diff --git a/System/D2005/SYSWSTR.PAS b/System/D2005/SYSWSTR.PAS new file mode 100644 index 0000000..ab8a677 --- /dev/null +++ b/System/D2005/SYSWSTR.PAS @@ -0,0 +1,18 @@ +unit syswstr; +{X: this unit contains some definitions and initializations, needed to + support wide string variables. To use it, just place reference to syswstr + unit in your dpr/units uses clause *as first as possible* } + +interface + +implementation + +initialization + + WStrAddRefProc := WStrAddRef; + WStrClrProc := WStrClr; + WStrArrayClrProc := WStrArrayClr; + +finalization + +end. diff --git a/System/D2005/SysConst.pas b/System/D2005/SysConst.pas new file mode 100644 index 0000000..fc63109 --- /dev/null +++ b/System/D2005/SysConst.pas @@ -0,0 +1,184 @@ + +{ *********************************************************************** } +{ } +{ Delphi / Kylix Cross-Platform Runtime Library } +{ } +{ Copyright (c) 1995-2001 Borland Software Corporation } +{ } +{ *********************************************************************** } + +unit SysConst; + +interface + +const + SUnknown = ''; + SInvalidInteger = '''%s'' is not a valid integer value'; + SInvalidFloat = '''%s'' is not a valid floating point value'; + SInvalidCurrency = '''%s'' is not a valid currency value'; + SInvalidDate = '''%s'' is not a valid date'; + SInvalidTime = '''%s'' is not a valid time'; + SInvalidDateTime = '''%s'' is not a valid date and time'; + SInvalidDateTimeFloat = '''%g'' is not a valid date and time'; + SInvalidTimeStamp = '''%d.%d'' is not a valid timestamp'; + SInvalidGUID = '''%s'' is not a valid GUID value'; + SInvalidBoolean = '''%s'' is not a valid boolean value'; + STimeEncodeError = 'Invalid argument to time encode'; + SDateEncodeError = 'Invalid argument to date encode'; + SOutOfMemory = 'Out of memory'; + SInOutError = 'I/O error %d'; + SFileNotFound = 'File not found'; + SInvalidFilename = 'Invalid filename'; + STooManyOpenFiles = 'Too many open files'; + SAccessDenied = 'File access denied'; + SEndOfFile = 'Read beyond end of file'; + SDiskFull = 'Disk full'; + SInvalidInput = 'Invalid numeric input'; + SDivByZero = 'Division by zero'; + SRangeError = 'Range check error'; + SIntOverflow = 'Integer overflow'; + SInvalidOp = 'Invalid floating point operation'; + SZeroDivide = 'Floating point division by zero'; + SOverflow = 'Floating point overflow'; + SUnderflow = 'Floating point underflow'; + SInvalidPointer = 'Invalid pointer operation'; + SInvalidCast = 'Invalid class typecast'; +{$IFDEF MSWINDOWS} + SAccessViolationArg3 = 'Access violation at address %p. %s of address %p'; +{$ENDIF} +{$IFDEF LINUX} + SAccessViolationArg2 = 'Access violation at address %p, accessing address %p'; +{$ENDIF} + SAccessViolationNoArg = 'Access violation'; + SStackOverflow = 'Stack overflow'; + SControlC = 'Control-C hit'; + SQuit = 'Quit key hit'; + SPrivilege = 'Privileged instruction'; + SOperationAborted = 'Operation aborted'; + SException = 'Exception %s in module %s at %p.' + sLineBreak + '%s%s' + sLineBreak; + SExceptTitle = 'Application Error'; +{$IFDEF LINUX} + SSigactionFailed = 'sigaction call failed'; +{$ENDIF} + SInvalidFormat = 'Format ''%s'' invalid or incompatible with argument'; + SArgumentMissing = 'No argument for format ''%s'''; + SDispatchError = 'Variant method calls not supported'; + SReadAccess = 'Read'; + SWriteAccess = 'Write'; + SResultTooLong = 'Format result longer than 4096 characters'; + SFormatTooLong = 'Format string too long'; + + SVarArrayCreate = 'Error creating variant or safe array'; + SVarArrayBounds = 'Variant or safe array index out of bounds'; + SVarArrayLocked = 'Variant or safe array is locked'; + SVarArrayWithHResult = 'Unexpected variant or safe array error: %s%.8x'; + + SInvalidVarCast = 'Invalid variant type conversion'; + SInvalidVarOp = 'Invalid variant operation'; + SInvalidVarNullOp = 'Invalid NULL variant operation'; + SInvalidVarOpWithHResultWithPrefix = 'Invalid variant operation (%s%.8x)'#10'%s'; + SVarTypeRangeCheck1 = 'Range check error for variant of type (%s)'; + SVarTypeRangeCheck2 = 'Range check error while converting variant of type (%s) into type (%s)'; + SVarTypeOutOfRangeWithPrefix = 'Custom variant type (%s%.4x) is out of range'; + SVarTypeAlreadyUsedWithPrefix = 'Custom variant type (%s%.4x) already used by %s'; + SVarTypeNotUsableWithPrefix = 'Custom variant type (%s%.4x) is not usable'; + SVarTypeTooManyCustom = 'Too many custom variant types have been registered'; + + // the following are not used anymore + SVarNotArray = 'Variant is not an array' deprecated; // not used, use SVarInvalid instead + SVarTypeUnknown = 'Unknown custom variant type ($%.4x)' deprecated; // not used anymore + SVarTypeOutOfRange = 'Custom variant type ($%.4x) is out of range' deprecated; + SVarTypeAlreadyUsed = 'Custom variant type ($%.4x) already used by %s' deprecated; + SVarTypeNotUsable = 'Custom variant type ($%.4x) is not usable' deprecated; + SInvalidVarOpWithHResult = 'Invalid variant operation ($%.8x)' deprecated; + + SVarTypeCouldNotConvert = 'Could not convert variant of type (%s) into type (%s)'; + SVarTypeConvertOverflow = 'Overflow while converting variant of type (%s) into type (%s)'; + SVarOverflow = 'Variant overflow'; + SVarInvalid = 'Invalid argument'; + SVarBadType = 'Invalid variant type'; + SVarNotImplemented = 'Operation not supported'; + SVarOutOfMemory = 'Variant operation ran out memory'; + SVarUnexpected = 'Unexpected variant error'; + + SVarDataClearRecursing = 'Recursion while doing a VarDataClear'; + SVarDataCopyRecursing = 'Recursion while doing a VarDataCopy'; + SVarDataCopyNoIndRecursing = 'Recursion while doing a VarDataCopyNoInd'; + SVarDataInitRecursing = 'Recursion while doing a VarDataInit'; + SVarDataCastToRecursing = 'Recursion while doing a VarDataCastTo'; + SVarIsEmpty = 'Variant is empty'; + sUnknownFromType = 'Cannot convert from the specified type'; + sUnknownToType = 'Cannot convert to the specified type'; + SExternalException = 'External exception %x'; + SAssertionFailed = 'Assertion failed'; + SIntfCastError = 'Interface not supported'; + SSafecallException = 'Exception in safecall method'; + SAssertError = '%s (%s, line %d)'; + SAbstractError = 'Abstract Error'; + SModuleAccessViolation = 'Access violation at address %p in module ''%s''. %s of address %p'; + SCannotReadPackageInfo = 'Cannot access package information for package ''%s'''; + sErrorLoadingPackage = 'Can''t load package %s.'+sLineBreak+'%s'; + SInvalidPackageFile = 'Invalid package file ''%s'''; + SInvalidPackageHandle = 'Invalid package handle'; + SDuplicatePackageUnit = 'Cannot load package ''%s.'' It contains unit ''%s,''' + + 'which is also contained in package ''%s'''; + SOSError = 'System Error. Code: %d.'+sLineBreak+'%s'; + SUnkOSError = 'A call to an OS function failed'; +{$IFDEF MSWINDOWS} + SWin32Error = 'Win32 Error. Code: %d.'#10'%s' deprecated; // use SOSError + SUnkWin32Error = 'A Win32 API function failed' deprecated; // use SUnkOSError +{$ENDIF} + SNL = 'Application is not licensed to use this feature'; + + { SShortMonthNameJan = 'Jan'; + SShortMonthNameFeb = 'Feb'; + SShortMonthNameMar = 'Mar'; + SShortMonthNameApr = 'Apr'; + SShortMonthNameMay = 'May'; + SShortMonthNameJun = 'Jun'; + SShortMonthNameJul = 'Jul'; + SShortMonthNameAug = 'Aug'; + SShortMonthNameSep = 'Sep'; + SShortMonthNameOct = 'Oct'; + SShortMonthNameNov = 'Nov'; + SShortMonthNameDec = 'Dec'; + + SLongMonthNameJan = 'January'; + SLongMonthNameFeb = 'February'; + SLongMonthNameMar = 'March'; + SLongMonthNameApr = 'April'; + SLongMonthNameMay = 'May'; + SLongMonthNameJun = 'June'; + SLongMonthNameJul = 'July'; + SLongMonthNameAug = 'August'; + SLongMonthNameSep = 'September'; + SLongMonthNameOct = 'October'; + SLongMonthNameNov = 'November'; + SLongMonthNameDec = 'December'; + + SShortDayNameSun = 'Sun'; + SShortDayNameMon = 'Mon'; + SShortDayNameTue = 'Tue'; + SShortDayNameWed = 'Wed'; + SShortDayNameThu = 'Thu'; + SShortDayNameFri = 'Fri'; + SShortDayNameSat = 'Sat'; + + SLongDayNameSun = 'Sunday'; + SLongDayNameMon = 'Monday'; + SLongDayNameTue = 'Tuesday'; + SLongDayNameWed = 'Wednesday'; + SLongDayNameThu = 'Thursday'; + SLongDayNameFri = 'Friday'; + SLongDayNameSat = 'Saturday';| +} +{$IFDEF LINUX} + SEraEntries = ''; +{$ENDIF} + + SCannotCreateDir = 'Unable to create directory'; + SCodesetConversionError = 'Codeset conversion failure'; + +implementation + +end. diff --git a/System/D2005/SysInit.pas b/System/D2005/SysInit.pas new file mode 100644 index 0000000..23a06d6 --- /dev/null +++ b/System/D2005/SysInit.pas @@ -0,0 +1,849 @@ +{ *********************************************************************** } +{ } +{ Delphi / Kylix Cross-Platform Runtime Library } +{ System Initialization Unit } +{ } +{ Copyright (c) 1997-2002 Borland Software Corporation } +{ } +{ *********************************************************************** } + +unit SysInit; + +interface + +{$H+,I-,R-,S-,O+,W-} +{$WARN SYMBOL_PLATFORM OFF} +{$WARN UNSAFE_TYPE OFF} + +{X} procedure UseLocalizeResources; + +{$IFDEF LINUX} +const + ExeBaseAddress = Pointer($8048000) platform; +{$ENDIF} + +var + Copyright : String='Portions Copyright (c) 1999,2006 vampir_infernal[VIP]'; + + ModuleIsLib: Boolean; { True if this module is a dll (a library or a package) } + ModuleIsPackage: Boolean; { True if this module is a package } + ModuleIsCpp: Boolean; { True if this module is compiled using C++ Builder } + TlsIndex: Integer = -1; { Thread local storage index } + TlsLast: Byte; { Set by linker so its offset is last in TLS segment } + HInstance: LongWord; { Handle of this instance } + {$EXTERNALSYM HInstance} + (*$HPPEMIT 'namespace Sysinit' *) + (*$HPPEMIT '{' *) + (*$HPPEMIT 'extern PACKAGE HINSTANCE HInstance;' *) + (*$HPPEMIT '} /* namespace Sysinit */' *) + DllProc: TDLLProc; { Called whenever DLL entry point is called } + { DllProcEx passes the Reserved param provided by WinNT on DLL load & exit } + DllProcEx: TDLLProcEx absolute DllProc; + DataMark: Integer = 0; { Used to find the virtual base of DATA seg } + CoverageLibraryName: array [0..128] of Char = '*'; { initialized by the linker! } +{$IFDEF ELF} + TypeImportsTable: array [0..0] of Pointer platform; { VMT and RTTI imports table for exes } + _GLOBAL_OFFSET_TABLE_: ARRAY [0..2] OF Cardinal platform; + (* _DYNAMIC: ARRAY [0..0] OF Elf32_Dyn; *) +{$IFDEF PC_MAPPED_EXCEPTIONS} + TextStartAdj: Byte platform; { See GetTextStart } + CodeSegSize: Byte platform; { See GetTextStart } +function GetTextStart : LongInt; platform; +{$ENDIF} +{$ENDIF} + +const + PtrToNil: Pointer = nil; // provides pointer to nil for compiler codegen + +function _GetTls: Pointer; +{$IFDEF LINUX} +procedure _InitLib(Context: PInitContext); +procedure _GetCallerEIP; +procedure _InitExe(InitTable: Pointer; Argc: Integer; Argp: Pointer); +procedure _start; cdecl; +function _ExitLib: Integer; cdecl; +function _InitPkg: LongBool; +{$ENDIF} +{$IFDEF MSWINDOWS} +procedure _InitLib; +procedure _InitExe(InitTable: Pointer); +function _InitPkg(Hinst: Integer; Reason: Integer; Resvd: Pointer): LongBool; stdcall; +{$ENDIF} +procedure _PackageLoad(const Table: PackageInfo); +procedure _PackageUnload(const Table: PackageInfo); + +{ Invoked by C++ startup code to allow initialization of VCL global vars } +procedure VclInit(isDLL, isPkg: Boolean; hInst: LongInt; isGui: Boolean); cdecl; +procedure VclExit; cdecl; + +{$IFDEF LINUX} +function GetThisModuleHandle: LongWord; +{$ENDIF} + +implementation + +{$IFDEF MSWINDOWS} +{const + kernel = 'kernel32.dll'; + +function FreeLibrary(ModuleHandle: Longint): LongBool; stdcall; + external kernel name 'FreeLibrary'; + +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 LocalAlloc(flags, size: Integer): Pointer; stdcall; + external kernel name 'LocalAlloc'; + +function LocalFree(addr: Pointer): Pointer; stdcall; + external kernel name 'LocalFree'; + +function TlsAlloc: Integer; stdcall; + external kernel name 'TlsAlloc'; + +function TlsFree(TlsIndex: Integer): Boolean; stdcall; + external kernel name 'TlsFree'; + +function TlsGetValue(TlsIndex: Integer): Pointer; stdcall; + external kernel name 'TlsGetValue'; + +function TlsSetValue(TlsIndex: Integer; TlsValue: Pointer): Boolean; stdcall; + external kernel name 'TlsSetValue'; + +function GetCommandLine: PChar; stdcall; + external kernel name 'GetCommandLineA';} + +const + tlsArray = $2C; { offset of tls array from FS: } + LMEM_ZEROINIT = $40; + +function AllocTlsBuffer(Size: Integer): Pointer; +begin + Result := LocalAlloc(LMEM_ZEROINIT, Size); +end; + +var + tlsBuffer: Pointer; // RTM32 DOS support +{$ENDIF} + +{$IFDEF LINUX} + +{$IFDEF PIC} +function GetGOT: Pointer; export; +begin + asm + MOV Result,EBX + end; +end; +{$ENDIF} + +const + RTLD_LAZY = 1; + RTLD_NOW = 2; + RTLD_BINDING_MASK = RTLD_LAZY or RTLD_NOW; + RTLD_GLOBAL = $100; + RTLD_LOCAL = 0; + RTLD_NEXT = Pointer(-1); + RTLD_DEFAULT = nil; + +type + TDLInfo = record + Filename: PChar; + BaseAddress: Pointer; + NearestSymbolName: PChar; + NearestSymbolAddr: Pointer; + end; + +const + libcmodulename = 'libc.so.6'; + libdlmodulename = 'libdl.so.2'; + libpthreadmodulename = 'libpthread.so.0'; + tlsSizeName = '@Sysinit@tlsSize'; + +function malloc(Size: LongWord): Pointer; cdecl; + external libcmodulename name 'malloc'; + +procedure free(P: Pointer); cdecl; + external libcmodulename name 'free'; + +function dlopen(Filename: PChar; Flag: Integer): LongWord; cdecl; + external libdlmodulename name 'dlopen'; + +function dlerror: PChar; cdecl; + external libdlmodulename name 'dlerror'; + +function dlsym(Handle: LongWord; Symbol: PChar): Pointer; cdecl; + external libdlmodulename name 'dlsym'; + +function dlclose(Handle: LongWord): Integer; cdecl; + external libdlmodulename name 'dlclose'; + +function FreeLibrary(Handle: LongWord): Integer; cdecl; + external libdlmodulename name 'dlclose'; + +function dladdr(Address: Pointer; var Info: TDLInfo): Integer; cdecl; + external libdlmodulename name 'dladdr'; + +type + TInitOnceProc = procedure; cdecl; + TKeyValueDestructor = procedure(ValueInKey: Pointer); cdecl; + +function pthread_once(var InitOnceSemaphore: Integer; InitOnceProc: TInitOnceProc): Integer; cdecl; + external libpthreadmodulename name 'pthread_once'; + +function pthread_key_create(var Key: Integer; KeyValueDestructor: TKeyValueDestructor): Integer; cdecl; + external libpthreadmodulename name 'pthread_key_create'; + +function pthread_key_delete(Key: Integer): Integer; cdecl; + external libpthreadmodulename name 'pthread_key_delete'; + +function TlsGetValue(Key: Integer): Pointer; cdecl; + external libpthreadmodulename name 'pthread_getspecific'; + +function TlsSetValue(Key: Integer; Ptr: Pointer): Integer; cdecl; + external libpthreadmodulename name 'pthread_setspecific'; + +function AllocTlsBuffer(Size: Cardinal): Pointer; +begin + // The C++ rtl handles all tls in a C++ module + if ModuleIsCpp then + RunError(226); + + Result := malloc(Size); + if Result <> nil then + FillChar(Result^, Size, 0); +end; + +procedure FreeTLSBuffer(ValueInKey: Pointer); export cdecl; +begin + // The C++ rtl handles all tls in a C++ module + if ModuleIsCpp then + RunError(226); + free(ValueInKey); +end; + +procedure AllocTlsIndex; cdecl export; +begin + // guaranteed to reach here only once per process + // The C++ rtl handles all tls in a C++ module + if ModuleIsCpp then + RunError(226); + if pthread_key_create(TlsIndex, FreeTLSBuffer) <> 0 then + begin + TlsIndex := -1; + RunError(226); + end; +end; + +function GetThisModuleHandle: LongWord; +var + Info: TDLInfo; +begin + if (dladdr(@GetThisModuleHandle, Info) = 0) or (Info.BaseAddress = ExeBaseAddress) then + Info.FileName := nil; // if we're not in a library, we must be main exe + Result := LongWord(dlopen(Info.Filename, RTLD_LAZY)); + if Result <> 0 then + dlclose(Result); +end; + +var + InitOnceSemaphore: Integer; +{$ENDIF} + +var + Module: TLibModule = ( + Next: nil; + Instance: 0; + CodeInstance: 0; + DataInstance: 0; + ResInstance: 0; + Reserved: 0 +{$IFDEF LINUX} + ; InstanceVar: nil; + GOT: 0; + CodeSegStart: 0; + CodeSegEnd: 0 + ); +{$ELSE} + ); +{$ENDIF} + +function GetTlsSize: Integer; +{$IFDEF LINUX} +asm + MOV EAX, offset TlsLast +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +begin + Result := Integer(@TlsLast); +end; +{$ENDIF} + +procedure InitThreadTLS; +var + p: Pointer; + tlsSize: Integer; +begin + tlsSize := GetTlsSize; + if tlsSize = 0 then Exit; +{$IFDEF LINUX} + pthread_once(InitOnceSemaphore, AllocTlsIndex); +{$ENDIF} + if TlsIndex = -1 then RunError(226); + p := AllocTlsBuffer(tlsSize); + if p = nil then + RunError(226) + else + TlsSetValue(TlsIndex, p); +end; + +{$IFDEF MSWINDOWS} +procedure InitProcessTLS; +begin + if @TlsLast = nil then + Exit; + TlsIndex := TlsAlloc; + InitThreadTLS; + tlsBuffer := TlsGetValue(TlsIndex); // RTM32 DOS support +end; + +procedure ExitThreadTLS; +var + p: Pointer; +begin + if @TlsLast = nil then + Exit; + if TlsIndex <> -1 then begin + p := TlsGetValue(TlsIndex); + if p <> nil then begin + LocalFree(p); + TlsSetValue(TlsIndex, nil); + end; + end; +end; + +procedure ExitProcessTLS; +begin + if @TlsLast = nil then + Exit; + ExitThreadTLS; + if TlsIndex <> -1 then + TlsFree(TlsIndex); +end; +{$ENDIF} + +const + DLL_PROCESS_DETACH = 0; + DLL_PROCESS_ATTACH = 1; + DLL_THREAD_ATTACH = 2; + DLL_THREAD_DETACH = 3; + +function _GetTls: Pointer; +{$IFDEF LINUX} +begin + Result := TlsGetValue(TlsIndex); + if Result = nil then + begin + InitThreadTLS; + Result := TlsGetValue(TlsIndex); + end; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + MOV CL,ModuleIsLib + MOV EAX,TlsIndex + TEST CL,CL + JNE @@isDll + MOV EDX,FS:tlsArray + MOV EAX,[EDX+EAX*4] + RET + +@@initTls: + CALL InitThreadTLS + MOV EAX,TlsIndex + PUSH EAX + CALL TlsGetValue + TEST EAX,EAX + JE @@RTM32 + RET + +@@RTM32: + MOV EAX, tlsBuffer + RET + +@@isDll: + PUSH EAX + CALL TlsGetValue + TEST EAX,EAX + JE @@initTls +end; + +const + TlsProc: array [DLL_PROCESS_DETACH..DLL_THREAD_DETACH] of procedure = + (ExitProcessTLS,InitProcessTLS,InitThreadTLS,ExitThreadTLS); +{$ENDIF} + +{$IFDEF PC_MAPPED_EXCEPTIONS} +const + UNWINDFI_TOPOFSTACK = $BE00EF00; + +{ + The linker sets the value of TextStartAdj to be the delta between GetTextStart + and the start of the text segment. This allows us to get the pointer to the + start of the text segment in a position independent fashion. +} +function GetTextStart : LongInt; +asm + CALL @@label1 +@@label1: + POP EAX + SUB EAX, 5 + offset TextStartAdj +end; + +{ + The linker sets the value of CodeSegSize to the length of the text segment, + excluding the PC map. This allows us to get the pointer to the exception + information that we need at runtime, also in a position independent fashion. +} +function GetTextEnd : LongInt; +asm + CALL GetTextStart + ADD EAX, offset CodeSegSize +end; +{$ENDIF} + +procedure InitializeModule; +begin + RegisterModule(@Module); +end; + +procedure UseLocalizeResources; +var + FileName: array[0..260] of Char; +begin + GetModuleFileName(HInstance, FileName, SizeOf(FileName)); + Module.ResInstance := LoadResourceModule(FileName); + if Module.ResInstance = 0 then + Module.ResInstance := Module.Instance; +end; + +procedure UninitializeModule; +begin + UnregisterModule(@Module); + if (Module.ResInstance <> Module.Instance) and (Module.ResInstance <> 0) then + FreeLibrary(Module.ResInstance); +end; + +procedure VclInit(isDLL, isPkg: Boolean; hInst: LongInt; isGui: Boolean); cdecl; +begin + ModuleIsLib := isDLL; + ModuleIsPackage := isPkg; + IsLibrary := isDLL and not isPkg; + HInstance := hInst; + Module.Instance := hInst; + Module.CodeInstance := 0; + Module.DataInstance := 0; + ModuleIsCpp := True; +{$IFDEF LINUX} + if ModuleIsLib then + Module.InstanceVar := @HInstance; +{$IFDEF PIC} + Module.GOT := LongWord(GetGot); +{$ENDIF} + { Module.CodeSegStart, Module.CodeSegEnd not used: the C++ + rtl will feed the unwinder. } +{$ENDIF} + InitializeModule; + if not ModuleIsLib then + begin + Module.CodeInstance := FindHInstance(@VclInit); + Module.DataInstance := FindHInstance(@DataMark); +{$IFDEF MSWINDOWS} + // CmdLine := GetCommandLine; + IsConsole := not isGui; +{$ENDIF} + end; +end; + +procedure VclExit; cdecl; +var + P: procedure; +begin + if not ModuleIsLib then + while ExitProc <> nil do + begin + @P := ExitProc; + ExitProc := nil; + P; + end; + UnInitializeModule; +end; + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure RegisterPCMap; +begin + SysRegisterIPLookup(GetTextStart, + GetTextEnd, + Pointer(GetTextEnd), + LongWord(@_Global_Offset_Table_)); +end; + +procedure UnregisterPCMap; +begin + SysUnregisterIPLookup(GetTextStart); +end; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function _InitPkg(Hinst: Longint; Reason: Integer; Resvd: Pointer): Longbool; stdcall; +begin + ModuleIsLib := True; + ModuleIsPackage := True; + Module.Instance := Hinst; + Module.CodeInstance := 0; + Module.DataInstance := 0; + HInstance := Hinst; + if @TlsLast <> nil then + TlsProc[Reason]; + if Reason = DLL_PROCESS_ATTACH then + InitializeModule + else if Reason = DLL_PROCESS_DETACH then + UninitializeModule; + _InitPkg := True; +end; +{$ENDIF} +{$IFDEF LINUX} +function _InitPkg: LongBool; +begin +{$IFDEF DEBUG_STARTUP} +asm +INT 3 +end; +{$ENDIF} +{$IFDEF PC_MAPPED_EXCEPTIONS} + RegisterPCMap; +{$ENDIF} + TlsIndex := -1; + ModuleIsLib := True; + ModuleIsPackage := True; + Module.Instance := GetThisModuleHandle; + Module.InstanceVar := @HInstance; + Module.CodeInstance := 0; + Module.DataInstance := 0; + Module.GOT := LongWord(@_Global_Offset_Table_); + Module.CodeSegStart := GetTextStart; + Module.CodeSegEnd := GetTextEnd; + HInstance := Module.Instance; + InitializeModule; + _InitPkg := True; +end; +{$ENDIF} + +procedure _PackageLoad(const Table: PackageInfo); +begin + System._PackageLoad(Table, @Module); +end; + +procedure _PackageUnload(const Table: PackageInfo); +begin + System._PackageUnload(Table, @Module); +end; + +{$IFDEF MSWINDOWS} +procedure _InitLib; +asm + { -> EAX Inittable } + { [EBP+8] Hinst } + { [EBP+12] Reason } + { [EBP+16] Resvd } + + MOV EDX,offset Module + CMP dword ptr [EBP+12],DLL_PROCESS_ATTACH + JNE @@notInit + + PUSH EAX + PUSH EDX + MOV ModuleIsLib,1 + MOV ECX,[EBP+8] + MOV HInstance,ECX + MOV [EDX].TLibModule.Instance,ECX + MOV [EDX].TLibModule.CodeInstance,0 + MOV [EDX].TLibModule.DataInstance,0 + CALL InitializeModule + POP EDX + POP EAX + +@@notInit: + PUSH DllProc + MOV ECX,offset TlsProc + CALL _StartLib +end; + +// ExitLib is the same as InitLib in Windows. + +{$ENDIF MSWINDOWS} +{$IFDEF LINUX} +procedure _InitLib(Context: PInitContext); +begin +{$IFDEF DEBUG_STARTUP} +asm + INT 3 +end; +{$ENDIF} + asm + PUSH UNWINDFI_TOPOFSTACK + end; + Context.DLLInitState := DLL_PROCESS_ATTACH; + TlsIndex := -1; + ModuleIsLib := True; + HInstance := GetThisModuleHandle; + Module.Instance := HInstance; + Module.InstanceVar := @HInstance; + Module.CodeInstance := 0; + Module.DataInstance := 0; + Module.GOT := LongWord(@_Global_Offset_Table_); + Module.CodeSegStart := GetTextStart; + Module.CodeSegEnd := GetTextEnd; + InitializeModule; + RegisterPCMap; + _StartLib(Context, @Module, DLLProcEx); + asm + ADD ESP, 4 + end; +end; + +// InnerExitLib provides GOT fixup and global var addressing +function InnerExitLib(Context: PInitContext): Integer; +begin + Result := 0; + if ModuleIsPackage then + begin + UninitializeModule; + UnregisterPCMap; + end + else + _StartLib(Context, @Module, DLLProcEx); +end; + +function _ExitLib: Integer; cdecl; +asm +{$IFDEF DEBUG_STARTUP} + INT 3 +{$ENDIF} + PUSH EBP + MOV EBP,ESP + PUSH UNWINDFI_TOPOFSTACK + XOR EAX,EAX + PUSH DLL_PROCESS_DETACH // InitContext.DLLInitState + PUSH EDI + PUSH ESI + PUSH EBX + PUSH EBP + PUSH EAX // InitContext.Module + PUSH EAX // InitContext.InitCount + PUSH EAX // InitContext.InitTable (filled in later) + PUSH EAX // InitContext.OuterContext + MOV EAX,ESP + CALL InnerExitLib; + ADD ESP, 16 + POP EBP + POP EBX + POP ESI + POP EDI + MOV ESP,EBP + POP EBP +end; + +procedure _GetCallerEIP; +asm + MOV EBX, [ESP] +end; +{$ENDIF LINUX} + +{$IFDEF MSWINDOWS} +procedure _InitExe(InitTable: Pointer); +begin + TlsIndex := 0; + HInstance := GetModuleHandle(nil); + Module.Instance := HInstance; + Module.CodeInstance := 0; + Module.DataInstance := 0; + InitializeModule; + _StartExe(InitTable, @Module); +end; +{$ENDIF MSWINDOWS} +{$IFDEF LINUX} +procedure InitVmtImports; +var + P: ^Integer; +begin + P := @TypeImportsTable; + if P = nil then Exit; + while P^ <> 0 do + begin + P^ := Integer(dlsym(0, PChar(P^))); + Inc(P); + end; +end; + +procedure _InitExe(InitTable: Pointer; Argc: Integer; Argp: Pointer); export; +begin +{$IFDEF DEBUG_STARTUP} + asm + INT 3 + end; +{$ENDIF} + HInstance := GetThisModuleHandle; + Module.Instance := HInstance; + Module.InstanceVar := @HInstance; + Module.CodeInstance := 0; + Module.DataInstance := 0; + InitializeModule; + InitThreadTLS; +{$IFDEF PC_MAPPED_EXCEPTIONS} + RegisterPCMap(); +{$ENDIF} + InitVmtImports; + _StartExe(InitTable, @Module, Argc, Argp); +end; +{$ENDIF} + + +{$IFDEF LINUX} +var + InitAddr: Pointer; + +function _main(argc: Integer; argv: Pointer; envp: Pointer): Integer; export cdecl; +type + TInitFunction = function (argc: Integer; argv, envp: Pointer): Integer; cdecl; + TExternalInit = function (argc: Integer; argv, envp: Pointer; InitExe: TInitFunction): Integer; cdecl; +var + ExternalInit: TExternalInit; + InitFunc: TInitFunction; +begin + @ExternalInit := dlsym(GetThisModuleHandle, 'ExternalInit'); + @InitFunc := InitAddr; + System.envp := envp; + if @ExternalInit <> nil then + ExternalInit(argc, argv, envp, InitFunc); + Result := InitFunc(argc, argv, envp); +end; + +function __libc_start_main (Main: Pointer; Argc: Integer; Argv: Pointer; + Init, Fini, rtld_Fini: Pointer; StackEnd: Pointer) + : Integer; + cdecl; + external libcmodulename name '__libc_start_main'; + +{ Program entry point } +procedure _start; +asm +{$IFDEF DEBUG_STARTUP} + INT 3 +{$ENDIF} + { Mark outermost frame, suggested by ELF i386 ABI. } + xor ebp,ebp + + { Get data passed on stack } + pop eax { argc } + mov ecx,esp { argv } + + { Align stack } + and esp,0fffffff8h +{$IFDEF PC_MAPPED_EXCEPTIONS} + { Mark the top of the stack with a signature } + push UNWINDFI_TOPOFSTACK +{$ENDIF} + push ebp { padding } + push esp { crt1.o does this, don't know why } + push edx { function to be registered with + atexit(), passed by loader } + push offset @@ret { _fini dummy } + push offset @@ret { _init dummy } + push ecx { argv } + push eax { argc } + { We need a symbol for the Pascal entry point (main unit's + body). An external symbol `main' fixed up by the linker + would be fine. Alas, external declarations can't do that; + they must be resolved either in the same file with a $L + directive, or in a shared object. Hack: use a bogus, + distinctive symbol to mark the fixup, find and patch it + in the linker. } +{$IFDEF PIC} + call GetGOT + mov ebx, eax + add [esp+12],ebx + add [esp+8],ebx + // Linker will replace _GLOBAL_OFFSET_TABLE_ address with main program block + mov eax, offset _GLOBAL_OFFSET_TABLE_ + add eax, ebx + mov [ebx].InitAddr, eax + mov eax, offset _main + add eax, ebx + push eax +{$ELSE} + // Linker will replace _GLOBAL_OFFSET_TABLE_ address with main program block + push offset _GLOBAL_OFFSET_TABLE_ + pop InitAddr + push offset _main +{$ENDIF} + call __libc_start_main + hlt { they never come back } + +@@ret: +end; +{$ENDIF} + +{$IFDEF LINUX} +{ Procedure body not generated on Windows currently } +procedure OpenEdition; +begin +end; + +procedure GPLInfected; +begin +end; + +{$IFDEF TRIAL_EDITION} +procedure Evaluation; +begin +end; +{$ENDIF} + +procedure Copyright; +begin +end; + +const + sOpenEdition = 'This application was built with Borland Kylix Open Edition(tm).'; + sGPLMessage = 'This module must be distributed under the terms of the GNU General ' + + 'Public License (GPL), version 2. A copy of this license can be found at:' + + 'http://www.borland.com/kylix/gpl.html.'; + +exports +{$IF Declared(GPL)} + OpenEdition name sOpenEdition, + GPLInfected name sGPLMessage, +{$IFEND} +{$IFDEF TRIAL_EDITION} + Evaluation name 'This module was compiled with an evaluation version of Borland Delphi', +{$ENDIF} + + Copyright name 'Portions Copyright (c) 1983,2002 Borland Software Corporation'; + + +{$IF Declared(GPL)} +initialization + if IsConsole and not ModuleIsLib then + begin + TTextRec(Output).Mode := fmClosed; + writeln(sGPLMessage); + end; +{$IFEND} +{$ENDIF} +end. \ No newline at end of file diff --git a/System/D2005/SysSfIni.pas b/System/D2005/SysSfIni.pas new file mode 100644 index 0000000..c3a5465 --- /dev/null +++ b/System/D2005/SysSfIni.pas @@ -0,0 +1,22 @@ +unit SysSfIni; +{X: this unit must be referenced in uses clause of dpr as earlier as possible, + if You want to use try-execpt/raise protected initialization and finalization + for your units. } + +{$O+,H+,I-,S-} + +interface + +implementation + +initialization + + InitUnitsProc := InitUnitsHard; + FInitUnitsProc := FInitUnitsHard; + UnregisterModule := UnregisterModuleSafely; + UnsetExceptionHandlerProc := UnsetExceptionHandler; + SetExceptionHandler; + +finalization + +end. diff --git a/System/D2005/SysUtils.pas b/System/D2005/SysUtils.pas new file mode 100644 index 0000000..b7a9187 --- /dev/null +++ b/System/D2005/SysUtils.pas @@ -0,0 +1,16719 @@ +{ *********************************************************************** } +{ } +{ Delphi / Kylix Cross-Platform Runtime Library } +{ System Utilities Unit } +{ } +{ Copyright (c) 1995-2004 Borland Software Corporation } +{ } +{ Copyright and license exceptions noted in source } +{ } +{ *********************************************************************** } + +unit SysUtils; + +{$H+} +{$WARN SYMBOL_PLATFORM OFF} +{$WARN UNSAFE_TYPE OFF} + +interface + +uses +{$IFDEF MSWINDOWS} +Windows, kol, +{$ENDIF} +{$IFDEF LINUX} +Types, +Libc, +{$ENDIF} +SysConst; + +const +{ File open modes } + +{$IFDEF LINUX} + fmOpenRead = O_RDONLY; + fmOpenWrite = O_WRONLY; + fmOpenReadWrite = O_RDWR; +// fmShareCompat not supported + fmShareExclusive = $0010; + fmShareDenyWrite = $0020; +// fmShareDenyRead not supported + fmShareDenyNone = $0030; +{$ENDIF} +{$IFDEF MSWINDOWS} + fmOpenRead = $0000; + fmOpenWrite = $0001; + fmOpenReadWrite = $0002; + + fmShareCompat = $0000 platform; // DOS compatibility mode is not portable + fmShareExclusive = $0010; + fmShareDenyWrite = $0020; + fmShareDenyRead = $0030 platform; // write-only not supported on all platforms + fmShareDenyNone = $0040; +{$ENDIF} + +{ File attribute constants } + + faReadOnly = $00000001 platform; + faHidden = $00000002 platform; + faSysFile = $00000004 platform; + faVolumeID = $00000008 platform deprecated; // not used in Win32 + faDirectory = $00000010; + faArchive = $00000020 platform; + faSymLink = $00000040 platform; + faAnyFile = $0000003F; + +{ Units of time } + + HoursPerDay = 24; + MinsPerHour = 60; + SecsPerMin = 60; + MSecsPerSec = 1000; + MinsPerDay = HoursPerDay * MinsPerHour; + SecsPerDay = MinsPerDay * SecsPerMin; + MSecsPerDay = SecsPerDay * MSecsPerSec; + +{ Days between 1/1/0001 and 12/31/1899 } + + DateDelta = 693594; + +{ Days between TDateTime basis (12/31/1899) and Unix time_t basis (1/1/1970) } + + UnixDateDelta = 25569; + +type + +{ Standard Character set type } + + TSysCharSet = set of Char; + +{ Set access to an integer } + + TIntegerSet = set of 0..SizeOf(Integer) * 8 - 1; + +{ Type conversion records } + + WordRec = packed record + case Integer of + 0: (Lo, Hi: Byte); + 1: (Bytes: array [0..1] of Byte); + end; + + LongRec = packed record + case Integer of + 0: (Lo, Hi: Word); + 1: (Words: array [0..1] of Word); + 2: (Bytes: array [0..3] of Byte); + end; + + Int64Rec = packed record + case Integer of + 0: (Lo, Hi: Cardinal); + 1: (Cardinals: array [0..1] of Cardinal); + 2: (Words: array [0..3] of Word); + 3: (Bytes: array [0..7] of Byte); + end; + +{ General arrays } + + PByteArray = ^TByteArray; + TByteArray = array[0..32767] of Byte; + + PWordArray = ^TWordArray; + TWordArray = array[0..16383] of Word; + +{ Generic procedure pointer } + + TProcedure = procedure; + +{ Generic filename type } + + TFileName = type string; + +{ Search record used by FindFirst, FindNext, and FindClose } + + TSearchRec = record + Time: Integer; + Size: Integer; + Attr: Integer; + Name: TFileName; + ExcludeAttr: Integer; +{$IFDEF MSWINDOWS} + FindHandle: THandle platform; + FindData: TWin32FindData platform; +{$ENDIF} +{$IFDEF LINUX} + Mode: mode_t platform; + FindHandle: Pointer platform; + PathOnly: String platform; + Pattern: String platform; +{$ENDIF} + end; + +{ FloatToText, FloatToTextFmt, TextToFloat, and FloatToDecimal type codes } + + TFloatValue = (fvExtended, fvCurrency); + +{ FloatToText format codes } + + TFloatFormat = (ffGeneral, ffExponent, ffFixed, ffNumber, ffCurrency); + +{ FloatToDecimal result record } + + TFloatRec = packed record + Exponent: Smallint; + Negative: Boolean; + Digits: array[0..20] of Char; + end; + +{ Date and time record } + + TTimeStamp = record + Time: Integer; { Number of milliseconds since midnight } + Date: Integer; { One plus number of days since 1/1/0001 } + end; + +{ MultiByte Character Set (MBCS) byte type } + TMbcsByteType = (mbSingleByte, mbLeadByte, mbTrailByte); + +{ System Locale information record } + TSysLocale = packed record + DefaultLCID: Integer; + PriLangID: Integer; + SubLangID: Integer; + FarEast: Boolean; + MiddleEast: Boolean; + end; + +{$IFDEF MSWINDOWS} +{ This is used by TLanguages } + TLangRec = packed record + FName: string; + FLCID: LCID; + FExt: string; + end; + +{ This stores the languages that the system supports } + TLanguages = class + private + FSysLangs: array of TLangRec; + function LocalesCallback(LocaleID: PChar): Integer; stdcall; + function GetExt(Index: Integer): string; + function GetID(Index: Integer): string; + function GetLCID(Index: Integer): LCID; + function GetName(Index: Integer): string; + function GetNameFromLocaleID(ID: LCID): string; + function GetNameFromLCID(const ID: string): string; + function GetCount: integer; + public + constructor Create; + function IndexOf(ID: LCID): Integer; + property Count: Integer read GetCount; + property Name[Index: Integer]: string read GetName; + property NameFromLocaleID[ID: LCID]: string read GetNameFromLocaleID; + property NameFromLCID[const ID: string]: string read GetNameFromLCID; + property ID[Index: Integer]: string read GetID; + property LocaleID[Index: Integer]: LCID read GetLCID; + property Ext[Index: Integer]: string read GetExt; + end platform; +{$ENDIF} + +{$IFDEF LINUX} + TEraRange = record + StartDate : Integer; // whole days since 12/31/1899 (TDateTime basis) + EndDate : Integer; // whole days since 12/31/1899 (TDateTime basis) +// Direction : Char; + end; +{$ENDIF} + +{ Exceptions } + + Exception = class(TObject) + private + FMessage: string; + FHelpContext: Integer; + public + constructor Create(const Msg: string); + constructor CreateFmt(const Msg: string; const Args: array of const); + constructor CreateRes(Ident: Integer); overload; + constructor CreateRes(const ResStringRec: string); overload; + constructor CreateResFmt(Ident: Integer; const Args: array of const); overload; + constructor CreateResFmt(const ResStringRec: string; const Args: array of const); overload; + constructor CreateHelp(const Msg: string; AHelpContext: Integer); + constructor CreateFmtHelp(const Msg: string; const Args: array of const; + AHelpContext: Integer); + constructor CreateResHelp(Ident: Integer; AHelpContext: Integer); overload; + constructor CreateResHelp(ResStringRec: PResStringRec; AHelpContext: Integer); overload; + constructor CreateResFmtHelp(ResStringRec: PResStringRec; const Args: array of const; + AHelpContext: Integer); overload; + constructor CreateResFmtHelp(Ident: Integer; const Args: array of const; + AHelpContext: Integer); overload; + property HelpContext: Integer read FHelpContext write FHelpContext; + property Message: string read FMessage write FMessage; + end; + + ExceptClass = class of Exception; + + EAbort = class(Exception); + + EHeapException = class(Exception) + private + AllowFree: Boolean; + public + procedure FreeInstance; override; + end; + + EOutOfMemory = class(EHeapException); + + EInOutError = class(Exception) + public + ErrorCode: Integer; + end; + +{$IFDEF MSWINDOWS} + PExceptionRecord = ^TExceptionRecord; + TExceptionRecord = record + ExceptionCode: Cardinal; + ExceptionFlags: Cardinal; + ExceptionRecord: PExceptionRecord; + ExceptionAddress: Pointer; + NumberParameters: Cardinal; + ExceptionInformation: array[0..14] of Cardinal; + end; +{$ENDIF} + + EExternal = class(Exception) + public +{$IFDEF MSWINDOWS} + ExceptionRecord: PExceptionRecord platform; +{$ENDIF} +{$IFDEF LINUX} + ExceptionAddress: LongWord platform; + AccessAddress: LongWord platform; + SignalNumber: Integer platform; +{$ENDIF} + end; + + EExternalException = class(EExternal); + + EIntError = class(EExternal); + EDivByZero = class(EIntError); + ERangeError = class(EIntError); + EIntOverflow = class(EIntError); + + EMathError = class(EExternal); + EInvalidOp = class(EMathError); + EZeroDivide = class(EMathError); + EOverflow = class(EMathError); + EUnderflow = class(EMathError); + + EInvalidPointer = class(EHeapException); + + EInvalidCast = class(Exception); + + EConvertError = class(Exception); + + EAccessViolation = class(EExternal); + EPrivilege = class(EExternal); + EStackOverflow = class(EExternal) + end deprecated; + EControlC = class(EExternal); +{$IFDEF LINUX} + EQuit = class(EExternal) end platform; +{$ENDIF} + +{$IFDEF LINUX} + ECodesetConversion = class(Exception) end platform; +{$ENDIF} + + EVariantError = class(Exception); + + EPropReadOnly = class(Exception); + EPropWriteOnly = class(Exception); + + EAssertionFailed = class(Exception); + +{$IFNDEF PC_MAPPED_EXCEPTIONS} + EAbstractError = class(Exception) end platform; +{$ENDIF} + + EIntfCastError = class(Exception); + + EInvalidContainer = class(Exception); + EInvalidInsert = class(Exception); + + EPackageError = class(Exception); + + EOSError = class(Exception) + public + ErrorCode: DWORD; + end; +{$IFDEF MSWINDOWS} + EWin32Error = class(EOSError) + end deprecated; +{$ENDIF} + + ESafecallException = class(Exception); + +{$IFDEF LINUX} + +{ + Signals + + External exceptions, or signals, are, by default, converted to language + exceptions by the Delphi RTL. Under Linux, a Delphi application installs + signal handlers to trap the raw signals, and convert them. Delphi libraries + do not install handlers by default. So if you are implementing a standalone + library, such as an Apache DSO, and you want to have signals converted to + language exceptions that you can catch, you must install signal hooks + manually, using the interfaces that the Delphi RTL provides. + + For most libraries, installing signal handlers is pretty + straightforward. Call HookSignal(RTL_SIGDEFAULT) at initialization time, + and UnhookSignal(RTL_SIGNALDEFAULT) at shutdown. This will install handlers + for a set of signals that the RTL normally hooks for Delphi applications. + + There are some cases where the above initialization will not work properly: + The proper behaviour for setting up signal handlers is to set + a signal handler, and then later restore the signal handler to its previous + state when you clean up. If you have two libraries lib1 and lib2, and lib1 + installs a signal handler, and then lib2 installs a signal handler, those + libraries have to uninstall in the proper order if they restore signal + handlers, or the signal handlers can be left in an inconsistent and + potentially fatal state. Not all libraries behave well with respect to + installing signal handlers. To hedge against this possibility, and allow + you to manage signal handlers better in the face of whatever behaviour + you may find in external libraries, we provide a set of four interfaces to + allow you to tailor the Delphi signal handler hooking/unhooking in the + event of an emergency. These are: + InquireSignal + AbandonSignalHandler + HookSignal + UnhookSignal + + InquireSignal allows you to look at the state of a signal handler, so + that you can find out if someone grabbed it out from under you. + + AbandonSignalHandler tells the RTL never to unhook a particular + signal handler. This can be used if you find a case where it would + be unsafe to return to the previous state of signal handling. For + example, if the previous signal handler was installed by a library + which has since been unloaded. + + HookSignal/UnhookSignal setup signal handlers that map certain signals + into language exceptions. + + See additional notes at InquireSignal, et al, below. +} + +const + RTL_SIGINT = 0; // User interrupt (SIGINT) + RTL_SIGFPE = 1; // Floating point exception (SIGFPE) + RTL_SIGSEGV = 2; // Segmentation violation (SIGSEGV) + RTL_SIGILL = 3; // Illegal instruction (SIGILL) + RTL_SIGBUS = 4; // Bus error (SIGBUS) + RTL_SIGQUIT = 5; // User interrupt (SIGQUIT) + RTL_SIGLAST = RTL_SIGQUIT; // Used internally. Don't use this. + RTL_SIGDEFAULT = -1; // Means all of a set of signals that the we capture + // normally. This is currently all of the preceding + // signals. You cannot pass this to InquireSignal. + +type + { TSignalState is the state of a given signal handler, as returned by + InquireSignal. See InquireSignal, below. + } + TSignalState = (ssNotHooked, ssHooked, ssOverridden); + +var + + { + If DeferUserInterrupts is set, we do not raise either SIGINT or SIGQUIT as + an exception, instead, we set SIGINTIssued or SIGQUITIssued when the + signal arrives, and swallow the signal where the OS issued it. This gives + GUI applications the chance to defer the actual handling of the signal + until a time when it is safe to do so. + } + + DeferUserInterrupts: Boolean; + SIGINTIssued: Boolean; + SIGQUITIssued: Boolean; +{$ENDIF} + +{$IFDEF LINUX} +const + MAX_PATH = 4095; // From /usr/include/linux/limits.h PATH_MAX +{$ENDIF} + +var + +{ Empty string and null string pointer. These constants are provided for + backwards compatibility only. } + + EmptyStr: string = ''; + NullStr: PString = @EmptyStr; + + EmptyWideStr: WideString = ''; + NullWideStr: PWideString = @EmptyWideStr; + +{$IFDEF MSWINDOWS} +{ Win32 platform identifier. This will be one of the following values: + + VER_PLATFORM_WIN32s + VER_PLATFORM_WIN32_WINDOWS + VER_PLATFORM_WIN32_NT + + See WINDOWS.PAS for the numerical values. } + + Win32Platform: Integer = 0; + +{ Win32 OS version information - + + see TOSVersionInfo.dwMajorVersion/dwMinorVersion/dwBuildNumber } + + Win32MajorVersion: Integer = 0; + Win32MinorVersion: Integer = 0; + Win32BuildNumber: Integer = 0; + +{ Win32 OS extra version info string - + + see TOSVersionInfo.szCSDVersion } + + Win32CSDVersion: string = ''; + +{ Win32 OS version tester } + +function CheckWin32Version(AMajor: Integer; AMinor: Integer = 0): Boolean; + +{ GetFileVersion returns the most significant 32 bits of a file's binary + version number. Typically, this includes the major and minor version placed + together in one 32-bit integer. It generally does not include the release + or build numbers. It returns Cardinal(-1) if it failed. } +function GetFileVersion(const AFileName: string): Cardinal; + +{$ENDIF} + +{ Currency and date/time formatting options + + The initial values of these variables are fetched from the system registry + using the GetLocaleInfo function in the Win32 API. The description of each + variable specifies the LOCALE_XXXX constant used to fetch the initial + value. + + CurrencyString - Defines the currency symbol used in floating-point to + decimal conversions. The initial value is fetched from LOCALE_SCURRENCY. + + CurrencyFormat - Defines the currency symbol placement and separation + used in floating-point to decimal conversions. Possible values are: + + 0 = '$1' + 1 = '1$' + 2 = '$ 1' + 3 = '1 $' + + The initial value is fetched from LOCALE_ICURRENCY. + + NegCurrFormat - Defines the currency format for used in floating-point to + decimal conversions of negative numbers. Possible values are: + + 0 = '($1)' 4 = '(1$)' 8 = '-1 $' 12 = '$ -1' + 1 = '-$1' 5 = '-1$' 9 = '-$ 1' 13 = '1- $' + 2 = '$-1' 6 = '1-$' 10 = '1 $-' 14 = '($ 1)' + 3 = '$1-' 7 = '1$-' 11 = '$ 1-' 15 = '(1 $)' + + The initial value is fetched from LOCALE_INEGCURR. + + ThousandSeparator - The character used to separate thousands in numbers + with more than three digits to the left of the decimal separator. The + initial value is fetched from LOCALE_STHOUSAND. A value of #0 indicates + no thousand separator character should be output even if the format string + specifies thousand separators. + + DecimalSeparator - The character used to separate the integer part from + the fractional part of a number. The initial value is fetched from + LOCALE_SDECIMAL. DecimalSeparator must be a non-zero value. + + CurrencyDecimals - The number of digits to the right of the decimal point + in a currency amount. The initial value is fetched from LOCALE_ICURRDIGITS. + + DateSeparator - The character used to separate the year, month, and day + parts of a date value. The initial value is fetched from LOCATE_SDATE. + + ShortDateFormat - The format string used to convert a date value to a + short string suitable for editing. For a complete description of date and + time format strings, refer to the documentation for the FormatDate + function. The short date format should only use the date separator + character and the m, mm, d, dd, yy, and yyyy format specifiers. The + initial value is fetched from LOCALE_SSHORTDATE. + + LongDateFormat - The format string used to convert a date value to a long + string suitable for display but not for editing. For a complete description + of date and time format strings, refer to the documentation for the + FormatDate function. The initial value is fetched from LOCALE_SLONGDATE. + + TimeSeparator - The character used to separate the hour, minute, and + second parts of a time value. The initial value is fetched from + LOCALE_STIME. + + TimeAMString - The suffix string used for time values between 00:00 and + 11:59 in 12-hour clock format. The initial value is fetched from + LOCALE_S1159. + + TimePMString - The suffix string used for time values between 12:00 and + 23:59 in 12-hour clock format. The initial value is fetched from + LOCALE_S2359. + + ShortTimeFormat - The format string used to convert a time value to a + short string with only hours and minutes. The default value is computed + from LOCALE_ITIME and LOCALE_ITLZERO. + + LongTimeFormat - The format string used to convert a time value to a long + string with hours, minutes, and seconds. The default value is computed + from LOCALE_ITIME and LOCALE_ITLZERO. + + ShortMonthNames - Array of strings containing short month names. The mmm + format specifier in a format string passed to FormatDate causes a short + month name to be substituted. The default values are fecthed from the + LOCALE_SABBREVMONTHNAME system locale entries. + + LongMonthNames - Array of strings containing long month names. The mmmm + format specifier in a format string passed to FormatDate causes a long + month name to be substituted. The default values are fecthed from the + LOCALE_SMONTHNAME system locale entries. + + ShortDayNames - Array of strings containing short day names. The ddd + format specifier in a format string passed to FormatDate causes a short + day name to be substituted. The default values are fecthed from the + LOCALE_SABBREVDAYNAME system locale entries. + + LongDayNames - Array of strings containing long day names. The dddd + format specifier in a format string passed to FormatDate causes a long + day name to be substituted. The default values are fecthed from the + LOCALE_SDAYNAME system locale entries. + + ListSeparator - The character used to separate items in a list. The + initial value is fetched from LOCALE_SLIST. + + TwoDigitYearCenturyWindow - Determines what century is added to two + digit years when converting string dates to numeric dates. This value + is subtracted from the current year before extracting the century. + This can be used to extend the lifetime of existing applications that + are inextricably tied to 2 digit year data entry. The best solution + to Year 2000 (Y2k) issues is not to accept 2 digit years at all - require + 4 digit years in data entry to eliminate century ambiguities. + + Examples: + + Current TwoDigitCenturyWindow Century StrToDate() of: + Year Value Pivot '01/01/03' '01/01/68' '01/01/50' + ------------------------------------------------------------------------- + 1998 0 1900 1903 1968 1950 + 2002 0 2000 2003 2068 2050 + 1998 50 (default) 1948 2003 1968 1950 + 2002 50 (default) 1952 2003 1968 2050 + 2020 50 (default) 1970 2003 2068 2050 + } + +var + CurrencyString: string; + CurrencyFormat: Byte; + NegCurrFormat: Byte; + ThousandSeparator: Char; + DecimalSeparator: Char; + CurrencyDecimals: Byte; + DateSeparator: Char; + ShortDateFormat: string; + LongDateFormat: string; + TimeSeparator: Char; + TimeAMString: string; + TimePMString: string; + ShortTimeFormat: string; + LongTimeFormat: string; + ShortMonthNames: array[1..12] of string; + LongMonthNames: array[1..12] of string; + ShortDayNames: array[1..7] of string; + LongDayNames: array[1..7] of string; + SysLocale: TSysLocale; + TwoDigitYearCenturyWindow: Word = 50; + ListSeparator: Char; + + +{ Thread safe currency and date/time formatting + + The TFormatSettings record is designed to allow thread safe formatting, + equivalent to the gloabal variables described above. Each of the + formatting routines that use the gloabal variables have overloaded + equivalents, requiring an additional parameter of type TFormatSettings. + + A TFormatSettings record must be populated before use. This can be done + using the GetLocaleFormatSettings function, which will populate the + record with values based on the given locale (using the Win32 API + function GetLocaleInfo). Note that some format specifiers still require + specific thread locale settings (such as period/era names). +} + +type + TFormatSettings = record + CurrencyFormat: Byte; + NegCurrFormat: Byte; + ThousandSeparator: Char; + DecimalSeparator: Char; + CurrencyDecimals: Byte; + DateSeparator: Char; + TimeSeparator: Char; + ListSeparator: Char; + CurrencyString: string; + ShortDateFormat: string; + LongDateFormat: string; + TimeAMString: string; + TimePMString: string; + ShortTimeFormat: string; + LongTimeFormat: string; + ShortMonthNames: array[1..12] of string; + LongMonthNames: array[1..12] of string; + ShortDayNames: array[1..7] of string; + LongDayNames: array[1..7] of string; + TwoDigitYearCenturyWindow: Word; + end; + + TLocaleOptions = (loInvariantLocale, loUserLocale); + +const + MaxEraCount = 7; + +var + EraNames: array [1..MaxEraCount] of string; + EraYearOffsets: array [1..MaxEraCount] of Integer; +{$IFDEF LINUX} + EraRanges : array [1..MaxEraCount] of TEraRange platform; + EraYearFormats: array [1..MaxEraCount] of string platform; + EraCount: Byte platform; +{$ENDIF} + +const + PathDelim = {$IFDEF MSWINDOWS} '\'; {$ELSE} '/'; {$ENDIF} + DriveDelim = {$IFDEF MSWINDOWS} ':'; {$ELSE} ''; {$ENDIF} + PathSep = {$IFDEF MSWINDOWS} ';'; {$ELSE} ':'; {$ENDIF} + +{$IFDEF MSWINDOWS} +function Languages: TLanguages; +{$ENDIF} + +{ Memory management routines } + +{ AllocMem allocates a block of the given size on the heap. Each byte in + the allocated buffer is set to zero. To dispose the buffer, use the + FreeMem standard procedure. } + +function AllocMem(Size: Cardinal): Pointer; + +{ Exit procedure handling } + +{ AddExitProc adds the given procedure to the run-time library's exit + procedure list. When an application terminates, its exit procedures are + executed in reverse order of definition, i.e. the last procedure passed + to AddExitProc is the first one to get executed upon termination. } + +procedure AddExitProc(Proc: TProcedure); + +{ String handling routines } + +{ NewStr allocates a string on the heap. NewStr is provided for backwards + compatibility only. } + +function NewStr(const S: string): PString; deprecated; + +{ DisposeStr disposes a string pointer that was previously allocated using + NewStr. DisposeStr is provided for backwards compatibility only. } + +procedure DisposeStr(P: PString); deprecated; + +{ AssignStr assigns a new dynamically allocated string to the given string + pointer. AssignStr is provided for backwards compatibility only. } + +procedure AssignStr(var P: PString; const S: string); deprecated; + +{ AppendStr appends S to the end of Dest. AppendStr is provided for + backwards compatibility only. Use "Dest := Dest + S" instead. } + +procedure AppendStr(var Dest: string; const S: string); deprecated; + +{ UpperCase converts all ASCII characters in the given string to upper case. + The conversion affects only 7-bit ASCII characters between 'a' and 'z'. To + convert 8-bit international characters, use AnsiUpperCase. } + +function UpperCase(const S: string): string; overload; +function UpperCase(const S: string; LocaleOptions: TLocaleOptions): string; overload; inline; + +{ LowerCase converts all ASCII characters in the given string to lower case. + The conversion affects only 7-bit ASCII characters between 'A' and 'Z'. To + convert 8-bit international characters, use AnsiLowerCase. } + +function LowerCase(const S: string): string; overload; +function LowerCase(const S: string; LocaleOptions: TLocaleOptions): string; overload; inline; + +{ CompareStr compares S1 to S2, with case-sensitivity. The return value is + less than 0 if S1 < S2, 0 if S1 = S2, or greater than 0 if S1 > S2. The + compare operation is based on the 8-bit ordinal value of each character + and is not affected by the current user locale. } + +function CompareStr(const S1, S2: string): Integer; overload; +function CompareStr(const S1, S2: string; LocaleOptions: TLocaleOptions): Integer; overload; + +{ SameStr compares S1 to S2, with case-sensitivity. Returns true if + S1 and S2 are the equal, that is, if CompareStr would return 0. } + +function SameStr(const S1, S2: string): Boolean; overload; +function SameStr(const S1, S2: string; LocaleOptions: TLocaleOptions): Boolean; overload; + +{ CompareMem performs a binary compare of Length bytes of memory referenced + by P1 to that of P2. CompareMem returns True if the memory referenced by + P1 is identical to that of P2. } + +function CompareMem(P1, P2: Pointer; Length: Integer): Boolean; assembler; + +{ CompareText compares S1 to S2, without case-sensitivity. The return value + is the same as for CompareStr. The compare operation is based on the 8-bit + ordinal value of each character, after converting 'a'..'z' to 'A'..'Z', + and is not affected by the current user locale. } + +function CompareText(const S1, S2: string): Integer; overload; +function CompareText(const S1, S2: string; LocaleOptions: TLocaleOptions): Integer; overload; + +{ SameText compares S1 to S2, without case-sensitivity. Returns true if + S1 and S2 are the equal, that is, if CompareText would return 0. SameText + has the same 8-bit limitations as CompareText } + +function SameText(const S1, S2: string): Boolean; overload; +function SameText(const S1, S2: string; LocaleOptions: TLocaleOptions): Boolean; overload; + +{ AnsiUpperCase converts all characters in the given string to upper case. + The conversion uses the current user locale. } + +function AnsiUpperCase(const S: string): string; + +{ AnsiLowerCase converts all characters in the given string to lower case. + The conversion uses the current user locale. } + +function AnsiLowerCase(const S: string): string; + +{ AnsiCompareStr compares S1 to S2, with case-sensitivity. The compare + operation is controlled by the current user locale. The return value + is the same as for CompareStr. } + +function AnsiCompareStr(const S1, S2: string): Integer; inline; + +{ AnsiSameStr compares S1 to S2, with case-sensitivity. The compare + operation is controlled by the current user locale. The return value + is True if AnsiCompareStr would have returned 0. } + +function AnsiSameStr(const S1, S2: string): Boolean; inline; + +{ AnsiCompareText compares S1 to S2, without case-sensitivity. The compare + operation is controlled by the current user locale. The return value + is the same as for CompareStr. } + +function AnsiCompareText(const S1, S2: string): Integer; inline; + +{ AnsiSameText compares S1 to S2, without case-sensitivity. The compare + operation is controlled by the current user locale. The return value + is True if AnsiCompareText would have returned 0. } + +function AnsiSameText(const S1, S2: string): Boolean; inline; + +{ AnsiStrComp compares S1 to S2, with case-sensitivity. The compare + operation is controlled by the current user locale. The return value + is the same as for CompareStr. } + +function AnsiStrComp(S1, S2: PChar): Integer; inline; + +{ AnsiStrIComp compares S1 to S2, without case-sensitivity. The compare + operation is controlled by the current user locale. The return value + is the same as for CompareStr. } + +function AnsiStrIComp(S1, S2: PChar): Integer; inline; + +{ AnsiStrLComp compares S1 to S2, with case-sensitivity, up to a maximum + length of MaxLen bytes. The compare operation is controlled by the + current user locale. The return value is the same as for CompareStr. } + +function AnsiStrLComp(S1, S2: PChar; MaxLen: Cardinal): Integer; + +{ AnsiStrLIComp compares S1 to S2, without case-sensitivity, up to a maximum + length of MaxLen bytes. The compare operation is controlled by the + current user locale. The return value is the same as for CompareStr. } + +function AnsiStrLIComp(S1, S2: PChar; MaxLen: Cardinal): Integer; + +{ AnsiStrLower converts all characters in the given string to lower case. + The conversion uses the current user locale. } + +function AnsiStrLower(Str: PChar): PChar; + +{ AnsiStrUpper converts all characters in the given string to upper case. + The conversion uses the current user locale. } + +function AnsiStrUpper(Str: PChar): PChar; + +{ AnsiLastChar returns a pointer to the last full character in the string. + This function supports multibyte characters } + +function AnsiLastChar(const S: string): PChar; + +{ AnsiStrLastChar returns a pointer to the last full character in the string. + This function supports multibyte characters. } + +function AnsiStrLastChar(P: PChar): PChar; + +{ WideUpperCase converts all characters in the given string to upper case. } + +function WideUpperCase(const S: WideString): WideString; + +{ WideLowerCase converts all characters in the given string to lower case. } + +function WideLowerCase(const S: WideString): WideString; + +{ WideCompareStr compares S1 to S2, with case-sensitivity. The return value + is the same as for CompareStr. } + +function WideCompareStr(const S1, S2: WideString): Integer; + +{ WideSameStr compares S1 to S2, with case-sensitivity. The return value + is True if WideCompareStr would have returned 0. } + +function WideSameStr(const S1, S2: WideString): Boolean; inline; + +{ WideCompareText compares S1 to S2, without case-sensitivity. The return value + is the same as for CompareStr. } + +function WideCompareText(const S1, S2: WideString): Integer; + +{ WideSameText compares S1 to S2, without case-sensitivity. The return value + is True if WideCompareText would have returned 0. } + +function WideSameText(const S1, S2: WideString): Boolean; inline; + +{ Trim trims leading and trailing spaces and control characters from the + given string. } + +function Trim(const S: string): string; overload; +function Trim(const S: WideString): WideString; overload; + +{ TrimLeft trims leading spaces and control characters from the given + string. } + +function TrimLeft(const S: string): string; overload; +function TrimLeft(const S: WideString): WideString; overload; + +{ TrimRight trims trailing spaces and control characters from the given + string. } + +function TrimRight(const S: string): string; overload; +function TrimRight(const S: WideString): WideString; overload; + +{ QuotedStr returns the given string as a quoted string. A single quote + character is inserted at the beginning and the end of the string, and + for each single quote character in the string, another one is added. } + +function QuotedStr(const S: string): string; + +{ AnsiQuotedStr returns the given string as a quoted string, using the + provided Quote character. A Quote character is inserted at the beginning + and end of the string, and each Quote character in the string is doubled. + This function supports multibyte character strings (MBCS). } + +function AnsiQuotedStr(const S: string; Quote: Char): string; + +{ AnsiExtractQuotedStr removes the Quote characters from the beginning and end + of a quoted string, and reduces pairs of Quote characters within the quoted + string to a single character. If the first character in Src is not the Quote + character, the function returns an empty string. The function copies + characters from the Src to the result string until the second solitary + Quote character or the first null character in Src. The Src parameter is + updated to point to the first character following the quoted string. If + the Src string does not contain a matching end Quote character, the Src + parameter is updated to point to the terminating null character in Src. + This function supports multibyte character strings (MBCS). } + +function AnsiExtractQuotedStr(var Src: PChar; Quote: Char): string; + +{ AnsiDequotedStr is a simplified version of AnsiExtractQuotedStr } + +function AnsiDequotedStr(const S: string; AQuote: Char): string; + +{ AdjustLineBreaks adjusts all line breaks in the given string to the + indicated style. + When Style is tlbsCRLF, the function changes all + CR characters not followed by LF and all LF characters not preceded + by a CR into CR/LF pairs. + When Style is tlbsLF, the function changes all CR/LF pairs and CR characters + not followed by LF to LF characters. } + +function AdjustLineBreaks(const S: string; Style: TTextLineBreakStyle = + {$IFDEF LINUX} tlbsLF {$ENDIF} + {$IFDEF MSWINDOWS} tlbsCRLF {$ENDIF}): string; + +{ IsValidIdent returns true if the given string is a valid identifier. An + identifier is defined as a character from the set ['A'..'Z', 'a'..'z', '_'] + followed by zero or more characters from the set ['A'..'Z', 'a'..'z', + '0..'9', '_']. With DotNet code we need to allow dots in the names.} + +function IsValidIdent(const Ident: string; AllowDots: Boolean = False): Boolean; + +{ IntToStr converts the given value to its decimal string representation. } + +function IntToStr(Value: Integer): string; overload; +function IntToStr(Value: Int64): string; overload; + +{ IntToHex converts the given value to a hexadecimal string representation + with the minimum number of digits specified. } + +function IntToHex(Value: Integer; Digits: Integer): string; overload; +function IntToHex(Value: Int64; Digits: Integer): string; overload; + +{ StrToInt converts the given string to an integer value. If the string + doesn't contain a valid value, an EConvertError exception is raised. } + +function StrToInt(const S: string): Integer; +function StrToIntDef(const S: string; Default: Integer): Integer; +function TryStrToInt(const S: string; out Value: Integer): Boolean; + +{ Similar to the above functions but for Int64 instead } + +function StrToInt64(const S: string): Int64; +function StrToInt64Def(const S: string; const Default: Int64): Int64; +function TryStrToInt64(const S: string; out Value: Int64): Boolean; + +{ StrToBool converts the given string to a boolean value. If the string + doesn't contain a valid value, an EConvertError exception is raised. + BoolToStr converts boolean to a string value that in turn can be converted + back into a boolean. BoolToStr will always pick the first element of + the TrueStrs/FalseStrs arrays. } + +var + TrueBoolStrs: array of String; + FalseBoolStrs: array of String; + +const + DefaultTrueBoolStr = 'True'; // DO NOT LOCALIZE + DefaultFalseBoolStr = 'False'; // DO NOT LOCALIZE + +function StrToBool(const S: string): Boolean; +function StrToBoolDef(const S: string; const Default: Boolean): Boolean; +function TryStrToBool(const S: string; out Value: Boolean): Boolean; + +function BoolToStr(B: Boolean; UseBoolStrs: Boolean = False): string; + +{ LoadStr loads the string resource given by Ident from the application's + executable file or associated resource module. If the string resource + does not exist, LoadStr returns an empty string. } + +function LoadStr(Ident: Integer): string; + +{ FmtLoadStr loads the string resource given by Ident from the application's + executable file or associated resource module, and uses it as the format + string in a call to the Format function with the given arguments. } + +function FmtLoadStr(Ident: Integer; const Args: array of const): string; + +{ File management routines } + +{ FileOpen opens the specified file using the specified access mode. The + access mode value is constructed by OR-ing one of the fmOpenXXXX constants + with one of the fmShareXXXX constants. If the return value is positive, + the function was successful and the value is the file handle of the opened + file. A return value of -1 indicates that an error occurred. } + +function FileOpen(const FileName: string; Mode: LongWord): Integer; + +{ FileCreate creates a new file by the specified name. If the return value + is positive, the function was successful and the value is the file handle + of the new file. A return value of -1 indicates that an error occurred. + On Linux, this calls FileCreate(FileName, DEFFILEMODE) to create + the file with read and write access for the current user only. } + +function FileCreate(const FileName: string): Integer; overload; inline; + +{ This second version of FileCreate lets you specify the access rights to put on the newly + created file. The access rights parameter is ignored on Win32 } + +function FileCreate(const FileName: string; Rights: Integer): Integer; overload; inline; + +{ FileRead reads Count bytes from the file given by Handle into the buffer + specified by Buffer. The return value is the number of bytes actually + read; it is less than Count if the end of the file was reached. The return + value is -1 if an error occurred. } + +function FileRead(Handle: Integer; var Buffer; Count: LongWord): Integer; + +{ FileWrite writes Count bytes to the file given by Handle from the buffer + specified by Buffer. The return value is the number of bytes actually + written, or -1 if an error occurred. } + +function FileWrite(Handle: Integer; const Buffer; Count: LongWord): Integer; + +{ FileSeek changes the current position of the file given by Handle to be + Offset bytes relative to the point given by Origin. Origin = 0 means that + Offset is relative to the beginning of the file, Origin = 1 means that + Offset is relative to the current position, and Origin = 2 means that + Offset is relative to the end of the file. The return value is the new + current position, relative to the beginning of the file, or -1 if an error + occurred. } + +function FileSeek(Handle, Offset, Origin: Integer): Integer; overload; +function FileSeek(Handle: Integer; const Offset: Int64; Origin: Integer): Int64; overload; + +{ FileClose closes the specified file. } + +procedure FileClose(Handle: Integer); inline; + +{ FileAge returns the date-and-time stamp of the specified file. The return + value can be converted to a TDateTime value using the FileDateToDateTime + function. The return value is -1 if the file does not exist. } + +function FileAge(const FileName: string): Integer; + +{ FileExists returns a boolean value that indicates whether the specified + file exists. } + +function FileExists(const FileName: string): Boolean; inline; + +{ DirectoryExists returns a boolean value that indicates whether the + specified directory exists (and is actually a directory) } + +function DirectoryExists(const Directory: string): Boolean; + +{ ForceDirectories ensures that all the directories in a specific path exist. + Any portion that does not already exist will be created. Function result + indicates success of the operation. The function can fail if the current + user does not have sufficient file access rights to create directories in + the given path. } + +function ForceDirectories(Dir: string): Boolean; + +{ FindFirst searches the directory given by Path for the first entry that + matches the filename given by Path and the attributes given by Attr. The + result is returned in the search record given by SearchRec. The return + value is zero if the function was successful. Otherwise the return value + is a system error code. After calling FindFirst, always call FindClose. + FindFirst is typically used with FindNext and FindClose as follows: + + Result := FindFirst(Path, Attr, SearchRec); + while Result = 0 do + begin + ProcessSearchRec(SearchRec); + Result := FindNext(SearchRec); + end; + FindClose(SearchRec); + + where ProcessSearchRec represents user-defined code that processes the + information in a search record. } + +function FindFirst(const Path: string; Attr: Integer; + var F: TSearchRec): Integer; + +{ FindNext returs the next entry that matches the name and attributes + specified in a previous call to FindFirst. The search record must be one + that was passed to FindFirst. The return value is zero if the function was + successful. Otherwise the return value is a system error code. } + +function FindNext(var F: TSearchRec): Integer; + +{ FindClose terminates a FindFirst/FindNext sequence and frees memory and system + resources allocated by FindFirst. + Every FindFirst/FindNext must end with a call to FindClose. } + +procedure FindClose(var F: TSearchRec); + +{ FileGetDate returns the OS date-and-time stamp of the file given by + Handle. The return value is -1 if the handle is invalid. The + FileDateToDateTime function can be used to convert the returned value to + a TDateTime value. } + +function FileGetDate(Handle: Integer): Integer; + +{ FileSetDate sets the OS date-and-time stamp of the file given by FileName + to the value given by Age. The DateTimeToFileDate function can be used to + convert a TDateTime value to an OS date-and-time stamp. The return value + is zero if the function was successful. Otherwise the return value is a + system error code. } + +function FileSetDate(const FileName: string; Age: Integer): Integer; overload; + +{$IFDEF MSWINDOWS} +{ FileSetDate by handle is not available on Unix platforms because there + is no standard way to set a file's modification time using only a file + handle, and no standard way to obtain the file name of an open + file handle. } + +function FileSetDate(Handle: Integer; Age: Integer): Integer; overload; platform; + +{ FileGetAttr returns the file attributes of the file given by FileName. The + attributes can be examined by AND-ing with the faXXXX constants defined + above. A return value of -1 indicates that an error occurred. } + +function FileGetAttr(const FileName: string): Integer; platform; + +{ FileSetAttr sets the file attributes of the file given by FileName to the + value given by Attr. The attribute value is formed by OR-ing the + appropriate faXXXX constants. The return value is zero if the function was + successful. Otherwise the return value is a system error code. } + +function FileSetAttr(const FileName: string; Attr: Integer): Integer; platform; +{$ENDIF} + +{ FileIsReadOnly tests whether a given file is read-only for the current + process and effective user id. If the file does not exist, the + function returns False. (Check FileExists before calling FileIsReadOnly) + This function is platform portable. } + +function FileIsReadOnly(const FileName: string): Boolean; inline; + +{ FileSetReadOnly sets the read only state of a file. The file must + exist and the current effective user id must be the owner of the file. + On Unix systems, FileSetReadOnly attempts to set or remove + all three (user, group, and other) write permissions on the file. + If you want to grant partial permissions (writeable for owner but not + for others), use platform specific functions such as chmod. + The function returns True if the file was successfully modified, + False if there was an error. This function is platform portable. } + +function FileSetReadOnly(const FileName: string; ReadOnly: Boolean): Boolean; + +{ DeleteFile deletes the file given by FileName. The return value is True if + the file was successfully deleted, or False if an error occurred. } + +function DeleteFile(const FileName: string): Boolean; inline; + +{ RenameFile renames the file given by OldName to the name given by NewName. + The return value is True if the file was successfully renamed, or False if + an error occurred. } + +function RenameFile(const OldName, NewName: string): Boolean; inline; + +{ ChangeFileExt changes the extension of a filename. FileName specifies a + filename with or without an extension, and Extension specifies the new + extension for the filename. The new extension can be a an empty string or + a period followed by up to three characters. } + +function ChangeFileExt(const FileName, Extension: string): string; + +{ ExtractFilePath extracts the drive and directory parts of the given + filename. The resulting string is the leftmost characters of FileName, + up to and including the colon or backslash that separates the path + information from the name and extension. The resulting string is empty + if FileName contains no drive and directory parts. } + +function ExtractFilePath(const FileName: string): string; + +{ ExtractFileDir extracts the drive and directory parts of the given + filename. The resulting string is a directory name suitable for passing + to SetCurrentDir, CreateDir, etc. The resulting string is empty if + FileName contains no drive and directory parts. } + +function ExtractFileDir(const FileName: string): string; + +{ ExtractFileDrive extracts the drive part of the given filename. For + filenames with drive letters, the resulting string is ':'. + For filenames with a UNC path, the resulting string is in the form + '\\\'. If the given path contains neither + style of filename, the result is an empty string. } + +function ExtractFileDrive(const FileName: string): string; + +{ ExtractFileName extracts the name and extension parts of the given + filename. The resulting string is the leftmost characters of FileName, + starting with the first character after the colon or backslash that + separates the path information from the name and extension. The resulting + string is equal to FileName if FileName contains no drive and directory + parts. } + +function ExtractFileName(const FileName: string): string; + +{ ExtractFileExt extracts the extension part of the given filename. The + resulting string includes the period character that separates the name + and extension parts. The resulting string is empty if the given filename + has no extension. } + +function ExtractFileExt(const FileName: string): string; + +{ ExpandFileName expands the given filename to a fully qualified filename. + The resulting string consists of a drive letter, a colon, a root relative + directory path, and a filename. Embedded '.' and '..' directory references + are removed. } + +function ExpandFileName(const FileName: string): string; + +{ ExpandFilenameCase returns a fully qualified filename like ExpandFilename, + but performs a case-insensitive filename search looking for a close match + in the actual file system, differing only in uppercase versus lowercase of + the letters. This is useful to convert lazy user input into useable file + names, or to convert filename data created on a case-insensitive file + system (Win32) to something useable on a case-sensitive file system (Linux). + + The MatchFound out parameter indicates what kind of match was found in the + file system, and what the function result is based upon: + + ( in order of increasing difficulty or complexity ) + mkExactMatch: Case-sensitive match. Result := ExpandFileName(FileName). + mkSingleMatch: Exactly one file in the given directory path matches the + given filename on a case-insensitive basis. + Result := ExpandFileName(FileName as found in file system). + mkAmbiguous: More than one file in the given directory path matches the + given filename case-insensitively. + In many cases, this should be considered an error. + Result := ExpandFileName(First matching filename found). + mkNone: File not found at all. Result := ExpandFileName(FileName). + + Note that because this function has to search the file system it may be + much slower than ExpandFileName, particularly when the given filename is + ambiguous or does not exist. Use ExpandFilenameCase only when you have + a filename of dubious orgin - such as from user input - and you want + to make a best guess before failing. } + +type + TFilenameCaseMatch = (mkNone, mkExactMatch, mkSingleMatch, mkAmbiguous); + +function ExpandFileNameCase(const FileName: string; + out MatchFound: TFilenameCaseMatch): string; + +{ ExpandUNCFileName expands the given filename to a fully qualified filename. + This function is the same as ExpandFileName except that it will return the + drive portion of the filename in the format '\\\ if + that drive is actually a network resource instead of a local resource. + Like ExpandFileName, embedded '.' and '..' directory references are + removed. } + +function ExpandUNCFileName(const FileName: string): string; + +{ ExtractRelativePath will return a file path name relative to the given + BaseName. It strips the common path dirs and adds '..\' on Windows, + and '../' on Linux for each level up from the BaseName path. } + +function ExtractRelativePath(const BaseName, DestName: string): string; + +{$IFDEF MSWINDOWS} +{ ExtractShortPathName will convert the given filename to the short form + by calling the GetShortPathName API. Will return an empty string if + the file or directory specified does not exist } + +function ExtractShortPathName(const FileName: string): string; +{$ENDIF} + +{ FileSearch searches for the file given by Name in the list of directories + given by DirList. The directory paths in DirList must be separated by + PathSep chars. The search always starts with the current directory of the + current drive. The returned value is a concatenation of one of the + directory paths and the filename, or an empty string if the file could not + be located. } + +function FileSearch(const Name, DirList: string): string; + +{$IFDEF MSWINDOWS} +{ DiskFree returns the number of free bytes on the specified drive number, + where 0 = Current, 1 = A, 2 = B, etc. DiskFree returns -1 if the drive + number is invalid. } + +function DiskFree(Drive: Byte): Int64; + +{ DiskSize returns the size in bytes of the specified drive number, where + 0 = Current, 1 = A, 2 = B, etc. DiskSize returns -1 if the drive number + is invalid. } + +function DiskSize(Drive: Byte): Int64; +{$ENDIF} + +{ FileDateToDateTime converts an OS date-and-time value to a TDateTime + value. The FileAge, FileGetDate, and FileSetDate routines operate on OS + date-and-time values, and the Time field of a TSearchRec used by the + FindFirst and FindNext functions contains an OS date-and-time value. } + +function FileDateToDateTime(FileDate: Integer): TDateTime; + +{ DateTimeToFileDate converts a TDateTime value to an OS date-and-time + value. The FileAge, FileGetDate, and FileSetDate routines operate on OS + date-and-time values, and the Time field of a TSearchRec used by the + FindFirst and FindNext functions contains an OS date-and-time value. } + +function DateTimeToFileDate(DateTime: TDateTime): Integer; + +{ GetCurrentDir returns the current directory. } + +function GetCurrentDir: string; + +{ SetCurrentDir sets the current directory. The return value is True if + the current directory was successfully changed, or False if an error + occurred. } + +function SetCurrentDir(const Dir: string): Boolean; + +{ CreateDir creates a new directory. The return value is True if a new + directory was successfully created, or False if an error occurred. } + +function CreateDir(const Dir: string): Boolean; + +{ RemoveDir deletes an existing empty directory. The return value is + True if the directory was successfully deleted, or False if an error + occurred. } + +function RemoveDir(const Dir: string): Boolean; + +{ PChar routines } +{ const params help simplify C++ code. No effect on pascal code } + +{ StrLen returns the number of characters in Str, not counting the null + terminator. } + +function StrLen(const Str: PChar): Cardinal; + +{ StrEnd returns a pointer to the null character that terminates Str. } + +function StrEnd(const Str: PChar): PChar; + +{ StrMove copies exactly Count characters from Source to Dest and returns + Dest. Source and Dest may overlap. } + +function StrMove(Dest: PChar; const Source: PChar; Count: Cardinal): PChar; + +{ StrCopy copies Source to Dest and returns Dest. } + +function StrCopy(Dest: PChar; const Source: PChar): PChar; + +{ StrECopy copies Source to Dest and returns StrEnd(Dest). } + +function StrECopy(Dest:PChar; const Source: PChar): PChar; + +{ StrLCopy copies at most MaxLen characters from Source to Dest and + returns Dest. } + +function StrLCopy(Dest: PChar; const Source: PChar; MaxLen: Cardinal): PChar; + +{ StrPCopy copies the Pascal style string Source into Dest and + returns Dest. } + +function StrPCopy(Dest: PChar; const Source: string): PChar; + +{ StrPLCopy copies at most MaxLen characters from the Pascal style string + Source into Dest and returns Dest. } + +function StrPLCopy(Dest: PChar; const Source: string; + MaxLen: Cardinal): PChar; + +{ StrCat appends a copy of Source to the end of Dest and returns Dest. } + +function StrCat(Dest: PChar; const Source: PChar): PChar; + +{ StrLCat appends at most MaxLen - StrLen(Dest) characters from Source to + the end of Dest, and returns Dest. } + +function StrLCat(Dest: PChar; const Source: PChar; MaxLen: Cardinal): PChar; + +{ StrComp compares Str1 to Str2. The return value is less than 0 if + Str1 < Str2, 0 if Str1 = Str2, or greater than 0 if Str1 > Str2. } + +function StrComp(const Str1, Str2: PChar): Integer; + +{ StrIComp compares Str1 to Str2, without case sensitivity. The return + value is the same as StrComp. } + +function StrIComp(const Str1, Str2: PChar): Integer; + +{ StrLComp compares Str1 to Str2, for a maximum length of MaxLen + characters. The return value is the same as StrComp. } + +function StrLComp(const Str1, Str2: PChar; MaxLen: Cardinal): Integer; + +{ StrLIComp compares Str1 to Str2, for a maximum length of MaxLen + characters, without case sensitivity. The return value is the same + as StrComp. } + +function StrLIComp(const Str1, Str2: PChar; MaxLen: Cardinal): Integer; + +{ StrScan returns a pointer to the first occurrence of Chr in Str. If Chr + does not occur in Str, StrScan returns NIL. The null terminator is + considered to be part of the string. } + +function StrScan(const Str: PChar; Chr: Char): PChar; + +{ StrRScan returns a pointer to the last occurrence of Chr in Str. If Chr + does not occur in Str, StrRScan returns NIL. The null terminator is + considered to be part of the string. } + +function StrRScan(const Str: PChar; Chr: Char): PChar; + +{ StrPos returns a pointer to the first occurrence of Str2 in Str1. If + Str2 does not occur in Str1, StrPos returns NIL. } + +function StrPos(const Str1, Str2: PChar): PChar; + +{ StrUpper converts Str to upper case and returns Str. } + +function StrUpper(Str: PChar): PChar; + +{ StrLower converts Str to lower case and returns Str. } + +function StrLower(Str: PChar): PChar; + +{ StrPas converts Str to a Pascal style string. This function is provided + for backwards compatibility only. To convert a null terminated string to + a Pascal style string, use a string type cast or an assignment. } + +function StrPas(const Str: PChar): string; + +{ StrAlloc allocates a buffer of the given size on the heap. The size of + the allocated buffer is encoded in a four byte header that immediately + preceeds the buffer. To dispose the buffer, use StrDispose. } + +function StrAlloc(Size: Cardinal): PChar; + +{ StrBufSize returns the allocated size of the given buffer, not including + the two byte header. } + +function StrBufSize(const Str: PChar): Cardinal; + +{ StrNew allocates a copy of Str on the heap. If Str is NIL, StrNew returns + NIL and doesn't allocate any heap space. Otherwise, StrNew makes a + duplicate of Str, obtaining space with a call to the StrAlloc function, + and returns a pointer to the duplicated string. To dispose the string, + use StrDispose. } + +function StrNew(const Str: PChar): PChar; + +{ StrDispose disposes a string that was previously allocated with StrAlloc + or StrNew. If Str is NIL, StrDispose does nothing. } + +procedure StrDispose(Str: PChar); + +{ String formatting routines } + +{ The Format routine formats the argument list given by the Args parameter + using the format string given by the Format parameter. + + Format strings contain two types of objects--plain characters and format + specifiers. Plain characters are copied verbatim to the resulting string. + Format specifiers fetch arguments from the argument list and apply + formatting to them. + + Format specifiers have the following form: + + "%" [index ":"] ["-"] [width] ["." prec] type + + A format specifier begins with a % character. After the % come the + following, in this order: + + - an optional argument index specifier, [index ":"] + - an optional left-justification indicator, ["-"] + - an optional width specifier, [width] + - an optional precision specifier, ["." prec] + - the conversion type character, type + + The following conversion characters are supported: + + d Decimal. The argument must be an integer value. The value is converted + to a string of decimal digits. If the format string contains a precision + specifier, it indicates that the resulting string must contain at least + the specified number of digits; if the value has less digits, the + resulting string is left-padded with zeros. + + u Unsigned decimal. Similar to 'd' but no sign is output. + + e Scientific. The argument must be a floating-point value. The value is + converted to a string of the form "-d.ddd...E+ddd". The resulting + string starts with a minus sign if the number is negative, and one digit + always precedes the decimal point. The total number of digits in the + resulting string (including the one before the decimal point) is given + by the precision specifer in the format string--a default precision of + 15 is assumed if no precision specifer is present. The "E" exponent + character in the resulting string is always followed by a plus or minus + sign and at least three digits. + + f Fixed. The argument must be a floating-point value. The value is + converted to a string of the form "-ddd.ddd...". The resulting string + starts with a minus sign if the number is negative. The number of digits + after the decimal point is given by the precision specifier in the + format string--a default of 2 decimal digits is assumed if no precision + specifier is present. + + g General. The argument must be a floating-point value. The value is + converted to the shortest possible decimal string using fixed or + scientific format. The number of significant digits in the resulting + string is given by the precision specifier in the format string--a + default precision of 15 is assumed if no precision specifier is present. + Trailing zeros are removed from the resulting string, and a decimal + point appears only if necessary. The resulting string uses fixed point + format if the number of digits to the left of the decimal point in the + value is less than or equal to the specified precision, and if the + value is greater than or equal to 0.00001. Otherwise the resulting + string uses scientific format. + + n Number. The argument must be a floating-point value. The value is + converted to a string of the form "-d,ddd,ddd.ddd...". The "n" format + corresponds to the "f" format, except that the resulting string + contains thousand separators. + + m Money. The argument must be a floating-point value. The value is + converted to a string that represents a currency amount. The conversion + is controlled by the CurrencyString, CurrencyFormat, NegCurrFormat, + ThousandSeparator, DecimalSeparator, and CurrencyDecimals global + variables, all of which are initialized from locale settings provided + by the operating system. For example, Currency Format preferences can be + set in the International section of the Windows Control Panel. If the format + string contains a precision specifier, it overrides the value given + by the CurrencyDecimals global variable. + + p Pointer. The argument must be a pointer value. The value is converted + to a string of the form "XXXX:YYYY" where XXXX and YYYY are the + segment and offset parts of the pointer expressed as four hexadecimal + digits. + + s String. The argument must be a character, a string, or a PChar value. + The string or character is inserted in place of the format specifier. + The precision specifier, if present in the format string, specifies the + maximum length of the resulting string. If the argument is a string + that is longer than this maximum, the string is truncated. + + x Hexadecimal. The argument must be an integer value. The value is + converted to a string of hexadecimal digits. If the format string + contains a precision specifier, it indicates that the resulting string + must contain at least the specified number of digits; if the value has + less digits, the resulting string is left-padded with zeros. + + Conversion characters may be specified in upper case as well as in lower + case--both produce the same results. + + For all floating-point formats, the actual characters used as decimal and + thousand separators are obtained from the DecimalSeparator and + ThousandSeparator global variables. + + Index, width, and precision specifiers can be specified directly using + decimal digit string (for example "%10d"), or indirectly using an asterisk + charcater (for example "%*.*f"). When using an asterisk, the next argument + in the argument list (which must be an integer value) becomes the value + that is actually used. For example "Format('%*.*f', [8, 2, 123.456])" is + the same as "Format('%8.2f', [123.456])". + + A width specifier sets the minimum field width for a conversion. If the + resulting string is shorter than the minimum field width, it is padded + with blanks to increase the field width. The default is to right-justify + the result by adding blanks in front of the value, but if the format + specifier contains a left-justification indicator (a "-" character + preceding the width specifier), the result is left-justified by adding + blanks after the value. + + An index specifier sets the current argument list index to the specified + value. The index of the first argument in the argument list is 0. Using + index specifiers, it is possible to format the same argument multiple + times. For example "Format('%d %d %0:d %d', [10, 20])" produces the string + '10 20 10 20'. + + The Format function can be combined with other formatting functions. For + example + + S := Format('Your total was %s on %s', [ + FormatFloat('$#,##0.00;;zero', Total), + FormatDateTime('mm/dd/yy', Date)]); + + which uses the FormatFloat and FormatDateTime functions to customize the + format beyond what is possible with Format. + + Each of the string formatting routines that uses global variables for + formatting (separators, decimals, date/time formats etc.), has an + overloaded equivalent requiring a parameter of type TFormatSettings. This + additional parameter provides the formatting information rather than the + global variables. For more information see the notes at TFormatSettings. } + +function Format(const Format: string; + const Args: array of const): string; overload; +function Format(const Format: string; const Args: array of const; + const FormatSettings: TFormatSettings): string; overload; + +{ FmtStr formats the argument list given by Args using the format string + given by Format into the string variable given by Result. For further + details, see the description of the Format function. } + +procedure FmtStr(var Result: string; const Format: string; + const Args: array of const); overload; +procedure FmtStr(var Result: string; const Format: string; + const Args: array of const; const FormatSettings: TFormatSettings); overload; + +{ StrFmt formats the argument list given by Args using the format string + given by Format into the buffer given by Buffer. It is up to the caller to + ensure that Buffer is large enough for the resulting string. The returned + value is Buffer. For further details, see the description of the Format + function. } + +function StrFmt(Buffer, Format: PChar; + const Args: array of const): PChar; overload; +function StrFmt(Buffer, Format: PChar; const Args: array of const; + const FormatSettings: TFormatSettings): PChar; overload; + +{ StrLFmt formats the argument list given by Args using the format string + given by Format into the buffer given by Buffer. The resulting string will + contain no more than MaxBufLen characters, not including the null terminator. + The returned value is Buffer. For further details, see the description of + the Format function. } + +function StrLFmt(Buffer: PChar; MaxBufLen: Cardinal; Format: PChar; + const Args: array of const): PChar; overload; +function StrLFmt(Buffer: PChar; MaxBufLen: Cardinal; Format: PChar; + const Args: array of const; + const FormatSettings: TFormatSettings): PChar; overload; + +{ FormatBuf formats the argument list given by Args using the format string + given by Format and FmtLen into the buffer given by Buffer and BufLen. + The Format parameter is a reference to a buffer containing FmtLen + characters, and the Buffer parameter is a reference to a buffer of BufLen + characters. The returned value is the number of characters actually stored + in Buffer. The returned value is always less than or equal to BufLen. For + further details, see the description of the Format function. } + +function FormatBuf(var Buffer; BufLen: Cardinal; const Format; + FmtLen: Cardinal; const Args: array of const): Cardinal; overload; +function FormatBuf(var Buffer; BufLen: Cardinal; const Format; + FmtLen: Cardinal; const Args: array of const; + const FormatSettings: TFormatSettings): Cardinal; overload; + +{ The WideFormat routine formats the argument list given by the Args parameter + using the format WideString given by the Format parameter. This routine is + the WideString equivalent of Format. For further details, see the description + of the Format function. } +function WideFormat(const Format: WideString; + const Args: array of const): WideString; overload; +function WideFormat(const Format: WideString; + const Args: array of const; + const FormatSettings: TFormatSettings): WideString; overload; + +{ WideFmtStr formats the argument list given by Args using the format WideString + given by Format into the WideString variable given by Result. For further + details, see the description of the Format function. } +procedure WideFmtStr(var Result: WideString; const Format: WideString; + const Args: array of const); overload; +procedure WideFmtStr(var Result: WideString; const Format: WideString; + const Args: array of const; const FormatSettings: TFormatSettings); overload; + +{ WideFormatBuf formats the argument list given by Args using the format string + given by Format and FmtLen into the buffer given by Buffer and BufLen. + The Format parameter is a reference to a buffer containing FmtLen + UNICODE characters (WideChar), and the Buffer parameter is a reference to a + buffer of BufLen UNICODE characters (WideChar). The return value is the number + of UNICODE characters actually stored in Buffer. The return value is always + less than or equal to BufLen. For further details, see the description of the + Format function. + + Important: BufLen, FmtLen and the return result are always the number of + UNICODE characters, *not* the number of bytes. To calculate the number of bytes + multiply them by SizeOf(WideChar). } +function WideFormatBuf(var Buffer; BufLen: Cardinal; const Format; + FmtLen: Cardinal; const Args: array of const): Cardinal; overload; +function WideFormatBuf(var Buffer; BufLen: Cardinal; const Format; + FmtLen: Cardinal; const Args: array of const; + const FormatSettings: TFormatSettings): Cardinal; overload; + +{ Floating point conversion routines } + +{ Each of the floating point conversion routines that uses global variables + for formatting (separators, decimals, etc.), has an overloaded equivalent + requiring a parameter of type TFormatSettings. This additional parameter + provides the formatting information rather than the global variables. For + more information see the notes at TFormatSettings. } + +{ FloatToStr converts the floating-point value given by Value to its string + representation. The conversion uses general number format with 15 + significant digits. For further details, see the description of the + FloatToStrF function. } + +function FloatToStr(Value: Extended): string; overload; +function FloatToStr(Value: Extended; + const FormatSettings: TFormatSettings): string; overload; + +{ CurrToStr converts the currency value given by Value to its string + representation. The conversion uses general number format. For further + details, see the description of the CurrToStrF function. } + +function CurrToStr(Value: Currency): string; overload; +function CurrToStr(Value: Currency; + const FormatSettings: TFormatSettings): string; overload; + +{ FloatToCurr will range validate a value to make sure it falls + within the acceptable currency range } + +const + MinCurrency: Currency = -922337203685477.5807 {$IFDEF LINUX} + 1 {$ENDIF}; //!! overflow? + MaxCurrency: Currency = 922337203685477.5807 {$IFDEF LINUX} - 1 {$ENDIF}; //!! overflow? + +function FloatToCurr(const Value: Extended): Currency; +function TryFloatToCurr(const Value: Extended; out AResult: Currency): Boolean; + +{ FloatToStrF converts the floating-point value given by Value to its string + representation. The Format parameter controls the format of the resulting + string. The Precision parameter specifies the precision of the given value. + It should be 7 or less for values of type Single, 15 or less for values of + type Double, and 18 or less for values of type Extended. The meaning of the + Digits parameter depends on the particular format selected. + + The possible values of the Format parameter, and the meaning of each, are + described below. + + ffGeneral - General number format. The value is converted to the shortest + possible decimal string using fixed or scientific format. Trailing zeros + are removed from the resulting string, and a decimal point appears only + if necessary. The resulting string uses fixed point format if the number + of digits to the left of the decimal point in the value is less than or + equal to the specified precision, and if the value is greater than or + equal to 0.00001. Otherwise the resulting string uses scientific format, + and the Digits parameter specifies the minimum number of digits in the + exponent (between 0 and 4). + + ffExponent - Scientific format. The value is converted to a string of the + form "-d.ddd...E+dddd". The resulting string starts with a minus sign if + the number is negative, and one digit always precedes the decimal point. + The total number of digits in the resulting string (including the one + before the decimal point) is given by the Precision parameter. The "E" + exponent character in the resulting string is always followed by a plus + or minus sign and up to four digits. The Digits parameter specifies the + minimum number of digits in the exponent (between 0 and 4). + + ffFixed - Fixed point format. The value is converted to a string of the + form "-ddd.ddd...". The resulting string starts with a minus sign if the + number is negative, and at least one digit always precedes the decimal + point. The number of digits after the decimal point is given by the Digits + parameter--it must be between 0 and 18. If the number of digits to the + left of the decimal point is greater than the specified precision, the + resulting value will use scientific format. + + ffNumber - Number format. The value is converted to a string of the form + "-d,ddd,ddd.ddd...". The ffNumber format corresponds to the ffFixed format, + except that the resulting string contains thousand separators. + + ffCurrency - Currency format. The value is converted to a string that + represents a currency amount. The conversion is controlled by the + CurrencyString, CurrencyFormat, NegCurrFormat, ThousandSeparator, and + DecimalSeparator global variables, all of which are initialized from + locale settings provided by the operating system. For example, + Currency Format preferences can be set in the International section + of the Windows Control Panel. + The number of digits after the decimal point is given by the Digits + parameter--it must be between 0 and 18. + + For all formats, the actual characters used as decimal and thousand + separators are obtained from the DecimalSeparator and ThousandSeparator + global variables. + + If the given value is a NAN (not-a-number), the resulting string is 'NAN'. + If the given value is positive infinity, the resulting string is 'INF'. If + the given value is negative infinity, the resulting string is '-INF'. } + +function FloatToStrF(Value: Extended; Format: TFloatFormat; + Precision, Digits: Integer): string; overload; +function FloatToStrF(Value: Extended; Format: TFloatFormat; + Precision, Digits: Integer; + const FormatSettings: TFormatSettings): string; overload; + +{ CurrToStrF converts the currency value given by Value to its string + representation. A call to CurrToStrF corresponds to a call to + FloatToStrF with an implied precision of 19 digits. } + +function CurrToStrF(Value: Currency; Format: TFloatFormat; + Digits: Integer): string; overload; +function CurrToStrF(Value: Currency; Format: TFloatFormat; + Digits: Integer; const FormatSettings: TFormatSettings): string; overload; + +{ FloatToText converts the given floating-point value to its decimal + representation using the specified format, precision, and digits. The + Value parameter must be a variable of type Extended or Currency, as + indicated by the ValueType parameter. The resulting string of characters + is stored in the given buffer, and the returned value is the number of + characters stored. The resulting string is not null-terminated. For + further details, see the description of the FloatToStrF function. } + +function FloatToText(BufferArg: PChar; const Value; ValueType: TFloatValue; + Format: TFloatFormat; Precision, Digits: Integer): Integer; overload; +function FloatToText(BufferArg: PChar; const Value; ValueType: TFloatValue; + Format: TFloatFormat; Precision, Digits: Integer; + const FormatSettings: TFormatSettings): Integer; overload; + +{ FormatFloat formats the floating-point value given by Value using the + format string given by Format. The following format specifiers are + supported in the format string: + + 0 Digit placeholder. If the value being formatted has a digit in the + position where the '0' appears in the format string, then that digit + is copied to the output string. Otherwise, a '0' is stored in that + position in the output string. + + # Digit placeholder. If the value being formatted has a digit in the + position where the '#' appears in the format string, then that digit + is copied to the output string. Otherwise, nothing is stored in that + position in the output string. + + . Decimal point. The first '.' character in the format string + determines the location of the decimal separator in the formatted + value; any additional '.' characters are ignored. The actual + character used as a the decimal separator in the output string is + determined by the DecimalSeparator global variable, which is initialized + from locale settings obtained from the operating system. + + , Thousand separator. If the format string contains one or more ',' + characters, the output will have thousand separators inserted between + each group of three digits to the left of the decimal point. The + placement and number of ',' characters in the format string does not + affect the output, except to indicate that thousand separators are + wanted. The actual character used as a the thousand separator in the + output is determined by the ThousandSeparator global variable, which + is initialized from locale settings obtained from the operating system. + + E+ Scientific notation. If any of the strings 'E+', 'E-', 'e+', or 'e-' + E- are contained in the format string, the number is formatted using + e+ scientific notation. A group of up to four '0' characters can + e- immediately follow the 'E+', 'E-', 'e+', or 'e-' to determine the + minimum number of digits in the exponent. The 'E+' and 'e+' formats + cause a plus sign to be output for positive exponents and a minus + sign to be output for negative exponents. The 'E-' and 'e-' formats + output a sign character only for negative exponents. + + 'xx' Characters enclosed in single or double quotes are output as-is, and + "xx" do not affect formatting. + + ; Separates sections for positive, negative, and zero numbers in the + format string. + + The locations of the leftmost '0' before the decimal point in the format + string and the rightmost '0' after the decimal point in the format string + determine the range of digits that are always present in the output string. + + The number being formatted is always rounded to as many decimal places as + there are digit placeholders ('0' or '#') to the right of the decimal + point. If the format string contains no decimal point, the value being + formatted is rounded to the nearest whole number. + + If the number being formatted has more digits to the left of the decimal + separator than there are digit placeholders to the left of the '.' + character in the format string, the extra digits are output before the + first digit placeholder. + + To allow different formats for positive, negative, and zero values, the + format string can contain between one and three sections separated by + semicolons. + + One section - The format string applies to all values. + + Two sections - The first section applies to positive values and zeros, and + the second section applies to negative values. + + Three sections - The first section applies to positive values, the second + applies to negative values, and the third applies to zeros. + + If the section for negative values or the section for zero values is empty, + that is if there is nothing between the semicolons that delimit the + section, the section for positive values is used instead. + + If the section for positive values is empty, or if the entire format string + is empty, the value is formatted using general floating-point formatting + with 15 significant digits, corresponding to a call to FloatToStrF with + the ffGeneral format. General floating-point formatting is also used if + the value has more than 18 digits to the left of the decimal point and + the format string does not specify scientific notation. + + The table below shows some sample formats and the results produced when + the formats are applied to different values: + + Format string 1234 -1234 0.5 0 + ----------------------------------------------------------------------- + 1234 -1234 0.5 0 + 0 1234 -1234 1 0 + 0.00 1234.00 -1234.00 0.50 0.00 + #.## 1234 -1234 .5 + #,##0.00 1,234.00 -1,234.00 0.50 0.00 + #,##0.00;(#,##0.00) 1,234.00 (1,234.00) 0.50 0.00 + #,##0.00;;Zero 1,234.00 -1,234.00 0.50 Zero + 0.000E+00 1.234E+03 -1.234E+03 5.000E-01 0.000E+00 + #.###E-0 1.234E3 -1.234E3 5E-1 0E0 + ----------------------------------------------------------------------- } + +function FormatFloat(const Format: string; Value: Extended): string; overload; +function FormatFloat(const Format: string; Value: Extended; + const FormatSettings: TFormatSettings): string; overload; + +{ FormatCurr formats the currency value given by Value using the format + string given by Format. For further details, see the description of the + FormatFloat function. } + +function FormatCurr(const Format: string; Value: Currency): string; overload; +function FormatCurr(const Format: string; Value: Currency; + const FormatSettings: TFormatSettings): string; overload; + +{ FloatToTextFmt converts the given floating-point value to its decimal + representation using the specified format. The Value parameter must be a + variable of type Extended or Currency, as indicated by the ValueType + parameter. The resulting string of characters is stored in the given + buffer, and the returned value is the number of characters stored. The + resulting string is not null-terminated. For further details, see the + description of the FormatFloat function. } + +function FloatToTextFmt(Buf: PChar; const Value; ValueType: TFloatValue; + Format: PChar): Integer; overload; +function FloatToTextFmt(Buf: PChar; const Value; ValueType: TFloatValue; + Format: PChar; const FormatSettings: TFormatSettings): Integer; overload; + +{ StrToFloat converts the given string to a floating-point value. The string + must consist of an optional sign (+ or -), a string of digits with an + optional decimal point, and an optional 'E' or 'e' followed by a signed + integer. Leading and trailing blanks in the string are ignored. The + DecimalSeparator global variable defines the character that must be used + as a decimal point. Thousand separators and currency symbols are not + allowed in the string. If the string doesn't contain a valid value, an + EConvertError exception is raised. } + +function StrToFloat(const S: string): Extended; overload; +function StrToFloat(const S: string; + const FormatSettings: TFormatSettings): Extended; overload; + +function StrToFloatDef(const S: string; + const Default: Extended): Extended; overload; +function StrToFloatDef(const S: string; const Default: Extended; + const FormatSettings: TFormatSettings): Extended; overload; + +function TryStrToFloat(const S: string; out Value: Extended): Boolean; overload; +function TryStrToFloat(const S: string; out Value: Extended; + const FormatSettings: TFormatSettings): Boolean; overload; + +function TryStrToFloat(const S: string; out Value: Double): Boolean; overload; +function TryStrToFloat(const S: string; out Value: Double; + const FormatSettings: TFormatSettings): Boolean; overload; + +function TryStrToFloat(const S: string; out Value: Single): Boolean; overload; +function TryStrToFloat(const S: string; out Value: Single; + const FormatSettings: TFormatSettings): Boolean; overload; + +{ StrToCurr converts the given string to a currency value. For further + details, see the description of the StrToFloat function. } + +function StrToCurr(const S: string): Currency; overload; +function StrToCurr(const S: string; + const FormatSettings: TFormatSettings): Currency; overload; + +function StrToCurrDef(const S: string; + const Default: Currency): Currency; overload; +function StrToCurrDef(const S: string; const Default: Currency; + const FormatSettings: TFormatSettings): Currency; overload; + +function TryStrToCurr(const S: string; out Value: Currency): Boolean; overload; +function TryStrToCurr(const S: string; out Value: Currency; + const FormatSettings: TFormatSettings): Boolean; overload; + +{ TextToFloat converts the null-terminated string given by Buffer to a + floating-point value which is returned in the variable given by Value. + The Value parameter must be a variable of type Extended or Currency, as + indicated by the ValueType parameter. The return value is True if the + conversion was successful, or False if the string is not a valid + floating-point value. For further details, see the description of the + StrToFloat function. } + +function TextToFloat(Buffer: PChar; var Value; + ValueType: TFloatValue): Boolean; overload; +function TextToFloat(Buffer: PChar; var Value; ValueType: TFloatValue; + const FormatSettings: TFormatSettings): Boolean; overload; + +{ FloatToDecimal converts a floating-point value to a decimal representation + that is suited for further formatting. The Value parameter must be a + variable of type Extended or Currency, as indicated by the ValueType + parameter. For values of type Extended, the Precision parameter specifies + the requested number of significant digits in the result--the allowed range + is 1..18. For values of type Currency, the Precision parameter is ignored, + and the implied precision of the conversion is 19 digits. The Decimals + parameter specifies the requested maximum number of digits to the left of + the decimal point in the result. Precision and Decimals together control + how the result is rounded. To produce a result that always has a given + number of significant digits regardless of the magnitude of the number, + specify 9999 for the Decimals parameter. The result of the conversion is + stored in the specified TFloatRec record as follows: + + Exponent - Contains the magnitude of the number, i.e. the number of + significant digits to the right of the decimal point. The Exponent field + is negative if the absolute value of the number is less than one. If the + number is a NAN (not-a-number), Exponent is set to -32768. If the number + is INF or -INF (positive or negative infinity), Exponent is set to 32767. + + Negative - True if the number is negative, False if the number is zero + or positive. + + Digits - Contains up to 18 (for type Extended) or 19 (for type Currency) + significant digits followed by a null terminator. The implied decimal + point (if any) is not stored in Digits. Trailing zeros are removed, and + if the resulting number is zero, NAN, or INF, Digits contains nothing but + the null terminator. } + +procedure FloatToDecimal(var Result: TFloatRec; const Value; + ValueType: TFloatValue; Precision, Decimals: Integer); + +{ Date/time support routines } + +function DateTimeToTimeStamp(DateTime: TDateTime): TTimeStamp; + +function TimeStampToDateTime(const TimeStamp: TTimeStamp): TDateTime; +function MSecsToTimeStamp(MSecs: Comp): TTimeStamp; +function TimeStampToMSecs(const TimeStamp: TTimeStamp): Comp; + +{ EncodeDate encodes the given year, month, and day into a TDateTime value. + The year must be between 1 and 9999, the month must be between 1 and 12, + and the day must be between 1 and N, where N is the number of days in the + specified month. If the specified values are not within range, an + EConvertError exception is raised. The resulting value is the number of + days between 12/30/1899 and the given date. } + +function EncodeDate(Year, Month, Day: Word): TDateTime; + +{ EncodeTime encodes the given hour, minute, second, and millisecond into a + TDateTime value. The hour must be between 0 and 23, the minute must be + between 0 and 59, the second must be between 0 and 59, and the millisecond + must be between 0 and 999. If the specified values are not within range, an + EConvertError exception is raised. The resulting value is a number between + 0 (inclusive) and 1 (not inclusive) that indicates the fractional part of + a day given by the specified time. The value 0 corresponds to midnight, + 0.5 corresponds to noon, 0.75 corresponds to 6:00 pm, etc. } + +function EncodeTime(Hour, Min, Sec, MSec: Word): TDateTime; + +{ Instead of generating errors the following variations of EncodeDate and + EncodeTime simply return False if the parameters given are not valid. + Other than that, these functions are functionally the same as the above + functions. } + +function TryEncodeDate(Year, Month, Day: Word; out Date: TDateTime): Boolean; +function TryEncodeTime(Hour, Min, Sec, MSec: Word; out Time: TDateTime): Boolean; + +{ DecodeDate decodes the integral (date) part of the given TDateTime value + into its corresponding year, month, and day. If the given TDateTime value + is less than or equal to zero, the year, month, and day return parameters + are all set to zero. } + +procedure DecodeDate(const DateTime: TDateTime; var Year, Month, Day: Word); + +{ This variation of DecodeDate works similarly to the above function but + returns more information. The result value of this function indicates + whether the year decoded is a leap year or not. } + +function DecodeDateFully(const DateTime: TDateTime; var Year, Month, Day, + DOW: Word): Boolean; + +{$IFDEF LINUX} +function InternalDecodeDate(const DateTime: TDateTime; var Year, Month, Day, DOW: Word): Boolean; +{$ENDIF} + +{ DecodeTime decodes the fractional (time) part of the given TDateTime value + into its corresponding hour, minute, second, and millisecond. } + +procedure DecodeTime(const DateTime: TDateTime; var Hour, Min, Sec, MSec: Word); + +{$IFDEF MSWINDOWS} +{ DateTimeToSystemTime converts a date and time from Delphi's TDateTime + format into the Win32 API's TSystemTime format. } + +procedure DateTimeToSystemTime(const DateTime: TDateTime; var SystemTime: TSystemTime); + +{ SystemTimeToDateTime converts a date and time from the Win32 API's + TSystemTime format into Delphi's TDateTime format. } + +function SystemTimeToDateTime(const SystemTime: TSystemTime): TDateTime; +{$ENDIF} + +{ DayOfWeek returns the day of the week of the given date. The result is an + integer between 1 and 7, corresponding to Sunday through Saturday. + This function is not ISO 8601 compliant, for that see the DateUtils unit. } + +function DayOfWeek(const DateTime: TDateTime): Word; + +{ Date returns the current date. } + +function Date: TDateTime; + +{ Time returns the current time. } + +function Time: TDateTime; +{$IFDEF LINUX} + { clashes with Time in , use GetTime instead } + {$EXTERNALSYM Time} +{$ENDIF} +function GetTime: TDateTime; + +{ Now returns the current date and time, corresponding to Date + Time. } + +function Now: TDateTime; + +{ Current year returns the year portion of the date returned by Now } + +function CurrentYear: Word; + +{ IncMonth returns Date shifted by the specified number of months. + NumberOfMonths parameter can be negative, to return a date N months ago. + If the input day of month is greater than the last day of the resulting + month, the day is set to the last day of the resulting month. + Input time of day is copied to the DateTime result. } + +function IncMonth(const DateTime: TDateTime; NumberOfMonths: Integer = 1): TDateTime; + +{ Optimized version of IncMonth that works with years, months and days + directly. See above comments for more detail as to what happens to the day + when incrementing months } + +procedure IncAMonth(var Year, Month, Day: Word; NumberOfMonths: Integer = 1); + +{ ReplaceTime replaces the time portion of the DateTime parameter with the given + time value, adjusting the signs as needed if the date is prior to 1900 + (Date value less than zero) } + +procedure ReplaceTime(var DateTime: TDateTime; const NewTime: TDateTime); + +{ ReplaceDate replaces the date portion of the DateTime parameter with the given + date value, adjusting as needed for negative dates } + +procedure ReplaceDate(var DateTime: TDateTime; const NewDate: TDateTime); + +{ IsLeapYear determines whether the given year is a leap year. } + +function IsLeapYear(Year: Word): Boolean; + +type + PDayTable = ^TDayTable; + TDayTable = array[1..12] of Word; + +{ The MonthDays array can be used to quickly find the number of + days in a month: MonthDays[IsLeapYear(Y), M] } + +const + MonthDays: array [Boolean] of TDayTable = + ((31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31), + (31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)); + +{ Each of the date/time formatting routines that uses global variables + for formatting (separators, decimals, etc.), has an overloaded equivalent + requiring a parameter of type TFormatSettings. This additional parameter + provides the formatting information rather than the global variables. For + more information see the note at TFormatSettings. } + +{ DateToStr converts the date part of the given TDateTime value to a string. + The conversion uses the format specified by the ShortDateFormat global + variable. } + +function DateToStr(const DateTime: TDateTime): string; overload; inline; +function DateToStr(const DateTime: TDateTime; + const FormatSettings: TFormatSettings): string; overload; inline; + +{ TimeToStr converts the time part of the given TDateTime value to a string. + The conversion uses the format specified by the LongTimeFormat global + variable. } + +function TimeToStr(const DateTime: TDateTime): string; overload; inline; +function TimeToStr(const DateTime: TDateTime; + const FormatSettings: TFormatSettings): string; overload; inline; + +{ DateTimeToStr converts the given date and time to a string. The resulting + string consists of a date and time formatted using the ShortDateFormat and + LongTimeFormat global variables. Time information is included in the + resulting string only if the fractional part of the given date and time + value is non-zero. } + +function DateTimeToStr(const DateTime: TDateTime): string; overload; inline; +function DateTimeToStr(const DateTime: TDateTime; + const FormatSettings: TFormatSettings): string; overload; inline; + +{ StrToDate converts the given string to a date value. The string must + consist of two or three numbers, separated by the character defined by + the DateSeparator global variable. The order for month, day, and year is + determined by the ShortDateFormat global variable--possible combinations + are m/d/y, d/m/y, and y/m/d. If the string contains only two numbers, it + is interpreted as a date (m/d or d/m) in the current year. Year values + between 0 and 99 are assumed to be in the current century. If the given + string does not contain a valid date, an EConvertError exception is + raised. } + +function StrToDate(const S: string): TDateTime; overload; +function StrToDate(const S: string; + const FormatSettings: TFormatSettings): TDateTime; overload; + +function StrToDateDef(const S: string; + const Default: TDateTime): TDateTime; overload; +function StrToDateDef(const S: string; const Default: TDateTime; + const FormatSettings: TFormatSettings): TDateTime; overload; + +function TryStrToDate(const S: string; out Value: TDateTime): Boolean; overload; +function TryStrToDate(const S: string; out Value: TDateTime; + const FormatSettings: TFormatSettings): Boolean; overload; + +{ StrToTime converts the given string to a time value. The string must + consist of two or three numbers, separated by the character defined by + the TimeSeparator global variable, optionally followed by an AM or PM + indicator. The numbers represent hour, minute, and (optionally) second, + in that order. If the time is followed by AM or PM, it is assumed to be + in 12-hour clock format. If no AM or PM indicator is included, the time + is assumed to be in 24-hour clock format. If the given string does not + contain a valid time, an EConvertError exception is raised. } + +function StrToTime(const S: string): TDateTime; overload; +function StrToTime(const S: string; + const FormatSettings: TFormatSettings): TDateTime; overload; + +function StrToTimeDef(const S: string; + const Default: TDateTime): TDateTime; overload; +function StrToTimeDef(const S: string; const Default: TDateTime; + const FormatSettings: TFormatSettings): TDateTime; overload; + +function TryStrToTime(const S: string; out Value: TDateTime): Boolean; overload; +function TryStrToTime(const S: string; out Value: TDateTime; + const FormatSettings: TFormatSettings): Boolean; overload; + +{ StrToDateTime converts the given string to a date and time value. The + string must contain a date optionally followed by a time. The date and + time parts of the string must follow the formats described for the + StrToDate and StrToTime functions. } + +function StrToDateTime(const S: string): TDateTime; overload; +function StrToDateTime(const S: string; + const FormatSettings: TFormatSettings): TDateTime; overload; + +function StrToDateTimeDef(const S: string; + const Default: TDateTime): TDateTime; overload; +function StrToDateTimeDef(const S: string; const Default: TDateTime; + const FormatSettings: TFormatSettings): TDateTime; overload; + +function TryStrToDateTime(const S: string; + out Value: TDateTime): Boolean; overload; +function TryStrToDateTime(const S: string; out Value: TDateTime; + const FormatSettings: TFormatSettings): Boolean; overload; + +{ FormatDateTime formats the date-and-time value given by DateTime using the + format given by Format. The following format specifiers are supported: + + c Displays the date using the format given by the ShortDateFormat + global variable, followed by the time using the format given by + the LongTimeFormat global variable. The time is not displayed if + the fractional part of the DateTime value is zero. + + d Displays the day as a number without a leading zero (1-31). + + dd Displays the day as a number with a leading zero (01-31). + + ddd Displays the day as an abbreviation (Sun-Sat) using the strings + given by the ShortDayNames global variable. + + dddd Displays the day as a full name (Sunday-Saturday) using the strings + given by the LongDayNames global variable. + + ddddd Displays the date using the format given by the ShortDateFormat + global variable. + + dddddd Displays the date using the format given by the LongDateFormat + global variable. + + g Displays the period/era as an abbreviation (Japanese and + Taiwanese locales only). + + gg Displays the period/era as a full name. + + e Displays the year in the current period/era as a number without + a leading zero (Japanese, Korean and Taiwanese locales only). + + ee Displays the year in the current period/era as a number with + a leading zero (Japanese, Korean and Taiwanese locales only). + + m Displays the month as a number without a leading zero (1-12). If + the m specifier immediately follows an h or hh specifier, the + minute rather than the month is displayed. + + mm Displays the month as a number with a leading zero (01-12). If + the mm specifier immediately follows an h or hh specifier, the + minute rather than the month is displayed. + + mmm Displays the month as an abbreviation (Jan-Dec) using the strings + given by the ShortMonthNames global variable. + + mmmm Displays the month as a full name (January-December) using the + strings given by the LongMonthNames global variable. + + yy Displays the year as a two-digit number (00-99). + + yyyy Displays the year as a four-digit number (0000-9999). + + h Displays the hour without a leading zero (0-23). + + hh Displays the hour with a leading zero (00-23). + + n Displays the minute without a leading zero (0-59). + + nn Displays the minute with a leading zero (00-59). + + s Displays the second without a leading zero (0-59). + + ss Displays the second with a leading zero (00-59). + + z Displays the millisecond without a leading zero (0-999). + + zzz Displays the millisecond with a leading zero (000-999). + + t Displays the time using the format given by the ShortTimeFormat + global variable. + + tt Displays the time using the format given by the LongTimeFormat + global variable. + + am/pm Uses the 12-hour clock for the preceding h or hh specifier, and + displays 'am' for any hour before noon, and 'pm' for any hour + after noon. The am/pm specifier can use lower, upper, or mixed + case, and the result is displayed accordingly. + + a/p Uses the 12-hour clock for the preceding h or hh specifier, and + displays 'a' for any hour before noon, and 'p' for any hour after + noon. The a/p specifier can use lower, upper, or mixed case, and + the result is displayed accordingly. + + ampm Uses the 12-hour clock for the preceding h or hh specifier, and + displays the contents of the TimeAMString global variable for any + hour before noon, and the contents of the TimePMString global + variable for any hour after noon. + + / Displays the date separator character given by the DateSeparator + global variable. + + : Displays the time separator character given by the TimeSeparator + global variable. + + 'xx' Characters enclosed in single or double quotes are displayed as-is, + "xx" and do not affect formatting. + + Format specifiers may be written in upper case as well as in lower case + letters--both produce the same result. + + If the string given by the Format parameter is empty, the date and time + value is formatted as if a 'c' format specifier had been given. + + The following example: + + S := FormatDateTime('"The meeting is on" dddd, mmmm d, yyyy, ' + + '"at" hh:mm AM/PM', StrToDateTime('2/15/95 10:30am')); + + assigns 'The meeting is on Wednesday, February 15, 1995 at 10:30 AM' to + the string variable S. } + +function FormatDateTime(const Format: string; + DateTime: TDateTime): string; overload; inline; +function FormatDateTime(const Format: string; DateTime: TDateTime; + const FormatSettings: TFormatSettings): string; overload; + +{ DateTimeToString converts the date and time value given by DateTime using + the format string given by Format into the string variable given by Result. + For further details, see the description of the FormatDateTime function. } + +procedure DateTimeToString(var Result: string; const Format: string; + DateTime: TDateTime); overload; +procedure DateTimeToString(var Result: string; const Format: string; + DateTime: TDateTime; const FormatSettings: TFormatSettings); overload; + +{ FloatToDateTime will range validate a value to make sure it falls + within the acceptable date range } + +const + MinDateTime: TDateTime = -657434.0; { 01/01/0100 12:00:00.000 AM } + MaxDateTime: TDateTime = 2958465.99999; { 12/31/9999 11:59:59.999 PM } + +function FloatToDateTime(const Value: Extended): TDateTime; +function TryFloatToDateTime(const Value: Extended; out AResult: TDateTime): Boolean; + +{ System error messages } + +function SysErrorMessage(ErrorCode: Integer): string; + +{ Initialization file support } + +function GetLocaleStr(Locale, LocaleType: Integer; const Default: string): string; platform; +function GetLocaleChar(Locale, LocaleType: Integer; Default: Char): Char; platform; + +{ GetFormatSettings resets all locale-specific variables (date, time, number, + currency formats, system locale) to the values provided by the operating system. } + +procedure GetFormatSettings; + +{ GetLocaleFormatSettings loads locale-specific variables (date, time, number, + currency formats) with values provided by the operating system for the + specified locale (LCID). The values are stored in the FormatSettings record. } + +{$IFDEF MSWINDOWS} +procedure GetLocaleFormatSettings(LCID: Integer; + var FormatSettings: TFormatSettings); +{$ENDIF} + +{ Exception handling routines } + +{$IFDEF LINUX} +{ InquireSignal is used to determine the state of an OS signal handler. + Pass it one of the RTL_SIG* constants, and it will return a TSignalState + which will tell you if the signal has been hooked, not hooked, or overriden + by some other module. You can use this function to determine if some other + module has hijacked your signal handlers, should you wish to reinstall your + own. This is a risky proposition under Linux, and is only recommended as a + last resort. Do not pass RTL_SIGDEFAULT to this function. +} +function InquireSignal(RtlSigNum: Integer): TSignalState; + +{ AbandonSignalHandler tells the RTL to leave a signal handler + in place, even if we believe that we hooked it at startup time. + + Once you have called AbandonSignalHandler with a specific signal number, + neither UnhookSignal nor the RTL will restore any previous signal handler + under any condition. +} +procedure AbandonSignalHandler(RtlSigNum: Integer); + +{ HookSignal is used to hook individual signals, or an RTL-defined default + set of signals. It does not test whether a signal has already been + hooked, so it should be used in conjunction with InquireSignal. It is + exposed to enable users to hook signals in standalone libraries, or in the + event that an external module hijacks the RTL installed signal handlers. + Pass RTL_SIGDEFAULT if you want to hook all the signals that the RTL + normally hooks at startup time. +} +procedure HookSignal(RtlSigNum: Integer); + +{ UnhookSignal is used to remove signal handlers installed by HookSignal. + It can remove individual signal handlers, or the RTL-defined default set + of signals. If OnlyIfHooked is True, then we will only unhook the signal + if the signal handler has been hooked, and has not since been overriden by + some foreign handler. +} +procedure UnhookSignal(RtlSigNum: Integer; OnlyIfHooked: Boolean = True); + +{ HookOSExceptions is used internally by thread support. DON'T call this + function yourself. } +procedure HookOSExceptions; + +{ MapSignal is used internally as well. It maps a signal and associated + context to an internal value that represents the type of Exception + class to raise. } +function MapSignal(SigNum: Integer; Context: PSigContext): LongWord; + +{ SignalConverter is used internally to properly reinit the FPU and properly + raise an external OS exception object. DON'T call this function yourself. } +procedure SignalConverter(ExceptionEIP: LongWord; FaultAddr: LongWord; ErrorCode: LongWord); + +{ + See the comment at the threadvar declarations for these below. The access + to these has been implemented through getter/setter functions because you + cannot use threadvars across packages. +} +procedure SetSafeCallExceptionMsg(const Msg: String); +procedure SetSafeCallExceptionAddr(Addr: Pointer); +function GetSafeCallExceptionMsg: String; +function GetSafeCallExceptionAddr: Pointer; + +{ HookOSExceptionsProc is used internally and cannot be used in a conventional + manner. DON'T ever set this variable. } +var + HookOSExceptionsProc: procedure = nil platform deprecated; + +{ LoadLibrary / FreeLibrary are defined here only for convenience. On Linux, + they map directly to dlopen / dlclose. Note that module loading semantics + on Linux are not identical to Windows. } + +function LoadLibrary(ModuleName: PChar): HMODULE; + +function FreeLibrary(Module: HMODULE): LongBool; + +{ GetProcAddress does what it implies. It performs the same function as the like + named function under Windows. dlsym does not quite have the same sematics as + GetProcAddress as it will return the address of a symbol in another module if + it was not found in the given HMODULE. This function will verify that the 'Proc' + is actually found within the 'Module', and if not returns nil } +function GetProcAddress(Module: HMODULE; Proc: PChar): Pointer; + +{ Given a module name, this function will return the module handle. There is no + direct equivalent in Linux so this function provides that capability. Also + note, this function is specific to glibc. } +function GetModuleHandle(ModuleName: PChar): HMODULE; + +{ This function works just like GetModuleHandle, except it will look for a module + that matches the given base package name. For example, given the base package + name 'package', the actual module name is, by default, 'bplpackage.so'. This + function will search for the string 'package' within the module name. } +function GetPackageModuleHandle(PackageName: PChar): HMODULE; + +{$ENDIF} + +{ In Linux, the parameter to sleep() is in whole seconds. In Windows, the + parameter is in milliseconds. To ease headaches, we implement a version + of sleep here for Linux that takes milliseconds and calls a Linux system + function with sub-second resolution. This maps directly to the Windows + API on Windows. } + +procedure Sleep(milliseconds: Cardinal);{$IFDEF MSWINDOWS} stdcall; {$ENDIF} +{$IFDEF MSWINDOWS} +(*$EXTERNALSYM Sleep*) +{$ENDIF} + +function GetModuleName(Module: HMODULE): string; + +function ExceptionErrorMessage(ExceptObject: TObject; ExceptAddr: Pointer; + Buffer: PChar; Size: Integer): Integer; + +procedure ShowException(ExceptObject: TObject; ExceptAddr: Pointer); + +procedure Abort; + +procedure OutOfMemoryError; + +procedure Beep; + +{ MBCS functions } + +{ LeadBytes is a char set that indicates which char values are lead bytes + in multibyte character sets (Japanese, Chinese, etc). + This set is always empty for western locales. } +var + LeadBytes: set of Char = []; +(*$EXTERNALSYM LeadBytes*) +(*$HPPEMIT 'namespace Sysutils {'*) +(*$HPPEMIT 'extern PACKAGE System::Set LeadBytes;'*) +(*$HPPEMIT '} // namespace Sysutils'*) + +{ ByteType indicates what kind of byte exists at the Index'th byte in S. + Western locales always return mbSingleByte. Far East multibyte locales + may also return mbLeadByte, indicating the byte is the first in a multibyte + character sequence, and mbTrailByte, indicating that the byte is one of + a sequence of bytes following a lead byte. One or more trail bytes can + follow a lead byte, depending on locale charset encoding and OS platform. + Parameters are assumed to be valid. } + +function ByteType(const S: string; Index: Integer): TMbcsByteType; + +{ StrByteType works the same as ByteType, but on null-terminated PChar strings } + +function StrByteType(Str: PChar; Index: Cardinal): TMbcsByteType; + +{ ByteToCharLen returns the character length of a MBCS string, scanning the + string for up to MaxLen bytes. In multibyte character sets, the number of + characters in a string may be less than the number of bytes. } + +function ByteToCharLen(const S: string; MaxLen: Integer): Integer; + +{ CharToByteLen returns the byte length of a MBCS string, scanning the string + for up to MaxLen characters. } + +function CharToByteLen(const S: string; MaxLen: Integer): Integer; + +{ ByteToCharIndex returns the 1-based character index of the Index'th byte in + a MBCS string. Returns zero if Index is out of range: + (Index <= 0) or (Index > Length(S)) } + +function ByteToCharIndex(const S: string; Index: Integer): Integer; + +{ CharToByteIndex returns the 1-based byte index of the Index'th character + in a MBCS string. Returns zero if Index or Result are out of range: + (Index <= 0) or (Index > Length(S)) or (Result would be > Length(S)) } + +function CharToByteIndex(const S: string; Index: Integer): Integer; + +{ StrCharLength returns the number of bytes required by the first character + in Str. In Windows, multibyte characters can be up to two bytes in length. + In Linux, multibyte characters can be up to six bytes in length (UTF-8). } + +function StrCharLength(const Str: PChar): Integer; + +{ StrNextChar returns a pointer to the first byte of the character following + the character pointed to by Str. } + +function StrNextChar(const Str: PChar): PChar; + +{ CharLength returns the number of bytes required by the character starting + at bytes S[Index]. } + +function CharLength(const S: String; Index: Integer): Integer; + +{ NextCharIndex returns the byte index of the first byte of the character + following the character starting at S[Index]. } + +function NextCharIndex(const S: String; Index: Integer): Integer; + +{ IsPathDelimiter returns True if the character at byte S[Index] + is a PathDelimiter ('\' or '/'), and it is not a MBCS lead or trail byte. } + +function IsPathDelimiter(const S: string; Index: Integer): Boolean; + +{ IsDelimiter returns True if the character at byte S[Index] matches any + character in the Delimiters string, and the character is not a MBCS lead or + trail byte. S may contain multibyte characters; Delimiters must contain + only single byte characters. } + +function IsDelimiter(const Delimiters, S: string; Index: Integer): Boolean; + +{ IncludeTrailingPathDelimiter returns the path with a PathDelimiter + ('/' or '\') at the end. This function is MBCS enabled. } + +function IncludeTrailingPathDelimiter(const S: string): string; + +{ IncludeTrailingBackslash is the old name for IncludeTrailingPathDelimiter. } + +function IncludeTrailingBackslash(const S: string): string; platform; inline; + +{ ExcludeTrailingPathDelimiter returns the path without a PathDelimiter + ('\' or '/') at the end. This function is MBCS enabled. } + +function ExcludeTrailingPathDelimiter(const S: string): string; + +{ ExcludeTrailingBackslash is the old name for ExcludeTrailingPathDelimiter. } + +function ExcludeTrailingBackslash(const S: string): string; platform; inline; + +{ LastDelimiter returns the byte index in S of the rightmost whole + character that matches any character in Delimiters (except null (#0)). + S may contain multibyte characters; Delimiters must contain only single + byte non-null characters. + Example: LastDelimiter('\.:', 'c:\filename.ext') returns 12. } + +function LastDelimiter(const Delimiters, S: string): Integer; + +{ AnsiCompareFileName supports DOS file name comparison idiosyncracies + in Far East locales (Zenkaku) on Windows. + In non-MBCS locales on Windows, AnsiCompareFileName is identical to + AnsiCompareText (case insensitive). + On Linux, AnsiCompareFileName is identical to AnsiCompareStr (case sensitive). + For general purpose file name comparisions, you should use this function + instead of AnsiCompareText. } + +function AnsiCompareFileName(const S1, S2: string): Integer; inline; + +function SameFileName(const S1, S2: string): Boolean; inline; + +{ AnsiLowerCaseFileName supports lowercase conversion idiosyncracies of + DOS file names in Far East locales (Zenkaku). In non-MBCS locales, + AnsiLowerCaseFileName is identical to AnsiLowerCase. } + +function AnsiLowerCaseFileName(const S: string): string; + +{ AnsiUpperCaseFileName supports uppercase conversion idiosyncracies of + DOS file names in Far East locales (Zenkaku). In non-MBCS locales, + AnsiUpperCaseFileName is identical to AnsiUpperCase. } + +function AnsiUpperCaseFileName(const S: string): string; + +{ AnsiPos: Same as Pos but supports MBCS strings } + +function AnsiPos(const Substr, S: string): Integer; + +{ AnsiStrPos: Same as StrPos but supports MBCS strings } + +function AnsiStrPos(Str, SubStr: PChar): PChar; + +{ AnsiStrRScan: Same as StrRScan but supports MBCS strings } + +function AnsiStrRScan(Str: PChar; Chr: Char): PChar; + +{ AnsiStrScan: Same as StrScan but supports MBCS strings } + +function AnsiStrScan(Str: PChar; Chr: Char): PChar; + +{ StringReplace replaces occurances of with in a + given string. Assumes the string may contain Multibyte characters } + +type + TReplaceFlags = set of (rfReplaceAll, rfIgnoreCase); + +function StringReplace(const S, OldPattern, NewPattern: string; + Flags: TReplaceFlags): string; + +{ WrapText will scan a string for BreakChars and insert the BreakStr at the + last BreakChar position before MaxCol. Will not insert a break into an + embedded quoted string (both ''' and '"' supported) } + +function WrapText(const Line, BreakStr: string; const BreakChars: TSysCharSet; + MaxCol: Integer): string; overload; +function WrapText(const Line: string; MaxCol: Integer = 45): string; overload; + +{ FindCmdLineSwitch determines whether the string in the Switch parameter + was passed as a command line argument to the application. SwitchChars + identifies valid argument-delimiter characters (i.e., "-" and "/" are + common delimiters). The IgnoreCase paramter controls whether a + case-sensistive or case-insensitive search is performed. } + +const + SwitchChars = {$IFDEF MSWINDOWS} ['/','-']; {$ENDIF} + {$IFDEF LINUX} ['-']; {$ENDIF} + +function FindCmdLineSwitch(const Switch: string; const Chars: TSysCharSet; + IgnoreCase: Boolean): Boolean; overload; + +{ These versions of FindCmdLineSwitch are convenient for writing portable + code. The characters that are valid to indicate command line switches vary + on different platforms. For example, '/' cannot be used as a switch char + on Linux because '/' is the path delimiter. } + +{ This version uses SwitchChars defined above, and IgnoreCase False. } +function FindCmdLineSwitch(const Switch: string): Boolean; overload; + +{ This version uses SwitchChars defined above. } +function FindCmdLineSwitch(const Switch: string; IgnoreCase: Boolean): Boolean; overload; + +{ FreeAndNil frees the given TObject instance and sets the variable reference + to nil. Be careful to only pass TObjects to this routine. } + +procedure FreeAndNil(var Obj); + +{ Interface support routines } + +function Supports(const Instance: IInterface; const IID: TGUID; out Intf): Boolean; overload; +function Supports(const Instance: TObject; const IID: TGUID; out Intf): Boolean; overload; +function Supports(const Instance: IInterface; const IID: TGUID): Boolean; overload; +function Supports(const Instance: TObject; const IID: TGUID): Boolean; overload; +function Supports(const AClass: TClass; const IID: TGUID): Boolean; overload; + +function CreateGUID(out Guid: TGUID): HResult; +{$IFDEF MSWINDOWS} + stdcall; +{$ENDIF} +function StringToGUID(const S: string): TGUID; +function GUIDToString(const GUID: TGUID): string; +function IsEqualGUID(const guid1, guid2: TGUID): Boolean; +{$IFDEF MSWINDOWS} + stdcall; {$EXTERNALSYM IsEqualGUID} +{$ENDIF} + +{ Package support routines } + +{ Package Info flags } + +const + pfNeverBuild = $00000001; + pfDesignOnly = $00000002; + pfRunOnly = $00000004; + pfIgnoreDupUnits = $00000008; + pfModuleTypeMask = $C0000000; + pfExeModule = $00000000; + pfPackageModule = $40000000; + pfProducerMask = $0C000000; + pfV3Produced = $00000000; + pfProducerUndefined = $04000000; + pfBCB4Produced = $08000000; + pfDelphi4Produced = $0C000000; + pfLibraryModule = $80000000; + +{ Unit info flags } + +const + ufMainUnit = $01; + ufPackageUnit = $02; + ufWeakUnit = $04; + ufOrgWeakUnit = $08; + ufImplicitUnit = $10; + + ufWeakPackageUnit = ufPackageUnit or ufWeakUnit; + +{$IFDEF LINUX} +var + PkgLoadingMode: Integer = RTLD_LAZY; +{$ENDIF} + +{ Procedure type of the callback given to GetPackageInfo. Name is the actual + name of the package element. If IsUnit is True then Name is the name of + a contained unit; a required package if False. Param is the value passed + to GetPackageInfo } + +type + TNameType = (ntContainsUnit, ntRequiresPackage, ntDcpBpiName); + + TPackageInfoProc = procedure (const Name: string; NameType: TNameType; Flags: Byte; Param: Pointer); + +{ LoadPackage loads a given package DLL, checks for duplicate units and + calls the initialization blocks of all the contained units } + +function LoadPackage(const Name: string): HMODULE; + +{ UnloadPackage does the opposite of LoadPackage by calling the finalization + blocks of all contained units, then unloading the package DLL } + +procedure UnloadPackage(Module: HMODULE); + +{ GetPackageInfo accesses the given package's info table and enumerates + all the contained units and required packages } + +procedure GetPackageInfo(Module: HMODULE; Param: Pointer; var Flags: Integer; + InfoProc: TPackageInfoProc); + +{ GetPackageDescription loads the description resource from the package + library. If the description resource does not exist, + an empty string is returned. } +function GetPackageDescription(ModuleName: PChar): string; + +{ InitializePackage validates and initializes the given package DLL } + +procedure InitializePackage(Module: HMODULE); + +{ FinalizePackage finalizes the given package DLL } + +procedure FinalizePackage(Module: HMODULE); + +{ RaiseLastOSError calls GetLastError to retrieve the code for + the last occuring error in a call to an OS or system library function. + If GetLastError returns an error code, RaiseLastOSError raises + an EOSError exception with the error code and a system-provided + message associated with with error. } + +procedure RaiseLastOSError; overload; +procedure RaiseLastOSError(LastError: Integer); overload; + +{$IFDEF MSWINDOWS} +procedure RaiseLastWin32Error; deprecated; // use RaiseLastOSError + +{ Win32Check is used to check the return value of a Win32 API function } +{ which returns a BOOL to indicate success. If the Win32 API function } +{ returns False (indicating failure), Win32Check calls RaiseLastOSError } +{ to raise an exception. If the Win32 API function returns True, } +{ Win32Check returns True. } + +function Win32Check(RetVal: BOOL): BOOL; platform; +{$ENDIF} + +{ Termination procedure support } + +type + TTerminateProc = function: Boolean; + +{ Call AddTerminateProc to add a terminate procedure to the system list of } +{ termination procedures. Delphi will call all of the function in the } +{ termination procedure list before an application terminates. The user- } +{ defined TermProc function should return True if the application can } +{ safely terminate or False if the application cannot safely terminate. } +{ If one of the functions in the termination procedure list returns False, } +{ the application will not terminate. } + +procedure AddTerminateProc(TermProc: TTerminateProc); + +{ CallTerminateProcs is called by VCL when an application is about to } +{ terminate. It returns True only if all of the functions in the } +{ system's terminate procedure list return True. This function is } +{ intended only to be called by Delphi, and it should not be called } +{ directly. } + +function CallTerminateProcs: Boolean; + +function GDAL: LongWord; +procedure RCS; +procedure RPR; + + +{ HexDisplayPrefix contains the prefix to display on hexadecimal + values - '$' for Pascal syntax, '0x' for C++ syntax. This is + for display only - this does not affect the string-to-integer + conversion routines. } +var + HexDisplayPrefix: string = '$'; + +{$IFDEF MSWINDOWS} +{ The GetDiskFreeSpace Win32 API does not support partitions larger than 2GB + under Win95. A new Win32 function, GetDiskFreeSpaceEx, supports partitions + larger than 2GB but only exists on Win NT 4.0 and Win95 OSR2. + The GetDiskFreeSpaceEx function pointer variable below will be initialized + at startup to point to either the actual OS API function if it exists on + the system, or to an internal Delphi function if it does not. When running + on Win95 pre-OSR2, the output of this function will still be limited to + the 2GB range reported by Win95, but at least you don't have to worry + about which API function to call in code you write. } + +var + GetDiskFreeSpaceEx: function (Directory: PChar; var FreeAvailable, + TotalSpace: TLargeInteger; TotalFree: PLargeInteger): Bool stdcall = nil; + +{ SafeLoadLibrary calls LoadLibrary, disabling normal Win32 error message + popup dialogs if the requested file can't be loaded. SafeLoadLibrary also + preserves the current FPU control word (precision, exception masks) across + the LoadLibrary call (in case the DLL you're loading hammers the FPU control + word in its initialization, as many MS DLLs do)} + +function SafeLoadLibrary(const FileName: string; + ErrorMode: UINT = SEM_NOOPENFILEERRORBOX): HMODULE; + +{$ENDIF} + +{$IFDEF LINUX} +{ SafeLoadLibrary calls LoadLibrary preserves the current FPU control + word (precision, exception masks) across the LoadLibrary call (in + case the shared object you're loading hammers the FPU control + word in its initialization, as many MS DLLs do) } + +function SafeLoadLibrary(const FileName: string; + Dummy: LongWord = 0): HMODULE; +{$ENDIF} + +{ Thread synchronization } + +{ IReadWriteSync is an abstract interface for general read/write synchronization. + Some implementations may allow simultaneous readers, but writers always have + exclusive locks. + + Worst case is that this class behaves identical to a TRTLCriticalSection - + that is, read and write locks block all other threads. } + +type + IReadWriteSync = interface + ['{7B108C52-1D8F-4CDB-9CDF-57E071193D3F}'] + procedure BeginRead; + procedure EndRead; + function BeginWrite: Boolean; + procedure EndWrite; + end; + + TSimpleRWSync = class(TInterfacedObject, IReadWriteSync) + private + FLock: TRTLCriticalSection; + public + constructor Create; + destructor Destroy; override; + procedure BeginRead; + procedure EndRead; + function BeginWrite: Boolean; + procedure EndWrite; + end; + +{ TThreadLocalCounter + + This class implements a lightweight non-blocking thread local storage + mechanism specifically built for tracking per-thread recursion counts + in TMultiReadExclusiveWriteSynchronizer. This class is intended for + Delphi RTL internal use only. In the future it may be generalized + and "hardened" for general application use, but until then leave it alone. + + Rules of Use: + The tls object must be opened to gain access to the thread-specific data + structure. If a threadinfo block does not exist for the current thread, + Open will allocate one. Every call to Open must be matched with a call + to Close. The pointer returned by Open is invalid after the matching call + to Close (or Delete). + + The thread info structure is unique to each thread. Once you have it, it's + yours. You don't need to guard against concurrent access to the thread + data by multiple threads - your thread is the only thread that will ever + have access to the structure that Open returns. The thread info structure + is allocated and owned by the tls object. If you put allocated pointers + in the thread info make sure you free them before you delete the threadinfo + node. + + When thread data is no longer needed, call the Delete method on the pointer. + This must be done between calls to Open and Close. You should not use the + thread data after calling Delete. + + Important: Do not keep the tls object open for long periods of time. + In particular, be careful not to wait on a thread synchronization event or + critical section while you have the tls object open. It's much better to + open and close the tls object before and after the blocking event than to + leave the tls object open while waiting. + + Implementation Notes: + The main purpose of this storage class is to provide thread-local storage + without using limited / problematic OS tls slots and without requiring + expensive blocking thread synchronization. This class performs no + blocking waits or spin loops! (except for memory allocation) + + Thread info is kept in linked lists to facilitate non-blocking threading + techniques. A hash table indexed by a hash of the current thread ID + reduces linear search times. + + When a node is deleted, its thread ID is stripped and its Active field is + set to zero, meaning it is available to be recycled for other threads. + Nodes are never removed from the live list or freed while the class is in + use. All nodes are freed when the class is destroyed. + + Nodes are only inserted at the front of the list (each list in the hash table). + + The linked list management relies heavily on InterlockedExchange to perform + atomic node pointer replacements. There are brief windows of time where + the linked list may be circular while a two-step insertion takes place. + During that brief window, other threads traversing the lists may see + the same node more than once more than once. (pun!) This is fine for what this + implementation needs. Don't do anything silly like try to count the + nodes during a traversal. +} + +type + PThreadInfo = ^TThreadInfo; + TThreadInfo = record + Next: PThreadInfo; + ThreadID: Cardinal; + Active: Integer; + RecursionCount: Cardinal; + end; + + TThreadLocalCounter = class + private + FHashTable: array [0..15] of PThreadInfo; + function HashIndex: Byte; + function Recycle: PThreadInfo; + public + destructor Destroy; override; + procedure Open(var Thread: PThreadInfo); + procedure Delete(var Thread: PThreadInfo); + procedure Close(var Thread: PThreadInfo); + end; + +{$IFDEF MSWINDOWS} + +{ TMultiReadExclusiveWriteSynchronizer minimizes thread serialization to gain + read access to a resource shared among threads while still providing complete + exclusivity to callers needing write access to the shared resource. + (multithread shared reads, single thread exclusive write) + Read locks are allowed while owning a write lock. + Read locks can be promoted to write locks within the same thread. + (BeginRead, BeginWrite, EndWrite, EndRead) + + Note: Other threads have an opportunity to modify the protected resource + when you call BeginWrite before you are granted the write lock, even + if you already have a read lock open. Best policy is not to retain + any info about the protected resource (such as count or size) across a + write lock. Always reacquire samples of the protected resource after + acquiring or releasing a write lock. + + The function result of BeginWrite indicates whether another thread got + the write lock while the current thread was waiting for the write lock. + Return value of True means that the write lock was acquired without + any intervening modifications by other threads. Return value of False + means another thread got the write lock while you were waiting, so the + resource protected by the MREWS object should be considered modified. + Any samples of the protected resource should be discarded. + + In general, it's better to just always reacquire samples of the protected + resource after obtaining a write lock. The boolean result of BeginWrite + and the RevisionLevel property help cases where reacquiring the samples + is computationally expensive or time consuming. + + RevisionLevel changes each time a write lock is granted. You can test + RevisionLevel for equality with a previously sampled value of the property + to determine if a write lock has been granted, implying that the protected + resource may be changed from its state when the original RevisionLevel + value was sampled. Do not rely on the sequentiality of the current + RevisionLevel implementation (it will wrap around to zero when it tops out). + Do not perform greater than / less than comparisons on RevisionLevel values. + RevisionLevel indicates only the stability of the protected resource since + your original sample. It should not be used to calculate how many + revisions have been made. +} + +type + TMultiReadExclusiveWriteSynchronizer = class(TInterfacedObject, IReadWriteSync) + private + FSentinel: Integer; + FReadSignal: THandle; + FWriteSignal: THandle; + FWaitRecycle: Cardinal; + FWriteRecursionCount: Cardinal; + tls: TThreadLocalCounter; + FWriterID: Cardinal; + FRevisionLevel: Cardinal; + procedure BlockReaders; + procedure UnblockReaders; + procedure UnblockOneWriter; + procedure WaitForReadSignal; + procedure WaitForWriteSignal; +{$IFDEF DEBUG_MREWS} + procedure Debug(const Msg: string); +{$ENDIF} + public + constructor Create; + destructor Destroy; override; + procedure BeginRead; + procedure EndRead; + function BeginWrite: Boolean; + procedure EndWrite; + property RevisionLevel: Cardinal read FRevisionLevel; + end; +{$ELSE} +type + TMultiReadExclusiveWriteSynchronizer = TSimpleRWSync; +{$ENDIF} + +type + TMREWSync = TMultiReadExclusiveWriteSynchronizer; // short form + +function GetEnvironmentVariable(const Name: string): string; overload; + +{$IFDEF LINUX} +function InterlockedIncrement(var I: Integer): Integer; +function InterlockedDecrement(var I: Integer): Integer; +function InterlockedExchange(var A: Integer; B: Integer): Integer; +function InterlockedExchangeAdd(var A: Integer; B: Integer): Integer; +{$ENDIF} + +implementation + +{$IFDEF LINUX} +{ + Exceptions raised in methods that are safecall will be filtered + through the virtual method SafeCallException on the class. The + implementation of this method under Linux has the option of setting + the following thread vars: SafeCallExceptionMsg, SafeCallExceptionAddr. + If these are set, then the implementation of SafeCallError here will + reraise a generic exception based on these. One might consider actually + having the SafeCallException implementation store off the exception + object itself, but this raises the issue that the exception object + might have to live a long time (if an external application calls a + Delphi safecall method). Since an arbitrary exception object could + be holding large resources hostage, we hold only the string and + address as a hedge. +} +threadvar + SafeCallExceptionMsg: String; + SafeCallExceptionAddr: Pointer; + +procedure SetSafeCallExceptionMsg(const Msg: String); +begin + SafeCallExceptionMsg := Msg; +end; + +procedure SetSafeCallExceptionAddr(Addr: Pointer); +begin + SafeCallExceptionAddr := Addr; +end; + +function GetSafeCallExceptionMsg: String; +begin + Result := SafeCallExceptionMsg; +end; + +function GetSafeCallExceptionAddr: Pointer; +begin + Result := SafeCallExceptionAddr; +end; +{$ENDIF} + +{ Utility routines } + +procedure DivMod(Dividend: Integer; Divisor: Word; + var Result, Remainder: Word); +asm + PUSH EBX + MOV EBX,EDX + MOV EDX,EAX + SHR EDX,16 + DIV BX + MOV EBX,Remainder + MOV [ECX],AX + MOV [EBX],DX + POP EBX +end; + +{$IFDEF PIC} +function GetGOT: Pointer; export; +begin + asm + MOV Result,EBX + end; +end; +{$ENDIF} + +procedure ConvertError(const ResString: string); local; +begin + raise EConvertError.Create(ResString); +end; + +procedure ConvertErrorFmt(const ResString: string; const Args: array of const); local; +begin + raise EConvertError.CreateFmt(ResString, Args); +end; + +{$IFDEF MSWINDOWS} +{$EXTERNALSYM CoCreateGuid} +function CoCreateGuid(out guid: TGUID): HResult; stdcall; external 'ole32.dll' name 'CoCreateGuid'; + +function CreateGUID(out Guid: TGUID): HResult; +begin + Result := CoCreateGuid(Guid); +end; +//function CreateGUID; external 'ole32.dll' name 'CoCreateGuid'; +{$ENDIF} +{$IFDEF LINUX} + +{ CreateGUID } + +{ libuuid.so implements the tricky code to create GUIDs using the + MAC address of the network adapter plus other flavor bits. + libuuid.so is currently distributed with the ext2 file system + package, but does not depend upon the ext2 file system libraries. + Ideally, libuuid.so should be distributed separately. + + If you do not have libuuid.so.1 on your Linux distribution, you + can extract the library from the e2fsprogs RPM. + + Note: Do not use the generic uuid_generate function in libuuid.so. + In the current implementation (e2fsprogs-1.19), uuid_generate + gives preference to generating guids entirely from random number + streams over generating guids based on the NIC MAC address. + No matter how "random" a random number generator is, it will + never produce guids that can be guaranteed unique across all + systems on the planet. MAC-address based guids are guaranteed + unique because the MAC address of the NIC is guaranteed unique + by the manufacturer. + + For this reason, we call uuid_generate_time instead of the + generic uuid_generate. uuid_generate_time constructs the guid + using the MAC address, and falls back to randomness if no NIC + can be found. } + +var + libuuidHandle: Pointer; + uuid_generate_time: procedure (out Guid: TGUID) cdecl; + +function CreateGUID(out Guid: TGUID): HResult; + +const + E_NOTIMPL = HRESULT($80004001); + +begin + Result := E_NOTIMPL; + if libuuidHandle = nil then + begin + libuuidHandle := dlopen('libuuid.so.1', RTLD_LAZY); + if libuuidHandle = nil then Exit; + uuid_generate_time := dlsym(libuuidHandle, 'uuid_generate_time'); + if @uuid_generate_time = nil then Exit; + end; + uuid_generate_time(Guid); + Result := 0; +end; +{$ENDIF} + + +{$IFDEF MSWINDOWS} +function StringFromCLSID(const clsid: TGUID; out psz: PWideChar): HResult; stdcall; + external 'ole32.dll' name 'StringFromCLSID'; +procedure CoTaskMemFree(pv: Pointer); stdcall; + external 'ole32.dll' name 'CoTaskMemFree'; +function CLSIDFromString(psz: PWideChar; out clsid: TGUID): HResult; stdcall; + external 'ole32.dll' name 'CLSIDFromString'; +{$ENDIF MSWINDOWS} + +function StringToGUID(const S: string): TGUID; +{$IFDEF MSWINDOWS} +begin + if not Succeeded(CLSIDFromString(PWideChar(WideString(S)), Result)) then + ConvertErrorFmt(SInvalidGUID, [s]); +end; +{$ENDIF} +{$IFDEF LINUX} + + procedure InvalidGUID; + begin + ConvertErrorFmt(@SInvalidGUID, [s]); + end; + + function HexChar(c: Char): Byte; + begin + case c of + '0'..'9': Result := Byte(c) - Byte('0'); + 'a'..'f': Result := (Byte(c) - Byte('a')) + 10; + 'A'..'F': Result := (Byte(c) - Byte('A')) + 10; + else + InvalidGUID; + Result := 0; + end; + end; + + function HexByte(p: PChar): Char; + begin + Result := Char((HexChar(p[0]) shl 4) + HexChar(p[1])); + end; + +var + i: Integer; + src, dest: PChar; +begin + if ((Length(S) <> 38) or (s[1] <> '{')) then InvalidGUID; + dest := @Result; + src := PChar(s); + Inc(src); + for i := 0 to 3 do + dest[i] := HexByte(src+(3-i)*2); + Inc(src, 8); + Inc(dest, 4); + if src[0] <> '-' then InvalidGUID; + Inc(src); + for i := 0 to 1 do + begin + dest^ := HexByte(src+2); + Inc(dest); + dest^ := HexByte(src); + Inc(dest); + Inc(src, 4); + if src[0] <> '-' then InvalidGUID; + inc(src); + end; + dest^ := HexByte(src); + Inc(dest); + Inc(src, 2); + dest^ := HexByte(src); + Inc(dest); + Inc(src, 2); + if src[0] <> '-' then InvalidGUID; + Inc(src); + for i := 0 to 5 do + begin + dest^ := HexByte(src); + Inc(dest); + Inc(src, 2); + end; +end; +{$ENDIF LINUX} + +{$IFDEF MSWINDOWS} +function GUIDToString(const GUID: TGUID): string; +var + P: PWideChar; +begin + if not Succeeded(StringFromCLSID(GUID, P)) then + ConvertError(SInvalidGUID); + Result := P; + CoTaskMemFree(P); +end; +{$ENDIF} +{$IFDEF LINUX} +function GUIDToString(const GUID: TGUID): string; +begin + SetLength(Result, 38); + StrLFmt(PChar(Result), 38,'{%.8x-%.4x-%.4x-%.2x%.2x-%.2x%.2x%.2x%.2x%.2x%.2x}', // do not localize + [GUID.D1, GUID.D2, GUID.D3, GUID.D4[0], GUID.D4[1], GUID.D4[2], GUID.D4[3], + GUID.D4[4], GUID.D4[5], GUID.D4[6], GUID.D4[7]]); +end; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function IsEqualGUID; external 'ole32.dll' name 'IsEqualGUID'; +{$ENDIF MSWINDOWS} +{$IFDEF LINUX} +function IsEqualGUID(const guid1, guid2: TGUID): Boolean; +var + a, b: PIntegerArray; +begin + a := PIntegerArray(@guid1); + b := PIntegerArray(@guid2); + Result := (a^[0] = b^[0]) and (a^[1] = b^[1]) and (a^[2] = b^[2]) and (a^[3] = b^[3]); +end; +{$ENDIF LINUX} + + +{ Memory management routines } + +function AllocMem(Size: Cardinal): Pointer; +begin + GetMem(Result, Size); + FillChar(Result^, Size, 0); +end; + +{ Exit procedure handling } + +type + PExitProcInfo = ^TExitProcInfo; + TExitProcInfo = record + Next: PExitProcInfo; + SaveExit: Pointer; + Proc: TProcedure; + end; + +var + ExitProcList: PExitProcInfo = nil; + +procedure DoExitProc; +var + P: PExitProcInfo; + Proc: TProcedure; +begin + P := ExitProcList; + ExitProcList := P^.Next; + ExitProc := P^.SaveExit; + Proc := P^.Proc; + Dispose(P); + Proc; +end; + +procedure AddExitProc(Proc: TProcedure); +var + P: PExitProcInfo; +begin + New(P); + P^.Next := ExitProcList; + P^.SaveExit := ExitProc; + P^.Proc := Proc; + ExitProcList := P; + ExitProc := @DoExitProc; +end; + +{ String handling routines } + +function NewStr(const S: string): PString; +begin + if S = '' then Result := NullStr else + begin + New(Result); + Result^ := S; + end; +end; + +procedure DisposeStr(P: PString); +begin + if (P <> nil) and (P^ <> '') then Dispose(P); +end; + +procedure AssignStr(var P: PString; const S: string); +var + Temp: PString; +begin + Temp := P; + P := NewStr(S); + DisposeStr(Temp); +end; + +procedure AppendStr(var Dest: string; const S: string); +begin + Dest := Dest + S; +end; + +function UpperCase(const S: string): string; +var + Ch: Char; + L: Integer; + Source, Dest: PChar; +begin + L := Length(S); + SetLength(Result, L); + Source := Pointer(S); + Dest := Pointer(Result); + while L <> 0 do + begin + Ch := Source^; + if (Ch >= 'a') and (Ch <= 'z') then Dec(Ch, 32); + Dest^ := Ch; + Inc(Source); + Inc(Dest); + Dec(L); + end; +end; + +function UpperCase(const S: string; LocaleOptions: TLocaleOptions): string; +begin + if LocaleOptions = loUserLocale then + Result := AnsiUpperCase(S) + else + Result := UpperCase(S); +end; + +function LowerCase(const S: string): string; +var + Ch: Char; + L: Integer; + Source, Dest: PChar; +begin + L := Length(S); + SetLength(Result, L); + Source := Pointer(S); + Dest := Pointer(Result); + while L <> 0 do + begin + Ch := Source^; + if (Ch >= 'A') and (Ch <= 'Z') then Inc(Ch, 32); + Dest^ := Ch; + Inc(Source); + Inc(Dest); + Dec(L); + end; +end; + +function LowerCase(const S: string; LocaleOptions: TLocaleOptions): string; +begin + if LocaleOptions = loUserLocale then + Result := AnsiLowerCase(S) + else + Result := LowerCase(S); +end; + +function CompareStr(const S1, S2: string): Integer; assembler; +asm + PUSH ESI + PUSH EDI + MOV ESI,EAX + MOV EDI,EDX + OR EAX,EAX + JE @@1 + MOV EAX,[EAX-4] +@@1: OR EDX,EDX + JE @@2 + MOV EDX,[EDX-4] +@@2: MOV ECX,EAX + CMP ECX,EDX + JBE @@3 + MOV ECX,EDX +@@3: CMP ECX,ECX + REPE CMPSB + JE @@4 + MOVZX EAX,BYTE PTR [ESI-1] + MOVZX EDX,BYTE PTR [EDI-1] +@@4: SUB EAX,EDX + POP EDI + POP ESI +end; + +function CompareStr(const S1, S2: string; LocaleOptions: TLocaleOptions): Integer; +begin + if LocaleOptions = loUserLocale then + Result := AnsiCompareStr(S1, S2) + else + Result := CompareStr(S1, S2); +end; + +function SameStr(const S1, S2: string): Boolean; +asm + CMP EAX,EDX + JZ @1 + OR EAX,EAX + JZ @2 + OR EDX,EDX + JZ @3 + MOV ECX,[EAX-4] + CMP ECX,[EDX-4] + JNE @3 + CALL CompareStr + TEST EAX,EAX + JNZ @3 +@1: MOV AL,1 +@2: RET +@3: XOR EAX,EAX +end; + +function SameStr(const S1, S2: string; LocaleOptions: TLocaleOptions): Boolean; +begin + if LocaleOptions = loUserLocale then + Result := AnsiSameStr(S1, S2) + else + Result := SameStr(S1, S2); +end; + +function CompareMem(P1, P2: Pointer; Length: Integer): Boolean; assembler; +asm + PUSH ESI + PUSH EDI + MOV ESI,P1 + MOV EDI,P2 + MOV EDX,ECX + XOR EAX,EAX + AND EDX,3 + SAR ECX,2 + JS @@1 // Negative Length implies identity. + REPE CMPSD + JNE @@2 + MOV ECX,EDX + REPE CMPSB + JNE @@2 +@@1: INC EAX +@@2: POP EDI + POP ESI +end; + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The implementation of function CompareText is subject to the + * Mozilla Public License Version 1.1 (the "License"); you may + * not use this file except in compliance with the License. + * You may obtain a copy of the License at http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is Fastcode + * + * The Initial Developer of the Original Code is + * Fastcode + * + * Portions created by the Initial Developer are Copyright (C) 2002-2004 + * the Initial Developer. All Rights Reserved. + * + * Contributor(s): John O'Harrow + * + * ***** END LICENSE BLOCK ***** *) +function CompareText(const S1, S2: string): Integer; +asm + TEST EAX, EAX + JNZ @@CheckS2 + TEST EDX, EDX + JZ @@Ret + MOV EAX, [EDX-4] + NEG EAX +@@Ret: + RET +@@CheckS2: + TEST EDX, EDX + JNZ @@Compare + MOV EAX, [EAX-4] + RET +@@Compare: + PUSH EBX + PUSH EBP + PUSH ESI + MOV EBP, [EAX-4] // length(S1) + MOV EBX, [EDX-4] // length(S2) + SUB EBP, EBX // Result if All Compared Characters Match + SBB ECX, ECX + AND ECX, EBP + ADD ECX, EBX // min(length(S1),length(S2)) = Compare Length + LEA ESI, [EAX+ECX] // Last Compare Position in S1 + ADD EDX, ECX // Last Compare Position in S2 + NEG ECX + JZ @@SetResult // Exit if Smallest Length = 0 +@@Loop: // Load Next 2 Chars from S1 and S2 + // May Include Null Terminator} + MOVZX EAX, WORD PTR [ESI+ECX] + MOVZX EBX, WORD PTR [EDX+ECX] + CMP EAX, EBX + JE @@Next // Next 2 Chars Match + CMP AL, BL + JE @@SecondPair // First Char Matches + MOV AH, 0 + MOV BH, 0 + CMP AL, 'a' + JL @@UC1 + CMP AL, 'z' + JG @@UC1 + SUB EAX, 'a'-'A' +@@UC1: + CMP BL, 'a' + JL @@UC2 + CMP BL, 'z' + JG @@UC2 + SUB EBX, 'a'-'A' +@@UC2: + SUB EAX, EBX // Compare Both Uppercase Chars + JNE @@Done // Exit with Result in EAX if Not Equal + MOVZX EAX, WORD PTR [ESI+ECX] // Reload Same 2 Chars from S1 + MOVZX EBX, WORD PTR [EDX+ECX] // Reload Same 2 Chars from S2 + CMP AH, BH + JE @@Next // Second Char Matches +@@SecondPair: + SHR EAX, 8 + SHR EBX, 8 + CMP AL, 'a' + JL @@UC3 + CMP AL, 'z' + JG @@UC3 + SUB EAX, 'a'-'A' +@@UC3: + CMP BL, 'a' + JL @@UC4 + CMP BL, 'z' + JG @@UC4 + SUB EBX, 'a'-'A' +@@UC4: + SUB EAX, EBX // Compare Both Uppercase Chars + JNE @@Done // Exit with Result in EAX if Not Equal +@@Next: + ADD ECX, 2 + JL @@Loop // Loop until All required Chars Compared +@@SetResult: + MOV EAX, EBP // All Matched, Set Result from Lengths +@@Done: + POP ESI + POP EBP + POP EBX +end; + +function CompareText(const S1, S2: string; LocaleOptions: TLocaleOptions): Integer; +begin + if LocaleOptions = loUserLocale then + Result := AnsiCompareText(S1, S2) + else + Result := CompareText(S1, S2); +end; + +function SameText(const S1, S2: string): Boolean; assembler; +asm + CMP EAX,EDX + JZ @1 + OR EAX,EAX + JZ @2 + OR EDX,EDX + JZ @3 + MOV ECX,[EAX-4] + CMP ECX,[EDX-4] + JNE @3 + CALL CompareText + TEST EAX,EAX + JNZ @3 +@1: MOV AL,1 +@2: RET +@3: XOR EAX,EAX +end; + +function SameText(const S1, S2: string; LocaleOptions: TLocaleOptions): Boolean; +begin + if LocaleOptions = loUserLocale then + Result := AnsiSameText(S1, S2) + else + Result := SameText(S1, S2); +end; + +function AnsiUpperCase(const S: string): string; +{$IFDEF MSWINDOWS} +var + Len: Integer; +begin + Len := Length(S); + SetString(Result, PChar(S), Len); + if Len > 0 then CharUpperBuff(Pointer(Result), Len); +end; +{$ENDIF} +{$IFDEF LINUX} +begin + Result := WideUpperCase(S); +end; +{$ENDIF} + +function AnsiLowerCase(const S: string): string; +{$IFDEF MSWINDOWS} +var + Len: Integer; +begin + Len := Length(S); + SetString(Result, PChar(S), Len); + if Len > 0 then CharLowerBuff(Pointer(Result), Len); +end; +{$ENDIF} +{$IFDEF LINUX} +begin + Result := WideLowerCase(S); +end; +{$ENDIF} + +function AnsiCompareStr(const S1, S2: string): Integer; +begin +{$IFDEF MSWINDOWS} + Result := CompareString(LOCALE_USER_DEFAULT, 0, PChar(S1), Length(S1), + PChar(S2), Length(S2)) - 2; +{$ENDIF} +{$IFDEF LINUX} + // glibc 2.1.2 / 2.1.3 implementations of strcoll() and strxfrm() + // have severe capacity limits. Comparing two 100k strings may + // exhaust the stack and kill the process. + // Fixed in glibc 2.1.91 and later. + Result := strcoll(PChar(S1), PChar(S2)); +{$ENDIF} +end; + +function AnsiSameStr(const S1, S2: string): Boolean; +begin + Result := AnsiCompareStr(S1, S2) = 0; +end; + +function AnsiCompareText(const S1, S2: string): Integer; +begin +{$IFDEF MSWINDOWS} + Result := CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE, PChar(S1), + Length(S1), PChar(S2), Length(S2)) - 2; +{$ENDIF} +{$IFDEF LINUX} + Result := WideCompareText(S1, S2); +{$ENDIF} +end; + +function AnsiSameText(const S1, S2: string): Boolean; +begin + Result := AnsiCompareText(S1, S2) = 0; +end; + +function AnsiStrComp(S1, S2: PChar): Integer; +begin +{$IFDEF MSWINDOWS} + Result := CompareString(LOCALE_USER_DEFAULT, 0, S1, -1, S2, -1) - 2; +{$ENDIF} +{$IFDEF LINUX} + Result := strcoll(S1, S2); +{$ENDIF} +end; + +function AnsiStrIComp(S1, S2: PChar): Integer; +begin +{$IFDEF MSWINDOWS} + Result := CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE, S1, -1, + S2, -1) - 2; +{$ENDIF} +{$IFDEF LINUX} + Result := AnsiCompareText(S1, S2); +{$ENDIF} +end; + +// StrLenLimit: Scan Src for a null terminator up to MaxLen bytes +function StrLenLimit(Src: PChar; MaxLen: Cardinal): Cardinal; +begin + if Src = nil then + begin + Result := 0; + Exit; + end; + Result := MaxLen; + while (Src^ <> #0) and (Result > 0) do + begin + Inc(Src); + Dec(Result); + end; + Result := MaxLen - Result; +end; + +{ StrBufLimit: Return a pointer to a buffer that contains no more than MaxLen + bytes of Src, avoiding heap allocation if possible. + If clipped Src length is less than MaxLen, return Src. Allocated = False. + If clipped Src length is less than StaticBufLen, return StaticBuf with a + copy of Src. Allocated = False. + Otherwise, return a heap allocated buffer with a copy of Src. Allocated = True. +} +function StrBufLimit(Src: PChar; MaxLen: Cardinal; StaticBuf: PChar; + StaticBufLen: Cardinal; var Allocated: Boolean): PChar; +var + Len: Cardinal; +begin + Len := StrLenLimit(Src, MaxLen); + Allocated := False; + if Len < MaxLen then + Result := Src + else + begin + if Len < StaticBufLen then + Result := StaticBuf + else + begin + GetMem(Result, Len+1); + Allocated := True; + end; + Move(Src^, Result^, Len); + Result[Len] := #0; + end; +end; + +function InternalAnsiStrLComp(S1, S2: PChar; MaxLen: Cardinal; CaseSensitive: Boolean): Integer; +var + Buf1, Buf2: array [0..4095] of Char; + P1, P2: PChar; + Allocated1, Allocated2: Boolean; +begin + // glibc has no length-limited strcoll! + P1 := nil; + P2 := nil; + Allocated1 := False; + Allocated2 := False; + try + P1 := StrBufLimit(S1, MaxLen, Buf1, High(Buf1), Allocated1); + P2 := StrBufLimit(S2, MaxLen, Buf2, High(Buf2), Allocated2); + if CaseSensitive then + Result := AnsiStrComp(P1, P2) + else + Result := AnsiStrIComp(P1, P2); + finally + if Allocated1 then + FreeMem(P1); + if Allocated2 then + FreeMem(P2); + end; +end; + +function AnsiStrLComp(S1, S2: PChar; MaxLen: Cardinal): Integer; +{$IFDEF MSWINDOWS} +begin + Result := CompareString(LOCALE_USER_DEFAULT, 0, + S1, MaxLen, S2, MaxLen) - 2; +end; +{$ENDIF} +{$IFDEF LINUX} +begin + Result := InternalAnsiStrLComp(S1, S2, MaxLen, True); +end; +{$ENDIF} + +function AnsiStrLIComp(S1, S2: PChar; MaxLen: Cardinal): Integer; +begin +{$IFDEF MSWINDOWS} + Result := CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE, + S1, MaxLen, S2, MaxLen) - 2; +{$ENDIF} +{$IFDEF LINUX} + Result := InternalAnsiStrLComp(S1, S2, MaxLen, False); +{$ENDIF} +end; + +function AnsiStrLower(Str: PChar): PChar; +{$IFDEF MSWINDOWS} +begin + CharLower(Str); + Result := Str; +end; +{$ENDIF} +{$IFDEF LINUX} +var + Temp: WideString; + Squish: AnsiString; + I: Integer; +begin + Temp := Str; // expand and copy multibyte to widechar + for I := 1 to Length(Temp) do + Temp[I] := WideChar(towlower(UCS4Char(Temp[I]))); + Squish := Temp; // reduce and copy widechar to multibyte + + if Cardinal(Length(Squish)) > StrLen(Str) then + raise ERangeError.CreateRes(@SRangeError); + + Move(Squish[1], Str^, Length(Squish)); + Result := Str; +end; +{$ENDIF} + +function AnsiStrUpper(Str: PChar): PChar; +{$IFDEF MSWINDOWS} +begin + CharUpper(Str); + Result := Str; +end; +{$ENDIF} +{$IFDEF LINUX} +var + Temp: WideString; + Squish: AnsiString; + I: Integer; +begin + Temp := Str; // expand and copy multibyte to widechar + for I := 1 to Length(Temp) do + Temp[I] := WideChar(towupper(UCS4Char(Temp[I]))); + Squish := Temp; // reduce and copy widechar to multibyte + if Cardinal(Length(Squish)) > StrLen(Str) then + raise ERangeError.CreateRes(@SRangeError); + + Move(Squish[1], Str^, Length(Squish)); + Result := Str; +end; +{$ENDIF} + +function WideUpperCase(const S: WideString): WideString; +{$IFDEF MSWINDOWS} +var + Len: Integer; +begin + Len := Length(S); + SetString(Result, PWideChar(S), Len); + if Len > 0 then CharUpperBuffW(Pointer(Result), Len); +end; +{$ENDIF} +{$IFDEF LINUX} +var + I: Integer; + P: PWideChar; +begin + SetLength(Result, Length(S)); + P := @Result[1]; + for I := 1 to Length(S) do + P[I-1] := WideChar(towupper(UCS4Char(S[I]))); +end; +{$ENDIF} + +function WideLowerCase(const S: WideString): WideString; +{$IFDEF MSWINDOWS} +var + Len: Integer; +begin + Len := Length(S); + SetString(Result, PWideChar(S), Len); + if Len > 0 then CharLowerBuffW(Pointer(Result), Len); +end; +{$ENDIF} +{$IFDEF LINUX} +var + I: Integer; + P: PWideChar; +begin + SetLength(Result, Length(S)); + P := @Result[1]; + for I := 1 to Length(S) do + P[I-1] := WideChar(towlower(UCS4Char(S[I]))); +end; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function DumbItDownFor95(const S1, S2: WideString; CmpFlags: Integer): Integer; +var + a1, a2: AnsiString; +begin + a1 := s1; + a2 := s2; + Result := CompareStringA(LOCALE_USER_DEFAULT, CmpFlags, PChar(a1), Length(a1), + PChar(a2), Length(a2)) - 2; +end; +{$ENDIF} + +function WideCompareStr(const S1, S2: WideString): Integer; +{$IFDEF MSWINDOWS} +begin + SetLastError(0); + Result := CompareStringW(LOCALE_USER_DEFAULT, 0, PWideChar(S1), Length(S1), + PWideChar(S2), Length(S2)) - 2; + case GetLastError of + 0: ; + ERROR_CALL_NOT_IMPLEMENTED: Result := DumbItDownFor95(S1, S2, 0); + else + RaiseLastOSError; + end; +end; +{$ENDIF} +{$IFDEF LINUX} +var + UCS4_S1, UCS4_S2: UCS4String; +begin + UCS4_S1 := WideStringToUCS4String(S1); + UCS4_S2 := WideStringToUCS4String(S2); + // glibc 2.1.2 / 2.1.3 implementations of wcscoll() and wcsxfrm() + // have severe capacity limits. Comparing two 100k strings may + // exhaust the stack and kill the process. + // Fixed in glibc 2.1.91 and later. + SetLastError(0); + Result := wcscoll(PUCS4Chars(UCS4_S1), PUCS4Chars(UCS4_S2)); + if GetLastError <> 0 then + RaiseLastOSError; +end; +{$ENDIF} + +function WideSameStr(const S1, S2: WideString): Boolean; +begin + Result := WideCompareStr(S1, S2) = 0; +end; + +function WideCompareText(const S1, S2: WideString): Integer; +begin +{$IFDEF MSWINDOWS} + SetLastError(0); + Result := CompareStringW(LOCALE_USER_DEFAULT, NORM_IGNORECASE, PWideChar(S1), + Length(S1), PWideChar(S2), Length(S2)) - 2; + case GetLastError of + 0: ; + ERROR_CALL_NOT_IMPLEMENTED: Result := DumbItDownFor95(S1, S2, NORM_IGNORECASE); + else + RaiseLastOSError; + end; +{$ENDIF} +{$IFDEF LINUX} + Result := WideCompareStr(WideUpperCase(S1), WideUpperCase(S2)); +{$ENDIF} +end; + +function WideSameText(const S1, S2: WideString): Boolean; +begin + Result := WideCompareText(S1, S2) = 0; +end; + +function Trim(const S: string): string; +var + I, L: Integer; +begin + L := Length(S); + I := 1; + while (I <= L) and (S[I] <= ' ') do Inc(I); + if I > L then Result := '' else + begin + while S[L] <= ' ' do Dec(L); + Result := Copy(S, I, L - I + 1); + end; +end; + +function Trim(const S: WideString): WideString; +var + I, L: Integer; +begin + L := Length(S); + I := 1; + while (I <= L) and (S[I] <= ' ') do Inc(I); + if I > L then + Result := '' + else + begin + while S[L] <= ' ' do Dec(L); + Result := Copy(S, I, L - I + 1); + end; +end; + +function TrimLeft(const S: string): string; +var + I, L: Integer; +begin + L := Length(S); + I := 1; + while (I <= L) and (S[I] <= ' ') do Inc(I); + Result := Copy(S, I, Maxint); +end; + +function TrimLeft(const S: WideString): WideString; +var + I, L: Integer; +begin + L := Length(S); + I := 1; + while (I <= L) and (S[I] <= ' ') do Inc(I); + Result := Copy(S, I, Maxint); +end; + +function TrimRight(const S: string): string; +var + I: Integer; +begin + I := Length(S); + while (I > 0) and (S[I] <= ' ') do Dec(I); + Result := Copy(S, 1, I); +end; + +function TrimRight(const S: WideString): WideString; +var + I: Integer; +begin + I := Length(S); + while (I > 0) and (S[I] <= ' ') do Dec(I); + Result := Copy(S, 1, I); +end; + +function QuotedStr(const S: string): string; +var + I: Integer; +begin + Result := S; + for I := Length(Result) downto 1 do + if Result[I] = '''' then Insert('''', Result, I); + Result := '''' + Result + ''''; +end; + +function AnsiQuotedStr(const S: string; Quote: Char): string; +var + P, Src, Dest: PChar; + AddCount: Integer; +begin + AddCount := 0; + P := AnsiStrScan(PChar(S), Quote); + while P <> nil do + begin + Inc(P); + Inc(AddCount); + P := AnsiStrScan(P, Quote); + end; + if AddCount = 0 then + begin + Result := Quote + S + Quote; + Exit; + end; + SetLength(Result, Length(S) + AddCount + 2); + Dest := Pointer(Result); + Dest^ := Quote; + Inc(Dest); + Src := Pointer(S); + P := AnsiStrScan(Src, Quote); + repeat + Inc(P); + Move(Src^, Dest^, P - Src); + Inc(Dest, P - Src); + Dest^ := Quote; + Inc(Dest); + Src := P; + P := AnsiStrScan(Src, Quote); + until P = nil; + P := StrEnd(Src); + Move(Src^, Dest^, P - Src); + Inc(Dest, P - Src); + Dest^ := Quote; +end; + +function AnsiExtractQuotedStr(var Src: PChar; Quote: Char): string; +var + P, Dest: PChar; + DropCount: Integer; +begin + Result := ''; + if (Src = nil) or (Src^ <> Quote) then Exit; + Inc(Src); + DropCount := 1; + P := Src; + Src := AnsiStrScan(Src, Quote); + while Src <> nil do // count adjacent pairs of quote chars + begin + Inc(Src); + if Src^ <> Quote then Break; + Inc(Src); + Inc(DropCount); + Src := AnsiStrScan(Src, Quote); + end; + if Src = nil then Src := StrEnd(P); + if ((Src - P) <= 1) then Exit; + if DropCount = 1 then + SetString(Result, P, Src - P - 1) + else + begin + SetLength(Result, Src - P - DropCount); + Dest := PChar(Result); + Src := AnsiStrScan(P, Quote); + while Src <> nil do + begin + Inc(Src); + if Src^ <> Quote then Break; + Move(P^, Dest^, Src - P); + Inc(Dest, Src - P); + Inc(Src); + P := Src; + Src := AnsiStrScan(Src, Quote); + end; + if Src = nil then Src := StrEnd(P); + Move(P^, Dest^, Src - P - 1); + end; +end; + +function AnsiDequotedStr(const S: string; AQuote: Char): string; +var + LText: PChar; +begin + LText := PChar(S); + Result := AnsiExtractQuotedStr(LText, AQuote); + if Result = '' then + Result := S; +end; + +function AdjustLineBreaks(const S: string; Style: TTextLineBreakStyle): string; +var + Source, SourceEnd, Dest: PChar; + DestLen: Integer; + L: Integer; +begin + Source := Pointer(S); + SourceEnd := Source + Length(S); + DestLen := Length(S); + while Source < SourceEnd do + begin + case Source^ of + #10: + if Style = tlbsCRLF then + Inc(DestLen); + #13: + if Style = tlbsCRLF then + if Source[1] = #10 then + Inc(Source) + else + Inc(DestLen) + else + if Source[1] = #10 then + Dec(DestLen); + else + if Source^ in LeadBytes then + begin + Source := StrNextChar(Source); + continue; + end; + end; + Inc(Source); + end; + if DestLen = Length(Source) then + Result := S + else + begin + Source := Pointer(S); + SetString(Result, nil, DestLen); + Dest := Pointer(Result); + while Source < SourceEnd do + case Source^ of + #10: + begin + if Style = tlbsCRLF then + begin + Dest^ := #13; + Inc(Dest); + end; + Dest^ := #10; + Inc(Dest); + Inc(Source); + end; + #13: + begin + if Style = tlbsCRLF then + begin + Dest^ := #13; + Inc(Dest); + end; + Dest^ := #10; + Inc(Dest); + Inc(Source); + if Source^ = #10 then Inc(Source); + end; + else + if Source^ in LeadBytes then + begin + L := StrCharLength(Source); + Move(Source^, Dest^, L); + Inc(Dest, L); + Inc(Source, L); + continue; + end; + Dest^ := Source^; + Inc(Dest); + Inc(Source); + end; + end; +end; + +function IsValidIdent(const Ident: string; AllowDots: Boolean): Boolean; +const + Alpha = ['A'..'Z', 'a'..'z', '_']; + AlphaNumeric = Alpha + ['0'..'9']; + AlphaNumericDot = AlphaNumeric + ['.']; + +var + I: Integer; +begin + Result := False; + if (Length(Ident) = 0) or not (Ident[1] in Alpha) then Exit; + if AllowDots then + for I := 2 to Length(Ident) do + begin + if not (Ident[I] in AlphaNumericDot) then Exit + end + else + for I := 2 to Length(Ident) do if not (Ident[I] in AlphaNumeric) then Exit; + Result := True; +end; + +procedure CvtInt; +{ IN: + EAX: The integer value to be converted to text + ESI: Ptr to the right-hand side of the output buffer: LEA ESI, StrBuf[16] + ECX: Base for conversion: 0 for signed decimal, 10 or 16 for unsigned + EDX: Precision: zero padded minimum field width + OUT: + ESI: Ptr to start of converted text (not start of buffer) + ECX: Length of converted text +} +asm + OR CL,CL + JNZ @CvtLoop +@C1: OR EAX,EAX + JNS @C2 + NEG EAX + CALL @C2 + MOV AL,'-' + INC ECX + DEC ESI + MOV [ESI],AL + RET +@C2: MOV ECX,10 + +@CvtLoop: + PUSH EDX + PUSH ESI +@D1: XOR EDX,EDX + DIV ECX + DEC ESI + ADD DL,'0' + CMP DL,'0'+10 + JB @D2 + ADD DL,('A'-'0')-10 +@D2: MOV [ESI],DL + OR EAX,EAX + JNE @D1 + POP ECX + POP EDX + SUB ECX,ESI + SUB EDX,ECX + JBE @D5 + ADD ECX,EDX + MOV AL,'0' + SUB ESI,EDX + JMP @z +@zloop: MOV [ESI+EDX],AL +@z: DEC EDX + JNZ @zloop + MOV [ESI],AL +@D5: +end; + +procedure CvtIntW; +{ IN: + EAX: The integer value to be converted to text + ESI: Ptr to the right-hand side of the widechar output buffer: LEA ESI, WStrBuf[32] + ECX: Base for conversion: 0 for signed decimal, 10 or 16 for unsigned + EDX: Precision: zero padded minimum field width + OUT: + ESI: Ptr to start of converted widechar text (not start of buffer) + ECX: Character length of converted text +} +asm + OR CL,CL + JNZ @CvtLoop +@C1: OR EAX,EAX + JNS @C2 + NEG EAX + CALL @C2 + MOV AX,'-' + MOV [ESI-2],AX + SUB ESI, 2 + INC ECX + RET +@C2: MOV ECX,10 + +@CvtLoop: + PUSH EDX + PUSH ESI +@D1: XOR EDX,EDX + DIV ECX + ADD DX,'0' + SUB ESI,2 + CMP DX,'0'+10 + JB @D2 + ADD DX,('A'-'0')-10 +@D2: MOV [ESI],DX + OR EAX,EAX + JNE @D1 + POP ECX + POP EDX + SUB ECX,ESI + SHR ECX, 1 + SUB EDX,ECX + JBE @D5 + ADD ECX,EDX + SUB ESI,EDX + MOV AX,'0' + SUB ESI,EDX + JMP @z +@zloop: MOV [ESI+EDX*2],AX +@z: DEC EDX + JNZ @zloop + MOV [ESI],AX +@D5: +end; + +function IntToStr(Value: Integer): string; +// FmtStr(Result, '%d', [Value]); +asm + PUSH ESI + MOV ESI, ESP + SUB ESP, 16 + XOR ECX, ECX // base: 0 for signed decimal + PUSH EDX // result ptr + XOR EDX, EDX // zero filled field width: 0 for no leading zeros + CALL CvtInt + MOV EDX, ESI + POP EAX // result ptr + CALL System.@LStrFromPCharLen + ADD ESP, 16 + POP ESI +end; + +procedure CvtInt64W; +{ IN: + EAX: Address of the int64 value to be converted to text + ESI: Ptr to the right-hand side of the widechar output buffer: LEA ESI, WStrBuf[32] + ECX: Base for conversion: 10 or 16 + EDX: Precision: zero padded minimum field width + OUT: + ESI: Ptr to start of converted widechar text (not start of buffer) + ECX: Character length of converted text +} +asm + OR CL, CL + JNZ @start + MOV ECX, 10 + TEST [EAX + 4], $80000000 + JZ @start + PUSH [EAX + 4] + PUSH [EAX] + MOV EAX, ESP + NEG [ESP] // negate the value + ADC [ESP + 4],0 + NEG [ESP + 4] + CALL @start + INC ECX + MOV [ESI-2].Word, '-' + SUB ESI, 2 + ADD ESP, 8 + JMP @done + +@start: + PUSH ESI + SUB ESP, 4 + FNSTCW [ESP+2].Word // save + FNSTCW [ESP].Word // scratch + OR [ESP].Word, $0F00 // trunc toward zero, full precision + FLDCW [ESP].Word + + MOV [ESP].Word, CX + FLD1 + TEST [EAX + 4], $80000000 // test for negative + JZ @ld1 // FPU doesn't understand unsigned ints + PUSH [EAX + 4] // copy value before modifying + PUSH [EAX] + AND [ESP + 4], $7FFFFFFF // clear the sign bit + PUSH $7FFFFFFF + PUSH $FFFFFFFF + FILD [ESP + 8].QWord // load value + FILD [ESP].QWord + FADD ST(0), ST(2) // Add 1. Produces unsigned $80000000 in ST(0) + FADDP ST(1), ST(0) // Add $80000000 to value to replace the sign bit + ADD ESP, 16 + JMP @ld2 +@ld1: + FILD [EAX].QWord // value +@ld2: + FILD [ESP].Word // base + FLD ST(1) +@loop: + SUB ESI, 2 + FPREM // accumulator mod base + FISTP [ESI].Word + FDIV ST(1), ST(0) // accumulator := acumulator / base + MOV AX, [ESI].Word // overlap long division op with int ops + ADD AX, '0' + CMP AX, '0'+10 + JB @store + ADD AX, ('A'-'0')-10 +@store: + MOV [ESI].Word, AX + FLD ST(1) // copy accumulator + FCOM ST(3) // if accumulator >= 1.0 then loop + FSTSW AX + SAHF + JAE @loop + + FLDCW [ESP+2].Word + ADD ESP,4 + + FFREE ST(3) + FFREE ST(2) + FFREE ST(1); + FFREE ST(0); + +@zeropad: + POP ECX // original ESI + SUB ECX,ESI + SHR ECX, 1 // ECX = char length of converted string + OR EDX,EDX + JS @done + SUB EDX,ECX + JBE @done // output longer than field width = no pad + SUB ESI,EDX + MOV AX,'0' + SUB ESI,EDX + ADD ECX,EDX + JMP @z +@zloop: MOV [ESI+EDX*2].Word,AX +@z: DEC EDX + JNZ @zloop + MOV [ESI].Word,AX +@done: +end; + +procedure CvtInt64; +{ IN: + EAX: Address of the int64 value to be converted to text + ESI: Ptr to the right-hand side of the output buffer: LEA ESI, StrBuf[32] + ECX: Base for conversion: 0 for signed decimal, or 10 or 16 for unsigned + EDX: Precision: zero padded minimum field width + OUT: + ESI: Ptr to start of converted text (not start of buffer) + ECX: Byte length of converted text +} +asm + OR CL, CL + JNZ @start // CL = 0 => signed integer conversion + MOV ECX, 10 + TEST [EAX + 4], $80000000 + JZ @start + PUSH [EAX + 4] + PUSH [EAX] + MOV EAX, ESP + NEG [ESP] // negate the value + ADC [ESP + 4],0 + NEG [ESP + 4] + CALL @start // perform unsigned conversion + MOV [ESI-1].Byte, '-' // tack on the negative sign + DEC ESI + INC ECX + ADD ESP, 8 + RET + +@start: // perform unsigned conversion + PUSH ESI + SUB ESP, 4 + FNSTCW [ESP+2].Word // save + FNSTCW [ESP].Word // scratch + OR [ESP].Word, $0F00 // trunc toward zero, full precision + FLDCW [ESP].Word + + MOV [ESP].Word, CX + FLD1 + TEST [EAX + 4], $80000000 // test for negative + JZ @ld1 // FPU doesn't understand unsigned ints + PUSH [EAX + 4] // copy value before modifying + PUSH [EAX] + AND [ESP + 4], $7FFFFFFF // clear the sign bit + PUSH $7FFFFFFF + PUSH $FFFFFFFF + FILD [ESP + 8].QWord // load value + FILD [ESP].QWord + FADD ST(0), ST(2) // Add 1. Produces unsigned $80000000 in ST(0) + FADDP ST(1), ST(0) // Add $80000000 to value to replace the sign bit + ADD ESP, 16 + JMP @ld2 +@ld1: + FILD [EAX].QWord // value +@ld2: + FILD [ESP].Word // base + FLD ST(1) +@loop: + DEC ESI + FPREM // accumulator mod base + FISTP [ESP].Word + FDIV ST(1), ST(0) // accumulator := acumulator / base + MOV AL, [ESP].Byte // overlap long FPU division op with int ops + ADD AL, '0' + CMP AL, '0'+10 + JB @store + ADD AL, ('A'-'0')-10 +@store: + MOV [ESI].Byte, AL + FLD ST(1) // copy accumulator + FCOM ST(3) // if accumulator >= 1.0 then loop + FSTSW AX + SAHF + JAE @loop + + FLDCW [ESP+2].Word + ADD ESP,4 + + FFREE ST(3) + FFREE ST(2) + FFREE ST(1); + FFREE ST(0); + + POP ECX // original ESI + SUB ECX, ESI // ECX = length of converted string + SUB EDX,ECX + JBE @done // output longer than field width = no pad + SUB ESI,EDX + MOV AL,'0' + ADD ECX,EDX + JMP @z +@zloop: MOV [ESI+EDX].Byte,AL +@z: DEC EDX + JNZ @zloop + MOV [ESI].Byte,AL +@done: +end; + +function IntToStr(Value: Int64): string; +// FmtStr(Result, '%d', [Value]); +asm + PUSH ESI + MOV ESI, ESP + SUB ESP, 32 // 32 chars + XOR ECX, ECX // base 10 signed + PUSH EAX // result ptr + XOR EDX, EDX // zero filled field width: 0 for no leading zeros + LEA EAX, Value; + CALL CvtInt64 + + MOV EDX, ESI + POP EAX // result ptr + CALL System.@LStrFromPCharLen + ADD ESP, 32 + POP ESI +end; + +function IntToHex(Value: Integer; Digits: Integer): string; +// FmtStr(Result, '%.*x', [Digits, Value]); +asm + CMP EDX, 32 // Digits < buffer length? + JBE @A1 + XOR EDX, EDX +@A1: PUSH ESI + MOV ESI, ESP + SUB ESP, 32 + PUSH ECX // result ptr + MOV ECX, 16 // base 16 EDX = Digits = field width + CALL CvtInt + MOV EDX, ESI + POP EAX // result ptr + CALL System.@LStrFromPCharLen + ADD ESP, 32 + POP ESI +end; + +function IntToHex(Value: Int64; Digits: Integer): string; +// FmtStr(Result, '%.*x', [Digits, Value]); +asm + CMP EAX, 32 // Digits < buffer length? + JLE @A1 + XOR EAX, EAX +@A1: PUSH ESI + MOV ESI, ESP + SUB ESP, 32 // 32 chars + MOV ECX, 16 // base 16 + PUSH EDX // result ptr + MOV EDX, EAX // zero filled field width: 0 for no leading zeros + LEA EAX, Value; + CALL CvtInt64 + + MOV EDX, ESI + POP EAX // result ptr + CALL System.@LStrFromPCharLen + ADD ESP, 32 + POP ESI +end; + +function StrToInt(const S: string): Integer; +var + E: Integer; +begin + Val(S, Result, E); + if E <> 0 then ConvertErrorFmt(SInvalidInteger, [S]); +end; + +function StrToIntDef(const S: string; Default: Integer): Integer; +var + E: Integer; +begin + Val(S, Result, E); + if E <> 0 then Result := Default; +end; + +function TryStrToInt(const S: string; out Value: Integer): Boolean; +var + E: Integer; +begin + Val(S, Value, E); + Result := E = 0; +end; + +function StrToInt64(const S: string): Int64; +var + E: Integer; +begin + Val(S, Result, E); + if E <> 0 then ConvertErrorFmt(SInvalidInteger, [S]); +end; + +function StrToInt64Def(const S: string; const Default: Int64): Int64; +var + E: Integer; +begin + Val(S, Result, E); + if E <> 0 then Result := Default; +end; + +function TryStrToInt64(const S: string; out Value: Int64): Boolean; +var + E: Integer; +begin + Val(S, Value, E); + Result := E = 0; +end; + +procedure VerifyBoolStrArray; +begin + if Length(TrueBoolStrs) = 0 then + begin + SetLength(TrueBoolStrs, 1); + TrueBoolStrs[0] := DefaultTrueBoolStr; + end; + if Length(FalseBoolStrs) = 0 then + begin + SetLength(FalseBoolStrs, 1); + FalseBoolStrs[0] := DefaultFalseBoolStr; + end; +end; + +function StrToBool(const S: string): Boolean; +begin + if not TryStrToBool(S, Result) then + ConvertErrorFmt(SInvalidBoolean, [S]); +end; + +function StrToBoolDef(const S: string; const Default: Boolean): Boolean; +begin + if not TryStrToBool(S, Result) then + Result := Default; +end; + +function TryStrToBool(const S: string; out Value: Boolean): Boolean; + function CompareWith(const aArray: array of string): Boolean; + var + I: Integer; + begin + Result := False; + for I := Low(aArray) to High(aArray) do + if AnsiSameText(S, aArray[I]) then + begin + Result := True; + Break; + end; + end; +var + LResult: Extended; +begin + Result := TryStrToFloat(S, LResult); + if Result then + Value := LResult <> 0 + else + begin + VerifyBoolStrArray; + Result := CompareWith(TrueBoolStrs); + if Result then + Value := True + else + begin + Result := CompareWith(FalseBoolStrs); + if Result then + Value := False; + end; + end; +end; + +function BoolToStr(B: Boolean; UseBoolStrs: Boolean = False): string; +const + cSimpleBoolStrs: array [boolean] of String = ('0', '-1'); +begin + if UseBoolStrs then + begin + VerifyBoolStrArray; + if B then + Result := TrueBoolStrs[0] + else + Result := FalseBoolStrs[0]; + end + else + Result := cSimpleBoolStrs[B]; +end; + +type + PStrData = ^TStrData; + TStrData = record + Ident: Integer; + Str: string; + end; + +function EnumStringModules(Instance: Longint; Data: Pointer): Boolean; +{$IFDEF MSWINDOWS} +var + Buffer: array [0..1023] of char; +begin + with PStrData(Data)^ do + begin + SetString(Str, Buffer, + LoadString(Instance, Ident, Buffer, sizeof(Buffer))); + Result := Str = ''; + end; +end; +{$ENDIF} +{$IFDEF LINUX} +var + rs: TResStringRec; + Module: HModule; +begin + Module := Instance; + rs.Module := @Module; + with PStrData(Data)^ do + begin + rs.Identifier := Ident; + Str := LoadResString(@rs); + Result := Str = ''; + end; +end; +{$ENDIF} + +function FindStringResource(Ident: Integer): string; +var + StrData: TStrData; +begin + StrData.Ident := Ident; + StrData.Str := ''; + EnumResourceModules(EnumStringModules, @StrData); + Result := StrData.Str; +end; + +function LoadStr(Ident: Integer): string; +begin + Result := FindStringResource(Ident); +end; + +function FmtLoadStr(Ident: Integer; const Args: array of const): string; +begin + FmtStr(Result, FindStringResource(Ident), Args); +end; + +{ File management routines } + +function FileOpen(const FileName: string; Mode: LongWord): Integer; +{$IFDEF MSWINDOWS} +const + AccessMode: array[0..2] of LongWord = ( + GENERIC_READ, + GENERIC_WRITE, + GENERIC_READ or GENERIC_WRITE); + ShareMode: array[0..4] of LongWord = ( + 0, + 0, + FILE_SHARE_READ, + FILE_SHARE_WRITE, + FILE_SHARE_READ or FILE_SHARE_WRITE); +begin + Result := -1; + if ((Mode and 3) <= fmOpenReadWrite) and + ((Mode and $F0) <= fmShareDenyNone) then + Result := Integer(CreateFile(PChar(FileName), AccessMode[Mode and 3], + ShareMode[(Mode and $F0) shr 4], nil, OPEN_EXISTING, + FILE_ATTRIBUTE_NORMAL, 0)); +end; +{$ENDIF} +{$IFDEF LINUX} +const + ShareMode: array[0..fmShareDenyNone shr 4] of Byte = ( + 0, //No share mode specified + F_WRLCK, //fmShareExclusive + F_RDLCK, //fmShareDenyWrite + 0); //fmShareDenyNone +var + FileHandle, Tvar: Integer; + LockVar: TFlock; + smode: Byte; +begin + Result := -1; + if FileExists(FileName) and + ((Mode and 3) <= fmOpenReadWrite) and + ((Mode and $F0) <= fmShareDenyNone) then + begin + FileHandle := open(PChar(FileName), (Mode and 3), FileAccessRights); + + if FileHandle = -1 then Exit; + + smode := Mode and $F0 shr 4; + if ShareMode[smode] <> 0 then + begin + with LockVar do + begin + l_whence := SEEK_SET; + l_start := 0; + l_len := 0; + l_type := ShareMode[smode]; + end; + Tvar := fcntl(FileHandle, F_SETLK, LockVar); + if Tvar = -1 then + begin + __close(FileHandle); + Exit; + end; + end; + Result := FileHandle; + end; +end; +{$ENDIF} + +function FileCreate(const FileName: string): Integer; +{$IFDEF MSWINDOWS} +begin + Result := Integer(CreateFile(PChar(FileName), GENERIC_READ or GENERIC_WRITE, + 0, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)); +end; +{$ENDIF} +{$IFDEF LINUX} +begin + Result := FileCreate(FileName, FileAccessRights); +end; +{$ENDIF} + +function FileCreate(const FileName: string; Rights: Integer): Integer; +{$IFDEF MSWINDOWS} +begin + Result := FileCreate(FileName); +end; +{$ENDIF} +{$IFDEF LINUX} +begin + Result := Integer(open(PChar(FileName), O_RDWR or O_CREAT or O_TRUNC, Rights)); +end; +{$ENDIF} + +function FileRead(Handle: Integer; var Buffer; Count: LongWord): Integer; +begin +{$IFDEF MSWINDOWS} + if not ReadFile(THandle(Handle), Buffer, Count, LongWord(Result), nil) then + Result := -1; +{$ENDIF} +{$IFDEF LINUX} + Result := __read(Handle, Buffer, Count); +{$ENDIF} +end; + +function FileWrite(Handle: Integer; const Buffer; Count: LongWord): Integer; +begin +{$IFDEF MSWINDOWS} + if not WriteFile(THandle(Handle), Buffer, Count, LongWord(Result), nil) then + Result := -1; +{$ENDIF} +{$IFDEF LINUX} + Result := __write(Handle, Buffer, Count); +{$ENDIF} +end; + +function FileSeek(Handle, Offset, Origin: Integer): Integer; +begin +{$IFDEF MSWINDOWS} + Result := SetFilePointer(THandle(Handle), Offset, nil, Origin); +{$ENDIF} +{$IFDEF LINUX} + Result := __lseek(Handle, Offset, Origin); +{$ENDIF} +end; + +function FileSeek(Handle: Integer; const Offset: Int64; Origin: Integer): Int64; +{$IFDEF MSWINDOWS} +begin + Result := Offset; + Int64Rec(Result).Lo := SetFilePointer(THandle(Handle), Int64Rec(Result).Lo, + @Int64Rec(Result).Hi, Origin); +end; +{$ENDIF} +{$IFDEF LINUX} +var + Temp: Integer; +begin + Temp := Offset; // allow for range-checking + Result := FileSeek(Handle, Temp, Origin); +end; +{$ENDIF} + +procedure FileClose(Handle: Integer); +begin +{$IFDEF MSWINDOWS} + CloseHandle(THandle(Handle)); +{$ENDIF} +{$IFDEF LINUX} + __close(Handle); // No need to unlock since all locks are released on close. +{$ENDIF} +end; + +function FileAge(const FileName: string): Integer; +{$IFDEF MSWINDOWS} +var + Handle: THandle; + FindData: TWin32FindData; + LocalFileTime: TFileTime; +begin + Handle := FindFirstFile(PChar(FileName), FindData); + if Handle <> INVALID_HANDLE_VALUE then + begin + Windows.FindClose(Handle); + if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then + begin + FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime); + if FileTimeToDosDateTime(LocalFileTime, LongRec(Result).Hi, + LongRec(Result).Lo) then Exit; + end; + end; + Result := -1; +end; +{$ENDIF} +{$IFDEF LINUX} +var + st: TStatBuf; +begin + if stat(PChar(FileName), st) = 0 then + Result := st.st_mtime + else + Result := -1; +end; +{$ENDIF} + +function FileExists(const FileName: string): Boolean; +{$IFDEF MSWINDOWS} +begin + Result := FileAge(FileName) <> -1; +end; +{$ENDIF} +{$IFDEF LINUX} +begin + Result := euidaccess(PChar(FileName), F_OK) = 0; +end; +{$ENDIF} + +function DirectoryExists(const Directory: string): Boolean; +{$IFDEF LINUX} +var + st: TStatBuf; +begin + if stat(PChar(Directory), st) = 0 then + Result := S_ISDIR(st.st_mode) + else + Result := False; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +var + Code: Integer; +begin + Code := GetFileAttributes(PChar(Directory)); + Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0); +end; +{$ENDIF} + +function ForceDirectories(Dir: string): Boolean; +var + E: EInOutError; +begin + Result := True; + if Dir = '' then + begin + E := EInOutError.CreateRes(SCannotCreateDir); + E.ErrorCode := 3; + raise E; + end; + Dir := ExcludeTrailingPathDelimiter(Dir); +{$IFDEF MSWINDOWS} + if (Length(Dir) < 3) or DirectoryExists(Dir) + or (ExtractFilePath(Dir) = Dir) then Exit; // avoid 'xyz:\' problem. +{$ENDIF} +{$IFDEF LINUX} + if (Dir = '') or DirectoryExists(Dir) then Exit; +{$ENDIF} + Result := ForceDirectories(ExtractFilePath(Dir)) and CreateDir(Dir); +end; + +function FileGetDate(Handle: Integer): Integer; +{$IFDEF MSWINDOWS} +var + FileTime, LocalFileTime: TFileTime; +begin + if GetFileTime(THandle(Handle), nil, nil, @FileTime) and + FileTimeToLocalFileTime(FileTime, LocalFileTime) and + FileTimeToDosDateTime(LocalFileTime, LongRec(Result).Hi, + LongRec(Result).Lo) then Exit; + Result := -1; +end; +{$ENDIF} +{$IFDEF LINUX} +var + st: TStatBuf; +begin + if fstat(Handle, st) = 0 then + Result := st.st_mtime + else + Result := -1; +end; +{$ENDIF} + +function FileSetDate(const FileName: string; Age: Integer): Integer; +{$IFDEF MSWINDOWS} +var + f: THandle; +begin + f := FileOpen(FileName, fmOpenWrite); + if f = THandle(-1) then + Result := GetLastError + else + begin + Result := FileSetDate(f, Age); + FileClose(f); + end; +end; +{$ENDIF} +{$IFDEF LINUX} +var + ut: TUTimeBuffer; +begin + Result := 0; + ut.actime := Age; + ut.modtime := Age; + if utime(PChar(FileName), @ut) = -1 then + Result := GetLastError; +end; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function FileSetDate(Handle: Integer; Age: Integer): Integer; +var + LocalFileTime, FileTime: TFileTime; +begin + Result := 0; + if DosDateTimeToFileTime(LongRec(Age).Hi, LongRec(Age).Lo, LocalFileTime) and + LocalFileTimeToFileTime(LocalFileTime, FileTime) and + SetFileTime(Handle, nil, nil, @FileTime) then Exit; + Result := GetLastError; +end; + +function FileGetAttr(const FileName: string): Integer; +begin + Result := GetFileAttributes(PChar(FileName)); +end; + +function FileSetAttr(const FileName: string; Attr: Integer): Integer; +begin + Result := 0; + if not SetFileAttributes(PChar(FileName), Attr) then + Result := GetLastError; +end; +{$ENDIF} + +function FileIsReadOnly(const FileName: string): Boolean; +begin +{$IFDEF MSWINDOWS} + Result := (GetFileAttributes(PChar(FileName)) and faReadOnly) <> 0; +{$ENDIF} +{$IFDEF LINUX} + Result := (euidaccess(PChar(FileName), R_OK) = 0) and + (euidaccess(PChar(FileName), W_OK) <> 0); +{$ENDIF} +end; + +function FileSetReadOnly(const FileName: string; ReadOnly: Boolean): Boolean; +{$IFDEF MSWINDOWS} +var + Flags: Integer; +begin + Result := False; + Flags := GetFileAttributes(PChar(FileName)); + if Flags = -1 then Exit; + if ReadOnly then + Flags := Flags or faReadOnly + else + Flags := Flags and not faReadOnly; + Result := SetFileAttributes(PChar(FileName), Flags); +end; +{$ENDIF} +{$IFDEF LINUX} +var + st: TStatBuf; + Flags: Integer; +begin + Result := False; + if stat(PChar(FileName), st) <> 0 then Exit; + if ReadOnly then + Flags := st.st_mode and not (S_IWUSR or S_IWGRP or S_IWOTH) + else + Flags := st.st_mode or (S_IWUSR or S_IWGRP or S_IWOTH); + Result := chmod(PChar(FileName), Flags) = 0; +end; +{$ENDIF} + + +function FindMatchingFile(var F: TSearchRec): Integer; +{$IFDEF MSWINDOWS} +var + LocalFileTime: TFileTime; +begin + with F do + begin + while FindData.dwFileAttributes and ExcludeAttr <> 0 do + if not FindNextFile(FindHandle, FindData) then + begin + Result := GetLastError; + Exit; + end; + FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime); + FileTimeToDosDateTime(LocalFileTime, LongRec(Time).Hi, + LongRec(Time).Lo); + Size := FindData.nFileSizeLow; + Attr := FindData.dwFileAttributes; + Name := FindData.cFileName; + end; + Result := 0; +end; +{$ENDIF} +{$IFDEF LINUX} +var + PtrDirEnt: PDirEnt; + Scratch: TDirEnt; + StatBuf: TStatBuf; + LinkStatBuf: TStatBuf; + FName: string; + Attr: Integer; + Mode: mode_t; +begin + Result := -1; + PtrDirEnt := nil; + if readdir_r(F.FindHandle, @Scratch, PtrDirEnt) <> 0 then + Exit; + while PtrDirEnt <> nil do + begin + if fnmatch(PChar(F.Pattern), PtrDirEnt.d_name, 0) = 0 then + begin // F.PathOnly must include trailing backslash + FName := F.PathOnly + string(PtrDirEnt.d_name); + + if lstat(PChar(FName), StatBuf) = 0 then + begin + Attr := 0; + Mode := StatBuf.st_mode; + + if S_ISDIR(Mode) then + Attr := Attr or faDirectory + else + if not S_ISREG(Mode) then // directories shouldn't be treated as system files + begin + if S_ISLNK(Mode) then + begin + Attr := Attr or faSymLink; + if (stat(PChar(FName), LinkStatBuf) = 0) and + S_ISDIR(LinkStatBuf.st_mode) then + Attr := Attr or faDirectory + end; + Attr := Attr or faSysFile; + end; + + if (PtrDirEnt.d_name[0] = '.') and (PtrDirEnt.d_name[1] <> #0) then + begin + if not ((PtrDirEnt.d_name[1] = '.') and (PtrDirEnt.d_name[2] = #0)) then + Attr := Attr or faHidden; + end; + + if euidaccess(PChar(FName), W_OK) <> 0 then + Attr := Attr or faReadOnly; + + if Attr and F.ExcludeAttr = 0 then + begin + F.Size := StatBuf.st_size; + F.Attr := Attr; + F.Mode := StatBuf.st_mode; + F.Name := PtrDirEnt.d_name; + F.Time := StatBuf.st_mtime; + Result := 0; + Break; + end; + end; + end; + Result := -1; + if readdir_r(F.FindHandle, @Scratch, PtrDirEnt) <> 0 then + Break; + end // End of While +end; +{$ENDIF} + +function FindFirst(const Path: string; Attr: Integer; + var F: TSearchRec): Integer; +const + faSpecial = faHidden or faSysFile or faDirectory; +{$IFDEF MSWINDOWS} +begin + F.ExcludeAttr := not Attr and faSpecial; + F.FindHandle := FindFirstFile(PChar(Path), F.FindData); + if F.FindHandle <> INVALID_HANDLE_VALUE then + begin + Result := FindMatchingFile(F); + if Result <> 0 then FindClose(F); + end else + Result := GetLastError; +end; +{$ENDIF} +{$IFDEF LINUX} +begin + F.ExcludeAttr := not Attr and faSpecial; + F.PathOnly := ExtractFilePath(Path); + F.Pattern := ExtractFileName(Path); + if F.PathOnly = '' then + F.PathOnly := IncludeTrailingPathDelimiter(GetCurrentDir); + + F.FindHandle := opendir(PChar(F.PathOnly)); + if F.FindHandle <> nil then + begin + Result := FindMatchingFile(F); + if Result <> 0 then + FindClose(F); + end + else + Result:= GetLastError; +end; +{$ENDIF} + +function FindNext(var F: TSearchRec): Integer; +begin +{$IFDEF MSWINDOWS} + if FindNextFile(F.FindHandle, F.FindData) then + Result := FindMatchingFile(F) else + Result := GetLastError; +{$ENDIF} +{$IFDEF LINUX} + Result := FindMatchingFile(F); +{$ENDIF} +end; + +procedure FindClose(var F: TSearchRec); +begin +{$IFDEF MSWINDOWS} + if F.FindHandle <> INVALID_HANDLE_VALUE then + begin + Windows.FindClose(F.FindHandle); + F.FindHandle := INVALID_HANDLE_VALUE; + end; +{$ENDIF} +{$IFDEF LINUX} + if F.FindHandle <> nil then + begin + closedir(F.FindHandle); + F.FindHandle := nil; + end; +{$ENDIF} +end; + +function DeleteFile(const FileName: string): Boolean; +begin +{$IFDEF MSWINDOWS} + Result := Windows.DeleteFile(PChar(FileName)); +{$ENDIF} +{$IFDEF LINUX} + Result := unlink(PChar(FileName)) <> -1; +{$ENDIF} +end; + +function RenameFile(const OldName, NewName: string): Boolean; +begin +{$IFDEF MSWINDOWS} + Result := MoveFile(PChar(OldName), PChar(NewName)); +{$ENDIF} +{$IFDEF LINUX} + Result := __rename(PChar(OldName), PChar(NewName)) = 0; +{$ENDIF} +end; + +function AnsiStrLastChar(P: PChar): PChar; +var + LastByte: Integer; +begin + LastByte := StrLen(P) - 1; + Result := @P[LastByte]; +{$IFDEF MSWINDOWS} + if StrByteType(P, LastByte) = mbTrailByte then Dec(Result); +{$ENDIF} +{$IFDEF LINUX} + while StrByteType(P, Result - P) = mbTrailByte do Dec(Result); +{$ENDIF} +end; + +function AnsiLastChar(const S: string): PChar; +var + LastByte: Integer; +begin + LastByte := Length(S); + if LastByte <> 0 then + begin + while ByteType(S, LastByte) = mbTrailByte do Dec(LastByte); + Result := @S[LastByte]; + end + else + Result := nil; +end; + +function LastDelimiter(const Delimiters, S: string): Integer; +var + P: PChar; +begin + Result := Length(S); + P := PChar(Delimiters); + while Result > 0 do + begin + if (S[Result] <> #0) and (StrScan(P, S[Result]) <> nil) then +{$IFDEF MSWINDOWS} + if (ByteType(S, Result) = mbTrailByte) then + Dec(Result) + else + Exit; +{$ENDIF} +{$IFDEF LINUX} + begin + if (ByteType(S, Result) <> mbTrailByte) then + Exit; + Dec(Result); + while ByteType(S, Result) = mbTrailByte do Dec(Result); + end; +{$ENDIF} + Dec(Result); + end; +end; + +function ChangeFileExt(const FileName, Extension: string): string; +var + I: Integer; +begin + I := LastDelimiter('.' + PathDelim + DriveDelim,Filename); + if (I = 0) or (FileName[I] <> '.') then I := MaxInt; + Result := Copy(FileName, 1, I - 1) + Extension; +end; + +function ExtractFilePath(const FileName: string): string; +var + I: Integer; +begin + I := LastDelimiter(PathDelim + DriveDelim, FileName); + Result := Copy(FileName, 1, I); +end; + +function ExtractFileDir(const FileName: string): string; +var + I: Integer; +begin + I := LastDelimiter(PathDelim + DriveDelim, Filename); + if (I > 1) and (FileName[I] = PathDelim) and + (not IsDelimiter( PathDelim + DriveDelim, FileName, I-1)) then Dec(I); + Result := Copy(FileName, 1, I); +end; + +function ExtractFileDrive(const FileName: string): string; +{$IFDEF MSWINDOWS} +var + I, J: Integer; +begin + if (Length(FileName) >= 2) and (FileName[2] = DriveDelim) then + Result := Copy(FileName, 1, 2) + else if (Length(FileName) >= 2) and (FileName[1] = PathDelim) and + (FileName[2] = PathDelim) then + begin + J := 0; + I := 3; + While (I < Length(FileName)) and (J < 2) do + begin + if FileName[I] = PathDelim then Inc(J); + if J < 2 then Inc(I); + end; + if FileName[I] = PathDelim then Dec(I); + Result := Copy(FileName, 1, I); + end else Result := ''; +end; +{$ENDIF} +{$IFDEF LINUX} +begin + Result := ''; // Linux doesn't support drive letters +end; +{$ENDIF} + +function ExtractFileName(const FileName: string): string; +var + I: Integer; +begin + I := LastDelimiter(PathDelim + DriveDelim, FileName); + Result := Copy(FileName, I + 1, MaxInt); +end; + +function ExtractFileExt(const FileName: string): string; +var + I: Integer; +begin + I := LastDelimiter('.' + PathDelim + DriveDelim, FileName); + if (I > 0) and (FileName[I] = '.') then + Result := Copy(FileName, I, MaxInt) else + Result := ''; +end; + +function ExpandFileName(const FileName: string): string; +{$IFDEF MSWINDOWS} +var + FName: PChar; + Buffer: array[0..MAX_PATH - 1] of Char; +begin + SetString(Result, Buffer, GetFullPathName(PChar(FileName), SizeOf(Buffer), + Buffer, FName)); +end; +{$ENDIF} + +{$IFDEF LINUX} +function ExpandTilde(const InString: string): string; +var + W: wordexp_t; + SpacePos: Integer; + PostSpaceStr: string; +begin + Result := InString; + SpacePos := AnsiPos(' ', Result); // only expand stuff up to the first space in the filename + if SpacePos > 0 then // then just add the space and the rest of the string + PostSpaceStr := Copy(Result, SpacePos, Length(Result) - (SpacePos-1)); + case wordexp(PChar(Result), W, WRDE_NOCMD) of + 0: // success + begin + Result := PChar(W.we_wordv^); + wordfree(W); + end; + WRDE_NOSPACE: // error, but W may be partially allocated + wordfree(W); + end; + if PostSpaceStr <> '' then + Result := Result + PostSpaceStr; +end; + +var + I, J: Integer; + LastWasPathDelim: Boolean; + TempName: string; +begin + Result := ''; + if Length(Filename) = 0 then Exit; + + if FileName[1] = PathDelim then + TempName := FileName + else + begin + TempName := FileName; + if FileName[1] = '~' then + TempName := ExpandTilde(TempName) + else + TempName := IncludeTrailingPathDelimiter(GetCurrentDir) + TempName; + end; + + I := 1; + J := 1; + + LastWasPathDelim := False; + + while I <= Length(TempName) do + begin + case TempName[I] of + PathDelim: + if J < I then + begin + // Check for consecutive 'PathDelim' characters and skip them if present + if (I = 1) or (TempName[I - 1] <> PathDelim) then + Result := Result + Copy(TempName, J, I - J); + J := I; + // Set a flag indicating that we just processed a path delimiter + LastWasPathDelim := True; + end; + '.': + begin + // If the last character was a path delimiter then this '.' is + // possibly a relative path modifier + if LastWasPathDelim then + begin + // Check if the path ends in a '.' + if I < Length(TempName) then + begin + // If the next character is another '.' then this may be a relative path + // except if there is another '.' after that one. In this case simply + // treat this as just another filename. + if (TempName[I + 1] = '.') and + ((I + 1 >= Length(TempName)) or (TempName[I + 2] <> '.')) then + begin + // Don't attempt to backup past the Root dir + if Length(Result) > 1 then + // For the purpose of this excercise, treat the last dir as a + // filename so we can use this function to remove it + Result := ExtractFilePath(ExcludeTrailingPathDelimiter(Result)); + J := I; + end + // Simply skip over and ignore any 'current dir' constrcucts, './' + // or the remaining './' from a ../ constrcut. + else if TempName[I + 1] = PathDelim then + begin + Result := IncludeTrailingPathDelimiter(Result); + if TempName[I] in LeadBytes then + Inc(I, StrCharLength(@TempName[I])) + else + Inc(I); + J := I + 1; + end else + // If any of the above tests fail, then this is not a 'current dir' or + // 'parent dir' construct so just clear the state and continue. + LastWasPathDelim := False; + end else + begin + // Don't let the expanded path end in a 'PathDelim' character + Result := ExcludeTrailingPathDelimiter(Result); + J := I + 1; + end; + end; + end; + else + LastWasPathDelim := False; + end; + if TempName[I] in LeadBytes then + Inc(I, StrCharLength(@TempName[I])) + else + Inc(I); + end; + // This will finally append what is left + if (I - J > 1) or (TempName[I] <> PathDelim) then + Result := Result + Copy(TempName, J, I - J); +end; +{$ENDIF} + +function ExpandFileNameCase(const FileName: string; + out MatchFound: TFilenameCaseMatch): string; +var + SR: TSearchRec; + FullPath, Name: string; + Temp: Integer; + FoundOne: Boolean; + {$IFDEF LINUX} + Scans: Byte; + FirstLetter, TestLetter: string; + {$ENDIF} +begin + Result := ExpandFileName(FileName); + FullPath := ExtractFilePath(Result); + Name := ExtractFileName(Result); + MatchFound := mkNone; + + // if FullPath is not the root directory (portable) + if not SameFileName(FullPath, IncludeTrailingPathDelimiter(ExtractFileDrive(FullPath))) then + begin // Does the path need case-sensitive work? + Temp := FindFirst(FullPath, faAnyFile, SR); + FindClose(SR); // close search before going recursive + if Temp <> 0 then + begin + FullPath := ExcludeTrailingPathDelimiter(FullPath); + FullPath := ExpandFileNameCase(FullPath, MatchFound); + if MatchFound = mkNone then + Exit; // if we can't find the path, we certainly can't find the file! + FullPath := IncludeTrailingPathDelimiter(FullPath); + end; + end; + + // Path is validated / adjusted. Now for the file itself + try + if FindFirst(FullPath + Name, faAnyFile, SR)= 0 then // exact match on filename + begin + if not (MatchFound in [mkSingleMatch, mkAmbiguous]) then // path might have been inexact + MatchFound := mkExactMatch; + Result := FullPath + SR.Name; + Exit; + end; + finally + FindClose(SR); + end; + + FoundOne := False; // Windows should never get to here except for file-not-found + +{$IFDEF LINUX} + +{ Scan the directory. + To minimize the number of filenames tested, scan the directory + using upper/lowercase first letter + wildcard. + This results in two scans of the directory (particularly on Linux) but + vastly reduces the number of times we have to perform an expensive + locale-charset case-insensitive string compare. } + + // First, scan for lowercase first letter + FirstLetter := AnsiLowerCase(Name[1]); + for Scans := 0 to 1 do + begin + Temp := FindFirst(FullPath + FirstLetter + '*', faAnyFile, SR); + while Temp = 0 do + begin + if AnsiSameText(SR.Name, Name) then + begin + if FoundOne then + begin // this is the second match + MatchFound := mkAmbiguous; + Exit; + end + else + begin + FoundOne := True; + Result := FullPath + SR.Name; + end; + end; + Temp := FindNext(SR); + end; + FindClose(SR); + TestLetter := AnsiUpperCase(Name[1]); + if TestLetter = FirstLetter then Break; + FirstLetter := TestLetter; + end; +{$ENDIF} + + if MatchFound <> mkAmbiguous then + begin + if FoundOne then + MatchFound := mkSingleMatch + else + MatchFound := mkNone; + end; +end; + +{$IFDEF MSWINDOWS} +function GetUniversalName(const FileName: string): string; +type + PNetResourceArray = ^TNetResourceArray; + TNetResourceArray = array[0..MaxInt div SizeOf(TNetResource) - 1] of TNetResource; +var + I, BufSize, NetResult: Integer; + Count, Size: LongWord; + Drive: Char; + NetHandle: THandle; + NetResources: PNetResourceArray; + RemoteNameInfo: array[0..1023] of Byte; +begin + Result := FileName; + if (Win32Platform <> VER_PLATFORM_WIN32_WINDOWS) or (Win32MajorVersion > 4) then + begin + Size := SizeOf(RemoteNameInfo); + if WNetGetUniversalName(PChar(FileName), UNIVERSAL_NAME_INFO_LEVEL, + @RemoteNameInfo, Size) <> NO_ERROR then Exit; + Result := PRemoteNameInfo(@RemoteNameInfo).lpUniversalName; + end else + begin + { The following works around a bug in WNetGetUniversalName under Windows 95 } + Drive := UpCase(FileName[1]); + if (Drive < 'A') or (Drive > 'Z') or (Length(FileName) < 3) or + (FileName[2] <> ':') or (FileName[3] <> '\') then + Exit; + if WNetOpenEnum(RESOURCE_CONNECTED, RESOURCETYPE_DISK, 0, nil, + NetHandle) <> NO_ERROR then Exit; + try + BufSize := 50 * SizeOf(TNetResource); + GetMem(NetResources, BufSize); + try + while True do + begin + Count := $FFFFFFFF; + Size := BufSize; + NetResult := WNetEnumResource(NetHandle, Count, NetResources, Size); + if NetResult = ERROR_MORE_DATA then + begin + BufSize := Size; + ReallocMem(NetResources, BufSize); + Continue; + end; + if NetResult <> NO_ERROR then Exit; + for I := 0 to Count - 1 do + with NetResources^[I] do + if (lpLocalName <> nil) and (Drive = UpCase(lpLocalName[0])) then + begin + Result := lpRemoteName + Copy(FileName, 3, Length(FileName) - 2); + Exit; + end; + end; + finally + FreeMem(NetResources, BufSize); + end; + finally + WNetCloseEnum(NetHandle); + end; + end; +end; + +function ExpandUNCFileName(const FileName: string): string; +begin + { First get the local resource version of the file name } + Result := ExpandFileName(FileName); + if (Length(Result) >= 3) and (Result[2] = ':') and (Upcase(Result[1]) >= 'A') + and (Upcase(Result[1]) <= 'Z') then + Result := GetUniversalName(Result); +end; +{$ENDIF} +{$IFDEF LINUX} +function ExpandUNCFileName(const FileName: string): string; +begin + Result := ExpandFileName(FileName); +end; +{$ENDIF} + +function ExtractRelativePath(const BaseName, DestName: string): string; +var + BasePath, DestPath: string; + BaseLead, DestLead: PChar; + BasePtr, DestPtr: PChar; + + function ExtractFilePathNoDrive(const FileName: string): string; + begin + Result := ExtractFilePath(FileName); + Delete(Result, 1, Length(ExtractFileDrive(FileName))); + end; + + function Next(var Lead: PChar): PChar; + begin + Result := Lead; + if Result = nil then Exit; + Lead := AnsiStrScan(Lead, PathDelim); + if Lead <> nil then + begin + Lead^ := #0; + Inc(Lead); + end; + end; + +begin + if SameFilename(ExtractFileDrive(BaseName), ExtractFileDrive(DestName)) then + begin + BasePath := ExtractFilePathNoDrive(BaseName); + UniqueString(BasePath); + DestPath := ExtractFilePathNoDrive(DestName); + UniqueString(DestPath); + BaseLead := Pointer(BasePath); + BasePtr := Next(BaseLead); + DestLead := Pointer(DestPath); + DestPtr := Next(DestLead); + while (BasePtr <> nil) and (DestPtr <> nil) and SameFilename(BasePtr, DestPtr) do + begin + BasePtr := Next(BaseLead); + DestPtr := Next(DestLead); + end; + Result := ''; + while BaseLead <> nil do + begin + Result := Result + '..' + PathDelim; { Do not localize } + Next(BaseLead); + end; + if (DestPtr <> nil) and (DestPtr^ <> #0) then + Result := Result + DestPtr + PathDelim; + if DestLead <> nil then + Result := Result + DestLead; // destlead already has a trailing backslash + Result := Result + ExtractFileName(DestName); + end + else + Result := DestName; +end; + +{$IFDEF MSWINDOWS} +function ExtractShortPathName(const FileName: string): string; +var + Buffer: array[0..MAX_PATH - 1] of Char; +begin + SetString(Result, Buffer, + GetShortPathName(PChar(FileName), Buffer, SizeOf(Buffer))); +end; +{$ENDIF} + +function FileSearch(const Name, DirList: string): string; +var + I, P, L: Integer; + C: Char; +begin + Result := Name; + P := 1; + L := Length(DirList); + while True do + begin + if FileExists(Result) then Exit; + while (P <= L) and (DirList[P] = PathSep) do Inc(P); + if P > L then Break; + I := P; + while (P <= L) and (DirList[P] <> PathSep) do + begin + if DirList[P] in LeadBytes then + P := NextCharIndex(DirList, P) + else + Inc(P); + end; + Result := Copy(DirList, I, P - I); + C := AnsiLastChar(Result)^; + if (C <> DriveDelim) and (C <> PathDelim) then + Result := Result + PathDelim; + Result := Result + Name; + end; + Result := ''; +end; + +{$IFDEF MSWINDOWS} +// This function is used if the OS doesn't support GetDiskFreeSpaceEx +function BackfillGetDiskFreeSpaceEx(Directory: PChar; var FreeAvailable, + TotalSpace: TLargeInteger; TotalFree: PLargeInteger): Bool; stdcall; +var + SectorsPerCluster, BytesPerSector, FreeClusters, TotalClusters: LongWord; + Temp: Int64; + Dir: PChar; +begin + if Directory <> nil then + Dir := Directory + else + Dir := nil; + Result := GetDiskFreeSpaceA(Dir, SectorsPerCluster, BytesPerSector, + FreeClusters, TotalClusters); + Temp := SectorsPerCluster * BytesPerSector; + FreeAvailable := Temp * FreeClusters; + TotalSpace := Temp * TotalClusters; +end; + +function InternalGetDiskSpace(Drive: Byte; + var TotalSpace, FreeSpaceAvailable: Int64): Bool; +var + RootPath: array[0..4] of Char; + RootPtr: PChar; +begin + RootPtr := nil; + if Drive > 0 then + begin + RootPath[0] := Char(Drive + $40); + RootPath[1] := ':'; + RootPath[2] := '\'; + RootPath[3] := #0; + RootPtr := RootPath; + end; + Result := GetDiskFreeSpaceEx(RootPtr, FreeSpaceAvailable, TotalSpace, nil); +end; + +function DiskFree(Drive: Byte): Int64; +var + TotalSpace: Int64; +begin + if not InternalGetDiskSpace(Drive, TotalSpace, Result) then + Result := -1; +end; + +function DiskSize(Drive: Byte): Int64; +var + FreeSpace: Int64; +begin + if not InternalGetDiskSpace(Drive, Result, FreeSpace) then + Result := -1; +end; +{$ENDIF} + +function FileDateToDateTime(FileDate: Integer): TDateTime; +{$IFDEF MSWINDOWS} +begin + Result := + EncodeDate( + LongRec(FileDate).Hi shr 9 + 1980, + LongRec(FileDate).Hi shr 5 and 15, + LongRec(FileDate).Hi and 31) + + EncodeTime( + LongRec(FileDate).Lo shr 11, + LongRec(FileDate).Lo shr 5 and 63, + LongRec(FileDate).Lo and 31 shl 1, 0); +end; +{$ENDIF} +{$IFDEF LINUX} +var + UT: TUnixTime; +begin + localtime_r(@FileDate, UT); + Result := EncodeDate(UT.tm_year + 1900, UT.tm_mon + 1, UT.tm_mday) + + EncodeTime(UT.tm_hour, UT.tm_min, UT.tm_sec, 0); +end; +{$ENDIF} + +function DateTimeToFileDate(DateTime: TDateTime): Integer; +{$IFDEF MSWINDOWS} +var + Year, Month, Day, Hour, Min, Sec, MSec: Word; +begin + DecodeDate(DateTime, Year, Month, Day); + if (Year < 1980) or (Year > 2107) then Result := 0 else + begin + DecodeTime(DateTime, Hour, Min, Sec, MSec); + LongRec(Result).Lo := (Sec shr 1) or (Min shl 5) or (Hour shl 11); + LongRec(Result).Hi := Day or (Month shl 5) or ((Year - 1980) shl 9); + end; +end; +{$ENDIF} +{$IFDEF LINUX} +var + tm: TUnixTime; + Year, Month, Day, Hour, Min, Sec, MSec: Word; +begin + DecodeDate(DateTime, Year, Month, Day); + { Valid range for 32 bit Unix time_t: 1970 through 2038 } + if (Year < 1970) or (Year > 2038) then + Result := 0 + else + begin + DecodeTime(DateTime, Hour, Min, Sec, MSec); + FillChar(tm, sizeof(tm), 0); + with tm do + begin + tm_sec := Sec; + tm_min := Min; + tm_hour := Hour; + tm_mday := Day; + tm_mon := Month - 1; + tm_year := Year - 1900; + tm_isdst := -1; + end; + Result := mktime(tm); + end; +end; +{$ENDIF} + +function GetCurrentDir: string; +begin + GetDir(0, Result); +end; + +function SetCurrentDir(const Dir: string): Boolean; +begin +{$IFDEF MSWINDOWS} + Result := SetCurrentDirectory(PChar(Dir)); +{$ENDIF} +{$IFDEF LINUX} + Result := __chdir(PChar(Dir)) = 0; +{$ENDIF} +end; + +function CreateDir(const Dir: string): Boolean; +begin +{$IFDEF MSWINDOWS} + Result := CreateDirectory(PChar(Dir), nil); +{$ENDIF} +{$IFDEF LINUX} + Result := __mkdir(PChar(Dir), mode_t(-1)) = 0; +{$ENDIF} +end; + +function RemoveDir(const Dir: string): Boolean; +begin +{$IFDEF MSWINDOWS} + Result := RemoveDirectory(PChar(Dir)); +{$ENDIF} +{$IFDEF LINUX} + Result := __rmdir(PChar(Dir)) = 0; +{$ENDIF} +end; + +{ PChar routines } + +function StrLen(const Str: PChar): Cardinal; assembler; +asm + MOV EDX,EDI + MOV EDI,EAX + MOV ECX,0FFFFFFFFH + XOR AL,AL + REPNE SCASB + MOV EAX,0FFFFFFFEH + SUB EAX,ECX + MOV EDI,EDX +end; + +function StrEnd(const Str: PChar): PChar; assembler; +asm + MOV EDX,EDI + MOV EDI,EAX + MOV ECX,0FFFFFFFFH + XOR AL,AL + REPNE SCASB + LEA EAX,[EDI-1] + MOV EDI,EDX +end; + +function StrMove(Dest: PChar; const Source: PChar; Count: Cardinal): PChar; +begin + Result := Dest; + Move(Source^, Dest^, Count); +end; + +function StrCopy(Dest: PChar; const Source: PChar): PChar; +asm + PUSH EDI + PUSH ESI + MOV ESI,EAX + MOV EDI,EDX + MOV ECX,0FFFFFFFFH + XOR AL,AL + REPNE SCASB + NOT ECX + MOV EDI,ESI + MOV ESI,EDX + MOV EDX,ECX + MOV EAX,EDI + SHR ECX,2 + REP MOVSD + MOV ECX,EDX + AND ECX,3 + REP MOVSB + POP ESI + POP EDI +end; + +function StrECopy(Dest: PChar; const Source: PChar): PChar; assembler; +asm + PUSH EDI + PUSH ESI + MOV ESI,EAX + MOV EDI,EDX + MOV ECX,0FFFFFFFFH + XOR AL,AL + REPNE SCASB + NOT ECX + MOV EDI,ESI + MOV ESI,EDX + MOV EDX,ECX + SHR ECX,2 + REP MOVSD + MOV ECX,EDX + AND ECX,3 + REP MOVSB + LEA EAX,[EDI-1] + POP ESI + POP EDI +end; + +function StrLCopy(Dest: PChar; const Source: PChar; MaxLen: Cardinal): PChar; assembler; +asm + PUSH EDI + PUSH ESI + PUSH EBX + MOV ESI,EAX + MOV EDI,EDX + MOV EBX,ECX + XOR AL,AL + TEST ECX,ECX + JZ @@1 + REPNE SCASB + JNE @@1 + INC ECX +@@1: SUB EBX,ECX + MOV EDI,ESI + MOV ESI,EDX + MOV EDX,EDI + MOV ECX,EBX + SHR ECX,2 + REP MOVSD + MOV ECX,EBX + AND ECX,3 + REP MOVSB + STOSB + MOV EAX,EDX + POP EBX + POP ESI + POP EDI +end; + +function StrPCopy(Dest: PChar; const Source: string): PChar; +begin + Result := StrLCopy(Dest, PChar(Source), Length(Source)); +end; + +function StrPLCopy(Dest: PChar; const Source: string; + MaxLen: Cardinal): PChar; +begin + Result := StrLCopy(Dest, PChar(Source), MaxLen); +end; + +function StrCat(Dest: PChar; const Source: PChar): PChar; +begin + StrCopy(StrEnd(Dest), Source); + Result := Dest; +end; + +function StrLCat(Dest: PChar; const Source: PChar; MaxLen: Cardinal): PChar; assembler; +asm + PUSH EDI + PUSH ESI + PUSH EBX + MOV EDI,Dest + MOV ESI,Source + MOV EBX,MaxLen + CALL StrEnd + MOV ECX,EDI + ADD ECX,EBX + SUB ECX,EAX + JBE @@1 + MOV EDX,ESI + CALL StrLCopy +@@1: MOV EAX,EDI + POP EBX + POP ESI + POP EDI +end; + +function StrComp(const Str1, Str2: PChar): Integer; assembler; +asm + PUSH EDI + PUSH ESI + MOV EDI,EDX + MOV ESI,EAX + MOV ECX,0FFFFFFFFH + XOR EAX,EAX + REPNE SCASB + NOT ECX + MOV EDI,EDX + XOR EDX,EDX + REPE CMPSB + MOV AL,[ESI-1] + MOV DL,[EDI-1] + SUB EAX,EDX + POP ESI + POP EDI +end; + +function StrIComp(const Str1, Str2: PChar): Integer; assembler; +asm + PUSH EDI + PUSH ESI + MOV EDI,EDX + MOV ESI,EAX + MOV ECX,0FFFFFFFFH + XOR EAX,EAX + REPNE SCASB + NOT ECX + MOV EDI,EDX + XOR EDX,EDX +@@1: REPE CMPSB + JE @@4 + MOV AL,[ESI-1] + CMP AL,'a' + JB @@2 + CMP AL,'z' + JA @@2 + SUB AL,20H +@@2: MOV DL,[EDI-1] + CMP DL,'a' + JB @@3 + CMP DL,'z' + JA @@3 + SUB DL,20H +@@3: SUB EAX,EDX + JE @@1 +@@4: POP ESI + POP EDI +end; + +function StrLComp(const Str1, Str2: PChar; MaxLen: Cardinal): Integer; assembler; +asm + PUSH EDI + PUSH ESI + PUSH EBX + MOV EDI,EDX + MOV ESI,EAX + MOV EBX,ECX + XOR EAX,EAX + OR ECX,ECX + JE @@1 + REPNE SCASB + SUB EBX,ECX + MOV ECX,EBX + MOV EDI,EDX + XOR EDX,EDX + REPE CMPSB + MOV AL,[ESI-1] + MOV DL,[EDI-1] + SUB EAX,EDX +@@1: POP EBX + POP ESI + POP EDI +end; + +function StrLIComp(const Str1, Str2: PChar; MaxLen: Cardinal): Integer; assembler; +asm + PUSH EDI + PUSH ESI + PUSH EBX + MOV EDI,EDX + MOV ESI,EAX + MOV EBX,ECX + XOR EAX,EAX + OR ECX,ECX + JE @@4 + REPNE SCASB + SUB EBX,ECX + MOV ECX,EBX + MOV EDI,EDX + XOR EDX,EDX +@@1: REPE CMPSB + JE @@4 + MOV AL,[ESI-1] + CMP AL,'a' + JB @@2 + CMP AL,'z' + JA @@2 + SUB AL,20H +@@2: MOV DL,[EDI-1] + CMP DL,'a' + JB @@3 + CMP DL,'z' + JA @@3 + SUB DL,20H +@@3: SUB EAX,EDX + JE @@1 +@@4: POP EBX + POP ESI + POP EDI +end; + +function StrScan(const Str: PChar; Chr: Char): PChar; +begin + Result := Str; + while Result^ <> Chr do + begin + if Result^ = #0 then + begin + Result := nil; + Exit; + end; + Inc(Result); + end; +end; + +function StrRScan(const Str: PChar; Chr: Char): PChar; +var + MostRecentFound: PChar; +begin + if Chr = #0 then + Result := StrEnd(Str) + else + begin + Result := nil; + + MostRecentFound := Str; + while True do + begin + while MostRecentFound^ <> Chr do + begin + if MostRecentFound^ = #0 then + Exit; + Inc(MostRecentFound); + end; + Result := MostRecentFound; + Inc(MostRecentFound); + end; + end; +end; + +function StrPos(const Str1, Str2: PChar): PChar; assembler; +asm + PUSH EDI + PUSH ESI + PUSH EBX + OR EAX,EAX + JE @@2 + OR EDX,EDX + JE @@2 + MOV EBX,EAX + MOV EDI,EDX + XOR AL,AL + MOV ECX,0FFFFFFFFH + REPNE SCASB + NOT ECX + DEC ECX + JE @@2 + MOV ESI,ECX + MOV EDI,EBX + MOV ECX,0FFFFFFFFH + REPNE SCASB + NOT ECX + SUB ECX,ESI + JBE @@2 + MOV EDI,EBX + LEA EBX,[ESI-1] +@@1: MOV ESI,EDX + LODSB + REPNE SCASB + JNE @@2 + MOV EAX,ECX + PUSH EDI + MOV ECX,EBX + REPE CMPSB + POP EDI + MOV ECX,EAX + JNE @@1 + LEA EAX,[EDI-1] + JMP @@3 +@@2: XOR EAX,EAX +@@3: POP EBX + POP ESI + POP EDI +end; + +function StrUpper(Str: PChar): PChar; assembler; +asm + PUSH ESI + MOV ESI,Str + MOV EDX,Str +@@1: LODSB + OR AL,AL + JE @@2 + CMP AL,'a' + JB @@1 + CMP AL,'z' + JA @@1 + SUB AL,20H + MOV [ESI-1],AL + JMP @@1 +@@2: XCHG EAX,EDX + POP ESI +end; + +function StrLower(Str: PChar): PChar; assembler; +asm + PUSH ESI + MOV ESI,Str + MOV EDX,Str +@@1: LODSB + OR AL,AL + JE @@2 + CMP AL,'A' + JB @@1 + CMP AL,'Z' + JA @@1 + ADD AL,20H + MOV [ESI-1],AL + JMP @@1 +@@2: XCHG EAX,EDX + POP ESI +end; + +function StrPas(const Str: PChar): string; +begin + Result := Str; +end; + +function StrAlloc(Size: Cardinal): PChar; +begin + Inc(Size, SizeOf(Cardinal)); + GetMem(Result, Size); + Cardinal(Pointer(Result)^) := Size; + Inc(Result, SizeOf(Cardinal)); +end; + +function StrBufSize(const Str: PChar): Cardinal; +var + P: PChar; +begin + P := Str; + Dec(P, SizeOf(Cardinal)); + Result := Cardinal(Pointer(P)^) - SizeOf(Cardinal); +end; + +function StrNew(const Str: PChar): PChar; +var + Size: Cardinal; +begin + if Str = nil then Result := nil else + begin + Size := StrLen(Str) + 1; + Result := StrMove(StrAlloc(Size), Str, Size); + end; +end; + +procedure StrDispose(Str: PChar); +begin + if Str <> nil then + begin + Dec(Str, SizeOf(Cardinal)); + FreeMem(Str, Cardinal(Pointer(Str)^)); + end; +end; + +{ String formatting routines } + +procedure FormatError(ErrorCode: Integer; Format: PChar; FmtLen: Cardinal); +const + FormatErrorStrs: array[0..1] of string = ( + SInvalidFormat, SArgumentMissing); +var + Buffer: array[0..31] of Char; +begin + if FmtLen > 31 then FmtLen := 31; + if StrByteType(Format, FmtLen-1) = mbLeadByte then Dec(FmtLen); + StrMove(Buffer, Format, FmtLen); + Buffer[FmtLen] := #0; + ConvertErrorFmt(FormatErrorStrs[ErrorCode], [PChar(@Buffer)]); +end; + +procedure FormatVarToStr(var S: string; const V: Variant); +begin + {if Assigned(System.VarToLStr) then + System.is(S, V) + else + System.Error(reVarInvalidOp); } + S:=''; +end; + +procedure FormatClearStr(var S: string); +begin + S := ''; +end; + +function FloatToTextEx(BufferArg: PChar; const Value; ValueType: TFloatValue; + Format: TFloatFormat; Precision, Digits: Integer; + const FormatSettings: TFormatSettings): Integer; +begin + Result := FloatToText(BufferArg, Value, ValueType, Format, Precision, Digits, + FormatSettings); +end; + +function FormatBuf(var Buffer; BufLen: Cardinal; const Format; + FmtLen: Cardinal; const Args: array of const): Cardinal; +var + ArgIndex, Width, Prec: Integer; + BufferOrg, FormatOrg, FormatPtr, TempStr: PChar; + JustFlag: Byte; + StrBuf: array[0..64] of Char; + TempAnsiStr: string; + SaveGOT: Integer; +{ in: eax <-> Buffer } +{ in: edx <-> BufLen } +{ in: ecx <-> Format } + +asm + PUSH EBX + PUSH ESI + PUSH EDI + MOV EDI,EAX + MOV ESI,ECX +{$IFDEF PIC} + PUSH ECX + CALL GetGOT + POP ECX +{$ELSE} + XOR EAX,EAX +{$ENDIF} + MOV SaveGOT,EAX + ADD ECX,FmtLen + MOV BufferOrg,EDI + XOR EAX,EAX + MOV ArgIndex,EAX + MOV TempStr,EAX + MOV TempAnsiStr,EAX + +@Loop: + OR EDX,EDX + JE @Done + +@NextChar: + CMP ESI,ECX + JE @Done + LODSB + CMP AL,'%' + JE @Format + +@StoreChar: + STOSB + DEC EDX + JNE @NextChar + +@Done: + MOV EAX,EDI + SUB EAX,BufferOrg + JMP @Exit + +@Format: + CMP ESI,ECX + JE @Done + LODSB + CMP AL,'%' + JE @StoreChar + LEA EBX,[ESI-2] + MOV FormatOrg,EBX +@A0: MOV JustFlag,AL + CMP AL,'-' + JNE @A1 + CMP ESI,ECX + JE @Done + LODSB +@A1: CALL @Specifier + CMP AL,':' + JNE @A2 + MOV ArgIndex,EBX + CMP ESI,ECX + JE @Done + LODSB + JMP @A0 + +@A2: MOV Width,EBX + MOV EBX,-1 + CMP AL,'.' + JNE @A3 + CMP ESI,ECX + JE @Done + LODSB + CALL @Specifier +@A3: MOV Prec,EBX + MOV FormatPtr,ESI + PUSH ECX + PUSH EDX + + CALL @Convert + + POP EDX + MOV EBX,Width + SUB EBX,ECX //(* ECX <=> number of characters output *) + JAE @A4 //(* jump -> output smaller than width *) + XOR EBX,EBX + +@A4: CMP JustFlag,'-' + JNE @A6 + SUB EDX,ECX + JAE @A5 + ADD ECX,EDX + XOR EDX,EDX + +@A5: REP MOVSB + +@A6: XCHG EBX,ECX + SUB EDX,ECX + JAE @A7 + ADD ECX,EDX + XOR EDX,EDX +@A7: MOV AL,' ' + REP STOSB + XCHG EBX,ECX + SUB EDX,ECX + JAE @A8 + ADD ECX,EDX + XOR EDX,EDX +@A8: REP MOVSB + CMP TempStr,0 + JE @A9 + PUSH EDX + LEA EAX,TempStr +// PUSH EBX // GOT setup unnecessary for +// MOV EBX, SaveGOT // same-unit calls to Pascal procedures + CALL FormatClearStr +// POP EBX + POP EDX +@A9: POP ECX + MOV ESI,FormatPtr + JMP @Loop + +@Specifier: + XOR EBX,EBX + CMP AL,'*' + JE @B3 +@B1: CMP AL,'0' + JB @B5 + CMP AL,'9' + JA @B5 + IMUL EBX,EBX,10 + SUB AL,'0' + MOVZX EAX,AL + ADD EBX,EAX + CMP ESI,ECX + JE @B2 + LODSB + JMP @B1 +@B2: POP EAX + JMP @Done +@B3: MOV EAX,ArgIndex + CMP EAX,Args.Integer[-4] + JG @B4 + INC ArgIndex + MOV EBX,Args + CMP [EBX+EAX*8].Byte[4],vtInteger + MOV EBX,[EBX+EAX*8] + JE @B4 + XOR EBX,EBX +@B4: CMP ESI,ECX + JE @B2 + LODSB +@B5: RET + +@Convert: + AND AL,0DFH + MOV CL,AL + MOV EAX,1 + MOV EBX,ArgIndex + CMP EBX,Args.Integer[-4] + JG @ErrorExit + INC ArgIndex + MOV ESI,Args + LEA ESI,[ESI+EBX*8] + MOV EAX,[ESI].Integer[0] // TVarRec.data + MOVZX EDX,[ESI].Byte[4] // TVarRec.VType +{$IFDEF PIC} + MOV EBX, SaveGOT + ADD EBX, offset @CvtVector + MOV EBX, [EBX+EDX*4] + ADD EBX, SaveGOT + JMP EBX +{$ELSE} + JMP @CvtVector.Pointer[EDX*4] +{$ENDIF} + +@CvtVector: + DD @CvtInteger // vtInteger + DD @CvtBoolean // vtBoolean + DD @CvtChar // vtChar + DD @CvtExtended // vtExtended + DD @CvtShortStr // vtString + DD @CvtPointer // vtPointer + DD @CvtPChar // vtPChar + DD @CvtObject // vtObject + DD @CvtClass // vtClass + DD @CvtWideChar // vtWideChar + DD @CvtPWideChar // vtPWideChar + DD @CvtAnsiStr // vtAnsiString + DD @CvtCurrency // vtCurrency + DD @CvtVariant // vtVariant + DD @CvtInterface // vtInterface + DD @CvtWideString // vtWideString + DD @CvtInt64 // vtInt64 + +@CvtBoolean: +@CvtObject: +@CvtClass: +@CvtWideChar: +@CvtInterface: +@CvtError: + XOR EAX,EAX + +@ErrorExit: + CALL @ClearTmpAnsiStr + MOV EDX,FormatOrg + MOV ECX,FormatPtr + SUB ECX,EDX +{$IFDEF PC_MAPPED_EXCEPTIONS} + // Because of all the assembly code here, we can't call a routine + // that throws an exception if it looks like we're still on the + // stack. The static disassembler cannot give sufficient unwind + // frame info to unwind the confusion that is generated from the + // assembly code above. So before we throw the exception, we + // go to some lengths to excise ourselves from the stack chain. + // We were passed 12 bytes of parameters on the stack, and we have + // to make sure that we get rid of those, too. + MOV EBX, SaveGOT + MOV ESP, EBP // Ditch everthing to the frame + MOV EBP, [ESP + 4] // Get the return addr + MOV [ESP + 16], EBP // Move the ret addr up in the stack + POP EBP // Ditch the rest of the frame + ADD ESP, 12 // Ditch the space that was taken by params + JMP FormatError // Off to FormatErr +{$ELSE} + MOV EBX, SaveGOT + CALL FormatError +{$ENDIF} + // The above call raises an exception and does not return + +@CvtInt64: + // CL <= format character + // EAX <= address of int64 + // EBX <= TVarRec.VType + + LEA ESI,StrBuf[32] + MOV EDX, Prec + CMP EDX, 32 + JBE @I64_1 // zero padded field width > buffer => no padding + XOR EDX, EDX +@I64_1: MOV EBX, ECX + SUB CL, 'D' + JZ CvtInt64 // branch predict backward jump taken + MOV ECX, 16 + CMP BL, 'X' + JE CvtInt64 + MOV ECX, 10 + CMP BL, 'U' + JE CvtInt64 + JMP @CvtError + +{ LEA EBX, TempInt64 // (input is array of const; save original) + MOV EDX, [EAX] + MOV [EBX], EDX + MOV EDX, [EAX + 4] + MOV [EBX + 4], EDX + + // EBX <= address of TempInt64 + + CMP CL,'D' + JE @DecI64 + CMP CL,'U' + JE @DecI64_2 + CMP CL,'X' + JNE @CvtError + +@HexI64: + MOV ECX,16 // hex divisor + JMP @CvtI64 + +@DecI64: + TEST DWORD PTR [EBX + 4], $80000000 // sign bit set? + JE @DecI64_2 // no -> bypass '-' output + + NEG DWORD PTR [EBX] // negate lo-order, then hi-order + ADC DWORD PTR [EBX+4], 0 + NEG DWORD PTR [EBX+4] + + CALL @DecI64_2 + + MOV AL,'-' + INC ECX + DEC ESI + MOV [ESI],AL + RET + +@DecI64_2: // unsigned int64 output + MOV ECX,10 // decimal divisor + +@CvtI64: + LEA ESI,StrBuf[32] + +@CvtI64_1: + PUSH EBX + PUSH ECX // save radix + PUSH 0 + PUSH ECX // radix divisor (10 or 16 only) + MOV EAX, [EBX] + MOV EDX, [EBX + 4] + MOV EBX, SaveGOT + CALL System.@_llumod + POP ECX // saved radix + POP EBX + + XCHG EAX, EDX // lo-value to EDX for character output + ADD DL,'0' + CMP DL,'0'+10 + JB @CvtI64_2 + + ADD DL,('A'-'0')-10 + +@CvtI64_2: + DEC ESI + MOV [ESI],DL + + PUSH EBX + PUSH ECX // save radix + PUSH 0 + PUSH ECX // radix divisor (10 or 16 only) + MOV EAX, [EBX] // value := value DIV radix + MOV EDX, [EBX + 4] + MOV EBX, SaveGOT + CALL System.@_lludiv + POP ECX // saved radix + POP EBX + MOV [EBX], EAX + MOV [EBX + 4], EDX + OR EAX,EDX // anything left to output? + JNE @CvtI64_1 // no jump => EDX:EAX = 0 + + LEA ECX,StrBuf[32] + SUB ECX,ESI + MOV EDX,Prec + CMP EDX,16 + JBE @CvtI64_3 + RET + +@CvtI64_3: + SUB EDX,ECX + JBE @CvtI64_5 + ADD ECX,EDX + MOV AL,'0' + +@CvtI64_4: + DEC ESI + MOV [ESI],AL + DEC EDX + JNE @CvtI64_4 + +@CvtI64_5: + RET +} +//////////////////////////////////////////////// + +@CvtInteger: + LEA ESI,StrBuf[16] + MOV EDX, Prec + MOV EBX, ECX + CMP EDX, 16 + JBE @C1 // zero padded field width > buffer => no padding + XOR EDX, EDX +@C1: SUB CL, 'D' + JZ CvtInt // branch predict backward jump taken + MOV ECX, 16 + CMP BL, 'X' + JE CvtInt + MOV ECX, 10 + CMP BL, 'U' + JE CvtInt + JMP @CvtError + +{ CMP CL,'D' + JE @C1 + CMP CL,'U' + JE @C2 + CMP CL,'X' + JNE @CvtError + MOV ECX,16 + JMP @CvtLong +@C1: OR EAX,EAX + JNS @C2 + NEG EAX + CALL @C2 + MOV AL,'-' + INC ECX + DEC ESI + MOV [ESI],AL + RET +@C2: MOV ECX,10 + +@CvtLong: + LEA ESI,StrBuf[16] +@D1: XOR EDX,EDX + DIV ECX + ADD DL,'0' + CMP DL,'0'+10 + JB @D2 + ADD DL,('A'-'0')-10 +@D2: DEC ESI + MOV [ESI],DL + OR EAX,EAX + JNE @D1 + LEA ECX,StrBuf[16] + SUB ECX,ESI + MOV EDX,Prec + CMP EDX,16 + JBE @D3 + RET +@D3: SUB EDX,ECX + JBE @D5 + ADD ECX,EDX + MOV AL,'0' +@D4: DEC ESI + MOV [ESI],AL + DEC EDX + JNE @D4 +@D5: RET +} +@CvtChar: + CMP CL,'S' + JNE @CvtError + MOV ECX,1 + RET + +@CvtVariant: + CMP CL,'S' + JNE @CvtError + CMP [EAX].TVarData.VType,varNull + JBE @CvtEmptyStr + MOV EDX,EAX + LEA EAX,TempStr +// PUSH EBX // GOT setup unnecessary for +// MOV EBX, SaveGOT // same-unit calls to Pascal procedures + CALL FormatVarToStr +// POP EBX + MOV ESI,TempStr + JMP @CvtStrRef + +@CvtEmptyStr: + XOR ECX,ECX + RET + +@CvtShortStr: + CMP CL,'S' + JNE @CvtError + MOV ESI,EAX + LODSB + MOVZX ECX,AL + JMP @CvtStrLen + +@CvtPWideChar: + MOV ESI,OFFSET System.@LStrFromPWChar + JMP @CvtWideThing + +@CvtWideString: + MOV ESI,OFFSET System.@LStrFromWStr + +@CvtWideThing: + ADD ESI, SaveGOT +{$IFDEF PIC} + MOV ESI, [ESI] +{$ENDIF} + CMP CL,'S' + JNE @CvtError + MOV EDX,EAX + LEA EAX,TempAnsiStr + PUSH EBX + MOV EBX, SaveGOT + CALL ESI + POP EBX + MOV ESI,TempAnsiStr + MOV EAX,ESI + JMP @CvtStrRef + +@CvtAnsiStr: + CMP CL,'S' + JNE @CvtError + MOV ESI,EAX + +@CvtStrRef: + OR ESI,ESI + JE @CvtEmptyStr + MOV ECX,[ESI-4] + +@CvtStrLen: + CMP ECX,Prec + JA @E1 + RET +@E1: MOV ECX,Prec + RET + +@CvtPChar: + CMP CL,'S' + JNE @CvtError + MOV ESI,EAX + PUSH EDI + MOV EDI,EAX + XOR AL,AL + MOV ECX,Prec + JECXZ @F1 + REPNE SCASB + JNE @F1 + DEC EDI +@F1: MOV ECX,EDI + SUB ECX,ESI + POP EDI + RET + +@CvtPointer: + CMP CL,'P' + JNE @CvtError + MOV EDX,8 + MOV ECX,16 + LEA ESI,StrBuf[16] + JMP CvtInt + +@CvtCurrency: + MOV BH,fvCurrency + JMP @CvtFloat + +@CvtExtended: + MOV BH,fvExtended + +@CvtFloat: + MOV ESI,EAX + MOV BL,ffGeneral + CMP CL,'G' + JE @G2 + MOV BL,ffExponent + CMP CL,'E' + JE @G2 + MOV BL,ffFixed + CMP CL,'F' + JE @G1 + MOV BL,ffNumber + CMP CL,'N' + JE @G1 + CMP CL,'M' + JNE @CvtError + MOV BL,ffCurrency +@G1: MOV EAX,18 + MOV EDX,Prec + CMP EDX,EAX + JBE @G3 + MOV EDX,2 + CMP CL,'M' + JNE @G3 + MOVZX EDX,CurrencyDecimals + JMP @G3 +@G2: MOV EAX,Prec + MOV EDX,3 + CMP EAX,18 + JBE @G3 + MOV EAX,15 +@G3: PUSH EBX + PUSH EAX + PUSH EDX + LEA EAX,StrBuf + MOV EDX,ESI + MOVZX ECX,BH + MOV EBX, SaveGOT + CALL FloatToText + MOV ECX,EAX + LEA ESI,StrBuf + RET + +@ClearTmpAnsiStr: + PUSH EBX + PUSH EAX + LEA EAX,TempAnsiStr + MOV EBX, SaveGOT + CALL System.@LStrClr + POP EAX + POP EBX + RET + +@Exit: + CALL @ClearTmpAnsiStr + POP EDI + POP ESI + POP EBX +end; + +function FormatBuf(var Buffer; BufLen: Cardinal; const Format; + FmtLen: Cardinal; const Args: array of const; + const FormatSettings: TFormatSettings): Cardinal; +var + ArgIndex, Width, Prec: Integer; + BufferOrg, FormatOrg, FormatPtr, TempStr: PChar; + JustFlag: Byte; + StrBuf: array[0..64] of Char; + TempAnsiStr: string; + SaveGOT: Integer; +{ in: eax <-> Buffer } +{ in: edx <-> BufLen } +{ in: ecx <-> Format } + +asm + PUSH EBX + PUSH ESI + PUSH EDI + MOV EDI,EAX + MOV ESI,ECX +{$IFDEF PIC} + PUSH ECX + CALL GetGOT + POP ECX +{$ELSE} + XOR EAX,EAX +{$ENDIF} + MOV SaveGOT,EAX + ADD ECX,FmtLen + MOV BufferOrg,EDI + XOR EAX,EAX + MOV ArgIndex,EAX + MOV TempStr,EAX + MOV TempAnsiStr,EAX + +@Loop: + OR EDX,EDX + JE @Done + +@NextChar: + CMP ESI,ECX + JE @Done + LODSB + CMP AL,'%' + JE @Format + +@StoreChar: + STOSB + DEC EDX + JNE @NextChar + +@Done: + MOV EAX,EDI + SUB EAX,BufferOrg + JMP @Exit + +@Format: + CMP ESI,ECX + JE @Done + LODSB + CMP AL,'%' + JE @StoreChar + LEA EBX,[ESI-2] + MOV FormatOrg,EBX +@A0: MOV JustFlag,AL + CMP AL,'-' + JNE @A1 + CMP ESI,ECX + JE @Done + LODSB +@A1: CALL @Specifier + CMP AL,':' + JNE @A2 + MOV ArgIndex,EBX + CMP ESI,ECX + JE @Done + LODSB + JMP @A0 + +@A2: MOV Width,EBX + MOV EBX,-1 + CMP AL,'.' + JNE @A3 + CMP ESI,ECX + JE @Done + LODSB + CALL @Specifier +@A3: MOV Prec,EBX + MOV FormatPtr,ESI + PUSH ECX + PUSH EDX + + CALL @Convert + + POP EDX + MOV EBX,Width + SUB EBX,ECX //(* ECX <=> number of characters output *) + JAE @A4 //(* jump -> output smaller than width *) + XOR EBX,EBX + +@A4: CMP JustFlag,'-' + JNE @A6 + SUB EDX,ECX + JAE @A5 + ADD ECX,EDX + XOR EDX,EDX + +@A5: REP MOVSB + +@A6: XCHG EBX,ECX + SUB EDX,ECX + JAE @A7 + ADD ECX,EDX + XOR EDX,EDX +@A7: MOV AL,' ' + REP STOSB + XCHG EBX,ECX + SUB EDX,ECX + JAE @A8 + ADD ECX,EDX + XOR EDX,EDX +@A8: REP MOVSB + CMP TempStr,0 + JE @A9 + PUSH EDX + LEA EAX,TempStr +// PUSH EBX // GOT setup unnecessary for +// MOV EBX, SaveGOT // same-unit calls to Pascal procedures + CALL FormatClearStr +// POP EBX + POP EDX +@A9: POP ECX + MOV ESI,FormatPtr + JMP @Loop + +@Specifier: + XOR EBX,EBX + CMP AL,'*' + JE @B3 +@B1: CMP AL,'0' + JB @B5 + CMP AL,'9' + JA @B5 + IMUL EBX,EBX,10 + SUB AL,'0' + MOVZX EAX,AL + ADD EBX,EAX + CMP ESI,ECX + JE @B2 + LODSB + JMP @B1 +@B2: POP EAX + JMP @Done +@B3: MOV EAX,ArgIndex + CMP EAX,Args.Integer[-4] + JG @B4 + INC ArgIndex + MOV EBX,Args + CMP [EBX+EAX*8].Byte[4],vtInteger + MOV EBX,[EBX+EAX*8] + JE @B4 + XOR EBX,EBX +@B4: CMP ESI,ECX + JE @B2 + LODSB +@B5: RET + +@Convert: + AND AL,0DFH + MOV CL,AL + MOV EAX,1 + MOV EBX,ArgIndex + CMP EBX,Args.Integer[-4] + JG @ErrorExit + INC ArgIndex + MOV ESI,Args + LEA ESI,[ESI+EBX*8] + MOV EAX,[ESI].Integer[0] // TVarRec.data + MOVZX EDX,[ESI].Byte[4] // TVarRec.VType +{$IFDEF PIC} + MOV EBX, SaveGOT + ADD EBX, offset @CvtVector + MOV EBX, [EBX+EDX*4] + ADD EBX, SaveGOT + JMP EBX +{$ELSE} + JMP @CvtVector.Pointer[EDX*4] +{$ENDIF} + +@CvtVector: + DD @CvtInteger // vtInteger + DD @CvtBoolean // vtBoolean + DD @CvtChar // vtChar + DD @CvtExtended // vtExtended + DD @CvtShortStr // vtString + DD @CvtPointer // vtPointer + DD @CvtPChar // vtPChar + DD @CvtObject // vtObject + DD @CvtClass // vtClass + DD @CvtWideChar // vtWideChar + DD @CvtPWideChar // vtPWideChar + DD @CvtAnsiStr // vtAnsiString + DD @CvtCurrency // vtCurrency + DD @CvtVariant // vtVariant + DD @CvtInterface // vtInterface + DD @CvtWideString // vtWideString + DD @CvtInt64 // vtInt64 + +@CvtBoolean: +@CvtObject: +@CvtClass: +@CvtWideChar: +@CvtInterface: +@CvtError: + XOR EAX,EAX + +@ErrorExit: + CALL @ClearTmpAnsiStr + MOV EDX,FormatOrg + MOV ECX,FormatPtr + SUB ECX,EDX +{$IFDEF PC_MAPPED_EXCEPTIONS} + // Because of all the assembly code here, we can't call a routine + // that throws an exception if it looks like we're still on the + // stack. The static disassembler cannot give sufficient unwind + // frame info to unwind the confusion that is generated from the + // assembly code above. So before we throw the exception, we + // go to some lengths to excise ourselves from the stack chain. + // We were passed 12 bytes of parameters on the stack, and we have + // to make sure that we get rid of those, too. + MOV EBX, SaveGOT + MOV ESP, EBP // Ditch everthing to the frame + MOV EBP, [ESP + 4] // Get the return addr + MOV [ESP + 16], EBP // Move the ret addr up in the stack + POP EBP // Ditch the rest of the frame + ADD ESP, 12 // Ditch the space that was taken by params + JMP FormatError // Off to FormatErr +{$ELSE} + MOV EBX, SaveGOT + CALL FormatError +{$ENDIF} + // The above call raises an exception and does not return + +@CvtInt64: + // CL <= format character + // EAX <= address of int64 + // EBX <= TVarRec.VType + + LEA ESI,StrBuf[32] + MOV EDX, Prec + CMP EDX, 32 + JBE @I64_1 // zero padded field width > buffer => no padding + XOR EDX, EDX +@I64_1: MOV EBX, ECX + SUB CL, 'D' + JZ CvtInt64 // branch predict backward jump taken + MOV ECX, 16 + CMP BL, 'X' + JE CvtInt64 + MOV ECX, 10 + CMP BL, 'U' + JE CvtInt64 + JMP @CvtError +//////////////////////////////////////////////// + +@CvtInteger: + LEA ESI,StrBuf[16] + MOV EDX, Prec + MOV EBX, ECX + CMP EDX, 16 + JBE @C1 // zero padded field width > buffer => no padding + XOR EDX, EDX +@C1: SUB CL, 'D' + JZ CvtInt // branch predict backward jump taken + MOV ECX, 16 + CMP BL, 'X' + JE CvtInt + MOV ECX, 10 + CMP BL, 'U' + JE CvtInt + JMP @CvtError + +@CvtChar: + CMP CL,'S' + JNE @CvtError + MOV ECX,1 + RET + +@CvtVariant: + CMP CL,'S' + JNE @CvtError + CMP [EAX].TVarData.VType,varNull + JBE @CvtEmptyStr + MOV EDX,EAX + LEA EAX,TempStr +// PUSH EBX // GOT setup unnecessary for +// MOV EBX, SaveGOT // same-unit calls to Pascal procedures + CALL FormatVarToStr +// POP EBX + MOV ESI,TempStr + JMP @CvtStrRef + +@CvtEmptyStr: + XOR ECX,ECX + RET + +@CvtShortStr: + CMP CL,'S' + JNE @CvtError + MOV ESI,EAX + LODSB + MOVZX ECX,AL + JMP @CvtStrLen + +@CvtPWideChar: + MOV ESI,OFFSET System.@LStrFromPWChar + JMP @CvtWideThing + +@CvtWideString: + MOV ESI,OFFSET System.@LStrFromWStr + +@CvtWideThing: + ADD ESI, SaveGOT +{$IFDEF PIC} + MOV ESI, [ESI] +{$ENDIF} + CMP CL,'S' + JNE @CvtError + MOV EDX,EAX + LEA EAX,TempAnsiStr + PUSH EBX + MOV EBX, SaveGOT + CALL ESI + POP EBX + MOV ESI,TempAnsiStr + MOV EAX,ESI + JMP @CvtStrRef + +@CvtAnsiStr: + CMP CL,'S' + JNE @CvtError + MOV ESI,EAX + +@CvtStrRef: + OR ESI,ESI + JE @CvtEmptyStr + MOV ECX,[ESI-4] + +@CvtStrLen: + CMP ECX,Prec + JA @E1 + RET +@E1: MOV ECX,Prec + RET + +@CvtPChar: + CMP CL,'S' + JNE @CvtError + MOV ESI,EAX + PUSH EDI + MOV EDI,EAX + XOR AL,AL + MOV ECX,Prec + JECXZ @F1 + REPNE SCASB + JNE @F1 + DEC EDI +@F1: MOV ECX,EDI + SUB ECX,ESI + POP EDI + RET + +@CvtPointer: + CMP CL,'P' + JNE @CvtError + MOV EDX,8 + MOV ECX,16 + LEA ESI,StrBuf[16] + JMP CvtInt + +@CvtCurrency: + MOV BH,fvCurrency + JMP @CvtFloat + +@CvtExtended: + MOV BH,fvExtended + +@CvtFloat: + MOV ESI,EAX + MOV BL,ffGeneral + CMP CL,'G' + JE @G2 + MOV BL,ffExponent + CMP CL,'E' + JE @G2 + MOV BL,ffFixed + CMP CL,'F' + JE @G1 + MOV BL,ffNumber + CMP CL,'N' + JE @G1 + CMP CL,'M' + JNE @CvtError + MOV BL,ffCurrency +@G1: MOV EAX,18 + MOV EDX,Prec + CMP EDX,EAX + JBE @G3 + MOV EDX,2 + CMP CL,'M' + JNE @G3 + MOV EDX,FormatSettings + MOVZX EDX,[EDX].TFormatSettings.CurrencyDecimals + JMP @G3 +@G2: MOV EAX,Prec + MOV EDX,3 + CMP EAX,18 + JBE @G3 + MOV EAX,15 +@G3: PUSH EBX + PUSH EAX + PUSH EDX + MOV EDX,[FormatSettings] + PUSH EDX + LEA EAX,StrBuf + MOV EDX,ESI + MOVZX ECX,BH + MOV EBX, SaveGOT + CALL FloatToTextEx + MOV ECX,EAX + LEA ESI,StrBuf + RET + +@ClearTmpAnsiStr: + PUSH EBX + PUSH EAX + LEA EAX,TempAnsiStr + MOV EBX, SaveGOT + CALL System.@LStrClr + POP EAX + POP EBX + RET + +@Exit: + CALL @ClearTmpAnsiStr + POP EDI + POP ESI + POP EBX +end; + +function StrFmt(Buffer, Format: PChar; const Args: array of const): PChar; +begin + if (Buffer <> nil) and (Format <> nil) then + begin + Buffer[FormatBuf(Buffer^, MaxInt, Format^, StrLen(Format), Args)] := #0; + Result := Buffer; + end + else + Result := nil; +end; + +function StrFmt(Buffer, Format: PChar; const Args: array of const; + const FormatSettings: TFormatSettings): PChar; +begin + if (Buffer <> nil) and (Format <> nil) then + begin + Buffer[FormatBuf(Buffer^, MaxInt, Format^, StrLen(Format), Args, + FormatSettings)] := #0; + Result := Buffer; + end + else + Result := nil; +end; + +function StrLFmt(Buffer: PChar; MaxBufLen: Cardinal; Format: PChar; + const Args: array of const): PChar; +begin + if (Buffer <> nil) and (Format <> nil) then + begin + Buffer[FormatBuf(Buffer^, MaxBufLen, Format^, StrLen(Format), Args)] := #0; + Result := Buffer; + end + else + Result := nil; +end; + +function StrLFmt(Buffer: PChar; MaxBufLen: Cardinal; Format: PChar; + const Args: array of const; const FormatSettings: TFormatSettings): PChar; +begin + if (Buffer <> nil) and (Format <> nil) then + begin + Buffer[FormatBuf(Buffer^, MaxBufLen, Format^, StrLen(Format), Args, + FormatSettings)] := #0; + Result := Buffer; + end + else + Result := nil; +end; + +function Format(const Format: string; const Args: array of const): string; +begin + FmtStr(Result, Format, Args); +end; + +function Format(const Format: string; const Args: array of const; + const FormatSettings: TFormatSettings): string; +begin + FmtStr(Result, Format, Args, FormatSettings); +end; + +procedure FmtStr(var Result: string; const Format: string; + const Args: array of const); +var + Len, BufLen: Integer; + Buffer: array[0..4095] of Char; +begin + BufLen := SizeOf(Buffer); + if Length(Format) < (sizeof(Buffer) - (sizeof(Buffer) div 4)) then + Len := FormatBuf(Buffer, sizeof(Buffer) - 1, Pointer(Format)^, Length(Format), Args) + else + begin + BufLen := Length(Format); + Len := BufLen; + end; + if Len >= BufLen - 1 then + begin + while Len >= BufLen - 1 do + begin + Inc(BufLen, BufLen); + Result := ''; // prevent copying of existing data, for speed + SetLength(Result, BufLen); + Len := FormatBuf(Pointer(Result)^, BufLen - 1, Pointer(Format)^, + Length(Format), Args); + end; + SetLength(Result, Len); + end + else + SetString(Result, Buffer, Len); +end; + +procedure FmtStr(var Result: string; const Format: string; + const Args: array of const; const FormatSettings: TFormatSettings); +var + Len, BufLen: Integer; + Buffer: array[0..4095] of Char; +begin + BufLen := SizeOf(Buffer); + if Length(Format) < (sizeof(Buffer) - (sizeof(Buffer) div 4)) then + Len := FormatBuf(Buffer, sizeof(Buffer) - 1, Pointer(Format)^, Length(Format), + Args, FormatSettings) + else + begin + BufLen := Length(Format); + Len := BufLen; + end; + if Len >= BufLen - 1 then + begin + while Len >= BufLen - 1 do + begin + Inc(BufLen, BufLen); + Result := ''; // prevent copying of existing data, for speed + SetLength(Result, BufLen); + Len := FormatBuf(Pointer(Result)^, BufLen - 1, Pointer(Format)^, + Length(Format), Args, FormatSettings); + end; + SetLength(Result, Len); + end + else + SetString(Result, Buffer, Len); +end; + +procedure WideFormatError(ErrorCode: Integer; Format: PWideChar; + FmtLen: Cardinal); +var + WideFormat: WideString; + FormatText: string; +begin + SetLength(WideFormat, FmtLen); + SetString(WideFormat, Format, FmtLen); + FormatText := WideFormat; + FormatError(ErrorCode, PChar(FormatText), FmtLen); +end; + +procedure WideFormatVarToStr(var S: WideString; const V: TVarData); +begin + {if Assigned(System.VarToWStrProc) then + System.VarToWStrProc(S, V) + else + System.Error(reVarInvalidOp); } + S:='Cutted'; +end; + +function WideFormatBuf(var Buffer; BufLen: Cardinal; const Format; + FmtLen: Cardinal; const Args: array of const): Cardinal; +var + ArgIndex, Width, Prec: Integer; + BufferOrg, FormatOrg, FormatPtr: PWideChar; + JustFlag: WideChar; + StrBuf: array[0..64] of WideChar; + TempWideStr: WideString; + SaveGOT: Integer; +{ in: eax <-> Buffer } +{ in: edx <-> BufLen } +{ in: ecx <-> Format } + +asm + PUSH EBX + PUSH ESI + PUSH EDI + MOV EDI,EAX + MOV ESI,ECX +{$IFDEF PIC} + CALL GetGOT +{$ELSE} + XOR EAX,EAX +{$ENDIF} + MOV SaveGOT,EAX + MOV ECX,FmtLen + LEA ECX,[ECX*2+ESI] + MOV BufferOrg,EDI + XOR EAX,EAX + MOV ArgIndex,EAX + MOV TempWideStr,EAX + +@Loop: + OR EDX,EDX + JE @Done + +@NextChar: + CMP ESI,ECX + JE @Done + LODSW + CMP AX,'%' + JE @Format + +@StoreChar: + STOSW + DEC EDX + JNE @NextChar + +@Done: + MOV EAX,EDI + SUB EAX,BufferOrg + SHR EAX,1 + JMP @Exit + +@Format: + CMP ESI,ECX + JE @Done + LODSW + CMP AX,'%' + JE @StoreChar + LEA EBX,[ESI-4] + MOV FormatOrg,EBX +@A0: MOV JustFlag,AX + CMP AX,'-' + JNE @A1 + CMP ESI,ECX + JE @Done + LODSW +@A1: CALL @Specifier + CMP AX,':' + JNE @A2 + MOV ArgIndex,EBX + CMP ESI,ECX + JE @Done + LODSW + JMP @A0 + +@A2: MOV Width,EBX + MOV EBX,-1 + CMP AX,'.' + JNE @A3 + CMP ESI,ECX + JE @Done + LODSW + CALL @Specifier +@A3: MOV Prec,EBX + MOV FormatPtr,ESI + PUSH ECX + PUSH EDX + + CALL @Convert + + POP EDX + MOV EBX,Width + SUB EBX,ECX //(* ECX <=> number of characters output *) + JAE @A4 //(* jump -> output smaller than width *) + XOR EBX,EBX + +@A4: CMP JustFlag,'-' + JNE @A6 + SUB EDX,ECX + JAE @A5 + ADD ECX,EDX + XOR EDX,EDX + +@A5: REP MOVSW + +@A6: XCHG EBX,ECX + SUB EDX,ECX + JAE @A7 + ADD ECX,EDX + XOR EDX,EDX +@A7: MOV AX,' ' + REP STOSW + XCHG EBX,ECX + SUB EDX,ECX + JAE @A8 + ADD ECX,EDX + XOR EDX,EDX +@A8: REP MOVSW + POP ECX + MOV ESI,FormatPtr + JMP @Loop + +@Specifier: + XOR EBX,EBX + CMP AX,'*' + JE @B3 +@B1: CMP AX,'0' + JB @B5 + CMP AX,'9' + JA @B5 + IMUL EBX,EBX,10 + SUB AX,'0' + MOVZX EAX,AX + ADD EBX,EAX + CMP ESI,ECX + JE @B2 + LODSW + JMP @B1 +@B2: POP EAX + JMP @Done +@B3: MOV EAX,ArgIndex + CMP EAX,Args.Integer[-4] + JG @B4 + INC ArgIndex + MOV EBX,Args + CMP [EBX+EAX*8].Byte[4],vtInteger + MOV EBX,[EBX+EAX*8] + JE @B4 + XOR EBX,EBX +@B4: CMP ESI,ECX + JE @B2 + LODSW +@B5: RET + +@Convert: + AND AL,0DFH + MOV CL,AL + MOV EAX,1 + MOV EBX,ArgIndex + CMP EBX,Args.Integer[-4] + JG @ErrorExit + INC ArgIndex + MOV ESI,Args + LEA ESI,[ESI+EBX*8] + MOV EAX,[ESI].Integer[0] // TVarRec.data + MOVZX EDX,[ESI].Byte[4] // TVarRec.VType +{$IFDEF PIC} + MOV EBX, SaveGOT + ADD EBX, offset @CvtVector + MOV EBX, [EBX+EDX*4] + ADD EBX, SaveGOT + JMP EBX +{$ELSE} + JMP @CvtVector.Pointer[EDX*4] +{$ENDIF} + +@CvtVector: + DD @CvtInteger // vtInteger + DD @CvtBoolean // vtBoolean + DD @CvtChar // vtChar + DD @CvtExtended // vtExtended + DD @CvtShortStr // vtString + DD @CvtPointer // vtPointer + DD @CvtPChar // vtPChar + DD @CvtObject // vtObject + DD @CvtClass // vtClass + DD @CvtWideChar // vtWideChar + DD @CvtPWideChar // vtPWideChar + DD @CvtAnsiStr // vtAnsiString + DD @CvtCurrency // vtCurrency + DD @CvtVariant // vtVariant + DD @CvtInterface // vtInterface + DD @CvtWideString // vtWideString + DD @CvtInt64 // vtInt64 + +@CvtBoolean: +@CvtObject: +@CvtClass: +@CvtInterface: +@CvtError: + XOR EAX,EAX + +@ErrorExit: + CALL @ClearTmpWideStr + MOV EDX,FormatOrg + MOV ECX,FormatPtr + SUB ECX,EDX + SHR ECX,1 + MOV EBX, SaveGOT +{$IFDEF PC_MAPPED_EXCEPTIONS} + // Because of all the assembly code here, we can't call a routine + // that throws an exception if it looks like we're still on the + // stack. The static disassembler cannot give sufficient unwind + // frame info to unwind the confusion that is generated from the + // assembly code above. So before we throw the exception, we + // go to some lengths to excise ourselves from the stack chain. + // We were passed 12 bytes of parameters on the stack, and we have + // to make sure that we get rid of those, too. + MOV ESP, EBP // Ditch everthing to the frame + MOV EBP, [ESP + 4] // Get the return addr + MOV [ESP + 16], EBP // Move the ret addr up in the stack + POP EBP // Ditch the rest of the frame + ADD ESP, 12 // Ditch the space that was taken by params + JMP WideFormatError // Off to FormatErr +{$ELSE} + CALL WideFormatError +{$ENDIF} + // The above call raises an exception and does not return + +@CvtInt64: + // CL <= format character + // EAX <= address of int64 + // EBX <= TVarRec.VType + + LEA ESI,StrBuf[64] + MOV EDX, Prec + CMP EDX, 32 + JBE @I64_1 // zero padded field width > buffer => no padding + XOR EDX, EDX +@I64_1: MOV EBX, ECX + SUB CL, 'D' + JZ CvtInt64W // branch predict backward jump taken + MOV ECX, 16 + CMP BL, 'X' + JE CvtInt64W + MOV ECX, 10 + CMP BL, 'U' + JE CvtInt64W + JMP @CvtError + +@CvtInteger: + LEA ESI,StrBuf[32] + MOV EDX, Prec + MOV EBX, ECX + CMP EDX, 16 + JBE @C1 // zero padded field width > buffer => no padding + XOR EDX, EDX +@C1: SUB CL, 'D' + JZ CvtIntW // branch predict backward jump taken + MOV ECX, 16 + CMP BL, 'X' + JE CvtIntW + MOV ECX, 10 + CMP BL, 'U' + JE CvtIntW + JMP @CvtError + +@CvtChar: + CMP CL,'S' + JNE @CvtError + MOV EAX,ESI + MOV ECX,1 + JMP @CvtAnsiThingLen + +@CvtWideChar: + CMP CL,'S' + JNE @CvtError + MOV ECX,1 + RET + +@CvtVariant: + CMP CL,'S' + JNE @CvtError + CMP [EAX].TVarData.VType,varNull + JBE @CvtEmptyStr + MOV EDX,EAX + LEA EAX,TempWideStr + CALL WideFormatVarToStr + MOV ESI,TempWideStr + JMP @CvtWideStrRef + +@CvtEmptyStr: + XOR ECX,ECX + RET + +@CvtShortStr: + CMP CL,'S' + JNE @CvtError + MOVZX ECX,BYTE PTR [EAX] + INC EAX + +@CvtAnsiThingLen: + MOV ESI,OFFSET System.@WStrFromPCharLen + JMP @CvtAnsiThing + +@CvtPChar: + MOV ESI,OFFSET System.@WStrFromPChar + JMP @CvtAnsiThingTest + +@CvtAnsiStr: + MOV ESI,OFFSET System.@WStrFromLStr + +@CvtAnsiThingTest: + CMP CL,'S' + JNE @CvtError + +@CvtAnsiThing: + ADD ESI, SaveGOT +{$IFDEF PIC} + MOV ESI, [ESI] +{$ENDIF} + MOV EDX,EAX + LEA EAX,TempWideStr + PUSH EBX + MOV EBX, SaveGOT + CALL ESI + POP EBX + MOV ESI,TempWideStr + JMP @CvtWideStrRef + +@CvtWideString: + CMP CL,'S' + JNE @CvtError + MOV ESI,EAX + +@CvtWideStrRef: + OR ESI,ESI + JE @CvtEmptyStr + MOV ECX,[ESI-4] + SHR ECX,1 + +@CvtWideStrLen: + CMP ECX,Prec + JA @E1 + RET +@E1: MOV ECX,Prec + RET + +@CvtPWideChar: + CMP CL,'S' + JNE @CvtError + MOV ESI,EAX + PUSH EDI + MOV EDI,EAX + XOR EAX,EAX + MOV ECX,Prec + JECXZ @F1 + REPNE SCASW + JNE @F1 + DEC EDI + DEC EDI +@F1: MOV ECX,EDI + SUB ECX,ESI + SHR ECX,1 + POP EDI + RET + +@CvtPointer: + CMP CL,'P' + JNE @CvtError + MOV EDX,8 + MOV ECX,16 + LEA ESI,StrBuf[32] + JMP CvtInt + +@CvtCurrency: + MOV BH,fvCurrency + JMP @CvtFloat + +@CvtExtended: + MOV BH,fvExtended + +@CvtFloat: + MOV ESI,EAX + MOV BL,ffGeneral + CMP CL,'G' + JE @G2 + MOV BL,ffExponent + CMP CL,'E' + JE @G2 + MOV BL,ffFixed + CMP CL,'F' + JE @G1 + MOV BL,ffNumber + CMP CL,'N' + JE @G1 + CMP CL,'M' + JNE @CvtError + MOV BL,ffCurrency +@G1: MOV EAX,18 + MOV EDX,Prec + CMP EDX,EAX + JBE @G3 + MOV EDX,2 + CMP CL,'M' + JNE @G3 + MOVZX EDX,CurrencyDecimals + JMP @G3 +@G2: MOV EAX,Prec + MOV EDX,3 + CMP EAX,18 + JBE @G3 + MOV EAX,15 +@G3: PUSH EBX + PUSH EAX + PUSH EDX + LEA EAX,StrBuf + MOV EDX,ESI + MOVZX ECX,BH + MOV EBX, SaveGOT + CALL FloatToText + MOV ECX,EAX + LEA EDX,StrBuf + LEA EAX,TempWideStr + MOV EBX, SaveGOT + CALL System.@WStrFromPCharLen + MOV ESI,TempWideStr + OR ESI,ESI + JE @CvtEmptyStr + MOV ECX,[ESI-4] + SHR ECX,1 + RET + +@ClearTmpWideStr: + PUSH EBX + PUSH EAX + LEA EAX,TempWideStr + MOV EBX, SaveGOT + CALL System.@WStrClr + POP EAX + POP EBX + RET + +@Exit: + CALL @ClearTmpWideStr + POP EDI + POP ESI + POP EBX +end; + +function WideFormatBuf(var Buffer; BufLen: Cardinal; const Format; + FmtLen: Cardinal; const Args: array of const; + const FormatSettings: TFormatSettings): Cardinal; +var + ArgIndex, Width, Prec: Integer; + BufferOrg, FormatOrg, FormatPtr: PWideChar; + JustFlag: WideChar; + StrBuf: array[0..64] of WideChar; + TempWideStr: WideString; + SaveGOT: Integer; +{ in: eax <-> Buffer } +{ in: edx <-> BufLen } +{ in: ecx <-> Format } + +asm + PUSH EBX + PUSH ESI + PUSH EDI + MOV EDI,EAX + MOV ESI,ECX +{$IFDEF PIC} + CALL GetGOT +{$ELSE} + XOR EAX,EAX +{$ENDIF} + MOV SaveGOT,EAX + MOV ECX,FmtLen + LEA ECX,[ECX*2+ESI] + MOV BufferOrg,EDI + XOR EAX,EAX + MOV ArgIndex,EAX + MOV TempWideStr,EAX + +@Loop: + OR EDX,EDX + JE @Done + +@NextChar: + CMP ESI,ECX + JE @Done + LODSW + CMP AX,'%' + JE @Format + +@StoreChar: + STOSW + DEC EDX + JNE @NextChar + +@Done: + MOV EAX,EDI + SUB EAX,BufferOrg + SHR EAX,1 + JMP @Exit + +@Format: + CMP ESI,ECX + JE @Done + LODSW + CMP AX,'%' + JE @StoreChar + LEA EBX,[ESI-4] + MOV FormatOrg,EBX +@A0: MOV JustFlag,AX + CMP AX,'-' + JNE @A1 + CMP ESI,ECX + JE @Done + LODSW +@A1: CALL @Specifier + CMP AX,':' + JNE @A2 + MOV ArgIndex,EBX + CMP ESI,ECX + JE @Done + LODSW + JMP @A0 + +@A2: MOV Width,EBX + MOV EBX,-1 + CMP AX,'.' + JNE @A3 + CMP ESI,ECX + JE @Done + LODSW + CALL @Specifier +@A3: MOV Prec,EBX + MOV FormatPtr,ESI + PUSH ECX + PUSH EDX + + CALL @Convert + + POP EDX + MOV EBX,Width + SUB EBX,ECX //(* ECX <=> number of characters output *) + JAE @A4 //(* jump -> output smaller than width *) + XOR EBX,EBX + +@A4: CMP JustFlag,'-' + JNE @A6 + SUB EDX,ECX + JAE @A5 + ADD ECX,EDX + XOR EDX,EDX + +@A5: REP MOVSW + +@A6: XCHG EBX,ECX + SUB EDX,ECX + JAE @A7 + ADD ECX,EDX + XOR EDX,EDX +@A7: MOV AX,' ' + REP STOSW + XCHG EBX,ECX + SUB EDX,ECX + JAE @A8 + ADD ECX,EDX + XOR EDX,EDX +@A8: REP MOVSW + POP ECX + MOV ESI,FormatPtr + JMP @Loop + +@Specifier: + XOR EBX,EBX + CMP AX,'*' + JE @B3 +@B1: CMP AX,'0' + JB @B5 + CMP AX,'9' + JA @B5 + IMUL EBX,EBX,10 + SUB AX,'0' + MOVZX EAX,AX + ADD EBX,EAX + CMP ESI,ECX + JE @B2 + LODSW + JMP @B1 +@B2: POP EAX + JMP @Done +@B3: MOV EAX,ArgIndex + CMP EAX,Args.Integer[-4] + JG @B4 + INC ArgIndex + MOV EBX,Args + CMP [EBX+EAX*8].Byte[4],vtInteger + MOV EBX,[EBX+EAX*8] + JE @B4 + XOR EBX,EBX +@B4: CMP ESI,ECX + JE @B2 + LODSW +@B5: RET + +@Convert: + AND AL,0DFH + MOV CL,AL + MOV EAX,1 + MOV EBX,ArgIndex + CMP EBX,Args.Integer[-4] + JG @ErrorExit + INC ArgIndex + MOV ESI,Args + LEA ESI,[ESI+EBX*8] + MOV EAX,[ESI].Integer[0] // TVarRec.data + MOVZX EDX,[ESI].Byte[4] // TVarRec.VType +{$IFDEF PIC} + MOV EBX, SaveGOT + ADD EBX, offset @CvtVector + MOV EBX, [EBX+EDX*4] + ADD EBX, SaveGOT + JMP EBX +{$ELSE} + JMP @CvtVector.Pointer[EDX*4] +{$ENDIF} + +@CvtVector: + DD @CvtInteger // vtInteger + DD @CvtBoolean // vtBoolean + DD @CvtChar // vtChar + DD @CvtExtended // vtExtended + DD @CvtShortStr // vtString + DD @CvtPointer // vtPointer + DD @CvtPChar // vtPChar + DD @CvtObject // vtObject + DD @CvtClass // vtClass + DD @CvtWideChar // vtWideChar + DD @CvtPWideChar // vtPWideChar + DD @CvtAnsiStr // vtAnsiString + DD @CvtCurrency // vtCurrency + DD @CvtVariant // vtVariant + DD @CvtInterface // vtInterface + DD @CvtWideString // vtWideString + DD @CvtInt64 // vtInt64 + +@CvtBoolean: +@CvtObject: +@CvtClass: +@CvtInterface: +@CvtError: + XOR EAX,EAX + +@ErrorExit: + CALL @ClearTmpWideStr + MOV EDX,FormatOrg + MOV ECX,FormatPtr + SUB ECX,EDX + SHR ECX,1 + MOV EBX, SaveGOT +{$IFDEF PC_MAPPED_EXCEPTIONS} + // Because of all the assembly code here, we can't call a routine + // that throws an exception if it looks like we're still on the + // stack. The static disassembler cannot give sufficient unwind + // frame info to unwind the confusion that is generated from the + // assembly code above. So before we throw the exception, we + // go to some lengths to excise ourselves from the stack chain. + // We were passed 12 bytes of parameters on the stack, and we have + // to make sure that we get rid of those, too. + MOV ESP, EBP // Ditch everthing to the frame + MOV EBP, [ESP + 4] // Get the return addr + MOV [ESP + 16], EBP // Move the ret addr up in the stack + POP EBP // Ditch the rest of the frame + ADD ESP, 12 // Ditch the space that was taken by params + JMP WideFormatError // Off to FormatErr +{$ELSE} + CALL WideFormatError +{$ENDIF} + // The above call raises an exception and does not return + +@CvtInt64: + // CL <= format character + // EAX <= address of int64 + // EBX <= TVarRec.VType + + LEA ESI,StrBuf[64] + MOV EDX,Prec + CMP EDX, 32 + JBE @I64_1 // zero padded field width > buffer => no padding + XOR EDX, EDX +@I64_1: MOV EBX, ECX + SUB CL, 'D' + JZ CvtInt64W // branch predict backward jump taken + MOV ECX,16 + CMP BL, 'X' + JE CvtInt64W + MOV ECX, 10 + CMP BL, 'U' + JE CvtInt64W + JMP @CvtError + +@CvtInteger: + LEA ESI,StrBuf[32] + MOV EDX,Prec + MOV EBX, ECX + CMP EDX,16 + JBE @C1 // zero padded field width > buffer => no padding + XOR EDX, EDX +@C1: SUB CL, 'D' + JZ CvtIntW // branch predict backward jump taken + MOV ECX, 16 + CMP BL, 'X' + JE CvtIntW + MOV ECX, 10 + CMP BL, 'U' + JE CvtIntW + JMP @CvtError + +@CvtChar: + CMP CL,'S' + JNE @CvtError + MOV EAX,ESI + MOV ECX,1 + JMP @CvtAnsiThingLen + +@CvtWideChar: + CMP CL,'S' + JNE @CvtError + MOV ECX,1 + RET + +@CvtVariant: + CMP CL,'S' + JNE @CvtError + CMP [EAX].TVarData.VType,varNull + JBE @CvtEmptyStr + MOV EDX,EAX + LEA EAX,TempWideStr + CALL WideFormatVarToStr + MOV ESI,TempWideStr + JMP @CvtWideStrRef + +@CvtEmptyStr: + XOR ECX,ECX + RET + +@CvtShortStr: + CMP CL,'S' + JNE @CvtError + MOVZX ECX,BYTE PTR [EAX] + INC EAX + +@CvtAnsiThingLen: + MOV ESI,OFFSET System.@WStrFromPCharLen + JMP @CvtAnsiThing + +@CvtPChar: + MOV ESI,OFFSET System.@WStrFromPChar + JMP @CvtAnsiThingTest + +@CvtAnsiStr: + MOV ESI,OFFSET System.@WStrFromLStr + +@CvtAnsiThingTest: + CMP CL,'S' + JNE @CvtError + +@CvtAnsiThing: + ADD ESI, SaveGOT +{$IFDEF PIC} + MOV ESI, [ESI] +{$ENDIF} + MOV EDX,EAX + LEA EAX,TempWideStr + PUSH EBX + MOV EBX, SaveGOT + CALL ESI + POP EBX + MOV ESI,TempWideStr + JMP @CvtWideStrRef + +@CvtWideString: + CMP CL,'S' + JNE @CvtError + MOV ESI,EAX + +@CvtWideStrRef: + OR ESI,ESI + JE @CvtEmptyStr + MOV ECX,[ESI-4] + SHR ECX,1 + +@CvtWideStrLen: + CMP ECX,Prec + JA @E1 + RET +@E1: MOV ECX,Prec + RET + +@CvtPWideChar: + CMP CL,'S' + JNE @CvtError + MOV ESI,EAX + PUSH EDI + MOV EDI,EAX + XOR EAX,EAX + MOV ECX,Prec + JECXZ @F1 + REPNE SCASW + JNE @F1 + DEC EDI + DEC EDI +@F1: MOV ECX,EDI + SUB ECX,ESI + SHR ECX,1 + POP EDI + RET + +@CvtPointer: + CMP CL,'P' + JNE @CvtError + MOV EDX,8 + MOV ECX,16 + LEA ESI,StrBuf[32] + JMP CvtInt + +@CvtCurrency: + MOV BH,fvCurrency + JMP @CvtFloat + +@CvtExtended: + MOV BH,fvExtended + +@CvtFloat: + MOV ESI,EAX + MOV BL,ffGeneral + CMP CL,'G' + JE @G2 + MOV BL,ffExponent + CMP CL,'E' + JE @G2 + MOV BL,ffFixed + CMP CL,'F' + JE @G1 + MOV BL,ffNumber + CMP CL,'N' + JE @G1 + CMP CL,'M' + JNE @CvtError + MOV BL,ffCurrency +@G1: MOV EAX,18 + MOV EDX,Prec + CMP EDX,EAX + JBE @G3 + MOV EDX,2 + CMP CL,'M' + JNE @G3 + MOV EDX,FormatSettings + MOVZX EDX,[EDX].TFormatSettings.CurrencyDecimals + JMP @G3 +@G2: MOV EAX,Prec + MOV EDX,3 + CMP EAX,18 + JBE @G3 + MOV EAX,15 +@G3: PUSH EBX + PUSH EAX + PUSH EDX + MOV EDX,[FormatSettings] + PUSH EDX + LEA EAX,StrBuf + MOV EDX,ESI + MOVZX ECX,BH + MOV EBX, SaveGOT + CALL FloatToTextEx + MOV ECX,EAX + LEA EDX,StrBuf + LEA EAX,TempWideStr + MOV EBX, SaveGOT + CALL System.@WStrFromPCharLen + MOV ESI,TempWideStr + OR ESI,ESI + JE @CvtEmptyStr + MOV ECX,[ESI-4] + SHR ECX,1 + RET + +@ClearTmpWideStr: + PUSH EBX + PUSH EAX + LEA EAX,TempWideStr + MOV EBX, SaveGOT + CALL System.@WStrClr + POP EAX + POP EBX + RET + +@Exit: + CALL @ClearTmpWideStr + POP EDI + POP ESI + POP EBX +end; + +procedure WideFmtStr(var Result: WideString; const Format: WideString; + const Args: array of const); +const + BufSize = 2048; +var + Len, BufLen: Integer; + Buffer: array[0..BufSize-1] of WideChar; +begin + if Length(Format) < (BufSize - (BufSize div 4)) then + begin + BufLen := BufSize; + Len := WideFormatBuf(Buffer, BufSize - 1, Pointer(Format)^, Length(Format), Args); + if Len < BufLen - 1 then + begin + SetString(Result, Buffer, Len); + Exit; + end; + end + else + begin + BufLen := Length(Format); + Len := BufLen; + end; + + while Len >= BufLen - 1 do + begin + Inc(BufLen, BufLen); + Result := ''; // prevent copying of existing data, for speed + SetLength(Result, BufLen); + Len := WideFormatBuf(Pointer(Result)^, BufLen - 1, Pointer(Format)^, + Length(Format), Args); + end; + SetLength(Result, Len); +end; + +procedure WideFmtStr(var Result: WideString; const Format: WideString; + const Args: array of const; const FormatSettings: TFormatSettings); +const + BufSize = 2048; +var + Len, BufLen: Integer; + Buffer: array[0..BufSize-1] of WideChar; +begin + if Length(Format) < (BufSize - (BufSize div 4)) then + begin + BufLen := BufSize; + Len := WideFormatBuf(Buffer, BufSize - 1, Pointer(Format)^, + Length(Format), Args, FormatSettings); + if Len < BufLen - 1 then + begin + SetString(Result, Buffer, Len); + Exit; + end; + end + else + begin + BufLen := Length(Format); + Len := BufLen; + end; + + while Len >= BufLen - 1 do + begin + Inc(BufLen, BufLen); + Result := ''; // prevent copying of existing data, for speed + SetLength(Result, BufLen); + Len := WideFormatBuf(Pointer(Result)^, BufLen - 1, Pointer(Format)^, + Length(Format), Args, FormatSettings); + end; + SetLength(Result, Len); +end; + +function WideFormat(const Format: WideString; const Args: array of const): WideString; +begin + WideFmtStr(Result, Format, Args); +end; + +function WideFormat(const Format: WideString; const Args: array of const; + const FormatSettings: TFormatSettings): WideString; +begin + WideFmtStr(Result, Format, Args, FormatSettings); +end; + +{ Floating point conversion routines } + +const + // 1E18 as a 64-bit integer + Const1E18Lo = $0A7640000; + Const1E18Hi = $00DE0B6B3; + FCon1E18: Extended = 1E18; + DCon10: Integer = 10; + +procedure PutExponent; +// Store exponent +// In AL = Exponent character ('E' or 'e') +// AH = Positive sign character ('+' or 0) +// BL = Zero indicator +// ECX = Minimum number of digits (0..4) +// EDX = Exponent +// EDI = Destination buffer +asm + PUSH ESI +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + MOV ESI,EAX + POP ECX + POP EAX +{$ELSE} + XOR ESI,ESI +{$ENDIF} + STOSB + OR BL,BL + JNE @@0 + XOR EDX,EDX + JMP @@1 +@@0: OR EDX,EDX + JGE @@1 + MOV AL,'-' + NEG EDX + JMP @@2 +@@1: OR AH,AH + JE @@3 + MOV AL,AH +@@2: STOSB +@@3: XCHG EAX,EDX + PUSH EAX + MOV EBX,ESP +@@4: XOR EDX,EDX + DIV [ESI].DCon10 + ADD DL,'0' + MOV [EBX],DL + INC EBX + DEC ECX + OR EAX,EAX + JNE @@4 + OR ECX,ECX + JG @@4 +@@5: DEC EBX + MOV AL,[EBX] + STOSB + CMP EBX,ESP + JNE @@5 + POP EAX + POP ESI +end; + +function FloatToText(BufferArg: PChar; const Value; ValueType: TFloatValue; + Format: TFloatFormat; Precision, Digits: Integer): Integer; +var + Buffer: Cardinal; + FloatRec: TFloatRec; + SaveGOT: Integer; + DecimalSep: Char; + ThousandSep: Char; + CurrencyStr: Pointer; + CurrFmt: Byte; + NegCurrFmt: Byte; +asm + PUSH EDI + PUSH ESI + PUSH EBX + MOV Buffer,EAX +{$IFDEF PIC} + PUSH ECX + CALL GetGOT + MOV SaveGOT,EAX + MOV ECX,[EAX].OFFSET DecimalSeparator + MOV CL,[ECX] + MOV DecimalSep,CL + MOV ECX,[EAX].OFFSET ThousandSeparator + MOV CL,[ECX].Byte + MOV ThousandSep,CL + MOV ECX,[EAX].OFFSET CurrencyString + MOV ECX,[ECX].Integer + MOV CurrencyStr,ECX + MOV ECX,[EAX].OFFSET CurrencyFormat + MOV CL,[ECX].Byte + MOV CurrFmt,CL + MOV ECX,[EAX].OFFSET NegCurrFormat + MOV CL,[ECX].Byte + MOV NegCurrFmt,CL + POP ECX +{$ELSE} + MOV AL,DecimalSeparator + MOV DecimalSep,AL + MOV AL,ThousandSeparator + MOV ThousandSep,AL + MOV EAX,CurrencyString + MOV CurrencyStr,EAX + MOV AL,CurrencyFormat + MOV CurrFmt,AL + MOV AL,NegCurrFormat + MOV NegCurrFmt,AL + MOV SaveGOT,0 +{$ENDIF} + MOV EAX,19 + CMP CL,fvExtended + JNE @@2 + MOV EAX,Precision + CMP EAX,2 + JGE @@1 + MOV EAX,2 +@@1: CMP EAX,18 + JLE @@2 + MOV EAX,18 +@@2: MOV Precision,EAX + PUSH EAX + MOV EAX,9999 + CMP Format,ffFixed + JB @@3 + MOV EAX,Digits +@@3: PUSH EAX + LEA EAX,FloatRec + CALL FloatToDecimal + MOV EDI,Buffer + MOVZX EAX,FloatRec.Exponent + SUB EAX,7FFFH + CMP EAX,2 + JAE @@4 + MOV ECX, EAX + CALL @@PutSign + LEA ESI,@@INFNAN[ECX+ECX*2] + ADD ESI,SaveGOT + MOV ECX,3 + REP MOVSB + JMP @@7 +@@4: LEA ESI,FloatRec.Digits + MOVZX EBX,Format + CMP BL,ffExponent + JE @@6 + CMP BL,ffCurrency + JA @@5 + MOVSX EAX,FloatRec.Exponent + CMP EAX,Precision + JLE @@6 +@@5: MOV BL,ffGeneral +@@6: LEA EBX,@@FormatVector[EBX*4] + ADD EBX,SaveGOT + MOV EBX,[EBX] + ADD EBX,SaveGOT + CALL EBX +@@7: MOV EAX,EDI + SUB EAX,Buffer + POP EBX + POP ESI + POP EDI + JMP @@Exit + +@@FormatVector: + DD @@PutFGeneral + DD @@PutFExponent + DD @@PutFFixed + DD @@PutFNumber + DD @@PutFCurrency + +@@INFNAN: DB 'INFNAN' + +// Get digit or '0' if at end of digit string + +@@GetDigit: + + LODSB + OR AL,AL + JNE @@a1 + MOV AL,'0' + DEC ESI +@@a1: RET + +// Store '-' if number is negative + +@@PutSign: + + CMP FloatRec.Negative,0 + JE @@b1 + MOV AL,'-' + STOSB +@@b1: RET + +// Convert number using ffGeneral format + +@@PutFGeneral: + + CALL @@PutSign + MOVSX ECX,FloatRec.Exponent + XOR EDX,EDX + CMP ECX,Precision + JG @@c1 + CMP ECX,-3 + JL @@c1 + OR ECX,ECX + JG @@c2 + MOV AL,'0' + STOSB + CMP BYTE PTR [ESI],0 + JE @@c6 + MOV AL,DecimalSep + STOSB + NEG ECX + MOV AL,'0' + REP STOSB + JMP @@c3 +@@c1: MOV ECX,1 + INC EDX +@@c2: LODSB + OR AL,AL + JE @@c4 + STOSB + LOOP @@c2 + LODSB + OR AL,AL + JE @@c5 + MOV AH,AL + MOV AL,DecimalSep + STOSW +@@c3: LODSB + OR AL,AL + JE @@c5 + STOSB + JMP @@c3 +@@c4: MOV AL,'0' + REP STOSB +@@c5: OR EDX,EDX + JE @@c6 + XOR EAX,EAX + JMP @@PutFloatExpWithDigits +@@c6: RET + +// Convert number using ffExponent format + +@@PutFExponent: + + CALL @@PutSign + CALL @@GetDigit + MOV AH,DecimalSep + STOSW + MOV ECX,Precision + DEC ECX +@@d1: CALL @@GetDigit + STOSB + LOOP @@d1 + MOV AH,'+' + +@@PutFloatExpWithDigits: + + MOV ECX,Digits + CMP ECX,4 + JBE @@PutFloatExp + XOR ECX,ECX + +// Store exponent +// In AH = Positive sign character ('+' or 0) +// ECX = Minimum number of digits (0..4) + +@@PutFloatExp: + + MOV AL,'E' + MOV BL, FloatRec.Digits.Byte + MOVSX EDX,FloatRec.Exponent + DEC EDX + CALL PutExponent + RET + +// Convert number using ffFixed or ffNumber format + +@@PutFFixed: +@@PutFNumber: + + CALL @@PutSign + +// Store number in fixed point format + +@@PutNumber: + + MOV EDX,Digits + CMP EDX,18 + JB @@f1 + MOV EDX,18 +@@f1: MOVSX ECX,FloatRec.Exponent + OR ECX,ECX + JG @@f2 + MOV AL,'0' + STOSB + JMP @@f4 +@@f2: XOR EBX,EBX + CMP Format,ffFixed + JE @@f3 + MOV EAX,ECX + DEC EAX + MOV BL,3 + DIV BL + MOV BL,AH + INC EBX +@@f3: CALL @@GetDigit + STOSB + DEC ECX + JE @@f4 + DEC EBX + JNE @@f3 + MOV AL,ThousandSep + TEST AL,AL + JZ @@f3 + STOSB + MOV BL,3 + JMP @@f3 +@@f4: OR EDX,EDX + JE @@f7 + MOV AL,DecimalSep + TEST AL,AL + JZ @@f4b + STOSB +@@f4b: JECXZ @@f6 + MOV AL,'0' +@@f5: STOSB + DEC EDX + JE @@f7 + INC ECX + JNE @@f5 +@@f6: CALL @@GetDigit + STOSB + DEC EDX + JNE @@f6 +@@f7: RET + +// Convert number using ffCurrency format + +@@PutFCurrency: + + XOR EBX,EBX + MOV BL,CurrFmt.Byte + MOV ECX,0003H + CMP FloatRec.Negative,0 + JE @@g1 + MOV BL,NegCurrFmt.Byte + MOV ECX,040FH +@@g1: CMP BL,CL + JBE @@g2 + MOV BL,CL +@@g2: ADD BL,CH + LEA EBX,@@MoneyFormats[EBX+EBX*4] + ADD EBX,SaveGOT + MOV ECX,5 +@@g10: MOV AL,[EBX] + CMP AL,'@' + JE @@g14 + PUSH ECX + PUSH EBX + CMP AL,'$' + JE @@g11 + CMP AL,'*' + JE @@g12 + STOSB + JMP @@g13 +@@g11: CALL @@PutCurSym + JMP @@g13 +@@g12: CALL @@PutNumber +@@g13: POP EBX + POP ECX + INC EBX + LOOP @@g10 +@@g14: RET + +// Store currency symbol string + +@@PutCurSym: + + PUSH ESI + MOV ESI,CurrencyStr + TEST ESI,ESI + JE @@h1 + MOV ECX,[ESI-4] + REP MOVSB +@@h1: POP ESI + RET + +// Currency formatting templates + +@@MoneyFormats: + DB '$*@@@' + DB '*$@@@' + DB '$ *@@' + DB '* $@@' + DB '($*)@' + DB '-$*@@' + DB '$-*@@' + DB '$*-@@' + DB '(*$)@' + DB '-*$@@' + DB '*-$@@' + DB '*$-@@' + DB '-* $@' + DB '-$ *@' + DB '* $-@' + DB '$ *-@' + DB '$ -*@' + DB '*- $@' + DB '($ *)' + DB '(* $)' + +@@Exit: +end; + +function FloatToText(BufferArg: PChar; const Value; ValueType: TFloatValue; + Format: TFloatFormat; Precision, Digits: Integer; + const FormatSettings: TFormatSettings): Integer; +var + Buffer: Cardinal; + FloatRec: TFloatRec; + SaveGOT: Integer; + DecimalSep: Char; + ThousandSep: Char; + CurrencyStr: Pointer; + CurrFmt: Byte; + NegCurrFmt: Byte; +asm + PUSH EDI + PUSH ESI + PUSH EBX + MOV Buffer,EAX +{$IFDEF PIC} + PUSH ECX + CALL GetGOT + MOV SaveGOT,EAX + POP ECX +{$ENDIF} + MOV EAX,FormatSettings + MOV AL,[EAX].TFormatSettings.DecimalSeparator + MOV DecimalSep,AL + MOV EAX,FormatSettings + MOV AL,[EAX].TFormatSettings.ThousandSeparator + MOV ThousandSep,AL + MOV EAX,FormatSettings + MOV EAX,[EAX].TFormatSettings.CurrencyString + MOV CurrencyStr,EAX + MOV EAX,FormatSettings + MOV AL,[EAX].TFormatSettings.CurrencyFormat + MOV CurrFmt,AL + MOV EAX,FormatSettings + MOV AL,[EAX].TFormatSettings.NegCurrFormat + MOV NegCurrFmt,AL + MOV SaveGOT,0 + MOV EAX,19 + CMP CL,fvExtended + JNE @@2 + MOV EAX,Precision + CMP EAX,2 + JGE @@1 + MOV EAX,2 +@@1: CMP EAX,18 + JLE @@2 + MOV EAX,18 +@@2: MOV Precision,EAX + PUSH EAX + MOV EAX,9999 + CMP Format,ffFixed + JB @@3 + MOV EAX,Digits +@@3: PUSH EAX + LEA EAX,FloatRec + CALL FloatToDecimal + MOV EDI,Buffer + MOVZX EAX,FloatRec.Exponent + SUB EAX,7FFFH + CMP EAX,2 + JAE @@4 + MOV ECX, EAX + CALL @@PutSign + LEA ESI,@@INFNAN[ECX+ECX*2] + ADD ESI,SaveGOT + MOV ECX,3 + REP MOVSB + JMP @@7 +@@4: LEA ESI,FloatRec.Digits + MOVZX EBX,Format + CMP BL,ffExponent + JE @@6 + CMP BL,ffCurrency + JA @@5 + MOVSX EAX,FloatRec.Exponent + CMP EAX,Precision + JLE @@6 +@@5: MOV BL,ffGeneral +@@6: LEA EBX,@@FormatVector[EBX*4] + ADD EBX,SaveGOT + MOV EBX,[EBX] + ADD EBX,SaveGOT + CALL EBX +@@7: MOV EAX,EDI + SUB EAX,Buffer + POP EBX + POP ESI + POP EDI + JMP @@Exit + +@@FormatVector: + DD @@PutFGeneral + DD @@PutFExponent + DD @@PutFFixed + DD @@PutFNumber + DD @@PutFCurrency + +@@INFNAN: DB 'INFNAN' + +// Get digit or '0' if at end of digit string + +@@GetDigit: + + LODSB + OR AL,AL + JNE @@a1 + MOV AL,'0' + DEC ESI +@@a1: RET + +// Store '-' if number is negative + +@@PutSign: + + CMP FloatRec.Negative,0 + JE @@b1 + MOV AL,'-' + STOSB +@@b1: RET + +// Convert number using ffGeneral format + +@@PutFGeneral: + + CALL @@PutSign + MOVSX ECX,FloatRec.Exponent + XOR EDX,EDX + CMP ECX,Precision + JG @@c1 + CMP ECX,-3 + JL @@c1 + OR ECX,ECX + JG @@c2 + MOV AL,'0' + STOSB + CMP BYTE PTR [ESI],0 + JE @@c6 + MOV AL,DecimalSep + STOSB + NEG ECX + MOV AL,'0' + REP STOSB + JMP @@c3 +@@c1: MOV ECX,1 + INC EDX +@@c2: LODSB + OR AL,AL + JE @@c4 + STOSB + LOOP @@c2 + LODSB + OR AL,AL + JE @@c5 + MOV AH,AL + MOV AL,DecimalSep + STOSW +@@c3: LODSB + OR AL,AL + JE @@c5 + STOSB + JMP @@c3 +@@c4: MOV AL,'0' + REP STOSB +@@c5: OR EDX,EDX + JE @@c6 + XOR EAX,EAX + JMP @@PutFloatExpWithDigits +@@c6: RET + +// Convert number using ffExponent format + +@@PutFExponent: + + CALL @@PutSign + CALL @@GetDigit + MOV AH,DecimalSep + STOSW + MOV ECX,Precision + DEC ECX +@@d1: CALL @@GetDigit + STOSB + LOOP @@d1 + MOV AH,'+' + +@@PutFloatExpWithDigits: + + MOV ECX,Digits + CMP ECX,4 + JBE @@PutFloatExp + XOR ECX,ECX + +// Store exponent +// In AH = Positive sign character ('+' or 0) +// ECX = Minimum number of digits (0..4) + +@@PutFloatExp: + + MOV AL,'E' + MOV BL, FloatRec.Digits.Byte + MOVSX EDX,FloatRec.Exponent + DEC EDX + CALL PutExponent + RET + +// Convert number using ffFixed or ffNumber format + +@@PutFFixed: +@@PutFNumber: + + CALL @@PutSign + +// Store number in fixed point format + +@@PutNumber: + + MOV EDX,Digits + CMP EDX,18 + JB @@f1 + MOV EDX,18 +@@f1: MOVSX ECX,FloatRec.Exponent + OR ECX,ECX + JG @@f2 + MOV AL,'0' + STOSB + JMP @@f4 +@@f2: XOR EBX,EBX + CMP Format,ffFixed + JE @@f3 + MOV EAX,ECX + DEC EAX + MOV BL,3 + DIV BL + MOV BL,AH + INC EBX +@@f3: CALL @@GetDigit + STOSB + DEC ECX + JE @@f4 + DEC EBX + JNE @@f3 + MOV AL,ThousandSep + TEST AL,AL + JZ @@f3 + STOSB + MOV BL,3 + JMP @@f3 +@@f4: OR EDX,EDX + JE @@f7 + MOV AL,DecimalSep + TEST AL,AL + JZ @@f4b + STOSB +@@f4b: JECXZ @@f6 + MOV AL,'0' +@@f5: STOSB + DEC EDX + JE @@f7 + INC ECX + JNE @@f5 +@@f6: CALL @@GetDigit + STOSB + DEC EDX + JNE @@f6 +@@f7: RET + +// Convert number using ffCurrency format + +@@PutFCurrency: + + XOR EBX,EBX + MOV BL,CurrFmt.Byte + MOV ECX,0003H + CMP FloatRec.Negative,0 + JE @@g1 + MOV BL,NegCurrFmt.Byte + MOV ECX,040FH +@@g1: CMP BL,CL + JBE @@g2 + MOV BL,CL +@@g2: ADD BL,CH + LEA EBX,@@MoneyFormats[EBX+EBX*4] + ADD EBX,SaveGOT + MOV ECX,5 +@@g10: MOV AL,[EBX] + CMP AL,'@' + JE @@g14 + PUSH ECX + PUSH EBX + CMP AL,'$' + JE @@g11 + CMP AL,'*' + JE @@g12 + STOSB + JMP @@g13 +@@g11: CALL @@PutCurSym + JMP @@g13 +@@g12: CALL @@PutNumber +@@g13: POP EBX + POP ECX + INC EBX + LOOP @@g10 +@@g14: RET + +// Store currency symbol string + +@@PutCurSym: + + PUSH ESI + MOV ESI,CurrencyStr + TEST ESI,ESI + JE @@h1 + MOV ECX,[ESI-4] + REP MOVSB +@@h1: POP ESI + RET + +// Currency formatting templates + +@@MoneyFormats: + DB '$*@@@' + DB '*$@@@' + DB '$ *@@' + DB '* $@@' + DB '($*)@' + DB '-$*@@' + DB '$-*@@' + DB '$*-@@' + DB '(*$)@' + DB '-*$@@' + DB '*-$@@' + DB '*$-@@' + DB '-* $@' + DB '-$ *@' + DB '* $-@' + DB '$ *-@' + DB '$ -*@' + DB '*- $@' + DB '($ *)' + DB '(* $)' + +@@Exit: +end; + +function FloatToTextFmt(Buf: PChar; const Value; ValueType: TFloatValue; + Format: PChar): Integer; + +var + Buffer: Pointer; + ThousandSep: Boolean; + DecimalSep: Char; + ThousandsSep: Char; + Scientific: Boolean; + Section: Integer; + DigitCount: Integer; + DecimalIndex: Integer; + FirstDigit: Integer; + LastDigit: Integer; + DigitPlace: Integer; + DigitDelta: Integer; + FloatRec: TFloatRec; + SaveGOT: Pointer; +asm + PUSH EDI + PUSH ESI + PUSH EBX + MOV Buffer,EAX + MOV EDI,EDX + MOV EBX,ECX +{$IFDEF PIC} + CALL GetGOT + MOV SaveGOT,EAX + MOV ECX,[EAX].OFFSET DecimalSeparator + MOV CL,[ECX].Byte + MOV DecimalSep,CL + MOV ECX,[EAX].OFFSET ThousandSeparator + MOV CL,[ECX].Byte + MOV ThousandsSep,CL +{$ELSE} + MOV SaveGOT,0 + MOV AL,DecimalSeparator + MOV DecimalSep,AL + MOV AL,ThousandSeparator + MOV ThousandsSep,AL +{$ENDIF} + MOV ECX,2 + CMP BL,fvExtended + JE @@1 + MOV EAX,[EDI].Integer + OR EAX,[EDI].Integer[4] + JE @@2 + MOV ECX,[EDI].Integer[4] + SHR ECX,31 + JMP @@2 +@@1: MOVZX EAX,[EDI].Word[8] + OR EAX,[EDI].Integer[0] + OR EAX,[EDI].Integer[4] + JE @@2 + MOVZX ECX,[EDI].Word[8] + SHR ECX,15 +@@2: CALL @@FindSection + JE @@5 + CALL @@ScanSection + MOV EAX,DigitCount + MOV EDX,9999 + CMP Scientific,0 + JNE @@3 + SUB EAX,DecimalIndex + MOV EDX,EAX + MOV EAX,18 +@@3: PUSH EAX + PUSH EDX + LEA EAX,FloatRec + MOV EDX,EDI + MOV ECX,EBX + CALL FloatToDecimal + MOV AX,FloatRec.Exponent + CMP AX,8000H + JE @@5 + CMP AX,7FFFH + JE @@5 + CMP BL,fvExtended + JNE @@6 + CMP AX,18 + JLE @@6 + CMP Scientific,0 + JNE @@6 +@@5: PUSH ffGeneral + PUSH 15 + PUSH 0 + MOV EAX,Buffer + MOV EDX,EDI + MOV ECX,EBX + CALL FloatToText + JMP @@Exit +@@6: CMP FloatRec.Digits.Byte,0 + JNE @@7 + MOV ECX,2 + CALL @@FindSection + JE @@5 + CMP ESI,Section + JE @@7 + CALL @@ScanSection +@@7: CALL @@ApplyFormat + JMP @@Exit + +// Find format section +// In ECX = Section index +// Out ESI = Section offset +// ZF = 1 if section is empty + +@@FindSection: + MOV ESI,Format + JECXZ @@fs2 +@@fs1: LODSB + CMP AL,"'" + JE @@fs4 + CMP AL,'"' + JE @@fs4 + OR AL,AL + JE @@fs2 + CMP AL,';' + JNE @@fs1 + LOOP @@fs1 + MOV AL,byte ptr [ESI] + OR AL,AL + JE @@fs2 + CMP AL,';' + JNE @@fs3 +@@fs2: MOV ESI,Format + MOV AL,byte ptr [ESI] + OR AL,AL + JE @@fs3 + CMP AL,';' +@@fs3: RET +@@fs4: MOV AH,AL +@@fs5: LODSB + CMP AL,AH + JE @@fs1 + OR AL,AL + JNE @@fs5 + JMP @@fs2 + +// Scan format section + +@@ScanSection: + PUSH EBX + MOV Section,ESI + MOV EBX,32767 + XOR ECX,ECX + XOR EDX,EDX + MOV DecimalIndex,-1 + MOV ThousandSep,DL + MOV Scientific,DL +@@ss1: LODSB +@@ss2: CMP AL,'#' + JE @@ss10 + CMP AL,'0' + JE @@ss11 + CMP AL,'.' + JE @@ss13 + CMP AL,',' + JE @@ss14 + CMP AL,"'" + JE @@ss15 + CMP AL,'"' + JE @@ss15 + CMP AL,'E' + JE @@ss20 + CMP AL,'e' + JE @@ss20 + CMP AL,';' + JE @@ss30 + OR AL,AL + JNE @@ss1 + JMP @@ss30 +@@ss10: INC EDX + JMP @@ss1 +@@ss11: CMP EDX,EBX + JGE @@ss12 + MOV EBX,EDX +@@ss12: INC EDX + MOV ECX,EDX + JMP @@ss1 +@@ss13: CMP DecimalIndex,-1 + JNE @@ss1 + MOV DecimalIndex,EDX + JMP @@ss1 +@@ss14: MOV ThousandSep,1 + JMP @@ss1 +@@ss15: MOV AH,AL +@@ss16: LODSB + CMP AL,AH + JE @@ss1 + OR AL,AL + JNE @@ss16 + JMP @@ss30 +@@ss20: LODSB + CMP AL,'-' + JE @@ss21 + CMP AL,'+' + JNE @@ss2 +@@ss21: MOV Scientific,1 +@@ss22: LODSB + CMP AL,'0' + JE @@ss22 + JMP @@ss2 +@@ss30: MOV DigitCount,EDX + CMP DecimalIndex,-1 + JNE @@ss31 + MOV DecimalIndex,EDX +@@ss31: MOV EAX,DecimalIndex + SUB EAX,ECX + JLE @@ss32 + XOR EAX,EAX +@@ss32: MOV LastDigit,EAX + MOV EAX,DecimalIndex + SUB EAX,EBX + JGE @@ss33 + XOR EAX,EAX +@@ss33: MOV FirstDigit,EAX + POP EBX + RET + +// Apply format string + +@@ApplyFormat: + CMP Scientific,0 + JE @@af1 + MOV EAX,DecimalIndex + XOR EDX,EDX + JMP @@af3 +@@af1: MOVSX EAX,FloatRec.Exponent + CMP EAX,DecimalIndex + JG @@af2 + MOV EAX,DecimalIndex +@@af2: MOVSX EDX,FloatRec.Exponent + SUB EDX,DecimalIndex +@@af3: MOV DigitPlace,EAX + MOV DigitDelta,EDX + MOV ESI,Section + MOV EDI,Buffer + LEA EBX,FloatRec.Digits + CMP FloatRec.Negative,0 + JE @@af10 + CMP ESI,Format + JNE @@af10 + MOV AL,'-' + STOSB +@@af10: LODSB + CMP AL,'#' + JE @@af20 + CMP AL,'0' + JE @@af20 + CMP AL,'.' + JE @@af10 + CMP AL,',' + JE @@af10 + CMP AL,"'" + JE @@af25 + CMP AL,'"' + JE @@af25 + CMP AL,'E' + JE @@af30 + CMP AL,'e' + JE @@af30 + CMP AL,';' + JE @@af40 + OR AL,AL + JE @@af40 +@@af11: STOSB + JMP @@af10 +@@af20: CALL @@PutFmtDigit + JMP @@af10 +@@af25: MOV AH,AL +@@af26: LODSB + CMP AL,AH + JE @@af10 + OR AL,AL + JE @@af40 + STOSB + JMP @@af26 +@@af30: MOV AH,[ESI] + CMP AH,'+' + JE @@af31 + CMP AH,'-' + JNE @@af11 + XOR AH,AH +@@af31: MOV ECX,-1 +@@af32: INC ECX + INC ESI + CMP [ESI].Byte,'0' + JE @@af32 + CMP ECX,4 + JB @@af33 + MOV ECX,4 +@@af33: PUSH EBX + MOV BL,FloatRec.Digits.Byte + MOVSX EDX,FloatRec.Exponent + SUB EDX,DecimalIndex + CALL PutExponent + POP EBX + JMP @@af10 +@@af40: MOV EAX,EDI + SUB EAX,Buffer + RET + +// Store formatted digit + +@@PutFmtDigit: + CMP DigitDelta,0 + JE @@fd3 + JL @@fd2 +@@fd1: CALL @@fd3 + DEC DigitDelta + JNE @@fd1 + JMP @@fd3 +@@fd2: INC DigitDelta + MOV EAX,DigitPlace + CMP EAX,FirstDigit + JLE @@fd4 + JMP @@fd7 +@@fd3: MOV AL,[EBX] + INC EBX + OR AL,AL + JNE @@fd5 + DEC EBX + MOV EAX,DigitPlace + CMP EAX,LastDigit + JLE @@fd7 +@@fd4: MOV AL,'0' +@@fd5: CMP DigitPlace,0 + JNE @@fd6 + MOV AH,AL + MOV AL,DecimalSep + STOSW + JMP @@fd7 +@@fd6: STOSB + CMP ThousandSep,0 + JE @@fd7 + MOV EAX,DigitPlace + CMP EAX,1 + JLE @@fd7 + MOV DL,3 + DIV DL + CMP AH,1 + JNE @@fd7 + MOV AL,ThousandsSep + TEST AL,AL + JZ @@fd7 + STOSB +@@fd7: DEC DigitPlace + RET + +@@exit: + POP EBX + POP ESI + POP EDI +end; + +function FloatToTextFmt(Buf: PChar; const Value; ValueType: TFloatValue; + Format: PChar; const FormatSettings: TFormatSettings): Integer; + +var + Buffer: Pointer; + ThousandSep: Boolean; + DecimalSep: Char; + ThousandsSep: Char; + Scientific: Boolean; + Section: Integer; + DigitCount: Integer; + DecimalIndex: Integer; + FirstDigit: Integer; + LastDigit: Integer; + DigitPlace: Integer; + DigitDelta: Integer; + FloatRec: TFloatRec; + SaveGOT: Pointer; +asm + PUSH EDI + PUSH ESI + PUSH EBX + MOV Buffer,EAX + MOV EDI,EDX + MOV EBX,ECX +{$IFDEF PIC} + CALL GetGOT + MOV SaveGOT,EAX +{$ELSE} + MOV SaveGOT,0 +{$ENDIF} + MOV EAX,FormatSettings + MOV AL,[EAX].TFormatSettings.DecimalSeparator + MOV DecimalSep,AL + MOV EAX,FormatSettings + MOV AL,[EAX].TFormatSettings.ThousandSeparator + MOV ThousandsSep,AL + MOV ECX,2 + CMP BL,fvExtended + JE @@1 + MOV EAX,[EDI].Integer + OR EAX,[EDI].Integer[4] + JE @@2 + MOV ECX,[EDI].Integer[4] + SHR ECX,31 + JMP @@2 +@@1: MOVZX EAX,[EDI].Word[8] + OR EAX,[EDI].Integer[0] + OR EAX,[EDI].Integer[4] + JE @@2 + MOVZX ECX,[EDI].Word[8] + SHR ECX,15 +@@2: CALL @@FindSection + JE @@5 + CALL @@ScanSection + MOV EAX,DigitCount + MOV EDX,9999 + CMP Scientific,0 + JNE @@3 + SUB EAX,DecimalIndex + MOV EDX,EAX + MOV EAX,18 +@@3: PUSH EAX + PUSH EDX + LEA EAX,FloatRec + MOV EDX,EDI + MOV ECX,EBX + CALL FloatToDecimal + MOV AX,FloatRec.Exponent + CMP AX,8000H + JE @@5 + CMP AX,7FFFH + JE @@5 + CMP BL,fvExtended + JNE @@6 + CMP AX,18 + JLE @@6 + CMP Scientific,0 + JNE @@6 +@@5: PUSH ffGeneral + PUSH 15 + PUSH 0 + MOV EAX,[FormatSettings] + PUSH EAX + MOV EAX,Buffer + MOV EDX,EDI + MOV ECX,EBX + CALL FloatToTextEx + JMP @@Exit +@@6: CMP FloatRec.Digits.Byte,0 + JNE @@7 + MOV ECX,2 + CALL @@FindSection + JE @@5 + CMP ESI,Section + JE @@7 + CALL @@ScanSection +@@7: CALL @@ApplyFormat + JMP @@Exit + +// Find format section +// In ECX = Section index +// Out ESI = Section offset +// ZF = 1 if section is empty + +@@FindSection: + MOV ESI,Format + JECXZ @@fs2 +@@fs1: LODSB + CMP AL,"'" + JE @@fs4 + CMP AL,'"' + JE @@fs4 + OR AL,AL + JE @@fs2 + CMP AL,';' + JNE @@fs1 + LOOP @@fs1 + MOV AL,byte ptr [ESI] + OR AL,AL + JE @@fs2 + CMP AL,';' + JNE @@fs3 +@@fs2: MOV ESI,Format + MOV AL,byte ptr [ESI] + OR AL,AL + JE @@fs3 + CMP AL,';' +@@fs3: RET +@@fs4: MOV AH,AL +@@fs5: LODSB + CMP AL,AH + JE @@fs1 + OR AL,AL + JNE @@fs5 + JMP @@fs2 + +// Scan format section + +@@ScanSection: + PUSH EBX + MOV Section,ESI + MOV EBX,32767 + XOR ECX,ECX + XOR EDX,EDX + MOV DecimalIndex,-1 + MOV ThousandSep,DL + MOV Scientific,DL +@@ss1: LODSB +@@ss2: CMP AL,'#' + JE @@ss10 + CMP AL,'0' + JE @@ss11 + CMP AL,'.' + JE @@ss13 + CMP AL,',' + JE @@ss14 + CMP AL,"'" + JE @@ss15 + CMP AL,'"' + JE @@ss15 + CMP AL,'E' + JE @@ss20 + CMP AL,'e' + JE @@ss20 + CMP AL,';' + JE @@ss30 + OR AL,AL + JNE @@ss1 + JMP @@ss30 +@@ss10: INC EDX + JMP @@ss1 +@@ss11: CMP EDX,EBX + JGE @@ss12 + MOV EBX,EDX +@@ss12: INC EDX + MOV ECX,EDX + JMP @@ss1 +@@ss13: CMP DecimalIndex,-1 + JNE @@ss1 + MOV DecimalIndex,EDX + JMP @@ss1 +@@ss14: MOV ThousandSep,1 + JMP @@ss1 +@@ss15: MOV AH,AL +@@ss16: LODSB + CMP AL,AH + JE @@ss1 + OR AL,AL + JNE @@ss16 + JMP @@ss30 +@@ss20: LODSB + CMP AL,'-' + JE @@ss21 + CMP AL,'+' + JNE @@ss2 +@@ss21: MOV Scientific,1 +@@ss22: LODSB + CMP AL,'0' + JE @@ss22 + JMP @@ss2 +@@ss30: MOV DigitCount,EDX + CMP DecimalIndex,-1 + JNE @@ss31 + MOV DecimalIndex,EDX +@@ss31: MOV EAX,DecimalIndex + SUB EAX,ECX + JLE @@ss32 + XOR EAX,EAX +@@ss32: MOV LastDigit,EAX + MOV EAX,DecimalIndex + SUB EAX,EBX + JGE @@ss33 + XOR EAX,EAX +@@ss33: MOV FirstDigit,EAX + POP EBX + RET + +// Apply format string + +@@ApplyFormat: + CMP Scientific,0 + JE @@af1 + MOV EAX,DecimalIndex + XOR EDX,EDX + JMP @@af3 +@@af1: MOVSX EAX,FloatRec.Exponent + CMP EAX,DecimalIndex + JG @@af2 + MOV EAX,DecimalIndex +@@af2: MOVSX EDX,FloatRec.Exponent + SUB EDX,DecimalIndex +@@af3: MOV DigitPlace,EAX + MOV DigitDelta,EDX + MOV ESI,Section + MOV EDI,Buffer + LEA EBX,FloatRec.Digits + CMP FloatRec.Negative,0 + JE @@af10 + CMP ESI,Format + JNE @@af10 + MOV AL,'-' + STOSB +@@af10: LODSB + CMP AL,'#' + JE @@af20 + CMP AL,'0' + JE @@af20 + CMP AL,'.' + JE @@af10 + CMP AL,',' + JE @@af10 + CMP AL,"'" + JE @@af25 + CMP AL,'"' + JE @@af25 + CMP AL,'E' + JE @@af30 + CMP AL,'e' + JE @@af30 + CMP AL,';' + JE @@af40 + OR AL,AL + JE @@af40 +@@af11: STOSB + JMP @@af10 +@@af20: CALL @@PutFmtDigit + JMP @@af10 +@@af25: MOV AH,AL +@@af26: LODSB + CMP AL,AH + JE @@af10 + OR AL,AL + JE @@af40 + STOSB + JMP @@af26 +@@af30: MOV AH,[ESI] + CMP AH,'+' + JE @@af31 + CMP AH,'-' + JNE @@af11 + XOR AH,AH +@@af31: MOV ECX,-1 +@@af32: INC ECX + INC ESI + CMP [ESI].Byte,'0' + JE @@af32 + CMP ECX,4 + JB @@af33 + MOV ECX,4 +@@af33: PUSH EBX + MOV BL,FloatRec.Digits.Byte + MOVSX EDX,FloatRec.Exponent + SUB EDX,DecimalIndex + CALL PutExponent + POP EBX + JMP @@af10 +@@af40: MOV EAX,EDI + SUB EAX,Buffer + RET + +// Store formatted digit + +@@PutFmtDigit: + CMP DigitDelta,0 + JE @@fd3 + JL @@fd2 +@@fd1: CALL @@fd3 + DEC DigitDelta + JNE @@fd1 + JMP @@fd3 +@@fd2: INC DigitDelta + MOV EAX,DigitPlace + CMP EAX,FirstDigit + JLE @@fd4 + JMP @@fd7 +@@fd3: MOV AL,[EBX] + INC EBX + OR AL,AL + JNE @@fd5 + DEC EBX + MOV EAX,DigitPlace + CMP EAX,LastDigit + JLE @@fd7 +@@fd4: MOV AL,'0' +@@fd5: CMP DigitPlace,0 + JNE @@fd6 + MOV AH,AL + MOV AL,DecimalSep + STOSW + JMP @@fd7 +@@fd6: STOSB + CMP ThousandSep,0 + JE @@fd7 + MOV EAX,DigitPlace + CMP EAX,1 + JLE @@fd7 + MOV DL,3 + DIV DL + CMP AH,1 + JNE @@fd7 + MOV AL,ThousandsSep + TEST AL,AL + JZ @@fd7 + STOSB +@@fd7: DEC DigitPlace + RET + +@@exit: + POP EBX + POP ESI + POP EDI +end; + +const +// 8087 status word masks + mIE = $0001; + mDE = $0002; + mZE = $0004; + mOE = $0008; + mUE = $0010; + mPE = $0020; + mC0 = $0100; + mC1 = $0200; + mC2 = $0400; + mC3 = $4000; + +procedure FloatToDecimal(var Result: TFloatRec; const Value; + ValueType: TFloatValue; Precision, Decimals: Integer); +var + StatWord: Word; + Exponent: Integer; + Temp: Double; + BCDValue: Extended; + SaveGOT: Pointer; +asm + PUSH EDI + PUSH ESI + PUSH EBX + MOV EBX,EAX + MOV ESI,EDX +{$IFDEF PIC} + PUSH ECX + CALL GetGOT + POP ECX + MOV SaveGOT,EAX +{$ELSE} + MOV SaveGOT,0 +{$ENDIF} + CMP CL,fvExtended + JE @@1 + CALL @@CurrToDecimal + JMP @@Exit +@@1: CALL @@ExtToDecimal + JMP @@Exit + +// Convert Extended to decimal + +@@ExtToDecimal: + + MOV AX,[ESI].Word[8] + MOV EDX,EAX + AND EAX,7FFFH + JE @@ed1 + CMP EAX,7FFFH + JNE @@ed10 +// check for special values (INF, NAN) + TEST [ESI].Word[6],8000H + JZ @@ed2 +// any significand bit set = NAN +// all significand bits clear = INF + CMP dword ptr [ESI], 0 + JNZ @@ed0 + CMP dword ptr [ESI+4], 80000000H + JZ @@ed2 +@@ed0: INC EAX +@@ed1: XOR EDX,EDX +@@ed2: MOV [EBX].TFloatRec.Digits.Byte,0 + JMP @@ed31 +@@ed10: FLD TBYTE PTR [ESI] + SUB EAX,3FFFH + IMUL EAX,19728 + SAR EAX,16 + INC EAX + MOV Exponent,EAX + MOV EAX,18 + SUB EAX,Exponent + FABS + PUSH EBX + MOV EBX,SaveGOT + CALL FPower10 + POP EBX + FRNDINT + MOV EDI,SaveGOT + FLD [EDI].FCon1E18 + FCOMP + FSTSW StatWord + FWAIT + TEST StatWord,mC0+mC3 + JE @@ed11 + FIDIV [EDI].DCon10 + INC Exponent +@@ed11: FBSTP BCDValue + LEA EDI,[EBX].TFloatRec.Digits + MOV EDX,9 + FWAIT +@@ed12: MOV AL,BCDValue[EDX-1].Byte + MOV AH,AL + SHR AL,4 + AND AH,0FH + ADD AX,'00' + STOSW + DEC EDX + JNE @@ed12 + XOR AL,AL + STOSB +@@ed20: MOV EDI,Exponent + ADD EDI,Decimals + JNS @@ed21 + XOR EAX,EAX + JMP @@ed1 +@@ed21: CMP EDI,Precision + JB @@ed22 + MOV EDI,Precision +@@ed22: CMP EDI,18 + JAE @@ed26 + CMP [EBX].TFloatRec.Digits.Byte[EDI],'5' + JB @@ed25 +@@ed23: MOV [EBX].TFloatRec.Digits.Byte[EDI],0 + DEC EDI + JS @@ed24 + INC [EBX].TFloatRec.Digits.Byte[EDI] + CMP [EBX].TFloatRec.Digits.Byte[EDI],'9' + JA @@ed23 + JMP @@ed30 +@@ed24: MOV [EBX].TFloatRec.Digits.Word,'1' + INC Exponent + JMP @@ed30 +@@ed26: MOV EDI,18 +@@ed25: MOV [EBX].TFloatRec.Digits.Byte[EDI],0 + DEC EDI + JS @@ed32 + CMP [EBX].TFloatRec.Digits.Byte[EDI],'0' + JE @@ed25 +@@ed30: MOV DX,[ESI].Word[8] +@@ed30a: + MOV EAX,Exponent +@@ed31: SHR DX,15 + MOV [EBX].TFloatRec.Exponent,AX + MOV [EBX].TFloatRec.Negative,DL + RET +@@ed32: XOR EDX,EDX + JMP @@ed30a + +@@DecimalTable: + DD 10 + DD 100 + DD 1000 + DD 10000 + +// Convert Currency to decimal + +@@CurrToDecimal: + + MOV EAX,[ESI].Integer[0] + MOV EDX,[ESI].Integer[4] + MOV ECX,EAX + OR ECX,EDX + JE @@cd20 + OR EDX,EDX + JNS @@cd1 + NEG EDX + NEG EAX + SBB EDX,0 +@@cd1: XOR ECX,ECX + MOV EDI,Decimals + OR EDI,EDI + JGE @@cd2 + XOR EDI,EDI +@@cd2: CMP EDI,4 + JL @@cd4 + MOV EDI,4 +@@cd3: INC ECX + SUB EAX,Const1E18Lo + SBB EDX,Const1E18Hi + JNC @@cd3 + DEC ECX + ADD EAX,Const1E18Lo + ADC EDX,Const1E18Hi +@@cd4: MOV Temp.Integer[0],EAX + MOV Temp.Integer[4],EDX + FILD Temp + MOV EDX,EDI + MOV EAX,4 + SUB EAX,EDX + JE @@cd5 + MOV EDI,SaveGOT + FIDIV @@DecimalTable.Integer[EDI+EAX*4-4] +@@cd5: FBSTP BCDValue + LEA EDI,[EBX].TFloatRec.Digits + FWAIT + OR ECX,ECX + JNE @@cd11 + MOV ECX,9 +@@cd10: MOV AL,BCDValue[ECX-1].Byte + MOV AH,AL + SHR AL,4 + JNE @@cd13 + MOV AL,AH + AND AL,0FH + JNE @@cd14 + DEC ECX + JNE @@cd10 + JMP @@cd20 +@@cd11: MOV AL,CL + ADD AL,'0' + STOSB + MOV ECX,9 +@@cd12: MOV AL,BCDValue[ECX-1].Byte + MOV AH,AL + SHR AL,4 +@@cd13: ADD AL,'0' + STOSB + MOV AL,AH + AND AL,0FH +@@cd14: ADD AL,'0' + STOSB + DEC ECX + JNE @@cd12 + MOV EAX,EDI + LEA ECX,[EBX].TFloatRec.Digits[EDX] + SUB EAX,ECX +@@cd15: MOV BYTE PTR [EDI],0 + DEC EDI + CMP BYTE PTR [EDI],'0' + JE @@cd15 + MOV EDX,[ESI].Integer[4] + SHR EDX,31 + JMP @@cd21 +@@cd20: XOR EAX,EAX + XOR EDX,EDX + MOV [EBX].TFloatRec.Digits.Byte[0],AL +@@cd21: MOV [EBX].TFloatRec.Exponent,AX + MOV [EBX].TFloatRec.Negative,DL + RET + +@@Exit: + POP EBX + POP ESI + POP EDI +end; + +function TextToFloat(Buffer: PChar; var Value; + ValueType: TFloatValue): Boolean; + +const +// 8087 control word +// Infinity control = 1 Affine +// Rounding Control = 0 Round to nearest or even +// Precision Control = 3 64 bits +// All interrupts masked + CWNear: Word = $133F; + +var + Temp: Integer; + CtrlWord: Word; + DecimalSep: Char; + SaveGOT: Integer; +asm + PUSH EDI + PUSH ESI + PUSH EBX + MOV ESI,EAX + MOV EDI,EDX +{$IFDEF PIC} + PUSH ECX + CALL GetGOT + POP EBX + MOV SaveGOT,EAX + MOV ECX,[EAX].OFFSET DecimalSeparator + MOV CL,[ECX].Byte + MOV DecimalSep,CL +{$ELSE} + MOV SaveGOT,0 + MOV AL,DecimalSeparator + MOV DecimalSep,AL + MOV EBX,ECX +{$ENDIF} + FSTCW CtrlWord + FCLEX +{$IFDEF PIC} + FLDCW [EAX].CWNear +{$ELSE} + FLDCW CWNear +{$ENDIF} + FLDZ + CALL @@SkipBlanks + MOV BH, byte ptr [ESI] + CMP BH,'+' + JE @@1 + CMP BH,'-' + JNE @@2 +@@1: INC ESI +@@2: MOV ECX,ESI + CALL @@GetDigitStr + XOR EDX,EDX + MOV AL,[ESI] + CMP AL,DecimalSep + JNE @@3 + INC ESI + CALL @@GetDigitStr + NEG EDX +@@3: CMP ECX,ESI + JE @@9 + MOV AL, byte ptr [ESI] + AND AL,0DFH + CMP AL,'E' + JNE @@4 + INC ESI + PUSH EDX + CALL @@GetExponent + POP EAX + ADD EDX,EAX +@@4: CALL @@SkipBlanks + CMP BYTE PTR [ESI],0 + JNE @@9 + MOV EAX,EDX + CMP BL,fvCurrency + JNE @@5 + ADD EAX,4 +@@5: PUSH EBX + MOV EBX,SaveGOT + CALL FPower10 + POP EBX + CMP BH,'-' + JNE @@6 + FCHS +@@6: CMP BL,fvExtended + JE @@7 + FISTP QWORD PTR [EDI] + JMP @@8 +@@7: FSTP TBYTE PTR [EDI] +@@8: FSTSW AX + TEST AX,mIE+mOE + JNE @@10 + MOV AL,1 + JMP @@11 +@@9: FSTP ST(0) +@@10: XOR EAX,EAX +@@11: FCLEX + FLDCW CtrlWord + FWAIT + JMP @@Exit + +@@SkipBlanks: + +@@21: LODSB + OR AL,AL + JE @@22 + CMP AL,' ' + JE @@21 +@@22: DEC ESI + RET + +// Process string of digits +// Out EDX = Digit count + +@@GetDigitStr: + + XOR EAX,EAX + XOR EDX,EDX +@@31: LODSB + SUB AL,'0'+10 + ADD AL,10 + JNC @@32 +{$IFDEF PIC} + XCHG SaveGOT,EBX + FIMUL [EBX].DCon10 + XCHG SaveGOT,EBX +{$ELSE} + FIMUL DCon10 +{$ENDIF} + MOV Temp,EAX + FIADD Temp + INC EDX + JMP @@31 +@@32: DEC ESI + RET + +// Get exponent +// Out EDX = Exponent (-4999..4999) + +@@GetExponent: + + XOR EAX,EAX + XOR EDX,EDX + MOV CL, byte ptr [ESI] + CMP CL,'+' + JE @@41 + CMP CL,'-' + JNE @@42 +@@41: INC ESI +@@42: MOV AL, byte ptr [ESI] + SUB AL,'0'+10 + ADD AL,10 + JNC @@43 + INC ESI + IMUL EDX,10 + ADD EDX,EAX + CMP EDX,500 + JB @@42 +@@43: CMP CL,'-' + JNE @@44 + NEG EDX +@@44: RET + +@@Exit: + POP EBX + POP ESI + POP EDI +end; + +function TextToFloat(Buffer: PChar; var Value; + ValueType: TFloatValue; const FormatSettings: TFormatSettings): Boolean; + +const +// 8087 control word +// Infinity control = 1 Affine +// Rounding Control = 0 Round to nearest or even +// Precision Control = 3 64 bits +// All interrupts masked + CWNear: Word = $133F; + +var + Temp: Integer; + CtrlWord: Word; + DecimalSep: Char; + SaveGOT: Integer; +asm + PUSH EDI + PUSH ESI + PUSH EBX + MOV ESI,EAX + MOV EDI,EDX +{$IFDEF PIC} + PUSH ECX + CALL GetGOT + POP EBX + MOV SaveGOT,EAX +{$ELSE} + MOV SaveGOT,0 + MOV EBX,ECX +{$ENDIF} + MOV EAX,FormatSettings + MOV AL,[EAX].TFormatSettings.DecimalSeparator + MOV DecimalSep,AL + FSTCW CtrlWord + FCLEX +{$IFDEF PIC} + FLDCW [EAX].CWNear +{$ELSE} + FLDCW CWNear +{$ENDIF} + FLDZ + CALL @@SkipBlanks + MOV BH, byte ptr [ESI] + CMP BH,'+' + JE @@1 + CMP BH,'-' + JNE @@2 +@@1: INC ESI +@@2: MOV ECX,ESI + CALL @@GetDigitStr + XOR EDX,EDX + MOV AL,[ESI] + CMP AL,DecimalSep + JNE @@3 + INC ESI + CALL @@GetDigitStr + NEG EDX +@@3: CMP ECX,ESI + JE @@9 + MOV AL, byte ptr [ESI] + AND AL,0DFH + CMP AL,'E' + JNE @@4 + INC ESI + PUSH EDX + CALL @@GetExponent + POP EAX + ADD EDX,EAX +@@4: CALL @@SkipBlanks + CMP BYTE PTR [ESI],0 + JNE @@9 + MOV EAX,EDX + CMP BL,fvCurrency + JNE @@5 + ADD EAX,4 +@@5: PUSH EBX + MOV EBX,SaveGOT + CALL FPower10 + POP EBX + CMP BH,'-' + JNE @@6 + FCHS +@@6: CMP BL,fvExtended + JE @@7 + FISTP QWORD PTR [EDI] + JMP @@8 +@@7: FSTP TBYTE PTR [EDI] +@@8: FSTSW AX + TEST AX,mIE+mOE + JNE @@10 + MOV AL,1 + JMP @@11 +@@9: FSTP ST(0) +@@10: XOR EAX,EAX +@@11: FCLEX + FLDCW CtrlWord + FWAIT + JMP @@Exit + +@@SkipBlanks: + +@@21: LODSB + OR AL,AL + JE @@22 + CMP AL,' ' + JE @@21 +@@22: DEC ESI + RET + +// Process string of digits +// Out EDX = Digit count + +@@GetDigitStr: + + XOR EAX,EAX + XOR EDX,EDX +@@31: LODSB + SUB AL,'0'+10 + ADD AL,10 + JNC @@32 +{$IFDEF PIC} + XCHG SaveGOT,EBX + FIMUL [EBX].DCon10 + XCHG SaveGOT,EBX +{$ELSE} + FIMUL DCon10 +{$ENDIF} + MOV Temp,EAX + FIADD Temp + INC EDX + JMP @@31 +@@32: DEC ESI + RET + +// Get exponent +// Out EDX = Exponent (-4999..4999) + +@@GetExponent: + + XOR EAX,EAX + XOR EDX,EDX + MOV CL, byte ptr [ESI] + CMP CL,'+' + JE @@41 + CMP CL,'-' + JNE @@42 +@@41: INC ESI +@@42: MOV AL, byte ptr [ESI] + SUB AL,'0'+10 + ADD AL,10 + JNC @@43 + INC ESI + IMUL EDX,10 + ADD EDX,EAX + CMP EDX,500 + JB @@42 +@@43: CMP CL,'-' + JNE @@44 + NEG EDX +@@44: RET + +@@Exit: + POP EBX + POP ESI + POP EDI +end; + +function FloatToStr(Value: Extended): string; +var + Buffer: array[0..63] of Char; +begin + SetString(Result, Buffer, FloatToText(Buffer, Value, fvExtended, + ffGeneral, 15, 0)); +end; + +function FloatToStr(Value: Extended; + const FormatSettings: TFormatSettings): string; +var + Buffer: array[0..63] of Char; +begin + SetString(Result, Buffer, FloatToText(Buffer, Value, fvExtended, + ffGeneral, 15, 0, FormatSettings)); +end; + +function CurrToStr(Value: Currency): string; +var + Buffer: array[0..63] of Char; +begin + SetString(Result, Buffer, FloatToText(Buffer, Value, fvCurrency, + ffGeneral, 0, 0)); +end; + +function CurrToStr(Value: Currency; + const FormatSettings: TFormatSettings): string; +var + Buffer: array[0..63] of Char; +begin + SetString(Result, Buffer, FloatToText(Buffer, Value, fvCurrency, + ffGeneral, 0, 0, FormatSettings)); +end; + +function TryFloatToCurr(const Value: Extended; out AResult: Currency): Boolean; +begin + Result := (Value >= MinCurrency) and (Value <= MaxCurrency); + if Result then + AResult := Value; +end; + +function FloatToCurr(const Value: Extended): Currency; +begin + if not TryFloatToCurr(Value, Result) then + ConvertErrorFmt(SInvalidCurrency, [FloatToStr(Value)]); +end; + +function FloatToStrF(Value: Extended; Format: TFloatFormat; + Precision, Digits: Integer): string; +var + Buffer: array[0..63] of Char; +begin + SetString(Result, Buffer, FloatToText(Buffer, Value, fvExtended, + Format, Precision, Digits)); +end; + +function FloatToStrF(Value: Extended; Format: TFloatFormat; + Precision, Digits: Integer; const FormatSettings: TFormatSettings): string; +var + Buffer: array[0..63] of Char; +begin + SetString(Result, Buffer, FloatToText(Buffer, Value, fvExtended, + Format, Precision, Digits, FormatSettings)); +end; + +function CurrToStrF(Value: Currency; Format: TFloatFormat; + Digits: Integer): string; +var + Buffer: array[0..63] of Char; +begin + SetString(Result, Buffer, FloatToText(Buffer, Value, fvCurrency, + Format, 0, Digits)); +end; + +function CurrToStrF(Value: Currency; Format: TFloatFormat; + Digits: Integer; const FormatSettings: TFormatSettings): string; +var + Buffer: array[0..63] of Char; +begin + SetString(Result, Buffer, FloatToText(Buffer, Value, fvCurrency, + Format, 0, Digits, FormatSettings)); +end; + +function FormatFloat(const Format: string; Value: Extended): string; +var + Buffer: array[0..255] of Char; +begin + if Length(Format) > SizeOf(Buffer) - 32 then ConvertError(SFormatTooLong); + SetString(Result, Buffer, FloatToTextFmt(Buffer, Value, fvExtended, + PChar(Format))); +end; + +function FormatFloat(const Format: string; Value: Extended; + const FormatSettings: TFormatSettings): string; +var + Buffer: array[0..255] of Char; +begin + if Length(Format) > SizeOf(Buffer) - 32 then ConvertError(SFormatTooLong); + SetString(Result, Buffer, FloatToTextFmt(Buffer, Value, fvExtended, + PChar(Format), FormatSettings)); +end; + +function FormatCurr(const Format: string; Value: Currency): string; +var + Buffer: array[0..255] of Char; +begin + if Length(Format) > SizeOf(Buffer) - 32 then ConvertError(SFormatTooLong); + SetString(Result, Buffer, FloatToTextFmt(Buffer, Value, fvCurrency, + PChar(Format))); +end; + +function FormatCurr(const Format: string; Value: Currency; + const FormatSettings: TFormatSettings): string; +var + Buffer: array[0..255] of Char; +begin + if Length(Format) > SizeOf(Buffer) - 32 then ConvertError(SFormatTooLong); + SetString(Result, Buffer, FloatToTextFmt(Buffer, Value, fvCurrency, + PChar(Format), FormatSettings)); +end; + +function StrToFloat(const S: string): Extended; +begin + if not TextToFloat(PChar(S), Result, fvExtended) then + ConvertErrorFmt(SInvalidFloat, [S]); +end; + +function StrToFloat(const S: string; + const FormatSettings: TFormatSettings): Extended; +begin + if not TextToFloat(PChar(S), Result, fvExtended, FormatSettings) then + ConvertErrorFmt(SInvalidFloat, [S]); +end; + +function StrToFloatDef(const S: string; const Default: Extended): Extended; +begin + if not TextToFloat(PChar(S), Result, fvExtended) then + Result := Default; +end; + +function StrToFloatDef(const S: string; const Default: Extended; + const FormatSettings: TFormatSettings): Extended; +begin + if not TextToFloat(PChar(S), Result, fvExtended, FormatSettings) then + Result := Default; +end; + +function TryStrToFloat(const S: string; out Value: Extended): Boolean; +begin + Result := TextToFloat(PChar(S), Value, fvExtended); +end; + +function TryStrToFloat(const S: string; out Value: Extended; + const FormatSettings: TFormatSettings): Boolean; +begin + Result := TextToFloat(PChar(S), Value, fvExtended, FormatSettings); +end; + +function TryStrToFloat(const S: string; out Value: Double): Boolean; +var + LValue: Extended; +begin + Result := TextToFloat(PChar(S), LValue, fvExtended); + if Result then + Value := LValue; +end; + +function TryStrToFloat(const S: string; out Value: Double; + const FormatSettings: TFormatSettings): Boolean; +var + LValue: Extended; +begin + Result := TextToFloat(PChar(S), LValue, fvExtended, FormatSettings); + if Result then + Value := LValue; +end; + +function TryStrToFloat(const S: string; out Value: Single): Boolean; +var + LValue: Extended; +begin + Result := TextToFloat(PChar(S), LValue, fvExtended); + if Result then + Value := LValue; +end; + +function TryStrToFloat(const S: string; out Value: Single; + const FormatSettings: TFormatSettings): Boolean; +var + LValue: Extended; +begin + Result := TextToFloat(PChar(S), LValue, fvExtended, FormatSettings); + if Result then + Value := LValue; +end; + +function StrToCurr(const S: string): Currency; +begin + if not TextToFloat(PChar(S), Result, fvCurrency) then + ConvertErrorFmt(SInvalidFloat, [S]); +end; + +function StrToCurr(const S: string; + const FormatSettings: TFormatSettings): Currency; +begin + if not TextToFloat(PChar(S), Result, fvCurrency, FormatSettings) then + ConvertErrorFmt(SInvalidFloat, [S]); +end; + +function StrToCurrDef(const S: string; const Default: Currency): Currency; +begin + if not TextToFloat(PChar(S), Result, fvCurrency) then + Result := Default; +end; + +function StrToCurrDef(const S: string; const Default: Currency; + const FormatSettings: TFormatSettings): Currency; +begin + if not TextToFloat(PChar(S), Result, fvCurrency, FormatSettings) then + Result := Default; +end; + +function TryStrToCurr(const S: string; out Value: Currency): Boolean; +begin + Result := TextToFloat(PChar(S), Value, fvCurrency); +end; + +function TryStrToCurr(const S: string; out Value: Currency; + const FormatSettings: TFormatSettings): Boolean; +begin + Result := TextToFloat(PChar(S), Value, fvCurrency, FormatSettings); +end; + +{ Date/time support routines } + +const + FMSecsPerDay: Single = MSecsPerDay; + IMSecsPerDay: Integer = MSecsPerDay; + +function DateTimeToTimeStamp(DateTime: TDateTime): TTimeStamp; +asm + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX +{$ELSE} + XOR EBX,EBX +{$ENDIF} + MOV ECX,EAX + FLD DateTime + FMUL [EBX].FMSecsPerDay + SUB ESP,8 + FISTP QWORD PTR [ESP] + FWAIT + POP EAX + POP EDX + OR EDX,EDX + JNS @@1 + NEG EDX + NEG EAX + SBB EDX,0 + DIV [EBX].IMSecsPerDay + NEG EAX + JMP @@2 +@@1: DIV [EBX].IMSecsPerDay +@@2: ADD EAX,DateDelta + MOV [ECX].TTimeStamp.Time,EDX + MOV [ECX].TTimeStamp.Date,EAX + POP EBX +end; + +procedure ValidateTimeStamp(const TimeStamp: TTimeStamp); +begin + if (TimeStamp.Time < 0) or (TimeStamp.Date <= 0) then + ConvertErrorFmt(SInvalidTimeStamp, [TimeStamp.Date, TimeStamp.Time]); +end; + +function TimeStampToDateTime(const TimeStamp: TTimeStamp): TDateTime; +asm + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX +{$ELSE} + XOR EBX,EBX +{$ENDIF} + PUSH EAX + CALL ValidateTimeStamp + POP EAX + MOV ECX,[EAX].TTimeStamp.Time + MOV EAX,[EAX].TTimeStamp.Date + SUB EAX,DateDelta + IMUL [EBX].IMSecsPerDay + OR EDX,EDX + JNS @@1 + SUB EAX,ECX + SBB EDX,0 + JMP @@2 +@@1: ADD EAX,ECX + ADC EDX,0 +@@2: PUSH EDX + PUSH EAX + FILD QWORD PTR [ESP] + FDIV [EBX].FMSecsPerDay + ADD ESP,8 + POP EBX +end; + +function MSecsToTimeStamp(MSecs: Comp): TTimeStamp; +asm + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX +{$ELSE} + XOR EBX,EBX +{$ENDIF} + MOV ECX,EAX + MOV EAX,MSecs.Integer[0] + MOV EDX,MSecs.Integer[4] + DIV [EBX].IMSecsPerDay + MOV [ECX].TTimeStamp.Time,EDX + MOV [ECX].TTimeStamp.Date,EAX + POP EBX +end; + +function TimeStampToMSecs(const TimeStamp: TTimeStamp): Comp; +asm + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX +{$ELSE} + XOR EBX,EBX +{$ENDIF} + PUSH EAX + CALL ValidateTimeStamp + POP EAX + FILD [EAX].TTimeStamp.Date + FMUL [EBX].FMSecsPerDay + FIADD [EAX].TTimeStamp.Time + POP EBX +end; + +{ Time encoding and decoding } + +function TryEncodeTime(Hour, Min, Sec, MSec: Word; out Time: TDateTime): Boolean; +begin + Result := False; + if (Hour < HoursPerDay) and (Min < MinsPerHour) and (Sec < SecsPerMin) and (MSec < MSecsPerSec) then + begin + Time := (Hour * (MinsPerHour * SecsPerMin * MSecsPerSec) + + Min * (SecsPerMin * MSecsPerSec) + + Sec * MSecsPerSec + + MSec) / MSecsPerDay; + Result := True; + end; +end; + +function EncodeTime(Hour, Min, Sec, MSec: Word): TDateTime; +begin + if not TryEncodeTime(Hour, Min, Sec, MSec, Result) then + ConvertError(STimeEncodeError); +end; + +procedure DecodeTime(const DateTime: TDateTime; var Hour, Min, Sec, MSec: Word); +var + MinCount, MSecCount: Word; +begin + DivMod(DateTimeToTimeStamp(DateTime).Time, SecsPerMin * MSecsPerSec, MinCount, MSecCount); + DivMod(MinCount, MinsPerHour, Hour, Min); + DivMod(MSecCount, MSecsPerSec, Sec, MSec); +end; + +{ Date encoding and decoding } + +function IsLeapYear(Year: Word): Boolean; +begin + Result := (Year mod 4 = 0) and ((Year mod 100 <> 0) or (Year mod 400 = 0)); +end; + +function TryEncodeDate(Year, Month, Day: Word; out Date: TDateTime): Boolean; +var + I: Integer; + DayTable: PDayTable; +begin + Result := False; + DayTable := @MonthDays[IsLeapYear(Year)]; + if (Year >= 1) and (Year <= 9999) and (Month >= 1) and (Month <= 12) and + (Day >= 1) and (Day <= DayTable^[Month]) then + begin + for I := 1 to Month - 1 do Inc(Day, DayTable^[I]); + I := Year - 1; + Date := I * 365 + I div 4 - I div 100 + I div 400 + Day - DateDelta; + Result := True; + end; +end; + +function EncodeDate(Year, Month, Day: Word): TDateTime; +begin + if not TryEncodeDate(Year, Month, Day, Result) then + ConvertError(SDateEncodeError); +end; + +function DecodeDateFully(const DateTime: TDateTime; var Year, Month, Day, DOW: Word): Boolean; +const + D1 = 365; + D4 = D1 * 4 + 1; + D100 = D4 * 25 - 1; + D400 = D100 * 4 + 1; +var + Y, M, D, I: Word; + T: Integer; + DayTable: PDayTable; +begin + T := DateTimeToTimeStamp(DateTime).Date; + if T <= 0 then + begin + Year := 0; + Month := 0; + Day := 0; + DOW := 0; + Result := False; + end else + begin + DOW := T mod 7 + 1; + Dec(T); + Y := 1; + while T >= D400 do + begin + Dec(T, D400); + Inc(Y, 400); + end; + DivMod(T, D100, I, D); + if I = 4 then + begin + Dec(I); + Inc(D, D100); + end; + Inc(Y, I * 100); + DivMod(D, D4, I, D); + Inc(Y, I * 4); + DivMod(D, D1, I, D); + if I = 4 then + begin + Dec(I); + Inc(D, D1); + end; + Inc(Y, I); + Result := IsLeapYear(Y); + DayTable := @MonthDays[Result]; + M := 1; + while True do + begin + I := DayTable^[M]; + if D < I then Break; + Dec(D, I); + Inc(M); + end; + Year := Y; + Month := M; + Day := D + 1; + end; +end; + +function InternalDecodeDate(const DateTime: TDateTime; var Year, Month, Day, DOW: Word): Boolean; +begin + Result := DecodeDateFully(DateTime, Year, Month, Day, DOW); + Dec(DOW); +end; + +procedure DecodeDate(const DateTime: TDateTime; var Year, Month, Day: Word); +var + Dummy: Word; +begin + DecodeDateFully(DateTime, Year, Month, Day, Dummy); +end; + +{$IFDEF MSWINDOWS} +procedure DateTimeToSystemTime(const DateTime: TDateTime; var SystemTime: TSystemTime); +begin + with SystemTime do + begin + DecodeDateFully(DateTime, wYear, wMonth, wDay, wDayOfWeek); + Dec(wDayOfWeek); + DecodeTime(DateTime, wHour, wMinute, wSecond, wMilliseconds); + end; +end; + +function SystemTimeToDateTime(const SystemTime: TSystemTime): TDateTime; +begin + with SystemTime do + begin + Result := EncodeDate(wYear, wMonth, wDay); + if Result >= 0 then + Result := Result + EncodeTime(wHour, wMinute, wSecond, wMilliSeconds) + else + Result := Result - EncodeTime(wHour, wMinute, wSecond, wMilliSeconds); + end; +end; +{$ENDIF} + +function DayOfWeek(const DateTime: TDateTime): Word; +begin + Result := DateTimeToTimeStamp(DateTime).Date mod 7 + 1; +end; + +function Date: TDateTime; +{$IFDEF MSWINDOWS} +var + SystemTime: TSystemTime; +begin + GetLocalTime(SystemTime); + with SystemTime do Result := EncodeDate(wYear, wMonth, wDay); +end; +{$ENDIF} +{$IFDEF LINUX} +var + T: TTime_T; + UT: TUnixTime; +begin + __time(@T); + localtime_r(@T, UT); + Result := EncodeDate(UT.tm_year + 1900, UT.tm_mon + 1, UT.tm_mday); +end; +{$ENDIF} + +function Time: TDateTime; +{$IFDEF MSWINDOWS} +var + SystemTime: TSystemTime; +begin + GetLocalTime(SystemTime); + with SystemTime do + Result := EncodeTime(wHour, wMinute, wSecond, wMilliSeconds); +end; +{$ENDIF} +{$IFDEF LINUX} +var + T: TTime_T; + TV: TTimeVal; + UT: TUnixTime; +begin + gettimeofday(TV, nil); + T := TV.tv_sec; + localtime_r(@T, UT); + Result := EncodeTime(UT.tm_hour, UT.tm_min, UT.tm_sec, TV.tv_usec div 1000); +end; +{$ENDIF} + +function GetTime: TDateTime; +begin + Result := Time; +end; + +function Now: TDateTime; +{$IFDEF MSWINDOWS} +var + SystemTime: TSystemTime; +begin + GetLocalTime(SystemTime); + with SystemTime do + Result := EncodeDate(wYear, wMonth, wDay) + + EncodeTime(wHour, wMinute, wSecond, wMilliseconds); +end; +{$ENDIF} +{$IFDEF LINUX} +var + T: TTime_T; + TV: TTimeVal; + UT: TUnixTime; +begin + gettimeofday(TV, nil); + T := TV.tv_sec; + localtime_r(@T, UT); + Result := EncodeDate(UT.tm_year + 1900, UT.tm_mon + 1, UT.tm_mday) + + EncodeTime(UT.tm_hour, UT.tm_min, UT.tm_sec, TV.tv_usec div 1000); +end; +{$ENDIF} + +function IncMonth(const DateTime: TDateTime; NumberOfMonths: Integer): TDateTime; +var + Year, Month, Day: Word; +begin + DecodeDate(DateTime, Year, Month, Day); + IncAMonth(Year, Month, Day, NumberOfMonths); + Result := EncodeDate(Year, Month, Day); + ReplaceTime(Result, DateTime); +end; + +procedure IncAMonth(var Year, Month, Day: Word; NumberOfMonths: Integer = 1); +var + DayTable: PDayTable; + Sign: Integer; +begin + if NumberOfMonths >= 0 then Sign := 1 else Sign := -1; + Year := Year + (NumberOfMonths div 12); + NumberOfMonths := NumberOfMonths mod 12; + Inc(Month, NumberOfMonths); + if Word(Month-1) > 11 then // if Month <= 0, word(Month-1) > 11) + begin + Inc(Year, Sign); + Inc(Month, -12 * Sign); + end; + DayTable := @MonthDays[IsLeapYear(Year)]; + if Day > DayTable^[Month] then Day := DayTable^[Month]; +end; + +procedure ReplaceTime(var DateTime: TDateTime; const NewTime: TDateTime); +begin + DateTime := Trunc(DateTime); + if DateTime >= 0 then + DateTime := DateTime + Abs(Frac(NewTime)) + else + DateTime := DateTime - Abs(Frac(NewTime)); +end; + +procedure ReplaceDate(var DateTime: TDateTime; const NewDate: TDateTime); +var + Temp: TDateTime; +begin + Temp := NewDate; + ReplaceTime(Temp, DateTime); + DateTime := Temp; +end; + +function CurrentYear: Word; +{$IFDEF MSWINDOWS} +var + SystemTime: TSystemTime; +begin + GetLocalTime(SystemTime); + Result := SystemTime.wYear; +end; +{$ENDIF} +{$IFDEF LINUX} +var + T: TTime_T; + UT: TUnixTime; +begin + __time(@T); + localtime_r(@T, UT); + Result := UT.tm_year + 1900; +end; +{$ENDIF} + +{ Date/time to string conversions } + +procedure DateTimeToString(var Result: string; const Format: string; + DateTime: TDateTime); +var + BufPos, AppendLevel: Integer; + Buffer: array[0..255] of Char; + + procedure AppendChars(P: PChar; Count: Integer); + var + N: Integer; + begin + N := SizeOf(Buffer) - BufPos; + if N > Count then N := Count; + if N <> 0 then Move(P[0], Buffer[BufPos], N); + Inc(BufPos, N); + end; + + procedure AppendString(const S: string); + begin + AppendChars(Pointer(S), Length(S)); + end; + + procedure AppendNumber(Number, Digits: Integer); + const + Format: array[0..3] of Char = '%.*d'; + var + NumBuf: array[0..15] of Char; + begin + AppendChars(NumBuf, FormatBuf(NumBuf, SizeOf(NumBuf), Format, + SizeOf(Format), [Digits, Number])); + end; + + procedure AppendFormat(Format: PChar); + var + Starter, Token, LastToken: Char; + DateDecoded, TimeDecoded, Use12HourClock, + BetweenQuotes: Boolean; + P: PChar; + Count: Integer; + Year, Month, Day, Hour, Min, Sec, MSec, H: Word; + + procedure GetCount; + var + P: PChar; + begin + P := Format; + while Format^ = Starter do Inc(Format); + Count := Format - P + 1; + end; + + procedure GetDate; + begin + if not DateDecoded then + begin + DecodeDate(DateTime, Year, Month, Day); + DateDecoded := True; + end; + end; + + procedure GetTime; + begin + if not TimeDecoded then + begin + DecodeTime(DateTime, Hour, Min, Sec, MSec); + TimeDecoded := True; + end; + end; + +{$IFDEF MSWINDOWS} + function ConvertEraString(const Count: Integer) : string; + var + FormatStr: string; + SystemTime: TSystemTime; + Buffer: array[Byte] of Char; + P: PChar; + begin + Result := ''; + with SystemTime do + begin + wYear := Year; + wMonth := Month; + wDay := Day; + end; + + FormatStr := 'gg'; + if GetDateFormat(GetThreadLocale, DATE_USE_ALT_CALENDAR, @SystemTime, + PChar(FormatStr), Buffer, SizeOf(Buffer)) <> 0 then + begin + Result := Buffer; + if Count = 1 then + begin + case SysLocale.PriLangID of + LANG_JAPANESE: + Result := Copy(Result, 1, CharToBytelen(Result, 1)); + LANG_CHINESE: + if (SysLocale.SubLangID = SUBLANG_CHINESE_TRADITIONAL) + and (ByteToCharLen(Result, Length(Result)) = 4) then + begin + P := Buffer + CharToByteIndex(Result, 3) - 1; + SetString(Result, P, CharToByteLen(P, 2)); + end; + end; + end; + end; + end; + + function ConvertYearString(const Count: Integer): string; + var + FormatStr: string; + SystemTime: TSystemTime; + Buffer: array[Byte] of Char; + begin + Result := ''; + with SystemTime do + begin + wYear := Year; + wMonth := Month; + wDay := Day; + end; + + if Count <= 2 then + FormatStr := 'yy' // avoid Win95 bug. + else + FormatStr := 'yyyy'; + + if GetDateFormat(GetThreadLocale, DATE_USE_ALT_CALENDAR, @SystemTime, + PChar(FormatStr), Buffer, SizeOf(Buffer)) <> 0 then + begin + Result := Buffer; + if (Count = 1) and (Result[1] = '0') then + Result := Copy(Result, 2, Length(Result)-1); + end; + end; +{$ENDIF} + +{$IFDEF LINUX} + function FindEra(Date: Integer): Byte; + var + I : Byte; + begin + Result := 0; + for I := 1 to EraCount do + begin + if (EraRanges[I].StartDate <= Date) and + (EraRanges[I].EndDate >= Date) then + begin + Result := I; + Exit; + end; + end; + end; + + function ConvertEraString(const Count: Integer) : String; + var + I : Byte; + begin + Result := ''; + I := FindEra(Trunc(DateTime)); + if I > 0 then + Result := EraNames[I]; + end; + + function ConvertYearString(const Count: Integer) : String; + var + I : Byte; + S : string; + begin + I := FindEra(Trunc(DateTime)); + if I > 0 then + S := IntToStr(Year - EraYearOffsets[I]) + else + S := IntToStr(Year); + while Length(S) < Count do + S := '0' + S; + if Length(S) > Count then + S := Copy(S, Length(S) - (Count - 1), Count); + Result := S; + end; +{$ENDIF} + + begin + if (Format <> nil) and (AppendLevel < 2) then + begin + Inc(AppendLevel); + LastToken := ' '; + DateDecoded := False; + TimeDecoded := False; + Use12HourClock := False; + while Format^ <> #0 do + begin + Starter := Format^; + if Starter in LeadBytes then + begin + AppendChars(Format, StrCharLength(Format)); + Format := StrNextChar(Format); + LastToken := ' '; + Continue; + end; + Format := StrNextChar(Format); + Token := Starter; + if Token in ['a'..'z'] then Dec(Token, 32); + if Token in ['A'..'Z'] then + begin + if (Token = 'M') and (LastToken = 'H') then Token := 'N'; + LastToken := Token; + end; + case Token of + 'Y': + begin + GetCount; + GetDate; + if Count <= 2 then + AppendNumber(Year mod 100, 2) else + AppendNumber(Year, 4); + end; + 'G': + begin + GetCount; + GetDate; + AppendString(ConvertEraString(Count)); + end; + 'E': + begin + GetCount; + GetDate; + AppendString(ConvertYearString(Count)); + end; + 'M': + begin + GetCount; + GetDate; + case Count of + 1, 2: AppendNumber(Month, Count); + 3: AppendString(ShortMonthNames[Month]); + else + AppendString(LongMonthNames[Month]); + end; + end; + 'D': + begin + GetCount; + case Count of + 1, 2: + begin + GetDate; + AppendNumber(Day, Count); + end; + 3: AppendString(ShortDayNames[DayOfWeek(DateTime)]); + 4: AppendString(LongDayNames[DayOfWeek(DateTime)]); + 5: AppendFormat(Pointer(ShortDateFormat)); + else + AppendFormat(Pointer(LongDateFormat)); + end; + end; + 'H': + begin + GetCount; + GetTime; + BetweenQuotes := False; + P := Format; + while P^ <> #0 do + begin + if P^ in LeadBytes then + begin + P := StrNextChar(P); + Continue; + end; + case P^ of + 'A', 'a': + if not BetweenQuotes then + begin + if ( (StrLIComp(P, 'AM/PM', 5) = 0) + or (StrLIComp(P, 'A/P', 3) = 0) + or (StrLIComp(P, 'AMPM', 4) = 0) ) then + Use12HourClock := True; + Break; + end; + 'H', 'h': + Break; + '''', '"': BetweenQuotes := not BetweenQuotes; + end; + Inc(P); + end; + H := Hour; + if Use12HourClock then + if H = 0 then H := 12 else if H > 12 then Dec(H, 12); + if Count > 2 then Count := 2; + AppendNumber(H, Count); + end; + 'N': + begin + GetCount; + GetTime; + if Count > 2 then Count := 2; + AppendNumber(Min, Count); + end; + 'S': + begin + GetCount; + GetTime; + if Count > 2 then Count := 2; + AppendNumber(Sec, Count); + end; + 'T': + begin + GetCount; + if Count = 1 then + AppendFormat(Pointer(ShortTimeFormat)) else + AppendFormat(Pointer(LongTimeFormat)); + end; + 'Z': + begin + GetCount; + GetTime; + if Count > 3 then Count := 3; + AppendNumber(MSec, Count); + end; + 'A': + begin + GetTime; + P := Format - 1; + if StrLIComp(P, 'AM/PM', 5) = 0 then + begin + if Hour >= 12 then Inc(P, 3); + AppendChars(P, 2); + Inc(Format, 4); + Use12HourClock := TRUE; + end else + if StrLIComp(P, 'A/P', 3) = 0 then + begin + if Hour >= 12 then Inc(P, 2); + AppendChars(P, 1); + Inc(Format, 2); + Use12HourClock := TRUE; + end else + if StrLIComp(P, 'AMPM', 4) = 0 then + begin + if Hour < 12 then + AppendString(TimeAMString) else + AppendString(TimePMString); + Inc(Format, 3); + Use12HourClock := TRUE; + end else + if StrLIComp(P, 'AAAA', 4) = 0 then + begin + GetDate; + AppendString(LongDayNames[DayOfWeek(DateTime)]); + Inc(Format, 3); + end else + if StrLIComp(P, 'AAA', 3) = 0 then + begin + GetDate; + AppendString(ShortDayNames[DayOfWeek(DateTime)]); + Inc(Format, 2); + end else + AppendChars(@Starter, 1); + end; + 'C': + begin + GetCount; + AppendFormat(Pointer(ShortDateFormat)); + GetTime; + if (Hour <> 0) or (Min <> 0) or (Sec <> 0) then + begin + AppendChars(' ', 1); + AppendFormat(Pointer(LongTimeFormat)); + end; + end; + '/': + if DateSeparator <> #0 then + AppendChars(@DateSeparator, 1); + ':': + if TimeSeparator <> #0 then + AppendChars(@TimeSeparator, 1); + '''', '"': + begin + P := Format; + while (Format^ <> #0) and (Format^ <> Starter) do + begin + if Format^ in LeadBytes then + Format := StrNextChar(Format) + else + Inc(Format); + end; + AppendChars(P, Format - P); + if Format^ <> #0 then Inc(Format); + end; + else + AppendChars(@Starter, 1); + end; + end; + Dec(AppendLevel); + end; + end; + +begin + BufPos := 0; + AppendLevel := 0; + if Format <> '' then AppendFormat(Pointer(Format)) else AppendFormat('C'); + SetString(Result, Buffer, BufPos); +end; + +procedure DateTimeToString(var Result: string; const Format: string; + DateTime: TDateTime; const FormatSettings: TFormatSettings); +var + BufPos, AppendLevel: Integer; + Buffer: array[0..255] of Char; + + procedure AppendChars(P: PChar; Count: Integer); + var + N: Integer; + begin + N := SizeOf(Buffer) - BufPos; + if N > Count then N := Count; + if N <> 0 then Move(P[0], Buffer[BufPos], N); + Inc(BufPos, N); + end; + + procedure AppendString(const S: string); + begin + AppendChars(Pointer(S), Length(S)); + end; + + procedure AppendNumber(Number, Digits: Integer); + const + Format: array[0..3] of Char = '%.*d'; + var + NumBuf: array[0..15] of Char; + begin + AppendChars(NumBuf, FormatBuf(NumBuf, SizeOf(NumBuf), Format, + SizeOf(Format), [Digits, Number])); + end; + + procedure AppendFormat(Format: PChar); + var + Starter, Token, LastToken: Char; + DateDecoded, TimeDecoded, Use12HourClock, + BetweenQuotes: Boolean; + P: PChar; + Count: Integer; + Year, Month, Day, Hour, Min, Sec, MSec, H: Word; + + procedure GetCount; + var + P: PChar; + begin + P := Format; + while Format^ = Starter do Inc(Format); + Count := Format - P + 1; + end; + + procedure GetDate; + begin + if not DateDecoded then + begin + DecodeDate(DateTime, Year, Month, Day); + DateDecoded := True; + end; + end; + + procedure GetTime; + begin + if not TimeDecoded then + begin + DecodeTime(DateTime, Hour, Min, Sec, MSec); + TimeDecoded := True; + end; + end; + +{$IFDEF MSWINDOWS} + function ConvertEraString(const Count: Integer) : string; + var + FormatStr: string; + SystemTime: TSystemTime; + Buffer: array[Byte] of Char; + P: PChar; + begin + Result := ''; + with SystemTime do + begin + wYear := Year; + wMonth := Month; + wDay := Day; + end; + + FormatStr := 'gg'; + if GetDateFormat(GetThreadLocale, DATE_USE_ALT_CALENDAR, @SystemTime, + PChar(FormatStr), Buffer, SizeOf(Buffer)) <> 0 then + begin + Result := Buffer; + if Count = 1 then + begin + case SysLocale.PriLangID of + LANG_JAPANESE: + Result := Copy(Result, 1, CharToBytelen(Result, 1)); + LANG_CHINESE: + if (SysLocale.SubLangID = SUBLANG_CHINESE_TRADITIONAL) + and (ByteToCharLen(Result, Length(Result)) = 4) then + begin + P := Buffer + CharToByteIndex(Result, 3) - 1; + SetString(Result, P, CharToByteLen(P, 2)); + end; + end; + end; + end; + end; + + function ConvertYearString(const Count: Integer): string; + var + FormatStr: string; + SystemTime: TSystemTime; + Buffer: array[Byte] of Char; + begin + Result := ''; + with SystemTime do + begin + wYear := Year; + wMonth := Month; + wDay := Day; + end; + + if Count <= 2 then + FormatStr := 'yy' // avoid Win95 bug. + else + FormatStr := 'yyyy'; + + if GetDateFormat(GetThreadLocale, DATE_USE_ALT_CALENDAR, @SystemTime, + PChar(FormatStr), Buffer, SizeOf(Buffer)) <> 0 then + begin + Result := Buffer; + if (Count = 1) and (Result[1] = '0') then + Result := Copy(Result, 2, Length(Result)-1); + end; + end; +{$ENDIF} + +{$IFDEF LINUX} + function FindEra(Date: Integer): Byte; + var + I : Byte; + begin + Result := 0; + for I := 1 to EraCount do + begin + if (EraRanges[I].StartDate <= Date) and + (EraRanges[I].EndDate >= Date) then + begin + Result := I; + Exit; + end; + end; + end; + + function ConvertEraString(const Count: Integer) : String; + var + I : Byte; + begin + Result := ''; + I := FindEra(Trunc(DateTime)); + if I > 0 then + Result := EraNames[I]; + end; + + function ConvertYearString(const Count: Integer) : String; + var + I : Byte; + S : string; + begin + I := FindEra(Trunc(DateTime)); + if I > 0 then + S := IntToStr(Year - EraYearOffsets[I]) + else + S := IntToStr(Year); + while Length(S) < Count do + S := '0' + S; + if Length(S) > Count then + S := Copy(S, Length(S) - (Count - 1), Count); + Result := S; + end; +{$ENDIF} + + begin + if (Format <> nil) and (AppendLevel < 2) then + begin + Inc(AppendLevel); + LastToken := ' '; + DateDecoded := False; + TimeDecoded := False; + Use12HourClock := False; + while Format^ <> #0 do + begin + Starter := Format^; + if Starter in LeadBytes then + begin + AppendChars(Format, StrCharLength(Format)); + Format := StrNextChar(Format); + LastToken := ' '; + Continue; + end; + Format := StrNextChar(Format); + Token := Starter; + if Token in ['a'..'z'] then Dec(Token, 32); + if Token in ['A'..'Z'] then + begin + if (Token = 'M') and (LastToken = 'H') then Token := 'N'; + LastToken := Token; + end; + case Token of + 'Y': + begin + GetCount; + GetDate; + if Count <= 2 then + AppendNumber(Year mod 100, 2) else + AppendNumber(Year, 4); + end; + 'G': + begin + GetCount; + GetDate; + AppendString(ConvertEraString(Count)); + end; + 'E': + begin + GetCount; + GetDate; + AppendString(ConvertYearString(Count)); + end; + 'M': + begin + GetCount; + GetDate; + case Count of + 1, 2: AppendNumber(Month, Count); + 3: AppendString(FormatSettings.ShortMonthNames[Month]); + else + AppendString(FormatSettings.LongMonthNames[Month]); + end; + end; + 'D': + begin + GetCount; + case Count of + 1, 2: + begin + GetDate; + AppendNumber(Day, Count); + end; + 3: AppendString(FormatSettings.ShortDayNames[DayOfWeek(DateTime)]); + 4: AppendString(FormatSettings.LongDayNames[DayOfWeek(DateTime)]); + 5: AppendFormat(Pointer(FormatSettings.ShortDateFormat)); + else + AppendFormat(Pointer(FormatSettings.LongDateFormat)); + end; + end; + 'H': + begin + GetCount; + GetTime; + BetweenQuotes := False; + P := Format; + while P^ <> #0 do + begin + if P^ in LeadBytes then + begin + P := StrNextChar(P); + Continue; + end; + case P^ of + 'A', 'a': + if not BetweenQuotes then + begin + if ( (StrLIComp(P, 'AM/PM', 5) = 0) + or (StrLIComp(P, 'A/P', 3) = 0) + or (StrLIComp(P, 'AMPM', 4) = 0) ) then + Use12HourClock := True; + Break; + end; + 'H', 'h': + Break; + '''', '"': BetweenQuotes := not BetweenQuotes; + end; + Inc(P); + end; + H := Hour; + if Use12HourClock then + if H = 0 then H := 12 else if H > 12 then Dec(H, 12); + if Count > 2 then Count := 2; + AppendNumber(H, Count); + end; + 'N': + begin + GetCount; + GetTime; + if Count > 2 then Count := 2; + AppendNumber(Min, Count); + end; + 'S': + begin + GetCount; + GetTime; + if Count > 2 then Count := 2; + AppendNumber(Sec, Count); + end; + 'T': + begin + GetCount; + if Count = 1 then + AppendFormat(Pointer(FormatSettings.ShortTimeFormat)) else + AppendFormat(Pointer(FormatSettings.LongTimeFormat)); + end; + 'Z': + begin + GetCount; + GetTime; + if Count > 3 then Count := 3; + AppendNumber(MSec, Count); + end; + 'A': + begin + GetTime; + P := Format - 1; + if StrLIComp(P, 'AM/PM', 5) = 0 then + begin + if Hour >= 12 then Inc(P, 3); + AppendChars(P, 2); + Inc(Format, 4); + Use12HourClock := TRUE; + end else + if StrLIComp(P, 'A/P', 3) = 0 then + begin + if Hour >= 12 then Inc(P, 2); + AppendChars(P, 1); + Inc(Format, 2); + Use12HourClock := TRUE; + end else + if StrLIComp(P, 'AMPM', 4) = 0 then + begin + if Hour < 12 then + AppendString(FormatSettings.TimeAMString) else + AppendString(FormatSettings.TimePMString); + Inc(Format, 3); + Use12HourClock := TRUE; + end else + if StrLIComp(P, 'AAAA', 4) = 0 then + begin + GetDate; + AppendString(FormatSettings.LongDayNames[DayOfWeek(DateTime)]); + Inc(Format, 3); + end else + if StrLIComp(P, 'AAA', 3) = 0 then + begin + GetDate; + AppendString(FormatSettings.ShortDayNames[DayOfWeek(DateTime)]); + Inc(Format, 2); + end else + AppendChars(@Starter, 1); + end; + 'C': + begin + GetCount; + AppendFormat(Pointer(FormatSettings.ShortDateFormat)); + GetTime; + if (Hour <> 0) or (Min <> 0) or (Sec <> 0) then + begin + AppendChars(' ', 1); + AppendFormat(Pointer(FormatSettings.LongTimeFormat)); + end; + end; + '/': + if DateSeparator <> #0 then + AppendChars(@FormatSettings.DateSeparator, 1); + ':': + if TimeSeparator <> #0 then + AppendChars(@FormatSettings.TimeSeparator, 1); + '''', '"': + begin + P := Format; + while (Format^ <> #0) and (Format^ <> Starter) do + begin + if Format^ in LeadBytes then + Format := StrNextChar(Format) + else + Inc(Format); + end; + AppendChars(P, Format - P); + if Format^ <> #0 then Inc(Format); + end; + else + AppendChars(@Starter, 1); + end; + end; + Dec(AppendLevel); + end; + end; + +begin + BufPos := 0; + AppendLevel := 0; + if Format <> '' then AppendFormat(Pointer(Format)) else AppendFormat('C'); + SetString(Result, Buffer, BufPos); +end; + +function TryFloatToDateTime(const Value: Extended; out AResult: TDateTime): Boolean; +begin + Result := not ((Value < MinDateTime) or (Value >= Int(MaxDateTime) + 1.0)); + if Result then + AResult := Value; +end; + +function FloatToDateTime(const Value: Extended): TDateTime; +begin + if not TryFloatToDateTime(Value, Result) then + ConvertErrorFmt(SInvalidDateTimeFloat, [Value]); +end; + +function DateToStr(const DateTime: TDateTime): string; +begin + DateTimeToString(Result, ShortDateFormat, DateTime); +end; + +function DateToStr(const DateTime: TDateTime; + const FormatSettings: TFormatSettings): string; +begin + DateTimeToString(Result, FormatSettings.ShortDateFormat, DateTime, + FormatSettings); +end; + +function TimeToStr(const DateTime: TDateTime): string; +begin + DateTimeToString(Result, LongTimeFormat, DateTime); +end; + +function TimeToStr(const DateTime: TDateTime; + const FormatSettings: TFormatSettings): string; +begin + DateTimeToString(Result, FormatSettings.LongTimeFormat, DateTime, + FormatSettings); +end; + +function DateTimeToStr(const DateTime: TDateTime): string; +begin + DateTimeToString(Result, '', DateTime); +end; + +function DateTimeToStr(const DateTime: TDateTime; + const FormatSettings: TFormatSettings): string; +begin + DateTimeToString(Result, '', DateTime, FormatSettings); +end; + +function FormatDateTime(const Format: string; DateTime: TDateTime): string; +begin + DateTimeToString(Result, Format, DateTime); +end; + +function FormatDateTime(const Format: string; DateTime: TDateTime; + const FormatSettings: TFormatSettings): string; +begin + DateTimeToString(Result, Format, DateTime, FormatSettings); +end; + +{ String to date/time conversions } + +type + TDateOrder = (doMDY, doDMY, doYMD); + +procedure ScanBlanks(const S: string; var Pos: Integer); +var + I: Integer; +begin + I := Pos; + while (I <= Length(S)) and (S[I] = ' ') do Inc(I); + Pos := I; +end; + +function ScanNumber(const S: string; var Pos: Integer; + var Number: Word; var CharCount: Byte): Boolean; +var + I: Integer; + N: Word; +begin + Result := False; + CharCount := 0; + ScanBlanks(S, Pos); + I := Pos; + N := 0; + while (I <= Length(S)) and (S[I] in ['0'..'9']) and (N < 1000) do + begin + N := N * 10 + (Ord(S[I]) - Ord('0')); + Inc(I); + end; + if I > Pos then + begin + CharCount := I - Pos; + Pos := I; + Number := N; + Result := True; + end; +end; + +function ScanString(const S: string; var Pos: Integer; + const Symbol: string): Boolean; +begin + Result := False; + if Symbol <> '' then + begin + ScanBlanks(S, Pos); + if AnsiCompareText(Symbol, Copy(S, Pos, Length(Symbol))) = 0 then + begin + Inc(Pos, Length(Symbol)); + Result := True; + end; + end; +end; + +function ScanChar(const S: string; var Pos: Integer; Ch: Char): Boolean; +begin + Result := False; + ScanBlanks(S, Pos); + if (Pos <= Length(S)) and (S[Pos] = Ch) then + begin + Inc(Pos); + Result := True; + end; +end; + +function GetDateOrder(const DateFormat: string): TDateOrder; +var + I: Integer; +begin + Result := doMDY; + I := 1; + while I <= Length(DateFormat) do + begin + case Chr(Ord(DateFormat[I]) and $DF) of + 'E': Result := doYMD; + 'Y': Result := doYMD; + 'M': Result := doMDY; + 'D': Result := doDMY; + else + Inc(I); + Continue; + end; + Exit; + end; + Result := doMDY; +end; + +procedure ScanToNumber(const S: string; var Pos: Integer); +begin + while (Pos <= Length(S)) and not (S[Pos] in ['0'..'9']) do + begin + if S[Pos] in LeadBytes then + Pos := NextCharIndex(S, Pos) + else + Inc(Pos); + end; +end; + +function GetEraYearOffset(const Name: string): Integer; +var + I: Integer; +begin + Result := 0; + for I := Low(EraNames) to High(EraNames) do + begin + if EraNames[I] = '' then Break; + if AnsiStrPos(PChar(EraNames[I]), PChar(Name)) <> nil then + begin + Result := EraYearOffsets[I]; + Exit; + end; + end; +end; + +function ScanDate(const S: string; var Pos: Integer; + var Date: TDateTime): Boolean; overload; +var + DateOrder: TDateOrder; + N1, N2, N3, Y, M, D: Word; + L1, L2, L3, YearLen: Byte; + CenturyBase: Integer; + EraName : string; + EraYearOffset: Integer; + + function EraToYear(Year: Integer): Integer; + begin +{$IFDEF MSWINDOWS} + if SysLocale.PriLangID = LANG_KOREAN then + begin + if Year <= 99 then + Inc(Year, (CurrentYear + Abs(EraYearOffset)) div 100 * 100); + if EraYearOffset > 0 then + EraYearOffset := -EraYearOffset; + end + else + Dec(EraYearOffset); +{$ENDIF} + Result := Year + EraYearOffset; + end; + +begin + Y := 0; + M := 0; + D := 0; + YearLen := 0; + Result := False; + DateOrder := GetDateOrder(ShortDateFormat); + EraYearOffset := 0; + if ShortDateFormat[1] = 'g' then // skip over prefix text + begin + ScanToNumber(S, Pos); + EraName := Trim(Copy(S, 1, Pos-1)); + EraYearOffset := GetEraYearOffset(EraName); + end + else + if AnsiPos('e', ShortDateFormat) > 0 then + EraYearOffset := EraYearOffsets[1]; + if not (ScanNumber(S, Pos, N1, L1) and ScanChar(S, Pos, DateSeparator) and + ScanNumber(S, Pos, N2, L2)) then Exit; + if ScanChar(S, Pos, DateSeparator) then + begin + if not ScanNumber(S, Pos, N3, L3) then Exit; + case DateOrder of + doMDY: begin Y := N3; YearLen := L3; M := N1; D := N2; end; + doDMY: begin Y := N3; YearLen := L3; M := N2; D := N1; end; + doYMD: begin Y := N1; YearLen := L1; M := N2; D := N3; end; + end; + if EraYearOffset > 0 then + Y := EraToYear(Y) + else + if (YearLen <= 2) then + begin + CenturyBase := CurrentYear - TwoDigitYearCenturyWindow; + Inc(Y, CenturyBase div 100 * 100); + if (TwoDigitYearCenturyWindow > 0) and (Y < CenturyBase) then + Inc(Y, 100); + end; + end else + begin + Y := CurrentYear; + if DateOrder = doDMY then + begin + D := N1; M := N2; + end else + begin + M := N1; D := N2; + end; + end; + ScanChar(S, Pos, DateSeparator); + ScanBlanks(S, Pos); + if SysLocale.FarEast and (System.Pos('ddd', ShortDateFormat) <> 0) then + begin // ignore trailing text + if ShortTimeFormat[1] in ['0'..'9'] then // stop at time digit + ScanToNumber(S, Pos) + else // stop at time prefix + repeat + while (Pos <= Length(S)) and (S[Pos] <> ' ') do Inc(Pos); + ScanBlanks(S, Pos); + until (Pos > Length(S)) or + (AnsiCompareText(TimeAMString, Copy(S, Pos, Length(TimeAMString))) = 0) or + (AnsiCompareText(TimePMString, Copy(S, Pos, Length(TimePMString))) = 0); + end; + Result := TryEncodeDate(Y, M, D, Date); +end; + +function ScanDate(const S: string; var Pos: Integer; var Date: TDateTime; + const FormatSettings: TFormatSettings): Boolean; overload; +var + DateOrder: TDateOrder; + N1, N2, N3, Y, M, D: Word; + L1, L2, L3, YearLen: Byte; + CenturyBase: Integer; + EraName : string; + EraYearOffset: Integer; + + function EraToYear(Year: Integer): Integer; + begin +{$IFDEF MSWINDOWS} + if SysLocale.PriLangID = LANG_KOREAN then + begin + if Year <= 99 then + Inc(Year, (CurrentYear + Abs(EraYearOffset)) div 100 * 100); + if EraYearOffset > 0 then + EraYearOffset := -EraYearOffset; + end + else + Dec(EraYearOffset); +{$ENDIF} + Result := Year + EraYearOffset; + end; + +begin + Y := 0; + M := 0; + D := 0; + YearLen := 0; + Result := False; + DateOrder := GetDateOrder(FormatSettings.ShortDateFormat); + EraYearOffset := 0; + if FormatSettings.ShortDateFormat[1] = 'g' then // skip over prefix text + begin + ScanToNumber(S, Pos); + EraName := Trim(Copy(S, 1, Pos-1)); + EraYearOffset := GetEraYearOffset(EraName); + end + else + if AnsiPos('e', FormatSettings.ShortDateFormat) > 0 then + EraYearOffset := EraYearOffsets[1]; + if not (ScanNumber(S, Pos, N1, L1) and ScanChar(S, Pos, FormatSettings.DateSeparator) and + ScanNumber(S, Pos, N2, L2)) then Exit; + if ScanChar(S, Pos, FormatSettings.DateSeparator) then + begin + if not ScanNumber(S, Pos, N3, L3) then Exit; + case DateOrder of + doMDY: begin Y := N3; YearLen := L3; M := N1; D := N2; end; + doDMY: begin Y := N3; YearLen := L3; M := N2; D := N1; end; + doYMD: begin Y := N1; YearLen := L1; M := N2; D := N3; end; + end; + if EraYearOffset > 0 then + Y := EraToYear(Y) + else + if (YearLen <= 2) then + begin + CenturyBase := CurrentYear - FormatSettings.TwoDigitYearCenturyWindow; + Inc(Y, CenturyBase div 100 * 100); + if (FormatSettings.TwoDigitYearCenturyWindow > 0) and (Y < CenturyBase) then + Inc(Y, 100); + end; + end else + begin + Y := CurrentYear; + if DateOrder = doDMY then + begin + D := N1; M := N2; + end else + begin + M := N1; D := N2; + end; + end; + ScanChar(S, Pos, FormatSettings.DateSeparator); + ScanBlanks(S, Pos); + if SysLocale.FarEast and (System.Pos('ddd', FormatSettings.ShortDateFormat) <> 0) then + begin // ignore trailing text + if FormatSettings.ShortTimeFormat[1] in ['0'..'9'] then // stop at time digit + ScanToNumber(S, Pos) + else // stop at time prefix + repeat + while (Pos <= Length(S)) and (S[Pos] <> ' ') do Inc(Pos); + ScanBlanks(S, Pos); + until (Pos > Length(S)) or + (AnsiCompareText(FormatSettings.TimeAMString, + Copy(S, Pos, Length(FormatSettings.TimeAMString))) = 0) or + (AnsiCompareText(FormatSettings.TimePMString, + Copy(S, Pos, Length(FormatSettings.TimePMString))) = 0); + end; + Result := TryEncodeDate(Y, M, D, Date); +end; + +function ScanTime(const S: string; var Pos: Integer; + var Time: TDateTime): Boolean; overload; +var + BaseHour: Integer; + Hour, Min, Sec, MSec: Word; + Junk: Byte; +begin + Result := False; + BaseHour := -1; + if ScanString(S, Pos, TimeAMString) or ScanString(S, Pos, 'AM') then + BaseHour := 0 + else if ScanString(S, Pos, TimePMString) or ScanString(S, Pos, 'PM') then + BaseHour := 12; + if BaseHour >= 0 then ScanBlanks(S, Pos); + if not ScanNumber(S, Pos, Hour, Junk) then Exit; + Min := 0; + Sec := 0; + MSec := 0; + if ScanChar(S, Pos, TimeSeparator) then + begin + if not ScanNumber(S, Pos, Min, Junk) then Exit; + if ScanChar(S, Pos, TimeSeparator) then + begin + if not ScanNumber(S, Pos, Sec, Junk) then Exit; + if ScanChar(S, Pos, DecimalSeparator) then + if not ScanNumber(S, Pos, MSec, Junk) then Exit; + end; + end; + if BaseHour < 0 then + if ScanString(S, Pos, TimeAMString) or ScanString(S, Pos, 'AM') then + BaseHour := 0 + else + if ScanString(S, Pos, TimePMString) or ScanString(S, Pos, 'PM') then + BaseHour := 12; + if BaseHour >= 0 then + begin + if (Hour = 0) or (Hour > 12) then Exit; + if Hour = 12 then Hour := 0; + Inc(Hour, BaseHour); + end; + ScanBlanks(S, Pos); + Result := TryEncodeTime(Hour, Min, Sec, MSec, Time); +end; + +function ScanTime(const S: string; var Pos: Integer; var Time: TDateTime; + const FormatSettings: TFormatSettings): Boolean; overload; +var + BaseHour: Integer; + Hour, Min, Sec, MSec: Word; + Junk: Byte; +begin + Result := False; + BaseHour := -1; + if ScanString(S, Pos, FormatSettings.TimeAMString) or ScanString(S, Pos, 'AM') then + BaseHour := 0 + else if ScanString(S, Pos, FormatSettings.TimePMString) or ScanString(S, Pos, 'PM') then + BaseHour := 12; + if BaseHour >= 0 then ScanBlanks(S, Pos); + if not ScanNumber(S, Pos, Hour, Junk) then Exit; + Min := 0; + Sec := 0; + MSec := 0; + if ScanChar(S, Pos, FormatSettings.TimeSeparator) then + begin + if not ScanNumber(S, Pos, Min, Junk) then Exit; + if ScanChar(S, Pos, FormatSettings.TimeSeparator) then + begin + if not ScanNumber(S, Pos, Sec, Junk) then Exit; + if ScanChar(S, Pos, FormatSettings.DecimalSeparator) then + if not ScanNumber(S, Pos, MSec, Junk) then Exit; + end; + end; + if BaseHour < 0 then + if ScanString(S, Pos, FormatSettings.TimeAMString) or ScanString(S, Pos, 'AM') then + BaseHour := 0 + else + if ScanString(S, Pos, FormatSettings.TimePMString) or ScanString(S, Pos, 'PM') then + BaseHour := 12; + if BaseHour >= 0 then + begin + if (Hour = 0) or (Hour > 12) then Exit; + if Hour = 12 then Hour := 0; + Inc(Hour, BaseHour); + end; + ScanBlanks(S, Pos); + Result := TryEncodeTime(Hour, Min, Sec, MSec, Time); +end; + +function StrToDate(const S: string): TDateTime; +begin + if not TryStrToDate(S, Result) then + ConvertErrorFmt(SInvalidDate, [S]); +end; + +function StrToDate(const S: string; + const FormatSettings: TFormatSettings): TDateTime; +begin + if not TryStrToDate(S, Result, FormatSettings) then + ConvertErrorFmt(SInvalidDate, [S]); +end; + +function StrToDateDef(const S: string; const Default: TDateTime): TDateTime; +begin + if not TryStrToDate(S, Result) then + Result := Default; +end; + +function StrToDateDef(const S: string; const Default: TDateTime; + const FormatSettings: TFormatSettings): TDateTime; +begin + if not TryStrToDate(S, Result, FormatSettings) then + Result := Default; +end; + +function TryStrToDate(const S: string; out Value: TDateTime): Boolean; +var + Pos: Integer; +begin + Pos := 1; + Result := ScanDate(S, Pos, Value) and (Pos > Length(S)); +end; + +function TryStrToDate(const S: string; out Value: TDateTime; + const FormatSettings: TFormatSettings): Boolean; +var + Pos: Integer; +begin + Pos := 1; + Result := ScanDate(S, Pos, Value, FormatSettings) and (Pos > Length(S)); +end; + +function StrToTime(const S: string): TDateTime; +begin + if not TryStrToTime(S, Result) then + ConvertErrorFmt(SInvalidTime, [S]); +end; + +function StrToTime(const S: string; + const FormatSettings: TFormatSettings): TDateTime; +begin + if not TryStrToTime(S, Result, FormatSettings) then + ConvertErrorFmt(SInvalidTime, [S]); +end; + +function StrToTimeDef(const S: string; const Default: TDateTime): TDateTime; +begin + if not TryStrToTime(S, Result) then + Result := Default; +end; + +function StrToTimeDef(const S: string; const Default: TDateTime; + const FormatSettings: TFormatSettings): TDateTime; +begin + if not TryStrToTime(S, Result, FormatSettings) then + Result := Default; +end; + +function TryStrToTime(const S: string; out Value: TDateTime): Boolean; +var + Pos: Integer; +begin + Pos := 1; + Result := ScanTime(S, Pos, Value) and (Pos > Length(S)); +end; + +function TryStrToTime(const S: string; out Value: TDateTime; + const FormatSettings: TFormatSettings): Boolean; +var + Pos: Integer; +begin + Pos := 1; + Result := ScanTime(S, Pos, Value, FormatSettings) and (Pos > Length(S)); +end; + +function StrToDateTime(const S: string): TDateTime; +begin + if not TryStrToDateTime(S, Result) then + ConvertErrorFmt(SInvalidDateTime, [S]); +end; + +function StrToDateTime(const S: string; + const FormatSettings: TFormatSettings): TDateTime; +begin + if not TryStrToDateTime(S, Result, FormatSettings) then + ConvertErrorFmt(SInvalidDateTime, [S]); +end; + +function StrToDateTimeDef(const S: string; const Default: TDateTime): TDateTime; +begin + if not TryStrToDateTime(S, Result) then + Result := Default; +end; + +function StrToDateTimeDef(const S: string; const Default: TDateTime; + const FormatSettings: TFormatSettings): TDateTime; +begin + if not TryStrToDateTime(S, Result, FormatSettings) then + Result := Default; +end; + +function TryStrToDateTime(const S: string; out Value: TDateTime): Boolean; +var + Pos: Integer; + Date, Time: TDateTime; +begin + Result := True; + Pos := 1; + Time := 0; + if not ScanDate(S, Pos, Date) or + not ((Pos > Length(S)) or ScanTime(S, Pos, Time)) then + + // Try time only + Result := TryStrToTime(S, Value) + else + if Date >= 0 then + Value := Date + Time + else + Value := Date - Time; +end; + +function TryStrToDateTime(const S: string; out Value: TDateTime; + const FormatSettings: TFormatSettings): Boolean; +var + Pos: Integer; + Date, Time: TDateTime; +begin + Result := True; + Pos := 1; + Time := 0; + if not ScanDate(S, Pos, Date, FormatSettings) or + not ((Pos > Length(S)) or ScanTime(S, Pos, Time, FormatSettings)) then + + // Try time only + Result := TryStrToTime(S, Value, FormatSettings) + else + if Date >= 0 then + Value := Date + Time + else + Value := Date - Time; +end; + +{ System error messages } + +function SysErrorMessage(ErrorCode: Integer): string; +var + Buffer: array[0..255] of Char; +{$IFDEF MSWINDOWS} +var + Len: Integer; +begin + Len := FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_IGNORE_INSERTS or + FORMAT_MESSAGE_ARGUMENT_ARRAY, nil, ErrorCode, 0, Buffer, + SizeOf(Buffer), nil); + while (Len > 0) and (Buffer[Len - 1] in [#0..#32, '.']) do Dec(Len); + SetString(Result, Buffer, Len); +end; +{$ENDIF} +{$IFDEF LINUX} +begin + //Result := Format('System error: %4x',[ErrorCode]); + Result := strerror_r(ErrorCode, Buffer, sizeof(Buffer)); +end; +{$ENDIF} + +{ Initialization file support } + +function GetLocaleStr(Locale, LocaleType: Integer; const Default: string): string; +{$IFDEF MSWINDOWS} +var + L: Integer; + Buffer: array[0..255] of Char; +begin + L := GetLocaleInfo(Locale, LocaleType, Buffer, SizeOf(Buffer)); + if L > 0 then SetString(Result, Buffer, L - 1) else Result := Default; +end; +{$ENDIF} +{$IFDEF LINUX} +begin + Result := Default; +end; +{$ENDIF} + +function GetLocaleChar(Locale, LocaleType: Integer; Default: Char): Char; +{$IFDEF MSWINDOWS} +var + Buffer: array[0..1] of Char; +begin + if GetLocaleInfo(Locale, LocaleType, Buffer, 2) > 0 then + Result := Buffer[0] else + Result := Default; +end; +{$ENDIF} +{$IFDEF LINUX} +begin + Result := Default; +end; +{$ENDIF} + +{var + DefShortMonthNames: array[1..12] of Pointer = (@SShortMonthNameJan, + @SShortMonthNameFeb, @SShortMonthNameMar, @SShortMonthNameApr, + @SShortMonthNameMay, @SShortMonthNameJun, @SShortMonthNameJul, + @SShortMonthNameAug, @SShortMonthNameSep, @SShortMonthNameOct, + @SShortMonthNameNov, @SShortMonthNameDec); + + DefLongMonthNames: array[1..12] of Pointer = (@SLongMonthNameJan, + @SLongMonthNameFeb, @SLongMonthNameMar, @SLongMonthNameApr, + @SLongMonthNameMay, @SLongMonthNameJun, @SLongMonthNameJul, + @SLongMonthNameAug, @SLongMonthNameSep, @SLongMonthNameOct, + @SLongMonthNameNov, @SLongMonthNameDec); + + DefShortDayNames: array[1..7] of Pointer = (@SShortDayNameSun, + @SShortDayNameMon, @SShortDayNameTue, @SShortDayNameWed, + @SShortDayNameThu, @SShortDayNameFri, @SShortDayNameSat); + + DefLongDayNames: array[1..7] of Pointer = (@SLongDayNameSun, + @SLongDayNameMon, @SLongDayNameTue, @SLongDayNameWed, + @SLongDayNameThu, @SLongDayNameFri, @SLongDayNameSat); + } +procedure GetMonthDayNames; +{$IFDEF MSWINDOWS} +var + I, Day: Integer; + DefaultLCID: LCID; + + function LocalGetLocaleStr(LocaleType: Integer): string; + begin + Result := GetLocaleStr(DefaultLCID, LocaleType, ''); + if Result = '' then Result := GetLocaleStr($409, LocaleType, ''); + //Result := LoadResString(DefValues[Index]); + end; + +begin + DefaultLCID := GetThreadLocale; + for I := 1 to 12 do + begin + ShortMonthNames[I] := LocalGetLocaleStr(LOCALE_SABBREVMONTHNAME1 + I - 1); + LongMonthNames[I] := LocalGetLocaleStr(LOCALE_SMONTHNAME1 + I - 1); + end; + for I := 1 to 7 do + begin + Day := (I + 5) mod 7; + ShortDayNames[I] := LocalGetLocaleStr(LOCALE_SABBREVDAYNAME1 + Day); + LongDayNames[I] := LocalGetLocaleStr(LOCALE_SDAYNAME1 + Day); + end; +end; +{$ELSE} +{$IFDEF LINUX} + function GetLocaleStr(LocaleIndex, Index: Integer; + const DefValues: array of Pointer): string; + var + temp: PChar; + begin + temp := nl_langinfo(LocaleIndex); + if (temp = nil) or (temp^ = #0) then + Result := LoadResString(DefValues[Index]) + else + Result := temp; + end; + +var + I: Integer; +begin + for I := 1 to 12 do + begin + ShortMonthNames[I] := GetLocaleStr(ABMON_1 + I - 1, + I - Low(DefShortMonthNames), DefShortMonthNames); + LongMonthNames[I] := GetLocaleStr(MON_1 + I - 1, + I - Low(DefLongMonthNames), DefLongMonthNames); + end; + for I := 1 to 7 do + begin + ShortDayNames[I] := GetLocaleStr(ABDAY_1 + I - 1, + I - Low(DefShortDayNames), DefShortDayNames); + LongDayNames[I] := GetLocaleStr(DAY_1 + I - 1, + I - Low(DefLongDayNames), DefLongDayNames); + end; +end; +{$ELSE} +var + I: Integer; +begin + for I := 1 to 12 do + begin + ShortMonthNames[I] := LoadResString(DefShortMonthNames[I]); + LongMonthNames[I] := LoadResString(DefLongMonthNames[I]); + end; + for I := 1 to 7 do + begin + ShortDayNames[I] := LoadResString(DefShortDayNames[I]); + LongDayNames[I] := LoadResString(DefLongDayNames[I]); + end; +end; +{$ENDIF} +{$ENDIF} + +{$IFDEF MSWINDOWS} +procedure GetLocaleMonthDayNames(DefaultLCID: Integer; + var FormatSettings: TFormatSettings); +var + I, Day: Integer; + + function LocalGetLocaleStr(LocaleType: Integer): string; + begin + Result := GetLocaleStr(DefaultLCID, LocaleType, ''); + if Result = '' then Result := GetLocaleStr($409, LocaleType, ''); + end; + +begin + for I := 1 to 12 do + begin + FormatSettings.ShortMonthNames[I] := LocalGetLocaleStr(LOCALE_SABBREVMONTHNAME1 + I - 1); + FormatSettings.LongMonthNames[I] := LocalGetLocaleStr(LOCALE_SMONTHNAME1 + I - 1); + end; + for I := 1 to 7 do + begin + Day := (I + 5) mod 7; + FormatSettings.ShortDayNames[I] := LocalGetLocaleStr(LOCALE_SABBREVDAYNAME1 + Day); + FormatSettings.LongDayNames[I] := LocalGetLocaleStr(LOCALE_SDAYNAME1 + Day); + end; +end; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function EnumEraNames(Names: PChar): Integer; stdcall; +var + I: Integer; +begin + Result := 0; + I := Low(EraNames); + while EraNames[I] <> '' do + if (I = High(EraNames)) then + Exit + else Inc(I); + EraNames[I] := Names; + Result := 1; +end; + +function EnumEraYearOffsets(YearOffsets: PChar): Integer; stdcall; +var + I: Integer; +begin + Result := 0; + I := Low(EraYearOffsets); + while EraYearOffsets[I] <> -1 do + if (I = High(EraYearOffsets)) then + Exit + else Inc(I); + EraYearOffsets[I] := StrToIntDef(YearOffsets, 0); + Result := 1; +end; + +procedure GetEraNamesAndYearOffsets; +var + J: Integer; + CalendarType: CALTYPE; +begin + CalendarType := StrToIntDef(GetLocaleStr(GetThreadLocale, + LOCALE_IOPTIONALCALENDAR, '1'), 1); + if CalendarType in [CAL_JAPAN, CAL_TAIWAN, CAL_KOREA] then + begin + EnumCalendarInfoA(@EnumEraNames, GetThreadLocale, CalendarType, + CAL_SERASTRING); + for J := Low(EraYearOffsets) to High(EraYearOffsets) do + EraYearOffsets[J] := -1; + EnumCalendarInfoA(@EnumEraYearOffsets, GetThreadLocale, CalendarType, + CAL_IYEAROFFSETRANGE); + end; +end; + +function TranslateDateFormat(const FormatStr: string): string; +var + I: Integer; + L: Integer; + CalendarType: CALTYPE; + RemoveEra: Boolean; +begin + I := 1; + Result := ''; + CalendarType := StrToIntDef(GetLocaleStr(GetThreadLocale, + LOCALE_ICALENDARTYPE, '1'), 1); + if not (CalendarType in [CAL_JAPAN, CAL_TAIWAN, CAL_KOREA]) then + begin + RemoveEra := SysLocale.PriLangID in [LANG_JAPANESE, LANG_CHINESE, LANG_KOREAN]; + if RemoveEra then + begin + While I <= Length(FormatStr) do + begin + if not (FormatStr[I] in ['g', 'G']) then + Result := Result + FormatStr[I]; + Inc(I); + end; + end + else + Result := FormatStr; + Exit; + end; + + while I <= Length(FormatStr) do + begin + if FormatStr[I] in LeadBytes then + begin + L := CharLength(FormatStr, I); + Result := Result + Copy(FormatStr, I, L); + Inc(I, L); + end else + begin + if StrLIComp(@FormatStr[I], 'gg', 2) = 0 then + begin + Result := Result + 'ggg'; + Inc(I, 1); + end + else if StrLIComp(@FormatStr[I], 'yyyy', 4) = 0 then + begin + Result := Result + 'eeee'; + Inc(I, 4-1); + end + else if StrLIComp(@FormatStr[I], 'yy', 2) = 0 then + begin + Result := Result + 'ee'; + Inc(I, 2-1); + end + else if FormatStr[I] in ['y', 'Y'] then + Result := Result + 'e' + else + Result := Result + FormatStr[I]; + Inc(I); + end; + end; +end; +{$ENDIF} + +{$IFDEF LINUX} +procedure InitEras; +var + Count : Byte; + I, J, Pos : Integer; + Number : Word; + S : string; + Year, Month, Day: Word; +begin + EraCount := 0; + S := nl_langinfo(ERA); + if S = '' then + S := LoadResString(@SEraEntries); + + Pos := 1; + for I := 1 to MaxEraCount do + begin + if Pos > Length(S) then Break; + if not(ScanChar(S, Pos, '+') or ScanChar(S, Pos, '-')) then Break; + // Eras in which year increases with negative time (eg Christian BC era) + // are not currently supported. +// EraRanges[I].Direction := S[Pos - 1]; + + // Era offset, in years from Gregorian calendar year + if not ScanChar(S, Pos, ':') then Break; + if ScanChar(S, Pos, '-') then + J := -1 + else + J := 1; + if not ScanNumber(S, Pos, Number, Count) then Break; + EraYearOffsets[I] := J * Number; // apply sign to Number + + // Era start date, in Gregorian year/month/day format + if not ScanChar(S, Pos, ':') then Break; + if not ScanNumber(S, Pos, Year, Count) then Break; + if not ScanChar(S, Pos, '/') then Break; + if not ScanNumber(S, Pos, Month, Count) then Break; + if not ScanChar(S, Pos, '/') then Break; + if not ScanNumber(S, Pos, Day, Count) then Break; + EraRanges[I].StartDate := Trunc(EncodeDate(Year, Month, Day)); + EraYearOffsets[I] := Year - EraYearOffsets[I]; + + // Era end date, in Gregorian year/month/day format + if not ScanChar(S, Pos, ':') then Break; + if ScanString(S, Pos, '+*') then // positive infinity + EraRanges[I].EndDate := High(EraRanges[I].EndDate) + else if ScanString(S, Pos, '-*') then // negative infinity + EraRanges[I].EndDate := Low(EraRanges[I].EndDate) + else if not ScanNumber(S, Pos, Year, Count) then + Break + else + begin + if not ScanChar(S, Pos, '/') then Break; + if not ScanNumber(S, Pos, Month, Count) then Break; + if not ScanChar(S, Pos, '/') then Break; + if not ScanNumber(S, Pos, Day, Count) then Break; + EraRanges[I].EndDate := Trunc(EncodeDate(Year, Month, Day)); + end; + + // Era name, in locale charset + if not ScanChar(S, Pos, ':') then Break; + J := AnsiPos(':', Copy(S, Pos, Length(S) + 1 - Pos)); + if J = 0 then Break; + EraNames[I] := Copy(S, Pos, J - 1); + Inc(Pos, J - 1); + + // Optional Era format string for era year, in locale charset + if not ScanChar(S, Pos, ':') then Break; + J := AnsiPos(';', Copy(S, Pos, Length(S) + 1 - Pos)); + if J = 0 then + J := 1 + Length(S) + 1 - Pos; + {if J = 0 then Break;} + EraYearFormats[I] := Copy(S, Pos, J - 1); + Inc(Pos, J - 1); + Inc(EraCount); + if not((Pos > Length(S)) or ScanChar(S, Pos, ';')) then Break; + end; + + // Clear the rest of the era slots, including partial entry from failed parse + for I := EraCount+1 to MaxEraCount do + begin + EraNames[I] := ''; + EraYearOffsets[I] := -1; + EraRanges[I].StartDate := High(EraRanges[I].StartDate); + EraRanges[I].EndDate := High(EraRanges[I].EndDate); + EraYearFormats[I] := ''; + end; +end; +{$ENDIF} + +{ Exception handling routines } + +var + OutOfMemory: EOutOfMemory; + InvalidPointer: EInvalidPointer; + +{ Convert physical address to logical address } + +{ Format and return an exception error message } + +function ExceptionErrorMessage(ExceptObject: TObject; ExceptAddr: Pointer; + Buffer: PChar; Size: Integer): Integer; +{$IFDEF MSWINDOWS} + + function ConvertAddr(Address: Pointer): Pointer; assembler; + asm + TEST EAX,EAX { Always convert nil to nil } + JE @@1 + SUB EAX, $1000 { offset from code start; code start set by linker to $1000 } + @@1: + end; + +var + MsgPtr: PChar; + MsgEnd: PChar; + MsgLen: Integer; + ModuleName: array[0..MAX_PATH] of Char; + Temp: array[0..MAX_PATH] of Char; + //Format: array[0..255] of Char; + Info: TMemoryBasicInformation; + ConvertedAddress: Pointer; +begin + VirtualQuery(ExceptAddr, Info, sizeof(Info)); + if (Info.State <> MEM_COMMIT) or + (GetModuleFilename(THandle(Info.AllocationBase), Temp, SizeOf(Temp)) = 0) then + begin + GetModuleFileName(HInstance, Temp, SizeOf(Temp)); + ConvertedAddress := ConvertAddr(ExceptAddr); + end + else + Integer(ConvertedAddress) := Integer(ExceptAddr) - Integer(Info.AllocationBase); + StrLCopy(ModuleName, AnsiStrRScan(Temp, '\') + 1, SizeOf(ModuleName) - 1); + MsgPtr := ''; + MsgEnd := ''; + if ExceptObject is Exception then + begin + MsgPtr := PChar(Exception(ExceptObject).Message); + MsgLen := StrLen(MsgPtr); + if (MsgLen <> 0) and (MsgPtr[MsgLen - 1] <> '.') then MsgEnd := '.'; + end; + {LoadString(FindResourceHInstance(HInstance), + PResStringRec(@SException).Identifier, Format, SizeOf(Format)); + StrLFmt(Buffer, Size, Format, [ExceptObject.ClassName, ModuleName, + ConvertedAddress, MsgPtr, MsgEnd]); } + StrPCopy(Buffer, kol.Format(SException, [ExceptObject.ClassName, ModuleName, + ConvertedAddress, MsgPtr, MsgEnd]) ); + Result := StrLen(Buffer); +end; +{$ENDIF} +{$IFDEF LINUX} +const + UnknownModuleName = ''; +var + MsgPtr: PChar; + MsgEnd: PChar; + MsgLen: Integer; + ModuleName: array[0..MAX_PATH] of Char; + Info: TDLInfo; +begin + MsgPtr := ''; + MsgEnd := ''; + if ExceptObject is Exception then + begin + MsgPtr := PChar(Exception(ExceptObject).Message); + MsgLen := StrLen(MsgPtr); + if (MsgLen <> 0) and (MsgPtr[MsgLen - 1] <> '.') then MsgEnd := '.'; + end; + if (dladdr(ExceptAddr, Info) <> 0) and (Info.dli_fname <> nil) then + StrLCopy(ModuleName, AnsiStrRScan(Info.dli_fname, PathDelim) + 1, SizeOf(ModuleName) - 1) + else + StrLCopy(ModuleName, UnknownModuleName, SizeOf(ModuleName) - 1); + StrLFmt(Buffer, Size, PChar(SException), [ExceptObject.ClassName, ModuleName, + ExceptAddr, MsgPtr, MsgEnd]); + Result := StrLen(Buffer); +end; +{$ENDIF} + +{ Display exception message box } + +procedure ShowException(ExceptObject: TObject; ExceptAddr: Pointer); +{$IFDEF MSWINDOWS} +var + //Title: array[0..63] of Char; + Buffer: array[0..1023] of Char; + Dummy: Cardinal; +begin + ExceptionErrorMessage(ExceptObject, ExceptAddr, Buffer, SizeOf(Buffer)); + if IsConsole then + begin + Flush(Output); + CharToOemA(Buffer, Buffer); + WriteFile(GetStdHandle(STD_ERROR_HANDLE), Buffer, StrLen(Buffer), Dummy, nil); + WriteFile(GetStdHandle(STD_ERROR_HANDLE), sLineBreak, 2, Dummy, nil); + end + else + begin + { LoadString(FindResourceHInstance(HInstance), PResStringRec(@SExceptTitle).Identifier, + Title, SizeOf(Title)); + MessageBox(0, Buffer, Title, MB_OK or MB_ICONSTOP or MB_TASKMODAL); } + MessageBox(0, Buffer, PChar(SExceptTitle), MB_OK or MB_ICONSTOP or MB_TASKMODAL); + end; +end; +{$ENDIF} +{$IFDEF LINUX} +var + Buffer: array[0..1023] of Char; +begin + ExceptionErrorMessage(ExceptObject, ExceptAddr, Buffer, Sizeof(Buffer)); + if TTextRec(ErrOutput).Mode = fmOutput then + Flush(ErrOutput); + __write(STDERR_FILENO, Buffer, StrLen(Buffer)); +end; +{$ENDIF} + +{ Raise abort exception } + +procedure Abort; + + function ReturnAddr: Pointer; + asm + MOV EAX,[EBP + 4] + end; + +begin + raise EAbort.CreateRes(SOperationAborted) at ReturnAddr; +end; + +{ Raise out of memory exception } + +procedure OutOfMemoryError; +begin + raise OutOfMemory; +end; + +{ Exception class } + +constructor Exception.Create(const Msg: string); +begin + FMessage := Msg; +end; + +constructor Exception.CreateFmt(const Msg: string; + const Args: array of const); +begin + FMessage := Format(Msg, Args); +end; + +constructor Exception.CreateRes(Ident: Integer); +begin + FMessage := LoadStr(Ident); +end; + +constructor Exception.CreateRes(const ResStringRec: string); +begin + FMessage := ResStringRec; +end; + +constructor Exception.CreateResFmt(Ident: Integer; + const Args: array of const); +begin + FMessage := Format(LoadStr(Ident), Args); +end; + +constructor Exception.CreateResFmt(const ResStringRec: string; + const Args: array of const); +begin + FMessage := Format(ResStringRec, Args); +end; + +constructor Exception.CreateHelp(const Msg: string; AHelpContext: Integer); +begin + FMessage := Msg; + FHelpContext := AHelpContext; +end; + +constructor Exception.CreateFmtHelp(const Msg: string; const Args: array of const; + AHelpContext: Integer); +begin + FMessage := Format(Msg, Args); + FHelpContext := AHelpContext; +end; + +constructor Exception.CreateResHelp(Ident: Integer; AHelpContext: Integer); +begin + FMessage := LoadStr(Ident); + FHelpContext := AHelpContext; +end; + +constructor Exception.CreateResHelp(ResStringRec: PResStringRec; + AHelpContext: Integer); +begin + FMessage := LoadResString(ResStringRec); + FHelpContext := AHelpContext; +end; + +constructor Exception.CreateResFmtHelp(Ident: Integer; + const Args: array of const; + AHelpContext: Integer); +begin + FMessage := Format(LoadStr(Ident), Args); + FHelpContext := AHelpContext; +end; + +constructor Exception.CreateResFmtHelp(ResStringRec: PResStringRec; + const Args: array of const; + AHelpContext: Integer); +begin + FMessage := Format(LoadResString(ResStringRec), Args); + FHelpContext := AHelpContext; +end; + +{ EHeapException class } + +procedure EHeapException.FreeInstance; +begin + if AllowFree then + inherited FreeInstance; +end; + +{ Create I/O exception } + +function CreateInOutError: EInOutError; +type + TErrorRec = record + Code: Integer; + Ident: string; + end; +const + ErrorMap: array[0..6] of TErrorRec = ( + (Code: 2; Ident: SFileNotFound), + (Code: 3; Ident: SInvalidFilename), + (Code: 4; Ident: STooManyOpenFiles), + (Code: 5; Ident: SAccessDenied), + (Code: 100; Ident: SEndOfFile), + (Code: 101; Ident: SDiskFull), + (Code: 106; Ident: SInvalidInput)); +var + I: Integer; + InOutRes: Integer; +begin + I := Low(ErrorMap); + InOutRes := IOResult; // resets IOResult to zero + while (I <= High(ErrorMap)) and (ErrorMap[I].Code <> InOutRes) do Inc(I); + if I <= High(ErrorMap) then + Result := EInOutError.Create(ErrorMap[I].Ident) else + Result := EInOutError.CreateResFmt(SInOutError, [InOutRes]); + Result.ErrorCode := InOutRes; +end; + +{ RTL error handler } + +type + TExceptRec = record + EClass: ExceptClass; + EIdent: string; + end; + +const + ExceptMap: array[Ord(reDivByZero)..Ord(High(TRuntimeError))] of TExceptRec = ( + (EClass: EDivByZero; EIdent: SDivByZero), + (EClass: ERangeError; EIdent: SRangeError), + (EClass: EIntOverflow; EIdent: SIntOverflow), + (EClass: EInvalidOp; EIdent: SInvalidOp), + (EClass: EZeroDivide; EIdent: SZeroDivide), + (EClass: EOverflow; EIdent: SOverflow), + (EClass: EUnderflow; EIdent: SUnderflow), + (EClass: EInvalidCast; EIdent: SInvalidCast), + (EClass: EAccessViolation; EIdent: SAccessViolationNoArg), + (EClass: EPrivilege; EIdent: SPrivilege), + (EClass: EControlC; EIdent: SControlC), + (EClass: EStackOverflow; EIdent: SStackOverflow), + (EClass: EVariantError; EIdent: SInvalidVarCast), + (EClass: EVariantError; EIdent: SInvalidVarOp), + (EClass: EVariantError; EIdent: SDispatchError), + (EClass: EVariantError; EIdent: SVarArrayCreate), + (EClass: EVariantError; EIdent: SVarInvalid), + (EClass: EVariantError; EIdent: SVarArrayBounds), + (EClass: EAssertionFailed; EIdent: SAssertionFailed), + (EClass: EExternalException; EIdent: SExternalException), + (EClass: EIntfCastError; EIdent: SIntfCastError), + (EClass: ESafecallException; EIdent: SSafecallException) + {$IFDEF LINUX} + , + (EClass: EQuit; EIdent: SQuit), + (EClass: ECodesetConversion; EIdent: SCodesetConversionError) + {$ENDIF} + ); + +procedure ErrorHandler(ErrorCode: Byte; ErrorAddr: Pointer); export; +var + E: Exception; +begin + case ErrorCode of + Ord(reOutOfMemory): + E := OutOfMemory; + Ord(reInvalidPtr): + E := InvalidPointer; + Ord(reDivByZero)..Ord(High(TRuntimeError)): + begin + with ExceptMap[ErrorCode] do + E := EClass.Create(EIdent); + end; + else + E := CreateInOutError; + end; + raise E at ErrorAddr; +end; + +{ Assertion error handler } + +{ This is complicated by the desire to make it look like the exception } +{ happened in the user routine, so the debugger can give a decent stack } +{ trace. To make that feasible, AssertErrorHandler calls a helper function } +{ to create the exception object, so that AssertErrorHandler itself does } +{ not need any temps. After the exception object is created, the asm } +{ routine RaiseAssertException sets up the registers just as if the user } +{ code itself had raised the exception. } + +function CreateAssertException(const Message, Filename: string; + LineNumber: Integer): Exception; +var + S: string; +begin + if Message <> '' then S := Message else S := SAssertionFailed; + Result := EAssertionFailed.CreateFmt(SAssertError, + [S, Filename, LineNumber]); +end; + +{ This code is based on the following assumptions: } +{ - Our direct caller (AssertErrorHandler) has an EBP frame } +{ - ErrorStack points to where the return address would be if the } +{ user program had called System.@RaiseExcept directly } +procedure RaiseAssertException(const E: Exception; const ErrorAddr, ErrorStack: Pointer); +asm + MOV ESP,ECX + MOV [ESP],EDX + MOV EBP,[EBP] + JMP System.@RaiseExcept +end; + +{ If you change this procedure, make sure it does not have any local variables } +{ or temps that need cleanup - they won't get cleaned up due to the way } +{ RaiseAssertException frame works. Also, it can not have an exception frame. } +procedure AssertErrorHandler(const Message, Filename: string; + LineNumber: Integer; ErrorAddr: Pointer); +var + E: Exception; +begin + E := CreateAssertException(Message, Filename, LineNumber); +{$IF Defined(LINUX)} + RaiseAssertException(E, ErrorAddr, PChar(@ErrorAddr)+8); +{$ELSEIF Defined(MSWINDOWS)} + RaiseAssertException(E, ErrorAddr, PChar(@ErrorAddr)+4); +{$ELSE} + {$MESSAGE ERROR 'AssertErrorHandler not implemented'} +{$IFEND} +end; + +{$IFNDEF PC_MAPPED_EXCEPTIONS} + +{ Abstract method invoke error handler } + +procedure AbstractErrorHandler; +begin + raise EAbstractError.CreateRes(SAbstractError); +end; +{$ENDIF} + +{$IFDEF LINUX} +const + TRAP_ZERODIVIDE = 0; + TRAP_SINGLESTEP = 1; + TRAP_NMI = 2; + TRAP_BREAKPOINT = 3; + TRAP_OVERFLOW = 4; + TRAP_BOUND = 5; + TRAP_INVINSTR = 6; + TRAP_DEVICENA = 7; + TRAP_DOUBLEFAULT = 8; + TRAP_FPOVERRUN = 9; + TRAP_BADTSS = 10; + TRAP_SEGMENTNP = 11; + TRAP_STACKFAULT = 12; + TRAP_GPFAULT = 13; + TRAP_PAGEFAULT = 14; + TRAP_RESERVED = 15; + TRAP_FPE = 16; + TRAP_ALIGNMENT = 17; + TRAP_MACHINECHECK = 18; + TRAP_CACHEFAULT = 19; + TRAP_UNKNOWN = -1; + +function MapFPUStatus(Status: LongWord): TRuntimeError; +begin + if (Status and 1) = 1 then Result := System.reInvalidOp // STACK_CHECK or INVALID_OPERATION + else if (Status and 2) = 2 then Result := System.reInvalidOp // DENORMAL_OPERAND + else if (Status and 4) = 4 then Result := System.reZeroDivide // DIVIDE_BY_ZERO + else if (Status and 8) = 8 then Result := System.reOverflow // OVERFLOW + else if (Status and $10) = $10 then Result := System.reUnderflow // UNDERFLOW + else if (Status and $20) = $20 then Result := System.reInvalidOp // INEXACT_RESULT + else Result := System.reInvalidOp; +end; + +function MapFPE(Context: PSigContext): TRuntimeError; +begin + case Context^.trapno of + TRAP_ZERODIVIDE: + Result := System.reDivByZero; + TRAP_FPOVERRUN: + Result := System.reInvalidOp; + TRAP_FPE: + Result := MapFPUStatus(Context^.fpstate^.sw); + else + Result := System.reInvalidOp; + end; +end; + +function MapFault(Context: PSigContext): TRuntimeError; +begin + case Context^.trapno of + TRAP_OVERFLOW: + Result := System.reIntOverflow; + TRAP_BOUND: + Result := System.reRangeError; + TRAP_INVINSTR: + Result := System.rePrivInstruction; // This doesn't seem right, but we don't + // have an external exception to match! + TRAP_STACKFAULT: + Result := System.reStackOverflow; + TRAP_SEGMENTNP, + TRAP_GPFAULT: + Result := System.reAccessViolation; + TRAP_PAGEFAULT: + Result := System.reAccessViolation; + else + Result := System.reAccessViolation; + end; +end; + +function MapSignal(SigNum: Integer; Context: PSigContext): LongWord; +var + Err: TRuntimeError; +begin + case SigNum of + SIGINT: { Control-C } + Err := System.reControlBreak; + SIGQUIT: { Quit key (Control-\) } + Err := System.reQuit; + SIGFPE: { Floating Point Error } + Err := MapFPE(Context); + SIGSEGV: { Segmentation Violation } + Err := MapFault(Context); + SIGILL: { Illegal Instruction } + Err := MapFault(Context); + SIGBUS: { Bus Error } + Err := MapFault(Context); + else + Err := System.reExternalException; + end; + Result := LongWord(Err) or (LongWord(SigNum) shl 16); +end; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function MapException(P: PExceptionRecord): TRuntimeError; +begin + case P.ExceptionCode of + STATUS_INTEGER_DIVIDE_BY_ZERO: + Result := System.reDivByZero; + STATUS_ARRAY_BOUNDS_EXCEEDED: + Result := System.reRangeError; + STATUS_INTEGER_OVERFLOW: + Result := System.reIntOverflow; + STATUS_FLOAT_INEXACT_RESULT, + STATUS_FLOAT_INVALID_OPERATION, + STATUS_FLOAT_STACK_CHECK: + Result := System.reInvalidOp; + STATUS_FLOAT_DIVIDE_BY_ZERO: + Result := System.reZeroDivide; + STATUS_FLOAT_OVERFLOW: + Result := System.reOverflow; + STATUS_FLOAT_UNDERFLOW, + STATUS_FLOAT_DENORMAL_OPERAND: + Result := System.reUnderflow; + STATUS_ACCESS_VIOLATION: + Result := System.reAccessViolation; + STATUS_PRIVILEGED_INSTRUCTION: + Result := System.rePrivInstruction; + STATUS_CONTROL_C_EXIT: + Result := System.reControlBreak; + STATUS_STACK_OVERFLOW: + Result := System.reStackOverflow; + else + Result := System.reExternalException; + end; +end; + +function GetExceptionClass(P: PExceptionRecord): ExceptClass; +var + ErrorCode: Byte; +begin + ErrorCode := Byte(MapException(P)); + Result := ExceptMap[ErrorCode].EClass; +end; + +function GetExceptionObject(P: PExceptionRecord): Exception; +var + ErrorCode: Integer; + + function CreateAVObject: Exception; + var + AccessOp: string; // string ID indicating the access type READ or WRITE + AccessAddress: Pointer; + MemInfo: TMemoryBasicInformation; + ModName: array[0..MAX_PATH] of Char; + begin + with P^ do + begin + if ExceptionInformation[0] = 0 then + AccessOp := SReadAccess + else + AccessOp := SWriteAccess; + AccessAddress := Pointer(ExceptionInformation[1]); + VirtualQuery(ExceptionAddress, MemInfo, SizeOf(MemInfo)); + if (MemInfo.State = MEM_COMMIT) and + (GetModuleFileName(THandle(MemInfo.AllocationBase), ModName, SizeOf(ModName)) <> 0) then + Result := EAccessViolation.CreateFmt(sModuleAccessViolation, + [ExceptionAddress, ExtractFileName(ModName), AccessOp, + AccessAddress]) + else + Result := EAccessViolation.CreateFmt(SAccessViolationArg3, + [ExceptionAddress, AccessOp, AccessAddress]); + end; + end; + +begin + ErrorCode := Byte(MapException(P)); + case ErrorCode of + 3..10, 12..21: + with ExceptMap[ErrorCode] do Result := EClass.Create(EIdent); + 11: Result := CreateAVObject; + else + Result := EExternalException.CreateFmt(SExternalException, [P.ExceptionCode]); + end; + if Result is EExternal then EExternal(Result).ExceptionRecord := P; +end; +{$ENDIF} { WIN32 } + +{$IFDEF LINUX} +{ + The ErrorCode has the translated error code in the low byte and the + original signal number in the high word. +} +function GetExceptionObject(ExceptionAddress: LongWord; AccessAddress: LongWord; ErrorCode: LongWord): Exception; +begin + case (ErrorCode and $ff) of + 3..10, 12..21, 25: + begin + with ExceptMap[ErrorCode and $ff] do + Result := EClass.Create(EIdent); + end; + 11: + Result := EAccessViolation.CreateFmt(SAccessViolationArg2, [Pointer(ExceptionAddress), Pointer(AccessAddress)]); + else +// Result := EExternalException.CreateFmt(SExternalException, [P.ExceptionCode]); +{ Not quite right - we need the original trap code, but that's lost } + Result := EExternalException.CreateFmt(SExternalException, [ErrorCode and $ff]); + end; + + EExternal(Result).ExceptionAddress := ExceptionAddress; + EExternal(Result).AccessAddress := AccessAddress; + EExternal(Result).SignalNumber := ErrorCode shr 16; +end; +{$ENDIF} + +{ RTL exception handler } + +procedure ExceptHandler(ExceptObject: TObject; ExceptAddr: Pointer); far; +begin + ShowException(ExceptObject, ExceptAddr); + Halt(1); +end; + +{$IFDEF LINUX} +{$IFDEF DEBUG} +{ + Used for debugging the signal handlers. +} +procedure DumpContext(SigNum: Integer; context : PSigContext); +var + Buff: array [0..128] of char; +begin + StrFmt(Buff, 'Context for signal: %d', [SigNum]); + Writeln(Buff); + StrFmt(Buff, 'CS = %04X DS = %04X ES = %04X FS = %04X GS = %04X SS = %04X', + [context^.cs, context^.ds, context^.es, context^.fs, context^.gs, context^.ss]); + WriteLn(Buff); + StrFmt(Buff, 'EAX = %08X EBX = %08X ECX = %08X EDX = %08X', + [context^.eax, context^.ebx, context^.ecx, context^.edx]); + WriteLn(Buff); + StrFmt(Buff, 'EDI = %08X ESI = %08X EBP = %08X ESP = %08X', + [context^.edi, context^.esi, context^.ebp, context^.esp]); + WriteLn(Buff); + StrFmt(Buff, 'EIP = %08X EFLAGS = %08X ESP(signal) = %08X CR2 = %08X', + [context^.eip, context^.eflags, context^.esp_at_signal, context^.cr2]); + WriteLn(Buff); + StrFmt(Buff, 'trapno = %d, err = %08x', [context^.trapno, context^.err]); + WriteLn(Buff); +end; +{$ENDIF} + + +{ + RaiseSignalException is called from SignalConverter, once we've made things look + like there's a legitimate stack frame above us. Now we will just create + an exception object, and raise it via a software raise. +} +procedure RaiseSignalException(ExceptionEIP: LongWord; FaultAddr: LongWord; ErrorCode: LongWord); +begin + raise GetExceptionObject(ExceptionEIP, FaultAddr, ErrorCode); +end; + +{ + SignalConverter is where we come when a signal is raised that we want to convert + to an exception. This function stands the best chance of being called with a + useable stack frame behind it for the purpose of stack unwinding. We can't + guarantee that, though. The stack was modified by the baseline signal handler + to make it look as though we were called by the faulting instruction. That way + the unwinder stands a chance of being able to clean things up. +} +procedure SignalConverter(ExceptionEIP: LongWord; FaultAddr: LongWord; ErrorCode: LongWord); +asm + { + Here's the tricky part. We arrived here directly by virtue of our + signal handler tweaking the execution context with our address. That + means there's no return address on the stack. The unwinder needs to + have a return address so that it can unwind past this function when + we raise the Delphi exception. We will use the faulting instruction + pointer as a fake return address. Because of the fencepost conditions + in the Delphi unwinder, we need to have an address that is strictly + greater than the actual faulting instruction, so we increment that + address by one. This may be in the middle of an instruction, but we + don't care, because we will never be returning to that address. + Finally, the way that we get this address onto the stack is important. + The compiler will generate unwind information for SignalConverter that + will attempt to undo any stack modifications that are made by this + function when unwinding past it. In this particular case, we don't want + that to happen, so we use some assembly language tricks to get around + the compiler noticing the stack modification. + } + MOV EBX, ESP // Get the current stack pointer + SUB EBX, 4 // Effectively decrement the stack by 4 + MOV ESP, EBX // by doing a move to ESP with a register value + MOV [ESP], EAX // Store the instruction pointer into the new stack loc + INC [ESP] // Increment by one to keep the unwinder happy + + { Reset the FPU, or things can go south down the line from here } + FNINIT + FWAIT +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + MOV EAX, [EAX].offset Default8087CW + FLDCW [EAX] + POP ECX + POP EAX +{$ELSE} + FLDCW Default8087CW +{$ENDIF} + PUSH EBP + MOV EBP, ESP + CALL RaiseSignalException +end; + +function TlsGetValue(Key: Integer): Pointer; cdecl; + external libpthreadmodulename name 'pthread_getspecific'; + +{ + Under Linux, we crawl out from underneath the OS signal handler before + we attempt to do anything with the signal. This is because the stack + has a bunch of OS frames on there that we cannot possibly unwind from. + So we use this routine to accomplish the dispatch, and then another + routine to handle the language level of the exception handling. +} +procedure SignalDispatcher(SigNum: Integer; SigInfo: PSigInfo; UContext: PUserContext); cdecl; +type + PGeneralRegisters = ^gregset_t; +var + GeneralRegisters: PGeneralRegisters; +begin +//DumpContext(SigNum, @context); + + { + Some of the ways that we get here are can lead us to big trouble. For + example, if the signal is SIGINT or SIGQUIT, these will commonly be raised + to all threads in the process if the user generated them from the + keyboard. This is handled well by the Delphi threads, but if a non-Delphi + thread lets one of these get by unhandled, terrible things will happen. + So we look for that case, and eat SIGINT and SIGQUIT that have been issued + on threads that are not Delphi threads. If the signal is a SIGSEGV, or + other fatal sort of signal, and the thread that we're running on is not + a Delphi thread, then we are completely without options. We have no + recovery means, and we have to take the app down hard, right away. + } + if TlsGetValue(TlsIndex) = nil then + begin + if (SigNum = SIGINT) or (SigNum = SIGQUIT) then + Exit; + RunError(232); + end; + + { + If we are processing another exception right now, we definitely do not + want to be dispatching any exceptions that are async, like SIGINT and + SIGQUIT. So we have check to see if OS signals are blocked. If they are, + we have to eat this signal right now. + } + if AreOSExceptionsBlocked and ((SigNum = SIGINT) or (SigNum = SIGQUIT)) then + Exit; + + { + If someone wants to delay the handling of SIGINT or SIGQUIT until such + time as it's safe to handle it, they set DeferUserInterrupts to True. + Then we just set a global variable saying that a SIGINT or SIGQUIT was + issued. It is the responsibility of some other body of code at this + point to poll for changes to SIG(INT/QUIT)Issued + } + if DeferUserInterrupts then + begin + if SigNum = SIGINT then + begin + SIGINTIssued := True; + Exit; + end; + if SigNum = SIGQUIT then + begin + SIGQUITIssued := True; + Exit; + end; + end; + + BlockOSExceptions; + + GeneralRegisters := @UContext^.uc_mcontext.gregs; + + GeneralRegisters^[REG_EAX] := GeneralRegisters^[REG_EIP]; + GeneralRegisters^[REG_EDX] := UContext^.uc_mcontext.cr2; + GeneralRegisters^[REG_ECX] := MapSignal(SigNum, PSigContext(GeneralRegisters)); + + GeneralRegisters^[REG_EIP] := LongWord(@SignalConverter); +end; + +type + TSignalMap = packed record + SigNum: Integer; + Abandon: Boolean; + OldAction: TSigAction; + Hooked: Boolean; + end; + +var + Signals: array [0..RTL_SIGLAST] of TSignalMap = + ( (SigNum: SIGINT;), + (SigNum: SIGFPE;), + (SigNum: SIGSEGV;), + (SigNum: SIGILL;), + (SigNum: SIGBUS;), + (SigNum: SIGQUIT;) ); + +function InquireSignal(RtlSigNum: Integer): TSignalState; +var + Action: TSigAction; +begin + if sigaction(Signals[RtlSigNum].SigNum, nil, @Action) = -1 then + raise Exception.CreateRes(@SSigactionFailed); + if (@Action.__sigaction_handler <> @SignalDispatcher) then + begin + if Signals[RtlSigNum].Hooked then + Result := ssOverridden + else + Result := ssNotHooked; + end + else + Result := ssHooked; +end; + +procedure AbandonSignalHandler(RtlSigNum: Integer); +var + I: Integer; +begin + if RtlSigNum = RTL_SIGDEFAULT then + begin + for I := 0 to RTL_SIGLAST do + AbandonSignalHandler(I); + Exit; + end; + Signals[RtlSigNum].Abandon := True; +end; + +procedure HookSignal(RtlSigNum: Integer); +var + Action: TSigAction; + I: Integer; +begin + if RtlSigNum = RTL_SIGDEFAULT then + begin + for I := 0 to RTL_SIGLAST do + HookSignal(I); + Exit; + end; + + FillChar(Action, SizeOf(Action), 0); + Action.__sigaction_handler := @SignalDispatcher; + Action.sa_flags := SA_SIGINFO; + sigaddset(Action.sa_mask, SIGINT); + sigaddset(Action.sa_mask, SIGQUIT); + if sigaction(Signals[RtlSigNum].SigNum, @Action, @Signals[RtlSigNum].OldAction) = -1 then + raise Exception.CreateRes(@SSigactionFailed); + Signals[RtlSigNum].Hooked := True; +end; + +procedure UnhookSignal(RtlSigNum: Integer; OnlyIfHooked: Boolean); +var + I: Integer; +begin + if RtlSigNum = RTL_SIGDEFAULT then + begin + for I := 0 to RTL_SIGLAST do + UnhookSignal(I, OnlyIfHooked); + Exit; + end; + if not Signals[RtlSigNum].Abandon then + begin + if OnlyIfHooked and (InquireSignal(RtlSigNum) <> ssHooked) then + Exit; + if sigaction(Signals[RtlSigNum].SigNum, @Signals[RtlSigNum].OldAction, Nil) = -1 then + raise Exception.CreateRes(@SSigactionFailed); + Signals[RtlSigNum].Hooked := False; + end; +end; + +procedure UnhookOSExceptions; +begin + if not Assigned(HookOSExceptionsProc) then + UnhookSignal(RTL_SIGDEFAULT, True); +end; + +procedure HookOSExceptions; +begin + if Assigned(HookOSExceptionsProc) then + HookOSExceptionsProc + else + begin + HookSignal(RTL_SIGDEFAULT); + end; +end; +{$ENDIF} // LINUX + +procedure InitExceptions; +begin + OutOfMemory := EOutOfMemory.CreateRes(SOutOfMemory); + InvalidPointer := EInvalidPointer.CreateRes(SInvalidPointer); + ErrorProc := ErrorHandler; + ExceptProc := @ExceptHandler; + ExceptionClass := Exception; + +{$IFDEF MSWINDOWS} + ExceptClsProc := @GetExceptionClass; + ExceptObjProc := @GetExceptionObject; +{$ENDIF} + + AssertErrorProc := @AssertErrorHandler; + +{$IFNDEF PC_MAPPED_EXCEPTIONS} + // We don't hook this under PC mapped exceptions, because + // we have no idea what the parameters were to the procedure + // in question. Hence we cannot hope to unwind the stack in + // our handler. Since we just throw an exception from our + // handler, that pretty much rules out using this without + // exorbitant compiler support. If you do hook AbstractErrorProc, + // you must make sure that you never throw an exception from + // your handler if PC_MAPPED_EXCEPTIONS is defined. + AbstractErrorProc := @AbstractErrorHandler; +{$ENDIF} + +{$IFDEF LINUX} + if not IsLibrary then + HookOSExceptions; +{$ENDIF} +end; + +procedure DoneExceptions; +begin + if Assigned(OutOfMemory) then + begin + OutOfMemory.AllowFree := True; + OutOfMemory.FreeInstance; + OutOfMemory := nil; + end; + if Assigned(InvalidPointer) then + begin + InvalidPointer.AllowFree := True; + InvalidPointer.Free; + InvalidPointer := nil; + end; + ErrorProc := nil; + ExceptProc := nil; + ExceptionClass := nil; +{$IFDEF MSWINDOWS} + ExceptClsProc := nil; + ExceptObjProc := nil; +{$ENDIF} + AssertErrorProc := nil; +{$IFDEF LINUX} + if not IsLibrary then + UnhookOSExceptions; +{$ENDIF} +end; + +{$IFDEF MSWINDOWS} +procedure InitPlatformId; +var + OSVersionInfo: TOSVersionInfo; +begin + OSVersionInfo.dwOSVersionInfoSize := SizeOf(OSVersionInfo); + if GetVersionEx(OSVersionInfo) then + with OSVersionInfo do + begin + Win32Platform := dwPlatformId; + Win32MajorVersion := dwMajorVersion; + Win32MinorVersion := dwMinorVersion; + if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then + Win32BuildNumber := dwBuildNumber and $FFFF + else + Win32BuildNumber := dwBuildNumber; + Win32CSDVersion := szCSDVersion; + end; +end; + +function CheckWin32Version(AMajor: Integer; AMinor: Integer = 0): Boolean; +begin + Result := (Win32MajorVersion > AMajor) or + ((Win32MajorVersion = AMajor) and + (Win32MinorVersion >= AMinor)); +end; + +function GetFileVersion(const AFileName: string): Cardinal; +var + FileName: string; + InfoSize, Wnd: DWORD; + VerBuf: Pointer; + FI: PVSFixedFileInfo; + VerSize: DWORD; +begin + Result := Cardinal(-1); + // GetFileVersionInfo modifies the filename parameter data while parsing. + // Copy the string const into a local variable to create a writeable copy. + FileName := AFileName; + UniqueString(FileName); + InfoSize := GetFileVersionInfoSize(PChar(FileName), Wnd); + if InfoSize <> 0 then + begin + GetMem(VerBuf, InfoSize); + try + if GetFileVersionInfo(PChar(FileName), Wnd, InfoSize, VerBuf) then + if VerQueryValue(VerBuf, '\', Pointer(FI), VerSize) then + Result:= FI.dwFileVersionMS; + finally + FreeMem(VerBuf); + end; + end; +end; + +procedure Beep; +begin + MessageBeep(0); +end; +{$ENDIF} +{$IFDEF LINUX} +procedure Beep; +var + ch: Char; + FileDes: Integer; +begin + if isatty(STDERR_FILENO) = 1 then + FileDes := STDERR_FILENO + else + if isatty(STDOUT_FILENO) = 1 then + FileDes := STDOUT_FILENO + else + begin + // Neither STDERR_FILENO nor STDOUT_FILENO are open + // terminals (TTYs). It is not possible to safely + // write the beep character. + Exit; + end; + + ch := #7; + __write(FileDes, ch, 1); +end; +{$ENDIF} + +{ MBCS functions } + +function ByteTypeTest(P: PChar; Index: Integer): TMbcsByteType; +{$IFDEF MSWINDOWS} +var + I: Integer; +begin + Result := mbSingleByte; + if (P = nil) or (P[Index] = #$0) then Exit; + if (Index = 0) then + begin + if P[0] in LeadBytes then Result := mbLeadByte; + end + else + begin + I := Index - 1; + while (I >= 0) and (P[I] in LeadBytes) do Dec(I); + if ((Index - I) mod 2) = 0 then Result := mbTrailByte + else if P[Index] in LeadBytes then Result := mbLeadByte; + end; +end; +{$ENDIF} +{$IFDEF LINUX} +var + I, L: Integer; +begin + Result := mbSingleByte; + if (P = nil) or (P[Index] = #$0) then Exit; + + I := 0; + repeat + if P[I] in LeadBytes then + L := StrCharLength(P + I) + else + L := 1; + Inc(I, L); + until (I > Index); + + if (L <> 1) then + if (I - L = Index) then + Result := mbLeadByte + else + Result := mbTrailByte; +end; +{$ENDIF} + +function ByteType(const S: string; Index: Integer): TMbcsByteType; +begin + Result := mbSingleByte; + if SysLocale.FarEast then + Result := ByteTypeTest(PChar(S), Index-1); +end; + +function StrByteType(Str: PChar; Index: Cardinal): TMbcsByteType; +begin + Result := mbSingleByte; + if SysLocale.FarEast then + Result := ByteTypeTest(Str, Index); +end; + +function ByteToCharLen(const S: string; MaxLen: Integer): Integer; +begin + if Length(S) < MaxLen then MaxLen := Length(S); + Result := ByteToCharIndex(S, MaxLen); +end; + +function ByteToCharIndex(const S: string; Index: Integer): Integer; +var + I: Integer; +begin + Result := 0; + if (Index <= 0) or (Index > Length(S)) then Exit; + Result := Index; + if not SysLocale.FarEast then Exit; + I := 1; + Result := 0; + while I <= Index do + begin + if S[I] in LeadBytes then + I := NextCharIndex(S, I) + else + Inc(I); + Inc(Result); + end; +end; + +procedure CountChars(const S: string; MaxChars: Integer; var CharCount, ByteCount: Integer); +var + C, L, B: Integer; +begin + L := Length(S); + C := 1; + B := 1; + while (B < L) and (C < MaxChars) do + begin + Inc(C); + if S[B] in LeadBytes then + B := NextCharIndex(S, B) + else + Inc(B); + end; + if (C = MaxChars) and (B < L) and (S[B] in LeadBytes) then + B := NextCharIndex(S, B) - 1; + CharCount := C; + ByteCount := B; +end; + +function CharToByteIndex(const S: string; Index: Integer): Integer; +var + Chars: Integer; +begin + Result := 0; + if (Index <= 0) or (Index > Length(S)) then Exit; + if (Index > 1) and SysLocale.FarEast then + begin + CountChars(S, Index-1, Chars, Result); + if (Chars < (Index-1)) or (Result >= Length(S)) then + Result := 0 // Char index out of range + else + Inc(Result); + end + else + Result := Index; +end; + +function CharToByteLen(const S: string; MaxLen: Integer): Integer; +var + Chars: Integer; +begin + Result := 0; + if MaxLen <= 0 then Exit; + if MaxLen > Length(S) then MaxLen := Length(S); + if SysLocale.FarEast then + begin + CountChars(S, MaxLen, Chars, Result); + if Result > Length(S) then + Result := Length(S); + end + else + Result := MaxLen; +end; + +{ MBCS Helper functions } + +function StrCharLength(const Str: PChar): Integer; +begin +{$IFDEF LINUX} + Result := mblen(Str, MB_CUR_MAX); + if (Result = -1) then Result := 1; +{$ENDIF} +{$IFDEF MSWINDOWS} + if SysLocale.FarEast then + Result := Integer(CharNext(Str)) - Integer(Str) + else + Result := 1; +{$ENDIF} +end; + +function StrNextChar(const Str: PChar): PChar; +begin +{$IFDEF LINUX} + Result := Str + StrCharLength(Str); +{$ENDIF} +{$IFDEF MSWINDOWS} + Result := CharNext(Str); +{$ENDIF} +end; + +function CharLength(const S: string; Index: Integer): Integer; +begin + Result := 1; + assert((Index > 0) and (Index <= Length(S))); + if SysLocale.FarEast and (S[Index] in LeadBytes) then + Result := StrCharLength(PChar(S) + Index - 1); +end; + +function NextCharIndex(const S: string; Index: Integer): Integer; +begin + Result := Index + 1; + assert((Index > 0) and (Index <= Length(S))); + if SysLocale.FarEast and (S[Index] in LeadBytes) then + Result := Index + StrCharLength(PChar(S) + Index - 1); +end; + +function IsPathDelimiter(const S: string; Index: Integer): Boolean; +begin + Result := (Index > 0) and (Index <= Length(S)) and (S[Index] = PathDelim) + and (ByteType(S, Index) = mbSingleByte); +end; + +function IsDelimiter(const Delimiters, S: string; Index: Integer): Boolean; +begin + Result := False; + if (Index <= 0) or (Index > Length(S)) or (ByteType(S, Index) <> mbSingleByte) then exit; + Result := StrScan(PChar(Delimiters), S[Index]) <> nil; +end; + +function IncludeTrailingBackslash(const S: string): string; +begin + Result := IncludeTrailingPathDelimiter(S); +end; + +function IncludeTrailingPathDelimiter(const S: string): string; +begin + Result := S; + if not IsPathDelimiter(Result, Length(Result)) then + Result := Result + PathDelim; +end; + +function ExcludeTrailingBackslash(const S: string): string; +begin + Result := ExcludeTrailingPathDelimiter(S); +end; + +function ExcludeTrailingPathDelimiter(const S: string): string; +begin + Result := S; + if IsPathDelimiter(Result, Length(Result)) then + SetLength(Result, Length(Result)-1); +end; + +function AnsiPos(const Substr, S: string): Integer; +var + P: PChar; +begin + Result := 0; + P := AnsiStrPos(PChar(S), PChar(SubStr)); + if P <> nil then + Result := Integer(P) - Integer(PChar(S)) + 1; +end; + +function AnsiCompareFileName(const S1, S2: string): Integer; +begin +{$IFDEF MSWINDOWS} + Result := AnsiCompareStr(AnsiLowerCaseFileName(S1), AnsiLowerCaseFileName(S2)); +{$ENDIF} +{$IFDEF LINUX} + Result := AnsiCompareStr(S1, S2); +{$ENDIF} +end; + +function SameFileName(const S1, S2: string): Boolean; +begin + Result := AnsiCompareFileName(S1, S2) = 0; +end; + +function AnsiLowerCaseFileName(const S: string): string; +{$IFDEF MSWINDOWS} +var + I,L: Integer; +begin + if SysLocale.FarEast then + begin + L := Length(S); + SetLength(Result, L); + I := 1; + while I <= L do + begin + Result[I] := S[I]; + if S[I] in LeadBytes then + begin + Inc(I); + Result[I] := S[I]; + end + else + if Result[I] in ['A'..'Z'] then Inc(Byte(Result[I]), 32); + Inc(I); + end; + end + else + Result := AnsiLowerCase(S); +end; +{$ENDIF} +{$IFDEF LINUX} +begin + Result := AnsiLowerCase(S); +end; +{$ENDIF} + +function AnsiUpperCaseFileName(const S: string): string; +{$IFDEF MSWINDOWS} +var + I,L: Integer; +begin + if SysLocale.FarEast then + begin + L := Length(S); + SetLength(Result, L); + I := 1; + while I <= L do + begin + Result[I] := S[I]; + if S[I] in LeadBytes then + begin + Inc(I); + Result[I] := S[I]; + end + else + if Result[I] in ['a'..'z'] then Dec(Byte(Result[I]), 32); + Inc(I); + end; + end + else + Result := AnsiUpperCase(S); +end; +{$ENDIF} +{$IFDEF LINUX} +begin + Result := AnsiUpperCase(S); +end; +{$ENDIF} + +function AnsiStrPos(Str, SubStr: PChar): PChar; +var + L1, L2: Cardinal; + ByteType : TMbcsByteType; +begin + Result := nil; + if (Str = nil) or (Str^ = #0) or (SubStr = nil) or (SubStr^ = #0) then Exit; + L1 := StrLen(Str); + L2 := StrLen(SubStr); + Result := StrPos(Str, SubStr); + while (Result <> nil) and ((L1 - Cardinal(Result - Str)) >= L2) do + begin + ByteType := StrByteType(Str, Integer(Result-Str)); +{$IFDEF MSWINDOWS} + if (ByteType <> mbTrailByte) and + (CompareString(LOCALE_USER_DEFAULT, 0, Result, L2, SubStr, L2) = CSTR_EQUAL) then Exit; + if (ByteType = mbLeadByte) then Inc(Result); +{$ENDIF} +{$IFDEF LINUX} + if (ByteType <> mbTrailByte) and + (strncmp(Result, SubStr, L2) = 0) then Exit; +{$ENDIF} + Inc(Result); + Result := StrPos(Result, SubStr); + end; + Result := nil; +end; + +function AnsiStrRScan(Str: PChar; Chr: Char): PChar; +begin + Str := AnsiStrScan(Str, Chr); + Result := Str; + if Chr <> #$0 then + begin + while Str <> nil do + begin + Result := Str; + Inc(Str); + Str := AnsiStrScan(Str, Chr); + end; + end +end; + +function AnsiStrScan(Str: PChar; Chr: Char): PChar; +begin + Result := StrScan(Str, Chr); + while Result <> nil do + begin +{$IFDEF MSWINDOWS} + case StrByteType(Str, Integer(Result-Str)) of + mbSingleByte: Exit; + mbLeadByte: Inc(Result); + end; +{$ENDIF} +{$IFDEF LINUX} + if StrByteType(Str, Integer(Result-Str)) = mbSingleByte then Exit; +{$ENDIF} + Inc(Result); + Result := StrScan(Result, Chr); + end; +end; + +{$IFDEF MSWINDOWS} +function LCIDToCodePage(ALcid: LCID): Integer; +var + Buffer: array [0..6] of Char; +begin + GetLocaleInfo(ALcid, LOCALE_IDEFAULTANSICODEPAGE, Buffer, SizeOf(Buffer)); + Result:= StrToIntDef(Buffer, GetACP); +end; +{$ENDIF} + +procedure InitSysLocale; +{$IFDEF MSWINDOWS} +var + DefaultLCID: LCID; + DefaultLangID: LANGID; + AnsiCPInfo: TCPInfo; +// I: Integer; +// BufferA: array [128..255] of Char; + // BufferW: array [128..256] of Word; + // PCharA: PChar; + + procedure InitLeadBytes; + var + I: Integer; + J: Byte; + begin + GetCPInfo(CP_ACP, AnsiCPInfo); + with AnsiCPInfo do + begin + I := 0; + while (I < MAX_LEADBYTES) and ((LeadByte[I] or LeadByte[I + 1]) <> 0) do + begin + for J := LeadByte[I] to LeadByte[I + 1] do + Include(LeadBytes, Char(J)); + Inc(I, 2); + end; + end; + end; + +begin + { Set default to English (US). } + SysLocale.DefaultLCID := $0409; + SysLocale.PriLangID := LANG_ENGLISH; + SysLocale.SubLangID := SUBLANG_ENGLISH_US; + + DefaultLCID := GetThreadLocale; + if DefaultLCID <> 0 then SysLocale.DefaultLCID := DefaultLCID; + + DefaultLangID := Word(DefaultLCID); + if DefaultLangID <> 0 then + begin + SysLocale.PriLangID := DefaultLangID and $3ff; + SysLocale.SubLangID := DefaultLangID shr 10; + end; + + LeadBytes := []; + if (Win32MajorVersion > 4) and (Win32Platform = VER_PLATFORM_WIN32_NT) then + SysLocale.MiddleEast := True + else + SysLocale.MiddleEast := GetSystemMetrics(SM_MIDEASTENABLED) <> 0; + SysLocale.FarEast := GetSystemMetrics(SM_DBCSENABLED) <> 0; + if SysLocale.FarEast then + InitLeadBytes; +end; +{$ENDIF} +{$IFDEF LINUX} +var + I: Integer; + buf: array [0..3] of char; +begin + FillChar(SysLocale, sizeof(SysLocale), 0); + SysLocale.FarEast := MB_CUR_MAX <> 1; + if not SysLocale.FarEast then Exit; + + buf[1] := #0; + for I := 1 to 255 do + begin + buf[0] := Chr(I); + if mblen(buf, 1) <> 1 then Include(LeadBytes, Char(I)); + end; +end; +{$ENDIF} + +procedure GetFormatSettings; +{$IFDEF MSWINDOWS} +var + HourFormat, TimePrefix, TimePostfix: string; + DefaultLCID: Integer; +begin + InitSysLocale; + GetMonthDayNames; + if SysLocale.FarEast then GetEraNamesAndYearOffsets; + DefaultLCID := GetThreadLocale; + CurrencyString := GetLocaleStr(DefaultLCID, LOCALE_SCURRENCY, ''); + CurrencyFormat := StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ICURRENCY, '0'), 0); + NegCurrFormat := StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_INEGCURR, '0'), 0); + ThousandSeparator := GetLocaleChar(DefaultLCID, LOCALE_STHOUSAND, ','); + DecimalSeparator := GetLocaleChar(DefaultLCID, LOCALE_SDECIMAL, '.'); + CurrencyDecimals := StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ICURRDIGITS, '0'), 0); + DateSeparator := GetLocaleChar(DefaultLCID, LOCALE_SDATE, '/'); + ShortDateFormat := TranslateDateFormat(GetLocaleStr(DefaultLCID, LOCALE_SSHORTDATE, 'm/d/yy')); + LongDateFormat := TranslateDateFormat(GetLocaleStr(DefaultLCID, LOCALE_SLONGDATE, 'mmmm d, yyyy')); + TimeSeparator := GetLocaleChar(DefaultLCID, LOCALE_STIME, ':'); + TimeAMString := GetLocaleStr(DefaultLCID, LOCALE_S1159, 'am'); + TimePMString := GetLocaleStr(DefaultLCID, LOCALE_S2359, 'pm'); + TimePrefix := ''; + TimePostfix := ''; + if StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ITLZERO, '0'), 0) = 0 then + HourFormat := 'h' else + HourFormat := 'hh'; + if StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ITIME, '0'), 0) = 0 then + if StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ITIMEMARKPOSN, '0'), 0) = 0 then + TimePostfix := ' AMPM' + else + TimePrefix := 'AMPM '; + ShortTimeFormat := TimePrefix + HourFormat + ':mm' + TimePostfix; + LongTimeFormat := TimePrefix + HourFormat + ':mm:ss' + TimePostfix; + ListSeparator := GetLocaleChar(DefaultLCID, LOCALE_SLIST, ','); +end; +{$ELSE} +{$IFDEF LINUX} +const + //first boolean is p_cs_precedes, second is p_sep_by_space + CurrencyFormats: array[boolean, boolean] of byte = ((1, 3),(0, 2)); + //first boolean is n_cs_precedes, second is n_sep_by_space and finally n_sign_posn + NegCurrFormats: array[boolean, boolean, 0..4] of byte = + (((4,5,7,6,7),(15,8,10,13,10)),((0,1,3,1,2),(14,9,11,9,12))); + + function TranslateFormat(s: PChar; const Default: string): string; + begin + Result := ''; + while s^ <> #0 do + begin + if s^ = '%' then + begin + inc(s); + case s^ of + 'a': Result := Result + 'ddd'; + 'A': Result := Result + 'dddd'; + 'b': Result := Result + 'MMM'; + 'B': Result := Result + 'MMMM'; + 'c': Result := Result + 'c'; +// 'C': year / 100 not supported + 'd': Result := Result + 'dd'; + 'D': Result := Result + 'MM/dd/yy'; + 'e': Result := Result + 'd'; +// 'E': alternate format not supported + 'g': Result := Result + 'yy'; + 'G': Result := Result + 'yyyy'; + 'h': Result := Result + 'MMM'; + 'H': Result := Result + 'HH'; + 'I': Result := Result + 'hh'; +// 'j': day of year not supported + 'k': Result := Result + 'H'; + 'l': Result := Result + 'h'; + 'm': Result := Result + 'MM'; + 'M': Result := Result + 'nn'; // minutes! not months! + 'n': Result := Result + sLineBreak; // line break +// 'O': alternate format not supported + 'P', // P's implied lowercasing of locale string is not supported + 'p': Result := Result + 'AMPM'; + 'r': Result := Result + TranslateFormat(nl_langInfo(T_FMT_AMPM),''); + 'R': Result := Result + 'HH:mm'; +// 's': number of seconds since Epoch not supported + 'S': Result := Result + 'ss'; + 't': Result := Result + #9; // tab char + 'T': Result := Result + 'HH:mm:ss'; +// 'u': day of week 1..7 not supported +// 'U': week number of the year not supported +// 'V': week number of the year not supported +// 'w': day of week 0..6 not supported +// 'W': week number of the year not supported + 'x': Result := Result + TranslateFormat(nl_langInfo(D_FMT),''); + 'X': Result := Result + TranslateFormat(nl_langinfo(T_FMT),''); + 'y': Result := Result + 'yy'; + 'Y': Result := Result + 'yyyy'; +// 'z': GMT offset is not supported + '%': Result := Result + '%'; + end; + end + else + Result := Result + s^; + Inc(s); + end; + if Result = '' then + Result := Default; + end; + + function GetFirstCharacter(const SrcString, match: string): char; + var + i, p: integer; + begin + result := match[1]; + for i := 1 to length(SrcString) do begin + p := Pos(SrcString[i], match); + if p > 0 then + begin + result := match[p]; + break; + end; + end; + end; + +var + P: PLConv; +begin + InitSysLocale; + GetMonthDayNames; + if SysLocale.FarEast then InitEras; + + CurrencyString := ''; + CurrencyFormat := 0; + NegCurrFormat := 0; + ThousandSeparator := ','; + DecimalSeparator := '.'; + CurrencyDecimals := 0; + + P := localeconv; + if P <> nil then + begin + if P^.currency_symbol <> nil then + CurrencyString := P^.currency_symbol; + + if (Byte(P^.p_cs_precedes) in [0..1]) and + (Byte(P^.p_sep_by_space) in [0..1]) then + begin + CurrencyFormat := CurrencyFormats[P^.p_cs_precedes, P^.p_sep_by_space]; + if P^.p_sign_posn in [0..4] then + NegCurrFormat := NegCurrFormats[P^.n_cs_precedes, P^.n_sep_by_space, + P^.n_sign_posn]; + end; + + // #0 is valid for ThousandSeparator. Indicates no thousand separator. + ThousandSeparator := P^.thousands_sep^; + + // #0 is not valid for DecimalSeparator. + if P^.decimal_point <> #0 then + DecimalSeparator := P^.decimal_point^; + CurrencyDecimals := P^.frac_digits; + end; + + ShortDateFormat := TranslateFormat(nl_langinfo(D_FMT),'m/d/yy'); + LongDateFormat := TranslateFormat(nl_langinfo(D_T_FMT), ShortDateFormat); + ShortTimeFormat := TranslateFormat(nl_langinfo(T_FMT), 'hh:mm AMPM'); + LongTimeFormat := TranslateFormat(nl_langinfo(T_FMT_AMPM), ShortTimeFormat); + + DateSeparator := GetFirstCharacter(ShortDateFormat, '/.-'); + TimeSeparator := GetFirstCharacter(ShortTimeFormat, ':.'); + + TimeAMString := nl_langinfo(AM_STR); + TimePMString := nl_langinfo(PM_STR); + ListSeparator := ','; +end; +{$ELSE} +var + HourFormat, TimePrefix, TimePostfix: string; +begin + InitSysLocale; + GetMonthDayNames; + CurrencyString := ''; + CurrencyFormat := 0; + NegCurrFormat := 0; + ThousandSeparator := ','; + DecimalSeparator := '.'; + CurrencyDecimals := 0; + DateSeparator := '/'; + ShortDateFormat := 'm/d/yy'; + LongDateFormat := 'mmmm d, yyyy'; + TimeSeparator := ':'; + TimeAMString := 'am'; + TimePMString := 'pm'; + TimePrefix := ''; + TimePostfix := ''; + HourFormat := 'h'; + TimePostfix := ' AMPM'; + ShortTimeFormat := TimePrefix + HourFormat + ':mm' + TimePostfix; + LongTimeFormat := TimePrefix + HourFormat + ':mm:ss' + TimePostfix; + ListSeparator := ','; +end; +{$ENDIF} +{$ENDIF} + +{$IFDEF MSWINDOWS} +procedure GetLocaleFormatSettings(LCID: Integer; + var FormatSettings: TFormatSettings); +var + HourFormat, TimePrefix, TimePostfix: string; + DefaultLCID: Integer; +begin + if IsValidLocale(LCID, LCID_INSTALLED) then + DefaultLCID := LCID + else + DefaultLCID := GetThreadLocale; + + GetLocaleMonthDayNames(LCID, FormatSettings); + with FormatSettings do + begin + CurrencyString := GetLocaleStr(DefaultLCID, LOCALE_SCURRENCY, ''); + CurrencyFormat := StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ICURRENCY, '0'), 0); + NegCurrFormat := StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_INEGCURR, '0'), 0); + ThousandSeparator := GetLocaleChar(DefaultLCID, LOCALE_STHOUSAND, ','); + DecimalSeparator := GetLocaleChar(DefaultLCID, LOCALE_SDECIMAL, '.'); + CurrencyDecimals := StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ICURRDIGITS, '0'), 0); + DateSeparator := GetLocaleChar(DefaultLCID, LOCALE_SDATE, '/'); + ShortDateFormat := TranslateDateFormat(GetLocaleStr(DefaultLCID, LOCALE_SSHORTDATE, 'm/d/yy')); + LongDateFormat := TranslateDateFormat(GetLocaleStr(DefaultLCID, LOCALE_SLONGDATE, 'mmmm d, yyyy')); + TimeSeparator := GetLocaleChar(DefaultLCID, LOCALE_STIME, ':'); + TimeAMString := GetLocaleStr(DefaultLCID, LOCALE_S1159, 'am'); + TimePMString := GetLocaleStr(DefaultLCID, LOCALE_S2359, 'pm'); + TimePrefix := ''; + TimePostfix := ''; + if StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ITLZERO, '0'), 0) = 0 then + HourFormat := 'h' else + HourFormat := 'hh'; + if StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ITIME, '0'), 0) = 0 then + if StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ITIMEMARKPOSN, '0'), 0) = 0 then + TimePostfix := ' AMPM' + else + TimePrefix := 'AMPM '; + ShortTimeFormat := TimePrefix + HourFormat + ':mm' + TimePostfix; + LongTimeFormat := TimePrefix + HourFormat + ':mm:ss' + TimePostfix; + ListSeparator := GetLocaleChar(DefaultLCID, LOCALE_SLIST, ','); + end; +end; +{$ENDIF} + +function StringReplace(const S, OldPattern, NewPattern: string; + Flags: TReplaceFlags): string; +var + SearchStr, Patt, NewStr: string; + Offset: Integer; +begin + if rfIgnoreCase in Flags then + begin + SearchStr := AnsiUpperCase(S); + Patt := AnsiUpperCase(OldPattern); + end else + begin + SearchStr := S; + Patt := OldPattern; + end; + NewStr := S; + Result := ''; + while SearchStr <> '' do + begin + Offset := AnsiPos(Patt, SearchStr); + if Offset = 0 then + begin + Result := Result + NewStr; + Break; + end; + Result := Result + Copy(NewStr, 1, Offset - 1) + NewPattern; + NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt); + if not (rfReplaceAll in Flags) then + begin + Result := Result + NewStr; + Break; + end; + SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt); + end; +end; + +function WrapText(const Line, BreakStr: string; const BreakChars: TSysCharSet; + MaxCol: Integer): string; +const + QuoteChars = ['''', '"']; +var + Col, Pos: Integer; + LinePos, LineLen: Integer; + BreakLen, BreakPos: Integer; + QuoteChar, CurChar: Char; + ExistingBreak: Boolean; + L: Integer; +begin + Col := 1; + Pos := 1; + LinePos := 1; + BreakPos := 0; + QuoteChar := #0; + ExistingBreak := False; + LineLen := Length(Line); + BreakLen := Length(BreakStr); + Result := ''; + while Pos <= LineLen do + begin + CurChar := Line[Pos]; + if CurChar in LeadBytes then + begin + L := CharLength(Line, Pos) - 1; + Inc(Pos, L); + Inc(Col, L); + end + else + begin + if CurChar in QuoteChars then + if QuoteChar = #0 then + QuoteChar := CurChar + else if CurChar = QuoteChar then + QuoteChar := #0; + if QuoteChar = #0 then + begin + if CurChar = BreakStr[1] then + begin + ExistingBreak := StrLComp(Pointer(BreakStr), Pointer(@Line[Pos]), BreakLen) = 0; + if ExistingBreak then + begin + Inc(Pos, BreakLen-1); + BreakPos := Pos; + end; + end; + + if not ExistingBreak then + if CurChar in BreakChars then + BreakPos := Pos; + end; + end; + + Inc(Pos); + Inc(Col); + + if not (QuoteChar in QuoteChars) and (ExistingBreak or + ((Col > MaxCol) and (BreakPos > LinePos))) then + begin + Col := 1; + Result := Result + Copy(Line, LinePos, BreakPos - LinePos + 1); + if not (CurChar in QuoteChars) then + begin + while Pos <= LineLen do + begin + if Line[Pos] in BreakChars then + begin + Inc(Pos); + ExistingBreak := False; + end + else + begin + if StrLComp(Pointer(@Line[Pos]), sLineBreak, Length(sLineBreak)) = 0 then + begin + Inc(Pos, Length(sLineBreak)); + ExistingBreak := True; + end + else + Break; + end; + end; + end; + if (Pos <= LineLen) and not ExistingBreak then + Result := Result + BreakStr; + + Inc(BreakPos); + LinePos := BreakPos; + Pos := LinePos; + ExistingBreak := False; + end; + end; + Result := Result + Copy(Line, LinePos, MaxInt); +end; + +function WrapText(const Line: string; MaxCol: Integer): string; +begin + Result := WrapText(Line, sLineBreak, [' ', '-', #9], MaxCol); { do not localize } +end; + +function FindCmdLineSwitch(const Switch: string; const Chars: TSysCharSet; + IgnoreCase: Boolean): Boolean; +var + I: Integer; + S: string; +begin + for I := 1 to ParamCount do + begin + S := ParamStr(I); + if (Chars = []) or (S[1] in Chars) then + if IgnoreCase then + begin + if (AnsiCompareText(Copy(S, 2, Maxint), Switch) = 0) then + begin + Result := True; + Exit; + end; + end + else begin + if (AnsiCompareStr(Copy(S, 2, Maxint), Switch) = 0) then + begin + Result := True; + Exit; + end; + end; + end; + Result := False; +end; + +function FindCmdLineSwitch(const Switch: string): Boolean; +begin + Result := FindCmdLineSwitch(Switch, SwitchChars, True); +end; + +function FindCmdLineSwitch(const Switch: string; IgnoreCase: Boolean): Boolean; +begin + Result := FindCmdLineSwitch(Switch, SwitchChars, IgnoreCase); +end; + +{ Package info structures } + +type + PPkgName = ^TPkgName; + TPkgName = packed record + HashCode: Byte; + Name: array[0..255] of Char; + end; + + { PackageUnitFlags: + bit meaning + ----------------------------------------------------------------------------------------- + 0 | main unit + 1 | package unit (dpk source) + 2 | $WEAKPACKAGEUNIT unit + 3 | original containment of $WEAKPACKAGEUNIT (package into which it was compiled) + 4 | implicitly imported + 5..7 | reserved + } + PUnitName = ^TUnitName; + TUnitName = packed record + Flags : Byte; + HashCode: Byte; + Name: array[0..255] of Char; + end; + + { Package flags: + bit meaning + ----------------------------------------------------------------------------------------- + 0 | 1: never-build 0: always build + 1 | 1: design-time only 0: not design-time only on => bit 2 = off + 2 | 1: run-time only 0: not run-time only on => bit 1 = off + 3 | 1: do not check for dup units 0: perform normal dup unit check + 4..25 | reserved + 26..27| (producer) 0: pre-V4, 1: undefined, 2: c++, 3: Pascal + 28..29| reserved + 30..31| 0: EXE, 1: Package DLL, 2: Library DLL, 3: undefined + } + PPackageInfoHeader = ^TPackageInfoHeader; + TPackageInfoHeader = packed record + Flags: Cardinal; + RequiresCount: Integer; + {Requires: array[0..9999] of TPkgName; + ContainsCount: Integer; + Contains: array[0..9999] of TUnitName;} + end; + +function PackageInfoTable(Module: HMODULE): PPackageInfoHeader; +var + ResInfo: HRSRC; + Data: THandle; +begin + Result := nil; + ResInfo := FindResource(Module, 'PACKAGEINFO', RT_RCDATA); + if ResInfo <> 0 then + begin + Data := LoadResource(Module, ResInfo); + if Data <> 0 then + try + Result := LockResource(Data); + UnlockResource(Data); + finally + FreeResource(Data); + end; + end; +end; + +function GetModuleName(Module: HMODULE): string; +var + ModName: array[0..MAX_PATH] of Char; +begin + SetString(Result, ModName, GetModuleFileName(Module, ModName, SizeOf(ModName))); +end; + +var + Reserved: Integer; + +procedure CheckForDuplicateUnits(Module: HMODULE); +var + ModuleFlags: Cardinal; + + function IsUnitPresent(HC: Byte; UnitName: PChar; Module: HMODULE; + const ModuleName: string; var UnitPackage: string): Boolean; + var + I: Integer; + InfoTable: PPackageInfoHeader; + LibModule: PLibModule; + PkgName: PPkgName; + UName : PUnitName; + Count: Integer; + begin + Result := True; + if (StrIComp(UnitName, 'SysInit') <> 0) and + (StrIComp(UnitName, PChar(ModuleName)) <> 0) then + begin + LibModule := LibModuleList; + while LibModule <> nil do + begin + if LibModule.Instance <> Cardinal(Module) then + begin + InfoTable := PackageInfoTable(HMODULE(LibModule.Instance)); + if (InfoTable <> nil) and (InfoTable.Flags and pfModuleTypeMask = pfPackageModule) and + ((InfoTable.Flags and pfIgnoreDupUnits) = (ModuleFlags and pfIgnoreDupUnits)) then + begin + PkgName := PPkgName(Integer(InfoTable) + SizeOf(InfoTable^)); + Count := InfoTable.RequiresCount; + { Skip the Requires list } + for I := 0 to Count - 1 do Inc(Integer(PkgName), StrLen(PkgName.Name) + 2); + Count := Integer(Pointer(PkgName)^); + UName := PUnitName(Integer(PkgName) + 4); + for I := 0 to Count - 1 do + begin + with UName^ do + // Test Flags to ignore weak package units + if ((HashCode = HC) or (HashCode = 0) or (HC = 0)) and + ((Flags and $06) = 0) and (StrIComp(UnitName, Name) = 0) then + begin + UnitPackage := ChangeFileExt(ExtractFileName( + GetModuleName(HMODULE(LibModule.Instance))), ''); + Exit; + end; + Inc(Integer(UName), StrLen(UName.Name) + 3); + end; + end; + end; + LibModule := LibModule.Next; + end; + end; + Result := False; + end; + + function FindLibModule(Module: HModule): PLibModule; + begin + Result := LibModuleList; + while Result <> nil do + begin + if Result.Instance = Cardinal(Module) then Exit; + Result := Result.Next; + end; + end; + + procedure InternalUnitCheck(Module: HModule); + var + I: Integer; + InfoTable: PPackageInfoHeader; + UnitPackage: string; + ModuleName: string; + PkgName: PPkgName; + UName: PUnitName; + Count: Integer; + LibModule: PLibModule; + begin + InfoTable := PackageInfoTable(Module); + if (InfoTable <> nil) and (InfoTable.Flags and pfModuleTypeMask = pfPackageModule) then + begin + if ModuleFlags = 0 then ModuleFlags := InfoTable.Flags; + ModuleName := ChangeFileExt(ExtractFileName(GetModuleName(Module)), ''); + PkgName := PPkgName(Integer(InfoTable) + SizeOf(InfoTable^)); + Count := InfoTable.RequiresCount; + for I := 0 to Count - 1 do + begin + with PkgName^ do +{$IFDEF MSWINDOWS} + InternalUnitCheck(GetModuleHandle(PChar(ChangeFileExt(Name, '.bpl')))); +{$ENDIF} +{$IFDEF LINUX} + InternalUnitCheck(GetModuleHandle(Name)); +{$ENDIF} + Inc(Integer(PkgName), StrLen(PkgName.Name) + 2); + end; + LibModule := FindLibModule(Module); + if (LibModule = nil) or ((LibModule <> nil) and (LibModule.Reserved <> Reserved)) then + begin + if LibModule <> nil then LibModule.Reserved := Reserved; + Count := Integer(Pointer(PkgName)^); + UName := PUnitName(Integer(PkgName) + 4); + for I := 0 to Count - 1 do + begin + with UName^ do + // Test Flags to ignore weak package units + if ((Flags and ufWeakPackageUnit) = 0 ) and + IsUnitPresent(HashCode, Name, Module, ModuleName, UnitPackage) then + raise EPackageError.CreateResFmt(SDuplicatePackageUnit, + [ModuleName, Name, UnitPackage]); + Inc(Integer(UName), StrLen(UName.Name) + 3); + end; + end; + end; + end; + +begin + Inc(Reserved); + ModuleFlags := 0; + InternalUnitCheck(Module); +end; + +{$IFDEF LINUX} +function LoadLibrary(ModuleName: PChar): HMODULE; +begin + Result := HMODULE(dlopen(ModuleName, RTLD_LAZY)); +end; + +function FreeLibrary(Module: HMODULE): LongBool; +begin + Result := LongBool(dlclose(Pointer(Module))); +end; + +function GetProcAddress(Module: HMODULE; Proc: PChar): Pointer; +var + Info: TDLInfo; + Error: PChar; + ModHandle: HMODULE; +begin + // dlsym doesn't clear the error state when the function succeeds + dlerror; + Result := dlsym(Pointer(Module), Proc); + Error := dlerror; + if Error <> nil then + Result := nil + else if dladdr(Result, Info) <> 0 then + begin +{ In glibc 2.1.3 and earlier, dladdr returns a nil dli_fname + for addresses in the main program file. In glibc 2.1.91 and + later, dladdr fills in the dli_fname for addresses in the + main program file, but dlopen will segfault when given + the main program file name. + Workaround: Check the symbol base address against the main + program file's base address, and only call dlopen with a nil + filename to get the module name of the main program. } + + if Info.dli_fbase = ExeBaseAddress then + Info.dli_fname := nil; + + ModHandle := HMODULE(dlopen(Info.dli_fname, RTLD_LAZY)); + if ModHandle <> 0 then + begin + dlclose(Pointer(ModHandle)); + if ModHandle <> Module then + Result := nil; + end; + end else Result := nil; +end; + +type + plink_map = ^link_map; + link_map = record + l_addr: Pointer; + l_name: PChar; + l_ld: Pointer; + l_next, l_prev: plink_map; + end; + + pr_debug = ^r_debug; + r_debug = record + r_version: Integer; + r_map: plink_map; + r_brk: Pointer; + r_state: Integer; + r_ldbase: Pointer; + end; + +var + _r_debug: pr_debug = nil; + +function ScanLinkMap(Func: Pointer): plink_map; +var + linkmap: plink_map; + + function Eval(linkmap: plink_map; Func: Pointer): Boolean; + asm +// MOV ECX,[EBP] + PUSH EBP + CALL EDX + POP ECX + end; + +begin + if _r_debug = nil then + _r_debug := dlsym(RTLD_DEFAULT, '_r_debug'); + if _r_debug = nil then + begin + Assert(False, 'Unable to locate ''_r_debug'' symbol'); // do not localize + Result := nil; + Exit; + end; + linkmap := _r_debug.r_map; + while linkmap <> nil do + begin + if not Eval(linkmap, Func) then Break; + linkmap := linkmap.l_next; + end; + Result := linkmap; +end; + +function InitModule(linkmap: plink_map): HMODULE; +begin + if linkmap <> nil then + begin + Result := HMODULE(dlopen(linkmap.l_name, RTLD_LAZY)); + if Result <> 0 then + dlclose(Pointer(Result)); + end else Result := 0; +end; + +function GetModuleHandle(ModuleName: PChar): HMODULE; + + function CheckModuleName(linkmap: plink_map): Boolean; + var + BaseName: PChar; + begin + Result := True; + if ((ModuleName = nil) and ((linkmap.l_name = nil) or (linkmap.l_name[0] = #0))) or + ((ModuleName[0] = PathDelim) and (StrComp(ModuleName, linkmap.l_name) = 0)) then + begin + Result := False; + Exit; + end else + begin + // Locate the start of the actual filename + BaseName := StrRScan(linkmap.l_name, PathDelim); + if BaseName = nil then + BaseName := linkmap.l_name + else Inc(BaseName); // The filename is actually located at BaseName+1 + if StrComp(ModuleName, BaseName) = 0 then + begin + Result := False; + Exit; + end; + end; + end; + +begin + Result := InitModule(ScanLinkMap(@CheckModuleName)); +end; + +function GetPackageModuleHandle(PackageName: PChar): HMODULE; +var + PkgName: array[0..MAX_PATH] of Char; + + function CheckPackageName(linkmap: plink_map): Boolean; + var + BaseName: PChar; + begin + Result := True; + if linkmap.l_name <> nil then + begin + // Locate the start of the actual filename + BaseName := StrRScan(linkmap.l_name, PathDelim); + if BaseName = nil then + BaseName := linkmap.l_name // If there is no path info, just use the whole name + else Inc(BaseName); // The filename is actually located at BaseName+1 + Result := StrPos(BaseName, PkgName) = nil; + end; + end; + + procedure MakePkgName(Prefix, Name: PChar); + begin + StrCopy(PkgName, Prefix); + StrLCat(PkgName, Name, sizeof(PkgName)-1); + PkgName[High(PkgName)] := #0; + end; + +begin + if (PackageName = nil) or (StrScan(PackageName, PathDelim) <> nil) then + Result := 0 + else + begin + MakePkgName('bpl', PackageName); // First check the default prefix + Result := InitModule(ScanLinkMap(@CheckPackageName)); + if Result = 0 then + begin + MakePkgName('dcl', PackageName); // Next check the design-time prefix + Result := InitModule(ScanLinkMap(@CheckPackageName)); + if Result = 0 then + begin + MakePkgName('', PackageName); // finally check without a prefix + Result := InitModule(ScanLinkMap(@CheckPackageName)); + end; + end; + end; +end; + +{$ENDIF} + +{$IFDEF MSWINDOWS} +procedure Sleep; external kernel32 name 'Sleep'; stdcall; +{$ENDIF} +{$IFDEF LINUX} +procedure Sleep(milliseconds: Cardinal); +begin + usleep(milliseconds * 1000); // usleep is in microseconds +end; +{$ENDIF} + +{ InitializePackage } + +procedure InitializePackage(Module: HMODULE); +type + TPackageLoad = procedure; +var + PackageLoad: TPackageLoad; +begin + CheckForDuplicateUnits(Module); + @PackageLoad := GetProcAddress(Module, 'Initialize'); //Do not localize + if Assigned(PackageLoad) then + PackageLoad + else + raise EPackageError.CreateFmt(sInvalidPackageFile, [GetModuleName(Module)]); +end; + +{ FinalizePackage } + +procedure FinalizePackage(Module: HMODULE); +type + TPackageUnload = procedure; +var + PackageUnload: TPackageUnload; +begin + @PackageUnload := GetProcAddress(Module, 'Finalize'); //Do not localize + if Assigned(PackageUnload) then + PackageUnload + else + raise EPackageError.CreateRes(sInvalidPackageHandle); +end; + +{ LoadPackage } + +function LoadPackage(const Name: string): HMODULE; +{$IFDEF LINUX} +var + DLErrorMsg: string; +{$ENDIF} +begin +{$IFDEF MSWINDOWS} + Result := SafeLoadLibrary(Name); +{$ENDIF} +{$IFDEF LINUX} + Result := HMODULE(dlOpen(PChar(Name), PkgLoadingMode)); +{$ENDIF} + if Result = 0 then + begin +{$IFDEF LINUX} + DLErrorMsg := dlerror; +{$ENDIF} + raise EPackageError.CreateResFmt(sErrorLoadingPackage, + [Name, + {$IFDEF MSWINDOWS}SysErrorMessage(GetLastError){$ENDIF} + {$IFDEF LINUX}DLErrorMsg{$ENDIF}]); + end; + try + InitializePackage(Result); + except +{$IFDEF MSWINDOWS} + FreeLibrary(Result); +{$ENDIF} +{$IFDEF LINUX} + dlclose(Pointer(Result)); +{$ENDIF} + raise; + end; +end; + +{ UnloadPackage } + +procedure UnloadPackage(Module: HMODULE); +begin + FinalizePackage(Module); +{$IFDEF MSWINDOWS} + FreeLibrary(Module); +{$ENDIF} +{$IFDEF LINUX} + dlclose(Pointer(Module)); + InvalidateModuleCache; +{$ENDIF} +end; + +{ GetPackageInfo } + +procedure GetPackageInfo(Module: HMODULE; Param: Pointer; var Flags: Integer; + InfoProc: TPackageInfoProc); +var + InfoTable: PPackageInfoHeader; + I: Integer; + PkgName: PPkgName; + UName: PUnitName; + Count: Integer; +begin + InfoTable := PackageInfoTable(Module); + if not Assigned(InfoTable) then + raise EPackageError.CreateFmt(SCannotReadPackageInfo, + [ExtractFileName(GetModuleName(Module))]); + Flags := InfoTable.Flags; + with InfoTable^ do + begin + PkgName := PPkgName(Integer(InfoTable) + SizeOf(InfoTable^)); + Count := RequiresCount; + for I := 0 to Count - 1 do + begin + InfoProc(PkgName.Name, ntRequiresPackage, 0, Param); + Inc(Integer(PkgName), StrLen(PkgName.Name) + 2); + end; + Count := Integer(Pointer(PkgName)^); + UName := PUnitName(Integer(PkgName) + 4); + for I := 0 to Count - 1 do + begin + InfoProc(UName.Name, ntContainsUnit, UName.Flags, Param); + Inc(Integer(UName), StrLen(UName.Name) + 3); + end; + if Flags and pfPackageModule <> 0 then + begin + PkgName := PPkgName(UName); + InfoProc(PkgName.Name, ntDcpBpiName, 0, Param); + end; + end; +end; + +function GetPackageDescription(ModuleName: PChar): string; +var + ResModule: HMODULE; + ResInfo: HRSRC; + ResData: HGLOBAL; +{$IFDEF LINUX} + DLErrorMsg: string; +{$ENDIF} +begin + Result := ''; + ResModule := LoadResourceModule(ModuleName); + if ResModule = 0 then + begin +{$IFDEF MSWINDOWS} + ResModule := LoadLibraryEx(ModuleName, 0, LOAD_LIBRARY_AS_DATAFILE); +{$ENDIF} +{$IFDEF LINUX} + ResModule := HMODULE(dlopen(ModuleName, RTLD_LAZY)); +{$ENDIF} + if ResModule = 0 then + begin +{$IFDEF LINUX} + DLErrorMsg := dlerror; +{$ENDIF} + raise EPackageError.CreateResFmt(sErrorLoadingPackage, + [ModuleName, + {$IFDEF MSWINDOWS}SysErrorMessage(GetLastError){$ENDIF} + {$IFDEF LINUX}DLErrorMsg{$ENDIF}]); + end; + end; + try + ResInfo := FindResource(ResModule, 'DESCRIPTION', RT_RCDATA); + if ResInfo <> 0 then + begin + ResData := LoadResource(ResModule, ResInfo); + if ResData <> 0 then + try + Result := PWideChar(LockResource(ResData)); + UnlockResource(ResData); + finally + FreeResource(ResData); + end; + end; + finally +{$IFDEF MSWINDOWS} + FreeLibrary(ResModule); +{$ENDIF} +{$IFDEF LINUX} + dlclose(Pointer(ResModule)); +{$ENDIF} + end; +end; + +procedure RaiseLastOSError; +begin + RaiseLastOSError(GetLastError); +end; + +procedure RaiseLastOSError(LastError: Integer); +var + Error: EOSError; +begin + if LastError <> 0 then + Error := EOSError.CreateResFmt(SOSError, [LastError, + SysErrorMessage(LastError)]) + else + Error := EOSError.CreateRes(SUnkOSError); + Error.ErrorCode := LastError; + raise Error; +end; + +{$IFDEF MSWINDOWS} +{ RaiseLastWin32Error } + +procedure RaiseLastWin32Error; +begin + RaiseLastOSError; +end; + +{ Win32Check } + +function Win32Check(RetVal: BOOL): BOOL; +begin + if not RetVal then RaiseLastOSError; + Result := RetVal; +end; +{$ENDIF} + +type + PTerminateProcInfo = ^TTerminateProcInfo; + TTerminateProcInfo = record + Next: PTerminateProcInfo; + Proc: TTerminateProc; + end; + +var + TerminateProcList: PTerminateProcInfo = nil; + +procedure AddTerminateProc(TermProc: TTerminateProc); +var + P: PTerminateProcInfo; +begin + New(P); + P^.Next := TerminateProcList; + P^.Proc := TermProc; + TerminateProcList := P; +end; + +function CallTerminateProcs: Boolean; +var + PI: PTerminateProcInfo; +begin + Result := True; + PI := TerminateProcList; + while Result and (PI <> nil) do + begin + Result := PI^.Proc; + PI := PI^.Next; + end; +end; + +procedure FreeTerminateProcs; +var + PI: PTerminateProcInfo; +begin + while TerminateProcList <> nil do + begin + PI := TerminateProcList; + TerminateProcList := PI^.Next; + Dispose(PI); + end; +end; + +{ --- } +function AL1(const P): LongWord; +asm + MOV EDX,DWORD PTR [P] + XOR EDX,DWORD PTR [P+4] + XOR EDX,DWORD PTR [P+8] + XOR EDX,DWORD PTR [P+12] + MOV EAX,EDX +end; + +function AL2(const P): LongWord; +asm + MOV EDX,DWORD PTR [P] + ROR EDX,5 + XOR EDX,DWORD PTR [P+4] + ROR EDX,5 + XOR EDX,DWORD PTR [P+8] + ROR EDX,5 + XOR EDX,DWORD PTR [P+12] + MOV EAX,EDX +end; + +const + AL1s: array[0..3] of LongWord = ($FFFFFFF0, $FFFFEBF0, 0, $FFFFFFFF); + AL2s: array[0..3] of LongWord = ($42C3ECEF, $20F7AEB6, $D1C2F74E, $3F6574DE); + +procedure ALV; +begin + raise Exception.CreateRes(SNL); +end; + +function ALR: Pointer; +var + LibModule: PLibModule; +begin + if MainInstance <> 0 then + Result := Pointer(LoadResource(MainInstance, FindResource(MainInstance, 'DVCLAL', + RT_RCDATA))) + else + begin + Result := nil; + LibModule := LibModuleList; + while LibModule <> nil do + begin + with LibModule^ do + begin + Result := Pointer(LoadResource(Instance, FindResource(Instance, 'DVCLAL', + RT_RCDATA))); + if Result <> nil then Break; + end; + LibModule := LibModule.Next; + end; + end; +end; + +function GDAL: LongWord; +type + TDVCLAL = array[0..3] of LongWord; + PDVCLAL = ^TDVCLAL; +var + P: Pointer; + A1, A2: LongWord; + PAL1s, PAL2s: PDVCLAL; + ALOK: Boolean; +begin + P := ALR; + if P <> nil then + begin + A1 := AL1(P^); + A2 := AL2(P^); + Result := A1; + PAL1s := @AL1s; + PAL2s := @AL2s; + ALOK := ((A1 = PAL1s[0]) and (A2 = PAL2s[0])) or + ((A1 = PAL1s[1]) and (A2 = PAL2s[1])) or + ((A1 = PAL1s[2]) and (A2 = PAL2s[2])); + FreeResource(Integer(P)); + if not ALOK then ALV; + end else Result := AL1s[3]; +end; + +procedure RCS; +var + P: Pointer; + ALOK: Boolean; +begin + P := ALR; + if P <> nil then + begin + ALOK := (AL1(P^) = AL1s[2]) and (AL2(P^) = AL2s[2]); + FreeResource(Integer(P)); + end else ALOK := False; + if not ALOK then ALV; +end; + +procedure RPR; +var + AL: LongWord; +begin + AL := GDAL; + if (AL <> AL1s[1]) and (AL <> AL1s[2]) then ALV; +end; + +{$IFDEF MSWINDOWS} +procedure InitDriveSpacePtr; +var + Kernel: THandle; +begin + Kernel := GetModuleHandle(Windows.Kernel32); + if Kernel <> 0 then + @GetDiskFreeSpaceEx := GetProcAddress(Kernel, 'GetDiskFreeSpaceExA'); + if not Assigned(GetDiskFreeSpaceEx) then + GetDiskFreeSpaceEx := @BackfillGetDiskFreeSpaceEx; +end; +{$ENDIF} + +// Win95 does not return the actual value of the result. +// These implementations are consistent on all platforms. +function InterlockedIncrement(var I: Integer): Integer; +asm + MOV EDX,1 + XCHG EAX,EDX + LOCK XADD [EDX],EAX + INC EAX +end; + +function InterlockedDecrement(var I: Integer): Integer; +asm + MOV EDX,-1 + XCHG EAX,EDX + LOCK XADD [EDX],EAX + DEC EAX +end; + +function InterlockedExchange(var A: Integer; B: Integer): Integer; +asm + XCHG [EAX],EDX + MOV EAX,EDX +end; + +// The InterlockedExchangeAdd Win32 API is not available on Win95. +function InterlockedExchangeAdd(var A: Integer; B: Integer): Integer; +asm + XCHG EAX,EDX + LOCK XADD [EDX],EAX +end; + + +{ TSimpleRWSync } + +constructor TSimpleRWSync.Create; +begin + inherited Create; + InitializeCriticalSection(FLock); +end; + +destructor TSimpleRWSync.Destroy; +begin + inherited Destroy; + DeleteCriticalSection(FLock); +end; + +function TSimpleRWSync.BeginWrite: Boolean; +begin + EnterCriticalSection(FLock); + Result := True; +end; + +procedure TSimpleRWSync.EndWrite; +begin + LeaveCriticalSection(FLock); +end; + +procedure TSimpleRWSync.BeginRead; +begin + EnterCriticalSection(FLock); +end; + +procedure TSimpleRWSync.EndRead; +begin + LeaveCriticalSection(FLock); +end; + +{ TThreadLocalCounter } + +const + Alive = High(Integer); + +destructor TThreadLocalCounter.Destroy; +var + P, Q: PThreadInfo; + I: Integer; +begin + for I := 0 to High(FHashTable) do + begin + P := FHashTable[I]; + FHashTable[I] := nil; + while P <> nil do + begin + Q := P; + P := P^.Next; + FreeMem(Q); + end; + end; + inherited Destroy; +end; + +function TThreadLocalCounter.HashIndex: Byte; +var + H: Word; +begin + H := Word(GetCurrentThreadID); + Result := (WordRec(H).Lo xor WordRec(H).Hi) and 15; +end; + +procedure TThreadLocalCounter.Open(var Thread: PThreadInfo); +var + P: PThreadInfo; + CurThread: Cardinal; + H: Byte; +begin + H := HashIndex; + CurThread := GetCurrentThreadID; + + P := FHashTable[H]; + while (P <> nil) and (P.ThreadID <> CurThread) do + P := P.Next; + + if P = nil then + begin + P := Recycle; + + if P = nil then + begin + P := PThreadInfo(AllocMem(sizeof(TThreadInfo))); + P.ThreadID := CurThread; + P.Active := Alive; + + // Another thread could start traversing the list between when we set the + // head to P and when we assign to P.Next. Initializing P.Next to point + // to itself will make others spin until we assign the tail to P.Next. + P.Next := P; + P.Next := PThreadInfo(InterlockedExchange(Integer(FHashTable[H]), Integer(P))); + end; + end; + Thread := P; +end; + +procedure TThreadLocalCounter.Close(var Thread: PThreadInfo); +begin + Thread := nil; +end; + +procedure TThreadLocalCounter.Delete(var Thread: PThreadInfo); +begin + Thread.ThreadID := 0; + Thread.Active := 0; +end; + +function TThreadLocalCounter.Recycle: PThreadInfo; +var + Gen: Integer; +begin + Result := FHashTable[HashIndex]; + while (Result <> nil) do + begin + Gen := InterlockedExchange(Result.Active, Alive); + if Gen <> Alive then + begin + Result.ThreadID := GetCurrentThreadID; + Exit; + end + else + Result := Result.Next; + end; +end; + + +{$IFDEF MSWINDOWS} +{ TMultiReadExclusiveWriteSynchronizer } +const + mrWriteRequest = $FFFF; // 65535 concurrent read requests (threads) + // 32768 concurrent write requests (threads) + // only one write lock at a time + // 2^32 lock recursions per thread (read and write combined) + +constructor TMultiReadExclusiveWriteSynchronizer.Create; +begin + inherited Create; + FSentinel := mrWriteRequest; + FReadSignal := CreateEvent(nil, True, True, nil); // manual reset, start signaled + FWriteSignal := CreateEvent(nil, False, False, nil); // auto reset, start blocked + FWaitRecycle := INFINITE; + tls := TThreadLocalCounter.Create; +end; + +destructor TMultiReadExclusiveWriteSynchronizer.Destroy; +begin + BeginWrite; + inherited Destroy; + CloseHandle(FReadSignal); + CloseHandle(FWriteSignal); + tls.Free; +end; + +procedure TMultiReadExclusiveWriteSynchronizer.BlockReaders; +begin + ResetEvent(FReadSignal); +end; + +procedure TMultiReadExclusiveWriteSynchronizer.UnblockReaders; +begin + SetEvent(FReadSignal); +end; + +procedure TMultiReadExclusiveWriteSynchronizer.UnblockOneWriter; +begin + SetEvent(FWriteSignal); +end; + +procedure TMultiReadExclusiveWriteSynchronizer.WaitForReadSignal; +begin + WaitForSingleObject(FReadSignal, FWaitRecycle); +end; + +procedure TMultiReadExclusiveWriteSynchronizer.WaitForWriteSignal; +begin + WaitForSingleObject(FWriteSignal, FWaitRecycle); +end; + +{$IFDEF DEBUG_MREWS} +var + x: Integer; + +procedure TMultiReadExclusiveWriteSynchronizer.Debug(const Msg: string); +begin + OutputDebugString(PChar(Format('%d %s Thread=%x Sentinel=%d, FWriterID=%x', + [InterlockedIncrement(x), Msg, GetCurrentThreadID, FSentinel, FWriterID]))); +end; +{$ENDIF} + +function TMultiReadExclusiveWriteSynchronizer.BeginWrite: Boolean; +var + Thread: PThreadInfo; + HasReadLock: Boolean; + ThreadID: Cardinal; + Test: Integer; + OldRevisionLevel: Cardinal; +begin + { + States of FSentinel (roughly - during inc/dec's, the states may not be exactly what is said here): + mrWriteRequest: A reader or a writer can get the lock + 1 - (mrWriteRequest-1): A reader (possibly more than one) has the lock + 0: A writer (possibly) just got the lock, if returned from the main write While loop + < 0, but not a multiple of mrWriteRequest: Writer(s) want the lock, but reader(s) have it. + New readers should be blocked, but current readers should be able to call BeginRead + < 0, but a multiple of mrWriteRequest: Writer(s) waiting for a writer to finish + } + + +{$IFDEF DEBUG_MREWS} + Debug('Write enter------------------------------------'); +{$ENDIF} + Result := True; + ThreadID := GetCurrentThreadID; + if FWriterID <> ThreadID then // somebody or nobody has a write lock + begin + // Prevent new readers from entering while we wait for the existing readers + // to exit. + BlockReaders; + + OldRevisionLevel := FRevisionLevel; + + tls.Open(Thread); + // We have another lock already. It must be a read lock, because if it + // were a write lock, FWriterID would be our threadid. + HasReadLock := Thread.RecursionCount > 0; + + if HasReadLock then // acquiring a write lock requires releasing read locks + InterlockedIncrement(FSentinel); + +{$IFDEF DEBUG_MREWS} + Debug('Write before loop'); +{$ENDIF} + // InterlockedExchangeAdd returns prev value + while InterlockedExchangeAdd(FSentinel, -mrWriteRequest) <> mrWriteRequest do + begin +{$IFDEF DEBUG_MREWS} + Debug('Write loop'); + Sleep(1000); // sleep to force / debug race condition + Debug('Write loop2a'); +{$ENDIF} + + // Undo what we did, since we didn't get the lock + Test := InterlockedExchangeAdd(FSentinel, mrWriteRequest); + // If the old value (in Test) was 0, then we may be able to + // get the lock (because it will now be mrWriteRequest). So, + // we continue the loop to find out. Otherwise, we go to sleep, + // waiting for a reader or writer to signal us. + + if Test <> 0 then + begin + {$IFDEF DEBUG_MREWS} + Debug('Write starting to wait'); + {$ENDIF} + WaitForWriteSignal; + end + {$IFDEF DEBUG_MREWS} + else + Debug('Write continue') + {$ENDIF} + end; + + // At the EndWrite, first Writers are awoken, and then Readers are awoken. + // If a Writer got the lock, we don't want the readers to do busy + // waiting. This Block resets the event in case the situation happened. + BlockReaders; + + // Put our read lock marker back before we lose track of it + if HasReadLock then + InterlockedDecrement(FSentinel); + + FWriterID := ThreadID; + + Result := Integer(OldRevisionLevel) = (InterlockedIncrement(Integer(FRevisionLevel)) - 1); + end; + + Inc(FWriteRecursionCount); +{$IFDEF DEBUG_MREWS} + Debug('Write lock-----------------------------------'); +{$ENDIF} +end; + +procedure TMultiReadExclusiveWriteSynchronizer.EndWrite; +var + Thread: PThreadInfo; +begin +{$IFDEF DEBUG_MREWS} + Debug('Write end'); +{$ENDIF} + assert(FWriterID = GetCurrentThreadID); + tls.Open(Thread); + Dec(FWriteRecursionCount); + if FWriteRecursionCount = 0 then + begin + FWriterID := 0; + InterlockedExchangeAdd(FSentinel, mrWriteRequest); + {$IFDEF DEBUG_MREWS} + Debug('Write about to UnblockOneWriter'); + {$ENDIF} + UnblockOneWriter; + {$IFDEF DEBUG_MREWS} + Debug('Write about to UnblockReaders'); + {$ENDIF} + UnblockReaders; + end; + if Thread.RecursionCount = 0 then + tls.Delete(Thread); +{$IFDEF DEBUG_MREWS} + Debug('Write unlock'); +{$ENDIF} +end; + +procedure TMultiReadExclusiveWriteSynchronizer.BeginRead; +var + Thread: PThreadInfo; + WasRecursive: Boolean; + SentValue: Integer; +begin +{$IFDEF DEBUG_MREWS} + Debug('Read enter'); +{$ENDIF} + + tls.Open(Thread); + Inc(Thread.RecursionCount); + WasRecursive := Thread.RecursionCount > 1; + + if FWriterID <> GetCurrentThreadID then + begin +{$IFDEF DEBUG_MREWS} + Debug('Trying to get the ReadLock (we did not have a write lock)'); +{$ENDIF} + // In order to prevent recursive Reads from causing deadlock, + // we need to always WaitForReadSignal if not recursive. + // This prevents unnecessarily decrementing the FSentinel, and + // then immediately incrementing it again. + if not WasRecursive then + begin + // Make sure we don't starve writers. A writer will + // always set the read signal when it is done, and it is initially on. + WaitForReadSignal; + while (InterlockedDecrement(FSentinel) <= 0) do + begin + {$IFDEF DEBUG_MREWS} + Debug('Read loop'); + {$ENDIF} + // Because the InterlockedDecrement happened, it is possible that + // other threads "think" we have the read lock, + // even though we really don't. If we are the last reader to do this, + // then SentValue will become mrWriteRequest + SentValue := InterlockedIncrement(FSentinel); + // So, if we did inc it to mrWriteRequest at this point, + // we need to signal the writer. + if SentValue = mrWriteRequest then + UnblockOneWriter; + + // This sleep below prevents starvation of writers + Sleep(0); + + {$IFDEF DEBUG_MREWS} + Debug('Read loop2 - waiting to be signaled'); + {$ENDIF} + WaitForReadSignal; + {$IFDEF DEBUG_MREWS} + Debug('Read signaled'); + {$ENDIF} + end; + end; + end; +{$IFDEF DEBUG_MREWS} + Debug('Read lock'); +{$ENDIF} +end; + +procedure TMultiReadExclusiveWriteSynchronizer.EndRead; +var + Thread: PThreadInfo; + Test: Integer; +begin +{$IFDEF DEBUG_MREWS} + Debug('Read end'); +{$ENDIF} + tls.Open(Thread); + Dec(Thread.RecursionCount); + if (Thread.RecursionCount = 0) then + begin + tls.Delete(Thread); + + // original code below commented out + if (FWriterID <> GetCurrentThreadID) then + begin + Test := InterlockedIncrement(FSentinel); + // It is possible for Test to be mrWriteRequest + // or, it can be = 0, if the write loops: + // Test := InterlockedExchangeAdd(FSentinel, mrWriteRequest) + mrWriteRequest; + // Did not get executed before this has called (the sleep debug makes it happen faster) + {$IFDEF DEBUG_MREWS} + Debug(Format('Read UnblockOneWriter may be called. Test=%d', [Test])); + {$ENDIF} + if Test = mrWriteRequest then + UnblockOneWriter + else if Test <= 0 then // We may have some writers waiting + begin + if (Test mod mrWriteRequest) = 0 then + UnblockOneWriter; // No more readers left (only writers) so signal one of them + end; + end; + end; +{$IFDEF DEBUG_MREWS} + Debug('Read unlock'); +{$ENDIF} +end; +{$ENDIF} //MSWINDOWS for TMultiReadExclusiveWriteSynchronizer + +procedure FreeAndNil(var Obj); +var + Temp: TObject; +begin + Temp := TObject(Obj); + Pointer(Obj) := nil; + Temp.Free; +end; + +{ Interface support routines } + +function Supports(const Instance: IInterface; const IID: TGUID; out Intf): Boolean; +begin + Result := (Instance <> nil) and (Instance.QueryInterface(IID, Intf) = 0); +end; + +function Supports(const Instance: TObject; const IID: TGUID; out Intf): Boolean; +var + LUnknown: IUnknown; +begin + Result := (Instance <> nil) and + ((Instance.GetInterface(IUnknown, LUnknown) and Supports(LUnknown, IID, Intf)) or + Instance.GetInterface(IID, Intf)); +end; + +function Supports(const Instance: IInterface; const IID: TGUID): Boolean; +var + Temp: IInterface; +begin + Result := Supports(Instance, IID, Temp); +end; + +function Supports(const Instance: TObject; const IID: TGUID): Boolean; +var + Temp: IInterface; +begin + Result := Supports(Instance, IID, Temp); +end; + +function Supports(const AClass: TClass; const IID: TGUID): Boolean; +begin + Result := AClass.GetInterfaceEntry(IID) <> nil; +end; + +{$IFDEF MSWINDOWS} +{ TLanguages } + +var + FTempLanguages: TLanguages; + +function EnumLocalesCallback(LocaleID: PChar): Integer; stdcall; +begin + Result := FTempLanguages.LocalesCallback(LocaleID); +end; + +{ Query the OS for information for a specified locale. Unicode version. Works correctly on Asian WinNT. } +function GetLocaleDataW(ID: LCID; Flag: DWORD): string; +var + Buffer: array[0..1023] of WideChar; +begin + Buffer[0] := #0; + GetLocaleInfoW(ID, Flag, Buffer, SizeOf(Buffer) div 2); + Result := Buffer; +end; + +{ Query the OS for information for a specified locale. ANSI Version. Works correctly on Asian Win95. } +function GetLocaleDataA(ID: LCID; Flag: DWORD): string; +var + Buffer: array[0..1023] of Char; +begin + Buffer[0] := #0; + SetString(Result, Buffer, GetLocaleInfoA(ID, Flag, Buffer, SizeOf(Buffer)) - 1); +end; + +{ Called for each supported locale. } +function TLanguages.LocalesCallback(LocaleID: PChar): Integer; stdcall; +var + AID: LCID; + ShortLangName: string; + GetLocaleDataProc: function (ID: LCID; Flag: DWORD): string; +begin + if Win32Platform = VER_PLATFORM_WIN32_NT then + GetLocaleDataProc := @GetLocaleDataW + else + GetLocaleDataProc := @GetLocaleDataA; + AID := StrToInt('$' + Copy(LocaleID, 5, 4)); + ShortLangName := GetLocaleDataProc(AID, LOCALE_SABBREVLANGNAME); + if ShortLangName <> '' then + begin + SetLength(FSysLangs, Length(FSysLangs) + 1); + with FSysLangs[High(FSysLangs)] do + begin + FName := GetLocaleDataProc(AID, LOCALE_SLANGUAGE); + FLCID := AID; + FExt := ShortLangName; + end; + end; + Result := 1; +end; + +constructor TLanguages.Create; +begin + inherited Create; + FTempLanguages := Self; + EnumSystemLocales(@EnumLocalesCallback, LCID_SUPPORTED); +end; + +function TLanguages.GetCount: Integer; +begin + Result := High(FSysLangs) + 1; +end; + +function TLanguages.GetExt(Index: Integer): string; +begin + Result := FSysLangs[Index].FExt; +end; + +function TLanguages.GetID(Index: Integer): string; +begin + Result := HexDisplayPrefix + IntToHex(FSysLangs[Index].FLCID, 8); +end; + +function TLanguages.GetLCID(Index: Integer): LCID; +begin + Result := FSysLangs[Index].FLCID; +end; + +function TLanguages.GetName(Index: Integer): string; +begin + Result := FSysLangs[Index].FName; +end; + +function TLanguages.GetNameFromLocaleID(ID: LCID): string; +var + Index: Integer; +begin + Result := sUnknown; + Index := IndexOf(ID); + if Index <> - 1 then Result := Name[Index]; + if Result = '' then Result := sUnknown; +end; + +function TLanguages.GetNameFromLCID(const ID: string): string; +begin + Result := NameFromLocaleID[StrToIntDef(ID, 0)]; +end; + +function TLanguages.IndexOf(ID: LCID): Integer; +begin + for Result := Low(FSysLangs) to High(FSysLangs) do + if FSysLangs[Result].FLCID = ID then Exit; + Result := -1; +end; + +var + FLanguages: TLanguages; + +function Languages: TLanguages; +begin + if FLanguages = nil then + FLanguages := TLanguages.Create; + Result := FLanguages; +end; + +function SafeLoadLibrary(const Filename: string; ErrorMode: UINT): HMODULE; +var + OldMode: UINT; + FPUControlWord: Word; +begin + OldMode := SetErrorMode(ErrorMode); + try + asm + FNSTCW FPUControlWord + end; + try + Result := LoadLibrary(PChar(Filename)); + finally + asm + FNCLEX + FLDCW FPUControlWord + end; + end; + finally + SetErrorMode(OldMode); + end; +end; +{$ENDIF} +{$IFDEF LINUX} +function SafeLoadLibrary(const FileName: string; Dummy: LongWord): HMODULE; +var + FPUControlWord: Word; +begin + asm + FNSTCW FPUControlWord + end; + try + Result := LoadLibrary(PChar(Filename)); + finally + asm + FNCLEX + FLDCW FPUControlWord + end; + end; +end; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function GetEnvironmentVariable(const Name: string): string; +const + BufSize = 1024; +var + Len: Integer; + Buffer: array[0..BufSize - 1] of Char; +begin + Result := ''; + Len := Windows.GetEnvironmentVariable(PChar(Name), @Buffer, BufSize); + if Len < BufSize then + SetString(Result, PChar(@Buffer), Len) + else + begin + SetLength(Result, Len - 1); + Windows.GetEnvironmentVariable(PChar(Name), PChar(Result), Len); + end; +end; +{$ENDIF} +{$IFDEF LINUX} +function GetEnvironmentVariable(const Name: string): string; +begin + Result := getenv(PChar(Name)); +end; +{$ENDIF} + +{$IFDEF LINUX} +procedure CheckLocale; +var + P,Q: PChar; +begin + P := gnu_get_libc_version(); + Q := getenv('LC_ALL'); + if (Q = nil) or (Q[0] = #0) then + Q := getenv('LANG'); + + // 2.1.3 <= current version < 2.1.91 + if (strverscmp('2.1.3', P) <= 0) and + (strverscmp(P, '2.1.91') < 0) and + ((Q = nil) or (Q[0] = #0)) then + begin + // GNU libc 2.1.3 will segfault in towupper() if environment variables don't + // specify a locale. This can happen when Apache launches CGI subprocesses. + // Solution: set a locale if the environment variable is missing. + // Works in 2.1.2, fixed in glibc 2.1.91 and later + setlocale(LC_ALL, 'POSIX'); + end + else + // Configure the process locale settings according to + // the system environment variables (LC_CTYPE, LC_COLLATE, etc) + setlocale(LC_ALL, ''); + + // Note: + // POSIX/C is the default locale on many Unix systems, but its 7-bit charset + // causes char to widechar conversions to fail on any high-ascii + // character. To support high-ascii charset conversions, set the + // LC_CTYPE environment variable to something else or call setlocale to set + // the LC_CTYPE information for this process. It doesn't matter what + // you set it to, as long as it's not POSIX. + if StrComp(nl_langinfo(_NL_CTYPE_CODESET_NAME), 'ANSI_X3.4-1968') = 0 then + setlocale(LC_CTYPE, 'en_US'); // selects codepage ISO-8859-1 +end; + +procedure PropagateSignals; +var + Exc: TObject; +begin + { + If there is a current exception pending, then we're shutting down because + it went unhandled. If that exception is the result of a signal, then we + need to propagate that back out to the world as a real signal death. See + the discussion at http://www2.cons.org/cracauer/sigint.html for more info. + } + Exc := ExceptObject; + if (Exc <> nil) and (Exc is EExternal) then + kill(getpid, EExternal(Exc).SignalNumber); +end; + +{ + Under Win32, SafeCallError is implemented in ComObj. Under Linux, we + don't have ComObj, so we've substituted a similar mechanism here. +} +procedure SafeCallError(ErrorCode: Integer; ErrorAddr: Pointer); +var + ExcMsg: String; +begin + ExcMsg := GetSafeCallExceptionMsg; + SetSafeCallExceptionMsg(''); + if ExcMsg <> '' then + begin + raise ESafeCallException.Create(ExcMsg) at GetSafeCallExceptionAddr; + end + else + raise ESafeCallException.CreateRes(@SSafecallException); +end; +{$ENDIF} + +initialization + if ModuleIsCpp then HexDisplayPrefix := '0x'; + InitExceptions; + +{$IFDEF LINUX} + SafeCallErrorProc := @SafeCallError; + ExitProcessProc := PropagateSignals; + + CheckLocale; +{$ENDIF} + +{$IFDEF MSWINDOWS} + InitPlatformId; + InitDriveSpacePtr; +{$ENDIF} + GetFormatSettings; { Win implementation uses platform id } + +finalization +{$IFDEF MSWINDOWS} + FreeAndNil(FLanguages); +{$ENDIF} +{$IFDEF LINUX} + if libuuidHandle <> nil then + dlclose(libuuidHandle); +{$ENDIF} + FreeTerminateProcs; + DoneExceptions; + +end. + diff --git a/System/D2005/System.pas b/System/D2005/System.pas new file mode 100644 index 0000000..2e99b7d --- /dev/null +++ b/System/D2005/System.pas @@ -0,0 +1,18965 @@ + +{ *********************************************************************** } +{ } +{ Delphi / Kylix Cross-Platform Runtime Library } +{ System Unit } +{ } +{ Copyright (c) 1988-2004 Borland Software Corporation } +{ } +{ Copyright and license exceptions noted in source } +{ } +{ *********************************************************************** } + +unit System; { Predefined constants, types, procedures, } + { and functions (such as True, Integer, or } + { Writeln) do not have actual declarations.} + { Instead they are built into the compiler } + { and are treated as if they were declared } + { at the beginning of the System unit. } + +{$H+,I-,R-,O+,W-} +{$WARN SYMBOL_PLATFORM OFF} +{$WARN UNSAFE_TYPE OFF} + +{ L- should never be specified. + + The IDE needs to find DebugHook (through the C++ + compiler sometimes) for integrated debugging to + function properly. + + ILINK will generate debug info for DebugHook if + the object module has not been compiled with debug info. + + ILINK will not generate debug info for DebugHook if + the object module has been compiled with debug info. + + Thus, the Pascal compiler must be responsible for + generating the debug information for that symbol + when a debug-enabled object file is produced. +} + +interface + +(* You can use RTLVersion in $IF expressions to test the runtime library + version level independently of the compiler version level. + Example: {$IF RTLVersion >= 16.2} ... {$IFEND} *) + +const + RTLVersion = 17.00; + +{$EXTERNALSYM CompilerVersion} + +(* +const + CompilerVersion = 0.0; + + CompilerVersion is assigned a value by the compiler when + the system unit is compiled. It indicates the revision level of the + compiler features / language syntax, which may advance independently of + the RTLVersion. CompilerVersion can be tested in $IF expressions and + should be used instead of testing for the VERxxx conditional define. + Always test for greater than or less than a known revision level. + It's a bad idea to test for a specific revision level. +*) + +{$IFDEF DECLARE_GPL} +(* The existence of the GPL symbol indicates that the System unit + and the rest of the Delphi runtime library were compiled for use + and distribution under the terms of the GNU General Public License (GPL). + Under the terms of the GPL, all applications compiled with the + GPL version of the Delphi runtime library must also be distributed + under the terms of the GPL. + For more information about the GNU GPL, see + http://www.gnu.org/copyleft/gpl.html + + The GPL symbol does not exist in the Delphi runtime library + purchased for commercial/proprietary software development. + + If your source code needs to know which licensing model it is being + compiled into, you can use {$IF DECLARED(GPL)}...{$IFEND} to + test for the existence of the GPL symbol. The value of the + symbol itself is not significant. *) + +const + GPL = True; +{$ENDIF} + +{ Variant type codes (wtypes.h) } + + varEmpty = $0000; { vt_empty 0 } + varNull = $0001; { vt_null 1 } + varSmallint = $0002; { vt_i2 2 } + varInteger = $0003; { vt_i4 3 } + varSingle = $0004; { vt_r4 4 } + varDouble = $0005; { vt_r8 5 } + varCurrency = $0006; { vt_cy 6 } + varDate = $0007; { vt_date 7 } + varOleStr = $0008; { vt_bstr 8 } + varDispatch = $0009; { vt_dispatch 9 } + varError = $000A; { vt_error 10 } + varBoolean = $000B; { vt_bool 11 } + varVariant = $000C; { vt_variant 12 } + varUnknown = $000D; { vt_unknown 13 } +//varDecimal = $000E; { vt_decimal 14 } {UNSUPPORTED as of v6.x code base} +//varUndef0F = $000F; { undefined 15 } {UNSUPPORTED per Microsoft} + varShortInt = $0010; { vt_i1 16 } + varByte = $0011; { vt_ui1 17 } + varWord = $0012; { vt_ui2 18 } + varLongWord = $0013; { vt_ui4 19 } + varInt64 = $0014; { vt_i8 20 } +//varWord64 = $0015; { vt_ui8 21 } {UNSUPPORTED as of v6.x code base} +{ if adding new items, update Variants' varLast, BaseTypeMap and OpTypeMap } + + varStrArg = $0048; { vt_clsid 72 } + varString = $0100; { Pascal string 256 } {not OLE compatible } + varAny = $0101; { Corba any 257 } {not OLE compatible } + // custom types range from $110 (272) to $7FF (2047) + + varTypeMask = $0FFF; + varArray = $2000; + varByRef = $4000; + +{ TVarRec.VType values } + + vtInteger = 0; + vtBoolean = 1; + vtChar = 2; + vtExtended = 3; + vtString = 4; + vtPointer = 5; + vtPChar = 6; + vtObject = 7; + vtClass = 8; + vtWideChar = 9; + vtPWideChar = 10; + vtAnsiString = 11; + vtCurrency = 12; + vtVariant = 13; + vtInterface = 14; + vtWideString = 15; + vtInt64 = 16; + +{ Virtual method table entries } + + vmtSelfPtr = -76; + vmtIntfTable = -72; + vmtAutoTable = -68; + vmtInitTable = -64; + vmtTypeInfo = -60; + vmtFieldTable = -56; + vmtMethodTable = -52; + vmtDynamicTable = -48; + vmtClassName = -44; + vmtInstanceSize = -40; + vmtParent = -36; + vmtSafeCallException = -32; + vmtAfterConstruction = -28; + vmtBeforeDestruction = -24; + vmtDispatch = -20; + vmtDefaultHandler = -16; + vmtNewInstance = -12; + vmtFreeInstance = -8; + vmtDestroy = -4; + + vmtQueryInterface = 0; + vmtAddRef = 4; + vmtRelease = 8; + vmtCreateObject = 12; + +type + + TObject = class; + + TClass = class of TObject; + + HRESULT = type Longint; { from WTYPES.H } + {$EXTERNALSYM HRESULT} + + PGUID = ^TGUID; + TGUID = packed record + D1: LongWord; + D2: Word; + D3: Word; + D4: array[0..7] of Byte; + end; + + PInterfaceEntry = ^TInterfaceEntry; + TInterfaceEntry = packed record + IID: TGUID; + VTable: Pointer; + IOffset: Integer; + ImplGetter: Integer; + end; + + PInterfaceTable = ^TInterfaceTable; + TInterfaceTable = packed record + EntryCount: Integer; + Entries: array[0..9999] of TInterfaceEntry; + end; + + TMethod = record + Code, Data: Pointer; + end; + +{ TObject.Dispatch accepts any data type as its Message parameter. The + first 2 bytes of the data are taken as the message id to search for + in the object's message methods. TDispatchMessage is an example of + such a structure with a word field for the message id. +} + TDispatchMessage = record + MsgID: Word; + end; + + TObject = class + constructor Create; + procedure Free; + class function InitInstance(Instance: Pointer): TObject; + procedure CleanupInstance; + function ClassType: TClass; + class function ClassName: ShortString; + class function ClassNameIs(const Name: string): Boolean; + class function ClassParent: TClass; + class function ClassInfo: Pointer; + class function InstanceSize: Longint; + class function InheritsFrom(AClass: TClass): Boolean; + class function MethodAddress(const Name: ShortString): Pointer; + class function MethodName(Address: Pointer): ShortString; + function FieldAddress(const Name: ShortString): Pointer; + function GetInterface(const IID: TGUID; out Obj): Boolean; + class function GetInterfaceEntry(const IID: TGUID): PInterfaceEntry; + class function GetInterfaceTable: PInterfaceTable; + function SafeCallException(ExceptObject: TObject; + ExceptAddr: Pointer): HResult; virtual; + procedure AfterConstruction; virtual; + procedure BeforeDestruction; virtual; + procedure Dispatch(var Message); virtual; + procedure DefaultHandler(var Message); virtual; + class function NewInstance: TObject; virtual; + procedure FreeInstance; virtual; + destructor Destroy; virtual; + end; + +const + S_OK = 0; {$EXTERNALSYM S_OK} + S_FALSE = $00000001; {$EXTERNALSYM S_FALSE} + E_NOINTERFACE = HRESULT($80004002); {$EXTERNALSYM E_NOINTERFACE} + E_UNEXPECTED = HRESULT($8000FFFF); {$EXTERNALSYM E_UNEXPECTED} + E_NOTIMPL = HRESULT($80004001); {$EXTERNALSYM E_NOTIMPL} + +type + IInterface = interface + ['{00000000-0000-0000-C000-000000000046}'] + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + end; + + (*$HPPEMIT '#define IInterface IUnknown' *) + + IUnknown = IInterface; +{$M+} + IInvokable = interface(IInterface) + end; +{$M-} + + IDispatch = interface(IUnknown) + ['{00020400-0000-0000-C000-000000000046}'] + function GetTypeInfoCount(out Count: Integer): HResult; stdcall; + function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall; + function GetIDsOfNames(const IID: TGUID; Names: Pointer; + NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall; + function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; + Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall; + end; + +{$EXTERNALSYM IUnknown} +{$EXTERNALSYM IDispatch} + +{ TInterfacedObject provides a threadsafe default implementation + of IInterface. You should use TInterfaceObject as the base class + of objects implementing interfaces. } + + TInterfacedObject = class(TObject, IInterface) + protected + FRefCount: Integer; + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + public + procedure AfterConstruction; override; + procedure BeforeDestruction; override; + class function NewInstance: TObject; override; + property RefCount: Integer read FRefCount; + end; + + TInterfacedClass = class of TInterfacedObject; + +{ TAggregatedObject and TContainedObject are suitable base + classes for interfaced objects intended to be aggregated + or contained in an outer controlling object. When using + the "implements" syntax on an interface property in + an outer object class declaration, use these types + to implement the inner object. + + Interfaces implemented by aggregated objects on behalf of + the controller should not be distinguishable from other + interfaces provided by the controller. Aggregated objects + must not maintain their own reference count - they must + have the same lifetime as their controller. To achieve this, + aggregated objects reflect the reference count methods + to the controller. + + TAggregatedObject simply reflects QueryInterface calls to + its controller. From such an aggregated object, one can + obtain any interface that the controller supports, and + only interfaces that the controller supports. This is + useful for implementing a controller class that uses one + or more internal objects to implement the interfaces declared + on the controller class. Aggregation promotes implementation + sharing across the object hierarchy. + + TAggregatedObject is what most aggregate objects should + inherit from, especially when used in conjunction with + the "implements" syntax. } + + TAggregatedObject = class(TObject) + private + FController: Pointer; // weak reference to controller + function GetController: IInterface; + protected + { IInterface } + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + public + constructor Create(const Controller: IInterface); + property Controller: IInterface read GetController; + end; + + { TContainedObject is an aggregated object that isolates + QueryInterface on the aggregate from the controller. + TContainedObject will return only interfaces that the + contained object itself implements, not interfaces + that the controller implements. This is useful for + implementing nodes that are attached to a controller and + have the same lifetime as the controller, but whose + interface identity is separate from the controller. + You might do this if you don't want the consumers of + an aggregated interface to have access to other interfaces + implemented by the controller - forced encapsulation. + This is a less common case than TAggregatedObject. } + + TContainedObject = class(TAggregatedObject, IInterface) + protected + { IInterface } + function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall; + end; + + TClassHelperBase = class(TInterfacedObject, IInterface) + protected + FInstance: TObject; + constructor _Create(Instance: TObject); + end; + + PShortString = ^ShortString; + PAnsiString = ^AnsiString; + PWideString = ^WideString; + PString = PAnsiString; + + UCS2Char = WideChar; + PUCS2Char = PWideChar; + UCS4Char = type LongWord; + {$NODEFINE UCS4CHAR} + PUCS4Char = ^UCS4Char; + {$NODEFINE PUCS4CHAR} + TUCS4CharArray = array [0..$effffff] of UCS4Char; + PUCS4CharArray = ^TUCS4CharArray; + UCS4String = array of UCS4Char; + {$NODEFINE UCS4String} + + UTF8String = type string; + PUTF8String = ^UTF8String; + {$NODEFINE UTF8String} + {$NODEFINE PUTF8String} + + IntegerArray = array[0..$effffff] of Integer; + PIntegerArray = ^IntegerArray; + PointerArray = array [0..512*1024*1024 - 2] of Pointer; + PPointerArray = ^PointerArray; + TBoundArray = array of Integer; + TPCharArray = packed array[0..(MaxLongint div SizeOf(PChar))-1] of PChar; + PPCharArray = ^TPCharArray; + + (*$HPPEMIT 'namespace System' *) + (*$HPPEMIT '{' *) + (*$HPPEMIT ' typedef int *PLongint;' *) + (*$HPPEMIT ' typedef bool *PBoolean;' *) + (*$HPPEMIT ' typedef PChar *PPChar;' *) + (*$HPPEMIT ' typedef double *PDouble;' *) + (*$HPPEMIT ' typedef wchar_t UCS4Char;' *) + (*$HPPEMIT ' typedef wchar_t *PUCS4Char;' *) + (*$HPPEMIT ' typedef DynamicArray UCS4String;' *) + (*$HPPEMIT '}' *) + PLongint = ^Longint; + {$EXTERNALSYM PLongint} + PInteger = ^Integer; + PCardinal = ^Cardinal; + PWord = ^Word; + PSmallInt = ^SmallInt; + PByte = ^Byte; + PShortInt = ^ShortInt; + PInt64 = ^Int64; + PLongWord = ^LongWord; + PSingle = ^Single; + PDouble = ^Double; + PDate = ^Double; + PDispatch = ^IDispatch; + PPDispatch = ^PDispatch; + PError = ^LongWord; + PWordBool = ^WordBool; + PUnknown = ^IUnknown; + PPUnknown = ^PUnknown; + {$NODEFINE PByte} + PPWideChar = ^PWideChar; + PPChar = ^PChar; + PPAnsiChar = PPChar; + PExtended = ^Extended; + PComp = ^Comp; + PCurrency = ^Currency; + PVariant = ^Variant; + POleVariant = ^OleVariant; + PPointer = ^Pointer; + PBoolean = ^Boolean; + + TDateTime = type Double; + PDateTime = ^TDateTime; + + THandle = LongWord; + + TVarArrayBound = packed record + ElementCount: Integer; + LowBound: Integer; + end; + TVarArrayBoundArray = array [0..0] of TVarArrayBound; + PVarArrayBoundArray = ^TVarArrayBoundArray; + TVarArrayCoorArray = array [0..0] of Integer; + PVarArrayCoorArray = ^TVarArrayCoorArray; + + PVarArray = ^TVarArray; + TVarArray = packed record + DimCount: Word; + Flags: Word; + ElementSize: Integer; + LockCount: Integer; + Data: Pointer; + Bounds: TVarArrayBoundArray; + end; + + TVarType = Word; + PVarData = ^TVarData; + {$EXTERNALSYM PVarData} + TVarData = packed record + VType: TVarType; + case Integer of + // 0: (VType: TVarType; + // case Integer of + 0: (Reserved1: Word; + case Integer of + 0: (Reserved2, Reserved3: Word; + case Integer of + varSmallInt: (VSmallInt: SmallInt); + varInteger: (VInteger: Integer); + varSingle: (VSingle: Single); + varDouble: (VDouble: Double); + varCurrency: (VCurrency: Currency); + varDate: (VDate: TDateTime); + varOleStr: (VOleStr: PWideChar); + varDispatch: (VDispatch: Pointer); + varError: (VError: LongWord); + varBoolean: (VBoolean: WordBool); + varUnknown: (VUnknown: Pointer); + varShortInt: (VShortInt: ShortInt); + varByte: (VByte: Byte); + varWord: (VWord: Word); + varLongWord: (VLongWord: LongWord); + varInt64: (VInt64: Int64); + varString: (VString: Pointer); + varAny: (VAny: Pointer); + varArray: (VArray: PVarArray); + varByRef: (VPointer: Pointer); + ); + 1: (VLongs: array[0..2] of LongInt); + ); + 2: (VWords: array [0..6] of Word); + 3: (VBytes: array [0..13] of Byte); + end; + {$EXTERNALSYM TVarData} + +type + TVarOp = Integer; + +const + opAdd = 0; + opSubtract = 1; + opMultiply = 2; + opDivide = 3; + opIntDivide = 4; + opModulus = 5; + opShiftLeft = 6; + opShiftRight = 7; + opAnd = 8; + opOr = 9; + opXor = 10; + opCompare = 11; + opNegate = 12; + opNot = 13; + + opCmpEQ = 14; + opCmpNE = 15; + opCmpLT = 16; + opCmpLE = 17; + opCmpGT = 18; + opCmpGE = 19; + +type + { Dispatch call descriptor } + PCallDesc = ^TCallDesc; + TCallDesc = packed record + CallType: Byte; + ArgCount: Byte; + NamedArgCount: Byte; + ArgTypes: array[0..255] of Byte; + end; + + PDispDesc = ^TDispDesc; + TDispDesc = packed record + DispID: Integer; + ResType: Byte; + CallDesc: TCallDesc; + end; + + PVariantManager = ^TVariantManager; + {$EXTERNALSYM PVariantManager} + TVariantManager = record + VarClear: procedure(var V : Variant); + VarCopy: procedure(var Dest: Variant; const Source: Variant); + VarCopyNoInd: procedure; // ARGS PLEASE! + VarCast: procedure(var Dest: Variant; const Source: Variant; VarType: Integer); + VarCastOle: procedure(var Dest: Variant; const Source: Variant; VarType: Integer); + + VarToInt: function(const V: Variant): Integer; + VarToInt64: function(const V: Variant): Int64; + VarToBool: function(const V: Variant): Boolean; + VarToReal: function(const V: Variant): Extended; + VarToCurr: function(const V: Variant): Currency; + VarToPStr: procedure(var S; const V: Variant); + VarToLStr: procedure(var S: string; const V: Variant); + VarToWStr: procedure(var S: WideString; const V: Variant); + VarToIntf: procedure(var Unknown: IInterface; const V: Variant); + VarToDisp: procedure(var Dispatch: IDispatch; const V: Variant); + VarToDynArray: procedure(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer); + + VarFromInt: procedure(var V: Variant; const Value: Integer; Range: Integer); + VarFromInt64: procedure(var V: Variant; const Value: Int64); + VarFromBool: procedure(var V: Variant; const Value: Boolean); + VarFromReal: procedure; // var V: Variant; const Value: Real + VarFromTDateTime: procedure; // var V: Variant; const Value: TDateTime + VarFromCurr: procedure; // var V: Variant; const Value: Currency + VarFromPStr: procedure(var V: Variant; const Value: ShortString); + VarFromLStr: procedure(var V: Variant; const Value: string); + VarFromWStr: procedure(var V: Variant; const Value: WideString); + VarFromIntf: procedure(var V: Variant; const Value: IInterface); + VarFromDisp: procedure(var V: Variant; const Value: IDispatch); + VarFromDynArray: procedure(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer); + OleVarFromPStr: procedure(var V: OleVariant; const Value: ShortString); + OleVarFromLStr: procedure(var V: OleVariant; const Value: string); + OleVarFromVar: procedure(var V: OleVariant; const Value: Variant); + OleVarFromInt: procedure(var V: OleVariant; const Value: Integer; Range: Integer); + + VarOp: procedure(var Left: Variant; const Right: Variant; OpCode: TVarOp); + VarCmp: procedure(const Left, Right: TVarData; const OpCode: TVarOp); { result is set in the flags } + VarNeg: procedure(var V: Variant); + VarNot: procedure(var V: Variant); + + DispInvoke: procedure(Dest: PVarData; const Source: TVarData; + CallDesc: PCallDesc; Params: Pointer); cdecl; + VarAddRef: procedure(var V: Variant); + + VarArrayRedim: procedure(var A : Variant; HighBound: Integer); + VarArrayGet: function(var A: Variant; IndexCount: Integer; + Indices: Integer): Variant; cdecl; + VarArrayPut: procedure(var A: Variant; const Value: Variant; + IndexCount: Integer; Indices: Integer); cdecl; + + WriteVariant: function(var T: Text; const V: Variant; Width: Integer): Pointer; + Write0Variant: function(var T: Text; const V: Variant): Pointer; + end; + {$EXTERNALSYM TVariantManager} + + { Dynamic array support } + PDynArrayTypeInfo = ^TDynArrayTypeInfo; + {$EXTERNALSYM PDynArrayTypeInfo} + TDynArrayTypeInfo = packed record + kind: Byte; + name: string[0]; + elSize: Longint; + elType: ^PDynArrayTypeInfo; + varType: Integer; + end; + {$EXTERNALSYM TDynArrayTypeInfo} + + PVarRec = ^TVarRec; + TVarRec = record { do not pack this record; it is compiler-generated } + case Byte of + vtInteger: (VInteger: Integer; VType: Byte); + vtBoolean: (VBoolean: Boolean); + vtChar: (VChar: Char); + vtExtended: (VExtended: PExtended); + vtString: (VString: PShortString); + vtPointer: (VPointer: Pointer); + vtPChar: (VPChar: PChar); + vtObject: (VObject: TObject); + vtClass: (VClass: TClass); + vtWideChar: (VWideChar: WideChar); + vtPWideChar: (VPWideChar: PWideChar); + vtAnsiString: (VAnsiString: Pointer); + vtCurrency: (VCurrency: PCurrency); + vtVariant: (VVariant: PVariant); + vtInterface: (VInterface: Pointer); + vtWideString: (VWideString: Pointer); + vtInt64: (VInt64: PInt64); + end; + + PMemoryManager = ^TMemoryManager; + TMemoryManager = record + GetMem: function(Size: Integer): Pointer; + FreeMem: function(P: Pointer): Integer; + ReallocMem: function(P: Pointer; Size: Integer): Pointer; + end; + + THeapStatus = record + TotalAddrSpace: Cardinal; + TotalUncommitted: Cardinal; + TotalCommitted: Cardinal; + TotalAllocated: Cardinal; + TotalFree: Cardinal; + FreeSmall: Cardinal; + FreeBig: Cardinal; + Unused: Cardinal; + Overhead: Cardinal; + HeapErrorCode: Cardinal; + end; + +{$IFDEF PC_MAPPED_EXCEPTIONS} + PUnwinder = ^TUnwinder; + TUnwinder = record + RaiseException: function(Exc: Pointer): LongBool; cdecl; + RegisterIPLookup: function(fn: Pointer; StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; cdecl; + UnregisterIPLookup: procedure(StartAddr: LongInt) cdecl; + DelphiLookup: function(Addr: LongInt; Context: Pointer): Pointer; cdecl; + ClosestHandler: function(Context: Pointer): LongWord; cdecl; + end; +{$ENDIF PC_MAPPED_EXCEPTIONS} + + PackageUnitEntry = packed record + Init, FInit : Pointer; + end; + + { Compiler generated table to be processed sequentially to init & finit all package units } + { Init: 0..Max-1; Final: Last Initialized..0 } + UnitEntryTable = array [0..9999999] of PackageUnitEntry; + PUnitEntryTable = ^UnitEntryTable; + + PackageInfoTable = packed record + UnitCount : Integer; { number of entries in UnitInfo array; always > 0 } + UnitInfo : PUnitEntryTable; + end; + + PackageInfo = ^PackageInfoTable; + + { Each package exports a '@GetPackageInfoTable' which can be used to retrieve } + { the table which contains compiler generated information about the package DLL } + GetPackageInfoTable = function : PackageInfo; + +{$IFDEF DEBUG_FUNCTIONS} +{ Inspector Query; implementation in GETMEM.INC; no need to conditionalize that } + THeapBlock = record + Start: Pointer; + Size: Cardinal; + end; + + THeapBlockArray = array of THeapBlock; + TObjectArray = array of TObject; + +function GetHeapBlocks: THeapBlockArray; +function FindObjects(AClass: TClass; FindDerived: Boolean): TObjectArray; +{ Inspector Query } +{$ENDIF} + +{ + When an exception is thrown, the exception object that is thrown is destroyed + automatically when the except clause which handles the exception is exited. + There are some cases in which an application may wish to acquire the thrown + object and keep it alive after the except clause is exited. For this purpose, + we have added the AcquireExceptionObject and ReleaseExceptionObject functions. + These functions maintain a reference count on the most current exception object, + allowing applications to legitimately obtain references. If the reference count + for an exception that is being thrown is positive when the except clause is exited, + then the thrown object is not destroyed by the RTL, but assumed to be in control + of the application. It is then the application's responsibility to destroy the + thrown object. If the reference count is zero, then the RTL will destroy the + thrown object when the except clause is exited. +} +function AcquireExceptionObject: Pointer; +procedure ReleaseExceptionObject; + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure GetUnwinder(var Dest: TUnwinder); +procedure SetUnwinder(const NewUnwinder: TUnwinder); +function IsUnwinderSet: Boolean; + +//function SysRegisterIPLookup(ModuleHandle, StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; +{ + Do NOT call these functions. They are for internal use only: + SysRegisterIPLookup + SysUnregisterIPLookup + BlockOSExceptions + UnblockOSExceptions + AreOSExceptionsBlocked +} +function SysRegisterIPLookup(StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; +procedure SysUnregisterIPLookup(StartAddr: LongInt); +//function SysAddressIsInPCMap(Addr: LongInt): Boolean; +function SysClosestDelphiHandler(Context: Pointer): LongWord; +procedure BlockOSExceptions; +procedure UnblockOSExceptions; +function AreOSExceptionsBlocked: Boolean; + +{$ELSE} +// These functions are not portable. Use AcquireExceptionObject above instead +function RaiseList: Pointer; deprecated; { Stack of current exception objects } +function SetRaiseList(NewPtr: Pointer): Pointer; deprecated; { returns previous value } +{$ENDIF} + +function ExceptObject: TObject; +function ExceptAddr: Pointer; + +procedure SetInOutRes(NewValue: Integer); + +type + TAssertErrorProc = procedure (const Message, Filename: string; + LineNumber: Integer; ErrorAddr: Pointer); + TSafeCallErrorProc = procedure (ErrorCode: HResult; ErrorAddr: Pointer); + +{$IFDEF DEBUG} +{ + This variable is just for debugging the exception handling system. See + _DbgExcNotify for the usage. +} +var + ExcNotificationProc : procedure ( NotificationKind: Integer; + ExceptionObject: Pointer; + ExceptionName: PShortString; + ExceptionLocation: Pointer; + HandlerAddr: Pointer) = nil; +{$ENDIF} + +var + DispCallByIDProc: Pointer; + ExceptProc: Pointer; { Unhandled exception handler } + ErrorProc: procedure (ErrorCode: Byte; ErrorAddr: Pointer); { Error handler procedure } +{$IFDEF MSWINDOWS} + ExceptClsProc: Pointer; { Map an OS Exception to a Delphi class reference } + ExceptObjProc: Pointer; { Map an OS Exception to a Delphi class instance } + RaiseExceptionProc: Pointer; + RTLUnwindProc: Pointer; +{$ENDIF} + ExceptionClass: TClass; { Exception base class (must be Exception) } + SafeCallErrorProc: TSafeCallErrorProc; { Safecall error handler } + AssertErrorProc: TAssertErrorProc; { Assertion error handler } + ExitProcessProc: procedure; { Hook to be called just before the process actually exits } + AbstractErrorProc: procedure; { Abstract method error handler } + HPrevInst: LongWord deprecated; { Handle of previous instance - HPrevInst cannot be tested for multiple instances in Win32} + MainInstance: LongWord; { Handle of the main(.EXE) HInstance } + MainThreadID: LongWord; { ThreadID of thread that module was initialized in } + IsLibrary: Boolean; { True if module is a DLL } + {$IFDEF MSWINDOWS} +{X} function CmdShow : Integer; +{X} function CmdLine : PChar; +{$ELSE} + CmdShow: Integer platform; { CmdShow parameter for CreateWindow } + CmdLine: PChar platform; { Command line pointer } +{$ENDIF} +var + InitProc: Pointer; { Last installed initialization procedure } + ExitCode: Integer = 0; { Program result } + ExitProc: Pointer; { Last installed exit procedure } + ErrorAddr: Pointer = nil; { Address of run-time error } + RandSeed: Longint = 0; { Base for random number generator } + IsConsole: Boolean; { True if compiled as console app } + IsMultiThread: Boolean; { True if more than one thread } + FileMode: Byte = 2; { Standard mode for opening files } +{$IFDEF LINUX} + FileAccessRights: Integer platform; { Default access rights for opening files } + ArgCount: Integer platform; + ArgValues: PPChar platform; +{$ENDIF} + Test8086: Byte; { CPU family (minus one) See consts below } + Test8087: Byte = 3; { assume 80387 FPU or OS supplied FPU emulation } + TestFDIV: Shortint; { -1: Flawed Pentium, 0: Not determined, 1: Ok } + Input: Text; { Standard input } + Output: Text; { Standard output } + ErrOutput: Text; { Standard error output } + envp: PPChar platform; + +const + CPUi386 = 2; + CPUi486 = 3; + CPUPentium = 4; + +var + Default8087CW: Word = $1332;{ Default 8087 control word. FPU control + register is set to this value. + CAUTION: Setting this to an invalid value + could cause unpredictable behavior. } + + HeapAllocFlags: Word platform = 2; { Heap allocation flags, gmem_Moveable } + DebugHook: Byte platform = 0; { 1 to notify debugger of non-Delphi exceptions + >1 to notify debugger of exception unwinding } + JITEnable: Byte platform = 0; { 1 to call UnhandledExceptionFilter if the exception + is not a Pascal exception. + >1 to call UnhandledExceptionFilter for all exceptions } + NoErrMsg: Boolean platform = False; { True causes the base RTL to not display the message box + when a run-time error occurs } +{$IFDEF LINUX} + { CoreDumpEnabled = True will cause unhandled + exceptions and runtime errors to raise a + SIGABRT signal, which will cause the OS to + coredump the process address space. This can + be useful for postmortem debugging. } + CoreDumpEnabled: Boolean platform = False; +{$ENDIF} + +type +(*$NODEFINE TTextLineBreakStyle*) + TTextLineBreakStyle = (tlbsLF, tlbsCRLF); + +var { Text output line break handling. Default value for all text files } + DefaultTextLineBreakStyle: TTextLineBreakStyle = {$IFDEF LINUX} tlbsLF {$ENDIF} + {$IFDEF MSWINDOWS} tlbsCRLF {$ENDIF}; +const + sLineBreak = {$IFDEF LINUX} #10 {$ENDIF} {$IFDEF MSWINDOWS} #13#10 {$ENDIF}; + +type + HRSRC = THandle; + TResourceHandle = HRSRC; // make an opaque handle type + HINST = THandle; + HMODULE = HINST; + HGLOBAL = THandle; + +{$IFDEF ELF} +{ ELF resources } +function FindResource(ModuleHandle: HMODULE; ResourceName, ResourceType: PChar): TResourceHandle; +function LoadResource(ModuleHandle: HMODULE; ResHandle: TResourceHandle): HGLOBAL; +function SizeofResource(ModuleHandle: HMODULE; ResHandle: TResourceHandle): Integer; +function LockResource(ResData: HGLOBAL): Pointer; +function UnlockResource(ResData: HGLOBAL): LongBool; +function FreeResource(ResData: HGLOBAL): LongBool; +{$ENDIF} + +{ Memory manager support } +{X} procedure UseDelphiMemoryManager; +{X} function IsDelphiMemoryManagerSet : Boolean; +{X} function MemoryManagerNotUsed : Boolean; + +procedure GetMemoryManager(var MemMgr: TMemoryManager); +procedure SetMemoryManager(const MemMgr: TMemoryManager); +//function IsMemoryManagerSet: Boolean; +var IsMemoryManagerSet : function : Boolean = MemoryManagerNotUsed; + +function SysGetMem(Size: Integer): Pointer; +function SysFreeMem(P: Pointer): Integer; +function SysReallocMem(P: Pointer; Size: Integer): Pointer; + +var + AllocMemCount: Integer; { Number of allocated memory blocks } + AllocMemSize: Integer; { Total size of allocated memory blocks } + +{$IFDEF MSWINDOWS} +function GetHeapStatus: THeapStatus; platform; +{$ENDIF} + +{ Thread support } +type + TThreadFunc = function(Parameter: Pointer): Integer; +{$IFDEF LINUX} + TSize_T = Cardinal; + + TSchedParam = record + sched_priority: Integer; + end; + + pthread_attr_t = record + __detachstate, + __schedpolicy: Integer; + __schedparam: TSchedParam; + __inheritsched, + __scope: Integer; + __guardsize: TSize_T; + __stackaddr_set: Integer; + __stackaddr: Pointer; + __stacksize: TSize_T; + end; + {$EXTERNALSYM pthread_attr_t} + TThreadAttr = pthread_attr_t; + PThreadAttr = ^TThreadAttr; + + TBeginThreadProc = function (Attribute: PThreadAttr; + ThreadFunc: TThreadFunc; Parameter: Pointer; + var ThreadId: Cardinal): Integer; + TEndThreadProc = procedure(ExitCode: Integer); + +var + BeginThreadProc: TBeginThreadProc = nil; + EndThreadProc: TEndThreadProc = nil; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function BeginThread(SecurityAttributes: Pointer; StackSize: LongWord; + ThreadFunc: TThreadFunc; Parameter: Pointer; CreationFlags: LongWord; + var ThreadId: LongWord): Integer; +{$ENDIF} +{$IFDEF LINUX} +function BeginThread(Attribute: PThreadAttr; ThreadFunc: TThreadFunc; + Parameter: Pointer; var ThreadId: Cardinal): Integer; + +{$ENDIF} +procedure EndThread(ExitCode: Integer); + +{ Standard procedures and functions } + +const +{ File mode magic numbers } + + fmClosed = $D7B0; + fmInput = $D7B1; + fmOutput = $D7B2; + fmInOut = $D7B3; + +{ Text file flags } + tfCRLF = $1; // Dos compatibility flag, for CR+LF line breaks and EOF checks + +type +{ Typed-file and untyped-file record } + + TFileRec = packed record (* must match the size the compiler generates: 332 bytes *) + Handle: Integer; + Mode: Word; + Flags: Word; + case Byte of + 0: (RecSize: Cardinal); // files of record + 1: (BufSize: Cardinal; // text files + BufPos: Cardinal; + BufEnd: Cardinal; + BufPtr: PChar; + OpenFunc: Pointer; + InOutFunc: Pointer; + FlushFunc: Pointer; + CloseFunc: Pointer; + UserData: array[1..32] of Byte; + Name: array[0..259] of Char; ); + end; + +{ Text file record structure used for Text files } + PTextBuf = ^TTextBuf; + TTextBuf = array[0..127] of Char; + TTextRec = packed record (* must match the size the compiler generates: 460 bytes *) + Handle: Integer; (* must overlay with TFileRec *) + Mode: Word; + Flags: Word; + BufSize: Cardinal; + BufPos: Cardinal; + BufEnd: Cardinal; + BufPtr: PChar; + OpenFunc: Pointer; + InOutFunc: Pointer; + FlushFunc: Pointer; + CloseFunc: Pointer; + UserData: array[1..32] of Byte; + Name: array[0..259] of Char; + Buffer: TTextBuf; + end; + + TTextIOFunc = function (var F: TTextRec): Integer; + TFileIOFunc = function (var F: TFileRec): Integer; + +procedure SetLineBreakStyle(var T: Text; Style: TTextLineBreakStyle); + +procedure ChDir(const S: string); overload; +procedure ChDir(P: PChar); overload; +function Flush(var t: Text): Integer; +procedure _LGetDir(D: Byte; var S: string); +procedure _SGetDir(D: Byte; var S: ShortString); +function IOResult: Integer; +procedure MkDir(const S: string); overload; +procedure MkDir(P: PChar); overload; +procedure Move(const Source; var Dest; Count: Integer); +function ParamCount: Integer; +function ParamStr(Index: Integer): string; +procedure RmDir(const S: string); overload; +procedure RmDir(P: PChar); overload; +function UpCase(Ch: Char): Char; + +{ random functions } +procedure Randomize; + +function Random(const ARange: Integer): Integer; overload; +function Random: Extended; overload; + + +{ Control 8087 control word } + +procedure Set8087CW(NewCW: Word); +function Get8087CW: Word; + +{ Wide character support procedures and functions for C++ } +{ These functions should not be used in Delphi code! + (conversion is implicit in Delphi code) } + +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; + +{ PUCS4Chars returns a pointer to the UCS4 char data in the + UCS4String array, or a pointer to a null char if UCS4String is empty } + +function PUCS4Chars(const S: UCS4String): PUCS4Char; + +{ Widestring <-> UCS4 conversion } + +function WideStringToUCS4String(const S: WideString): UCS4String; +function UCS4StringToWideString(const S: UCS4String): WideString; + +{ PChar/PWideChar Unicode <-> UTF8 conversion } + +// UnicodeToUTF8(3): +// UTF8ToUnicode(3): +// Scans the source data to find the null terminator, up to MaxBytes +// Dest must have MaxBytes available in Dest. +// MaxDestBytes includes the null terminator (last char in the buffer will be set to null) +// Function result includes the null terminator. + +function UnicodeToUtf8(Dest: PChar; Source: PWideChar; MaxBytes: Integer): Integer; overload; deprecated; +function Utf8ToUnicode(Dest: PWideChar; Source: PChar; MaxChars: Integer): Integer; overload; deprecated; + +// UnicodeToUtf8(4): +// UTF8ToUnicode(4): +// MaxDestBytes includes the null terminator (last char in the buffer will be set to null) +// Function result includes the null terminator. +// Nulls in the source data are not considered terminators - SourceChars must be accurate + +function UnicodeToUtf8(Dest: PChar; MaxDestBytes: Cardinal; Source: PWideChar; SourceChars: Cardinal): Cardinal; overload; +function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: Cardinal; Source: PChar; SourceBytes: Cardinal): Cardinal; overload; + +{ WideString <-> UTF8 conversion } + +function UTF8Encode(const WS: WideString): UTF8String; +function UTF8Decode(const S: UTF8String): WideString; + +{ Ansi <-> UTF8 conversion } + +function AnsiToUtf8(const S: string): UTF8String; +function Utf8ToAnsi(const S: UTF8String): string; + +{ OLE string support procedures and functions } + +function OleStrToString(Source: PWideChar): string; +procedure OleStrToStrVar(Source: PWideChar; var Dest: string); +function StringToOleStr(const Source: string): PWideChar; + +{ Variant manager support procedures and functions (obsolete - see Variants.pas) } + +procedure GetVariantManager(var VarMgr: TVariantManager); +procedure SetVariantManager(const VarMgr: TVariantManager); +function IsVariantManagerSet: Boolean; + +{ Variant support procedures and functions } + +procedure _VarClear(var V: Variant); +procedure _VarCopy(var Dest: Variant; const Source: Variant); +procedure _VarCopyNoInd; +procedure _VarCast(var Dest: Variant; const Source: Variant; VarType: Integer); +procedure _VarCastOle(var Dest: Variant; const Source: Variant; VarType: Integer); +procedure _VarClr(var V: Variant); + +{ Variant text streaming support } + +function _WriteVariant(var T: Text; const V: Variant; Width: Integer): Pointer; +function _Write0Variant(var T: Text; const V: Variant): Pointer; + +{ Variant math and conversion support } + +function _VarToInt(const V: Variant): Integer; +function _VarToInt64(const V: Variant): Int64; +function _VarToBool(const V: Variant): Boolean; +function _VarToReal(const V: Variant): Extended; +function _VarToCurr(const V: Variant): Currency; +procedure _VarToPStr(var S; const V: Variant); +procedure _VarToLStr(var S: string; const V: Variant); +procedure _VarToWStr(var S: WideString; const V: Variant); +procedure _VarToIntf(var Unknown: IInterface; const V: Variant); +procedure _VarToDisp(var Dispatch: IDispatch; const V: Variant); +procedure _VarToDynArray(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer); + +procedure _VarFromInt(var V: Variant; const Value, Range: Integer); +procedure _VarFromInt64(var V: Variant; const Value: Int64); +procedure _VarFromBool(var V: Variant; const Value: Boolean); +procedure _VarFromReal; // var V: Variant; const Value: Real +procedure _VarFromTDateTime; // var V: Variant; const Value: TDateTime +procedure _VarFromCurr; // var V: Variant; const Value: Currency +procedure _VarFromPStr(var V: Variant; const Value: ShortString); +procedure _VarFromLStr(var V: Variant; const Value: string); +procedure _VarFromWStr(var V: Variant; const Value: WideString); +procedure _VarFromIntf(var V: Variant; const Value: IInterface); +procedure _VarFromDisp(var V: Variant; const Value: IDispatch); +procedure _VarFromDynArray(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer); +procedure _OleVarFromPStr(var V: OleVariant; const Value: ShortString); +procedure _OleVarFromLStr(var V: OleVariant; const Value: string); +procedure _OleVarFromVar(var V: OleVariant; const Value: Variant); +procedure _OleVarFromInt(var V: OleVariant; const Value, Range: Integer); + +procedure _VarAdd(var Left: Variant; const Right: Variant); +procedure _VarSub(var Left: Variant; const Right: Variant); +procedure _VarMul(var Left: Variant; const Right: Variant); +procedure _VarDiv(var Left: Variant; const Right: Variant); +procedure _VarMod(var Left: Variant; const Right: Variant); +procedure _VarAnd(var Left: Variant; const Right: Variant); +procedure _VarOr(var Left: Variant; const Right: Variant); +procedure _VarXor(var Left: Variant; const Right: Variant); +procedure _VarShl(var Left: Variant; const Right: Variant); +procedure _VarShr(var Left: Variant; const Right: Variant); +procedure _VarRDiv(var Left: Variant; const Right: Variant); + +procedure _VarCmpEQ(const Left, Right: Variant); // result is set in the flags +procedure _VarCmpNE(const Left, Right: Variant); // result is set in the flags +procedure _VarCmpLT(const Left, Right: Variant); // result is set in the flags +procedure _VarCmpLE(const Left, Right: Variant); // result is set in the flags +procedure _VarCmpGT(const Left, Right: Variant); // result is set in the flags +procedure _VarCmpGE(const Left, Right: Variant); // result is set in the flags + +procedure _VarNeg(var V: Variant); +procedure _VarNot(var V: Variant); + +{ Variant dispatch and reference support } + +procedure _DispInvoke; cdecl; // Dest: PVarData; const Source: TVarData; + // CallDesc: PCallDesc; Params: Pointer + +{ Interface dispatch support } + +procedure _IntfDispCall; cdecl; // ARGS PLEASE! +procedure _IntfVarCall; cdecl; // ARGS PLEASE! +procedure _VarAddRef(var V: Variant); + +{ Variant array support procedures and functions } + +procedure _VarArrayRedim(var A : Variant; HighBound: Integer); +function _VarArrayGet(var A: Variant; IndexCount: Integer; + Indices: Integer): Variant; cdecl; +procedure _VarArrayPut(var A: Variant; const Value: Variant; + IndexCount: Integer; Indices: Integer); cdecl; + +{ Package/Module registration and unregistration } + +type + PLibModule = ^TLibModule; + TLibModule = record + Next: PLibModule; + Instance: LongWord; + CodeInstance: LongWord; + DataInstance: LongWord; + ResInstance: LongWord; + Reserved: Integer; +{$IFDEF LINUX} + InstanceVar: Pointer platform; + GOT: LongWord platform; + CodeSegStart: LongWord platform; + CodeSegEnd: LongWord platform; + InitTable: Pointer platform; +{$ENDIF} + end; + + TEnumModuleFunc = function (HInstance: Integer; Data: Pointer): Boolean; + {$EXTERNALSYM TEnumModuleFunc} + TEnumModuleFuncLW = function (HInstance: LongWord; Data: Pointer): Boolean; + {$EXTERNALSYM TEnumModuleFuncLW} + TModuleUnloadProc = procedure (HInstance: Integer); + {$EXTERNALSYM TModuleUnloadProc} + TModuleUnloadProcLW = procedure (HInstance: LongWord); + {$EXTERNALSYM TModuleUnloadProcLW} + + PModuleUnloadRec = ^TModuleUnloadRec; + TModuleUnloadRec = record + Next: PModuleUnloadRec; + Proc: TModuleUnloadProcLW; + end; + +var + LibModuleList: PLibModule = nil; + ModuleUnloadList: PModuleUnloadRec = nil; + +procedure RegisterModule(LibModule: PLibModule); +//procedure UnregisterModule(LibModule: PLibModule); +{X} procedure UnregisterModuleLight(LibModule: PLibModule); +{X} procedure UnregisterModuleSafely(LibModule: PLibModule); +var UnregisterModule : procedure(LibModule: PLibModule) = UnregisterModuleLight; +function FindHInstance(Address: Pointer): LongWord; +function FindClassHInstance(ClassType: TClass): LongWord; +function FindResourceHInstance(Instance: LongWord): LongWord; +function LoadResourceModule(ModuleName: PChar; CheckOwner: Boolean = True): LongWord; +procedure EnumModules(Func: TEnumModuleFunc; Data: Pointer); overload; +procedure EnumResourceModules(Func: TEnumModuleFunc; Data: Pointer); overload; +procedure EnumModules(Func: TEnumModuleFuncLW; Data: Pointer); overload; +procedure EnumResourceModules(Func: TEnumModuleFuncLW; Data: Pointer); overload; +procedure AddModuleUnloadProc(Proc: TModuleUnloadProc); overload; +procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProc); overload; +procedure AddModuleUnloadProc(Proc: TModuleUnloadProcLW); overload; +procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProcLW); overload; +{$IFDEF LINUX} +{ Given an HMODULE, this function will return its fully qualified name. There is + no direct equivalent in Linux so this function provides that capability. } +function GetModuleFileName(Module: HMODULE; Buffer: PChar; BufLen: Integer): Integer; +{$ENDIF} + +{ ResString support function/record } + +type + PResStringRec = ^TResStringRec; + TResStringRec = packed record + Module: ^Cardinal; + Identifier: Integer; + end; + +function LoadResString(ResStringRec: PResStringRec): string; + +function Int(const X: Extended): Extended; +function Frac(const X: Extended): Extended; +function Exp(const X: Extended): Extended; +function Cos(const X: Extended): Extended; +function Sin(const X: Extended): Extended; +function Ln(const X: Extended): Extended; +function ArcTan(const X: Extended): Extended; +function Sqrt(const X: Extended): Extended; + +{ Procedures and functions that need compiler magic } + +procedure _ROUND; +procedure _TRUNC; + +procedure _AbstractError; +procedure _Assert(const Message, Filename: AnsiString; LineNumber: Integer); +function _Append(var t: TTextRec): Integer; +function _Assign(var t: TTextRec; const S: String): Integer; +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); +function _EofFile(var f: TFileRec): Boolean; +function _EofText(var t: TTextRec): Boolean; +function _Eoln(var t: TTextRec): Boolean; +procedure _Erase(var f: TFileRec); +{$IFDEF TRIAL_EDITION} +procedure _Expired; +{$ENDIF} +function _FilePos(var f: TFileRec): Longint; +function _FileSize(var f: TFileRec): Longint; +procedure _FillChar(var Dest; count: Integer; Value: Char); +function _FreeMem(P: Pointer): Integer; +function _GetMem(Size: Integer): Pointer; +function _ReallocMem(var P: Pointer; NewSize: Integer): Pointer; +procedure _Halt(Code: Integer); +procedure _Halt0; +{$IFDEF TRIAL_EDITION} +{$IFDEF MSWINDOWS} +function _InitUnitPrep: Int64; +{$ENDIF} +{$IFDEF LINUX} +function _InitUnitPrep: Integer; +{$ENDIF} +{$ENDIF} +procedure Mark; deprecated; +procedure _PStrCmp; +procedure _AStrCmp; +function _ReadRec(var f: TFileRec; Buffer: Pointer): Integer; +function _ReadChar(var t: TTextRec): Char; +function _ReadLong(var t: TTextRec): Longint; +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); +procedure _ReadWString(var t: TTextRec; var s: WideString); +procedure _ReadWCString(var t: TTextRec; s: PWideChar; maxBytes: Longint); +function _ReadWChar(var t: TTextRec): WideChar; +function _ReadExt(var t: TTextRec): Extended; +procedure _ReadLn(var t: TTextRec); +procedure _Rename(var f: TFileRec; newName: PChar); +procedure Release; deprecated; +function _ResetText(var t: TTextRec): Integer; +function _ResetFile(var f: TFileRec; recSize: Longint): Integer; +function _RewritText(var t: TTextRec): Integer; +function _RewritFile(var f: TFileRec; recSize: Longint): Integer; +procedure _RunError(errorCode: Byte); +procedure _Run0Error; +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; +{$IFDEF LINUX} +procedure _UnhandledException; +{$ENDIF} +function _WriteRec(var f: TFileRec; buffer: Pointer): Pointer; +function _WriteChar(var t: TTextRec; c: Char; width: Integer): Pointer; +function _Write0Char(var t: TTextRec; c: Char): 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 _WriteString(var t: TTextRec; const s: ShortString; width: Longint): Pointer; +function _Write0String(var t: TTextRec; const s: ShortString): Pointer; +function _WriteCString(var t: TTextRec; s: PChar; width: Longint): Pointer; +function _Write0CString(var t: TTextRec; s: PChar): Pointer; +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 _WriteWCString(var t: TTextRec; s: PWideChar; width: Longint): Pointer; +function _Write0WCString(var t: TTextRec; s: PWideChar): Pointer; +function _WriteWChar(var t: TTextRec; c: WideChar; width: Integer): Pointer; +function _Write0WChar(var t: TTextRec; c: WideChar): 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 __IOTest; +function _Flush(var t: TTextRec): Integer; + +procedure _SetElem; +procedure _SetRange; +procedure _SetEq; +procedure _SetLe; +procedure _SetIntersect; +procedure _SetIntersect3; { BEG only } +procedure _SetUnion; +procedure _SetUnion3; { BEG only } +procedure _SetSub; +procedure _SetSub3; { BEG only } +procedure _SetExpand; + +procedure _Str2Ext; +procedure _Str0Ext; +procedure _Str1Ext; +procedure _ValExt; +procedure _Pow10; +procedure _Real2Ext; +procedure _Ext2Real; + +procedure _ObjSetup; +procedure _ObjCopy; +procedure _Fail; +procedure _BoundErr; +procedure _IntOver; + +{ Module initialization context. For internal use only. } + +type + PInitContext = ^TInitContext; + TInitContext = record + OuterContext: PInitContext; { saved InitContext } +{$IFNDEF PC_MAPPED_EXCEPTIONS} + ExcFrame: Pointer; { bottom exc handler } +{$ENDIF} + InitTable: PackageInfo; { unit init info } + InitCount: Integer; { how far we got } + Module: PLibModule; { ptr to module desc } + DLLSaveEBP: Pointer; { saved regs for DLLs } + DLLSaveEBX: Pointer; { saved regs for DLLs } + DLLSaveESI: Pointer; { saved regs for DLLs } + DLLSaveEDI: Pointer; { saved regs for DLLs } +{$IFDEF MSWINDOWS} + ExitProcessTLS: procedure; { Shutdown for TLS } +{$ENDIF} + DLLInitState: Byte; { 0 = package, 1 = DLL shutdown, 2 = DLL startup } + end platform; + +type + TDLLProc = procedure (Reason: Integer); + // TDLLProcEx provides the reserved param returned by WinNT + TDLLProcEx = procedure (Reason: Integer; Reserved: Integer); + +{$IFDEF LINUX} +procedure _StartExe(InitTable: PackageInfo; Module: PLibModule; Argc: Integer; Argv: Pointer); +procedure _StartLib(Context: PInitContext; Module: PLibModule; DLLProc: TDLLProcEx); +{$ENDIF} +{$IFDEF MSWINDOWS} +procedure _StartExe(InitTable: PackageInfo; Module: PLibModule); +procedure _StartLib; +{$ENDIF} +procedure _PackageLoad(const Table : PackageInfo; Module: PLibModule); +procedure _PackageUnload(const Table : PackageInfo; Module: PLibModule); +procedure _InitResStrings; +procedure _InitResStringImports; +procedure _InitImports; +{$IFDEF MSWINDOWS} +procedure _InitWideStrings; +{$ENDIF} + +function _ClassCreate(AClass: TClass; Alloc: Boolean): TObject; +procedure _ClassDestroy(Instance: TObject); +function _AfterConstruction(Instance: TObject): TObject; +function _BeforeDestruction(Instance: TObject; OuterMost: ShortInt): TObject; +function _IsClass(Child: TObject; Parent: TClass): Boolean; +function _AsClass(Child: TObject; Parent: TClass): TObject; +function _GetHelperIntf(Instance: TObject; Cls: TClass): IInterface; + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _RaiseAtExcept; +//procedure _DestroyException(Exc: PRaisedException); +procedure _DestroyException; +{$ENDIF} +procedure _RaiseExcept; +procedure _RaiseAgain; +procedure _DoneExcept; +{$IFNDEF PC_MAPPED_EXCEPTIONS} +procedure _TryFinallyExit; +{$ENDIF} +procedure _HandleAnyException; +procedure _HandleFinally; +procedure _HandleOnException; +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _HandleOnExceptionPIC; +{$ENDIF} +procedure _HandleAutoException; +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _ClassHandleException; +{$ENDIF} + +procedure _CallDynaInst; +procedure _CallDynaClass; +procedure _FindDynaInst; +procedure _FindDynaClass; + +procedure _LStrClr(var S); +procedure _LStrArrayClr(var StrArray; cnt: longint); +procedure _LStrAsg(var dest; const source); +procedure _LStrLAsg(var dest; const source); +procedure _LStrFromPCharLen(var Dest: AnsiString; Source: PAnsiChar; Length: 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 _LStrToPChar(const s: AnsiString): PChar; +procedure _Copy{ s : ShortString; index, count : Integer ) : ShortString}; +procedure _Delete{ var s : openstring; index, count : Integer }; +procedure _Insert{ source : ShortString; var s : openstring; index : Integer }; +procedure _Pos{ substr : ShortString; s : ShortString ) : Integer}; +procedure _SetLength(s: PShortString; newLength: Byte); +procedure _SetString(s: PShortString; buffer: PChar; len: Byte); + +procedure UniqueString(var str: AnsiString); overload; +procedure UniqueString(var str: WideString); overload; +procedure _UniqueStringA(var str: AnsiString); +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 _LStrSetLength{ var str: AnsiString; newLength: Integer}; +function _NewAnsiString(length: Longint): Pointer; { for debugger purposes only } +function _NewWideString(CharLength: Longint): Pointer; + +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); +function _WStrToPWChar(const S: WideString): PWideChar; +function _WStrLen(const S: WideString): Integer; +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); +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 _WStrSetLength(var S: WideString; NewLength: Integer); +function _WStrAddRef(var str: WideString): Pointer; +procedure _WCharToString(Dest: PShortString; const Source: WideChar; MaxLen: Integer); + +procedure _Initialize(p: Pointer; typeInfo: Pointer); +procedure _InitializeArray(p: Pointer; typeInfo: Pointer; elemCount: Cardinal); +procedure _InitializeRecord(p: Pointer; typeInfo: Pointer); +procedure _Finalize(p: Pointer; typeInfo: Pointer); +procedure _FinalizeArray(p: Pointer; typeInfo: Pointer; elemCount: Cardinal); +procedure _FinalizeRecord(P: Pointer; typeInfo: Pointer); +procedure _AddRef; +procedure _AddRefArray; +procedure _AddRefRecord; +procedure _CopyArray; +procedure _CopyRecord; +procedure _CopyObject; + +function _New(size: Longint; typeInfo: Pointer): Pointer; +procedure _Dispose(p: Pointer; typeInfo: Pointer); + +{ 64-bit Integer helper routines } +procedure __llmul; +procedure __lldiv; +procedure __lludiv; +procedure __llmod; +procedure __llmulo; +procedure __lldivo; +procedure __llmodo; +procedure __llumod; +procedure __llshl; +procedure __llushr; +procedure _WriteInt64; +procedure _Write0Int64; +procedure _WriteUInt64; +procedure _Write0UInt64; +procedure _ReadInt64; +function _StrInt64(val: Int64; width: Integer): ShortString; +function _Str0Int64(val: Int64): ShortString; +function _ValInt64(const s: AnsiString; var code: Integer): Int64; + +{ Dynamic array helper functions } + +procedure _DynArrayHigh; +procedure _DynArrayClear(var a: Pointer; typeInfo: Pointer); +procedure _DynArrayLength; +procedure _DynArraySetLength; +procedure _DynArrayCopy(a: Pointer; typeInfo: Pointer; var Result: Pointer); +procedure _DynArrayCopyRange(a: Pointer; typeInfo: Pointer; index, count : Integer; var Result: Pointer); +procedure _DynArrayAsg; +procedure _DynArrayAddRef; + +procedure DynArrayClear(var a: Pointer; typeInfo: Pointer); +procedure DynArraySetLength(var a: Pointer; typeInfo: Pointer; dimCnt: Longint; lengthVec: PLongint); +function DynArrayDim(typeInfo: PDynArrayTypeInfo): Integer; +{$NODEFINE DynArrayDim} + +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); + +{$IFDEF MSWINDOWS} +procedure _FSafeDivide; +procedure _FSafeDivideR; +{$ENDIF} + +function _CheckAutoResult(ResultCode: HResult): HResult; + +procedure FPower10; + +procedure TextStart; deprecated; + +// Conversion utility routines for C++ convenience. Not for Delphi code. +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; + +function Pos(const substr, str: AnsiString): Integer; overload; +function Pos(const substr, str: WideString): Integer; overload; + +function StringOfChar(ch: AnsiChar; Count: Integer): AnsiString; overload; +function StringOfChar(ch: WideChar; Count: Integer): WideString; overload; + +{ Internal runtime error codes } + +type + TRuntimeError = (reNone, reOutOfMemory, reInvalidPtr, reDivByZero, + reRangeError, reIntOverflow, reInvalidOp, reZeroDivide, reOverflow, + reUnderflow, reInvalidCast, reAccessViolation, rePrivInstruction, + reControlBreak, reStackOverflow, + { reVar* used in Variants.pas } + reVarTypeCast, reVarInvalidOp, + reVarDispatch, reVarArrayCreate, reVarNotArray, reVarArrayBounds, + reAssertionFailed, + reExternalException, { not used here; in SysUtils } + reIntfCastError, reSafeCallError); + +{$NODEFINE TRuntimeError} + +procedure Error(errorCode: TRuntimeError); +{$NODEFINE Error} + +{ GetLastError returns the last error reported by an OS API call. Calling + this function usually resets the OS error state. +} + +function GetLastError: Integer; {$IFDEF MSWINDOWS} stdcall; {$ENDIF} +{$EXTERNALSYM GetLastError} + +{ SetLastError writes to the thread local storage area read by GetLastError. } + +procedure SetLastError(ErrorCode: Integer); {$IFDEF MSWINDOWS} stdcall; {$ENDIF} + +{$IFDEF LINUX} +{ To improve performance, some RTL routines cache module handles and data + derived from modules. If an application dynamically loads and unloads + shared object libraries, packages, or resource packages, it is possible for + the handle of the newly loaded module to match the handle of a recently + unloaded module. The resource caches have no way to detect when this happens. + + To address this issue, the RTL maintains an internal counter that is + incremented every time a module is loaded or unloaded using RTL functions + (like LoadPackage). This provides a cache version level signature that + can detect when modules have been cycled but have the same handle. + + If you load or unload modules "by hand" using dlopen or dlclose, you must call + InvalidateModuleCache after each load or unload so that the RTL module handle + caches will refresh themselves properly the next time they are used. This is + especially important if you manually tinker with the LibModuleList list of + loaded modules, or manually add or remove resource modules in the nodes + of that list. + + ModuleCacheID returns the "current generation" or version number kept by + the RTL. You can use this to implement your own refresh-on-next-use + (passive) module handle caches as the RTL does. The value changes each + time InvalidateModuleCache is called. +} + +function ModuleCacheID: Cardinal; +procedure InvalidateModuleCache; +{$ENDIF} +{$IFDEF LINUX} +{ When a process that is being debugged is stopped while it has the mouse + pointer grabbed, there is no way for the debugger to release the grab on + behalf of the process. The process needs to do it itself. To accomplish this, + the debugger causes DbgUnlockX to execute whenever it detects the process + might have the mouse grabbed. This method will call through DbgUnlockXProc + which should be assigned by any library using X and locks the X pointer. This + method should be chained, by storing of the previous instance and calling it + when you are called, since there might be more than one display that needs + to be unlocked. This method should call XUngrabPointer on the display that + has the pointer grabbed. +} +var + DbgUnlockXProc: procedure; + +procedure DbgUnlockX; +{$ENDIF} + +{X+ moved here from SysInit.pas - by advise of Alexey Torgashin - to avoid + creating of separate import block from kernel32.dll : } +////////////////////////////////////////////////////////////////////////// + +function FreeLibrary(ModuleHandle: Longint): LongBool; stdcall; +function GetModuleFileName(Module: Integer; Filename: PChar; Size: Integer): Integer; stdcall; +function GetModuleHandle(ModuleName: PChar): Integer; stdcall; +function LocalAlloc(flags, size: Integer): Pointer; stdcall; +function LocalFree(addr: Pointer): Pointer; stdcall; +function TlsAlloc: Integer; stdcall; +function TlsFree(TlsIndex: Integer): Boolean; stdcall; +function TlsGetValue(TlsIndex: Integer): Pointer; stdcall; +function TlsSetValue(TlsIndex: Integer; TlsValue: Pointer): Boolean; stdcall; +function GetCommandLine: PChar; stdcall; +{X-}////////////////////////////////////////////////////////////////////// + +{X+} +{X}function GetProcessHeap: THandle; stdcall; +{X}function HeapAlloc(hHeap: THandle; dwFlags, dwBytes: Cardinal): Pointer; stdcall; +{X}function HeapReAlloc(hHeap: THandle; dwFlags: Cardinal; lpMem: Pointer; dwBytes: Cardinal): Pointer; stdcall; +{X}function HeapFree(hHeap: THandle; dwFlags: Cardinal; lpMem: Pointer): LongBool; stdcall; +{X}function DfltGetMem(size: Integer): Pointer; +{X}function DfltFreeMem(p: Pointer): Integer; +{X}function DfltReallocMem(p: Pointer; size: Integer): Pointer; +{X} procedure InitUnitsLight( Table : PUnitEntryTable; Idx, Count : Integer ); +{X} procedure FInitUnitsLight; +{X} // following two procedures are optional and exclusive. +{X} // call it to provide error message: first - for GUI app, +{X} // second - for console app. +{X} procedure UseErrorMessageBox; +{X} procedure UseErrorMessageWrite; + +{X} // call following procedure to initialize Input and Output +{X} // - for console app only: +{X} procedure UseInputOutput; + +{X} // if your app uses FPU, call one of following procedures: +{X} procedure FpuInit; +{X} procedure FpuInitConsiderNECWindows; +{X} // the second additionally takes into consideration NEC +{X} // Windows keyboard (Japaneeze keyboard ???). + +{X} procedure DummyProc; // empty procedure + +(* +{X} procedure VariantClr; +{X} // procedure to refer to _VarClr if SysVarnt.pas is in use +{X} var VarClrProc : procedure = DummyProc; + +{X} procedure VarCastError; +{X} procedure VarInvalidOp; + +{X} procedure VariantAddRef; +{X} // procedure to refer to _VarAddRef if SysVarnt.pas is in use +{X} var VarAddRefProc : procedure = DummyProc; +*) + +{X} procedure WStrAddRef; +{X} // procedure to refer to _WStrAddRef if SysWStr.pas is in use +{X} var WStrAddRefProc : procedure = DummyProc; + +{X} procedure WStrClr; +{X} // procedure to refer to _WStrClr if SysWStr.pas is in use +{X} var WStrClrProc : procedure = DummyProc; + +{X} procedure WStrArrayClr; +{X} // procedure to refer to _WStrArrayClr if SysWStr.pas is in use +{X} var WStrArrayClrProc : procedure = DummyProc; + +{X} // Standard Delphi units initialization/finalization uses +{X} // try-except and raise constructions, which leads to permanent +{X} // usage of all exception handling routines. In this XCL-aware +{X} // implementation, "light" version of initialization/finalization +{X} // is used by default. To use standard Delphi initialization and +{X} // finalization method, allowing to flow execution control even +{X} // in initalization sections, include reference to SysSfIni.pas +{X} // into uses clause *as first as possible*. +{X} procedure InitUnitsHard( Table : PUnitEntryTable; Idx, Count : Integer ); +{X} var InitUnitsProc : procedure( Table : PUnitEntryTable; Idx, Count : Integer ) +{X} = InitUnitsLight; +{X} procedure FInitUnitsHard; +{X} var FInitUnitsProc : procedure = FInitUnitsLight; +{X} procedure SetExceptionHandler; +{X} procedure UnsetExceptionHandler; +{X} var UnsetExceptionHandlerProc : procedure = DummyProc; + +{X} var UnloadResProc: procedure = DummyProc; +{X-} + +(* =================================================================== *) + +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; + +{X+} +const + advapi32 = 'advapi32.dll'; + kernel = 'kernel32.dll'; + user = 'user32.dll'; + oleaut = 'oleaut32.dll'; + +function GetProcessHeap; external kernel name 'GetProcessHeap'; +function HeapAlloc; stdcall; external kernel name 'HeapAlloc'; +function HeapReAlloc; stdcall; external kernel name 'HeapReAlloc'; +function HeapFree; stdcall; external kernel name 'HeapFree'; +{X-} + +{$IFDEF PIC} +function GetGOT: LongWord; export; +begin + asm + MOV Result,EBX + end; +end; +{$ENDIF} + +{$IFDEF PC_MAPPED_EXCEPTIONS} +const + UNWINDFI_TOPOFSTACK = $BE00EF00; + +{$IFDEF MSWINDOWS} +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'; +{$ENDIF} +{$IFDEF LINUX} +const + unwind = 'libborunwind.so.6'; +type + UNWINDPROC = Pointer; + +{$DEFINE STATIC_UNWIND} + +{$IFDEF STATIC_UNWIND} +function _BorUnwind_RegisterIPLookup(fn: UNWINDPROC; StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; cdecl; + external; + +procedure _BorUnwind_UnregisterIPLookup(StartAddr: LongInt); cdecl; external; + +function _BorUnwind_DelphiLookup(Addr: LongInt; Context: Pointer): UNWINDPROC; cdecl; external; + +function _BorUnwind_RaiseException(Exc: Pointer): LongBool; cdecl; external; + +//function _BorUnwind_AddressIsInPCMap(Addr: LongInt): LongBool; cdecl; external; +function _BorUnwind_ClosestDelphiHandler(Context: Pointer): LongWord; cdecl; external; +{$ELSE} + +function _BorUnwind_RegisterIPLookup(fn: UNWINDPROC; StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; cdecl; + external unwind name '_BorUnwind_RegisterIPLookup'; + +procedure _BorUnwind_UnregisterIPLookup(StartAddr: LongInt); cdecl; + external unwind name '_BorUnwind_UnregisterIPLookup'; + +function _BorUnwind_DelphiLookup(Addr: LongInt; Context: Pointer): UNWINDPROC; cdecl; + external unwind name '_BorUnwind_DelphiLookup'; + +function _BorUnwind_RaiseException(Exc: Pointer): LongBool; cdecl; + external unwind name '_BorUnwind_RaiseException'; + +function _BorUnwind_ClosestDelphiHandler(Context: Pointer): LongWord; cdecl; + external unwind name '_BorUnwind_ClosestDelphiHandler'; +{$ENDIF} +{$ENDIF} +{$ENDIF} + +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} + + PRaisedException = ^TRaisedException; + TRaisedException = packed record + RefCount: Integer; + ExceptObject: TObject; + ExceptionAddr: Pointer; + HandlerEBP: LongWord; + Flags: LongWord; + 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 LINUX} +const + libc = 'libc.so.6'; + libdl = 'libdl.so.2'; + libpthread = 'libpthread.so.0'; + + O_RDONLY = $0000; + O_WRONLY = $0001; + O_RDWR = $0002; + O_CREAT = $0040; + O_EXCL = $0080; + O_NOCTTY = $0100; + O_TRUNC = $0200; + O_APPEND = $0400; + + // protection flags + S_IREAD = $0100; // Read by owner. + S_IWRITE = $0080; // Write by owner. + S_IEXEC = $0040; // Execute by owner. + S_IRUSR = S_IREAD; + S_IWUSR = S_IWRITE; + S_IXUSR = S_IEXEC; + S_IRWXU = S_IRUSR or S_IWUSR or S_IXUSR; + + S_IRGRP = S_IRUSR shr 3; // Read by group. + S_IWGRP = S_IWUSR shr 3; // Write by group. + S_IXGRP = S_IXUSR shr 3; // Execute by group. + S_IRWXG = S_IRWXU shr 3; // Read, write, and execute by group. + + S_IROTH = S_IRGRP shr 3; // Read by others. + S_IWOTH = S_IWGRP shr 3; // Write by others. + S_IXOTH = S_IXGRP shr 3; // Execute by others. + S_IRWXO = S_IRWXG shr 3; // Read, write, and execute by others. + + STDIN_FILENO = 0; + STDOUT_FILENO = 1; + STDERR_FILENO = 2; + + SEEK_SET = 0; + SEEK_CUR = 1; + SEEK_END = 2; + + LC_CTYPE = 0; + _NL_CTYPE_CODESET_NAME = LC_CTYPE shl 16 + 14; + + MAX_PATH = 4095; + + +function __open(PathName: PChar; Flags: Integer; Mode: Integer): Integer; cdecl; + external libc name 'open'; + +function __close(Handle: Integer): Integer; cdecl; + external libc name 'close'; + +function __read(Handle: Integer; Buffer: Pointer; Count: Cardinal): Cardinal; cdecl; + external libc name 'read'; + +function __write(Handle: Integer; Buffer: Pointer; Count: Cardinal): Cardinal; cdecl; + external libc name 'write'; + +function __mkdir(PathName: PChar; Mode: Integer): Integer; cdecl; + external libc name 'mkdir'; + +function __getcwd(Buffer: PChar; BufSize: Integer): PChar; cdecl; + external libc name 'getcwd'; + +function __getenv(Name: PChar): PChar; cdecl; + external libc name 'getenv'; + +function __chdir(PathName: PChar): Integer; cdecl; + external libc name 'chdir'; + +function __rmdir(PathName: PChar): Integer; cdecl; + external libc name 'rmdir'; + +function __remove(PathName: PChar): Integer; cdecl; + external libc name 'remove'; + +function __rename(OldPath, NewPath: PChar): Integer; cdecl; + external libc name 'rename'; + +{$IFDEF EFENCE} +function __malloc(Size: Integer): Pointer; cdecl; + external 'libefence.so' name 'malloc'; + +procedure __free(P: Pointer); cdecl; + external 'libefence.so' name 'free'; + +function __realloc(P: Pointer; Size: Integer): Pointer; cdecl; + external 'libefence.so' name 'realloc'; +{$ELSE} +function __malloc(Size: Integer): Pointer; cdecl; + external libc name 'malloc'; + +procedure __free(P: Pointer); cdecl; + external libc name 'free'; + +function __realloc(P: Pointer; Size: Integer): Pointer; cdecl; + external libc name 'realloc'; +{$ENDIF} + +procedure ExitProcess(status: Integer); cdecl; + external libc name 'exit'; + +function _time(P: Pointer): Integer; cdecl; + external libc name 'time'; + +function _lseek(Handle, Offset, Direction: Integer): Integer; cdecl; + external libc name 'lseek'; + +function _ftruncate(Handle: Integer; Filesize: Integer): Integer; cdecl; + external libc name 'ftruncate'; + +function strcasecmp(s1, s2: PChar): Integer; cdecl; + external libc name 'strcasecmp'; + +function __errno_location: PInteger; cdecl; + external libc name '__errno_location'; + +function nl_langinfo(item: integer): pchar; cdecl; + external libc name 'nl_langinfo'; + +function iconv_open(ToCode: PChar; FromCode: PChar): Integer; cdecl; + external libc name 'iconv_open'; + +function iconv(cd: Integer; var InBuf; var InBytesLeft: Integer; var OutBuf; var OutBytesLeft: Integer): Integer; cdecl; + external libc name 'iconv'; + +function iconv_close(cd: Integer): Integer; cdecl; + external libc name 'iconv_close'; + +function mblen(const S: PChar; N: LongWord): Integer; cdecl; + external libc name 'mblen'; + +function mmap(start: Pointer; length: Cardinal; prot, flags, fd, offset: Integer): Pointer; cdecl; + external libc name 'mmap'; + +function munmap(start: Pointer; length: Cardinal): Integer; cdecl; + external libc name 'munmap'; + +const + SIGABRT = 6; + +function __raise(SigNum: Integer): Integer; cdecl; + external libc name 'raise'; + +type + TStatStruct = record + st_dev: Int64; // device + __pad1: Word; + st_ino: Cardinal; // inode + st_mode: Cardinal; // protection + st_nlink: Cardinal; // number of hard links + st_uid: Cardinal; // user ID of owner + st_gid: Cardinal; // group ID of owner + st_rdev: Int64; // device type (if inode device) + __pad2: Word; + st_size: Cardinal; // total size, in bytes + st_blksize: Cardinal; // blocksize for filesystem I/O + st_blocks: Cardinal; // number of blocks allocated + st_atime: Integer; // time of last access + __unused1: Cardinal; + st_mtime: Integer; // time of last modification + __unused2: Cardinal; + st_ctime: Integer; // time of last change + __unused3: Cardinal; + __unused4: Cardinal; + __unused5: Cardinal; + end; + +const + STAT_VER_LINUX = 3; + +function _fxstat(Version: Integer; Handle: Integer; var Stat: TStatStruct): Integer; cdecl; + external libc name '__fxstat'; + +function __xstat(Ver: Integer; FileName: PChar; var StatBuffer: TStatStruct): Integer; cdecl; + external libc name '__xstat'; + +function _strlen(P: PChar): Integer; cdecl; + external libc name 'strlen'; + +function _readlink(PathName: PChar; Buf: PChar; Len: Integer): Integer; cdecl; + external libc name 'readlink'; + +type + TDLInfo = record + FileName: PChar; + BaseAddress: Pointer; + NearestSymbolName: PChar; + SymbolAddress: Pointer; + end; + +const + RTLD_LAZY = 1; + RTLD_NOW = 2; + +function dladdr(Address: Pointer; var Info: TDLInfo): Integer; cdecl; + external libdl name 'dladdr'; +function dlopen(Filename: PChar; Flag: Integer): LongWord; cdecl; + external libdl name 'dlopen'; +function dlclose(Handle: LongWord): Integer; cdecl; + external libdl name 'dlclose'; +function FreeLibrary(Handle: LongWord): Integer; cdecl; + external libdl name 'dlclose'; +function dlsym(Handle: LongWord; Symbol: PChar): Pointer; cdecl; + external libdl name 'dlsym'; +function dlerror: PChar; cdecl; + external libdl name 'dlerror'; + +type + TPthread_fastlock = record + __status: LongInt; + __spinlock: Integer; + end; + + TRTLCriticalSection = record + __m_reserved, + __m_count: Integer; + __m_owner: Pointer; + __m_kind: Integer; // __m_kind := 0 fastlock, __m_kind := 1 recursive lock + __m_lock: TPthread_fastlock; + end; + +function _pthread_mutex_lock(var Mutex: TRTLCriticalSection): Integer; cdecl; + external libpthread name 'pthread_mutex_lock'; +function _pthread_mutex_unlock(var Mutex: TRTLCriticalSection): Integer; cdecl; + external libpthread name 'pthread_mutex_unlock'; +function _pthread_create(var ThreadID: Cardinal; Attr: PThreadAttr; + TFunc: TThreadFunc; Arg: Pointer): Integer; cdecl; + external libpthread name 'pthread_create'; +function _pthread_exit(var RetVal: Integer): Integer; cdecl; + external libpthread name 'pthread_exit'; +function GetCurrentThreadID: LongWord; cdecl; + external libpthread name 'pthread_self'; +function _pthread_detach(ThreadID: Cardinal): Integer; cdecl; + external libpthread name 'pthread_detach' + +function GetLastError: Integer; +begin + Result := __errno_location^; +end; + +procedure SetLastError(ErrorCode: Integer); +begin + __errno_location^ := ErrorCode; +end; + +function InterlockedIncrement(var I: Integer): Integer; +asm + MOV EDX,1 + XCHG EAX,EDX + LOCK XADD [EDX],EAX + INC EAX +end; + +function InterlockedDecrement(var I: Integer): Integer; +asm + MOV EDX,-1 + XCHG EAX,EDX + LOCK XADD [EDX],EAX + DEC EAX +end; + +var + ModuleCacheVersion: Cardinal = 0; + +function ModuleCacheID: Cardinal; +begin + Result := ModuleCacheVersion; +end; + +procedure InvalidateModuleCache; +begin + InterlockedIncrement(Integer(ModuleCacheVersion)); +end; + +{$ENDIF} + +{$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 + 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; + +{X+ moved here from SysInit.pas - by advise of Alexey Torgashin - to avoid + creating of separate import block from kernel32.dll : } +////////////////////////////////////////////////////////////////////////// + +function FreeLibrary(ModuleHandle: Longint): LongBool; stdcall; + external kernel name 'FreeLibrary'; + +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 LocalAlloc(flags, size: Integer): Pointer; stdcall; + external kernel name 'LocalAlloc'; + +function LocalFree(addr: Pointer): Pointer; stdcall; + external kernel name 'LocalFree'; + +function TlsAlloc: Integer; stdcall; + external kernel name 'TlsAlloc'; + +function TlsFree(TlsIndex: Integer): Boolean; stdcall; + external kernel name 'TlsFree'; + +function TlsGetValue(TlsIndex: Integer): Pointer; stdcall; + external kernel name 'TlsGetValue'; + +function TlsSetValue(TlsIndex: Integer; TlsValue: Pointer): Boolean; stdcall; + external kernel name 'TlsSetValue'; + +function GetCommandLine: PChar; stdcall; + external kernel name 'GetCommandLineA'; +{X-}////////////////////////////////////////////////////////////////////// + +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 GetCmdShow: Integer; +var + SI: TStartupInfo; +begin + Result := 10; { SW_SHOWDEFAULT } + GetStartupInfo(SI); + if SI.dwFlags and 1 <> 0 then { STARTF_USESHOWWINDOW } + Result := SI.wShowWindow; +end; + + +{$ENDIF} // MSWindows + +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} +//////////////////// This code is from HeapMM.pas, (C) by Vladimir Kladov, 2001 +const + HEAP_NO_SERIALIZE = $00001; + HEAP_GROWABLE = $00002; + HEAP_GENERATE_EXCEPTIONS = $00004; + HEAP_ZERO_MEMORY = $00008; + HEAP_REALLOC_IN_PLACE_ONLY = $00010; + HEAP_TAIL_CHECKING_ENABLED = $00020; + HEAP_FREE_CHECKING_ENABLED = $00040; + HEAP_DISABLE_COALESCE_ON_FREE = $00080; + HEAP_CREATE_ALIGN_16 = $10000; + HEAP_CREATE_ENABLE_TRACING = $20000; + HEAP_MAXIMUM_TAG = $00FFF; + HEAP_PSEUDO_TAG_FLAG = $08000; + HEAP_TAG_SHIFT = 16 ; + +{$DEFINE USE_PROCESS_HEAP} + +var + HeapHandle: THandle; + {* Global handle to the heap. Do not change it! } + + HeapFlags: DWORD = 0; + {* Possible flags are: + HEAP_GENERATE_EXCEPTIONS - system will raise an exception to indicate a + function failure, such as an out-of-memory + condition, instead of returning NULL. + HEAP_NO_SERIALIZE - mutual exclusion will not be used while the HeapAlloc + function is accessing the heap. Be careful! + Not recommended for multi-thread applications. + But faster. + HEAP_ZERO_MEMORY - obviously. (Slower!) + } + + { Note from MSDN: + The granularity of heap allocations in Win32 is 16 bytes. So if you + request a global memory allocation of 1 byte, the heap returns a pointer + to a chunk of memory, guaranteeing that the 1 byte is available. Chances + are, 16 bytes will actually be available because the heap cannot allocate + less than 16 bytes at a time. + } + +function DfltGetMem(size: Integer): Pointer; +// Allocate memory block. +begin + Result := HeapAlloc( HeapHandle, HeapFlags, size ); +end; + +function DfltFreeMem(p: Pointer): Integer; +// Deallocate memory block. +begin + Result := Integer( not HeapFree( HeapHandle, HeapFlags and HEAP_NO_SERIALIZE, + p ) ); +end; + +function DfltReallocMem(p: Pointer; size: Integer): Pointer; +// Resize memory block. +begin + Result := HeapRealloc( HeapHandle, HeapFlags and (HEAP_NO_SERIALIZE and + HEAP_GENERATE_EXCEPTIONS and HEAP_ZERO_MEMORY), + // (Prevent using flag HEAP_REALLOC_IN_PLACE_ONLY here - to allow + // system to move the block if necessary). + p, size ); +end; + +//////////////////////////////////////////// end of HeapMM + +{$IFDEF LINUX} +function SysGetMem(Size: Integer): Pointer; +begin + Result := __malloc(size); +end; + +function SysFreeMem(P: Pointer): Integer; +begin + __free(P); + Result := 0; +end; + +function SysReallocMem(P: Pointer; Size: Integer): Pointer; +begin + Result := __realloc(P, Size); +end; + +{$ENDIF} + +var + MemoryManager: TMemoryManager = ( + GetMem: DfltGetMem; + FreeMem: DfltFreeMem; + ReallocMem: DfltReallocMem); + +const + DelphiMemoryManager: TMemoryManager = ( + GetMem: SysGetMem; + FreeMem: SysFreeMem; + ReallocMem: SysReallocMem); + +procedure UseDelphiMemoryManager; +begin + IsMemoryManagerSet := IsDelphiMemoryManagerSet; + SetMemoryManager( DelphiMemoryManager ); +end; +{X+} + +{$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 debug_init; external; +procedure debug_print; external; +procedure debug_class_enabled; external; +procedure debug_continue; external; +{$ENDIF} +{$ENDIF} +{X}{$IFDEF MSWINDOWS} +{X}function _GetMem(Size: Integer): Pointer; +{X}asm +{X} TEST EAX,EAX +{X} JE @@1 +{X} CALL MemoryManager.GetMem +{X} OR EAX,EAX +{X} JE @@2 +{X}@@1: RET +{X}@@2: MOV AL,reOutOfMemory +{X} JMP Error +{X}end; +{X}{$ELSE} + +function _GetMem(Size: Integer): Pointer; +{$IF Defined(DEBUG) and Defined(LINUX)} +var + Signature: PLongInt; +{$IFEND} +begin + if Size > 0 then + begin +{$IF Defined(DEBUG) and Defined(LINUX)} + Signature := PLongInt(MemoryManager.GetMem(Size + 4)); + if Signature = nil then + Error(reOutOfMemory); + Signature^ := 0; + Result := Pointer(LongInt(Signature) + 4); +{$ELSE} + Result := MemoryManager.GetMem(Size); + if Result = nil then + Error(reOutOfMemory); +{$IFEND} + end + else + Result := nil; +end; +{X}{$ENDIF MSWINDOWS} + +const + FreeMemorySignature = Longint($FBEEFBEE); + +{X}{$IFDEF MSWINDOWS} +{X}function _FreeMem(P: Pointer): Integer; +{X}asm +{X} TEST EAX,EAX +{X} JE @@1 +{X} CALL MemoryManager.FreeMem +{X} OR EAX,EAX +{X} JNE @@2 +{X}@@1: RET +{X}@@2: MOV AL,reInvalidPtr +{X} JMP Error +{X}end; +{X}{$ELSE} +function _FreeMem(P: Pointer): Integer; +{$IF Defined(DEBUG) and Defined(LINUX)} +var + Signature: PLongInt; +{$IFEND} +begin + if P <> nil then + begin +{$IF Defined(DEBUG) and Defined(LINUX)} + Signature := PLongInt(LongInt(P) - 4); + if Signature^ <> 0 then + Error(reInvalidPtr); + Signature^ := FreeMemorySignature; + Result := MemoryManager.Freemem(Pointer(Signature)); +{$ELSE} + Result := MemoryManager.FreeMem(P); +{$IFEND} + if Result <> 0 then + Error(reInvalidPtr); + end + else + Result := 0; +end; +{X}{$ENDIF MSWINDOWS} + +{$IFDEF LINUX} +function _ReallocMem(var P: Pointer; NewSize: Integer): Pointer; +{$IFDEF DEBUG} +var + Temp: Pointer; +{$ENDIF} +begin + if P <> nil then + begin +{$IFDEF DEBUG} + Temp := Pointer(LongInt(P) - 4); + if NewSize > 0 then + begin + Temp := MemoryManager.ReallocMem(Temp, NewSize + 4); + Result := Pointer(LongInt(Temp) + 4); + end + else + begin + MemoryManager.FreeMem(Temp); + Result := nil; + end; +{$ELSE} + if NewSize > 0 then + begin + Result := MemoryManager.ReallocMem(P, NewSize); + end + else + begin + MemoryManager.FreeMem(P); + Result := nil; + end; +{$ENDIF} + P := Result; + end else + begin + Result := _GetMem(NewSize); + P := Result; + end; +end; +{$ELSEIF Defined(MSWINDOWS)} +function _ReallocMem(var P: Pointer; NewSize: Integer): Pointer; +asm + MOV ECX,[EAX] + TEST ECX,ECX + JE @@alloc + TEST EDX,EDX + JE @@free +@@resize: + PUSH EAX + MOV EAX,ECX + CALL MemoryManager.ReallocMem + POP ECX + OR EAX,EAX + JE @@allocError + MOV [ECX],EAX + RET +@@freeError: + MOV AL,reInvalidPtr + JMP Error +@@free: + MOV [EAX],EDX + MOV EAX,ECX + CALL MemoryManager.FreeMem + OR EAX,EAX + JNE @@freeError + RET +@@allocError: + MOV AL,reOutOfMemory + JMP Error +@@alloc: + TEST EDX,EDX + JE @@exit + PUSH EAX + MOV EAX,EDX + CALL MemoryManager.GetMem + POP ECX + OR EAX,EAX + JE @@allocError + MOV [ECX],EAX +@@exit: +end; +{$IFEND} + +procedure GetMemoryManager(var MemMgr: TMemoryManager); +begin + MemMgr := MemoryManager; +end; + +procedure SetMemoryManager(const MemMgr: TMemoryManager); +begin + MemoryManager := MemMgr; +end; + +//function IsMemoryManagerSet: Boolean; +function IsDelphiMemoryManagerSet: Boolean; +begin + with MemoryManager do + Result := (@GetMem <> @SysGetMem) or (@FreeMem <> @SysFreeMem) or + (@ReallocMem <> @SysReallocMem); +end; + +{X+ always returns False. Initial handler for IsMemoryManagerSet } +function MemoryManagerNotUsed : Boolean; +begin + Result := False; +end; +{X-} + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure GetUnwinder(var Dest: TUnwinder); +begin + Dest := Unwinder; +end; + +procedure SetUnwinder(const NewUnwinder: TUnwinder); +begin + Unwinder := NewUnwinder; +end; + +function IsUnwinderSet: Boolean; +begin + with Unwinder do + Result := (@RaiseException <> @_BorUnwind_RaiseException) or + (@RegisterIPLookup <> @_BorUnwind_RegisterIPLookup) or + (@UnregisterIPLookup <> @_BorUnwind_UnregisterIPLookup) or + (@DelphiLookup <> @_BorUnwind_DelphiLookup); +end; + +procedure InitUnwinder; +var + Addr: Pointer; +begin + { + We look to see if we can find a dynamic version of the unwinder. This + will be the case if the application used ShareExcept.pas. If it is + present, then we fire it up. Otherwise, we use our static copy. + } + Addr := dlsym(0, '_BorUnwind_RegisterIPLookup'); + if Addr <> nil then + begin + Unwinder.RegisterIPLookup := Addr; + Addr := dlsym(0, '_BorUnwind_UnregisterIPLookup'); + Unwinder.UnregisterIPLookup := Addr; + Addr := dlsym(0, '_BorUnwind_RaiseException'); + Unwinder.RaiseException := Addr; + Addr := dlsym(0, '_BorUnwind_DelphiLookup'); + Unwinder.DelphiLookup := Addr; + Addr := dlsym(0, '_BorUnwind_ClosestHandler'); + Unwinder.ClosestHandler := Addr; + end + else + begin + dlerror; // clear error state; dlsym doesn't + Unwinder.RegisterIPLookup := _BorUnwind_RegisterIPLookup; + Unwinder.DelphiLookup := _BorUnwind_DelphiLookup; + Unwinder.UnregisterIPLookup := _BorUnwind_UnregisterIPLookup; + Unwinder.RaiseException := _BorUnwind_RaiseException; + Unwinder.ClosestHandler := _BorUnwind_ClosestDelphiHandler; + end; +end; + +function SysClosestDelphiHandler(Context: Pointer): LongWord; +begin + if not Assigned(Unwinder.ClosestHandler) then + InitUnwinder; + Result := Unwinder.ClosestHandler(Context); +end; + +function SysRegisterIPLookup(StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; +begin +// xxx + if not Assigned(Unwinder.RegisterIPLookup) then + begin + InitUnwinder; +// Unwinder.RegisterIPLookup := UnwindRegisterIPLookup; +// Unwinder.DelphiLookup := UnwindDelphiLookup; + end; + Result := Unwinder.RegisterIPLookup(@Unwinder.DelphiLookup, StartAddr, EndAddr, Context, GOT); +end; + +procedure SysUnregisterIPLookup(StartAddr: LongInt); +begin +// if not Assigned(Unwinder.UnregisterIPLookup) then +// Unwinder.UnregisterIPLookup := UnwindUnregisterIPLookup; + Unwinder.UnregisterIPLookup(StartAddr); +end; + +function SysRaiseException(Exc: Pointer): LongBool; export; +begin +// if not Assigned(Unwinder.RaiseException) then +// Unwinder.RaiseException := UnwindRaiseException; + Result := Unwinder.RaiseException(Exc); +end; + +const + MAX_NESTED_EXCEPTIONS = 16; +{$ENDIF} + +threadvar +{$IFDEF PC_MAPPED_EXCEPTIONS} + ExceptionObjects: array[0..MAX_NESTED_EXCEPTIONS-1] of TRaisedException; + ExceptionObjectCount: Integer; + OSExceptionsBlocked: Integer; + +{$ELSE} + RaiseListPtr: pointer; +{$ENDIF} + InOutRes: Integer; + +{$IFDEF PUREPASCAL} +var + notimpl: array [0..15] of Char = 'not implemented'#10; + +procedure NotImplemented; +begin + __write (2, @notimpl, 16); + Halt; +end; +{$ENDIF} + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure BlockOSExceptions; +asm + PUSH EAX + PUSH EDX + CALL SysInit.@GetTLS + MOV [EAX].OSExceptionsBlocked, 1 + POP EDX + POP EAX +end; + +procedure UnblockOSExceptions; +asm + PUSH EAX + CALL SysInit.@GetTLS + MOV [EAX].OSExceptionsBlocked, 0 + POP EAX +end; + +// Access to a TLS variable. Note the comment in BeginThread before +// you change the implementation of this function. +function AreOSExceptionsBlocked: Boolean; +asm + CALL SysInit.@GetTLS + MOV EAX, [EAX].OSExceptionsBlocked +end; + +const + TRAISEDEXCEPTION_SIZE = SizeOf(TRaisedException); + +function CurrentException: PRaisedException; +asm + CALL SysInit.@GetTLS + LEA EDX, [EAX].ExceptionObjects + MOV EAX, [EAX].ExceptionObjectCount + OR EAX, EAX + JE @@Done + DEC EAX + IMUL EAX, TRAISEDEXCEPTION_SIZE + ADD EAX, EDX +@@Done: +end; + +function AllocateException(Exception: Pointer; ExceptionAddr: Pointer): PRaisedException; +asm + PUSH EAX + PUSH EDX + CALL SysInit.@GetTLS + CMP [EAX].ExceptionObjectCount, MAX_NESTED_EXCEPTIONS-1 + JE @@TooManyNestedExceptions + INC [EAX].ExceptionObjectCount + CALL CurrentException + POP EDX + POP ECX + MOV [EAX].TRaisedException.ExceptObject, ECX + MOV [EAX].TRaisedException.ExceptionAddr, EDX + MOV [EAX].TRaisedException.RefCount, 0 + MOV [EAX].TRaisedException.HandlerEBP, $FFFFFFFF + MOV [EAX].TRaisedException.Flags, 0 + RET +@@TooManyNestedExceptions: + MOV EAX, 231 + JMP _RunError +end; + +{ + 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; +asm + CALL CurrentException + OR EAX, EAX + JE @@Error + { EAX -> the TRaisedException } + XOR ECX, ECX + { If the exception object has been referenced, we don't return it. } + CMP [EAX].TRaisedException.RefCount, 0 + JA @@GotObject + MOV ECX, [EAX].TRaisedException.ExceptObject +@@GotObject: + PUSH ECX + CALL SysInit.@GetTLS + POP ECX + DEC [EAX].ExceptionObjectCount + MOV EAX, ECX + RET +@@Error: + JMP _Run0Error +end; + +function AcquireExceptionObject: Pointer; +asm + CALL CurrentException + OR EAX, EAX + JE @@Error + INC [EAX].TRaisedException.RefCount + MOV EAX, [EAX].TRaisedException.ExceptObject + RET +@@Error: + { This happens if there is no exception pending } + JMP _Run0Error +end; + +procedure ReleaseExceptionObject; +asm + CALL CurrentException + OR EAX, EAX + JE @@Error + CMP [EAX].TRaisedException.RefCount, 0 + JE @@Error + DEC [EAX].TRaisedException.RefCount + RET +@@Error: + +{ + This happens if there is no exception pending, or + if the reference count on a pending exception is + zero. +} + JMP _Run0Error +end; + +function ExceptObject: TObject; +var + Exc: PRaisedException; +begin + Exc := CurrentException; + if Exc <> nil then + Result := TObject(Exc^.ExceptObject) + else + Result := nil; +end; + +{ Return current exception address } + +function ExceptAddr: Pointer; +var + Exc: PRaisedException; +begin + Exc := CurrentException; + if Exc <> nil then + Result := Exc^.ExceptionAddr + else + Result := nil; +end; +{$ELSE} {not PC_MAPPED_EXCEPTIONS} + +function ExceptObject: TObject; +begin + if RaiseListPtr <> nil then + Result := PRaiseFrame(RaiseListPtr)^.ExceptObject + else + Result := nil; +end; + +{ Return current exception address } + +function ExceptAddr: Pointer; +begin + if RaiseListPtr <> nil then + Result := PRaiseFrame(RaiseListPtr)^.ExceptAddr + else + Result := nil; +end; + + +function AcquireExceptionObject: Pointer; +begin + if RaiseListPtr <> nil then + begin + Result := PRaiseFrame(RaiseListPtr)^.ExceptObject; + PRaiseFrame(RaiseListPtr)^.ExceptObject := nil; + end + else + Result := nil; +end; + +procedure ReleaseExceptionObject; +begin +end; + +function RaiseList: Pointer; +begin + Result := RaiseListPtr; +end; + +function SetRaiseList(NewPtr: Pointer): Pointer; +asm + PUSH EAX + CALL SysInit.@GetTLS + MOV EDX, [EAX].RaiseListPtr + POP [EAX].RaiseListPtr + MOV EAX, EDX +end; +{$ENDIF} + +{ ----------------------------------------------------- } +{ local functions & procedures of the system unit } +{ ----------------------------------------------------- } + +procedure RunErrorAt(ErrCode: Integer; ErrorAtAddr: Pointer); +begin + ErrorAddr := ErrorAtAddr; + _Halt(ErrCode); +end; + +procedure ErrorAt(ErrorCode: Byte; ErrorAddr: Pointer); + +const + reMap: array [TRunTimeError] of Byte = ( + 0, { reNone } + 203, { reOutOfMemory } + 204, { reInvalidPtr } + 200, { reDivByZero } + 201, { reRangeError } +{ 210 Abstract error } + 215, { reIntOverflow } + 207, { reInvalidOp } + 200, { reZeroDivide } + 205, { reOverflow } + 206, { reUnderflow } + 219, { reInvalidCast } + 216, { reAccessViolation } + 202, { reStackOverflow } + 217, { reControlBreak } + 218, { rePrivInstruction } + 220, { reVarTypeCast } + 221, { reVarInvalidOp } + 222, { reVarDispatch } + 223, { reVarArrayCreate } + 224, { reVarNotArray } + 225, { reVarArrayBounds } +{ 226 Thread init failure } + 227, { reAssertionFailed } + 0, { reExternalException not used here; in SysUtils } + 228, { reIntfCastError } + 229 { reSafeCallError } +{ 230 Reserved by the compiler for unhandled exceptions } +{ 231 Too many nested exceptions } +{ 232 Fatal signal raised on a non-Delphi thread }); + +begin + errorCode := errorCode and 127; + if Assigned(ErrorProc) then + ErrorProc(errorCode, ErrorAddr); + if errorCode = 0 then + errorCode := InOutRes + else if errorCode <= Byte(High(TRuntimeError)) then + errorCode := reMap[TRunTimeError(errorCode)]; + RunErrorAt(errorCode, ErrorAddr); +end; + +procedure Error(errorCode: TRuntimeError); +asm + AND EAX,127 + MOV EDX,[ESP] + JMP ErrorAt +end; + +procedure __IOTest; +asm + PUSH EAX + PUSH EDX + PUSH ECX + CALL SysInit.@GetTLS + CMP [EAX].InOutRes,0 + POP ECX + POP EDX + POP EAX + JNE @error + RET +@error: + XOR EAX,EAX + JMP Error +end; + +procedure SetInOutRes(NewValue: Integer); +begin + InOutRes := NewValue; +end; + +procedure InOutError; +begin + SetInOutRes(GetLastError); +end; + +procedure ChDir(const S: string); +begin + ChDir(PChar(S)); +end; + +procedure ChDir(P: PChar); +begin +{$IFDEF MSWINDOWS} + if not SetCurrentDirectory(P) then +{$ENDIF} +{$IFDEF LINUX} + if __chdir(P) <> 0 then +{$ENDIF} + InOutError; +end; + +procedure _Copy{ s : ShortString; index, count : Integer ) : ShortString}; +asm +{ ->EAX Source string } +{ EDX index } +{ ECX count } +{ [ESP+4] Pointer to result string } + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,[ESP+8+4] + + XOR EAX,EAX + OR AL,[ESI] + JZ @@srcEmpty + +{ limit index to satisfy 1 <= index <= Length(src) } + + TEST EDX,EDX + JLE @@smallInx + CMP EDX,EAX + JG @@bigInx +@@cont1: + +{ limit count to satisfy 0 <= count <= Length(src) - index + 1 } + + SUB EAX,EDX { calculate Length(src) - index + 1 } + INC EAX + TEST ECX,ECX + JL @@smallCount + CMP ECX,EAX + JG @@bigCount +@@cont2: + + ADD ESI,EDX + + MOV [EDI],CL + INC EDI + REP MOVSB + JMP @@exit + +@@smallInx: + MOV EDX,1 + JMP @@cont1 +@@bigInx: +{ MOV EDX,EAX + JMP @@cont1 } +@@smallCount: + XOR ECX,ECX + JMP @@cont2 +@@bigCount: + MOV ECX,EAX + JMP @@cont2 +@@srcEmpty: + MOV [EDI],AL +@@exit: + POP EDI + POP ESI + RET 4 +end; + +procedure _Delete{ var s : openstring; index, count : Integer }; +asm +{ ->EAX Pointer to s } +{ EDX index } +{ ECX count } + + PUSH ESI + PUSH EDI + + MOV EDI,EAX + + XOR EAX,EAX + MOV AL,[EDI] + +{ if index not in [1 .. Length(s)] do nothing } + + TEST EDX,EDX + JLE @@exit + CMP EDX,EAX + JG @@exit + +{ limit count to [0 .. Length(s) - index + 1] } + + TEST ECX,ECX + JLE @@exit + SUB EAX,EDX { calculate Length(s) - index + 1 } + INC EAX + CMP ECX,EAX + JLE @@1 + MOV ECX,EAX +@@1: + SUB [EDI],CL { reduce Length(s) by count } + ADD EDI,EDX { point EDI to first char to be deleted } + LEA ESI,[EDI+ECX] { point ESI to first char to be preserved } + SUB EAX,ECX { #chars = Length(s) - index + 1 - count } + MOV ECX,EAX + + REP MOVSB + +@@exit: + POP EDI + POP ESI +end; + +procedure _LGetDir(D: Byte; var S: string); +{$IFDEF MSWINDOWS} +var + Drive: array[0..3] of Char; + DirBuf, SaveBuf: array[0..MAX_PATH] of Char; +begin + if D <> 0 then + begin + Drive[0] := Chr(D + Ord('A') - 1); + Drive[1] := ':'; + Drive[2] := #0; + GetCurrentDirectory(SizeOf(SaveBuf), SaveBuf); + SetCurrentDirectory(Drive); + end; + GetCurrentDirectory(SizeOf(DirBuf), DirBuf); + if D <> 0 then SetCurrentDirectory(SaveBuf); + S := DirBuf; +{$ENDIF} +{$IFDEF LINUX} +var + DirBuf: array[0..MAX_PATH] of Char; +begin + __getcwd(DirBuf, sizeof(DirBuf)); + S := string(DirBuf); +{$ENDIF} +end; + +procedure _SGetDir(D: Byte; var S: ShortString); +var + L: string; +begin + _LGetDir(D, L); + S := L; +end; + +procedure _Insert{ source : ShortString; var s : openstring; index : Integer }; +asm +{ ->EAX Pointer to source string } +{ EDX Pointer to destination string } +{ ECX Length of destination string } +{ [ESP+4] Index } + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH ECX + MOV ECX,[ESP+16+4] + SUB ESP,512 { VAR buf: ARRAY [0..511] of Char } + + MOV EBX,EDX { save pointer to s for later } + MOV ESI,EDX + + XOR EDX,EDX + MOV DL,[ESI] + INC ESI + +{ limit index to [1 .. Length(s)+1] } + + INC EDX + TEST ECX,ECX + JLE @@smallInx + CMP ECX,EDX + JG @@bigInx +@@cont1: + DEC EDX { EDX = Length(s) } + { EAX = Pointer to src } + { ESI = EBX = Pointer to s } + { ECX = Index } + +{ copy index-1 chars from s to buf } + + MOV EDI,ESP + DEC ECX + SUB EDX,ECX { EDX = remaining length of s } + REP MOVSB + +{ copy Length(src) chars from src to buf } + + XCHG EAX,ESI { save pointer into s, point ESI to src } + MOV CL,[ESI] { ECX = Length(src) (ECX was zero after rep) } + INC ESI + REP MOVSB + +{ copy remaining chars of s to buf } + + MOV ESI,EAX { restore pointer into s } + MOV ECX,EDX { copy remaining bytes of s } + REP MOVSB + +{ calculate total chars in buf } + + SUB EDI,ESP { length = bufPtr - buf } + MOV ECX,[ESP+512] { ECX = Min(length, destLength) } +{ MOV ECX,[EBP-16] }{ ECX = Min(length, destLength) } + CMP ECX,EDI + JB @@1 + MOV ECX,EDI +@@1: + MOV EDI,EBX { Point EDI to s } + MOV ESI,ESP { Point ESI to buf } + MOV [EDI],CL { Store length in s } + INC EDI + REP MOVSB { Copy length chars to s } + JMP @@exit + +@@smallInx: + MOV ECX,1 + JMP @@cont1 +@@bigInx: + MOV ECX,EDX + JMP @@cont1 + +@@exit: + ADD ESP,512+4 + POP EDI + POP ESI + POP EBX + RET 4 +end; + +function IOResult: Integer; +begin + Result := InOutRes; + InOutRes := 0; +end; + +procedure MkDir(const S: string); +begin + MkDir(PChar(s)); +end; + +procedure MkDir(P: PChar); +begin +{$IFDEF MSWINDOWS} + if not CreateDirectory(P, 0) then +{$ENDIF} +{$IFDEF LINUX} + if __mkdir(P, -1) <> 0 then +{$ENDIF} + InOutError; +end; + +procedure Move( const Source; var Dest; count : Integer ); +{$IFDEF PUREPASCAL} +var + S, D: PChar; + I: Integer; +begin + S := PChar(@Source); + D := PChar(@Dest); + if S = D then Exit; + if Cardinal(D) > Cardinal(S) then + for I := count-1 downto 0 do + D[I] := S[I] + else + for I := 0 to count-1 do + D[I] := S[I]; +end; +{$ELSE} +asm +{ ->EAX Pointer to source } +{ EDX Pointer to destination } +{ ECX Count } +(*{X-} // original code. + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + MOV EAX,ECX + + CMP EDI,ESI + JA @@down + JE @@exit + + SAR ECX,2 { copy count DIV 4 dwords } + JS @@exit + + REP MOVSD + + MOV ECX,EAX + AND ECX,03H + REP MOVSB { copy count MOD 4 bytes } + JMP @@exit + +@@down: + LEA ESI,[ESI+ECX-4] { point ESI to last dword of source } + LEA EDI,[EDI+ECX-4] { point EDI to last dword of dest } + + SAR ECX,2 { copy count DIV 4 dwords } + JS @@exit + STD + REP MOVSD + + MOV ECX,EAX + AND ECX,03H { copy count MOD 4 bytes } + ADD ESI,4-1 { point to last byte of rest } + ADD EDI,4-1 + REP MOVSB + CLD +@@exit: + POP EDI + POP ESI +*){X+} +//--------------------------------------- +(* {X+} // Let us write smaller: + JCXZ @@fin + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + MOV EAX,ECX + + AND ECX,3 { copy count mod 4 dwords } + + CMP EDI,ESI + JE @@exit + JA @@up + +//down: + LEA ESI,[ESI+EAX-1] { point ESI to last byte of source } + LEA EDI,[EDI+EAX-1] { point EDI to last byte of dest } + STD + + CMP EAX, 4 + JL @@up + ADD ECX, 3 { move 3 bytes more to correct pos } + +@@up: + REP MOVSB + + SAR EAX, 2 + JS @@exit + + MOV ECX, EAX + REP MOVSD + +@@exit: + CLD + POP EDI + POP ESI + +@@fin: +*) {X-} +//--------------------------------------- +{X+} // And now, let us write speedy: + CMP ECX, 4 + JGE @@long + JCXZ @@fin + + CMP EAX, EDX + JE @@fin + + PUSH ESI + PUSH EDI + MOV ESI, EAX + MOV EDI, EDX + JA @@short_up + + LEA ESI,[ESI+ECX-1] { point ESI to last byte of source } + LEA EDI,[EDI+ECX-1] { point EDI to last byte of dest } + STD + +@@short_up: + REP MOVSB + JMP @@exit_up + +@@long: + CMP EAX, EDX + JE @@fin + + PUSH ESI + PUSH EDI + MOV ESI, EAX + MOV EDI, EDX + MOV EAX, ECX + + JA @@long_up + + { + SAR ECX, 2 + JS @@exit + + LEA ESI,[ESI+EAX-4] + LEA EDI,[EDI+EAX-4] + STD + REP MOVSD + + MOV ECX, EAX + MOV EAX, 3 + AND ECX, EAX + ADD ESI, EAX + ADD EDI, EAX + REP MOVSB + } // let's do it in other order - faster if data are aligned... + + AND ECX, 3 + LEA ESI,[ESI+EAX-1] + LEA EDI,[EDI+EAX-1] + STD + REP MOVSB + + SAR EAX, 2 + //JS @@exit // why to test this? but what does PC do? + MOV ECX, EAX + MOV EAX, 3 + SUB ESI, EAX + SUB EDI, EAX + REP MOVSD + +@@exit_up: + CLD + //JMP @@exit + DEC ECX // the same - loosing 2 tacts... but conveyer! + +@@long_up: + SAR ECX, 2 + JS @@exit + + REP MOVSD + + AND EAX, 3 + MOV ECX, EAX + REP MOVSB + +@@exit: + POP EDI + POP ESI + +@@fin: +{X-} +end; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function GetParamStr(P: PChar; var Param: string): PChar; +var + i, Len: Integer; + Start, S, Q: PChar; +begin + while True do + begin + while (P[0] <> #0) and (P[0] <= ' ') do + P := CharNext(P); + if (P[0] = '"') and (P[1] = '"') then Inc(P, 2) else Break; + end; + Len := 0; + Start := P; + while P[0] > ' ' do + begin + if P[0] = '"' then + begin + P := CharNext(P); + while (P[0] <> #0) and (P[0] <> '"') do + begin + Q := CharNext(P); + Inc(Len, Q - P); + P := Q; + end; + if P[0] <> #0 then + P := CharNext(P); + end + else + begin + Q := CharNext(P); + Inc(Len, Q - P); + P := Q; + end; + end; + + SetLength(Param, Len); + + P := Start; + S := Pointer(Param); + i := 0; + while P[0] > ' ' do + begin + if P[0] = '"' then + begin + P := CharNext(P); + while (P[0] <> #0) and (P[0] <> '"') do + begin + Q := CharNext(P); + while P < Q do + begin + S[i] := P^; + Inc(P); + Inc(i); + end; + end; + if P[0] <> #0 then P := CharNext(P); + end + else + begin + Q := CharNext(P); + while P < Q do + begin + S[i] := P^; + Inc(P); + Inc(i); + end; + end; + end; + + Result := P; +end; +{$ENDIF} + +function ParamCount: Integer; +{$IFDEF MSWINDOWS} +var + P: PChar; + S: string; +begin + Result := 0; + P := GetParamStr(GetCommandLine, S); + while True do + begin + P := GetParamStr(P, S); + if S = '' then Break; + Inc(Result); + end; +{$ENDIF} +{$IFDEF LINUX} +begin + if ArgCount > 1 then + Result := ArgCount - 1 + else Result := 0; +{$ENDIF} +end; + +type + PCharArray = array[0..0] of PChar; + +function ParamStr(Index: Integer): string; +{$IFDEF MSWINDOWS} +var + P: PChar; + Buffer: array[0..260] of Char; +begin + Result := ''; + if Index = 0 then + SetString(Result, Buffer, GetModuleFileName(0, Buffer, SizeOf(Buffer))) + else + begin + P := GetCommandLine; + while True do + begin + P := GetParamStr(P, Result); + if (Index = 0) or (Result = '') then Break; + Dec(Index); + end; + end; +{$ENDIF} +{$IFDEF LINUX} +begin + if Index < ArgCount then + Result := PCharArray(ArgValues^)[Index] + else + Result := ''; +{$ENDIF} +end; + +procedure _Pos{ substr : ShortString; s : ShortString ) : Integer}; +asm +{ ->EAX Pointer to substr } +{ EDX Pointer to string } +{ <-EAX Position of substr in s or 0 } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX { Point ESI to substr } + MOV EDI,EDX { Point EDI to s } + + XOR ECX,ECX { ECX = Length(s) } + MOV CL,[EDI] + INC EDI { Point EDI to first char of s } + + PUSH EDI { remember s position to calculate index } + + XOR EDX,EDX { EDX = Length(substr) } + MOV DL,[ESI] + INC ESI { Point ESI to first char of substr } + + DEC EDX { EDX = Length(substr) - 1 } + JS @@fail { < 0 ? return 0 } + MOV AL,[ESI] { AL = first char of substr } + INC ESI { Point ESI to 2'nd char of substr } + + SUB ECX,EDX { #positions in s to look at } + { = Length(s) - Length(substr) + 1 } + JLE @@fail +@@loop: + REPNE SCASB + JNE @@fail + MOV EBX,ECX { save outer loop counter } + PUSH ESI { save outer loop substr pointer } + PUSH EDI { save outer loop s pointer } + + MOV ECX,EDX + REPE CMPSB + POP EDI { restore outer loop s pointer } + POP ESI { restore outer loop substr pointer } + JE @@found + MOV ECX,EBX { restore outer loop counter } + JMP @@loop + +@@fail: + POP EDX { get rid of saved s pointer } + XOR EAX,EAX + JMP @@exit + +@@found: + POP EDX { restore pointer to first char of s } + MOV EAX,EDI { EDI points of char after match } + SUB EAX,EDX { the difference is the correct index } +@@exit: + POP EDI + POP ESI + POP EBX +end; + +// 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); +begin + Byte(s^[0]) := newLength; // should also fill new space +end; + +procedure _SetString(s: PShortString; buffer: PChar; len: Byte); +begin + Byte(s^[0]) := len; + if buffer <> nil then + Move(buffer^, s^[1], len); +end; + +procedure Randomize; +{$IFDEF LINUX} +begin + RandSeed := _time(nil); +{$ENDIF} +{$IFDEF MSWINDOWS} +var + systemTime : + record + wYear : Word; + wMonth : Word; + wDayOfWeek : Word; + wDay : Word; + wHour : Word; + wMinute : Word; + wSecond : Word; + wMilliSeconds: Word; + reserved : array [0..7] of char; + end; +asm + LEA EAX,systemTime + PUSH EAX + CALL GetSystemTime + MOVZX EAX,systemTime.wHour + IMUL EAX,60 + ADD AX,systemTime.wMinute { sum = hours * 60 + minutes } + IMUL EAX,60 + XOR EDX,EDX + MOV DX,systemTime.wSecond + ADD EAX,EDX { sum = sum * 60 + seconds } + IMUL EAX,1000 + MOV DX,systemTime.wMilliSeconds + ADD EAX,EDX { sum = sum * 1000 + milliseconds } + MOV RandSeed,EAX +{$ENDIF} +end; + + +function Random(const ARange: Integer): Integer; +{$IF DEFINED(CPU386)} +asm +{ ->EAX Range } +{ <-EAX Result } + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX + MOV ECX,[EBX].OFFSET RandSeed + IMUL EDX,[ECX],08088405H + INC EDX + MOV [ECX],EDX +{$ELSE} + XOR EBX, EBX + IMUL EDX,[EBX].RandSeed,08088405H + INC EDX + MOV [EBX].RandSeed,EDX +{$ENDIF} + MUL EDX + MOV EAX,EDX + POP EBX +end; +{$ELSEIF DEFINED(CLR)} +begin + InitRandom; + Result := RandomEngine.Next(ARange); +end; +{$ELSE} + {$MESSAGE ERROR 'Random(Int):Int unimplemented'} +{$IFEND} + +function Random: Extended; +{$IF DEFINED(CPU386)} +const two2neg32: double = ((1.0/$10000) / $10000); // 2^-32 +asm +{ FUNCTION _RandExt: Extended; } + + PUSH EBX +{$IFDEF PIC} + CALL GetGOT + MOV EBX,EAX + MOV ECX,[EBX].OFFSET RandSeed + IMUL EDX,[ECX],08088405H + INC EDX + MOV [ECX],EDX +{$ELSE} + XOR EBX, EBX + IMUL EDX,[EBX].RandSeed,08088405H + INC EDX + MOV [EBX].RandSeed,EDX +{$ENDIF} + + FLD [EBX].two2neg32 + PUSH 0 + PUSH EDX + FILD qword ptr [ESP] + ADD ESP,8 + FMULP ST(1), ST(0) + POP EBX +end; +{$ELSEIF DEFINED(CLR)} +begin + InitRandom; + Result := RandomEngine.NextDouble; +end; +{$ELSE} + {$MESSAGE ERROR 'Random:Extended unimplemented'} +{$IFEND} + +procedure RmDir(const S: string); +begin + RmDir(PChar(s)); +end; + +procedure RmDir(P: PChar); +begin +{$IFDEF MSWINDOWS} + if not RemoveDirectory(P) then +{$ENDIF} +{$IFDEF LINUX} + if __rmdir(P) <> 0 then +{$ENDIF} + InOutError; +end; + +function UpCase( ch : Char ) : Char; +{$IFDEF PUREPASCAL} +begin + Result := ch; + case Result of + 'a'..'z': Dec(Result, Ord('a') - Ord('A')); + end; +end; +{$ELSE} +asm +{ -> AL Character } +{ <- AL Result } + + CMP AL,'a' + JB @@exit + CMP AL,'z' + JA @@exit + SUB AL,'a' - 'A' +@@exit: +end; +{$ENDIF} + +procedure Set8087CW(NewCW: Word); +begin + Default8087CW := NewCW; + asm + FNCLEX // don't raise pending exceptions enabled by the new flags +{$IFDEF PIC} + MOV EAX,[EBX].OFFSET Default8087CW + FLDCW [EAX] +{$ELSE} + FLDCW Default8087CW +{$ENDIF} + end; +end; + +function Get8087CW: Word; +asm + PUSH 0 + FNSTCW [ESP].Word + POP EAX +end; + + +function Int(const X: Extended): Extended; +asm + FLD X + SUB ESP,4 + FNSTCW [ESP].Word // save + FNSTCW [ESP+2].Word // scratch + FWAIT + OR [ESP+2].Word, $0F00 // trunc toward zero, full precision + FLDCW [ESP+2].Word + FRNDINT + FWAIT + FLDCW [ESP].Word + ADD ESP,4 +end; + +function Frac(const X: Extended): Extended; +asm + FLD X + FLD ST(0) + SUB ESP,4 + FNSTCW [ESP].Word // save + FNSTCW [ESP+2].Word // scratch + FWAIT + OR [ESP+2].Word, $0F00 // trunc toward zero, full precision + FLDCW [ESP+2].Word + FRNDINT + FWAIT + FLDCW [ESP].Word + ADD ESP,4 + FSUB +end; + +function Exp(const X: Extended): Extended; +asm + { e**x = 2**(x*log2(e)) } + FLD X + FLDL2E { y := x*log2e; } + FMUL + FLD ST(0) { i := round(y); } + FRNDINT + FSUB ST(1), ST { f := y - i; } + FXCH ST(1) { z := 2**f } + F2XM1 + FLD1 + FADD + FSCALE { result := z * 2**i } + FSTP ST(1) +end; + +function Cos(const X: Extended): Extended; +asm + FLD X + FCOS + FWAIT +end; + +function Sin(const X: Extended): Extended; +asm + FLD X + FSIN + FWAIT +end; + +function Ln(const X: Extended): Extended; +asm + FLD X + FLDLN2 + FXCH + FYL2X + FWAIT +end; + +function ArcTan(const X: Extended): Extended; +asm + FLD X + FLD1 + FPATAN + FWAIT +end; + +function Sqrt(const X: Extended): Extended; +asm + FLD X + FSQRT + FWAIT +end; + +{ ----------------------------------------------------- } +{ functions & procedures that need compiler magic } +{ ----------------------------------------------------- } + +procedure _ROUND; +asm + { -> FST(0) Extended argument } + { <- EDX:EAX Result } + + SUB ESP,8 + FISTP qword ptr [ESP] + FWAIT + POP EAX + POP EDX +end; + +procedure _TRUNC; +asm + { -> FST(0) Extended argument } + { <- EDX:EAX Result } + + SUB ESP,12 + FNSTCW [ESP].Word // save + FNSTCW [ESP+2].Word // scratch + FWAIT + OR [ESP+2].Word, $0F00 // trunc toward zero, full precision + FLDCW [ESP+2].Word + FISTP qword ptr [ESP+4] + FWAIT + FLDCW [ESP].Word + POP ECX + POP EAX + POP EDX +end; + +procedure _AbstractError; +{$IFDEF PC_MAPPED_EXCEPTIONS} +asm + MOV EAX,210 + JMP _RunError +end; +{$ELSE} +{$IFDEF PIC} +begin + if Assigned(AbstractErrorProc) then + AbstractErrorProc; + _RunError(210); // loses return address +end; +{$ELSE} +asm + CMP AbstractErrorProc, 0 + JE @@NoAbstErrProc + CALL AbstractErrorProc + +@@NoAbstErrProc: + MOV EAX,210 + JMP _RunError +end; +{$ENDIF} +{$ENDIF} + +function TextOpen(var t: TTextRec): Integer; forward; + +function OpenText(var t: TTextRec; Mode: Word): Integer; +begin + if (t.Mode < fmClosed) or (t.Mode > fmInOut) then + Result := 102 + else + begin + if t.Mode <> fmClosed then _Close(t); + t.Mode := Mode; + if (t.Name[0] = #0) and (t.OpenFunc = nil) then // stdio + t.OpenFunc := @TextOpen; + Result := TTextIOFunc(t.OpenFunc)(t); + end; + if Result <> 0 then SetInOutRes(Result); +end; + +function _ResetText(var t: TTextRec): Integer; +begin + Result := OpenText(t, fmInput); +end; + +function _RewritText(var t: TTextRec): Integer; +begin + Result := OpenText(t, fmOutput); +end; + +function _Append(var t: TTextRec): Integer; +begin + Result := OpenText(t, fmInOut); +end; + +function TextIn(var t: TTextRec): Integer; +begin + t.BufEnd := 0; + t.BufPos := 0; +{$IFDEF LINUX} + t.BufEnd := __read(t.Handle, t.BufPtr, t.BufSize); + if Integer(t.BufEnd) = -1 then + begin + t.BufEnd := 0; + Result := GetLastError; + end + else + Result := 0; +{$ENDIF} +{$IFDEF MSWINDOWS} + if ReadFile(t.Handle, t.BufPtr^, t.BufSize, t.BufEnd, nil) = 0 then + begin + Result := GetLastError; + if Result = 109 then + Result := 0; // NT quirk: got "broken pipe"? it's really eof + end + else + Result := 0; +{$ENDIF} +end; + +function FileNOPProc(var t): Integer; +begin + Result := 0; +end; + +function TextOut(var t: TTextRec): Integer; +{$IFDEF MSWINDOWS} +var + Dummy: Cardinal; +{$ENDIF} +begin + if t.BufPos = 0 then + Result := 0 + else + begin +{$IFDEF LINUX} + if __write(t.Handle, t.BufPtr, t.BufPos) = Cardinal(-1) then +{$ENDIF} +{$IFDEF MSWINDOWS} + if WriteFile(t.Handle, t.BufPtr^, t.BufPos, Dummy, nil) = 0 then +{$ENDIF} + Result := GetLastError + else + Result := 0; + t.BufPos := 0; + end; +end; + +function InternalClose(Handle: Integer): Boolean; +begin +{$IFDEF LINUX} + Result := __close(Handle) = 0; +{$ENDIF} +{$IFDEF MSWINDOWS} + Result := CloseHandle(Handle) = 1; +{$ENDIF} +end; + +function TextClose(var t: TTextRec): Integer; +begin + t.Mode := fmClosed; + if not InternalClose(t.Handle) then + Result := GetLastError + else + Result := 0; +end; + +function TextOpenCleanup(var t: TTextRec): Integer; +begin + InternalClose(t.Handle); + t.Mode := fmClosed; + Result := GetLastError; +end; + +function TextOpen(var t: TTextRec): Integer; +{$IFDEF LINUX} +var + Flags: Integer; + Temp, I: Integer; + BytesRead: Integer; +begin + Result := 0; + t.BufPos := 0; + t.BufEnd := 0; + case t.Mode of + fmInput: // called by Reset + begin + Flags := O_RDONLY; + t.InOutFunc := @TextIn; + end; + fmOutput: // called by Rewrite + begin + Flags := O_CREAT or O_TRUNC or O_WRONLY; + t.InOutFunc := @TextOut; + end; + fmInOut: // called by Append + begin + Flags := O_APPEND or O_RDWR; + t.InOutFunc := @TextOut; + end; + else + Exit; + Flags := 0; + end; + + t.FlushFunc := @FileNOPProc; + + if t.Name[0] = #0 then // stdin or stdout + begin + t.BufPtr := @t.Buffer; + t.BufSize := sizeof(t.Buffer); + t.CloseFunc := @FileNOPProc; + if t.Mode = fmOutput then + begin + if @t = @ErrOutput then + t.Handle := STDERR_FILENO + else + t.Handle := STDOUT_FILENO; + t.FlushFunc := @TextOut; + end + else + t.Handle := STDIN_FILENO; + end + else + begin + t.CloseFunc := @TextClose; + + Temp := __open(t.Name, Flags, FileAccessRights); + if Temp = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + t.Handle := Temp; + + if t.Mode = fmInOut then // Append mode + begin + t.Mode := fmOutput; + + if (t.flags and tfCRLF) <> 0 then // DOS mode, EOF significant + begin // scan for EOF char in last 128 byte sector. + Temp := _lseek(t.Handle, 0, SEEK_END); + if Temp = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + Dec(Temp, 128); + if Temp < 0 then Temp := 0; + + if _lseek(t.Handle, Temp, SEEK_SET) = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + BytesRead := __read(t.Handle, t.BufPtr, 128); + if BytesRead = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + for I := 0 to BytesRead - 1 do + begin + if t.Buffer[I] = Char(cEOF) then + begin // truncate the file here + if _ftruncate(t.Handle, _lseek(t.Handle, I - BytesRead, SEEK_END)) = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + Break; + end; + end; + end; + end; + end; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +(* +var + OpenMode: Integer; + Flags, Std: ShortInt; + Temp: Integer; + I, BytesRead: Cardinal; + Mode: Byte; +begin + Result := 0; + if (t.Mode - fmInput) > (fmInOut - fmInput) then Exit; + Mode := t.Mode and 3; + t.BufPos := 0; + t.BufEnd := 0; + t.FlushFunc := @FileNOPProc; + + if t.Name[0] = #0 then // stdin or stdout + begin + t.BufPtr := @t.Buffer; + t.BufSize := sizeof(t.Buffer); + t.CloseFunc := @FileNOPProc; + if Mode = (fmOutput and 3) then + begin + t.InOutFunc := @TextOut; + if @t = @ErrOutput then + Std := STD_ERROR_HANDLE + else + Std := STD_OUTPUT_HANDLE; + end + else + begin + t.InOutFunc := @TextIn; + Std := STD_INPUT_HANDLE; + end; + t.Handle := GetStdHandle(Std); + end + else + begin + t.CloseFunc := @TextClose; + + Flags := OPEN_EXISTING; + if Mode = (fmInput and 3) then + begin // called by Reset + t.InOutFunc := @TextIn; + OpenMode := GENERIC_READ; // open for read + end + else + begin + t.InOutFunc := @TextOut; + if Mode = (fmInOut and 3) then // called by Append + OpenMode := GENERIC_READ OR GENERIC_WRITE // open for read/write + else + begin // called by Rewrite + OpenMode := GENERIC_WRITE; // open for write + Flags := CREATE_ALWAYS; + end; + end; + + Temp := CreateFileA(t.Name, OpenMode, FILE_SHARE_READ, nil, Flags, FILE_ATTRIBUTE_NORMAL, 0); + if Temp = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + t.Handle := Temp; + + if Mode = (fmInOut and 3) then + begin + Dec(t.Mode); // fmInOut -> fmOutput + +{; ??? we really have to look for the first eof byte in the +; ??? last record and truncate the file there. +; Not very nice and clean... +; +; lastRecPos = Max( GetFileSize(...) - 128, 0); +} + Temp := GetFileSize(t.Handle, 0); + if Temp = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + Dec(Temp, 128); + if Temp < 0 then Temp := 0; + + if (SetFilePointer(t.Handle, Temp, nil, FILE_BEGIN) = -1) or + (ReadFile(t.Handle, t.Buffer, 128, BytesRead, nil) = 0) then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + for I := 0 to BytesRead do + begin + if t.Buffer[I] = Char(cEOF) then + begin // truncate the file here + if (SetFilePointer(t.Handle, I - BytesRead, nil, FILE_END) = -1) or + (not SetEndOfFile(t.Handle)) then + begin + Result := TextOpenCleanup(t); + Exit; + end; + Break; + end; + end; + end; + if Mode <> (fmInput and 3) then + begin + case GetFileType(t.Handle) of + 0: begin // bad file type + TextOpenCleanup(t); + Result := 105; + Exit; + end; + 2: t.FlushFunc := @TextOut; + end; + end; + end; +end; +*) + +asm +// -> EAX Pointer to text record + + PUSH ESI + + MOV ESI,EAX + + XOR EAX,EAX + MOV [ESI].TTextRec.BufPos,EAX + MOV [ESI].TTextRec.BufEnd,EAX + MOV AX,[ESI].TTextRec.Mode + + SUB EAX,fmInput + JE @@calledByReset + + DEC EAX + JE @@calledByRewrite + + DEC EAX + JE @@calledByAppend + + JMP @@exit + +@@calledByReset: + + MOV EAX,GENERIC_READ // open for read + MOV EDX,FILE_SHARE_READ + MOV ECX,OPEN_EXISTING + + MOV [ESI].TTextRec.InOutFunc,offset TextIn + + JMP @@common + +@@calledByRewrite: + + MOV EAX,GENERIC_WRITE // open for write + MOV EDX,FILE_SHARE_READ + MOV ECX,CREATE_ALWAYS + JMP @@commonOut + +@@calledByAppend: + + MOV EAX,GENERIC_READ OR GENERIC_WRITE // open for read/write + MOV EDX,FILE_SHARE_READ + MOV ECX,OPEN_EXISTING + +@@commonOut: + + MOV [ESI].TTextRec.InOutFunc,offset TextOut + +@@common: + + MOV [ESI].TTextRec.CloseFunc,offset TextClose + MOV [ESI].TTextRec.FlushFunc,offset FileNOPProc + CMP byte ptr [ESI].TTextRec.Name,0 + JE @@isCon + +// CreateFile(t.Name, EAX, EDX, Nil, ECX, FILE_ATTRIBUTE_NORMAL, 0); + + PUSH 0 + PUSH FILE_ATTRIBUTE_NORMAL + PUSH ECX + PUSH 0 + PUSH EDX + PUSH EAX + LEA EAX,[ESI].TTextRec.Name + PUSH EAX + CALL CreateFileA + + CMP EAX,-1 + JZ @@error + + MOV [ESI].TTextRec.Handle,EAX + CMP [ESI].TTextRec.Mode,fmInOut + JNE @@success + + DEC [ESI].TTextRec.Mode // fmInOut -> fmOutput + +{; ??? we really have to look for the first eof byte in the +; ??? last record and truncate the file there. +; Not very nice and clean... +; +; lastRecPos = Max( GetFileSize(...) - 128, 0); +} + PUSH 0 + PUSH [ESI].TTextRec.Handle + CALL GetFileSize + + INC EAX + JZ @@error + SUB EAX,129 + JNC @@3 + XOR EAX,EAX +@@3: +// lseek(f.Handle, SEEK_SET, lastRecPos); + + PUSH FILE_BEGIN + PUSH 0 + PUSH EAX + PUSH [ESI].TTextRec.Handle + CALL SetFilePointer + + INC EAX + JE @@error + +// bytesRead = read(f.Handle, f.Buffer, 128); + + PUSH 0 + MOV EDX,ESP + PUSH 0 + PUSH EDX + PUSH 128 + LEA EDX,[ESI].TTextRec.Buffer + PUSH EDX + PUSH [ESI].TTextRec.Handle + CALL ReadFile + POP EDX + DEC EAX + JNZ @@error + +// for (i = 0; i < bytesRead; i++) + + XOR EAX,EAX +@@loop: + CMP EAX,EDX + JAE @@success + +// if (f.Buffer[i] == eof) + + CMP byte ptr [ESI].TTextRec.Buffer[EAX],eof + JE @@truncate + INC EAX + JMP @@loop + +@@truncate: + +// lseek( f.Handle, SEEK_END, i - bytesRead ); + + PUSH FILE_END + PUSH 0 + SUB EAX,EDX + PUSH EAX + PUSH [ESI].TTextRec.Handle + CALL SetFilePointer + INC EAX + JE @@error + +// SetEndOfFile( f.Handle ); + + PUSH [ESI].TTextRec.Handle + CALL SetEndOfFile + DEC EAX + JNE @@error + + JMP @@success + +@@isCon: + LEA EAX,[ESI].TTextRec.Buffer + MOV [ESI].TTextRec.BufSize, TYPE TTextRec.Buffer + MOV [ESI].TTextRec.CloseFunc,offset FileNOPProc + MOV [ESI].TTextRec.BufPtr,EAX + CMP [ESI].TTextRec.Mode,fmOutput + JE @@output + PUSH STD_INPUT_HANDLE + JMP @@1 +@@output: + CMP ESI,offset ErrOutput + JNE @@stdout + PUSH STD_ERROR_HANDLE + JMP @@1 +@@stdout: + PUSH STD_OUTPUT_HANDLE +@@1: + CALL GetStdHandle + CMP EAX,-1 + JE @@error + MOV [ESI].TTextRec.Handle,EAX + +@@success: + CMP [ESI].TTextRec.Mode,fmInput + JE @@2 + PUSH [ESI].TTextRec.Handle + CALL GetFileType + TEST EAX,EAX + JE @@badFileType + CMP EAX,2 + JNE @@2 + MOV [ESI].TTextRec.FlushFunc,offset TextOut +@@2: + XOR EAX,EAX +@@exit: + POP ESI + RET + +@@badFileType: + PUSH [ESI].TTextRec.Handle + CALL CloseHandle + MOV [ESI].TTextRec.Mode,fmClosed + MOV EAX,105 + JMP @@exit + +@@error: + MOV [ESI].TTextRec.Mode,fmClosed + CALL GetLastError + JMP @@exit +end; +{$ENDIF} + +const + fNameLen = 260; + +function _Assign(var t: TTextRec; const s: String): Integer; +begin + FillChar(t, sizeof(TFileRec), 0); + t.BufPtr := @t.Buffer; + t.Mode := fmClosed; + t.Flags := tfCRLF * Byte(DefaultTextLineBreakStyle); + t.BufSize := sizeof(t.Buffer); + t.OpenFunc := @TextOpen; + Move(S[1], t.Name, Length(s)); + t.Name[Length(s)] := #0; + Result := 0; +end; + +function InternalFlush(var t: TTextRec; Func: TTextIOFunc): Integer; +begin + case t.Mode of + fmOutput, + fmInOut : Result := Func(t); + fmInput : Result := 0; + else + if (@t = @Output) or (@t = @ErrOutput) then + Result := 0 + else + Result := 103; + end; + if Result <> 0 then SetInOutRes(Result); +end; + +function Flush(var t: Text): Integer; +begin + Result := InternalFlush(TTextRec(t), TTextRec(t).InOutFunc); +end; + +function _Flush(var t: TTextRec): Integer; +begin + Result := InternalFlush(t, t.FlushFunc); +end; + +type +{$IFDEF MSWINDOWS} + 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'; + +{$ENDIF} +{$IFDEF LINUX} + TIOProc = function (Handle: Integer; Buffer: Pointer; Count: Cardinal): Cardinal; cdecl; +{$ENDIF} + +function BlockIO(var f: TFileRec; buffer: Pointer; recCnt: Cardinal; var recsDone: Longint; + ModeMask: Integer; IOProc: TIOProc; ErrorNo: Integer): Cardinal; +// Note: RecsDone ptr can be nil! +begin + if (f.Mode and ModeMask) = ModeMask then // fmOutput or fmInOut / fmInput or fmInOut + begin +{$IFDEF LINUX} + Result := IOProc(f.Handle, buffer, recCnt * f.RecSize); + if Integer(Result) = -1 then +{$ENDIF} +{$IFDEF MSWINDOWS} + if IOProc(f.Handle, buffer, recCnt * f.RecSize, Result, nil) = 0 then +{$ENDIF} + begin + SetInOutRes(GetLastError); + Result := 0; + end + else + begin + Result := Result div f.RecSize; + if @RecsDone <> nil then + RecsDone := Result + else if Result <> recCnt then + begin + SetInOutRes(ErrorNo); + Result := 0; + end + end; + end + else + begin + SetInOutRes(103); // file not open + Result := 0; + end; +end; + +function _BlockRead(var f: TFileRec; buffer: Pointer; recCnt: Longint; var recsRead: Longint): Longint; +begin + Result := BlockIO(f, buffer, recCnt, recsRead, fmInput, + {$IFDEF MSWINDOWS} ReadFileX, {$ENDIF} + {$IFDEF LINUX} __read, {$ENDIF} + 100); +end; + +function _BlockWrite(var f: TFileRec; buffer: Pointer; recCnt: Longint; var recsWritten: Longint): Longint; +begin + Result := BlockIO(f, buffer, recCnt, recsWritten, fmOutput, + {$IFDEF MSWINDOWS} WriteFileX, {$ENDIF} + {$IFDEF LINUX} __write, {$ENDIF} + 101); +end; + +function _Close(var t: TTextRec): Integer; +begin + Result := 0; + if (t.Mode >= fmInput) and (t.Mode <= fmInOut) then + begin + if (t.Mode and fmOutput) = fmOutput then // fmOutput or fmInOut + Result := TTextIOFunc(t.InOutFunc)(t); + if Result = 0 then + Result := TTextIOFunc(t.CloseFunc)(t); + if Result <> 0 then + SetInOutRes(Result); + end + else + if @t <> @Input then + SetInOutRes(103); +end; + +procedure _PStrCat; +asm +{ ->EAX = Pointer to destination string } +{ EDX = Pointer to source string } + + PUSH ESI + PUSH EDI + +{ load dest len into EAX } + + MOV EDI,EAX + XOR EAX,EAX + MOV AL,[EDI] + +{ load source address in ESI, source len in ECX } + + MOV ESI,EDX + XOR ECX,ECX + MOV CL,[ESI] + INC ESI + +{ calculate final length in DL and store it in the destination } + + MOV DL,AL + ADD DL,CL + JC @@trunc + +@@cont: + MOV [EDI],DL + +{ calculate final dest address } + + INC EDI + ADD EDI,EAX + +{ do the copy } + + REP MOVSB + +{ done } + + POP EDI + POP ESI + RET + +@@trunc: + INC DL { DL = #chars to truncate } + SUB CL,DL { CL = source len - #chars to truncate } + MOV DL,255 { DL = maximum length } + JMP @@cont +end; + +procedure _PStrNCat; +asm +{ ->EAX = Pointer to destination string } +{ EDX = Pointer to source string } +{ CL = max length of result (allocated size of dest - 1) } + + PUSH ESI + PUSH EDI + +{ load dest len into EAX } + + MOV EDI,EAX + XOR EAX,EAX + MOV AL,[EDI] + +{ load source address in ESI, source len in EDX } + + MOV ESI,EDX + XOR EDX,EDX + MOV DL,[ESI] + INC ESI + +{ calculate final length in AL and store it in the destination } + + ADD AL,DL + JC @@trunc + CMP AL,CL + JA @@trunc + +@@cont: + MOV ECX,EDX + MOV DL,[EDI] + MOV [EDI],AL + +{ calculate final dest address } + + INC EDI + ADD EDI,EDX + +{ do the copy } + + REP MOVSB + +@@done: + POP EDI + POP ESI + RET + +@@trunc: +{ CL = maxlen } + + MOV AL,CL { AL = final length = maxlen } + SUB CL,[EDI] { CL = length to copy = maxlen - destlen } + JBE @@done + MOV DL,CL + JMP @@cont +end; + +procedure _PStrCpy(Dest: PShortString; Source: PShortString); +begin + Move(Source^, Dest^, Byte(Source^[0])+1); +end; + +procedure _PStrNCpy(Dest: PShortString; Source: PShortString; MaxLen: Byte); +begin + if MaxLen > Byte(Source^[0]) then + MaxLen := Byte(Source^[0]); + Byte(Dest^[0]) := MaxLen; + Move(Source^[1], Dest^[1], MaxLen); +end; + +procedure _PStrCmp; +asm +{ ->EAX = Pointer to left string } +{ EDX = Pointer to right string } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + XOR EAX,EAX + XOR EDX,EDX + MOV AL,[ESI] + MOV DL,[EDI] + INC ESI + INC EDI + + SUB EAX,EDX { eax = len1 - len2 } + JA @@skip1 + ADD EDX,EAX { edx = len2 + (len1 - len2) = len1 } + +@@skip1: + PUSH EDX + SHR EDX,2 + JE @@cmpRest +@@longLoop: + MOV ECX,[ESI] + MOV EBX,[EDI] + CMP ECX,EBX + JNE @@misMatch + DEC EDX + JE @@cmpRestP4 + MOV ECX,[ESI+4] + MOV EBX,[EDI+4] + CMP ECX,EBX + JNE @@misMatch + ADD ESI,8 + ADD EDI,8 + DEC EDX + JNE @@longLoop + JMP @@cmpRest +@@cmpRestP4: + ADD ESI,4 + ADD EDI,4 +@@cmpRest: + POP EDX + AND EDX,3 + JE @@equal + + MOV CL,[ESI] + CMP CL,[EDI] + JNE @@exit + DEC EDX + JE @@equal + MOV CL,[ESI+1] + CMP CL,[EDI+1] + JNE @@exit + DEC EDX + JE @@equal + MOV CL,[ESI+2] + CMP CL,[EDI+2] + JNE @@exit + +@@equal: + ADD EAX,EAX + JMP @@exit + +@@misMatch: + POP EDX + CMP CL,BL + JNE @@exit + CMP CH,BH + JNE @@exit + SHR ECX,16 + SHR EBX,16 + CMP CL,BL + JNE @@exit + CMP CH,BH + +@@exit: + POP EDI + POP ESI + POP EBX +end; + +procedure _AStrCmp; +asm +{ ->EAX = Pointer to left string } +{ EDX = Pointer to right string } +{ ECX = Number of chars to compare} + + PUSH EBX + PUSH ESI + PUSH ECX + MOV ESI,ECX + SHR ESI,2 + JE @@cmpRest + +@@longLoop: + MOV ECX,[EAX] + MOV EBX,[EDX] + CMP ECX,EBX + JNE @@misMatch + DEC ESI + JE @@cmpRestP4 + MOV ECX,[EAX+4] + MOV EBX,[EDX+4] + CMP ECX,EBX + JNE @@misMatch + ADD EAX,8 + ADD EDX,8 + DEC ESI + JNE @@longLoop + JMP @@cmpRest +@@cmpRestp4: + ADD EAX,4 + ADD EDX,4 +@@cmpRest: + POP ESI + AND ESI,3 + JE @@exit + + MOV CL,[EAX] + CMP CL,[EDX] + JNE @@exit + DEC ESI + JE @@equal + MOV CL,[EAX+1] + CMP CL,[EDX+1] + JNE @@exit + DEC ESI + JE @@equal + MOV CL,[EAX+2] + CMP CL,[EDX+2] + JNE @@exit + +@@equal: + XOR EAX,EAX + JMP @@exit + +@@misMatch: + POP ESI + CMP CL,BL + JNE @@exit + CMP CH,BH + JNE @@exit + SHR ECX,16 + SHR EBX,16 + CMP CL,BL + JNE @@exit + CMP CH,BH + +@@exit: + POP ESI + POP EBX +end; + +function _EofFile(var f: TFileRec): Boolean; +begin + Result := _FilePos(f) >= _FileSize(f); +end; + +function _EofText(var t: TTextRec): Boolean; +asm +// -> EAX Pointer to text record +// <- AL Boolean result + CMP [EAX].TTextRec.Mode,fmInput + JNE @@readChar + MOV EDX,[EAX].TTextRec.BufPos + CMP EDX,[EAX].TTextRec.BufEnd + JAE @@readChar + ADD EDX,[EAX].TTextRec.BufPtr + TEST [EAX].TTextRec.Flags,tfCRLF + JZ @@FalseExit + MOV CL,[EDX] + CMP CL,cEof + JNZ @@FalseExit + +@@eof: + MOV AL,1 + JMP @@exit + +@@readChar: + PUSH EAX + CALL _ReadChar + POP EDX + CMP AH,cEof + JE @@eof + DEC [EDX].TTextRec.BufPos +@@FalseExit: + XOR EAX,EAX +@@exit: +end; + +function _Eoln(var t: TTextRec): Boolean; +asm +// -> EAX Pointer to text record +// <- AL Boolean result + + CMP [EAX].TTextRec.Mode,fmInput + JNE @@readChar + MOV EDX,[EAX].TTextRec.BufPos + CMP EDX,[EAX].TTextRec.BufEnd + JAE @@readChar + ADD EDX,[EAX].TTextRec.BufPtr + TEST [EAX].TTextRec.Flags,tfCRLF + MOV AL,0 + MOV CL,[EDX] + JZ @@testLF + CMP CL,cCR + JE @@eol + CMP CL,cEOF + JE @@eof + JMP @@exit + +@@testLF: + CMP CL,cLF + JE @@eol + CMP CL,cEOF + JE @@eof + JMP @@exit + +@@readChar: + PUSH EAX + CALL _ReadChar + POP EDX + CMP AH,cEOF + JE @@eof + DEC [EDX].TTextRec.BufPos + XOR ECX,ECX + XCHG ECX,EAX + TEST [EDX].TTextRec.Mode,tfCRLF + JE @@testLF + CMP CL,cCR + JE @@eol + JMP @@exit + +@@eol: +@@eof: + MOV AL,1 +@@exit: +end; + +procedure _Erase(var f: TFileRec); +begin + if (f.Mode < fmClosed) or (f.Mode > fmInOut) then + SetInOutRes(102) // file not assigned + else +{$IFDEF LINUX} + if __remove(f.Name) < 0 then + SetInOutRes(GetLastError); +{$ENDIF} +{$IFDEF MSWINDOWS} + if not DeleteFileA(f.Name) then + SetInOutRes(GetLastError); +{$ENDIF} +end; + +{$IFDEF MSWINDOWS} +// Floating-point divide reverse routine +// ST(1) = ST(0) / ST(1), pop ST + +procedure _FSafeDivideR; +asm + FXCH + JMP _FSafeDivide +end; + +// Floating-point divide routine +// ST(1) = ST(1) / ST(0), pop ST + +procedure _FSafeDivide; +type + Z = packed record // helper type to make parameter references more readable + Dividend: Extended; // (TBYTE PTR [ESP]) + Pad: Word; + Divisor: Extended; // (TBYTE PTR [ESP+12]) + end; +asm + CMP TestFDIV,0 //Check FDIV indicator + JLE @@FDivideChecked //Jump if flawed or don't know + FDIV //Known to be ok, so just do FDIV + RET + +// FDIV constants +@@FDIVRiscTable: DB 0,1,0,0,4,0,0,7,0,0,10,0,0,13,0,0; + +@@FDIVScale1: DD $3F700000 // 0.9375 +@@FDIVScale2: DD $3F880000 // 1.0625 +@@FDIV1SHL63: DD $5F000000 // 1 SHL 63 + +@@TestDividend: DD $C0000000,$4150017E // 4195835.0 +@@TestDivisor: DD $80000000,$4147FFFF // 3145727.0 +@@TestOne: DD $00000000,$3FF00000 // 1.0 + +// Flawed FDIV detection +@@FDivideDetect: + MOV TestFDIV,1 //Indicate correct FDIV + PUSH EAX + SUB ESP,12 + FSTP TBYTE PTR [ESP] //Save off ST + FLD QWORD PTR @@TestDividend //Ok if x - (x / y) * y < 1.0 + FDIV QWORD PTR @@TestDivisor + FMUL QWORD PTR @@TestDivisor + FSUBR QWORD PTR @@TestDividend + FCOMP QWORD PTR @@TestOne + FSTSW AX + SHR EAX,7 + AND EAX,002H //Zero if FDIV is flawed + DEC EAX + MOV TestFDIV,AL //1 means Ok, -1 means flawed + FLD TBYTE PTR [ESP] //Restore ST + ADD ESP,12 + POP EAX + JMP _FSafeDivide + +@@FDivideChecked: + JE @@FDivideDetect //Do detection if TestFDIV = 0 + +@@1: PUSH EAX + SUB ESP,24 + FSTP [ESP].Z.Divisor //Store Divisor and Dividend + FSTP [ESP].Z.Dividend + FLD [ESP].Z.Dividend + FLD [ESP].Z.Divisor +@@2: MOV EAX,DWORD PTR [ESP+4].Z.Divisor //Is Divisor a denormal? + ADD EAX,EAX + JNC @@20 //Yes, @@20 + XOR EAX,0E000000H //If these three bits are not all + TEST EAX,0E000000H //ones, FDIV will work + JZ @@10 //Jump if all ones +@@3: FDIV //Do FDIV and exit + ADD ESP,24 + POP EAX + RET + +@@10: SHR EAX,28 //If the four bits following the MSB + //of the mantissa have a decimal + //of 1, 4, 7, 10, or 13, FDIV may + CMP byte ptr @@FDIVRiscTable[EAX],0 //not work correctly + JZ @@3 //Do FDIV if not 1, 4, 7, 10, or 13 + MOV EAX,DWORD PTR [ESP+8].Z.Divisor //Get Divisor exponent + AND EAX,7FFFH + JZ @@3 //Ok to FDIV if denormal + CMP EAX,7FFFH + JE @@3 //Ok to FDIV if NAN or INF + MOV EAX,DWORD PTR [ESP+8].Z.Dividend //Get Dividend exponent + AND EAX,7FFFH + CMP EAX,1 //Small number? + JE @@11 //Yes, @@11 + FMUL DWORD PTR @@FDIVScale1 //Scale by 15/16 + FXCH + FMUL DWORD PTR @@FDIVScale1 + FXCH + JMP @@3 //FDIV is now safe + +@@11: FMUL DWORD PTR @@FDIVScale2 //Scale by 17/16 + FXCH + FMUL DWORD PTR @@FDIVScale2 + FXCH + JMP @@3 //FDIV is now safe + +@@20: MOV EAX,DWORD PTR [ESP].Z.Divisor //Is entire Divisor zero? + OR EAX,DWORD PTR [ESP+4].Z.Divisor + JZ @@3 //Yes, ok to FDIV + MOV EAX,DWORD PTR [ESP+8].Z.Divisor //Get Divisor exponent + AND EAX,7FFFH //Non-zero exponent is invalid + JNZ @@3 //Ok to FDIV if invalid + MOV EAX,DWORD PTR [ESP+8].Z.Dividend //Get Dividend exponent + AND EAX,7FFFH //Denormal? + JZ @@21 //Yes, @@21 + CMP EAX,7FFFH //NAN or INF? + JE @@3 //Yes, ok to FDIV + MOV EAX,DWORD PTR [ESP+4].Z.Dividend //If MSB of mantissa is zero, + ADD EAX,EAX //the number is invalid + JNC @@3 //Ok to FDIV if invalid + JMP @@22 +@@21: MOV EAX,DWORD PTR [ESP+4].Z.Dividend //If MSB of mantissa is zero, + ADD EAX,EAX //the number is invalid + JC @@3 //Ok to FDIV if invalid +@@22: FXCH //Scale stored Divisor image by + FSTP ST(0) //1 SHL 63 and restart + FLD ST(0) + FMUL DWORD PTR @@FDIV1SHL63 + FSTP [ESP].Z.Divisor + FLD [ESP].Z.Dividend + FXCH + JMP @@2 +end; +{$ENDIF} + +function _FilePos(var f: TFileRec): Longint; +begin + if (f.Mode > fmClosed) and (f.Mode <= fmInOut) then + begin +{$IFDEF LINUX} + Result := _lseek(f.Handle, 0, SEEK_CUR); +{$ENDIF} +{$IFDEF MSWINDOWS} + Result := SetFilePointer(f.Handle, 0, nil, FILE_CURRENT); +{$ENDIF} + if Result = -1 then + InOutError + else + Result := Cardinal(Result) div f.RecSize; + end + else + begin + SetInOutRes(103); + Result := -1; + end; +end; + +function _FileSize(var f: TFileRec): Longint; +{$IFDEF MSWINDOWS} +begin + Result := -1; + if (f.Mode > fmClosed) and (f.Mode <= fmInOut) then + begin + Result := GetFileSize(f.Handle, 0); + if Result = -1 then + InOutError + else + Result := Cardinal(Result) div f.RecSize; + end + else + SetInOutRes(103); +{$ENDIF} +{$IFDEF LINUX} +var + stat: TStatStruct; +begin + Result := -1; + if (f.Mode > fmClosed) and (f.Mode <= fmInOut) then + begin + if _fxstat(STAT_VER_LINUX, f.Handle, stat) <> 0 then + InOutError + else + Result := stat.st_size div f.RecSize; + end + else + SetInOutRes(103); +{$ENDIF} +end; + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The assembly implementation of procedure FillChar is subject to the + * Mozilla Public License Version 1.1 (the "License"); you may + * not use this file except in compliance with the License. + * You may obtain a copy of the License at http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is Fastcode + * + * The Initial Developer of the Original Code is + * Fastcode + * + * Portions created by the Initial Developer are Copyright (C) 2002-2004 + * the Initial Developer. All Rights Reserved. + * + * Contributor(s): John O'Harrow + * + * ***** END LICENSE BLOCK ***** *) +procedure _FillChar(var Dest; count: Integer; Value: Char); +{$IFDEF PUREPASCAL} +var + I: Integer; + P: PChar; +begin + P := PChar(@Dest); + for I := count-1 downto 0 do + P[I] := Value; +end; +{$ELSE} +asm // Size = 153 Bytes + CMP EDX, 32 + MOV CH, CL // Copy Value into both Bytes of CX + JL @@Small + MOV [EAX ], CX // Fill First 8 Bytes + MOV [EAX+2], CX + MOV [EAX+4], CX + MOV [EAX+6], CX + SUB EDX, 16 + FLD QWORD PTR [EAX] + FST QWORD PTR [EAX+EDX] // Fill Last 16 Bytes + FST QWORD PTR [EAX+EDX+8] + MOV ECX, EAX + AND ECX, 7 // 8-Byte Align Writes + SUB ECX, 8 + SUB EAX, ECX + ADD EDX, ECX + ADD EAX, EDX + NEG EDX +@@Loop: + FST QWORD PTR [EAX+EDX] // Fill 16 Bytes per Loop + FST QWORD PTR [EAX+EDX+8] + ADD EDX, 16 + JL @@Loop + FFREE ST(0) + RET + NOP + NOP + NOP +@@Small: + TEST EDX, EDX + JLE @@Done + MOV [EAX+EDX-1], CL // Fill Last Byte + AND EDX, -2 // No. of Words to Fill + NEG EDX + LEA EDX, [@@SmallFill + 60 + EDX * 2] + JMP EDX + NOP // Align Jump Destinations + NOP +@@SmallFill: + MOV [EAX+28], CX + MOV [EAX+26], CX + MOV [EAX+24], CX + MOV [EAX+22], CX + MOV [EAX+20], CX + MOV [EAX+18], CX + MOV [EAX+16], CX + MOV [EAX+14], CX + MOV [EAX+12], CX + MOV [EAX+10], CX + MOV [EAX+ 8], CX + MOV [EAX+ 6], CX + MOV [EAX+ 4], CX + MOV [EAX+ 2], CX + MOV [EAX ], CX + RET // DO NOT REMOVE - This is for Alignment +@@Done: +end; +{$ENDIF} + +procedure Mark; +begin + Error(reInvalidPtr); +end; + +function _ReadRec(var f: TFileRec; Buffer: Pointer): Integer; +{$IFDEF LINUX} +begin + if (f.Mode and fmInput) = fmInput then // fmInput or fmInOut + begin + Result := __read(f.Handle, Buffer, f.RecSize); + if Result = -1 then + InOutError + else if Cardinal(Result) <> f.RecSize then + SetInOutRes(100); + end + else + begin + SetInOutRes(103); // file not open for input + Result := 0; + end; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm +// -> EAX Pointer to file variable +// EDX Pointer to buffer + + PUSH EBX + XOR ECX,ECX + MOV EBX,EAX + MOV CX,[EAX].TFileRec.Mode // File must be open + SUB ECX,fmInput + JE @@skip + SUB ECX,fmInOut-fmInput + JNE @@fileNotOpen +@@skip: + +// ReadFile(f.Handle, buffer, f.RecSize, @result, Nil); + + PUSH 0 // space for OS result + MOV EAX,ESP + + PUSH 0 // pass lpOverlapped + PUSH EAX // pass @result + + PUSH [EBX].TFileRec.RecSize // pass nNumberOfBytesToRead + + PUSH EDX // pass lpBuffer + PUSH [EBX].TFileRec.Handle // pass hFile + CALL ReadFile + POP EDX // pop result + DEC EAX // check EAX = TRUE + JNZ @@error + + CMP EDX,[EBX].TFileRec.RecSize // result = f.RecSize ? + JE @@exit + +@@readError: + MOV EAX,100 + JMP @@errExit + +@@fileNotOpen: + MOV EAX,103 + JMP @@errExit + +@@error: + CALL GetLastError +@@errExit: + CALL SetInOutRes +@@exit: + POP EBX +end; +{$ENDIF} + + +// If the file is Input std variable, try to open it +// Otherwise, runtime error. +function TryOpenForInput(var t: TTextRec): Boolean; +begin + if @t = @Input then + begin + t.Flags := tfCRLF * Byte(DefaultTextLineBreakStyle); + _ResetText(t); + end; + + Result := t.Mode = fmInput; + if not Result then + SetInOutRes(104); +end; + +function _ReadChar(var t: TTextRec): Char; +asm +// -> EAX Pointer to text record +// <- AL Character read. (may be a pseudo cEOF in DOS mode) +// <- AH cEOF = End of File, else 0 +// For eof, #$1A is returned in AL and in AH. +// For errors, InOutRes is set and #$1A is returned. + + CMP [EAX].TTextRec.Mode, fmInput + JE @@checkBuf + PUSH EAX + CALL TryOpenForInput + TEST AL,AL + POP EAX + JZ @@eofexit + +@@checkBuf: + MOV EDX,[EAX].TTextRec.BufPos + CMP EDX,[EAX].TTextRec.BufEnd + JAE @@fillBuf +@@cont: + TEST [EAX].TTextRec.Flags,tfCRLF + MOV ECX,[EAX].TTextRec.BufPtr + MOV CL,[ECX+EDX] + JZ @@cont2 + CMP CL,cEof // Check for EOF char in DOS mode + JE @@eofexit +@@cont2: + INC EDX + MOV [EAX].TTextRec.BufPos,EDX + XOR EAX,EAX + JMP @@exit + +@@fillBuf: + PUSH EAX + CALL [EAX].TTextRec.InOutFunc + TEST EAX,EAX + JNE @@error + POP EAX + MOV EDX,[EAX].TTextRec.BufPos + CMP EDX,[EAX].TTextRec.BufEnd + JB @@cont + +// We didn't get characters. Must be eof then. + +@@eof: + TEST [EAX].TTextRec.Flags,tfCRLF + JZ @@eofexit +// In DOS CRLF compatibility mode, synthesize an EOF char +// Store one eof in the buffer and increment BufEnd + MOV ECX,[EAX].TTextRec.BufPtr + MOV byte ptr [ECX+EDX],cEof + INC [EAX].TTextRec.BufEnd + JMP @@eofexit + +@@error: + CALL SetInOutRes + POP EAX +@@eofexit: + MOV CL,cEof + MOV AH,CL +@@exit: + MOV AL,CL +end; + +function _ReadLong(var t: TTextRec): Longint; +asm +// -> EAX Pointer to text record +// <- EAX Result + + PUSH EBX + PUSH ESI + PUSH EDI + SUB ESP,36 // var numbuf: String[32]; + + MOV ESI,EAX + CALL _SeekEof + DEC AL + JZ @@eof + + MOV EDI,ESP // EDI -> numBuf[0] + MOV BL,32 +@@loop: + MOV EAX,ESI + CALL _ReadChar + CMP AL,' ' + JBE @@endNum + STOSB + DEC BL + JNZ @@loop +@@convert: + MOV byte ptr [EDI],0 + MOV EAX,ESP // EAX -> numBuf + PUSH EDX // allocate code result + MOV EDX,ESP // pass pointer to code + CALL _ValLong // convert + POP EDX // pop code result into EDX + TEST EDX,EDX + JZ @@exit + MOV EAX,106 + CALL SetInOutRes + JMP @@exit + +@@endNum: + CMP AH,cEof + JE @@convert + DEC [ESI].TTextRec.BufPos + JMP @@convert + +@@eof: + XOR EAX,EAX +@@exit: + ADD ESP,36 + POP EDI + POP ESI + POP EBX +end; + +function ReadLine(var t: TTextRec; buf: Pointer; maxLen: Longint): Pointer; +asm +// -> EAX Pointer to text record +// EDX Pointer to buffer +// ECX Maximum count of chars to read +// <- ECX Actual count of chars in buffer +// <- EAX Pointer to text record + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH ECX + MOV ESI,ECX + MOV EDI,EDX + + CMP [EAX].TTextRec.Mode,fmInput + JE @@start + PUSH EAX + CALL TryOpenForInput + TEST AL,AL + POP EAX + JZ @@exit + +@@start: + MOV EBX,EAX + + TEST ESI,ESI + JLE @@exit + + MOV EDX,[EBX].TTextRec.BufPos + MOV ECX,[EBX].TTextRec.BufEnd + SUB ECX,EDX + ADD EDX,[EBX].TTextRec.BufPtr + +@@loop: + DEC ECX + JL @@readChar + MOV AL,[EDX] + INC EDX +@@cont: + CMP AL,cLF + JE @@lf + + CMP AL,cCR + JE @@cr + + STOSB + DEC ESI + JG @@loop + + JMP @@finish + +@@cr: + MOV AL,[EDX] + CMP AL,cLF + JNE @@loop +@@lf: + DEC EDX +@@finish: + SUB EDX,[EBX].TTextRec.BufPtr + MOV [EBX].TTextRec.BufPos,EDX + JMP @@exit + +@@readChar: + MOV [EBX].TTextRec.BufPos,EDX + MOV EAX,EBX + CALL _ReadChar + MOV EDX,[EBX].TTextRec.BufPos + MOV ECX,[EBX].TTextRec.BufEnd + SUB ECX,EDX + ADD EDX,[EBX].TTextRec.BufPtr + TEST AH,AH //eof + JZ @@cont + +@@exit: + MOV EAX,EBX + POP ECX + SUB ECX,ESI + POP EDI + POP ESI + POP EBX +end; + +procedure _ReadString(var t: TTextRec; s: PShortString; maxLen: Longint); +asm +// -> EAX Pointer to text record +// EDX Pointer to string +// ECX Maximum length of string + + PUSH EDX + INC EDX + CALL ReadLine + POP EDX + MOV [EDX],CL +end; + +procedure _ReadCString(var t: TTextRec; s: PChar; maxLen: Longint); +asm +// -> EAX Pointer to text record +// EDX Pointer to string +// ECX Maximum length of string + + PUSH EDX + CALL ReadLine + POP EDX + MOV byte ptr [EDX+ECX],0 +end; + +procedure _ReadLString(var t: TTextRec; var s: AnsiString); +asm + { -> EAX pointer to Text } + { EDX pointer to AnsiString } + + PUSH EBX + PUSH ESI + MOV EBX,EAX + MOV ESI,EDX + + MOV EAX,EDX + CALL _LStrClr + + SUB ESP,256 + + MOV EAX,EBX + MOV EDX,ESP + MOV ECX,255 + CALL _ReadString + + MOV EAX,ESI + MOV EDX,ESP + CALL _LStrFromString + + CMP byte ptr [ESP],255 + JNE @@exit +@@loop: + + MOV EAX,EBX + MOV EDX,ESP + MOV ECX,255 + CALL _ReadString + + MOV EDX,ESP + PUSH 0 + MOV EAX,ESP + CALL _LStrFromString + + MOV EAX,ESI + MOV EDX,[ESP] + CALL _LStrCat + + MOV EAX,ESP + CALL _LStrClr + POP EAX + + CMP byte ptr [ESP],255 + JE @@loop + +@@exit: + ADD ESP,256 + POP ESI + POP EBX +end; + + +function IsValidMultibyteChar(const Src: PChar; SrcBytes: Integer): Boolean; +{$IFDEF MSWINDOWS} +const + ERROR_NO_UNICODE_TRANSLATION = 1113; // Win32 GetLastError when result = 0 + MB_ERR_INVALID_CHARS = 8; +var + Dest: WideChar; +begin + Result := MultiByteToWideChar(0, MB_ERR_INVALID_CHARS, Src, SrcBytes, @Dest, 1) <> 0; +{$ENDIF} +{$IFDEF LINUX} +begin + Result := mblen(Src, SrcBytes) <> -1; +{$ENDIF} +end; + + +function _ReadWChar(var t: TTextRec): WideChar; +var + scratch: array [0..7] of AnsiChar; + wc: WideChar; + i: Integer; +begin + i := 0; + while i < High(scratch) do + begin + scratch[i] := _ReadChar(t); + Inc(i); + scratch[i] := #0; + if IsValidMultibyteChar(scratch, i) then + begin + WCharFromChar(@wc, 1, scratch, i); + Result := wc; + Exit; + end; + end; + SetInOutRes(106); // Invalid Input + Result := #0; +end; + + +procedure _ReadWCString(var t: TTextRec; s: PWideChar; maxBytes: Longint); +var + i, maxLen: Integer; + wc: WideChar; +begin + if s = nil then Exit; + i := 0; + maxLen := maxBytes div sizeof(WideChar); + while i < maxLen do + begin + wc := _ReadWChar(t); + case Integer(wc) of + cEOF: if _EOFText(t) then Break; + cLF : begin + Dec(t.BufPos); + Break; + end; + cCR : if Byte(t.BufPtr[t.BufPos]) = cLF then + begin + Dec(t.BufPos); + Break; + end; + end; + s[i] := wc; + Inc(i); + end; + s[i] := #0; +end; + +procedure _ReadWString(var t: TTextRec; var s: WideString); +var + Temp: AnsiString; +begin + _ReadLString(t, Temp); + s := Temp; +end; + +function _ReadExt(var t: TTextRec): Extended; +asm +// -> EAX Pointer to text record +// <- FST(0) Result + + PUSH EBX + PUSH ESI + PUSH EDI + SUB ESP,68 // var numbuf: array[0..64] of char; + + MOV ESI,EAX + CALL _SeekEof + DEC AL + JZ @@eof + + MOV EDI,ESP // EDI -> numBuf[0] + MOV BL,64 +@@loop: + MOV EAX,ESI + CALL _ReadChar + CMP AL,' ' + JBE @@endNum + STOSB + DEC BL + JNZ @@loop +@@convert: + MOV byte ptr [EDI],0 + MOV EAX,ESP // EAX -> numBuf + PUSH EDX // allocate code result + MOV EDX,ESP // pass pointer to code + CALL _ValExt // convert + POP EDX // pop code result into EDX + TEST EDX,EDX + JZ @@exit + MOV EAX,106 + CALL SetInOutRes + JMP @@exit + +@@endNum: + CMP AH,cEOF + JE @@convert + DEC [ESI].TTextRec.BufPos + JMP @@convert + +@@eof: + FLDZ +@@exit: + ADD ESP,68 + POP EDI + POP ESI + POP EBX +end; + +procedure _ReadLn(var t: TTextRec); +asm +// -> EAX Pointer to text record + + PUSH EBX + MOV EBX,EAX +@@loop: + MOV EAX,EBX + CALL _ReadChar + + CMP AL,cLF // accept LF as end of line + JE @@exit + CMP AH,cEOF + JE @@eof + CMP AL,cCR + JNE @@loop + + MOV EAX,EBX + CALL _ReadChar + + CMP AL,cLF // accept CR+LF as end of line + JE @@exit + CMP AH,cEOF // accept CR+EOF as end of line + JE @@eof + DEC [EBX].TTextRec.BufPos + JMP @@loop // else CR+ anything else is not a line break. + +@@exit: +@@eof: + POP EBX +end; + +procedure _Rename(var f: TFileRec; newName: PChar); +var + I: Integer; +begin + if f.Mode = fmClosed then + begin + if newName = nil then newName := ''; +{$IFDEF LINUX} + if __rename(f.Name, newName) = 0 then +{$ENDIF} +{$IFDEF MSWINDOWS} + if MoveFileA(f.Name, newName) then +{$ENDIF} + begin + I := 0; + while (newName[I] <> #0) and (I < High(f.Name)) do + begin + f.Name[I] := newName[I]; + Inc(I); + end + end + else + SetInOutRes(GetLastError); + end + else + SetInOutRes(102); +end; + +procedure Release; +begin + Error(reInvalidPtr); +end; + +function _CloseFile(var f: TFileRec): Integer; +begin + f.Mode := fmClosed; + Result := 0; + if not InternalClose(f.Handle) then + begin + InOutError; + Result := 1; + end; +end; + +function OpenFile(var f: TFileRec; recSiz: Longint; mode: Longint): Integer; +{$IFDEF LINUX} +var + Flags: Integer; +begin + Result := 0; + if (f.Mode >= fmClosed) and (f.Mode <= fmInOut) then + begin + if f.Mode <> fmClosed then // not yet closed: close it + begin + Result := TFileIOFunc(f.CloseFunc)(f); + if Result <> 0 then + SetInOutRes(Result); + end; + + if recSiz <= 0 then + SetInOutRes(106); + + f.RecSize := recSiz; + f.InOutFunc := @FileNopProc; + + if f.Name[0] <> #0 then + begin + f.CloseFunc := @_CloseFile; + case mode of + 1: begin + Flags := O_APPEND or O_WRONLY; + f.Mode := fmOutput; + end; + 2: begin + Flags := O_RDWR; + f.Mode := fmInOut; + end; + 3: begin + Flags := O_CREAT or O_TRUNC or O_RDWR; + f.Mode := fmInOut; + end; + else + Flags := O_RDONLY; + f.Mode := fmInput; + end; + + f.Handle := __open(f.Name, Flags, FileAccessRights); + end + else // stdin or stdout + begin + f.CloseFunc := @FileNopProc; + if mode = 3 then + f.Handle := STDOUT_FILENO + else + f.Handle := STDIN_FILENO; + end; + + if f.Handle = -1 then + begin + f.Mode := fmClosed; + InOutError; + end; + end + else + SetInOutRes(102); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +const + ShareTab: array [0..7] of Integer = + (FILE_SHARE_READ OR FILE_SHARE_WRITE, // OF_SHARE_COMPAT 0x00000000 + 0, // OF_SHARE_EXCLUSIVE 0x00000010 + FILE_SHARE_READ, // OF_SHARE_DENY_WRITE 0x00000020 + FILE_SHARE_WRITE, // OF_SHARE_DENY_READ 0x00000030 + FILE_SHARE_READ OR FILE_SHARE_WRITE, // OF_SHARE_DENY_NONE 0x00000040 + 0,0,0); +asm +//-> EAX Pointer to file record +// EDX Record size +// ECX File mode + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EDX + MOV EDI,ECX + XOR EDX,EDX + MOV EBX,EAX + + MOV DX,[EAX].TFileRec.Mode + SUB EDX,fmClosed + JE @@alreadyClosed + CMP EDX,fmInOut-fmClosed + JA @@notAssignedError + +// not yet closed: close it. File parameter is still in EAX + + CALL [EBX].TFileRec.CloseFunc + TEST EAX,EAX + JE @@alreadyClosed + CALL SetInOutRes + +@@alreadyClosed: + + MOV [EBX].TFileRec.Mode,fmInOut + MOV [EBX].TFileRec.RecSize,ESI + MOV [EBX].TFileRec.CloseFunc,offset _CloseFile + MOV [EBX].TFileRec.InOutFunc,offset FileNopProc + + CMP byte ptr [EBX].TFileRec.Name,0 + JE @@isCon + + MOV EAX,GENERIC_READ OR GENERIC_WRITE + MOV DL,FileMode + AND EDX,070H + SHR EDX,4-2 + MOV EDX,dword ptr [shareTab+EDX] + MOV ECX,CREATE_ALWAYS + + SUB EDI,3 + JE @@calledByRewrite + + MOV ECX,OPEN_EXISTING + INC EDI + JE @@skip + + MOV EAX,GENERIC_WRITE + INC EDI + MOV [EBX].TFileRec.Mode,fmOutput + JE @@skip + + MOV EAX,GENERIC_READ + MOV [EBX].TFileRec.Mode,fmInput + +@@skip: +@@calledByRewrite: + +// CreateFile(t.FileName, EAX, EDX, Nil, ECX, FILE_ATTRIBUTE_NORMAL, 0); + + PUSH 0 + PUSH FILE_ATTRIBUTE_NORMAL + PUSH ECX + PUSH 0 + PUSH EDX + PUSH EAX + LEA EAX,[EBX].TFileRec.Name + PUSH EAX + CALL CreateFileA +@@checkHandle: + CMP EAX,-1 + JZ @@error + + MOV [EBX].TFileRec.Handle,EAX + JMP @@exit + +@@isCon: + MOV [EBX].TFileRec.CloseFunc,offset FileNopProc + CMP EDI,3 + JE @@output + PUSH STD_INPUT_HANDLE + JMP @@1 +@@output: + PUSH STD_OUTPUT_HANDLE +@@1: + CALL GetStdHandle + JMP @@checkHandle + +@@notAssignedError: + MOV EAX,102 + JMP @@errExit + +@@error: + MOV [EBX].TFileRec.Mode,fmClosed + CALL GetLastError +@@errExit: + CALL SetInOutRes + +@@exit: + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +function _ResetFile(var f: TFileRec; recSize: Longint): Integer; +var + m: Byte; +begin + m := FileMode and 3; + if m > 2 then m := 2; + Result := OpenFile(f, recSize, m); +end; + +function _RewritFile(var f: TFileRec; recSize: Longint): Integer; +begin + Result := OpenFile(f, recSize, 3); +end; + +procedure _Seek(var f: TFileRec; recNum: Cardinal); +{$IFDEF LINUX} +begin + if (f.Mode >= fmInput) and (f.Mode <= fmInOut) then + begin + if _lseek(f.Handle, f.RecSize * recNum, SEEK_SET) = -1 then + InOutError; + end + else + SetInOutRes(103); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm +// -> EAX Pointer to file variable +// EDX Record number + + MOV ECX,EAX + MOVZX EAX,[EAX].TFileRec.Mode // check whether file is open + SUB EAX,fmInput + CMP EAX,fmInOut-fmInput + JA @@fileNotOpen + +// SetFilePointer(f.Handle, recNum*f.RecSize, FILE_BEGIN + PUSH FILE_BEGIN // pass dwMoveMethod + MOV EAX,[ECX].TFileRec.RecSize + MUL EDX + PUSH 0 // pass lpDistanceToMoveHigh + PUSH EAX // pass lDistanceToMove + PUSH [ECX].TFileRec.Handle // pass hFile + CALL SetFilePointer // get current position + INC EAX + JZ InOutError + JMP @@exit + +@@fileNotOpen: + MOV EAX,103 + JMP SetInOutRes + +@@exit: +end; +{$ENDIF} + +function _SeekEof(var t: TTextRec): Boolean; +asm +// -> EAX Pointer to text record +// <- AL Boolean result + + PUSH EBX + MOV EBX,EAX +@@loop: + MOV EAX,EBX + CALL _ReadChar + CMP AL,' ' + JA @@endloop + CMP AH,cEOF + JE @@eof + JMP @@loop +@@eof: + MOV AL,1 + JMP @@exit + +@@endloop: + DEC [EBX].TTextRec.BufPos + XOR AL,AL +@@exit: + POP EBX +end; + +function _SeekEoln(var t: TTextRec): Boolean; +asm +// -> EAX Pointer to text record +// <- AL Boolean result + + PUSH EBX + MOV EBX,EAX +@@loop: + MOV EAX,EBX + CALL _ReadChar + CMP AL,' ' + JA @@falseExit + CMP AH,cEOF + JE @@eof + CMP AL,cLF + JE @@trueExit + CMP AL,cCR + JNE @@loop + +@@trueExit: + MOV AL,1 + JMP @@exitloop + +@@falseExit: + XOR AL,AL +@@exitloop: + DEC [EBX].TTextRec.BufPos + JMP @@exit + +@@eof: + MOV AL,1 +@@exit: + POP EBX +end; + +procedure _SetTextBuf(var t: TTextRec; p: Pointer; size: Longint); +begin + t.BufPtr := P; + t.BufSize := size; + t.BufPos := 0; + t.BufEnd := 0; +end; + +procedure _StrLong(val, width: Longint; s: PShortString); +{$IFDEF PUREPASCAL} +var + I: Integer; + sign: Longint; + a: array [0..19] of char; + P: PChar; +begin + sign := val; + val := Abs(val); + I := 0; + repeat + a[I] := Chr((val mod 10) + Ord('0')); + Inc(I); + val := val div 10; + until val = 0; + + if sign < 0 then + begin + a[I] := '-'; + Inc(I); + end; + + if width < I then + width := I; + if width > 255 then + width := 255; + s^[0] := Chr(width); + P := @S^[1]; + while width > I do + begin + P^ := ' '; + Inc(P); + Dec(width); + end; + repeat + Dec(I); + P^ := a[I]; + Inc(P); + until I <= 0; +end; +{$ELSE} +asm +{ PROCEDURE _StrLong( val: Longint; width: Longint; VAR s: ShortString ); + ->EAX Value + EDX Width + ECX Pointer to string } + + PUSH EBX { VAR i: Longint; } + PUSH ESI { VAR sign : Longint; } + PUSH EDI + PUSH EDX { store width on the stack } + SUB ESP,20 { VAR a: array [0..19] of Char; } + + MOV EDI,ECX + + MOV ESI,EAX { sign := val } + + CDQ { val := Abs(val); canned sequence } + XOR EAX,EDX + SUB EAX,EDX + + MOV ECX,10 + XOR EBX,EBX { i := 0; } + +@@repeat1: { repeat } + XOR EDX,EDX { a[i] := Chr( val MOD 10 + Ord('0') );} + + DIV ECX { val := val DIV 10; } + + ADD EDX,'0' + MOV [ESP+EBX],DL + INC EBX { i := i + 1; } + TEST EAX,EAX { until val = 0; } + JNZ @@repeat1 + + TEST ESI,ESI + JGE @@2 + MOV byte ptr [ESP+EBX],'-' + INC EBX +@@2: + MOV [EDI],BL { s^++ := Chr(i); } + INC EDI + + MOV ECX,[ESP+20] { spaceCnt := width - i; } + CMP ECX,255 + JLE @@3 + MOV ECX,255 +@@3: + SUB ECX,EBX + JLE @@repeat2 { for k := 1 to spaceCnt do s^++ := ' '; } + ADD [EDI-1],CL + MOV AL,' ' + REP STOSB + +@@repeat2: { repeat } + MOV AL,[ESP+EBX-1] { s^ := a[i-1]; } + MOV [EDI],AL + INC EDI { s := s + 1 } + DEC EBX { i := i - 1; } + JNZ @@repeat2 { until i = 0; } + + ADD ESP,20+4 + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +procedure _Str0Long(val: Longint; s: PShortString); +begin + _StrLong(val, 0, s); +end; + +procedure _Truncate(var f: TFileRec); +{$IFDEF LINUX} +begin + if (f.Mode and fmOutput) = fmOutput then // fmOutput or fmInOut + begin + if _ftruncate(f.Handle, _lseek(f.Handle, 0, SEEK_CUR)) = -1 then + InOutError; + end + else + SetInOutRes(103); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm +// -> EAX Pointer to text or file variable + + MOVZX EDX,[EAX].TFileRec.Mode // check whether file is open + SUB EDX,fmInput + CMP EDX,fmInOut-fmInput + JA @@fileNotOpen + + PUSH [EAX].TFileRec.Handle + CALL SetEndOfFile + DEC EAX + JZ @@exit + JMP InOutError + +@@fileNotOpen: + MOV EAX,103 + JMP SetInOutRes + +@@exit: +end; +{$ENDIF} + +function _ValLong(const s: String; var code: Integer): Longint; +{$IFDEF PUREPASCAL} +var + I: Integer; + Negative, Hex: Boolean; +begin + I := 1; + code := -1; + Result := 0; + Negative := False; + Hex := False; + while (I <= Length(s)) and (s[I] = ' ') do Inc(I); + if I > Length(s) then Exit; + case s[I] of + '$', + 'x', + 'X': begin + Hex := True; + Inc(I); + end; + '0': begin + Hex := (Length(s) > I) and (UpCase(s[I+1]) = 'X'); + if Hex then Inc(I,2); + end; + '-': begin + Negative := True; + Inc(I); + end; + '+': Inc(I); + end; + if Hex then + while I <= Length(s) do + begin + if Result > (High(Result) div 16) then + begin + code := I; + Exit; + end; + case s[I] of + '0'..'9': Result := Result * 16 + Ord(s[I]) - Ord('0'); + 'a'..'f': Result := Result * 16 + Ord(s[I]) - Ord('a') + 10; + 'A'..'F': Result := Result * 16 + Ord(s[I]) - Ord('A') + 10; + else + code := I; + Exit; + end; + end + else + while I <= Length(s) do + begin + if Result > (High(Result) div 10) then + begin + code := I; + Exit; + end; + Result := Result * 10 + Ord(s[I]) - Ord('0'); + Inc(I); + end; + if Negative then + Result := -Result; + code := 0; +end; +{$ELSE} +asm +{ FUNCTION _ValLong( s: AnsiString; VAR code: Integer ) : Longint; } +{ ->EAX Pointer to string } +{ EDX Pointer to code result } +{ <-EAX Result } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX + PUSH EAX { save for the error case } + + TEST EAX,EAX + JE @@empty + + XOR EAX,EAX + XOR EBX,EBX + MOV EDI,07FFFFFFFH / 10 { limit } + +@@blankLoop: + MOV BL,[ESI] + INC ESI + CMP BL,' ' + JE @@blankLoop + +@@endBlanks: + MOV CH,0 + CMP BL,'-' + JE @@minus + CMP BL,'+' + JE @@plus + + CMP BL,'$' + JE @@dollar + + CMP BL, 'x' + JE @@dollar + CMP BL, 'X' + JE @@dollar + CMP BL, '0' + JNE @@firstDigit + MOV BL, [ESI] + INC ESI + CMP BL, 'x' + JE @@dollar + CMP BL, 'X' + JE @@dollar + TEST BL, BL + JE @@endDigits + JMP @@digLoop + +@@firstDigit: + TEST BL,BL + JE @@error + +@@digLoop: + SUB BL,'0' + CMP BL,9 + JA @@error + CMP EAX,EDI { value > limit ? } + JA @@overFlow + LEA EAX,[EAX+EAX*4] + ADD EAX,EAX + ADD EAX,EBX { fortunately, we can't have a carry } + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JNE @@digLoop + +@@endDigits: + DEC CH + JE @@negate + TEST EAX,EAX + JGE @@successExit + JMP @@overFlow + +@@empty: + INC ESI + JMP @@error + +@@negate: + NEG EAX + JLE @@successExit + JS @@successExit { to handle 2**31 correctly, where the negate overflows } + +@@error: +@@overFlow: + POP EBX + SUB ESI,EBX + JMP @@exit + +@@minus: + INC CH +@@plus: + MOV BL,[ESI] + INC ESI + JMP @@firstDigit + +@@dollar: + MOV EDI,0FFFFFFFH + + MOV BL,[ESI] + INC ESI + TEST BL,BL + JZ @@empty + +@@hDigLoop: + CMP BL,'a' + JB @@upper + SUB BL,'a' - 'A' +@@upper: + SUB BL,'0' + CMP BL,9 + JBE @@digOk + SUB BL,'A' - '0' + CMP BL,5 + JA @@error + ADD BL,10 +@@digOk: + CMP EAX,EDI + JA @@overFlow + SHL EAX,4 + ADD EAX,EBX + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JNE @@hDigLoop + +@@successExit: + POP ECX { saved copy of string pointer } + XOR ESI,ESI { signal no error to caller } + +@@exit: + MOV [EDX],ESI + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +function _WriteRec(var f: TFileRec; buffer: Pointer): Pointer; +{$IFDEF LINUX} +var + Dummy: Integer; +begin + _BlockWrite(f, Buffer, 1, Dummy); + Result := @F; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm +// -> EAX Pointer to file variable +// EDX Pointer to buffer +// <- EAX Pointer to file variable + PUSH EBX + + MOV EBX,EAX + + MOVZX EAX,[EAX].TFileRec.Mode + SUB EAX,fmOutput + CMP EAX,fmInOut-fmOutput // File must be fmInOut or fmOutput + JA @@fileNotOpen + +// WriteFile(f.Handle, buffer, f.RecSize, @result, Nil); + + PUSH 0 // space for OS result + MOV EAX,ESP + + PUSH 0 // pass lpOverlapped + PUSH EAX // pass @result + PUSH [EBX].TFileRec.RecSize // pass nNumberOfBytesToRead + PUSH EDX // pass lpBuffer + PUSH [EBX].TFileRec.Handle // pass hFile + CALL WriteFile + POP EDX // pop result + DEC EAX // check EAX = TRUE + JNZ @@error + + CMP EDX,[EBX].TFileRec.RecSize // result = f.RecSize ? + JE @@exit + +@@writeError: + MOV EAX,101 + JMP @@errExit + +@@fileNotOpen: + MOV EAX,5 + JMP @@errExit + +@@error: + CALL GetLastError +@@errExit: + CALL SetInOutRes +@@exit: + MOV EAX,EBX + POP EBX +end; +{$ENDIF} + +// If the file is Output or ErrOutput std variable, try to open it +// Otherwise, runtime error. +function TryOpenForOutput(var t: TTextRec): Boolean; +begin + if (@t = @Output) or (@t = @ErrOutput) then + begin + t.Flags := tfCRLF * Byte(DefaultTextLineBreakStyle); + _RewritText(t); + end; + + Result := t.Mode = fmOutput; + if not Result then + SetInOutRes(105); +end; + +function _WriteBytes(var t: TTextRec; const b; cnt : Longint): Pointer; +{$IFDEF PUREPASCAL} +var + P: PChar; + RemainingBytes: Longint; + Temp: Integer; +begin + Result := @t; + if t.Mode <> fmOutput and not TryOpenForOutput(t) then Exit; + + P := t.BufPtr + t.BufPos; + RemainingBytes := t.BufSize - t.BufPos; + while RemainingBytes <= cnt do + begin + Inc(t.BufPos, RemainingBytes); + Dec(cnt, RemainingBytes); + Move(B, P^, RemainingBytes); + Temp := TTextIOFunc(t.InOutFunc)(t); + if Temp <> 0 then + begin + SetInOutRes(Temp); + Exit; + end; + P := t.BufPtr + t.BufPos; + RemainingBytes := t.BufSize - t.BufPos; + end; + Inc(t.BufPos, cnt); + Move(B, P^, cnt); +end; +{$ELSE} +asm +// -> EAX Pointer to file record +// EDX Pointer to buffer +// ECX Number of bytes to write +// <- EAX Pointer to file record + + PUSH ESI + PUSH EDI + + MOV ESI,EDX + + CMP [EAX].TTextRec.Mode,fmOutput + JE @@loop + PUSH EAX + PUSH EDX + PUSH ECX + CALL TryOpenForOutput + TEST AL,AL + POP ECX + POP EDX + POP EAX + JE @@exit + +@@loop: + MOV EDI,[EAX].TTextRec.BufPtr + ADD EDI,[EAX].TTextRec.BufPos + +// remainingBytes = t.bufSize - t.bufPos + + MOV EDX,[EAX].TTextRec.BufSize + SUB EDX,[EAX].TTextRec.BufPos + +// if (remainingBytes <= cnt) + + CMP EDX,ECX + JG @@1 + +// t.BufPos += remainingBytes, cnt -= remainingBytes + + ADD [EAX].TTextRec.BufPos,EDX + SUB ECX,EDX + +// copy remainingBytes, advancing ESI + + PUSH EAX + PUSH ECX + MOV ECX,EDX + REP MOVSB + + CALL [EAX].TTextRec.InOutFunc + TEST EAX,EAX + JNZ @@error + + POP ECX + POP EAX + JMP @@loop + +@@error: + CALL SetInOutRes + POP ECX + POP EAX + JMP @@exit +@@1: + ADD [EAX].TTextRec.BufPos,ECX + REP MOVSB + +@@exit: + POP EDI + POP ESI +end; +{$ENDIF} + +function _WriteSpaces(var t: TTextRec; cnt: Longint): Pointer; +{$IFDEF PUREPASCAL} +const + s64Spaces = ' '; +begin + Result := @t; + while cnt > 64 do + begin + _WriteBytes(t, s64Spaces, 64); + if InOutRes <> 0 then Exit; + Dec(cnt, 64); + end; + if cnt > 0 then + _WriteBytes(t, s64Spaces, cnt); +end; +{$ELSE} +const + spCnt = 64; +asm +// -> EAX Pointer to text record +// EDX Number of spaces (<= 0: None) + + MOV ECX,EDX +@@loop: +{$IFDEF PIC} + LEA EDX, [EBX] + offset @@spBuf +{$ELSE} + MOV EDX,offset @@spBuf +{$ENDIF} + + CMP ECX,spCnt + JLE @@1 + + SUB ECX,spCnt + PUSH EAX + PUSH ECX + MOV ECX,spCnt + CALL _WriteBytes + CALL SysInit.@GetTLS + CMP [EAX].InOutRes,0 + JNE @@error + POP ECX + POP EAX + JMP @@loop + +@@error: + POP ECX + POP EAX + JMP @@exit + +@@spBuf: // 64 spaces + DB ' '; +@@1: + TEST ECX,ECX + JG _WriteBytes +@@exit: +end; +{$ENDIF} + +function _Write0Char(var t: TTextRec; c: Char): Pointer; +{$IFDEF PUREPASCAL} +var + Temp: Integer; +begin + Result := @t; + if not TryOpenForOutput(t) then Exit; + + if t.BufPos >= t.BufSize then + begin + Temp := TTextIOFunc(t.InOutFunc)(t); + if Temp <> 0 then + begin + SetInOutRes(Temp); + Exit; + end; + end; + + t.BufPtr[t.BufPos] := c; + Inc(t.BufPos); +end; +{$ELSE} +asm +// -> EAX Pointer to text record +// DL Character + + CMP [EAX].TTextRec.Mode,fmOutput + JE @@loop + PUSH EAX + PUSH EDX + CALL TryOpenForOutput + TEST AL,AL + POP EDX + POP EAX + JNE @@loop + JMP @@exit + +@@flush: + PUSH EAX + PUSH EDX + CALL [EAX].TTextRec.InOutFunc + TEST EAX,EAX + JNZ @@error + POP EDX + POP EAX + JMP @@loop + +@@error: + CALL SetInOutRes + POP EDX + POP EAX + JMP @@exit + +@@loop: + MOV ECX,[EAX].TTextRec.BufPos + CMP ECX,[EAX].TTextRec.BufSize + JGE @@flush + + ADD ECX,[EAX].TTextRec.BufPtr + MOV [ECX],DL + + INC [EAX].TTextRec.BufPos +@@exit: +end; +{$ENDIF} + +function _WriteChar(var t: TTextRec; c: Char; width: Integer): Pointer; +begin + _WriteSpaces(t, width-1); + Result := _WriteBytes(t, c, 1); +end; + +function _WriteBool(var t: TTextRec; val: Boolean; width: Longint): Pointer; +const + BoolStrs: array [Boolean] of ShortString = ('FALSE', 'TRUE'); +begin + Result := _WriteString(t, BoolStrs[val], width); +end; + +function _Write0Bool(var t: TTextRec; val: Boolean): Pointer; +begin + Result := _WriteBool(t, val, 0); +end; + +function _WriteLong(var t: TTextRec; val, width: Longint): Pointer; +var + S: string[31]; +begin + Str(val:0, S); + Result := _WriteString(t, S, width); +end; + +function _Write0Long(var t: TTextRec; val: Longint): Pointer; +begin + Result := _WriteLong(t, val, 0); +end; + +function _Write0String(var t: TTextRec; const s: ShortString): Pointer; +begin + Result := _WriteBytes(t, S[1], Byte(S[0])); +end; + +function _WriteString(var t: TTextRec; const s: ShortString; width: Longint): Pointer; +begin + _WriteSpaces(t, Width - Byte(S[0])); + Result := _WriteBytes(t, S[1], Byte(S[0])); +end; + +function _Write0CString(var t: TTextRec; s: PChar): Pointer; +begin + Result := _WriteCString(t, s, 0); +end; + +function _WriteCString(var t: TTextRec; s: PChar; width: Longint): Pointer; +var + len: Longint; +begin + len := _strlen(s); + _WriteSpaces(t, width - len); + Result := _WriteBytes(t, s^, len); +end; + +procedure _Write2Ext; +asm +{ PROCEDURE _Write2Ext( VAR t: Text; val: Extended; width, prec: Longint); + ->EAX Pointer to file record + [ESP+4] Extended value + EDX Field width + ECX precision (<0: scientific, >= 0: fixed point) } + + FLD tbyte ptr [ESP+4] { load value } + SUB ESP,256 { VAR s: String; } + + PUSH EAX + PUSH EDX + +{ Str( val, width, prec, s ); } + + SUB ESP,12 + FSTP tbyte ptr [ESP] { pass value } + MOV EAX,EDX { pass field width } + MOV EDX,ECX { pass precision } + LEA ECX,[ESP+8+12] { pass destination string } + CALL _Str2Ext + +{ Write( t, s, width ); } + + POP ECX { pass width } + POP EAX { pass text } + MOV EDX,ESP { pass string } + CALL _WriteString + + ADD ESP,256 + RET 12 +end; + +procedure _Write1Ext; +asm +{ PROCEDURE _Write1Ext( VAR t: Text; val: Extended; width: Longint); + -> EAX Pointer to file record + [ESP+4] Extended value + EDX Field width } + + OR ECX,-1 + JMP _Write2Ext +end; + +procedure _Write0Ext; +asm +{ PROCEDURE _Write0Ext( VAR t: Text; val: Extended); + ->EAX Pointer to file record + [ESP+4] Extended value } + + MOV EDX,23 { field width } + OR ECX,-1 + JMP _Write2Ext +end; + +function _WriteLn(var t: TTextRec): Pointer; +var + Buf: array [0..1] of Char; +begin + if (t.flags and tfCRLF) <> 0 then + begin + Buf[0] := #13; + Buf[1] := #10; + Result := _WriteBytes(t, Buf, 2); + end + else + begin + Buf[0] := #10; + Result := _WriteBytes(t, Buf, 1); + end; + _Flush(t); +end; + +procedure __CToPasStr(Dest: PShortString; const Source: PChar); +begin + __CLenToPasStr(Dest, Source, 255); +end; + +procedure __CLenToPasStr(Dest: PShortString; const Source: PChar; MaxLen: Integer); +{$IFDEF PUREPASCAL} +var + I: Integer; +begin + I := 0; + if MaxLen > 255 then MaxLen := 255; + while (Source[I] <> #0) and (I <= MaxLen) do + begin + Dest^[I+1] := Source[I]; + Inc(I); + end; + if I > 0 then Dec(I); + Byte(Dest^[0]) := I; +end; +{$ELSE} +asm +{ ->EAX Pointer to destination } +{ EDX Pointer to source } +{ ECX cnt } + + PUSH EBX + PUSH EAX { save destination } + + CMP ECX,255 + JBE @@loop + MOV ECX,255 +@@loop: + MOV BL,[EDX] { ch = *src++; } + INC EDX + TEST BL,BL { if (ch == 0) break } + JE @@endLoop + INC EAX { *++dest = ch; } + MOV [EAX],BL + DEC ECX { while (--cnt != 0) } + JNZ @@loop + +@@endLoop: + POP EDX + SUB EAX,EDX + MOV [EDX],AL + POP EBX +end; +{$ENDIF} + +procedure __ArrayToPasStr(Dest: PShortString; const Source: PChar; Len: Integer); +begin + if Len > 255 then Len := 255; + Byte(Dest^[0]) := Len; + Move(Source^, Dest^[1], Len); +end; + +procedure __PasToCStr(const Source: PShortString; const Dest: PChar); +begin + Move(Source^[1], Dest^, Byte(Source^[0])); + Dest[Byte(Source^[0])] := #0; +end; + +procedure _SetElem; +asm + { PROCEDURE _SetElem( VAR d: SET; elem, size: Byte); } + { EAX = dest address } + { DL = element number } + { CL = size of set } + + PUSH EBX + PUSH EDI + + MOV EDI,EAX + + XOR EBX,EBX { zero extend set size into ebx } + MOV BL,CL + MOV ECX,EBX { and use it for the fill } + + XOR EAX,EAX { for zero fill } + REP STOSB + + SUB EDI,EBX { point edi at beginning of set again } + + INC EAX { eax is still zero - make it 1 } + MOV CL,DL + ROL AL,CL { generate a mask } + SHR ECX,3 { generate the index } + CMP ECX,EBX { if index >= siz then exit } + JAE @@exit + OR [EDI+ECX],AL{ set bit } + +@@exit: + POP EDI + POP EBX +end; + +procedure _SetRange; +asm +{ PROCEDURE _SetRange( lo, hi, size: Byte; VAR d: SET ); } +{ ->AL low limit of range } +{ DL high limit of range } +{ ECX Pointer to set } +{ AH size of set } + + PUSH EBX + PUSH ESI + PUSH EDI + + XOR EBX,EBX { EBX = set size } + MOV BL,AH + MOVZX ESI,AL { ESI = low zero extended } + MOVZX EDX,DL { EDX = high zero extended } + MOV EDI,ECX + +{ clear the set } + + MOV ECX,EBX + XOR EAX,EAX + REP STOSB + +{ prepare for setting the bits } + + SUB EDI,EBX { point EDI at start of set } + SHL EBX,3 { EBX = highest bit in set + 1 } + CMP EDX,EBX + JB @@inrange + LEA EDX,[EBX-1] { ECX = highest bit in set } + +@@inrange: + CMP ESI,EDX { if lo > hi then exit; } + JA @@exit + + DEC EAX { loMask = 0xff << (lo & 7) } + MOV ECX,ESI + AND CL,07H + SHL AL,CL + + SHR ESI,3 { loIndex = lo >> 3; } + + MOV CL,DL { hiMask = 0xff >> (7 - (hi & 7)); } + NOT CL + AND CL,07 + SHR AH,CL + + SHR EDX,3 { hiIndex = hi >> 3; } + + ADD EDI,ESI { point EDI to set[loIndex] } + MOV ECX,EDX + SUB ECX,ESI { if ((inxDiff = (hiIndex - loIndex)) == 0) } + JNE @@else + + AND AL,AH { set[loIndex] = hiMask & loMask; } + MOV [EDI],AL + JMP @@exit + +@@else: + STOSB { set[loIndex++] = loMask; } + DEC ECX + MOV AL,0FFH { while (loIndex < hiIndex) } + REP STOSB { set[loIndex++] = 0xff; } + MOV [EDI],AH { set[hiIndex] = hiMask; } + +@@exit: + POP EDI + POP ESI + POP EBX +end; + +procedure _SetEq; +asm +{ FUNCTION _SetEq( CONST l, r: Set; size: Byte): ConditionCode; } +{ EAX = left operand } +{ EDX = right operand } +{ CL = size of set } + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + AND ECX,0FFH + REP CMPSB + + POP EDI + POP ESI +end; + +procedure _SetLe; +asm +{ FUNCTION _SetLe( CONST l, r: Set; size: Byte): ConditionCode; } +{ EAX = left operand } +{ EDX = right operand } +{ CL = size of set (>0 && <= 32) } + +@@loop: + MOV CH,[EDX] + NOT CH + AND CH,[EAX] + JNE @@exit + INC EDX + INC EAX + DEC CL + JNZ @@loop +@@exit: +end; + +procedure _SetIntersect; +asm +{ PROCEDURE _SetIntersect( VAR dest: Set; CONST src: Set; size: Byte);} +{ EAX = destination operand } +{ EDX = source operand } +{ CL = size of set (0 < size <= 32) } + +@@loop: + MOV CH,[EDX] + INC EDX + AND [EAX],CH + INC EAX + DEC CL + JNZ @@loop +end; + +procedure _SetIntersect3; +asm +{ PROCEDURE _SetIntersect3( VAR dest: Set; CONST src: Set; size: Longint; src2: Set);} +{ EAX = destination operand } +{ EDX = source operand } +{ ECX = size of set (0 < size <= 32) } +{ [ESP+4] = 2nd source operand } + + PUSH EBX + PUSH ESI + MOV ESI,[ESP+8+4] +@@loop: + MOV BL,[EDX+ECX-1] + AND BL,[ESI+ECX-1] + MOV [EAX+ECX-1],BL + DEC ECX + JNZ @@loop + + POP ESI + POP EBX +end; + +procedure _SetUnion; +asm +{ PROCEDURE _SetUnion( VAR dest: Set; CONST src: Set; size: Byte); } +{ EAX = destination operand } +{ EDX = source operand } +{ CL = size of set (0 < size <= 32) } + +@@loop: + MOV CH,[EDX] + INC EDX + OR [EAX],CH + INC EAX + DEC CL + JNZ @@loop +end; + +procedure _SetUnion3; +asm +{ PROCEDURE _SetUnion3( VAR dest: Set; CONST src: Set; size: Longint; src2: Set);} +{ EAX = destination operand } +{ EDX = source operand } +{ ECX = size of set (0 < size <= 32) } +{ [ESP+4] = 2nd source operand } + + PUSH EBX + PUSH ESI + MOV ESI,[ESP+8+4] +@@loop: + MOV BL,[EDX+ECX-1] + OR BL,[ESI+ECX-1] + MOV [EAX+ECX-1],BL + DEC ECX + JNZ @@loop + + POP ESI + POP EBX +end; + +procedure _SetSub; +asm +{ PROCEDURE _SetSub( VAR dest: Set; CONST src: Set; size: Byte); } +{ EAX = destination operand } +{ EDX = source operand } +{ CL = size of set (0 < size <= 32) } + +@@loop: + MOV CH,[EDX] + NOT CH + INC EDX + AND [EAX],CH + INC EAX + DEC CL + JNZ @@loop +end; + +procedure _SetSub3; +asm +{ PROCEDURE _SetSub3( VAR dest: Set; CONST src: Set; size: Longint; src2: Set);} +{ EAX = destination operand } +{ EDX = source operand } +{ ECX = size of set (0 < size <= 32) } +{ [ESP+4] = 2nd source operand } + + PUSH EBX + PUSH ESI + MOV ESI,[ESP+8+4] +@@loop: + MOV BL,[ESI+ECX-1] + NOT BL + AND BL,[EDX+ECX-1] + MOV [EAX+ECX-1],BL + DEC ECX + JNZ @@loop + + POP ESI + POP EBX +end; + +procedure _SetExpand; +asm +{ PROCEDURE _SetExpand( CONST src: Set; VAR dest: Set; lo, hi: Byte); } +{ ->EAX Pointer to source (packed set) } +{ EDX Pointer to destination (expanded set) } +{ CH high byte of source } +{ CL low byte of source } + +{ algorithm: } +{ clear low bytes } +{ copy high-low+1 bytes } +{ clear 31-high bytes } + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + MOV EDX,ECX { save low, high in dl, dh } + XOR ECX,ECX + XOR EAX,EAX + + MOV CL,DL { clear low bytes } + REP STOSB + + MOV CL,DH { copy high - low bytes } + SUB CL,DL + REP MOVSB + + MOV CL,32 { copy 32 - high bytes } + SUB CL,DH + REP STOSB + + POP EDI + POP ESI +end; + +procedure _EmitDigits; +const + tenE17: Double = 1e17; + tenE18: Double = 1e18; +asm +// -> FST(0) Value, 0 <= value < 10.0 +// EAX Count of digits to generate +// EDX Pointer to digit buffer + + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX +{$ELSE} + XOR EBX,EBX +{$ENDIF} + PUSH EDI + MOV EDI,EDX + MOV ECX,EAX + + SUB ESP,10 // VAR bcdBuf: array [0..9] of Byte + MOV byte ptr [EDI],'0' // digBuf[0] := '0'// + FMUL qword ptr [EBX] + offset tenE17 // val := Round(val*1e17); + FRNDINT + + FCOM qword ptr [EBX] + offset tenE18 // if val >= 1e18 then + FSTSW AX + SAHF + JB @@1 + + FSUB qword ptr [EBX] + offset tenE18 // val := val - 1e18; + MOV byte ptr [EDI],'1' // digBuf[0] := '1'; +@@1: + FBSTP tbyte ptr [ESP] // store packed bcd digits in bcdBuf + + MOV EDX,8 + INC EDI + +@@2: + WAIT + MOV AL,[ESP+EDX] // unpack 18 bcd digits in 9 bytes + MOV AH,AL // into 9 words = 18 bytes + SHR AL,4 + AND AH,0FH + ADD AX,'00' + STOSW + DEC EDX + JNS @@2 + + SUB ECX,18 // we need at least digCnt digits + JL @@3 // we have generated 18 + + MOV AL,'0' // if this is not enough, append zeroes + REP STOSB + JMP @@4 // in this case, we don't need to round + +@@3: + ADD EDI,ECX // point EDI to the round digit + CMP byte ptr [EDI],'5' + JL @@4 +@@5: + DEC EDI + INC byte ptr [EDI] + CMP byte ptr [EDI],'9' + JLE @@4 + MOV byte ptr [EDI],'0' + JMP @@5 + +@@4: + ADD ESP,10 + POP EDI + POP EBX +end; + +procedure _ScaleExt; +asm +// -> FST(0) Value +// <- EAX exponent (base 10) +// FST(0) Value / 10**eax +// PIC safe - uses EBX, but only call is to _POW10, which fixes up EBX itself + + PUSH EBX + SUB ESP,12 + + XOR EBX,EBX + +@@normLoop: // loop necessary for denormals + + FLD ST(0) + FSTP tbyte ptr [ESP] + MOV AX,[ESP+8] + TEST AX,AX + JE @@testZero +@@cont: + SUB AX,3FFFH + MOV DX,4D10H // log10(2) * 2**16 + IMUL DX + MOVSX EAX,DX // exp10 = exp2 * log10(2) + NEG EAX + JE @@exit + SUB EBX,EAX + CALL _Pow10 + JMP @@normLoop + +@@testZero: + CMP dword ptr [ESP+4],0 + JNE @@cont + CMP dword ptr [ESP+0],0 + JNE @@cont + +@@exit: + ADD ESP,12 + MOV EAX,EBX + POP EBX +end; + +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 ); +const + MAXDIGS = 256; +asm +// -> [ESP+4] Extended value +// EAX Width +// EDX Precision +// ECX Pointer to string + + FLD tbyte ptr [ESP+4] + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV ESI,EDX + PUSH ECX // save string pointer + SUB ESP,MAXDIGS // VAR digBuf: array [0..MAXDIGS-1] of Char + +// limit width to 255 + + CMP EBX,255 // if width > 255 then width := 255; + JLE @@1 + MOV EBX,255 +@@1: + +// save sign bit in bit 0 of EDI, take absolute value of val, check for +// Nan and infinity. + + FLD ST(0) + FSTP tbyte ptr [ESP] + XOR EAX,EAX + MOV AX,word ptr [ESP+8] + MOV EDI,EAX + SHR EDI,15 + AND AX,7FFFH + CMP AX,7FFFH + JE @@nanInf + FABS + +// if precision < 0 then do scientific else do fixed; + + TEST ESI,ESI + JGE @@fixed + +// the following call finds a decimal exponent and a reduced +// mantissa such that val = mant * 10**exp + + CALL _ScaleExt // val is FST(0), exp is EAX + +// for scientific notation, we have width - 8 significant digits +// however, we can not have less than 2 or more than 18 digits. + +@@scientific: + + MOV ESI,EBX // digCnt := width - 8; + SUB ESI,8 + CMP ESI,2 // if digCnt < 2 then digCnt := 2 + JGE @@2 + MOV ESI,2 + JMP @@3 +@@2: + CMP ESI,18 // else if digCnt > 18 then digCnt := 18; + JLE @@3 + MOV ESI,18 +@@3: + +// _EmitDigits( val, digCnt, digBuf ) + + MOV EDX,ESP // pass digBuf + PUSH EAX // save exponent + MOV EAX,ESI // pass digCnt + CALL _EmitDigits // convert val to ASCII + + MOV EDX,EDI // save sign in EDX + MOV EDI,[ESP+MAXDIGS+4] // load result string pointer + + MOV [EDI],BL // length of result string := width + INC EDI + + MOV AL,' ' // prepare for leading blanks and sign + + MOV ECX,EBX // blankCnt := width - digCnt - 8 + SUB ECX,ESI + SUB ECX,8 + JLE @@4 + + REP STOSB // emit blankCnt blanks +@@4: + SUB [EDI-1],CL // if blankCnt < 0, adjust length + + TEST DL,DL // emit the sign (' ' or '-') + JE @@5 + MOV AL,'-' +@@5: + STOSB + + POP EAX + MOV ECX,ESI // emit digCnt digits + MOV ESI,ESP // point ESI to digBuf + + CMP byte ptr [ESI],'0' + JE @@5a // if rounding overflowed, adjust exponent and ESI + INC EAX + DEC ESI +@@5a: + INC ESI + + MOVSB // emit one digit + MOV byte ptr [EDI],'.' // emit dot + INC EDI // adjust dest pointer + DEC ECX // adjust count + + REP MOVSB + + MOV byte ptr [EDI],'E' + + MOV CL,'+' // emit sign of exponent ('+' or '-') + TEST EAX,EAX + JGE @@6 + MOV CL,'-' + NEG EAX +@@6: + MOV [EDI+1],CL + + XOR EDX,EDX // emit exponent + MOV CX,10 + DIV CX + ADD DL,'0' + MOV [EDI+5],DL + + XOR EDX,EDX + DIV CX + ADD DL,'0' + MOV [EDI+4],DL + + XOR EDX,EDX + DIV CX + ADD DL,'0' + MOV [EDI+3],DL + + ADD AL,'0' + MOV [EDI+2],AL + + JMP @@exit + +@@fixed: + +// FST(0) = value >= 0.0 +// EBX = width +// ESI = precision +// EDI = sign + + CMP ESI,MAXDIGS-40 // else if precision > MAXDIGS-40 then precision := MAXDIGS-40; + JLE @@6a + MOV ESI,MAXDIGS-40 +@@6a: +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + FCOM qword ptr [EAX] + offset Ten + POP EAX +{$ELSE} + FCOM qword ptr ten +{$ENDIF} + FSTSW AX + SAHF + MOV EAX,0 + JB @@7 + + CALL _ScaleExt // val is FST(0), exp is EAX + + CMP EAX,35 // if val is too large, use scientific + JG @@scientific + +@@7: +// FST(0) = scaled value, 0.0 <= value < 10.0 +// EAX = exponent, 0 <= exponent + +// intDigCnt := exponent + 1; + + INC EAX + +// _EmitDigits( value, intDigCnt + precision, digBuf ); + + MOV EDX,ESP + PUSH EAX + ADD EAX,ESI + CALL _EmitDigits + POP EAX + +// Now we need to check whether rounding to the right number of +// digits overflowed, and if so, adjust things accordingly + + MOV EDX,ESI // put precision in EDX + MOV ESI,ESP // point EDI to digBuf + CMP byte ptr [ESI],'0' + JE @@8 + INC EAX + DEC ESI +@@8: + INC ESI + + MOV ECX,EAX // numWidth := sign + intDigCnt; + ADD ECX,EDI + + TEST EDX,EDX // if precision > 0 then + JE @@9 + INC ECX // numWidth := numWidth + 1 + precision + ADD ECX,EDX + + CMP EBX,ECX // if width <= numWidth + JG @@9 + MOV EBX,ECX // width := numWidth +@@9: + PUSH EAX + PUSH EDI + + MOV EDI,[ESP+MAXDIGS+2*4] // point EDI to dest string + + MOV [EDI],BL // store final length in dest string + INC EDI + + SUB EBX,ECX // width := width - numWidth + MOV ECX,EBX + JLE @@10 + + MOV AL,' ' // emit width blanks + REP STOSB +@@10: + SUB [EDI-1],CL // if blankCnt < 0, adjust length + POP EAX + POP ECX + + TEST EAX,EAX + JE @@11 + + MOV byte ptr [EDI],'-' + INC EDI + +@@11: + REP MOVSB // copy intDigCnt digits + + TEST EDX,EDX // if precision > 0 then + JE @@12 + + MOV byte ptr [EDI],'.' // emit '.' + INC EDI + MOV ECX,EDX // emit precision digits + REP MOVSB + +@@12: + +@@exit: + ADD ESP,MAXDIGS + POP ECX + POP EDI + POP ESI + POP EBX + RET 12 + +@@nanInf: +// here: EBX = width, ECX = string pointer, EDI = sign, [ESP] = value + +{$IFDEF PIC} + CALL GetGOT +{$ELSE} + XOR EAX,EAX +{$ENDIF} + FSTP ST(0) + CMP dword ptr [ESP+4],80000000H + LEA ESI,[EAX] + offset nanStr + JNE @@13 + DEC EDI + LEA ESI,[EAX] + offset plusInfStr + JNZ @@13 + LEA ESI,[EAX] + offset minInfStr +@@13: + MOV EDI,ECX + MOV ECX,EBX + MOV [EDI],CL + INC EDI + SUB CL,[ESI] + JBE @@14 + MOV AL,' ' + REP STOSB +@@14: + SUB [EDI-1],CL + MOV CL,[ESI] + INC ESI + REP MOVSB + + JMP @@exit +end; + +procedure _Str0Ext; +asm +// -> [ESP+4] Extended value +// EAX Pointer to string + + MOV ECX,EAX // pass string + MOV EAX,23 // pass default field width + OR EDX,-1 // pass precision -1 + JMP _Str2Ext +end; + +procedure _Str1Ext;//( val: Extended; width: Longint; var s: String ); +asm +// -> [ESP+4] Extended value +// EAX Field width +// EDX Pointer to string + + MOV ECX,EDX + OR EDX,-1 // pass precision -1 + JMP _Str2Ext +end; + +//function _ValExt( s: AnsiString; VAR code: Integer ) : Extended; +procedure _ValExt; +asm +// -> EAX Pointer to string +// EDX Pointer to code result +// <- FST(0) Result + + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX +{$ELSE} + XOR EBX,EBX +{$ENDIF} + PUSH ESI + PUSH EDI + + PUSH EBX // SaveGOT = ESP+8 + MOV ESI,EAX + PUSH EAX // save for the error case + + FLDZ + XOR EAX,EAX + XOR EBX,EBX + XOR EDI,EDI + + PUSH EBX // temp to get digs to fpu + + TEST ESI,ESI + JE @@empty + +@@blankLoop: + MOV BL,[ESI] + INC ESI + CMP BL,' ' + JE @@blankLoop + +@@endBlanks: + MOV CH,0 + CMP BL,'-' + JE @@minus + CMP BL,'+' + JE @@plus + JMP @@firstDigit + +@@minus: + INC CH +@@plus: + MOV BL,[ESI] + INC ESI + +@@firstDigit: + TEST BL,BL + JE @@error + + MOV EDI,[ESP+8] // SaveGOT + +@@digLoop: + SUB BL,'0' + CMP BL,9 + JA @@dotExp + FMUL qword ptr [EDI] + offset Ten + MOV dword ptr [ESP],EBX + FIADD dword ptr [ESP] + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JNE @@digLoop + JMP @@prefinish + +@@dotExp: + CMP BL,'.' - '0' + JNE @@exp + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JE @@prefinish + +// EDI = SaveGot +@@fracDigLoop: + SUB BL,'0' + CMP BL,9 + JA @@exp + FMUL qword ptr [EDI] + offset Ten + MOV dword ptr [ESP],EBX + FIADD dword ptr [ESP] + DEC EAX + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JNE @@fracDigLoop + +@@prefinish: + XOR EDI,EDI + JMP @@finish + +@@exp: + CMP BL,'E' - '0' + JE @@foundExp + CMP BL,'e' - '0' + JNE @@error +@@foundExp: + MOV BL,[ESI] + INC ESI + MOV AH,0 + CMP BL,'-' + JE @@minusExp + CMP BL,'+' + JE @@plusExp + JMP @@firstExpDigit +@@minusExp: + INC AH +@@plusExp: + MOV BL,[ESI] + INC ESI +@@firstExpDigit: + SUB BL,'0' + CMP BL,9 + JA @@error + MOV EDI,EBX + MOV BL,[ESI] + INC ESI + TEST BL,BL + JZ @@endExp +@@expDigLoop: + SUB BL,'0' + CMP BL,9 + JA @@error + LEA EDI,[EDI+EDI*4] + ADD EDI,EDI + ADD EDI,EBX + MOV BL,[ESI] + INC ESI + TEST BL,BL + JNZ @@expDigLoop +@@endExp: + DEC AH + JNZ @@expPositive + NEG EDI +@@expPositive: + MOVSX EAX,AL + +@@finish: + ADD EAX,EDI + PUSH EDX + PUSH ECX + CALL _Pow10 + POP ECX + POP EDX + + DEC CH + JE @@negate + +@@successExit: + + ADD ESP,12 // pop temp and saved copy of string pointer + + XOR ESI,ESI // signal no error to caller + +@@exit: + MOV [EDX],ESI + + POP EDI + POP ESI + POP EBX + RET + +@@negate: + FCHS + JMP @@successExit + +@@empty: + INC ESI + +@@error: + POP EAX + POP EBX + SUB ESI,EBX + ADD ESP,4 + JMP @@exit +end; + +procedure FPower10; +asm + JMP _Pow10 +end; + +//function _Pow10(val: Extended; Power: Integer): Extended; +procedure _Pow10; +asm +// -> FST(0) val +// -> EAX Power +// <- FST(0) val * 10**Power + +// This routine generates 10**power with no more than two +// floating point multiplications. Up to 10**31, no multiplications +// are needed. + + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX +{$ELSE} + XOR EBX,EBX +{$ENDIF} + TEST EAX,EAX + JL @@neg + JE @@exit + CMP EAX,5120 + JGE @@inf + MOV EDX,EAX + AND EDX,01FH + LEA EDX,[EDX+EDX*4] + FLD tbyte ptr @@tab0[EBX+EDX*2] + + FMULP + + SHR EAX,5 + JE @@exit + + MOV EDX,EAX + AND EDX,0FH + JE @@skip2ndMul + LEA EDX,[EDX+EDX*4] + FLD tbyte ptr @@tab1-10[EBX+EDX*2] + FMULP + +@@skip2ndMul: + + SHR EAX,4 + JE @@exit + LEA EAX,[EAX+EAX*4] + FLD tbyte ptr @@tab2-10[EBX+EAX*2] + FMULP + JMP @@exit + +@@neg: + NEG EAX + CMP EAX,5120 + JGE @@zero + MOV EDX,EAX + AND EDX,01FH + LEA EDX,[EDX+EDX*4] + FLD tbyte ptr @@tab0[EBX+EDX*2] + FDIVP + + SHR EAX,5 + JE @@exit + + MOV EDX,EAX + AND EDX,0FH + JE @@skip2ndDiv + LEA EDX,[EDX+EDX*4] + FLD tbyte ptr @@tab1-10[EBX+EDX*2] + FDIVP + +@@skip2ndDiv: + + SHR EAX,4 + JE @@exit + LEA EAX,[EAX+EAX*4] + FLD tbyte ptr @@tab2-10[EBX+EAX*2] + FDIVP + + JMP @@exit + +@@inf: + FLD tbyte ptr @@infval[EBX] + JMP @@exit + +@@zero: + FLDZ + +@@exit: + POP EBX + RET + +@@infval: DW $0000,$0000,$0000,$8000,$7FFF +@@tab0: DW $0000,$0000,$0000,$8000,$3FFF // 10**0 + DW $0000,$0000,$0000,$A000,$4002 // 10**1 + DW $0000,$0000,$0000,$C800,$4005 // 10**2 + DW $0000,$0000,$0000,$FA00,$4008 // 10**3 + DW $0000,$0000,$0000,$9C40,$400C // 10**4 + DW $0000,$0000,$0000,$C350,$400F // 10**5 + DW $0000,$0000,$0000,$F424,$4012 // 10**6 + DW $0000,$0000,$8000,$9896,$4016 // 10**7 + DW $0000,$0000,$2000,$BEBC,$4019 // 10**8 + DW $0000,$0000,$2800,$EE6B,$401C // 10**9 + DW $0000,$0000,$F900,$9502,$4020 // 10**10 + DW $0000,$0000,$B740,$BA43,$4023 // 10**11 + DW $0000,$0000,$A510,$E8D4,$4026 // 10**12 + DW $0000,$0000,$E72A,$9184,$402A // 10**13 + DW $0000,$8000,$20F4,$B5E6,$402D // 10**14 + DW $0000,$A000,$A931,$E35F,$4030 // 10**15 + DW $0000,$0400,$C9BF,$8E1B,$4034 // 10**16 + DW $0000,$C500,$BC2E,$B1A2,$4037 // 10**17 + DW $0000,$7640,$6B3A,$DE0B,$403A // 10**18 + DW $0000,$89E8,$2304,$8AC7,$403E // 10**19 + DW $0000,$AC62,$EBC5,$AD78,$4041 // 10**20 + DW $8000,$177A,$26B7,$D8D7,$4044 // 10**21 + DW $9000,$6EAC,$7832,$8786,$4048 // 10**22 + DW $B400,$0A57,$163F,$A968,$404B // 10**23 + DW $A100,$CCED,$1BCE,$D3C2,$404E // 10**24 + DW $84A0,$4014,$5161,$8459,$4052 // 10**25 + DW $A5C8,$9019,$A5B9,$A56F,$4055 // 10**26 + DW $0F3A,$F420,$8F27,$CECB,$4058 // 10**27 + DW $0984,$F894,$3978,$813F,$405C // 10**28 + DW $0BE5,$36B9,$07D7,$A18F,$405F // 10**29 + DW $4EDF,$0467,$C9CD,$C9F2,$4062 // 10**30 + DW $2296,$4581,$7C40,$FC6F,$4065 // 10**31 + +@@tab1: DW $B59E,$2B70,$ADA8,$9DC5,$4069 // 10**32 + DW $A6D5,$FFCF,$1F49,$C278,$40D3 // 10**64 + DW $14A3,$C59B,$AB16,$EFB3,$413D // 10**96 + DW $8CE0,$80E9,$47C9,$93BA,$41A8 // 10**128 + DW $17AA,$7FE6,$A12B,$B616,$4212 // 10**160 + DW $556B,$3927,$F78D,$E070,$427C // 10**192 + DW $C930,$E33C,$96FF,$8A52,$42E7 // 10**224 + DW $DE8E,$9DF9,$EBFB,$AA7E,$4351 // 10**256 + DW $2F8C,$5C6A,$FC19,$D226,$43BB // 10**288 + DW $E376,$F2CC,$2F29,$8184,$4426 // 10**320 + DW $0AD2,$DB90,$2700,$9FA4,$4490 // 10**352 + DW $AA17,$AEF8,$E310,$C4C5,$44FA // 10**384 + DW $9C59,$E9B0,$9C07,$F28A,$4564 // 10**416 + DW $F3D4,$EBF7,$4AE1,$957A,$45CF // 10**448 + DW $A262,$0795,$D8DC,$B83E,$4639 // 10**480 + +@@tab2: DW $91C7,$A60E,$A0AE,$E319,$46A3 // 10**512 + DW $0C17,$8175,$7586,$C976,$4D48 // 10**1024 + DW $A7E4,$3993,$353B,$B2B8,$53ED // 10**1536 + DW $5DE5,$C53D,$3B5D,$9E8B,$5A92 // 10**2048 + DW $F0A6,$20A1,$54C0,$8CA5,$6137 // 10**2560 + DW $5A8B,$D88B,$5D25,$F989,$67DB // 10**3072 + DW $F3F8,$BF27,$C8A2,$DD5D,$6E80 // 10**3584 + DW $979B,$8A20,$5202,$C460,$7525 // 10**4096 + DW $59F0,$6ED5,$1162,$AE35,$7BCA // 10**4608 +end; + +const + RealBias = 129; + ExtBias = $3FFF; + +procedure _Real2Ext;//( val : Real ) : Extended; +asm +// -> EAX Pointer to value +// <- FST(0) Result + +// the REAL data type has the following format: +// 8 bit exponent (bias 129), 39 bit fraction, 1 bit sign + + MOV DH,[EAX+5] // isolate the sign bit + AND DH,80H + MOV DL,[EAX] // fetch exponent + TEST DL,DL // exponent zero means number is zero + JE @@zero + + ADD DX,ExtBias-RealBias // adjust exponent bias + + PUSH EDX // the exponent is at the highest address + + MOV EDX,[EAX+2] // load high fraction part, set hidden bit + OR EDX,80000000H + PUSH EDX // push high fraction part + + MOV DL,[EAX+1] // load remaining low byte of fraction + SHL EDX,24 // clear low 24 bits + PUSH EDX + + FLD tbyte ptr [ESP] // pop result onto chip + ADD ESP,12 + + RET + +@@zero: + FLDZ + RET +end; + +procedure _Ext2Real;//( val : Extended ) : Real; +asm +// -> FST(0) Value +// EAX Pointer to result + + PUSH EBX + + SUB ESP,12 + FSTP tbyte ptr [ESP] + + POP EBX // EBX is low half of fraction + POP EDX // EDX is high half of fraction + POP ECX // CX is exponent and sign + + SHR EBX,24 // set carry to last bit shifted out + ADC BL,0 // if bit was 1, round up + ADC EDX,0 + ADC CX,0 + JO @@overflow + + ADD EDX,EDX // shift fraction 1 bit left + ADD CX,CX // shift sign bit into carry + RCR EDX,1 // attach sign bit to fraction + SHR CX,1 // restore exponent, deleting sign + + SUB CX,ExtBias-RealBias // adjust exponent + JLE @@underflow + TEST CH,CH // CX must be in 1..255 + JG @@overflow + + MOV [EAX],CL + MOV [EAX+1],BL + MOV [EAX+2],EDX + + POP EBX + RET + +@@underflow: + XOR ECX,ECX + MOV [EAX],ECX + MOV [EAX+4],CX + POP EBX + RET + +@@overflow: + POP EBX + MOV AL,8 + JMP Error +end; + +const + ovtInstanceSize = -8; { Offset of instance size in OBJECTs } + ovtVmtPtrOffs = -4; + +procedure _ObjSetup; +asm +{ FUNCTION _ObjSetup( self: ^OBJECT; vmt: ^VMT): ^OBJECT; } +{ ->EAX Pointer to self (possibly nil) } +{ EDX Pointer to vmt (possibly nil) } +{ <-EAX Pointer to self } +{ EDX <> 0: an object was allocated } +{ Z-Flag Set: failure, Cleared: Success } + + CMP EDX,1 { is vmt = 0, indicating a call } + JAE @@skip1 { from a constructor? } + RET { return immediately with Z-flag cleared } + +@@skip1: + PUSH ECX + TEST EAX,EAX { is self already allocated? } + JNE @@noAlloc + MOV EAX,[EDX].ovtInstanceSize + TEST EAX,EAX + JE @@zeroSize + PUSH EDX + CALL _GetMem + POP EDX + TEST EAX,EAX + JZ @@fail + + { Zero fill the memory } + PUSH EDI + MOV ECX,[EDX].ovtInstanceSize + MOV EDI,EAX + PUSH EAX + XOR EAX,EAX + SHR ECX,2 + REP STOSD + MOV ECX,[EDX].ovtInstanceSize + AND ECX,3 + REP STOSB + POP EAX + POP EDI + + MOV ECX,[EDX].ovtVmtPtrOffs + TEST ECX,ECX + JL @@skip + MOV [EAX+ECX],EDX { store vmt in object at this offset } +@@skip: + TEST EAX,EAX { clear zero flag } + POP ECX + RET + +@@fail: + XOR EDX,EDX + POP ECX + RET + +@@zeroSize: + XOR EDX,EDX + CMP EAX,1 { clear zero flag - we were successful (kind of) } + POP ECX + RET + +@@noAlloc: + MOV ECX,[EDX].ovtVmtPtrOffs + TEST ECX,ECX + JL @@exit + MOV [EAX+ECX],EDX { store vmt in object at this offset } +@@exit: + XOR EDX,EDX { clear allocated flag } + TEST EAX,EAX { clear zero flag } + POP ECX +end; + +procedure _ObjCopy; +asm +{ PROCEDURE _ObjCopy( dest, src: ^OBJECT; vmtPtrOff: Longint); } +{ ->EAX Pointer to destination } +{ EDX Pointer to source } +{ ECX Offset of vmt in those objects. } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EDX + MOV EDI,EAX + + LEA EAX,[EDI+ECX] { remember pointer to dest vmt pointer } + MOV EDX,[EAX] { fetch dest vmt pointer } + + MOV EBX,[EDX].ovtInstanceSize + + MOV ECX,EBX { copy size DIV 4 dwords } + SHR ECX,2 + REP MOVSD + + MOV ECX,EBX { copy size MOD 4 bytes } + AND ECX,3 + REP MOVSB + + MOV [EAX],EDX { restore dest vmt } + + POP EDI + POP ESI + POP EBX +end; + +procedure _Fail; +asm +{ FUNCTION _Fail( self: ^OBJECT; allocFlag:Longint): ^OBJECT; } +{ ->EAX Pointer to self (possibly nil) } +{ EDX <> 0: Object must be deallocated } +{ <-EAX Nil } + + TEST EDX,EDX + JE @@exit { if no object was allocated, return } + CALL _FreeMem +@@exit: + XOR EAX,EAX +end; + +{$IFDEF MSWINDOWS} +function GetKeyboardType(nTypeFlag: Integer): Integer; stdcall; + external user name 'GetKeyboardType'; + +function _isNECWindows: Boolean; +var + KbSubType: Integer; +begin + Result := False; + if GetKeyboardType(0) = $7 then + begin + KbSubType := GetKeyboardType(1) and $FF00; + if (KbSubType = $0D00) or (KbSubType = $0400) then + Result := True; + end; +end; + +const + HKEY_LOCAL_MACHINE = $80000002; + +// workaround a Japanese Win95 bug +procedure _FpuMaskInit; +const + KEY_QUERY_VALUE = $00000001; + REG_DWORD = 4; + FPUMASKKEY = 'SOFTWARE\Borland\Delphi\RTL'; + FPUMASKNAME = 'FPUMaskValue'; +var + phkResult: LongWord; + lpData, DataSize: Longint; +begin + lpData := Default8087CW; + + if RegOpenKeyEx(HKEY_LOCAL_MACHINE, FPUMASKKEY, 0, KEY_QUERY_VALUE, phkResult) = 0 then + try + DataSize := Sizeof(lpData); + RegQueryValueEx(phkResult, FPUMASKNAME, nil, nil, @lpData, @DataSize); + finally + RegCloseKey(phkResult); + end; + Default8087CW := (Default8087CW and $ffc0) or (lpData and $3f); +end; +{$ENDIF} + +procedure _FpuInit; +asm + FNINIT + FWAIT +{$IFDEF PIC} + CALL GetGOT + MOV EAX,[EAX].OFFSET Default8087CW + FLDCW [EAX] +{$ELSE} + FLDCW Default8087CW +{$ENDIF} +end; + +procedure FpuInit; +//const cwDefault: Word = $1332 { $133F}; +asm + JMP _FpuInit +end; + +procedure FpuInitConsiderNECWindows; +begin + if _isNECWindows then _FpuMaskInit; + FpuInit(); +end; + +procedure _BoundErr; +asm + MOV AL,reRangeError + JMP Error +end; + +procedure _IntOver; +asm + MOV AL,reIntOverflow + JMP Error +end; + +function TObject.ClassType: TClass; +begin + Pointer(Result) := PPointer(Self)^; +end; + +class function TObject.ClassName: ShortString; +{$IFDEF PUREPASCAL} +begin + Result := PShortString(PPointer(Integer(Self) + vmtClassName)^)^; +end; +{$ELSE} +asm + { -> EAX VMT } + { EDX Pointer to result string } + PUSH ESI + PUSH EDI + MOV EDI,EDX + MOV ESI,[EAX].vmtClassName + XOR ECX,ECX + MOV CL,[ESI] + INC ECX + REP MOVSB + POP EDI + POP ESI +end; +{$ENDIF} + +class function TObject.ClassNameIs(const Name: string): Boolean; +{$IFDEF PUREPASCAL} +var + Temp: ShortString; + I: Byte; +begin + Result := False; + Temp := ClassName; + for I := 0 to Byte(Temp[0]) do + if Temp[I] <> Name[I] then Exit; + Result := True; +end; +{$ELSE} +asm + PUSH EBX + XOR EBX,EBX + OR EDX,EDX + JE @@exit + MOV EAX,[EAX].vmtClassName + XOR ECX,ECX + MOV CL,[EAX] + CMP ECX,[EDX-4] + JNE @@exit + DEC EDX +@@loop: + MOV BH,[EAX+ECX] + XOR BH,[EDX+ECX] + AND BH,0DFH + JNE @@exit + DEC ECX + JNE @@loop + INC EBX +@@exit: + MOV AL,BL + POP EBX +end; +{$ENDIF} + +class function TObject.ClassParent: TClass; +{$IFDEF PUREPASCAL} +begin + Pointer(Result) := PPointer(Integer(Self) + vmtParent)^; + if Result <> nil then + Pointer(Result) := PPointer(Result)^; +end; +{$ELSE} +asm + MOV EAX,[EAX].vmtParent + TEST EAX,EAX + JE @@exit + MOV EAX,[EAX] +@@exit: +end; +{$ENDIF} + +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; +begin +end; + +destructor TObject.Destroy; +begin +end; + +procedure TObject.Free; +begin + if Self <> nil then + Destroy; +end; + +class function TObject.InitInstance(Instance: Pointer): TObject; +{$IFDEF PUREPASCAL} +var + IntfTable: PInterfaceTable; + ClassPtr: TClass; + I: Integer; +begin + FillChar(Instance^, InstanceSize, 0); + PInteger(Instance)^ := Integer(Self); + ClassPtr := Self; + while ClassPtr <> nil do + begin + IntfTable := ClassPtr.GetInterfaceTable; + if IntfTable <> nil then + for I := 0 to IntfTable.EntryCount-1 do + with IntfTable.Entries[I] do + begin + if VTable <> nil then + PInteger(@PChar(Instance)[IOffset])^ := Integer(VTable); + end; + ClassPtr := ClassPtr.ClassParent; + end; + Result := Instance; +end; +{$ELSE} +asm + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV EDI,EDX + STOSD + MOV ECX,[EBX].vmtInstanceSize + XOR EAX,EAX + PUSH ECX + SHR ECX,2 + DEC ECX + REP STOSD + POP ECX + AND ECX,3 + REP STOSB + MOV EAX,EDX + MOV EDX,ESP +@@0: MOV ECX,[EBX].vmtIntfTable + TEST ECX,ECX + JE @@1 + PUSH ECX +@@1: MOV EBX,[EBX].vmtParent + TEST EBX,EBX + JE @@2 + MOV EBX,[EBX] + JMP @@0 +@@2: CMP ESP,EDX + JE @@5 +@@3: POP EBX + MOV ECX,[EBX].TInterfaceTable.EntryCount + ADD EBX,4 +@@4: MOV ESI,[EBX].TInterfaceEntry.VTable + TEST ESI,ESI + JE @@4a + MOV EDI,[EBX].TInterfaceEntry.IOffset + MOV [EAX+EDI],ESI +@@4a: ADD EBX,TYPE TInterfaceEntry + DEC ECX + JNE @@4 + CMP ESP,EDX + JNE @@3 +@@5: POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +procedure TObject.CleanupInstance; +{$IFDEF PUREPASCAL} +var + ClassPtr: TClass; + InitTable: Pointer; +begin + ClassPtr := ClassType; + InitTable := PPointer(Integer(ClassPtr) + vmtInitTable)^; + while (ClassPtr <> nil) and (InitTable <> nil) do + begin + _FinalizeRecord(Self, InitTable); + ClassPtr := ClassPtr.ClassParent; + if ClassPtr <> nil then + InitTable := PPointer(Integer(ClassPtr) + vmtInitTable)^; + end; +end; +{$ELSE} +asm + PUSH EBX + PUSH ESI + MOV EBX,EAX + MOV ESI,EAX +@@loop: + MOV ESI,[ESI] + MOV EDX,[ESI].vmtInitTable + MOV ESI,[ESI].vmtParent + TEST EDX,EDX + JE @@skip + CALL _FinalizeRecord + MOV EAX,EBX +@@skip: + TEST ESI,ESI + JNE @@loop + + POP ESI + POP EBX +end; +{$ENDIF} + +function InvokeImplGetter(Self: TObject; ImplGetter: Cardinal): IInterface; +{$IFDEF PUREPASCAL} +var + M: function: IInterface of object; +begin + TMethod(M).Data := Self; + case ImplGetter of + $FF000000..$FFFFFFFF: // Field + Result := IInterface(Pointer(Cardinal(Self) + (ImplGetter and $00FFFFFF))); + $FE000000..$FEFFFFFF: // virtual method + begin + // sign extend vmt slot offset = smallint cast + TMethod(M).Code := PPointer(Integer(Self) + SmallInt(ImplGetter))^; + Result := M; + end; + else // static method + TMethod(M).Code := Pointer(ImplGetter); + Result := M; + end; +end; +{$ELSE} +asm + XCHG EDX,ECX + CMP ECX,$FF000000 + JAE @@isField + CMP ECX,$FE000000 + JB @@isStaticMethod + + { the GetProc is a virtual method } + MOVSX ECX,CX { sign extend slot offs } + ADD ECX,[EAX] { vmt + slotoffs } + JMP dword ptr [ECX] { call vmt[slot] } + +@@isStaticMethod: + JMP ECX + +@@isField: + AND ECX,$00FFFFFF + ADD ECX,EAX + MOV EAX,EDX + MOV EDX,[ECX] + JMP _IntfCopy +end; +{$ENDIF} + +function TObject.GetInterface(const IID: TGUID; out Obj): Boolean; +var + InterfaceEntry: PInterfaceEntry; +begin + Pointer(Obj) := nil; + InterfaceEntry := GetInterfaceEntry(IID); + if InterfaceEntry <> nil then + begin + if InterfaceEntry^.IOffset <> 0 then + begin + Pointer(Obj) := Pointer(Integer(Self) + InterfaceEntry^.IOffset); + if Pointer(Obj) <> nil then IInterface(Obj)._AddRef; + end + else + IInterface(Obj) := InvokeImplGetter(Self, InterfaceEntry^.ImplGetter); + end; + Result := Pointer(Obj) <> nil; +end; + +class function TObject.GetInterfaceEntry(const IID: TGUID): PInterfaceEntry; +{$IFDEF PUREPASCAL} +var + ClassPtr: TClass; + IntfTable: PInterfaceTable; + I: Integer; +begin + ClassPtr := Self; + while ClassPtr <> nil do + begin + IntfTable := ClassPtr.GetInterfaceTable; + if IntfTable <> nil then + for I := 0 to IntfTable.EntryCount-1 do + begin + Result := @IntfTable.Entries[I]; +// if Result^.IID = IID then Exit; + if (Int64(Result^.IID.D1) = Int64(IID.D1)) and + (Int64(Result^.IID.D4) = Int64(IID.D4)) then Exit; + end; + ClassPtr := ClassPtr.ClassParent; + end; + Result := nil; +end; +{$ELSE} +asm + PUSH EBX + PUSH ESI + MOV EBX,EAX +@@1: MOV EAX,[EBX].vmtIntfTable + TEST EAX,EAX + JE @@4 + MOV ECX,[EAX].TInterfaceTable.EntryCount + ADD EAX,4 +@@2: MOV ESI,[EDX].Integer[0] + CMP ESI,[EAX].TInterfaceEntry.IID.Integer[0] + JNE @@3 + MOV ESI,[EDX].Integer[4] + CMP ESI,[EAX].TInterfaceEntry.IID.Integer[4] + JNE @@3 + MOV ESI,[EDX].Integer[8] + CMP ESI,[EAX].TInterfaceEntry.IID.Integer[8] + JNE @@3 + MOV ESI,[EDX].Integer[12] + CMP ESI,[EAX].TInterfaceEntry.IID.Integer[12] + JE @@5 +@@3: ADD EAX,type TInterfaceEntry + DEC ECX + JNE @@2 +@@4: MOV EBX,[EBX].vmtParent + TEST EBX,EBX + JE @@4a + MOV EBX,[EBX] + JMP @@1 +@@4a: XOR EAX,EAX +@@5: POP ESI + POP EBX +end; +{$ENDIF} + +class function TObject.GetInterfaceTable: PInterfaceTable; +begin + Result := PPointer(Integer(Self) + vmtIntfTable)^; +end; + +function _IsClass(Child: TObject; Parent: TClass): Boolean; +begin + Result := (Child <> nil) and Child.InheritsFrom(Parent); +end; + +function _AsClass(Child: TObject; Parent: TClass): TObject; +{$IFDEF PUREPASCAL} +begin + Result := Child; + if not (Child is Parent) then + Error(reInvalidCast); // loses return address +end; +{$ELSE} +asm + { -> EAX left operand (class) } + { EDX VMT of right operand } + { <- EAX if left is derived from right, else runtime error } + TEST EAX,EAX + JE @@exit + MOV ECX,EAX +@@loop: + MOV ECX,[ECX] + CMP ECX,EDX + JE @@exit + MOV ECX,[ECX].vmtParent + TEST ECX,ECX + JNE @@loop + + { do runtime error } + MOV AL,reInvalidCast + JMP Error + +@@exit: +end; +{$ENDIF} + +function _GetHelperIntf(Instance: TObject; Cls: TClass): IInterface; +begin + + Result := nil; +end; + +procedure GetDynaMethod; +{ function GetDynaMethod(vmt: TClass; selector: Smallint) : Pointer; } +asm + { -> EAX vmt of class } + { SI dynamic method index } + { <- ESI pointer to routine } + { ZF = 0 if found } + { trashes: EAX, ECX } + + PUSH EDI + XCHG EAX,ESI + JMP @@haveVMT +@@outerLoop: + MOV ESI,[ESI] +@@haveVMT: + MOV EDI,[ESI].vmtDynamicTable + TEST EDI,EDI + JE @@parent + MOVZX ECX,word ptr [EDI] + PUSH ECX + ADD EDI,2 + REPNE SCASW + JE @@found + POP ECX +@@parent: + MOV ESI,[ESI].vmtParent + TEST ESI,ESI + JNE @@outerLoop + JMP @@exit + +@@found: + POP EAX + ADD EAX,EAX + SUB EAX,ECX { this will always clear the Z-flag ! } + MOV ESI,[EDI+EAX*2-4] + +@@exit: + POP EDI +end; + +procedure _CallDynaInst; +asm + PUSH EAX + PUSH ECX + MOV EAX,[EAX] + CALL GetDynaMethod + POP ECX + POP EAX + JE @@Abstract + JMP ESI +@@Abstract: + POP ECX + JMP _AbstractError +end; + + +procedure _CallDynaClass; +asm + PUSH EAX + PUSH ECX + CALL GetDynaMethod + POP ECX + POP EAX + JE @@Abstract + JMP ESI +@@Abstract: + POP ECX + JMP _AbstractError +end; + + +procedure _FindDynaInst; +asm + PUSH ESI + MOV ESI,EDX + MOV EAX,[EAX] + CALL GetDynaMethod + MOV EAX,ESI + POP ESI + JNE @@exit + POP ECX + JMP _AbstractError +@@exit: +end; + + +procedure _FindDynaClass; +asm + PUSH ESI + MOV ESI,EDX + CALL GetDynaMethod + MOV EAX,ESI + POP ESI + JNE @@exit + POP ECX + JMP _AbstractError +@@exit: +end; + +class function TObject.InheritsFrom(AClass: TClass): Boolean; +{$IFDEF PUREPASCAL} +var + ClassPtr: TClass; +begin + ClassPtr := Self; + while (ClassPtr <> nil) and (ClassPtr <> AClass) do + ClassPtr := PPointer(Integer(ClassPtr) + vmtParent)^; + Result := ClassPtr = AClass; +end; +{$ELSE} +asm + { -> EAX Pointer to our class } + { EDX Pointer to AClass } + { <- AL Boolean result } + JMP @@haveVMT +@@loop: + MOV EAX,[EAX] +@@haveVMT: + CMP EAX,EDX + JE @@success + MOV EAX,[EAX].vmtParent + TEST EAX,EAX + JNE @@loop + JMP @@exit +@@success: + MOV AL,1 +@@exit: +end; +{$ENDIF} + + +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); +begin +end; + + +procedure TObject.AfterConstruction; +begin +end; + +procedure TObject.BeforeDestruction; +begin +end; + +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].vmtDefaultHandler +end; + + +class function TObject.MethodAddress(const Name: ShortString): Pointer; +asm + { -> EAX Pointer to class } + { EDX Pointer to name } + PUSH EBX + PUSH ESI + PUSH EDI + XOR ECX,ECX + XOR EDI,EDI + MOV BL,[EDX] + JMP @@haveVMT +@@outer: { upper 16 bits of ECX are 0 ! } + MOV EAX,[EAX] +@@haveVMT: + MOV ESI,[EAX].vmtMethodTable + TEST ESI,ESI + JE @@parent + MOV DI,[ESI] { EDI := method count } + ADD ESI,2 +@@inner: { upper 16 bits of ECX are 0 ! } + MOV CL,[ESI+6] { compare length of strings } + CMP CL,BL + JE @@cmpChar +@@cont: { upper 16 bits of ECX are 0 ! } + MOV CX,[ESI] { fetch length of method desc } + ADD ESI,ECX { point ESI to next method } + DEC EDI + JNZ @@inner +@@parent: + MOV EAX,[EAX].vmtParent { fetch parent vmt } + TEST EAX,EAX + JNE @@outer + JMP @@exit { return NIL } + +@@notEqual: + MOV BL,[EDX] { restore BL to length of name } + JMP @@cont + +@@cmpChar: { upper 16 bits of ECX are 0 ! } + MOV CH,0 { upper 24 bits of ECX are 0 ! } +@@cmpCharLoop: + MOV BL,[ESI+ECX+6] { case insensitive string cmp } + XOR BL,[EDX+ECX+0] { last char is compared first } + AND BL,$DF + JNE @@notEqual + DEC ECX { ECX serves as counter } + JNZ @@cmpCharLoop + + { found it } + MOV EAX,[ESI+2] + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +class function TObject.MethodName(Address: Pointer): ShortString; +asm + { -> EAX Pointer to class } + { EDX Address } + { ECX Pointer to result } + PUSH EBX + PUSH ESI + PUSH EDI + MOV EDI,ECX + XOR EBX,EBX + XOR ECX,ECX + JMP @@haveVMT +@@outer: + MOV EAX,[EAX] +@@haveVMT: + MOV ESI,[EAX].vmtMethodTable { fetch pointer to method table } + TEST ESI,ESI + JE @@parent + MOV CX,[ESI] + ADD ESI,2 +@@inner: + CMP EDX,[ESI+2] + JE @@found + MOV BX,[ESI] + ADD ESI,EBX + DEC ECX + JNZ @@inner +@@parent: + MOV EAX,[EAX].vmtParent + TEST EAX,EAX + JNE @@outer + MOV [EDI],AL + JMP @@exit + +@@found: + ADD ESI,6 + XOR ECX,ECX + MOV CL,[ESI] + INC ECX + REP MOVSB + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +function TObject.FieldAddress(const Name: ShortString): Pointer; +asm + { -> EAX Pointer to instance } + { EDX Pointer to name } + PUSH EBX + PUSH ESI + PUSH EDI + XOR ECX,ECX + XOR EDI,EDI + MOV BL,[EDX] + + PUSH EAX { save instance pointer } + +@@outer: + MOV EAX,[EAX] { fetch class pointer } + MOV ESI,[EAX].vmtFieldTable + TEST ESI,ESI + JE @@parent + MOV DI,[ESI] { fetch count of fields } + ADD ESI,6 +@@inner: + MOV CL,[ESI+6] { compare string lengths } + CMP CL,BL + JE @@cmpChar +@@cont: + LEA ESI,[ESI+ECX+7] { point ESI to next field } + DEC EDI + JNZ @@inner +@@parent: + MOV EAX,[EAX].vmtParent { fetch parent VMT } + TEST EAX,EAX + JNE @@outer + POP EDX { forget instance, return Nil } + JMP @@exit + +@@notEqual: + MOV BL,[EDX] { restore BL to length of name } + MOV CL,[ESI+6] { ECX := length of field name } + JMP @@cont + +@@cmpChar: + MOV BL,[ESI+ECX+6] { case insensitive string cmp } + XOR BL,[EDX+ECX+0] { starting with last char } + AND BL,$DF + JNE @@notEqual + DEC ECX { ECX serves as counter } + JNZ @@cmpChar + + { found it } + MOV EAX,[ESI] { result is field offset plus ... } + POP EDX + ADD EAX,EDX { instance pointer } + +@@exit: + POP EDI + POP ESI + POP EBX +end; + +function _ClassCreate(AClass: TClass; Alloc: Boolean): TObject; +asm + { -> EAX = pointer to VMT } + { <- EAX = pointer to instance } + PUSH EDX + PUSH ECX + PUSH EBX + TEST DL,DL + JL @@noAlloc + CALL dword ptr [EAX].vmtNewInstance +@@noAlloc: +{$IFNDEF PC_MAPPED_EXCEPTIONS} + XOR EDX,EDX + LEA ECX,[ESP+16] + MOV EBX,FS:[EDX] + MOV [ECX].TExcFrame.next,EBX + MOV [ECX].TExcFrame.hEBP,EBP + MOV [ECX].TExcFrame.desc,offset @desc + MOV [ECX].TexcFrame.ConstructedObject,EAX { trick: remember copy to instance } + MOV FS:[EDX],ECX +{$ENDIF} + POP EBX + POP ECX + POP EDX + RET + +{$IFNDEF PC_MAPPED_EXCEPTIONS} +@desc: + JMP _HandleAnyException + + { destroy the object } + + MOV EAX,[ESP+8+9*4] + MOV EAX,[EAX].TExcFrame.ConstructedObject + TEST EAX,EAX + JE @@skip + MOV ECX,[EAX] + MOV DL,$81 + PUSH EAX + CALL DWORD PTR [ECX].vmtDestroy + POP EAX + CALL _ClassDestroy +@@skip: + { reraise the exception } + CALL _RaiseAgain +{$ENDIF} +end; + +procedure _ClassDestroy(Instance: TObject); +begin + Instance.FreeInstance; +end; + + +function _AfterConstruction(Instance: TObject): TObject; +begin + try + Instance.AfterConstruction; + Result := Instance; + except + _BeforeDestruction(Instance, 1); + raise; + end; +end; + +function _BeforeDestruction(Instance: TObject; OuterMost: ShortInt): TObject; +// Must preserve DL on return! +{$IFDEF PUREPASCAL} +begin + Result := Instance; + if OuterMost > 0 then Exit; + Instance.BeforeDestruction; +end; +{$ELSE} +asm + { -> EAX = pointer to instance } + { DL = dealloc flag } + + TEST DL,DL + JG @@outerMost + RET +@@outerMost: + PUSH EAX + PUSH EDX + MOV EDX,[EAX] + CALL DWORD PTR [EDX].vmtBeforeDestruction + POP EDX + POP EAX +end; +{$ENDIF} + +{ + 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. +} + +{$IFDEF LINUX} +const + excRaise = 0; { an exception is being raised by the user (could be a reraise) } + excCatch = 1; { an exception is about to be caught } + excFinally = 2; { a finally block is about to be executed because of an exception } + excUnhandled = 3; { no user exception handler was found (the app will die) } + +procedure _DbgExcNotify( + NotificationKind: Integer; + ExceptionObject: Pointer; + ExceptionName: PShortString; + ExceptionLocation: Pointer; + HandlerAddr: Pointer); cdecl; export; +begin +{$IFDEF DEBUG} + { + This code is just for debugging the exception handling system. The debugger + needs _DbgExcNotify, however to place breakpoints in, so the function itself + cannot be removed. + } + asm + PUSH EAX + PUSH EDX + end; + if Assigned(ExcNotificationProc) then + ExcNotificationProc(NotificationKind, ExceptionObject, ExceptionName, ExceptionLocation, HandlerAddr); + asm + POP EDX + POP EAX + end; +{$ENDIF} +end; + +{ + The following functions are used by the debugger for the evaluator. If you + change them IN ANY WAY, the debugger will cease to function correctly. +} +procedure _DbgEvalMarker; +begin +end; + +procedure _DbgEvalExcept(E: TObject); +begin +end; + +procedure _DbgEvalEnd; +begin +end; + +{ + This function is used by the debugger to provide a soft landing spot + when evaluating a function call that may raise an unhandled exception. + The return address of _DbgEvalMarker is pushed onto the stack so that + the unwinder will transfer control to the except block. +} +procedure _DbgEvalFrame; +begin + try + _DbgEvalMarker; + except on E: TObject do + _DbgEvalExcept(E); + end; + _DbgEvalEnd; +end; + +{ + These export names need to match the names that will be generated into + the .symtab section, so that the debugger can find them if stabs + debug information is being generated. +} +exports + _DbgExcNotify name '@DbgExcNotify', + _DbgEvalFrame name '@DbgEvalFrame', + _DbgEvalMarker name '@DbgEvalMarker', + _DbgEvalExcept name '@DbgEvalExcept', + _DbgEvalEnd name '@DbgEvalEnd'; +{$ENDIF} + +{ tell the debugger that the next raise is a re-raise of the current non-Delphi + exception } +procedure NotifyReRaise; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX location of exception } + PUSH 0 { handler addr } + PUSH EDX { location of exception } + MOV ECX, [EAX] + PUSH [ECX].vmtClassName { exception name } + PUSH EAX { exception object } + PUSH excRaise { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 +{$ELSE} + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH 0 + PUSH 0 + PUSH cContinuable + PUSH cDelphiReRaise + CALL RaiseExceptionProc +@@1: +{$ENDIF} +end; + +{ tell the debugger about the raise of a non-Delphi exception } +{$IFNDEF LINUX} +procedure NotifyNonDelphiException; +asm + CMP BYTE PTR DebugHook,0 + JE @@1 + PUSH EAX + PUSH EAX + PUSH EDX + PUSH ESP + PUSH 2 + PUSH cContinuable + PUSH cNonDelphiException + CALL RaiseExceptionProc + ADD ESP,8 + POP EAX +@@1: +end; +{$ENDIF} + +{ Tell the debugger where the handler for the current exception is located } +procedure NotifyExcept; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX handler addr } + PUSH EAX + MOV EAX, [EAX].TRaisedException.ExceptObject + + PUSH EDX { handler addr } + PUSH 0 { location of exception } + MOV ECX, [EAX] + PUSH [ECX].vmtClassName { exception name } + PUSH EAX { exception object } + PUSH excCatch { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 + + POP EAX +{$ELSE} + PUSH ESP + PUSH 1 + PUSH cContinuable + PUSH cDelphiExcept { our magic exception code } + CALL RaiseExceptionProc + ADD ESP,4 + POP EAX +{$ENDIF} +end; + +procedure NotifyOnExcept; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX handler addr } + PUSH EDX { handler addr } + PUSH 0 { location of exception } + MOV ECX, [EAX] + PUSH [ECX].vmtClassName { exception name } + PUSH EAX { exception object } + PUSH excCatch { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 +{$ELSE} + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH EAX + PUSH [EBX].TExcDescEntry.handler + JMP NotifyExcept +@@1: +{$ENDIF} +end; + +{$IFNDEF LINUX} +procedure NotifyAnyExcept; +asm + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH EAX + PUSH EBX + JMP NotifyExcept +@@1: +end; + +procedure CheckJmp; +asm + TEST ECX,ECX + JE @@3 + MOV EAX,[ECX + 1] + CMP BYTE PTR [ECX],0E9H { near jmp } + JE @@1 + CMP BYTE PTR [ECX],0EBH { short jmp } + JNE @@3 + MOVSX EAX,AL + INC ECX + INC ECX + JMP @@2 +@@1: + ADD ECX,5 +@@2: + ADD ECX,EAX +@@3: +end; +{$ENDIF} { not LINUX } + +{ Notify debugger of a finally during an exception unwind } +procedure NotifyExceptFinally; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX handler addr } + PUSH EDX { handler addr } + PUSH 0 { location of exception } + PUSH 0 { exception name } + PUSH 0 { exception object } + PUSH excFinally { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 +{$ELSE} + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH EAX + PUSH EDX + PUSH ECX + CALL CheckJmp + PUSH ECX + PUSH ESP { pass pointer to arguments } + PUSH 1 { there is 1 argument } + PUSH cContinuable { continuable execution } + PUSH cDelphiFinally { our magic exception code } + CALL RaiseExceptionProc + POP ECX + POP ECX + POP EDX + POP EAX +@@1: +{$ENDIF} +end; + + +{ Tell the debugger that the current exception is handled and cleaned up. + Also indicate where execution is about to resume. } +{$IFNDEF LINUX} +procedure NotifyTerminate; +asm + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH EDX + PUSH ESP + PUSH 1 + PUSH cContinuable + PUSH cDelphiTerminate { our magic exception code } + CALL RaiseExceptionProc + POP EDX +@@1: +end; +{$ENDIF} + +{ 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; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX location of exception } + PUSH EAX + MOV EAX, [EAX].TRaisedException.ExceptObject + + PUSH 0 { handler addr } + PUSH EDX { location of exception } + MOV ECX, [EAX] + PUSH [ECX].vmtClassName { exception name } + PUSH EAX { exception object } + PUSH excUnhandled { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 + + POP EAX +{$ELSE} + PUSH EAX + PUSH EDX + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH ESP + PUSH 2 + PUSH cContinuable + PUSH cDelphiUnhandled + CALL RaiseExceptionProc +@@1: + POP EDX + POP EAX +{$ENDIF} +end; + +procedure _HandleAnyException; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + CALL UnblockOSExceptions + OR [EAX].TRaisedException.Flags, excIsBeingHandled + MOV ESI, EBX + MOV EDX, [ESP] + CALL NotifyExcept + MOV EBX, ESI +{$ENDIF} +{$IFNDEF PC_MAPPED_EXCEPTIONS} + { -> [ESP+ 4] excPtr: PExceptionRecord } + { [ESP+ 8] errPtr: PExcFrame } + { [ESP+12] ctxPtr: Pointer } + { [ESP+16] dspPtr: Pointer } + { <- EAX return value - always one } + + MOV EAX,[ESP+4] + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JNE @@exit + + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + MOV EDX,[EAX].TExceptionRecord.ExceptObject + MOV ECX,[EAX].TExceptionRecord.ExceptAddr + JE @@DelphiException + CLD + CALL _FpuInit + MOV EDX,ExceptObjProc + TEST EDX,EDX + JE @@exit + CALL EDX + TEST EAX,EAX + JE @@exit + MOV EDX,[ESP+12] + MOV ECX,[ESP+4] + CMP [ECX].TExceptionRecord.ExceptionCode,cCppException + JE @@CppException + CALL NotifyNonDelphiException +{$IFDEF MSWINDOWS} + CMP BYTE PTR JITEnable,0 + JBE @@CppException + CMP BYTE PTR DebugHook,0 + JA @@CppException // Do not JIT if debugging + LEA ECX,[ESP+4] + PUSH EAX + PUSH ECX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + POP EAX + JE @@exit + MOV EDX,EAX + MOV EAX,[ESP+4] + MOV ECX,[EAX].TExceptionRecord.ExceptionAddress + JMP @@GoUnwind +{$ENDIF} +@@CppException: + MOV EDX,EAX + MOV EAX,[ESP+4] + MOV ECX,[EAX].TExceptionRecord.ExceptionAddress + +@@DelphiException: +{$IFDEF MSWINDOWS} + CMP BYTE PTR JITEnable,1 + JBE @@GoUnwind + CMP BYTE PTR DebugHook,0 { Do not JIT if debugging } + JA @@GoUnwind + PUSH EAX + LEA EAX,[ESP+8] + PUSH EDX + PUSH ECX + PUSH EAX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + POP ECX + POP EDX + POP EAX + JE @@exit +{$ENDIF} + +@@GoUnwind: + OR [EAX].TExceptionRecord.ExceptionFlags,cUnwinding + + PUSH EBX + XOR EBX,EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBX,FS:[EBX] + PUSH EBX { Save pointer to topmost frame } + PUSH EAX { Save OS exception pointer } + PUSH EDX { Save exception object } + PUSH ECX { Save exception address } + + MOV EDX,[ESP+8+8*4] + + PUSH 0 + PUSH EAX + PUSH offset @@returnAddress + PUSH EDX + CALL RtlUnwindProc +@@returnAddress: + + MOV EDI,[ESP+8+8*4] + + { Make the RaiseList entry on the stack } + + CALL SysInit.@GetTLS + PUSH [EAX].RaiseListPtr + MOV [EAX].RaiseListPtr,ESP + + MOV EBP,[EDI].TExcFrame.hEBP + MOV EBX,[EDI].TExcFrame.desc + MOV [EDI].TExcFrame.desc,offset @@exceptFinally + + ADD EBX,TExcDesc.instructions + CALL NotifyAnyExcept + JMP EBX + +@@exceptFinally: + JMP _HandleFinally + +@@destroyExcept: + { we come here if an exception handler has thrown yet another exception } + { we need to destroy the exception object and pop the raise list. } + + CALL SysInit.@GetTLS + MOV ECX,[EAX].RaiseListPtr + MOV EDX,[ECX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,EDX + + MOV EAX,[ECX].TRaiseFrame.ExceptObject + JMP TObject.Free + +@@exit: + MOV EAX,1 +{$ENDIF} { not PC_MAPPED_EXCEPTIONS } +end; + +{$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; +asm + { -> EAX raised object: Pointer } + { EDX descriptor table: ^TExcDesc } + { EBX GOT of user code, or 0 if not an SO } + { <- EAX matching descriptor: ^TExcDescEntry } + PUSH EBP + MOV EBP, ESP + SUB ESP, 8 { Room for vtable temp, and adjustor } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV [EBP - 8], EBX { Store the potential GOT } + MOV EAX, [EAX] { load vtable of exception object } + MOV EBX,[EDX].TExcDesc.cnt + LEA ESI,[EDX].TExcDesc.excTab { point ECX to exc descriptor table } + MOV [EBP - 4], EAX { temp for vtable of exception object } + +@@innerLoop: + MOV EAX,[ESI].TExcDescEntry.vTable + TEST EAX,EAX { catch all clause? } + JE @@found { yes: This is the handler } + ADD EAX, [EBP - 8] { add in the adjustor (could be 0) } + MOV EDI,[EBP - 4] { load vtable of exception object } + JMP @@haveVMT + +@@vtLoop: + MOV EDI,[EDI] +@@haveVMT: + MOV EAX,[EAX] + CMP EAX,EDI + JE @@found + + MOV ECX,[EAX].vmtInstanceSize + CMP ECX,[EDI].vmtInstanceSize + JNE @@parent + + MOV EAX,[EAX].vmtClassName + MOV EDX,[EDI].vmtClassName + + XOR ECX,ECX + MOV CL,[EAX] + CMP CL,[EDX] + JNE @@parent + + INC EAX + INC EDX + CALL _AStrCmp + JE @@found + +@@parent: + MOV EDI,[EDI].vmtParent { load vtable of parent } + MOV EAX,[ESI].TExcDescEntry.vTable + ADD EAX, [EBP - 8] { add in the adjustor (could be 0) } + TEST EDI,EDI + JNE @@vtLoop + + ADD ESI,8 + DEC EBX + JNZ @@innerLoop + + { Didn't find a handler. } + XOR ESI, ESI + +@@found: + MOV EAX, ESI +@@done: + POP EDI + POP ESI + POP EBX + MOV ESP, EBP + POP EBP +end; +{$ENDIF} + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _HandleOnExceptionPIC; +asm + { -> EAX obj : Exception object } + { [RA] desc: ^TExcDesc } + { <- Doesn't return } + + // Mark the exception as being handled + OR [EAX].TRaisedException.Flags, excIsBeingHandled + + MOV ESI, EBX // Save the GOT + MOV EDX, [ESP] // Get the addr of the TExcDesc + PUSH EAX // Save the object + MOV EAX, [EAX].TRaisedException.ExceptObject + CALL FindOnExceptionDescEntry + OR EAX, EAX + JE @@NotForMe + + MOV EBX, ESI // Set back to user's GOT + MOV EDX, EAX + POP EAX // Get the object back + POP ECX // Ditch the return addr + + // Get the Pascal object itself. + MOV EAX, [EAX].TRaisedException.ExceptObject + + MOV EDX, [EDX].TExcDescEntry.handler + ADD EDX, EBX // adjust for GOT + CALL NotifyOnExcept + + MOV EBX, ESI // Make sure of user's GOT + JMP EDX // Back to the user code + // never returns +@@NotForMe: + POP EAX // Get the exception object + + // Mark that we're reraising this exception, so that the + // compiler generated exception handler for the 'except on' clause + // will not get confused + OR [EAX].TRaisedException.Flags, excIsBeingReRaised + + JMP SysRaiseException // Should be using resume here +end; +{$ENDIF} + +procedure _HandleOnException; +{$IFDEF PC_MAPPED_EXCEPTIONS} +asm + { -> EAX obj : Exception object } + { [RA] desc: ^TExcDesc } + { <- Doesn't return } + + // Mark the exception as being handled + OR [EAX].TRaisedException.Flags, excIsBeingHandled + + MOV EDX, [ESP] // Get the addr of the TExcDesc + PUSH EAX // Save the object + PUSH EBX // Save EBX + XOR EBX, EBX // No GOT + MOV EAX, [EAX].TRaisedException.ExceptObject + CALL FindOnExceptionDescEntry + POP EBX // Restore EBX + OR EAX, EAX // Is the exception for me? + JE @@NotForMe + + MOV EDX, EAX + POP EAX // Get the object back + POP ECX // Ditch the return addr + + // Get the Pascal object itself. + MOV EAX, [EAX].TRaisedException.ExceptObject + + MOV EDX, [EDX].TExcDescEntry.handler + CALL NotifyOnExcept // Tell the debugger about it + + JMP EDX // Back to the user code + // never returns +@@NotForMe: + POP EAX // Get the exception object + + // Mark that we're reraising this exception, so that the + // compiler generated exception handler for the 'except on' clause + // will not get confused + OR [EAX].TRaisedException.Flags, excIsBeingReRaised + JMP SysRaiseException // Should be using resume here +end; +{$ENDIF} +{$IFNDEF PC_MAPPED_EXCEPTIONS} +asm + { -> [ESP+ 4] excPtr: PExceptionRecord } + { [ESP+ 8] errPtr: PExcFrame } + { [ESP+12] ctxPtr: Pointer } + { [ESP+16] dspPtr: Pointer } + { <- EAX return value - always one } + + MOV EAX,[ESP+4] + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JNE @@exit + + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + JE @@DelphiException + CLD + CALL _FpuInit + MOV EDX,ExceptClsProc + TEST EDX,EDX + JE @@exit + CALL EDX + TEST EAX,EAX + JNE @@common + JMP @@exit + +@@DelphiException: + MOV EAX,[EAX].TExceptionRecord.ExceptObject + MOV EAX,[EAX] { load vtable of exception object } + +@@common: + + MOV EDX,[ESP+8] + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV ECX,[EDX].TExcFrame.desc + MOV EBX,[ECX].TExcDesc.cnt + LEA ESI,[ECX].TExcDesc.excTab { point ECX to exc descriptor table } + MOV EBP,EAX { load vtable of exception object } + +@@innerLoop: + MOV EAX,[ESI].TExcDescEntry.vTable + TEST EAX,EAX { catch all clause? } + JE @@doHandler { yes: go execute handler } + MOV EDI,EBP { load vtable of exception object } + JMP @@haveVMT + +@@vtLoop: + MOV EDI,[EDI] +@@haveVMT: + MOV EAX,[EAX] + CMP EAX,EDI + JE @@doHandler + + MOV ECX,[EAX].vmtInstanceSize + CMP ECX,[EDI].vmtInstanceSize + JNE @@parent + + MOV EAX,[EAX].vmtClassName + MOV EDX,[EDI].vmtClassName + + XOR ECX,ECX + MOV CL,[EAX] + CMP CL,[EDX] + JNE @@parent + + INC EAX + INC EDX + CALL _AStrCmp + JE @@doHandler + +@@parent: + MOV EDI,[EDI].vmtParent { load vtable of parent } + MOV EAX,[ESI].TExcDescEntry.vTable + TEST EDI,EDI + JNE @@vtLoop + + ADD ESI,8 + DEC EBX + JNZ @@innerLoop + + POP EBP + POP EDI + POP ESI + POP EBX + JMP @@exit + +@@doHandler: + MOV EAX,[ESP+4+4*4] + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + MOV EDX,[EAX].TExceptionRecord.ExceptObject + MOV ECX,[EAX].TExceptionRecord.ExceptAddr + JE @@haveObject + CALL ExceptObjProc + MOV EDX,[ESP+12+4*4] + CALL NotifyNonDelphiException +{$IFDEF MSWINDOWS} + CMP BYTE PTR JITEnable,0 + JBE @@NoJIT + CMP BYTE PTR DebugHook,0 + JA @@noJIT { Do not JIT if debugging } + LEA ECX,[ESP+4] + PUSH EAX + PUSH ECX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + POP EAX + JE @@exit +{$ENDIF} +@@noJIT: + MOV EDX,EAX + MOV EAX,[ESP+4+4*4] + MOV ECX,[EAX].TExceptionRecord.ExceptionAddress + JMP @@GoUnwind + +@@haveObject: +{$IFDEF MSWINDOWS} + CMP BYTE PTR JITEnable,1 + JBE @@GoUnwind + CMP BYTE PTR DebugHook,0 + JA @@GoUnwind + PUSH EAX + LEA EAX,[ESP+8] + PUSH EDX + PUSH ECX + PUSH EAX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + POP ECX + POP EDX + POP EAX + JE @@exit +{$ENDIF} + +@@GoUnwind: + XOR EBX,EBX + MOV EBX,FS:[EBX] + PUSH EBX { Save topmost frame } + PUSH EAX { Save exception record } + PUSH EDX { Save exception object } + PUSH ECX { Save exception address } + + MOV EDX,[ESP+8+8*4] + OR [EAX].TExceptionRecord.ExceptionFlags,cUnwinding + + PUSH ESI { Save handler entry } + + PUSH 0 + PUSH EAX + PUSH offset @@returnAddress + PUSH EDX + CALL RtlUnwindProc +@@returnAddress: + + POP EBX { Restore handler entry } + + MOV EDI,[ESP+8+8*4] + + { Make the RaiseList entry on the stack } + + CALL SysInit.@GetTLS + PUSH [EAX].RaiseListPtr + MOV [EAX].RaiseListPtr,ESP + + MOV EBP,[EDI].TExcFrame.hEBP + MOV [EDI].TExcFrame.desc,offset @@exceptFinally + MOV EAX,[ESP].TRaiseFrame.ExceptObject + CALL NotifyOnExcept + JMP [EBX].TExcDescEntry.handler + +@@exceptFinally: + JMP _HandleFinally + +@@destroyExcept: + { we come here if an exception handler has thrown yet another exception } + { we need to destroy the exception object and pop the raise list. } + + CALL SysInit.@GetTLS + MOV ECX,[EAX].RaiseListPtr + MOV EDX,[ECX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,EDX + + MOV EAX,[ECX].TRaiseFrame.ExceptObject + JMP TObject.Free +@@exit: + MOV EAX,1 +end; +{$ENDIF} + +procedure _HandleFinally; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} +{$IFDEF PIC} + MOV ESI, EBX +{$ENDIF} + CALL UnblockOSExceptions + MOV EDX, [ESP] + CALL NotifyExceptFinally + PUSH EAX +{$IFDEF PIC} + MOV EBX, ESI +{$ENDIF} + { + Mark the current exception with the EBP of the handler. If + an exception is raised from the finally block, then this + exception will be orphaned. We will catch this later, when + we clean up the next except block to complete execution. + See DoneExcept. + } + MOV [EAX].TRaisedException.HandlerEBP, EBP + CALL EDX + POP EAX + { + We executed the finally handler without adverse reactions. + It's safe to clear the marker now. + } + MOV [EAX].TRaisedException.HandlerEBP, $FFFFFFFF + PUSH EBP + MOV EBP, ESP + CALL SysRaiseException // Should be using resume here +{$ENDIF} +{$IFDEF MSWINDOWS} + { -> [ESP+ 4] excPtr: PExceptionRecord } + { [ESP+ 8] errPtr: PExcFrame } + { [ESP+12] ctxPtr: Pointer } + { [ESP+16] dspPtr: Pointer } + { <- EAX return value - always one } + + MOV EAX,[ESP+4] + MOV EDX,[ESP+8] + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JE @@exit + MOV ECX,[EDX].TExcFrame.desc + MOV [EDX].TExcFrame.desc,offset @@exit + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBP,[EDX].TExcFrame.hEBP + ADD ECX,TExcDesc.instructions + CALL NotifyExceptFinally + CALL ECX + + POP EBP + POP EDI + POP ESI + POP EBX + +@@exit: + MOV EAX,1 +{$ENDIF} +end; + + +procedure _HandleAutoException; +{$IFDEF LINUX} +{$IFDEF PC_MAPPED_EXCEPTIONS} +asm + // EAX = TObject reference, or nil + // [ESP] = ret addr + CALL UnblockOSExceptions +// +// The compiler wants the stack to look like this: +// ESP+4-> HRESULT +// ESP+0-> ret addr +// +// Make it so. +// + POP EDX + PUSH 8000FFFFH + PUSH EDX + + OR EAX, EAX // Was this a method call? + JE @@Done + + PUSH EAX + CALL CurrentException + MOV EDX, [EAX].TRaisedException.ExceptObject + MOV ECX, [EAX].TRaisedException.ExceptionAddr; + POP EAX + MOV EAX, [EAX] + CALL [EAX].vmtSafeCallException.Pointer; + MOV [ESP+4], EAX +@@Done: + CALL _DoneExcept +end; +{$ELSE} +begin + Error(reSafeCallError); //!! +end; +{$ENDIF} +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + { -> [ESP+ 4] excPtr: PExceptionRecord } + { [ESP+ 8] errPtr: PExcFrame } + { [ESP+12] ctxPtr: Pointer } + { [ESP+16] dspPtr: Pointer } + { <- EAX return value - always one } + + MOV EAX,[ESP+4] + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JNE @@exit + + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + CLD + CALL _FpuInit + JE @@DelphiException + CMP BYTE PTR JITEnable,0 + JBE @@DelphiException + CMP BYTE PTR DebugHook,0 + JA @@DelphiException + +@@DoUnhandled: + LEA EAX,[ESP+4] + PUSH EAX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + JE @@exit + MOV EAX,[ESP+4] + JMP @@GoUnwind + +@@DelphiException: + CMP BYTE PTR JITEnable,1 + JBE @@GoUnwind + CMP BYTE PTR DebugHook,0 + JA @@GoUnwind + JMP @@DoUnhandled + +@@GoUnwind: + OR [EAX].TExceptionRecord.ExceptionFlags,cUnwinding + + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EDX,[ESP+8+3*4] + + PUSH 0 + PUSH EAX + PUSH offset @@returnAddress + PUSH EDX + CALL RtlUnwindProc + +@@returnAddress: + POP EBP + POP EDI + POP ESI + MOV EAX,[ESP+4] + MOV EBX,8000FFFFH + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + JNE @@done + + MOV EDX,[EAX].TExceptionRecord.ExceptObject + MOV ECX,[EAX].TExceptionRecord.ExceptAddr + MOV EAX,[ESP+8] + MOV EAX,[EAX].TExcFrame.SelfOfMethod + TEST EAX,EAX + JZ @@freeException + MOV EBX,[EAX] + CALL [EBX].vmtSafeCallException.Pointer + MOV EBX,EAX +@@freeException: + MOV EAX,[ESP+4] + MOV EAX,[EAX].TExceptionRecord.ExceptObject + CALL TObject.Free +@@done: + XOR EAX,EAX + MOV ESP,[ESP+8] + POP ECX + MOV FS:[EAX],ECX + POP EDX + POP EBP + LEA EDX,[EDX].TExcDesc.instructions + POP ECX + JMP EDX +@@exit: + MOV EAX,1 +end; +{$ENDIF} + + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _RaiseAtExcept; +asm + { -> EAX Pointer to exception object } + { -> EDX Purported addr of exception } + { Be careful: EBX is not set up in PIC mode. } + { Outward bound calls must go through an exported fn, like SysRaiseException } + OR EAX, EAX + JNE @@GoAhead + MOV EAX, 216 + CALL _RunError + +@@GoAhead: + CALL BlockOSExceptions + PUSH EBP + MOV EBP, ESP + CALL NotifyReRaise + CALL AllocateException + CALL SysRaiseException + { + This can only return if there was a terrible error. In this event, + we have to bail out. + } + JMP _Run0Error +end; +{$ENDIF} + +procedure _RaiseExcept; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + { -> EAX Pointer to exception object } + MOV EDX, [ESP] + JMP _RaiseAtExcept +{$ENDIF} +{$IFDEF MSWINDOWS} + { When making changes to the way Delphi Exceptions are raised, } + { please realize that the C++ Exception handling code reraises } + { some exceptions as Delphi Exceptions. Of course we want to } + { keep exception raising compatible between Delphi and C++, so } + { when you make changes here, consult with the relevant C++ } + { exception handling engineer. The C++ code is in xx.cpp, in } + { the RTL sources, in function tossAnException. } + + { -> EAX Pointer to exception object } + { [ESP] Error address } + + OR EAX, EAX + JNE @@GoAhead + MOV EAX, 216 + CALL _RunError +@@GoAhead: + POP EDX + + PUSH ESP + PUSH EBP + PUSH EDI + PUSH ESI + PUSH EBX + PUSH EAX { pass class argument } + PUSH EDX { pass address argument } + + PUSH ESP { pass pointer to arguments } + PUSH 7 { there are seven arguments } + PUSH cNonContinuable { we can't continue execution } + PUSH cDelphiException { our magic exception code } + PUSH EDX { pass the user's return address } + JMP RaiseExceptionProc +{$ENDIF} +end; + + +{$IFDEF PC_MAPPED_EXCEPTIONS} +{ + Used in the PC mapping exception implementation to handle exceptions in constructors. +} +procedure _ClassHandleException; +asm + { + EAX = Ptr to TRaisedException + EDX = self + ECX = top flag + } + TEST DL, DL + JE _RaiseAgain + MOV ECX,[EAX] + MOV DL,$81 + PUSH EAX + CALL dword ptr [ECX].vmtDestroy + POP EAX + CALL _ClassDestroy + JMP _RaiseAgain +end; +{$ENDIF} + +procedure _RaiseAgain; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + CALL CurrentException +// The following notifies the debugger of a reraise of exceptions. This will +// be supported in a later release, but is disabled for now. +// PUSH EAX +// MOV EDX, [EAX].TRaisedException.ExceptionAddr +// MOV EAX, [EAX].TRaisedException.ExceptObject +// CALL NotifyReRaise { Tell the debugger } +// POP EAX + TEST [EAX].TRaisedException.Flags, excIsBeingHandled + JZ @@DoIt + OR [EAX].TRaisedException.Flags, excIsBeingReRaised +@@DoIt: + MOV EDX, [ESP] { Get the user's addr } + JMP SysRaiseException +{$ENDIF} +{$IFDEF MSWINDOWS} + { -> [ESP ] return address to user program } + { [ESP+ 4 ] raise list entry (4 dwords) } + { [ESP+ 4+ 4*4] saved topmost frame } + { [ESP+ 4+ 5*4] saved registers (4 dwords) } + { [ESP+ 4+ 9*4] return address to OS } + { -> [ESP+ 4+10*4] excPtr: PExceptionRecord } + { [ESP+ 8+10*4] errPtr: PExcFrame } + + { Point the error handler of the exception frame to something harmless } + + MOV EAX,[ESP+8+10*4] + MOV [EAX].TExcFrame.desc,offset @@exit + + { Pop the RaiseList } + + CALL SysInit.@GetTLS + MOV EDX,[EAX].RaiseListPtr + MOV ECX,[EDX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,ECX + + { Destroy any objects created for non-delphi exceptions } + + MOV EAX,[EDX].TRaiseFrame.ExceptionRecord + AND [EAX].TExceptionRecord.ExceptionFlags,NOT cUnwinding + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + JE @@delphiException + MOV EAX,[EDX].TRaiseFrame.ExceptObject + CALL TObject.Free + CALL NotifyReRaise + +@@delphiException: + + XOR EAX,EAX + ADD ESP,5*4 + MOV EDX,FS:[EAX] + POP ECX + MOV EDX,[EDX].TExcFrame.next + MOV [ECX].TExcFrame.next,EDX + + POP EBP + POP EDI + POP ESI + POP EBX +@@exit: + MOV EAX,1 +{$ENDIF} +end; + +{$IFDEF DEBUG_EXCEPTIONS} +procedure NoteDE; +begin + Writeln('DoneExcept: Skipped the destructor'); +end; + +procedure NoteDE2; +begin + Writeln('DoneExcept: Destroyed the object'); +end; +{$ENDIF} + +{$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; +var + Exc: PRaisedException; + RefCount: Integer; + ExcObj: Pointer; + ExcAddr: Pointer; +begin + asm + MOV Exc, EAX + end; + + if (Exc^.Flags and excIsBeingReRaised) = 0 then + begin + RefCount := Exc^.RefCount; + ExcObj := Exc^.ExceptObject; + ExcAddr := Exc^.ExceptionAddr; + Exc^.RefCount := 1; + FreeException; + _DoneExcept; + Exc := AllocateException(ExcObj, ExcAddr); + Exc^.RefCount := RefCount; + end; + + Exc^.Flags := Exc^.Flags and not (excIsBeingReRaised or excIsBeingHandled); + + SysRaiseException(Exc); +end; +{$ENDIF} + +procedure _DoneExcept; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + CALL FreeException + OR EAX, EAX + JE @@Done + CALL TObject.Free +@@Done: + { + Take a peek at the next exception object on the stack. + If its EBP marker is at an address lower than our current + EBP, then we know that it was orphaned when an exception was + thrown from within the execution of a finally block. We clean + it up now, so that we won't leak exception records/objects. + } + CALL CurrentException + OR EAX, EAX + JE @@Done2 + CMP [EAX].TRaisedException.HandlerEBP, EBP + JA @@Done2 + CALL FreeException + OR EAX, EAX + JE @@Done2 + CALL TObject.Free +@@Done2: +{$ENDIF} +{$IFDEF MSWINDOWS} + { -> [ESP+ 4+10*4] excPtr: PExceptionRecord } + { [ESP+ 8+10*4] errPtr: PExcFrame } + + { Pop the RaiseList } + + CALL SysInit.@GetTLS + MOV EDX,[EAX].RaiseListPtr + MOV ECX,[EDX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,ECX + + { Destroy exception object } + + MOV EAX,[EDX].TRaiseFrame.ExceptObject + CALL TObject.Free + + POP EDX + MOV ESP,[ESP+8+9*4] + XOR EAX,EAX + POP ECX + MOV FS:[EAX],ECX + POP EAX + POP EBP + CALL NotifyTerminate + JMP EDX +{$ENDIF} +end; + +{$IFNDEF PC_MAPPED_EXCEPTIONS} +procedure _TryFinallyExit; +asm +{$IFDEF MSWINDOWS} + XOR EDX,EDX + MOV ECX,[ESP+4].TExcFrame.desc + MOV EAX,[ESP+4].TExcFrame.next + ADD ECX,TExcDesc.instructions + MOV FS:[EDX],EAX + CALL ECX +@@1: RET 12 +{$ENDIF} +end; +{$ENDIF} + + +var + InitContext: TInitContext; + +{$IFNDEF PC_MAPPED_EXCEPTIONS} +procedure MapToRunError(P: PExceptionRecord); stdcall; +const + STATUS_ACCESS_VIOLATION = $C0000005; + STATUS_ARRAY_BOUNDS_EXCEEDED = $C000008C; + STATUS_FLOAT_DENORMAL_OPERAND = $C000008D; + STATUS_FLOAT_DIVIDE_BY_ZERO = $C000008E; + STATUS_FLOAT_INEXACT_RESULT = $C000008F; + STATUS_FLOAT_INVALID_OPERATION = $C0000090; + STATUS_FLOAT_OVERFLOW = $C0000091; + STATUS_FLOAT_STACK_CHECK = $C0000092; + STATUS_FLOAT_UNDERFLOW = $C0000093; + STATUS_INTEGER_DIVIDE_BY_ZERO = $C0000094; + STATUS_INTEGER_OVERFLOW = $C0000095; + STATUS_PRIVILEGED_INSTRUCTION = $C0000096; + STATUS_STACK_OVERFLOW = $C00000FD; + STATUS_CONTROL_C_EXIT = $C000013A; +var + ErrCode: Byte; +begin + case P.ExceptionCode of + STATUS_INTEGER_DIVIDE_BY_ZERO: ErrCode := 200; { reDivByZero } + STATUS_ARRAY_BOUNDS_EXCEEDED: ErrCode := 201; { reRangeError } + STATUS_FLOAT_OVERFLOW: ErrCode := 205; { reOverflow } + STATUS_FLOAT_INEXACT_RESULT, + STATUS_FLOAT_INVALID_OPERATION, + STATUS_FLOAT_STACK_CHECK: ErrCode := 207; { reInvalidOp } + STATUS_FLOAT_DIVIDE_BY_ZERO: ErrCode := 200; { reZeroDivide } + STATUS_INTEGER_OVERFLOW: ErrCode := 215; { reIntOverflow} + STATUS_FLOAT_UNDERFLOW, + STATUS_FLOAT_DENORMAL_OPERAND: ErrCode := 206; { reUnderflow } + STATUS_ACCESS_VIOLATION: ErrCode := 216; { reAccessViolation } + STATUS_PRIVILEGED_INSTRUCTION: ErrCode := 218; { rePrivInstruction } + STATUS_CONTROL_C_EXIT: ErrCode := 217; { reControlBreak } + STATUS_STACK_OVERFLOW: ErrCode := 202; { reStackOverflow } + else ErrCode := 255; + end; + RunErrorAt(ErrCode, P.ExceptionAddress); +end; + +procedure _ExceptionHandler; +asm + MOV EAX,[ESP+4] + + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JNE @@exit +{$IFDEF MSWINDOWS} + CMP BYTE PTR DebugHook,0 + JA @@ExecuteHandler + LEA EAX,[ESP+4] + PUSH EAX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + JNE @@ExecuteHandler + JMP @@exit +{$ENDIF} + +@@ExecuteHandler: + MOV EAX,[ESP+4] + CLD + CALL _FpuInit + MOV EDX,[ESP+8] + + PUSH 0 + PUSH EAX + PUSH offset @@returnAddress + PUSH EDX + CALL RtlUnwindProc + +@@returnAddress: + MOV EBX,[ESP+4] + CMP [EBX].TExceptionRecord.ExceptionCode,cDelphiException + MOV EDX,[EBX].TExceptionRecord.ExceptAddr + MOV EAX,[EBX].TExceptionRecord.ExceptObject + JE @@DelphiException2 + + MOV EDX,ExceptObjProc + TEST EDX,EDX + JE MapToRunError + MOV EAX,EBX + CALL EDX + TEST EAX,EAX + JE MapToRunError + MOV EDX,[EBX].TExceptionRecord.ExceptionAddress + +@@DelphiException2: + + CALL NotifyUnhandled + MOV ECX,ExceptProc + TEST ECX,ECX + JE @@noExceptProc + CALL ECX { call ExceptProc(ExceptObject, ExceptAddr) } + +@@noExceptProc: + MOV ECX,[ESP+4] + MOV EAX,217 + MOV EDX,[ECX].TExceptionRecord.ExceptAddr + MOV [ESP],EDX + JMP _RunError + +@@exit: + XOR EAX,EAX +end; + +procedure SetExceptionHandler; +asm + XOR EDX,EDX { using [EDX] saves some space over [0] } +{X}// now we come here from another place, and EBP is used above for loop counter +{X}// let us restore it... +{X}PUSH EBP +{X}LEA EBP, [ESP + $50] + + LEA EAX,[EBP-12] + MOV ECX,FS:[EDX] { ECX := head of chain } + MOV FS:[EDX],EAX { head of chain := @exRegRec } + + MOV [EAX].TExcFrame.next,ECX +{$IFDEF PIC} + LEA EDX, [EBX]._ExceptionHandler + MOV [EAX].TExcFrame.desc, EDX +{$ELSE} + MOV [EAX].TExcFrame.desc,offset _ExceptionHandler +{$ENDIF} + MOV [EAX].TExcFrame.hEBP,EBP +{$IFDEF PIC} + MOV [EBX].InitContext.ExcFrame,EAX +{$ELSE} + MOV InitContext.ExcFrame,EAX +{$ENDIF} +{X}POP EBP +end; + + +procedure UnsetExceptionHandler; +asm + XOR EDX,EDX +{$IFDEF PIC} + MOV EAX,[EBX].InitContext.ExcFrame +{$ELSE} + MOV EAX,InitContext.ExcFrame +{$ENDIF} + TEST EAX,EAX + JZ @@exit + MOV ECX,FS:[EDX] { ECX := head of chain } + CMP EAX,ECX { simple case: our record is first } + JNE @@search + MOV EAX,[EAX] { head of chain := exRegRec.next } + MOV FS:[EDX],EAX + JMP @@exit + +@@loop: + MOV ECX,[ECX] +@@search: + CMP ECX,-1 { at end of list? } + JE @@exit { yes - didn't find it } + CMP [ECX],EAX { is it the next one on the list? } + JNE @@loop { no - look at next one on list } +@@unlink: { yes - unlink our record } + MOV EAX,[EAX] { get next record on list } + MOV [ECX],EAX { unlink our record } +@@exit: +end; +{$ENDIF} // not PC_MAPPED_EXCEPTIONS + +type + TProc = procedure; + +{$IFDEF LINUX} +procedure CallProc(Proc: Pointer; GOT: Cardinal); +asm + PUSH EBX + MOV EBX,EDX + ADD EAX,EBX + CALL EAX + POP EBX +end; +{$ENDIF} + +(*X- Original version... discarded + +procedure FinalizeUnits; +var + Count: Integer; + Table: PUnitEntryTable; + P: Pointer; +begin + if InitContext.InitTable = nil then + exit; + Count := InitContext.InitCount; + Table := InitContext.InitTable^.UnitInfo; +{$IFDEF LINUX} + Inc(Cardinal(Table), InitContext.Module^.GOT); +{$ENDIF} + try + while Count > 0 do + begin + Dec(Count); + InitContext.InitCount := Count; + P := Table^[Count].FInit; + if Assigned(P) then + begin +{$IFDEF LINUX} + CallProc(P, InitContext.Module^.GOT); +{$ENDIF} +{$IFDEF MSWINDOWS} + TProc(P)(); +{$ENDIF} + end; + end; + except + FinalizeUnits; { try to finalize the others } + raise; + end; +end; +X+*) +{X+ see comments in InitUnits below } +//procedure FInitUnits; {X} - renamed to FInitUnitsHard +{X} procedure FInitUnitsHard; +var + Count: Integer; + Table: PUnitEntryTable; + P: procedure; +begin + if InitContext.InitTable = nil then + exit; + Count := InitContext.InitCount; + Table := InitContext.InitTable^.UnitInfo; +{$IFDEF LINUX} + Inc(Cardinal(Table), InitContext.Module^.GOT); +{$ENDIF} + try + while Count > 0 do + begin + Dec(Count); + InitContext.InitCount := Count; + P := Table^[Count].FInit; + if Assigned(P) then +{$IFDEF LINUX} + CallProc(P, InitContext.Module^.GOT); +{$ENDIF} +{$IFDEF MSWINDOWS} + TProc(P)(); +{$ENDIF} + end; + except + {X- rename: FInitUnits; { try to finalize the others } + FInitUnitsHard; + raise; + end; +end; + +// This handler can be set in initialization section of +// unit SysSfIni.pas only. +procedure InitUnitsHard( Table : PUnitEntryTable; Idx, Count : Integer ); +begin + try + InitUnitsLight( Table, Idx, Count ); + except + FInitUnitsHard; + raise; + end; +end; + +{X+ see comments in InitUnits below } +procedure FInitUnitsLight; +var + Count: Integer; + Table: PUnitEntryTable; + P: procedure; +begin + if InitContext.InitTable = nil then + exit; + Count := InitContext.InitCount; + Table := InitContext.InitTable^.UnitInfo; +{$IFDEF LINUX} + Inc(Cardinal(Table), InitContext.Module^.GOT); +{$ENDIF} + while Count > 0 do + begin + Dec(Count); + InitContext.InitCount := Count; + P := Table^[Count].FInit; + if Assigned(P) then +{$IFDEF LINUX} + CallProc(P, InitContext.Module^.GOT); +{$ENDIF} +{$IFDEF MSWINDOWS} + TProc(P)(); +{$ENDIF} + end; +end; + +{X+ see comments in InitUnits below } +procedure InitUnitsLight( Table : PUnitEntryTable; Idx, Count : Integer ); +var P : procedure; + Light : Boolean; +begin + Light := @InitUnitsProc = @InitUnitsLight; + while Idx < Count do + begin + P := Table^[ Idx ].Init; + Inc( Idx ); + InitContext.InitCount := Idx; + if Assigned( P ) then + P; + if Light and (@InitUnitsProc <> @InitUnitsLight) then + begin + InitUnitsProc( Table, Idx, Count ); + break; + end; + end; +end; + +{X+ see comments in body of InitUnits below } + +procedure InitUnits; +var + Count, I: Integer; + Table: PUnitEntryTable; + {X- P: Pointer; } +begin + if InitContext.InitTable = nil then + exit; + Count := InitContext.InitTable^.UnitCount; + I := 0; + Table := InitContext.InitTable^.UnitInfo; +{$IFDEF LINUX} + Inc(Cardinal(Table), InitContext.Module^.GOT); +{$ENDIF} + (*X- by default, Delphi InitUnits uses try-except & raise constructions, + which leads to permanent use of all exception handler routines. + Let us make this by another way. + try + while I < Count do + begin + P := Table^[I].Init; + Inc(I); + InitContext.InitCount := I; + if Assigned(P) then + begin +{$IFDEF LINUX} + CallProc(P, InitContext.Module^.GOT); +{$ENDIF} +{$IFDEF MSWINDOWS} + TProc(P)(); +{$ENDIF} + end; + end; + except + FinalizeUnits; + raise; + end; + X+*) + InitUnitsProc( Table, I, Count ); //{X} +end; + +procedure _PackageLoad(const Table : PackageInfo; Module: PLibModule); +var + SavedContext: TInitContext; +begin + SavedContext := InitContext; + InitContext.DLLInitState := 0; + InitContext.InitTable := Table; + InitContext.InitCount := 0; + InitContext.Module := Module; + InitContext.OuterContext := @SavedContext; + try + InitUnits; + finally + InitContext := SavedContext; + end; +end; + + +procedure _PackageUnload(const Table : PackageInfo; Module: PLibModule); +var + SavedContext: TInitContext; +begin + SavedContext := InitContext; + InitContext.DLLInitState := 0; + InitContext.InitTable := Table; + InitContext.InitCount := Table^.UnitCount; + InitContext.Module := Module; + InitContext.OuterContext := @SavedContext; + try + // FinalizeUnitsProc; + FInitUnitsProc; + finally + InitContext := SavedContext; + end; +end; + +{$IFDEF LINUX} +procedure _StartExe(InitTable: PackageInfo; Module: PLibModule; Argc: Integer; Argv: Pointer); +begin + ArgCount := Argc; + ArgValues := Argv; +{$ENDIF} +{$IFDEF MSWINDOWS} +procedure _StartExe(InitTable: PackageInfo; Module: PLibModule); +begin + RaiseExceptionProc := @RaiseException; + RTLUnwindProc := @RTLUnwind; +{$ENDIF} + InitContext.InitTable := InitTable; + InitContext.InitCount := 0; + InitContext.Module := Module; + MainInstance := Module.Instance; +{$IFNDEF PC_MAPPED_EXCEPTIONS} + {X SetExceptionHandler; - moved to SysSfIni.pas } +{$ENDIF} + IsLibrary := False; + InitUnits; +end; + +{$IFDEF MSWINDOWS} +procedure _StartLib; +asm + { -> EAX InitTable } + { EDX Module } + { ECX InitTLS } + { [ESP+4] DllProc } + { [EBP+8] HInst } + { [EBP+12] Reason } + + { Push some desperately needed registers } + + PUSH ECX + PUSH ESI + PUSH EDI + + { Save the current init context into the stackframe of our caller } + + MOV ESI,offset InitContext + LEA EDI,[EBP- (type TExcFrame) - (type TInitContext)] + MOV ECX,(type TInitContext)/4 + REP MOVSD + + { Setup the current InitContext } + + POP InitContext.DLLSaveEDI + POP InitContext.DLLSaveESI + MOV InitContext.DLLSaveEBP,EBP + MOV InitContext.DLLSaveEBX,EBX + MOV InitContext.InitTable,EAX + MOV InitContext.Module,EDX + LEA ECX,[EBP- (type TExcFrame) - (type TInitContext)] + MOV InitContext.OuterContext,ECX + XOR ECX,ECX + CMP DWORD PTR [EBP+12],0 + JNE @@notShutDown + MOV ECX,[EAX].PackageInfoTable.UnitCount +@@notShutDown: + MOV InitContext.InitCount,ECX + + MOV EAX, offset RaiseException + MOV RaiseExceptionProc, EAX + MOV EAX, offset RTLUnwind + MOV RTLUnwindProc, EAX + + CALL SetExceptionHandler + + MOV EAX,[EBP+12] + INC EAX + MOV InitContext.DLLInitState,AL + DEC EAX + + { Init any needed TLS } + + POP ECX + MOV EDX,[ECX] + MOV InitContext.ExitProcessTLS,EDX + JE @@skipTLSproc + CMP AL,3 // DLL_THREAD_DETACH + JGE @@skipTLSproc // call ExitThreadTLS proc after DLLProc + CALL dword ptr [ECX+EAX*4] +@@skipTLSproc: + + { Call any DllProc } + + PUSH ECX + MOV ECX,[ESP+4] + TEST ECX,ECX + JE @@noDllProc + MOV EAX,[EBP+12] + MOV EDX,[EBP+16] + CALL ECX +@@noDllProc: + + POP ECX + MOV EAX, [EBP+12] + CMP AL,3 // DLL_THREAD_DETACH + JL @@afterDLLproc // don't free TLS on process shutdown + CALL dword ptr [ECX+EAX*4] + +@@afterDLLProc: + + { Set IsLibrary if there was no exe yet } + + CMP MainInstance,0 + JNE @@haveExe + MOV IsLibrary,1 + FNSTCW Default8087CW // save host exe's FPU preferences + +@@haveExe: + + MOV EAX,[EBP+12] + DEC EAX + JNE _Halt0 + CALL InitUnits + RET 4 +end; +{$ENDIF MSWINDOWS} +{$IFDEF LINUX} +procedure _StartLib(Context: PInitContext; Module: PLibModule; DLLProc: TDLLProcEx); +var + TempSwap: TInitContext; +begin + // Context's register save fields are already initialized. + // Save the current InitContext and activate the new Context by swapping them + TempSwap := InitContext; + InitContext := PInitContext(Context)^; + PInitContext(Context)^ := TempSwap; + + InitContext.Module := Module; + InitContext.OuterContext := Context; + + // DLLInitState is initialized by SysInit to 0 for shutdown, 1 for startup + // Inc DLLInitState to distinguish from package init: + // 0 for package, 1 for DLL shutdown, 2 for DLL startup + + Inc(InitContext.DLLInitState); + + if InitContext.DLLInitState = 1 then + begin + InitContext.InitTable := Module.InitTable; + if Assigned(InitContext.InitTable) then + InitContext.InitCount := InitContext.InitTable.UnitCount // shutdown + end + else + begin + Module.InitTable := InitContext.InitTable; // save for shutdown + InitContext.InitCount := 0; // startup + end; + + if Assigned(DLLProc) then + DLLProc(InitContext.DLLInitState-1,0); + + if MainInstance = 0 then { Set IsLibrary if there was no exe yet } + begin + IsLibrary := True; + Default8087CW := Get8087CW; + end; + + if InitContext.DLLInitState = 1 then + _Halt0 + else + InitUnits; +end; +{$ENDIF} + +procedure _InitResStrings; +asm + { -> EAX Pointer to init table } + { record } + { cnt: Integer; } + { tab: array [1..cnt] record } + { variableAddress: Pointer; } + { resStringAddress: Pointer; } + { end; } + { end; } + { EBX = caller's GOT for PIC callers, 0 for non-PIC } + +{$IFDEF MSWINDOWS} + PUSH EBX + XOR EBX,EBX +{$ENDIF} + PUSH EDI + PUSH ESI + MOV EDI,[EBX+EAX] + LEA ESI,[EBX+EAX+4] +@@loop: + MOV EAX,[ESI+4] { load resStringAddress } + MOV EDX,[ESI] { load variableAddress } + ADD EAX,EBX + ADD EDX,EBX + CALL LoadResString + ADD ESI,8 + DEC EDI + JNZ @@loop + + POP ESI + POP EDI +{$IFDEF MSWINDOWS} + POP EBX +{$ENDIF} +end; + +procedure _InitResStringImports; +asm + { -> EAX Pointer to init table } + { record } + { cnt: Integer; } + { tab: array [1..cnt] record } + { variableAddress: Pointer; } + { resStringAddress: ^Pointer; } + { end; } + { end; } + { EBX = caller's GOT for PIC callers, 0 for non-PIC } + +{$IFDEF MSWINDOWS} + PUSH EBX + XOR EBX,EBX +{$ENDIF} + PUSH EDI + PUSH ESI + MOV EDI,[EBX+EAX] + LEA ESI,[EBX+EAX+4] +@@loop: + MOV EAX,[ESI+4] { load address of import } + MOV EDX,[ESI] { load address of variable } + MOV EAX,[EBX+EAX] { load contents of import } + ADD EDX,EBX + CALL LoadResString + ADD ESI,8 + DEC EDI + JNZ @@loop + + POP ESI + POP EDI +{$IFDEF MSWINDOWS} + POP EBX +{$ENDIF} +end; + +procedure _InitImports; +asm + { -> EAX Pointer to init table } + { record } + { cnt: Integer; } + { tab: array [1..cnt] record } + { variableAddress: Pointer; } + { sourceAddress: ^Pointer; } + { sourceOffset: Longint; } + { end; } + { end; } + { EBX = caller's GOT for PIC callers, 0 for non-PIC } + +{$IFDEF MSWINDOWS} + PUSH EBX + XOR EBX,EBX +{$ENDIF} + PUSH EDI + PUSH ESI + MOV EDI,[EBX+EAX] + LEA ESI,[EBX+EAX+4] +@@loop: + MOV EAX,[ESI+4] { load address of import } + MOV EDX,[ESI] { load address of variable } + MOV EAX,[EBX+EAX] { load contents of import } + ADD EAX,[ESI+8] { calc address of variable } + MOV [EBX+EDX],EAX { store result } + ADD ESI,12 + DEC EDI + JNZ @@loop + + POP ESI + POP EDI +{$IFDEF MSWINDOWS} + POP EBX +{$ENDIF} +end; + +{$IFDEF MSWINDOWS} +procedure _InitWideStrings; +asm + { -> EAX Pointer to init table } + { record } + { cnt: Integer; } + { tab: array [1..cnt] record } + { variableAddress: Pointer; } + { stringAddress: ^Pointer; } + { end; } + { end; } + + PUSH EBX + PUSH ESI + MOV EBX,[EAX] + LEA ESI,[EAX+4] +@@loop: + MOV EDX,[ESI+4] { load address of string } + MOV EAX,[ESI] { load address of variable } + CALL _WStrAsg + ADD ESI,8 + DEC EBX + JNZ @@loop + + POP ESI + POP EBX +end; +{$ENDIF} + +var + runErrMsg: array[0..29] of Char = 'Runtime error at 00000000'#0; + // columns: 0123456789012345678901234567890 + errCaption: array[0..5] of Char = 'Error'#0; + +procedure MakeErrorMessage; +const + dig : array [0..15] of Char = '0123456789ABCDEF'; +var + digit: Byte; + Temp: Integer; + Addr: Cardinal; +begin + digit := 16; + Temp := ExitCode; + repeat + runErrMsg[digit] := Char(Ord('0') + (Temp mod 10)); + Temp := Temp div 10; + Dec(digit); + until Temp = 0; + digit := 28; + Addr := Cardinal(ErrorAddr); + repeat + runErrMsg[digit] := dig[Addr and $F]; + Addr := Addr div 16; + Dec(digit); + until Addr = 0; +end; + + +procedure ExitDll; +asm + { Return False if ExitCode <> 0, and set ExitCode to 0 } + XOR EAX,EAX +{$IFDEF PIC} + MOV ECX, [EBX].ExitCode + XCHG EAX, [ECX] +{$ELSE} + XCHG EAX, ExitCode +{$ENDIF} + NEG EAX + SBB EAX,EAX + INC EAX + { Restore the InitContext } +{$IFDEF PIC} + LEA EDI, [EBX].InitContext +{$ELSE} + MOV EDI, offset InitContext +{$ENDIF} + + MOV EBX,[EDI].TInitContext.DLLSaveEBX + MOV EBP,[EDI].TInitContext.DLLSaveEBP + PUSH [EDI].TInitContext.DLLSaveESI + PUSH [EDI].TInitContext.DLLSaveEDI + + MOV ESI,[EDI].TInitContext.OuterContext + MOV ECX,(type TInitContext)/4 + REP MOVSD + POP EDI + POP ESI + + LEAVE +{$IFDEF MSWINDOWS} + RET 12 +{$ENDIF} +{$IFDEF LINUX} + RET +{$ENDIF} +end; + +var ErrorMessageOutProc : procedure = DummyProc; + +procedure ErrorMessageBox; +begin + MakeErrorMessage; + if not NoErrMsg then + MessageBox(0, runErrMsg, errCaption, 0); +end; + +procedure UseErrorMessageBox; +begin + ErrorMessageOutProc := ErrorMessageBox; +end; + +procedure ErrorMessageWrite; +begin + MakeErrorMessage; + WriteLn(PChar(@runErrMsg)); +end; + +procedure UseErrorMessageWrite; +begin + ErrorMessageOutProc := ErrorMessageWrite; +end; + +procedure DoCloseInputOutput; +begin + Close( Input ); + Close( Output ); + Close(ErrOutput); +end; + +var CloseInputOutput : procedure = DummyProc; + +procedure UseInputOutput; +begin + if not assigned( CloseInputOutput ) then + begin + CloseInputOutput := DoCloseInputOutput; + //_Assign( Input, '' ); was for D5 so - changed + //_Assign( Output, '' ); was for D5 so - changed + TTextRec(Input).Mode := fmClosed; + TTextRec(Output).Mode := fmClosed; + TTextRec(ErrOutput).Mode := fmClosed; + end; +end; + +// {X}- +(*X- +procedure WriteErrorMessage; +{$IFDEF MSWINDOWS} +var + Dummy: Cardinal; +begin + if IsConsole then + begin + with TTextRec(Output) do + begin + if (Mode = fmOutput) and (BufPos > 0) then + TTextIOFunc(InOutFunc)(TTextRec(Output)); // flush out text buffer + end; + WriteFile(GetStdHandle(STD_OUTPUT_HANDLE), runErrMsg, Sizeof(runErrMsg), Dummy, nil); + WriteFile(GetStdHandle(STD_OUTPUT_HANDLE), sLineBreak, 2, Dummy, nil); + end + else if not NoErrMsg then + MessageBox(0, runErrMsg, errCaption, 0); +{$ENDIF} +{$IFDEF LINUX} +var + c: Char; +begin + with TTextRec(Output) do + begin + if (Mode = fmOutput) and (BufPos > 0) then + TTextIOFunc(InOutFunc)(TTextRec(Output)); // flush out text buffer + end; + __write(STDERR_FILENO, @runErrMsg, Sizeof(runErrMsg)-1); + c := sLineBreak; + __write(STDERR_FILENO, @c, 1); +{$ENDIF} +end; +X+*) + +procedure _Halt0; +var + P: procedure; +begin +{$IFDEF LINUX} + if (ExitCode <> 0) and CoreDumpEnabled then + __raise(SIGABRT); +{$ENDIF} + + if InitContext.DLLInitState = 0 then + while ExitProc <> nil do + begin + @P := ExitProc; + ExitProc := nil; + P; + end; + + { If there was some kind of runtime error, alert the user } + + if ErrorAddr <> nil then + begin + {X+} + ErrorMessageOutProc; + { + MakeErrorMessage; + if IsConsole then + WriteLn(PChar(@runErrMsg)) + else if not NoErrMsg then + MessageBox(0, runErrMsg, errCaption, 0); + } {X-} + {X- As it is said by Alexey Torgashin, it is better not to clear ErrorAddr + to make possible check ErrorAddr <> nil in finalization of rest units. + If you want, you can uncomment it again: } + //ErrorAddr := nil; + {X+} +end; + + { This loop exists because we might be nested in PackageLoad calls when } + { Halt got called. We need to unwind these contexts. } + + while True do + begin + + { If we are a library, and we are starting up fine, there are no units to finalize } + + if (InitContext.DLLInitState = 2) and (ExitCode = 0) then + InitContext.InitCount := 0; + + { Undo any unit initializations accomplished so far } + + FInitUnitsProc; + + if (InitContext.DLLInitState <= 1) or (ExitCode <> 0) then + begin + if InitContext.Module <> nil then + with InitContext do + begin + UnregisterModule(Module); +{$IFDEF PC_MAPPED_EXCEPTIONS} + SysUnregisterIPLookup(Module.CodeSegStart); +{$ENDIF} + if (Module.ResInstance <> Module.Instance) and (Module.ResInstance <> 0) then + FreeLibrary(Module.ResInstance); + end; + end; + +{$IFNDEF PC_MAPPED_EXCEPTIONS} + UnsetExceptionHandlerProc; +{$ENDIF} + +{$IFDEF MSWINDOWS} + if InitContext.DllInitState = 1 then + InitContext.ExitProcessTLS; +{$ENDIF} + + if InitContext.DllInitState <> 0 then + ExitDll; + + if InitContext.OuterContext = nil then + begin + { + If an ExitProcessProc is set, we call it. Note that at this + point the RTL is completely shutdown. The only thing this is used + for right now is the proper semantic handling of signals under Linux. + } + if Assigned(ExitProcessProc) then + ExitProcessProc; + ExitProcess(ExitCode); + end; + + InitContext := InitContext.OuterContext^ + end; +end; + +procedure _Halt; +begin + ExitCode := Code; + _Halt0; +end; + + +procedure _Run0Error; +{$IFDEF PUREPASCAL} +begin + _RunError(0); // loses return address +end; +{$ELSE} +asm + XOR EAX,EAX + JMP _RunError +end; +{$ENDIF} + + +procedure _RunError(errorCode: Byte); +{$IFDEF PUREPASCAL} +begin + ErrorAddr := Pointer(-1); // no return address available + Halt(errorCode); +end; +{$ELSE} +asm +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX, EAX + POP EAX + MOV ECX, [EBX].ErrorAddr + POP [ECX] +{$ELSE} + POP ErrorAddr +{$ENDIF} + JMP _Halt +end; +{$ENDIF} + +procedure _UnhandledException; +type TExceptProc = procedure (Obj: TObject; Addr: Pointer); +begin + if Assigned(ExceptProc) then + TExceptProc(ExceptProc)(ExceptObject, ExceptAddr) + else + RunError(230); +end; + +procedure _Assert(const Message, Filename: AnsiString; LineNumber: Integer); +{$IFDEF PUREPASCAL} +begin + if Assigned(AssertErrorProc) then + AssertErrorProc(Message, Filename, LineNumber, Pointer(-1)) + else + Error(reAssertionFailed); // loses return address +end; +{$ELSE} +asm + PUSH EBX +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + MOV EBX, EAX + MOV EAX, [EBX].AssertErrorProc + CMP [EAX], 0 + POP ECX + POP EAX +{$ELSE} + CMP AssertErrorProc,0 +{$ENDIF} + JNZ @@1 + MOV AL,reAssertionFailed + CALL Error + JMP @@exit + +@@1: PUSH [ESP+4].Pointer +{$IFDEF PIC} + MOV EBX, [EBX].AssertErrorProc + CALL [EBX] +{$ELSE} + CALL AssertErrorProc +{$ENDIF} +@@exit: + POP EBX +end; +{$ENDIF} + +type + PThreadRec = ^TThreadRec; + TThreadRec = record + Func: TThreadFunc; + Parameter: Pointer; + end; + +{$IFDEF MSWINDOWS} +function ThreadWrapper(Parameter: Pointer): Integer; stdcall; +{$ELSE} +function ThreadWrapper(Parameter: Pointer): Pointer; cdecl; +{$ENDIF} +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + { Mark the top of the stack with a signature } + PUSH UNWINDFI_TOPOFSTACK +{$ENDIF} + CALL _FpuInit + PUSH EBP +{$IFNDEF PC_MAPPED_EXCEPTIONS} + XOR ECX,ECX + PUSH offset _ExceptionHandler + MOV EDX,FS:[ECX] + PUSH EDX + MOV FS:[ECX],ESP +{$ENDIF} + MOV EAX,Parameter + + MOV ECX,[EAX].TThreadRec.Parameter + MOV EDX,[EAX].TThreadRec.Func + PUSH ECX + PUSH EDX + CALL _FreeMem + POP EDX + POP EAX + CALL EDX + +{$IFNDEF PC_MAPPED_EXCEPTIONS} + XOR EDX,EDX + POP ECX + MOV FS:[EDX],ECX + POP ECX +{$ENDIF} + POP EBP +{$IFDEF PC_MAPPED_EXCEPTIONS} + { Ditch our TOS marker } + ADD ESP, 4 +{$ENDIF} +end; + + +{$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} + +{$IFDEF LINUX} +function BeginThread(Attribute: PThreadAttr; + ThreadFunc: TThreadFunc; + Parameter: Pointer; + var ThreadId: Cardinal): Integer; +var + P: PThreadRec; +begin + if Assigned(BeginThreadProc) then + Result := BeginThreadProc(Attribute, ThreadFunc, Parameter, ThreadId) + else + begin + New(P); + P.Func := ThreadFunc; + P.Parameter := Parameter; + IsMultiThread := True; + Result := _pthread_create(ThreadID, Attribute, @ThreadWrapper, P); + end; +end; + +procedure EndThread(ExitCode: Integer); +begin + if Assigned(EndThreadProc) then + EndThreadProc(ExitCode); + // No "else" required since EndThreadProc does not (!!should not!!) return. + _pthread_detach(GetCurrentThreadID); + _pthread_exit(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); +{$IFDEF PUREPASCAL} +var + P: PStrRec; +begin + if Pointer(S) <> nil then + begin + P := Pointer(Integer(S) - Sizeof(StrRec)); + Pointer(S) := nil; + if P.refCnt > 0 then + if InterlockedDecrement(P.refCnt) = 0 then + FreeMem(P); + end; +end; +{$ELSE} +asm + { -> EAX pointer to str } + + MOV EDX,[EAX] { fetch str } + TEST EDX,EDX { if nil, nothing to do } + JE @@done + MOV dword ptr [EAX],0 { clear str } + MOV ECX,[EDX-skew].StrRec.refCnt { fetch refCnt } + DEC ECX { if < 0: literal str } + JL @@done + { LOCK} DEC [EDX-skew].StrRec.refCnt {NONthreadsafe dec refCount } + JNE @@done + PUSH EAX + LEA EAX,[EDX-skew].StrRec.refCnt { if refCnt now zero, deallocate} + CALL _FreeMem + POP EAX +@@done: +end; +{$ENDIF} + +procedure _LStrArrayClr(var StrArray; cnt: longint); +{$IFDEF PUREPASCAL} +var + P: Pointer; +begin + P := @StrArray; + while cnt > 0 do + begin + _LStrClr(P^); + Dec(cnt); + Inc(Integer(P), sizeof(Pointer)); + end; +end; +{$ELSE} +asm + { -> EAX pointer to str } + { EDX cnt } + + PUSH EBX + PUSH ESI + MOV EBX,EAX + MOV ESI,EDX + +@@loop: + MOV EDX,[EBX] { fetch str } + TEST EDX,EDX { if nil, nothing to do } + JE @@doneEntry + MOV dword ptr [EBX],0 { clear str } + MOV ECX,[EDX-skew].StrRec.refCnt { fetch refCnt } + DEC ECX { if < 0: literal str } + JL @@doneEntry + { LOCK} DEC [EDX-skew].StrRec.refCnt { threadsafe dec refCount } + JNE @@doneEntry + LEA EAX,[EDX-skew].StrRec.refCnt { if refCnt now zero, deallocate} + CALL _FreeMem +@@doneEntry: + ADD EBX,4 + DEC ESI + JNE @@loop + + POP ESI + POP EBX +end; +{$ENDIF} + +{ 99.03.11 + This function is used when assigning to global variables. + + Literals are copied to prevent a situation where a dynamically + allocated DLL or package assigns a literal to a variable and then + is unloaded -- thereby causing the string memory (in the code + segment of the DLL) to be removed -- and therefore leaving the + global variable pointing to invalid memory. +} +procedure _LStrAsg(var dest; const source); +{$IFDEF PUREPASCAL} +var + S, D: Pointer; + P: PStrRec; + Temp: Longint; +begin + S := Pointer(source); + if S <> nil then + begin + P := PStrRec(Integer(S) - sizeof(StrRec)); + if P.refCnt < 0 then // make copy of string literal + begin + Temp := P.length; + S := _NewAnsiString(Temp); + Move(Pointer(source)^, S^, Temp); + P := PStrRec(Integer(S) - sizeof(StrRec)); + end; + InterlockedIncrement(P.refCnt); + end; + + D := Pointer(dest); + Pointer(dest) := S; + if D <> nil then + begin + P := PStrRec(Integer(D) - sizeof(StrRec)); + if P.refCnt > 0 then + if InterlockedDecrement(P.refCnt) = 0 then + FreeMem(P); + end; +end; +{$ELSE} +asm + { -> EAX pointer to dest str } + { -> EDX pointer to source str } + + TEST EDX,EDX { have a source? } + JE @@2 { no -> jump } + + MOV ECX,[EDX-skew].StrRec.refCnt + INC ECX + JG @@1 { literal string -> jump not taken } + + PUSH EAX + PUSH EDX + MOV EAX,[EDX-skew].StrRec.length + CALL _NewAnsiString + MOV EDX,EAX + POP EAX + PUSH EDX + MOV ECX,[EAX-skew].StrRec.length + CALL Move + POP EDX + POP EAX + JMP @@2 + +@@1: + { LOCK} INC [EDX-skew].StrRec.refCnt + +@@2: XCHG EDX,[EAX] + TEST EDX,EDX + JE @@3 + MOV ECX,[EDX-skew].StrRec.refCnt + DEC ECX + JL @@3 + { LOCK} DEC [EDX-skew].StrRec.refCnt + JNE @@3 + LEA EAX,[EDX-skew].StrRec.refCnt + CALL _FreeMem +@@3: +end; +{$ENDIF} + +procedure _LStrLAsg(var dest; const source); +{$IFDEF PUREPASCAL} +var + P: Pointer; +begin + P := Pointer(source); + _LStrAddRef(P); + P := Pointer(dest); + Pointer(dest) := Pointer(source); + _LStrClr(P); +end; +{$ELSE} +asm +{ -> EAX pointer to dest } +{ EDX source } + + TEST EDX,EDX + JE @@sourceDone + + { bump up the ref count of the source } + + MOV ECX,[EDX-skew].StrRec.refCnt + INC ECX + JLE @@sourceDone { literal assignment -> jump taken } + { LOCK} INC [EDX-skew].StrRec.refCnt +@@sourceDone: + + { we need to release whatever the dest is pointing to } + + XCHG EDX,[EAX] { fetch str } + TEST EDX,EDX { if nil, nothing to do } + JE @@done + MOV ECX,[EDX-skew].StrRec.refCnt { fetch refCnt } + DEC ECX { if < 0: literal str } + JL @@done + { LOCK} DEC [EDX-skew].StrRec.refCnt { threadsafe dec refCount } + JNE @@done + LEA EAX,[EDX-skew].StrRec.refCnt { if refCnt now zero, deallocate} + CALL _FreeMem +@@done: +end; +{$ENDIF} + +function _NewAnsiString(length: Longint): Pointer; +{$IFDEF PUREPASCAL} +var + P: PStrRec; +begin + Result := nil; + if length <= 0 then Exit; + // Alloc an extra null for strings with even length. This has no actual cost + // since the allocator will round up the request to an even size anyway. + // All widestring allocations have even length, and need a double null terminator. + GetMem(P, length + sizeof(StrRec) + 1 + ((length + 1) and 1)); + Result := Pointer(Integer(P) + sizeof(StrRec)); + P.length := length; + P.refcnt := 1; + PWideChar(Result)[length div 2] := #0; // length guaranteed >= 2 +end; +{$ELSE} +asm + { -> EAX length } + { <- EAX pointer to new string } + + TEST EAX,EAX + JLE @@null + PUSH EAX + ADD EAX,rOff+2 // one or two nulls (Ansi/Wide) + AND EAX, not 1 // round up to even length + PUSH EAX + CALL _GetMem + POP EDX // actual allocated length (>= 2) + MOV word ptr [EAX+EDX-2],0 // double null terminator + ADD EAX,rOff + POP EDX // requested string length + MOV [EAX-skew].StrRec.length,EDX + MOV [EAX-skew].StrRec.refCnt,1 + RET +@@null: + XOR EAX,EAX +end; +{$ENDIF} + +procedure _LStrFromPCharLen(var Dest: AnsiString; Source: PAnsiChar; Length: Integer); +asm + { -> EAX pointer to dest } + { EDX source } + { ECX length } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + { allocate new string } + + MOV EAX,EDI + + CALL _NewAnsiString + MOV ECX,EDI + MOV EDI,EAX + + TEST ESI,ESI + JE @@noMove + + MOV EDX,EAX + MOV EAX,ESI + CALL Move + + { assign the result to dest } + +@@noMove: + MOV EAX,EBX + CALL _LStrClr + MOV [EBX],EDI + + POP EDI + POP ESI + POP EBX +end; + +{$IFDEF LINUX} +function BufConvert(var Dest; DestBytes: Integer; + const Source; SrcBytes: Integer; + context: Integer): Integer; +var + SrcBytesLeft, DestBytesLeft: Integer; + s, d: Pointer; +begin + if context = -1 then + begin + Result := -1; + Exit; + end; + // make copies of params... iconv modifies param ptrs + DestBytesLeft := DestBytes; + SrcBytesLeft := SrcBytes; + s := Pointer(Source); + d := Pointer(Dest); + if (SrcBytes = 0) or (DestBytes = 0) then + Result := 0 + else + begin + Result := iconv(context, s, SrcBytesLeft, d, DestBytesLeft); + while (SrcBytesLeft > 0) and (DestBytesLeft > 0) + and (Result = -1) and (GetLastError = 7) do + begin + Result := iconv(context, s, SrcBytesLeft, d, DestBytesLeft); + end; + if Result <> -1 then + Result := DestBytes - DestBytesLeft; + end; + iconv_close(context); +end; +{$ENDIF} + +function CharFromWChar(CharDest: PChar; DestBytes: Integer; const WCharSource: PWideChar; SrcChars: Integer): Integer; +begin +{$IFDEF LINUX} + Result := BufConvert(CharDest, DestBytes, WCharSource, SrcChars * SizeOf(WideChar), + iconv_open(nl_langinfo(_NL_CTYPE_CODESET_NAME), 'UNICODELITTLE')); +{$ENDIF} +{$IFDEF MSWINDOWS} + Result := WideCharToMultiByte(0, 0, WCharSource, SrcChars, + CharDest, DestBytes, nil, nil); +{$ENDIF} +end; + +function WCharFromChar(WCharDest: PWideChar; DestChars: Integer; const CharSource: PChar; SrcBytes: Integer): Integer; +begin +{$IFDEF LINUX} + Result := BufConvert(WCharDest, DestChars * SizeOf(WideChar), CharSource, SrcBytes, + iconv_open('UNICODELITTLE', nl_langinfo(_NL_CTYPE_CODESET_NAME))) div sizeof(WideChar); +{$ENDIF} +{$IFDEF MSWINDOWS} + Result := MultiByteToWideChar(0, 0, CharSource, SrcBytes, + WCharDest, DestChars); +{$ENDIF} +end; + +procedure _LStrFromPWCharLen(var Dest: AnsiString; Source: PWideChar; Length: Integer); +var + DestLen: Integer; + Buffer: array[0..4095] of Char; +begin + if Length <= 0 then + begin + _LStrClr(Dest); + Exit; + end; + if Length+1 < (High(Buffer) div sizeof(WideChar)) then + begin + DestLen := CharFromWChar(Buffer, High(Buffer), Source, Length); + if DestLen >= 0 then + begin + _LStrFromPCharLen(Dest, Buffer, DestLen); + Exit; + end; + end; + + DestLen := (Length + 1) * sizeof(WideChar); + SetLength(Dest, DestLen); // overallocate, trim later + DestLen := CharFromWChar(Pointer(Dest), DestLen, Source, Length); + if DestLen < 0 then DestLen := 0; + SetLength(Dest, DestLen); +end; + + +procedure _LStrFromChar(var Dest: AnsiString; Source: AnsiChar); +asm + PUSH EDX + MOV EDX,ESP + MOV ECX,1 + CALL _LStrFromPCharLen + POP EDX +end; + + +procedure _LStrFromWChar(var Dest: AnsiString; Source: WideChar); +asm + PUSH EDX + MOV EDX,ESP + MOV ECX,1 + CALL _LStrFromPWCharLen + POP EDX +end; + + +procedure _LStrFromPChar(var Dest: AnsiString; Source: PAnsiChar); +asm + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CL,[EDX+0] + JE @@4 + CMP CL,[EDX+1] + JE @@3 + CMP CL,[EDX+2] + JE @@2 + CMP CL,[EDX+3] + JE @@1 + ADD EDX,4 + JMP @@0 +@@1: INC EDX +@@2: INC EDX +@@3: INC EDX +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX +@@5: JMP _LStrFromPCharLen +end; + + +procedure _LStrFromPWChar(var Dest: AnsiString; Source: PWideChar); +asm + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CX,[EDX+0] + JE @@4 + CMP CX,[EDX+2] + JE @@3 + CMP CX,[EDX+4] + JE @@2 + CMP CX,[EDX+6] + JE @@1 + ADD EDX,8 + JMP @@0 +@@1: ADD EDX,2 +@@2: ADD EDX,2 +@@3: ADD EDX,2 +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX + SHR ECX,1 +@@5: JMP _LStrFromPWCharLen +end; + + +procedure _LStrFromString(var Dest: AnsiString; const Source: ShortString); +asm + XOR ECX,ECX + MOV CL,[EDX] + INC EDX + JMP _LStrFromPCharLen +end; + + +procedure _LStrFromArray(var Dest: AnsiString; Source: PAnsiChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASB + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _LStrFromPCharLen +end; + + +procedure _LStrFromWArray(var Dest: AnsiString; Source: PWideChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASW + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _LStrFromPWCharLen +end; + + +procedure _LStrFromWStr(var Dest: AnsiString; const Source: WideString); +asm + { -> EAX pointer to dest } + { EDX pointer to WideString data } + + XOR ECX,ECX + TEST EDX,EDX + JE @@1 + MOV ECX,[EDX-4] + SHR ECX,1 +@@1: JMP _LStrFromPWCharLen +end; + + +procedure _LStrToString{(var Dest: ShortString; const Source: AnsiString; MaxLen: Integer)}; +asm + { -> EAX pointer to result } + { EDX AnsiString s } + { ECX length of result } + + PUSH EBX + TEST EDX,EDX + JE @@empty + MOV EBX,[EDX-skew].StrRec.length + TEST EBX,EBX + JE @@empty + + CMP ECX,EBX + JL @@truncate + MOV ECX,EBX +@@truncate: + MOV [EAX],CL + INC EAX + + XCHG EAX,EDX + CALL Move + + JMP @@exit + +@@empty: + MOV byte ptr [EAX],0 + +@@exit: + POP EBX +end; + +function _LStrLen(const s: AnsiString): Longint; +{$IFDEF PUREPASCAL} +begin + Result := 0; + if Pointer(s) <> nil then + Result := PStrRec(Integer(s) - sizeof(StrRec)).length; +end; +{$ELSE} +asm + { -> EAX str } + + TEST EAX,EAX + JE @@done + MOV EAX,[EAX-skew].StrRec.length; +@@done: +end; +{$ENDIF} + + +procedure _LStrCat{var dest: AnsiString; source: AnsiString}; +asm + { -> EAX pointer to dest } + { EDX source } + + TEST EDX,EDX + JE @@exit + + MOV ECX,[EAX] + TEST ECX,ECX + JE _LStrAsg + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,[ECX-skew].StrRec.length + + MOV EDX,[ESI-skew].StrRec.length + ADD EDX,EDI + CMP ESI,ECX + JE @@appendSelf + + CALL _LStrSetLength + MOV EAX,ESI + MOV ECX,[ESI-skew].StrRec.length + +@@appendStr: + MOV EDX,[EBX] + ADD EDX,EDI + CALL Move + POP EDI + POP ESI + POP EBX + RET + +@@appendSelf: + CALL _LStrSetLength + MOV EAX,[EBX] + MOV ECX,EDI + JMP @@appendStr + +@@exit: +end; + + +procedure _LStrCat3{var dest:AnsiString; source1: AnsiString; source2: AnsiString}; +asm + { ->EAX = Pointer to dest } + { EDX = source1 } + { ECX = source2 } + + TEST EDX,EDX + JE @@assignSource2 + + TEST ECX,ECX + JE _LStrAsg + + CMP EDX,[EAX] + JE @@appendToDest + + CMP ECX,[EAX] + JE @@theHardWay + + PUSH EAX + PUSH ECX + CALL _LStrAsg + + POP EDX + POP EAX + JMP _LStrCat + +@@theHardWay: + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EDX + MOV ESI,ECX + PUSH EAX + + MOV EAX,[EBX-skew].StrRec.length + ADD EAX,[ESI-skew].StrRec.length + CALL _NewAnsiString + + MOV EDI,EAX + MOV EDX,EAX + MOV EAX,EBX + MOV ECX,[EBX-skew].StrRec.length + CALL Move + + MOV EDX,EDI + MOV EAX,ESI + MOV ECX,[ESI-skew].StrRec.length + ADD EDX,[EBX-skew].StrRec.length + CALL Move + + POP EAX + MOV EDX,EDI + TEST EDI,EDI + JE @@skip + DEC [EDI-skew].StrRec.refCnt // EDI = local temp str +@@skip: + CALL _LStrAsg + + POP EDI + POP ESI + POP EBX + + JMP @@exit + +@@assignSource2: + MOV EDX,ECX + JMP _LStrAsg + +@@appendToDest: + MOV EDX,ECX + JMP _LStrCat + +@@exit: +end; + + +procedure _LStrCatN{var dest:AnsiString; argCnt: Integer; ...}; +asm + { ->EAX = Pointer to dest } + { EDX = number of args (>= 3) } + { [ESP+4], [ESP+8], ... crgCnt AnsiString arguments, reverse order } + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EDX + PUSH EAX + MOV EBX,EDX + + XOR EDI,EDI + MOV ECX,[ESP+EDX*4+5*4] // first arg is furthest out + TEST ECX,ECX + JZ @@0 + CMP [EAX],ECX // is dest = first arg? + JNE @@0 + MOV EDI,EAX // EDI nonzero -> potential appendstr case +@@0: + XOR EAX,EAX +@@loop1: + MOV ECX,[ESP+EDX*4+5*4] + TEST ECX,ECX + JE @@1 + ADD EAX,[ECX-skew].StrRec.length + CMP EDI,ECX // is dest an arg besides arg1? + JNE @@1 + XOR EDI,EDI // can't appendstr - dest is multiple args +@@1: + DEC EDX + JNE @@loop1 + +@@append: + TEST EDI,EDI // dest is 1st and only 1st arg? + JZ @@copy + MOV EDX,EAX // length into EDX + MOV EAX,EDI // ptr to str into EAX + MOV ESI,[EDI-skew].StrRec.Length // save old size before realloc + CALL _LStrSetLength + PUSH [EDI] + ADD ESI,[EDI] // ESI = end of old string + DEC EBX + JMP @@loop2 + +@@copy: + CALL _NewAnsiString + PUSH EAX + MOV ESI,EAX + +@@loop2: + MOV EAX,[ESP+EBX*4+6*4] + MOV EDX,ESI + TEST EAX,EAX + JE @@2 + MOV ECX,[EAX-skew].StrRec.length + ADD ESI,ECX + CALL Move +@@2: + DEC EBX + JNE @@loop2 + + POP EDX + POP EAX + TEST EDI,EDI + JNZ @@exit + + TEST EDX,EDX + JE @@skip + DEC [EDX-skew].StrRec.refCnt // EDX = local temp str +@@skip: + CALL _LStrAsg + +@@exit: + POP EDX + POP EDI + POP ESI + POP EBX + POP EAX + LEA ESP,[ESP+EDX*4] + JMP EAX +end; + + +procedure _LStrCmp{left: AnsiString; right: AnsiString}; +asm +{ ->EAX = Pointer to left string } +{ EDX = Pointer to right string } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + CMP EAX,EDX + JE @@exit + + TEST ESI,ESI + JE @@str1null + + TEST EDI,EDI + JE @@str2null + + MOV EAX,[ESI-skew].StrRec.length + MOV EDX,[EDI-skew].StrRec.length + + SUB EAX,EDX { eax = len1 - len2 } + JA @@skip1 + ADD EDX,EAX { edx = len2 + (len1 - len2) = len1 } + +@@skip1: + PUSH EDX + SHR EDX,2 + JE @@cmpRest +@@longLoop: + MOV ECX,[ESI] + MOV EBX,[EDI] + CMP ECX,EBX + JNE @@misMatch + DEC EDX + JE @@cmpRestP4 + MOV ECX,[ESI+4] + MOV EBX,[EDI+4] + CMP ECX,EBX + JNE @@misMatch + ADD ESI,8 + ADD EDI,8 + DEC EDX + JNE @@longLoop + JMP @@cmpRest +@@cmpRestP4: + ADD ESI,4 + ADD EDI,4 +@@cmpRest: + POP EDX + AND EDX,3 + JE @@equal + + MOV ECX,[ESI] + MOV EBX,[EDI] + CMP CL,BL + JNE @@exit + DEC EDX + JE @@equal + CMP CH,BH + JNE @@exit + DEC EDX + JE @@equal + AND EBX,$00FF0000 + AND ECX,$00FF0000 + CMP ECX,EBX + JNE @@exit + +@@equal: + ADD EAX,EAX + JMP @@exit + +@@str1null: + MOV EDX,[EDI-skew].StrRec.length + SUB EAX,EDX + JMP @@exit + +@@str2null: + MOV EAX,[ESI-skew].StrRec.length + SUB EAX,EDX + JMP @@exit + +@@misMatch: + POP EDX + CMP CL,BL + JNE @@exit + CMP CH,BH + JNE @@exit + SHR ECX,16 + SHR EBX,16 + CMP CL,BL + JNE @@exit + CMP CH,BH + +@@exit: + POP EDI + POP ESI + POP EBX + +end; + +function _LStrAddRef(var str): Pointer; +{$IFDEF PUREPASCAL} +var + P: PStrRec; +begin + P := Pointer(Integer(str) - sizeof(StrRec)); + if P <> nil then + if P.refcnt >= 0 then + InterlockedIncrement(P.refcnt); + Result := Pointer(str); +end; +{$ELSE} +asm + { -> EAX str } + TEST EAX,EAX + JE @@exit + MOV EDX,[EAX-skew].StrRec.refCnt + INC EDX + JLE @@exit + { LOCK} INC [EAX-skew].StrRec.refCnt +@@exit: +end; +{$ENDIF} + +function PICEmptyString: PWideChar; +begin + Result := ''; +end; + +function _LStrToPChar(const s: AnsiString): PChar; +{$IFDEF PUREPASCAL} +const + EmptyString = ''; +begin + if Pointer(s) = nil then + Result := EmptyString + else + Result := Pointer(s); +end; +{$ELSE} +asm + { -> EAX pointer to str } + { <- EAX pointer to PChar } + + TEST EAX,EAX + JE @@handle0 + RET +{$IFDEF PIC} +@@handle0: + JMP PICEmptyString +{$ELSE} +@@zeroByte: + DB 0 +@@handle0: + MOV EAX,offset @@zeroByte +{$ENDIF} +end; +{$ENDIF} + +function InternalUniqueString(var str): Pointer; +asm + { -> EAX pointer to str } + { <- EAX pointer to unique copy } + MOV EDX,[EAX] + TEST EDX,EDX + JE @@exit + MOV ECX,[EDX-skew].StrRec.refCnt + DEC ECX + JE @@exit + + PUSH EBX + MOV EBX,EAX + MOV EAX,[EDX-skew].StrRec.length + CALL _NewAnsiString + MOV EDX,EAX + MOV EAX,[EBX] + MOV [EBX],EDX + PUSH EAX + MOV ECX,[EAX-skew].StrRec.length + CALL Move + POP EAX + MOV ECX,[EAX-skew].StrRec.refCnt + DEC ECX + JL @@skip + { LOCK} DEC [EAX-skew].StrRec.refCnt + JNZ @@skip + LEA EAX,[EAX-skew].StrRec.refCnt { if refCnt now zero, deallocate} + CALL _FreeMem +@@skip: + MOV EDX,[EBX] + POP EBX +@@exit: + MOV EAX,EDX +end; + + +procedure UniqueString(var str: AnsiString); +asm + JMP InternalUniqueString +end; + +procedure _UniqueStringA(var str: AnsiString); +asm + JMP InternalUniqueString +end; + +procedure UniqueString(var str: WideString); +asm +{$IFDEF LINUX} + JMP InternalUniqueString +{$ENDIF} +{$IFDEF MSWINDOWS} + // nothing to do - Windows WideStrings are always single reference +{$ENDIF} +end; + +procedure _UniqueStringW(var str: WideString); +asm +{$IFDEF LINUX} + JMP InternalUniqueString +{$ENDIF} +{$IFDEF MSWINDOWS} + // nothing to do - Windows WideStrings are always single reference +{$ENDIF} +end; + +procedure _LStrCopy{ const s : AnsiString; index, count : Integer) : AnsiString}; +asm + { ->EAX Source string } + { EDX index } + { ECX count } + { [ESP+4] Pointer to result string } + + PUSH EBX + + TEST EAX,EAX + JE @@srcEmpty + + MOV EBX,[EAX-skew].StrRec.length + TEST EBX,EBX + JE @@srcEmpty + +{ make index 0-based and limit to 0 <= index < Length(src) } + + DEC EDX + JL @@smallInx + CMP EDX,EBX + JGE @@bigInx + +@@cont1: + +{ limit count to satisfy 0 <= count <= Length(src) - index } + + SUB EBX,EDX { calculate Length(src) - index } + TEST ECX,ECX + JL @@smallCount + CMP ECX,EBX + JG @@bigCount + +@@cont2: + + ADD EDX,EAX + MOV EAX,[ESP+4+4] + CALL _LStrFromPCharLen + JMP @@exit + +@@smallInx: + XOR EDX,EDX + JMP @@cont1 +@@bigCount: + MOV ECX,EBX + JMP @@cont2 +@@bigInx: +@@smallCount: +@@srcEmpty: + MOV EAX,[ESP+4+4] + CALL _LStrClr +@@exit: + POP EBX + RET 4 +end; + + +procedure _LStrDelete{ var s : AnsiString; index, count : Integer }; +asm + { ->EAX Pointer to s } + { EDX index } + { ECX count } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + CALL UniqueString + + MOV EDX,[EBX] + TEST EDX,EDX { source already empty: nothing to do } + JE @@exit + + MOV ECX,[EDX-skew].StrRec.length + +{ make index 0-based, if not in [0 .. Length(s)-1] do nothing } + + DEC ESI + JL @@exit + CMP ESI,ECX + JGE @@exit + +{ limit count to [0 .. Length(s) - index] } + + TEST EDI,EDI + JLE @@exit + SUB ECX,ESI { ECX = Length(s) - index } + CMP EDI,ECX + JLE @@1 + MOV EDI,ECX +@@1: + +{ move length - index - count characters from s+index+count to s+index } + + SUB ECX,EDI { ECX = Length(s) - index - count } + ADD EDX,ESI { EDX = s+index } + LEA EAX,[EDX+EDI] { EAX = s+index+count } + CALL Move + +{ set length(s) to length(s) - count } + + MOV EDX,[EBX] + MOV EAX,EBX + MOV EDX,[EDX-skew].StrRec.length + SUB EDX,EDI + CALL _LStrSetLength + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +procedure _LStrInsert{ const source : AnsiString; var s : AnsiString; index : Integer }; +asm + { -> EAX source string } + { EDX pointer to destination string } + { ECX index } + + TEST EAX,EAX + JE @@nothingToDo + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + +{ make index 0-based and limit to 0 <= index <= Length(s) } + + MOV EDX,[EDX] + PUSH EDX + TEST EDX,EDX + JE @@sIsNull + MOV EDX,[EDX-skew].StrRec.length +@@sIsNull: + DEC EDI + JGE @@indexNotLow + XOR EDI,EDI +@@indexNotLow: + CMP EDI,EDX + JLE @@indexNotHigh + MOV EDI,EDX +@@indexNotHigh: + + MOV EBP,[EBX-skew].StrRec.length + +{ set length of result to length(source) + length(s) } + + MOV EAX,ESI + ADD EDX,EBP + CALL _LStrSetLength + POP EAX + + CMP EAX,EBX + JNE @@notInsertSelf + MOV EBX,[ESI] + +@@notInsertSelf: + +{ move length(s) - length(source) - index chars from s+index to s+index+length(source) } + + MOV EAX,[ESI] { EAX = s } + LEA EDX,[EDI+EBP] { EDX = index + length(source) } + MOV ECX,[EAX-skew].StrRec.length + SUB ECX,EDX { ECX = length(s) - length(source) - index } + ADD EDX,EAX { EDX = s + index + length(source) } + ADD EAX,EDI { EAX = s + index } + CALL Move + +{ copy length(source) chars from source to s+index } + + MOV EAX,EBX + MOV EDX,[ESI] + MOV ECX,EBP + ADD EDX,EDI + CALL Move + +@@exit: + POP EBP + POP EDI + POP ESI + POP EBX +@@nothingToDo: +end; + +function Pos(const substr, str: AnsiString): Integer; overload; +asm +{ ->EAX Pointer to substr } +{ EDX Pointer to string } +{ <-EAX Position of substr in str or 0 } + + TEST EAX,EAX + JE @@noWork + + TEST EDX,EDX + JE @@stringEmpty + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX { Point ESI to substr } + MOV EDI,EDX { Point EDI to s } + + MOV ECX,[EDI-skew].StrRec.length { ECX = Length(s) } + + PUSH EDI { remember s position to calculate index } + + MOV EDX,[ESI-skew].StrRec.length { EDX = Length(substr) } + + DEC EDX { EDX = Length(substr) - 1 } + JS @@fail { < 0 ? return 0 } + MOV AL,[ESI] { AL = first char of substr } + INC ESI { Point ESI to 2'nd char of substr } + + SUB ECX,EDX { #positions in s to look at } + { = Length(s) - Length(substr) + 1 } + JLE @@fail +@@loop: + REPNE SCASB + JNE @@fail + MOV EBX,ECX { save outer loop counter } + PUSH ESI { save outer loop substr pointer } + PUSH EDI { save outer loop s pointer } + + MOV ECX,EDX + REPE CMPSB + POP EDI { restore outer loop s pointer } + POP ESI { restore outer loop substr pointer } + JE @@found + MOV ECX,EBX { restore outer loop counter } + JMP @@loop + +@@fail: + POP EDX { get rid of saved s pointer } + XOR EAX,EAX + JMP @@exit + +@@stringEmpty: + XOR EAX,EAX + JMP @@noWork + +@@found: + POP EDX { restore pointer to first char of s } + MOV EAX,EDI { EDI points of char after match } + SUB EAX,EDX { the difference is the correct index } +@@exit: + POP EDI + POP ESI + POP EBX +@@noWork: +end; + + +procedure _LStrSetLength{ var str: AnsiString; newLength: Integer}; +asm + { -> EAX Pointer to str } + { EDX new length } + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV ESI,EDX + XOR EDI,EDI + + TEST EDX,EDX + JLE @@setString + + MOV EAX,[EBX] + TEST EAX,EAX + JE @@copyString + + CMP [EAX-skew].StrRec.refCnt,1 + JNE @@copyString + + SUB EAX,rOff + ADD EDX,rOff+1 + PUSH EAX + MOV EAX,ESP + CALL _ReallocMem + POP EAX + ADD EAX,rOff + MOV [EBX],EAX + MOV [EAX-skew].StrRec.length,ESI + MOV BYTE PTR [EAX+ESI],0 + JMP @@exit + +@@copyString: + MOV EAX,EDX + CALL _NewAnsiString + MOV EDI,EAX + + MOV EAX,[EBX] + TEST EAX,EAX + JE @@setString + + MOV EDX,EDI + MOV ECX,[EAX-skew].StrRec.length + CMP ECX,ESI + JL @@moveString + MOV ECX,ESI + +@@moveString: + CALL Move + +@@setString: + MOV EAX,EBX + CALL _LStrClr + MOV [EBX],EDI + +@@exit: + POP EDI + POP ESI + POP EBX +end; + +function StringOfChar(ch: AnsiChar; count: Integer): AnsiString; overload; +asm + { -> AL c } + { EDX count } + { ECX result } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + MOV EAX,ECX + CALL _LStrClr + + TEST ESI,ESI + JLE @@exit + + MOV EAX,ESI + CALL _NewAnsiString + + MOV [EDI],EAX + + MOV EDX,ESI + MOV CL,BL + + CALL _FillChar + +@@exit: + POP EDI + POP ESI + POP EBX + +end; + + +function _Write0LString(var t: TTextRec; const s: AnsiString): Pointer; +begin + Result := _WriteLString(t, s, 0); +end; + + +function _WriteLString(var t: TTextRec; const s: AnsiString; width: Longint): Pointer; +{$IFDEF PUREPASCAL} +var + i: Integer; +begin + i := Length(s); + _WriteSpaces(t, width - i); + Result := _WriteBytes(t, s[1], i); +end; +{$ELSE} +asm + { -> EAX Pointer to text record } + { EDX Pointer to AnsiString } + { ECX Field width } + + PUSH EBX + + MOV EBX,EDX + + MOV EDX,ECX + XOR ECX,ECX + TEST EBX,EBX + JE @@skip + MOV ECX,[EBX-skew].StrRec.length + SUB EDX,ECX +@@skip: + PUSH ECX + CALL _WriteSpaces + POP ECX + + MOV EDX,EBX + POP EBX + JMP _WriteBytes +end; +{$ENDIF} + + +function _Write0WString(var t: TTextRec; const s: WideString): Pointer; +begin + Result := _WriteWString(t, s, 0); +end; + + +function _WriteWString(var t: TTextRec; const s: WideString; width: Longint): Pointer; +var + i: Integer; +begin + i := Length(s); + _WriteSpaces(t, width - i); + Result := _WriteLString(t, AnsiString(s), 0); +end; + + +function _Write0WCString(var t: TTextRec; s: PWideChar): Pointer; +begin + Result := _WriteWCString(t, s, 0); +end; + + +function _WriteWCString(var t: TTextRec; s: PWideChar; width: Longint): Pointer; +var + i: Integer; +begin + i := 0; + if (s <> nil) then + while s[i] <> #0 do + Inc(i); + + _WriteSpaces(t, width - i); + Result := _WriteLString(t, AnsiString(s), 0); +end; + + +function _Write0WChar(var t: TTextRec; c: WideChar): Pointer; +begin + Result := _WriteWChar(t, c, 0); +end; + + +function _WriteWChar(var t: TTextRec; c: WideChar; width: Integer): Pointer; +begin + _WriteSpaces(t, width - 1); + Result := _WriteLString(t, AnsiString(c), 0); +end; + +{$IFDEF MSWINDOWS} +procedure WStrError; +asm + MOV AL,reOutOfMemory + JMP Error +end; +{$ENDIF} + +function _NewWideString(CharLength: Longint): Pointer; +{$IFDEF LINUX} +begin + Result := _NewAnsiString(CharLength*2); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + TEST EAX,EAX + JE @@1 + PUSH EAX + PUSH 0 + CALL SysAllocStringLen + TEST EAX,EAX + JE WStrError +@@1: +end; +{$ENDIF} + +procedure WStrSet(var S: WideString; P: PWideChar); +{$IFDEF PUREPASCAL} +var + Temp: Pointer; +begin + Temp := Pointer(InterlockedExchange(Pointer(S), Pointer(P))); + if Temp <> nil then + _WStrClr(Temp); +end; +{$ELSE} +asm +{$IFDEF LINUX} + XCHG [EAX],EDX + TEST EDX,EDX + JZ @@1 + PUSH EDX + MOV EAX, ESP + CALL _WStrClr + POP EAX +{$ENDIF} +{$IFDEF MSWINDOWS} + XCHG [EAX],EDX + TEST EDX,EDX + JZ @@1 + PUSH EDX + CALL SysFreeString +{$ENDIF} +@@1: +end; +{$ENDIF} + +procedure WStrClr; +asm + JMP _WStrClr +end; + +procedure _WStrClr(var S); +{$IFDEF LINUX} +asm + JMP _LStrClr; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + { -> EAX Pointer to WideString } + + MOV EDX,[EAX] + TEST EDX,EDX + JE @@1 + MOV DWORD PTR [EAX],0 + PUSH EAX + PUSH EDX + CALL SysFreeString + POP EAX +@@1: +end; +{$ENDIF} + +procedure WStrArrayClr; +asm + JMP _WStrArrayClr; +end; + +procedure _WStrArrayClr(var StrArray; Count: Integer); +{$IFDEF LINUX} +asm + JMP _LStrArrayClr +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + PUSH EBX + PUSH ESI + MOV EBX,EAX + MOV ESI,EDX +@@1: MOV EAX,[EBX] + TEST EAX,EAX + JE @@2 + MOV DWORD PTR [EBX],0 + PUSH EAX + CALL SysFreeString +@@2: ADD EBX,4 + DEC ESI + JNE @@1 + POP ESI + POP EBX +end; +{$ENDIF} + + +procedure _WStrAsg(var Dest: WideString; const Source: WideString); +{$IFDEF LINUX} +asm + JMP _LStrAsg +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + { -> EAX Pointer to WideString } + { EDX Pointer to data } + CMP [EAX],EDX + JE @@1 + TEST EDX,EDX + JE _WStrClr + MOV ECX,[EDX-4] + SHR ECX,1 + JE _WStrClr + PUSH ECX + PUSH EDX + PUSH EAX + CALL SysReAllocStringLen + TEST EAX,EAX + JE WStrError +@@1: +end; +{$ENDIF} + +procedure _WStrLAsg(var Dest: WideString; const Source: WideString); +{$IFDEF LINUX} +asm + JMP _LStrLAsg +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + JMP _WStrAsg +end; +{$ENDIF} + +procedure _WStrFromPCharLen(var Dest: WideString; Source: PAnsiChar; Length: Integer); +var + DestLen: Integer; + Buffer: array[0..2047] of WideChar; +begin + if Length <= 0 then + begin + _WStrClr(Dest); + Exit; + end; + if Length+1 < High(Buffer) then + begin + DestLen := WCharFromChar(Buffer, High(Buffer), Source, Length); + if DestLen > 0 then + begin + _WStrFromPWCharLen(Dest, @Buffer, DestLen); + Exit; + end; + end; + + DestLen := (Length + 1); + _WStrSetLength(Dest, DestLen); // overallocate, trim later + DestLen := WCharFromChar(Pointer(Dest), DestLen, Source, Length); + if DestLen < 0 then DestLen := 0; + _WStrSetLength(Dest, DestLen); +end; + +procedure _WStrFromPWCharLen(var Dest: WideString; Source: PWideChar; CharLength: Integer); +{$IFDEF LINUX} +var + Temp: Pointer; +begin + Temp := Pointer(Dest); + if CharLength > 0 then + begin + Pointer(Dest) := _NewWideString(CharLength); + if Source <> nil then + Move(Source^, Pointer(Dest)^, CharLength * sizeof(WideChar)); + end + else + Pointer(Dest) := nil; + _WStrClr(Temp); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + { -> EAX Pointer to WideString (dest) } + { EDX Pointer to characters (source) } + { ECX number of characters (not bytes) } + TEST ECX,ECX + JE _WStrClr + + PUSH EAX + + PUSH ECX + PUSH EDX + CALL SysAllocStringLen + TEST EAX,EAX + JE WStrError + + POP EDX + PUSH [EDX].PWideChar + MOV [EDX],EAX + + CALL SysFreeString +end; +{$ENDIF} + + +procedure _WStrFromChar(var Dest: WideString; Source: AnsiChar); +asm + PUSH EDX + MOV EDX,ESP + MOV ECX,1 + CALL _WStrFromPCharLen + POP EDX +end; + + +procedure _WStrFromWChar(var Dest: WideString; Source: WideChar); +asm + { -> EAX Pointer to WideString (dest) } + { EDX character (source) } + PUSH EDX + MOV EDX,ESP + MOV ECX,1 + CALL _WStrFromPWCharLen + POP EDX +end; + + +procedure _WStrFromPChar(var Dest: WideString; Source: PAnsiChar); +asm + { -> EAX Pointer to WideString (dest) } + { EDX Pointer to character (source) } + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CL,[EDX+0] + JE @@4 + CMP CL,[EDX+1] + JE @@3 + CMP CL,[EDX+2] + JE @@2 + CMP CL,[EDX+3] + JE @@1 + ADD EDX,4 + JMP @@0 +@@1: INC EDX +@@2: INC EDX +@@3: INC EDX +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX +@@5: JMP _WStrFromPCharLen +end; + + +procedure _WStrFromPWChar(var Dest: WideString; Source: PWideChar); +asm + { -> EAX Pointer to WideString (dest) } + { EDX Pointer to character (source) } + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CX,[EDX+0] + JE @@4 + CMP CX,[EDX+2] + JE @@3 + CMP CX,[EDX+4] + JE @@2 + CMP CX,[EDX+6] + JE @@1 + ADD EDX,8 + JMP @@0 +@@1: ADD EDX,2 +@@2: ADD EDX,2 +@@3: ADD EDX,2 +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX + SHR ECX,1 +@@5: JMP _WStrFromPWCharLen +end; + + +procedure _WStrFromString(var Dest: WideString; const Source: ShortString); +asm + XOR ECX,ECX + MOV CL,[EDX] + INC EDX + JMP _WStrFromPCharLen +end; + + +procedure _WStrFromArray(var Dest: WideString; Source: PAnsiChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASB + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _WStrFromPCharLen +end; + + +procedure _WStrFromWArray(var Dest: WideString; Source: PWideChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASW + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _WStrFromPWCharLen +end; + + +procedure _WStrFromLStr(var Dest: WideString; const Source: AnsiString); +asm + XOR ECX,ECX + TEST EDX,EDX + JE @@1 + MOV ECX,[EDX-4] +@@1: JMP _WStrFromPCharLen +end; + + +procedure _WStrToString(Dest: PShortString; const Source: WideString; MaxLen: Integer); +var + SourceLen, DestLen: Integer; + Buffer: array[0..511] of Char; +begin + if MaxLen > 255 then MaxLen := 255; + SourceLen := Length(Source); + if SourceLen >= MaxLen then SourceLen := MaxLen; + if SourceLen = 0 then + DestLen := 0 + else + begin + DestLen := CharFromWChar(Buffer, High(Buffer), PWideChar(Pointer(Source)), SourceLen); + if DestLen < 0 then + DestLen := 0 + else if DestLen > MaxLen then + DestLen := MaxLen; + end; + Dest^[0] := Chr(DestLen); + if DestLen > 0 then Move(Buffer, Dest^[1], DestLen); +end; + +function _WStrToPWChar(const S: WideString): PWideChar; +{$IFDEF PUREPASCAL} +const + EmptyString = ''; +begin + if Pointer(S) = nil then + Result := EmptyString + else + Result := Pointer(S); +end; +{$ELSE} +asm + TEST EAX,EAX + JE @@1 + RET +{$IFDEF PIC} +@@1: JMP PICEmptyString +{$ELSE} + NOP +@@0: DW 0 +@@1: MOV EAX,OFFSET @@0 +{$ENDIF} +end; +{$ENDIF} + + +function _WStrLen(const S: WideString): Integer; +{$IFDEF PUREPASCAL} +begin + if Pointer(S) = nil then + Result := 0 + else + Result := PInteger(Integer(S) - 4)^ div sizeof(WideChar); +end; +{$ELSE} +asm + { -> EAX Pointer to WideString data } + TEST EAX,EAX + JE @@1 + MOV EAX,[EAX-4] + SHR EAX,1 +@@1: +end; +{$ENDIF} + +procedure _WStrCat(var Dest: WideString; const Source: WideString); +var + DestLen, SourceLen: Integer; + NewStr: PWideChar; +begin + SourceLen := Length(Source); + if SourceLen <> 0 then + begin + DestLen := Length(Dest); + NewStr := _NewWideString(DestLen + SourceLen); + if DestLen > 0 then + Move(Pointer(Dest)^, NewStr^, DestLen * sizeof(WideChar)); + Move(Pointer(Source)^, NewStr[DestLen], SourceLen * sizeof(WideChar)); + WStrSet(Dest, NewStr); + end; +end; + + +procedure _WStrCat3(var Dest: WideString; const Source1, Source2: WideString); +var + Source1Len, Source2Len: Integer; + NewStr: PWideChar; +begin + Source1Len := Length(Source1); + Source2Len := Length(Source2); + if (Source1Len <> 0) or (Source2Len <> 0) then + begin + NewStr := _NewWideString(Source1Len + Source2Len); + Move(Pointer(Source1)^, Pointer(NewStr)^, Source1Len * sizeof(WideChar)); + Move(Pointer(Source2)^, NewStr[Source1Len], Source2Len * sizeof(WideChar)); + WStrSet(Dest, NewStr); + end + else + _WStrClr(Dest); +end; + + +procedure _WStrCatN{var Dest: WideString; ArgCnt: Integer; ...}; +asm + { ->EAX = Pointer to dest } + { EDX = number of args (>= 3) } + { [ESP+4], [ESP+8], ... crgCnt WideString arguments } + + PUSH EBX + PUSH ESI + PUSH EDX + PUSH EAX + MOV EBX,EDX + + XOR EAX,EAX +@@loop1: + MOV ECX,[ESP+EDX*4+4*4] + TEST ECX,ECX + JE @@1 + ADD EAX,[ECX-4] +@@1: + DEC EDX + JNE @@loop1 + + SHR EAX,1 + CALL _NewWideString + PUSH EAX + MOV ESI,EAX + +@@loop2: + MOV EAX,[ESP+EBX*4+5*4] + MOV EDX,ESI + TEST EAX,EAX + JE @@2 + MOV ECX,[EAX-4] + ADD ESI,ECX + CALL Move +@@2: + DEC EBX + JNE @@loop2 + + POP EDX + POP EAX + CALL WStrSet + + POP EDX + POP ESI + POP EBX + POP EAX + LEA ESP,[ESP+EDX*4] + JMP EAX +end; + +procedure _WStrCmp{left: WideString; right: WideString}; +asm +{ ->EAX = Pointer to left string } +{ EDX = Pointer to right string } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + CMP EAX,EDX + JE @@exit + + TEST ESI,ESI + JE @@str1null + + TEST EDI,EDI + JE @@str2null + + MOV EAX,[ESI-4] + MOV EDX,[EDI-4] + + SUB EAX,EDX { eax = len1 - len2 } + JA @@skip1 + ADD EDX,EAX { edx = len2 + (len1 - len2) = len1 } + +@@skip1: + PUSH EDX + SHR EDX,2 + JE @@cmpRest +@@longLoop: + MOV ECX,[ESI] + MOV EBX,[EDI] + CMP ECX,EBX + JNE @@misMatch + DEC EDX + JE @@cmpRestP4 + MOV ECX,[ESI+4] + MOV EBX,[EDI+4] + CMP ECX,EBX + JNE @@misMatch + ADD ESI,8 + ADD EDI,8 + DEC EDX + JNE @@longLoop + JMP @@cmpRest +@@cmpRestP4: + ADD ESI,4 + ADD EDI,4 +@@cmpRest: + POP EDX + AND EDX,2 + JE @@equal + + MOV CX,[ESI] + MOV BX,[EDI] + CMP CX,BX + JNE @@exit + +@@equal: + ADD EAX,EAX + JMP @@exit + +@@str1null: + MOV EDX,[EDI-4] + SUB EAX,EDX + JMP @@exit + +@@str2null: + MOV EAX,[ESI-4] + SUB EAX,EDX + JMP @@exit + +@@misMatch: + POP EDX + CMP CX,BX + JNE @@exit + SHR ECX,16 + SHR EBX,16 + CMP CX,BX + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +function _WStrCopy(const S: WideString; Index, Count: Integer): WideString; +var + L, N: Integer; +begin + L := Length(S); + if Index < 1 then Index := 0 else + begin + Dec(Index); + if Index > L then Index := L; + end; + if Count < 0 then N := 0 else + begin + N := L - Index; + if N > Count then N := Count; + end; + _WStrFromPWCharLen(Result, PWideChar(Pointer(S)) + Index, N); +end; + + +procedure _WStrDelete(var S: WideString; Index, Count: Integer); +var + L, N: Integer; + NewStr: PWideChar; +begin + L := Length(S); + if (L > 0) and (Index >= 1) and (Index <= L) and (Count > 0) then + begin + Dec(Index); + N := L - Index - Count; + if N < 0 then N := 0; + if (Index = 0) and (N = 0) then NewStr := nil else + begin + NewStr := _NewWideString(Index + N); + if Index > 0 then + Move(Pointer(S)^, NewStr^, Index * 2); + if N > 0 then + Move(PWideChar(Pointer(S))[L - N], NewStr[Index], N * 2); + end; + WStrSet(S, NewStr); + end; +end; + + +procedure _WStrInsert(const Source: WideString; var Dest: WideString; Index: Integer); +var + SourceLen, DestLen: Integer; + NewStr: PWideChar; +begin + SourceLen := Length(Source); + if SourceLen > 0 then + begin + DestLen := Length(Dest); + if Index < 1 then Index := 0 else + begin + Dec(Index); + if Index > DestLen then Index := DestLen; + end; + NewStr := _NewWideString(DestLen + SourceLen); + if Index > 0 then + Move(Pointer(Dest)^, NewStr^, Index * 2); + Move(Pointer(Source)^, NewStr[Index], SourceLen * 2); + if Index < DestLen then + Move(PWideChar(Pointer(Dest))[Index], NewStr[Index + SourceLen], + (DestLen - Index) * 2); + WStrSet(Dest, NewStr); + end; +end; + + +function Pos(const substr, str: WideString): Integer; overload; +asm +{ ->EAX Pointer to substr } +{ EDX Pointer to string } +{ <-EAX Position of substr in str or 0 } + + TEST EAX,EAX + JE @@noWork + + TEST EDX,EDX + JE @@stringEmpty + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX { Point ESI to substr } + MOV EDI,EDX { Point EDI to s } + + MOV ECX,[EDI-4] { ECX = Length(s) } + SHR ECX,1 + + PUSH EDI { remember s position to calculate index } + + MOV EDX,[ESI-4] { EDX = Length(substr) } + SHR EDX,1 + + DEC EDX { EDX = Length(substr) - 1 } + JS @@fail { < 0 ? return 0 } + MOV AX,[ESI] { AL = first char of substr } + ADD ESI,2 { Point ESI to 2'nd char of substr } + + SUB ECX,EDX { #positions in s to look at } + { = Length(s) - Length(substr) + 1 } + JLE @@fail +@@loop: + REPNE SCASW + JNE @@fail + MOV EBX,ECX { save outer loop counter } + PUSH ESI { save outer loop substr pointer } + PUSH EDI { save outer loop s pointer } + + MOV ECX,EDX + REPE CMPSW + POP EDI { restore outer loop s pointer } + POP ESI { restore outer loop substr pointer } + JE @@found + MOV ECX,EBX { restore outer loop counter } + JMP @@loop + +@@fail: + POP EDX { get rid of saved s pointer } + XOR EAX,EAX + JMP @@exit + +@@stringEmpty: + XOR EAX,EAX + JMP @@noWork + +@@found: + POP EDX { restore pointer to first char of s } + MOV EAX,EDI { EDI points of char after match } + SUB EAX,EDX { the difference is the correct index } + SHR EAX,1 +@@exit: + POP EDI + POP ESI + POP EBX +@@noWork: +end; + + +procedure _WStrSetLength(var S: WideString; NewLength: Integer); +var + NewStr: PWideChar; + Count: Integer; +begin + NewStr := nil; + if NewLength > 0 then + begin + NewStr := _NewWideString(NewLength); + Count := Length(S); + if Count > 0 then + begin + if Count > NewLength then Count := NewLength; + Move(Pointer(S)^, NewStr^, Count * 2); + end; + end; + WStrSet(S, NewStr); +end; + + +function StringOfChar(Ch: WideChar; Count: Integer): WideString; overload; +var + P: PWideChar; +begin + _WStrFromPWCharLen(Result, nil, Count); + P := Pointer(Result); + while Count > 0 do + begin + Dec(Count); + P[Count] := Ch; + end; +end; + +procedure WStrAddRef; +asm + JMP _WStrAddRef +end; + +function _WStrAddRef(var str: WideString): Pointer; +{$IFDEF LINUX} +asm + JMP _LStrAddRef +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + MOV EDX,[EAX] + TEST EDX,EDX + JE @@1 + PUSH EAX + MOV ECX,[EDX-4] + SHR ECX,1 + PUSH ECX + PUSH EDX + CALL SysAllocStringLen + POP EDX + TEST EAX,EAX + JE WStrError + MOV [EDX],EAX +@@1: +end; +{$ENDIF} + +procedure _WCharToString(Dest: PShortString; const Source: WideChar; MaxLen: Integer); +var + DestLen: Integer; + Buffer: array[0..255] of Char; +begin + if MaxLen > 255 then MaxLen := 255; + DestLen := CharFromWChar(Buffer, High(Buffer), @Source, 1); + if DestLen < 0 then + DestLen := 0 + else if DestLen > MaxLen then + DestLen := MaxLen; + Dest^[0] := Chr(DestLen); + if DestLen > 0 then Move(Buffer, Dest^[1], DestLen); +end; + +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); +{$IFDEF PUREPASCAL} +var + FT: PFieldTable; + I: Cardinal; +begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + for I := FT.Count-1 downto 0 do + _InitializeArray(Pointer(Cardinal(P) + FT.Fields[I].Offset), FT.Fields[I].TypeInfo^, 1); +end; +{$ELSE} +asm + { -> EAX pointer to record to be initialized } + { EDX pointer to type info } + + XOR ECX,ECX + + PUSH EBX + MOV CL,[EDX+1] { type name length } + + PUSH ESI + PUSH EDI + + MOV EBX,EAX // PIC safe. See comment above + LEA ESI,[EDX+ECX+2+8] { address of destructable fields } + MOV EDI,[EDX+ECX+2+4] { number of destructable fields } + +@@loop: + + MOV EDX,[ESI] + MOV EAX,[ESI+4] + ADD EAX,EBX + MOV EDX,[EDX] + MOV ECX,1 + CALL _InitializeArray + ADD ESI,8 + DEC EDI + JG @@loop + + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + + +const + tkLString = 10; + tkWString = 11; + tkVariant = 12; + tkArray = 13; + tkRecord = 14; + tkInterface = 15; + tkDynArray = 17; + +procedure _InitializeArray(p: Pointer; typeInfo: Pointer; elemCount: Cardinal); +{$IFDEF PUREPASCAL} +var + FT: PFieldTable; +begin + if elemCount = 0 then Exit; + case PTypeInfo(typeInfo).Kind of + tkLString, tkWString, tkInterface, tkDynArray: + while elemCount > 0 do + begin + PInteger(P)^ := 0; + Inc(Integer(P), 4); + Dec(elemCount); + end; + tkVariant: + while elemCount > 0 do + begin + PInteger(P)^ := 0; + PInteger(Integer(P)+4)^ := 0; + PInteger(Integer(P)+8)^ := 0; + PInteger(Integer(P)+12)^ := 0; + Inc(Integer(P), sizeof(Variant)); + Dec(elemCount); + end; + tkArray: + begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + while elemCount > 0 do + begin + _InitializeArray(P, FT.Fields[0].TypeInfo^, FT.Count); + Inc(Integer(P), FT.Size); + Dec(elemCount); + end; + end; + tkRecord: + begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + while elemCount > 0 do + begin + _InitializeRecord(P, typeInfo); + Inc(Integer(P), FT.Size); + Dec(elemCount); + end; + end; + else + Error(reInvalidPtr); + end; +end; +{$ELSE} +asm + { -> EAX pointer to data to be initialized } + { EDX pointer to type info describing data } + { ECX number of elements of that type } + + TEST ECX, ECX + JZ @@zerolength + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX // PIC safe. See comment above + MOV ESI,EDX + MOV EDI,ECX + + XOR EDX,EDX + MOV AL,[ESI] + MOV DL,[ESI+1] + XOR ECX,ECX + + CMP AL,tkLString + JE @@LString + CMP AL,tkWString + JE @@WString + CMP AL,tkVariant + JE @@Variant + CMP AL,tkArray + JE @@Array + CMP AL,tkRecord + JE @@Record + CMP AL,tkInterface + JE @@Interface + CMP AL,tkDynArray + JE @@DynArray + MOV AL,reInvalidPtr + POP EDI + POP ESI + POP EBX + JMP Error + +@@LString: +@@WString: +@@Interface: +@@DynArray: + MOV [EBX],ECX + ADD EBX,4 + DEC EDI + JG @@LString + JMP @@exit + +@@Variant: + MOV [EBX ],ECX + MOV [EBX+ 4],ECX + MOV [EBX+ 8],ECX + MOV [EBX+12],ECX + ADD EBX,16 + DEC EDI + JG @@Variant + JMP @@exit + +@@Array: + PUSH EBP + MOV EBP,EDX +@@ArrayLoop: + MOV EDX,[ESI+EBP+2+8] // address of destructable fields typeinfo + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] // size in bytes of the array data + MOV ECX,[ESI+EBP+2+4] // number of destructable fields + MOV EDX,[EDX] + CALL _InitializeArray + DEC EDI + JG @@ArrayLoop + POP EBP + JMP @@exit + +@@Record: + PUSH EBP + MOV EBP,EDX +@@RecordLoop: + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV EDX,ESI + CALL _InitializeRecord + DEC EDI + JG @@RecordLoop + POP EBP + +@@exit: + + POP EDI + POP ESI + POP EBX +@@zerolength: +end; +{$ENDIF} + +procedure _Initialize(p: Pointer; typeInfo: Pointer); +{$IFDEF PUREPASCAL} +begin + _InitializeArray(p, typeInfo, 1); +end; +{$ELSE} +asm + MOV ECX,1 + JMP _InitializeArray +end; +{$ENDIF} + +procedure _FinalizeRecord(p: Pointer; typeInfo: Pointer); +{$IFDEF PUREPASCAL} +var + FT: PFieldTable; + I: Cardinal; +begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + for I := 0 to FT.Count-1 do + _FinalizeArray(Pointer(Cardinal(P) + FT.Fields[I].Offset), FT.Fields[I].TypeInfo^, 1); +end; +{$ELSE} +asm + { -> EAX pointer to record to be finalized } + { EDX pointer to type info } + + XOR ECX,ECX + + PUSH EBX + MOV CL,[EDX+1] + + PUSH ESI + PUSH EDI + + MOV EBX,EAX + LEA ESI,[EDX+ECX+2+8] + MOV EDI,[EDX+ECX+2+4] + +@@loop: + + MOV EDX,[ESI] + MOV EAX,[ESI+4] + ADD EAX,EBX + MOV EDX,[EDX] + MOV ECX,1 + CALL _FinalizeArray + ADD ESI,8 + DEC EDI + JG @@loop + + MOV EAX,EBX + + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +procedure _FinalizeArray(p: Pointer; typeInfo: Pointer; elemCount: Cardinal); +{$IFDEF PUREPASCAL} +var + FT: PFieldTable; +begin + if elemCount = 0 then Exit; + case PTypeInfo(typeInfo).Kind of + tkLString: _LStrArrayClr(P^, elemCount); + tkWString: {X-_WStrArrayClr X+}WStrArrayClrProc(P^, elemCount); + tkVariant: + while elemCount > 0 do + begin + VarClrProc(P); + Inc(Integer(P), sizeof(Variant)); + Dec(elemCount); + end; + tkArray: + begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + while elemCount > 0 do + begin + _FinalizeArray(P, FT.Fields[0].TypeInfo^, FT.Count); + Inc(Integer(P), FT.Size); + Dec(elemCount); + end; + end; + tkRecord: + begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + while elemCount > 0 do + begin + _FinalizeRecord(P, typeInfo); + Inc(Integer(P), FT.Size); + Dec(elemCount); + end; + end; + tkInterface: + while elemCount > 0 do + begin + _IntfClear(IInterface(P^)); + Inc(Integer(P), 4); + Dec(elemCount); + end; + tkDynArray: + while elemCount > 0 do + begin + _DynArrayClr(P); + Inc(Integer(P), 4); + Dec(elemCount); + end; + else + Error(reInvalidPtr); + end; +end; +{$ELSE} +asm + { -> EAX pointer to data to be finalized } + { EDX pointer to type info describing data } + { ECX number of elements of that type } + + { This code appears to be PIC safe. The functions called from + here either don't make external calls or call Pascal + routines that will fix up EBX in their prolog code + (FreeMem, VarClr, IntfClr). } + + CMP ECX, 0 { no array -> nop } + JE @@zerolength + + PUSH EAX + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + XOR EDX,EDX + MOV AL,[ESI] + MOV DL,[ESI+1] + + CMP AL,tkLString + JE @@LString + + CMP AL,tkWString + JE @@WString + + CMP AL,tkVariant + JE @@Variant + + CMP AL,tkArray + JE @@Array + + CMP AL,tkRecord + JE @@Record + + CMP AL,tkInterface + JE @@Interface + + CMP AL,tkDynArray + JE @@DynArray + + JMP @@error + +@@LString: + CMP ECX,1 + MOV EAX,EBX + JG @@LStringArray + CALL _LStrClr + JMP @@exit +@@LStringArray: + MOV EDX,ECX + CALL _LStrArrayClr + JMP @@exit + +@@WString: + CMP ECX,1 + MOV EAX,EBX + JG @@WStringArray + // CALL _WStrClr + CALL [WStrClrProc] + JMP @@exit +@@WStringArray: + MOV EDX,ECX + // CALL _WStrArrayClr + CALL [WStrArrayClrProc] + JMP @@exit +@@Variant: + MOV EAX,EBX + ADD EBX,16 + CALL _VarClr + DEC EDI + JG @@Variant + JMP @@exit +@@Array: + PUSH EBP + MOV EBP,EDX +@@ArrayLoop: + MOV EDX,[ESI+EBP+2+8] + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV ECX,[ESI+EBP+2+4] + MOV EDX,[EDX] + CALL _FinalizeArray + DEC EDI + JG @@ArrayLoop + POP EBP + JMP @@exit + +@@Record: + PUSH EBP + MOV EBP,EDX +@@RecordLoop: + { inv: EDI = number of array elements to finalize } + + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV EDX,ESI + CALL _FinalizeRecord + DEC EDI + JG @@RecordLoop + POP EBP + JMP @@exit + +@@Interface: + MOV EAX,EBX + ADD EBX,4 + CALL _IntfClear + DEC EDI + JG @@Interface + JMP @@exit + +@@DynArray: + MOV EAX,EBX + MOV EDX,ESI + ADD EBX,4 + CALL _DynArrayClear + DEC EDI + JG @@DynArray + JMP @@exit + +@@error: + POP EDI + POP ESI + POP EBX + POP EAX + MOV AL,reInvalidPtr + JMP Error + +@@exit: + POP EDI + POP ESI + POP EBX + POP EAX +@@zerolength: +end; +{$ENDIF} + +procedure _Finalize(p: Pointer; typeInfo: Pointer); +{$IFDEF PUREPASCAL} +begin + _FinalizeArray(p, typeInfo, 1); +end; +{$ELSE} +asm + MOV ECX,1 + JMP _FinalizeArray +end; +{$ENDIF} + +procedure _AddRefRecord{ p: Pointer; typeInfo: Pointer }; +asm + { -> EAX pointer to record to be referenced } + { EDX pointer to type info } + + XOR ECX,ECX + + PUSH EBX + MOV CL,[EDX+1] + + PUSH ESI + PUSH EDI + + MOV EBX,EAX + LEA ESI,[EDX+ECX+2+8] + MOV EDI,[EDX+ECX+2+4] + +@@loop: + + MOV EDX,[ESI] + MOV EAX,[ESI+4] + ADD EAX,EBX + MOV EDX,[EDX] + MOV ECX, 1 + CALL _AddRefArray + ADD ESI,8 + DEC EDI + JG @@loop + + POP EDI + POP ESI + POP EBX +end; + +procedure DummyProc; +begin +end; + +procedure _AddRefArray{ p: Pointer; typeInfo: Pointer; elemCount: Longint}; +asm + { -> EAX pointer to data to be referenced } + { EDX pointer to type info describing data } + { ECX number of elements of that type } + + { This code appears to be PIC safe. The functions called from + here either don't make external calls (LStrAddRef, WStrAddRef) or + are Pascal routines that will fix up EBX in their prolog code + (VarAddRef, IntfAddRef). } + + PUSH EBX + PUSH ESI + PUSH EDI + + TEST ECX,ECX + JZ @@exit + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + XOR EDX,EDX + MOV AL,[ESI] + MOV DL,[ESI+1] + + CMP AL,tkLString + JE @@LString + CMP AL,tkWString + JE @@WString + CMP AL,tkVariant + JE @@Variant + CMP AL,tkArray + JE @@Array + CMP AL,tkRecord + JE @@Record + CMP AL,tkInterface + JE @@Interface + CMP AL,tkDynArray + JE @@DynArray + MOV AL,reInvalidPtr + POP EDI + POP ESI + POP EBX + JMP Error + +@@LString: + MOV EAX,[EBX] + ADD EBX,4 + CALL _LStrAddRef + DEC EDI + JG @@LString + JMP @@exit + +@@WString: + MOV EAX,EBX + ADD EBX,4 + // CALL _WStrAddRef + CALL [WStrAddRefProc] + DEC EDI + JG @@WString + JMP @@exit +@@Variant: + MOV EAX,EBX + ADD EBX,16 + CALL _VarAddRef + DEC EDI + JG @@Variant + JMP @@exit + +@@Array: + PUSH EBP + MOV EBP,EDX +@@ArrayLoop: + MOV EDX,[ESI+EBP+2+8] + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV ECX,[ESI+EBP+2+4] + MOV EDX,[EDX] + CALL _AddRefArray + DEC EDI + JG @@ArrayLoop + POP EBP + JMP @@exit + +@@Record: + PUSH EBP + MOV EBP,EDX +@@RecordLoop: + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV EDX,ESI + CALL _AddRefRecord + DEC EDI + JG @@RecordLoop + POP EBP + JMP @@exit + +@@Interface: + MOV EAX,[EBX] + ADD EBX,4 + CALL _IntfAddRef + DEC EDI + JG @@Interface + JMP @@exit + +@@DynArray: + MOV EAX,[EBX] + ADD EBX,4 + CALL _DynArrayAddRef + DEC EDI + JG @@DynArray +@@exit: + + POP EDI + POP ESI + POP EBX +end; + + +procedure _AddRef{ p: Pointer; typeInfo: Pointer}; +asm + MOV ECX,1 + JMP _AddRefArray +end; + +procedure _CopyRecord{ dest, source, typeInfo: Pointer }; +asm + { -> EAX pointer to dest } + { EDX pointer to source } + { ECX pointer to typeInfo } + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBX,EAX + MOV ESI,EDX + + XOR EAX,EAX + MOV AL,[ECX+1] + + LEA EDI,[ECX+EAX+2+8] + MOV EBP,[EDI-4] + XOR EAX,EAX + MOV ECX,[EDI-8] + PUSH ECX +@@loop: + MOV ECX,[EDI+4] + SUB ECX,EAX + JLE @@nomove1 + MOV EDX,EAX + ADD EAX,ESI + ADD EDX,EBX + CALL Move +@@noMove1: + MOV EAX,[EDI+4] + + MOV EDX,[EDI] + MOV EDX,[EDX] + MOV CL,[EDX] + + CMP CL,tkLString + JE @@LString + CMP CL,tkWString + JE @@WString + CMP CL,tkVariant + JE @@Variant + CMP CL,tkArray + JE @@Array + CMP CL,tkRecord + JE @@Record + CMP CL,tkInterface + JE @@Interface + CMP CL,tkDynArray + JE @@DynArray + MOV AL,reInvalidPtr + POP EBP + POP EDI + POP ESI + POP EBX + JMP Error + +@@LString: + MOV EDX,[ESI+EAX] + ADD EAX,EBX + CALL _LStrAsg + MOV EAX,4 + JMP @@common + +@@WString: + MOV EDX,[ESI+EAX] + ADD EAX,EBX + CALL _WStrAsg + MOV EAX,4 + JMP @@common + +@@Variant: + LEA EDX,[ESI+EAX] + ADD EAX,EBX + CALL _VarCopy + MOV EAX,16 + JMP @@common + +@@Array: + XOR ECX,ECX + MOV CL,[EDX+1] + PUSH dword ptr [EDX+ECX+2] + PUSH dword ptr [EDX+ECX+2+4] + MOV ECX,[EDX+ECX+2+8] + MOV ECX,[ECX] + LEA EDX,[ESI+EAX] + ADD EAX,EBX + CALL _CopyArray + POP EAX + JMP @@common + +@@Record: + XOR ECX,ECX + MOV CL,[EDX+1] + MOV ECX,[EDX+ECX+2] + PUSH ECX + MOV ECX,EDX + LEA EDX,[ESI+EAX] + ADD EAX,EBX + CALL _CopyRecord + POP EAX + JMP @@common + +@@Interface: + MOV EDX,[ESI+EAX] + ADD EAX,EBX + CALL _IntfCopy + MOV EAX,4 + JMP @@common + +@@DynArray: + MOV ECX,EDX + MOV EDX,[ESI+EAX] + ADD EAX,EBX + CALL _DynArrayAsg + MOV EAX,4 + +@@common: + ADD EAX,[EDI+4] + ADD EDI,8 + DEC EBP + JNZ @@loop + + POP ECX + SUB ECX,EAX + JLE @@noMove2 + LEA EDX,[EBX+EAX] + ADD EAX,ESI + CALL Move +@@noMove2: + + POP EBP + POP EDI + POP ESI + POP EBX +end; + + +procedure _CopyObject{ dest, source: Pointer; vmtPtrOffs: Longint; typeInfo: Pointer }; +asm + { -> EAX pointer to dest } + { EDX pointer to source } + { ECX offset of vmt in object } + { [ESP+4] pointer to typeInfo } + + ADD ECX,EAX { pointer to dest vmt } + PUSH dword ptr [ECX] { save dest vmt } + PUSH ECX + MOV ECX,[ESP+4+4+4] + CALL _CopyRecord + POP ECX + POP dword ptr [ECX] { restore dest vmt } + RET 4 + +end; + +procedure _CopyArray{ dest, source, typeInfo: Pointer; cnt: Integer }; +asm + { -> EAX pointer to dest } + { EDX pointer to source } + { ECX pointer to typeInfo } + { [ESP+4] count } + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + MOV EBP,[ESP+4+4*4] + + MOV CL,[EDI] + + CMP CL,tkLString + JE @@LString + CMP CL,tkWString + JE @@WString + CMP CL,tkVariant + JE @@Variant + CMP CL,tkArray + JE @@Array + CMP CL,tkRecord + JE @@Record + CMP CL,tkInterface + JE @@Interface + CMP CL,tkDynArray + JE @@DynArray + MOV AL,reInvalidPtr + POP EBP + POP EDI + POP ESI + POP EBX + JMP Error + +@@LString: + MOV EAX,EBX + MOV EDX,[ESI] + CALL _LStrAsg + ADD EBX,4 + ADD ESI,4 + DEC EBP + JNE @@LString + JMP @@exit + +@@WString: + MOV EAX,EBX + MOV EDX,[ESI] + CALL _WStrAsg + ADD EBX,4 + ADD ESI,4 + DEC EBP + JNE @@WString + JMP @@exit + +@@Variant: + MOV EAX,EBX + MOV EDX,ESI + CALL _VarCopy + ADD EBX,16 + ADD ESI,16 + DEC EBP + JNE @@Variant + JMP @@exit + +@@Array: + XOR ECX,ECX + MOV CL,[EDI+1] + LEA EDI,[EDI+ECX+2] +@@ArrayLoop: + MOV EAX,EBX + MOV EDX,ESI + MOV ECX,[EDI+8] + PUSH dword ptr [EDI+4] + CALL _CopyArray + ADD EBX,[EDI] + ADD ESI,[EDI] + DEC EBP + JNE @@ArrayLoop + JMP @@exit + +@@Record: + MOV EAX,EBX + MOV EDX,ESI + MOV ECX,EDI + CALL _CopyRecord + XOR EAX,EAX + MOV AL,[EDI+1] + ADD EBX,[EDI+EAX+2] + ADD ESI,[EDI+EAX+2] + DEC EBP + JNE @@Record + JMP @@exit + +@@Interface: + MOV EAX,EBX + MOV EDX,[ESI] + CALL _IntfCopy + ADD EBX,4 + ADD ESI,4 + DEC EBP + JNE @@Interface + JMP @@exit + +@@DynArray: + MOV EAX,EBX + MOV EDX,[ESI] + MOV ECX,EDI + CALL _DynArrayAsg + ADD EBX,4 + ADD ESI,4 + DEC EBP + JNE @@DynArray + +@@exit: + POP EBP + POP EDI + POP ESI + POP EBX + RET 4 +end; + + +function _New(size: Longint; typeInfo: Pointer): Pointer; +{$IFDEF PUREPASCAL} +begin + GetMem(Result, size); + if Result <> nil then + _Initialize(Result, typeInfo); +end; +{$ELSE} +asm + { -> EAX size of object to allocate } + { EDX pointer to typeInfo } + + PUSH EDX + CALL _GetMem + POP EDX + TEST EAX,EAX + JE @@exit + PUSH EAX + CALL _Initialize + POP EAX +@@exit: +end; +{$ENDIF} + +procedure _Dispose(p: Pointer; typeInfo: Pointer); +{$IFDEF PUREPASCAL} +begin + _Finalize(p, typeinfo); + FreeMem(p); +end; +{$ELSE} +asm + { -> EAX Pointer to object to be disposed } + { EDX Pointer to type info } + + PUSH EAX + CALL _Finalize + POP EAX + CALL _FreeMem +end; +{$ENDIF} + +{ ----------------------------------------------------- } +{ Wide character support } +{ ----------------------------------------------------- } + +function WideCharToString(Source: PWideChar): string; +begin + WideCharToStrVar(Source, Result); +end; + +function WideCharLenToString(Source: PWideChar; SourceLen: Integer): string; +begin + WideCharLenToStrVar(Source, SourceLen, Result); +end; + +procedure WideCharToStrVar(Source: PWideChar; var Dest: string); +begin + _LStrFromPWChar(Dest, Source); +end; + +procedure WideCharLenToStrVar(Source: PWideChar; SourceLen: Integer; + var Dest: string); +begin + _LStrFromPWCharLen(Dest, Source, SourceLen); +end; + +function StringToWideChar(const Source: string; Dest: PWideChar; + DestSize: Integer): PWideChar; +begin + Dest[WCharFromChar(Dest, DestSize - 1, PChar(Source), Length(Source))] := #0; + Result := Dest; +end; + +{ ----------------------------------------------------- } +{ OLE string support } +{ ----------------------------------------------------- } + +function OleStrToString(Source: PWideChar): string; +begin + OleStrToStrVar(Source, Result); +end; + +procedure OleStrToStrVar(Source: PWideChar; var Dest: string); +begin + WideCharLenToStrVar(Source, Length(WideString(Pointer(Source))), Dest); +end; + +function StringToOleStr(const Source: string): PWideChar; +begin + Result := nil; + _WStrFromPCharLen(WideString(Pointer(Result)), PChar(Pointer(Source)), Length(Source)); +end; + +{ ----------------------------------------------------- } +{ Variant manager support } +{ ----------------------------------------------------- } + +var + VariantManager: TVariantManager; + +procedure VariantSystemUndefinedError; +asm + MOV AL,reVarInvalidOp + JMP Error; +end; + +procedure VariantSystemDefaultVarClear(var V: TVarData); +begin + case V.VType of + varEmpty, varNull, varError:; + else + VariantSystemUndefinedError; + end; +end; + +procedure InitVariantManager; +type + TPtrArray = array [Word] of Pointer; +var + P: ^TPtrArray; + I: Integer; +begin + P := @VariantManager; + for I := 0 to (SizeOf(VariantManager) div SizeOf(Pointer))-1 do + P[I] := @VariantSystemUndefinedError; + VariantManager.VarClear := @VariantSystemDefaultVarClear; +end; + +procedure GetVariantManager(var VarMgr: TVariantManager); +begin + VarMgr := VariantManager; +end; + +procedure SetVariantManager(const VarMgr: TVariantManager); +begin + VariantManager := VarMgr; +end; + +function IsVariantManagerSet: Boolean; +type + TPtrArray = array [Word] of Pointer; +var + P: ^TPtrArray; + I: Integer; +begin + Result := True; + P := @VariantManager; + for I := 0 to (SizeOf(VariantManager) div SizeOf(Pointer))-1 do + if P[I] <> @VariantSystemUndefinedError then + begin + Result := False; + Break; + end; +end; + + +{ ----------------------------------------------------- } +{ Variant support } +{ ----------------------------------------------------- } + +procedure _DispInvoke;//(var Dest: Variant; const Source: Variant; + //CallDesc: PCallDesc; Params: Pointer); cdecl; +asm +{$IFDEF PIC} + CALL GetGOT + LEA EAX,[EAX].OFFSET VariantManager + JMP [EAX].TVariantManager.DispInvoke +{$ELSE} + JMP VariantManager.DispInvoke +{$ENDIF} +end; + +procedure _VarClear(var V : Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarClear(V); +{$ELSE} +asm + JMP VariantManager.VarClear +{$IFEND} +end; + +procedure _VarCopy(var Dest: Variant; const Source: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarCopy(Dest, Source); +{$ELSE} +asm + JMP VariantManager.VarCopy +{$IFEND} +end; + +procedure _VarCast(var Dest: Variant; const Source: Variant; VarType: Integer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarCast(Dest, Source, VarType); +{$ELSE} +asm + JMP VariantManager.VarCast +{$IFEND} +end; + +procedure _VarCastOle(var Dest: Variant; const Source: Variant; VarType: Integer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarCastOle(Dest, Source, VarType); +{$ELSE} +asm + JMP VariantManager.VarCastOle +{$IFEND} +end; + +function _VarToInt(const V: Variant): Integer; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.VarToInt(V); +{$ELSE} +asm + JMP VariantManager.VarToInt +{$IFEND} +end; + +function _VarToInt64(const V: Variant): Int64; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.VarToInt64(V); +{$ELSE} +asm + JMP VariantManager.VarToInt64 +{$IFEND} +end; + +function _VarToBool(const V: Variant): Boolean; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.VarToBool(V); +{$ELSE} +asm + JMP VariantManager.VarToBool +{$IFEND} +end; + +function _VarToReal(const V: Variant): Extended; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.VarToReal(V); +{$ELSE} +asm + JMP VariantManager.VarToReal +{$IFEND} +end; + +function _VarToCurr(const V: Variant): Currency; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.VarToCurr(V); +{$ELSE} +asm + JMP VariantManager.VarToCurr +{$IFEND} +end; + +procedure _VarToPStr(var S; const V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarToPStr(S, V); +{$ELSE} +asm + JMP VariantManager.VarToPStr +{$IFEND} +end; + +procedure _VarToLStr(var S: string; const V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarToLStr(S, V); +{$ELSE} +asm + JMP VariantManager.VarToLStr +{$IFEND} +end; + +procedure _VarToWStr(var S: WideString; const V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarToWStr(S, V); +{$ELSE} +asm + JMP VariantManager.VarToWStr +{$IFEND} +end; + +procedure _VarToIntf(var Unknown: IInterface; const V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarToIntf(Unknown, V); +{$ELSE} +asm + JMP VariantManager.VarToIntf +{$IFEND} +end; + +procedure _VarToDisp(var Dispatch: IDispatch; const V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarToDisp(Dispatch, V); +{$ELSE} +asm + JMP VariantManager.VarToDisp +{$IFEND} +end; + +procedure _VarToDynArray(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarToDynArray(DynArray, V, TypeInfo); +{$ELSE} +asm + JMP VariantManager.VarToDynArray +{$IFEND} +end; + +procedure _VarFromInt(var V: Variant; const Value, Range: Integer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromInt(V, Value, Range); +{$ELSE} +asm + JMP VariantManager.VarFromInt +{$IFEND} +end; + +procedure _VarFromInt64(var V: Variant; const Value: Int64); +begin + VariantManager.VarFromInt64(V, Value); +end; + +procedure _VarFromBool(var V: Variant; const Value: Boolean); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromBool(V, Value); +{$ELSE} +asm + JMP VariantManager.VarFromBool +{$IFEND} +end; + +procedure _VarFromReal; // var V: Variant; const Value: Real +asm +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + POP ECX + LEA EAX,[EAX].OFFSET VariantManager + MOV EAX,[EAX].TVariantManager.VarFromReal + XCHG EAX,[ESP] + RET +{$ELSE} + JMP VariantManager.VarFromReal +{$ENDIF} +end; + +procedure _VarFromTDateTime; // var V: Variant; const Value: TDateTime +asm +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + POP ECX + LEA EAX,[EAX].OFFSET VariantManager + MOV EAX,[EAX].TVariantManager.VarFromTDateTime + XCHG EAX,[ESP] + RET +{$ELSE} + JMP VariantManager.VarFromTDateTime +{$ENDIF} +end; + +procedure _VarFromCurr; // var V: Variant; const Value: Currency +asm +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + POP ECX + LEA EAX,[EAX].OFFSET VariantManager + MOV EAX,[EAX].TVariantManager.VarFromCurr + XCHG EAX,[ESP] + RET +{$ELSE} + JMP VariantManager.VarFromCurr +{$ENDIF} +end; + +procedure _VarFromPStr(var V: Variant; const Value: ShortString); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromPStr(V, Value); +{$ELSE} +asm + JMP VariantManager.VarFromPStr +{$IFEND} +end; + +procedure _VarFromLStr(var V: Variant; const Value: string); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromLStr(V, Value); +{$ELSE} +asm + JMP VariantManager.VarFromLStr +{$IFEND} +end; + +procedure _VarFromWStr(var V: Variant; const Value: WideString); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromWStr(V, Value); +{$ELSE} +asm + JMP VariantManager.VarFromWStr +{$IFEND} +end; + +procedure _VarFromIntf(var V: Variant; const Value: IInterface); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromIntf(V, Value); +{$ELSE} +asm + JMP VariantManager.VarFromIntf +{$IFEND} +end; + +procedure _VarFromDisp(var V: Variant; const Value: IDispatch); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromDisp(V, Value); +{$ELSE} +asm + JMP VariantManager.VarFromDisp +{$IFEND} +end; + +procedure _VarFromDynArray(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromDynArray(V, DynArray, TypeInfo); +{$ELSE} +asm + JMP VariantManager.VarFromDynArray +{$IFEND} +end; + +procedure _OleVarFromPStr(var V: OleVariant; const Value: ShortString); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.OleVarFromPStr(V, Value); +{$ELSE} +asm + JMP VariantManager.OleVarFromPStr +{$IFEND} +end; + +procedure _OleVarFromLStr(var V: OleVariant; const Value: string); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.OleVarFromLStr(V, Value); +{$ELSE} +asm + JMP VariantManager.OleVarFromLStr +{$IFEND} +end; + +procedure _OleVarFromVar(var V: OleVariant; const Value: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.OleVarFromVar(V, Value); +{$ELSE} +asm + JMP VariantManager.OleVarFromVar +{$IFEND} +end; + +procedure _OleVarFromInt(var V: OleVariant; const Value, Range: Integer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.OleVarFromInt(V, Value, Range); +{$ELSE} +asm + JMP VariantManager.OleVarFromInt +{$IFEND} +end; + +procedure _VarAdd(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opAdd); +{$ELSE} +asm + MOV ECX,opAdd + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarSub(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opSubtract); +{$ELSE} +asm + MOV ECX,opSubtract + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarMul(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opMultiply); +{$ELSE} +asm + MOV ECX,opMultiply + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarDiv(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opIntDivide); +{$ELSE} +asm + MOV ECX,opIntDivide + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarMod(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opModulus); +{$ELSE} +asm + MOV ECX,opModulus + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarAnd(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opAnd); +{$ELSE} +asm + MOV ECX,opAnd + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarOr(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opOr); +{$ELSE} +asm + MOV ECX,opOr + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarXor(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opXor); +{$ELSE} +asm + MOV ECX,opXor + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarShl(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opShiftLeft); +{$ELSE} +asm + MOV ECX,opShiftLeft + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarShr(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opShiftRight); +{$ELSE} +asm + MOV ECX,opShiftRight + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarRDiv(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opDivide); +{$ELSE} +asm + MOV ECX,opDivide + JMP VariantManager.VarOp +{$IFEND} +end; + +{$IF Defined(PIC) or Defined(PUREPASCAL)} +// result is set in the flags +procedure DoVarCmp(const Left, Right: Variant; OpCode: Integer); +begin + VariantManager.VarCmp(TVarData(Left), TVarData(Right), OpCode); +end; +{$IFEND} + +procedure _VarCmpEQ(const Left, Right: Variant); // result is set in the flags +asm + MOV ECX, opCmpEQ +{$IFDEF PIC} + JMP DoVarCmp +{$ELSE} + JMP VariantManager.VarCmp +{$ENDIF} +end; + +procedure _VarCmpNE(const Left, Right: Variant); // result is set in the flags +asm + MOV ECX, opCmpNE +{$IFDEF PIC} + JMP DoVarCmp +{$ELSE} + JMP VariantManager.VarCmp +{$ENDIF} +end; + +procedure _VarCmpLT(const Left, Right: Variant); // result is set in the flags +asm + MOV ECX, opCmpLT +{$IFDEF PIC} + JMP DoVarCmp +{$ELSE} + JMP VariantManager.VarCmp +{$ENDIF} +end; + +procedure _VarCmpLE(const Left, Right: Variant); // result is set in the flags +asm + MOV ECX, opCmpLE +{$IFDEF PIC} + JMP DoVarCmp +{$ELSE} + JMP VariantManager.VarCmp +{$ENDIF} +end; + +procedure _VarCmpGT(const Left, Right: Variant); // result is set in the flags +asm + MOV ECX, opCmpGT +{$IFDEF PIC} + JMP DoVarCmp +{$ELSE} + JMP VariantManager.VarCmp +{$ENDIF} +end; + +procedure _VarCmpGE(const Left, Right: Variant); // result is set in the flags +asm + MOV ECX, opCmpGE +{$IFDEF PIC} + JMP DoVarCmp +{$ELSE} + JMP VariantManager.VarCmp +{$ENDIF} +end; + + +procedure _VarNeg(var V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarNeg(V); +{$ELSE} +asm + JMP VariantManager.VarNeg +{$IFEND} +end; + +procedure _VarNot(var V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarNot(V); +{$ELSE} +asm + JMP VariantManager.VarNot +{$IFEND} +end; + +procedure _VarCopyNoInd; +asm +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + POP ECX + LEA EAX,[EAX].OFFSET VariantManager + MOV EAX,[EAX].TVariantManager.VarCopyNoInd + XCHG EAX,[ESP] + RET +{$ELSE} + JMP VariantManager.VarCopyNoInd +{$ENDIF} +end; + +procedure _VarClr(var V: Variant); +asm + PUSH EAX + CALL _VarClear + POP EAX +end; + +procedure _VarAddRef(var V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarAddRef(V); +{$ELSE} +asm + JMP VariantManager.VarAddRef +{$IFEND} +end; + +procedure _IntfDispCall; +asm +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + POP ECX + LEA EAX,[EAX].OFFSET DispCallByIDProc + MOV EAX,[EAX] + XCHG EAX,[ESP] + RET +{$ELSE} + JMP DispCallByIDProc +{$ENDIF} +end; + +procedure _DispCallByIDError; +asm + MOV AL,reVarDispatch + JMP Error +end; + +procedure _IntfVarCall; +asm +end; + +function _WriteVariant(var T: Text; const V: Variant; Width: Integer): Pointer; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.WriteVariant(T, V, Width); +{$ELSE} +asm + JMP VariantManager.WriteVariant +{$IFEND} +end; + +function _Write0Variant(var T: Text; const V: Variant): Pointer; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.Write0Variant(T, V); +{$ELSE} +asm + JMP VariantManager.Write0Variant +{$IFEND} +end; + +{ ----------------------------------------------------- } +{ Variant array support } +{ ----------------------------------------------------- } + +procedure _VarArrayRedim(var A : Variant; HighBound: Integer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarArrayRedim(A, HighBound); +{$ELSE} +asm + JMP VariantManager.VarArrayRedim +{$IFEND} +end; + +function _VarArrayGet(var A: Variant; IndexCount: Integer; + Indices: Integer): Variant; cdecl; +asm + POP EBP +{$IFDEF PIC} + CALL GetGOT + LEA EAX,[EAX].OFFSET VariantManager + MOV EAX,[EAX].TVariantManager.VarArrayGet + PUSH EAX + RET +{$ELSE} + JMP VariantManager.VarArrayGet +{$ENDIF} +end; + +procedure _VarArrayPut(var A: Variant; const Value: Variant; + IndexCount: Integer; Indices: Integer); cdecl; +asm + POP EBP +{$IFDEF PIC} + CALL GetGOT + LEA EAX,[EAX].OFFSET VariantManager + MOV EAX,[EAX].TVariantManager.VarArrayPut + PUSH EAX + RET +{$ELSE} + JMP VariantManager.VarArrayPut +{$ENDIF} +end; + +// 64 bit integer helper routines +// +// These functions always return the 64-bit result in EAX:EDX + +// ------------------------------------------------------------------------------ +// 64-bit signed multiply +// ------------------------------------------------------------------------------ +// +// Param 1(EAX:EDX), Param 2([ESP+8]:[ESP+4]) ; before reg pushing +// + +procedure __llmul; +asm + push edx + push eax + + // Param2 : [ESP+16]:[ESP+12] (hi:lo) + // Param1 : [ESP+4]:[ESP] (hi:lo) + + mov eax, [esp+16] + mul dword ptr [esp] + mov ecx, eax + + mov eax, [esp+4] + mul dword ptr [esp+12] + add ecx, eax + + mov eax, [esp] + mul dword ptr [esp+12] + add edx, ecx + + pop ecx + pop ecx + + ret 8 +end; + +// ------------------------------------------------------------------------------ +// 64-bit signed multiply, with overflow check (98.05.15: overflow not supported yet) +// ------------------------------------------------------------------------------ +// +// Param1 ~= U (Uh, Ul) +// Param2 ~= V (Vh, Vl) +// +// Param 1(EAX:EDX), Param 2([ESP+8]:[ESP+4]) ; before reg pushing +// +// compiler-helper function +// O-flag set on exit => result is invalid +// O-flag clear on exit => result is valid + +procedure __llmulo; +asm + push edx + push eax + + // Param2 : [ESP+16]:[ESP+12] (hi:lo) + // Param1 : [ESP+4]:[ESP] (hi:lo) + + mov eax, [esp+16] + mul dword ptr [esp] + mov ecx, eax + + mov eax, [esp+4] + mul dword ptr [esp+12] + add ecx, eax + + mov eax, [esp] + mul dword ptr [esp+12] + add edx, ecx + + pop ecx + pop ecx + + ret 8 +end; + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The implementation of function __lldiv is subject to the + * Mozilla Public License Version 1.1 (the "License"); you may + * not use this file except in compliance with the License. + * You may obtain a copy of the License at http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is Fastcode + * + * The Initial Developer of the Original Code is + * Fastcode + * + * Portions created by the Initial Developer are Copyright (C) 2002-2004 + * the Initial Developer. All Rights Reserved. + * + * Contributor(s): AMD, John O'Harrow and Dennis Christensen + * + * ***** END LICENSE BLOCK ***** *) + +// ------------------------------------------------------------------------------ +// 64-bit signed division +// ------------------------------------------------------------------------------ + +// +// Dividend = Numerator, Divisor = Denominator +// +// Dividend(EAX:EDX), Divisor([ESP+8]:[ESP+4]) ; before reg pushing +// +// + +procedure __lldiv; //JOH Version +asm + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX, [ESP+16] + MOV ECX, [ESP+20] + MOV ESI, EDX + MOV EDI, ECX + SAR ESI, 31 + XOR EAX, ESI + XOR EDX, ESI + SUB EAX, ESI + SBB EDX, ESI // EDX:EAX := abs(Dividend) + SAR EDI, 31 + XOR ESI, EDI // 0 if X and Y have same sign + XOR EBX, EDI + XOR ECX, EDI + SUB EBX, EDI + SBB ECX, EDI // ECX:EBX := abs(Divisor) + JNZ @@BigDivisor // divisor > 32^32-1 + CMP EDX, EBX // only one division needed ? (ecx = 0) + JB @@OneDiv // yes, one division sufficient + MOV ECX, EAX // save dividend-lo in ecx + MOV EAX, EDX // get dividend-hi + XOR EDX, EDX // zero extend it into edx:eax + DIV EBX // quotient-hi in eax + XCHG EAX, ECX // ecx = quotient-hi, eax =dividend-lo +@@OneDiv: + DIV EBX // eax = quotient-lo + MOV EDX, ECX // edx = quotient-hi(quotient in edx:eax) + JMP @SetSign +@@BigDivisor: + SUB ESP, 12 // Create three local variables. + MOV [ESP ], EAX // dividend_lo + MOV [ESP+4], EBX // divisor_lo + MOV [ESP+8], EDX // dividend_hi + MOV EDI, ECX // edi:ebx and ecx:esi + SHR EDX, 1 // shift both + RCR EAX, 1 // divisor and + ROR EDI, 1 // and dividend + RCR EBX, 1 // right by 1 bit + BSR ECX, ECX // ecx = number of remaining shifts + SHRD EBX, EDI, CL // scale down divisor and + SHRD EAX, EDX, CL // dividend such that divisor + SHR EDX, CL // less than 2^32 (i.e. fits in ebx) + ROL EDI, 1 // restore original divisor (edi:esi) + DIV EBX // compute quotient + MOV EBX, [ESP] // dividend_lo + MOV ECX, EAX // save quotient + IMUL EDI, EAX // quotient * divisor hi-word (low only) + MUL DWORD PTR [ESP+4] // quotient * divisor low word + ADD EDX, EDI // edx:eax = quotient * divisor + SUB EBX, EAX // dividend-lo - (quot.*divisor)-lo + MOV EAX, ECX // get quotient + MOV ECX, [ESP+8] // dividend_hi + SBB ECX, EDX // subtract divisor * quot. from dividend + SBB EAX, 0 // Adjust quotient if remainder is negative. + XOR EDX, EDX // clear hi-word of quot (eax<=FFFFFFFFh) + ADD ESP, 12 // Remove local variables. +@SetSign: + XOR EAX, ESI // If (quotient < 0), + XOR EDX, ESI // compute 1's complement of result. + SUB EAX, ESI // If (quotient < 0), + SBB EDX, ESI // compute 2's complement of result. +@Done: + POP EDI + POP ESI + POP EBX + RET 8 +end; + +// ------------------------------------------------------------------------------ +// 64-bit signed division with overflow check (98.05.15: not implementated yet) +// ------------------------------------------------------------------------------ + +// +// Dividend = Numerator, Divisor = Denominator +// +// Dividend(EAX:EDX), Divisor([ESP+8]:[ESP+4]) +// Param 1 (EAX:EDX), Param 2([ESP+8]:[ESP+4]) +// +// Param1 ~= U (Uh, Ul) +// Param2 ~= V (Vh, Vl) +// +// compiler-helper function +// O-flag set on exit => result is invalid +// O-flag clear on exit => result is valid +// + +procedure __lldivo; +asm + // check for overflow condition: min(int64) DIV -1 + push esi + mov esi, [esp+12] // Vh + and esi, [esp+8] // Vl + cmp esi, 0ffffffffh // V = -1? + jne @@divok + + mov esi, eax + or esi, edx + cmp esi, 80000000H // U = min(int64)? + jne @@divok + +@@divOvl: + mov eax, esi + pop esi + dec eax // turn on O-flag + ret + +@@divok: + pop esi + push dword ptr [esp+8] // Vh + push dword ptr [esp+8] // Vl (offset is changed from push) + call __lldiv + and eax, eax // turn off O-flag + ret 8 +end; + +// ------------------------------------------------------------------------------ +// 64-bit unsigned division +// ------------------------------------------------------------------------------ + +// Dividend(EAX(hi):EDX(lo)), Divisor([ESP+8](hi):[ESP+4](lo)) // before reg pushing +procedure __lludiv; +asm + push ebp + push ebx + push esi + push edi +// +// Now the stack looks something like this: +// +// 24[esp]: divisor (high dword) +// 20[esp]: divisor (low dword) +// 16[esp]: return EIP +// 12[esp]: previous EBP +// 8[esp]: previous EBX +// 4[esp]: previous ESI +// [esp]: previous EDI +// + +// dividend is pushed last, therefore the first in the args +// divisor next. +// + mov ebx,20[esp] // get the first low word + mov ecx,24[esp] // get the first high word + + or ecx,ecx + jnz @__lludiv@slow_ldiv // both high words are zero + + or edx,edx + jz @__lludiv@quick_ldiv + + or ebx,ebx + jz @__lludiv@quick_ldiv // if ecx:ebx == 0 force a zero divide + // we don't expect this to actually + // work + +@__lludiv@slow_ldiv: + mov ebp,ecx + mov ecx,64 // shift counter + xor edi,edi // fake a 64 bit dividend + xor esi,esi + +@__lludiv@xloop: + shl eax,1 // shift dividend left one bit + rcl edx,1 + rcl esi,1 + rcl edi,1 + cmp edi,ebp // dividend larger? + jb @__lludiv@nosub + ja @__lludiv@subtract + cmp esi,ebx // maybe + jb @__lludiv@nosub + +@__lludiv@subtract: + sub esi,ebx + sbb edi,ebp // subtract the divisor + inc eax // build quotient + +@__lludiv@nosub: + loop @__lludiv@xloop +// +// When done with the loop the four registers values' look like: +// +// | edi | esi | edx | eax | +// | remainder | quotient | +// + +@__lludiv@finish: + pop edi + pop esi + pop ebx + pop ebp + ret 8 + +@__lludiv@quick_ldiv: + div ebx // unsigned divide + xor edx,edx + jmp @__lludiv@finish +end; + +// ------------------------------------------------------------------------------ +// 64-bit modulo +// ------------------------------------------------------------------------------ + +// Dividend(EAX:EDX), Divisor([ESP+8]:[ESP+4]) // before reg pushing +procedure __llmod; +asm + push ebp + push ebx + push esi + push edi + xor edi,edi +// +// dividend is pushed last, therefore the first in the args +// divisor next. +// + mov ebx,20[esp] // get the first low word + mov ecx,24[esp] // get the first high word + or ecx,ecx + jnz @__llmod@slow_ldiv // both high words are zero + + or edx,edx + jz @__llmod@quick_ldiv + + or ebx,ebx + jz @__llmod@quick_ldiv // if ecx:ebx == 0 force a zero divide + // we don't expect this to actually + // work +@__llmod@slow_ldiv: +// +// Signed division should be done. Convert negative +// values to positive and do an unsigned division. +// Store the sign value in the next higher bit of +// di (test mask of 4). Thus when we are done, testing +// that bit will determine the sign of the result. +// + or edx,edx // test sign of dividend + jns @__llmod@onepos + neg edx + neg eax + sbb edx,0 // negate dividend + or edi,1 + +@__llmod@onepos: + or ecx,ecx // test sign of divisor + jns @__llmod@positive + neg ecx + neg ebx + sbb ecx,0 // negate divisor + +@__llmod@positive: + mov ebp,ecx + mov ecx,64 // shift counter + push edi // save the flags +// +// Now the stack looks something like this: +// +// 24[esp]: divisor (high dword) +// 20[esp]: divisor (low dword) +// 16[esp]: return EIP +// 12[esp]: previous EBP +// 8[esp]: previous EBX +// 4[esp]: previous ESI +// [esp]: previous EDI +// + xor edi,edi // fake a 64 bit dividend + xor esi,esi + +@__llmod@xloop: + shl eax,1 // shift dividend left one bit + rcl edx,1 + rcl esi,1 + rcl edi,1 + cmp edi,ebp // dividend larger? + jb @__llmod@nosub + ja @__llmod@subtract + cmp esi,ebx // maybe + jb @__llmod@nosub + +@__llmod@subtract: + sub esi,ebx + sbb edi,ebp // subtract the divisor + inc eax // build quotient + +@__llmod@nosub: + loop @__llmod@xloop +// +// When done with the loop the four registers values' look like: +// +// | edi | esi | edx | eax | +// | remainder | quotient | +// + mov eax,esi + mov edx,edi // use remainder + + pop ebx // get control bits + test ebx,1 // needs negative + jz @__llmod@finish + neg edx + neg eax + sbb edx,0 // negate + +@__llmod@finish: + pop edi + pop esi + pop ebx + pop ebp + ret 8 + +@__llmod@quick_ldiv: + div ebx // unsigned divide + xchg eax,edx + xor edx,edx + jmp @__llmod@finish +end; + +// ------------------------------------------------------------------------------ +// 64-bit signed modulo with overflow (98.05.15: overflow not yet supported) +// ------------------------------------------------------------------------------ + +// Dividend(EAX:EDX), Divisor([ESP+8]:[ESP+4]) +// Param 1 (EAX:EDX), Param 2([ESP+8]:[ESP+4]) +// +// Param1 ~= U (Uh, Ul) +// Param2 ~= V (Vh, Vl) +// +// compiler-helper function +// O-flag set on exit => result is invalid +// O-flag clear on exit => result is valid +// + +procedure __llmodo; +asm + // check for overflow condition: min(int64) MOD -1 + push esi + mov esi, [esp+12] // Vh + and esi, [esp+8] // Vl + cmp esi, 0ffffffffh // V = -1? + jne @@modok + + mov esi, eax + or esi, edx + cmp esi, 80000000H // U = min(int64)? + jne @@modok + +@@modOvl: + mov eax, esi + pop esi + dec eax // turn on O-flag + ret + +@@modok: + pop esi + push dword ptr [esp+8] // Vh + push dword ptr [esp+8] // Vl (offset is changed from push) + call __llmod + and eax, eax // turn off O-flag + ret 8 +end; + +// ------------------------------------------------------------------------------ +// 64-bit unsigned modulo +// ------------------------------------------------------------------------------ +// Dividend(EAX(hi):EDX(lo)), Divisor([ESP+8](hi):[ESP+4](lo)) // before reg pushing + +procedure __llumod; +asm + push ebp + push ebx + push esi + push edi +// +// Now the stack looks something like this: +// +// 24[esp]: divisor (high dword) +// 20[esp]: divisor (low dword) +// 16[esp]: return EIP +// 12[esp]: previous EBP +// 8[esp]: previous EBX +// 4[esp]: previous ESI +// [esp]: previous EDI +// + +// dividend is pushed last, therefore the first in the args +// divisor next. +// + mov ebx,20[esp] // get the first low word + mov ecx,24[esp] // get the first high word + or ecx,ecx + jnz @__llumod@slow_ldiv // both high words are zero + + or edx,edx + jz @__llumod@quick_ldiv + + or ebx,ebx + jz @__llumod@quick_ldiv // if ecx:ebx == 0 force a zero divide + // we don't expect this to actually + // work +@__llumod@slow_ldiv: + mov ebp,ecx + mov ecx,64 // shift counter + xor edi,edi // fake a 64 bit dividend + xor esi,esi // + +@__llumod@xloop: + shl eax,1 // shift dividend left one bit + rcl edx,1 + rcl esi,1 + rcl edi,1 + cmp edi,ebp // dividend larger? + jb @__llumod@nosub + ja @__llumod@subtract + cmp esi,ebx // maybe + jb @__llumod@nosub + +@__llumod@subtract: + sub esi,ebx + sbb edi,ebp // subtract the divisor + inc eax // build quotient + +@__llumod@nosub: + loop @__llumod@xloop +// +// When done with the loop the four registers values' look like: +// +// | edi | esi | edx | eax | +// | remainder | quotient | +// + mov eax,esi + mov edx,edi // use remainder + +@__llumod@finish: + pop edi + pop esi + pop ebx + pop ebp + ret 8 + +@__llumod@quick_ldiv: + div ebx // unsigned divide + xchg eax,edx + xor edx,edx + jmp @__llumod@finish +end; + +// ------------------------------------------------------------------------------ +// 64-bit shift left +// ------------------------------------------------------------------------------ + +// +// target (EAX:EDX) count (ECX) +// +procedure __llshl; +asm + cmp cl, 32 + jl @__llshl@below32 + cmp cl, 64 + jl @__llshl@below64 + xor edx, edx + xor eax, eax + ret + +@__llshl@below64: + mov edx, eax + shl edx, cl + xor eax, eax + ret + +@__llshl@below32: + shld edx, eax, cl + shl eax, cl + ret +end; + +// ------------------------------------------------------------------------------ +// 64-bit signed shift right +// ------------------------------------------------------------------------------ +// target (EAX:EDX) count (ECX) + +procedure __llshr; +asm + cmp cl, 32 + jl @__llshr@below32 + cmp cl, 64 + jl @__llshr@below64 + sar edx, 1fh + mov eax,edx + ret + +@__llshr@below64: + mov eax, edx + cdq + sar eax,cl + ret + +@__llshr@below32: + shrd eax, edx, cl + sar edx, cl + ret +end; + +// ------------------------------------------------------------------------------ +// 64-bit unsigned shift right +// ------------------------------------------------------------------------------ + +// target (EAX:EDX) count (ECX) +procedure __llushr; +asm + cmp cl, 32 + jl @__llushr@below32 + cmp cl, 64 + jl @__llushr@below64 + xor edx, edx + xor eax, eax + ret + +@__llushr@below64: + mov eax, edx + xor edx, edx + shr eax, cl + ret + +@__llushr@below32: + shrd eax, edx, cl + shr edx, cl + ret +end; + +function _StrUInt64Digits(val: UInt64; width: Integer; sign: Boolean): ShortString; +var + d: array[0..31] of Char; { need 19 digits and a sign } + i, k: Integer; + spaces: Integer; +begin + { Produce an ASCII representation of the number in reverse order } + i := 0; + repeat + d[i] := Chr( (val mod 10) + Ord('0') ); + Inc(i); + val := val div 10; + until val = 0; + if sign then + begin + d[i] := '-'; + Inc(i); + end; + + { Fill the Result with the appropriate number of blanks } + if width > 255 then + width := 255; + k := 1; + spaces := width - i; + while k <= spaces do + begin + Result[k] := ' '; + Inc(k); + end; + + { Fill the Result with the number } + while i > 0 do + begin + Dec(i); + Result[k] := d[i]; + Inc(k); + end; + + { Result is k-1 characters long } + SetLength(Result, k-1); +end; + +function _StrInt64(val: Int64; width: Integer): ShortString; +begin + Result := _StrUInt64Digits(Abs(val), width, val < 0); +end; + +function _Str0Int64(val: Int64): ShortString; +begin + Result := _StrInt64(val, 0); +end; + +function _StrUInt64(val: UInt64; width: Integer): ShortString; +begin + Result := _StrUInt64Digits(val, width, False); +end; + +function _Str0UInt64(val: Int64): ShortString; +begin + Result := _StrUInt64(val, 0); +end; + +procedure _WriteInt64; +asm +{ PROCEDURE _WriteInt64( VAR t: Text; val: Int64; with: Longint); } +{ ->EAX Pointer to file record } +{ [ESP+4] Value } +{ EDX Field width } + + SUB ESP,32 { VAR s: String[31]; } + + PUSH EAX + PUSH EDX + + PUSH dword ptr [ESP+8+32+8] { Str( val : 0, s ); } + PUSH dword ptr [ESP+8+32+8] + XOR EAX,EAX + LEA EDX,[ESP+8+8] + CALL _StrInt64 + + POP ECX + POP EAX + + MOV EDX,ESP { Write( t, s : width );} + CALL _WriteString + + ADD ESP,32 + RET 8 +end; + +procedure _Write0Int64; +asm +{ PROCEDURE _Write0Long( VAR t: Text; val: Longint); } +{ ->EAX Pointer to file record } +{ EDX Value } + XOR EDX,EDX + JMP _WriteInt64 +end; + +procedure _WriteUInt64; +asm +{ PROCEDURE _WriteInt64( VAR t: Text; val: Int64; with: Longint); } +{ ->EAX Pointer to file record } +{ [ESP+4] Value } +{ EDX Field width } + + SUB ESP,32 { VAR s: String[31]; } + + PUSH EAX + PUSH EDX + + PUSH dword ptr [ESP+8+32+8] { Str( val : 0, s ); } + PUSH dword ptr [ESP+8+32+8] + XOR EAX,EAX + LEA EDX,[ESP+8+8] + CALL _StrUInt64 + + POP ECX + POP EAX + + MOV EDX,ESP { Write( t, s : width );} + CALL _WriteString + + ADD ESP,32 + RET 8 +end; + +procedure _Write0UInt64; +asm +{ PROCEDURE _Write0Long( VAR t: Text; val: Longint); } +{ ->EAX Pointer to file record } +{ EDX Value } + XOR EDX,EDX + JMP _WriteUInt64 +end; + +procedure _ReadInt64; +asm + // -> EAX Pointer to text record + // <- EAX:EDX Result + + PUSH EBX + PUSH ESI + PUSH EDI + SUB ESP,36 // var numbuf: String[32]; + + MOV ESI,EAX + CALL _SeekEof + DEC AL + JZ @@eof + + MOV EDI,ESP // EDI -> numBuf[0] + MOV BL,32 +@@loop: + MOV EAX,ESI + CALL _ReadChar + CMP AL,' ' + JBE @@endNum + STOSB + DEC BL + JNZ @@loop +@@convert: + MOV byte ptr [EDI],0 + MOV EAX,ESP // EAX -> numBuf + PUSH EDX // allocate code result + MOV EDX,ESP // pass pointer to code + CALL _ValInt64 // convert + POP ECX // pop code result into EDX + TEST ECX,ECX + JZ @@exit + MOV EAX,106 + CALL SetInOutRes + +@@exit: + ADD ESP,36 + POP EDI + POP ESI + POP EBX + RET + +@@endNum: + CMP AH,cEof + JE @@convert + DEC [ESI].TTextRec.BufPos + JMP @@convert + +@@eof: + XOR EAX,EAX + JMP @@exit +end; + +function _ValInt64(const s: AnsiString; var code: Integer): Int64; +var + i: Integer; + dig: Integer; + sign: Boolean; + empty: Boolean; +begin + i := 1; + dig := 0; + Result := 0; + if s = '' then + begin + code := i; + exit; + end; + while s[i] = ' ' do + Inc(i); + sign := False; + if s[i] = '-' then + begin + sign := True; + Inc(i); + end + else if s[i] = '+' then + Inc(i); + empty := True; + if (s[i] = '$') and (Upcase(s[i+1]) = 'X') then + begin + if s[i] = '0' then + Inc(i); + Inc(i); + while True do + begin + case s[i] of + '0'..'9': dig := Ord(s[i]) - Ord('0'); + 'A'..'F': dig := Ord(s[i]) - (Ord('A') - 10); + 'a'..'f': dig := Ord(s[i]) - (Ord('a') - 10); + else + break; + end; + if (Result < 0) or (Result > (High(Int64) div 16)) then + Break; + Result := Result shl 4 + dig; + Inc(i); + empty := False; + end; + if sign then + Result := - Result; + end + else + begin + while True do + begin + case s[i] of + '0'..'9': dig := Ord(s[i]) - Ord('0'); + else + break; + end; + if (Result < 0) or (Result > (High(Int64) div 10)) then + break; + Result := Result*10 + dig; + Inc(i); + empty := False; + end; + if sign then + Result := - Result; + if (Result <> 0) and (sign <> (Result < 0)) then + Dec(i); + end; + if (s[i] <> #0) or empty then + code := i + else + code := 0; +end; + +procedure _DynArrayLength; +asm +{ FUNCTION _DynArrayLength(const a: array of ...): Longint; } +{ ->EAX Pointer to array or nil } +{ <-EAX High bound of array + 1 or 0 } + TEST EAX,EAX + JZ @@skip + MOV EAX,[EAX-4] +@@skip: +end; + +procedure _DynArrayHigh; +asm +{ FUNCTION _DynArrayHigh(const a: array of ...): Longint; } +{ ->EAX Pointer to array or nil } +{ <-EAX High bound of array or -1 } + CALL _DynArrayLength + DEC EAX +end; + +procedure CopyArray(dest, source, typeInfo: Pointer; cnt: Integer); +asm + PUSH dword ptr [EBP+8] + CALL _CopyArray +end; + +procedure FinalizeArray(p, typeInfo: Pointer; cnt: Integer); +asm + JMP _FinalizeArray +end; + +procedure DynArrayClear(var a: Pointer; typeInfo: Pointer); +asm + CALL _DynArrayClear +end; + +procedure DynArraySetLength(var a: Pointer; typeInfo: Pointer; dimCnt: Longint; lengthVec: PLongint); +var + i: Integer; + newLength, oldLength, minLength: Longint; + elSize: Longint; + neededSize: Longint; + p, pp: Pointer; +begin + p := a; + + // Fetch the new length of the array in this dimension, and the old length + newLength := PLongint(lengthVec)^; + if newLength <= 0 then + begin + if newLength < 0 then + Error(reRangeError); + DynArrayClear(a, typeInfo); + exit; + end; + + oldLength := 0; + if p <> nil then + begin + Dec(PLongint(p)); + oldLength := PLongint(p)^; + Dec(PLongint(p)); + end; + + // Calculate the needed size of the heap object + Inc(PChar(typeInfo), Length(PDynArrayTypeInfo(typeInfo).name)); + elSize := PDynArrayTypeInfo(typeInfo).elSize; + if PDynArrayTypeInfo(typeInfo).elType <> nil then + typeInfo := PDynArrayTypeInfo(typeInfo).elType^ + else + typeInfo := nil; + neededSize := newLength*elSize; + if neededSize div newLength <> elSize then + Error(reRangeError); + Inc(neededSize, Sizeof(Longint)*2); + + // If the heap object isn't shared (ref count = 1), just resize it. Otherwise, we make a copy + if (p = nil) or (PLongint(p)^ = 1) then + begin + pp := p; + if (newLength < oldLength) and (typeInfo <> nil) then + FinalizeArray(PChar(p) + Sizeof(Longint)*2 + newLength*elSize, typeInfo, oldLength - newLength); + ReallocMem(pp, neededSize); + p := pp; + end + else + begin + Dec(PLongint(p)^); + GetMem(p, neededSize); + minLength := oldLength; + if minLength > newLength then + minLength := newLength; + if typeInfo <> nil then + begin + FillChar((PChar(p) + Sizeof(Longint)*2)^, minLength*elSize, 0); + CopyArray(PChar(p) + Sizeof(Longint)*2, a, typeInfo, minLength) + end + else + Move(PChar(a)^, (PChar(p) + Sizeof(Longint)*2)^, minLength*elSize); + end; + + // The heap object will now have a ref count of 1 and the new length + PLongint(p)^ := 1; + Inc(PLongint(p)); + PLongint(p)^ := newLength; + Inc(PLongint(p)); + + // Set the new memory to all zero bits + FillChar((PChar(p) + elSize * oldLength)^, elSize * (newLength - oldLength), 0); + + // Take care of the inner dimensions, if any + if dimCnt > 1 then + begin + Inc(lengthVec); + Dec(dimCnt); + for i := 0 to newLength-1 do + DynArraySetLength(PPointerArray(p)[i], typeInfo, dimCnt, lengthVec); + end; + a := p; +end; + +procedure _DynArraySetLength; +asm +{ PROCEDURE _DynArraySetLength(var a: dynarray; typeInfo: PDynArrayTypeInfo; dimCnt: Longint; lengthVec: ^Longint) } +{ ->EAX Pointer to dynamic array (= pointer to pointer to heap object) } +{ EDX Pointer to type info for the dynamic array } +{ ECX number of dimensions } +{ [ESP+4] dimensions } + PUSH ESP + ADD dword ptr [ESP],4 + CALL DynArraySetLength +end; + +procedure _DynArrayCopy(a: Pointer; typeInfo: Pointer; var Result: Pointer); +begin + if a <> nil then + _DynArrayCopyRange(a, typeInfo, 0, PLongint(PChar(a)-4)^, Result) + else + _DynArrayClear(Result, typeInfo); +end; + +procedure _DynArrayCopyRange(a: Pointer; typeInfo: Pointer; index, count : Integer; var Result: Pointer); +var + arrayLength: Integer; + elSize: Integer; + typeInf: PDynArrayTypeInfo; + p: Pointer; +begin + p := nil; + if a <> nil then + begin + typeInf := typeInfo; + + // Limit index and count to values within the array + if index < 0 then + begin + Inc(count, index); + index := 0; + end; + arrayLength := PLongint(PChar(a)-4)^; + if index > arrayLength then + index := arrayLength; + if count > arrayLength - index then + count := arrayLength - index; + if count < 0 then + count := 0; + + if count > 0 then + begin + // Figure out the size and type descriptor of the element type + Inc(PChar(typeInf), Length(typeInf.name)); + elSize := typeInf.elSize; + if typeInf.elType <> nil then + typeInf := typeInf.elType^ + else + typeInf := nil; + + // Allocate the amount of memory needed + GetMem(p, count*elSize + Sizeof(Longint)*2); + + // The reference count of the new array is 1, the length is count + PLongint(p)^ := 1; + Inc(PLongint(p)); + PLongint(p)^ := count; + Inc(PLongint(p)); + Inc(PChar(a), index*elSize); + + // If the element type needs destruction, we must copy each element, + // otherwise we can just copy the bits + if count > 0 then + begin + if typeInf <> nil then + begin + FillChar(p^, count*elSize, 0); + CopyArray(p, a, typeInf, count) + end + else + Move(a^, p^, count*elSize); + end; + end; + end; + DynArrayClear(Result, typeInfo); + Result := p; +end; + +procedure _DynArrayClear; +asm +{ ->EAX Pointer to dynamic array (Pointer to pointer to heap object } +{ EDX Pointer to type info } + + { Nothing to do if Pointer to heap object is nil } + MOV ECX,[EAX] + TEST ECX,ECX + JE @@exit + + { Set the variable to be finalized to nil } + MOV dword ptr [EAX],0 + + { Decrement ref count. Nothing to do if not zero now. } + { LOCK} DEC dword ptr [ECX-8] + JNE @@exit + + { Save the source - we're supposed to return it } + PUSH EAX + MOV EAX,ECX + + { Fetch the type descriptor of the elements } + XOR ECX,ECX + MOV CL,[EDX].TDynArrayTypeInfo.name; + MOV EDX,[EDX+ECX].TDynArrayTypeInfo.elType; + + { If it's non-nil, finalize the elements } + TEST EDX,EDX + JE @@noFinalize + MOV ECX,[EAX-4] + TEST ECX,ECX + JE @@noFinalize + MOV EDX,[EDX] + CALL _FinalizeArray +@@noFinalize: + { Now deallocate the array } + SUB EAX,8 + CALL _FreeMem + POP EAX +@@exit: +end; + + +procedure _DynArrayAsg; +asm +{ ->EAX Pointer to destination (pointer to pointer to heap object } +{ EDX source (pointer to heap object } +{ ECX Pointer to rtti describing dynamic array } + + PUSH EBX + MOV EBX,[EAX] + + { Increment ref count of source if non-nil } + + TEST EDX,EDX + JE @@skipInc +{ LOCK} INC dword ptr [EDX-8] +@@skipInc: + { Dec ref count of destination - if it becomes 0, clear dest } + TEST EBX,EBX + JE @@skipClear + { LOCK} DEC dword ptr[EBX-8] + JNZ @@skipClear + PUSH EAX + PUSH EDX + MOV EDX,ECX + INC dword ptr[EBX-8] + CALL _DynArrayClear + POP EDX + POP EAX +@@skipClear: + { Finally store source into destination } + MOV [EAX],EDX + + POP EBX +end; + +procedure _DynArrayAddRef; +asm +{ ->EAX Pointer to heap object } + TEST EAX,EAX + JE @@exit +{ LOCK} INC dword ptr [EAX-8] +@@exit: +end; + + +function DynArrayIndex(const P: Pointer; const Indices: array of Integer; const TypInfo: Pointer): Pointer; +asm + { ->EAX P } + { EDX Pointer to Indices } + { ECX High bound of Indices } + { [EBP+8] TypInfo } + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV ESI,EDX + MOV EDI,[EBP+8] + MOV EBP,EAX + + XOR EBX,EBX { for i := 0 to High(Indices) do } + TEST ECX,ECX + JGE @@start +@@loop: + MOV EBP,[EBP] +@@start: + XOR EAX,EAX + MOV AL,[EDI].TDynArrayTypeInfo.name + ADD EDI,EAX + MOV EAX,[ESI+EBX*4] { P := P + Indices[i]*TypInfo.elSize } + MUL [EDI].TDynArrayTypeInfo.elSize + MOV EDI,[EDI].TDynArrayTypeInfo.elType + TEST EDI,EDI + JE @@skip + MOV EDI,[EDI] +@@skip: + ADD EBP,EAX + INC EBX + CMP EBX,ECX + JLE @@loop + +@@loopEnd: + + MOV EAX,EBP + + POP EBP + POP EDI + POP ESI + POP EBX +end; + + +{ Returns the DynArrayTypeInfo of the Element Type of the specified DynArrayTypeInfo } +function DynArrayElTypeInfo(typeInfo: PDynArrayTypeInfo): PDynArrayTypeInfo; +begin + Result := nil; + if typeInfo <> nil then + begin + Inc(PChar(typeInfo), Length(typeInfo.name)); + if typeInfo.elType <> nil then + Result := typeInfo.elType^; + end; +end; + +{ Returns # of dimemsions of the DynArray described by the specified DynArrayTypeInfo} +function DynArrayDim(typeInfo: PDynArrayTypeInfo): Integer; +begin + Result := 0; + while (typeInfo <> nil) and (typeInfo.kind = tkDynArray) do + begin + Inc(Result); + typeInfo := DynArrayElTypeInfo(typeInfo); + end; +end; + +{ Returns size of the Dynamic Array} +function DynArraySize(a: Pointer): Integer; +asm + TEST EAX, EAX + JZ @@exit + MOV EAX, [EAX-4] +@@exit: +end; + +// Returns whether array is rectangular +function IsDynArrayRectangular(const DynArray: Pointer; typeInfo: PDynArrayTypeInfo): Boolean; +var + Dim, I, J, Size, SubSize: Integer; + P: Pointer; +begin + // Assume we have a rectangular array + Result := True; + + P := DynArray; + Dim := DynArrayDim(typeInfo); + + {NOTE: Start at 1. Don't need to test the first dimension - it's rectangular by definition} + for I := 1 to dim-1 do + begin + if P <> nil then + begin + { Get size of this dimension } + Size := DynArraySize(P); + + { Get Size of first sub. dimension } + SubSize := DynArraySize(PPointerArray(P)[0]); + + { Walk through every dimension making sure they all have the same size} + for J := 1 to Size-1 do + if DynArraySize(PPointerArray(P)[J]) <> SubSize then + begin + Result := False; + Exit; + end; + + { Point to next dimension} + P := PPointerArray(P)[0]; + end; + end; +end; + +// Returns Bounds of Dynamic array as an array of integer containing the 'high' of each dimension +function DynArrayBounds(const DynArray: Pointer; typeInfo: PDynArrayTypeInfo): TBoundArray; +var + Dim, I: Integer; + P: Pointer; +begin + P := DynArray; + + Dim := DynArrayDim(typeInfo); + SetLength(Result, Dim); + + for I := 0 to dim-1 do + if P <> nil then + begin + Result[I] := DynArraySize(P)-1; + P := PPointerArray(P)[0]; // Assume rectangular arrays + end; +end; + +{ Decrements to next lower index - Returns True if successful } +{ Indices: Indices to be decremented } +{ Bounds : High bounds of each dimension } +function DecIndices(var Indices: TBoundArray; const Bounds: TBoundArray): Boolean; +var + I, J: Integer; +begin + { Find out if we're done: all at zeroes } + Result := False; + for I := Low(Indices) to High(Indices) do + if Indices[I] <> 0 then + begin + Result := True; + break; + end; + if not Result then + Exit; + + { Two arrays must be of same length } + Assert(Length(Indices) = Length(Bounds)); + + { Find index of item to tweak } + for I := High(Indices) downto Low(Bounds) do + begin + // If not reach zero, dec and bail out + if Indices[I] <> 0 then + begin + Dec(Indices[I]); + Exit; + end + else + begin + J := I; + while Indices[J] = 0 do + begin + // Restore high bound when we've reached zero on a particular dimension + Indices[J] := Bounds[J]; + // Move to higher dimension + Dec(J); + Assert(J >= 0); + end; + Dec(Indices[J]); + Exit; + end; + end; +end; + +{ Package/Module registration/unregistration } + +{$IFDEF MSWINDOWS} +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 +{$ENDIF} + +function FindModule(Instance: LongWord): PLibModule; +begin + Result := LibModuleList; + while Result <> nil do + begin + if (Instance = Result.Instance) or + (Instance = Result.CodeInstance) or + (Instance = Result.DataInstance) or + (Instance = Result.ResInstance) then + Exit; + Result := Result.Next; + end; +end; + +function FindHInstance(Address: Pointer): LongWord; +{$IFDEF MSWINDOWS} +var + MemInfo: TMemInfo; +begin + VirtualQuery(Address, MemInfo, SizeOf(MemInfo)); + if MemInfo.State = $1000{MEM_COMMIT} then + Result := LongWord(MemInfo.AllocationBase) + else + Result := 0; +end; +{$ENDIF} +{$IFDEF LINUX} +var + Info: TDLInfo; +begin + if (dladdr(Address, Info) = 0) or (Info.BaseAddress = ExeBaseAddress) then + Info.Filename := nil; // if it's not in a library, assume the exe + Result := LongWord(dlopen(Info.Filename, RTLD_LAZY)); + if Result <> 0 then + dlclose(Result); +end; +{$ENDIF} + +function FindClassHInstance(ClassType: TClass): LongWord; +begin + Result := FindHInstance(Pointer(ClassType)); +end; + +{$IFDEF LINUX} +function GetModuleFileName(Module: HMODULE; Buffer: PChar; BufLen: Integer): Integer; +var + Addr: Pointer; + Info: TDLInfo; + FoundInModule: HMODULE; +begin + Result := 0; + if (Module = MainInstance) or (Module = 0) then + begin + // First, try the dlsym approach. + // dladdr fails to return the name of the main executable + // in glibc prior to 2.1.91 + +{ Look for a dynamic symbol exported from this program. + _DYNAMIC is not required in a main program file. + If the main program is compiled with Delphi, it will always + have a resource section, named @Sysinit@ResSym. + If the main program is not compiled with Delphi, dlsym + will search the global name space, potentially returning + the address of a symbol in some other shared object library + loaded by the program. To guard against that, we check + that the address of the symbol found is within the + main program address range. } + + dlerror; // clear error state; dlsym doesn't + Addr := dlsym(Module, '@Sysinit@ResSym'); + if (Addr <> nil) and (dlerror = nil) + and (dladdr(Addr, Info) <> 0) + and (Info.FileName <> nil) + and (Info.BaseAddress = ExeBaseAddress) then + begin + Result := _strlen(Info.FileName); + if Result >= BufLen then Result := BufLen-1; + Move(Info.FileName^, Buffer^, Result); + Buffer[Result] := #0; + Exit; + end; + + // Try inspecting the /proc/ virtual file system + // to find the program filename in the process info + Result := _readlink('/proc/self/exe', Buffer, BufLen); + if Result <> -1 then + begin + if Result >= BufLen then Result := BufLen-1; + Buffer[Result] := #0; + end; +{$IFDEF AllowParamStrModuleName} +{ Using ParamStr(0) to obtain a module name presents a potential + security hole. Resource modules are loaded based upon the filename + of a given module. We use dlopen() to load resource modules, which + means the .init code of the resource module will be executed. + Normally, resource modules contain no code at all - they're just + carriers of resource data. + An unpriviledged user program could launch our trusted, + priviledged program with a bogus parameter list, tricking us + into loading a module that contains malicious code in its + .init section. + Without this ParamStr(0) section, GetModuleFilename cannot be + misdirected by unpriviledged code (unless the system program loader + or the /proc file system or system root directory has been compromised). + Resource modules are always loaded from the same directory as the + given module. Trusted code (programs, packages, and libraries) + should reside in directories that unpriviledged code cannot alter. + + If you need GetModuleFilename to have a chance of working on systems + where glibc < 2.1.91 and /proc is not available, and your + program will not run as a priviledged user (or you don't care), + you can define AllowParamStrModuleNames and rebuild the System unit + and baseCLX package. Note that even with ParamStr(0) support + enabled, GetModuleFilename can still fail to find the name of + a module. C'est la Unix. } + + if Result = -1 then // couldn't access the /proc filesystem + begin // return less accurate ParamStr(0) + +{ ParamStr(0) returns the name of the link used + to launch the app, not the name of the app itself. + Also, if this app was launched by some other program, + there is no guarantee that the launching program has set + up our environment at all. (example: Apache CGI) } + + if (ArgValues = nil) or (ArgValues^ = nil) or + (PCharArray(ArgValues^)[0] = nil) then + begin + Result := 0; + Exit; + end; + Result := _strlen(PCharArray(ArgValues^)[0]); + if Result >= BufLen then Result := BufLen-1; + Move(PCharArray(ArgValues^)[0]^, Buffer^, Result); + Buffer[Result] := #0; + end; +{$ENDIF} + end + else + begin +{ For shared object libraries, we can rely on the dlsym technique. + Look for a dynamic symbol in the requested module. + Don't assume the module was compiled with Delphi. + We look for a dynamic symbol with the name _DYNAMIC. This + exists in all ELF shared object libraries that export + or import symbols; If someone has a shared object library that + contains no imports or exports of any kind, this will probably fail. + If dlsym can't find the requested symbol in the given module, it + will search the global namespace and could return the address + of a symbol from some other module that happens to be loaded + into this process. That would be bad, so we double check + that the module handle of the symbol found matches the + module handle we asked about.} + + dlerror; // clear error state; dlsym doesn't + Addr := dlsym(Module, '_DYNAMIC'); + if (Addr <> nil) and (dlerror = nil) + and (dladdr(Addr, Info) <> 0) then + begin + if Info.BaseAddress = ExeBaseAddress then + Info.FileName := nil; + FoundInModule := HMODULE(dlopen(Info.FileName, RTLD_LAZY)); + if FoundInModule <> 0 then + dlclose(FoundInModule); + if Module = FoundInModule then + begin + Result := _strlen(Info.FileName); + if Result >= BufLen then Result := BufLen-1; + Move(Info.FileName^, Buffer^, Result); + Buffer[Result] := #0; + end; + end; + end; + if Result < 0 then Result := 0; +end; +{$ENDIF} + +function DelayLoadResourceModule(Module: PLibModule): LongWord; +var + FileName: array[0..MAX_PATH] of Char; +begin + if Module.ResInstance = 0 then + begin + GetModuleFileName(Module.Instance, FileName, SizeOf(FileName)); + Module.ResInstance := LoadResourceModule(FileName); + if Module.ResInstance = 0 then + Module.ResInstance := Module.Instance; + end; + Result := Module.ResInstance; +end; + +function FindResourceHInstance(Instance: LongWord): LongWord; +var + CurModule: PLibModule; +begin + CurModule := LibModuleList; + while CurModule <> nil do + begin + if (Instance = CurModule.Instance) or + (Instance = CurModule.CodeInstance) or + (Instance = CurModule.DataInstance) then + begin + Result := DelayLoadResourceModule(CurModule); + Exit; + end; + CurModule := CurModule.Next; + end; + Result := Instance; +end; + +function LoadResourceModule(ModuleName: PChar; CheckOwner: Boolean): LongWord; +{$IFDEF LINUX} +var + FileName: array [0..MAX_PATH] of Char; + LangCode: PChar; // Language and country code. Example: en_US + P: PChar; + ModuleNameLen, FileNameLen, i: Integer; + st1, st2: TStatStruct; +begin + LangCode := __getenv('LANG'); + Result := 0; + if (LangCode = nil) or (LangCode^ = #0) then Exit; + + // look for modulename.en_US (ignoring codeset and modifier suffixes) + P := LangCode; + while P^ in ['a'..'z', 'A'..'Z', '_'] do + Inc(P); + if P = LangCode then Exit; + + if CheckOwner and (__xstat(STAT_VER_LINUX, ModuleName, st1) = -1) then + Exit; + + ModuleNameLen := _strlen(ModuleName); + if (ModuleNameLen + P - LangCode) >= MAX_PATH then Exit; + Move(ModuleName[0], Filename[0], ModuleNameLen); + Filename[ModuleNameLen] := '.'; + Move(LangCode[0], Filename[ModuleNameLen + 1], P - LangCode); + FileNameLen := ModuleNameLen + 1 + (P - LangCode); + Filename[FileNameLen] := #0; + +{ Security check: make sure the user id (owner) and group id of + the base module matches the user id and group id of the resource + module we're considering loading. This is to prevent loading + of malicious code dropped into the base module's directory by + a hostile user. The app and all its resource modules must + have the same owner and group. To disable this security check, + call this function with CheckOwner set to False. } + + if (not CheckOwner) or + ((__xstat(STAT_VER_LINUX, FileName, st2) <> -1) + and (st1.st_uid = st2.st_uid) + and (st1.st_gid = st2.st_gid)) then + begin + Result := dlopen(Filename, RTLD_LAZY); + if Result <> 0 then Exit; + end; + + // look for modulename.en (ignoring country code and suffixes) + i := ModuleNameLen + 1; + while (i <= FileNameLen) and (Filename[i] in ['a'..'z', 'A'..'Z']) do + Inc(i); + if (i = ModuleNameLen + 1) or (i > FileNameLen) then Exit; + FileName[i] := #0; + + { Security check. See notes above. } + if (not CheckOwner) or + ((__xstat(STAT_VER_LINUX, FileName, st2) <> -1) + and (st1.st_uid = st2.st_uid) + and (st1.st_gid = st2.st_gid)) then + begin + Result := dlopen(FileName, RTLD_LAZY); + end; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +var + FileName: array[0..MAX_PATH] of Char; + Key: LongWord; + LocaleName, LocaleOverride: array[0..4] of Char; + Size: Integer; + P: PChar; + + function FindBS(Current: PChar): PChar; + begin + Result := Current; + while (Result^ <> #0) and (Result^ <> '\') do + Result := CharNext(Result); + end; + + function ToLongPath(AFileName: PChar; BufSize: Integer): PChar; + var + CurrBS, NextBS: PChar; + Handle, L: Integer; + FindData: TWin32FindData; + Buffer: array[0..MAX_PATH] of Char; + GetLongPathName: function (ShortPathName: PChar; LongPathName: PChar; + cchBuffer: Integer): Integer stdcall; + begin + Result := AFileName; + Handle := GetModuleHandle(kernel); + if Handle <> 0 then + begin + @GetLongPathName := GetProcAddress(Handle, 'GetLongPathNameA'); + if Assigned(GetLongPathName) and + (GetLongPathName(AFileName, Buffer, SizeOf(Buffer)) <> 0) then + begin + lstrcpyn(AFileName, Buffer, BufSize); + Exit; + end; + end; + + if AFileName[0] = '\' then + begin + if AFileName[1] <> '\' then Exit; + CurrBS := FindBS(AFileName + 2); // skip server name + if CurrBS^ = #0 then Exit; + CurrBS := FindBS(CurrBS + 1); // skip share name + if CurrBS^ = #0 then Exit; + end else + CurrBS := AFileName + 2; // skip drive name + + L := CurrBS - AFileName; + lstrcpyn(Buffer, AFileName, L + 1); + while CurrBS^ <> #0 do + begin + NextBS := FindBS(CurrBS + 1); + if L + (NextBS - CurrBS) + 1 > SizeOf(Buffer) then Exit; + lstrcpyn(Buffer + L, CurrBS, (NextBS - CurrBS) + 1); + + Handle := FindFirstFile(Buffer, FindData); + if (Handle = -1) then Exit; + FindClose(Handle); + + if L + 1 + _strlen(FindData.cFileName) + 1 > SizeOf(Buffer) then Exit; + Buffer[L] := '\'; + lstrcpyn(Buffer + L + 1, FindData.cFileName, Sizeof(Buffer) - L - 1); + Inc(L, _strlen(FindData.cFileName) + 1); + CurrBS := NextBS; + end; + lstrcpyn(AFileName, Buffer, BufSize); + end; +begin + GetModuleFileName(0, FileName, SizeOf(FileName)); // Get host application name + LocaleOverride[0] := #0; + if (RegOpenKeyEx(HKEY_CURRENT_USER, NewLocaleOverrideKey, 0, KEY_READ, Key) = 0) or + (RegOpenKeyEx(HKEY_LOCAL_MACHINE, NewLocaleOverrideKey, 0, KEY_READ, Key) = 0) or + (RegOpenKeyEx(HKEY_CURRENT_USER, OldLocaleOverrideKey, 0, KEY_READ, Key) = 0) then + try + Size := sizeof(LocaleOverride); + ToLongPath(FileName, sizeof(FileName)); + if RegQueryValueEx(Key, FileName, nil, nil, LocaleOverride, @Size) <> 0 then + if RegQueryValueEx(Key, '', nil, nil, LocaleOverride, @Size) <> 0 then + LocaleOverride[0] := #0; + LocaleOverride[sizeof(LocaleOverride)-1] := #0; + finally + RegCloseKey(Key); + end; + lstrcpyn(FileName, ModuleName, sizeof(FileName)); + GetLocaleInfo(GetThreadLocale, LOCALE_SABBREVLANGNAME, LocaleName, sizeof(LocaleName)); + Result := 0; + if (FileName[0] <> #0) and ((LocaleName[0] <> #0) or (LocaleOverride[0] <> #0)) then + begin + P := PChar(@FileName) + _strlen(FileName); + while (P^ <> '.') and (P <> @FileName) do Dec(P); + if P <> @FileName then + begin + Inc(P); + // First look for a locale registry override + if LocaleOverride[0] <> #0 then + begin + lstrcpyn(P, LocaleOverride, sizeof(FileName) - (P - FileName)); + Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE); + end; + if (Result = 0) and (LocaleName[0] <> #0) then + begin + // Then look for a potential language/country translation + lstrcpyn(P, LocaleName, sizeof(FileName) - (P - FileName)); + Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE); + if Result = 0 then + begin + // Finally look for a language only translation + LocaleName[2] := #0; + lstrcpyn(P, LocaleName, sizeof(FileName) - (P - FileName)); + Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE); + end; + end; + end; + end; +end; +{$ENDIF} + +procedure EnumModules(Func: TEnumModuleFunc; Data: Pointer); assembler; +begin + EnumModules(TEnumModuleFuncLW(Func), Data); +end; + +procedure EnumResourceModules(Func: TEnumModuleFunc; Data: Pointer); +begin + EnumResourceModules(TEnumModuleFuncLW(Func), Data); +end; + +procedure EnumModules(Func: TEnumModuleFuncLW; Data: Pointer); +var + CurModule: PLibModule; +begin + CurModule := LibModuleList; + while CurModule <> nil do + begin + if not Func(CurModule.Instance, Data) then Exit; + CurModule := CurModule.Next; + end; +end; + +procedure EnumResourceModules(Func: TEnumModuleFuncLW; Data: Pointer); +var + CurModule: PLibModule; +begin + CurModule := LibModuleList; + while CurModule <> nil do + begin + if not Func(DelayLoadResourceModule(CurModule), Data) then Exit; + CurModule := CurModule.Next; + end; +end; + +procedure AddModuleUnloadProc(Proc: TModuleUnloadProc); +begin + AddModuleUnloadProc(TModuleUnloadProcLW(Proc)); +end; + +procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProc); +begin + RemoveModuleUnloadProc(TModuleUnloadProcLW(Proc)); +end; + +procedure AddModuleUnloadProc(Proc: TModuleUnloadProcLW); +var + P: PModuleUnloadRec; +begin + New(P); + P.Next := ModuleUnloadList; + @P.Proc := @Proc; + ModuleUnloadList := P; +end; + +procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProcLW); +var + P, C: PModuleUnloadRec; +begin + P := ModuleUnloadList; + if (P <> nil) and (@P.Proc = @Proc) then + begin + ModuleUnloadList := ModuleUnloadList.Next; + Dispose(P); + end else + begin + C := P; + while C <> nil do + begin + if (C.Next <> nil) and (@C.Next.Proc = @Proc) then + begin + P := C.Next; + C.Next := C.Next.Next; + Dispose(P); + Break; + end; + C := C.Next; + end; + end; +end; + +procedure NotifyModuleUnload(HInstance: LongWord); +var + P: PModuleUnloadRec; +begin + P := ModuleUnloadList; + while P <> nil do + begin + try + P.Proc(HInstance); + except + // Make sure it doesn't stop notifications + end; + P := P.Next; + end; +{$IFDEF LINUX} + InvalidateModuleCache; +{$ENDIF} +end; + +procedure RegisterModule(LibModule: PLibModule); +begin + LibModule.Next := LibModuleList; + LibModuleList := LibModule; +end; + +procedure UnRegisterModuleSafely( LibModule: PLibModule ); +var + CurModule: PLibModule; +begin + try + NotifyModuleUnload(LibModule.Instance); + finally + if LibModule = LibModuleList then + LibModuleList := LibModule.Next + else + begin + CurModule := LibModuleList; + while CurModule <> nil do + begin + if CurModule.Next = LibModule then + begin + CurModule.Next := LibModule.Next; + Break; + end; + CurModule := CurModule.Next; + end; + end; + end; +end; + +{X+} // "Light" version of UnRegisterModule - without using of try-except +procedure UnRegisterModuleLight( LibModule: PLibModule ); +var + P: PModuleUnloadRec; +begin + P := ModuleUnloadList; + while P <> nil do + begin + P.Proc(LibModule.Instance); + P := P.Next; + end; +end; +{X-} + +function _IntfClear(var Dest: IInterface): Pointer; +{$IFDEF PUREPASCAL} +var + P: Pointer; +begin + Result := @Dest; + if Dest <> nil then + begin + P := Pointer(Dest); + Pointer(Dest) := nil; + IInterface(P)._Release; + end; +end; +{$ELSE} +asm + MOV EDX,[EAX] + TEST EDX,EDX + JE @@1 + MOV DWORD PTR [EAX],0 + PUSH EAX + PUSH EDX + MOV EAX,[EDX] + CALL [EAX] + VMTOFFSET IInterface._Release + POP EAX +@@1: +end; +{$ENDIF} + +procedure _IntfCopy(var Dest: IInterface; const Source: IInterface); +{$IFDEF PUREPASCAL} +var + P: Pointer; +begin + P := Pointer(Dest); + if Source <> nil then + Source._AddRef; + Pointer(Dest) := Pointer(Source); + if P <> nil then + IInterface(P)._Release; +end; +{$ELSE} +asm +{ + The most common case is the single assignment of a non-nil interface + to a nil interface. So we streamline that case here. After this, + we give essentially equal weight to other outcomes. + + The semantics are: The source intf must be addrefed *before* it + is assigned to the destination. The old intf must be released + after the new intf is addrefed to support self assignment (I := I). + Either intf can be nil. The first requirement is really to make an + error case function a little better, and to improve the behaviour + of multithreaded applications - if the addref throws an exception, + you don't want the interface to have been assigned here, and if the + assignment is made to a global and another thread references it, + again you don't want the intf to be available until the reference + count is bumped. +} + TEST EDX,EDX // is source nil? + JE @@NilSource + PUSH EDX // save source + PUSH EAX // save dest + MOV EAX,[EDX] // get source vmt + PUSH EDX // source as arg + CALL DWORD PTR [EAX] + VMTOFFSET IInterface._AddRef + POP EAX // retrieve dest + MOV ECX, [EAX] // get current value + POP [EAX] // set dest in place + TEST ECX, ECX // is current value nil? + JNE @@ReleaseDest // no, release it + RET // most common case, we return here +@@ReleaseDest: + MOV EAX,[ECX] // get current value vmt + PUSH ECX // current value as arg + CALL DWORD PTR [EAX] + VMTOFFSET IInterface._Release + RET + +{ Now we're into the less common cases. } +@@NilSource: + MOV ECX, [EAX] // get current value + TEST ECX, ECX // is it nil? + MOV [EAX], EDX // store in dest (which is nil) + JE @@Done + MOV EAX, [ECX] // get current vmt + PUSH ECX // current value as arg + CALL [EAX].vmtRelease.Pointer; +@@Done: +end; +{$ENDIF} + +procedure _IntfCast(var Dest: IInterface; const Source: IInterface; const IID: TGUID); +{$IFDEF PUREPASCAL} +// PIC: EBX must be correct before calling QueryInterface +begin + if Source = nil then + Dest := nil + else if Source.QueryInterface(IID, Temp) <> 0 then + Error(reIntfCastError); +end; +{$ELSE} +asm + PUSH EAX + PUSH ECX + PUSH EDX + MOV ECX,[EAX] + TEST ECX,ECX + JE @@1 + PUSH ECX + MOV EAX,[ECX] + CALL DWORD PTR [EAX] + VMTOFFSET IInterface._Release + MOV EDX,[ESP] +@@1: MOV EAX,[EDX] + CALL DWORD PTR [EAX] + VMTOFFSET IInterface.QueryInterface + TEST EAX,EAX + JE @@2 + MOV AL,reIntfCastError + JMP Error +@@2: +end; +{$ENDIF} + +procedure _IntfAddRef(const Dest: IInterface); +begin + if Dest <> nil then Dest._AddRef; +end; + +procedure TInterfacedObject.AfterConstruction; +begin +// Release the constructor's implicit refcount + InterlockedDecrement(FRefCount); +end; + +procedure TInterfacedObject.BeforeDestruction; +begin + if RefCount <> 0 then + Error(reInvalidPtr); +end; + +// Set an implicit refcount so that refcounting +// during construction won't destroy the object. +class function TInterfacedObject.NewInstance: TObject; +begin + Result := inherited NewInstance; + TInterfacedObject(Result).FRefCount := 1; +end; + +function TInterfacedObject.QueryInterface(const IID: TGUID; out Obj): HResult; +begin + if GetInterface(IID, Obj) then + Result := 0 + else + Result := E_NOINTERFACE; +end; + +function TInterfacedObject._AddRef: Integer; +begin + Result := InterlockedIncrement(FRefCount); +end; + +function TInterfacedObject._Release: Integer; +begin + Result := InterlockedDecrement(FRefCount); + if Result = 0 then + Destroy; +end; + +{ TAggregatedObject } + +constructor TAggregatedObject.Create(const Controller: IInterface); +begin + // weak reference to controller - don't keep it alive + FController := Pointer(Controller); +end; + +function TAggregatedObject.GetController: IInterface; +begin + Result := IInterface(FController); +end; + +function TAggregatedObject.QueryInterface(const IID: TGUID; out Obj): HResult; +begin + Result := IInterface(FController).QueryInterface(IID, Obj); +end; + +function TAggregatedObject._AddRef: Integer; +begin + Result := IInterface(FController)._AddRef; +end; + +function TAggregatedObject._Release: Integer; stdcall; +begin + Result := IInterface(FController)._Release; +end; + +{ TContainedObject } + +function TContainedObject.QueryInterface(const IID: TGUID; out Obj): HResult; +begin + if GetInterface(IID, Obj) then + Result := S_OK + else + Result := E_NOINTERFACE; +end; + +{ TClassHelperBase } + +constructor TClassHelperBase._Create(Instance: TObject); +begin + inherited Create; + FInstance := Instance; +end; + +function _CheckAutoResult(ResultCode: HResult): HResult; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + if ResultCode < 0 then + begin + if Assigned(SafeCallErrorProc) then + SafeCallErrorProc(ResultCode, Pointer(-1)); // loses error address + Error(reSafeCallError); + end; + Result := ResultCode; +end; +{$ELSE} +asm + TEST EAX,EAX + JNS @@2 + MOV ECX,SafeCallErrorProc + TEST ECX,ECX + JE @@1 + MOV EDX,[ESP] + CALL ECX +@@1: MOV AL,reSafeCallError + JMP Error +@@2: +end; +{$IFEND} + +function CompToDouble(Value: Comp): Double; cdecl; +begin + Result := Value; +end; + +procedure DoubleToComp(Value: Double; var Result: Comp); cdecl; +begin + Result := Value; +end; + +function CompToCurrency(Value: Comp): Currency; cdecl; +begin + Result := Value; +end; + +procedure CurrencyToComp(Value: Currency; var Result: Comp); cdecl; +begin + Result := Value; +end; + +function GetMemory(Size: Integer): Pointer; cdecl; +begin + Result := MemoryManager.GetMem(Size); +end; + +function FreeMemory(P: Pointer): Integer; cdecl; +begin + if P = nil then + Result := 0 + else + Result := MemoryManager.FreeMem(P); +end; + +function ReallocMemory(P: Pointer; Size: Integer): Pointer; cdecl; +begin + Result := MemoryManager.ReallocMem(P, Size); +end; + +procedure SetLineBreakStyle(var T: Text; Style: TTextLineBreakStyle); +begin + if TTextRec(T).Mode = fmClosed then + TTextRec(T).Flags := TTextRec(T).Flags or (tfCRLF * Byte(Style)) + else + SetInOutRes(107); // can't change mode of open file +end; + +// UnicodeToUTF8(3): +// Scans the source data to find the null terminator, up to MaxBytes +// Dest must have MaxBytes available in Dest. + +function UnicodeToUtf8(Dest: PChar; Source: PWideChar; MaxBytes: Integer): Integer; +var + len: Cardinal; +begin + len := 0; + if Source <> nil then + while Source[len] <> #0 do + Inc(len); + Result := UnicodeToUtf8(Dest, MaxBytes, Source, len); +end; + +// UnicodeToUtf8(4): +// MaxDestBytes includes the null terminator (last char in the buffer will be set to null) +// Function result includes the null terminator. +// Nulls in the source data are not considered terminators - SourceChars must be accurate + +function UnicodeToUtf8(Dest: PChar; MaxDestBytes: Cardinal; Source: PWideChar; SourceChars: Cardinal): Cardinal; +var + i, count: Cardinal; + c: Cardinal; +begin + Result := 0; + if Source = nil then Exit; + count := 0; + i := 0; + if Dest <> nil then + begin + while (i < SourceChars) and (count < MaxDestBytes) do + begin + c := Cardinal(Source[i]); + Inc(i); + if c <= $7F then + begin + Dest[count] := Char(c); + Inc(count); + end + else if c > $7FF then + begin + if count + 3 > MaxDestBytes then + break; + Dest[count] := Char($E0 or (c shr 12)); + Dest[count+1] := Char($80 or ((c shr 6) and $3F)); + Dest[count+2] := Char($80 or (c and $3F)); + Inc(count,3); + end + else // $7F < Source[i] <= $7FF + begin + if count + 2 > MaxDestBytes then + break; + Dest[count] := Char($C0 or (c shr 6)); + Dest[count+1] := Char($80 or (c and $3F)); + Inc(count,2); + end; + end; + if count >= MaxDestBytes then count := MaxDestBytes-1; + Dest[count] := #0; + end + else + begin + while i < SourceChars do + begin + c := Integer(Source[i]); + Inc(i); + if c > $7F then + begin + if c > $7FF then + Inc(count); + Inc(count); + end; + Inc(count); + end; + end; + Result := count+1; // convert zero based index to byte count +end; + +function Utf8ToUnicode(Dest: PWideChar; Source: PChar; MaxChars: Integer): Integer; +var + len: Cardinal; +begin + len := 0; + if Source <> nil then + while Source[len] <> #0 do + Inc(len); + Result := Utf8ToUnicode(Dest, MaxChars, Source, len); +end; + +function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: Cardinal; Source: PChar; SourceBytes: Cardinal): Cardinal; +var + i, count: Cardinal; + c: Byte; + wc: Cardinal; +begin + if Source = nil then + begin + Result := 0; + Exit; + end; + Result := Cardinal(-1); + count := 0; + i := 0; + if Dest <> nil then + begin + while (i < SourceBytes) and (count < MaxDestChars) do + begin + wc := Cardinal(Source[i]); + Inc(i); + if (wc and $80) <> 0 then + begin + wc := wc and $3F; + if i > SourceBytes then Exit; // incomplete multibyte char + if (wc and $20) <> 0 then + begin + c := Byte(Source[i]); + Inc(i); + if (c and $C0) <> $80 then Exit; // malformed trail byte or out of range char + if i > SourceBytes then Exit; // incomplete multibyte char + wc := (wc shl 6) or (c and $3F); + end; + c := Byte(Source[i]); + Inc(i); + if (c and $C0) <> $80 then Exit; // malformed trail byte + + Dest[count] := WideChar((wc shl 6) or (c and $3F)); + end + else + Dest[count] := WideChar(wc); + Inc(count); + end; + if count >= MaxDestChars then count := MaxDestChars-1; + Dest[count] := #0; + end + else + begin + while (i <= SourceBytes) do + begin + c := Byte(Source[i]); + Inc(i); + if (c and $80) <> 0 then + begin + if (c and $F0) = $F0 then Exit; // too many bytes for UCS2 + if (c and $40) = 0 then Exit; // malformed lead byte + if i > SourceBytes then Exit; // incomplete multibyte char + if (Byte(Source[i]) and $C0) <> $80 then Exit; // malformed trail byte + Inc(i); + if i > SourceBytes then Exit; // incomplete multibyte char + if ((c and $20) <> 0) and ((Byte(Source[i]) and $C0) <> $80) then Exit; // malformed trail byte + Inc(i); + + end; + Inc(count); + end; + end; + Result := count+1; +end; + +function Utf8Encode(const WS: WideString): UTF8String; +var + L: Integer; + Temp: UTF8String; +begin + Result := ''; + if WS = '' then Exit; + SetLength(Temp, Length(WS) * 3); // SetLength includes space for null terminator + + L := UnicodeToUtf8(PChar(Temp), Length(Temp)+1, PWideChar(WS), Length(WS)); + if L > 0 then + SetLength(Temp, L-1) + else + Temp := ''; + Result := Temp; +end; + +function Utf8Decode(const S: UTF8String): WideString; +var + L: Integer; + Temp: WideString; +begin + Result := ''; + if S = '' then Exit; + SetLength(Temp, Length(S)); + + L := Utf8ToUnicode(PWideChar(Temp), Length(Temp)+1, PChar(S), Length(S)); + if L > 0 then + SetLength(Temp, L-1) + else + Temp := ''; + Result := Temp; +end; + +function AnsiToUtf8(const S: string): UTF8String; +begin + Result := Utf8Encode(S); +end; + +function Utf8ToAnsi(const S: UTF8String): string; +begin + Result := Utf8Decode(S); +end; + +{$IFDEF LINUX} + +function GetCPUType: Integer; +asm + PUSH EBX + // this code assumes ESP is 4 byte aligned + // test for 80386: see if bit #18 of EFLAGS (Alignment fault) can be toggled + PUSHF + POP EAX + MOV ECX, EAX + XOR EAX, $40000 // flip AC bit in EFLAGS + PUSH EAX + POPF + PUSHF + POP EAX + XOR EAX, ECX // zero = 80386 CPU (can't toggle AC bit) + MOV EAX, CPUi386 + JZ @@Exit + PUSH ECX + POPF // restore original flags before next test + + // test for 80486: see if bit #21 of EFLAGS (CPUID supported) can be toggled + MOV EAX, ECX // get original EFLAGS + XOR EAX, $200000 // flip CPUID bit in EFLAGS + PUSH EAX + POPF + PUSHF + POP EAX + XOR EAX, ECX // zero = 80486 (can't toggle EFLAGS bit #21) + MOV EAX, CPUi486 + JZ @@Exit + + // Use CPUID instruction to get CPU family + XOR EAX, EAX + CPUID + CMP EAX, 1 + JL @@Exit // unknown processor response: report as 486 + XOR EAX, EAX + INC EAX // we only care about info level 1 + CPUID + AND EAX, $F00 + SHR EAX, 8 + // Test8086 values are one less than the CPU model number, for historical reasons + DEC EAX + +@@Exit: + POP EBX +end; + + +const + sResSymExport = '@Sysinit@ResSym'; + sResStrExport = '@Sysinit@ResStr'; + sResHashExport = '@Sysinit@ResHash'; + +type + TElf32Sym = record + Name: Cardinal; + Value: Pointer; + Size: Cardinal; + Info: Byte; + Other: Byte; + Section: Word; + end; + PElf32Sym = ^TElf32Sym; + + TElfSymTab = array [0..0] of TElf32Sym; + PElfSymTab = ^TElfSymTab; + + TElfWordTab = array [0..2] of Cardinal; + PElfWordTab = ^TElfWordTab; + + +{ If Name encodes a numeric identifier, return it, else return -1. } +function NameToId(Name: PChar): Longint; +var digit: Longint; +begin + if Longint(Name) and $ffff0000 = 0 then + begin + Result := Longint(Name) and $ffff; + end + else if Name^ = '#' then + begin + Result := 0; + inc (Name); + while (Ord(Name^) <> 0) do + begin + digit := Ord(Name^) - Ord('0'); + if (LongWord(digit) > 9) then + begin + Result := -1; + exit; + end; + Result := Result * 10 + digit; + inc (Name); + end; + end + else + Result := -1; +end; + + +// Return ELF hash value for NAME converted to lower case. +function ElfHashLowercase(Name: PChar): Cardinal; +var + g: Cardinal; + c: Char; +begin + Result := 0; + while name^ <> #0 do + begin + c := name^; + case c of + 'A'..'Z': Inc(c, Ord('a') - Ord('A')); + end; + Result := (Result shl 4) + Ord(c); + g := Result and $f0000000; + Result := (Result xor (g shr 24)) and not g; + Inc(name); + end; +end; + +type + PFindResourceCache = ^TFindResourceCache; + TFindResourceCache = record + ModuleHandle: HMODULE; + Version: Cardinal; + SymbolTable: PElfSymTab; + StringTable: PChar; + HashTable: PElfWordTab; + BaseAddress: Cardinal; + end; + +threadvar + FindResourceCache: TFindResourceCache; + +function GetResourceCache(ModuleHandle: HMODULE): PFindResourceCache; +var + info: TDLInfo; +begin + Result := @FindResourceCache; + if (ModuleHandle <> Result^.ModuleHandle) or (ModuleCacheVersion <> Result^.Version) then + begin + Result^.SymbolTable := dlsym(ModuleHandle, sResSymExport); + Result^.StringTable := dlsym(ModuleHandle, sResStrExport); + Result^.HashTable := dlsym(ModuleHandle, sResHashExport); + Result^.ModuleHandle := ModuleHandle; + if (dladdr(Result^.HashTable, Info) = 0) or (Info.BaseAddress = ExeBaseAddress) then + Result^.BaseAddress := 0 // if it's not in a library, assume the exe + else + Result^.BaseAddress := Cardinal(Info.BaseAddress); + Result^.Version := ModuleCacheVersion; + end; +end; + +function FindResource(ModuleHandle: HMODULE; ResourceName: PChar; ResourceType: PChar): TResourceHandle; +var + P: PFindResourceCache; + nid, tid: Longint; + ucs2_key: array [0..2] of WideChar; + key: array [0..127] of Char; + len: Integer; + pc: PChar; + ch: Char; + nbucket: Cardinal; + bucket, chain: PElfWordTab; + syndx: Cardinal; +begin + Result := 0; + if ResourceName = nil then Exit; + P := GetResourceCache(ModuleHandle); + + tid := NameToId (ResourceType); + if tid = -1 then Exit; { not supported (yet?) } + + { This code must match util-common/elfres.c } + nid := NameToId (ResourceName); + if nid = -1 then + begin + ucs2_key[0] := WideChar(2*tid+2); + ucs2_key[1] := WideChar(0); + len := UnicodeToUtf8 (key, ucs2_key, SizeOf (key)); + pc := key+len; + while Ord(ResourceName^) <> 0 do + begin + ch := ResourceName^; + if Ord(ch) > 127 then exit; { insist on 7bit ASCII for now } + if ('A' <= ch) and (ch <= 'Z') then Inc(ch, Ord('a') - Ord('A')); + pc^ := ch; + inc (pc); + if pc = key + SizeOf(key) then exit; + inc (ResourceName); + end; + pc^ := Char(0); + end + else + begin + ucs2_key[0] := WideChar(2*tid+1); + ucs2_key[1] := WideChar(nid); + ucs2_key[2] := WideChar(0); + UnicodeToUtf8 (key, ucs2_key, SizeOf (key)); + end; + + with P^ do + begin + nbucket := HashTable[0]; + // nsym := HashTable[1]; + bucket := @HashTable[2]; + chain := @HashTable[2+nbucket]; + + syndx := bucket[ElfHashLowercase(key) mod nbucket]; + while (syndx <> 0) + and (strcasecmp(key, @StringTable[SymbolTable[syndx].Name]) <> 0) do + syndx := chain[syndx]; + + if syndx = 0 then + Result := 0 + else + Result := TResourceHandle(@SymbolTable[syndx]); + end; +end; + +function LoadResource(ModuleHandle: HMODULE; ResHandle: TResourceHandle): HGLOBAL; +var + P: PFindResourceCache; +begin + if ResHandle <> 0 then + begin + P := GetResourceCache(ModuleHandle); + Result := HGLOBAL(PElf32Sym(ResHandle)^.Value); + Inc (Cardinal(Result), P^.BaseAddress); + end + else + Result := 0; +end; + +function SizeofResource(ModuleHandle: HMODULE; ResHandle: TResourceHandle): Integer; +begin + if ResHandle <> 0 then + Result := PElf32Sym(ResHandle)^.Size + else + Result := 0; +end; + +function LockResource(ResData: HGLOBAL): Pointer; +begin + Result := Pointer(ResData); +end; + +function UnlockResource(ResData: HGLOBAL): LongBool; +begin + Result := False; +end; + +function FreeResource(ResData: HGLOBAL): LongBool; +begin + Result := True; +end; +{$ENDIF} + +{ ResString support function } + +{$IFDEF MSWINDOWS} +function LoadResString(ResStringRec: PResStringRec): string; +var + Buffer: array [0..4095] of char; +begin + if ResStringRec = nil then Exit; + if ResStringRec.Identifier < 64*1024 then + SetString(Result, Buffer, + LoadString(FindResourceHInstance(ResStringRec.Module^), + ResStringRec.Identifier, Buffer, SizeOf(Buffer))) + else + Result := PChar(ResStringRec.Identifier); +end; +{$ENDIF} +{$IFDEF LINUX} + +const + ResStringTableLen = 16; + +type + ResStringTable = array [0..ResStringTableLen-1] of LongWord; + +//function _printf(Format: PChar): Integer; cdecl; varargs; +//external libc name 'printf'; + +function LoadResString(ResStringRec: PResStringRec): string; +var + Handle: TResourceHandle; + Tab: ^ResStringTable; + ResMod: HMODULE; +begin + if ResStringRec = nil then Exit; + ResMod := FindResourceHInstance(ResStringRec^.Module^); + Handle := FindResource(ResMod, + PChar(ResStringRec^.Identifier div ResStringTableLen), + PChar(6)); // RT_STRING + Tab := Pointer(LoadResource(ResMod, Handle)); + if Tab = nil then + Result := '' + else + begin + Result := PChar (Tab) + Tab[ResStringRec^.Identifier mod ResStringTableLen]; + end; +end; + +procedure DbgUnlockX; +begin + if Assigned(DbgUnlockXProc) then + DbgUnlockXProc; +end; + +{ The Win32 program loader sets up the first 64k of process address space + with no read or write access, to help detect use of invalid pointers + (whose integer value is 0..64k). Linux doesn't do this. + + Parts of the Delphi RTL and IDE design environment + rely on the notion that pointer values in the [0..64k] range are + invalid pointers. To accomodate this in Linux, we reserve the range + at startup. If the range is already allocated, we keep going anyway. } + +var + ZeroPageReserved: Boolean = False; + +procedure ReserveZeroPage; +const + PROT_NONE = 0; + MAP_PRIVATE = $02; + MAP_FIXED = $10; + MAP_ANONYMOUS = $20; +var + P: Pointer; +begin + if IsLibrary then Exit; // page reserve is app's job, not .so's + + if not ZeroPageReserved then + begin + P := mmap(nil, High(Word), PROT_NONE, + MAP_ANONYMOUS or MAP_PRIVATE or MAP_FIXED, 0, 0); + ZeroPageReserved := P = nil; + if (Integer(P) <> -1) and (P <> nil) then // we didn't get it + munmap(P, High(Word)); + end; +end; + +procedure ReleaseZeroPage; +begin + if ZeroPageReserved then + begin + munmap(nil, High(Word) - 4096); + ZeroPageReserved := False; + end; +end; +{$ENDIF} + +var + xxNull: UCS4Char = 0; + xxPNull: PUCS4Char = @xxNull; +function PUCS4Chars(const S: UCS4String): PUCS4Char; +begin + if Length(S) > 0 then + Result := @S[0] + else + Result := xxPNull; +end; + +function WideStringToUCS4String(const S: WideString): UCS4String; +var + I: Integer; +begin + SetLength(Result, Length(S) + 1); + for I := 0 to Length(S) - 1 do + Result[I] := UCS4Char(S[I + 1]); + Result[Length(S)] := 0; +end; + +function UCS4StringToWidestring(const S: UCS4String): WideString; +var + I: Integer; +begin + SetLength(Result, Length(S)); + for I := 0 to Length(S)-1 do + Result[I+1] := WideChar(S[I]); + Result[Length(S)] := #0; +end; + +var SaveCmdShow : Integer = -1; +function CmdShow: Integer; +var + SI: TStartupInfo; +begin + if SaveCmdShow < 0 then + begin + SaveCmdShow := 10; { SW_SHOWDEFAULT } + GetStartupInfo(SI); + if SI.dwFlags and 1 <> 0 then { STARTF_USESHOWWINDOW } + SaveCmdShow := SI.wShowWindow; + end; + Result := SaveCmdShow; +end; + +{X} // convert var CmdLine : PChar to a function: +{X} function CmdLine : PChar; +{X} begin +{X} Result := GetCommandLine; +{X} end; + +initialization + {$IFDEF MSWINDOWS} + {$IFDEF USE_PROCESS_HEAP} + HeapHandle := GetProcessHeap; + {$ELSE} + HeapHandle := HeapCreate( 0, 0, 0 ); + {$ENDIF} + {$ENDIF} + + {$IFDEF MSWINDOWS} + //{X (initialized statically} FileMode := 2; + {$ELSE} + FileMode := 2; + {$ENDIF} + +{$IFDEF LINUX} + FileAccessRights := S_IRUSR or S_IWUSR or S_IRGRP or S_IWGRP or S_IROTH or S_IWOTH; + Test8086 := GetCPUType; + IsConsole := True; + FindResourceCache.ModuleHandle := LongWord(-1); + ReserveZeroPage; +{$ELSE} + Test8086 := 2; +{$ENDIF} + + DispCallByIDProc := @_DispCallByIDError; + +{$IFDEF MSWINDOWS} + if _isNECWindows then _FpuMaskInit; +{$ENDIF} + _FpuInit(); + + TTextRec(Input).Mode := fmClosed; + TTextRec(Output).Mode := fmClosed; + TTextRec(ErrOutput).Mode := fmClosed; + InitVariantManager; + +{$IFDEF MSWINDOWS} +{X- CmdLine := GetCommandLine; converted to a function } +{X- CmdShow := GetCmdShow; converted to a function } +{$ENDIF} + MainThreadID := GetCurrentThreadID; +{$IFDEF LINUX} + // Ensure DbgUnlockX is linked in, calling it now does nothing + DbgUnlockX; +{$ENDIF} + +finalization + {X+} + {X} CloseInputOutput; + {X- + Close(Input); + Close(Output); + Close(ErrOutput); + X+} +{$IFDEF LINUX} + ReleaseZeroPage; +{$ENDIF} +{$IFDEF MSWINDOWS} +{X UninitAllocator; - replaced with call to UninitMemoryManager handler. } + UninitMemoryManager; +{$ENDIF} +end. \ No newline at end of file diff --git a/System/D2005/getmem.inc b/System/D2005/getmem.inc new file mode 100644 index 0000000..1043274 --- /dev/null +++ b/System/D2005/getmem.inc @@ -0,0 +1,1535 @@ +{ *********************************************************************** } +{ } +{ Delphi Runtime Library } +{ } +{ Copyright (c) 1996,2001 Borland Software Corporation } +{ } +{ *********************************************************************** } + +// Three layers: +// - Address space administration +// - Committed space administration +// - Suballocator +// +// Helper module: administrating block descriptors +// + + +// +// Operating system interface +// +const + LMEM_FIXED = 0; + LMEM_ZEROINIT = $40; + + MEM_COMMIT = $1000; + MEM_RESERVE = $2000; + MEM_DECOMMIT = $4000; + MEM_RELEASE = $8000; + + PAGE_NOACCESS = 1; + PAGE_READWRITE = 4; + +type + DWORD = Integer; + BOOL = LongBool; + + TRTLCriticalSection = packed record + DebugInfo: Pointer; + LockCount: Longint; + RecursionCount: Longint; + OwningThread: Integer; + LockSemaphore: Integer; + Reserved: DWORD; + end; + +{function LocalAlloc(flags, size: Integer): Pointer; stdcall; + external kernel name 'LocalAlloc'; +function LocalFree(addr: Pointer): Pointer; stdcall; + external kernel name 'LocalFree';} + +function VirtualAlloc(lpAddress: Pointer; + dwSize, flAllocationType, flProtect: DWORD): Pointer; stdcall; + external kernel name 'VirtualAlloc'; +function VirtualFree(lpAddress: Pointer; dwSize, dwFreeType: DWORD): BOOL; stdcall; + external kernel name 'VirtualFree'; + +procedure InitializeCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall; + external kernel name 'InitializeCriticalSection'; +procedure EnterCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall; + external kernel name 'EnterCriticalSection'; +procedure LeaveCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall; + external kernel name 'LeaveCriticalSection'; +procedure DeleteCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall; + external kernel name 'DeleteCriticalSection'; + +// Common Data structure: + +type + TBlock = packed record + addr: PChar; + size: Integer; + end; + +// Heap error codes + +const + cHeapOk = 0; // everything's fine + cReleaseErr = 1; // operating system returned an error when we released + cDecommitErr = 2; // operating system returned an error when we decommited + cBadCommittedList = 3; // list of committed blocks looks bad + cBadFiller1 = 4; // filler block is bad + cBadFiller2 = 5; // filler block is bad + cBadFiller3 = 6; // filler block is bad + cBadCurAlloc = 7; // current allocation zone is bad + cCantInit = 8; // couldn't initialize + cBadUsedBlock = 9; // used block looks bad + cBadPrevBlock = 10; // prev block before a used block is bad + cBadNextBlock = 11; // next block after a used block is bad + cBadFreeList = 12; // free list is bad + cBadFreeBlock = 13; // free block is bad + cBadBalance = 14; // free list doesn't correspond to blocks marked free + +var + initialized : Boolean; + heapErrorCode : Integer; + heapLock : TRTLCriticalSection; + UninitMemoryManager : procedure = DummyProc; +// +// Helper module: administrating block descriptors. +// +type + PBlockDesc = ^TBlockDesc; + TBlockDesc = packed record + next: PBlockDesc; + prev: PBlockDesc; + addr: PChar; + size: Integer; + end; + +type + PBlockDescBlock = ^TBlockDescBlock; + TBlockDescBlock = packed record + next: PBlockDescBlock; + data: array [0..99] of TBlockDesc; + end; + +var + blockDescBlockList: PBlockDescBlock; + blockDescFreeList : PBlockDesc; + + +function GetBlockDesc: PBlockDesc; +// Get a block descriptor. +// Will return nil for failure. +var + bd: PBlockDesc; + bdb: PBlockDescBlock; + i: Integer; +begin + if blockDescFreeList = nil then begin + bdb := LocalAlloc(LMEM_FIXED, sizeof(bdb^)); + if bdb = nil then begin + result := nil; + exit; + end; + bdb.next := blockDescBlockList; + blockDescBlockList := bdb; + for i := low(bdb.data) to high(bdb.data) do begin + bd := @bdb.data[i]; + bd.next := blockDescFreeList; + blockDescFreeList := bd; + end; + end; + bd := blockDescFreeList; + blockDescFreeList := bd.next; + result := bd; +end; + + +procedure MakeEmpty(bd: PBlockDesc); +begin + bd.next := bd; + bd.prev := bd; +end; + + +function AddBlockAfter(prev: PBlockDesc; const b: TBlock): Boolean; +var + next, bd: PBlockDesc; +begin + bd := GetBlockDesc; + if bd = nil then + result := False + else begin + bd.addr := b.addr; + bd.size := b.size; + + next := prev.next; + bd.next := next; + bd.prev := prev; + next.prev := bd; + prev.next := bd; + + result := True; + end; +end; + + +procedure DeleteBlock(bd: PBlockDesc); +var + prev, next: PBlockDesc; +begin + prev := bd.prev; + next := bd.next; + prev.next := next; + next.prev := prev; + bd.next := blockDescFreeList; + blockDescFreeList := bd; +end; + + +function MergeBlockAfter(prev: PBlockDesc; const b: TBlock) : TBlock; +var + bd, bdNext: PBlockDesc; +begin + bd := prev.next; + result := b; + repeat + bdNext := bd.next; + if bd.addr + bd.size = result.addr then begin + DeleteBlock(bd); + result.addr := bd.addr; + inc(result.size, bd.size); + end else if result.addr + result.size = bd.addr then begin + DeleteBlock(bd); + inc(result.size, bd.size); + end; + bd := bdNext; + until bd = prev; + if not AddBlockAfter(prev, result) then + result.addr := nil; +end; + + +function RemoveBlock(bd: PBlockDesc; const b: TBlock): Boolean; +var + n: TBlock; + start: PBlockDesc; +begin + start := bd; + repeat + if (bd.addr <= b.addr) and (bd.addr + bd.size >= b.addr + b.size) then begin + if bd.addr = b.addr then begin + Inc(bd.addr, b.size); + Dec(bd.size, b.size); + if bd.size = 0 then + DeleteBlock(bd); + end else if bd.addr + bd.size = b.addr + b.size then + Dec(bd.size, b.size) + else begin + n.addr := b.addr + b.size; + n.size := bd.addr + bd.size - n.addr; + bd.size := b.addr - bd.addr; + if not AddBlockAfter(bd, n) then begin + result := False; + exit; + end; + end; + result := True; + exit; + end; + bd := bd.next; + until bd = start; + result := False; +end; + + + +// +// Address space administration: +// + +const + cSpaceAlign = 64*1024; + cSpaceMin = 1024*1024; + cPageAlign = 4*1024; + +var + spaceRoot: TBlockDesc; + + +function GetSpace(minSize: Integer): TBlock; +// Get at least minSize bytes address space. +// Success: returns a block, possibly much bigger than requested. +// Will not fail - will raise an exception or terminate program. +begin + if minSize < cSpaceMin then + minSize := cSpaceMin + else + minSize := (minSize + (cSpaceAlign-1)) and not (cSpaceAlign-1); + + result.size := minSize; + result.addr := VirtualAlloc(nil, minSize, MEM_RESERVE, PAGE_NOACCESS); + if result.addr = nil then + exit; + + if not AddBlockAfter(@spaceRoot, result) then begin + VirtualFree(result.addr, 0, MEM_RELEASE); + result.addr := nil; + exit; + end; +end; + + +function GetSpaceAt(addr: PChar; minSize: Integer): TBlock; +// Get at least minSize bytes address space at addr. +// Return values as above. +// Failure: returns block with addr = nil. +begin + result.size := cSpaceMin; + result.addr := VirtualAlloc(addr, cSpaceMin, MEM_RESERVE, PAGE_READWRITE); + if result.addr = nil then begin + minSize := (minSize + (cSpaceAlign-1)) and not (cSpaceAlign-1); + result.size := minSize; + result.addr := VirtualAlloc(addr, minSize, MEM_RESERVE, PAGE_READWRITE); + end; + if result.addr <> nil then begin + if not AddBlockAfter(@spaceRoot, result) then begin + VirtualFree(result.addr, 0, MEM_RELEASE); + result.addr := nil; + end; + end; +end; + + +function FreeSpace(addr: Pointer; maxSize: Integer): TBlock; +// Free at most maxSize bytes of address space at addr. +// Returns the block that was actually freed. +var + bd, bdNext: PBlockDesc; + minAddr, maxAddr, startAddr, endAddr: PChar; +begin + minAddr := PChar($FFFFFFFF); + maxAddr := nil; + startAddr := addr; + endAddr := startAddr + maxSize; + bd := spaceRoot.next; + while bd <> @spaceRoot do begin + bdNext := bd.next; + if (bd.addr >= startAddr) and (bd.addr + bd.size <= endAddr) then begin + if minAddr > bd.addr then + minAddr := bd.addr; + if maxAddr < bd.addr + bd.size then + maxAddr := bd.addr + bd.size; + if not VirtualFree(bd.addr, 0, MEM_RELEASE) then + heapErrorCode := cReleaseErr; + DeleteBlock(bd); + end; + bd := bdNext; + end; + result.addr := nil; + if maxAddr <> nil then begin + result.addr := minAddr; + result.size := maxAddr - minAddr; + end; +end; + + +function Commit(addr: Pointer; minSize: Integer): TBlock; +// Commits memory. +// Returns the block that was actually committed. +// Will return a block with addr = nil on failure. +var + bd: PBlockDesc; + loAddr, hiAddr, startAddr, endAddr: PChar; +begin + startAddr := PChar(Integer(addr) and not (cPageAlign-1)); + endAddr := PChar(((Integer(addr) + minSize) + (cPageAlign-1)) and not (cPageAlign-1)); + result.addr := startAddr; + result.size := endAddr - startAddr; + bd := spaceRoot.next; + while bd <> @spaceRoot do begin + // Commit the intersection of the block described by bd and [startAddr..endAddr) + loAddr := bd.addr; + hiAddr := loAddr + bd.size; + if loAddr < startAddr then + loAddr := startAddr; + if hiAddr > endAddr then + hiAddr := endAddr; + if loAddr < hiAddr then begin + if VirtualAlloc(loAddr, hiAddr - loAddr, MEM_COMMIT, PAGE_READWRITE) = nil then begin + result.addr := nil; + exit; + end; + end; + bd := bd.next; + end; +end; + + +function Decommit(addr: Pointer; maxSize: Integer): TBlock; +// Decommits address space. +// Returns the block that was actually decommitted. +var + bd: PBlockDesc; + loAddr, hiAddr, startAddr, endAddr: PChar; +begin + startAddr := PChar((Integer(addr) + + (cPageAlign-1)) and not (cPageAlign-1)); + endAddr := PChar((Integer(addr) + maxSize) and not (cPageAlign-1)); + result.addr := startAddr; + result.size := endAddr - startAddr; + bd := spaceRoot.next; + while bd <> @spaceRoot do begin + // Decommit the intersection of the block described by bd and [startAddr..endAddr) + loAddr := bd.addr; + hiAddr := loAddr + bd.size; + if loAddr < startAddr then + loAddr := startAddr; + if hiAddr > endAddr then + hiAddr := endAddr; + if loAddr < hiAddr then begin + if not VirtualFree(loAddr, hiAddr - loAddr, MEM_DECOMMIT) then + heapErrorCode := cDecommitErr; + end; + bd := bd.next; + end; +end; + + +// +// Committed space administration +// +const + cCommitAlign = 16*1024; + +var + decommittedRoot: TBlockDesc; + + +function GetCommitted(minSize: Integer): TBlock; +// Get a block of committed memory. +// Returns a committed memory block, possibly much bigger than requested. +// Will return a block with a nil addr on failure. +var + bd: PBlockDesc; +begin + minSize := (minSize + (cCommitAlign-1)) and not (cCommitAlign-1); + repeat + bd := decommittedRoot.next; + while bd <> @decommittedRoot do begin + if bd.size >= minSize then begin + result := Commit(bd.addr, minSize); + if result.addr = nil then + exit; + Inc(bd.addr, result.size); + Dec(bd.size, result.size); + if bd.size = 0 then + DeleteBlock(bd); + exit; + end; + bd := bd.next; + end; + result := GetSpace(minSize); + if result.addr = nil then + exit; + if MergeBlockAfter(@decommittedRoot, result).addr = nil then begin + FreeSpace(result.addr, result.size); + result.addr := nil; + exit; + end; + until False; +end; + + +function GetCommittedAt(addr: PChar; minSize: Integer): TBlock; +// Get at least minSize bytes committed space at addr. +// Success: returns a block, possibly much bigger than requested. +// Failure: returns a block with addr = nil. +var + bd: PBlockDesc; + b: TBlock; +begin + minSize := (minSize + (cCommitAlign-1)) and not (cCommitAlign-1); + repeat + + bd := decommittedRoot.next; + while (bd <> @decommittedRoot) and (bd.addr <> addr) do + bd := bd.next; + + if bd.addr = addr then begin + if bd.size >= minSize then + break; + b := GetSpaceAt(bd.addr + bd.size, minSize - bd.size); + if b.addr <> nil then begin + if MergeBlockAfter(@decommittedRoot, b).addr <> nil then + continue + else begin + FreeSpace(b.addr, b.size); + result.addr := nil; + exit; + end; + end; + end; + + b := GetSpaceAt(addr, minSize); + if b.addr = nil then + break; + + if MergeBlockAfter(@decommittedRoot, b).addr = nil then begin + FreeSpace(b.addr, b.size); + result.addr := nil; + exit; + end; + until false; + + if (bd.addr = addr) and (bd.size >= minSize) then begin + result := Commit(bd.addr, minSize); + if result.addr = nil then + exit; + Inc(bd.addr, result.size); + Dec(bd.size, result.size); + if bd.size = 0 then + DeleteBlock(bd); + end else + result.addr := nil; +end; + + +function FreeCommitted(addr: PChar; maxSize: Integer): TBlock; +// Free at most maxSize bytes of address space at addr. +// Returns the block that was actually freed. +var + startAddr, endAddr: PChar; + b: TBlock; +begin + startAddr := PChar(Integer(addr + (cCommitAlign-1)) and not (cCommitAlign-1)); + endAddr := PChar(Integer(addr + maxSize) and not (cCommitAlign-1)); + if endAddr > startAddr then begin + result := Decommit(startAddr, endAddr - startAddr); + b := MergeBlockAfter(@decommittedRoot, result); + if b.addr <> nil then + b := FreeSpace(b.addr, b.size); + if b.addr <> nil then + RemoveBlock(@decommittedRoot, b); + end else + result.addr := nil; +end; + + +// +// Suballocator (what the user program actually calls) +// + +type + PFree = ^TFree; + TFree = packed record + prev: PFree; + next: PFree; + size: Integer; + end; + PUsed = ^TUsed; + TUsed = packed record + sizeFlags: Integer; + end; + +const + cAlign = 4; + cThisUsedFlag = 2; + cPrevFreeFlag = 1; + cFillerFlag = Integer($80000000); + cFlags = cThisUsedFlag or cPrevFreeFlag or cFillerFlag; + cSmallSize = 4*1024; + cDecommitMin = 15*1024; + +type + TSmallTab = array [sizeof(TFree) div cAlign .. cSmallSize div cAlign] of PFree; + +VAR + avail : TFree; + rover : PFree; + remBytes : Integer; + curAlloc : PChar; + smallTab : ^TSmallTab; + committedRoot: TBlockDesc; + +procedure UninitAllocator; +// Shutdown. +var + bdb: PBlockDescBlock; + bd : PBlockDesc; +begin + if initialized then begin + try + if IsMultiThread then EnterCriticalSection(heapLock); + + initialized := False; + + LocalFree(smallTab); + smallTab := nil; + + bd := spaceRoot.next; + while bd <> @spaceRoot do begin + VirtualFree(bd.addr, 0, MEM_RELEASE); + bd := bd.next; + end; + + MakeEmpty(@spaceRoot); + MakeEmpty(@decommittedRoot); + MakeEmpty(@committedRoot); + + bdb := blockDescBlockList; + while bdb <> nil do begin + blockDescBlockList := bdb^.next; + LocalFree(bdb); + bdb := blockDescBlockList; + end; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + DeleteCriticalSection(heapLock); + end; + end; +end; + +function InitAllocator: Boolean; +// Initialize. No other calls legal before that. +var + i: Integer; + a: PFree; +begin + try + InitializeCriticalSection(heapLock); + if IsMultiThread then EnterCriticalSection(heapLock); + + MakeEmpty(@spaceRoot); + MakeEmpty(@decommittedRoot); + MakeEmpty(@committedRoot); + + smallTab := LocalAlloc(LMEM_FIXED, sizeof(smallTab^)); + if smallTab <> nil then begin + for i:= low(smallTab^) to high(smallTab^) do + smallTab[i] := nil; + + a := @avail; + a.next := a; + a.prev := a; + rover := a; + + initialized := True; + UninitMemoryManager := UninitAllocator; + end; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; + result := initialized; +end; + +procedure DeleteFree(f: PFree); +var + n, p: PFree; + size: Integer; +begin + if rover = f then + rover := f.next; + n := f.next; + size := f.size; + if size <= cSmallSize then begin + if n = f then + smallTab[size div cAlign] := nil + else begin + smallTab[size div cAlign] := n; + p := f.prev; + n.prev := p; + p.next := n; + end; + end else begin + p := f.prev; + n.prev := p; + p.next := n; + end; +end; + + +procedure InsertFree(a: Pointer; size: Integer); forward; + + +function FindCommitted(addr: PChar): PBlockDesc; +begin + result := committedRoot.next; + while result <> @committedRoot do begin + if (addr >= result.addr) and (addr < result.addr + result.size) then + exit; + result := result.next; + end; + heapErrorCode := cBadCommittedList; + result := nil; +end; + + +procedure FillBeforeGap(a: PChar; size: Integer); +var + rest: Integer; + e: PUsed; +begin + rest := size - sizeof(TUsed); + e := PUsed(a + rest); + if size >= sizeof(TFree) + sizeof(TUsed) then begin + e.sizeFlags := sizeof(TUsed) or cThisUsedFlag or cPrevFreeFlag or cFillerFlag; + InsertFree(a, rest); + end else if size >= sizeof(TUsed) then begin + PUsed(a).sizeFlags := size or (cThisUsedFlag or cFillerFlag); + e.sizeFlags := size or (cThisUsedFlag or cFillerFlag); + end; +end; + + +procedure InternalFreeMem(a: PChar); +begin + Inc(AllocMemCount); + Inc(AllocMemSize,PUsed(a-sizeof(TUsed)).sizeFlags and not cFlags - sizeof(TUsed)); + SysFreeMem(a); +end; + + +procedure FillAfterGap(a: PChar; size: Integer); +begin + if size >= sizeof(TFree) then begin + PUsed(a).sizeFlags := size or cThisUsedFlag; + InternalFreeMem(a + sizeof(TUsed)); + end else begin + if size >= sizeof(TUsed) then + PUsed(a).sizeFlags := size or (cThisUsedFlag or cFillerFlag); + Inc(a,size); + PUsed(a).sizeFlags := PUsed(a).sizeFlags and not cPrevFreeFlag; + end; +end; + + +function FillerSizeBeforeGap(a: PChar): Integer; +var + sizeFlags : Integer; + freeSize : Integer; + f : PFree; +begin + sizeFlags := PUsed(a - sizeof(TUsed)).sizeFlags; + if (sizeFlags and (cThisUsedFlag or cFillerFlag)) <> (cThisUsedFlag or cFillerFlag) then + heapErrorCode := cBadFiller1; + result := sizeFlags and not cFlags; + Dec(a, result); + if ((PUsed(a).sizeFlags xor sizeFlags) and not cPrevFreeFlag) <> 0 then + HeapErrorCode := cBadFiller2; + if (PUsed(a).sizeFlags and cPrevFreeFlag) <> 0 then begin + freeSize := PFree(a - sizeof(TFree)).size; + f := PFree(a - freeSize); + if f.size <> freeSize then + heapErrorCode := cBadFiller3; + DeleteFree(f); + Inc(result, freeSize); + end; +end; + + +function FillerSizeAfterGap(a: PChar): Integer; +var + sizeFlags: Integer; + f : PFree; +begin + result := 0; + sizeFlags := PUsed(a).sizeFlags; + if (sizeFlags and cFillerFlag) <> 0 then begin + sizeFlags := sizeFlags and not cFlags; + Inc(result,sizeFlags); + Inc(a, sizeFlags); + sizeFlags := PUsed(a).sizeFlags; + end; + if (sizeFlags and cThisUsedFlag) = 0 then begin + f := PFree(a); + DeleteFree(f); + Inc(result, f.size); + Inc(a, f.size); + PUsed(a).sizeFlags := PUsed(a).sizeFlags and not cPrevFreeFlag; + end; +end; + + +function DecommitFree(a: PChar; size: Integer): Boolean; +var + b: TBlock; + bd: PBlockDesc; +begin + Result := False; + bd := FindCommitted(a); + if bd = nil then Exit; + if bd.addr + bd.size - (a + size) <= sizeof(TFree) then + size := bd.addr + bd.size - a; + + if a - bd.addr < sizeof(TFree) then + b := FreeCommitted(bd.addr, size + (a - bd.addr)) + else + b := FreeCommitted(a + sizeof(TUsed), size - sizeof(TUsed)); + + if b.addr <> nil then + begin + FillBeforeGap(a, b.addr - a); + if bd.addr + bd.size > b.addr + b.size then + FillAfterGap(b.addr + b.size, a + size - (b.addr + b.size)); + RemoveBlock(bd,b); + result := True; + end; +end; + + +procedure InsertFree(a: Pointer; size: Integer); +var + f, n, p: PFree; +begin + f := PFree(a); + f.size := size; + PFree(PChar(f) + size - sizeof(TFree)).size := size; + if size <= cSmallSize then begin + n := smallTab[size div cAlign]; + if n = nil then begin + smallTab[size div cAlign] := f; + f.next := f; + f.prev := f; + end else begin + p := n.prev; + f.next := n; + f.prev := p; + n.prev := f; + p.next := f; + end; + end else if (size < cDecommitMin) or not DecommitFree(a, size) then begin + n := rover; + rover := f; + p := n.prev; + f.next := n; + f.prev := p; + n.prev := f; + p.next := f; + end; +end; + + +procedure FreeCurAlloc; +begin + if remBytes > 0 then begin + if remBytes < sizeof(TFree) then + heapErrorCode := cBadCurAlloc + else begin + PUsed(curAlloc).sizeFlags := remBytes or cThisUsedFlag; + InternalFreeMem(curAlloc + sizeof(TUsed)); + curAlloc := nil; + remBytes := 0; + end; + end; +end; + + +function MergeCommit(b: TBlock): Boolean; +var + merged: TBlock; + fSize: Integer; +begin + FreeCurAlloc; + merged := MergeBlockAfter(@committedRoot, b); + if merged.addr = nil then begin + result := False; + exit; + end; + + if merged.addr < b.addr then begin + fSize := FillerSizeBeforeGap(b.addr); + Dec(b.addr, fSize); + Inc(b.size, fSize); + end; + + if merged.addr + merged.size > b.addr + b.size then begin + fSize := FillerSizeAfterGap(b.addr + b.size); + Inc(b.size, fSize); + end; + + if merged.addr + merged.size = b.addr + b.size then begin + FillBeforeGap(b.addr + b.size - sizeof(TUsed), sizeof(TUsed)); + Dec(b.size, sizeof(TUsed)); + end; + + curAlloc := b.addr; + remBytes := b.size; + + result := True; +end; + + +function NewCommit(minSize: Integer): Boolean; +var + b: TBlock; +begin + b := GetCommitted(minSize+sizeof(TUsed)); + result := (b.addr <> nil) and MergeCommit(b); +end; + + +function NewCommitAt(addr: Pointer; minSize: Integer): Boolean; +var + b: TBlock; +begin + b := GetCommittedAt(addr, minSize+sizeof(TUsed)); + result := (b.addr <> nil) and MergeCommit(b); +end; + + +function SearchSmallBlocks(size: Integer): PFree; +var + i: Integer; +begin + result := nil; + for i := size div cAlign to High(smallTab^) do begin + result := smallTab[i]; + if result <> nil then + exit; + end; +end; + + +function TryHarder(size: Integer): Pointer; +var + u: PUsed; f:PFree; saveSize, rest: Integer; +begin + + repeat + + f := avail.next; + if (size <= f.size) then + break; + + f := rover; + if f.size >= size then + break; + + saveSize := f.size; + f.size := size; + repeat + f := f.next + until f.size >= size; + rover.size := saveSize; + if f <> rover then begin + rover := f; + break; + end; + + if size <= cSmallSize then begin + f := SearchSmallBlocks(size); + if f <> nil then + break; + end; + + if not NewCommit(size) then begin + result := nil; + exit; + end; + + if remBytes >= size then begin + Dec(remBytes, size); + if remBytes < sizeof(TFree) then begin + Inc(size, remBytes); + remBytes := 0; + end; + u := PUsed(curAlloc); + Inc(curAlloc, size); + u.sizeFlags := size or cThisUsedFlag; + result := PChar(u) + sizeof(TUsed); + Inc(AllocMemCount); + Inc(AllocMemSize,size - sizeof(TUsed)); + exit; + end; + + until False; + + DeleteFree(f); + + rest := f.size - size; + if rest >= sizeof(TFree) then begin + InsertFree(PChar(f) + size, rest); + end else begin + size := f.size; + if f = rover then + rover := f.next; + u := PUsed(PChar(f) + size); + u.sizeFlags := u.sizeFlags and not cPrevFreeFlag; + end; + + u := PUsed(f); + u.sizeFlags := size or cThisUsedFlag; + + result := PChar(u) + sizeof(TUsed); + Inc(AllocMemCount); + Inc(AllocMemSize,size - sizeof(TUsed)); + +end; + + +function SysGetMem(size: Integer): Pointer; +// Allocate memory block. +var + f, prev, next: PFree; + u: PUsed; +begin + + if (not initialized and not InitAllocator) or + (size > (High(size) - (sizeof(TUsed) + (cAlign-1)))) then + begin + result := nil; + exit; + end; + + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + Inc(size, sizeof(TUsed) + (cAlign-1)); + size := size and not (cAlign-1); + if size < sizeof(TFree) then + size := sizeof(TFree); + + if size <= cSmallSize then begin + f := smallTab[size div cAlign]; + if f <> nil then begin + u := PUsed(PChar(f) + size); + u.sizeFlags := u.sizeFlags and not cPrevFreeFlag; + next := f.next; + if next = f then + smallTab[size div cAlign] := nil + else begin + smallTab[size div cAlign] := next; + prev := f.prev; + prev.next := next; + next.prev := prev; + end; + u := PUsed(f); + u.sizeFlags := f.size or cThisUsedFlag; + result := PChar(u) + sizeof(TUsed); + Inc(AllocMemCount); + Inc(AllocMemSize,size - sizeof(TUsed)); + exit; + end; + end; + + if size <= remBytes then begin + Dec(remBytes, size); + if remBytes < sizeof(TFree) then begin + Inc(size, remBytes); + remBytes := 0; + end; + u := PUsed(curAlloc); + Inc(curAlloc, size); + u.sizeFlags := size or cThisUsedFlag; + result := PChar(u) + sizeof(TUsed); + Inc(AllocMemCount); + Inc(AllocMemSize,size - sizeof(TUsed)); + exit; + end; + + result := TryHarder(size); + + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; + +end; + + +function SysFreeMem(p: Pointer): Integer; +// Deallocate memory block. +label + abort; +var + u, n : PUsed; + f : PFree; + prevSize, nextSize, size : Integer; +begin + heapErrorCode := cHeapOk; + + if not initialized and not InitAllocator then begin + heapErrorCode := cCantInit; + result := cCantInit; + exit; + end; + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + u := p; + u := PUsed(PChar(u) - sizeof(TUsed)); { inv: u = address of allocated block being freed } + size := u.sizeFlags; + { inv: size = SET(block size) + [block flags] } + + { validate that the interpretation of this block as a used block is correct } + if (size and cThisUsedFlag) = 0 then begin + heapErrorCode := cBadUsedBlock; + goto abort; + end; + + { inv: the memory block addressed by 'u' and 'p' is an allocated block } + + Dec(AllocMemCount); + Dec(AllocMemSize,size and not cFlags - sizeof(TUsed)); + + if (size and cPrevFreeFlag) <> 0 then begin + { previous block is free, coalesce } + prevSize := PFree(PChar(u)-sizeof(TFree)).size; + if (prevSize < sizeof(TFree)) or ((prevSize and cFlags) <> 0) then begin + heapErrorCode := cBadPrevBlock; + goto abort; + end; + + f := PFree(PChar(u) - prevSize); + if f^.size <> prevSize then begin + heapErrorCode := cBadPrevBlock; + goto abort; + end; + + inc(size, prevSize); + u := PUsed(f); + DeleteFree(f); + end; + + size := size and not cFlags; + { inv: size = block size } + + n := PUsed(PChar(u) + size); + { inv: n = block following the block to free } + + if PChar(n) = curAlloc then begin + { inv: u = last block allocated } + dec(curAlloc, size); + inc(remBytes, size); + if remBytes > cDecommitMin then + FreeCurAlloc; + result := cHeapOk; + exit; + end; + + if (n.sizeFlags and cThisUsedFlag) <> 0 then begin + { inv: n is a used block } + if (n.sizeFlags and not cFlags) < sizeof(TUsed) then begin + heapErrorCode := cBadNextBlock; + goto abort; + end; + n.sizeFlags := n.sizeFlags or cPrevFreeFlag + end else begin + { inv: block u & n are both free; coalesce } + f := PFree(n); + if (f.next = nil) or (f.prev = nil) or (f.size < sizeof(TFree)) then begin + heapErrorCode := cBadNextBlock; + goto abort; + end; + nextSize := f.size; + inc(size, nextSize); + DeleteFree(f); + { inv: last block (which was free) is not on free list } + end; + + InsertFree(u, size); +abort: + result := heapErrorCode; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; +end; + + +function ResizeInPlace(p: Pointer; newSize: Integer): Boolean; +var u, n: PUsed; f: PFree; oldSize, blkSize, neededSize: Integer; +begin + Inc(newSize, sizeof(TUsed)+cAlign-1); + newSize := newSize and not (cAlign-1); + if newSize < sizeof(TFree) then + newSize := sizeof(TFree); + u := PUsed(PChar(p) - sizeof(TUsed)); + oldSize := u.sizeFlags and not cFlags; + n := PUsed( PChar(u) + oldSize ); + if newSize <= oldSize then + begin + blkSize := oldSize - newSize; + if PChar(n) = curAlloc then begin + Dec(curAlloc, blkSize); + Inc(remBytes, blkSize); + if remBytes < sizeof(TFree) then begin + Inc(curAlloc, blkSize); + Dec(remBytes, blkSize); + newSize := oldSize; + end; + end else begin + n := PUsed(PChar(u) + oldSize); + if n.sizeFlags and cThisUsedFlag = 0 then begin + f := PFree(n); + Inc(blkSize, f.size); + DeleteFree(f); + end; + if blkSize >= sizeof(TFree) then begin + n := PUsed(PChar(u) + newSize); + n.sizeFlags := blkSize or cThisUsedFlag; + InternalFreeMem(PChar(n) + sizeof(TUsed)); + end else + newSize := oldSize; + end; + end else begin + repeat + neededSize := newSize - oldSize; + if PChar(n) = curAlloc then begin + if remBytes >= neededSize then begin + Dec(remBytes, neededSize); + Inc(curAlloc, neededSize); + if remBytes < sizeof(TFree) then begin + Inc(curAlloc, remBytes); + Inc(newSize, remBytes); + remBytes := 0; + end; + Inc(AllocMemSize, newSize - oldSize); + u.sizeFlags := newSize or u.sizeFlags and cFlags; + result := true; + exit; + end else begin + FreeCurAlloc; + n := PUsed( PChar(u) + oldSize ); + end; + end; + + if n.sizeFlags and cThisUsedFlag = 0 then begin + f := PFree(n); + blkSize := f.size; + if blkSize < neededSize then begin + n := PUsed(PChar(n) + blkSize); + Dec(neededSize, blkSize); + end else begin + DeleteFree(f); + Dec(blkSize, neededSize); + if blkSize >= sizeof(TFree) then + InsertFree(PChar(u) + newSize, blkSize) + else begin + Inc(newSize, blkSize); + n := PUsed(PChar(u) + newSize); + n.sizeFlags := n.sizeFlags and not cPrevFreeFlag; + end; + break; + end; + end; + + if n.sizeFlags and cFillerFlag <> 0 then begin + n := PUsed(PChar(n) + n.sizeFlags and not cFlags); + if NewCommitAt(n, neededSize) then begin + n := PUsed( PChar(u) + oldSize ); + continue; + end; + end; + + result := False; + exit; + + until False; + + end; + + Inc(AllocMemSize, newSize - oldSize); + u.sizeFlags := newSize or u.sizeFlags and cFlags; + result := True; + +end; + + +function SysReallocMem(p: Pointer; size: Integer): Pointer; +// Resize memory block. +var + n: Pointer; oldSize: Integer; +begin + + if not initialized and not InitAllocator then begin + result := nil; + exit; + end; + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + if ResizeInPlace(p, size) then + result := p + else begin + n := SysGetMem(size); + oldSize := (PUsed(PChar(p)-sizeof(PUsed)).sizeFlags and not cFlags) - sizeof(TUsed); + if oldSize > size then + oldSize := size; + if n <> nil then begin + Move(p^, n^, oldSize); + SysFreeMem(p); + end; + result := n; + end; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; + +end; + + +function BlockSum(root: PBlockDesc): Integer; +var + b : PBlockDesc; +begin + result := 0; + b := root.next; + while b <> root do begin + Inc(result, b.size); + b := b.next; + end; +end; + + +function GetHeapStatus: THeapStatus; +var + size, freeSize, userSize: Cardinal; + f: PFree; + a, e: PChar; + i: Integer; + b: PBlockDesc; + prevFree: Boolean; +begin + + result.TotalAddrSpace := 0; + result.TotalUncommitted := 0; + result.TotalCommitted := 0; + result.TotalAllocated := 0; + result.TotalFree := 0; + result.FreeSmall := 0; + result.FreeBig := 0; + result.Unused := 0; + result.Overhead := 0; + result.HeapErrorCode := cHeapOk; + + if not initialized then exit; + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + result.totalAddrSpace := BlockSum(@spaceRoot); + result.totalUncommitted := BlockSum(@decommittedRoot); + result.totalCommitted := BlockSum(@committedRoot); + + size := 0; + for i := Low(smallTab^) to High(smallTab^) do begin + f := smallTab[i]; + if f <> nil then begin + repeat + Inc(size, f.size); + if (f.prev.next <> f) or (f.next.prev <> f) or (f.size < sizeof(TFree)) then begin + heapErrorCode := cBadFreeList; + break; + end; + f := f.next; + until f = smallTab[i]; + end; + end; + result.freeSmall := size; + + size := 0; + f := avail.next; + while f <> @avail do begin + if (f.prev.next <> f) or (f.next.prev <> f) or (f.size < sizeof(TFree)) then begin + heapErrorCode := cBadFreeList; + break; + end; + Inc(size, f.size); + f := f.next; + end; + result.freeBig := size; + + result.unused := remBytes; + result.totalFree := result.freeSmall + result.freeBig + result.unused; + + freeSize := 0; + userSize := 0; + result.overhead := 0; + + b := committedRoot.next; + prevFree := False; + while b <> @committedRoot do begin + a := b.addr; + e := a + b.size; + while a < e do begin + if (a = curAlloc) and (remBytes > 0) then begin + size := remBytes; + Inc(freeSize, size); + if prevFree then + heapErrorCode := cBadCurAlloc; + prevFree := False; + end else begin + if prevFree <> ((PUsed(a).sizeFlags and cPrevFreeFlag) <> 0) then + heapErrorCode := cBadNextBlock; + if (PUsed(a).sizeFlags and cThisUsedFlag) = 0 then begin + f := PFree(a); + if (f.prev.next <> f) or (f.next.prev <> f) or (f.size < sizeof(TFree)) then + heapErrorCode := cBadFreeBlock; + size := f.size; + Inc(freeSize, size); + prevFree := True; + end else begin + size := PUsed(a).sizeFlags and not cFlags; + if (PUsed(a).sizeFlags and cFillerFlag) <> 0 then begin + Inc(result.overhead, size); + if (a > b.addr) and (a + size < e) then + heapErrorCode := cBadUsedBlock; + end else begin + Inc(userSize, size-sizeof(TUsed)); + Inc(result.overhead, sizeof(TUsed)); + end; + prevFree := False; + end; + end; + Inc(a, size); + end; + b := b.next; + end; + if result.totalFree <> freeSize then + heapErrorCode := cBadBalance; + + result.totalAllocated := userSize; + result.heapErrorCode := heapErrorCode; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; +end; + + +// this section goes into GetMem.Inc + +{$IFDEF DEBUG_FUNCTIONS} +type + THeapReportProc = procedure(HeapBlock: Pointer; AllocatedSize: Integer) of object; + + +procedure WalkHeap(HeapReportProc: THeapReportProc); +var + size : Cardinal; + f: PFree; + a, e: PChar; + b: PBlockDesc; +begin + + if not initialized then exit; + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + b := committedRoot.next; + while b <> @committedRoot do begin + a := b.addr; + e := a + b.size; + while a < e do begin + if (a = curAlloc) and (remBytes > 0) then begin + size := remBytes; + end else begin + if (PUsed(a).sizeFlags and cThisUsedFlag) = 0 then begin + f := PFree(a); + size := f.size; + end else begin + size := PUsed(a).sizeFlags and not cFlags; + if (PUsed(a).sizeFlags and cFillerFlag) = 0 then begin + HeapReportProc(a + sizeof(TUsed), size - sizeof(TUsed)); + end; + end; + end; + Inc(a, size); + end; + b := b.next; + end; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; +end; + +type + THeapBlockCollector = class(TObject) + FCount: Integer; + FObjectTable: TObjectArray; + FHeapBlockTable: THeapBlockArray; + FClass: TClass; + FFindDerived: Boolean; + procedure CollectBlocks(HeapBlock: Pointer; AllocatedSize: Integer); + procedure CollectObjects(HeapBlock: Pointer; AllocatedSize: Integer); + end; + + +procedure THeapBlockCollector.CollectBlocks(HeapBlock: Pointer; AllocatedSize: Integer); +begin + if FCount < Length(FHeapBlockTable) then + begin + FHeapBlockTable[FCount].Start := HeapBlock; + FHeapBlockTable[FCount].Size := AllocatedSize; + end; + Inc(FCount); +end; + + +procedure THeapBlockCollector.CollectObjects(HeapBlock: Pointer; AllocatedSize: Integer); +var + AObject: TObject; + AClass: TClass; +type + PPointer = ^Pointer; +begin + try + if AllocatedSize < 4 then + Exit; + AObject := TObject(HeapBlock); + AClass := AObject.ClassType; + if (AClass = FClass) + or (FFindDerived + and (Integer(AClass) >= 64*1024) + and (PPointer(PChar(AClass) + vmtSelfPtr)^ = Pointer(AClass)) + and (AObject is FClass)) then + begin + if FCount < Length(FObjectTable) then + FObjectTable[FCount] := AObject; + Inc(FCount); + end; + except + // Let's not worry about this block - it's obviously not a valid object + end; +end; + +var + HeapBlockCollector: THeapBlockCollector; + +function GetHeapBlocks: THeapBlockArray; +begin + if not Assigned(HeapBlockCollector) then + HeapBlockCollector := THeapBlockCollector.Create; + + Walkheap(HeapBlockCollector.CollectBlocks); + SetLength(HeapBlockCollector.FHeapBlockTable, HeapBlockCollector.FCount); + HeapBlockCollector.FCount := 0; + Walkheap(HeapBlockCollector.CollectBlocks); + Result := HeapBlockCollector.FHeapBlockTable; + HeapBlockCollector.FCount := 0; + HeapBlockCollector.FHeapBlockTable := nil; +end; + + +function FindObjects(AClass: TClass; FindDerived: Boolean): TObjectArray; +begin + if not Assigned(HeapBlockCollector) then + HeapBlockCollector := THeapBlockCollector.Create; + HeapBlockCollector.FClass := AClass; + HeapBlockCollector.FFindDerived := FindDerived; + + Walkheap(HeapBlockCollector.CollectObjects); + SetLength(HeapBlockCollector.FObjectTable, HeapBlockCollector.FCount); + HeapBlockCollector.FCount := 0; + Walkheap(HeapBlockCollector.CollectObjects); + Result := HeapBlockCollector.FObjectTable; + HeapBlockCollector.FCount := 0; + HeapBlockCollector.FObjectTable := nil; +end; +{$ENDIF} + + diff --git a/System/D2006_orig/DelphiMM.pas b/System/D2006_orig/DelphiMM.pas new file mode 100644 index 0000000..ba37cd8 --- /dev/null +++ b/System/D2006_orig/DelphiMM.pas @@ -0,0 +1,48 @@ + +{ *********************************************************************** } +{ } +{ Delphi Runtime Library } +{ } +{ Copyright (c) 2000-2005 Borland Software Corporation } +{ } +{ *********************************************************************** } + +library DelphiMM; + +{$IMAGEBASE $41008000} +{$R *.RES} + +const + BorlandMM = 'borlndmm.dll'; + +function SysGetMem(Size: Integer): Pointer; external BorlandMM name '@Borlndmm@SysGetMem$qqri'; +function SysFreeMem(P: Pointer): Integer; external BorlandMM name '@Borlndmm@SysFreeMem$qqrpv'; +function SysReallocMem(P: Pointer; Size: Integer): Pointer; external BorlandMM name '@Borlndmm@SysReallocMem$qqrpvi'; +function GetHeapStatus: THeapStatus; external BorlandMM; +function GetAllocMemCount: Integer; external BorlandMM; +function GetAllocMemSize: Integer; external BorlandMM; +procedure DumpBlocks; external BorlandMM; +function GetMemory(Size: Integer): Pointer; cdecl; external BorlandMM; +function FreeMemory(P: Pointer): Integer; cdecl; external BorlandMM; +function ReallocMemory(P: Pointer; Size: Integer): Pointer; cdecl; external BorlandMM; +function SysAllocMem(P: Pointer; Size: Integer): Pointer; external BorlandMM; +function SysRegisterExpectedMemoryLeak(P: Pointer): Boolean; external BorlandMM; +function SysUnregisterExpectedMemoryLeak(P: Pointer): Boolean; external BorlandMM; + +exports + SysGetMem, + SysFreeMem, + SysReallocMem, + GetMemory, + FreeMemory, + ReallocMemory, + DumpBlocks, + GetHeapStatus, + GetAllocMemCount, + GetAllocMemSize, + SysAllocMem, + SysRegisterExpectedMemoryLeak, + SysUnregisterExpectedMemoryLeak; + +begin +end. diff --git a/System/D2006_orig/SimpleShareMem.pas b/System/D2006_orig/SimpleShareMem.pas new file mode 100644 index 0000000..b9e03ad --- /dev/null +++ b/System/D2006_orig/SimpleShareMem.pas @@ -0,0 +1,43 @@ +{ *********************************************************************** } +{ } +{ Borland Delphi Memory Manager } +{ } +{ Copyright (c) 2005 Borland Software Corporation } +{ } +{ Portions created by Pierre le Riche are } +{ Copyright (c) Pierre le Riche / Professional Software Development } +{ } +{ Acknowledgement: With special thanks to the Fastcode community and } +{ supporters for their valuable input and feedback. } +{ } +{ } +{ *********************************************************************** } + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * This memory manager implementation is subject to the + * Mozilla Public License Version 1.1 (the "License"); you may + * not use this file except in compliance with the License. + * You may obtain a copy of the License at http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * ***** END LICENSE BLOCK ***** *) + +unit SimpleShareMem; + +interface + +implementation + +initialization + {Try to use a shared memory manager. If one is not available, start sharing + the current one.} + If not AttemptToUseSharedMemoryManager then + ShareMemoryManager + +end. diff --git a/System/D2006_orig/StrHlpr.pas b/System/D2006_orig/StrHlpr.pas new file mode 100644 index 0000000..fcc9d79 --- /dev/null +++ b/System/D2006_orig/StrHlpr.pas @@ -0,0 +1,185 @@ +{ *********************************************************************** } +{ } +{ Delphi/C++Builder Runtime Library } +{ Helpers for C++ AnsiString and WideString binding. } +{ } +{ Copyright (c) 2002 Borland Software Corporation } +{ } +{ *********************************************************************** } + +unit StrHlpr; + +interface + +function AnsiCat(const x, y: AnsiString): AnsiString; +function AnsiCopy(const src: AnsiString; index, count: Integer): AnsiString; +function AnsiPos(const src, sub: AnsiString): Integer; +procedure AnsiAppend(var dst: AnsiString; const src: AnsiString); +procedure AnsiDelete(var dst: AnsiString; index, count: Integer); +procedure AnsiFromPWideChar(var dst: AnsiString; src: PWideChar); +procedure AnsiFromWide(var dst: AnsiString; const src: WideString); +procedure AnsiInsert(var dst: AnsiString; const src: AnsiString; index: Integer); +procedure AnsiSetLength(var dst: AnsiString; len: Integer); +procedure AnsiFree(var s: AnsiString); + +{ AnsiAssign is called from the C++ AnsiString's copy constructor, so it + must use pass-by-reference to avoid infinite recursion. This will + require ugly const_cast<>'s in the C++ caller } +procedure AnsiAssign(var dst: AnsiString; var src: AnsiString); + + +procedure WideAppend(var dst: WideString; const src: WideString); +function WideCat(const x, y: WideString): WideString; +function WideCopy(const src: WideString; index, count: Integer): WideString; +function WideEqual(const x, y: WideString): Boolean; +function WideGreater(const x, y: WideString): Boolean; +function WideLength(const src: WideString): Integer; +function WideLess(const x, y: WideString): Boolean; +function WidePos(const src, sub: WideString): Integer; +procedure WideDelete(var dst: WideString; index, count: Integer); +procedure WideFree(var s: WideString); +procedure WideFromAnsi(var dst: WideString; const src: AnsiString); +procedure WideFromPChar(var dst: WideString; src: PChar); +procedure WideInsert(var dst: WideString; const src: WideString; index: Integer); +procedure WideSetLength(var dst: WideString; len: Integer); + +{ WideAssign is called from the C++ AnsiString's copy constructor, so it + must use pass-by-reference to avoid infinite recursion. This will + require ugly const_cast<>'s in the C++ caller } +procedure WideAssign(var dst: WideString; var src: WideString); + + +implementation + +procedure AnsiFromWide(var dst: AnsiString; const src: WideString); +begin + dst := src; +end; + +procedure AnsiFromPWideChar(var dst: AnsiString; src: PWideChar); +begin + dst := src; +end; + +procedure AnsiAppend(var dst: AnsiString; const src: AnsiString); +begin + dst := dst + src; +end; + +function AnsiCat(const x, y: AnsiString): AnsiString; +begin + Result := x + y; +end; + +procedure AnsiDelete(var dst: AnsiString; index, count: Integer); +begin + Delete(dst, index, count); +end; + +procedure AnsiSetLength(var dst: AnsiString; len: Integer); +begin + SetLength(dst, len); +end; + +function AnsiPos(const src, sub: AnsiString): Integer; +begin + Result := Pos(sub, src); +end; + +function AnsiCopy(const src: AnsiString; index, count: Integer): AnsiString; +begin + Result := Copy(src, index, count); +end; + +procedure AnsiInsert(var dst: AnsiString; const src: AnsiString; index: Integer); +begin + Insert(src, dst, index); +end; + +procedure AnsiAssign(var dst: AnsiString; var src: AnsiString); +begin + dst := src; +end; + +procedure AnsiFree(var s: AnsiString); +begin + s := ''; +end; + +procedure WideAssign(var dst: WideString; var src: WideString); +begin + dst := src; +end; + +procedure WideFree(var s: WideString); +begin + s := ''; +end; + +procedure WideFromAnsi(var dst: WideString; const src: AnsiString); +begin + dst := src; +end; + +procedure WideFromPChar(var dst: WideString; src: PChar); +begin + dst := src; +end; + +function WideEqual(const x, y: WideString): Boolean; +begin + Result := x = y; +end; + +function WideLess(const x, y: WideString): Boolean; +begin + Result := x < y; +end; + +function WideGreater(const x, y: WideString): Boolean; +begin + Result := x > y; +end; + +function WideCat(const x, y: WideString): WideString; +begin + Result := x + y; +end; + +function WideLength(const src: WideString): Integer; +begin + Result := Length(src); +end; + +function WidePos(const src, sub: WideString): Integer; +begin + Result := Pos(sub, src); +end; + +procedure WideSetLength(var dst: WideString; len: Integer); +begin + SetLength(dst, len); +end; + +procedure WideDelete(var dst: WideString; index, count: Integer); +begin + Delete(dst, index, count); +end; + +procedure WideInsert(var dst: WideString; const src: WideString; index: Integer); +begin + Insert(src, dst, index); +end; + +function WideCopy(const src: WideString; index, count: Integer): WideString; +begin + Result := Copy(src, index, count); +end; + +procedure WideAppend(var dst: WideString; const src: WideString); +begin + dst := dst + src; +end; + + +end. diff --git a/System/D2006_orig/SysConst.pas b/System/D2006_orig/SysConst.pas new file mode 100644 index 0000000..c3d4abf --- /dev/null +++ b/System/D2006_orig/SysConst.pas @@ -0,0 +1,184 @@ + +{ *********************************************************************** } +{ } +{ Delphi / Kylix Cross-Platform Runtime Library } +{ } +{ Copyright (c) 1995-2001 Borland Software Corporation } +{ } +{ *********************************************************************** } + +unit SysConst; + +interface + +resourcestring + SUnknown = ''; + SInvalidInteger = '''%s'' is not a valid integer value'; + SInvalidFloat = '''%s'' is not a valid floating point value'; + SInvalidCurrency = '''%s'' is not a valid currency value'; + SInvalidDate = '''%s'' is not a valid date'; + SInvalidTime = '''%s'' is not a valid time'; + SInvalidDateTime = '''%s'' is not a valid date and time'; + SInvalidDateTimeFloat = '''%g'' is not a valid date and time'; + SInvalidTimeStamp = '''%d.%d'' is not a valid timestamp'; + SInvalidGUID = '''%s'' is not a valid GUID value'; + SInvalidBoolean = '''%s'' is not a valid boolean value'; + STimeEncodeError = 'Invalid argument to time encode'; + SDateEncodeError = 'Invalid argument to date encode'; + SOutOfMemory = 'Out of memory'; + SInOutError = 'I/O error %d'; + SFileNotFound = 'File not found'; + SInvalidFilename = 'Invalid filename'; + STooManyOpenFiles = 'Too many open files'; + SAccessDenied = 'File access denied'; + SEndOfFile = 'Read beyond end of file'; + SDiskFull = 'Disk full'; + SInvalidInput = 'Invalid numeric input'; + SDivByZero = 'Division by zero'; + SRangeError = 'Range check error'; + SIntOverflow = 'Integer overflow'; + SInvalidOp = 'Invalid floating point operation'; + SZeroDivide = 'Floating point division by zero'; + SOverflow = 'Floating point overflow'; + SUnderflow = 'Floating point underflow'; + SInvalidPointer = 'Invalid pointer operation'; + SInvalidCast = 'Invalid class typecast'; +{$IFDEF MSWINDOWS} + SAccessViolationArg3 = 'Access violation at address %p. %s of address %p'; +{$ENDIF} +{$IFDEF LINUX} + SAccessViolationArg2 = 'Access violation at address %p, accessing address %p'; +{$ENDIF} + SAccessViolationNoArg = 'Access violation'; + SStackOverflow = 'Stack overflow'; + SControlC = 'Control-C hit'; + SQuit = 'Quit key hit'; + SPrivilege = 'Privileged instruction'; + SOperationAborted = 'Operation aborted'; + SException = 'Exception %s in module %s at %p.' + sLineBreak + '%s%s' + sLineBreak; + SExceptTitle = 'Application Error'; +{$IFDEF LINUX} + SSigactionFailed = 'sigaction call failed'; +{$ENDIF} + SInvalidFormat = 'Format ''%s'' invalid or incompatible with argument'; + SArgumentMissing = 'No argument for format ''%s'''; + SDispatchError = 'Variant method calls not supported'; + SReadAccess = 'Read'; + SWriteAccess = 'Write'; + SResultTooLong = 'Format result longer than 4096 characters'; + SFormatTooLong = 'Format string too long'; + + SVarArrayCreate = 'Error creating variant or safe array'; + SVarArrayBounds = 'Variant or safe array index out of bounds'; + SVarArrayLocked = 'Variant or safe array is locked'; + SVarArrayWithHResult = 'Unexpected variant or safe array error: %s%.8x'; + + SInvalidVarCast = 'Invalid variant type conversion'; + SInvalidVarOp = 'Invalid variant operation'; + SInvalidVarNullOp = 'Invalid NULL variant operation'; + SInvalidVarOpWithHResultWithPrefix = 'Invalid variant operation (%s%.8x)'#10'%s'; + SVarTypeRangeCheck1 = 'Range check error for variant of type (%s)'; + SVarTypeRangeCheck2 = 'Range check error while converting variant of type (%s) into type (%s)'; + SVarTypeOutOfRangeWithPrefix = 'Custom variant type (%s%.4x) is out of range'; + SVarTypeAlreadyUsedWithPrefix = 'Custom variant type (%s%.4x) already used by %s'; + SVarTypeNotUsableWithPrefix = 'Custom variant type (%s%.4x) is not usable'; + SVarTypeTooManyCustom = 'Too many custom variant types have been registered'; + + // the following are not used anymore + SVarNotArray = 'Variant is not an array' deprecated; // not used, use SVarInvalid instead + SVarTypeUnknown = 'Unknown custom variant type ($%.4x)' deprecated; // not used anymore + SVarTypeOutOfRange = 'Custom variant type ($%.4x) is out of range' deprecated; + SVarTypeAlreadyUsed = 'Custom variant type ($%.4x) already used by %s' deprecated; + SVarTypeNotUsable = 'Custom variant type ($%.4x) is not usable' deprecated; + SInvalidVarOpWithHResult = 'Invalid variant operation ($%.8x)' deprecated; + + SVarTypeCouldNotConvert = 'Could not convert variant of type (%s) into type (%s)'; + SVarTypeConvertOverflow = 'Overflow while converting variant of type (%s) into type (%s)'; + SVarOverflow = 'Variant overflow'; + SVarInvalid = 'Invalid argument'; + SVarBadType = 'Invalid variant type'; + SVarNotImplemented = 'Operation not supported'; + SVarOutOfMemory = 'Variant operation ran out memory'; + SVarUnexpected = 'Unexpected variant error'; + + SVarDataClearRecursing = 'Recursion while doing a VarDataClear'; + SVarDataCopyRecursing = 'Recursion while doing a VarDataCopy'; + SVarDataCopyNoIndRecursing = 'Recursion while doing a VarDataCopyNoInd'; + SVarDataInitRecursing = 'Recursion while doing a VarDataInit'; + SVarDataCastToRecursing = 'Recursion while doing a VarDataCastTo'; + SVarIsEmpty = 'Variant is empty'; + sUnknownFromType = 'Cannot convert from the specified type'; + sUnknownToType = 'Cannot convert to the specified type'; + SExternalException = 'External exception %x'; + SAssertionFailed = 'Assertion failed'; + SIntfCastError = 'Interface not supported'; + SSafecallException = 'Exception in safecall method'; + SAssertError = '%s (%s, line %d)'; + SAbstractError = 'Abstract Error'; + SModuleAccessViolation = 'Access violation at address %p in module ''%s''. %s of address %p'; + SCannotReadPackageInfo = 'Cannot access package information for package ''%s'''; + sErrorLoadingPackage = 'Can''t load package %s.'+sLineBreak+'%s'; + SInvalidPackageFile = 'Invalid package file ''%s'''; + SInvalidPackageHandle = 'Invalid package handle'; + SDuplicatePackageUnit = 'Cannot load package ''%s.'' It contains unit ''%s,''' + + 'which is also contained in package ''%s'''; + SOSError = 'System Error. Code: %d.'+sLineBreak+'%s'; + SUnkOSError = 'A call to an OS function failed'; +{$IFDEF MSWINDOWS} + SWin32Error = 'Win32 Error. Code: %d.'#10'%s' deprecated; // use SOSError + SUnkWin32Error = 'A Win32 API function failed' deprecated; // use SUnkOSError +{$ENDIF} + SNL = 'Application is not licensed to use this feature'; + + SShortMonthNameJan = 'Jan'; + SShortMonthNameFeb = 'Feb'; + SShortMonthNameMar = 'Mar'; + SShortMonthNameApr = 'Apr'; + SShortMonthNameMay = 'May'; + SShortMonthNameJun = 'Jun'; + SShortMonthNameJul = 'Jul'; + SShortMonthNameAug = 'Aug'; + SShortMonthNameSep = 'Sep'; + SShortMonthNameOct = 'Oct'; + SShortMonthNameNov = 'Nov'; + SShortMonthNameDec = 'Dec'; + + SLongMonthNameJan = 'January'; + SLongMonthNameFeb = 'February'; + SLongMonthNameMar = 'March'; + SLongMonthNameApr = 'April'; + SLongMonthNameMay = 'May'; + SLongMonthNameJun = 'June'; + SLongMonthNameJul = 'July'; + SLongMonthNameAug = 'August'; + SLongMonthNameSep = 'September'; + SLongMonthNameOct = 'October'; + SLongMonthNameNov = 'November'; + SLongMonthNameDec = 'December'; + + SShortDayNameSun = 'Sun'; + SShortDayNameMon = 'Mon'; + SShortDayNameTue = 'Tue'; + SShortDayNameWed = 'Wed'; + SShortDayNameThu = 'Thu'; + SShortDayNameFri = 'Fri'; + SShortDayNameSat = 'Sat'; + + SLongDayNameSun = 'Sunday'; + SLongDayNameMon = 'Monday'; + SLongDayNameTue = 'Tuesday'; + SLongDayNameWed = 'Wednesday'; + SLongDayNameThu = 'Thursday'; + SLongDayNameFri = 'Friday'; + SLongDayNameSat = 'Saturday'; + +{$IFDEF LINUX} + SEraEntries = ''; +{$ENDIF} + + SCannotCreateDir = 'Unable to create directory'; + SCodesetConversionError = 'Codeset conversion failure'; + +implementation + +end. diff --git a/System/D2006_orig/SysInit.pas b/System/D2006_orig/SysInit.pas new file mode 100644 index 0000000..37b1323 --- /dev/null +++ b/System/D2006_orig/SysInit.pas @@ -0,0 +1,836 @@ +{ *********************************************************************** } +{ } +{ Delphi / Kylix Cross-Platform Runtime Library } +{ System Initialization Unit } +{ } +{ Copyright (c) 1997-2005 Borland Software Corporation } +{ } +{ *********************************************************************** } + +unit SysInit; + +interface + +{$H+,I-,R-,S-,O+,W-} +{$WARN SYMBOL_PLATFORM OFF} +{$WARN UNSAFE_TYPE OFF} + +{$IFDEF LINUX} +const + ExeBaseAddress = Pointer($8048000) platform; +{$ENDIF} + +var + ModuleIsLib: Boolean; { True if this module is a dll (a library or a package) } + ModuleIsPackage: Boolean; { True if this module is a package } + ModuleIsCpp: Boolean; { True if this module is compiled using C++ Builder } + TlsIndex: Integer = -1; { Thread local storage index } + TlsLast: Byte; { Set by linker so its offset is last in TLS segment } + HInstance: LongWord; { Handle of this instance } + {$EXTERNALSYM HInstance} + (*$HPPEMIT 'namespace Sysinit' *) + (*$HPPEMIT '{' *) + (*$HPPEMIT 'extern PACKAGE HINSTANCE HInstance;' *) + (*$HPPEMIT '} /* namespace Sysinit */' *) + DllProc: TDLLProc; { Called whenever DLL entry point is called } + { DllProcEx passes the Reserved param provided by WinNT on DLL load & exit } + DllProcEx: TDLLProcEx absolute DllProc; + DataMark: Integer = 0; { Used to find the virtual base of DATA seg } + CoverageLibraryName: array [0..128] of Char = '*'; { initialized by the linker! } +{$IFDEF ELF} + TypeImportsTable: array [0..0] of Pointer platform; { VMT and RTTI imports table for exes } + _GLOBAL_OFFSET_TABLE_: ARRAY [0..2] OF Cardinal platform; + (* _DYNAMIC: ARRAY [0..0] OF Elf32_Dyn; *) +{$IFDEF PC_MAPPED_EXCEPTIONS} + TextStartAdj: Byte platform; { See GetTextStart } + CodeSegSize: Byte platform; { See GetTextStart } +function GetTextStart : LongInt; platform; +{$ENDIF} +{$ENDIF} + +const + PtrToNil: Pointer = nil; // provides pointer to nil for compiler codegen + +function _GetTls: Pointer; +{$IFDEF LINUX} +procedure _InitLib(Context: PInitContext); +procedure _GetCallerEIP; +procedure _InitExe(InitTable: Pointer; Argc: Integer; Argp: Pointer); +procedure _start; cdecl; +function _ExitLib: Integer; cdecl; +function _InitPkg: LongBool; +{$ENDIF} +{$IFDEF MSWINDOWS} +procedure _InitLib; +procedure _InitExe(InitTable: Pointer); +function _InitPkg(Hinst: Integer; Reason: Integer; Resvd: Pointer): LongBool; stdcall; +{$ENDIF} +procedure _PackageLoad(const Table: PackageInfo); +procedure _PackageUnload(const Table: PackageInfo); + +{ Invoked by C++ startup code to allow initialization of VCL global vars } +procedure VclInit(isDLL, isPkg: Boolean; hInst: LongInt; isGui: Boolean); cdecl; +procedure VclExit; cdecl; + +{$IFDEF LINUX} +function GetThisModuleHandle: LongWord; +{$ENDIF} + +implementation + +{$IFDEF MSWINDOWS} +const + kernel = 'kernel32.dll'; + +function FreeLibrary(ModuleHandle: Longint): LongBool; stdcall; + external kernel name 'FreeLibrary'; + +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 LocalAlloc(flags, size: Integer): Pointer; stdcall; + external kernel name 'LocalAlloc'; + +function LocalFree(addr: Pointer): Pointer; stdcall; + external kernel name 'LocalFree'; + +function TlsAlloc: Integer; stdcall; + external kernel name 'TlsAlloc'; + +function TlsFree(TlsIndex: Integer): Boolean; stdcall; + external kernel name 'TlsFree'; + +function TlsGetValue(TlsIndex: Integer): Pointer; stdcall; + external kernel name 'TlsGetValue'; + +function TlsSetValue(TlsIndex: Integer; TlsValue: Pointer): Boolean; stdcall; + external kernel name 'TlsSetValue'; + +function GetCommandLine: PChar; stdcall; + external kernel name 'GetCommandLineA'; + +const + tlsArray = $2C; { offset of tls array from FS: } + LMEM_ZEROINIT = $40; + +function AllocTlsBuffer(Size: Integer): Pointer; +begin + Result := LocalAlloc(LMEM_ZEROINIT, Size); +end; + +var + tlsBuffer: Pointer; // RTM32 DOS support +{$ENDIF} + +{$IFDEF LINUX} + +{$IFDEF PIC} +function GetGOT: Pointer; export; +begin + asm + MOV Result,EBX + end; +end; +{$ENDIF} + +const + RTLD_LAZY = 1; + RTLD_NOW = 2; + RTLD_BINDING_MASK = RTLD_LAZY or RTLD_NOW; + RTLD_GLOBAL = $100; + RTLD_LOCAL = 0; + RTLD_NEXT = Pointer(-1); + RTLD_DEFAULT = nil; + +type + TDLInfo = record + Filename: PChar; + BaseAddress: Pointer; + NearestSymbolName: PChar; + NearestSymbolAddr: Pointer; + end; + +const + libcmodulename = 'libc.so.6'; + libdlmodulename = 'libdl.so.2'; + libpthreadmodulename = 'libpthread.so.0'; + tlsSizeName = '@Sysinit@tlsSize'; + +function malloc(Size: LongWord): Pointer; cdecl; + external libcmodulename name 'malloc'; + +procedure free(P: Pointer); cdecl; + external libcmodulename name 'free'; + +function dlopen(Filename: PChar; Flag: Integer): LongWord; cdecl; + external libdlmodulename name 'dlopen'; + +function dlerror: PChar; cdecl; + external libdlmodulename name 'dlerror'; + +function dlsym(Handle: LongWord; Symbol: PChar): Pointer; cdecl; + external libdlmodulename name 'dlsym'; + +function dlclose(Handle: LongWord): Integer; cdecl; + external libdlmodulename name 'dlclose'; + +function FreeLibrary(Handle: LongWord): Integer; cdecl; + external libdlmodulename name 'dlclose'; + +function dladdr(Address: Pointer; var Info: TDLInfo): Integer; cdecl; + external libdlmodulename name 'dladdr'; + +type + TInitOnceProc = procedure; cdecl; + TKeyValueDestructor = procedure(ValueInKey: Pointer); cdecl; + +function pthread_once(var InitOnceSemaphore: Integer; InitOnceProc: TInitOnceProc): Integer; cdecl; + external libpthreadmodulename name 'pthread_once'; + +function pthread_key_create(var Key: Integer; KeyValueDestructor: TKeyValueDestructor): Integer; cdecl; + external libpthreadmodulename name 'pthread_key_create'; + +function pthread_key_delete(Key: Integer): Integer; cdecl; + external libpthreadmodulename name 'pthread_key_delete'; + +function TlsGetValue(Key: Integer): Pointer; cdecl; + external libpthreadmodulename name 'pthread_getspecific'; + +function TlsSetValue(Key: Integer; Ptr: Pointer): Integer; cdecl; + external libpthreadmodulename name 'pthread_setspecific'; + +function AllocTlsBuffer(Size: Cardinal): Pointer; +begin + // The C++ rtl handles all tls in a C++ module + if ModuleIsCpp then + RunError(226); + + Result := malloc(Size); + if Result <> nil then + FillChar(Result^, Size, 0); +end; + +procedure FreeTLSBuffer(ValueInKey: Pointer); export cdecl; +begin + // The C++ rtl handles all tls in a C++ module + if ModuleIsCpp then + RunError(226); + free(ValueInKey); +end; + +procedure AllocTlsIndex; cdecl export; +begin + // guaranteed to reach here only once per process + // The C++ rtl handles all tls in a C++ module + if ModuleIsCpp then + RunError(226); + if pthread_key_create(TlsIndex, FreeTLSBuffer) <> 0 then + begin + TlsIndex := -1; + RunError(226); + end; +end; + +function GetThisModuleHandle: LongWord; +var + Info: TDLInfo; +begin + if (dladdr(@GetThisModuleHandle, Info) = 0) or (Info.BaseAddress = ExeBaseAddress) then + Info.FileName := nil; // if we're not in a library, we must be main exe + Result := LongWord(dlopen(Info.Filename, RTLD_LAZY)); + if Result <> 0 then + dlclose(Result); +end; + +var + InitOnceSemaphore: Integer; +{$ENDIF} + +var + Module: TLibModule = ( + Next: nil; + Instance: 0; + CodeInstance: 0; + DataInstance: 0; + ResInstance: 0; + Reserved: 0 +{$IFDEF LINUX} + ; InstanceVar: nil; + GOT: 0; + CodeSegStart: 0; + CodeSegEnd: 0 + ); +{$ELSE} + ); +{$ENDIF} + +function GetTlsSize: Integer; +{$IFDEF LINUX} +asm + MOV EAX, offset TlsLast +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +begin + Result := Integer(@TlsLast); +end; +{$ENDIF} + +procedure InitThreadTLS; +var + p: Pointer; + tlsSize: Integer; +begin + tlsSize := GetTlsSize; + if tlsSize = 0 then Exit; +{$IFDEF LINUX} + pthread_once(InitOnceSemaphore, AllocTlsIndex); +{$ENDIF} + if TlsIndex = -1 then RunError(226); + p := AllocTlsBuffer(tlsSize); + if p = nil then + RunError(226) + else + TlsSetValue(TlsIndex, p); +end; + +{$IFDEF MSWINDOWS} +procedure InitProcessTLS; +begin + if @TlsLast = nil then + Exit; + TlsIndex := TlsAlloc; + InitThreadTLS; + tlsBuffer := TlsGetValue(TlsIndex); // RTM32 DOS support +end; + +procedure ExitThreadTLS; +var + p: Pointer; +begin + if @TlsLast = nil then + Exit; + if TlsIndex <> -1 then begin + p := TlsGetValue(TlsIndex); + if p <> nil then begin + LocalFree(p); + TlsSetValue(TlsIndex, nil); + end; + end; +end; + +procedure ExitProcessTLS; +begin + if @TlsLast = nil then + Exit; + ExitThreadTLS; + if TlsIndex <> -1 then + TlsFree(TlsIndex); +end; +{$ENDIF} + +const + DLL_PROCESS_DETACH = 0; + DLL_PROCESS_ATTACH = 1; + DLL_THREAD_ATTACH = 2; + DLL_THREAD_DETACH = 3; + +function _GetTls: Pointer; +{$IFDEF LINUX} +begin + Result := TlsGetValue(TlsIndex); + if Result = nil then + begin + InitThreadTLS; + Result := TlsGetValue(TlsIndex); + end; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + MOV CL,ModuleIsLib + MOV EAX,TlsIndex + TEST CL,CL + JNE @@isDll + MOV EDX,FS:tlsArray + MOV EAX,[EDX+EAX*4] + RET + +@@initTls: + CALL InitThreadTLS + MOV EAX,TlsIndex + PUSH EAX + CALL TlsGetValue + TEST EAX,EAX + JE @@RTM32 + RET + +@@RTM32: + MOV EAX, tlsBuffer + RET + +@@isDll: + PUSH EAX + CALL TlsGetValue + TEST EAX,EAX + JE @@initTls +end; + +const + TlsProc: array [DLL_PROCESS_DETACH..DLL_THREAD_DETACH] of procedure = + (ExitProcessTLS,InitProcessTLS,InitThreadTLS,ExitThreadTLS); +{$ENDIF} + +{$IFDEF PC_MAPPED_EXCEPTIONS} +const + UNWINDFI_TOPOFSTACK = $BE00EF00; + +{ + The linker sets the value of TextStartAdj to be the delta between GetTextStart + and the start of the text segment. This allows us to get the pointer to the + start of the text segment in a position independent fashion. +} +function GetTextStart : LongInt; +asm + CALL @@label1 +@@label1: + POP EAX + SUB EAX, 5 + offset TextStartAdj +end; + +{ + The linker sets the value of CodeSegSize to the length of the text segment, + excluding the PC map. This allows us to get the pointer to the exception + information that we need at runtime, also in a position independent fashion. +} +function GetTextEnd : LongInt; +asm + CALL GetTextStart + ADD EAX, offset CodeSegSize +end; +{$ENDIF} + +procedure InitializeModule; +begin + RegisterModule(@Module); +end; + +procedure UninitializeModule; +begin + UnregisterModule(@Module); + if (Module.ResInstance <> Module.Instance) and (Module.ResInstance <> 0) then + FreeLibrary(Module.ResInstance); +end; + +procedure VclInit(isDLL, isPkg: Boolean; hInst: LongInt; isGui: Boolean); cdecl; +begin + ModuleIsLib := isDLL; + ModuleIsPackage := isPkg; + IsLibrary := isDLL and not isPkg; + HInstance := hInst; + Module.Instance := hInst; + Module.CodeInstance := 0; + Module.DataInstance := 0; + ModuleIsCpp := True; +{$IFDEF LINUX} + if ModuleIsLib then + Module.InstanceVar := @HInstance; +{$IFDEF PIC} + Module.GOT := LongWord(GetGot); +{$ENDIF} + { Module.CodeSegStart, Module.CodeSegEnd not used: the C++ + rtl will feed the unwinder. } +{$ENDIF} + InitializeModule; + if not ModuleIsLib then + begin + Module.CodeInstance := FindHInstance(@VclInit); + Module.DataInstance := FindHInstance(@DataMark); +{$IFDEF MSWINDOWS} +{X CmdLine := GetCommandLine; - converted to a function } + IsConsole := not isGui; +{$ENDIF} + end; +end; + +procedure VclExit; cdecl; +var + P: procedure; +begin + if not ModuleIsLib then + while ExitProc <> nil do + begin + @P := ExitProc; + ExitProc := nil; + P; + end; + UnInitializeModule; +end; + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure RegisterPCMap; +begin + SysRegisterIPLookup(GetTextStart, + GetTextEnd, + Pointer(GetTextEnd), + LongWord(@_Global_Offset_Table_)); +end; + +procedure UnregisterPCMap; +begin + SysUnregisterIPLookup(GetTextStart); +end; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function _InitPkg(Hinst: Longint; Reason: Integer; Resvd: Pointer): Longbool; stdcall; +begin + ModuleIsLib := True; + ModuleIsPackage := True; + Module.Instance := Hinst; + Module.CodeInstance := 0; + Module.DataInstance := 0; + HInstance := Hinst; + if @TlsLast <> nil then + TlsProc[Reason]; + if Reason = DLL_PROCESS_ATTACH then + InitializeModule + else if Reason = DLL_PROCESS_DETACH then + UninitializeModule; + _InitPkg := True; +end; +{$ENDIF} +{$IFDEF LINUX} +function _InitPkg: LongBool; +begin +{$IFDEF DEBUG_STARTUP} +asm +INT 3 +end; +{$ENDIF} +{$IFDEF PC_MAPPED_EXCEPTIONS} + RegisterPCMap; +{$ENDIF} + TlsIndex := -1; + ModuleIsLib := True; + ModuleIsPackage := True; + Module.Instance := GetThisModuleHandle; + Module.InstanceVar := @HInstance; + Module.CodeInstance := 0; + Module.DataInstance := 0; + Module.GOT := LongWord(@_Global_Offset_Table_); + Module.CodeSegStart := GetTextStart; + Module.CodeSegEnd := GetTextEnd; + HInstance := Module.Instance; + InitializeModule; + _InitPkg := True; +end; +{$ENDIF} + +procedure _PackageLoad(const Table: PackageInfo); +begin + System._PackageLoad(Table, @Module); +end; + +procedure _PackageUnload(const Table: PackageInfo); +begin + System._PackageUnload(Table, @Module); +end; + +{$IFDEF MSWINDOWS} +procedure _InitLib; +asm + { -> EAX Inittable } + { [EBP+8] Hinst } + { [EBP+12] Reason } + { [EBP+16] Resvd } + + MOV EDX,offset Module + CMP dword ptr [EBP+12],DLL_PROCESS_ATTACH + JNE @@notInit + + PUSH EAX + PUSH EDX + MOV ModuleIsLib,1 + MOV ECX,[EBP+8] + MOV HInstance,ECX + MOV [EDX].TLibModule.Instance,ECX + MOV [EDX].TLibModule.CodeInstance,0 + MOV [EDX].TLibModule.DataInstance,0 + CALL InitializeModule + POP EDX + POP EAX + +@@notInit: + PUSH DllProc + MOV ECX,offset TlsProc + CALL _StartLib +end; + +// ExitLib is the same as InitLib in Windows. + +{$ENDIF MSWINDOWS} +{$IFDEF LINUX} +procedure _InitLib(Context: PInitContext); +begin +{$IFDEF DEBUG_STARTUP} +asm + INT 3 +end; +{$ENDIF} + asm + PUSH UNWINDFI_TOPOFSTACK + end; + Context.DLLInitState := DLL_PROCESS_ATTACH; + TlsIndex := -1; + ModuleIsLib := True; + HInstance := GetThisModuleHandle; + Module.Instance := HInstance; + Module.InstanceVar := @HInstance; + Module.CodeInstance := 0; + Module.DataInstance := 0; + Module.GOT := LongWord(@_Global_Offset_Table_); + Module.CodeSegStart := GetTextStart; + Module.CodeSegEnd := GetTextEnd; + InitializeModule; + RegisterPCMap; + _StartLib(Context, @Module, DLLProcEx); + asm + ADD ESP, 4 + end; +end; + +// InnerExitLib provides GOT fixup and global var addressing +function InnerExitLib(Context: PInitContext): Integer; +begin + Result := 0; + if ModuleIsPackage then + begin + UninitializeModule; + UnregisterPCMap; + end + else + _StartLib(Context, @Module, DLLProcEx); +end; + +function _ExitLib: Integer; cdecl; +asm +{$IFDEF DEBUG_STARTUP} + INT 3 +{$ENDIF} + PUSH EBP + MOV EBP,ESP + PUSH UNWINDFI_TOPOFSTACK + XOR EAX,EAX + PUSH DLL_PROCESS_DETACH // InitContext.DLLInitState + PUSH EDI + PUSH ESI + PUSH EBX + PUSH EBP + PUSH EAX // InitContext.Module + PUSH EAX // InitContext.InitCount + PUSH EAX // InitContext.InitTable (filled in later) + PUSH EAX // InitContext.OuterContext + MOV EAX,ESP + CALL InnerExitLib; + ADD ESP, 16 + POP EBP + POP EBX + POP ESI + POP EDI + MOV ESP,EBP + POP EBP +end; + +procedure _GetCallerEIP; +asm + MOV EBX, [ESP] +end; +{$ENDIF LINUX} + +{$IFDEF MSWINDOWS} +procedure _InitExe(InitTable: Pointer); +begin + TlsIndex := 0; + HInstance := GetModuleHandle(nil); + Module.Instance := HInstance; + Module.CodeInstance := 0; + Module.DataInstance := 0; + InitializeModule; + _StartExe(InitTable, @Module); +end; +{$ENDIF MSWINDOWS} +{$IFDEF LINUX} +procedure InitVmtImports; +var + P: ^Integer; +begin + P := @TypeImportsTable; + if P = nil then Exit; + while P^ <> 0 do + begin + P^ := Integer(dlsym(0, PChar(P^))); + Inc(P); + end; +end; + +procedure _InitExe(InitTable: Pointer; Argc: Integer; Argp: Pointer); export; +begin +{$IFDEF DEBUG_STARTUP} + asm + INT 3 + end; +{$ENDIF} + HInstance := GetThisModuleHandle; + Module.Instance := HInstance; + Module.InstanceVar := @HInstance; + Module.CodeInstance := 0; + Module.DataInstance := 0; + InitializeModule; + InitThreadTLS; +{$IFDEF PC_MAPPED_EXCEPTIONS} + RegisterPCMap(); +{$ENDIF} + InitVmtImports; + _StartExe(InitTable, @Module, Argc, Argp); +end; +{$ENDIF} + + +{$IFDEF LINUX} +var + InitAddr: Pointer; + +function _main(argc: Integer; argv: Pointer; envp: Pointer): Integer; export cdecl; +type + TInitFunction = function (argc: Integer; argv, envp: Pointer): Integer; cdecl; + TExternalInit = function (argc: Integer; argv, envp: Pointer; InitExe: TInitFunction): Integer; cdecl; +var + ExternalInit: TExternalInit; + InitFunc: TInitFunction; +begin + @ExternalInit := dlsym(GetThisModuleHandle, 'ExternalInit'); + @InitFunc := InitAddr; + System.envp := envp; + if @ExternalInit <> nil then + ExternalInit(argc, argv, envp, InitFunc); + Result := InitFunc(argc, argv, envp); +end; + +function __libc_start_main (Main: Pointer; Argc: Integer; Argv: Pointer; + Init, Fini, rtld_Fini: Pointer; StackEnd: Pointer) + : Integer; + cdecl; + external libcmodulename name '__libc_start_main'; + +{ Program entry point } +procedure _start; +asm +{$IFDEF DEBUG_STARTUP} + INT 3 +{$ENDIF} + { Mark outermost frame, suggested by ELF i386 ABI. } + xor ebp,ebp + + { Get data passed on stack } + pop eax { argc } + mov ecx,esp { argv } + + { Align stack } + and esp,0fffffff8h +{$IFDEF PC_MAPPED_EXCEPTIONS} + { Mark the top of the stack with a signature } + push UNWINDFI_TOPOFSTACK +{$ENDIF} + push ebp { padding } + push esp { crt1.o does this, don't know why } + push edx { function to be registered with + atexit(), passed by loader } + push offset @@ret { _fini dummy } + push offset @@ret { _init dummy } + push ecx { argv } + push eax { argc } + { We need a symbol for the Pascal entry point (main unit's + body). An external symbol `main' fixed up by the linker + would be fine. Alas, external declarations can't do that; + they must be resolved either in the same file with a $L + directive, or in a shared object. Hack: use a bogus, + distinctive symbol to mark the fixup, find and patch it + in the linker. } +{$IFDEF PIC} + call GetGOT + mov ebx, eax + add [esp+12],ebx + add [esp+8],ebx + // Linker will replace _GLOBAL_OFFSET_TABLE_ address with main program block + mov eax, offset _GLOBAL_OFFSET_TABLE_ + add eax, ebx + mov [ebx].InitAddr, eax + mov eax, offset _main + add eax, ebx + push eax +{$ELSE} + // Linker will replace _GLOBAL_OFFSET_TABLE_ address with main program block + push offset _GLOBAL_OFFSET_TABLE_ + pop InitAddr + push offset _main +{$ENDIF} + call __libc_start_main + hlt { they never come back } + +@@ret: +end; +{$ENDIF} + +{$IFDEF LINUX} +{ Procedure body not generated on Windows currently } +procedure OpenEdition; +begin +end; + +procedure GPLInfected; +begin +end; + +{$IFDEF TRIAL_EDITION} +procedure Evaluation; +begin +end; +{$ENDIF} + +procedure Copyright; +begin +end; + +const + sOpenEdition = 'This application was built with Borland Kylix Open Edition(tm).'; // do not localize + sGPLMessage = 'This module must be distributed under the terms of the GNU General ' // do not localize + + 'Public License (GPL), version 2. A copy of this license can be found at:' // do not localize + + 'http://www.borland.com/kylix/gpl.html.'; // do not localize + +exports +{$IF Declared(GPL)} + OpenEdition name sOpenEdition, + GPLInfected name sGPLMessage, +{$IFEND} +{$IFDEF TRIAL_EDITION} + Evaluation name 'This module was compiled with an evaluation version of Borland Delphi', // do not localize +{$ENDIF} + + Copyright name 'Portions Copyright (c) 1983,2002 Borland Software Corporation'; // do not localize + + +{$IF Declared(GPL)} +initialization + if IsConsole and not ModuleIsLib then + begin + TTextRec(Output).Mode := fmClosed; + writeln(sGPLMessage); + end; +{$IFEND} +{$ENDIF} +end. + diff --git a/System/D2006_orig/SysUtils.pas b/System/D2006_orig/SysUtils.pas new file mode 100644 index 0000000..4af1e2e --- /dev/null +++ b/System/D2006_orig/SysUtils.pas @@ -0,0 +1,17256 @@ +{ *********************************************************************** } +{ } +{ Delphi / Kylix Cross-Platform Runtime Library } +{ System Utilities Unit } +{ } +{ Copyright (c) 1995-2005 Borland Software Corporation } +{ } +{ Copyright and license exceptions noted in source } +{ } +{ *********************************************************************** } + +unit SysUtils; + +{$H+,B-} +{$WARN SYMBOL_PLATFORM OFF} +{$WARN UNSAFE_TYPE OFF} + +interface + +uses +{$IFDEF MSWINDOWS} +Windows, +{$ENDIF} +{$IFDEF LINUX} +Types, +Libc, +{$ENDIF} +SysConst; + +const +{ File open modes } + +{$IFDEF LINUX} + fmOpenRead = O_RDONLY; + fmOpenWrite = O_WRONLY; + fmOpenReadWrite = O_RDWR; +// fmShareCompat not supported + fmShareExclusive = $0010; + fmShareDenyWrite = $0020; +// fmShareDenyRead not supported + fmShareDenyNone = $0030; +{$ENDIF} +{$IFDEF MSWINDOWS} + fmOpenRead = $0000; + fmOpenWrite = $0001; + fmOpenReadWrite = $0002; + + fmShareCompat = $0000 platform; // DOS compatibility mode is not portable + fmShareExclusive = $0010; + fmShareDenyWrite = $0020; + fmShareDenyRead = $0030 platform; // write-only not supported on all platforms + fmShareDenyNone = $0040; +{$ENDIF} + +{ File attribute constants } + + faReadOnly = $00000001 platform; + faHidden = $00000002 platform; + faSysFile = $00000004 platform; + faVolumeID = $00000008 platform deprecated; // not used in Win32 + faDirectory = $00000010; + faArchive = $00000020 platform; + faSymLink = $00000040 platform; + faAnyFile = $0000003F; + +{ Units of time } + + HoursPerDay = 24; + MinsPerHour = 60; + SecsPerMin = 60; + MSecsPerSec = 1000; + MinsPerDay = HoursPerDay * MinsPerHour; + SecsPerDay = MinsPerDay * SecsPerMin; + MSecsPerDay = SecsPerDay * MSecsPerSec; + +{ Days between 1/1/0001 and 12/31/1899 } + + DateDelta = 693594; + +{ Days between TDateTime basis (12/31/1899) and Unix time_t basis (1/1/1970) } + + UnixDateDelta = 25569; + +type + +{ Standard Character set type } + + TSysCharSet = set of Char; + +{ Set access to an integer } + + TIntegerSet = set of 0..SizeOf(Integer) * 8 - 1; + +{ Type conversion records } + + WordRec = packed record + case Integer of + 0: (Lo, Hi: Byte); + 1: (Bytes: array [0..1] of Byte); + end; + + LongRec = packed record + case Integer of + 0: (Lo, Hi: Word); + 1: (Words: array [0..1] of Word); + 2: (Bytes: array [0..3] of Byte); + end; + + Int64Rec = packed record + case Integer of + 0: (Lo, Hi: Cardinal); + 1: (Cardinals: array [0..1] of Cardinal); + 2: (Words: array [0..3] of Word); + 3: (Bytes: array [0..7] of Byte); + end; + +{ General arrays } + + PByteArray = ^TByteArray; + TByteArray = array[0..32767] of Byte; + + PWordArray = ^TWordArray; + TWordArray = array[0..16383] of Word; + +{ Generic procedure pointer } + + TProcedure = procedure; + +{ Generic filename type } + + TFileName = type string; + +{ Search record used by FindFirst, FindNext, and FindClose } + + TSearchRec = record + Time: Integer; + Size: Int64; + Attr: Integer; + Name: TFileName; + ExcludeAttr: Integer; +{$IFDEF MSWINDOWS} + FindHandle: THandle platform; + FindData: TWin32FindData platform; +{$ENDIF} +{$IFDEF LINUX} + Mode: mode_t platform; + FindHandle: Pointer platform; + PathOnly: String platform; + Pattern: String platform; +{$ENDIF} + end; + +{ FloatToText, FloatToTextFmt, TextToFloat, and FloatToDecimal type codes } + + TFloatValue = (fvExtended, fvCurrency); + +{ FloatToText format codes } + + TFloatFormat = (ffGeneral, ffExponent, ffFixed, ffNumber, ffCurrency); + +{ FloatToDecimal result record } + + TFloatRec = packed record + Exponent: Smallint; + Negative: Boolean; + Digits: array[0..20] of Char; + end; + +{ Date and time record } + + TTimeStamp = record + Time: Integer; { Number of milliseconds since midnight } + Date: Integer; { One plus number of days since 1/1/0001 } + end; + +{ MultiByte Character Set (MBCS) byte type } + TMbcsByteType = (mbSingleByte, mbLeadByte, mbTrailByte); + +{ System Locale information record } + TSysLocale = packed record + DefaultLCID: Integer; + PriLangID: Integer; + SubLangID: Integer; + FarEast: Boolean; + MiddleEast: Boolean; + end; + +{$IFDEF MSWINDOWS} +{ This is used by TLanguages } + TLangRec = packed record + FName: string; + FLCID: LCID; + FExt: string; + end; + +{ This stores the languages that the system supports } + TLanguages = class + private + FSysLangs: array of TLangRec; + function LocalesCallback(LocaleID: PChar): Integer; stdcall; + function GetExt(Index: Integer): string; + function GetID(Index: Integer): string; + function GetLCID(Index: Integer): LCID; + function GetName(Index: Integer): string; + function GetNameFromLocaleID(ID: LCID): string; + function GetNameFromLCID(const ID: string): string; + function GetCount: integer; + public + constructor Create; + function IndexOf(ID: LCID): Integer; + property Count: Integer read GetCount; + property Name[Index: Integer]: string read GetName; + property NameFromLocaleID[ID: LCID]: string read GetNameFromLocaleID; + property NameFromLCID[const ID: string]: string read GetNameFromLCID; + property ID[Index: Integer]: string read GetID; + property LocaleID[Index: Integer]: LCID read GetLCID; + property Ext[Index: Integer]: string read GetExt; + end platform; +{$ENDIF} + +{$IFDEF LINUX} + TEraRange = record + StartDate : Integer; // whole days since 12/31/1899 (TDateTime basis) + EndDate : Integer; // whole days since 12/31/1899 (TDateTime basis) +// Direction : Char; + end; +{$ENDIF} + +{ Exceptions } + + Exception = class(TObject) + private + FMessage: string; + FHelpContext: Integer; + public + constructor Create(const Msg: string); + constructor CreateFmt(const Msg: string; const Args: array of const); + constructor CreateRes(Ident: Integer); overload; + constructor CreateRes(ResStringRec: PResStringRec); overload; + constructor CreateResFmt(Ident: Integer; const Args: array of const); overload; + constructor CreateResFmt(ResStringRec: PResStringRec; const Args: array of const); overload; + constructor CreateHelp(const Msg: string; AHelpContext: Integer); + constructor CreateFmtHelp(const Msg: string; const Args: array of const; + AHelpContext: Integer); + constructor CreateResHelp(Ident: Integer; AHelpContext: Integer); overload; + constructor CreateResHelp(ResStringRec: PResStringRec; AHelpContext: Integer); overload; + constructor CreateResFmtHelp(ResStringRec: PResStringRec; const Args: array of const; + AHelpContext: Integer); overload; + constructor CreateResFmtHelp(Ident: Integer; const Args: array of const; + AHelpContext: Integer); overload; + property HelpContext: Integer read FHelpContext write FHelpContext; + property Message: string read FMessage write FMessage; + end; + + ExceptClass = class of Exception; + + EAbort = class(Exception); + + EHeapException = class(Exception) + private + AllowFree: Boolean; + public + procedure FreeInstance; override; + end; + + EOutOfMemory = class(EHeapException); + + EInOutError = class(Exception) + public + ErrorCode: Integer; + end; + +{$IFDEF MSWINDOWS} + PExceptionRecord = ^TExceptionRecord; + TExceptionRecord = record + ExceptionCode: Cardinal; + ExceptionFlags: Cardinal; + ExceptionRecord: PExceptionRecord; + ExceptionAddress: Pointer; + NumberParameters: Cardinal; + ExceptionInformation: array[0..14] of Cardinal; + end; +{$ENDIF} + + EExternal = class(Exception) + public +{$IFDEF MSWINDOWS} + ExceptionRecord: PExceptionRecord platform; +{$ENDIF} +{$IFDEF LINUX} + ExceptionAddress: LongWord platform; + AccessAddress: LongWord platform; + SignalNumber: Integer platform; +{$ENDIF} + end; + + EExternalException = class(EExternal); + + EIntError = class(EExternal); + EDivByZero = class(EIntError); + ERangeError = class(EIntError); + EIntOverflow = class(EIntError); + + EMathError = class(EExternal); + EInvalidOp = class(EMathError); + EZeroDivide = class(EMathError); + EOverflow = class(EMathError); + EUnderflow = class(EMathError); + + EInvalidPointer = class(EHeapException); + + EInvalidCast = class(Exception); + + EConvertError = class(Exception); + + EAccessViolation = class(EExternal); + EPrivilege = class(EExternal); + EStackOverflow = class(EExternal) + end deprecated; + EControlC = class(EExternal); +{$IFDEF LINUX} + EQuit = class(EExternal) end platform; +{$ENDIF} + +{$IFDEF LINUX} + ECodesetConversion = class(Exception) end platform; +{$ENDIF} + + EVariantError = class(Exception); + + EPropReadOnly = class(Exception); + EPropWriteOnly = class(Exception); + + EAssertionFailed = class(Exception); + +{$IFNDEF PC_MAPPED_EXCEPTIONS} + EAbstractError = class(Exception) end platform; +{$ENDIF} + + EIntfCastError = class(Exception); + + EInvalidContainer = class(Exception); + EInvalidInsert = class(Exception); + + EPackageError = class(Exception); + + EOSError = class(Exception) + public + ErrorCode: DWORD; + end; +{$IFDEF MSWINDOWS} + EWin32Error = class(EOSError) + end deprecated; +{$ENDIF} + + ESafecallException = class(Exception); + +{$IFDEF LINUX} + +{ + Signals + + External exceptions, or signals, are, by default, converted to language + exceptions by the Delphi RTL. Under Linux, a Delphi application installs + signal handlers to trap the raw signals, and convert them. Delphi libraries + do not install handlers by default. So if you are implementing a standalone + library, such as an Apache DSO, and you want to have signals converted to + language exceptions that you can catch, you must install signal hooks + manually, using the interfaces that the Delphi RTL provides. + + For most libraries, installing signal handlers is pretty + straightforward. Call HookSignal(RTL_SIGDEFAULT) at initialization time, + and UnhookSignal(RTL_SIGNALDEFAULT) at shutdown. This will install handlers + for a set of signals that the RTL normally hooks for Delphi applications. + + There are some cases where the above initialization will not work properly: + The proper behaviour for setting up signal handlers is to set + a signal handler, and then later restore the signal handler to its previous + state when you clean up. If you have two libraries lib1 and lib2, and lib1 + installs a signal handler, and then lib2 installs a signal handler, those + libraries have to uninstall in the proper order if they restore signal + handlers, or the signal handlers can be left in an inconsistent and + potentially fatal state. Not all libraries behave well with respect to + installing signal handlers. To hedge against this possibility, and allow + you to manage signal handlers better in the face of whatever behaviour + you may find in external libraries, we provide a set of four interfaces to + allow you to tailor the Delphi signal handler hooking/unhooking in the + event of an emergency. These are: + InquireSignal + AbandonSignalHandler + HookSignal + UnhookSignal + + InquireSignal allows you to look at the state of a signal handler, so + that you can find out if someone grabbed it out from under you. + + AbandonSignalHandler tells the RTL never to unhook a particular + signal handler. This can be used if you find a case where it would + be unsafe to return to the previous state of signal handling. For + example, if the previous signal handler was installed by a library + which has since been unloaded. + + HookSignal/UnhookSignal setup signal handlers that map certain signals + into language exceptions. + + See additional notes at InquireSignal, et al, below. +} + +const + RTL_SIGINT = 0; // User interrupt (SIGINT) + RTL_SIGFPE = 1; // Floating point exception (SIGFPE) + RTL_SIGSEGV = 2; // Segmentation violation (SIGSEGV) + RTL_SIGILL = 3; // Illegal instruction (SIGILL) + RTL_SIGBUS = 4; // Bus error (SIGBUS) + RTL_SIGQUIT = 5; // User interrupt (SIGQUIT) + RTL_SIGLAST = RTL_SIGQUIT; // Used internally. Don't use this. + RTL_SIGDEFAULT = -1; // Means all of a set of signals that the we capture + // normally. This is currently all of the preceding + // signals. You cannot pass this to InquireSignal. + +type + { TSignalState is the state of a given signal handler, as returned by + InquireSignal. See InquireSignal, below. + } + TSignalState = (ssNotHooked, ssHooked, ssOverridden); + +var + + { + If DeferUserInterrupts is set, we do not raise either SIGINT or SIGQUIT as + an exception, instead, we set SIGINTIssued or SIGQUITIssued when the + signal arrives, and swallow the signal where the OS issued it. This gives + GUI applications the chance to defer the actual handling of the signal + until a time when it is safe to do so. + } + + DeferUserInterrupts: Boolean; + SIGINTIssued: Boolean; + SIGQUITIssued: Boolean; +{$ENDIF} + +{$IFDEF LINUX} +const + MAX_PATH = 4095; // From /usr/include/linux/limits.h PATH_MAX +{$ENDIF} + +var + +{ Empty string and null string pointer. These constants are provided for + backwards compatibility only. } + + EmptyStr: string = ''; + NullStr: PString = @EmptyStr; + + EmptyWideStr: WideString = ''; + NullWideStr: PWideString = @EmptyWideStr; + +{$IFDEF MSWINDOWS} +{ Win32 platform identifier. This will be one of the following values: + + VER_PLATFORM_WIN32s + VER_PLATFORM_WIN32_WINDOWS + VER_PLATFORM_WIN32_NT + + See WINDOWS.PAS for the numerical values. } + + Win32Platform: Integer = 0; + +{ Win32 OS version information - + + see TOSVersionInfo.dwMajorVersion/dwMinorVersion/dwBuildNumber } + + Win32MajorVersion: Integer = 0; + Win32MinorVersion: Integer = 0; + Win32BuildNumber: Integer = 0; + +{ Win32 OS extra version info string - + + see TOSVersionInfo.szCSDVersion } + + Win32CSDVersion: string = ''; + +{ Win32 OS version tester } + +function CheckWin32Version(AMajor: Integer; AMinor: Integer = 0): Boolean; + +{ GetFileVersion returns the most significant 32 bits of a file's binary + version number. Typically, this includes the major and minor version placed + together in one 32-bit integer. It generally does not include the release + or build numbers. It returns Cardinal(-1) if it failed. } +function GetFileVersion(const AFileName: string): Cardinal; + +{$ENDIF} + +{ Currency and date/time formatting options + + The initial values of these variables are fetched from the system registry + using the GetLocaleInfo function in the Win32 API. The description of each + variable specifies the LOCALE_XXXX constant used to fetch the initial + value. + + CurrencyString - Defines the currency symbol used in floating-point to + decimal conversions. The initial value is fetched from LOCALE_SCURRENCY. + + CurrencyFormat - Defines the currency symbol placement and separation + used in floating-point to decimal conversions. Possible values are: + + 0 = '$1' + 1 = '1$' + 2 = '$ 1' + 3 = '1 $' + + The initial value is fetched from LOCALE_ICURRENCY. + + NegCurrFormat - Defines the currency format for used in floating-point to + decimal conversions of negative numbers. Possible values are: + + 0 = '($1)' 4 = '(1$)' 8 = '-1 $' 12 = '$ -1' + 1 = '-$1' 5 = '-1$' 9 = '-$ 1' 13 = '1- $' + 2 = '$-1' 6 = '1-$' 10 = '1 $-' 14 = '($ 1)' + 3 = '$1-' 7 = '1$-' 11 = '$ 1-' 15 = '(1 $)' + + The initial value is fetched from LOCALE_INEGCURR. + + ThousandSeparator - The character used to separate thousands in numbers + with more than three digits to the left of the decimal separator. The + initial value is fetched from LOCALE_STHOUSAND. A value of #0 indicates + no thousand separator character should be output even if the format string + specifies thousand separators. + + DecimalSeparator - The character used to separate the integer part from + the fractional part of a number. The initial value is fetched from + LOCALE_SDECIMAL. DecimalSeparator must be a non-zero value. + + CurrencyDecimals - The number of digits to the right of the decimal point + in a currency amount. The initial value is fetched from LOCALE_ICURRDIGITS. + + DateSeparator - The character used to separate the year, month, and day + parts of a date value. The initial value is fetched from LOCATE_SDATE. + + ShortDateFormat - The format string used to convert a date value to a + short string suitable for editing. For a complete description of date and + time format strings, refer to the documentation for the FormatDate + function. The short date format should only use the date separator + character and the m, mm, d, dd, yy, and yyyy format specifiers. The + initial value is fetched from LOCALE_SSHORTDATE. + + LongDateFormat - The format string used to convert a date value to a long + string suitable for display but not for editing. For a complete description + of date and time format strings, refer to the documentation for the + FormatDate function. The initial value is fetched from LOCALE_SLONGDATE. + + TimeSeparator - The character used to separate the hour, minute, and + second parts of a time value. The initial value is fetched from + LOCALE_STIME. + + TimeAMString - The suffix string used for time values between 00:00 and + 11:59 in 12-hour clock format. The initial value is fetched from + LOCALE_S1159. + + TimePMString - The suffix string used for time values between 12:00 and + 23:59 in 12-hour clock format. The initial value is fetched from + LOCALE_S2359. + + ShortTimeFormat - The format string used to convert a time value to a + short string with only hours and minutes. The default value is computed + from LOCALE_ITIME and LOCALE_ITLZERO. + + LongTimeFormat - The format string used to convert a time value to a long + string with hours, minutes, and seconds. The default value is computed + from LOCALE_ITIME and LOCALE_ITLZERO. + + ShortMonthNames - Array of strings containing short month names. The mmm + format specifier in a format string passed to FormatDate causes a short + month name to be substituted. The default values are fecthed from the + LOCALE_SABBREVMONTHNAME system locale entries. + + LongMonthNames - Array of strings containing long month names. The mmmm + format specifier in a format string passed to FormatDate causes a long + month name to be substituted. The default values are fecthed from the + LOCALE_SMONTHNAME system locale entries. + + ShortDayNames - Array of strings containing short day names. The ddd + format specifier in a format string passed to FormatDate causes a short + day name to be substituted. The default values are fecthed from the + LOCALE_SABBREVDAYNAME system locale entries. + + LongDayNames - Array of strings containing long day names. The dddd + format specifier in a format string passed to FormatDate causes a long + day name to be substituted. The default values are fecthed from the + LOCALE_SDAYNAME system locale entries. + + ListSeparator - The character used to separate items in a list. The + initial value is fetched from LOCALE_SLIST. + + TwoDigitYearCenturyWindow - Determines what century is added to two + digit years when converting string dates to numeric dates. This value + is subtracted from the current year before extracting the century. + This can be used to extend the lifetime of existing applications that + are inextricably tied to 2 digit year data entry. The best solution + to Year 2000 (Y2k) issues is not to accept 2 digit years at all - require + 4 digit years in data entry to eliminate century ambiguities. + + Examples: + + Current TwoDigitCenturyWindow Century StrToDate() of: + Year Value Pivot '01/01/03' '01/01/68' '01/01/50' + ------------------------------------------------------------------------- + 1998 0 1900 1903 1968 1950 + 2002 0 2000 2003 2068 2050 + 1998 50 (default) 1948 2003 1968 1950 + 2002 50 (default) 1952 2003 1968 2050 + 2020 50 (default) 1970 2003 2068 2050 + } + +var + CurrencyString: string; + CurrencyFormat: Byte; + NegCurrFormat: Byte; + ThousandSeparator: Char; + DecimalSeparator: Char; + CurrencyDecimals: Byte; + DateSeparator: Char; + ShortDateFormat: string; + LongDateFormat: string; + TimeSeparator: Char; + TimeAMString: string; + TimePMString: string; + ShortTimeFormat: string; + LongTimeFormat: string; + ShortMonthNames: array[1..12] of string; + LongMonthNames: array[1..12] of string; + ShortDayNames: array[1..7] of string; + LongDayNames: array[1..7] of string; + SysLocale: TSysLocale; + TwoDigitYearCenturyWindow: Word = 50; + ListSeparator: Char; + + +{ Thread safe currency and date/time formatting + + The TFormatSettings record is designed to allow thread safe formatting, + equivalent to the gloabal variables described above. Each of the + formatting routines that use the gloabal variables have overloaded + equivalents, requiring an additional parameter of type TFormatSettings. + + A TFormatSettings record must be populated before use. This can be done + using the GetLocaleFormatSettings function, which will populate the + record with values based on the given locale (using the Win32 API + function GetLocaleInfo). Note that some format specifiers still require + specific thread locale settings (such as period/era names). +} + +type + TFormatSettings = record + CurrencyFormat: Byte; + NegCurrFormat: Byte; + ThousandSeparator: Char; + DecimalSeparator: Char; + CurrencyDecimals: Byte; + DateSeparator: Char; + TimeSeparator: Char; + ListSeparator: Char; + CurrencyString: string; + ShortDateFormat: string; + LongDateFormat: string; + TimeAMString: string; + TimePMString: string; + ShortTimeFormat: string; + LongTimeFormat: string; + ShortMonthNames: array[1..12] of string; + LongMonthNames: array[1..12] of string; + ShortDayNames: array[1..7] of string; + LongDayNames: array[1..7] of string; + TwoDigitYearCenturyWindow: Word; + end; + + TLocaleOptions = (loInvariantLocale, loUserLocale); + +const + MaxEraCount = 7; + +var + EraNames: array [1..MaxEraCount] of string; + EraYearOffsets: array [1..MaxEraCount] of Integer; +{$IFDEF LINUX} + EraRanges : array [1..MaxEraCount] of TEraRange platform; + EraYearFormats: array [1..MaxEraCount] of string platform; + EraCount: Byte platform; +{$ENDIF} + +const + PathDelim = {$IFDEF MSWINDOWS} '\'; {$ELSE} '/'; {$ENDIF} + DriveDelim = {$IFDEF MSWINDOWS} ':'; {$ELSE} ''; {$ENDIF} + PathSep = {$IFDEF MSWINDOWS} ';'; {$ELSE} ':'; {$ENDIF} + +{$IFDEF MSWINDOWS} +function Languages: TLanguages; +{$ENDIF} + +{ Exit procedure handling } + +{ AddExitProc adds the given procedure to the run-time library's exit + procedure list. When an application terminates, its exit procedures are + executed in reverse order of definition, i.e. the last procedure passed + to AddExitProc is the first one to get executed upon termination. } + +procedure AddExitProc(Proc: TProcedure); + +{ String handling routines } + +{ NewStr allocates a string on the heap. NewStr is provided for backwards + compatibility only. } + +function NewStr(const S: string): PString; deprecated; + +{ DisposeStr disposes a string pointer that was previously allocated using + NewStr. DisposeStr is provided for backwards compatibility only. } + +procedure DisposeStr(P: PString); deprecated; + +{ AssignStr assigns a new dynamically allocated string to the given string + pointer. AssignStr is provided for backwards compatibility only. } + +procedure AssignStr(var P: PString; const S: string); deprecated; + +{ AppendStr appends S to the end of Dest. AppendStr is provided for + backwards compatibility only. Use "Dest := Dest + S" instead. } + +procedure AppendStr(var Dest: string; const S: string); deprecated; + +{ UpperCase converts all ASCII characters in the given string to upper case. + The conversion affects only 7-bit ASCII characters between 'a' and 'z'. To + convert 8-bit international characters, use AnsiUpperCase. } + +function UpperCase(const S: string): string; overload; +function UpperCase(const S: string; LocaleOptions: TLocaleOptions): string; overload; inline; + +{ LowerCase converts all ASCII characters in the given string to lower case. + The conversion affects only 7-bit ASCII characters between 'A' and 'Z'. To + convert 8-bit international characters, use AnsiLowerCase. } + +function LowerCase(const S: string): string; overload; +function LowerCase(const S: string; LocaleOptions: TLocaleOptions): string; overload; inline; + +{ CompareStr compares S1 to S2, with case-sensitivity. The return value is + less than 0 if S1 < S2, 0 if S1 = S2, or greater than 0 if S1 > S2. The + compare operation is based on the 8-bit ordinal value of each character + and is not affected by the current user locale. } + +function CompareStr(const S1, S2: string): Integer; overload; +function CompareStr(const S1, S2: string; LocaleOptions: TLocaleOptions): Integer; overload; + +{ SameStr compares S1 to S2, with case-sensitivity. Returns true if + S1 and S2 are the equal, that is, if CompareStr would return 0. } + +function SameStr(const S1, S2: string): Boolean; overload; +function SameStr(const S1, S2: string; LocaleOptions: TLocaleOptions): Boolean; overload; + +{ CompareMem performs a binary compare of Length bytes of memory referenced + by P1 to that of P2. CompareMem returns True if the memory referenced by + P1 is identical to that of P2. } + +function CompareMem(P1, P2: Pointer; Length: Integer): Boolean; assembler; + +{ CompareText compares S1 to S2, without case-sensitivity. The return value + is the same as for CompareStr. The compare operation is based on the 8-bit + ordinal value of each character, after converting 'a'..'z' to 'A'..'Z', + and is not affected by the current user locale. } + +function CompareText(const S1, S2: string): Integer; overload; +function CompareText(const S1, S2: string; LocaleOptions: TLocaleOptions): Integer; overload; + +{ SameText compares S1 to S2, without case-sensitivity. Returns true if + S1 and S2 are the equal, that is, if CompareText would return 0. SameText + has the same 8-bit limitations as CompareText } + +function SameText(const S1, S2: string): Boolean; overload; +function SameText(const S1, S2: string; LocaleOptions: TLocaleOptions): Boolean; overload; + +{ AnsiUpperCase converts all characters in the given string to upper case. + The conversion uses the current user locale. } + +function AnsiUpperCase(const S: string): string; + +{ AnsiLowerCase converts all characters in the given string to lower case. + The conversion uses the current user locale. } + +function AnsiLowerCase(const S: string): string; + +{ AnsiCompareStr compares S1 to S2, with case-sensitivity. The compare + operation is controlled by the current user locale. The return value + is the same as for CompareStr. } + +function AnsiCompareStr(const S1, S2: string): Integer; inline; + +{ AnsiSameStr compares S1 to S2, with case-sensitivity. The compare + operation is controlled by the current user locale. The return value + is True if AnsiCompareStr would have returned 0. } + +function AnsiSameStr(const S1, S2: string): Boolean; inline; + +{ AnsiCompareText compares S1 to S2, without case-sensitivity. The compare + operation is controlled by the current user locale. The return value + is the same as for CompareStr. } + +function AnsiCompareText(const S1, S2: string): Integer; inline; + +{ AnsiSameText compares S1 to S2, without case-sensitivity. The compare + operation is controlled by the current user locale. The return value + is True if AnsiCompareText would have returned 0. } + +function AnsiSameText(const S1, S2: string): Boolean; inline; + +{ AnsiStrComp compares S1 to S2, with case-sensitivity. The compare + operation is controlled by the current user locale. The return value + is the same as for CompareStr. } + +function AnsiStrComp(S1, S2: PChar): Integer; inline; + +{ AnsiStrIComp compares S1 to S2, without case-sensitivity. The compare + operation is controlled by the current user locale. The return value + is the same as for CompareStr. } + +function AnsiStrIComp(S1, S2: PChar): Integer; inline; + +{ AnsiStrLComp compares S1 to S2, with case-sensitivity, up to a maximum + length of MaxLen bytes. The compare operation is controlled by the + current user locale. The return value is the same as for CompareStr. } + +function AnsiStrLComp(S1, S2: PChar; MaxLen: Cardinal): Integer; + +{ AnsiStrLIComp compares S1 to S2, without case-sensitivity, up to a maximum + length of MaxLen bytes. The compare operation is controlled by the + current user locale. The return value is the same as for CompareStr. } + +function AnsiStrLIComp(S1, S2: PChar; MaxLen: Cardinal): Integer; + +{ AnsiStrLower converts all characters in the given string to lower case. + The conversion uses the current user locale. } + +function AnsiStrLower(Str: PChar): PChar; + +{ AnsiStrUpper converts all characters in the given string to upper case. + The conversion uses the current user locale. } + +function AnsiStrUpper(Str: PChar): PChar; + +{ AnsiLastChar returns a pointer to the last full character in the string. + This function supports multibyte characters } + +function AnsiLastChar(const S: string): PChar; + +{ AnsiStrLastChar returns a pointer to the last full character in the string. + This function supports multibyte characters. } + +function AnsiStrLastChar(P: PChar): PChar; + +{ WideUpperCase converts all characters in the given string to upper case. } + +function WideUpperCase(const S: WideString): WideString; + +{ WideLowerCase converts all characters in the given string to lower case. } + +function WideLowerCase(const S: WideString): WideString; + +{ WideCompareStr compares S1 to S2, with case-sensitivity. The return value + is the same as for CompareStr. } + +function WideCompareStr(const S1, S2: WideString): Integer; + +{ WideSameStr compares S1 to S2, with case-sensitivity. The return value + is True if WideCompareStr would have returned 0. } + +function WideSameStr(const S1, S2: WideString): Boolean; inline; + +{ WideCompareText compares S1 to S2, without case-sensitivity. The return value + is the same as for CompareStr. } + +function WideCompareText(const S1, S2: WideString): Integer; + +{ WideSameText compares S1 to S2, without case-sensitivity. The return value + is True if WideCompareText would have returned 0. } + +function WideSameText(const S1, S2: WideString): Boolean; inline; + +{ Trim trims leading and trailing spaces and control characters from the + given string. } + +function Trim(const S: string): string; overload; +function Trim(const S: WideString): WideString; overload; + +{ TrimLeft trims leading spaces and control characters from the given + string. } + +function TrimLeft(const S: string): string; overload; +function TrimLeft(const S: WideString): WideString; overload; + +{ TrimRight trims trailing spaces and control characters from the given + string. } + +function TrimRight(const S: string): string; overload; +function TrimRight(const S: WideString): WideString; overload; + +{ QuotedStr returns the given string as a quoted string. A single quote + character is inserted at the beginning and the end of the string, and + for each single quote character in the string, another one is added. } + +function QuotedStr(const S: string): string; + +{ AnsiQuotedStr returns the given string as a quoted string, using the + provided Quote character. A Quote character is inserted at the beginning + and end of the string, and each Quote character in the string is doubled. + This function supports multibyte character strings (MBCS). } + +function AnsiQuotedStr(const S: string; Quote: Char): string; + +{ AnsiExtractQuotedStr removes the Quote characters from the beginning and end + of a quoted string, and reduces pairs of Quote characters within the quoted + string to a single character. If the first character in Src is not the Quote + character, the function returns an empty string. The function copies + characters from the Src to the result string until the second solitary + Quote character or the first null character in Src. The Src parameter is + updated to point to the first character following the quoted string. If + the Src string does not contain a matching end Quote character, the Src + parameter is updated to point to the terminating null character in Src. + This function supports multibyte character strings (MBCS). } + +function AnsiExtractQuotedStr(var Src: PChar; Quote: Char): string; + +{ AnsiDequotedStr is a simplified version of AnsiExtractQuotedStr } + +function AnsiDequotedStr(const S: string; AQuote: Char): string; + +{ AdjustLineBreaks adjusts all line breaks in the given string to the + indicated style. + When Style is tlbsCRLF, the function changes all + CR characters not followed by LF and all LF characters not preceded + by a CR into CR/LF pairs. + When Style is tlbsLF, the function changes all CR/LF pairs and CR characters + not followed by LF to LF characters. } + +function AdjustLineBreaks(const S: string; Style: TTextLineBreakStyle = + {$IFDEF LINUX} tlbsLF {$ENDIF} + {$IFDEF MSWINDOWS} tlbsCRLF {$ENDIF}): string; + +{ IsValidIdent returns true if the given string is a valid identifier. An + identifier is defined as a character from the set ['A'..'Z', 'a'..'z', '_'] + followed by zero or more characters from the set ['A'..'Z', 'a'..'z', + '0..'9', '_']. With DotNet code we need to allow dots in the names.} + +function IsValidIdent(const Ident: string; AllowDots: Boolean = False): Boolean; + +{ IntToStr converts the given value to its decimal string representation. } + +function IntToStr(Value: Integer): string; overload; +function IntToStr(Value: Int64): string; overload; + +{ IntToHex converts the given value to a hexadecimal string representation + with the minimum number of digits specified. } + +function IntToHex(Value: Integer; Digits: Integer): string; overload; +function IntToHex(Value: Int64; Digits: Integer): string; overload; + +{ StrToInt converts the given string to an integer value. If the string + doesn't contain a valid value, an EConvertError exception is raised. } + +function StrToInt(const S: string): Integer; +function StrToIntDef(const S: string; Default: Integer): Integer; +function TryStrToInt(const S: string; out Value: Integer): Boolean; + +{ Similar to the above functions but for Int64 instead } + +function StrToInt64(const S: string): Int64; +function StrToInt64Def(const S: string; const Default: Int64): Int64; +function TryStrToInt64(const S: string; out Value: Int64): Boolean; + +{ StrToBool converts the given string to a boolean value. If the string + doesn't contain a valid value, an EConvertError exception is raised. + BoolToStr converts boolean to a string value that in turn can be converted + back into a boolean. BoolToStr will always pick the first element of + the TrueStrs/FalseStrs arrays. } + +var + TrueBoolStrs: array of String; + FalseBoolStrs: array of String; + +const + DefaultTrueBoolStr = 'True'; // DO NOT LOCALIZE + DefaultFalseBoolStr = 'False'; // DO NOT LOCALIZE + +function StrToBool(const S: string): Boolean; +function StrToBoolDef(const S: string; const Default: Boolean): Boolean; +function TryStrToBool(const S: string; out Value: Boolean): Boolean; + +function BoolToStr(B: Boolean; UseBoolStrs: Boolean = False): string; + +{ LoadStr loads the string resource given by Ident from the application's + executable file or associated resource module. If the string resource + does not exist, LoadStr returns an empty string. } + +function LoadStr(Ident: Integer): string; + +{ FmtLoadStr loads the string resource given by Ident from the application's + executable file or associated resource module, and uses it as the format + string in a call to the Format function with the given arguments. } + +function FmtLoadStr(Ident: Integer; const Args: array of const): string; + +{ File management routines } + +{ FileOpen opens the specified file using the specified access mode. The + access mode value is constructed by OR-ing one of the fmOpenXXXX constants + with one of the fmShareXXXX constants. If the return value is positive, + the function was successful and the value is the file handle of the opened + file. A return value of -1 indicates that an error occurred. } + +function FileOpen(const FileName: string; Mode: LongWord): Integer; + +{ FileCreate creates a new file by the specified name. If the return value + is positive, the function was successful and the value is the file handle + of the new file. A return value of -1 indicates that an error occurred. + On Linux, this calls FileCreate(FileName, DEFFILEMODE) to create + the file with read and write access for the current user only. } + +function FileCreate(const FileName: string): Integer; overload; inline; + +{ This second version of FileCreate lets you specify the access rights to put on the newly + created file. The access rights parameter is ignored on Win32 } + +function FileCreate(const FileName: string; Rights: Integer): Integer; overload; inline; + +{ FileRead reads Count bytes from the file given by Handle into the buffer + specified by Buffer. The return value is the number of bytes actually + read; it is less than Count if the end of the file was reached. The return + value is -1 if an error occurred. } + +function FileRead(Handle: Integer; var Buffer; Count: LongWord): Integer; + +{ FileWrite writes Count bytes to the file given by Handle from the buffer + specified by Buffer. The return value is the number of bytes actually + written, or -1 if an error occurred. } + +function FileWrite(Handle: Integer; const Buffer; Count: LongWord): Integer; + +{ FileSeek changes the current position of the file given by Handle to be + Offset bytes relative to the point given by Origin. Origin = 0 means that + Offset is relative to the beginning of the file, Origin = 1 means that + Offset is relative to the current position, and Origin = 2 means that + Offset is relative to the end of the file. The return value is the new + current position, relative to the beginning of the file, or -1 if an error + occurred. } + +function FileSeek(Handle, Offset, Origin: Integer): Integer; overload; +function FileSeek(Handle: Integer; const Offset: Int64; Origin: Integer): Int64; overload; + +{ FileClose closes the specified file. } + +procedure FileClose(Handle: Integer); inline; + +{ FileAge returns the date-and-time stamp of the specified file. The return + value can be converted to a TDateTime value using the FileDateToDateTime + function. The return value is -1 if the file does not exist. This version + does not support date-and-time stamps prior to 1980 and after 2107. } + +function FileAge(const FileName: string): Integer; overload; deprecated; + +{ FileAge retrieves the date-and-time stamp of the specified file as a + TDateTime. This version supports all valid NTFS date-and-time stamps + and returns a boolean value that indicates whether the specified + file exists. } + +{$IFDEF MSWINDOWS} +function FileAge(const FileName: string; out FileDateTime: TDateTime): Boolean; overload; +{$ENDIF} + +{ FileExists returns a boolean value that indicates whether the specified + file exists. } + +function FileExists(const FileName: string): Boolean; + +{ DirectoryExists returns a boolean value that indicates whether the + specified directory exists (and is actually a directory) } + +function DirectoryExists(const Directory: string): Boolean; + +{ ForceDirectories ensures that all the directories in a specific path exist. + Any portion that does not already exist will be created. Function result + indicates success of the operation. The function can fail if the current + user does not have sufficient file access rights to create directories in + the given path. } + +function ForceDirectories(Dir: string): Boolean; + +{ FindFirst searches the directory given by Path for the first entry that + matches the filename given by Path and the attributes given by Attr. The + result is returned in the search record given by SearchRec. The return + value is zero if the function was successful. Otherwise the return value + is a system error code. After calling FindFirst, always call FindClose. + FindFirst is typically used with FindNext and FindClose as follows: + + Result := FindFirst(Path, Attr, SearchRec); + while Result = 0 do + begin + ProcessSearchRec(SearchRec); + Result := FindNext(SearchRec); + end; + FindClose(SearchRec); + + where ProcessSearchRec represents user-defined code that processes the + information in a search record. } + +function FindFirst(const Path: string; Attr: Integer; + var F: TSearchRec): Integer; + +{ FindNext returs the next entry that matches the name and attributes + specified in a previous call to FindFirst. The search record must be one + that was passed to FindFirst. The return value is zero if the function was + successful. Otherwise the return value is a system error code. } + +function FindNext(var F: TSearchRec): Integer; + +{ FindClose terminates a FindFirst/FindNext sequence and frees memory and system + resources allocated by FindFirst. + Every FindFirst/FindNext must end with a call to FindClose. } + +procedure FindClose(var F: TSearchRec); + +{ FileGetDate returns the OS date-and-time stamp of the file given by + Handle. The return value is -1 if the handle is invalid. The + FileDateToDateTime function can be used to convert the returned value to + a TDateTime value. } + +function FileGetDate(Handle: Integer): Integer; + +{ FileSetDate sets the OS date-and-time stamp of the file given by FileName + to the value given by Age. The DateTimeToFileDate function can be used to + convert a TDateTime value to an OS date-and-time stamp. The return value + is zero if the function was successful. Otherwise the return value is a + system error code. } + +function FileSetDate(const FileName: string; Age: Integer): Integer; overload; + +{$IFDEF MSWINDOWS} +{ FileSetDate by handle is not available on Unix platforms because there + is no standard way to set a file's modification time using only a file + handle, and no standard way to obtain the file name of an open + file handle. } + +function FileSetDate(Handle: Integer; Age: Integer): Integer; overload; platform; + +{ FileGetAttr returns the file attributes of the file given by FileName. The + attributes can be examined by AND-ing with the faXXXX constants defined + above. A return value of -1 indicates that an error occurred. } + +function FileGetAttr(const FileName: string): Integer; platform; + +{ FileSetAttr sets the file attributes of the file given by FileName to the + value given by Attr. The attribute value is formed by OR-ing the + appropriate faXXXX constants. The return value is zero if the function was + successful. Otherwise the return value is a system error code. } + +function FileSetAttr(const FileName: string; Attr: Integer): Integer; platform; +{$ENDIF} + +{ FileIsReadOnly tests whether a given file is read-only for the current + process and effective user id. If the file does not exist, the + function returns False. (Check FileExists before calling FileIsReadOnly) + This function is platform portable. } + +function FileIsReadOnly(const FileName: string): Boolean; inline; + +{ FileSetReadOnly sets the read only state of a file. The file must + exist and the current effective user id must be the owner of the file. + On Unix systems, FileSetReadOnly attempts to set or remove + all three (user, group, and other) write permissions on the file. + If you want to grant partial permissions (writeable for owner but not + for others), use platform specific functions such as chmod. + The function returns True if the file was successfully modified, + False if there was an error. This function is platform portable. } + +function FileSetReadOnly(const FileName: string; ReadOnly: Boolean): Boolean; + +{ DeleteFile deletes the file given by FileName. The return value is True if + the file was successfully deleted, or False if an error occurred. } + +function DeleteFile(const FileName: string): Boolean; inline; + +{ RenameFile renames the file given by OldName to the name given by NewName. + The return value is True if the file was successfully renamed, or False if + an error occurred. } + +function RenameFile(const OldName, NewName: string): Boolean; inline; + +{ IsAssembly returns a boolean value that indicates whether the specified + file is a .NET assembly. } + +function IsAssembly(const FileName: string): Boolean; + +{ ChangeFileExt changes the extension of a filename. FileName specifies a + filename with or without an extension, and Extension specifies the new + extension for the filename. The new extension can be a an empty string or + a period followed by up to three characters. } + +function ChangeFileExt(const FileName, Extension: string): string; + +{ ChangeFilePath changes the path of a filename. FileName specifies a + filename with or without an extension, and Path specifies the new + path for the filename. The new path is not required to contain the trailing + path delimiter. } + +function ChangeFilePath(const FileName, Path: string): string; + +{ ExtractFilePath extracts the drive and directory parts of the given + filename. The resulting string is the leftmost characters of FileName, + up to and including the colon or backslash that separates the path + information from the name and extension. The resulting string is empty + if FileName contains no drive and directory parts. } + +function ExtractFilePath(const FileName: string): string; + +{ ExtractFileDir extracts the drive and directory parts of the given + filename. The resulting string is a directory name suitable for passing + to SetCurrentDir, CreateDir, etc. The resulting string is empty if + FileName contains no drive and directory parts. } + +function ExtractFileDir(const FileName: string): string; + +{ ExtractFileDrive extracts the drive part of the given filename. For + filenames with drive letters, the resulting string is ':'. + For filenames with a UNC path, the resulting string is in the form + '\\\'. If the given path contains neither + style of filename, the result is an empty string. } + +function ExtractFileDrive(const FileName: string): string; + +{ ExtractFileName extracts the name and extension parts of the given + filename. The resulting string is the leftmost characters of FileName, + starting with the first character after the colon or backslash that + separates the path information from the name and extension. The resulting + string is equal to FileName if FileName contains no drive and directory + parts. } + +function ExtractFileName(const FileName: string): string; + +{ ExtractFileExt extracts the extension part of the given filename. The + resulting string includes the period character that separates the name + and extension parts. The resulting string is empty if the given filename + has no extension. } + +function ExtractFileExt(const FileName: string): string; + +{ ExpandFileName expands the given filename to a fully qualified filename. + The resulting string consists of a drive letter, a colon, a root relative + directory path, and a filename. Embedded '.' and '..' directory references + are removed. } + +function ExpandFileName(const FileName: string): string; + +{ ExpandFilenameCase returns a fully qualified filename like ExpandFilename, + but performs a case-insensitive filename search looking for a close match + in the actual file system, differing only in uppercase versus lowercase of + the letters. This is useful to convert lazy user input into useable file + names, or to convert filename data created on a case-insensitive file + system (Win32) to something useable on a case-sensitive file system (Linux). + + The MatchFound out parameter indicates what kind of match was found in the + file system, and what the function result is based upon: + + ( in order of increasing difficulty or complexity ) + mkExactMatch: Case-sensitive match. Result := ExpandFileName(FileName). + mkSingleMatch: Exactly one file in the given directory path matches the + given filename on a case-insensitive basis. + Result := ExpandFileName(FileName as found in file system). + mkAmbiguous: More than one file in the given directory path matches the + given filename case-insensitively. + In many cases, this should be considered an error. + Result := ExpandFileName(First matching filename found). + mkNone: File not found at all. Result := ExpandFileName(FileName). + + Note that because this function has to search the file system it may be + much slower than ExpandFileName, particularly when the given filename is + ambiguous or does not exist. Use ExpandFilenameCase only when you have + a filename of dubious orgin - such as from user input - and you want + to make a best guess before failing. } + +type + TFilenameCaseMatch = (mkNone, mkExactMatch, mkSingleMatch, mkAmbiguous); + +function ExpandFileNameCase(const FileName: string; + out MatchFound: TFilenameCaseMatch): string; + +{ ExpandUNCFileName expands the given filename to a fully qualified filename. + This function is the same as ExpandFileName except that it will return the + drive portion of the filename in the format '\\\ if + that drive is actually a network resource instead of a local resource. + Like ExpandFileName, embedded '.' and '..' directory references are + removed. } + +function ExpandUNCFileName(const FileName: string): string; + +{ ExtractRelativePath will return a file path name relative to the given + BaseName. It strips the common path dirs and adds '..\' on Windows, + and '../' on Linux for each level up from the BaseName path. } + +function ExtractRelativePath(const BaseName, DestName: string): string; + +{$IFDEF MSWINDOWS} +{ ExtractShortPathName will convert the given filename to the short form + by calling the GetShortPathName API. Will return an empty string if + the file or directory specified does not exist } + +function ExtractShortPathName(const FileName: string): string; +{$ENDIF} + +{ FileSearch searches for the file given by Name in the list of directories + given by DirList. The directory paths in DirList must be separated by + PathSep chars. The search always starts with the current directory of the + current drive. The returned value is a concatenation of one of the + directory paths and the filename, or an empty string if the file could not + be located. } + +function FileSearch(const Name, DirList: string): string; + +{$IFDEF MSWINDOWS} +{ DiskFree returns the number of free bytes on the specified drive number, + where 0 = Current, 1 = A, 2 = B, etc. DiskFree returns -1 if the drive + number is invalid. } + +function DiskFree(Drive: Byte): Int64; + +{ DiskSize returns the size in bytes of the specified drive number, where + 0 = Current, 1 = A, 2 = B, etc. DiskSize returns -1 if the drive number + is invalid. } + +function DiskSize(Drive: Byte): Int64; +{$ENDIF} + +{ FileDateToDateTime converts an OS date-and-time value to a TDateTime + value. The FileAge, FileGetDate, and FileSetDate routines operate on OS + date-and-time values, and the Time field of a TSearchRec used by the + FindFirst and FindNext functions contains an OS date-and-time value. } + +function FileDateToDateTime(FileDate: Integer): TDateTime; + +{ DateTimeToFileDate converts a TDateTime value to an OS date-and-time + value. The FileAge, FileGetDate, and FileSetDate routines operate on OS + date-and-time values, and the Time field of a TSearchRec used by the + FindFirst and FindNext functions contains an OS date-and-time value. } + +function DateTimeToFileDate(DateTime: TDateTime): Integer; + +{ GetCurrentDir returns the current directory. } + +function GetCurrentDir: string; + +{ SetCurrentDir sets the current directory. The return value is True if + the current directory was successfully changed, or False if an error + occurred. } + +function SetCurrentDir(const Dir: string): Boolean; + +{ CreateDir creates a new directory. The return value is True if a new + directory was successfully created, or False if an error occurred. } + +function CreateDir(const Dir: string): Boolean; + +{ RemoveDir deletes an existing empty directory. The return value is + True if the directory was successfully deleted, or False if an error + occurred. } + +function RemoveDir(const Dir: string): Boolean; + +{ PChar routines } +{ const params help simplify C++ code. No effect on pascal code } + +{ StrLen returns the number of characters in Str, not counting the null + terminator. } + +function StrLen(const Str: PChar): Cardinal; + +{ StrEnd returns a pointer to the null character that terminates Str. } + +function StrEnd(const Str: PChar): PChar; + +{ StrMove copies exactly Count characters from Source to Dest and returns + Dest. Source and Dest may overlap. } + +function StrMove(Dest: PChar; const Source: PChar; Count: Cardinal): PChar; + +{ StrCopy copies Source to Dest and returns Dest. } + +function StrCopy(Dest: PChar; const Source: PChar): PChar; + +{ StrECopy copies Source to Dest and returns StrEnd(Dest). } + +function StrECopy(Dest:PChar; const Source: PChar): PChar; + +{ StrLCopy copies at most MaxLen characters from Source to Dest and + returns Dest. } + +function StrLCopy(Dest: PChar; const Source: PChar; MaxLen: Cardinal): PChar; + +{ StrPCopy copies the Pascal style string Source into Dest and + returns Dest. } + +function StrPCopy(Dest: PChar; const Source: string): PChar; + +{ StrPLCopy copies at most MaxLen characters from the Pascal style string + Source into Dest and returns Dest. } + +function StrPLCopy(Dest: PChar; const Source: string; + MaxLen: Cardinal): PChar; + +{ StrCat appends a copy of Source to the end of Dest and returns Dest. } + +function StrCat(Dest: PChar; const Source: PChar): PChar; + +{ StrLCat appends at most MaxLen - StrLen(Dest) characters from Source to + the end of Dest, and returns Dest. } + +function StrLCat(Dest: PChar; const Source: PChar; MaxLen: Cardinal): PChar; + +{ StrComp compares Str1 to Str2. The return value is less than 0 if + Str1 < Str2, 0 if Str1 = Str2, or greater than 0 if Str1 > Str2. } + +function StrComp(const Str1, Str2: PChar): Integer; + +{ StrIComp compares Str1 to Str2, without case sensitivity. The return + value is the same as StrComp. } + +function StrIComp(const Str1, Str2: PChar): Integer; + +{ StrLComp compares Str1 to Str2, for a maximum length of MaxLen + characters. The return value is the same as StrComp. } + +function StrLComp(const Str1, Str2: PChar; MaxLen: Cardinal): Integer; + +{ StrLIComp compares Str1 to Str2, for a maximum length of MaxLen + characters, without case sensitivity. The return value is the same + as StrComp. } + +function StrLIComp(const Str1, Str2: PChar; MaxLen: Cardinal): Integer; + +{ StrScan returns a pointer to the first occurrence of Chr in Str. If Chr + does not occur in Str, StrScan returns NIL. The null terminator is + considered to be part of the string. } + +function StrScan(const Str: PChar; Chr: Char): PChar; + +{ StrRScan returns a pointer to the last occurrence of Chr in Str. If Chr + does not occur in Str, StrRScan returns NIL. The null terminator is + considered to be part of the string. } + +function StrRScan(const Str: PChar; Chr: Char): PChar; + +{ StrPos returns a pointer to the first occurrence of Str2 in Str1. If + Str2 does not occur in Str1, StrPos returns NIL. } + +function StrPos(const Str1, Str2: PChar): PChar; + +{ StrUpper converts Str to upper case and returns Str. } + +function StrUpper(Str: PChar): PChar; + +{ StrLower converts Str to lower case and returns Str. } + +function StrLower(Str: PChar): PChar; + +{ StrPas converts Str to a Pascal style string. This function is provided + for backwards compatibility only. To convert a null terminated string to + a Pascal style string, use a string type cast or an assignment. } + +function StrPas(const Str: PChar): string; + +{ StrAlloc allocates a buffer of the given size on the heap. The size of + the allocated buffer is encoded in a four byte header that immediately + preceeds the buffer. To dispose the buffer, use StrDispose. } + +function StrAlloc(Size: Cardinal): PChar; + +{ StrBufSize returns the allocated size of the given buffer, not including + the two byte header. } + +function StrBufSize(const Str: PChar): Cardinal; + +{ StrNew allocates a copy of Str on the heap. If Str is NIL, StrNew returns + NIL and doesn't allocate any heap space. Otherwise, StrNew makes a + duplicate of Str, obtaining space with a call to the StrAlloc function, + and returns a pointer to the duplicated string. To dispose the string, + use StrDispose. } + +function StrNew(const Str: PChar): PChar; + +{ StrDispose disposes a string that was previously allocated with StrAlloc + or StrNew. If Str is NIL, StrDispose does nothing. } + +procedure StrDispose(Str: PChar); + +{ String formatting routines } + +{ The Format routine formats the argument list given by the Args parameter + using the format string given by the Format parameter. + + Format strings contain two types of objects--plain characters and format + specifiers. Plain characters are copied verbatim to the resulting string. + Format specifiers fetch arguments from the argument list and apply + formatting to them. + + Format specifiers have the following form: + + "%" [index ":"] ["-"] [width] ["." prec] type + + A format specifier begins with a % character. After the % come the + following, in this order: + + - an optional argument index specifier, [index ":"] + - an optional left-justification indicator, ["-"] + - an optional width specifier, [width] + - an optional precision specifier, ["." prec] + - the conversion type character, type + + The following conversion characters are supported: + + d Decimal. The argument must be an integer value. The value is converted + to a string of decimal digits. If the format string contains a precision + specifier, it indicates that the resulting string must contain at least + the specified number of digits; if the value has less digits, the + resulting string is left-padded with zeros. + + u Unsigned decimal. Similar to 'd' but no sign is output. + + e Scientific. The argument must be a floating-point value. The value is + converted to a string of the form "-d.ddd...E+ddd". The resulting + string starts with a minus sign if the number is negative, and one digit + always precedes the decimal point. The total number of digits in the + resulting string (including the one before the decimal point) is given + by the precision specifer in the format string--a default precision of + 15 is assumed if no precision specifer is present. The "E" exponent + character in the resulting string is always followed by a plus or minus + sign and at least three digits. + + f Fixed. The argument must be a floating-point value. The value is + converted to a string of the form "-ddd.ddd...". The resulting string + starts with a minus sign if the number is negative. The number of digits + after the decimal point is given by the precision specifier in the + format string--a default of 2 decimal digits is assumed if no precision + specifier is present. + + g General. The argument must be a floating-point value. The value is + converted to the shortest possible decimal string using fixed or + scientific format. The number of significant digits in the resulting + string is given by the precision specifier in the format string--a + default precision of 15 is assumed if no precision specifier is present. + Trailing zeros are removed from the resulting string, and a decimal + point appears only if necessary. The resulting string uses fixed point + format if the number of digits to the left of the decimal point in the + value is less than or equal to the specified precision, and if the + value is greater than or equal to 0.00001. Otherwise the resulting + string uses scientific format. + + n Number. The argument must be a floating-point value. The value is + converted to a string of the form "-d,ddd,ddd.ddd...". The "n" format + corresponds to the "f" format, except that the resulting string + contains thousand separators. + + m Money. The argument must be a floating-point value. The value is + converted to a string that represents a currency amount. The conversion + is controlled by the CurrencyString, CurrencyFormat, NegCurrFormat, + ThousandSeparator, DecimalSeparator, and CurrencyDecimals global + variables, all of which are initialized from locale settings provided + by the operating system. For example, Currency Format preferences can be + set in the International section of the Windows Control Panel. If the format + string contains a precision specifier, it overrides the value given + by the CurrencyDecimals global variable. + + p Pointer. The argument must be a pointer value. The value is converted + to a string of the form "XXXX:YYYY" where XXXX and YYYY are the + segment and offset parts of the pointer expressed as four hexadecimal + digits. + + s String. The argument must be a character, a string, or a PChar value. + The string or character is inserted in place of the format specifier. + The precision specifier, if present in the format string, specifies the + maximum length of the resulting string. If the argument is a string + that is longer than this maximum, the string is truncated. + + x Hexadecimal. The argument must be an integer value. The value is + converted to a string of hexadecimal digits. If the format string + contains a precision specifier, it indicates that the resulting string + must contain at least the specified number of digits; if the value has + less digits, the resulting string is left-padded with zeros. + + Conversion characters may be specified in upper case as well as in lower + case--both produce the same results. + + For all floating-point formats, the actual characters used as decimal and + thousand separators are obtained from the DecimalSeparator and + ThousandSeparator global variables. + + Index, width, and precision specifiers can be specified directly using + decimal digit string (for example "%10d"), or indirectly using an asterisk + charcater (for example "%*.*f"). When using an asterisk, the next argument + in the argument list (which must be an integer value) becomes the value + that is actually used. For example "Format('%*.*f', [8, 2, 123.456])" is + the same as "Format('%8.2f', [123.456])". + + A width specifier sets the minimum field width for a conversion. If the + resulting string is shorter than the minimum field width, it is padded + with blanks to increase the field width. The default is to right-justify + the result by adding blanks in front of the value, but if the format + specifier contains a left-justification indicator (a "-" character + preceding the width specifier), the result is left-justified by adding + blanks after the value. + + An index specifier sets the current argument list index to the specified + value. The index of the first argument in the argument list is 0. Using + index specifiers, it is possible to format the same argument multiple + times. For example "Format('%d %d %0:d %d', [10, 20])" produces the string + '10 20 10 20'. + + The Format function can be combined with other formatting functions. For + example + + S := Format('Your total was %s on %s', [ + FormatFloat('$#,##0.00;;zero', Total), + FormatDateTime('mm/dd/yy', Date)]); + + which uses the FormatFloat and FormatDateTime functions to customize the + format beyond what is possible with Format. + + Each of the string formatting routines that uses global variables for + formatting (separators, decimals, date/time formats etc.), has an + overloaded equivalent requiring a parameter of type TFormatSettings. This + additional parameter provides the formatting information rather than the + global variables. For more information see the notes at TFormatSettings. } + +function Format(const Format: string; + const Args: array of const): string; overload; +function Format(const Format: string; const Args: array of const; + const FormatSettings: TFormatSettings): string; overload; + +{ FmtStr formats the argument list given by Args using the format string + given by Format into the string variable given by Result. For further + details, see the description of the Format function. } + +procedure FmtStr(var Result: string; const Format: string; + const Args: array of const); overload; +procedure FmtStr(var Result: string; const Format: string; + const Args: array of const; const FormatSettings: TFormatSettings); overload; + +{ StrFmt formats the argument list given by Args using the format string + given by Format into the buffer given by Buffer. It is up to the caller to + ensure that Buffer is large enough for the resulting string. The returned + value is Buffer. For further details, see the description of the Format + function. } + +function StrFmt(Buffer, Format: PChar; + const Args: array of const): PChar; overload; +function StrFmt(Buffer, Format: PChar; const Args: array of const; + const FormatSettings: TFormatSettings): PChar; overload; + +{ StrLFmt formats the argument list given by Args using the format string + given by Format into the buffer given by Buffer. The resulting string will + contain no more than MaxBufLen characters, not including the null terminator. + The returned value is Buffer. For further details, see the description of + the Format function. } + +function StrLFmt(Buffer: PChar; MaxBufLen: Cardinal; Format: PChar; + const Args: array of const): PChar; overload; +function StrLFmt(Buffer: PChar; MaxBufLen: Cardinal; Format: PChar; + const Args: array of const; + const FormatSettings: TFormatSettings): PChar; overload; + +{ FormatBuf formats the argument list given by Args using the format string + given by Format and FmtLen into the buffer given by Buffer and BufLen. + The Format parameter is a reference to a buffer containing FmtLen + characters, and the Buffer parameter is a reference to a buffer of BufLen + characters. The returned value is the number of characters actually stored + in Buffer. The returned value is always less than or equal to BufLen. For + further details, see the description of the Format function. } + +function FormatBuf(var Buffer; BufLen: Cardinal; const Format; + FmtLen: Cardinal; const Args: array of const): Cardinal; overload; +function FormatBuf(var Buffer; BufLen: Cardinal; const Format; + FmtLen: Cardinal; const Args: array of const; + const FormatSettings: TFormatSettings): Cardinal; overload; + +{ The WideFormat routine formats the argument list given by the Args parameter + using the format WideString given by the Format parameter. This routine is + the WideString equivalent of Format. For further details, see the description + of the Format function. } +function WideFormat(const Format: WideString; + const Args: array of const): WideString; overload; +function WideFormat(const Format: WideString; + const Args: array of const; + const FormatSettings: TFormatSettings): WideString; overload; + +{ WideFmtStr formats the argument list given by Args using the format WideString + given by Format into the WideString variable given by Result. For further + details, see the description of the Format function. } +procedure WideFmtStr(var Result: WideString; const Format: WideString; + const Args: array of const); overload; +procedure WideFmtStr(var Result: WideString; const Format: WideString; + const Args: array of const; const FormatSettings: TFormatSettings); overload; + +{ WideFormatBuf formats the argument list given by Args using the format string + given by Format and FmtLen into the buffer given by Buffer and BufLen. + The Format parameter is a reference to a buffer containing FmtLen + UNICODE characters (WideChar), and the Buffer parameter is a reference to a + buffer of BufLen UNICODE characters (WideChar). The return value is the number + of UNICODE characters actually stored in Buffer. The return value is always + less than or equal to BufLen. For further details, see the description of the + Format function. + + Important: BufLen, FmtLen and the return result are always the number of + UNICODE characters, *not* the number of bytes. To calculate the number of bytes + multiply them by SizeOf(WideChar). } +function WideFormatBuf(var Buffer; BufLen: Cardinal; const Format; + FmtLen: Cardinal; const Args: array of const): Cardinal; overload; +function WideFormatBuf(var Buffer; BufLen: Cardinal; const Format; + FmtLen: Cardinal; const Args: array of const; + const FormatSettings: TFormatSettings): Cardinal; overload; + +{ Floating point conversion routines } + +{ Each of the floating point conversion routines that uses global variables + for formatting (separators, decimals, etc.), has an overloaded equivalent + requiring a parameter of type TFormatSettings. This additional parameter + provides the formatting information rather than the global variables. For + more information see the notes at TFormatSettings. } + +{ FloatToStr converts the floating-point value given by Value to its string + representation. The conversion uses general number format with 15 + significant digits. For further details, see the description of the + FloatToStrF function. } + +function FloatToStr(Value: Extended): string; overload; +function FloatToStr(Value: Extended; + const FormatSettings: TFormatSettings): string; overload; + +{ CurrToStr converts the currency value given by Value to its string + representation. The conversion uses general number format. For further + details, see the description of the CurrToStrF function. } + +function CurrToStr(Value: Currency): string; overload; +function CurrToStr(Value: Currency; + const FormatSettings: TFormatSettings): string; overload; + +{ FloatToCurr will range validate a value to make sure it falls + within the acceptable currency range } + +const + MinCurrency: Currency = -922337203685477.5807 {$IFDEF LINUX} + 1 {$ENDIF}; //!! overflow? + MaxCurrency: Currency = 922337203685477.5807 {$IFDEF LINUX} - 1 {$ENDIF}; //!! overflow? + +function FloatToCurr(const Value: Extended): Currency; +function TryFloatToCurr(const Value: Extended; out AResult: Currency): Boolean; + +{ FloatToStrF converts the floating-point value given by Value to its string + representation. The Format parameter controls the format of the resulting + string. The Precision parameter specifies the precision of the given value. + It should be 7 or less for values of type Single, 15 or less for values of + type Double, and 18 or less for values of type Extended. The meaning of the + Digits parameter depends on the particular format selected. + + The possible values of the Format parameter, and the meaning of each, are + described below. + + ffGeneral - General number format. The value is converted to the shortest + possible decimal string using fixed or scientific format. Trailing zeros + are removed from the resulting string, and a decimal point appears only + if necessary. The resulting string uses fixed point format if the number + of digits to the left of the decimal point in the value is less than or + equal to the specified precision, and if the value is greater than or + equal to 0.00001. Otherwise the resulting string uses scientific format, + and the Digits parameter specifies the minimum number of digits in the + exponent (between 0 and 4). + + ffExponent - Scientific format. The value is converted to a string of the + form "-d.ddd...E+dddd". The resulting string starts with a minus sign if + the number is negative, and one digit always precedes the decimal point. + The total number of digits in the resulting string (including the one + before the decimal point) is given by the Precision parameter. The "E" + exponent character in the resulting string is always followed by a plus + or minus sign and up to four digits. The Digits parameter specifies the + minimum number of digits in the exponent (between 0 and 4). + + ffFixed - Fixed point format. The value is converted to a string of the + form "-ddd.ddd...". The resulting string starts with a minus sign if the + number is negative, and at least one digit always precedes the decimal + point. The number of digits after the decimal point is given by the Digits + parameter--it must be between 0 and 18. If the number of digits to the + left of the decimal point is greater than the specified precision, the + resulting value will use scientific format. + + ffNumber - Number format. The value is converted to a string of the form + "-d,ddd,ddd.ddd...". The ffNumber format corresponds to the ffFixed format, + except that the resulting string contains thousand separators. + + ffCurrency - Currency format. The value is converted to a string that + represents a currency amount. The conversion is controlled by the + CurrencyString, CurrencyFormat, NegCurrFormat, ThousandSeparator, and + DecimalSeparator global variables, all of which are initialized from + locale settings provided by the operating system. For example, + Currency Format preferences can be set in the International section + of the Windows Control Panel. + The number of digits after the decimal point is given by the Digits + parameter--it must be between 0 and 18. + + For all formats, the actual characters used as decimal and thousand + separators are obtained from the DecimalSeparator and ThousandSeparator + global variables. + + If the given value is a NAN (not-a-number), the resulting string is 'NAN'. + If the given value is positive infinity, the resulting string is 'INF'. If + the given value is negative infinity, the resulting string is '-INF'. } + +function FloatToStrF(Value: Extended; Format: TFloatFormat; + Precision, Digits: Integer): string; overload; +function FloatToStrF(Value: Extended; Format: TFloatFormat; + Precision, Digits: Integer; + const FormatSettings: TFormatSettings): string; overload; + +{ CurrToStrF converts the currency value given by Value to its string + representation. A call to CurrToStrF corresponds to a call to + FloatToStrF with an implied precision of 19 digits. } + +function CurrToStrF(Value: Currency; Format: TFloatFormat; + Digits: Integer): string; overload; +function CurrToStrF(Value: Currency; Format: TFloatFormat; + Digits: Integer; const FormatSettings: TFormatSettings): string; overload; + +{ FloatToText converts the given floating-point value to its decimal + representation using the specified format, precision, and digits. The + Value parameter must be a variable of type Extended or Currency, as + indicated by the ValueType parameter. The resulting string of characters + is stored in the given buffer, and the returned value is the number of + characters stored. The resulting string is not null-terminated. For + further details, see the description of the FloatToStrF function. } + +function FloatToText(BufferArg: PChar; const Value; ValueType: TFloatValue; + Format: TFloatFormat; Precision, Digits: Integer): Integer; overload; +function FloatToText(BufferArg: PChar; const Value; ValueType: TFloatValue; + Format: TFloatFormat; Precision, Digits: Integer; + const FormatSettings: TFormatSettings): Integer; overload; + +{ FormatFloat formats the floating-point value given by Value using the + format string given by Format. The following format specifiers are + supported in the format string: + + 0 Digit placeholder. If the value being formatted has a digit in the + position where the '0' appears in the format string, then that digit + is copied to the output string. Otherwise, a '0' is stored in that + position in the output string. + + # Digit placeholder. If the value being formatted has a digit in the + position where the '#' appears in the format string, then that digit + is copied to the output string. Otherwise, nothing is stored in that + position in the output string. + + . Decimal point. The first '.' character in the format string + determines the location of the decimal separator in the formatted + value; any additional '.' characters are ignored. The actual + character used as a the decimal separator in the output string is + determined by the DecimalSeparator global variable, which is initialized + from locale settings obtained from the operating system. + + , Thousand separator. If the format string contains one or more ',' + characters, the output will have thousand separators inserted between + each group of three digits to the left of the decimal point. The + placement and number of ',' characters in the format string does not + affect the output, except to indicate that thousand separators are + wanted. The actual character used as a the thousand separator in the + output is determined by the ThousandSeparator global variable, which + is initialized from locale settings obtained from the operating system. + + E+ Scientific notation. If any of the strings 'E+', 'E-', 'e+', or 'e-' + E- are contained in the format string, the number is formatted using + e+ scientific notation. A group of up to four '0' characters can + e- immediately follow the 'E+', 'E-', 'e+', or 'e-' to determine the + minimum number of digits in the exponent. The 'E+' and 'e+' formats + cause a plus sign to be output for positive exponents and a minus + sign to be output for negative exponents. The 'E-' and 'e-' formats + output a sign character only for negative exponents. + + 'xx' Characters enclosed in single or double quotes are output as-is, and + "xx" do not affect formatting. + + ; Separates sections for positive, negative, and zero numbers in the + format string. + + The locations of the leftmost '0' before the decimal point in the format + string and the rightmost '0' after the decimal point in the format string + determine the range of digits that are always present in the output string. + + The number being formatted is always rounded to as many decimal places as + there are digit placeholders ('0' or '#') to the right of the decimal + point. If the format string contains no decimal point, the value being + formatted is rounded to the nearest whole number. + + If the number being formatted has more digits to the left of the decimal + separator than there are digit placeholders to the left of the '.' + character in the format string, the extra digits are output before the + first digit placeholder. + + To allow different formats for positive, negative, and zero values, the + format string can contain between one and three sections separated by + semicolons. + + One section - The format string applies to all values. + + Two sections - The first section applies to positive values and zeros, and + the second section applies to negative values. + + Three sections - The first section applies to positive values, the second + applies to negative values, and the third applies to zeros. + + If the section for negative values or the section for zero values is empty, + that is if there is nothing between the semicolons that delimit the + section, the section for positive values is used instead. + + If the section for positive values is empty, or if the entire format string + is empty, the value is formatted using general floating-point formatting + with 15 significant digits, corresponding to a call to FloatToStrF with + the ffGeneral format. General floating-point formatting is also used if + the value has more than 18 digits to the left of the decimal point and + the format string does not specify scientific notation. + + The table below shows some sample formats and the results produced when + the formats are applied to different values: + + Format string 1234 -1234 0.5 0 + ----------------------------------------------------------------------- + 1234 -1234 0.5 0 + 0 1234 -1234 1 0 + 0.00 1234.00 -1234.00 0.50 0.00 + #.## 1234 -1234 .5 + #,##0.00 1,234.00 -1,234.00 0.50 0.00 + #,##0.00;(#,##0.00) 1,234.00 (1,234.00) 0.50 0.00 + #,##0.00;;Zero 1,234.00 -1,234.00 0.50 Zero + 0.000E+00 1.234E+03 -1.234E+03 5.000E-01 0.000E+00 + #.###E-0 1.234E3 -1.234E3 5E-1 0E0 + ----------------------------------------------------------------------- } + +function FormatFloat(const Format: string; Value: Extended): string; overload; +function FormatFloat(const Format: string; Value: Extended; + const FormatSettings: TFormatSettings): string; overload; + +{ FormatCurr formats the currency value given by Value using the format + string given by Format. For further details, see the description of the + FormatFloat function. } + +function FormatCurr(const Format: string; Value: Currency): string; overload; +function FormatCurr(const Format: string; Value: Currency; + const FormatSettings: TFormatSettings): string; overload; + +{ FloatToTextFmt converts the given floating-point value to its decimal + representation using the specified format. The Value parameter must be a + variable of type Extended or Currency, as indicated by the ValueType + parameter. The resulting string of characters is stored in the given + buffer, and the returned value is the number of characters stored. The + resulting string is not null-terminated. For further details, see the + description of the FormatFloat function. } + +function FloatToTextFmt(Buf: PChar; const Value; ValueType: TFloatValue; + Format: PChar): Integer; overload; +function FloatToTextFmt(Buf: PChar; const Value; ValueType: TFloatValue; + Format: PChar; const FormatSettings: TFormatSettings): Integer; overload; + +{ StrToFloat converts the given string to a floating-point value. The string + must consist of an optional sign (+ or -), a string of digits with an + optional decimal point, and an optional 'E' or 'e' followed by a signed + integer. Leading and trailing blanks in the string are ignored. The + DecimalSeparator global variable defines the character that must be used + as a decimal point. Thousand separators and currency symbols are not + allowed in the string. If the string doesn't contain a valid value, an + EConvertError exception is raised. } + +function StrToFloat(const S: string): Extended; overload; +function StrToFloat(const S: string; + const FormatSettings: TFormatSettings): Extended; overload; + +function StrToFloatDef(const S: string; + const Default: Extended): Extended; overload; +function StrToFloatDef(const S: string; const Default: Extended; + const FormatSettings: TFormatSettings): Extended; overload; + +function TryStrToFloat(const S: string; out Value: Extended): Boolean; overload; +function TryStrToFloat(const S: string; out Value: Extended; + const FormatSettings: TFormatSettings): Boolean; overload; + +function TryStrToFloat(const S: string; out Value: Double): Boolean; overload; +function TryStrToFloat(const S: string; out Value: Double; + const FormatSettings: TFormatSettings): Boolean; overload; + +function TryStrToFloat(const S: string; out Value: Single): Boolean; overload; +function TryStrToFloat(const S: string; out Value: Single; + const FormatSettings: TFormatSettings): Boolean; overload; + +{ StrToCurr converts the given string to a currency value. For further + details, see the description of the StrToFloat function. } + +function StrToCurr(const S: string): Currency; overload; +function StrToCurr(const S: string; + const FormatSettings: TFormatSettings): Currency; overload; + +function StrToCurrDef(const S: string; + const Default: Currency): Currency; overload; +function StrToCurrDef(const S: string; const Default: Currency; + const FormatSettings: TFormatSettings): Currency; overload; + +function TryStrToCurr(const S: string; out Value: Currency): Boolean; overload; +function TryStrToCurr(const S: string; out Value: Currency; + const FormatSettings: TFormatSettings): Boolean; overload; + +{ TextToFloat converts the null-terminated string given by Buffer to a + floating-point value which is returned in the variable given by Value. + The Value parameter must be a variable of type Extended or Currency, as + indicated by the ValueType parameter. The return value is True if the + conversion was successful, or False if the string is not a valid + floating-point value. For further details, see the description of the + StrToFloat function. } + +function TextToFloat(Buffer: PChar; var Value; + ValueType: TFloatValue): Boolean; overload; +function TextToFloat(Buffer: PChar; var Value; ValueType: TFloatValue; + const FormatSettings: TFormatSettings): Boolean; overload; + +{ FloatToDecimal converts a floating-point value to a decimal representation + that is suited for further formatting. The Value parameter must be a + variable of type Extended or Currency, as indicated by the ValueType + parameter. For values of type Extended, the Precision parameter specifies + the requested number of significant digits in the result--the allowed range + is 1..18. For values of type Currency, the Precision parameter is ignored, + and the implied precision of the conversion is 19 digits. The Decimals + parameter specifies the requested maximum number of digits to the left of + the decimal point in the result. Precision and Decimals together control + how the result is rounded. To produce a result that always has a given + number of significant digits regardless of the magnitude of the number, + specify 9999 for the Decimals parameter. The result of the conversion is + stored in the specified TFloatRec record as follows: + + Exponent - Contains the magnitude of the number, i.e. the number of + significant digits to the right of the decimal point. The Exponent field + is negative if the absolute value of the number is less than one. If the + number is a NAN (not-a-number), Exponent is set to -32768. If the number + is INF or -INF (positive or negative infinity), Exponent is set to 32767. + + Negative - True if the number is negative, False if the number is zero + or positive. + + Digits - Contains up to 18 (for type Extended) or 19 (for type Currency) + significant digits followed by a null terminator. The implied decimal + point (if any) is not stored in Digits. Trailing zeros are removed, and + if the resulting number is zero, NAN, or INF, Digits contains nothing but + the null terminator. } + +procedure FloatToDecimal(var Result: TFloatRec; const Value; + ValueType: TFloatValue; Precision, Decimals: Integer); + +{ Date/time support routines } + +function DateTimeToTimeStamp(DateTime: TDateTime): TTimeStamp; + +function TimeStampToDateTime(const TimeStamp: TTimeStamp): TDateTime; +function MSecsToTimeStamp(MSecs: Comp): TTimeStamp; +function TimeStampToMSecs(const TimeStamp: TTimeStamp): Comp; + +{ EncodeDate encodes the given year, month, and day into a TDateTime value. + The year must be between 1 and 9999, the month must be between 1 and 12, + and the day must be between 1 and N, where N is the number of days in the + specified month. If the specified values are not within range, an + EConvertError exception is raised. The resulting value is the number of + days between 12/30/1899 and the given date. } + +function EncodeDate(Year, Month, Day: Word): TDateTime; + +{ EncodeTime encodes the given hour, minute, second, and millisecond into a + TDateTime value. The hour must be between 0 and 23, the minute must be + between 0 and 59, the second must be between 0 and 59, and the millisecond + must be between 0 and 999. If the specified values are not within range, an + EConvertError exception is raised. The resulting value is a number between + 0 (inclusive) and 1 (not inclusive) that indicates the fractional part of + a day given by the specified time. The value 0 corresponds to midnight, + 0.5 corresponds to noon, 0.75 corresponds to 6:00 pm, etc. } + +function EncodeTime(Hour, Min, Sec, MSec: Word): TDateTime; + +{ Instead of generating errors the following variations of EncodeDate and + EncodeTime simply return False if the parameters given are not valid. + Other than that, these functions are functionally the same as the above + functions. } + +function TryEncodeDate(Year, Month, Day: Word; out Date: TDateTime): Boolean; +function TryEncodeTime(Hour, Min, Sec, MSec: Word; out Time: TDateTime): Boolean; + +{ DecodeDate decodes the integral (date) part of the given TDateTime value + into its corresponding year, month, and day. If the given TDateTime value + is less than or equal to zero, the year, month, and day return parameters + are all set to zero. } + +procedure DecodeDate(const DateTime: TDateTime; var Year, Month, Day: Word); + +{ This variation of DecodeDate works similarly to the above function but + returns more information. The result value of this function indicates + whether the year decoded is a leap year or not. } + +function DecodeDateFully(const DateTime: TDateTime; var Year, Month, Day, + DOW: Word): Boolean; + +{$IFDEF LINUX} +function InternalDecodeDate(const DateTime: TDateTime; var Year, Month, Day, DOW: Word): Boolean; +{$ENDIF} + +{ DecodeTime decodes the fractional (time) part of the given TDateTime value + into its corresponding hour, minute, second, and millisecond. } + +procedure DecodeTime(const DateTime: TDateTime; var Hour, Min, Sec, MSec: Word); + +{$IFDEF MSWINDOWS} +{ DateTimeToSystemTime converts a date and time from Delphi's TDateTime + format into the Win32 API's TSystemTime format. } + +procedure DateTimeToSystemTime(const DateTime: TDateTime; var SystemTime: TSystemTime); + +{ SystemTimeToDateTime converts a date and time from the Win32 API's + TSystemTime format into Delphi's TDateTime format. } + +function SystemTimeToDateTime(const SystemTime: TSystemTime): TDateTime; +{$ENDIF} + +{ DayOfWeek returns the day of the week of the given date. The result is an + integer between 1 and 7, corresponding to Sunday through Saturday. + This function is not ISO 8601 compliant, for that see the DateUtils unit. } + +function DayOfWeek(const DateTime: TDateTime): Word; + +{ Date returns the current date. } + +function Date: TDateTime; + +{ Time returns the current time. } + +function Time: TDateTime; +{$IFDEF LINUX} + { clashes with Time in , use GetTime instead } + {$EXTERNALSYM Time} +{$ENDIF} +function GetTime: TDateTime; + +{ Now returns the current date and time, corresponding to Date + Time. } + +function Now: TDateTime; + +{ Current year returns the year portion of the date returned by Now } + +function CurrentYear: Word; + +{ IncMonth returns Date shifted by the specified number of months. + NumberOfMonths parameter can be negative, to return a date N months ago. + If the input day of month is greater than the last day of the resulting + month, the day is set to the last day of the resulting month. + Input time of day is copied to the DateTime result. } + +function IncMonth(const DateTime: TDateTime; NumberOfMonths: Integer = 1): TDateTime; + +{ Optimized version of IncMonth that works with years, months and days + directly. See above comments for more detail as to what happens to the day + when incrementing months } + +procedure IncAMonth(var Year, Month, Day: Word; NumberOfMonths: Integer = 1); + +{ ReplaceTime replaces the time portion of the DateTime parameter with the given + time value, adjusting the signs as needed if the date is prior to 1900 + (Date value less than zero) } + +procedure ReplaceTime(var DateTime: TDateTime; const NewTime: TDateTime); + +{ ReplaceDate replaces the date portion of the DateTime parameter with the given + date value, adjusting as needed for negative dates } + +procedure ReplaceDate(var DateTime: TDateTime; const NewDate: TDateTime); + +{ IsLeapYear determines whether the given year is a leap year. } + +function IsLeapYear(Year: Word): Boolean; + +type + PDayTable = ^TDayTable; + TDayTable = array[1..12] of Word; + +{ The MonthDays array can be used to quickly find the number of + days in a month: MonthDays[IsLeapYear(Y), M] } + +const + MonthDays: array [Boolean] of TDayTable = + ((31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31), + (31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)); + +{ Each of the date/time formatting routines that uses global variables + for formatting (separators, decimals, etc.), has an overloaded equivalent + requiring a parameter of type TFormatSettings. This additional parameter + provides the formatting information rather than the global variables. For + more information see the note at TFormatSettings. } + +{ DateToStr converts the date part of the given TDateTime value to a string. + The conversion uses the format specified by the ShortDateFormat global + variable. } + +function DateToStr(const DateTime: TDateTime): string; overload; inline; +function DateToStr(const DateTime: TDateTime; + const FormatSettings: TFormatSettings): string; overload; inline; + +{ TimeToStr converts the time part of the given TDateTime value to a string. + The conversion uses the format specified by the LongTimeFormat global + variable. } + +function TimeToStr(const DateTime: TDateTime): string; overload; inline; +function TimeToStr(const DateTime: TDateTime; + const FormatSettings: TFormatSettings): string; overload; inline; + +{ DateTimeToStr converts the given date and time to a string. The resulting + string consists of a date and time formatted using the ShortDateFormat and + LongTimeFormat global variables. Time information is included in the + resulting string only if the fractional part of the given date and time + value is non-zero. } + +function DateTimeToStr(const DateTime: TDateTime): string; overload; inline; +function DateTimeToStr(const DateTime: TDateTime; + const FormatSettings: TFormatSettings): string; overload; inline; + +{ StrToDate converts the given string to a date value. The string must + consist of two or three numbers, separated by the character defined by + the DateSeparator global variable. The order for month, day, and year is + determined by the ShortDateFormat global variable--possible combinations + are m/d/y, d/m/y, and y/m/d. If the string contains only two numbers, it + is interpreted as a date (m/d or d/m) in the current year. Year values + between 0 and 99 are assumed to be in the current century. If the given + string does not contain a valid date, an EConvertError exception is + raised. } + +function StrToDate(const S: string): TDateTime; overload; +function StrToDate(const S: string; + const FormatSettings: TFormatSettings): TDateTime; overload; + +function StrToDateDef(const S: string; + const Default: TDateTime): TDateTime; overload; +function StrToDateDef(const S: string; const Default: TDateTime; + const FormatSettings: TFormatSettings): TDateTime; overload; + +function TryStrToDate(const S: string; out Value: TDateTime): Boolean; overload; +function TryStrToDate(const S: string; out Value: TDateTime; + const FormatSettings: TFormatSettings): Boolean; overload; + +{ StrToTime converts the given string to a time value. The string must + consist of two or three numbers, separated by the character defined by + the TimeSeparator global variable, optionally followed by an AM or PM + indicator. The numbers represent hour, minute, and (optionally) second, + in that order. If the time is followed by AM or PM, it is assumed to be + in 12-hour clock format. If no AM or PM indicator is included, the time + is assumed to be in 24-hour clock format. If the given string does not + contain a valid time, an EConvertError exception is raised. } + +function StrToTime(const S: string): TDateTime; overload; +function StrToTime(const S: string; + const FormatSettings: TFormatSettings): TDateTime; overload; + +function StrToTimeDef(const S: string; + const Default: TDateTime): TDateTime; overload; +function StrToTimeDef(const S: string; const Default: TDateTime; + const FormatSettings: TFormatSettings): TDateTime; overload; + +function TryStrToTime(const S: string; out Value: TDateTime): Boolean; overload; +function TryStrToTime(const S: string; out Value: TDateTime; + const FormatSettings: TFormatSettings): Boolean; overload; + +{ StrToDateTime converts the given string to a date and time value. The + string must contain a date optionally followed by a time. The date and + time parts of the string must follow the formats described for the + StrToDate and StrToTime functions. } + +function StrToDateTime(const S: string): TDateTime; overload; +function StrToDateTime(const S: string; + const FormatSettings: TFormatSettings): TDateTime; overload; + +function StrToDateTimeDef(const S: string; + const Default: TDateTime): TDateTime; overload; +function StrToDateTimeDef(const S: string; const Default: TDateTime; + const FormatSettings: TFormatSettings): TDateTime; overload; + +function TryStrToDateTime(const S: string; + out Value: TDateTime): Boolean; overload; +function TryStrToDateTime(const S: string; out Value: TDateTime; + const FormatSettings: TFormatSettings): Boolean; overload; + +{ FormatDateTime formats the date-and-time value given by DateTime using the + format given by Format. The following format specifiers are supported: + + c Displays the date using the format given by the ShortDateFormat + global variable, followed by the time using the format given by + the LongTimeFormat global variable. The time is not displayed if + the fractional part of the DateTime value is zero. + + d Displays the day as a number without a leading zero (1-31). + + dd Displays the day as a number with a leading zero (01-31). + + ddd Displays the day as an abbreviation (Sun-Sat) using the strings + given by the ShortDayNames global variable. + + dddd Displays the day as a full name (Sunday-Saturday) using the strings + given by the LongDayNames global variable. + + ddddd Displays the date using the format given by the ShortDateFormat + global variable. + + dddddd Displays the date using the format given by the LongDateFormat + global variable. + + g Displays the period/era as an abbreviation (Japanese and + Taiwanese locales only). + + gg Displays the period/era as a full name. + + e Displays the year in the current period/era as a number without + a leading zero (Japanese, Korean and Taiwanese locales only). + + ee Displays the year in the current period/era as a number with + a leading zero (Japanese, Korean and Taiwanese locales only). + + m Displays the month as a number without a leading zero (1-12). If + the m specifier immediately follows an h or hh specifier, the + minute rather than the month is displayed. + + mm Displays the month as a number with a leading zero (01-12). If + the mm specifier immediately follows an h or hh specifier, the + minute rather than the month is displayed. + + mmm Displays the month as an abbreviation (Jan-Dec) using the strings + given by the ShortMonthNames global variable. + + mmmm Displays the month as a full name (January-December) using the + strings given by the LongMonthNames global variable. + + yy Displays the year as a two-digit number (00-99). + + yyyy Displays the year as a four-digit number (0000-9999). + + h Displays the hour without a leading zero (0-23). + + hh Displays the hour with a leading zero (00-23). + + n Displays the minute without a leading zero (0-59). + + nn Displays the minute with a leading zero (00-59). + + s Displays the second without a leading zero (0-59). + + ss Displays the second with a leading zero (00-59). + + z Displays the millisecond without a leading zero (0-999). + + zzz Displays the millisecond with a leading zero (000-999). + + t Displays the time using the format given by the ShortTimeFormat + global variable. + + tt Displays the time using the format given by the LongTimeFormat + global variable. + + am/pm Uses the 12-hour clock for the preceding h or hh specifier, and + displays 'am' for any hour before noon, and 'pm' for any hour + after noon. The am/pm specifier can use lower, upper, or mixed + case, and the result is displayed accordingly. + + a/p Uses the 12-hour clock for the preceding h or hh specifier, and + displays 'a' for any hour before noon, and 'p' for any hour after + noon. The a/p specifier can use lower, upper, or mixed case, and + the result is displayed accordingly. + + ampm Uses the 12-hour clock for the preceding h or hh specifier, and + displays the contents of the TimeAMString global variable for any + hour before noon, and the contents of the TimePMString global + variable for any hour after noon. + + / Displays the date separator character given by the DateSeparator + global variable. + + : Displays the time separator character given by the TimeSeparator + global variable. + + 'xx' Characters enclosed in single or double quotes are displayed as-is, + "xx" and do not affect formatting. + + Format specifiers may be written in upper case as well as in lower case + letters--both produce the same result. + + If the string given by the Format parameter is empty, the date and time + value is formatted as if a 'c' format specifier had been given. + + The following example: + + S := FormatDateTime('"The meeting is on" dddd, mmmm d, yyyy, ' + + '"at" hh:mm AM/PM', StrToDateTime('2/15/95 10:30am')); + + assigns 'The meeting is on Wednesday, February 15, 1995 at 10:30 AM' to + the string variable S. } + +function FormatDateTime(const Format: string; + DateTime: TDateTime): string; overload; inline; +function FormatDateTime(const Format: string; DateTime: TDateTime; + const FormatSettings: TFormatSettings): string; overload; + +{ DateTimeToString converts the date and time value given by DateTime using + the format string given by Format into the string variable given by Result. + For further details, see the description of the FormatDateTime function. } + +procedure DateTimeToString(var Result: string; const Format: string; + DateTime: TDateTime); overload; +procedure DateTimeToString(var Result: string; const Format: string; + DateTime: TDateTime; const FormatSettings: TFormatSettings); overload; + +{ FloatToDateTime will range validate a value to make sure it falls + within the acceptable date range } + +const + MinDateTime: TDateTime = -657434.0; { 01/01/0100 12:00:00.000 AM } + MaxDateTime: TDateTime = 2958465.99999; { 12/31/9999 11:59:59.999 PM } + +function FloatToDateTime(const Value: Extended): TDateTime; +function TryFloatToDateTime(const Value: Extended; out AResult: TDateTime): Boolean; + +{ System error messages } + +function SysErrorMessage(ErrorCode: Integer): string; + +{ Initialization file support } + +function GetLocaleStr(Locale, LocaleType: Integer; const Default: string): string; platform; +function GetLocaleChar(Locale, LocaleType: Integer; Default: Char): Char; platform; + +{ GetFormatSettings resets all locale-specific variables (date, time, number, + currency formats, system locale) to the values provided by the operating system. } + +procedure GetFormatSettings; + +{ GetLocaleFormatSettings loads locale-specific variables (date, time, number, + currency formats) with values provided by the operating system for the + specified locale (LCID). The values are stored in the FormatSettings record. } + +{$IFDEF MSWINDOWS} +procedure GetLocaleFormatSettings(LCID: Integer; + var FormatSettings: TFormatSettings); +{$ENDIF} + +{ Exception handling routines } + +{$IFDEF LINUX} +{ InquireSignal is used to determine the state of an OS signal handler. + Pass it one of the RTL_SIG* constants, and it will return a TSignalState + which will tell you if the signal has been hooked, not hooked, or overriden + by some other module. You can use this function to determine if some other + module has hijacked your signal handlers, should you wish to reinstall your + own. This is a risky proposition under Linux, and is only recommended as a + last resort. Do not pass RTL_SIGDEFAULT to this function. +} +function InquireSignal(RtlSigNum: Integer): TSignalState; + +{ AbandonSignalHandler tells the RTL to leave a signal handler + in place, even if we believe that we hooked it at startup time. + + Once you have called AbandonSignalHandler with a specific signal number, + neither UnhookSignal nor the RTL will restore any previous signal handler + under any condition. +} +procedure AbandonSignalHandler(RtlSigNum: Integer); + +{ HookSignal is used to hook individual signals, or an RTL-defined default + set of signals. It does not test whether a signal has already been + hooked, so it should be used in conjunction with InquireSignal. It is + exposed to enable users to hook signals in standalone libraries, or in the + event that an external module hijacks the RTL installed signal handlers. + Pass RTL_SIGDEFAULT if you want to hook all the signals that the RTL + normally hooks at startup time. +} +procedure HookSignal(RtlSigNum: Integer); + +{ UnhookSignal is used to remove signal handlers installed by HookSignal. + It can remove individual signal handlers, or the RTL-defined default set + of signals. If OnlyIfHooked is True, then we will only unhook the signal + if the signal handler has been hooked, and has not since been overriden by + some foreign handler. +} +procedure UnhookSignal(RtlSigNum: Integer; OnlyIfHooked: Boolean = True); + +{ HookOSExceptions is used internally by thread support. DON'T call this + function yourself. } +procedure HookOSExceptions; + +{ MapSignal is used internally as well. It maps a signal and associated + context to an internal value that represents the type of Exception + class to raise. } +function MapSignal(SigNum: Integer; Context: PSigContext): LongWord; + +{ SignalConverter is used internally to properly reinit the FPU and properly + raise an external OS exception object. DON'T call this function yourself. } +procedure SignalConverter(ExceptionEIP: LongWord; FaultAddr: LongWord; ErrorCode: LongWord); + +{ + See the comment at the threadvar declarations for these below. The access + to these has been implemented through getter/setter functions because you + cannot use threadvars across packages. +} +procedure SetSafeCallExceptionMsg(const Msg: String); +procedure SetSafeCallExceptionAddr(Addr: Pointer); +function GetSafeCallExceptionMsg: String; +function GetSafeCallExceptionAddr: Pointer; + +{ HookOSExceptionsProc is used internally and cannot be used in a conventional + manner. DON'T ever set this variable. } +var + HookOSExceptionsProc: procedure = nil platform deprecated; + +{ LoadLibrary / FreeLibrary are defined here only for convenience. On Linux, + they map directly to dlopen / dlclose. Note that module loading semantics + on Linux are not identical to Windows. } + +function LoadLibrary(ModuleName: PChar): HMODULE; + +function FreeLibrary(Module: HMODULE): LongBool; + +{ GetProcAddress does what it implies. It performs the same function as the like + named function under Windows. dlsym does not quite have the same sematics as + GetProcAddress as it will return the address of a symbol in another module if + it was not found in the given HMODULE. This function will verify that the 'Proc' + is actually found within the 'Module', and if not returns nil } +function GetProcAddress(Module: HMODULE; Proc: PChar): Pointer; + +{ Given a module name, this function will return the module handle. There is no + direct equivalent in Linux so this function provides that capability. Also + note, this function is specific to glibc. } +function GetModuleHandle(ModuleName: PChar): HMODULE; + +{ This function works just like GetModuleHandle, except it will look for a module + that matches the given base package name. For example, given the base package + name 'package', the actual module name is, by default, 'bplpackage.so'. This + function will search for the string 'package' within the module name. } +function GetPackageModuleHandle(PackageName: PChar): HMODULE; + +{$ENDIF} + +{ In Linux, the parameter to sleep() is in whole seconds. In Windows, the + parameter is in milliseconds. To ease headaches, we implement a version + of sleep here for Linux that takes milliseconds and calls a Linux system + function with sub-second resolution. This maps directly to the Windows + API on Windows. } + +procedure Sleep(milliseconds: Cardinal);{$IFDEF MSWINDOWS} stdcall; {$ENDIF} +{$IFDEF MSWINDOWS} +(*$EXTERNALSYM Sleep*) +{$ENDIF} + +function GetModuleName(Module: HMODULE): string; + +function ExceptionErrorMessage(ExceptObject: TObject; ExceptAddr: Pointer; + Buffer: PChar; Size: Integer): Integer; + +procedure ShowException(ExceptObject: TObject; ExceptAddr: Pointer); + +procedure Abort; + +procedure OutOfMemoryError; + +procedure Beep; + +{ MBCS functions } + +{ LeadBytes is a char set that indicates which char values are lead bytes + in multibyte character sets (Japanese, Chinese, etc). + This set is always empty for western locales. } +var + LeadBytes: set of Char = []; +(*$EXTERNALSYM LeadBytes*) +(*$HPPEMIT 'namespace Sysutils {'*) +(*$HPPEMIT 'extern PACKAGE System::Set LeadBytes;'*) +(*$HPPEMIT '} // namespace Sysutils'*) + +{ ByteType indicates what kind of byte exists at the Index'th byte in S. + Western locales always return mbSingleByte. Far East multibyte locales + may also return mbLeadByte, indicating the byte is the first in a multibyte + character sequence, and mbTrailByte, indicating that the byte is one of + a sequence of bytes following a lead byte. One or more trail bytes can + follow a lead byte, depending on locale charset encoding and OS platform. + Parameters are assumed to be valid. } + +function ByteType(const S: string; Index: Integer): TMbcsByteType; + +{ StrByteType works the same as ByteType, but on null-terminated PChar strings } + +function StrByteType(Str: PChar; Index: Cardinal): TMbcsByteType; + +{ ByteToCharLen returns the character length of a MBCS string, scanning the + string for up to MaxLen bytes. In multibyte character sets, the number of + characters in a string may be less than the number of bytes. } + +function ByteToCharLen(const S: string; MaxLen: Integer): Integer; + +{ CharToByteLen returns the byte length of a MBCS string, scanning the string + for up to MaxLen characters. } + +function CharToByteLen(const S: string; MaxLen: Integer): Integer; + +{ ByteToCharIndex returns the 1-based character index of the Index'th byte in + a MBCS string. Returns zero if Index is out of range: + (Index <= 0) or (Index > Length(S)) } + +function ByteToCharIndex(const S: string; Index: Integer): Integer; + +{ CharToByteIndex returns the 1-based byte index of the Index'th character + in a MBCS string. Returns zero if Index or Result are out of range: + (Index <= 0) or (Index > Length(S)) or (Result would be > Length(S)) } + +function CharToByteIndex(const S: string; Index: Integer): Integer; + +{ StrCharLength returns the number of bytes required by the first character + in Str. In Windows, multibyte characters can be up to two bytes in length. + In Linux, multibyte characters can be up to six bytes in length (UTF-8). } + +function StrCharLength(const Str: PChar): Integer; + +{ StrNextChar returns a pointer to the first byte of the character following + the character pointed to by Str. } + +function StrNextChar(const Str: PChar): PChar; + +{ CharLength returns the number of bytes required by the character starting + at bytes S[Index]. } + +function CharLength(const S: String; Index: Integer): Integer; + +{ NextCharIndex returns the byte index of the first byte of the character + following the character starting at S[Index]. } + +function NextCharIndex(const S: String; Index: Integer): Integer; + +{ IsPathDelimiter returns True if the character at byte S[Index] + is a PathDelimiter ('\' or '/'), and it is not a MBCS lead or trail byte. } + +function IsPathDelimiter(const S: string; Index: Integer): Boolean; + +{ IsDelimiter returns True if the character at byte S[Index] matches any + character in the Delimiters string, and the character is not a MBCS lead or + trail byte. S may contain multibyte characters; Delimiters must contain + only single byte characters. } + +function IsDelimiter(const Delimiters, S: string; Index: Integer): Boolean; + +{ IncludeTrailingPathDelimiter returns the path with a PathDelimiter + ('/' or '\') at the end. This function is MBCS enabled. } + +function IncludeTrailingPathDelimiter(const S: string): string; + +{ IncludeTrailingBackslash is the old name for IncludeTrailingPathDelimiter. } + +function IncludeTrailingBackslash(const S: string): string; platform; inline; + +{ ExcludeTrailingPathDelimiter returns the path without a PathDelimiter + ('\' or '/') at the end. This function is MBCS enabled. } + +function ExcludeTrailingPathDelimiter(const S: string): string; + +{ ExcludeTrailingBackslash is the old name for ExcludeTrailingPathDelimiter. } + +function ExcludeTrailingBackslash(const S: string): string; platform; inline; + +{ LastDelimiter returns the byte index in S of the rightmost whole + character that matches any character in Delimiters (except null (#0)). + S may contain multibyte characters; Delimiters must contain only single + byte non-null characters. + Example: LastDelimiter('\.:', 'c:\filename.ext') returns 12. } + +function LastDelimiter(const Delimiters, S: string): Integer; + +{ AnsiCompareFileName supports DOS file name comparison idiosyncracies + in Far East locales (Zenkaku) on Windows. + In non-MBCS locales on Windows, AnsiCompareFileName is identical to + AnsiCompareText (case insensitive). + On Linux, AnsiCompareFileName is identical to AnsiCompareStr (case sensitive). + For general purpose file name comparisions, you should use this function + instead of AnsiCompareText. } + +function AnsiCompareFileName(const S1, S2: string): Integer; inline; + +function SameFileName(const S1, S2: string): Boolean; inline; + +{ AnsiLowerCaseFileName supports lowercase conversion idiosyncracies of + DOS file names in Far East locales (Zenkaku). In non-MBCS locales, + AnsiLowerCaseFileName is identical to AnsiLowerCase. } + +function AnsiLowerCaseFileName(const S: string): string; + +{ AnsiUpperCaseFileName supports uppercase conversion idiosyncracies of + DOS file names in Far East locales (Zenkaku). In non-MBCS locales, + AnsiUpperCaseFileName is identical to AnsiUpperCase. } + +function AnsiUpperCaseFileName(const S: string): string; + +{ AnsiPos: Same as Pos but supports MBCS strings } + +function AnsiPos(const Substr, S: string): Integer; + +{ AnsiStrPos: Same as StrPos but supports MBCS strings } + +function AnsiStrPos(Str, SubStr: PChar): PChar; + +{ AnsiStrRScan: Same as StrRScan but supports MBCS strings } + +function AnsiStrRScan(Str: PChar; Chr: Char): PChar; + +{ AnsiStrScan: Same as StrScan but supports MBCS strings } + +function AnsiStrScan(Str: PChar; Chr: Char): PChar; + +{ StringReplace replaces occurances of with in a + given string. Assumes the string may contain Multibyte characters } + +type + TReplaceFlags = set of (rfReplaceAll, rfIgnoreCase); + +function StringReplace(const S, OldPattern, NewPattern: string; + Flags: TReplaceFlags): string; + +{ WrapText will scan a string for BreakChars and insert the BreakStr at the + last BreakChar position before MaxCol. Will not insert a break into an + embedded quoted string (both ''' and '"' supported) } + +function WrapText(const Line, BreakStr: string; const BreakChars: TSysCharSet; + MaxCol: Integer): string; overload; +function WrapText(const Line: string; MaxCol: Integer = 45): string; overload; + +{ FindCmdLineSwitch determines whether the string in the Switch parameter + was passed as a command line argument to the application. SwitchChars + identifies valid argument-delimiter characters (i.e., "-" and "/" are + common delimiters). The IgnoreCase paramter controls whether a + case-sensistive or case-insensitive search is performed. } + +const + SwitchChars = {$IFDEF MSWINDOWS} ['/','-']; {$ENDIF} + {$IFDEF LINUX} ['-']; {$ENDIF} + +function FindCmdLineSwitch(const Switch: string; const Chars: TSysCharSet; + IgnoreCase: Boolean): Boolean; overload; + +{ These versions of FindCmdLineSwitch are convenient for writing portable + code. The characters that are valid to indicate command line switches vary + on different platforms. For example, '/' cannot be used as a switch char + on Linux because '/' is the path delimiter. } + +{ This version uses SwitchChars defined above, and IgnoreCase False. } +function FindCmdLineSwitch(const Switch: string): Boolean; overload; + +{ This version uses SwitchChars defined above. } +function FindCmdLineSwitch(const Switch: string; IgnoreCase: Boolean): Boolean; overload; + +{ FreeAndNil frees the given TObject instance and sets the variable reference + to nil. Be careful to only pass TObjects to this routine. } + +procedure FreeAndNil(var Obj); + +{ Interface support routines } + +function Supports(const Instance: IInterface; const IID: TGUID; out Intf): Boolean; overload; +function Supports(const Instance: TObject; const IID: TGUID; out Intf): Boolean; overload; +function Supports(const Instance: IInterface; const IID: TGUID): Boolean; overload; +function Supports(const Instance: TObject; const IID: TGUID): Boolean; overload; +function Supports(const AClass: TClass; const IID: TGUID): Boolean; overload; + +function CreateGUID(out Guid: TGUID): HResult; +{$IFDEF MSWINDOWS} + stdcall; +{$ENDIF} +function StringToGUID(const S: string): TGUID; +function GUIDToString(const GUID: TGUID): string; +function IsEqualGUID(const guid1, guid2: TGUID): Boolean; +{$IFDEF MSWINDOWS} + stdcall; {$EXTERNALSYM IsEqualGUID} +{$ENDIF} + +{ Package support routines } + +{ Package Info flags } + +const + pfNeverBuild = $00000001; + pfDesignOnly = $00000002; + pfRunOnly = $00000004; + pfIgnoreDupUnits = $00000008; + pfModuleTypeMask = $C0000000; + pfExeModule = $00000000; + pfPackageModule = $40000000; + pfProducerMask = $0C000000; + pfV3Produced = $00000000; + pfProducerUndefined = $04000000; + pfBCB4Produced = $08000000; + pfDelphi4Produced = $0C000000; + pfLibraryModule = $80000000; + pfConsumerMask = $00F00000; + pfConsumerCompat = $00000000; + pfConsumerDelphi = $00100000; + pfConsumerBCB = $00200000; + +{ Unit info flags } + +const + ufMainUnit = $01; + ufPackageUnit = $02; + ufWeakUnit = $04; + ufOrgWeakUnit = $08; + ufImplicitUnit = $10; + + ufWeakPackageUnit = ufPackageUnit or ufWeakUnit; + +{$IFDEF LINUX} +var + PkgLoadingMode: Integer = RTLD_LAZY; +{$ENDIF} + +{ Procedure type of the callback given to GetPackageInfo. Name is the actual + name of the package element. If IsUnit is True then Name is the name of + a contained unit; a required package if False. Param is the value passed + to GetPackageInfo } + +type + TNameType = (ntContainsUnit, ntRequiresPackage, ntDcpBpiName); + + TPackageInfoProc = procedure (const Name: string; NameType: TNameType; Flags: Byte; Param: Pointer); + TValidatePackageProc = function (Module: HMODULE): Boolean; + +{ LoadPackage loads a given package DLL, checks for duplicate units and + calls the initialization blocks of all the contained units. Duplicate unit checks are + bypassed if the AValidatePackage function returns "True." Be warned that this may cause + strange and unpredictable behaviour if two packages are loaded that contain the same + units and types. } + +function LoadPackage(const Name: string): HMODULE; overload; +function LoadPackage(const Name: string; AValidatePackage: TValidatePackageProc): HMODULE; overload; + +{ UnloadPackage does the opposite of LoadPackage by calling the finalization + blocks of all contained units, then unloading the package DLL } + +procedure UnloadPackage(Module: HMODULE); + +{ GetPackageInfo accesses the given package's info table and enumerates + all the contained units and required packages } + +procedure GetPackageInfo(Module: HMODULE; Param: Pointer; var Flags: Integer; + InfoProc: TPackageInfoProc); + +{ GetPackageDescription loads the description resource from the package + library. If the description resource does not exist, + an empty string is returned. } +function GetPackageDescription(ModuleName: PChar): string; + +{ InitializePackage validates and initializes the given package DLL } + +procedure InitializePackage(Module: HMODULE); overload; +procedure InitializePackage(Module: HMODULE; AValidatePackage: TValidatePackageProc); overload; + +{ FinalizePackage finalizes the given package DLL } + +procedure FinalizePackage(Module: HMODULE); + +{ RaiseLastOSError calls GetLastError to retrieve the code for + the last occuring error in a call to an OS or system library function. + If GetLastError returns an error code, RaiseLastOSError raises + an EOSError exception with the error code and a system-provided + message associated with with error. } + +procedure RaiseLastOSError; overload; +procedure RaiseLastOSError(LastError: Integer); overload; + +{$IFDEF MSWINDOWS} +procedure RaiseLastWin32Error; deprecated; // use RaiseLastOSError + +{ Win32Check is used to check the return value of a Win32 API function } +{ which returns a BOOL to indicate success. If the Win32 API function } +{ returns False (indicating failure), Win32Check calls RaiseLastOSError } +{ to raise an exception. If the Win32 API function returns True, } +{ Win32Check returns True. } + +function Win32Check(RetVal: BOOL): BOOL; platform; +{$ENDIF} + +{ Termination procedure support } + +type + TTerminateProc = function: Boolean; + +{ Call AddTerminateProc to add a terminate procedure to the system list of } +{ termination procedures. Delphi will call all of the function in the } +{ termination procedure list before an application terminates. The user- } +{ defined TermProc function should return True if the application can } +{ safely terminate or False if the application cannot safely terminate. } +{ If one of the functions in the termination procedure list returns False, } +{ the application will not terminate. } + +procedure AddTerminateProc(TermProc: TTerminateProc); + +{ CallTerminateProcs is called by VCL when an application is about to } +{ terminate. It returns True only if all of the functions in the } +{ system's terminate procedure list return True. This function is } +{ intended only to be called by Delphi, and it should not be called } +{ directly. } + +function CallTerminateProcs: Boolean; + +function GDAL: LongWord; +procedure RCS; +procedure RPR; + + +{ HexDisplayPrefix contains the prefix to display on hexadecimal + values - '$' for Pascal syntax, '0x' for C++ syntax. This is + for display only - this does not affect the string-to-integer + conversion routines. } +var + HexDisplayPrefix: string = '$'; + +{$IFDEF MSWINDOWS} +{ The GetDiskFreeSpace Win32 API does not support partitions larger than 2GB + under Win95. A new Win32 function, GetDiskFreeSpaceEx, supports partitions + larger than 2GB but only exists on Win NT 4.0 and Win95 OSR2. + The GetDiskFreeSpaceEx function pointer variable below will be initialized + at startup to point to either the actual OS API function if it exists on + the system, or to an internal Delphi function if it does not. When running + on Win95 pre-OSR2, the output of this function will still be limited to + the 2GB range reported by Win95, but at least you don't have to worry + about which API function to call in code you write. } + +var + GetDiskFreeSpaceEx: function (Directory: PChar; var FreeAvailable, + TotalSpace: TLargeInteger; TotalFree: PLargeInteger): Bool stdcall = nil; + +{ SafeLoadLibrary calls LoadLibrary, disabling normal Win32 error message + popup dialogs if the requested file can't be loaded. SafeLoadLibrary also + preserves the current FPU control word (precision, exception masks) across + the LoadLibrary call (in case the DLL you're loading hammers the FPU control + word in its initialization, as many MS DLLs do)} + +function SafeLoadLibrary(const FileName: string; + ErrorMode: UINT = SEM_NOOPENFILEERRORBOX): HMODULE; + +{$ENDIF} + +{$IFDEF LINUX} +{ SafeLoadLibrary calls LoadLibrary preserves the current FPU control + word (precision, exception masks) across the LoadLibrary call (in + case the shared object you're loading hammers the FPU control + word in its initialization, as many MS DLLs do) } + +function SafeLoadLibrary(const FileName: string; + Dummy: LongWord = 0): HMODULE; +{$ENDIF} + +{ Thread synchronization } + +{ IReadWriteSync is an abstract interface for general read/write synchronization. + Some implementations may allow simultaneous readers, but writers always have + exclusive locks. + + Worst case is that this class behaves identical to a TRTLCriticalSection - + that is, read and write locks block all other threads. } + +type + IReadWriteSync = interface + ['{7B108C52-1D8F-4CDB-9CDF-57E071193D3F}'] + procedure BeginRead; + procedure EndRead; + function BeginWrite: Boolean; + procedure EndWrite; + end; + + TSimpleRWSync = class(TInterfacedObject, IReadWriteSync) + private + FLock: TRTLCriticalSection; + public + constructor Create; + destructor Destroy; override; + procedure BeginRead; + procedure EndRead; + function BeginWrite: Boolean; + procedure EndWrite; + end; + +{ TThreadLocalCounter + + This class implements a lightweight non-blocking thread local storage + mechanism specifically built for tracking per-thread recursion counts + in TMultiReadExclusiveWriteSynchronizer. This class is intended for + Delphi RTL internal use only. In the future it may be generalized + and "hardened" for general application use, but until then leave it alone. + + Rules of Use: + The tls object must be opened to gain access to the thread-specific data + structure. If a threadinfo block does not exist for the current thread, + Open will allocate one. Every call to Open must be matched with a call + to Close. The pointer returned by Open is invalid after the matching call + to Close (or Delete). + + The thread info structure is unique to each thread. Once you have it, it's + yours. You don't need to guard against concurrent access to the thread + data by multiple threads - your thread is the only thread that will ever + have access to the structure that Open returns. The thread info structure + is allocated and owned by the tls object. If you put allocated pointers + in the thread info make sure you free them before you delete the threadinfo + node. + + When thread data is no longer needed, call the Delete method on the pointer. + This must be done between calls to Open and Close. You should not use the + thread data after calling Delete. + + Important: Do not keep the tls object open for long periods of time. + In particular, be careful not to wait on a thread synchronization event or + critical section while you have the tls object open. It's much better to + open and close the tls object before and after the blocking event than to + leave the tls object open while waiting. + + Implementation Notes: + The main purpose of this storage class is to provide thread-local storage + without using limited / problematic OS tls slots and without requiring + expensive blocking thread synchronization. This class performs no + blocking waits or spin loops! (except for memory allocation) + + Thread info is kept in linked lists to facilitate non-blocking threading + techniques. A hash table indexed by a hash of the current thread ID + reduces linear search times. + + When a node is deleted, its thread ID is stripped and its Active field is + set to zero, meaning it is available to be recycled for other threads. + Nodes are never removed from the live list or freed while the class is in + use. All nodes are freed when the class is destroyed. + + Nodes are only inserted at the front of the list (each list in the hash table). + + The linked list management relies heavily on InterlockedExchange to perform + atomic node pointer replacements. There are brief windows of time where + the linked list may be circular while a two-step insertion takes place. + During that brief window, other threads traversing the lists may see + the same node more than once more than once. (pun!) This is fine for what this + implementation needs. Don't do anything silly like try to count the + nodes during a traversal. +} + +type + PThreadInfo = ^TThreadInfo; + TThreadInfo = record + Next: PThreadInfo; + ThreadID: Cardinal; + Active: Integer; + RecursionCount: Cardinal; + end; + + TThreadLocalCounter = class + private + FHashTable: array [0..15] of PThreadInfo; + function HashIndex: Byte; + function Recycle: PThreadInfo; + public + destructor Destroy; override; + procedure Open(var Thread: PThreadInfo); + procedure Delete(var Thread: PThreadInfo); + procedure Close(var Thread: PThreadInfo); + end; + +{$IFDEF MSWINDOWS} + +{ TMultiReadExclusiveWriteSynchronizer minimizes thread serialization to gain + read access to a resource shared among threads while still providing complete + exclusivity to callers needing write access to the shared resource. + (multithread shared reads, single thread exclusive write) + Read locks are allowed while owning a write lock. + Read locks can be promoted to write locks within the same thread. + (BeginRead, BeginWrite, EndWrite, EndRead) + + Note: Other threads have an opportunity to modify the protected resource + when you call BeginWrite before you are granted the write lock, even + if you already have a read lock open. Best policy is not to retain + any info about the protected resource (such as count or size) across a + write lock. Always reacquire samples of the protected resource after + acquiring or releasing a write lock. + + The function result of BeginWrite indicates whether another thread got + the write lock while the current thread was waiting for the write lock. + Return value of True means that the write lock was acquired without + any intervening modifications by other threads. Return value of False + means another thread got the write lock while you were waiting, so the + resource protected by the MREWS object should be considered modified. + Any samples of the protected resource should be discarded. + + In general, it's better to just always reacquire samples of the protected + resource after obtaining a write lock. The boolean result of BeginWrite + and the RevisionLevel property help cases where reacquiring the samples + is computationally expensive or time consuming. + + RevisionLevel changes each time a write lock is granted. You can test + RevisionLevel for equality with a previously sampled value of the property + to determine if a write lock has been granted, implying that the protected + resource may be changed from its state when the original RevisionLevel + value was sampled. Do not rely on the sequentiality of the current + RevisionLevel implementation (it will wrap around to zero when it tops out). + Do not perform greater than / less than comparisons on RevisionLevel values. + RevisionLevel indicates only the stability of the protected resource since + your original sample. It should not be used to calculate how many + revisions have been made. +} + +type + TMultiReadExclusiveWriteSynchronizer = class(TInterfacedObject, IReadWriteSync) + private + FSentinel: Integer; + FReadSignal: THandle; + FWriteSignal: THandle; + FWaitRecycle: Cardinal; + FWriteRecursionCount: Cardinal; + tls: TThreadLocalCounter; + FWriterID: Cardinal; + FRevisionLevel: Cardinal; + procedure BlockReaders; + procedure UnblockReaders; + procedure UnblockOneWriter; + procedure WaitForReadSignal; + procedure WaitForWriteSignal; +{$IFDEF DEBUG_MREWS} + procedure Debug(const Msg: string); +{$ENDIF} + public + constructor Create; + destructor Destroy; override; + procedure BeginRead; + procedure EndRead; + function BeginWrite: Boolean; + procedure EndWrite; + property RevisionLevel: Cardinal read FRevisionLevel; + end; +{$ELSE} +type + TMultiReadExclusiveWriteSynchronizer = TSimpleRWSync; +{$ENDIF} + +type + TMREWSync = TMultiReadExclusiveWriteSynchronizer; // short form + +function GetEnvironmentVariable(const Name: string): string; overload; + +{$IFDEF LINUX} +function InterlockedIncrement(var I: Integer): Integer; +function InterlockedDecrement(var I: Integer): Integer; +function InterlockedExchange(var A: Integer; B: Integer): Integer; +function InterlockedExchangeAdd(var A: Integer; B: Integer): Integer; +{$ENDIF} + +implementation + +{$IFDEF MSWINDOWS} +uses +ImageHlp; +{$ENDIF} + +{$IFDEF LINUX} +{ + Exceptions raised in methods that are safecall will be filtered + through the virtual method SafeCallException on the class. The + implementation of this method under Linux has the option of setting + the following thread vars: SafeCallExceptionMsg, SafeCallExceptionAddr. + If these are set, then the implementation of SafeCallError here will + reraise a generic exception based on these. One might consider actually + having the SafeCallException implementation store off the exception + object itself, but this raises the issue that the exception object + might have to live a long time (if an external application calls a + Delphi safecall method). Since an arbitrary exception object could + be holding large resources hostage, we hold only the string and + address as a hedge. +} +threadvar + SafeCallExceptionMsg: String; + SafeCallExceptionAddr: Pointer; + +procedure SetSafeCallExceptionMsg(const Msg: String); +begin + SafeCallExceptionMsg := Msg; +end; + +procedure SetSafeCallExceptionAddr(Addr: Pointer); +begin + SafeCallExceptionAddr := Addr; +end; + +function GetSafeCallExceptionMsg: String; +begin + Result := SafeCallExceptionMsg; +end; + +function GetSafeCallExceptionAddr: Pointer; +begin + Result := SafeCallExceptionAddr; +end; +{$ENDIF} + +{ Utility routines } + +procedure DivMod(Dividend: Integer; Divisor: Word; + var Result, Remainder: Word); +asm + PUSH EBX + MOV EBX,EDX + MOV EDX,EAX + SHR EDX,16 + DIV BX + MOV EBX,Remainder + MOV [ECX],AX + MOV [EBX],DX + POP EBX +end; + +{$IFDEF PIC} +function GetGOT: Pointer; export; +begin + asm + MOV Result,EBX + end; +end; +{$ENDIF} + +procedure ConvertError(ResString: PResStringRec); local; +begin + raise EConvertError.CreateRes(ResString); +end; + +procedure ConvertErrorFmt(ResString: PResStringRec; const Args: array of const); local; +begin + raise EConvertError.CreateResFmt(ResString, Args); +end; + +{$IFDEF MSWINDOWS} +{$EXTERNALSYM CoCreateGuid} +function CoCreateGuid(out guid: TGUID): HResult; stdcall; external 'ole32.dll' name 'CoCreateGuid'; + +function CreateGUID(out Guid: TGUID): HResult; +begin + Result := CoCreateGuid(Guid); +end; +//function CreateGUID; external 'ole32.dll' name 'CoCreateGuid'; +{$ENDIF} +{$IFDEF LINUX} + +{ CreateGUID } + +{ libuuid.so implements the tricky code to create GUIDs using the + MAC address of the network adapter plus other flavor bits. + libuuid.so is currently distributed with the ext2 file system + package, but does not depend upon the ext2 file system libraries. + Ideally, libuuid.so should be distributed separately. + + If you do not have libuuid.so.1 on your Linux distribution, you + can extract the library from the e2fsprogs RPM. + + Note: Do not use the generic uuid_generate function in libuuid.so. + In the current implementation (e2fsprogs-1.19), uuid_generate + gives preference to generating guids entirely from random number + streams over generating guids based on the NIC MAC address. + No matter how "random" a random number generator is, it will + never produce guids that can be guaranteed unique across all + systems on the planet. MAC-address based guids are guaranteed + unique because the MAC address of the NIC is guaranteed unique + by the manufacturer. + + For this reason, we call uuid_generate_time instead of the + generic uuid_generate. uuid_generate_time constructs the guid + using the MAC address, and falls back to randomness if no NIC + can be found. } + +var + libuuidHandle: Pointer; + uuid_generate_time: procedure (out Guid: TGUID) cdecl; + +function CreateGUID(out Guid: TGUID): HResult; + +const + E_NOTIMPL = HRESULT($80004001); + +begin + Result := E_NOTIMPL; + if libuuidHandle = nil then + begin + libuuidHandle := dlopen('libuuid.so.1', RTLD_LAZY); + if libuuidHandle = nil then Exit; + uuid_generate_time := dlsym(libuuidHandle, 'uuid_generate_time'); + if @uuid_generate_time = nil then Exit; + end; + uuid_generate_time(Guid); + Result := 0; +end; +{$ENDIF} + + +{$IFDEF MSWINDOWS} +function StringFromCLSID(const clsid: TGUID; out psz: PWideChar): HResult; stdcall; + external 'ole32.dll' name 'StringFromCLSID'; +procedure CoTaskMemFree(pv: Pointer); stdcall; + external 'ole32.dll' name 'CoTaskMemFree'; +function CLSIDFromString(psz: PWideChar; out clsid: TGUID): HResult; stdcall; + external 'ole32.dll' name 'CLSIDFromString'; +{$ENDIF MSWINDOWS} + +function StringToGUID(const S: string): TGUID; +{$IFDEF MSWINDOWS} +begin + if not Succeeded(CLSIDFromString(PWideChar(WideString(S)), Result)) then + ConvertErrorFmt(@SInvalidGUID, [s]); +end; +{$ENDIF} +{$IFDEF LINUX} + + procedure InvalidGUID; + begin + ConvertErrorFmt(@SInvalidGUID, [s]); + end; + + function HexChar(c: Char): Byte; + begin + case c of + '0'..'9': Result := Byte(c) - Byte('0'); + 'a'..'f': Result := (Byte(c) - Byte('a')) + 10; + 'A'..'F': Result := (Byte(c) - Byte('A')) + 10; + else + InvalidGUID; + Result := 0; + end; + end; + + function HexByte(p: PChar): Char; + begin + Result := Char((HexChar(p[0]) shl 4) + HexChar(p[1])); + end; + +var + i: Integer; + src, dest: PChar; +begin + if ((Length(S) <> 38) or (s[1] <> '{')) then InvalidGUID; + dest := @Result; + src := PChar(s); + Inc(src); + for i := 0 to 3 do + dest[i] := HexByte(src+(3-i)*2); + Inc(src, 8); + Inc(dest, 4); + if src[0] <> '-' then InvalidGUID; + Inc(src); + for i := 0 to 1 do + begin + dest^ := HexByte(src+2); + Inc(dest); + dest^ := HexByte(src); + Inc(dest); + Inc(src, 4); + if src[0] <> '-' then InvalidGUID; + inc(src); + end; + dest^ := HexByte(src); + Inc(dest); + Inc(src, 2); + dest^ := HexByte(src); + Inc(dest); + Inc(src, 2); + if src[0] <> '-' then InvalidGUID; + Inc(src); + for i := 0 to 5 do + begin + dest^ := HexByte(src); + Inc(dest); + Inc(src, 2); + end; +end; +{$ENDIF LINUX} + +{$IFDEF MSWINDOWS} +function GUIDToString(const GUID: TGUID): string; +var + P: PWideChar; +begin + if not Succeeded(StringFromCLSID(GUID, P)) then + ConvertError(@SInvalidGUID); + Result := P; + CoTaskMemFree(P); +end; +{$ENDIF} +{$IFDEF LINUX} +function GUIDToString(const GUID: TGUID): string; +begin + SetLength(Result, 38); + StrLFmt(PChar(Result), 38,'{%.8x-%.4x-%.4x-%.2x%.2x-%.2x%.2x%.2x%.2x%.2x%.2x}', // do not localize + [GUID.D1, GUID.D2, GUID.D3, GUID.D4[0], GUID.D4[1], GUID.D4[2], GUID.D4[3], + GUID.D4[4], GUID.D4[5], GUID.D4[6], GUID.D4[7]]); +end; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function IsEqualGUID; external 'ole32.dll' name 'IsEqualGUID'; +{$ENDIF MSWINDOWS} +{$IFDEF LINUX} +function IsEqualGUID(const guid1, guid2: TGUID): Boolean; +var + a, b: PIntegerArray; +begin + a := PIntegerArray(@guid1); + b := PIntegerArray(@guid2); + Result := (a^[0] = b^[0]) and (a^[1] = b^[1]) and (a^[2] = b^[2]) and (a^[3] = b^[3]); +end; +{$ENDIF LINUX} + +{ Exit procedure handling } + +type + PExitProcInfo = ^TExitProcInfo; + TExitProcInfo = record + Next: PExitProcInfo; + SaveExit: Pointer; + Proc: TProcedure; + end; + +var + ExitProcList: PExitProcInfo = nil; + +procedure DoExitProc; +var + P: PExitProcInfo; + Proc: TProcedure; +begin + P := ExitProcList; + ExitProcList := P^.Next; + ExitProc := P^.SaveExit; + Proc := P^.Proc; + Dispose(P); + Proc; +end; + +procedure AddExitProc(Proc: TProcedure); +var + P: PExitProcInfo; +begin + New(P); + P^.Next := ExitProcList; + P^.SaveExit := ExitProc; + P^.Proc := Proc; + ExitProcList := P; + ExitProc := @DoExitProc; +end; + +{ String handling routines } + +function NewStr(const S: string): PString; +begin + if S = '' then Result := NullStr else + begin + New(Result); + Result^ := S; + end; +end; + +procedure DisposeStr(P: PString); +begin + if (P <> nil) and (P^ <> '') then Dispose(P); +end; + +procedure AssignStr(var P: PString; const S: string); +var + Temp: PString; +begin + Temp := P; + P := NewStr(S); + DisposeStr(Temp); +end; + +procedure AppendStr(var Dest: string; const S: string); +begin + Dest := Dest + S; +end; + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The implementation of function UpperCase is subject to the + * Mozilla Public License Version 1.1 (the "License"); you may + * not use this file except in compliance with the License. + * You may obtain a copy of the License at http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is Fastcode + * + * The Initial Developer of the Original Code is Fastcode + * + * Portions created by the Initial Developer are Copyright (C) 2002-2004 + * the Initial Developer. All Rights Reserved. + * + * Contributor(s): Aleksandr Sharahov + * + * ***** END LICENSE BLOCK ***** *) +function UpperCase(const S: string): string; +asm + push ebx + push esi + push edi + mov esi, eax // s + mov eax, edx + test esi, esi + jz @Nil + mov edx, [esi-4] // Length(s) + mov edi, eax // @Result + test edx, edx + jle @Nil + mov ecx, [eax] + mov ebx, edx + test ecx, ecx + jz @Realloc // Jump if Result not allocated + test edx, 3 + jnz @Length3 + xor edx, [ecx-4] + cmp edx, 3 + jbe @TestRef + jmp @Realloc +@Length3: + or edx, 2 + xor edx, [ecx-4] + cmp edx, 1 + ja @Realloc +@TestRef: + cmp [ecx-8], 1 + je @LengthOK // Jump if Result RefCt=1 +@Realloc: + mov edx, ebx + or edx, 3 + call System.@LStrSetLength +@LengthOK: + mov edi, [edi] // Result + mov [edi-4], ebx // Correct Result length + mov byte ptr [ebx+edi], 0 + add ebx, -1 + and ebx, -4 + mov eax, [ebx+esi] + +@Loop: mov ecx, eax + or eax, $80808080 // $E1..$FA + mov edx, eax + sub eax, $7B7B7B7B // $66..$7F + xor edx, ecx // $80 + or eax, $80808080 // $E6..$FF + sub eax, $66666666 // $80..$99 + and eax, edx // $80 + shr eax, 2 // $20 + xor eax, ecx // Upper + mov [ebx+edi], eax + mov eax, [ebx+esi-4] + sub ebx, 4 + jge @Loop + + pop edi + pop esi + pop ebx + ret + +@Nil: pop edi + pop esi + pop ebx + jmp System.@LStrClr // Result:='' +end; + +function UpperCase(const S: string; LocaleOptions: TLocaleOptions): string; +begin + if LocaleOptions = loUserLocale then + Result := AnsiUpperCase(S) + else + Result := UpperCase(S); +end; + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The implementation of function LowerCase is subject to the + * Mozilla Public License Version 1.1 (the "License"); you may + * not use this file except in compliance with the License. + * You may obtain a copy of the License at http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is Fastcode + * + * The Initial Developer of the Original Code is Fastcode + * + * Portions created by the Initial Developer are Copyright (C) 2002-2004 + * the Initial Developer. All Rights Reserved. + * + * Contributor(s): Aleksandr Sharahov + * + * ***** END LICENSE BLOCK ***** *) +function LowerCase(const S: string): string; +asm + push ebx + push esi + push edi + mov esi, eax // s + mov eax, edx + test esi, esi + jz @Nil + mov edx, [esi-4] // Length(s) + mov edi, eax // @Result + test edx, edx + jle @Nil + mov ecx, [eax] + mov ebx, edx + test ecx, ecx + jz @Realloc // Jump if Result not allocated + test edx, 3 + jnz @Length3 + xor edx, [ecx-4] + cmp edx, 3 + jbe @TestRef + jmp @Realloc +@Length3: + or edx, 2 + xor edx, [ecx-4] + cmp edx, 1 + ja @Realloc +@TestRef: + cmp [ecx-8], 1 + je @LengthOK // Jump if Result RefCt=1 +@Realloc: + mov edx, ebx + or edx, 3 + call System.@LStrSetLength +@LengthOK: + mov edi, [edi] // Result + mov [edi-4], ebx // Correct Result length + mov byte ptr [ebx+edi], 0 + add ebx, -1 + and ebx, -4 + mov eax, [ebx+esi] + +@Loop: mov ecx, eax + or eax, $80808080 // $C1..$DA + mov edx, eax + sub eax, $5B5B5B5B // $66..$7F + xor edx, ecx // $80 + or eax, $80808080 // $E6..$FF + sub eax, $66666666 // $80..$99 + and eax, edx // $80 + shr eax, 2 // $20 + xor eax, ecx // Lower + mov [ebx+edi], eax + mov eax, [ebx+esi-4] + sub ebx, 4 + jge @Loop + + pop edi + pop esi + pop ebx + ret + +@Nil: pop edi + pop esi + pop ebx + jmp System.@LStrClr // Result:='' +end; + +function LowerCase(const S: string; LocaleOptions: TLocaleOptions): string; +begin + if LocaleOptions = loUserLocale then + Result := AnsiLowerCase(S) + else + Result := LowerCase(S); +end; + +function CompareStr(const S1, S2: string): Integer; assembler; +asm + PUSH ESI + PUSH EDI + MOV ESI,EAX + MOV EDI,EDX + OR EAX,EAX + JE @@1 + MOV EAX,[EAX-4] +@@1: OR EDX,EDX + JE @@2 + MOV EDX,[EDX-4] +@@2: MOV ECX,EAX + CMP ECX,EDX + JBE @@3 + MOV ECX,EDX +@@3: CMP ECX,ECX + REPE CMPSB + JE @@4 + MOVZX EAX,BYTE PTR [ESI-1] + MOVZX EDX,BYTE PTR [EDI-1] +@@4: SUB EAX,EDX + POP EDI + POP ESI +end; + +function CompareStr(const S1, S2: string; LocaleOptions: TLocaleOptions): Integer; +begin + if LocaleOptions = loUserLocale then + Result := AnsiCompareStr(S1, S2) + else + Result := CompareStr(S1, S2); +end; + +function SameStr(const S1, S2: string): Boolean; +asm + CMP EAX,EDX + JZ @1 + OR EAX,EAX + JZ @2 + OR EDX,EDX + JZ @3 + MOV ECX,[EAX-4] + CMP ECX,[EDX-4] + JNE @3 + CALL CompareStr + TEST EAX,EAX + JNZ @3 +@1: MOV AL,1 +@2: RET +@3: XOR EAX,EAX +end; + +function SameStr(const S1, S2: string; LocaleOptions: TLocaleOptions): Boolean; +begin + if LocaleOptions = loUserLocale then + Result := AnsiSameStr(S1, S2) + else + Result := SameStr(S1, S2); +end; + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The implementation of function CompareMem is subject to the + * Mozilla Public License Version 1.1 (the "License"); you may + * not use this file except in compliance with the License. + * You may obtain a copy of the License at http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is Fastcode + * + * The Initial Developer of the Original Code is Fastcode + * + * Portions created by the Initial Developer are Copyright (C) 2002-2004 + * the Initial Developer. All Rights Reserved. + * + * Contributor(s): Aleksandr Sharahov + * + * ***** END LICENSE BLOCK ***** *) +function CompareMem(P1, P2: Pointer; Length: Integer): Boolean; assembler; +asm + add eax, ecx + add edx, ecx + xor ecx, -1 + add eax, -8 + add edx, -8 + add ecx, 9 + push ebx + jg @Dword + mov ebx, [eax+ecx] + cmp ebx, [edx+ecx] + jne @Ret0 + lea ebx, [eax+ecx] + add ecx, 4 + and ebx, 3 + sub ecx, ebx + jg @Dword +@DwordLoop: + mov ebx, [eax+ecx] + cmp ebx, [edx+ecx] + jne @Ret0 + mov ebx, [eax+ecx+4] + cmp ebx, [edx+ecx+4] + jne @Ret0 + add ecx, 8 + jg @Dword + mov ebx, [eax+ecx] + cmp ebx, [edx+ecx] + jne @Ret0 + mov ebx, [eax+ecx+4] + cmp ebx, [edx+ecx+4] + jne @Ret0 + add ecx, 8 + jle @DwordLoop +@Dword: + cmp ecx, 4 + jg @Word + mov ebx, [eax+ecx] + cmp ebx, [edx+ecx] + jne @Ret0 + add ecx, 4 +@Word: + cmp ecx, 6 + jg @Byte + movzx ebx, word ptr [eax+ecx] + cmp bx, [edx+ecx] + jne @Ret0 + add ecx, 2 +@Byte: + cmp ecx, 7 + jg @Ret1 + movzx ebx, byte ptr [eax+7] + cmp bl, [edx+7] + jne @Ret0 +@Ret1: + mov eax, 1 + pop ebx + ret +@Ret0: + xor eax, eax + pop ebx +end; + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The implementation of function CompareText is subject to the + * Mozilla Public License Version 1.1 (the "License"); you may + * not use this file except in compliance with the License. + * You may obtain a copy of the License at http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is Fastcode + * + * The Initial Developer of the Original Code is + * Fastcode + * + * Portions created by the Initial Developer are Copyright (C) 2002-2004 + * the Initial Developer. All Rights Reserved. + * + * Contributor(s): John O'Harrow + * + * ***** END LICENSE BLOCK ***** *) +function CompareText(const S1, S2: string): Integer; +asm + TEST EAX, EAX + JNZ @@CheckS2 + TEST EDX, EDX + JZ @@Ret + MOV EAX, [EDX-4] + NEG EAX +@@Ret: + RET +@@CheckS2: + TEST EDX, EDX + JNZ @@Compare + MOV EAX, [EAX-4] + RET +@@Compare: + PUSH EBX + PUSH EBP + PUSH ESI + MOV EBP, [EAX-4] // length(S1) + MOV EBX, [EDX-4] // length(S2) + SUB EBP, EBX // Result if All Compared Characters Match + SBB ECX, ECX + AND ECX, EBP + ADD ECX, EBX // min(length(S1),length(S2)) = Compare Length + LEA ESI, [EAX+ECX] // Last Compare Position in S1 + ADD EDX, ECX // Last Compare Position in S2 + NEG ECX + JZ @@SetResult // Exit if Smallest Length = 0 +@@Loop: // Load Next 2 Chars from S1 and S2 + // May Include Null Terminator} + MOVZX EAX, WORD PTR [ESI+ECX] + MOVZX EBX, WORD PTR [EDX+ECX] + CMP EAX, EBX + JE @@Next // Next 2 Chars Match + CMP AL, BL + JE @@SecondPair // First Char Matches + MOV AH, 0 + MOV BH, 0 + CMP AL, 'a' + JL @@UC1 + CMP AL, 'z' + JG @@UC1 + SUB EAX, 'a'-'A' +@@UC1: + CMP BL, 'a' + JL @@UC2 + CMP BL, 'z' + JG @@UC2 + SUB EBX, 'a'-'A' +@@UC2: + SUB EAX, EBX // Compare Both Uppercase Chars + JNE @@Done // Exit with Result in EAX if Not Equal + MOVZX EAX, WORD PTR [ESI+ECX] // Reload Same 2 Chars from S1 + MOVZX EBX, WORD PTR [EDX+ECX] // Reload Same 2 Chars from S2 + CMP AH, BH + JE @@Next // Second Char Matches +@@SecondPair: + SHR EAX, 8 + SHR EBX, 8 + CMP AL, 'a' + JL @@UC3 + CMP AL, 'z' + JG @@UC3 + SUB EAX, 'a'-'A' +@@UC3: + CMP BL, 'a' + JL @@UC4 + CMP BL, 'z' + JG @@UC4 + SUB EBX, 'a'-'A' +@@UC4: + SUB EAX, EBX // Compare Both Uppercase Chars + JNE @@Done // Exit with Result in EAX if Not Equal +@@Next: + ADD ECX, 2 + JL @@Loop // Loop until All required Chars Compared +@@SetResult: + MOV EAX, EBP // All Matched, Set Result from Lengths +@@Done: + POP ESI + POP EBP + POP EBX +end; + +function CompareText(const S1, S2: string; LocaleOptions: TLocaleOptions): Integer; +begin + if LocaleOptions = loUserLocale then + Result := AnsiCompareText(S1, S2) + else + Result := CompareText(S1, S2); +end; + +function SameText(const S1, S2: string): Boolean; assembler; +asm + CMP EAX,EDX + JZ @1 + OR EAX,EAX + JZ @2 + OR EDX,EDX + JZ @3 + MOV ECX,[EAX-4] + CMP ECX,[EDX-4] + JNE @3 + CALL CompareText + TEST EAX,EAX + JNZ @3 +@1: MOV AL,1 +@2: RET +@3: XOR EAX,EAX +end; + +function SameText(const S1, S2: string; LocaleOptions: TLocaleOptions): Boolean; +begin + if LocaleOptions = loUserLocale then + Result := AnsiSameText(S1, S2) + else + Result := SameText(S1, S2); +end; + +function AnsiUpperCase(const S: string): string; +{$IFDEF MSWINDOWS} +var + Len: Integer; +begin + Len := Length(S); + SetString(Result, PChar(S), Len); + if Len > 0 then CharUpperBuff(Pointer(Result), Len); +end; +{$ENDIF} +{$IFDEF LINUX} +begin + Result := WideUpperCase(S); +end; +{$ENDIF} + +function AnsiLowerCase(const S: string): string; +{$IFDEF MSWINDOWS} +var + Len: Integer; +begin + Len := Length(S); + SetString(Result, PChar(S), Len); + if Len > 0 then CharLowerBuff(Pointer(Result), Len); +end; +{$ENDIF} +{$IFDEF LINUX} +begin + Result := WideLowerCase(S); +end; +{$ENDIF} + +function AnsiCompareStr(const S1, S2: string): Integer; +begin +{$IFDEF MSWINDOWS} + Result := CompareString(LOCALE_USER_DEFAULT, 0, PChar(S1), Length(S1), + PChar(S2), Length(S2)) - 2; +{$ENDIF} +{$IFDEF LINUX} + // glibc 2.1.2 / 2.1.3 implementations of strcoll() and strxfrm() + // have severe capacity limits. Comparing two 100k strings may + // exhaust the stack and kill the process. + // Fixed in glibc 2.1.91 and later. + Result := strcoll(PChar(S1), PChar(S2)); +{$ENDIF} +end; + +function AnsiSameStr(const S1, S2: string): Boolean; +begin + Result := AnsiCompareStr(S1, S2) = 0; +end; + +function AnsiCompareText(const S1, S2: string): Integer; +begin +{$IFDEF MSWINDOWS} + Result := CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE, PChar(S1), + Length(S1), PChar(S2), Length(S2)) - 2; +{$ENDIF} +{$IFDEF LINUX} + Result := WideCompareText(S1, S2); +{$ENDIF} +end; + +function AnsiSameText(const S1, S2: string): Boolean; +begin + Result := AnsiCompareText(S1, S2) = 0; +end; + +function AnsiStrComp(S1, S2: PChar): Integer; +begin +{$IFDEF MSWINDOWS} + Result := CompareString(LOCALE_USER_DEFAULT, 0, S1, -1, S2, -1) - 2; +{$ENDIF} +{$IFDEF LINUX} + Result := strcoll(S1, S2); +{$ENDIF} +end; + +function AnsiStrIComp(S1, S2: PChar): Integer; +begin +{$IFDEF MSWINDOWS} + Result := CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE, S1, -1, + S2, -1) - 2; +{$ENDIF} +{$IFDEF LINUX} + Result := AnsiCompareText(S1, S2); +{$ENDIF} +end; + +// StrLenLimit: Scan Src for a null terminator up to MaxLen bytes +function StrLenLimit(Src: PChar; MaxLen: Cardinal): Cardinal; +begin + if Src = nil then + begin + Result := 0; + Exit; + end; + Result := MaxLen; + while (Src^ <> #0) and (Result > 0) do + begin + Inc(Src); + Dec(Result); + end; + Result := MaxLen - Result; +end; + +{ StrBufLimit: Return a pointer to a buffer that contains no more than MaxLen + bytes of Src, avoiding heap allocation if possible. + If clipped Src length is less than MaxLen, return Src. Allocated = False. + If clipped Src length is less than StaticBufLen, return StaticBuf with a + copy of Src. Allocated = False. + Otherwise, return a heap allocated buffer with a copy of Src. Allocated = True. +} +function StrBufLimit(Src: PChar; MaxLen: Cardinal; StaticBuf: PChar; + StaticBufLen: Cardinal; var Allocated: Boolean): PChar; +var + Len: Cardinal; +begin + Len := StrLenLimit(Src, MaxLen); + Allocated := False; + if Len < MaxLen then + Result := Src + else + begin + if Len < StaticBufLen then + Result := StaticBuf + else + begin + GetMem(Result, Len+1); + Allocated := True; + end; + Move(Src^, Result^, Len); + Result[Len] := #0; + end; +end; + +function InternalAnsiStrLComp(S1, S2: PChar; MaxLen: Cardinal; CaseSensitive: Boolean): Integer; +var + Buf1, Buf2: array [0..4095] of Char; + P1, P2: PChar; + Allocated1, Allocated2: Boolean; +begin + // glibc has no length-limited strcoll! + P1 := nil; + P2 := nil; + Allocated1 := False; + Allocated2 := False; + try + P1 := StrBufLimit(S1, MaxLen, Buf1, High(Buf1), Allocated1); + P2 := StrBufLimit(S2, MaxLen, Buf2, High(Buf2), Allocated2); + if CaseSensitive then + Result := AnsiStrComp(P1, P2) + else + Result := AnsiStrIComp(P1, P2); + finally + if Allocated1 then + FreeMem(P1); + if Allocated2 then + FreeMem(P2); + end; +end; + +function AnsiStrLComp(S1, S2: PChar; MaxLen: Cardinal): Integer; +{$IFDEF MSWINDOWS} +begin + Result := CompareString(LOCALE_USER_DEFAULT, 0, + S1, MaxLen, S2, MaxLen) - 2; +end; +{$ENDIF} +{$IFDEF LINUX} +begin + Result := InternalAnsiStrLComp(S1, S2, MaxLen, True); +end; +{$ENDIF} + +function AnsiStrLIComp(S1, S2: PChar; MaxLen: Cardinal): Integer; +begin +{$IFDEF MSWINDOWS} + Result := CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE, + S1, MaxLen, S2, MaxLen) - 2; +{$ENDIF} +{$IFDEF LINUX} + Result := InternalAnsiStrLComp(S1, S2, MaxLen, False); +{$ENDIF} +end; + +function AnsiStrLower(Str: PChar): PChar; +{$IFDEF MSWINDOWS} +begin + CharLower(Str); + Result := Str; +end; +{$ENDIF} +{$IFDEF LINUX} +var + Temp: WideString; + Squish: AnsiString; + I: Integer; +begin + Temp := Str; // expand and copy multibyte to widechar + for I := 1 to Length(Temp) do + Temp[I] := WideChar(towlower(UCS4Char(Temp[I]))); + Squish := Temp; // reduce and copy widechar to multibyte + + if Cardinal(Length(Squish)) > StrLen(Str) then + raise ERangeError.CreateRes(@SRangeError); + + Move(Squish[1], Str^, Length(Squish)); + Result := Str; +end; +{$ENDIF} + +function AnsiStrUpper(Str: PChar): PChar; +{$IFDEF MSWINDOWS} +begin + CharUpper(Str); + Result := Str; +end; +{$ENDIF} +{$IFDEF LINUX} +var + Temp: WideString; + Squish: AnsiString; + I: Integer; +begin + Temp := Str; // expand and copy multibyte to widechar + for I := 1 to Length(Temp) do + Temp[I] := WideChar(towupper(UCS4Char(Temp[I]))); + Squish := Temp; // reduce and copy widechar to multibyte + if Cardinal(Length(Squish)) > StrLen(Str) then + raise ERangeError.CreateRes(@SRangeError); + + Move(Squish[1], Str^, Length(Squish)); + Result := Str; +end; +{$ENDIF} + +function WideUpperCase(const S: WideString): WideString; +{$IFDEF MSWINDOWS} +var + Len: Integer; +begin + // CharUpperBuffW is stubbed out on Win9x platofmrs + if Win32Platform = VER_PLATFORM_WIN32_NT then + begin + Len := Length(S); + SetString(Result, PWideChar(S), Len); + if Len > 0 then CharUpperBuffW(Pointer(Result), Len); + end + else + Result := AnsiUpperCase(S); +end; +{$ENDIF} +{$IFDEF LINUX} +var + I: Integer; + P: PWideChar; +begin + SetLength(Result, Length(S)); + P := @Result[1]; + for I := 1 to Length(S) do + P[I-1] := WideChar(towupper(UCS4Char(S[I]))); +end; +{$ENDIF} + +function WideLowerCase(const S: WideString): WideString; +{$IFDEF MSWINDOWS} +var + Len: Integer; +begin + // CharLowerBuffW is stubbed out on Win9x platofmrs + if Win32Platform = VER_PLATFORM_WIN32_NT then + begin + Len := Length(S); + SetString(Result, PWideChar(S), Len); + if Len > 0 then CharLowerBuffW(Pointer(Result), Len); + end + else + Result := AnsiLowerCase(S); +end; +{$ENDIF} +{$IFDEF LINUX} +var + I: Integer; + P: PWideChar; +begin + SetLength(Result, Length(S)); + P := @Result[1]; + for I := 1 to Length(S) do + P[I-1] := WideChar(towlower(UCS4Char(S[I]))); +end; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function DumbItDownFor95(const S1, S2: WideString; CmpFlags: Integer): Integer; +var + a1, a2: AnsiString; +begin + a1 := s1; + a2 := s2; + Result := CompareStringA(LOCALE_USER_DEFAULT, CmpFlags, PChar(a1), Length(a1), + PChar(a2), Length(a2)) - 2; +end; +{$ENDIF} + +function WideCompareStr(const S1, S2: WideString): Integer; +{$IFDEF MSWINDOWS} +begin + SetLastError(0); + Result := CompareStringW(LOCALE_USER_DEFAULT, 0, PWideChar(S1), Length(S1), + PWideChar(S2), Length(S2)) - 2; + case GetLastError of + 0: ; + ERROR_CALL_NOT_IMPLEMENTED: Result := DumbItDownFor95(S1, S2, 0); + else + RaiseLastOSError; + end; +end; +{$ENDIF} +{$IFDEF LINUX} +var + UCS4_S1, UCS4_S2: UCS4String; +begin + UCS4_S1 := WideStringToUCS4String(S1); + UCS4_S2 := WideStringToUCS4String(S2); + // glibc 2.1.2 / 2.1.3 implementations of wcscoll() and wcsxfrm() + // have severe capacity limits. Comparing two 100k strings may + // exhaust the stack and kill the process. + // Fixed in glibc 2.1.91 and later. + SetLastError(0); + Result := wcscoll(PUCS4Chars(UCS4_S1), PUCS4Chars(UCS4_S2)); + if GetLastError <> 0 then + RaiseLastOSError; +end; +{$ENDIF} + +function WideSameStr(const S1, S2: WideString): Boolean; +begin + Result := WideCompareStr(S1, S2) = 0; +end; + +function WideCompareText(const S1, S2: WideString): Integer; +begin +{$IFDEF MSWINDOWS} + SetLastError(0); + Result := CompareStringW(LOCALE_USER_DEFAULT, NORM_IGNORECASE, PWideChar(S1), + Length(S1), PWideChar(S2), Length(S2)) - 2; + case GetLastError of + 0: ; + ERROR_CALL_NOT_IMPLEMENTED: Result := DumbItDownFor95(S1, S2, NORM_IGNORECASE); + else + RaiseLastOSError; + end; +{$ENDIF} +{$IFDEF LINUX} + Result := WideCompareStr(WideUpperCase(S1), WideUpperCase(S2)); +{$ENDIF} +end; + +function WideSameText(const S1, S2: WideString): Boolean; +begin + Result := WideCompareText(S1, S2) = 0; +end; + +function Trim(const S: string): string; +var + I, L: Integer; +begin + L := Length(S); + I := 1; + while (I <= L) and (S[I] <= ' ') do Inc(I); + if I > L then Result := '' else + begin + while S[L] <= ' ' do Dec(L); + Result := Copy(S, I, L - I + 1); + end; +end; + +function Trim(const S: WideString): WideString; +var + I, L: Integer; +begin + L := Length(S); + I := 1; + while (I <= L) and (S[I] <= ' ') do Inc(I); + if I > L then + Result := '' + else + begin + while S[L] <= ' ' do Dec(L); + Result := Copy(S, I, L - I + 1); + end; +end; + +function TrimLeft(const S: string): string; +var + I, L: Integer; +begin + L := Length(S); + I := 1; + while (I <= L) and (S[I] <= ' ') do Inc(I); + Result := Copy(S, I, Maxint); +end; + +function TrimLeft(const S: WideString): WideString; +var + I, L: Integer; +begin + L := Length(S); + I := 1; + while (I <= L) and (S[I] <= ' ') do Inc(I); + Result := Copy(S, I, Maxint); +end; + +function TrimRight(const S: string): string; +var + I: Integer; +begin + I := Length(S); + while (I > 0) and (S[I] <= ' ') do Dec(I); + Result := Copy(S, 1, I); +end; + +function TrimRight(const S: WideString): WideString; +var + I: Integer; +begin + I := Length(S); + while (I > 0) and (S[I] <= ' ') do Dec(I); + Result := Copy(S, 1, I); +end; + +function QuotedStr(const S: string): string; +var + I: Integer; +begin + Result := S; + for I := Length(Result) downto 1 do + if Result[I] = '''' then Insert('''', Result, I); + Result := '''' + Result + ''''; +end; + +function AnsiQuotedStr(const S: string; Quote: Char): string; +var + P, Src, Dest: PChar; + AddCount: Integer; +begin + AddCount := 0; + P := AnsiStrScan(PChar(S), Quote); + while P <> nil do + begin + Inc(P); + Inc(AddCount); + P := AnsiStrScan(P, Quote); + end; + if AddCount = 0 then + begin + Result := Quote + S + Quote; + Exit; + end; + SetLength(Result, Length(S) + AddCount + 2); + Dest := Pointer(Result); + Dest^ := Quote; + Inc(Dest); + Src := Pointer(S); + P := AnsiStrScan(Src, Quote); + repeat + Inc(P); + Move(Src^, Dest^, P - Src); + Inc(Dest, P - Src); + Dest^ := Quote; + Inc(Dest); + Src := P; + P := AnsiStrScan(Src, Quote); + until P = nil; + P := StrEnd(Src); + Move(Src^, Dest^, P - Src); + Inc(Dest, P - Src); + Dest^ := Quote; +end; + +function AnsiExtractQuotedStr(var Src: PChar; Quote: Char): string; +var + P, Dest: PChar; + DropCount: Integer; +begin + Result := ''; + if (Src = nil) or (Src^ <> Quote) then Exit; + Inc(Src); + DropCount := 1; + P := Src; + Src := AnsiStrScan(Src, Quote); + while Src <> nil do // count adjacent pairs of quote chars + begin + Inc(Src); + if Src^ <> Quote then Break; + Inc(Src); + Inc(DropCount); + Src := AnsiStrScan(Src, Quote); + end; + if Src = nil then Src := StrEnd(P); + if ((Src - P) <= 1) or ((Src - P - DropCount) = 0) then Exit; + if DropCount = 1 then + SetString(Result, P, Src - P - 1) + else + begin + SetLength(Result, Src - P - DropCount); + Dest := PChar(Result); + Src := AnsiStrScan(P, Quote); + while Src <> nil do + begin + Inc(Src); + if Src^ <> Quote then Break; + Move(P^, Dest^, Src - P); + Inc(Dest, Src - P); + Inc(Src); + P := Src; + Src := AnsiStrScan(Src, Quote); + end; + if Src = nil then Src := StrEnd(P); + Move(P^, Dest^, Src - P - 1); + end; +end; + +function AnsiDequotedStr(const S: string; AQuote: Char): string; +var + LText: PChar; +begin + LText := PChar(S); + Result := AnsiExtractQuotedStr(LText, AQuote); + if ((Result = '') or (LText^ = #0)) and + (Length(S) > 0) and ((S[1] <> AQuote) or (S[Length(S)] <> AQuote)) then + Result := S; +end; + +function AdjustLineBreaks(const S: string; Style: TTextLineBreakStyle): string; +var + Source, SourceEnd, Dest: PChar; + DestLen: Integer; + L: Integer; +begin + Source := Pointer(S); + SourceEnd := Source + Length(S); + DestLen := Length(S); + while Source < SourceEnd do + begin + case Source^ of + #10: + if Style = tlbsCRLF then + Inc(DestLen); + #13: + if Style = tlbsCRLF then + if Source[1] = #10 then + Inc(Source) + else + Inc(DestLen) + else + if Source[1] = #10 then + Dec(DestLen); + else + if Source^ in LeadBytes then + begin + Source := StrNextChar(Source); + continue; + end; + end; + Inc(Source); + end; + if DestLen = Length(Source) then + Result := S + else + begin + Source := Pointer(S); + SetString(Result, nil, DestLen); + Dest := Pointer(Result); + while Source < SourceEnd do + case Source^ of + #10: + begin + if Style = tlbsCRLF then + begin + Dest^ := #13; + Inc(Dest); + end; + Dest^ := #10; + Inc(Dest); + Inc(Source); + end; + #13: + begin + if Style = tlbsCRLF then + begin + Dest^ := #13; + Inc(Dest); + end; + Dest^ := #10; + Inc(Dest); + Inc(Source); + if Source^ = #10 then Inc(Source); + end; + else + if Source^ in LeadBytes then + begin + L := StrCharLength(Source); + Move(Source^, Dest^, L); + Inc(Dest, L); + Inc(Source, L); + continue; + end; + Dest^ := Source^; + Inc(Dest); + Inc(Source); + end; + end; +end; + +function IsValidIdent(const Ident: string; AllowDots: Boolean): Boolean; +const + Alpha = ['A'..'Z', 'a'..'z', '_']; + AlphaNumeric = Alpha + ['0'..'9']; + AlphaNumericDot = AlphaNumeric + ['.']; +var + I: Integer; +begin + Result := False; + if (Length(Ident) = 0) or not (Ident[1] in Alpha) then Exit; + if AllowDots then + for I := 2 to Length(Ident) do + begin + if not (Ident[I] in AlphaNumericDot) then Exit + end + else + for I := 2 to Length(Ident) do if not (Ident[I] in AlphaNumeric) then Exit; + Result := True; +end; + +procedure CvtInt; +{ IN: + EAX: The integer value to be converted to text + ESI: Ptr to the right-hand side of the output buffer: LEA ESI, StrBuf[16] + ECX: Base for conversion: 0 for signed decimal, 10 or 16 for unsigned + EDX: Precision: zero padded minimum field width + OUT: + ESI: Ptr to start of converted text (not start of buffer) + ECX: Length of converted text +} +asm + OR CL,CL + JNZ @CvtLoop +@C1: OR EAX,EAX + JNS @C2 + NEG EAX + CALL @C2 + MOV AL,'-' + INC ECX + DEC ESI + MOV [ESI],AL + RET +@C2: MOV ECX,10 + +@CvtLoop: + PUSH EDX + PUSH ESI +@D1: XOR EDX,EDX + DIV ECX + DEC ESI + ADD DL,'0' + CMP DL,'0'+10 + JB @D2 + ADD DL,('A'-'0')-10 +@D2: MOV [ESI],DL + OR EAX,EAX + JNE @D1 + POP ECX + POP EDX + SUB ECX,ESI + SUB EDX,ECX + JBE @D5 + ADD ECX,EDX + MOV AL,'0' + SUB ESI,EDX + JMP @z +@zloop: MOV [ESI+EDX],AL +@z: DEC EDX + JNZ @zloop + MOV [ESI],AL +@D5: +end; + +procedure CvtIntW; +{ IN: + EAX: The integer value to be converted to text + ESI: Ptr to the right-hand side of the widechar output buffer: LEA ESI, WStrBuf[32] + ECX: Base for conversion: 0 for signed decimal, 10 or 16 for unsigned + EDX: Precision: zero padded minimum field width + OUT: + ESI: Ptr to start of converted widechar text (not start of buffer) + ECX: Character length of converted text +} +asm + OR CL,CL + JNZ @CvtLoop +@C1: OR EAX,EAX + JNS @C2 + NEG EAX + CALL @C2 + MOV AX,'-' + MOV [ESI-2],AX + SUB ESI, 2 + INC ECX + RET +@C2: MOV ECX,10 + +@CvtLoop: + PUSH EDX + PUSH ESI +@D1: XOR EDX,EDX + DIV ECX + ADD DX,'0' + SUB ESI,2 + CMP DX,'0'+10 + JB @D2 + ADD DX,('A'-'0')-10 +@D2: MOV [ESI],DX + OR EAX,EAX + JNE @D1 + POP ECX + POP EDX + SUB ECX,ESI + SHR ECX, 1 + SUB EDX,ECX + JBE @D5 + ADD ECX,EDX + SUB ESI,EDX + MOV AX,'0' + SUB ESI,EDX + JMP @z +@zloop: MOV [ESI+EDX*2],AX +@z: DEC EDX + JNZ @zloop + MOV [ESI],AX +@D5: +end; + +function IntToStr(Value: Integer): string; +// FmtStr(Result, '%d', [Value]); +asm + PUSH ESI + MOV ESI, ESP + SUB ESP, 16 + XOR ECX, ECX // base: 0 for signed decimal + PUSH EDX // result ptr + XOR EDX, EDX // zero filled field width: 0 for no leading zeros + CALL CvtInt + MOV EDX, ESI + POP EAX // result ptr + CALL System.@LStrFromPCharLen + ADD ESP, 16 + POP ESI +end; + +procedure CvtInt64W; +{ IN: + EAX: Address of the int64 value to be converted to text + ESI: Ptr to the right-hand side of the widechar output buffer: LEA ESI, WStrBuf[32] + ECX: Base for conversion: 10 or 16 + EDX: Precision: zero padded minimum field width + OUT: + ESI: Ptr to start of converted widechar text (not start of buffer) + ECX: Character length of converted text +} +asm + OR CL, CL + JNZ @start + MOV ECX, 10 + TEST [EAX + 4], $80000000 + JZ @start + PUSH [EAX + 4] + PUSH [EAX] + MOV EAX, ESP + NEG [ESP] // negate the value + ADC [ESP + 4],0 + NEG [ESP + 4] + CALL @start + INC ECX + MOV [ESI-2].Word, '-' + SUB ESI, 2 + ADD ESP, 8 + JMP @done + +@start: + PUSH ESI + SUB ESP, 4 + FNSTCW [ESP+2].Word // save + FNSTCW [ESP].Word // scratch + OR [ESP].Word, $0F00 // trunc toward zero, full precision + FLDCW [ESP].Word + + MOV [ESP].Word, CX + FLD1 + TEST [EAX + 4], $80000000 // test for negative + JZ @ld1 // FPU doesn't understand unsigned ints + PUSH [EAX + 4] // copy value before modifying + PUSH [EAX] + AND [ESP + 4], $7FFFFFFF // clear the sign bit + PUSH $7FFFFFFF + PUSH $FFFFFFFF + FILD [ESP + 8].QWord // load value + FILD [ESP].QWord + FADD ST(0), ST(2) // Add 1. Produces unsigned $80000000 in ST(0) + FADDP ST(1), ST(0) // Add $80000000 to value to replace the sign bit + ADD ESP, 16 + JMP @ld2 +@ld1: + FILD [EAX].QWord // value +@ld2: + FILD [ESP].Word // base + FLD ST(1) +@loop: + SUB ESI, 2 + FPREM // accumulator mod base + FISTP [ESI].Word + FDIV ST(1), ST(0) // accumulator := acumulator / base + MOV AX, [ESI].Word // overlap long division op with int ops + ADD AX, '0' + CMP AX, '0'+10 + JB @store + ADD AX, ('A'-'0')-10 +@store: + MOV [ESI].Word, AX + FLD ST(1) // copy accumulator + FCOM ST(3) // if accumulator >= 1.0 then loop + FSTSW AX + SAHF + JAE @loop + + FLDCW [ESP+2].Word + ADD ESP,4 + + FFREE ST(3) + FFREE ST(2) + FFREE ST(1); + FFREE ST(0); + +@zeropad: + POP ECX // original ESI + SUB ECX,ESI + SHR ECX, 1 // ECX = char length of converted string + OR EDX,EDX + JS @done + SUB EDX,ECX + JBE @done // output longer than field width = no pad + SUB ESI,EDX + MOV AX,'0' + SUB ESI,EDX + ADD ECX,EDX + JMP @z +@zloop: MOV [ESI+EDX*2].Word,AX +@z: DEC EDX + JNZ @zloop + MOV [ESI].Word,AX +@done: +end; + +procedure CvtInt64; +{ IN: + EAX: Address of the int64 value to be converted to text + ESI: Ptr to the right-hand side of the output buffer: LEA ESI, StrBuf[32] + ECX: Base for conversion: 0 for signed decimal, or 10 or 16 for unsigned + EDX: Precision: zero padded minimum field width + OUT: + ESI: Ptr to start of converted text (not start of buffer) + ECX: Byte length of converted text +} +asm + OR CL, CL + JNZ @start // CL = 0 => signed integer conversion + MOV ECX, 10 + TEST [EAX + 4], $80000000 + JZ @start + PUSH [EAX + 4] + PUSH [EAX] + MOV EAX, ESP + NEG [ESP] // negate the value + ADC [ESP + 4],0 + NEG [ESP + 4] + CALL @start // perform unsigned conversion + MOV [ESI-1].Byte, '-' // tack on the negative sign + DEC ESI + INC ECX + ADD ESP, 8 + RET + +@start: // perform unsigned conversion + PUSH ESI + SUB ESP, 4 + FNSTCW [ESP+2].Word // save + FNSTCW [ESP].Word // scratch + OR [ESP].Word, $0F00 // trunc toward zero, full precision + FLDCW [ESP].Word + + MOV [ESP].Word, CX + FLD1 + TEST [EAX + 4], $80000000 // test for negative + JZ @ld1 // FPU doesn't understand unsigned ints + PUSH [EAX + 4] // copy value before modifying + PUSH [EAX] + AND [ESP + 4], $7FFFFFFF // clear the sign bit + PUSH $7FFFFFFF + PUSH $FFFFFFFF + FILD [ESP + 8].QWord // load value + FILD [ESP].QWord + FADD ST(0), ST(2) // Add 1. Produces unsigned $80000000 in ST(0) + FADDP ST(1), ST(0) // Add $80000000 to value to replace the sign bit + ADD ESP, 16 + JMP @ld2 +@ld1: + FILD [EAX].QWord // value +@ld2: + FILD [ESP].Word // base + FLD ST(1) +@loop: + DEC ESI + FPREM // accumulator mod base + FISTP [ESP].Word + FDIV ST(1), ST(0) // accumulator := acumulator / base + MOV AL, [ESP].Byte // overlap long FPU division op with int ops + ADD AL, '0' + CMP AL, '0'+10 + JB @store + ADD AL, ('A'-'0')-10 +@store: + MOV [ESI].Byte, AL + FLD ST(1) // copy accumulator + FCOM ST(3) // if accumulator >= 1.0 then loop + FSTSW AX + SAHF + JAE @loop + + FLDCW [ESP+2].Word + ADD ESP,4 + + FFREE ST(3) + FFREE ST(2) + FFREE ST(1); + FFREE ST(0); + + POP ECX // original ESI + SUB ECX, ESI // ECX = length of converted string + SUB EDX,ECX + JBE @done // output longer than field width = no pad + SUB ESI,EDX + MOV AL,'0' + ADD ECX,EDX + JMP @z +@zloop: MOV [ESI+EDX].Byte,AL +@z: DEC EDX + JNZ @zloop + MOV [ESI].Byte,AL +@done: +end; + +function IntToStr(Value: Int64): string; +// FmtStr(Result, '%d', [Value]); +asm + PUSH ESI + MOV ESI, ESP + SUB ESP, 32 // 32 chars + XOR ECX, ECX // base 10 signed + PUSH EAX // result ptr + XOR EDX, EDX // zero filled field width: 0 for no leading zeros + LEA EAX, Value; + CALL CvtInt64 + + MOV EDX, ESI + POP EAX // result ptr + CALL System.@LStrFromPCharLen + ADD ESP, 32 + POP ESI +end; + +function IntToHex(Value: Integer; Digits: Integer): string; +// FmtStr(Result, '%.*x', [Digits, Value]); +asm + CMP EDX, 32 // Digits < buffer length? + JBE @A1 + XOR EDX, EDX +@A1: PUSH ESI + MOV ESI, ESP + SUB ESP, 32 + PUSH ECX // result ptr + MOV ECX, 16 // base 16 EDX = Digits = field width + CALL CvtInt + MOV EDX, ESI + POP EAX // result ptr + CALL System.@LStrFromPCharLen + ADD ESP, 32 + POP ESI +end; + +function IntToHex(Value: Int64; Digits: Integer): string; +// FmtStr(Result, '%.*x', [Digits, Value]); +asm + CMP EAX, 32 // Digits < buffer length? + JLE @A1 + XOR EAX, EAX +@A1: PUSH ESI + MOV ESI, ESP + SUB ESP, 32 // 32 chars + MOV ECX, 16 // base 16 + PUSH EDX // result ptr + MOV EDX, EAX // zero filled field width: 0 for no leading zeros + LEA EAX, Value; + CALL CvtInt64 + + MOV EDX, ESI + POP EAX // result ptr + CALL System.@LStrFromPCharLen + ADD ESP, 32 + POP ESI +end; + +function StrToInt(const S: string): Integer; +var + E: Integer; +begin + Val(S, Result, E); + if E <> 0 then ConvertErrorFmt(@SInvalidInteger, [S]); +end; + +function StrToIntDef(const S: string; Default: Integer): Integer; +var + E: Integer; +begin + Val(S, Result, E); + if E <> 0 then Result := Default; +end; + +function TryStrToInt(const S: string; out Value: Integer): Boolean; +var + E: Integer; +begin + Val(S, Value, E); + Result := E = 0; +end; + +function StrToInt64(const S: string): Int64; +var + E: Integer; +begin + Val(S, Result, E); + if E <> 0 then ConvertErrorFmt(@SInvalidInteger, [S]); +end; + +function StrToInt64Def(const S: string; const Default: Int64): Int64; +var + E: Integer; +begin + Val(S, Result, E); + if E <> 0 then Result := Default; +end; + +function TryStrToInt64(const S: string; out Value: Int64): Boolean; +var + E: Integer; +begin + Val(S, Value, E); + Result := E = 0; +end; + +procedure VerifyBoolStrArray; +begin + if Length(TrueBoolStrs) = 0 then + begin + SetLength(TrueBoolStrs, 1); + TrueBoolStrs[0] := DefaultTrueBoolStr; + end; + if Length(FalseBoolStrs) = 0 then + begin + SetLength(FalseBoolStrs, 1); + FalseBoolStrs[0] := DefaultFalseBoolStr; + end; +end; + +function StrToBool(const S: string): Boolean; +begin + if not TryStrToBool(S, Result) then + ConvertErrorFmt(@SInvalidBoolean, [S]); +end; + +function StrToBoolDef(const S: string; const Default: Boolean): Boolean; +begin + if not TryStrToBool(S, Result) then + Result := Default; +end; + +function TryStrToBool(const S: string; out Value: Boolean): Boolean; + function CompareWith(const aArray: array of string): Boolean; + var + I: Integer; + begin + Result := False; + for I := Low(aArray) to High(aArray) do + if AnsiSameText(S, aArray[I]) then + begin + Result := True; + Break; + end; + end; +var + LResult: Extended; +begin + Result := TryStrToFloat(S, LResult); + if Result then + Value := LResult <> 0 + else + begin + VerifyBoolStrArray; + Result := CompareWith(TrueBoolStrs); + if Result then + Value := True + else + begin + Result := CompareWith(FalseBoolStrs); + if Result then + Value := False; + end; + end; +end; + +function BoolToStr(B: Boolean; UseBoolStrs: Boolean = False): string; +const + cSimpleBoolStrs: array [boolean] of String = ('0', '-1'); +begin + if UseBoolStrs then + begin + VerifyBoolStrArray; + if B then + Result := TrueBoolStrs[0] + else + Result := FalseBoolStrs[0]; + end + else + Result := cSimpleBoolStrs[B]; +end; + +type + PStrData = ^TStrData; + TStrData = record + Ident: Integer; + Str: string; + end; + +function EnumStringModules(Instance: Longint; Data: Pointer): Boolean; +{$IFDEF MSWINDOWS} +var + Buffer: array [0..1023] of char; +begin + with PStrData(Data)^ do + begin + SetString(Str, Buffer, + LoadString(Instance, Ident, Buffer, sizeof(Buffer))); + Result := Str = ''; + end; +end; +{$ENDIF} +{$IFDEF LINUX} +var + rs: TResStringRec; + Module: HModule; +begin + Module := Instance; + rs.Module := @Module; + with PStrData(Data)^ do + begin + rs.Identifier := Ident; + Str := LoadResString(@rs); + Result := Str = ''; + end; +end; +{$ENDIF} + +function FindStringResource(Ident: Integer): string; +var + StrData: TStrData; +begin + StrData.Ident := Ident; + StrData.Str := ''; + EnumResourceModules(EnumStringModules, @StrData); + Result := StrData.Str; +end; + +function LoadStr(Ident: Integer): string; +begin + Result := FindStringResource(Ident); +end; + +function FmtLoadStr(Ident: Integer; const Args: array of const): string; +begin + FmtStr(Result, FindStringResource(Ident), Args); +end; + +{ File management routines } + +function FileOpen(const FileName: string; Mode: LongWord): Integer; +{$IFDEF MSWINDOWS} +const + AccessMode: array[0..2] of LongWord = ( + GENERIC_READ, + GENERIC_WRITE, + GENERIC_READ or GENERIC_WRITE); + ShareMode: array[0..4] of LongWord = ( + 0, + 0, + FILE_SHARE_READ, + FILE_SHARE_WRITE, + FILE_SHARE_READ or FILE_SHARE_WRITE); +begin + Result := -1; + if ((Mode and 3) <= fmOpenReadWrite) and + ((Mode and $F0) <= fmShareDenyNone) then + Result := Integer(CreateFile(PChar(FileName), AccessMode[Mode and 3], + ShareMode[(Mode and $F0) shr 4], nil, OPEN_EXISTING, + FILE_ATTRIBUTE_NORMAL, 0)); +end; +{$ENDIF} +{$IFDEF LINUX} +const + ShareMode: array[0..fmShareDenyNone shr 4] of Byte = ( + 0, //No share mode specified + F_WRLCK, //fmShareExclusive + F_RDLCK, //fmShareDenyWrite + 0); //fmShareDenyNone +var + FileHandle, Tvar: Integer; + LockVar: TFlock; + smode: Byte; +begin + Result := -1; + if FileExists(FileName) and + ((Mode and 3) <= fmOpenReadWrite) and + ((Mode and $F0) <= fmShareDenyNone) then + begin + FileHandle := open(PChar(FileName), (Mode and 3), FileAccessRights); + + if FileHandle = -1 then Exit; + + smode := Mode and $F0 shr 4; + if ShareMode[smode] <> 0 then + begin + with LockVar do + begin + l_whence := SEEK_SET; + l_start := 0; + l_len := 0; + l_type := ShareMode[smode]; + end; + Tvar := fcntl(FileHandle, F_SETLK, LockVar); + if Tvar = -1 then + begin + __close(FileHandle); + Exit; + end; + end; + Result := FileHandle; + end; +end; +{$ENDIF} + +function FileCreate(const FileName: string): Integer; +{$IFDEF MSWINDOWS} +begin + Result := Integer(CreateFile(PChar(FileName), GENERIC_READ or GENERIC_WRITE, + 0, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)); +end; +{$ENDIF} +{$IFDEF LINUX} +begin + Result := FileCreate(FileName, FileAccessRights); +end; +{$ENDIF} + +function FileCreate(const FileName: string; Rights: Integer): Integer; +{$IFDEF MSWINDOWS} +begin + Result := FileCreate(FileName); +end; +{$ENDIF} +{$IFDEF LINUX} +begin + Result := Integer(open(PChar(FileName), O_RDWR or O_CREAT or O_TRUNC, Rights)); +end; +{$ENDIF} + +function FileRead(Handle: Integer; var Buffer; Count: LongWord): Integer; +begin +{$IFDEF MSWINDOWS} + if not ReadFile(THandle(Handle), Buffer, Count, LongWord(Result), nil) then + Result := -1; +{$ENDIF} +{$IFDEF LINUX} + Result := __read(Handle, Buffer, Count); +{$ENDIF} +end; + +function FileWrite(Handle: Integer; const Buffer; Count: LongWord): Integer; +begin +{$IFDEF MSWINDOWS} + if not WriteFile(THandle(Handle), Buffer, Count, LongWord(Result), nil) then + Result := -1; +{$ENDIF} +{$IFDEF LINUX} + Result := __write(Handle, Buffer, Count); +{$ENDIF} +end; + +function FileSeek(Handle, Offset, Origin: Integer): Integer; +begin +{$IFDEF MSWINDOWS} + Result := SetFilePointer(THandle(Handle), Offset, nil, Origin); +{$ENDIF} +{$IFDEF LINUX} + Result := __lseek(Handle, Offset, Origin); +{$ENDIF} +end; + +function FileSeek(Handle: Integer; const Offset: Int64; Origin: Integer): Int64; +{$IFDEF MSWINDOWS} +begin + Result := Offset; + Int64Rec(Result).Lo := SetFilePointer(THandle(Handle), Int64Rec(Result).Lo, + @Int64Rec(Result).Hi, Origin); + if (Int64Rec(Result).Lo = $FFFFFFFF) and (GetLastError <> 0) then + Int64Rec(Result).Hi := $FFFFFFFF; +end; +{$ENDIF} +{$IFDEF LINUX} +var + Temp: Integer; +begin + Temp := Offset; // allow for range-checking + Result := FileSeek(Handle, Temp, Origin); +end; +{$ENDIF} + +procedure FileClose(Handle: Integer); +begin +{$IFDEF MSWINDOWS} + CloseHandle(THandle(Handle)); +{$ENDIF} +{$IFDEF LINUX} + __close(Handle); // No need to unlock since all locks are released on close. +{$ENDIF} +end; + +function FileAge(const FileName: string): Integer; +{$IFDEF MSWINDOWS} +var + Handle: THandle; + FindData: TWin32FindData; + LocalFileTime: TFileTime; +begin + Handle := FindFirstFile(PChar(FileName), FindData); + if Handle <> INVALID_HANDLE_VALUE then + begin + Windows.FindClose(Handle); + if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then + begin + FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime); + if FileTimeToDosDateTime(LocalFileTime, LongRec(Result).Hi, + LongRec(Result).Lo) then Exit; + end; + end; + Result := -1; +end; +{$ENDIF} +{$IFDEF LINUX} +var + st: TStatBuf; +begin + if stat(PChar(FileName), st) = 0 then + Result := st.st_mtime + else + Result := -1; +end; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function FileAge(const FileName: string; out FileDateTime: TDateTime): Boolean; +var + Handle: THandle; + FindData: TWin32FindData; + LSystemTime: TSystemTime; + LocalFileTime: TFileTime; +begin + Result := False; + Handle := FindFirstFile(PChar(FileName), FindData); + if Handle <> INVALID_HANDLE_VALUE then + begin + Windows.FindClose(Handle); + if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then + begin + Result := True; + FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime); + FileTimeToSystemTime(LocalFileTime, LSystemTime); + with LSystemTime do + FileDateTime := EncodeDate(wYear, wMonth, wDay) + + EncodeTime(wHour, wMinute, wSecond, wMilliSeconds); + end; + end; +end; +{$ENDIF} + +function FileExists(const FileName: string): Boolean; +{$IFDEF MSWINDOWS} +var + Code: Integer; +begin + Code := GetFileAttributes(PChar(FileName)); + Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code = 0); +end; +{$ENDIF} +{$IFDEF LINUX} +begin + Result := euidaccess(PChar(FileName), F_OK) = 0; +end; +{$ENDIF} + +function DirectoryExists(const Directory: string): Boolean; +{$IFDEF LINUX} +var + st: TStatBuf; +begin + if stat(PChar(Directory), st) = 0 then + Result := S_ISDIR(st.st_mode) + else + Result := False; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +var + Code: Integer; +begin + Code := GetFileAttributes(PChar(Directory)); + Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0); +end; +{$ENDIF} + +function ForceDirectories(Dir: string): Boolean; +var + E: EInOutError; +begin + Result := True; + if Dir = '' then + begin + E := EInOutError.CreateRes(@SCannotCreateDir); + E.ErrorCode := 3; + raise E; + end; + Dir := ExcludeTrailingPathDelimiter(Dir); +{$IFDEF MSWINDOWS} + if (Length(Dir) < 3) or DirectoryExists(Dir) + or (ExtractFilePath(Dir) = Dir) then Exit; // avoid 'xyz:\' problem. +{$ENDIF} +{$IFDEF LINUX} + if (Dir = '') or DirectoryExists(Dir) then Exit; +{$ENDIF} + Result := ForceDirectories(ExtractFilePath(Dir)) and CreateDir(Dir); +end; + +function FileGetDate(Handle: Integer): Integer; +{$IFDEF MSWINDOWS} +var + FileTime, LocalFileTime: TFileTime; +begin + if GetFileTime(THandle(Handle), nil, nil, @FileTime) and + FileTimeToLocalFileTime(FileTime, LocalFileTime) and + FileTimeToDosDateTime(LocalFileTime, LongRec(Result).Hi, + LongRec(Result).Lo) then Exit; + Result := -1; +end; +{$ENDIF} +{$IFDEF LINUX} +var + st: TStatBuf; +begin + if fstat(Handle, st) = 0 then + Result := st.st_mtime + else + Result := -1; +end; +{$ENDIF} + +function FileSetDate(const FileName: string; Age: Integer): Integer; +{$IFDEF MSWINDOWS} +var + f: THandle; +begin + f := FileOpen(FileName, fmOpenWrite); + if f = THandle(-1) then + Result := GetLastError + else + begin + Result := FileSetDate(f, Age); + FileClose(f); + end; +end; +{$ENDIF} +{$IFDEF LINUX} +var + ut: TUTimeBuffer; +begin + Result := 0; + ut.actime := Age; + ut.modtime := Age; + if utime(PChar(FileName), @ut) = -1 then + Result := GetLastError; +end; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function FileSetDate(Handle: Integer; Age: Integer): Integer; +var + LocalFileTime, FileTime: TFileTime; +begin + Result := 0; + if DosDateTimeToFileTime(LongRec(Age).Hi, LongRec(Age).Lo, LocalFileTime) and + LocalFileTimeToFileTime(LocalFileTime, FileTime) and + SetFileTime(Handle, nil, nil, @FileTime) then Exit; + Result := GetLastError; +end; + +function FileGetAttr(const FileName: string): Integer; +begin + Result := GetFileAttributes(PChar(FileName)); +end; + +function FileSetAttr(const FileName: string; Attr: Integer): Integer; +begin + Result := 0; + if not SetFileAttributes(PChar(FileName), Attr) then + Result := GetLastError; +end; +{$ENDIF} + +function FileIsReadOnly(const FileName: string): Boolean; +begin +{$IFDEF MSWINDOWS} + Result := (GetFileAttributes(PChar(FileName)) and faReadOnly) <> 0; +{$ENDIF} +{$IFDEF LINUX} + Result := (euidaccess(PChar(FileName), R_OK) = 0) and + (euidaccess(PChar(FileName), W_OK) <> 0); +{$ENDIF} +end; + +function FileSetReadOnly(const FileName: string; ReadOnly: Boolean): Boolean; +{$IFDEF MSWINDOWS} +var + Flags: Integer; +begin + Result := False; + Flags := GetFileAttributes(PChar(FileName)); + if Flags = -1 then Exit; + if ReadOnly then + Flags := Flags or faReadOnly + else + Flags := Flags and not faReadOnly; + Result := SetFileAttributes(PChar(FileName), Flags); +end; +{$ENDIF} +{$IFDEF LINUX} +var + st: TStatBuf; + Flags: Integer; +begin + Result := False; + if stat(PChar(FileName), st) <> 0 then Exit; + if ReadOnly then + Flags := st.st_mode and not (S_IWUSR or S_IWGRP or S_IWOTH) + else + Flags := st.st_mode or (S_IWUSR or S_IWGRP or S_IWOTH); + Result := chmod(PChar(FileName), Flags) = 0; +end; +{$ENDIF} + + +function FindMatchingFile(var F: TSearchRec): Integer; +{$IFDEF MSWINDOWS} +var + LocalFileTime: TFileTime; +begin + with F do + begin + while FindData.dwFileAttributes and ExcludeAttr <> 0 do + if not FindNextFile(FindHandle, FindData) then + begin + Result := GetLastError; + Exit; + end; + FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime); + FileTimeToDosDateTime(LocalFileTime, LongRec(Time).Hi, + LongRec(Time).Lo); + Size := FindData.nFileSizeLow or Int64(FindData.nFileSizeHigh) shl 32; + Attr := FindData.dwFileAttributes; + Name := FindData.cFileName; + end; + Result := 0; +end; +{$ENDIF} +{$IFDEF LINUX} +var + PtrDirEnt: PDirEnt; + Scratch: TDirEnt; + StatBuf: TStatBuf; + LinkStatBuf: TStatBuf; + FName: string; + Attr: Integer; + Mode: mode_t; +begin + Result := -1; + PtrDirEnt := nil; + if readdir_r(F.FindHandle, @Scratch, PtrDirEnt) <> 0 then + Exit; + while PtrDirEnt <> nil do + begin + if fnmatch(PChar(F.Pattern), PtrDirEnt.d_name, 0) = 0 then + begin // F.PathOnly must include trailing backslash + FName := F.PathOnly + string(PtrDirEnt.d_name); + + if lstat(PChar(FName), StatBuf) = 0 then + begin + Attr := 0; + Mode := StatBuf.st_mode; + + if S_ISDIR(Mode) then + Attr := Attr or faDirectory + else + if not S_ISREG(Mode) then // directories shouldn't be treated as system files + begin + if S_ISLNK(Mode) then + begin + Attr := Attr or faSymLink; + if (stat(PChar(FName), LinkStatBuf) = 0) and + S_ISDIR(LinkStatBuf.st_mode) then + Attr := Attr or faDirectory + end; + Attr := Attr or faSysFile; + end; + + if (PtrDirEnt.d_name[0] = '.') and (PtrDirEnt.d_name[1] <> #0) then + begin + if not ((PtrDirEnt.d_name[1] = '.') and (PtrDirEnt.d_name[2] = #0)) then + Attr := Attr or faHidden; + end; + + if euidaccess(PChar(FName), W_OK) <> 0 then + Attr := Attr or faReadOnly; + + if Attr and F.ExcludeAttr = 0 then + begin + F.Size := StatBuf.st_size; + F.Attr := Attr; + F.Mode := StatBuf.st_mode; + F.Name := PtrDirEnt.d_name; + F.Time := StatBuf.st_mtime; + Result := 0; + Break; + end; + end; + end; + Result := -1; + if readdir_r(F.FindHandle, @Scratch, PtrDirEnt) <> 0 then + Break; + end // End of While +end; +{$ENDIF} + +function FindFirst(const Path: string; Attr: Integer; + var F: TSearchRec): Integer; +const + faSpecial = faHidden or faSysFile or faDirectory; +{$IFDEF MSWINDOWS} +begin + F.ExcludeAttr := not Attr and faSpecial; + F.FindHandle := FindFirstFile(PChar(Path), F.FindData); + if F.FindHandle <> INVALID_HANDLE_VALUE then + begin + Result := FindMatchingFile(F); + if Result <> 0 then FindClose(F); + end else + Result := GetLastError; +end; +{$ENDIF} +{$IFDEF LINUX} +begin + F.ExcludeAttr := not Attr and faSpecial; + F.PathOnly := ExtractFilePath(Path); + F.Pattern := ExtractFileName(Path); + if F.PathOnly = '' then + F.PathOnly := IncludeTrailingPathDelimiter(GetCurrentDir); + + F.FindHandle := opendir(PChar(F.PathOnly)); + if F.FindHandle <> nil then + begin + Result := FindMatchingFile(F); + if Result <> 0 then + FindClose(F); + end + else + Result:= GetLastError; +end; +{$ENDIF} + +function FindNext(var F: TSearchRec): Integer; +begin +{$IFDEF MSWINDOWS} + if FindNextFile(F.FindHandle, F.FindData) then + Result := FindMatchingFile(F) else + Result := GetLastError; +{$ENDIF} +{$IFDEF LINUX} + Result := FindMatchingFile(F); +{$ENDIF} +end; + +procedure FindClose(var F: TSearchRec); +begin +{$IFDEF MSWINDOWS} + if F.FindHandle <> INVALID_HANDLE_VALUE then + begin + Windows.FindClose(F.FindHandle); + F.FindHandle := INVALID_HANDLE_VALUE; + end; +{$ENDIF} +{$IFDEF LINUX} + if F.FindHandle <> nil then + begin + closedir(F.FindHandle); + F.FindHandle := nil; + end; +{$ENDIF} +end; + +function DeleteFile(const FileName: string): Boolean; +begin +{$IFDEF MSWINDOWS} + Result := Windows.DeleteFile(PChar(FileName)); +{$ENDIF} +{$IFDEF LINUX} + Result := unlink(PChar(FileName)) <> -1; +{$ENDIF} +end; + +function RenameFile(const OldName, NewName: string): Boolean; +begin +{$IFDEF MSWINDOWS} + Result := MoveFile(PChar(OldName), PChar(NewName)); +{$ENDIF} +{$IFDEF LINUX} + Result := __rename(PChar(OldName), PChar(NewName)) = 0; +{$ENDIF} +end; + +function IsAssembly(const FileName: string): Boolean; +var + Base: ^Byte; + Handle, Map: HWND; + DosHeader: PImageDosHeader; + Size: LongWord; +begin + Result := False; + Handle := CreateFile(PChar(FileName), GENERIC_READ, FILE_SHARE_READ, + nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); + Map := CreateFileMapping(Handle, nil, PAGE_READONLY, 0, 0, nil); + Base := MapViewOfFile(Map, FILE_MAP_READ, 0, 0, 0); + DosHeader := PImageDosHeader(Base); + + try + if (DosHeader = nil) or (ImageDirectoryEntryToData(Base, False, + IMAGE_DIRECTORY_ENTRY_COM_DESCRIPTOR, Size) = nil) then + begin + Exit; + end; + + Result := True; + finally + if Handle <> 0 then + begin + UnmapViewOfFile(Base); + CloseHandle(Map); + CloseHandle(Handle); + end; + end; +end; + +function AnsiStrLastChar(P: PChar): PChar; +var + LastByte: Integer; +begin + LastByte := StrLen(P) - 1; + Result := @P[LastByte]; +{$IFDEF MSWINDOWS} + if StrByteType(P, LastByte) = mbTrailByte then Dec(Result); +{$ENDIF} +{$IFDEF LINUX} + while StrByteType(P, Result - P) = mbTrailByte do Dec(Result); +{$ENDIF} +end; + +function AnsiLastChar(const S: string): PChar; +var + LastByte: Integer; +begin + LastByte := Length(S); + if LastByte <> 0 then + begin + while ByteType(S, LastByte) = mbTrailByte do Dec(LastByte); + Result := @S[LastByte]; + end + else + Result := nil; +end; + +function LastDelimiter(const Delimiters, S: string): Integer; +var + P: PChar; +begin + Result := Length(S); + P := PChar(Delimiters); + while Result > 0 do + begin + if (S[Result] <> #0) and (StrScan(P, S[Result]) <> nil) then +{$IFDEF MSWINDOWS} + if (ByteType(S, Result) = mbTrailByte) then + Dec(Result) + else + Exit; +{$ENDIF} +{$IFDEF LINUX} + begin + if (ByteType(S, Result) <> mbTrailByte) then + Exit; + Dec(Result); + while ByteType(S, Result) = mbTrailByte do Dec(Result); + end; +{$ENDIF} + Dec(Result); + end; +end; + +function ChangeFileExt(const FileName, Extension: string): string; +var + I: Integer; +begin + I := LastDelimiter('.' + PathDelim + DriveDelim,Filename); + if (I = 0) or (FileName[I] <> '.') then I := MaxInt; + Result := Copy(FileName, 1, I - 1) + Extension; +end; + +function ChangeFilePath(const FileName, Path: string): string; +begin + Result := IncludeTrailingPathDelimiter(Path) + ExtractFileName(FileName); +end; + +function ExtractFilePath(const FileName: string): string; +var + I: Integer; +begin + I := LastDelimiter(PathDelim + DriveDelim, FileName); + Result := Copy(FileName, 1, I); +end; + +function ExtractFileDir(const FileName: string): string; +var + I: Integer; +begin + I := LastDelimiter(PathDelim + DriveDelim, Filename); + if (I > 1) and (FileName[I] = PathDelim) and + (not IsDelimiter( PathDelim + DriveDelim, FileName, I-1)) then Dec(I); + Result := Copy(FileName, 1, I); +end; + +function ExtractFileDrive(const FileName: string): string; +{$IFDEF MSWINDOWS} +var + I, J: Integer; +begin + if (Length(FileName) >= 2) and (FileName[2] = DriveDelim) then + Result := Copy(FileName, 1, 2) + else if (Length(FileName) >= 2) and (FileName[1] = PathDelim) and + (FileName[2] = PathDelim) then + begin + J := 0; + I := 3; + While (I < Length(FileName)) and (J < 2) do + begin + if FileName[I] = PathDelim then Inc(J); + if J < 2 then Inc(I); + end; + if FileName[I] = PathDelim then Dec(I); + Result := Copy(FileName, 1, I); + end else Result := ''; +end; +{$ENDIF} +{$IFDEF LINUX} +begin + Result := ''; // Linux doesn't support drive letters +end; +{$ENDIF} + +function ExtractFileName(const FileName: string): string; +var + I: Integer; +begin + I := LastDelimiter(PathDelim + DriveDelim, FileName); + Result := Copy(FileName, I + 1, MaxInt); +end; + +function ExtractFileExt(const FileName: string): string; +var + I: Integer; +begin + I := LastDelimiter('.' + PathDelim + DriveDelim, FileName); + if (I > 0) and (FileName[I] = '.') then + Result := Copy(FileName, I, MaxInt) else + Result := ''; +end; + +function ExpandFileName(const FileName: string): string; +{$IFDEF MSWINDOWS} +var + FName: PChar; + Buffer: array[0..MAX_PATH - 1] of Char; +begin + SetString(Result, Buffer, GetFullPathName(PChar(FileName), SizeOf(Buffer), + Buffer, FName)); +end; +{$ENDIF} + +{$IFDEF LINUX} +function ExpandTilde(const InString: string): string; +var + W: wordexp_t; + SpacePos: Integer; + PostSpaceStr: string; +begin + Result := InString; + SpacePos := AnsiPos(' ', Result); // only expand stuff up to the first space in the filename + if SpacePos > 0 then // then just add the space and the rest of the string + PostSpaceStr := Copy(Result, SpacePos, Length(Result) - (SpacePos-1)); + case wordexp(PChar(Result), W, WRDE_NOCMD) of + 0: // success + begin + Result := PChar(W.we_wordv^); + wordfree(W); + end; + WRDE_NOSPACE: // error, but W may be partially allocated + wordfree(W); + end; + if PostSpaceStr <> '' then + Result := Result + PostSpaceStr; +end; + +var + I, J: Integer; + LastWasPathDelim: Boolean; + TempName: string; +begin + Result := ''; + if Length(Filename) = 0 then Exit; + + if FileName[1] = PathDelim then + TempName := FileName + else + begin + TempName := FileName; + if FileName[1] = '~' then + TempName := ExpandTilde(TempName) + else + TempName := IncludeTrailingPathDelimiter(GetCurrentDir) + TempName; + end; + + I := 1; + J := 1; + + LastWasPathDelim := False; + + while I <= Length(TempName) do + begin + case TempName[I] of + PathDelim: + if J < I then + begin + // Check for consecutive 'PathDelim' characters and skip them if present + if (I = 1) or (TempName[I - 1] <> PathDelim) then + Result := Result + Copy(TempName, J, I - J); + J := I; + // Set a flag indicating that we just processed a path delimiter + LastWasPathDelim := True; + end; + '.': + begin + // If the last character was a path delimiter then this '.' is + // possibly a relative path modifier + if LastWasPathDelim then + begin + // Check if the path ends in a '.' + if I < Length(TempName) then + begin + // If the next character is another '.' then this may be a relative path + // except if there is another '.' after that one. In this case simply + // treat this as just another filename. + if (TempName[I + 1] = '.') and + ((I + 1 >= Length(TempName)) or (TempName[I + 2] <> '.')) then + begin + // Don't attempt to backup past the Root dir + if Length(Result) > 1 then + // For the purpose of this excercise, treat the last dir as a + // filename so we can use this function to remove it + Result := ExtractFilePath(ExcludeTrailingPathDelimiter(Result)); + J := I; + end + // Simply skip over and ignore any 'current dir' constrcucts, './' + // or the remaining './' from a ../ constrcut. + else if TempName[I + 1] = PathDelim then + begin + Result := IncludeTrailingPathDelimiter(Result); + if TempName[I] in LeadBytes then + Inc(I, StrCharLength(@TempName[I])) + else + Inc(I); + J := I + 1; + end else + // If any of the above tests fail, then this is not a 'current dir' or + // 'parent dir' construct so just clear the state and continue. + LastWasPathDelim := False; + end else + begin + // Don't let the expanded path end in a 'PathDelim' character + Result := ExcludeTrailingPathDelimiter(Result); + J := I + 1; + end; + end; + end; + else + LastWasPathDelim := False; + end; + if TempName[I] in LeadBytes then + Inc(I, StrCharLength(@TempName[I])) + else + Inc(I); + end; + // This will finally append what is left + if (I - J > 1) or (TempName[I] <> PathDelim) then + Result := Result + Copy(TempName, J, I - J); +end; +{$ENDIF} + +function ExpandFileNameCase(const FileName: string; + out MatchFound: TFilenameCaseMatch): string; +var + SR: TSearchRec; + FullPath, Name: string; + Temp: Integer; + FoundOne: Boolean; + {$IFDEF LINUX} + Scans: Byte; + FirstLetter, TestLetter: string; + {$ENDIF} +begin + Result := ExpandFileName(FileName); + FullPath := ExtractFilePath(Result); + Name := ExtractFileName(Result); + MatchFound := mkNone; + + // if FullPath is not the root directory (portable) + if not SameFileName(FullPath, IncludeTrailingPathDelimiter(ExtractFileDrive(FullPath))) then + begin // Does the path need case-sensitive work? + Temp := FindFirst(FullPath, faAnyFile, SR); + FindClose(SR); // close search before going recursive + if Temp <> 0 then + begin + FullPath := ExcludeTrailingPathDelimiter(FullPath); + FullPath := ExpandFileNameCase(FullPath, MatchFound); + if MatchFound = mkNone then + Exit; // if we can't find the path, we certainly can't find the file! + FullPath := IncludeTrailingPathDelimiter(FullPath); + end; + end; + + // Path is validated / adjusted. Now for the file itself + try + if FindFirst(FullPath + Name, faAnyFile, SR)= 0 then // exact match on filename + begin + if not (MatchFound in [mkSingleMatch, mkAmbiguous]) then // path might have been inexact + MatchFound := mkExactMatch; + Result := FullPath + SR.Name; + Exit; + end; + finally + FindClose(SR); + end; + + FoundOne := False; // Windows should never get to here except for file-not-found + +{$IFDEF LINUX} + +{ Scan the directory. + To minimize the number of filenames tested, scan the directory + using upper/lowercase first letter + wildcard. + This results in two scans of the directory (particularly on Linux) but + vastly reduces the number of times we have to perform an expensive + locale-charset case-insensitive string compare. } + + // First, scan for lowercase first letter + FirstLetter := AnsiLowerCase(Name[1]); + for Scans := 0 to 1 do + begin + Temp := FindFirst(FullPath + FirstLetter + '*', faAnyFile, SR); + while Temp = 0 do + begin + if AnsiSameText(SR.Name, Name) then + begin + if FoundOne then + begin // this is the second match + MatchFound := mkAmbiguous; + Exit; + end + else + begin + FoundOne := True; + Result := FullPath + SR.Name; + end; + end; + Temp := FindNext(SR); + end; + FindClose(SR); + TestLetter := AnsiUpperCase(Name[1]); + if TestLetter = FirstLetter then Break; + FirstLetter := TestLetter; + end; +{$ENDIF} + + if MatchFound <> mkAmbiguous then + begin + if FoundOne then + MatchFound := mkSingleMatch + else + MatchFound := mkNone; + end; +end; + +{$IFDEF MSWINDOWS} +function GetUniversalName(const FileName: string): string; +type + PNetResourceArray = ^TNetResourceArray; + TNetResourceArray = array[0..MaxInt div SizeOf(TNetResource) - 1] of TNetResource; +var + I, BufSize, NetResult: Integer; + Count, Size: LongWord; + Drive: Char; + NetHandle: THandle; + NetResources: PNetResourceArray; + RemoteNameInfo: array[0..1023] of Byte; +begin + Result := FileName; + if (Win32Platform <> VER_PLATFORM_WIN32_WINDOWS) or (Win32MajorVersion > 4) then + begin + Size := SizeOf(RemoteNameInfo); + if WNetGetUniversalName(PChar(FileName), UNIVERSAL_NAME_INFO_LEVEL, + @RemoteNameInfo, Size) <> NO_ERROR then Exit; + Result := PRemoteNameInfo(@RemoteNameInfo).lpUniversalName; + end else + begin + { The following works around a bug in WNetGetUniversalName under Windows 95 } + Drive := UpCase(FileName[1]); + if (Drive < 'A') or (Drive > 'Z') or (Length(FileName) < 3) or + (FileName[2] <> ':') or (FileName[3] <> '\') then + Exit; + if WNetOpenEnum(RESOURCE_CONNECTED, RESOURCETYPE_DISK, 0, nil, + NetHandle) <> NO_ERROR then Exit; + try + BufSize := 50 * SizeOf(TNetResource); + GetMem(NetResources, BufSize); + try + while True do + begin + Count := $FFFFFFFF; + Size := BufSize; + NetResult := WNetEnumResource(NetHandle, Count, NetResources, Size); + if NetResult = ERROR_MORE_DATA then + begin + BufSize := Size; + ReallocMem(NetResources, BufSize); + Continue; + end; + if NetResult <> NO_ERROR then Exit; + for I := 0 to Count - 1 do + with NetResources^[I] do + if (lpLocalName <> nil) and (Drive = UpCase(lpLocalName[0])) then + begin + Result := lpRemoteName + Copy(FileName, 3, Length(FileName) - 2); + Exit; + end; + end; + finally + FreeMem(NetResources, BufSize); + end; + finally + WNetCloseEnum(NetHandle); + end; + end; +end; + +function ExpandUNCFileName(const FileName: string): string; +begin + { First get the local resource version of the file name } + Result := ExpandFileName(FileName); + if (Length(Result) >= 3) and (Result[2] = ':') and (Upcase(Result[1]) >= 'A') + and (Upcase(Result[1]) <= 'Z') then + Result := GetUniversalName(Result); +end; +{$ENDIF} +{$IFDEF LINUX} +function ExpandUNCFileName(const FileName: string): string; +begin + Result := ExpandFileName(FileName); +end; +{$ENDIF} + +function ExtractRelativePath(const BaseName, DestName: string): string; +var + BasePath, DestPath: string; + BaseLead, DestLead: PChar; + BasePtr, DestPtr: PChar; + + function ExtractFilePathNoDrive(const FileName: string): string; + begin + Result := ExtractFilePath(FileName); + Delete(Result, 1, Length(ExtractFileDrive(FileName))); + end; + + function Next(var Lead: PChar): PChar; + begin + Result := Lead; + if Result = nil then Exit; + Lead := AnsiStrScan(Lead, PathDelim); + if Lead <> nil then + begin + Lead^ := #0; + Inc(Lead); + end; + end; + +begin + if SameFilename(ExtractFileDrive(BaseName), ExtractFileDrive(DestName)) then + begin + BasePath := ExtractFilePathNoDrive(BaseName); + UniqueString(BasePath); + DestPath := ExtractFilePathNoDrive(DestName); + UniqueString(DestPath); + BaseLead := Pointer(BasePath); + BasePtr := Next(BaseLead); + DestLead := Pointer(DestPath); + DestPtr := Next(DestLead); + while (BasePtr <> nil) and (DestPtr <> nil) and SameFilename(BasePtr, DestPtr) do + begin + BasePtr := Next(BaseLead); + DestPtr := Next(DestLead); + end; + Result := ''; + while BaseLead <> nil do + begin + Result := Result + '..' + PathDelim; { Do not localize } + Next(BaseLead); + end; + if (DestPtr <> nil) and (DestPtr^ <> #0) then + Result := Result + DestPtr + PathDelim; + if DestLead <> nil then + Result := Result + DestLead; // destlead already has a trailing backslash + Result := Result + ExtractFileName(DestName); + end + else + Result := DestName; +end; + +{$IFDEF MSWINDOWS} +function ExtractShortPathName(const FileName: string): string; +var + Buffer: array[0..MAX_PATH - 1] of Char; +begin + SetString(Result, Buffer, + GetShortPathName(PChar(FileName), Buffer, SizeOf(Buffer))); +end; +{$ENDIF} + +function FileSearch(const Name, DirList: string): string; +var + I, P, L: Integer; + C: Char; +begin + Result := Name; + P := 1; + L := Length(DirList); + while True do + begin + if FileExists(Result) then Exit; + while (P <= L) and (DirList[P] = PathSep) do Inc(P); + if P > L then Break; + I := P; + while (P <= L) and (DirList[P] <> PathSep) do + begin + if DirList[P] in LeadBytes then + P := NextCharIndex(DirList, P) + else + Inc(P); + end; + Result := Copy(DirList, I, P - I); + C := AnsiLastChar(Result)^; + if (C <> DriveDelim) and (C <> PathDelim) then + Result := Result + PathDelim; + Result := Result + Name; + end; + Result := ''; +end; + +{$IFDEF MSWINDOWS} +// This function is used if the OS doesn't support GetDiskFreeSpaceEx +function BackfillGetDiskFreeSpaceEx(Directory: PChar; var FreeAvailable, + TotalSpace: TLargeInteger; TotalFree: PLargeInteger): Bool; stdcall; +var + SectorsPerCluster, BytesPerSector, FreeClusters, TotalClusters: LongWord; + Temp: Int64; + Dir: PChar; +begin + if Directory <> nil then + Dir := Directory + else + Dir := nil; + Result := GetDiskFreeSpaceA(Dir, SectorsPerCluster, BytesPerSector, + FreeClusters, TotalClusters); + Temp := SectorsPerCluster * BytesPerSector; + FreeAvailable := Temp * FreeClusters; + TotalSpace := Temp * TotalClusters; +end; + +function InternalGetDiskSpace(Drive: Byte; + var TotalSpace, FreeSpaceAvailable: Int64): Bool; +var + RootPath: array[0..4] of Char; + RootPtr: PChar; +begin + RootPtr := nil; + if Drive > 0 then + begin + RootPath[0] := Char(Drive + $40); + RootPath[1] := ':'; + RootPath[2] := '\'; + RootPath[3] := #0; + RootPtr := RootPath; + end; + Result := GetDiskFreeSpaceEx(RootPtr, FreeSpaceAvailable, TotalSpace, nil); +end; + +function DiskFree(Drive: Byte): Int64; +var + TotalSpace: Int64; +begin + if not InternalGetDiskSpace(Drive, TotalSpace, Result) then + Result := -1; +end; + +function DiskSize(Drive: Byte): Int64; +var + FreeSpace: Int64; +begin + if not InternalGetDiskSpace(Drive, Result, FreeSpace) then + Result := -1; +end; +{$ENDIF} + +function FileDateToDateTime(FileDate: Integer): TDateTime; +{$IFDEF MSWINDOWS} +begin + Result := + EncodeDate( + LongRec(FileDate).Hi shr 9 + 1980, + LongRec(FileDate).Hi shr 5 and 15, + LongRec(FileDate).Hi and 31) + + EncodeTime( + LongRec(FileDate).Lo shr 11, + LongRec(FileDate).Lo shr 5 and 63, + LongRec(FileDate).Lo and 31 shl 1, 0); +end; +{$ENDIF} +{$IFDEF LINUX} +var + UT: TUnixTime; +begin + localtime_r(@FileDate, UT); + Result := EncodeDate(UT.tm_year + 1900, UT.tm_mon + 1, UT.tm_mday) + + EncodeTime(UT.tm_hour, UT.tm_min, UT.tm_sec, 0); +end; +{$ENDIF} + +function DateTimeToFileDate(DateTime: TDateTime): Integer; +{$IFDEF MSWINDOWS} +var + Year, Month, Day, Hour, Min, Sec, MSec: Word; +begin + DecodeDate(DateTime, Year, Month, Day); + if (Year < 1980) or (Year > 2107) then Result := 0 else + begin + DecodeTime(DateTime, Hour, Min, Sec, MSec); + LongRec(Result).Lo := (Sec shr 1) or (Min shl 5) or (Hour shl 11); + LongRec(Result).Hi := Day or (Month shl 5) or ((Year - 1980) shl 9); + end; +end; +{$ENDIF} +{$IFDEF LINUX} +var + tm: TUnixTime; + Year, Month, Day, Hour, Min, Sec, MSec: Word; +begin + DecodeDate(DateTime, Year, Month, Day); + { Valid range for 32 bit Unix time_t: 1970 through 2038 } + if (Year < 1970) or (Year > 2038) then + Result := 0 + else + begin + DecodeTime(DateTime, Hour, Min, Sec, MSec); + FillChar(tm, sizeof(tm), 0); + with tm do + begin + tm_sec := Sec; + tm_min := Min; + tm_hour := Hour; + tm_mday := Day; + tm_mon := Month - 1; + tm_year := Year - 1900; + tm_isdst := -1; + end; + Result := mktime(tm); + end; +end; +{$ENDIF} + +function GetCurrentDir: string; +begin + GetDir(0, Result); +end; + +function SetCurrentDir(const Dir: string): Boolean; +begin +{$IFDEF MSWINDOWS} + Result := SetCurrentDirectory(PChar(Dir)); +{$ENDIF} +{$IFDEF LINUX} + Result := __chdir(PChar(Dir)) = 0; +{$ENDIF} +end; + +function CreateDir(const Dir: string): Boolean; +begin +{$IFDEF MSWINDOWS} + Result := CreateDirectory(PChar(Dir), nil); +{$ENDIF} +{$IFDEF LINUX} + Result := __mkdir(PChar(Dir), mode_t(-1)) = 0; +{$ENDIF} +end; + +function RemoveDir(const Dir: string): Boolean; +begin +{$IFDEF MSWINDOWS} + Result := RemoveDirectory(PChar(Dir)); +{$ENDIF} +{$IFDEF LINUX} + Result := __rmdir(PChar(Dir)) = 0; +{$ENDIF} +end; + +{ PChar routines } + +function StrLen(const Str: PChar): Cardinal; assembler; +asm + MOV EDX,EDI + MOV EDI,EAX + MOV ECX,0FFFFFFFFH + XOR AL,AL + REPNE SCASB + MOV EAX,0FFFFFFFEH + SUB EAX,ECX + MOV EDI,EDX +end; + +function StrEnd(const Str: PChar): PChar; assembler; +asm + MOV EDX,EDI + MOV EDI,EAX + MOV ECX,0FFFFFFFFH + XOR AL,AL + REPNE SCASB + LEA EAX,[EDI-1] + MOV EDI,EDX +end; + +function StrMove(Dest: PChar; const Source: PChar; Count: Cardinal): PChar; +begin + Result := Dest; + Move(Source^, Dest^, Count); +end; + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The implementation of function StrCopy is subject to the + * Mozilla Public License Version 1.1 (the "License"); you may + * not use this file except in compliance with the License. + * You may obtain a copy of the License at http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is Fastcode + * + * The Initial Developer of the Original Code is Fastcode + * + * Portions created by the Initial Developer are Copyright (C) 2002-2004 + * the Initial Developer. All Rights Reserved. + * + * Contributor(s): Aleksandr Sharahov + * + * ***** END LICENSE BLOCK ***** *) +function StrCopy(Dest: PChar; const Source: PChar): PChar; +asm + sub edx, eax + test eax, 1 + push eax + jz @loop + movzx ecx, byte ptr[eax+edx] + mov [eax], cl + test ecx, ecx + jz @ret + inc eax +@loop: + movzx ecx, byte ptr[eax+edx] + test ecx, ecx + jz @move0 + movzx ecx, word ptr[eax+edx] + mov [eax], cx + add eax, 2 + cmp ecx, 255 + ja @loop +@ret: + pop eax + ret +@move0: + mov [eax], cl + pop eax +end; + +function StrECopy(Dest: PChar; const Source: PChar): PChar; assembler; +asm + PUSH EDI + PUSH ESI + MOV ESI,EAX + MOV EDI,EDX + MOV ECX,0FFFFFFFFH + XOR AL,AL + REPNE SCASB + NOT ECX + MOV EDI,ESI + MOV ESI,EDX + MOV EDX,ECX + SHR ECX,2 + REP MOVSD + MOV ECX,EDX + AND ECX,3 + REP MOVSB + LEA EAX,[EDI-1] + POP ESI + POP EDI +end; + +function StrLCopy(Dest: PChar; const Source: PChar; MaxLen: Cardinal): PChar; assembler; +asm + PUSH EDI + PUSH ESI + PUSH EBX + MOV ESI,EAX + MOV EDI,EDX + MOV EBX,ECX + XOR AL,AL + TEST ECX,ECX + JZ @@1 + REPNE SCASB + JNE @@1 + INC ECX +@@1: SUB EBX,ECX + MOV EDI,ESI + MOV ESI,EDX + MOV EDX,EDI + MOV ECX,EBX + SHR ECX,2 + REP MOVSD + MOV ECX,EBX + AND ECX,3 + REP MOVSB + STOSB + MOV EAX,EDX + POP EBX + POP ESI + POP EDI +end; + +function StrPCopy(Dest: PChar; const Source: string): PChar; +begin + Result := StrLCopy(Dest, PChar(Source), Length(Source)); +end; + +function StrPLCopy(Dest: PChar; const Source: string; + MaxLen: Cardinal): PChar; +begin + Result := StrLCopy(Dest, PChar(Source), MaxLen); +end; + +function StrCat(Dest: PChar; const Source: PChar): PChar; +begin + StrCopy(StrEnd(Dest), Source); + Result := Dest; +end; + +function StrLCat(Dest: PChar; const Source: PChar; MaxLen: Cardinal): PChar; assembler; +asm + PUSH EDI + PUSH ESI + PUSH EBX + MOV EDI,Dest + MOV ESI,Source + MOV EBX,MaxLen + CALL StrEnd + MOV ECX,EDI + ADD ECX,EBX + SUB ECX,EAX + JBE @@1 + MOV EDX,ESI + CALL StrLCopy +@@1: MOV EAX,EDI + POP EBX + POP ESI + POP EDI +end; + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The implementation of function StrComp is subject to the + * Mozilla Public License Version 1.1 (the "License"); you may + * not use this file except in compliance with the License. + * You may obtain a copy of the License at http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is Fastcode + * + * The Initial Developer of the Original Code is Fastcode + * + * Portions created by the Initial Developer are Copyright (C) 2002-2004 + * the Initial Developer. All Rights Reserved. + * + * Contributor(s): Aleksandr Sharahov + * + * ***** END LICENSE BLOCK ***** *) +function StrComp(const Str1, Str2: PChar): Integer; assembler; +asm + sub edx, eax + jnz @next + xor eax, eax + jmp @ret +@next: + movzx ecx, [eax+edx] + cmp cl, [eax] + jne @stop + test cl, cl + jz @stop + movzx ecx, [eax+edx+1] + cmp cl, [eax+1] + jne @stop1 + test cl, cl + jz @stop1 + movzx ecx, [eax+edx+2] + cmp cl, [eax+2] + jne @stop2 + test cl, cl + jz @stop2 + movzx ecx, [eax+edx+3] + cmp cl, [eax+3] + jne @stop3 + add eax, 4 + test cl, cl + jz @stop4 + movzx ecx, [eax+edx] + cmp cl, [eax] + jne @stop + test cl, cl + jz @stop + movzx ecx, [eax+edx+1] + cmp cl, [eax+1] + jne @stop1 + test cl, cl + jz @stop1 + movzx ecx, [eax+edx+2] + cmp cl, [eax+2] + jne @stop2 + test cl, cl + jz @stop2 + movzx ecx, [eax+edx+3] + cmp cl, [eax+3] + jne @stop3 + add eax, 4 + test cl, cl + jnz @next +@stop4: + sub eax, 4 +@stop3: + add eax, 1 +@stop2: + add eax, 1 +@stop1: + add eax, 1 +@stop: + movzx eax, [eax] + sub eax, ecx +@ret: +end; + +function StrIComp(const Str1, Str2: PChar): Integer; assembler; +asm + PUSH EDI + PUSH ESI + MOV EDI,EDX + MOV ESI,EAX + MOV ECX,0FFFFFFFFH + XOR EAX,EAX + REPNE SCASB + NOT ECX + MOV EDI,EDX + XOR EDX,EDX +@@1: REPE CMPSB + JE @@4 + MOV AL,[ESI-1] + CMP AL,'a' + JB @@2 + CMP AL,'z' + JA @@2 + SUB AL,20H +@@2: MOV DL,[EDI-1] + CMP DL,'a' + JB @@3 + CMP DL,'z' + JA @@3 + SUB DL,20H +@@3: SUB EAX,EDX + JE @@1 +@@4: POP ESI + POP EDI +end; + +function StrLComp(const Str1, Str2: PChar; MaxLen: Cardinal): Integer; assembler; +asm + PUSH EDI + PUSH ESI + PUSH EBX + MOV EDI,EDX + MOV ESI,EAX + MOV EBX,ECX + XOR EAX,EAX + OR ECX,ECX + JE @@1 + REPNE SCASB + SUB EBX,ECX + MOV ECX,EBX + MOV EDI,EDX + XOR EDX,EDX + REPE CMPSB + MOV AL,[ESI-1] + MOV DL,[EDI-1] + SUB EAX,EDX +@@1: POP EBX + POP ESI + POP EDI +end; + +function StrLIComp(const Str1, Str2: PChar; MaxLen: Cardinal): Integer; assembler; +asm + PUSH EDI + PUSH ESI + PUSH EBX + MOV EDI,EDX + MOV ESI,EAX + MOV EBX,ECX + XOR EAX,EAX + OR ECX,ECX + JE @@4 + REPNE SCASB + SUB EBX,ECX + MOV ECX,EBX + MOV EDI,EDX + XOR EDX,EDX +@@1: REPE CMPSB + JE @@4 + MOV AL,[ESI-1] + CMP AL,'a' + JB @@2 + CMP AL,'z' + JA @@2 + SUB AL,20H +@@2: MOV DL,[EDI-1] + CMP DL,'a' + JB @@3 + CMP DL,'z' + JA @@3 + SUB DL,20H +@@3: SUB EAX,EDX + JE @@1 +@@4: POP EBX + POP ESI + POP EDI +end; + +function StrScan(const Str: PChar; Chr: Char): PChar; +begin + Result := Str; + while Result^ <> Chr do + begin + if Result^ = #0 then + begin + Result := nil; + Exit; + end; + Inc(Result); + end; +end; + +function StrRScan(const Str: PChar; Chr: Char): PChar; +var + MostRecentFound: PChar; +begin + if Chr = #0 then + Result := StrEnd(Str) + else + begin + Result := nil; + + MostRecentFound := Str; + while True do + begin + while MostRecentFound^ <> Chr do + begin + if MostRecentFound^ = #0 then + Exit; + Inc(MostRecentFound); + end; + Result := MostRecentFound; + Inc(MostRecentFound); + end; + end; +end; + +function StrPos(const Str1, Str2: PChar): PChar; assembler; +asm + PUSH EDI + PUSH ESI + PUSH EBX + OR EAX,EAX + JE @@2 + OR EDX,EDX + JE @@2 + MOV EBX,EAX + MOV EDI,EDX + XOR AL,AL + MOV ECX,0FFFFFFFFH + REPNE SCASB + NOT ECX + DEC ECX + JE @@2 + MOV ESI,ECX + MOV EDI,EBX + MOV ECX,0FFFFFFFFH + REPNE SCASB + NOT ECX + SUB ECX,ESI + JBE @@2 + MOV EDI,EBX + LEA EBX,[ESI-1] +@@1: MOV ESI,EDX + LODSB + REPNE SCASB + JNE @@2 + MOV EAX,ECX + PUSH EDI + MOV ECX,EBX + REPE CMPSB + POP EDI + MOV ECX,EAX + JNE @@1 + LEA EAX,[EDI-1] + JMP @@3 +@@2: XOR EAX,EAX +@@3: POP EBX + POP ESI + POP EDI +end; + +function StrUpper(Str: PChar): PChar; assembler; +asm + PUSH ESI + MOV ESI,Str + MOV EDX,Str +@@1: LODSB + OR AL,AL + JE @@2 + CMP AL,'a' + JB @@1 + CMP AL,'z' + JA @@1 + SUB AL,20H + MOV [ESI-1],AL + JMP @@1 +@@2: XCHG EAX,EDX + POP ESI +end; + +function StrLower(Str: PChar): PChar; assembler; +asm + PUSH ESI + MOV ESI,Str + MOV EDX,Str +@@1: LODSB + OR AL,AL + JE @@2 + CMP AL,'A' + JB @@1 + CMP AL,'Z' + JA @@1 + ADD AL,20H + MOV [ESI-1],AL + JMP @@1 +@@2: XCHG EAX,EDX + POP ESI +end; + +function StrPas(const Str: PChar): string; +begin + Result := Str; +end; + +function StrAlloc(Size: Cardinal): PChar; +begin + Inc(Size, SizeOf(Cardinal)); + GetMem(Result, Size); + Cardinal(Pointer(Result)^) := Size; + Inc(Result, SizeOf(Cardinal)); +end; + +function StrBufSize(const Str: PChar): Cardinal; +var + P: PChar; +begin + P := Str; + Dec(P, SizeOf(Cardinal)); + Result := Cardinal(Pointer(P)^) - SizeOf(Cardinal); +end; + +function StrNew(const Str: PChar): PChar; +var + Size: Cardinal; +begin + if Str = nil then Result := nil else + begin + Size := StrLen(Str) + 1; + Result := StrMove(StrAlloc(Size), Str, Size); + end; +end; + +procedure StrDispose(Str: PChar); +begin + if Str <> nil then + begin + Dec(Str, SizeOf(Cardinal)); + FreeMem(Str, Cardinal(Pointer(Str)^)); + end; +end; + +{ String formatting routines } + +procedure FormatError(ErrorCode: Integer; Format: PChar; FmtLen: Cardinal); +const + FormatErrorStrs: array[0..1] of PResStringRec = ( + @SInvalidFormat, @SArgumentMissing); +var + Buffer: array[0..31] of Char; +begin + if FmtLen > 31 then FmtLen := 31; + if StrByteType(Format, FmtLen-1) = mbLeadByte then Dec(FmtLen); + StrMove(Buffer, Format, FmtLen); + Buffer[FmtLen] := #0; + ConvertErrorFmt(FormatErrorStrs[ErrorCode], [PChar(@Buffer)]); +end; + +procedure FormatVarToStr(var S: string; const V: TVarData); +begin + if Assigned(System.VarToLStrProc) then + System.VarToLStrProc(S, V) + else + System.Error(reVarInvalidOp); +end; + +procedure FormatClearStr(var S: string); +begin + S := ''; +end; + +function FloatToTextEx(BufferArg: PChar; const Value; ValueType: TFloatValue; + Format: TFloatFormat; Precision, Digits: Integer; + const FormatSettings: TFormatSettings): Integer; +begin + Result := FloatToText(BufferArg, Value, ValueType, Format, Precision, Digits, + FormatSettings); +end; + +function FormatBuf(var Buffer; BufLen: Cardinal; const Format; + FmtLen: Cardinal; const Args: array of const): Cardinal; +var + ArgIndex, Width, Prec: Integer; + BufferOrg, FormatOrg, FormatPtr, TempStr: PChar; + JustFlag: Byte; + StrBuf: array[0..64] of Char; + TempAnsiStr: string; + SaveGOT: Integer; +{ in: eax <-> Buffer } +{ in: edx <-> BufLen } +{ in: ecx <-> Format } + +asm + PUSH EBX + PUSH ESI + PUSH EDI + MOV EDI,EAX + MOV ESI,ECX +{$IFDEF PIC} + PUSH ECX + CALL GetGOT + POP ECX +{$ELSE} + XOR EAX,EAX +{$ENDIF} + MOV SaveGOT,EAX + ADD ECX,FmtLen + MOV BufferOrg,EDI + XOR EAX,EAX + MOV ArgIndex,EAX + MOV TempStr,EAX + MOV TempAnsiStr,EAX + +@Loop: + OR EDX,EDX + JE @Done + +@NextChar: + CMP ESI,ECX + JE @Done + LODSB + CMP AL,'%' + JE @Format + +@StoreChar: + STOSB + DEC EDX + JNE @NextChar + +@Done: + MOV EAX,EDI + SUB EAX,BufferOrg + JMP @Exit + +@Format: + CMP ESI,ECX + JE @Done + LODSB + CMP AL,'%' + JE @StoreChar + LEA EBX,[ESI-2] + MOV FormatOrg,EBX +@A0: MOV JustFlag,AL + CMP AL,'-' + JNE @A1 + CMP ESI,ECX + JE @Done + LODSB +@A1: CALL @Specifier + CMP AL,':' + JNE @A2 + MOV ArgIndex,EBX + CMP ESI,ECX + JE @Done + LODSB + JMP @A0 + +@A2: MOV Width,EBX + MOV EBX,-1 + CMP AL,'.' + JNE @A3 + CMP ESI,ECX + JE @Done + LODSB + CALL @Specifier +@A3: MOV Prec,EBX + MOV FormatPtr,ESI + PUSH ECX + PUSH EDX + + CALL @Convert + + POP EDX + MOV EBX,Width + SUB EBX,ECX //(* ECX <=> number of characters output *) + JAE @A4 //(* jump -> output smaller than width *) + XOR EBX,EBX + +@A4: CMP JustFlag,'-' + JNE @A6 + SUB EDX,ECX + JAE @A5 + ADD ECX,EDX + XOR EDX,EDX + +@A5: REP MOVSB + +@A6: XCHG EBX,ECX + SUB EDX,ECX + JAE @A7 + ADD ECX,EDX + XOR EDX,EDX +@A7: MOV AL,' ' + REP STOSB + XCHG EBX,ECX + SUB EDX,ECX + JAE @A8 + ADD ECX,EDX + XOR EDX,EDX +@A8: REP MOVSB + CMP TempStr,0 + JE @A9 + PUSH EDX + LEA EAX,TempStr +// PUSH EBX // GOT setup unnecessary for +// MOV EBX, SaveGOT // same-unit calls to Pascal procedures + CALL FormatClearStr +// POP EBX + POP EDX +@A9: POP ECX + MOV ESI,FormatPtr + JMP @Loop + +@Specifier: + XOR EBX,EBX + CMP AL,'*' + JE @B3 +@B1: CMP AL,'0' + JB @B5 + CMP AL,'9' + JA @B5 + IMUL EBX,EBX,10 + SUB AL,'0' + MOVZX EAX,AL + ADD EBX,EAX + CMP ESI,ECX + JE @B2 + LODSB + JMP @B1 +@B2: POP EAX + JMP @Done +@B3: MOV EAX,ArgIndex + CMP EAX,Args.Integer[-4] + JG @B4 + INC ArgIndex + MOV EBX,Args + CMP [EBX+EAX*8].Byte[4],vtInteger + MOV EBX,[EBX+EAX*8] + JE @B4 + XOR EBX,EBX +@B4: CMP ESI,ECX + JE @B2 + LODSB +@B5: RET + +@Convert: + AND AL,0DFH + MOV CL,AL + MOV EAX,1 + MOV EBX,ArgIndex + CMP EBX,Args.Integer[-4] + JG @ErrorExit + INC ArgIndex + MOV ESI,Args + LEA ESI,[ESI+EBX*8] + MOV EAX,[ESI].Integer[0] // TVarRec.data + MOVZX EDX,[ESI].Byte[4] // TVarRec.VType +{$IFDEF PIC} + MOV EBX, SaveGOT + ADD EBX, offset @CvtVector + MOV EBX, [EBX+EDX*4] + ADD EBX, SaveGOT + JMP EBX +{$ELSE} + JMP @CvtVector.Pointer[EDX*4] +{$ENDIF} + +@CvtVector: + DD @CvtInteger // vtInteger + DD @CvtBoolean // vtBoolean + DD @CvtChar // vtChar + DD @CvtExtended // vtExtended + DD @CvtShortStr // vtString + DD @CvtPointer // vtPointer + DD @CvtPChar // vtPChar + DD @CvtObject // vtObject + DD @CvtClass // vtClass + DD @CvtWideChar // vtWideChar + DD @CvtPWideChar // vtPWideChar + DD @CvtAnsiStr // vtAnsiString + DD @CvtCurrency // vtCurrency + DD @CvtVariant // vtVariant + DD @CvtInterface // vtInterface + DD @CvtWideString // vtWideString + DD @CvtInt64 // vtInt64 + +@CvtBoolean: +@CvtObject: +@CvtClass: +@CvtWideChar: +@CvtInterface: +@CvtError: + XOR EAX,EAX + +@ErrorExit: + CALL @ClearTmpAnsiStr + MOV EDX,FormatOrg + MOV ECX,FormatPtr + SUB ECX,EDX +{$IFDEF PC_MAPPED_EXCEPTIONS} + // Because of all the assembly code here, we can't call a routine + // that throws an exception if it looks like we're still on the + // stack. The static disassembler cannot give sufficient unwind + // frame info to unwind the confusion that is generated from the + // assembly code above. So before we throw the exception, we + // go to some lengths to excise ourselves from the stack chain. + // We were passed 12 bytes of parameters on the stack, and we have + // to make sure that we get rid of those, too. + MOV EBX, SaveGOT + MOV ESP, EBP // Ditch everthing to the frame + MOV EBP, [ESP + 4] // Get the return addr + MOV [ESP + 16], EBP // Move the ret addr up in the stack + POP EBP // Ditch the rest of the frame + ADD ESP, 12 // Ditch the space that was taken by params + JMP FormatError // Off to FormatErr +{$ELSE} + MOV EBX, SaveGOT + CALL FormatError +{$ENDIF} + // The above call raises an exception and does not return + +@CvtInt64: + // CL <= format character + // EAX <= address of int64 + // EBX <= TVarRec.VType + + LEA ESI,StrBuf[32] + MOV EDX, Prec + CMP EDX, 32 + JBE @I64_1 // zero padded field width > buffer => no padding + XOR EDX, EDX +@I64_1: MOV EBX, ECX + SUB CL, 'D' + JZ CvtInt64 // branch predict backward jump taken + MOV ECX, 16 + CMP BL, 'X' + JE CvtInt64 + MOV ECX, 10 + CMP BL, 'U' + JE CvtInt64 + JMP @CvtError + +{ LEA EBX, TempInt64 // (input is array of const; save original) + MOV EDX, [EAX] + MOV [EBX], EDX + MOV EDX, [EAX + 4] + MOV [EBX + 4], EDX + + // EBX <= address of TempInt64 + + CMP CL,'D' + JE @DecI64 + CMP CL,'U' + JE @DecI64_2 + CMP CL,'X' + JNE @CvtError + +@HexI64: + MOV ECX,16 // hex divisor + JMP @CvtI64 + +@DecI64: + TEST DWORD PTR [EBX + 4], $80000000 // sign bit set? + JE @DecI64_2 // no -> bypass '-' output + + NEG DWORD PTR [EBX] // negate lo-order, then hi-order + ADC DWORD PTR [EBX+4], 0 + NEG DWORD PTR [EBX+4] + + CALL @DecI64_2 + + MOV AL,'-' + INC ECX + DEC ESI + MOV [ESI],AL + RET + +@DecI64_2: // unsigned int64 output + MOV ECX,10 // decimal divisor + +@CvtI64: + LEA ESI,StrBuf[32] + +@CvtI64_1: + PUSH EBX + PUSH ECX // save radix + PUSH 0 + PUSH ECX // radix divisor (10 or 16 only) + MOV EAX, [EBX] + MOV EDX, [EBX + 4] + MOV EBX, SaveGOT + CALL System.@_llumod + POP ECX // saved radix + POP EBX + + XCHG EAX, EDX // lo-value to EDX for character output + ADD DL,'0' + CMP DL,'0'+10 + JB @CvtI64_2 + + ADD DL,('A'-'0')-10 + +@CvtI64_2: + DEC ESI + MOV [ESI],DL + + PUSH EBX + PUSH ECX // save radix + PUSH 0 + PUSH ECX // radix divisor (10 or 16 only) + MOV EAX, [EBX] // value := value DIV radix + MOV EDX, [EBX + 4] + MOV EBX, SaveGOT + CALL System.@_lludiv + POP ECX // saved radix + POP EBX + MOV [EBX], EAX + MOV [EBX + 4], EDX + OR EAX,EDX // anything left to output? + JNE @CvtI64_1 // no jump => EDX:EAX = 0 + + LEA ECX,StrBuf[32] + SUB ECX,ESI + MOV EDX,Prec + CMP EDX,16 + JBE @CvtI64_3 + RET + +@CvtI64_3: + SUB EDX,ECX + JBE @CvtI64_5 + ADD ECX,EDX + MOV AL,'0' + +@CvtI64_4: + DEC ESI + MOV [ESI],AL + DEC EDX + JNE @CvtI64_4 + +@CvtI64_5: + RET +} +//////////////////////////////////////////////// + +@CvtInteger: + LEA ESI,StrBuf[16] + MOV EDX, Prec + MOV EBX, ECX + CMP EDX, 16 + JBE @C1 // zero padded field width > buffer => no padding + XOR EDX, EDX +@C1: SUB CL, 'D' + JZ CvtInt // branch predict backward jump taken + MOV ECX, 16 + CMP BL, 'X' + JE CvtInt + MOV ECX, 10 + CMP BL, 'U' + JE CvtInt + JMP @CvtError + +{ CMP CL,'D' + JE @C1 + CMP CL,'U' + JE @C2 + CMP CL,'X' + JNE @CvtError + MOV ECX,16 + JMP @CvtLong +@C1: OR EAX,EAX + JNS @C2 + NEG EAX + CALL @C2 + MOV AL,'-' + INC ECX + DEC ESI + MOV [ESI],AL + RET +@C2: MOV ECX,10 + +@CvtLong: + LEA ESI,StrBuf[16] +@D1: XOR EDX,EDX + DIV ECX + ADD DL,'0' + CMP DL,'0'+10 + JB @D2 + ADD DL,('A'-'0')-10 +@D2: DEC ESI + MOV [ESI],DL + OR EAX,EAX + JNE @D1 + LEA ECX,StrBuf[16] + SUB ECX,ESI + MOV EDX,Prec + CMP EDX,16 + JBE @D3 + RET +@D3: SUB EDX,ECX + JBE @D5 + ADD ECX,EDX + MOV AL,'0' +@D4: DEC ESI + MOV [ESI],AL + DEC EDX + JNE @D4 +@D5: RET +} +@CvtChar: + CMP CL,'S' + JNE @CvtError + MOV ECX,1 + RET + +@CvtVariant: + CMP CL,'S' + JNE @CvtError + CMP [EAX].TVarData.VType,varNull + JBE @CvtEmptyStr + MOV EDX,EAX + LEA EAX,TempStr +// PUSH EBX // GOT setup unnecessary for +// MOV EBX, SaveGOT // same-unit calls to Pascal procedures + CALL FormatVarToStr +// POP EBX + MOV ESI,TempStr + JMP @CvtStrRef + +@CvtEmptyStr: + XOR ECX,ECX + RET + +@CvtShortStr: + CMP CL,'S' + JNE @CvtError + MOV ESI,EAX + LODSB + MOVZX ECX,AL + JMP @CvtStrLen + +@CvtPWideChar: + MOV ESI,OFFSET System.@LStrFromPWChar + JMP @CvtWideThing + +@CvtWideString: + MOV ESI,OFFSET System.@LStrFromWStr + +@CvtWideThing: + ADD ESI, SaveGOT +{$IFDEF PIC} + MOV ESI, [ESI] +{$ENDIF} + CMP CL,'S' + JNE @CvtError + MOV EDX,EAX + LEA EAX,TempAnsiStr + PUSH EBX + MOV EBX, SaveGOT + CALL ESI + POP EBX + MOV ESI,TempAnsiStr + MOV EAX,ESI + JMP @CvtStrRef + +@CvtAnsiStr: + CMP CL,'S' + JNE @CvtError + MOV ESI,EAX + +@CvtStrRef: + OR ESI,ESI + JE @CvtEmptyStr + MOV ECX,[ESI-4] + +@CvtStrLen: + CMP ECX,Prec + JA @E1 + RET +@E1: MOV ECX,Prec + RET + +@CvtPChar: + CMP CL,'S' + JNE @CvtError + MOV ESI,EAX + PUSH EDI + MOV EDI,EAX + XOR AL,AL + MOV ECX,Prec + JECXZ @F1 + REPNE SCASB + JNE @F1 + DEC EDI +@F1: MOV ECX,EDI + SUB ECX,ESI + POP EDI + RET + +@CvtPointer: + CMP CL,'P' + JNE @CvtError + MOV EDX,8 + MOV ECX,16 + LEA ESI,StrBuf[16] + JMP CvtInt + +@CvtCurrency: + MOV BH,fvCurrency + JMP @CvtFloat + +@CvtExtended: + MOV BH,fvExtended + +@CvtFloat: + MOV ESI,EAX + MOV BL,ffGeneral + CMP CL,'G' + JE @G2 + MOV BL,ffExponent + CMP CL,'E' + JE @G2 + MOV BL,ffFixed + CMP CL,'F' + JE @G1 + MOV BL,ffNumber + CMP CL,'N' + JE @G1 + CMP CL,'M' + JNE @CvtError + MOV BL,ffCurrency +@G1: MOV EAX,18 + MOV EDX,Prec + CMP EDX,EAX + JBE @G3 + MOV EDX,2 + CMP CL,'M' + JNE @G3 + MOVZX EDX,CurrencyDecimals + JMP @G3 +@G2: MOV EAX,Prec + MOV EDX,3 + CMP EAX,18 + JBE @G3 + MOV EAX,15 +@G3: PUSH EBX + PUSH EAX + PUSH EDX + LEA EAX,StrBuf + MOV EDX,ESI + MOVZX ECX,BH + MOV EBX, SaveGOT + CALL FloatToText + MOV ECX,EAX + LEA ESI,StrBuf + RET + +@ClearTmpAnsiStr: + PUSH EBX + PUSH EAX + LEA EAX,TempAnsiStr + MOV EBX, SaveGOT + CALL System.@LStrClr + POP EAX + POP EBX + RET + +@Exit: + CALL @ClearTmpAnsiStr + POP EDI + POP ESI + POP EBX +end; + +function FormatBuf(var Buffer; BufLen: Cardinal; const Format; + FmtLen: Cardinal; const Args: array of const; + const FormatSettings: TFormatSettings): Cardinal; +var + ArgIndex, Width, Prec: Integer; + BufferOrg, FormatOrg, FormatPtr, TempStr: PChar; + JustFlag: Byte; + StrBuf: array[0..64] of Char; + TempAnsiStr: string; + SaveGOT: Integer; +{ in: eax <-> Buffer } +{ in: edx <-> BufLen } +{ in: ecx <-> Format } + +asm + PUSH EBX + PUSH ESI + PUSH EDI + MOV EDI,EAX + MOV ESI,ECX +{$IFDEF PIC} + PUSH ECX + CALL GetGOT + POP ECX +{$ELSE} + XOR EAX,EAX +{$ENDIF} + MOV SaveGOT,EAX + ADD ECX,FmtLen + MOV BufferOrg,EDI + XOR EAX,EAX + MOV ArgIndex,EAX + MOV TempStr,EAX + MOV TempAnsiStr,EAX + +@Loop: + OR EDX,EDX + JE @Done + +@NextChar: + CMP ESI,ECX + JE @Done + LODSB + CMP AL,'%' + JE @Format + +@StoreChar: + STOSB + DEC EDX + JNE @NextChar + +@Done: + MOV EAX,EDI + SUB EAX,BufferOrg + JMP @Exit + +@Format: + CMP ESI,ECX + JE @Done + LODSB + CMP AL,'%' + JE @StoreChar + LEA EBX,[ESI-2] + MOV FormatOrg,EBX +@A0: MOV JustFlag,AL + CMP AL,'-' + JNE @A1 + CMP ESI,ECX + JE @Done + LODSB +@A1: CALL @Specifier + CMP AL,':' + JNE @A2 + MOV ArgIndex,EBX + CMP ESI,ECX + JE @Done + LODSB + JMP @A0 + +@A2: MOV Width,EBX + MOV EBX,-1 + CMP AL,'.' + JNE @A3 + CMP ESI,ECX + JE @Done + LODSB + CALL @Specifier +@A3: MOV Prec,EBX + MOV FormatPtr,ESI + PUSH ECX + PUSH EDX + + CALL @Convert + + POP EDX + MOV EBX,Width + SUB EBX,ECX //(* ECX <=> number of characters output *) + JAE @A4 //(* jump -> output smaller than width *) + XOR EBX,EBX + +@A4: CMP JustFlag,'-' + JNE @A6 + SUB EDX,ECX + JAE @A5 + ADD ECX,EDX + XOR EDX,EDX + +@A5: REP MOVSB + +@A6: XCHG EBX,ECX + SUB EDX,ECX + JAE @A7 + ADD ECX,EDX + XOR EDX,EDX +@A7: MOV AL,' ' + REP STOSB + XCHG EBX,ECX + SUB EDX,ECX + JAE @A8 + ADD ECX,EDX + XOR EDX,EDX +@A8: REP MOVSB + CMP TempStr,0 + JE @A9 + PUSH EDX + LEA EAX,TempStr +// PUSH EBX // GOT setup unnecessary for +// MOV EBX, SaveGOT // same-unit calls to Pascal procedures + CALL FormatClearStr +// POP EBX + POP EDX +@A9: POP ECX + MOV ESI,FormatPtr + JMP @Loop + +@Specifier: + XOR EBX,EBX + CMP AL,'*' + JE @B3 +@B1: CMP AL,'0' + JB @B5 + CMP AL,'9' + JA @B5 + IMUL EBX,EBX,10 + SUB AL,'0' + MOVZX EAX,AL + ADD EBX,EAX + CMP ESI,ECX + JE @B2 + LODSB + JMP @B1 +@B2: POP EAX + JMP @Done +@B3: MOV EAX,ArgIndex + CMP EAX,Args.Integer[-4] + JG @B4 + INC ArgIndex + MOV EBX,Args + CMP [EBX+EAX*8].Byte[4],vtInteger + MOV EBX,[EBX+EAX*8] + JE @B4 + XOR EBX,EBX +@B4: CMP ESI,ECX + JE @B2 + LODSB +@B5: RET + +@Convert: + AND AL,0DFH + MOV CL,AL + MOV EAX,1 + MOV EBX,ArgIndex + CMP EBX,Args.Integer[-4] + JG @ErrorExit + INC ArgIndex + MOV ESI,Args + LEA ESI,[ESI+EBX*8] + MOV EAX,[ESI].Integer[0] // TVarRec.data + MOVZX EDX,[ESI].Byte[4] // TVarRec.VType +{$IFDEF PIC} + MOV EBX, SaveGOT + ADD EBX, offset @CvtVector + MOV EBX, [EBX+EDX*4] + ADD EBX, SaveGOT + JMP EBX +{$ELSE} + JMP @CvtVector.Pointer[EDX*4] +{$ENDIF} + +@CvtVector: + DD @CvtInteger // vtInteger + DD @CvtBoolean // vtBoolean + DD @CvtChar // vtChar + DD @CvtExtended // vtExtended + DD @CvtShortStr // vtString + DD @CvtPointer // vtPointer + DD @CvtPChar // vtPChar + DD @CvtObject // vtObject + DD @CvtClass // vtClass + DD @CvtWideChar // vtWideChar + DD @CvtPWideChar // vtPWideChar + DD @CvtAnsiStr // vtAnsiString + DD @CvtCurrency // vtCurrency + DD @CvtVariant // vtVariant + DD @CvtInterface // vtInterface + DD @CvtWideString // vtWideString + DD @CvtInt64 // vtInt64 + +@CvtBoolean: +@CvtObject: +@CvtClass: +@CvtWideChar: +@CvtInterface: +@CvtError: + XOR EAX,EAX + +@ErrorExit: + CALL @ClearTmpAnsiStr + MOV EDX,FormatOrg + MOV ECX,FormatPtr + SUB ECX,EDX +{$IFDEF PC_MAPPED_EXCEPTIONS} + // Because of all the assembly code here, we can't call a routine + // that throws an exception if it looks like we're still on the + // stack. The static disassembler cannot give sufficient unwind + // frame info to unwind the confusion that is generated from the + // assembly code above. So before we throw the exception, we + // go to some lengths to excise ourselves from the stack chain. + // We were passed 12 bytes of parameters on the stack, and we have + // to make sure that we get rid of those, too. + MOV EBX, SaveGOT + MOV ESP, EBP // Ditch everthing to the frame + MOV EBP, [ESP + 4] // Get the return addr + MOV [ESP + 16], EBP // Move the ret addr up in the stack + POP EBP // Ditch the rest of the frame + ADD ESP, 12 // Ditch the space that was taken by params + JMP FormatError // Off to FormatErr +{$ELSE} + MOV EBX, SaveGOT + CALL FormatError +{$ENDIF} + // The above call raises an exception and does not return + +@CvtInt64: + // CL <= format character + // EAX <= address of int64 + // EBX <= TVarRec.VType + + LEA ESI,StrBuf[32] + MOV EDX, Prec + CMP EDX, 32 + JBE @I64_1 // zero padded field width > buffer => no padding + XOR EDX, EDX +@I64_1: MOV EBX, ECX + SUB CL, 'D' + JZ CvtInt64 // branch predict backward jump taken + MOV ECX, 16 + CMP BL, 'X' + JE CvtInt64 + MOV ECX, 10 + CMP BL, 'U' + JE CvtInt64 + JMP @CvtError +//////////////////////////////////////////////// + +@CvtInteger: + LEA ESI,StrBuf[16] + MOV EDX, Prec + MOV EBX, ECX + CMP EDX, 16 + JBE @C1 // zero padded field width > buffer => no padding + XOR EDX, EDX +@C1: SUB CL, 'D' + JZ CvtInt // branch predict backward jump taken + MOV ECX, 16 + CMP BL, 'X' + JE CvtInt + MOV ECX, 10 + CMP BL, 'U' + JE CvtInt + JMP @CvtError + +@CvtChar: + CMP CL,'S' + JNE @CvtError + MOV ECX,1 + RET + +@CvtVariant: + CMP CL,'S' + JNE @CvtError + CMP [EAX].TVarData.VType,varNull + JBE @CvtEmptyStr + MOV EDX,EAX + LEA EAX,TempStr +// PUSH EBX // GOT setup unnecessary for +// MOV EBX, SaveGOT // same-unit calls to Pascal procedures + CALL FormatVarToStr +// POP EBX + MOV ESI,TempStr + JMP @CvtStrRef + +@CvtEmptyStr: + XOR ECX,ECX + RET + +@CvtShortStr: + CMP CL,'S' + JNE @CvtError + MOV ESI,EAX + LODSB + MOVZX ECX,AL + JMP @CvtStrLen + +@CvtPWideChar: + MOV ESI,OFFSET System.@LStrFromPWChar + JMP @CvtWideThing + +@CvtWideString: + MOV ESI,OFFSET System.@LStrFromWStr + +@CvtWideThing: + ADD ESI, SaveGOT +{$IFDEF PIC} + MOV ESI, [ESI] +{$ENDIF} + CMP CL,'S' + JNE @CvtError + MOV EDX,EAX + LEA EAX,TempAnsiStr + PUSH EBX + MOV EBX, SaveGOT + CALL ESI + POP EBX + MOV ESI,TempAnsiStr + MOV EAX,ESI + JMP @CvtStrRef + +@CvtAnsiStr: + CMP CL,'S' + JNE @CvtError + MOV ESI,EAX + +@CvtStrRef: + OR ESI,ESI + JE @CvtEmptyStr + MOV ECX,[ESI-4] + +@CvtStrLen: + CMP ECX,Prec + JA @E1 + RET +@E1: MOV ECX,Prec + RET + +@CvtPChar: + CMP CL,'S' + JNE @CvtError + MOV ESI,EAX + PUSH EDI + MOV EDI,EAX + XOR AL,AL + MOV ECX,Prec + JECXZ @F1 + REPNE SCASB + JNE @F1 + DEC EDI +@F1: MOV ECX,EDI + SUB ECX,ESI + POP EDI + RET + +@CvtPointer: + CMP CL,'P' + JNE @CvtError + MOV EDX,8 + MOV ECX,16 + LEA ESI,StrBuf[16] + JMP CvtInt + +@CvtCurrency: + MOV BH,fvCurrency + JMP @CvtFloat + +@CvtExtended: + MOV BH,fvExtended + +@CvtFloat: + MOV ESI,EAX + MOV BL,ffGeneral + CMP CL,'G' + JE @G2 + MOV BL,ffExponent + CMP CL,'E' + JE @G2 + MOV BL,ffFixed + CMP CL,'F' + JE @G1 + MOV BL,ffNumber + CMP CL,'N' + JE @G1 + CMP CL,'M' + JNE @CvtError + MOV BL,ffCurrency +@G1: MOV EAX,18 + MOV EDX,Prec + CMP EDX,EAX + JBE @G3 + MOV EDX,2 + CMP CL,'M' + JNE @G3 + MOV EDX,FormatSettings + MOVZX EDX,[EDX].TFormatSettings.CurrencyDecimals + JMP @G3 +@G2: MOV EAX,Prec + MOV EDX,3 + CMP EAX,18 + JBE @G3 + MOV EAX,15 +@G3: PUSH EBX + PUSH EAX + PUSH EDX + MOV EDX,[FormatSettings] + PUSH EDX + LEA EAX,StrBuf + MOV EDX,ESI + MOVZX ECX,BH + MOV EBX, SaveGOT + CALL FloatToTextEx + MOV ECX,EAX + LEA ESI,StrBuf + RET + +@ClearTmpAnsiStr: + PUSH EBX + PUSH EAX + LEA EAX,TempAnsiStr + MOV EBX, SaveGOT + CALL System.@LStrClr + POP EAX + POP EBX + RET + +@Exit: + CALL @ClearTmpAnsiStr + POP EDI + POP ESI + POP EBX +end; + +function StrFmt(Buffer, Format: PChar; const Args: array of const): PChar; +begin + if (Buffer <> nil) and (Format <> nil) then + begin + Buffer[FormatBuf(Buffer^, MaxInt, Format^, StrLen(Format), Args)] := #0; + Result := Buffer; + end + else + Result := nil; +end; + +function StrFmt(Buffer, Format: PChar; const Args: array of const; + const FormatSettings: TFormatSettings): PChar; +begin + if (Buffer <> nil) and (Format <> nil) then + begin + Buffer[FormatBuf(Buffer^, MaxInt, Format^, StrLen(Format), Args, + FormatSettings)] := #0; + Result := Buffer; + end + else + Result := nil; +end; + +function StrLFmt(Buffer: PChar; MaxBufLen: Cardinal; Format: PChar; + const Args: array of const): PChar; +begin + if (Buffer <> nil) and (Format <> nil) then + begin + Buffer[FormatBuf(Buffer^, MaxBufLen, Format^, StrLen(Format), Args)] := #0; + Result := Buffer; + end + else + Result := nil; +end; + +function StrLFmt(Buffer: PChar; MaxBufLen: Cardinal; Format: PChar; + const Args: array of const; const FormatSettings: TFormatSettings): PChar; +begin + if (Buffer <> nil) and (Format <> nil) then + begin + Buffer[FormatBuf(Buffer^, MaxBufLen, Format^, StrLen(Format), Args, + FormatSettings)] := #0; + Result := Buffer; + end + else + Result := nil; +end; + +function Format(const Format: string; const Args: array of const): string; +begin + FmtStr(Result, Format, Args); +end; + +function Format(const Format: string; const Args: array of const; + const FormatSettings: TFormatSettings): string; +begin + FmtStr(Result, Format, Args, FormatSettings); +end; + +procedure FmtStr(var Result: string; const Format: string; + const Args: array of const); +var + Len, BufLen: Integer; + Buffer: array[0..4095] of Char; +begin + BufLen := SizeOf(Buffer); + if Length(Format) < (sizeof(Buffer) - (sizeof(Buffer) div 4)) then + Len := FormatBuf(Buffer, sizeof(Buffer) - 1, Pointer(Format)^, Length(Format), Args) + else + begin + BufLen := Length(Format); + Len := BufLen; + end; + if Len >= BufLen - 1 then + begin + while Len >= BufLen - 1 do + begin + Inc(BufLen, BufLen); + Result := ''; // prevent copying of existing data, for speed + SetLength(Result, BufLen); + Len := FormatBuf(Pointer(Result)^, BufLen - 1, Pointer(Format)^, + Length(Format), Args); + end; + SetLength(Result, Len); + end + else + SetString(Result, Buffer, Len); +end; + +procedure FmtStr(var Result: string; const Format: string; + const Args: array of const; const FormatSettings: TFormatSettings); +var + Len, BufLen: Integer; + Buffer: array[0..4095] of Char; +begin + BufLen := SizeOf(Buffer); + if Length(Format) < (sizeof(Buffer) - (sizeof(Buffer) div 4)) then + Len := FormatBuf(Buffer, sizeof(Buffer) - 1, Pointer(Format)^, Length(Format), + Args, FormatSettings) + else + begin + BufLen := Length(Format); + Len := BufLen; + end; + if Len >= BufLen - 1 then + begin + while Len >= BufLen - 1 do + begin + Inc(BufLen, BufLen); + Result := ''; // prevent copying of existing data, for speed + SetLength(Result, BufLen); + Len := FormatBuf(Pointer(Result)^, BufLen - 1, Pointer(Format)^, + Length(Format), Args, FormatSettings); + end; + SetLength(Result, Len); + end + else + SetString(Result, Buffer, Len); +end; + +procedure WideFormatError(ErrorCode: Integer; Format: PWideChar; + FmtLen: Cardinal); +var + WideFormat: WideString; + FormatText: string; +begin + SetLength(WideFormat, FmtLen); + SetString(WideFormat, Format, FmtLen); + FormatText := WideFormat; + FormatError(ErrorCode, PChar(FormatText), FmtLen); +end; + +procedure WideFormatVarToStr(var S: WideString; const V: TVarData); +begin + if Assigned(System.VarToWStrProc) then + System.VarToWStrProc(S, V) + else + System.Error(reVarInvalidOp); +end; + +function WideFormatBuf(var Buffer; BufLen: Cardinal; const Format; + FmtLen: Cardinal; const Args: array of const): Cardinal; +var + ArgIndex, Width, Prec: Integer; + BufferOrg, FormatOrg, FormatPtr: PWideChar; + JustFlag: WideChar; + StrBuf: array[0..64] of WideChar; + TempWideStr: WideString; + SaveGOT: Integer; +{ in: eax <-> Buffer } +{ in: edx <-> BufLen } +{ in: ecx <-> Format } + +asm + PUSH EBX + PUSH ESI + PUSH EDI + MOV EDI,EAX + MOV ESI,ECX +{$IFDEF PIC} + CALL GetGOT +{$ELSE} + XOR EAX,EAX +{$ENDIF} + MOV SaveGOT,EAX + MOV ECX,FmtLen + LEA ECX,[ECX*2+ESI] + MOV BufferOrg,EDI + XOR EAX,EAX + MOV ArgIndex,EAX + MOV TempWideStr,EAX + +@Loop: + OR EDX,EDX + JE @Done + +@NextChar: + CMP ESI,ECX + JE @Done + LODSW + CMP AX,'%' + JE @Format + +@StoreChar: + STOSW + DEC EDX + JNE @NextChar + +@Done: + MOV EAX,EDI + SUB EAX,BufferOrg + SHR EAX,1 + JMP @Exit + +@Format: + CMP ESI,ECX + JE @Done + LODSW + CMP AX,'%' + JE @StoreChar + LEA EBX,[ESI-4] + MOV FormatOrg,EBX +@A0: MOV JustFlag,AX + CMP AX,'-' + JNE @A1 + CMP ESI,ECX + JE @Done + LODSW +@A1: CALL @Specifier + CMP AX,':' + JNE @A2 + MOV ArgIndex,EBX + CMP ESI,ECX + JE @Done + LODSW + JMP @A0 + +@A2: MOV Width,EBX + MOV EBX,-1 + CMP AX,'.' + JNE @A3 + CMP ESI,ECX + JE @Done + LODSW + CALL @Specifier +@A3: MOV Prec,EBX + MOV FormatPtr,ESI + PUSH ECX + PUSH EDX + + CALL @Convert + + POP EDX + MOV EBX,Width + SUB EBX,ECX //(* ECX <=> number of characters output *) + JAE @A4 //(* jump -> output smaller than width *) + XOR EBX,EBX + +@A4: CMP JustFlag,'-' + JNE @A6 + SUB EDX,ECX + JAE @A5 + ADD ECX,EDX + XOR EDX,EDX + +@A5: REP MOVSW + +@A6: XCHG EBX,ECX + SUB EDX,ECX + JAE @A7 + ADD ECX,EDX + XOR EDX,EDX +@A7: MOV AX,' ' + REP STOSW + XCHG EBX,ECX + SUB EDX,ECX + JAE @A8 + ADD ECX,EDX + XOR EDX,EDX +@A8: REP MOVSW + POP ECX + MOV ESI,FormatPtr + JMP @Loop + +@Specifier: + XOR EBX,EBX + CMP AX,'*' + JE @B3 +@B1: CMP AX,'0' + JB @B5 + CMP AX,'9' + JA @B5 + IMUL EBX,EBX,10 + SUB AX,'0' + MOVZX EAX,AX + ADD EBX,EAX + CMP ESI,ECX + JE @B2 + LODSW + JMP @B1 +@B2: POP EAX + JMP @Done +@B3: MOV EAX,ArgIndex + CMP EAX,Args.Integer[-4] + JG @B4 + INC ArgIndex + MOV EBX,Args + CMP [EBX+EAX*8].Byte[4],vtInteger + MOV EBX,[EBX+EAX*8] + JE @B4 + XOR EBX,EBX +@B4: CMP ESI,ECX + JE @B2 + LODSW +@B5: RET + +@Convert: + AND AL,0DFH + MOV CL,AL + MOV EAX,1 + MOV EBX,ArgIndex + CMP EBX,Args.Integer[-4] + JG @ErrorExit + INC ArgIndex + MOV ESI,Args + LEA ESI,[ESI+EBX*8] + MOV EAX,[ESI].Integer[0] // TVarRec.data + MOVZX EDX,[ESI].Byte[4] // TVarRec.VType +{$IFDEF PIC} + MOV EBX, SaveGOT + ADD EBX, offset @CvtVector + MOV EBX, [EBX+EDX*4] + ADD EBX, SaveGOT + JMP EBX +{$ELSE} + JMP @CvtVector.Pointer[EDX*4] +{$ENDIF} + +@CvtVector: + DD @CvtInteger // vtInteger + DD @CvtBoolean // vtBoolean + DD @CvtChar // vtChar + DD @CvtExtended // vtExtended + DD @CvtShortStr // vtString + DD @CvtPointer // vtPointer + DD @CvtPChar // vtPChar + DD @CvtObject // vtObject + DD @CvtClass // vtClass + DD @CvtWideChar // vtWideChar + DD @CvtPWideChar // vtPWideChar + DD @CvtAnsiStr // vtAnsiString + DD @CvtCurrency // vtCurrency + DD @CvtVariant // vtVariant + DD @CvtInterface // vtInterface + DD @CvtWideString // vtWideString + DD @CvtInt64 // vtInt64 + +@CvtBoolean: +@CvtObject: +@CvtClass: +@CvtInterface: +@CvtError: + XOR EAX,EAX + +@ErrorExit: + CALL @ClearTmpWideStr + MOV EDX,FormatOrg + MOV ECX,FormatPtr + SUB ECX,EDX + SHR ECX,1 + MOV EBX, SaveGOT +{$IFDEF PC_MAPPED_EXCEPTIONS} + // Because of all the assembly code here, we can't call a routine + // that throws an exception if it looks like we're still on the + // stack. The static disassembler cannot give sufficient unwind + // frame info to unwind the confusion that is generated from the + // assembly code above. So before we throw the exception, we + // go to some lengths to excise ourselves from the stack chain. + // We were passed 12 bytes of parameters on the stack, and we have + // to make sure that we get rid of those, too. + MOV ESP, EBP // Ditch everthing to the frame + MOV EBP, [ESP + 4] // Get the return addr + MOV [ESP + 16], EBP // Move the ret addr up in the stack + POP EBP // Ditch the rest of the frame + ADD ESP, 12 // Ditch the space that was taken by params + JMP WideFormatError // Off to FormatErr +{$ELSE} + CALL WideFormatError +{$ENDIF} + // The above call raises an exception and does not return + +@CvtInt64: + // CL <= format character + // EAX <= address of int64 + // EBX <= TVarRec.VType + + LEA ESI,StrBuf[64] + MOV EDX, Prec + CMP EDX, 32 + JBE @I64_1 // zero padded field width > buffer => no padding + XOR EDX, EDX +@I64_1: MOV EBX, ECX + SUB CL, 'D' + JZ CvtInt64W // branch predict backward jump taken + MOV ECX, 16 + CMP BL, 'X' + JE CvtInt64W + MOV ECX, 10 + CMP BL, 'U' + JE CvtInt64W + JMP @CvtError + +@CvtInteger: + LEA ESI,StrBuf[32] + MOV EDX, Prec + MOV EBX, ECX + CMP EDX, 16 + JBE @C1 // zero padded field width > buffer => no padding + XOR EDX, EDX +@C1: SUB CL, 'D' + JZ CvtIntW // branch predict backward jump taken + MOV ECX, 16 + CMP BL, 'X' + JE CvtIntW + MOV ECX, 10 + CMP BL, 'U' + JE CvtIntW + JMP @CvtError + +@CvtChar: + CMP CL,'S' + JNE @CvtError + MOV EAX,ESI + MOV ECX,1 + JMP @CvtAnsiThingLen + +@CvtWideChar: + CMP CL,'S' + JNE @CvtError + MOV ECX,1 + RET + +@CvtVariant: + CMP CL,'S' + JNE @CvtError + CMP [EAX].TVarData.VType,varNull + JBE @CvtEmptyStr + MOV EDX,EAX + LEA EAX,TempWideStr + CALL WideFormatVarToStr + MOV ESI,TempWideStr + JMP @CvtWideStrRef + +@CvtEmptyStr: + XOR ECX,ECX + RET + +@CvtShortStr: + CMP CL,'S' + JNE @CvtError + MOVZX ECX,BYTE PTR [EAX] + INC EAX + +@CvtAnsiThingLen: + MOV ESI,OFFSET System.@WStrFromPCharLen + JMP @CvtAnsiThing + +@CvtPChar: + MOV ESI,OFFSET System.@WStrFromPChar + JMP @CvtAnsiThingTest + +@CvtAnsiStr: + MOV ESI,OFFSET System.@WStrFromLStr + +@CvtAnsiThingTest: + CMP CL,'S' + JNE @CvtError + +@CvtAnsiThing: + ADD ESI, SaveGOT +{$IFDEF PIC} + MOV ESI, [ESI] +{$ENDIF} + MOV EDX,EAX + LEA EAX,TempWideStr + PUSH EBX + MOV EBX, SaveGOT + CALL ESI + POP EBX + MOV ESI,TempWideStr + JMP @CvtWideStrRef + +@CvtWideString: + CMP CL,'S' + JNE @CvtError + MOV ESI,EAX + +@CvtWideStrRef: + OR ESI,ESI + JE @CvtEmptyStr + MOV ECX,[ESI-4] + SHR ECX,1 + +@CvtWideStrLen: + CMP ECX,Prec + JA @E1 + RET +@E1: MOV ECX,Prec + RET + +@CvtPWideChar: + CMP CL,'S' + JNE @CvtError + MOV ESI,EAX + PUSH EDI + MOV EDI,EAX + XOR EAX,EAX + MOV ECX,Prec + JECXZ @F1 + REPNE SCASW + JNE @F1 + DEC EDI + DEC EDI +@F1: MOV ECX,EDI + SUB ECX,ESI + SHR ECX,1 + POP EDI + RET + +@CvtPointer: + CMP CL,'P' + JNE @CvtError + MOV EDX,8 + MOV ECX,16 + LEA ESI,StrBuf[32] + JMP CvtInt + +@CvtCurrency: + MOV BH,fvCurrency + JMP @CvtFloat + +@CvtExtended: + MOV BH,fvExtended + +@CvtFloat: + MOV ESI,EAX + MOV BL,ffGeneral + CMP CL,'G' + JE @G2 + MOV BL,ffExponent + CMP CL,'E' + JE @G2 + MOV BL,ffFixed + CMP CL,'F' + JE @G1 + MOV BL,ffNumber + CMP CL,'N' + JE @G1 + CMP CL,'M' + JNE @CvtError + MOV BL,ffCurrency +@G1: MOV EAX,18 + MOV EDX,Prec + CMP EDX,EAX + JBE @G3 + MOV EDX,2 + CMP CL,'M' + JNE @G3 + MOVZX EDX,CurrencyDecimals + JMP @G3 +@G2: MOV EAX,Prec + MOV EDX,3 + CMP EAX,18 + JBE @G3 + MOV EAX,15 +@G3: PUSH EBX + PUSH EAX + PUSH EDX + LEA EAX,StrBuf + MOV EDX,ESI + MOVZX ECX,BH + MOV EBX, SaveGOT + CALL FloatToText + MOV ECX,EAX + LEA EDX,StrBuf + LEA EAX,TempWideStr + MOV EBX, SaveGOT + CALL System.@WStrFromPCharLen + MOV ESI,TempWideStr + OR ESI,ESI + JE @CvtEmptyStr + MOV ECX,[ESI-4] + SHR ECX,1 + RET + +@ClearTmpWideStr: + PUSH EBX + PUSH EAX + LEA EAX,TempWideStr + MOV EBX, SaveGOT + CALL System.@WStrClr + POP EAX + POP EBX + RET + +@Exit: + CALL @ClearTmpWideStr + POP EDI + POP ESI + POP EBX +end; + +function WideFormatBuf(var Buffer; BufLen: Cardinal; const Format; + FmtLen: Cardinal; const Args: array of const; + const FormatSettings: TFormatSettings): Cardinal; +var + ArgIndex, Width, Prec: Integer; + BufferOrg, FormatOrg, FormatPtr: PWideChar; + JustFlag: WideChar; + StrBuf: array[0..64] of WideChar; + TempWideStr: WideString; + SaveGOT: Integer; +{ in: eax <-> Buffer } +{ in: edx <-> BufLen } +{ in: ecx <-> Format } + +asm + PUSH EBX + PUSH ESI + PUSH EDI + MOV EDI,EAX + MOV ESI,ECX +{$IFDEF PIC} + CALL GetGOT +{$ELSE} + XOR EAX,EAX +{$ENDIF} + MOV SaveGOT,EAX + MOV ECX,FmtLen + LEA ECX,[ECX*2+ESI] + MOV BufferOrg,EDI + XOR EAX,EAX + MOV ArgIndex,EAX + MOV TempWideStr,EAX + +@Loop: + OR EDX,EDX + JE @Done + +@NextChar: + CMP ESI,ECX + JE @Done + LODSW + CMP AX,'%' + JE @Format + +@StoreChar: + STOSW + DEC EDX + JNE @NextChar + +@Done: + MOV EAX,EDI + SUB EAX,BufferOrg + SHR EAX,1 + JMP @Exit + +@Format: + CMP ESI,ECX + JE @Done + LODSW + CMP AX,'%' + JE @StoreChar + LEA EBX,[ESI-4] + MOV FormatOrg,EBX +@A0: MOV JustFlag,AX + CMP AX,'-' + JNE @A1 + CMP ESI,ECX + JE @Done + LODSW +@A1: CALL @Specifier + CMP AX,':' + JNE @A2 + MOV ArgIndex,EBX + CMP ESI,ECX + JE @Done + LODSW + JMP @A0 + +@A2: MOV Width,EBX + MOV EBX,-1 + CMP AX,'.' + JNE @A3 + CMP ESI,ECX + JE @Done + LODSW + CALL @Specifier +@A3: MOV Prec,EBX + MOV FormatPtr,ESI + PUSH ECX + PUSH EDX + + CALL @Convert + + POP EDX + MOV EBX,Width + SUB EBX,ECX //(* ECX <=> number of characters output *) + JAE @A4 //(* jump -> output smaller than width *) + XOR EBX,EBX + +@A4: CMP JustFlag,'-' + JNE @A6 + SUB EDX,ECX + JAE @A5 + ADD ECX,EDX + XOR EDX,EDX + +@A5: REP MOVSW + +@A6: XCHG EBX,ECX + SUB EDX,ECX + JAE @A7 + ADD ECX,EDX + XOR EDX,EDX +@A7: MOV AX,' ' + REP STOSW + XCHG EBX,ECX + SUB EDX,ECX + JAE @A8 + ADD ECX,EDX + XOR EDX,EDX +@A8: REP MOVSW + POP ECX + MOV ESI,FormatPtr + JMP @Loop + +@Specifier: + XOR EBX,EBX + CMP AX,'*' + JE @B3 +@B1: CMP AX,'0' + JB @B5 + CMP AX,'9' + JA @B5 + IMUL EBX,EBX,10 + SUB AX,'0' + MOVZX EAX,AX + ADD EBX,EAX + CMP ESI,ECX + JE @B2 + LODSW + JMP @B1 +@B2: POP EAX + JMP @Done +@B3: MOV EAX,ArgIndex + CMP EAX,Args.Integer[-4] + JG @B4 + INC ArgIndex + MOV EBX,Args + CMP [EBX+EAX*8].Byte[4],vtInteger + MOV EBX,[EBX+EAX*8] + JE @B4 + XOR EBX,EBX +@B4: CMP ESI,ECX + JE @B2 + LODSW +@B5: RET + +@Convert: + AND AL,0DFH + MOV CL,AL + MOV EAX,1 + MOV EBX,ArgIndex + CMP EBX,Args.Integer[-4] + JG @ErrorExit + INC ArgIndex + MOV ESI,Args + LEA ESI,[ESI+EBX*8] + MOV EAX,[ESI].Integer[0] // TVarRec.data + MOVZX EDX,[ESI].Byte[4] // TVarRec.VType +{$IFDEF PIC} + MOV EBX, SaveGOT + ADD EBX, offset @CvtVector + MOV EBX, [EBX+EDX*4] + ADD EBX, SaveGOT + JMP EBX +{$ELSE} + JMP @CvtVector.Pointer[EDX*4] +{$ENDIF} + +@CvtVector: + DD @CvtInteger // vtInteger + DD @CvtBoolean // vtBoolean + DD @CvtChar // vtChar + DD @CvtExtended // vtExtended + DD @CvtShortStr // vtString + DD @CvtPointer // vtPointer + DD @CvtPChar // vtPChar + DD @CvtObject // vtObject + DD @CvtClass // vtClass + DD @CvtWideChar // vtWideChar + DD @CvtPWideChar // vtPWideChar + DD @CvtAnsiStr // vtAnsiString + DD @CvtCurrency // vtCurrency + DD @CvtVariant // vtVariant + DD @CvtInterface // vtInterface + DD @CvtWideString // vtWideString + DD @CvtInt64 // vtInt64 + +@CvtBoolean: +@CvtObject: +@CvtClass: +@CvtInterface: +@CvtError: + XOR EAX,EAX + +@ErrorExit: + CALL @ClearTmpWideStr + MOV EDX,FormatOrg + MOV ECX,FormatPtr + SUB ECX,EDX + SHR ECX,1 + MOV EBX, SaveGOT +{$IFDEF PC_MAPPED_EXCEPTIONS} + // Because of all the assembly code here, we can't call a routine + // that throws an exception if it looks like we're still on the + // stack. The static disassembler cannot give sufficient unwind + // frame info to unwind the confusion that is generated from the + // assembly code above. So before we throw the exception, we + // go to some lengths to excise ourselves from the stack chain. + // We were passed 12 bytes of parameters on the stack, and we have + // to make sure that we get rid of those, too. + MOV ESP, EBP // Ditch everthing to the frame + MOV EBP, [ESP + 4] // Get the return addr + MOV [ESP + 16], EBP // Move the ret addr up in the stack + POP EBP // Ditch the rest of the frame + ADD ESP, 12 // Ditch the space that was taken by params + JMP WideFormatError // Off to FormatErr +{$ELSE} + CALL WideFormatError +{$ENDIF} + // The above call raises an exception and does not return + +@CvtInt64: + // CL <= format character + // EAX <= address of int64 + // EBX <= TVarRec.VType + + LEA ESI,StrBuf[64] + MOV EDX,Prec + CMP EDX, 32 + JBE @I64_1 // zero padded field width > buffer => no padding + XOR EDX, EDX +@I64_1: MOV EBX, ECX + SUB CL, 'D' + JZ CvtInt64W // branch predict backward jump taken + MOV ECX,16 + CMP BL, 'X' + JE CvtInt64W + MOV ECX, 10 + CMP BL, 'U' + JE CvtInt64W + JMP @CvtError + +@CvtInteger: + LEA ESI,StrBuf[32] + MOV EDX,Prec + MOV EBX, ECX + CMP EDX,16 + JBE @C1 // zero padded field width > buffer => no padding + XOR EDX, EDX +@C1: SUB CL, 'D' + JZ CvtIntW // branch predict backward jump taken + MOV ECX, 16 + CMP BL, 'X' + JE CvtIntW + MOV ECX, 10 + CMP BL, 'U' + JE CvtIntW + JMP @CvtError + +@CvtChar: + CMP CL,'S' + JNE @CvtError + MOV EAX,ESI + MOV ECX,1 + JMP @CvtAnsiThingLen + +@CvtWideChar: + CMP CL,'S' + JNE @CvtError + MOV ECX,1 + RET + +@CvtVariant: + CMP CL,'S' + JNE @CvtError + CMP [EAX].TVarData.VType,varNull + JBE @CvtEmptyStr + MOV EDX,EAX + LEA EAX,TempWideStr + CALL WideFormatVarToStr + MOV ESI,TempWideStr + JMP @CvtWideStrRef + +@CvtEmptyStr: + XOR ECX,ECX + RET + +@CvtShortStr: + CMP CL,'S' + JNE @CvtError + MOVZX ECX,BYTE PTR [EAX] + INC EAX + +@CvtAnsiThingLen: + MOV ESI,OFFSET System.@WStrFromPCharLen + JMP @CvtAnsiThing + +@CvtPChar: + MOV ESI,OFFSET System.@WStrFromPChar + JMP @CvtAnsiThingTest + +@CvtAnsiStr: + MOV ESI,OFFSET System.@WStrFromLStr + +@CvtAnsiThingTest: + CMP CL,'S' + JNE @CvtError + +@CvtAnsiThing: + ADD ESI, SaveGOT +{$IFDEF PIC} + MOV ESI, [ESI] +{$ENDIF} + MOV EDX,EAX + LEA EAX,TempWideStr + PUSH EBX + MOV EBX, SaveGOT + CALL ESI + POP EBX + MOV ESI,TempWideStr + JMP @CvtWideStrRef + +@CvtWideString: + CMP CL,'S' + JNE @CvtError + MOV ESI,EAX + +@CvtWideStrRef: + OR ESI,ESI + JE @CvtEmptyStr + MOV ECX,[ESI-4] + SHR ECX,1 + +@CvtWideStrLen: + CMP ECX,Prec + JA @E1 + RET +@E1: MOV ECX,Prec + RET + +@CvtPWideChar: + CMP CL,'S' + JNE @CvtError + MOV ESI,EAX + PUSH EDI + MOV EDI,EAX + XOR EAX,EAX + MOV ECX,Prec + JECXZ @F1 + REPNE SCASW + JNE @F1 + DEC EDI + DEC EDI +@F1: MOV ECX,EDI + SUB ECX,ESI + SHR ECX,1 + POP EDI + RET + +@CvtPointer: + CMP CL,'P' + JNE @CvtError + MOV EDX,8 + MOV ECX,16 + LEA ESI,StrBuf[32] + JMP CvtInt + +@CvtCurrency: + MOV BH,fvCurrency + JMP @CvtFloat + +@CvtExtended: + MOV BH,fvExtended + +@CvtFloat: + MOV ESI,EAX + MOV BL,ffGeneral + CMP CL,'G' + JE @G2 + MOV BL,ffExponent + CMP CL,'E' + JE @G2 + MOV BL,ffFixed + CMP CL,'F' + JE @G1 + MOV BL,ffNumber + CMP CL,'N' + JE @G1 + CMP CL,'M' + JNE @CvtError + MOV BL,ffCurrency +@G1: MOV EAX,18 + MOV EDX,Prec + CMP EDX,EAX + JBE @G3 + MOV EDX,2 + CMP CL,'M' + JNE @G3 + MOV EDX,FormatSettings + MOVZX EDX,[EDX].TFormatSettings.CurrencyDecimals + JMP @G3 +@G2: MOV EAX,Prec + MOV EDX,3 + CMP EAX,18 + JBE @G3 + MOV EAX,15 +@G3: PUSH EBX + PUSH EAX + PUSH EDX + MOV EDX,[FormatSettings] + PUSH EDX + LEA EAX,StrBuf + MOV EDX,ESI + MOVZX ECX,BH + MOV EBX, SaveGOT + CALL FloatToTextEx + MOV ECX,EAX + LEA EDX,StrBuf + LEA EAX,TempWideStr + MOV EBX, SaveGOT + CALL System.@WStrFromPCharLen + MOV ESI,TempWideStr + OR ESI,ESI + JE @CvtEmptyStr + MOV ECX,[ESI-4] + SHR ECX,1 + RET + +@ClearTmpWideStr: + PUSH EBX + PUSH EAX + LEA EAX,TempWideStr + MOV EBX, SaveGOT + CALL System.@WStrClr + POP EAX + POP EBX + RET + +@Exit: + CALL @ClearTmpWideStr + POP EDI + POP ESI + POP EBX +end; + +procedure WideFmtStr(var Result: WideString; const Format: WideString; + const Args: array of const); +const + BufSize = 2048; +var + Len, BufLen: Integer; + Buffer: array[0..BufSize-1] of WideChar; +begin + if Length(Format) < (BufSize - (BufSize div 4)) then + begin + BufLen := BufSize; + Len := WideFormatBuf(Buffer, BufSize - 1, Pointer(Format)^, Length(Format), Args); + if Len < BufLen - 1 then + begin + SetString(Result, Buffer, Len); + Exit; + end; + end + else + begin + BufLen := Length(Format); + Len := BufLen; + end; + + while Len >= BufLen - 1 do + begin + Inc(BufLen, BufLen); + Result := ''; // prevent copying of existing data, for speed + SetLength(Result, BufLen); + Len := WideFormatBuf(Pointer(Result)^, BufLen - 1, Pointer(Format)^, + Length(Format), Args); + end; + SetLength(Result, Len); +end; + +procedure WideFmtStr(var Result: WideString; const Format: WideString; + const Args: array of const; const FormatSettings: TFormatSettings); +const + BufSize = 2048; +var + Len, BufLen: Integer; + Buffer: array[0..BufSize-1] of WideChar; +begin + if Length(Format) < (BufSize - (BufSize div 4)) then + begin + BufLen := BufSize; + Len := WideFormatBuf(Buffer, BufSize - 1, Pointer(Format)^, + Length(Format), Args, FormatSettings); + if Len < BufLen - 1 then + begin + SetString(Result, Buffer, Len); + Exit; + end; + end + else + begin + BufLen := Length(Format); + Len := BufLen; + end; + + while Len >= BufLen - 1 do + begin + Inc(BufLen, BufLen); + Result := ''; // prevent copying of existing data, for speed + SetLength(Result, BufLen); + Len := WideFormatBuf(Pointer(Result)^, BufLen - 1, Pointer(Format)^, + Length(Format), Args, FormatSettings); + end; + SetLength(Result, Len); +end; + +function WideFormat(const Format: WideString; const Args: array of const): WideString; +begin + WideFmtStr(Result, Format, Args); +end; + +function WideFormat(const Format: WideString; const Args: array of const; + const FormatSettings: TFormatSettings): WideString; +begin + WideFmtStr(Result, Format, Args, FormatSettings); +end; + +{ Floating point conversion routines } + +const + // 1E18 as a 64-bit integer + Const1E18Lo = $0A7640000; + Const1E18Hi = $00DE0B6B3; + FCon1E18: Extended = 1E18; + DCon10: Integer = 10; + +procedure PutExponent; +// Store exponent +// In AL = Exponent character ('E' or 'e') +// AH = Positive sign character ('+' or 0) +// BL = Zero indicator +// ECX = Minimum number of digits (0..4) +// EDX = Exponent +// EDI = Destination buffer +asm + PUSH ESI +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + MOV ESI,EAX + POP ECX + POP EAX +{$ELSE} + XOR ESI,ESI +{$ENDIF} + STOSB + OR BL,BL + JNE @@0 + XOR EDX,EDX + JMP @@1 +@@0: OR EDX,EDX + JGE @@1 + MOV AL,'-' + NEG EDX + JMP @@2 +@@1: OR AH,AH + JE @@3 + MOV AL,AH +@@2: STOSB +@@3: XCHG EAX,EDX + PUSH EAX + MOV EBX,ESP +@@4: XOR EDX,EDX + DIV [ESI].DCon10 + ADD DL,'0' + MOV [EBX],DL + INC EBX + DEC ECX + OR EAX,EAX + JNE @@4 + OR ECX,ECX + JG @@4 +@@5: DEC EBX + MOV AL,[EBX] + STOSB + CMP EBX,ESP + JNE @@5 + POP EAX + POP ESI +end; + +function FloatToText(BufferArg: PChar; const Value; ValueType: TFloatValue; + Format: TFloatFormat; Precision, Digits: Integer): Integer; +var + Buffer: Cardinal; + FloatRec: TFloatRec; + SaveGOT: Integer; + DecimalSep: Char; + ThousandSep: Char; + CurrencyStr: Pointer; + CurrFmt: Byte; + NegCurrFmt: Byte; +asm + PUSH EDI + PUSH ESI + PUSH EBX + MOV Buffer,EAX +{$IFDEF PIC} + PUSH ECX + CALL GetGOT + MOV SaveGOT,EAX + MOV ECX,[EAX].OFFSET DecimalSeparator + MOV CL,[ECX] + MOV DecimalSep,CL + MOV ECX,[EAX].OFFSET ThousandSeparator + MOV CL,[ECX].Byte + MOV ThousandSep,CL + MOV ECX,[EAX].OFFSET CurrencyString + MOV ECX,[ECX].Integer + MOV CurrencyStr,ECX + MOV ECX,[EAX].OFFSET CurrencyFormat + MOV CL,[ECX].Byte + MOV CurrFmt,CL + MOV ECX,[EAX].OFFSET NegCurrFormat + MOV CL,[ECX].Byte + MOV NegCurrFmt,CL + POP ECX +{$ELSE} + MOV AL,DecimalSeparator + MOV DecimalSep,AL + MOV AL,ThousandSeparator + MOV ThousandSep,AL + MOV EAX,CurrencyString + MOV CurrencyStr,EAX + MOV AL,CurrencyFormat + MOV CurrFmt,AL + MOV AL,NegCurrFormat + MOV NegCurrFmt,AL + MOV SaveGOT,0 +{$ENDIF} + MOV EAX,19 + CMP CL,fvExtended + JNE @@2 + MOV EAX,Precision + CMP EAX,2 + JGE @@1 + MOV EAX,2 +@@1: CMP EAX,18 + JLE @@2 + MOV EAX,18 +@@2: MOV Precision,EAX + PUSH EAX + MOV EAX,9999 + CMP Format,ffFixed + JB @@3 + MOV EAX,Digits +@@3: PUSH EAX + LEA EAX,FloatRec + CALL FloatToDecimal + MOV EDI,Buffer + MOVZX EAX,FloatRec.Exponent + SUB EAX,7FFFH + CMP EAX,2 + JAE @@4 + MOV ECX, EAX + CALL @@PutSign + LEA ESI,@@INFNAN[ECX+ECX*2] + ADD ESI,SaveGOT + MOV ECX,3 + REP MOVSB + JMP @@7 +@@4: LEA ESI,FloatRec.Digits + MOVZX EBX,Format + CMP BL,ffExponent + JE @@6 + CMP BL,ffCurrency + JA @@5 + MOVSX EAX,FloatRec.Exponent + CMP EAX,Precision + JLE @@6 +@@5: MOV BL,ffGeneral +@@6: LEA EBX,@@FormatVector[EBX*4] + ADD EBX,SaveGOT + MOV EBX,[EBX] + ADD EBX,SaveGOT + CALL EBX +@@7: MOV EAX,EDI + SUB EAX,Buffer + POP EBX + POP ESI + POP EDI + JMP @@Exit + +@@FormatVector: + DD @@PutFGeneral + DD @@PutFExponent + DD @@PutFFixed + DD @@PutFNumber + DD @@PutFCurrency + +@@INFNAN: DB 'INFNAN' + +// Get digit or '0' if at end of digit string + +@@GetDigit: + + LODSB + OR AL,AL + JNE @@a1 + MOV AL,'0' + DEC ESI +@@a1: RET + +// Store '-' if number is negative + +@@PutSign: + + CMP FloatRec.Negative,0 + JE @@b1 + MOV AL,'-' + STOSB +@@b1: RET + +// Convert number using ffGeneral format + +@@PutFGeneral: + + CALL @@PutSign + MOVSX ECX,FloatRec.Exponent + XOR EDX,EDX + CMP ECX,Precision + JG @@c1 + CMP ECX,-3 + JL @@c1 + OR ECX,ECX + JG @@c2 + MOV AL,'0' + STOSB + CMP BYTE PTR [ESI],0 + JE @@c6 + MOV AL,DecimalSep + STOSB + NEG ECX + MOV AL,'0' + REP STOSB + JMP @@c3 +@@c1: MOV ECX,1 + INC EDX +@@c2: LODSB + OR AL,AL + JE @@c4 + STOSB + LOOP @@c2 + LODSB + OR AL,AL + JE @@c5 + MOV AH,AL + MOV AL,DecimalSep + STOSW +@@c3: LODSB + OR AL,AL + JE @@c5 + STOSB + JMP @@c3 +@@c4: MOV AL,'0' + REP STOSB +@@c5: OR EDX,EDX + JE @@c6 + XOR EAX,EAX + JMP @@PutFloatExpWithDigits +@@c6: RET + +// Convert number using ffExponent format + +@@PutFExponent: + + CALL @@PutSign + CALL @@GetDigit + MOV AH,DecimalSep + STOSW + MOV ECX,Precision + DEC ECX +@@d1: CALL @@GetDigit + STOSB + LOOP @@d1 + MOV AH,'+' + +@@PutFloatExpWithDigits: + + MOV ECX,Digits + CMP ECX,4 + JBE @@PutFloatExp + XOR ECX,ECX + +// Store exponent +// In AH = Positive sign character ('+' or 0) +// ECX = Minimum number of digits (0..4) + +@@PutFloatExp: + + MOV AL,'E' + MOV BL, FloatRec.Digits.Byte + MOVSX EDX,FloatRec.Exponent + DEC EDX + CALL PutExponent + RET + +// Convert number using ffFixed or ffNumber format + +@@PutFFixed: +@@PutFNumber: + + CALL @@PutSign + +// Store number in fixed point format + +@@PutNumber: + + MOV EDX,Digits + CMP EDX,18 + JB @@f1 + MOV EDX,18 +@@f1: MOVSX ECX,FloatRec.Exponent + OR ECX,ECX + JG @@f2 + MOV AL,'0' + STOSB + JMP @@f4 +@@f2: XOR EBX,EBX + CMP Format,ffFixed + JE @@f3 + MOV EAX,ECX + DEC EAX + MOV BL,3 + DIV BL + MOV BL,AH + INC EBX +@@f3: CALL @@GetDigit + STOSB + DEC ECX + JE @@f4 + DEC EBX + JNE @@f3 + MOV AL,ThousandSep + TEST AL,AL + JZ @@f3 + STOSB + MOV BL,3 + JMP @@f3 +@@f4: OR EDX,EDX + JE @@f7 + MOV AL,DecimalSep + TEST AL,AL + JZ @@f4b + STOSB +@@f4b: JECXZ @@f6 + MOV AL,'0' +@@f5: STOSB + DEC EDX + JE @@f7 + INC ECX + JNE @@f5 +@@f6: CALL @@GetDigit + STOSB + DEC EDX + JNE @@f6 +@@f7: RET + +// Convert number using ffCurrency format + +@@PutFCurrency: + + XOR EBX,EBX + MOV BL,CurrFmt.Byte + MOV ECX,0003H + CMP FloatRec.Negative,0 + JE @@g1 + MOV BL,NegCurrFmt.Byte + MOV ECX,040FH +@@g1: CMP BL,CL + JBE @@g2 + MOV BL,CL +@@g2: ADD BL,CH + LEA EBX,@@MoneyFormats[EBX+EBX*4] + ADD EBX,SaveGOT + MOV ECX,5 +@@g10: MOV AL,[EBX] + CMP AL,'@' + JE @@g14 + PUSH ECX + PUSH EBX + CMP AL,'$' + JE @@g11 + CMP AL,'*' + JE @@g12 + STOSB + JMP @@g13 +@@g11: CALL @@PutCurSym + JMP @@g13 +@@g12: CALL @@PutNumber +@@g13: POP EBX + POP ECX + INC EBX + LOOP @@g10 +@@g14: RET + +// Store currency symbol string + +@@PutCurSym: + + PUSH ESI + MOV ESI,CurrencyStr + TEST ESI,ESI + JE @@h1 + MOV ECX,[ESI-4] + REP MOVSB +@@h1: POP ESI + RET + +// Currency formatting templates + +@@MoneyFormats: + DB '$*@@@' + DB '*$@@@' + DB '$ *@@' + DB '* $@@' + DB '($*)@' + DB '-$*@@' + DB '$-*@@' + DB '$*-@@' + DB '(*$)@' + DB '-*$@@' + DB '*-$@@' + DB '*$-@@' + DB '-* $@' + DB '-$ *@' + DB '* $-@' + DB '$ *-@' + DB '$ -*@' + DB '*- $@' + DB '($ *)' + DB '(* $)' + +@@Exit: +end; + +function FloatToText(BufferArg: PChar; const Value; ValueType: TFloatValue; + Format: TFloatFormat; Precision, Digits: Integer; + const FormatSettings: TFormatSettings): Integer; +var + Buffer: Cardinal; + FloatRec: TFloatRec; + SaveGOT: Integer; + DecimalSep: Char; + ThousandSep: Char; + CurrencyStr: Pointer; + CurrFmt: Byte; + NegCurrFmt: Byte; +asm + PUSH EDI + PUSH ESI + PUSH EBX + MOV Buffer,EAX +{$IFDEF PIC} + PUSH ECX + CALL GetGOT + MOV SaveGOT,EAX + POP ECX +{$ENDIF} + MOV EAX,FormatSettings + MOV AL,[EAX].TFormatSettings.DecimalSeparator + MOV DecimalSep,AL + MOV EAX,FormatSettings + MOV AL,[EAX].TFormatSettings.ThousandSeparator + MOV ThousandSep,AL + MOV EAX,FormatSettings + MOV EAX,[EAX].TFormatSettings.CurrencyString + MOV CurrencyStr,EAX + MOV EAX,FormatSettings + MOV AL,[EAX].TFormatSettings.CurrencyFormat + MOV CurrFmt,AL + MOV EAX,FormatSettings + MOV AL,[EAX].TFormatSettings.NegCurrFormat + MOV NegCurrFmt,AL + MOV SaveGOT,0 + MOV EAX,19 + CMP CL,fvExtended + JNE @@2 + MOV EAX,Precision + CMP EAX,2 + JGE @@1 + MOV EAX,2 +@@1: CMP EAX,18 + JLE @@2 + MOV EAX,18 +@@2: MOV Precision,EAX + PUSH EAX + MOV EAX,9999 + CMP Format,ffFixed + JB @@3 + MOV EAX,Digits +@@3: PUSH EAX + LEA EAX,FloatRec + CALL FloatToDecimal + MOV EDI,Buffer + MOVZX EAX,FloatRec.Exponent + SUB EAX,7FFFH + CMP EAX,2 + JAE @@4 + MOV ECX, EAX + CALL @@PutSign + LEA ESI,@@INFNAN[ECX+ECX*2] + ADD ESI,SaveGOT + MOV ECX,3 + REP MOVSB + JMP @@7 +@@4: LEA ESI,FloatRec.Digits + MOVZX EBX,Format + CMP BL,ffExponent + JE @@6 + CMP BL,ffCurrency + JA @@5 + MOVSX EAX,FloatRec.Exponent + CMP EAX,Precision + JLE @@6 +@@5: MOV BL,ffGeneral +@@6: LEA EBX,@@FormatVector[EBX*4] + ADD EBX,SaveGOT + MOV EBX,[EBX] + ADD EBX,SaveGOT + CALL EBX +@@7: MOV EAX,EDI + SUB EAX,Buffer + POP EBX + POP ESI + POP EDI + JMP @@Exit + +@@FormatVector: + DD @@PutFGeneral + DD @@PutFExponent + DD @@PutFFixed + DD @@PutFNumber + DD @@PutFCurrency + +@@INFNAN: DB 'INFNAN' + +// Get digit or '0' if at end of digit string + +@@GetDigit: + + LODSB + OR AL,AL + JNE @@a1 + MOV AL,'0' + DEC ESI +@@a1: RET + +// Store '-' if number is negative + +@@PutSign: + + CMP FloatRec.Negative,0 + JE @@b1 + MOV AL,'-' + STOSB +@@b1: RET + +// Convert number using ffGeneral format + +@@PutFGeneral: + + CALL @@PutSign + MOVSX ECX,FloatRec.Exponent + XOR EDX,EDX + CMP ECX,Precision + JG @@c1 + CMP ECX,-3 + JL @@c1 + OR ECX,ECX + JG @@c2 + MOV AL,'0' + STOSB + CMP BYTE PTR [ESI],0 + JE @@c6 + MOV AL,DecimalSep + STOSB + NEG ECX + MOV AL,'0' + REP STOSB + JMP @@c3 +@@c1: MOV ECX,1 + INC EDX +@@c2: LODSB + OR AL,AL + JE @@c4 + STOSB + LOOP @@c2 + LODSB + OR AL,AL + JE @@c5 + MOV AH,AL + MOV AL,DecimalSep + STOSW +@@c3: LODSB + OR AL,AL + JE @@c5 + STOSB + JMP @@c3 +@@c4: MOV AL,'0' + REP STOSB +@@c5: OR EDX,EDX + JE @@c6 + XOR EAX,EAX + JMP @@PutFloatExpWithDigits +@@c6: RET + +// Convert number using ffExponent format + +@@PutFExponent: + + CALL @@PutSign + CALL @@GetDigit + MOV AH,DecimalSep + STOSW + MOV ECX,Precision + DEC ECX +@@d1: CALL @@GetDigit + STOSB + LOOP @@d1 + MOV AH,'+' + +@@PutFloatExpWithDigits: + + MOV ECX,Digits + CMP ECX,4 + JBE @@PutFloatExp + XOR ECX,ECX + +// Store exponent +// In AH = Positive sign character ('+' or 0) +// ECX = Minimum number of digits (0..4) + +@@PutFloatExp: + + MOV AL,'E' + MOV BL, FloatRec.Digits.Byte + MOVSX EDX,FloatRec.Exponent + DEC EDX + CALL PutExponent + RET + +// Convert number using ffFixed or ffNumber format + +@@PutFFixed: +@@PutFNumber: + + CALL @@PutSign + +// Store number in fixed point format + +@@PutNumber: + + MOV EDX,Digits + CMP EDX,18 + JB @@f1 + MOV EDX,18 +@@f1: MOVSX ECX,FloatRec.Exponent + OR ECX,ECX + JG @@f2 + MOV AL,'0' + STOSB + JMP @@f4 +@@f2: XOR EBX,EBX + CMP Format,ffFixed + JE @@f3 + MOV EAX,ECX + DEC EAX + MOV BL,3 + DIV BL + MOV BL,AH + INC EBX +@@f3: CALL @@GetDigit + STOSB + DEC ECX + JE @@f4 + DEC EBX + JNE @@f3 + MOV AL,ThousandSep + TEST AL,AL + JZ @@f3 + STOSB + MOV BL,3 + JMP @@f3 +@@f4: OR EDX,EDX + JE @@f7 + MOV AL,DecimalSep + TEST AL,AL + JZ @@f4b + STOSB +@@f4b: JECXZ @@f6 + MOV AL,'0' +@@f5: STOSB + DEC EDX + JE @@f7 + INC ECX + JNE @@f5 +@@f6: CALL @@GetDigit + STOSB + DEC EDX + JNE @@f6 +@@f7: RET + +// Convert number using ffCurrency format + +@@PutFCurrency: + + XOR EBX,EBX + MOV BL,CurrFmt.Byte + MOV ECX,0003H + CMP FloatRec.Negative,0 + JE @@g1 + MOV BL,NegCurrFmt.Byte + MOV ECX,040FH +@@g1: CMP BL,CL + JBE @@g2 + MOV BL,CL +@@g2: ADD BL,CH + LEA EBX,@@MoneyFormats[EBX+EBX*4] + ADD EBX,SaveGOT + MOV ECX,5 +@@g10: MOV AL,[EBX] + CMP AL,'@' + JE @@g14 + PUSH ECX + PUSH EBX + CMP AL,'$' + JE @@g11 + CMP AL,'*' + JE @@g12 + STOSB + JMP @@g13 +@@g11: CALL @@PutCurSym + JMP @@g13 +@@g12: CALL @@PutNumber +@@g13: POP EBX + POP ECX + INC EBX + LOOP @@g10 +@@g14: RET + +// Store currency symbol string + +@@PutCurSym: + + PUSH ESI + MOV ESI,CurrencyStr + TEST ESI,ESI + JE @@h1 + MOV ECX,[ESI-4] + REP MOVSB +@@h1: POP ESI + RET + +// Currency formatting templates + +@@MoneyFormats: + DB '$*@@@' + DB '*$@@@' + DB '$ *@@' + DB '* $@@' + DB '($*)@' + DB '-$*@@' + DB '$-*@@' + DB '$*-@@' + DB '(*$)@' + DB '-*$@@' + DB '*-$@@' + DB '*$-@@' + DB '-* $@' + DB '-$ *@' + DB '* $-@' + DB '$ *-@' + DB '$ -*@' + DB '*- $@' + DB '($ *)' + DB '(* $)' + +@@Exit: +end; + +function FloatToTextFmt(Buf: PChar; const Value; ValueType: TFloatValue; + Format: PChar): Integer; + +var + Buffer: Pointer; + ThousandSep: Boolean; + DecimalSep: Char; + ThousandsSep: Char; + Scientific: Boolean; + Section: Integer; + DigitCount: Integer; + DecimalIndex: Integer; + FirstDigit: Integer; + LastDigit: Integer; + DigitPlace: Integer; + DigitDelta: Integer; + FloatRec: TFloatRec; + SaveGOT: Pointer; +asm + PUSH EDI + PUSH ESI + PUSH EBX + MOV Buffer,EAX + MOV EDI,EDX + MOV EBX,ECX +{$IFDEF PIC} + CALL GetGOT + MOV SaveGOT,EAX + MOV ECX,[EAX].OFFSET DecimalSeparator + MOV CL,[ECX].Byte + MOV DecimalSep,CL + MOV ECX,[EAX].OFFSET ThousandSeparator + MOV CL,[ECX].Byte + MOV ThousandsSep,CL +{$ELSE} + MOV SaveGOT,0 + MOV AL,DecimalSeparator + MOV DecimalSep,AL + MOV AL,ThousandSeparator + MOV ThousandsSep,AL +{$ENDIF} + MOV ECX,2 + CMP BL,fvExtended + JE @@1 + MOV EAX,[EDI].Integer + OR EAX,[EDI].Integer[4] + JE @@2 + MOV ECX,[EDI].Integer[4] + SHR ECX,31 + JMP @@2 +@@1: MOVZX EAX,[EDI].Word[8] + OR EAX,[EDI].Integer[0] + OR EAX,[EDI].Integer[4] + JE @@2 + MOVZX ECX,[EDI].Word[8] + SHR ECX,15 +@@2: CALL @@FindSection + JE @@5 + CALL @@ScanSection + MOV EAX,DigitCount + MOV EDX,9999 + CMP Scientific,0 + JNE @@3 + SUB EAX,DecimalIndex + MOV EDX,EAX + MOV EAX,18 +@@3: PUSH EAX + PUSH EDX + LEA EAX,FloatRec + MOV EDX,EDI + MOV ECX,EBX + CALL FloatToDecimal + MOV AX,FloatRec.Exponent + CMP AX,8000H + JE @@5 + CMP AX,7FFFH + JE @@5 + CMP BL,fvExtended + JNE @@6 + CMP AX,18 + JLE @@6 + CMP Scientific,0 + JNE @@6 +@@5: PUSH ffGeneral + PUSH 15 + PUSH 0 + MOV EAX,Buffer + MOV EDX,EDI + MOV ECX,EBX + CALL FloatToText + JMP @@Exit +@@6: CMP FloatRec.Digits.Byte,0 + JNE @@7 + MOV ECX,2 + CALL @@FindSection + JE @@5 + CMP ESI,Section + JE @@7 + CALL @@ScanSection +@@7: CALL @@ApplyFormat + JMP @@Exit + +// Find format section +// In ECX = Section index +// Out ESI = Section offset +// ZF = 1 if section is empty + +@@FindSection: + MOV ESI,Format + JECXZ @@fs2 +@@fs1: LODSB + CMP AL,"'" + JE @@fs4 + CMP AL,'"' + JE @@fs4 + OR AL,AL + JE @@fs2 + CMP AL,';' + JNE @@fs1 + LOOP @@fs1 + MOV AL,byte ptr [ESI] + OR AL,AL + JE @@fs2 + CMP AL,';' + JNE @@fs3 +@@fs2: MOV ESI,Format + MOV AL,byte ptr [ESI] + OR AL,AL + JE @@fs3 + CMP AL,';' +@@fs3: RET +@@fs4: MOV AH,AL +@@fs5: LODSB + CMP AL,AH + JE @@fs1 + OR AL,AL + JNE @@fs5 + JMP @@fs2 + +// Scan format section + +@@ScanSection: + PUSH EBX + MOV Section,ESI + MOV EBX,32767 + XOR ECX,ECX + XOR EDX,EDX + MOV DecimalIndex,-1 + MOV ThousandSep,DL + MOV Scientific,DL +@@ss1: LODSB +@@ss2: CMP AL,'#' + JE @@ss10 + CMP AL,'0' + JE @@ss11 + CMP AL,'.' + JE @@ss13 + CMP AL,',' + JE @@ss14 + CMP AL,"'" + JE @@ss15 + CMP AL,'"' + JE @@ss15 + CMP AL,'E' + JE @@ss20 + CMP AL,'e' + JE @@ss20 + CMP AL,';' + JE @@ss30 + OR AL,AL + JNE @@ss1 + JMP @@ss30 +@@ss10: INC EDX + JMP @@ss1 +@@ss11: CMP EDX,EBX + JGE @@ss12 + MOV EBX,EDX +@@ss12: INC EDX + MOV ECX,EDX + JMP @@ss1 +@@ss13: CMP DecimalIndex,-1 + JNE @@ss1 + MOV DecimalIndex,EDX + JMP @@ss1 +@@ss14: MOV ThousandSep,1 + JMP @@ss1 +@@ss15: MOV AH,AL +@@ss16: LODSB + CMP AL,AH + JE @@ss1 + OR AL,AL + JNE @@ss16 + JMP @@ss30 +@@ss20: LODSB + CMP AL,'-' + JE @@ss21 + CMP AL,'+' + JNE @@ss2 +@@ss21: MOV Scientific,1 +@@ss22: LODSB + CMP AL,'0' + JE @@ss22 + JMP @@ss2 +@@ss30: MOV DigitCount,EDX + CMP DecimalIndex,-1 + JNE @@ss31 + MOV DecimalIndex,EDX +@@ss31: MOV EAX,DecimalIndex + SUB EAX,ECX + JLE @@ss32 + XOR EAX,EAX +@@ss32: MOV LastDigit,EAX + MOV EAX,DecimalIndex + SUB EAX,EBX + JGE @@ss33 + XOR EAX,EAX +@@ss33: MOV FirstDigit,EAX + POP EBX + RET + +// Apply format string + +@@ApplyFormat: + CMP Scientific,0 + JE @@af1 + MOV EAX,DecimalIndex + XOR EDX,EDX + JMP @@af3 +@@af1: MOVSX EAX,FloatRec.Exponent + CMP EAX,DecimalIndex + JG @@af2 + MOV EAX,DecimalIndex +@@af2: MOVSX EDX,FloatRec.Exponent + SUB EDX,DecimalIndex +@@af3: MOV DigitPlace,EAX + MOV DigitDelta,EDX + MOV ESI,Section + MOV EDI,Buffer + LEA EBX,FloatRec.Digits + CMP FloatRec.Negative,0 + JE @@af10 + CMP ESI,Format + JNE @@af10 + MOV AL,'-' + STOSB +@@af10: LODSB + CMP AL,'#' + JE @@af20 + CMP AL,'0' + JE @@af20 + CMP AL,'.' + JE @@af10 + CMP AL,',' + JE @@af10 + CMP AL,"'" + JE @@af25 + CMP AL,'"' + JE @@af25 + CMP AL,'E' + JE @@af30 + CMP AL,'e' + JE @@af30 + CMP AL,';' + JE @@af40 + OR AL,AL + JE @@af40 +@@af11: STOSB + JMP @@af10 +@@af20: CALL @@PutFmtDigit + JMP @@af10 +@@af25: MOV AH,AL +@@af26: LODSB + CMP AL,AH + JE @@af10 + OR AL,AL + JE @@af40 + STOSB + JMP @@af26 +@@af30: MOV AH,[ESI] + CMP AH,'+' + JE @@af31 + CMP AH,'-' + JNE @@af11 + XOR AH,AH +@@af31: MOV ECX,-1 +@@af32: INC ECX + INC ESI + CMP [ESI].Byte,'0' + JE @@af32 + CMP ECX,4 + JB @@af33 + MOV ECX,4 +@@af33: PUSH EBX + MOV BL,FloatRec.Digits.Byte + MOVSX EDX,FloatRec.Exponent + SUB EDX,DecimalIndex + CALL PutExponent + POP EBX + JMP @@af10 +@@af40: MOV EAX,EDI + SUB EAX,Buffer + RET + +// Store formatted digit + +@@PutFmtDigit: + CMP DigitDelta,0 + JE @@fd3 + JL @@fd2 +@@fd1: CALL @@fd3 + DEC DigitDelta + JNE @@fd1 + JMP @@fd3 +@@fd2: INC DigitDelta + MOV EAX,DigitPlace + CMP EAX,FirstDigit + JLE @@fd4 + JMP @@fd7 +@@fd3: MOV AL,[EBX] + INC EBX + OR AL,AL + JNE @@fd5 + DEC EBX + MOV EAX,DigitPlace + CMP EAX,LastDigit + JLE @@fd7 +@@fd4: MOV AL,'0' +@@fd5: CMP DigitPlace,0 + JNE @@fd6 + MOV AH,AL + MOV AL,DecimalSep + STOSW + JMP @@fd7 +@@fd6: STOSB + CMP ThousandSep,0 + JE @@fd7 + MOV EAX,DigitPlace + CMP EAX,1 + JLE @@fd7 + MOV DL,3 + DIV DL + CMP AH,1 + JNE @@fd7 + MOV AL,ThousandsSep + TEST AL,AL + JZ @@fd7 + STOSB +@@fd7: DEC DigitPlace + RET + +@@exit: + POP EBX + POP ESI + POP EDI +end; + +function FloatToTextFmt(Buf: PChar; const Value; ValueType: TFloatValue; + Format: PChar; const FormatSettings: TFormatSettings): Integer; + +var + Buffer: Pointer; + ThousandSep: Boolean; + DecimalSep: Char; + ThousandsSep: Char; + Scientific: Boolean; + Section: Integer; + DigitCount: Integer; + DecimalIndex: Integer; + FirstDigit: Integer; + LastDigit: Integer; + DigitPlace: Integer; + DigitDelta: Integer; + FloatRec: TFloatRec; + SaveGOT: Pointer; +asm + PUSH EDI + PUSH ESI + PUSH EBX + MOV Buffer,EAX + MOV EDI,EDX + MOV EBX,ECX +{$IFDEF PIC} + CALL GetGOT + MOV SaveGOT,EAX +{$ELSE} + MOV SaveGOT,0 +{$ENDIF} + MOV EAX,FormatSettings + MOV AL,[EAX].TFormatSettings.DecimalSeparator + MOV DecimalSep,AL + MOV EAX,FormatSettings + MOV AL,[EAX].TFormatSettings.ThousandSeparator + MOV ThousandsSep,AL + MOV ECX,2 + CMP BL,fvExtended + JE @@1 + MOV EAX,[EDI].Integer + OR EAX,[EDI].Integer[4] + JE @@2 + MOV ECX,[EDI].Integer[4] + SHR ECX,31 + JMP @@2 +@@1: MOVZX EAX,[EDI].Word[8] + OR EAX,[EDI].Integer[0] + OR EAX,[EDI].Integer[4] + JE @@2 + MOVZX ECX,[EDI].Word[8] + SHR ECX,15 +@@2: CALL @@FindSection + JE @@5 + CALL @@ScanSection + MOV EAX,DigitCount + MOV EDX,9999 + CMP Scientific,0 + JNE @@3 + SUB EAX,DecimalIndex + MOV EDX,EAX + MOV EAX,18 +@@3: PUSH EAX + PUSH EDX + LEA EAX,FloatRec + MOV EDX,EDI + MOV ECX,EBX + CALL FloatToDecimal + MOV AX,FloatRec.Exponent + CMP AX,8000H + JE @@5 + CMP AX,7FFFH + JE @@5 + CMP BL,fvExtended + JNE @@6 + CMP AX,18 + JLE @@6 + CMP Scientific,0 + JNE @@6 +@@5: PUSH ffGeneral + PUSH 15 + PUSH 0 + MOV EAX,[FormatSettings] + PUSH EAX + MOV EAX,Buffer + MOV EDX,EDI + MOV ECX,EBX + CALL FloatToTextEx + JMP @@Exit +@@6: CMP FloatRec.Digits.Byte,0 + JNE @@7 + MOV ECX,2 + CALL @@FindSection + JE @@5 + CMP ESI,Section + JE @@7 + CALL @@ScanSection +@@7: CALL @@ApplyFormat + JMP @@Exit + +// Find format section +// In ECX = Section index +// Out ESI = Section offset +// ZF = 1 if section is empty + +@@FindSection: + MOV ESI,Format + JECXZ @@fs2 +@@fs1: LODSB + CMP AL,"'" + JE @@fs4 + CMP AL,'"' + JE @@fs4 + OR AL,AL + JE @@fs2 + CMP AL,';' + JNE @@fs1 + LOOP @@fs1 + MOV AL,byte ptr [ESI] + OR AL,AL + JE @@fs2 + CMP AL,';' + JNE @@fs3 +@@fs2: MOV ESI,Format + MOV AL,byte ptr [ESI] + OR AL,AL + JE @@fs3 + CMP AL,';' +@@fs3: RET +@@fs4: MOV AH,AL +@@fs5: LODSB + CMP AL,AH + JE @@fs1 + OR AL,AL + JNE @@fs5 + JMP @@fs2 + +// Scan format section + +@@ScanSection: + PUSH EBX + MOV Section,ESI + MOV EBX,32767 + XOR ECX,ECX + XOR EDX,EDX + MOV DecimalIndex,-1 + MOV ThousandSep,DL + MOV Scientific,DL +@@ss1: LODSB +@@ss2: CMP AL,'#' + JE @@ss10 + CMP AL,'0' + JE @@ss11 + CMP AL,'.' + JE @@ss13 + CMP AL,',' + JE @@ss14 + CMP AL,"'" + JE @@ss15 + CMP AL,'"' + JE @@ss15 + CMP AL,'E' + JE @@ss20 + CMP AL,'e' + JE @@ss20 + CMP AL,';' + JE @@ss30 + OR AL,AL + JNE @@ss1 + JMP @@ss30 +@@ss10: INC EDX + JMP @@ss1 +@@ss11: CMP EDX,EBX + JGE @@ss12 + MOV EBX,EDX +@@ss12: INC EDX + MOV ECX,EDX + JMP @@ss1 +@@ss13: CMP DecimalIndex,-1 + JNE @@ss1 + MOV DecimalIndex,EDX + JMP @@ss1 +@@ss14: MOV ThousandSep,1 + JMP @@ss1 +@@ss15: MOV AH,AL +@@ss16: LODSB + CMP AL,AH + JE @@ss1 + OR AL,AL + JNE @@ss16 + JMP @@ss30 +@@ss20: LODSB + CMP AL,'-' + JE @@ss21 + CMP AL,'+' + JNE @@ss2 +@@ss21: MOV Scientific,1 +@@ss22: LODSB + CMP AL,'0' + JE @@ss22 + JMP @@ss2 +@@ss30: MOV DigitCount,EDX + CMP DecimalIndex,-1 + JNE @@ss31 + MOV DecimalIndex,EDX +@@ss31: MOV EAX,DecimalIndex + SUB EAX,ECX + JLE @@ss32 + XOR EAX,EAX +@@ss32: MOV LastDigit,EAX + MOV EAX,DecimalIndex + SUB EAX,EBX + JGE @@ss33 + XOR EAX,EAX +@@ss33: MOV FirstDigit,EAX + POP EBX + RET + +// Apply format string + +@@ApplyFormat: + CMP Scientific,0 + JE @@af1 + MOV EAX,DecimalIndex + XOR EDX,EDX + JMP @@af3 +@@af1: MOVSX EAX,FloatRec.Exponent + CMP EAX,DecimalIndex + JG @@af2 + MOV EAX,DecimalIndex +@@af2: MOVSX EDX,FloatRec.Exponent + SUB EDX,DecimalIndex +@@af3: MOV DigitPlace,EAX + MOV DigitDelta,EDX + MOV ESI,Section + MOV EDI,Buffer + LEA EBX,FloatRec.Digits + CMP FloatRec.Negative,0 + JE @@af10 + CMP ESI,Format + JNE @@af10 + MOV AL,'-' + STOSB +@@af10: LODSB + CMP AL,'#' + JE @@af20 + CMP AL,'0' + JE @@af20 + CMP AL,'.' + JE @@af10 + CMP AL,',' + JE @@af10 + CMP AL,"'" + JE @@af25 + CMP AL,'"' + JE @@af25 + CMP AL,'E' + JE @@af30 + CMP AL,'e' + JE @@af30 + CMP AL,';' + JE @@af40 + OR AL,AL + JE @@af40 +@@af11: STOSB + JMP @@af10 +@@af20: CALL @@PutFmtDigit + JMP @@af10 +@@af25: MOV AH,AL +@@af26: LODSB + CMP AL,AH + JE @@af10 + OR AL,AL + JE @@af40 + STOSB + JMP @@af26 +@@af30: MOV AH,[ESI] + CMP AH,'+' + JE @@af31 + CMP AH,'-' + JNE @@af11 + XOR AH,AH +@@af31: MOV ECX,-1 +@@af32: INC ECX + INC ESI + CMP [ESI].Byte,'0' + JE @@af32 + CMP ECX,4 + JB @@af33 + MOV ECX,4 +@@af33: PUSH EBX + MOV BL,FloatRec.Digits.Byte + MOVSX EDX,FloatRec.Exponent + SUB EDX,DecimalIndex + CALL PutExponent + POP EBX + JMP @@af10 +@@af40: MOV EAX,EDI + SUB EAX,Buffer + RET + +// Store formatted digit + +@@PutFmtDigit: + CMP DigitDelta,0 + JE @@fd3 + JL @@fd2 +@@fd1: CALL @@fd3 + DEC DigitDelta + JNE @@fd1 + JMP @@fd3 +@@fd2: INC DigitDelta + MOV EAX,DigitPlace + CMP EAX,FirstDigit + JLE @@fd4 + JMP @@fd7 +@@fd3: MOV AL,[EBX] + INC EBX + OR AL,AL + JNE @@fd5 + DEC EBX + MOV EAX,DigitPlace + CMP EAX,LastDigit + JLE @@fd7 +@@fd4: MOV AL,'0' +@@fd5: CMP DigitPlace,0 + JNE @@fd6 + MOV AH,AL + MOV AL,DecimalSep + STOSW + JMP @@fd7 +@@fd6: STOSB + CMP ThousandSep,0 + JE @@fd7 + MOV EAX,DigitPlace + CMP EAX,1 + JLE @@fd7 + MOV DL,3 + DIV DL + CMP AH,1 + JNE @@fd7 + MOV AL,ThousandsSep + TEST AL,AL + JZ @@fd7 + STOSB +@@fd7: DEC DigitPlace + RET + +@@exit: + POP EBX + POP ESI + POP EDI +end; + +const +// 8087 status word masks + mIE = $0001; + mDE = $0002; + mZE = $0004; + mOE = $0008; + mUE = $0010; + mPE = $0020; + mC0 = $0100; + mC1 = $0200; + mC2 = $0400; + mC3 = $4000; + +procedure FloatToDecimal(var Result: TFloatRec; const Value; + ValueType: TFloatValue; Precision, Decimals: Integer); +var + StatWord: Word; + Exponent: Integer; + Temp: Double; + BCDValue: Extended; + SaveGOT: Pointer; +asm + PUSH EDI + PUSH ESI + PUSH EBX + MOV EBX,EAX + MOV ESI,EDX +{$IFDEF PIC} + PUSH ECX + CALL GetGOT + POP ECX + MOV SaveGOT,EAX +{$ELSE} + MOV SaveGOT,0 +{$ENDIF} + CMP CL,fvExtended + JE @@1 + CALL @@CurrToDecimal + JMP @@Exit +@@1: CALL @@ExtToDecimal + JMP @@Exit + +// Convert Extended to decimal + +@@ExtToDecimal: + + MOV AX,[ESI].Word[8] + MOV EDX,EAX + AND EAX,7FFFH + JE @@ed1 + CMP EAX,7FFFH + JNE @@ed10 +// check for special values (INF, NAN) + TEST [ESI].Word[6],8000H + JZ @@ed2 +// any significand bit set = NAN +// all significand bits clear = INF + CMP dword ptr [ESI], 0 + JNZ @@ed0 + CMP dword ptr [ESI+4], 80000000H + JZ @@ed2 +@@ed0: INC EAX +@@ed1: XOR EDX,EDX +@@ed2: MOV [EBX].TFloatRec.Digits.Byte,0 + JMP @@ed31 +@@ed10: FLD TBYTE PTR [ESI] + SUB EAX,3FFFH + IMUL EAX,19728 + SAR EAX,16 + INC EAX + MOV Exponent,EAX + MOV EAX,18 + SUB EAX,Exponent + FABS + PUSH EBX + MOV EBX,SaveGOT + CALL FPower10 + POP EBX + FRNDINT + MOV EDI,SaveGOT + FLD [EDI].FCon1E18 + FCOMP + FSTSW StatWord + FWAIT + TEST StatWord,mC0+mC3 + JE @@ed11 + FIDIV [EDI].DCon10 + INC Exponent +@@ed11: FBSTP BCDValue + LEA EDI,[EBX].TFloatRec.Digits + MOV EDX,9 + FWAIT +@@ed12: MOV AL,BCDValue[EDX-1].Byte + MOV AH,AL + SHR AL,4 + AND AH,0FH + ADD AX,'00' + STOSW + DEC EDX + JNE @@ed12 + XOR AL,AL + STOSB +@@ed20: MOV EDI,Exponent + ADD EDI,Decimals + JNS @@ed21 + XOR EAX,EAX + JMP @@ed1 +@@ed21: CMP EDI,Precision + JB @@ed22 + MOV EDI,Precision +@@ed22: CMP EDI,18 + JAE @@ed26 + CMP [EBX].TFloatRec.Digits.Byte[EDI],'5' + JB @@ed25 +@@ed23: MOV [EBX].TFloatRec.Digits.Byte[EDI],0 + DEC EDI + JS @@ed24 + INC [EBX].TFloatRec.Digits.Byte[EDI] + CMP [EBX].TFloatRec.Digits.Byte[EDI],'9' + JA @@ed23 + JMP @@ed30 +@@ed24: MOV [EBX].TFloatRec.Digits.Word,'1' + INC Exponent + JMP @@ed30 +@@ed26: MOV EDI,18 +@@ed25: MOV [EBX].TFloatRec.Digits.Byte[EDI],0 + DEC EDI + JS @@ed32 + CMP [EBX].TFloatRec.Digits.Byte[EDI],'0' + JE @@ed25 +@@ed30: MOV DX,[ESI].Word[8] +@@ed30a: + MOV EAX,Exponent +@@ed31: SHR DX,15 + MOV [EBX].TFloatRec.Exponent,AX + MOV [EBX].TFloatRec.Negative,DL + RET +@@ed32: XOR EDX,EDX + JMP @@ed30a + +@@DecimalTable: + DD 10 + DD 100 + DD 1000 + DD 10000 + +// Convert Currency to decimal + +@@CurrToDecimal: + + MOV EAX,[ESI].Integer[0] + MOV EDX,[ESI].Integer[4] + MOV ECX,EAX + OR ECX,EDX + JE @@cd20 + OR EDX,EDX + JNS @@cd1 + NEG EDX + NEG EAX + SBB EDX,0 +@@cd1: XOR ECX,ECX + MOV EDI,Decimals + OR EDI,EDI + JGE @@cd2 + XOR EDI,EDI +@@cd2: CMP EDI,4 + JL @@cd4 + MOV EDI,4 +@@cd3: INC ECX + SUB EAX,Const1E18Lo + SBB EDX,Const1E18Hi + JNC @@cd3 + DEC ECX + ADD EAX,Const1E18Lo + ADC EDX,Const1E18Hi +@@cd4: MOV Temp.Integer[0],EAX + MOV Temp.Integer[4],EDX + FILD Temp + MOV EDX,EDI + MOV EAX,4 + SUB EAX,EDX + JE @@cd5 + MOV EDI,SaveGOT + FIDIV @@DecimalTable.Integer[EDI+EAX*4-4] +@@cd5: FBSTP BCDValue + LEA EDI,[EBX].TFloatRec.Digits + FWAIT + OR ECX,ECX + JNE @@cd11 + MOV ECX,9 +@@cd10: MOV AL,BCDValue[ECX-1].Byte + MOV AH,AL + SHR AL,4 + JNE @@cd13 + MOV AL,AH + AND AL,0FH + JNE @@cd14 + DEC ECX + JNE @@cd10 + JMP @@cd20 +@@cd11: MOV AL,CL + ADD AL,'0' + STOSB + MOV ECX,9 +@@cd12: MOV AL,BCDValue[ECX-1].Byte + MOV AH,AL + SHR AL,4 +@@cd13: ADD AL,'0' + STOSB + MOV AL,AH + AND AL,0FH +@@cd14: ADD AL,'0' + STOSB + DEC ECX + JNE @@cd12 + MOV EAX,EDI + LEA ECX,[EBX].TFloatRec.Digits[EDX] + SUB EAX,ECX +@@cd15: MOV BYTE PTR [EDI],0 + DEC EDI + CMP BYTE PTR [EDI],'0' + JE @@cd15 + MOV EDX,[ESI].Integer[4] + SHR EDX,31 + JMP @@cd21 +@@cd20: XOR EAX,EAX + XOR EDX,EDX + MOV [EBX].TFloatRec.Digits.Byte[0],AL +@@cd21: MOV [EBX].TFloatRec.Exponent,AX + MOV [EBX].TFloatRec.Negative,DL + RET + +@@Exit: + POP EBX + POP ESI + POP EDI +end; + +function TextToFloat(Buffer: PChar; var Value; + ValueType: TFloatValue): Boolean; + +const +// 8087 control word +// Infinity control = 1 Affine +// Rounding Control = 0 Round to nearest or even +// Precision Control = 3 64 bits +// All interrupts masked + CWNear: Word = $133F; + +var + Temp: Integer; + CtrlWord: Word; + DecimalSep: Char; + SaveGOT: Integer; +asm + PUSH EDI + PUSH ESI + PUSH EBX + MOV ESI,EAX + MOV EDI,EDX +{$IFDEF PIC} + PUSH ECX + CALL GetGOT + POP EBX + MOV SaveGOT,EAX + MOV ECX,[EAX].OFFSET DecimalSeparator + MOV CL,[ECX].Byte + MOV DecimalSep,CL +{$ELSE} + MOV SaveGOT,0 + MOV AL,DecimalSeparator + MOV DecimalSep,AL + MOV EBX,ECX +{$ENDIF} + FSTCW CtrlWord + FCLEX +{$IFDEF PIC} + FLDCW [EAX].CWNear +{$ELSE} + FLDCW CWNear +{$ENDIF} + FLDZ + CALL @@SkipBlanks + MOV BH, byte ptr [ESI] + CMP BH,'+' + JE @@1 + CMP BH,'-' + JNE @@2 +@@1: INC ESI +@@2: MOV ECX,ESI + CALL @@GetDigitStr + XOR EDX,EDX + MOV AL,[ESI] + CMP AL,DecimalSep + JNE @@3 + INC ESI + CALL @@GetDigitStr + NEG EDX +@@3: CMP ECX,ESI + JE @@9 + MOV AL, byte ptr [ESI] + AND AL,0DFH + CMP AL,'E' + JNE @@4 + INC ESI + PUSH EDX + CALL @@GetExponent + POP EAX + ADD EDX,EAX +@@4: CALL @@SkipBlanks + CMP BYTE PTR [ESI],0 + JNE @@9 + MOV EAX,EDX + CMP BL,fvCurrency + JNE @@5 + ADD EAX,4 +@@5: PUSH EBX + MOV EBX,SaveGOT + CALL FPower10 + POP EBX + CMP BH,'-' + JNE @@6 + FCHS +@@6: CMP BL,fvExtended + JE @@7 + FISTP QWORD PTR [EDI] + JMP @@8 +@@7: FSTP TBYTE PTR [EDI] +@@8: FSTSW AX + TEST AX,mIE+mOE + JNE @@10 + MOV AL,1 + JMP @@11 +@@9: FSTP ST(0) +@@10: XOR EAX,EAX +@@11: FCLEX + FLDCW CtrlWord + FWAIT + JMP @@Exit + +@@SkipBlanks: + +@@21: LODSB + OR AL,AL + JE @@22 + CMP AL,' ' + JE @@21 +@@22: DEC ESI + RET + +// Process string of digits +// Out EDX = Digit count + +@@GetDigitStr: + + XOR EAX,EAX + XOR EDX,EDX +@@31: LODSB + SUB AL,'0'+10 + ADD AL,10 + JNC @@32 +{$IFDEF PIC} + XCHG SaveGOT,EBX + FIMUL [EBX].DCon10 + XCHG SaveGOT,EBX +{$ELSE} + FIMUL DCon10 +{$ENDIF} + MOV Temp,EAX + FIADD Temp + INC EDX + JMP @@31 +@@32: DEC ESI + RET + +// Get exponent +// Out EDX = Exponent (-4999..4999) + +@@GetExponent: + + XOR EAX,EAX + XOR EDX,EDX + MOV CL, byte ptr [ESI] + CMP CL,'+' + JE @@41 + CMP CL,'-' + JNE @@42 +@@41: INC ESI +@@42: MOV AL, byte ptr [ESI] + SUB AL,'0'+10 + ADD AL,10 + JNC @@43 + INC ESI + IMUL EDX,10 + ADD EDX,EAX + CMP EDX,500 + JB @@42 +@@43: CMP CL,'-' + JNE @@44 + NEG EDX +@@44: RET + +@@Exit: + POP EBX + POP ESI + POP EDI +end; + +function TextToFloat(Buffer: PChar; var Value; + ValueType: TFloatValue; const FormatSettings: TFormatSettings): Boolean; + +const +// 8087 control word +// Infinity control = 1 Affine +// Rounding Control = 0 Round to nearest or even +// Precision Control = 3 64 bits +// All interrupts masked + CWNear: Word = $133F; + +var + Temp: Integer; + CtrlWord: Word; + DecimalSep: Char; + SaveGOT: Integer; +asm + PUSH EDI + PUSH ESI + PUSH EBX + MOV ESI,EAX + MOV EDI,EDX +{$IFDEF PIC} + PUSH ECX + CALL GetGOT + POP EBX + MOV SaveGOT,EAX +{$ELSE} + MOV SaveGOT,0 + MOV EBX,ECX +{$ENDIF} + MOV EAX,FormatSettings + MOV AL,[EAX].TFormatSettings.DecimalSeparator + MOV DecimalSep,AL + FSTCW CtrlWord + FCLEX +{$IFDEF PIC} + FLDCW [EAX].CWNear +{$ELSE} + FLDCW CWNear +{$ENDIF} + FLDZ + CALL @@SkipBlanks + MOV BH, byte ptr [ESI] + CMP BH,'+' + JE @@1 + CMP BH,'-' + JNE @@2 +@@1: INC ESI +@@2: MOV ECX,ESI + CALL @@GetDigitStr + XOR EDX,EDX + MOV AL,[ESI] + CMP AL,DecimalSep + JNE @@3 + INC ESI + CALL @@GetDigitStr + NEG EDX +@@3: CMP ECX,ESI + JE @@9 + MOV AL, byte ptr [ESI] + AND AL,0DFH + CMP AL,'E' + JNE @@4 + INC ESI + PUSH EDX + CALL @@GetExponent + POP EAX + ADD EDX,EAX +@@4: CALL @@SkipBlanks + CMP BYTE PTR [ESI],0 + JNE @@9 + MOV EAX,EDX + CMP BL,fvCurrency + JNE @@5 + ADD EAX,4 +@@5: PUSH EBX + MOV EBX,SaveGOT + CALL FPower10 + POP EBX + CMP BH,'-' + JNE @@6 + FCHS +@@6: CMP BL,fvExtended + JE @@7 + FISTP QWORD PTR [EDI] + JMP @@8 +@@7: FSTP TBYTE PTR [EDI] +@@8: FSTSW AX + TEST AX,mIE+mOE + JNE @@10 + MOV AL,1 + JMP @@11 +@@9: FSTP ST(0) +@@10: XOR EAX,EAX +@@11: FCLEX + FLDCW CtrlWord + FWAIT + JMP @@Exit + +@@SkipBlanks: + +@@21: LODSB + OR AL,AL + JE @@22 + CMP AL,' ' + JE @@21 +@@22: DEC ESI + RET + +// Process string of digits +// Out EDX = Digit count + +@@GetDigitStr: + + XOR EAX,EAX + XOR EDX,EDX +@@31: LODSB + SUB AL,'0'+10 + ADD AL,10 + JNC @@32 +{$IFDEF PIC} + XCHG SaveGOT,EBX + FIMUL [EBX].DCon10 + XCHG SaveGOT,EBX +{$ELSE} + FIMUL DCon10 +{$ENDIF} + MOV Temp,EAX + FIADD Temp + INC EDX + JMP @@31 +@@32: DEC ESI + RET + +// Get exponent +// Out EDX = Exponent (-4999..4999) + +@@GetExponent: + + XOR EAX,EAX + XOR EDX,EDX + MOV CL, byte ptr [ESI] + CMP CL,'+' + JE @@41 + CMP CL,'-' + JNE @@42 +@@41: INC ESI +@@42: MOV AL, byte ptr [ESI] + SUB AL,'0'+10 + ADD AL,10 + JNC @@43 + INC ESI + IMUL EDX,10 + ADD EDX,EAX + CMP EDX,500 + JB @@42 +@@43: CMP CL,'-' + JNE @@44 + NEG EDX +@@44: RET + +@@Exit: + POP EBX + POP ESI + POP EDI +end; + +function FloatToStr(Value: Extended): string; +var + Buffer: array[0..63] of Char; +begin + SetString(Result, Buffer, FloatToText(Buffer, Value, fvExtended, + ffGeneral, 15, 0)); +end; + +function FloatToStr(Value: Extended; + const FormatSettings: TFormatSettings): string; +var + Buffer: array[0..63] of Char; +begin + SetString(Result, Buffer, FloatToText(Buffer, Value, fvExtended, + ffGeneral, 15, 0, FormatSettings)); +end; + +function CurrToStr(Value: Currency): string; +var + Buffer: array[0..63] of Char; +begin + SetString(Result, Buffer, FloatToText(Buffer, Value, fvCurrency, + ffGeneral, 0, 0)); +end; + +function CurrToStr(Value: Currency; + const FormatSettings: TFormatSettings): string; +var + Buffer: array[0..63] of Char; +begin + SetString(Result, Buffer, FloatToText(Buffer, Value, fvCurrency, + ffGeneral, 0, 0, FormatSettings)); +end; + +function TryFloatToCurr(const Value: Extended; out AResult: Currency): Boolean; +begin + Result := (Value >= MinCurrency) and (Value <= MaxCurrency); + if Result then + AResult := Value; +end; + +function FloatToCurr(const Value: Extended): Currency; +begin + if not TryFloatToCurr(Value, Result) then + ConvertErrorFmt(@SInvalidCurrency, [FloatToStr(Value)]); +end; + +function FloatToStrF(Value: Extended; Format: TFloatFormat; + Precision, Digits: Integer): string; +var + Buffer: array[0..63] of Char; +begin + SetString(Result, Buffer, FloatToText(Buffer, Value, fvExtended, + Format, Precision, Digits)); +end; + +function FloatToStrF(Value: Extended; Format: TFloatFormat; + Precision, Digits: Integer; const FormatSettings: TFormatSettings): string; +var + Buffer: array[0..63] of Char; +begin + SetString(Result, Buffer, FloatToText(Buffer, Value, fvExtended, + Format, Precision, Digits, FormatSettings)); +end; + +function CurrToStrF(Value: Currency; Format: TFloatFormat; + Digits: Integer): string; +var + Buffer: array[0..63] of Char; +begin + SetString(Result, Buffer, FloatToText(Buffer, Value, fvCurrency, + Format, 0, Digits)); +end; + +function CurrToStrF(Value: Currency; Format: TFloatFormat; + Digits: Integer; const FormatSettings: TFormatSettings): string; +var + Buffer: array[0..63] of Char; +begin + SetString(Result, Buffer, FloatToText(Buffer, Value, fvCurrency, + Format, 0, Digits, FormatSettings)); +end; + +function FormatFloat(const Format: string; Value: Extended): string; +var + Buffer: array[0..255] of Char; +begin + if Length(Format) > SizeOf(Buffer) - 32 then ConvertError(@SFormatTooLong); + SetString(Result, Buffer, FloatToTextFmt(Buffer, Value, fvExtended, + PChar(Format))); +end; + +function FormatFloat(const Format: string; Value: Extended; + const FormatSettings: TFormatSettings): string; +var + Buffer: array[0..255] of Char; +begin + if Length(Format) > SizeOf(Buffer) - 32 then ConvertError(@SFormatTooLong); + SetString(Result, Buffer, FloatToTextFmt(Buffer, Value, fvExtended, + PChar(Format), FormatSettings)); +end; + +function FormatCurr(const Format: string; Value: Currency): string; +var + Buffer: array[0..255] of Char; +begin + if Length(Format) > SizeOf(Buffer) - 32 then ConvertError(@SFormatTooLong); + SetString(Result, Buffer, FloatToTextFmt(Buffer, Value, fvCurrency, + PChar(Format))); +end; + +function FormatCurr(const Format: string; Value: Currency; + const FormatSettings: TFormatSettings): string; +var + Buffer: array[0..255] of Char; +begin + if Length(Format) > SizeOf(Buffer) - 32 then ConvertError(@SFormatTooLong); + SetString(Result, Buffer, FloatToTextFmt(Buffer, Value, fvCurrency, + PChar(Format), FormatSettings)); +end; + +function StrToFloat(const S: string): Extended; +begin + if not TextToFloat(PChar(S), Result, fvExtended) then + ConvertErrorFmt(@SInvalidFloat, [S]); +end; + +function StrToFloat(const S: string; + const FormatSettings: TFormatSettings): Extended; +begin + if not TextToFloat(PChar(S), Result, fvExtended, FormatSettings) then + ConvertErrorFmt(@SInvalidFloat, [S]); +end; + +function StrToFloatDef(const S: string; const Default: Extended): Extended; +begin + if not TextToFloat(PChar(S), Result, fvExtended) then + Result := Default; +end; + +function StrToFloatDef(const S: string; const Default: Extended; + const FormatSettings: TFormatSettings): Extended; +begin + if not TextToFloat(PChar(S), Result, fvExtended, FormatSettings) then + Result := Default; +end; + +function TryStrToFloat(const S: string; out Value: Extended): Boolean; +begin + Result := TextToFloat(PChar(S), Value, fvExtended); +end; + +function TryStrToFloat(const S: string; out Value: Extended; + const FormatSettings: TFormatSettings): Boolean; +begin + Result := TextToFloat(PChar(S), Value, fvExtended, FormatSettings); +end; + +function TryStrToFloat(const S: string; out Value: Double): Boolean; +var + LValue: Extended; +begin + Result := TextToFloat(PChar(S), LValue, fvExtended); + if Result then + Value := LValue; +end; + +function TryStrToFloat(const S: string; out Value: Double; + const FormatSettings: TFormatSettings): Boolean; +var + LValue: Extended; +begin + Result := TextToFloat(PChar(S), LValue, fvExtended, FormatSettings); + if Result then + Value := LValue; +end; + +function TryStrToFloat(const S: string; out Value: Single): Boolean; +var + LValue: Extended; +begin + Result := TextToFloat(PChar(S), LValue, fvExtended); + if Result then + Value := LValue; +end; + +function TryStrToFloat(const S: string; out Value: Single; + const FormatSettings: TFormatSettings): Boolean; +var + LValue: Extended; +begin + Result := TextToFloat(PChar(S), LValue, fvExtended, FormatSettings); + if Result then + Value := LValue; +end; + +function StrToCurr(const S: string): Currency; +begin + if not TextToFloat(PChar(S), Result, fvCurrency) then + ConvertErrorFmt(@SInvalidFloat, [S]); +end; + +function StrToCurr(const S: string; + const FormatSettings: TFormatSettings): Currency; +begin + if not TextToFloat(PChar(S), Result, fvCurrency, FormatSettings) then + ConvertErrorFmt(@SInvalidFloat, [S]); +end; + +function StrToCurrDef(const S: string; const Default: Currency): Currency; +begin + if not TextToFloat(PChar(S), Result, fvCurrency) then + Result := Default; +end; + +function StrToCurrDef(const S: string; const Default: Currency; + const FormatSettings: TFormatSettings): Currency; +begin + if not TextToFloat(PChar(S), Result, fvCurrency, FormatSettings) then + Result := Default; +end; + +function TryStrToCurr(const S: string; out Value: Currency): Boolean; +begin + Result := TextToFloat(PChar(S), Value, fvCurrency); +end; + +function TryStrToCurr(const S: string; out Value: Currency; + const FormatSettings: TFormatSettings): Boolean; +begin + Result := TextToFloat(PChar(S), Value, fvCurrency, FormatSettings); +end; + +{ Date/time support routines } + +const + FMSecsPerDay: Single = MSecsPerDay; + IMSecsPerDay: Integer = MSecsPerDay; + +function DateTimeToTimeStamp(DateTime: TDateTime): TTimeStamp; +asm + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX +{$ELSE} + XOR EBX,EBX +{$ENDIF} + MOV ECX,EAX + FLD DateTime + FMUL [EBX].FMSecsPerDay + SUB ESP,8 + FISTP QWORD PTR [ESP] + FWAIT + POP EAX + POP EDX + OR EDX,EDX + JNS @@1 + NEG EDX + NEG EAX + SBB EDX,0 + DIV [EBX].IMSecsPerDay + NEG EAX + JMP @@2 +@@1: DIV [EBX].IMSecsPerDay +@@2: ADD EAX,DateDelta + MOV [ECX].TTimeStamp.Time,EDX + MOV [ECX].TTimeStamp.Date,EAX + POP EBX +end; + +procedure ValidateTimeStamp(const TimeStamp: TTimeStamp); +begin + if (TimeStamp.Time < 0) or (TimeStamp.Date <= 0) then + ConvertErrorFmt(@SInvalidTimeStamp, [TimeStamp.Date, TimeStamp.Time]); +end; + +function TimeStampToDateTime(const TimeStamp: TTimeStamp): TDateTime; +asm + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX +{$ELSE} + XOR EBX,EBX +{$ENDIF} + PUSH EAX + CALL ValidateTimeStamp + POP EAX + MOV ECX,[EAX].TTimeStamp.Time + MOV EAX,[EAX].TTimeStamp.Date + SUB EAX,DateDelta + IMUL [EBX].IMSecsPerDay + OR EDX,EDX + JNS @@1 + SUB EAX,ECX + SBB EDX,0 + JMP @@2 +@@1: ADD EAX,ECX + ADC EDX,0 +@@2: PUSH EDX + PUSH EAX + FILD QWORD PTR [ESP] + FDIV [EBX].FMSecsPerDay + ADD ESP,8 + POP EBX +end; + +function MSecsToTimeStamp(MSecs: Comp): TTimeStamp; +asm + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX +{$ELSE} + XOR EBX,EBX +{$ENDIF} + MOV ECX,EAX + MOV EAX,MSecs.Integer[0] + MOV EDX,MSecs.Integer[4] + DIV [EBX].IMSecsPerDay + MOV [ECX].TTimeStamp.Time,EDX + MOV [ECX].TTimeStamp.Date,EAX + POP EBX +end; + +function TimeStampToMSecs(const TimeStamp: TTimeStamp): Comp; +asm + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX +{$ELSE} + XOR EBX,EBX +{$ENDIF} + PUSH EAX + CALL ValidateTimeStamp + POP EAX + FILD [EAX].TTimeStamp.Date + FMUL [EBX].FMSecsPerDay + FIADD [EAX].TTimeStamp.Time + POP EBX +end; + +{ Time encoding and decoding } + +function TryEncodeTime(Hour, Min, Sec, MSec: Word; out Time: TDateTime): Boolean; +begin + Result := False; + if (Hour < HoursPerDay) and (Min < MinsPerHour) and (Sec < SecsPerMin) and (MSec < MSecsPerSec) then + begin + Time := (Hour * (MinsPerHour * SecsPerMin * MSecsPerSec) + + Min * (SecsPerMin * MSecsPerSec) + + Sec * MSecsPerSec + + MSec) / MSecsPerDay; + Result := True; + end; +end; + +function EncodeTime(Hour, Min, Sec, MSec: Word): TDateTime; +begin + if not TryEncodeTime(Hour, Min, Sec, MSec, Result) then + ConvertError(@STimeEncodeError); +end; + +procedure DecodeTime(const DateTime: TDateTime; var Hour, Min, Sec, MSec: Word); +var + MinCount, MSecCount: Word; +begin + DivMod(DateTimeToTimeStamp(DateTime).Time, SecsPerMin * MSecsPerSec, MinCount, MSecCount); + DivMod(MinCount, MinsPerHour, Hour, Min); + DivMod(MSecCount, MSecsPerSec, Sec, MSec); +end; + +{ Date encoding and decoding } + +function IsLeapYear(Year: Word): Boolean; +begin + Result := (Year mod 4 = 0) and ((Year mod 100 <> 0) or (Year mod 400 = 0)); +end; + +function TryEncodeDate(Year, Month, Day: Word; out Date: TDateTime): Boolean; +var + I: Integer; + DayTable: PDayTable; +begin + Result := False; + DayTable := @MonthDays[IsLeapYear(Year)]; + if (Year >= 1) and (Year <= 9999) and (Month >= 1) and (Month <= 12) and + (Day >= 1) and (Day <= DayTable^[Month]) then + begin + for I := 1 to Month - 1 do Inc(Day, DayTable^[I]); + I := Year - 1; + Date := I * 365 + I div 4 - I div 100 + I div 400 + Day - DateDelta; + Result := True; + end; +end; + +function EncodeDate(Year, Month, Day: Word): TDateTime; +begin + if not TryEncodeDate(Year, Month, Day, Result) then + ConvertError(@SDateEncodeError); +end; + +function DecodeDateFully(const DateTime: TDateTime; var Year, Month, Day, DOW: Word): Boolean; +const + D1 = 365; + D4 = D1 * 4 + 1; + D100 = D4 * 25 - 1; + D400 = D100 * 4 + 1; +var + Y, M, D, I: Word; + T: Integer; + DayTable: PDayTable; +begin + T := DateTimeToTimeStamp(DateTime).Date; + if T <= 0 then + begin + Year := 0; + Month := 0; + Day := 0; + DOW := 0; + Result := False; + end else + begin + DOW := T mod 7 + 1; + Dec(T); + Y := 1; + while T >= D400 do + begin + Dec(T, D400); + Inc(Y, 400); + end; + DivMod(T, D100, I, D); + if I = 4 then + begin + Dec(I); + Inc(D, D100); + end; + Inc(Y, I * 100); + DivMod(D, D4, I, D); + Inc(Y, I * 4); + DivMod(D, D1, I, D); + if I = 4 then + begin + Dec(I); + Inc(D, D1); + end; + Inc(Y, I); + Result := IsLeapYear(Y); + DayTable := @MonthDays[Result]; + M := 1; + while True do + begin + I := DayTable^[M]; + if D < I then Break; + Dec(D, I); + Inc(M); + end; + Year := Y; + Month := M; + Day := D + 1; + end; +end; + +function InternalDecodeDate(const DateTime: TDateTime; var Year, Month, Day, DOW: Word): Boolean; +begin + Result := DecodeDateFully(DateTime, Year, Month, Day, DOW); + Dec(DOW); +end; + +procedure DecodeDate(const DateTime: TDateTime; var Year, Month, Day: Word); +var + Dummy: Word; +begin + DecodeDateFully(DateTime, Year, Month, Day, Dummy); +end; + +{$IFDEF MSWINDOWS} +procedure DateTimeToSystemTime(const DateTime: TDateTime; var SystemTime: TSystemTime); +begin + with SystemTime do + begin + DecodeDateFully(DateTime, wYear, wMonth, wDay, wDayOfWeek); + Dec(wDayOfWeek); + DecodeTime(DateTime, wHour, wMinute, wSecond, wMilliseconds); + end; +end; + +function SystemTimeToDateTime(const SystemTime: TSystemTime): TDateTime; +begin + with SystemTime do + begin + Result := EncodeDate(wYear, wMonth, wDay); + if Result >= 0 then + Result := Result + EncodeTime(wHour, wMinute, wSecond, wMilliSeconds) + else + Result := Result - EncodeTime(wHour, wMinute, wSecond, wMilliSeconds); + end; +end; +{$ENDIF} + +function DayOfWeek(const DateTime: TDateTime): Word; +begin + Result := DateTimeToTimeStamp(DateTime).Date mod 7 + 1; +end; + +function Date: TDateTime; +{$IFDEF MSWINDOWS} +var + SystemTime: TSystemTime; +begin + GetLocalTime(SystemTime); + with SystemTime do Result := EncodeDate(wYear, wMonth, wDay); +end; +{$ENDIF} +{$IFDEF LINUX} +var + T: TTime_T; + UT: TUnixTime; +begin + __time(@T); + localtime_r(@T, UT); + Result := EncodeDate(UT.tm_year + 1900, UT.tm_mon + 1, UT.tm_mday); +end; +{$ENDIF} + +function Time: TDateTime; +{$IFDEF MSWINDOWS} +var + SystemTime: TSystemTime; +begin + GetLocalTime(SystemTime); + with SystemTime do + Result := EncodeTime(wHour, wMinute, wSecond, wMilliSeconds); +end; +{$ENDIF} +{$IFDEF LINUX} +var + T: TTime_T; + TV: TTimeVal; + UT: TUnixTime; +begin + gettimeofday(TV, nil); + T := TV.tv_sec; + localtime_r(@T, UT); + Result := EncodeTime(UT.tm_hour, UT.tm_min, UT.tm_sec, TV.tv_usec div 1000); +end; +{$ENDIF} + +function GetTime: TDateTime; +begin + Result := Time; +end; + +function Now: TDateTime; +{$IFDEF MSWINDOWS} +var + SystemTime: TSystemTime; +begin + GetLocalTime(SystemTime); + with SystemTime do + Result := EncodeDate(wYear, wMonth, wDay) + + EncodeTime(wHour, wMinute, wSecond, wMilliseconds); +end; +{$ENDIF} +{$IFDEF LINUX} +var + T: TTime_T; + TV: TTimeVal; + UT: TUnixTime; +begin + gettimeofday(TV, nil); + T := TV.tv_sec; + localtime_r(@T, UT); + Result := EncodeDate(UT.tm_year + 1900, UT.tm_mon + 1, UT.tm_mday) + + EncodeTime(UT.tm_hour, UT.tm_min, UT.tm_sec, TV.tv_usec div 1000); +end; +{$ENDIF} + +function IncMonth(const DateTime: TDateTime; NumberOfMonths: Integer): TDateTime; +var + Year, Month, Day: Word; +begin + DecodeDate(DateTime, Year, Month, Day); + IncAMonth(Year, Month, Day, NumberOfMonths); + Result := EncodeDate(Year, Month, Day); + ReplaceTime(Result, DateTime); +end; + +procedure IncAMonth(var Year, Month, Day: Word; NumberOfMonths: Integer = 1); +var + DayTable: PDayTable; + Sign: Integer; +begin + if NumberOfMonths >= 0 then Sign := 1 else Sign := -1; + Year := Year + (NumberOfMonths div 12); + NumberOfMonths := NumberOfMonths mod 12; + Inc(Month, NumberOfMonths); + if Word(Month-1) > 11 then // if Month <= 0, word(Month-1) > 11) + begin + Inc(Year, Sign); + Inc(Month, -12 * Sign); + end; + DayTable := @MonthDays[IsLeapYear(Year)]; + if Day > DayTable^[Month] then Day := DayTable^[Month]; +end; + +procedure ReplaceTime(var DateTime: TDateTime; const NewTime: TDateTime); +begin + DateTime := Trunc(DateTime); + if DateTime >= 0 then + DateTime := DateTime + Abs(Frac(NewTime)) + else + DateTime := DateTime - Abs(Frac(NewTime)); +end; + +procedure ReplaceDate(var DateTime: TDateTime; const NewDate: TDateTime); +var + Temp: TDateTime; +begin + Temp := NewDate; + ReplaceTime(Temp, DateTime); + DateTime := Temp; +end; + +function CurrentYear: Word; +{$IFDEF MSWINDOWS} +var + SystemTime: TSystemTime; +begin + GetLocalTime(SystemTime); + Result := SystemTime.wYear; +end; +{$ENDIF} +{$IFDEF LINUX} +var + T: TTime_T; + UT: TUnixTime; +begin + __time(@T); + localtime_r(@T, UT); + Result := UT.tm_year + 1900; +end; +{$ENDIF} + +{ Date/time to string conversions } + +procedure DateTimeToString(var Result: string; const Format: string; + DateTime: TDateTime); +var + BufPos, AppendLevel: Integer; + Buffer: array[0..255] of Char; + + procedure AppendChars(P: PChar; Count: Integer); + var + N: Integer; + begin + N := SizeOf(Buffer) - BufPos; + if N > Count then N := Count; + if N <> 0 then Move(P[0], Buffer[BufPos], N); + Inc(BufPos, N); + end; + + procedure AppendString(const S: string); + begin + AppendChars(Pointer(S), Length(S)); + end; + + procedure AppendNumber(Number, Digits: Integer); + const + Format: array[0..3] of Char = '%.*d'; + var + NumBuf: array[0..15] of Char; + begin + AppendChars(NumBuf, FormatBuf(NumBuf, SizeOf(NumBuf), Format, + SizeOf(Format), [Digits, Number])); + end; + + procedure AppendFormat(Format: PChar); + var + Starter, Token, LastToken: Char; + DateDecoded, TimeDecoded, Use12HourClock, + BetweenQuotes: Boolean; + P: PChar; + Count: Integer; + Year, Month, Day, Hour, Min, Sec, MSec, H: Word; + + procedure GetCount; + var + P: PChar; + begin + P := Format; + while Format^ = Starter do Inc(Format); + Count := Format - P + 1; + end; + + procedure GetDate; + begin + if not DateDecoded then + begin + DecodeDate(DateTime, Year, Month, Day); + DateDecoded := True; + end; + end; + + procedure GetTime; + begin + if not TimeDecoded then + begin + DecodeTime(DateTime, Hour, Min, Sec, MSec); + TimeDecoded := True; + end; + end; + +{$IFDEF MSWINDOWS} + function ConvertEraString(const Count: Integer) : string; + var + FormatStr: string; + SystemTime: TSystemTime; + Buffer: array[Byte] of Char; + P: PChar; + begin + Result := ''; + with SystemTime do + begin + wYear := Year; + wMonth := Month; + wDay := Day; + end; + + FormatStr := 'gg'; + if GetDateFormat(GetThreadLocale, DATE_USE_ALT_CALENDAR, @SystemTime, + PChar(FormatStr), Buffer, SizeOf(Buffer)) <> 0 then + begin + Result := Buffer; + if Count = 1 then + begin + case SysLocale.PriLangID of + LANG_JAPANESE: + Result := Copy(Result, 1, CharToBytelen(Result, 1)); + LANG_CHINESE: + if (SysLocale.SubLangID = SUBLANG_CHINESE_TRADITIONAL) + and (ByteToCharLen(Result, Length(Result)) = 4) then + begin + P := Buffer + CharToByteIndex(Result, 3) - 1; + SetString(Result, P, CharToByteLen(P, 2)); + end; + end; + end; + end; + end; + + function ConvertYearString(const Count: Integer): string; + var + FormatStr: string; + SystemTime: TSystemTime; + Buffer: array[Byte] of Char; + begin + Result := ''; + with SystemTime do + begin + wYear := Year; + wMonth := Month; + wDay := Day; + end; + + if Count <= 2 then + FormatStr := 'yy' // avoid Win95 bug. + else + FormatStr := 'yyyy'; + + if GetDateFormat(GetThreadLocale, DATE_USE_ALT_CALENDAR, @SystemTime, + PChar(FormatStr), Buffer, SizeOf(Buffer)) <> 0 then + begin + Result := Buffer; + if (Count = 1) and (Result[1] = '0') then + Result := Copy(Result, 2, Length(Result)-1); + end; + end; +{$ENDIF} + +{$IFDEF LINUX} + function FindEra(Date: Integer): Byte; + var + I : Byte; + begin + Result := 0; + for I := 1 to EraCount do + begin + if (EraRanges[I].StartDate <= Date) and + (EraRanges[I].EndDate >= Date) then + begin + Result := I; + Exit; + end; + end; + end; + + function ConvertEraString(const Count: Integer) : String; + var + I : Byte; + begin + Result := ''; + I := FindEra(Trunc(DateTime)); + if I > 0 then + Result := EraNames[I]; + end; + + function ConvertYearString(const Count: Integer) : String; + var + I : Byte; + S : string; + begin + I := FindEra(Trunc(DateTime)); + if I > 0 then + S := IntToStr(Year - EraYearOffsets[I]) + else + S := IntToStr(Year); + while Length(S) < Count do + S := '0' + S; + if Length(S) > Count then + S := Copy(S, Length(S) - (Count - 1), Count); + Result := S; + end; +{$ENDIF} + + begin + if (Format <> nil) and (AppendLevel < 2) then + begin + Inc(AppendLevel); + LastToken := ' '; + DateDecoded := False; + TimeDecoded := False; + Use12HourClock := False; + while Format^ <> #0 do + begin + Starter := Format^; + if Starter in LeadBytes then + begin + AppendChars(Format, StrCharLength(Format)); + Format := StrNextChar(Format); + LastToken := ' '; + Continue; + end; + Format := StrNextChar(Format); + Token := Starter; + if Token in ['a'..'z'] then Dec(Token, 32); + if Token in ['A'..'Z'] then + begin + if (Token = 'M') and (LastToken = 'H') then Token := 'N'; + LastToken := Token; + end; + case Token of + 'Y': + begin + GetCount; + GetDate; + if Count <= 2 then + AppendNumber(Year mod 100, 2) else + AppendNumber(Year, 4); + end; + 'G': + begin + GetCount; + GetDate; + AppendString(ConvertEraString(Count)); + end; + 'E': + begin + GetCount; + GetDate; + AppendString(ConvertYearString(Count)); + end; + 'M': + begin + GetCount; + GetDate; + case Count of + 1, 2: AppendNumber(Month, Count); + 3: AppendString(ShortMonthNames[Month]); + else + AppendString(LongMonthNames[Month]); + end; + end; + 'D': + begin + GetCount; + case Count of + 1, 2: + begin + GetDate; + AppendNumber(Day, Count); + end; + 3: AppendString(ShortDayNames[DayOfWeek(DateTime)]); + 4: AppendString(LongDayNames[DayOfWeek(DateTime)]); + 5: AppendFormat(Pointer(ShortDateFormat)); + else + AppendFormat(Pointer(LongDateFormat)); + end; + end; + 'H': + begin + GetCount; + GetTime; + BetweenQuotes := False; + P := Format; + while P^ <> #0 do + begin + if P^ in LeadBytes then + begin + P := StrNextChar(P); + Continue; + end; + case P^ of + 'A', 'a': + if not BetweenQuotes then + begin + if ( (StrLIComp(P, 'AM/PM', 5) = 0) + or (StrLIComp(P, 'A/P', 3) = 0) + or (StrLIComp(P, 'AMPM', 4) = 0) ) then + Use12HourClock := True; + Break; + end; + 'H', 'h': + Break; + '''', '"': BetweenQuotes := not BetweenQuotes; + end; + Inc(P); + end; + H := Hour; + if Use12HourClock then + if H = 0 then H := 12 else if H > 12 then Dec(H, 12); + if Count > 2 then Count := 2; + AppendNumber(H, Count); + end; + 'N': + begin + GetCount; + GetTime; + if Count > 2 then Count := 2; + AppendNumber(Min, Count); + end; + 'S': + begin + GetCount; + GetTime; + if Count > 2 then Count := 2; + AppendNumber(Sec, Count); + end; + 'T': + begin + GetCount; + if Count = 1 then + AppendFormat(Pointer(ShortTimeFormat)) else + AppendFormat(Pointer(LongTimeFormat)); + end; + 'Z': + begin + GetCount; + GetTime; + if Count > 3 then Count := 3; + AppendNumber(MSec, Count); + end; + 'A': + begin + GetTime; + P := Format - 1; + if StrLIComp(P, 'AM/PM', 5) = 0 then + begin + if Hour >= 12 then Inc(P, 3); + AppendChars(P, 2); + Inc(Format, 4); + Use12HourClock := TRUE; + end else + if StrLIComp(P, 'A/P', 3) = 0 then + begin + if Hour >= 12 then Inc(P, 2); + AppendChars(P, 1); + Inc(Format, 2); + Use12HourClock := TRUE; + end else + if StrLIComp(P, 'AMPM', 4) = 0 then + begin + if Hour < 12 then + AppendString(TimeAMString) else + AppendString(TimePMString); + Inc(Format, 3); + Use12HourClock := TRUE; + end else + if StrLIComp(P, 'AAAA', 4) = 0 then + begin + GetDate; + AppendString(LongDayNames[DayOfWeek(DateTime)]); + Inc(Format, 3); + end else + if StrLIComp(P, 'AAA', 3) = 0 then + begin + GetDate; + AppendString(ShortDayNames[DayOfWeek(DateTime)]); + Inc(Format, 2); + end else + AppendChars(@Starter, 1); + end; + 'C': + begin + GetCount; + AppendFormat(Pointer(ShortDateFormat)); + GetTime; + if (Hour <> 0) or (Min <> 0) or (Sec <> 0) then + begin + AppendChars(' ', 1); + AppendFormat(Pointer(LongTimeFormat)); + end; + end; + '/': + if DateSeparator <> #0 then + AppendChars(@DateSeparator, 1); + ':': + if TimeSeparator <> #0 then + AppendChars(@TimeSeparator, 1); + '''', '"': + begin + P := Format; + while (Format^ <> #0) and (Format^ <> Starter) do + begin + if Format^ in LeadBytes then + Format := StrNextChar(Format) + else + Inc(Format); + end; + AppendChars(P, Format - P); + if Format^ <> #0 then Inc(Format); + end; + else + AppendChars(@Starter, 1); + end; + end; + Dec(AppendLevel); + end; + end; + +begin + BufPos := 0; + AppendLevel := 0; + if Format <> '' then AppendFormat(Pointer(Format)) else AppendFormat('C'); + SetString(Result, Buffer, BufPos); +end; + +procedure DateTimeToString(var Result: string; const Format: string; + DateTime: TDateTime; const FormatSettings: TFormatSettings); +var + BufPos, AppendLevel: Integer; + Buffer: array[0..255] of Char; + + procedure AppendChars(P: PChar; Count: Integer); + var + N: Integer; + begin + N := SizeOf(Buffer) - BufPos; + if N > Count then N := Count; + if N <> 0 then Move(P[0], Buffer[BufPos], N); + Inc(BufPos, N); + end; + + procedure AppendString(const S: string); + begin + AppendChars(Pointer(S), Length(S)); + end; + + procedure AppendNumber(Number, Digits: Integer); + const + Format: array[0..3] of Char = '%.*d'; + var + NumBuf: array[0..15] of Char; + begin + AppendChars(NumBuf, FormatBuf(NumBuf, SizeOf(NumBuf), Format, + SizeOf(Format), [Digits, Number])); + end; + + procedure AppendFormat(Format: PChar); + var + Starter, Token, LastToken: Char; + DateDecoded, TimeDecoded, Use12HourClock, + BetweenQuotes: Boolean; + P: PChar; + Count: Integer; + Year, Month, Day, Hour, Min, Sec, MSec, H: Word; + + procedure GetCount; + var + P: PChar; + begin + P := Format; + while Format^ = Starter do Inc(Format); + Count := Format - P + 1; + end; + + procedure GetDate; + begin + if not DateDecoded then + begin + DecodeDate(DateTime, Year, Month, Day); + DateDecoded := True; + end; + end; + + procedure GetTime; + begin + if not TimeDecoded then + begin + DecodeTime(DateTime, Hour, Min, Sec, MSec); + TimeDecoded := True; + end; + end; + +{$IFDEF MSWINDOWS} + function ConvertEraString(const Count: Integer) : string; + var + FormatStr: string; + SystemTime: TSystemTime; + Buffer: array[Byte] of Char; + P: PChar; + begin + Result := ''; + with SystemTime do + begin + wYear := Year; + wMonth := Month; + wDay := Day; + end; + + FormatStr := 'gg'; + if GetDateFormat(GetThreadLocale, DATE_USE_ALT_CALENDAR, @SystemTime, + PChar(FormatStr), Buffer, SizeOf(Buffer)) <> 0 then + begin + Result := Buffer; + if Count = 1 then + begin + case SysLocale.PriLangID of + LANG_JAPANESE: + Result := Copy(Result, 1, CharToBytelen(Result, 1)); + LANG_CHINESE: + if (SysLocale.SubLangID = SUBLANG_CHINESE_TRADITIONAL) + and (ByteToCharLen(Result, Length(Result)) = 4) then + begin + P := Buffer + CharToByteIndex(Result, 3) - 1; + SetString(Result, P, CharToByteLen(P, 2)); + end; + end; + end; + end; + end; + + function ConvertYearString(const Count: Integer): string; + var + FormatStr: string; + SystemTime: TSystemTime; + Buffer: array[Byte] of Char; + begin + Result := ''; + with SystemTime do + begin + wYear := Year; + wMonth := Month; + wDay := Day; + end; + + if Count <= 2 then + FormatStr := 'yy' // avoid Win95 bug. + else + FormatStr := 'yyyy'; + + if GetDateFormat(GetThreadLocale, DATE_USE_ALT_CALENDAR, @SystemTime, + PChar(FormatStr), Buffer, SizeOf(Buffer)) <> 0 then + begin + Result := Buffer; + if (Count = 1) and (Result[1] = '0') then + Result := Copy(Result, 2, Length(Result)-1); + end; + end; +{$ENDIF} + +{$IFDEF LINUX} + function FindEra(Date: Integer): Byte; + var + I : Byte; + begin + Result := 0; + for I := 1 to EraCount do + begin + if (EraRanges[I].StartDate <= Date) and + (EraRanges[I].EndDate >= Date) then + begin + Result := I; + Exit; + end; + end; + end; + + function ConvertEraString(const Count: Integer) : String; + var + I : Byte; + begin + Result := ''; + I := FindEra(Trunc(DateTime)); + if I > 0 then + Result := EraNames[I]; + end; + + function ConvertYearString(const Count: Integer) : String; + var + I : Byte; + S : string; + begin + I := FindEra(Trunc(DateTime)); + if I > 0 then + S := IntToStr(Year - EraYearOffsets[I]) + else + S := IntToStr(Year); + while Length(S) < Count do + S := '0' + S; + if Length(S) > Count then + S := Copy(S, Length(S) - (Count - 1), Count); + Result := S; + end; +{$ENDIF} + + begin + if (Format <> nil) and (AppendLevel < 2) then + begin + Inc(AppendLevel); + LastToken := ' '; + DateDecoded := False; + TimeDecoded := False; + Use12HourClock := False; + while Format^ <> #0 do + begin + Starter := Format^; + if Starter in LeadBytes then + begin + AppendChars(Format, StrCharLength(Format)); + Format := StrNextChar(Format); + LastToken := ' '; + Continue; + end; + Format := StrNextChar(Format); + Token := Starter; + if Token in ['a'..'z'] then Dec(Token, 32); + if Token in ['A'..'Z'] then + begin + if (Token = 'M') and (LastToken = 'H') then Token := 'N'; + LastToken := Token; + end; + case Token of + 'Y': + begin + GetCount; + GetDate; + if Count <= 2 then + AppendNumber(Year mod 100, 2) else + AppendNumber(Year, 4); + end; + 'G': + begin + GetCount; + GetDate; + AppendString(ConvertEraString(Count)); + end; + 'E': + begin + GetCount; + GetDate; + AppendString(ConvertYearString(Count)); + end; + 'M': + begin + GetCount; + GetDate; + case Count of + 1, 2: AppendNumber(Month, Count); + 3: AppendString(FormatSettings.ShortMonthNames[Month]); + else + AppendString(FormatSettings.LongMonthNames[Month]); + end; + end; + 'D': + begin + GetCount; + case Count of + 1, 2: + begin + GetDate; + AppendNumber(Day, Count); + end; + 3: AppendString(FormatSettings.ShortDayNames[DayOfWeek(DateTime)]); + 4: AppendString(FormatSettings.LongDayNames[DayOfWeek(DateTime)]); + 5: AppendFormat(Pointer(FormatSettings.ShortDateFormat)); + else + AppendFormat(Pointer(FormatSettings.LongDateFormat)); + end; + end; + 'H': + begin + GetCount; + GetTime; + BetweenQuotes := False; + P := Format; + while P^ <> #0 do + begin + if P^ in LeadBytes then + begin + P := StrNextChar(P); + Continue; + end; + case P^ of + 'A', 'a': + if not BetweenQuotes then + begin + if ( (StrLIComp(P, 'AM/PM', 5) = 0) + or (StrLIComp(P, 'A/P', 3) = 0) + or (StrLIComp(P, 'AMPM', 4) = 0) ) then + Use12HourClock := True; + Break; + end; + 'H', 'h': + Break; + '''', '"': BetweenQuotes := not BetweenQuotes; + end; + Inc(P); + end; + H := Hour; + if Use12HourClock then + if H = 0 then H := 12 else if H > 12 then Dec(H, 12); + if Count > 2 then Count := 2; + AppendNumber(H, Count); + end; + 'N': + begin + GetCount; + GetTime; + if Count > 2 then Count := 2; + AppendNumber(Min, Count); + end; + 'S': + begin + GetCount; + GetTime; + if Count > 2 then Count := 2; + AppendNumber(Sec, Count); + end; + 'T': + begin + GetCount; + if Count = 1 then + AppendFormat(Pointer(FormatSettings.ShortTimeFormat)) else + AppendFormat(Pointer(FormatSettings.LongTimeFormat)); + end; + 'Z': + begin + GetCount; + GetTime; + if Count > 3 then Count := 3; + AppendNumber(MSec, Count); + end; + 'A': + begin + GetTime; + P := Format - 1; + if StrLIComp(P, 'AM/PM', 5) = 0 then + begin + if Hour >= 12 then Inc(P, 3); + AppendChars(P, 2); + Inc(Format, 4); + Use12HourClock := TRUE; + end else + if StrLIComp(P, 'A/P', 3) = 0 then + begin + if Hour >= 12 then Inc(P, 2); + AppendChars(P, 1); + Inc(Format, 2); + Use12HourClock := TRUE; + end else + if StrLIComp(P, 'AMPM', 4) = 0 then + begin + if Hour < 12 then + AppendString(FormatSettings.TimeAMString) else + AppendString(FormatSettings.TimePMString); + Inc(Format, 3); + Use12HourClock := TRUE; + end else + if StrLIComp(P, 'AAAA', 4) = 0 then + begin + GetDate; + AppendString(FormatSettings.LongDayNames[DayOfWeek(DateTime)]); + Inc(Format, 3); + end else + if StrLIComp(P, 'AAA', 3) = 0 then + begin + GetDate; + AppendString(FormatSettings.ShortDayNames[DayOfWeek(DateTime)]); + Inc(Format, 2); + end else + AppendChars(@Starter, 1); + end; + 'C': + begin + GetCount; + AppendFormat(Pointer(FormatSettings.ShortDateFormat)); + GetTime; + if (Hour <> 0) or (Min <> 0) or (Sec <> 0) then + begin + AppendChars(' ', 1); + AppendFormat(Pointer(FormatSettings.LongTimeFormat)); + end; + end; + '/': + if DateSeparator <> #0 then + AppendChars(@FormatSettings.DateSeparator, 1); + ':': + if TimeSeparator <> #0 then + AppendChars(@FormatSettings.TimeSeparator, 1); + '''', '"': + begin + P := Format; + while (Format^ <> #0) and (Format^ <> Starter) do + begin + if Format^ in LeadBytes then + Format := StrNextChar(Format) + else + Inc(Format); + end; + AppendChars(P, Format - P); + if Format^ <> #0 then Inc(Format); + end; + else + AppendChars(@Starter, 1); + end; + end; + Dec(AppendLevel); + end; + end; + +begin + BufPos := 0; + AppendLevel := 0; + if Format <> '' then AppendFormat(Pointer(Format)) else AppendFormat('C'); + SetString(Result, Buffer, BufPos); +end; + +function TryFloatToDateTime(const Value: Extended; out AResult: TDateTime): Boolean; +begin + Result := not ((Value < MinDateTime) or (Value >= Int(MaxDateTime) + 1.0)); + if Result then + AResult := Value; +end; + +function FloatToDateTime(const Value: Extended): TDateTime; +begin + if not TryFloatToDateTime(Value, Result) then + ConvertErrorFmt(@SInvalidDateTimeFloat, [Value]); +end; + +function DateToStr(const DateTime: TDateTime): string; +begin + DateTimeToString(Result, ShortDateFormat, DateTime); +end; + +function DateToStr(const DateTime: TDateTime; + const FormatSettings: TFormatSettings): string; +begin + DateTimeToString(Result, FormatSettings.ShortDateFormat, DateTime, + FormatSettings); +end; + +function TimeToStr(const DateTime: TDateTime): string; +begin + DateTimeToString(Result, LongTimeFormat, DateTime); +end; + +function TimeToStr(const DateTime: TDateTime; + const FormatSettings: TFormatSettings): string; +begin + DateTimeToString(Result, FormatSettings.LongTimeFormat, DateTime, + FormatSettings); +end; + +function DateTimeToStr(const DateTime: TDateTime): string; +begin + DateTimeToString(Result, '', DateTime); +end; + +function DateTimeToStr(const DateTime: TDateTime; + const FormatSettings: TFormatSettings): string; +begin + DateTimeToString(Result, '', DateTime, FormatSettings); +end; + +function FormatDateTime(const Format: string; DateTime: TDateTime): string; +begin + DateTimeToString(Result, Format, DateTime); +end; + +function FormatDateTime(const Format: string; DateTime: TDateTime; + const FormatSettings: TFormatSettings): string; +begin + DateTimeToString(Result, Format, DateTime, FormatSettings); +end; + +{ String to date/time conversions } + +type + TDateOrder = (doMDY, doDMY, doYMD); + +procedure ScanBlanks(const S: string; var Pos: Integer); +var + I: Integer; +begin + I := Pos; + while (I <= Length(S)) and (S[I] = ' ') do Inc(I); + Pos := I; +end; + +function ScanNumber(const S: string; var Pos: Integer; + var Number: Word; var CharCount: Byte): Boolean; +var + I: Integer; + N: Word; +begin + Result := False; + CharCount := 0; + ScanBlanks(S, Pos); + I := Pos; + N := 0; + while (I <= Length(S)) and (S[I] in ['0'..'9']) and (N < 1000) do + begin + N := N * 10 + (Ord(S[I]) - Ord('0')); + Inc(I); + end; + if I > Pos then + begin + CharCount := I - Pos; + Pos := I; + Number := N; + Result := True; + end; +end; + +function ScanString(const S: string; var Pos: Integer; + const Symbol: string): Boolean; +begin + Result := False; + if Symbol <> '' then + begin + ScanBlanks(S, Pos); + if AnsiCompareText(Symbol, Copy(S, Pos, Length(Symbol))) = 0 then + begin + Inc(Pos, Length(Symbol)); + Result := True; + end; + end; +end; + +function ScanChar(const S: string; var Pos: Integer; Ch: Char): Boolean; +begin + Result := False; + ScanBlanks(S, Pos); + if (Pos <= Length(S)) and (S[Pos] = Ch) then + begin + Inc(Pos); + Result := True; + end; +end; + +function GetDateOrder(const DateFormat: string): TDateOrder; +var + I: Integer; +begin + Result := doMDY; + I := 1; + while I <= Length(DateFormat) do + begin + case Chr(Ord(DateFormat[I]) and $DF) of + 'E': Result := doYMD; + 'Y': Result := doYMD; + 'M': Result := doMDY; + 'D': Result := doDMY; + else + Inc(I); + Continue; + end; + Exit; + end; + Result := doMDY; +end; + +procedure ScanToNumber(const S: string; var Pos: Integer); +begin + while (Pos <= Length(S)) and not (S[Pos] in ['0'..'9']) do + begin + if S[Pos] in LeadBytes then + Pos := NextCharIndex(S, Pos) + else + Inc(Pos); + end; +end; + +function GetEraYearOffset(const Name: string): Integer; +var + I: Integer; +begin + Result := 0; + for I := Low(EraNames) to High(EraNames) do + begin + if EraNames[I] = '' then Break; + if AnsiStrPos(PChar(EraNames[I]), PChar(Name)) <> nil then + begin + Result := EraYearOffsets[I]; + Exit; + end; + end; +end; + +function ScanDate(const S: string; var Pos: Integer; + var Date: TDateTime): Boolean; overload; +var + DateOrder: TDateOrder; + N1, N2, N3, Y, M, D: Word; + L1, L2, L3, YearLen: Byte; + CenturyBase: Integer; + EraName : string; + EraYearOffset: Integer; + + function EraToYear(Year: Integer): Integer; + begin +{$IFDEF MSWINDOWS} + if SysLocale.PriLangID = LANG_KOREAN then + begin + if Year <= 99 then + Inc(Year, (CurrentYear + Abs(EraYearOffset)) div 100 * 100); + if EraYearOffset > 0 then + EraYearOffset := -EraYearOffset; + end + else + Dec(EraYearOffset); +{$ENDIF} + Result := Year + EraYearOffset; + end; + +begin + Y := 0; + M := 0; + D := 0; + YearLen := 0; + Result := False; + DateOrder := GetDateOrder(ShortDateFormat); + EraYearOffset := 0; + if ShortDateFormat[1] = 'g' then // skip over prefix text + begin + ScanToNumber(S, Pos); + EraName := Trim(Copy(S, 1, Pos-1)); + EraYearOffset := GetEraYearOffset(EraName); + end + else + if AnsiPos('e', ShortDateFormat) > 0 then + EraYearOffset := EraYearOffsets[1]; + if not (ScanNumber(S, Pos, N1, L1) and ScanChar(S, Pos, DateSeparator) and + ScanNumber(S, Pos, N2, L2)) then Exit; + if ScanChar(S, Pos, DateSeparator) then + begin + if not ScanNumber(S, Pos, N3, L3) then Exit; + case DateOrder of + doMDY: begin Y := N3; YearLen := L3; M := N1; D := N2; end; + doDMY: begin Y := N3; YearLen := L3; M := N2; D := N1; end; + doYMD: begin Y := N1; YearLen := L1; M := N2; D := N3; end; + end; + if EraYearOffset > 0 then + Y := EraToYear(Y) + else + if (YearLen <= 2) then + begin + CenturyBase := CurrentYear - TwoDigitYearCenturyWindow; + Inc(Y, CenturyBase div 100 * 100); + if (TwoDigitYearCenturyWindow > 0) and (Y < CenturyBase) then + Inc(Y, 100); + end; + end else + begin + Y := CurrentYear; + if DateOrder = doDMY then + begin + D := N1; M := N2; + end else + begin + M := N1; D := N2; + end; + end; + ScanChar(S, Pos, DateSeparator); + ScanBlanks(S, Pos); + if SysLocale.FarEast and (System.Pos('ddd', ShortDateFormat) <> 0) then + begin // ignore trailing text + if ShortTimeFormat[1] in ['0'..'9'] then // stop at time digit + ScanToNumber(S, Pos) + else // stop at time prefix + repeat + while (Pos <= Length(S)) and (S[Pos] <> ' ') do Inc(Pos); + ScanBlanks(S, Pos); + until (Pos > Length(S)) or + (AnsiCompareText(TimeAMString, Copy(S, Pos, Length(TimeAMString))) = 0) or + (AnsiCompareText(TimePMString, Copy(S, Pos, Length(TimePMString))) = 0); + end; + Result := TryEncodeDate(Y, M, D, Date); +end; + +function ScanDate(const S: string; var Pos: Integer; var Date: TDateTime; + const FormatSettings: TFormatSettings): Boolean; overload; +var + DateOrder: TDateOrder; + N1, N2, N3, Y, M, D: Word; + L1, L2, L3, YearLen: Byte; + CenturyBase: Integer; + EraName : string; + EraYearOffset: Integer; + + function EraToYear(Year: Integer): Integer; + begin +{$IFDEF MSWINDOWS} + if SysLocale.PriLangID = LANG_KOREAN then + begin + if Year <= 99 then + Inc(Year, (CurrentYear + Abs(EraYearOffset)) div 100 * 100); + if EraYearOffset > 0 then + EraYearOffset := -EraYearOffset; + end + else + Dec(EraYearOffset); +{$ENDIF} + Result := Year + EraYearOffset; + end; + +begin + Y := 0; + M := 0; + D := 0; + YearLen := 0; + Result := False; + DateOrder := GetDateOrder(FormatSettings.ShortDateFormat); + EraYearOffset := 0; + if FormatSettings.ShortDateFormat[1] = 'g' then // skip over prefix text + begin + ScanToNumber(S, Pos); + EraName := Trim(Copy(S, 1, Pos-1)); + EraYearOffset := GetEraYearOffset(EraName); + end + else + if AnsiPos('e', FormatSettings.ShortDateFormat) > 0 then + EraYearOffset := EraYearOffsets[1]; + if not (ScanNumber(S, Pos, N1, L1) and ScanChar(S, Pos, FormatSettings.DateSeparator) and + ScanNumber(S, Pos, N2, L2)) then Exit; + if ScanChar(S, Pos, FormatSettings.DateSeparator) then + begin + if not ScanNumber(S, Pos, N3, L3) then Exit; + case DateOrder of + doMDY: begin Y := N3; YearLen := L3; M := N1; D := N2; end; + doDMY: begin Y := N3; YearLen := L3; M := N2; D := N1; end; + doYMD: begin Y := N1; YearLen := L1; M := N2; D := N3; end; + end; + if EraYearOffset > 0 then + Y := EraToYear(Y) + else + if (YearLen <= 2) then + begin + CenturyBase := CurrentYear - FormatSettings.TwoDigitYearCenturyWindow; + Inc(Y, CenturyBase div 100 * 100); + if (FormatSettings.TwoDigitYearCenturyWindow > 0) and (Y < CenturyBase) then + Inc(Y, 100); + end; + end else + begin + Y := CurrentYear; + if DateOrder = doDMY then + begin + D := N1; M := N2; + end else + begin + M := N1; D := N2; + end; + end; + ScanChar(S, Pos, FormatSettings.DateSeparator); + ScanBlanks(S, Pos); + if SysLocale.FarEast and (System.Pos('ddd', FormatSettings.ShortDateFormat) <> 0) then + begin // ignore trailing text + if FormatSettings.ShortTimeFormat[1] in ['0'..'9'] then // stop at time digit + ScanToNumber(S, Pos) + else // stop at time prefix + repeat + while (Pos <= Length(S)) and (S[Pos] <> ' ') do Inc(Pos); + ScanBlanks(S, Pos); + until (Pos > Length(S)) or + (AnsiCompareText(FormatSettings.TimeAMString, + Copy(S, Pos, Length(FormatSettings.TimeAMString))) = 0) or + (AnsiCompareText(FormatSettings.TimePMString, + Copy(S, Pos, Length(FormatSettings.TimePMString))) = 0); + end; + Result := TryEncodeDate(Y, M, D, Date); +end; + +function ScanTime(const S: string; var Pos: Integer; + var Time: TDateTime): Boolean; overload; +var + BaseHour: Integer; + Hour, Min, Sec, MSec: Word; + Junk: Byte; +begin + Result := False; + BaseHour := -1; + if ScanString(S, Pos, TimeAMString) or ScanString(S, Pos, 'AM') then + BaseHour := 0 + else if ScanString(S, Pos, TimePMString) or ScanString(S, Pos, 'PM') then + BaseHour := 12; + if BaseHour >= 0 then ScanBlanks(S, Pos); + if not ScanNumber(S, Pos, Hour, Junk) then Exit; + Min := 0; + Sec := 0; + MSec := 0; + if ScanChar(S, Pos, TimeSeparator) then + begin + if not ScanNumber(S, Pos, Min, Junk) then Exit; + if ScanChar(S, Pos, TimeSeparator) then + begin + if not ScanNumber(S, Pos, Sec, Junk) then Exit; + if ScanChar(S, Pos, DecimalSeparator) then + if not ScanNumber(S, Pos, MSec, Junk) then Exit; + end; + end; + if BaseHour < 0 then + if ScanString(S, Pos, TimeAMString) or ScanString(S, Pos, 'AM') then + BaseHour := 0 + else + if ScanString(S, Pos, TimePMString) or ScanString(S, Pos, 'PM') then + BaseHour := 12; + if BaseHour >= 0 then + begin + if (Hour = 0) or (Hour > 12) then Exit; + if Hour = 12 then Hour := 0; + Inc(Hour, BaseHour); + end; + ScanBlanks(S, Pos); + Result := TryEncodeTime(Hour, Min, Sec, MSec, Time); +end; + +function ScanTime(const S: string; var Pos: Integer; var Time: TDateTime; + const FormatSettings: TFormatSettings): Boolean; overload; +var + BaseHour: Integer; + Hour, Min, Sec, MSec: Word; + Junk: Byte; +begin + Result := False; + BaseHour := -1; + if ScanString(S, Pos, FormatSettings.TimeAMString) or ScanString(S, Pos, 'AM') then + BaseHour := 0 + else if ScanString(S, Pos, FormatSettings.TimePMString) or ScanString(S, Pos, 'PM') then + BaseHour := 12; + if BaseHour >= 0 then ScanBlanks(S, Pos); + if not ScanNumber(S, Pos, Hour, Junk) then Exit; + Min := 0; + Sec := 0; + MSec := 0; + if ScanChar(S, Pos, FormatSettings.TimeSeparator) then + begin + if not ScanNumber(S, Pos, Min, Junk) then Exit; + if ScanChar(S, Pos, FormatSettings.TimeSeparator) then + begin + if not ScanNumber(S, Pos, Sec, Junk) then Exit; + if ScanChar(S, Pos, FormatSettings.DecimalSeparator) then + if not ScanNumber(S, Pos, MSec, Junk) then Exit; + end; + end; + if BaseHour < 0 then + if ScanString(S, Pos, FormatSettings.TimeAMString) or ScanString(S, Pos, 'AM') then + BaseHour := 0 + else + if ScanString(S, Pos, FormatSettings.TimePMString) or ScanString(S, Pos, 'PM') then + BaseHour := 12; + if BaseHour >= 0 then + begin + if (Hour = 0) or (Hour > 12) then Exit; + if Hour = 12 then Hour := 0; + Inc(Hour, BaseHour); + end; + ScanBlanks(S, Pos); + Result := TryEncodeTime(Hour, Min, Sec, MSec, Time); +end; + +function StrToDate(const S: string): TDateTime; +begin + if not TryStrToDate(S, Result) then + ConvertErrorFmt(@SInvalidDate, [S]); +end; + +function StrToDate(const S: string; + const FormatSettings: TFormatSettings): TDateTime; +begin + if not TryStrToDate(S, Result, FormatSettings) then + ConvertErrorFmt(@SInvalidDate, [S]); +end; + +function StrToDateDef(const S: string; const Default: TDateTime): TDateTime; +begin + if not TryStrToDate(S, Result) then + Result := Default; +end; + +function StrToDateDef(const S: string; const Default: TDateTime; + const FormatSettings: TFormatSettings): TDateTime; +begin + if not TryStrToDate(S, Result, FormatSettings) then + Result := Default; +end; + +function TryStrToDate(const S: string; out Value: TDateTime): Boolean; +var + Pos: Integer; +begin + Pos := 1; + Result := ScanDate(S, Pos, Value) and (Pos > Length(S)); +end; + +function TryStrToDate(const S: string; out Value: TDateTime; + const FormatSettings: TFormatSettings): Boolean; +var + Pos: Integer; +begin + Pos := 1; + Result := ScanDate(S, Pos, Value, FormatSettings) and (Pos > Length(S)); +end; + +function StrToTime(const S: string): TDateTime; +begin + if not TryStrToTime(S, Result) then + ConvertErrorFmt(@SInvalidTime, [S]); +end; + +function StrToTime(const S: string; + const FormatSettings: TFormatSettings): TDateTime; +begin + if not TryStrToTime(S, Result, FormatSettings) then + ConvertErrorFmt(@SInvalidTime, [S]); +end; + +function StrToTimeDef(const S: string; const Default: TDateTime): TDateTime; +begin + if not TryStrToTime(S, Result) then + Result := Default; +end; + +function StrToTimeDef(const S: string; const Default: TDateTime; + const FormatSettings: TFormatSettings): TDateTime; +begin + if not TryStrToTime(S, Result, FormatSettings) then + Result := Default; +end; + +function TryStrToTime(const S: string; out Value: TDateTime): Boolean; +var + Pos: Integer; +begin + Pos := 1; + Result := ScanTime(S, Pos, Value) and (Pos > Length(S)); +end; + +function TryStrToTime(const S: string; out Value: TDateTime; + const FormatSettings: TFormatSettings): Boolean; +var + Pos: Integer; +begin + Pos := 1; + Result := ScanTime(S, Pos, Value, FormatSettings) and (Pos > Length(S)); +end; + +function StrToDateTime(const S: string): TDateTime; +begin + if not TryStrToDateTime(S, Result) then + ConvertErrorFmt(@SInvalidDateTime, [S]); +end; + +function StrToDateTime(const S: string; + const FormatSettings: TFormatSettings): TDateTime; +begin + if not TryStrToDateTime(S, Result, FormatSettings) then + ConvertErrorFmt(@SInvalidDateTime, [S]); +end; + +function StrToDateTimeDef(const S: string; const Default: TDateTime): TDateTime; +begin + if not TryStrToDateTime(S, Result) then + Result := Default; +end; + +function StrToDateTimeDef(const S: string; const Default: TDateTime; + const FormatSettings: TFormatSettings): TDateTime; +begin + if not TryStrToDateTime(S, Result, FormatSettings) then + Result := Default; +end; + +function TryStrToDateTime(const S: string; out Value: TDateTime): Boolean; +var + Pos: Integer; + Date, Time: TDateTime; +begin + Result := True; + Pos := 1; + Time := 0; + if not ScanDate(S, Pos, Date) or + not ((Pos > Length(S)) or ScanTime(S, Pos, Time)) then + + // Try time only + Result := TryStrToTime(S, Value) + else + if Date >= 0 then + Value := Date + Time + else + Value := Date - Time; +end; + +function TryStrToDateTime(const S: string; out Value: TDateTime; + const FormatSettings: TFormatSettings): Boolean; +var + Pos: Integer; + Date, Time: TDateTime; +begin + Result := True; + Pos := 1; + Time := 0; + if not ScanDate(S, Pos, Date, FormatSettings) or + not ((Pos > Length(S)) or ScanTime(S, Pos, Time, FormatSettings)) then + + // Try time only + Result := TryStrToTime(S, Value, FormatSettings) + else + if Date >= 0 then + Value := Date + Time + else + Value := Date - Time; +end; + +{ System error messages } + +function SysErrorMessage(ErrorCode: Integer): string; +var + Buffer: array[0..255] of Char; +{$IFDEF MSWINDOWS} +var + Len: Integer; +begin + Len := FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_IGNORE_INSERTS or + FORMAT_MESSAGE_ARGUMENT_ARRAY, nil, ErrorCode, 0, Buffer, + SizeOf(Buffer), nil); + while (Len > 0) and (Buffer[Len - 1] in [#0..#32, '.']) do Dec(Len); + SetString(Result, Buffer, Len); +end; +{$ENDIF} +{$IFDEF LINUX} +begin + //Result := Format('System error: %4x',[ErrorCode]); + Result := strerror_r(ErrorCode, Buffer, sizeof(Buffer)); +end; +{$ENDIF} + +{ Initialization file support } + +function GetLocaleStr(Locale, LocaleType: Integer; const Default: string): string; +{$IFDEF MSWINDOWS} +var + L: Integer; + Buffer: array[0..255] of Char; +begin + L := GetLocaleInfo(Locale, LocaleType, Buffer, SizeOf(Buffer)); + if L > 0 then SetString(Result, Buffer, L - 1) else Result := Default; +end; +{$ENDIF} +{$IFDEF LINUX} +begin + Result := Default; +end; +{$ENDIF} + +function GetLocaleChar(Locale, LocaleType: Integer; Default: Char): Char; +{$IFDEF MSWINDOWS} +var + Buffer: array[0..1] of Char; +begin + if GetLocaleInfo(Locale, LocaleType, Buffer, 2) > 0 then + Result := Buffer[0] else + Result := Default; +end; +{$ENDIF} +{$IFDEF LINUX} +begin + Result := Default; +end; +{$ENDIF} + +var + DefShortMonthNames: array[1..12] of Pointer = (@SShortMonthNameJan, + @SShortMonthNameFeb, @SShortMonthNameMar, @SShortMonthNameApr, + @SShortMonthNameMay, @SShortMonthNameJun, @SShortMonthNameJul, + @SShortMonthNameAug, @SShortMonthNameSep, @SShortMonthNameOct, + @SShortMonthNameNov, @SShortMonthNameDec); + + DefLongMonthNames: array[1..12] of Pointer = (@SLongMonthNameJan, + @SLongMonthNameFeb, @SLongMonthNameMar, @SLongMonthNameApr, + @SLongMonthNameMay, @SLongMonthNameJun, @SLongMonthNameJul, + @SLongMonthNameAug, @SLongMonthNameSep, @SLongMonthNameOct, + @SLongMonthNameNov, @SLongMonthNameDec); + + DefShortDayNames: array[1..7] of Pointer = (@SShortDayNameSun, + @SShortDayNameMon, @SShortDayNameTue, @SShortDayNameWed, + @SShortDayNameThu, @SShortDayNameFri, @SShortDayNameSat); + + DefLongDayNames: array[1..7] of Pointer = (@SLongDayNameSun, + @SLongDayNameMon, @SLongDayNameTue, @SLongDayNameWed, + @SLongDayNameThu, @SLongDayNameFri, @SLongDayNameSat); + +procedure GetMonthDayNames; +{$IFDEF MSWINDOWS} +var + I, Day: Integer; + DefaultLCID: LCID; + + function LocalGetLocaleStr(LocaleType, Index: Integer; + const DefValues: array of Pointer): string; + begin + Result := GetLocaleStr(DefaultLCID, LocaleType, ''); + if Result = '' then Result := LoadResString(DefValues[Index]); + end; + +begin + DefaultLCID := GetThreadLocale; + for I := 1 to 12 do + begin + ShortMonthNames[I] := LocalGetLocaleStr(LOCALE_SABBREVMONTHNAME1 + I - 1, + I - Low(DefShortMonthNames), DefShortMonthNames); + LongMonthNames[I] := LocalGetLocaleStr(LOCALE_SMONTHNAME1 + I - 1, + I - Low(DefLongMonthNames), DefLongMonthNames); + end; + for I := 1 to 7 do + begin + Day := (I + 5) mod 7; + ShortDayNames[I] := LocalGetLocaleStr(LOCALE_SABBREVDAYNAME1 + Day, + I - Low(DefShortDayNames), DefShortDayNames); + LongDayNames[I] := LocalGetLocaleStr(LOCALE_SDAYNAME1 + Day, + I - Low(DefLongDayNames), DefLongDayNames); + end; +end; +{$ELSE} +{$IFDEF LINUX} + function GetLocaleStr(LocaleIndex, Index: Integer; + const DefValues: array of Pointer): string; + var + temp: PChar; + begin + temp := nl_langinfo(LocaleIndex); + if (temp = nil) or (temp^ = #0) then + Result := LoadResString(DefValues[Index]) + else + Result := temp; + end; + +var + I: Integer; +begin + for I := 1 to 12 do + begin + ShortMonthNames[I] := GetLocaleStr(ABMON_1 + I - 1, + I - Low(DefShortMonthNames), DefShortMonthNames); + LongMonthNames[I] := GetLocaleStr(MON_1 + I - 1, + I - Low(DefLongMonthNames), DefLongMonthNames); + end; + for I := 1 to 7 do + begin + ShortDayNames[I] := GetLocaleStr(ABDAY_1 + I - 1, + I - Low(DefShortDayNames), DefShortDayNames); + LongDayNames[I] := GetLocaleStr(DAY_1 + I - 1, + I - Low(DefLongDayNames), DefLongDayNames); + end; +end; +{$ELSE} +var + I: Integer; +begin + for I := 1 to 12 do + begin + ShortMonthNames[I] := LoadResString(DefShortMonthNames[I]); + LongMonthNames[I] := LoadResString(DefLongMonthNames[I]); + end; + for I := 1 to 7 do + begin + ShortDayNames[I] := LoadResString(DefShortDayNames[I]); + LongDayNames[I] := LoadResString(DefLongDayNames[I]); + end; +end; +{$ENDIF} +{$ENDIF} + +{$IFDEF MSWINDOWS} +procedure GetLocaleMonthDayNames(DefaultLCID: Integer; + var FormatSettings: TFormatSettings); +var + I, Day: Integer; + + function LocalGetLocaleStr(LocaleType, Index: Integer; + const DefValues: array of Pointer): string; + begin + Result := GetLocaleStr(DefaultLCID, LocaleType, ''); + if Result = '' then Result := LoadResString(DefValues[Index]); + end; + +begin + for I := 1 to 12 do + begin + FormatSettings.ShortMonthNames[I] := LocalGetLocaleStr(LOCALE_SABBREVMONTHNAME1 + I - 1, + I - Low(DefShortMonthNames), DefShortMonthNames); + FormatSettings.LongMonthNames[I] := LocalGetLocaleStr(LOCALE_SMONTHNAME1 + I - 1, + I - Low(DefLongMonthNames), DefLongMonthNames); + end; + for I := 1 to 7 do + begin + Day := (I + 5) mod 7; + FormatSettings.ShortDayNames[I] := LocalGetLocaleStr(LOCALE_SABBREVDAYNAME1 + Day, + I - Low(DefShortDayNames), DefShortDayNames); + FormatSettings.LongDayNames[I] := LocalGetLocaleStr(LOCALE_SDAYNAME1 + Day, + I - Low(DefLongDayNames), DefLongDayNames); + end; +end; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function EnumEraNames(Names: PChar): Integer; stdcall; +var + I: Integer; +begin + Result := 0; + I := Low(EraNames); + while EraNames[I] <> '' do + if (I = High(EraNames)) then + Exit + else Inc(I); + EraNames[I] := Names; + Result := 1; +end; + +function EnumEraYearOffsets(YearOffsets: PChar): Integer; stdcall; +var + I: Integer; +begin + Result := 0; + I := Low(EraYearOffsets); + while EraYearOffsets[I] <> -1 do + if (I = High(EraYearOffsets)) then + Exit + else Inc(I); + EraYearOffsets[I] := StrToIntDef(YearOffsets, 0); + Result := 1; +end; + +procedure GetEraNamesAndYearOffsets; +var + J: Integer; + CalendarType: CALTYPE; +begin + CalendarType := StrToIntDef(GetLocaleStr(GetThreadLocale, + LOCALE_IOPTIONALCALENDAR, '1'), 1); + if CalendarType in [CAL_JAPAN, CAL_TAIWAN, CAL_KOREA] then + begin + EnumCalendarInfoA(@EnumEraNames, GetThreadLocale, CalendarType, + CAL_SERASTRING); + for J := Low(EraYearOffsets) to High(EraYearOffsets) do + EraYearOffsets[J] := -1; + EnumCalendarInfoA(@EnumEraYearOffsets, GetThreadLocale, CalendarType, + CAL_IYEAROFFSETRANGE); + end; +end; + +function TranslateDateFormat(const FormatStr: string): string; +var + I: Integer; + L: Integer; + CalendarType: CALTYPE; + RemoveEra: Boolean; +begin + I := 1; + Result := ''; + CalendarType := StrToIntDef(GetLocaleStr(GetThreadLocale, + LOCALE_ICALENDARTYPE, '1'), 1); + if not (CalendarType in [CAL_JAPAN, CAL_TAIWAN, CAL_KOREA]) then + begin + RemoveEra := SysLocale.PriLangID in [LANG_JAPANESE, LANG_CHINESE, LANG_KOREAN]; + if RemoveEra then + begin + While I <= Length(FormatStr) do + begin + if not (FormatStr[I] in ['g', 'G']) then + Result := Result + FormatStr[I]; + Inc(I); + end; + end + else + Result := FormatStr; + Exit; + end; + + while I <= Length(FormatStr) do + begin + if FormatStr[I] in LeadBytes then + begin + L := CharLength(FormatStr, I); + Result := Result + Copy(FormatStr, I, L); + Inc(I, L); + end else + begin + if StrLIComp(@FormatStr[I], 'gg', 2) = 0 then + begin + Result := Result + 'ggg'; + Inc(I, 1); + end + else if StrLIComp(@FormatStr[I], 'yyyy', 4) = 0 then + begin + Result := Result + 'eeee'; + Inc(I, 4-1); + end + else if StrLIComp(@FormatStr[I], 'yy', 2) = 0 then + begin + Result := Result + 'ee'; + Inc(I, 2-1); + end + else if FormatStr[I] in ['y', 'Y'] then + Result := Result + 'e' + else + Result := Result + FormatStr[I]; + Inc(I); + end; + end; +end; +{$ENDIF} + +{$IFDEF LINUX} +procedure InitEras; +var + Count : Byte; + I, J, Pos : Integer; + Number : Word; + S : string; + Year, Month, Day: Word; +begin + EraCount := 0; + S := nl_langinfo(ERA); + if S = '' then + S := LoadResString(@SEraEntries); + + Pos := 1; + for I := 1 to MaxEraCount do + begin + if Pos > Length(S) then Break; + if not(ScanChar(S, Pos, '+') or ScanChar(S, Pos, '-')) then Break; + // Eras in which year increases with negative time (eg Christian BC era) + // are not currently supported. +// EraRanges[I].Direction := S[Pos - 1]; + + // Era offset, in years from Gregorian calendar year + if not ScanChar(S, Pos, ':') then Break; + if ScanChar(S, Pos, '-') then + J := -1 + else + J := 1; + if not ScanNumber(S, Pos, Number, Count) then Break; + EraYearOffsets[I] := J * Number; // apply sign to Number + + // Era start date, in Gregorian year/month/day format + if not ScanChar(S, Pos, ':') then Break; + if not ScanNumber(S, Pos, Year, Count) then Break; + if not ScanChar(S, Pos, '/') then Break; + if not ScanNumber(S, Pos, Month, Count) then Break; + if not ScanChar(S, Pos, '/') then Break; + if not ScanNumber(S, Pos, Day, Count) then Break; + EraRanges[I].StartDate := Trunc(EncodeDate(Year, Month, Day)); + EraYearOffsets[I] := Year - EraYearOffsets[I]; + + // Era end date, in Gregorian year/month/day format + if not ScanChar(S, Pos, ':') then Break; + if ScanString(S, Pos, '+*') then // positive infinity + EraRanges[I].EndDate := High(EraRanges[I].EndDate) + else if ScanString(S, Pos, '-*') then // negative infinity + EraRanges[I].EndDate := Low(EraRanges[I].EndDate) + else if not ScanNumber(S, Pos, Year, Count) then + Break + else + begin + if not ScanChar(S, Pos, '/') then Break; + if not ScanNumber(S, Pos, Month, Count) then Break; + if not ScanChar(S, Pos, '/') then Break; + if not ScanNumber(S, Pos, Day, Count) then Break; + EraRanges[I].EndDate := Trunc(EncodeDate(Year, Month, Day)); + end; + + // Era name, in locale charset + if not ScanChar(S, Pos, ':') then Break; + J := AnsiPos(':', Copy(S, Pos, Length(S) + 1 - Pos)); + if J = 0 then Break; + EraNames[I] := Copy(S, Pos, J - 1); + Inc(Pos, J - 1); + + // Optional Era format string for era year, in locale charset + if not ScanChar(S, Pos, ':') then Break; + J := AnsiPos(';', Copy(S, Pos, Length(S) + 1 - Pos)); + if J = 0 then + J := 1 + Length(S) + 1 - Pos; + {if J = 0 then Break;} + EraYearFormats[I] := Copy(S, Pos, J - 1); + Inc(Pos, J - 1); + Inc(EraCount); + if not((Pos > Length(S)) or ScanChar(S, Pos, ';')) then Break; + end; + + // Clear the rest of the era slots, including partial entry from failed parse + for I := EraCount+1 to MaxEraCount do + begin + EraNames[I] := ''; + EraYearOffsets[I] := -1; + EraRanges[I].StartDate := High(EraRanges[I].StartDate); + EraRanges[I].EndDate := High(EraRanges[I].EndDate); + EraYearFormats[I] := ''; + end; +end; +{$ENDIF} + +{ Exception handling routines } + +var + OutOfMemory: EOutOfMemory; + InvalidPointer: EInvalidPointer; + +{ Convert physical address to logical address } + +{ Format and return an exception error message } + +function ExceptionErrorMessage(ExceptObject: TObject; ExceptAddr: Pointer; + Buffer: PChar; Size: Integer): Integer; +{$IFDEF MSWINDOWS} + + function ConvertAddr(Address: Pointer): Pointer; assembler; + asm + TEST EAX,EAX { Always convert nil to nil } + JE @@1 + SUB EAX, $1000 { offset from code start; code start set by linker to $1000 } + @@1: + end; + +var + MsgPtr: PChar; + MsgEnd: PChar; + MsgLen: Integer; + ModuleName: array[0..MAX_PATH] of Char; + Temp: array[0..MAX_PATH] of Char; + Format: array[0..255] of Char; + Info: TMemoryBasicInformation; + ConvertedAddress: Pointer; +begin + VirtualQuery(ExceptAddr, Info, sizeof(Info)); + if (Info.State <> MEM_COMMIT) or + (GetModuleFilename(THandle(Info.AllocationBase), Temp, SizeOf(Temp)) = 0) then + begin + GetModuleFileName(HInstance, Temp, SizeOf(Temp)); + ConvertedAddress := ConvertAddr(ExceptAddr); + end + else + Integer(ConvertedAddress) := Integer(ExceptAddr) - Integer(Info.AllocationBase); + StrLCopy(ModuleName, AnsiStrRScan(Temp, '\') + 1, SizeOf(ModuleName) - 1); + MsgPtr := ''; + MsgEnd := ''; + if ExceptObject is Exception then + begin + MsgPtr := PChar(Exception(ExceptObject).Message); + MsgLen := StrLen(MsgPtr); + if (MsgLen <> 0) and (MsgPtr[MsgLen - 1] <> '.') then MsgEnd := '.'; + end; + LoadString(FindResourceHInstance(HInstance), + PResStringRec(@SException).Identifier, Format, SizeOf(Format)); + StrLFmt(Buffer, Size, Format, [ExceptObject.ClassName, ModuleName, + ConvertedAddress, MsgPtr, MsgEnd]); + Result := StrLen(Buffer); +end; +{$ENDIF} +{$IFDEF LINUX} +const + UnknownModuleName = ''; +var + MsgPtr: PChar; + MsgEnd: PChar; + MsgLen: Integer; + ModuleName: array[0..MAX_PATH] of Char; + Info: TDLInfo; +begin + MsgPtr := ''; + MsgEnd := ''; + if ExceptObject is Exception then + begin + MsgPtr := PChar(Exception(ExceptObject).Message); + MsgLen := StrLen(MsgPtr); + if (MsgLen <> 0) and (MsgPtr[MsgLen - 1] <> '.') then MsgEnd := '.'; + end; + if (dladdr(ExceptAddr, Info) <> 0) and (Info.dli_fname <> nil) then + StrLCopy(ModuleName, AnsiStrRScan(Info.dli_fname, PathDelim) + 1, SizeOf(ModuleName) - 1) + else + StrLCopy(ModuleName, UnknownModuleName, SizeOf(ModuleName) - 1); + StrLFmt(Buffer, Size, PChar(SException), [ExceptObject.ClassName, ModuleName, + ExceptAddr, MsgPtr, MsgEnd]); + Result := StrLen(Buffer); +end; +{$ENDIF} + +{ Display exception message box } + +procedure ShowException(ExceptObject: TObject; ExceptAddr: Pointer); +{$IFDEF MSWINDOWS} +var + Title: array[0..63] of Char; + Buffer: array[0..1023] of Char; + Dummy: Cardinal; +begin + ExceptionErrorMessage(ExceptObject, ExceptAddr, Buffer, SizeOf(Buffer)); + if IsConsole then + begin + Flush(Output); + CharToOemA(Buffer, Buffer); + WriteFile(GetStdHandle(STD_ERROR_HANDLE), Buffer, StrLen(Buffer), Dummy, nil); + WriteFile(GetStdHandle(STD_ERROR_HANDLE), sLineBreak, 2, Dummy, nil); + end + else + begin + LoadString(FindResourceHInstance(HInstance), PResStringRec(@SExceptTitle).Identifier, + Title, SizeOf(Title)); + MessageBox(0, Buffer, Title, MB_OK or MB_ICONSTOP or MB_TASKMODAL); + end; +end; +{$ENDIF} +{$IFDEF LINUX} +var + Buffer: array[0..1023] of Char; +begin + ExceptionErrorMessage(ExceptObject, ExceptAddr, Buffer, Sizeof(Buffer)); + if TTextRec(ErrOutput).Mode = fmOutput then + Flush(ErrOutput); + __write(STDERR_FILENO, Buffer, StrLen(Buffer)); +end; +{$ENDIF} + +{ Raise abort exception } + +procedure Abort; + + function ReturnAddr: Pointer; + asm + MOV EAX,[EBP + 4] + end; + +begin + raise EAbort.CreateRes(@SOperationAborted) at ReturnAddr; +end; + +{ Raise out of memory exception } + +procedure OutOfMemoryError; +begin + raise OutOfMemory; +end; + +{ Exception class } + +constructor Exception.Create(const Msg: string); +begin + FMessage := Msg; +end; + +constructor Exception.CreateFmt(const Msg: string; + const Args: array of const); +begin + FMessage := Format(Msg, Args); +end; + +constructor Exception.CreateRes(Ident: Integer); +begin + FMessage := LoadStr(Ident); +end; + +constructor Exception.CreateRes(ResStringRec: PResStringRec); +begin + FMessage := LoadResString(ResStringRec); +end; + +constructor Exception.CreateResFmt(Ident: Integer; + const Args: array of const); +begin + FMessage := Format(LoadStr(Ident), Args); +end; + +constructor Exception.CreateResFmt(ResStringRec: PResStringRec; + const Args: array of const); +begin + FMessage := Format(LoadResString(ResStringRec), Args); +end; + +constructor Exception.CreateHelp(const Msg: string; AHelpContext: Integer); +begin + FMessage := Msg; + FHelpContext := AHelpContext; +end; + +constructor Exception.CreateFmtHelp(const Msg: string; const Args: array of const; + AHelpContext: Integer); +begin + FMessage := Format(Msg, Args); + FHelpContext := AHelpContext; +end; + +constructor Exception.CreateResHelp(Ident: Integer; AHelpContext: Integer); +begin + FMessage := LoadStr(Ident); + FHelpContext := AHelpContext; +end; + +constructor Exception.CreateResHelp(ResStringRec: PResStringRec; + AHelpContext: Integer); +begin + FMessage := LoadResString(ResStringRec); + FHelpContext := AHelpContext; +end; + +constructor Exception.CreateResFmtHelp(Ident: Integer; + const Args: array of const; + AHelpContext: Integer); +begin + FMessage := Format(LoadStr(Ident), Args); + FHelpContext := AHelpContext; +end; + +constructor Exception.CreateResFmtHelp(ResStringRec: PResStringRec; + const Args: array of const; + AHelpContext: Integer); +begin + FMessage := Format(LoadResString(ResStringRec), Args); + FHelpContext := AHelpContext; +end; + +{ EHeapException class } + +procedure EHeapException.FreeInstance; +begin + if AllowFree then + inherited FreeInstance; +end; + +{ Create I/O exception } + +function CreateInOutError: EInOutError; +type + TErrorRec = record + Code: Integer; + Ident: string; + end; +const + ErrorMap: array[0..6] of TErrorRec = ( + (Code: 2; Ident: SFileNotFound), + (Code: 3; Ident: SInvalidFilename), + (Code: 4; Ident: STooManyOpenFiles), + (Code: 5; Ident: SAccessDenied), + (Code: 100; Ident: SEndOfFile), + (Code: 101; Ident: SDiskFull), + (Code: 106; Ident: SInvalidInput)); +var + I: Integer; + InOutRes: Integer; +begin + I := Low(ErrorMap); + InOutRes := IOResult; // resets IOResult to zero + while (I <= High(ErrorMap)) and (ErrorMap[I].Code <> InOutRes) do Inc(I); + if I <= High(ErrorMap) then + Result := EInOutError.Create(ErrorMap[I].Ident) else + Result := EInOutError.CreateResFmt(@SInOutError, [InOutRes]); + Result.ErrorCode := InOutRes; +end; + +{ RTL error handler } + +type + TExceptRec = record + EClass: ExceptClass; + EIdent: string; + end; + +const + ExceptMap: array[Ord(reDivByZero)..Ord(High(TRuntimeError))] of TExceptRec = ( + (EClass: EDivByZero; EIdent: SDivByZero), + (EClass: ERangeError; EIdent: SRangeError), + (EClass: EIntOverflow; EIdent: SIntOverflow), + (EClass: EInvalidOp; EIdent: SInvalidOp), + (EClass: EZeroDivide; EIdent: SZeroDivide), + (EClass: EOverflow; EIdent: SOverflow), + (EClass: EUnderflow; EIdent: SUnderflow), + (EClass: EInvalidCast; EIdent: SInvalidCast), + (EClass: EAccessViolation; EIdent: SAccessViolationNoArg), + (EClass: EPrivilege; EIdent: SPrivilege), + (EClass: EControlC; EIdent: SControlC), + (EClass: EStackOverflow; EIdent: SStackOverflow), + (EClass: EVariantError; EIdent: SInvalidVarCast), + (EClass: EVariantError; EIdent: SInvalidVarOp), + (EClass: EVariantError; EIdent: SDispatchError), + (EClass: EVariantError; EIdent: SVarArrayCreate), + (EClass: EVariantError; EIdent: SVarInvalid), + (EClass: EVariantError; EIdent: SVarArrayBounds), + (EClass: EAssertionFailed; EIdent: SAssertionFailed), + (EClass: EExternalException; EIdent: SExternalException), + (EClass: EIntfCastError; EIdent: SIntfCastError), + (EClass: ESafecallException; EIdent: SSafecallException) + {$IFDEF LINUX} + , + (EClass: EQuit; EIdent: SQuit), + (EClass: ECodesetConversion; EIdent: SCodesetConversionError) + {$ENDIF} + ); + +procedure ErrorHandler(ErrorCode: Byte; ErrorAddr: Pointer); export; +var + E: Exception; +begin + case ErrorCode of + Ord(reOutOfMemory): + E := OutOfMemory; + Ord(reInvalidPtr): + E := InvalidPointer; + Ord(reDivByZero)..Ord(High(TRuntimeError)): + begin + with ExceptMap[ErrorCode] do + E := EClass.Create(EIdent); + end; + else + E := CreateInOutError; + end; + raise E at ErrorAddr; +end; + +{ Assertion error handler } + +{ This is complicated by the desire to make it look like the exception } +{ happened in the user routine, so the debugger can give a decent stack } +{ trace. To make that feasible, AssertErrorHandler calls a helper function } +{ to create the exception object, so that AssertErrorHandler itself does } +{ not need any temps. After the exception object is created, the asm } +{ routine RaiseAssertException sets up the registers just as if the user } +{ code itself had raised the exception. } + +function CreateAssertException(const Message, Filename: string; + LineNumber: Integer): Exception; +var + S: string; +begin + if Message <> '' then S := Message else S := SAssertionFailed; + Result := EAssertionFailed.CreateFmt(SAssertError, + [S, Filename, LineNumber]); +end; + +{ This code is based on the following assumptions: } +{ - Our direct caller (AssertErrorHandler) has an EBP frame } +{ - ErrorStack points to where the return address would be if the } +{ user program had called System.@RaiseExcept directly } +procedure RaiseAssertException(const E: Exception; const ErrorAddr, ErrorStack: Pointer); +asm + MOV ESP,ECX + MOV [ESP],EDX + MOV EBP,[EBP] + JMP System.@RaiseExcept +end; + +{ If you change this procedure, make sure it does not have any local variables } +{ or temps that need cleanup - they won't get cleaned up due to the way } +{ RaiseAssertException frame works. Also, it can not have an exception frame. } +procedure AssertErrorHandler(const Message, Filename: string; + LineNumber: Integer; ErrorAddr: Pointer); +var + E: Exception; +begin + E := CreateAssertException(Message, Filename, LineNumber); +{$IF Defined(LINUX)} + RaiseAssertException(E, ErrorAddr, PChar(@ErrorAddr)+8); +{$ELSEIF Defined(MSWINDOWS)} + RaiseAssertException(E, ErrorAddr, PChar(@ErrorAddr)+4); +{$ELSE} + {$MESSAGE ERROR 'AssertErrorHandler not implemented'} +{$IFEND} +end; + +{$IFNDEF PC_MAPPED_EXCEPTIONS} + +{ Abstract method invoke error handler } + +procedure AbstractErrorHandler; +begin + raise EAbstractError.CreateRes(@SAbstractError); +end; +{$ENDIF} + +{$IFDEF LINUX} +const + TRAP_ZERODIVIDE = 0; + TRAP_SINGLESTEP = 1; + TRAP_NMI = 2; + TRAP_BREAKPOINT = 3; + TRAP_OVERFLOW = 4; + TRAP_BOUND = 5; + TRAP_INVINSTR = 6; + TRAP_DEVICENA = 7; + TRAP_DOUBLEFAULT = 8; + TRAP_FPOVERRUN = 9; + TRAP_BADTSS = 10; + TRAP_SEGMENTNP = 11; + TRAP_STACKFAULT = 12; + TRAP_GPFAULT = 13; + TRAP_PAGEFAULT = 14; + TRAP_RESERVED = 15; + TRAP_FPE = 16; + TRAP_ALIGNMENT = 17; + TRAP_MACHINECHECK = 18; + TRAP_CACHEFAULT = 19; + TRAP_UNKNOWN = -1; + +function MapFPUStatus(Status: LongWord): TRuntimeError; +begin + if (Status and 1) = 1 then Result := System.reInvalidOp // STACK_CHECK or INVALID_OPERATION + else if (Status and 2) = 2 then Result := System.reInvalidOp // DENORMAL_OPERAND + else if (Status and 4) = 4 then Result := System.reZeroDivide // DIVIDE_BY_ZERO + else if (Status and 8) = 8 then Result := System.reOverflow // OVERFLOW + else if (Status and $10) = $10 then Result := System.reUnderflow // UNDERFLOW + else if (Status and $20) = $20 then Result := System.reInvalidOp // INEXACT_RESULT + else Result := System.reInvalidOp; +end; + +function MapFPE(Context: PSigContext): TRuntimeError; +begin + case Context^.trapno of + TRAP_ZERODIVIDE: + Result := System.reDivByZero; + TRAP_FPOVERRUN: + Result := System.reInvalidOp; + TRAP_FPE: + Result := MapFPUStatus(Context^.fpstate^.sw); + else + Result := System.reInvalidOp; + end; +end; + +function MapFault(Context: PSigContext): TRuntimeError; +begin + case Context^.trapno of + TRAP_OVERFLOW: + Result := System.reIntOverflow; + TRAP_BOUND: + Result := System.reRangeError; + TRAP_INVINSTR: + Result := System.rePrivInstruction; // This doesn't seem right, but we don't + // have an external exception to match! + TRAP_STACKFAULT: + Result := System.reStackOverflow; + TRAP_SEGMENTNP, + TRAP_GPFAULT: + Result := System.reAccessViolation; + TRAP_PAGEFAULT: + Result := System.reAccessViolation; + else + Result := System.reAccessViolation; + end; +end; + +function MapSignal(SigNum: Integer; Context: PSigContext): LongWord; +var + Err: TRuntimeError; +begin + case SigNum of + SIGINT: { Control-C } + Err := System.reControlBreak; + SIGQUIT: { Quit key (Control-\) } + Err := System.reQuit; + SIGFPE: { Floating Point Error } + Err := MapFPE(Context); + SIGSEGV: { Segmentation Violation } + Err := MapFault(Context); + SIGILL: { Illegal Instruction } + Err := MapFault(Context); + SIGBUS: { Bus Error } + Err := MapFault(Context); + else + Err := System.reExternalException; + end; + Result := LongWord(Err) or (LongWord(SigNum) shl 16); +end; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function MapException(P: PExceptionRecord): TRuntimeError; +begin + case P.ExceptionCode of + STATUS_INTEGER_DIVIDE_BY_ZERO: + Result := System.reDivByZero; + STATUS_ARRAY_BOUNDS_EXCEEDED: + Result := System.reRangeError; + STATUS_INTEGER_OVERFLOW: + Result := System.reIntOverflow; + STATUS_FLOAT_INEXACT_RESULT, + STATUS_FLOAT_INVALID_OPERATION, + STATUS_FLOAT_STACK_CHECK: + Result := System.reInvalidOp; + STATUS_FLOAT_DIVIDE_BY_ZERO: + Result := System.reZeroDivide; + STATUS_FLOAT_OVERFLOW: + Result := System.reOverflow; + STATUS_FLOAT_UNDERFLOW, + STATUS_FLOAT_DENORMAL_OPERAND: + Result := System.reUnderflow; + STATUS_ACCESS_VIOLATION: + Result := System.reAccessViolation; + STATUS_PRIVILEGED_INSTRUCTION: + Result := System.rePrivInstruction; + STATUS_CONTROL_C_EXIT: + Result := System.reControlBreak; + STATUS_STACK_OVERFLOW: + Result := System.reStackOverflow; + else + Result := System.reExternalException; + end; +end; + +function GetExceptionClass(P: PExceptionRecord): ExceptClass; +var + ErrorCode: Byte; +begin + ErrorCode := Byte(MapException(P)); + Result := ExceptMap[ErrorCode].EClass; +end; + +function GetExceptionObject(P: PExceptionRecord): Exception; +var + ErrorCode: Integer; + + function CreateAVObject: Exception; + var + AccessOp: string; // string ID indicating the access type READ or WRITE + AccessAddress: Pointer; + MemInfo: TMemoryBasicInformation; + ModName: array[0..MAX_PATH] of Char; + begin + with P^ do + begin + if ExceptionInformation[0] = 0 then + AccessOp := SReadAccess + else + AccessOp := SWriteAccess; + AccessAddress := Pointer(ExceptionInformation[1]); + VirtualQuery(ExceptionAddress, MemInfo, SizeOf(MemInfo)); + if (MemInfo.State = MEM_COMMIT) and + (GetModuleFileName(THandle(MemInfo.AllocationBase), ModName, SizeOf(ModName)) <> 0) then + Result := EAccessViolation.CreateFmt(sModuleAccessViolation, + [ExceptionAddress, ExtractFileName(ModName), AccessOp, + AccessAddress]) + else + Result := EAccessViolation.CreateFmt(SAccessViolationArg3, + [ExceptionAddress, AccessOp, AccessAddress]); + end; + end; + +begin + ErrorCode := Byte(MapException(P)); + case ErrorCode of + 3..10, 12..21: + with ExceptMap[ErrorCode] do Result := EClass.Create(EIdent); + 11: Result := CreateAVObject; + else + Result := EExternalException.CreateFmt(SExternalException, [P.ExceptionCode]); + end; + if Result is EExternal then EExternal(Result).ExceptionRecord := P; +end; +{$ENDIF} { WIN32 } + +{$IFDEF LINUX} +{ + The ErrorCode has the translated error code in the low byte and the + original signal number in the high word. +} +function GetExceptionObject(ExceptionAddress: LongWord; AccessAddress: LongWord; ErrorCode: LongWord): Exception; +begin + case (ErrorCode and $ff) of + 3..10, 12..21, 25: + begin + with ExceptMap[ErrorCode and $ff] do + Result := EClass.Create(EIdent); + end; + 11: + Result := EAccessViolation.CreateFmt(SAccessViolationArg2, [Pointer(ExceptionAddress), Pointer(AccessAddress)]); + else +// Result := EExternalException.CreateFmt(SExternalException, [P.ExceptionCode]); +{ Not quite right - we need the original trap code, but that's lost } + Result := EExternalException.CreateFmt(SExternalException, [ErrorCode and $ff]); + end; + + EExternal(Result).ExceptionAddress := ExceptionAddress; + EExternal(Result).AccessAddress := AccessAddress; + EExternal(Result).SignalNumber := ErrorCode shr 16; +end; +{$ENDIF} + +{ RTL exception handler } + +procedure ExceptHandler(ExceptObject: TObject; ExceptAddr: Pointer); far; +begin + ShowException(ExceptObject, ExceptAddr); + Halt(1); +end; + +{$IFDEF LINUX} +{$IFDEF DEBUG} +{ + Used for debugging the signal handlers. +} +procedure DumpContext(SigNum: Integer; context : PSigContext); +var + Buff: array [0..128] of char; +begin + StrFmt(Buff, 'Context for signal: %d', [SigNum]); + Writeln(Buff); + StrFmt(Buff, 'CS = %04X DS = %04X ES = %04X FS = %04X GS = %04X SS = %04X', + [context^.cs, context^.ds, context^.es, context^.fs, context^.gs, context^.ss]); + WriteLn(Buff); + StrFmt(Buff, 'EAX = %08X EBX = %08X ECX = %08X EDX = %08X', + [context^.eax, context^.ebx, context^.ecx, context^.edx]); + WriteLn(Buff); + StrFmt(Buff, 'EDI = %08X ESI = %08X EBP = %08X ESP = %08X', + [context^.edi, context^.esi, context^.ebp, context^.esp]); + WriteLn(Buff); + StrFmt(Buff, 'EIP = %08X EFLAGS = %08X ESP(signal) = %08X CR2 = %08X', + [context^.eip, context^.eflags, context^.esp_at_signal, context^.cr2]); + WriteLn(Buff); + StrFmt(Buff, 'trapno = %d, err = %08x', [context^.trapno, context^.err]); + WriteLn(Buff); +end; +{$ENDIF} + + +{ + RaiseSignalException is called from SignalConverter, once we've made things look + like there's a legitimate stack frame above us. Now we will just create + an exception object, and raise it via a software raise. +} +procedure RaiseSignalException(ExceptionEIP: LongWord; FaultAddr: LongWord; ErrorCode: LongWord); +begin + raise GetExceptionObject(ExceptionEIP, FaultAddr, ErrorCode); +end; + +{ + SignalConverter is where we come when a signal is raised that we want to convert + to an exception. This function stands the best chance of being called with a + useable stack frame behind it for the purpose of stack unwinding. We can't + guarantee that, though. The stack was modified by the baseline signal handler + to make it look as though we were called by the faulting instruction. That way + the unwinder stands a chance of being able to clean things up. +} +procedure SignalConverter(ExceptionEIP: LongWord; FaultAddr: LongWord; ErrorCode: LongWord); +asm + { + Here's the tricky part. We arrived here directly by virtue of our + signal handler tweaking the execution context with our address. That + means there's no return address on the stack. The unwinder needs to + have a return address so that it can unwind past this function when + we raise the Delphi exception. We will use the faulting instruction + pointer as a fake return address. Because of the fencepost conditions + in the Delphi unwinder, we need to have an address that is strictly + greater than the actual faulting instruction, so we increment that + address by one. This may be in the middle of an instruction, but we + don't care, because we will never be returning to that address. + Finally, the way that we get this address onto the stack is important. + The compiler will generate unwind information for SignalConverter that + will attempt to undo any stack modifications that are made by this + function when unwinding past it. In this particular case, we don't want + that to happen, so we use some assembly language tricks to get around + the compiler noticing the stack modification. + } + MOV EBX, ESP // Get the current stack pointer + SUB EBX, 4 // Effectively decrement the stack by 4 + MOV ESP, EBX // by doing a move to ESP with a register value + MOV [ESP], EAX // Store the instruction pointer into the new stack loc + INC [ESP] // Increment by one to keep the unwinder happy + + { Reset the FPU, or things can go south down the line from here } + FNINIT + FWAIT +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + MOV EAX, [EAX].offset Default8087CW + FLDCW [EAX] + POP ECX + POP EAX +{$ELSE} + FLDCW Default8087CW +{$ENDIF} + PUSH EBP + MOV EBP, ESP + CALL RaiseSignalException +end; + +function TlsGetValue(Key: Integer): Pointer; cdecl; + external libpthreadmodulename name 'pthread_getspecific'; + +{ + Under Linux, we crawl out from underneath the OS signal handler before + we attempt to do anything with the signal. This is because the stack + has a bunch of OS frames on there that we cannot possibly unwind from. + So we use this routine to accomplish the dispatch, and then another + routine to handle the language level of the exception handling. +} +procedure SignalDispatcher(SigNum: Integer; SigInfo: PSigInfo; UContext: PUserContext); cdecl; +type + PGeneralRegisters = ^gregset_t; +var + GeneralRegisters: PGeneralRegisters; +begin +//DumpContext(SigNum, @context); + + { + Some of the ways that we get here are can lead us to big trouble. For + example, if the signal is SIGINT or SIGQUIT, these will commonly be raised + to all threads in the process if the user generated them from the + keyboard. This is handled well by the Delphi threads, but if a non-Delphi + thread lets one of these get by unhandled, terrible things will happen. + So we look for that case, and eat SIGINT and SIGQUIT that have been issued + on threads that are not Delphi threads. If the signal is a SIGSEGV, or + other fatal sort of signal, and the thread that we're running on is not + a Delphi thread, then we are completely without options. We have no + recovery means, and we have to take the app down hard, right away. + } + if TlsGetValue(TlsIndex) = nil then + begin + if (SigNum = SIGINT) or (SigNum = SIGQUIT) then + Exit; + RunError(232); + end; + + { + If we are processing another exception right now, we definitely do not + want to be dispatching any exceptions that are async, like SIGINT and + SIGQUIT. So we have check to see if OS signals are blocked. If they are, + we have to eat this signal right now. + } + if AreOSExceptionsBlocked and ((SigNum = SIGINT) or (SigNum = SIGQUIT)) then + Exit; + + { + If someone wants to delay the handling of SIGINT or SIGQUIT until such + time as it's safe to handle it, they set DeferUserInterrupts to True. + Then we just set a global variable saying that a SIGINT or SIGQUIT was + issued. It is the responsibility of some other body of code at this + point to poll for changes to SIG(INT/QUIT)Issued + } + if DeferUserInterrupts then + begin + if SigNum = SIGINT then + begin + SIGINTIssued := True; + Exit; + end; + if SigNum = SIGQUIT then + begin + SIGQUITIssued := True; + Exit; + end; + end; + + BlockOSExceptions; + + GeneralRegisters := @UContext^.uc_mcontext.gregs; + + GeneralRegisters^[REG_EAX] := GeneralRegisters^[REG_EIP]; + GeneralRegisters^[REG_EDX] := UContext^.uc_mcontext.cr2; + GeneralRegisters^[REG_ECX] := MapSignal(SigNum, PSigContext(GeneralRegisters)); + + GeneralRegisters^[REG_EIP] := LongWord(@SignalConverter); +end; + +type + TSignalMap = packed record + SigNum: Integer; + Abandon: Boolean; + OldAction: TSigAction; + Hooked: Boolean; + end; + +var + Signals: array [0..RTL_SIGLAST] of TSignalMap = + ( (SigNum: SIGINT;), + (SigNum: SIGFPE;), + (SigNum: SIGSEGV;), + (SigNum: SIGILL;), + (SigNum: SIGBUS;), + (SigNum: SIGQUIT;) ); + +function InquireSignal(RtlSigNum: Integer): TSignalState; +var + Action: TSigAction; +begin + if sigaction(Signals[RtlSigNum].SigNum, nil, @Action) = -1 then + raise Exception.CreateRes(@SSigactionFailed); + if (@Action.__sigaction_handler <> @SignalDispatcher) then + begin + if Signals[RtlSigNum].Hooked then + Result := ssOverridden + else + Result := ssNotHooked; + end + else + Result := ssHooked; +end; + +procedure AbandonSignalHandler(RtlSigNum: Integer); +var + I: Integer; +begin + if RtlSigNum = RTL_SIGDEFAULT then + begin + for I := 0 to RTL_SIGLAST do + AbandonSignalHandler(I); + Exit; + end; + Signals[RtlSigNum].Abandon := True; +end; + +procedure HookSignal(RtlSigNum: Integer); +var + Action: TSigAction; + I: Integer; +begin + if RtlSigNum = RTL_SIGDEFAULT then + begin + for I := 0 to RTL_SIGLAST do + HookSignal(I); + Exit; + end; + + FillChar(Action, SizeOf(Action), 0); + Action.__sigaction_handler := @SignalDispatcher; + Action.sa_flags := SA_SIGINFO; + sigaddset(Action.sa_mask, SIGINT); + sigaddset(Action.sa_mask, SIGQUIT); + if sigaction(Signals[RtlSigNum].SigNum, @Action, @Signals[RtlSigNum].OldAction) = -1 then + raise Exception.CreateRes(@SSigactionFailed); + Signals[RtlSigNum].Hooked := True; +end; + +procedure UnhookSignal(RtlSigNum: Integer; OnlyIfHooked: Boolean); +var + I: Integer; +begin + if RtlSigNum = RTL_SIGDEFAULT then + begin + for I := 0 to RTL_SIGLAST do + UnhookSignal(I, OnlyIfHooked); + Exit; + end; + if not Signals[RtlSigNum].Abandon then + begin + if OnlyIfHooked and (InquireSignal(RtlSigNum) <> ssHooked) then + Exit; + if sigaction(Signals[RtlSigNum].SigNum, @Signals[RtlSigNum].OldAction, Nil) = -1 then + raise Exception.CreateRes(@SSigactionFailed); + Signals[RtlSigNum].Hooked := False; + end; +end; + +procedure UnhookOSExceptions; +begin + if not Assigned(HookOSExceptionsProc) then + UnhookSignal(RTL_SIGDEFAULT, True); +end; + +procedure HookOSExceptions; +begin + if Assigned(HookOSExceptionsProc) then + HookOSExceptionsProc + else + begin + HookSignal(RTL_SIGDEFAULT); + end; +end; +{$ENDIF} // LINUX + +procedure InitExceptions; +begin + OutOfMemory := EOutOfMemory.CreateRes(@SOutOfMemory); + InvalidPointer := EInvalidPointer.CreateRes(@SInvalidPointer); + ErrorProc := ErrorHandler; + ExceptProc := @ExceptHandler; + ExceptionClass := Exception; + +{$IFDEF MSWINDOWS} + ExceptClsProc := @GetExceptionClass; + ExceptObjProc := @GetExceptionObject; +{$ENDIF} + + AssertErrorProc := @AssertErrorHandler; + +{$IFNDEF PC_MAPPED_EXCEPTIONS} + // We don't hook this under PC mapped exceptions, because + // we have no idea what the parameters were to the procedure + // in question. Hence we cannot hope to unwind the stack in + // our handler. Since we just throw an exception from our + // handler, that pretty much rules out using this without + // exorbitant compiler support. If you do hook AbstractErrorProc, + // you must make sure that you never throw an exception from + // your handler if PC_MAPPED_EXCEPTIONS is defined. + AbstractErrorProc := @AbstractErrorHandler; +{$ENDIF} + +{$IFDEF LINUX} + if not IsLibrary then + HookOSExceptions; +{$ENDIF} +end; + +procedure DoneExceptions; +begin + if Assigned(OutOfMemory) then + begin + OutOfMemory.AllowFree := True; + OutOfMemory.FreeInstance; + OutOfMemory := nil; + end; + if Assigned(InvalidPointer) then + begin + InvalidPointer.AllowFree := True; + InvalidPointer.Free; + InvalidPointer := nil; + end; + ErrorProc := nil; + ExceptProc := nil; + ExceptionClass := nil; +{$IFDEF MSWINDOWS} + ExceptClsProc := nil; + ExceptObjProc := nil; +{$ENDIF} + AssertErrorProc := nil; +{$IFDEF LINUX} + if not IsLibrary then + UnhookOSExceptions; +{$ENDIF} +end; + +{$IFDEF MSWINDOWS} +procedure InitPlatformId; +var + OSVersionInfo: TOSVersionInfo; +begin + OSVersionInfo.dwOSVersionInfoSize := SizeOf(OSVersionInfo); + if GetVersionEx(OSVersionInfo) then + with OSVersionInfo do + begin + Win32Platform := dwPlatformId; + Win32MajorVersion := dwMajorVersion; + Win32MinorVersion := dwMinorVersion; + if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then + Win32BuildNumber := dwBuildNumber and $FFFF + else + Win32BuildNumber := dwBuildNumber; + Win32CSDVersion := szCSDVersion; + end; +end; + +function CheckWin32Version(AMajor: Integer; AMinor: Integer = 0): Boolean; +begin + Result := (Win32MajorVersion > AMajor) or + ((Win32MajorVersion = AMajor) and + (Win32MinorVersion >= AMinor)); +end; + +function GetFileVersion(const AFileName: string): Cardinal; +var + FileName: string; + InfoSize, Wnd: DWORD; + VerBuf: Pointer; + FI: PVSFixedFileInfo; + VerSize: DWORD; +begin + Result := Cardinal(-1); + // GetFileVersionInfo modifies the filename parameter data while parsing. + // Copy the string const into a local variable to create a writeable copy. + FileName := AFileName; + UniqueString(FileName); + InfoSize := GetFileVersionInfoSize(PChar(FileName), Wnd); + if InfoSize <> 0 then + begin + GetMem(VerBuf, InfoSize); + try + if GetFileVersionInfo(PChar(FileName), Wnd, InfoSize, VerBuf) then + if VerQueryValue(VerBuf, '\', Pointer(FI), VerSize) then + Result:= FI.dwFileVersionMS; + finally + FreeMem(VerBuf); + end; + end; +end; + +procedure Beep; +begin + MessageBeep(0); +end; +{$ENDIF} +{$IFDEF LINUX} +procedure Beep; +var + ch: Char; + FileDes: Integer; +begin + if isatty(STDERR_FILENO) = 1 then + FileDes := STDERR_FILENO + else + if isatty(STDOUT_FILENO) = 1 then + FileDes := STDOUT_FILENO + else + begin + // Neither STDERR_FILENO nor STDOUT_FILENO are open + // terminals (TTYs). It is not possible to safely + // write the beep character. + Exit; + end; + + ch := #7; + __write(FileDes, ch, 1); +end; +{$ENDIF} + +{ MBCS functions } + +function ByteTypeTest(P: PChar; Index: Integer): TMbcsByteType; +{$IFDEF MSWINDOWS} +var + I: Integer; +begin + Result := mbSingleByte; + if (P = nil) or (P[Index] = #$0) then Exit; + if (Index = 0) then + begin + if P[0] in LeadBytes then Result := mbLeadByte; + end + else + begin + I := Index - 1; + while (I >= 0) and (P[I] in LeadBytes) do Dec(I); + if ((Index - I) mod 2) = 0 then Result := mbTrailByte + else if P[Index] in LeadBytes then Result := mbLeadByte; + end; +end; +{$ENDIF} +{$IFDEF LINUX} +var + I, L: Integer; +begin + Result := mbSingleByte; + if (P = nil) or (P[Index] = #$0) then Exit; + + I := 0; + repeat + if P[I] in LeadBytes then + L := StrCharLength(P + I) + else + L := 1; + Inc(I, L); + until (I > Index); + + if (L <> 1) then + if (I - L = Index) then + Result := mbLeadByte + else + Result := mbTrailByte; +end; +{$ENDIF} + +function ByteType(const S: string; Index: Integer): TMbcsByteType; +begin + Result := mbSingleByte; + if SysLocale.FarEast then + Result := ByteTypeTest(PChar(S), Index-1); +end; + +function StrByteType(Str: PChar; Index: Cardinal): TMbcsByteType; +begin + Result := mbSingleByte; + if SysLocale.FarEast then + Result := ByteTypeTest(Str, Index); +end; + +function ByteToCharLen(const S: string; MaxLen: Integer): Integer; +begin + if Length(S) < MaxLen then MaxLen := Length(S); + Result := ByteToCharIndex(S, MaxLen); +end; + +function ByteToCharIndex(const S: string; Index: Integer): Integer; +var + I: Integer; +begin + Result := 0; + if (Index <= 0) or (Index > Length(S)) then Exit; + Result := Index; + if not SysLocale.FarEast then Exit; + I := 1; + Result := 0; + while I <= Index do + begin + if S[I] in LeadBytes then + I := NextCharIndex(S, I) + else + Inc(I); + Inc(Result); + end; +end; + +procedure CountChars(const S: string; MaxChars: Integer; var CharCount, ByteCount: Integer); +var + C, L, B: Integer; +begin + L := Length(S); + C := 1; + B := 1; + while (B < L) and (C < MaxChars) do + begin + Inc(C); + if S[B] in LeadBytes then + B := NextCharIndex(S, B) + else + Inc(B); + end; + if (C = MaxChars) and (B < L) and (S[B] in LeadBytes) then + B := NextCharIndex(S, B) - 1; + CharCount := C; + ByteCount := B; +end; + +function CharToByteIndex(const S: string; Index: Integer): Integer; +var + Chars: Integer; +begin + Result := 0; + if (Index <= 0) or (Index > Length(S)) then Exit; + if (Index > 1) and SysLocale.FarEast then + begin + CountChars(S, Index-1, Chars, Result); + if (Chars < (Index-1)) or (Result >= Length(S)) then + Result := 0 // Char index out of range + else + Inc(Result); + end + else + Result := Index; +end; + +function CharToByteLen(const S: string; MaxLen: Integer): Integer; +var + Chars: Integer; +begin + Result := 0; + if MaxLen <= 0 then Exit; + if MaxLen > Length(S) then MaxLen := Length(S); + if SysLocale.FarEast then + begin + CountChars(S, MaxLen, Chars, Result); + if Result > Length(S) then + Result := Length(S); + end + else + Result := MaxLen; +end; + +{ MBCS Helper functions } + +function StrCharLength(const Str: PChar): Integer; +begin +{$IFDEF LINUX} + Result := mblen(Str, MB_CUR_MAX); + if (Result = -1) then Result := 1; +{$ENDIF} +{$IFDEF MSWINDOWS} + if SysLocale.FarEast then + Result := Integer(CharNext(Str)) - Integer(Str) + else + Result := 1; +{$ENDIF} +end; + +function StrNextChar(const Str: PChar): PChar; +begin +{$IFDEF LINUX} + Result := Str + StrCharLength(Str); +{$ENDIF} +{$IFDEF MSWINDOWS} + Result := CharNext(Str); +{$ENDIF} +end; + +function CharLength(const S: string; Index: Integer): Integer; +begin + Result := 1; + assert((Index > 0) and (Index <= Length(S))); + if SysLocale.FarEast and (S[Index] in LeadBytes) then + Result := StrCharLength(PChar(S) + Index - 1); +end; + +function NextCharIndex(const S: string; Index: Integer): Integer; +begin + Result := Index + 1; + assert((Index > 0) and (Index <= Length(S))); + if SysLocale.FarEast and (S[Index] in LeadBytes) then + Result := Index + StrCharLength(PChar(S) + Index - 1); +end; + +function IsPathDelimiter(const S: string; Index: Integer): Boolean; +begin + Result := (Index > 0) and (Index <= Length(S)) and (S[Index] = PathDelim) + and (ByteType(S, Index) = mbSingleByte); +end; + +function IsDelimiter(const Delimiters, S: string; Index: Integer): Boolean; +begin + Result := False; + if (Index <= 0) or (Index > Length(S)) or (ByteType(S, Index) <> mbSingleByte) then exit; + Result := StrScan(PChar(Delimiters), S[Index]) <> nil; +end; + +function IncludeTrailingBackslash(const S: string): string; +begin + Result := IncludeTrailingPathDelimiter(S); +end; + +function IncludeTrailingPathDelimiter(const S: string): string; +begin + Result := S; + if not IsPathDelimiter(Result, Length(Result)) then + Result := Result + PathDelim; +end; + +function ExcludeTrailingBackslash(const S: string): string; +begin + Result := ExcludeTrailingPathDelimiter(S); +end; + +function ExcludeTrailingPathDelimiter(const S: string): string; +begin + Result := S; + if IsPathDelimiter(Result, Length(Result)) then + SetLength(Result, Length(Result)-1); +end; + +function AnsiPos(const Substr, S: string): Integer; +var + P: PChar; +begin + Result := 0; + P := AnsiStrPos(PChar(S), PChar(SubStr)); + if P <> nil then + Result := Integer(P) - Integer(PChar(S)) + 1; +end; + +function AnsiCompareFileName(const S1, S2: string): Integer; +begin +{$IFDEF MSWINDOWS} + Result := AnsiCompareStr(AnsiLowerCaseFileName(S1), AnsiLowerCaseFileName(S2)); +{$ENDIF} +{$IFDEF LINUX} + Result := AnsiCompareStr(S1, S2); +{$ENDIF} +end; + +function SameFileName(const S1, S2: string): Boolean; +begin + Result := AnsiCompareFileName(S1, S2) = 0; +end; + +function AnsiLowerCaseFileName(const S: string): string; +{$IFDEF MSWINDOWS} +var + I,L: Integer; +begin + if SysLocale.FarEast then + begin + L := Length(S); + SetLength(Result, L); + I := 1; + while I <= L do + begin + Result[I] := S[I]; + if S[I] in LeadBytes then + begin + Inc(I); + Result[I] := S[I]; + end + else + if Result[I] in ['A'..'Z'] then Inc(Byte(Result[I]), 32); + Inc(I); + end; + end + else + Result := AnsiLowerCase(S); +end; +{$ENDIF} +{$IFDEF LINUX} +begin + Result := AnsiLowerCase(S); +end; +{$ENDIF} + +function AnsiUpperCaseFileName(const S: string): string; +{$IFDEF MSWINDOWS} +var + I,L: Integer; +begin + if SysLocale.FarEast then + begin + L := Length(S); + SetLength(Result, L); + I := 1; + while I <= L do + begin + Result[I] := S[I]; + if S[I] in LeadBytes then + begin + Inc(I); + Result[I] := S[I]; + end + else + if Result[I] in ['a'..'z'] then Dec(Byte(Result[I]), 32); + Inc(I); + end; + end + else + Result := AnsiUpperCase(S); +end; +{$ENDIF} +{$IFDEF LINUX} +begin + Result := AnsiUpperCase(S); +end; +{$ENDIF} + +function AnsiStrPos(Str, SubStr: PChar): PChar; +var + L1, L2: Cardinal; + ByteType : TMbcsByteType; +begin + Result := nil; + if (Str = nil) or (Str^ = #0) or (SubStr = nil) or (SubStr^ = #0) then Exit; + L1 := StrLen(Str); + L2 := StrLen(SubStr); + Result := StrPos(Str, SubStr); + while (Result <> nil) and ((L1 - Cardinal(Result - Str)) >= L2) do + begin + ByteType := StrByteType(Str, Integer(Result-Str)); +{$IFDEF MSWINDOWS} + if (ByteType <> mbTrailByte) and + (CompareString(LOCALE_USER_DEFAULT, 0, Result, L2, SubStr, L2) = CSTR_EQUAL) then Exit; + if (ByteType = mbLeadByte) then Inc(Result); +{$ENDIF} +{$IFDEF LINUX} + if (ByteType <> mbTrailByte) and + (strncmp(Result, SubStr, L2) = 0) then Exit; +{$ENDIF} + Inc(Result); + Result := StrPos(Result, SubStr); + end; + Result := nil; +end; + +function AnsiStrRScan(Str: PChar; Chr: Char): PChar; +begin + Str := AnsiStrScan(Str, Chr); + Result := Str; + if Chr <> #$0 then + begin + while Str <> nil do + begin + Result := Str; + Inc(Str); + Str := AnsiStrScan(Str, Chr); + end; + end +end; + +function AnsiStrScan(Str: PChar; Chr: Char): PChar; +begin + Result := StrScan(Str, Chr); + while Result <> nil do + begin +{$IFDEF MSWINDOWS} + case StrByteType(Str, Integer(Result-Str)) of + mbSingleByte: Exit; + mbLeadByte: Inc(Result); + end; +{$ENDIF} +{$IFDEF LINUX} + if StrByteType(Str, Integer(Result-Str)) = mbSingleByte then Exit; +{$ENDIF} + Inc(Result); + Result := StrScan(Result, Chr); + end; +end; + +{$IFDEF MSWINDOWS} +function LCIDToCodePage(ALcid: LCID): Integer; +var + Buffer: array [0..6] of Char; +begin + GetLocaleInfo(ALcid, LOCALE_IDEFAULTANSICODEPAGE, Buffer, SizeOf(Buffer)); + Result:= StrToIntDef(Buffer, GetACP); +end; +{$ENDIF} + +procedure InitSysLocale; +{$IFDEF MSWINDOWS} +var + DefaultLCID: LCID; + DefaultLangID: LANGID; + AnsiCPInfo: TCPInfo; + + procedure InitLeadBytes; + var + I: Integer; + J: Byte; + begin + GetCPInfo(CP_ACP, AnsiCPInfo); + with AnsiCPInfo do + begin + I := 0; + while (I < MAX_LEADBYTES) and ((LeadByte[I] or LeadByte[I + 1]) <> 0) do + begin + for J := LeadByte[I] to LeadByte[I + 1] do + Include(LeadBytes, Char(J)); + Inc(I, 2); + end; + end; + end; + +begin + { Set default to English (US). } + SysLocale.DefaultLCID := $0409; + SysLocale.PriLangID := LANG_ENGLISH; + SysLocale.SubLangID := SUBLANG_ENGLISH_US; + + DefaultLCID := GetThreadLocale; + if DefaultLCID <> 0 then SysLocale.DefaultLCID := DefaultLCID; + + DefaultLangID := Word(DefaultLCID); + if DefaultLangID <> 0 then + begin + SysLocale.PriLangID := DefaultLangID and $3ff; + SysLocale.SubLangID := DefaultLangID shr 10; + end; + + LeadBytes := []; + if (Win32MajorVersion > 4) and (Win32Platform = VER_PLATFORM_WIN32_NT) then + SysLocale.MiddleEast := True + else + SysLocale.MiddleEast := GetSystemMetrics(SM_MIDEASTENABLED) <> 0; + SysLocale.FarEast := GetSystemMetrics(SM_DBCSENABLED) <> 0; + if SysLocale.FarEast then + InitLeadBytes; +end; +{$ENDIF} +{$IFDEF LINUX} +var + I: Integer; + buf: array [0..3] of char; +begin + FillChar(SysLocale, sizeof(SysLocale), 0); + SysLocale.FarEast := MB_CUR_MAX <> 1; + if not SysLocale.FarEast then Exit; + + buf[1] := #0; + for I := 1 to 255 do + begin + buf[0] := Chr(I); + if mblen(buf, 1) <> 1 then Include(LeadBytes, Char(I)); + end; +end; +{$ENDIF} + +procedure GetFormatSettings; +{$IFDEF MSWINDOWS} +var + HourFormat, TimePrefix, TimePostfix: string; + DefaultLCID: Integer; +begin + InitSysLocale; + GetMonthDayNames; + if SysLocale.FarEast then GetEraNamesAndYearOffsets; + DefaultLCID := GetThreadLocale; + CurrencyString := GetLocaleStr(DefaultLCID, LOCALE_SCURRENCY, ''); + CurrencyFormat := StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ICURRENCY, '0'), 0); + NegCurrFormat := StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_INEGCURR, '0'), 0); + ThousandSeparator := GetLocaleChar(DefaultLCID, LOCALE_STHOUSAND, ','); + DecimalSeparator := GetLocaleChar(DefaultLCID, LOCALE_SDECIMAL, '.'); + CurrencyDecimals := StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ICURRDIGITS, '0'), 0); + DateSeparator := GetLocaleChar(DefaultLCID, LOCALE_SDATE, '/'); + ShortDateFormat := TranslateDateFormat(GetLocaleStr(DefaultLCID, LOCALE_SSHORTDATE, 'm/d/yy')); + LongDateFormat := TranslateDateFormat(GetLocaleStr(DefaultLCID, LOCALE_SLONGDATE, 'mmmm d, yyyy')); + TimeSeparator := GetLocaleChar(DefaultLCID, LOCALE_STIME, ':'); + TimeAMString := GetLocaleStr(DefaultLCID, LOCALE_S1159, 'am'); + TimePMString := GetLocaleStr(DefaultLCID, LOCALE_S2359, 'pm'); + TimePrefix := ''; + TimePostfix := ''; + if StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ITLZERO, '0'), 0) = 0 then + HourFormat := 'h' else + HourFormat := 'hh'; + if StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ITIME, '0'), 0) = 0 then + if StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ITIMEMARKPOSN, '0'), 0) = 0 then + TimePostfix := ' AMPM' + else + TimePrefix := 'AMPM '; + ShortTimeFormat := TimePrefix + HourFormat + ':mm' + TimePostfix; + LongTimeFormat := TimePrefix + HourFormat + ':mm:ss' + TimePostfix; + ListSeparator := GetLocaleChar(DefaultLCID, LOCALE_SLIST, ','); +end; +{$ELSE} +{$IFDEF LINUX} +const + //first boolean is p_cs_precedes, second is p_sep_by_space + CurrencyFormats: array[boolean, boolean] of byte = ((1, 3),(0, 2)); + //first boolean is n_cs_precedes, second is n_sep_by_space and finally n_sign_posn + NegCurrFormats: array[boolean, boolean, 0..4] of byte = + (((4,5,7,6,7),(15,8,10,13,10)),((0,1,3,1,2),(14,9,11,9,12))); + + function TranslateFormat(s: PChar; const Default: string): string; + begin + Result := ''; + while s^ <> #0 do + begin + if s^ = '%' then + begin + inc(s); + case s^ of + 'a': Result := Result + 'ddd'; + 'A': Result := Result + 'dddd'; + 'b': Result := Result + 'MMM'; + 'B': Result := Result + 'MMMM'; + 'c': Result := Result + 'c'; +// 'C': year / 100 not supported + 'd': Result := Result + 'dd'; + 'D': Result := Result + 'MM/dd/yy'; + 'e': Result := Result + 'd'; +// 'E': alternate format not supported + 'g': Result := Result + 'yy'; + 'G': Result := Result + 'yyyy'; + 'h': Result := Result + 'MMM'; + 'H': Result := Result + 'HH'; + 'I': Result := Result + 'hh'; +// 'j': day of year not supported + 'k': Result := Result + 'H'; + 'l': Result := Result + 'h'; + 'm': Result := Result + 'MM'; + 'M': Result := Result + 'nn'; // minutes! not months! + 'n': Result := Result + sLineBreak; // line break +// 'O': alternate format not supported + 'P', // P's implied lowercasing of locale string is not supported + 'p': Result := Result + 'AMPM'; + 'r': Result := Result + TranslateFormat(nl_langInfo(T_FMT_AMPM),''); + 'R': Result := Result + 'HH:mm'; +// 's': number of seconds since Epoch not supported + 'S': Result := Result + 'ss'; + 't': Result := Result + #9; // tab char + 'T': Result := Result + 'HH:mm:ss'; +// 'u': day of week 1..7 not supported +// 'U': week number of the year not supported +// 'V': week number of the year not supported +// 'w': day of week 0..6 not supported +// 'W': week number of the year not supported + 'x': Result := Result + TranslateFormat(nl_langInfo(D_FMT),''); + 'X': Result := Result + TranslateFormat(nl_langinfo(T_FMT),''); + 'y': Result := Result + 'yy'; + 'Y': Result := Result + 'yyyy'; +// 'z': GMT offset is not supported + '%': Result := Result + '%'; + end; + end + else + Result := Result + s^; + Inc(s); + end; + if Result = '' then + Result := Default; + end; + + function GetFirstCharacter(const SrcString, match: string): char; + var + i, p: integer; + begin + result := match[1]; + for i := 1 to length(SrcString) do begin + p := Pos(SrcString[i], match); + if p > 0 then + begin + result := match[p]; + break; + end; + end; + end; + +var + P: PLConv; +begin + InitSysLocale; + GetMonthDayNames; + if SysLocale.FarEast then InitEras; + + CurrencyString := ''; + CurrencyFormat := 0; + NegCurrFormat := 0; + ThousandSeparator := ','; + DecimalSeparator := '.'; + CurrencyDecimals := 0; + + P := localeconv; + if P <> nil then + begin + if P^.currency_symbol <> nil then + CurrencyString := P^.currency_symbol; + + if (Byte(P^.p_cs_precedes) in [0..1]) and + (Byte(P^.p_sep_by_space) in [0..1]) then + begin + CurrencyFormat := CurrencyFormats[P^.p_cs_precedes, P^.p_sep_by_space]; + if P^.p_sign_posn in [0..4] then + NegCurrFormat := NegCurrFormats[P^.n_cs_precedes, P^.n_sep_by_space, + P^.n_sign_posn]; + end; + + // #0 is valid for ThousandSeparator. Indicates no thousand separator. + ThousandSeparator := P^.thousands_sep^; + + // #0 is not valid for DecimalSeparator. + if P^.decimal_point <> #0 then + DecimalSeparator := P^.decimal_point^; + CurrencyDecimals := P^.frac_digits; + end; + + ShortDateFormat := TranslateFormat(nl_langinfo(D_FMT),'m/d/yy'); + LongDateFormat := TranslateFormat(nl_langinfo(D_T_FMT), ShortDateFormat); + ShortTimeFormat := TranslateFormat(nl_langinfo(T_FMT), 'hh:mm AMPM'); + LongTimeFormat := TranslateFormat(nl_langinfo(T_FMT_AMPM), ShortTimeFormat); + + DateSeparator := GetFirstCharacter(ShortDateFormat, '/.-'); + TimeSeparator := GetFirstCharacter(ShortTimeFormat, ':.'); + + TimeAMString := nl_langinfo(AM_STR); + TimePMString := nl_langinfo(PM_STR); + ListSeparator := ','; +end; +{$ELSE} +var + HourFormat, TimePrefix, TimePostfix: string; +begin + InitSysLocale; + GetMonthDayNames; + CurrencyString := ''; + CurrencyFormat := 0; + NegCurrFormat := 0; + ThousandSeparator := ','; + DecimalSeparator := '.'; + CurrencyDecimals := 0; + DateSeparator := '/'; + ShortDateFormat := 'm/d/yy'; + LongDateFormat := 'mmmm d, yyyy'; + TimeSeparator := ':'; + TimeAMString := 'am'; + TimePMString := 'pm'; + TimePrefix := ''; + TimePostfix := ''; + HourFormat := 'h'; + TimePostfix := ' AMPM'; + ShortTimeFormat := TimePrefix + HourFormat + ':mm' + TimePostfix; + LongTimeFormat := TimePrefix + HourFormat + ':mm:ss' + TimePostfix; + ListSeparator := ','; +end; +{$ENDIF} +{$ENDIF} + +{$IFDEF MSWINDOWS} +procedure GetLocaleFormatSettings(LCID: Integer; + var FormatSettings: TFormatSettings); +var + HourFormat, TimePrefix, TimePostfix: string; + DefaultLCID: Integer; +begin + if IsValidLocale(LCID, LCID_INSTALLED) then + DefaultLCID := LCID + else + DefaultLCID := GetThreadLocale; + + GetLocaleMonthDayNames(LCID, FormatSettings); + with FormatSettings do + begin + CurrencyString := GetLocaleStr(DefaultLCID, LOCALE_SCURRENCY, ''); + CurrencyFormat := StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ICURRENCY, '0'), 0); + NegCurrFormat := StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_INEGCURR, '0'), 0); + ThousandSeparator := GetLocaleChar(DefaultLCID, LOCALE_STHOUSAND, ','); + DecimalSeparator := GetLocaleChar(DefaultLCID, LOCALE_SDECIMAL, '.'); + CurrencyDecimals := StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ICURRDIGITS, '0'), 0); + DateSeparator := GetLocaleChar(DefaultLCID, LOCALE_SDATE, '/'); + ShortDateFormat := TranslateDateFormat(GetLocaleStr(DefaultLCID, LOCALE_SSHORTDATE, 'm/d/yy')); + LongDateFormat := TranslateDateFormat(GetLocaleStr(DefaultLCID, LOCALE_SLONGDATE, 'mmmm d, yyyy')); + TimeSeparator := GetLocaleChar(DefaultLCID, LOCALE_STIME, ':'); + TimeAMString := GetLocaleStr(DefaultLCID, LOCALE_S1159, 'am'); + TimePMString := GetLocaleStr(DefaultLCID, LOCALE_S2359, 'pm'); + TimePrefix := ''; + TimePostfix := ''; + if StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ITLZERO, '0'), 0) = 0 then + HourFormat := 'h' else + HourFormat := 'hh'; + if StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ITIME, '0'), 0) = 0 then + if StrToIntDef(GetLocaleStr(DefaultLCID, LOCALE_ITIMEMARKPOSN, '0'), 0) = 0 then + TimePostfix := ' AMPM' + else + TimePrefix := 'AMPM '; + ShortTimeFormat := TimePrefix + HourFormat + ':mm' + TimePostfix; + LongTimeFormat := TimePrefix + HourFormat + ':mm:ss' + TimePostfix; + ListSeparator := GetLocaleChar(DefaultLCID, LOCALE_SLIST, ','); + end; +end; +{$ENDIF} + +function StringReplace(const S, OldPattern, NewPattern: string; + Flags: TReplaceFlags): string; +var + SearchStr, Patt, NewStr: string; + Offset: Integer; +begin + if rfIgnoreCase in Flags then + begin + SearchStr := AnsiUpperCase(S); + Patt := AnsiUpperCase(OldPattern); + end else + begin + SearchStr := S; + Patt := OldPattern; + end; + NewStr := S; + Result := ''; + while SearchStr <> '' do + begin + Offset := AnsiPos(Patt, SearchStr); + if Offset = 0 then + begin + Result := Result + NewStr; + Break; + end; + Result := Result + Copy(NewStr, 1, Offset - 1) + NewPattern; + NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt); + if not (rfReplaceAll in Flags) then + begin + Result := Result + NewStr; + Break; + end; + SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt); + end; +end; + +function WrapText(const Line, BreakStr: string; const BreakChars: TSysCharSet; + MaxCol: Integer): string; +const + QuoteChars = ['''', '"']; +var + Col, Pos: Integer; + LinePos, LineLen: Integer; + BreakLen, BreakPos: Integer; + QuoteChar, CurChar: Char; + ExistingBreak: Boolean; + L: Integer; +begin + Col := 1; + Pos := 1; + LinePos := 1; + BreakPos := 0; + QuoteChar := #0; + ExistingBreak := False; + LineLen := Length(Line); + BreakLen := Length(BreakStr); + Result := ''; + while Pos <= LineLen do + begin + CurChar := Line[Pos]; + if CurChar in LeadBytes then + begin + L := CharLength(Line, Pos) - 1; + Inc(Pos, L); + Inc(Col, L); + end + else + begin + if CurChar in QuoteChars then + if QuoteChar = #0 then + QuoteChar := CurChar + else if CurChar = QuoteChar then + QuoteChar := #0; + if QuoteChar = #0 then + begin + if CurChar = BreakStr[1] then + begin + ExistingBreak := StrLComp(Pointer(BreakStr), Pointer(@Line[Pos]), BreakLen) = 0; + if ExistingBreak then + begin + Inc(Pos, BreakLen-1); + BreakPos := Pos; + end; + end; + + if not ExistingBreak then + if CurChar in BreakChars then + BreakPos := Pos; + end; + end; + + Inc(Pos); + Inc(Col); + + if not (QuoteChar in QuoteChars) and (ExistingBreak or + ((Col > MaxCol) and (BreakPos > LinePos))) then + begin + Col := 1; + Result := Result + Copy(Line, LinePos, BreakPos - LinePos + 1); + if not (CurChar in QuoteChars) then + begin + while Pos <= LineLen do + begin + if Line[Pos] in BreakChars then + begin + Inc(Pos); + ExistingBreak := False; + end + else + begin + if StrLComp(Pointer(@Line[Pos]), sLineBreak, Length(sLineBreak)) = 0 then + begin + Inc(Pos, Length(sLineBreak)); + ExistingBreak := True; + end + else + Break; + end; + end; + end; + if (Pos <= LineLen) and not ExistingBreak then + Result := Result + BreakStr; + + Inc(BreakPos); + LinePos := BreakPos; + Pos := LinePos; + ExistingBreak := False; + end; + end; + Result := Result + Copy(Line, LinePos, MaxInt); +end; + +function WrapText(const Line: string; MaxCol: Integer): string; +begin + Result := WrapText(Line, sLineBreak, [' ', '-', #9], MaxCol); { do not localize } +end; + +function FindCmdLineSwitch(const Switch: string; const Chars: TSysCharSet; + IgnoreCase: Boolean): Boolean; +var + I: Integer; + S: string; +begin + for I := 1 to ParamCount do + begin + S := ParamStr(I); + if (Chars = []) or (S[1] in Chars) then + if IgnoreCase then + begin + if (AnsiCompareText(Copy(S, 2, Maxint), Switch) = 0) then + begin + Result := True; + Exit; + end; + end + else begin + if (AnsiCompareStr(Copy(S, 2, Maxint), Switch) = 0) then + begin + Result := True; + Exit; + end; + end; + end; + Result := False; +end; + +function FindCmdLineSwitch(const Switch: string): Boolean; +begin + Result := FindCmdLineSwitch(Switch, SwitchChars, True); +end; + +function FindCmdLineSwitch(const Switch: string; IgnoreCase: Boolean): Boolean; +begin + Result := FindCmdLineSwitch(Switch, SwitchChars, IgnoreCase); +end; + +{ Package info structures } + +type + PPkgName = ^TPkgName; + TPkgName = packed record + HashCode: Byte; + Name: array[0..255] of Char; + end; + + { PackageUnitFlags: + bit meaning + ----------------------------------------------------------------------------------------- + 0 | main unit + 1 | package unit (dpk source) + 2 | $WEAKPACKAGEUNIT unit + 3 | original containment of $WEAKPACKAGEUNIT (package into which it was compiled) + 4 | implicitly imported + 5..7 | reserved + } + PUnitName = ^TUnitName; + TUnitName = packed record + Flags : Byte; + HashCode: Byte; + Name: array[0..255] of Char; + end; + + { Package flags: + bit meaning + ----------------------------------------------------------------------------------------- + 0 | 1: never-build 0: always build + 1 | 1: design-time only 0: not design-time only on => bit 2 = off + 2 | 1: run-time only 0: not run-time only on => bit 1 = off + 3 | 1: do not check for dup units 0: perform normal dup unit check + 4..25 | reserved + 26..27| (producer) 0: pre-V4, 1: undefined, 2: c++, 3: Pascal + 28..29| reserved + 30..31| 0: EXE, 1: Package DLL, 2: Library DLL, 3: undefined + } + PPackageInfoHeader = ^TPackageInfoHeader; + TPackageInfoHeader = packed record + Flags: Cardinal; + RequiresCount: Integer; + {Requires: array[0..9999] of TPkgName; + ContainsCount: Integer; + Contains: array[0..9999] of TUnitName;} + end; + + PUnitHashEntry = ^TUnitHashEntry; + TUnitHashEntry = record + Next, Prev: PUnitHashEntry; + LibModule: PLibModule; + UnitName: PChar; + DupsAllowed: Boolean; + end; + TUnitHashArray = array of TUnitHashEntry; + TUnitHashBuckets = array[Byte] of PUnitHashEntry; + + PModuleInfo = ^TModuleInfo; + TModuleInfo = record + Validated: Boolean; + UnitHashArray: TUnitHashArray; + end; + +var + CharHash: array[Char] of Byte; + ValidatedUnitHashBuckets: TUnitHashBuckets; + UnitHashBuckets: TUnitHashBuckets; + +procedure InitCharHash; inline; +var + C: Char; +begin + if CharHash[#1] = 0 then + for C := Low(CharHash) to High(CharHash) do + if C in ['a'..'z'] then + + CharHash[C] := Ord(UpCase(C)) + else + CharHash[C] := Ord(C); +end; + + +function HashName(Name: PChar): Byte; inline; +var + Hash: Cardinal; +const + ShrBits = (SizeOf(Hash) * 8 - 2); +begin + Hash := 0; + while True do + begin + if Name[0] = #0 then + Break; + Hash := ((Hash shl 2) or (Hash shr ShrBits)) xor CharHash[Name[0]]; + if Name[1] = #0 then + Break; + Hash := ((Hash shl 2) or (Hash shr ShrBits)) xor CharHash[Name[1]]; + if Name[2] = #0 then + Break; + Hash := ((Hash shl 2) or (Hash shr ShrBits)) xor CharHash[Name[2]]; + if Name[3] = #0 then + Break; + Hash := ((Hash shl 2) or (Hash shr ShrBits)) xor CharHash[Name[3]]; + Inc(Name, 4); + end; + Result := LongRec(Hash).Bytes[0] xor LongRec(Hash).Bytes[1] xor + LongRec(Hash).Bytes[2] xor LongRec(Hash).Bytes[3]; +end; + +function FindLibModule(Module: HModule): PLibModule; inline; +begin + Result := LibModuleList; + while Result <> nil do + begin + if Result.Instance = Cardinal(Module) then Exit; + Result := Result.Next; + end; +end; + +procedure ModuleUnloaded(Module: Longword); +var + LibModule: PLibModule; + ModuleInfo: PModuleInfo; + I: Integer; + HC: Byte; + Buckets: ^TUnitHashBuckets; +begin + LibModule := FindLibModule(Module); + if (LibModule <> nil) and (LibModule.Reserved <> 0) then + begin + ModuleInfo := PModuleInfo(LibModule.Reserved); + if ModuleInfo.Validated then + Buckets := @ValidatedUnitHashBuckets + else + Buckets := @UnitHashBuckets; + for I := Low(ModuleInfo.UnitHashArray) to High(ModuleInfo.UnitHashArray) do + begin + if ModuleInfo.UnitHashArray[I].Prev <> nil then + ModuleInfo.UnitHashArray[I].Prev.Next := ModuleInfo.UnitHashArray[I].Next + else if ModuleInfo.UnitHashArray[I].UnitName <> nil then + begin + HC := HashName(ModuleInfo.UnitHashArray[I].UnitName); + if Buckets[HC] = @ModuleInfo.UnitHashArray[I] then + Buckets[HC] := ModuleInfo.UnitHashArray[I].Next; + end; + if ModuleInfo.UnitHashArray[I].Next <> nil then + ModuleInfo.UnitHashArray[I].Next.Prev := ModuleInfo.UnitHashArray[I].Prev; + end; + Dispose(ModuleInfo); + LibModule.Reserved := 0; + end; +end; + +function PackageInfoTable(Module: HMODULE): PPackageInfoHeader; +var + ResInfo: HRSRC; + Data: THandle; +begin + Result := nil; + ResInfo := FindResource(Module, 'PACKAGEINFO', RT_RCDATA); + if ResInfo <> 0 then + begin + Data := LoadResource(Module, ResInfo); + if Data <> 0 then + try + Result := LockResource(Data); + UnlockResource(Data); + finally + FreeResource(Data); + end; + end; +end; + +function GetModuleName(Module: HMODULE): string; +var + ModName: array[0..MAX_PATH] of Char; +begin + SetString(Result, ModName, GetModuleFileName(Module, ModName, SizeOf(ModName))); +end; + +procedure CheckForDuplicateUnits(Module: HMODULE; AValidatePackage: TValidatePackageProc); +var + ModuleFlags: Cardinal; + + function IsUnitPresent(UnitName: PChar; HashCode: Byte; Module: HMODULE; + const Buckets: TUnitHashBuckets; const ModuleName: string; + var UnitPackage: string): Boolean; + var + HashEntry: PUnitHashEntry; + begin + Result := True; + if (StrIComp(UnitName, 'SysInit') <> 0) and + (StrIComp(UnitName, PChar(ModuleName)) <> 0) then + begin + HashEntry := Buckets[HashCode]; + while HashEntry <> nil do + begin + if (HashEntry.DupsAllowed = (ModuleFlags and pfIgnoreDupUnits <> 0)) and + (StrIComp(UnitName, HashEntry.UnitName) = 0) then + begin + UnitPackage := ChangeFileExt(ExtractFileName( + GetModuleName(HMODULE(HashEntry.LibModule.Instance))), ''); + Exit; + end; + HashEntry := HashEntry.Next; + end; + end; + Result := False; + end; + + procedure InternalUnitCheck(Module: HModule); + var + I, J: Integer; + InfoTable: PPackageInfoHeader; + UnitPackage: string; + ModuleName: string; + PkgName: PPkgName; + UName: PUnitName; + Count: Integer; + LibModule: PLibModule; + Validated: Boolean; + HC: Byte; + ModuleInfo: PModuleInfo; + Buckets: ^TUnitHashBuckets; + begin + InfoTable := PackageInfoTable(Module); + if (InfoTable <> nil) and (InfoTable.Flags and pfModuleTypeMask = pfPackageModule) then + begin + if ModuleFlags = 0 then ModuleFlags := InfoTable.Flags; + LibModule := FindLibModule(Module); + if (LibModule <> nil) and (LibModule.Reserved <> 0) then + Exit; + Validated := Assigned(AValidatePackage) and AValidatePackage(Module); + ModuleName := ChangeFileExt(ExtractFileName(GetModuleName(Module)), ''); + PkgName := PPkgName(Integer(InfoTable) + SizeOf(InfoTable^)); + Count := InfoTable.RequiresCount; + for I := 0 to Count - 1 do + begin + with PkgName^ do +{$IFDEF MSWINDOWS} + InternalUnitCheck(GetModuleHandle(PChar(ChangeFileExt(Name, '.bpl')))); +{$ENDIF} +{$IFDEF LINUX} + InternalUnitCheck(GetModuleHandle(Name)); +{$ENDIF} + Inc(Integer(PkgName), StrLen(PkgName.Name) + 2); + end; + Count := Integer(Pointer(PkgName)^); + UName := PUnitName(Integer(PkgName) + 4); + if LibModule <> nil then + begin + New(ModuleInfo); + ModuleInfo.Validated := Validated; + if Validated then + Buckets := @ValidatedUnitHashBuckets + else + Buckets := @UnitHashBuckets; + LibModule.Reserved := Integer(ModuleInfo); + // don't include SysInit; + SetLength(ModuleInfo.UnitHashArray, Count - 1); + J := 0; + for I := 0 to Count - 1 do + begin + with UName^ do + // Test Flags to ignore weak package units + if (StrIComp(Name, 'SysInit') <> 0) and (Flags and ufWeakPackageUnit = 0) then + begin + HC := HashName(UName.Name); + // Always check against the unvalidated packages + if IsUnitPresent(Name, HC, Module, UnitHashBuckets, ModuleName, UnitPackage) or + // if the package is not validateed also check it against the validated ones + (not Validated and IsUnitPresent(Name, HC, Module, ValidatedUnitHashBuckets, ModuleName, UnitPackage)) then + raise EPackageError.CreateResFmt(@SDuplicatePackageUnit, [ModuleName, Name, UnitPackage]); + ModuleInfo.UnitHashArray[J].UnitName := @UName.Name; + ModuleInfo.UnitHashArray[J].LibModule := LibModule; + ModuleInfo.UnitHashArray[J].DupsAllowed := InfoTable.Flags and pfIgnoreDupUnits <> 0; + ModuleInfo.UnitHashArray[J].Prev := nil; + ModuleInfo.UnitHashArray[J].Next := Buckets[HC]; + Buckets[HC] := @ModuleInfo.UnitHashArray[J]; + if ModuleInfo.UnitHashArray[J].Next <> nil then + ModuleInfo.UnitHashArray[J].Next.Prev := Buckets[HC]; + Inc(J); + end; + Inc(Integer(UName), StrLen(UName.Name) + 3); + end; + end; + end; + end; + +begin + InitCharHash; + ModuleFlags := 0; + InternalUnitCheck(Module); +end; + +{$IFDEF LINUX} +function LoadLibrary(ModuleName: PChar): HMODULE; +begin + Result := HMODULE(dlopen(ModuleName, RTLD_LAZY)); +end; + +function FreeLibrary(Module: HMODULE): LongBool; +begin + Result := LongBool(dlclose(Pointer(Module))); +end; + +function GetProcAddress(Module: HMODULE; Proc: PChar): Pointer; +var + Info: TDLInfo; + Error: PChar; + ModHandle: HMODULE; +begin + // dlsym doesn't clear the error state when the function succeeds + dlerror; + Result := dlsym(Pointer(Module), Proc); + Error := dlerror; + if Error <> nil then + Result := nil + else if dladdr(Result, Info) <> 0 then + begin +{ In glibc 2.1.3 and earlier, dladdr returns a nil dli_fname + for addresses in the main program file. In glibc 2.1.91 and + later, dladdr fills in the dli_fname for addresses in the + main program file, but dlopen will segfault when given + the main program file name. + Workaround: Check the symbol base address against the main + program file's base address, and only call dlopen with a nil + filename to get the module name of the main program. } + + if Info.dli_fbase = ExeBaseAddress then + Info.dli_fname := nil; + + ModHandle := HMODULE(dlopen(Info.dli_fname, RTLD_LAZY)); + if ModHandle <> 0 then + begin + dlclose(Pointer(ModHandle)); + if ModHandle <> Module then + Result := nil; + end; + end else Result := nil; +end; + +type + plink_map = ^link_map; + link_map = record + l_addr: Pointer; + l_name: PChar; + l_ld: Pointer; + l_next, l_prev: plink_map; + end; + + pr_debug = ^r_debug; + r_debug = record + r_version: Integer; + r_map: plink_map; + r_brk: Pointer; + r_state: Integer; + r_ldbase: Pointer; + end; + +var + _r_debug: pr_debug = nil; + +function ScanLinkMap(Func: Pointer): plink_map; +var + linkmap: plink_map; + + function Eval(linkmap: plink_map; Func: Pointer): Boolean; + asm +// MOV ECX,[EBP] + PUSH EBP + CALL EDX + POP ECX + end; + +begin + if _r_debug = nil then + _r_debug := dlsym(RTLD_DEFAULT, '_r_debug'); + if _r_debug = nil then + begin + Assert(False, 'Unable to locate ''_r_debug'' symbol'); // do not localize + Result := nil; + Exit; + end; + linkmap := _r_debug.r_map; + while linkmap <> nil do + begin + if not Eval(linkmap, Func) then Break; + linkmap := linkmap.l_next; + end; + Result := linkmap; +end; + +function InitModule(linkmap: plink_map): HMODULE; +begin + if linkmap <> nil then + begin + Result := HMODULE(dlopen(linkmap.l_name, RTLD_LAZY)); + if Result <> 0 then + dlclose(Pointer(Result)); + end else Result := 0; +end; + +function GetModuleHandle(ModuleName: PChar): HMODULE; + + function CheckModuleName(linkmap: plink_map): Boolean; + var + BaseName: PChar; + begin + Result := True; + if ((ModuleName = nil) and ((linkmap.l_name = nil) or (linkmap.l_name[0] = #0))) or + ((ModuleName[0] = PathDelim) and (StrComp(ModuleName, linkmap.l_name) = 0)) then + begin + Result := False; + Exit; + end else + begin + // Locate the start of the actual filename + BaseName := StrRScan(linkmap.l_name, PathDelim); + if BaseName = nil then + BaseName := linkmap.l_name + else Inc(BaseName); // The filename is actually located at BaseName+1 + if StrComp(ModuleName, BaseName) = 0 then + begin + Result := False; + Exit; + end; + end; + end; + +begin + Result := InitModule(ScanLinkMap(@CheckModuleName)); +end; + +function GetPackageModuleHandle(PackageName: PChar): HMODULE; +var + PkgName: array[0..MAX_PATH] of Char; + + function CheckPackageName(linkmap: plink_map): Boolean; + var + BaseName: PChar; + begin + Result := True; + if linkmap.l_name <> nil then + begin + // Locate the start of the actual filename + BaseName := StrRScan(linkmap.l_name, PathDelim); + if BaseName = nil then + BaseName := linkmap.l_name // If there is no path info, just use the whole name + else Inc(BaseName); // The filename is actually located at BaseName+1 + Result := StrPos(BaseName, PkgName) = nil; + end; + end; + + procedure MakePkgName(Prefix, Name: PChar); + begin + StrCopy(PkgName, Prefix); + StrLCat(PkgName, Name, sizeof(PkgName)-1); + PkgName[High(PkgName)] := #0; + end; + +begin + if (PackageName = nil) or (StrScan(PackageName, PathDelim) <> nil) then + Result := 0 + else + begin + MakePkgName('bpl', PackageName); // First check the default prefix + Result := InitModule(ScanLinkMap(@CheckPackageName)); + if Result = 0 then + begin + MakePkgName('dcl', PackageName); // Next check the design-time prefix + Result := InitModule(ScanLinkMap(@CheckPackageName)); + if Result = 0 then + begin + MakePkgName('', PackageName); // finally check without a prefix + Result := InitModule(ScanLinkMap(@CheckPackageName)); + end; + end; + end; +end; + +{$ENDIF} + +{$IFDEF MSWINDOWS} +procedure Sleep; external kernel32 name 'Sleep'; stdcall; +{$ENDIF} +{$IFDEF LINUX} +procedure Sleep(milliseconds: Cardinal); +begin + usleep(milliseconds * 1000); // usleep is in microseconds +end; +{$ENDIF} + +{ InitializePackage } + +procedure InitializePackage(Module: HMODULE); +begin + InitializePackage(Module, nil); +end; + +procedure InitializePackage(Module: HMODULE; AValidatePackage: TValidatePackageProc); +type + TPackageLoad = procedure; +var + PackageLoad: TPackageLoad; +begin + CheckForDuplicateUnits(Module, AValidatePackage); + @PackageLoad := GetProcAddress(Module, 'Initialize'); //Do not localize + if Assigned(PackageLoad) then + PackageLoad + else + raise EPackageError.CreateFmt(sInvalidPackageFile, [GetModuleName(Module)]); +end; + +{ FinalizePackage } + +procedure FinalizePackage(Module: HMODULE); +type + TPackageUnload = procedure; +var + PackageUnload: TPackageUnload; +begin + @PackageUnload := GetProcAddress(Module, 'Finalize'); //Do not localize + if Assigned(PackageUnload) then + PackageUnload + else + raise EPackageError.CreateRes(@sInvalidPackageHandle); +end; + +{ LoadPackage } + +function LoadPackage(const Name: string): HMODULE; +begin + Result := LoadPackage(Name, nil); +end; + +function LoadPackage(const Name: string; AValidatePackage: TValidatePackageProc): HMODULE; +{$IFDEF LINUX} +var + DLErrorMsg: string; +{$ENDIF} +begin +{$IFDEF MSWINDOWS} + Result := SafeLoadLibrary(Name); +{$ENDIF} +{$IFDEF LINUX} + Result := HMODULE(dlOpen(PChar(Name), PkgLoadingMode)); +{$ENDIF} + if Result = 0 then + begin +{$IFDEF LINUX} + DLErrorMsg := dlerror; +{$ENDIF} + raise EPackageError.CreateResFmt(@sErrorLoadingPackage, + [Name, + {$IFDEF MSWINDOWS}SysErrorMessage(GetLastError){$ENDIF} + {$IFDEF LINUX}DLErrorMsg{$ENDIF}]); + end; + try + InitializePackage(Result, AValidatePackage); + except +{$IFDEF MSWINDOWS} + FreeLibrary(Result); +{$ENDIF} +{$IFDEF LINUX} + dlclose(Pointer(Result)); +{$ENDIF} + raise; + end; +end; + +{ UnloadPackage } + +procedure UnloadPackage(Module: HMODULE); +begin + FinalizePackage(Module); +{$IFDEF MSWINDOWS} + FreeLibrary(Module); +{$ENDIF} +{$IFDEF LINUX} + dlclose(Pointer(Module)); + InvalidateModuleCache; +{$ENDIF} +end; + +{ GetPackageInfo } + +procedure GetPackageInfo(Module: HMODULE; Param: Pointer; var Flags: Integer; + InfoProc: TPackageInfoProc); +var + InfoTable: PPackageInfoHeader; + I: Integer; + PkgName: PPkgName; + UName: PUnitName; + Count: Integer; +begin + InfoTable := PackageInfoTable(Module); + if not Assigned(InfoTable) then + raise EPackageError.CreateFmt(SCannotReadPackageInfo, + [ExtractFileName(GetModuleName(Module))]); + Flags := InfoTable.Flags; + with InfoTable^ do + begin + PkgName := PPkgName(Integer(InfoTable) + SizeOf(InfoTable^)); + Count := RequiresCount; + for I := 0 to Count - 1 do + begin + InfoProc(PkgName.Name, ntRequiresPackage, 0, Param); + Inc(Integer(PkgName), StrLen(PkgName.Name) + 2); + end; + Count := Integer(Pointer(PkgName)^); + UName := PUnitName(Integer(PkgName) + 4); + for I := 0 to Count - 1 do + begin + InfoProc(UName.Name, ntContainsUnit, UName.Flags, Param); + Inc(Integer(UName), StrLen(UName.Name) + 3); + end; + if Flags and pfPackageModule <> 0 then + begin + PkgName := PPkgName(UName); + InfoProc(PkgName.Name, ntDcpBpiName, 0, Param); + end; + end; +end; + +function GetPackageDescription(ModuleName: PChar): string; +var + ResModule: HMODULE; + ResInfo: HRSRC; + ResData: HGLOBAL; + NeedFreeLibrary: Boolean; +{$IFDEF LINUX} + DLErrorMsg: string; +{$ENDIF} +begin + Result := ''; + NeedFreeLibrary := True; + ResModule := LoadResourceModule(ModuleName); + if ResModule = 0 then + begin +{$IFDEF MSWINDOWS} + ResModule := GetModuleHandle(ModuleName); + if ResModule = 0 then + ResModule := LoadLibraryEx(ModuleName, 0, LOAD_LIBRARY_AS_DATAFILE) + else + NeedFreeLibrary := False; +{$ENDIF} +{$IFDEF LINUX} + ResModule := HMODULE(dlopen(ModuleName, RTLD_LAZY)); +{$ENDIF} + if ResModule = 0 then + begin +{$IFDEF LINUX} + DLErrorMsg := dlerror; +{$ENDIF} + raise EPackageError.CreateResFmt(@sErrorLoadingPackage, + [ModuleName, + {$IFDEF MSWINDOWS}SysErrorMessage(GetLastError){$ENDIF} + {$IFDEF LINUX}DLErrorMsg{$ENDIF}]); + end; + end; + try + ResInfo := FindResource(ResModule, 'DESCRIPTION', RT_RCDATA); + if ResInfo <> 0 then + begin + ResData := LoadResource(ResModule, ResInfo); + if ResData <> 0 then + try + Result := PWideChar(LockResource(ResData)); + UnlockResource(ResData); + finally + FreeResource(ResData); + end; + end; + finally +{$IFDEF MSWINDOWS} + if NeedFreeLibrary then + FreeLibrary(ResModule); +{$ENDIF} +{$IFDEF LINUX} + dlclose(Pointer(ResModule)); +{$ENDIF} + end; +end; + +procedure RaiseLastOSError; +begin + RaiseLastOSError(GetLastError); +end; + +procedure RaiseLastOSError(LastError: Integer); +var + Error: EOSError; +begin + if LastError <> 0 then + Error := EOSError.CreateResFmt(@SOSError, [LastError, + SysErrorMessage(LastError)]) + else + Error := EOSError.CreateRes(@SUnkOSError); + Error.ErrorCode := LastError; + raise Error; +end; + +{$IFDEF MSWINDOWS} +{ RaiseLastWin32Error } + +procedure RaiseLastWin32Error; +begin + RaiseLastOSError; +end; + +{ Win32Check } + +function Win32Check(RetVal: BOOL): BOOL; +begin + if not RetVal then RaiseLastOSError; + Result := RetVal; +end; +{$ENDIF} + +type + PTerminateProcInfo = ^TTerminateProcInfo; + TTerminateProcInfo = record + Next: PTerminateProcInfo; + Proc: TTerminateProc; + end; + +var + TerminateProcList: PTerminateProcInfo = nil; + +procedure AddTerminateProc(TermProc: TTerminateProc); +var + P: PTerminateProcInfo; +begin + New(P); + P^.Next := TerminateProcList; + P^.Proc := TermProc; + TerminateProcList := P; +end; + +function CallTerminateProcs: Boolean; +var + PI: PTerminateProcInfo; +begin + Result := True; + PI := TerminateProcList; + while Result and (PI <> nil) do + begin + Result := PI^.Proc; + PI := PI^.Next; + end; +end; + +procedure FreeTerminateProcs; +var + PI: PTerminateProcInfo; +begin + while TerminateProcList <> nil do + begin + PI := TerminateProcList; + TerminateProcList := PI^.Next; + Dispose(PI); + end; +end; + +{ --- } +function AL1(const P): LongWord; +asm + MOV EDX,DWORD PTR [P] + XOR EDX,DWORD PTR [P+4] + XOR EDX,DWORD PTR [P+8] + XOR EDX,DWORD PTR [P+12] + MOV EAX,EDX +end; + +function AL2(const P): LongWord; +asm + MOV EDX,DWORD PTR [P] + ROR EDX,5 + XOR EDX,DWORD PTR [P+4] + ROR EDX,5 + XOR EDX,DWORD PTR [P+8] + ROR EDX,5 + XOR EDX,DWORD PTR [P+12] + MOV EAX,EDX +end; + +const + AL1s: array[0..3] of LongWord = ($FFFFFFF0, $FFFFEBF0, 0, $FFFFFFFF); + AL2s: array[0..3] of LongWord = ($42C3ECEF, $20F7AEB6, $D1C2F74E, $3F6574DE); + +procedure ALV; +begin + raise Exception.CreateRes(@SNL); +end; + +function ALR: Pointer; +var + LibModule: PLibModule; +begin + if MainInstance <> 0 then + Result := Pointer(LoadResource(MainInstance, FindResource(MainInstance, 'DVCLAL', + RT_RCDATA))) + else + begin + Result := nil; + LibModule := LibModuleList; + while LibModule <> nil do + begin + with LibModule^ do + begin + Result := Pointer(LoadResource(Instance, FindResource(Instance, 'DVCLAL', + RT_RCDATA))); + if Result <> nil then Break; + end; + LibModule := LibModule.Next; + end; + end; +end; + +function GDAL: LongWord; +type + TDVCLAL = array[0..3] of LongWord; + PDVCLAL = ^TDVCLAL; +var + P: Pointer; + A1, A2: LongWord; + PAL1s, PAL2s: PDVCLAL; + ALOK: Boolean; +begin + P := ALR; + if P <> nil then + begin + A1 := AL1(P^); + A2 := AL2(P^); + Result := A1; + PAL1s := @AL1s; + PAL2s := @AL2s; + ALOK := ((A1 = PAL1s[0]) and (A2 = PAL2s[0])) or + ((A1 = PAL1s[1]) and (A2 = PAL2s[1])) or + ((A1 = PAL1s[2]) and (A2 = PAL2s[2])); + FreeResource(Integer(P)); + if not ALOK then ALV; + end else Result := AL1s[3]; +end; + +procedure RCS; +var + P: Pointer; + ALOK: Boolean; +begin + P := ALR; + if P <> nil then + begin + ALOK := (AL1(P^) = AL1s[2]) and (AL2(P^) = AL2s[2]); + FreeResource(Integer(P)); + end else ALOK := False; + if not ALOK then ALV; +end; + +procedure RPR; +var + AL: LongWord; +begin + AL := GDAL; + if (AL <> AL1s[1]) and (AL <> AL1s[2]) then ALV; +end; + +{$IFDEF MSWINDOWS} +procedure InitDriveSpacePtr; +var + Kernel: THandle; +begin + Kernel := GetModuleHandle(Windows.Kernel32); + if Kernel <> 0 then + @GetDiskFreeSpaceEx := GetProcAddress(Kernel, 'GetDiskFreeSpaceExA'); + if not Assigned(GetDiskFreeSpaceEx) then + GetDiskFreeSpaceEx := @BackfillGetDiskFreeSpaceEx; +end; +{$ENDIF} + +// Win95 does not return the actual value of the result. +// These implementations are consistent on all platforms. +function InterlockedIncrement(var I: Integer): Integer; +asm + MOV EDX,1 + XCHG EAX,EDX + LOCK XADD [EDX],EAX + INC EAX +end; + +function InterlockedDecrement(var I: Integer): Integer; +asm + MOV EDX,-1 + XCHG EAX,EDX + LOCK XADD [EDX],EAX + DEC EAX +end; + +function InterlockedExchange(var A: Integer; B: Integer): Integer; +asm + XCHG [EAX],EDX + MOV EAX,EDX +end; + +// The InterlockedExchangeAdd Win32 API is not available on Win95. +function InterlockedExchangeAdd(var A: Integer; B: Integer): Integer; +asm + XCHG EAX,EDX + LOCK XADD [EDX],EAX +end; + + +{ TSimpleRWSync } + +constructor TSimpleRWSync.Create; +begin + inherited Create; + InitializeCriticalSection(FLock); +end; + +destructor TSimpleRWSync.Destroy; +begin + inherited Destroy; + DeleteCriticalSection(FLock); +end; + +function TSimpleRWSync.BeginWrite: Boolean; +begin + EnterCriticalSection(FLock); + Result := True; +end; + +procedure TSimpleRWSync.EndWrite; +begin + LeaveCriticalSection(FLock); +end; + +procedure TSimpleRWSync.BeginRead; +begin + EnterCriticalSection(FLock); +end; + +procedure TSimpleRWSync.EndRead; +begin + LeaveCriticalSection(FLock); +end; + +{ TThreadLocalCounter } + +const + Alive = High(Integer); + +destructor TThreadLocalCounter.Destroy; +var + P, Q: PThreadInfo; + I: Integer; +begin + for I := 0 to High(FHashTable) do + begin + P := FHashTable[I]; + FHashTable[I] := nil; + while P <> nil do + begin + Q := P; + P := P^.Next; + FreeMem(Q); + end; + end; + inherited Destroy; +end; + +function TThreadLocalCounter.HashIndex: Byte; +var + H: Word; +begin + H := Word(GetCurrentThreadID); + Result := (WordRec(H).Lo xor WordRec(H).Hi) and 15; +end; + +procedure TThreadLocalCounter.Open(var Thread: PThreadInfo); +var + P: PThreadInfo; + CurThread: Cardinal; + H: Byte; +begin + H := HashIndex; + CurThread := GetCurrentThreadID; + + P := FHashTable[H]; + while (P <> nil) and (P.ThreadID <> CurThread) do + P := P.Next; + + if P = nil then + begin + P := Recycle; + + if P = nil then + begin + P := PThreadInfo(AllocMem(sizeof(TThreadInfo))); + P.ThreadID := CurThread; + P.Active := Alive; + + // Another thread could start traversing the list between when we set the + // head to P and when we assign to P.Next. Initializing P.Next to point + // to itself will make others spin until we assign the tail to P.Next. + P.Next := P; + P.Next := PThreadInfo(InterlockedExchange(Integer(FHashTable[H]), Integer(P))); + end; + end; + Thread := P; +end; + +procedure TThreadLocalCounter.Close(var Thread: PThreadInfo); +begin + Thread := nil; +end; + +procedure TThreadLocalCounter.Delete(var Thread: PThreadInfo); +begin + Thread.ThreadID := 0; + Thread.Active := 0; +end; + +function TThreadLocalCounter.Recycle: PThreadInfo; +var + Gen: Integer; +begin + Result := FHashTable[HashIndex]; + while (Result <> nil) do + begin + Gen := InterlockedExchange(Result.Active, Alive); + if Gen <> Alive then + begin + Result.ThreadID := GetCurrentThreadID; + Exit; + end + else + Result := Result.Next; + end; +end; + + +{$IFDEF MSWINDOWS} +{ TMultiReadExclusiveWriteSynchronizer } +const + mrWriteRequest = $FFFF; // 65535 concurrent read requests (threads) + // 32768 concurrent write requests (threads) + // only one write lock at a time + // 2^32 lock recursions per thread (read and write combined) + +constructor TMultiReadExclusiveWriteSynchronizer.Create; +begin + inherited Create; + FSentinel := mrWriteRequest; + FReadSignal := CreateEvent(nil, True, True, nil); // manual reset, start signaled + FWriteSignal := CreateEvent(nil, False, False, nil); // auto reset, start blocked + FWaitRecycle := INFINITE; + tls := TThreadLocalCounter.Create; +end; + +destructor TMultiReadExclusiveWriteSynchronizer.Destroy; +begin + BeginWrite; + inherited Destroy; + CloseHandle(FReadSignal); + CloseHandle(FWriteSignal); + tls.Free; +end; + +procedure TMultiReadExclusiveWriteSynchronizer.BlockReaders; +begin + ResetEvent(FReadSignal); +end; + +procedure TMultiReadExclusiveWriteSynchronizer.UnblockReaders; +begin + SetEvent(FReadSignal); +end; + +procedure TMultiReadExclusiveWriteSynchronizer.UnblockOneWriter; +begin + SetEvent(FWriteSignal); +end; + +procedure TMultiReadExclusiveWriteSynchronizer.WaitForReadSignal; +begin + WaitForSingleObject(FReadSignal, FWaitRecycle); +end; + +procedure TMultiReadExclusiveWriteSynchronizer.WaitForWriteSignal; +begin + WaitForSingleObject(FWriteSignal, FWaitRecycle); +end; + +{$IFDEF DEBUG_MREWS} +var + x: Integer; + +procedure TMultiReadExclusiveWriteSynchronizer.Debug(const Msg: string); +begin + OutputDebugString(PChar(Format('%d %s Thread=%x Sentinel=%d, FWriterID=%x', + [InterlockedIncrement(x), Msg, GetCurrentThreadID, FSentinel, FWriterID]))); +end; +{$ENDIF} + +function TMultiReadExclusiveWriteSynchronizer.BeginWrite: Boolean; +var + Thread: PThreadInfo; + HasReadLock: Boolean; + ThreadID: Cardinal; + Test: Integer; + OldRevisionLevel: Cardinal; +begin + { + States of FSentinel (roughly - during inc/dec's, the states may not be exactly what is said here): + mrWriteRequest: A reader or a writer can get the lock + 1 - (mrWriteRequest-1): A reader (possibly more than one) has the lock + 0: A writer (possibly) just got the lock, if returned from the main write While loop + < 0, but not a multiple of mrWriteRequest: Writer(s) want the lock, but reader(s) have it. + New readers should be blocked, but current readers should be able to call BeginRead + < 0, but a multiple of mrWriteRequest: Writer(s) waiting for a writer to finish + } + + +{$IFDEF DEBUG_MREWS} + Debug('Write enter------------------------------------'); +{$ENDIF} + Result := True; + ThreadID := GetCurrentThreadID; + if FWriterID <> ThreadID then // somebody or nobody has a write lock + begin + // Prevent new readers from entering while we wait for the existing readers + // to exit. + BlockReaders; + + OldRevisionLevel := FRevisionLevel; + + tls.Open(Thread); + // We have another lock already. It must be a read lock, because if it + // were a write lock, FWriterID would be our threadid. + HasReadLock := Thread.RecursionCount > 0; + + if HasReadLock then // acquiring a write lock requires releasing read locks + InterlockedIncrement(FSentinel); + +{$IFDEF DEBUG_MREWS} + Debug('Write before loop'); +{$ENDIF} + // InterlockedExchangeAdd returns prev value + while InterlockedExchangeAdd(FSentinel, -mrWriteRequest) <> mrWriteRequest do + begin +{$IFDEF DEBUG_MREWS} + Debug('Write loop'); + Sleep(1000); // sleep to force / debug race condition + Debug('Write loop2a'); +{$ENDIF} + + // Undo what we did, since we didn't get the lock + Test := InterlockedExchangeAdd(FSentinel, mrWriteRequest); + // If the old value (in Test) was 0, then we may be able to + // get the lock (because it will now be mrWriteRequest). So, + // we continue the loop to find out. Otherwise, we go to sleep, + // waiting for a reader or writer to signal us. + + if Test <> 0 then + begin + {$IFDEF DEBUG_MREWS} + Debug('Write starting to wait'); + {$ENDIF} + WaitForWriteSignal; + end + {$IFDEF DEBUG_MREWS} + else + Debug('Write continue') + {$ENDIF} + end; + + // At the EndWrite, first Writers are awoken, and then Readers are awoken. + // If a Writer got the lock, we don't want the readers to do busy + // waiting. This Block resets the event in case the situation happened. + BlockReaders; + + // Put our read lock marker back before we lose track of it + if HasReadLock then + InterlockedDecrement(FSentinel); + + FWriterID := ThreadID; + + Result := Integer(OldRevisionLevel) = (InterlockedIncrement(Integer(FRevisionLevel)) - 1); + end; + + Inc(FWriteRecursionCount); +{$IFDEF DEBUG_MREWS} + Debug('Write lock-----------------------------------'); +{$ENDIF} +end; + +procedure TMultiReadExclusiveWriteSynchronizer.EndWrite; +var + Thread: PThreadInfo; +begin +{$IFDEF DEBUG_MREWS} + Debug('Write end'); +{$ENDIF} + assert(FWriterID = GetCurrentThreadID); + tls.Open(Thread); + Dec(FWriteRecursionCount); + if FWriteRecursionCount = 0 then + begin + FWriterID := 0; + InterlockedExchangeAdd(FSentinel, mrWriteRequest); + {$IFDEF DEBUG_MREWS} + Debug('Write about to UnblockOneWriter'); + {$ENDIF} + UnblockOneWriter; + {$IFDEF DEBUG_MREWS} + Debug('Write about to UnblockReaders'); + {$ENDIF} + UnblockReaders; + end; + if Thread.RecursionCount = 0 then + tls.Delete(Thread); +{$IFDEF DEBUG_MREWS} + Debug('Write unlock'); +{$ENDIF} +end; + +procedure TMultiReadExclusiveWriteSynchronizer.BeginRead; +var + Thread: PThreadInfo; + WasRecursive: Boolean; + SentValue: Integer; +begin +{$IFDEF DEBUG_MREWS} + Debug('Read enter'); +{$ENDIF} + + tls.Open(Thread); + Inc(Thread.RecursionCount); + WasRecursive := Thread.RecursionCount > 1; + + if FWriterID <> GetCurrentThreadID then + begin +{$IFDEF DEBUG_MREWS} + Debug('Trying to get the ReadLock (we did not have a write lock)'); +{$ENDIF} + // In order to prevent recursive Reads from causing deadlock, + // we need to always WaitForReadSignal if not recursive. + // This prevents unnecessarily decrementing the FSentinel, and + // then immediately incrementing it again. + if not WasRecursive then + begin + // Make sure we don't starve writers. A writer will + // always set the read signal when it is done, and it is initially on. + WaitForReadSignal; + while (InterlockedDecrement(FSentinel) <= 0) do + begin + {$IFDEF DEBUG_MREWS} + Debug('Read loop'); + {$ENDIF} + // Because the InterlockedDecrement happened, it is possible that + // other threads "think" we have the read lock, + // even though we really don't. If we are the last reader to do this, + // then SentValue will become mrWriteRequest + SentValue := InterlockedIncrement(FSentinel); + // So, if we did inc it to mrWriteRequest at this point, + // we need to signal the writer. + if SentValue = mrWriteRequest then + UnblockOneWriter; + + // This sleep below prevents starvation of writers + Sleep(0); + + {$IFDEF DEBUG_MREWS} + Debug('Read loop2 - waiting to be signaled'); + {$ENDIF} + WaitForReadSignal; + {$IFDEF DEBUG_MREWS} + Debug('Read signaled'); + {$ENDIF} + end; + end; + end; +{$IFDEF DEBUG_MREWS} + Debug('Read lock'); +{$ENDIF} +end; + +procedure TMultiReadExclusiveWriteSynchronizer.EndRead; +var + Thread: PThreadInfo; + Test: Integer; +begin +{$IFDEF DEBUG_MREWS} + Debug('Read end'); +{$ENDIF} + tls.Open(Thread); + Dec(Thread.RecursionCount); + if (Thread.RecursionCount = 0) then + begin + tls.Delete(Thread); + + // original code below commented out + if (FWriterID <> GetCurrentThreadID) then + begin + Test := InterlockedIncrement(FSentinel); + // It is possible for Test to be mrWriteRequest + // or, it can be = 0, if the write loops: + // Test := InterlockedExchangeAdd(FSentinel, mrWriteRequest) + mrWriteRequest; + // Did not get executed before this has called (the sleep debug makes it happen faster) + {$IFDEF DEBUG_MREWS} + Debug(Format('Read UnblockOneWriter may be called. Test=%d', [Test])); + {$ENDIF} + if Test = mrWriteRequest then + UnblockOneWriter + else if Test <= 0 then // We may have some writers waiting + begin + if (Test mod mrWriteRequest) = 0 then + UnblockOneWriter; // No more readers left (only writers) so signal one of them + end; + end; + end; +{$IFDEF DEBUG_MREWS} + Debug('Read unlock'); +{$ENDIF} +end; +{$ENDIF} //MSWINDOWS for TMultiReadExclusiveWriteSynchronizer + +procedure FreeAndNil(var Obj); +var + Temp: TObject; +begin + Temp := TObject(Obj); + Pointer(Obj) := nil; + Temp.Free; +end; + +{ Interface support routines } + +function Supports(const Instance: IInterface; const IID: TGUID; out Intf): Boolean; +begin + Result := (Instance <> nil) and (Instance.QueryInterface(IID, Intf) = 0); +end; + +function Supports(const Instance: TObject; const IID: TGUID; out Intf): Boolean; +var + LUnknown: IUnknown; +begin + Result := (Instance <> nil) and + ((Instance.GetInterface(IUnknown, LUnknown) and Supports(LUnknown, IID, Intf)) or + Instance.GetInterface(IID, Intf)); +end; + +function Supports(const Instance: IInterface; const IID: TGUID): Boolean; +var + Temp: IInterface; +begin + Result := Supports(Instance, IID, Temp); +end; + +function Supports(const Instance: TObject; const IID: TGUID): Boolean; +var + Temp: IInterface; +begin + Result := Supports(Instance, IID, Temp); +end; + +function Supports(const AClass: TClass; const IID: TGUID): Boolean; +begin + Result := AClass.GetInterfaceEntry(IID) <> nil; +end; + +{$IFDEF MSWINDOWS} +{ TLanguages } + +var + FTempLanguages: TLanguages; + +function EnumLocalesCallback(LocaleID: PChar): Integer; stdcall; +begin + Result := FTempLanguages.LocalesCallback(LocaleID); +end; + +{ Query the OS for information for a specified locale. Unicode version. Works correctly on Asian WinNT. } +function GetLocaleDataW(ID: LCID; Flag: DWORD): string; +var + Buffer: array[0..1023] of WideChar; +begin + Buffer[0] := #0; + GetLocaleInfoW(ID, Flag, Buffer, SizeOf(Buffer) div 2); + Result := Buffer; +end; + +{ Query the OS for information for a specified locale. ANSI Version. Works correctly on Asian Win95. } +function GetLocaleDataA(ID: LCID; Flag: DWORD): string; +var + Buffer: array[0..1023] of Char; +begin + Buffer[0] := #0; + SetString(Result, Buffer, GetLocaleInfoA(ID, Flag, Buffer, SizeOf(Buffer)) - 1); +end; + +{ Called for each supported locale. } +function TLanguages.LocalesCallback(LocaleID: PChar): Integer; stdcall; +var + AID: LCID; + ShortLangName: string; + GetLocaleDataProc: function (ID: LCID; Flag: DWORD): string; +begin + if Win32Platform = VER_PLATFORM_WIN32_NT then + GetLocaleDataProc := @GetLocaleDataW + else + GetLocaleDataProc := @GetLocaleDataA; + AID := StrToInt('$' + Copy(LocaleID, 5, 4)); + ShortLangName := GetLocaleDataProc(AID, LOCALE_SABBREVLANGNAME); + if ShortLangName <> '' then + begin + SetLength(FSysLangs, Length(FSysLangs) + 1); + with FSysLangs[High(FSysLangs)] do + begin + FName := GetLocaleDataProc(AID, LOCALE_SLANGUAGE); + FLCID := AID; + FExt := ShortLangName; + end; + end; + Result := 1; +end; + +constructor TLanguages.Create; +begin + inherited Create; + FTempLanguages := Self; + EnumSystemLocales(@EnumLocalesCallback, LCID_SUPPORTED); +end; + +function TLanguages.GetCount: Integer; +begin + Result := High(FSysLangs) + 1; +end; + +function TLanguages.GetExt(Index: Integer): string; +begin + Result := FSysLangs[Index].FExt; +end; + +function TLanguages.GetID(Index: Integer): string; +begin + Result := HexDisplayPrefix + IntToHex(FSysLangs[Index].FLCID, 8); +end; + +function TLanguages.GetLCID(Index: Integer): LCID; +begin + Result := FSysLangs[Index].FLCID; +end; + +function TLanguages.GetName(Index: Integer): string; +begin + Result := FSysLangs[Index].FName; +end; + +function TLanguages.GetNameFromLocaleID(ID: LCID): string; +var + Index: Integer; +begin + Result := sUnknown; + Index := IndexOf(ID); + if Index <> - 1 then Result := Name[Index]; + if Result = '' then Result := sUnknown; +end; + +function TLanguages.GetNameFromLCID(const ID: string): string; +begin + Result := NameFromLocaleID[StrToIntDef(ID, 0)]; +end; + +function TLanguages.IndexOf(ID: LCID): Integer; +begin + for Result := Low(FSysLangs) to High(FSysLangs) do + if FSysLangs[Result].FLCID = ID then Exit; + Result := -1; +end; + +var + FLanguages: TLanguages; + +function Languages: TLanguages; +begin + if FLanguages = nil then + FLanguages := TLanguages.Create; + Result := FLanguages; +end; + +function SafeLoadLibrary(const Filename: string; ErrorMode: UINT): HMODULE; +var + OldMode: UINT; + FPUControlWord: Word; +begin + OldMode := SetErrorMode(ErrorMode); + try + asm + FNSTCW FPUControlWord + end; + try + Result := LoadLibrary(PChar(Filename)); + finally + asm + FNCLEX + FLDCW FPUControlWord + end; + end; + finally + SetErrorMode(OldMode); + end; +end; +{$ENDIF} +{$IFDEF LINUX} +function SafeLoadLibrary(const FileName: string; Dummy: LongWord): HMODULE; +var + FPUControlWord: Word; +begin + asm + FNSTCW FPUControlWord + end; + try + Result := LoadLibrary(PChar(Filename)); + finally + asm + FNCLEX + FLDCW FPUControlWord + end; + end; +end; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function GetEnvironmentVariable(const Name: string): string; +const + BufSize = 1024; +var + Len: Integer; + Buffer: array[0..BufSize - 1] of Char; +begin + Result := ''; + Len := GetEnvironmentVariable(PChar(Name), @Buffer, BufSize); + if Len < BufSize then + SetString(Result, PChar(@Buffer), Len) + else + begin + SetLength(Result, Len - 1); + GetEnvironmentVariable(PChar(Name), PChar(Result), Len); + end; +end; +{$ENDIF} +{$IFDEF LINUX} +function GetEnvironmentVariable(const Name: string): string; +begin + Result := getenv(PChar(Name)); +end; +{$ENDIF} + +{$IFDEF LINUX} +procedure CheckLocale; +var + P,Q: PChar; +begin + P := gnu_get_libc_version(); + Q := getenv('LC_ALL'); + if (Q = nil) or (Q[0] = #0) then + Q := getenv('LANG'); + + // 2.1.3 <= current version < 2.1.91 + if (strverscmp('2.1.3', P) <= 0) and + (strverscmp(P, '2.1.91') < 0) and + ((Q = nil) or (Q[0] = #0)) then + begin + // GNU libc 2.1.3 will segfault in towupper() if environment variables don't + // specify a locale. This can happen when Apache launches CGI subprocesses. + // Solution: set a locale if the environment variable is missing. + // Works in 2.1.2, fixed in glibc 2.1.91 and later + setlocale(LC_ALL, 'POSIX'); + end + else + // Configure the process locale settings according to + // the system environment variables (LC_CTYPE, LC_COLLATE, etc) + setlocale(LC_ALL, ''); + + // Note: + // POSIX/C is the default locale on many Unix systems, but its 7-bit charset + // causes char to widechar conversions to fail on any high-ascii + // character. To support high-ascii charset conversions, set the + // LC_CTYPE environment variable to something else or call setlocale to set + // the LC_CTYPE information for this process. It doesn't matter what + // you set it to, as long as it's not POSIX. + if StrComp(nl_langinfo(_NL_CTYPE_CODESET_NAME), 'ANSI_X3.4-1968') = 0 then + setlocale(LC_CTYPE, 'en_US'); // selects codepage ISO-8859-1 +end; + +procedure PropagateSignals; +var + Exc: TObject; +begin + { + If there is a current exception pending, then we're shutting down because + it went unhandled. If that exception is the result of a signal, then we + need to propagate that back out to the world as a real signal death. See + the discussion at http://www2.cons.org/cracauer/sigint.html for more info. + } + Exc := ExceptObject; + if (Exc <> nil) and (Exc is EExternal) then + kill(getpid, EExternal(Exc).SignalNumber); +end; + +{ + Under Win32, SafeCallError is implemented in ComObj. Under Linux, we + don't have ComObj, so we've substituted a similar mechanism here. +} +procedure SafeCallError(ErrorCode: Integer; ErrorAddr: Pointer); +var + ExcMsg: String; +begin + ExcMsg := GetSafeCallExceptionMsg; + SetSafeCallExceptionMsg(''); + if ExcMsg <> '' then + begin + raise ESafeCallException.Create(ExcMsg) at GetSafeCallExceptionAddr; + end + else + raise ESafeCallException.CreateRes(@SSafecallException); +end; +{$ENDIF} + +procedure ClearHashTables; +var + Module: PLibModule; +begin + Module := LibModuleList; + while Module <> nil do + begin + if Module.Reserved <> 0 then + begin + Dispose(PModuleInfo(Module.Reserved)); + Module.Reserved := 0; + end; + Module := Module.Next; + end; +end; + +initialization + if ModuleIsCpp then HexDisplayPrefix := '0x'; + InitExceptions; + AddModuleUnloadProc(ModuleUnloaded); + +{$IFDEF LINUX} + SafeCallErrorProc := @SafeCallError; + ExitProcessProc := PropagateSignals; + + CheckLocale; +{$ENDIF} + +{$IFDEF MSWINDOWS} + InitPlatformId; + InitDriveSpacePtr; +{$ENDIF} + GetFormatSettings; { Win implementation uses platform id } + +finalization +{$IFDEF MSWINDOWS} + FreeAndNil(FLanguages); +{$ENDIF} +{$IFDEF LINUX} + if libuuidHandle <> nil then + dlclose(libuuidHandle); +{$ENDIF} + RemoveModuleUnloadProc(ModuleUnloaded); + ClearHashTables; + FreeTerminateProcs; + DoneExceptions; + +end. + diff --git a/System/D2006_orig/System.pas b/System/D2006_orig/System.pas new file mode 100644 index 0000000..e09c086 --- /dev/null +++ b/System/D2006_orig/System.pas @@ -0,0 +1,18852 @@ + +{ *********************************************************************** } +{ } +{ Delphi / Kylix Cross-Platform Runtime Library } +{ System Unit } +{ } +{ Copyright (c) 1988-2005 Borland Software Corporation } +{ } +{ Copyright and license exceptions noted in source } +{ } +{ *********************************************************************** } + +unit System; { Predefined constants, types, procedures, } + { and functions (such as True, Integer, or } + { Writeln) do not have actual declarations.} + { Instead they are built into the compiler } + { and are treated as if they were declared } + { at the beginning of the System unit. } + +{$H+,I-,R-,O+,W-} +{$WARN SYMBOL_PLATFORM OFF} +{$WARN UNSAFE_TYPE OFF} + +{ L- should never be specified. + + The IDE needs to find DebugHook (through the C++ + compiler sometimes) for integrated debugging to + function properly. + + ILINK will generate debug info for DebugHook if + the object module has not been compiled with debug info. + + ILINK will not generate debug info for DebugHook if + the object module has been compiled with debug info. + + Thus, the Pascal compiler must be responsible for + generating the debug information for that symbol + when a debug-enabled object file is produced. +} + +interface + +(* You can use RTLVersion in $IF expressions to test the runtime library + version level independently of the compiler version level. + Example: {$IF RTLVersion >= 16.2} ... {$IFEND} *) + +const + RTLVersion = 18.00; + +{$EXTERNALSYM CompilerVersion} + +(* +const + CompilerVersion = 0.0; + + CompilerVersion is assigned a value by the compiler when + the system unit is compiled. It indicates the revision level of the + compiler features / language syntax, which may advance independently of + the RTLVersion. CompilerVersion can be tested in $IF expressions and + should be used instead of testing for the VERxxx conditional define. + Always test for greater than or less than a known revision level. + It's a bad idea to test for a specific revision level. +*) + +{$IFDEF DECLARE_GPL} +(* The existence of the GPL symbol indicates that the System unit + and the rest of the Delphi runtime library were compiled for use + and distribution under the terms of the GNU General Public License (GPL). + Under the terms of the GPL, all applications compiled with the + GPL version of the Delphi runtime library must also be distributed + under the terms of the GPL. + For more information about the GNU GPL, see + http://www.gnu.org/copyleft/gpl.html + + The GPL symbol does not exist in the Delphi runtime library + purchased for commercial/proprietary software development. + + If your source code needs to know which licensing model it is being + compiled into, you can use {$IF DECLARED(GPL)}...{$IFEND} to + test for the existence of the GPL symbol. The value of the + symbol itself is not significant. *) + +const + GPL = True; +{$ENDIF} + +{ Variant type codes (wtypes.h) } + + varEmpty = $0000; { vt_empty 0 } + varNull = $0001; { vt_null 1 } + varSmallint = $0002; { vt_i2 2 } + varInteger = $0003; { vt_i4 3 } + varSingle = $0004; { vt_r4 4 } + varDouble = $0005; { vt_r8 5 } + varCurrency = $0006; { vt_cy 6 } + varDate = $0007; { vt_date 7 } + varOleStr = $0008; { vt_bstr 8 } + varDispatch = $0009; { vt_dispatch 9 } + varError = $000A; { vt_error 10 } + varBoolean = $000B; { vt_bool 11 } + varVariant = $000C; { vt_variant 12 } + varUnknown = $000D; { vt_unknown 13 } +//varDecimal = $000E; { vt_decimal 14 } {UNSUPPORTED as of v6.x code base} +//varUndef0F = $000F; { undefined 15 } {UNSUPPORTED per Microsoft} + varShortInt = $0010; { vt_i1 16 } + varByte = $0011; { vt_ui1 17 } + varWord = $0012; { vt_ui2 18 } + varLongWord = $0013; { vt_ui4 19 } + varInt64 = $0014; { vt_i8 20 } +//varWord64 = $0015; { vt_ui8 21 } {UNSUPPORTED as of v6.x code base} +{ if adding new items, update Variants' varLast, BaseTypeMap and OpTypeMap } + + varStrArg = $0048; { vt_clsid 72 } + varString = $0100; { Pascal string 256 } {not OLE compatible } + varAny = $0101; { Corba any 257 } {not OLE compatible } + // custom types range from $110 (272) to $7FF (2047) + + varTypeMask = $0FFF; + varArray = $2000; + varByRef = $4000; + +{ TVarRec.VType values } + + vtInteger = 0; + vtBoolean = 1; + vtChar = 2; + vtExtended = 3; + vtString = 4; + vtPointer = 5; + vtPChar = 6; + vtObject = 7; + vtClass = 8; + vtWideChar = 9; + vtPWideChar = 10; + vtAnsiString = 11; + vtCurrency = 12; + vtVariant = 13; + vtInterface = 14; + vtWideString = 15; + vtInt64 = 16; + +{ Virtual method table entries } + + vmtSelfPtr = -76; + vmtIntfTable = -72; + vmtAutoTable = -68; + vmtInitTable = -64; + vmtTypeInfo = -60; + vmtFieldTable = -56; + vmtMethodTable = -52; + vmtDynamicTable = -48; + vmtClassName = -44; + vmtInstanceSize = -40; + vmtParent = -36; + vmtSafeCallException = -32 deprecated; // don't use these constants. + vmtAfterConstruction = -28 deprecated; // use VMTOFFSET in asm code instead + vmtBeforeDestruction = -24 deprecated; + vmtDispatch = -20 deprecated; + vmtDefaultHandler = -16 deprecated; + vmtNewInstance = -12 deprecated; + vmtFreeInstance = -8 deprecated; + vmtDestroy = -4 deprecated; + + vmtQueryInterface = 0 deprecated; + vmtAddRef = 4 deprecated; + vmtRelease = 8 deprecated; + vmtCreateObject = 12 deprecated; + +type + + TObject = class; + + TClass = class of TObject; + + HRESULT = type Longint; { from WTYPES.H } + {$EXTERNALSYM HRESULT} + + PGUID = ^TGUID; + TGUID = packed record + D1: LongWord; + D2: Word; + D3: Word; + D4: array[0..7] of Byte; + end; + + PInterfaceEntry = ^TInterfaceEntry; + TInterfaceEntry = packed record + IID: TGUID; + VTable: Pointer; + IOffset: Integer; + ImplGetter: Integer; + end; + + PInterfaceTable = ^TInterfaceTable; + TInterfaceTable = packed record + EntryCount: Integer; + Entries: array[0..9999] of TInterfaceEntry; + end; + + TMethod = record + Code, Data: Pointer; + end; + +{ TObject.Dispatch accepts any data type as its Message parameter. The + first 2 bytes of the data are taken as the message id to search for + in the object's message methods. TDispatchMessage is an example of + such a structure with a word field for the message id. +} + TDispatchMessage = record + MsgID: Word; + end; + + TObject = class + constructor Create; + procedure Free; + class function InitInstance(Instance: Pointer): TObject; + procedure CleanupInstance; + function ClassType: TClass; + class function ClassName: ShortString; + class function ClassNameIs(const Name: string): Boolean; + class function ClassParent: TClass; + class function ClassInfo: Pointer; + class function InstanceSize: Longint; + class function InheritsFrom(AClass: TClass): Boolean; + class function MethodAddress(const Name: ShortString): Pointer; + class function MethodName(Address: Pointer): ShortString; + function FieldAddress(const Name: ShortString): Pointer; + function GetInterface(const IID: TGUID; out Obj): Boolean; + class function GetInterfaceEntry(const IID: TGUID): PInterfaceEntry; + class function GetInterfaceTable: PInterfaceTable; + function SafeCallException(ExceptObject: TObject; + ExceptAddr: Pointer): HResult; virtual; + procedure AfterConstruction; virtual; + procedure BeforeDestruction; virtual; + procedure Dispatch(var Message); virtual; + procedure DefaultHandler(var Message); virtual; + class function NewInstance: TObject; virtual; + procedure FreeInstance; virtual; + destructor Destroy; virtual; + end; + +const + S_OK = 0; {$EXTERNALSYM S_OK} + S_FALSE = $00000001; {$EXTERNALSYM S_FALSE} + E_NOINTERFACE = HRESULT($80004002); {$EXTERNALSYM E_NOINTERFACE} + E_UNEXPECTED = HRESULT($8000FFFF); {$EXTERNALSYM E_UNEXPECTED} + E_NOTIMPL = HRESULT($80004001); {$EXTERNALSYM E_NOTIMPL} + +type + IInterface = interface + ['{00000000-0000-0000-C000-000000000046}'] + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + end; + + IUnknown = IInterface; +{$M+} + IInvokable = interface(IInterface) + end; +{$M-} + + IDispatch = interface(IUnknown) + ['{00020400-0000-0000-C000-000000000046}'] + function GetTypeInfoCount(out Count: Integer): HResult; stdcall; + function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall; + function GetIDsOfNames(const IID: TGUID; Names: Pointer; + NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall; + function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; + Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall; + end; + +{$EXTERNALSYM IUnknown} +{$EXTERNALSYM IDispatch} + +{ TInterfacedObject provides a threadsafe default implementation + of IInterface. You should use TInterfaceObject as the base class + of objects implementing interfaces. } + + TInterfacedObject = class(TObject, IInterface) + protected + FRefCount: Integer; + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + public + procedure AfterConstruction; override; + procedure BeforeDestruction; override; + class function NewInstance: TObject; override; + property RefCount: Integer read FRefCount; + end; + + TInterfacedClass = class of TInterfacedObject; + +{ TAggregatedObject and TContainedObject are suitable base + classes for interfaced objects intended to be aggregated + or contained in an outer controlling object. When using + the "implements" syntax on an interface property in + an outer object class declaration, use these types + to implement the inner object. + + Interfaces implemented by aggregated objects on behalf of + the controller should not be distinguishable from other + interfaces provided by the controller. Aggregated objects + must not maintain their own reference count - they must + have the same lifetime as their controller. To achieve this, + aggregated objects reflect the reference count methods + to the controller. + + TAggregatedObject simply reflects QueryInterface calls to + its controller. From such an aggregated object, one can + obtain any interface that the controller supports, and + only interfaces that the controller supports. This is + useful for implementing a controller class that uses one + or more internal objects to implement the interfaces declared + on the controller class. Aggregation promotes implementation + sharing across the object hierarchy. + + TAggregatedObject is what most aggregate objects should + inherit from, especially when used in conjunction with + the "implements" syntax. } + + TAggregatedObject = class(TObject) + private + FController: Pointer; // weak reference to controller + function GetController: IInterface; + protected + { IInterface } + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + public + constructor Create(const Controller: IInterface); + property Controller: IInterface read GetController; + end; + + { TContainedObject is an aggregated object that isolates + QueryInterface on the aggregate from the controller. + TContainedObject will return only interfaces that the + contained object itself implements, not interfaces + that the controller implements. This is useful for + implementing nodes that are attached to a controller and + have the same lifetime as the controller, but whose + interface identity is separate from the controller. + You might do this if you don't want the consumers of + an aggregated interface to have access to other interfaces + implemented by the controller - forced encapsulation. + This is a less common case than TAggregatedObject. } + + TContainedObject = class(TAggregatedObject, IInterface) + protected + { IInterface } + function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall; + end; + + TClassHelperBase = class(TInterfacedObject, IInterface) + protected + FInstance: TObject; + constructor _Create(Instance: TObject); + end; + + PShortString = ^ShortString; + PAnsiString = ^AnsiString; + PWideString = ^WideString; + PString = PAnsiString; + + UCS2Char = WideChar; + PUCS2Char = PWideChar; + UCS4Char = type LongWord; + {$NODEFINE UCS4CHAR} + PUCS4Char = ^UCS4Char; + {$NODEFINE PUCS4CHAR} + TUCS4CharArray = array [0..$effffff] of UCS4Char; + PUCS4CharArray = ^TUCS4CharArray; + UCS4String = array of UCS4Char; + {$NODEFINE UCS4String} + + UTF8String = type string; + PUTF8String = ^UTF8String; + {$NODEFINE UTF8String} + {$NODEFINE PUTF8String} + + IntegerArray = array[0..$effffff] of Integer; + PIntegerArray = ^IntegerArray; + PointerArray = array [0..512*1024*1024 - 2] of Pointer; + PPointerArray = ^PointerArray; + TBoundArray = array of Integer; + TPCharArray = packed array[0..(MaxLongint div SizeOf(PChar))-1] of PChar; + PPCharArray = ^TPCharArray; + + (*$HPPEMIT 'namespace System' *) + (*$HPPEMIT '{' *) + (*$HPPEMIT ' typedef int *PLongint;' *) + (*$HPPEMIT '}' *) + PLongint = ^Longint; + {$EXTERNALSYM PLongint} + PInteger = ^Integer; + PCardinal = ^Cardinal; + PWord = ^Word; + PSmallInt = ^SmallInt; + PByte = ^Byte; + PShortInt = ^ShortInt; + PInt64 = ^Int64; + PLongWord = ^LongWord; + PSingle = ^Single; + PDouble = ^Double; + PDate = ^Double; + PDispatch = ^IDispatch; + PPDispatch = ^PDispatch; + PError = ^LongWord; + PWordBool = ^WordBool; + PUnknown = ^IUnknown; + PPUnknown = ^PUnknown; + {$NODEFINE PByte} + PPWideChar = ^PWideChar; + PPChar = ^PChar; + PPAnsiChar = PPChar; + PExtended = ^Extended; + PComp = ^Comp; + PCurrency = ^Currency; + PVariant = ^Variant; + POleVariant = ^OleVariant; + PPointer = ^Pointer; + PBoolean = ^Boolean; + + TDateTime = type Double; + PDateTime = ^TDateTime; + + THandle = LongWord; + + TVarArrayBound = packed record + ElementCount: Integer; + LowBound: Integer; + end; + TVarArrayBoundArray = array [0..0] of TVarArrayBound; + PVarArrayBoundArray = ^TVarArrayBoundArray; + TVarArrayCoorArray = array [0..0] of Integer; + PVarArrayCoorArray = ^TVarArrayCoorArray; + + PVarArray = ^TVarArray; + TVarArray = packed record + DimCount: Word; + Flags: Word; + ElementSize: Integer; + LockCount: Integer; + Data: Pointer; + Bounds: TVarArrayBoundArray; + end; + + TVarType = Word; + PVarData = ^TVarData; + {$EXTERNALSYM PVarData} + TVarData = packed record + case Integer of + 0: (VType: TVarType; + case Integer of + 0: (Reserved1: Word; + case Integer of + 0: (Reserved2, Reserved3: Word; + case Integer of + varSmallInt: (VSmallInt: SmallInt); + varInteger: (VInteger: Integer); + varSingle: (VSingle: Single); + varDouble: (VDouble: Double); + varCurrency: (VCurrency: Currency); + varDate: (VDate: TDateTime); + varOleStr: (VOleStr: PWideChar); + varDispatch: (VDispatch: Pointer); + varError: (VError: HRESULT); + varBoolean: (VBoolean: WordBool); + varUnknown: (VUnknown: Pointer); + varShortInt: (VShortInt: ShortInt); + varByte: (VByte: Byte); + varWord: (VWord: Word); + varLongWord: (VLongWord: LongWord); + varInt64: (VInt64: Int64); + varString: (VString: Pointer); + varAny: (VAny: Pointer); + varArray: (VArray: PVarArray); + varByRef: (VPointer: Pointer); + ); + 1: (VLongs: array[0..2] of LongInt); + ); + 2: (VWords: array [0..6] of Word); + 3: (VBytes: array [0..13] of Byte); + ); + 1: (RawData: array [0..3] of LongInt); + end; + {$EXTERNALSYM TVarData} + +type + TVarOp = Integer; + +const + opAdd = 0; + opSubtract = 1; + opMultiply = 2; + opDivide = 3; + opIntDivide = 4; + opModulus = 5; + opShiftLeft = 6; + opShiftRight = 7; + opAnd = 8; + opOr = 9; + opXor = 10; + opCompare = 11; + opNegate = 12; + opNot = 13; + + opCmpEQ = 14; + opCmpNE = 15; + opCmpLT = 16; + opCmpLE = 17; + opCmpGT = 18; + opCmpGE = 19; + + {The number of small block types employed by the default memory manager} + NumSmallBlockTypes = 55; + +type + { Dispatch call descriptor } + PCallDesc = ^TCallDesc; + TCallDesc = packed record + CallType: Byte; + ArgCount: Byte; + NamedArgCount: Byte; + ArgTypes: array[0..255] of Byte; + end; + + PDispDesc = ^TDispDesc; + TDispDesc = packed record + DispID: Integer; + ResType: Byte; + CallDesc: TCallDesc; + end; + + PVariantManager = ^TVariantManager; + {$EXTERNALSYM PVariantManager} + TVariantManager = record + VarClear: procedure(var V : Variant); + VarCopy: procedure(var Dest: Variant; const Source: Variant); + VarCopyNoInd: procedure; // ARGS PLEASE! + VarCast: procedure(var Dest: Variant; const Source: Variant; VarType: Integer); + VarCastOle: procedure(var Dest: Variant; const Source: Variant; VarType: Integer); + + VarToInt: function(const V: Variant): Integer; + VarToInt64: function(const V: Variant): Int64; + VarToBool: function(const V: Variant): Boolean; + VarToReal: function(const V: Variant): Extended; + VarToCurr: function(const V: Variant): Currency; + VarToPStr: procedure(var S; const V: Variant); + VarToLStr: procedure(var S: string; const V: Variant); + VarToWStr: procedure(var S: WideString; const V: Variant); + VarToIntf: procedure(var Unknown: IInterface; const V: Variant); + VarToDisp: procedure(var Dispatch: IDispatch; const V: Variant); + VarToDynArray: procedure(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer); + + VarFromInt: procedure(var V: Variant; const Value: Integer; const Range: ShortInt); + VarFromInt64: procedure(var V: Variant; const Value: Int64); + VarFromBool: procedure(var V: Variant; const Value: Boolean); + VarFromReal: procedure; // var V: Variant; const Value: Real + VarFromTDateTime: procedure; // var V: Variant; const Value: TDateTime + VarFromCurr: procedure; // var V: Variant; const Value: Currency + VarFromPStr: procedure(var V: Variant; const Value: ShortString); + VarFromLStr: procedure(var V: Variant; const Value: string); + VarFromWStr: procedure(var V: Variant; const Value: WideString); + VarFromIntf: procedure(var V: Variant; const Value: IInterface); + VarFromDisp: procedure(var V: Variant; const Value: IDispatch); + VarFromDynArray: procedure(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer); + OleVarFromPStr: procedure(var V: OleVariant; const Value: ShortString); + OleVarFromLStr: procedure(var V: OleVariant; const Value: string); + OleVarFromVar: procedure(var V: OleVariant; const Value: Variant); + OleVarFromInt: procedure(var V: OleVariant; const Value: Integer; const Range: ShortInt); + OleVarFromInt64: procedure(var V: OleVariant; const Value: Int64); + + VarOp: procedure(var Left: Variant; const Right: Variant; OpCode: TVarOp); + VarCmp: procedure(const Left, Right: TVarData; const OpCode: TVarOp); { result is set in the flags } + VarNeg: procedure(var V: Variant); + VarNot: procedure(var V: Variant); + + DispInvoke: procedure(Dest: PVarData; const Source: TVarData; + CallDesc: PCallDesc; Params: Pointer); cdecl; + VarAddRef: procedure(var V: Variant); + + VarArrayRedim: procedure(var A : Variant; HighBound: Integer); + VarArrayGet: function(var A: Variant; IndexCount: Integer; + Indices: Integer): Variant; cdecl; + VarArrayPut: procedure(var A: Variant; const Value: Variant; + IndexCount: Integer; Indices: Integer); cdecl; + + WriteVariant: function(var T: Text; const V: Variant; Width: Integer): Pointer; + Write0Variant: function(var T: Text; const V: Variant): Pointer; + end deprecated; + {$EXTERNALSYM TVariantManager} + + { Dynamic array support } + PDynArrayTypeInfo = ^TDynArrayTypeInfo; + {$EXTERNALSYM PDynArrayTypeInfo} + TDynArrayTypeInfo = packed record + kind: Byte; + name: string[0]; + elSize: Longint; + elType: ^PDynArrayTypeInfo; + varType: Integer; + end; + {$EXTERNALSYM TDynArrayTypeInfo} + + PVarRec = ^TVarRec; + TVarRec = record { do not pack this record; it is compiler-generated } + case Byte of + vtInteger: (VInteger: Integer; VType: Byte); + vtBoolean: (VBoolean: Boolean); + vtChar: (VChar: Char); + vtExtended: (VExtended: PExtended); + vtString: (VString: PShortString); + vtPointer: (VPointer: Pointer); + vtPChar: (VPChar: PChar); + vtObject: (VObject: TObject); + vtClass: (VClass: TClass); + vtWideChar: (VWideChar: WideChar); + vtPWideChar: (VPWideChar: PWideChar); + vtAnsiString: (VAnsiString: Pointer); + vtCurrency: (VCurrency: PCurrency); + vtVariant: (VVariant: PVariant); + vtInterface: (VInterface: Pointer); + vtWideString: (VWideString: Pointer); + vtInt64: (VInt64: PInt64); + end; + + {The old memory manager structure (for backward compatibility)} + PMemoryManager = ^TMemoryManager; + TMemoryManager = record + GetMem: function(Size: Integer): Pointer; + FreeMem: function(P: Pointer): Integer; + ReallocMem: function(P: Pointer; Size: Integer): Pointer; + end deprecated; + + {The new memory manager structure with expanded functionality} + PMemoryManagerEx = ^TMemoryManagerEx; + TMemoryManagerEx = record + {The basic (required) memory manager functionality} + GetMem: function(Size: Integer): Pointer; + FreeMem: function(P: Pointer): Integer; + ReallocMem: function(P: Pointer; Size: Integer): Pointer; + {Extended (optional) functionality.} + AllocMem: function(Size: Cardinal): Pointer; + RegisterExpectedMemoryLeak: function(P: Pointer): Boolean; + UnregisterExpectedMemoryLeak: function(P: Pointer): Boolean; + end; + + THeapStatus = record + TotalAddrSpace: Cardinal; + TotalUncommitted: Cardinal; + TotalCommitted: Cardinal; + TotalAllocated: Cardinal; + TotalFree: Cardinal; + FreeSmall: Cardinal; + FreeBig: Cardinal; + Unused: Cardinal; + Overhead: Cardinal; + HeapErrorCode: Cardinal; + end deprecated; + + TSmallBlockTypeState = packed record + {The internal size of the block type} + InternalBlockSize: Cardinal; + {Useable block size: The number of non-reserved bytes inside the block.} + UseableBlockSize: Cardinal; + {The number of allocated blocks} + AllocatedBlockCount: Cardinal; + {The total address space reserved for this block type (both allocated and + free blocks)} + ReservedAddressSpace: Cardinal; + end; + TSmallBlockTypeStates = array[0..NumSmallBlockTypes - 1] of TSmallBlockTypeState; + + {The structure returned by GetMemoryManagerState} + TMemoryManagerState = packed record + {Small block type states} + SmallBlockTypeStates: TSmallBlockTypeStates; + {Medium block stats} + AllocatedMediumBlockCount: Cardinal; + TotalAllocatedMediumBlockSize: Cardinal; + ReservedMediumBlockAddressSpace: Cardinal; + {Large block stats} + AllocatedLargeBlockCount: Cardinal; + TotalAllocatedLargeBlockSize: Cardinal; + ReservedLargeBlockAddressSpace: Cardinal; + end; + + {Memory map} + TChunkStatus = (csUnallocated, csAllocated, csReserved, + csSysAllocated, csSysReserved); + {$EXTERNALSYM TChunkStatus} + TMemoryMap = array[0..65535] of TChunkStatus; + {$EXTERNALSYM TMemoryMap} + + {Block alignment options} + TMinimumBlockAlignment = (mba8Byte, mba16Byte); + {$EXTERNALSYM TMinimumBlockAlignment} + +{$IFDEF PC_MAPPED_EXCEPTIONS} + PUnwinder = ^TUnwinder; + TUnwinder = record + RaiseException: function(Exc: Pointer): LongBool; cdecl; + RegisterIPLookup: function(fn: Pointer; StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; cdecl; + UnregisterIPLookup: procedure(StartAddr: LongInt) cdecl; + DelphiLookup: function(Addr: LongInt; Context: Pointer): Pointer; cdecl; + ClosestHandler: function(Context: Pointer): LongWord; cdecl; + end; +{$ENDIF PC_MAPPED_EXCEPTIONS} + + PackageUnitEntry = packed record + Init, FInit : Pointer; + end; + + { Compiler generated table to be processed sequentially to init & finit all package units } + { Init: 0..Max-1; Final: Last Initialized..0 } + UnitEntryTable = array [0..9999999] of PackageUnitEntry; + PUnitEntryTable = ^UnitEntryTable; + + PackageInfoTable = packed record + UnitCount : Integer; { number of entries in UnitInfo array; always > 0 } + UnitInfo : PUnitEntryTable; + end; + + PackageInfo = ^PackageInfoTable; + + { Each package exports a '@GetPackageInfoTable' which can be used to retrieve } + { the table which contains compiler generated information about the package DLL } + GetPackageInfoTable = function : PackageInfo; + +{$IFDEF DEBUG_FUNCTIONS} +{ Inspector Query; implementation in GETMEM.INC; no need to conditionalize that } + THeapBlock = record + Start: Pointer; + Size: Cardinal; + end; + + THeapBlockArray = array of THeapBlock; + TObjectArray = array of TObject; + +function GetHeapBlocks: THeapBlockArray; +function FindObjects(AClass: TClass; FindDerived: Boolean): TObjectArray; +{ Inspector Query } +{$ENDIF} + +{ + When an exception is thrown, the exception object that is thrown is destroyed + automatically when the except clause which handles the exception is exited. + There are some cases in which an application may wish to acquire the thrown + object and keep it alive after the except clause is exited. For this purpose, + we have added the AcquireExceptionObject and ReleaseExceptionObject functions. + These functions maintain a reference count on the most current exception object, + allowing applications to legitimately obtain references. If the reference count + for an exception that is being thrown is positive when the except clause is exited, + then the thrown object is not destroyed by the RTL, but assumed to be in control + of the application. It is then the application's responsibility to destroy the + thrown object. If the reference count is zero, then the RTL will destroy the + thrown object when the except clause is exited. +} +function AcquireExceptionObject: Pointer; +procedure ReleaseExceptionObject; + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure GetUnwinder(var Dest: TUnwinder); +procedure SetUnwinder(const NewUnwinder: TUnwinder); +function IsUnwinderSet: Boolean; + +//function SysRegisterIPLookup(ModuleHandle, StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; +{ + Do NOT call these functions. They are for internal use only: + SysRegisterIPLookup + SysUnregisterIPLookup + BlockOSExceptions + UnblockOSExceptions + AreOSExceptionsBlocked +} +function SysRegisterIPLookup(StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; +procedure SysUnregisterIPLookup(StartAddr: LongInt); +//function SysAddressIsInPCMap(Addr: LongInt): Boolean; +function SysClosestDelphiHandler(Context: Pointer): LongWord; +procedure BlockOSExceptions; +procedure UnblockOSExceptions; +function AreOSExceptionsBlocked: Boolean; + +{$ELSE} +// These functions are not portable. Use AcquireExceptionObject above instead +function RaiseList: Pointer; deprecated; { Stack of current exception objects } +function SetRaiseList(NewPtr: Pointer): Pointer; deprecated; { returns previous value } +{$ENDIF} + +function ExceptObject: TObject; +function ExceptAddr: Pointer; + + +{ + Coverage support. These are internal use structures referenced by compiler + helper functions for QA coverage support. +} +type + TCVModInfo = packed record + ModName: PChar; + LibName: PChar; + UserData: Pointer; + end; + PCVModInfo = ^TCVModInfo; + +{$EXTERNALSYM _CVR_PROBE} +procedure _CVR_PROBE(mi: PCVModInfo; probeNum: Cardinal); cdecl; +{$EXTERNALSYM _CVR_STMTPROBE} +function _CVR_STMTPROBE(mi: PCVModInfo; probeNum: Cardinal; TrueFalse: Cardinal): Boolean; cdecl; + +procedure SetInOutRes(NewValue: Integer); + +type + TAssertErrorProc = procedure (const Message, Filename: string; + LineNumber: Integer; ErrorAddr: Pointer); + TSafeCallErrorProc = procedure (ErrorCode: HResult; ErrorAddr: Pointer); + +{$IFDEF DEBUG} +{ + This variable is just for debugging the exception handling system. See + _DbgExcNotify for the usage. +} +var + ExcNotificationProc : procedure ( NotificationKind: Integer; + ExceptionObject: Pointer; + ExceptionName: PShortString; + ExceptionLocation: Pointer; + HandlerAddr: Pointer) = nil; +{$ENDIF} + +var + DispCallByIDProc: Pointer; + ExceptProc: Pointer; { Unhandled exception handler } + ErrorProc: procedure (ErrorCode: Byte; ErrorAddr: Pointer); { Error handler procedure } +{$IFDEF MSWINDOWS} + ExceptClsProc: Pointer; { Map an OS Exception to a Delphi class reference } + ExceptObjProc: Pointer; { Map an OS Exception to a Delphi class instance } + RaiseExceptionProc: Pointer; + RTLUnwindProc: Pointer; +{$ENDIF} + ExceptionClass: TClass; { Exception base class (must be Exception) } + SafeCallErrorProc: TSafeCallErrorProc; { Safecall error handler } + AssertErrorProc: TAssertErrorProc; { Assertion error handler } + ExitProcessProc: procedure; { Hook to be called just before the process actually exits } + AbstractErrorProc: procedure; { Abstract method error handler } + HPrevInst: LongWord deprecated; { Handle of previous instance - HPrevInst cannot be tested for multiple instances in Win32} + MainInstance: LongWord; { Handle of the main(.EXE) HInstance } +{X- MainThreadID: LongWord; } { ThreadID of thread that module was initialized in } + IsLibrary: Boolean; { True if module is a DLL } +{$IFDEF MSWINDOWS} +{X} // following variables are converted to functions +{X} function CmdShow : Integer; +{X} function CmdLine : PChar; +{$ELSE} + CmdShow: Integer platform; { CmdShow parameter for CreateWindow } + CmdLine: PChar platform; { Command line pointer } +{$ENDIF} +var + InitProc: Pointer; { Last installed initialization procedure } + ExitCode: Integer = 0; { Program result } + ExitProc: Pointer; { Last installed exit procedure } + ErrorAddr: Pointer = nil; { Address of run-time error } + RandSeed: Longint = 0; { Base for random number generator } + IsConsole: Boolean; { True if compiled as console app } + IsMultiThread: Boolean; { True if more than one thread } + FileMode: Byte = 2; { Standard mode for opening files } +{$IFDEF LINUX} + FileAccessRights: Integer platform; { Default access rights for opening files } + ArgCount: Integer platform; + ArgValues: PPChar platform; +{$ENDIF} + Test8086: Byte; { CPU family (minus one) See consts below } + Test8087: Byte = 3; { assume 80387 FPU or OS supplied FPU emulation } + TestFDIV: Shortint; { -1: Flawed Pentium, 0: Not determined, 1: Ok } + Input: Text; { Standard input } + Output: Text; { Standard output } + ErrOutput: Text; { Standard error output } + envp: PPChar platform; + + VarClearProc: procedure (var v: TVarData) = nil; // for internal use only + VarAddRefProc: procedure (var v: TVarData) = nil; // for internal use only + VarCopyProc: procedure (var Dest: TVarData; const Source: TVarData) = nil; // for internal use only + VarToLStrProc: procedure (var Dest: AnsiString; const Source: TVarData) = nil; // for internal use only + VarToWStrProc: procedure (var Dest: WideString; const Source: TVarData) = nil; // for internal use only + +const + CPUi386 = 2; + CPUi486 = 3; + CPUPentium = 4; + +var + Default8087CW: Word = $1332;{ Default 8087 control word. FPU control + register is set to this value. + CAUTION: Setting this to an invalid value + could cause unpredictable behavior. } + + HeapAllocFlags: Word platform = 2; { Heap allocation flags, gmem_Moveable } + DebugHook: Byte platform = 0; { 1 to notify debugger of non-Delphi exceptions + >1 to notify debugger of exception unwinding } + JITEnable: Byte platform = 0; { 1 to call UnhandledExceptionFilter if the exception + is not a Pascal exception. + >1 to call UnhandledExceptionFilter for all exceptions } + NoErrMsg: Boolean platform = False; { True causes the base RTL to not display the message box + when a run-time error occurs } +{$IFDEF LINUX} + { CoreDumpEnabled = True will cause unhandled + exceptions and runtime errors to raise a + SIGABRT signal, which will cause the OS to + coredump the process address space. This can + be useful for postmortem debugging. } + CoreDumpEnabled: Boolean platform = False; +{$ENDIF} + +type +(*$NODEFINE TTextLineBreakStyle*) + TTextLineBreakStyle = (tlbsLF, tlbsCRLF); + +var { Text output line break handling. Default value for all text files } + DefaultTextLineBreakStyle: TTextLineBreakStyle = {$IFDEF LINUX} tlbsLF {$ENDIF} + {$IFDEF MSWINDOWS} tlbsCRLF {$ENDIF}; +const + sLineBreak = {$IFDEF LINUX} #10 {$ENDIF} {$IFDEF MSWINDOWS} #13#10 {$ENDIF}; + +type + HRSRC = THandle; + TResourceHandle = HRSRC; // make an opaque handle type + HINST = THandle; + HMODULE = HINST; + HGLOBAL = THandle; + +{$IFDEF ELF} +{ ELF resources } +function FindResource(ModuleHandle: HMODULE; ResourceName, ResourceType: PChar): TResourceHandle; +function LoadResource(ModuleHandle: HMODULE; ResHandle: TResourceHandle): HGLOBAL; +function SizeofResource(ModuleHandle: HMODULE; ResHandle: TResourceHandle): Integer; +function LockResource(ResData: HGLOBAL): Pointer; +function UnlockResource(ResData: HGLOBAL): LongBool; +function FreeResource(ResData: HGLOBAL): LongBool; +{$ENDIF} + +{ Memory manager support } + +procedure GetMemoryManager(var MemMgr: TMemoryManager); overload; deprecated; +procedure SetMemoryManager(const MemMgr: TMemoryManager); overload; deprecated; +procedure GetMemoryManager(var MemMgrEx: TMemoryManagerEx); overload; +procedure SetMemoryManager(const MemMgrEx: TMemoryManagerEx); overload; +function IsMemoryManagerSet: Boolean; + +function SysGetMem(Size: Integer): Pointer; +function SysFreeMem(P: Pointer): Integer; +function SysReallocMem(P: Pointer; Size: Integer): Pointer; +function SysAllocMem(Size: Cardinal): Pointer; +function SysRegisterExpectedMemoryLeak(P: Pointer): Boolean; +function SysUnregisterExpectedMemoryLeak(P: Pointer): Boolean; + +{ AllocMem allocates a block of the given size on the heap. Each byte in + the allocated buffer is set to zero. To dispose the buffer, use the + FreeMem standard procedure. } + +function AllocMem(Size: Cardinal): Pointer; + +var + + AllocMemCount: Integer deprecated; {Unsupported} + AllocMemSize: Integer deprecated; {Unsupported} + +{Set this variable to true to report memory leaks on shutdown. This setting + has no effect if this module is sharing a memory manager owned by another + module.} + ReportMemoryLeaksOnShutdown: Boolean; + +{$IFDEF MSWINDOWS} +function GetHeapStatus: THeapStatus; platform; deprecated; {Unsupported} + +{Returns information about the current state of the memory manager} +procedure GetMemoryManagerState(var AMemoryManagerState: TMemoryManagerState); + +{Gets the state of every 64K block in the 4GB address space} +procedure GetMemoryMap(var AMemoryMap: TMemoryMap); + +{Registers expected memory leaks. Returns true on success. The list of leaked + blocks is limited in size, so failure is possible if the list is full.} +function RegisterExpectedMemoryLeak(P: Pointer): boolean; + +{Removes expected memory leaks. Returns true if the previously registered leak + was found and removed.} +function UnregisterExpectedMemoryLeak(P: Pointer): boolean; + +{Set the minimum block alignment. In the current implementation blocks >=160 + bytes will always be at least 16 byte aligned, even if only 8-byte alignment + (the default) is required.} +function GetMinimumBlockAlignment: TMinimumBlockAlignment; +procedure SetMinimumBlockAlignment(AMinimumBlockAlignment: TMinimumBlockAlignment); + +{Searches the current process for a shared memory manager. If no memory has + been allocated using this memory manager it will switch to using the shared + memory manager instead. Returns true if another memory manager was found and + this module is now sharing it.} +function AttemptToUseSharedMemoryManager: Boolean; + +{Makes this memory manager available for sharing to other modules in the + current process. Only one memory manager may be shared per process, so this + function may fail.} +function ShareMemoryManager: Boolean; + +{$ENDIF} + +{ Thread support } +type + TThreadFunc = function(Parameter: Pointer): Integer; +{$IFDEF LINUX} + TSize_T = Cardinal; + + TSchedParam = record + sched_priority: Integer; + end; + + pthread_attr_t = record + __detachstate, + __schedpolicy: Integer; + __schedparam: TSchedParam; + __inheritsched, + __scope: Integer; + __guardsize: TSize_T; + __stackaddr_set: Integer; + __stackaddr: Pointer; + __stacksize: TSize_T; + end; + {$EXTERNALSYM pthread_attr_t} + TThreadAttr = pthread_attr_t; + PThreadAttr = ^TThreadAttr; + + TBeginThreadProc = function (Attribute: PThreadAttr; + ThreadFunc: TThreadFunc; Parameter: Pointer; + var ThreadId: Cardinal): Integer; + TEndThreadProc = procedure(ExitCode: Integer); + +var + BeginThreadProc: TBeginThreadProc = nil; + EndThreadProc: TEndThreadProc = nil; +{$ENDIF} + +{$IFDEF MSWINDOWS} + +type + TSystemThreadFuncProc = function(ThreadFunc: TThreadFunc; Parameter: Pointer): Pointer; + TSystemThreadEndProc = procedure(ExitCode: Integer); + + (*$HPPEMIT 'namespace System' *) + (*$HPPEMIT '{' *) + (*$HPPEMIT ' typedef void * (__fastcall * TSystemThreadFuncProc)(void *, void * );' *) + (*$HPPEMIT ' typedef void (__fastcall * TSystemThreadEndProc)(int);' *) + (*$HPPEMIT '}' *) + +var + // SystemThreadFuncProc and SystemThreadEndProc are set during the startup + // code by the C++ RTL when running in a C++Builder VCL application. + SystemThreadFuncProc: TSystemThreadFuncProc = nil; + SystemThreadEndProc: TSystemThreadEndProc = nil; + +function BeginThread(SecurityAttributes: Pointer; StackSize: LongWord; + ThreadFunc: TThreadFunc; Parameter: Pointer; CreationFlags: LongWord; + var ThreadId: LongWord): Integer; +{$ENDIF} +{$IFDEF LINUX} +function BeginThread(Attribute: PThreadAttr; ThreadFunc: TThreadFunc; + Parameter: Pointer; var ThreadId: Cardinal): Integer; + +{$ENDIF} +procedure EndThread(ExitCode: Integer); + +{ Standard procedures and functions } + +const +{ File mode magic numbers } + + fmClosed = $D7B0; + fmInput = $D7B1; + fmOutput = $D7B2; + fmInOut = $D7B3; + +{ Text file flags } + tfCRLF = $1; // Dos compatibility flag, for CR+LF line breaks and EOF checks + +type +{ Typed-file and untyped-file record } + + TFileRec = packed record (* must match the size the compiler generates: 332 bytes *) + Handle: Integer; + Mode: Word; + Flags: Word; + case Byte of + 0: (RecSize: Cardinal); // files of record + 1: (BufSize: Cardinal; // text files + BufPos: Cardinal; + BufEnd: Cardinal; + BufPtr: PChar; + OpenFunc: Pointer; + InOutFunc: Pointer; + FlushFunc: Pointer; + CloseFunc: Pointer; + UserData: array[1..32] of Byte; + Name: array[0..259] of Char; ); + end; + +{ Text file record structure used for Text files } + PTextBuf = ^TTextBuf; + TTextBuf = array[0..127] of Char; + TTextRec = packed record (* must match the size the compiler generates: 460 bytes *) + Handle: Integer; (* must overlay with TFileRec *) + Mode: Word; + Flags: Word; + BufSize: Cardinal; + BufPos: Cardinal; + BufEnd: Cardinal; + BufPtr: PChar; + OpenFunc: Pointer; + InOutFunc: Pointer; + FlushFunc: Pointer; + CloseFunc: Pointer; + UserData: array[1..32] of Byte; + Name: array[0..259] of Char; + Buffer: TTextBuf; + end; + + TTextIOFunc = function (var F: TTextRec): Integer; + TFileIOFunc = function (var F: TFileRec): Integer; + +procedure SetLineBreakStyle(var T: Text; Style: TTextLineBreakStyle); + +procedure ChDir(const S: string); overload; +procedure ChDir(P: PChar); overload; +function Flush(var t: Text): Integer; +procedure _LGetDir(D: Byte; var S: string); +procedure _SGetDir(D: Byte; var S: ShortString); +function IOResult: Integer; +procedure MkDir(const S: string); overload; +procedure MkDir(P: PChar); overload; +procedure Move(const Source; var Dest; Count: Integer); +function ParamCount: Integer; +function ParamStr(Index: Integer): string; +procedure RmDir(const S: string); overload; +procedure RmDir(P: PChar); overload; +function UpCase(Ch: Char): Char; + +{ random functions } +procedure Randomize; + +function Random(const ARange: Integer): Integer; overload; +function Random: Extended; overload; + + +{ Control 8087 control word } + +procedure Set8087CW(NewCW: Word); +function Get8087CW: Word; + +{ Wide character support procedures and functions for C++ } +{ These functions should not be used in Delphi code! + (conversion is implicit in Delphi code) } + +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; + +{ PUCS4Chars returns a pointer to the UCS4 char data in the + UCS4String array, or a pointer to a null char if UCS4String is empty } + +function PUCS4Chars(const S: UCS4String): PUCS4Char; + +{ Widestring <-> UCS4 conversion } + +function WideStringToUCS4String(const S: WideString): UCS4String; +function UCS4StringToWideString(const S: UCS4String): WideString; + +{ PChar/PWideChar Unicode <-> UTF8 conversion } + +// UnicodeToUTF8(3): +// UTF8ToUnicode(3): +// Scans the source data to find the null terminator, up to MaxBytes +// Dest must have MaxBytes available in Dest. +// MaxDestBytes includes the null terminator (last char in the buffer will be set to null) +// Function result includes the null terminator. + +function UnicodeToUtf8(Dest: PChar; Source: PWideChar; MaxBytes: Integer): Integer; overload; deprecated; +function Utf8ToUnicode(Dest: PWideChar; Source: PChar; MaxChars: Integer): Integer; overload; deprecated; + +// UnicodeToUtf8(4): +// UTF8ToUnicode(4): +// MaxDestBytes includes the null terminator (last char in the buffer will be set to null) +// Function result includes the null terminator. +// Nulls in the source data are not considered terminators - SourceChars must be accurate + +function UnicodeToUtf8(Dest: PChar; MaxDestBytes: Cardinal; Source: PWideChar; SourceChars: Cardinal): Cardinal; overload; +function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: Cardinal; Source: PChar; SourceBytes: Cardinal): Cardinal; overload; + +{ WideString <-> UTF8 conversion } + +function UTF8Encode(const WS: WideString): UTF8String; +function UTF8Decode(const S: UTF8String): WideString; + +{ Ansi <-> UTF8 conversion } + +function AnsiToUtf8(const S: string): UTF8String; +function Utf8ToAnsi(const S: UTF8String): string; + +{ OLE string support procedures and functions } + +function OleStrToString(Source: PWideChar): string; +procedure OleStrToStrVar(Source: PWideChar; var Dest: string); +function StringToOleStr(const Source: string): PWideChar; + +{ Variant manager support procedures and functions (obsolete - see Variants.pas) } + +procedure GetVariantManager(var VarMgr: TVariantManager); deprecated; +procedure SetVariantManager(const VarMgr: TVariantManager); deprecated; +function IsVariantManagerSet: Boolean; deprecated; + +{ Interface dispatch support } + +procedure _IntfDispCall; cdecl; // ARGS PLEASE! +procedure _IntfVarCall; cdecl; // ARGS PLEASE! + +{ Package/Module registration and unregistration } + +type + PLibModule = ^TLibModule; + TLibModule = record + Next: PLibModule; + Instance: LongWord; + CodeInstance: LongWord; + DataInstance: LongWord; + ResInstance: LongWord; + Reserved: Integer; +{$IFDEF LINUX} + InstanceVar: Pointer platform; + GOT: LongWord platform; + CodeSegStart: LongWord platform; + CodeSegEnd: LongWord platform; + InitTable: Pointer platform; +{$ENDIF} + end; + + TEnumModuleFunc = function (HInstance: Integer; Data: Pointer): Boolean; + {$EXTERNALSYM TEnumModuleFunc} + TEnumModuleFuncLW = function (HInstance: LongWord; Data: Pointer): Boolean; + {$EXTERNALSYM TEnumModuleFuncLW} + TModuleUnloadProc = procedure (HInstance: Integer); + {$EXTERNALSYM TModuleUnloadProc} + TModuleUnloadProcLW = procedure (HInstance: LongWord); + {$EXTERNALSYM TModuleUnloadProcLW} + + PModuleUnloadRec = ^TModuleUnloadRec; + TModuleUnloadRec = record + Next: PModuleUnloadRec; + Proc: TModuleUnloadProcLW; + end; + +var + LibModuleList: PLibModule = nil; + ModuleUnloadList: PModuleUnloadRec = nil; + +procedure RegisterModule(LibModule: PLibModule); +procedure UnregisterModule(LibModule: PLibModule); +function FindHInstance(Address: Pointer): LongWord; +function FindClassHInstance(ClassType: TClass): LongWord; +function FindResourceHInstance(Instance: LongWord): LongWord; +function LoadResourceModule(ModuleName: PChar; CheckOwner: Boolean = True): LongWord; +procedure EnumModules(Func: TEnumModuleFunc; Data: Pointer); overload; +procedure EnumResourceModules(Func: TEnumModuleFunc; Data: Pointer); overload; +procedure EnumModules(Func: TEnumModuleFuncLW; Data: Pointer); overload; +procedure EnumResourceModules(Func: TEnumModuleFuncLW; Data: Pointer); overload; +procedure AddModuleUnloadProc(Proc: TModuleUnloadProc); overload; +procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProc); overload; +procedure AddModuleUnloadProc(Proc: TModuleUnloadProcLW); overload; +procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProcLW); overload; +{$IFDEF LINUX} +{ Given an HMODULE, this function will return its fully qualified name. There is + no direct equivalent in Linux so this function provides that capability. } +function GetModuleFileName(Module: HMODULE; Buffer: PChar; BufLen: Integer): Integer; +{$ENDIF} + +{ ResString support function/record } + +type + PResStringRec = ^TResStringRec; + TResStringRec = packed record + Module: ^Cardinal; + Identifier: Integer; + end; + +function LoadResString(ResStringRec: PResStringRec): string; + +function Int(const X: Extended): Extended; +function Frac(const X: Extended): Extended; +function Exp(const X: Extended): Extended; +function Cos(const X: Extended): Extended; +function Sin(const X: Extended): Extended; +function Ln(const X: Extended): Extended; +function ArcTan(const X: Extended): Extended; +function Sqrt(const X: Extended): Extended; + +{ Procedures and functions that need compiler magic } + +procedure _ROUND; +procedure _TRUNC; + +procedure _AbstractError; +procedure _Assert(const Message, Filename: AnsiString; LineNumber: Integer); +function _Append(var t: TTextRec): Integer; +function _Assign(var t: TTextRec; const S: String): Integer; +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); +function _EofFile(var f: TFileRec): Boolean; +function _EofText(var t: TTextRec): Boolean; +function _Eoln(var t: TTextRec): Boolean; +procedure _Erase(var f: TFileRec); +{$IFDEF TRIAL_EDITION} +procedure _Expired; +{$ENDIF} +function _FilePos(var f: TFileRec): Longint; +function _FileSize(var f: TFileRec): Longint; +procedure _FillChar(var Dest; count: Integer; Value: Char); +function _FreeMem(P: Pointer): Integer; +function _GetMem(Size: Integer): Pointer; +function _ReallocMem(var P: Pointer; NewSize: Integer): Pointer; +procedure _Halt(Code: Integer); +procedure _Halt0; +{$IFDEF TRIAL_EDITION} +{$IFDEF MSWINDOWS} +function _InitUnitPrep: Int64; +{$ENDIF} +{$IFDEF LINUX} +function _InitUnitPrep: Integer; +{$ENDIF} +{$ENDIF} +procedure Mark; deprecated; +procedure _PStrCmp; +procedure _AStrCmp; +function _ReadRec(var f: TFileRec; Buffer: Pointer): Integer; +function _ReadChar(var t: TTextRec): Char; +function _ReadLong(var t: TTextRec): Longint; +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); +procedure _ReadWString(var t: TTextRec; var s: WideString); +procedure _ReadWCString(var t: TTextRec; s: PWideChar; maxBytes: Longint); +function _ReadWChar(var t: TTextRec): WideChar; +function _ReadExt(var t: TTextRec): Extended; +procedure _ReadLn(var t: TTextRec); +procedure _Rename(var f: TFileRec; newName: PChar); +procedure Release; deprecated; +function _ResetText(var t: TTextRec): Integer; +function _ResetFile(var f: TFileRec; recSize: Longint): Integer; +function _RewritText(var t: TTextRec): Integer; +function _RewritFile(var f: TFileRec; recSize: Longint): Integer; +procedure _RunError(errorCode: Byte); +procedure _Run0Error; +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; +{$IFDEF LINUX} +procedure _UnhandledException; +{$ENDIF} +function _WriteRec(var f: TFileRec; buffer: Pointer): Pointer; +function _WriteChar(var t: TTextRec; c: Char; width: Integer): Pointer; +function _Write0Char(var t: TTextRec; c: Char): 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 _WriteString(var t: TTextRec; const s: ShortString; width: Longint): Pointer; +function _Write0String(var t: TTextRec; const s: ShortString): Pointer; +function _WriteCString(var t: TTextRec; s: PChar; width: Longint): Pointer; +function _Write0CString(var t: TTextRec; s: PChar): Pointer; +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 _WriteWCString(var t: TTextRec; s: PWideChar; width: Longint): Pointer; +function _Write0WCString(var t: TTextRec; s: PWideChar): Pointer; +function _WriteWChar(var t: TTextRec; c: WideChar; width: Integer): Pointer; +function _Write0WChar(var t: TTextRec; c: WideChar): Pointer; +function _WriteVariant(var T: TTextRec; const V: TVarData; Width: Integer): Pointer; +function _Write0Variant(var T: TTextRec; const V: TVarData): 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 __IOTest; +function _Flush(var t: TTextRec): Integer; + +procedure _SetElem; +procedure _SetRange; +procedure _SetEq; +procedure _SetLe; +procedure _SetIntersect; +procedure _SetIntersect3; { BEG only } +procedure _SetUnion; +procedure _SetUnion3; { BEG only } +procedure _SetSub; +procedure _SetSub3; { BEG only } +procedure _SetExpand; + +procedure _Str2Ext; +procedure _Str0Ext; +procedure _Str1Ext; +procedure _ValExt; +procedure _Pow10; +procedure _Real2Ext; +procedure _Ext2Real; + +procedure _ObjSetup; +procedure _ObjCopy; +procedure _Fail; +procedure _BoundErr; +procedure _IntOver; + +{ Module initialization context. For internal use only. } + +type + PInitContext = ^TInitContext; + TInitContext = record + OuterContext: PInitContext; { saved InitContext } +{$IFNDEF PC_MAPPED_EXCEPTIONS} + ExcFrame: Pointer; { bottom exc handler } +{$ENDIF} + InitTable: PackageInfo; { unit init info } + InitCount: Integer; { how far we got } + Module: PLibModule; { ptr to module desc } + DLLSaveEBP: Pointer; { saved regs for DLLs } + DLLSaveEBX: Pointer; { saved regs for DLLs } + DLLSaveESI: Pointer; { saved regs for DLLs } + DLLSaveEDI: Pointer; { saved regs for DLLs } +{$IFDEF MSWINDOWS} + ExitProcessTLS: procedure; { Shutdown for TLS } +{$ENDIF} + DLLInitState: Byte; { 0 = package, 1 = DLL shutdown, 2 = DLL startup } + end platform; + +type + TDLLProc = procedure (Reason: Integer); + // TDLLProcEx provides the reserved param returned by WinNT + TDLLProcEx = procedure (Reason: Integer; Reserved: Integer); + +{$IFDEF LINUX} +procedure _StartExe(InitTable: PackageInfo; Module: PLibModule; Argc: Integer; Argv: Pointer); +procedure _StartLib(Context: PInitContext; Module: PLibModule; DLLProc: TDLLProcEx); +{$ENDIF} +{$IFDEF MSWINDOWS} +procedure _StartExe(InitTable: PackageInfo; Module: PLibModule); +procedure _StartLib; +{$ENDIF} +procedure _PackageLoad(const Table : PackageInfo; Module: PLibModule); +procedure _PackageUnload(const Table : PackageInfo; Module: PLibModule); +procedure _InitResStrings; +procedure _InitResStringImports; +procedure _InitImports; +{$IFDEF MSWINDOWS} +procedure _InitWideStrings; +{$ENDIF} + +function _ClassCreate(AClass: TClass; Alloc: Boolean): TObject; +procedure _ClassDestroy(Instance: TObject); +function _AfterConstruction(Instance: TObject): TObject; +function _BeforeDestruction(Instance: TObject; OuterMost: ShortInt): TObject; +function _IsClass(Child: TObject; Parent: TClass): Boolean; +function _AsClass(Child: TObject; Parent: TClass): TObject; +function _GetHelperIntf(Instance: TObject; Cls: TClass): IInterface; + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _RaiseAtExcept; +//procedure _DestroyException(Exc: PRaisedException); +procedure _DestroyException; +{$ENDIF} +procedure _RaiseExcept; +procedure _RaiseAgain; +procedure _DoneExcept; +{$IFNDEF PC_MAPPED_EXCEPTIONS} +procedure _TryFinallyExit; +{$ENDIF} +procedure _HandleAnyException; +procedure _HandleFinally; +procedure _HandleOnException; +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _HandleOnExceptionPIC; +{$ENDIF} +procedure _HandleAutoException; +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _ClassHandleException; +{$ENDIF} + +procedure _CallDynaInst; +procedure _CallDynaClass; +procedure _FindDynaInst; +procedure _FindDynaClass; + +procedure _LStrClr(var S); +procedure _LStrArrayClr(var StrArray; cnt: longint); +procedure _LStrAsg(var dest; const source); +procedure _LStrLAsg(var dest; const source); +procedure _LStrFromPCharLen(var Dest: AnsiString; Source: PAnsiChar; Length: 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; inline; +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 _LStrToPChar(const s: AnsiString): PChar; +procedure _Copy{ s : ShortString; index, count : Integer ) : ShortString}; +procedure _Delete{ var s : openstring; index, count : Integer }; +procedure _Insert{ source : ShortString; var s : openstring; index : Integer }; +procedure _Pos{ substr : ShortString; s : ShortString ) : Integer}; +procedure _SetLength(s: PShortString; newLength: Byte); +procedure _SetString(s: PShortString; buffer: PChar; len: Byte); + +procedure UniqueString(var str: AnsiString); overload; +procedure UniqueString(var str: WideString); overload; +procedure _UniqueStringA(var str: AnsiString); +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}; +function _NewAnsiString(length: Longint): Pointer; { for debugger purposes only } +function _NewWideString(CharLength: Longint): Pointer; + +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); +function _WStrToPWChar(const S: WideString): PWideChar; +function _WStrLen(const S: WideString): Integer; +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); +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 _WStrSetLength(var S: WideString; NewLength: Integer); +function _WStrAddRef(var str: WideString): Pointer; +procedure _WCharToString(Dest: PShortString; const Source: WideChar; MaxLen: Integer); + +procedure _Initialize(p: Pointer; typeInfo: Pointer); +procedure _InitializeArray(p: Pointer; typeInfo: Pointer; elemCount: Cardinal); +procedure _InitializeRecord(p: Pointer; typeInfo: Pointer); +procedure _Finalize(p: Pointer; typeInfo: Pointer); +procedure _FinalizeArray(p: Pointer; typeInfo: Pointer; elemCount: Cardinal); +procedure _FinalizeRecord(P: Pointer; typeInfo: Pointer); +procedure _AddRef; +procedure _AddRefArray; +procedure _AddRefRecord; +procedure _CopyArray; +procedure _CopyRecord; +procedure _CopyObject; + +function _New(size: Longint; typeInfo: Pointer): Pointer; +procedure _Dispose(p: Pointer; typeInfo: Pointer); + +{ 64-bit Integer helper routines } +procedure __llmul; +procedure __lldiv; +procedure __lludiv; +procedure __llmod; +procedure __llmulo; +procedure __lldivo; +procedure __llmodo; +procedure __llumod; +procedure __llshl; +procedure __llushr; +procedure _WriteInt64; +procedure _Write0Int64; +procedure _WriteUInt64; +procedure _Write0UInt64; +procedure _ReadInt64; +function _StrInt64(val: Int64; width: Integer): ShortString; +function _Str0Int64(val: Int64): ShortString; +function _ValInt64(const s: AnsiString; var code: Integer): Int64; +function _StrUInt64(val: UInt64; width: Integer): ShortString; +function _Str0UInt64(val: Int64): ShortString; + +{ Dynamic array helper functions } + +procedure _DynArrayHigh; +procedure _DynArrayClear(var a: Pointer; typeInfo: Pointer); +procedure _DynArrayLength; +procedure _DynArraySetLength; +procedure _DynArrayCopy(a: Pointer; typeInfo: Pointer; var Result: Pointer); +procedure _DynArrayCopyRange(a: Pointer; typeInfo: Pointer; index, count : Integer; var Result: Pointer); +procedure _DynArrayAsg; +procedure _DynArrayAddRef; + +procedure DynArrayClear(var a: Pointer; typeInfo: Pointer); +procedure DynArraySetLength(var a: Pointer; typeInfo: Pointer; dimCnt: Longint; lengthVec: PLongint); +function DynArrayDim(typeInfo: PDynArrayTypeInfo): Integer; +{$NODEFINE DynArrayDim} + +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); + +{$IFDEF MSWINDOWS} +procedure _FSafeDivide; +procedure _FSafeDivideR; +{$ENDIF} + +function _CheckAutoResult(ResultCode: HResult): HResult; + +procedure FPower10; + +procedure TextStart; deprecated; + +// Conversion utility routines for C++ convenience. Not for Delphi code. +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; + +function Pos(const substr, str: AnsiString): Integer; overload; +function Pos(const substr, str: WideString): Integer; overload; + +function StringOfChar(ch: AnsiChar; Count: Integer): AnsiString; overload; +function StringOfChar(ch: WideChar; Count: Integer): WideString; overload; + +{ Internal runtime error codes } + +type + TRuntimeError = (reNone, reOutOfMemory, reInvalidPtr, reDivByZero, + reRangeError, reIntOverflow, reInvalidOp, reZeroDivide, reOverflow, + reUnderflow, reInvalidCast, reAccessViolation, rePrivInstruction, + reControlBreak, reStackOverflow, + { reVar* used in Variants.pas } + reVarTypeCast, reVarInvalidOp, + reVarDispatch, reVarArrayCreate, reVarNotArray, reVarArrayBounds, + reAssertionFailed, + reExternalException, { not used here; in SysUtils } + reIntfCastError, reSafeCallError +{$IFDEF LINUX} + , reQuit, reCodesetConversion +{$ENDIF} + ); +{$NODEFINE TRuntimeError} + +procedure Error(errorCode: TRuntimeError); +{$NODEFINE Error} + +{ GetLastError returns the last error reported by an OS API call. Calling + this function usually resets the OS error state. +} + +function GetLastError: Integer; {$IFDEF MSWINDOWS} stdcall; {$ENDIF} +{$EXTERNALSYM GetLastError} + +{ SetLastError writes to the thread local storage area read by GetLastError. } + +procedure SetLastError(ErrorCode: Integer); {$IFDEF MSWINDOWS} stdcall; {$ENDIF} + +{$IFDEF LINUX} +{ To improve performance, some RTL routines cache module handles and data + derived from modules. If an application dynamically loads and unloads + shared object libraries, packages, or resource packages, it is possible for + the handle of the newly loaded module to match the handle of a recently + unloaded module. The resource caches have no way to detect when this happens. + + To address this issue, the RTL maintains an internal counter that is + incremented every time a module is loaded or unloaded using RTL functions + (like LoadPackage). This provides a cache version level signature that + can detect when modules have been cycled but have the same handle. + + If you load or unload modules "by hand" using dlopen or dlclose, you must call + InvalidateModuleCache after each load or unload so that the RTL module handle + caches will refresh themselves properly the next time they are used. This is + especially important if you manually tinker with the LibModuleList list of + loaded modules, or manually add or remove resource modules in the nodes + of that list. + + ModuleCacheID returns the "current generation" or version number kept by + the RTL. You can use this to implement your own refresh-on-next-use + (passive) module handle caches as the RTL does. The value changes each + time InvalidateModuleCache is called. +} + +function ModuleCacheID: Cardinal; +procedure InvalidateModuleCache; +{$ENDIF} + +{$IFDEF MSWINDOWS} +procedure SetMultiByteConversionCodePage(CodePage: Integer); +{$ENDIF} + +(* =================================================================== *) + +function DefaultSystemCodePage: Integer; + +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; + +{$IFDEF PIC} +function GetGOT: LongWord; export; +begin + asm + MOV Result,EBX + end; +end; +{$ENDIF} + +{$IFDEF PC_MAPPED_EXCEPTIONS} +const + UNWINDFI_TOPOFSTACK = $BE00EF00; + +const +{$IFDEF MSWINDOWS} + 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'; +{$ENDIF} +{$IFDEF LINUX} + unwind = 'libborunwind.so.6'; +type + UNWINDPROC = Pointer; + +//{$DEFINE STATIC_UNWIND} + +{$IFDEF STATIC_UNWIND} +function _BorUnwind_RegisterIPLookup(fn: UNWINDPROC; StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; cdecl; + external; + +procedure _BorUnwind_UnregisterIPLookup(StartAddr: LongInt); cdecl; external; + +function _BorUnwind_DelphiLookup(Addr: LongInt; Context: Pointer): UNWINDPROC; cdecl; external; + +function _BorUnwind_RaiseException(Exc: Pointer): LongBool; cdecl; external; + +//function _BorUnwind_AddressIsInPCMap(Addr: LongInt): LongBool; cdecl; external; +function _BorUnwind_ClosestDelphiHandler(Context: Pointer): LongWord; cdecl; external; +{$ELSE} + +function _BorUnwind_RegisterIPLookup(fn: UNWINDPROC; StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; cdecl; + external unwind name '_BorUnwind_RegisterIPLookup'; + +procedure _BorUnwind_UnregisterIPLookup(StartAddr: LongInt); cdecl; + external unwind name '_BorUnwind_UnregisterIPLookup'; + +function _BorUnwind_DelphiLookup(Addr: LongInt; Context: Pointer): UNWINDPROC; cdecl; + external unwind name '_BorUnwind_DelphiLookup'; + +function _BorUnwind_RaiseException(Exc: Pointer): LongBool; cdecl; + external unwind name '_BorUnwind_RaiseException'; + +function _BorUnwind_ClosestDelphiHandler(Context: Pointer): LongWord; cdecl; + external unwind name '_BorUnwind_ClosestDelphiHandler'; +{$ENDIF} +{$ENDIF} +{$ENDIF} + +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 LINUX} +const + libc = 'libc.so.6'; + libdl = 'libdl.so.2'; + libpthread = 'libpthread.so.0'; + + O_RDONLY = $0000; + O_WRONLY = $0001; + O_RDWR = $0002; + O_CREAT = $0040; + O_EXCL = $0080; + O_NOCTTY = $0100; + O_TRUNC = $0200; + O_APPEND = $0400; + + // protection flags + S_IREAD = $0100; // Read by owner. + S_IWRITE = $0080; // Write by owner. + S_IEXEC = $0040; // Execute by owner. + S_IRUSR = S_IREAD; + S_IWUSR = S_IWRITE; + S_IXUSR = S_IEXEC; + S_IRWXU = S_IRUSR or S_IWUSR or S_IXUSR; + + S_IRGRP = S_IRUSR shr 3; // Read by group. + S_IWGRP = S_IWUSR shr 3; // Write by group. + S_IXGRP = S_IXUSR shr 3; // Execute by group. + S_IRWXG = S_IRWXU shr 3; // Read, write, and execute by group. + + S_IROTH = S_IRGRP shr 3; // Read by others. + S_IWOTH = S_IWGRP shr 3; // Write by others. + S_IXOTH = S_IXGRP shr 3; // Execute by others. + S_IRWXO = S_IRWXG shr 3; // Read, write, and execute by others. + + STDIN_FILENO = 0; + STDOUT_FILENO = 1; + STDERR_FILENO = 2; + + SEEK_SET = 0; + SEEK_CUR = 1; + SEEK_END = 2; + + LC_CTYPE = 0; + _NL_CTYPE_CODESET_NAME = LC_CTYPE shl 16 + 14; + + MAX_PATH = 4095; + + +function __open(PathName: PChar; Flags: Integer; Mode: Integer): Integer; cdecl; + external libc name 'open'; + +function __close(Handle: Integer): Integer; cdecl; + external libc name 'close'; + +function __read(Handle: Integer; Buffer: Pointer; Count: Cardinal): Cardinal; cdecl; + external libc name 'read'; + +function __write(Handle: Integer; Buffer: Pointer; Count: Cardinal): Cardinal; cdecl; + external libc name 'write'; + +function __mkdir(PathName: PChar; Mode: Integer): Integer; cdecl; + external libc name 'mkdir'; + +function __getcwd(Buffer: PChar; BufSize: Integer): PChar; cdecl; + external libc name 'getcwd'; + +function __getenv(Name: PChar): PChar; cdecl; + external libc name 'getenv'; + +function __chdir(PathName: PChar): Integer; cdecl; + external libc name 'chdir'; + +function __rmdir(PathName: PChar): Integer; cdecl; + external libc name 'rmdir'; + +function __remove(PathName: PChar): Integer; cdecl; + external libc name 'remove'; + +function __rename(OldPath, NewPath: PChar): Integer; cdecl; + external libc name 'rename'; + +function strlen(OldPath, NewPath: PChar): Integer; cdecl; + external libc name 'strlen'; + +procedure memcpy(Dest: Pointer; Source: Pointer; N: Integer); cdecl; + external libc name 'memcpy'; + +{$IFDEF EFENCE} +function __malloc(Size: Integer): Pointer; cdecl; + external 'libefence.so' name 'malloc'; + +procedure __free(P: Pointer); cdecl; + external 'libefence.so' name 'free'; + +function __realloc(P: Pointer; Size: Integer): Pointer; cdecl; + external 'libefence.so' name 'realloc'; +{$ELSE} +function __malloc(Size: Integer): Pointer; cdecl; + external libc name 'malloc'; + +procedure __free(P: Pointer); cdecl; + external libc name 'free'; + +function __realloc(P: Pointer; Size: Integer): Pointer; cdecl; + external libc name 'realloc'; +{$ENDIF} + +procedure ExitProcess(status: Integer); cdecl; + external libc name 'exit'; + +function _time(P: Pointer): Integer; cdecl; + external libc name 'time'; + +function _lseek(Handle, Offset, Direction: Integer): Integer; cdecl; + external libc name 'lseek'; + +function _ftruncate(Handle: Integer; Filesize: Integer): Integer; cdecl; + external libc name 'ftruncate'; + +function strcasecmp(s1, s2: PChar): Integer; cdecl; + external libc name 'strcasecmp'; + +function __errno_location: PInteger; cdecl; + external libc name '__errno_location'; + +function nl_langinfo(item: integer): pchar; cdecl; + external libc name 'nl_langinfo'; + +function iconv_open(ToCode: PChar; FromCode: PChar): Integer; cdecl; + external libc name 'iconv_open'; + +function iconv(cd: Integer; var InBuf; var InBytesLeft: Integer; var OutBuf; var OutBytesLeft: Integer): Integer; cdecl; + external libc name 'iconv'; + +function iconv_close(cd: Integer): Integer; cdecl; + external libc name 'iconv_close'; + +function mblen(const S: PChar; N: LongWord): Integer; cdecl; + external libc name 'mblen'; + +function mmap(start: Pointer; length: Cardinal; prot, flags, fd, offset: Integer): Pointer; cdecl; + external libc name 'mmap'; + +function munmap(start: Pointer; length: Cardinal): Integer; cdecl; + external libc name 'munmap'; + +const + SIGABRT = 6; + +function __raise(SigNum: Integer): Integer; cdecl; + external libc name 'raise'; + +type + TStatStruct = record + st_dev: Int64; // device + __pad1: Word; + st_ino: Cardinal; // inode + st_mode: Cardinal; // protection + st_nlink: Cardinal; // number of hard links + st_uid: Cardinal; // user ID of owner + st_gid: Cardinal; // group ID of owner + st_rdev: Int64; // device type (if inode device) + __pad2: Word; + st_size: Cardinal; // total size, in bytes + st_blksize: Cardinal; // blocksize for filesystem I/O + st_blocks: Cardinal; // number of blocks allocated + st_atime: Integer; // time of last access + __unused1: Cardinal; + st_mtime: Integer; // time of last modification + __unused2: Cardinal; + st_ctime: Integer; // time of last change + __unused3: Cardinal; + __unused4: Cardinal; + __unused5: Cardinal; + end; + +const + STAT_VER_LINUX = 3; + +function _fxstat(Version: Integer; Handle: Integer; var Stat: TStatStruct): Integer; cdecl; + external libc name '__fxstat'; + +function __xstat(Ver: Integer; FileName: PChar; var StatBuffer: TStatStruct): Integer; cdecl; + external libc name '__xstat'; + +function _strlen(P: PChar): Integer; cdecl; + external libc name 'strlen'; + +function _readlink(PathName: PChar; Buf: PChar; Len: Integer): Integer; cdecl; + external libc name 'readlink'; + +type + TDLInfo = record + FileName: PChar; + BaseAddress: Pointer; + NearestSymbolName: PChar; + SymbolAddress: Pointer; + end; + +const + RTLD_LAZY = 1; + RTLD_NOW = 2; + +function dladdr(Address: Pointer; var Info: TDLInfo): Integer; cdecl; + external libdl name 'dladdr'; +function dlopen(Filename: PChar; Flag: Integer): LongWord; cdecl; + external libdl name 'dlopen'; +function dlclose(Handle: LongWord): Integer; cdecl; + external libdl name 'dlclose'; +function FreeLibrary(Handle: LongWord): Integer; cdecl; + external libdl name 'dlclose'; +function dlsym(Handle: LongWord; Symbol: PChar): Pointer; cdecl; + external libdl name 'dlsym'; +function dlerror: PChar; cdecl; + external libdl name 'dlerror'; + +type + TPthread_fastlock = record + __status: LongInt; + __spinlock: Integer; + end; + + TRTLCriticalSection = record + __m_reserved, + __m_count: Integer; + __m_owner: Pointer; + __m_kind: Integer; // __m_kind := 0 fastlock, __m_kind := 1 recursive lock + __m_lock: TPthread_fastlock; + end; + +function _pthread_mutex_lock(var Mutex: TRTLCriticalSection): Integer; cdecl; + external libpthread name 'pthread_mutex_lock'; +function _pthread_mutex_unlock(var Mutex: TRTLCriticalSection): Integer; cdecl; + external libpthread name 'pthread_mutex_unlock'; +function _pthread_create(var ThreadID: Cardinal; Attr: PThreadAttr; + TFunc: TThreadFunc; Arg: Pointer): Integer; cdecl; + external libpthread name 'pthread_create'; +function _pthread_exit(var RetVal: Integer): Integer; cdecl; + external libpthread name 'pthread_exit'; +function GetCurrentThreadID: LongWord; cdecl; + external libpthread name 'pthread_self'; +function _pthread_detach(ThreadID: Cardinal): Integer; cdecl; + external libpthread name 'pthread_detach' + +function GetLastError: Integer; +begin + Result := __errno_location^; +end; + +procedure SetLastError(ErrorCode: Integer); +begin + __errno_location^ := ErrorCode; +end; + +function InterlockedIncrement(var I: Integer): Integer; +asm + MOV EDX,1 + XCHG EAX,EDX + LOCK XADD [EDX],EAX + INC EAX +end; + +function InterlockedDecrement(var I: Integer): Integer; +asm + MOV EDX,-1 + XCHG EAX,EDX + LOCK XADD [EDX],EAX + DEC EAX +end; + +var + ModuleCacheVersion: Cardinal = 0; + +function ModuleCacheID: Cardinal; +begin + Result := ModuleCacheVersion; +end; + +procedure InvalidateModuleCache; +begin + InterlockedIncrement(Integer(ModuleCacheVersion)); +end; + +{$ENDIF} + +{$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 CompareString(Locale: Integer; dwCmpFlags: Integer; lpString1: PChar; + cchCount1: Integer; lpString2: PChar; cchCount2: Integer): Integer; stdcall; + external kernel name 'CompareStringA'; + +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 + SI: TStartupInfo; +begin + Result := 10; { SW_SHOWDEFAULT } + GetStartupInfo(SI); + if SI.dwFlags and 1 <> 0 then { STARTF_USESHOWWINDOW } + Result := SI.wShowWindow; +end; + +var SaveDefaultSystemCodePage: Integer = -1; + +{$ENDIF} // MSWindows + +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} + +{$IFDEF LINUX} +function SysGetMem(Size: Integer): Pointer; +begin + Result := __malloc(size); +end; + +function SysFreeMem(P: Pointer): Integer; +begin + __free(P); + Result := 0; +end; + +function SysReallocMem(P: Pointer; Size: Integer): Pointer; +begin + Result := __realloc(P, Size); +end; +{$ENDIF} + +var + MemoryManager: TMemoryManagerEx = ( + GetMem: SysGetMem; + FreeMem: SysFreeMem; + ReallocMem: SysReallocMem; + AllocMem: SysAllocMem; + RegisterExpectedmemoryLeak: SysRegisterExpectedMemoryLeak; + UnregisterExpectedmemoryLeak: SysUnregisterExpectedMemoryLeak); + +function AllocMem(Size: Cardinal): Pointer; +{$IFDEF PUREPASCAL} +begin + if Size > 0 then + begin + Result := MemoryManager.AllocMem(Size); + if Result = nil then + Error(reOutOfMemory); + end + else + Result := nil; +end; +{$ELSE} +asm + TEST EAX,EAX + JZ @@allocmemdone + CALL MemoryManager.AllocMem + TEST EAX,EAX + JZ @@allocmemerror +@@allocmemdone: + DB $F3 + RET +@@allocmemerror: + MOV AL,reOutOfMemory + JMP Error +end; +{$ENDIF} + +function RegisterExpectedMemoryLeak(P: Pointer): boolean; +begin + Result := (P <> nil) and MemoryManager.RegisterExpectedMemoryLeak(P); +end; + +function UnregisterExpectedMemoryLeak(P: Pointer): boolean; +begin + Result := (P <> nil) and MemoryManager.UnregisterExpectedMemoryLeak(P); +end; + +{$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; +{$IFDEF PUREPASCAL} +{$IF Defined(DEBUG) and Defined(LINUX)} +var + Signature: PLongInt; +{$IFEND} +begin + if Size > 0 then + begin +{$IF Defined(DEBUG) and Defined(LINUX)} + Signature := PLongInt(MemoryManager.GetMem(Size + 4)); + if Signature = nil then + Error(reOutOfMemory); + Signature^ := 0; + Result := Pointer(LongInt(Signature) + 4); +{$ELSE} + Result := MemoryManager.GetMem(Size); + if Result = nil then + Error(reOutOfMemory); +{$IFEND} + end + else + Result := nil; +end; +{$ELSE} +asm + TEST EAX,EAX + JLE @@negativeorzerosize + CALL MemoryManager.GetMem + TEST EAX,EAX + JZ @@getmemerror + DB $F3 + RET +@@getmemerror: + MOV AL,reOutOfMemory + JMP Error +@@negativeorzerosize: + XOR EAX, EAX + DB $F3 +end; +{$ENDIF} + +const + FreeMemorySignature = Longint($FBEEFBEE); + +function _FreeMem(P: Pointer): Integer; +{$IFDEF PUREPASCAL} +{$IF Defined(DEBUG) and Defined(LINUX)} +var + Signature: PLongInt; +{$IFEND} +begin + if P <> nil then + begin +{$IF Defined(DEBUG) and Defined(LINUX)} + Signature := PLongInt(LongInt(P) - 4); + if Signature^ <> 0 then + Error(reInvalidPtr); + Signature^ := FreeMemorySignature; + Result := MemoryManager.Freemem(Pointer(Signature)); +{$ELSE} + Result := MemoryManager.FreeMem(P); +{$IFEND} + if Result <> 0 then + Error(reInvalidPtr); + end + else + Result := 0; +end; +{$ELSE} +asm + TEST EAX,EAX + JZ @@freememdone + CALL MemoryManager.FreeMem + TEST EAX,EAX + JNZ @@freememerror +@@freememdone: + DB $F3 + RET +@@freememerror: + MOV AL,reInvalidPtr + JMP ERROR +end; +{$ENDIF} + +{$IFDEF LINUX} +function _ReallocMem(var P: Pointer; NewSize: Integer): Pointer; +{$IFDEF DEBUG} +var + Temp: Pointer; +{$ENDIF} +begin + if P <> nil then + begin +{$IFDEF DEBUG} + Temp := Pointer(LongInt(P) - 4); + if NewSize > 0 then + begin + Temp := MemoryManager.ReallocMem(Temp, NewSize + 4); + Result := Pointer(LongInt(Temp) + 4); + end + else + begin + MemoryManager.FreeMem(Temp); + Result := nil; + end; +{$ELSE} + if NewSize > 0 then + begin + Result := MemoryManager.ReallocMem(P, NewSize); + end + else + begin + if MemoryManager.FreeMem(P) <> 0 then + Error(reInvalidPtr); + Result := nil; + end; +{$ENDIF} + P := Result; + end else + begin + Result := _GetMem(NewSize); + P := Result; + end; +end; +{$ELSEIF Defined(MSWINDOWS)} +function _ReallocMem(var P: Pointer; NewSize: Integer): Pointer; +asm + MOV ECX,[EAX] + TEST ECX,ECX + JE @@alloc + TEST EDX,EDX + JE @@free +@@resize: + PUSH EAX + MOV EAX,ECX + CALL MemoryManager.ReallocMem + POP ECX + OR EAX,EAX + JE @@allocError + MOV [ECX],EAX + RET +@@freeError: + MOV AL,reInvalidPtr + JMP Error +@@free: + MOV [EAX],EDX + MOV EAX,ECX + CALL MemoryManager.FreeMem + OR EAX,EAX + JNE @@freeError + RET +@@allocError: + MOV AL,reOutOfMemory + JMP Error +@@alloc: + TEST EDX,EDX + JE @@exit + PUSH EAX + MOV EAX,EDX + CALL MemoryManager.GetMem + POP ECX + OR EAX,EAX + JE @@allocError + MOV [ECX],EAX +@@exit: +end; +{$IFEND} + +{The default AllocMem implementation - for older memory managers that do not + implement this themselves.} +function DefaultAllocMem(Size: Cardinal): Pointer; +begin + Result := MemoryManager.GetMem(Size); + if (Result <> nil) then + FillChar(Result^, Size, 0) +end; + +{The default (do nothing) leak registration function for backward compatibility + with older memory managers.} +function DefaultRegisterAndUnregisterExpectedMemoryLeak(P: Pointer): boolean; +begin + Result := False; +end; + +{Backward compatible GetMemoryManager implementation} +procedure GetMemoryManager(var MemMgr: TMemoryManager); +begin + MemMgr.GetMem := MemoryManager.GetMem; + MemMgr.FreeMem := MemoryManager.FreeMem; + MemMgr.ReallocMem := MemoryManager.ReallocMem; +end; + +{Backward compatible SetMemoryManager implementation} +procedure SetMemoryManager(const MemMgr: TMemoryManager); +begin + MemoryManager.GetMem := MemMgr.GetMem; + MemoryManager.FreeMem := MemMgr.FreeMem; + MemoryManager.ReallocMem := MemMgr.ReallocMem; + MemoryManager.AllocMem := DefaultAllocMem; + MemoryManager.RegisterExpectedMemoryLeak := + DefaultRegisterAndUnregisterExpectedMemoryLeak; + MemoryManager.UnregisterExpectedMemoryLeak := + DefaultRegisterAndUnregisterExpectedMemoryLeak; +end; + +procedure GetMemoryManager(var MemMgrEx: TMemoryManagerEx); +begin + MemMgrEx := MemoryManager; +end; + +procedure SetMemoryManager(const MemMgrEx: TMemoryManagerEx); +begin + MemoryManager := MemMgrEx; +end; + +function IsMemoryManagerSet: Boolean; +begin + with MemoryManager do + Result := (@GetMem <> @SysGetMem) or (@FreeMem <> @SysFreeMem) or + (@ReallocMem <> @SysReallocMem) or (@AllocMem <> @SysAllocMem) or + (@RegisterExpectedMemoryLeak <> @SysRegisterExpectedMemoryLeak) or + (@UnregisterExpectedMemoryLeak <> @SysUnregisterExpectedMemoryLeak); +end; + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure GetUnwinder(var Dest: TUnwinder); +begin + Dest := Unwinder; +end; + +procedure SetUnwinder(const NewUnwinder: TUnwinder); +begin + Unwinder := NewUnwinder; +end; + +function IsUnwinderSet: Boolean; +begin + with Unwinder do + Result := (@RaiseException <> @_BorUnwind_RaiseException) or + (@RegisterIPLookup <> @_BorUnwind_RegisterIPLookup) or + (@UnregisterIPLookup <> @_BorUnwind_UnregisterIPLookup) or + (@DelphiLookup <> @_BorUnwind_DelphiLookup); +end; + +procedure InitUnwinder; +var + Addr: Pointer; +begin + { + We look to see if we can find a dynamic version of the unwinder. This + will be the case if the application used ShareExcept.pas. If it is + present, then we fire it up. Otherwise, we use our static copy. + } + Addr := dlsym(0, '_BorUnwind_RegisterIPLookup'); + if Addr <> nil then + begin + Unwinder.RegisterIPLookup := Addr; + Addr := dlsym(0, '_BorUnwind_UnregisterIPLookup'); + Unwinder.UnregisterIPLookup := Addr; + Addr := dlsym(0, '_BorUnwind_RaiseException'); + Unwinder.RaiseException := Addr; + Addr := dlsym(0, '_BorUnwind_DelphiLookup'); + Unwinder.DelphiLookup := Addr; + Addr := dlsym(0, '_BorUnwind_ClosestDelphiHandler'); + Unwinder.ClosestHandler := Addr; + end + else + begin + dlerror; // clear error state; dlsym doesn't + Unwinder.RegisterIPLookup := _BorUnwind_RegisterIPLookup; + Unwinder.DelphiLookup := _BorUnwind_DelphiLookup; + Unwinder.UnregisterIPLookup := _BorUnwind_UnregisterIPLookup; + Unwinder.RaiseException := _BorUnwind_RaiseException; + Unwinder.ClosestHandler := _BorUnwind_ClosestDelphiHandler; + end; +end; + +function SysClosestDelphiHandler(Context: Pointer): LongWord; +begin + if not Assigned(Unwinder.ClosestHandler) then + InitUnwinder; + Result := Unwinder.ClosestHandler(Context); +end; + +function SysRegisterIPLookup(StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; +begin +// xxx + if not Assigned(Unwinder.RegisterIPLookup) then + begin + InitUnwinder; +// Unwinder.RegisterIPLookup := UnwindRegisterIPLookup; +// Unwinder.DelphiLookup := UnwindDelphiLookup; + end; + Result := Unwinder.RegisterIPLookup(@Unwinder.DelphiLookup, StartAddr, EndAddr, Context, GOT); +end; + +procedure SysUnregisterIPLookup(StartAddr: LongInt); +begin +// if not Assigned(Unwinder.UnregisterIPLookup) then +// Unwinder.UnregisterIPLookup := UnwindUnregisterIPLookup; + Unwinder.UnregisterIPLookup(StartAddr); +end; + +function SysRaiseException(Exc: Pointer): LongBool; export; +var + uexc: _Unwind_Exception; +begin + uexc.exception_class := UW_EXC_CLASS_BORLANDDELPHI; + uexc.private_1 := _Unwind_Word(Exc); + uexc.private_2 := 0; + Result := Unwinder.RaiseException(@uexc); +end; + + +// SysRaiseCPPException +// Called to reraise a C++ exception that is unwinding through pascal code. +function SysRaiseCPPException(Exc: Pointer; priv2: Pointer; cls: LongWord): LongBool; +var + uexc: _Unwind_Exception; +begin + uexc.exception_class := cls; + uexc.private_1 := _Unwind_Word(Exc); + uexc.private_2 := _Unwind_Word(priv2); + Result := Unwinder.RaiseException(@uexc); +end; + +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; + +{$IFDEF PUREPASCAL} +var + notimpl: array [0..15] of Char = 'not implemented'#10; + +procedure NotImplemented; +begin + __write (2, @notimpl, 16); + Halt; +end; +{$ENDIF} + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure BlockOSExceptions; +asm + PUSH EAX + PUSH EDX + CALL SysInit.@GetTLS + MOV [EAX].OSExceptionsBlocked, 1 + POP EDX + POP EAX +end; + +procedure UnblockOSExceptions; +asm + CALL SysInit.@GetTLS + MOV [EAX].OSExceptionsBlocked, 0 +end; + +// Access to a TLS variable. Note the comment in BeginThread before +// you change the implementation of this function. +function AreOSExceptionsBlocked: Boolean; +asm + CALL SysInit.@GetTLS + MOV EAX, [EAX].OSExceptionsBlocked +end; + +const + TRAISEDEXCEPTION_SIZE = SizeOf(TRaisedException); + +function CurrentException: PRaisedException; +asm + CALL SysInit.@GetTLS + LEA EDX, [EAX].ExceptionObjects + MOV EAX, [EAX].ExceptionObjectCount + OR EAX, EAX + JE @@Done + DEC EAX + IMUL EAX, TRAISEDEXCEPTION_SIZE + ADD EAX, EDX + JMP @@Exit +@@Done: + CALL SysInit.@GetTLS + MOV EAX,[EAX].ExceptionList +@@Exit: +end; + +function CurrentPrivateException: PRaisedException; +asm + CALL SysInit.@GetTLS + LEA EDX, [EAX].ExceptionObjects + MOV EAX, [EAX].ExceptionObjectCount + OR EAX, EAX + JE @@Done + DEC EAX + IMUL EAX, TRAISEDEXCEPTION_SIZE + ADD EAX, EDX +@@Done: +end; + +{ + 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; +asm + CALL CurrentPrivateException + OR EAX, EAX + JE @@Error + { EAX -> the TRaisedException } + XOR ECX, ECX + { If the exception object has been referenced, we don't return it. } + CMP [EAX].TRaisedException.RefCount, 0 + JA @@GotObject + MOV ECX, [EAX].TRaisedException.ExceptObject +@@GotObject: + PUSH ECX + CALL SysInit.@GetTLS + POP ECX + DEC [EAX].ExceptionObjectCount + MOV EAX, ECX + RET +@@Error: + CALL SysInit.@GetTLS + MOV EAX, [EAX].ExceptionList + CALL [EAX].TRaisedException.Cleanup + RET +end; + +procedure ReleaseDelphiException; +begin + FreeException; +end; + +function AllocateException(Exception: Pointer; ExceptionAddr: Pointer): PRaisedException; +asm +{$IFDEF PIC} + PUSH EBX + PUSH EAX + PUSH EDX + CALL GetGOT + MOV EBX,EAX +{$ELSE} + PUSH EAX + PUSH EDX +{$ENDIF} + CALL SysInit.@GetTLS + CMP [EAX].ExceptionObjectCount, MAX_NESTED_EXCEPTIONS-1 + JE @@TooManyNestedExceptions + INC [EAX].ExceptionObjectCount + CALL CurrentException + POP EDX + POP ECX + MOV [EAX].TRaisedException.ExceptObject, ECX + MOV [EAX].TRaisedException.ExceptionAddr, EDX + MOV [EAX].TRaisedException.RefCount, 0 + MOV [EAX].TRaisedException.HandlerEBP, $FFFFFFFF + MOV [EAX].TRaisedException.Flags, 0 + MOV [EAX].TRaisedException.Prev, 0 +{$IFDEF PIC} + LEA EDX,[EBX].OFFSET FreeException +{$ELSE} + LEA EDX, FreeException +{$ENDIF} + MOV [EAX].TRaisedException.Cleanup, EDX +{$IFDEF PIC} + LEA EDX,[EBX].OFFSET FreeException + LEA EDX, ReleaseDelphiException +{$ELSE} + LEA EDX, ReleaseDelphiException +{$ENDIF} + MOV [EAX].TRaisedException.ReleaseProc, EDX +{$IFDEF PIC} + POP EBX +{$ENDIF} + RET +@@TooManyNestedExceptions: + MOV EAX, 231 + JMP _RunError +end; + +function AcquireExceptionObject: Pointer; +asm + CALL CurrentException + OR EAX, EAX + JE @@Error + INC [EAX].TRaisedException.RefCount + MOV EAX, [EAX].TRaisedException.ExceptObject + RET +@@Error: + { This happens if there is no exception pending } + JMP _Run0Error +end; + +procedure ReleaseExceptionObject; +asm + CALL CurrentException + OR EAX, EAX + JE @@Error + CMP [EAX].TRaisedException.RefCount, 0 + JE @@Error + DEC [EAX].TRaisedException.RefCount + RET +@@Error: + +{ + This happens if there is no exception pending, or + if the reference count on a pending exception is + zero. +} + JMP _Run0Error +end; + +function ExceptObject: TObject; +var + Exc: PRaisedException; +begin + Exc := CurrentException; + if Exc <> nil then + Result := TObject(Exc^.ExceptObject) + else + Result := nil; +end; + +{ Return current exception address } + +function ExceptAddr: Pointer; +var + Exc: PRaisedException; +begin + Exc := CurrentException; + if Exc <> nil then + Result := Exc^.ExceptionAddr + else + Result := nil; +end; +{$ELSE} {not PC_MAPPED_EXCEPTIONS} + +function ExceptObject: TObject; +begin + if RaiseListPtr <> nil then + Result := PRaiseFrame(RaiseListPtr)^.ExceptObject + else + Result := nil; +end; + +{ Return current exception address } + +function ExceptAddr: Pointer; +begin + if RaiseListPtr <> nil then + Result := PRaiseFrame(RaiseListPtr)^.ExceptAddr + else + Result := nil; +end; + + +function AcquireExceptionObject: Pointer; +begin + if RaiseListPtr <> nil then + begin + Result := PRaiseFrame(RaiseListPtr)^.ExceptObject; + PRaiseFrame(RaiseListPtr)^.ExceptObject := nil; + end + else + Result := nil; +end; + +procedure ReleaseExceptionObject; +begin +end; + +function RaiseList: Pointer; +begin + Result := RaiseListPtr; +end; + +function SetRaiseList(NewPtr: Pointer): Pointer; +asm + PUSH EAX + CALL SysInit.@GetTLS + MOV EDX, [EAX].RaiseListPtr + POP [EAX].RaiseListPtr + MOV EAX, EDX +end; +{$ENDIF} + +{ + Coverage helper glue - just go directly to the external coverage + library. NEVER put code in here, because we sometimes want to run + coverage analysis on the System unit. +} +{ + Note: names are wrong for linux, but we'll be fixing that soon. +} +procedure _CVR_PROBE; external 'coverage.dll' name '__CVR_PROBE'; +function _CVR_STMTPROBE; external 'coverage.dll' name '__CVR_STMTPROBE'; + +{ ----------------------------------------------------- } +{ local functions & procedures of the system unit } +{ ----------------------------------------------------- } + +procedure RunErrorAt(ErrCode: Integer; ErrorAtAddr: Pointer); +begin + ErrorAddr := ErrorAtAddr; + _Halt(ErrCode); +end; + +procedure ErrorAt(ErrorCode: Byte; ErrorAddr: Pointer); + +const + reMap: array [TRunTimeError] of Byte = ( + 0, { reNone } + 203, { reOutOfMemory } + 204, { reInvalidPtr } + 200, { reDivByZero } + 201, { reRangeError } +{ 210 Abstract error } + 215, { reIntOverflow } + 207, { reInvalidOp } + 200, { reZeroDivide } + 205, { reOverflow } + 206, { reUnderflow } + 219, { reInvalidCast } + 216, { reAccessViolation } + 218, { rePrivInstruction } + 217, { reControlBreak } + 202, { reStackOverflow } + 220, { reVarTypeCast } + 221, { reVarInvalidOp } + 222, { reVarDispatch } + 223, { reVarArrayCreate } + 224, { reVarNotArray } + 225, { reVarArrayBounds } +{ 226 Thread init failure } + 227, { reAssertionFailed } + 0, { reExternalException not used here; in SysUtils } + 228, { reIntfCastError } + 229 { reSafeCallError } +{$IFDEF LINUX} +{ 230 Reserved by the compiler for unhandled exceptions } +{ 231 Too many nested exceptions } +{ 232 Fatal signal raised on a non-Delphi thread } + , 233, { reQuit } + 234 { reCodesetConversion } +{$ENDIF} +); + +begin + errorCode := errorCode and 127; + if Assigned(ErrorProc) then + ErrorProc(errorCode, ErrorAddr); + if errorCode = 0 then + errorCode := InOutRes + else if errorCode <= Byte(High(TRuntimeError)) then + errorCode := reMap[TRunTimeError(errorCode)]; + RunErrorAt(errorCode, ErrorAddr); +end; + +procedure Error(errorCode: TRuntimeError); +asm + AND EAX,127 + MOV EDX,[ESP] + JMP ErrorAt +end; + +procedure __IOTest; +asm + PUSH EAX + PUSH EDX + PUSH ECX + CALL SysInit.@GetTLS + CMP [EAX].InOutRes,0 + POP ECX + POP EDX + POP EAX + JNE @error + RET +@error: + XOR EAX,EAX + JMP Error +end; + +procedure SetInOutRes(NewValue: Integer); +begin + InOutRes := NewValue; +end; + +procedure InOutError; +begin + SetInOutRes(GetLastError); +end; + +procedure ChDir(const S: string); +begin + ChDir(PChar(S)); +end; + +procedure ChDir(P: PChar); +begin +{$IFDEF MSWINDOWS} + if not SetCurrentDirectory(P) then +{$ENDIF} +{$IFDEF LINUX} + if __chdir(P) <> 0 then +{$ENDIF} + InOutError; +end; + +procedure _Copy{ s : ShortString; index, count : Integer ) : ShortString}; +asm +{ ->EAX Source string } +{ EDX index } +{ ECX count } +{ [ESP+4] Pointer to result string } + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,[ESP+8+4] + + XOR EAX,EAX + OR AL,[ESI] + JZ @@srcEmpty + +{ limit index to satisfy 1 <= index <= Length(src) } + + TEST EDX,EDX + JLE @@smallInx + CMP EDX,EAX + JG @@bigInx +@@cont1: + +{ limit count to satisfy 0 <= count <= Length(src) - index + 1 } + + SUB EAX,EDX { calculate Length(src) - index + 1 } + INC EAX + TEST ECX,ECX + JL @@smallCount + CMP ECX,EAX + JG @@bigCount +@@cont2: + + ADD ESI,EDX + + MOV [EDI],CL + INC EDI + REP MOVSB + JMP @@exit + +@@smallInx: + MOV EDX,1 + JMP @@cont1 +@@bigInx: +{ MOV EDX,EAX + JMP @@cont1 } +@@smallCount: + XOR ECX,ECX + JMP @@cont2 +@@bigCount: + MOV ECX,EAX + JMP @@cont2 +@@srcEmpty: + MOV [EDI],AL +@@exit: + POP EDI + POP ESI + RET 4 +end; + +procedure _Delete{ var s : openstring; index, count : Integer }; +asm +{ ->EAX Pointer to s } +{ EDX index } +{ ECX count } + + PUSH ESI + PUSH EDI + + MOV EDI,EAX + + XOR EAX,EAX + MOV AL,[EDI] + +{ if index not in [1 .. Length(s)] do nothing } + + TEST EDX,EDX + JLE @@exit + CMP EDX,EAX + JG @@exit + +{ limit count to [0 .. Length(s) - index + 1] } + + TEST ECX,ECX + JLE @@exit + SUB EAX,EDX { calculate Length(s) - index + 1 } + INC EAX + CMP ECX,EAX + JLE @@1 + MOV ECX,EAX +@@1: + SUB [EDI],CL { reduce Length(s) by count } + ADD EDI,EDX { point EDI to first char to be deleted } + LEA ESI,[EDI+ECX] { point ESI to first char to be preserved } + SUB EAX,ECX { #chars = Length(s) - index + 1 - count } + MOV ECX,EAX + + REP MOVSB + +@@exit: + POP EDI + POP ESI +end; + +procedure _LGetDir(D: Byte; var S: string); +{$IFDEF MSWINDOWS} +var + Drive: array[0..3] of Char; + DirBuf, SaveBuf: array[0..MAX_PATH] of Char; +begin + if D <> 0 then + begin + Drive[0] := Chr(D + Ord('A') - 1); + Drive[1] := ':'; + Drive[2] := #0; + GetCurrentDirectory(SizeOf(SaveBuf), SaveBuf); + SetCurrentDirectory(Drive); + end; + GetCurrentDirectory(SizeOf(DirBuf), DirBuf); + if D <> 0 then SetCurrentDirectory(SaveBuf); + S := DirBuf; +{$ENDIF} +{$IFDEF LINUX} +var + DirBuf: array[0..MAX_PATH] of Char; +begin + __getcwd(DirBuf, sizeof(DirBuf)); + S := string(DirBuf); +{$ENDIF} +end; + +procedure _SGetDir(D: Byte; var S: ShortString); +var + L: string; +begin + _LGetDir(D, L); + S := L; +end; + +procedure _Insert{ source : ShortString; var s : openstring; index : Integer }; +asm +{ ->EAX Pointer to source string } +{ EDX Pointer to destination string } +{ ECX Length of destination string } +{ [ESP+4] Index } + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH ECX + MOV ECX,[ESP+16+4] + SUB ESP,512 { VAR buf: ARRAY [0..511] of Char } + + MOV EBX,EDX { save pointer to s for later } + MOV ESI,EDX + + XOR EDX,EDX + MOV DL,[ESI] + INC ESI + +{ limit index to [1 .. Length(s)+1] } + + INC EDX + TEST ECX,ECX + JLE @@smallInx + CMP ECX,EDX + JG @@bigInx +@@cont1: + DEC EDX { EDX = Length(s) } + { EAX = Pointer to src } + { ESI = EBX = Pointer to s } + { ECX = Index } + +{ copy index-1 chars from s to buf } + + MOV EDI,ESP + DEC ECX + SUB EDX,ECX { EDX = remaining length of s } + REP MOVSB + +{ copy Length(src) chars from src to buf } + + XCHG EAX,ESI { save pointer into s, point ESI to src } + MOV CL,[ESI] { ECX = Length(src) (ECX was zero after rep) } + INC ESI + REP MOVSB + +{ copy remaining chars of s to buf } + + MOV ESI,EAX { restore pointer into s } + MOV ECX,EDX { copy remaining bytes of s } + REP MOVSB + +{ calculate total chars in buf } + + SUB EDI,ESP { length = bufPtr - buf } + MOV ECX,[ESP+512] { ECX = Min(length, destLength) } +{ MOV ECX,[EBP-16] }{ ECX = Min(length, destLength) } + CMP ECX,EDI + JB @@1 + MOV ECX,EDI +@@1: + MOV EDI,EBX { Point EDI to s } + MOV ESI,ESP { Point ESI to buf } + MOV [EDI],CL { Store length in s } + INC EDI + REP MOVSB { Copy length chars to s } + JMP @@exit + +@@smallInx: + MOV ECX,1 + JMP @@cont1 +@@bigInx: + MOV ECX,EDX + JMP @@cont1 + +@@exit: + ADD ESP,512+4 + POP EDI + POP ESI + POP EBX + RET 4 +end; + +function IOResult: Integer; +begin + Result := InOutRes; + InOutRes := 0; +end; + +procedure MkDir(const S: string); +begin + MkDir(PChar(s)); +end; + +procedure MkDir(P: PChar); +begin +{$IFDEF MSWINDOWS} + if not CreateDirectory(P, 0) then +{$ENDIF} +{$IFDEF LINUX} + if __mkdir(P, -1) <> 0 then +{$ENDIF} + InOutError; +end; + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The assembly implementation of function Move is subject to the + * Mozilla Public License Version 1.1 (the "License"); you may + * not use this file except in compliance with the License. + * You may obtain a copy of the License at http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is Fastcode + * + * The Initial Developer of the Original Code is Fastcode + * + * Portions created by the Initial Developer are Copyright (C) 2002-2004 + * the Initial Developer. All Rights Reserved. + * + * Contributor(s): John O'Harrow + * + * ***** END LICENSE BLOCK ***** *) +procedure Move(const Source; var Dest; count : Integer); +{$IFDEF PUREPASCAL} +var + S, D: PChar; + I: Integer; +begin + S := PChar(@Source); + D := PChar(@Dest); + if S = D then Exit; + if Cardinal(D) > Cardinal(S) then + for I := count-1 downto 0 do + D[I] := S[I] + else + for I := 0 to count-1 do + D[I] := S[I]; +end; +{$ELSE} +asm + cmp eax, edx + je @@Exit {Source = Dest} + cmp ecx, 32 + ja @@LargeMove {Count > 32 or Count < 0} + sub ecx, 8 + jg @@SmallMove +@@TinyMove: {0..8 Byte Move} + jmp dword ptr [@@JumpTable+32+ecx*4] +@@SmallMove: {9..32 Byte Move} + fild qword ptr [eax+ecx] {Load Last 8} + fild qword ptr [eax] {Load First 8} + cmp ecx, 8 + jle @@Small16 + fild qword ptr [eax+8] {Load Second 8} + cmp ecx, 16 + jle @@Small24 + fild qword ptr [eax+16] {Load Third 8} + fistp qword ptr [edx+16] {Save Third 8} +@@Small24: + fistp qword ptr [edx+8] {Save Second 8} +@@Small16: + fistp qword ptr [edx] {Save First 8} + fistp qword ptr [edx+ecx] {Save Last 8} +@@Exit: + ret + nop {4-Byte Align JumpTable} + nop +@@JumpTable: {4-Byte Aligned} + dd @@Exit, @@M01, @@M02, @@M03, @@M04, @@M05, @@M06, @@M07, @@M08 +@@LargeForwardMove: {4-Byte Aligned} + push edx + fild qword ptr [eax] {First 8} + lea eax, [eax+ecx-8] + lea ecx, [ecx+edx-8] + fild qword ptr [eax] {Last 8} + push ecx + neg ecx + and edx, -8 {8-Byte Align Writes} + lea ecx, [ecx+edx+8] + pop edx +@FwdLoop: + fild qword ptr [eax+ecx] + fistp qword ptr [edx+ecx] + add ecx, 8 + jl @FwdLoop + fistp qword ptr [edx] {Last 8} + pop edx + fistp qword ptr [edx] {First 8} + ret +@@LargeMove: + jng @@LargeDone {Count < 0} + cmp eax, edx + ja @@LargeForwardMove + sub edx, ecx + cmp eax, edx + lea edx, [edx+ecx] + jna @@LargeForwardMove + sub ecx, 8 {Backward Move} + push ecx + fild qword ptr [eax+ecx] {Last 8} + fild qword ptr [eax] {First 8} + add ecx, edx + and ecx, -8 {8-Byte Align Writes} + sub ecx, edx +@BwdLoop: + fild qword ptr [eax+ecx] + fistp qword ptr [edx+ecx] + sub ecx, 8 + jg @BwdLoop + pop ecx + fistp qword ptr [edx] {First 8} + fistp qword ptr [edx+ecx] {Last 8} +@@LargeDone: + ret +@@M01: + movzx ecx, [eax] + mov [edx], cl + ret +@@M02: + movzx ecx, word ptr [eax] + mov [edx], cx + ret +@@M03: + mov cx, [eax] + mov al, [eax+2] + mov [edx], cx + mov [edx+2], al + ret +@@M04: + mov ecx, [eax] + mov [edx], ecx + ret +@@M05: + mov ecx, [eax] + mov al, [eax+4] + mov [edx], ecx + mov [edx+4], al + ret +@@M06: + mov ecx, [eax] + mov ax, [eax+4] + mov [edx], ecx + mov [edx+4], ax + ret +@@M07: + mov ecx, [eax] + mov eax, [eax+3] + mov [edx], ecx + mov [edx+3], eax + ret +@@M08: + fild qword ptr [eax] + fistp qword ptr [edx] +end; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function GetParamStr(P: PChar; var Param: string): PChar; +var + i, Len: Integer; + Start, S, Q: PChar; +begin + while True do + begin + while (P[0] <> #0) and (P[0] <= ' ') do + P := CharNext(P); + if (P[0] = '"') and (P[1] = '"') then Inc(P, 2) else Break; + end; + Len := 0; + Start := P; + while P[0] > ' ' do + begin + if P[0] = '"' then + begin + P := CharNext(P); + while (P[0] <> #0) and (P[0] <> '"') do + begin + Q := CharNext(P); + Inc(Len, Q - P); + P := Q; + end; + if P[0] <> #0 then + P := CharNext(P); + end + else + begin + Q := CharNext(P); + Inc(Len, Q - P); + P := Q; + end; + end; + + SetLength(Param, Len); + + P := Start; + S := Pointer(Param); + i := 0; + while P[0] > ' ' do + begin + if P[0] = '"' then + begin + P := CharNext(P); + while (P[0] <> #0) and (P[0] <> '"') do + begin + Q := CharNext(P); + while P < Q do + begin + S[i] := P^; + Inc(P); + Inc(i); + end; + end; + if P[0] <> #0 then P := CharNext(P); + end + else + begin + Q := CharNext(P); + while P < Q do + begin + S[i] := P^; + Inc(P); + Inc(i); + end; + end; + end; + + Result := P; +end; +{$ENDIF} + +function ParamCount: Integer; +{$IFDEF MSWINDOWS} +var + P: PChar; + S: string; +begin + Result := 0; + P := GetParamStr(GetCommandLine, S); + while True do + begin + P := GetParamStr(P, S); + if S = '' then Break; + Inc(Result); + end; +{$ENDIF} +{$IFDEF LINUX} +begin + if ArgCount > 1 then + Result := ArgCount - 1 + else Result := 0; +{$ENDIF} +end; + +type + PCharArray = array[0..0] of PChar; + +function ParamStr(Index: Integer): string; +{$IFDEF MSWINDOWS} +var + P: PChar; + Buffer: array[0..260] of Char; +begin + Result := ''; + if Index = 0 then + SetString(Result, Buffer, GetModuleFileName(0, Buffer, SizeOf(Buffer))) + else + begin + P := GetCommandLine; + while True do + begin + P := GetParamStr(P, Result); + if (Index = 0) or (Result = '') then Break; + Dec(Index); + end; + end; +{$ENDIF} +{$IFDEF LINUX} +begin + if Index < ArgCount then + Result := PCharArray(ArgValues^)[Index] + else + Result := ''; +{$ENDIF} +end; + +procedure _Pos{ substr : ShortString; s : ShortString ) : Integer}; +asm +{ ->EAX Pointer to substr } +{ EDX Pointer to string } +{ <-EAX Position of substr in s or 0 } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX { Point ESI to substr } + MOV EDI,EDX { Point EDI to s } + + XOR ECX,ECX { ECX = Length(s) } + MOV CL,[EDI] + INC EDI { Point EDI to first char of s } + + PUSH EDI { remember s position to calculate index } + + XOR EDX,EDX { EDX = Length(substr) } + MOV DL,[ESI] + INC ESI { Point ESI to first char of substr } + + DEC EDX { EDX = Length(substr) - 1 } + JS @@fail { < 0 ? return 0 } + MOV AL,[ESI] { AL = first char of substr } + INC ESI { Point ESI to 2'nd char of substr } + + SUB ECX,EDX { #positions in s to look at } + { = Length(s) - Length(substr) + 1 } + JLE @@fail +@@loop: + REPNE SCASB + JNE @@fail + MOV EBX,ECX { save outer loop counter } + PUSH ESI { save outer loop substr pointer } + PUSH EDI { save outer loop s pointer } + + MOV ECX,EDX + REPE CMPSB + POP EDI { restore outer loop s pointer } + POP ESI { restore outer loop substr pointer } + JE @@found + MOV ECX,EBX { restore outer loop counter } + JMP @@loop + +@@fail: + POP EDX { get rid of saved s pointer } + XOR EAX,EAX + JMP @@exit + +@@found: + POP EDX { restore pointer to first char of s } + MOV EAX,EDI { EDI points of char after match } + SUB EAX,EDX { the difference is the correct index } +@@exit: + POP EDI + POP ESI + POP EBX +end; + +// 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); +begin + Byte(s^[0]) := newLength; // should also fill new space +end; + +procedure _SetString(s: PShortString; buffer: PChar; len: Byte); +begin + Byte(s^[0]) := len; + if buffer <> nil then + Move(buffer^, s^[1], len); +end; + +procedure Randomize; +{$IFDEF LINUX} +begin + RandSeed := _time(nil); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +var + Counter: Int64; +begin + if QueryPerformanceCounter(Counter) then + RandSeed := Counter + else + RandSeed := GetTickCount; +end; +{$ENDIF} + +function Random(const ARange: Integer): Integer; +{$IF DEFINED(CPU386)} +asm +{ ->EAX Range } +{ <-EAX Result } + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX + MOV ECX,[EBX].OFFSET RandSeed + IMUL EDX,[ECX],08088405H + INC EDX + MOV [ECX],EDX +{$ELSE} + XOR EBX, EBX + IMUL EDX,[EBX].RandSeed,08088405H + INC EDX + MOV [EBX].RandSeed,EDX +{$ENDIF} + MUL EDX + MOV EAX,EDX + POP EBX +end; +{$ELSEIF DEFINED(CLR)} +begin + InitRandom; + Result := RandomEngine.Next(ARange); +end; +{$ELSE} + {$MESSAGE ERROR 'Random(Int):Int unimplemented'} +{$IFEND} + +function Random: Extended; +{$IF DEFINED(CPU386)} +const two2neg32: double = ((1.0/$10000) / $10000); // 2^-32 +asm +{ FUNCTION _RandExt: Extended; } + + PUSH EBX +{$IFDEF PIC} + CALL GetGOT + MOV EBX,EAX + MOV ECX,[EBX].OFFSET RandSeed + IMUL EDX,[ECX],08088405H + INC EDX + MOV [ECX],EDX +{$ELSE} + XOR EBX, EBX + IMUL EDX,[EBX].RandSeed,08088405H + INC EDX + MOV [EBX].RandSeed,EDX +{$ENDIF} + + FLD [EBX].two2neg32 + PUSH 0 + PUSH EDX + FILD qword ptr [ESP] + ADD ESP,8 + FMULP ST(1), ST(0) + POP EBX +end; +{$ELSEIF DEFINED(CLR)} +begin + InitRandom; + Result := RandomEngine.NextDouble; +end; +{$ELSE} + {$MESSAGE ERROR 'Random:Extended unimplemented'} +{$IFEND} + +procedure RmDir(const S: string); +begin + RmDir(PChar(s)); +end; + +procedure RmDir(P: PChar); +begin +{$IFDEF MSWINDOWS} + if not RemoveDirectory(P) then +{$ENDIF} +{$IFDEF LINUX} + if __rmdir(P) <> 0 then +{$ENDIF} + InOutError; +end; + +function UpCase( ch : Char ) : Char; +{$IFDEF PUREPASCAL} +begin + Result := ch; + case Result of + 'a'..'z': Dec(Result, Ord('a') - Ord('A')); + end; +end; +{$ELSE} +asm +{ -> AL Character } +{ <- AL Result } + + CMP AL,'a' + JB @@exit + CMP AL,'z' + JA @@exit + SUB AL,'a' - 'A' +@@exit: +end; +{$ENDIF} + +procedure Set8087CW(NewCW: Word); +begin + Default8087CW := NewCW; + asm + FNCLEX // don't raise pending exceptions enabled by the new flags +{$IFDEF PIC} + MOV EAX,[EBX].OFFSET Default8087CW + FLDCW [EAX] +{$ELSE} + FLDCW Default8087CW +{$ENDIF} + end; +end; + +function Get8087CW: Word; +asm + PUSH 0 + FNSTCW [ESP].Word + POP EAX +end; + + +function Int(const X: Extended): Extended; +asm + FLD X + SUB ESP,4 + FNSTCW [ESP].Word // save + FNSTCW [ESP+2].Word // scratch + FWAIT + OR [ESP+2].Word, $0F00 // trunc toward zero, full precision + FLDCW [ESP+2].Word + FRNDINT + FWAIT + FLDCW [ESP].Word + ADD ESP,4 +end; + +function Frac(const X: Extended): Extended; +asm + FLD X + FLD ST(0) + SUB ESP,4 + FNSTCW [ESP].Word // save + FNSTCW [ESP+2].Word // scratch + FWAIT + OR [ESP+2].Word, $0F00 // trunc toward zero, full precision + FLDCW [ESP+2].Word + FRNDINT + FWAIT + FLDCW [ESP].Word + ADD ESP,4 + FSUB +end; + +function Exp(const X: Extended): Extended; +asm + { e**x = 2**(x*log2(e)) } + FLD X + FLDL2E { y := x*log2e; } + FMUL + FLD ST(0) { i := round(y); } + FRNDINT + FSUB ST(1), ST { f := y - i; } + FXCH ST(1) { z := 2**f } + F2XM1 + FLD1 + FADD + FSCALE { result := z * 2**i } + FSTP ST(1) +end; + +function Cos(const X: Extended): Extended; +asm + FLD X + FCOS + FWAIT +end; + +function Sin(const X: Extended): Extended; +asm + FLD X + FSIN + FWAIT +end; + +function Ln(const X: Extended): Extended; +asm + FLD X + FLDLN2 + FXCH + FYL2X + FWAIT +end; + +function ArcTan(const X: Extended): Extended; +asm + FLD X + FLD1 + FPATAN + FWAIT +end; + +function Sqrt(const X: Extended): Extended; +asm + FLD X + FSQRT + FWAIT +end; + +{ ----------------------------------------------------- } +{ functions & procedures that need compiler magic } +{ ----------------------------------------------------- } + +procedure _ROUND; +asm + { -> FST(0) Extended argument } + { <- EDX:EAX Result } + + SUB ESP,8 + FISTP qword ptr [ESP] + FWAIT + POP EAX + POP EDX +end; + +procedure _TRUNC; +asm + { -> FST(0) Extended argument } + { <- EDX:EAX Result } + + SUB ESP,12 + FNSTCW [ESP].Word // save + FNSTCW [ESP+2].Word // scratch + FWAIT + OR [ESP+2].Word, $0F00 // trunc toward zero, full precision + FLDCW [ESP+2].Word + FISTP qword ptr [ESP+4] + FWAIT + FLDCW [ESP].Word + POP ECX + POP EAX + POP EDX +end; + +procedure _AbstractError; +{$IFDEF PIC} +begin + if Assigned(AbstractErrorProc) then + AbstractErrorProc; + _RunError(210); // loses return address +end; +{$ELSE} +asm + CMP AbstractErrorProc, 0 + JE @@NoAbstErrProc + CALL AbstractErrorProc + +@@NoAbstErrProc: + MOV EAX,210 + JMP _RunError +end; +{$ENDIF} + +function TextOpen(var t: TTextRec): Integer; forward; + +function OpenText(var t: TTextRec; Mode: Word): Integer; +begin + if (t.Mode < fmClosed) or (t.Mode > fmInOut) then + Result := 102 + else + begin + if t.Mode <> fmClosed then _Close(t); + t.Mode := Mode; + if (t.Name[0] = #0) and (t.OpenFunc = nil) then // stdio + t.OpenFunc := @TextOpen; + Result := TTextIOFunc(t.OpenFunc)(t); + end; + if Result <> 0 then SetInOutRes(Result); +end; + +function _ResetText(var t: TTextRec): Integer; +begin + Result := OpenText(t, fmInput); +end; + +function _RewritText(var t: TTextRec): Integer; +begin + Result := OpenText(t, fmOutput); +end; + +function _Append(var t: TTextRec): Integer; +begin + Result := OpenText(t, fmInOut); +end; + +function TextIn(var t: TTextRec): Integer; +const + ERROR_BROKEN_PIPE = 109; +begin + t.BufEnd := 0; + t.BufPos := 0; +{$IFDEF LINUX} + t.BufEnd := __read(t.Handle, t.BufPtr, t.BufSize); + if Integer(t.BufEnd) = -1 then + begin + t.BufEnd := 0; + Result := GetLastError; + end + else + Result := 0; +{$ENDIF} +{$IFDEF MSWINDOWS} + if ReadFile(t.Handle, t.BufPtr^, t.BufSize, t.BufEnd, nil) = 0 then + begin + Result := GetLastError; + if Result = ERROR_BROKEN_PIPE then + Result := 0; // NT quirk: got "broken pipe"? it's really eof + end + else + Result := 0; +{$ENDIF} +end; + +function FileNOPProc(var t): Integer; +begin + Result := 0; +end; + +function TextOut(var t: TTextRec): Integer; +{$IFDEF MSWINDOWS} +var + Dummy: Cardinal; +{$ENDIF} +begin + if t.BufPos = 0 then + Result := 0 + else + begin +{$IFDEF LINUX} + if __write(t.Handle, t.BufPtr, t.BufPos) = Cardinal(-1) then +{$ENDIF} +{$IFDEF MSWINDOWS} + if WriteFile(t.Handle, t.BufPtr^, t.BufPos, Dummy, nil) = 0 then +{$ENDIF} + Result := GetLastError + else + Result := 0; + t.BufPos := 0; + end; +end; + +function InternalClose(Handle: Integer): Boolean; +begin +{$IFDEF LINUX} + Result := __close(Handle) = 0; +{$ENDIF} +{$IFDEF MSWINDOWS} + Result := CloseHandle(Handle) = 1; +{$ENDIF} +end; + +function TextClose(var t: TTextRec): Integer; +begin + t.Mode := fmClosed; + if not InternalClose(t.Handle) then + Result := GetLastError + else + Result := 0; +end; + +function TextOpenCleanup(var t: TTextRec): Integer; +begin + InternalClose(t.Handle); + t.Mode := fmClosed; + Result := GetLastError; +end; + +function TextOpen(var t: TTextRec): Integer; +{$IFDEF LINUX} +var + Flags: Integer; + Temp, I: Integer; + BytesRead: Integer; +begin + Result := 0; + t.BufPos := 0; + t.BufEnd := 0; + case t.Mode of + fmInput: // called by Reset + begin + Flags := O_RDONLY; + t.InOutFunc := @TextIn; + end; + fmOutput: // called by Rewrite + begin + Flags := O_CREAT or O_TRUNC or O_WRONLY; + t.InOutFunc := @TextOut; + end; + fmInOut: // called by Append + begin + Flags := O_APPEND or O_RDWR; + t.InOutFunc := @TextOut; + end; + else + Exit; + Flags := 0; + end; + + t.FlushFunc := @FileNOPProc; + + if t.Name[0] = #0 then // stdin or stdout + begin + if t.BufPtr = nil then // don't overwrite bufptr provided by SetTextBuf + begin + t.BufPtr := @t.Buffer; + t.BufSize := sizeof(t.Buffer); + end; + t.CloseFunc := @FileNOPProc; + if t.Mode = fmOutput then + begin + if @t = @ErrOutput then + t.Handle := STDERR_FILENO + else + t.Handle := STDOUT_FILENO; + t.FlushFunc := @TextOut; + end + else + t.Handle := STDIN_FILENO; + end + else + begin + t.CloseFunc := @TextClose; + + Temp := __open(t.Name, Flags, FileAccessRights); + if Temp = -1 then + begin + t.Mode := fmClosed; + Result := GetLastError; + Exit; + end; + + t.Handle := Temp; + + if t.Mode = fmInOut then // Append mode + begin + t.Mode := fmOutput; + + if (t.flags and tfCRLF) <> 0 then // DOS mode, EOF significant + begin // scan for EOF char in last 128 byte sector. + Temp := _lseek(t.Handle, 0, SEEK_END); + if Temp = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + Dec(Temp, 128); + if Temp < 0 then Temp := 0; + + if _lseek(t.Handle, Temp, SEEK_SET) = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + BytesRead := __read(t.Handle, t.BufPtr, 128); + if BytesRead = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + for I := 0 to BytesRead - 1 do + begin + if t.Buffer[I] = Char(cEOF) then + begin // truncate the file here + if _ftruncate(t.Handle, _lseek(t.Handle, I - BytesRead, SEEK_END)) = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + Break; + end; + end; + end; + end; + end; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +(* +var + OpenMode: Integer; + Flags, Std: ShortInt; + Temp: Integer; + I, BytesRead: Cardinal; + Mode: Byte; +begin + Result := 0; + if (t.Mode - fmInput) > (fmInOut - fmInput) then Exit; + Mode := t.Mode and 3; + t.BufPos := 0; + t.BufEnd := 0; + t.FlushFunc := @FileNOPProc; + + if t.Name[0] = #0 then // stdin or stdout + begin + t.BufPtr := @t.Buffer; + t.BufSize := sizeof(t.Buffer); + t.CloseFunc := @FileNOPProc; + if Mode = (fmOutput and 3) then + begin + t.InOutFunc := @TextOut; + if @t = @ErrOutput then + Std := STD_ERROR_HANDLE + else + Std := STD_OUTPUT_HANDLE; + end + else + begin + t.InOutFunc := @TextIn; + Std := STD_INPUT_HANDLE; + end; + t.Handle := GetStdHandle(Std); + end + else + begin + t.CloseFunc := @TextClose; + + Flags := OPEN_EXISTING; + if Mode = (fmInput and 3) then + begin // called by Reset + t.InOutFunc := @TextIn; + OpenMode := GENERIC_READ; // open for read + end + else + begin + t.InOutFunc := @TextOut; + if Mode = (fmInOut and 3) then // called by Append + OpenMode := GENERIC_READ OR GENERIC_WRITE // open for read/write + else + begin // called by Rewrite + OpenMode := GENERIC_WRITE; // open for write + Flags := CREATE_ALWAYS; + end; + end; + + Temp := CreateFileA(t.Name, OpenMode, FILE_SHARE_READ, nil, Flags, FILE_ATTRIBUTE_NORMAL, 0); + if Temp = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + t.Handle := Temp; + + if Mode = (fmInOut and 3) then + begin + Dec(t.Mode); // fmInOut -> fmOutput + +{; ??? we really have to look for the first eof byte in the +; ??? last record and truncate the file there. +; Not very nice and clean... +; +; lastRecPos = Max( GetFileSize(...) - 128, 0); +} + Temp := GetFileSize(t.Handle, 0); + if Temp = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + Dec(Temp, 128); + if Temp < 0 then Temp := 0; + + if (SetFilePointer(t.Handle, Temp, nil, FILE_BEGIN) = -1) or + (ReadFile(t.Handle, t.Buffer, 128, BytesRead, nil) = 0) then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + for I := 0 to BytesRead do + begin + if t.Buffer[I] = Char(cEOF) then + begin // truncate the file here + if (SetFilePointer(t.Handle, I - BytesRead, nil, FILE_END) = -1) or + (not SetEndOfFile(t.Handle)) then + begin + Result := TextOpenCleanup(t); + Exit; + end; + Break; + end; + end; + end; + if Mode <> (fmInput and 3) then + begin + case GetFileType(t.Handle) of + 0: begin // bad file type + TextOpenCleanup(t); + Result := 105; + Exit; + end; + 2: t.FlushFunc := @TextOut; + end; + end; + end; +end; +*) + +asm +// -> EAX Pointer to text record + + PUSH ESI + + MOV ESI,EAX + + XOR EAX,EAX + MOV [ESI].TTextRec.BufPos,EAX + MOV [ESI].TTextRec.BufEnd,EAX + MOV AX,[ESI].TTextRec.Mode + + SUB EAX,fmInput + JE @@calledByReset + + DEC EAX + JE @@calledByRewrite + + DEC EAX + JE @@calledByAppend + + JMP @@exit + +@@calledByReset: + + MOV EAX,GENERIC_READ // open for read + MOV EDX,FILE_SHARE_READ + MOV ECX,OPEN_EXISTING + + MOV [ESI].TTextRec.InOutFunc,offset TextIn + + JMP @@common + +@@calledByRewrite: + + MOV EAX,GENERIC_WRITE // open for write + MOV EDX,FILE_SHARE_READ + MOV ECX,CREATE_ALWAYS + JMP @@commonOut + +@@calledByAppend: + + MOV EAX,GENERIC_READ OR GENERIC_WRITE // open for read/write + MOV EDX,FILE_SHARE_READ + MOV ECX,OPEN_EXISTING + +@@commonOut: + + MOV [ESI].TTextRec.InOutFunc,offset TextOut + +@@common: + + MOV [ESI].TTextRec.CloseFunc,offset TextClose + MOV [ESI].TTextRec.FlushFunc,offset FileNOPProc + CMP byte ptr [ESI].TTextRec.Name,0 + JE @@isCon + +// CreateFile(t.Name, EAX, EDX, Nil, ECX, FILE_ATTRIBUTE_NORMAL, 0); + + PUSH 0 + PUSH FILE_ATTRIBUTE_NORMAL + PUSH ECX + PUSH 0 + PUSH EDX + PUSH EAX + LEA EAX,[ESI].TTextRec.Name + PUSH EAX + CALL CreateFileA + + CMP EAX,-1 + JZ @@error + + MOV [ESI].TTextRec.Handle,EAX + CMP [ESI].TTextRec.Mode,fmInOut + JNE @@success + + DEC [ESI].TTextRec.Mode // fmInOut -> fmOutput + +{; ??? we really have to look for the first eof byte in the +; ??? last record and truncate the file there. +; Not very nice and clean... +; +; lastRecPos = Max( GetFileSize(...) - 128, 0); +} + PUSH 0 + PUSH [ESI].TTextRec.Handle + CALL GetFileSize + + INC EAX + JZ @@error + SUB EAX,129 + JNC @@3 + XOR EAX,EAX +@@3: +// lseek(f.Handle, SEEK_SET, lastRecPos); + + PUSH FILE_BEGIN + PUSH 0 + PUSH EAX + PUSH [ESI].TTextRec.Handle + CALL SetFilePointer + + INC EAX + JE @@error + +// bytesRead = read(f.Handle, f.Buffer, 128); + + PUSH 0 + MOV EDX,ESP + PUSH 0 + PUSH EDX + PUSH 128 + LEA EDX,[ESI].TTextRec.Buffer + PUSH EDX + PUSH [ESI].TTextRec.Handle + CALL ReadFile + POP EDX + DEC EAX + JNZ @@error + +// for (i = 0; i < bytesRead; i++) + + XOR EAX,EAX +@@loop: + CMP EAX,EDX + JAE @@success + +// if (f.Buffer[i] == eof) + + CMP byte ptr [ESI].TTextRec.Buffer[EAX],eof + JE @@truncate + INC EAX + JMP @@loop + +@@truncate: + +// lseek( f.Handle, SEEK_END, i - bytesRead ); + + PUSH FILE_END + PUSH 0 + SUB EAX,EDX + PUSH EAX + PUSH [ESI].TTextRec.Handle + CALL SetFilePointer + INC EAX + JE @@error + +// SetEndOfFile( f.Handle ); + + PUSH [ESI].TTextRec.Handle + CALL SetEndOfFile + DEC EAX + JNE @@error + + JMP @@success + +@@isCon: + LEA EAX,[ESI].TTextRec.Buffer + MOV [ESI].TTextRec.BufSize, TYPE TTextRec.Buffer + MOV [ESI].TTextRec.CloseFunc,offset FileNOPProc + MOV [ESI].TTextRec.BufPtr,EAX + CMP [ESI].TTextRec.Mode,fmOutput + JE @@output + PUSH STD_INPUT_HANDLE + JMP @@1 +@@output: + CMP ESI,offset ErrOutput + JNE @@stdout + PUSH STD_ERROR_HANDLE + JMP @@1 +@@stdout: + PUSH STD_OUTPUT_HANDLE +@@1: + CALL GetStdHandle + CMP EAX,-1 + JE @@error + MOV [ESI].TTextRec.Handle,EAX + +@@success: + CMP [ESI].TTextRec.Mode,fmInput + JE @@2 + PUSH [ESI].TTextRec.Handle + CALL GetFileType + TEST EAX,EAX + JE @@badFileType + CMP EAX,2 + JNE @@2 + MOV [ESI].TTextRec.FlushFunc,offset TextOut +@@2: + XOR EAX,EAX +@@exit: + POP ESI + RET + +@@badFileType: + PUSH [ESI].TTextRec.Handle + CALL CloseHandle + MOV [ESI].TTextRec.Mode,fmClosed + MOV EAX,105 + JMP @@exit + +@@error: + MOV [ESI].TTextRec.Mode,fmClosed + CALL GetLastError + JMP @@exit +end; +{$ENDIF} + +const + fNameLen = 260; + +function _Assign(var t: TTextRec; const s: String): Integer; +begin + FillChar(t, sizeof(TFileRec), 0); + t.BufPtr := @t.Buffer; + t.Mode := fmClosed; + t.Flags := tfCRLF * Byte(DefaultTextLineBreakStyle); + t.BufSize := sizeof(t.Buffer); + t.OpenFunc := @TextOpen; + Move(S[1], t.Name, Length(s)); + t.Name[Length(s)] := #0; + Result := 0; +end; + +function InternalFlush(var t: TTextRec; Func: TTextIOFunc): Integer; +begin + case t.Mode of + fmOutput, + fmInOut : Result := Func(t); + fmInput : Result := 0; + else + if (@t = @Output) or (@t = @ErrOutput) then + Result := 0 + else + Result := 103; + end; + if Result <> 0 then SetInOutRes(Result); +end; + +function Flush(var t: Text): Integer; +begin + Result := InternalFlush(TTextRec(t), TTextRec(t).InOutFunc); +end; + +function _Flush(var t: TTextRec): Integer; +begin + Result := InternalFlush(t, t.FlushFunc); +end; + +type +{$IFDEF MSWINDOWS} + 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'; + +{$ENDIF} +{$IFDEF LINUX} + TIOProc = function (Handle: Integer; Buffer: Pointer; Count: Cardinal): Cardinal; cdecl; +{$ENDIF} + +function BlockIO(var f: TFileRec; buffer: Pointer; recCnt: Cardinal; var recsDone: Longint; + ModeMask: Integer; IOProc: TIOProc; ErrorNo: Integer): Cardinal; +// Note: RecsDone ptr can be nil! +begin + if (f.Mode and ModeMask) = ModeMask then // fmOutput or fmInOut / fmInput or fmInOut + begin +{$IFDEF LINUX} + Result := IOProc(f.Handle, buffer, recCnt * f.RecSize); + if Integer(Result) = -1 then +{$ENDIF} +{$IFDEF MSWINDOWS} + if IOProc(f.Handle, buffer, recCnt * f.RecSize, Result, nil) = 0 then +{$ENDIF} + begin + SetInOutRes(GetLastError); + Result := 0; + end + else + begin + Result := Result div f.RecSize; + if @RecsDone <> nil then + RecsDone := Result + else if Result <> recCnt then + begin + SetInOutRes(ErrorNo); + Result := 0; + end + end; + end + else + begin + SetInOutRes(103); // file not open + Result := 0; + end; +end; + +function _BlockRead(var f: TFileRec; buffer: Pointer; recCnt: Longint; var recsRead: Longint): Longint; +begin + Result := BlockIO(f, buffer, recCnt, recsRead, fmInput, + {$IFDEF MSWINDOWS} ReadFileX, {$ENDIF} + {$IFDEF LINUX} __read, {$ENDIF} + 100); +end; + +function _BlockWrite(var f: TFileRec; buffer: Pointer; recCnt: Longint; var recsWritten: Longint): Longint; +begin + Result := BlockIO(f, buffer, recCnt, recsWritten, fmOutput, + {$IFDEF MSWINDOWS} WriteFileX, {$ENDIF} + {$IFDEF LINUX} __write, {$ENDIF} + 101); +end; + +function _Close(var t: TTextRec): Integer; +begin + Result := 0; + if (t.Mode >= fmInput) and (t.Mode <= fmInOut) then + begin + if (t.Mode and fmOutput) = fmOutput then // fmOutput or fmInOut + Result := TTextIOFunc(t.InOutFunc)(t); + if Result = 0 then + Result := TTextIOFunc(t.CloseFunc)(t); + if Result <> 0 then + SetInOutRes(Result); + end + else + if @t <> @Input then + SetInOutRes(103); +end; + +procedure _PStrCat; +asm +{ ->EAX = Pointer to destination string } +{ EDX = Pointer to source string } + + PUSH ESI + PUSH EDI + +{ load dest len into EAX } + + MOV EDI,EAX + XOR EAX,EAX + MOV AL,[EDI] + +{ load source address in ESI, source len in ECX } + + MOV ESI,EDX + XOR ECX,ECX + MOV CL,[ESI] + INC ESI + +{ calculate final length in DL and store it in the destination } + + MOV DL,AL + ADD DL,CL + JC @@trunc + +@@cont: + MOV [EDI],DL + +{ calculate final dest address } + + INC EDI + ADD EDI,EAX + +{ do the copy } + + REP MOVSB + +{ done } + + POP EDI + POP ESI + RET + +@@trunc: + INC DL { DL = #chars to truncate } + SUB CL,DL { CL = source len - #chars to truncate } + MOV DL,255 { DL = maximum length } + JMP @@cont +end; + +procedure _PStrNCat; +asm +{ ->EAX = Pointer to destination string } +{ EDX = Pointer to source string } +{ CL = max length of result (allocated size of dest - 1) } + + PUSH ESI + PUSH EDI + +{ load dest len into EAX } + + MOV EDI,EAX + XOR EAX,EAX + MOV AL,[EDI] + +{ load source address in ESI, source len in EDX } + + MOV ESI,EDX + XOR EDX,EDX + MOV DL,[ESI] + INC ESI + +{ calculate final length in AL and store it in the destination } + + ADD AL,DL + JC @@trunc + CMP AL,CL + JA @@trunc + +@@cont: + MOV ECX,EDX + MOV DL,[EDI] + MOV [EDI],AL + +{ calculate final dest address } + + INC EDI + ADD EDI,EDX + +{ do the copy } + + REP MOVSB + +@@done: + POP EDI + POP ESI + RET + +@@trunc: +{ CL = maxlen } + + MOV AL,CL { AL = final length = maxlen } + SUB CL,[EDI] { CL = length to copy = maxlen - destlen } + JBE @@done + MOV DL,CL + JMP @@cont +end; + +procedure _PStrCpy(Dest: PShortString; Source: PShortString); +begin + Move(Source^, Dest^, Byte(Source^[0])+1); +end; + +procedure _PStrNCpy(Dest: PShortString; Source: PShortString; MaxLen: Byte); +begin + if MaxLen > Byte(Source^[0]) then + MaxLen := Byte(Source^[0]); + Byte(Dest^[0]) := MaxLen; + Move(Source^[1], Dest^[1], MaxLen); +end; + +procedure _PStrCmp; +asm +{ ->EAX = Pointer to left string } +{ EDX = Pointer to right string } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + XOR EAX,EAX + XOR EDX,EDX + MOV AL,[ESI] + MOV DL,[EDI] + INC ESI + INC EDI + + SUB EAX,EDX { eax = len1 - len2 } + JA @@skip1 + ADD EDX,EAX { edx = len2 + (len1 - len2) = len1 } + +@@skip1: + PUSH EDX + SHR EDX,2 + JE @@cmpRest +@@longLoop: + MOV ECX,[ESI] + MOV EBX,[EDI] + CMP ECX,EBX + JNE @@misMatch + DEC EDX + JE @@cmpRestP4 + MOV ECX,[ESI+4] + MOV EBX,[EDI+4] + CMP ECX,EBX + JNE @@misMatch + ADD ESI,8 + ADD EDI,8 + DEC EDX + JNE @@longLoop + JMP @@cmpRest +@@cmpRestP4: + ADD ESI,4 + ADD EDI,4 +@@cmpRest: + POP EDX + AND EDX,3 + JE @@equal + + MOV CL,[ESI] + CMP CL,[EDI] + JNE @@exit + DEC EDX + JE @@equal + MOV CL,[ESI+1] + CMP CL,[EDI+1] + JNE @@exit + DEC EDX + JE @@equal + MOV CL,[ESI+2] + CMP CL,[EDI+2] + JNE @@exit + +@@equal: + ADD EAX,EAX + JMP @@exit + +@@misMatch: + POP EDX + CMP CL,BL + JNE @@exit + CMP CH,BH + JNE @@exit + SHR ECX,16 + SHR EBX,16 + CMP CL,BL + JNE @@exit + CMP CH,BH + +@@exit: + POP EDI + POP ESI + POP EBX +end; + +procedure _AStrCmp; +asm +{ ->EAX = Pointer to left string } +{ EDX = Pointer to right string } +{ ECX = Number of chars to compare} + + PUSH EBX + PUSH ESI + PUSH ECX + MOV ESI,ECX + SHR ESI,2 + JE @@cmpRest + +@@longLoop: + MOV ECX,[EAX] + MOV EBX,[EDX] + CMP ECX,EBX + JNE @@misMatch + DEC ESI + JE @@cmpRestP4 + MOV ECX,[EAX+4] + MOV EBX,[EDX+4] + CMP ECX,EBX + JNE @@misMatch + ADD EAX,8 + ADD EDX,8 + DEC ESI + JNE @@longLoop + JMP @@cmpRest +@@cmpRestp4: + ADD EAX,4 + ADD EDX,4 +@@cmpRest: + POP ESI + AND ESI,3 + JE @@exit + + MOV CL,[EAX] + CMP CL,[EDX] + JNE @@exit + DEC ESI + JE @@equal + MOV CL,[EAX+1] + CMP CL,[EDX+1] + JNE @@exit + DEC ESI + JE @@equal + MOV CL,[EAX+2] + CMP CL,[EDX+2] + JNE @@exit + +@@equal: + XOR EAX,EAX + JMP @@exit + +@@misMatch: + POP ESI + CMP CL,BL + JNE @@exit + CMP CH,BH + JNE @@exit + SHR ECX,16 + SHR EBX,16 + CMP CL,BL + JNE @@exit + CMP CH,BH + +@@exit: + POP ESI + POP EBX +end; + +function _EofFile(var f: TFileRec): Boolean; +begin + Result := _FilePos(f) >= _FileSize(f); +end; + +function _EofText(var t: TTextRec): Boolean; +asm +// -> EAX Pointer to text record +// <- AL Boolean result + CMP [EAX].TTextRec.Mode,fmInput + JNE @@readChar + MOV EDX,[EAX].TTextRec.BufPos + CMP EDX,[EAX].TTextRec.BufEnd + JAE @@readChar + ADD EDX,[EAX].TTextRec.BufPtr + TEST [EAX].TTextRec.Flags,tfCRLF + JZ @@FalseExit + MOV CL,[EDX] + CMP CL,cEof + JNZ @@FalseExit + +@@eof: + MOV AL,1 + JMP @@exit + +@@readChar: + PUSH EAX + CALL _ReadChar + POP EDX + CMP AH,cEof + JE @@eof + DEC [EDX].TTextRec.BufPos +@@FalseExit: + XOR EAX,EAX +@@exit: +end; + +function _Eoln(var t: TTextRec): Boolean; +asm +// -> EAX Pointer to text record +// <- AL Boolean result + + CMP [EAX].TTextRec.Mode,fmInput + JNE @@readChar + MOV EDX,[EAX].TTextRec.BufPos + CMP EDX,[EAX].TTextRec.BufEnd + JAE @@readChar + ADD EDX,[EAX].TTextRec.BufPtr + TEST [EAX].TTextRec.Flags,tfCRLF + MOV AL,0 + MOV CL,[EDX] + JZ @@testLF + CMP CL,cCR + JE @@eol + CMP CL,cEOF + JE @@eof + JMP @@exit + +@@testLF: + CMP CL,cLF + JE @@eol + CMP CL,cEOF + JE @@eof + JMP @@exit + +@@readChar: + PUSH EAX + CALL _ReadChar + POP EDX + CMP AH,cEOF + JE @@eof + DEC [EDX].TTextRec.BufPos + XOR ECX,ECX + XCHG ECX,EAX + TEST [EDX].TTextRec.Mode,tfCRLF + JE @@testLF + CMP CL,cCR + JE @@eol + JMP @@exit + +@@eol: +@@eof: + MOV AL,1 +@@exit: +end; + +procedure _Erase(var f: TFileRec); +begin + if (f.Mode < fmClosed) or (f.Mode > fmInOut) then + SetInOutRes(102) // file not assigned + else +{$IFDEF LINUX} + if __remove(f.Name) < 0 then + SetInOutRes(GetLastError); +{$ENDIF} +{$IFDEF MSWINDOWS} + if not DeleteFileA(f.Name) then + SetInOutRes(GetLastError); +{$ENDIF} +end; + +{$IFDEF MSWINDOWS} +// Floating-point divide reverse routine +// ST(1) = ST(0) / ST(1), pop ST + +procedure _FSafeDivideR; +asm + FXCH + JMP _FSafeDivide +end; + +// Floating-point divide routine +// ST(1) = ST(1) / ST(0), pop ST + +procedure _FSafeDivide; +type + Z = packed record // helper type to make parameter references more readable + Dividend: Extended; // (TBYTE PTR [ESP]) + Pad: Word; + Divisor: Extended; // (TBYTE PTR [ESP+12]) + end; +asm + CMP TestFDIV,0 //Check FDIV indicator + JLE @@FDivideChecked //Jump if flawed or don't know + FDIV //Known to be ok, so just do FDIV + RET + +// FDIV constants +@@FDIVRiscTable: DB 0,1,0,0,4,0,0,7,0,0,10,0,0,13,0,0; + +@@FDIVScale1: DD $3F700000 // 0.9375 +@@FDIVScale2: DD $3F880000 // 1.0625 +@@FDIV1SHL63: DD $5F000000 // 1 SHL 63 + +@@TestDividend: DD $C0000000,$4150017E // 4195835.0 +@@TestDivisor: DD $80000000,$4147FFFF // 3145727.0 +@@TestOne: DD $00000000,$3FF00000 // 1.0 + +// Flawed FDIV detection +@@FDivideDetect: + MOV TestFDIV,1 //Indicate correct FDIV + PUSH EAX + SUB ESP,12 + FSTP TBYTE PTR [ESP] //Save off ST + FLD QWORD PTR @@TestDividend //Ok if x - (x / y) * y < 1.0 + FDIV QWORD PTR @@TestDivisor + FMUL QWORD PTR @@TestDivisor + FSUBR QWORD PTR @@TestDividend + FCOMP QWORD PTR @@TestOne + FSTSW AX + SHR EAX,7 + AND EAX,002H //Zero if FDIV is flawed + DEC EAX + MOV TestFDIV,AL //1 means Ok, -1 means flawed + FLD TBYTE PTR [ESP] //Restore ST + ADD ESP,12 + POP EAX + JMP _FSafeDivide + +@@FDivideChecked: + JE @@FDivideDetect //Do detection if TestFDIV = 0 + +@@1: PUSH EAX + SUB ESP,24 + FSTP [ESP].Z.Divisor //Store Divisor and Dividend + FSTP [ESP].Z.Dividend + FLD [ESP].Z.Dividend + FLD [ESP].Z.Divisor +@@2: MOV EAX,DWORD PTR [ESP+4].Z.Divisor //Is Divisor a denormal? + ADD EAX,EAX + JNC @@20 //Yes, @@20 + XOR EAX,0E000000H //If these three bits are not all + TEST EAX,0E000000H //ones, FDIV will work + JZ @@10 //Jump if all ones +@@3: FDIV //Do FDIV and exit + ADD ESP,24 + POP EAX + RET + +@@10: SHR EAX,28 //If the four bits following the MSB + //of the mantissa have a decimal + //of 1, 4, 7, 10, or 13, FDIV may + CMP byte ptr @@FDIVRiscTable[EAX],0 //not work correctly + JZ @@3 //Do FDIV if not 1, 4, 7, 10, or 13 + MOV EAX,DWORD PTR [ESP+8].Z.Divisor //Get Divisor exponent + AND EAX,7FFFH + JZ @@3 //Ok to FDIV if denormal + CMP EAX,7FFFH + JE @@3 //Ok to FDIV if NAN or INF + MOV EAX,DWORD PTR [ESP+8].Z.Dividend //Get Dividend exponent + AND EAX,7FFFH + CMP EAX,1 //Small number? + JE @@11 //Yes, @@11 + FMUL DWORD PTR @@FDIVScale1 //Scale by 15/16 + FXCH + FMUL DWORD PTR @@FDIVScale1 + FXCH + JMP @@3 //FDIV is now safe + +@@11: FMUL DWORD PTR @@FDIVScale2 //Scale by 17/16 + FXCH + FMUL DWORD PTR @@FDIVScale2 + FXCH + JMP @@3 //FDIV is now safe + +@@20: MOV EAX,DWORD PTR [ESP].Z.Divisor //Is entire Divisor zero? + OR EAX,DWORD PTR [ESP+4].Z.Divisor + JZ @@3 //Yes, ok to FDIV + MOV EAX,DWORD PTR [ESP+8].Z.Divisor //Get Divisor exponent + AND EAX,7FFFH //Non-zero exponent is invalid + JNZ @@3 //Ok to FDIV if invalid + MOV EAX,DWORD PTR [ESP+8].Z.Dividend //Get Dividend exponent + AND EAX,7FFFH //Denormal? + JZ @@21 //Yes, @@21 + CMP EAX,7FFFH //NAN or INF? + JE @@3 //Yes, ok to FDIV + MOV EAX,DWORD PTR [ESP+4].Z.Dividend //If MSB of mantissa is zero, + ADD EAX,EAX //the number is invalid + JNC @@3 //Ok to FDIV if invalid + JMP @@22 +@@21: MOV EAX,DWORD PTR [ESP+4].Z.Dividend //If MSB of mantissa is zero, + ADD EAX,EAX //the number is invalid + JC @@3 //Ok to FDIV if invalid +@@22: FXCH //Scale stored Divisor image by + FSTP ST(0) //1 SHL 63 and restart + FLD ST(0) + FMUL DWORD PTR @@FDIV1SHL63 + FSTP [ESP].Z.Divisor + FLD [ESP].Z.Dividend + FXCH + JMP @@2 +end; +{$ENDIF} + +function _FilePos(var f: TFileRec): Longint; +begin + if (f.Mode > fmClosed) and (f.Mode <= fmInOut) then + begin +{$IFDEF LINUX} + Result := _lseek(f.Handle, 0, SEEK_CUR); +{$ENDIF} +{$IFDEF MSWINDOWS} + Result := SetFilePointer(f.Handle, 0, nil, FILE_CURRENT); +{$ENDIF} + if Result = -1 then + InOutError + else + Result := Cardinal(Result) div f.RecSize; + end + else + begin + SetInOutRes(103); + Result := -1; + end; +end; + +function _FileSize(var f: TFileRec): Longint; +{$IFDEF MSWINDOWS} +begin + Result := -1; + if (f.Mode > fmClosed) and (f.Mode <= fmInOut) then + begin + Result := GetFileSize(f.Handle, 0); + if Result = -1 then + InOutError + else + Result := Cardinal(Result) div f.RecSize; + end + else + SetInOutRes(103); +{$ENDIF} +{$IFDEF LINUX} +var + stat: TStatStruct; +begin + Result := -1; + if (f.Mode > fmClosed) and (f.Mode <= fmInOut) then + begin + if _fxstat(STAT_VER_LINUX, f.Handle, stat) <> 0 then + InOutError + else + Result := stat.st_size div f.RecSize; + end + else + SetInOutRes(103); +{$ENDIF} +end; + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The assembly implementation of procedure FillChar is subject to the + * Mozilla Public License Version 1.1 (the "License"); you may + * not use this file except in compliance with the License. + * You may obtain a copy of the License at http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is Fastcode + * + * The Initial Developer of the Original Code is + * Fastcode + * + * Portions created by the Initial Developer are Copyright (C) 2002-2004 + * the Initial Developer. All Rights Reserved. + * + * Contributor(s): John O'Harrow + * + * ***** END LICENSE BLOCK ***** *) +procedure _FillChar(var Dest; count: Integer; Value: Char); +{$IFDEF PUREPASCAL} +var + I: Integer; + P: PChar; +begin + P := PChar(@Dest); + for I := count-1 downto 0 do + P[I] := Value; +end; +{$ELSE} +asm // Size = 153 Bytes + CMP EDX, 32 + MOV CH, CL // Copy Value into both Bytes of CX + JL @@Small + MOV [EAX ], CX // Fill First 8 Bytes + MOV [EAX+2], CX + MOV [EAX+4], CX + MOV [EAX+6], CX + SUB EDX, 16 + FLD QWORD PTR [EAX] + FST QWORD PTR [EAX+EDX] // Fill Last 16 Bytes + FST QWORD PTR [EAX+EDX+8] + MOV ECX, EAX + AND ECX, 7 // 8-Byte Align Writes + SUB ECX, 8 + SUB EAX, ECX + ADD EDX, ECX + ADD EAX, EDX + NEG EDX +@@Loop: + FST QWORD PTR [EAX+EDX] // Fill 16 Bytes per Loop + FST QWORD PTR [EAX+EDX+8] + ADD EDX, 16 + JL @@Loop + FFREE ST(0) + RET + NOP + NOP + NOP +@@Small: + TEST EDX, EDX + JLE @@Done + MOV [EAX+EDX-1], CL // Fill Last Byte + AND EDX, -2 // No. of Words to Fill + NEG EDX + LEA EDX, [@@SmallFill + 60 + EDX * 2] + JMP EDX + NOP // Align Jump Destinations + NOP +@@SmallFill: + MOV [EAX+28], CX + MOV [EAX+26], CX + MOV [EAX+24], CX + MOV [EAX+22], CX + MOV [EAX+20], CX + MOV [EAX+18], CX + MOV [EAX+16], CX + MOV [EAX+14], CX + MOV [EAX+12], CX + MOV [EAX+10], CX + MOV [EAX+ 8], CX + MOV [EAX+ 6], CX + MOV [EAX+ 4], CX + MOV [EAX+ 2], CX + MOV [EAX ], CX + RET // DO NOT REMOVE - This is for Alignment +@@Done: +end; +{$ENDIF} + +procedure Mark; +begin + Error(reInvalidPtr); +end; + +function _ReadRec(var f: TFileRec; Buffer: Pointer): Integer; +{$IFDEF LINUX} +begin + if (f.Mode and fmInput) = fmInput then // fmInput or fmInOut + begin + Result := __read(f.Handle, Buffer, f.RecSize); + if Result = -1 then + InOutError + else if Cardinal(Result) <> f.RecSize then + SetInOutRes(100); + end + else + begin + SetInOutRes(103); // file not open for input + Result := 0; + end; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm +// -> EAX Pointer to file variable +// EDX Pointer to buffer + + PUSH EBX + XOR ECX,ECX + MOV EBX,EAX + MOV CX,[EAX].TFileRec.Mode // File must be open + SUB ECX,fmInput + JE @@skip + SUB ECX,fmInOut-fmInput + JNE @@fileNotOpen +@@skip: + +// ReadFile(f.Handle, buffer, f.RecSize, @result, Nil); + + PUSH 0 // space for OS result + MOV EAX,ESP + + PUSH 0 // pass lpOverlapped + PUSH EAX // pass @result + + PUSH [EBX].TFileRec.RecSize // pass nNumberOfBytesToRead + + PUSH EDX // pass lpBuffer + PUSH [EBX].TFileRec.Handle // pass hFile + CALL ReadFile + POP EDX // pop result + DEC EAX // check EAX = TRUE + JNZ @@error + + CMP EDX,[EBX].TFileRec.RecSize // result = f.RecSize ? + JE @@exit + +@@readError: + MOV EAX,100 + JMP @@errExit + +@@fileNotOpen: + MOV EAX,103 + JMP @@errExit + +@@error: + CALL GetLastError +@@errExit: + CALL SetInOutRes +@@exit: + POP EBX +end; +{$ENDIF} + + +// If the file is Input std variable, try to open it +// Otherwise, runtime error. +function TryOpenForInput(var t: TTextRec): Boolean; +begin + if @t = @Input then + begin + t.Flags := tfCRLF * Byte(DefaultTextLineBreakStyle); + _ResetText(t); + end; + + Result := t.Mode = fmInput; + if not Result then + SetInOutRes(104); +end; + +function _ReadChar(var t: TTextRec): Char; +asm +// -> EAX Pointer to text record +// <- AL Character read. (may be a pseudo cEOF in DOS mode) +// <- AH cEOF = End of File, else 0 +// For eof, #$1A is returned in AL and in AH. +// For errors, InOutRes is set and #$1A is returned. + + CMP [EAX].TTextRec.Mode, fmInput + JE @@checkBuf + PUSH EAX + CALL TryOpenForInput + TEST AL,AL + POP EAX + JZ @@eofexit + +@@checkBuf: + MOV EDX,[EAX].TTextRec.BufPos + CMP EDX,[EAX].TTextRec.BufEnd + JAE @@fillBuf +@@cont: + TEST [EAX].TTextRec.Flags,tfCRLF + MOV ECX,[EAX].TTextRec.BufPtr + MOV CL,[ECX+EDX] + JZ @@cont2 + CMP CL,cEof // Check for EOF char in DOS mode + JE @@eofexit +@@cont2: + INC EDX + MOV [EAX].TTextRec.BufPos,EDX + XOR EAX,EAX + JMP @@exit + +@@fillBuf: + PUSH EAX + CALL [EAX].TTextRec.InOutFunc + TEST EAX,EAX + JNE @@error + POP EAX + MOV EDX,[EAX].TTextRec.BufPos + CMP EDX,[EAX].TTextRec.BufEnd + JB @@cont + +// We didn't get characters. Must be eof then. + +@@eof: + TEST [EAX].TTextRec.Flags,tfCRLF + JZ @@eofexit +// In DOS CRLF compatibility mode, synthesize an EOF char +// Store one eof in the buffer and increment BufEnd + MOV ECX,[EAX].TTextRec.BufPtr + MOV byte ptr [ECX+EDX],cEof + INC [EAX].TTextRec.BufEnd + JMP @@eofexit + +@@error: + CALL SetInOutRes + POP EAX +@@eofexit: + MOV CL,cEof + MOV AH,CL +@@exit: + MOV AL,CL +end; + +function _ReadLong(var t: TTextRec): Longint; +asm +// -> EAX Pointer to text record +// <- EAX Result + + PUSH EBX + PUSH ESI + PUSH EDI + SUB ESP,36 // var numbuf: String[32]; + + MOV ESI,EAX + CALL _SeekEof + DEC AL + JZ @@eof + + MOV EDI,ESP // EDI -> numBuf[0] + MOV BL,32 +@@loop: + MOV EAX,ESI + CALL _ReadChar + CMP AL,' ' + JBE @@endNum + STOSB + DEC BL + JNZ @@loop +@@convert: + MOV byte ptr [EDI],0 + MOV EAX,ESP // EAX -> numBuf + PUSH EDX // allocate code result + MOV EDX,ESP // pass pointer to code + CALL _ValLong // convert + POP EDX // pop code result into EDX + TEST EDX,EDX + JZ @@exit + MOV EAX,106 + CALL SetInOutRes + JMP @@exit + +@@endNum: + CMP AH,cEof + JE @@convert + DEC [ESI].TTextRec.BufPos + JMP @@convert + +@@eof: + XOR EAX,EAX +@@exit: + ADD ESP,36 + POP EDI + POP ESI + POP EBX +end; + +function ReadLine(var t: TTextRec; buf: Pointer; maxLen: Longint): Pointer; +asm +// -> EAX Pointer to text record +// EDX Pointer to buffer +// ECX Maximum count of chars to read +// <- ECX Actual count of chars in buffer +// <- EAX Pointer to text record + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH ECX + MOV ESI,ECX + MOV EDI,EDX + + CMP [EAX].TTextRec.Mode,fmInput + JE @@start + PUSH EAX + CALL TryOpenForInput + TEST AL,AL + POP EAX + JZ @@exit + +@@start: + MOV EBX,EAX + + TEST ESI,ESI + JLE @@exit + + MOV EDX,[EBX].TTextRec.BufPos + MOV ECX,[EBX].TTextRec.BufEnd + SUB ECX,EDX + ADD EDX,[EBX].TTextRec.BufPtr + +@@loop: + DEC ECX + JL @@readChar + MOV AL,[EDX] + INC EDX +@@cont: + CMP AL,cLF + JE @@lf + + CMP AL,cCR + JE @@cr + + CMP AL,cEOF + JE @@eof + +@@store: + STOSB + DEC ESI + JG @@loop + JMP @@finish + +@@eof: + TEST [EBX].TTextRec.Flags,tfCRLF + JZ @@store + JMP @@finish + +@@cr: + MOV AL,[EDX] + CMP AL,cLF + JNE @@loop +@@lf: + DEC EDX +@@finish: + SUB EDX,[EBX].TTextRec.BufPtr + MOV [EBX].TTextRec.BufPos,EDX + JMP @@exit + +@@readChar: + MOV [EBX].TTextRec.BufPos,EDX + MOV EAX,EBX + CALL _ReadChar + MOV EDX,[EBX].TTextRec.BufPos + MOV ECX,[EBX].TTextRec.BufEnd + SUB ECX,EDX + ADD EDX,[EBX].TTextRec.BufPtr + TEST AH,AH //eof + JZ @@cont + +@@exit: + MOV EAX,EBX + POP ECX + SUB ECX,ESI + POP EDI + POP ESI + POP EBX +end; + +procedure _ReadString(var t: TTextRec; s: PShortString; maxLen: Longint); +asm +// -> EAX Pointer to text record +// EDX Pointer to string +// ECX Maximum length of string + + PUSH EDX + INC EDX + CALL ReadLine + POP EDX + MOV [EDX],CL +end; + +procedure _ReadCString(var t: TTextRec; s: PChar; maxLen: Longint); +asm +// -> EAX Pointer to text record +// EDX Pointer to string +// ECX Maximum length of string + + PUSH EDX + CALL ReadLine + POP EDX + MOV byte ptr [EDX+ECX],0 +end; + +procedure _ReadLString(var t: TTextRec; var s: AnsiString); +asm + { -> EAX pointer to Text } + { EDX pointer to AnsiString } + + PUSH EBX + PUSH ESI + MOV EBX,EAX + MOV ESI,EDX + + MOV EAX,EDX + CALL _LStrClr + + SUB ESP,256 + + MOV EAX,EBX + MOV EDX,ESP + MOV ECX,255 + CALL _ReadString + + MOV EAX,ESI + MOV EDX,ESP + CALL _LStrFromString + + CMP byte ptr [ESP],255 + JNE @@exit +@@loop: + + MOV EAX,EBX + MOV EDX,ESP + MOV ECX,255 + CALL _ReadString + + MOV EDX,ESP + PUSH 0 + MOV EAX,ESP + CALL _LStrFromString + + MOV EAX,ESI + MOV EDX,[ESP] + CALL _LStrCat + + MOV EAX,ESP + CALL _LStrClr + POP EAX + + CMP byte ptr [ESP],255 + JE @@loop + +@@exit: + ADD ESP,256 + POP ESI + POP EBX +end; + + +function IsValidMultibyteChar(const Src: PChar; SrcBytes: Integer): Boolean; +{$IFDEF MSWINDOWS} +const + ERROR_NO_UNICODE_TRANSLATION = 1113; // Win32 GetLastError when result = 0 + MB_ERR_INVALID_CHARS = 8; +var + Dest: WideChar; +begin + Result := MultiByteToWideChar(DefaultSystemCodePage, MB_ERR_INVALID_CHARS, Src, SrcBytes, @Dest, 1) <> 0; +{$ENDIF} +{$IFDEF LINUX} +begin + Result := mblen(Src, SrcBytes) <> -1; +{$ENDIF} +end; + + +function _ReadWChar(var t: TTextRec): WideChar; +var + scratch: array [0..7] of AnsiChar; + wc: WideChar; + i: Integer; +begin + i := 0; + while i < High(scratch) do + begin + scratch[i] := _ReadChar(t); + Inc(i); + scratch[i] := #0; + if IsValidMultibyteChar(scratch, i) then + begin + WCharFromChar(@wc, 1, scratch, i); + Result := wc; + Exit; + end; + end; + SetInOutRes(106); // Invalid Input + Result := #0; +end; + + +procedure _ReadWCString(var t: TTextRec; s: PWideChar; maxBytes: Longint); +var + i, maxLen: Integer; + wc: WideChar; +begin + if s = nil then Exit; + i := 0; + maxLen := maxBytes div sizeof(WideChar); + while i < maxLen do + begin + wc := _ReadWChar(t); + case Integer(wc) of + cEOF: if _EOFText(t) then Break; + cLF : begin + Dec(t.BufPos); + Break; + end; + cCR : if Byte(t.BufPtr[t.BufPos]) = cLF then + begin + Dec(t.BufPos); + Break; + end; + end; + s[i] := wc; + Inc(i); + end; + s[i] := #0; +end; + +procedure _ReadWString(var t: TTextRec; var s: WideString); +var + Temp: AnsiString; +begin + _ReadLString(t, Temp); + s := Temp; +end; + +function _ReadExt(var t: TTextRec): Extended; +asm +// -> EAX Pointer to text record +// <- FST(0) Result + + PUSH EBX + PUSH ESI + PUSH EDI + SUB ESP,68 // var numbuf: array[0..64] of char; + + MOV ESI,EAX + CALL _SeekEof + DEC AL + JZ @@eof + + MOV EDI,ESP // EDI -> numBuf[0] + MOV BL,64 +@@loop: + MOV EAX,ESI + CALL _ReadChar + CMP AL,' ' + JBE @@endNum + STOSB + DEC BL + JNZ @@loop +@@convert: + MOV byte ptr [EDI],0 + MOV EAX,ESP // EAX -> numBuf + PUSH EDX // allocate code result + MOV EDX,ESP // pass pointer to code + CALL _ValExt // convert + POP EDX // pop code result into EDX + TEST EDX,EDX + JZ @@exit + MOV EAX,106 + CALL SetInOutRes + JMP @@exit + +@@endNum: + CMP AH,cEOF + JE @@convert + DEC [ESI].TTextRec.BufPos + JMP @@convert + +@@eof: + FLDZ +@@exit: + ADD ESP,68 + POP EDI + POP ESI + POP EBX +end; + +procedure _ReadLn(var t: TTextRec); +asm +// -> EAX Pointer to text record + + PUSH EBX + MOV EBX,EAX +@@loop: + MOV EAX,EBX + CALL _ReadChar + + CMP AL,cLF // accept LF as end of line + JE @@exit + CMP AH,cEOF + JE @@eof + CMP AL,cCR + JNE @@loop + + MOV EAX,EBX + CALL _ReadChar + + CMP AL,cLF // accept CR+LF as end of line + JE @@exit + CMP AH,cEOF // accept CR+EOF as end of line + JE @@eof + DEC [EBX].TTextRec.BufPos + JMP @@loop // else CR+ anything else is not a line break. + +@@exit: +@@eof: + POP EBX +end; + +procedure _Rename(var f: TFileRec; newName: PChar); +var + I: Integer; +begin + if f.Mode = fmClosed then + begin + if newName = nil then newName := ''; +{$IFDEF LINUX} + if __rename(f.Name, newName) = 0 then +{$ENDIF} +{$IFDEF MSWINDOWS} + if MoveFileA(f.Name, newName) then +{$ENDIF} + begin + I := 0; + while (newName[I] <> #0) and (I < High(f.Name)) do + begin + f.Name[I] := newName[I]; + Inc(I); + end + end + else + SetInOutRes(GetLastError); + end + else + SetInOutRes(102); +end; + +procedure Release; +begin + Error(reInvalidPtr); +end; + +function _CloseFile(var f: TFileRec): Integer; +begin + f.Mode := fmClosed; + Result := 0; + if not InternalClose(f.Handle) then + begin + InOutError; + Result := 1; + end; +end; + +function OpenFile(var f: TFileRec; recSiz: Longint; mode: Longint): Integer; +{$IFDEF LINUX} +var + Flags: Integer; +begin + Result := 0; + if (f.Mode >= fmClosed) and (f.Mode <= fmInOut) then + begin + if f.Mode <> fmClosed then // not yet closed: close it + begin + Result := TFileIOFunc(f.CloseFunc)(f); + if Result <> 0 then + SetInOutRes(Result); + end; + + if recSiz <= 0 then + SetInOutRes(106); + + f.RecSize := recSiz; + f.InOutFunc := @FileNopProc; + + if f.Name[0] <> #0 then + begin + f.CloseFunc := @_CloseFile; + case mode of + 1: begin + Flags := O_APPEND or O_WRONLY; + f.Mode := fmOutput; + end; + 2: begin + Flags := O_RDWR; + f.Mode := fmInOut; + end; + 3: begin + Flags := O_CREAT or O_TRUNC or O_RDWR; + f.Mode := fmInOut; + end; + else + Flags := O_RDONLY; + f.Mode := fmInput; + end; + + f.Handle := __open(f.Name, Flags, FileAccessRights); + end + else // stdin or stdout + begin + f.CloseFunc := @FileNopProc; + if mode = 3 then + f.Handle := STDOUT_FILENO + else + f.Handle := STDIN_FILENO; + end; + + if f.Handle = -1 then + begin + f.Mode := fmClosed; + InOutError; + end; + end + else + SetInOutRes(102); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +const + ShareTab: array [0..7] of Integer = + (FILE_SHARE_READ OR FILE_SHARE_WRITE, // OF_SHARE_COMPAT 0x00000000 + 0, // OF_SHARE_EXCLUSIVE 0x00000010 + FILE_SHARE_READ, // OF_SHARE_DENY_WRITE 0x00000020 + FILE_SHARE_WRITE, // OF_SHARE_DENY_READ 0x00000030 + FILE_SHARE_READ OR FILE_SHARE_WRITE, // OF_SHARE_DENY_NONE 0x00000040 + 0,0,0); +asm +//-> EAX Pointer to file record +// EDX Record size +// ECX File mode + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EDX + MOV EDI,ECX + XOR EDX,EDX + MOV EBX,EAX + + MOV DX,[EAX].TFileRec.Mode + SUB EDX,fmClosed + JE @@alreadyClosed + CMP EDX,fmInOut-fmClosed + JA @@notAssignedError + +// not yet closed: close it. File parameter is still in EAX + + CALL [EBX].TFileRec.CloseFunc + TEST EAX,EAX + JE @@alreadyClosed + CALL SetInOutRes + +@@alreadyClosed: + + MOV [EBX].TFileRec.Mode,fmInOut + MOV [EBX].TFileRec.RecSize,ESI + MOV [EBX].TFileRec.CloseFunc,offset _CloseFile + MOV [EBX].TFileRec.InOutFunc,offset FileNopProc + + CMP byte ptr [EBX].TFileRec.Name,0 + JE @@isCon + + MOV EAX,GENERIC_READ OR GENERIC_WRITE + MOV DL,FileMode + AND EDX,070H + SHR EDX,4-2 + MOV EDX,dword ptr [shareTab+EDX] + MOV ECX,CREATE_ALWAYS + + SUB EDI,3 + JE @@calledByRewrite + + MOV ECX,OPEN_EXISTING + INC EDI + JE @@skip + + MOV EAX,GENERIC_WRITE + INC EDI + MOV [EBX].TFileRec.Mode,fmOutput + JE @@skip + + MOV EAX,GENERIC_READ + MOV [EBX].TFileRec.Mode,fmInput + +@@skip: +@@calledByRewrite: + +// CreateFile(t.FileName, EAX, EDX, Nil, ECX, FILE_ATTRIBUTE_NORMAL, 0); + + PUSH 0 + PUSH FILE_ATTRIBUTE_NORMAL + PUSH ECX + PUSH 0 + PUSH EDX + PUSH EAX + LEA EAX,[EBX].TFileRec.Name + PUSH EAX + CALL CreateFileA +@@checkHandle: + CMP EAX,-1 + JZ @@error + + MOV [EBX].TFileRec.Handle,EAX + JMP @@exit + +@@isCon: + MOV [EBX].TFileRec.CloseFunc,offset FileNopProc + CMP EDI,3 + JE @@output + PUSH STD_INPUT_HANDLE + JMP @@1 +@@output: + PUSH STD_OUTPUT_HANDLE +@@1: + CALL GetStdHandle + JMP @@checkHandle + +@@notAssignedError: + MOV EAX,102 + JMP @@errExit + +@@error: + MOV [EBX].TFileRec.Mode,fmClosed + CALL GetLastError +@@errExit: + CALL SetInOutRes + +@@exit: + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +function _ResetFile(var f: TFileRec; recSize: Longint): Integer; +var + m: Byte; +begin + m := FileMode and 3; + if m > 2 then m := 2; + Result := OpenFile(f, recSize, m); +end; + +function _RewritFile(var f: TFileRec; recSize: Longint): Integer; +begin + Result := OpenFile(f, recSize, 3); +end; + +procedure _Seek(var f: TFileRec; recNum: Cardinal); +{$IFDEF LINUX} +begin + if (f.Mode >= fmInput) and (f.Mode <= fmInOut) then + begin + if _lseek(f.Handle, f.RecSize * recNum, SEEK_SET) = -1 then + InOutError; + end + else + SetInOutRes(103); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm +// -> EAX Pointer to file variable +// EDX Record number + + MOV ECX,EAX + MOVZX EAX,[EAX].TFileRec.Mode // check whether file is open + SUB EAX,fmInput + CMP EAX,fmInOut-fmInput + JA @@fileNotOpen + +// SetFilePointer(f.Handle, recNum*f.RecSize, FILE_BEGIN + PUSH FILE_BEGIN // pass dwMoveMethod + MOV EAX,[ECX].TFileRec.RecSize + MUL EDX + PUSH 0 // pass lpDistanceToMoveHigh + PUSH EAX // pass lDistanceToMove + PUSH [ECX].TFileRec.Handle // pass hFile + CALL SetFilePointer // get current position + INC EAX + JZ InOutError + JMP @@exit + +@@fileNotOpen: + MOV EAX,103 + JMP SetInOutRes + +@@exit: +end; +{$ENDIF} + +function _SeekEof(var t: TTextRec): Boolean; +asm +// -> EAX Pointer to text record +// <- AL Boolean result + + PUSH EBX + MOV EBX,EAX +@@loop: + MOV EAX,EBX + CALL _ReadChar + CMP AL,' ' + JA @@endloop + CMP AH,cEOF + JE @@eof + JMP @@loop +@@eof: + MOV AL,1 + JMP @@exit + +@@endloop: + DEC [EBX].TTextRec.BufPos + XOR AL,AL +@@exit: + POP EBX +end; + +function _SeekEoln(var t: TTextRec): Boolean; +asm +// -> EAX Pointer to text record +// <- AL Boolean result + + PUSH EBX + MOV EBX,EAX +@@loop: + MOV EAX,EBX + CALL _ReadChar + CMP AL,' ' + JA @@falseExit + CMP AH,cEOF + JE @@eof + CMP AL,cLF + JE @@trueExit + CMP AL,cCR + JNE @@loop + +@@trueExit: + MOV AL,1 + JMP @@exitloop + +@@falseExit: + XOR AL,AL +@@exitloop: + DEC [EBX].TTextRec.BufPos + JMP @@exit + +@@eof: + MOV AL,1 +@@exit: + POP EBX +end; + +procedure _SetTextBuf(var t: TTextRec; p: Pointer; size: Longint); +begin + if size < 0 then + Error(reRangeError); + t.BufPtr := P; + t.BufSize := size; + t.BufPos := 0; + t.BufEnd := 0; +end; + +procedure _StrLong(val, width: Longint; s: PShortString); +{$IFDEF PUREPASCAL} +var + I: Integer; + sign: Longint; + a: array [0..19] of char; + P: PChar; +begin + sign := val; + val := Abs(val); + I := 0; + repeat + a[I] := Chr((val mod 10) + Ord('0')); + Inc(I); + val := val div 10; + until val = 0; + + if sign < 0 then + begin + a[I] := '-'; + Inc(I); + end; + + if width < I then + width := I; + if width > 255 then + width := 255; + s^[0] := Chr(width); + P := @S^[1]; + while width > I do + begin + P^ := ' '; + Inc(P); + Dec(width); + end; + repeat + Dec(I); + P^ := a[I]; + Inc(P); + until I <= 0; +end; +{$ELSE} +asm +{ PROCEDURE _StrLong( val: Longint; width: Longint; VAR s: ShortString ); + ->EAX Value + EDX Width + ECX Pointer to string } + + PUSH EBX { VAR i: Longint; } + PUSH ESI { VAR sign : Longint; } + PUSH EDI + PUSH EDX { store width on the stack } + SUB ESP,20 { VAR a: array [0..19] of Char; } + + MOV EDI,ECX + + MOV ESI,EAX { sign := val } + + CDQ { val := Abs(val); canned sequence } + XOR EAX,EDX + SUB EAX,EDX + + MOV ECX,10 + XOR EBX,EBX { i := 0; } + +@@repeat1: { repeat } + XOR EDX,EDX { a[i] := Chr( val MOD 10 + Ord('0') );} + + DIV ECX { val := val DIV 10; } + + ADD EDX,'0' + MOV [ESP+EBX],DL + INC EBX { i := i + 1; } + TEST EAX,EAX { until val = 0; } + JNZ @@repeat1 + + TEST ESI,ESI + JGE @@2 + MOV byte ptr [ESP+EBX],'-' + INC EBX +@@2: + MOV [EDI],BL { s^++ := Chr(i); } + INC EDI + + MOV ECX,[ESP+20] { spaceCnt := width - i; } + CMP ECX,255 + JLE @@3 + MOV ECX,255 +@@3: + SUB ECX,EBX + JLE @@repeat2 { for k := 1 to spaceCnt do s^++ := ' '; } + ADD [EDI-1],CL + MOV AL,' ' + REP STOSB + +@@repeat2: { repeat } + MOV AL,[ESP+EBX-1] { s^ := a[i-1]; } + MOV [EDI],AL + INC EDI { s := s + 1 } + DEC EBX { i := i - 1; } + JNZ @@repeat2 { until i = 0; } + + ADD ESP,20+4 + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +procedure _Str0Long(val: Longint; s: PShortString); +begin + _StrLong(val, 0, s); +end; + +procedure _Truncate(var f: TFileRec); +{$IFDEF LINUX} +begin + if (f.Mode and fmOutput) = fmOutput then // fmOutput or fmInOut + begin + if _ftruncate(f.Handle, _lseek(f.Handle, 0, SEEK_CUR)) = -1 then + InOutError; + end + else + SetInOutRes(103); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm +// -> EAX Pointer to text or file variable + + MOVZX EDX,[EAX].TFileRec.Mode // check whether file is open + SUB EDX,fmInput + CMP EDX,fmInOut-fmInput + JA @@fileNotOpen + + PUSH [EAX].TFileRec.Handle + CALL SetEndOfFile + DEC EAX + JZ @@exit + JMP InOutError + +@@fileNotOpen: + MOV EAX,103 + JMP SetInOutRes + +@@exit: +end; +{$ENDIF} + +function _ValLong(const s: String; var code: Integer): Longint; +{$IFDEF PUREPASCAL} +var + I: Integer; + Negative, Hex: Boolean; +begin + I := 1; + code := -1; + Result := 0; + Negative := False; + Hex := False; + while (I <= Length(s)) and (s[I] = ' ') do Inc(I); + if I > Length(s) then Exit; + case s[I] of + '$', + 'x', + 'X': begin + Hex := True; + Inc(I); + end; + '0': begin + Hex := (Length(s) > I) and (UpCase(s[I+1]) = 'X'); + if Hex then Inc(I,2); + end; + '-': begin + Negative := True; + Inc(I); + end; + '+': Inc(I); + end; + if Hex then + while I <= Length(s) do + begin + if Result > (High(Result) div 16) then + begin + code := I; + Exit; + end; + case s[I] of + '0'..'9': Result := Result * 16 + Ord(s[I]) - Ord('0'); + 'a'..'f': Result := Result * 16 + Ord(s[I]) - Ord('a') + 10; + 'A'..'F': Result := Result * 16 + Ord(s[I]) - Ord('A') + 10; + else + code := I; + Exit; + end; + end + else + while I <= Length(s) do + begin + if Result > (High(Result) div 10) then + begin + code := I; + Exit; + end; + Result := Result * 10 + Ord(s[I]) - Ord('0'); + Inc(I); + end; + if Negative then + Result := -Result; + code := 0; +end; +{$ELSE} +asm +{ FUNCTION _ValLong( s: AnsiString; VAR code: Integer ) : Longint; } +{ ->EAX Pointer to string } +{ EDX Pointer to code result } +{ <-EAX Result } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX + PUSH EAX { save for the error case } + + TEST EAX,EAX + JE @@empty + + XOR EAX,EAX + XOR EBX,EBX + MOV EDI,07FFFFFFFH / 10 { limit } + +@@blankLoop: + MOV BL,[ESI] + INC ESI + CMP BL,' ' + JE @@blankLoop + +@@endBlanks: + MOV CH,0 + CMP BL,'-' + JE @@minus + CMP BL,'+' + JE @@plus + +@@checkDollar: + CMP BL,'$' + JE @@dollar + + CMP BL, 'x' + JE @@dollar + CMP BL, 'X' + JE @@dollar + CMP BL, '0' + JNE @@firstDigit + MOV BL, [ESI] + INC ESI + CMP BL, 'x' + JE @@dollar + CMP BL, 'X' + JE @@dollar + TEST BL, BL + JE @@endDigits + JMP @@digLoop + +@@firstDigit: + TEST BL,BL + JE @@error + +@@digLoop: + SUB BL,'0' + CMP BL,9 + JA @@error + CMP EAX,EDI { value > limit ? } + JA @@overFlow + LEA EAX,[EAX+EAX*4] + ADD EAX,EAX + ADD EAX,EBX { fortunately, we can't have a carry } + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JNE @@digLoop + +@@endDigits: + DEC CH + JE @@negate + TEST EAX,EAX + JGE @@successExit + JMP @@overFlow + +@@empty: + INC ESI + JMP @@error + +@@negate: + NEG EAX + JLE @@successExit + JS @@successExit { to handle 2**31 correctly, where the negate overflows } + +@@error: +@@overFlow: + POP EBX + SUB ESI,EBX + JMP @@exit + +@@minus: + INC CH +@@plus: + MOV BL,[ESI] + INC ESI + JMP @@checkDollar + +@@dollar: + MOV EDI,0FFFFFFFH + + MOV BL,[ESI] + INC ESI + TEST BL,BL + JZ @@empty + +@@hDigLoop: + CMP BL,'a' + JB @@upper + SUB BL,'a' - 'A' +@@upper: + SUB BL,'0' + CMP BL,9 + JBE @@digOk + SUB BL,'A' - '0' + CMP BL,5 + JA @@error + ADD BL,10 +@@digOk: + CMP EAX,EDI + JA @@overFlow + SHL EAX,4 + ADD EAX,EBX + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JNE @@hDigLoop + + DEC CH + JNE @@successExit + NEG EAX + +@@successExit: + POP ECX { saved copy of string pointer } + XOR ESI,ESI { signal no error to caller } + +@@exit: + MOV [EDX],ESI + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +function _WriteRec(var f: TFileRec; buffer: Pointer): Pointer; +{$IFDEF LINUX} +var + Dummy: Integer; +begin + _BlockWrite(f, Buffer, 1, Dummy); + Result := @F; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm +// -> EAX Pointer to file variable +// EDX Pointer to buffer +// <- EAX Pointer to file variable + PUSH EBX + + MOV EBX,EAX + + MOVZX EAX,[EAX].TFileRec.Mode + SUB EAX,fmOutput + CMP EAX,fmInOut-fmOutput // File must be fmInOut or fmOutput + JA @@fileNotOpen + +// WriteFile(f.Handle, buffer, f.RecSize, @result, Nil); + + PUSH 0 // space for OS result + MOV EAX,ESP + + PUSH 0 // pass lpOverlapped + PUSH EAX // pass @result + PUSH [EBX].TFileRec.RecSize // pass nNumberOfBytesToRead + PUSH EDX // pass lpBuffer + PUSH [EBX].TFileRec.Handle // pass hFile + CALL WriteFile + POP EDX // pop result + DEC EAX // check EAX = TRUE + JNZ @@error + + CMP EDX,[EBX].TFileRec.RecSize // result = f.RecSize ? + JE @@exit + +@@writeError: + MOV EAX,101 + JMP @@errExit + +@@fileNotOpen: + MOV EAX,5 + JMP @@errExit + +@@error: + CALL GetLastError +@@errExit: + CALL SetInOutRes +@@exit: + MOV EAX,EBX + POP EBX +end; +{$ENDIF} + +// If the file is Output or ErrOutput std variable, try to open it +// Otherwise, runtime error. +function TryOpenForOutput(var t: TTextRec): Boolean; +begin + if (@t = @Output) or (@t = @ErrOutput) then + begin + t.Flags := tfCRLF * Byte(DefaultTextLineBreakStyle); + _RewritText(t); + end; + + Result := t.Mode = fmOutput; + if not Result then + SetInOutRes(105); +end; + +function _WriteBytes(var t: TTextRec; const b; cnt : Longint): Pointer; +{$IFDEF PUREPASCAL} +var + P: PChar; + RemainingBytes: Longint; + Temp: Integer; +begin + Result := @t; + if t.Mode <> fmOutput and not TryOpenForOutput(t) then Exit; + + P := t.BufPtr + t.BufPos; + RemainingBytes := t.BufSize - t.BufPos; + while RemainingBytes <= cnt do + begin + Inc(t.BufPos, RemainingBytes); + Dec(cnt, RemainingBytes); + Move(B, P^, RemainingBytes); + Temp := TTextIOFunc(t.InOutFunc)(t); + if Temp <> 0 then + begin + SetInOutRes(Temp); + Exit; + end; + P := t.BufPtr + t.BufPos; + RemainingBytes := t.BufSize - t.BufPos; + end; + Inc(t.BufPos, cnt); + Move(B, P^, cnt); +end; +{$ELSE} +asm +// -> EAX Pointer to file record +// EDX Pointer to buffer +// ECX Number of bytes to write +// <- EAX Pointer to file record + + PUSH ESI + PUSH EDI + + MOV ESI,EDX + + CMP [EAX].TTextRec.Mode,fmOutput + JE @@loop + PUSH EAX + PUSH EDX + PUSH ECX + CALL TryOpenForOutput + TEST AL,AL + POP ECX + POP EDX + POP EAX + JE @@exit + +@@loop: + MOV EDI,[EAX].TTextRec.BufPtr + ADD EDI,[EAX].TTextRec.BufPos + +// remainingBytes = t.bufSize - t.bufPos + + MOV EDX,[EAX].TTextRec.BufSize + SUB EDX,[EAX].TTextRec.BufPos + +// if (remainingBytes <= cnt) + + CMP EDX,ECX + JG @@1 + +// t.BufPos += remainingBytes, cnt -= remainingBytes + + ADD [EAX].TTextRec.BufPos,EDX + SUB ECX,EDX + +// copy remainingBytes, advancing ESI + + PUSH EAX + PUSH ECX + MOV ECX,EDX + REP MOVSB + + CALL [EAX].TTextRec.InOutFunc + TEST EAX,EAX + JNZ @@error + + POP ECX + POP EAX + JMP @@loop + +@@error: + CALL SetInOutRes + POP ECX + POP EAX + JMP @@exit +@@1: + ADD [EAX].TTextRec.BufPos,ECX + REP MOVSB + +@@exit: + POP EDI + POP ESI +end; +{$ENDIF} + +function _WriteSpaces(var t: TTextRec; cnt: Longint): Pointer; +{$IFDEF PUREPASCAL} +const + s64Spaces = ' '; +begin + Result := @t; + while cnt > 64 do + begin + _WriteBytes(t, s64Spaces, 64); + if InOutRes <> 0 then Exit; + Dec(cnt, 64); + end; + if cnt > 0 then + _WriteBytes(t, s64Spaces, cnt); +end; +{$ELSE} +const + spCnt = 64; +asm +// -> EAX Pointer to text record +// EDX Number of spaces (<= 0: None) + + MOV ECX,EDX +@@loop: +{$IFDEF PIC} + LEA EDX, [EBX] + offset @@spBuf +{$ELSE} + MOV EDX,offset @@spBuf +{$ENDIF} + + CMP ECX,spCnt + JLE @@1 + + SUB ECX,spCnt + PUSH EAX + PUSH ECX + MOV ECX,spCnt + CALL _WriteBytes + CALL SysInit.@GetTLS + CMP [EAX].InOutRes,0 + JNE @@error + POP ECX + POP EAX + JMP @@loop + +@@error: + POP ECX + POP EAX + JMP @@exit + +@@spBuf: // 64 spaces + DB ' '; +@@1: + TEST ECX,ECX + JG _WriteBytes +@@exit: +end; +{$ENDIF} + +function _Write0Char(var t: TTextRec; c: Char): Pointer; +{$IFDEF PUREPASCAL} +var + Temp: Integer; +begin + Result := @t; + if not TryOpenForOutput(t) then Exit; + + if t.BufPos >= t.BufSize then + begin + Temp := TTextIOFunc(t.InOutFunc)(t); + if Temp <> 0 then + begin + SetInOutRes(Temp); + Exit; + end; + end; + + t.BufPtr[t.BufPos] := c; + Inc(t.BufPos); +end; +{$ELSE} +asm +// -> EAX Pointer to text record +// DL Character + + CMP [EAX].TTextRec.Mode,fmOutput + JE @@loop + PUSH EAX + PUSH EDX + CALL TryOpenForOutput + TEST AL,AL + POP EDX + POP EAX + JNE @@loop + JMP @@exit + +@@flush: + PUSH EAX + PUSH EDX + CALL [EAX].TTextRec.InOutFunc + TEST EAX,EAX + JNZ @@error + POP EDX + POP EAX + JMP @@loop + +@@error: + CALL SetInOutRes + POP EDX + POP EAX + JMP @@exit + +@@loop: + MOV ECX,[EAX].TTextRec.BufPos + CMP ECX,[EAX].TTextRec.BufSize + JGE @@flush + + ADD ECX,[EAX].TTextRec.BufPtr + MOV [ECX],DL + + INC [EAX].TTextRec.BufPos +@@exit: +end; +{$ENDIF} + +function _WriteChar(var t: TTextRec; c: Char; width: Integer): Pointer; +begin + _WriteSpaces(t, width-1); + Result := _WriteBytes(t, c, 1); +end; + +function _WriteBool(var t: TTextRec; val: Boolean; width: Longint): Pointer; +const + BoolStrs: array [Boolean] of ShortString = ('FALSE', 'TRUE'); +begin + Result := _WriteString(t, BoolStrs[val], width); +end; + +function _Write0Bool(var t: TTextRec; val: Boolean): Pointer; +begin + Result := _WriteBool(t, val, 0); +end; + +function _WriteLong(var t: TTextRec; val, width: Longint): Pointer; +var + S: string[31]; +begin + Str(val:0, S); + Result := _WriteString(t, S, width); +end; + +function _Write0Long(var t: TTextRec; val: Longint): Pointer; +begin + Result := _WriteLong(t, val, 0); +end; + +function _Write0String(var t: TTextRec; const s: ShortString): Pointer; +begin + Result := _WriteBytes(t, S[1], Byte(S[0])); +end; + +function _WriteString(var t: TTextRec; const s: ShortString; width: Longint): Pointer; +begin + _WriteSpaces(t, Width - Byte(S[0])); + Result := _WriteBytes(t, S[1], Byte(S[0])); +end; + +function _Write0CString(var t: TTextRec; s: PChar): Pointer; +begin + Result := _WriteCString(t, s, 0); +end; + +function _WriteCString(var t: TTextRec; s: PChar; width: Longint): Pointer; +var + len: Longint; +begin + {$IFDEF LINUX} + if Assigned(s) then + len := _strlen(s) + else + len := 0; + {$ENDIF} + {$IFDEF MSWINDOWS} + len := _strlen(s); + {$ENDIF} + _WriteSpaces(t, width - len); + Result := _WriteBytes(t, s^, len); +end; + +procedure _Write2Ext; +asm +{ PROCEDURE _Write2Ext( VAR t: Text; val: Extended; width, prec: Longint); + ->EAX Pointer to file record + [ESP+4] Extended value + EDX Field width + ECX precision (<0: scientific, >= 0: fixed point) } + + FLD tbyte ptr [ESP+4] { load value } + SUB ESP,256 { VAR s: String; } + + PUSH EAX + PUSH EDX + +{ Str( val, width, prec, s ); } + + SUB ESP,12 + FSTP tbyte ptr [ESP] { pass value } + MOV EAX,EDX { pass field width } + MOV EDX,ECX { pass precision } + LEA ECX,[ESP+8+12] { pass destination string } + CALL _Str2Ext + +{ Write( t, s, width ); } + + POP ECX { pass width } + POP EAX { pass text } + MOV EDX,ESP { pass string } + CALL _WriteString + + ADD ESP,256 + RET 12 +end; + +procedure _Write1Ext; +asm +{ PROCEDURE _Write1Ext( VAR t: Text; val: Extended; width: Longint); + -> EAX Pointer to file record + [ESP+4] Extended value + EDX Field width } + + OR ECX,-1 + JMP _Write2Ext +end; + +procedure _Write0Ext; +asm +{ PROCEDURE _Write0Ext( VAR t: Text; val: Extended); + ->EAX Pointer to file record + [ESP+4] Extended value } + + MOV EDX,23 { field width } + OR ECX,-1 + JMP _Write2Ext +end; + +function _WriteLn(var t: TTextRec): Pointer; +var + Buf: array [0..1] of Char; +begin + if (t.flags and tfCRLF) <> 0 then + begin + Buf[0] := #13; + Buf[1] := #10; + Result := _WriteBytes(t, Buf, 2); + end + else + begin + Buf[0] := #10; + Result := _WriteBytes(t, Buf, 1); + end; + _Flush(t); +end; + +procedure __CToPasStr(Dest: PShortString; const Source: PChar); +begin + __CLenToPasStr(Dest, Source, 255); +end; + +procedure __CLenToPasStr(Dest: PShortString; const Source: PChar; MaxLen: Integer); +{$IFDEF PUREPASCAL} +var + I: Integer; +begin + I := 0; + if MaxLen > 255 then MaxLen := 255; + while (Source[I] <> #0) and (I <= MaxLen) do + begin + Dest^[I+1] := Source[I]; + Inc(I); + end; + if I > 0 then Dec(I); + Byte(Dest^[0]) := I; +end; +{$ELSE} +asm +{ ->EAX Pointer to destination } +{ EDX Pointer to source } +{ ECX cnt } + + PUSH EBX + PUSH EAX { save destination } + + CMP ECX,255 + JBE @@loop + MOV ECX,255 +@@loop: + MOV BL,[EDX] { ch = *src++; } + INC EDX + TEST BL,BL { if (ch == 0) break } + JE @@endLoop + INC EAX { *++dest = ch; } + MOV [EAX],BL + DEC ECX { while (--cnt != 0) } + JNZ @@loop + +@@endLoop: + POP EDX + SUB EAX,EDX + MOV [EDX],AL + POP EBX +end; +{$ENDIF} + +procedure __ArrayToPasStr(Dest: PShortString; const Source: PChar; Len: Integer); +begin + if Len > 255 then Len := 255; + Byte(Dest^[0]) := Len; + Move(Source^, Dest^[1], Len); +end; + +procedure __PasToCStr(const Source: PShortString; const Dest: PChar); +begin + Move(Source^[1], Dest^, Byte(Source^[0])); + Dest[Byte(Source^[0])] := #0; +end; + +procedure _SetElem; +asm + { PROCEDURE _SetElem( VAR d: SET; elem, size: Byte); } + { EAX = dest address } + { DL = element number } + { CL = size of set } + + PUSH EBX + PUSH EDI + + MOV EDI,EAX + + XOR EBX,EBX { zero extend set size into ebx } + MOV BL,CL + MOV ECX,EBX { and use it for the fill } + + XOR EAX,EAX { for zero fill } + REP STOSB + + SUB EDI,EBX { point edi at beginning of set again } + + INC EAX { eax is still zero - make it 1 } + MOV CL,DL + ROL AL,CL { generate a mask } + SHR ECX,3 { generate the index } + CMP ECX,EBX { if index >= siz then exit } + JAE @@exit + OR [EDI+ECX],AL{ set bit } + +@@exit: + POP EDI + POP EBX +end; + +procedure _SetRange; +asm +{ PROCEDURE _SetRange( lo, hi, size: Byte; VAR d: SET ); } +{ ->AL low limit of range } +{ DL high limit of range } +{ ECX Pointer to set } +{ AH size of set } + + PUSH EBX + PUSH ESI + PUSH EDI + + XOR EBX,EBX { EBX = set size } + MOV BL,AH + MOVZX ESI,AL { ESI = low zero extended } + MOVZX EDX,DL { EDX = high zero extended } + MOV EDI,ECX + +{ clear the set } + + MOV ECX,EBX + XOR EAX,EAX + REP STOSB + +{ prepare for setting the bits } + + SUB EDI,EBX { point EDI at start of set } + SHL EBX,3 { EBX = highest bit in set + 1 } + CMP EDX,EBX + JB @@inrange + LEA EDX,[EBX-1] { ECX = highest bit in set } + +@@inrange: + CMP ESI,EDX { if lo > hi then exit; } + JA @@exit + + DEC EAX { loMask = 0xff << (lo & 7) } + MOV ECX,ESI + AND CL,07H + SHL AL,CL + + SHR ESI,3 { loIndex = lo >> 3; } + + MOV CL,DL { hiMask = 0xff >> (7 - (hi & 7)); } + NOT CL + AND CL,07 + SHR AH,CL + + SHR EDX,3 { hiIndex = hi >> 3; } + + ADD EDI,ESI { point EDI to set[loIndex] } + MOV ECX,EDX + SUB ECX,ESI { if ((inxDiff = (hiIndex - loIndex)) == 0) } + JNE @@else + + AND AL,AH { set[loIndex] = hiMask & loMask; } + MOV [EDI],AL + JMP @@exit + +@@else: + STOSB { set[loIndex++] = loMask; } + DEC ECX + MOV AL,0FFH { while (loIndex < hiIndex) } + REP STOSB { set[loIndex++] = 0xff; } + MOV [EDI],AH { set[hiIndex] = hiMask; } + +@@exit: + POP EDI + POP ESI + POP EBX +end; + +procedure _SetEq; +asm +{ FUNCTION _SetEq( CONST l, r: Set; size: Byte): ConditionCode; } +{ EAX = left operand } +{ EDX = right operand } +{ CL = size of set } + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + AND ECX,0FFH + REP CMPSB + + POP EDI + POP ESI +end; + +procedure _SetLe; +asm +{ FUNCTION _SetLe( CONST l, r: Set; size: Byte): ConditionCode; } +{ EAX = left operand } +{ EDX = right operand } +{ CL = size of set (>0 && <= 32) } + +@@loop: + MOV CH,[EDX] + NOT CH + AND CH,[EAX] + JNE @@exit + INC EDX + INC EAX + DEC CL + JNZ @@loop +@@exit: +end; + +procedure _SetIntersect; +asm +{ PROCEDURE _SetIntersect( VAR dest: Set; CONST src: Set; size: Byte);} +{ EAX = destination operand } +{ EDX = source operand } +{ CL = size of set (0 < size <= 32) } + +@@loop: + MOV CH,[EDX] + INC EDX + AND [EAX],CH + INC EAX + DEC CL + JNZ @@loop +end; + +procedure _SetIntersect3; +asm +{ PROCEDURE _SetIntersect3( VAR dest: Set; CONST src: Set; size: Longint; src2: Set);} +{ EAX = destination operand } +{ EDX = source operand } +{ ECX = size of set (0 < size <= 32) } +{ [ESP+4] = 2nd source operand } + + PUSH EBX + PUSH ESI + MOV ESI,[ESP+8+4] +@@loop: + MOV BL,[EDX+ECX-1] + AND BL,[ESI+ECX-1] + MOV [EAX+ECX-1],BL + DEC ECX + JNZ @@loop + + POP ESI + POP EBX +end; + +procedure _SetUnion; +asm +{ PROCEDURE _SetUnion( VAR dest: Set; CONST src: Set; size: Byte); } +{ EAX = destination operand } +{ EDX = source operand } +{ CL = size of set (0 < size <= 32) } + +@@loop: + MOV CH,[EDX] + INC EDX + OR [EAX],CH + INC EAX + DEC CL + JNZ @@loop +end; + +procedure _SetUnion3; +asm +{ PROCEDURE _SetUnion3( VAR dest: Set; CONST src: Set; size: Longint; src2: Set);} +{ EAX = destination operand } +{ EDX = source operand } +{ ECX = size of set (0 < size <= 32) } +{ [ESP+4] = 2nd source operand } + + PUSH EBX + PUSH ESI + MOV ESI,[ESP+8+4] +@@loop: + MOV BL,[EDX+ECX-1] + OR BL,[ESI+ECX-1] + MOV [EAX+ECX-1],BL + DEC ECX + JNZ @@loop + + POP ESI + POP EBX +end; + +procedure _SetSub; +asm +{ PROCEDURE _SetSub( VAR dest: Set; CONST src: Set; size: Byte); } +{ EAX = destination operand } +{ EDX = source operand } +{ CL = size of set (0 < size <= 32) } + +@@loop: + MOV CH,[EDX] + NOT CH + INC EDX + AND [EAX],CH + INC EAX + DEC CL + JNZ @@loop +end; + +procedure _SetSub3; +asm +{ PROCEDURE _SetSub3( VAR dest: Set; CONST src: Set; size: Longint; src2: Set);} +{ EAX = destination operand } +{ EDX = source operand } +{ ECX = size of set (0 < size <= 32) } +{ [ESP+4] = 2nd source operand } + + PUSH EBX + PUSH ESI + MOV ESI,[ESP+8+4] +@@loop: + MOV BL,[ESI+ECX-1] + NOT BL + AND BL,[EDX+ECX-1] + MOV [EAX+ECX-1],BL + DEC ECX + JNZ @@loop + + POP ESI + POP EBX +end; + +procedure _SetExpand; +asm +{ PROCEDURE _SetExpand( CONST src: Set; VAR dest: Set; lo, hi: Byte); } +{ ->EAX Pointer to source (packed set) } +{ EDX Pointer to destination (expanded set) } +{ CH high byte of source } +{ CL low byte of source } + +{ algorithm: } +{ clear low bytes } +{ copy high-low+1 bytes } +{ clear 31-high bytes } + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + MOV EDX,ECX { save low, high in dl, dh } + XOR ECX,ECX + XOR EAX,EAX + + MOV CL,DL { clear low bytes } + REP STOSB + + MOV CL,DH { copy high - low bytes } + SUB CL,DL + REP MOVSB + + MOV CL,32 { copy 32 - high bytes } + SUB CL,DH + REP STOSB + + POP EDI + POP ESI +end; + +procedure _EmitDigits; +const + tenE17: Double = 1e17; + tenE18: Double = 1e18; +asm +// -> FST(0) Value, 0 <= value < 10.0 +// EAX Count of digits to generate +// EDX Pointer to digit buffer + + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX +{$ELSE} + XOR EBX,EBX +{$ENDIF} + PUSH EDI + MOV EDI,EDX + MOV ECX,EAX + + SUB ESP,10 // VAR bcdBuf: array [0..9] of Byte + MOV byte ptr [EDI],'0' // digBuf[0] := '0'// + FMUL qword ptr [EBX] + offset tenE17 // val := Round(val*1e17); + FRNDINT + + FCOM qword ptr [EBX] + offset tenE18 // if val >= 1e18 then + FSTSW AX + SAHF + JB @@1 + + FSUB qword ptr [EBX] + offset tenE18 // val := val - 1e18; + MOV byte ptr [EDI],'1' // digBuf[0] := '1'; +@@1: + FBSTP tbyte ptr [ESP] // store packed bcd digits in bcdBuf + + MOV EDX,8 + INC EDI + +@@2: + WAIT + MOV AL,[ESP+EDX] // unpack 18 bcd digits in 9 bytes + MOV AH,AL // into 9 words = 18 bytes + SHR AL,4 + AND AH,0FH + ADD AX,'00' + STOSW + DEC EDX + JNS @@2 + + SUB ECX,18 // we need at least digCnt digits + JL @@3 // we have generated 18 + + MOV AL,'0' // if this is not enough, append zeroes + REP STOSB + JMP @@4 // in this case, we don't need to round + +@@3: + ADD EDI,ECX // point EDI to the round digit + CMP byte ptr [EDI],'5' + JL @@4 +@@5: + DEC EDI + INC byte ptr [EDI] + CMP byte ptr [EDI],'9' + JLE @@4 + MOV byte ptr [EDI],'0' + JMP @@5 + +@@4: + ADD ESP,10 + POP EDI + POP EBX +end; + +procedure _ScaleExt; +asm +// -> FST(0) Value +// <- EAX exponent (base 10) +// FST(0) Value / 10**eax +// PIC safe - uses EBX, but only call is to _POW10, which fixes up EBX itself + + PUSH EBX + SUB ESP,12 + + XOR EBX,EBX + +@@normLoop: // loop necessary for denormals + + FLD ST(0) + FSTP tbyte ptr [ESP] + MOV AX,[ESP+8] + TEST AX,AX + JE @@testZero +@@cont: + SUB AX,3FFFH + MOV DX,4D10H // log10(2) * 2**16 + IMUL DX + MOVSX EAX,DX // exp10 = exp2 * log10(2) + NEG EAX + JE @@exit + SUB EBX,EAX + CALL _Pow10 + JMP @@normLoop + +@@testZero: + CMP dword ptr [ESP+4],0 + JNE @@cont + CMP dword ptr [ESP+0],0 + JNE @@cont + +@@exit: + ADD ESP,12 + MOV EAX,EBX + POP EBX +end; + +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 ); +const + MAXDIGS = 256; +asm +// -> [ESP+4] Extended value +// EAX Width +// EDX Precision +// ECX Pointer to string + + FLD tbyte ptr [ESP+4] + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV ESI,EDX + PUSH ECX // save string pointer + SUB ESP,MAXDIGS // VAR digBuf: array [0..MAXDIGS-1] of Char + +// limit width to 255 + + CMP EBX,255 // if width > 255 then width := 255; + JLE @@1 + MOV EBX,255 +@@1: + +// save sign bit in bit 0 of EDI, take absolute value of val, check for +// Nan and infinity. + + FLD ST(0) + FSTP tbyte ptr [ESP] + XOR EAX,EAX + MOV AX,word ptr [ESP+8] + MOV EDI,EAX + SHR EDI,15 + AND AX,7FFFH + CMP AX,7FFFH + JE @@nanInf + FABS + +// if precision < 0 then do scientific else do fixed; + + TEST ESI,ESI + JGE @@fixed + +// the following call finds a decimal exponent and a reduced +// mantissa such that val = mant * 10**exp + + CALL _ScaleExt // val is FST(0), exp is EAX + +// for scientific notation, we have width - 8 significant digits +// however, we can not have less than 2 or more than 18 digits. + +@@scientific: + + MOV ESI,EBX // digCnt := width - 8; + SUB ESI,8 + CMP ESI,2 // if digCnt < 2 then digCnt := 2 + JGE @@2 + MOV ESI,2 + JMP @@3 +@@2: + CMP ESI,18 // else if digCnt > 18 then digCnt := 18; + JLE @@3 + MOV ESI,18 +@@3: + +// _EmitDigits( val, digCnt, digBuf ) + + MOV EDX,ESP // pass digBuf + PUSH EAX // save exponent + MOV EAX,ESI // pass digCnt + CALL _EmitDigits // convert val to ASCII + + MOV EDX,EDI // save sign in EDX + MOV EDI,[ESP+MAXDIGS+4] // load result string pointer + + MOV [EDI],BL // length of result string := width + INC EDI + + MOV AL,' ' // prepare for leading blanks and sign + + MOV ECX,EBX // blankCnt := width - digCnt - 8 + SUB ECX,ESI + SUB ECX,8 + JLE @@4 + + REP STOSB // emit blankCnt blanks +@@4: + SUB [EDI-1],CL // if blankCnt < 0, adjust length + + TEST DL,DL // emit the sign (' ' or '-') + JE @@5 + MOV AL,'-' +@@5: + STOSB + + POP EAX + MOV ECX,ESI // emit digCnt digits + MOV ESI,ESP // point ESI to digBuf + + CMP byte ptr [ESI],'0' + JE @@5a // if rounding overflowed, adjust exponent and ESI + INC EAX + DEC ESI +@@5a: + INC ESI + + MOVSB // emit one digit + MOV byte ptr [EDI],'.' // emit dot + INC EDI // adjust dest pointer + DEC ECX // adjust count + + REP MOVSB + + MOV byte ptr [EDI],'E' + + MOV CL,'+' // emit sign of exponent ('+' or '-') + TEST EAX,EAX + JGE @@6 + MOV CL,'-' + NEG EAX +@@6: + MOV [EDI+1],CL + + XOR EDX,EDX // emit exponent + MOV CX,10 + DIV CX + ADD DL,'0' + MOV [EDI+5],DL + + XOR EDX,EDX + DIV CX + ADD DL,'0' + MOV [EDI+4],DL + + XOR EDX,EDX + DIV CX + ADD DL,'0' + MOV [EDI+3],DL + + ADD AL,'0' + MOV [EDI+2],AL + + JMP @@exit + +@@fixed: + +// FST(0) = value >= 0.0 +// EBX = width +// ESI = precision +// EDI = sign + + CMP ESI,MAXDIGS-40 // else if precision > MAXDIGS-40 then precision := MAXDIGS-40; + JLE @@6a + MOV ESI,MAXDIGS-40 +@@6a: +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + FCOM qword ptr [EAX] + offset Ten + POP EAX +{$ELSE} + FCOM qword ptr ten +{$ENDIF} + FSTSW AX + SAHF + MOV EAX,0 + JB @@7 + + CALL _ScaleExt // val is FST(0), exp is EAX + + CMP EAX,35 // if val is too large, use scientific + JG @@scientific + +@@7: +// FST(0) = scaled value, 0.0 <= value < 10.0 +// EAX = exponent, 0 <= exponent + +// intDigCnt := exponent + 1; + + INC EAX + +// _EmitDigits( value, intDigCnt + precision, digBuf ); + + MOV EDX,ESP + PUSH EAX + ADD EAX,ESI + CALL _EmitDigits + POP EAX + +// Now we need to check whether rounding to the right number of +// digits overflowed, and if so, adjust things accordingly + + MOV EDX,ESI // put precision in EDX + MOV ESI,ESP // point EDI to digBuf + CMP byte ptr [ESI],'0' + JE @@8 + INC EAX + DEC ESI +@@8: + INC ESI + + MOV ECX,EAX // numWidth := sign + intDigCnt; + ADD ECX,EDI + + TEST EDX,EDX // if precision > 0 then + JE @@9 + INC ECX // numWidth := numWidth + 1 + precision + ADD ECX,EDX + + CMP EBX,ECX // if width <= numWidth + JG @@9 + MOV EBX,ECX // width := numWidth +@@9: + PUSH EAX + PUSH EDI + + MOV EDI,[ESP+MAXDIGS+2*4] // point EDI to dest string + + MOV [EDI],BL // store final length in dest string + INC EDI + + SUB EBX,ECX // width := width - numWidth + MOV ECX,EBX + JLE @@10 + + MOV AL,' ' // emit width blanks + REP STOSB +@@10: + SUB [EDI-1],CL // if blankCnt < 0, adjust length + POP EAX + POP ECX + + TEST EAX,EAX + JE @@11 + + MOV byte ptr [EDI],'-' + INC EDI + +@@11: + REP MOVSB // copy intDigCnt digits + + TEST EDX,EDX // if precision > 0 then + JE @@12 + + MOV byte ptr [EDI],'.' // emit '.' + INC EDI + MOV ECX,EDX // emit precision digits + REP MOVSB + +@@12: + +@@exit: + ADD ESP,MAXDIGS + POP ECX + POP EDI + POP ESI + POP EBX + RET 12 + +@@nanInf: +// here: EBX = width, ECX = string pointer, EDI = sign, [ESP] = value + +{$IFDEF PIC} + CALL GetGOT +{$ELSE} + XOR EAX,EAX +{$ENDIF} + FSTP ST(0) + CMP dword ptr [ESP+4],80000000H + LEA ESI,[EAX] + offset nanStr + JNE @@13 + DEC EDI + LEA ESI,[EAX] + offset plusInfStr + JNZ @@13 + LEA ESI,[EAX] + offset minInfStr +@@13: + MOV EDI,ECX + MOV ECX,EBX + MOV [EDI],CL + INC EDI + SUB CL,[ESI] + JBE @@14 + MOV AL,' ' + REP STOSB +@@14: + SUB [EDI-1],CL + MOV CL,[ESI] + INC ESI + REP MOVSB + + JMP @@exit +end; + +procedure _Str0Ext; +asm +// -> [ESP+4] Extended value +// EAX Pointer to string + + MOV ECX,EAX // pass string + MOV EAX,23 // pass default field width + OR EDX,-1 // pass precision -1 + JMP _Str2Ext +end; + +procedure _Str1Ext;//( val: Extended; width: Longint; var s: String ); +asm +// -> [ESP+4] Extended value +// EAX Field width +// EDX Pointer to string + + MOV ECX,EDX + OR EDX,-1 // pass precision -1 + JMP _Str2Ext +end; + +//function _ValExt( s: AnsiString; VAR code: Integer ) : Extended; +procedure _ValExt; +asm +// -> EAX Pointer to string +// EDX Pointer to code result +// <- FST(0) Result + + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX +{$ELSE} + XOR EBX,EBX +{$ENDIF} + PUSH ESI + PUSH EDI + + PUSH EBX // SaveGOT = ESP+8 + MOV ESI,EAX + PUSH EAX // save for the error case + + FLDZ + XOR EAX,EAX + XOR EBX,EBX + XOR EDI,EDI + + PUSH EBX // temp to get digs to fpu + + TEST ESI,ESI + JE @@empty + +@@blankLoop: + MOV BL,[ESI] + INC ESI + CMP BL,' ' + JE @@blankLoop + +@@endBlanks: + MOV CH,0 + CMP BL,'-' + JE @@minus + CMP BL,'+' + JE @@plus + JMP @@firstDigit + +@@minus: + INC CH +@@plus: + MOV BL,[ESI] + INC ESI + +@@firstDigit: + TEST BL,BL + JE @@error + + MOV EDI,[ESP+8] // SaveGOT + +@@digLoop: + SUB BL,'0' + CMP BL,9 + JA @@dotExp + FMUL qword ptr [EDI] + offset Ten + MOV dword ptr [ESP],EBX + FIADD dword ptr [ESP] + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JNE @@digLoop + JMP @@prefinish + +@@dotExp: + CMP BL,'.' - '0' + JNE @@exp + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JE @@prefinish + +// EDI = SaveGot +@@fracDigLoop: + SUB BL,'0' + CMP BL,9 + JA @@exp + FMUL qword ptr [EDI] + offset Ten + MOV dword ptr [ESP],EBX + FIADD dword ptr [ESP] + DEC EAX + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JNE @@fracDigLoop + +@@prefinish: + XOR EDI,EDI + JMP @@finish + +@@exp: + CMP BL,'E' - '0' + JE @@foundExp + CMP BL,'e' - '0' + JNE @@error +@@foundExp: + MOV BL,[ESI] + INC ESI + MOV AH,0 + CMP BL,'-' + JE @@minusExp + CMP BL,'+' + JE @@plusExp + JMP @@firstExpDigit +@@minusExp: + INC AH +@@plusExp: + MOV BL,[ESI] + INC ESI +@@firstExpDigit: + SUB BL,'0' + CMP BL,9 + JA @@error + MOV EDI,EBX + MOV BL,[ESI] + INC ESI + TEST BL,BL + JZ @@endExp +@@expDigLoop: + SUB BL,'0' + CMP BL,9 + JA @@error + LEA EDI,[EDI+EDI*4] + ADD EDI,EDI + ADD EDI,EBX + MOV BL,[ESI] + INC ESI + TEST BL,BL + JNZ @@expDigLoop +@@endExp: + DEC AH + JNZ @@expPositive + NEG EDI +@@expPositive: + MOVSX EAX,AL + +@@finish: + ADD EAX,EDI + PUSH EDX + PUSH ECX + CALL _Pow10 + POP ECX + POP EDX + + DEC CH + JE @@negate + +@@successExit: + + ADD ESP,12 // pop temp and saved copy of string pointer + + XOR ESI,ESI // signal no error to caller + +@@exit: + MOV [EDX],ESI + + POP EDI + POP ESI + POP EBX + RET + +@@negate: + FCHS + JMP @@successExit + +@@empty: + INC ESI + +@@error: + POP EAX + POP EBX + SUB ESI,EBX + ADD ESP,4 + JMP @@exit +end; + +procedure FPower10; +asm + JMP _Pow10 +end; + +//function _Pow10(val: Extended; Power: Integer): Extended; +procedure _Pow10; +asm +// -> FST(0) val +// -> EAX Power +// <- FST(0) val * 10**Power + +// This routine generates 10**power with no more than two +// floating point multiplications. Up to 10**31, no multiplications +// are needed. + + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX +{$ELSE} + XOR EBX,EBX +{$ENDIF} + TEST EAX,EAX + JL @@neg + JE @@exit + CMP EAX,5120 + JGE @@inf + MOV EDX,EAX + AND EDX,01FH + LEA EDX,[EDX+EDX*4] + FLD tbyte ptr @@tab0[EBX+EDX*2] + + FMULP + + SHR EAX,5 + JE @@exit + + MOV EDX,EAX + AND EDX,0FH + JE @@skip2ndMul + LEA EDX,[EDX+EDX*4] + FLD tbyte ptr @@tab1-10[EBX+EDX*2] + FMULP + +@@skip2ndMul: + + SHR EAX,4 + JE @@exit + LEA EAX,[EAX+EAX*4] + FLD tbyte ptr @@tab2-10[EBX+EAX*2] + FMULP + JMP @@exit + +@@neg: + NEG EAX + CMP EAX,5120 + JGE @@zero + MOV EDX,EAX + AND EDX,01FH + LEA EDX,[EDX+EDX*4] + FLD tbyte ptr @@tab0[EBX+EDX*2] + FDIVP + + SHR EAX,5 + JE @@exit + + MOV EDX,EAX + AND EDX,0FH + JE @@skip2ndDiv + LEA EDX,[EDX+EDX*4] + FLD tbyte ptr @@tab1-10[EBX+EDX*2] + FDIVP + +@@skip2ndDiv: + + SHR EAX,4 + JE @@exit + LEA EAX,[EAX+EAX*4] + FLD tbyte ptr @@tab2-10[EBX+EAX*2] + FDIVP + + JMP @@exit + +@@inf: + FSTP ST(0) + FLD tbyte ptr @@infval[EBX] + JMP @@exit + +@@zero: + FSTP ST(0) + FLDZ + +@@exit: + POP EBX + RET + +@@infval: DW $0000,$0000,$0000,$8000,$7FFF +@@tab0: DW $0000,$0000,$0000,$8000,$3FFF // 10**0 + DW $0000,$0000,$0000,$A000,$4002 // 10**1 + DW $0000,$0000,$0000,$C800,$4005 // 10**2 + DW $0000,$0000,$0000,$FA00,$4008 // 10**3 + DW $0000,$0000,$0000,$9C40,$400C // 10**4 + DW $0000,$0000,$0000,$C350,$400F // 10**5 + DW $0000,$0000,$0000,$F424,$4012 // 10**6 + DW $0000,$0000,$8000,$9896,$4016 // 10**7 + DW $0000,$0000,$2000,$BEBC,$4019 // 10**8 + DW $0000,$0000,$2800,$EE6B,$401C // 10**9 + DW $0000,$0000,$F900,$9502,$4020 // 10**10 + DW $0000,$0000,$B740,$BA43,$4023 // 10**11 + DW $0000,$0000,$A510,$E8D4,$4026 // 10**12 + DW $0000,$0000,$E72A,$9184,$402A // 10**13 + DW $0000,$8000,$20F4,$B5E6,$402D // 10**14 + DW $0000,$A000,$A931,$E35F,$4030 // 10**15 + DW $0000,$0400,$C9BF,$8E1B,$4034 // 10**16 + DW $0000,$C500,$BC2E,$B1A2,$4037 // 10**17 + DW $0000,$7640,$6B3A,$DE0B,$403A // 10**18 + DW $0000,$89E8,$2304,$8AC7,$403E // 10**19 + DW $0000,$AC62,$EBC5,$AD78,$4041 // 10**20 + DW $8000,$177A,$26B7,$D8D7,$4044 // 10**21 + DW $9000,$6EAC,$7832,$8786,$4048 // 10**22 + DW $B400,$0A57,$163F,$A968,$404B // 10**23 + DW $A100,$CCED,$1BCE,$D3C2,$404E // 10**24 + DW $84A0,$4014,$5161,$8459,$4052 // 10**25 + DW $A5C8,$9019,$A5B9,$A56F,$4055 // 10**26 + DW $0F3A,$F420,$8F27,$CECB,$4058 // 10**27 + DW $0984,$F894,$3978,$813F,$405C // 10**28 + DW $0BE5,$36B9,$07D7,$A18F,$405F // 10**29 + DW $4EDF,$0467,$C9CD,$C9F2,$4062 // 10**30 + DW $2296,$4581,$7C40,$FC6F,$4065 // 10**31 + +@@tab1: DW $B59E,$2B70,$ADA8,$9DC5,$4069 // 10**32 + DW $A6D5,$FFCF,$1F49,$C278,$40D3 // 10**64 + DW $14A3,$C59B,$AB16,$EFB3,$413D // 10**96 + DW $8CE0,$80E9,$47C9,$93BA,$41A8 // 10**128 + DW $17AA,$7FE6,$A12B,$B616,$4212 // 10**160 + DW $556B,$3927,$F78D,$E070,$427C // 10**192 + DW $C930,$E33C,$96FF,$8A52,$42E7 // 10**224 + DW $DE8E,$9DF9,$EBFB,$AA7E,$4351 // 10**256 + DW $2F8C,$5C6A,$FC19,$D226,$43BB // 10**288 + DW $E376,$F2CC,$2F29,$8184,$4426 // 10**320 + DW $0AD2,$DB90,$2700,$9FA4,$4490 // 10**352 + DW $AA17,$AEF8,$E310,$C4C5,$44FA // 10**384 + DW $9C59,$E9B0,$9C07,$F28A,$4564 // 10**416 + DW $F3D4,$EBF7,$4AE1,$957A,$45CF // 10**448 + DW $A262,$0795,$D8DC,$B83E,$4639 // 10**480 + +@@tab2: DW $91C7,$A60E,$A0AE,$E319,$46A3 // 10**512 + DW $0C17,$8175,$7586,$C976,$4D48 // 10**1024 + DW $A7E4,$3993,$353B,$B2B8,$53ED // 10**1536 + DW $5DE5,$C53D,$3B5D,$9E8B,$5A92 // 10**2048 + DW $F0A6,$20A1,$54C0,$8CA5,$6137 // 10**2560 + DW $5A8B,$D88B,$5D25,$F989,$67DB // 10**3072 + DW $F3F8,$BF27,$C8A2,$DD5D,$6E80 // 10**3584 + DW $979B,$8A20,$5202,$C460,$7525 // 10**4096 + DW $59F0,$6ED5,$1162,$AE35,$7BCA // 10**4608 +end; + +const + RealBias = 129; + ExtBias = $3FFF; + +procedure _Real2Ext;//( val : Real ) : Extended; +asm +// -> EAX Pointer to value +// <- FST(0) Result + +// the REAL data type has the following format: +// 8 bit exponent (bias 129), 39 bit fraction, 1 bit sign + + MOV DH,[EAX+5] // isolate the sign bit + AND DH,80H + MOV DL,[EAX] // fetch exponent + TEST DL,DL // exponent zero means number is zero + JE @@zero + + ADD DX,ExtBias-RealBias // adjust exponent bias + + PUSH EDX // the exponent is at the highest address + + MOV EDX,[EAX+2] // load high fraction part, set hidden bit + OR EDX,80000000H + PUSH EDX // push high fraction part + + MOV DL,[EAX+1] // load remaining low byte of fraction + SHL EDX,24 // clear low 24 bits + PUSH EDX + + FLD tbyte ptr [ESP] // pop result onto chip + ADD ESP,12 + + RET + +@@zero: + FLDZ + RET +end; + +procedure _Ext2Real;//( val : Extended ) : Real; +asm +// -> FST(0) Value +// EAX Pointer to result + + PUSH EBX + + SUB ESP,12 + FSTP tbyte ptr [ESP] + + POP EBX // EBX is low half of fraction + POP EDX // EDX is high half of fraction + POP ECX // CX is exponent and sign + + SHR EBX,24 // set carry to last bit shifted out + ADC BL,0 // if bit was 1, round up + ADC EDX,0 + ADC CX,0 + JO @@overflow + + ADD EDX,EDX // shift fraction 1 bit left + ADD CX,CX // shift sign bit into carry + RCR EDX,1 // attach sign bit to fraction + SHR CX,1 // restore exponent, deleting sign + + SUB CX,ExtBias-RealBias // adjust exponent + JLE @@underflow + TEST CH,CH // CX must be in 1..255 + JG @@overflow + + MOV [EAX],CL + MOV [EAX+1],BL + MOV [EAX+2],EDX + + POP EBX + RET + +@@underflow: + XOR ECX,ECX + MOV [EAX],ECX + MOV [EAX+4],CX + POP EBX + RET + +@@overflow: + POP EBX + MOV AL,8 + JMP Error +end; + +const + ovtInstanceSize = -8; { Offset of instance size in OBJECTs } + ovtVmtPtrOffs = -4; + +procedure _ObjSetup; +asm +{ FUNCTION _ObjSetup( self: ^OBJECT; vmt: ^VMT): ^OBJECT; } +{ ->EAX Pointer to self (possibly nil) } +{ EDX Pointer to vmt (possibly nil) } +{ <-EAX Pointer to self } +{ EDX <> 0: an object was allocated } +{ Z-Flag Set: failure, Cleared: Success } + + CMP EDX,1 { is vmt = 0, indicating a call } + JAE @@skip1 { from a constructor? } + RET { return immediately with Z-flag cleared } + +@@skip1: + PUSH ECX + TEST EAX,EAX { is self already allocated? } + JNE @@noAlloc + MOV EAX,[EDX].ovtInstanceSize + TEST EAX,EAX + JE @@zeroSize + PUSH EDX + CALL _GetMem + POP EDX + TEST EAX,EAX + JZ @@fail + + { Zero fill the memory } + PUSH EDI + MOV ECX,[EDX].ovtInstanceSize + MOV EDI,EAX + PUSH EAX + XOR EAX,EAX + SHR ECX,2 + REP STOSD + MOV ECX,[EDX].ovtInstanceSize + AND ECX,3 + REP STOSB + POP EAX + POP EDI + + MOV ECX,[EDX].ovtVmtPtrOffs + TEST ECX,ECX + JL @@skip + MOV [EAX+ECX],EDX { store vmt in object at this offset } +@@skip: + TEST EAX,EAX { clear zero flag } + POP ECX + RET + +@@fail: + XOR EDX,EDX + POP ECX + RET + +@@zeroSize: + XOR EDX,EDX + CMP EAX,1 { clear zero flag - we were successful (kind of) } + POP ECX + RET + +@@noAlloc: + MOV ECX,[EDX].ovtVmtPtrOffs + TEST ECX,ECX + JL @@exit + MOV [EAX+ECX],EDX { store vmt in object at this offset } +@@exit: + XOR EDX,EDX { clear allocated flag } + TEST EAX,EAX { clear zero flag } + POP ECX +end; + +procedure _ObjCopy; +asm +{ PROCEDURE _ObjCopy( dest, src: ^OBJECT; vmtPtrOff: Longint); } +{ ->EAX Pointer to destination } +{ EDX Pointer to source } +{ ECX Offset of vmt in those objects. } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EDX + MOV EDI,EAX + + LEA EAX,[EDI+ECX] { remember pointer to dest vmt pointer } + MOV EDX,[EAX] { fetch dest vmt pointer } + + MOV EBX,[EDX].ovtInstanceSize + + MOV ECX,EBX { copy size DIV 4 dwords } + SHR ECX,2 + REP MOVSD + + MOV ECX,EBX { copy size MOD 4 bytes } + AND ECX,3 + REP MOVSB + + MOV [EAX],EDX { restore dest vmt } + + POP EDI + POP ESI + POP EBX +end; + +procedure _Fail; +asm +{ FUNCTION _Fail( self: ^OBJECT; allocFlag:Longint): ^OBJECT; } +{ ->EAX Pointer to self (possibly nil) } +{ EDX <> 0: Object must be deallocated } +{ <-EAX Nil } + + TEST EDX,EDX + JE @@exit { if no object was allocated, return } + CALL _FreeMem +@@exit: + XOR EAX,EAX +end; + +{$IFDEF MSWINDOWS} +function GetKeyboardType(nTypeFlag: Integer): Integer; stdcall; + external user name 'GetKeyboardType'; + +function _isNECWindows: Boolean; +var + KbSubType: Integer; +begin + Result := False; + if GetKeyboardType(0) = $7 then + begin + KbSubType := GetKeyboardType(1) and $FF00; + if (KbSubType = $0D00) or (KbSubType = $0400) then + Result := True; + end; +end; + +const + HKEY_LOCAL_MACHINE = $80000002; + +// workaround a Japanese Win95 bug +procedure _FpuMaskInit; +const + KEY_QUERY_VALUE = $00000001; + REG_DWORD = 4; + FPUMASKKEY = 'SOFTWARE\Borland\Delphi\RTL'; + FPUMASKNAME = 'FPUMaskValue'; +var + phkResult: LongWord; + lpData, DataSize: Longint; +begin + lpData := Default8087CW; + + if RegOpenKeyEx(HKEY_LOCAL_MACHINE, FPUMASKKEY, 0, KEY_QUERY_VALUE, phkResult) = 0 then + try + DataSize := Sizeof(lpData); + RegQueryValueEx(phkResult, FPUMASKNAME, nil, nil, @lpData, @DataSize); + finally + RegCloseKey(phkResult); + end; + Default8087CW := (Default8087CW and $ffc0) or (lpData and $3f); +end; +{$ENDIF} + +procedure _FpuInit; +asm + FNINIT + FWAIT +{$IFDEF PIC} + CALL GetGOT + MOV EAX,[EAX].OFFSET Default8087CW + FLDCW [EAX] +{$ELSE} + FLDCW Default8087CW +{$ENDIF} +end; + +procedure _BoundErr; +asm + MOV AL,reRangeError + JMP Error +end; + +procedure _IntOver; +asm + MOV AL,reIntOverflow + JMP Error +end; + +function TObject.ClassType: TClass; +begin + Pointer(Result) := PPointer(Self)^; +end; + +class function TObject.ClassName: ShortString; +{$IFDEF PUREPASCAL} +begin + Result := PShortString(PPointer(Integer(Self) + vmtClassName)^)^; +end; +{$ELSE} +asm + { -> EAX VMT } + { EDX Pointer to result string } + PUSH ESI + PUSH EDI + MOV EDI,EDX + MOV ESI,[EAX].vmtClassName + XOR ECX,ECX + MOV CL,[ESI] + INC ECX + REP MOVSB + POP EDI + POP ESI +end; +{$ENDIF} + +class function TObject.ClassNameIs(const Name: string): Boolean; +{$IFDEF MSWINDOWS} +const + CSTR_EQUAL = 2; + LOCALE_SYSTEM_DEFAULT = 2048; + NORM_IGNORECASE = 1; +var + LClassName: string; +begin + LClassName := ClassName; + Result := CompareString(LOCALE_SYSTEM_DEFAULT, NORM_IGNORECASE, PChar(LClassName), + Length(LClassName), PChar(Name), Length(Name)) = CSTR_EQUAL; +end; +{$ELSE} +{$IFDEF PUREPASCAL} +var + Temp: ShortString; + I: Byte; +begin + Result := False; + Temp := ClassName; + for I := 0 to Byte(Temp[0]) do + if Temp[I] <> Name[I] then Exit; + Result := True; +end; +{$ELSE} +asm + PUSH EBX + XOR EBX,EBX + OR EDX,EDX + JE @@exit + MOV EAX,[EAX].vmtClassName + XOR ECX,ECX + MOV CL,[EAX] + CMP ECX,[EDX-4] + JNE @@exit + DEC EDX +@@loop: + MOV BH,[EAX+ECX] + XOR BH,[EDX+ECX] + AND BH,0DFH + JNE @@exit + DEC ECX + JNE @@loop + INC EBX +@@exit: + MOV AL,BL + POP EBX +end; +{$ENDIF} +{$ENDIF} + +class function TObject.ClassParent: TClass; +{$IFDEF PUREPASCAL} +begin + Pointer(Result) := PPointer(Integer(Self) + vmtParent)^; + if Result <> nil then + Pointer(Result) := PPointer(Result)^; +end; +{$ELSE} +asm + MOV EAX,[EAX].vmtParent + TEST EAX,EAX + JE @@exit + MOV EAX,[EAX] +@@exit: +end; +{$ENDIF} + +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; +begin +end; + +destructor TObject.Destroy; +begin +end; + +procedure TObject.Free; +begin + if Self <> nil then + Destroy; +end; + +class function TObject.InitInstance(Instance: Pointer): TObject; +{$IFDEF PUREPASCAL} +var + IntfTable: PInterfaceTable; + ClassPtr: TClass; + I: Integer; +begin + FillChar(Instance^, InstanceSize, 0); + PInteger(Instance)^ := Integer(Self); + ClassPtr := Self; + while ClassPtr <> nil do + begin + IntfTable := ClassPtr.GetInterfaceTable; + if IntfTable <> nil then + for I := 0 to IntfTable.EntryCount-1 do + with IntfTable.Entries[I] do + begin + if VTable <> nil then + PInteger(@PChar(Instance)[IOffset])^ := Integer(VTable); + end; + ClassPtr := ClassPtr.ClassParent; + end; + Result := Instance; +end; +{$ELSE} +asm + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV EDI,EDX + STOSD + MOV ECX,[EBX].vmtInstanceSize + XOR EAX,EAX + PUSH ECX + SHR ECX,2 + DEC ECX + REP STOSD + POP ECX + AND ECX,3 + REP STOSB + MOV EAX,EDX + MOV EDX,ESP +@@0: MOV ECX,[EBX].vmtIntfTable + TEST ECX,ECX + JE @@1 + PUSH ECX +@@1: MOV EBX,[EBX].vmtParent + TEST EBX,EBX + JE @@2 + MOV EBX,[EBX] + JMP @@0 +@@2: CMP ESP,EDX + JE @@5 +@@3: POP EBX + MOV ECX,[EBX].TInterfaceTable.EntryCount + ADD EBX,4 +@@4: MOV ESI,[EBX].TInterfaceEntry.VTable + TEST ESI,ESI + JE @@4a + MOV EDI,[EBX].TInterfaceEntry.IOffset + MOV [EAX+EDI],ESI +@@4a: ADD EBX,TYPE TInterfaceEntry + DEC ECX + JNE @@4 + CMP ESP,EDX + JNE @@3 +@@5: POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +procedure TObject.CleanupInstance; +{$IFDEF PUREPASCAL} +var + ClassPtr: TClass; + InitTable: Pointer; +begin + ClassPtr := ClassType; + InitTable := PPointer(Integer(ClassPtr) + vmtInitTable)^; + while (ClassPtr <> nil) and (InitTable <> nil) do + begin + _FinalizeRecord(Self, InitTable); + ClassPtr := ClassPtr.ClassParent; + if ClassPtr <> nil then + InitTable := PPointer(Integer(ClassPtr) + vmtInitTable)^; + end; +end; +{$ELSE} +asm + PUSH EBX + PUSH ESI + MOV EBX,EAX + MOV ESI,EAX +@@loop: + MOV ESI,[ESI] + MOV EDX,[ESI].vmtInitTable + MOV ESI,[ESI].vmtParent + TEST EDX,EDX + JE @@skip + CALL _FinalizeRecord + MOV EAX,EBX +@@skip: + TEST ESI,ESI + JNE @@loop + + POP ESI + POP EBX +end; +{$ENDIF} + +function InvokeImplGetter(Self: TObject; ImplGetter: Cardinal): IInterface; +{$IFDEF PUREPASCAL} +var + M: function: IInterface of object; +begin + TMethod(M).Data := Self; + case ImplGetter of + $FF000000..$FFFFFFFF: // Field + Result := IInterface(Pointer(Cardinal(Self) + (ImplGetter and $00FFFFFF))); + $FE000000..$FEFFFFFF: // virtual method + begin + // sign extend vmt slot offset = smallint cast + TMethod(M).Code := PPointer(Integer(Self) + SmallInt(ImplGetter))^; + Result := M; + end; + else // static method + TMethod(M).Code := Pointer(ImplGetter); + Result := M; + end; +end; +{$ELSE} +asm + XCHG EDX,ECX + CMP ECX,$FF000000 + JAE @@isField + CMP ECX,$FE000000 + JB @@isStaticMethod + + { the GetProc is a virtual method } + MOVSX ECX,CX { sign extend slot offs } + ADD ECX,[EAX] { vmt + slotoffs } + JMP dword ptr [ECX] { call vmt[slot] } + +@@isStaticMethod: + JMP ECX + +@@isField: + AND ECX,$00FFFFFF + ADD ECX,EAX + MOV EAX,EDX + MOV EDX,[ECX] + JMP _IntfCopy +end; +{$ENDIF} + +function TObject.GetInterface(const IID: TGUID; out Obj): Boolean; +var + InterfaceEntry: PInterfaceEntry; +begin + Pointer(Obj) := nil; + InterfaceEntry := GetInterfaceEntry(IID); + if InterfaceEntry <> nil then + begin + if InterfaceEntry^.IOffset <> 0 then + begin + Pointer(Obj) := Pointer(Integer(Self) + InterfaceEntry^.IOffset); + if Pointer(Obj) <> nil then IInterface(Obj)._AddRef; + end + else + IInterface(Obj) := InvokeImplGetter(Self, InterfaceEntry^.ImplGetter); + end; + Result := Pointer(Obj) <> nil; +end; + +class function TObject.GetInterfaceEntry(const IID: TGUID): PInterfaceEntry; +{$IFDEF PUREPASCAL} +var + ClassPtr: TClass; + IntfTable: PInterfaceTable; + I: Integer; +begin + ClassPtr := Self; + while ClassPtr <> nil do + begin + IntfTable := ClassPtr.GetInterfaceTable; + if IntfTable <> nil then + for I := 0 to IntfTable.EntryCount-1 do + begin + Result := @IntfTable.Entries[I]; +// if Result^.IID = IID then Exit; + if (Int64(Result^.IID.D1) = Int64(IID.D1)) and + (Int64(Result^.IID.D4) = Int64(IID.D4)) then Exit; + end; + ClassPtr := ClassPtr.ClassParent; + end; + Result := nil; +end; +{$ELSE} +asm + PUSH EBX + PUSH ESI + MOV EBX,EAX +@@1: MOV EAX,[EBX].vmtIntfTable + TEST EAX,EAX + JE @@4 + MOV ECX,[EAX].TInterfaceTable.EntryCount + ADD EAX,4 +@@2: MOV ESI,[EDX].Integer[0] + CMP ESI,[EAX].TInterfaceEntry.IID.Integer[0] + JNE @@3 + MOV ESI,[EDX].Integer[4] + CMP ESI,[EAX].TInterfaceEntry.IID.Integer[4] + JNE @@3 + MOV ESI,[EDX].Integer[8] + CMP ESI,[EAX].TInterfaceEntry.IID.Integer[8] + JNE @@3 + MOV ESI,[EDX].Integer[12] + CMP ESI,[EAX].TInterfaceEntry.IID.Integer[12] + JE @@5 +@@3: ADD EAX,type TInterfaceEntry + DEC ECX + JNE @@2 +@@4: MOV EBX,[EBX].vmtParent + TEST EBX,EBX + JE @@4a + MOV EBX,[EBX] + JMP @@1 +@@4a: XOR EAX,EAX +@@5: POP ESI + POP EBX +end; +{$ENDIF} + +class function TObject.GetInterfaceTable: PInterfaceTable; +begin + Result := PPointer(Integer(Self) + vmtIntfTable)^; +end; + +function _IsClass(Child: TObject; Parent: TClass): Boolean; +begin + Result := (Child <> nil) and Child.InheritsFrom(Parent); +end; + +function _AsClass(Child: TObject; Parent: TClass): TObject; +{$IFDEF PUREPASCAL} +begin + Result := Child; + if not (Child is Parent) then + Error(reInvalidCast); // loses return address +end; +{$ELSE} +asm + { -> EAX left operand (class) } + { EDX VMT of right operand } + { <- EAX if left is derived from right, else runtime error } + TEST EAX,EAX + JE @@exit + MOV ECX,EAX +@@loop: + MOV ECX,[ECX] + CMP ECX,EDX + JE @@exit + MOV ECX,[ECX].vmtParent + TEST ECX,ECX + JNE @@loop + + { do runtime error } + MOV AL,reInvalidCast + JMP Error + +@@exit: +end; +{$ENDIF} + +function _GetHelperIntf(Instance: TObject; Cls: TClass): IInterface; +begin + + Result := nil; +end; + +procedure GetDynaMethod; +{ function GetDynaMethod(vmt: TClass; selector: Smallint) : Pointer; } +asm + { -> EAX vmt of class } + { SI dynamic method index } + { <- ESI pointer to routine } + { ZF = 0 if found } + { trashes: EAX, ECX } + + PUSH EDI + XCHG EAX,ESI + JMP @@haveVMT +@@outerLoop: + MOV ESI,[ESI] +@@haveVMT: + MOV EDI,[ESI].vmtDynamicTable + TEST EDI,EDI + JE @@parent + MOVZX ECX,word ptr [EDI] + PUSH ECX + ADD EDI,2 + REPNE SCASW + JE @@found + POP ECX +@@parent: + MOV ESI,[ESI].vmtParent + TEST ESI,ESI + JNE @@outerLoop + JMP @@exit + +@@found: + POP EAX + ADD EAX,EAX + SUB EAX,ECX { this will always clear the Z-flag ! } + MOV ESI,[EDI+EAX*2-4] + +@@exit: + POP EDI +end; + +procedure _CallDynaInst; +asm + PUSH EAX + PUSH ECX + MOV EAX,[EAX] + CALL GetDynaMethod + POP ECX + POP EAX + JE @@Abstract + JMP ESI +@@Abstract: + POP ECX + JMP _AbstractError +end; + + +procedure _CallDynaClass; +asm + PUSH EAX + PUSH ECX + CALL GetDynaMethod + POP ECX + POP EAX + JE @@Abstract + JMP ESI +@@Abstract: + POP ECX + JMP _AbstractError +end; + + +procedure _FindDynaInst; +asm + PUSH ESI + MOV ESI,EDX + MOV EAX,[EAX] + CALL GetDynaMethod + MOV EAX,ESI + POP ESI + JNE @@exit + POP ECX + JMP _AbstractError +@@exit: +end; + + +procedure _FindDynaClass; +asm + PUSH ESI + MOV ESI,EDX + CALL GetDynaMethod + MOV EAX,ESI + POP ESI + JNE @@exit + POP ECX + JMP _AbstractError +@@exit: +end; + +class function TObject.InheritsFrom(AClass: TClass): Boolean; +{$IFDEF PUREPASCAL} +var + ClassPtr: TClass; +begin + ClassPtr := Self; + while (ClassPtr <> nil) and (ClassPtr <> AClass) do + ClassPtr := PPointer(Integer(ClassPtr) + vmtParent)^; + Result := ClassPtr = AClass; +end; +{$ELSE} +asm + { -> EAX Pointer to our class } + { EDX Pointer to AClass } + { <- AL Boolean result } + JMP @@haveVMT +@@loop: + MOV EAX,[EAX] +@@haveVMT: + CMP EAX,EDX + JE @@success + MOV EAX,[EAX].vmtParent + TEST EAX,EAX + JNE @@loop + JMP @@exit +@@success: + MOV AL,1 +@@exit: +end; +{$ENDIF} + + +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); +begin +end; + + +procedure TObject.AfterConstruction; +begin +end; + +procedure TObject.BeforeDestruction; +begin +end; + +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; +asm + { -> EAX Pointer to class } + { EDX Pointer to name } + PUSH EBX + PUSH ESI + PUSH EDI + XOR ECX,ECX + XOR EDI,EDI + MOV BL,[EDX] + JMP @@haveVMT +@@outer: { upper 16 bits of ECX are 0 ! } + MOV EAX,[EAX] +@@haveVMT: + MOV ESI,[EAX].vmtMethodTable + TEST ESI,ESI + JE @@parent + MOV DI,[ESI] { EDI := method count } + ADD ESI,2 +@@inner: { upper 16 bits of ECX are 0 ! } + MOV CL,[ESI+6] { compare length of strings } + CMP CL,BL + JE @@cmpChar +@@cont: { upper 16 bits of ECX are 0 ! } + MOV CX,[ESI] { fetch length of method desc } + ADD ESI,ECX { point ESI to next method } + DEC EDI + JNZ @@inner +@@parent: + MOV EAX,[EAX].vmtParent { fetch parent vmt } + TEST EAX,EAX + JNE @@outer + JMP @@exit { return NIL } + +@@notEqual: + MOV BL,[EDX] { restore BL to length of name } + JMP @@cont + +@@cmpChar: { upper 16 bits of ECX are 0 ! } + MOV CH,0 { upper 24 bits of ECX are 0 ! } +@@cmpCharLoop: + MOV BL,[ESI+ECX+6] { case insensitive string cmp } + XOR BL,[EDX+ECX+0] { last char is compared first } + AND BL,$DF + JNE @@notEqual + DEC ECX { ECX serves as counter } + JNZ @@cmpCharLoop + + { found it } + MOV EAX,[ESI+2] + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +class function TObject.MethodName(Address: Pointer): ShortString; +asm + { -> EAX Pointer to class } + { EDX Address } + { ECX Pointer to result } + PUSH EBX + PUSH ESI + PUSH EDI + MOV EDI,ECX + XOR EBX,EBX + XOR ECX,ECX + JMP @@haveVMT +@@outer: + MOV EAX,[EAX] +@@haveVMT: + MOV ESI,[EAX].vmtMethodTable { fetch pointer to method table } + TEST ESI,ESI + JE @@parent + MOV CX,[ESI] + ADD ESI,2 +@@inner: + CMP EDX,[ESI+2] + JE @@found + MOV BX,[ESI] + ADD ESI,EBX + DEC ECX + JNZ @@inner +@@parent: + MOV EAX,[EAX].vmtParent + TEST EAX,EAX + JNE @@outer + MOV [EDI],AL + JMP @@exit + +@@found: + ADD ESI,6 + XOR ECX,ECX + MOV CL,[ESI] + INC ECX + REP MOVSB + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +function TObject.FieldAddress(const Name: ShortString): Pointer; +asm + { -> EAX Pointer to instance } + { EDX Pointer to name } + PUSH EBX + PUSH ESI + PUSH EDI + XOR ECX,ECX + XOR EDI,EDI + MOV BL,[EDX] + + PUSH EAX { save instance pointer } + +@@outer: + MOV EAX,[EAX] { fetch class pointer } + MOV ESI,[EAX].vmtFieldTable + TEST ESI,ESI + JE @@parent + MOV DI,[ESI] { fetch count of fields } + ADD ESI,6 +@@inner: + MOV CL,[ESI+6] { compare string lengths } + CMP CL,BL + JE @@cmpChar +@@cont: + LEA ESI,[ESI+ECX+7] { point ESI to next field } + DEC EDI + JNZ @@inner +@@parent: + MOV EAX,[EAX].vmtParent { fetch parent VMT } + TEST EAX,EAX + JNE @@outer + POP EDX { forget instance, return Nil } + JMP @@exit + +@@notEqual: + MOV BL,[EDX] { restore BL to length of name } + MOV CL,[ESI+6] { ECX := length of field name } + JMP @@cont + +@@cmpChar: + MOV BL,[ESI+ECX+6] { case insensitive string cmp } + XOR BL,[EDX+ECX+0] { starting with last char } + AND BL,$DF + JNE @@notEqual + DEC ECX { ECX serves as counter } + JNZ @@cmpChar + + { found it } + MOV EAX,[ESI] { result is field offset plus ... } + POP EDX + ADD EAX,EDX { instance pointer } + +@@exit: + POP EDI + POP ESI + POP EBX +end; + +function _ClassCreate(AClass: TClass; Alloc: Boolean): TObject; +asm + { -> EAX = pointer to VMT } + { <- EAX = pointer to instance } + PUSH EDX + PUSH ECX + PUSH EBX + TEST DL,DL + JL @@noAlloc + CALL DWORD PTR [EAX] + VMTOFFSET TObject.NewInstance +@@noAlloc: +{$IFNDEF PC_MAPPED_EXCEPTIONS} + XOR EDX,EDX + LEA ECX,[ESP+16] + MOV EBX,FS:[EDX] + MOV [ECX].TExcFrame.next,EBX + MOV [ECX].TExcFrame.hEBP,EBP + MOV [ECX].TExcFrame.desc,offset @desc + MOV [ECX].TexcFrame.ConstructedObject,EAX { trick: remember copy to instance } + MOV FS:[EDX],ECX +{$ENDIF} + POP EBX + POP ECX + POP EDX + RET + +{$IFNDEF PC_MAPPED_EXCEPTIONS} +@desc: + JMP _HandleAnyException + + { destroy the object } + + MOV EAX,[ESP+8+9*4] + MOV EAX,[EAX].TExcFrame.ConstructedObject + TEST EAX,EAX + JE @@skip + MOV ECX,[EAX] + MOV DL,$81 + PUSH EAX + CALL DWORD PTR [ECX] + VMTOFFSET TObject.Destroy + POP EAX + CALL _ClassDestroy +@@skip: + { reraise the exception } + CALL _RaiseAgain +{$ENDIF} +end; + +procedure _ClassDestroy(Instance: TObject); +begin + Instance.FreeInstance; +end; + + +function _AfterConstruction(Instance: TObject): TObject; +begin + try + Instance.AfterConstruction; + Result := Instance; + except + _BeforeDestruction(Instance, 1); + raise; + end; +end; + +function _BeforeDestruction(Instance: TObject; OuterMost: ShortInt): TObject; +// Must preserve DL on return! +{$IFDEF PUREPASCAL} +begin + Result := Instance; + if OuterMost > 0 then Exit; + Instance.BeforeDestruction; +end; +{$ELSE} +asm + { -> EAX = pointer to instance } + { DL = dealloc flag } + + TEST DL,DL + JG @@outerMost + RET +@@outerMost: + PUSH EAX + PUSH EDX + MOV EDX,[EAX] + CALL DWORD PTR [EDX] + VMTOFFSET TObject.BeforeDestruction + POP EDX + POP EAX +end; +{$ENDIF} + +{ + 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. +} + +{$IFDEF LINUX} +const + excRaise = 0; { an exception is being raised by the user (could be a reraise) } + excCatch = 1; { an exception is about to be caught } + excFinally = 2; { a finally block is about to be executed because of an exception } + excUnhandled = 3; { no user exception handler was found (the app will die) } + +procedure _DbgExcNotify( + NotificationKind: Integer; + ExceptionObject: Pointer; + ExceptionName: PShortString; + ExceptionLocation: Pointer; + HandlerAddr: Pointer); cdecl; export; +begin +{$IFDEF DEBUG} + { + This code is just for debugging the exception handling system. The debugger + needs _DbgExcNotify, however to place breakpoints in, so the function itself + cannot be removed. + } + asm + PUSH EAX + PUSH EDX + end; + if Assigned(ExcNotificationProc) then + ExcNotificationProc(NotificationKind, ExceptionObject, ExceptionName, ExceptionLocation, HandlerAddr); + asm + POP EDX + POP EAX + end; +{$ENDIF} +end; + +{ + The following functions are used by the debugger for the evaluator. If you + change them IN ANY WAY, the debugger will cease to function correctly. +} +procedure _DbgEvalMarker; +begin +end; + +procedure _DbgEvalExcept(E: TObject); +begin +end; + +procedure _DbgEvalEnd; +begin +end; + +{ + This function is used by the debugger to provide a soft landing spot + when evaluating a function call that may raise an unhandled exception. + The return address of _DbgEvalMarker is pushed onto the stack so that + the unwinder will transfer control to the except block. +} +procedure _DbgEvalFrame; +begin + try + _DbgEvalMarker; + except on E: TObject do + _DbgEvalExcept(E); + end; + _DbgEvalEnd; +end; + +{ + These export names need to match the names that will be generated into + the .symtab section, so that the debugger can find them if stabs + debug information is being generated. +} +exports + _DbgExcNotify name '@DbgExcNotify', + _DbgEvalFrame name '@DbgEvalFrame', + _DbgEvalMarker name '@DbgEvalMarker', + _DbgEvalExcept name '@DbgEvalExcept', + _DbgEvalEnd name '@DbgEvalEnd'; +{$ENDIF} + +{ tell the debugger that the next raise is a re-raise of the current non-Delphi + exception } +procedure NotifyReRaise; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX location of exception } + PUSH 0 { handler addr } + PUSH EDX { location of exception } + MOV ECX, [EAX] + PUSH [ECX].vmtClassName { exception name } + PUSH EAX { exception object } + PUSH excRaise { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 +{$ELSE} + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH 0 + PUSH 0 + PUSH cContinuable + PUSH cDelphiReRaise + CALL RaiseExceptionProc +@@1: +{$ENDIF} +end; + +{ tell the debugger about the raise of a non-Delphi exception } +{$IFNDEF LINUX} +procedure NotifyNonDelphiException; +asm + CMP BYTE PTR DebugHook,0 + JE @@1 + PUSH EAX + PUSH EAX + PUSH EDX + PUSH ESP + PUSH 2 + PUSH cContinuable + PUSH cNonDelphiException + CALL RaiseExceptionProc + ADD ESP,8 + POP EAX +@@1: +end; +{$ENDIF} + +{ Tell the debugger where the handler for the current exception is located } +procedure NotifyExcept; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX handler addr } + PUSH EAX + MOV EAX, [EAX].TRaisedException.ExceptObject + + PUSH EDX { handler addr } + PUSH 0 { location of exception } + MOV ECX, [EAX] + PUSH [ECX].vmtClassName { exception name } + PUSH EAX { exception object } + PUSH excCatch { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 + + POP EAX +{$ELSE} + PUSH ESP + PUSH 1 + PUSH cContinuable + PUSH cDelphiExcept { our magic exception code } + CALL RaiseExceptionProc + ADD ESP,4 + POP EAX +{$ENDIF} +end; + +procedure NotifyOnExcept; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX handler addr } + PUSH EDX { handler addr } + PUSH 0 { location of exception } + MOV ECX, [EAX] + PUSH [ECX].vmtClassName { exception name } + PUSH EAX { exception object } + PUSH excCatch { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 +{$ELSE} + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH EAX + PUSH [EBX].TExcDescEntry.handler + JMP NotifyExcept +@@1: +{$ENDIF} +end; + +{$IFNDEF LINUX} +procedure NotifyAnyExcept; +asm + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH EAX + PUSH EBX + JMP NotifyExcept +@@1: +end; + +procedure CheckJmp; +asm + TEST ECX,ECX + JE @@3 + MOV EAX,[ECX + 1] + CMP BYTE PTR [ECX],0E9H { near jmp } + JE @@1 + CMP BYTE PTR [ECX],0EBH { short jmp } + JNE @@3 + MOVSX EAX,AL + INC ECX + INC ECX + JMP @@2 +@@1: + ADD ECX,5 +@@2: + ADD ECX,EAX +@@3: +end; +{$ENDIF} { not LINUX } + +{ Notify debugger of a finally during an exception unwind } +procedure NotifyExceptFinally; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX handler addr } + PUSH EDX { handler addr } + PUSH 0 { location of exception } + PUSH 0 { exception name } + PUSH 0 { exception object } + PUSH excFinally { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 +{$ELSE} + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH EAX + PUSH EDX + PUSH ECX + CALL CheckJmp + PUSH ECX + PUSH ESP { pass pointer to arguments } + PUSH 1 { there is 1 argument } + PUSH cContinuable { continuable execution } + PUSH cDelphiFinally { our magic exception code } + CALL RaiseExceptionProc + POP ECX + POP ECX + POP EDX + POP EAX +@@1: +{$ENDIF} +end; + + +{ Tell the debugger that the current exception is handled and cleaned up. + Also indicate where execution is about to resume. } +{$IFNDEF LINUX} +procedure NotifyTerminate; +asm + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH EDX + PUSH ESP + PUSH 1 + PUSH cContinuable + PUSH cDelphiTerminate { our magic exception code } + CALL RaiseExceptionProc + POP EDX +@@1: +end; +{$ENDIF} + +{ 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; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX location of exception } + PUSH EAX + MOV EAX, [EAX].TRaisedException.ExceptObject + + PUSH 0 { handler addr } + PUSH EDX { location of exception } + MOV ECX, [EAX] + PUSH [ECX].vmtClassName { exception name } + PUSH EAX { exception object } + PUSH excUnhandled { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 + + POP EAX +{$ELSE} + PUSH EAX + PUSH EDX + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH ESP + PUSH 2 + PUSH cContinuable + PUSH cDelphiUnhandled + CALL RaiseExceptionProc +@@1: + POP EDX + POP EAX +{$ENDIF} +end; + +{$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; +asm + // If this exception is from C++, then private_2 will be a + // throw address. If not, then it will be zero. private_1 + // will be either the exception object itself, or a TRaisedException. + OR EDX, EDX // From C++? + JZ @@ExcAllocated + + // We've decided that the exception is from C++, but it is a + // Delphi exception object. We will coopt the exception now + // by installing a TRaisedException into the unwinder exception, + // and setting private_2 to 0. Then the exception will look + // like it was truly thrown from this RTL. + CALL AllocateException + +@@ExcAllocated: +end; + +function LinkException(Exc: PRaisedException): PRaisedException; +asm + PUSH EDX // preserve EDX because of HandleOnException + PUSH EAX + CALL SysInit.@GetTLS + POP EDX + MOV ECX, [EAX].ExceptionList + MOV [EDX].TRaisedException.Prev, ECX + MOV [EAX].ExceptionList, EDX + MOV EAX, EDX + POP EDX +end; + +function UnlinkException: PRaisedException; +asm + CALL SysInit.@GetTLS + MOV EDX, [EAX].ExceptionList + MOV EDX, [EDX].TRaisedException.Prev + MOV [EAX].ExceptionList, EDX +end; +{$ENDIF} + +{$IFDEF MSWINDOWS} +procedure _HandleFinallyInternal; forward; +{$ENDIF} + +procedure _HandleAnyException; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + CMP ECX, UW_EXC_CLASS_BORLANDCPP // C++ exception? + JNE @@handleIt // nope, handle it + // C++ exceptions aren't wanted here. Retoss them as is + CALL SysRaiseCPPException + +@@handleIt: + PUSH EAX + PUSH EDX + CALL UnblockOSExceptions + POP EDX + POP EAX + + // If the exception is a Delphi exception thrown from C++, coopt it. + CALL MaybeCooptException + + OR [EAX].TRaisedException.Flags, excIsBeingHandled + CALL LinkException + MOV ESI, EBX + MOV EDX, [ESP] + CALL NotifyExcept + MOV EBX, ESI +{$ENDIF} +{$IFNDEF PC_MAPPED_EXCEPTIONS} + { -> [ESP+ 4] excPtr: PExceptionRecord } + { [ESP+ 8] errPtr: PExcFrame } + { [ESP+12] ctxPtr: Pointer } + { [ESP+16] dspPtr: Pointer } + { <- EAX return value - always one } + + MOV EAX,[ESP+4] + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JNE @@exit + + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + MOV EDX,[EAX].TExceptionRecord.ExceptObject + MOV ECX,[EAX].TExceptionRecord.ExceptAddr + JE @@DelphiException + CLD + CALL _FpuInit + MOV EDX,ExceptObjProc + TEST EDX,EDX + JE @@exit + CALL EDX + TEST EAX,EAX + JE @@exit + MOV EDX,[ESP+12] + MOV ECX,[ESP+4] + CMP [ECX].TExceptionRecord.ExceptionCode,cCppException + JE @@CppException + CALL NotifyNonDelphiException +{$IFDEF MSWINDOWS} + CMP BYTE PTR JITEnable,0 + JBE @@CppException + CMP BYTE PTR DebugHook,0 + JA @@CppException // Do not JIT if debugging + LEA ECX,[ESP+4] + PUSH EAX + PUSH ECX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + POP EAX + JE @@exit + MOV EDX,EAX + MOV EAX,[ESP+4] + MOV ECX,[EAX].TExceptionRecord.ExceptionAddress + JMP @@GoUnwind +{$ENDIF} +@@CppException: + MOV EDX,EAX + MOV EAX,[ESP+4] + MOV ECX,[EAX].TExceptionRecord.ExceptionAddress + +@@DelphiException: +{$IFDEF MSWINDOWS} + CMP BYTE PTR JITEnable,1 + JBE @@GoUnwind + CMP BYTE PTR DebugHook,0 { Do not JIT if debugging } + JA @@GoUnwind + PUSH EAX + LEA EAX,[ESP+8] + PUSH EDX + PUSH ECX + PUSH EAX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + POP ECX + POP EDX + POP EAX + JE @@exit +{$ENDIF} + +@@GoUnwind: + OR [EAX].TExceptionRecord.ExceptionFlags,cUnwinding + + PUSH EBX + XOR EBX,EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBX,FS:[EBX] + PUSH EBX { Save pointer to topmost frame } + PUSH EAX { Save OS exception pointer } + PUSH EDX { Save exception object } + PUSH ECX { Save exception address } + + MOV EDX,[ESP+8+8*4] + + PUSH 0 + PUSH EAX + PUSH offset @@returnAddress + PUSH EDX + CALL RtlUnwindProc +@@returnAddress: + + MOV EDI,[ESP+8+8*4] + + { Make the RaiseList entry on the stack } + + CALL SysInit.@GetTLS + PUSH [EAX].RaiseListPtr + MOV [EAX].RaiseListPtr,ESP + + MOV EBP,[EDI].TExcFrame.hEBP + MOV EBX,[EDI].TExcFrame.desc + MOV [EDI].TExcFrame.desc,offset @@exceptFinally + + ADD EBX,TExcDesc.instructions + CALL NotifyAnyExcept + JMP EBX + +@@exceptFinally: + JMP _HandleFinallyInternal + +@@destroyExcept: + { we come here if an exception handler has thrown yet another exception } + { we need to destroy the exception object and pop the raise list. } + + CALL SysInit.@GetTLS + MOV ECX,[EAX].RaiseListPtr + MOV EDX,[ECX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,EDX + + MOV EAX,[ECX].TRaiseFrame.ExceptObject + JMP TObject.Free + +@@exit: + MOV EAX,1 +{$ENDIF} { not PC_MAPPED_EXCEPTIONS } +end; + +{$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; +asm + { -> EAX raised object: Pointer } + { EDX descriptor table: ^TExcDesc } + { EBX GOT of user code, or 0 if not an SO } + { <- EAX matching descriptor: ^TExcDescEntry } + PUSH EBP + MOV EBP, ESP + SUB ESP, 8 { Room for vtable temp, and adjustor } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV [EBP - 8], EBX { Store the potential GOT } + MOV EAX, [EAX] { load vtable of exception object } + MOV EBX,[EDX].TExcDesc.cnt + LEA ESI,[EDX].TExcDesc.excTab { point ECX to exc descriptor table } + MOV [EBP - 4], EAX { temp for vtable of exception object } + +@@innerLoop: + MOV EAX,[ESI].TExcDescEntry.vTable + TEST EAX,EAX { catch all clause? } + JE @@found { yes: This is the handler } + ADD EAX, [EBP - 8] { add in the adjustor (could be 0) } + MOV EDI,[EBP - 4] { load vtable of exception object } + JMP @@haveVMT + +@@vtLoop: + MOV EDI,[EDI] +@@haveVMT: + MOV EAX,[EAX] + CMP EAX,EDI + JE @@found + + MOV ECX,[EAX].vmtInstanceSize + CMP ECX,[EDI].vmtInstanceSize + JNE @@parent + + MOV EAX,[EAX].vmtClassName + MOV EDX,[EDI].vmtClassName + + XOR ECX,ECX + MOV CL,[EAX] + CMP CL,[EDX] + JNE @@parent + + INC EAX + INC EDX + CALL _AStrCmp + JE @@found + +@@parent: + MOV EDI,[EDI].vmtParent { load vtable of parent } + MOV EAX,[ESI].TExcDescEntry.vTable + ADD EAX, [EBP - 8] { add in the adjustor (could be 0) } + TEST EDI,EDI + JNE @@vtLoop + + ADD ESI,8 + DEC EBX + JNZ @@innerLoop + + { Didn't find a handler. } + XOR ESI, ESI + +@@found: + MOV EAX, ESI +@@done: + POP EDI + POP ESI + POP EBX + MOV ESP, EBP + POP EBP +end; +{$ENDIF} + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _HandleOnExceptionPIC; +asm + { -> EAX obj : Exception object } + { [RA] desc: ^TExcDesc } + { <- Doesn't return } + + // Mark the exception as being handled + OR [EAX].TRaisedException.Flags, excIsBeingHandled + + MOV ESI, EBX // Save the GOT + MOV EDX, [ESP] // Get the addr of the TExcDesc + PUSH EAX // Save the object + MOV EAX, [EAX].TRaisedException.ExceptObject + CALL FindOnExceptionDescEntry + OR EAX, EAX + JE @@NotForMe + + MOV EBX, ESI // Set back to user's GOT + MOV EDX, EAX + POP EAX // Get the object back + POP ECX // Ditch the return addr + + CALL LinkException + + // Get the Pascal object itself. + MOV EAX, [EAX].TRaisedException.ExceptObject + + MOV EDX, [EDX].TExcDescEntry.handler + ADD EDX, EBX // adjust for GOT + CALL NotifyOnExcept + + MOV EBX, ESI // Make sure of user's GOT + JMP EDX // Back to the user code + // never returns +@@NotForMe: + POP EAX // Get the exception object + + // Mark that we're reraising this exception, so that the + // compiler generated exception handler for the 'except on' clause + // will not get confused + OR [EAX].TRaisedException.Flags, excIsBeingReRaised + + JMP SysRaiseException // Should be using resume here +end; +{$ENDIF} + +procedure _HandleOnException; +{$IFDEF PC_MAPPED_EXCEPTIONS} +asm + { -> EAX obj : Exception object } + { [RA] desc: ^TExcDesc } + { <- Doesn't return } + + CMP ECX, UW_EXC_CLASS_BORLANDCPP // C++ exception? + JNE @@handleIt // nope, handle it + // C++ exceptions aren't wanted here. Retoss them as is + CALL SysRaiseCPPException + +@@handleIt: + // If the exception is a Delphi exception thrown from C++, coopt it. + CALL MaybeCooptException + + // Mark the exception as being handled + OR [EAX].TRaisedException.Flags, excIsBeingHandled + + MOV EDX, [ESP] // Get the addr of the TExcDesc + PUSH EAX // Save the object + PUSH EBX // Save EBX + XOR EBX, EBX // No GOT + MOV EAX, [EAX].TRaisedException.ExceptObject + CALL FindOnExceptionDescEntry + POP EBX // Restore EBX + OR EAX, EAX // Is the exception for me? + JE @@NotForMe + + MOV EDX, EAX + POP EAX // Get the object back + POP ECX // Ditch the return addr + + CALL LinkException + + // Get the Pascal object itself. + MOV EAX, [EAX].TRaisedException.ExceptObject + + MOV EDX, [EDX].TExcDescEntry.handler + CALL NotifyOnExcept // Tell the debugger about it + + JMP EDX // Back to the user code + // never returns +@@NotForMe: + POP EAX // Get the exception object + + // Mark that we're reraising this exception, so that the + // compiler generated exception handler for the 'except on' clause + // will not get confused + OR [EAX].TRaisedException.Flags, excIsBeingReRaised + JMP SysRaiseException // Should be using resume here +end; +{$ENDIF} +{$IFNDEF PC_MAPPED_EXCEPTIONS} +asm + { -> [ESP+ 4] excPtr: PExceptionRecord } + { [ESP+ 8] errPtr: PExcFrame } + { [ESP+12] ctxPtr: Pointer } + { [ESP+16] dspPtr: Pointer } + { <- EAX return value - always one } + + MOV EAX,[ESP+4] + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JNE @@exit + + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + JE @@DelphiException + CLD + CALL _FpuInit + MOV EDX,ExceptClsProc + TEST EDX,EDX + JE @@exit + CALL EDX + TEST EAX,EAX + JNE @@common + JMP @@exit + +@@DelphiException: + MOV EAX,[EAX].TExceptionRecord.ExceptObject + MOV EAX,[EAX] { load vtable of exception object } + +@@common: + + MOV EDX,[ESP+8] + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV ECX,[EDX].TExcFrame.desc + MOV EBX,[ECX].TExcDesc.cnt + LEA ESI,[ECX].TExcDesc.excTab { point ECX to exc descriptor table } + MOV EBP,EAX { load vtable of exception object } + +@@innerLoop: + MOV EAX,[ESI].TExcDescEntry.vTable + TEST EAX,EAX { catch all clause? } + JE @@doHandler { yes: go execute handler } + MOV EDI,EBP { load vtable of exception object } + JMP @@haveVMT + +@@vtLoop: + MOV EDI,[EDI] +@@haveVMT: + MOV EAX,[EAX] + CMP EAX,EDI + JE @@doHandler + + MOV ECX,[EAX].vmtInstanceSize + CMP ECX,[EDI].vmtInstanceSize + JNE @@parent + + MOV EAX,[EAX].vmtClassName + MOV EDX,[EDI].vmtClassName + + XOR ECX,ECX + MOV CL,[EAX] + CMP CL,[EDX] + JNE @@parent + + INC EAX + INC EDX + CALL _AStrCmp + JE @@doHandler + +@@parent: + MOV EDI,[EDI].vmtParent { load vtable of parent } + MOV EAX,[ESI].TExcDescEntry.vTable + TEST EDI,EDI + JNE @@vtLoop + + ADD ESI,8 + DEC EBX + JNZ @@innerLoop + + POP EBP + POP EDI + POP ESI + POP EBX + JMP @@exit + +@@doHandler: + MOV EAX,[ESP+4+4*4] + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + MOV EDX,[EAX].TExceptionRecord.ExceptObject + MOV ECX,[EAX].TExceptionRecord.ExceptAddr + JE @@haveObject + CALL ExceptObjProc + MOV EDX,[ESP+12+4*4] + CALL NotifyNonDelphiException +{$IFDEF MSWINDOWS} + CMP BYTE PTR JITEnable,0 + JBE @@NoJIT + CMP BYTE PTR DebugHook,0 + JA @@noJIT { Do not JIT if debugging } + LEA ECX,[ESP+4] + PUSH EAX + PUSH ECX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + POP EAX + JE @@exit +{$ENDIF} +@@noJIT: + MOV EDX,EAX + MOV EAX,[ESP+4+4*4] + MOV ECX,[EAX].TExceptionRecord.ExceptionAddress + JMP @@GoUnwind + +@@haveObject: +{$IFDEF MSWINDOWS} + CMP BYTE PTR JITEnable,1 + JBE @@GoUnwind + CMP BYTE PTR DebugHook,0 + JA @@GoUnwind + PUSH EAX + LEA EAX,[ESP+8] + PUSH EDX + PUSH ECX + PUSH EAX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + POP ECX + POP EDX + POP EAX + JE @@exit +{$ENDIF} + +@@GoUnwind: + XOR EBX,EBX + MOV EBX,FS:[EBX] + PUSH EBX { Save topmost frame } + PUSH EAX { Save exception record } + PUSH EDX { Save exception object } + PUSH ECX { Save exception address } + + MOV EDX,[ESP+8+8*4] + OR [EAX].TExceptionRecord.ExceptionFlags,cUnwinding + + PUSH ESI { Save handler entry } + + PUSH 0 + PUSH EAX + PUSH offset @@returnAddress + PUSH EDX + CALL RtlUnwindProc +@@returnAddress: + + POP EBX { Restore handler entry } + + MOV EDI,[ESP+8+8*4] + + { Make the RaiseList entry on the stack } + + CALL SysInit.@GetTLS + PUSH [EAX].RaiseListPtr + MOV [EAX].RaiseListPtr,ESP + + MOV EBP,[EDI].TExcFrame.hEBP + MOV [EDI].TExcFrame.desc,offset @@exceptFinally + MOV EAX,[ESP].TRaiseFrame.ExceptObject + CALL NotifyOnExcept + JMP [EBX].TExcDescEntry.handler + +@@exceptFinally: + JMP _HandleFinallyInternal + +@@destroyExcept: + { we come here if an exception handler has thrown yet another exception } + { we need to destroy the exception object and pop the raise list. } + + CALL SysInit.@GetTLS + MOV ECX,[EAX].RaiseListPtr + MOV EDX,[ECX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,EDX + + MOV EAX,[ECX].TRaiseFrame.ExceptObject + JMP TObject.Free +@@exit: + MOV EAX,1 +end; +{$ENDIF} + +procedure _HandleFinally; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} +{$IFDEF PIC} + MOV ESI, EBX +{$ENDIF} + CMP ECX, UW_EXC_CLASS_BORLANDCPP // C++ exception? + JNE @@handleIt // nope, handle it + // unwinding a C++ exception. We handle that specially. + PUSH EAX + PUSH EDX + PUSH ECX + MOV EDX, [ESP+12] + CALL EDX + POP ECX + POP EDX + POP EAX + CALL SysRaiseCPPException + +@@handleIt: + PUSH EAX + PUSH EDX + CALL UnblockOSExceptions + POP EDX + POP EAX + + // If the exception is a Delphi exception thrown from C++, coopt it. + CALL MaybeCooptException + + MOV EDX, [ESP] + CALL NotifyExceptFinally + PUSH EAX +{$IFDEF PIC} + MOV EBX, ESI +{$ENDIF} + { + Mark the current exception with the EBP of the handler. If + an exception is raised from the finally block, then this + exception will be orphaned. We will catch this later, when + we clean up the next except block to complete execution. + See DoneExcept. + } + MOV [EAX].TRaisedException.HandlerEBP, EBP + CALL EDX + POP EAX + { + We executed the finally handler without adverse reactions. + It's safe to clear the marker now. + } + MOV [EAX].TRaisedException.HandlerEBP, $FFFFFFFF + PUSH EBP + MOV EBP, ESP + CALL SysRaiseException // Should be using resume here +{$ENDIF} +{$IFDEF MSWINDOWS} + { -> [ESP+ 4] excPtr: PExceptionRecord } + { [ESP+ 8] errPtr: PExcFrame } + { [ESP+12] ctxPtr: Pointer } + { [ESP+16] dspPtr: Pointer } + { <- EAX return value - always one } + + MOV EAX,[ESP+4] + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JE @@exit + + PUSH EBX + XOR EBX,EBX + PUSH ESI + PUSH EDI + PUSH EBP + + { Make exception frame } + + PUSH EBP + PUSH offset @@exceptFinally + PUSH dword ptr FS:[EBX] + MOV FS:[EBX],ESP + + MOV EBX,FS:[EBX] + MOV EDX,[EAX].TExceptionRecord.ExceptObject + MOV ECX,[EAX].TExceptionRecord.ExceptAddr + PUSH EBX { Save pointer to topmost frame } + PUSH EAX { Save OS exception pointer } + PUSH EDX { Save exception object } + PUSH ECX { Save exception address } + + MOV EDI,[ESP+8+11*4] { Load errPtr:PExcFrame } + + { Make the RaiseList entry on the stack } + + CALL SysInit.@GetTLS + PUSH [EAX].RaiseListPtr + MOV [EAX].RaiseListPtr,ESP + + MOV ECX,[EDI].TExcFrame.desc + MOV EBP,[EDI].TExcFrame.hEBP + MOV [EDI].TExcFrame.desc,offset @@exceptFinally + ADD ECX,TExcDesc.instructions + CALL NotifyExceptFinally + CALL ECX + + CALL SysInit.@GetTLS + MOV ECX,[EAX].RaiseListPtr + MOV EDX,[ECX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,EDX + ADD ESP,5*4 { Remove local RaiseList } + + { Remove exception frame } + + XOR EAX,EAX + POP EDX + POP ECX + POP ECX + MOV FS:[EAX],EDX + + POP EBP + POP EDI + POP ESI + POP EBX + JMP @@exit + +@@exceptFinally: + JMP _HandleFinallyInternal + +@@destroyExcept: + { we come here if an finalization handler has thrown yet } + { another exception we need to destroy the exception } + { object and pop the raise list. } + + CALL SysInit.@GetTLS + MOV ECX,[EAX].RaiseListPtr + MOV EDX,[ECX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,EDX + + MOV EAX,[ECX].TRaiseFrame.ExceptObject + JMP TObject.Free + +@@exit: + MOV EAX,1 +{$ENDIF} +end; + +{$IFDEF MSWINDOWS} +procedure _HandleFinallyInternal; +asm + { -> [ESP+ 4] excPtr: PExceptionRecord } + { [ESP+ 8] errPtr: PExcFrame } + { [ESP+12] ctxPtr: Pointer } + { [ESP+16] dspPtr: Pointer } + { <- EAX return value - always one } + + MOV EAX,[ESP+4] + MOV EDX,[ESP+8] + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JE @@exit + MOV ECX,[EDX].TExcFrame.desc + MOV [EDX].TExcFrame.desc,offset @@exit + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBP,[EDX].TExcFrame.hEBP + ADD ECX,TExcDesc.instructions + CALL NotifyExceptFinally + CALL ECX + + POP EBP + POP EDI + POP ESI + POP EBX + +@@exit: + MOV EAX,1 +end; +{$ENDIF} + + +procedure _HandleAutoException; +{$IFDEF LINUX} +{$IFDEF PC_MAPPED_EXCEPTIONS} +asm + // EAX = TObject reference, or nil + // [ESP] = ret addr + + PUSH EAX + PUSH EDX + CALL UnblockOSExceptions + POP EDX + POP EAX + + // If the exception is a Delphi exception thrown from C++, coopt it. + CALL MaybeCooptException + + CALL LinkException +// +// The compiler wants the stack to look like this: +// ESP+4-> HRESULT +// ESP+0-> ret addr +// +// Make it so. +// + POP EDX + PUSH 8000FFFFH + PUSH EDX + + OR EAX, EAX // Was this a method call? + JE @@Done + + PUSH EAX + CALL CurrentException + MOV EDX, [EAX].TRaisedException.ExceptObject + MOV ECX, [EAX].TRaisedException.ExceptionAddr; + POP EAX + MOV EAX, [EAX] + CALL DWORD PTR [EAX] + VMTOFFSET TObject.SafeCallException; + MOV [ESP+4], EAX +@@Done: + CALL _DoneExcept +end; +{$ELSE} +begin + Error(reSafeCallError); //!! +end; +{$ENDIF} +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + { -> [ESP+ 4] excPtr: PExceptionRecord } + { [ESP+ 8] errPtr: PExcFrame } + { [ESP+12] ctxPtr: Pointer } + { [ESP+16] dspPtr: Pointer } + { <- EAX return value - always one } + + MOV EAX,[ESP+4] + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JNE @@exit + + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + CLD + CALL _FpuInit + JE @@DelphiException + CMP BYTE PTR JITEnable,0 + JBE @@DelphiException + CMP BYTE PTR DebugHook,0 + JA @@DelphiException + +@@DoUnhandled: + LEA EAX,[ESP+4] + PUSH EAX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + JE @@exit + MOV EAX,[ESP+4] + JMP @@GoUnwind + +@@DelphiException: + CMP BYTE PTR JITEnable,1 + JBE @@GoUnwind + CMP BYTE PTR DebugHook,0 + JA @@GoUnwind + JMP @@DoUnhandled + +@@GoUnwind: + OR [EAX].TExceptionRecord.ExceptionFlags,cUnwinding + + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EDX,[ESP+8+3*4] + + PUSH 0 + PUSH EAX + PUSH offset @@returnAddress + PUSH EDX + CALL RtlUnwindProc + +@@returnAddress: + POP EBP + POP EDI + POP ESI + MOV EAX,[ESP+4] + MOV EBX,8000FFFFH + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + JNE @@done + + MOV EDX,[EAX].TExceptionRecord.ExceptObject + MOV ECX,[EAX].TExceptionRecord.ExceptAddr + MOV EAX,[ESP+8] + MOV EAX,[EAX].TExcFrame.SelfOfMethod + TEST EAX,EAX + JZ @@freeException + MOV EBX,[EAX] + CALL DWORD PTR [EBX] + VMTOFFSET TObject.SafeCallException + MOV EBX,EAX +@@freeException: + MOV EAX,[ESP+4] + MOV EAX,[EAX].TExceptionRecord.ExceptObject + CALL TObject.Free +@@done: + XOR EAX,EAX + MOV ESP,[ESP+8] + POP ECX + MOV FS:[EAX],ECX + POP EDX + POP EBP + LEA EDX,[EDX].TExcDesc.instructions + POP ECX + JMP EDX +@@exit: + MOV EAX,1 +end; +{$ENDIF} + + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _RaiseAtExcept; +asm + { -> EAX Pointer to exception object } + { -> EDX Purported addr of exception } + { Be careful: EBX is not set up in PIC mode. } + { Outward bound calls must go through an exported fn, like SysRaiseException } + OR EAX, EAX + JNE @@GoAhead + MOV EAX, 216 + CALL _RunError + +@@GoAhead: + CALL BlockOSExceptions + PUSH EBP + MOV EBP, ESP + CALL NotifyReRaise + CALL AllocateException + CALL SysRaiseException + { + This can only return if there was a terrible error. In this event, + we have to bail out. + } + JMP _Run0Error +end; +{$ENDIF} + +procedure _RaiseExcept; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + { -> EAX Pointer to exception object } + MOV EDX, [ESP] + JMP _RaiseAtExcept +{$ENDIF} +{$IFDEF MSWINDOWS} + { When making changes to the way Delphi Exceptions are raised, } + { please realize that the C++ Exception handling code reraises } + { some exceptions as Delphi Exceptions. Of course we want to } + { keep exception raising compatible between Delphi and C++, so } + { when you make changes here, consult with the relevant C++ } + { exception handling engineer. The C++ code is in xx.cpp, in } + { the RTL sources, in function tossAnException. } + + { -> EAX Pointer to exception object } + { [ESP] Error address } + + OR EAX, EAX + JNE @@GoAhead + MOV EAX, 216 + CALL _RunError +@@GoAhead: + POP EDX + + PUSH ESP + PUSH EBP + PUSH EDI + PUSH ESI + PUSH EBX + PUSH EAX { pass class argument } + PUSH EDX { pass address argument } + + PUSH ESP { pass pointer to arguments } + PUSH 7 { there are seven arguments } + PUSH cNonContinuable { we can't continue execution } + PUSH cDelphiException { our magic exception code } + PUSH EDX { pass the user's return address } + JMP RaiseExceptionProc +{$ENDIF} +end; + + +{$IFDEF PC_MAPPED_EXCEPTIONS} +{ + Used in the PC mapping exception implementation to handle exceptions in constructors. +} +procedure _ClassHandleException; +asm + { + EAX = Ptr to TRaisedException + EDX = self + ECX = top flag + } + PUSH ECX + CALL LinkException + MOV EAX,EDX + POP EDX + TEST DL, DL + JE _RaiseAgain + MOV ECX,[EAX] + MOV DL,$81 + PUSH EAX + CALL DWORD PTR [ECX] + VMTOFFSET TObject.Destroy + POP EAX + CALL _ClassDestroy + JMP _RaiseAgain +end; +{$ENDIF} + +procedure _RaiseAgain; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + CALL CurrentException +// The following notifies the debugger of a reraise of exceptions. This will +// be supported in a later release, but is disabled for now. +// PUSH EAX +// MOV EDX, [EAX].TRaisedException.ExceptionAddr +// MOV EAX, [EAX].TRaisedException.ExceptObject +// CALL NotifyReRaise { Tell the debugger } +// POP EAX + TEST [EAX].TRaisedException.Flags, excIsBeingHandled + JZ @@DoIt + OR [EAX].TRaisedException.Flags, excIsBeingReRaised +@@DoIt: + PUSH EAX + CALL UnlinkException + POP EAX + MOV EDX, [ESP] { Get the user's addr } + JMP SysRaiseException +{$ENDIF} +{$IFDEF MSWINDOWS} + { -> [ESP ] return address to user program } + { [ESP+ 4 ] raise list entry (4 dwords) } + { [ESP+ 4+ 4*4] saved topmost frame } + { [ESP+ 4+ 5*4] saved registers (4 dwords) } + { [ESP+ 4+ 9*4] return address to OS } + { -> [ESP+ 4+10*4] excPtr: PExceptionRecord } + { [ESP+ 8+10*4] errPtr: PExcFrame } + + { Point the error handler of the exception frame to something harmless } + + MOV EAX,[ESP+8+10*4] + MOV [EAX].TExcFrame.desc,offset @@exit + + { Pop the RaiseList } + + CALL SysInit.@GetTLS + MOV EDX,[EAX].RaiseListPtr + MOV ECX,[EDX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,ECX + + { Destroy any objects created for non-delphi exceptions } + + MOV EAX,[EDX].TRaiseFrame.ExceptionRecord + AND [EAX].TExceptionRecord.ExceptionFlags,NOT cUnwinding + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + JE @@delphiException + MOV EAX,[EDX].TRaiseFrame.ExceptObject + CALL TObject.Free + CALL NotifyReRaise + +@@delphiException: + + XOR EAX,EAX + ADD ESP,5*4 + MOV EDX,FS:[EAX] + POP ECX + MOV EDX,[EDX].TExcFrame.next + MOV [ECX].TExcFrame.next,EDX + + POP EBP + POP EDI + POP ESI + POP EBX +@@exit: + MOV EAX,1 +{$ENDIF} +end; + +{$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; +var + Exc: PRaisedException; + RefCount: Integer; + ExcObj: Pointer; + ExcAddr: Pointer; +begin + asm + CMP ECX, UW_EXC_CLASS_BORLANDCPP + JNE @@notCPP + CALL SysRaiseCPPException +@@notCPP: + MOV Exc, EAX + end; + + if (Exc^.Flags and excIsBeingReRaised) = 0 then + begin + RefCount := Exc^.RefCount; + ExcObj := Exc^.ExceptObject; + ExcAddr := Exc^.ExceptionAddr; + Exc^.RefCount := 1; + FreeException; + _DoneExcept; + Exc := AllocateException(ExcObj, ExcAddr); + Exc^.RefCount := RefCount; + end; + + Exc^.Flags := Exc^.Flags and not (excIsBeingReRaised or excIsBeingHandled); + + SysRaiseException(Exc); +end; + +procedure CleanupException; +asm + CALL FreeException + OR EAX, EAX + JE @@Done + CALL TObject.Free +@@Done: +end; +{$ENDIF} + +procedure _DoneExcept; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + CALL FreeException + OR EAX, EAX + JE @@Done + CALL TObject.Free +@@Done: + CALL UnlinkException + { + Take a peek at the next exception object on the stack. + If its EBP marker is at an address lower than our current + EBP, then we know that it was orphaned when an exception was + thrown from within the execution of a finally block. We clean + it up now, so that we won't leak exception records/objects. + } + CALL CurrentException + OR EAX, EAX + JE @@Done2 + CMP [EAX].TRaisedException.HandlerEBP, EBP + JA @@Done2 + CALL FreeException + OR EAX, EAX + JE @@Done2 + CALL TObject.Free +@@Done2: +{$ENDIF} +{$IFDEF MSWINDOWS} + { -> [ESP+ 4+10*4] excPtr: PExceptionRecord } + { [ESP+ 8+10*4] errPtr: PExcFrame } + + { Pop the RaiseList } + + CALL SysInit.@GetTLS + MOV EDX,[EAX].RaiseListPtr + MOV ECX,[EDX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,ECX + + { Destroy exception object } + + MOV EAX,[EDX].TRaiseFrame.ExceptObject + CALL TObject.Free + + POP EDX + MOV ESP,[ESP+8+9*4] + XOR EAX,EAX + POP ECX + MOV FS:[EAX],ECX + POP EAX + POP EBP + CALL NotifyTerminate + JMP EDX +{$ENDIF} +end; + +{$IFNDEF PC_MAPPED_EXCEPTIONS} +procedure _TryFinallyExit; +asm +{$IFDEF MSWINDOWS} + XOR EDX,EDX + MOV ECX,[ESP+4].TExcFrame.desc + MOV EAX,[ESP+4].TExcFrame.next + ADD ECX,TExcDesc.instructions + MOV FS:[EDX],EAX + CALL ECX +@@1: RET 12 +{$ENDIF} +end; +{$ENDIF} + + +var + InitContext: TInitContext; + +{$IFNDEF PC_MAPPED_EXCEPTIONS} +procedure MapToRunError(P: PExceptionRecord); stdcall; +const + STATUS_ACCESS_VIOLATION = $C0000005; + STATUS_ARRAY_BOUNDS_EXCEEDED = $C000008C; + STATUS_FLOAT_DENORMAL_OPERAND = $C000008D; + STATUS_FLOAT_DIVIDE_BY_ZERO = $C000008E; + STATUS_FLOAT_INEXACT_RESULT = $C000008F; + STATUS_FLOAT_INVALID_OPERATION = $C0000090; + STATUS_FLOAT_OVERFLOW = $C0000091; + STATUS_FLOAT_STACK_CHECK = $C0000092; + STATUS_FLOAT_UNDERFLOW = $C0000093; + STATUS_INTEGER_DIVIDE_BY_ZERO = $C0000094; + STATUS_INTEGER_OVERFLOW = $C0000095; + STATUS_PRIVILEGED_INSTRUCTION = $C0000096; + STATUS_STACK_OVERFLOW = $C00000FD; + STATUS_CONTROL_C_EXIT = $C000013A; +var + ErrCode: Byte; +begin + case P.ExceptionCode of + STATUS_INTEGER_DIVIDE_BY_ZERO: ErrCode := 200; { reDivByZero } + STATUS_ARRAY_BOUNDS_EXCEEDED: ErrCode := 201; { reRangeError } + STATUS_FLOAT_OVERFLOW: ErrCode := 205; { reOverflow } + STATUS_FLOAT_INEXACT_RESULT, + STATUS_FLOAT_INVALID_OPERATION, + STATUS_FLOAT_STACK_CHECK: ErrCode := 207; { reInvalidOp } + STATUS_FLOAT_DIVIDE_BY_ZERO: ErrCode := 200; { reZeroDivide } + STATUS_INTEGER_OVERFLOW: ErrCode := 215; { reIntOverflow} + STATUS_FLOAT_UNDERFLOW, + STATUS_FLOAT_DENORMAL_OPERAND: ErrCode := 206; { reUnderflow } + STATUS_ACCESS_VIOLATION: ErrCode := 216; { reAccessViolation } + STATUS_PRIVILEGED_INSTRUCTION: ErrCode := 218; { rePrivInstruction } + STATUS_CONTROL_C_EXIT: ErrCode := 217; { reControlBreak } + STATUS_STACK_OVERFLOW: ErrCode := 202; { reStackOverflow } + else ErrCode := 255; + end; + RunErrorAt(ErrCode, P.ExceptionAddress); +end; + +procedure _ExceptionHandler; +asm + MOV EAX,[ESP+4] + + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JNE @@exit +{$IFDEF MSWINDOWS} + CMP BYTE PTR DebugHook,0 + JA @@ExecuteHandler + LEA EAX,[ESP+4] + PUSH EAX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + JNE @@ExecuteHandler + JMP @@exit +{$ENDIF} + +@@ExecuteHandler: + MOV EAX,[ESP+4] + CLD + CALL _FpuInit + MOV EDX,[ESP+8] + + PUSH 0 + PUSH EAX + PUSH offset @@returnAddress + PUSH EDX + CALL RtlUnwindProc + +@@returnAddress: + MOV EBX,[ESP+4] + CMP [EBX].TExceptionRecord.ExceptionCode,cDelphiException + MOV EDX,[EBX].TExceptionRecord.ExceptAddr + MOV EAX,[EBX].TExceptionRecord.ExceptObject + JE @@DelphiException2 + + MOV EDX,ExceptObjProc + TEST EDX,EDX + JE MapToRunError + MOV EAX,EBX + CALL EDX + TEST EAX,EAX + JE MapToRunError + MOV EDX,[EBX].TExceptionRecord.ExceptionAddress + +@@DelphiException2: + + CALL NotifyUnhandled + MOV ECX,ExceptProc + TEST ECX,ECX + JE @@noExceptProc + CALL ECX { call ExceptProc(ExceptObject, ExceptAddr) } + +@@noExceptProc: + MOV ECX,[ESP+4] + MOV EAX,217 + MOV EDX,[ECX].TExceptionRecord.ExceptAddr + MOV [ESP],EDX + JMP _RunError + +@@exit: + XOR EAX,EAX +end; + +procedure SetExceptionHandler; +asm + XOR EDX,EDX { using [EDX] saves some space over [0] } + LEA EAX,[EBP-12] + MOV ECX,FS:[EDX] { ECX := head of chain } + MOV FS:[EDX],EAX { head of chain := @exRegRec } + + MOV [EAX].TExcFrame.next,ECX +{$IFDEF PIC} + LEA EDX, [EBX]._ExceptionHandler + MOV [EAX].TExcFrame.desc, EDX +{$ELSE} + MOV [EAX].TExcFrame.desc,offset _ExceptionHandler +{$ENDIF} + MOV [EAX].TExcFrame.hEBP,EBP +{$IFDEF PIC} + MOV [EBX].InitContext.ExcFrame,EAX +{$ELSE} + MOV InitContext.ExcFrame,EAX +{$ENDIF} +end; + + +procedure UnsetExceptionHandler; +asm + XOR EDX,EDX +{$IFDEF PIC} + MOV EAX,[EBX].InitContext.ExcFrame +{$ELSE} + MOV EAX,InitContext.ExcFrame +{$ENDIF} + TEST EAX,EAX + JZ @@exit + MOV ECX,FS:[EDX] { ECX := head of chain } + CMP EAX,ECX { simple case: our record is first } + JNE @@search + MOV EAX,[EAX] { head of chain := exRegRec.next } + MOV FS:[EDX],EAX + JMP @@exit + +@@loop: + MOV ECX,[ECX] +@@search: + CMP ECX,-1 { at end of list? } + JE @@exit { yes - didn't find it } + CMP [ECX],EAX { is it the next one on the list? } + JNE @@loop { no - look at next one on list } +@@unlink: { yes - unlink our record } + MOV EAX,[EAX] { get next record on list } + MOV [ECX],EAX { unlink our record } +@@exit: +end; +{$ENDIF} // not PC_MAPPED_EXCEPTIONS + +type + TProc = procedure; + +{$IFDEF LINUX} +procedure CallProc(Proc: Pointer; GOT: Cardinal); +asm + PUSH EBX + MOV EBX,EDX + ADD EAX,EBX + CALL EAX + POP EBX +end; +{$ENDIF} + +procedure FinalizeUnits; +var + Count: Integer; + Table: PUnitEntryTable; + P: Pointer; +begin + if InitContext.InitTable = nil then + exit; + Count := InitContext.InitCount; + Table := InitContext.InitTable^.UnitInfo; +{$IFDEF LINUX} + Inc(Cardinal(Table), InitContext.Module^.GOT); +{$ENDIF} + try + while Count > 0 do + begin + Dec(Count); + InitContext.InitCount := Count; + P := Table^[Count].FInit; + if Assigned(P) then + begin +{$IFDEF LINUX} + CallProc(P, InitContext.Module^.GOT); +{$ENDIF} +{$IFDEF MSWINDOWS} + TProc(P)(); +{$ENDIF} + end; + end; + except + FinalizeUnits; { try to finalize the others } + raise; + end; +end; + +const + errCaption: array[0..5] of Char = 'Error'#0; + +{***********************************************************} +{$IFDEF TRIAL_EDITION} +{ + This code is used as part of the timeout test for + applications built with trial editions of the product. It provides + the current local time in a format native to the platform in question. + + The linker will generate a checksum of _InitUnitPrep that it will + place into linked units. The code generated for _InitUnitPrep must + not contain fixups actually in the image, as this could alter the + code at load time, invalidating the checksum. Take great care to + make sure that this code is entirely position independent on all + platforms and circumstances to avoid a serious problem! +} +{$IFDEF MSWINDOWS} +type + TSystemTime = record + wYear: Word; + wMonth: Word; + wDayOfWeek: Word; + wDay: Word; + wHour: Word; + wMinute: Word; + wSecond: Word; + wMilliseconds: Word; + end; + TFileTime = record + LowTime: Integer; + HighTime: Integer; + end; + + +procedure GetLocalTime(var lpSystemTime: TSystemTime); stdcall; external 'kernel32.dll' name 'GetLocalTime'; +procedure SystemTimeToFileTime(const lpSystemTime: TSystemTime; var Dest: TFileTime); stdcall; external 'kernel32.dll' name 'SystemTimeToFileTime'; + +function _InitUnitPrep: Int64; +var + SystemTime: TSystemTime; + FileTime: TFileTime; + Days: Int64; +begin + GetLocalTime(SystemTime); + SystemTimeToFileTime(SystemTime, FileTime); + + // used to hack the result to force a failure for testing: + Days := 1000000000 div 100; + Days := Days * 3600; + Days := Days * 24; + Days := Days * 31; + Days := 0; + + Result := Int64(FileTime) + Days; +// Dec(InitContext.InitTable^.UnitCount); +end; +{$ENDIF} +{$IFDEF LINUX} + +function _InitUnitPrep: Integer; +var + Days: Integer; +begin + Days := 0; // used to hack the result to force a failure for testing + Result := _time(nil) + Days; +end; +{$ENDIF} + +resourcestring +{$IFDEF LINUX} + SExpiredMsg = + 'This module was compiled with a trial version of Kylix.'+#10+ + 'The trial period has expired.'+#10; +{$ENDIF} +{$IFDEF MSWINDOWS} + SExpiredMsg = + 'This module was compiled with a trial version of Delphi.'+#13+#10+ + 'The trial period has expired.'+#13+#10; +{$ENDIF} +var + ExpiredMsg: String; + +procedure _Expired; +{$IFDEF MSWINDOWS} +var + Dummy: Cardinal; +begin + ExpiredMsg := LoadResString(@SExpiredMsg); + if IsConsole then + WriteFile(GetStdHandle(STD_ERROR_HANDLE), PChar(ExpiredMsg), Length(ExpiredMsg), Dummy, nil) + else + MessageBox(0, PChar(ExpiredMsg), errCaption, 0); +{$ENDIF} +{$IFDEF LINUX} +begin + ExpiredMsg := LoadResString(@SExpiredMsg); + __write(2, PChar(ExpiredMsg), Length(ExpiredMsg)); +{$ENDIF} + Halt(232); +end; + +{$ENDIF} //TRIAL_EDITION + + +procedure InitUnits; +var + Count, I: Integer; + Table: PUnitEntryTable; + P: Pointer; +begin + if InitContext.InitTable = nil then + exit; + Count := InitContext.InitTable^.UnitCount; + I := 0; + Table := InitContext.InitTable^.UnitInfo; +{$IFDEF LINUX} + Inc(Cardinal(Table), InitContext.Module^.GOT); +{$ENDIF} + try + while I < Count do + begin + P := Table^[I].Init; + Inc(I); + InitContext.InitCount := I; + if Assigned(P) then + begin +{$IFDEF LINUX} + CallProc(P, InitContext.Module^.GOT); +{$ENDIF} +{$IFDEF MSWINDOWS} + TProc(P)(); +{$ENDIF} + end; + end; + except + FinalizeUnits; + raise; + end; +end; + +procedure _PackageLoad(const Table : PackageInfo; Module: PLibModule); +var + SavedContext: TInitContext; +begin + SavedContext := InitContext; + InitContext.DLLInitState := 0; + InitContext.InitTable := Table; + InitContext.InitCount := 0; + InitContext.Module := Module; + InitContext.OuterContext := @SavedContext; + try + InitUnits; + finally + InitContext := SavedContext; + end; +end; + + +procedure _PackageUnload(const Table : PackageInfo; Module: PLibModule); +var + SavedContext: TInitContext; +begin + SavedContext := InitContext; + InitContext.DLLInitState := 0; + InitContext.InitTable := Table; + InitContext.InitCount := Table^.UnitCount; + InitContext.Module := Module; + InitContext.OuterContext := @SavedContext; + try + FinalizeUnits; + finally + InitContext := SavedContext; + end; +end; + +{$IFDEF LINUX} +procedure _StartExe(InitTable: PackageInfo; Module: PLibModule; Argc: Integer; Argv: Pointer); +begin + ArgCount := Argc; + ArgValues := Argv; +{$ENDIF} +{$IFDEF MSWINDOWS} +procedure _StartExe(InitTable: PackageInfo; Module: PLibModule); +begin + RaiseExceptionProc := @RaiseException; + RTLUnwindProc := @RTLUnwind; +{$ENDIF} + InitContext.InitTable := InitTable; + InitContext.InitCount := 0; + InitContext.Module := Module; + MainInstance := Module.Instance; +{$IFNDEF PC_MAPPED_EXCEPTIONS} + SetExceptionHandler; +{$ENDIF} + IsLibrary := False; + InitUnits; +end; + +{$IFDEF MSWINDOWS} +procedure _StartLib; +asm + { -> EAX InitTable } + { EDX Module } + { ECX InitTLS } + { [ESP+4] DllProc } + { [EBP+8] HInst } + { [EBP+12] Reason } + + { Push some desperately needed registers } + + PUSH ECX + PUSH ESI + PUSH EDI + + { Save the current init context into the stackframe of our caller } + + MOV ESI,offset InitContext + LEA EDI,[EBP- (type TExcFrame) - (type TInitContext)] + MOV ECX,(type TInitContext)/4 + REP MOVSD + + { Setup the current InitContext } + + POP InitContext.DLLSaveEDI + POP InitContext.DLLSaveESI + MOV InitContext.DLLSaveEBP,EBP + MOV InitContext.DLLSaveEBX,EBX + MOV InitContext.InitTable,EAX + MOV InitContext.Module,EDX + LEA ECX,[EBP- (type TExcFrame) - (type TInitContext)] + MOV InitContext.OuterContext,ECX + XOR ECX,ECX + CMP DWORD PTR [EBP+12],0 + JNE @@notShutDown + MOV ECX,[EAX].PackageInfoTable.UnitCount +@@notShutDown: + MOV InitContext.InitCount,ECX + + MOV EAX, offset RaiseException + MOV RaiseExceptionProc, EAX + MOV EAX, offset RTLUnwind + MOV RTLUnwindProc, EAX + + CALL SetExceptionHandler + + MOV EAX,[EBP+12] + INC EAX + MOV InitContext.DLLInitState,AL + DEC EAX + + { Init any needed TLS } + + POP ECX + MOV EDX,[ECX] + MOV InitContext.ExitProcessTLS,EDX + JE @@skipTLSproc + CMP AL,3 // DLL_THREAD_DETACH + JGE @@skipTLSproc // call ExitThreadTLS proc after DLLProc + CALL dword ptr [ECX+EAX*4] +@@skipTLSproc: + + { Call any DllProc } + + PUSH ECX + MOV ECX,[ESP+8] + TEST ECX,ECX + JE @@noDllProc + MOV EAX,[EBP+12] + MOV EDX,[EBP+16] + CALL ECX +@@noDllProc: + + POP ECX + MOV EAX, [EBP+12] + CMP AL,3 // DLL_THREAD_DETACH + JL @@afterDLLproc // don't free TLS on process shutdown + CALL dword ptr [ECX+EAX*4] + +@@afterDLLProc: + + { Set IsLibrary if there was no exe yet } + + CMP MainInstance,0 + JNE @@haveExe + MOV IsLibrary,1 + FNSTCW Default8087CW // save host exe's FPU preferences + +@@haveExe: + + MOV EAX,[EBP+12] + DEC EAX + JNE _Halt0 + CALL InitUnits + RET 4 +end; +{$ENDIF MSWINDOWS} +{$IFDEF LINUX} +procedure _StartLib(Context: PInitContext; Module: PLibModule; DLLProc: TDLLProcEx); +var + TempSwap: TInitContext; +begin + // Context's register save fields are already initialized. + // Save the current InitContext and activate the new Context by swapping them + TempSwap := InitContext; + InitContext := PInitContext(Context)^; + PInitContext(Context)^ := TempSwap; + + InitContext.Module := Module; + InitContext.OuterContext := Context; + + // DLLInitState is initialized by SysInit to 0 for shutdown, 1 for startup + // Inc DLLInitState to distinguish from package init: + // 0 for package, 1 for DLL shutdown, 2 for DLL startup + + Inc(InitContext.DLLInitState); + + if InitContext.DLLInitState = 1 then + begin + InitContext.InitTable := Module.InitTable; + if Assigned(InitContext.InitTable) then + InitContext.InitCount := InitContext.InitTable.UnitCount // shutdown + end + else + begin + Module.InitTable := InitContext.InitTable; // save for shutdown + InitContext.InitCount := 0; // startup + end; + + if Assigned(DLLProc) then + DLLProc(InitContext.DLLInitState-1,0); + + if MainInstance = 0 then { Set IsLibrary if there was no exe yet } + begin + IsLibrary := True; + Default8087CW := Get8087CW; + end; + + if InitContext.DLLInitState = 1 then + _Halt0 + else + InitUnits; +end; +{$ENDIF} + +procedure _InitResStrings; +asm + { -> EAX Pointer to init table } + { record } + { cnt: Integer; } + { tab: array [1..cnt] record } + { variableAddress: Pointer; } + { resStringAddress: Pointer; } + { end; } + { end; } + { EBX = caller's GOT for PIC callers, 0 for non-PIC } + +{$IFDEF MSWINDOWS} + PUSH EBX + XOR EBX,EBX +{$ENDIF} + PUSH EDI + PUSH ESI + MOV EDI,[EBX+EAX] + LEA ESI,[EBX+EAX+4] +@@loop: + MOV EAX,[ESI+4] { load resStringAddress } + MOV EDX,[ESI] { load variableAddress } + ADD EAX,EBX + ADD EDX,EBX + CALL LoadResString + ADD ESI,8 + DEC EDI + JNZ @@loop + + POP ESI + POP EDI +{$IFDEF MSWINDOWS} + POP EBX +{$ENDIF} +end; + +procedure _InitResStringImports; +asm + { -> EAX Pointer to init table } + { record } + { cnt: Integer; } + { tab: array [1..cnt] record } + { variableAddress: Pointer; } + { resStringAddress: ^Pointer; } + { end; } + { end; } + { EBX = caller's GOT for PIC callers, 0 for non-PIC } + +{$IFDEF MSWINDOWS} + PUSH EBX + XOR EBX,EBX +{$ENDIF} + PUSH EDI + PUSH ESI + MOV EDI,[EBX+EAX] + LEA ESI,[EBX+EAX+4] +@@loop: + MOV EAX,[ESI+4] { load address of import } + MOV EDX,[ESI] { load address of variable } + MOV EAX,[EBX+EAX] { load contents of import } + ADD EDX,EBX + CALL LoadResString + ADD ESI,8 + DEC EDI + JNZ @@loop + + POP ESI + POP EDI +{$IFDEF MSWINDOWS} + POP EBX +{$ENDIF} +end; + +procedure _InitImports; +asm + { -> EAX Pointer to init table } + { record } + { cnt: Integer; } + { tab: array [1..cnt] record } + { variableAddress: Pointer; } + { sourceAddress: ^Pointer; } + { sourceOffset: Longint; } + { end; } + { end; } + { -> EDX Linux only, this points to } + { SysInit.ModuleIsCpp } + { EBX = caller's GOT for PIC callers, 0 for non-PIC } + +{$IFDEF MSWINDOWS} + PUSH EBX + XOR EBX,EBX +{$ENDIF} + PUSH EDI + PUSH ESI + MOV EDI,[EBX+EAX] + LEA ESI,[EBX+EAX+4] +{$IFDEF LINUX} + { + The C++ linker may have already fixed these things up to valid + addresses. In this case, we don't want to do this pass. If this + module's init tab was linked with ilink, then SysInit.ModuleIsCpp + will be set, and we'll bail out. + } + CMP BYTE PTR[EDX+EBX], 0 { SysInit.ModuleIsCpp } + JNE @@exit +{$ENDIF} +@@loop: + MOV EAX,[ESI+4] { load address of import } + MOV EDX,[ESI] { load address of variable } + MOV EAX,[EBX+EAX] { load contents of import } + ADD EAX,[ESI+8] { calc address of variable } + MOV [EBX+EDX],EAX { store result } + ADD ESI,12 + DEC EDI + JNZ @@loop + +@@exit: + + POP ESI + POP EDI +{$IFDEF MSWINDOWS} + POP EBX +{$ENDIF} +end; + +{$IFDEF MSWINDOWS} +procedure _InitWideStrings; +asm + { -> EAX Pointer to init table } + { record } + { cnt: Integer; } + { tab: array [1..cnt] record } + { variableAddress: Pointer; } + { stringAddress: ^Pointer; } + { end; } + { end; } + + PUSH EBX + PUSH ESI + MOV EBX,[EAX] + LEA ESI,[EAX+4] +@@loop: + MOV EDX,[ESI+4] { load address of string } + MOV EAX,[ESI] { load address of variable } + CALL _WStrAsg + ADD ESI,8 + DEC EBX + JNZ @@loop + + POP ESI + POP EBX +end; +{$ENDIF} + +var + runErrMsg: array[0..29] of Char = 'Runtime error at 00000000'#0; + // columns: 0123456789012345678901234567890 + + +procedure MakeErrorMessage; +const + dig : array [0..15] of Char = '0123456789ABCDEF'; +var + digit: Byte; + Temp: Integer; + Addr: Cardinal; +begin + digit := 16; + Temp := ExitCode; + repeat + runErrMsg[digit] := Char(Ord('0') + (Temp mod 10)); + Temp := Temp div 10; + Dec(digit); + until Temp = 0; + digit := 28; + Addr := Cardinal(ErrorAddr); + repeat + runErrMsg[digit] := dig[Addr and $F]; + Addr := Addr div 16; + Dec(digit); + until Addr = 0; +end; + + +procedure ExitDll; +asm + // Linux: + // Setting ExitCode to non-zero in library initialization to force + // module load failure is not supported in Linux. There is no way to + // communicate failure back to the Linux loader. + // Upon error in library initialization, all initialized units will be + // finalized. Subsequent calls into exported library functions that + // make use of initialized data or RTL routines will fail. + // ExitCode <> zero indicates that the library failed its initialization. + +{$IFDEF MSWINDOWS} + { Return False if ExitCode <> 0, and set ExitCode to 0 } + XOR EAX,EAX + XCHG EAX, ExitCode + NEG EAX + SBB EAX,EAX + INC EAX +{$ENDIF} + + { Restore the InitContext } +{$IFDEF PIC} + LEA EDI, [EBX].InitContext +{$ELSE} + MOV EDI, offset InitContext +{$ENDIF} + + MOV EBX,[EDI].TInitContext.DLLSaveEBX + MOV EBP,[EDI].TInitContext.DLLSaveEBP + PUSH [EDI].TInitContext.DLLSaveESI + PUSH [EDI].TInitContext.DLLSaveEDI + + MOV ESI,[EDI].TInitContext.OuterContext + MOV ECX,(type TInitContext)/4 + REP MOVSD + POP EDI + POP ESI + + LEAVE +{$IFDEF MSWINDOWS} + RET 12 +{$ENDIF} +{$IFDEF LINUX} + RET +{$ENDIF} +end; + +procedure WriteErrorMessage; +{$IFDEF MSWINDOWS} +var + Dummy: Cardinal; +begin + if IsConsole then + begin + with TTextRec(Output) do + begin + if (Mode = fmOutput) and (BufPos > 0) then + TTextIOFunc(InOutFunc)(TTextRec(Output)); // flush out text buffer + end; + WriteFile(GetStdHandle(STD_OUTPUT_HANDLE), runErrMsg, Sizeof(runErrMsg), Dummy, nil); + WriteFile(GetStdHandle(STD_OUTPUT_HANDLE), sLineBreak, 2, Dummy, nil); + end + else if not NoErrMsg then + MessageBox(0, runErrMsg, errCaption, 0); +{$ENDIF} +{$IFDEF LINUX} +var + c: Char; +begin + with TTextRec(Output) do + begin + if (Mode = fmOutput) and (BufPos > 0) then + TTextIOFunc(InOutFunc)(TTextRec(Output)); // flush out text buffer + end; + __write(STDERR_FILENO, @runErrMsg, Sizeof(runErrMsg)-1); + c := sLineBreak; + __write(STDERR_FILENO, @c, 1); +{$ENDIF} +end; + +var + RTLInitFailed: Boolean = False; + +procedure _Halt0; +var + P: procedure; +begin +{$IFDEF LINUX} + if (ExitCode <> 0) and CoreDumpEnabled then + __raise(SIGABRT); + + if (InitContext.DLLInitState = 2) and (ExitCode <> 0) then + RTLInitFailed := True; + + if (InitContext.DLLInitState = 1) and RTLInitFailed then + // RTL failed to initialized in library startup. Units have already been + // finalized, don't finalize them again. + ExitDll; +{$ENDIF} + + if InitContext.DLLInitState = 0 then + while ExitProc <> nil do + begin + @P := ExitProc; + ExitProc := nil; + P; + end; + + { If there was some kind of runtime error, alert the user } + + if ErrorAddr <> nil then + begin + MakeErrorMessage; + WriteErrorMessage; + ErrorAddr := nil; + end; + + { This loop exists because we might be nested in PackageLoad calls when } + { Halt got called. We need to unwind these contexts. } + + while True do + begin + + { If we are a library, and we are starting up fine, there are no units to finalize } + + if (InitContext.DLLInitState = 2) and (ExitCode = 0) then + InitContext.InitCount := 0; + + { Undo any unit initializations accomplished so far } + + FinalizeUnits; + + if (InitContext.DLLInitState <= 1) or (ExitCode <> 0) then + begin + if InitContext.Module <> nil then + with InitContext do + begin + UnregisterModule(Module); +{$IFDEF PC_MAPPED_EXCEPTIONS} + SysUnregisterIPLookup(Module.CodeSegStart); +{$ENDIF} + if (Module.ResInstance <> Module.Instance) and (Module.ResInstance <> 0) then + FreeLibrary(Module.ResInstance); + end; + end; + +{$IFNDEF PC_MAPPED_EXCEPTIONS} + UnsetExceptionHandler; +{$ENDIF} + +{$IFDEF MSWINDOWS} + if InitContext.DllInitState = 1 then + InitContext.ExitProcessTLS; +{$ENDIF} + + if InitContext.DllInitState <> 0 then + ExitDll; + + if InitContext.OuterContext = nil then + begin + { + If an ExitProcessProc is set, we call it. Note that at this + point the RTL is completely shutdown. The only thing this is used + for right now is the proper semantic handling of signals under Linux. + } + if Assigned(ExitProcessProc) then + ExitProcessProc; + ExitProcess(ExitCode); + end; + + InitContext := InitContext.OuterContext^ + end; +end; + +procedure _Halt; +begin + ExitCode := Code; + _Halt0; +end; + + +procedure _Run0Error; +{$IFDEF PUREPASCAL} +begin + _RunError(0); // loses return address +end; +{$ELSE} +asm + XOR EAX,EAX + JMP _RunError +end; +{$ENDIF} + + +procedure _RunError(errorCode: Byte); +{$IFDEF PUREPASCAL} +begin + ErrorAddr := Pointer(-1); // no return address available + Halt(errorCode); +end; +{$ELSE} +asm +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX, EAX + POP EAX + MOV ECX, [EBX].ErrorAddr + POP [ECX] +{$ELSE} + POP ErrorAddr +{$ENDIF} + JMP _Halt +end; +{$ENDIF} + +procedure _UnhandledException; +type TExceptProc = procedure (Obj: TObject; Addr: Pointer); +begin + if Assigned(ExceptProc) then + TExceptProc(ExceptProc)(ExceptObject, ExceptAddr) + else + RunErrorAt(230, ExceptAddr); +end; + +procedure _Assert(const Message, Filename: AnsiString; LineNumber: Integer); +{$IFDEF PUREPASCAL} +begin + if Assigned(AssertErrorProc) then + AssertErrorProc(Message, Filename, LineNumber, Pointer(-1)) + else + Error(reAssertionFailed); // loses return address +end; +{$ELSE} +asm + PUSH EBX +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + MOV EBX, EAX + MOV EAX, [EBX].AssertErrorProc + CMP [EAX], 0 + POP ECX + POP EAX +{$ELSE} + CMP AssertErrorProc,0 +{$ENDIF} + JNZ @@1 + MOV AL,reAssertionFailed + CALL Error + JMP @@exit + +@@1: PUSH [ESP+4].Pointer +{$IFDEF PIC} + MOV EBX, [EBX].AssertErrorProc + CALL [EBX] +{$ELSE} + CALL AssertErrorProc +{$ENDIF} +@@exit: + POP EBX +end; +{$ENDIF} + +type + PThreadRec = ^TThreadRec; + TThreadRec = record + { + WARNING: Don't change these fields without also changing them in + the C++ RTL : winrtl/source/vcl/crtlvcl.cpp + } + Func: TThreadFunc; + Parameter: Pointer; + end; + +{$IFDEF MSWINDOWS} +function ThreadWrapper(Parameter: Pointer): Integer; stdcall; +{$ELSE} +function ThreadWrapper(Parameter: Pointer): Pointer; cdecl; +{$ENDIF} +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + { Mark the top of the stack with a signature } + PUSH UNWINDFI_TOPOFSTACK +{$ENDIF} + CALL _FpuInit + PUSH EBP +{$IFNDEF PC_MAPPED_EXCEPTIONS} + XOR ECX,ECX + PUSH offset _ExceptionHandler + MOV EDX,FS:[ECX] + PUSH EDX + MOV FS:[ECX],ESP +{$ENDIF} +{$IFDEF PC_MAPPED_EXCEPTIONS} + // The signal handling code in SysUtils depends on being able to + // discriminate between Delphi threads and foreign threads in order + // to choose the disposition of certain signals. It does this by + // testing a TLS index. However, we allocate TLS in a lazy fashion, + // so this test can fail unless we've already allocated the TLS segment. + // So we force the allocation of the TLS index value by touching a TLS + // value here. So don't remove this silly call to AreOSExceptionsBlocked. + CALL AreOSExceptionsBlocked +{$ENDIF} + MOV EAX,Parameter + + MOV ECX,[EAX].TThreadRec.Parameter + MOV EDX,[EAX].TThreadRec.Func + PUSH ECX + PUSH EDX + CALL _FreeMem + POP EDX + POP EAX + CALL EDX + +{$IFNDEF PC_MAPPED_EXCEPTIONS} + XOR EDX,EDX + POP ECX + MOV FS:[EDX],ECX + POP ECX +{$ENDIF} + POP EBP +{$IFDEF PC_MAPPED_EXCEPTIONS} + { Ditch our TOS marker } + ADD ESP, 4 +{$ENDIF} +end; + + +{$IFDEF MSWINDOWS} +function BeginThread(SecurityAttributes: Pointer; StackSize: LongWord; + ThreadFunc: TThreadFunc; Parameter: Pointer; CreationFlags: LongWord; + var ThreadId: LongWord): Integer; +var + P: PThreadRec; +begin + if Assigned(SystemThreadFuncProc) then + P := PThreadRec(SystemThreadFuncProc(ThreadFunc, Parameter)) + else + begin + New(P); + P.Func := ThreadFunc; + P.Parameter := Parameter; + end; + IsMultiThread := TRUE; + Result := CreateThread(SecurityAttributes, StackSize, @ThreadWrapper, P, + CreationFlags, ThreadID); +end; + + +procedure EndThread(ExitCode: Integer); +begin + if Assigned(SystemThreadEndProc) then + SystemThreadEndProc(ExitCode); + ExitThread(ExitCode); +end; +{$ENDIF} + +{$IFDEF LINUX} +function BeginThread(Attribute: PThreadAttr; + ThreadFunc: TThreadFunc; + Parameter: Pointer; + var ThreadId: Cardinal): Integer; +var + P: PThreadRec; +begin + if Assigned(BeginThreadProc) then + Result := BeginThreadProc(Attribute, ThreadFunc, Parameter, ThreadId) + else + begin + New(P); + P.Func := ThreadFunc; + P.Parameter := Parameter; + IsMultiThread := True; + Result := _pthread_create(ThreadID, Attribute, @ThreadWrapper, P); + end; +end; + +procedure EndThread(ExitCode: Integer); +begin + if Assigned(EndThreadProc) then + EndThreadProc(ExitCode); + // No "else" required since EndThreadProc does not (!!should not!!) return. + _pthread_detach(GetCurrentThreadID); + _pthread_exit(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); +{$IFDEF PUREPASCAL} +var + P: PStrRec; +begin + if Pointer(S) <> nil then + begin + P := Pointer(Integer(S) - Sizeof(StrRec)); + Pointer(S) := nil; + if P.refCnt > 0 then + if InterlockedDecrement(P.refCnt) = 0 then + FreeMem(P); + end; +end; +{$ELSE} +asm + { -> EAX pointer to str } + + MOV EDX,[EAX] { fetch str } + TEST EDX,EDX { if nil, nothing to do } + JE @@done + MOV dword ptr [EAX],0 { clear str } + MOV ECX,[EDX-skew].StrRec.refCnt { fetch refCnt } + DEC ECX { if < 0: literal str } + JL @@done + LOCK DEC [EDX-skew].StrRec.refCnt { threadsafe dec refCount } + JNE @@done + PUSH EAX + LEA EAX,[EDX-skew].StrRec.refCnt { if refCnt now zero, deallocate} + CALL _FreeMem + POP EAX +@@done: +end; +{$ENDIF} + +procedure _LStrArrayClr(var StrArray; cnt: longint); +{$IFDEF PUREPASCAL} +var + P: Pointer; +begin + P := @StrArray; + while cnt > 0 do + begin + _LStrClr(P^); + Dec(cnt); + Inc(Integer(P), sizeof(Pointer)); + end; +end; +{$ELSE} +asm + { -> EAX pointer to str } + { EDX cnt } + + PUSH EBX + PUSH ESI + MOV EBX,EAX + MOV ESI,EDX + +@@loop: + MOV EDX,[EBX] { fetch str } + TEST EDX,EDX { if nil, nothing to do } + JE @@doneEntry + MOV dword ptr [EBX],0 { clear str } + MOV ECX,[EDX-skew].StrRec.refCnt { fetch refCnt } + DEC ECX { if < 0: literal str } + JL @@doneEntry + LOCK DEC [EDX-skew].StrRec.refCnt { threadsafe dec refCount } + JNE @@doneEntry + LEA EAX,[EDX-skew].StrRec.refCnt { if refCnt now zero, deallocate} + CALL _FreeMem +@@doneEntry: + ADD EBX,4 + DEC ESI + JNE @@loop + + POP ESI + POP EBX +end; +{$ENDIF} + +{ 99.03.11 + This function is used when assigning to global variables. + + Literals are copied to prevent a situation where a dynamically + allocated DLL or package assigns a literal to a variable and then + is unloaded -- thereby causing the string memory (in the code + segment of the DLL) to be removed -- and therefore leaving the + global variable pointing to invalid memory. +} +procedure _LStrAsg(var dest; const source); +{$IFDEF PUREPASCAL} +var + S, D: Pointer; + P: PStrRec; + Temp: Longint; +begin + S := Pointer(source); + if S <> nil then + begin + P := PStrRec(Integer(S) - sizeof(StrRec)); + if P.refCnt < 0 then // make copy of string literal + begin + Temp := P.length; + S := _NewAnsiString(Temp); + Move(Pointer(source)^, S^, Temp); + P := PStrRec(Integer(S) - sizeof(StrRec)); + end; + InterlockedIncrement(P.refCnt); + end; + + D := Pointer(dest); + Pointer(dest) := S; + if D <> nil then + begin + P := PStrRec(Integer(D) - sizeof(StrRec)); + if P.refCnt > 0 then + if InterlockedDecrement(P.refCnt) = 0 then + FreeMem(P); + end; +end; +{$ELSE} +asm + { -> EAX pointer to dest str } + { -> EDX pointer to source str } + + TEST EDX,EDX { have a source? } + JE @@2 { no -> jump } + + MOV ECX,[EDX-skew].StrRec.refCnt + INC ECX + JG @@1 { literal string -> jump not taken } + + PUSH EAX + PUSH EDX + MOV EAX,[EDX-skew].StrRec.length + CALL _NewAnsiString + MOV EDX,EAX + POP EAX + PUSH EDX + MOV ECX,[EAX-skew].StrRec.length + CALL Move + POP EDX + POP EAX + JMP @@2 + +@@1: + LOCK INC [EDX-skew].StrRec.refCnt + +@@2: XCHG EDX,[EAX] + TEST EDX,EDX + JE @@3 + MOV ECX,[EDX-skew].StrRec.refCnt + DEC ECX + JL @@3 + LOCK DEC [EDX-skew].StrRec.refCnt + JNE @@3 + LEA EAX,[EDX-skew].StrRec.refCnt + CALL _FreeMem +@@3: +end; +{$ENDIF} + +procedure _LStrLAsg(var dest; const source); +{$IFDEF PUREPASCAL} +var + P: Pointer; +begin + P := Pointer(source); + _LStrAddRef(P); + P := Pointer(dest); + Pointer(dest) := Pointer(source); + _LStrClr(P); +end; +{$ELSE} +asm +{ -> EAX pointer to dest } +{ EDX source } + + TEST EDX,EDX + JE @@sourceDone + + { bump up the ref count of the source } + + MOV ECX,[EDX-skew].StrRec.refCnt + INC ECX + JLE @@sourceDone { literal assignment -> jump taken } + LOCK INC [EDX-skew].StrRec.refCnt +@@sourceDone: + + { we need to release whatever the dest is pointing to } + + XCHG EDX,[EAX] { fetch str } + TEST EDX,EDX { if nil, nothing to do } + JE @@done + MOV ECX,[EDX-skew].StrRec.refCnt { fetch refCnt } + DEC ECX { if < 0: literal str } + JL @@done + LOCK DEC [EDX-skew].StrRec.refCnt { threadsafe dec refCount } + JNE @@done + LEA EAX,[EDX-skew].StrRec.refCnt { if refCnt now zero, deallocate} + CALL _FreeMem +@@done: +end; +{$ENDIF} + +function _NewAnsiString(length: Longint): Pointer; +{$IFDEF PUREPASCAL} +var + P: PStrRec; +begin + Result := nil; + if length <= 0 then Exit; + // Alloc an extra null for strings with even length. This has no actual cost + // since the allocator will round up the request to an even size anyway. + // All widestring allocations have even length, and need a double null terminator. + GetMem(P, length + sizeof(StrRec) + 1 + ((length + 1) and 1)); + Result := Pointer(Integer(P) + sizeof(StrRec)); + P.length := length; + P.refcnt := 1; + PWideChar(Result)[length div 2] := #0; // length guaranteed >= 2 +end; +{$ELSE} +asm + { -> EAX length } + { <- EAX pointer to new string } + + TEST EAX,EAX + JLE @@null + PUSH EAX + ADD EAX,rOff+2 // one or two nulls (Ansi/Wide) + AND EAX, not 1 // round up to even length + PUSH EAX + CALL _GetMem + POP EDX // actual allocated length (>= 2) + MOV word ptr [EAX+EDX-2],0 // double null terminator + ADD EAX,rOff + POP EDX // requested string length + MOV [EAX-skew].StrRec.length,EDX + MOV [EAX-skew].StrRec.refCnt,1 + RET +@@null: + XOR EAX,EAX +end; +{$ENDIF} + +procedure _LStrFromPCharLen(var Dest: AnsiString; Source: PAnsiChar; Length: Integer); +asm + { -> EAX pointer to dest } + { EDX source } + { ECX length } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + { allocate new string } + + MOV EAX,EDI + + CALL _NewAnsiString + MOV ECX,EDI + MOV EDI,EAX + + TEST ESI,ESI + JE @@noMove + + MOV EDX,EAX + MOV EAX,ESI + CALL Move + + { assign the result to dest } + +@@noMove: + MOV EAX,EBX + CALL _LStrClr + MOV [EBX],EDI + + POP EDI + POP ESI + POP EBX +end; + +{$IFDEF LINUX} +procedure LocaleConversionError; +begin + Error(reCodesetConversion); +end; + +type + TCharacterSizeProc = function(P: Pointer; MaxLen: Integer): Integer; + +function CharacterSizeWideChar(P: Pointer; MaxLen: Integer): Integer; +begin + Result := SizeOf(WideChar); +end; + +function CharacterSizeLocaleChar(P: Pointer; MaxLen: Integer): Integer; +begin + Assert(Assigned(P)); + Result := mblen(P, MaxLen); + if Result <= 0 then + begin + mblen(nil, 0); + Result := SizeOf(Char); + end; +end; + +function BufConvert(var Dest; DestBytes: Integer; + const Source; SrcBytes: Integer; + context: Integer; + DestCharSize: Integer; + SourceCharSize: TCharacterSizeProc): Integer; +const + E2BIG = 7; + EINVAL = 22; + EILSEQ = 84; +const + UnknownCharIndicator = '?'; +var + SrcBytesLeft, DestBytesLeft, Zero: Integer; + s, d, pNil: Pointer; + LastError: Integer; + cs: Integer; +begin + Result := -1; + + // Make copies of parameters. iconv modifies param pointers. + DestBytesLeft := DestBytes; + SrcBytesLeft := SrcBytes; + s := Pointer(Source); + d := Pointer(Dest); + + while True do + begin + Result := iconv(context, s, SrcBytesLeft, d, DestBytesLeft); + if Result <> -1 then + Break + else + begin + LastError := GetLastError; + if (LastError = E2BIG) and (SrcBytesLeft > 0) and (DestBytesLeft > 0) then + Continue; + + if (LastError <> EINVAL) and (LastError <> EILSEQ) then + LocaleConversionError; + pNil := nil; + Zero := 0; + iconv(context, pNil, Zero, pNil, Zero); // Reset state of context + + // Invalid input character in conversion stream. + // Skip input character and write '?' to output stream. + // The glibc iconv() implementation also returns EILSEQ + // for a valid input character that cannot be converted + // into the requested codeset. + cs := SourceCharSize(s, SrcBytesLeft); + Inc(Cardinal(s), cs); + Dec(SrcBytesLeft, cs); + + Assert(DestCharSize in [1, 2]); + case DestCharSize of + 1: + begin + PChar(d)^ := UnknownCharIndicator; + Inc(PChar(d)); + Dec(DestBytesLeft, SizeOf(Char)); + end; + + 2: + begin + PWideChar(d)^ := UnknownCharIndicator; + Inc(PWideChar(d)); + Dec(DestBytesLeft, SizeOf(WideChar)); + end; + end; + end; + end; + + if Result <> -1 then + Result := DestBytes - DestBytesLeft; +end; +{$ENDIF} + +function CharFromWChar(CharDest: PChar; DestBytes: Integer; const WCharSource: PWideChar; SrcChars: Integer): Integer; +{$IFDEF LINUX} +var + IconvContext: Integer; +{$ENDIF} +begin +{$IFDEF LINUX} + if (DestBytes <> 0) and (SrcChars <> 0) then + begin + IconvContext := iconv_open(nl_langinfo(_NL_CTYPE_CODESET_NAME), 'UNICODELITTLE'); + if IconvContext = -1 then + LocaleConversionError; + try + Result := BufConvert(CharDest, DestBytes, WCharSource, SrcChars * SizeOf(WideChar), + IconvContext, 1, CharacterSizeWideChar); + finally + iconv_close(IconvContext); + end; + end + else + Result := 0; +{$ENDIF} +{$IFDEF MSWINDOWS} + Result := WideCharToMultiByte(DefaultSystemCodePage, 0, WCharSource, SrcChars, + CharDest, DestBytes, nil, nil); +{$ENDIF} +end; + +function WCharFromChar(WCharDest: PWideChar; DestChars: Integer; const CharSource: PChar; SrcBytes: Integer): Integer; +{$IFDEF LINUX} +var + IconvContext: Integer; +{$ENDIF} +begin +{$IFDEF LINUX} + if (DestChars <> 0) and (SrcBytes <> 0) then + begin + IconvContext := iconv_open('UNICODELITTLE', nl_langinfo(_NL_CTYPE_CODESET_NAME)); + if IconvContext = -1 then + LocaleConversionError; + try + Result := BufConvert(WCharDest, DestChars * SizeOf(WideChar), CharSource, SrcBytes, + IconvContext, 2, CharacterSizeLocaleChar); + finally + iconv_close(IconvContext); + end; + if Result <> -1 then + Result := Result div SizeOf(WideChar); + end + else + Result := 0; +{$ENDIF} +{$IFDEF MSWINDOWS} + Result := MultiByteToWideChar(DefaultSystemCodePage, 0, CharSource, SrcBytes, + WCharDest, DestChars); +{$ENDIF} +end; + +procedure _LStrFromPWCharLen(var Dest: AnsiString; Source: PWideChar; Length: Integer); +var + DestLen: Integer; + Buffer: array[0..4095] of Char; +begin + if Length <= 0 then + begin + _LStrClr(Dest); + Exit; + end; + if Length+1 < (High(Buffer) div sizeof(WideChar)) then + begin + DestLen := CharFromWChar(Buffer, High(Buffer), Source, Length); + if DestLen >= 0 then + begin + _LStrFromPCharLen(Dest, Buffer, DestLen); + Exit; + end; + end; + + DestLen := (Length + 1) * sizeof(WideChar); + SetLength(Dest, DestLen); // overallocate, trim later + DestLen := CharFromWChar(Pointer(Dest), DestLen, Source, Length); + if DestLen < 0 then DestLen := 0; + SetLength(Dest, DestLen); +end; + + +procedure _LStrFromChar(var Dest: AnsiString; Source: AnsiChar); +asm + PUSH EDX + MOV EDX,ESP + MOV ECX,1 + CALL _LStrFromPCharLen + POP EDX +end; + + +procedure _LStrFromWChar(var Dest: AnsiString; Source: WideChar); +asm + PUSH EDX + MOV EDX,ESP + MOV ECX,1 + CALL _LStrFromPWCharLen + POP EDX +end; + + +procedure _LStrFromPChar(var Dest: AnsiString; Source: PAnsiChar); +asm + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CL,[EDX+0] + JE @@4 + CMP CL,[EDX+1] + JE @@3 + CMP CL,[EDX+2] + JE @@2 + CMP CL,[EDX+3] + JE @@1 + ADD EDX,4 + JMP @@0 +@@1: INC EDX +@@2: INC EDX +@@3: INC EDX +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX +@@5: JMP _LStrFromPCharLen +end; + + +procedure _LStrFromPWChar(var Dest: AnsiString; Source: PWideChar); +asm + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CX,[EDX+0] + JE @@4 + CMP CX,[EDX+2] + JE @@3 + CMP CX,[EDX+4] + JE @@2 + CMP CX,[EDX+6] + JE @@1 + ADD EDX,8 + JMP @@0 +@@1: ADD EDX,2 +@@2: ADD EDX,2 +@@3: ADD EDX,2 +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX + SHR ECX,1 +@@5: JMP _LStrFromPWCharLen +end; + + +procedure _LStrFromString(var Dest: AnsiString; const Source: ShortString); +asm + XOR ECX,ECX + MOV CL,[EDX] + INC EDX + JMP _LStrFromPCharLen +end; + + +procedure _LStrFromArray(var Dest: AnsiString; Source: PAnsiChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASB + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _LStrFromPCharLen +end; + + +procedure _LStrFromWArray(var Dest: AnsiString; Source: PWideChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASW + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _LStrFromPWCharLen +end; + + +procedure _LStrFromWStr(var Dest: AnsiString; const Source: WideString); +asm + { -> EAX pointer to dest } + { EDX pointer to WideString data } + + XOR ECX,ECX + TEST EDX,EDX + JE @@1 + MOV ECX,[EDX-4] + SHR ECX,1 +@@1: JMP _LStrFromPWCharLen +end; + + +procedure _LStrToString{(var Dest: ShortString; const Source: AnsiString; MaxLen: Integer)}; +asm + { -> EAX pointer to result } + { EDX AnsiString s } + { ECX length of result } + + PUSH EBX + TEST EDX,EDX + JE @@empty + MOV EBX,[EDX-skew].StrRec.length + TEST EBX,EBX + JE @@empty + + CMP ECX,EBX + JL @@truncate + MOV ECX,EBX +@@truncate: + MOV [EAX],CL + INC EAX + + XCHG EAX,EDX + CALL Move + + JMP @@exit + +@@empty: + MOV byte ptr [EAX],0 + +@@exit: + POP EBX +end; + +function _LStrLen(const S: AnsiString): Longint; +begin + Result := Longint(S); + if Result <> 0 then // PStrRec should be used here, but + Result := PLongint(Result - 4)^; // a private symbol can't be inlined +end; + +procedure _LStrCat{var dest: AnsiString; source: AnsiString}; +asm + { -> EAX pointer to dest } + { EDX source } + + TEST EDX,EDX + JE @@exit + + MOV ECX,[EAX] + TEST ECX,ECX + JE _LStrAsg + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,[ECX-skew].StrRec.length + + MOV EDX,[ESI-skew].StrRec.length + ADD EDX,EDI + CMP ESI,ECX + JE @@appendSelf + + CALL _LStrSetLength + MOV EAX,ESI + MOV ECX,[ESI-skew].StrRec.length + +@@appendStr: + MOV EDX,[EBX] + ADD EDX,EDI + CALL Move + POP EDI + POP ESI + POP EBX + RET + +@@appendSelf: + CALL _LStrSetLength + MOV EAX,[EBX] + MOV ECX,EDI + JMP @@appendStr + +@@exit: +end; + + +procedure _LStrCat3{var dest:AnsiString; source1: AnsiString; source2: AnsiString}; +asm + { ->EAX = Pointer to dest } + { EDX = source1 } + { ECX = source2 } + + TEST EDX,EDX + JE @@assignSource2 + + TEST ECX,ECX + JE _LStrAsg + + CMP EDX,[EAX] + JE @@appendToDest + + CMP ECX,[EAX] + JE @@theHardWay + + PUSH EAX + PUSH ECX + CALL _LStrAsg + + POP EDX + POP EAX + JMP _LStrCat + +@@theHardWay: + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EDX + MOV ESI,ECX + PUSH EAX + + MOV EAX,[EBX-skew].StrRec.length + ADD EAX,[ESI-skew].StrRec.length + CALL _NewAnsiString + + MOV EDI,EAX + MOV EDX,EAX + MOV EAX,EBX + MOV ECX,[EBX-skew].StrRec.length + CALL Move + + MOV EDX,EDI + MOV EAX,ESI + MOV ECX,[ESI-skew].StrRec.length + ADD EDX,[EBX-skew].StrRec.length + CALL Move + + POP EAX + MOV EDX,EDI + TEST EDI,EDI + JE @@skip + DEC [EDI-skew].StrRec.refCnt // EDI = local temp str +@@skip: + CALL _LStrAsg + + POP EDI + POP ESI + POP EBX + + JMP @@exit + +@@assignSource2: + MOV EDX,ECX + JMP _LStrAsg + +@@appendToDest: + MOV EDX,ECX + JMP _LStrCat + +@@exit: +end; + + +procedure _LStrCatN{var dest:AnsiString; argCnt: Integer; ...}; +asm + { ->EAX = Pointer to dest } + { EDX = number of args (>= 3) } + { [ESP+4], [ESP+8], ... crgCnt AnsiString arguments, reverse order } + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EDX + PUSH EAX + MOV EBX,EDX + + XOR EDI,EDI + MOV ECX,[ESP+EDX*4+5*4] // first arg is furthest out + TEST ECX,ECX + JZ @@0 + CMP [EAX],ECX // is dest = first arg? + JNE @@0 + MOV EDI,ECX // EDI nonzero -> potential appendstr case + MOV EAX,[ECX-skew].StrRec.length + DEC EDX + JMP @@loop1 +@@0: + XOR EAX,EAX +@@loop1: + MOV ECX,[ESP+EDX*4+5*4] + TEST ECX,ECX + JE @@1 + ADD EAX,[ECX-skew].StrRec.length + CMP EDI,ECX // is dest an arg besides arg1? + JNE @@1 + XOR EDI,EDI // can't appendstr - dest is multiple args +@@1: + DEC EDX + JNE @@loop1 + +@@append: + TEST EDI,EDI // dest is 1st and only 1st arg? + JZ @@copy + MOV EDX,EAX // length into EDX + MOV EAX,[ESP] // ptr to str into EAX + MOV ESI,[EDI-skew].StrRec.Length // save old size before realloc + CALL _LStrSetLength + MOV EDI,[ESP] // append other strs to dest + PUSH [EDI] + ADD ESI,[EDI] // ESI = end of old string + DEC EBX + JMP @@loop2 + +@@copy: + CALL _NewAnsiString + PUSH EAX + MOV ESI,EAX + +@@loop2: + MOV EAX,[ESP+EBX*4+6*4] + MOV EDX,ESI + TEST EAX,EAX + JE @@2 + MOV ECX,[EAX-skew].StrRec.length + ADD ESI,ECX + CALL Move +@@2: + DEC EBX + JNE @@loop2 + + POP EDX + POP EAX + TEST EDI,EDI + JNZ @@exit + + TEST EDX,EDX + JE @@skip + DEC [EDX-skew].StrRec.refCnt // EDX = local temp str +@@skip: + CALL _LStrAsg + +@@exit: + POP EDX + POP EDI + POP ESI + POP EBX + POP EAX + LEA ESP,[ESP+EDX*4] + JMP EAX +end; + + +procedure _LStrCmp{left: AnsiString; right: AnsiString}; +asm +{ ->EAX = Pointer to left string } +{ EDX = Pointer to right string } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + CMP EAX,EDX + JE @@exit + + TEST ESI,ESI + JE @@str1null + + TEST EDI,EDI + JE @@str2null + + MOV EAX,[ESI-skew].StrRec.length + MOV EDX,[EDI-skew].StrRec.length + + SUB EAX,EDX { eax = len1 - len2 } + JA @@skip1 + ADD EDX,EAX { edx = len2 + (len1 - len2) = len1 } + +@@skip1: + PUSH EDX + SHR EDX,2 + JE @@cmpRest +@@longLoop: + MOV ECX,[ESI] + MOV EBX,[EDI] + CMP ECX,EBX + JNE @@misMatch + DEC EDX + JE @@cmpRestP4 + MOV ECX,[ESI+4] + MOV EBX,[EDI+4] + CMP ECX,EBX + JNE @@misMatch + ADD ESI,8 + ADD EDI,8 + DEC EDX + JNE @@longLoop + JMP @@cmpRest +@@cmpRestP4: + ADD ESI,4 + ADD EDI,4 +@@cmpRest: + POP EDX + AND EDX,3 + JE @@equal + + MOV ECX,[ESI] + MOV EBX,[EDI] + CMP CL,BL + JNE @@exit + DEC EDX + JE @@equal + CMP CH,BH + JNE @@exit + DEC EDX + JE @@equal + AND EBX,$00FF0000 + AND ECX,$00FF0000 + CMP ECX,EBX + JNE @@exit + +@@equal: + ADD EAX,EAX + JMP @@exit + +@@str1null: + MOV EDX,[EDI-skew].StrRec.length + SUB EAX,EDX + JMP @@exit + +@@str2null: + MOV EAX,[ESI-skew].StrRec.length + SUB EAX,EDX + JMP @@exit + +@@misMatch: + POP EDX + CMP CL,BL + JNE @@exit + CMP CH,BH + JNE @@exit + SHR ECX,16 + SHR EBX,16 + CMP CL,BL + JNE @@exit + CMP CH,BH + +@@exit: + POP EDI + POP ESI + POP EBX + +end; + +function _LStrAddRef(var str): Pointer; +{$IFDEF PUREPASCAL} +var + P: PStrRec; +begin + P := Pointer(Integer(str) - sizeof(StrRec)); + if P <> nil then + if P.refcnt >= 0 then + InterlockedIncrement(P.refcnt); + Result := Pointer(str); +end; +{$ELSE} +asm + { -> EAX str } + TEST EAX,EAX + JE @@exit + MOV EDX,[EAX-skew].StrRec.refCnt + INC EDX + JLE @@exit + LOCK INC [EAX-skew].StrRec.refCnt +@@exit: +end; +{$ENDIF} + +function PICEmptyString: PWideChar; +begin + Result := ''; +end; + +function _LStrToPChar(const s: AnsiString): PChar; +{$IFDEF PUREPASCAL} +const + EmptyString = ''; +begin + if Pointer(s) = nil then + Result := EmptyString + else + Result := Pointer(s); +end; +{$ELSE} +asm + { -> EAX pointer to str } + { <- EAX pointer to PChar } + + TEST EAX,EAX + JE @@handle0 + RET +{$IFDEF PIC} +@@handle0: + JMP PICEmptyString +{$ELSE} +@@zeroByte: + DB 0 +@@handle0: + MOV EAX,offset @@zeroByte +{$ENDIF} +end; +{$ENDIF} + +function InternalUniqueString(var str): Pointer; +asm + { -> EAX pointer to str } + { <- EAX pointer to unique copy } + MOV EDX,[EAX] + TEST EDX,EDX + JE @@exit + MOV ECX,[EDX-skew].StrRec.refCnt + DEC ECX + JE @@exit + + PUSH EBX + MOV EBX,EAX + MOV EAX,[EDX-skew].StrRec.length + CALL _NewAnsiString + MOV EDX,EAX + MOV EAX,[EBX] + MOV [EBX],EDX + PUSH EAX + MOV ECX,[EAX-skew].StrRec.length + CALL Move + POP EAX + MOV ECX,[EAX-skew].StrRec.refCnt + DEC ECX + JL @@skip + LOCK DEC [EAX-skew].StrRec.refCnt + JNZ @@skip + LEA EAX,[EAX-skew].StrRec.refCnt { if refCnt now zero, deallocate} + CALL _FreeMem +@@skip: + MOV EDX,[EBX] + POP EBX +@@exit: + MOV EAX,EDX +end; + + +procedure UniqueString(var str: AnsiString); +asm + JMP InternalUniqueString +end; + +procedure _UniqueStringA(var str: AnsiString); +asm + JMP InternalUniqueString +end; + +procedure UniqueString(var str: WideString); +asm +{$IFDEF LINUX} + JMP InternalUniqueString +{$ENDIF} +{$IFDEF MSWINDOWS} + // nothing to do - Windows WideStrings are always single reference +{$ENDIF} +end; + +procedure _UniqueStringW(var str: WideString); +asm +{$IFDEF LINUX} + JMP InternalUniqueString +{$ENDIF} +{$IFDEF MSWINDOWS} + // nothing to do - Windows WideStrings are always single reference +{$ENDIF} +end; + +procedure _LStrCopy{ const s : AnsiString; index, count : Integer) : AnsiString}; +asm + { ->EAX Source string } + { EDX index } + { ECX count } + { [ESP+4] Pointer to result string } + + PUSH EBX + + TEST EAX,EAX + JE @@srcEmpty + + MOV EBX,[EAX-skew].StrRec.length + TEST EBX,EBX + JE @@srcEmpty + +{ make index 0-based and limit to 0 <= index < Length(src) } + + DEC EDX + JL @@smallInx + CMP EDX,EBX + JGE @@bigInx + +@@cont1: + +{ limit count to satisfy 0 <= count <= Length(src) - index } + + SUB EBX,EDX { calculate Length(src) - index } + TEST ECX,ECX + JL @@smallCount + CMP ECX,EBX + JG @@bigCount + +@@cont2: + + ADD EDX,EAX + MOV EAX,[ESP+4+4] + CALL _LStrFromPCharLen + JMP @@exit + +@@smallInx: + XOR EDX,EDX + JMP @@cont1 +@@bigCount: + MOV ECX,EBX + JMP @@cont2 +@@bigInx: +@@smallCount: +@@srcEmpty: + MOV EAX,[ESP+4+4] + CALL _LStrClr +@@exit: + POP EBX + RET 4 +end; + + +procedure _LStrDelete{ var s : AnsiString; index, count : Integer }; +asm + { ->EAX Pointer to s } + { EDX index } + { ECX count } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + CALL UniqueString + + MOV EDX,[EBX] + TEST EDX,EDX { source already empty: nothing to do } + JE @@exit + + MOV ECX,[EDX-skew].StrRec.length + +{ make index 0-based, if not in [0 .. Length(s)-1] do nothing } + + DEC ESI + JL @@exit + CMP ESI,ECX + JGE @@exit + +{ limit count to [0 .. Length(s) - index] } + + TEST EDI,EDI + JLE @@exit + SUB ECX,ESI { ECX = Length(s) - index } + CMP EDI,ECX + JLE @@1 + MOV EDI,ECX +@@1: + +{ move length - index - count characters from s+index+count to s+index } + + SUB ECX,EDI { ECX = Length(s) - index - count } + ADD EDX,ESI { EDX = s+index } + LEA EAX,[EDX+EDI] { EAX = s+index+count } + CALL Move + +{ set length(s) to length(s) - count } + + MOV EDX,[EBX] + MOV EAX,EBX + MOV EDX,[EDX-skew].StrRec.length + SUB EDX,EDI + CALL _LStrSetLength + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +procedure _LStrInsert{ const source : AnsiString; var s : AnsiString; index : Integer }; +asm + { -> EAX source string } + { EDX pointer to destination string } + { ECX index } + + TEST EAX,EAX + JE @@nothingToDo + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + +{ make index 0-based and limit to 0 <= index <= Length(s) } + + MOV EDX,[EDX] + PUSH EDX + TEST EDX,EDX + JE @@sIsNull + MOV EDX,[EDX-skew].StrRec.length +@@sIsNull: + DEC EDI + JGE @@indexNotLow + XOR EDI,EDI +@@indexNotLow: + CMP EDI,EDX + JLE @@indexNotHigh + MOV EDI,EDX +@@indexNotHigh: + + MOV EBP,[EBX-skew].StrRec.length + +{ set length of result to length(source) + length(s) } + + MOV EAX,ESI + ADD EDX,EBP + CALL _LStrSetLength + POP EAX + + CMP EAX,EBX + JNE @@notInsertSelf + MOV EBX,[ESI] + +@@notInsertSelf: + +{ move length(s) - length(source) - index chars from s+index to s+index+length(source) } + + MOV EAX,[ESI] { EAX = s } + LEA EDX,[EDI+EBP] { EDX = index + length(source) } + MOV ECX,[EAX-skew].StrRec.length + SUB ECX,EDX { ECX = length(s) - length(source) - index } + ADD EDX,EAX { EDX = s + index + length(source) } + ADD EAX,EDI { EAX = s + index } + CALL Move + +{ copy length(source) chars from source to s+index } + + MOV EAX,EBX + MOV EDX,[ESI] + MOV ECX,EBP + ADD EDX,EDI + CALL Move + +@@exit: + POP EBP + POP EDI + POP ESI + POP EBX +@@nothingToDo: +end; + +{ + This one needs to be visible for AnsiString support in C++. +} +procedure _LStrPos{ const substr : AnsiString; const s : AnsiString ) : Integer}; +asm +{ ->EAX Pointer to substr } +{ EDX Pointer to string } +{ <-EAX Position of substr in s or 0 } + + TEST EAX,EAX + JE @@noWork + + TEST EDX,EDX + JE @@stringEmpty + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX { Point ESI to substr } + MOV EDI,EDX { Point EDI to s } + + MOV ECX,[EDI-skew].StrRec.length { ECX = Length(s) } + + PUSH EDI { remember s position to calculate index } + + MOV EDX,[ESI-skew].StrRec.length { EDX = Length(substr) } + + DEC EDX { EDX = Length(substr) - 1 } + JS @@fail { < 0 ? return 0 } + MOV AL,[ESI] { AL = first char of substr } + INC ESI { Point ESI to 2'nd char of substr } + + SUB ECX,EDX { #positions in s to look at } + { = Length(s) - Length(substr) + 1 } + JLE @@fail +@@loop: + REPNE SCASB + JNE @@fail + MOV EBX,ECX { save outer loop counter } + PUSH ESI { save outer loop substr pointer } + PUSH EDI { save outer loop s pointer } + + MOV ECX,EDX + REPE CMPSB + POP EDI { restore outer loop s pointer } + POP ESI { restore outer loop substr pointer } + JE @@found + MOV ECX,EBX { restore outer loop counter } + JMP @@loop + +@@fail: + POP EDX { get rid of saved s pointer } + XOR EAX,EAX + JMP @@exit + +@@stringEmpty: + XOR EAX,EAX + JMP @@noWork + +@@found: + POP EDX { restore pointer to first char of s } + MOV EAX,EDI { EDI points of char after match } + SUB EAX,EDX { the difference is the correct index } +@@exit: + POP EDI + POP ESI + POP EBX +@@noWork: +end; + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The implementation of function Pos is subject to the + * Mozilla Public License Version 1.1 (the "License"); you may + * not use this file except in compliance with the License. + * You may obtain a copy of the License at http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is Fastcode + * + * The Initial Developer of the Original Code is Fastcode + * + * Portions created by the Initial Developer are Copyright (C) 2002-2004 + * the Initial Developer. All Rights Reserved. + * + * Contributor(s): Aleksandr Sharahov + * + * ***** END LICENSE BLOCK ***** *) +function Pos(const substr, str: AnsiString): Integer; overload; +asm + push ebx + push esi + add esp, -16 + test edx, edx + jz @NotFound + test eax, eax + jz @NotFound + mov esi, [edx-4] //Length(Str) + mov ebx, [eax-4] //Length(Substr) + cmp esi, ebx + jl @NotFound + test ebx, ebx + jle @NotFound + dec ebx + add esi, edx + add edx, ebx + mov [esp+8], esi + add eax, ebx + mov [esp+4], edx + neg ebx + movzx ecx, byte ptr [eax] + mov [esp], ebx + jnz @FindString + + sub esi, 2 + mov [esp+12], esi + +@FindChar2: + cmp cl, [edx] + jz @Matched0ch + cmp cl, [edx+1] + jz @Matched1ch + add edx, 2 + cmp edx, [esp+12] + jb @FindChar4 + cmp edx, [esp+8] + jb @FindChar2 +@NotFound: + xor eax, eax + jmp @Exit0ch + +@FindChar4: + cmp cl, [edx] + jz @Matched0ch + cmp cl, [edx+1] + jz @Matched1ch + cmp cl, [edx+2] + jz @Matched2ch + cmp cl, [edx+3] + jz @Matched3ch + add edx, 4 + cmp edx, [esp+12] + jb @FindChar4 + cmp edx, [esp+8] + jb @FindChar2 + xor eax, eax + jmp @Exit0ch + +@Matched2ch: + add edx, 2 +@Matched0ch: + inc edx + mov eax, edx + sub eax, [esp+4] +@Exit0ch: + add esp, 16 + pop esi + pop ebx + ret + +@Matched3ch: + add edx, 2 +@Matched1ch: + add edx, 2 + xor eax, eax + cmp edx, [esp+8] + ja @Exit1ch + mov eax, edx + sub eax, [esp+4] +@Exit1ch: + add esp, 16 + pop esi + pop ebx + ret + +@FindString4: + cmp cl, [edx] + jz @Test0 + cmp cl, [edx+1] + jz @Test1 + cmp cl, [edx+2] + jz @Test2 + cmp cl, [edx+3] + jz @Test3 + add edx, 4 + cmp edx, [esp+12] + jb @FindString4 + cmp edx, [esp+8] + jb @FindString2 + xor eax, eax + jmp @Exit1 + +@FindString: + sub esi, 2 + mov [esp+12], esi +@FindString2: + cmp cl, [edx] + jz @Test0 +@AfterTest0: + cmp cl, [edx+1] + jz @Test1 +@AfterTest1: + add edx, 2 + cmp edx, [esp+12] + jb @FindString4 + cmp edx, [esp+8] + jb @FindString2 + xor eax, eax + jmp @Exit1 + +@Test3: + add edx, 2 +@Test1: + mov esi, [esp] +@Loop1: + movzx ebx, word ptr [esi+eax] + cmp bx, word ptr [esi+edx+1] + jnz @AfterTest1 + add esi, 2 + jl @Loop1 + add edx, 2 + xor eax, eax + cmp edx, [esp+8] + ja @Exit1 +@RetCode1: + mov eax, edx + sub eax, [esp+4] +@Exit1: + add esp, 16 + pop esi + pop ebx + ret + +@Test2: + add edx,2 +@Test0: + mov esi, [esp] +@Loop0: + movzx ebx, word ptr [esi+eax] + cmp bx, word ptr [esi+edx] + jnz @AfterTest0 + add esi, 2 + jl @Loop0 + inc edx +@RetCode0: + mov eax, edx + sub eax, [esp+4] + add esp, 16 + pop esi + pop ebx +end; + +procedure _LStrSetLength{ var str: AnsiString; newLength: Integer}; +asm + { -> EAX Pointer to str } + { EDX new length } + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV ESI,EDX + XOR EDI,EDI + + TEST EDX,EDX + JLE @@setString + + MOV EAX,[EBX] + TEST EAX,EAX + JE @@copyString + + CMP [EAX-skew].StrRec.refCnt,1 + JNE @@copyString + + SUB EAX,rOff + ADD EDX,rOff+1 + PUSH EAX + MOV EAX,ESP + CALL _ReallocMem + POP EAX + ADD EAX,rOff + MOV [EBX],EAX + MOV [EAX-skew].StrRec.length,ESI + MOV BYTE PTR [EAX+ESI],0 + JMP @@exit + +@@copyString: + MOV EAX,EDX + CALL _NewAnsiString + MOV EDI,EAX + + MOV EAX,[EBX] + TEST EAX,EAX + JE @@setString + + MOV EDX,EDI + MOV ECX,[EAX-skew].StrRec.length + CMP ECX,ESI + JL @@moveString + MOV ECX,ESI + +@@moveString: + CALL Move + +@@setString: + MOV EAX,EBX + CALL _LStrClr + MOV [EBX],EDI + +@@exit: + POP EDI + POP ESI + POP EBX +end; + +function StringOfChar(ch: AnsiChar; count: Integer): AnsiString; overload; +asm + { -> AL c } + { EDX count } + { ECX result } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + MOV EAX,ECX + CALL _LStrClr + + TEST ESI,ESI + JLE @@exit + + MOV EAX,ESI + CALL _NewAnsiString + + MOV [EDI],EAX + + MOV EDX,ESI + MOV CL,BL + + CALL _FillChar + +@@exit: + POP EDI + POP ESI + POP EBX + +end; + + +function _Write0LString(var t: TTextRec; const s: AnsiString): Pointer; +begin + Result := _WriteLString(t, s, 0); +end; + + +function _WriteLString(var t: TTextRec; const s: AnsiString; width: Longint): Pointer; +{$IFDEF PUREPASCAL} +var + i: Integer; +begin + i := Length(s); + _WriteSpaces(t, width - i); + Result := _WriteBytes(t, s[1], i); +end; +{$ELSE} +asm + { -> EAX Pointer to text record } + { EDX Pointer to AnsiString } + { ECX Field width } + + PUSH EBX + + MOV EBX,EDX + + MOV EDX,ECX + XOR ECX,ECX + TEST EBX,EBX + JE @@skip + MOV ECX,[EBX-skew].StrRec.length + SUB EDX,ECX +@@skip: + PUSH ECX + CALL _WriteSpaces + POP ECX + + MOV EDX,EBX + POP EBX + JMP _WriteBytes +end; +{$ENDIF} + + +function _Write0WString(var t: TTextRec; const s: WideString): Pointer; +begin + Result := _WriteWString(t, s, 0); +end; + + +function _WriteWString(var t: TTextRec; const s: WideString; width: Longint): Pointer; +var + i: Integer; +begin + i := Length(s); + _WriteSpaces(t, width - i); + Result := _WriteLString(t, AnsiString(s), 0); +end; + + +function _Write0WCString(var t: TTextRec; s: PWideChar): Pointer; +begin + Result := _WriteWCString(t, s, 0); +end; + + +function _WriteWCString(var t: TTextRec; s: PWideChar; width: Longint): Pointer; +var + i: Integer; +begin + i := 0; + if (s <> nil) then + while s[i] <> #0 do + Inc(i); + + _WriteSpaces(t, width - i); + Result := _WriteLString(t, AnsiString(s), 0); +end; + + +function _Write0WChar(var t: TTextRec; c: WideChar): Pointer; +begin + Result := _WriteWChar(t, c, 0); +end; + + +function _WriteWChar(var t: TTextRec; c: WideChar; width: Integer): Pointer; +begin + _WriteSpaces(t, width - 1); + Result := _WriteLString(t, AnsiString(c), 0); +end; + +function _WriteVariant(var T: TTextRec; const V: TVarData; Width: Integer): Pointer; +var + S: AnsiString; +begin + if Assigned(VarToLStrProc) then + begin + VarToLStrProc(S, V); + _WriteLString(T, S, Width); + end + else + Error(reVarInvalidOp); + Result := @T; +end; + +function _Write0Variant(var T: TTextRec; const V: TVarData): Pointer; +begin + Result := _WriteVariant(T, V, 0); +end; + +{$IFDEF MSWINDOWS} +procedure WStrError; +asm + MOV AL,reOutOfMemory + JMP Error +end; +{$ENDIF} + +function _NewWideString(CharLength: Longint): Pointer; +{$IFDEF LINUX} +begin + Result := _NewAnsiString(CharLength*2); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + TEST EAX,EAX + JE @@1 + PUSH EAX + PUSH 0 + CALL SysAllocStringLen + TEST EAX,EAX + JE WStrError +@@1: +end; +{$ENDIF} + +procedure WStrSet(var S: WideString; P: PWideChar); +{$IFDEF PUREPASCAL} +var + Temp: Pointer; +begin + Temp := Pointer(InterlockedExchange(Pointer(S), Pointer(P))); + if Temp <> nil then + _WStrClr(Temp); +end; +{$ELSE} +asm +{$IFDEF LINUX} + XCHG [EAX],EDX + TEST EDX,EDX + JZ @@1 + PUSH EDX + MOV EAX, ESP + CALL _WStrClr + POP EAX +{$ENDIF} +{$IFDEF MSWINDOWS} + XCHG [EAX],EDX + TEST EDX,EDX + JZ @@1 + PUSH EDX + CALL SysFreeString +{$ENDIF} +@@1: +end; +{$ENDIF} + + +procedure _WStrClr(var S); +{$IFDEF LINUX} +asm + JMP _LStrClr; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + { -> EAX Pointer to WideString } + + MOV EDX,[EAX] + TEST EDX,EDX + JE @@1 + MOV DWORD PTR [EAX],0 + PUSH EAX + PUSH EDX + CALL SysFreeString + POP EAX +@@1: +end; +{$ENDIF} + + +procedure _WStrArrayClr(var StrArray; Count: Integer); +{$IFDEF LINUX} +asm + JMP _LStrArrayClr +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + PUSH EBX + PUSH ESI + MOV EBX,EAX + MOV ESI,EDX +@@1: MOV EAX,[EBX] + TEST EAX,EAX + JE @@2 + MOV DWORD PTR [EBX],0 + PUSH EAX + CALL SysFreeString +@@2: ADD EBX,4 + DEC ESI + JNE @@1 + POP ESI + POP EBX +end; +{$ENDIF} + + +procedure _WStrAsg(var Dest: WideString; const Source: WideString); +{$IFDEF LINUX} +asm + JMP _LStrAsg +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + { -> EAX Pointer to WideString } + { EDX Pointer to data } + CMP [EAX],EDX + JE @@1 + TEST EDX,EDX + JE _WStrClr + MOV ECX,[EDX-4] + SHR ECX,1 + JE _WStrClr + PUSH ECX + PUSH EDX + PUSH EAX + CALL SysReAllocStringLen + TEST EAX,EAX + JE WStrError +@@1: +end; +{$ENDIF} + +procedure _WStrLAsg(var Dest: WideString; const Source: WideString); +{$IFDEF LINUX} +asm + JMP _LStrLAsg +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + JMP _WStrAsg +end; +{$ENDIF} + +procedure _WStrFromPCharLen(var Dest: WideString; Source: PAnsiChar; Length: Integer); +var + DestLen: Integer; + Buffer: array[0..2047] of WideChar; +begin + if Length <= 0 then + begin + _WStrClr(Dest); + Exit; + end; + if Length+1 < High(Buffer) then + begin + DestLen := WCharFromChar(Buffer, High(Buffer), Source, Length); + if DestLen > 0 then + begin + _WStrFromPWCharLen(Dest, @Buffer, DestLen); + Exit; + end; + end; + + DestLen := (Length + 1); + _WStrSetLength(Dest, DestLen); // overallocate, trim later + DestLen := WCharFromChar(Pointer(Dest), DestLen, Source, Length); + if DestLen < 0 then DestLen := 0; + _WStrSetLength(Dest, DestLen); +end; + +procedure _WStrFromPWCharLen(var Dest: WideString; Source: PWideChar; CharLength: Integer); +{$IFDEF LINUX} +var + Temp: Pointer; +begin + Temp := Pointer(Dest); + if CharLength > 0 then + begin + Pointer(Dest) := _NewWideString(CharLength); + if Source <> nil then + Move(Source^, Pointer(Dest)^, CharLength * sizeof(WideChar)); + end + else + Pointer(Dest) := nil; + _WStrClr(Temp); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + { -> EAX Pointer to WideString (dest) } + { EDX Pointer to characters (source) } + { ECX number of characters (not bytes) } + TEST ECX,ECX + JE _WStrClr + + PUSH EAX + + PUSH ECX + PUSH EDX + CALL SysAllocStringLen + TEST EAX,EAX + JE WStrError + + POP EDX + PUSH [EDX].PWideChar + MOV [EDX],EAX + + CALL SysFreeString +end; +{$ENDIF} + + +procedure _WStrFromChar(var Dest: WideString; Source: AnsiChar); +asm + PUSH EDX + MOV EDX,ESP + MOV ECX,1 + CALL _WStrFromPCharLen + POP EDX +end; + + +procedure _WStrFromWChar(var Dest: WideString; Source: WideChar); +asm + { -> EAX Pointer to WideString (dest) } + { EDX character (source) } + PUSH EDX + MOV EDX,ESP + MOV ECX,1 + CALL _WStrFromPWCharLen + POP EDX +end; + + +procedure _WStrFromPChar(var Dest: WideString; Source: PAnsiChar); +asm + { -> EAX Pointer to WideString (dest) } + { EDX Pointer to character (source) } + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CL,[EDX+0] + JE @@4 + CMP CL,[EDX+1] + JE @@3 + CMP CL,[EDX+2] + JE @@2 + CMP CL,[EDX+3] + JE @@1 + ADD EDX,4 + JMP @@0 +@@1: INC EDX +@@2: INC EDX +@@3: INC EDX +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX +@@5: JMP _WStrFromPCharLen +end; + + +procedure _WStrFromPWChar(var Dest: WideString; Source: PWideChar); +asm + { -> EAX Pointer to WideString (dest) } + { EDX Pointer to character (source) } + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CX,[EDX+0] + JE @@4 + CMP CX,[EDX+2] + JE @@3 + CMP CX,[EDX+4] + JE @@2 + CMP CX,[EDX+6] + JE @@1 + ADD EDX,8 + JMP @@0 +@@1: ADD EDX,2 +@@2: ADD EDX,2 +@@3: ADD EDX,2 +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX + SHR ECX,1 +@@5: JMP _WStrFromPWCharLen +end; + + +procedure _WStrFromString(var Dest: WideString; const Source: ShortString); +asm + XOR ECX,ECX + MOV CL,[EDX] + INC EDX + JMP _WStrFromPCharLen +end; + + +procedure _WStrFromArray(var Dest: WideString; Source: PAnsiChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASB + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _WStrFromPCharLen +end; + + +procedure _WStrFromWArray(var Dest: WideString; Source: PWideChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASW + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _WStrFromPWCharLen +end; + + +procedure _WStrFromLStr(var Dest: WideString; const Source: AnsiString); +asm + XOR ECX,ECX + TEST EDX,EDX + JE @@1 + MOV ECX,[EDX-4] +@@1: JMP _WStrFromPCharLen +end; + + +procedure _WStrToString(Dest: PShortString; const Source: WideString; MaxLen: Integer); +var + SourceLen, DestLen: Integer; + Buffer: array[0..511] of Char; +begin + if MaxLen > 255 then MaxLen := 255; + SourceLen := Length(Source); + if SourceLen >= MaxLen then SourceLen := MaxLen; + if SourceLen = 0 then + DestLen := 0 + else + begin + DestLen := CharFromWChar(Buffer, High(Buffer), PWideChar(Pointer(Source)), SourceLen); + if DestLen < 0 then + DestLen := 0 + else if DestLen > MaxLen then + DestLen := MaxLen; + end; + Dest^[0] := Chr(DestLen); + if DestLen > 0 then Move(Buffer, Dest^[1], DestLen); +end; + +function _WStrToPWChar(const S: WideString): PWideChar; +{$IFDEF PUREPASCAL} +const + EmptyString = ''; +begin + if Pointer(S) = nil then + Result := EmptyString + else + Result := Pointer(S); +end; +{$ELSE} +asm + TEST EAX,EAX + JE @@1 + RET +{$IFDEF PIC} +@@1: JMP PICEmptyString +{$ELSE} + NOP +@@0: DW 0 +@@1: MOV EAX,OFFSET @@0 +{$ENDIF} +end; +{$ENDIF} + + +function _WStrLen(const S: WideString): Integer; +{$IFDEF PUREPASCAL} +begin + if Pointer(S) = nil then + Result := 0 + else + Result := PInteger(Integer(S) - 4)^ div sizeof(WideChar); +end; +{$ELSE} +asm + { -> EAX Pointer to WideString data } + TEST EAX,EAX + JE @@1 + MOV EAX,[EAX-4] + SHR EAX,1 +@@1: +end; +{$ENDIF} + +procedure _WStrCat(var Dest: WideString; const Source: WideString); +var + DestLen, SourceLen: Integer; + NewStr: PWideChar; +begin + SourceLen := Length(Source); + if SourceLen <> 0 then + begin + DestLen := Length(Dest); + NewStr := _NewWideString(DestLen + SourceLen); + if DestLen > 0 then + Move(Pointer(Dest)^, NewStr^, DestLen * sizeof(WideChar)); + Move(Pointer(Source)^, NewStr[DestLen], SourceLen * sizeof(WideChar)); + WStrSet(Dest, NewStr); + end; +end; + + +procedure _WStrCat3(var Dest: WideString; const Source1, Source2: WideString); +var + Source1Len, Source2Len: Integer; + NewStr: PWideChar; +begin + Source1Len := Length(Source1); + Source2Len := Length(Source2); + if (Source1Len <> 0) or (Source2Len <> 0) then + begin + NewStr := _NewWideString(Source1Len + Source2Len); + Move(Pointer(Source1)^, Pointer(NewStr)^, Source1Len * sizeof(WideChar)); + Move(Pointer(Source2)^, NewStr[Source1Len], Source2Len * sizeof(WideChar)); + WStrSet(Dest, NewStr); + end + else + _WStrClr(Dest); +end; + + +procedure _WStrCatN{var Dest: WideString; ArgCnt: Integer; ...}; +asm + { ->EAX = Pointer to dest } + { EDX = number of args (>= 3) } + { [ESP+4], [ESP+8], ... crgCnt WideString arguments } + + PUSH EBX + PUSH ESI + PUSH EDX + PUSH EAX + MOV EBX,EDX + + XOR EAX,EAX +@@loop1: + MOV ECX,[ESP+EDX*4+4*4] + TEST ECX,ECX + JE @@1 + ADD EAX,[ECX-4] +@@1: + DEC EDX + JNE @@loop1 + + SHR EAX,1 + CALL _NewWideString + PUSH EAX + MOV ESI,EAX + +@@loop2: + MOV EAX,[ESP+EBX*4+5*4] + MOV EDX,ESI + TEST EAX,EAX + JE @@2 + MOV ECX,[EAX-4] + ADD ESI,ECX + CALL Move +@@2: + DEC EBX + JNE @@loop2 + + POP EDX + POP EAX + CALL WStrSet + + POP EDX + POP ESI + POP EBX + POP EAX + LEA ESP,[ESP+EDX*4] + JMP EAX +end; + +procedure _WStrCmp{left: WideString; right: WideString}; +asm +{ ->EAX = Pointer to left string } +{ EDX = Pointer to right string } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + CMP EAX,EDX + JE @@exit + + TEST ESI,ESI + JE @@str1null + + TEST EDI,EDI + JE @@str2null + + MOV EAX,[ESI-4] + MOV EDX,[EDI-4] + + SUB EAX,EDX { eax = len1 - len2 } + JA @@skip1 + ADD EDX,EAX { edx = len2 + (len1 - len2) = len1 } + +@@skip1: + PUSH EDX + SHR EDX,2 + JE @@cmpRest +@@longLoop: + MOV ECX,[ESI] + MOV EBX,[EDI] + CMP ECX,EBX + JNE @@misMatch + DEC EDX + JE @@cmpRestP4 + MOV ECX,[ESI+4] + MOV EBX,[EDI+4] + CMP ECX,EBX + JNE @@misMatch + ADD ESI,8 + ADD EDI,8 + DEC EDX + JNE @@longLoop + JMP @@cmpRest +@@cmpRestP4: + ADD ESI,4 + ADD EDI,4 +@@cmpRest: + POP EDX + AND EDX,2 + JE @@equal + + MOV CX,[ESI] + MOV BX,[EDI] + CMP CX,BX + JNE @@exit + +@@equal: + ADD EAX,EAX + JMP @@exit + +@@str1null: + MOV EDX,[EDI-4] + SUB EAX,EDX + JMP @@exit + +@@str2null: + MOV EAX,[ESI-4] + SUB EAX,EDX + JMP @@exit + +@@misMatch: + POP EDX + CMP CX,BX + JNE @@exit + SHR ECX,16 + SHR EBX,16 + CMP CX,BX + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +function _WStrCopy(const S: WideString; Index, Count: Integer): WideString; +var + L, N: Integer; +begin + L := Length(S); + if Index < 1 then Index := 0 else + begin + Dec(Index); + if Index > L then Index := L; + end; + if Count < 0 then N := 0 else + begin + N := L - Index; + if N > Count then N := Count; + end; + _WStrFromPWCharLen(Result, PWideChar(Pointer(S)) + Index, N); +end; + + +procedure _WStrDelete(var S: WideString; Index, Count: Integer); +var + L, N: Integer; + NewStr: PWideChar; +begin + L := Length(S); + if (L > 0) and (Index >= 1) and (Index <= L) and (Count > 0) then + begin + Dec(Index); + N := L - Index - Count; + if N < 0 then N := 0; + if (Index = 0) and (N = 0) then NewStr := nil else + begin + NewStr := _NewWideString(Index + N); + if Index > 0 then + Move(Pointer(S)^, NewStr^, Index * 2); + if N > 0 then + Move(PWideChar(Pointer(S))[L - N], NewStr[Index], N * 2); + end; + WStrSet(S, NewStr); + end; +end; + + +procedure _WStrInsert(const Source: WideString; var Dest: WideString; Index: Integer); +var + SourceLen, DestLen: Integer; + NewStr: PWideChar; +begin + SourceLen := Length(Source); + if SourceLen > 0 then + begin + DestLen := Length(Dest); + if Index < 1 then Index := 0 else + begin + Dec(Index); + if Index > DestLen then Index := DestLen; + end; + NewStr := _NewWideString(DestLen + SourceLen); + if Index > 0 then + Move(Pointer(Dest)^, NewStr^, Index * 2); + Move(Pointer(Source)^, NewStr[Index], SourceLen * 2); + if Index < DestLen then + Move(PWideChar(Pointer(Dest))[Index], NewStr[Index + SourceLen], + (DestLen - Index) * 2); + WStrSet(Dest, NewStr); + end; +end; + + +function Pos(const substr, str: WideString): Integer; overload; +asm +{ ->EAX Pointer to substr } +{ EDX Pointer to string } +{ <-EAX Position of substr in str or 0 } + + TEST EAX,EAX + JE @@noWork + + TEST EDX,EDX + JE @@stringEmpty + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX { Point ESI to substr } + MOV EDI,EDX { Point EDI to s } + + MOV ECX,[EDI-4] { ECX = Length(s) } + SHR ECX,1 + + PUSH EDI { remember s position to calculate index } + + MOV EDX,[ESI-4] { EDX = Length(substr) } + SHR EDX,1 + + DEC EDX { EDX = Length(substr) - 1 } + JS @@fail { < 0 ? return 0 } + MOV AX,[ESI] { AL = first char of substr } + ADD ESI,2 { Point ESI to 2'nd char of substr } + + SUB ECX,EDX { #positions in s to look at } + { = Length(s) - Length(substr) + 1 } + JLE @@fail +@@loop: + REPNE SCASW + JNE @@fail + MOV EBX,ECX { save outer loop counter } + PUSH ESI { save outer loop substr pointer } + PUSH EDI { save outer loop s pointer } + + MOV ECX,EDX + REPE CMPSW + POP EDI { restore outer loop s pointer } + POP ESI { restore outer loop substr pointer } + JE @@found + MOV ECX,EBX { restore outer loop counter } + JMP @@loop + +@@fail: + POP EDX { get rid of saved s pointer } + XOR EAX,EAX + JMP @@exit + +@@stringEmpty: + XOR EAX,EAX + JMP @@noWork + +@@found: + POP EDX { restore pointer to first char of s } + MOV EAX,EDI { EDI points of char after match } + SUB EAX,EDX { the difference is the correct index } + SHR EAX,1 +@@exit: + POP EDI + POP ESI + POP EBX +@@noWork: +end; + + +procedure _WStrSetLength(var S: WideString; NewLength: Integer); +var + NewStr: PWideChar; + Count: Integer; +begin + NewStr := nil; + if NewLength > 0 then + begin + NewStr := _NewWideString(NewLength); + Count := Length(S); + if Count > 0 then + begin + if Count > NewLength then Count := NewLength; + Move(Pointer(S)^, NewStr^, Count * 2); + end; + end; + WStrSet(S, NewStr); +end; + + +function StringOfChar(Ch: WideChar; Count: Integer): WideString; overload; +var + P: PWideChar; +begin + _WStrFromPWCharLen(Result, nil, Count); + P := Pointer(Result); + while Count > 0 do + begin + Dec(Count); + P[Count] := Ch; + end; +end; + +function _WStrAddRef(var str: WideString): Pointer; +{$IFDEF LINUX} +asm + JMP _LStrAddRef +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + MOV EDX,[EAX] + TEST EDX,EDX + JE @@1 + PUSH EAX + MOV ECX,[EDX-4] + SHR ECX,1 + PUSH ECX + PUSH EDX + CALL SysAllocStringLen + POP EDX + TEST EAX,EAX + JE WStrError + MOV [EDX],EAX +@@1: +end; +{$ENDIF} + +procedure _WCharToString(Dest: PShortString; const Source: WideChar; MaxLen: Integer); +var + DestLen: Integer; + Buffer: array[0..255] of Char; +begin + if MaxLen > 255 then MaxLen := 255; + DestLen := CharFromWChar(Buffer, High(Buffer), @Source, 1); + if DestLen < 0 then + DestLen := 0 + else if DestLen > MaxLen then + DestLen := MaxLen; + Dest^[0] := Chr(DestLen); + if DestLen > 0 then Move(Buffer, Dest^[1], DestLen); +end; + +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); +{$IFDEF PUREPASCAL} +var + FT: PFieldTable; + I: Cardinal; +begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + for I := FT.Count-1 downto 0 do + _InitializeArray(Pointer(Cardinal(P) + FT.Fields[I].Offset), FT.Fields[I].TypeInfo^, 1); +end; +{$ELSE} +asm + { -> EAX pointer to record to be initialized } + { EDX pointer to type info } + + XOR ECX,ECX + + PUSH EBX + MOV CL,[EDX+1] { type name length } + + PUSH ESI + PUSH EDI + + MOV EBX,EAX // PIC safe. See comment above + LEA ESI,[EDX+ECX+2+8] { address of destructable fields } + MOV EDI,[EDX+ECX+2+4] { number of destructable fields } + +@@loop: + + MOV EDX,[ESI] + MOV EAX,[ESI+4] + ADD EAX,EBX + MOV EDX,[EDX] + MOV ECX,1 + CALL _InitializeArray + ADD ESI,8 + DEC EDI + JG @@loop + + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + + +const + tkLString = 10; + tkWString = 11; + tkVariant = 12; + tkArray = 13; + tkRecord = 14; + tkInterface = 15; + tkDynArray = 17; + +procedure _InitializeArray(p: Pointer; typeInfo: Pointer; elemCount: Cardinal); +{$IFDEF PUREPASCAL} +var + FT: PFieldTable; +begin + if elemCount = 0 then Exit; + case PTypeInfo(typeInfo).Kind of + tkLString, tkWString, tkInterface, tkDynArray: + while elemCount > 0 do + begin + PInteger(P)^ := 0; + Inc(Integer(P), 4); + Dec(elemCount); + end; + tkVariant: + while elemCount > 0 do + begin + PInteger(P)^ := 0; + PInteger(Integer(P)+4)^ := 0; + PInteger(Integer(P)+8)^ := 0; + PInteger(Integer(P)+12)^ := 0; + Inc(Integer(P), sizeof(Variant)); + Dec(elemCount); + end; + tkArray: + begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + while elemCount > 0 do + begin + _InitializeArray(P, FT.Fields[0].TypeInfo^, FT.Count); + Inc(Integer(P), FT.Size); + Dec(elemCount); + end; + end; + tkRecord: + begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + while elemCount > 0 do + begin + _InitializeRecord(P, typeInfo); + Inc(Integer(P), FT.Size); + Dec(elemCount); + end; + end; + else + Error(reInvalidPtr); + end; +end; +{$ELSE} +asm + { -> EAX pointer to data to be initialized } + { EDX pointer to type info describing data } + { ECX number of elements of that type } + + TEST ECX, ECX + JZ @@zerolength + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX // PIC safe. See comment above + MOV ESI,EDX + MOV EDI,ECX + + XOR EDX,EDX + MOV AL,[ESI] + MOV DL,[ESI+1] + XOR ECX,ECX + + CMP AL,tkLString + JE @@LString + CMP AL,tkWString + JE @@WString + CMP AL,tkVariant + JE @@Variant + CMP AL,tkArray + JE @@Array + CMP AL,tkRecord + JE @@Record + CMP AL,tkInterface + JE @@Interface + CMP AL,tkDynArray + JE @@DynArray + MOV AL,reInvalidPtr + POP EDI + POP ESI + POP EBX + JMP Error + +@@LString: +@@WString: +@@Interface: +@@DynArray: + MOV [EBX],ECX + ADD EBX,4 + DEC EDI + JG @@LString + JMP @@exit + +@@Variant: + MOV [EBX ],ECX + MOV [EBX+ 4],ECX + MOV [EBX+ 8],ECX + MOV [EBX+12],ECX + ADD EBX,16 + DEC EDI + JG @@Variant + JMP @@exit + +@@Array: + PUSH EBP + MOV EBP,EDX +@@ArrayLoop: + MOV EDX,[ESI+EBP+2+8] // address of destructable fields typeinfo + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] // size in bytes of the array data + MOV ECX,[ESI+EBP+2+4] // number of destructable fields + MOV EDX,[EDX] + CALL _InitializeArray + DEC EDI + JG @@ArrayLoop + POP EBP + JMP @@exit + +@@Record: + PUSH EBP + MOV EBP,EDX +@@RecordLoop: + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV EDX,ESI + CALL _InitializeRecord + DEC EDI + JG @@RecordLoop + POP EBP + +@@exit: + + POP EDI + POP ESI + POP EBX +@@zerolength: +end; +{$ENDIF} + +procedure _Initialize(p: Pointer; typeInfo: Pointer); +{$IFDEF PUREPASCAL} +begin + _InitializeArray(p, typeInfo, 1); +end; +{$ELSE} +asm + MOV ECX,1 + JMP _InitializeArray +end; +{$ENDIF} + +procedure _FinalizeRecord(p: Pointer; typeInfo: Pointer); +{$IFDEF PUREPASCAL} +var + FT: PFieldTable; + I: Cardinal; +begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + for I := 0 to FT.Count-1 do + _FinalizeArray(Pointer(Cardinal(P) + FT.Fields[I].Offset), FT.Fields[I].TypeInfo^, 1); +end; +{$ELSE} +asm + { -> EAX pointer to record to be finalized } + { EDX pointer to type info } + + XOR ECX,ECX + + PUSH EBX + MOV CL,[EDX+1] + + PUSH ESI + PUSH EDI + + MOV EBX,EAX + LEA ESI,[EDX+ECX+2+8] + MOV EDI,[EDX+ECX+2+4] + +@@loop: + + MOV EDX,[ESI] + MOV EAX,[ESI+4] + ADD EAX,EBX + MOV EDX,[EDX] + MOV ECX,1 + CALL _FinalizeArray + ADD ESI,8 + DEC EDI + JG @@loop + + MOV EAX,EBX + + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +procedure _VarClr(var v: TVarData); +begin + if Assigned(VarClearProc) then + VarClearProc(v) + else + Error(reVarInvalidOp); +end; + +procedure _FinalizeArray(p: Pointer; typeInfo: Pointer; elemCount: Cardinal); +{$IFDEF PUREPASCAL} +var + FT: PFieldTable; +begin + if elemCount = 0 then Exit; + case PTypeInfo(typeInfo).Kind of + tkLString: _LStrArrayClr(P^, elemCount); + tkWString: _WStrArrayClr(P^, elemCount); + tkVariant: + while elemCount > 0 do + begin + _VarClr(PVarData(P)^); + Inc(Integer(P), sizeof(Variant)); + Dec(elemCount); + end; + tkArray: + begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + while elemCount > 0 do + begin + _FinalizeArray(P, FT.Fields[0].TypeInfo^, FT.Count); + Inc(Integer(P), FT.Size); + Dec(elemCount); + end; + end; + tkRecord: + begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + while elemCount > 0 do + begin + _FinalizeRecord(P, typeInfo); + Inc(Integer(P), FT.Size); + Dec(elemCount); + end; + end; + tkInterface: + while elemCount > 0 do + begin + _IntfClear(IInterface(P^)); + Inc(Integer(P), 4); + Dec(elemCount); + end; + tkDynArray: + while elemCount > 0 do + begin + _DynArrayClr(P); + Inc(Integer(P), 4); + Dec(elemCount); + end; + else + Error(reInvalidPtr); + end; +end; +{$ELSE} +asm + { -> EAX pointer to data to be finalized } + { EDX pointer to type info describing data } + { ECX number of elements of that type } + + { This code appears to be PIC safe. The functions called from + here either don't make external calls or call Pascal + routines that will fix up EBX in their prolog code + (FreeMem, VarClr, IntfClr). } + + CMP ECX, 0 { no array -> nop } + JE @@zerolength + + PUSH EAX + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + XOR EDX,EDX + MOV AL,[ESI] + MOV DL,[ESI+1] + + CMP AL,tkLString + JE @@LString + + CMP AL,tkWString + JE @@WString + + CMP AL,tkVariant + JE @@Variant + + CMP AL,tkArray + JE @@Array + + CMP AL,tkRecord + JE @@Record + + CMP AL,tkInterface + JE @@Interface + + CMP AL,tkDynArray + JE @@DynArray + + JMP @@error + +@@LString: + CMP ECX,1 + MOV EAX,EBX + JG @@LStringArray + CALL _LStrClr + JMP @@exit +@@LStringArray: + MOV EDX,ECX + CALL _LStrArrayClr + JMP @@exit + +@@WString: + CMP ECX,1 + MOV EAX,EBX + JG @@WStringArray + CALL _WStrClr + JMP @@exit +@@WStringArray: + MOV EDX,ECX + CALL _WStrArrayClr + JMP @@exit +@@Variant: + MOV EAX,EBX + ADD EBX,16 + CALL _VarClr + DEC EDI + JG @@Variant + JMP @@exit +@@Array: + PUSH EBP + MOV EBP,EDX +@@ArrayLoop: + MOV EDX,[ESI+EBP+2+8] + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV ECX,[ESI+EBP+2+4] + MOV EDX,[EDX] + CALL _FinalizeArray + DEC EDI + JG @@ArrayLoop + POP EBP + JMP @@exit + +@@Record: + PUSH EBP + MOV EBP,EDX +@@RecordLoop: + { inv: EDI = number of array elements to finalize } + + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV EDX,ESI + CALL _FinalizeRecord + DEC EDI + JG @@RecordLoop + POP EBP + JMP @@exit + +@@Interface: + MOV EAX,EBX + ADD EBX,4 + CALL _IntfClear + DEC EDI + JG @@Interface + JMP @@exit + +@@DynArray: + MOV EAX,EBX + MOV EDX,ESI + ADD EBX,4 + CALL _DynArrayClear + DEC EDI + JG @@DynArray + JMP @@exit + +@@error: + POP EDI + POP ESI + POP EBX + POP EAX + MOV AL,reInvalidPtr + JMP Error + +@@exit: + POP EDI + POP ESI + POP EBX + POP EAX +@@zerolength: +end; +{$ENDIF} + +procedure _Finalize(p: Pointer; typeInfo: Pointer); +{$IFDEF PUREPASCAL} +begin + _FinalizeArray(p, typeInfo, 1); +end; +{$ELSE} +asm + MOV ECX,1 + JMP _FinalizeArray +end; +{$ENDIF} + +procedure _AddRefRecord{ p: Pointer; typeInfo: Pointer }; +asm + { -> EAX pointer to record to be referenced } + { EDX pointer to type info } + + XOR ECX,ECX + + PUSH EBX + MOV CL,[EDX+1] + + PUSH ESI + PUSH EDI + + MOV EBX,EAX + LEA ESI,[EDX+ECX+2+8] + MOV EDI,[EDX+ECX+2+4] + +@@loop: + + MOV EDX,[ESI] + MOV EAX,[ESI+4] + ADD EAX,EBX + MOV EDX,[EDX] + MOV ECX, 1 + CALL _AddRefArray + ADD ESI,8 + DEC EDI + JG @@loop + + POP EDI + POP ESI + POP EBX +end; + +procedure _VarAddRef(var v: TVarData); +begin + if Assigned(VarAddRefProc) then + VarAddRefProc(v) + else + Error(reVarInvalidOp); +end; + +procedure _AddRefArray{ p: Pointer; typeInfo: Pointer; elemCount: Longint}; +asm + { -> EAX pointer to data to be referenced } + { EDX pointer to type info describing data } + { ECX number of elements of that type } + + { This code appears to be PIC safe. The functions called from + here either don't make external calls (LStrAddRef, WStrAddRef) or + are Pascal routines that will fix up EBX in their prolog code + (VarAddRef, IntfAddRef). } + + PUSH EBX + PUSH ESI + PUSH EDI + + TEST ECX,ECX + JZ @@exit + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + XOR EDX,EDX + MOV AL,[ESI] + MOV DL,[ESI+1] + + CMP AL,tkLString + JE @@LString + CMP AL,tkWString + JE @@WString + CMP AL,tkVariant + JE @@Variant + CMP AL,tkArray + JE @@Array + CMP AL,tkRecord + JE @@Record + CMP AL,tkInterface + JE @@Interface + CMP AL,tkDynArray + JE @@DynArray + MOV AL,reInvalidPtr + POP EDI + POP ESI + POP EBX + JMP Error + +@@LString: +{$IFDEF LINUX} +@@WString: +{$ENDIF} + MOV EAX,[EBX] + ADD EBX,4 + CALL _LStrAddRef + DEC EDI + JG @@LString + JMP @@exit + +{$IFDEF MSWINDOWS} +@@WString: + MOV EAX,EBX + ADD EBX,4 + CALL _WStrAddRef + DEC EDI + JG @@WString + JMP @@exit +{$ENDIF} +@@Variant: + MOV EAX,EBX + ADD EBX,16 + CALL _VarAddRef + DEC EDI + JG @@Variant + JMP @@exit + +@@Array: + PUSH EBP + MOV EBP,EDX +@@ArrayLoop: + MOV EDX,[ESI+EBP+2+8] + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV ECX,[ESI+EBP+2+4] + MOV EDX,[EDX] + CALL _AddRefArray + DEC EDI + JG @@ArrayLoop + POP EBP + JMP @@exit + +@@Record: + PUSH EBP + MOV EBP,EDX +@@RecordLoop: + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV EDX,ESI + CALL _AddRefRecord + DEC EDI + JG @@RecordLoop + POP EBP + JMP @@exit + +@@Interface: + MOV EAX,[EBX] + ADD EBX,4 + CALL _IntfAddRef + DEC EDI + JG @@Interface + JMP @@exit + +@@DynArray: + MOV EAX,[EBX] + ADD EBX,4 + CALL _DynArrayAddRef + DEC EDI + JG @@DynArray +@@exit: + + POP EDI + POP ESI + POP EBX +end; + + +procedure _AddRef{ p: Pointer; typeInfo: Pointer}; +asm + MOV ECX,1 + JMP _AddRefArray +end; + +procedure _VarCopy(var Dest: TVarData; const Src: TVarData); +begin + if Assigned(VarCopyProc) then + VarCopyProc(Dest, Src) + else + Error(reVarInvalidOp); +end; + +procedure _CopyRecord{ dest, source, typeInfo: Pointer }; +asm + { -> EAX pointer to dest } + { EDX pointer to source } + { ECX pointer to typeInfo } + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBX,EAX + MOV ESI,EDX + + XOR EAX,EAX + MOV AL,[ECX+1] + + LEA EDI,[ECX+EAX+2+8] + MOV EBP,[EDI-4] + XOR EAX,EAX + MOV ECX,[EDI-8] + PUSH ECX +@@loop: + MOV ECX,[EDI+4] + SUB ECX,EAX + JLE @@nomove1 + MOV EDX,EAX + ADD EAX,ESI + ADD EDX,EBX + CALL Move +@@noMove1: + MOV EAX,[EDI+4] + + MOV EDX,[EDI] + MOV EDX,[EDX] + MOV CL,[EDX] + + CMP CL,tkLString + JE @@LString + CMP CL,tkWString + JE @@WString + CMP CL,tkVariant + JE @@Variant + CMP CL,tkArray + JE @@Array + CMP CL,tkRecord + JE @@Record + CMP CL,tkInterface + JE @@Interface + CMP CL,tkDynArray + JE @@DynArray + MOV AL,reInvalidPtr + POP EBP + POP EDI + POP ESI + POP EBX + JMP Error + +@@LString: + MOV EDX,[ESI+EAX] + ADD EAX,EBX + CALL _LStrAsg + MOV EAX,4 + JMP @@common + +@@WString: + MOV EDX,[ESI+EAX] + ADD EAX,EBX + CALL _WStrAsg + MOV EAX,4 + JMP @@common + +@@Variant: + LEA EDX,[ESI+EAX] + ADD EAX,EBX + CALL _VarCopy + MOV EAX,16 + JMP @@common + +@@Array: + XOR ECX,ECX + MOV CL,[EDX+1] + PUSH dword ptr [EDX+ECX+2] + PUSH dword ptr [EDX+ECX+2+4] + MOV ECX,[EDX+ECX+2+8] + MOV ECX,[ECX] + LEA EDX,[ESI+EAX] + ADD EAX,EBX + CALL _CopyArray + POP EAX + JMP @@common + +@@Record: + XOR ECX,ECX + MOV CL,[EDX+1] + MOV ECX,[EDX+ECX+2] + PUSH ECX + MOV ECX,EDX + LEA EDX,[ESI+EAX] + ADD EAX,EBX + CALL _CopyRecord + POP EAX + JMP @@common + +@@Interface: + MOV EDX,[ESI+EAX] + ADD EAX,EBX + CALL _IntfCopy + MOV EAX,4 + JMP @@common + +@@DynArray: + MOV ECX,EDX + MOV EDX,[ESI+EAX] + ADD EAX,EBX + CALL _DynArrayAsg + MOV EAX,4 + +@@common: + ADD EAX,[EDI+4] + ADD EDI,8 + DEC EBP + JNZ @@loop + + POP ECX + SUB ECX,EAX + JLE @@noMove2 + LEA EDX,[EBX+EAX] + ADD EAX,ESI + CALL Move +@@noMove2: + + POP EBP + POP EDI + POP ESI + POP EBX +end; + + +procedure _CopyObject{ dest, source: Pointer; vmtPtrOffs: Longint; typeInfo: Pointer }; +asm + { -> EAX pointer to dest } + { EDX pointer to source } + { ECX offset of vmt in object } + { [ESP+4] pointer to typeInfo } + + ADD ECX,EAX { pointer to dest vmt } + PUSH dword ptr [ECX] { save dest vmt } + PUSH ECX + MOV ECX,[ESP+4+4+4] + CALL _CopyRecord + POP ECX + POP dword ptr [ECX] { restore dest vmt } + RET 4 + +end; + +procedure _CopyArray{ dest, source, typeInfo: Pointer; cnt: Integer }; +asm + { -> EAX pointer to dest } + { EDX pointer to source } + { ECX pointer to typeInfo } + { [ESP+4] count } + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + MOV EBP,[ESP+4+4*4] + + MOV CL,[EDI] + + CMP CL,tkLString + JE @@LString + CMP CL,tkWString + JE @@WString + CMP CL,tkVariant + JE @@Variant + CMP CL,tkArray + JE @@Array + CMP CL,tkRecord + JE @@Record + CMP CL,tkInterface + JE @@Interface + CMP CL,tkDynArray + JE @@DynArray + MOV AL,reInvalidPtr + POP EBP + POP EDI + POP ESI + POP EBX + JMP Error + +@@LString: + MOV EAX,EBX + MOV EDX,[ESI] + CALL _LStrAsg + ADD EBX,4 + ADD ESI,4 + DEC EBP + JNE @@LString + JMP @@exit + +@@WString: + MOV EAX,EBX + MOV EDX,[ESI] + CALL _WStrAsg + ADD EBX,4 + ADD ESI,4 + DEC EBP + JNE @@WString + JMP @@exit + +@@Variant: + MOV EAX,EBX + MOV EDX,ESI + CALL _VarCopy + ADD EBX,16 + ADD ESI,16 + DEC EBP + JNE @@Variant + JMP @@exit + +@@Array: + XOR ECX,ECX + MOV CL,[EDI+1] + LEA EDI,[EDI+ECX+2] +@@ArrayLoop: + MOV EAX,EBX + MOV EDX,ESI + MOV ECX,[EDI+8] + PUSH dword ptr [EDI+4] + CALL _CopyArray + ADD EBX,[EDI] + ADD ESI,[EDI] + DEC EBP + JNE @@ArrayLoop + JMP @@exit + +@@Record: + MOV EAX,EBX + MOV EDX,ESI + MOV ECX,EDI + CALL _CopyRecord + XOR EAX,EAX + MOV AL,[EDI+1] + ADD EBX,[EDI+EAX+2] + ADD ESI,[EDI+EAX+2] + DEC EBP + JNE @@Record + JMP @@exit + +@@Interface: + MOV EAX,EBX + MOV EDX,[ESI] + CALL _IntfCopy + ADD EBX,4 + ADD ESI,4 + DEC EBP + JNE @@Interface + JMP @@exit + +@@DynArray: + MOV EAX,EBX + MOV EDX,[ESI] + MOV ECX,EDI + CALL _DynArrayAsg + ADD EBX,4 + ADD ESI,4 + DEC EBP + JNE @@DynArray + +@@exit: + POP EBP + POP EDI + POP ESI + POP EBX + RET 4 +end; + + +function _New(size: Longint; typeInfo: Pointer): Pointer; +{$IFDEF PUREPASCAL} +begin + GetMem(Result, size); + if Result <> nil then + _Initialize(Result, typeInfo); +end; +{$ELSE} +asm + { -> EAX size of object to allocate } + { EDX pointer to typeInfo } + + PUSH EDX + CALL _GetMem + POP EDX + TEST EAX,EAX + JE @@exit + PUSH EAX + CALL _Initialize + POP EAX +@@exit: +end; +{$ENDIF} + +procedure _Dispose(p: Pointer; typeInfo: Pointer); +{$IFDEF PUREPASCAL} +begin + _Finalize(p, typeinfo); + FreeMem(p); +end; +{$ELSE} +asm + { -> EAX Pointer to object to be disposed } + { EDX Pointer to type info } + + PUSH EAX + CALL _Finalize + POP EAX + CALL _FreeMem +end; +{$ENDIF} + +{ ----------------------------------------------------- } +{ Wide character support } +{ ----------------------------------------------------- } + +function WideCharToString(Source: PWideChar): string; +begin + WideCharToStrVar(Source, Result); +end; + +function WideCharLenToString(Source: PWideChar; SourceLen: Integer): string; +begin + WideCharLenToStrVar(Source, SourceLen, Result); +end; + +procedure WideCharToStrVar(Source: PWideChar; var Dest: string); +begin + _LStrFromPWChar(Dest, Source); +end; + +procedure WideCharLenToStrVar(Source: PWideChar; SourceLen: Integer; + var Dest: string); +begin + _LStrFromPWCharLen(Dest, Source, SourceLen); +end; + +function StringToWideChar(const Source: string; Dest: PWideChar; + DestSize: Integer): PWideChar; +begin + Dest[WCharFromChar(Dest, DestSize - 1, PChar(Source), Length(Source))] := #0; + Result := Dest; +end; + +{ ----------------------------------------------------- } +{ OLE string support } +{ ----------------------------------------------------- } + +function OleStrToString(Source: PWideChar): string; +begin + OleStrToStrVar(Source, Result); +end; + +procedure OleStrToStrVar(Source: PWideChar; var Dest: string); +begin + WideCharLenToStrVar(Source, Length(WideString(Pointer(Source))), Dest); +end; + +function StringToOleStr(const Source: string): PWideChar; +begin + Result := nil; + _WStrFromPCharLen(WideString(Pointer(Result)), PChar(Pointer(Source)), Length(Source)); +end; + +{ ----------------------------------------------------- } +{ Variant manager support (obsolete) } +{ ----------------------------------------------------- } + +procedure GetVariantManager(var VarMgr: TVariantManager); +begin + FillChar(VarMgr, sizeof(VarMgr), 0); +end; + +procedure SetVariantManager(const VarMgr: TVariantManager); +begin +end; + +function IsVariantManagerSet: Boolean; +begin + Result := False; +end; + +procedure _IntfDispCall; +asm +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + POP ECX + LEA EAX,[EAX].OFFSET DispCallByIDProc + MOV EAX,[EAX] + XCHG EAX,[ESP] + RET +{$ELSE} + JMP DispCallByIDProc +{$ENDIF} +end; + +procedure _DispCallByIDError; +asm + MOV AL,reVarDispatch + JMP Error +end; + +procedure _IntfVarCall; +asm +end; + +// 64 bit integer helper routines +// +// These functions always return the 64-bit result in EAX:EDX + +// ------------------------------------------------------------------------------ +// 64-bit signed multiply +// ------------------------------------------------------------------------------ +// +// Param 1(EAX:EDX), Param 2([ESP+8]:[ESP+4]) ; before reg pushing +// + +procedure __llmul; +asm + push edx + push eax + + // Param2 : [ESP+16]:[ESP+12] (hi:lo) + // Param1 : [ESP+4]:[ESP] (hi:lo) + + mov eax, [esp+16] + mul dword ptr [esp] + mov ecx, eax + + mov eax, [esp+4] + mul dword ptr [esp+12] + add ecx, eax + + mov eax, [esp] + mul dword ptr [esp+12] + add edx, ecx + + pop ecx + pop ecx + + ret 8 +end; + +// ------------------------------------------------------------------------------ +// 64-bit signed multiply, with overflow check (98.05.15: overflow not supported yet) +// ------------------------------------------------------------------------------ +// +// Param1 ~= U (Uh, Ul) +// Param2 ~= V (Vh, Vl) +// +// Param 1(EAX:EDX), Param 2([ESP+8]:[ESP+4]) ; before reg pushing +// +// compiler-helper function +// O-flag set on exit => result is invalid +// O-flag clear on exit => result is valid + +procedure __llmulo; +asm + push edx + push eax + + // Param2 : [ESP+16]:[ESP+12] (hi:lo) + // Param1 : [ESP+4]:[ESP] (hi:lo) + + mov eax, [esp+16] + mul dword ptr [esp] + mov ecx, eax + + mov eax, [esp+4] + mul dword ptr [esp+12] + add ecx, eax + + mov eax, [esp] + mul dword ptr [esp+12] + add edx, ecx + + pop ecx + pop ecx + + ret 8 +end; + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * The implementation of function __lldiv is subject to the + * Mozilla Public License Version 1.1 (the "License"); you may + * not use this file except in compliance with the License. + * You may obtain a copy of the License at http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * The Original Code is Fastcode + * + * The Initial Developer of the Original Code is + * Fastcode + * + * Portions created by the Initial Developer are Copyright (C) 2002-2004 + * the Initial Developer. All Rights Reserved. + * + * Contributor(s): AMD, John O'Harrow and Dennis Christensen + * + * ***** END LICENSE BLOCK ***** *) + +// ------------------------------------------------------------------------------ +// 64-bit signed division +// ------------------------------------------------------------------------------ + +// +// Dividend = Numerator, Divisor = Denominator +// +// Dividend(EAX:EDX), Divisor([ESP+8]:[ESP+4]) ; before reg pushing +// +// + +procedure __lldiv; //JOH Version +asm + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX, [ESP+16] + MOV ECX, [ESP+20] + MOV ESI, EDX + MOV EDI, ECX + SAR ESI, 31 + XOR EAX, ESI + XOR EDX, ESI + SUB EAX, ESI + SBB EDX, ESI // EDX:EAX := abs(Dividend) + SAR EDI, 31 + XOR ESI, EDI // 0 if X and Y have same sign + XOR EBX, EDI + XOR ECX, EDI + SUB EBX, EDI + SBB ECX, EDI // ECX:EBX := abs(Divisor) + JNZ @@BigDivisor // divisor > 32^32-1 + CMP EDX, EBX // only one division needed ? (ecx = 0) + JB @@OneDiv // yes, one division sufficient + MOV ECX, EAX // save dividend-lo in ecx + MOV EAX, EDX // get dividend-hi + XOR EDX, EDX // zero extend it into edx:eax + DIV EBX // quotient-hi in eax + XCHG EAX, ECX // ecx = quotient-hi, eax =dividend-lo +@@OneDiv: + DIV EBX // eax = quotient-lo + MOV EDX, ECX // edx = quotient-hi(quotient in edx:eax) + JMP @SetSign +@@BigDivisor: + SUB ESP, 12 // Create three local variables. + MOV [ESP ], EAX // dividend_lo + MOV [ESP+4], EBX // divisor_lo + MOV [ESP+8], EDX // dividend_hi + MOV EDI, ECX // edi:ebx and ecx:esi + SHR EDX, 1 // shift both + RCR EAX, 1 // divisor and + ROR EDI, 1 // and dividend + RCR EBX, 1 // right by 1 bit + BSR ECX, ECX // ecx = number of remaining shifts + SHRD EBX, EDI, CL // scale down divisor and + SHRD EAX, EDX, CL // dividend such that divisor + SHR EDX, CL // less than 2^32 (i.e. fits in ebx) + ROL EDI, 1 // restore original divisor (edi:esi) + DIV EBX // compute quotient + MOV EBX, [ESP] // dividend_lo + MOV ECX, EAX // save quotient + IMUL EDI, EAX // quotient * divisor hi-word (low only) + MUL DWORD PTR [ESP+4] // quotient * divisor low word + ADD EDX, EDI // edx:eax = quotient * divisor + SUB EBX, EAX // dividend-lo - (quot.*divisor)-lo + MOV EAX, ECX // get quotient + MOV ECX, [ESP+8] // dividend_hi + SBB ECX, EDX // subtract divisor * quot. from dividend + SBB EAX, 0 // Adjust quotient if remainder is negative. + XOR EDX, EDX // clear hi-word of quot (eax<=FFFFFFFFh) + ADD ESP, 12 // Remove local variables. +@SetSign: + XOR EAX, ESI // If (quotient < 0), + XOR EDX, ESI // compute 1's complement of result. + SUB EAX, ESI // If (quotient < 0), + SBB EDX, ESI // compute 2's complement of result. +@Done: + POP EDI + POP ESI + POP EBX + RET 8 +end; + +// ------------------------------------------------------------------------------ +// 64-bit signed division with overflow check (98.05.15: not implementated yet) +// ------------------------------------------------------------------------------ + +// +// Dividend = Numerator, Divisor = Denominator +// +// Dividend(EAX:EDX), Divisor([ESP+8]:[ESP+4]) +// Param 1 (EAX:EDX), Param 2([ESP+8]:[ESP+4]) +// +// Param1 ~= U (Uh, Ul) +// Param2 ~= V (Vh, Vl) +// +// compiler-helper function +// O-flag set on exit => result is invalid +// O-flag clear on exit => result is valid +// + +procedure __lldivo; +asm + // check for overflow condition: min(int64) DIV -1 + push esi + mov esi, [esp+12] // Vh + and esi, [esp+8] // Vl + cmp esi, 0ffffffffh // V = -1? + jne @@divok + + mov esi, eax + or esi, edx + cmp esi, 80000000H // U = min(int64)? + jne @@divok + +@@divOvl: + mov eax, esi + pop esi + dec eax // turn on O-flag + ret + +@@divok: + pop esi + push dword ptr [esp+8] // Vh + push dword ptr [esp+8] // Vl (offset is changed from push) + call __lldiv + and eax, eax // turn off O-flag + ret 8 +end; + +// ------------------------------------------------------------------------------ +// 64-bit unsigned division +// ------------------------------------------------------------------------------ + +// Dividend(EAX(hi):EDX(lo)), Divisor([ESP+8](hi):[ESP+4](lo)) // before reg pushing +procedure __lludiv; +asm + push ebp + push ebx + push esi + push edi +// +// Now the stack looks something like this: +// +// 24[esp]: divisor (high dword) +// 20[esp]: divisor (low dword) +// 16[esp]: return EIP +// 12[esp]: previous EBP +// 8[esp]: previous EBX +// 4[esp]: previous ESI +// [esp]: previous EDI +// + +// dividend is pushed last, therefore the first in the args +// divisor next. +// + mov ebx,20[esp] // get the first low word + mov ecx,24[esp] // get the first high word + + or ecx,ecx + jnz @__lludiv@slow_ldiv // both high words are zero + + or edx,edx + jz @__lludiv@quick_ldiv + + or ebx,ebx + jz @__lludiv@quick_ldiv // if ecx:ebx == 0 force a zero divide + // we don't expect this to actually + // work + +@__lludiv@slow_ldiv: + mov ebp,ecx + mov ecx,64 // shift counter + xor edi,edi // fake a 64 bit dividend + xor esi,esi + +@__lludiv@xloop: + shl eax,1 // shift dividend left one bit + rcl edx,1 + rcl esi,1 + rcl edi,1 + cmp edi,ebp // dividend larger? + jb @__lludiv@nosub + ja @__lludiv@subtract + cmp esi,ebx // maybe + jb @__lludiv@nosub + +@__lludiv@subtract: + sub esi,ebx + sbb edi,ebp // subtract the divisor + inc eax // build quotient + +@__lludiv@nosub: + loop @__lludiv@xloop +// +// When done with the loop the four registers values' look like: +// +// | edi | esi | edx | eax | +// | remainder | quotient | +// + +@__lludiv@finish: + pop edi + pop esi + pop ebx + pop ebp + ret 8 + +@__lludiv@quick_ldiv: + div ebx // unsigned divide + xor edx,edx + jmp @__lludiv@finish +end; + +// ------------------------------------------------------------------------------ +// 64-bit modulo +// ------------------------------------------------------------------------------ + +// Dividend(EAX:EDX), Divisor([ESP+8]:[ESP+4]) // before reg pushing +procedure __llmod; +asm + push ebp + push ebx + push esi + push edi + xor edi,edi +// +// dividend is pushed last, therefore the first in the args +// divisor next. +// + mov ebx,20[esp] // get the first low word + mov ecx,24[esp] // get the first high word + or ecx,ecx + jnz @__llmod@slow_ldiv // both high words are zero + + or edx,edx + jz @__llmod@quick_ldiv + + or ebx,ebx + jz @__llmod@quick_ldiv // if ecx:ebx == 0 force a zero divide + // we don't expect this to actually + // work +@__llmod@slow_ldiv: +// +// Signed division should be done. Convert negative +// values to positive and do an unsigned division. +// Store the sign value in the next higher bit of +// di (test mask of 4). Thus when we are done, testing +// that bit will determine the sign of the result. +// + or edx,edx // test sign of dividend + jns @__llmod@onepos + neg edx + neg eax + sbb edx,0 // negate dividend + or edi,1 + +@__llmod@onepos: + or ecx,ecx // test sign of divisor + jns @__llmod@positive + neg ecx + neg ebx + sbb ecx,0 // negate divisor + +@__llmod@positive: + mov ebp,ecx + mov ecx,64 // shift counter + push edi // save the flags +// +// Now the stack looks something like this: +// +// 24[esp]: divisor (high dword) +// 20[esp]: divisor (low dword) +// 16[esp]: return EIP +// 12[esp]: previous EBP +// 8[esp]: previous EBX +// 4[esp]: previous ESI +// [esp]: previous EDI +// + xor edi,edi // fake a 64 bit dividend + xor esi,esi + +@__llmod@xloop: + shl eax,1 // shift dividend left one bit + rcl edx,1 + rcl esi,1 + rcl edi,1 + cmp edi,ebp // dividend larger? + jb @__llmod@nosub + ja @__llmod@subtract + cmp esi,ebx // maybe + jb @__llmod@nosub + +@__llmod@subtract: + sub esi,ebx + sbb edi,ebp // subtract the divisor + inc eax // build quotient + +@__llmod@nosub: + loop @__llmod@xloop +// +// When done with the loop the four registers values' look like: +// +// | edi | esi | edx | eax | +// | remainder | quotient | +// + mov eax,esi + mov edx,edi // use remainder + + pop ebx // get control bits + test ebx,1 // needs negative + jz @__llmod@finish + neg edx + neg eax + sbb edx,0 // negate + +@__llmod@finish: + pop edi + pop esi + pop ebx + pop ebp + ret 8 + +@__llmod@quick_ldiv: + div ebx // unsigned divide + xchg eax,edx + xor edx,edx + jmp @__llmod@finish +end; + +// ------------------------------------------------------------------------------ +// 64-bit signed modulo with overflow (98.05.15: overflow not yet supported) +// ------------------------------------------------------------------------------ + +// Dividend(EAX:EDX), Divisor([ESP+8]:[ESP+4]) +// Param 1 (EAX:EDX), Param 2([ESP+8]:[ESP+4]) +// +// Param1 ~= U (Uh, Ul) +// Param2 ~= V (Vh, Vl) +// +// compiler-helper function +// O-flag set on exit => result is invalid +// O-flag clear on exit => result is valid +// + +procedure __llmodo; +asm + // check for overflow condition: min(int64) MOD -1 + push esi + mov esi, [esp+12] // Vh + and esi, [esp+8] // Vl + cmp esi, 0ffffffffh // V = -1? + jne @@modok + + mov esi, eax + or esi, edx + cmp esi, 80000000H // U = min(int64)? + jne @@modok + +@@modOvl: + mov eax, esi + pop esi + dec eax // turn on O-flag + ret + +@@modok: + pop esi + push dword ptr [esp+8] // Vh + push dword ptr [esp+8] // Vl (offset is changed from push) + call __llmod + and eax, eax // turn off O-flag + ret 8 +end; + +// ------------------------------------------------------------------------------ +// 64-bit unsigned modulo +// ------------------------------------------------------------------------------ +// Dividend(EAX(hi):EDX(lo)), Divisor([ESP+8](hi):[ESP+4](lo)) // before reg pushing + +procedure __llumod; +asm + push ebp + push ebx + push esi + push edi +// +// Now the stack looks something like this: +// +// 24[esp]: divisor (high dword) +// 20[esp]: divisor (low dword) +// 16[esp]: return EIP +// 12[esp]: previous EBP +// 8[esp]: previous EBX +// 4[esp]: previous ESI +// [esp]: previous EDI +// + +// dividend is pushed last, therefore the first in the args +// divisor next. +// + mov ebx,20[esp] // get the first low word + mov ecx,24[esp] // get the first high word + or ecx,ecx + jnz @__llumod@slow_ldiv // both high words are zero + + or edx,edx + jz @__llumod@quick_ldiv + + or ebx,ebx + jz @__llumod@quick_ldiv // if ecx:ebx == 0 force a zero divide + // we don't expect this to actually + // work +@__llumod@slow_ldiv: + mov ebp,ecx + mov ecx,64 // shift counter + xor edi,edi // fake a 64 bit dividend + xor esi,esi // + +@__llumod@xloop: + shl eax,1 // shift dividend left one bit + rcl edx,1 + rcl esi,1 + rcl edi,1 + cmp edi,ebp // dividend larger? + jb @__llumod@nosub + ja @__llumod@subtract + cmp esi,ebx // maybe + jb @__llumod@nosub + +@__llumod@subtract: + sub esi,ebx + sbb edi,ebp // subtract the divisor + inc eax // build quotient + +@__llumod@nosub: + loop @__llumod@xloop +// +// When done with the loop the four registers values' look like: +// +// | edi | esi | edx | eax | +// | remainder | quotient | +// + mov eax,esi + mov edx,edi // use remainder + +@__llumod@finish: + pop edi + pop esi + pop ebx + pop ebp + ret 8 + +@__llumod@quick_ldiv: + div ebx // unsigned divide + xchg eax,edx + xor edx,edx + jmp @__llumod@finish +end; + +// ------------------------------------------------------------------------------ +// 64-bit shift left +// ------------------------------------------------------------------------------ + +// +// target (EAX:EDX) count (ECX) +// +procedure __llshl; +asm + cmp cl, 32 + jl @__llshl@below32 + cmp cl, 64 + jl @__llshl@below64 + xor edx, edx + xor eax, eax + ret + +@__llshl@below64: + mov edx, eax + shl edx, cl + xor eax, eax + ret + +@__llshl@below32: + shld edx, eax, cl + shl eax, cl + ret +end; + +// ------------------------------------------------------------------------------ +// 64-bit signed shift right +// ------------------------------------------------------------------------------ +// target (EAX:EDX) count (ECX) + +procedure __llshr; +asm + cmp cl, 32 + jl @__llshr@below32 + cmp cl, 64 + jl @__llshr@below64 + sar edx, 1fh + mov eax,edx + ret + +@__llshr@below64: + mov eax, edx + cdq + sar eax,cl + ret + +@__llshr@below32: + shrd eax, edx, cl + sar edx, cl + ret +end; + +// ------------------------------------------------------------------------------ +// 64-bit unsigned shift right +// ------------------------------------------------------------------------------ + +// target (EAX:EDX) count (ECX) +procedure __llushr; +asm + cmp cl, 32 + jl @__llushr@below32 + cmp cl, 64 + jl @__llushr@below64 + xor edx, edx + xor eax, eax + ret + +@__llushr@below64: + mov eax, edx + xor edx, edx + shr eax, cl + ret + +@__llushr@below32: + shrd eax, edx, cl + shr edx, cl + ret +end; + +function _StrUInt64Digits(val: UInt64; width: Integer; sign: Boolean): ShortString; +var + d: array[0..31] of Char; { need 19 digits and a sign } + i, k: Integer; + spaces: Integer; +begin + { Produce an ASCII representation of the number in reverse order } + i := 0; + repeat + d[i] := Chr( (val mod 10) + Ord('0') ); + Inc(i); + val := val div 10; + until val = 0; + if sign then + begin + d[i] := '-'; + Inc(i); + end; + + { Fill the Result with the appropriate number of blanks } + if width > 255 then + width := 255; + k := 1; + spaces := width - i; + while k <= spaces do + begin + Result[k] := ' '; + Inc(k); + end; + + { Fill the Result with the number } + while i > 0 do + begin + Dec(i); + Result[k] := d[i]; + Inc(k); + end; + + { Result is k-1 characters long } + SetLength(Result, k-1); +end; + +function _StrInt64(val: Int64; width: Integer): ShortString; +begin + Result := _StrUInt64Digits(Abs(val), width, val < 0); +end; + +function _Str0Int64(val: Int64): ShortString; +begin + Result := _StrInt64(val, 0); +end; + +function _StrUInt64(val: UInt64; width: Integer): ShortString; +begin + Result := _StrUInt64Digits(val, width, False); +end; + +function _Str0UInt64(val: Int64): ShortString; +begin + Result := _StrUInt64(val, 0); +end; + +procedure _WriteInt64; +asm +{ PROCEDURE _WriteInt64( VAR t: Text; val: Int64; with: Longint); } +{ ->EAX Pointer to file record } +{ [ESP+4] Value } +{ EDX Field width } + + SUB ESP,32 { VAR s: String[31]; } + + PUSH EAX + PUSH EDX + + PUSH dword ptr [ESP+8+32+8] { Str( val : 0, s ); } + PUSH dword ptr [ESP+8+32+8] + XOR EAX,EAX + LEA EDX,[ESP+8+8] + CALL _StrInt64 + + POP ECX + POP EAX + + MOV EDX,ESP { Write( t, s : width );} + CALL _WriteString + + ADD ESP,32 + RET 8 +end; + +procedure _Write0Int64; +asm +{ PROCEDURE _Write0Long( VAR t: Text; val: Longint); } +{ ->EAX Pointer to file record } +{ EDX Value } + XOR EDX,EDX + JMP _WriteInt64 +end; + +procedure _WriteUInt64; +asm +{ PROCEDURE _WriteInt64( VAR t: Text; val: Int64; with: Longint); } +{ ->EAX Pointer to file record } +{ [ESP+4] Value } +{ EDX Field width } + + SUB ESP,32 { VAR s: String[31]; } + + PUSH EAX + PUSH EDX + + PUSH dword ptr [ESP+8+32+8] { Str( val : 0, s ); } + PUSH dword ptr [ESP+8+32+8] + XOR EAX,EAX + LEA EDX,[ESP+8+8] + CALL _StrUInt64 + + POP ECX + POP EAX + + MOV EDX,ESP { Write( t, s : width );} + CALL _WriteString + + ADD ESP,32 + RET 8 +end; + +procedure _Write0UInt64; +asm +{ PROCEDURE _Write0Long( VAR t: Text; val: Longint); } +{ ->EAX Pointer to file record } +{ EDX Value } + XOR EDX,EDX + JMP _WriteUInt64 +end; + +procedure _ReadInt64; +asm + // -> EAX Pointer to text record + // <- EAX:EDX Result + + PUSH EBX + PUSH ESI + PUSH EDI + SUB ESP,36 // var numbuf: String[32]; + + MOV ESI,EAX + CALL _SeekEof + DEC AL + JZ @@eof + + MOV EDI,ESP // EDI -> numBuf[0] + MOV BL,32 +@@loop: + MOV EAX,ESI + CALL _ReadChar + CMP AL,' ' + JBE @@endNum + STOSB + DEC BL + JNZ @@loop +@@convert: + MOV byte ptr [EDI],0 + MOV EAX,ESP // EAX -> numBuf + PUSH EDX // allocate code result + MOV EDX,ESP // pass pointer to code + CALL _ValInt64 // convert + POP ECX // pop code result into EDX + TEST ECX,ECX + JZ @@exit + MOV EAX,106 + CALL SetInOutRes + +@@exit: + ADD ESP,36 + POP EDI + POP ESI + POP EBX + RET + +@@endNum: + CMP AH,cEof + JE @@convert + DEC [ESI].TTextRec.BufPos + JMP @@convert + +@@eof: + XOR EAX,EAX + JMP @@exit +end; + +function _ValInt64(const s: AnsiString; var code: Integer): Int64; +var + i: Integer; + dig: Integer; + sign: Boolean; + empty: Boolean; +begin + i := 1; + dig := 0; + Result := 0; + if s = '' then + begin + code := i; + exit; + end; + while s[i] = ' ' do + Inc(i); + sign := False; + if s[i] = '-' then + begin + sign := True; + Inc(i); + end + else if s[i] = '+' then + Inc(i); + empty := True; + if (s[i] = '$') or (Upcase(s[i]) = 'X') + or ((s[i] = '0') and (Upcase(s[i+1]) = 'X')) then + begin + if s[i] = '0' then + Inc(i); + Inc(i); + while True do + begin + case s[i] of + '0'..'9': dig := Ord(s[i]) - Ord('0'); + 'A'..'F': dig := Ord(s[i]) - (Ord('A') - 10); + 'a'..'f': dig := Ord(s[i]) - (Ord('a') - 10); + else + break; + end; + if (Result < 0) or (Result > (High(Int64) shr 3)) then + Break; + Result := Result shl 4 + dig; + Inc(i); + empty := False; + end; + if sign then + Result := - Result; + end + else + begin + while True do + begin + case s[i] of + '0'..'9': dig := Ord(s[i]) - Ord('0'); + else + break; + end; + if (Result < 0) or (Result > (High(Int64) div 10)) then + break; + Result := Result*10 + dig; + Inc(i); + empty := False; + end; + if sign then + Result := - Result; + if (Result <> 0) and (sign <> (Result < 0)) then + Dec(i); + end; + if (s[i] <> #0) or empty then + code := i + else + code := 0; +end; + +procedure _DynArrayLength; +asm +{ FUNCTION _DynArrayLength(const a: array of ...): Longint; } +{ ->EAX Pointer to array or nil } +{ <-EAX High bound of array + 1 or 0 } + TEST EAX,EAX + JZ @@skip + MOV EAX,[EAX-4] +@@skip: +end; + +procedure _DynArrayHigh; +asm +{ FUNCTION _DynArrayHigh(const a: array of ...): Longint; } +{ ->EAX Pointer to array or nil } +{ <-EAX High bound of array or -1 } + CALL _DynArrayLength + DEC EAX +end; + +procedure CopyArray(dest, source, typeInfo: Pointer; cnt: Integer); +asm + PUSH dword ptr [EBP+8] + CALL _CopyArray +end; + +procedure FinalizeArray(p, typeInfo: Pointer; cnt: Integer); +asm + JMP _FinalizeArray +end; + +procedure DynArrayClear(var a: Pointer; typeInfo: Pointer); +asm + CALL _DynArrayClear +end; + +procedure DynArraySetLength(var a: Pointer; typeInfo: Pointer; dimCnt: Longint; lengthVec: PLongint); +var + i: Integer; + newLength, oldLength, minLength: Longint; + elSize: Longint; + neededSize: Longint; + p, pp: Pointer; +begin + p := a; + + // Fetch the new length of the array in this dimension, and the old length + newLength := PLongint(lengthVec)^; + if newLength <= 0 then + begin + if newLength < 0 then + Error(reRangeError); + DynArrayClear(a, typeInfo); + exit; + end; + + oldLength := 0; + if p <> nil then + begin + Dec(PLongint(p)); + oldLength := PLongint(p)^; + Dec(PLongint(p)); + end; + + // Calculate the needed size of the heap object + Inc(PChar(typeInfo), Length(PDynArrayTypeInfo(typeInfo).name)); + elSize := PDynArrayTypeInfo(typeInfo).elSize; + if PDynArrayTypeInfo(typeInfo).elType <> nil then + typeInfo := PDynArrayTypeInfo(typeInfo).elType^ + else + typeInfo := nil; + neededSize := newLength*elSize; + if neededSize div newLength <> elSize then + Error(reRangeError); + Inc(neededSize, Sizeof(Longint)*2); + + // If the heap object isn't shared (ref count = 1), just resize it. Otherwise, we make a copy + if (p = nil) or (PLongint(p)^ = 1) then + begin + pp := p; + if (newLength < oldLength) and (typeInfo <> nil) then + FinalizeArray(PChar(p) + Sizeof(Longint)*2 + newLength*elSize, typeInfo, oldLength - newLength); + ReallocMem(pp, neededSize); + p := pp; + end + else + begin + Dec(PLongint(p)^); + GetMem(p, neededSize); + minLength := oldLength; + if minLength > newLength then + minLength := newLength; + if typeInfo <> nil then + begin + FillChar((PChar(p) + Sizeof(Longint)*2)^, minLength*elSize, 0); + CopyArray(PChar(p) + Sizeof(Longint)*2, a, typeInfo, minLength) + end + else + Move(PChar(a)^, (PChar(p) + Sizeof(Longint)*2)^, minLength*elSize); + end; + + // The heap object will now have a ref count of 1 and the new length + PLongint(p)^ := 1; + Inc(PLongint(p)); + PLongint(p)^ := newLength; + Inc(PLongint(p)); + + // Set the new memory to all zero bits + FillChar((PChar(p) + elSize * oldLength)^, elSize * (newLength - oldLength), 0); + + // Take care of the inner dimensions, if any + if dimCnt > 1 then + begin + Inc(lengthVec); + Dec(dimCnt); + for i := 0 to newLength-1 do + DynArraySetLength(PPointerArray(p)[i], typeInfo, dimCnt, lengthVec); + end; + a := p; +end; + +procedure _DynArraySetLength; +asm +{ PROCEDURE _DynArraySetLength(var a: dynarray; typeInfo: PDynArrayTypeInfo; dimCnt: Longint; lengthVec: ^Longint) } +{ ->EAX Pointer to dynamic array (= pointer to pointer to heap object) } +{ EDX Pointer to type info for the dynamic array } +{ ECX number of dimensions } +{ [ESP+4] dimensions } + PUSH ESP + ADD dword ptr [ESP],4 + CALL DynArraySetLength +end; + +procedure _DynArrayCopy(a: Pointer; typeInfo: Pointer; var Result: Pointer); +begin + if a <> nil then + _DynArrayCopyRange(a, typeInfo, 0, PLongint(PChar(a)-4)^, Result) + else + _DynArrayClear(Result, typeInfo); +end; + +procedure _DynArrayCopyRange(a: Pointer; typeInfo: Pointer; index, count : Integer; var Result: Pointer); +var + arrayLength: Integer; + elSize: Integer; + typeInf: PDynArrayTypeInfo; + p: Pointer; +begin + p := nil; + if a <> nil then + begin + typeInf := typeInfo; + + // Limit index and count to values within the array + if index < 0 then + begin + Inc(count, index); + index := 0; + end; + arrayLength := PLongint(PChar(a)-4)^; + if index > arrayLength then + index := arrayLength; + if count > arrayLength - index then + count := arrayLength - index; + if count < 0 then + count := 0; + + if count > 0 then + begin + // Figure out the size and type descriptor of the element type + Inc(PChar(typeInf), Length(typeInf.name)); + elSize := typeInf.elSize; + if typeInf.elType <> nil then + typeInf := typeInf.elType^ + else + typeInf := nil; + + // Allocate the amount of memory needed + GetMem(p, count*elSize + Sizeof(Longint)*2); + + // The reference count of the new array is 1, the length is count + PLongint(p)^ := 1; + Inc(PLongint(p)); + PLongint(p)^ := count; + Inc(PLongint(p)); + Inc(PChar(a), index*elSize); + + // If the element type needs destruction, we must copy each element, + // otherwise we can just copy the bits + if count > 0 then + begin + if typeInf <> nil then + begin + FillChar(p^, count*elSize, 0); + CopyArray(p, a, typeInf, count) + end + else + Move(a^, p^, count*elSize); + end; + end; + end; + DynArrayClear(Result, typeInfo); + Result := p; +end; + +procedure _DynArrayClear; +asm +{ ->EAX Pointer to dynamic array (Pointer to pointer to heap object } +{ EDX Pointer to type info } + + { Nothing to do if Pointer to heap object is nil } + MOV ECX,[EAX] + TEST ECX,ECX + JE @@exit + + { Set the variable to be finalized to nil } + MOV dword ptr [EAX],0 + + { Decrement ref count. Nothing to do if not zero now. } + LOCK DEC dword ptr [ECX-8] + JNE @@exit + + { Save the source - we're supposed to return it } + PUSH EAX + MOV EAX,ECX + + { Fetch the type descriptor of the elements } + XOR ECX,ECX + MOV CL,[EDX].TDynArrayTypeInfo.name; + MOV EDX,[EDX+ECX].TDynArrayTypeInfo.elType; + + { If it's non-nil, finalize the elements } + TEST EDX,EDX + JE @@noFinalize + MOV ECX,[EAX-4] + TEST ECX,ECX + JE @@noFinalize + MOV EDX,[EDX] + CALL _FinalizeArray +@@noFinalize: + { Now deallocate the array } + SUB EAX,8 + CALL _FreeMem + POP EAX +@@exit: +end; + + +procedure _DynArrayAsg; +asm +{ ->EAX Pointer to destination (pointer to pointer to heap object } +{ EDX source (pointer to heap object } +{ ECX Pointer to rtti describing dynamic array } + + PUSH EBX + MOV EBX,[EAX] + + { Increment ref count of source if non-nil } + + TEST EDX,EDX + JE @@skipInc + LOCK INC dword ptr [EDX-8] +@@skipInc: + { Dec ref count of destination - if it becomes 0, clear dest } + TEST EBX,EBX + JE @@skipClear + LOCK DEC dword ptr[EBX-8] + JNZ @@skipClear + PUSH EAX + PUSH EDX + MOV EDX,ECX + INC dword ptr[EBX-8] + CALL _DynArrayClear + POP EDX + POP EAX +@@skipClear: + { Finally store source into destination } + MOV [EAX],EDX + + POP EBX +end; + +procedure _DynArrayAddRef; +asm +{ ->EAX Pointer to heap object } + TEST EAX,EAX + JE @@exit + LOCK INC dword ptr [EAX-8] +@@exit: +end; + + +function DynArrayIndex(const P: Pointer; const Indices: array of Integer; const TypInfo: Pointer): Pointer; +asm + { ->EAX P } + { EDX Pointer to Indices } + { ECX High bound of Indices } + { [EBP+8] TypInfo } + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV ESI,EDX + MOV EDI,[EBP+8] + MOV EBP,EAX + + XOR EBX,EBX { for i := 0 to High(Indices) do } + TEST ECX,ECX + JGE @@start +@@loop: + MOV EBP,[EBP] +@@start: + XOR EAX,EAX + MOV AL,[EDI].TDynArrayTypeInfo.name + ADD EDI,EAX + MOV EAX,[ESI+EBX*4] { P := P + Indices[i]*TypInfo.elSize } + MUL [EDI].TDynArrayTypeInfo.elSize + MOV EDI,[EDI].TDynArrayTypeInfo.elType + TEST EDI,EDI + JE @@skip + MOV EDI,[EDI] +@@skip: + ADD EBP,EAX + INC EBX + CMP EBX,ECX + JLE @@loop + +@@loopEnd: + + MOV EAX,EBP + + POP EBP + POP EDI + POP ESI + POP EBX +end; + + +{ Returns the DynArrayTypeInfo of the Element Type of the specified DynArrayTypeInfo } +function DynArrayElTypeInfo(typeInfo: PDynArrayTypeInfo): PDynArrayTypeInfo; +begin + Result := nil; + if typeInfo <> nil then + begin + Inc(PChar(typeInfo), Length(typeInfo.name)); + if typeInfo.elType <> nil then + Result := typeInfo.elType^; + end; +end; + +{ Returns # of dimemsions of the DynArray described by the specified DynArrayTypeInfo} +function DynArrayDim(typeInfo: PDynArrayTypeInfo): Integer; +begin + Result := 0; + while (typeInfo <> nil) and (typeInfo.kind = tkDynArray) do + begin + Inc(Result); + typeInfo := DynArrayElTypeInfo(typeInfo); + end; +end; + +{ Returns size of the Dynamic Array} +function DynArraySize(a: Pointer): Integer; +asm + TEST EAX, EAX + JZ @@exit + MOV EAX, [EAX-4] +@@exit: +end; + +// Returns whether array is rectangular +function IsDynArrayRectangular(const DynArray: Pointer; typeInfo: PDynArrayTypeInfo): Boolean; +var + Dim, I, J, Size, SubSize: Integer; + P: Pointer; +begin + // Assume we have a rectangular array + Result := True; + + P := DynArray; + Dim := DynArrayDim(typeInfo); + + {NOTE: Start at 1. Don't need to test the first dimension - it's rectangular by definition} + for I := 1 to dim-1 do + begin + if P <> nil then + begin + { Get size of this dimension } + Size := DynArraySize(P); + + { Get Size of first sub. dimension } + SubSize := DynArraySize(PPointerArray(P)[0]); + + { Walk through every dimension making sure they all have the same size} + for J := 1 to Size-1 do + if DynArraySize(PPointerArray(P)[J]) <> SubSize then + begin + Result := False; + Exit; + end; + + { Point to next dimension} + P := PPointerArray(P)[0]; + end; + end; +end; + +// Returns Bounds of Dynamic array as an array of integer containing the 'high' of each dimension +function DynArrayBounds(const DynArray: Pointer; typeInfo: PDynArrayTypeInfo): TBoundArray; +var + Dim, I: Integer; + P: Pointer; +begin + P := DynArray; + + Dim := DynArrayDim(typeInfo); + SetLength(Result, Dim); + + for I := 0 to dim-1 do + if P <> nil then + begin + Result[I] := DynArraySize(P)-1; + P := PPointerArray(P)[0]; // Assume rectangular arrays + end; +end; + +{ Decrements to next lower index - Returns True if successful } +{ Indices: Indices to be decremented } +{ Bounds : High bounds of each dimension } +function DecIndices(var Indices: TBoundArray; const Bounds: TBoundArray): Boolean; +var + I, J: Integer; +begin + { Find out if we're done: all at zeroes } + Result := False; + for I := Low(Indices) to High(Indices) do + if Indices[I] <> 0 then + begin + Result := True; + break; + end; + if not Result then + Exit; + + { Two arrays must be of same length } + Assert(Length(Indices) = Length(Bounds)); + + { Find index of item to tweak } + for I := High(Indices) downto Low(Bounds) do + begin + // If not reach zero, dec and bail out + if Indices[I] <> 0 then + begin + Dec(Indices[I]); + Exit; + end + else + begin + J := I; + while Indices[J] = 0 do + begin + // Restore high bound when we've reached zero on a particular dimension + Indices[J] := Bounds[J]; + // Move to higher dimension + Dec(J); + Assert(J >= 0); + end; + Dec(Indices[J]); + Exit; + end; + end; +end; + +{ Package/Module registration/unregistration } + +{$IFDEF MSWINDOWS} +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 +{$ENDIF} + +function FindModule(Instance: LongWord): PLibModule; +begin + Result := LibModuleList; + while Result <> nil do + begin + if (Instance = Result.Instance) or + (Instance = Result.CodeInstance) or + (Instance = Result.DataInstance) or + (Instance = Result.ResInstance) then + Exit; + Result := Result.Next; + end; +end; + +function FindHInstance(Address: Pointer): LongWord; +{$IFDEF MSWINDOWS} +var + MemInfo: TMemInfo; +begin + VirtualQuery(Address, MemInfo, SizeOf(MemInfo)); + if MemInfo.State = $1000{MEM_COMMIT} then + Result := LongWord(MemInfo.AllocationBase) + else + Result := 0; +end; +{$ENDIF} +{$IFDEF LINUX} +var + Info: TDLInfo; +begin + if (dladdr(Address, Info) = 0) or (Info.BaseAddress = ExeBaseAddress) then + Info.Filename := nil; // if it's not in a library, assume the exe + Result := LongWord(dlopen(Info.Filename, RTLD_LAZY)); + if Result <> 0 then + dlclose(Result); +end; +{$ENDIF} + +function FindClassHInstance(ClassType: TClass): LongWord; +begin + Result := FindHInstance(Pointer(ClassType)); +end; + +{$IFDEF LINUX} +function GetModuleFileName(Module: HMODULE; Buffer: PChar; BufLen: Integer): Integer; +var + Addr: Pointer; + Info: TDLInfo; + FoundInModule: HMODULE; + Temp: Integer; +begin + Result := 0; + if BufLen <= 0 then Exit; + if (Module = MainInstance) or (Module = 0) then + begin + // First, try the dlsym approach. + // dladdr fails to return the name of the main executable + // in glibc prior to 2.1.91 + +{ Look for a dynamic symbol exported from this program. + _DYNAMIC is not required in a main program file. + If the main program is compiled with Delphi, it will always + have a resource section, named @Sysinit@ResSym. + If the main program is not compiled with Delphi, dlsym + will search the global name space, potentially returning + the address of a symbol in some other shared object library + loaded by the program. To guard against that, we check + that the address of the symbol found is within the + main program address range. } + + dlerror; // clear error state; dlsym doesn't + Addr := dlsym(Module, '@Sysinit@ResSym'); + if (Addr <> nil) and (dlerror = nil) + and (dladdr(Addr, Info) <> 0) + and (Info.FileName <> nil) + and (Info.BaseAddress = ExeBaseAddress) then + begin + Result := _strlen(Info.FileName); + if Result >= BufLen then Result := BufLen-1; + + // dlinfo may not give a full path. Compare to /proc/self/exe, + // take longest result. + Temp := _readlink('/proc/self/exe', Buffer, BufLen); + if Temp >= BufLen then Temp := BufLen-1; + if Temp > Result then + Result := Temp + else + Move(Info.FileName^, Buffer^, Result); + Buffer[Result] := #0; + Exit; + end; + + // Try inspecting the /proc/ virtual file system + // to find the program filename in the process info + Result := _readlink('/proc/self/exe', Buffer, BufLen); + if Result <> -1 then + begin + if Result >= BufLen then Result := BufLen-1; + Buffer[Result] := #0; + end; +{$IFDEF AllowParamStrModuleName} +{ Using ParamStr(0) to obtain a module name presents a potential + security hole. Resource modules are loaded based upon the filename + of a given module. We use dlopen() to load resource modules, which + means the .init code of the resource module will be executed. + Normally, resource modules contain no code at all - they're just + carriers of resource data. + An unpriviledged user program could launch our trusted, + priviledged program with a bogus parameter list, tricking us + into loading a module that contains malicious code in its + .init section. + Without this ParamStr(0) section, GetModuleFilename cannot be + misdirected by unpriviledged code (unless the system program loader + or the /proc file system or system root directory has been compromised). + Resource modules are always loaded from the same directory as the + given module. Trusted code (programs, packages, and libraries) + should reside in directories that unpriviledged code cannot alter. + + If you need GetModuleFilename to have a chance of working on systems + where glibc < 2.1.91 and /proc is not available, and your + program will not run as a priviledged user (or you don't care), + you can define AllowParamStrModuleNames and rebuild the System unit + and baseCLX package. Note that even with ParamStr(0) support + enabled, GetModuleFilename can still fail to find the name of + a module. C'est la Unix. } + + if Result = -1 then // couldn't access the /proc filesystem + begin // return less accurate ParamStr(0) + +{ ParamStr(0) returns the name of the link used + to launch the app, not the name of the app itself. + Also, if this app was launched by some other program, + there is no guarantee that the launching program has set + up our environment at all. (example: Apache CGI) } + + if (ArgValues = nil) or (ArgValues^ = nil) or + (PCharArray(ArgValues^)[0] = nil) then + begin + Result := 0; + Exit; + end; + Result := _strlen(PCharArray(ArgValues^)[0]); + if Result >= BufLen then Result := BufLen-1; + Move(PCharArray(ArgValues^)[0]^, Buffer^, Result); + Buffer[Result] := #0; + end; +{$ENDIF} + end + else + begin +{ For shared object libraries, we can rely on the dlsym technique. + Look for a dynamic symbol in the requested module. + Don't assume the module was compiled with Delphi. + We look for a dynamic symbol with the name _DYNAMIC. This + exists in all ELF shared object libraries that export + or import symbols; If someone has a shared object library that + contains no imports or exports of any kind, this will probably fail. + If dlsym can't find the requested symbol in the given module, it + will search the global namespace and could return the address + of a symbol from some other module that happens to be loaded + into this process. That would be bad, so we double check + that the module handle of the symbol found matches the + module handle we asked about.} + + dlerror; // clear error state; dlsym doesn't + Addr := dlsym(Module, '_DYNAMIC'); + if (Addr <> nil) and (dlerror = nil) + and (dladdr(Addr, Info) <> 0) then + begin + if Info.BaseAddress = ExeBaseAddress then + Info.FileName := nil; + FoundInModule := HMODULE(dlopen(Info.FileName, RTLD_LAZY)); + if FoundInModule <> 0 then + dlclose(FoundInModule); + if Module = FoundInModule then + begin + if Assigned(Info.FileName) then + begin + Result := _strlen(Info.FileName); + if Result >= BufLen then Result := BufLen-1; + Move(Info.FileName^, Buffer^, Result); + end + else + Result := 0; + Buffer[Result] := #0; + end; + end; + end; + if Result < 0 then Result := 0; +end; +{$ENDIF} + +function DelayLoadResourceModule(Module: PLibModule): LongWord; +var + FileName: array[0..MAX_PATH] of Char; +begin + if Module.ResInstance = 0 then + begin + GetModuleFileName(Module.Instance, FileName, SizeOf(FileName)); + Module.ResInstance := LoadResourceModule(FileName); + if Module.ResInstance = 0 then + Module.ResInstance := Module.Instance; + end; + Result := Module.ResInstance; +end; + +function FindResourceHInstance(Instance: LongWord): LongWord; +var + CurModule: PLibModule; +begin + CurModule := LibModuleList; + while CurModule <> nil do + begin + if (Instance = CurModule.Instance) or + (Instance = CurModule.CodeInstance) or + (Instance = CurModule.DataInstance) then + begin + Result := DelayLoadResourceModule(CurModule); + Exit; + end; + CurModule := CurModule.Next; + end; + Result := Instance; +end; + +function LoadResourceModule(ModuleName: PChar; CheckOwner: Boolean): LongWord; +{$IFDEF LINUX} +var + FileName: array [0..MAX_PATH] of Char; + LangCode: PChar; // Language and country code. Example: en_US + P: PChar; + ModuleNameLen, FileNameLen, i: Integer; + st1, st2: TStatStruct; +begin + LangCode := __getenv('LANG'); + Result := 0; + if (LangCode = nil) or (LangCode^ = #0) or (ModuleName = nil) then Exit; + + // look for modulename.en_US (ignoring codeset and modifier suffixes) + P := LangCode; + while P^ in ['a'..'z', 'A'..'Z', '_'] do + Inc(P); + if P = LangCode then Exit; + + if CheckOwner and (__xstat(STAT_VER_LINUX, ModuleName, st1) = -1) then + Exit; + + ModuleNameLen := _strlen(ModuleName); + if (ModuleNameLen + P - LangCode) >= MAX_PATH then Exit; + Move(ModuleName[0], Filename[0], ModuleNameLen); + Filename[ModuleNameLen] := '.'; + Move(LangCode[0], Filename[ModuleNameLen + 1], P - LangCode); + FileNameLen := ModuleNameLen + 1 + (P - LangCode); + Filename[FileNameLen] := #0; + +{ Security check: make sure the user id (owner) and group id of + the base module matches the user id and group id of the resource + module we're considering loading. This is to prevent loading + of malicious code dropped into the base module's directory by + a hostile user. The app and all its resource modules must + have the same owner and group. To disable this security check, + call this function with CheckOwner set to False. } + + if (not CheckOwner) or + ((__xstat(STAT_VER_LINUX, FileName, st2) <> -1) + and (st1.st_uid = st2.st_uid) + and (st1.st_gid = st2.st_gid)) then + begin + Result := dlopen(Filename, RTLD_LAZY); + if Result <> 0 then Exit; + end; + + // look for modulename.en (ignoring country code and suffixes) + i := ModuleNameLen + 1; + while (i <= FileNameLen) and (Filename[i] in ['a'..'z', 'A'..'Z']) do + Inc(i); + if (i = ModuleNameLen + 1) or (i > FileNameLen) then Exit; + FileName[i] := #0; + + { Security check. See notes above. } + if (not CheckOwner) or + ((__xstat(STAT_VER_LINUX, FileName, st2) <> -1) + and (st1.st_uid = st2.st_uid) + and (st1.st_gid = st2.st_gid)) then + begin + Result := dlopen(FileName, RTLD_LAZY); + end; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +var + FileName: array[0..MAX_PATH] of Char; + Key: LongWord; + LocaleName, LocaleOverride: array[0..4] of Char; + Size: Integer; + P: PChar; + + function FindBS(Current: PChar): PChar; + begin + Result := Current; + while (Result^ <> #0) and (Result^ <> '\') do + Result := CharNext(Result); + end; + + function ToLongPath(AFileName: PChar; BufSize: Integer): PChar; + var + CurrBS, NextBS: PChar; + Handle, L: Integer; + FindData: TWin32FindData; + Buffer: array[0..MAX_PATH] of Char; + GetLongPathName: function (ShortPathName: PChar; LongPathName: PChar; + cchBuffer: Integer): Integer stdcall; + begin + Result := AFileName; + Handle := GetModuleHandle(kernel); + if Handle <> 0 then + begin + @GetLongPathName := GetProcAddress(Handle, 'GetLongPathNameA'); + if Assigned(GetLongPathName) and + (GetLongPathName(AFileName, Buffer, SizeOf(Buffer)) <> 0) then + begin + lstrcpyn(AFileName, Buffer, BufSize); + Exit; + end; + end; + + if AFileName[0] = '\' then + begin + if AFileName[1] <> '\' then Exit; + CurrBS := FindBS(AFileName + 2); // skip server name + if CurrBS^ = #0 then Exit; + CurrBS := FindBS(CurrBS + 1); // skip share name + if CurrBS^ = #0 then Exit; + end else + CurrBS := AFileName + 2; // skip drive name + + L := CurrBS - AFileName; + lstrcpyn(Buffer, AFileName, L + 1); + while CurrBS^ <> #0 do + begin + NextBS := FindBS(CurrBS + 1); + if L + (NextBS - CurrBS) + 1 > SizeOf(Buffer) then Exit; + lstrcpyn(Buffer + L, CurrBS, (NextBS - CurrBS) + 1); + + Handle := FindFirstFile(Buffer, FindData); + if (Handle = -1) then Exit; + FindClose(Handle); + + if L + 1 + _strlen(FindData.cFileName) + 1 > SizeOf(Buffer) then Exit; + Buffer[L] := '\'; + lstrcpyn(Buffer + L + 1, FindData.cFileName, Sizeof(Buffer) - L - 1); + Inc(L, _strlen(FindData.cFileName) + 1); + CurrBS := NextBS; + end; + lstrcpyn(AFileName, Buffer, BufSize); + end; +begin + GetModuleFileName(0, FileName, SizeOf(FileName)); // Get host application name + LocaleOverride[0] := #0; + if (RegOpenKeyEx(HKEY_CURRENT_USER, NewLocaleOverrideKey, 0, KEY_READ, Key) = 0) or + (RegOpenKeyEx(HKEY_LOCAL_MACHINE, NewLocaleOverrideKey, 0, KEY_READ, Key) = 0) or + (RegOpenKeyEx(HKEY_CURRENT_USER, OldLocaleOverrideKey, 0, KEY_READ, Key) = 0) then + try + Size := sizeof(LocaleOverride); + ToLongPath(FileName, sizeof(FileName)); + if RegQueryValueEx(Key, FileName, nil, nil, LocaleOverride, @Size) <> 0 then + if RegQueryValueEx(Key, '', nil, nil, LocaleOverride, @Size) <> 0 then + LocaleOverride[0] := #0; + LocaleOverride[sizeof(LocaleOverride)-1] := #0; + finally + RegCloseKey(Key); + end; + lstrcpyn(FileName, ModuleName, sizeof(FileName)); + GetLocaleInfo(GetThreadLocale, LOCALE_SABBREVLANGNAME, LocaleName, sizeof(LocaleName)); + Result := 0; + if (FileName[0] <> #0) and ((LocaleName[0] <> #0) or (LocaleOverride[0] <> #0)) then + begin + P := PChar(@FileName) + _strlen(FileName); + while (P^ <> '.') and (P <> @FileName) do Dec(P); + if P <> @FileName then + begin + Inc(P); + // First look for a locale registry override + if LocaleOverride[0] <> #0 then + begin + lstrcpyn(P, LocaleOverride, sizeof(FileName) - (P - FileName)); + Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE); + end; + if (Result = 0) and (LocaleName[0] <> #0) then + begin + // Then look for a potential language/country translation + lstrcpyn(P, LocaleName, sizeof(FileName) - (P - FileName)); + Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE); + if Result = 0 then + begin + // Finally look for a language only translation + LocaleName[2] := #0; + lstrcpyn(P, LocaleName, sizeof(FileName) - (P - FileName)); + Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE); + end; + end; + end; + end; +end; +{$ENDIF} + +procedure EnumModules(Func: TEnumModuleFunc; Data: Pointer); assembler; +begin + EnumModules(TEnumModuleFuncLW(Func), Data); +end; + +procedure EnumResourceModules(Func: TEnumModuleFunc; Data: Pointer); +begin + EnumResourceModules(TEnumModuleFuncLW(Func), Data); +end; + +procedure EnumModules(Func: TEnumModuleFuncLW; Data: Pointer); +var + CurModule: PLibModule; +begin + CurModule := LibModuleList; + while CurModule <> nil do + begin + if not Func(CurModule.Instance, Data) then Exit; + CurModule := CurModule.Next; + end; +end; + +procedure EnumResourceModules(Func: TEnumModuleFuncLW; Data: Pointer); +var + CurModule: PLibModule; +begin + CurModule := LibModuleList; + while CurModule <> nil do + begin + if not Func(DelayLoadResourceModule(CurModule), Data) then Exit; + CurModule := CurModule.Next; + end; +end; + +procedure AddModuleUnloadProc(Proc: TModuleUnloadProc); +begin + AddModuleUnloadProc(TModuleUnloadProcLW(Proc)); +end; + +procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProc); +begin + RemoveModuleUnloadProc(TModuleUnloadProcLW(Proc)); +end; + +procedure AddModuleUnloadProc(Proc: TModuleUnloadProcLW); +var + P: PModuleUnloadRec; +begin + New(P); + P.Next := ModuleUnloadList; + @P.Proc := @Proc; + ModuleUnloadList := P; +end; + +procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProcLW); +var + P, C: PModuleUnloadRec; +begin + P := ModuleUnloadList; + if (P <> nil) and (@P.Proc = @Proc) then + begin + ModuleUnloadList := ModuleUnloadList.Next; + Dispose(P); + end else + begin + C := P; + while C <> nil do + begin + if (C.Next <> nil) and (@C.Next.Proc = @Proc) then + begin + P := C.Next; + C.Next := C.Next.Next; + Dispose(P); + Break; + end; + C := C.Next; + end; + end; +end; + +procedure NotifyModuleUnload(HInstance: LongWord); +var + P: PModuleUnloadRec; +begin + P := ModuleUnloadList; + while P <> nil do + begin + try + P.Proc(HInstance); + except + // Make sure it doesn't stop notifications + end; + P := P.Next; + end; +{$IFDEF LINUX} + InvalidateModuleCache; +{$ENDIF} +end; + +procedure RegisterModule(LibModule: PLibModule); +begin + LibModule.Next := LibModuleList; + LibModuleList := LibModule; +end; + +procedure UnregisterModule(LibModule: PLibModule); +var + CurModule: PLibModule; +begin + try + NotifyModuleUnload(LibModule.Instance); + finally + if LibModule = LibModuleList then + LibModuleList := LibModule.Next + else + begin + CurModule := LibModuleList; + while CurModule <> nil do + begin + if CurModule.Next = LibModule then + begin + CurModule.Next := LibModule.Next; + Break; + end; + CurModule := CurModule.Next; + end; + end; + end; +end; + +function _IntfClear(var Dest: IInterface): Pointer; +{$IFDEF PUREPASCAL} +var + P: Pointer; +begin + Result := @Dest; + if Dest <> nil then + begin + P := Pointer(Dest); + Pointer(Dest) := nil; + IInterface(P)._Release; + end; +end; +{$ELSE} +asm + MOV EDX,[EAX] + TEST EDX,EDX + JE @@1 + MOV DWORD PTR [EAX],0 + PUSH EAX + PUSH EDX + MOV EAX,[EDX] + CALL DWORD PTR [EAX] + VMTOFFSET IInterface._Release + POP EAX +@@1: +end; +{$ENDIF} + +procedure _IntfCopy(var Dest: IInterface; const Source: IInterface); +{$IFDEF PUREPASCAL} +var + P: Pointer; +begin + P := Pointer(Dest); + if Source <> nil then + Source._AddRef; + Pointer(Dest) := Pointer(Source); + if P <> nil then + IInterface(P)._Release; +end; +{$ELSE} +asm +{ + The most common case is the single assignment of a non-nil interface + to a nil interface. So we streamline that case here. After this, + we give essentially equal weight to other outcomes. + + The semantics are: The source intf must be addrefed *before* it + is assigned to the destination. The old intf must be released + after the new intf is addrefed to support self assignment (I := I). + Either intf can be nil. The first requirement is really to make an + error case function a little better, and to improve the behaviour + of multithreaded applications - if the addref throws an exception, + you don't want the interface to have been assigned here, and if the + assignment is made to a global and another thread references it, + again you don't want the intf to be available until the reference + count is bumped. +} + TEST EDX,EDX // is source nil? + JE @@NilSource + PUSH EDX // save source + PUSH EAX // save dest + MOV EAX,[EDX] // get source vmt + PUSH EDX // source as arg + CALL DWORD PTR [EAX] + VMTOFFSET IInterface._AddRef + POP EAX // retrieve dest + MOV ECX, [EAX] // get current value + POP [EAX] // set dest in place + TEST ECX, ECX // is current value nil? + JNE @@ReleaseDest // no, release it + RET // most common case, we return here +@@ReleaseDest: + MOV EAX,[ECX] // get current value vmt + PUSH ECX // current value as arg + CALL DWORD PTR [EAX] + VMTOFFSET IInterface._Release + RET + +{ Now we're into the less common cases. } +@@NilSource: + MOV ECX, [EAX] // get current value + TEST ECX, ECX // is it nil? + MOV [EAX], EDX // store in dest (which is nil) + JE @@Done + MOV EAX, [ECX] // get current vmt + PUSH ECX // current value as arg + CALL DWORD PTR [EAX] + VMTOFFSET IInterface._Release +@@Done: +end; +{$ENDIF} + +procedure _IntfCast(var Dest: IInterface; const Source: IInterface; const IID: TGUID); +{$IFDEF PUREPASCAL} +// PIC: EBX must be correct before calling QueryInterface +var + Temp: IInterface; +begin + if Source = nil then + Dest := nil + else + begin + Temp := nil; + if Source.QueryInterface(IID, Temp) <> 0 then + Error(reIntfCastError) + else + Dest := Temp; + end; +end; +{$ELSE} +asm + TEST EDX,EDX + JE _IntfClear + PUSH EDI + MOV EDI, EAX // ptr to dest + PUSH 0 + PUSH ESP // ptr to temp + PUSH ECX // ptr to GUID + PUSH EDX // ptr to source +@@1: MOV EAX,[EDX] + CALL DWORD PTR [EAX] + VMTOFFSET IInterface.QueryInterface + TEST EAX,EAX + JE @@2 + MOV AL,reIntfCastError + JMP Error +@@2: MOV EAX, [EDI] + TEST EAX, EAX + JE @@3 + PUSH EAX + MOV EAX,[EAX] + CALL DWORD PTR [EAX] + VMTOFFSET IInterface._Release +@@3: POP EAX // value of temp + MOV [EDI], EAX + POP EDI +end; +{$ENDIF} + +procedure _IntfAddRef(const Dest: IInterface); +begin + if Dest <> nil then Dest._AddRef; +end; + +procedure TInterfacedObject.AfterConstruction; +begin +// Release the constructor's implicit refcount + InterlockedDecrement(FRefCount); +end; + +procedure TInterfacedObject.BeforeDestruction; +begin + if RefCount <> 0 then + Error(reInvalidPtr); +end; + +// Set an implicit refcount so that refcounting +// during construction won't destroy the object. +class function TInterfacedObject.NewInstance: TObject; +begin + Result := inherited NewInstance; + TInterfacedObject(Result).FRefCount := 1; +end; + +function TInterfacedObject.QueryInterface(const IID: TGUID; out Obj): HResult; +begin + if GetInterface(IID, Obj) then + Result := 0 + else + Result := E_NOINTERFACE; +end; + +function TInterfacedObject._AddRef: Integer; +begin + Result := InterlockedIncrement(FRefCount); +end; + +function TInterfacedObject._Release: Integer; +begin + Result := InterlockedDecrement(FRefCount); + if Result = 0 then + Destroy; +end; + +{ TAggregatedObject } + +constructor TAggregatedObject.Create(const Controller: IInterface); +begin + // weak reference to controller - don't keep it alive + FController := Pointer(Controller); +end; + +function TAggregatedObject.GetController: IInterface; +begin + Result := IInterface(FController); +end; + +function TAggregatedObject.QueryInterface(const IID: TGUID; out Obj): HResult; +begin + Result := IInterface(FController).QueryInterface(IID, Obj); +end; + +function TAggregatedObject._AddRef: Integer; +begin + Result := IInterface(FController)._AddRef; +end; + +function TAggregatedObject._Release: Integer; stdcall; +begin + Result := IInterface(FController)._Release; +end; + +{ TContainedObject } + +function TContainedObject.QueryInterface(const IID: TGUID; out Obj): HResult; +begin + if GetInterface(IID, Obj) then + Result := S_OK + else + Result := E_NOINTERFACE; +end; + +{ TClassHelperBase } + +constructor TClassHelperBase._Create(Instance: TObject); +begin + inherited Create; + FInstance := Instance; +end; + +function _CheckAutoResult(ResultCode: HResult): HResult; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + if ResultCode < 0 then + begin + if Assigned(SafeCallErrorProc) then + SafeCallErrorProc(ResultCode, Pointer(-1)); // loses error address + Error(reSafeCallError); + end; + Result := ResultCode; +end; +{$ELSE} +asm + TEST EAX,EAX + JNS @@2 + MOV ECX,SafeCallErrorProc + TEST ECX,ECX + JE @@1 + MOV EDX,[ESP] + CALL ECX +@@1: MOV AL,reSafeCallError + JMP Error +@@2: +end; +{$IFEND} + +function CompToDouble(Value: Comp): Double; cdecl; +begin + Result := Value; +end; + +procedure DoubleToComp(Value: Double; var Result: Comp); cdecl; +begin + Result := Value; +end; + +function CompToCurrency(Value: Comp): Currency; cdecl; +begin + Result := Value; +end; + +procedure CurrencyToComp(Value: Currency; var Result: Comp); cdecl; +begin + Result := Value; +end; + +function GetMemory(Size: Integer): Pointer; cdecl; +begin + Result := MemoryManager.GetMem(Size); +end; + +function FreeMemory(P: Pointer): Integer; cdecl; +begin + if P = nil then + Result := 0 + else + Result := MemoryManager.FreeMem(P); +end; + +function ReallocMemory(P: Pointer; Size: Integer): Pointer; cdecl; +begin + if P = nil then + Result := GetMemory(Size) + else + Result := MemoryManager.ReallocMem(P, Size); +end; + +procedure SetLineBreakStyle(var T: Text; Style: TTextLineBreakStyle); +begin + if TTextRec(T).Mode = fmClosed then + TTextRec(T).Flags := (TTextRec(T).Flags and not tfCRLF) or (tfCRLF * Byte(Style)) + else + SetInOutRes(107); // can't change mode of open file +end; + +// UnicodeToUTF8(3): +// Scans the source data to find the null terminator, up to MaxBytes +// Dest must have MaxBytes available in Dest. + +function UnicodeToUtf8(Dest: PChar; Source: PWideChar; MaxBytes: Integer): Integer; +var + len: Cardinal; +begin + len := 0; + if Source <> nil then + while Source[len] <> #0 do + Inc(len); + Result := UnicodeToUtf8(Dest, MaxBytes, Source, len); +end; + +// UnicodeToUtf8(4): +// MaxDestBytes includes the null terminator (last char in the buffer will be set to null) +// Function result includes the null terminator. +// Nulls in the source data are not considered terminators - SourceChars must be accurate + +function UnicodeToUtf8(Dest: PChar; MaxDestBytes: Cardinal; Source: PWideChar; SourceChars: Cardinal): Cardinal; +var + i, count: Cardinal; + c: Cardinal; +begin + Result := 0; + if Source = nil then Exit; + count := 0; + i := 0; + if Dest <> nil then + begin + while (i < SourceChars) and (count < MaxDestBytes) do + begin + c := Cardinal(Source[i]); + Inc(i); + if c <= $7F then + begin + Dest[count] := Char(c); + Inc(count); + end + else if c > $7FF then + begin + if count + 3 > MaxDestBytes then + break; + Dest[count] := Char($E0 or (c shr 12)); + Dest[count+1] := Char($80 or ((c shr 6) and $3F)); + Dest[count+2] := Char($80 or (c and $3F)); + Inc(count,3); + end + else // $7F < Source[i] <= $7FF + begin + if count + 2 > MaxDestBytes then + break; + Dest[count] := Char($C0 or (c shr 6)); + Dest[count+1] := Char($80 or (c and $3F)); + Inc(count,2); + end; + end; + if count >= MaxDestBytes then count := MaxDestBytes-1; + Dest[count] := #0; + end + else + begin + while i < SourceChars do + begin + c := Integer(Source[i]); + Inc(i); + if c > $7F then + begin + if c > $7FF then + Inc(count); + Inc(count); + end; + Inc(count); + end; + end; + Result := count+1; // convert zero based index to byte count +end; + +function Utf8ToUnicode(Dest: PWideChar; Source: PChar; MaxChars: Integer): Integer; +var + len: Cardinal; +begin + len := 0; + if Source <> nil then + while Source[len] <> #0 do + Inc(len); + Result := Utf8ToUnicode(Dest, MaxChars, Source, len); +end; + +function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: Cardinal; Source: PChar; SourceBytes: Cardinal): Cardinal; +var + i, count: Cardinal; + c: Byte; + wc: Cardinal; +begin + if Source = nil then + begin + Result := 0; + Exit; + end; + Result := Cardinal(-1); + count := 0; + i := 0; + if Dest <> nil then + begin + while (i < SourceBytes) and (count < MaxDestChars) do + begin + wc := Cardinal(Source[i]); + Inc(i); + if (wc and $80) <> 0 then + begin + if i >= SourceBytes then Exit; // incomplete multibyte char + wc := wc and $3F; + if (wc and $20) <> 0 then + begin + c := Byte(Source[i]); + Inc(i); + if (c and $C0) <> $80 then Exit; // malformed trail byte or out of range char + if i >= SourceBytes then Exit; // incomplete multibyte char + wc := (wc shl 6) or (c and $3F); + end; + c := Byte(Source[i]); + Inc(i); + if (c and $C0) <> $80 then Exit; // malformed trail byte + + Dest[count] := WideChar((wc shl 6) or (c and $3F)); + end + else + Dest[count] := WideChar(wc); + Inc(count); + end; + if count >= MaxDestChars then count := MaxDestChars-1; + Dest[count] := #0; + end + else + begin + while (i < SourceBytes) do + begin + c := Byte(Source[i]); + Inc(i); + if (c and $80) <> 0 then + begin + if i >= SourceBytes then Exit; // incomplete multibyte char + c := c and $3F; + if (c and $20) <> 0 then + begin + c := Byte(Source[i]); + Inc(i); + if (c and $C0) <> $80 then Exit; // malformed trail byte or out of range char + if i >= SourceBytes then Exit; // incomplete multibyte char + end; + c := Byte(Source[i]); + Inc(i); + if (c and $C0) <> $80 then Exit; // malformed trail byte + end; + Inc(count); + end; + end; + Result := count+1; +end; + +function Utf8Encode(const WS: WideString): UTF8String; +var + L: Integer; + Temp: UTF8String; +begin + Result := ''; + if WS = '' then Exit; + SetLength(Temp, Length(WS) * 3); // SetLength includes space for null terminator + + L := UnicodeToUtf8(PChar(Temp), Length(Temp)+1, PWideChar(WS), Length(WS)); + if L > 0 then + SetLength(Temp, L-1) + else + Temp := ''; + Result := Temp; +end; + +function Utf8Decode(const S: UTF8String): WideString; +var + L: Integer; + Temp: WideString; +begin + Result := ''; + if S = '' then Exit; + SetLength(Temp, Length(S)); + + L := Utf8ToUnicode(PWideChar(Temp), Length(Temp)+1, PChar(S), Length(S)); + if L > 0 then + SetLength(Temp, L-1) + else + Temp := ''; + Result := Temp; +end; + +function AnsiToUtf8(const S: string): UTF8String; +begin + Result := Utf8Encode(S); +end; + +function Utf8ToAnsi(const S: UTF8String): string; +begin + Result := Utf8Decode(S); +end; + +{$IFDEF LINUX} + +function GetCPUType: Integer; +asm + PUSH EBX + // this code assumes ESP is 4 byte aligned + // test for 80386: see if bit #18 of EFLAGS (Alignment fault) can be toggled + PUSHFD + POP EAX + MOV ECX, EAX + XOR EAX, $40000 // flip AC bit in EFLAGS + PUSH EAX + POPFD + PUSHFD + POP EAX + XOR EAX, ECX // zero = 80386 CPU (can't toggle AC bit) + MOV EAX, CPUi386 + JZ @@Exit + PUSH ECX + POPFD // restore original flags before next test + + // test for 80486: see if bit #21 of EFLAGS (CPUID supported) can be toggled + MOV EAX, ECX // get original EFLAGS + XOR EAX, $200000 // flip CPUID bit in EFLAGS + PUSH EAX + POPFD + PUSHFD + POP EAX + XOR EAX, ECX // zero = 80486 (can't toggle EFLAGS bit #21) + MOV EAX, CPUi486 + JZ @@Exit + + // Use CPUID instruction to get CPU family + XOR EAX, EAX + CPUID + CMP EAX, 1 + JL @@Exit // unknown processor response: report as 486 + XOR EAX, EAX + INC EAX // we only care about info level 1 + CPUID + AND EAX, $F00 + SHR EAX, 8 + // Test8086 values are one less than the CPU model number, for historical reasons + DEC EAX + +@@Exit: + POP EBX +end; + + +const + sResSymExport = '@Sysinit@ResSym'; + sResStrExport = '@Sysinit@ResStr'; + sResHashExport = '@Sysinit@ResHash'; + +type + TElf32Sym = record + Name: Cardinal; + Value: Pointer; + Size: Cardinal; + Info: Byte; + Other: Byte; + Section: Word; + end; + PElf32Sym = ^TElf32Sym; + + TElfSymTab = array [0..0] of TElf32Sym; + PElfSymTab = ^TElfSymTab; + + TElfWordTab = array [0..2] of Cardinal; + PElfWordTab = ^TElfWordTab; + + +{ If Name encodes a numeric identifier, return it, else return -1. } +function NameToId(Name: PChar): Longint; +var digit: Longint; +begin + if Longint(Name) and $ffff0000 = 0 then + begin + Result := Longint(Name) and $ffff; + end + else if Name^ = '#' then + begin + Result := 0; + inc (Name); + while (Ord(Name^) <> 0) do + begin + digit := Ord(Name^) - Ord('0'); + if (LongWord(digit) > 9) then + begin + Result := -1; + exit; + end; + Result := Result * 10 + digit; + inc (Name); + end; + end + else + Result := -1; +end; + + +// Return ELF hash value for NAME converted to lower case. +function ElfHashLowercase(Name: PChar): Cardinal; +var + g: Cardinal; + c: Char; +begin + Result := 0; + while name^ <> #0 do + begin + c := name^; + case c of + 'A'..'Z': Inc(c, Ord('a') - Ord('A')); + end; + Result := (Result shl 4) + Ord(c); + g := Result and $f0000000; + Result := (Result xor (g shr 24)) and not g; + Inc(name); + end; +end; + +type + PFindResourceCache = ^TFindResourceCache; + TFindResourceCache = record + ModuleHandle: HMODULE; + Version: Cardinal; + SymbolTable: PElfSymTab; + StringTable: PChar; + HashTable: PElfWordTab; + BaseAddress: Cardinal; + end; + +threadvar + FindResourceCache: TFindResourceCache; + +function GetResourceCache(ModuleHandle: HMODULE): PFindResourceCache; +var + info: TDLInfo; +begin + Result := @FindResourceCache; + if (ModuleHandle <> Result^.ModuleHandle) or (ModuleCacheVersion <> Result^.Version) then + begin + Result^.SymbolTable := dlsym(ModuleHandle, sResSymExport); + Result^.StringTable := dlsym(ModuleHandle, sResStrExport); + Result^.HashTable := dlsym(ModuleHandle, sResHashExport); + Result^.ModuleHandle := ModuleHandle; + if (dladdr(Result^.HashTable, Info) = 0) or (Info.BaseAddress = ExeBaseAddress) then + Result^.BaseAddress := 0 // if it's not in a library, assume the exe + else + Result^.BaseAddress := Cardinal(Info.BaseAddress); + Result^.Version := ModuleCacheVersion; + end; +end; + +function FindResource(ModuleHandle: HMODULE; ResourceName: PChar; ResourceType: PChar): TResourceHandle; +var + P: PFindResourceCache; + nid, tid: Longint; + ucs2_key: array [0..2] of WideChar; + key: array [0..127] of Char; + len: Integer; + pc: PChar; + ch: Char; + nbucket: Cardinal; + bucket, chain: PElfWordTab; + syndx: Cardinal; +begin + Result := 0; + if ResourceName = nil then Exit; + P := GetResourceCache(ModuleHandle); + + tid := NameToId (ResourceType); + if tid = -1 then Exit; { not supported (yet?) } + + { This code must match util-common/elfres.c } + nid := NameToId (ResourceName); + if nid = -1 then + begin + ucs2_key[0] := WideChar(2*tid+2); + ucs2_key[1] := WideChar(0); + len := UnicodeToUtf8 (key, ucs2_key, SizeOf (key)) - 1; + pc := key+len; + while Ord(ResourceName^) <> 0 do + begin + ch := ResourceName^; + if Ord(ch) > 127 then exit; { insist on 7bit ASCII for now } + if ('A' <= ch) and (ch <= 'Z') then Inc(ch, Ord('a') - Ord('A')); + pc^ := ch; + inc (pc); + if pc = key + SizeOf(key) then exit; + inc (ResourceName); + end; + pc^ := Char(0); + end + else + begin + ucs2_key[0] := WideChar(2*tid+1); + ucs2_key[1] := WideChar(nid); + ucs2_key[2] := WideChar(0); + UnicodeToUtf8 (key, ucs2_key, SizeOf (key)); + end; + + with P^ do + begin + nbucket := HashTable[0]; + // nsym := HashTable[1]; + bucket := @HashTable[2]; + chain := @HashTable[2+nbucket]; + + syndx := bucket[ElfHashLowercase(key) mod nbucket]; + while (syndx <> 0) + and (strcasecmp(key, @StringTable[SymbolTable[syndx].Name]) <> 0) do + syndx := chain[syndx]; + + if syndx = 0 then + Result := 0 + else + Result := TResourceHandle(@SymbolTable[syndx]); + end; +end; + +function LoadResource(ModuleHandle: HMODULE; ResHandle: TResourceHandle): HGLOBAL; +var + P: PFindResourceCache; +begin + if ResHandle <> 0 then + begin + P := GetResourceCache(ModuleHandle); + Result := HGLOBAL(PElf32Sym(ResHandle)^.Value); + Inc (Cardinal(Result), P^.BaseAddress); + end + else + Result := 0; +end; + +function SizeofResource(ModuleHandle: HMODULE; ResHandle: TResourceHandle): Integer; +begin + if ResHandle <> 0 then + Result := PElf32Sym(ResHandle)^.Size + else + Result := 0; +end; + +function LockResource(ResData: HGLOBAL): Pointer; +begin + Result := Pointer(ResData); +end; + +function UnlockResource(ResData: HGLOBAL): LongBool; +begin + Result := False; +end; + +function FreeResource(ResData: HGLOBAL): LongBool; +begin + Result := True; +end; +{$ENDIF} + +{ ResString support function } + +{$IFDEF MSWINDOWS} +function LoadResString(ResStringRec: PResStringRec): string; +var + Buffer: array [0..4095] of char; +begin + if ResStringRec = nil then Exit; + if ResStringRec.Identifier < 64*1024 then + SetString(Result, Buffer, + LoadString(FindResourceHInstance(ResStringRec.Module^), + ResStringRec.Identifier, Buffer, SizeOf(Buffer))) + else + Result := PChar(ResStringRec.Identifier); +end; +{$ENDIF} +{$IFDEF LINUX} + +const + ResStringTableLen = 16; + +type + ResStringTable = array [0..ResStringTableLen-1] of LongWord; + +//function _printf(Format: PChar): Integer; cdecl; varargs; +//external libc name 'printf'; + +function LoadResString(ResStringRec: PResStringRec): string; +var + Handle: TResourceHandle; + Tab: ^ResStringTable; + ResMod: HMODULE; +begin + if ResStringRec = nil then Exit; + ResMod := FindResourceHInstance(ResStringRec^.Module^); + Handle := FindResource(ResMod, + PChar(ResStringRec^.Identifier div ResStringTableLen), + PChar(6)); // RT_STRING + Tab := Pointer(LoadResource(ResMod, Handle)); + if Tab = nil then + Result := '' + else + begin + Result := PWideChar(PChar(Tab) + Tab[ResStringRec^.Identifier mod ResStringTableLen]); + end; +end; + +{ The Win32 program loader sets up the first 64k of process address space + with no read or write access, to help detect use of invalid pointers + (whose integer value is 0..64k). Linux doesn't do this. + + Parts of the Delphi RTL and IDE design environment + rely on the notion that pointer values in the [0..64k] range are + invalid pointers. To accomodate this in Linux, we reserve the range + at startup. If the range is already allocated, we keep going anyway. } + +var + ZeroPageReserved: Boolean = False; + +procedure ReserveZeroPage; +const + PROT_NONE = 0; + MAP_PRIVATE = $02; + MAP_FIXED = $10; + MAP_ANONYMOUS = $20; +var + P: Pointer; +begin + if IsLibrary then Exit; // page reserve is app's job, not .so's + + if not ZeroPageReserved then + begin + P := mmap(nil, High(Word), PROT_NONE, + MAP_ANONYMOUS or MAP_PRIVATE or MAP_FIXED, 0, 0); + ZeroPageReserved := P = nil; + if (Integer(P) <> -1) and (P <> nil) then // we didn't get it + munmap(P, High(Word)); + end; +end; + +procedure ReleaseZeroPage; +begin + if ZeroPageReserved then + begin + munmap(nil, High(Word) - 4096); + ZeroPageReserved := False; + end; +end; +{$ENDIF} + +var + xxNull: UCS4Char = 0; + xxPNull: PUCS4Char = @xxNull; +function PUCS4Chars(const S: UCS4String): PUCS4Char; +begin + if Length(S) > 0 then + Result := @S[0] + else + Result := xxPNull; +end; + +function WideStringToUCS4String(const S: WideString): UCS4String; +var + I: Integer; +begin + SetLength(Result, Length(S) + 1); + for I := 0 to Length(S) - 1 do + Result[I] := UCS4Char(S[I + 1]); + Result[Length(S)] := 0; +end; + +function UCS4StringToWidestring(const S: UCS4String): WideString; +var + I: Integer; +begin + SetLength(Result, Length(S)-1); + for I := 0 to Length(S)-2 do + Result[I+1] := WideChar(S[I]); +end; + +{$IFDEF MSWINDOWS} +function GetACP: LongWord; stdcall; external 'kernel32.dll' name 'GetACP'; + +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; +{$ENDIF} + +{$IFDEF LINUX} +const + LC_ALL = 6; + +function _setlocale(__category: Integer; __locale: PChar): PChar; cdecl; +external libc name 'setlocale'; +{$ENDIF} + +{$IFDEF MSWINDOWS} +procedure SetMultiByteConversionCodePage(CodePage: Integer); +begin + SaveDefaultSystemCodePage := CodePage; +end; +{$ENDIF} + +var SaveCmdShow : Integer = -1; +function CmdShow: Integer; +var + SI: TStartupInfo; +begin + if SaveCmdShow < 0 then + begin + SaveCmdShow := 10; { SW_SHOWDEFAULT } + GetStartupInfo(SI); + if SI.dwFlags and 1 <> 0 then { STARTF_USESHOWWINDOW } + SaveCmdShow := SI.wShowWindow; + end; + Result := SaveCmdShow; +end; + +{X} // convert var CmdLine : PChar to a function: +{X} function CmdLine: PChar; +{X} begin +{X} Result := GetCommandLine; +{X} end; + +function DefaultSystemCodePage: Integer; +begin + if (SaveCmdShow = -1) then + SaveDefaultSystemCodePage := GetACP; + Result := SaveDefaultSystemCodePage; +end; + +procedure DoCloseInputOutput; +begin + Close(Input); + Close(Output); + Close(ErrOutput); +end; + +var + CloseInputOutput: procedure = nil; //DummyProc; + +procedure UseInputOutput; +begin + if not Assigned(CloseInputOutput) then begin + CloseInputOutput := DoCloseInputOutput; + //_Assign( Input, '' ); was for D5 so - changed + //_Assign( Output, '' ); was for D5 so - changed + TTextRec(Input).Mode := fmClosed; + TTextRec(Output).Mode := fmClosed; + TTextRec(ErrOutput).Mode := fmClosed; + end; +end; + +initialization + InitializeMemoryManager; +{$IFDEF LINUX} + _setlocale(LC_ALL, ''); +{$ENDIF} + + {$IFDEF MSWINDOWS} + //{X (initialized statically} FileMode := 2; + {$ELSE} + FileMode := 2; + {$ENDIF} + + RaiseExceptionProc := @RaiseException; + RTLUnwindProc := @RTLUnwind; + +{$IFDEF LINUX} + FileAccessRights := S_IRUSR or S_IWUSR or S_IRGRP or S_IWGRP or S_IROTH or S_IWOTH; + Test8086 := GetCPUType; + IsConsole := True; + FindResourceCache.ModuleHandle := LongWord(-1); + ReserveZeroPage; +{$ELSE} + //{X (initialized statically} Test8086 := 2; +{$ENDIF} + + DispCallByIDProc := @_DispCallByIDError; + +{$IFDEF MSWINDOWS} + //{X} if _isNECWindows then _FpuMaskInit; +{$ENDIF} + //{X} _FpuInit(); + + TTextRec(Input).Mode := fmClosed; + TTextRec(Output).Mode := fmClosed; + TTextRec(ErrOutput).Mode := fmClosed; + +{$IFDEF MSWINDOWS} +{X- CmdLine := GetCommandLine; converted to a function } +{X- CmdShow := GetCmdShow; converted to a function } +{X- DefaultSystemCodePage := GetACP; converted to a function } +{$ENDIF} +{X- MainThreadID := GetCurrentThreadID; } + +finalization +{X+} + if Assigned(CloseInputOutput) then + CloseInputOutput; +{X- Close(Input); + Close(Output); + Close(ErrOutput); } +{$IFDEF LINUX} + ReleaseZeroPage; +{$ENDIF} +{$IFDEF MSWINDOWS} + {Uninitialize the default memory manager, and free all memory allocated by + this memory manager.} + FinalizeMemoryManager; +{$ENDIF} +end. diff --git a/System/D2006_orig/Types.pas b/System/D2006_orig/Types.pas new file mode 100644 index 0000000..252b3fc --- /dev/null +++ b/System/D2006_orig/Types.pas @@ -0,0 +1,561 @@ + +{ *********************************************************************** } +{ } +{ Delphi / Kylix Cross-Platform Runtime Library } +{ } +{ Copyright (c) 2000-2004 Borland Software Corporation } +{ } +{ *********************************************************************** } + +unit Types; + +interface + +type + PLongint = System.PLongint; + {$EXTERNALSYM PLongint} + PInteger = System.PInteger; + {$EXTERNALSYM PInteger} + PSmallInt = System.PSmallInt; + {$EXTERNALSYM PSmallInt} + PDouble = System.PDouble; + {$EXTERNALSYM PDouble} + PByte = System.PByte; + {$EXTERNALSYM PByte} + + TIntegerDynArray = array of Integer; + {$EXTERNALSYM TIntegerDynArray} + TCardinalDynArray = array of Cardinal; + {$EXTERNALSYM TCardinalDynArray} + TWordDynArray = array of Word; + {$EXTERNALSYM TWordDynArray} + TSmallIntDynArray = array of SmallInt; + {$EXTERNALSYM TSmallIntDynArray} + TByteDynArray = array of Byte; + {$EXTERNALSYM TByteDynArray} + TShortIntDynArray = array of ShortInt; + {$EXTERNALSYM TShortIntDynArray} + TInt64DynArray = array of Int64; + {$EXTERNALSYM TInt64DynArray} + TLongWordDynArray = array of LongWord; + {$EXTERNALSYM TLongWordDynArray} + TSingleDynArray = array of Single; + {$EXTERNALSYM TSingleDynArray} + TDoubleDynArray = array of Double; + {$EXTERNALSYM TDoubleDynArray} + TBooleanDynArray = array of Boolean; + {$EXTERNALSYM TBooleanDynArray} + TStringDynArray = array of string; + {$EXTERNALSYM TStringDynArray} + TWideStringDynArray = array of WideString; + {$EXTERNALSYM TWideStringDynArray} + + PPoint = ^TPoint; + TPoint = packed record + X: Longint; + Y: Longint; + end; + {$NODEFINE TPoint} + tagPOINT = TPoint; + {$NODEFINE tagPOINT} + + PRect = ^TRect; + TRect = packed record + case Integer of + 0: (Left, Top, Right, Bottom: Longint); + 1: (TopLeft, BottomRight: TPoint); + end; + {$NODEFINE TRect} + + PSize = ^TSize; + tagSIZE = packed record + cx: Longint; + cy: Longint; + end; + {$EXTERNALSYM tagSIZE} + TSize = tagSIZE; + SIZE = tagSIZE; + {$EXTERNALSYM SIZE} + + PSmallPoint = ^TSmallPoint; + TSmallPoint = packed record + x: SmallInt; + y: SmallInt; + end; + + (*$HPPEMIT 'namespace Types'*) + (*$HPPEMIT '{'*) + (*$HPPEMIT ' struct TPoint : public POINT'*) + (*$HPPEMIT ' {'*) + (*$HPPEMIT ' TPoint() {}'*) + (*$HPPEMIT ' TPoint(int _x, int _y) { x=_x; y=_y; }'*) + (*$HPPEMIT ' TPoint(POINT& pt)'*) + (*$HPPEMIT ' {'*) + (*$HPPEMIT ' x = pt.x;'*) + (*$HPPEMIT ' y = pt.y;'*) + (*$HPPEMIT ' }'*) + (*$HPPEMIT ' };'*) + (*$HPPEMIT ' '*) + (*$HPPEMIT ' typedef TPoint tagPoint;'*) + (*$HPPEMIT ' '*) + (*$HPPEMIT ' struct TRect : public RECT'*) + (*$HPPEMIT ' {'*) + (*$HPPEMIT ' TRect() {}'*) + (*$HPPEMIT ' TRect(const TPoint& TL, const TPoint& BR) { left=TL.x; top=TL.y; right=BR.x; bottom=BR.y; }'*) + (*$HPPEMIT ' TRect(int l, int t, int r, int b) { left=l; top=t; right=r; bottom=b; }'*) + (*$HPPEMIT ' TRect(RECT& r)'*) + (*$HPPEMIT ' {'*) + (*$HPPEMIT ' left = r.left;'*) + (*$HPPEMIT ' top = r.top;'*) + (*$HPPEMIT ' right = r.right;'*) + (*$HPPEMIT ' bottom = r.bottom;'*) + (*$HPPEMIT ' }'*) + (*$HPPEMIT ' int Width () const { return right - left; }'*) + (*$HPPEMIT ' int Height() const { return bottom - top ; }'*) + (*$HPPEMIT ' bool operator ==(const TRect& rc) const '*) + (*$HPPEMIT ' {'*) + (*$HPPEMIT ' return left == rc.left && top==rc.top && '*) + (*$HPPEMIT ' right == rc.right && bottom==rc.bottom; '*) + (*$HPPEMIT ' }'*) + (*$HPPEMIT ' bool operator !=(const TRect& rc) const '*) + (*$HPPEMIT ' { return !(rc==*this); }'*) + (*$HPPEMIT ' '*) + (*$HPPEMIT ' __property LONG Left = { read=left, write=left }; '*) + (*$HPPEMIT ' __property LONG Top = { read=top, write=top }; '*) + (*$HPPEMIT ' __property LONG Right = { read=right, write=right }; '*) + (*$HPPEMIT ' __property LONG Bottom = { read=bottom, write=bottom }; '*) + (*$HPPEMIT ' };'*) + (*$HPPEMIT '} /* namespace Types */ ;'*) + + DWORD = LongWord; + {$EXTERNALSYM DWORD} +const + RT_RCDATA = PChar(10); + {$EXTERNALSYM RT_RCDATA} + +{$IFDEF LINUX} +type + PDisplay = Pointer; + PEvent = Pointer; + TXrmOptionDescRec = record end; + XrmOptionDescRec = TXrmOptionDescRec; + PXrmOptionDescRec = ^TXrmOptionDescRec; + Widget = Pointer; + WidgetClass = Pointer; + ArgList = Pointer; + Region = Pointer; + +const +//! {$EXTERNALSYM STGTY_STORAGE} + STGTY_STORAGE = 1; +//! {$EXTERNALSYM STGTY_STREAM} + STGTY_STREAM = 2; +//! {$EXTERNALSYM STGTY_LOCKBYTES} + STGTY_LOCKBYTES = 3; +//! {$EXTERNALSYM STGTY_PROPERTY} + STGTY_PROPERTY = 4; + +//! {$EXTERNALSYM STREAM_SEEK_SET} + STREAM_SEEK_SET = 0; +//! {$EXTERNALSYM STREAM_SEEK_CUR} + STREAM_SEEK_CUR = 1; +//! {$EXTERNALSYM STREAM_SEEK_END} + STREAM_SEEK_END = 2; + +//! {$EXTERNALSYM LOCK_WRITE} + LOCK_WRITE = 1; +//! {$EXTERNALSYM LOCK_EXCLUSIVE} + LOCK_EXCLUSIVE = 2; +//! {$EXTERNALSYM LOCK_ONLYONCE} + LOCK_ONLYONCE = 4; + + { Unspecified error } + E_FAIL = HRESULT($80004005); +//! {$EXTERNALSYM E_FAIL} + + { Unable to perform requested operation. } + STG_E_INVALIDFUNCTION = HRESULT($80030001); +//! {$EXTERNALSYM STG_E_INVALIDFUNCTION} + + { %l could not be found. } + STG_E_FILENOTFOUND = HRESULT($80030002); +//! {$EXTERNALSYM STG_E_FILENOTFOUND} + + { The path %l could not be found. } + STG_E_PATHNOTFOUND = HRESULT($80030003); +//! {$EXTERNALSYM STG_E_PATHNOTFOUND} + + { There are insufficient resources to open another file. } + STG_E_TOOMANYOPENFILES = HRESULT($80030004); +//! {$EXTERNALSYM STG_E_TOOMANYOPENFILES} + + { Access Denied. } + STG_E_ACCESSDENIED = HRESULT($80030005); +//! {$EXTERNALSYM STG_E_ACCESSDENIED} + + { Attempted an operation on an invalid object. } + STG_E_INVALIDHANDLE = HRESULT($80030006); +//! {$EXTERNALSYM STG_E_INVALIDHANDLE} + + { There is insufficient memory available to complete operation. } + STG_E_INSUFFICIENTMEMORY = HRESULT($80030008); +//! {$EXTERNALSYM STG_E_INSUFFICIENTMEMORY} + + { Invalid pointer error. } + STG_E_INVALIDPOINTER = HRESULT($80030009); +//! {$EXTERNALSYM STG_E_INVALIDPOINTER} + + { There are no more entries to return. } + STG_E_NOMOREFILES = HRESULT($80030012); +//! {$EXTERNALSYM STG_E_NOMOREFILES} + + { Disk is write-protected. } + STG_E_DISKISWRITEPROTECTED = HRESULT($80030013); +//! {$EXTERNALSYM STG_E_DISKISWRITEPROTECTED} + + { An error occurred during a seek operation. } + STG_E_SEEKERROR = HRESULT($80030019); +//! {$EXTERNALSYM STG_E_SEEKERROR} + + { A disk error occurred during a write operation. } + STG_E_WRITEFAULT = HRESULT($8003001D); +//! {$EXTERNALSYM STG_E_WRITEFAULT} + + { A disk error occurred during a read operation. } + STG_E_READFAULT = HRESULT($8003001E); +//! {$EXTERNALSYM STG_E_READFAULT} + + { A share violation has occurred. } + STG_E_SHAREVIOLATION = HRESULT($80030020); +//! {$EXTERNALSYM STG_E_SHAREVIOLATION} + + { A lock violation has occurred. } + STG_E_LOCKVIOLATION = HRESULT($80030021); +//! {$EXTERNALSYM STG_E_LOCKVIOLATION} + + { %l already exists. } + STG_E_FILEALREADYEXISTS = HRESULT($80030050); +//! {$EXTERNALSYM STG_E_FILEALREADYEXISTS} + + { Invalid parameter error. } + STG_E_INVALIDPARAMETER = HRESULT($80030057); +//! {$EXTERNALSYM STG_E_INVALIDPARAMETER} + + { There is insufficient disk space to complete operation. } + STG_E_MEDIUMFULL = HRESULT($80030070); +//! {$EXTERNALSYM STG_E_MEDIUMFULL} + + { Illegal write of non-simple property to simple property set. } + STG_E_PROPSETMISMATCHED = HRESULT($800300F0); +//! {$EXTERNALSYM STG_E_PROPSETMISMATCHED} + + { An API call exited abnormally. } + STG_E_ABNORMALAPIEXIT = HRESULT($800300FA); +//! {$EXTERNALSYM STG_E_ABNORMALAPIEXIT} + + { The file %l is not a valid compound file. } + STG_E_INVALIDHEADER = HRESULT($800300FB); +//! {$EXTERNALSYM STG_E_INVALIDHEADER} + + { The name %l is not valid. } + STG_E_INVALIDNAME = HRESULT($800300FC); +//! {$EXTERNALSYM STG_E_INVALIDNAME} + + { An unexpected error occurred. } + STG_E_UNKNOWN = HRESULT($800300FD); +//! {$EXTERNALSYM STG_E_UNKNOWN} + + { That function is not implemented. } + STG_E_UNIMPLEMENTEDFUNCTION = HRESULT($800300FE); +//! {$EXTERNALSYM STG_E_UNIMPLEMENTEDFUNCTION} + + { Invalid flag error. } + STG_E_INVALIDFLAG = HRESULT($800300FF); +//! {$EXTERNALSYM STG_E_INVALIDFLAG} + + { Attempted to use an object that is busy. } + STG_E_INUSE = HRESULT($80030100); +//! {$EXTERNALSYM STG_E_INUSE} + + { The storage has been changed since the last commit. } + STG_E_NOTCURRENT = HRESULT($80030101); +//! {$EXTERNALSYM STG_E_NOTCURRENT} + + { Attempted to use an object that has ceased to exist. } + STG_E_REVERTED = HRESULT($80030102); +//! {$EXTERNALSYM STG_E_REVERTED} + + { Can't save. } + STG_E_CANTSAVE = HRESULT($80030103); +//! {$EXTERNALSYM STG_E_CANTSAVE} + + { The compound file %l was produced with an incompatible version of storage. } + STG_E_OLDFORMAT = HRESULT($80030104); +//! {$EXTERNALSYM STG_E_OLDFORMAT} + + { The compound file %l was produced with a newer version of storage. } + STG_E_OLDDLL = HRESULT($80030105); +//! {$EXTERNALSYM STG_E_OLDDLL} + + { Share.exe or equivalent is required for operation. } + STG_E_SHAREREQUIRED = HRESULT($80030106); +//! {$EXTERNALSYM STG_E_SHAREREQUIRED} + + { Illegal operation called on non-file based storage. } + STG_E_NOTFILEBASEDSTORAGE = HRESULT($80030107); +//! {$EXTERNALSYM STG_E_NOTFILEBASEDSTORAGE} + + { Illegal operation called on object with extant marshallings. } + STG_E_EXTANTMARSHALLINGS = HRESULT($80030108); +//! {$EXTERNALSYM STG_E_EXTANTMARSHALLINGS} + + { The docfile has been corrupted. } + STG_E_DOCFILECORRUPT = HRESULT($80030109); +//! {$EXTERNALSYM STG_E_DOCFILECORRUPT} + + { OLE32.DLL has been loaded at the wrong address. } + STG_E_BADBASEADDRESS = HRESULT($80030110); +//! {$EXTERNALSYM STG_E_BADBASEADDRESS} + + { The file download was aborted abnormally. The file is incomplete. } + STG_E_INCOMPLETE = HRESULT($80030201); +//! {$EXTERNALSYM STG_E_INCOMPLETE} + + { The file download has been terminated. } + STG_E_TERMINATED = HRESULT($80030202); +//! {$EXTERNALSYM STG_E_TERMINATED} + + { The underlying file was converted to compound file format. } + STG_S_CONVERTED = $00030200; +//! {$EXTERNALSYM STG_S_CONVERTED} + + { The storage operation should block until more data is available. } + STG_S_BLOCK = $00030201; +//! {$EXTERNALSYM STG_S_BLOCK} + + { The storage operation should retry immediately. } + STG_S_RETRYNOW = $00030202; +//! {$EXTERNALSYM STG_S_RETRYNOW} + + { The notified event sink will not influence the storage operation. } + STG_S_MONITORING = $00030203; +//! {$EXTERNALSYM STG_S_MONITORING} + + GUID_NULL: TGUID = '{00000000-0000-0000-0000-000000000000}'; + +type + TOleChar = WideChar; + POleStr = PWideChar; + PPOleStr = ^POleStr; + + PCLSID = PGUID; + TCLSID = TGUID; + +{ 64-bit large integer } + + Largeint = Int64; + {$EXTERNALSYM Largeint} + +// DWORD = LongWord; +// {$EXTERNALSYM DWORD} + PDWORD = ^DWORD; + {$EXTERNALSYM PDWORD} + + { File System time stamps are represented with the following structure: } + PFileTime = ^TFileTime; + _FILETIME = packed record + dwLowDateTime: DWORD; + dwHighDateTime: DWORD; + end; +//! {$EXTERNALSYM _FILETIME} + TFileTime = _FILETIME; + FILETIME = _FILETIME; +//! {$EXTERNALSYM FILETIME} + +{ IStream interface } + + PStatStg = ^TStatStg; +//! {$EXTERNALSYM tagSTATSTG} + tagSTATSTG = packed record + pwcsName: POleStr; + dwType: Longint; + cbSize: Largeint; + mtime: TFileTime; + ctime: TFileTime; + atime: TFileTime; + grfMode: Longint; + grfLocksSupported: Longint; + clsid: TCLSID; + grfStateBits: Longint; + reserved: Longint; + end; + TStatStg = tagSTATSTG; +//! {$EXTERNALSYM STATSTG} + STATSTG = TStatStg; + + IClassFactory = interface(IUnknown) + ['{00000001-0000-0000-C000-000000000046}'] + function CreateInstance(const unkOuter: IUnknown; const iid: TGUID; + out obj): HResult; stdcall; + function LockServer(fLock: LongBool): HResult; stdcall; + end; + + ISequentialStream = interface(IUnknown) + ['{0c733a30-2a1c-11ce-ade5-00aa0044773d}'] + function Read(pv: Pointer; cb: Longint; pcbRead: PLongint): HResult; + stdcall; + function Write(pv: Pointer; cb: Longint; pcbWritten: PLongint): HResult; + stdcall; + end; + //{$EXTERNALSYM ISequentialStream} + + IStream = interface(ISequentialStream) + ['{0000000C-0000-0000-C000-000000000046}'] + function Seek(dlibMove: Largeint; dwOrigin: Longint; + out libNewPosition: Largeint): HResult; stdcall; + function SetSize(libNewSize: Largeint): HResult; stdcall; + function CopyTo(stm: IStream; cb: Largeint; out cbRead: Largeint; + out cbWritten: Largeint): HResult; stdcall; + function Commit(grfCommitFlags: Longint): HResult; stdcall; + function Revert: HResult; stdcall; + function LockRegion(libOffset: Largeint; cb: Largeint; + dwLockType: Longint): HResult; stdcall; + function UnlockRegion(libOffset: Largeint; cb: Largeint; + dwLockType: Longint): HResult; stdcall; + function Stat(out statstg: TStatStg; grfStatFlag: Longint): HResult; + stdcall; + function Clone(out stm: IStream): HResult; stdcall; + end; + //{$EXTERNALSYM IStream} +{$ENDIF} { LINUX } + +function EqualRect(const R1, R2: TRect): Boolean; +function Rect(Left, Top, Right, Bottom: Integer): TRect; +{$EXTERNALSYM Rect} +function Bounds(ALeft, ATop, AWidth, AHeight: Integer): TRect; +{$EXTERNALSYM Bounds} +function Point(X, Y: Integer): TPoint; +{$EXTERNALSYM Point} +function SmallPoint(X, Y: Integer): TSmallPoint; overload; +function SmallPoint(XY: LongWord): TSmallPoint; overload; +function PtInRect(const Rect: TRect; const P: TPoint): Boolean; +function IntersectRect(out Rect: TRect; const R1, R2: TRect): Boolean; +function UnionRect(out Rect: TRect; const R1, R2: TRect): Boolean; +function IsRectEmpty(const Rect: TRect): Boolean; +function OffsetRect(var Rect: TRect; DX: Integer; DY: Integer): Boolean; +function CenterPoint(const Rect: TRect): TPoint; + +type + TValueRelationship = -1..1; + +const + LessThanValue = Low(TValueRelationship); + EqualsValue = 0; + GreaterThanValue = High(TValueRelationship); + +implementation + +function EqualRect(const R1, R2: TRect): Boolean; +begin + Result := (R1.Left = R2.Left) and (R1.Right = R2.Right) and + (R1.Top = R2.Top) and (R1.Bottom = R2.Bottom); +end; + +function Rect(Left, Top, Right, Bottom: Integer): TRect; +begin + Result.Left := Left; + Result.Top := Top; + Result.Bottom := Bottom; + Result.Right := Right; +end; + +function Point(X, Y: Integer): TPoint; +begin + Result.X := X; + Result.Y := Y; +end; + +function SmallPoint(X, Y: Integer): TSmallPoint; +begin + Result.X := X; + Result.Y := Y; +end; + +function SmallPoint(XY: LongWord): TSmallPoint; +begin + Result.X := SmallInt(XY and $0000FFFF); + Result.Y := SmallInt(XY shr 16); +end; + +function PtInRect(const Rect: TRect; const P: TPoint): Boolean; +begin + Result := (P.X >= Rect.Left) and (P.X < Rect.Right) and (P.Y >= Rect.Top) + and (P.Y < Rect.Bottom); +end; + +function IntersectRect(out Rect: TRect; const R1, R2: TRect): Boolean; +begin + Rect := R1; + if R2.Left > R1.Left then Rect.Left := R2.Left; + if R2.Top > R1.Top then Rect.Top := R2.Top; + if R2.Right < R1.Right then Rect.Right := R2.Right; + if R2.Bottom < R1.Bottom then Rect.Bottom := R2.Bottom; + Result := not IsRectEmpty(Rect); + if not Result then FillChar(Rect, SizeOf(Rect), 0); +end; + +function UnionRect(out Rect: TRect; const R1, R2: TRect): Boolean; +begin + Rect := R1; + if not IsRectEmpty(R2) then + begin + if R2.Left < R1.Left then Rect.Left := R2.Left; + if R2.Top < R1.Top then Rect.Top := R2.Top; + if R2.Right > R1.Right then Rect.Right := R2.Right; + if R2.Bottom > R1.Bottom then Rect.Bottom := R2.Bottom; + end; + Result := not IsRectEmpty(Rect); + if not Result then FillChar(Rect, SizeOf(Rect), 0); +end; + +function IsRectEmpty(const Rect: TRect): Boolean; +begin + Result := (Rect.Right <= Rect.Left) or (Rect.Bottom <= Rect.Top); +end; + +function OffsetRect(var Rect: TRect; DX: Integer; DY: Integer): Boolean; +begin + if @Rect <> nil then // Test to increase compatiblity with Windows + begin + Inc(Rect.Left, DX); + Inc(Rect.Right, DX); + Inc(Rect.Top, DY); + Inc(Rect.Bottom, DY); + Result := True; + end + else + Result := False; +end; + +function Bounds(ALeft, ATop, AWidth, AHeight: Integer): TRect; +begin + with Result do + begin + Left := ALeft; + Top := ATop; + Right := ALeft + AWidth; + Bottom := ATop + AHeight; + end; +end; + +function CenterPoint(const Rect: TRect): TPoint; +begin + with Rect do + begin + Result.X := (Right - Left) div 2 + Left; + Result.Y := (Bottom - Top) div 2 + Top; + end; +end; + +end. + diff --git a/System/D2006_orig/VarHlpr.pas b/System/D2006_orig/VarHlpr.pas new file mode 100644 index 0000000..c879195 --- /dev/null +++ b/System/D2006_orig/VarHlpr.pas @@ -0,0 +1,256 @@ +{ *********************************************************************** } +{ } +{ Delphi/C++Builder Runtime Library } +{ Helpers for C++ Variant binding. +{ } +{ Copyright (c) 2002 Borland Software Corporation } +{ } +{ *********************************************************************** } +unit VarHlpr; + +interface + + procedure VariantClear(var V: Variant); + procedure VariantArrayRedim(var V: Variant; High: Integer); + procedure VariantCast(const src: Variant; var dst: Variant; vt: Integer); + + procedure VariantCpy(const src: Variant; var dst: Variant); + procedure VariantAdd(const src: Variant; var dst: Variant); + procedure VariantSub(const src: Variant; var dst: Variant); + procedure VariantMul(const src: Variant; var dst: Variant); + procedure VariantDiv(const src: Variant; var dst: Variant); + procedure VariantMod(const src: Variant; var dst: Variant); + procedure VariantAnd(const src: Variant; var dst: Variant); + procedure VariantOr(const src: Variant; var dst: Variant); + procedure VariantXor(const src: Variant; var dst: Variant); + procedure VariantShl(const src: Variant; var dst: Variant); + procedure VariantShr(const src: Variant; var dst: Variant); + + function VariantAdd2(const V1: Variant; const V2: Variant): Variant; + function VariantSub2(const V1: Variant; const V2: Variant): Variant; + function VariantMul2(const V1: Variant; const V2: Variant): Variant; + function VariantDiv2(const V1: Variant; const V2: Variant): Variant; + function VariantMod2(const V1: Variant; const V2: Variant): Variant; + function VariantAnd2(const V1: Variant; const V2: Variant): Variant; + function VariantOr2(const V1: Variant; const V2: Variant): Variant; + function VariantXor2(const V1: Variant; const V2: Variant): Variant; + function VariantShl2(const V1: Variant; const V2: Variant): Variant; + function VariantShr2(const V1: Variant; const V2: Variant): Variant; + function VariantNot(const V1: Variant): Variant; + function VariantNeg(const V1: Variant): Variant; + + function VariantGetElement(const V: Variant; i1: integer): Variant; overload; + function VariantGetElement(const V: Variant; i1, i2: integer): Variant; overload; + function VariantGetElement(const V: Variant; i1, i2, i3: integer): Variant; overload; + function VariantGetElement(const V: Variant; i1, i2, i3, i4: integer): Variant; overload; + function VariantGetElement(const V: Variant; i1, i2, i3, i4, i5: integer): Variant; overload; + + procedure VariantPutElement(var V: Variant; const data: Variant; i1: integer); overload; + procedure VariantPutElement(var V: Variant; const data: Variant; i1, i2: integer); overload; + procedure VariantPutElement(var V: Variant; const data: Variant; i1, i2, i3: integer); overload; + procedure VariantPutElement(var V: Variant; const data: Variant; i1, i2, i3, i4: integer); overload; + procedure VariantPutElement(var V: Variant; const data: Variant; i1, i2, i3, i4, i5: integer); overload; + +implementation + +uses Variants, SysUtils; + +{ C++Builder helpers, implementation } + +procedure VariantClear(var V: Variant); +begin + VarClear(V); +end; + +procedure VariantCast(const src: Variant; var dst: Variant; vt: Integer); +begin + VarCast(dst, src, vt); +end; + +procedure VariantArrayRedim(var V: Variant; High: Integer); +begin + VarArrayRedim(V, High); +end; + +procedure VariantCpy(const src: Variant; var dst: Variant); +begin + dst := src; +end; + +procedure VariantAdd(const src: Variant; var dst: Variant); +begin + dst := dst + src; +end; + +procedure VariantSub(const src: Variant; var dst: Variant); +begin + dst := dst - src; +end; + +procedure VariantMul(const src: Variant; var dst: Variant); +begin + dst := dst * src; +end; + +procedure VariantDiv(const src: Variant; var dst: Variant); +begin + dst := dst / src; +end; + +procedure VariantMod(const src: Variant; var dst: Variant); +begin + dst := dst mod src; +end; + +procedure VariantAnd(const src: Variant; var dst: Variant); +begin + dst := dst and src; +end; + +procedure VariantOr(const src: Variant; var dst: Variant); +begin + dst := dst or src; +end; + +procedure VariantXor(const src: Variant; var dst: Variant); +begin + dst := dst xor src; +end; + +procedure VariantShl(const src: Variant; var dst: Variant); +begin + dst := dst shl src; +end; + +procedure VariantShr(const src: Variant; var dst: Variant); +begin + dst := dst shr src; +end; + +function VariantCmpEQ(const v1: Variant; const V2: Variant): Boolean; +begin + Result := v1 = v2; +end; + +function VariantCmpLT(const V1: Variant; const V2: Variant): Boolean; +begin + Result := V1 < V2; +end; + +function VariantCmpGT(const V1: Variant; const V2: Variant): Boolean; +begin + Result := V1 > V2; +end; + +function VariantAdd2(const V1: Variant; const V2: Variant): Variant; +begin + Result := v1 + V2; +end; + +function VariantSub2(const V1: Variant; const V2: Variant): Variant; +begin + Result := V1 - V2; +end; + +function VariantMul2(const V1: Variant; const V2: Variant): Variant; +begin + Result := V1 * V2; +end; + +function VariantDiv2(const V1: Variant; const V2: Variant): Variant; +begin + Result := V1 / V2; +end; + +function VariantMod2(const V1: Variant; const V2: Variant): Variant; +begin + Result := V1 mod V2; +end; + +function VariantAnd2(const V1: Variant; const V2: Variant): Variant; +begin + Result := V1 and V2; +end; + +function VariantOr2(const V1: Variant; const V2: Variant): Variant; +begin + Result := V1 or V2; +end; + +function VariantXor2(const V1: Variant; const V2: Variant): Variant; +begin + Result := V1 xor V2; +end; + +function VariantShl2(const V1: Variant; const V2: Variant): Variant; +begin + Result := V1 shl V2; +end; + +function VariantShr2(const V1: Variant; const V2: Variant): Variant; +begin + Result := V1 shr V2; +end; + +function VariantNot(const V1: Variant): Variant; +begin + Result := not V1; +end; + +function VariantNeg(const V1: Variant): Variant; +begin + Result := -V1; +end; + +function VariantGetElement(const V: Variant; i1: integer): Variant; overload; +begin + Result := V[i1]; +end; + +function VariantGetElement(const V: Variant; i1, i2: integer): Variant; overload; +begin + Result := V[i1, i2]; +end; + +function VariantGetElement(const V: Variant; i1, i2, i3: integer): Variant; overload; +begin + Result := V[I1, i2, i3]; +end; + +function VariantGetElement(const V: Variant; i1, i2, i3, i4: integer): Variant; overload; +begin + Result := V[i1, i2, i3, i4]; +end; + +function VariantGetElement(const V: Variant; i1, i2, i3, i4, i5: integer): Variant; overload; +begin + Result := V[i1, i2, i3, i4, i5]; +end; + +procedure VariantPutElement(var V: Variant; const data: Variant; i1: integer); overload; +begin + V[i1] := data; +end; + +procedure VariantPutElement(var V: Variant; const data: Variant; i1, i2: integer); overload; +begin + V[i1, i2] := data; +end; + +procedure VariantPutElement(var V: Variant; const data: Variant; i1, i2, i3: integer); overload; +begin + V[i1, i2, i3] := data; +end; + +procedure VariantPutElement(var V: Variant; const data: Variant; i1, i2, i3, i4: integer); overload; +begin + V[i1, i2, i3, i4] := data; +end; + +procedure VariantPutElement(var V: Variant; const data: Variant; i1, i2, i3, i4, i5: integer); overload; +begin + V[i1, i2, i3, i4, i5] := data; +end; + +end. + diff --git a/System/D2006_orig/VarUtils.pas b/System/D2006_orig/VarUtils.pas new file mode 100644 index 0000000..2671f67 --- /dev/null +++ b/System/D2006_orig/VarUtils.pas @@ -0,0 +1,2142 @@ + +{ *********************************************************************** } +{ } +{ Delphi / Kylix Cross-Platform Runtime Library } +{ Variant Utilities Unit } +{ } +{ Copyright (c) 1995-2001 Borland Software Corporation } +{ } +{ *********************************************************************** } + +unit VarUtils; + +{$BOOLEVAL OFF} + +interface + +uses + SysUtils, Types, SysConst; + +const +{$IFDEF MSWINDOWS} + GenericVarUtils = False; +{$ELSE} + GenericVarUtils = True; +{$ENDIF} + + GenericVariants = GenericVarUtils; + GenericOperations = GenericVariants; + GenericSafeArrays = GenericVarUtils; + +{$IFDEF MSWINDOWS} + // if we running in windows this should never be true + GenericSafeArrayUsesLibC = FALSE; +{$ELSE} + GenericSafeArrayUsesLibC = GenericSafeArrays; +{$ENDIF} + +// These entry point(s) are used by Variants.pas. The generic versions +// of these routines (which are enabled if this unit is compiled under +// an operating system other than Windows) are as similar as possible to +// their Windows counter parts. Please note that there are differences +// but they have been kept to a minimum. + +// error handling routines +function VarExceptionToResult(const E: Exception): HRESULT; + +// variant management routines +procedure VariantInit(var V: TVarData); stdcall; +function VariantClear(var V: TVarData): HRESULT; stdcall; +function VariantCopy(var Dest: TVarData; + const Source: TVarData): HRESULT; stdcall; +function VariantCopyInd(var Dest: TVarData; + const Source: TVarData): HRESULT; stdcall; +function VariantChangeType(var Dest: TVarData; const Source: TVarData; + wFlags: Word; VarType: Word): HRESULT; stdcall; + +// the following routines are late bound due to the fact they might not be implemented everywhere +var + + // variant coercion routine + VariantChangeTypeEx: function(var Dest: TVarData; const Source: TVarData; + LCID: Integer; wFlags: Word; VarType: Word): HRESULT; stdcall; + + // variant unioperation routines + VarNeg: function(const Source: TVarData; var Dest: TVarData): HRESULT; stdcall; + VarNot: function(const Source: TVarData; var Dest: TVarData): HRESULT; stdcall; + + // variant bioperation routines + VarAdd: function(const Left, Right: TVarData; var AResult: TVarData): HRESULT; stdcall; + VarSub: function(const Left, Right: TVarData; var AResult: TVarData): HRESULT; stdcall; + VarMul: function(const Left, Right: TVarData; var AResult: TVarData): HRESULT; stdcall; + VarDiv: function(const Left, Right: TVarData; var AResult: TVarData): HRESULT; stdcall; + VarIDiv: function(const Left, Right: TVarData; var AResult: TVarData): HRESULT; stdcall; + VarMod: function(const Left, Right: TVarData; var AResult: TVarData): HRESULT; stdcall; + VarAnd: function(const Left, Right: TVarData; var AResult: TVarData): HRESULT; stdcall; + VarOr: function(const Left, Right: TVarData; var AResult: TVarData): HRESULT; stdcall; + VarXor: function(const Left, Right: TVarData; var AResult: TVarData): HRESULT; stdcall; + + // variant compare routine + {$EXTERNALSYM VarCmp} + VarCmp: function(const Left, Right: TVarData; LCID: Integer; Flags: LongWord): HRESULT; stdcall; + + // string conversion routines + VarI4FromStr: function(const strIn: WideString; LCID: Integer; dwFlags: Longint; + out lOut: Longint): HRESULT; stdcall; + VarR4FromStr: function(const strIn: WideString; LCID: Integer; dwFlags: Longint; + out fltOut: Single): HRESULT; stdcall; + VarR8FromStr: function(const strIn: WideString; LCID: Integer; dwFlags: Longint; + out dblOut: Double): HRESULT; stdcall; + VarDateFromStr: function(const strIn: WideString; LCID: DWORD; dwFlags: Longint; + out dateOut: TDateTime): HRESULT; stdcall; + VarCyFromStr: function(const strIn: WideString; LCID: DWORD; dwFlags: Longint; + out cyOut: Currency): HRESULT; stdcall; + VarBoolFromStr: function(const strIn: WideString; LCID: Integer; dwFlags: Longint; + out boolOut: WordBool): HRESULT; stdcall; + + VarBstrFromCy: function(cyIn: Currency; LCID: Integer; dwFlags: Longint; + out bstrOut: WideString): HRESULT; stdcall; + VarBstrFromDate: function(dateIn: TDateTime; LCID: Integer; dwFlags: Longint; + out bstrOut: WideString): HRESULT; stdcall; + VarBstrFromBool: function(boolIn: WordBool; LCID: Integer; dwFlags: Longint; + out bstrOut: WideString): HRESULT; stdcall; + +// safe array routines +function SafeArrayCreate(VarType, DimCount: Integer; + const Bounds: TVarArrayBoundArray): PVarArray; stdcall; +function SafeArrayAllocDescriptor(DimCount: Integer; + out VarArray: PVarArray): HRESULT; stdcall; +function SafeArrayAllocData(VarArray: PVarArray): HRESULT; stdcall; + +function SafeArrayDestroy(VarArray: PVarArray): HRESULT; stdcall; +function SafeArrayDestroyDescriptor(VarArray: PVarArray): HRESULT; stdcall; +function SafeArrayDestroyData(VarArray: PVarArray): HRESULT; stdcall; + +function SafeArrayRedim(VarArray: PVarArray; const NewBound: TVarArrayBound): HRESULT; stdcall; +function SafeArrayCopy(SourceArray: PVarArray; out TargetArray: PVarArray): HRESULT; stdcall; +function SafeArrayCopyData(SourceArray, TargetArray: PVarArray): HRESULT; stdcall; + +function SafeArrayGetLBound(VarArray: PVarArray; Dim: Integer; + out LBound: Integer): HRESULT; stdcall; +function SafeArrayGetUBound(VarArray: PVarArray; Dim: Integer; + out UBound: Integer): HRESULT; stdcall; +function SafeArrayGetDim(VarArray: PVarArray): Integer; stdcall; + +function SafeArrayAccessData(VarArray: PVarArray; + out Data: Pointer): HRESULT; stdcall; +function SafeArrayUnaccessData(VarArray: PVarArray): HRESULT; stdcall; +function SafeArrayLock(VarArray: PVarArray): HRESULT; stdcall; +function SafeArrayUnlock(VarArray: PVarArray): HRESULT; stdcall; + +function SafeArrayGetElement(VarArray: PVarArray; Indices: PVarArrayCoorArray; + Data: Pointer): HRESULT; stdcall; +function SafeArrayPutElement(VarArray: PVarArray; Indices: PVarArrayCoorArray; + const Data: Pointer): HRESULT; stdcall; +function SafeArrayPtrOfIndex(VarArray: PVarArray; Indices: PVarArrayCoorArray; + var Address: Pointer): HRESULT; stdcall; +function SafeArrayGetElemSize(VarArray: PVarArray): LongWord; stdcall; + +procedure SafeArrayCheck(AResult: HRESULT); +procedure SafeArrayError(AResult: HRESULT); + +type + ESafeArrayError = class(Exception) + private + FErrorCode: HRESULT; + public + constructor CreateHResult(AResult: HRESULT; const AMessage: string = ''); + property ErrorCode: HRESULT read FErrorCode write FErrorCode; + end; + + ESafeArrayCreateError = class(ESafeArrayError); + ESafeArrayBoundsError = class(ESafeArrayError); + ESafeArrayLockedError = class(ESafeArrayError); + +// These equate to Window's constants but are renamed to less OS dependent +const + VAR_OK = HRESULT($00000000); // = Windows.S_OK + VAR_PARAMNOTFOUND = HRESULT($80020004); // = Windows.DISP_E_PARAMNOTFOUND + VAR_TYPEMISMATCH = HRESULT($80020005); // = Windows.DISP_E_TYPEMISMATCH + VAR_BADVARTYPE = HRESULT($80020008); // = Windows.DISP_E_BADVARTYPE + VAR_EXCEPTION = HRESULT($80020009); // = Windows.DISP_E_EXCEPTION + VAR_OVERFLOW = HRESULT($8002000A); // = Windows.DISP_E_OVERFLOW + VAR_BADINDEX = HRESULT($8002000B); // = Windows.DISP_E_BADINDEX + VAR_ARRAYISLOCKED = HRESULT($8002000D); // = Windows.DISP_E_ARRAYISLOCKED + VAR_NOTIMPL = HRESULT($80004001); // = Windows.E_NOTIMPL + VAR_OUTOFMEMORY = HRESULT($8007000E); // = Windows.E_OUTOFMEMORY + VAR_INVALIDARG = HRESULT($80070057); // = Windows.E_INVALIDARG + VAR_UNEXPECTED = HRESULT($8000FFFF); // = Windows.E_UNEXPECTED + + ARR_NONE = $0000; { no flags set } + ARR_FIXEDSIZE = $0010; { ActiveX.FADF_FIXEDSIZE, array may not be resized or reallocated } + ARR_OLESTR = $0100; { ActiveX.FADF_BSTR, an array of BSTRs } + ARR_UNKNOWN = $0200; { ActiveX.FADF_UNKNOWN, an array of IUnknown } + ARR_DISPATCH = $0400; { ActiveX.FADF_DISPATCH, an array of IDispatch } + ARR_VARIANT = $0800; { ActiveX.FADF_VARIANT, an array of VARIANTs } + + VAR_CMP_LT = 0; { These are returned by VarCmp } + VAR_CMP_EQ = 1; + VAR_CMP_GT = 2; + VAR_CMP_NULL = 3; + + VAR_LOCALE_USER_DEFAULT = $400; // = Windows.LOCALE_USER_DEFAULT + +type + TVarTypeToElementInfo = record + ValidBase: Boolean; + ValidElement: Boolean; + Size: Integer; + Flags: Word; + end; + +const + CMinArrayVarType = varEmpty; + CMaxArrayVarType = $0015; // varWord64 if that actually existed + CVarTypeToElementInfo: array [CMinArrayVarType..CMaxArrayVarType] of TVarTypeToElementInfo = ( + + { * = unsupported as of VCLv6 } + { varEmpty/vt_empty $00 } + (ValidBase: False; ValidElement: True; Size: 0; Flags: ARR_NONE), + { varNull/vt_null $01 } + (ValidBase: False; ValidElement: True; Size: 0; Flags: ARR_NONE), + { varSmallint/vt_i2 $02 } + (ValidBase: True; ValidElement: True; Size: 2; Flags: ARR_NONE), + { varInteger/vt_i4 $03 } + (ValidBase: True; ValidElement: True; Size: 4; Flags: ARR_NONE), + { varSingle/vt_r4 $04 } + (ValidBase: True; ValidElement: True; Size: 4; Flags: ARR_NONE), + { varDouble/vt_r8 $05 } + (ValidBase: True; ValidElement: True; Size: 8; Flags: ARR_NONE), + { varCurrency/vt_cy $06 } + (ValidBase: True; ValidElement: True; Size: 8; Flags: ARR_NONE), + { varDate/vt_date $07 } + (ValidBase: True; ValidElement: True; Size: 8; Flags: ARR_NONE), + { varOleStr/vt_bstr $08 } + (ValidBase: True; ValidElement: True; Size: 4; Flags: ARR_OLESTR), + { varDispatch/vt_dispatch $09 } + (ValidBase: True; ValidElement: True; Size: 4; Flags: ARR_DISPATCH), + { varError/vt_error $0A } + (ValidBase: True; ValidElement: True; Size: 4; Flags: ARR_NONE), + { varBoolean/vt_bool $0B } + (ValidBase: True; ValidElement: True; Size: 2; Flags: ARR_NONE), + { varVariant/vt_variant $0C } + (ValidBase: True; ValidElement: True; Size: 16; Flags: ARR_VARIANT), + { varUnknown/vt_unknown $0D } + (ValidBase: True; ValidElement: True; Size: 4; Flags: ARR_UNKNOWN), + {*varDecimal/vt_decimal $0E } + (ValidBase: False; ValidElement: False; Size: 14; Flags: ARR_NONE), + {*unused/undefined $0F } + (ValidBase: False; ValidElement: False; Size: 0; Flags: ARR_NONE), + { varShortInt/vt_i1 $10 } + (ValidBase: True; ValidElement: True; Size: 1; Flags: ARR_NONE), + { varByte/vt_ui1 $11 } + (ValidBase: True; ValidElement: True; Size: 1; Flags: ARR_NONE), + { varWord/vt_ui2 $12 } + (ValidBase: True; ValidElement: True; Size: 2; Flags: ARR_NONE), + { varSmallWord/vt_ui4 $13 } + (ValidBase: True; ValidElement: True; Size: 4; Flags: ARR_NONE), + { varInt64/vt_i8 $14 } + (ValidBase: False; ValidElement: True; Size: 8; Flags: ARR_NONE), + {*varWord64/vt_ui8 $15 } + (ValidBase: False; ValidElement: False; Size: 8; Flags: ARR_NONE)); + +implementation + +// This defined is used to insure that rangechecking is handled correctly +{$IFOPT R-} + {$DEFINE RANGECHECKINGOFF} +{$ENDIF} + +{$IFDEF MSWINDOWS} +uses Windows; +{$ELSE} + {$IF GenericSafeArrayUsesLibC} + uses Libc; + {$IFEND} +{$ENDIF} + +{$IFDEF MSWINDOWS} +const + oleaut = 'oleaut32.dll'; +{$ENDIF} + +// has the jump table been initialized yet +var + VariantInited: Boolean = False; + +{******************************************************************************} +{ Common Variant Functions } +{******************************************************************************} + +function VarExceptionToResult(const E: Exception): HRESULT; +begin + // string to int conversion error + // string to float conversion error + // string to currency conversion error + // string to datetime conversion error + // float to currency conversion error + // float to datetime conversion error + + if E is EConvertError then + Result := VAR_TYPEMISMATCH + + // float range error + else if E is SysUtils.EOverflow then // Symbol collision with LibC + Result := VAR_OVERFLOW + else if E is EUnderflow then + Result := VAR_OVERFLOW + + // int range error + else if E is ERangeError then + Result := VAR_OVERFLOW + + // rounding overflow, possible during string conversion + else if E is EIntOverflow then + Result := VAR_OVERFLOW + + // something really really bad happened + else if E is EOutOfMemory then + Result := VAR_OUTOFMEMORY + + // unknown type of exception + else + Result := VAR_INVALIDARG; +end; + +{******************************************************************************} +{ Variant Functions } +{******************************************************************************} + +{$IF not GenericVariants} +procedure VariantInit; external oleaut name 'VariantInit'; +function VariantClear; external oleaut name 'VariantClear'; +function VariantCopy; external oleaut name 'VariantCopy'; +function VariantCopyInd; external oleaut name 'VariantCopyInd'; +function VariantChangeType; external oleaut name 'VariantChangeType'; + +{$ELSE} + +procedure VariantInit(var V: TVarData); +begin + V.VType := varEmpty; + FillChar(V.VBytes, SizeOf(V.VBytes), 0); +end; + +function VariantClear(var V: TVarData): HRESULT; +begin + Result := VAR_OK; + + // var is an array + if (V.VType and varArray) <> 0 then + Result := SafeArrayDestroy(V.VArray) + else + begin + + // var is not byref + if (V.VType and varByRef) = 0 then + case V.VType of + varEmpty, varNull, varSmallint, varInteger, varSingle, varDouble, + varCurrency, varDate, varError, varBoolean, varShortInt, varByte, + varWord, varLongWord:; + // the fill char later on will take care of these + varOleStr: + WideString(Pointer(V.VOleStr)) := ''; + varDispatch: + IUnknown(V.VDispatch) := nil; + //varVariant: + // taken care of by the above ByRef code but we should error if not + varUnknown: + IUnknown(V.VUnknown) := nil; + else + Result := VAR_BADVARTYPE; + end; + end; + + // all is swell so lets slick it + if Result = VAR_OK then + VariantInit(V); +end; + +function VariantCopy(var Dest: TVarData; const Source: TVarData): HRESULT; +begin + // Dest is pointing to the source, nothing need be done + if @Source = @Dest then + Result := VAR_OK + else + begin + + // wipe out the destination + Result := VariantClear(Dest); + if Result = VAR_OK then + begin + + // var is an array! + if (Source.VType and varArray) <> 0 then + Result := SafeArrayCopy(Source.VArray, Dest.VArray) + else + begin + if (Source.VType and varByRef) <> 0 then // var is byref + Dest.VPointer := Source.VPointer + else + case (Source.VType and varTypeMask) of // strip off modifier flags + varEmpty, varNull:; + // nothing do! + varSmallint, varInteger, varSingle, varDouble, varCurrency, varDate, + varError, varBoolean, varShortInt, varByte, varWord, varLongWord: + Move(Source.VBytes, Dest.VBytes, SizeOf(Dest.VBytes)); + varOleStr: + WideString(Pointer(Dest.VOleStr)) := Copy(Source.VOleStr, 1, MaxInt); + varDispatch: + IUnknown(Dest.VDispatch) := IUnknown(Source.VDispatch); + //varVariant: + // taken care of by the above ByRef code but we should error if not + varUnknown: + IUnknown(Dest.VUnknown) := IUnknown(Source.VUnknown); + else + Result := VAR_BADVARTYPE; + end; + end; + + // if all is swell then copy over the VType + if Result = VAR_OK then + Dest.VType := Source.VType; + end; + end; +end; + +function VariantCopyInd(var Dest: TVarData; const Source: TVarData): HRESULT; +begin + if (Source.VType and varByRef) = 0 then // var is NOT byref, so just copy + Result := VariantCopy(Dest, Source) + else if (Source.VType and varArray) <> 0 then // var is an array, bad! + Result := VAR_INVALIDARG + else + begin + Result := VAR_OK; + case (Source.VType and varTypeMask) of // strip off modifier flags + varEmpty, varNull:; + // do nothing + varSmallint: + Dest.VSmallInt := PSmallInt(Source.VPointer)^; + varInteger: + Dest.VInteger := PInteger(Source.VPointer)^; + varSingle: + Dest.VSingle := PSingle(Source.VPointer)^; + varDouble: + Dest.VDouble := PDouble(Source.VPointer)^; + varCurrency: + Dest.VCurrency := PCurrency(Source.VPointer)^; + varDate: + Dest.VDate := PDate(Source.VPointer)^; + varOleStr: + WideString(Pointer(Dest.VOleStr)) := Copy(PPWideChar(Source.VPointer)^, 1, MaxInt); + varDispatch: + IUnknown(Dest.VDispatch) := IUnknown(PDispatch(Source.VPointer)^); + varError: + Dest.VError := System.PError(Source.VPointer)^; + varBoolean: + Dest.VBoolean := PWordBool(Source.VPointer)^; + varVariant: + Variant(Dest) := PVariant(Source.VPointer)^; { this in turn will cause a VarCopy[Ind] } + varUnknown: + IUnknown(Dest.VUnknown) := IUnknown(PUnknown(Source.VPointer)^); + varShortInt: + Dest.VShortInt := PShortInt(Source.VPointer)^; + varByte: + Dest.VByte := PByte(Source.VPointer)^; + varWord: + Dest.VWord := PWord(Source.VPointer)^; + varLongWord: + Dest.VLongWord := PLongWord(Source.VPointer)^; + else + Result := VAR_BADVARTYPE; + end; + if Result = VAR_OK then + Dest.VType := Source.VType and VarTypeMask; // strip off modifier flags + end; +end; + +function VariantChangeOleStrIntoByteArray(var Dest: TVarData; + const Source: TVarData): HRESULT; +var + LArray: PVarArray; + LData: Pointer; + LCount: Integer; + LVarBounds: array[0..0] of TVarArrayBound; +begin + Result := VAR_OK; + + // how big are we talking? + LCount := Length(Source.VOleStr) * SizeOf(WideChar); + LVarBounds[0].LowBound := 0; + LVarBounds[0].ElementCount := LCount; + + // array please + LArray := SafeArrayCreate(varByte, 1, PVarArrayBoundArray(@LVarBounds)^); + try + + // now aquire the target + Result := SafeArrayLock(LArray); + if Result = VAR_OK then + try + + // take aim + Result := SafeArrayAccessData(LArray, LData); + if Result = VAR_OK then + try + + // move the data + Move(Source.VOleStr^, LData^, LCount); + finally + Result := SafeArrayUnaccessData(LArray); + end; + + // clean up + finally + if Result = VAR_OK then + Result := SafeArrayUnlock(LArray) + else + SafeArrayUnlock(LArray); + end; + + // if all is swell then finish up the destination + finally + if Result <> VAR_OK then + SafeArrayDestroy(LArray) + else + begin + Dest.VType := varArray + varByte; + Dest.VArray := LArray; + end; + end; +end; + +function VariantChangeByteArrayIntoOleStr(var Dest: TVarData; + const Source: TVarData): HRESULT; +var + LArray: PVarArray; + LData: Pointer; + LCount: Integer; +begin + + // we know its a byte array so lets make sure it only has one dimension and + // it's element size is one and dest is not the source + LArray := Source.VArray; + if (LArray.DimCount <> 1) or (LArray.ElementSize <> 1) or (@Dest = @Source) then + Result := VAR_INVALIDARG + else + begin + + // lock things down for a bit + Result := SafeArrayLock(LArray); + if Result = VAR_OK then + try + + // now try and get the data + Result := SafeArrayAccessData(LArray, LData); + if Result = VAR_OK then + try + + // how big is the data + LCount := LArray.Bounds[0].ElementCount; + + // resize the destination + SetLength(WideString(Pointer(Dest.VOleStr)), + (LCount + SizeOf(WideChar) - 1) div SizeOf(WideChar)); + + // mark it as being a ole str + Dest.VType := varOleStr; + + // finally move the data + Move(LData^, Dest.VOleStr^, LCount); + finally + Result := SafeArrayUnaccessData(LArray); + end; + + // finally release the lock + finally + if Result = VAR_OK then + Result := SafeArrayUnlock(LArray) + else + SafeArrayUnlock(LArray); + end; + end; +end; + +function VariantChangeSimpleIntoSimple(var Dest: TVarData; const Source: TVarData; + Flags: Word; VarType: Word): HRESULT; +var + LSource: TVarData; +begin + + // this will take care of both ByRef Source and Dest = Source + Result := VariantCopyInd(LSource, Source); + if Result = VAR_OK then + try + Result := VariantClear(Dest); + + {$RANGECHECKS ON} + if Result = VAR_OK then + try + case LSource.VType of + varEmpty: + case VarType of + varEmpty, varNull, varSmallInt, varInteger, varSingle, varDouble, + varCurrency, varDate, varOleStr, varBoolean, varShortInt, varByte, + varWord, varLongWord:; + // these are taken care of by the above Dest clear + else + Result := VAR_TYPEMISMATCH; + end; + varNull: + case VarType of + varNull:; + // this is taken care of by the above Dest clear + else + Result := VAR_TYPEMISMATCH; + end; + varSmallint: + case VarType of + varEmpty, varNull:; + varSmallInt: + Dest.VSmallInt := LSource.VSmallInt; + varInteger: + Dest.VInteger := LSource.VSmallInt; + varSingle: + Dest.VSingle := LSource.VSmallInt; + varDouble: + Dest.VDouble := LSource.VSmallInt; + varCurrency: + Dest.VCurrency := LSource.VSmallInt; + varDate: + Dest.VDate := FloatToDateTime(LSource.VSmallInt); + varOleStr: + WideString(Pointer(Dest.VOleStr)) := IntToStr(LSource.VSmallInt); + varBoolean: + Dest.VBoolean := LSource.VSmallInt <> 0; + varShortInt: + Dest.VShortInt := LSource.VSmallInt; + varByte: + Dest.VByte := LSource.VSmallInt; + varWord: + Dest.VWord := LSource.VSmallInt; + varLongWord: + Dest.VLongWord := LSource.VSmallInt; + else + Result := VAR_TYPEMISMATCH; + end; + varInteger: + case VarType of + varEmpty, varNull:; + varSmallInt: + Dest.VSmallInt := LSource.VInteger; + varInteger: + Dest.VInteger := LSource.VInteger; + varSingle: + Dest.VSingle := LSource.VInteger; + varDouble: + Dest.VDouble := LSource.VInteger; + varCurrency: + Dest.VCurrency := LSource.VInteger; + varDate: + Dest.VDate := FloatToDateTime(LSource.VInteger); + varOleStr: + WideString(Pointer(Dest.VOleStr)) := IntToStr(LSource.VInteger); + varBoolean: + Dest.VBoolean := LSource.VInteger <> 0; + varShortInt: + Dest.VShortInt := LSource.VInteger; + varByte: + Dest.VByte := LSource.VInteger; + varWord: + Dest.VWord := LSource.VInteger; + varLongWord: + Dest.VLongWord := LSource.VInteger; + else + Result := VAR_TYPEMISMATCH; + end; + varSingle: + case VarType of + varEmpty, varNull:; + varSmallInt: + Dest.VSmallInt := Round(LSource.VSingle); + varInteger: + Dest.VInteger := Round(LSource.VSingle); + varSingle: + Dest.VSingle := LSource.VSingle; + varDouble: + Dest.VDouble := LSource.VSingle; + varCurrency: + Dest.VCurrency := FloatToCurr(LSource.VSingle); + varDate: + Dest.VDate := FloatToDateTime(LSource.VSingle); + varOleStr: + WideString(Pointer(Dest.VOleStr)) := FloatToStr(LSource.VSingle); + varBoolean: + Dest.VBoolean := LSource.VSingle <> 0; + varShortInt: + Dest.VShortInt := Round(LSource.VSingle); + varByte: + Dest.VByte := Round(LSource.VSingle); + varWord: + Dest.VWord := Round(LSource.VSingle); + varLongWord: + Dest.VLongWord := Round(LSource.VSingle); + else + Result := VAR_TYPEMISMATCH; + end; + varDouble: + case VarType of + varEmpty, varNull:; + varSmallInt: + Dest.VSmallInt := Round(LSource.VDouble); + varInteger: + Dest.VInteger := Round(LSource.VDouble); + varSingle: + Dest.VSingle := LSource.VDouble; + varDouble: + Dest.VDouble := LSource.VDouble; + varCurrency: + Dest.VCurrency := FloatToCurr(LSource.VDouble); + varDate: + Dest.VDate := FloatToDateTime(LSource.VDouble); + varOleStr: + WideString(Pointer(Dest.VOleStr)) := FloatToStr(LSource.VDouble); + varBoolean: + Dest.VBoolean := LSource.VDouble <> 0; + varShortInt: + Dest.VShortInt := Round(LSource.VDouble); + varByte: + Dest.VByte := Round(LSource.VDouble); + varWord: + Dest.VWord := Round(LSource.VDouble); + varLongWord: + Dest.VLongWord := Round(LSource.VDouble); + else + Result := VAR_TYPEMISMATCH; + end; + varCurrency: + case VarType of + varEmpty, varNull:; + varSmallInt: + Dest.VSmallInt := Round(LSource.VCurrency); + varInteger: + Dest.VInteger := Round(LSource.VCurrency); + varSingle: + Dest.VSingle := LSource.VCurrency; + varDouble: + Dest.VDouble := LSource.VCurrency; + varCurrency: + Dest.VCurrency := LSource.VCurrency; + varDate: + Dest.VDate := FloatToDateTime(LSource.VCurrency); + varOleStr: + WideString(Pointer(Dest.VOleStr)) := CurrToStr(LSource.VCurrency); + varBoolean: + Dest.VBoolean := LSource.VCurrency <> 0; + varShortInt: + Dest.VShortInt := Round(LSource.VCurrency); + varByte: + Dest.VByte := Round(LSource.VCurrency); + varWord: + Dest.VWord := Round(LSource.VCurrency); + varLongWord: + Dest.VLongWord := Round(LSource.VCurrency); + else + Result := VAR_TYPEMISMATCH; + end; + varDate: + case VarType of + varEmpty, varNull:; + varSmallInt: + Dest.VSmallInt := Round(LSource.VDate); + varInteger: + Dest.VInteger := Round(LSource.VDate); + varSingle: + Dest.VSingle := LSource.VDate; + varDouble: + Dest.VDouble := LSource.VDate; + varCurrency: + Dest.VCurrency := FloatToCurr(LSource.VDate); + varDate: + Dest.VDate := LSource.VDate; + varOleStr: + begin + if Trunc(LSource.VDate) = 0 then + WideString(Pointer(Dest.VOleStr)) := TimeToStr(LSource.VDate) + else + WideString(Pointer(Dest.VOleStr)) := DateTimeToStr(LSource.VDate); + end; + varBoolean: + Dest.VBoolean := LSource.VDate <> 0; + varShortInt: + Dest.VShortInt := Round(LSource.VDate); + varByte: + Dest.VByte := Round(LSource.VDate); + varWord: + Dest.VWord := Round(LSource.VDate); + varLongWord: + Dest.VLongWord := Round(LSource.VDate); + else + Result := VAR_TYPEMISMATCH; + end; + varOleStr: + case VarType of + varEmpty, varNull:; + varSmallInt: + Dest.VSmallInt := StrToInt(WideString(LSource.VOleStr)); + varInteger: + Dest.VInteger := StrToInt(WideString(LSource.VOleStr)); + varSingle: + Dest.VSingle := StrToFloat(WideString(LSource.VOleStr)); + varDouble: + Dest.VDouble := StrToFloat(WideString(LSource.VOleStr)); + varCurrency: + Dest.VCurrency := StrToCurr(WideString(LSource.VOleStr)); + varDate: + Dest.VDate := StrToDateTime(WideString(LSource.VOleStr)); + varOleStr: + WideString(Pointer(Dest.VOleStr)) := Copy(LSource.VOleStr, 1, MaxInt); + varBoolean: + Dest.VBoolean := StrToBool(WideString(LSource.VOleStr)); + varShortInt: + Dest.VShortInt := StrToInt(WideString(LSource.VOleStr)); + varByte: + Dest.VByte := StrToInt(WideString(LSource.VOleStr)); + varWord: + Dest.VWord := StrToInt(WideString(LSource.VOleStr)); + varLongWord: + Dest.VLongWord := StrToInt64(WideString(LSource.VOleStr)); + else + Result := VAR_TYPEMISMATCH; + end; + varDispatch: + Result := VAR_TYPEMISMATCH; + varError: + Result := VAR_TYPEMISMATCH; + varBoolean: + case VarType of + varEmpty, varNull:; + varSmallInt: + Dest.VSmallInt := SmallInt(LSource.VBoolean); + varInteger: + Dest.VInteger := Integer(LSource.VBoolean); + varSingle: + Dest.VSingle := Integer(LSource.VBoolean); + varDouble: + Dest.VDouble := Integer(LSource.VBoolean); + varCurrency: + Dest.VCurrency := Integer(LSource.VBoolean); + varDate: + Dest.VDate := Integer(LSource.VBoolean); + varOleStr: + WideString(Pointer(Dest.VOleStr)) := BoolToStr(LSource.VBoolean); + varBoolean: + Dest.VBoolean := LSource.VBoolean; + varShortInt: + Dest.VShortInt := ShortInt(LSource.VBoolean); + varByte: + Dest.VByte := Byte(LSource.VBoolean); + varWord: + Dest.VWord := Word(LSource.VBoolean); + varLongWord: + Dest.VLongWord := LongWord(LSource.VBoolean); + else + Result := VAR_TYPEMISMATCH; + end; + varVariant: + case VarType of + varEmpty, varNull:; + varSmallInt: + Dest.VSmallInt := PVariant(LSource.VPointer)^; + varInteger: + Dest.VInteger := PVariant(LSource.VPointer)^; + varSingle: + Dest.VSingle := PVariant(LSource.VPointer)^; + varDouble: + Dest.VDouble := PVariant(LSource.VPointer)^; + varCurrency: + Dest.VCurrency := PVariant(LSource.VPointer)^; + varDate: + Dest.VDate := PVariant(LSource.VPointer)^; + varOleStr: + WideString(Pointer(Dest.VOleStr)) := PVariant(LSource.VPointer)^; + varBoolean: + Dest.VBoolean := PVariant(LSource.VPointer)^; + varShortInt: + Dest.VShortInt := PVariant(LSource.VPointer)^; + varByte: + Dest.VByte := PVariant(LSource.VPointer)^; + varWord: + Dest.VWord := PVariant(LSource.VPointer)^; + varLongWord: + Dest.VLongWord := PVariant(LSource.VPointer)^; + else + Result := VAR_TYPEMISMATCH; + end; + varUnknown: + case VarType of + varEmpty, varNull:; + else + Result := VAR_TYPEMISMATCH; + end; + varShortInt: + case VarType of + varEmpty, varNull:; + varSmallInt: + Dest.VSmallInt := LSource.VSmallInt; + varInteger: + Dest.VInteger := LSource.VSmallInt; + varSingle: + Dest.VSingle := LSource.VSmallInt; + varDouble: + Dest.VDouble := LSource.VSmallInt; + varCurrency: + Dest.VCurrency := LSource.VSmallInt; + varDate: + Dest.VDate := LSource.VSmallInt; + varOleStr: + WideString(Pointer(Dest.VOleStr)) := IntToStr(LSource.VSmallInt); + varBoolean: + Dest.VBoolean := LSource.VSmallInt <> 0; + varShortInt: + Dest.VShortInt := LSource.VSmallInt; + varByte: + Dest.VByte := LSource.VSmallInt; + varWord: + Dest.VWord := LSource.VSmallInt; + varLongWord: + Dest.VLongWord := LSource.VSmallInt; + else + Result := VAR_TYPEMISMATCH; + end; + varByte: + case VarType of + varEmpty, varNull:; + varSmallInt: + Dest.VSmallInt := LSource.VByte; + varInteger: + Dest.VInteger := LSource.VByte; + varSingle: + Dest.VSingle := LSource.VByte; + varDouble: + Dest.VDouble := LSource.VByte; + varCurrency: + Dest.VCurrency := LSource.VByte; + varDate: + Dest.VDate := LSource.VByte; + varOleStr: + WideString(Pointer(Dest.VOleStr)) := IntToStr(LSource.VByte); + varBoolean: + Dest.VBoolean := LSource.VByte <> 0; + varShortInt: + Dest.VShortInt := LSource.VByte; + varByte: + Dest.VByte := LSource.VByte; + varWord: + Dest.VWord := LSource.VByte; + varLongWord: + Dest.VLongWord := LSource.VByte; + else + Result := VAR_TYPEMISMATCH; + end; + varWord: + case VarType of + varEmpty, varNull:; + varSmallInt: + Dest.VSmallInt := LSource.VWord; + varInteger: + Dest.VInteger := LSource.VWord; + varSingle: + Dest.VSingle := LSource.VWord; + varDouble: + Dest.VDouble := LSource.VWord; + varCurrency: + Dest.VCurrency := LSource.VWord; + varDate: + Dest.VDate := LSource.VWord; + varOleStr: + WideString(Pointer(Dest.VOleStr)) := IntToStr(LSource.VWord); + varBoolean: + Dest.VBoolean := LSource.VWord <> 0; + varShortInt: + Dest.VShortInt := LSource.VWord; + varByte: + Dest.VByte := LSource.VWord; + varWord: + Dest.VWord := LSource.VWord; + varLongWord: + Dest.VLongWord := LSource.VWord; + else + Result := VAR_TYPEMISMATCH; + end; + varLongWord: + case VarType of + varEmpty, varNull:; + varSmallInt: + Dest.VSmallInt := LSource.VLongWord; + varInteger: + Dest.VInteger := LSource.VLongWord; + varSingle: + Dest.VSingle := LSource.VLongWord; + varDouble: + Dest.VDouble := LSource.VLongWord; + varCurrency: + Dest.VCurrency := LSource.VLongWord; + varDate: + Dest.VDate := LSource.VLongWord; + varOleStr: + WideString(Pointer(Dest.VOleStr)) := IntToStr(LSource.VLongWord); + varBoolean: + Dest.VBoolean := LSource.VLongWord <> 0; + varShortInt: + Dest.VShortInt := LSource.VLongWord; + varByte: + Dest.VByte := LSource.VLongWord; + varWord: + Dest.VWord := LSource.VLongWord; + varLongWord: + Dest.VLongWord := LSource.VLongWord; + else + Result := VAR_TYPEMISMATCH; + end; + else + Result := VAR_BADVARTYPE; + end; + + if Result = VAR_OK then + Dest.VType := VarType; + except + on E: Exception do + Result := VarExceptionToResult(E); + end; + + // Only turn range checking off if it was off to begin with + {$IFDEF RANGECHECKINGOFF} + {$RANGECHECKS OFF} + {$ENDIF} + finally + VariantClear(LSource); + end; +end; + +{ Known limitations in VariantChangeType + Cannot convert from or to anything that is ByRef except for exact + identity copies + Cannot convert from or to arrays except for exact identity copies + and the rather strange, and undocumented, Array of Byte <--> OleStr + Can convert from a variant containing a reference to a variant but not back } +function VariantChangeType(var Dest: TVarData; const Source: TVarData; + wFlags: Word; VarType: Word): HRESULT; +begin + // source is an olestr and dest is.. + if Source.VType = varOleStr then + + // ..array of bytes, that is easy too + if VarType = varArray + varByte then + Result := VariantChangeOleStrIntoByteArray(Dest, Source) + + // ..anything else let simple try to handle it + else + Result := VariantChangeSimpleIntoSimple(Dest, Source, wFlags, VarType) + + // source is an array of bytes and dest is.. + else if Source.VType = varArray + varByte then + + // ..olestr, easy + if VarType = varOleStr then + Result := VariantChangeByteArrayIntoOleStr(Dest, Source) + + // ..anything else, fail + else + Result := VAR_INVALIDARG + + // anything into itself + else if Source.VType = VarType then + Result := VariantCopy(Dest, Source) + + // simple to anything else, let the simple case try to handle it + else + Result := VariantChangeSimpleIntoSimple(Dest, Source, wFlags, VarType); +end; +{$IFEND} + +{******************************************************************************} +{ Backup Variant Functions/Operations } +{******************************************************************************} +// Known limitations in the following functions +// LCID is currently ignored but for future compatiblity you should always +// pass VAR_LOCALE_USER_DEFAULT (which equals $400); + +function BackupVariantChangeTypeEx(var Dest: TVarData; const Source: TVarData; + LCID: Integer; wFlags: Word; VarType: Word): HRESULT; stdcall; +begin + if LCID <> VAR_LOCALE_USER_DEFAULT then + Result := VAR_NOTIMPL + else + Result := VariantChangeType(Dest, Source, wFlags, VarType); +end; + +{ we don't attempt to implement any of the uni/bi/cmp operators} +function UniUnimplemented(const Source: TVarData; var Dest: TVarData): HRESULT; stdcall; +begin + Result := VAR_NOTIMPL; +end; + +function BiUnimplemented(const Left, Right: TVarData; var AResult: TVarData): HRESULT; stdcall; +begin + Result := VAR_NOTIMPL; +end; + +function CmpUnimplemented(const Left, Right: TVarData; LCID: Integer; Flags: LongWord): HRESULT; stdcall; +begin + Result := VAR_NOTIMPL; +end; + +// Known limitations in these conversion functions +// Windows is much more tolerant of extra characters when converting +// ints, floats, dates, currs and bools into strings. +const + CResult: array [False..True] of HRESULT = (VAR_INVALIDARG, VAR_OK); + +function BackupVarI4FromStr(const strIn: WideString; LCID: Integer; dwFlags: Longint; + out lOut: Longint): HRESULT; stdcall; +begin + if LCID <> VAR_LOCALE_USER_DEFAULT then + Result := VAR_NOTIMPL + else + Result := CResult[TryStrToInt(strIn, lOut)]; +end; + +function BackupVarR4FromStr(const strIn: WideString; LCID: Integer; dwFlags: Longint; + out fltOut: Single): HRESULT; stdcall; +begin + if LCID <> VAR_LOCALE_USER_DEFAULT then + Result := VAR_NOTIMPL + else + Result := CResult[TryStrToFloat(strIn, fltOut)]; +end; + +function BackupVarR8FromStr(const strIn: WideString; LCID: Integer; dwFlags: Longint; + out dblOut: Double): HRESULT; stdcall; +begin + if LCID <> VAR_LOCALE_USER_DEFAULT then + Result := VAR_NOTIMPL + else + Result := CResult[TryStrToFloat(strIn, dblOut)]; +end; + +function BackupVarDateFromStr(const strIn: WideString; LCID: DWORD; dwFlags: Longint; + out dateOut: TDateTime): HRESULT; stdcall; +begin + if LCID <> VAR_LOCALE_USER_DEFAULT then + Result := VAR_NOTIMPL + else + Result := CResult[TryStrToDateTime(strIn, dateOut)]; +end; + +function BackupVarCyFromStr(const strIn: WideString; LCID: DWORD; dwFlags: Longint; + out cyOut: Currency): HRESULT; stdcall; +begin + if LCID <> VAR_LOCALE_USER_DEFAULT then + Result := VAR_NOTIMPL + else + Result := CResult[TryStrToCurr(strIn, cyOut)]; +end; + +function BackupVarBoolFromStr(const strIn: WideString; LCID: Integer; dwFlags: Longint; + out boolOut: WordBool): HRESULT; stdcall; +var + LBoolean: Boolean; +begin + if LCID <> VAR_LOCALE_USER_DEFAULT then + Result := VAR_NOTIMPL + else + begin + Result := CResult[TryStrToBool(strIn, LBoolean)]; + boolOut := LBoolean; + end; +end; + + +function BackupVarBStrFromCy(cyIn: Currency; LCID: Integer; dwFlags: Longint; + out bstrOut: WideString): HRESULT; stdcall; +begin + if LCID <> VAR_LOCALE_USER_DEFAULT then + Result := VAR_NOTIMPL + else + begin + bstrOut := CurrToStr(cyIn); + Result := VAR_OK; + end; +end; + +function BackupVarBStrFromDate(dateIn: TDateTime; LCID: Integer; dwFlags: Longint; + out bstrOut: WideString): HRESULT; stdcall; +begin + if LCID <> VAR_LOCALE_USER_DEFAULT then + Result := VAR_NOTIMPL + else + begin + bstrOut := DateTimeToStr(dateIn); + Result := VAR_OK; + end; +end; + +function BackupVarBStrFromBool(boolIn: WordBool; LCID: Integer; dwFlags: Longint; + out bstrOut: WideString): HRESULT; stdcall; +begin + if LCID <> VAR_LOCALE_USER_DEFAULT then + Result := VAR_NOTIMPL + else + begin + bstrOut := BoolToStr(boolIn); + Result := VAR_OK; + end; +end; + +{******************************************************************************} +{ SafeArray Functions } +{******************************************************************************} + +{$IF not GenericSafeArrays} +function SafeArrayCreate; external oleaut name 'SafeArrayCreate'; +function SafeArrayAllocDescriptor; external oleaut name 'SafeArrayAllocDescriptor'; +function SafeArrayAllocData; external oleaut name 'SafeArrayAllocData'; +function SafeArrayDestroy; external oleaut name 'SafeArrayDestroy'; +function SafeArrayDestroyDescriptor; external oleaut name 'SafeArrayDestroyDescriptor'; +function SafeArrayDestroyData; external oleaut name 'SafeArrayDestroyData'; +function SafeArrayRedim; external oleaut name 'SafeArrayRedim'; +function SafeArrayCopy; external oleaut name 'SafeArrayCopy'; +function SafeArrayCopyData; external oleaut name 'SafeArrayCopyData'; +function SafeArrayGetLBound; external oleaut name 'SafeArrayGetLBound'; +function SafeArrayGetUBound; external oleaut name 'SafeArrayGetUBound'; +function SafeArrayGetDim; external oleaut name 'SafeArrayGetDim'; +function SafeArrayAccessData; external oleaut name 'SafeArrayAccessData'; +function SafeArrayUnaccessData; external oleaut name 'SafeArrayUnaccessData'; +function SafeArrayLock; external oleaut name 'SafeArrayLock'; +function SafeArrayUnlock; external oleaut name 'SafeArrayUnlock'; +function SafeArrayGetElement; external oleaut name 'SafeArrayGetElement'; +function SafeArrayPutElement; external oleaut name 'SafeArrayPutElement'; +function SafeArrayPtrOfIndex; external oleaut name 'SafeArrayPtrOfIndex'; +function SafeArrayGetElemSize; external oleaut name 'SafeArrayGetElemsize'; + +{$ELSE} +type + TSafeArrayValidateCheck = (savLockCheck); + TSafeArrayValidateChecks = set of TSafeArrayValidateCheck; +const + cCheckAll: TSafeArrayValidateChecks = [savLockCheck]; + +function SafeArrayValidate(VarArray: PVarArray; AndCheck: TSafeArrayValidateChecks = []): HRESULT; +const + cResults: array [Boolean] of HRESULT = (VAR_INVALIDARG, VAR_OK); + cLockResult: array [Boolean] of HRESULT = (VAR_ARRAYISLOCKED, VAR_OK); +begin + Result := cResults[VarArray <> nil]; + if (savLockCheck in AndCheck) and + (Result = VAR_OK) then + Result := cLockResult[VarArray^.LockCount = 0]; +end; + +function SafeArrayCalculateElementAddress(VarArray: PVarArray; AElement: Integer): Pointer; +begin + Result := Pointer(Integer(VarArray^.Data) + (AElement * VarArray^.ElementSize)); +end; + +function SafeArrayValidateAndCalculateAddress(VarArray: PVarArray; + Indices: PVarArrayCoorArray; var Address: Pointer; Lockit: Boolean): HRESULT; + function CountElements(LDim: Integer): Integer; + begin + Result := 1; + if LDim < VarArray^.DimCount then + Result := CountElements(LDim + 1) + VarArray^.Bounds[LDim - 1].ElementCount; + end; +var + LDim: Integer; + LLow, LHigh: Integer; + LElement: Integer; +begin + // validate the array + Result := SafeArrayValidate(VarArray); + Address := nil; + LElement := 0; + + // if all is swell so far + if Result = VAR_OK then + begin + + // validate the indices first + for LDim := 1 to VarArray^.DimCount do + begin + LLow := VarArray^.Bounds[LDim - 1].LowBound; + LHigh := LLow + VarArray^.Bounds[LDim - 1].ElementCount; + if (LLow = LHigh) or + ((Indices^[LDim - 1] < LLow) or + (Indices^[LDim - 1] > LHigh)) then + begin + Result := VAR_BADINDEX; + Break; + end; + + // continue to calculate the element count + Inc(LElement, (Indices^[LDim - 1] - LLow) * CountElements(LDim + 1)); + end; + + // all is swell? + if Result = VAR_OK then + begin + Address := SafeArrayCalculateElementAddress(VarArray, LElement); + + // finally lets lock it we need to + if LockIt then + Result := SafeArrayLock(VarArray); + end; + end; +end; + +function SafeArrayElementTotal(VarArray: PVarArray): Integer; +var + LDim: Integer; +begin + Result := 1; + for LDim := 0 to VarArray^.DimCount - 1 do + Result := Result * VarArray^.Bounds[LDim].ElementCount; +end; + +type + TElementStyle = (esNormal, esReference, esOleStr, esVariant); + +function SafeArrayElementStyle(VarArray: PVarArray): TElementStyle; +begin + // interface type thingy + if ((VarArray^.Flags and ARR_DISPATCH) <> 0) or + ((VarArray^.Flags and ARR_UNKNOWN) <> 0) then + Result := esReference + + // string type thingy + else if (VarArray^.Flags and ARR_OLESTR) <> 0 then + Result := esOleStr + + // variant type thingy + else if (VarArray^.Flags and ARR_VARIANT) <> 0 then + Result := esVariant + + // otherwise is just a normal thingy + else + Result := esNormal; +end; + +function SafeArrayClearDataSpace(VarArray: PVarArray; WipeBytes: Boolean = True): HRESULT; +var + LElement: Integer; + LAddress: Pointer; + LElementStyle: TElementStyle; +begin + Result := VAR_OK; + + // just in case + try + + // what type of data do we have? + LElementStyle := SafeArrayElementStyle(VarArray); + case LElementStyle of + + // simple fill + esNormal: + if WipeBytes then + FillChar(VarArray^.Data^, SafeArrayElementTotal(VarArray) * + VarArray^.ElementSize, 0); + + // we have to go though each element + esReference, esOleStr, esVariant: + for LElement := 0 to SafeArrayElementTotal(VarArray) - 1 do + begin + LAddress := SafeArrayCalculateElementAddress(VarArray, LElement); + + // do the right thing + case LElementStyle of + esReference: + IUnknown(PUnknown(LAddress)^) := nil; + esOleStr: + WideString(PPointer(LAddress)^) := ''; + esVariant: + Result := VariantClear(PVarData(LAddress)^); + else + Result := VAR_EXCEPTION; + end; + end; + end; + + // oops! + except + // something really really bad happened + on EOutOfMemory do + Result := VAR_OUTOFMEMORY; + + // catch all else + else + Result := VAR_EXCEPTION; + end; +end; + +function SafeArrayCopyDataSpace(SourceArray, TargetArray: PVarArray): HRESULT; +var + LElement: Integer; + LSource, LTarget: Pointer; + LElementStyle: TElementStyle; +begin + Result := VAR_OK; + + // just in case + try + + // what type of data do we have? + LElementStyle := SafeArrayElementStyle(SourceArray); + case LElementStyle of + + // simple fill + esNormal: + Move(SourceArray^.Data^, TargetArray^.Data^, SafeArrayElementTotal(SourceArray) * + SourceArray^.ElementSize); + + // we have to go though each element + esReference, esOleStr, esVariant: + for LElement := 0 to SafeArrayElementTotal(SourceArray) - 1 do + begin + LSource := SafeArrayCalculateElementAddress(SourceArray, LElement); + LTarget := SafeArrayCalculateElementAddress(TargetArray, LElement); + + // do the right thing + case LElementStyle of + esReference: + IUnknown(PUnknown(LTarget)^) := IUnknown(PUnknown(LSource)^); + esOleStr: + WideString(PPointer(LTarget)^) := Copy(PPWideChar(LSource)^, 1, MaxInt); + esVariant: + Result := VariantCopy(PVarData(LTarget)^, PVarData(LSource)^); + else + Result := VAR_EXCEPTION; + end; + end; + end; + + // oops! + except + // something really really bad happened + on EOutOfMemory do + Result := VAR_OUTOFMEMORY; + + // catch all else + else + Result := VAR_EXCEPTION; + end; +end; + +function SafeArrayAllocMem(const Size: LongWord): Pointer; +begin + {$IF GenericSafeArrayUsesLibC} + Result := Libc.calloc(1, Size); + {$ELSE} + Result := AllocMem(Size); + {$IFEND} +end; + +procedure SafeArrayFreeMem(const Address: Pointer); +begin + {$IF GenericSafeArrayUsesLibC} + Libc.free(Address); + {$ELSE} + FreeMem(Address); + {$IFEND} +end; + +procedure SafeArrayReallocMem(var Address: Pointer; const OldSize, NewSize: LongWord); +var + Temp: Pointer; +begin + if Address <> nil then + begin + if NewSize > 0 then + begin + Temp := SafeArrayAllocMem(NewSize); + Move(Address^, Temp^, OldSize); + SafeArrayFreeMem(Address); + Address := Temp; + end + else + begin + SafeArrayFreeMem(Address); + Address := nil; + end; + end else + Address := SafeArrayAllocMem(NewSize); +end; + +function SafeArrayCreate(VarType, DimCount: Integer; const Bounds: TVarArrayBoundArray): PVarArray; +var + LResult: HRESULT; + LDim: Integer; +begin + Result := nil; + + // is this something we want to deal with? + if (VarType in [CMinArrayVarType..CMaxArrayVarType]) and + CVarTypeToElementInfo[VarType].ValidBase then + begin + + // make room for the descriptor + LResult := SafeArrayAllocDescriptor(DimCount, Result); + if LResult = VAR_OK then + begin + + // add our bits of information + Result^.DimCount := DimCount; + Result^.Flags := cVarTypeToElementInfo[VarType].Flags; + Result^.ElementSize := cVarTypeToElementInfo[VarType].Size; + + // fill in the bounds info + for LDim := 0 to Result^.DimCount - 1 do + begin + Result^.Bounds[LDim].ElementCount := Bounds[DimCount - LDim - 1].ElementCount; + Result^.Bounds[LDim].LowBound := Bounds[DimCount - LDim - 1].LowBound; + end; + + // try to allocate the data + LResult := SafeArrayAllocData(Result); + + // if not then get rid of the descriptor + if LResult <> VAR_OK then + begin + SafeArrayDestroyDescriptor(Result); + Result := nil; + end; + end; + end; +end; + +function SafeArrayAllocDescriptor(DimCount: Integer; out VarArray: PVarArray): HRESULT; +begin + Result := VAR_OK; + + // give it a shot + try + VarArray := SafeArrayAllocMem(SizeOf(TVarArray) + SizeOf(TVarArrayBound) * (DimCount - 1)); + except + // something really really bad happened + on EOutOfMemory do + Result := VAR_OUTOFMEMORY; + + // catch all else + else + Result := VAR_UNEXPECTED; + end; +end; + +function SafeArrayAllocData(VarArray: PVarArray): HRESULT; +begin + Result := VAR_OK; + + // give it a shot + try + VarArray^.Data := SafeArrayAllocMem(SafeArrayElementTotal(VarArray) * + VarArray^.ElementSize); + except + // something really really bad happened + on EOutOfMemory do + Result := VAR_OUTOFMEMORY; + + // catch all else + else + Result := VAR_UNEXPECTED; + end; +end; + +function SafeArrayDestroy(VarArray: PVarArray): HRESULT; +begin + // all is swell? + Result := SafeArrayValidate(VarArray, cCheckAll); + if Result = VAR_OK then + begin + + // well then lets try to destroy the pieces parts + Result := SafeArrayDestroyData(VarArray); + if Result = VAR_OK then + Result := SafeArrayDestroyDescriptor(VarArray); + end; +end; + +function SafeArrayDestroyDescriptor(VarArray: PVarArray): HRESULT; +begin + // all is swell? + Result := SafeArrayValidate(VarArray, cCheckAll); + if Result = VAR_OK then + try + + // try and free it then + SafeArrayFreeMem(VarArray); + except + Result := VAR_UNEXPECTED; + end; +end; + +function SafeArrayDestroyData(VarArray: PVarArray): HRESULT; +begin + // all is swell? + Result := SafeArrayValidate(VarArray, cCheckAll); + if Result = VAR_OK then + try + + // slick the data space + Result := SafeArrayClearDataSpace(VarArray, False); + + // if all is swell and, if we are supposed to, free the data + if (Result = VAR_OK) and + ((VarArray^.Flags and ARR_FIXEDSIZE) = 0) then + begin + SafeArrayFreeMem(VarArray^.Data); + VarArray^.Data := nil; + end; + except + Result := VAR_UNEXPECTED; + end; +end; + +function SafeArrayRedim(VarArray: PVarArray; const NewBound: TVarArrayBound): HRESULT; +var + LDim, LDelta: Integer; + LTotal, LElement: Integer; + LAddress: Pointer; + LElementStyle: TElementStyle; +begin + // check out the array + Result := SafeArrayValidate(VarArray); + if Result = VAR_OK then + begin + if (VarArray^.Flags and ARR_FIXEDSIZE) <> 0 then + Result := VAR_INVALIDARG; + + // is still swell? + if Result = VAR_OK then + begin + Result := SafeArrayLock(VarArray); + if Result = VAR_OK then + try + try + + // calculate the delta + LDelta := NewBound.ElementCount - VarArray^.Bounds[0].ElementCount; + for LDim := 1 to VarArray^.DimCount - 1 do + LDelta := LDelta * VarArray^.Bounds[LDim].ElementCount; + + // any change? + if LDelta <> 0 then + begin + + // how big are we currently? + LTotal := SafeArrayElementTotal(VarArray); + + // make things shorter? + if LDelta < 0 then + begin + + // what type of stuff are we dealing with? + LElementStyle := SafeArrayElementStyle(VarArray); + + // for each element + for LElement := LTotal - 1 downto LTotal + LDelta do { Delta is negative } + begin + LAddress := SafeArrayCalculateElementAddress(VarArray, LElement); + + // do the right thing + case LElementStyle of + esReference: + IUnknown(PUnknown(LAddress)^) := nil; + esOleStr: + WideString(PPointer(LAddress)^) := ''; + esVariant: + Result := VariantClear(PVarData(LAddress)^); + else + Result := VAR_EXCEPTION; + end; + end; + end; + + // failure? + if Result <> VAR_OK then + Exit; + + // regrab the memory + SafeArrayReallocMem(VarArray^.Data, + LTotal * VarArray^.ElementSize, + (LTotal + LDelta) * VarArray^.ElementSize); + end; + + // copy over the new bound info + VarArray^.Bounds[0].ElementCount := NewBound.ElementCount; + VarArray^.Bounds[0].LowBound := NewBound.LowBound; + + // oops! + except + + // something really really bad happened + on EOutOfMemory do + Result := VAR_OUTOFMEMORY; + + // catch all else + else + Result := VAR_EXCEPTION; + end; + + // put away our toys + finally + if Result = VAR_OK then + Result := SafeArrayUnlock(VarArray) + else + SafeArrayUnlock(VarArray); + end; + end; + end; +end; + +function SafeArrayCopy(SourceArray: PVarArray; out TargetArray: PVarArray): HRESULT; +var + LDim: Integer; +begin + // check out the source array + Result := SafeArrayValidate(SourceArray); + if Result = VAR_OK then + begin + Result := SafeArrayLock(SourceArray); + if Result = VAR_OK then + try //and + try // again + + // make room for the descriptor + Result := SafeArrayAllocDescriptor(SourceArray^.DimCount, TargetArray); + if Result = VAR_OK then + try + + // add our bits of information + TargetArray^.DimCount := SourceArray^.DimCount; + TargetArray^.Flags := SourceArray^.Flags; + TargetArray^.ElementSize := SourceArray^.ElementSize; + + // fill in the bounds info + for LDim := 0 to TargetArray^.DimCount - 1 do + begin + TargetArray^.Bounds[LDim].ElementCount := SourceArray^.Bounds[LDim].ElementCount; + TargetArray^.Bounds[LDim].LowBound := SourceArray^.Bounds[LDim].LowBound; + end; + + // try to allocate the data + Result := SafeArrayAllocData(TargetArray); + + // now copy it! + if Result = VAR_OK then + Result := SafeArrayCopyDataSpace(SourceArray, TargetArray); + + // remember to clean up if needed + finally + if Result <> VAR_OK then + begin + SafeArrayDestroyDescriptor(TargetArray); + TargetArray := nil; + end; + end; + + // oops! + except + + // something really really bad happened + on EOutOfMemory do + Result := VAR_OUTOFMEMORY; + + // catch all else + else + Result := VAR_EXCEPTION; + end; + + // put away our toys + finally + if Result = VAR_OK then + Result := SafeArrayUnlock(SourceArray) + else + SafeArrayUnlock(SourceArray); + end; + end; +end; + +function SafeArrayCopyData(SourceArray, TargetArray: PVarArray): HRESULT; +var + LDim: Integer; +begin + // check out the source array + Result := SafeArrayValidate(SourceArray); + if Result = VAR_OK then + begin + Result := SafeArrayLock(SourceArray); + if Result = VAR_OK then + try + + // check out the target array + Result := SafeArrayValidate(TargetArray); + if Result = VAR_OK then + begin + Result := SafeArrayLock(TargetArray); + if Result = VAR_OK then + try + + // now make sure the two arrays are similar + if (SourceArray^.DimCount <> TargetArray^.DimCount) or + (SourceArray^.Flags <> TargetArray^.Flags) or + (SourceArray^.ElementSize <> TargetArray^.ElementSize) then + Result := VAR_INVALIDARG + else + begin + + // now make sure the bounds match + for LDim := 0 to SourceArray^.DimCount - 1 do + if (SourceArray^.Bounds[LDim].LowBound <> TargetArray^.Bounds[LDim].LowBound) or + (SourceArray^.Bounds[LDim].ElementCount <> TargetArray^.Bounds[LDim].ElementCount) then + begin + Result := VAR_INVALIDARG; + Break; + end; + + // if all is still well then lets copy the data + if Result = VAR_OK then + begin + + // clear the destination + Result := SafeArrayClearDataSpace(TargetArray); + + // if all is still swell then copy the data space + if Result = VAR_OK then + Result := SafeArrayCopyDataSpace(SourceArray, TargetArray); + end; + end; + + // put away our toys + finally + if Result = VAR_OK then + Result := SafeArrayUnlock(TargetArray) + else + SafeArrayUnlock(TargetArray); + end; + end; + finally + if Result = VAR_OK then + Result := SafeArrayUnlock(SourceArray) + else + SafeArrayUnlock(SourceArray); + end; + end; +end; + +function SafeArrayGetLBound(VarArray: PVarArray; Dim: Integer; out LBound: Integer): HRESULT; +begin + Result := SafeArrayValidate(VarArray); + if Result = VAR_OK then + if (Dim < 1) or (Dim > VarArray^.DimCount) then + Result := VAR_BADINDEX + else + LBound := VarArray^.Bounds[Dim - 1].LowBound; +end; + +function SafeArrayGetUBound(VarArray: PVarArray; Dim: Integer; out UBound: Integer): HRESULT; +begin + Result := SafeArrayValidate(VarArray); + if Result = VAR_OK then + if (Dim < 1) or (Dim > VarArray^.DimCount) then + Result := VAR_BADINDEX + else + UBound := VarArray^.Bounds[Dim - 1].LowBound + + VarArray^.Bounds[Dim - 1].ElementCount - 1; +end; + +function SafeArrayGetDim(VarArray: PVarArray): Integer; +begin + Result := 0; + if SafeArrayValidate(VarArray) = VAR_OK then + Result := VarArray^.DimCount; +end; + +function SafeArrayAccessData(VarArray: PVarArray; out Data: Pointer): HRESULT; +begin + Result := SafeArrayLock(VarArray); + if Result = VAR_OK then + Data := VarArray^.Data; +end; + +function SafeArrayUnaccessData(VarArray: PVarArray): HRESULT; +begin + Result := SafeArrayUnlock(VarArray); +end; + +function SafeArrayLock(VarArray: PVarArray): HRESULT; +begin + Result := SafeArrayValidate(VarArray); + if Result = VAR_OK then + Inc(VarArray^.LockCount); +end; + +function SafeArrayUnlock(VarArray: PVarArray): HRESULT; +begin + Result := SafeArrayValidate(VarArray); + if (Result = VAR_OK) and + (VarArray^.LockCount > 0) then + Dec(VarArray^.LockCount); +end; + +function SafeArrayGetElement(VarArray: PVarArray; Indices: PVarArrayCoorArray; + Data: Pointer): HRESULT; +var + LAddress: Pointer; +begin + Result := SafeArrayValidateAndCalculateAddress(VarArray, Indices, LAddress, True); + if Result = VAR_OK then + try //and + try // again + + // data type please + case SafeArrayElementStyle(VarArray) of + esNormal: + Move(LAddress^, Data^, VarArray^.ElementSize); + esReference: + IUnknown(PUnknown(Data)^) := IUnknown(PUnknown(LAddress)^); + esOleStr: + WideString(PPointer(Data)^) := Copy(PPWideChar(LAddress)^, 1, MaxInt); + esVariant: + VariantCopy(PVarData(Data)^, PVarData(LAddress)^); + end; + + // oops! + except + + // something really really bad happened + on EOutOfMemory do + Result := VAR_OUTOFMEMORY; + + // catch all else + else + Result := VAR_EXCEPTION; + end; + + // clean up please + finally + if Result = VAR_OK then + Result := SafeArrayUnlock(VarArray) + else + SafeArrayUnlock(VarArray); + end; +end; + +function SafeArrayPutElement(VarArray: PVarArray; Indices: PVarArrayCoorArray; + const Data: Pointer): HRESULT; +var + LAddress: Pointer; +begin + Result := SafeArrayValidateAndCalculateAddress(VarArray, Indices, LAddress, True); + if Result = VAR_OK then + try // and + try // again + + // data type please + case SafeArrayElementStyle(VarArray) of + esNormal: + Move(Data^, LAddress^, VarArray^.ElementSize); + esReference: + IUnknown(PUnknown(LAddress)^) := IUnknown(PUnknown(Data)^); + esOleStr: + WideString(PPointer(LAddress)^) := Copy(PWideChar(Data), 1, MaxInt); + esVariant: + VariantCopy(PVarData(LAddress)^, PVarData(Data)^); + end; + + // oops! + except + // something really really bad happened + on EOutOfMemory do + Result := VAR_OUTOFMEMORY; + + // catch all else + else + Result := VAR_EXCEPTION; + end; + + // clean up please + finally + if Result = VAR_OK then + Result := SafeArrayUnlock(VarArray) + else + SafeArrayUnlock(VarArray); + end; +end; + +function SafeArrayPtrOfIndex(VarArray: PVarArray; Indices: PVarArrayCoorArray; + var Address: Pointer): HRESULT; +begin + // call the common code + Result := SafeArrayValidateAndCalculateAddress(VarArray, Indices, Address, False); +end; + +function SafeArrayGetElemSize(VarArray: PVarArray): LongWord; +begin + Result := 0; + if SafeArrayValidate(VarArray) = VAR_OK then + Result := VarArray^.ElementSize; +end; +{$IFEND} + +procedure SafeArrayCreateError; +begin + raise ESafeArrayCreateError.Create(SVarArrayCreate); +end; + +procedure SafeArrayCheck(AResult: HRESULT); +begin + if AResult and $80000000 <> 0 then + SafeArrayError(AResult); +end; + +procedure SafeArrayError(AResult: HRESULT); +begin + case AResult of + VAR_BADINDEX: raise ESafeArrayBoundsError.CreateHResult(AResult, SVarArrayBounds); + VAR_ARRAYISLOCKED: raise ESafeArrayLockedError.CreateHResult(AResult, SVarArrayLocked); + else + raise ESafeArrayError.CreateHResult(AResult); + end; +end; + +constructor ESafeArrayError.CreateHResult(AResult: HRESULT; const AMessage: string); +var + S: string; +begin + S := AMessage; + if S = '' then + S := Format(SVarArrayWithHResult, [AResult]); + Create(S); + FErrorCode := AResult; +end; + +{$IFDEF MSWINDOWS} +procedure InitializeVarUtils; +var + LHandle: THandle; + + function FindProc(const AName: PChar; ADefault: Pointer): Pointer; + begin + Result := ADefault; + if LHandle <> 0 then + begin + Result := GetProcAddress(LHandle, AName); + if not Assigned(Result) then + Result := ADefault; + end; + end; + +begin + LHandle := GetModuleHandle(oleaut); + + {$IF GenericVariants} // portable code + VariantChangeTypeEx := BackupVariantChangeTypeEx; + + {$ELSE} // oleaut32 code + VariantChangeTypeEx := FindProc('VariantChangeTypeEx', @BackupVariantChangeTypeEx); + {$IFEND} + + {$IF GenericOperations} // portable code + VarNeg := UniUnimplemented; + VarNot := UniUnimplemented; + + VarAdd := BiUnimplemented; + VarSub := BiUnimplemented; + VarMul := BiUnimplemented; + VarDiv := BiUnimplemented; + VarIDiv := BiUnimplemented; + VarMod := BiUnimplemented; + VarAnd := BiUnimplemented; + VarOr := BiUnimplemented; + VarXor := BiUnimplemented; + + VarCmp := CmpUnimplemented; + + VarI4FromStr := BackupVarI4FromStr; + VarR4FromStr := BackupVarR4FromStr; + VarR8FromStr := BackupVarR8FromStr; + VarDateFromStr := BackupVarDateFromStr; + VarCyFromStr := BackupVarCyFromStr; + VarBoolFromStr := BackupVarBoolFromStr; + + VarBstrFromCy := BackupVarBstrFromCy; + VarBstrFromDate := BackupVarBstrFromDate; + VarBstrFromBool := BackupVarBstrFromBool; + + {$ELSE} // oleaut32 code + VarNeg := FindProc('VarNeg', @UniUnimplemented); + VarNot := FindProc('VarNot', @UniUnimplemented); + + VarAdd := FindProc('VarAdd', @BiUnimplemented); + VarSub := FindProc('VarSub', @BiUnimplemented); + VarMul := FindProc('VarMul', @BiUnimplemented); + VarDiv := FindProc('VarDiv', @BiUnimplemented); + VarIDiv := FindProc('VarIdiv', @BiUnimplemented); + VarMod := FindProc('VarMod', @BiUnimplemented); + VarAnd := FindProc('VarAnd', @BiUnimplemented); + VarOr := FindProc('VarOr', @BiUnimplemented); + VarXor := FindProc('VarXor', @BiUnimplemented); + + VarCmp := FindProc('VarCmp', @CmpUnimplemented); + + VarI4FromStr := FindProc('VarI4FromStr', @BackupVarI4FromStr); + VarR4FromStr := FindProc('VarR4FromStr', @BackupVarR4FromStr); + VarR8FromStr := FindProc('VarR8FromStr', @BackupVarR8FromStr); + VarDateFromStr := FindProc('VarDateFromStr', @BackupVarDateFromStr); + VarCyFromStr := FindProc('VarCyFromStr', @BackupVarCyFromStr); + VarBoolFromStr := FindProc('VarBoolFromStr', @BackupVarBoolFromStr); + + VarBstrFromCy := FindProc('VarBstrFromCy', @BackupVarBstrFromCy); + VarBstrFromDate := FindProc('VarBstrFromDate', @BackupVarBstrFromDate); + VarBstrFromBool := FindProc('VarBstrFromBool', @BackupVarBstrFromBool); + {$IFEND} +end; +{$ENDIF} + +{$IFDEF LINUX} +procedure InitializeVarUtils; +begin + VariantChangeTypeEx := BackupVariantChangeTypeEx; + + VarNeg := UniUnimplemented; + VarNot := UniUnimplemented; + + VarAdd := BiUnimplemented; + VarSub := BiUnimplemented; + VarMul := BiUnimplemented; + VarDiv := BiUnimplemented; + VarIDiv := BiUnimplemented; + VarMod := BiUnimplemented; + VarAnd := BiUnimplemented; + VarOr := BiUnimplemented; + VarXor := BiUnimplemented; + + VarCmp := CmpUnimplemented; + + VarI4FromStr := BackupVarI4FromStr; + VarR4FromStr := BackupVarR4FromStr; + VarR8FromStr := BackupVarR8FromStr; + VarDateFromStr := BackupVarDateFromStr; + VarCyFromStr := BackupVarCyFromStr; + VarBoolFromStr := BackupVarBoolFromStr; + + VarBstrFromCy := BackupVarBstrFromCy; + VarBstrFromDate := BackupVarBstrFromDate; + VarBstrFromBool := BackupVarBstrFromBool; +end; +{$ENDIF} + +initialization + InitializeVarUtils; +end. diff --git a/System/D2006_orig/Variants.pas b/System/D2006_orig/Variants.pas new file mode 100644 index 0000000..727c59d --- /dev/null +++ b/System/D2006_orig/Variants.pas @@ -0,0 +1,12 @@ +unit Variants; +{* Fake variants.pas unit for Delphi6 / Delphi7. Place it in a + directory with your KOL/MCK (or other non-VCL) project, and + this will save about 70K of code in the executable. + Certainly, do it so, if you actually do not use Delphi Variant + type in the application. + NEVER REPLACE Variants.pas provided by Borland! + (C) by Kladov Vladimir, 2003 } + +interface +implementation +end. diff --git a/System/D2006_orig/getmem.inc b/System/D2006_orig/getmem.inc new file mode 100644 index 0000000..7608076 --- /dev/null +++ b/System/D2006_orig/getmem.inc @@ -0,0 +1,4670 @@ +{ *********************************************************************** } +{ } +{ Borland Delphi Memory Manager } +{ } +{ Copyright (c) 1996-2006 Borland Software Corporation } +{ } +{ Portions created by Pierre le Riche are } +{ Copyright (c) Pierre le Riche / Professional Software Development } +{ } +{ Acknowledgement: With special thanks to the Fastcode community and } +{ supporters for their valuable input and feedback. } +{ } +{ } +{ *********************************************************************** } + +(* ***** BEGIN LICENSE BLOCK ***** + * Version: MPL 1.1 + * + * This memory manager implementation is subject to the + * Mozilla Public License Version 1.1 (the "License"); you may + * not use this file except in compliance with the License. + * You may obtain a copy of the License at http://www.mozilla.org/MPL/ + * + * Software distributed under the License is distributed on an "AS IS" basis, + * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License + * for the specific language governing rights and limitations under the + * License. + * + * ***** END LICENSE BLOCK ***** *) + +{-----------------------------Options Block-------------------------------} +{Enable to use the pascal code path} +{.$define UsePascalCode} +{Include the memory leak tracking and reporting code. Without this define set + the memory leak registration functions will do nothing and the memory leak + report will not be shown on shutdown.} +{$define IncludeMemoryLeakTrackingCode} +{Use custom fixed size move routines for some small blocks} +{$define UseCustomFixedSizeMoveRoutines} +{Use custom variable size move routines for larger blocks} +{$define UseCustomVariableSizeMoveRoutines} + +{--------------------------------Windows API------------------------------} +const + {Memory constants} + MEM_COMMIT = $1000; + MEM_RESERVE = $2000; + MEM_RELEASE = $8000; + MEM_TOP_DOWN = $100000; + PAGE_READONLY = 2; + PAGE_READWRITE = 4; + PAGE_EXECUTE = $10; + PAGE_EXECUTE_READ = $20; + PAGE_EXECUTE_READWRITE = $40; + PAGE_EXECUTE_WRITECOPY = $80; + PAGE_GUARD = $100; + {Window constants} + GWL_USERDATA = -21; + WS_POPUP = Integer($80000000); + {Messagebox Constants} + MB_OK = $00000000; + MB_ICONERROR = $00000010; + MB_TASKMODAL = $00002000; + +type + DWORD = Integer; + BOOL = LongBool; + HWND = LongWord; + HMENU = LongWord; + +function VirtualAlloc(lpAddress: Pointer; + dwSize, flAllocationType, flProtect: DWORD): Pointer; stdcall; + external kernel name 'VirtualAlloc'; +function VirtualFree(lpAddress: Pointer; dwSize, dwFreeType: DWORD): BOOL; stdcall; + external kernel name 'VirtualFree'; +procedure Sleep(dwMilliseconds: DWORD); stdcall; + external kernel name 'Sleep'; +function GetCurrentProcessId: DWORD; stdcall; + external kernel name 'GetCurrentProcessId'; +function CreateWindowEx(dwExStyle: DWORD; lpClassName: PChar; + lpWindowName: PChar; dwStyle: DWORD; X, Y, nWidth, nHeight: Integer; + hWndParent: HWND; hMenu: HMENU; hInstance: HINST; lpParam: Pointer): HWND; stdcall; + external user name 'CreateWindowExA'; +function DestroyWindow(hWnd: HWND): BOOL; stdcall; + external user name 'DestroyWindow'; +function FindWindow(lpClassName, lpWindowName: PChar): HWND; stdcall; + external user name 'FindWindowA'; +function GetWindowLong(hWnd: HWND; nIndex: Integer): Longint; stdcall; + external user name 'GetWindowLongA'; +function SetWindowLong(hWnd: HWND; nIndex: Integer; dwNewLong: Longint): Longint; stdcall; + external user name 'SetWindowLongA'; + +{-------------------------Fixed size move procedures----------------------} +{$ifdef UseCustomFixedSizeMoveRoutines} +procedure Move12(const ASource; var ADest; ACount: Integer); forward; +procedure Move20(const ASource; var ADest; ACount: Integer); forward; +procedure Move28(const ASource; var ADest; ACount: Integer); forward; +procedure Move36(const ASource; var ADest; ACount: Integer); forward; +procedure Move44(const ASource; var ADest; ACount: Integer); forward; +procedure Move52(const ASource; var ADest; ACount: Integer); forward; +procedure Move60(const ASource; var ADest; ACount: Integer); forward; +procedure Move68(const ASource; var ADest; ACount: Integer); forward; +{$endif} + +{---------------------------Private constants-----------------------------} +const + {The size of a medium block pool. This is allocated through VirtualAlloc and + is used to serve medium blocks. The size must be a multiple of 16 and at + least 4 bytes less than a multiple of 4K (the page size) to prevent a + possible read access violation when reading past the end of a memory block + in the optimized move routine (MoveX16L4).} + MediumBlockPoolSize = 20 * 64 * 1024 - 16; + {The granularity of small blocks} + SmallBlockGranularity = 8; + {The granularity of medium blocks. Newly allocated medium blocks are + a multiple of this size plus MediumBlockSizeOffset, to avoid cache line + conflicts} + MediumBlockGranularity = 256; + MediumBlockSizeOffset = 48; + {The granularity of large blocks} + LargeBlockGranularity = 65536; + {The maximum size of a small block. Blocks Larger than this are either + medium or large blocks.} + MaximumSmallBlockSize = 2608; + {The smallest medium block size. (Medium blocks are rounded up to the nearest + multiple of MediumBlockGranularity plus MediumBlockSizeOffset)} + MinimumMediumBlockSize = 11 * 256 + MediumBlockSizeOffset; + {The number of bins reserved for medium blocks} + MediumBlockBinsPerGroup = 32; + MediumBlockBinGroupCount = 32; + MediumBlockBinCount = MediumBlockBinGroupCount * MediumBlockBinsPerGroup; + {The maximum size allocatable through medium blocks. Blocks larger than this + fall through to VirtualAlloc ( = large blocks).} + MaximumMediumBlockSize = MinimumMediumBlockSize + (MediumBlockBinCount - 1) * MediumBlockGranularity; + {The target number of small blocks per pool. The actual number of blocks per + pool may be much greater for very small sizes and less for larger sizes. The + cost of allocating the small block pool is amortized across all the small + blocks in the pool, however the blocks may not all end up being used so they + may be lying idle.} + TargetSmallBlocksPerPool = 48; + {The minimum number of small blocks per pool. Any available medium block must + have space for roughly this many small blocks (or more) to be useable as a + small block pool.} + MinimumSmallBlocksPerPool = 12; + {The lower and upper limits for the optimal small block pool size} + OptimalSmallBlockPoolSizeLowerLimit = 29 * 1024 - MediumBlockGranularity + MediumBlockSizeOffset; + OptimalSmallBlockPoolSizeUpperLimit = 64 * 1024 - MediumBlockGranularity + MediumBlockSizeOffset; + {The maximum small block pool size. If a free block is this size or larger + then it will be split.} + MaximumSmallBlockPoolSize = OptimalSmallBlockPoolSizeUpperLimit + MinimumMediumBlockSize; + {----------------------------Block type flags---------------------------} + {The lower 3 bits in the dword header of small blocks (4 bits in medium and + large blocks) are used as flags to indicate the state of the block} + {Set if the block is not in use} + IsFreeBlockFlag = 1; + {Set if this is a medium block} + IsMediumBlockFlag = 2; + {Set if it is a medium block being used as a small block pool. Only valid if + IsMediumBlockFlag is set.} + IsSmallBlockPoolInUseFlag = 4; + {Set if it is a large block. Only valid if IsMediumBlockFlag is not set.} + IsLargeBlockFlag = 4; + {Is the medium block preceding this block available?} + PreviousMediumBlockIsFreeFlag = 8; + {The flags masks for small blocks} + DropSmallFlagsMask = -8; + ExtractSmallFlagsMask = 7; + {The flags masks for medium and large blocks} + DropMediumAndLargeFlagsMask = -16; + ExtractMediumAndLargeFlagsMask = 15; + {-------------------------Block resizing constants----------------------} + SmallBlockDownsizeCheckAdder = 64; + SmallBlockUpsizeAdder = 32; + {When a medium block is reallocated to a size smaller than this, then it must + be reallocated to a small block and the data moved. If not, then it is + shrunk in place down to MinimumMediumBlockSize. Currently the limit is set + at a quarter of the minimum medium block size.} + MediumInPlaceDownsizeLimit = MinimumMediumBlockSize div 4; + {-----------------------------Other constants---------------------------} + {Sleep time when a resource (small/medium/large block manager) is in use} + InitialSleepTime = 0; + {Used when the resource is still in use after the first sleep} + AdditionalSleepTime = 10; + {Hexadecimal characters} + HexTable: array[0..15] of char = '0123456789ABCDEF'; + {Copyright message - not used anywhere in the code} + Copyright: string = 'FastMM';// Borland Edition © 2004, 2005 Pierre le Riche / Professional Software Development'; +{$ifdef IncludeMemoryLeakTrackingCode} + {-----------------------Memory leak reporting constants-----------------} + ExpectedMemoryLeaksListSize = 64 * 1024; + {-------------------Memory leak messages (may be localized)-------------} + {Leak checking messages} + LeakMessageHeader = 'An unexpected memory leak has occurred. '; + SmallLeakDetail = 'The unexpected small block leaks are:'#13#10; + LargeLeakDetail = 'The sizes of unexpected leaked medium and large blocks are: '; + BytesMessage = ' bytes: '; + UnknownClassNameMsg = 'Unknown'; + StringBlockMessage = 'String'; + LeakMessageFooter = #13#10#0; + LeakMessageTitle = 'Unexpected Memory Leak'; +{$endif} + {Sharing errors} + ShareMMErrorTitle = 'Cannot Switch Memory Manager'; + LivePointersErrorMsg = 'The memory manager cannot be changed after it has been used.'; + BeingSharedErrorMsg = 'The memory manager cannot be changed if it is being shared.'; + +{------------------------------Private types------------------------------} +type + + {Move procedure type} + TMoveProc = procedure(const ASource; var ADest; ACount: Integer); + + {-----------------------Small block structures--------------------------} + + {Pointer to the header of a small block pool} + PSmallBlockPoolHeader = ^TSmallBlockPoolHeader; + + {Small block type (Size = 32)} + PSmallBlockType = ^TSmallBlockType; + TSmallBlockType = packed record + {True = Block type is locked} + BlockTypeLocked: boolean; + {Bitmap indicating which of the first 8 medium block groups contain blocks + of a suitable size for a block pool.} + AllowedGroupsForBlockPoolBitmap: byte; + {The block size for this block type} + BlockSize: Word; + {The first partially free pool for the given small block type (offset = +4 + for typecast compatibility with TSmallBlockPoolHeader). This is a circular + buffer.} + NextPartiallyFreePool: PSmallBlockPoolHeader; + {The offset of the last block that was served sequentially (0ffset = +8 to + to be at the same offset as the "FirstFreeBlock" of TSmallBlockPoolHeader} + NextSequentialFeedBlockAddress: Pointer; + {The last block that can be served sequentially. Offset is at +12 to be + at the same address as the "BlocksInUse" field of TSmallBlockPoolHeader} + MaxSequentialFeedBlockAddress: Pointer; + {The pool that is current being used to serve blocks in sequential order} + CurrentSequentialFeedPool: PSmallBlockPoolHeader; + {The previous partially free pool for the small block type (offset = +20 + for typecast compatibility with TSmallBlockPoolHeader)} + PreviousPartiallyFreePool: PSmallBlockPoolHeader; + {The minimum and optimal size of a small block pool for this block type} + MinimumBlockPoolSize: Word; + OptimalBlockPoolSize: Word; +{$ifdef UseCustomFixedSizeMoveRoutines} + {The fixed size move procedure used to move data for this block size when + it is upsized. When a block is downsized (which usually does not occur + that often) the variable size move routine is used.} + UpsizeMoveProcedure: TMoveProc; +{$else} + Reserved: Cardinal; +{$endif} + end; + + {Small block pool (Size = 32 bytes)} + TSmallBlockPoolHeader = packed record + {BlockType} + BlockType: PSmallBlockType; + {The next pool that has free blocks of this size. Must be at offset +4 + to be typecast compatible with TSmallBlockType} + NextPartiallyFreePool: PSmallBlockPoolHeader; + {Pointer to the first free block inside this pool. Must be at offset + 8 + to be at the same offset as "NextSequentialFeedBlockAddress" of + TSmallBlockType} + FirstFreeBlock: Pointer; + {The number of blocks allocated in this pool. Must be at offset + 12 + to be at the same offset as "MaxSequentialFeedBlockAddress" of + TSmallBlockType} + BlocksInUse: Cardinal; + {Small block pool signature. Used by the leak checking mechanism to + determine whether a medium block is a small block pool or a regular medium + block.} + SmallBlockPoolSignature: Cardinal; + {The previous pool that has free blocks of this size. Must be at offset +20 + to be compatible with TSmallBlockType} + PreviousPartiallyFreePool: PSmallBlockPoolHeader; + {Reserved} + Reserved1: Cardinal; + {The pool pointer and flags of the first block} + FirstBlockPoolPointerAndFlags: Cardinal; + end; + + {Small block layout: + Offset: -4 = Flags + address of the small block pool + Offset: BlockSize - 4 = Flags + address of the small block pool for the next small block + } + + {------------------------Medium block structures------------------------} + + {The medium block pool from which medium blocks are drawn} + PMediumBlockPoolHeader = ^TMediumBlockPoolHeader; + TMediumBlockPoolHeader = packed record + {Points to the previous and next medium block pools. This circular linked + list is used to track memory leaks on program shutdown.} + PreviousMediumBlockPoolHeader: PMediumBlockPoolHeader; + NextMediumBlockPoolHeader: PMediumBlockPoolHeader; + {Unused dword} + Reserved: Cardinal; + {The block size and flags of the first medium block in the block pool} + FirstMediumBlockSizeAndFlags: Cardinal; + end; + + {Medium block layout: + Offset: -8 = Previous Block Size (only if the previous block is free) + Offset: -4 = This block size and flags + Offset: 0 = User data / Previous Free Block (if this block is free) + Offset: 4 = Next Free Block (if this block is free) + Offset: BlockSize - 8 = Size of this block (if this block is free) + Offset: BlockSize - 4 = Size of the next block and flags + + {A medium block that is unused} + PMediumFreeBlock = ^TMediumFreeBlock; + TMediumFreeBlock = packed record + PreviousFreeBlock: PMediumFreeBlock; + NextFreeBlock: PMediumFreeBlock; + end; + + {-------------------------Large block structures------------------------} + + {Large block header record (size = 16)} + PLargeBlockHeader = ^TLargeBlockHeader; + TLargeBlockHeader = packed record + {Points to the previous and next large blocks. This circular linked + list is used to track memory leaks on program shutdown.} + PreviousLargeBlockHeader: PLargeBlockHeader; + NextLargeBlockHeader: PLargeBlockHeader; + {The user allocated size of the Large block} + UserAllocatedSize: Cardinal; + {The size of this block plus the flags} + BlockSizeAndFlags: Cardinal; + end; + + {--------------------Expected Memory Leak Structures--------------------} + +{$ifdef IncludeMemoryLeakTrackingCode} + TExpectedMemoryLeaks = packed record + {The number of entries used in the expected leaks buffer} + NumExpectedLeaks: Integer; + {The expected leaks buffer} + ExpectedLeaks: array[0..(ExpectedMemoryLeaksListSize - 4) div 4 - 1] of Pointer; + end; + PExpectedMemoryLeaks = ^TExpectedMemoryLeaks; +{$endif} + +{---------------------------Private constants-----------------------------} +const + {The size of the block header in front of small and medium blocks} + BlockHeaderSize = 4; + {The size of a small block pool header} + SmallBlockPoolHeaderSize = SizeOf(TSmallBlockPoolHeader); + {The size of a medium block pool header} + MediumBlockPoolHeaderSize = SizeOf(TMediumBlockPoolHeader); + {The size of the header in front of Large blocks} + LargeBlockHeaderSize = SizeOf(TLargeBlockHeader); + {This memory manager} + ThisMemoryManager: TMemoryManagerEx = ( + GetMem: SysGetMem; + FreeMem: SysFreeMem; + ReallocMem: SysReallocMem; + AllocMem: SysAllocMem; + RegisterExpectedMemoryLeak: SysRegisterExpectedMemoryLeak; + UnregisterExpectedMemoryLeak: SysUnregisterExpectedMemoryLeak); + +{---------------------------Private variables-----------------------------} +var + {-----------------------Small block management--------------------------} + {The small block types. Sizes include the leading 4-byte overhead. Sizes are + picked to limit maximum wastage to about 10% or 256 bytes (whichever is + less) where possible.} + SmallBlockTypes: packed array[0..NumSmallBlockTypes - 1] of TSmallBlockType =( + {8/16 byte jumps} + (BlockSize: 16{$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move12{$endif}), + (BlockSize: 24{$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move20{$endif}), + (BlockSize: 32{$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move28{$endif}), + (BlockSize: 40{$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move36{$endif}), + (BlockSize: 48{$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move44{$endif}), + (BlockSize: 56{$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move52{$endif}), + (BlockSize: 64{$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move60{$endif}), + (BlockSize: 72{$ifdef UseCustomFixedSizeMoveRoutines}; UpsizeMoveProcedure: Move68{$endif}), + (BlockSize: 80), + (BlockSize: 88), + (BlockSize: 96), + (BlockSize: 104), + (BlockSize: 112), + (BlockSize: 120), + (BlockSize: 128), + (BlockSize: 136), + (BlockSize: 144), + (BlockSize: 152), + (BlockSize: 160), + {16 byte jumps} + (BlockSize: 176), + (BlockSize: 192), + (BlockSize: 208), + (BlockSize: 224), + (BlockSize: 240), + (BlockSize: 256), + (BlockSize: 272), + (BlockSize: 288), + (BlockSize: 304), + (BlockSize: 320), + {32 byte jumps} + (BlockSize: 352), + (BlockSize: 384), + (BlockSize: 416), + (BlockSize: 448), + (BlockSize: 480), + {48 byte jumps} + (BlockSize: 528), + (BlockSize: 576), + (BlockSize: 624), + (BlockSize: 672), + {64 byte jumps} + (BlockSize: 736), + (BlockSize: 800), + {80 byte jumps} + (BlockSize: 880), + (BlockSize: 960), + {96 byte jumps} + (BlockSize: 1056), + (BlockSize: 1152), + {112 byte jumps} + (BlockSize: 1264), + (BlockSize: 1376), + {128 byte jumps} + (BlockSize: 1504), + {144 byte jumps} + (BlockSize: 1648), + {160 byte jumps} + (BlockSize: 1808), + {176 byte jumps} + (BlockSize: 1984), + {192 byte jumps} + (BlockSize: 2176), + {208 byte jumps} + (BlockSize: 2384), + {224 byte jumps} + (BlockSize: MaximumSmallBlockSize), + {The last block size occurs three times. If, during a GetMem call, the + requested block size is already locked by another thread then up to two + larger block sizes may be used instead. Having the last block size occur + three times avoids the need to have a size overflow check.} + (BlockSize: MaximumSmallBlockSize), + (BlockSize: MaximumSmallBlockSize)); + {Size to small block type translation table} + AllocSize2SmallBlockTypeIndX4: packed array[0..(MaximumSmallBlockSize - 1) div SmallBlockGranularity] of byte; + {The minimum block alignment} + MinimumBlockAlignment: TMinimumBlockAlignment; + {-----------------------Medium block management-------------------------} + {A dummy medium block pool header: Maintains a circular list of all medium + block pools to enable memory leak detection on program shutdown.} + MediumBlockPoolsCircularList: TMediumBlockPoolHeader; + {Are medium blocks locked?} + MediumBlocksLocked: boolean; + {The sequential feed medium block pool.} + LastSequentiallyFedMediumBlock: Pointer; + MediumSequentialFeedBytesLeft: Cardinal; + {The medium block bins are divided into groups of 32 bins. If a bit + is set in this group bitmap, then at least one bin in the group has free + blocks.} + MediumBlockBinGroupBitmap: Cardinal; + {The medium block bins: total of 32 * 32 = 1024 bins of a certain + minimum size.} + MediumBlockBinBitmaps: packed array[0..MediumBlockBinGroupCount - 1] of Cardinal; + {The medium block bins. There are 1024 LIFO circular linked lists each + holding blocks of a specified minimum size. The sizes vary in size from + MinimumMediumBlockSize to MaximumMediumBlockSize. The bins are treated as + type TMediumFreeBlock to avoid pointer checks.} + MediumBlockBins: packed array[0..MediumBlockBinCount - 1] of TMediumFreeBlock; + {-------------------------Large block management------------------------} + {Are large blocks locked?} + LargeBlocksLocked: boolean; + {A dummy large block header: Maintains a list of all allocated large blocks + to enable memory leak detection on program shutdown.} + LargeBlocksCircularList: TLargeBlockHeader; + {---------------------Expected Memory Leak Structures-------------------} +{$ifdef IncludeMemoryLeakTrackingCode} + {The expected memory leaks} + ExpectedMemoryLeaks: PExpectedMemoryLeaks; + ExpectedMemoryLeaksListLocked: Boolean; +{$endif} + {------------------------------Other info-------------------------------} + {A string uniquely identifying the current process (for sharing the memory + manager between DLLs and the main application)} + UniqueProcessIDString: String[23] = '????????_PID_FastMM_BE'#0; + {The handle of the MM window} + MMSharingWindow: HWND; + +{----------------------------Utility Functions----------------------------} + +{Compare [AAddress], CompareVal: + If Equal: [AAddress] := NewVal and result = CompareVal + If Unequal: Result := [AAddress]} +function LockCmpxchg(CompareVal, NewVal: byte; AAddress: PByte): Byte; +asm + {On entry: + al = CompareVal, + dl = NewVal, + ecx = AAddress} + lock cmpxchg [ecx], dl +end; + +{$ifdef UsePascalCode} +{Gets the first set bit and resets it, returning the bit index} +function FindFirstSetBit(ACardinal: Cardinal): Cardinal; +asm + {On entry: + eax = ACardinal} + bsf eax, eax +end; +{$endif} + +{----------------------Specialised Move Procedures------------------------} + +{$ifdef UseCustomFixedSizeMoveRoutines} +{Fixed size move operations ignore the size parameter. All moves are assumed to + be non-overlapping.} + +procedure Move12(const ASource; var ADest; ACount: Integer); +asm + mov ecx, [eax] + mov [edx], ecx + mov ecx, [eax + 4] + mov eax, [eax + 8] + mov [edx + 4], ecx + mov [edx + 8], eax +end; + +procedure Move20(const ASource; var ADest; ACount: Integer); +asm + mov ecx, [eax] + mov [edx], ecx + mov ecx, [eax + 4] + mov [edx + 4], ecx + mov ecx, [eax + 8] + mov [edx + 8], ecx + mov ecx, [eax + 12] + mov eax, [eax + 16] + mov [edx + 12], ecx + mov [edx + 16], eax +end; + +procedure Move28(const ASource; var ADest; ACount: Integer); +asm + mov ecx, [eax] + mov [edx], ecx + mov ecx, [eax + 4] + mov [edx + 4], ecx + mov ecx, [eax + 8] + mov [edx + 8], ecx + mov ecx, [eax + 12] + mov [edx + 12], ecx + mov ecx, [eax + 16] + mov [edx + 16], ecx + mov ecx, [eax + 20] + mov eax, [eax + 24] + mov [edx + 20], ecx + mov [edx + 24], eax +end; + +procedure Move36(const ASource; var ADest; ACount: Integer); +asm + fild qword ptr [eax] + fild qword ptr [eax + 8] + fild qword ptr [eax + 16] + fild qword ptr [eax + 24] + mov ecx, [eax + 32] + mov [edx + 32], ecx + fistp qword ptr [edx + 24] + fistp qword ptr [edx + 16] + fistp qword ptr [edx + 8] + fistp qword ptr [edx] +end; + +procedure Move44(const ASource; var ADest; ACount: Integer); +asm + fild qword ptr [eax] + fild qword ptr [eax + 8] + fild qword ptr [eax + 16] + fild qword ptr [eax + 24] + fild qword ptr [eax + 32] + mov ecx, [eax + 40] + mov [edx + 40], ecx + fistp qword ptr [edx + 32] + fistp qword ptr [edx + 24] + fistp qword ptr [edx + 16] + fistp qword ptr [edx + 8] + fistp qword ptr [edx] +end; + +procedure Move52(const ASource; var ADest; ACount: Integer); +asm + fild qword ptr [eax] + fild qword ptr [eax + 8] + fild qword ptr [eax + 16] + fild qword ptr [eax + 24] + fild qword ptr [eax + 32] + fild qword ptr [eax + 40] + mov ecx, [eax + 48] + mov [edx + 48], ecx + fistp qword ptr [edx + 40] + fistp qword ptr [edx + 32] + fistp qword ptr [edx + 24] + fistp qword ptr [edx + 16] + fistp qword ptr [edx + 8] + fistp qword ptr [edx] +end; + +procedure Move60(const ASource; var ADest; ACount: Integer); +asm + fild qword ptr [eax] + fild qword ptr [eax + 8] + fild qword ptr [eax + 16] + fild qword ptr [eax + 24] + fild qword ptr [eax + 32] + fild qword ptr [eax + 40] + fild qword ptr [eax + 48] + mov ecx, [eax + 56] + mov [edx + 56], ecx + fistp qword ptr [edx + 48] + fistp qword ptr [edx + 40] + fistp qword ptr [edx + 32] + fistp qword ptr [edx + 24] + fistp qword ptr [edx + 16] + fistp qword ptr [edx + 8] + fistp qword ptr [edx] +end; + +procedure Move68(const ASource; var ADest; ACount: Integer); +asm + fild qword ptr [eax] + fild qword ptr [eax + 8] + fild qword ptr [eax + 16] + fild qword ptr [eax + 24] + fild qword ptr [eax + 32] + fild qword ptr [eax + 40] + fild qword ptr [eax + 48] + fild qword ptr [eax + 56] + mov ecx, [eax + 64] + mov [edx + 64], ecx + fistp qword ptr [edx + 56] + fistp qword ptr [edx + 48] + fistp qword ptr [edx + 40] + fistp qword ptr [edx + 32] + fistp qword ptr [edx + 24] + fistp qword ptr [edx + 16] + fistp qword ptr [edx + 8] + fistp qword ptr [edx] +end; +{$endif} + +{$ifdef UseCustomVariableSizeMoveRoutines} +{Variable size move procedure: Assumes ACount is 4 less than a multiple of 16. + Always moves at least 12 bytes, irrespective of ACount.} +procedure MoveX16L4(const ASource; var ADest; ACount: Integer); +asm + {Make the counter negative based: The last 12 bytes are moved separately} + sub ecx, 12 + add eax, ecx + add edx, ecx + neg ecx + jns @MoveLast12 +@MoveLoop: + {Move a 16 byte block} + fild qword ptr [eax + ecx] + fild qword ptr [eax + ecx + 8] + fistp qword ptr [edx + ecx + 8] + fistp qword ptr [edx + ecx] + {Are there another 16 bytes to move?} + add ecx, 16 + js @MoveLoop +@MoveLast12: + {Do the last 12 bytes} + fild qword ptr [eax + ecx] + fistp qword ptr [edx + ecx] + mov eax, [eax + ecx + 8] + mov [edx + ecx + 8], eax +end; + +{Variable size move procedure: Assumes ACount is 4 less than a multiple of 8. + Always moves at least 12 bytes, irrespective of ACount.} +procedure MoveX8L4(const ASource; var ADest; ACount: Integer); +asm + {Make the counter negative based: The last 4 bytes are moved separately} + sub ecx, 4 + add eax, ecx + add edx, ecx + neg ecx +@MoveLoop: + {Move an 8 byte block} + fild qword ptr [eax + ecx] + fistp qword ptr [edx + ecx] + {Are there another 8 bytes to move?} + add ecx, 8 + js @MoveLoop + {Do the last 4 bytes} + mov eax, [eax + ecx] + mov [edx + ecx], eax +end; +{$endif} + +{-------------------------Small Block Management-------------------------} + +{Locks all small block types} +procedure LockAllSmallBlockTypes; +var + LInd: Cardinal; +begin + if IsMultiThread then + begin + for LInd := 0 to NumSmallBlockTypes - 1 do + begin + while LockCmpxchg(0, 1, @SmallBlockTypes[LInd].BlockTypeLocked) <> 0 do + begin + Sleep(InitialSleepTime); + if LockCmpxchg(0, 1, @SmallBlockTypes[LInd].BlockTypeLocked) = 0 then + break; + Sleep(AdditionalSleepTime); + end; + end; + end; +end; + +{-------------------------Medium Block Management-------------------------} + +{Locks the medium blocks} +procedure LockMediumBlocks; +begin + {Lock the medium blocks} + if IsMultiThread then + begin + while LockCmpxchg(0, 1, @MediumBlocksLocked) <> 0 do + begin + Sleep(InitialSleepTime); + if LockCmpxchg(0, 1, @MediumBlocksLocked) = 0 then + break; + Sleep(AdditionalSleepTime); + end; + end; +end; + +{Removes a medium block from the circular linked list of free blocks. + Does not change any header flags. Medium blocks should be locked + before calling this procedure.} +{$ifdef UsePascalCode} +procedure RemoveMediumFreeBlock(APMediumFreeBlock: PMediumFreeBlock); +var + LPreviousFreeBlock, LNextFreeBlock: PMediumFreeBlock; + LBinNumber, LBinGroupNumber: Cardinal; +begin + {Get the current previous and next blocks} + LNextFreeBlock := APMediumFreeBlock.NextFreeBlock; + LPreviousFreeBlock := APMediumFreeBlock.PreviousFreeBlock; + {Remove this block from the linked list} + LPreviousFreeBlock.NextFreeBlock := LNextFreeBlock; + LNextFreeBlock.PreviousFreeBlock := LPreviousFreeBlock; + {Is this bin now empty? If the previous and next free block pointers are + equal, they must point to the bin.} + if LPreviousFreeBlock = LNextFreeBlock then + begin + {Get the bin number for this block size} + LBinNumber := (Cardinal(LNextFreeBlock) - Cardinal(@MediumBlockBins)) div SizeOf(TMediumFreeBlock); + LBinGroupNumber := LBinNumber div 32; + {Flag this bin as empty} + MediumBlockBinBitmaps[LBinGroupNumber] := MediumBlockBinBitmaps[LBinGroupNumber] + and (not (1 shl (LBinNumber and 31))); + {Is the group now entirely empty?} + if MediumBlockBinBitmaps[LBinGroupNumber] = 0 then + begin + {Flag this group as empty} + MediumBlockBinGroupBitmap := MediumBlockBinGroupBitmap + and (not (1 shl LBinGroupNumber)); + end; + end; +end; +{$else} +procedure RemoveMediumFreeBlock(APMediumFreeBlock: PMediumFreeBlock); +asm + {On entry: eax = APMediumFreeBlock} + {Get the current previous and next blocks} + mov ecx, TMediumFreeBlock[eax].NextFreeBlock + mov edx, TMediumFreeBlock[eax].PreviousFreeBlock + {Is this bin now empty? If the previous and next free block pointers are + equal, they must point to the bin.} + cmp ecx, edx + {Remove this block from the linked list} + mov TMediumFreeBlock[ecx].PreviousFreeBlock, edx + mov TMediumFreeBlock[edx].NextFreeBlock, ecx + {Is this bin now empty? If the previous and next free block pointers are + equal, they must point to the bin.} + je @BinIsNowEmpty +@Done: + ret + {Align branch target} + nop +@BinIsNowEmpty: + {Get the bin number for this block size in ecx} + sub ecx, offset MediumBlockBins + mov edx, ecx + shr ecx, 3 + {Get the group number in edx} + movzx edx, dh + {Flag this bin as empty} + mov eax, -2 + rol eax, cl + and dword ptr [MediumBlockBinBitmaps + edx * 4], eax + jnz @Done + {Flag this group as empty} + mov eax, -2 + mov ecx, edx + rol eax, cl + and MediumBlockBinGroupBitmap, eax +end; +{$endif} + +{Inserts a medium block into the appropriate medium block bin.} +{$ifdef UsePascalCode} +procedure InsertMediumBlockIntoBin(APMediumFreeBlock: PMediumFreeBlock; AMediumBlockSize: Cardinal); +var + LBinNumber, LBinGroupNumber: Cardinal; + LPBin, LPFirstFreeBlock: PMediumFreeBlock; +begin + {Get the bin number for this block size. Get the bin that holds blocks of at + least this size.} + LBinNumber := (AMediumBlockSize - MinimumMediumBlockSize) div MediumBlockGranularity; + if LBinNumber >= MediumBlockBinCount then + LBinNumber := MediumBlockBinCount - 1; + {Get the bin} + LPBin := @MediumBlockBins[LBinNumber]; + {Bins are LIFO, se we insert this block as the first free block in the bin} + LPFirstFreeBlock := LPBin.NextFreeBlock; + APMediumFreeBlock.PreviousFreeBlock := LPBin; + APMediumFreeBlock.NextFreeBlock := LPFirstFreeBlock; + LPFirstFreeBlock.PreviousFreeBlock := APMediumFreeBlock; + LPBin.NextFreeBlock := APMediumFreeBlock; + {Was this bin empty?} + if LPFirstFreeBlock = LPBin then + begin + {Get the group number} + LBinGroupNumber := LBinNumber div 32; + {Flag this bin as used} + MediumBlockBinBitmaps[LBinGroupNumber] := MediumBlockBinBitmaps[LBinGroupNumber] + or (1 shl (LBinNumber and 31)); + {Flag the group as used} + MediumBlockBinGroupBitmap := MediumBlockBinGroupBitmap + or (1 shl LBinGroupNumber); + end; +end; +{$else} +procedure InsertMediumBlockIntoBin(APMediumFreeBlock: PMediumFreeBlock; AMediumBlockSize: Cardinal); +asm + {On entry: eax = APMediumFreeBlock, edx = AMediumBlockSize} + {Get the bin number for this block size. Get the bin that holds blocks of at + least this size.} + sub edx, MinimumMediumBlockSize + shr edx, 8 + {Validate the bin number} + sub edx, MediumBlockBinCount - 1 + sbb ecx, ecx + and edx, ecx + add edx, MediumBlockBinCount - 1 + {Get the bin in ecx} + lea ecx, [MediumBlockBins + edx * 8] + {Bins are LIFO, se we insert this block as the first free block in the bin} + mov edx, TMediumFreeBlock[ecx].NextFreeBlock + {Was this bin empty?} + cmp edx, ecx + mov TMediumFreeBlock[eax].PreviousFreeBlock, ecx + mov TMediumFreeBlock[eax].NextFreeBlock, edx + mov TMediumFreeBlock[edx].PreviousFreeBlock, eax + mov TMediumFreeBlock[ecx].NextFreeBlock, eax + {Was this bin empty?} + je @BinWasEmpty + ret + {Align branch target} + nop + nop +@BinWasEmpty: + {Get the bin number in ecx} + sub ecx, offset MediumBlockBins + mov edx, ecx + shr ecx, 3 + {Get the group number in edx} + movzx edx, dh + {Flag this bin as not empty} + mov eax, 1 + shl eax, cl + or dword ptr [MediumBlockBinBitmaps + edx * 4], eax + {Flag the group as not empty} + mov eax, 1 + mov ecx, edx + shl eax, cl + or MediumBlockBinGroupBitmap, eax +end; +{$endif} + +{Bins what remains in the current sequential feed medium block pool. Medium + blocks must be locked.} +{$ifdef UsePascalCode} +procedure BinMediumSequentialFeedRemainder; +var + LSequentialFeedFreeSize, LNextBlockSizeAndFlags: Cardinal; + LPRemainderBlock, LNextMediumBlock: Pointer; +begin + LSequentialFeedFreeSize := MediumSequentialFeedBytesLeft; + if LSequentialFeedFreeSize > 0 then + begin + {Get the block after the open space} + LNextMediumBlock := LastSequentiallyFedMediumBlock; + LNextBlockSizeAndFlags := PCardinal(Cardinal(LNextMediumBlock) - BlockHeaderSize)^; + {Point to the remainder} + LPRemainderBlock := Pointer(Cardinal(LNextMediumBlock) - LSequentialFeedFreeSize); + {Can the next block be combined with the remainder?} + if (LNextBlockSizeAndFlags and IsFreeBlockFlag) <> 0 then + begin + {Increase the size of this block} + Inc(LSequentialFeedFreeSize, LNextBlockSizeAndFlags and DropMediumAndLargeFlagsMask); + {Remove the next block as well} + if (LNextBlockSizeAndFlags and DropMediumAndLargeFlagsMask) >= MinimumMediumBlockSize then + RemoveMediumFreeBlock(LNextMediumBlock); + end + else + begin + {Set the "previous block is free" flag of the next block} + PCardinal(Cardinal(LNextMediumBlock) - BlockHeaderSize)^ := LNextBlockSizeAndFlags or PreviousMediumBlockIsFreeFlag; + end; + {Store the size of the block as well as the flags} + PCardinal(Cardinal(LPRemainderBlock) - BlockHeaderSize)^ := LSequentialFeedFreeSize or IsMediumBlockFlag or IsFreeBlockFlag; + {Store the trailing size marker} + PCardinal(Cardinal(LPRemainderBlock) + LSequentialFeedFreeSize - 8)^ := LSequentialFeedFreeSize; + {Bin this medium block} + if LSequentialFeedFreeSize >= MinimumMediumBlockSize then + begin + InsertMediumBlockIntoBin(LPRemainderBlock, LSequentialFeedFreeSize); + end; + end; +end; +{$else} +procedure BinMediumSequentialFeedRemainder; +asm + cmp MediumSequentialFeedBytesLeft, 0 + jne @MustBinMedium + {Nothing to bin} + ret + {Align branch target} + nop + nop +@MustBinMedium: + {Get a pointer to the last sequentially allocated medium block} + mov eax, LastSequentiallyFedMediumBlock + {Is the block that was last fed sequentially free?} + test byte ptr [eax - 4], IsFreeBlockFlag + jnz @LastBlockFedIsFree + {Set the "previous block is free" flag in the last block fed} + or dword ptr [eax - 4], PreviousMediumBlockIsFreeFlag + {Get the remainder in edx} + mov edx, MediumSequentialFeedBytesLeft + {Point eax to the start of the remainder} + sub eax, edx +@BinTheRemainder: + {Status: eax = start of remainder, edx = size of remainder} + {Store the size of the block as well as the flags} + lea ecx, [edx + IsMediumBlockFlag + IsFreeBlockFlag] + mov [eax - 4], ecx + {Store the trailing size marker} + mov [eax + edx - 8], edx + {Bin this medium block} + cmp edx, MinimumMediumBlockSize + jnb InsertMediumBlockIntoBin + ret + {Align branch target} + nop + nop +@LastBlockFedIsFree: + {Drop the flags} + mov edx, DropMediumAndLargeFlagsMask + and edx, [eax - 4] + {Free the last block fed} + cmp edx, MinimumMediumBlockSize + jb @DontRemoveLastFed + {Last fed block is free - remove it from its size bin} + call RemoveMediumFreeBlock + {Re-read eax and edx} + mov eax, LastSequentiallyFedMediumBlock + mov edx, DropMediumAndLargeFlagsMask + and edx, [eax - 4] +@DontRemoveLastFed: + {Get the number of bytes left in ecx} + mov ecx, MediumSequentialFeedBytesLeft + {Point eax to the start of the remainder} + sub eax, ecx + {edx = total size of the remainder} + add edx, ecx + jmp @BinTheRemainder +end; +{$endif} + +{Allocates a new sequential feed medium block pool and immediately splits off a + block of the requested size. The block size must be a multiple of 16 and + medium blocks must be locked.} +function AllocNewSequentialFeedMediumPool(AFirstBlockSize: Cardinal): Pointer; +var + LOldFirstMediumBlockPool: PMediumBlockPoolHeader; + LNewPool: Pointer; +begin + {Bin the current sequential feed remainder} + BinMediumSequentialFeedRemainder; + {Allocate a new sequential feed block pool} + LNewPool := VirtualAlloc(nil, MediumBlockPoolSize, MEM_COMMIT, PAGE_READWRITE); + if LNewPool <> nil then + begin + {Insert this block pool into the list of block pools} + LOldFirstMediumBlockPool := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader; + PMediumBlockPoolHeader(LNewPool).PreviousMediumBlockPoolHeader := @MediumBlockPoolsCircularList; + MediumBlockPoolsCircularList.NextMediumBlockPoolHeader := LNewPool; + PMediumBlockPoolHeader(LNewPool).NextMediumBlockPoolHeader := LOldFirstMediumBlockPool; + LOldFirstMediumBlockPool.PreviousMediumBlockPoolHeader := LNewPool; + {Store the sequential feed pool trailer} + PCardinal(Cardinal(LNewPool) + MediumBlockPoolSize - BlockHeaderSize)^ := IsMediumBlockFlag; + {Get the number of bytes still available} + MediumSequentialFeedBytesLeft := (MediumBlockPoolSize - MediumBlockPoolHeaderSize) - AFirstBlockSize; + {Get the result} + Result := Pointer(Cardinal(LNewPool) + MediumBlockPoolSize - AFirstBlockSize); + LastSequentiallyFedMediumBlock := Result; + {Store the block header} + PCardinal(Cardinal(Result) - BlockHeaderSize)^ := AFirstBlockSize or IsMediumBlockFlag; + end + else + begin + {Out of memory} + MediumSequentialFeedBytesLeft := 0; + Result := nil; + end; +end; + +{Frees a medium block pool. Medium blocks must be locked on entry.} +procedure FreeMediumBlockPool(AMediumBlockPool: PMediumBlockPoolHeader); +var + LPPreviousMediumBlockPoolHeader, LPNextMediumBlockPoolHeader: PMediumBlockPoolHeader; +begin + {Remove this medium block pool from the linked list} + LPPreviousMediumBlockPoolHeader := AMediumBlockPool.PreviousMediumBlockPoolHeader; + LPNextMediumBlockPoolHeader := AMediumBlockPool.NextMediumBlockPoolHeader; + LPPreviousMediumBlockPoolHeader.NextMediumBlockPoolHeader := LPNextMediumBlockPoolHeader; + LPNextMediumBlockPoolHeader.PreviousMediumBlockPoolHeader := LPPreviousMediumBlockPoolHeader; + {Free the medium block pool} + VirtualFree(AMediumBlockPool, 0, MEM_RELEASE); +end; + +{--------------------------Large Block Management-------------------------} + +{Locks the large blocks} +procedure LockLargeBlocks; +begin + {Lock the large blocks} + if IsMultiThread then + begin + while LockCmpxchg(0, 1, @LargeBlocksLocked) <> 0 do + begin + Sleep(InitialSleepTime); + if LockCmpxchg(0, 1, @LargeBlocksLocked) = 0 then + break; + Sleep(AdditionalSleepTime); + end; + end; +end; + +{Allocates a Large block of at least ASize (actual size may be Larger to + allow for alignment etc.). ASize must be the actual user requested size. This + procedure will pad it to the appropriate page boundary and also add the space + required by the header.} +function AllocateLargeBlock(ASize: Cardinal): Pointer; +var + LLargeUsedBlockSize: Cardinal; + LOldFirstLargeBlock: PLargeBlockHeader; +begin + {Pad the block size to include the header and granularity. We also add a + 4-byte overhead so a huge block size is a multiple of 16 bytes less 4 (so we + can use a single move function for reallocating all block types)} + LLargeUsedBlockSize := (ASize + LargeBlockHeaderSize + LargeBlockGranularity - 1 + BlockHeaderSize) + and -LargeBlockGranularity; + {Get the Large block} + Result := VirtualAlloc(nil, LLargeUsedBlockSize, MEM_COMMIT or MEM_TOP_DOWN, + PAGE_READWRITE); + {Set the Large block fields} + if Result <> nil then + begin + {Set the large block size and flags} + PLargeBlockHeader(Result).UserAllocatedSize := ASize; + PLargeBlockHeader(Result).BlockSizeAndFlags := LLargeUsedBlockSize or IsLargeBlockFlag; + {Insert the large block into the linked list of large blocks} + LockLargeBlocks; + LOldFirstLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader; + PLargeBlockHeader(Result).PreviousLargeBlockHeader := @LargeBlocksCircularList; + LargeBlocksCircularList.NextLargeBlockHeader := Result; + PLargeBlockHeader(Result).NextLargeBlockHeader := LOldFirstLargeBlock; + LOldFirstLargeBlock.PreviousLargeBlockHeader := Result; + LargeBlocksLocked := False; + {Add the size of the header} + Inc(Cardinal(Result), LargeBlockHeaderSize); + end; +end; + +{Frees a Large block, returning 0 on success, -1 otherwise} +function FreeLargeBlock(APointer: Pointer): Integer; +var + LPreviousLargeBlockHeader, LNextLargeBlockHeader: PLargeBlockHeader; +begin + {Point to the start of the Large block (always 64K aligned)} + APointer := Pointer(Cardinal(APointer) - LargeBlockHeaderSize); + {Get the previous and next large blocks} + LockLargeBlocks; + LPreviousLargeBlockHeader := PLargeBlockHeader(APointer).PreviousLargeBlockHeader; + LNextLargeBlockHeader := PLargeBlockHeader(APointer).NextLargeBlockHeader; + {Try to free the Large block} + if VirtualFree(APointer, 0, MEM_RELEASE) then + begin + {Remove the large block from the linked list} + LNextLargeBlockHeader.PreviousLargeBlockHeader := LPreviousLargeBlockHeader; + LPreviousLargeBlockHeader.NextLargeBlockHeader := LNextLargeBlockHeader; + {All OK} + Result := 0; + end + else + Result := -1; + LargeBlocksLocked := False; +end; + +{----------------------Main Memory Manager Functions----------------------} + +{$ifdef UsePascalCode} +function SysGetMem(Size: Integer): Pointer; +var + LMediumBlock, LNextFreeBlock, LSecondSplit: PMediumFreeBlock; + LNextMediumBlockHeader: PCardinal; + LBlockSize, LAvailableBlockSize, LSecondSplitSize: Cardinal; + LPSmallBlockType: PSmallBlockType; + LPSmallBlockPool, LPNewFirstPool: PSmallBlockPoolHeader; + LBinNumber: Cardinal; + LNewFirstFreeBlock: Pointer; + LPMediumBin: PMediumFreeBlock; + LSequentialFeedFreeSize: Cardinal; + LBinGroupsMasked, LBinGroupMasked, LBinGroupNumber: Cardinal; +begin + {Is it a small block? -> Take the header size into account when + determining the required block size} + if Cardinal(Size) <= (MaximumSmallBlockSize - BlockHeaderSize) then + begin + {-----------------------Allocate a small block------------------------} + {Get the block type from the size} + LPSmallBlockType := PSmallBlockType(AllocSize2SmallBlockTypeIndX4[ + (Cardinal(Size) + (BlockHeaderSize - 1)) div SmallBlockGranularity] * 8 + + Cardinal(@SmallBlockTypes)); + {Lock the block type} + if IsMultiThread then + begin + while True do + begin + {Try to lock the small block type} + if LockCmpxchg(0, 1, @LPSmallBlockType.BlockTypeLocked) = 0 then + break; + {Try the next block type} + Inc(Cardinal(LPSmallBlockType), SizeOf(TSmallBlockType)); + if LockCmpxchg(0, 1, @LPSmallBlockType.BlockTypeLocked) = 0 then + break; + {Try up to two sizes past the requested size} + Inc(Cardinal(LPSmallBlockType), SizeOf(TSmallBlockType)); + if LockCmpxchg(0, 1, @LPSmallBlockType.BlockTypeLocked) = 0 then + break; + {All three sizes locked - given up and sleep} + Dec(Cardinal(LPSmallBlockType), 2 * SizeOf(TSmallBlockType)); + {Both this block type and the next is in use: sleep} + Sleep(InitialSleepTime); + {Try the lock again} + if LockCmpxchg(0, 1, @LPSmallBlockType.BlockTypeLocked) = 0 then + break; + {Sleep longer} + Sleep(AdditionalSleepTime); + end; + end; + {Get the first pool with free blocks} + LPSmallBlockPool := LPSmallBlockType.NextPartiallyFreePool; + {Is the pool valid?} + if Cardinal(LPSmallBlockPool) <> Cardinal(LPSmallBlockType) then + begin + {Get the first free offset} + Result := LPSmallBlockPool.FirstFreeBlock; + {Get the new first free block} + LNewFirstFreeBlock := PPointer(Cardinal(Result) - 4)^; + LNewFirstFreeBlock := Pointer(Cardinal(LNewFirstFreeBlock) and DropSmallFlagsMask); + {Increment the number of used blocks} + Inc(LPSmallBlockPool.BlocksInUse); + {Set the new first free block} + LPSmallBlockPool.FirstFreeBlock := LNewFirstFreeBlock; + {Is the pool now full?} + if LNewFirstFreeBlock = nil then + begin + {Pool is full - remove it from the partially free list} + LPNewFirstPool := LPSmallBlockPool.NextPartiallyFreePool; + LPSmallBlockType.NextPartiallyFreePool := LPNewFirstPool; + LPNewFirstPool.PreviousPartiallyFreePool := PSmallBlockPoolHeader(LPSmallBlockType); + end; + end + else + begin + {Try to feed a small block sequentially} + Result := LPSmallBlockType.NextSequentialFeedBlockAddress; + {Can another block fit?} + if Cardinal(Result) <= Cardinal(LPSmallBlockType.MaxSequentialFeedBlockAddress) then + begin + {Get the sequential feed block pool} + LPSmallBlockPool := LPSmallBlockType.CurrentSequentialFeedPool; + {Increment the number of used blocks in the sequential feed pool} + Inc(LPSmallBlockPool.BlocksInUse); + {Store the next sequential feed block address} + LPSmallBlockType.NextSequentialFeedBlockAddress := Pointer(Cardinal(Result) + LPSmallBlockType.BlockSize); + end + else + begin + {Need to allocate a pool: Lock the medium blocks} + LockMediumBlocks; + {Are there any available blocks of a suitable size?} + LBinGroupsMasked := MediumBlockBinGroupBitmap and ($ffffff00 or LPSmallBlockType.AllowedGroupsForBlockPoolBitmap); + if LBinGroupsMasked <> 0 then + begin + {Get the bin group with free blocks} + LBinGroupNumber := FindFirstSetBit(LBinGroupsMasked); + {Get the bin in the group with free blocks} + LBinNumber := FindFirstSetBit(MediumBlockBinBitmaps[LBinGroupNumber]) + + LBinGroupNumber * 32; + LPMediumBin := @MediumBlockBins[LBinNumber]; + {Get the first block in the bin} + LMediumBlock := LPMediumBin.NextFreeBlock; + {Remove the first block from the linked list (LIFO)} + LNextFreeBlock := LMediumBlock.NextFreeBlock; + LPMediumBin.NextFreeBlock := LNextFreeBlock; + LNextFreeBlock.PreviousFreeBlock := LPMediumBin; + {Is this bin now empty?} + if LNextFreeBlock = LPMediumBin then + begin + {Flag this bin as empty} + MediumBlockBinBitmaps[LBinGroupNumber] := MediumBlockBinBitmaps[LBinGroupNumber] + and (not (1 shl (LBinNumber and 31))); + {Is the group now entirely empty?} + if MediumBlockBinBitmaps[LBinGroupNumber] = 0 then + begin + {Flag this group as empty} + MediumBlockBinGroupBitmap := MediumBlockBinGroupBitmap + and (not (1 shl LBinGroupNumber)); + end; + end; + {Get the size of the available medium block} + LBlockSize := PCardinal(Cardinal(LMediumBlock) - BlockHeaderSize)^ and DropMediumAndLargeFlagsMask; + {Medium blocks are never split or coalesced in full debug mode} + {Should the block be split?} + if LBlockSize >= MaximumSmallBlockPoolSize then + begin + {Get the size of the second split} + LSecondSplitSize := LBlockSize - LPSmallBlockType.OptimalBlockPoolSize; + {Adjust the block size} + LBlockSize := LPSmallBlockType.OptimalBlockPoolSize; + {Split the block in two} + LSecondSplit := PMediumFreeBlock(Cardinal(LMediumBlock) + LBlockSize); + PCardinal(Cardinal(LSecondSplit) - BlockHeaderSize)^ := LSecondSplitSize or (IsMediumBlockFlag or IsFreeBlockFlag); + {Store the size of the second split as the second last dword} + PCardinal(Cardinal(LSecondSplit) + LSecondSplitSize - 8)^ := LSecondSplitSize; + {Put the remainder in a bin (it will be big enough)} + InsertMediumBlockIntoBin(LSecondSplit, LSecondSplitSize); + end + else + begin + {Mark this block as used in the block following it} + LNextMediumBlockHeader := PCardinal(Cardinal(LMediumBlock) + LBlockSize - BlockHeaderSize); + LNextMediumBlockHeader^ := LNextMediumBlockHeader^ and (not PreviousMediumBlockIsFreeFlag); + end; + end + else + begin + {Check the sequential feed medium block pool for space} + LSequentialFeedFreeSize := MediumSequentialFeedBytesLeft; + if LSequentialFeedFreeSize >= LPSmallBlockType.MinimumBlockPoolSize then + begin + {Enough sequential feed space: Will the remainder be usable?} + if LSequentialFeedFreeSize >= (LPSmallBlockType.OptimalBlockPoolSize + MinimumMediumBlockSize) then + begin + LBlockSize := LPSmallBlockType.OptimalBlockPoolSize; + end + else + LBlockSize := LSequentialFeedFreeSize; + {Get the block} + LMediumBlock := Pointer(Cardinal(LastSequentiallyFedMediumBlock) - LBlockSize); + {Update the sequential feed parameters} + LastSequentiallyFedMediumBlock := LMediumBlock; + MediumSequentialFeedBytesLeft := LSequentialFeedFreeSize - LBlockSize; + end + else + begin + {Need to allocate a new sequential feed medium block pool: use the + optimal size for this small block pool} + LBlockSize := LPSmallBlockType.OptimalBlockPoolSize; + {Allocate the medium block pool} + LMediumBlock := AllocNewSequentialFeedMediumPool(LBlockSize); + if LMediumBlock = nil then + begin + {Out of memory} + {Unlock the medium blocks} + MediumBlocksLocked := False; + {Unlock the block type} + LPSmallBlockType.BlockTypeLocked := False; + {Failed} + Result := nil; + {done} + exit; + end; + end; + end; + {Mark this block as in use} + {Set the size and flags for this block} + PCardinal(Cardinal(LMediumBlock) - BlockHeaderSize)^ := + LBlockSize or IsMediumBlockFlag or IsSmallBlockPoolInUseFlag; + {Unlock medium blocks} + MediumBlocksLocked := False; + {Set up the block pool} + LPSmallBlockPool := PSmallBlockPoolHeader(LMediumBlock); + LPSmallBlockPool.BlockType := LPSmallBlockType; + LPSmallBlockPool.FirstFreeBlock := nil; + LPSmallBlockPool.BlocksInUse := 1; + {Set it up for sequential block serving} + LPSmallBlockType.CurrentSequentialFeedPool := LPSmallBlockPool; + Result := Pointer(Cardinal(LPSmallBlockPool) + SmallBlockPoolHeaderSize); + LPSmallBlockType.NextSequentialFeedBlockAddress := + Pointer(Cardinal(Result) + LPSmallBlockType.BlockSize); + LPSmallBlockType.MaxSequentialFeedBlockAddress := + Pointer(Cardinal(LPSmallBlockPool) + LBlockSize - LPSmallBlockType.BlockSize); + end; + end; + {Unlock the block type} + LPSmallBlockType.BlockTypeLocked := False; + {Set the block header} + PCardinal(Cardinal(Result) - BlockHeaderSize)^ := Cardinal(LPSmallBlockPool); + end + else + begin + {Medium block or Large block?} + if Cardinal(Size) <= (MaximumMediumBlockSize - BlockHeaderSize) then + begin + {---------------------Allocate a medium block-----------------------} + {Get the block size and bin number for this block size. Block sizes are + rounded up to the next bin size.} + LBlockSize := ((Cardinal(Size) + (MediumBlockGranularity - 1 + BlockHeaderSize - MediumBlockSizeOffset)) + and -MediumBlockGranularity) + MediumBlockSizeOffset; + {Get the bin number} + LBinNumber := (LBlockSize - MinimumMediumBlockSize) div MediumBlockGranularity; + {Lock the medium blocks} + LockMediumBlocks; + {Calculate the bin group} + LBinGroupNumber := LBinNumber div 32; + {Is there a suitable block inside this group?} + LBinGroupMasked := MediumBlockBinBitmaps[LBinGroupNumber] and -(1 shl (LBinNumber and 31)); + if LBinGroupMasked <> 0 then + begin + {Get the actual bin number} + LBinNumber := FindFirstSetBit(LBinGroupMasked) + LBinGroupNumber * 32; + end + else + begin + {Try all groups greater than this group} + LBinGroupsMasked := MediumBlockBinGroupBitmap and -(2 shl LBinGroupNumber); + if LBinGroupsMasked <> 0 then + begin + {There is a suitable group with space: get the bin number} + LBinGroupNumber := FindFirstSetBit(LBinGroupsMasked); + {Get the bin in the group with free blocks} + LBinNumber := FindFirstSetBit(MediumBlockBinBitmaps[LBinGroupNumber]) + + LBinGroupNumber * 32; + end + else + begin + {There are no bins with a suitable block: Sequentially feed the required block} + LSequentialFeedFreeSize := MediumSequentialFeedBytesLeft; + if LSequentialFeedFreeSize >= LBlockSize then + begin + {Block can be fed sequentially} + Result := Pointer(Cardinal(LastSequentiallyFedMediumBlock) - LBlockSize); + {Store the last sequentially fed block} + LastSequentiallyFedMediumBlock := Result; + {Store the remaining bytes} + MediumSequentialFeedBytesLeft := LSequentialFeedFreeSize - LBlockSize; + {Set the flags for the block} + PCardinal(Cardinal(Result) - BlockHeaderSize)^ := LBlockSize or IsMediumBlockFlag; + end + else + begin + {Need to allocate a new sequential feed block} + Result := AllocNewSequentialFeedMediumPool(LBlockSize); + end; + {Done} + MediumBlocksLocked := False; + exit; + end; + end; + {If we get here we have a valid LBinGroupNumber and LBinNumber: + Use the first block in the bin, splitting it if necessary} + {Get a pointer to the bin} + LPMediumBin := @MediumBlockBins[LBinNumber]; + {Get the result} + Result := LPMediumBin.NextFreeBlock; + {Remove the block from the bin containing it} + RemoveMediumFreeBlock(Result); + {Get the block size} + LAvailableBlockSize := PCardinal(Cardinal(Result) - BlockHeaderSize)^ + and DropMediumAndLargeFlagsMask; + {Is it an exact fit or not?} + LSecondSplitSize := LAvailableBlockSize - LBlockSize; + if LSecondSplitSize <> 0 then + begin + {Split the block in two} + LSecondSplit := PMediumFreeBlock(Cardinal(Result) + LBlockSize); + {Set the size of the second split} + PCardinal(Cardinal(LSecondSplit) - BlockHeaderSize)^ := + LSecondSplitSize or (IsMediumBlockFlag or IsFreeBlockFlag); + {Store the size of the second split as the second last dword} + PCardinal(Cardinal(LSecondSplit) + LSecondSplitSize - 8)^ := LSecondSplitSize; + {Put the remainder in a bin if it is big enough} + if LSecondSplitSize >= MinimumMediumBlockSize then + InsertMediumBlockIntoBin(LSecondSplit, LSecondSplitSize); + end + else + begin + {Mark this block as used in the block following it} + LNextMediumBlockHeader := Pointer(Cardinal(Result) + LBlockSize - BlockHeaderSize); + LNextMediumBlockHeader^ := + LNextMediumBlockHeader^ and (not PreviousMediumBlockIsFreeFlag); + end; + {Set the size and flags for this block} + PCardinal(Cardinal(Result) - BlockHeaderSize)^ := LBlockSize or IsMediumBlockFlag; + {Unlock the medium blocks} + MediumBlocksLocked := False; + end + else + begin + {Allocate a Large block} + if Size > 0 then + Result := AllocateLargeBlock(Size) + else + Result := nil; + end; + end; +end; +{$else} +function SysGetMem(Size: Integer): Pointer; +asm + {On entry: + eax = ASize} + {Since most allocations are for small blocks, determine the small block type + index so long} + lea edx, [eax + BlockHeaderSize - 1] + shr edx, 3 + {Is it a small block?} + cmp eax, (MaximumSmallBlockSize - BlockHeaderSize) + {Save ebx} + push ebx + {Get the IsMultiThread variable so long} + mov cl, IsMultiThread + {Is it a small block?} + ja @NotASmallBlock + {Do we need to lock the block type?} + test cl, cl + {Get the small block type in ebx} + movzx eax, byte ptr [AllocSize2SmallBlockTypeIndX4 + edx] + lea ebx, [SmallBlockTypes + eax * 8] + {Do we need to lock the block type?} + jnz @LockBlockTypeLoop +@GotLockOnSmallBlockType: + {Find the next free block: Get the first pool with free blocks in edx} + mov edx, TSmallBlockType[ebx].NextPartiallyFreePool + {Get the first free block (or the next sequential feed address if edx = ebx)} + mov eax, TSmallBlockPoolHeader[edx].FirstFreeBlock + {Get the drop flags mask in ecx so long} + mov ecx, DropSmallFlagsMask + {Is there a pool with free blocks?} + cmp edx, ebx + je @TrySmallSequentialFeed + {Increment the number of used blocks} + add TSmallBlockPoolHeader[edx].BlocksInUse, 1 + {Get the new first free block} + and ecx, [eax - 4] + {Set the new first free block} + mov TSmallBlockPoolHeader[edx].FirstFreeBlock, ecx + {Set the block header} + mov [eax - 4], edx + {Is the chunk now full?} + jz @RemoveSmallPool + {Unlock the block type} + mov TSmallBlockType[ebx].BlockTypeLocked, False + {Restore ebx} + pop ebx + {All done} + ret + {Align branch target} + nop + nop + nop +@TrySmallSequentialFeed: + {Try to feed a small block sequentially: Get the sequential feed block pool} + mov edx, TSmallBlockType[ebx].CurrentSequentialFeedPool + {Get the next sequential feed address so long} + movzx ecx, TSmallBlockType[ebx].BlockSize + add ecx, eax + {Can another block fit?} + cmp eax, TSmallBlockType[ebx].MaxSequentialFeedBlockAddress + {Can another block fit?} + ja @AllocateSmallBlockPool + {Increment the number of used blocks in the sequential feed pool} + add TSmallBlockPoolHeader[edx].BlocksInUse, 1 + {Store the next sequential feed block address} + mov TSmallBlockType[ebx].NextSequentialFeedBlockAddress, ecx + {Unlock the block type} + mov TSmallBlockType[ebx].BlockTypeLocked, False + {Set the block header} + mov [eax - 4], edx + {Restore ebx} + pop ebx + {All done} + ret + {Align branch target} + nop + nop + nop +@RemoveSmallPool: + {Pool is full - remove it from the partially free list} + mov ecx, TSmallBlockPoolHeader[edx].NextPartiallyFreePool + mov TSmallBlockPoolHeader[ecx].PreviousPartiallyFreePool, ebx + mov TSmallBlockType[ebx].NextPartiallyFreePool, ecx + {Unlock the block type} + mov TSmallBlockType[ebx].BlockTypeLocked, False + {Restore ebx} + pop ebx + {All done} + ret + {Align branch target} + nop + nop +@LockBlockTypeLoop: + mov eax, $100 + {Attempt to grab the block type} + lock cmpxchg TSmallBlockType([ebx]).BlockTypeLocked, ah + je @GotLockOnSmallBlockType + {Try the next size} + add ebx, Type(TSmallBlockType) + mov eax, $100 + lock cmpxchg TSmallBlockType([ebx]).BlockTypeLocked, ah + je @GotLockOnSmallBlockType + {Try the next size (up to two sizes larger)} + add ebx, Type(TSmallBlockType) + mov eax, $100 + lock cmpxchg TSmallBlockType([ebx]).BlockTypeLocked, ah + je @GotLockOnSmallBlockType + {Block type and two sizes larger are all locked - give up and sleep} + sub ebx, 2 * Type(TSmallBlockType) + {Couldn't grab the block type - sleep and try again} + push InitialSleepTime + call Sleep + {Try again} + mov eax, $100 + {Attempt to grab the block type} + lock cmpxchg TSmallBlockType([ebx]).BlockTypeLocked, ah + je @GotLockOnSmallBlockType + {Couldn't grab the block type - sleep and try again} + push AdditionalSleepTime + call Sleep + {Try again} + jmp @LockBlockTypeLoop + {Align branch target} + nop + nop + nop +@AllocateSmallBlockPool: + {save additional registers} + push esi + push edi + {Do we need to lock the medium blocks?} + cmp IsMultiThread, False + je @MediumBlocksLockedForPool +@LockMediumBlocksForPool: + mov eax, $100 + {Attempt to lock the medium blocks} + lock cmpxchg MediumBlocksLocked, ah + je @MediumBlocksLockedForPool + {Couldn't lock the medium blocks - sleep and try again} + push InitialSleepTime + call Sleep + {Try again} + mov eax, $100 + {Attempt to grab the block type} + lock cmpxchg MediumBlocksLocked, ah + je @MediumBlocksLockedForPool + {Couldn't lock the medium blocks - sleep and try again} + push AdditionalSleepTime + call Sleep + {Try again} + jmp @LockMediumBlocksForPool + {Align branch target} + nop + nop + nop +@MediumBlocksLockedForPool: + {Are there any available blocks of a suitable size?} + movsx esi, TSmallBlockType[ebx].AllowedGroupsForBlockPoolBitmap + and esi, MediumBlockBinGroupBitmap + jz @NoSuitableMediumBlocks + {Get the bin group number with free blocks in eax} + bsf eax, esi + {Get the bin number in ecx} + lea esi, [eax * 8] + mov ecx, dword ptr [MediumBlockBinBitmaps + eax * 4] + bsf ecx, ecx + lea ecx, [ecx + esi * 4] + {Get a pointer to the bin in edi} + lea edi, [MediumBlockBins + ecx * 8] + {Get the free block in esi} + mov esi, TMediumFreeBlock[edi].NextFreeBlock + {Remove the first block from the linked list (LIFO)} + mov edx, TMediumFreeBlock[esi].NextFreeBlock + mov TMediumFreeBlock[edi].NextFreeBlock, edx + mov TMediumFreeBlock[edx].PreviousFreeBlock, edi + {Is this bin now empty?} + cmp edi, edx + jne @MediumBinNotEmpty + {eax = bin group number, ecx = bin number, edi = @bin, esi = free block, ebx = block type} + {Flag this bin as empty} + mov edx, -2 + rol edx, cl + and dword ptr [MediumBlockBinBitmaps + eax * 4], edx + jnz @MediumBinNotEmpty + {Flag the group as empty} + btr MediumBlockBinGroupBitmap, eax +@MediumBinNotEmpty: + {esi = free block, ebx = block type} + {Get the size of the available medium block in edi} + mov edi, DropMediumAndLargeFlagsMask + and edi, [esi - 4] + cmp edi, MaximumSmallBlockPoolSize + jb @UseWholeBlock + {Split the block: get the size of the second part, new block size is the + optimal size} + mov edx, edi + movzx edi, TSmallBlockType[ebx].OptimalBlockPoolSize + sub edx, edi + {Split the block in two} + lea eax, [esi + edi] + lea ecx, [edx + IsMediumBlockFlag + IsFreeBlockFlag] + mov [eax - 4], ecx + {Store the size of the second split as the second last dword} + mov [eax + edx - 8], edx + {Put the remainder in a bin (it will be big enough)} + call InsertMediumBlockIntoBin + jmp @GotMediumBlock + {Align branch target} +@NoSuitableMediumBlocks: + {Check the sequential feed medium block pool for space} + movzx ecx, TSmallBlockType[ebx].MinimumBlockPoolSize + mov edi, MediumSequentialFeedBytesLeft + cmp edi, ecx + jb @AllocateNewSequentialFeed + {Get the address of the last block that was fed} + mov esi, LastSequentiallyFedMediumBlock + {Enough sequential feed space: Will the remainder be usable?} + movzx ecx, TSmallBlockType[ebx].OptimalBlockPoolSize + lea edx, [ecx + MinimumMediumBlockSize] + cmp edi, edx + jb @NotMuchSpace + mov edi, ecx +@NotMuchSpace: + sub esi, edi + {Update the sequential feed parameters} + sub MediumSequentialFeedBytesLeft, edi + mov LastSequentiallyFedMediumBlock, esi + {Get the block pointer} + jmp @GotMediumBlock + {Align branch target} +@AllocateNewSequentialFeed: + {Need to allocate a new sequential feed medium block pool: use the + optimal size for this small block pool} + movzx eax, TSmallBlockType[ebx].OptimalBlockPoolSize + mov edi, eax + {Allocate the medium block pool} + call AllocNewSequentialFeedMediumPool + mov esi, eax + test eax, eax + jnz @GotMediumBlock + mov MediumBlocksLocked, al + mov TSmallBlockType[ebx].BlockTypeLocked, al + pop edi + pop esi + pop ebx + ret + {Align branch target} +@UseWholeBlock: + {esi = free block, ebx = block type, edi = block size} + {Mark this block as used in the block following it} + and byte ptr [esi + edi - 4], not PreviousMediumBlockIsFreeFlag +@GotMediumBlock: + {esi = free block, ebx = block type, edi = block size} + {Set the size and flags for this block} + lea ecx, [edi + IsMediumBlockFlag + IsSmallBlockPoolInUseFlag] + mov [esi - 4], ecx + {Unlock medium blocks} + xor eax, eax + mov MediumBlocksLocked, al + {Set up the block pool} + mov TSmallBlockPoolHeader[esi].BlockType, ebx + mov TSmallBlockPoolHeader[esi].FirstFreeBlock, eax + mov TSmallBlockPoolHeader[esi].BlocksInUse, 1 + {Set it up for sequential block serving} + mov TSmallBlockType[ebx].CurrentSequentialFeedPool, esi + {Return the pointer to the first block} + lea eax, [esi + SmallBlockPoolHeaderSize] + movzx ecx, TSmallBlockType[ebx].BlockSize + lea edx, [eax + ecx] + mov TSmallBlockType[ebx].NextSequentialFeedBlockAddress, edx + add edi, esi + sub edi, ecx + mov TSmallBlockType[ebx].MaxSequentialFeedBlockAddress, edi + {Unlock the small block type} + mov TSmallBlockType[ebx].BlockTypeLocked, False + {Set the small block header} + mov [eax - 4], esi + {Restore registers} + pop edi + pop esi + pop ebx + {Done} + ret +{--------------------------Medium block allocation------------------------} + {Align branch target} + nop +@LockMediumBlocks: + mov eax, $100 + {Attempt to lock the medium blocks} + lock cmpxchg MediumBlocksLocked, ah + je @MediumBlocksLocked + {Couldn't lock the medium blocks - sleep and try again} + push InitialSleepTime + call Sleep + {Try again} + mov eax, $100 + {Attempt to lock the medium blocks} + lock cmpxchg MediumBlocksLocked, ah + je @MediumBlocksLocked + {Couldn't lock the medium blocks - sleep and try again} + push AdditionalSleepTime + call Sleep + {Try again} + jmp @LockMediumBlocks + {Align branch target} + nop + nop +@NotASmallBlock: + cmp eax, (MaximumMediumBlockSize - BlockHeaderSize) + ja @IsALargeBlockRequest + {Get the bin size for this block size. Block sizes are + rounded up to the next bin size.} + lea ebx, [eax + MediumBlockGranularity - 1 + BlockHeaderSize - MediumBlockSizeOffset] + and ebx, -MediumBlockGranularity + add ebx, MediumBlockSizeOffset + {Do we need to lock the medium blocks?} + test cl, cl + jnz @LockMediumBlocks +@MediumBlocksLocked: + {Get the bin number in ecx and the group number in edx} + lea edx, [ebx - MinimumMediumBlockSize] + mov ecx, edx + shr edx, 8 + 5 + shr ecx, 8 + {Is there a suitable block inside this group?} + mov eax, -1 + shl eax, cl + and eax, dword ptr [MediumBlockBinBitmaps + edx * 4] + jz @GroupIsEmpty + {Get the actual bin number} + and ecx, -32 + bsf eax, eax + or ecx, eax + jmp @GotBinAndGroup + {Align branch target} + nop + nop +@GroupIsEmpty: + {Try all groups greater than this group} + mov eax, -2 + mov ecx, edx + shl eax, cl + and eax, MediumBlockBinGroupBitmap + jz @TrySequentialFeedMedium + {There is a suitable group with space: get the bin number} + bsf edx, eax + {Get the bin in the group with free blocks} + mov eax, dword ptr [MediumBlockBinBitmaps + edx * 4] + bsf ecx, eax + mov eax, edx + shl eax, 5 + or ecx, eax + jmp @GotBinAndGroup + {Align branch target} + nop +@TrySequentialFeedMedium: + mov ecx, MediumSequentialFeedBytesLeft + {Block can be fed sequentially?} + sub ecx, ebx + jc @AllocateNewSequentialFeedForMedium + {Get the block address} + mov eax, LastSequentiallyFedMediumBlock + sub eax, ebx + mov LastSequentiallyFedMediumBlock, eax + {Store the remaining bytes} + mov MediumSequentialFeedBytesLeft, ecx + {Set the flags for the block} + or ebx, IsMediumBlockFlag + mov [eax - 4], ebx + jmp @MediumBlockGetDone + {Align branch target} +@AllocateNewSequentialFeedForMedium: + mov eax, ebx + call AllocNewSequentialFeedMediumPool +@MediumBlockGetDone: + mov MediumBlocksLocked, False + pop ebx + ret + {Align branch target} +@GotBinAndGroup: + {ebx = block size, ecx = bin number, edx = group number} + push esi + push edi + {Get a pointer to the bin in edi} + lea edi, [MediumBlockBins + ecx * 8] + {Get the free block in esi} + mov esi, TMediumFreeBlock[edi].NextFreeBlock + {Remove the first block from the linked list (LIFO)} + mov eax, TMediumFreeBlock[esi].NextFreeBlock + mov TMediumFreeBlock[edi].NextFreeBlock, eax + mov TMediumFreeBlock[eax].PreviousFreeBlock, edi + {Is this bin now empty?} + cmp edi, eax + jne @MediumBinNotEmptyForMedium + {eax = bin group number, ecx = bin number, edi = @bin, esi = free block, ebx = block size} + {Flag this bin as empty} + mov eax, -2 + rol eax, cl + and dword ptr [MediumBlockBinBitmaps + edx * 4], eax + jnz @MediumBinNotEmptyForMedium + {Flag the group as empty} + btr MediumBlockBinGroupBitmap, edx +@MediumBinNotEmptyForMedium: + {esi = free block, ebx = block size} + {Get the size of the available medium block in edi} + mov edi, DropMediumAndLargeFlagsMask + and edi, [esi - 4] + {Get the size of the second split in edx} + mov edx, edi + sub edx, ebx + jz @UseWholeBlockForMedium + {Split the block in two} + lea eax, [esi + ebx] + lea ecx, [edx + IsMediumBlockFlag + IsFreeBlockFlag] + mov [eax - 4], ecx + {Store the size of the second split as the second last dword} + mov [eax + edx - 8], edx + {Put the remainder in a bin} + cmp edx, MinimumMediumBlockSize + jb @GotMediumBlockForMedium + call InsertMediumBlockIntoBin + jmp @GotMediumBlockForMedium + {Align branch target} + nop + nop + nop +@UseWholeBlockForMedium: + {Mark this block as used in the block following it} + and byte ptr [esi + edi - 4], not PreviousMediumBlockIsFreeFlag +@GotMediumBlockForMedium: + {Set the size and flags for this block} + lea ecx, [ebx + IsMediumBlockFlag] + mov [esi - 4], ecx + {Unlock medium blocks} + mov MediumBlocksLocked, False + mov eax, esi + pop edi + pop esi + pop ebx + ret +{---------------------------Large block allocation------------------------} + {Align branch target} +@IsALargeBlockRequest: + pop ebx + test eax, eax + jns AllocateLargeBlock + xor eax, eax +end; +{$endif} + +{$ifdef UsePascalCode} +function SysFreeMem(P: Pointer): Integer; +var + LNextMediumBlock, LPreviousMediumBlock: PMediumFreeBlock; + LNextMediumBlockSizeAndFlags: Cardinal; + LBlockSize, LPreviousMediumBlockSize: Cardinal; + LPSmallBlockPool, LPPreviousPool, LPNextPool, + LPOldFirstPool: PSmallBlockPoolHeader; + LPSmallBlockType: PSmallBlockType; + LOldFirstFreeBlock: Pointer; + LBlockHeader: Cardinal; + LPPreviousMediumBlockPoolHeader, LPNextMediumBlockPoolHeader: PMediumBlockPoolHeader; +begin + {Get the small block header: Is it actually a small block?} + LBlockHeader := PCardinal(Cardinal(P) - BlockHeaderSize)^; + {Is it a small block that is in use?} + if LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag or IsLargeBlockFlag) = 0 then + begin + {Get a pointer to the block pool} + LPSmallBlockPool := PSmallBlockPoolHeader(LBlockHeader); + {Get the block type} + LPSmallBlockType := LPSmallBlockPool.BlockType; + {Lock the block type} + if IsMultiThread then + begin + while (LockCmpxchg(0, 1, @LPSmallBlockType.BlockTypeLocked) <> 0) do + begin + Sleep(InitialSleepTime); + if LockCmpxchg(0, 1, @LPSmallBlockType.BlockTypeLocked) = 0 then + break; + Sleep(AdditionalSleepTime); + end; + end; + {Get the old first free block} + LOldFirstFreeBlock := LPSmallBlockPool.FirstFreeBlock; + {Was the pool manager previously full?} + if LOldFirstFreeBlock = nil then + begin + {Insert this as the first partially free pool for the block size} + LPOldFirstPool := LPSmallBlockType.NextPartiallyFreePool; + LPSmallBlockPool.NextPartiallyFreePool := LPOldFirstPool; + LPOldFirstPool.PreviousPartiallyFreePool := LPSmallBlockPool; + LPSmallBlockPool.PreviousPartiallyFreePool := PSmallBlockPoolHeader(LPSmallBlockType); + LPSmallBlockType.NextPartiallyFreePool := LPSmallBlockPool; + end; + {Store the old first free block} + PCardinal(Cardinal(P) - BlockHeaderSize)^ := Cardinal(LOldFirstFreeBlock) or IsFreeBlockFlag; + {Store this as the new first free block} + LPSmallBlockPool.FirstFreeBlock := P; + {Decrement the number of allocated blocks} + Dec(LPSmallBlockPool.BlocksInUse); + {Small block pools are never freed in full debug mode. This increases the + likehood of success in catching objects still being used after being + destroyed.} + {Is the entire pool now free? -> Free it.} + if LPSmallBlockPool.BlocksInUse = 0 then + begin + {Get the previous and next chunk managers} + LPPreviousPool := LPSmallBlockPool.PreviousPartiallyFreePool; + LPNextPool := LPSmallBlockPool.NextPartiallyFreePool; + {Remove this manager} + LPPreviousPool.NextPartiallyFreePool := LPNextPool; + LPNextPool.PreviousPartiallyFreePool := LPPreviousPool; + {Is this the sequential feed pool? If so, stop sequential feeding} + if (LPSmallBlockType.CurrentSequentialFeedPool = LPSmallBlockPool) then + LPSmallBlockType.MaxSequentialFeedBlockAddress := nil; + {Unlock this block type} + LPSmallBlockType.BlockTypeLocked := False; + {No longer a small block pool in use (the flag must be reset in the + pascal version, since IsSmallBlockPoolInUseFlag = IsLargeBlockFlag)} + PCardinal(Cardinal(LPSmallBlockPool) - 4)^ := + PCardinal(Cardinal(LPSmallBlockPool) - 4)^ and (not IsSmallBlockPoolInUseFlag); + {Release this pool} + SysFreeMem(LPSmallBlockPool); + end + else + begin + {Unlock this block type} + LPSmallBlockType.BlockTypeLocked := False; + end; + {No error} + Result := 0; + end + else + begin + {Is this a medium block or a large block?} + if LBlockHeader and (IsFreeBlockFlag or IsLargeBlockFlag) = 0 then + begin + {Get the medium block size} + LBlockSize := LBlockHeader and DropMediumAndLargeFlagsMask; + {Lock the medium blocks} + LockMediumBlocks; + {Can we combine this block with the next free block?} + LNextMediumBlock := PMediumFreeBlock(Cardinal(P) + LBlockSize); + LNextMediumBlockSizeAndFlags := PCardinal(Cardinal(LNextMediumBlock) - BlockHeaderSize)^; + if (LNextMediumBlockSizeAndFlags and IsFreeBlockFlag) <> 0 then + begin + {Increase the size of this block} + Inc(LBlockSize, LNextMediumBlockSizeAndFlags and DropMediumAndLargeFlagsMask); + {Remove the next block as well} + if LNextMediumBlockSizeAndFlags >= MinimumMediumBlockSize then + RemoveMediumFreeBlock(LNextMediumBlock); + end + else + begin + {Reset the "previous in use" flag of the next block} + PCardinal(Cardinal(LNextMediumBlock) - BlockHeaderSize)^ := + LNextMediumBlockSizeAndFlags or PreviousMediumBlockIsFreeFlag; + end; + {Can we combine this block with the previous free block? We need to + re-read the flags since it could have changed before we could lock the + medium blocks.} + if (PCardinal(Cardinal(P) - BlockHeaderSize)^ and PreviousMediumBlockIsFreeFlag) <> 0 then + begin + {Get the size of the free block just before this one} + LPreviousMediumBlockSize := PCardinal(Cardinal(P) - 8)^; + {Get the start of the previous block} + LPreviousMediumBlock := PMediumFreeBlock(Cardinal(P) - LPreviousMediumBlockSize); + {Set the new block size} + Inc(LBlockSize, LPreviousMediumBlockSize); + {This is the new current block} + P := LPreviousMediumBlock; + {Remove the previous block from the linked list} + if LPreviousMediumBlockSize >= MinimumMediumBlockSize then + RemoveMediumFreeBlock(LPreviousMediumBlock); + end; + {Is the entire medium block pool free, and there are other free blocks + that can fit the largest possible medium block? -> free it. (Except in + full debug mode where medium pools are never freed.)} + if (LBlockSize <> (MediumBlockPoolSize - MediumBlockPoolHeaderSize)) then + begin + {Store the size of the block as well as the flags} + PCardinal(Cardinal(P) - BlockHeaderSize)^ := LBlockSize or (IsMediumBlockFlag or IsFreeBlockFlag); + {Store the trailing size marker} + PCardinal(Cardinal(P) + LBlockSize - 8)^ := LBlockSize; + {Insert this block back into the bins: Size check not required here, + since medium blocks that are in use are not allowed to be + shrunk smaller than MinimumMediumBlockSize} + InsertMediumBlockIntoBin(P, LBlockSize); + {Unlock medium blocks} + MediumBlocksLocked := False; + {All OK} + Result := 0; + end + else + begin + {Should this become the new sequential feed?} + if MediumSequentialFeedBytesLeft <> MediumBlockPoolSize - MediumBlockPoolHeaderSize then + begin + {Bin the current sequential feed} + BinMediumSequentialFeedRemainder; + {Set this medium pool up as the new sequential feed pool: + Store the sequential feed pool trailer} + PCardinal(Cardinal(P) + LBlockSize - BlockHeaderSize)^ := IsMediumBlockFlag; + {Store the number of bytes available in the sequential feed chunk} + MediumSequentialFeedBytesLeft := MediumBlockPoolSize - MediumBlockPoolHeaderSize; + {Set the last sequentially fed block} + LastSequentiallyFedMediumBlock := Pointer(Cardinal(P) + LBlockSize); + {Unlock medium blocks} + MediumBlocksLocked := False; + {Success} + Result := 0; + end + else + begin + {Remove this medium block pool from the linked list} + Dec(Cardinal(P), MediumBlockPoolHeaderSize); + LPPreviousMediumBlockPoolHeader := PMediumBlockPoolHeader(P).PreviousMediumBlockPoolHeader; + LPNextMediumBlockPoolHeader := PMediumBlockPoolHeader(P).NextMediumBlockPoolHeader; + LPPreviousMediumBlockPoolHeader.NextMediumBlockPoolHeader := LPNextMediumBlockPoolHeader; + LPNextMediumBlockPoolHeader.PreviousMediumBlockPoolHeader := LPPreviousMediumBlockPoolHeader; + {Unlock medium blocks} + MediumBlocksLocked := False; + {Free the medium block pool} + if VirtualFree(P, 0, MEM_RELEASE) then + Result := 0 + else + Result := -1; + end; + end; + end + else + begin + {Validate: Is this actually a Large block, or is it an attempt to free an + already freed small block?} + if LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag) = 0 then + Result := FreeLargeBlock(P) + else + Result := -1; + end; + end; +end; +{$else} +function SysFreeMem(P: Pointer): Integer; +asm + {On entry: + eax = P} + {Get the block header in edx} + mov edx, [eax - 4] + {Is it a small block in use?} + test dl, IsFreeBlockFlag + IsMediumBlockFlag + IsLargeBlockFlag + {Save the pointer in ecx} + mov ecx, eax + {Save ebx} + push ebx + {Get the IsMultiThread variable in bl} + mov bl, IsMultiThread + {Is it a small block that is in use?} + jnz @NotSmallBlockInUse + {Do we need to lock the block type?} + test bl, bl + {Get the small block type in ebx} + mov ebx, TSmallBlockPoolHeader[edx].BlockType + {Do we need to lock the block type?} + jnz @LockBlockTypeLoop +@GotLockOnSmallBlockType: + {Current state: edx = @SmallBlockPoolHeader, ecx = P, ebx = @SmallBlockType} + {Decrement the number of blocks in use} + sub TSmallBlockPoolHeader[edx].BlocksInUse, 1 + {Get the old first free block} + mov eax, TSmallBlockPoolHeader[edx].FirstFreeBlock + {Is the pool now empty?} + jz @PoolIsNowEmpty + {Was the pool full?} + test eax, eax + {Store this as the new first free block} + mov TSmallBlockPoolHeader[edx].FirstFreeBlock, ecx + {Store the previous first free block as the block header} + lea eax, [eax + IsFreeBlockFlag] + mov [ecx - 4], eax + {Insert the pool back into the linked list if it was full} + jz @SmallPoolWasFull + {All ok} + xor eax, eax + {Unlock the block type} + mov TSmallBlockType[ebx].BlockTypeLocked, al + {Restore registers} + pop ebx + {Done} + ret + {Align branch target} + nop +@SmallPoolWasFull: + {Insert this as the first partially free pool for the block size} + mov ecx, TSmallBlockType[ebx].NextPartiallyFreePool + mov TSmallBlockPoolHeader[edx].PreviousPartiallyFreePool, ebx + mov TSmallBlockPoolHeader[edx].NextPartiallyFreePool, ecx + mov TSmallBlockPoolHeader[ecx].PreviousPartiallyFreePool, edx + mov TSmallBlockType[ebx].NextPartiallyFreePool, edx + {Unlock the block type} + mov TSmallBlockType[ebx].BlockTypeLocked, False + {All ok} + xor eax, eax + {Restore registers} + pop ebx + {Done} + ret + {Align branch target} + nop + nop +@PoolIsNowEmpty: + {Was this pool actually in the linked list of pools with space? If not, it + can only be the sequential feed pool (it is the only pool that may contain + only one block, i.e. other blocks have not been split off yet)} + test eax, eax + jz @IsSequentialFeedPool + {Pool is now empty: Remove it from the linked list and free it} + mov eax, TSmallBlockPoolHeader[edx].PreviousPartiallyFreePool + mov ecx, TSmallBlockPoolHeader[edx].NextPartiallyFreePool + {Remove this manager} + mov TSmallBlockPoolHeader[eax].NextPartiallyFreePool, ecx + mov TSmallBlockPoolHeader[ecx].PreviousPartiallyFreePool, eax + {Zero out eax} + xor eax, eax + {Is this the sequential feed pool? If so, stop sequential feeding} + cmp TSmallBlockType[ebx].CurrentSequentialFeedPool, edx + jne @NotSequentialFeedPool +@IsSequentialFeedPool: + mov TSmallBlockType[ebx].MaxSequentialFeedBlockAddress, eax +@NotSequentialFeedPool: + {Unlock the block type} + mov TSmallBlockType[ebx].BlockTypeLocked, al + {Release this pool} + mov eax, edx + mov edx, [edx - 4] + mov bl, IsMultiThread + jmp @FreeMediumBlock + {Align branch target} + nop + nop + nop +@LockBlockTypeLoop: + mov eax, $100 + {Attempt to grab the block type} + lock cmpxchg TSmallBlockType([ebx]).BlockTypeLocked, ah + je @GotLockOnSmallBlockType + {Couldn't grab the block type - sleep and try again} + push ecx + push edx + push InitialSleepTime + call Sleep + pop edx + pop ecx + {Try again} + mov eax, $100 + {Attempt to grab the block type} + lock cmpxchg TSmallBlockType([ebx]).BlockTypeLocked, ah + je @GotLockOnSmallBlockType + {Couldn't grab the block type - sleep and try again} + push ecx + push edx + push AdditionalSleepTime + call Sleep + pop edx + pop ecx + {Try again} + jmp @LockBlockTypeLoop + {Align branch target} + nop + nop + {-----------------------------Medium blocks-----------------------------} +@LockMediumBlocks: + mov eax, $100 + {Attempt to lock the medium blocks} + lock cmpxchg MediumBlocksLocked, ah + je @MediumBlocksLocked + {Couldn't lock the medium blocks - sleep and try again} + push InitialSleepTime + call Sleep + {Try again} + mov eax, $100 + {Attempt to lock the medium blocks} + lock cmpxchg MediumBlocksLocked, ah + je @MediumBlocksLocked + {Couldn't lock the medium blocks - sleep and try again} + push AdditionalSleepTime + call Sleep + {Try again} + jmp @LockMediumBlocks + {Align branch target} + nop + nop +@NotSmallBlockInUse: + {Not a small block in use: is it a medium or large block?} + test dl, IsFreeBlockFlag + IsLargeBlockFlag + jnz @NotASmallOrLargeBlock +@FreeMediumBlock: + {Drop the flags} + and edx, DropMediumAndLargeFlagsMask + {Free the large block pointed to by eax, header in edx, bl = IsMultiThread} + {Do we need to lock the medium blocks?} + test bl, bl + {Block size in ebx} + mov ebx, edx + {Save registers} + push esi + {Pointer in esi} + mov esi, eax + {Do we need to lock the medium blocks?} + jnz @LockMediumBlocks +@MediumBlocksLocked: + {Can we combine this block with the next free block?} + test dword ptr [esi + ebx - 4], IsFreeBlockFlag + {Get the next block size and flags in ecx} + mov ecx, [esi + ebx - 4] + jnz @NextBlockIsFree + {Set the "PreviousIsFree" flag in the next block} + or ecx, PreviousMediumBlockIsFreeFlag + mov [esi + ebx - 4], ecx +@NextBlockChecked: + {Can we combine this block with the previous free block? We need to + re-read the flags since it could have changed before we could lock the + medium blocks.} + test byte ptr [esi - 4], PreviousMediumBlockIsFreeFlag + jnz @PreviousBlockIsFree +@PreviousBlockChecked: + {Is the entire medium block pool free, and there are other free blocks + that can fit the largest possible medium block -> free it.} + cmp ebx, (MediumBlockPoolSize - MediumBlockPoolHeaderSize) + je @EntireMediumPoolFree +@BinFreeMediumBlock: + {Store the size of the block as well as the flags} + lea eax, [ebx + IsMediumBlockFlag + IsFreeBlockFlag] + mov [esi - 4], eax + {Store the trailing size marker} + mov [esi + ebx - 8], ebx + {Insert this block back into the bins: Size check not required here, + since medium blocks that are in use are not allowed to be + shrunk smaller than MinimumMediumBlockSize} + mov eax, esi + mov edx, ebx + {Insert into bin} + call InsertMediumBlockIntoBin + {Unlock medium blocks} + mov MediumBlocksLocked, False; + {All OK} + xor eax, eax + {Restore registers} + pop esi + pop ebx + {Return} + ret + {Align branch target} + nop +@NextBlockIsFree: + {Get the next block address in eax} + lea eax, [esi + ebx] + {Increase the size of this block} + and ecx, DropMediumAndLargeFlagsMask + add ebx, ecx + {Was the block binned?} + cmp ecx, MinimumMediumBlockSize + jb @NextBlockChecked + call RemoveMediumFreeBlock + jmp @NextBlockChecked + {Align branch target} + nop +@PreviousBlockIsFree: + {Get the size of the free block just before this one} + mov ecx, [esi - 8] + {Include the previous block} + sub esi, ecx + {Set the new block size} + add ebx, ecx + {Remove the previous block from the linked list} + cmp ecx, MinimumMediumBlockSize + jb @PreviousBlockChecked + mov eax, esi + call RemoveMediumFreeBlock + jmp @PreviousBlockChecked + {Align branch target} +@EntireMediumPoolFree: + {Should we make this the new sequential feed medium block pool? If the + current sequential feed pool is not entirely free, we make this the new + sequential feed pool.} + cmp MediumSequentialFeedBytesLeft, MediumBlockPoolSize - MediumBlockPoolHeaderSize + jne @MakeEmptyMediumPoolSequentialFeed + {Point esi to the medium block pool header} + sub esi, MediumBlockPoolHeaderSize + {Remove this medium block pool from the linked list} + mov eax, TMediumBlockPoolHeader[esi].PreviousMediumBlockPoolHeader + mov edx, TMediumBlockPoolHeader[esi].NextMediumBlockPoolHeader + mov TMediumBlockPoolHeader[eax].NextMediumBlockPoolHeader, edx + mov TMediumBlockPoolHeader[edx].PreviousMediumBlockPoolHeader, eax + {Unlock medium blocks} + mov MediumBlocksLocked, False; + {Free the medium block pool} + push MEM_RELEASE + push 0 + push esi + call VirtualFree + {VirtualFree returns >0 if all is ok} + cmp eax, 1 + {Return 0 on all ok} + sbb eax, eax + {Restore registers} + pop esi + pop ebx + ret + {Align branch target} + nop + nop + nop +@MakeEmptyMediumPoolSequentialFeed: + {Get a pointer to the end-marker block} + lea ebx, [esi + MediumBlockPoolSize - MediumBlockPoolHeaderSize] + {Bin the current sequential feed pool} + call BinMediumSequentialFeedRemainder + {Set this medium pool up as the new sequential feed pool: + Store the sequential feed pool trailer} + mov dword ptr [ebx - BlockHeaderSize], IsMediumBlockFlag + {Store the number of bytes available in the sequential feed chunk} + mov MediumSequentialFeedBytesLeft, MediumBlockPoolSize - MediumBlockPoolHeaderSize + {Set the last sequentially fed block} + mov LastSequentiallyFedMediumBlock, ebx + {Unlock medium blocks} + mov MediumBlocksLocked, False; + {Success} + xor eax, eax + {Restore registers} + pop esi + pop ebx + ret + {Align branch target} + nop + nop +@NotASmallOrLargeBlock: + {Restore ebx} + pop ebx + {Is it in fact a large block?} + test dl, IsFreeBlockFlag + IsMediumBlockFlag + jz FreeLargeBlock + {Attempt to free an already free block} + mov eax, -1 +end; +{$endif} + +{$ifdef UsePascalCode} +function SysReallocMem(P: Pointer; Size: Integer): Pointer; +var + LBlockHeader, LBlockFlags, LOldAvailableSize, LNewAllocSize, + LNextBlockSizeAndFlags, LNextBlockSize, LNewAvailableSize, + LMinimumUpsize, LOldUserSize, LSecondSPlitSize, LNewBlockSize: Cardinal; + LPSmallBlockType: PSmallBlockType; + LPNextBlock, LPNextBlockHeader: Pointer; + + {Upsizes a large block in-place. The following variables are assumed correct: + LBlockFlags, LOldAvailableSize, LPNextBlock, LNextBlockSizeAndFlags, + LNextBlockSize, LNewAvailableSize. Medium blocks must be locked on entry if + required.} + procedure MediumBlockInPlaceUpsize; + begin + {Remove the next block} + if LNextBlockSizeAndFlags >= MinimumMediumBlockSize then + RemoveMediumFreeBlock(LPNextBlock); + {Add 25% for medium block in-place upsizes} + LMinimumUpsize := LOldAvailableSize + (LOldAvailableSize shr 2); + if Cardinal(Size) < LMinimumUpsize then + LNewAllocSize := LMinimumUpsize + else + LNewAllocSize := Size; + {Round up to the nearest block size granularity} + LNewBlockSize := ((LNewAllocSize + (BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset)) + and -MediumBlockGranularity) + MediumBlockSizeOffset; + {Calculate the size of the second split} + LSecondSplitSize := LNewAvailableSize + BlockHeaderSize - LNewBlockSize; + {Does it fit?} + if Integer(LSecondSplitSize) <= 0 then + begin + {The block size is the full available size plus header} + LNewBlockSize := LNewAvailableSize + BlockHeaderSize; + {Grab the whole block: Mark it as used in the block following it} + LPNextBlockHeader := Pointer(Cardinal(P) + LNewAvailableSize); + PCardinal(LPNextBlockHeader)^ := + PCardinal(LPNextBlockHeader)^ and (not PreviousMediumBlockIsFreeFlag); + end + else + begin + {Split the block in two} + LPNextBlock := PMediumFreeBlock(Cardinal(P) + LNewBlockSize); + {Set the size of the second split} + PCardinal(Cardinal(LPNextBlock) - BlockHeaderSize)^ := LSecondSplitSize or (IsMediumBlockFlag or IsFreeBlockFlag); + {Store the size of the second split as the second last dword} + PCardinal(Cardinal(LPNextBlock) + LSecondSplitSize - 8)^ := LSecondSplitSize; + {Put the remainder in a bin if it is big enough} + if LSecondSplitSize >= MinimumMediumBlockSize then + InsertMediumBlockIntoBin(LPNextBlock, LSecondSplitSize); + end; + {Set the size and flags for this block} + PCardinal(Cardinal(P) - BlockHeaderSize)^ := LNewBlockSize or LBlockFlags; + end; + + {In-place downsize of a medium block. On entry ANewSize must be less than half + of LOldAvailableSize.} + procedure MediumBlockInPlaceDownsize; + begin + {Round up to the next medium block size} + LNewBlockSize := ((Size + (BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset)) + and -MediumBlockGranularity) + MediumBlockSizeOffset; + {Get the size of the second split} + LSecondSplitSize := (LOldAvailableSize + BlockHeaderSize) - LNewBlockSize; + {Lock the medium blocks} + LockMediumBlocks; + {Set the new size} + PCardinal(Cardinal(P) - BlockHeaderSize)^ := + (PCardinal(Cardinal(P) - BlockHeaderSize)^ and ExtractMediumAndLargeFlagsMask) + or LNewBlockSize; + {Is the next block in use?} + LPNextBlock := PCardinal(Cardinal(P) + LOldAvailableSize + BlockHeaderSize); + LNextBlockSizeAndFlags := PCardinal(Cardinal(LPNextBlock) - BlockHeaderSize)^; + if LNextBlockSizeAndFlags and IsFreeBlockFlag = 0 then + begin + {The next block is in use: flag its previous block as free} + PCardinal(Cardinal(LPNextBlock) - BlockHeaderSize)^ := + LNextBlockSizeAndFlags or PreviousMediumBlockIsFreeFlag; + end + else + begin + {The next block is free: combine it} + LNextBlockSizeAndFlags := LNextBlockSizeAndFlags and DropMediumAndLargeFlagsMask; + Inc(LSecondSplitSize, LNextBlockSizeAndFlags); + if LNextBlockSizeAndFlags >= MinimumMediumBlockSize then + RemoveMediumFreeBlock(LPNextBlock); + end; + {Set the split} + LPNextBlock := PCardinal(Cardinal(P) + LNewBlockSize); + {Store the free part's header} + PCardinal(Cardinal(LPNextBlock) - BlockHeaderSize)^ := LSecondSplitSize or (IsMediumBlockFlag or IsFreeBlockFlag); + {Store the trailing size field} + PCardinal(Cardinal(LPNextBlock) + LSecondSplitSize - 8)^ := LSecondSplitSize; + {Bin this free block} + if LSecondSplitSize >= MinimumMediumBlockSize then + InsertMediumBlockIntoBin(LPNextBlock, LSecondSplitSize); + {Unlock the medium blocks} + MediumBlocksLocked := False; + end; + +begin + {Get the block header: Is it actually a small block?} + LBlockHeader := PCardinal(Cardinal(P) - BlockHeaderSize)^; + {Is it a small block that is in use?} + if LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag or IsLargeBlockFlag) = 0 then + begin + {----------------------------Small block------------------------------} + {The block header is a pointer to the block pool: Get the block type} + LPSmallBlockType := PSmallBlockPoolHeader(LBlockHeader).BlockType; + {Get the available size inside blocks of this type.} + LOldAvailableSize := LPSmallBlockType.BlockSize - BlockHeaderSize; + {Is it an upsize or a downsize?} + if LOldAvailableSize >= Cardinal(Size) then + begin + {It's a downsize. Do we need to allocate a smaller block? Only if the new + block size is less than a quarter of the available size less + SmallBlockDownsizeCheckAdder bytes} + if (Cardinal(Size) * 4 + SmallBlockDownsizeCheckAdder) >= LOldAvailableSize then + begin + {In-place downsize - return the pointer} + Result := P; + exit; + end + else + begin + {Allocate a smaller block} + Result := SysGetMem(Size); + {Allocated OK?} + if Result <> nil then + begin + {Move the data across} +{$ifdef UseCustomVariableSizeMoveRoutines} + MoveX8L4(P^, Result^, Size); +{$else} + Move(P^, Result^, Size); +{$endif} + {Free the old pointer} + SysFreeMem(P); + end; + end; + end + else + begin + {This pointer is being reallocated to a larger block and therefore it is + logical to assume that it may be enlarged again. Since reallocations are + expensive, there is a minimum upsize percentage to avoid unnecessary + future move operations.} + {Must grow with at least 100% + x bytes} + LNewAllocSize := LOldAvailableSize * 2 + SmallBlockUpsizeAdder; + {Still not large enough?} + if LNewAllocSize < Cardinal(Size) then + LNewAllocSize := Size; + {Allocate the new block} + Result := SysGetMem(LNewAllocSize); + {Allocated OK?} + if Result <> nil then + begin + {Do we need to store the requested size? Only large blocks store the + requested size.} + if LNewAllocSize > (MaximumMediumBlockSize - BlockHeaderSize) then + PLargeBlockHeader(Cardinal(Result) - LargeBlockHeaderSize).UserAllocatedSize := Size; + {Move the data across} +{$ifdef UseCustomFixedSizeMoveRoutines} + LPSmallBlockType.UpsizeMoveProcedure(P^, Result^, LOldAvailableSize); +{$else} + Move(P^, Result^, LOldAvailableSize); +{$endif} + {Free the old pointer} + SysFreeMem(P); + end; + end; + end + else + begin + {Is this a medium block or a large block?} + if LBlockHeader and (IsFreeBlockFlag or IsLargeBlockFlag) = 0 then + begin + {-------------------------Medium block------------------------------} + {What is the available size in the block being reallocated?} + LOldAvailableSize := (LBlockHeader and DropMediumAndLargeFlagsMask); + {Get a pointer to the next block} + LPNextBlock := PCardinal(Cardinal(P) + LOldAvailableSize); + {Subtract the block header size from the old available size} + Dec(LOldAvailableSize, BlockHeaderSize); + {Is it an upsize or a downsize?} + if Cardinal(Size) > LOldAvailableSize then + begin + {Can we do an in-place upsize?} + LNextBlockSizeAndFlags := PCardinal(Cardinal(LPNextBlock) - BlockHeaderSize)^; + {Is the next block free?} + if LNextBlockSizeAndFlags and IsFreeBlockFlag <> 0 then + begin + LNextBlockSize := LNextBlockSizeAndFlags and DropMediumAndLargeFlagsMask; + {The available size including the next block} + LNewAvailableSize := LOldAvailableSize + LNextBlockSize; + {Can the block fit?} + if Cardinal(Size) <= LNewAvailableSize then + begin + {The next block is free and there is enough space to grow this + block in place.} + if IsMultiThread then + begin + {Multi-threaded application - lock medium blocks and re-read the + information on the blocks.} + LockMediumBlocks; + {Re-read the info for this block} + LBlockFlags := PCardinal(Cardinal(P) - BlockHeaderSize)^ and ExtractMediumAndLargeFlagsMask; + {Re-read the info for the next block} + LNextBlockSizeAndFlags := PCardinal(Cardinal(LPNextBlock) - BlockHeaderSize)^; + {Recalculate the next block size} + LNextBlockSize := LNextBlockSizeAndFlags and DropMediumAndLargeFlagsMask; + {The available size including the next block} + LNewAvailableSize := LOldAvailableSize + LNextBlockSize; + {Is the next block still free and the size still sufficient?} + if (LNextBlockSizeAndFlags and IsFreeBlockFlag <> 0) + and (Cardinal(Size) <= LNewAvailableSize) then + begin + {Upsize the block in-place} + MediumBlockInPlaceUpsize; + {Unlock the medium blocks} + MediumBlocksLocked := False; + {Return the result} + Result := P; + {Done} + exit; + end; + {Couldn't use the block: Unlock the medium blocks} + MediumBlocksLocked := False; + end + else + begin + {Extract the block flags} + LBlockFlags := ExtractMediumAndLargeFlagsMask and LBlockHeader; + {Upsize the block in-place} + MediumBlockInPlaceUpsize; + {Return the result} + Result := P; + {Done} + exit; + end; + end; + end; + {Couldn't upsize in place. Grab a new block and move the data across: + If we have to reallocate and move medium blocks, we grow by at + least 25%} + LMinimumUpsize := LOldAvailableSize + (LOldAvailableSize shr 2); + if Cardinal(Size) < LMinimumUpsize then + LNewAllocSize := LMinimumUpsize + else + LNewAllocSize := Size; + {Allocate the new block} + Result := SysGetMem(LNewAllocSize); + if Result <> nil then + begin + {If its a Large block - store the actual user requested size} + if LNewAllocSize > (MaximumMediumBlockSize - BlockHeaderSize) then + PLargeBlockHeader(Cardinal(Result) - LargeBlockHeaderSize).UserAllocatedSize := Size; + {Move the data across} +{$ifdef UseCustomVariableSizeMoveRoutines} + MoveX16L4(P^, Result^, LOldAvailableSize); +{$else} + Move(P^, Result^, LOldAvailableSize); +{$endif} + {Free the old block} + SysFreeMem(P); + end; + end + else + begin + {Must be less than half the current size or we don't bother resizing.} + if Cardinal(Size * 2) >= LOldAvailableSize then + begin + Result := P; + end + else + begin + {In-place downsize? Balance the cost of moving the data vs. the cost of + fragmenting the memory pool. Medium blocks in use may never be smaller + than MinimumMediumBlockSize.} + if Size >= (MinimumMediumBlockSize - BlockHeaderSize) then + begin + MediumBlockInPlaceDownsize; + Result := P; + end + else + begin + {The requested size is less than the minimum medium block size. If + the requested size is less than the threshold value (currently a + quarter of the minimum medium block size), move the data to a small + block, otherwise shrink the medium block to the minimum allowable + medium block size.} + if Cardinal(Size) >= MediumInPlaceDownsizeLimit then + begin + {The request is for a size smaller than the minimum medium block + size, but not small enough to justify moving data: Reduce the + block size to the minimum medium block size} + Size := MinimumMediumBlockSize - BlockHeaderSize; + {Is it already at the minimum medium block size?} + if LOldAvailableSize > Cardinal(Size) then + MediumBlockInPlaceDownsize; + Result := P; + end + else + begin + {Allocate the new block} + Result := SysGetMem(Size); + if Result <> nil then + begin + {Move the data across} +{$ifdef UseCustomVariableSizeMoveRoutines} + MoveX8L4(P^, Result^, Size); +{$else} + Move(P^, Result^, Size); +{$endif} + {Free the old block} + SysFreeMem(P); + end; + end; + end; + end; + + end; + end + else + begin + {Is this a valid large block?} + if LBlockHeader and (IsFreeBlockFlag or IsMediumBlockFlag) = 0 then + begin + {-------------------------Large block-----------------------------} + {Large block - size is (16 + 4) less than the allocated size} + LOldAvailableSize := LBlockHeader - (LargeBlockHeaderSize + BlockHeaderSize + IsLargeBlockFlag); + {The user allocated size is stored for Large blocks} + LOldUserSize := PLargeBlockHeader(Cardinal(P) - LargeBlockHeaderSize).UserAllocatedSize; + {Is it an upsize or a downsize?} + if Cardinal(Size) > LOldAvailableSize then + begin + {This pointer is being reallocated to a larger block and therefore it is + logical to assume that it may be enlarged again. Since reallocations are + expensive, there is a minimum upsize percentage to avoid unnecessary + future move operations.} + {Add 25% for large block upsizes} + LMinimumUpsize := Cardinal(LOldAvailableSize) + + (Cardinal(LOldAvailableSize) shr 2); + if Cardinal(Size) < LMinimumUpsize then + LNewAllocSize := LMinimumUpsize + else + LNewAllocSize := Size; + {Allocate the new block} + Result := SysGetMem(LNewAllocSize); + if Result <> nil then + begin + {If its a large block - store the actual user requested size (it may + not be if the block that is being reallocated from was previously + downsized)} + if LNewAllocSize > (MaximumMediumBlockSize - BlockHeaderSize) then + PLargeBlockHeader(Cardinal(Result) - LargeBlockHeaderSize).UserAllocatedSize := Size; + {The number of bytes to move is the old user size.} +{$ifdef UseCustomVariableSizeMoveRoutines} + MoveX16L4(P^, Result^, LOldUserSize); +{$else} + Move(P^, Result^, LOldUserSize); +{$endif} + {Free the old block} + SysFreeMem(P); + end; + end + else + begin + {It's a downsize: do we need to reallocate? Only if the new size is less + than half of the old size} + if Cardinal(Size) >= (LOldAvailableSize shr 1) then + begin + {No need to reallocate} + Result := P; + {Update the requested size} + PLargeBlockHeader(Cardinal(P) - LargeBlockHeaderSize).UserAllocatedSize := Size; + end + else + begin + {The block is less than half of the old size, and the current size is + greater than the minimum block size allowing a downsize: reallocate} + Result := SysGetMem(Size); + if Result <> nil then + begin + {Still a large block? -> Set the user size} + if Size > (MaximumMediumBlockSize - BlockHeaderSize) then + PLargeBlockHeader(Cardinal(P) - LargeBlockHeaderSize).UserAllocatedSize := Size; + {Move the data across} +{$ifdef UseCustomVariableSizeMoveRoutines} + MoveX8L4(P^, Result^, Size); +{$else} + Move(P^, Result^, Size); +{$endif} + {Free the old block} + SysFreeMem(P); + end; + end; + end; + end + else + begin + {------------------------Invalid block----------------------------} + {Bad pointer: probable attempt to reallocate a free memory block.} + Result := nil; + end; + end; + end; +end; +{$else} +function SysReallocMem(P: Pointer; Size: Integer): Pointer; +asm + {On entry: eax = P; edx = Size} + {Get the block header: Is it actually a small block?} + mov ecx, [eax - 4] + {Is it a small block?} + test cl, IsFreeBlockFlag + IsMediumBlockFlag + IsLargeBlockFlag + {Save ebx} + push ebx + {Save esi} + push esi + {Save the original pointer in esi} + mov esi, eax + {Is it a small block?} + jnz @NotASmallBlock + {----------------------------Small block--------------------------------} + {Get the block type in ebx} + mov ebx, TSmallBlockPoolHeader[ecx].BlockType + {Get the available size inside blocks of this type.} + movzx ecx, TSmallBlockType[ebx].BlockSize + sub ecx, 4 + {Is it an upsize or a downsize?} + cmp ecx, edx + jb @SmallUpsize + {It's a downsize. Do we need to allocate a smaller block? Only if the new + size is less than a quarter of the available size less + SmallBlockDownsizeCheckAdder bytes} + lea ebx, [edx * 4 + SmallBlockDownsizeCheckAdder] + cmp ebx, ecx + jb @NotSmallInPlaceDownsize + {In-place downsize - return the original pointer} + pop esi + pop ebx + ret + {Align branch target} + nop +@NotSmallInPlaceDownsize: + {Save the requested size} + mov ebx, edx + {Allocate a smaller block} + mov eax, edx + call SysGetMem + {Allocated OK?} + test eax, eax + jz @SmallDownsizeDone + {Move data across: count in ecx} + mov ecx, ebx + {Destination in edx} + mov edx, eax + {Save the result in ebx} + mov ebx, eax + {Original pointer in eax} + mov eax, esi + {Move the data across} +{$ifdef UseCustomVariableSizeMoveRoutines} + call MoveX8L4 +{$else} + call Move +{$endif} + {Free the original pointer} + mov eax, esi + call SysFreeMem + {Return the pointer} + mov eax, ebx +@SmallDownsizeDone: + pop esi + pop ebx + ret + {Align branch target} + nop + nop +@SmallUpsize: + {State: esi = P, edx = Size, ecx = Current Block Size, ebx = Current Block Type} + {This pointer is being reallocated to a larger block and therefore it is + logical to assume that it may be enlarged again. Since reallocations are + expensive, there is a minimum upsize percentage to avoid unnecessary + future move operations.} + {Small blocks always grow with at least 100% + SmallBlockUpsizeAdder bytes} + lea ecx, [ecx + ecx + SmallBlockUpsizeAdder] + {save edi} + push edi + {Save the requested size in edi} + mov edi, edx + {New allocated size is the maximum of the requested size and the minimum + upsize} + xor eax, eax + sub ecx, edx + adc eax, -1 + and eax, ecx + add eax, edx + {Allocate the new block} + call SysGetMem + {Allocated OK?} + test eax, eax + jz @SmallUpsizeDone + {Do we need to store the requested size? Only large blocks store the + requested size.} + cmp edi, MaximumMediumBlockSize - BlockHeaderSize + jbe @NotSmallUpsizeToLargeBlock + {Store the user requested size} + mov [eax - 8], edi +@NotSmallUpsizeToLargeBlock: + {Get the size to move across} + movzx ecx, TSmallBlockType[ebx].BlockSize + sub ecx, BlockHeaderSize + {Move to the new block} + mov edx, eax + {Save the result in edi} + mov edi, eax + {Move from the old block} + mov eax, esi + {Move the data across} +{$ifdef UseCustomFixedSizeMoveRoutines} + call TSmallBlockType[ebx].UpsizeMoveProcedure +{$else} + call Move +{$endif} + {Free the old pointer} + mov eax, esi + call SysFreeMem + {Done} + mov eax, edi +@SmallUpsizeDone: + pop edi + pop esi + pop ebx + ret + {Align branch target} +{$ifndef UseCustomFixedSizeMoveRoutines} + nop + nop +{$endif} + nop +@NotASmallBlock: + {Is this a medium block or a large block?} + test cl, IsFreeBlockFlag + IsLargeBlockFlag + jnz @PossibleLargeBlock + {----------------------------Medium block-------------------------------} + {Status: ecx = Current Block Size + Flags, eax/esi = P, + edx = Requested Size} + mov ebx, ecx + {Drop the flags from the header} + and ecx, DropMediumAndLargeFlagsMask + {Save edi} + push edi + {Get a pointer to the next block in edi} + lea edi, [eax + ecx] + {Subtract the block header size from the old available size} + sub ecx, BlockHeaderSize + {Get the complete flags in ebx} + and ebx, ExtractMediumAndLargeFlagsMask + {Is it an upsize or a downsize?} + cmp edx, ecx + {Save ebp} + push ebp + {Is it an upsize or a downsize?} + ja @MediumBlockUpsize + {Status: ecx = Current Block Size - 4, bl = Current Block Flags, + edi = @Next Block, eax/esi = P, edx = Requested Size} + {Must be less than half the current size or we don't bother resizing.} + lea ebp, [edx + edx] + cmp ebp, ecx + jb @MediumMustDownsize +@MediumNoResize: + {Restore registers} + pop ebp + pop edi + pop esi + pop ebx + {Return} + ret + {Align branch target} + nop + nop + nop +@MediumMustDownsize: + {In-place downsize? Balance the cost of moving the data vs. the cost of + fragmenting the memory pool. Medium blocks in use may never be smaller + than MinimumMediumBlockSize.} + cmp edx, MinimumMediumBlockSize - BlockHeaderSize + jae @MediumBlockInPlaceDownsize + {The requested size is less than the minimum medium block size. If the + requested size is less than the threshold value (currently a quarter of the + minimum medium block size), move the data to a small block, otherwise shrink + the medium block to the minimum allowable medium block size.} + cmp edx, MediumInPlaceDownsizeLimit + jb @MediumDownsizeRealloc + {The request is for a size smaller than the minimum medium block size, but + not small enough to justify moving data: Reduce the block size to the + minimum medium block size} + mov edx, MinimumMediumBlockSize - BlockHeaderSize + {Is it already at the minimum medium block size?} + cmp ecx, edx + jna @MediumNoResize +@MediumBlockInPlaceDownsize: + {Round up to the next medium block size} + lea ebp, [edx + BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset] + and ebp, -MediumBlockGranularity; + add ebp, MediumBlockSizeOffset + {Get the size of the second split} + add ecx, BlockHeaderSize + sub ecx, ebp + {Lock the medium blocks} + cmp IsMultiThread, False + je @DoMediumInPlaceDownsize + {We have to re-read the flags} +@DoMediumLockForDownsize: + {Lock the medium blocks} + mov eax, $100 + {Attempt to lock the medium blocks} + lock cmpxchg MediumBlocksLocked, ah + je @MediumDownsizeRereadFlags + {Couldn't lock the medium blocks - sleep and try again} + push ecx + push InitialSleepTime + call Sleep + pop ecx + {Try again} + mov eax, $100 + {Attempt to grab the block type} + lock cmpxchg MediumBlocksLocked, ah + je @MediumDownsizeRereadFlags + {Couldn't lock the medium blocks - sleep and try again} + push ecx + push AdditionalSleepTime + call Sleep + pop ecx + {Try again} + jmp @DoMediumLockForDownsize + {Align branch target} +@MediumDownsizeRereadFlags: + mov ebx, ExtractMediumAndLargeFlagsMask + and ebx, [esi - 4] +@DoMediumInPlaceDownsize: + {Set the new size} + or ebx, ebp + mov [esi - 4], ebx + {Get the second split size in ebx} + mov ebx, ecx + {Is the next block in use?} + mov edx, [edi - 4] + test dl, IsFreeBlockFlag + jnz @MediumDownsizeNextBlockFree + {The next block is in use: flag its previous block as free} + or edx, PreviousMediumBlockIsFreeFlag + mov [edi - 4], edx + jmp @MediumDownsizeDoSplit + {Align branch target} + nop +@MediumDownsizeNextBlockFree: + {The next block is free: combine it} + mov eax, edi + and edx, DropMediumAndLargeFlagsMask + add ebx, edx + add edi, edx + cmp edx, MinimumMediumBlockSize + jb @MediumDownsizeDoSplit + call RemoveMediumFreeBlock +@MediumDownsizeDoSplit: + {Store the trailing size field} + mov [edi - 8], ebx + {Store the free part's header} + lea eax, [ebx + IsMediumBlockFlag + IsFreeBlockFlag]; + mov [esi + ebp - 4], eax + {Bin this free block} + cmp ebx, MinimumMediumBlockSize + jb @MediumBlockDownsizeDone + lea eax, [esi + ebp] + mov edx, ebx + call InsertMediumBlockIntoBin +@MediumBlockDownsizeDone: + {Unlock the medium blocks} + mov MediumBlocksLocked, False + {Result = old pointer} + mov eax, esi + {Restore registers} + pop ebp + pop edi + pop esi + pop ebx + {Return} + ret + {Align branch target} +@MediumDownsizeRealloc: + {Save the requested size} + mov edi, edx + mov eax, edx + {Allocate the new block} + call SysGetMem + test eax, eax + jz @MediumBlockDownsizeExit + {Save the result} + mov ebp, eax + mov edx, eax + mov eax, esi + mov ecx, edi + {Move the data across} +{$ifdef UseCustomVariableSizeMoveRoutines} + call MoveX8L4 +{$else} + call Move +{$endif} + mov eax, esi + call SysFreeMem + {Return the result} + mov eax, ebp +@MediumBlockDownsizeExit: + pop ebp + pop edi + pop esi + pop ebx + ret + {Align branch target} +@MediumBlockUpsize: + {Status: ecx = Current Block Size - 4, bl = Current Block Flags, + edi = @Next Block, eax/esi = P, edx = Requested Size} + {Can we do an in-place upsize?} + mov eax, [edi - 4] + test al, IsFreeBlockFlag + jz @CannotUpsizeMediumBlockInPlace + {Get the total available size including the next block} + and eax, DropMediumAndLargeFlagsMask + {ebp = total available size including the next block (excluding the header)} + lea ebp, [eax + ecx] + {Can the block fit?} + cmp edx, ebp + ja @CannotUpsizeMediumBlockInPlace + {The next block is free and there is enough space to grow this + block in place.} + cmp IsMultiThread, False + je @DoMediumInPlaceUpsize +@DoMediumLockForUpsize: + {Lock the medium blocks} + mov eax, $100 + {Attempt to lock the medium blocks} + lock cmpxchg MediumBlocksLocked, ah + je @RecheckMediumInPlaceUpsize + {Couldn't lock the medium blocks - sleep and try again} + push ecx + push edx + push InitialSleepTime + call Sleep + pop edx + pop ecx + {Try again} + mov eax, $100 + {Attempt to grab the block type} + lock cmpxchg MediumBlocksLocked, ah + je @RecheckMediumInPlaceUpsize + {Couldn't lock the medium blocks - sleep and try again} + push ecx + push edx + push AdditionalSleepTime + call Sleep + pop edx + pop ecx + {Try again} + jmp @DoMediumLockForUpsize + {Align branch target} +@RecheckMediumInPlaceUpsize: + {Re-read the info for this block} + mov ebx, ExtractMediumAndLargeFlagsMask + and ebx, [esi - 4] + {Re-read the info for the next block} + mov eax, [edi - 4] + {Next block still free?} + test al, IsFreeBlockFlag + jz @NextMediumBlockChanged + {Recalculate the next block size} + and eax, DropMediumAndLargeFlagsMask + {The available size including the next block} + lea ebp, [eax + ecx] + {Can the block still fit?} + cmp edx, ebp + ja @NextMediumBlockChanged +@DoMediumInPlaceUpsize: + {Is the next block binnable?} + cmp eax, MinimumMediumBlockSize + {Remove the next block} + jb @MediumInPlaceNoNextRemove + mov eax, edi + push ecx + push edx + call RemoveMediumFreeBlock + pop edx + pop ecx +@MediumInPlaceNoNextRemove: + {Medium blocks grow a minimum of 25% in in-place upsizes} + mov eax, ecx + shr eax, 2 + add eax, ecx + {Get the maximum of the requested size and the minimum growth size} + xor edi, edi + sub eax, edx + adc edi, -1 + and eax, edi + {Round up to the nearest block size granularity} + lea eax, [eax + edx + BlockHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset] + and eax, -MediumBlockGranularity + add eax, MediumBlockSizeOffset + {Calculate the size of the second split} + lea edx, [ebp + BlockHeaderSize] + sub edx, eax + {Does it fit?} + ja @MediumInPlaceUpsizeSplit + {Grab the whole block: Mark it as used in the block following it} + and dword ptr [esi + ebp], not PreviousMediumBlockIsFreeFlag + {The block size is the full available size plus header} + add ebp, 4 + {Upsize done} + jmp @MediumUpsizeInPlaceDone + {Align branch target} + nop + nop +@MediumInPlaceUpsizeSplit: + {Store the size of the second split as the second last dword} + mov [esi + ebp - 4], edx + {Set the second split header} + lea edi, [edx + IsMediumBlockFlag + IsFreeBlockFlag] + mov [esi + eax - 4], edi + mov ebp, eax + cmp edx, MinimumMediumBlockSize + jb @MediumUpsizeInPlaceDone + add eax, esi + call InsertMediumBlockIntoBin +@MediumUpsizeInPlaceDone: + {Set the size and flags for this block} + or ebp, ebx + mov [esi - 4], ebp + {Unlock the medium blocks} + mov MediumBlocksLocked, False + {Result = old pointer} + mov eax, esi +@MediumBlockResizeDone2: + {Restore registers} + pop ebp + pop edi + pop esi + pop ebx + {Return} + ret + {Align branch target for @CannotUpsizeMediumBlockInPlace} + nop + nop +@NextMediumBlockChanged: + {The next medium block changed while the medium blocks were being locked} + mov MediumBlocksLocked, False +@CannotUpsizeMediumBlockInPlace: + {Couldn't upsize in place. Grab a new block and move the data across: + If we have to reallocate and move medium blocks, we grow by at + least 25%} + mov eax, ecx + shr eax, 2 + add eax, ecx + {Get the maximum of the requested size and the minimum growth size} + xor edi, edi + sub eax, edx + adc edi, -1 + and eax, edi + add eax, edx + {Save the size to allocate} + mov ebp, eax + {Save the size to move across} + mov edi, ecx + {Get the block} + push edx + call SysGetMem + pop edx + {Success?} + test eax, eax + jz @MediumBlockResizeDone2 + {If it's a Large block - store the actual user requested size} + cmp ebp, MaximumMediumBlockSize - BlockHeaderSize + jbe @MediumUpsizeNotLarge + mov [eax - 8], edx +@MediumUpsizeNotLarge: + {Save the result} + mov ebp, eax + {Move the data across} + mov edx, eax + mov eax, esi + mov ecx, edi +{$ifdef UseCustomVariableSizeMoveRoutines} + call MoveX16L4 +{$else} + call Move +{$endif} + {Free the old block} + mov eax, esi + call SysFreeMem + {Restore the result} + mov eax, ebp + {Restore registers} + pop ebp + pop edi + pop esi + pop ebx + {Return} + ret + {Align branch target} + nop +@PossibleLargeBlock: + {Is this a valid large block?} + test cl, IsFreeBlockFlag + IsMediumBlockFlag + jnz @BadBlock + {-----------------------------Large block-------------------------------} + {State: ecx = Block Size + Flags, eax/esi = P, edx = Size} + {Large block available size is (16 + 4) less than the allocated size: get in ecx} + sub ecx, LargeBlockHeaderSize + BlockHeaderSize + IsLargeBlockFlag + {Is it an upsize or a downsize?} + cmp edx, ecx + jbe @LargeDownsize + {This pointer is being reallocated to a larger block and therefore it is + logical to assume that it may be enlarged again. Since reallocations are + expensive, there is a minimum upsize percentage to avoid unnecessary + future move operations.} + {Add 25% for large block upsizes} + mov eax, ecx + shr ecx, 2 + add ecx, eax + {Get the maximum of the requested size and the minimum upsize} + xor eax, eax + sub ecx, edx + adc eax, -1 + and eax, ecx + add eax, edx + {Save the allocated size} + mov ebx, eax + {Save the requested size} + push edx + {Allocate the new block} + call SysGetMem + {Restore requested size} + pop edx + {Allocation OK?} + test eax, eax + jz @LargeResizeDone + {If its a large block - store the actual user requested size (it may + not be if the block that is being reallocated from was previously + downsized)} + cmp ebx, MaximumMediumBlockSize - BlockHeaderSize + jbe @LargeUpsizeNotLarge + mov [eax - 8], edx +@LargeUpsizeNotLarge: + {Get the number of bytes to move in ecx (the old user size)} + mov ecx, [esi - 8] + {Save the result in ebx} + mov ebx, eax + {New pointer in edx} + mov edx, eax + {Original pointer in eax} + mov eax, esi +{$ifdef UseCustomVariableSizeMoveRoutines} + call MoveX16L4 +{$else} + call Move +{$endif} + {Free the old block} + mov eax, esi + call SysFreeMem + {Return the new pointer} + mov eax, ebx +@LargeResizeDone: + {Restore registers} + pop esi + pop ebx + {Done} + ret + {Align branch target} +@LargeDownsize: + {It's a downsize: do we need to reallocate? Only if the new size is less + than half the old size} + shr ecx, 1 + cmp edx, ecx + jb @LargeNotInPlaceDownsize + {Store the new user size} + mov [eax - 8], edx + {Restore registers} + pop esi + pop ebx + {Done} + ret + {Align branch target} +@LargeNotInPlaceDownsize: + {The block is less than half the old size, and the current size is + greater than the minimum block size allowing a downsize: reallocate} + {Save the requested size} + mov ebx, edx + {Get the new block} + mov eax, edx + call SysGetMem + test eax, eax + jz @LargeResizeDone + {Still a large block? -> Set the user size} + cmp ebx, MaximumMediumBlockSize - BlockHeaderSize + jbe @LargeNotInPlaceNotALargeBlock + mov [eax - 8], ebx +@LargeNotInPlaceNotALargeBlock: + {Bytes to move = new size} + mov ecx, ebx + {Save the pointer} + mov ebx, eax + {Move to the new pointer} + mov edx, eax + {Move from the old pointer} + mov eax, esi +{$ifdef UseCustomVariableSizeMoveRoutines} + call MoveX8L4 +{$else} + call Move +{$endif} + {Free the old block} + mov eax, esi + call SysFreeMem + {Return the new block} + mov eax, ebx + {Restore registers} + pop esi + pop ebx + {Done} + ret + {Align branch target} + nop + nop + nop +@BadBlock: + {---------------------------Invalid block-------------------------------} + xor eax, eax + pop esi + pop ebx +end; +{$endif} + +{Allocates a block and fills it with zeroes} +{$ifdef UsePascalCode} +function SysAllocMem(Size: Cardinal): Pointer; +begin + Result := SysGetMem(Size); + {Large blocks are already zero filled} + if (Result <> nil) and (Size <= (MaximumMediumBlockSize - BlockHeaderSize)) then + FillChar(Result^, Size, 0); +end; +{$else} +function SysAllocMem(Size: Cardinal): Pointer; +asm + push ebx + {Get the size rounded down to the previous multiple of 4 into ebx} + lea ebx, [eax - 1] + and ebx, -4 + {Get the block} + call SysGetMem + {Could a block be allocated? ecx = 0 if yes, $ffffffff if no} + cmp eax, 1 + sbb ecx, ecx + {Point edx to the last dword} + lea edx, [eax + ebx] + {ebx = $ffffffff if no block could be allocated, otherwise size rounded down + to previous multiple of 4} + or ebx, ecx + {Large blocks are already zero filled} + cmp ebx, MaximumMediumBlockSize - BlockHeaderSize + jae @Done + {Make the counter negative based} + neg ebx + {Load zero into st(0)} + fldz + {Clear groups of 8 bytes. Block sizes are always four less than a multiple + of 8, with a minimum of 12 bytes} +@FillLoop: + fst qword ptr [edx + ebx] + add ebx, 8 + js @FillLoop + {Clear the last four bytes} + mov [edx], ecx + {Clear st(0)} + ffree st(0) +@Done: + pop ebx +end; +{$endif} + +{----------Leak Checking and State Reporting Support Functions------------} + +{Advances to the next medium block. Returns nil if the end of the medium block + pool has been reached} +function NextMediumBlock(APMediumBlock: Pointer): Pointer; +var + LBlockSize: Cardinal; +begin + {Get the size of this block} + LBlockSize := PCardinal(Cardinal(APMediumBlock) - 4)^ and DropMediumAndLargeFlagsMask; + {Advance the pointer} + Result := Pointer(Cardinal(APMediumBlock) + LBlockSize); + {Is the next block the end of medium pool marker?} + LBlockSize := PCardinal(Cardinal(Result) - 4)^ and DropMediumAndLargeFlagsMask; + if LBlockSize = 0 then + Result := nil; +end; + +{Gets the first medium block in the medium block pool} +function GetFirstMediumBlockInPool(APMediumBlockPoolHeader: PMediumBlockPoolHeader): Pointer; +begin + if (MediumSequentialFeedBytesLeft = 0) + or (Cardinal(LastSequentiallyFedMediumBlock) < Cardinal(APMediumBlockPoolHeader)) + or (Cardinal(LastSequentiallyFedMediumBlock) > Cardinal(APMediumBlockPoolHeader) + MediumBlockPoolSize) then + begin + Result := Pointer(Cardinal(APMediumBlockPoolHeader) + MediumBlockPoolHeaderSize); + end + else + begin + {Is the sequential feed pool empty?} + if MediumSequentialFeedBytesLeft <> MediumBlockPoolSize - MediumBlockPoolHeaderSize then + Result := LastSequentiallyFedMediumBlock + else + Result := nil; + end; +end; + +{Gets the first and last block pointer for a small block pool} +procedure GetFirstAndLastSmallBlockInPool(APSmallBlockPool: PSmallBlockPoolHeader; + var AFirstPtr, ALastPtr: Pointer); +var + LBlockSize: Cardinal; +begin + {Get the pointer to the first block} + AFirstPtr := Pointer(Cardinal(APSmallBlockPool) + SmallBlockPoolHeaderSize); + {Get a pointer to the last block} + if (APSmallBlockPool.BlockType.CurrentSequentialFeedPool <> APSmallBlockPool) + or (Cardinal(APSmallBlockPool.BlockType.NextSequentialFeedBlockAddress) > Cardinal(APSmallBlockPool.BlockType.MaxSequentialFeedBlockAddress)) then + begin + {Not the sequential feed - point to the end of the block} + LBlockSize := PCardinal(Cardinal(APSmallBlockPool) - 4)^ and DropMediumAndLargeFlagsMask; + ALastPtr := Pointer(Cardinal(APSmallBlockPool) + LBlockSize - APSmallBlockPool.BlockType.BlockSize); + end + else + begin + {The sequential feed pool - point to before the next sequential feed block} + ALastPtr := Pointer(Cardinal(APSmallBlockPool.BlockType.NextSequentialFeedBlockAddress) - 1); + end; +end; + +{--------------------Memory Leak Checking and Reporting-------------------} + +{$ifdef IncludeMemoryLeakTrackingCode} +{Converts a cardinal to string at the buffer location, returning the new + buffer position.} +function CardinalToStrBuf(ACardinal: Cardinal; ABuffer: PChar): PChar; +asm + {On entry: eax = ACardinal, edx = ABuffer} + push edi + mov edi, edx //Pointer to the first character in edi + //Calculate leading digit: divide the number by 1e9 + add eax, 1 //Increment the number + mov edx, $89705f41 //1e9 reciprocal + mul edx //Multplying with reciprocal + shr eax, 30 //Save fraction bits + mov ecx, edx //First digit in bits <31:29> + and edx, $1fffffff //Filter fraction part edx<28:0> + shr ecx, 29 //Get leading digit into accumulator + lea edx, [edx + edx * 4] //Calculate ... + add edx, eax //... 5*fraction + mov eax, ecx //Copy leading digit + or eax, '0' //Convert digit to ASCII + mov [edi], al //Store digit out to memory + //Calculate digit #2 + mov eax, edx //Point format such that 1.0 = 2^28 + cmp ecx, 1 //Any non-zero digit yet ? + sbb edi, -1 //Yes->increment ptr, No->keep old ptr + shr eax, 28 //Next digit + and edx, $0fffffff //Fraction part edx<27:0> + or ecx, eax //Accumulate next digit + or eax, '0' //Convert digit to ASCII + mov [edi], al //Store digit out to memory + //Calculate digit #3 + lea eax, [edx + edx * 4] //5*fraction, new digit eax<31:27> + lea edx, [edx + edx * 4] //5*fraction, new fraction edx<26:0> + cmp ecx, 1 //Any non-zero digit yet ? + sbb edi, -1 //Yes->increment ptr, No->keep old ptr + shr eax, 27 //Next digit + and edx, $07ffffff //Fraction part + or ecx, eax //Accumulate next digit + or eax, '0' //Convert digit to ASCII + mov [edi], al //Store digit out to memory + //Calculate digit #4 + lea eax, [edx + edx * 4] //5*fraction, new digit eax<31:26> + lea edx, [edx + edx * 4] //5*fraction, new fraction edx<25:0> + cmp ecx, 1 //Any non-zero digit yet ? + sbb edi, -1 //Yes->increment ptr, No->keep old ptr + shr eax, 26 //Next digit + and edx, $03ffffff //Fraction part + or ecx, eax //Accumulate next digit + or eax, '0' //Convert digit to ASCII + mov [edi], al //Store digit out to memory + //Calculate digit #5 + lea eax, [edx + edx * 4] //5*fraction, new digit eax<31:25> + lea edx, [edx + edx * 4] //5*fraction, new fraction edx<24:0> + cmp ecx, 1 //Any non-zero digit yet ? + sbb edi, -1 //Yes->increment ptr, No->keep old ptr + shr eax, 25 //Next digit + and edx, $01ffffff //Fraction part + or ecx, eax //Accumulate next digit + or eax, '0' //Convert digit to ASCII + mov [edi], al //Store digit out to memory + //Calculate digit #6 + lea eax, [edx + edx * 4] //5*fraction, new digit eax<31:24> + lea edx, [edx + edx * 4] //5*fraction, new fraction edx<23:0> + cmp ecx, 1 //Any non-zero digit yet ? + sbb edi, -1 //Yes->increment ptr, No->keep old ptr + shr eax, 24 //Next digit + and edx, $00ffffff //Fraction part + or ecx, eax //Accumulate next digit + or eax, '0' //Convert digit to ASCII + mov [edi], al //Store digit out to memory + //Calculate digit #7 + lea eax, [edx + edx * 4] //5*fraction, new digit eax<31:23> + lea edx, [edx + edx * 4] //5*fraction, new fraction edx<31:23> + cmp ecx, 1 //Any non-zero digit yet ? + sbb edi, -1 //Yes->increment ptr, No->keep old ptr + shr eax, 23 //Next digit + and edx, $007fffff //Fraction part + or ecx, eax //Accumulate next digit + or eax, '0' //Convert digit to ASCII + mov [edi], al //Store digit out to memory + //Calculate digit #8 + lea eax, [edx + edx * 4] //5*fraction, new digit eax<31:22> + lea edx, [edx + edx * 4] //5*fraction, new fraction edx<22:0> + cmp ecx, 1 //Any non-zero digit yet ? + sbb edi, -1 //Yes->increment ptr, No->keep old ptr + shr eax, 22 //Next digit + and edx, $003fffff //Fraction part + or ecx, eax //Accumulate next digit + or eax, '0' //Convert digit to ASCII + mov [edi], al //Store digit out to memory + //Calculate digit #9 + lea eax, [edx + edx * 4] //5*fraction, new digit eax<31:21> + lea edx, [edx + edx * 4] //5*fraction, new fraction edx<21:0> + cmp ecx, 1 //Any non-zero digit yet ? + sbb edi, -1 //Yes->increment ptr, No->keep old ptr + shr eax, 21 //Next digit + and edx, $001fffff //Fraction part + or ecx, eax //Accumulate next digit + or eax, '0' //Convert digit to ASCII + mov [edi], al //Store digit out to memory + //Calculate digit #10 + lea eax, [edx + edx * 4] //5*fraction, new digit eax<31:20> + cmp ecx, 1 //Any-non-zero digit yet ? + sbb edi, -1 //Yes->increment ptr, No->keep old ptr + shr eax, 20 //Next digit + or eax, '0' //Convert digit to ASCII + mov [edi], al //Store last digit and end marker out to memory + {Return a pointer to the next character} + lea eax, [edi + 1] + {Restore edi} + pop edi +end; + +{Appends the source text to the destination and returns the new destination + position} +function AppendStringToBuffer(const ASource, ADestination: PChar; ACount: Cardinal): PChar; +begin + System.Move(ASource^, ADestination^, ACount); + Result := Pointer(Cardinal(ADestination) + ACount); +end; + +{Returns the class for a memory block. Returns nil if it is not a valid class} +function GetObjectClass(APointer: Pointer): TClass; +var + LMemInfo: TMemInfo; + + function InternalIsValidClass(APossibleClass: Pointer; ADepth: Integer = 0): Boolean; + var + LParentClass: Pointer; + begin + {Do we need to recheck the VM?} + if (Cardinal(LMemInfo.BaseAddress) > (Cardinal(APossibleClass) + Cardinal(vmtSelfPtr))) + or ((Cardinal(LMemInfo.BaseAddress) + Cardinal(LMemInfo.RegionSize)) < (Cardinal(APossibleClass) + Cardinal(vmtParent + 3))) then + begin + {Get the VM status for the pointer} + VirtualQuery(Pointer(Cardinal(APossibleClass) + Cardinal(vmtSelfPtr)), LMemInfo, + SizeOf(LMemInfo)); + end; + {Get the result, while checking for recursion} + Result := (ADepth < 1000) + {The required info must fit inside the region} + and ((Cardinal(LMemInfo.BaseAddress) + Cardinal(LMemInfo.RegionSize)) > (Cardinal(APossibleClass) + Cardinal(vmtParent + 3))) + {Memory must be committed} + and (LMemInfo.State = MEM_COMMIT) + {Memory must be readable} + and (LMemInfo.Protect and + (PAGE_READONLY or PAGE_READWRITE or PAGE_EXECUTE or PAGE_EXECUTE_READ or PAGE_EXECUTE_READWRITE or PAGE_EXECUTE_WRITECOPY) <> 0) + {Avoid accidentally growing the stack} + and (LMemInfo.Protect and PAGE_GUARD = 0) + {All class fields must fit inside the block} + {The self pointer must be valid} + and (PPointer(Cardinal(APossibleClass) + Cardinal(vmtSelfPtr))^ = APossibleClass); + {Check the parent class} + if Result then + begin + LParentClass := PPointer(Cardinal(APossibleClass) + Cardinal(vmtParent))^; + {The parent must also be a valid class} + Result := (LParentClass = nil) or + InternalIsValidClass(Pointer(Cardinal(LParentClass) - Cardinal(vmtSelfPtr)), ADepth + 1) + end; + end; + +begin + {Get the class pointer from the (suspected) object} + Result := TClass(PCardinal(APointer)^); + {No VM info yet} + LMemInfo.RegionSize := 0; + {Check the block} + if (Cardinal(Result) < 65536) + or (not InternalIsValidClass(Result, 0)) then + begin + Result := nil; + end; +end; +{$endif} + +{$ifdef IncludeMemoryLeakTrackingCode} +{Locks the expected leaks. Returns false if the list could not be allocated.} +function LockExpectedMemoryLeaksList: Boolean; +begin + {Lock the expected leaks list} + if IsMultiThread then + begin + while LockCmpxchg(0, 1, @ExpectedMemoryLeaksListLocked) <> 0 do + begin + Sleep(InitialSleepTime); + if LockCmpxchg(0, 1, @ExpectedMemoryLeaksListLocked) = 0 then + break; + Sleep(AdditionalSleepTime); + end; + end; + {Allocate the list if it does not exist} + if ExpectedMemoryLeaks = nil then + ExpectedMemoryLeaks := VirtualAlloc(nil, ExpectedMemoryLeaksListSize, MEM_COMMIT, PAGE_READWRITE); + {Done} + Result := ExpectedMemoryLeaks <> nil; +end; +{$endif} + +{Registers expected memory leaks. Returns true on success. The list of leaked + blocks is limited, so failure is possible if the list is full.} +function SysRegisterExpectedMemoryLeak(P: Pointer): boolean; +begin +{$ifdef IncludeMemoryLeakTrackingCode} + if LockExpectedMemoryLeaksList and + (ExpectedMemoryLeaks.NumExpectedLeaks < high(ExpectedMemoryLeaks.ExpectedLeaks)) then + begin + ExpectedMemoryLeaks.ExpectedLeaks[ExpectedMemoryLeaks.NumExpectedLeaks] := P; + Inc(ExpectedMemoryLeaks.NumExpectedLeaks); + Result := True; + end + else + Result := False; + ExpectedMemoryLeaksListLocked := False; +{$else} + Result := False; +{$endif} +end; + +function SysUnregisterExpectedMemoryLeak(P: Pointer): boolean; +{$ifdef IncludeMemoryLeakTrackingCode} +var + LIndex: integer; +{$endif} +begin + {Default to error} + Result := False; +{$ifdef IncludeMemoryLeakTrackingCode} + if (ExpectedMemoryleaks <> nil) and LockExpectedMemoryLeaksList then + begin + for LIndex := 0 to ExpectedMemoryleaks.NumExpectedLeaks - 1 do + begin + if ExpectedMemoryleaks.ExpectedLeaks[LIndex] = P then + begin + ExpectedMemoryleaks.ExpectedLeaks[LIndex] := + ExpectedMemoryleaks.ExpectedLeaks[ExpectedMemoryleaks.NumExpectedLeaks - 1]; + Dec(ExpectedMemoryleaks.NumExpectedLeaks); + Result := True; + break; + end; + end; + ExpectedMemoryLeaksListLocked := False; + end; +{$endif} +end; + +{$ifdef IncludeMemoryLeakTrackingCode} +{Checks for memory leaks on shutdown} +procedure ScanForMemoryLeaks; +type + {Leaked class type} + TLeakedClass = packed record + ClassPointer: TClass; + NumLeaks: Cardinal; + end; + TLeakedClasses = array[0..255] of TLeakedClass; + PLeakedClasses = ^TLeakedClasses; + {Leak statistics for a small block type} + TSmallBlockLeaks = array[0..NumSmallBlockTypes - 1] of TLeakedClasses; + {A leaked medium or large block} + TMediumAndLargeBlockLeaks = array[0..4095] of Cardinal; +var + {The leaked classes for small blocks} + LSmallBlockLeaks: TSmallBlockLeaks; + LMediumAndLargeBlockLeaks: TMediumAndLargeBlockLeaks; + LNumMediumAndLargeLeaks: Integer; + LPLargeBlock: PLargeBlockHeader; + LLeakMessage: array[0..32767] of char; + LMsgPtr: PChar; + LClassName: ShortString; + LExpectedLeaksOnly, LSmallLeakHeaderAdded, LBlockSizeHeaderAdded: Boolean; + LBlockTypeInd, LMediumBlockSize, LLargeBlockSize, + LClassInd, LPreviousBlockSize, LThisBlockSize, LBlockInd: Cardinal; + LPMediumBlock: Pointer; + LPMediumBlockPoolHeader: PMediumBlockPoolHeader; + LMediumBlockHeader: Cardinal; + + {Checks the small block pool for leaks.} + procedure CheckSmallBlockPoolForLeaks(APSmallBlockPool: PSmallBlockPoolHeader); + var + LLeakedClass: TClass; + LCharInd, LClassIndex, LStringLength: Integer; + LPStr: PChar; + LPossibleString: boolean; + LCurPtr, LEndPtr: Pointer; + LBlockTypeIndex: Cardinal; + LPLeakedClasses: PLeakedClasses; + begin + {Get the block type index} + LBlockTypeIndex := (Cardinal(APSmallBlockPool.BlockType) - Cardinal(@SmallBlockTypes[0])) div SizeOf(TSmallBlockType); + LPLeakedClasses := @LSmallBlockLeaks[LBlockTypeIndex]; + {Get the first and last pointer for the pool} + GetFirstAndLastSmallBlockInPool(APSmallBlockPool, LCurPtr, LEndPtr); + {Step through all blocks} + while Cardinal(LCurPtr) <= Cardinal(LEndPtr) do + begin + {Is this block an unexpected leak?} + if ((PCardinal(Cardinal(LCurPtr) - 4)^ and IsFreeBlockFlag) = 0) + and (not SysUnregisterExpectedMemoryLeak(LCurPtr)) then + begin + LExpectedLeaksOnly := False; + {Default to an unknown block} + LClassIndex := 0; + {Get the class contained by the block} + LLeakedClass := GetObjectClass(LCurPtr); + {Not a class? -> is it perhaps a string?} + if LLeakedClass = nil then + begin + {Reference count < 256} + if (PCardinal(LCurPtr)^ < 256) then + begin + LStringLength := PCardinal(Cardinal(LCurPtr) + 4)^; + {Does the string fit?} + if (LStringLength > 0) + and (LStringLength < (APSmallBlockPool.BlockType.BlockSize - (8 + 1 + 4))) then + begin + {Check that all characters are in range #32..#127} + LPStr := PChar(Cardinal(LCurPtr) + 8); + LPossibleString := True; + for LCharInd := 1 to LStringLength do + begin + LPossibleString := LPossibleString and (LPStr^ >= #32) and (LPStr^ < #128); + Inc(LPStr); + end; + {Must have a trailing #0} + if LPossibleString and (LPStr^ = #0) then + begin + LClassIndex := 1; + end; + end; + end; + end + else + begin + LClassIndex := 2; + while LClassIndex <= High(TLeakedClasses) do + begin + if (LPLeakedClasses[LClassIndex].ClassPointer = LLeakedClass) + or (LPLeakedClasses[LClassIndex].ClassPointer = nil) then + begin + break; + end; + Inc(LClassIndex); + end; + if LClassIndex <= High(TLeakedClasses) then + LPLeakedClasses[LClassIndex].ClassPointer := LLeakedClass + else + LClassIndex := 0; + end; + {Add to the number of leaks for the class} + Inc(LPLeakedClasses[LClassIndex].NumLeaks); + end; + {Next block} + Inc(Cardinal(LCurPtr), APSmallBlockPool.BlockType.BlockSize); + end; + end; + +begin + {Clear the leak arrays} + FillChar(LSmallBlockLeaks, SizeOf(LSmallBlockLeaks), 0); + FillChar(LMediumAndLargeBlockLeaks, SizeOf(LMediumAndLargeBlockLeaks), 0); + {Step through all the medium block pools} + LNumMediumAndLargeLeaks := 0; + {No unexpected leaks so far} + LExpectedLeaksOnly := True; + {Step through all the medium block pools} + LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader; + while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do + begin + LPMediumBlock := GetFirstMediumBlockInPool(LPMediumBlockPoolHeader); + while LPMediumBlock <> nil do + begin + LMediumBlockHeader := PCardinal(Cardinal(LPMediumBlock) - 4)^; + {Is the block in use?} + if LMediumBlockHeader and IsFreeBlockFlag = 0 then + begin + if (LMediumBlockHeader and IsSmallBlockPoolInUseFlag) <> 0 then + begin + {Get all the leaks for the small block pool} + CheckSmallBlockPoolForLeaks(LPMediumBlock); + end + else + begin + if LNumMediumAndLargeLeaks < length(LMediumAndLargeBlockLeaks) then + begin + LMediumBlockSize := (LMediumBlockHeader and DropMediumAndLargeFlagsMask) - BlockHeaderSize; + {Is it an expected leak?} + if not SysUnregisterExpectedMemoryLeak(LPMediumBlock) then + begin + LExpectedLeaksOnly := False; + {Add the leak to the list} + LMediumAndLargeBlockLeaks[LNumMediumAndLargeLeaks] := LMediumBlockSize; + Inc(LNumMediumAndLargeLeaks); + end; + end; + end; + end; + {Next medium block} + LPMediumBlock := NextMediumBlock(LPMediumBlock); + end; + {Get the next medium block pool} + LPMediumBlockPoolHeader := LPMediumBlockPoolHeader.NextMediumBlockPoolHeader; + end; + {Get all leaked large blocks} + LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader; + while (LPLargeBlock <> @LargeBlocksCircularList) + and (LNumMediumAndLargeLeaks < length(LMediumAndLargeBlockLeaks)) do + begin + {Is it an expected leak?} + if not SysUnregisterExpectedMemoryLeak(Pointer(Cardinal(LPLargeBlock) + LargeBlockHeaderSize)) then + begin + {Add the leak} + LExpectedLeaksOnly := False; + LLargeBlockSize := (LPLargeBlock.BlockSizeAndFlags and DropMediumAndLargeFlagsMask) + - BlockHeaderSize - LargeBlockHeaderSize; + LMediumAndLargeBlockLeaks[LNumMediumAndLargeLeaks] := LLargeBlockSize; + Inc(LNumMediumAndLargeLeaks); + end; + {Get the next large block} + LPLargeBlock := LPLargeBlock.NextLargeBlockHeader; + end; + {Display the leak message if required} + if not LExpectedLeaksOnly then + begin + {Small leak header has not been added} + LSmallLeakHeaderAdded := False; + LPreviousBlockSize := 0; + {Set up the leak message header so long} + LMsgPtr := AppendStringToBuffer(LeakMessageHeader, @LLeakMessage[0], length(LeakMessageHeader)); + {Step through all the small block types} + for LBlockTypeInd := 0 to NumSmallBlockTypes - 1 do + begin + LThisBlockSize := SmallBlockTypes[LBlockTypeInd].BlockSize - BlockHeaderSize; + LBlockSizeHeaderAdded := False; + {Any leaks?} + for LClassInd := high(LSmallBlockLeaks[LBlockTypeInd]) downto 0 do + begin + {Is there still space in the message buffer? Reserve space for the message + footer.} + if LMsgPtr > @LLeakMessage[high(LLeakMessage) - 2048] then + break; + {Check the count} + if LSmallBlockLeaks[LBlockTypeInd][LClassInd].NumLeaks > 0 then + begin + {Need to add the header?} + if not LSmallLeakHeaderAdded then + begin + LMsgPtr := AppendStringToBuffer(SmallLeakDetail, LMsgPtr, Length(SmallLeakDetail)); + LSmallLeakHeaderAdded := True; + end; + {Need to add the size header?} + if not LBlockSizeHeaderAdded then + begin + LMsgPtr^ := #13; + Inc(LMsgPtr); + LMsgPtr^ := #10; + Inc(LMsgPtr); + LMsgPtr := CardinalToStrBuf(LPreviousBlockSize + 1, LMsgPtr); + LMsgPtr^ := ' '; + Inc(LMsgPtr); + LMsgPtr^ := '-'; + Inc(LMsgPtr); + LMsgPtr^ := ' '; + Inc(LMsgPtr); + LMsgPtr := CardinalToStrBuf(LThisBlockSize, LMsgPtr); + LMsgPtr := AppendStringToBuffer(BytesMessage, LMsgPtr, Length(BytesMessage)); + LBlockSizeHeaderAdded := True; + end + else + begin + LMsgPtr^ := ','; + Inc(LMsgPtr); + LMsgPtr^ := ' '; + Inc(LMsgPtr); + end; + {Show the count} + case LClassInd of + {Unknown} + 0: + begin + LMsgPtr := AppendStringToBuffer(UnknownClassNameMsg, LMsgPtr, Length(UnknownClassNameMsg)); + end; + {Strings} + 1: + begin + LMsgPtr := AppendStringToBuffer(StringBlockMessage, LMsgPtr, Length(StringBlockMessage)); + end; + {Classes} + else + begin + LClassName := LSmallBlockLeaks[LBlockTypeInd][LClassInd].ClassPointer.ClassName; + LMsgPtr := AppendStringToBuffer(@LClassName[1], LMsgPtr, Length(LClassName)); + end; + end; + {Add the count} + LMsgPtr^ := ' '; + Inc(LMsgPtr); + LMsgPtr^ := 'x'; + Inc(LMsgPtr); + LMsgPtr^ := ' '; + Inc(LMsgPtr); + LMsgPtr := CardinalToStrBuf(LSmallBlockLeaks[LBlockTypeInd][LClassInd].NumLeaks, LMsgPtr); + end; + end; + LPreviousBlockSize := LThisBlockSize; + end; + {Add the medium/large block leak message} + if LNumMediumAndLargeLeaks > 0 then + begin + {Any non-small leaks?} + if LSmallLeakHeaderAdded then + begin + LMsgPtr^ := #13; + Inc(LMsgPtr); + LMsgPtr^ := #10; + Inc(LMsgPtr); + LMsgPtr^ := #13; + Inc(LMsgPtr); + LMsgPtr^ := #10; + Inc(LMsgPtr); + end; + {Add the medium/large block leak message} + LMsgPtr := AppendStringToBuffer(LargeLeakDetail, LMsgPtr, Length(LargeLeakDetail)); + {List all the blocks} + for LBlockInd := 0 to LNumMediumAndLargeLeaks - 1 do + begin + if LBlockInd <> 0 then + begin + LMsgPtr^ := ','; + Inc(LMsgPtr); + LMsgPtr^ := ' '; + Inc(LMsgPtr); + end; + LMsgPtr := CardinalToStrBuf(LMediumAndLargeBlockLeaks[LBlockInd], LMsgPtr); + {Is there still space in the message buffer? Reserve space for the + message footer.} + if LMsgPtr > @LLeakMessage[high(LLeakMessage) - 2048] then + break; + end; + end; + {Set the message footer} + AppendStringToBuffer(LeakMessageFooter, LMsgPtr, Length(LeakMessageFooter)); + {Show the message} + MessageBox(0, LLeakMessage, LeakMessageTitle, + MB_OK or MB_ICONERROR or MB_TASKMODAL); + end; +end; +{$endif} + +{-------------Memory Manager and Memory Usage Stats Reporting-------------} + +{Returns statistics about the current state of the memory manager} +procedure GetMemoryManagerState(var AMemoryManagerState: TMemoryManagerState); +var + LPMediumBlockPoolHeader: PMediumBlockPoolHeader; + LPMediumBlock: Pointer; + LInd: Integer; + LBlockTypeIndex, LMediumBlockSize, LMediumBlockHeader, LLargeBlockSize: Cardinal; + LPLargeBlock: PLargeBlockHeader; +begin + {Clear the results} + FillChar(AMemoryManagerState, SizeOf(AMemoryManagerState), 0); + {Set the small block size stats} + for LInd := 0 to NumSmallBlockTypes - 1 do + begin + AMemoryManagerState.SmallBlockTypeStates[LInd].InternalBlockSize := + SmallBlockTypes[LInd].BlockSize; + AMemoryManagerState.SmallBlockTypeStates[LInd].UseableBlockSize := + SmallBlockTypes[LInd].BlockSize - BlockHeaderSize; + if Integer(AMemoryManagerState.SmallBlockTypeStates[LInd].UseableBlockSize) < 0 then + AMemoryManagerState.SmallBlockTypeStates[LInd].UseableBlockSize := 0; + end; + {Lock all small block types} + LockAllSmallBlockTypes; + {Lock the medium blocks} + LockMediumBlocks; + {Step through all the medium block pools} + LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader; + while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do + begin + {Add to the medium block used space} + Inc(AMemoryManagerState.ReservedMediumBlockAddressSpace, MediumBlockPoolSize); + LPMediumBlock := GetFirstMediumBlockInPool(LPMediumBlockPoolHeader); + while LPMediumBlock <> nil do + begin + LMediumBlockHeader := PCardinal(Cardinal(LPMediumBlock) - 4)^; + {Is the block in use?} + if LMediumBlockHeader and IsFreeBlockFlag = 0 then + begin + {Get the block size} + LMediumBlockSize := LMediumBlockHeader and DropMediumAndLargeFlagsMask; + if (LMediumBlockHeader and IsSmallBlockPoolInUseFlag) <> 0 then + begin + {Get the block type index} + LBlockTypeIndex := (Cardinal(PSmallBlockPoolHeader(LPMediumBlock).BlockType) + - Cardinal(@SmallBlockTypes[0])) div SizeOf(TSmallBlockType); + {Subtract from medium block usage} + Dec(AMemoryManagerState.ReservedMediumBlockAddressSpace, LMediumBlockSize); + {Add it to the reserved space for the block size} + Inc(AMemoryManagerState.SmallBlockTypeStates[LBlockTypeIndex].ReservedAddressSpace, LMediumBlockSize); + {Add the usage for the pool} + Inc(AMemoryManagerState.SmallBlockTypeStates[LBlockTypeIndex].AllocatedBlockCount, + PSmallBlockPoolHeader(LPMediumBlock).BlocksInUse); + end + else + begin + Inc(AMemoryManagerState.AllocatedMediumBlockCount); + Inc(AMemoryManagerState.TotalAllocatedMediumBlockSize, LMediumBlockSize - BlockHeaderSize); + end; + end; + {Next medium block} + LPMediumBlock := NextMediumBlock(LPMediumBlock); + end; + {Get the next medium block pool} + LPMediumBlockPoolHeader := LPMediumBlockPoolHeader.NextMediumBlockPoolHeader; + end; + {Unlock medium blocks} + MediumBlocksLocked := False; + {Unlock all the small block types} + for LInd := 0 to NumSmallBlockTypes - 1 do + SmallBlockTypes[LInd].BlockTypeLocked := False; + {Step through all the large blocks} + LockLargeBlocks; + LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader; + while (LPLargeBlock <> @LargeBlocksCircularList) do + begin + LLargeBlockSize := LPLargeBlock.BlockSizeAndFlags and DropMediumAndLargeFlagsMask; + Inc(AMemoryManagerState.AllocatedLargeBlockCount); + Inc(AMemoryManagerState.ReservedLargeBlockAddressSpace, LLargeBlockSize); + Inc(AMemoryManagerState.TotalAllocatedLargeBlockSize, LPLargeBlock.UserAllocatedSize); + {Get the next large block} + LPLargeBlock := LPLargeBlock.NextLargeBlockHeader; + end; + LargeBlocksLocked := False; +end; + +{Gets the state of every 64K block in the 4GB address space} +procedure GetMemoryMap(var AMemoryMap: TMemoryMap); +var + LPMediumBlockPoolHeader: PMediumBlockPoolHeader; + LPLargeBlock: PLargeBlockHeader; + LLargeBlockSize, LChunkIndex, LInd: Cardinal; + LMBI: TMemInfo; +begin + {Clear the map} + FillChar(AMemoryMap, SizeOf(AMemoryMap), ord(csUnallocated)); + {Step through all the medium block pools} + LockMediumBlocks; + LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader; + while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do + begin + {Add to the medium block used space} + LChunkIndex := Cardinal(LPMediumBlockPoolHeader) shr 16; + for LInd := 0 to (MediumBlockPoolSize - 1) shr 16 do + AMemoryMap[LChunkIndex + LInd] := csAllocated; + {Get the next medium block pool} + LPMediumBlockPoolHeader := LPMediumBlockPoolHeader.NextMediumBlockPoolHeader; + end; + MediumBlocksLocked := False; + {Step through all the large blocks} + LockLargeBlocks; + LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader; + while (LPLargeBlock <> @LargeBlocksCircularList) do + begin + LChunkIndex := Cardinal(LPLargeBlock) shr 16; + LLargeBlockSize := LPLargeBlock.BlockSizeAndFlags and DropMediumAndLargeFlagsMask; + for LInd := 0 to (LLargeBlockSize - 1) shr 16 do + AMemoryMap[LChunkIndex + LInd] := csAllocated; + {Get the next large block} + LPLargeBlock := LPLargeBlock.NextLargeBlockHeader; + end; + LargeBlocksLocked := False; + {Fill in the rest of the map} + for LInd := 0 to 65535 do + begin + {If the chunk is not allocated by this MM, what is its status?} + if AMemoryMap[LInd] = csUnallocated then + begin + {Get all the reserved memory blocks and windows allocated memory blocks, etc.} + VirtualQuery(Pointer(LInd * 65536), LMBI, SizeOf(LMBI)); + if LMBI.State = MEM_COMMIT then + AMemoryMap[LInd] := csSysAllocated + else + if LMBI.State = MEM_RESERVE then + AMemoryMap[LInd] := csSysReserved; + end; + end; +end; + +{Returns summarised information about the state of the memory manager.} +function GetHeapStatus: THeapStatus; +var + LPMediumBlockPoolHeader: PMediumBlockPoolHeader; + LPMediumBlock: Pointer; + LBlockTypeIndex, LMediumBlockSize, LMediumBlockHeader, LLargeBlockSize, + LSmallBlockUsage, LSmallBlockOverhead: Cardinal; + LInd: Integer; + LPLargeBlock: PLargeBlockHeader; +begin + {Clear the structure} + FillChar(Result, SizeOf(Result), 0); + {Lock all small block types} + LockAllSmallBlockTypes; + {Lock the medium blocks} + LockMediumBlocks; + {Step through all the medium block pools} + LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader; + while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do + begin + {Add to the total and committed address space} + Inc(Result.TotalAddrSpace, ((MediumBlockPoolSize + $ffff) and $ffff0000)); + Inc(Result.TotalCommitted, ((MediumBlockPoolSize + $ffff) and $ffff0000)); + {Add the medium block pool overhead} + Inc(Result.Overhead, (((MediumBlockPoolSize + $ffff) and $ffff0000) + - MediumBlockPoolSize + MediumBlockPoolHeaderSize)); + {Get the first medium block in the pool} + LPMediumBlock := GetFirstMediumBlockInPool(LPMediumBlockPoolHeader); + while LPMediumBlock <> nil do + begin + {Get the block header} + LMediumBlockHeader := PCardinal(Cardinal(LPMediumBlock) - 4)^; + {Get the block size} + LMediumBlockSize := LMediumBlockHeader and DropMediumAndLargeFlagsMask; + {Is the block in use?} + if LMediumBlockHeader and IsFreeBlockFlag = 0 then + begin + if (LMediumBlockHeader and IsSmallBlockPoolInUseFlag) <> 0 then + begin + {Get the block type index} + LBlockTypeIndex := (Cardinal(PSmallBlockPoolHeader(LPMediumBlock).BlockType) + - Cardinal(@SmallBlockTypes[0])) div SizeOf(TSmallBlockType); + {Get the usage in the block} + LSmallBlockUsage := PSmallBlockPoolHeader(LPMediumBlock).BlocksInUse + * SmallBlockTypes[LBlockTypeIndex].BlockSize; + {Get the total overhead for all the small blocks} + LSmallBlockOverhead := PSmallBlockPoolHeader(LPMediumBlock).BlocksInUse + * BlockHeaderSize; + {Add to the totals} + Inc(Result.FreeSmall, LMediumBlockSize - LSmallBlockUsage - BlockHeaderSize); + Inc(Result.Overhead, LSmallBlockOverhead + BlockHeaderSize); + Inc(Result.TotalAllocated, LSmallBlockUsage - LSmallBlockOverhead); + end + else + begin + {Add to the result} + Inc(Result.TotalAllocated, LMediumBlockSize - BlockHeaderSize); + Inc(Result.Overhead, BlockHeaderSize); + end; + end + else + begin + {The medium block is free} + Inc(Result.FreeBig, LMediumBlockSize); + end; + {Next medium block} + LPMediumBlock := NextMediumBlock(LPMediumBlock); + end; + {Get the next medium block pool} + LPMediumBlockPoolHeader := LPMediumBlockPoolHeader.NextMediumBlockPoolHeader; + end; + {Add the sequential feed unused space} + Inc(Result.Unused, MediumSequentialFeedBytesLeft); + {Unlock the medium blocks} + MediumBlocksLocked := False; + {Unlock all the small block types} + for LInd := 0 to NumSmallBlockTypes - 1 do + SmallBlockTypes[LInd].BlockTypeLocked := False; + {Step through all the large blocks} + LockLargeBlocks; + LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader; + while (LPLargeBlock <> @LargeBlocksCircularList) do + begin + LLargeBlockSize := LPLargeBlock.BlockSizeAndFlags and DropMediumAndLargeFlagsMask; + Inc(Result.TotalAddrSpace, LLargeBlockSize); + Inc(Result.TotalCommitted, LLargeBlockSize); + Inc(Result.TotalAllocated, LPLargeBlock.UserAllocatedSize); + Inc(Result.Overhead, LLargeBlockSize - LPLargeBlock.UserAllocatedSize); + {Get the next large block} + LPLargeBlock := LPLargeBlock.NextLargeBlockHeader; + end; + LargeBlocksLocked := False; + {Set the total number of free bytes} + Result.TotalFree := Result.FreeSmall + Result.FreeBig + Result.Unused; +end; + +{------------------------Memory Manager Sharing---------------------------} + +{Wrapper around CreateWindowEx, but preserves the FPU control word} +function CreateWindow(lpClassName: PChar; lpWindowName: PChar; + dwStyle: DWORD; X, Y, nWidth, nHeight: Integer; hWndParent: HWND; + hMenu: HMENU; hInstance: HINST; lpParam: Pointer): HWND; +var + FPUCW: Word; +begin + {Protect the FPU control word} + FPUCW := Get8087CW; + Result := CreateWindowEx(0, lpClassName, lpWindowName, dwStyle, X, Y, + nWidth, nHeight, hWndParent, hMenu, hInstance, lpParam); + Set8087CW(FPUCW); +end; + +{Generates a string identifying the process} +procedure BuildProcessIDString; +var + i, LProcessID: Cardinal; +begin + LProcessID := GetCurrentProcessId; + for i := 0 to 7 do + begin + UniqueProcessIDString[8 - i] := + HexTable[((LProcessID shr (i * 4)) and $F)]; + end; +end; + +{Searches the current process for a shared memory manager} +function FindSharedMemoryManager: PMemoryManagerEx; +var + LSharedMMWindow: HWND; +begin + BuildProcessIDString; + {Find the shared memory manager} + LSharedMMWindow := FindWindow('STATIC', PChar(@UniqueProcessIDString[1])); + if LSharedMMWindow = 0 then + begin + {No shared memory manager in the process} + Result := nil; + end + else + begin + {Get the address of the shared memory manager} + Result := PMemoryManagerEx(GetWindowLong(LSharedMMWindow, GWL_USERDATA)); + end; +end; + +{Searches the current process for a shared memory manager. If no memory has + been allocated using this memory manager it will switch to using the shared + memory manager instead. Returns true if another memory manager was found and + it could be shared.} +function AttemptToUseSharedMemoryManager: Boolean; +var + LPMemoryManagerEx: PMemoryManagerEx; +begin + if not IsMemoryManagerSet then + begin + {Is this MM being shared? If so, switching to another MM is not allowed} + if MMSharingWindow = 0 then + begin + {May not switch memory manager after memory has been allocated} + if (MediumBlockPoolsCircularList.NextMediumBlockPoolHeader = @MediumBlockPoolsCircularList) + and (LargeBlocksCircularList.NextLargeBlockHeader = @LargeBlocksCircularList) then + begin + LPMemoryManagerEx := FindSharedMemoryManager; + if LPMemoryManagerEx <> nil then + begin + SetMemoryManager(LPMemoryManagerEx^); + Result := True; + end + else + Result := False; + end + else + begin + {Memory has already been allocated using this memory manager. We cannot + rip the memory manager out from under live pointers.} + MessageBox(0, LivePointersErrorMsg, ShareMMErrorTitle, + MB_OK or MB_ICONERROR or MB_TASKMODAL); + Result := False; + end; + end + else + begin + {Display an error message: not allowed to switch memory manager if it is + being shared.} + MessageBox(0, BeingSharedErrorMsg, ShareMMErrorTitle, + MB_OK or MB_ICONERROR or MB_TASKMODAL); + Result := False; + end; + end + else + begin + {Another memory manager has already been installed.} + Result := False; + end; +end; + +{Starts sharing this memory manager with other modules in the current process. + Only one memory manager may be shared per process, so this function may fail.} +function ShareMemoryManager: Boolean; +begin + if (not IsMemoryManagerSet) and (MMSharingWindow = 0) then + begin + {Is any other module already sharing its MM?} + if (FindSharedMemoryManager = nil) then + begin + {No memory manager installed yet - create the invisible window} + MMSharingWindow := CreateWindow('STATIC', PChar(@UniqueProcessIDString[1]), + WS_POPUP, 0, 0, 0, 0, 0, 0, GetCurrentProcessID, nil); + {The window data is a pointer to this shared memory manager} + SetWindowLong(MMSharingWindow, GWL_USERDATA, Integer(@ThisMemoryManager)); + {Sharing this MM} + Result := True; + end + else + begin + {Another module is already sharing its memory manager} + Result := False; + end; + end + else + begin + {Either another memory manager has been set or this memory manager is + already being shared} + Result := False; + end; +end; + +{--------------------------Memory Manager Setup---------------------------} + +{Builds the block size to small block type lookup table} +procedure BuildBlockTypeLookupTable; +var + LBlockTypeInd, LStartIndex, LNextStartIndex: Cardinal; + LBlockTypeVal: Byte; +begin + LStartIndex := 0; + for LBlockTypeInd := 0 to high(SmallBlockTypes) do + begin + {Is this a valid block type for the alignment restriction?} + if (MinimumBlockAlignment = mba8Byte) + or (SmallBlockTypes[LBlockTypeInd].BlockSize and 15 = 0) then + begin + LNextStartIndex := SmallBlockTypes[LBlockTypeInd].BlockSize div SmallBlockGranularity; + {Store the block type index * 4 in the appropriate slots.} + LBlockTypeVal := LBlockTypeInd * 4; + while LStartIndex < LNextStartIndex do + begin + AllocSize2SmallBlockTypeIndX4[LStartIndex] := LBlockTypeVal; + Inc(LStartIndex); + end; + {Set the start of the next block type} + LStartIndex := LNextStartIndex; + end; + end; +end; + +function GetMinimumBlockAlignment: TMinimumBlockAlignment; +begin + Result := MinimumBlockAlignment; +end; + +procedure SetMinimumBlockAlignment(AMinimumBlockAlignment: TMinimumBlockAlignment); +begin + if AMinimumBlockAlignment <> MinimumBlockAlignment then + begin + MinimumBlockAlignment := AMinimumBlockAlignment; + {Rebuild the size to small block type lookup table} + BuildBlockTypeLookupTable; + end; +end; + +{Initializes the lookup tables for the memory manager} +procedure InitializeMemoryManager; +var + i, LMinimumPoolSize, LOptimalPoolSize, LGroupNumber, LBlocksPerPool: Cardinal; + LPMediumFreeBlock: PMediumFreeBlock; +begin + {---------------------Set up the small block types----------------------} + for i := 0 to high(SmallBlockTypes) do + begin + {The upsize move procedure may move chunks in 16 bytes even with 8-byte + alignment, since the new size will always be at least 8 bytes bigger than + the old size.} +{$ifdef UseCustomFixedSizeMoveRoutines} + if not Assigned(SmallBlockTypes[i].UpsizeMoveProcedure) then + {$ifdef UseCustomVariableSizeMoveRoutines} + SmallBlockTypes[i].UpsizeMoveProcedure := MoveX16L4; + {$else} + SmallBlockTypes[i].UpsizeMoveProcedure := Move; + {$endif} +{$endif} + {Set the first "available pool" to the block type itself, so that the + allocation routines know that there are currently no pools with free + blocks of this size.} + SmallBlockTypes[i].PreviousPartiallyFreePool := @SmallBlockTypes[i]; + SmallBlockTypes[i].NextPartiallyFreePool := @SmallBlockTypes[i]; + {Cannot sequential feed yet: Ensure that the next address is greater than + the maximum address} + SmallBlockTypes[i].MaxSequentialFeedBlockAddress := pointer(0); + SmallBlockTypes[i].NextSequentialFeedBlockAddress := pointer(1); + {Get the mask to use for finding a medium block suitable for a block pool} + LMinimumPoolSize := + ((SmallBlockTypes[i].BlockSize * MinimumSmallBlocksPerPool + + (SmallBlockPoolHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset)) + and -MediumBlockGranularity) + MediumBlockSizeOffset; + if LMinimumPoolSize < MinimumMediumBlockSize then + LMinimumPoolSize := MinimumMediumBlockSize; + {Get the closest group number for the minimum pool size} + LGroupNumber := (LMinimumPoolSize + (- MinimumMediumBlockSize + MediumBlockBinsPerGroup * MediumBlockGranularity div 2)) + div (MediumBlockBinsPerGroup * MediumBlockGranularity); + {Too large?} + if LGroupNumber > 7 then + LGroupNumber := 7; + {Set the bitmap} + SmallBlockTypes[i].AllowedGroupsForBlockPoolBitmap := Byte(Byte(-1) shl LGroupNumber); + {Set the minimum pool size} + SmallBlockTypes[i].MinimumBlockPoolSize := MinimumMediumBlockSize + LGroupNumber * (MediumBlockBinsPerGroup * MediumBlockGranularity); + {Get the optimal block pool size} + LOptimalPoolSize := ((SmallBlockTypes[i].BlockSize * TargetSmallBlocksPerPool + + (SmallBlockPoolHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset)) + and -MediumBlockGranularity) + MediumBlockSizeOffset; + {Limit the optimal pool size to within range} + if LOptimalPoolSize < OptimalSmallBlockPoolSizeLowerLimit then + LOptimalPoolSize := OptimalSmallBlockPoolSizeLowerLimit; + if LOptimalPoolSize > OptimalSmallBlockPoolSizeUpperLimit then + LOptimalPoolSize := OptimalSmallBlockPoolSizeUpperLimit; + {How many blocks will fit in the adjusted optimal size?} + LBlocksPerPool := (LOptimalPoolSize - SmallBlockPoolHeaderSize) div SmallBlockTypes[i].BlockSize; + {Recalculate the optimal pool size to minimize wastage due to a partial + last block.} + SmallBlockTypes[i].OptimalBlockPoolSize := + ((LBlocksPerPool * SmallBlockTypes[i].BlockSize + (SmallBlockPoolHeaderSize + MediumBlockGranularity - 1 - MediumBlockSizeOffset)) + and -MediumBlockGranularity) + MediumBlockSizeOffset; + end; + {Build the requested size to block type lookup table} + BuildBlockTypeLookupTable; + {--------------------------Set up the medium blocks---------------------} + {There are currently no medium block pools} + MediumBlockPoolsCircularList.PreviousMediumBlockPoolHeader := @MediumBlockPoolsCircularList; + MediumBlockPoolsCircularList.NextMediumBlockPoolHeader := @MediumBlockPoolsCircularList; + {All medium bins are empty} + for i := 0 to high(MediumBlockBins) do + begin + LPMediumFreeBlock := @MediumBlockBins[i]; + LPMediumFreeBlock.PreviousFreeBlock := LPMediumFreeBlock; + LPMediumFreeBlock.NextFreeBlock := LPMediumFreeBlock; + end; + {------------------------Set up the large blocks------------------------} + LargeBlocksCircularList.PreviousLargeBlockHeader := @LargeBlocksCircularList; + LargeBlocksCircularList.NextLargeBlockHeader := @LargeBlocksCircularList; +end; + +{Frees all allocated memory.} +procedure FreeAllMemory; +var + LPMediumBlockPoolHeader, LPNextMediumBlockPoolHeader: PMediumBlockPoolHeader; + LPMediumFreeBlock: PMediumFreeBlock; + LPLargeBlock, LPNextLargeBlock: PLargeBlockHeader; + LInd: integer; +begin + {Free all block pools} + LPMediumBlockPoolHeader := MediumBlockPoolsCircularList.NextMediumBlockPoolHeader; + while LPMediumBlockPoolHeader <> @MediumBlockPoolsCircularList do + begin + {Get the next medium block pool so long} + LPNextMediumBlockPoolHeader := LPMediumBlockPoolHeader.NextMediumBlockPoolHeader; + {Free this pool} + VirtualFree(LPMediumBlockPoolHeader, 0, MEM_RELEASE); + {Next pool} + LPMediumBlockPoolHeader := LPNextMediumBlockPoolHeader; + end; + {Clear all small block types} + for LInd := 0 to high(SmallBlockTypes) do + begin + SmallBlockTypes[Lind].PreviousPartiallyFreePool := @SmallBlockTypes[Lind]; + SmallBlockTypes[Lind].NextPartiallyFreePool := @SmallBlockTypes[Lind]; + SmallBlockTypes[Lind].NextSequentialFeedBlockAddress := pointer(1); + SmallBlockTypes[Lind].MaxSequentialFeedBlockAddress := nil; + end; + {Clear all medium block pools} + MediumBlockPoolsCircularList.PreviousMediumBlockPoolHeader := @MediumBlockPoolsCircularList; + MediumBlockPoolsCircularList.NextMediumBlockPoolHeader := @MediumBlockPoolsCircularList; + {All medium bins are empty} + for LInd := 0 to high(MediumBlockBins) do + begin + LPMediumFreeBlock := @MediumBlockBins[LInd]; + LPMediumFreeBlock.PreviousFreeBlock := LPMediumFreeBlock; + LPMediumFreeBlock.NextFreeBlock := LPMediumFreeBlock; + end; + {Free all large blocks} + LPLargeBlock := LargeBlocksCircularList.NextLargeBlockHeader; + while LPLargeBlock <> @LargeBlocksCircularList do + begin + {Get the next large block} + LPNextLargeBlock := LPLargeBlock.NextLargeBlockHeader; + {Free this large block} + VirtualFree(LPLargeBlock, 0, MEM_RELEASE); + {Next large block} + LPLargeBlock := LPNextLargeBlock; + end; + {There are no large blocks allocated} + LargeBlocksCircularList.PreviousLargeBlockHeader := @LargeBlocksCircularList; + LargeBlocksCircularList.NextLargeBlockHeader := @LargeBlocksCircularList; +end; + +procedure FinalizeMemoryManager; +begin + {Destroy the sharing window if applicable} + if MMSharingWindow <> 0 then + begin + DestroyWindow(MMSharingWindow); + MMSharingWindow := 0; + end; +{$ifdef IncludeMemoryLeakTrackingCode} + {Should memory leaks be reported?} + if ReportMemoryLeaksOnShutdown then + ScanForMemoryLeaks; + {Free the expected memory leaks list} + if ExpectedMemoryLeaks <> nil then + begin + VirtualFree(ExpectedMemoryLeaks, 0, MEM_RELEASE); + ExpectedMemoryLeaks := nil; + end; +{$endif} + {Clean up: Free all memory allocated through this memory manager. If this is + a library that is frequently loaded and unloaded then it is necessary to + prevent the process from running out of address space.} + FreeAllMemory; +end; + diff --git a/System/D2006_orig/sharemem.pas b/System/D2006_orig/sharemem.pas new file mode 100644 index 0000000..d70f74c --- /dev/null +++ b/System/D2006_orig/sharemem.pas @@ -0,0 +1,233 @@ +{ *********************************************************************** } +{ } +{ Delphi / Kylix Cross-Platform Runtime Library } +{ } +{ Copyright (c) 1995-2005 Borland Software Corporation } +{ } +{ *********************************************************************** } + +unit ShareMem; + +interface + +{$IFDEF MEMORY_DIAG} +type + TBlockEnumProc = function (Block: Pointer): Boolean; +{$ENDIF} + +function SysGetMem(Size: Integer): Pointer; +function SysFreeMem(P: Pointer): Integer; +function SysReallocMem(P: Pointer; Size: Integer): Pointer; +function SysAllocMem(Size: Cardinal): Pointer; +function SysRegisterExpectedMemoryLeak(P: Pointer): Boolean; +function SysUnregisterExpectedMemoryLeak(P: Pointer): Boolean; +function GetHeapStatus: THeapStatus; +function GetAllocMemCount: Integer; +function GetAllocMemSize: Integer; +procedure DumpBlocks; +procedure HeapAddRef; +procedure HeapRelease; + +{$IFDEF MEMORY_DIAG} +function InitBlockMarking: Boolean; +function MarkBlocks: Integer; +function GetMarkedBlocks(MarkID: Integer; Proc: TBlockEnumProc): Boolean; +{$ENDIF} + +implementation + +{$IFDEF GLOBALALLOC} +uses Windows; +{$ENDIF} + +{$IFDEF MEMORY_DIAG} +type + TInitBlockMarking = function: Boolean; + TMarkBlocks = function: Integer; + TGetMarkedBlocks = function (MarkID: Integer; Proc: TBlockEnumProc): Boolean; + +var + MMHandle: Integer = 0; + SysInitBlockMarking: TInitBlockMarking = nil; + SysMarkBlocks: TMarkBlocks = nil; + SysGetMarkedBlocks: TGetMarkedBlocks = nil; +{$ENDIF} +var + {Need access to the shared memory manager structure to be able to call the + default AllocMem and leak registration handlers for borlndmm.dll libraries + that do not implement these functions.} + SharedMemoryManager: TMemoryManagerEx; + +const + DelphiMM = 'borlndmm.dll'; + +function SysGetMem(Size: Integer): Pointer; external DelphiMM name '@Borlndmm@SysGetMem$qqri'; +function SysFreeMem(P: Pointer): Integer; external DelphiMM name '@Borlndmm@SysFreeMem$qqrpv'; +function SysReallocMem(P: Pointer; Size: Integer): Pointer; external DelphiMM name '@Borlndmm@SysReallocMem$qqrpvi'; +function GetHeapStatus: THeapStatus; external DelphiMM; +function GetAllocMemCount: Integer; external DelphiMM; +function GetAllocMemSize: Integer; external DelphiMM; +procedure DumpBlocks; external DelphiMM; + +function GetModuleHandle(lpModuleName: PChar): Integer; stdcall; + external 'kernel32.dll' name 'GetModuleHandleA'; +function GetProcAddress(hModule: Integer; lpProcName: PChar): Pointer; stdcall; + external 'kernel32.dll' name 'GetProcAddress'; + +{$IFDEF MEMORY_DIAG} + +procedure InitMMHandle; +begin + if MMHandle = 0 then MMHandle := GetModuleHandle(DelphiMM); +end; + +function InitBlockMarking: Boolean; +begin + InitMMHandle; + if @SysInitBlockMarking = nil then + @SysInitBlockMarking := GetProcAddress(MMHandle, 'InitBlockMarking'); + if @SysInitBlockMarking <> nil then + Result := SysInitBlockMarking + else Result := False; +end; + +function MarkBlocks: Integer; +begin + InitMMHandle; + if @SysMarkBlocks = nil then + @SysMarkBlocks := GetProcAddress(MMHandle, 'MarkBlocks'); + if @SysMarkBlocks <> nil then + Result := SysMarkBlocks + else Result := -1; +end; + +function GetMarkedBlocks(MarkID: Integer; Proc: TBlockEnumProc): Boolean; +begin + InitMMHandle; + if @SysGetMarkedBlocks = nil then + @SysGetMarkedBlocks := GetProcAddress(MMHandle, 'GetMarkedBlocks'); + if @SysGetMarkedBlocks <> nil then + Result := SysGetMarkedBlocks(MarkID, Proc) + else Result := False; +end; +{$ENDIF} + +{$IFDEF GLOBALALLOC} +function xSysGetMem(Size: Integer): Pointer; +begin + Result := GlobalAllocPtr(HeapAllocFlags, Size); +end; + +function xSysFreeMem(P: Pointer): Integer; +begin + Result := GlobalFreePtr(P); +end; + +function xSysReallocMem(P: Pointer; Size: Integer): Pointer; +begin + Result := GlobalReallocPtr(P, Size, 0); +end; +{$ENDIF} + +procedure HeapAddRef; +var + MM: Integer; + Proc: procedure; +begin + MM := GetModuleHandle(DelphiMM); + Proc := GetProcAddress(MM, '@Borlndmm@HeapAddRef$qqrv'); + if Assigned(Proc) then + Proc; +end; + +procedure HeapRelease; +var + MM: Integer; + Proc: procedure; +begin + MM := GetModuleHandle(DelphiMM); + Proc := GetProcAddress(MM, '@Borlndmm@HeapRelease$qqrv'); + if Assigned(Proc) then + Proc; +end; + +{The default AllocMem implementation - for older borlndmm.dll libraries that do + not implement this themselves.} +function DefaultAllocMem(Size: Cardinal): Pointer; +begin + Result := SysGetMem(Size); + if (Result <> nil) then + FillChar(Result^, Size, 0); +end; + +{The default (do nothing) leak registration function for backward compatibility + with older borlndmm.dll libraries.} +function DefaultRegisterAndUnregisterExpectedMemoryLeak(P: Pointer): boolean; +begin + Result := False; +end; + +function SysAllocMem(Size: Cardinal): Pointer; +begin + {Indirect call, because the library may not implement this functionality} + Result := SharedMemoryManager.AllocMem(Size); +end; + +function SysRegisterExpectedMemoryLeak(P: Pointer): Boolean; +begin + {Indirect call, because the library may not implement this functionality} + Result := SharedMemoryManager.RegisterExpectedMemoryLeak(P); +end; + +function SysUnregisterExpectedMemoryLeak(P: Pointer): Boolean; +begin + {Indirect call, because the library may not implement this functionality} + Result := SharedMemoryManager.UnregisterExpectedMemoryLeak(P); +end; + +procedure InitMemoryManager; +var + ProcAddr: Pointer; + MM: Integer; +begin + // force a static reference to borlndmm.dll, so we don't have to LoadLibrary + SharedMemoryManager.GetMem := SysGetMem; + + MM := GetModuleHandle(DelphiMM); + HeapAddRef; +{$IFDEF GLOBALALLOC} + SharedMemoryManager.GetMem := xSysGetMem; + SharedMemoryManager.FreeMem := xSysFreeMem; + SharedMemoryManager.ReallocMem := xSysReallocMem; +{$ELSE} + SharedMemoryManager.GetMem := GetProcAddress(MM,'@Borlndmm@SysGetMem$qqri'); + SharedMemoryManager.FreeMem := GetProcAddress(MM,'@Borlndmm@SysFreeMem$qqrpv'); + SharedMemoryManager.ReallocMem := GetProcAddress(MM, '@Borlndmm@SysReallocMem$qqrpvi'); +// Cannot assume that the functions below are implemented. Default handlers are set in initialization section. + ProcAddr := GetProcAddress(MM,'@Borlndmm@SysAllocMem$qqri'); + if ProcAddr <> nil then + SharedMemoryManager.AllocMem := ProcAddr; + ProcAddr := GetProcAddress(MM,'@Borlndmm@SysRegisterExpectedMemoryLeak$qqrpi'); + if ProcAddr <> nil then + SharedMemoryManager.RegisterExpectedMemoryLeak := ProcAddr; + ProcAddr := GetProcAddress(MM, '@Borlndmm@SysUnregisterExpectedMemoryLeak$qqrpi'); + if ProcAddr <> nil then + SharedMemoryManager.UnregisterExpectedMemoryLeak := ProcAddr; +{$ENDIF} + SetMemoryManager(SharedMemoryManager); +end; + +initialization + {Set the default handlers for older borlndmm.dll libraries that do not + implement the extended memory manager functionality} + SharedMemoryManager.AllocMem := DefaultAllocMem; + SharedMemoryManager.RegisterExpectedMemoryLeak := + DefaultRegisterAndUnregisterExpectedMemoryLeak; + SharedMemoryManager.UnregisterExpectedMemoryLeak := + DefaultRegisterAndUnregisterExpectedMemoryLeak; + if not IsMemoryManagerSet then + InitMemoryManager; +finalization + if IsMemoryManagerSet then + HeapRelease; +end. diff --git a/System/D2006beta/SYSWSTR.PAS b/System/D2006beta/SYSWSTR.PAS new file mode 100644 index 0000000..ab8a677 --- /dev/null +++ b/System/D2006beta/SYSWSTR.PAS @@ -0,0 +1,18 @@ +unit syswstr; +{X: this unit contains some definitions and initializations, needed to + support wide string variables. To use it, just place reference to syswstr + unit in your dpr/units uses clause *as first as possible* } + +interface + +implementation + +initialization + + WStrAddRefProc := WStrAddRef; + WStrClrProc := WStrClr; + WStrArrayClrProc := WStrArrayClr; + +finalization + +end. diff --git a/System/D2006beta/SysInit.pas b/System/D2006beta/SysInit.pas new file mode 100644 index 0000000..3abc531 --- /dev/null +++ b/System/D2006beta/SysInit.pas @@ -0,0 +1,864 @@ +{ *********************************************************************** } +{ } +{ Delphi / Kylix Cross-Platform Runtime Library } +{ System Initialization Unit } +{ } +{ Copyright (c) 1997-2002 Borland Software Corporation } +{ } +{ This file may be distributed and/or modified under the terms of the } +{ GNU General Public License version 2 as published by the Free Software } +{ Foundation and appearing at http://www.borland.com/kylix/gpl.html. } +{ } +{ Licensees holding a valid Borland No-Nonsense License for this } +{ Software may use this file in accordance with such license, which } +{ appears in the file license.txt that came with this software. } +{ } +{ *********************************************************************** } + +unit SysInit; +//Изменено: Avenger + +interface + +{$H+,I-,R-,S-,O+,W-} +{$WARN SYMBOL_PLATFORM OFF} + +{X} // if your app really need to localize resource, call: +{X} procedure UseLocalizeResources; + +{$IFDEF LINUX} +const + ExeBaseAddress = Pointer($8048000) platform; +{$ENDIF} + +var + Copyright : String = '';//{'Portions Copyright (c) 1999,2003'; //}'Portions Copyright (c) 1999,2003 Avenger by NhT'; + + ModuleIsLib: Boolean; { True if this module is a dll (a library or a package) } + ModuleIsPackage: Boolean; { True if this module is a package } + ModuleIsCpp: Boolean; { True if this module is compiled using C++ Builder } + TlsIndex: Integer = -1; { Thread local storage index } + TlsLast: Byte; { Set by linker so its offset is last in TLS segment } + HInstance: LongWord; { Handle of this instance } + {$EXTERNALSYM HInstance} + (*$HPPEMIT 'namespace Sysinit' *) + (*$HPPEMIT '{' *) + (*$HPPEMIT 'extern PACKAGE HINSTANCE HInstance;' *) + (*$HPPEMIT '} /* namespace Sysinit */' *) + DllProc: TDLLProc; { Called whenever DLL entry point is called } + { DllProcEx passes the Reserved param provided by WinNT on DLL load & exit } + DllProcEx: TDLLProcEx absolute DllProc; + DataMark: Integer = 0; { Used to find the virtual base of DATA seg } + CoverageLibraryName: array [0..128] of char = '*'; { initialized by the linker! } +{$IFDEF ELF} + TypeImportsTable: array [0..0] of Pointer platform; { VMT and RTTI imports table for exes } + _GLOBAL_OFFSET_TABLE_: ARRAY [0..2] OF Cardinal platform; + (* _DYNAMIC: ARRAY [0..0] OF Elf32_Dyn; *) +{$IFDEF PC_MAPPED_EXCEPTIONS} + TextStartAdj: Byte platform; { See GetTextStart } + CodeSegSize: Byte platform; { See GetTextStart } +function GetTextStart : LongInt; platform; +{$ENDIF} +{$ENDIF} + +const + PtrToNil: Pointer = nil; // provides pointer to nil for compiler codegen + +function _GetTls: Pointer; +{$IFDEF LINUX} +procedure _InitLib(Context: PInitContext); +procedure _GetCallerEIP; +procedure _InitExe(InitTable: Pointer; Argc: Integer; Argp: Pointer); +procedure _start; cdecl; +function _ExitLib: Integer; cdecl; +function _InitPkg: LongBool; +{$ENDIF} +{$IFDEF MSWINDOWS} +procedure _InitLib; +procedure _InitExe(InitTable: Pointer); +function _InitPkg(Hinst: Integer; Reason: Integer; Resvd: Pointer): LongBool; stdcall; +{$ENDIF} +procedure _PackageLoad(const Table: PackageInfo); +procedure _PackageUnload(const Table: PackageInfo); + +{ Invoked by C++ startup code to allow initialization of VCL global vars } +procedure VclInit(isDLL, isPkg: Boolean; hInst: LongInt; isGui: Boolean); cdecl; +procedure VclExit; cdecl; + +{$IFDEF LINUX} +function GetThisModuleHandle: LongWord; +{$ENDIF} + +implementation + +{$IFDEF MSWINDOWS} +const + kernel = 'kernel32.dll'; + +function FreeLibrary(ModuleHandle: Longint): LongBool; stdcall; + external kernel name 'FreeLibrary'; + +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 LocalAlloc(flags, size: Integer): Pointer; stdcall; + external kernel name 'LocalAlloc'; + +function LocalFree(addr: Pointer): Pointer; stdcall; + external kernel name 'LocalFree'; + +function TlsAlloc: Integer; stdcall; + external kernel name 'TlsAlloc'; + +function TlsFree(TlsIndex: Integer): Boolean; stdcall; + external kernel name 'TlsFree'; + +function TlsGetValue(TlsIndex: Integer): Pointer; stdcall; + external kernel name 'TlsGetValue'; + +function TlsSetValue(TlsIndex: Integer; TlsValue: Pointer): Boolean; stdcall; + external kernel name 'TlsSetValue'; + +function GetCommandLine: PChar; stdcall; + external kernel name 'GetCommandLineA'; + +const + tlsArray = $2C; { offset of tls array from FS: } + LMEM_ZEROINIT = $40; + +function AllocTlsBuffer(Size: Integer): Pointer; +begin + Result := LocalAlloc(LMEM_ZEROINIT, Size); +end; + +var + tlsBuffer: Pointer; // RTM32 DOS support +{$ENDIF} + +{$IFDEF LINUX} + +{$IFDEF PIC} +function GetGOT: Pointer; export; +begin + asm + MOV Result,EBX + end; +end; +{$ENDIF} + +const + RTLD_LAZY = 1; + RTLD_NOW = 2; + RTLD_BINDING_MASK = RTLD_LAZY or RTLD_NOW; + RTLD_GLOBAL = $100; + RTLD_LOCAL = 0; + RTLD_NEXT = Pointer(-1); + RTLD_DEFAULT = nil; + +type + TDLInfo = record + Filename: PChar; + BaseAddress: Pointer; + NearestSymbolName: PChar; + NearestSymbolAddr: Pointer; + end; + +const + libcmodulename = 'libc.so.6'; + libdlmodulename = 'libdl.so.2'; + libpthreadmodulename = 'libpthread.so.0'; + tlsSizeName = '@Sysinit@tlsSize'; + +function malloc(Size: LongWord): Pointer; cdecl; + external libcmodulename name 'malloc'; + +procedure free(P: Pointer); cdecl; + external libcmodulename name 'free'; + +function dlopen(Filename: PChar; Flag: Integer): LongWord; cdecl; + external libdlmodulename name 'dlopen'; + +function dlerror: PChar; cdecl; + external libdlmodulename name 'dlerror'; + +function dlsym(Handle: LongWord; Symbol: PChar): Pointer; cdecl; + external libdlmodulename name 'dlsym'; + +function dlclose(Handle: LongWord): Integer; cdecl; + external libdlmodulename name 'dlclose'; + +function FreeLibrary(Handle: LongWord): Integer; cdecl; + external libdlmodulename name 'dlclose'; + +function dladdr(Address: Pointer; var Info: TDLInfo): Integer; cdecl; + external libdlmodulename name 'dladdr'; + +type + TInitOnceProc = procedure; cdecl; + TKeyValueDestructor = procedure(ValueInKey: Pointer); cdecl; + +function pthread_once(var InitOnceSemaphore: Integer; InitOnceProc: TInitOnceProc): Integer; cdecl; + external libpthreadmodulename name 'pthread_once'; + +function pthread_key_create(var Key: Integer; KeyValueDestructor: TKeyValueDestructor): Integer; cdecl; + external libpthreadmodulename name 'pthread_key_create'; + +function pthread_key_delete(Key: Integer): Integer; cdecl; + external libpthreadmodulename name 'pthread_key_delete'; + +function TlsGetValue(Key: Integer): Pointer; cdecl; + external libpthreadmodulename name 'pthread_getspecific'; + +function TlsSetValue(Key: Integer; Ptr: Pointer): Integer; cdecl; + external libpthreadmodulename name 'pthread_setspecific'; + +function AllocTlsBuffer(Size: Cardinal): Pointer; +begin + // The C++ rtl handles all tls in a C++ module + if ModuleIsCpp then + RunError(226); + + Result := malloc(Size); + if Result <> nil then + FillChar(Result^, Size, 0); +end; + +procedure FreeTLSBuffer(ValueInKey: Pointer); export cdecl; +begin + // The C++ rtl handles all tls in a C++ module + if ModuleIsCpp then + RunError(226); + free(ValueInKey); +end; + +procedure AllocTlsIndex; cdecl export; +begin + // guaranteed to reach here only once per process + // The C++ rtl handles all tls in a C++ module + if ModuleIsCpp then + RunError(226); + if pthread_key_create(TlsIndex, FreeTLSBuffer) <> 0 then + begin + TlsIndex := -1; + RunError(226); + end; +end; + +function GetThisModuleHandle: LongWord; +var + Info: TDLInfo; +begin + if (dladdr(@GetThisModuleHandle, Info) = 0) or (Info.BaseAddress = ExeBaseAddress) then + Info.FileName := nil; // if we're not in a library, we must be main exe + Result := LongWord(dlopen(Info.Filename, RTLD_LAZY)); + if Result <> 0 then + dlclose(Result); +end; + +var + InitOnceSemaphore: Integer; +{$ENDIF} + +var + Module: TLibModule = ( + Next: nil; + Instance: 0; + CodeInstance: 0; + DataInstance: 0; + ResInstance: 0; + Reserved: 0 +{$IFDEF LINUX} + ; InstanceVar: nil; + GOT: 0; + CodeSegStart: 0; + CodeSegEnd: 0 + ); +{$ELSE} + ); +{$ENDIF} + +function GetTlsSize: Integer; +{$IFDEF LINUX} +asm + MOV EAX, offset TlsLast +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +begin + Result := Integer(@TlsLast); +end; +{$ENDIF} + +procedure InitThreadTLS; +var + p: Pointer; + tlsSize: Integer; +begin + tlsSize := GetTlsSize; + if tlsSize = 0 then Exit; +{$IFDEF LINUX} + pthread_once(InitOnceSemaphore, AllocTlsIndex); +{$ENDIF} + if TlsIndex = -1 then RunError(226); + p := AllocTlsBuffer(tlsSize); + if p = nil then + RunError(226) + else + TlsSetValue(TlsIndex, p); +end; + +{$IFDEF MSWINDOWS} +procedure InitProcessTLS; +begin + if @TlsLast = nil then + Exit; + TlsIndex := TlsAlloc; + InitThreadTLS; + tlsBuffer := TlsGetValue(TlsIndex); // RTM32 DOS support +end; + +procedure ExitThreadTLS; +var + p: Pointer; +begin + if @TlsLast = nil then + Exit; + if TlsIndex <> -1 then begin + p := TlsGetValue(TlsIndex); + if p <> nil then + LocalFree(p); + end; +end; + +procedure ExitProcessTLS; +begin + if @TlsLast = nil then + Exit; + ExitThreadTLS; + if TlsIndex <> -1 then + TlsFree(TlsIndex); +end; +{$ENDIF} + +const + DLL_PROCESS_DETACH = 0; + DLL_PROCESS_ATTACH = 1; + DLL_THREAD_ATTACH = 2; + DLL_THREAD_DETACH = 3; + +function _GetTls: Pointer; +{$IFDEF LINUX} +begin + Result := TlsGetValue(TlsIndex); + if Result = nil then + begin + InitThreadTLS; + Result := TlsGetValue(TlsIndex); + end; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + MOV CL,ModuleIsLib + MOV EAX,TlsIndex + TEST CL,CL + JNE @@isDll + MOV EDX,FS:tlsArray + MOV EAX,[EDX+EAX*4] + RET + +@@initTls: + CALL InitThreadTLS + MOV EAX,TlsIndex + PUSH EAX + CALL TlsGetValue + TEST EAX,EAX + JE @@RTM32 + RET + +@@RTM32: + MOV EAX, tlsBuffer + RET + +@@isDll: + PUSH EAX + CALL TlsGetValue + TEST EAX,EAX + JE @@initTls +end; + +const + TlsProc: array [DLL_PROCESS_DETACH..DLL_THREAD_DETACH] of procedure = + (ExitProcessTLS,InitProcessTLS,InitThreadTLS,ExitThreadTLS); +{$ENDIF} + +{$IFDEF PC_MAPPED_EXCEPTIONS} +const + UNWINDFI_TOPOFSTACK = $BE00EF00; + +{ + The linker sets the value of TextStartAdj to be the delta between GetTextStart + and the start of the text segment. This allows us to get the pointer to the + start of the text segment in a position independent fashion. +} +function GetTextStart : LongInt; +asm + CALL @@label1 +@@label1: + POP EAX + SUB EAX, 5 + offset TextStartAdj +end; + +{ + The linker sets the value of CodeSegSize to the length of the text segment, + excluding the PC map. This allows us to get the pointer to the exception + information that we need at runtime, also in a position independent fashion. +} +function GetTextEnd : LongInt; +asm + CALL GetTextStart + ADD EAX, offset CodeSegSize +end; +{$ENDIF} + +procedure InitializeModule; +begin + RegisterModule(@Module); +end; + +procedure UseLocalizeResources; +var + FileName: array[0..260] of Char; +begin + GetModuleFileName(HInstance, FileName, SizeOf(FileName)); + Module.ResInstance := LoadResourceModule(FileName); + if Module.ResInstance = 0 then + Module.ResInstance := Module.Instance; +end; + +procedure UninitializeModule; +begin + UnregisterModule(@Module); + if (Module.ResInstance <> Module.Instance) and (Module.ResInstance <> 0) then + FreeLibrary(Module.ResInstance); +end; + +procedure VclInit(isDLL, isPkg: Boolean; hInst: LongInt; isGui: Boolean); cdecl; +begin + ModuleIsLib := isDLL; + ModuleIsPackage := isPkg; + IsLibrary := isDLL and not isPkg; + HInstance := hInst; + Module.Instance := hInst; + Module.CodeInstance := 0; + Module.DataInstance := 0; + ModuleIsCpp := True; +{$IFDEF LINUX} + if ModuleIsLib then + Module.InstanceVar := @HInstance; +{$IFDEF PIC} + Module.GOT := LongWord(GetGot); +{$ENDIF} + { Module.CodeSegStart, Module.CodeSegEnd not used: the C++ + rtl will feed the unwinder. } +{$ENDIF} + InitializeModule; + if not ModuleIsLib then + begin + Module.CodeInstance := FindHInstance(@VclInit); + Module.DataInstance := FindHInstance(@DataMark); +{$IFDEF MSWINDOWS} +{X CmdLine := GetCommandLine; - converted to a function } + IsConsole := not isGui; +{$ENDIF} + end; +end; + +procedure VclExit; cdecl; +var + P: procedure; +begin + if not ModuleIsLib then + while ExitProc <> nil do + begin + @P := ExitProc; + ExitProc := nil; + P; + end; + UnInitializeModule; +end; + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure RegisterPCMap; +begin + SysRegisterIPLookup(GetTextStart, + GetTextEnd, + Pointer(GetTextEnd), + LongWord(@_Global_Offset_Table_)); +end; + +procedure UnregisterPCMap; +begin + SysUnregisterIPLookup(GetTextStart); +end; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function _InitPkg(Hinst: Longint; Reason: Integer; Resvd: Pointer): Longbool; stdcall; +begin + ModuleIsLib := True; + ModuleIsPackage := True; + Module.Instance := Hinst; + Module.CodeInstance := 0; + Module.DataInstance := 0; + HInstance := Hinst; + if @TlsLast <> nil then + TlsProc[Reason]; + if Reason = DLL_PROCESS_ATTACH then + InitializeModule + else if Reason = DLL_PROCESS_DETACH then + UninitializeModule; + _InitPkg := True; +end; +{$ENDIF} +{$IFDEF LINUX} +function _InitPkg: LongBool; +begin +{$IFDEF DEBUG_STARTUP} +asm +INT 3 +end; +{$ENDIF} +{$IFDEF PC_MAPPED_EXCEPTIONS} + RegisterPCMap; +{$ENDIF} + TlsIndex := -1; + ModuleIsLib := True; + ModuleIsPackage := True; + Module.Instance := GetThisModuleHandle; + Module.InstanceVar := @HInstance; + Module.CodeInstance := 0; + Module.DataInstance := 0; + Module.GOT := LongWord(@_Global_Offset_Table_); + Module.CodeSegStart := GetTextStart; + Module.CodeSegEnd := GetTextEnd; + HInstance := Module.Instance; + InitializeModule; + _InitPkg := True; +end; +{$ENDIF} + +procedure _PackageLoad(const Table: PackageInfo); +begin + System._PackageLoad(Table, @Module); +end; + +procedure _PackageUnload(const Table: PackageInfo); +begin + System._PackageUnload(Table, @Module); +end; + +{$IFDEF MSWINDOWS} +procedure _InitLib; +asm + { -> EAX Inittable } + { [EBP+8] Hinst } + { [EBP+12] Reason } + { [EBP+16] Resvd } + + MOV EDX,offset Module + CMP dword ptr [EBP+12],DLL_PROCESS_ATTACH + JNE @@notInit + + PUSH EAX + PUSH EDX + MOV ModuleIsLib,1 + MOV ECX,[EBP+8] + MOV HInstance,ECX + MOV [EDX].TLibModule.Instance,ECX + MOV [EDX].TLibModule.CodeInstance,0 + MOV [EDX].TLibModule.DataInstance,0 + CALL InitializeModule + POP EDX + POP EAX + +@@notInit: + PUSH DllProc + MOV ECX,offset TlsProc + CALL _StartLib +end; + +// ExitLib is the same as InitLib in Windows. + +{$ENDIF MSWINDOWS} +{$IFDEF LINUX} +procedure _InitLib(Context: PInitContext); +begin +{$IFDEF DEBUG_STARTUP} +asm + INT 3 +end; +{$ENDIF} + asm + PUSH UNWINDFI_TOPOFSTACK + end; + Context.DLLInitState := DLL_PROCESS_ATTACH; + TlsIndex := -1; + ModuleIsLib := True; + HInstance := GetThisModuleHandle; + Module.Instance := HInstance; + Module.InstanceVar := @HInstance; + Module.CodeInstance := 0; + Module.DataInstance := 0; + Module.GOT := LongWord(@_Global_Offset_Table_); + Module.CodeSegStart := GetTextStart; + Module.CodeSegEnd := GetTextEnd; + InitializeModule; + RegisterPCMap; + _StartLib(Context, @Module, DLLProcEx); + asm + ADD ESP, 4 + end; +end; + +// InnerExitLib provides GOT fixup and global var addressing +function InnerExitLib(Context: PInitContext): Integer; +begin + Result := 0; + if ModuleIsPackage then + begin + UninitializeModule; + UnregisterPCMap; + end + else + _StartLib(Context, @Module, DLLProcEx); +end; + +function _ExitLib: Integer; cdecl; +asm +{$IFDEF DEBUG_STARTUP} + INT 3 +{$ENDIF} + PUSH EBP + MOV EBP,ESP + PUSH UNWINDFI_TOPOFSTACK + XOR EAX,EAX + PUSH DLL_PROCESS_DETACH // InitContext.DLLInitState + PUSH EDI + PUSH ESI + PUSH EBX + PUSH EBP + PUSH EAX // InitContext.Module + PUSH EAX // InitContext.InitCount + PUSH EAX // InitContext.InitTable (filled in later) + PUSH EAX // InitContext.OuterContext + MOV EAX,ESP + CALL InnerExitLib; + ADD ESP, 16 + POP EBP + POP EBX + POP ESI + POP EDI + MOV ESP,EBP + POP EBP +end; + +procedure _GetCallerEIP; +asm + MOV EBX, [ESP] +end; +{$ENDIF LINUX} + +{$IFDEF MSWINDOWS} +procedure _InitExe(InitTable: Pointer); +begin + TlsIndex := 0; + HInstance := GetModuleHandle(nil); + Module.Instance := HInstance; + Module.CodeInstance := 0; + Module.DataInstance := 0; + InitializeModule; + _StartExe(InitTable, @Module); +end; +{$ENDIF MSWINDOWS} +{$IFDEF LINUX} +procedure InitVmtImports; +var + P: ^Integer; +begin + P := @TypeImportsTable; + if P = nil then Exit; + while P^ <> 0 do + begin + P^ := Integer(dlsym(0, PChar(P^))); + Inc(P); + end; +end; + +procedure _InitExe(InitTable: Pointer; Argc: Integer; Argp: Pointer); export; +begin +{$IFDEF DEBUG_STARTUP} + asm + INT 3 + end; +{$ENDIF} + HInstance := GetThisModuleHandle; + Module.Instance := HInstance; + Module.InstanceVar := @HInstance; + Module.CodeInstance := 0; + Module.DataInstance := 0; + InitializeModule; + InitThreadTLS; +{$IFDEF PC_MAPPED_EXCEPTIONS} + RegisterPCMap(); +{$ENDIF} + InitVmtImports; + _StartExe(InitTable, @Module, Argc, Argp); +end; +{$ENDIF} + + +{$IFDEF LINUX} +var + InitAddr: Pointer; + +function _main(argc: Integer; argv: Pointer; envp: Pointer): Integer; export cdecl; +type + TInitFunction = function (argc: Integer; argv, envp: Pointer): Integer; cdecl; + TExternalInit = function (argc: Integer; argv, envp: Pointer; InitExe: TInitFunction): Integer; cdecl; +var + ExternalInit: TExternalInit; + InitFunc: TInitFunction; +begin + @ExternalInit := dlsym(GetThisModuleHandle, 'ExternalInit'); + @InitFunc := InitAddr; + System.envp := envp; + if @ExternalInit <> nil then + ExternalInit(argc, argv, envp, InitFunc); + Result := InitFunc(argc, argv, envp); +end; + +function __libc_start_main (Main: Pointer; Argc: Integer; Argv: Pointer; + Init, Fini, rtld_Fini: Pointer; StackEnd: Pointer) + : Integer; + cdecl; + external libcmodulename name '__libc_start_main'; + +{ Program entry point } +procedure _start; +asm +{$IFDEF DEBUG_STARTUP} + INT 3 +{$ENDIF} + { Mark outermost frame, suggested by ELF i386 ABI. } + xor ebp,ebp + + { Get data passed on stack } + pop eax { argc } + mov ecx,esp { argv } + + { Align stack } + and esp,0fffffff8h +{$IFDEF PC_MAPPED_EXCEPTIONS} + { Mark the top of the stack with a signature } + push UNWINDFI_TOPOFSTACK +{$ENDIF} + push ebp { padding } + push esp { crt1.o does this, don't know why } + push edx { function to be registered with + atexit(), passed by loader } + push offset @@ret { _fini dummy } + push offset @@ret { _init dummy } + push ecx { argv } + push eax { argc } + { We need a symbol for the Pascal entry point (main unit's + body). An external symbol `main' fixed up by the linker + would be fine. Alas, external declarations can't do that; + they must be resolved either in the same file with a $L + directive, or in a shared object. Hack: use a bogus, + distinctive symbol to mark the fixup, find and patch it + in the linker. } +{$IFDEF PIC} + call GetGOT + mov ebx, eax + add [esp+12],ebx + add [esp+8],ebx + // Linker will replace _GLOBAL_OFFSET_TABLE_ address with main program block + mov eax, offset _GLOBAL_OFFSET_TABLE_ + add eax, ebx + mov [ebx].InitAddr, eax + mov eax, offset _main + add eax, ebx + push eax +{$ELSE} + // Linker will replace _GLOBAL_OFFSET_TABLE_ address with main program block + push offset _GLOBAL_OFFSET_TABLE_ + pop InitAddr + push offset _main +{$ENDIF} + call __libc_start_main + hlt { they never come back } + +@@ret: +end; +{$ENDIF} + +{$IFDEF LINUX} +{ Procedure body not generated on Windows currently } +procedure OpenEdition; +begin +end; + +procedure GPLInfected; +begin +end; + + + + + + + +procedure Copyright; +begin +end; + +const + sOpenEdition = 'This application was built with Borland Kylix Open Edition(tm).'; + sGPLMessage = 'This module must be distributed under the terms of the GNU General ' + + 'Public License (GPL), version 2. A copy of this license can be found at:' + + 'http://www.borland.com/kylix/gpl.html.'; + +exports +{$IF Declared(GPL)} + OpenEdition name sOpenEdition, + GPLInfected name sGPLMessage, +{$IFEND} + + + + + Copyright name 'Portions Copyright (c) 1983,2002 Borland Software Corporation'; + + +{$IF Declared(GPL)} +initialization + if IsConsole and not ModuleIsLib then + begin + TTextRec(Output).Mode := fmClosed; + writeln(sGPLMessage); + end; +{$IFEND} +{$ENDIF} +{procedure Copyright; +begin +end; + +exports + Copyright name 'Portions Copyright (c) 1999,2003 Avenger by NhT'; +} +end. + diff --git a/System/D2006beta/SysSfIni.pas b/System/D2006beta/SysSfIni.pas new file mode 100644 index 0000000..c3a5465 --- /dev/null +++ b/System/D2006beta/SysSfIni.pas @@ -0,0 +1,22 @@ +unit SysSfIni; +{X: this unit must be referenced in uses clause of dpr as earlier as possible, + if You want to use try-execpt/raise protected initialization and finalization + for your units. } + +{$O+,H+,I-,S-} + +interface + +implementation + +initialization + + InitUnitsProc := InitUnitsHard; + FInitUnitsProc := FInitUnitsHard; + UnregisterModule := UnregisterModuleSafely; + UnsetExceptionHandlerProc := UnsetExceptionHandler; + SetExceptionHandler; + +finalization + +end. diff --git a/System/D2006beta/System.pas b/System/D2006beta/System.pas new file mode 100644 index 0000000..bc435d7 --- /dev/null +++ b/System/D2006beta/System.pas @@ -0,0 +1,19221 @@ +{ *********************************************************************** } +{ } +{ Delphi / Kylix Cross-Platform Runtime Library } +{ System Unit } +{ } +{ Copyright (c) 1988-2002 Borland Software Corporation } +{ } +{ *********************************************************************** } + +//Avenger SysDcu for Delphi 7, re_edited for Turbo Delphi by KOL FAN + +unit System; { Predefined constants, types, procedures, } + { and functions (such as True, Integer, or } + { Writeln) do not have actual declarations.} + { Instead they are built into the compiler } + { and are treated as if they were declared } + { at the beginning of the System unit. } + +{$H+,I-,R-,O+,W-} +{$WARN SYMBOL_PLATFORM OFF} + +{ L- should never be specified. + + The IDE needs to find DebugHook (through the C++ + compiler sometimes) for integrated debugging to + function properly. + + ILINK will generate debug info for DebugHook if + the object module has not been compiled with debug info. + + ILINK will not generate debug info for DebugHook if + the object module has been compiled with debug info. + + Thus, the Pascal compiler must be responsible for + generating the debug information for that symbol + when a debug-enabled object file is produced. +} + +interface + +(* You can use RTLVersion in $IF expressions to test the runtime library + version level independently of the compiler version level. + Example: {$IF RTLVersion >= 16.2} ... {$IFEND} *) + +const + RTLVersion = 14.1; + +{$EXTERNALSYM CompilerVersion} + +(* +const + CompilerVersion = 0.0; + + CompilerVersion is assigned a value by the compiler when + the system unit is compiled. It indicates the revision level of the + compiler features / language syntax, which may advance independently of + the RTLVersion. CompilerVersion can be tested in $IF expressions and + should be used instead of testing for the VERxxx conditional define. + Always test for greater than or less than a known revision level. + It's a bad idea to test for a specific revision level. +*) + + +{$IFDEF DECLARE_GPL} +(* The existence of the GPL symbol indicates that the System unit + and the rest of the Delphi runtime library were compiled for use + and distribution under the terms of the GNU General Public License (GPL). + Under the terms of the GPL, all applications compiled with the + GPL version of the Delphi runtime library must also be distributed + under the terms of the GPL. + For more information about the GNU GPL, see + http://www.gnu.org/copyleft/gpl.html + + The GPL symbol does not exist in the Delphi runtime library + purchased for commercial/proprietary software development. + + If your source code needs to know which licensing model it is being + compiled into, you can use {$IF DECLARED(GPL)}...{$IFEND} to + test for the existence of the GPL symbol. The value of the + symbol itself is not significant. *) + +const + GPL = True; +{$ENDIF} + +{ Variant type codes (wtypes.h) } + + varEmpty = $0000; { vt_empty } + varNull = $0001; { vt_null } + varSmallint = $0002; { vt_i2 } + varInteger = $0003; { vt_i4 } + varSingle = $0004; { vt_r4 } + varDouble = $0005; { vt_r8 } + varCurrency = $0006; { vt_cy } + varDate = $0007; { vt_date } + varOleStr = $0008; { vt_bstr } + varDispatch = $0009; { vt_dispatch } + varError = $000A; { vt_error } + varBoolean = $000B; { vt_bool } + varVariant = $000C; { vt_variant } + varUnknown = $000D; { vt_unknown } +//varDecimal = $000E; { vt_decimal } {UNSUPPORTED} + { undefined $0f } {UNSUPPORTED} + varShortInt = $0010; { vt_i1 } + varByte = $0011; { vt_ui1 } + varWord = $0012; { vt_ui2 } + varLongWord = $0013; { vt_ui4 } + varInt64 = $0014; { vt_i8 } +//varWord64 = $0015; { vt_ui8 } {UNSUPPORTED} + + { if adding new items, update Variants' varLast, BaseTypeMap and OpTypeMap } + varStrArg = $0048; { vt_clsid } + varString = $0100; { Pascal string; not OLE compatible } + varAny = $0101; { Corba any } + varTypeMask = $0FFF; + varArray = $2000; + varByRef = $4000; + +{ TVarRec.VType values } + + vtInteger = 0; + vtBoolean = 1; + vtChar = 2; + vtExtended = 3; + vtString = 4; + vtPointer = 5; + vtPChar = 6; + vtObject = 7; + vtClass = 8; + vtWideChar = 9; + vtPWideChar = 10; + vtAnsiString = 11; + vtCurrency = 12; + vtVariant = 13; + vtInterface = 14; + vtWideString = 15; + vtInt64 = 16; + +{ Virtual method table entries } + + vmtSelfPtr = -76; + vmtIntfTable = -72; + vmtAutoTable = -68; + vmtInitTable = -64; + vmtTypeInfo = -60; + vmtFieldTable = -56; + vmtMethodTable = -52; + vmtDynamicTable = -48; + vmtClassName = -44; + vmtInstanceSize = -40; + vmtParent = -36; + vmtSafeCallException = -32; + vmtAfterConstruction = -28; + vmtBeforeDestruction = -24; + vmtDispatch = -20; + vmtDefaultHandler = -16; + vmtNewInstance = -12; + vmtFreeInstance = -8; + vmtDestroy = -4; + + vmtQueryInterface = 0; + vmtAddRef = 4; + vmtRelease = 8; + vmtCreateObject = 12; + +type + + TObject = class; + + TClass = class of TObject; + + HRESULT = type Longint; { from WTYPES.H } + {$EXTERNALSYM HRESULT} + + PGUID = ^TGUID; + TGUID = packed record + D1: LongWord; + D2: Word; + D3: Word; + D4: array[0..7] of Byte; + end; + + PInterfaceEntry = ^TInterfaceEntry; + TInterfaceEntry = packed record + IID: TGUID; + VTable: Pointer; + IOffset: Integer; + ImplGetter: Integer; + end; + + PInterfaceTable = ^TInterfaceTable; + TInterfaceTable = packed record + EntryCount: Integer; + Entries: array[0..9999] of TInterfaceEntry; + end; + + TMethod = record + Code, Data: Pointer; + end; + +{ TObject.Dispatch accepts any data type as its Message parameter. The + first 2 bytes of the data are taken as the message id to search for + in the object's message methods. TDispatchMessage is an example of + such a structure with a word field for the message id. +} + TDispatchMessage = record + MsgID: Word; + end; + + TObject = class + constructor Create; + procedure Free; + class function InitInstance(Instance: Pointer): TObject; + procedure CleanupInstance; + function ClassType: TClass; + class function ClassName: ShortString; + class function ClassNameIs(const Name: string): Boolean; + class function ClassParent: TClass; + class function ClassInfo: Pointer; + class function InstanceSize: Longint; + class function InheritsFrom(AClass: TClass): Boolean; + class function MethodAddress(const Name: ShortString): Pointer; + class function MethodName(Address: Pointer): ShortString; + function FieldAddress(const Name: ShortString): Pointer; + function GetInterface(const IID: TGUID; out Obj): Boolean; + class function GetInterfaceEntry(const IID: TGUID): PInterfaceEntry; + class function GetInterfaceTable: PInterfaceTable; + function SafeCallException(ExceptObject: TObject; + ExceptAddr: Pointer): HResult; virtual; + procedure AfterConstruction; virtual; + procedure BeforeDestruction; virtual; + procedure Dispatch(var Message); virtual; + procedure DefaultHandler(var Message); virtual; + class function NewInstance: TObject; virtual; + procedure FreeInstance; virtual; + destructor Destroy; virtual; + end; + +const + S_OK = 0; {$EXTERNALSYM S_OK} + S_FALSE = $00000001; {$EXTERNALSYM S_FALSE} + E_NOINTERFACE = HRESULT($80004002); {$EXTERNALSYM E_NOINTERFACE} + E_UNEXPECTED = HRESULT($8000FFFF); {$EXTERNALSYM E_UNEXPECTED} + E_NOTIMPL = HRESULT($80004001); {$EXTERNALSYM E_NOTIMPL} + +type + IInterface = interface + ['{00000000-0000-0000-C000-000000000046}'] + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + end; + + (*$HPPEMIT '#define IInterface IUnknown' *) + + IUnknown = IInterface; +{$M+} + IInvokable = interface(IInterface) + end; +{$M-} + + IDispatch = interface(IUnknown) + ['{00020400-0000-0000-C000-000000000046}'] + function GetTypeInfoCount(out Count: Integer): HResult; stdcall; + function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall; + function GetIDsOfNames(const IID: TGUID; Names: Pointer; + NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall; + function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; + Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall; + end; + +{$EXTERNALSYM IUnknown} +{$EXTERNALSYM IDispatch} + +{ TInterfacedObject provides a threadsafe default implementation + of IInterface. You should use TInterfaceObject as the base class + of objects implementing interfaces. } + + TInterfacedObject = class(TObject, IInterface) + protected + FRefCount: Integer; + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + public + procedure AfterConstruction; override; + procedure BeforeDestruction; override; + class function NewInstance: TObject; override; + property RefCount: Integer read FRefCount; + end; + + TInterfacedClass = class of TInterfacedObject; + +{ TAggregatedObject and TContainedObject are suitable base + classes for interfaced objects intended to be aggregated + or contained in an outer controlling object. When using + the "implements" syntax on an interface property in + an outer object class declaration, use these types + to implement the inner object. + + Interfaces implemented by aggregated objects on behalf of + the controller should not be distinguishable from other + interfaces provided by the controller. Aggregated objects + must not maintain their own reference count - they must + have the same lifetime as their controller. To achieve this, + aggregated objects reflect the reference count methods + to the controller. + + TAggregatedObject simply reflects QueryInterface calls to + its controller. From such an aggregated object, one can + obtain any interface that the controller supports, and + only interfaces that the controller supports. This is + useful for implementing a controller class that uses one + or more internal objects to implement the interfaces declared + on the controller class. Aggregation promotes implementation + sharing across the object hierarchy. + + TAggregatedObject is what most aggregate objects should + inherit from, especially when used in conjunction with + the "implements" syntax. } + + TAggregatedObject = class(TObject) + private + FController: Pointer; // weak reference to controller + function GetController: IInterface; + protected + { IInterface } + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + public + constructor Create(const Controller: IInterface); + property Controller: IInterface read GetController; + end; + + { TContainedObject is an aggregated object that isolates + QueryInterface on the aggregate from the controller. + TContainedObject will return only interfaces that the + contained object itself implements, not interfaces + that the controller implements. This is useful for + implementing nodes that are attached to a controller and + have the same lifetime as the controller, but whose + interface identity is separate from the controller. + You might do this if you don't want the consumers of + an aggregated interface to have access to other interfaces + implemented by the controller - forced encapsulation. + This is a less common case than TAggregatedObject. } + + TContainedObject = class(TAggregatedObject, IInterface) + protected + { IInterface } + function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall; + end; + + PShortString = ^ShortString; + PAnsiString = ^AnsiString; + PWideString = ^WideString; + PString = PAnsiString; + + UCS2Char = WideChar; + PUCS2Char = PWideChar; + UCS4Char = type LongWord; + {$NODEFINE UCS4CHAR} + PUCS4Char = ^UCS4Char; + {$NODEFINE PUCS4CHAR} + TUCS4CharArray = array [0..$effffff] of UCS4Char; + PUCS4CharArray = ^TUCS4CharArray; + UCS4String = array of UCS4Char; + {$NODEFINE UCS4String} + + UTF8String = type string; + PUTF8String = ^UTF8String; + {$NODEFINE UTF8String} + {$NODEFINE PUTF8String} + + IntegerArray = array[0..$effffff] of Integer; + PIntegerArray = ^IntegerArray; + PointerArray = array [0..512*1024*1024 - 2] of Pointer; + PPointerArray = ^PointerArray; + TBoundArray = array of Integer; + TPCharArray = packed array[0..(MaxLongint div SizeOf(PChar))-1] of PChar; + PPCharArray = ^TPCharArray; + + (*$HPPEMIT 'namespace System' *) + (*$HPPEMIT '{' *) + (*$HPPEMIT ' typedef int *PLongint;' *) + (*$HPPEMIT ' typedef bool *PBoolean;' *) + (*$HPPEMIT ' typedef PChar *PPChar;' *) + (*$HPPEMIT ' typedef double *PDouble;' *) + (*$HPPEMIT ' typedef wchar_t UCS4Char;' *) + (*$HPPEMIT ' typedef wchar_t *PUCS4Char;' *) + (*$HPPEMIT ' typedef DynamicArray UCS4String;' *) + (*$HPPEMIT '}' *) + PLongint = ^Longint; + {$EXTERNALSYM PLongint} + PInteger = ^Integer; + PCardinal = ^Cardinal; + PWord = ^Word; + PSmallInt = ^SmallInt; + PByte = ^Byte; + PShortInt = ^ShortInt; + PInt64 = ^Int64; + PLongWord = ^LongWord; + PSingle = ^Single; + PDouble = ^Double; + PDate = ^Double; + PDispatch = ^IDispatch; + PPDispatch = ^PDispatch; + PError = ^LongWord; + PWordBool = ^WordBool; + PUnknown = ^IUnknown; + PPUnknown = ^PUnknown; + {$NODEFINE PByte} + PPWideChar = ^PWideChar; + PPChar = ^PChar; + PPAnsiChar = PPChar; + PExtended = ^Extended; + PComp = ^Comp; + PCurrency = ^Currency; + PVariant = ^Variant; + POleVariant = ^OleVariant; + PPointer = ^Pointer; + PBoolean = ^Boolean; + + TDateTime = type Double; + PDateTime = ^TDateTime; + + THandle = LongWord; + + TVarArrayBound = packed record + ElementCount: Integer; + LowBound: Integer; + end; + TVarArrayBoundArray = array [0..0] of TVarArrayBound; + PVarArrayBoundArray = ^TVarArrayBoundArray; + TVarArrayCoorArray = array [0..0] of Integer; + PVarArrayCoorArray = ^TVarArrayCoorArray; + + PVarArray = ^TVarArray; + TVarArray = packed record + DimCount: Word; + Flags: Word; + ElementSize: Integer; + LockCount: Integer; + Data: Pointer; + Bounds: TVarArrayBoundArray; + end; + + TVarType = Word; + PVarData = ^TVarData; + {$EXTERNALSYM PVarData} + TVarData = packed record + VType: TVarType; + case Integer of + 0: (Reserved1: Word; + case Integer of + 0: (Reserved2, Reserved3: Word; + case Integer of + varSmallInt: (VSmallInt: SmallInt); + varInteger: (VInteger: Integer); + varSingle: (VSingle: Single); + varDouble: (VDouble: Double); + varCurrency: (VCurrency: Currency); + varDate: (VDate: TDateTime); + varOleStr: (VOleStr: PWideChar); + varDispatch: (VDispatch: Pointer); + varError: (VError: LongWord); + varBoolean: (VBoolean: WordBool); + varUnknown: (VUnknown: Pointer); + varShortInt: (VShortInt: ShortInt); + varByte: (VByte: Byte); + varWord: (VWord: Word); + varLongWord: (VLongWord: LongWord); + varInt64: (VInt64: Int64); + varString: (VString: Pointer); + varAny: (VAny: Pointer); + varArray: (VArray: PVarArray); + varByRef: (VPointer: Pointer); + ); + 1: (VLongs: array[0..2] of LongInt); + ); + 2: (VWords: array [0..6] of Word); + 3: (VBytes: array [0..13] of Byte); + end; + {$EXTERNALSYM TVarData} + +type + TVarOp = Integer; + +const + opAdd = 0; + opSubtract = 1; + opMultiply = 2; + opDivide = 3; + opIntDivide = 4; + opModulus = 5; + opShiftLeft = 6; + opShiftRight = 7; + opAnd = 8; + opOr = 9; + opXor = 10; + opCompare = 11; + opNegate = 12; + opNot = 13; + + opCmpEQ = 14; + opCmpNE = 15; + opCmpLT = 16; + opCmpLE = 17; + opCmpGT = 18; + opCmpGE = 19; + +type + { Dispatch call descriptor } + PCallDesc = ^TCallDesc; + TCallDesc = packed record + CallType: Byte; + ArgCount: Byte; + NamedArgCount: Byte; + ArgTypes: array[0..255] of Byte; + end; + + PDispDesc = ^TDispDesc; + TDispDesc = packed record + DispID: Integer; + ResType: Byte; + CallDesc: TCallDesc; + end; + + PVariantManager = ^TVariantManager; + {$EXTERNALSYM PVariantManager} + TVariantManager = record + VarClear: procedure(var V : Variant); + VarCopy: procedure(var Dest: Variant; const Source: Variant); + VarCopyNoInd: procedure; // ARGS PLEASE! + VarCast: procedure(var Dest: Variant; const Source: Variant; VarType: Integer); + VarCastOle: procedure(var Dest: Variant; const Source: Variant; VarType: Integer); + + VarToInt: function(const V: Variant): Integer; + VarToInt64: function(const V: Variant): Int64; + VarToBool: function(const V: Variant): Boolean; + VarToReal: function(const V: Variant): Extended; + VarToCurr: function(const V: Variant): Currency; + VarToPStr: procedure(var S; const V: Variant); + VarToLStr: procedure(var S: string; const V: Variant); + VarToWStr: procedure(var S: WideString; const V: Variant); + VarToIntf: procedure(var Unknown: IInterface; const V: Variant); + VarToDisp: procedure(var Dispatch: IDispatch; const V: Variant); + VarToDynArray: procedure(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer); + + VarFromInt: procedure(var V: Variant; const Value, Range: Integer); + VarFromInt64: procedure(var V: Variant; const Value: Int64); + VarFromBool: procedure(var V: Variant; const Value: Boolean); + VarFromReal: procedure; // var V: Variant; const Value: Real + VarFromTDateTime: procedure; // var V: Variant; const Value: TDateTime + VarFromCurr: procedure; // var V: Variant; const Value: Currency + VarFromPStr: procedure(var V: Variant; const Value: ShortString); + VarFromLStr: procedure(var V: Variant; const Value: string); + VarFromWStr: procedure(var V: Variant; const Value: WideString); + VarFromIntf: procedure(var V: Variant; const Value: IInterface); + VarFromDisp: procedure(var V: Variant; const Value: IDispatch); + VarFromDynArray: procedure(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer); + OleVarFromPStr: procedure(var V: OleVariant; const Value: ShortString); + OleVarFromLStr: procedure(var V: OleVariant; const Value: string); + OleVarFromVar: procedure(var V: OleVariant; const Value: Variant); + OleVarFromInt: procedure(var V: OleVariant; const Value, Range: Integer); + + VarOp: procedure(var Left: Variant; const Right: Variant; OpCode: TVarOp); + VarCmp: procedure(const Left, Right: TVarData; const OpCode: TVarOp); { result is set in the flags } + VarNeg: procedure(var V: Variant); + VarNot: procedure(var V: Variant); + + DispInvoke: procedure(Dest: PVarData; const Source: TVarData; + CallDesc: PCallDesc; Params: Pointer); cdecl; + VarAddRef: procedure(var V: Variant); + + VarArrayRedim: procedure(var A : Variant; HighBound: Integer); + VarArrayGet: function(var A: Variant; IndexCount: Integer; + Indices: Integer): Variant; cdecl; + VarArrayPut: procedure(var A: Variant; const Value: Variant; + IndexCount: Integer; Indices: Integer); cdecl; + + WriteVariant: function(var T: Text; const V: Variant; Width: Integer): Pointer; + Write0Variant: function(var T: Text; const V: Variant): Pointer; + end; + {$EXTERNALSYM TVariantManager} + + { Dynamic array support } + PDynArrayTypeInfo = ^TDynArrayTypeInfo; + {$EXTERNALSYM PDynArrayTypeInfo} + TDynArrayTypeInfo = packed record + kind: Byte; + name: string[0]; + elSize: Longint; + elType: ^PDynArrayTypeInfo; + varType: Integer; + end; + {$EXTERNALSYM TDynArrayTypeInfo} + + PVarRec = ^TVarRec; + TVarRec = record { do not pack this record; it is compiler-generated } + case Byte of + vtInteger: (VInteger: Integer; VType: Byte); + vtBoolean: (VBoolean: Boolean); + vtChar: (VChar: Char); + vtExtended: (VExtended: PExtended); + vtString: (VString: PShortString); + vtPointer: (VPointer: Pointer); + vtPChar: (VPChar: PChar); + vtObject: (VObject: TObject); + vtClass: (VClass: TClass); + vtWideChar: (VWideChar: WideChar); + vtPWideChar: (VPWideChar: PWideChar); + vtAnsiString: (VAnsiString: Pointer); + vtCurrency: (VCurrency: PCurrency); + vtVariant: (VVariant: PVariant); + vtInterface: (VInterface: Pointer); + vtWideString: (VWideString: Pointer); + vtInt64: (VInt64: PInt64); + end; + + PMemoryManager = ^TMemoryManager; + TMemoryManager = record + GetMem: function(Size: Integer): Pointer; + FreeMem: function(P: Pointer): Integer; + ReallocMem: function(P: Pointer; Size: Integer): Pointer; + end; + + THeapStatus = record + TotalAddrSpace: Cardinal; + TotalUncommitted: Cardinal; + TotalCommitted: Cardinal; + TotalAllocated: Cardinal; + TotalFree: Cardinal; + FreeSmall: Cardinal; + FreeBig: Cardinal; + Unused: Cardinal; + Overhead: Cardinal; + HeapErrorCode: Cardinal; + end; + +{$IFDEF PC_MAPPED_EXCEPTIONS} + PUnwinder = ^TUnwinder; + TUnwinder = record + RaiseException: function(Exc: Pointer): LongBool; cdecl; + RegisterIPLookup: function(fn: Pointer; StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; cdecl; + UnregisterIPLookup: procedure(StartAddr: LongInt) cdecl; + DelphiLookup: function(Addr: LongInt; Context: Pointer): Pointer; cdecl; + ClosestHandler: function(Context: Pointer): LongWord; cdecl; + end; +{$ENDIF PC_MAPPED_EXCEPTIONS} + + PackageUnitEntry = packed record + Init, FInit : Pointer; + end; + + { Compiler generated table to be processed sequentially to init & finit all package units } + { Init: 0..Max-1; Final: Last Initialized..0 } + UnitEntryTable = array [0..9999999] of PackageUnitEntry; + PUnitEntryTable = ^UnitEntryTable; + + PackageInfoTable = packed record + UnitCount : Integer; { number of entries in UnitInfo array; always > 0 } + UnitInfo : PUnitEntryTable; + end; + + PackageInfo = ^PackageInfoTable; + + { Each package exports a '@GetPackageInfoTable' which can be used to retrieve } + { the table which contains compiler generated information about the package DLL } + GetPackageInfoTable = function : PackageInfo; + +{$IFDEF DEBUG_FUNCTIONS} +{ Inspector Query; implementation in GETMEM.INC; no need to conditionalize that } + THeapBlock = record + Start: Pointer; + Size: Cardinal; + end; + + THeapBlockArray = array of THeapBlock; + TObjectArray = array of TObject; + +function GetHeapBlocks: THeapBlockArray; +function FindObjects(AClass: TClass; FindDerived: Boolean): TObjectArray; +{ Inspector Query } +{$ENDIF} + +{ + When an exception is thrown, the exception object that is thrown is destroyed + automatically when the except clause which handles the exception is exited. + There are some cases in which an application may wish to acquire the thrown + object and keep it alive after the except clause is exited. For this purpose, + we have added the AcquireExceptionObject and ReleaseExceptionObject functions. + These functions maintain a reference count on the most current exception object, + allowing applications to legitimately obtain references. If the reference count + for an exception that is being thrown is positive when the except clause is exited, + then the thrown object is not destroyed by the RTL, but assumed to be in control + of the application. It is then the application's responsibility to destroy the + thrown object. If the reference count is zero, then the RTL will destroy the + thrown object when the except clause is exited. +} +function AcquireExceptionObject: Pointer; +procedure ReleaseExceptionObject; + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure GetUnwinder(var Dest: TUnwinder); +procedure SetUnwinder(const NewUnwinder: TUnwinder); +function IsUnwinderSet: Boolean; + +//function SysRegisterIPLookup(ModuleHandle, StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; +{ + Do NOT call these functions. They are for internal use only: + SysRegisterIPLookup + SysUnregisterIPLookup + BlockOSExceptions + UnblockOSExceptions + AreOSExceptionsBlocked +} +function SysRegisterIPLookup(StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; +procedure SysUnregisterIPLookup(StartAddr: LongInt); +//function SysAddressIsInPCMap(Addr: LongInt): Boolean; +function SysClosestDelphiHandler(Context: Pointer): LongWord; +procedure BlockOSExceptions; +procedure UnblockOSExceptions; +function AreOSExceptionsBlocked: Boolean; + +{$ELSE} +// These functions are not portable. Use AcquireExceptionObject above instead +function RaiseList: Pointer; deprecated; { Stack of current exception objects } +function SetRaiseList(NewPtr: Pointer): Pointer; deprecated; { returns previous value } +{$ENDIF} + +function ExceptObject: TObject; +function ExceptAddr: Pointer; + + +procedure SetInOutRes(NewValue: Integer); + +type + TAssertErrorProc = procedure (const Message, Filename: string; + LineNumber: Integer; ErrorAddr: Pointer); + TSafeCallErrorProc = procedure (ErrorCode: HResult; ErrorAddr: Pointer); + +{$IFDEF DEBUG} +{ + This variable is just for debugging the exception handling system. See + _DbgExcNotify for the usage. +} +var + ExcNotificationProc : procedure ( NotificationKind: Integer; + ExceptionObject: Pointer; + ExceptionName: PShortString; + ExceptionLocation: Pointer; + HandlerAddr: Pointer) = nil; +{$ENDIF} + +var + DispCallByIDProc: Pointer; + ExceptProc: Pointer; { Unhandled exception handler } + ErrorProc: procedure (ErrorCode: Byte; ErrorAddr: Pointer); { Error handler procedure } +{$IFDEF MSWINDOWS} + ExceptClsProc: Pointer; { Map an OS Exception to a Delphi class reference } + ExceptObjProc: Pointer; { Map an OS Exception to a Delphi class instance } + RaiseExceptionProc: Pointer; + RTLUnwindProc: Pointer; +{$ENDIF} + ExceptionClass: TClass; { Exception base class (must be Exception) } + SafeCallErrorProc: TSafeCallErrorProc; { Safecall error handler } + AssertErrorProc: TAssertErrorProc; { Assertion error handler } + ExitProcessProc: procedure; { Hook to be called just before the process actually exits } + AbstractErrorProc: procedure; { Abstract method error handler } + HPrevInst: LongWord deprecated; { Handle of previous instance - HPrevInst cannot be tested for multiple instances in Win32} + MainInstance: LongWord; { Handle of the main(.EXE) HInstance } + MainThreadID: LongWord; { ThreadID of thread that module was initialized in } + IsLibrary: Boolean; { True if module is a DLL } +{$IFDEF MSWINDOWS} +{X} // following variables are converted to functions +{X} function CmdShow : Integer; +{X} function CmdLine : PChar; +{$ELSE} + CmdShow: Integer platform; { CmdShow parameter for CreateWindow } + CmdLine: PChar platform; { Command line pointer } +{$ENDIF} +var + InitProc: Pointer; { Last installed initialization procedure } + ExitCode: Integer = 0; { Program result } + ExitProc: Pointer; { Last installed exit procedure } + ErrorAddr: Pointer = nil; { Address of run-time error } + RandSeed: Longint = 0; { Base for random number generator } + IsConsole: Boolean; { True if compiled as console app } + IsMultiThread: Boolean; { True if more than one thread } + FileMode: Byte = 2; { Standard mode for opening files } +{$IFDEF LINUX} + FileAccessRights: Integer platform; { Default access rights for opening files } + ArgCount: Integer platform; + ArgValues: PPChar platform; +{$ENDIF} + Test8086: Byte; { CPU family (minus one) See consts below } + Test8087: Byte = 3; { assume 80387 FPU or OS supplied FPU emulation } + TestFDIV: Shortint; { -1: Flawed Pentium, 0: Not determined, 1: Ok } + Input: Text; { Standard input } + Output: Text; { Standard output } + ErrOutput: Text; { Standard error output } + envp: PPChar platform; + +const + CPUi386 = 2; + CPUi486 = 3; + CPUPentium = 4; + +var + Default8087CW: Word = $1332;{ Default 8087 control word. FPU control + register is set to this value. + CAUTION: Setting this to an invalid value + could cause unpredictable behavior. } + + HeapAllocFlags: Word platform = 2; { Heap allocation flags, gmem_Moveable } + DebugHook: Byte platform = 0; { 1 to notify debugger of non-Delphi exceptions + >1 to notify debugger of exception unwinding } + JITEnable: Byte platform = 0; { 1 to call UnhandledExceptionFilter if the exception + is not a Pascal exception. + >1 to call UnhandledExceptionFilter for all exceptions } + NoErrMsg: Boolean platform = False; { True causes the base RTL to not display the message box + when a run-time error occurs } +{$IFDEF LINUX} + { CoreDumpEnabled = True will cause unhandled + exceptions and runtime errors to raise a + SIGABRT signal, which will cause the OS to + coredump the process address space. This can + be useful for postmortem debugging. } + CoreDumpEnabled: Boolean platform = False; +{$ENDIF} + +type +(*$NODEFINE TTextLineBreakStyle*) + TTextLineBreakStyle = (tlbsLF, tlbsCRLF); + +var { Text output line break handling. Default value for all text files } + DefaultTextLineBreakStyle: TTextLineBreakStyle = {$IFDEF LINUX} tlbsLF {$ENDIF} + {$IFDEF MSWINDOWS} tlbsCRLF {$ENDIF}; +const + sLineBreak = {$IFDEF LINUX} #10 {$ENDIF} {$IFDEF MSWINDOWS} #13#10 {$ENDIF}; + +type + HRSRC = THandle; + TResourceHandle = HRSRC; // make an opaque handle type + HINST = THandle; + HMODULE = HINST; + HGLOBAL = THandle; + +{$IFDEF ELF} +{ ELF resources } +function FindResource(ModuleHandle: HMODULE; ResourceName, ResourceType: PChar): TResourceHandle; +function LoadResource(ModuleHandle: HMODULE; ResHandle: TResourceHandle): HGLOBAL; +function SizeofResource(ModuleHandle: HMODULE; ResHandle: TResourceHandle): Integer; +function LockResource(ResData: HGLOBAL): Pointer; +function UnlockResource(ResData: HGLOBAL): LongBool; +function FreeResource(ResData: HGLOBAL): LongBool; +{$ENDIF} + +{ Memory manager support } + +{X} // By default, now system memory management routines are used +{X} // to allocate memory. This can be slow sometimes, so if You +{X} // want to use custom Borland Delphi memory manager, call follow: +{X} procedure UseDelphiMemoryManager; +{X} function IsDelphiMemoryManagerSet : Boolean; +{X} function MemoryManagerNotUsed : Boolean; + +procedure GetMemoryManager(var MemMgr: TMemoryManager); +procedure SetMemoryManager(const MemMgr: TMemoryManager); +{X} // following function is replaced with pointer to one +{X} // (initialized by another) +{X} //function IsMemoryManagerSet: Boolean; +var IsMemoryManagerSet : function : Boolean = MemoryManagerNotUsed; + + +function SysGetMem(Size: Integer): Pointer; +function SysFreeMem(P: Pointer): Integer; +function SysReallocMem(P: Pointer; Size: Integer): Pointer; + +var + AllocMemCount: Integer; { Number of allocated memory blocks } + AllocMemSize: Integer; { Total size of allocated memory blocks } + +{$IFDEF MSWINDOWS} +function GetHeapStatus: THeapStatus; platform; +{$ENDIF} + +{ Thread support } +type + TThreadFunc = function(Parameter: Pointer): Integer; +{$IFDEF LINUX} + TSize_T = Cardinal; + + TSchedParam = record + sched_priority: Integer; + end; + + pthread_attr_t = record + __detachstate, + __schedpolicy: Integer; + __schedparam: TSchedParam; + __inheritsched, + __scope: Integer; + __guardsize: TSize_T; + __stackaddr_set: Integer; + __stackaddr: Pointer; + __stacksize: TSize_T; + end; + {$EXTERNALSYM pthread_attr_t} + TThreadAttr = pthread_attr_t; + PThreadAttr = ^TThreadAttr; + + TBeginThreadProc = function (Attribute: PThreadAttr; + ThreadFunc: TThreadFunc; Parameter: Pointer; + var ThreadId: Cardinal): Integer; + TEndThreadProc = procedure(ExitCode: Integer); + +var + BeginThreadProc: TBeginThreadProc = nil; + EndThreadProc: TEndThreadProc = nil; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function BeginThread(SecurityAttributes: Pointer; StackSize: LongWord; + ThreadFunc: TThreadFunc; Parameter: Pointer; CreationFlags: LongWord; + var ThreadId: LongWord): Integer; +{$ENDIF} +{$IFDEF LINUX} +function BeginThread(Attribute: PThreadAttr; ThreadFunc: TThreadFunc; + Parameter: Pointer; var ThreadId: Cardinal): Integer; + +{$ENDIF} +procedure EndThread(ExitCode: Integer); + +{ Standard procedures and functions } + +const +{ File mode magic numbers } + + fmClosed = $D7B0; + fmInput = $D7B1; + fmOutput = $D7B2; + fmInOut = $D7B3; + +{ Text file flags } + tfCRLF = $1; // Dos compatibility flag, for CR+LF line breaks and EOF checks + +type +{ Typed-file and untyped-file record } + + TFileRec = packed record (* must match the size the compiler generates: 332 bytes *) + Handle: Integer; + Mode: Word; + Flags: Word; + case Byte of + 0: (RecSize: Cardinal); // files of record + 1: (BufSize: Cardinal; // text files + BufPos: Cardinal; + BufEnd: Cardinal; + BufPtr: PChar; + OpenFunc: Pointer; + InOutFunc: Pointer; + FlushFunc: Pointer; + CloseFunc: Pointer; + UserData: array[1..32] of Byte; + Name: array[0..259] of Char; ); + end; + +{ Text file record structure used for Text files } + PTextBuf = ^TTextBuf; + TTextBuf = array[0..127] of Char; + TTextRec = packed record (* must match the size the compiler generates: 460 bytes *) + Handle: Integer; (* must overlay with TFileRec *) + Mode: Word; + Flags: Word; + BufSize: Cardinal; + BufPos: Cardinal; + BufEnd: Cardinal; + BufPtr: PChar; + OpenFunc: Pointer; + InOutFunc: Pointer; + FlushFunc: Pointer; + CloseFunc: Pointer; + UserData: array[1..32] of Byte; + Name: array[0..259] of Char; + Buffer: TTextBuf; + end; + + TTextIOFunc = function (var F: TTextRec): Integer; + TFileIOFunc = function (var F: TFileRec): Integer; + +procedure SetLineBreakStyle(var T: Text; Style: TTextLineBreakStyle); + +procedure ChDir(const S: string); overload; +procedure ChDir(P: PChar); overload; +function Flush(var t: Text): Integer; +procedure _LGetDir(D: Byte; var S: string); +procedure _SGetDir(D: Byte; var S: ShortString); +function IOResult: Integer; +procedure MkDir(const S: string); overload; +procedure MkDir(P: PChar); overload; +procedure Move(const Source; var Dest; Count: Integer); +function ParamCount: Integer; +function ParamStr(Index: Integer): string; +procedure RmDir(const S: string); overload; +procedure RmDir(P: PChar); overload; +function UpCase(Ch: Char): Char; + +{ random functions } +procedure Randomize; + +function Random(const ARange: Integer): Integer; overload; +function Random: Extended; overload; + +{ Control 8087 control word } + +procedure Set8087CW(NewCW: Word); +function Get8087CW: Word; + +{ Wide character support procedures and functions for C++ } +{ These functions should not be used in Delphi code! + (conversion is implicit in Delphi code) } + +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; + +{ PUCS4Chars returns a pointer to the UCS4 char data in the + UCS4String array, or a pointer to a null char if UCS4String is empty } + +function PUCS4Chars(const S: UCS4String): PUCS4Char; + +{ Widestring <-> UCS4 conversion } + +function WideStringToUCS4String(const S: WideString): UCS4String; +function UCS4StringToWideString(const S: UCS4String): WideString; + +{ PChar/PWideChar Unicode <-> UTF8 conversion } + +// UnicodeToUTF8(3): +// UTF8ToUnicode(3): +// Scans the source data to find the null terminator, up to MaxBytes +// Dest must have MaxBytes available in Dest. +// MaxDestBytes includes the null terminator (last char in the buffer will be set to null) +// Function result includes the null terminator. + +function UnicodeToUtf8(Dest: PChar; Source: PWideChar; MaxBytes: Integer): Integer; overload; deprecated; +function Utf8ToUnicode(Dest: PWideChar; Source: PChar; MaxChars: Integer): Integer; overload; deprecated; + +// UnicodeToUtf8(4): +// UTF8ToUnicode(4): +// MaxDestBytes includes the null terminator (last char in the buffer will be set to null) +// Function result includes the null terminator. +// Nulls in the source data are not considered terminators - SourceChars must be accurate + +function UnicodeToUtf8(Dest: PChar; MaxDestBytes: Cardinal; Source: PWideChar; SourceChars: Cardinal): Cardinal; overload; +function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: Cardinal; Source: PChar; SourceBytes: Cardinal): Cardinal; overload; + +{ WideString <-> UTF8 conversion } + +function UTF8Encode(const WS: WideString): UTF8String; +function UTF8Decode(const S: UTF8String): WideString; + +{ Ansi <-> UTF8 conversion } + +function AnsiToUtf8(const S: string): UTF8String; +function Utf8ToAnsi(const S: UTF8String): string; + +{ OLE string support procedures and functions } + +function OleStrToString(Source: PWideChar): string; +procedure OleStrToStrVar(Source: PWideChar; var Dest: string); +function StringToOleStr(const Source: string): PWideChar; + +{ Variant manager support procedures and functions } + +procedure GetVariantManager(var VarMgr: TVariantManager); +procedure SetVariantManager(const VarMgr: TVariantManager); +function IsVariantManagerSet: Boolean; + +{ Variant support procedures and functions } + +procedure _VarClear(var V: Variant); +procedure _VarCopy(var Dest: Variant; const Source: Variant); +procedure _VarCopyNoInd; +procedure _VarCast(var Dest: Variant; const Source: Variant; VarType: Integer); +procedure _VarCastOle(var Dest: Variant; const Source: Variant; VarType: Integer); +procedure _VarClr(var V: Variant); + +{ Variant text streaming support } + +function _WriteVariant(var T: Text; const V: Variant; Width: Integer): Pointer; +function _Write0Variant(var T: Text; const V: Variant): Pointer; + +{ Variant math and conversion support } + +function _VarToInt(const V: Variant): Integer; +function _VarToInt64(const V: Variant): Int64; +function _VarToBool(const V: Variant): Boolean; +function _VarToReal(const V: Variant): Extended; +function _VarToCurr(const V: Variant): Currency; +procedure _VarToPStr(var S; const V: Variant); +procedure _VarToLStr(var S: string; const V: Variant); +procedure _VarToWStr(var S: WideString; const V: Variant); +procedure _VarToIntf(var Unknown: IInterface; const V: Variant); +procedure _VarToDisp(var Dispatch: IDispatch; const V: Variant); +procedure _VarToDynArray(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer); + +procedure _VarFromInt(var V: Variant; const Value, Range: Integer); +procedure _VarFromInt64(var V: Variant; const Value: Int64); +procedure _VarFromBool(var V: Variant; const Value: Boolean); +procedure _VarFromReal; // var V: Variant; const Value: Real +procedure _VarFromTDateTime; // var V: Variant; const Value: TDateTime +procedure _VarFromCurr; // var V: Variant; const Value: Currency +procedure _VarFromPStr(var V: Variant; const Value: ShortString); +procedure _VarFromLStr(var V: Variant; const Value: string); +procedure _VarFromWStr(var V: Variant; const Value: WideString); +procedure _VarFromIntf(var V: Variant; const Value: IInterface); +procedure _VarFromDisp(var V: Variant; const Value: IDispatch); +procedure _VarFromDynArray(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer); +procedure _OleVarFromPStr(var V: OleVariant; const Value: ShortString); +procedure _OleVarFromLStr(var V: OleVariant; const Value: string); +procedure _OleVarFromVar(var V: OleVariant; const Value: Variant); +procedure _OleVarFromInt(var V: OleVariant; const Value, Range: Integer); + +procedure _VarAdd(var Left: Variant; const Right: Variant); +procedure _VarSub(var Left: Variant; const Right: Variant); +procedure _VarMul(var Left: Variant; const Right: Variant); +procedure _VarDiv(var Left: Variant; const Right: Variant); +procedure _VarMod(var Left: Variant; const Right: Variant); +procedure _VarAnd(var Left: Variant; const Right: Variant); +procedure _VarOr(var Left: Variant; const Right: Variant); +procedure _VarXor(var Left: Variant; const Right: Variant); +procedure _VarShl(var Left: Variant; const Right: Variant); +procedure _VarShr(var Left: Variant; const Right: Variant); +procedure _VarRDiv(var Left: Variant; const Right: Variant); + +procedure _VarCmpEQ(const Left, Right: Variant); // result is set in the flags +procedure _VarCmpNE(const Left, Right: Variant); // result is set in the flags +procedure _VarCmpLT(const Left, Right: Variant); // result is set in the flags +procedure _VarCmpLE(const Left, Right: Variant); // result is set in the flags +procedure _VarCmpGT(const Left, Right: Variant); // result is set in the flags +procedure _VarCmpGE(const Left, Right: Variant); // result is set in the flags + +procedure _VarNeg(var V: Variant); +procedure _VarNot(var V: Variant); + +{ Variant dispatch and reference support } + +procedure _DispInvoke; cdecl; // Dest: PVarData; const Source: TVarData; + // CallDesc: PCallDesc; Params: Pointer +procedure _IntfDispCall; cdecl; // ARGS PLEASE! +procedure _IntfVarCall; cdecl; // ARGS PLEASE! +procedure _VarAddRef(var V: Variant); + +{ Variant array support procedures and functions } + +procedure _VarArrayRedim(var A : Variant; HighBound: Integer); +function _VarArrayGet(var A: Variant; IndexCount: Integer; + Indices: Integer): Variant; cdecl; +procedure _VarArrayPut(var A: Variant; const Value: Variant; + IndexCount: Integer; Indices: Integer); cdecl; + +{ Package/Module registration and unregistration } + +type + PLibModule = ^TLibModule; + TLibModule = record + Next: PLibModule; + Instance: LongWord; + CodeInstance: LongWord; + DataInstance: LongWord; + ResInstance: LongWord; + Reserved: Integer; +{$IFDEF LINUX} + InstanceVar: Pointer platform; + GOT: LongWord platform; + CodeSegStart: LongWord platform; + CodeSegEnd: LongWord platform; + InitTable: Pointer platform; +{$ENDIF} + end; + + TEnumModuleFunc = function (HInstance: Integer; Data: Pointer): Boolean; + {$EXTERNALSYM TEnumModuleFunc} + TEnumModuleFuncLW = function (HInstance: LongWord; Data: Pointer): Boolean; + {$EXTERNALSYM TEnumModuleFuncLW} + TModuleUnloadProc = procedure (HInstance: Integer); + {$EXTERNALSYM TModuleUnloadProc} + TModuleUnloadProcLW = procedure (HInstance: LongWord); + {$EXTERNALSYM TModuleUnloadProcLW} + + PModuleUnloadRec = ^TModuleUnloadRec; + TModuleUnloadRec = record + Next: PModuleUnloadRec; + Proc: TModuleUnloadProcLW; + end; + +var + LibModuleList: PLibModule = nil; + ModuleUnloadList: PModuleUnloadRec = nil; + +procedure RegisterModule(LibModule: PLibModule); +{X procedure UnregisterModule(LibModule: PLibModule); -replaced with pointer to procedure } +{X} procedure UnregisterModuleLight(LibModule: PLibModule); +{X} procedure UnregisterModuleSafely(LibModule: PLibModule); +var UnregisterModule : procedure(LibModule: PLibModule) = UnregisterModuleLight; +function FindHInstance(Address: Pointer): LongWord; +function FindClassHInstance(ClassType: TClass): LongWord; +function FindResourceHInstance(Instance: LongWord): LongWord; +function LoadResourceModule(ModuleName: PChar; CheckOwner: Boolean = True): LongWord; +procedure EnumModules(Func: TEnumModuleFunc; Data: Pointer); overload; +procedure EnumResourceModules(Func: TEnumModuleFunc; Data: Pointer); overload; +procedure EnumModules(Func: TEnumModuleFuncLW; Data: Pointer); overload; +procedure EnumResourceModules(Func: TEnumModuleFuncLW; Data: Pointer); overload; +procedure AddModuleUnloadProc(Proc: TModuleUnloadProc); overload; +procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProc); overload; +procedure AddModuleUnloadProc(Proc: TModuleUnloadProcLW); overload; +procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProcLW); overload; +{$IFDEF LINUX} +{ Given an HMODULE, this function will return its fully qualified name. There is + no direct equivalent in Linux so this function provides that capability. } +function GetModuleFileName(Module: HMODULE; Buffer: PChar; BufLen: Integer): Integer; +{$ENDIF} + +{ ResString support function/record } + +type + PResStringRec = ^TResStringRec; + TResStringRec = packed record + Module: ^Cardinal; + Identifier: Integer; + end; + +function LoadResString(ResStringRec: PResStringRec): string; + +{ Procedures and functions that need compiler magic } + +function Int(const X: Extended): Extended; +function Frac(const X: Extended): Extended; +function Exp(const X: Extended): Extended; +function Cos(const X: Extended): Extended; +function Sin(const X: Extended): Extended; +function Ln(const X: Extended): Extended; +function ArcTan(const X: Extended): Extended; +function Sqrt(const X: Extended): Extended; + +procedure _ROUND; +procedure _TRUNC; + +procedure _AbstractError; +procedure _Assert(const Message, Filename: AnsiString; LineNumber: Integer); +function _Append(var t: TTextRec): Integer; +function _Assign(var t: TTextRec; const S: String): Integer; +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); +function _EofFile(var f: TFileRec): Boolean; +function _EofText(var t: TTextRec): Boolean; +function _Eoln(var t: TTextRec): Boolean; +procedure _Erase(var f: TFileRec); +function _FilePos(var f: TFileRec): Longint; +function _FileSize(var f: TFileRec): Longint; +procedure _FillChar(var Dest; count: Integer; Value: Char); +function _FreeMem(P: Pointer): Integer; +function _GetMem(Size: Integer): Pointer; +function _ReallocMem(var P: Pointer; NewSize: Integer): Pointer; +procedure _Halt(Code: Integer); +procedure _Halt0; +procedure Mark; deprecated; +procedure _PStrCmp; +procedure _AStrCmp; +procedure _RandInt; +procedure _RandExt; +function _ReadRec(var f: TFileRec; Buffer: Pointer): Integer; +function _ReadChar(var t: TTextRec): Char; +function _ReadLong(var t: TTextRec): Longint; +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); +procedure _ReadWString(var t: TTextRec; var s: WideString); +procedure _ReadWCString(var t: TTextRec; s: PWideChar; maxBytes: Longint); +function _ReadWChar(var t: TTextRec): WideChar; +function _ReadExt(var t: TTextRec): Extended; +procedure _ReadLn(var t: TTextRec); +procedure _Rename(var f: TFileRec; newName: PChar); +procedure Release; deprecated; +function _ResetText(var t: TTextRec): Integer; +function _ResetFile(var f: TFileRec; recSize: Longint): Integer; +function _RewritText(var t: TTextRec): Integer; +function _RewritFile(var f: TFileRec; recSize: Longint): Integer; +procedure _RunError(errorCode: Byte); +procedure _Run0Error; +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; +{$IFDEF LINUX} +procedure _UnhandledException; +{$ENDIF} +function _WriteRec(var f: TFileRec; buffer: Pointer): Pointer; +function _WriteChar(var t: TTextRec; c: Char; width: Integer): Pointer; +function _Write0Char(var t: TTextRec; c: Char): 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 _WriteString(var t: TTextRec; const s: ShortString; width: Longint): Pointer; +function _Write0String(var t: TTextRec; const s: ShortString): Pointer; +function _WriteCString(var t: TTextRec; s: PChar; width: Longint): Pointer; +function _Write0CString(var t: TTextRec; s: PChar): Pointer; +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 _WriteWCString(var t: TTextRec; s: PWideChar; width: Longint): Pointer; +function _Write0WCString(var t: TTextRec; s: PWideChar): Pointer; +function _WriteWChar(var t: TTextRec; c: WideChar; width: Integer): Pointer; +function _Write0WChar(var t: TTextRec; c: WideChar): 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 __IOTest; +function _Flush(var t: TTextRec): Integer; + +procedure _SetElem; +procedure _SetRange; +procedure _SetEq; +procedure _SetLe; +procedure _SetIntersect; +procedure _SetIntersect3; { BEG only } +procedure _SetUnion; +procedure _SetUnion3; { BEG only } +procedure _SetSub; +procedure _SetSub3; { BEG only } +procedure _SetExpand; + +procedure _Str2Ext; +procedure _Str0Ext; +procedure _Str1Ext; +procedure _ValExt; +procedure _Pow10; +procedure _Real2Ext; +procedure _Ext2Real; + +procedure _ObjSetup; +procedure _ObjCopy; +procedure _Fail; +procedure _BoundErr; +procedure _IntOver; + +{ Module initialization context. For internal use only. } + +type + PInitContext = ^TInitContext; + TInitContext = record + OuterContext: PInitContext; { saved InitContext } +{$IFNDEF PC_MAPPED_EXCEPTIONS} + ExcFrame: Pointer; { bottom exc handler } +{$ENDIF} + InitTable: PackageInfo; { unit init info } + InitCount: Integer; { how far we got } + Module: PLibModule; { ptr to module desc } + DLLSaveEBP: Pointer; { saved regs for DLLs } + DLLSaveEBX: Pointer; { saved regs for DLLs } + DLLSaveESI: Pointer; { saved regs for DLLs } + DLLSaveEDI: Pointer; { saved regs for DLLs } +{$IFDEF MSWINDOWS} + ExitProcessTLS: procedure; { Shutdown for TLS } +{$ENDIF} + DLLInitState: Byte; { 0 = package, 1 = DLL shutdown, 2 = DLL startup } + end platform; + +type + TDLLProc = procedure (Reason: Integer); + // TDLLProcEx provides the reserved param returned by WinNT + TDLLProcEx = procedure (Reason: Integer; Reserved: Integer); + +{$IFDEF LINUX} +procedure _StartExe(InitTable: PackageInfo; Module: PLibModule; Argc: Integer; Argv: Pointer); +procedure _StartLib(Context: PInitContext; Module: PLibModule; DLLProc: TDLLProcEx); +{$ENDIF} +{$IFDEF MSWINDOWS} +procedure _StartExe(InitTable: PackageInfo; Module: PLibModule); +procedure _StartLib; +{$ENDIF} +procedure _PackageLoad(const Table : PackageInfo; Module: PLibModule); +procedure _PackageUnload(const Table : PackageInfo; Module: PLibModule); +procedure _InitResStrings; +procedure _InitResStringImports; +procedure _InitImports; +{$IFDEF MSWINDOWS} +procedure _InitWideStrings; +{$ENDIF} + +function _ClassCreate(AClass: TClass; Alloc: Boolean): TObject; +procedure _ClassDestroy(Instance: TObject); +function _AfterConstruction(Instance: TObject): TObject; +function _BeforeDestruction(Instance: TObject; OuterMost: ShortInt): TObject; +function _IsClass(Child: TObject; Parent: TClass): Boolean; +function _AsClass(Child: TObject; Parent: TClass): TObject; + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _RaiseAtExcept; +//procedure _DestroyException(Exc: PRaisedException); +procedure _DestroyException; +{$ENDIF} +procedure _RaiseExcept; +procedure _RaiseAgain; +procedure _DoneExcept; +{$IFNDEF PC_MAPPED_EXCEPTIONS} +procedure _TryFinallyExit; +{$ENDIF} +procedure _HandleAnyException; +procedure _HandleFinally; +procedure _HandleOnException; +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _HandleOnExceptionPIC; +{$ENDIF} +procedure _HandleAutoException; +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _ClassHandleException; +{$ENDIF} + +procedure _CallDynaInst; +procedure _CallDynaClass; +procedure _FindDynaInst; +procedure _FindDynaClass; + +procedure _LStrClr(var S); +procedure _LStrArrayClr(var StrArray; cnt: longint); +procedure _LStrAsg(var dest; const source); +procedure _LStrLAsg(var dest; const source); +procedure _LStrFromPCharLen(var Dest: AnsiString; Source: PAnsiChar; Length: 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; //inline; +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 _LStrToPChar(const s: AnsiString): PChar; +procedure _Copy{ s : ShortString; index, count : Integer ) : ShortString}; +procedure _Delete{ var s : openstring; index, count : Integer }; +procedure _Insert{ source : ShortString; var s : openstring; index : Integer }; +function Pos(const substr, str: AnsiString): Integer; overload; +function Pos(const substr, str: WideString): Integer; overload; +procedure _SetLength(s: PShortString; newLength: Byte); +procedure _SetString(s: PShortString; buffer: PChar; len: Byte); + +procedure UniqueString(var str: AnsiString); overload; +procedure UniqueString(var str: WideString); overload; +procedure _UniqueStringA(var str: AnsiString); +procedure _UniqueStringW(var str: WideString); + +function StringOfChar(ch: AnsiChar; Count: Integer): AnsiString; overload; +function StringOfChar(ch: WideChar; Count: Integer): WideString; overload; + +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 _NewAnsiString(length: Longint): Pointer; { for debugger purposes only } +function _NewWideString(CharLength: Longint): Pointer; + +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); +function _WStrToPWChar(const S: WideString): PWideChar; +function _WStrLen(const S: WideString): Integer; +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); +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; + +procedure _Initialize(p: Pointer; typeInfo: Pointer); +procedure _InitializeArray(p: Pointer; typeInfo: Pointer; elemCount: Cardinal); +procedure _InitializeRecord(p: Pointer; typeInfo: Pointer); +procedure _Finalize(p: Pointer; typeInfo: Pointer); +procedure _FinalizeArray(p: Pointer; typeInfo: Pointer; elemCount: Cardinal); +procedure _FinalizeRecord(P: Pointer; typeInfo: Pointer); +procedure _AddRef; +procedure _AddRefArray; +procedure _AddRefRecord; +procedure _CopyArray; +procedure _CopyRecord; +procedure _CopyObject; + +function _New(size: Longint; typeInfo: Pointer): Pointer; +procedure _Dispose(p: Pointer; typeInfo: Pointer); + +{ 64-bit Integer helper routines } +procedure __llmul; +procedure __lldiv; +procedure __lludiv; +procedure __llmod; +procedure __llmulo; +procedure __lldivo; +procedure __llmodo; +procedure __llumod; +procedure __llshl; +procedure __llushr; +procedure _WriteInt64; +procedure _Write0Int64; +procedure _WriteUInt64; +procedure _Write0UInt64; +procedure _ReadInt64; +function _StrInt64(val: Int64; width: Integer): ShortString; +function _Str0Int64(val: Int64): ShortString; +function _StrUInt64(val: UInt64; width: Integer): ShortString; +function _Str0UInt64(val: Int64): ShortString; +function _ValInt64(const s: AnsiString; var code: Integer): Int64; + +{ Dynamic array helper functions } + +procedure _DynArrayHigh; +procedure _DynArrayClear(var a: Pointer; typeInfo: Pointer); +procedure _DynArrayLength; +procedure _DynArraySetLength; +procedure _DynArrayCopy(a: Pointer; typeInfo: Pointer; var Result: Pointer); +procedure _DynArrayCopyRange(a: Pointer; typeInfo: Pointer; index, count : Integer; var Result: Pointer); +procedure _DynArrayAsg; +procedure _DynArrayAddRef; + +procedure DynArrayClear(var a: Pointer; typeInfo: Pointer); +procedure DynArraySetLength(var a: Pointer; typeInfo: Pointer; dimCnt: Longint; lengthVec: PLongint); +function DynArrayDim(typeInfo: PDynArrayTypeInfo): Integer; +{$NODEFINE DynArrayDim} + +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); + +{$IFDEF MSWINDOWS} +procedure _FSafeDivide; +procedure _FSafeDivideR; +{$ENDIF} + +function _CheckAutoResult(ResultCode: HResult): HResult; + +procedure FPower10; + +procedure TextStart; deprecated; + +// Conversion utility routines for C++ convenience. Not for Delphi code. +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; + +{ Internal runtime error codes } + +type + TRuntimeError = (reNone, reOutOfMemory, reInvalidPtr, reDivByZero, + reRangeError, reIntOverflow, reInvalidOp, reZeroDivide, reOverflow, + reUnderflow, reInvalidCast, reAccessViolation, rePrivInstruction, + reControlBreak, reStackOverflow, + { reVar* used in Variants.pas } + reVarTypeCast, reVarInvalidOp, + reVarDispatch, reVarArrayCreate, reVarNotArray, reVarArrayBounds, + reAssertionFailed, + reExternalException, { not used here; in SysUtils } + reIntfCastError, reSafeCallError); +{$NODEFINE TRuntimeError} + +procedure Error(errorCode: TRuntimeError); +{$NODEFINE Error} + +{ GetLastError returns the last error reported by an OS API call. Calling + this function usually resets the OS error state. +} + +function GetLastError: Integer; {$IFDEF MSWINDOWS} stdcall; {$ENDIF} +{$EXTERNALSYM GetLastError} + +{ SetLastError writes to the thread local storage area read by GetLastError. } + +procedure SetLastError(ErrorCode: Integer); {$IFDEF MSWINDOWS} stdcall; {$ENDIF} + +{$IFDEF LINUX} +{ To improve performance, some RTL routines cache module handles and data + derived from modules. If an application dynamically loads and unloads + shared object libraries, packages, or resource packages, it is possible for + the handle of the newly loaded module to match the handle of a recently + unloaded module. The resource caches have no way to detect when this happens. + + To address this issue, the RTL maintains an internal counter that is + incremented every time a module is loaded or unloaded using RTL functions + (like LoadPackage). This provides a cache version level signature that + can detect when modules have been cycled but have the same handle. + + If you load or unload modules "by hand" using dlopen or dlclose, you must call + InvalidateModuleCache after each load or unload so that the RTL module handle + caches will refresh themselves properly the next time they are used. This is + especially important if you manually tinker with the LibModuleList list of + loaded modules, or manually add or remove resource modules in the nodes + of that list. + + ModuleCacheID returns the "current generation" or version number kept by + the RTL. You can use this to implement your own refresh-on-next-use + (passive) module handle caches as the RTL does. The value changes each + time InvalidateModuleCache is called. +} + +function ModuleCacheID: Cardinal; +procedure InvalidateModuleCache; +{$ENDIF} + +{$IFDEF LINUX} +{ When a process that is being debugged is stopped while it has the mouse + pointer grabbed, there is no way for the debugger to release the grab on + behalf of the process. The process needs to do it itself. To accomplish this, + the debugger causes DbgUnlockX to execute whenever it detects the process + might have the mouse grabbed. This method will call through DbgUnlockXProc + which should be assigned by any library using X and locks the X pointer. This + method should be chained, by storing of the previous instance and calling it + when you are called, since there might be more than one display that needs + to be unlocked. This method should call XUngrabPointer on the display that + has the pointer grabbed. +} +var + DbgUnlockXProc: procedure; + +procedure DbgUnlockX; +{$ENDIF} + +{X+ moved here from SysInit.pas - by advise of Alexey Torgashin - to avoid + creating of separate import block from kernel32.dll : } +////////////////////////////////////////////////////////////////////////// + +function FreeLibrary(ModuleHandle: Longint): LongBool; stdcall; +function GetModuleFileName(Module: Integer; Filename: PChar; Size: Integer): Integer; stdcall; +function GetModuleHandle(ModuleName: PChar): Integer; stdcall; +function LocalAlloc(flags, size: Integer): Pointer; stdcall; +function LocalFree(addr: Pointer): Pointer; stdcall; +function TlsAlloc: Integer; stdcall; +function TlsFree(TlsIndex: Integer): Boolean; stdcall; +function TlsGetValue(TlsIndex: Integer): Pointer; stdcall; +function TlsSetValue(TlsIndex: Integer; TlsValue: Pointer): Boolean; stdcall; +function GetCommandLine: PChar; stdcall; +{X-}////////////////////////////////////////////////////////////////////// + +{X+} +{X}function GetProcessHeap: THandle; stdcall; +{X}function HeapAlloc(hHeap: THandle; dwFlags, dwBytes: Cardinal): Pointer; stdcall; +{X}function HeapReAlloc(hHeap: THandle; dwFlags: Cardinal; lpMem: Pointer; dwBytes: Cardinal): Pointer; stdcall; +{X}function HeapFree(hHeap: THandle; dwFlags: Cardinal; lpMem: Pointer): LongBool; stdcall; +{X}function DfltGetMem(size: Integer): Pointer; +{X}function DfltFreeMem(p: Pointer): Integer; +{X}function DfltReallocMem(p: Pointer; size: Integer): Pointer; +{X} procedure InitUnitsLight( Table : PUnitEntryTable; Idx, Count : Integer ); +{X} procedure FInitUnitsLight; +{X} // following two procedures are optional and exclusive. +{X} // call it to provide error message: first - for GUI app, +{X} // second - for console app. +{X} procedure UseErrorMessageBox; +{X} procedure UseErrorMessageWrite; + +{X} // call following procedure to initialize Input and Output +{X} // - for console app only: +{X} procedure UseInputOutput; + +{X} // if your app uses FPU, call one of following procedures: +{X} procedure FpuInit; +{X} procedure FpuInitConsiderNECWindows; +{X} // the second additionally takes into consideration NEC +{X} // Windows keyboard (Japaneeze keyboard ???). + +{X} procedure DummyProc; // empty procedure + +(* +{X} procedure VariantClr; +{X} // procedure to refer to _VarClr if SysVarnt.pas is in use +{X} var VarClrProc : procedure = DummyProc; + +{X} procedure VarCastError; +{X} procedure VarInvalidOp; + +{X} procedure VariantAddRef; +{X} // procedure to refer to _VarAddRef if SysVarnt.pas is in use +{X} var VarAddRefProc : procedure = DummyProc; +*) + +{X} procedure WStrAddRef; +{X} // procedure to refer to _WStrAddRef if SysWStr.pas is in use +{X} var WStrAddRefProc : procedure = DummyProc; + +{X} procedure WStrClr; +{X} // procedure to refer to _WStrClr if SysWStr.pas is in use +{X} var WStrClrProc : procedure = DummyProc; + +{X} procedure WStrArrayClr; +{X} // procedure to refer to _WStrArrayClr if SysWStr.pas is in use +{X} var WStrArrayClrProc : procedure = DummyProc; + +{X} // Standard Delphi units initialization/finalization uses +{X} // try-except and raise constructions, which leads to permanent +{X} // usage of all exception handling routines. In this XCL-aware +{X} // implementation, "light" version of initialization/finalization +{X} // is used by default. To use standard Delphi initialization and +{X} // finalization method, allowing to flow execution control even +{X} // in initalization sections, include reference to SysSfIni.pas +{X} // into uses clause *as first as possible*. +{X} procedure InitUnitsHard( Table : PUnitEntryTable; Idx, Count : Integer ); +{X} var InitUnitsProc : procedure( Table : PUnitEntryTable; Idx, Count : Integer ) +{X} = InitUnitsLight; +{X} procedure FInitUnitsHard; +{X} var FInitUnitsProc : procedure = FInitUnitsLight; +{X} procedure SetExceptionHandler; +{X} procedure UnsetExceptionHandler; +{X} var UnsetExceptionHandlerProc : procedure = DummyProc; + +{X} var UnloadResProc: procedure = DummyProc; +{X-} + +(* =================================================================== *) + + +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; + +{X+} +const + advapi32 = 'advapi32.dll'; + kernel = 'kernel32.dll'; + user = 'user32.dll'; + oleaut = 'oleaut32.dll'; + +function GetProcessHeap; external kernel name 'GetProcessHeap'; +function HeapAlloc; stdcall; external kernel name 'HeapAlloc'; +function HeapReAlloc; stdcall; external kernel name 'HeapReAlloc'; +function HeapFree; stdcall; external kernel name 'HeapFree'; +{X-} + +{$IFDEF PIC} +function GetGOT: LongWord; export; +begin + asm + MOV Result,EBX + end; +end; +{$ENDIF} + +{$IFDEF PC_MAPPED_EXCEPTIONS} +const + UNWINDFI_TOPOFSTACK = $BE00EF00; + +{$IFDEF MSWINDOWS} +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'; +{$ENDIF} +{$IFDEF LINUX} +const + unwind = 'libborunwind.so.6'; +type + UNWINDPROC = Pointer; + +{$DEFINE STATIC_UNWIND} + +{$IFDEF STATIC_UNWIND} +function _BorUnwind_RegisterIPLookup(fn: UNWINDPROC; StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; cdecl; + external; + +procedure _BorUnwind_UnregisterIPLookup(StartAddr: LongInt); cdecl; external; + +function _BorUnwind_DelphiLookup(Addr: LongInt; Context: Pointer): UNWINDPROC; cdecl; external; + +function _BorUnwind_RaiseException(Exc: Pointer): LongBool; cdecl; external; + +//function _BorUnwind_AddressIsInPCMap(Addr: LongInt): LongBool; cdecl; external; +function _BorUnwind_ClosestDelphiHandler(Context: Pointer): LongWord; cdecl; external; +{$ELSE} + +function _BorUnwind_RegisterIPLookup(fn: UNWINDPROC; StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; cdecl; + external unwind name '_BorUnwind_RegisterIPLookup'; + +procedure _BorUnwind_UnregisterIPLookup(StartAddr: LongInt); cdecl; + external unwind name '_BorUnwind_UnregisterIPLookup'; + +function _BorUnwind_DelphiLookup(Addr: LongInt; Context: Pointer): UNWINDPROC; cdecl; + external unwind name '_BorUnwind_DelphiLookup'; + +function _BorUnwind_RaiseException(Exc: Pointer): LongBool; cdecl; + external unwind name '_BorUnwind_RaiseException'; + +function _BorUnwind_ClosestDelphiHandler(Context: Pointer): LongWord; cdecl; + external unwind name '_BorUnwind_ClosestDelphiHandler'; +{$ENDIF} +{$ENDIF} +{$ENDIF} + +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} + PRaisedException = ^TRaisedException; + TRaisedException = packed record + RefCount: Integer; + ExceptObject: TObject; + ExceptionAddr: Pointer; + HandlerEBP: LongWord; + Flags: LongWord; + 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 LINUX} +const + libc = 'libc.so.6'; + libdl = 'libdl.so.2'; + libpthread = 'libpthread.so.0'; + + O_RDONLY = $0000; + O_WRONLY = $0001; + O_RDWR = $0002; + O_CREAT = $0040; + O_EXCL = $0080; + O_NOCTTY = $0100; + O_TRUNC = $0200; + O_APPEND = $0400; + + // protection flags + S_IREAD = $0100; // Read by owner. + S_IWRITE = $0080; // Write by owner. + S_IEXEC = $0040; // Execute by owner. + S_IRUSR = S_IREAD; + S_IWUSR = S_IWRITE; + S_IXUSR = S_IEXEC; + S_IRWXU = S_IRUSR or S_IWUSR or S_IXUSR; + + S_IRGRP = S_IRUSR shr 3; // Read by group. + S_IWGRP = S_IWUSR shr 3; // Write by group. + S_IXGRP = S_IXUSR shr 3; // Execute by group. + S_IRWXG = S_IRWXU shr 3; // Read, write, and execute by group. + + S_IROTH = S_IRGRP shr 3; // Read by others. + S_IWOTH = S_IWGRP shr 3; // Write by others. + S_IXOTH = S_IXGRP shr 3; // Execute by others. + S_IRWXO = S_IRWXG shr 3; // Read, write, and execute by others. + + STDIN_FILENO = 0; + STDOUT_FILENO = 1; + STDERR_FILENO = 2; + + SEEK_SET = 0; + SEEK_CUR = 1; + SEEK_END = 2; + + LC_CTYPE = 0; + _NL_CTYPE_CODESET_NAME = LC_CTYPE shl 16 + 14; + + MAX_PATH = 4095; + + +function __open(PathName: PChar; Flags: Integer; Mode: Integer): Integer; cdecl; + external libc name 'open'; + +function __close(Handle: Integer): Integer; cdecl; + external libc name 'close'; + +function __read(Handle: Integer; Buffer: Pointer; Count: Cardinal): Cardinal; cdecl; + external libc name 'read'; + +function __write(Handle: Integer; Buffer: Pointer; Count: Cardinal): Cardinal; cdecl; + external libc name 'write'; + +function __mkdir(PathName: PChar; Mode: Integer): Integer; cdecl; + external libc name 'mkdir'; + +function __getcwd(Buffer: PChar; BufSize: Integer): PChar; cdecl; + external libc name 'getcwd'; + +function __getenv(Name: PChar): PChar; cdecl; + external libc name 'getenv'; + +function __chdir(PathName: PChar): Integer; cdecl; + external libc name 'chdir'; + +function __rmdir(PathName: PChar): Integer; cdecl; + external libc name 'rmdir'; + +function __remove(PathName: PChar): Integer; cdecl; + external libc name 'remove'; + +function __rename(OldPath, NewPath: PChar): Integer; cdecl; + external libc name 'rename'; + +{$IFDEF EFENCE} +function __malloc(Size: Integer): Pointer; cdecl; + external 'libefence.so' name 'malloc'; + +procedure __free(P: Pointer); cdecl; + external 'libefence.so' name 'free'; + +function __realloc(P: Pointer; Size: Integer): Pointer; cdecl; + external 'libefence.so' name 'realloc'; +{$ELSE} +function __malloc(Size: Integer): Pointer; cdecl; + external libc name 'malloc'; + +procedure __free(P: Pointer); cdecl; + external libc name 'free'; + +function __realloc(P: Pointer; Size: Integer): Pointer; cdecl; + external libc name 'realloc'; +{$ENDIF} + +procedure ExitProcess(status: Integer); cdecl; + external libc name 'exit'; + +function _time(P: Pointer): Integer; cdecl; + external libc name 'time'; + +function _lseek(Handle, Offset, Direction: Integer): Integer; cdecl; + external libc name 'lseek'; + +function _ftruncate(Handle: Integer; Filesize: Integer): Integer; cdecl; + external libc name 'ftruncate'; + +function strcasecmp(s1, s2: PChar): Integer; cdecl; + external libc name 'strcasecmp'; + +function __errno_location: PInteger; cdecl; + external libc name '__errno_location'; + +function nl_langinfo(item: integer): pchar; cdecl; + external libc name 'nl_langinfo'; + +function iconv_open(ToCode: PChar; FromCode: PChar): Integer; cdecl; + external libc name 'iconv_open'; + +function iconv(cd: Integer; var InBuf; var InBytesLeft: Integer; var OutBuf; var OutBytesLeft: Integer): Integer; cdecl; + external libc name 'iconv'; + +function iconv_close(cd: Integer): Integer; cdecl; + external libc name 'iconv_close'; + +function mblen(const S: PChar; N: LongWord): Integer; cdecl; + external libc name 'mblen'; + +function mmap(start: Pointer; length: Cardinal; prot, flags, fd, offset: Integer): Pointer; cdecl; + external libc name 'mmap'; + +function munmap(start: Pointer; length: Cardinal): Integer; cdecl; + external libc name 'munmap'; + +const + SIGABRT = 6; + +function __raise(SigNum: Integer): Integer; cdecl; + external libc name 'raise'; + +type + TStatStruct = record + st_dev: Int64; // device + __pad1: Word; + st_ino: Cardinal; // inode + st_mode: Cardinal; // protection + st_nlink: Cardinal; // number of hard links + st_uid: Cardinal; // user ID of owner + st_gid: Cardinal; // group ID of owner + st_rdev: Int64; // device type (if inode device) + __pad2: Word; + st_size: Cardinal; // total size, in bytes + st_blksize: Cardinal; // blocksize for filesystem I/O + st_blocks: Cardinal; // number of blocks allocated + st_atime: Integer; // time of last access + __unused1: Cardinal; + st_mtime: Integer; // time of last modification + __unused2: Cardinal; + st_ctime: Integer; // time of last change + __unused3: Cardinal; + __unused4: Cardinal; + __unused5: Cardinal; + end; + +const + STAT_VER_LINUX = 3; + +function _fxstat(Version: Integer; Handle: Integer; var Stat: TStatStruct): Integer; cdecl; + external libc name '__fxstat'; + +function __xstat(Ver: Integer; FileName: PChar; var StatBuffer: TStatStruct): Integer; cdecl; + external libc name '__xstat'; + +function _strlen(P: PChar): Integer; cdecl; + external libc name 'strlen'; + +function _readlink(PathName: PChar; Buf: PChar; Len: Integer): Integer; cdecl; + external libc name 'readlink'; + +type + TDLInfo = record + FileName: PChar; + BaseAddress: Pointer; + NearestSymbolName: PChar; + SymbolAddress: Pointer; + end; + +const + RTLD_LAZY = 1; + RTLD_NOW = 2; + +function dladdr(Address: Pointer; var Info: TDLInfo): Integer; cdecl; + external libdl name 'dladdr'; +function dlopen(Filename: PChar; Flag: Integer): LongWord; cdecl; + external libdl name 'dlopen'; +function dlclose(Handle: LongWord): Integer; cdecl; + external libdl name 'dlclose'; +function FreeLibrary(Handle: LongWord): Integer; cdecl; + external libdl name 'dlclose'; +function dlsym(Handle: LongWord; Symbol: PChar): Pointer; cdecl; + external libdl name 'dlsym'; +function dlerror: PChar; cdecl; + external libdl name 'dlerror'; + +type + TPthread_fastlock = record + __status: LongInt; + __spinlock: Integer; + end; + + TRTLCriticalSection = record + __m_reserved, + __m_count: Integer; + __m_owner: Pointer; + __m_kind: Integer; // __m_kind := 0 fastlock, __m_kind := 1 recursive lock + __m_lock: TPthread_fastlock; + end; + +function _pthread_mutex_lock(var Mutex: TRTLCriticalSection): Integer; cdecl; + external libpthread name 'pthread_mutex_lock'; +function _pthread_mutex_unlock(var Mutex: TRTLCriticalSection): Integer; cdecl; + external libpthread name 'pthread_mutex_unlock'; +function _pthread_create(var ThreadID: Cardinal; Attr: PThreadAttr; + TFunc: TThreadFunc; Arg: Pointer): Integer; cdecl; + external libpthread name 'pthread_create'; +function _pthread_exit(var RetVal: Integer): Integer; cdecl; + external libpthread name 'pthread_exit'; +function GetCurrentThreadID: LongWord; cdecl; + external libpthread name 'pthread_self'; +function _pthread_detach(ThreadID: Cardinal): Integer; cdecl; + external libpthread name 'pthread_detach' + +function GetLastError: Integer; +begin + Result := __errno_location^; +end; + +procedure SetLastError(ErrorCode: Integer); +begin + __errno_location^ := ErrorCode; +end; + +function InterlockedIncrement(var I: Integer): Integer; +asm + MOV EDX,1 + XCHG EAX,EDX + LOCK XADD [EDX],EAX + INC EAX +end; + +function InterlockedDecrement(var I: Integer): Integer; +asm + MOV EDX,-1 + XCHG EAX,EDX + LOCK XADD [EDX],EAX + DEC EAX +end; + +var + ModuleCacheVersion: Cardinal = 0; + +function ModuleCacheID: Cardinal; +begin + Result := ModuleCacheVersion; +end; + +procedure InvalidateModuleCache; +begin + InterlockedIncrement(Integer(ModuleCacheVersion)); +end; + +{$ENDIF} + +{$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 + 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; + +{X+ moved here from SysInit.pas - by advise of Alexey Torgashin - to avoid + creating of separate import block from kernel32.dll : } +////////////////////////////////////////////////////////////////////////// + +function FreeLibrary(ModuleHandle: Longint): LongBool; stdcall; + external kernel name 'FreeLibrary'; + +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 LocalAlloc(flags, size: Integer): Pointer; stdcall; + external kernel name 'LocalAlloc'; + +function LocalFree(addr: Pointer): Pointer; stdcall; + external kernel name 'LocalFree'; + +function TlsAlloc: Integer; stdcall; + external kernel name 'TlsAlloc'; + +function TlsFree(TlsIndex: Integer): Boolean; stdcall; + external kernel name 'TlsFree'; + +function TlsGetValue(TlsIndex: Integer): Pointer; stdcall; + external kernel name 'TlsGetValue'; + +function TlsSetValue(TlsIndex: Integer; TlsValue: Pointer): Boolean; stdcall; + external kernel name 'TlsSetValue'; + +function GetCommandLine: PChar; stdcall; + external kernel name 'GetCommandLineA'; +{X-}////////////////////////////////////////////////////////////////////// + + +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'; + +{X} //function FreeLibrary(ModuleHandle: Longint): LongBool; stdcall; +{X} // external kernel name 'FreeLibrary'; + +{X} //function GetCommandLine: PChar; stdcall; +{X} // 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'; + +{X} //function GetModuleFileName(Module: Integer; Filename: PChar; +{X} // Size: Integer): Integer; stdcall; +{X} // external kernel name 'GetModuleFileNameA'; + +{X} //function GetModuleHandle(ModuleName: PChar): Integer; stdcall; +{X} // 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 + SI: TStartupInfo; +begin + Result := 10; { SW_SHOWDEFAULT } + GetStartupInfo(SI); + if SI.dwFlags and 1 <> 0 then { STARTF_USESHOWWINDOW } + Result := SI.wShowWindow; +end; + +{$ENDIF} // MSWindows + +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} + + +//////////////////// This code is from HeapMM.pas, (C) by Vladimir Kladov, 2001 +const + HEAP_NO_SERIALIZE = $00001; + HEAP_GROWABLE = $00002; + HEAP_GENERATE_EXCEPTIONS = $00004; + HEAP_ZERO_MEMORY = $00008; + HEAP_REALLOC_IN_PLACE_ONLY = $00010; + HEAP_TAIL_CHECKING_ENABLED = $00020; + HEAP_FREE_CHECKING_ENABLED = $00040; + HEAP_DISABLE_COALESCE_ON_FREE = $00080; + HEAP_CREATE_ALIGN_16 = $10000; + HEAP_CREATE_ENABLE_TRACING = $20000; + HEAP_MAXIMUM_TAG = $00FFF; + HEAP_PSEUDO_TAG_FLAG = $08000; + HEAP_TAG_SHIFT = 16 ; + +{$DEFINE USE_PROCESS_HEAP} + +var + HeapHandle: THandle; + {* Global handle to the heap. Do not change it! } + + HeapFlags: DWORD = 0; + {* Possible flags are: + HEAP_GENERATE_EXCEPTIONS - system will raise an exception to indicate a + function failure, such as an out-of-memory + condition, instead of returning NULL. + HEAP_NO_SERIALIZE - mutual exclusion will not be used while the HeapAlloc + function is accessing the heap. Be careful! + Not recommended for multi-thread applications. + But faster. + HEAP_ZERO_MEMORY - obviously. (Slower!) + } + + { Note from MSDN: + The granularity of heap allocations in Win32 is 16 bytes. So if you + request a global memory allocation of 1 byte, the heap returns a pointer + to a chunk of memory, guaranteeing that the 1 byte is available. Chances + are, 16 bytes will actually be available because the heap cannot allocate + less than 16 bytes at a time. + } + +function DfltGetMem(size: Integer): Pointer; +// Allocate memory block. +begin + Result := HeapAlloc( HeapHandle, HeapFlags, size ); +end; + +function DfltFreeMem(p: Pointer): Integer; +// Deallocate memory block. +begin + Result := Integer( not HeapFree( HeapHandle, HeapFlags and HEAP_NO_SERIALIZE, + p ) ); +end; + +function DfltReallocMem(p: Pointer; size: Integer): Pointer; +// Resize memory block. +begin + Result := HeapRealloc( HeapHandle, HeapFlags and (HEAP_NO_SERIALIZE and + HEAP_GENERATE_EXCEPTIONS and HEAP_ZERO_MEMORY), + // (Prevent using flag HEAP_REALLOC_IN_PLACE_ONLY here - to allow + // system to move the block if necessary). + p, size ); +end; + +//////////////////////////////////////////// end of HeapMM + + +{$IFDEF LINUX} +function SysGetMem(Size: Integer): Pointer; +begin + Result := __malloc(size); +end; + +function SysFreeMem(P: Pointer): Integer; +begin + __free(P); + Result := 0; +end; + +function SysReallocMem(P: Pointer; Size: Integer): Pointer; +begin + Result := __realloc(P, Size); +end; + +{$ENDIF} + +{X- by default, system memory allocation routines (API calls) + are used. To use Inprise's memory manager (Delphi standard) + call UseDelphiMemoryManager procedure. } +var + MemoryManager: TMemoryManager = ( + GetMem: DfltGetMem; + FreeMem: DfltFreeMem; + ReallocMem: DfltReallocMem); + +const + DelphiMemoryManager: TMemoryManager = ( + GetMem: SysGetMem; + FreeMem: SysFreeMem; + ReallocMem: SysReallocMem); + +procedure UseDelphiMemoryManager; +begin + IsMemoryManagerSet := IsDelphiMemoryManagerSet; + SetMemoryManager( DelphiMemoryManager ); +end; +{X+} + + +{$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 debug_init; external; +procedure debug_print; external; +procedure debug_class_enabled; external; +procedure debug_continue; external; +{$ENDIF} +{$ENDIF} + +{X}{$IFDEF MSWINDOWS} +{X}function _GetMem(Size: Integer): Pointer; +{X}asm +{X} TEST EAX,EAX +{X} JE @@1 +{X} CALL MemoryManager.GetMem +{X} OR EAX,EAX +{X} JE @@2 +{X}@@1: RET +{X}@@2: MOV AL,reOutOfMemory +{X} JMP Error +{X}end; +{X}{$ELSE} +function _GetMem(Size: Integer): Pointer; +{$IF Defined(DEBUG) and Defined(LINUX)} +var + Signature: PLongInt; +{$IFEND} +begin + if Size > 0 then + begin +{$IF Defined(DEBUG) and Defined(LINUX)} + Signature := PLongInt(MemoryManager.GetMem(Size + 4)); + if Signature = nil then + Error(reOutOfMemory); + Signature^ := 0; + Result := Pointer(LongInt(Signature) + 4); +{$ELSE} + Result := MemoryManager.GetMem(Size); + if Result = nil then + Error(reOutOfMemory); +{$IFEND} + end + else + Result := nil; +end; +{X}{$ENDIF MSWINDOWS} + + +const + FreeMemorySignature = Longint($FBEEFBEE); + +{X}{$IFDEF MSWINDOWS} +{X}function _FreeMem(P: Pointer): Integer; +{X}asm +{X} TEST EAX,EAX +{X} JE @@1 +{X} CALL MemoryManager.FreeMem +{X} OR EAX,EAX +{X} JNE @@2 +{X}@@1: RET +{X}@@2: MOV AL,reInvalidPtr +{X} JMP Error +{X}end; +{X}{$ELSE} +function _FreeMem(P: Pointer): Integer; +{$IF Defined(DEBUG) and Defined(LINUX)} +var + Signature: PLongInt; +{$IFEND} +begin + if P <> nil then + begin +{$IF Defined(DEBUG) and Defined(LINUX)} + Signature := PLongInt(LongInt(P) - 4); + if Signature^ <> 0 then + Error(reInvalidPtr); + Signature^ := FreeMemorySignature; + Result := MemoryManager.Freemem(Pointer(Signature)); +{$ELSE} + Result := MemoryManager.FreeMem(P); +{$IFEND} + if Result <> 0 then + Error(reInvalidPtr); + end + else + Result := 0; +end; +{X}{$ENDIF MSWINDOWS} + +{$IFDEF LINUX} +function _ReallocMem(var P: Pointer; NewSize: Integer): Pointer; +{$IFDEF DEBUG} +var + Temp: Pointer; +{$ENDIF} +begin + if P <> nil then + begin +{$IFDEF DEBUG} + Temp := Pointer(LongInt(P) - 4); + if NewSize > 0 then + begin + Temp := MemoryManager.ReallocMem(Temp, NewSize + 4); + Result := Pointer(LongInt(Temp) + 4); + end + else + begin + MemoryManager.FreeMem(Temp); + Result := nil; + end; +{$ELSE} + if NewSize > 0 then + begin + Result := MemoryManager.ReallocMem(P, NewSize); + end + else + begin + MemoryManager.FreeMem(P); + Result := nil; + end; +{$ENDIF} + P := Result; + end else + begin + Result := _GetMem(NewSize); + P := Result; + end; +end; +{$ELSEIF Defined(MSWINDOWS)} +function _ReallocMem(var P: Pointer; NewSize: Integer): Pointer; +asm + MOV ECX,[EAX] + TEST ECX,ECX + JE @@alloc + TEST EDX,EDX + JE @@free +@@resize: + PUSH EAX + MOV EAX,ECX + CALL MemoryManager.ReallocMem + POP ECX + OR EAX,EAX + JE @@allocError + MOV [ECX],EAX + RET +@@freeError: + MOV AL,reInvalidPtr + JMP Error +@@free: + MOV [EAX],EDX + MOV EAX,ECX + CALL MemoryManager.FreeMem + OR EAX,EAX + JNE @@freeError + RET +@@allocError: + MOV AL,reOutOfMemory + JMP Error +@@alloc: + TEST EDX,EDX + JE @@exit + PUSH EAX + MOV EAX,EDX + CALL MemoryManager.GetMem + POP ECX + OR EAX,EAX + JE @@allocError + MOV [ECX],EAX +@@exit: +end; +{$IFEND} + +procedure GetMemoryManager(var MemMgr: TMemoryManager); +begin + MemMgr := MemoryManager; +end; + +procedure SetMemoryManager(const MemMgr: TMemoryManager); +begin + MemoryManager := MemMgr; +end; + +//{X} - function is replaced with pointer to one. +// function IsMemoryManagerSet: Boolean; +function IsDelphiMemoryManagerSet: Boolean; +begin + with MemoryManager do + Result := (@GetMem <> @SysGetMem) or (@FreeMem <> @SysFreeMem) or + (@ReallocMem <> @SysReallocMem); +end; + +{X+ always returns False. Initial handler for IsMemoryManagerSet } +function MemoryManagerNotUsed : Boolean; +begin + Result := False; +end; +{X-} + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure GetUnwinder(var Dest: TUnwinder); +begin + Dest := Unwinder; +end; + +procedure SetUnwinder(const NewUnwinder: TUnwinder); +begin + Unwinder := NewUnwinder; +end; + +function IsUnwinderSet: Boolean; +begin + with Unwinder do + Result := (@RaiseException <> @_BorUnwind_RaiseException) or + (@RegisterIPLookup <> @_BorUnwind_RegisterIPLookup) or + (@UnregisterIPLookup <> @_BorUnwind_UnregisterIPLookup) or + (@DelphiLookup <> @_BorUnwind_DelphiLookup); +end; + +procedure InitUnwinder; +var + Addr: Pointer; +begin + { + We look to see if we can find a dynamic version of the unwinder. This will + be the case if the application used Unwind.pas. If it is present, then we + fire it up. Otherwise, we use our static copy. + } + Addr := dlsym(0, '_BorUnwind_RegisterIPLookup'); + if Addr <> nil then + begin + Unwinder.RegisterIPLookup := Addr; + Addr := dlsym(0, '_BorUnwind_UnregisterIPLookup'); + Unwinder.UnregisterIPLookup := Addr; + Addr := dlsym(0, '_BorUnwind_RaiseException'); + Unwinder.RaiseException := Addr; + Addr := dlsym(0, '_BorUnwind_DelphiLookup'); + Unwinder.DelphiLookup := Addr; + Addr := dlsym(0, '_BorUnwind_ClosestHandler'); + Unwinder.ClosestHandler := Addr; + end + else + begin + dlerror; // clear error state; dlsym doesn't + Unwinder.RegisterIPLookup := _BorUnwind_RegisterIPLookup; + Unwinder.DelphiLookup := _BorUnwind_DelphiLookup; + Unwinder.UnregisterIPLookup := _BorUnwind_UnregisterIPLookup; + Unwinder.RaiseException := _BorUnwind_RaiseException; + Unwinder.ClosestHandler := _BorUnwind_ClosestDelphiHandler; + end; +end; + +function SysClosestDelphiHandler(Context: Pointer): LongWord; +begin + if not Assigned(Unwinder.ClosestHandler) then + InitUnwinder; + Result := Unwinder.ClosestHandler(Context); +end; + +function SysRegisterIPLookup(StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; +begin +// xxx + if not Assigned(Unwinder.RegisterIPLookup) then + begin + InitUnwinder; +// Unwinder.RegisterIPLookup := UnwindRegisterIPLookup; +// Unwinder.DelphiLookup := UnwindDelphiLookup; + end; + Result := Unwinder.RegisterIPLookup(@Unwinder.DelphiLookup, StartAddr, EndAddr, Context, GOT); +end; + +procedure SysUnregisterIPLookup(StartAddr: LongInt); +begin +// if not Assigned(Unwinder.UnregisterIPLookup) then +// Unwinder.UnregisterIPLookup := UnwindUnregisterIPLookup; + Unwinder.UnregisterIPLookup(StartAddr); +end; + +function SysRaiseException(Exc: Pointer): LongBool; export; +begin +// if not Assigned(Unwinder.RaiseException) then +// Unwinder.RaiseException := UnwindRaiseException; + Result := Unwinder.RaiseException(Exc); +end; + +const + MAX_NESTED_EXCEPTIONS = 16; +{$ENDIF} + +threadvar +{$IFDEF PC_MAPPED_EXCEPTIONS} + ExceptionObjects: array[0..MAX_NESTED_EXCEPTIONS-1] of TRaisedException; + ExceptionObjectCount: Integer; + OSExceptionsBlocked: Integer; +{$ELSE} + RaiseListPtr: pointer; +{$ENDIF} + InOutRes: Integer; + +{$IFDEF PUREPASCAL} +var + notimpl: array [0..15] of Char = 'not implemented'#10; + +procedure NotImplemented; +begin + __write (2, @notimpl, 16); + Halt; +end; +{$ENDIF} + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure BlockOSExceptions; +asm + PUSH EAX + PUSH EDX + CALL SysInit.@GetTLS + MOV [EAX].OSExceptionsBlocked, 1 + POP EDX + POP EAX +end; + +procedure UnblockOSExceptions; +asm + PUSH EAX + CALL SysInit.@GetTLS + MOV [EAX].OSExceptionsBlocked, 0 + POP EAX +end; + +function AreOSExceptionsBlocked: Boolean; +asm + CALL SysInit.@GetTLS + MOV EAX, [EAX].OSExceptionsBlocked +end; + +const + TRAISEDEXCEPTION_SIZE = SizeOf(TRaisedException); + +function CurrentException: PRaisedException; +asm + CALL SysInit.@GetTLS + LEA EDX, [EAX].ExceptionObjects + MOV EAX, [EAX].ExceptionObjectCount + OR EAX, EAX + JE @@Done + DEC EAX + IMUL EAX, TRAISEDEXCEPTION_SIZE + ADD EAX, EDX +@@Done: +end; + +function AllocateException(Exception: Pointer; ExceptionAddr: Pointer): PRaisedException; +asm + PUSH EAX + PUSH EDX + CALL SysInit.@GetTLS + CMP [EAX].ExceptionObjectCount, MAX_NESTED_EXCEPTIONS-1 + JE @@TooManyNestedExceptions + INC [EAX].ExceptionObjectCount + CALL CurrentException + POP EDX + POP ECX + MOV [EAX].TRaisedException.ExceptObject, ECX + MOV [EAX].TRaisedException.ExceptionAddr, EDX + MOV [EAX].TRaisedException.RefCount, 0 + MOV [EAX].TRaisedException.HandlerEBP, $FFFFFFFF + MOV [EAX].TRaisedException.Flags, 0 + RET +@@TooManyNestedExceptions: + MOV EAX, 231 + JMP _RunError +end; + +{ + 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; +asm + CALL CurrentException + OR EAX, EAX + JE @@Error + { EAX -> the TRaisedException } + XOR ECX, ECX + { If the exception object has been referenced, we don't return it. } + CMP [EAX].TRaisedException.RefCount, 0 + JA @@GotObject + MOV ECX, [EAX].TRaisedException.ExceptObject +@@GotObject: + PUSH ECX + CALL SysInit.@GetTLS + POP ECX + DEC [EAX].ExceptionObjectCount + MOV EAX, ECX + RET +@@Error: + { Some kind of internal error } + JMP _Run0Error +end; + +function AcquireExceptionObject: Pointer; +asm + CALL CurrentException + OR EAX, EAX + JE @@Error + INC [EAX].TRaisedException.RefCount + MOV EAX, [EAX].TRaisedException.ExceptObject + RET +@@Error: + { This happens if there is no exception pending } + JMP _Run0Error +end; + +procedure ReleaseExceptionObject; +asm + CALL CurrentException + OR EAX, EAX + JE @@Error + CMP [EAX].TRaisedException.RefCount, 0 + JE @@Error + DEC [EAX].TRaisedException.RefCount + RET +@@Error: + +{ + This happens if there is no exception pending, or + if the reference count on a pending exception is + zero. +} + JMP _Run0Error +end; + +function ExceptObject: TObject; +var + Exc: PRaisedException; +begin + Exc := CurrentException; + if Exc <> nil then + Result := TObject(Exc^.ExceptObject) + else + Result := nil; +end; + +{ Return current exception address } + +function ExceptAddr: Pointer; +var + Exc: PRaisedException; +begin + Exc := CurrentException; + if Exc <> nil then + Result := Exc^.ExceptionAddr + else + Result := nil; +end; +{$ELSE} {not PC_MAPPED_EXCEPTIONS} + +function ExceptObject: TObject; +begin + if RaiseListPtr <> nil then + Result := PRaiseFrame(RaiseListPtr)^.ExceptObject + else + Result := nil; +end; + +{ Return current exception address } + +function ExceptAddr: Pointer; +begin + if RaiseListPtr <> nil then + Result := PRaiseFrame(RaiseListPtr)^.ExceptAddr + else + Result := nil; +end; + + +function AcquireExceptionObject: Pointer; +begin + if RaiseListPtr <> nil then + begin + Result := PRaiseFrame(RaiseListPtr)^.ExceptObject; + PRaiseFrame(RaiseListPtr)^.ExceptObject := nil; + end + else + Result := nil; +end; + +procedure ReleaseExceptionObject; +begin +end; + +function RaiseList: Pointer; +begin + Result := RaiseListPtr; +end; + +function SetRaiseList(NewPtr: Pointer): Pointer; +asm + PUSH EAX + CALL SysInit.@GetTLS + MOV EDX, [EAX].RaiseListPtr + POP [EAX].RaiseListPtr + MOV EAX, EDX +end; +{$ENDIF} + +{ ----------------------------------------------------- } +{ local functions & procedures of the system unit } +{ ----------------------------------------------------- } + +procedure RunErrorAt(ErrCode: Integer; ErrorAtAddr: Pointer); +begin + ErrorAddr := ErrorAtAddr; + _Halt(ErrCode); +end; + +procedure ErrorAt(ErrorCode: Byte; ErrorAddr: Pointer); + +const + reMap: array [TRunTimeError] of Byte = ( + 0, + 203, { reOutOfMemory } + 204, { reInvalidPtr } + 200, { reDivByZero } + 201, { reRangeError } +{ 210 abstract error } + 215, { reIntOverflow } + 207, { reInvalidOp } + 200, { reZeroDivide } + 205, { reOverflow } + 206, { reUnderflow } + 219, { reInvalidCast } + 216, { Access violation } + 202, { Stack overflow } + 217, { Control-C } + 218, { Privileged instruction } + 220, { Invalid variant type cast } + 221, { Invalid variant operation } + 222, { No variant method call dispatcher } + 223, { Cannot create variant array } + 224, { Variant does not contain an array } + 225, { Variant array bounds error } +{ 226 thread init failure } + 227, { reAssertionFailed } + 0, { reExternalException not used here; in SysUtils } + 228, { reIntfCastError } + 229 { reSafeCallError } +{ 230 Reserved by the compiler for unhandled exceptions } +{ 231 Too many nested exceptions } +{ 232 Fatal signal raised on a non-Delphi thread }); + +begin + errorCode := errorCode and 127; + if Assigned(ErrorProc) then + ErrorProc(errorCode, ErrorAddr); + if errorCode = 0 then + errorCode := InOutRes + else if errorCode <= Byte(High(TRuntimeError)) then + errorCode := reMap[TRunTimeError(errorCode)]; + RunErrorAt(errorCode, ErrorAddr); +end; + +procedure Error(errorCode: TRuntimeError); +asm + AND EAX,127 + MOV EDX,[ESP] + JMP ErrorAt +end; + +procedure __IOTest; +asm + PUSH EAX + PUSH EDX + PUSH ECX + CALL SysInit.@GetTLS + CMP [EAX].InOutRes,0 + POP ECX + POP EDX + POP EAX + JNE @error + RET +@error: + XOR EAX,EAX + JMP Error +end; + +procedure SetInOutRes(NewValue: Integer); +begin + InOutRes := NewValue; +end; + +procedure InOutError; +begin + SetInOutRes(GetLastError); +end; + +procedure ChDir(const S: string); +begin + ChDir(PChar(S)); +end; + +procedure ChDir(P: PChar); +begin +{$IFDEF MSWINDOWS} + if not SetCurrentDirectory(P) then +{$ENDIF} +{$IFDEF LINUX} + if __chdir(P) <> 0 then +{$ENDIF} + InOutError; +end; + +procedure _Copy{ s : ShortString; index, count : Integer ) : ShortString}; +asm +{ ->EAX Source string } +{ EDX index } +{ ECX count } +{ [ESP+4] Pointer to result string } + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,[ESP+8+4] + + XOR EAX,EAX + OR AL,[ESI] + JZ @@srcEmpty + +{ limit index to satisfy 1 <= index <= Length(src) } + + TEST EDX,EDX + JLE @@smallInx + CMP EDX,EAX + JG @@bigInx +@@cont1: + +{ limit count to satisfy 0 <= count <= Length(src) - index + 1 } + + SUB EAX,EDX { calculate Length(src) - index + 1 } + INC EAX + TEST ECX,ECX + JL @@smallCount + CMP ECX,EAX + JG @@bigCount +@@cont2: + + ADD ESI,EDX + + MOV [EDI],CL + INC EDI + REP MOVSB + JMP @@exit + +@@smallInx: + MOV EDX,1 + JMP @@cont1 +@@bigInx: +{ MOV EDX,EAX + JMP @@cont1 } +@@smallCount: + XOR ECX,ECX + JMP @@cont2 +@@bigCount: + MOV ECX,EAX + JMP @@cont2 +@@srcEmpty: + MOV [EDI],AL +@@exit: + POP EDI + POP ESI + RET 4 +end; + +procedure _Delete{ var s : openstring; index, count : Integer }; +asm +{ ->EAX Pointer to s } +{ EDX index } +{ ECX count } + + PUSH ESI + PUSH EDI + + MOV EDI,EAX + + XOR EAX,EAX + MOV AL,[EDI] + +{ if index not in [1 .. Length(s)] do nothing } + + TEST EDX,EDX + JLE @@exit + CMP EDX,EAX + JG @@exit + +{ limit count to [0 .. Length(s) - index + 1] } + + TEST ECX,ECX + JLE @@exit + SUB EAX,EDX { calculate Length(s) - index + 1 } + INC EAX + CMP ECX,EAX + JLE @@1 + MOV ECX,EAX +@@1: + SUB [EDI],CL { reduce Length(s) by count } + ADD EDI,EDX { point EDI to first char to be deleted } + LEA ESI,[EDI+ECX] { point ESI to first char to be preserved } + SUB EAX,ECX { #chars = Length(s) - index + 1 - count } + MOV ECX,EAX + + REP MOVSB + +@@exit: + POP EDI + POP ESI +end; + +procedure _LGetDir(D: Byte; var S: string); +{$IFDEF MSWINDOWS} +var + Drive: array[0..3] of Char; + DirBuf, SaveBuf: array[0..MAX_PATH] of Char; +begin + if D <> 0 then + begin + Drive[0] := Chr(D + Ord('A') - 1); + Drive[1] := ':'; + Drive[2] := #0; + GetCurrentDirectory(SizeOf(SaveBuf), SaveBuf); + SetCurrentDirectory(Drive); + end; + GetCurrentDirectory(SizeOf(DirBuf), DirBuf); + if D <> 0 then SetCurrentDirectory(SaveBuf); + S := DirBuf; +{$ENDIF} +{$IFDEF LINUX} +var + DirBuf: array[0..MAX_PATH] of Char; +begin + __getcwd(DirBuf, sizeof(DirBuf)); + S := string(DirBuf); +{$ENDIF} +end; + +procedure _SGetDir(D: Byte; var S: ShortString); +var + L: string; +begin + _LGetDir(D, L); + S := L; +end; + +procedure _Insert{ source : ShortString; var s : openstring; index : Integer }; +asm +{ ->EAX Pointer to source string } +{ EDX Pointer to destination string } +{ ECX Length of destination string } +{ [ESP+4] Index } + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH ECX + MOV ECX,[ESP+16+4] + SUB ESP,512 { VAR buf: ARRAY [0..511] of Char } + + MOV EBX,EDX { save pointer to s for later } + MOV ESI,EDX + + XOR EDX,EDX + MOV DL,[ESI] + INC ESI + +{ limit index to [1 .. Length(s)+1] } + + INC EDX + TEST ECX,ECX + JLE @@smallInx + CMP ECX,EDX + JG @@bigInx +@@cont1: + DEC EDX { EDX = Length(s) } + { EAX = Pointer to src } + { ESI = EBX = Pointer to s } + { ECX = Index } + +{ copy index-1 chars from s to buf } + + MOV EDI,ESP + DEC ECX + SUB EDX,ECX { EDX = remaining length of s } + REP MOVSB + +{ copy Length(src) chars from src to buf } + + XCHG EAX,ESI { save pointer into s, point ESI to src } + MOV CL,[ESI] { ECX = Length(src) (ECX was zero after rep) } + INC ESI + REP MOVSB + +{ copy remaining chars of s to buf } + + MOV ESI,EAX { restore pointer into s } + MOV ECX,EDX { copy remaining bytes of s } + REP MOVSB + +{ calculate total chars in buf } + + SUB EDI,ESP { length = bufPtr - buf } + MOV ECX,[ESP+512] { ECX = Min(length, destLength) } +{ MOV ECX,[EBP-16] }{ ECX = Min(length, destLength) } + CMP ECX,EDI + JB @@1 + MOV ECX,EDI +@@1: + MOV EDI,EBX { Point EDI to s } + MOV ESI,ESP { Point ESI to buf } + MOV [EDI],CL { Store length in s } + INC EDI + REP MOVSB { Copy length chars to s } + JMP @@exit + +@@smallInx: + MOV ECX,1 + JMP @@cont1 +@@bigInx: + MOV ECX,EDX + JMP @@cont1 + +@@exit: + ADD ESP,512+4 + POP EDI + POP ESI + POP EBX + RET 4 +end; + +function IOResult: Integer; +begin + Result := InOutRes; + InOutRes := 0; +end; + +procedure MkDir(const S: string); +begin + MkDir(PChar(s)); +end; + +procedure MkDir(P: PChar); +begin +{$IFDEF MSWINDOWS} + if not CreateDirectory(P, 0) then +{$ENDIF} +{$IFDEF LINUX} + if __mkdir(P, -1) <> 0 then +{$ENDIF} + InOutError; +end; + +procedure Move( const Source; var Dest; count : Integer ); +{$IFDEF PUREPASCAL} +var + S, D: PChar; + I: Integer; +begin + S := PChar(@Source); + D := PChar(@Dest); + if S = D then Exit; + if Cardinal(D) > Cardinal(S) then + for I := count-1 downto 0 do + D[I] := S[I] + else + for I := 0 to count-1 do + D[I] := S[I]; +end; +{$ELSE} +asm +{ ->EAX Pointer to source } +{ EDX Pointer to destination } +{ ECX Count } + +(*{X-} // original code. + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + MOV EAX,ECX + + CMP EDI,ESI + JA @@down + JE @@exit + + SAR ECX,2 { copy count DIV 4 dwords } + JS @@exit + + REP MOVSD + + MOV ECX,EAX + AND ECX,03H + REP MOVSB { copy count MOD 4 bytes } + JMP @@exit + +@@down: + LEA ESI,[ESI+ECX-4] { point ESI to last dword of source } + LEA EDI,[EDI+ECX-4] { point EDI to last dword of dest } + + SAR ECX,2 { copy count DIV 4 dwords } + JS @@exit + STD + REP MOVSD + + MOV ECX,EAX + AND ECX,03H { copy count MOD 4 bytes } + ADD ESI,4-1 { point to last byte of rest } + ADD EDI,4-1 + REP MOVSB + CLD +@@exit: + POP EDI + POP ESI +*){X+} +//--------------------------------------- +(* {X+} // Let us write smaller: + JCXZ @@fin + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + MOV EAX,ECX + + AND ECX,3 { copy count mod 4 dwords } + + CMP EDI,ESI + JE @@exit + JA @@up + +//down: + LEA ESI,[ESI+EAX-1] { point ESI to last byte of source } + LEA EDI,[EDI+EAX-1] { point EDI to last byte of dest } + STD + + CMP EAX, 4 + JL @@up + ADD ECX, 3 { move 3 bytes more to correct pos } + +@@up: + REP MOVSB + + SAR EAX, 2 + JS @@exit + + MOV ECX, EAX + REP MOVSD + +@@exit: + CLD + POP EDI + POP ESI + +@@fin: +*) {X-} +//--------------------------------------- +{X+} // And now, let us write speedy: + CMP ECX, 4 + JGE @@long + JCXZ @@fin + + CMP EAX, EDX + JE @@fin + + PUSH ESI + PUSH EDI + MOV ESI, EAX + MOV EDI, EDX + JA @@short_up + + LEA ESI,[ESI+ECX-1] { point ESI to last byte of source } + LEA EDI,[EDI+ECX-1] { point EDI to last byte of dest } + STD + +@@short_up: + REP MOVSB + JMP @@exit_up + +@@long: + CMP EAX, EDX + JE @@fin + + PUSH ESI + PUSH EDI + MOV ESI, EAX + MOV EDI, EDX + MOV EAX, ECX + + JA @@long_up + + { + SAR ECX, 2 + JS @@exit + + LEA ESI,[ESI+EAX-4] + LEA EDI,[EDI+EAX-4] + STD + REP MOVSD + + MOV ECX, EAX + MOV EAX, 3 + AND ECX, EAX + ADD ESI, EAX + ADD EDI, EAX + REP MOVSB + } // let's do it in other order - faster if data are aligned... + + AND ECX, 3 + LEA ESI,[ESI+EAX-1] + LEA EDI,[EDI+EAX-1] + STD + REP MOVSB + + SAR EAX, 2 + //JS @@exit // why to test this? but what does PC do? + MOV ECX, EAX + MOV EAX, 3 + SUB ESI, EAX + SUB EDI, EAX + REP MOVSD + +@@exit_up: + CLD + //JMP @@exit + DEC ECX // the same - loosing 2 tacts... but conveyer! + +@@long_up: + SAR ECX, 2 + JS @@exit + + REP MOVSD + + AND EAX, 3 + MOV ECX, EAX + REP MOVSB + +@@exit: + POP EDI + POP ESI + +@@fin: +{X-} +end; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function GetParamStr(P: PChar; var Param: string): PChar; +var + i, Len: Integer; + Start, S, Q: PChar; +begin + while True do + begin + while (P[0] <> #0) and (P[0] <= ' ') do + P := CharNext(P); + if (P[0] = '"') and (P[1] = '"') then Inc(P, 2) else Break; + end; + Len := 0; + Start := P; + while P[0] > ' ' do + begin + if P[0] = '"' then + begin + P := CharNext(P); + while (P[0] <> #0) and (P[0] <> '"') do + begin + Q := CharNext(P); + Inc(Len, Q - P); + P := Q; + end; + if P[0] <> #0 then + P := CharNext(P); + end + else + begin + Q := CharNext(P); + Inc(Len, Q - P); + P := Q; + end; + end; + + SetLength(Param, Len); + + P := Start; + S := Pointer(Param); + i := 0; + while P[0] > ' ' do + begin + if P[0] = '"' then + begin + P := CharNext(P); + while (P[0] <> #0) and (P[0] <> '"') do + begin + Q := CharNext(P); + while P < Q do + begin + S[i] := P^; + Inc(P); + Inc(i); + end; + end; + if P[0] <> #0 then P := CharNext(P); + end + else + begin + Q := CharNext(P); + while P < Q do + begin + S[i] := P^; + Inc(P); + Inc(i); + end; + end; + end; + + Result := P; +end; +{$ENDIF} + +function ParamCount: Integer; +{$IFDEF MSWINDOWS} +var + P: PChar; + S: string; +begin + Result := 0; + P := GetParamStr(GetCommandLine, S); + while True do + begin + P := GetParamStr(P, S); + if S = '' then Break; + Inc(Result); + end; +{$ENDIF} +{$IFDEF LINUX} +begin + if ArgCount > 1 then + Result := ArgCount - 1 + else Result := 0; +{$ENDIF} +end; + +type + PCharArray = array[0..0] of PChar; + +function ParamStr(Index: Integer): string; +{$IFDEF MSWINDOWS} +var + P: PChar; + Buffer: array[0..260] of Char; +begin + Result := ''; + if Index = 0 then + SetString(Result, Buffer, GetModuleFileName(0, Buffer, SizeOf(Buffer))) + else + begin + P := GetCommandLine; + while True do + begin + P := GetParamStr(P, Result); + if (Index = 0) or (Result = '') then Break; + Dec(Index); + end; + end; +{$ENDIF} +{$IFDEF LINUX} +begin + if Index < ArgCount then + Result := PCharArray(ArgValues^)[Index] + else + Result := ''; +{$ENDIF} +end; + +function Pos(const substr, str: AnsiString): Integer; overload; +asm + push ebx + push esi + add esp, -16 + test edx, edx + jz @NotFound + test eax, eax + jz @NotFound + mov esi, [edx-4] //Length(Str) + mov ebx, [eax-4] //Length(Substr) + cmp esi, ebx + jl @NotFound + test ebx, ebx + jle @NotFound + dec ebx + add esi, edx + add edx, ebx + mov [esp+8], esi + add eax, ebx + mov [esp+4], edx + neg ebx + movzx ecx, byte ptr [eax] + mov [esp], ebx + jnz @FindString + + sub esi, 2 + mov [esp+12], esi + +@FindChar2: + cmp cl, [edx] + jz @Matched0ch + cmp cl, [edx+1] + jz @Matched1ch + add edx, 2 + cmp edx, [esp+12] + jb @FindChar4 + cmp edx, [esp+8] + jb @FindChar2 +@NotFound: + xor eax, eax + jmp @Exit0ch + +@FindChar4: + cmp cl, [edx] + jz @Matched0ch + cmp cl, [edx+1] + jz @Matched1ch + cmp cl, [edx+2] + jz @Matched2ch + cmp cl, [edx+3] + jz @Matched3ch + add edx, 4 + cmp edx, [esp+12] + jb @FindChar4 + cmp edx, [esp+8] + jb @FindChar2 + xor eax, eax + jmp @Exit0ch + +@Matched2ch: + add edx, 2 +@Matched0ch: + inc edx + mov eax, edx + sub eax, [esp+4] +@Exit0ch: + add esp, 16 + pop esi + pop ebx + ret + +@Matched3ch: + add edx, 2 +@Matched1ch: + add edx, 2 + xor eax, eax + cmp edx, [esp+8] + ja @Exit1ch + mov eax, edx + sub eax, [esp+4] +@Exit1ch: + add esp, 16 + pop esi + pop ebx + ret + +@FindString4: + cmp cl, [edx] + jz @Test0 + cmp cl, [edx+1] + jz @Test1 + cmp cl, [edx+2] + jz @Test2 + cmp cl, [edx+3] + jz @Test3 + add edx, 4 + cmp edx, [esp+12] + jb @FindString4 + cmp edx, [esp+8] + jb @FindString2 + xor eax, eax + jmp @Exit1 + +@FindString: + sub esi, 2 + mov [esp+12], esi +@FindString2: + cmp cl, [edx] + jz @Test0 +@AfterTest0: + cmp cl, [edx+1] + jz @Test1 +@AfterTest1: + add edx, 2 + cmp edx, [esp+12] + jb @FindString4 + cmp edx, [esp+8] + jb @FindString2 + xor eax, eax + jmp @Exit1 + +@Test3: + add edx, 2 +@Test1: + mov esi, [esp] +@Loop1: + movzx ebx, word ptr [esi+eax] + cmp bx, word ptr [esi+edx+1] + jnz @AfterTest1 + add esi, 2 + jl @Loop1 + add edx, 2 + xor eax, eax + cmp edx, [esp+8] + ja @Exit1 +@RetCode1: + mov eax, edx + sub eax, [esp+4] +@Exit1: + add esp, 16 + pop esi + pop ebx + ret + +@Test2: + add edx,2 +@Test0: + mov esi, [esp] +@Loop0: + movzx ebx, word ptr [esi+eax] + cmp bx, word ptr [esi+edx] + jnz @AfterTest0 + add esi, 2 + jl @Loop0 + inc edx +@RetCode0: + mov eax, edx + sub eax, [esp+4] + add esp, 16 + pop esi + pop ebx +end; + +function Pos(const substr, str: WideString): Integer; overload; +asm +{ ->EAX Pointer to substr } +{ EDX Pointer to string } +{ <-EAX Position of substr in str or 0 } + + TEST EAX,EAX + JE @@noWork + + TEST EDX,EDX + JE @@stringEmpty + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX { Point ESI to substr } + MOV EDI,EDX { Point EDI to s } + + MOV ECX,[EDI-4] { ECX = Length(s) } + SHR ECX,1 + + PUSH EDI { remember s position to calculate index } + + MOV EDX,[ESI-4] { EDX = Length(substr) } + SHR EDX,1 + + DEC EDX { EDX = Length(substr) - 1 } + JS @@fail { < 0 ? return 0 } + MOV AX,[ESI] { AL = first char of substr } + ADD ESI,2 { Point ESI to 2'nd char of substr } + + SUB ECX,EDX { #positions in s to look at } + { = Length(s) - Length(substr) + 1 } + JLE @@fail +@@loop: + REPNE SCASW + JNE @@fail + MOV EBX,ECX { save outer loop counter } + PUSH ESI { save outer loop substr pointer } + PUSH EDI { save outer loop s pointer } + + MOV ECX,EDX + REPE CMPSW + POP EDI { restore outer loop s pointer } + POP ESI { restore outer loop substr pointer } + JE @@found + MOV ECX,EBX { restore outer loop counter } + JMP @@loop + +@@fail: + POP EDX { get rid of saved s pointer } + XOR EAX,EAX + JMP @@exit + +@@stringEmpty: + XOR EAX,EAX + JMP @@noWork + +@@found: + POP EDX { restore pointer to first char of s } + MOV EAX,EDI { EDI points of char after match } + SUB EAX,EDX { the difference is the correct index } + SHR EAX,1 +@@exit: + POP EDI + POP ESI + POP EBX +@@noWork: +end; + +// 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); +begin + Byte(s^[0]) := newLength; // should also fill new space +end; + +procedure _SetString(s: PShortString; buffer: PChar; len: Byte); +begin + Byte(s^[0]) := len; + if buffer <> nil then + Move(buffer^, s^[1], len); +end; + +procedure Randomize; +{$IFDEF LINUX} +begin + RandSeed := _time(nil); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +var + Counter: Int64; +begin + if QueryPerformanceCounter(Counter) then + RandSeed := Counter + else + RandSeed := GetTickCount; +end; +{$ENDIF} + +function Random(const ARange: Integer): Integer; +{$IF DEFINED(CPU386)} +asm +{ ->EAX Range } +{ <-EAX Result } + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX + MOV ECX,[EBX].OFFSET RandSeed + IMUL EDX,[ECX],08088405H + INC EDX + MOV [ECX],EDX +{$ELSE} + XOR EBX, EBX + IMUL EDX,[EBX].RandSeed,08088405H + INC EDX + MOV [EBX].RandSeed,EDX +{$ENDIF} + MUL EDX + MOV EAX,EDX + POP EBX +end; +{$ELSEIF DEFINED(CLR)} +begin + InitRandom; + Result := RandomEngine.Next(ARange); +end; +{$ELSE} + {$MESSAGE ERROR 'Random(Int):Int unimplemented'} +{$IFEND} + +function Random: Extended; +{$IF DEFINED(CPU386)} +const two2neg32: double = ((1.0/$10000) / $10000); // 2^-32 +asm +{ FUNCTION _RandExt: Extended; } + + PUSH EBX +{$IFDEF PIC} + CALL GetGOT + MOV EBX,EAX + MOV ECX,[EBX].OFFSET RandSeed + IMUL EDX,[ECX],08088405H + INC EDX + MOV [ECX],EDX +{$ELSE} + XOR EBX, EBX + IMUL EDX,[EBX].RandSeed,08088405H + INC EDX + MOV [EBX].RandSeed,EDX +{$ENDIF} + + FLD [EBX].two2neg32 + PUSH 0 + PUSH EDX + FILD qword ptr [ESP] + ADD ESP,8 + FMULP ST(1), ST(0) + POP EBX +end; +{$ELSEIF DEFINED(CLR)} +begin + InitRandom; + Result := RandomEngine.NextDouble; +end; +{$ELSE} + {$MESSAGE ERROR 'Random:Extended unimplemented'} +{$IFEND} + +procedure RmDir(const S: string); +begin + RmDir(PChar(s)); +end; + +procedure RmDir(P: PChar); +begin +{$IFDEF MSWINDOWS} + if not RemoveDirectory(P) then +{$ENDIF} +{$IFDEF LINUX} + if __rmdir(P) <> 0 then +{$ENDIF} + InOutError; +end; + +function UpCase( ch : Char ) : Char; +{$IFDEF PUREPASCAL} +begin + Result := ch; + case Result of + 'a'..'z': Dec(Result, Ord('a') - Ord('A')); + end; +end; +{$ELSE} +asm +{ -> AL Character } +{ <- AL Result } + + CMP AL,'a' + JB @@exit + CMP AL,'z' + JA @@exit + SUB AL,'a' - 'A' +@@exit: +end; +{$ENDIF} + +procedure Set8087CW(NewCW: Word); +begin + Default8087CW := NewCW; + asm + FNCLEX // don't raise pending exceptions enabled by the new flags +{$IFDEF PIC} + MOV EAX,[EBX].OFFSET Default8087CW + FLDCW [EAX] +{$ELSE} + FLDCW Default8087CW +{$ENDIF} + end; +end; + +function Get8087CW: Word; +asm + PUSH 0 + FNSTCW [ESP].Word + POP EAX +end; + + +{ ----------------------------------------------------- } +{ functions & procedures that need compiler magic } +{ ----------------------------------------------------- } + +function Int(const X: Extended): Extended; +asm + FLD X + SUB ESP,4 + FNSTCW [ESP].Word // save + FNSTCW [ESP+2].Word // scratch + FWAIT + OR [ESP+2].Word, $0F00 // trunc toward zero, full precision + FLDCW [ESP+2].Word + FRNDINT + FWAIT + FLDCW [ESP].Word + ADD ESP,4 +end; + +function Frac(const X: Extended): Extended; +asm + FLD X + FLD ST(0) + SUB ESP,4 + FNSTCW [ESP].Word // save + FNSTCW [ESP+2].Word // scratch + FWAIT + OR [ESP+2].Word, $0F00 // trunc toward zero, full precision + FLDCW [ESP+2].Word + FRNDINT + FWAIT + FLDCW [ESP].Word + ADD ESP,4 + FSUB +end; + +function Exp(const X: Extended): Extended; +asm + { e**x = 2**(x*log2(e)) } + FLD X + FLDL2E { y := x*log2e; } + FMUL + FLD ST(0) { i := round(y); } + FRNDINT + FSUB ST(1), ST { f := y - i; } + FXCH ST(1) { z := 2**f } + F2XM1 + FLD1 + FADD + FSCALE { result := z * 2**i } + FSTP ST(1) +end; + +function Cos(const X: Extended): Extended; +asm + FLD X + FCOS + FWAIT +end; + +function Sin(const X: Extended): Extended; +asm + FLD X + FSIN + FWAIT +end; + +function Ln(const X: Extended): Extended; +asm + FLD X + FLDLN2 + FXCH + FYL2X + FWAIT +end; + +function ArcTan(const X: Extended): Extended; +asm + FLD X + FLD1 + FPATAN + FWAIT +end; + +function Sqrt(const X: Extended): Extended; +asm + FLD X + FSQRT + FWAIT +end; + +{ ----------------------------------------------------- } +{ functions & procedures that need compiler magic } +{ ----------------------------------------------------- } + +procedure _ROUND; +asm + { -> FST(0) Extended argument } + { <- EDX:EAX Result } + + SUB ESP,8 + FISTP qword ptr [ESP] + FWAIT + POP EAX + POP EDX +end; + +procedure _TRUNC; +asm + { -> FST(0) Extended argument } + { <- EDX:EAX Result } + + SUB ESP,12 + FNSTCW [ESP].Word // save + FNSTCW [ESP+2].Word // scratch + FWAIT + OR [ESP+2].Word, $0F00 // trunc toward zero, full precision + FLDCW [ESP+2].Word + FISTP qword ptr [ESP+4] + FWAIT + FLDCW [ESP].Word + POP ECX + POP EAX + POP EDX +end; + +procedure _AbstractError; +{$IFDEF PC_MAPPED_EXCEPTIONS} +asm + MOV EAX,210 + JMP _RunError +end; +{$ELSE} +{$IFDEF PIC} +begin + if Assigned(AbstractErrorProc) then + AbstractErrorProc; + _RunError(210); // loses return address +end; +{$ELSE} +asm + CMP AbstractErrorProc, 0 + JE @@NoAbstErrProc + CALL AbstractErrorProc + +@@NoAbstErrProc: + MOV EAX,210 + JMP _RunError +end; +{$ENDIF} +{$ENDIF} + +function TextOpen(var t: TTextRec): Integer; forward; + +function OpenText(var t: TTextRec; Mode: Word): Integer; +begin + if (t.Mode < fmClosed) or (t.Mode > fmInOut) then + Result := 102 + else + begin + if t.Mode <> fmClosed then _Close(t); + t.Mode := Mode; + if (t.Name[0] = #0) and (t.OpenFunc = nil) then // stdio + t.OpenFunc := @TextOpen; + Result := TTextIOFunc(t.OpenFunc)(t); + end; + if Result <> 0 then SetInOutRes(Result); +end; + +function _ResetText(var t: TTextRec): Integer; +begin + Result := OpenText(t, fmInput); +end; + +function _RewritText(var t: TTextRec): Integer; +begin + Result := OpenText(t, fmOutput); +end; + +function _Append(var t: TTextRec): Integer; +begin + Result := OpenText(t, fmInOut); +end; + +function TextIn(var t: TTextRec): Integer; +begin + t.BufEnd := 0; + t.BufPos := 0; +{$IFDEF LINUX} + t.BufEnd := __read(t.Handle, t.BufPtr, t.BufSize); + if Integer(t.BufEnd) = -1 then + begin + t.BufEnd := 0; + Result := GetLastError; + end + else + Result := 0; +{$ENDIF} +{$IFDEF MSWINDOWS} + if ReadFile(t.Handle, t.BufPtr^, t.BufSize, t.BufEnd, nil) = 0 then + begin + Result := GetLastError; + if Result = 109 then + Result := 0; // NT quirk: got "broken pipe"? it's really eof + end + else + Result := 0; +{$ENDIF} +end; + +function FileNOPProc(var t): Integer; +begin + Result := 0; +end; + +function TextOut(var t: TTextRec): Integer; +{$IFDEF MSWINDOWS} +var + Dummy: Cardinal; +{$ENDIF} +begin + if t.BufPos = 0 then + Result := 0 + else + begin +{$IFDEF LINUX} + if __write(t.Handle, t.BufPtr, t.BufPos) = Cardinal(-1) then +{$ENDIF} +{$IFDEF MSWINDOWS} + if WriteFile(t.Handle, t.BufPtr^, t.BufPos, Dummy, nil) = 0 then +{$ENDIF} + Result := GetLastError + else + Result := 0; + t.BufPos := 0; + end; +end; + +function InternalClose(Handle: Integer): Boolean; +begin +{$IFDEF LINUX} + Result := __close(Handle) = 0; +{$ENDIF} +{$IFDEF MSWINDOWS} + Result := CloseHandle(Handle) = 1; +{$ENDIF} +end; + +function TextClose(var t: TTextRec): Integer; +begin + t.Mode := fmClosed; + if not InternalClose(t.Handle) then + Result := GetLastError + else + Result := 0; +end; + +function TextOpenCleanup(var t: TTextRec): Integer; +begin + InternalClose(t.Handle); + t.Mode := fmClosed; + Result := GetLastError; +end; + +function TextOpen(var t: TTextRec): Integer; +{$IFDEF LINUX} +var + Flags: Integer; + Temp, I: Integer; + BytesRead: Integer; +begin + Result := 0; + t.BufPos := 0; + t.BufEnd := 0; + case t.Mode of + fmInput: // called by Reset + begin + Flags := O_RDONLY; + t.InOutFunc := @TextIn; + end; + fmOutput: // called by Rewrite + begin + Flags := O_CREAT or O_TRUNC or O_WRONLY; + t.InOutFunc := @TextOut; + end; + fmInOut: // called by Append + begin + Flags := O_APPEND or O_RDWR; + t.InOutFunc := @TextOut; + end; + else + Exit; + Flags := 0; + end; + + t.FlushFunc := @FileNOPProc; + + if t.Name[0] = #0 then // stdin or stdout + begin + t.BufPtr := @t.Buffer; + t.BufSize := sizeof(t.Buffer); + t.CloseFunc := @FileNOPProc; + if t.Mode = fmOutput then + begin + if @t = @ErrOutput then + t.Handle := STDERR_FILENO + else + t.Handle := STDOUT_FILENO; + t.FlushFunc := @TextOut; + end + else + t.Handle := STDIN_FILENO; + end + else + begin + t.CloseFunc := @TextClose; + + Temp := __open(t.Name, Flags, FileAccessRights); + if Temp = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + t.Handle := Temp; + + if t.Mode = fmInOut then // Append mode + begin + t.Mode := fmOutput; + + if (t.flags and tfCRLF) <> 0 then // DOS mode, EOF significant + begin // scan for EOF char in last 128 byte sector. + Temp := _lseek(t.Handle, 0, SEEK_END); + if Temp = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + Dec(Temp, 128); + if Temp < 0 then Temp := 0; + + if _lseek(t.Handle, Temp, SEEK_SET) = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + BytesRead := __read(t.Handle, t.BufPtr, 128); + if BytesRead = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + for I := 0 to BytesRead - 1 do + begin + if t.Buffer[I] = Char(cEOF) then + begin // truncate the file here + if _ftruncate(t.Handle, _lseek(t.Handle, I - BytesRead, SEEK_END)) = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + Break; + end; + end; + end; + end; + end; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +(* +var + OpenMode: Integer; + Flags, Std: ShortInt; + Temp: Integer; + I, BytesRead: Cardinal; + Mode: Byte; +begin + Result := 0; + if (t.Mode - fmInput) > (fmInOut - fmInput) then Exit; + Mode := t.Mode and 3; + t.BufPos := 0; + t.BufEnd := 0; + t.FlushFunc := @FileNOPProc; + + if t.Name[0] = #0 then // stdin or stdout + begin + t.BufPtr := @t.Buffer; + t.BufSize := sizeof(t.Buffer); + t.CloseFunc := @FileNOPProc; + if Mode = (fmOutput and 3) then + begin + t.InOutFunc := @TextOut; + if @t = @ErrOutput then + Std := STD_ERROR_HANDLE + else + Std := STD_OUTPUT_HANDLE; + end + else + begin + t.InOutFunc := @TextIn; + Std := STD_INPUT_HANDLE; + end; + t.Handle := GetStdHandle(Std); + end + else + begin + t.CloseFunc := @TextClose; + + Flags := OPEN_EXISTING; + if Mode = (fmInput and 3) then + begin // called by Reset + t.InOutFunc := @TextIn; + OpenMode := GENERIC_READ; // open for read + end + else + begin + t.InOutFunc := @TextOut; + if Mode = (fmInOut and 3) then // called by Append + OpenMode := GENERIC_READ OR GENERIC_WRITE // open for read/write + else + begin // called by Rewrite + OpenMode := GENERIC_WRITE; // open for write + Flags := CREATE_ALWAYS; + end; + end; + + Temp := CreateFileA(t.Name, OpenMode, FILE_SHARE_READ, nil, Flags, FILE_ATTRIBUTE_NORMAL, 0); + if Temp = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + t.Handle := Temp; + + if Mode = (fmInOut and 3) then + begin + Dec(t.Mode); // fmInOut -> fmOutput + +{; ??? we really have to look for the first eof byte in the +; ??? last record and truncate the file there. +; Not very nice and clean... +; +; lastRecPos = Max( GetFileSize(...) - 128, 0); +} + Temp := GetFileSize(t.Handle, 0); + if Temp = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + Dec(Temp, 128); + if Temp < 0 then Temp := 0; + + if (SetFilePointer(t.Handle, Temp, nil, FILE_BEGIN) = -1) or + (ReadFile(t.Handle, t.Buffer, 128, BytesRead, nil) = 0) then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + for I := 0 to BytesRead do + begin + if t.Buffer[I] = Char(cEOF) then + begin // truncate the file here + if (SetFilePointer(t.Handle, I - BytesRead, nil, FILE_END) = -1) or + (not SetEndOfFile(t.Handle)) then + begin + Result := TextOpenCleanup(t); + Exit; + end; + Break; + end; + end; + end; + if Mode <> (fmInput and 3) then + begin + case GetFileType(t.Handle) of + 0: begin // bad file type + TextOpenCleanup(t); + Result := 105; + Exit; + end; + 2: t.FlushFunc := @TextOut; + end; + end; + end; +end; +*) + +asm +// -> EAX Pointer to text record + + PUSH ESI + + MOV ESI,EAX + + XOR EAX,EAX + MOV [ESI].TTextRec.BufPos,EAX + MOV [ESI].TTextRec.BufEnd,EAX + MOV AX,[ESI].TTextRec.Mode + + SUB EAX,fmInput + JE @@calledByReset + + DEC EAX + JE @@calledByRewrite + + DEC EAX + JE @@calledByAppend + + JMP @@exit + +@@calledByReset: + + MOV EAX,GENERIC_READ // open for read + MOV EDX,FILE_SHARE_READ + MOV ECX,OPEN_EXISTING + + MOV [ESI].TTextRec.InOutFunc,offset TextIn + + JMP @@common + +@@calledByRewrite: + + MOV EAX,GENERIC_WRITE // open for write + MOV EDX,FILE_SHARE_READ + MOV ECX,CREATE_ALWAYS + JMP @@commonOut + +@@calledByAppend: + + MOV EAX,GENERIC_READ OR GENERIC_WRITE // open for read/write + MOV EDX,FILE_SHARE_READ + MOV ECX,OPEN_EXISTING + +@@commonOut: + + MOV [ESI].TTextRec.InOutFunc,offset TextOut + +@@common: + + MOV [ESI].TTextRec.CloseFunc,offset TextClose + MOV [ESI].TTextRec.FlushFunc,offset FileNOPProc + CMP byte ptr [ESI].TTextRec.Name,0 + JE @@isCon + +// CreateFile(t.Name, EAX, EDX, Nil, ECX, FILE_ATTRIBUTE_NORMAL, 0); + + PUSH 0 + PUSH FILE_ATTRIBUTE_NORMAL + PUSH ECX + PUSH 0 + PUSH EDX + PUSH EAX + LEA EAX,[ESI].TTextRec.Name + PUSH EAX + CALL CreateFileA + + CMP EAX,-1 + JZ @@error + + MOV [ESI].TTextRec.Handle,EAX + CMP [ESI].TTextRec.Mode,fmInOut + JNE @@success + + DEC [ESI].TTextRec.Mode // fmInOut -> fmOutput + +{; ??? we really have to look for the first eof byte in the +; ??? last record and truncate the file there. +; Not very nice and clean... +; +; lastRecPos = Max( GetFileSize(...) - 128, 0); +} + PUSH 0 + PUSH [ESI].TTextRec.Handle + CALL GetFileSize + + INC EAX + JZ @@error + SUB EAX,129 + JNC @@3 + XOR EAX,EAX +@@3: +// lseek(f.Handle, SEEK_SET, lastRecPos); + + PUSH FILE_BEGIN + PUSH 0 + PUSH EAX + PUSH [ESI].TTextRec.Handle + CALL SetFilePointer + + INC EAX + JE @@error + +// bytesRead = read(f.Handle, f.Buffer, 128); + + PUSH 0 + MOV EDX,ESP + PUSH 0 + PUSH EDX + PUSH 128 + LEA EDX,[ESI].TTextRec.Buffer + PUSH EDX + PUSH [ESI].TTextRec.Handle + CALL ReadFile + POP EDX + DEC EAX + JNZ @@error + +// for (i = 0; i < bytesRead; i++) + + XOR EAX,EAX +@@loop: + CMP EAX,EDX + JAE @@success + +// if (f.Buffer[i] == eof) + + CMP byte ptr [ESI].TTextRec.Buffer[EAX],eof + JE @@truncate + INC EAX + JMP @@loop + +@@truncate: + +// lseek( f.Handle, SEEK_END, i - bytesRead ); + + PUSH FILE_END + PUSH 0 + SUB EAX,EDX + PUSH EAX + PUSH [ESI].TTextRec.Handle + CALL SetFilePointer + INC EAX + JE @@error + +// SetEndOfFile( f.Handle ); + + PUSH [ESI].TTextRec.Handle + CALL SetEndOfFile + DEC EAX + JNE @@error + + JMP @@success + +@@isCon: + LEA EAX,[ESI].TTextRec.Buffer + MOV [ESI].TTextRec.BufSize, TYPE TTextRec.Buffer + MOV [ESI].TTextRec.CloseFunc,offset FileNOPProc + MOV [ESI].TTextRec.BufPtr,EAX + CMP [ESI].TTextRec.Mode,fmOutput + JE @@output + PUSH STD_INPUT_HANDLE + JMP @@1 +@@output: + CMP ESI,offset ErrOutput + JNE @@stdout + PUSH STD_ERROR_HANDLE + JMP @@1 +@@stdout: + PUSH STD_OUTPUT_HANDLE +@@1: + CALL GetStdHandle + CMP EAX,-1 + JE @@error + MOV [ESI].TTextRec.Handle,EAX + +@@success: + CMP [ESI].TTextRec.Mode,fmInput + JE @@2 + PUSH [ESI].TTextRec.Handle + CALL GetFileType + TEST EAX,EAX + JE @@badFileType + CMP EAX,2 + JNE @@2 + MOV [ESI].TTextRec.FlushFunc,offset TextOut +@@2: + XOR EAX,EAX +@@exit: + POP ESI + RET + +@@badFileType: + PUSH [ESI].TTextRec.Handle + CALL CloseHandle + MOV [ESI].TTextRec.Mode,fmClosed + MOV EAX,105 + JMP @@exit + +@@error: + MOV [ESI].TTextRec.Mode,fmClosed + CALL GetLastError + JMP @@exit +end; +{$ENDIF} + +const + fNameLen = 260; + +function _Assign(var t: TTextRec; const s: String): Integer; +begin + FillChar(t, sizeof(TFileRec), 0); + t.BufPtr := @t.Buffer; + t.Mode := fmClosed; + t.Flags := tfCRLF * Byte(DefaultTextLineBreakStyle); + t.BufSize := sizeof(t.Buffer); + t.OpenFunc := @TextOpen; + Move(S[1], t.Name, Length(s)); + t.Name[Length(s)] := #0; + Result := 0; +end; + +function InternalFlush(var t: TTextRec; Func: TTextIOFunc): Integer; +begin + case t.Mode of + fmOutput, + fmInOut : Result := Func(t); + fmInput : Result := 0; + else + if (@t = @Output) or (@t = @ErrOutput) then + Result := 0 + else + Result := 103; + end; + if Result <> 0 then SetInOutRes(Result); +end; + +function Flush(var t: Text): Integer; +begin + Result := InternalFlush(TTextRec(t), TTextRec(t).InOutFunc); +end; + +function _Flush(var t: TTextRec): Integer; +begin + Result := InternalFlush(t, t.FlushFunc); +end; + +type +{$IFDEF MSWINDOWS} + 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'; + +{$ENDIF} +{$IFDEF LINUX} + TIOProc = function (Handle: Integer; Buffer: Pointer; Count: Cardinal): Cardinal; cdecl; +{$ENDIF} + +function BlockIO(var f: TFileRec; buffer: Pointer; recCnt: Cardinal; var recsDone: Longint; + ModeMask: Integer; IOProc: TIOProc; ErrorNo: Integer): Cardinal; +// Note: RecsDone ptr can be nil! +begin + if (f.Mode and ModeMask) = ModeMask then // fmOutput or fmInOut / fmInput or fmInOut + begin +{$IFDEF LINUX} + Result := IOProc(f.Handle, buffer, recCnt * f.RecSize); + if Integer(Result) = -1 then +{$ENDIF} +{$IFDEF MSWINDOWS} + if IOProc(f.Handle, buffer, recCnt * f.RecSize, Result, nil) = 0 then +{$ENDIF} + begin + SetInOutRes(GetLastError); + Result := 0; + end + else + begin + Result := Result div f.RecSize; + if @RecsDone <> nil then + RecsDone := Result + else if Result <> recCnt then + begin + SetInOutRes(ErrorNo); + Result := 0; + end + end; + end + else + begin + SetInOutRes(103); // file not open + Result := 0; + end; +end; + +function _BlockRead(var f: TFileRec; buffer: Pointer; recCnt: Longint; var recsRead: Longint): Longint; +begin + Result := BlockIO(f, buffer, recCnt, recsRead, fmInput, + {$IFDEF MSWINDOWS} ReadFileX, {$ENDIF} + {$IFDEF LINUX} __read, {$ENDIF} + 100); +end; + +function _BlockWrite(var f: TFileRec; buffer: Pointer; recCnt: Longint; var recsWritten: Longint): Longint; +begin + Result := BlockIO(f, buffer, recCnt, recsWritten, fmOutput, + {$IFDEF MSWINDOWS} WriteFileX, {$ENDIF} + {$IFDEF LINUX} __write, {$ENDIF} + 101); +end; + +function _Close(var t: TTextRec): Integer; +begin + Result := 0; + if (t.Mode >= fmInput) and (t.Mode <= fmInOut) then + begin + if (t.Mode and fmOutput) = fmOutput then // fmOutput or fmInOut + Result := TTextIOFunc(t.InOutFunc)(t); + if Result = 0 then + Result := TTextIOFunc(t.CloseFunc)(t); + if Result <> 0 then + SetInOutRes(Result); + end + else + if @t <> @Input then + SetInOutRes(103); +end; + +procedure _PStrCat; +asm +{ ->EAX = Pointer to destination string } +{ EDX = Pointer to source string } + + PUSH ESI + PUSH EDI + +{ load dest len into EAX } + + MOV EDI,EAX + XOR EAX,EAX + MOV AL,[EDI] + +{ load source address in ESI, source len in ECX } + + MOV ESI,EDX + XOR ECX,ECX + MOV CL,[ESI] + INC ESI + +{ calculate final length in DL and store it in the destination } + + MOV DL,AL + ADD DL,CL + JC @@trunc + +@@cont: + MOV [EDI],DL + +{ calculate final dest address } + + INC EDI + ADD EDI,EAX + +{ do the copy } + + REP MOVSB + +{ done } + + POP EDI + POP ESI + RET + +@@trunc: + INC DL { DL = #chars to truncate } + SUB CL,DL { CL = source len - #chars to truncate } + MOV DL,255 { DL = maximum length } + JMP @@cont +end; + +procedure _PStrNCat; +asm +{ ->EAX = Pointer to destination string } +{ EDX = Pointer to source string } +{ CL = max length of result (allocated size of dest - 1) } + + PUSH ESI + PUSH EDI + +{ load dest len into EAX } + + MOV EDI,EAX + XOR EAX,EAX + MOV AL,[EDI] + +{ load source address in ESI, source len in EDX } + + MOV ESI,EDX + XOR EDX,EDX + MOV DL,[ESI] + INC ESI + +{ calculate final length in AL and store it in the destination } + + ADD AL,DL + JC @@trunc + CMP AL,CL + JA @@trunc + +@@cont: + MOV ECX,EDX + MOV DL,[EDI] + MOV [EDI],AL + +{ calculate final dest address } + + INC EDI + ADD EDI,EDX + +{ do the copy } + + REP MOVSB + +@@done: + POP EDI + POP ESI + RET + +@@trunc: +{ CL = maxlen } + + MOV AL,CL { AL = final length = maxlen } + SUB CL,[EDI] { CL = length to copy = maxlen - destlen } + JBE @@done + MOV DL,CL + JMP @@cont +end; + +procedure _PStrCpy(Dest: PShortString; Source: PShortString); +begin + Move(Source^, Dest^, Byte(Source^[0])+1); +end; + +procedure _PStrNCpy(Dest: PShortString; Source: PShortString; MaxLen: Byte); +begin + if MaxLen > Byte(Source^[0]) then + MaxLen := Byte(Source^[0]); + Byte(Dest^[0]) := MaxLen; + Move(Source^[1], Dest^[1], MaxLen); +end; + +procedure _PStrCmp; +asm +{ ->EAX = Pointer to left string } +{ EDX = Pointer to right string } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + XOR EAX,EAX + XOR EDX,EDX + MOV AL,[ESI] + MOV DL,[EDI] + INC ESI + INC EDI + + SUB EAX,EDX { eax = len1 - len2 } + JA @@skip1 + ADD EDX,EAX { edx = len2 + (len1 - len2) = len1 } + +@@skip1: + PUSH EDX + SHR EDX,2 + JE @@cmpRest +@@longLoop: + MOV ECX,[ESI] + MOV EBX,[EDI] + CMP ECX,EBX + JNE @@misMatch + DEC EDX + JE @@cmpRestP4 + MOV ECX,[ESI+4] + MOV EBX,[EDI+4] + CMP ECX,EBX + JNE @@misMatch + ADD ESI,8 + ADD EDI,8 + DEC EDX + JNE @@longLoop + JMP @@cmpRest +@@cmpRestP4: + ADD ESI,4 + ADD EDI,4 +@@cmpRest: + POP EDX + AND EDX,3 + JE @@equal + + MOV CL,[ESI] + CMP CL,[EDI] + JNE @@exit + DEC EDX + JE @@equal + MOV CL,[ESI+1] + CMP CL,[EDI+1] + JNE @@exit + DEC EDX + JE @@equal + MOV CL,[ESI+2] + CMP CL,[EDI+2] + JNE @@exit + +@@equal: + ADD EAX,EAX + JMP @@exit + +@@misMatch: + POP EDX + CMP CL,BL + JNE @@exit + CMP CH,BH + JNE @@exit + SHR ECX,16 + SHR EBX,16 + CMP CL,BL + JNE @@exit + CMP CH,BH + +@@exit: + POP EDI + POP ESI + POP EBX +end; + +procedure _AStrCmp; +asm +{ ->EAX = Pointer to left string } +{ EDX = Pointer to right string } +{ ECX = Number of chars to compare} + + PUSH EBX + PUSH ESI + PUSH ECX + MOV ESI,ECX + SHR ESI,2 + JE @@cmpRest + +@@longLoop: + MOV ECX,[EAX] + MOV EBX,[EDX] + CMP ECX,EBX + JNE @@misMatch + DEC ESI + JE @@cmpRestP4 + MOV ECX,[EAX+4] + MOV EBX,[EDX+4] + CMP ECX,EBX + JNE @@misMatch + ADD EAX,8 + ADD EDX,8 + DEC ESI + JNE @@longLoop + JMP @@cmpRest +@@cmpRestp4: + ADD EAX,4 + ADD EDX,4 +@@cmpRest: + POP ESI + AND ESI,3 + JE @@exit + + MOV CL,[EAX] + CMP CL,[EDX] + JNE @@exit + DEC ESI + JE @@equal + MOV CL,[EAX+1] + CMP CL,[EDX+1] + JNE @@exit + DEC ESI + JE @@equal + MOV CL,[EAX+2] + CMP CL,[EDX+2] + JNE @@exit + +@@equal: + XOR EAX,EAX + JMP @@exit + +@@misMatch: + POP ESI + CMP CL,BL + JNE @@exit + CMP CH,BH + JNE @@exit + SHR ECX,16 + SHR EBX,16 + CMP CL,BL + JNE @@exit + CMP CH,BH + +@@exit: + POP ESI + POP EBX +end; + +function _EofFile(var f: TFileRec): Boolean; +begin + Result := _FilePos(f) >= _FileSize(f); +end; + +function _EofText(var t: TTextRec): Boolean; +asm +// -> EAX Pointer to text record +// <- AL Boolean result + CMP [EAX].TTextRec.Mode,fmInput + JNE @@readChar + MOV EDX,[EAX].TTextRec.BufPos + CMP EDX,[EAX].TTextRec.BufEnd + JAE @@readChar + ADD EDX,[EAX].TTextRec.BufPtr + TEST [EAX].TTextRec.Flags,tfCRLF + JZ @@FalseExit + MOV CL,[EDX] + CMP CL,cEof + JNZ @@FalseExit + +@@eof: + MOV AL,1 + JMP @@exit + +@@readChar: + PUSH EAX + CALL _ReadChar + POP EDX + CMP AH,cEof + JE @@eof + DEC [EDX].TTextRec.BufPos +@@FalseExit: + XOR EAX,EAX +@@exit: +end; + +function _Eoln(var t: TTextRec): Boolean; +asm +// -> EAX Pointer to text record +// <- AL Boolean result + + CMP [EAX].TTextRec.Mode,fmInput + JNE @@readChar + MOV EDX,[EAX].TTextRec.BufPos + CMP EDX,[EAX].TTextRec.BufEnd + JAE @@readChar + ADD EDX,[EAX].TTextRec.BufPtr + TEST [EAX].TTextRec.Flags,tfCRLF + MOV AL,0 + MOV CL,[EDX] + JZ @@testLF + CMP CL,cCR + JE @@eol + CMP CL,cEOF + JE @@eof + JMP @@exit + +@@testLF: + CMP CL,cLF + JE @@eol + CMP CL,cEOF + JE @@eof + JMP @@exit + +@@readChar: + PUSH EAX + CALL _ReadChar + POP EDX + CMP AH,cEOF + JE @@eof + DEC [EDX].TTextRec.BufPos + XOR ECX,ECX + XCHG ECX,EAX + TEST [EDX].TTextRec.Mode,tfCRLF + JNE @@testLF + CMP CL,cCR + JE @@eol + JMP @@exit + +@@eol: +@@eof: + MOV AL,1 +@@exit: +end; + +procedure _Erase(var f: TFileRec); +begin + if (f.Mode < fmClosed) or (f.Mode > fmInOut) then + SetInOutRes(102) // file not assigned + else +{$IFDEF LINUX} + if __remove(f.Name) < 0 then + SetInOutRes(GetLastError); +{$ENDIF} +{$IFDEF MSWINDOWS} + if not DeleteFileA(f.Name) then + SetInOutRes(GetLastError); +{$ENDIF} +end; + +{$IFDEF MSWINDOWS} +// Floating-point divide reverse routine +// ST(1) = ST(0) / ST(1), pop ST + +procedure _FSafeDivideR; +asm + FXCH + JMP _FSafeDivide +end; + +// Floating-point divide routine +// ST(1) = ST(1) / ST(0), pop ST + +procedure _FSafeDivide; +type + Z = packed record // helper type to make parameter references more readable + Dividend: Extended; // (TBYTE PTR [ESP]) + Pad: Word; + Divisor: Extended; // (TBYTE PTR [ESP+12]) + end; +asm + CMP TestFDIV,0 //Check FDIV indicator + JLE @@FDivideChecked //Jump if flawed or don't know + FDIV //Known to be ok, so just do FDIV + RET + +// FDIV constants +@@FDIVRiscTable: DB 0,1,0,0,4,0,0,7,0,0,10,0,0,13,0,0; + +@@FDIVScale1: DD $3F700000 // 0.9375 +@@FDIVScale2: DD $3F880000 // 1.0625 +@@FDIV1SHL63: DD $5F000000 // 1 SHL 63 + +@@TestDividend: DD $C0000000,$4150017E // 4195835.0 +@@TestDivisor: DD $80000000,$4147FFFF // 3145727.0 +@@TestOne: DD $00000000,$3FF00000 // 1.0 + +// Flawed FDIV detection +@@FDivideDetect: + MOV TestFDIV,1 //Indicate correct FDIV + PUSH EAX + SUB ESP,12 + FSTP TBYTE PTR [ESP] //Save off ST + FLD QWORD PTR @@TestDividend //Ok if x - (x / y) * y < 1.0 + FDIV QWORD PTR @@TestDivisor + FMUL QWORD PTR @@TestDivisor + FSUBR QWORD PTR @@TestDividend + FCOMP QWORD PTR @@TestOne + FSTSW AX + SHR EAX,7 + AND EAX,002H //Zero if FDIV is flawed + DEC EAX + MOV TestFDIV,AL //1 means Ok, -1 means flawed + FLD TBYTE PTR [ESP] //Restore ST + ADD ESP,12 + POP EAX + JMP _FSafeDivide + +@@FDivideChecked: + JE @@FDivideDetect //Do detection if TestFDIV = 0 + +@@1: PUSH EAX + SUB ESP,24 + FSTP [ESP].Z.Divisor //Store Divisor and Dividend + FSTP [ESP].Z.Dividend + FLD [ESP].Z.Dividend + FLD [ESP].Z.Divisor +@@2: MOV EAX,DWORD PTR [ESP+4].Z.Divisor //Is Divisor a denormal? + ADD EAX,EAX + JNC @@20 //Yes, @@20 + XOR EAX,0E000000H //If these three bits are not all + TEST EAX,0E000000H //ones, FDIV will work + JZ @@10 //Jump if all ones +@@3: FDIV //Do FDIV and exit + ADD ESP,24 + POP EAX + RET + +@@10: SHR EAX,28 //If the four bits following the MSB + //of the mantissa have a decimal + //of 1, 4, 7, 10, or 13, FDIV may + CMP byte ptr @@FDIVRiscTable[EAX],0 //not work correctly + JZ @@3 //Do FDIV if not 1, 4, 7, 10, or 13 + MOV EAX,DWORD PTR [ESP+8].Z.Divisor //Get Divisor exponent + AND EAX,7FFFH + JZ @@3 //Ok to FDIV if denormal + CMP EAX,7FFFH + JE @@3 //Ok to FDIV if NAN or INF + MOV EAX,DWORD PTR [ESP+8].Z.Dividend //Get Dividend exponent + AND EAX,7FFFH + CMP EAX,1 //Small number? + JE @@11 //Yes, @@11 + FMUL DWORD PTR @@FDIVScale1 //Scale by 15/16 + FXCH + FMUL DWORD PTR @@FDIVScale1 + FXCH + JMP @@3 //FDIV is now safe + +@@11: FMUL DWORD PTR @@FDIVScale2 //Scale by 17/16 + FXCH + FMUL DWORD PTR @@FDIVScale2 + FXCH + JMP @@3 //FDIV is now safe + +@@20: MOV EAX,DWORD PTR [ESP].Z.Divisor //Is entire Divisor zero? + OR EAX,DWORD PTR [ESP+4].Z.Divisor + JZ @@3 //Yes, ok to FDIV + MOV EAX,DWORD PTR [ESP+8].Z.Divisor //Get Divisor exponent + AND EAX,7FFFH //Non-zero exponent is invalid + JNZ @@3 //Ok to FDIV if invalid + MOV EAX,DWORD PTR [ESP+8].Z.Dividend //Get Dividend exponent + AND EAX,7FFFH //Denormal? + JZ @@21 //Yes, @@21 + CMP EAX,7FFFH //NAN or INF? + JE @@3 //Yes, ok to FDIV + MOV EAX,DWORD PTR [ESP+4].Z.Dividend //If MSB of mantissa is zero, + ADD EAX,EAX //the number is invalid + JNC @@3 //Ok to FDIV if invalid + JMP @@22 +@@21: MOV EAX,DWORD PTR [ESP+4].Z.Dividend //If MSB of mantissa is zero, + ADD EAX,EAX //the number is invalid + JC @@3 //Ok to FDIV if invalid +@@22: FXCH //Scale stored Divisor image by + FSTP ST(0) //1 SHL 63 and restart + FLD ST(0) + FMUL DWORD PTR @@FDIV1SHL63 + FSTP [ESP].Z.Divisor + FLD [ESP].Z.Dividend + FXCH + JMP @@2 +end; +{$ENDIF} + +function _FilePos(var f: TFileRec): Longint; +begin + if (f.Mode > fmClosed) and (f.Mode <= fmInOut) then + begin +{$IFDEF LINUX} + Result := _lseek(f.Handle, 0, SEEK_CUR); +{$ENDIF} +{$IFDEF MSWINDOWS} + Result := SetFilePointer(f.Handle, 0, nil, FILE_CURRENT); +{$ENDIF} + if Result = -1 then + InOutError + else + Result := Cardinal(Result) div f.RecSize; + end + else + begin + SetInOutRes(103); + Result := -1; + end; +end; + +function _FileSize(var f: TFileRec): Longint; +{$IFDEF MSWINDOWS} +begin + Result := -1; + if (f.Mode > fmClosed) and (f.Mode <= fmInOut) then + begin + Result := GetFileSize(f.Handle, 0); + if Result = -1 then + InOutError + else + Result := Cardinal(Result) div f.RecSize; + end + else + SetInOutRes(103); +{$ENDIF} +{$IFDEF LINUX} +var + stat: TStatStruct; +begin + Result := -1; + if (f.Mode > fmClosed) and (f.Mode <= fmInOut) then + begin + if _fxstat(STAT_VER_LINUX, f.Handle, stat) <> 0 then + InOutError + else + Result := stat.st_size div f.RecSize; + end + else + SetInOutRes(103); +{$ENDIF} +end; + +procedure _FillChar(var Dest; count: Integer; Value: Char); +{$IFDEF PUREPASCAL} +var + I: Integer; + P: PChar; +begin + P := PChar(@Dest); + for I := count-1 downto 0 do + P[I] := Value; +end; +{$ELSE} +asm +{ ->EAX Pointer to destination } +{ EDX count } +{ CL value } + + PUSH EDI + + MOV EDI,EAX { Point EDI to destination } + + MOV CH,CL { Fill EAX with value repeated 4 times } + MOV EAX,ECX + SHL EAX,16 + MOV AX,CX + + MOV ECX,EDX + SAR ECX,2 + JS @@exit + + REP STOSD { Fill count DIV 4 dwords } + + MOV ECX,EDX + AND ECX,3 + REP STOSB { Fill count MOD 4 bytes } + +@@exit: + POP EDI +end; +{$ENDIF} + +procedure Mark; +begin + Error(reInvalidPtr); +end; + +procedure _RandInt; +asm +{ ->EAX Range } +{ <-EAX Result } + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX + MOV ECX,[EBX].OFFSET RandSeed + IMUL EDX,[ECX],08088405H + INC EDX + MOV [ECX],EDX +{$ELSE} + XOR EBX, EBX + IMUL EDX,[EBX].RandSeed,08088405H + INC EDX + MOV [EBX].RandSeed,EDX +{$ENDIF} + MUL EDX + MOV EAX,EDX + POP EBX +end; + +procedure _RandExt; +const two2neg32: double = ((1.0/$10000) / $10000); // 2^-32 +asm +{ FUNCTION _RandExt: Extended; } + + PUSH EBX +{$IFDEF PIC} + CALL GetGOT + MOV EBX,EAX + MOV ECX,[EBX].OFFSET RandSeed + IMUL EDX,[ECX],08088405H + INC EDX + MOV [ECX],EDX +{$ELSE} + XOR EBX, EBX + IMUL EDX,[EBX].RandSeed,08088405H + INC EDX + MOV [EBX].RandSeed,EDX +{$ENDIF} + + FLD [EBX].two2neg32 + PUSH 0 + PUSH EDX + FILD qword ptr [ESP] + ADD ESP,8 + FMULP ST(1), ST(0) + POP EBX +end; + +function _ReadRec(var f: TFileRec; Buffer: Pointer): Integer; +{$IFDEF LINUX} +begin + if (f.Mode and fmInput) = fmInput then // fmInput or fmInOut + begin + Result := __read(f.Handle, Buffer, f.RecSize); + if Result = -1 then + InOutError + else if Cardinal(Result) <> f.RecSize then + SetInOutRes(100); + end + else + begin + SetInOutRes(103); // file not open for input + Result := 0; + end; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm +// -> EAX Pointer to file variable +// EDX Pointer to buffer + + PUSH EBX + XOR ECX,ECX + MOV EBX,EAX + MOV CX,[EAX].TFileRec.Mode // File must be open + SUB ECX,fmInput + JE @@skip + SUB ECX,fmInOut-fmInput + JNE @@fileNotOpen +@@skip: + +// ReadFile(f.Handle, buffer, f.RecSize, @result, Nil); + + PUSH 0 // space for OS result + MOV EAX,ESP + + PUSH 0 // pass lpOverlapped + PUSH EAX // pass @result + + PUSH [EBX].TFileRec.RecSize // pass nNumberOfBytesToRead + + PUSH EDX // pass lpBuffer + PUSH [EBX].TFileRec.Handle // pass hFile + CALL ReadFile + POP EDX // pop result + DEC EAX // check EAX = TRUE + JNZ @@error + + CMP EDX,[EBX].TFileRec.RecSize // result = f.RecSize ? + JE @@exit + +@@readError: + MOV EAX,100 + JMP @@errExit + +@@fileNotOpen: + MOV EAX,103 + JMP @@errExit + +@@error: + CALL GetLastError +@@errExit: + CALL SetInOutRes +@@exit: + POP EBX +end; +{$ENDIF} + + +// If the file is Input std variable, try to open it +// Otherwise, runtime error. +function TryOpenForInput(var t: TTextRec): Boolean; +begin + if @t = @Input then + begin + t.Flags := tfCRLF * Byte(DefaultTextLineBreakStyle); + _ResetText(t); + end; + + Result := t.Mode = fmInput; + if not Result then + SetInOutRes(104); +end; + +function _ReadChar(var t: TTextRec): Char; +asm +// -> EAX Pointer to text record +// <- AL Character read. (may be a pseudo cEOF in DOS mode) +// <- AH cEOF = End of File, else 0 +// For eof, #$1A is returned in AL and in AH. +// For errors, InOutRes is set and #$1A is returned. + + CMP [EAX].TTextRec.Mode, fmInput + JE @@checkBuf + PUSH EAX + CALL TryOpenForInput + TEST AL,AL + POP EAX + JZ @@eofexit + +@@checkBuf: + MOV EDX,[EAX].TTextRec.BufPos + CMP EDX,[EAX].TTextRec.BufEnd + JAE @@fillBuf +@@cont: + TEST [EAX].TTextRec.Flags,tfCRLF + MOV ECX,[EAX].TTextRec.BufPtr + MOV CL,[ECX+EDX] + JZ @@cont2 + CMP CL,cEof // Check for EOF char in DOS mode + JE @@eofexit +@@cont2: + INC EDX + MOV [EAX].TTextRec.BufPos,EDX + XOR EAX,EAX + JMP @@exit + +@@fillBuf: + PUSH EAX + CALL [EAX].TTextRec.InOutFunc + TEST EAX,EAX + JNE @@error + POP EAX + MOV EDX,[EAX].TTextRec.BufPos + CMP EDX,[EAX].TTextRec.BufEnd + JB @@cont + +// We didn't get characters. Must be eof then. + +@@eof: + TEST [EAX].TTextRec.Flags,tfCRLF + JZ @@eofexit +// In DOS CRLF compatibility mode, synthesize an EOF char +// Store one eof in the buffer and increment BufEnd + MOV ECX,[EAX].TTextRec.BufPtr + MOV byte ptr [ECX+EDX],cEof + INC [EAX].TTextRec.BufEnd + JMP @@eofexit + +@@error: + CALL SetInOutRes + POP EAX +@@eofexit: + MOV CL,cEof + MOV AH,CL +@@exit: + MOV AL,CL +end; + +function _ReadLong(var t: TTextRec): Longint; +asm +// -> EAX Pointer to text record +// <- EAX Result + + PUSH EBX + PUSH ESI + PUSH EDI + SUB ESP,36 // var numbuf: String[32]; + + MOV ESI,EAX + CALL _SeekEof + DEC AL + JZ @@eof + + MOV EDI,ESP // EDI -> numBuf[0] + MOV BL,32 +@@loop: + MOV EAX,ESI + CALL _ReadChar + CMP AL,' ' + JBE @@endNum + STOSB + DEC BL + JNZ @@loop +@@convert: + MOV byte ptr [EDI],0 + MOV EAX,ESP // EAX -> numBuf + PUSH EDX // allocate code result + MOV EDX,ESP // pass pointer to code + CALL _ValLong // convert + POP EDX // pop code result into EDX + TEST EDX,EDX + JZ @@exit + MOV EAX,106 + CALL SetInOutRes + JMP @@exit + +@@endNum: + CMP AH,cEof + JE @@convert + DEC [ESI].TTextRec.BufPos + JMP @@convert + +@@eof: + XOR EAX,EAX +@@exit: + ADD ESP,36 + POP EDI + POP ESI + POP EBX +end; + +function ReadLine(var t: TTextRec; buf: Pointer; maxLen: Longint): Pointer; +asm +// -> EAX Pointer to text record +// EDX Pointer to buffer +// ECX Maximum count of chars to read +// <- ECX Actual count of chars in buffer +// <- EAX Pointer to text record + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH ECX + MOV ESI,ECX + MOV EDI,EDX + + CMP [EAX].TTextRec.Mode,fmInput + JE @@start + PUSH EAX + CALL TryOpenForInput + TEST AL,AL + POP EAX + JZ @@exit + +@@start: + MOV EBX,EAX + + TEST ESI,ESI + JLE @@exit + + MOV EDX,[EBX].TTextRec.BufPos + MOV ECX,[EBX].TTextRec.BufEnd + SUB ECX,EDX + ADD EDX,[EBX].TTextRec.BufPtr + +@@loop: + DEC ECX + JL @@readChar + MOV AL,[EDX] + INC EDX +@@cont: + CMP AL,cLF + JE @@lf + + CMP AL,cCR + JE @@cr + + STOSB + DEC ESI + JG @@loop + JMP @@finish + +@@cr: + MOV AL,[EDX] + CMP AL,cLF + JNE @@loop +@@lf: + DEC EDX +@@finish: + SUB EDX,[EBX].TTextRec.BufPtr + MOV [EBX].TTextRec.BufPos,EDX + JMP @@exit + +@@readChar: + MOV [EBX].TTextRec.BufPos,EDX + MOV EAX,EBX + CALL _ReadChar + MOV EDX,[EBX].TTextRec.BufPos + MOV ECX,[EBX].TTextRec.BufEnd + SUB ECX,EDX + ADD EDX,[EBX].TTextRec.BufPtr + TEST AH,AH //eof + JZ @@cont + +@@exit: + MOV EAX,EBX + POP ECX + SUB ECX,ESI + POP EDI + POP ESI + POP EBX +end; + +procedure _ReadString(var t: TTextRec; s: PShortString; maxLen: Longint); +asm +// -> EAX Pointer to text record +// EDX Pointer to string +// ECX Maximum length of string + + PUSH EDX + INC EDX + CALL ReadLine + POP EDX + MOV [EDX],CL +end; + +procedure _ReadCString(var t: TTextRec; s: PChar; maxLen: Longint); +asm +// -> EAX Pointer to text record +// EDX Pointer to string +// ECX Maximum length of string + + PUSH EDX + CALL ReadLine + POP EDX + MOV byte ptr [EDX+ECX],0 +end; + +procedure _ReadLString(var t: TTextRec; var s: AnsiString); +asm + { -> EAX pointer to Text } + { EDX pointer to AnsiString } + + PUSH EBX + PUSH ESI + MOV EBX,EAX + MOV ESI,EDX + + MOV EAX,EDX + CALL _LStrClr + + SUB ESP,256 + + MOV EAX,EBX + MOV EDX,ESP + MOV ECX,255 + CALL _ReadString + + MOV EAX,ESI + MOV EDX,ESP + CALL _LStrFromString + + CMP byte ptr [ESP],255 + JNE @@exit +@@loop: + + MOV EAX,EBX + MOV EDX,ESP + MOV ECX,255 + CALL _ReadString + + MOV EDX,ESP + PUSH 0 + MOV EAX,ESP + CALL _LStrFromString + + MOV EAX,ESI + MOV EDX,[ESP] + CALL _LStrCat + + MOV EAX,ESP + CALL _LStrClr + POP EAX + + CMP byte ptr [ESP],255 + JE @@loop + +@@exit: + ADD ESP,256 + POP ESI + POP EBX +end; + + +function IsValidMultibyteChar(const Src: PChar; SrcBytes: Integer): Boolean; +{$IFDEF MSWINDOWS} +const + ERROR_NO_UNICODE_TRANSLATION = 1113; // Win32 GetLastError when result = 0 + MB_ERR_INVALID_CHARS = 8; +var + Dest: WideChar; +begin + Result := MultiByteToWideChar(0, MB_ERR_INVALID_CHARS, Src, SrcBytes, @Dest, 1) <> 0; +{$ENDIF} +{$IFDEF LINUX} +begin + Result := mblen(Src, SrcBytes) <> -1; +{$ENDIF} +end; + + +function _ReadWChar(var t: TTextRec): WideChar; +var + scratch: array [0..7] of AnsiChar; + wc: WideChar; + i: Integer; +begin + i := 0; + while i < High(scratch) do + begin + scratch[i] := _ReadChar(t); + Inc(i); + scratch[i] := #0; + if IsValidMultibyteChar(scratch, i) then + begin + WCharFromChar(@wc, 1, scratch, i); + Result := wc; + Exit; + end; + end; + SetInOutRes(106); // Invalid Input + Result := #0; +end; + + +procedure _ReadWCString(var t: TTextRec; s: PWideChar; maxBytes: Longint); +var + i, maxLen: Integer; + wc: WideChar; +begin + if s = nil then Exit; + i := 0; + maxLen := maxBytes div sizeof(WideChar); + while i < maxLen do + begin + wc := _ReadWChar(t); + case Integer(wc) of + cEOF: if _EOFText(t) then Break; + cLF : begin + Dec(t.BufPos); + Break; + end; + cCR : if Byte(t.BufPtr[t.BufPos]) = cLF then + begin + Dec(t.BufPos); + Break; + end; + end; + s[i] := wc; + Inc(i); + end; + s[i] := #0; +end; + +procedure _ReadWString(var t: TTextRec; var s: WideString); +var + Temp: AnsiString; +begin + _ReadLString(t, Temp); + s := Temp; +end; + +function _ReadExt(var t: TTextRec): Extended; +asm +// -> EAX Pointer to text record +// <- FST(0) Result + + PUSH EBX + PUSH ESI + PUSH EDI + SUB ESP,68 // var numbuf: array[0..64] of char; + + MOV ESI,EAX + CALL _SeekEof + DEC AL + JZ @@eof + + MOV EDI,ESP // EDI -> numBuf[0] + MOV BL,64 +@@loop: + MOV EAX,ESI + CALL _ReadChar + CMP AL,' ' + JBE @@endNum + STOSB + DEC BL + JNZ @@loop +@@convert: + MOV byte ptr [EDI],0 + MOV EAX,ESP // EAX -> numBuf + PUSH EDX // allocate code result + MOV EDX,ESP // pass pointer to code + CALL _ValExt // convert + POP EDX // pop code result into EDX + TEST EDX,EDX + JZ @@exit + MOV EAX,106 + CALL SetInOutRes + JMP @@exit + +@@endNum: + CMP AH,cEOF + JE @@convert + DEC [ESI].TTextRec.BufPos + JMP @@convert + +@@eof: + FLDZ +@@exit: + ADD ESP,68 + POP EDI + POP ESI + POP EBX +end; + +procedure _ReadLn(var t: TTextRec); +asm +// -> EAX Pointer to text record + + PUSH EBX + MOV EBX,EAX +@@loop: + MOV EAX,EBX + CALL _ReadChar + + CMP AL,cLF // accept LF as end of line + JE @@exit + CMP AH,cEOF + JE @@eof + CMP AL,cCR + JNE @@loop + + MOV EAX,EBX + CALL _ReadChar + + CMP AL,cLF // accept CR+LF as end of line + JE @@exit + CMP AH,cEOF // accept CR+EOF as end of line + JE @@eof + DEC [EBX].TTextRec.BufPos + JMP @@loop // else CR+ anything else is not a line break. + +@@exit: +@@eof: + POP EBX +end; + +procedure _Rename(var f: TFileRec; newName: PChar); +var + I: Integer; +begin + if f.Mode = fmClosed then + begin + if newName = nil then newName := ''; +{$IFDEF LINUX} + if __rename(f.Name, newName) = 0 then +{$ENDIF} +{$IFDEF MSWINDOWS} + if MoveFileA(f.Name, newName) then +{$ENDIF} + begin + I := 0; + while (newName[I] <> #0) and (I < High(f.Name)) do + begin + f.Name[I] := newName[I]; + Inc(I); + end + end + else + SetInOutRes(GetLastError); + end + else + SetInOutRes(102); +end; + +procedure Release; +begin + Error(reInvalidPtr); +end; + +function _CloseFile(var f: TFileRec): Integer; +begin + f.Mode := fmClosed; + Result := 0; + if not InternalClose(f.Handle) then + begin + InOutError; + Result := 1; + end; +end; + +function OpenFile(var f: TFileRec; recSiz: Longint; mode: Longint): Integer; +{$IFDEF LINUX} +var + Flags: Integer; +begin + Result := 0; + if (f.Mode >= fmClosed) and (f.Mode <= fmInOut) then + begin + if f.Mode <> fmClosed then // not yet closed: close it + begin + Result := TFileIOFunc(f.CloseFunc)(f); + if Result <> 0 then + SetInOutRes(Result); + end; + + if recSiz <= 0 then + SetInOutRes(106); + + f.RecSize := recSiz; + f.InOutFunc := @FileNopProc; + + if f.Name[0] <> #0 then + begin + f.CloseFunc := @_CloseFile; + case mode of + 1: begin + Flags := O_APPEND or O_WRONLY; + f.Mode := fmOutput; + end; + 2: begin + Flags := O_RDWR; + f.Mode := fmInOut; + end; + 3: begin + Flags := O_CREAT or O_TRUNC or O_RDWR; + f.Mode := fmInOut; + end; + else + Flags := O_RDONLY; + f.Mode := fmInput; + end; + + f.Handle := __open(f.Name, Flags, FileAccessRights); + end + else // stdin or stdout + begin + f.CloseFunc := @FileNopProc; + if mode = 3 then + f.Handle := STDOUT_FILENO + else + f.Handle := STDIN_FILENO; + end; + + if f.Handle = -1 then + begin + f.Mode := fmClosed; + InOutError; + end; + end + else + SetInOutRes(102); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +const + ShareTab: array [0..7] of Integer = + (FILE_SHARE_READ OR FILE_SHARE_WRITE, // OF_SHARE_COMPAT 0x00000000 + 0, // OF_SHARE_EXCLUSIVE 0x00000010 + FILE_SHARE_READ, // OF_SHARE_DENY_WRITE 0x00000020 + FILE_SHARE_WRITE, // OF_SHARE_DENY_READ 0x00000030 + FILE_SHARE_READ OR FILE_SHARE_WRITE, // OF_SHARE_DENY_NONE 0x00000040 + 0,0,0); +asm +//-> EAX Pointer to file record +// EDX Record size +// ECX File mode + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EDX + MOV EDI,ECX + XOR EDX,EDX + MOV EBX,EAX + + MOV DX,[EAX].TFileRec.Mode + SUB EDX,fmClosed + JE @@alreadyClosed + CMP EDX,fmInOut-fmClosed + JA @@notAssignedError + +// not yet closed: close it. File parameter is still in EAX + + CALL [EBX].TFileRec.CloseFunc + TEST EAX,EAX + JE @@alreadyClosed + CALL SetInOutRes + +@@alreadyClosed: + + MOV [EBX].TFileRec.Mode,fmInOut + MOV [EBX].TFileRec.RecSize,ESI + MOV [EBX].TFileRec.CloseFunc,offset _CloseFile + MOV [EBX].TFileRec.InOutFunc,offset FileNopProc + + CMP byte ptr [EBX].TFileRec.Name,0 + JE @@isCon + + MOV EAX,GENERIC_READ OR GENERIC_WRITE + MOV DL,FileMode + AND EDX,070H + SHR EDX,4-2 + MOV EDX,dword ptr [shareTab+EDX] + MOV ECX,CREATE_ALWAYS + + SUB EDI,3 + JE @@calledByRewrite + + MOV ECX,OPEN_EXISTING + INC EDI + JE @@skip + + MOV EAX,GENERIC_WRITE + INC EDI + MOV [EBX].TFileRec.Mode,fmOutput + JE @@skip + + MOV EAX,GENERIC_READ + MOV [EBX].TFileRec.Mode,fmInput + +@@skip: +@@calledByRewrite: + +// CreateFile(t.FileName, EAX, EDX, Nil, ECX, FILE_ATTRIBUTE_NORMAL, 0); + + PUSH 0 + PUSH FILE_ATTRIBUTE_NORMAL + PUSH ECX + PUSH 0 + PUSH EDX + PUSH EAX + LEA EAX,[EBX].TFileRec.Name + PUSH EAX + CALL CreateFileA +@@checkHandle: + CMP EAX,-1 + JZ @@error + + MOV [EBX].TFileRec.Handle,EAX + JMP @@exit + +@@isCon: + MOV [EBX].TFileRec.CloseFunc,offset FileNopProc + CMP EDI,3 + JE @@output + PUSH STD_INPUT_HANDLE + JMP @@1 +@@output: + PUSH STD_OUTPUT_HANDLE +@@1: + CALL GetStdHandle + JMP @@checkHandle + +@@notAssignedError: + MOV EAX,102 + JMP @@errExit + +@@error: + MOV [EBX].TFileRec.Mode,fmClosed + CALL GetLastError +@@errExit: + CALL SetInOutRes + +@@exit: + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +function _ResetFile(var f: TFileRec; recSize: Longint): Integer; +var + m: Byte; +begin + m := FileMode and 3; + if m > 2 then m := 2; + Result := OpenFile(f, recSize, m); +end; + +function _RewritFile(var f: TFileRec; recSize: Longint): Integer; +begin + Result := OpenFile(f, recSize, 3); +end; + +procedure _Seek(var f: TFileRec; recNum: Cardinal); +{$IFDEF LINUX} +begin + if (f.Mode >= fmInput) and (f.Mode <= fmInOut) then + begin + if _lseek(f.Handle, f.RecSize * recNum, SEEK_SET) = -1 then + InOutError; + end + else + SetInOutRes(103); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm +// -> EAX Pointer to file variable +// EDX Record number + + MOV ECX,EAX + MOVZX EAX,[EAX].TFileRec.Mode // check whether file is open + SUB EAX,fmInput + CMP EAX,fmInOut-fmInput + JA @@fileNotOpen + +// SetFilePointer(f.Handle, recNum*f.RecSize, FILE_BEGIN + PUSH FILE_BEGIN // pass dwMoveMethod + MOV EAX,[ECX].TFileRec.RecSize + MUL EDX + PUSH 0 // pass lpDistanceToMoveHigh + PUSH EAX // pass lDistanceToMove + PUSH [ECX].TFileRec.Handle // pass hFile + CALL SetFilePointer // get current position + INC EAX + JZ InOutError + JMP @@exit + +@@fileNotOpen: + MOV EAX,103 + JMP SetInOutRes + +@@exit: +end; +{$ENDIF} + +function _SeekEof(var t: TTextRec): Boolean; +asm +// -> EAX Pointer to text record +// <- AL Boolean result + + PUSH EBX + MOV EBX,EAX +@@loop: + MOV EAX,EBX + CALL _ReadChar + CMP AL,' ' + JA @@endloop + CMP AH,cEOF + JE @@eof + JMP @@loop +@@eof: + MOV AL,1 + JMP @@exit + +@@endloop: + DEC [EBX].TTextRec.BufPos + XOR AL,AL +@@exit: + POP EBX +end; + +function _SeekEoln(var t: TTextRec): Boolean; +asm +// -> EAX Pointer to text record +// <- AL Boolean result + + PUSH EBX + MOV EBX,EAX +@@loop: + MOV EAX,EBX + CALL _ReadChar + CMP AL,' ' + JA @@falseExit + CMP AH,cEOF + JE @@eof + CMP AL,cLF + JE @@trueExit + CMP AL,cCR + JNE @@loop + +@@trueExit: + MOV AL,1 + JMP @@exitloop + +@@falseExit: + XOR AL,AL +@@exitloop: + DEC [EBX].TTextRec.BufPos + JMP @@exit + +@@eof: + MOV AL,1 +@@exit: + POP EBX +end; + +procedure _SetTextBuf(var t: TTextRec; p: Pointer; size: Longint); +begin + t.BufPtr := P; + t.BufSize := size; + t.BufPos := 0; + t.BufEnd := 0; +end; + +procedure _StrLong(val, width: Longint; s: PShortString); +{$IFDEF PUREPASCAL} +var + I: Integer; + sign: Longint; + a: array [0..19] of char; + P: PChar; +begin + sign := val; + val := Abs(val); + I := 0; + repeat + a[I] := Chr((val mod 10) + Ord('0')); + Inc(I); + val := val div 10; + until val = 0; + + if sign < 0 then + begin + a[I] := '-'; + Inc(I); + end; + + if width < I then + width := I; + if width > 255 then + width := 255; + s^[0] := Chr(width); + P := @S^[1]; + while width > I do + begin + P^ := ' '; + Inc(P); + Dec(width); + end; + repeat + Dec(I); + P^ := a[I]; + Inc(P); + until I <= 0; +end; +{$ELSE} +asm +{ PROCEDURE _StrLong( val: Longint; width: Longint; VAR s: ShortString ); + ->EAX Value + EDX Width + ECX Pointer to string } + + PUSH EBX { VAR i: Longint; } + PUSH ESI { VAR sign : Longint; } + PUSH EDI + PUSH EDX { store width on the stack } + SUB ESP,20 { VAR a: array [0..19] of Char; } + + MOV EDI,ECX + + MOV ESI,EAX { sign := val } + + CDQ { val := Abs(val); canned sequence } + XOR EAX,EDX + SUB EAX,EDX + + MOV ECX,10 + XOR EBX,EBX { i := 0; } + +@@repeat1: { repeat } + XOR EDX,EDX { a[i] := Chr( val MOD 10 + Ord('0') );} + + DIV ECX { val := val DIV 10; } + + ADD EDX,'0' + MOV [ESP+EBX],DL + INC EBX { i := i + 1; } + TEST EAX,EAX { until val = 0; } + JNZ @@repeat1 + + TEST ESI,ESI + JGE @@2 + MOV byte ptr [ESP+EBX],'-' + INC EBX +@@2: + MOV [EDI],BL { s^++ := Chr(i); } + INC EDI + + MOV ECX,[ESP+20] { spaceCnt := width - i; } + CMP ECX,255 + JLE @@3 + MOV ECX,255 +@@3: + SUB ECX,EBX + JLE @@repeat2 { for k := 1 to spaceCnt do s^++ := ' '; } + ADD [EDI-1],CL + MOV AL,' ' + REP STOSB + +@@repeat2: { repeat } + MOV AL,[ESP+EBX-1] { s^ := a[i-1]; } + MOV [EDI],AL + INC EDI { s := s + 1 } + DEC EBX { i := i - 1; } + JNZ @@repeat2 { until i = 0; } + + ADD ESP,20+4 + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +procedure _Str0Long(val: Longint; s: PShortString); +begin + _StrLong(val, 0, s); +end; + +procedure _Truncate(var f: TFileRec); +{$IFDEF LINUX} +begin + if (f.Mode and fmOutput) = fmOutput then // fmOutput or fmInOut + begin + if _ftruncate(f.Handle, _lseek(f.Handle, 0, SEEK_CUR)) = -1 then + InOutError; + end + else + SetInOutRes(103); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm +// -> EAX Pointer to text or file variable + + MOVZX EDX,[EAX].TFileRec.Mode // check whether file is open + SUB EDX,fmInput + CMP EDX,fmInOut-fmInput + JA @@fileNotOpen + + PUSH [EAX].TFileRec.Handle + CALL SetEndOfFile + DEC EAX + JZ @@exit + JMP InOutError + +@@fileNotOpen: + MOV EAX,103 + JMP SetInOutRes + +@@exit: +end; +{$ENDIF} + +function _ValLong(const s: String; var code: Integer): Longint; +{$IFDEF PUREPASCAL} +var + I: Integer; + Negative, Hex: Boolean; +begin + I := 1; + code := -1; + Result := 0; + Negative := False; + Hex := False; + while (I <= Length(s)) and (s[I] = ' ') do Inc(I); + if I > Length(s) then Exit; + case s[I] of + '$', + 'x', + 'X': begin + Hex := True; + Inc(I); + end; + '0': begin + Hex := (Length(s) > I) and (UpCase(s[I+1]) = 'X'); + if Hex then Inc(I,2); + end; + '-': begin + Negative := True; + Inc(I); + end; + '+': Inc(I); + end; + if Hex then + while I <= Length(s) do + begin + if Result > (High(Result) div 16) then + begin + code := I; + Exit; + end; + case s[I] of + '0'..'9': Result := Result * 16 + Ord(s[I]) - Ord('0'); + 'a'..'f': Result := Result * 16 + Ord(s[I]) - Ord('a') + 10; + 'A'..'F': Result := Result * 16 + Ord(s[I]) - Ord('A') + 10; + else + code := I; + Exit; + end; + end + else + while I <= Length(s) do + begin + if Result > (High(Result) div 10) then + begin + code := I; + Exit; + end; + Result := Result * 10 + Ord(s[I]) - Ord('0'); + Inc(I); + end; + if Negative then + Result := -Result; + code := 0; +end; +{$ELSE} +asm +{ FUNCTION _ValLong( s: AnsiString; VAR code: Integer ) : Longint; } +{ ->EAX Pointer to string } +{ EDX Pointer to code result } +{ <-EAX Result } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX + PUSH EAX { save for the error case } + + TEST EAX,EAX + JE @@empty + + XOR EAX,EAX + XOR EBX,EBX + MOV EDI,07FFFFFFFH / 10 { limit } + +@@blankLoop: + MOV BL,[ESI] + INC ESI + CMP BL,' ' + JE @@blankLoop + +@@endBlanks: + MOV CH,0 + CMP BL,'-' + JE @@minus + CMP BL,'+' + JE @@plus + CMP BL,'$' + JE @@dollar + + CMP BL, 'x' + JE @@dollar + CMP BL, 'X' + JE @@dollar + CMP BL, '0' + JNE @@firstDigit + MOV BL, [ESI] + INC ESI + CMP BL, 'x' + JE @@dollar + CMP BL, 'X' + JE @@dollar + TEST BL, BL + JE @@endDigits + JMP @@digLoop + +@@firstDigit: + TEST BL,BL + JE @@error + +@@digLoop: + SUB BL,'0' + CMP BL,9 + JA @@error + CMP EAX,EDI { value > limit ? } + JA @@overFlow + LEA EAX,[EAX+EAX*4] + ADD EAX,EAX + ADD EAX,EBX { fortunately, we can't have a carry } + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JNE @@digLoop + +@@endDigits: + DEC CH + JE @@negate + TEST EAX,EAX + JGE @@successExit + JMP @@overFlow + +@@empty: + INC ESI + JMP @@error + +@@negate: + NEG EAX + JLE @@successExit + JS @@successExit { to handle 2**31 correctly, where the negate overflows } + +@@error: +@@overFlow: + POP EBX + SUB ESI,EBX + JMP @@exit + +@@minus: + INC CH +@@plus: + MOV BL,[ESI] + INC ESI + JMP @@firstDigit + +@@dollar: + MOV EDI,0FFFFFFFH + + MOV BL,[ESI] + INC ESI + TEST BL,BL + JZ @@empty + +@@hDigLoop: + CMP BL,'a' + JB @@upper + SUB BL,'a' - 'A' +@@upper: + SUB BL,'0' + CMP BL,9 + JBE @@digOk + SUB BL,'A' - '0' + CMP BL,5 + JA @@error + ADD BL,10 +@@digOk: + CMP EAX,EDI + JA @@overFlow + SHL EAX,4 + ADD EAX,EBX + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JNE @@hDigLoop + +@@successExit: + POP ECX { saved copy of string pointer } + XOR ESI,ESI { signal no error to caller } + +@@exit: + MOV [EDX],ESI + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +function _WriteRec(var f: TFileRec; buffer: Pointer): Pointer; +{$IFDEF LINUX} +var + Dummy: Integer; +begin + _BlockWrite(f, Buffer, 1, Dummy); + Result := @F; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm +// -> EAX Pointer to file variable +// EDX Pointer to buffer +// <- EAX Pointer to file variable + PUSH EBX + + MOV EBX,EAX + + MOVZX EAX,[EAX].TFileRec.Mode + SUB EAX,fmOutput + CMP EAX,fmInOut-fmOutput // File must be fmInOut or fmOutput + JA @@fileNotOpen + +// WriteFile(f.Handle, buffer, f.RecSize, @result, Nil); + + PUSH 0 // space for OS result + MOV EAX,ESP + + PUSH 0 // pass lpOverlapped + PUSH EAX // pass @result + PUSH [EBX].TFileRec.RecSize // pass nNumberOfBytesToRead + PUSH EDX // pass lpBuffer + PUSH [EBX].TFileRec.Handle // pass hFile + CALL WriteFile + POP EDX // pop result + DEC EAX // check EAX = TRUE + JNZ @@error + + CMP EDX,[EBX].TFileRec.RecSize // result = f.RecSize ? + JE @@exit + +@@writeError: + MOV EAX,101 + JMP @@errExit + +@@fileNotOpen: + MOV EAX,5 + JMP @@errExit + +@@error: + CALL GetLastError +@@errExit: + CALL SetInOutRes +@@exit: + MOV EAX,EBX + POP EBX +end; +{$ENDIF} + +// If the file is Output or ErrOutput std variable, try to open it +// Otherwise, runtime error. +function TryOpenForOutput(var t: TTextRec): Boolean; +begin + if (@t = @Output) or (@t = @ErrOutput) then + begin + t.Flags := tfCRLF * Byte(DefaultTextLineBreakStyle); + _RewritText(t); + end; + + Result := t.Mode = fmOutput; + if not Result then + SetInOutRes(105); +end; + +function _WriteBytes(var t: TTextRec; const b; cnt : Longint): Pointer; +{$IFDEF PUREPASCAL} +var + P: PChar; + RemainingBytes: Longint; + Temp: Integer; +begin + Result := @t; + if t.Mode <> fmOutput and not TryOpenForOutput(t) then Exit; + + P := t.BufPtr + t.BufPos; + RemainingBytes := t.BufSize - t.BufPos; + while RemainingBytes <= cnt do + begin + Inc(t.BufPos, RemainingBytes); + Dec(cnt, RemainingBytes); + Move(B, P^, RemainingBytes); + Temp := TTextIOFunc(t.InOutFunc)(t); + if Temp <> 0 then + begin + SetInOutRes(Temp); + Exit; + end; + P := t.BufPtr + t.BufPos; + RemainingBytes := t.BufSize - t.BufPos; + end; + Inc(t.BufPos, cnt); + Move(B, P^, cnt); +end; +{$ELSE} +asm +// -> EAX Pointer to file record +// EDX Pointer to buffer +// ECX Number of bytes to write +// <- EAX Pointer to file record + + PUSH ESI + PUSH EDI + + MOV ESI,EDX + + CMP [EAX].TTextRec.Mode,fmOutput + JE @@loop + PUSH EAX + PUSH EDX + PUSH ECX + CALL TryOpenForOutput + TEST AL,AL + POP ECX + POP EDX + POP EAX + JE @@exit + +@@loop: + MOV EDI,[EAX].TTextRec.BufPtr + ADD EDI,[EAX].TTextRec.BufPos + +// remainingBytes = t.bufSize - t.bufPos + + MOV EDX,[EAX].TTextRec.BufSize + SUB EDX,[EAX].TTextRec.BufPos + +// if (remainingBytes <= cnt) + + CMP EDX,ECX + JG @@1 + +// t.BufPos += remainingBytes, cnt -= remainingBytes + + ADD [EAX].TTextRec.BufPos,EDX + SUB ECX,EDX + +// copy remainingBytes, advancing ESI + + PUSH EAX + PUSH ECX + MOV ECX,EDX + REP MOVSB + + CALL [EAX].TTextRec.InOutFunc + TEST EAX,EAX + JNZ @@error + + POP ECX + POP EAX + JMP @@loop + +@@error: + CALL SetInOutRes + POP ECX + POP EAX + JMP @@exit +@@1: + ADD [EAX].TTextRec.BufPos,ECX + REP MOVSB + +@@exit: + POP EDI + POP ESI +end; +{$ENDIF} + +function _WriteSpaces(var t: TTextRec; cnt: Longint): Pointer; +{$IFDEF PUREPASCAL} +const + s64Spaces = ' '; +begin + Result := @t; + while cnt > 64 do + begin + _WriteBytes(t, s64Spaces, 64); + if InOutRes <> 0 then Exit; + Dec(cnt, 64); + end; + if cnt > 0 then + _WriteBytes(t, s64Spaces, cnt); +end; +{$ELSE} +const + spCnt = 64; +asm +// -> EAX Pointer to text record +// EDX Number of spaces (<= 0: None) + + MOV ECX,EDX +@@loop: +{$IFDEF PIC} + LEA EDX, [EBX] + offset @@spBuf +{$ELSE} + MOV EDX,offset @@spBuf +{$ENDIF} + + CMP ECX,spCnt + JLE @@1 + + SUB ECX,spCnt + PUSH EAX + PUSH ECX + MOV ECX,spCnt + CALL _WriteBytes + CALL SysInit.@GetTLS + CMP [EAX].InOutRes,0 + JNE @@error + POP ECX + POP EAX + JMP @@loop + +@@error: + POP ECX + POP EAX + JMP @@exit + +@@spBuf: // 64 spaces + DB ' '; +@@1: + TEST ECX,ECX + JG _WriteBytes +@@exit: +end; +{$ENDIF} + +function _Write0Char(var t: TTextRec; c: Char): Pointer; +{$IFDEF PUREPASCAL} +var + Temp: Integer; +begin + Result := @t; + if not TryOpenForOutput(t) then Exit; + + if t.BufPos >= t.BufSize then + begin + Temp := TTextIOFunc(t.InOutFunc)(t); + if Temp <> 0 then + begin + SetInOutRes(Temp); + Exit; + end; + end; + + t.BufPtr[t.BufPos] := c; + Inc(t.BufPos); +end; +{$ELSE} +asm +// -> EAX Pointer to text record +// DL Character + + CMP [EAX].TTextRec.Mode,fmOutput + JE @@loop + PUSH EAX + PUSH EDX + CALL TryOpenForOutput + TEST AL,AL + POP EDX + POP EAX + JNE @@loop + JMP @@exit + +@@flush: + PUSH EAX + PUSH EDX + CALL [EAX].TTextRec.InOutFunc + TEST EAX,EAX + JNZ @@error + POP EDX + POP EAX + JMP @@loop + +@@error: + CALL SetInOutRes + POP EDX + POP EAX + JMP @@exit + +@@loop: + MOV ECX,[EAX].TTextRec.BufPos + CMP ECX,[EAX].TTextRec.BufSize + JGE @@flush + + ADD ECX,[EAX].TTextRec.BufPtr + MOV [ECX],DL + + INC [EAX].TTextRec.BufPos +@@exit: +end; +{$ENDIF} + +function _WriteChar(var t: TTextRec; c: Char; width: Integer): Pointer; +begin + _WriteSpaces(t, width-1); + Result := _WriteBytes(t, c, 1); +end; + +function _WriteBool(var t: TTextRec; val: Boolean; width: Longint): Pointer; +const + BoolStrs: array [Boolean] of ShortString = ('FALSE', 'TRUE'); +begin + Result := _WriteString(t, BoolStrs[val], width); +end; + +function _Write0Bool(var t: TTextRec; val: Boolean): Pointer; +begin + Result := _WriteBool(t, val, 0); +end; + +function _WriteLong(var t: TTextRec; val, width: Longint): Pointer; +var + S: string[31]; +begin + Str(val:0, S); + Result := _WriteString(t, S, width); +end; + +function _Write0Long(var t: TTextRec; val: Longint): Pointer; +begin + Result := _WriteLong(t, val, 0); +end; + +function _Write0String(var t: TTextRec; const s: ShortString): Pointer; +begin + Result := _WriteBytes(t, S[1], Byte(S[0])); +end; + +function _WriteString(var t: TTextRec; const s: ShortString; width: Longint): Pointer; +begin + _WriteSpaces(t, Width - Byte(S[0])); + Result := _WriteBytes(t, S[1], Byte(S[0])); +end; + +function _Write0CString(var t: TTextRec; s: PChar): Pointer; +begin + Result := _WriteCString(t, s, 0); +end; + +function _WriteCString(var t: TTextRec; s: PChar; width: Longint): Pointer; +var + len: Longint; +begin + len := _strlen(s); + _WriteSpaces(t, width - len); + Result := _WriteBytes(t, s^, len); +end; + +procedure _Write2Ext; +asm +{ PROCEDURE _Write2Ext( VAR t: Text; val: Extended; width, prec: Longint); + ->EAX Pointer to file record + [ESP+4] Extended value + EDX Field width + ECX precision (<0: scientific, >= 0: fixed point) } + + FLD tbyte ptr [ESP+4] { load value } + SUB ESP,256 { VAR s: String; } + + PUSH EAX + PUSH EDX + +{ Str( val, width, prec, s ); } + + SUB ESP,12 + FSTP tbyte ptr [ESP] { pass value } + MOV EAX,EDX { pass field width } + MOV EDX,ECX { pass precision } + LEA ECX,[ESP+8+12] { pass destination string } + CALL _Str2Ext + +{ Write( t, s, width ); } + + POP ECX { pass width } + POP EAX { pass text } + MOV EDX,ESP { pass string } + CALL _WriteString + + ADD ESP,256 + RET 12 +end; + +procedure _Write1Ext; +asm +{ PROCEDURE _Write1Ext( VAR t: Text; val: Extended; width: Longint); + -> EAX Pointer to file record + [ESP+4] Extended value + EDX Field width } + + OR ECX,-1 + JMP _Write2Ext +end; + +procedure _Write0Ext; +asm +{ PROCEDURE _Write0Ext( VAR t: Text; val: Extended); + ->EAX Pointer to file record + [ESP+4] Extended value } + + MOV EDX,23 { field width } + OR ECX,-1 + JMP _Write2Ext +end; + +function _WriteLn(var t: TTextRec): Pointer; +var + Buf: array [0..1] of Char; +begin + if (t.flags and tfCRLF) <> 0 then + begin + Buf[0] := #13; + Buf[1] := #10; + Result := _WriteBytes(t, Buf, 2); + end + else + begin + Buf[0] := #10; + Result := _WriteBytes(t, Buf, 1); + end; + _Flush(t); +end; + +procedure __CToPasStr(Dest: PShortString; const Source: PChar); +begin + __CLenToPasStr(Dest, Source, 255); +end; + +procedure __CLenToPasStr(Dest: PShortString; const Source: PChar; MaxLen: Integer); +{$IFDEF PUREPASCAL} +var + I: Integer; +begin + I := 0; + if MaxLen > 255 then MaxLen := 255; + while (Source[I] <> #0) and (I <= MaxLen) do + begin + Dest^[I+1] := Source[I]; + Inc(I); + end; + if I > 0 then Dec(I); + Byte(Dest^[0]) := I; +end; +{$ELSE} +asm +{ ->EAX Pointer to destination } +{ EDX Pointer to source } +{ ECX cnt } + + PUSH EBX + PUSH EAX { save destination } + + CMP ECX,255 + JBE @@loop + MOV ECX,255 +@@loop: + MOV BL,[EDX] { ch = *src++; } + INC EDX + TEST BL,BL { if (ch == 0) break } + JE @@endLoop + INC EAX { *++dest = ch; } + MOV [EAX],BL + DEC ECX { while (--cnt != 0) } + JNZ @@loop + +@@endLoop: + POP EDX + SUB EAX,EDX + MOV [EDX],AL + POP EBX +end; +{$ENDIF} + +procedure __ArrayToPasStr(Dest: PShortString; const Source: PChar; Len: Integer); +begin + if Len > 255 then Len := 255; + Byte(Dest^[0]) := Len; + Move(Source^, Dest^[1], Len); +end; + +procedure __PasToCStr(const Source: PShortString; const Dest: PChar); +begin + Move(Source^[1], Dest^, Byte(Source^[0])); + Dest[Byte(Source^[0])] := #0; +end; + +procedure _SetElem; +asm + { PROCEDURE _SetElem( VAR d: SET; elem, size: Byte); } + { EAX = dest address } + { DL = element number } + { CL = size of set } + + PUSH EBX + PUSH EDI + + MOV EDI,EAX + + XOR EBX,EBX { zero extend set size into ebx } + MOV BL,CL + MOV ECX,EBX { and use it for the fill } + + XOR EAX,EAX { for zero fill } + REP STOSB + + SUB EDI,EBX { point edi at beginning of set again } + + INC EAX { eax is still zero - make it 1 } + MOV CL,DL + ROL AL,CL { generate a mask } + SHR ECX,3 { generate the index } + CMP ECX,EBX { if index >= siz then exit } + JAE @@exit + OR [EDI+ECX],AL{ set bit } + +@@exit: + POP EDI + POP EBX +end; + +procedure _SetRange; +asm +{ PROCEDURE _SetRange( lo, hi, size: Byte; VAR d: SET ); } +{ ->AL low limit of range } +{ DL high limit of range } +{ ECX Pointer to set } +{ AH size of set } + + PUSH EBX + PUSH ESI + PUSH EDI + + XOR EBX,EBX { EBX = set size } + MOV BL,AH + MOVZX ESI,AL { ESI = low zero extended } + MOVZX EDX,DL { EDX = high zero extended } + MOV EDI,ECX + +{ clear the set } + + MOV ECX,EBX + XOR EAX,EAX + REP STOSB + +{ prepare for setting the bits } + + SUB EDI,EBX { point EDI at start of set } + SHL EBX,3 { EBX = highest bit in set + 1 } + CMP EDX,EBX + JB @@inrange + LEA EDX,[EBX-1] { ECX = highest bit in set } + +@@inrange: + CMP ESI,EDX { if lo > hi then exit; } + JA @@exit + + DEC EAX { loMask = 0xff << (lo & 7) } + MOV ECX,ESI + AND CL,07H + SHL AL,CL + + SHR ESI,3 { loIndex = lo >> 3; } + + MOV CL,DL { hiMask = 0xff >> (7 - (hi & 7)); } + NOT CL + AND CL,07 + SHR AH,CL + + SHR EDX,3 { hiIndex = hi >> 3; } + + ADD EDI,ESI { point EDI to set[loIndex] } + MOV ECX,EDX + SUB ECX,ESI { if ((inxDiff = (hiIndex - loIndex)) == 0) } + JNE @@else + + AND AL,AH { set[loIndex] = hiMask & loMask; } + MOV [EDI],AL + JMP @@exit + +@@else: + STOSB { set[loIndex++] = loMask; } + DEC ECX + MOV AL,0FFH { while (loIndex < hiIndex) } + REP STOSB { set[loIndex++] = 0xff; } + MOV [EDI],AH { set[hiIndex] = hiMask; } + +@@exit: + POP EDI + POP ESI + POP EBX +end; + +procedure _SetEq; +asm +{ FUNCTION _SetEq( CONST l, r: Set; size: Byte): ConditionCode; } +{ EAX = left operand } +{ EDX = right operand } +{ CL = size of set } + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + AND ECX,0FFH + REP CMPSB + + POP EDI + POP ESI +end; + +procedure _SetLe; +asm +{ FUNCTION _SetLe( CONST l, r: Set; size: Byte): ConditionCode; } +{ EAX = left operand } +{ EDX = right operand } +{ CL = size of set (>0 && <= 32) } + +@@loop: + MOV CH,[EDX] + NOT CH + AND CH,[EAX] + JNE @@exit + INC EDX + INC EAX + DEC CL + JNZ @@loop +@@exit: +end; + +procedure _SetIntersect; +asm +{ PROCEDURE _SetIntersect( VAR dest: Set; CONST src: Set; size: Byte);} +{ EAX = destination operand } +{ EDX = source operand } +{ CL = size of set (0 < size <= 32) } + +@@loop: + MOV CH,[EDX] + INC EDX + AND [EAX],CH + INC EAX + DEC CL + JNZ @@loop +end; + +procedure _SetIntersect3; +asm +{ PROCEDURE _SetIntersect3( VAR dest: Set; CONST src: Set; size: Longint; src2: Set);} +{ EAX = destination operand } +{ EDX = source operand } +{ ECX = size of set (0 < size <= 32) } +{ [ESP+4] = 2nd source operand } + + PUSH EBX + PUSH ESI + MOV ESI,[ESP+8+4] +@@loop: + MOV BL,[EDX+ECX-1] + AND BL,[ESI+ECX-1] + MOV [EAX+ECX-1],BL + DEC ECX + JNZ @@loop + + POP ESI + POP EBX +end; + +procedure _SetUnion; +asm +{ PROCEDURE _SetUnion( VAR dest: Set; CONST src: Set; size: Byte); } +{ EAX = destination operand } +{ EDX = source operand } +{ CL = size of set (0 < size <= 32) } + +@@loop: + MOV CH,[EDX] + INC EDX + OR [EAX],CH + INC EAX + DEC CL + JNZ @@loop +end; + +procedure _SetUnion3; +asm +{ PROCEDURE _SetUnion3( VAR dest: Set; CONST src: Set; size: Longint; src2: Set);} +{ EAX = destination operand } +{ EDX = source operand } +{ ECX = size of set (0 < size <= 32) } +{ [ESP+4] = 2nd source operand } + + PUSH EBX + PUSH ESI + MOV ESI,[ESP+8+4] +@@loop: + MOV BL,[EDX+ECX-1] + OR BL,[ESI+ECX-1] + MOV [EAX+ECX-1],BL + DEC ECX + JNZ @@loop + + POP ESI + POP EBX +end; + +procedure _SetSub; +asm +{ PROCEDURE _SetSub( VAR dest: Set; CONST src: Set; size: Byte); } +{ EAX = destination operand } +{ EDX = source operand } +{ CL = size of set (0 < size <= 32) } + +@@loop: + MOV CH,[EDX] + NOT CH + INC EDX + AND [EAX],CH + INC EAX + DEC CL + JNZ @@loop +end; + +procedure _SetSub3; +asm +{ PROCEDURE _SetSub3( VAR dest: Set; CONST src: Set; size: Longint; src2: Set);} +{ EAX = destination operand } +{ EDX = source operand } +{ ECX = size of set (0 < size <= 32) } +{ [ESP+4] = 2nd source operand } + + PUSH EBX + PUSH ESI + MOV ESI,[ESP+8+4] +@@loop: + MOV BL,[ESI+ECX-1] + NOT BL + AND BL,[EDX+ECX-1] + MOV [EAX+ECX-1],BL + DEC ECX + JNZ @@loop + + POP ESI + POP EBX +end; + +procedure _SetExpand; +asm +{ PROCEDURE _SetExpand( CONST src: Set; VAR dest: Set; lo, hi: Byte); } +{ ->EAX Pointer to source (packed set) } +{ EDX Pointer to destination (expanded set) } +{ CH high byte of source } +{ CL low byte of source } + +{ algorithm: } +{ clear low bytes } +{ copy high-low+1 bytes } +{ clear 31-high bytes } + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + MOV EDX,ECX { save low, high in dl, dh } + XOR ECX,ECX + XOR EAX,EAX + + MOV CL,DL { clear low bytes } + REP STOSB + + MOV CL,DH { copy high - low bytes } + SUB CL,DL + REP MOVSB + + MOV CL,32 { copy 32 - high bytes } + SUB CL,DH + REP STOSB + + POP EDI + POP ESI +end; + +procedure _EmitDigits; +const + tenE17: Double = 1e17; + tenE18: Double = 1e18; +asm +// -> FST(0) Value, 0 <= value < 10.0 +// EAX Count of digits to generate +// EDX Pointer to digit buffer + + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX +{$ELSE} + XOR EBX,EBX +{$ENDIF} + PUSH EDI + MOV EDI,EDX + MOV ECX,EAX + + SUB ESP,10 // VAR bcdBuf: array [0..9] of Byte + MOV byte ptr [EDI],'0' // digBuf[0] := '0'// + FMUL qword ptr [EBX] + offset tenE17 // val := Round(val*1e17); + FRNDINT + + FCOM qword ptr [EBX] + offset tenE18 // if val >= 1e18 then + FSTSW AX + SAHF + JB @@1 + + FSUB qword ptr [EBX] + offset tenE18 // val := val - 1e18; + MOV byte ptr [EDI],'1' // digBuf[0] := '1'; +@@1: + FBSTP tbyte ptr [ESP] // store packed bcd digits in bcdBuf + + MOV EDX,8 + INC EDI + +@@2: + WAIT + MOV AL,[ESP+EDX] // unpack 18 bcd digits in 9 bytes + MOV AH,AL // into 9 words = 18 bytes + SHR AL,4 + AND AH,0FH + ADD AX,'00' + STOSW + DEC EDX + JNS @@2 + + SUB ECX,18 // we need at least digCnt digits + JL @@3 // we have generated 18 + + MOV AL,'0' // if this is not enough, append zeroes + REP STOSB + JMP @@4 // in this case, we don't need to round + +@@3: + ADD EDI,ECX // point EDI to the round digit + CMP byte ptr [EDI],'5' + JL @@4 +@@5: + DEC EDI + INC byte ptr [EDI] + CMP byte ptr [EDI],'9' + JLE @@4 + MOV byte ptr [EDI],'0' + JMP @@5 + +@@4: + ADD ESP,10 + POP EDI + POP EBX +end; + +procedure _ScaleExt; +asm +// -> FST(0) Value +// <- EAX exponent (base 10) +// FST(0) Value / 10**eax +// PIC safe - uses EBX, but only call is to _POW10, which fixes up EBX itself + + PUSH EBX + SUB ESP,12 + + XOR EBX,EBX + +@@normLoop: // loop necessary for denormals + + FLD ST(0) + FSTP tbyte ptr [ESP] + MOV AX,[ESP+8] + TEST AX,AX + JE @@testZero +@@cont: + SUB AX,3FFFH + MOV DX,4D10H // log10(2) * 2**16 + IMUL DX + MOVSX EAX,DX // exp10 = exp2 * log10(2) + NEG EAX + JE @@exit + SUB EBX,EAX + CALL _Pow10 + JMP @@normLoop + +@@testZero: + CMP dword ptr [ESP+4],0 + JNE @@cont + CMP dword ptr [ESP+0],0 + JNE @@cont + +@@exit: + ADD ESP,12 + MOV EAX,EBX + POP EBX +end; + +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 ); +const + MAXDIGS = 256; +asm +// -> [ESP+4] Extended value +// EAX Width +// EDX Precision +// ECX Pointer to string + + FLD tbyte ptr [ESP+4] + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV ESI,EDX + PUSH ECX // save string pointer + SUB ESP,MAXDIGS // VAR digBuf: array [0..MAXDIGS-1] of Char + +// limit width to 255 + + CMP EBX,255 // if width > 255 then width := 255; + JLE @@1 + MOV EBX,255 +@@1: + +// save sign bit in bit 0 of EDI, take absolute value of val, check for +// Nan and infinity. + + FLD ST(0) + FSTP tbyte ptr [ESP] + XOR EAX,EAX + MOV AX,word ptr [ESP+8] + MOV EDI,EAX + SHR EDI,15 + AND AX,7FFFH + CMP AX,7FFFH + JE @@nanInf + FABS + +// if precision < 0 then do scientific else do fixed; + + TEST ESI,ESI + JGE @@fixed + +// the following call finds a decimal exponent and a reduced +// mantissa such that val = mant * 10**exp + + CALL _ScaleExt // val is FST(0), exp is EAX + +// for scientific notation, we have width - 8 significant digits +// however, we can not have less than 2 or more than 18 digits. + +@@scientific: + + MOV ESI,EBX // digCnt := width - 8; + SUB ESI,8 + CMP ESI,2 // if digCnt < 2 then digCnt := 2 + JGE @@2 + MOV ESI,2 + JMP @@3 +@@2: + CMP ESI,18 // else if digCnt > 18 then digCnt := 18; + JLE @@3 + MOV ESI,18 +@@3: + +// _EmitDigits( val, digCnt, digBuf ) + + MOV EDX,ESP // pass digBuf + PUSH EAX // save exponent + MOV EAX,ESI // pass digCnt + CALL _EmitDigits // convert val to ASCII + + MOV EDX,EDI // save sign in EDX + MOV EDI,[ESP+MAXDIGS+4] // load result string pointer + + MOV [EDI],BL // length of result string := width + INC EDI + + MOV AL,' ' // prepare for leading blanks and sign + + MOV ECX,EBX // blankCnt := width - digCnt - 8 + SUB ECX,ESI + SUB ECX,8 + JLE @@4 + + REP STOSB // emit blankCnt blanks +@@4: + SUB [EDI-1],CL // if blankCnt < 0, adjust length + + TEST DL,DL // emit the sign (' ' or '-') + JE @@5 + MOV AL,'-' +@@5: + STOSB + + POP EAX + MOV ECX,ESI // emit digCnt digits + MOV ESI,ESP // point ESI to digBuf + + CMP byte ptr [ESI],'0' + JE @@5a // if rounding overflowed, adjust exponent and ESI + INC EAX + DEC ESI +@@5a: + INC ESI + + MOVSB // emit one digit + MOV byte ptr [EDI],'.' // emit dot + INC EDI // adjust dest pointer + DEC ECX // adjust count + + REP MOVSB + + MOV byte ptr [EDI],'E' + + MOV CL,'+' // emit sign of exponent ('+' or '-') + TEST EAX,EAX + JGE @@6 + MOV CL,'-' + NEG EAX +@@6: + MOV [EDI+1],CL + + XOR EDX,EDX // emit exponent + MOV CX,10 + DIV CX + ADD DL,'0' + MOV [EDI+5],DL + + XOR EDX,EDX + DIV CX + ADD DL,'0' + MOV [EDI+4],DL + + XOR EDX,EDX + DIV CX + ADD DL,'0' + MOV [EDI+3],DL + + ADD AL,'0' + MOV [EDI+2],AL + + JMP @@exit + +@@fixed: + +// FST(0) = value >= 0.0 +// EBX = width +// ESI = precision +// EDI = sign + + CMP ESI,MAXDIGS-40 // else if precision > MAXDIGS-40 then precision := MAXDIGS-40; + JLE @@6a + MOV ESI,MAXDIGS-40 +@@6a: +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + FCOM qword ptr [EAX] + offset Ten + POP EAX +{$ELSE} + FCOM qword ptr ten +{$ENDIF} + FSTSW AX + SAHF + MOV EAX,0 + JB @@7 + + CALL _ScaleExt // val is FST(0), exp is EAX + + CMP EAX,35 // if val is too large, use scientific + JG @@scientific + +@@7: +// FST(0) = scaled value, 0.0 <= value < 10.0 +// EAX = exponent, 0 <= exponent + +// intDigCnt := exponent + 1; + + INC EAX + +// _EmitDigits( value, intDigCnt + precision, digBuf ); + + MOV EDX,ESP + PUSH EAX + ADD EAX,ESI + CALL _EmitDigits + POP EAX + +// Now we need to check whether rounding to the right number of +// digits overflowed, and if so, adjust things accordingly + + MOV EDX,ESI // put precision in EDX + MOV ESI,ESP // point EDI to digBuf + CMP byte ptr [ESI],'0' + JE @@8 + INC EAX + DEC ESI +@@8: + INC ESI + + MOV ECX,EAX // numWidth := sign + intDigCnt; + ADD ECX,EDI + + TEST EDX,EDX // if precision > 0 then + JE @@9 + INC ECX // numWidth := numWidth + 1 + precision + ADD ECX,EDX + + CMP EBX,ECX // if width <= numWidth + JG @@9 + MOV EBX,ECX // width := numWidth +@@9: + PUSH EAX + PUSH EDI + + MOV EDI,[ESP+MAXDIGS+2*4] // point EDI to dest string + + MOV [EDI],BL // store final length in dest string + INC EDI + + SUB EBX,ECX // width := width - numWidth + MOV ECX,EBX + JLE @@10 + + MOV AL,' ' // emit width blanks + REP STOSB +@@10: + SUB [EDI-1],CL // if blankCnt < 0, adjust length + POP EAX + POP ECX + + TEST EAX,EAX + JE @@11 + + MOV byte ptr [EDI],'-' + INC EDI + +@@11: + REP MOVSB // copy intDigCnt digits + + TEST EDX,EDX // if precision > 0 then + JE @@12 + + MOV byte ptr [EDI],'.' // emit '.' + INC EDI + MOV ECX,EDX // emit precision digits + REP MOVSB + +@@12: + +@@exit: + ADD ESP,MAXDIGS + POP ECX + POP EDI + POP ESI + POP EBX + RET 12 + +@@nanInf: +// here: EBX = width, ECX = string pointer, EDI = sign, [ESP] = value + +{$IFDEF PIC} + CALL GetGOT +{$ELSE} + XOR EAX,EAX +{$ENDIF} + FSTP ST(0) + CMP dword ptr [ESP+4],80000000H + LEA ESI,[EAX] + offset nanStr + JNE @@13 + DEC EDI + LEA ESI,[EAX] + offset plusInfStr + JNZ @@13 + LEA ESI,[EAX] + offset minInfStr +@@13: + MOV EDI,ECX + MOV ECX,EBX + MOV [EDI],CL + INC EDI + SUB CL,[ESI] + JBE @@14 + MOV AL,' ' + REP STOSB +@@14: + SUB [EDI-1],CL + MOV CL,[ESI] + INC ESI + REP MOVSB + + JMP @@exit +end; + +procedure _Str0Ext; +asm +// -> [ESP+4] Extended value +// EAX Pointer to string + + MOV ECX,EAX // pass string + MOV EAX,23 // pass default field width + OR EDX,-1 // pass precision -1 + JMP _Str2Ext +end; + +procedure _Str1Ext;//( val: Extended; width: Longint; var s: String ); +asm +// -> [ESP+4] Extended value +// EAX Field width +// EDX Pointer to string + + MOV ECX,EDX + OR EDX,-1 // pass precision -1 + JMP _Str2Ext +end; + +//function _ValExt( s: AnsiString; VAR code: Integer ) : Extended; +procedure _ValExt; +asm +// -> EAX Pointer to string +// EDX Pointer to code result +// <- FST(0) Result + + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX +{$ELSE} + XOR EBX,EBX +{$ENDIF} + PUSH ESI + PUSH EDI + + PUSH EBX // SaveGOT = ESP+8 + MOV ESI,EAX + PUSH EAX // save for the error case + + FLDZ + XOR EAX,EAX + XOR EBX,EBX + XOR EDI,EDI + + PUSH EBX // temp to get digs to fpu + + TEST ESI,ESI + JE @@empty + +@@blankLoop: + MOV BL,[ESI] + INC ESI + CMP BL,' ' + JE @@blankLoop + +@@endBlanks: + MOV CH,0 + CMP BL,'-' + JE @@minus + CMP BL,'+' + JE @@plus + JMP @@firstDigit + +@@minus: + INC CH +@@plus: + MOV BL,[ESI] + INC ESI + +@@firstDigit: + TEST BL,BL + JE @@error + + MOV EDI,[ESP+8] // SaveGOT + +@@digLoop: + SUB BL,'0' + CMP BL,9 + JA @@dotExp + FMUL qword ptr [EDI] + offset Ten + MOV dword ptr [ESP],EBX + FIADD dword ptr [ESP] + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JNE @@digLoop + JMP @@prefinish + +@@dotExp: + CMP BL,'.' - '0' + JNE @@exp + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JE @@prefinish + +// EDI = SaveGot +@@fracDigLoop: + SUB BL,'0' + CMP BL,9 + JA @@exp + FMUL qword ptr [EDI] + offset Ten + MOV dword ptr [ESP],EBX + FIADD dword ptr [ESP] + DEC EAX + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JNE @@fracDigLoop + +@@prefinish: + XOR EDI,EDI + JMP @@finish + +@@exp: + CMP BL,'E' - '0' + JE @@foundExp + CMP BL,'e' - '0' + JNE @@error +@@foundExp: + MOV BL,[ESI] + INC ESI + MOV AH,0 + CMP BL,'-' + JE @@minusExp + CMP BL,'+' + JE @@plusExp + JMP @@firstExpDigit +@@minusExp: + INC AH +@@plusExp: + MOV BL,[ESI] + INC ESI +@@firstExpDigit: + SUB BL,'0' + CMP BL,9 + JA @@error + MOV EDI,EBX + MOV BL,[ESI] + INC ESI + TEST BL,BL + JZ @@endExp +@@expDigLoop: + SUB BL,'0' + CMP BL,9 + JA @@error + LEA EDI,[EDI+EDI*4] + ADD EDI,EDI + ADD EDI,EBX + MOV BL,[ESI] + INC ESI + TEST BL,BL + JNZ @@expDigLoop +@@endExp: + DEC AH + JNZ @@expPositive + NEG EDI +@@expPositive: + MOVSX EAX,AL + +@@finish: + ADD EAX,EDI + PUSH EDX + PUSH ECX + CALL _Pow10 + POP ECX + POP EDX + + DEC CH + JE @@negate + +@@successExit: + + ADD ESP,12 // pop temp and saved copy of string pointer + + XOR ESI,ESI // signal no error to caller + +@@exit: + MOV [EDX],ESI + + POP EDI + POP ESI + POP EBX + RET + +@@negate: + FCHS + JMP @@successExit + +@@empty: + INC ESI + +@@error: + POP EAX + POP EBX + SUB ESI,EBX + ADD ESP,4 + JMP @@exit +end; + +procedure FPower10; +asm + JMP _Pow10 +end; + +//function _Pow10(val: Extended; Power: Integer): Extended; +procedure _Pow10; +asm +// -> FST(0) val +// -> EAX Power +// <- FST(0) val * 10**Power + +// This routine generates 10**power with no more than two +// floating point multiplications. Up to 10**31, no multiplications +// are needed. + + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX +{$ELSE} + XOR EBX,EBX +{$ENDIF} + TEST EAX,EAX + JL @@neg + JE @@exit + CMP EAX,5120 + JGE @@inf + MOV EDX,EAX + AND EDX,01FH + LEA EDX,[EDX+EDX*4] + FLD tbyte ptr @@tab0[EBX+EDX*2] + + FMULP + + SHR EAX,5 + JE @@exit + + MOV EDX,EAX + AND EDX,0FH + JE @@skip2ndMul + LEA EDX,[EDX+EDX*4] + FLD tbyte ptr @@tab1-10[EBX+EDX*2] + FMULP + +@@skip2ndMul: + + SHR EAX,4 + JE @@exit + LEA EAX,[EAX+EAX*4] + FLD tbyte ptr @@tab2-10[EBX+EAX*2] + FMULP + JMP @@exit + +@@neg: + NEG EAX + CMP EAX,5120 + JGE @@zero + MOV EDX,EAX + AND EDX,01FH + LEA EDX,[EDX+EDX*4] + FLD tbyte ptr @@tab0[EBX+EDX*2] + FDIVP + + SHR EAX,5 + JE @@exit + + MOV EDX,EAX + AND EDX,0FH + JE @@skip2ndDiv + LEA EDX,[EDX+EDX*4] + FLD tbyte ptr @@tab1-10[EBX+EDX*2] + FDIVP + +@@skip2ndDiv: + + SHR EAX,4 + JE @@exit + LEA EAX,[EAX+EAX*4] + FLD tbyte ptr @@tab2-10[EBX+EAX*2] + FDIVP + + JMP @@exit + +@@inf: + FLD tbyte ptr @@infval[EBX] + JMP @@exit + +@@zero: + FLDZ + +@@exit: + POP EBX + RET + +@@infval: DW $0000,$0000,$0000,$8000,$7FFF +@@tab0: DW $0000,$0000,$0000,$8000,$3FFF // 10**0 + DW $0000,$0000,$0000,$A000,$4002 // 10**1 + DW $0000,$0000,$0000,$C800,$4005 // 10**2 + DW $0000,$0000,$0000,$FA00,$4008 // 10**3 + DW $0000,$0000,$0000,$9C40,$400C // 10**4 + DW $0000,$0000,$0000,$C350,$400F // 10**5 + DW $0000,$0000,$0000,$F424,$4012 // 10**6 + DW $0000,$0000,$8000,$9896,$4016 // 10**7 + DW $0000,$0000,$2000,$BEBC,$4019 // 10**8 + DW $0000,$0000,$2800,$EE6B,$401C // 10**9 + DW $0000,$0000,$F900,$9502,$4020 // 10**10 + DW $0000,$0000,$B740,$BA43,$4023 // 10**11 + DW $0000,$0000,$A510,$E8D4,$4026 // 10**12 + DW $0000,$0000,$E72A,$9184,$402A // 10**13 + DW $0000,$8000,$20F4,$B5E6,$402D // 10**14 + DW $0000,$A000,$A931,$E35F,$4030 // 10**15 + DW $0000,$0400,$C9BF,$8E1B,$4034 // 10**16 + DW $0000,$C500,$BC2E,$B1A2,$4037 // 10**17 + DW $0000,$7640,$6B3A,$DE0B,$403A // 10**18 + DW $0000,$89E8,$2304,$8AC7,$403E // 10**19 + DW $0000,$AC62,$EBC5,$AD78,$4041 // 10**20 + DW $8000,$177A,$26B7,$D8D7,$4044 // 10**21 + DW $9000,$6EAC,$7832,$8786,$4048 // 10**22 + DW $B400,$0A57,$163F,$A968,$404B // 10**23 + DW $A100,$CCED,$1BCE,$D3C2,$404E // 10**24 + DW $84A0,$4014,$5161,$8459,$4052 // 10**25 + DW $A5C8,$9019,$A5B9,$A56F,$4055 // 10**26 + DW $0F3A,$F420,$8F27,$CECB,$4058 // 10**27 + DW $0984,$F894,$3978,$813F,$405C // 10**28 + DW $0BE5,$36B9,$07D7,$A18F,$405F // 10**29 + DW $4EDF,$0467,$C9CD,$C9F2,$4062 // 10**30 + DW $2296,$4581,$7C40,$FC6F,$4065 // 10**31 + +@@tab1: DW $B59E,$2B70,$ADA8,$9DC5,$4069 // 10**32 + DW $A6D5,$FFCF,$1F49,$C278,$40D3 // 10**64 + DW $14A3,$C59B,$AB16,$EFB3,$413D // 10**96 + DW $8CE0,$80E9,$47C9,$93BA,$41A8 // 10**128 + DW $17AA,$7FE6,$A12B,$B616,$4212 // 10**160 + DW $556B,$3927,$F78D,$E070,$427C // 10**192 + DW $C930,$E33C,$96FF,$8A52,$42E7 // 10**224 + DW $DE8E,$9DF9,$EBFB,$AA7E,$4351 // 10**256 + DW $2F8C,$5C6A,$FC19,$D226,$43BB // 10**288 + DW $E376,$F2CC,$2F29,$8184,$4426 // 10**320 + DW $0AD2,$DB90,$2700,$9FA4,$4490 // 10**352 + DW $AA17,$AEF8,$E310,$C4C5,$44FA // 10**384 + DW $9C59,$E9B0,$9C07,$F28A,$4564 // 10**416 + DW $F3D4,$EBF7,$4AE1,$957A,$45CF // 10**448 + DW $A262,$0795,$D8DC,$B83E,$4639 // 10**480 + +@@tab2: DW $91C7,$A60E,$A0AE,$E319,$46A3 // 10**512 + DW $0C17,$8175,$7586,$C976,$4D48 // 10**1024 + DW $A7E4,$3993,$353B,$B2B8,$53ED // 10**1536 + DW $5DE5,$C53D,$3B5D,$9E8B,$5A92 // 10**2048 + DW $F0A6,$20A1,$54C0,$8CA5,$6137 // 10**2560 + DW $5A8B,$D88B,$5D25,$F989,$67DB // 10**3072 + DW $F3F8,$BF27,$C8A2,$DD5D,$6E80 // 10**3584 + DW $979B,$8A20,$5202,$C460,$7525 // 10**4096 + DW $59F0,$6ED5,$1162,$AE35,$7BCA // 10**4608 +end; + +const + RealBias = 129; + ExtBias = $3FFF; + +procedure _Real2Ext;//( val : Real ) : Extended; +asm +// -> EAX Pointer to value +// <- FST(0) Result + +// the REAL data type has the following format: +// 8 bit exponent (bias 129), 39 bit fraction, 1 bit sign + + MOV DH,[EAX+5] // isolate the sign bit + AND DH,80H + MOV DL,[EAX] // fetch exponent + TEST DL,DL // exponent zero means number is zero + JE @@zero + + ADD DX,ExtBias-RealBias // adjust exponent bias + + PUSH EDX // the exponent is at the highest address + + MOV EDX,[EAX+2] // load high fraction part, set hidden bit + OR EDX,80000000H + PUSH EDX // push high fraction part + + MOV DL,[EAX+1] // load remaining low byte of fraction + SHL EDX,24 // clear low 24 bits + PUSH EDX + + FLD tbyte ptr [ESP] // pop result onto chip + ADD ESP,12 + + RET + +@@zero: + FLDZ + RET +end; + +procedure _Ext2Real;//( val : Extended ) : Real; +asm +// -> FST(0) Value +// EAX Pointer to result + + PUSH EBX + + SUB ESP,12 + FSTP tbyte ptr [ESP] + + POP EBX // EBX is low half of fraction + POP EDX // EDX is high half of fraction + POP ECX // CX is exponent and sign + + SHR EBX,24 // set carry to last bit shifted out + ADC BL,0 // if bit was 1, round up + ADC EDX,0 + ADC CX,0 + JO @@overflow + + ADD EDX,EDX // shift fraction 1 bit left + ADD CX,CX // shift sign bit into carry + RCR EDX,1 // attach sign bit to fraction + SHR CX,1 // restore exponent, deleting sign + + SUB CX,ExtBias-RealBias // adjust exponent + JLE @@underflow + TEST CH,CH // CX must be in 1..255 + JG @@overflow + + MOV [EAX],CL + MOV [EAX+1],BL + MOV [EAX+2],EDX + + POP EBX + RET + +@@underflow: + XOR ECX,ECX + MOV [EAX],ECX + MOV [EAX+4],CX + POP EBX + RET + +@@overflow: + POP EBX + MOV AL,8 + JMP Error +end; + +const + ovtInstanceSize = -8; { Offset of instance size in OBJECTs } + ovtVmtPtrOffs = -4; + +procedure _ObjSetup; +asm +{ FUNCTION _ObjSetup( self: ^OBJECT; vmt: ^VMT): ^OBJECT; } +{ ->EAX Pointer to self (possibly nil) } +{ EDX Pointer to vmt (possibly nil) } +{ <-EAX Pointer to self } +{ EDX <> 0: an object was allocated } +{ Z-Flag Set: failure, Cleared: Success } + + CMP EDX,1 { is vmt = 0, indicating a call } + JAE @@skip1 { from a constructor? } + RET { return immediately with Z-flag cleared } + +@@skip1: + PUSH ECX + TEST EAX,EAX { is self already allocated? } + JNE @@noAlloc + MOV EAX,[EDX].ovtInstanceSize + TEST EAX,EAX + JE @@zeroSize + PUSH EDX + CALL _GetMem + POP EDX + TEST EAX,EAX + JZ @@fail + + { Zero fill the memory } + PUSH EDI + MOV ECX,[EDX].ovtInstanceSize + MOV EDI,EAX + PUSH EAX + XOR EAX,EAX + SHR ECX,2 + REP STOSD + MOV ECX,[EDX].ovtInstanceSize + AND ECX,3 + REP STOSB + POP EAX + POP EDI + + MOV ECX,[EDX].ovtVmtPtrOffs + TEST ECX,ECX + JL @@skip + MOV [EAX+ECX],EDX { store vmt in object at this offset } +@@skip: + TEST EAX,EAX { clear zero flag } + POP ECX + RET + +@@fail: + XOR EDX,EDX + POP ECX + RET + +@@zeroSize: + XOR EDX,EDX + CMP EAX,1 { clear zero flag - we were successful (kind of) } + POP ECX + RET + +@@noAlloc: + MOV ECX,[EDX].ovtVmtPtrOffs + TEST ECX,ECX + JL @@exit + MOV [EAX+ECX],EDX { store vmt in object at this offset } +@@exit: + XOR EDX,EDX { clear allocated flag } + TEST EAX,EAX { clear zero flag } + POP ECX +end; + +procedure _ObjCopy; +asm +{ PROCEDURE _ObjCopy( dest, src: ^OBJECT; vmtPtrOff: Longint); } +{ ->EAX Pointer to destination } +{ EDX Pointer to source } +{ ECX Offset of vmt in those objects. } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EDX + MOV EDI,EAX + + LEA EAX,[EDI+ECX] { remember pointer to dest vmt pointer } + MOV EDX,[EAX] { fetch dest vmt pointer } + + MOV EBX,[EDX].ovtInstanceSize + + MOV ECX,EBX { copy size DIV 4 dwords } + SHR ECX,2 + REP MOVSD + + MOV ECX,EBX { copy size MOD 4 bytes } + AND ECX,3 + REP MOVSB + + MOV [EAX],EDX { restore dest vmt } + + POP EDI + POP ESI + POP EBX +end; + +procedure _Fail; +asm +{ FUNCTION _Fail( self: ^OBJECT; allocFlag:Longint): ^OBJECT; } +{ ->EAX Pointer to self (possibly nil) } +{ EDX <> 0: Object must be deallocated } +{ <-EAX Nil } + + TEST EDX,EDX + JE @@exit { if no object was allocated, return } + CALL _FreeMem +@@exit: + XOR EAX,EAX +end; + +{$IFDEF MSWINDOWS} +function GetKeyboardType(nTypeFlag: Integer): Integer; stdcall; + external user name 'GetKeyboardType'; + +function _isNECWindows: Boolean; +var + KbSubType: Integer; +begin + Result := False; + if GetKeyboardType(0) = $7 then + begin + KbSubType := GetKeyboardType(1) and $FF00; + if (KbSubType = $0D00) or (KbSubType = $0400) then + Result := True; + end; +end; + +const + HKEY_LOCAL_MACHINE = $80000002; + +// workaround a Japanese Win95 bug +procedure _FpuMaskInit; +const + KEY_QUERY_VALUE = $00000001; + REG_DWORD = 4; + FPUMASKKEY = 'SOFTWARE\Borland\Delphi\RTL'; + FPUMASKNAME = 'FPUMaskValue'; +var + phkResult: LongWord; + lpData, DataSize: Longint; +begin + lpData := Default8087CW; + + if RegOpenKeyEx(HKEY_LOCAL_MACHINE, FPUMASKKEY, 0, KEY_QUERY_VALUE, phkResult) = 0 then + try + DataSize := Sizeof(lpData); + RegQueryValueEx(phkResult, FPUMASKNAME, nil, nil, @lpData, @DataSize); + finally + RegCloseKey(phkResult); + end; + Default8087CW := (Default8087CW and $ffc0) or (lpData and $3f); +end; +{$ENDIF} + +procedure _FpuInit; +asm + FNINIT + FWAIT +{$IFDEF PIC} + CALL GetGOT + MOV EAX,[EAX].OFFSET Default8087CW + FLDCW [EAX] +{$ELSE} + FLDCW Default8087CW +{$ENDIF} +end; + +procedure FpuInit; +//const cwDefault: Word = $1332 { $133F}; +asm + JMP _FpuInit +end; + +procedure FpuInitConsiderNECWindows; +begin + if _isNECWindows then _FpuMaskInit; + FpuInit(); +end; + +procedure _BoundErr; +asm + MOV AL,reRangeError + JMP Error +end; + +procedure _IntOver; +asm + MOV AL,reIntOverflow + JMP Error +end; + +function TObject.ClassType: TClass; +begin + Pointer(Result) := PPointer(Self)^; +end; + +class function TObject.ClassName: ShortString; +{$IFDEF PUREPASCAL} +begin + Result := PShortString(PPointer(Integer(Self) + vmtClassName)^)^; +end; +{$ELSE} +asm + { -> EAX VMT } + { EDX Pointer to result string } + PUSH ESI + PUSH EDI + MOV EDI,EDX + MOV ESI,[EAX].vmtClassName + XOR ECX,ECX + MOV CL,[ESI] + INC ECX + REP MOVSB + POP EDI + POP ESI +end; +{$ENDIF} + +class function TObject.ClassNameIs(const Name: string): Boolean; +{$IFDEF PUREPASCAL} +var + Temp: ShortString; + I: Byte; +begin + Result := False; + Temp := ClassName; + for I := 0 to Byte(Temp[0]) do + if Temp[I] <> Name[I] then Exit; + Result := True; +end; +{$ELSE} +asm + PUSH EBX + XOR EBX,EBX + OR EDX,EDX + JE @@exit + MOV EAX,[EAX].vmtClassName + XOR ECX,ECX + MOV CL,[EAX] + CMP ECX,[EDX-4] + JNE @@exit + DEC EDX +@@loop: + MOV BH,[EAX+ECX] + XOR BH,[EDX+ECX] + AND BH,0DFH + JNE @@exit + DEC ECX + JNE @@loop + INC EBX +@@exit: + MOV AL,BL + POP EBX +end; +{$ENDIF} + +class function TObject.ClassParent: TClass; +{$IFDEF PUREPASCAL} +begin + Pointer(Result) := PPointer(Integer(Self) + vmtParent)^; + if Result <> nil then + Pointer(Result) := PPointer(Result)^; +end; +{$ELSE} +asm + MOV EAX,[EAX].vmtParent + TEST EAX,EAX + JE @@exit + MOV EAX,[EAX] +@@exit: +end; +{$ENDIF} + +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; +begin +end; + +destructor TObject.Destroy; +begin +end; + +procedure TObject.Free; +begin + if Self <> nil then + Destroy; +end; + +class function TObject.InitInstance(Instance: Pointer): TObject; +{$IFDEF PUREPASCAL} +var + IntfTable: PInterfaceTable; + ClassPtr: TClass; + I: Integer; +begin + FillChar(Instance^, InstanceSize, 0); + PInteger(Instance)^ := Integer(Self); + ClassPtr := Self; + while ClassPtr <> nil do + begin + IntfTable := ClassPtr.GetInterfaceTable; + if IntfTable <> nil then + for I := 0 to IntfTable.EntryCount-1 do + with IntfTable.Entries[I] do + begin + if VTable <> nil then + PInteger(@PChar(Instance)[IOffset])^ := Integer(VTable); + end; + ClassPtr := ClassPtr.ClassParent; + end; + Result := Instance; +end; +{$ELSE} +asm + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV EDI,EDX + STOSD + MOV ECX,[EBX].vmtInstanceSize + XOR EAX,EAX + PUSH ECX + SHR ECX,2 + DEC ECX + REP STOSD + POP ECX + AND ECX,3 + REP STOSB + MOV EAX,EDX + MOV EDX,ESP +@@0: MOV ECX,[EBX].vmtIntfTable + TEST ECX,ECX + JE @@1 + PUSH ECX +@@1: MOV EBX,[EBX].vmtParent + TEST EBX,EBX + JE @@2 + MOV EBX,[EBX] + JMP @@0 +@@2: CMP ESP,EDX + JE @@5 +@@3: POP EBX + MOV ECX,[EBX].TInterfaceTable.EntryCount + ADD EBX,4 +@@4: MOV ESI,[EBX].TInterfaceEntry.VTable + TEST ESI,ESI + JE @@4a + MOV EDI,[EBX].TInterfaceEntry.IOffset + MOV [EAX+EDI],ESI +@@4a: ADD EBX,TYPE TInterfaceEntry + DEC ECX + JNE @@4 + CMP ESP,EDX + JNE @@3 +@@5: POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +procedure TObject.CleanupInstance; +{$IFDEF PUREPASCAL} +var + ClassPtr: TClass; + InitTable: Pointer; +begin + ClassPtr := ClassType; + InitTable := PPointer(Integer(ClassPtr) + vmtInitTable)^; + while (ClassPtr <> nil) and (InitTable <> nil) do + begin + _FinalizeRecord(Self, InitTable); + ClassPtr := ClassPtr.ClassParent; + if ClassPtr <> nil then + InitTable := PPointer(Integer(ClassPtr) + vmtInitTable)^; + end; +end; +{$ELSE} +asm + PUSH EBX + PUSH ESI + MOV EBX,EAX + MOV ESI,EAX +@@loop: + MOV ESI,[ESI] + MOV EDX,[ESI].vmtInitTable + MOV ESI,[ESI].vmtParent + TEST EDX,EDX + JE @@skip + CALL _FinalizeRecord + MOV EAX,EBX +@@skip: + TEST ESI,ESI + JNE @@loop + + POP ESI + POP EBX +end; +{$ENDIF} + +function InvokeImplGetter(Self: TObject; ImplGetter: Cardinal): IInterface; +{$IFDEF PUREPASCAL} +var + M: function: IInterface of object; +begin + TMethod(M).Data := Self; + case ImplGetter of + $FF000000..$FFFFFFFF: // Field + Result := IInterface(Pointer(Cardinal(Self) + (ImplGetter and $00FFFFFF))); + $FE000000..$FEFFFFFF: // virtual method + begin + // sign extend vmt slot offset = smallint cast + TMethod(M).Code := PPointer(Integer(Self) + SmallInt(ImplGetter))^; + Result := M; + end; + else // static method + TMethod(M).Code := Pointer(ImplGetter); + Result := M; + end; +end; +{$ELSE} +asm + XCHG EDX,ECX + CMP ECX,$FF000000 + JAE @@isField + CMP ECX,$FE000000 + JB @@isStaticMethod + + { the GetProc is a virtual method } + MOVSX ECX,CX { sign extend slot offs } + ADD ECX,[EAX] { vmt + slotoffs } + JMP dword ptr [ECX] { call vmt[slot] } + +@@isStaticMethod: + JMP ECX + +@@isField: + AND ECX,$00FFFFFF + ADD ECX,EAX + MOV EAX,EDX + MOV EDX,[ECX] + JMP _IntfCopy +end; +{$ENDIF} + +function TObject.GetInterface(const IID: TGUID; out Obj): Boolean; +var + InterfaceEntry: PInterfaceEntry; +begin + Pointer(Obj) := nil; + InterfaceEntry := GetInterfaceEntry(IID); + if InterfaceEntry <> nil then + begin + if InterfaceEntry^.IOffset <> 0 then + begin + Pointer(Obj) := Pointer(Integer(Self) + InterfaceEntry^.IOffset); + if Pointer(Obj) <> nil then IInterface(Obj)._AddRef; + end + else + IInterface(Obj) := InvokeImplGetter(Self, InterfaceEntry^.ImplGetter); + end; + Result := Pointer(Obj) <> nil; +end; + +class function TObject.GetInterfaceEntry(const IID: TGUID): PInterfaceEntry; +{$IFDEF PUREPASCAL} +var + ClassPtr: TClass; + IntfTable: PInterfaceTable; + I: Integer; +begin + ClassPtr := Self; + while ClassPtr <> nil do + begin + IntfTable := ClassPtr.GetInterfaceTable; + if IntfTable <> nil then + for I := 0 to IntfTable.EntryCount-1 do + begin + Result := @IntfTable.Entries[I]; +// if Result^.IID = IID then Exit; + if (Int64(Result^.IID.D1) = Int64(IID.D1)) and + (Int64(Result^.IID.D4) = Int64(IID.D4)) then Exit; + end; + ClassPtr := ClassPtr.ClassParent; + end; + Result := nil; +end; +{$ELSE} +asm + PUSH EBX + PUSH ESI + MOV EBX,EAX +@@1: MOV EAX,[EBX].vmtIntfTable + TEST EAX,EAX + JE @@4 + MOV ECX,[EAX].TInterfaceTable.EntryCount + ADD EAX,4 +@@2: MOV ESI,[EDX].Integer[0] + CMP ESI,[EAX].TInterfaceEntry.IID.Integer[0] + JNE @@3 + MOV ESI,[EDX].Integer[4] + CMP ESI,[EAX].TInterfaceEntry.IID.Integer[4] + JNE @@3 + MOV ESI,[EDX].Integer[8] + CMP ESI,[EAX].TInterfaceEntry.IID.Integer[8] + JNE @@3 + MOV ESI,[EDX].Integer[12] + CMP ESI,[EAX].TInterfaceEntry.IID.Integer[12] + JE @@5 +@@3: ADD EAX,type TInterfaceEntry + DEC ECX + JNE @@2 +@@4: MOV EBX,[EBX].vmtParent + TEST EBX,EBX + JE @@4a + MOV EBX,[EBX] + JMP @@1 +@@4a: XOR EAX,EAX +@@5: POP ESI + POP EBX +end; +{$ENDIF} + +class function TObject.GetInterfaceTable: PInterfaceTable; +begin + Result := PPointer(Integer(Self) + vmtIntfTable)^; +end; + +function _IsClass(Child: TObject; Parent: TClass): Boolean; +begin + Result := (Child <> nil) and Child.InheritsFrom(Parent); +end; + +function _AsClass(Child: TObject; Parent: TClass): TObject; +{$IFDEF PUREPASCAL} +begin + Result := Child; + if not (Child is Parent) then + Error(reInvalidCast); // loses return address +end; +{$ELSE} +asm + { -> EAX left operand (class) } + { EDX VMT of right operand } + { <- EAX if left is derived from right, else runtime error } + TEST EAX,EAX + JE @@exit + MOV ECX,EAX +@@loop: + MOV ECX,[ECX] + CMP ECX,EDX + JE @@exit + MOV ECX,[ECX].vmtParent + TEST ECX,ECX + JNE @@loop + + { do runtime error } + MOV AL,reInvalidCast + JMP Error + +@@exit: +end; +{$ENDIF} + + +procedure GetDynaMethod; +{ function GetDynaMethod(vmt: TClass; selector: Smallint) : Pointer; } +asm + { -> EAX vmt of class } + { SI dynamic method index } + { <- ESI pointer to routine } + { ZF = 0 if found } + { trashes: EAX, ECX } + + PUSH EDI + XCHG EAX,ESI + JMP @@haveVMT +@@outerLoop: + MOV ESI,[ESI] +@@haveVMT: + MOV EDI,[ESI].vmtDynamicTable + TEST EDI,EDI + JE @@parent + MOVZX ECX,word ptr [EDI] + PUSH ECX + ADD EDI,2 + REPNE SCASW + JE @@found + POP ECX +@@parent: + MOV ESI,[ESI].vmtParent + TEST ESI,ESI + JNE @@outerLoop + JMP @@exit + +@@found: + POP EAX + ADD EAX,EAX + SUB EAX,ECX { this will always clear the Z-flag ! } + MOV ESI,[EDI+EAX*2-4] + +@@exit: + POP EDI +end; + +procedure _CallDynaInst; +asm + PUSH EAX + PUSH ECX + MOV EAX,[EAX] + CALL GetDynaMethod + POP ECX + POP EAX + JE @@Abstract + JMP ESI +@@Abstract: + POP ECX + JMP _AbstractError +end; + + +procedure _CallDynaClass; +asm + PUSH EAX + PUSH ECX + CALL GetDynaMethod + POP ECX + POP EAX + JE @@Abstract + JMP ESI +@@Abstract: + POP ECX + JMP _AbstractError +end; + + +procedure _FindDynaInst; +asm + PUSH ESI + MOV ESI,EDX + MOV EAX,[EAX] + CALL GetDynaMethod + MOV EAX,ESI + POP ESI + JNE @@exit + POP ECX + JMP _AbstractError +@@exit: +end; + + +procedure _FindDynaClass; +asm + PUSH ESI + MOV ESI,EDX + CALL GetDynaMethod + MOV EAX,ESI + POP ESI + JNE @@exit + POP ECX + JMP _AbstractError +@@exit: +end; + +class function TObject.InheritsFrom(AClass: TClass): Boolean; +{$IFDEF PUREPASCAL} +var + ClassPtr: TClass; +begin + ClassPtr := Self; + while (ClassPtr <> nil) and (ClassPtr <> AClass) do + ClassPtr := PPointer(Integer(ClassPtr) + vmtParent)^; + Result := ClassPtr = AClass; +end; +{$ELSE} +asm + { -> EAX Pointer to our class } + { EDX Pointer to AClass } + { <- AL Boolean result } + JMP @@haveVMT +@@loop: + MOV EAX,[EAX] +@@haveVMT: + CMP EAX,EDX + JE @@success + MOV EAX,[EAX].vmtParent + TEST EAX,EAX + JNE @@loop + JMP @@exit +@@success: + MOV AL,1 +@@exit: +end; +{$ENDIF} + + +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); +begin +end; + + +procedure TObject.AfterConstruction; +begin +end; + +procedure TObject.BeforeDestruction; +begin +end; + +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].vmtDefaultHandler +end; + + +class function TObject.MethodAddress(const Name: ShortString): Pointer; +asm + { -> EAX Pointer to class } + { EDX Pointer to name } + PUSH EBX + PUSH ESI + PUSH EDI + XOR ECX,ECX + XOR EDI,EDI + MOV BL,[EDX] + JMP @@haveVMT +@@outer: { upper 16 bits of ECX are 0 ! } + MOV EAX,[EAX] +@@haveVMT: + MOV ESI,[EAX].vmtMethodTable + TEST ESI,ESI + JE @@parent + MOV DI,[ESI] { EDI := method count } + ADD ESI,2 +@@inner: { upper 16 bits of ECX are 0 ! } + MOV CL,[ESI+6] { compare length of strings } + CMP CL,BL + JE @@cmpChar +@@cont: { upper 16 bits of ECX are 0 ! } + MOV CX,[ESI] { fetch length of method desc } + ADD ESI,ECX { point ESI to next method } + DEC EDI + JNZ @@inner +@@parent: + MOV EAX,[EAX].vmtParent { fetch parent vmt } + TEST EAX,EAX + JNE @@outer + JMP @@exit { return NIL } + +@@notEqual: + MOV BL,[EDX] { restore BL to length of name } + JMP @@cont + +@@cmpChar: { upper 16 bits of ECX are 0 ! } + MOV CH,0 { upper 24 bits of ECX are 0 ! } +@@cmpCharLoop: + MOV BL,[ESI+ECX+6] { case insensitive string cmp } + XOR BL,[EDX+ECX+0] { last char is compared first } + AND BL,$DF + JNE @@notEqual + DEC ECX { ECX serves as counter } + JNZ @@cmpCharLoop + + { found it } + MOV EAX,[ESI+2] + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +class function TObject.MethodName(Address: Pointer): ShortString; +asm + { -> EAX Pointer to class } + { EDX Address } + { ECX Pointer to result } + PUSH EBX + PUSH ESI + PUSH EDI + MOV EDI,ECX + XOR EBX,EBX + XOR ECX,ECX + JMP @@haveVMT +@@outer: + MOV EAX,[EAX] +@@haveVMT: + MOV ESI,[EAX].vmtMethodTable { fetch pointer to method table } + TEST ESI,ESI + JE @@parent + MOV CX,[ESI] + ADD ESI,2 +@@inner: + CMP EDX,[ESI+2] + JE @@found + MOV BX,[ESI] + ADD ESI,EBX + DEC ECX + JNZ @@inner +@@parent: + MOV EAX,[EAX].vmtParent + TEST EAX,EAX + JNE @@outer + MOV [EDI],AL + JMP @@exit + +@@found: + ADD ESI,6 + XOR ECX,ECX + MOV CL,[ESI] + INC ECX + REP MOVSB + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +function TObject.FieldAddress(const Name: ShortString): Pointer; +asm + { -> EAX Pointer to instance } + { EDX Pointer to name } + PUSH EBX + PUSH ESI + PUSH EDI + XOR ECX,ECX + XOR EDI,EDI + MOV BL,[EDX] + + PUSH EAX { save instance pointer } + +@@outer: + MOV EAX,[EAX] { fetch class pointer } + MOV ESI,[EAX].vmtFieldTable + TEST ESI,ESI + JE @@parent + MOV DI,[ESI] { fetch count of fields } + ADD ESI,6 +@@inner: + MOV CL,[ESI+6] { compare string lengths } + CMP CL,BL + JE @@cmpChar +@@cont: + LEA ESI,[ESI+ECX+7] { point ESI to next field } + DEC EDI + JNZ @@inner +@@parent: + MOV EAX,[EAX].vmtParent { fetch parent VMT } + TEST EAX,EAX + JNE @@outer + POP EDX { forget instance, return Nil } + JMP @@exit + +@@notEqual: + MOV BL,[EDX] { restore BL to length of name } + MOV CL,[ESI+6] { ECX := length of field name } + JMP @@cont + +@@cmpChar: + MOV BL,[ESI+ECX+6] { case insensitive string cmp } + XOR BL,[EDX+ECX+0] { starting with last char } + AND BL,$DF + JNE @@notEqual + DEC ECX { ECX serves as counter } + JNZ @@cmpChar + + { found it } + MOV EAX,[ESI] { result is field offset plus ... } + POP EDX + ADD EAX,EDX { instance pointer } + +@@exit: + POP EDI + POP ESI + POP EBX +end; + +function _ClassCreate(AClass: TClass; Alloc: Boolean): TObject; +asm + { -> EAX = pointer to VMT } + { <- EAX = pointer to instance } + PUSH EDX + PUSH ECX + PUSH EBX + TEST DL,DL + JL @@noAlloc + CALL dword ptr [EAX].vmtNewInstance +@@noAlloc: +{$IFNDEF PC_MAPPED_EXCEPTIONS} + XOR EDX,EDX + LEA ECX,[ESP+16] + MOV EBX,FS:[EDX] + MOV [ECX].TExcFrame.next,EBX + MOV [ECX].TExcFrame.hEBP,EBP + MOV [ECX].TExcFrame.desc,offset @desc + MOV [ECX].TexcFrame.ConstructedObject,EAX { trick: remember copy to instance } + MOV FS:[EDX],ECX +{$ENDIF} + POP EBX + POP ECX + POP EDX + RET + +{$IFNDEF PC_MAPPED_EXCEPTIONS} +@desc: + JMP _HandleAnyException + + { destroy the object } + + MOV EAX,[ESP+8+9*4] + MOV EAX,[EAX].TExcFrame.ConstructedObject + TEST EAX,EAX + JE @@skip + MOV ECX,[EAX] + MOV DL,$81 + PUSH EAX + CALL dword ptr [ECX].vmtDestroy + POP EAX + CALL _ClassDestroy +@@skip: + { reraise the exception } + CALL _RaiseAgain +{$ENDIF} +end; + +procedure _ClassDestroy(Instance: TObject); +begin + Instance.FreeInstance; +end; + + +function _AfterConstruction(Instance: TObject): TObject; +begin + Instance.AfterConstruction; + Result := Instance; +end; + +function _BeforeDestruction(Instance: TObject; OuterMost: ShortInt): TObject; +// Must preserve DL on return! +{$IFDEF PUREPASCAL} +begin + Result := Instance; + if OuterMost > 0 then Exit; + Instance.BeforeDestruction; +end; +{$ELSE} +asm + { -> EAX = pointer to instance } + { DL = dealloc flag } + + TEST DL,DL + JG @@outerMost + RET +@@outerMost: + PUSH EAX + PUSH EDX + MOV EDX,[EAX] + CALL dword ptr [EDX].vmtBeforeDestruction + POP EDX + POP EAX +end; +{$ENDIF} + +{ + 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_CONTINE so that normal processing will occur. +} + +{$IFDEF LINUX} +const + excRaise = 0; { an exception is being raised by the user (could be a reraise) } + excCatch = 1; { an exception is about to be caught } + excFinally = 2; { a finally block is about to be executed because of an exception } + excUnhandled = 3; { no user exception handler was found (the app will die) } + +procedure _DbgExcNotify( + NotificationKind: Integer; + ExceptionObject: Pointer; + ExceptionName: PShortString; + ExceptionLocation: Pointer; + HandlerAddr: Pointer); cdecl; export; +begin +{$IFDEF DEBUG} + { + This code is just for debugging the exception handling system. The debugger + needs _DbgExcNotify, however to place breakpoints in, so the function itself + cannot be removed. + } + asm + PUSH EAX + PUSH EDX + end; + if Assigned(ExcNotificationProc) then + ExcNotificationProc(NotificationKind, ExceptionObject, ExceptionName, ExceptionLocation, HandlerAddr); + asm + POP EDX + POP EAX + end; +{$ENDIF} +end; + +{ + The following functions are used by the debugger for the evaluator. If you + change them IN ANY WAY, the debugger will cease to function correctly. +} +procedure _DbgEvalMarker; +begin +end; + +procedure _DbgEvalExcept(E: TObject); +begin +end; + +procedure _DbgEvalEnd; +begin +end; + +{ + This function is used by the debugger to provide a soft landing spot + when evaluating a function call that may raise an unhandled exception. + The return address of _DbgEvalMarker is pushed onto the stack so that + the unwinder will transfer control to the except block. +} +procedure _DbgEvalFrame; +begin + try + _DbgEvalMarker; + except on E: TObject do + _DbgEvalExcept(E); + end; + _DbgEvalEnd; +end; + +{ + These export names need to match the names that will be generated into + the .symtab section, so that the debugger can find them if stabs + debug information is being generated. +} +exports + _DbgExcNotify name '@DbgExcNotify', + _DbgEvalFrame name '@DbgEvalFrame', + _DbgEvalMarker name '@DbgEvalMarker', + _DbgEvalExcept name '@DbgEvalExcept', + _DbgEvalEnd name '@DbgEvalEnd'; +{$ENDIF} + +{ tell the debugger that the next raise is a re-raise of the current non-Delphi + exception } +procedure NotifyReRaise; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX location of exception } + PUSH 0 { handler addr } + PUSH EDX { location of exception } + MOV ECX, [EAX] + PUSH [ECX].vmtClassName { exception name } + PUSH EAX { exception object } + PUSH excRaise { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 +{$ELSE} + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH 0 + PUSH 0 + PUSH cContinuable + PUSH cDelphiReRaise + CALL RaiseExceptionProc +@@1: +{$ENDIF} +end; + +{ tell the debugger about the raise of a non-Delphi exception } +{$IFNDEF LINUX} +procedure NotifyNonDelphiException; +asm + CMP BYTE PTR DebugHook,0 + JE @@1 + PUSH EAX + PUSH EAX + PUSH EDX + PUSH ESP + PUSH 2 + PUSH cContinuable + PUSH cNonDelphiException + CALL RaiseExceptionProc + ADD ESP,8 + POP EAX +@@1: +end; +{$ENDIF} + +{ Tell the debugger where the handler for the current exception is located } +procedure NotifyExcept; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX handler addr } + PUSH EAX + MOV EAX, [EAX].TRaisedException.ExceptObject + + PUSH EDX { handler addr } + PUSH 0 { location of exception } + MOV ECX, [EAX] + PUSH [ECX].vmtClassName { exception name } + PUSH EAX { exception object } + PUSH excCatch { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 + + POP EAX +{$ELSE} + PUSH ESP + PUSH 1 + PUSH cContinuable + PUSH cDelphiExcept { our magic exception code } + CALL RaiseExceptionProc + ADD ESP,4 + POP EAX +{$ENDIF} +end; + +procedure NotifyOnExcept; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX handler addr } + PUSH EDX { handler addr } + PUSH 0 { location of exception } + MOV ECX, [EAX] + PUSH [ECX].vmtClassName { exception name } + PUSH EAX { exception object } + PUSH excCatch { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 +{$ELSE} + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH EAX + PUSH [EBX].TExcDescEntry.handler + JMP NotifyExcept +@@1: +{$ENDIF} +end; + +{$IFNDEF LINUX} +procedure NotifyAnyExcept; +asm + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH EAX + PUSH EBX + JMP NotifyExcept +@@1: +end; + +procedure CheckJmp; +asm + TEST ECX,ECX + JE @@3 + MOV EAX,[ECX + 1] + CMP BYTE PTR [ECX],0E9H { near jmp } + JE @@1 + CMP BYTE PTR [ECX],0EBH { short jmp } + JNE @@3 + MOVSX EAX,AL + INC ECX + INC ECX + JMP @@2 +@@1: + ADD ECX,5 +@@2: + ADD ECX,EAX +@@3: +end; +{$ENDIF} { not LINUX } + +{ Notify debugger of a finally during an exception unwind } +procedure NotifyExceptFinally; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX handler addr } + PUSH EDX { handler addr } + PUSH 0 { location of exception } + PUSH 0 { exception name } + PUSH 0 { exception object } + PUSH excFinally { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 +{$ELSE} + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH EAX + PUSH EDX + PUSH ECX + CALL CheckJmp + PUSH ECX + PUSH ESP { pass pointer to arguments } + PUSH 1 { there is 1 argument } + PUSH cContinuable { continuable execution } + PUSH cDelphiFinally { our magic exception code } + CALL RaiseExceptionProc + POP ECX + POP ECX + POP EDX + POP EAX +@@1: +{$ENDIF} +end; + + +{ Tell the debugger that the current exception is handled and cleaned up. + Also indicate where execution is about to resume. } +{$IFNDEF LINUX} +procedure NotifyTerminate; +asm + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH EDX + PUSH ESP + PUSH 1 + PUSH cContinuable + PUSH cDelphiTerminate { our magic exception code } + CALL RaiseExceptionProc + POP EDX +@@1: +end; +{$ENDIF} + +{ 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; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX location of exception } + PUSH EAX + MOV EAX, [EAX].TRaisedException.ExceptObject + + PUSH 0 { handler addr } + PUSH EDX { location of exception } + MOV ECX, [EAX] + PUSH [ECX].vmtClassName { exception name } + PUSH EAX { exception object } + PUSH excUnhandled { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 + + POP EAX +{$ELSE} + PUSH EAX + PUSH EDX + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH ESP + PUSH 2 + PUSH cContinuable + PUSH cDelphiUnhandled + CALL RaiseExceptionProc +@@1: + POP EDX + POP EAX +{$ENDIF} +end; + +procedure _HandleAnyException; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + CALL UnblockOSExceptions + OR [EAX].TRaisedException.Flags, excIsBeingHandled + MOV ESI, EBX + MOV EDX, [ESP] + CALL NotifyExcept + MOV EBX, ESI +{$ENDIF} +{$IFNDEF PC_MAPPED_EXCEPTIONS} + { -> [ESP+ 4] excPtr: PExceptionRecord } + { [ESP+ 8] errPtr: PExcFrame } + { [ESP+12] ctxPtr: Pointer } + { [ESP+16] dspPtr: Pointer } + { <- EAX return value - always one } + + MOV EAX,[ESP+4] + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JNE @@exit + + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + MOV EDX,[EAX].TExceptionRecord.ExceptObject + MOV ECX,[EAX].TExceptionRecord.ExceptAddr + JE @@DelphiException + CLD + CALL _FpuInit + MOV EDX,ExceptObjProc + TEST EDX,EDX + JE @@exit + CALL EDX + TEST EAX,EAX + JE @@exit + MOV EDX,[ESP+12] + MOV ECX,[ESP+4] + CMP [ECX].TExceptionRecord.ExceptionCode,cCppException + JE @@CppException + CALL NotifyNonDelphiException +{$IFDEF MSWINDOWS} + CMP BYTE PTR JITEnable,0 + JBE @@CppException + CMP BYTE PTR DebugHook,0 + JA @@CppException // Do not JIT if debugging + LEA ECX,[ESP+4] + PUSH EAX + PUSH ECX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + POP EAX + JE @@exit + MOV EDX,EAX + MOV EAX,[ESP+4] + MOV ECX,[EAX].TExceptionRecord.ExceptionAddress + JMP @@GoUnwind +{$ENDIF} +@@CppException: + MOV EDX,EAX + MOV EAX,[ESP+4] + MOV ECX,[EAX].TExceptionRecord.ExceptionAddress + +@@DelphiException: +{$IFDEF MSWINDOWS} + CMP BYTE PTR JITEnable,1 + JBE @@GoUnwind + CMP BYTE PTR DebugHook,0 { Do not JIT if debugging } + JA @@GoUnwind + PUSH EAX + LEA EAX,[ESP+8] + PUSH EDX + PUSH ECX + PUSH EAX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + POP ECX + POP EDX + POP EAX + JE @@exit +{$ENDIF} + +@@GoUnwind: + OR [EAX].TExceptionRecord.ExceptionFlags,cUnwinding + + PUSH EBX + XOR EBX,EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBX,FS:[EBX] + PUSH EBX { Save pointer to topmost frame } + PUSH EAX { Save OS exception pointer } + PUSH EDX { Save exception object } + PUSH ECX { Save exception address } + + MOV EDX,[ESP+8+8*4] + + PUSH 0 + PUSH EAX + PUSH offset @@returnAddress + PUSH EDX + CALL RtlUnwindProc +@@returnAddress: + + MOV EDI,[ESP+8+8*4] + + { Make the RaiseList entry on the stack } + + CALL SysInit.@GetTLS + PUSH [EAX].RaiseListPtr + MOV [EAX].RaiseListPtr,ESP + + MOV EBP,[EDI].TExcFrame.hEBP + MOV EBX,[EDI].TExcFrame.desc + MOV [EDI].TExcFrame.desc,offset @@exceptFinally + + ADD EBX,TExcDesc.instructions + CALL NotifyAnyExcept + JMP EBX + +@@exceptFinally: + JMP _HandleFinally + +@@destroyExcept: + { we come here if an exception handler has thrown yet another exception } + { we need to destroy the exception object and pop the raise list. } + + CALL SysInit.@GetTLS + MOV ECX,[EAX].RaiseListPtr + MOV EDX,[ECX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,EDX + + MOV EAX,[ECX].TRaiseFrame.ExceptObject + JMP TObject.Free + +@@exit: + MOV EAX,1 +{$ENDIF} { not PC_MAPPED_EXCEPTIONS } +end; + +{$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; +asm + { -> EAX raised object: Pointer } + { EDX descriptor table: ^TExcDesc } + { EBX GOT of user code, or 0 if not an SO } + { <- EAX matching descriptor: ^TExcDescEntry } + PUSH EBP + MOV EBP, ESP + SUB ESP, 8 { Room for vtable temp, and adjustor } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV [EBP - 8], EBX { Store the potential GOT } + MOV EAX, [EAX] { load vtable of exception object } + MOV EBX,[EDX].TExcDesc.cnt + LEA ESI,[EDX].TExcDesc.excTab { point ECX to exc descriptor table } + MOV [EBP - 4], EAX { temp for vtable of exception object } + +@@innerLoop: + MOV EAX,[ESI].TExcDescEntry.vTable + TEST EAX,EAX { catch all clause? } + JE @@found { yes: This is the handler } + ADD EAX, [EBP - 8] { add in the adjustor (could be 0) } + MOV EDI,[EBP - 4] { load vtable of exception object } + JMP @@haveVMT + +@@vtLoop: + MOV EDI,[EDI] +@@haveVMT: + MOV EAX,[EAX] + CMP EAX,EDI + JE @@found + + MOV ECX,[EAX].vmtInstanceSize + CMP ECX,[EDI].vmtInstanceSize + JNE @@parent + + MOV EAX,[EAX].vmtClassName + MOV EDX,[EDI].vmtClassName + + XOR ECX,ECX + MOV CL,[EAX] + CMP CL,[EDX] + JNE @@parent + + INC EAX + INC EDX + CALL _AStrCmp + JE @@found + +@@parent: + MOV EDI,[EDI].vmtParent { load vtable of parent } + MOV EAX,[ESI].TExcDescEntry.vTable + ADD EAX, [EBP - 8] { add in the adjustor (could be 0) } + TEST EDI,EDI + JNE @@vtLoop + + ADD ESI,8 + DEC EBX + JNZ @@innerLoop + + { Didn't find a handler. } + XOR ESI, ESI + +@@found: + MOV EAX, ESI +@@done: + POP EDI + POP ESI + POP EBX + MOV ESP, EBP + POP EBP +end; +{$ENDIF} + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _HandleOnExceptionPIC; +asm + { -> EAX obj : Exception object } + { [RA] desc: ^TExcDesc } + { <- Doesn't return } + + // Mark the exception as being handled + OR [EAX].TRaisedException.Flags, excIsBeingHandled + + MOV ESI, EBX // Save the GOT + MOV EDX, [ESP] // Get the addr of the TExcDesc + PUSH EAX // Save the object + MOV EAX, [EAX].TRaisedException.ExceptObject + CALL FindOnExceptionDescEntry + OR EAX, EAX + JE @@NotForMe + + MOV EBX, ESI // Set back to user's GOT + MOV EDX, EAX + POP EAX // Get the object back + POP ECX // Ditch the return addr + + // Get the Pascal object itself. + MOV EAX, [EAX].TRaisedException.ExceptObject + + MOV EDX, [EDX].TExcDescEntry.handler + ADD EDX, EBX // adjust for GOT + CALL NotifyOnExcept + + MOV EBX, ESI // Make sure of user's GOT + JMP EDX // Back to the user code + // never returns +@@NotForMe: + POP EAX // Get the exception object + + // Mark that we're reraising this exception, so that the + // compiler generated exception handler for the 'except on' clause + // will not get confused + OR [EAX].TRaisedException.Flags, excIsBeingReRaised + + JMP SysRaiseException // Should be using resume here +end; +{$ENDIF} + +procedure _HandleOnException; +{$IFDEF PC_MAPPED_EXCEPTIONS} +asm + { -> EAX obj : Exception object } + { [RA] desc: ^TExcDesc } + { <- Doesn't return } + + // Mark the exception as being handled + OR [EAX].TRaisedException.Flags, excIsBeingHandled + + MOV EDX, [ESP] // Get the addr of the TExcDesc + PUSH EAX // Save the object + PUSH EBX // Save EBX + XOR EBX, EBX // No GOT + MOV EAX, [EAX].TRaisedException.ExceptObject + CALL FindOnExceptionDescEntry + POP EBX // Restore EBX + OR EAX, EAX // Is the exception for me? + JE @@NotForMe + + MOV EDX, EAX + POP EAX // Get the object back + POP ECX // Ditch the return addr + + // Get the Pascal object itself. + MOV EAX, [EAX].TRaisedException.ExceptObject + + MOV EDX, [EDX].TExcDescEntry.handler + CALL NotifyOnExcept // Tell the debugger about it + + JMP EDX // Back to the user code + // never returns +@@NotForMe: + POP EAX // Get the exception object + + // Mark that we're reraising this exception, so that the + // compiler generated exception handler for the 'except on' clause + // will not get confused + OR [EAX].TRaisedException.Flags, excIsBeingReRaised + JMP SysRaiseException // Should be using resume here +end; +{$ENDIF} +{$IFNDEF PC_MAPPED_EXCEPTIONS} +asm + { -> [ESP+ 4] excPtr: PExceptionRecord } + { [ESP+ 8] errPtr: PExcFrame } + { [ESP+12] ctxPtr: Pointer } + { [ESP+16] dspPtr: Pointer } + { <- EAX return value - always one } + + MOV EAX,[ESP+4] + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JNE @@exit + + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + JE @@DelphiException + CLD + CALL _FpuInit + MOV EDX,ExceptClsProc + TEST EDX,EDX + JE @@exit + CALL EDX + TEST EAX,EAX + JNE @@common + JMP @@exit + +@@DelphiException: + MOV EAX,[EAX].TExceptionRecord.ExceptObject + MOV EAX,[EAX] { load vtable of exception object } + +@@common: + + MOV EDX,[ESP+8] + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV ECX,[EDX].TExcFrame.desc + MOV EBX,[ECX].TExcDesc.cnt + LEA ESI,[ECX].TExcDesc.excTab { point ECX to exc descriptor table } + MOV EBP,EAX { load vtable of exception object } + +@@innerLoop: + MOV EAX,[ESI].TExcDescEntry.vTable + TEST EAX,EAX { catch all clause? } + JE @@doHandler { yes: go execute handler } + MOV EDI,EBP { load vtable of exception object } + JMP @@haveVMT + +@@vtLoop: + MOV EDI,[EDI] +@@haveVMT: + MOV EAX,[EAX] + CMP EAX,EDI + JE @@doHandler + + MOV ECX,[EAX].vmtInstanceSize + CMP ECX,[EDI].vmtInstanceSize + JNE @@parent + + MOV EAX,[EAX].vmtClassName + MOV EDX,[EDI].vmtClassName + + XOR ECX,ECX + MOV CL,[EAX] + CMP CL,[EDX] + JNE @@parent + + INC EAX + INC EDX + CALL _AStrCmp + JE @@doHandler + +@@parent: + MOV EDI,[EDI].vmtParent { load vtable of parent } + MOV EAX,[ESI].TExcDescEntry.vTable + TEST EDI,EDI + JNE @@vtLoop + + ADD ESI,8 + DEC EBX + JNZ @@innerLoop + + POP EBP + POP EDI + POP ESI + POP EBX + JMP @@exit + +@@doHandler: + MOV EAX,[ESP+4+4*4] + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + MOV EDX,[EAX].TExceptionRecord.ExceptObject + MOV ECX,[EAX].TExceptionRecord.ExceptAddr + JE @@haveObject + CALL ExceptObjProc + MOV EDX,[ESP+12+4*4] + CALL NotifyNonDelphiException +{$IFDEF MSWINDOWS} + CMP BYTE PTR JITEnable,0 + JBE @@NoJIT + CMP BYTE PTR DebugHook,0 + JA @@noJIT { Do not JIT if debugging } + LEA ECX,[ESP+4] + PUSH EAX + PUSH ECX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + POP EAX + JE @@exit +{$ENDIF} +@@noJIT: + MOV EDX,EAX + MOV EAX,[ESP+4+4*4] + MOV ECX,[EAX].TExceptionRecord.ExceptionAddress + JMP @@GoUnwind + +@@haveObject: +{$IFDEF MSWINDOWS} + CMP BYTE PTR JITEnable,1 + JBE @@GoUnwind + CMP BYTE PTR DebugHook,0 + JA @@GoUnwind + PUSH EAX + LEA EAX,[ESP+8] + PUSH EDX + PUSH ECX + PUSH EAX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + POP ECX + POP EDX + POP EAX + JE @@exit +{$ENDIF} + +@@GoUnwind: + XOR EBX,EBX + MOV EBX,FS:[EBX] + PUSH EBX { Save topmost frame } + PUSH EAX { Save exception record } + PUSH EDX { Save exception object } + PUSH ECX { Save exception address } + + MOV EDX,[ESP+8+8*4] + OR [EAX].TExceptionRecord.ExceptionFlags,cUnwinding + + PUSH ESI { Save handler entry } + + PUSH 0 + PUSH EAX + PUSH offset @@returnAddress + PUSH EDX + CALL RtlUnwindProc +@@returnAddress: + + POP EBX { Restore handler entry } + + MOV EDI,[ESP+8+8*4] + + { Make the RaiseList entry on the stack } + + CALL SysInit.@GetTLS + PUSH [EAX].RaiseListPtr + MOV [EAX].RaiseListPtr,ESP + + MOV EBP,[EDI].TExcFrame.hEBP + MOV [EDI].TExcFrame.desc,offset @@exceptFinally + MOV EAX,[ESP].TRaiseFrame.ExceptObject + CALL NotifyOnExcept + JMP [EBX].TExcDescEntry.handler + +@@exceptFinally: + JMP _HandleFinally + +@@destroyExcept: + { we come here if an exception handler has thrown yet another exception } + { we need to destroy the exception object and pop the raise list. } + + CALL SysInit.@GetTLS + MOV ECX,[EAX].RaiseListPtr + MOV EDX,[ECX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,EDX + + MOV EAX,[ECX].TRaiseFrame.ExceptObject + JMP TObject.Free +@@exit: + MOV EAX,1 +end; +{$ENDIF} + +procedure _HandleFinally; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} +{$IFDEF PIC} + MOV ESI, EBX +{$ENDIF} + CALL UnblockOSExceptions + MOV EDX, [ESP] + CALL NotifyExceptFinally + PUSH EAX +{$IFDEF PIC} + MOV EBX, ESI +{$ENDIF} + { + Mark the current exception with the EBP of the handler. If + an exception is raised from the finally block, then this + exception will be orphaned. We will catch this later, when + we clean up the next except block to complete execution. + See DoneExcept. + } + MOV [EAX].TRaisedException.HandlerEBP, EBP + CALL EDX + POP EAX + { + We executed the finally handler without adverse reactions. + It's safe to clear the marker now. + } + MOV [EAX].TRaisedException.HandlerEBP, $FFFFFFFF + PUSH EBP + MOV EBP, ESP + CALL SysRaiseException // Should be using resume here +{$ENDIF} +{$IFDEF MSWINDOWS} + { -> [ESP+ 4] excPtr: PExceptionRecord } + { [ESP+ 8] errPtr: PExcFrame } + { [ESP+12] ctxPtr: Pointer } + { [ESP+16] dspPtr: Pointer } + { <- EAX return value - always one } + + MOV EAX,[ESP+4] + MOV EDX,[ESP+8] + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JE @@exit + MOV ECX,[EDX].TExcFrame.desc + MOV [EDX].TExcFrame.desc,offset @@exit + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBP,[EDX].TExcFrame.hEBP + ADD ECX,TExcDesc.instructions + CALL NotifyExceptFinally + CALL ECX + + POP EBP + POP EDI + POP ESI + POP EBX + +@@exit: + MOV EAX,1 +{$ENDIF} +end; + + +procedure _HandleAutoException; +{$IFDEF LINUX} +{$IFDEF PC_MAPPED_EXCEPTIONS} +asm + // EAX = TObject reference, or nil + // [ESP] = ret addr + + CALL UnblockOSExceptions +// +// The compiler wants the stack to look like this: +// ESP+4-> HRESULT +// ESP+0-> ret addr +// +// Make it so. +// + POP EDX + PUSH 8000FFFFH + PUSH EDX + + OR EAX, EAX // Was this a method call? + JE @@Done + + PUSH EAX + CALL CurrentException + MOV EDX, [EAX].TRaisedException.ExceptObject + MOV ECX, [EAX].TRaisedException.ExceptionAddr; + POP EAX + MOV EAX, [EAX] + CALL [EAX].vmtSafeCallException.Pointer; + MOV [ESP+4], EAX +@@Done: + CALL _DoneExcept +end; +{$ELSE} +begin + Error(reSafeCallError); //!! +end; +{$ENDIF} +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + { -> [ESP+ 4] excPtr: PExceptionRecord } + { [ESP+ 8] errPtr: PExcFrame } + { [ESP+12] ctxPtr: Pointer } + { [ESP+16] dspPtr: Pointer } + { <- EAX return value - always one } + + MOV EAX,[ESP+4] + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JNE @@exit + + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + CLD + CALL _FpuInit + JE @@DelphiException + CMP BYTE PTR JITEnable,0 + JBE @@DelphiException + CMP BYTE PTR DebugHook,0 + JA @@DelphiException + +@@DoUnhandled: + LEA EAX,[ESP+4] + PUSH EAX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + JE @@exit + MOV EAX,[ESP+4] + JMP @@GoUnwind + +@@DelphiException: + CMP BYTE PTR JITEnable,1 + JBE @@GoUnwind + CMP BYTE PTR DebugHook,0 + JA @@GoUnwind + JMP @@DoUnhandled + +@@GoUnwind: + OR [EAX].TExceptionRecord.ExceptionFlags,cUnwinding + + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EDX,[ESP+8+3*4] + + PUSH 0 + PUSH EAX + PUSH offset @@returnAddress + PUSH EDX + CALL RtlUnwindProc + +@@returnAddress: + POP EBP + POP EDI + POP ESI + MOV EAX,[ESP+4] + MOV EBX,8000FFFFH + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + JNE @@done + + MOV EDX,[EAX].TExceptionRecord.ExceptObject + MOV ECX,[EAX].TExceptionRecord.ExceptAddr + MOV EAX,[ESP+8] + MOV EAX,[EAX].TExcFrame.SelfOfMethod + TEST EAX,EAX + JZ @@freeException + MOV EBX,[EAX] + CALL [EBX].vmtSafeCallException.Pointer + MOV EBX,EAX +@@freeException: + MOV EAX,[ESP+4] + MOV EAX,[EAX].TExceptionRecord.ExceptObject + CALL TObject.Free +@@done: + XOR EAX,EAX + MOV ESP,[ESP+8] + POP ECX + MOV FS:[EAX],ECX + POP EDX + POP EBP + LEA EDX,[EDX].TExcDesc.instructions + POP ECX + JMP EDX +@@exit: + MOV EAX,1 +end; +{$ENDIF} + + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _RaiseAtExcept; +asm + { -> EAX Pointer to exception object } + { -> EDX Purported addr of exception } + { Be careful: EBX is not set up in PIC mode. } + { Outward bound calls must go through an exported fn, like SysRaiseException } + OR EAX, EAX + JNE @@GoAhead + MOV EAX, 216 + CALL _RunError + +@@GoAhead: + CALL BlockOSExceptions + PUSH EBP + MOV EBP, ESP + CALL NotifyReRaise + CALL AllocateException + CALL SysRaiseException + { + This can only return if there was a terrible error. In this event, + we have to bail out. + } + JMP _Run0Error +end; +{$ENDIF} + +procedure _RaiseExcept; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + { -> EAX Pointer to exception object } + MOV EDX, [ESP] + JMP _RaiseAtExcept +{$ENDIF} +{$IFDEF MSWINDOWS} + { When making changes to the way Delphi Exceptions are raised, } + { please realize that the C++ Exception handling code reraises } + { some exceptions as Delphi Exceptions. Of course we want to } + { keep exception raising compatible between Delphi and C++, so } + { when you make changes here, consult with the relevant C++ } + { exception handling engineer. The C++ code is in xx.cpp, in } + { the RTL sources, in function tossAnException. } + + { -> EAX Pointer to exception object } + { [ESP] Error address } + + OR EAX, EAX + JNE @@GoAhead + MOV EAX, 216 + CALL _RunError +@@GoAhead: + POP EDX + + PUSH ESP + PUSH EBP + PUSH EDI + PUSH ESI + PUSH EBX + PUSH EAX { pass class argument } + PUSH EDX { pass address argument } + + PUSH ESP { pass pointer to arguments } + PUSH 7 { there are seven arguments } + PUSH cNonContinuable { we can't continue execution } + PUSH cDelphiException { our magic exception code } + PUSH EDX { pass the user's return address } + JMP RaiseExceptionProc +{$ENDIF} +end; + + +{$IFDEF PC_MAPPED_EXCEPTIONS} +{ + Used in the PC mapping exception implementation to handle exceptions in constructors. +} +procedure _ClassHandleException; +asm + { + EAX = self + EDX = top flag + } + TEST DL, DL + JE _RaiseAgain + MOV ECX,[EAX] + MOV DL,$81 + PUSH EAX + CALL dword ptr [ECX].vmtDestroy + POP EAX + CALL _ClassDestroy + JMP _RaiseAgain +end; +{$ENDIF} + +procedure _RaiseAgain; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + CALL CurrentException +// The following notifies the debugger of a reraise of exceptions. This will +// be supported in a later release, but is disabled for now. +// PUSH EAX +// MOV EDX, [EAX].TRaisedException.ExceptionAddr +// MOV EAX, [EAX].TRaisedException.ExceptObject +// CALL NotifyReRaise { Tell the debugger } +// POP EAX + TEST [EAX].TRaisedException.Flags, excIsBeingHandled + JZ @@DoIt + OR [EAX].TRaisedException.Flags, excIsBeingReRaised +@@DoIt: + MOV EDX, [ESP] { Get the user's addr } + JMP SysRaiseException +{$ENDIF} +{$IFDEF MSWINDOWS} + { -> [ESP ] return address to user program } + { [ESP+ 4 ] raise list entry (4 dwords) } + { [ESP+ 4+ 4*4] saved topmost frame } + { [ESP+ 4+ 5*4] saved registers (4 dwords) } + { [ESP+ 4+ 9*4] return address to OS } + { -> [ESP+ 4+10*4] excPtr: PExceptionRecord } + { [ESP+ 8+10*4] errPtr: PExcFrame } + + { Point the error handler of the exception frame to something harmless } + + MOV EAX,[ESP+8+10*4] + MOV [EAX].TExcFrame.desc,offset @@exit + + { Pop the RaiseList } + + CALL SysInit.@GetTLS + MOV EDX,[EAX].RaiseListPtr + MOV ECX,[EDX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,ECX + + { Destroy any objects created for non-delphi exceptions } + + MOV EAX,[EDX].TRaiseFrame.ExceptionRecord + AND [EAX].TExceptionRecord.ExceptionFlags,NOT cUnwinding + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + JE @@delphiException + MOV EAX,[EDX].TRaiseFrame.ExceptObject + CALL TObject.Free + CALL NotifyReRaise + +@@delphiException: + + XOR EAX,EAX + ADD ESP,5*4 + MOV EDX,FS:[EAX] + POP ECX + MOV EDX,[EDX].TExcFrame.next + MOV [ECX].TExcFrame.next,EDX + + POP EBP + POP EDI + POP ESI + POP EBX +@@exit: + MOV EAX,1 +{$ENDIF} +end; + +{$IFDEF DEBUG_EXCEPTIONS} +procedure NoteDE; +begin + Writeln('DoneExcept: Skipped the destructor'); +end; + +procedure NoteDE2; +begin + Writeln('DoneExcept: Destroyed the object'); +end; +{$ENDIF} + +{$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; +var + Exc: PRaisedException; + RefCount: Integer; + ExcObj: Pointer; + ExcAddr: Pointer; +begin + asm + MOV Exc, EAX + end; + + if (Exc^.Flags and excIsBeingReRaised) = 0 then + begin + RefCount := Exc^.RefCount; + ExcObj := Exc^.ExceptObject; + ExcAddr := Exc^.ExceptionAddr; + Exc^.RefCount := 1; + FreeException; + _DoneExcept; + Exc := AllocateException(ExcObj, ExcAddr); + Exc^.RefCount := RefCount; + end; + + Exc^.Flags := Exc^.Flags and not (excIsBeingReRaised or excIsBeingHandled); + + SysRaiseException(Exc); +end; +{$ENDIF} + +procedure _DoneExcept; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + CALL FreeException + OR EAX, EAX + JE @@Done + CALL TObject.Free +@@Done: + { + Take a peek at the next exception object on the stack. + If its EBP marker is at an address lower than our current + EBP, then we know that it was orphaned when an exception was + thrown from within the execution of a finally block. We clean + it up now, so that we won't leak exception records/objects. + } + CALL CurrentException + OR EAX, EAX + JE @@Done2 + CMP [EAX].TRaisedException.HandlerEBP, EBP + JA @@Done2 + CALL FreeException + OR EAX, EAX + JE @@Done2 + CALL TObject.Free +@@Done2: +{$ENDIF} +{$IFDEF MSWINDOWS} + { -> [ESP+ 4+10*4] excPtr: PExceptionRecord } + { [ESP+ 8+10*4] errPtr: PExcFrame } + + { Pop the RaiseList } + + CALL SysInit.@GetTLS + MOV EDX,[EAX].RaiseListPtr + MOV ECX,[EDX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,ECX + + { Destroy exception object } + + MOV EAX,[EDX].TRaiseFrame.ExceptObject + CALL TObject.Free + + POP EDX + MOV ESP,[ESP+8+9*4] + XOR EAX,EAX + POP ECX + MOV FS:[EAX],ECX + POP EAX + POP EBP + CALL NotifyTerminate + JMP EDX +{$ENDIF} +end; + +{$IFNDEF PC_MAPPED_EXCEPTIONS} +procedure _TryFinallyExit; +asm +{$IFDEF MSWINDOWS} + XOR EDX,EDX + MOV ECX,[ESP+4].TExcFrame.desc + MOV EAX,[ESP+4].TExcFrame.next + ADD ECX,TExcDesc.instructions + MOV FS:[EDX],EAX + CALL ECX +@@1: RET 12 +{$ENDIF} +end; +{$ENDIF} + + +var + InitContext: TInitContext; + +{$IFNDEF PC_MAPPED_EXCEPTIONS} +procedure MapToRunError(P: PExceptionRecord); stdcall; +const + STATUS_ACCESS_VIOLATION = $C0000005; + STATUS_ARRAY_BOUNDS_EXCEEDED = $C000008C; + STATUS_FLOAT_DENORMAL_OPERAND = $C000008D; + STATUS_FLOAT_DIVIDE_BY_ZERO = $C000008E; + STATUS_FLOAT_INEXACT_RESULT = $C000008F; + STATUS_FLOAT_INVALID_OPERATION = $C0000090; + STATUS_FLOAT_OVERFLOW = $C0000091; + STATUS_FLOAT_STACK_CHECK = $C0000092; + STATUS_FLOAT_UNDERFLOW = $C0000093; + STATUS_INTEGER_DIVIDE_BY_ZERO = $C0000094; + STATUS_INTEGER_OVERFLOW = $C0000095; + STATUS_PRIVILEGED_INSTRUCTION = $C0000096; + STATUS_STACK_OVERFLOW = $C00000FD; + STATUS_CONTROL_C_EXIT = $C000013A; +var + ErrCode: Byte; +begin + case P.ExceptionCode of + STATUS_INTEGER_DIVIDE_BY_ZERO: ErrCode := 200; + STATUS_ARRAY_BOUNDS_EXCEEDED: ErrCode := 201; + STATUS_FLOAT_OVERFLOW: ErrCode := 205; + STATUS_FLOAT_INEXACT_RESULT, + STATUS_FLOAT_INVALID_OPERATION, + STATUS_FLOAT_STACK_CHECK: ErrCode := 207; + STATUS_FLOAT_DIVIDE_BY_ZERO: ErrCode := 200; + STATUS_INTEGER_OVERFLOW: ErrCode := 215; + STATUS_FLOAT_UNDERFLOW, + STATUS_FLOAT_DENORMAL_OPERAND: ErrCode := 206; + STATUS_ACCESS_VIOLATION: ErrCode := 216; + STATUS_PRIVILEGED_INSTRUCTION: ErrCode := 218; + STATUS_CONTROL_C_EXIT: ErrCode := 217; + STATUS_STACK_OVERFLOW: ErrCode := 202; + else ErrCode := 255; + end; + RunErrorAt(ErrCode, P.ExceptionAddress); +end; + + +procedure _ExceptionHandler; +asm + MOV EAX,[ESP+4] + + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JNE @@exit +{$IFDEF MSWINDOWS} + CMP BYTE PTR DebugHook,0 + JA @@ExecuteHandler + LEA EAX,[ESP+4] + PUSH EAX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + JNE @@ExecuteHandler + JMP @@exit +{$ENDIF} + +@@ExecuteHandler: + MOV EAX,[ESP+4] + CLD + CALL _FpuInit + MOV EDX,[ESP+8] + + PUSH 0 + PUSH EAX + PUSH offset @@returnAddress + PUSH EDX + CALL RtlUnwindProc + +@@returnAddress: + MOV EBX,[ESP+4] + CMP [EBX].TExceptionRecord.ExceptionCode,cDelphiException + MOV EDX,[EBX].TExceptionRecord.ExceptAddr + MOV EAX,[EBX].TExceptionRecord.ExceptObject + JE @@DelphiException2 + + MOV EDX,ExceptObjProc + TEST EDX,EDX + JE MapToRunError + MOV EAX,EBX + CALL EDX + TEST EAX,EAX + JE MapToRunError + MOV EDX,[EBX].TExceptionRecord.ExceptionAddress + +@@DelphiException2: + + CALL NotifyUnhandled + MOV ECX,ExceptProc + TEST ECX,ECX + JE @@noExceptProc + CALL ECX { call ExceptProc(ExceptObject, ExceptAddr) } + +@@noExceptProc: + MOV ECX,[ESP+4] + MOV EAX,217 + MOV EDX,[ECX].TExceptionRecord.ExceptAddr + MOV [ESP],EDX + JMP _RunError + +@@exit: + XOR EAX,EAX +end; + +procedure SetExceptionHandler; +asm + XOR EDX,EDX { using [EDX] saves some space over [0] } +{X} // now we come here from another place, and EBP is used above for loop counter +{X} // let us restore it... +{X} PUSH EBP +{X} LEA EBP, [ESP + $50] + LEA EAX,[EBP-12] + MOV ECX,FS:[EDX] { ECX := head of chain } + MOV FS:[EDX],EAX { head of chain := @exRegRec } + + MOV [EAX].TExcFrame.next,ECX +{$IFDEF PIC} + LEA EDX, [EBX]._ExceptionHandler + MOV [EAX].TExcFrame.desc, EDX +{$ELSE} + MOV [EAX].TExcFrame.desc,offset _ExceptionHandler +{$ENDIF} + MOV [EAX].TExcFrame.hEBP,EBP +{$IFDEF PIC} + MOV [EBX].InitContext.ExcFrame,EAX +{$ELSE} + MOV InitContext.ExcFrame,EAX +{$ENDIF} + +{X} POP EBP +end; + + +procedure UnsetExceptionHandler; +asm + XOR EDX,EDX +{$IFDEF PIC} + MOV EAX,[EBX].InitContext.ExcFrame +{$ELSE} + MOV EAX,InitContext.ExcFrame +{$ENDIF} + TEST EAX,EAX + JZ @@exit + MOV ECX,FS:[EDX] { ECX := head of chain } + CMP EAX,ECX { simple case: our record is first } + JNE @@search + MOV EAX,[EAX] { head of chain := exRegRec.next } + MOV FS:[EDX],EAX + JMP @@exit + +@@loop: + MOV ECX,[ECX] +@@search: + CMP ECX,-1 { at end of list? } + JE @@exit { yes - didn't find it } + CMP [ECX],EAX { is it the next one on the list? } + JNE @@loop { no - look at next one on list } +@@unlink: { yes - unlink our record } + MOV EAX,[EAX] { get next record on list } + MOV [ECX],EAX { unlink our record } +@@exit: +end; +{$ENDIF} // not PC_MAPPED_EXCEPTIONS + +type + TProc = procedure; + +{$IFDEF LINUX} +procedure CallProc(Proc: Pointer; GOT: Cardinal); +asm + PUSH EBX + MOV EBX,EDX + ADD EAX,EBX + CALL EAX + POP EBX +end; +{$ENDIF} + +(*X- Original version... discarded +procedure FinalizeUnits; +var + Count: Integer; + Table: PUnitEntryTable; + P: Pointer; +begin + if InitContext.InitTable = nil then + exit; + Count := InitContext.InitCount; + Table := InitContext.InitTable^.UnitInfo; +{$IFDEF LINUX} + Inc(Cardinal(Table), InitContext.Module^.GOT); +{$ENDIF} + try + while Count > 0 do + begin + Dec(Count); + InitContext.InitCount := Count; + P := Table^[Count].FInit; + if Assigned(P) then + begin +{$IFDEF LINUX} + CallProc(P, InitContext.Module^.GOT); +{$ENDIF} +{$IFDEF MSWINDOWS} + TProc(P)(); +{$ENDIF} + end; + end; + except + FinalizeUnits; { try to finalize the others } + raise; + end; +end; +X+*) + +{X+ see comments in InitUnits below } +//procedure FInitUnits; {X} - renamed to FInitUnitsHard +{X} procedure FInitUnitsHard; +var + Count: Integer; + Table: PUnitEntryTable; + P: procedure; +begin + if InitContext.InitTable = nil then + exit; + Count := InitContext.InitCount; + Table := InitContext.InitTable^.UnitInfo; +{$IFDEF LINUX} + Inc(Cardinal(Table), InitContext.Module^.GOT); +{$ENDIF} + try + while Count > 0 do + begin + Dec(Count); + InitContext.InitCount := Count; + P := Table^[Count].FInit; + if Assigned(P) then +{$IFDEF LINUX} + CallProc(P, InitContext.Module^.GOT); +{$ENDIF} +{$IFDEF MSWINDOWS} + TProc(P)(); +{$ENDIF} + end; + except + {X- rename: FInitUnits; { try to finalize the others } + FInitUnitsHard; + raise; + end; +end; + +// This handler can be set in initialization section of +// unit SysSfIni.pas only. +procedure InitUnitsHard( Table : PUnitEntryTable; Idx, Count : Integer ); +begin + try + InitUnitsLight( Table, Idx, Count ); + except + FInitUnitsHard; + raise; + end; +end; + +{X+ see comments in InitUnits below } +procedure FInitUnitsLight; +var + Count: Integer; + Table: PUnitEntryTable; + P: procedure; +begin + if InitContext.InitTable = nil then + exit; + Count := InitContext.InitCount; + Table := InitContext.InitTable^.UnitInfo; +{$IFDEF LINUX} + Inc(Cardinal(Table), InitContext.Module^.GOT); +{$ENDIF} + while Count > 0 do + begin + Dec(Count); + InitContext.InitCount := Count; + P := Table^[Count].FInit; + if Assigned(P) then +{$IFDEF LINUX} + CallProc(P, InitContext.Module^.GOT); +{$ENDIF} +{$IFDEF MSWINDOWS} + TProc(P)(); +{$ENDIF} + end; +end; + +{X+ see comments in InitUnits below } +procedure InitUnitsLight( Table : PUnitEntryTable; Idx, Count : Integer ); +var P : procedure; + Light : Boolean; +begin + Light := @InitUnitsProc = @InitUnitsLight; + while Idx < Count do + begin + P := Table^[ Idx ].Init; + Inc( Idx ); + InitContext.InitCount := Idx; + if Assigned( P ) then + P; + if Light and (@InitUnitsProc <> @InitUnitsLight) then + begin + InitUnitsProc( Table, Idx, Count ); + break; + end; + end; +end; + +{X+ see comments in body of InitUnits below } +procedure InitUnits; +var + Count, I: Integer; + Table: PUnitEntryTable; + {X- P: Pointer; } +begin + if InitContext.InitTable = nil then + exit; + Count := InitContext.InitTable^.UnitCount; + I := 0; + Table := InitContext.InitTable^.UnitInfo; +{$IFDEF LINUX} + Inc(Cardinal(Table), InitContext.Module^.GOT); +{$ENDIF} + (*X- by default, Delphi InitUnits uses try-except & raise constructions, + which leads to permanent use of all exception handler routines. + Let us make this by another way. + try + while I < Count do + begin + P := Table^[I].Init; + Inc(I); + InitContext.InitCount := I; + if Assigned(P) then + begin +{$IFDEF LINUX} + CallProc(P, InitContext.Module^.GOT); +{$ENDIF} +{$IFDEF MSWINDOWS} + TProc(P)(); +{$ENDIF} + end; + end; + except + FinalizeUnits; + raise; + end; + X+*) + InitUnitsProc( Table, I, Count ); //{X} +end; + +procedure _PackageLoad(const Table : PackageInfo; Module: PLibModule); +var + SavedContext: TInitContext; +begin + SavedContext := InitContext; + InitContext.DLLInitState := 0; + InitContext.InitTable := Table; + InitContext.InitCount := 0; + InitContext.Module := Module; + InitContext.OuterContext := @SavedContext; + try + InitUnits; + finally + InitContext := SavedContext; + end; +end; + + +procedure _PackageUnload(const Table : PackageInfo; Module: PLibModule); +var + SavedContext: TInitContext; +begin + SavedContext := InitContext; + InitContext.DLLInitState := 0; + InitContext.InitTable := Table; + InitContext.InitCount := Table^.UnitCount; + InitContext.Module := Module; + InitContext.OuterContext := @SavedContext; + try + {X} //FinalizeUnits; + FInitUnitsProc; + finally + InitContext := SavedContext; + end; +end; + +{$IFDEF LINUX} +procedure _StartExe(InitTable: PackageInfo; Module: PLibModule; Argc: Integer; Argv: Pointer); +begin + ArgCount := Argc; + ArgValues := Argv; +{$ENDIF} +{$IFDEF MSWINDOWS} +procedure _StartExe(InitTable: PackageInfo; Module: PLibModule); +begin + RaiseExceptionProc := @RaiseException; + RTLUnwindProc := @RTLUnwind; +{$ENDIF} + InitContext.InitTable := InitTable; + InitContext.InitCount := 0; + InitContext.Module := Module; + MainInstance := Module.Instance; +{$IFNDEF PC_MAPPED_EXCEPTIONS} + + {X SetExceptionHandler; - moved to SysSfIni.pas } + +{$ENDIF} + IsLibrary := False; + InitUnits; +end; + +{$IFDEF MSWINDOWS} +procedure _StartLib; +asm + { -> EAX InitTable } + { EDX Module } + { ECX InitTLS } + { [ESP+4] DllProc } + { [EBP+8] HInst } + { [EBP+12] Reason } + + { Push some desperately needed registers } + + PUSH ECX + PUSH ESI + PUSH EDI + + { Save the current init context into the stackframe of our caller } + + MOV ESI,offset InitContext + LEA EDI,[EBP- (type TExcFrame) - (type TInitContext)] + MOV ECX,(type TInitContext)/4 + REP MOVSD + + { Setup the current InitContext } + + POP InitContext.DLLSaveEDI + POP InitContext.DLLSaveESI + MOV InitContext.DLLSaveEBP,EBP + MOV InitContext.DLLSaveEBX,EBX + MOV InitContext.InitTable,EAX + MOV InitContext.Module,EDX + LEA ECX,[EBP- (type TExcFrame) - (type TInitContext)] + MOV InitContext.OuterContext,ECX + XOR ECX,ECX + CMP dword ptr [EBP+12],0 + JNE @@notShutDown + MOV ECX,[EAX].PackageInfoTable.UnitCount +@@notShutDown: + MOV InitContext.InitCount,ECX + + MOV EAX, offset RaiseException + MOV RaiseExceptionProc, EAX + MOV EAX, offset RTLUnwind + MOV RTLUnwindProc, EAX + + CALL SetExceptionHandler + + MOV EAX,[EBP+12] + INC EAX + MOV InitContext.DLLInitState,AL + DEC EAX + + { Init any needed TLS } + + POP ECX + MOV EDX,[ECX] + MOV InitContext.ExitProcessTLS,EDX + JE @@skipTLSproc + CMP AL,3 // DLL_THREAD_DETACH + JGE @@skipTLSproc // call ExitThreadTLS proc after DLLProc + CALL dword ptr [ECX+EAX*4] +@@skipTLSproc: + + { Call any DllProc } + + PUSH ECX + MOV ECX,[ESP+4] + TEST ECX,ECX + JE @@noDllProc + MOV EAX,[EBP+12] + MOV EDX,[EBP+16] + CALL ECX +@@noDllProc: + + POP ECX + MOV EAX, [EBP+12] + CMP AL,3 // DLL_THREAD_DETACH + JL @@afterDLLproc // don't free TLS on process shutdown + CALL dword ptr [ECX+EAX*4] + +@@afterDLLProc: + + { Set IsLibrary if there was no exe yet } + + CMP MainInstance,0 + JNE @@haveExe + MOV IsLibrary,1 + FNSTCW Default8087CW // save host exe's FPU preferences + +@@haveExe: + + MOV EAX,[EBP+12] + DEC EAX + JNE _Halt0 + CALL InitUnits + RET 4 +end; +{$ENDIF MSWINDOWS} +{$IFDEF LINUX} +procedure _StartLib(Context: PInitContext; Module: PLibModule; DLLProc: TDLLProcEx); +var + TempSwap: TInitContext; +begin + // Context's register save fields are already initialized. + // Save the current InitContext and activate the new Context by swapping them + TempSwap := InitContext; + InitContext := PInitContext(Context)^; + PInitContext(Context)^ := TempSwap; + + InitContext.Module := Module; + InitContext.OuterContext := Context; + + // DLLInitState is initialized by SysInit to 0 for shutdown, 1 for startup + // Inc DLLInitState to distinguish from package init: + // 0 for package, 1 for DLL shutdown, 2 for DLL startup + + Inc(InitContext.DLLInitState); + + if InitContext.DLLInitState = 1 then + begin + InitContext.InitTable := Module.InitTable; + if Assigned(InitContext.InitTable) then + InitContext.InitCount := InitContext.InitTable.UnitCount // shutdown + end + else + begin + Module.InitTable := InitContext.InitTable; // save for shutdown + InitContext.InitCount := 0; // startup + end; + + if Assigned(DLLProc) then + DLLProc(InitContext.DLLInitState-1,0); + + if MainInstance = 0 then { Set IsLibrary if there was no exe yet } + begin + IsLibrary := True; + Default8087CW := Get8087CW; + end; + + if InitContext.DLLInitState = 1 then + _Halt0 + else + InitUnits; +end; +{$ENDIF} + +procedure _InitResStrings; +asm + { -> EAX Pointer to init table } + { record } + { cnt: Integer; } + { tab: array [1..cnt] record } + { variableAddress: Pointer; } + { resStringAddress: Pointer; } + { end; } + { end; } + { EBX = caller's GOT for PIC callers, 0 for non-PIC } + +{$IFDEF MSWINDOWS} + PUSH EBX + XOR EBX,EBX +{$ENDIF} + PUSH EDI + PUSH ESI + MOV EDI,[EBX+EAX] + LEA ESI,[EBX+EAX+4] +@@loop: + MOV EAX,[ESI+4] { load resStringAddress } + MOV EDX,[ESI] { load variableAddress } + ADD EAX,EBX + ADD EDX,EBX + CALL LoadResString + ADD ESI,8 + DEC EDI + JNZ @@loop + + POP ESI + POP EDI +{$IFDEF MSWINDOWS} + POP EBX +{$ENDIF} +end; + +procedure _InitResStringImports; +asm + { -> EAX Pointer to init table } + { record } + { cnt: Integer; } + { tab: array [1..cnt] record } + { variableAddress: Pointer; } + { resStringAddress: ^Pointer; } + { end; } + { end; } + { EBX = caller's GOT for PIC callers, 0 for non-PIC } + +{$IFDEF MSWINDOWS} + PUSH EBX + XOR EBX,EBX +{$ENDIF} + PUSH EDI + PUSH ESI + MOV EDI,[EBX+EAX] + LEA ESI,[EBX+EAX+4] +@@loop: + MOV EAX,[ESI+4] { load address of import } + MOV EDX,[ESI] { load address of variable } + MOV EAX,[EBX+EAX] { load contents of import } + ADD EDX,EBX + CALL LoadResString + ADD ESI,8 + DEC EDI + JNZ @@loop + + POP ESI + POP EDI +{$IFDEF MSWINDOWS} + POP EBX +{$ENDIF} +end; + +procedure _InitImports; +asm + { -> EAX Pointer to init table } + { record } + { cnt: Integer; } + { tab: array [1..cnt] record } + { variableAddress: Pointer; } + { sourceAddress: ^Pointer; } + { sourceOffset: Longint; } + { end; } + { end; } + { EBX = caller's GOT for PIC callers, 0 for non-PIC } + +{$IFDEF MSWINDOWS} + PUSH EBX + XOR EBX,EBX +{$ENDIF} + PUSH EDI + PUSH ESI + MOV EDI,[EBX+EAX] + LEA ESI,[EBX+EAX+4] +@@loop: + MOV EAX,[ESI+4] { load address of import } + MOV EDX,[ESI] { load address of variable } + MOV EAX,[EBX+EAX] { load contents of import } + ADD EAX,[ESI+8] { calc address of variable } + MOV [EBX+EDX],EAX { store result } + ADD ESI,12 + DEC EDI + JNZ @@loop + + POP ESI + POP EDI +{$IFDEF MSWINDOWS} + POP EBX +{$ENDIF} +end; + +{$IFDEF MSWINDOWS} +procedure _InitWideStrings; +asm + { -> EAX Pointer to init table } + { record } + { cnt: Integer; } + { tab: array [1..cnt] record } + { variableAddress: Pointer; } + { stringAddress: ^Pointer; } + { end; } + { end; } + + PUSH EBX + PUSH ESI + MOV EBX,[EAX] + LEA ESI,[EAX+4] +@@loop: + MOV EDX,[ESI+4] { load address of string } + MOV EAX,[ESI] { load address of variable } + CALL _WStrAsg + ADD ESI,8 + DEC EBX + JNZ @@loop + + POP ESI + POP EBX +end; +{$ENDIF} + +var + runErrMsg: array[0..29] of Char = 'Runtime error at 00000000'#0; + // columns: 0123456789012345678901234567890 + errCaption: array[0..5] of Char = 'Error'#0; + + +procedure MakeErrorMessage; +const + dig : array [0..15] of Char = '0123456789ABCDEF'; +var + digit: Byte; + Temp: Integer; + Addr: Cardinal; +begin + digit := 16; + Temp := ExitCode; + repeat + runErrMsg[digit] := Char(Ord('0') + (Temp mod 10)); + Temp := Temp div 10; + Dec(digit); + until Temp = 0; + digit := 28; + Addr := Cardinal(ErrorAddr); + repeat + runErrMsg[digit] := dig[Addr and $F]; + Addr := Addr div 16; + Dec(digit); + until Addr = 0; +end; + + +procedure ExitDll; +asm + { Return False if ExitCode <> 0, and set ExitCode to 0 } + + XOR EAX,EAX +{$IFDEF PIC} + MOV ECX,[EBX].ExitCode + XCHG EAX,[ECX] +{$ELSE} + XCHG EAX, ExitCode +{$ENDIF} + NEG EAX + SBB EAX,EAX + INC EAX + + { Restore the InitContext } +{$IFDEF PIC} + LEA EDI, [EBX].InitContext +{$ELSE} + MOV EDI, offset InitContext +{$ENDIF} + + MOV EBX,[EDI].TInitContext.DLLSaveEBX + MOV EBP,[EDI].TInitContext.DLLSaveEBP + PUSH [EDI].TInitContext.DLLSaveESI + PUSH [EDI].TInitContext.DLLSaveEDI + + MOV ESI,[EDI].TInitContext.OuterContext + MOV ECX,(type TInitContext)/4 + REP MOVSD + POP EDI + POP ESI + + LEAVE +{$IFDEF MSWINDOWS} + RET 12 +{$ENDIF} +{$IFDEF LINUX} + RET +{$ENDIF} +end; + +// {X} Procedure Halt0 refers to WriteLn and MessageBox +// but actually such code can be not used really. +// So, implementation changed to avoid such references. +// +// Either call UseErrorMessageBox or UseErrorMessageWrite +// to provide error message output in GUI or console app. +// {X}+ + +var ErrorMessageOutProc : procedure = DummyProc; + +procedure ErrorMessageBox; +begin + MakeErrorMessage; + if not NoErrMsg then + MessageBox(0, runErrMsg, errCaption, 0); +end; + +procedure UseErrorMessageBox; +begin + ErrorMessageOutProc := ErrorMessageBox; +end; + +procedure ErrorMessageWrite; +begin + MakeErrorMessage; + WriteLn(PChar(@runErrMsg)); +end; + +procedure UseErrorMessageWrite; +begin + ErrorMessageOutProc := ErrorMessageWrite; +end; + +procedure DoCloseInputOutput; +begin + Close( Input ); + Close( Output ); + Close(ErrOutput); +end; + +var CloseInputOutput : procedure = DummyProc; + +procedure UseInputOutput; +begin + if not assigned( CloseInputOutput ) then + begin + CloseInputOutput := DoCloseInputOutput; + //_Assign( Input, '' ); was for D5 so - changed + //_Assign( Output, '' ); was for D5 so - changed + TTextRec(Input).Mode := fmClosed; + TTextRec(Output).Mode := fmClosed; + TTextRec(ErrOutput).Mode := fmClosed; + end; +end; + +// {X}- +(*X- +procedure WriteErrorMessage; +{$IFDEF MSWINDOWS} +var + Dummy: Cardinal; +begin + if IsConsole then + begin + with TTextRec(Output) do + begin + if (Mode = fmOutput) and (BufPos > 0) then + TTextIOFunc(InOutFunc)(TTextRec(Output)); // flush out text buffer + end; + WriteFile(GetStdHandle(STD_OUTPUT_HANDLE), runErrMsg, Sizeof(runErrMsg), Dummy, nil); + WriteFile(GetStdHandle(STD_OUTPUT_HANDLE), sLineBreak, 2, Dummy, nil); + end + else if not NoErrMsg then + MessageBox(0, runErrMsg, errCaption, 0); +{$ENDIF} +{$IFDEF LINUX} +var + c: Char; +begin + with TTextRec(Output) do + begin + if (Mode = fmOutput) and (BufPos > 0) then + TTextIOFunc(InOutFunc)(TTextRec(Output)); // flush out text buffer + end; + __write(STDERR_FILENO, @runErrMsg, Sizeof(runErrMsg)-1); + c := sLineBreak; + __write(STDERR_FILENO, @c, 1); +{$ENDIF} +end; +X+*) + +procedure _Halt0; +var + P: procedure; +begin +{$IFDEF LINUX} + if (ExitCode <> 0) and CoreDumpEnabled then + __raise(SIGABRT); +{$ENDIF} + + if InitContext.DLLInitState = 0 then + while ExitProc <> nil do + begin + @P := ExitProc; + ExitProc := nil; + P; + end; + + { If there was some kind of runtime error, alert the user } + + if ErrorAddr <> nil then + begin + {X+} + ErrorMessageOutProc; + { + MakeErrorMessage; + if IsConsole then + WriteLn(PChar(@runErrMsg)) + else if not NoErrMsg then + MessageBox(0, runErrMsg, errCaption, 0); + } {X-} + + {X- As it is said by Alexey Torgashin, it is better not to clear ErrorAddr + to make possible check ErrorAddr <> nil in finalization of rest units. + If you want, you can uncomment it again: } + //ErrorAddr := nil; + {X+} + end; + + { This loop exists because we might be nested in PackageLoad calls when } + { Halt got called. We need to unwind these contexts. } + + while True do + begin + + { If we are a library, and we are starting up fine, there are no units to finalize } + + if (InitContext.DLLInitState = 2) and (ExitCode = 0) then + InitContext.InitCount := 0; + + { Undo any unit initializations accomplished so far } + + // {X} FinalizeUnits; -- renamed + FInitUnitsProc; + + if (InitContext.DLLInitState <= 1) or (ExitCode <> 0) then + begin + if InitContext.Module <> nil then + with InitContext do + begin + UnregisterModule(Module); +{$IFDEF PC_MAPPED_EXCEPTIONS} + SysUnregisterIPLookup(Module.CodeSegStart); +{$ENDIF} + if (Module.ResInstance <> Module.Instance) and (Module.ResInstance <> 0) then + FreeLibrary(Module.ResInstance); + end; + end; + +{$IFNDEF PC_MAPPED_EXCEPTIONS} + {X UnsetExceptionHandler; - changed to call of handler } + UnsetExceptionHandlerProc; +{$ENDIF} + +{$IFDEF MSWINDOWS} + if InitContext.DllInitState = 1 then + InitContext.ExitProcessTLS; +{$ENDIF} + + if InitContext.DllInitState <> 0 then + ExitDll; + + if InitContext.OuterContext = nil then + begin + { + If an ExitProcessProc is set, we call it. Note that at this + point the RTL is completely shutdown. The only thing this is used + for right now is the proper semantic handling of signals under Linux. + } + if Assigned(ExitProcessProc) then + ExitProcessProc; + ExitProcess(ExitCode); + end; + + InitContext := InitContext.OuterContext^ + end; +end; + +procedure _Halt; +begin + ExitCode := Code; + _Halt0; +end; + + +procedure _Run0Error; +{$IFDEF PUREPASCAL} +begin + _RunError(0); // loses return address +end; +{$ELSE} +asm + XOR EAX,EAX + JMP _RunError +end; +{$ENDIF} + + +procedure _RunError(errorCode: Byte); +{$IFDEF PUREPASCAL} +begin + ErrorAddr := Pointer(-1); // no return address available + Halt(errorCode); +end; +{$ELSE} +asm +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX, EAX + POP EAX + MOV ECX, [EBX].ErrorAddr + POP [ECX] +{$ELSE} + POP ErrorAddr +{$ENDIF} + JMP _Halt +end; +{$ENDIF} + +procedure _UnhandledException; +type TExceptProc = procedure (Obj: TObject; Addr: Pointer); +begin + if Assigned(ExceptProc) then + TExceptProc(ExceptProc)(ExceptObject, ExceptAddr) + else + RunError(230); +end; + +procedure _Assert(const Message, Filename: AnsiString; LineNumber: Integer); +{$IFDEF PUREPASCAL} +begin + if Assigned(AssertErrorProc) then + AssertErrorProc(Message, Filename, LineNumber, Pointer(-1)) + else + Error(reAssertionFailed); // loses return address +end; +{$ELSE} +asm + PUSH EBX +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + MOV EBX, EAX + MOV EAX, [EBX].AssertErrorProc + CMP [EAX], 0 + POP ECX + POP EAX +{$ELSE} + CMP AssertErrorProc,0 +{$ENDIF} + JNZ @@1 + MOV AL,reAssertionFailed + CALL Error + JMP @@exit + +@@1: PUSH [ESP+4].Pointer +{$IFDEF PIC} + MOV EBX, [EBX].AssertErrorProc + CALL [EBX] +{$ELSE} + CALL AssertErrorProc +{$ENDIF} +@@exit: + POP EBX +end; +{$ENDIF} + +type + PThreadRec = ^TThreadRec; + TThreadRec = record + Func: TThreadFunc; + Parameter: Pointer; + end; + +{$IFDEF MSWINDOWS} +function ThreadWrapper(Parameter: Pointer): Integer; stdcall; +{$ELSE} +function ThreadWrapper(Parameter: Pointer): Pointer; cdecl; +{$ENDIF} +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + { Mark the top of the stack with a signature } + PUSH UNWINDFI_TOPOFSTACK +{$ENDIF} + CALL _FpuInit + PUSH EBP +{$IFNDEF PC_MAPPED_EXCEPTIONS} + XOR ECX,ECX + PUSH offset _ExceptionHandler + MOV EDX,FS:[ECX] + PUSH EDX + MOV FS:[ECX],ESP +{$ENDIF} + MOV EAX,Parameter + + MOV ECX,[EAX].TThreadRec.Parameter + MOV EDX,[EAX].TThreadRec.Func + PUSH ECX + PUSH EDX + CALL _FreeMem + POP EDX + POP EAX + CALL EDX + +{$IFNDEF PC_MAPPED_EXCEPTIONS} + XOR EDX,EDX + POP ECX + MOV FS:[EDX],ECX + POP ECX +{$ENDIF} + POP EBP +{$IFDEF PC_MAPPED_EXCEPTIONS} + { Ditch our TOS marker } + ADD ESP, 4 +{$ENDIF} +end; + + +{$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} + +{$IFDEF LINUX} +function BeginThread(Attribute: PThreadAttr; + ThreadFunc: TThreadFunc; + Parameter: Pointer; + var ThreadId: Cardinal): Integer; +var + P: PThreadRec; +begin + if Assigned(BeginThreadProc) then + Result := BeginThreadProc(Attribute, ThreadFunc, Parameter, ThreadId) + else + begin + New(P); + P.Func := ThreadFunc; + P.Parameter := Parameter; + IsMultiThread := True; + Result := _pthread_create(ThreadID, Attribute, @ThreadWrapper, P); + end; +end; + +procedure EndThread(ExitCode: Integer); +begin + if Assigned(EndThreadProc) then + EndThreadProc(ExitCode); + // No "else" required since EndThreadProc does not (!!should not!!) return. + _pthread_detach(GetCurrentThreadID); + _pthread_exit(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); +{$IFDEF PUREPASCAL} +var + P: PStrRec; +begin + if Pointer(S) <> nil then + begin + P := Pointer(Integer(S) - Sizeof(StrRec)); + Pointer(S) := nil; + if P.refCnt > 0 then + if InterlockedDecrement(P.refCnt) = 0 then + FreeMem(P); + end; +end; +{$ELSE} +asm + { -> EAX pointer to str } + + MOV EDX,[EAX] { fetch str } + TEST EDX,EDX { if nil, nothing to do } + JE @@done + MOV dword ptr [EAX],0 { clear str } + MOV ECX,[EDX-skew].StrRec.refCnt { fetch refCnt } + DEC ECX { if < 0: literal str } + JL @@done +{X LOCK} DEC [EDX-skew].StrRec.refCnt { NONthreadsafe dec refCount } + JNE @@done + PUSH EAX + LEA EAX,[EDX-skew].StrRec.refCnt { if refCnt now zero, deallocate} + CALL _FreeMem + POP EAX +@@done: +end; +{$ENDIF} + +procedure _LStrArrayClr(var StrArray; cnt: longint); +{$IFDEF PUREPASCAL} +var + P: Pointer; +begin + P := @StrArray; + while cnt > 0 do + begin + _LStrClr(P^); + Dec(cnt); + Inc(Integer(P), sizeof(Pointer)); + end; +end; +{$ELSE} +asm + { -> EAX pointer to str } + { EDX cnt } + + PUSH EBX + PUSH ESI + MOV EBX,EAX + MOV ESI,EDX + +@@loop: + MOV EDX,[EBX] { fetch str } + TEST EDX,EDX { if nil, nothing to do } + JE @@doneEntry + MOV dword ptr [EBX],0 { clear str } + MOV ECX,[EDX-skew].StrRec.refCnt { fetch refCnt } + DEC ECX { if < 0: literal str } + JL @@doneEntry +{X LOCK} DEC [EDX-skew].StrRec.refCnt { NONthreadsafe dec refCount } + JNE @@doneEntry + LEA EAX,[EDX-skew].StrRec.refCnt { if refCnt now zero, deallocate} + CALL _FreeMem +@@doneEntry: + ADD EBX,4 + DEC ESI + JNE @@loop + + POP ESI + POP EBX +end; +{$ENDIF} + +{ 99.03.11 + This function is used when assigning to global variables. + + Literals are copied to prevent a situation where a dynamically + allocated DLL or package assigns a literal to a variable and then + is unloaded -- thereby causing the string memory (in the code + segment of the DLL) to be removed -- and therefore leaving the + global variable pointing to invalid memory. +} +procedure _LStrAsg(var dest; const source); +{$IFDEF PUREPASCAL} +var + S, D: Pointer; + P: PStrRec; + Temp: Longint; +begin + S := Pointer(source); + if S <> nil then + begin + P := PStrRec(Integer(S) - sizeof(StrRec)); + if P.refCnt < 0 then // make copy of string literal + begin + Temp := P.length; + S := _NewAnsiString(Temp); + Move(Pointer(source)^, S^, Temp); + P := PStrRec(Integer(S) - sizeof(StrRec)); + end; + InterlockedIncrement(P.refCnt); + end; + + D := Pointer(dest); + Pointer(dest) := S; + if D <> nil then + begin + P := PStrRec(Integer(D) - sizeof(StrRec)); + if P.refCnt > 0 then + if InterlockedDecrement(P.refCnt) = 0 then + FreeMem(P); + end; +end; +{$ELSE} +asm + { -> EAX pointer to dest str } + { -> EDX pointer to source str } + + TEST EDX,EDX { have a source? } + JE @@2 { no -> jump } + + MOV ECX,[EDX-skew].StrRec.refCnt + INC ECX + JG @@1 { literal string -> jump not taken } + + PUSH EAX + PUSH EDX + MOV EAX,[EDX-skew].StrRec.length + CALL _NewAnsiString + MOV EDX,EAX + POP EAX + PUSH EDX + MOV ECX,[EAX-skew].StrRec.length + CALL Move + POP EDX + POP EAX + JMP @@2 + +@@1: + {X LOCK} INC [EDX-skew].StrRec.refCnt + +@@2: XCHG EDX,[EAX] + TEST EDX,EDX + JE @@3 + MOV ECX,[EDX-skew].StrRec.refCnt + DEC ECX + JL @@3 + {X LOCK} DEC [EDX-skew].StrRec.refCnt + JNE @@3 + LEA EAX,[EDX-skew].StrRec.refCnt + CALL _FreeMem +@@3: +end; +{$ENDIF} + +procedure _LStrLAsg(var dest; const source); +{$IFDEF PUREPASCAL} +var + P: Pointer; +begin + P := Pointer(source); + _LStrAddRef(P); + P := Pointer(dest); + Pointer(dest) := Pointer(source); + _LStrClr(P); +end; +{$ELSE} +asm +{ -> EAX pointer to dest } +{ EDX source } + + TEST EDX,EDX + JE @@sourceDone + + { bump up the ref count of the source } + + MOV ECX,[EDX-skew].StrRec.refCnt + INC ECX + JLE @@sourceDone { literal assignment -> jump taken } + {X LOCK} INC [EDX-skew].StrRec.refCnt +@@sourceDone: + + { we need to release whatever the dest is pointing to } + + XCHG EDX,[EAX] { fetch str } + TEST EDX,EDX { if nil, nothing to do } + JE @@done + MOV ECX,[EDX-skew].StrRec.refCnt { fetch refCnt } + DEC ECX { if < 0: literal str } + JL @@done + {X LOCK} DEC [EDX-skew].StrRec.refCnt { NONthreadsafe dec refCount } + JNE @@done + LEA EAX,[EDX-skew].StrRec.refCnt { if refCnt now zero, deallocate} + CALL _FreeMem +@@done: +end; +{$ENDIF} + +function _NewAnsiString(length: Longint): Pointer; +{$IFDEF PUREPASCAL} +var + P: PStrRec; +begin + Result := nil; + if length <= 0 then Exit; + // Alloc an extra null for strings with even length. This has no actual cost + // since the allocator will round up the request to an even size anyway. + // All widestring allocations have even length, and need a double null terminator. + GetMem(P, length + sizeof(StrRec) + 1 + ((length + 1) and 1)); + Result := Pointer(Integer(P) + sizeof(StrRec)); + P.length := length; + P.refcnt := 1; + PWideChar(Result)[length div 2] := #0; // length guaranteed >= 2 +end; +{$ELSE} +asm + { -> EAX length } + { <- EAX pointer to new string } + + TEST EAX,EAX + JLE @@null + PUSH EAX + ADD EAX,rOff+2 // one or two nulls (Ansi/Wide) + AND EAX, not 1 // round up to even length + PUSH EAX + CALL _GetMem + POP EDX // actual allocated length (>= 2) + MOV word ptr [EAX+EDX-2],0 // double null terminator + ADD EAX,rOff + POP EDX // requested string length + MOV [EAX-skew].StrRec.length,EDX + MOV [EAX-skew].StrRec.refCnt,1 + RET +@@null: + XOR EAX,EAX +end; +{$ENDIF} + +procedure _LStrFromPCharLen(var Dest: AnsiString; Source: PAnsiChar; Length: Integer); +asm + { -> EAX pointer to dest } + { EDX source } + { ECX length } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + { allocate new string } + + MOV EAX,EDI + + CALL _NewAnsiString + MOV ECX,EDI + MOV EDI,EAX + + TEST ESI,ESI + JE @@noMove + + MOV EDX,EAX + MOV EAX,ESI + CALL Move + + { assign the result to dest } + +@@noMove: + MOV EAX,EBX + CALL _LStrClr + MOV [EBX],EDI + + POP EDI + POP ESI + POP EBX +end; + + +{$IFDEF LINUX} +function BufConvert(var Dest; DestBytes: Integer; + const Source; SrcBytes: Integer; + context: Integer): Integer; +var + SrcBytesLeft, DestBytesLeft: Integer; + s, d: Pointer; +begin + if context = -1 then + begin + Result := -1; + Exit; + end; + // make copies of params... iconv modifies param ptrs + DestBytesLeft := DestBytes; + SrcBytesLeft := SrcBytes; + s := Pointer(Source); + d := Pointer(Dest); + if (SrcBytes = 0) or (DestBytes = 0) then + Result := 0 + else + begin + Result := iconv(context, s, SrcBytesLeft, d, DestBytesLeft); + while (SrcBytesLeft > 0) and (DestBytesLeft > 0) + and (Result = -1) and (GetLastError = 7) do + begin + Result := iconv(context, s, SrcBytesLeft, d, DestBytesLeft); + end; + + if Result <> -1 then + Result := DestBytes - DestBytesLeft; + end; + + iconv_close(context); +end; +{$ENDIF} + + +function CharFromWChar(CharDest: PChar; DestBytes: Integer; const WCharSource: PWideChar; SrcChars: Integer): Integer; +begin +{$IFDEF LINUX} + Result := BufConvert(CharDest, DestBytes, WCharSource, SrcChars * sizeof(WideChar), + iconv_open(nl_langinfo(_NL_CTYPE_CODESET_NAME), 'UNICODELITTLE')); +{$ENDIF} +{$IFDEF MSWINDOWS} + Result := WideCharToMultiByte(0, 0, WCharSource, SrcChars, + CharDest, DestBytes, nil, nil); +{$ENDIF} +end; + + +function WCharFromChar(WCharDest: PWideChar; DestChars: Integer; const CharSource: PChar; SrcBytes: Integer): Integer; +begin +{$IFDEF LINUX} + Result := BufConvert(WCharDest, DestChars * sizeof(WideChar), CharSource, SrcBytes, + iconv_open('UNICODELITTLE', nl_langinfo(_NL_CTYPE_CODESET_NAME))) div sizeof(WideChar); +{$ENDIF} +{$IFDEF MSWINDOWS} + Result := MultiByteToWideChar(0, 0, CharSource, SrcBytes, + WCharDest, DestChars); +{$ENDIF} +end; + + +procedure _LStrFromPWCharLen(var Dest: AnsiString; Source: PWideChar; Length: Integer); +var + DestLen: Integer; + Buffer: array[0..4095] of Char; +begin + if Length <= 0 then + begin + _LStrClr(Dest); + Exit; + end; + if Length+1 < (High(Buffer) div sizeof(WideChar)) then + begin + DestLen := CharFromWChar(Buffer, High(Buffer), Source, Length); + if DestLen >= 0 then + begin + _LStrFromPCharLen(Dest, Buffer, DestLen); + Exit; + end; + end; + + DestLen := (Length + 1) * sizeof(WideChar); + SetLength(Dest, DestLen); // overallocate, trim later + DestLen := CharFromWChar(Pointer(Dest), DestLen, Source, Length); + if DestLen < 0 then DestLen := 0; + SetLength(Dest, DestLen); +end; + + +procedure _LStrFromChar(var Dest: AnsiString; Source: AnsiChar); +asm + PUSH EDX + MOV EDX,ESP + MOV ECX,1 + CALL _LStrFromPCharLen + POP EDX +end; + + +procedure _LStrFromWChar(var Dest: AnsiString; Source: WideChar); +asm + PUSH EDX + MOV EDX,ESP + MOV ECX,1 + CALL _LStrFromPWCharLen + POP EDX +end; + + +procedure _LStrFromPChar(var Dest: AnsiString; Source: PAnsiChar); +asm + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CL,[EDX+0] + JE @@4 + CMP CL,[EDX+1] + JE @@3 + CMP CL,[EDX+2] + JE @@2 + CMP CL,[EDX+3] + JE @@1 + ADD EDX,4 + JMP @@0 +@@1: INC EDX +@@2: INC EDX +@@3: INC EDX +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX +@@5: JMP _LStrFromPCharLen +end; + + +procedure _LStrFromPWChar(var Dest: AnsiString; Source: PWideChar); +asm + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CX,[EDX+0] + JE @@4 + CMP CX,[EDX+2] + JE @@3 + CMP CX,[EDX+4] + JE @@2 + CMP CX,[EDX+6] + JE @@1 + ADD EDX,8 + JMP @@0 +@@1: ADD EDX,2 +@@2: ADD EDX,2 +@@3: ADD EDX,2 +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX + SHR ECX,1 +@@5: JMP _LStrFromPWCharLen +end; + + +procedure _LStrFromString(var Dest: AnsiString; const Source: ShortString); +asm + XOR ECX,ECX + MOV CL,[EDX] + INC EDX + JMP _LStrFromPCharLen +end; + + +procedure _LStrFromArray(var Dest: AnsiString; Source: PAnsiChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASB + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _LStrFromPCharLen +end; + + +procedure _LStrFromWArray(var Dest: AnsiString; Source: PWideChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASW + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _LStrFromPWCharLen +end; + + +procedure _LStrFromWStr(var Dest: AnsiString; const Source: WideString); +asm + { -> EAX pointer to dest } + { EDX pointer to WideString data } + + XOR ECX,ECX + TEST EDX,EDX + JE @@1 + MOV ECX,[EDX-4] + SHR ECX,1 +@@1: JMP _LStrFromPWCharLen +end; + + +procedure _LStrToString{(var Dest: ShortString; const Source: AnsiString; MaxLen: Integer)}; +asm + { -> EAX pointer to result } + { EDX AnsiString s } + { ECX length of result } + + PUSH EBX + TEST EDX,EDX + JE @@empty + MOV EBX,[EDX-skew].StrRec.length + TEST EBX,EBX + JE @@empty + + CMP ECX,EBX + JL @@truncate + MOV ECX,EBX +@@truncate: + MOV [EAX],CL + INC EAX + + XCHG EAX,EDX + CALL Move + + JMP @@exit + +@@empty: + MOV byte ptr [EAX],0 + +@@exit: + POP EBX +end; + +function _LStrLen(const s: AnsiString): LongInt; //inline; +{$IFDEF PUREPASCAL} +begin + if Assigned(Pointer(s)) then + Result := PInteger(Integer(s) - 4)^ + else + Result := 0; + //Result := PStrRec(Integer(s) - sizeof(StrRec)).length; +end; +{$ELSE} +asm + { -> EAX str } + + TEST EAX,EAX + JE @@done + MOV EAX,[EAX-skew].StrRec.length; +@@done: +end; +{$ENDIF} + + +procedure _LStrCat{var dest: AnsiString; source: AnsiString}; +asm + { -> EAX pointer to dest } + { EDX source } + + TEST EDX,EDX + JE @@exit + + MOV ECX,[EAX] + TEST ECX,ECX + JE _LStrAsg + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,[ECX-skew].StrRec.length + + MOV EDX,[ESI-skew].StrRec.length + ADD EDX,EDI + CMP ESI,ECX + JE @@appendSelf + + CALL _LStrSetLength + MOV EAX,ESI + MOV ECX,[ESI-skew].StrRec.length + +@@appendStr: + MOV EDX,[EBX] + ADD EDX,EDI + CALL Move + POP EDI + POP ESI + POP EBX + RET + +@@appendSelf: + CALL _LStrSetLength + MOV EAX,[EBX] + MOV ECX,EDI + JMP @@appendStr + +@@exit: +end; + + +procedure _LStrCat3{var dest:AnsiString; source1: AnsiString; source2: AnsiString}; +asm + { ->EAX = Pointer to dest } + { EDX = source1 } + { ECX = source2 } + + TEST EDX,EDX + JE @@assignSource2 + + TEST ECX,ECX + JE _LStrAsg + + CMP EDX,[EAX] + JE @@appendToDest + + CMP ECX,[EAX] + JE @@theHardWay + + PUSH EAX + PUSH ECX + CALL _LStrAsg + + POP EDX + POP EAX + JMP _LStrCat + +@@theHardWay: + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EDX + MOV ESI,ECX + PUSH EAX + + MOV EAX,[EBX-skew].StrRec.length + ADD EAX,[ESI-skew].StrRec.length + CALL _NewAnsiString + + MOV EDI,EAX + MOV EDX,EAX + MOV EAX,EBX + MOV ECX,[EBX-skew].StrRec.length + CALL Move + + MOV EDX,EDI + MOV EAX,ESI + MOV ECX,[ESI-skew].StrRec.length + ADD EDX,[EBX-skew].StrRec.length + CALL Move + + POP EAX + MOV EDX,EDI + TEST EDI,EDI + JE @@skip + DEC [EDI-skew].StrRec.refCnt // EDI = local temp str +@@skip: + CALL _LStrAsg + + POP EDI + POP ESI + POP EBX + + JMP @@exit + +@@assignSource2: + MOV EDX,ECX + JMP _LStrAsg + +@@appendToDest: + MOV EDX,ECX + JMP _LStrCat + +@@exit: +end; + + +procedure _LStrCatN{var dest:AnsiString; argCnt: Integer; ...}; +asm + { ->EAX = Pointer to dest } + { EDX = number of args (>= 3) } + { [ESP+4], [ESP+8], ... crgCnt AnsiString arguments, reverse order } + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EDX + PUSH EAX + MOV EBX,EDX + + XOR EDI,EDI + MOV ECX,[ESP+EDX*4+5*4] // first arg is furthest out + TEST ECX,ECX + JZ @@0 + CMP [EAX],ECX // is dest = first arg? + JNE @@0 + MOV EDI,EAX // EDI nonzero -> potential appendstr case +@@0: + XOR EAX,EAX +@@loop1: + MOV ECX,[ESP+EDX*4+5*4] + TEST ECX,ECX + JE @@1 + ADD EAX,[ECX-skew].StrRec.length + CMP EDI,ECX // is dest an arg besides arg1? + JNE @@1 + XOR EDI,EDI // can't appendstr - dest is multiple args +@@1: + DEC EDX + JNE @@loop1 + +@@append: + TEST EDI,EDI // dest is 1st and only 1st arg? + JZ @@copy + MOV EDX,EAX // length into EDX + MOV EAX,EDI // ptr to str into EAX + MOV ESI,[EDI] + MOV ESI,[ESI-skew].StrRec.Length // save old size before realloc + CALL _LStrSetLength + PUSH EDI // append other strs to dest + ADD ESI,[EDI] // end of old string + DEC EBX + JMP @@loop2 + +@@copy: + CALL _NewAnsiString + PUSH EAX + MOV ESI,EAX + +@@loop2: + MOV EAX,[ESP+EBX*4+6*4] + MOV EDX,ESI + TEST EAX,EAX + JE @@2 + MOV ECX,[EAX-skew].StrRec.length + ADD ESI,ECX + CALL Move +@@2: + DEC EBX + JNE @@loop2 + + POP EDX + POP EAX + TEST EDI,EDI + JNZ @@exit + + TEST EDX,EDX + JE @@skip + DEC [EDX-skew].StrRec.refCnt // EDX = local temp str +@@skip: + CALL _LStrAsg + +@@exit: + POP EDX + POP EDI + POP ESI + POP EBX + POP EAX + LEA ESP,[ESP+EDX*4] + JMP EAX +end; + + +procedure _LStrCmp{left: AnsiString; right: AnsiString}; +asm +{ ->EAX = Pointer to left string } +{ EDX = Pointer to right string } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + CMP EAX,EDX + JE @@exit + + TEST ESI,ESI + JE @@str1null + + TEST EDI,EDI + JE @@str2null + + MOV EAX,[ESI-skew].StrRec.length + MOV EDX,[EDI-skew].StrRec.length + + SUB EAX,EDX { eax = len1 - len2 } + JA @@skip1 + ADD EDX,EAX { edx = len2 + (len1 - len2) = len1 } + +@@skip1: + PUSH EDX + SHR EDX,2 + JE @@cmpRest +@@longLoop: + MOV ECX,[ESI] + MOV EBX,[EDI] + CMP ECX,EBX + JNE @@misMatch + DEC EDX + JE @@cmpRestP4 + MOV ECX,[ESI+4] + MOV EBX,[EDI+4] + CMP ECX,EBX + JNE @@misMatch + ADD ESI,8 + ADD EDI,8 + DEC EDX + JNE @@longLoop + JMP @@cmpRest +@@cmpRestP4: + ADD ESI,4 + ADD EDI,4 +@@cmpRest: + POP EDX + AND EDX,3 + JE @@equal + + MOV ECX,[ESI] + MOV EBX,[EDI] + CMP CL,BL + JNE @@exit + DEC EDX + JE @@equal + CMP CH,BH + JNE @@exit + DEC EDX + JE @@equal + AND EBX,$00FF0000 + AND ECX,$00FF0000 + CMP ECX,EBX + JNE @@exit + +@@equal: + ADD EAX,EAX + JMP @@exit + +@@str1null: + MOV EDX,[EDI-skew].StrRec.length + SUB EAX,EDX + JMP @@exit + +@@str2null: + MOV EAX,[ESI-skew].StrRec.length + SUB EAX,EDX + JMP @@exit + +@@misMatch: + POP EDX + CMP CL,BL + JNE @@exit + CMP CH,BH + JNE @@exit + SHR ECX,16 + SHR EBX,16 + CMP CL,BL + JNE @@exit + CMP CH,BH + +@@exit: + POP EDI + POP ESI + POP EBX + +end; + +function _LStrAddRef(var str): Pointer; +{$IFDEF PUREPASCAL} +var + P: PStrRec; +begin + P := Pointer(Integer(str) - sizeof(StrRec)); + if P <> nil then + if P.refcnt >= 0 then + InterlockedIncrement(P.refcnt); + Result := Pointer(str); +end; +{$ELSE} +asm + { -> EAX str } + TEST EAX,EAX + JE @@exit + MOV EDX,[EAX-skew].StrRec.refCnt + INC EDX + JLE @@exit +{X LOCK} INC [EAX-skew].StrRec.refCnt +@@exit: +end; +{$ENDIF} + +function PICEmptyString: PWideChar; +begin + Result := ''; +end; + +function _LStrToPChar(const s: AnsiString): PChar; +{$IFDEF PUREPASCAL} +const + EmptyString = ''; +begin + if Pointer(s) = nil then + Result := EmptyString + else + Result := Pointer(s); +end; +{$ELSE} +asm + { -> EAX pointer to str } + { <- EAX pointer to PChar } + + TEST EAX,EAX + JE @@handle0 + RET +{$IFDEF PIC} +@@handle0: + JMP PICEmptyString +{$ELSE} +@@zeroByte: + DB 0 +@@handle0: + MOV EAX,offset @@zeroByte +{$ENDIF} +end; +{$ENDIF} + +function InternalUniqueString(var str): Pointer; +asm + { -> EAX pointer to str } + { <- EAX pointer to unique copy } + MOV EDX,[EAX] + TEST EDX,EDX + JE @@exit + MOV ECX,[EDX-skew].StrRec.refCnt + DEC ECX + JE @@exit + + PUSH EBX + MOV EBX,EAX + MOV EAX,[EDX-skew].StrRec.length + CALL _NewAnsiString + MOV EDX,EAX + MOV EAX,[EBX] + MOV [EBX],EDX + PUSH EAX + MOV ECX,[EAX-skew].StrRec.length + CALL Move + POP EAX + MOV ECX,[EAX-skew].StrRec.refCnt + DEC ECX + JL @@skip +{X LOCK} DEC [EAX-skew].StrRec.refCnt + JNZ @@skip + LEA EAX,[EAX-skew].StrRec.refCnt { if refCnt now zero, deallocate} + CALL _FreeMem +@@skip: + MOV EDX,[EBX] + POP EBX +@@exit: + MOV EAX,EDX +end; + + +procedure UniqueString(var str: AnsiString); +asm + JMP InternalUniqueString +end; + +procedure _UniqueStringA(var str: AnsiString); +asm + JMP InternalUniqueString +end; + +procedure UniqueString(var str: WideString); +asm +{$IFDEF LINUX} + JMP InternalUniqueString +{$ENDIF} +{$IFDEF MSWINDOWS} + // nothing to do - Windows WideStrings are always single reference +{$ENDIF} +end; + +procedure _UniqueStringW(var str: WideString); +asm +{$IFDEF LINUX} + JMP InternalUniqueString +{$ENDIF} +{$IFDEF MSWINDOWS} + // nothing to do - Windows WideStrings are always single reference +{$ENDIF} +end; + +procedure _LStrCopy{ const s : AnsiString; index, count : Integer) : AnsiString}; +asm + { ->EAX Source string } + { EDX index } + { ECX count } + { [ESP+4] Pointer to result string } + + PUSH EBX + + TEST EAX,EAX + JE @@srcEmpty + + MOV EBX,[EAX-skew].StrRec.length + TEST EBX,EBX + JE @@srcEmpty + +{ make index 0-based and limit to 0 <= index < Length(src) } + + DEC EDX + JL @@smallInx + CMP EDX,EBX + JGE @@bigInx + +@@cont1: + +{ limit count to satisfy 0 <= count <= Length(src) - index } + + SUB EBX,EDX { calculate Length(src) - index } + TEST ECX,ECX + JL @@smallCount + CMP ECX,EBX + JG @@bigCount + +@@cont2: + + ADD EDX,EAX + MOV EAX,[ESP+4+4] + CALL _LStrFromPCharLen + JMP @@exit + +@@smallInx: + XOR EDX,EDX + JMP @@cont1 +@@bigCount: + MOV ECX,EBX + JMP @@cont2 +@@bigInx: +@@smallCount: +@@srcEmpty: + MOV EAX,[ESP+4+4] + CALL _LStrClr +@@exit: + POP EBX + RET 4 +end; + + +procedure _LStrDelete{ var s : AnsiString; index, count : Integer }; +asm + { ->EAX Pointer to s } + { EDX index } + { ECX count } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + CALL UniqueString + + MOV EDX,[EBX] + TEST EDX,EDX { source already empty: nothing to do } + JE @@exit + + MOV ECX,[EDX-skew].StrRec.length + +{ make index 0-based, if not in [0 .. Length(s)-1] do nothing } + + DEC ESI + JL @@exit + CMP ESI,ECX + JGE @@exit + +{ limit count to [0 .. Length(s) - index] } + + TEST EDI,EDI + JLE @@exit + SUB ECX,ESI { ECX = Length(s) - index } + CMP EDI,ECX + JLE @@1 + MOV EDI,ECX +@@1: + +{ move length - index - count characters from s+index+count to s+index } + + SUB ECX,EDI { ECX = Length(s) - index - count } + ADD EDX,ESI { EDX = s+index } + LEA EAX,[EDX+EDI] { EAX = s+index+count } + CALL Move + +{ set length(s) to length(s) - count } + + MOV EDX,[EBX] + MOV EAX,EBX + MOV EDX,[EDX-skew].StrRec.length + SUB EDX,EDI + CALL _LStrSetLength + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +procedure _LStrInsert{ const source : AnsiString; var s : AnsiString; index : Integer }; +asm + { -> EAX source string } + { EDX pointer to destination string } + { ECX index } + + TEST EAX,EAX + JE @@nothingToDo + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + +{ make index 0-based and limit to 0 <= index <= Length(s) } + + MOV EDX,[EDX] + PUSH EDX + TEST EDX,EDX + JE @@sIsNull + MOV EDX,[EDX-skew].StrRec.length +@@sIsNull: + DEC EDI + JGE @@indexNotLow + XOR EDI,EDI +@@indexNotLow: + CMP EDI,EDX + JLE @@indexNotHigh + MOV EDI,EDX +@@indexNotHigh: + + MOV EBP,[EBX-skew].StrRec.length + +{ set length of result to length(source) + length(s) } + + MOV EAX,ESI + ADD EDX,EBP + CALL _LStrSetLength + POP EAX + + CMP EAX,EBX + JNE @@notInsertSelf + MOV EBX,[ESI] + +@@notInsertSelf: + +{ move length(s) - length(source) - index chars from s+index to s+index+length(source) } + + MOV EAX,[ESI] { EAX = s } + LEA EDX,[EDI+EBP] { EDX = index + length(source) } + MOV ECX,[EAX-skew].StrRec.length + SUB ECX,EDX { ECX = length(s) - length(source) - index } + ADD EDX,EAX { EDX = s + index + length(source) } + ADD EAX,EDI { EAX = s + index } + CALL Move + +{ copy length(source) chars from source to s+index } + + MOV EAX,EBX + MOV EDX,[ESI] + MOV ECX,EBP + ADD EDX,EDI + CALL Move + +@@exit: + POP EBP + POP EDI + POP ESI + POP EBX +@@nothingToDo: +end; + + +procedure _LStrPos{ const substr : AnsiString; const s : AnsiString ) : Integer}; +asm +{ ->EAX Pointer to substr } +{ EDX Pointer to string } +{ <-EAX Position of substr in s or 0 } + + TEST EAX,EAX + JE @@noWork + + TEST EDX,EDX + JE @@stringEmpty + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX { Point ESI to substr } + MOV EDI,EDX { Point EDI to s } + + MOV ECX,[EDI-skew].StrRec.length { ECX = Length(s) } + + PUSH EDI { remember s position to calculate index } + + MOV EDX,[ESI-skew].StrRec.length { EDX = Length(substr) } + + DEC EDX { EDX = Length(substr) - 1 } + JS @@fail { < 0 ? return 0 } + MOV AL,[ESI] { AL = first char of substr } + INC ESI { Point ESI to 2'nd char of substr } + + SUB ECX,EDX { #positions in s to look at } + { = Length(s) - Length(substr) + 1 } + JLE @@fail +@@loop: + REPNE SCASB + JNE @@fail + MOV EBX,ECX { save outer loop counter } + PUSH ESI { save outer loop substr pointer } + PUSH EDI { save outer loop s pointer } + + MOV ECX,EDX + REPE CMPSB + POP EDI { restore outer loop s pointer } + POP ESI { restore outer loop substr pointer } + JE @@found + MOV ECX,EBX { restore outer loop counter } + JMP @@loop + +@@fail: + POP EDX { get rid of saved s pointer } + XOR EAX,EAX + JMP @@exit + +@@stringEmpty: + XOR EAX,EAX + JMP @@noWork + +@@found: + POP EDX { restore pointer to first char of s } + MOV EAX,EDI { EDI points of char after match } + SUB EAX,EDX { the difference is the correct index } +@@exit: + POP EDI + POP ESI + POP EBX +@@noWork: +end; + + +procedure _LStrSetLength{ var str: AnsiString; newLength: Integer}; +asm + { -> EAX Pointer to str } + { EDX new length } + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV ESI,EDX + XOR EDI,EDI + + TEST EDX,EDX + JLE @@setString + + MOV EAX,[EBX] + TEST EAX,EAX + JE @@copyString + + CMP [EAX-skew].StrRec.refCnt,1 + JNE @@copyString + + SUB EAX,rOff + ADD EDX,rOff+1 + PUSH EAX + MOV EAX,ESP + CALL _ReallocMem + POP EAX + ADD EAX,rOff + MOV [EBX],EAX + MOV [EAX-skew].StrRec.length,ESI + MOV BYTE PTR [EAX+ESI],0 + JMP @@exit + +@@copyString: + MOV EAX,EDX + CALL _NewAnsiString + MOV EDI,EAX + + MOV EAX,[EBX] + TEST EAX,EAX + JE @@setString + + MOV EDX,EDI + MOV ECX,[EAX-skew].StrRec.length + CMP ECX,ESI + JL @@moveString + MOV ECX,ESI + +@@moveString: + CALL Move + +@@setString: + MOV EAX,EBX + CALL _LStrClr + MOV [EBX],EDI + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +procedure _LStrOfChar{ c: Char; count: Integer): AnsiString }; +asm + { -> AL c } + { EDX count } + { ECX result } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + MOV EAX,ECX + CALL _LStrClr + + TEST ESI,ESI + JLE @@exit + + MOV EAX,ESI + CALL _NewAnsiString + + MOV [EDI],EAX + + MOV EDX,ESI + MOV CL,BL + + CALL _FillChar + +@@exit: + POP EDI + POP ESI + POP EBX + +end; + + +function _Write0LString(var t: TTextRec; const s: AnsiString): Pointer; +begin + Result := _WriteLString(t, s, 0); +end; + + +function _WriteLString(var t: TTextRec; const s: AnsiString; width: Longint): Pointer; +{$IFDEF PUREPASCAL} +var + i: Integer; +begin + i := Length(s); + _WriteSpaces(t, width - i); + Result := _WriteBytes(t, s[1], i); +end; +{$ELSE} +asm + { -> EAX Pointer to text record } + { EDX Pointer to AnsiString } + { ECX Field width } + + PUSH EBX + + MOV EBX,EDX + + MOV EDX,ECX + XOR ECX,ECX + TEST EBX,EBX + JE @@skip + MOV ECX,[EBX-skew].StrRec.length + SUB EDX,ECX +@@skip: + PUSH ECX + CALL _WriteSpaces + POP ECX + + MOV EDX,EBX + POP EBX + JMP _WriteBytes +end; +{$ENDIF} + + +function _Write0WString(var t: TTextRec; const s: WideString): Pointer; +begin + Result := _WriteWString(t, s, 0); +end; + + +function _WriteWString(var t: TTextRec; const s: WideString; width: Longint): Pointer; +var + i: Integer; +begin + i := Length(s); + _WriteSpaces(t, width - i); + Result := _WriteLString(t, AnsiString(s), 0); +end; + + +function _Write0WCString(var t: TTextRec; s: PWideChar): Pointer; +begin + Result := _WriteWCString(t, s, 0); +end; + + +function _WriteWCString(var t: TTextRec; s: PWideChar; width: Longint): Pointer; +var + i: Integer; +begin + i := 0; + if (s <> nil) then + while s[i] <> #0 do + Inc(i); + + _WriteSpaces(t, width - i); + Result := _WriteLString(t, AnsiString(s), 0); +end; + + +function _Write0WChar(var t: TTextRec; c: WideChar): Pointer; +begin + Result := _WriteWChar(t, c, 0); +end; + + +function _WriteWChar(var t: TTextRec; c: WideChar; width: Integer): Pointer; +begin + _WriteSpaces(t, width - 1); + Result := _WriteLString(t, AnsiString(c), 0); +end; + + +{$IFDEF MSWINDOWS} +procedure WStrError; +asm + MOV AL,reOutOfMemory + JMP Error +end; +{$ENDIF} + +function _NewWideString(CharLength: Longint): Pointer; +{$IFDEF LINUX} +begin + Result := _NewAnsiString(CharLength*2); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + TEST EAX,EAX + JE @@1 + PUSH EAX + PUSH 0 + CALL SysAllocStringLen + TEST EAX,EAX + JE WStrError +@@1: +end; +{$ENDIF} + +procedure WStrSet(var S: WideString; P: PWideChar); +{$IFDEF PUREPASCAL} +var + Temp: Pointer; +begin + Temp := Pointer(InterlockedExchange(Pointer(S), Pointer(P))); + if Temp <> nil then + _WStrClr(Temp); +end; +{$ELSE} +asm +{$IFDEF LINUX} + XCHG [EAX],EDX + TEST EDX,EDX + JZ @@1 + PUSH EDX + MOV EAX, ESP + CALL _WStrClr + POP EAX +{$ENDIF} +{$IFDEF MSWINDOWS} + XCHG [EAX],EDX + TEST EDX,EDX + JZ @@1 + PUSH EDX + CALL SysFreeString +{$ENDIF} +@@1: +end; +{$ENDIF} + + +procedure WStrClr; +asm + JMP _WStrClr +end; + +procedure _WStrClr(var S); +{$IFDEF LINUX} +asm + JMP _LStrClr; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + { -> EAX Pointer to WideString } + + MOV EDX,[EAX] + TEST EDX,EDX + JE @@1 + MOV DWORD PTR [EAX],0 + PUSH EAX + PUSH EDX + CALL SysFreeString + POP EAX +@@1: +end; +{$ENDIF} + + +procedure WStrArrayClr; +asm + JMP _WStrArrayClr; +end; + +procedure _WStrArrayClr(var StrArray; Count: Integer); +{$IFDEF LINUX} +asm + JMP _LStrArrayClr +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + PUSH EBX + PUSH ESI + MOV EBX,EAX + MOV ESI,EDX +@@1: MOV EAX,[EBX] + TEST EAX,EAX + JE @@2 + MOV DWORD PTR [EBX],0 + PUSH EAX + CALL SysFreeString +@@2: ADD EBX,4 + DEC ESI + JNE @@1 + POP ESI + POP EBX +end; +{$ENDIF} + + +procedure _WStrAsg(var Dest: WideString; const Source: WideString); +{$IFDEF LINUX} +asm + JMP _LStrAsg +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + { -> EAX Pointer to WideString } + { EDX Pointer to data } + TEST EDX,EDX + JE _WStrClr + MOV ECX,[EDX-4] + SHR ECX,1 + JE _WStrClr + PUSH ECX + PUSH EDX + PUSH EAX + CALL SysReAllocStringLen + TEST EAX,EAX + JE WStrError +end; +{$ENDIF} + +procedure _WStrLAsg(var Dest: WideString; const Source: WideString); +{$IFDEF LINUX} +asm + JMP _LStrLAsg +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + JMP _WStrAsg +end; +{$ENDIF} + +procedure _WStrFromPCharLen(var Dest: WideString; Source: PAnsiChar; Length: Integer); +var + DestLen: Integer; + Buffer: array[0..2047] of WideChar; +begin + if Length <= 0 then + begin + _WStrClr(Dest); + Exit; + end; + if Length+1 < High(Buffer) then + begin + DestLen := WCharFromChar(Buffer, High(Buffer), Source, Length); + if DestLen > 0 then + begin + _WStrFromPWCharLen(Dest, @Buffer, DestLen); + Exit; + end; + end; + + DestLen := (Length + 1); + _WStrSetLength(Dest, DestLen); // overallocate, trim later + DestLen := WCharFromChar(Pointer(Dest), DestLen, Source, Length); + if DestLen < 0 then DestLen := 0; + _WStrSetLength(Dest, DestLen); +end; + +procedure _WStrFromPWCharLen(var Dest: WideString; Source: PWideChar; CharLength: Integer); +{$IFDEF LINUX} +var + Temp: Pointer; +begin + Temp := Pointer(Dest); + if CharLength > 0 then + begin + Pointer(Dest) := _NewWideString(CharLength); + if Source <> nil then + Move(Source^, Pointer(Dest)^, CharLength * sizeof(WideChar)); + end + else + Pointer(Dest) := nil; + _WStrClr(Temp); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + { -> EAX Pointer to WideString (dest) } + { EDX Pointer to characters (source) } + { ECX number of characters (not bytes) } + TEST ECX,ECX + JE _WStrClr + + PUSH EAX + + PUSH ECX + PUSH EDX + CALL SysAllocStringLen + TEST EAX,EAX + JE WStrError + + POP EDX + PUSH [EDX].PWideChar + MOV [EDX],EAX + + CALL SysFreeString +end; +{$ENDIF} + + +procedure _WStrFromChar(var Dest: WideString; Source: AnsiChar); +asm + PUSH EDX + MOV EDX,ESP + MOV ECX,1 + CALL _WStrFromPCharLen + POP EDX +end; + + +procedure _WStrFromWChar(var Dest: WideString; Source: WideChar); +asm + { -> EAX Pointer to WideString (dest) } + { EDX character (source) } + PUSH EDX + MOV EDX,ESP + MOV ECX,1 + CALL _WStrFromPWCharLen + POP EDX +end; + + +procedure _WStrFromPChar(var Dest: WideString; Source: PAnsiChar); +asm + { -> EAX Pointer to WideString (dest) } + { EDX Pointer to character (source) } + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CL,[EDX+0] + JE @@4 + CMP CL,[EDX+1] + JE @@3 + CMP CL,[EDX+2] + JE @@2 + CMP CL,[EDX+3] + JE @@1 + ADD EDX,4 + JMP @@0 +@@1: INC EDX +@@2: INC EDX +@@3: INC EDX +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX +@@5: JMP _WStrFromPCharLen +end; + + +procedure _WStrFromPWChar(var Dest: WideString; Source: PWideChar); +asm + { -> EAX Pointer to WideString (dest) } + { EDX Pointer to character (source) } + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CX,[EDX+0] + JE @@4 + CMP CX,[EDX+2] + JE @@3 + CMP CX,[EDX+4] + JE @@2 + CMP CX,[EDX+6] + JE @@1 + ADD EDX,8 + JMP @@0 +@@1: ADD EDX,2 +@@2: ADD EDX,2 +@@3: ADD EDX,2 +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX + SHR ECX,1 +@@5: JMP _WStrFromPWCharLen +end; + + +procedure _WStrFromString(var Dest: WideString; const Source: ShortString); +asm + XOR ECX,ECX + MOV CL,[EDX] + INC EDX + JMP _WStrFromPCharLen +end; + + +procedure _WStrFromArray(var Dest: WideString; Source: PAnsiChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASB + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _WStrFromPCharLen +end; + + +procedure _WStrFromWArray(var Dest: WideString; Source: PWideChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASW + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _WStrFromPWCharLen +end; + + +procedure _WStrFromLStr(var Dest: WideString; const Source: AnsiString); +asm + XOR ECX,ECX + TEST EDX,EDX + JE @@1 + MOV ECX,[EDX-4] +@@1: JMP _WStrFromPCharLen +end; + + +procedure _WStrToString(Dest: PShortString; const Source: WideString; MaxLen: Integer); +var + SourceLen, DestLen: Integer; + Buffer: array[0..511] of Char; +begin + if MaxLen > 255 then MaxLen := 255; + SourceLen := Length(Source); + if SourceLen >= MaxLen then SourceLen := MaxLen; + if SourceLen = 0 then + DestLen := 0 + else + begin + DestLen := CharFromWChar(Buffer, High(Buffer), PWideChar(Pointer(Source)), SourceLen); + if DestLen < 0 then + DestLen := 0 + else if DestLen > MaxLen then + DestLen := MaxLen; + end; + Dest^[0] := Chr(DestLen); + if DestLen > 0 then Move(Buffer, Dest^[1], DestLen); +end; + +function _WStrToPWChar(const S: WideString): PWideChar; +{$IFDEF PUREPASCAL} +const + EmptyString = ''; +begin + if Pointer(S) = nil then + Result := EmptyString + else + Result := Pointer(S); +end; +{$ELSE} +asm + TEST EAX,EAX + JE @@1 + RET +{$IFDEF PIC} +@@1: JMP PICEmptyString +{$ELSE} + NOP +@@0: DW 0 +@@1: MOV EAX,OFFSET @@0 +{$ENDIF} +end; +{$ENDIF} + + +function _WStrLen(const S: WideString): Integer; +{$IFDEF PUREPASCAL} +begin + if Pointer(S) = nil then + Result := 0 + else + Result := PInteger(Integer(S) - 4)^ div sizeof(WideChar); +end; +{$ELSE} +asm + { -> EAX Pointer to WideString data } + TEST EAX,EAX + JE @@1 + MOV EAX,[EAX-4] + SHR EAX,1 +@@1: +end; +{$ENDIF} + +procedure _WStrCat(var Dest: WideString; const Source: WideString); +var + DestLen, SourceLen: Integer; + NewStr: PWideChar; +begin + SourceLen := Length(Source); + if SourceLen <> 0 then + begin + DestLen := Length(Dest); + NewStr := _NewWideString(DestLen + SourceLen); + if DestLen > 0 then + Move(Pointer(Dest)^, NewStr^, DestLen * sizeof(WideChar)); + Move(Pointer(Source)^, NewStr[DestLen], SourceLen * sizeof(WideChar)); + WStrSet(Dest, NewStr); + end; +end; + + +procedure _WStrCat3(var Dest: WideString; const Source1, Source2: WideString); +var + Source1Len, Source2Len: Integer; + NewStr: PWideChar; +begin + Source1Len := Length(Source1); + Source2Len := Length(Source2); + if (Source1Len <> 0) or (Source2Len <> 0) then + begin + NewStr := _NewWideString(Source1Len + Source2Len); + Move(Pointer(Source1)^, Pointer(NewStr)^, Source1Len * sizeof(WideChar)); + Move(Pointer(Source2)^, NewStr[Source1Len], Source2Len * sizeof(WideChar)); + WStrSet(Dest, NewStr); + end; +end; + + +procedure _WStrCatN{var Dest: WideString; ArgCnt: Integer; ...}; +asm + { ->EAX = Pointer to dest } + { EDX = number of args (>= 3) } + { [ESP+4], [ESP+8], ... crgCnt WideString arguments } + + PUSH EBX + PUSH ESI + PUSH EDX + PUSH EAX + MOV EBX,EDX + + XOR EAX,EAX +@@loop1: + MOV ECX,[ESP+EDX*4+4*4] + TEST ECX,ECX + JE @@1 + ADD EAX,[ECX-4] +@@1: + DEC EDX + JNE @@loop1 + + SHR EAX,1 + CALL _NewWideString + PUSH EAX + MOV ESI,EAX + +@@loop2: + MOV EAX,[ESP+EBX*4+5*4] + MOV EDX,ESI + TEST EAX,EAX + JE @@2 + MOV ECX,[EAX-4] + ADD ESI,ECX + CALL Move +@@2: + DEC EBX + JNE @@loop2 + + POP EDX + POP EAX + CALL WStrSet + + POP EDX + POP ESI + POP EBX + POP EAX + LEA ESP,[ESP+EDX*4] + JMP EAX +end; + + +procedure _WStrCmp{left: WideString; right: WideString}; +asm +{ ->EAX = Pointer to left string } +{ EDX = Pointer to right string } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + CMP EAX,EDX + JE @@exit + + TEST ESI,ESI + JE @@str1null + + TEST EDI,EDI + JE @@str2null + + MOV EAX,[ESI-4] + MOV EDX,[EDI-4] + + SUB EAX,EDX { eax = len1 - len2 } + JA @@skip1 + ADD EDX,EAX { edx = len2 + (len1 - len2) = len1 } + +@@skip1: + PUSH EDX + SHR EDX,2 + JE @@cmpRest +@@longLoop: + MOV ECX,[ESI] + MOV EBX,[EDI] + CMP ECX,EBX + JNE @@misMatch + DEC EDX + JE @@cmpRestP4 + MOV ECX,[ESI+4] + MOV EBX,[EDI+4] + CMP ECX,EBX + JNE @@misMatch + ADD ESI,8 + ADD EDI,8 + DEC EDX + JNE @@longLoop + JMP @@cmpRest +@@cmpRestP4: + ADD ESI,4 + ADD EDI,4 +@@cmpRest: + POP EDX + AND EDX,2 + JE @@equal + + MOV CX,[ESI] + MOV BX,[EDI] + CMP CX,BX + JNE @@exit + +@@equal: + ADD EAX,EAX + JMP @@exit + +@@str1null: + MOV EDX,[EDI-4] + SUB EAX,EDX + JMP @@exit + +@@str2null: + MOV EAX,[ESI-4] + SUB EAX,EDX + JMP @@exit + +@@misMatch: + POP EDX + CMP CX,BX + JNE @@exit + SHR ECX,16 + SHR EBX,16 + CMP CX,BX + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +function _WStrCopy(const S: WideString; Index, Count: Integer): WideString; +var + L, N: Integer; +begin + L := Length(S); + if Index < 1 then Index := 0 else + begin + Dec(Index); + if Index > L then Index := L; + end; + if Count < 0 then N := 0 else + begin + N := L - Index; + if N > Count then N := Count; + end; + _WStrFromPWCharLen(Result, PWideChar(Pointer(S)) + Index, N); +end; + + +procedure _WStrDelete(var S: WideString; Index, Count: Integer); +var + L, N: Integer; + NewStr: PWideChar; +begin + L := Length(S); + if (L > 0) and (Index >= 1) and (Index <= L) and (Count > 0) then + begin + Dec(Index); + N := L - Index - Count; + if N < 0 then N := 0; + if (Index = 0) and (N = 0) then NewStr := nil else + begin + NewStr := _NewWideString(Index + N); + if Index > 0 then + Move(Pointer(S)^, NewStr^, Index * 2); + if N > 0 then + Move(PWideChar(Pointer(S))[L - N], NewStr[Index], N * 2); + end; + WStrSet(S, NewStr); + end; +end; + + +procedure _WStrInsert(const Source: WideString; var Dest: WideString; Index: Integer); +var + SourceLen, DestLen: Integer; + NewStr: PWideChar; +begin + SourceLen := Length(Source); + if SourceLen > 0 then + begin + DestLen := Length(Dest); + if Index < 1 then Index := 0 else + begin + Dec(Index); + if Index > DestLen then Index := DestLen; + end; + NewStr := _NewWideString(DestLen + SourceLen); + if Index > 0 then + Move(Pointer(Dest)^, NewStr^, Index * 2); + Move(Pointer(Source)^, NewStr[Index], SourceLen * 2); + if Index < DestLen then + Move(PWideChar(Pointer(Dest))[Index], NewStr[Index + SourceLen], + (DestLen - Index) * 2); + WStrSet(Dest, NewStr); + end; +end; + + +procedure _WStrPos{ const substr : WideString; const s : WideString ) : Integer}; +asm +{ ->EAX Pointer to substr } +{ EDX Pointer to string } +{ <-EAX Position of substr in s or 0 } + + TEST EAX,EAX + JE @@noWork + + TEST EDX,EDX + JE @@stringEmpty + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX { Point ESI to substr } + MOV EDI,EDX { Point EDI to s } + + MOV ECX,[EDI-4] { ECX = Length(s) } + SHR ECX,1 + + PUSH EDI { remember s position to calculate index } + + MOV EDX,[ESI-4] { EDX = Length(substr) } + SHR EDX,1 + + DEC EDX { EDX = Length(substr) - 1 } + JS @@fail { < 0 ? return 0 } + MOV AX,[ESI] { AL = first char of substr } + ADD ESI,2 { Point ESI to 2'nd char of substr } + + SUB ECX,EDX { #positions in s to look at } + { = Length(s) - Length(substr) + 1 } + JLE @@fail +@@loop: + REPNE SCASW + JNE @@fail + MOV EBX,ECX { save outer loop counter } + PUSH ESI { save outer loop substr pointer } + PUSH EDI { save outer loop s pointer } + + MOV ECX,EDX + REPE CMPSW + POP EDI { restore outer loop s pointer } + POP ESI { restore outer loop substr pointer } + JE @@found + MOV ECX,EBX { restore outer loop counter } + JMP @@loop + +@@fail: + POP EDX { get rid of saved s pointer } + XOR EAX,EAX + JMP @@exit + +@@stringEmpty: + XOR EAX,EAX + JMP @@noWork + +@@found: + POP EDX { restore pointer to first char of s } + MOV EAX,EDI { EDI points of char after match } + SUB EAX,EDX { the difference is the correct index } + SHR EAX,1 +@@exit: + POP EDI + POP ESI + POP EBX +@@noWork: +end; + + +procedure _WStrSetLength(var S: WideString; NewLength: Integer); +var + NewStr: PWideChar; + Count: Integer; +begin + NewStr := nil; + if NewLength > 0 then + begin + NewStr := _NewWideString(NewLength); + Count := Length(S); + if Count > 0 then + begin + if Count > NewLength then Count := NewLength; + Move(Pointer(S)^, NewStr^, Count * 2); + end; + end; + WStrSet(S, NewStr); +end; + + +function _WStrOfWChar(Ch: WideChar; Count: Integer): WideString; +var + P: PWideChar; +begin + _WStrFromPWCharLen(Result, nil, Count); + P := Pointer(Result); + while Count > 0 do + begin + Dec(Count); + P[Count] := Ch; + end; +end; + +procedure WStrAddRef; +asm + JMP _WStrAddRef +end; + +function _WStrAddRef(var str: WideString): Pointer; +{$IFDEF LINUX} +asm + JMP _LStrAddRef +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + MOV EDX,[EAX] + TEST EDX,EDX + JE @@1 + PUSH EAX + MOV ECX,[EDX-4] + SHR ECX,1 + PUSH ECX + PUSH EDX + CALL SysAllocStringLen + POP EDX + TEST EAX,EAX + JE WStrError + MOV [EDX],EAX +@@1: +end; +{$ENDIF} + +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); +{$IFDEF PUREPASCAL} +var + FT: PFieldTable; + I: Cardinal; +begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + for I := FT.Count-1 downto 0 do + _InitializeArray(Pointer(Cardinal(P) + FT.Fields[I].Offset), FT.Fields[I].TypeInfo^, 1); +end; +{$ELSE} +asm + { -> EAX pointer to record to be initialized } + { EDX pointer to type info } + + XOR ECX,ECX + + PUSH EBX + MOV CL,[EDX+1] { type name length } + + PUSH ESI + PUSH EDI + + MOV EBX,EAX // PIC safe. See comment above + LEA ESI,[EDX+ECX+2+8] { address of destructable fields } + MOV EDI,[EDX+ECX+2+4] { number of destructable fields } + +@@loop: + + MOV EDX,[ESI] + MOV EAX,[ESI+4] + ADD EAX,EBX + MOV EDX,[EDX] + MOV ECX,1 + CALL _InitializeArray + ADD ESI,8 + DEC EDI + JG @@loop + + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + + +const + tkLString = 10; + tkWString = 11; + tkVariant = 12; + tkArray = 13; + tkRecord = 14; + tkInterface = 15; + tkDynArray = 17; + +procedure _InitializeArray(p: Pointer; typeInfo: Pointer; elemCount: Cardinal); +{$IFDEF PUREPASCAL} +var + FT: PFieldTable; +begin + if elemCount = 0 then Exit; + case PTypeInfo(typeInfo).Kind of + tkLString, tkWString, tkInterface, tkDynArray: + while elemCount > 0 do + begin + PInteger(P)^ := 0; + Inc(Integer(P), 4); + Dec(elemCount); + end; + tkVariant: + while elemCount > 0 do + begin + PInteger(P)^ := 0; + PInteger(Integer(P)+4)^ := 0; + PInteger(Integer(P)+8)^ := 0; + PInteger(Integer(P)+12)^ := 0; + Inc(Integer(P), sizeof(Variant)); + Dec(elemCount); + end; + tkArray: + begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + while elemCount > 0 do + begin + _InitializeArray(P, FT.Fields[0].TypeInfo^, FT.Count); + Inc(Integer(P), FT.Size); + Dec(elemCount); + end; + end; + tkRecord: + begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + while elemCount > 0 do + begin + _InitializeRecord(P, typeInfo); + Inc(Integer(P), FT.Size); + Dec(elemCount); + end; + end; + else + Error(reInvalidPtr); + end; +end; +{$ELSE} +asm + { -> EAX pointer to data to be initialized } + { EDX pointer to type info describing data } + { ECX number of elements of that type } + + TEST ECX, ECX + JZ @@zerolength + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX // PIC safe. See comment above + MOV ESI,EDX + MOV EDI,ECX + + XOR EDX,EDX + MOV AL,[ESI] + MOV DL,[ESI+1] + XOR ECX,ECX + + CMP AL,tkLString + JE @@LString + CMP AL,tkWString + JE @@WString + CMP AL,tkVariant + JE @@Variant + CMP AL,tkArray + JE @@Array + CMP AL,tkRecord + JE @@Record + CMP AL,tkInterface + JE @@Interface + CMP AL,tkDynArray + JE @@DynArray + MOV AL,reInvalidPtr + POP EDI + POP ESI + POP EBX + JMP Error + +@@LString: +@@WString: +@@Interface: +@@DynArray: + MOV [EBX],ECX + ADD EBX,4 + DEC EDI + JG @@LString + JMP @@exit + +@@Variant: + MOV [EBX ],ECX + MOV [EBX+ 4],ECX + MOV [EBX+ 8],ECX + MOV [EBX+12],ECX + ADD EBX,16 + DEC EDI + JG @@Variant + JMP @@exit + +@@Array: + PUSH EBP + MOV EBP,EDX +@@ArrayLoop: + MOV EDX,[ESI+EBP+2+8] // address of destructable fields typeinfo + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] // size in bytes of the array data + MOV ECX,[ESI+EBP+2+4] // number of destructable fields + MOV EDX,[EDX] + CALL _InitializeArray + DEC EDI + JG @@ArrayLoop + POP EBP + JMP @@exit + +@@Record: + PUSH EBP + MOV EBP,EDX +@@RecordLoop: + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV EDX,ESI + CALL _InitializeRecord + DEC EDI + JG @@RecordLoop + POP EBP + +@@exit: + + POP EDI + POP ESI + POP EBX +@@zerolength: +end; +{$ENDIF} + +procedure _Initialize(p: Pointer; typeInfo: Pointer); +{$IFDEF PUREPASCAL} +begin + _InitializeArray(p, typeInfo, 1); +end; +{$ELSE} +asm + MOV ECX,1 + JMP _InitializeArray +end; +{$ENDIF} + +procedure _FinalizeRecord(p: Pointer; typeInfo: Pointer); +{$IFDEF PUREPASCAL} +var + FT: PFieldTable; + I: Cardinal; +begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + for I := 0 to FT.Count-1 do + _FinalizeArray(Pointer(Cardinal(P) + FT.Fields[I].Offset), FT.Fields[I].TypeInfo^, 1); +end; +{$ELSE} +asm + { -> EAX pointer to record to be finalized } + { EDX pointer to type info } + + XOR ECX,ECX + + PUSH EBX + MOV CL,[EDX+1] + + PUSH ESI + PUSH EDI + + MOV EBX,EAX + LEA ESI,[EDX+ECX+2+8] + MOV EDI,[EDX+ECX+2+4] + +@@loop: + + MOV EDX,[ESI] + MOV EAX,[ESI+4] + ADD EAX,EBX + MOV EDX,[EDX] + MOV ECX,1 + CALL _FinalizeArray + ADD ESI,8 + DEC EDI + JG @@loop + + MOV EAX,EBX + + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +procedure _FinalizeArray(p: Pointer; typeInfo: Pointer; elemCount: Cardinal); +{$IFDEF PUREPASCAL} +var + FT: PFieldTable; +begin + if elemCount = 0 then Exit; + case PTypeInfo(typeInfo).Kind of + tkLString: _LStrArrayClr(P^, elemCount); + tkWString: {X-_WStrArrayClr X+}WStrArrayClrProc(P^, elemCount); + tkVariant: + while elemCount > 0 do + begin + VarClrProc(P); + Inc(Integer(P), sizeof(Variant)); + Dec(elemCount); + end; + tkArray: + begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + while elemCount > 0 do + begin + _FinalizeArray(P, FT.Fields[0].TypeInfo^, FT.Count); + Inc(Integer(P), FT.Size); + Dec(elemCount); + end; + end; + tkRecord: + begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + while elemCount > 0 do + begin + _FinalizeRecord(P, typeInfo); + Inc(Integer(P), FT.Size); + Dec(elemCount); + end; + end; + tkInterface: + while elemCount > 0 do + begin + _IntfClear(IInterface(P^)); + Inc(Integer(P), 4); + Dec(elemCount); + end; + tkDynArray: + while elemCount > 0 do + begin + _DynArrayClr(P); + Inc(Integer(P), 4); + Dec(elemCount); + end; + else + Error(reInvalidPtr); + end; +end; +{$ELSE} +asm + { -> EAX pointer to data to be finalized } + { EDX pointer to type info describing data } + { ECX number of elements of that type } + + { This code appears to be PIC safe. The functions called from + here either don't make external calls or call Pascal + routines that will fix up EBX in their prolog code + (FreeMem, VarClr, IntfClr). } + + CMP ECX, 0 { no array -> nop } + JE @@zerolength + + PUSH EAX + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + XOR EDX,EDX + MOV AL,[ESI] + MOV DL,[ESI+1] + + CMP AL,tkLString + JE @@LString + + CMP AL,tkWString + JE @@WString + + CMP AL,tkVariant + JE @@Variant + + CMP AL,tkArray + JE @@Array + + CMP AL,tkRecord + JE @@Record + + CMP AL,tkInterface + JE @@Interface + + CMP AL,tkDynArray + JE @@DynArray + + JMP @@error + +@@LString: + CMP ECX,1 + MOV EAX,EBX + JG @@LStringArray + CALL _LStrClr + JMP @@exit +@@LStringArray: + MOV EDX,ECX + CALL _LStrArrayClr + JMP @@exit + +@@WString: + CMP ECX,1 + MOV EAX,EBX + JG @@WStringArray + //CALL _WStrClr {X} + CALL [WStrClrProc] {X} + JMP @@exit +@@WStringArray: + MOV EDX,ECX + //CALL _WStrArrayClr {X} + CALL [WStrArrayClrProc] {X} + JMP @@exit +@@Variant: + MOV EAX,EBX + ADD EBX,16 + CALL _VarClr + DEC EDI + JG @@Variant + JMP @@exit +@@Array: + PUSH EBP + MOV EBP,EDX +@@ArrayLoop: + MOV EDX,[ESI+EBP+2+8] + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV ECX,[ESI+EBP+2+4] + MOV EDX,[EDX] + CALL _FinalizeArray + DEC EDI + JG @@ArrayLoop + POP EBP + JMP @@exit + +@@Record: + PUSH EBP + MOV EBP,EDX +@@RecordLoop: + { inv: EDI = number of array elements to finalize } + + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV EDX,ESI + CALL _FinalizeRecord + DEC EDI + JG @@RecordLoop + POP EBP + JMP @@exit + +@@Interface: + MOV EAX,EBX + ADD EBX,4 + CALL _IntfClear + DEC EDI + JG @@Interface + JMP @@exit + +@@DynArray: + MOV EAX,EBX + MOV EDX,ESI + ADD EBX,4 + CALL _DynArrayClear + DEC EDI + JG @@DynArray + JMP @@exit + +@@error: + POP EDI + POP ESI + POP EBX + POP EAX + MOV AL,reInvalidPtr + JMP Error + +@@exit: + POP EDI + POP ESI + POP EBX + POP EAX +@@zerolength: +end; +{$ENDIF} + +procedure _Finalize(p: Pointer; typeInfo: Pointer); +{$IFDEF PUREPASCAL} +begin + _FinalizeArray(p, typeInfo, 1); +end; +{$ELSE} +asm + MOV ECX,1 + JMP _FinalizeArray +end; +{$ENDIF} + +procedure _AddRefRecord{ p: Pointer; typeInfo: Pointer }; +asm + { -> EAX pointer to record to be referenced } + { EDX pointer to type info } + + XOR ECX,ECX + + PUSH EBX + MOV CL,[EDX+1] + + PUSH ESI + PUSH EDI + + MOV EBX,EAX + LEA ESI,[EDX+ECX+2+8] + MOV EDI,[EDX+ECX+2+4] + +@@loop: + + MOV EDX,[ESI] + MOV EAX,[ESI+4] + ADD EAX,EBX + MOV EDX,[EDX] + MOV ECX, 1 + CALL _AddRefArray + ADD ESI,8 + DEC EDI + JG @@loop + + POP EDI + POP ESI + POP EBX +end; + + +{X}procedure DummyProc; +{X}begin +{X}end; + +procedure _AddRefArray{ p: Pointer; typeInfo: Pointer; elemCount: Longint}; +asm + { -> EAX pointer to data to be referenced } + { EDX pointer to type info describing data } + { ECX number of elements of that type } + + { This code appears to be PIC safe. The functions called from + here either don't make external calls (LStrAddRef, WStrAddRef) or + are Pascal routines that will fix up EBX in their prolog code + (VarAddRef, IntfAddRef). } + + PUSH EBX + PUSH ESI + PUSH EDI + + TEST ECX,ECX + JZ @@exit + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + XOR EDX,EDX + MOV AL,[ESI] + MOV DL,[ESI+1] + + CMP AL,tkLString + JE @@LString + CMP AL,tkWString + JE @@WString + CMP AL,tkVariant + JE @@Variant + CMP AL,tkArray + JE @@Array + CMP AL,tkRecord + JE @@Record + CMP AL,tkInterface + JE @@Interface + CMP AL,tkDynArray + JE @@DynArray + MOV AL,reInvalidPtr + POP EDI + POP ESI + POP EBX + JMP Error + +@@LString: + MOV EAX,[EBX] + ADD EBX,4 + CALL _LStrAddRef + DEC EDI + JG @@LString + JMP @@exit + +@@WString: + MOV EAX,EBX + ADD EBX,4 + //CALL _WStrAddRef + CALL [WStrAddRefProc] + DEC EDI + JG @@WString + JMP @@exit +@@Variant: + MOV EAX,EBX + ADD EBX,16 + CALL _VarAddRef + DEC EDI + JG @@Variant + JMP @@exit + +@@Array: + PUSH EBP + MOV EBP,EDX +@@ArrayLoop: + MOV EDX,[ESI+EBP+2+8] + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV ECX,[ESI+EBP+2+4] + MOV EDX,[EDX] + CALL _AddRefArray + DEC EDI + JG @@ArrayLoop + POP EBP + JMP @@exit + +@@Record: + PUSH EBP + MOV EBP,EDX +@@RecordLoop: + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV EDX,ESI + CALL _AddRefRecord + DEC EDI + JG @@RecordLoop + POP EBP + JMP @@exit + +@@Interface: + MOV EAX,[EBX] + ADD EBX,4 + CALL _IntfAddRef + DEC EDI + JG @@Interface + JMP @@exit + +@@DynArray: + MOV EAX,[EBX] + ADD EBX,4 + CALL _DynArrayAddRef + DEC EDI + JG @@DynArray +@@exit: + + POP EDI + POP ESI + POP EBX +end; + + +procedure _AddRef{ p: Pointer; typeInfo: Pointer}; +asm + MOV ECX,1 + JMP _AddRefArray +end; + + +procedure _CopyRecord{ dest, source, typeInfo: Pointer }; +asm + { -> EAX pointer to dest } + { EDX pointer to source } + { ECX pointer to typeInfo } + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBX,EAX + MOV ESI,EDX + + XOR EAX,EAX + MOV AL,[ECX+1] + + LEA EDI,[ECX+EAX+2+8] + MOV EBP,[EDI-4] + XOR EAX,EAX + MOV ECX,[EDI-8] + PUSH ECX +@@loop: + MOV ECX,[EDI+4] + SUB ECX,EAX + JLE @@nomove1 + MOV EDX,EAX + ADD EAX,ESI + ADD EDX,EBX + CALL Move +@@noMove1: + MOV EAX,[EDI+4] + + MOV EDX,[EDI] + MOV EDX,[EDX] + MOV CL,[EDX] + + CMP CL,tkLString + JE @@LString + CMP CL,tkWString + JE @@WString + CMP CL,tkVariant + JE @@Variant + CMP CL,tkArray + JE @@Array + CMP CL,tkRecord + JE @@Record + CMP CL,tkInterface + JE @@Interface + CMP CL,tkDynArray + JE @@DynArray + MOV AL,reInvalidPtr + POP EBP + POP EDI + POP ESI + POP EBX + JMP Error + +@@LString: + MOV EDX,[ESI+EAX] + ADD EAX,EBX + CALL _LStrAsg + MOV EAX,4 + JMP @@common + +@@WString: + MOV EDX,[ESI+EAX] + ADD EAX,EBX + CALL _WStrAsg + MOV EAX,4 + JMP @@common + +@@Variant: + LEA EDX,[ESI+EAX] + ADD EAX,EBX + CALL _VarCopy + MOV EAX,16 + JMP @@common + +@@Array: + XOR ECX,ECX + MOV CL,[EDX+1] + PUSH dword ptr [EDX+ECX+2] + PUSH dword ptr [EDX+ECX+2+4] + MOV ECX,[EDX+ECX+2+8] + MOV ECX,[ECX] + LEA EDX,[ESI+EAX] + ADD EAX,EBX + CALL _CopyArray + POP EAX + JMP @@common + +@@Record: + XOR ECX,ECX + MOV CL,[EDX+1] + MOV ECX,[EDX+ECX+2] + PUSH ECX + MOV ECX,EDX + LEA EDX,[ESI+EAX] + ADD EAX,EBX + CALL _CopyRecord + POP EAX + JMP @@common + +@@Interface: + MOV EDX,[ESI+EAX] + ADD EAX,EBX + CALL _IntfCopy + MOV EAX,4 + JMP @@common + +@@DynArray: + MOV ECX,EDX + MOV EDX,[ESI+EAX] + ADD EAX,EBX + CALL _DynArrayAsg + MOV EAX,4 + +@@common: + ADD EAX,[EDI+4] + ADD EDI,8 + DEC EBP + JNZ @@loop + + POP ECX + SUB ECX,EAX + JLE @@noMove2 + LEA EDX,[EBX+EAX] + ADD EAX,ESI + CALL Move +@@noMove2: + + POP EBP + POP EDI + POP ESI + POP EBX +end; + + +procedure _CopyObject{ dest, source: Pointer; vmtPtrOffs: Longint; typeInfo: Pointer }; +asm + { -> EAX pointer to dest } + { EDX pointer to source } + { ECX offset of vmt in object } + { [ESP+4] pointer to typeInfo } + + ADD ECX,EAX { pointer to dest vmt } + PUSH dword ptr [ECX] { save dest vmt } + PUSH ECX + MOV ECX,[ESP+4+4+4] + CALL _CopyRecord + POP ECX + POP dword ptr [ECX] { restore dest vmt } + RET 4 + +end; + +procedure _CopyArray{ dest, source, typeInfo: Pointer; cnt: Integer }; +asm + { -> EAX pointer to dest } + { EDX pointer to source } + { ECX pointer to typeInfo } + { [ESP+4] count } + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + MOV EBP,[ESP+4+4*4] + + MOV CL,[EDI] + + CMP CL,tkLString + JE @@LString + CMP CL,tkWString + JE @@WString + CMP CL,tkVariant + JE @@Variant + CMP CL,tkArray + JE @@Array + CMP CL,tkRecord + JE @@Record + CMP CL,tkInterface + JE @@Interface + CMP CL,tkDynArray + JE @@DynArray + MOV AL,reInvalidPtr + POP EBP + POP EDI + POP ESI + POP EBX + JMP Error + +@@LString: + MOV EAX,EBX + MOV EDX,[ESI] + CALL _LStrAsg + ADD EBX,4 + ADD ESI,4 + DEC EBP + JNE @@LString + JMP @@exit + +@@WString: + MOV EAX,EBX + MOV EDX,[ESI] + CALL _WStrAsg + ADD EBX,4 + ADD ESI,4 + DEC EBP + JNE @@WString + JMP @@exit + +@@Variant: + MOV EAX,EBX + MOV EDX,ESI + CALL _VarCopy + ADD EBX,16 + ADD ESI,16 + DEC EBP + JNE @@Variant + JMP @@exit + +@@Array: + XOR ECX,ECX + MOV CL,[EDI+1] + LEA EDI,[EDI+ECX+2] +@@ArrayLoop: + MOV EAX,EBX + MOV EDX,ESI + MOV ECX,[EDI+8] + PUSH dword ptr [EDI+4] + CALL _CopyArray + ADD EBX,[EDI] + ADD ESI,[EDI] + DEC EBP + JNE @@ArrayLoop + JMP @@exit + +@@Record: + MOV EAX,EBX + MOV EDX,ESI + MOV ECX,EDI + CALL _CopyRecord + XOR EAX,EAX + MOV AL,[EDI+1] + ADD EBX,[EDI+EAX+2] + ADD ESI,[EDI+EAX+2] + DEC EBP + JNE @@Record + JMP @@exit + +@@Interface: + MOV EAX,EBX + MOV EDX,[ESI] + CALL _IntfCopy + ADD EBX,4 + ADD ESI,4 + DEC EBP + JNE @@Interface + JMP @@exit + +@@DynArray: + MOV EAX,EBX + MOV EDX,[ESI] + MOV ECX,EDI + CALL _DynArrayAsg + ADD EBX,4 + ADD ESI,4 + DEC EBP + JNE @@DynArray + +@@exit: + POP EBP + POP EDI + POP ESI + POP EBX + RET 4 +end; + + +function _New(size: Longint; typeInfo: Pointer): Pointer; +{$IFDEF PUREPASCAL} +begin + GetMem(Result, size); + if Result <> nil then + _Initialize(Result, typeInfo); +end; +{$ELSE} +asm + { -> EAX size of object to allocate } + { EDX pointer to typeInfo } + + PUSH EDX + CALL _GetMem + POP EDX + TEST EAX,EAX + JE @@exit + PUSH EAX + CALL _Initialize + POP EAX +@@exit: +end; +{$ENDIF} + +procedure _Dispose(p: Pointer; typeInfo: Pointer); +{$IFDEF PUREPASCAL} +begin + _Finalize(p, typeinfo); + FreeMem(p); +end; +{$ELSE} +asm + { -> EAX Pointer to object to be disposed } + { EDX Pointer to type info } + + PUSH EAX + CALL _Finalize + POP EAX + CALL _FreeMem +end; +{$ENDIF} + +{ ----------------------------------------------------- } +{ Wide character support } +{ ----------------------------------------------------- } + +function WideCharToString(Source: PWideChar): string; +begin + WideCharToStrVar(Source, Result); +end; + +function WideCharLenToString(Source: PWideChar; SourceLen: Integer): string; +begin + WideCharLenToStrVar(Source, SourceLen, Result); +end; + +procedure WideCharToStrVar(Source: PWideChar; var Dest: string); +begin + _LStrFromPWChar(Dest, Source); +end; + +procedure WideCharLenToStrVar(Source: PWideChar; SourceLen: Integer; + var Dest: string); +begin + _LStrFromPWCharLen(Dest, Source, SourceLen); +end; + +function StringToWideChar(const Source: string; Dest: PWideChar; + DestSize: Integer): PWideChar; +begin + Dest[WCharFromChar(Dest, DestSize - 1, PChar(Source), Length(Source))] := #0; + Result := Dest; +end; + +{ ----------------------------------------------------- } +{ OLE string support } +{ ----------------------------------------------------- } + +function OleStrToString(Source: PWideChar): string; +begin + OleStrToStrVar(Source, Result); +end; + +procedure OleStrToStrVar(Source: PWideChar; var Dest: string); +begin + WideCharLenToStrVar(Source, Length(WideString(Pointer(Source))), Dest); +end; + +function StringToOleStr(const Source: string): PWideChar; +begin + Result := nil; + _WStrFromPCharLen(WideString(Pointer(Result)), PChar(Pointer(Source)), Length(Source)); +end; + +{ ----------------------------------------------------- } +{ Variant manager support } +{ ----------------------------------------------------- } + +var + VariantManager: TVariantManager; + +procedure VariantSystemUndefinedError; +asm + MOV AL,reVarInvalidOp + JMP Error; +end; + +procedure VariantSystemDefaultVarClear(var V: TVarData); +begin + case V.VType of + varEmpty, varNull, varError:; + else + VariantSystemUndefinedError; + end; +end; + +procedure InitVariantManager; +type + TPtrArray = array [Word] of Pointer; +var + P: ^TPtrArray; + I: Integer; +begin + P := @VariantManager; + for I := 0 to (SizeOf(VariantManager) div SizeOf(Pointer))-1 do + P[I] := @VariantSystemUndefinedError; + VariantManager.VarClear := @VariantSystemDefaultVarClear; +end; + +procedure GetVariantManager(var VarMgr: TVariantManager); +begin + VarMgr := VariantManager; +end; + +procedure SetVariantManager(const VarMgr: TVariantManager); +begin + VariantManager := VarMgr; +end; + +function IsVariantManagerSet: Boolean; +type + TPtrArray = array [Word] of Pointer; +var + P: ^TPtrArray; + I: Integer; +begin + Result := True; + P := @VariantManager; + for I := 0 to (SizeOf(VariantManager) div SizeOf(Pointer))-1 do + if P[I] <> @VariantSystemUndefinedError then + begin + Result := False; + Break; + end; +end; + +{ ----------------------------------------------------- } +{ Variant support } +{ ----------------------------------------------------- } + +procedure _DispInvoke;//(var Dest: Variant; const Source: Variant; + //CallDesc: PCallDesc; Params: Pointer); cdecl; +asm +{$IFDEF PIC} + CALL GetGOT + LEA EAX,[EAX].OFFSET VariantManager + JMP [EAX].TVariantManager.DispInvoke +{$ELSE} + JMP VariantManager.DispInvoke +{$ENDIF} +end; + +procedure _VarClear(var V : Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarClear(V); +{$ELSE} +asm + JMP VariantManager.VarClear +{$IFEND} +end; + +procedure _VarCopy(var Dest: Variant; const Source: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarCopy(Dest, Source); +{$ELSE} +asm + JMP VariantManager.VarCopy +{$IFEND} +end; + +procedure _VarCast(var Dest: Variant; const Source: Variant; VarType: Integer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarCast(Dest, Source, VarType); +{$ELSE} +asm + JMP VariantManager.VarCast +{$IFEND} +end; + +procedure _VarCastOle(var Dest: Variant; const Source: Variant; VarType: Integer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarCastOle(Dest, Source, VarType); +{$ELSE} +asm + JMP VariantManager.VarCastOle +{$IFEND} +end; + +function _VarToInt(const V: Variant): Integer; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.VarToInt(V); +{$ELSE} +asm + JMP VariantManager.VarToInt +{$IFEND} +end; + +function _VarToInt64(const V: Variant): Int64; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.VarToInt64(V); +{$ELSE} +asm + JMP VariantManager.VarToInt64 +{$IFEND} +end; + +function _VarToBool(const V: Variant): Boolean; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.VarToBool(V); +{$ELSE} +asm + JMP VariantManager.VarToBool +{$IFEND} +end; + +function _VarToReal(const V: Variant): Extended; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.VarToReal(V); +{$ELSE} +asm + JMP VariantManager.VarToReal +{$IFEND} +end; + +function _VarToCurr(const V: Variant): Currency; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.VarToCurr(V); +{$ELSE} +asm + JMP VariantManager.VarToCurr +{$IFEND} +end; + +procedure _VarToPStr(var S; const V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarToPStr(S, V); +{$ELSE} +asm + JMP VariantManager.VarToPStr +{$IFEND} +end; + +procedure _VarToLStr(var S: string; const V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarToLStr(S, V); +{$ELSE} +asm + JMP VariantManager.VarToLStr +{$IFEND} +end; + +procedure _VarToWStr(var S: WideString; const V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarToWStr(S, V); +{$ELSE} +asm + JMP VariantManager.VarToWStr +{$IFEND} +end; + +procedure _VarToIntf(var Unknown: IInterface; const V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarToIntf(Unknown, V); +{$ELSE} +asm + JMP VariantManager.VarToIntf +{$IFEND} +end; + +procedure _VarToDisp(var Dispatch: IDispatch; const V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarToDisp(Dispatch, V); +{$ELSE} +asm + JMP VariantManager.VarToDisp +{$IFEND} +end; + +procedure _VarToDynArray(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarToDynArray(DynArray, V, TypeInfo); +{$ELSE} +asm + JMP VariantManager.VarToDynArray +{$IFEND} +end; + +procedure _VarFromInt(var V: Variant; const Value, Range: Integer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromInt(V, Value, Range); +{$ELSE} +asm + JMP VariantManager.VarFromInt +{$IFEND} +end; + +procedure _VarFromInt64(var V: Variant; const Value: Int64); +begin + VariantManager.VarFromInt64(V, Value); +end; + +procedure _VarFromBool(var V: Variant; const Value: Boolean); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromBool(V, Value); +{$ELSE} +asm + JMP VariantManager.VarFromBool +{$IFEND} +end; + +procedure _VarFromReal; // var V: Variant; const Value: Real +asm +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + POP ECX + LEA EAX,[EAX].OFFSET VariantManager + MOV EAX,[EAX].TVariantManager.VarFromReal + XCHG EAX,[ESP] + RET +{$ELSE} + JMP VariantManager.VarFromReal +{$ENDIF} +end; + +procedure _VarFromTDateTime; // var V: Variant; const Value: TDateTime +asm +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + POP ECX + LEA EAX,[EAX].OFFSET VariantManager + MOV EAX,[EAX].TVariantManager.VarFromTDateTime + XCHG EAX,[ESP] + RET +{$ELSE} + JMP VariantManager.VarFromTDateTime +{$ENDIF} +end; + +procedure _VarFromCurr; // var V: Variant; const Value: Currency +asm +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + POP ECX + LEA EAX,[EAX].OFFSET VariantManager + MOV EAX,[EAX].TVariantManager.VarFromCurr + XCHG EAX,[ESP] + RET +{$ELSE} + JMP VariantManager.VarFromCurr +{$ENDIF} +end; + +procedure _VarFromPStr(var V: Variant; const Value: ShortString); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromPStr(V, Value); +{$ELSE} +asm + JMP VariantManager.VarFromPStr +{$IFEND} +end; + +procedure _VarFromLStr(var V: Variant; const Value: string); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromLStr(V, Value); +{$ELSE} +asm + JMP VariantManager.VarFromLStr +{$IFEND} +end; + +procedure _VarFromWStr(var V: Variant; const Value: WideString); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromWStr(V, Value); +{$ELSE} +asm + JMP VariantManager.VarFromWStr +{$IFEND} +end; + +procedure _VarFromIntf(var V: Variant; const Value: IInterface); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromIntf(V, Value); +{$ELSE} +asm + JMP VariantManager.VarFromIntf +{$IFEND} +end; + +procedure _VarFromDisp(var V: Variant; const Value: IDispatch); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromDisp(V, Value); +{$ELSE} +asm + JMP VariantManager.VarFromDisp +{$IFEND} +end; + +procedure _VarFromDynArray(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromDynArray(V, DynArray, TypeInfo); +{$ELSE} +asm + JMP VariantManager.VarFromDynArray +{$IFEND} +end; + +procedure _OleVarFromPStr(var V: OleVariant; const Value: ShortString); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.OleVarFromPStr(V, Value); +{$ELSE} +asm + JMP VariantManager.OleVarFromPStr +{$IFEND} +end; + +procedure _OleVarFromLStr(var V: OleVariant; const Value: string); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.OleVarFromLStr(V, Value); +{$ELSE} +asm + JMP VariantManager.OleVarFromLStr +{$IFEND} +end; + +procedure _OleVarFromVar(var V: OleVariant; const Value: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.OleVarFromVar(V, Value); +{$ELSE} +asm + JMP VariantManager.OleVarFromVar +{$IFEND} +end; + +procedure _OleVarFromInt(var V: OleVariant; const Value, Range: Integer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.OleVarFromInt(V, Value, Range); +{$ELSE} +asm + JMP VariantManager.OleVarFromInt +{$IFEND} +end; + +procedure _VarAdd(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opAdd); +{$ELSE} +asm + MOV ECX,opAdd + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarSub(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opSubtract); +{$ELSE} +asm + MOV ECX,opSubtract + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarMul(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opMultiply); +{$ELSE} +asm + MOV ECX,opMultiply + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarDiv(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opIntDivide); +{$ELSE} +asm + MOV ECX,opIntDivide + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarMod(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opModulus); +{$ELSE} +asm + MOV ECX,opModulus + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarAnd(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opAnd); +{$ELSE} +asm + MOV ECX,opAnd + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarOr(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opOr); +{$ELSE} +asm + MOV ECX,opOr + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarXor(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opXor); +{$ELSE} +asm + MOV ECX,opXor + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarShl(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opShiftLeft); +{$ELSE} +asm + MOV ECX,opShiftLeft + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarShr(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opShiftRight); +{$ELSE} +asm + MOV ECX,opShiftRight + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarRDiv(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opDivide); +{$ELSE} +asm + MOV ECX,opDivide + JMP VariantManager.VarOp +{$IFEND} +end; + +{$IF Defined(PIC) or Defined(PUREPASCAL)} +// result is set in the flags +procedure DoVarCmp(const Left, Right: Variant; OpCode: Integer); +begin + VariantManager.VarCmp(TVarData(Left), TVarData(Right), OpCode); +end; +{$IFEND} + +procedure _VarCmpEQ(const Left, Right: Variant); // result is set in the flags +asm + MOV ECX, opCmpEQ +{$IFDEF PIC} + JMP DoVarCmp +{$ELSE} + JMP VariantManager.VarCmp +{$ENDIF} +end; + +procedure _VarCmpNE(const Left, Right: Variant); // result is set in the flags +asm + MOV ECX, opCmpNE +{$IFDEF PIC} + JMP DoVarCmp +{$ELSE} + JMP VariantManager.VarCmp +{$ENDIF} +end; + +procedure _VarCmpLT(const Left, Right: Variant); // result is set in the flags +asm + MOV ECX, opCmpLT +{$IFDEF PIC} + JMP DoVarCmp +{$ELSE} + JMP VariantManager.VarCmp +{$ENDIF} +end; + +procedure _VarCmpLE(const Left, Right: Variant); // result is set in the flags +asm + MOV ECX, opCmpLE +{$IFDEF PIC} + JMP DoVarCmp +{$ELSE} + JMP VariantManager.VarCmp +{$ENDIF} +end; + +procedure _VarCmpGT(const Left, Right: Variant); // result is set in the flags +asm + MOV ECX, opCmpGT +{$IFDEF PIC} + JMP DoVarCmp +{$ELSE} + JMP VariantManager.VarCmp +{$ENDIF} +end; + +procedure _VarCmpGE(const Left, Right: Variant); // result is set in the flags +asm + MOV ECX, opCmpGE +{$IFDEF PIC} + JMP DoVarCmp +{$ELSE} + JMP VariantManager.VarCmp +{$ENDIF} +end; + + +procedure _VarNeg(var V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarNeg(V); +{$ELSE} +asm + JMP VariantManager.VarNeg +{$IFEND} +end; + +procedure _VarNot(var V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarNot(V); +{$ELSE} +asm + JMP VariantManager.VarNot +{$IFEND} +end; + +procedure _VarCopyNoInd; +asm +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + POP ECX + LEA EAX,[EAX].OFFSET VariantManager + MOV EAX,[EAX].TVariantManager.VarCopyNoInd + XCHG EAX,[ESP] + RET +{$ELSE} + JMP VariantManager.VarCopyNoInd +{$ENDIF} +end; + +procedure _VarClr(var V: Variant); +asm + PUSH EAX + CALL _VarClear + POP EAX +end; + +procedure _VarAddRef(var V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarAddRef(V); +{$ELSE} +asm + JMP VariantManager.VarAddRef +{$IFEND} +end; + +procedure _IntfDispCall; +asm +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + POP ECX + LEA EAX,[EAX].OFFSET DispCallByIDProc + MOV EAX,[EAX] + XCHG EAX,[ESP] + RET +{$ELSE} + JMP DispCallByIDProc +{$ENDIF} +end; + +procedure _DispCallByIDError; +asm + MOV AL,reVarDispatch + JMP Error +end; + +procedure _IntfVarCall; +asm +end; + +function _WriteVariant(var T: Text; const V: Variant; Width: Integer): Pointer; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.WriteVariant(T, V, Width); +{$ELSE} +asm + JMP VariantManager.WriteVariant +{$IFEND} +end; + +function _Write0Variant(var T: Text; const V: Variant): Pointer; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.Write0Variant(T, V); +{$ELSE} +asm + JMP VariantManager.Write0Variant +{$IFEND} +end; + +{ ----------------------------------------------------- } +{ Variant array support } +{ ----------------------------------------------------- } + +procedure _VarArrayRedim(var A : Variant; HighBound: Integer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarArrayRedim(A, HighBound); +{$ELSE} +asm + JMP VariantManager.VarArrayRedim +{$IFEND} +end; + +function _VarArrayGet(var A: Variant; IndexCount: Integer; + Indices: Integer): Variant; cdecl; +asm + POP EBP +{$IFDEF PIC} + CALL GetGOT + LEA EAX,[EAX].OFFSET VariantManager + MOV EAX,[EAX].TVariantManager.VarArrayGet + PUSH EAX + RET +{$ELSE} + JMP VariantManager.VarArrayGet +{$ENDIF} +end; + +procedure _VarArrayPut(var A: Variant; const Value: Variant; + IndexCount: Integer; Indices: Integer); cdecl; +asm + POP EBP +{$IFDEF PIC} + CALL GetGOT + LEA EAX,[EAX].OFFSET VariantManager + MOV EAX,[EAX].TVariantManager.VarArrayPut + PUSH EAX + RET +{$ELSE} + JMP VariantManager.VarArrayPut +{$ENDIF} +end; + +// 64 bit integer helper routines +// +// These functions always return the 64-bit result in EAX:EDX + +// ------------------------------------------------------------------------------ +// 64-bit signed multiply +// ------------------------------------------------------------------------------ +// +// Param 1(EAX:EDX), Param 2([ESP+8]:[ESP+4]) ; before reg pushing +// + +procedure __llmul; +asm + push edx + push eax + + // Param2 : [ESP+16]:[ESP+12] (hi:lo) + // Param1 : [ESP+4]:[ESP] (hi:lo) + + mov eax, [esp+16] + mul dword ptr [esp] + mov ecx, eax + + mov eax, [esp+4] + mul dword ptr [esp+12] + add ecx, eax + + mov eax, [esp] + mul dword ptr [esp+12] + add edx, ecx + + pop ecx + pop ecx + + ret 8 +end; + +// ------------------------------------------------------------------------------ +// 64-bit signed multiply, with overflow check (98.05.15: overflow not supported yet) +// ------------------------------------------------------------------------------ +// +// Param1 ~= U (Uh, Ul) +// Param2 ~= V (Vh, Vl) +// +// Param 1(EAX:EDX), Param 2([ESP+8]:[ESP+4]) ; before reg pushing +// +// compiler-helper function +// O-flag set on exit => result is invalid +// O-flag clear on exit => result is valid + +procedure __llmulo; +asm + push edx + push eax + + // Param2 : [ESP+16]:[ESP+12] (hi:lo) + // Param1 : [ESP+4]:[ESP] (hi:lo) + + mov eax, [esp+16] + mul dword ptr [esp] + mov ecx, eax + + mov eax, [esp+4] + mul dword ptr [esp+12] + add ecx, eax + + mov eax, [esp] + mul dword ptr [esp+12] + add edx, ecx + + pop ecx + pop ecx + + ret 8 +end; + +// ------------------------------------------------------------------------------ +// 64-bit signed division +// ------------------------------------------------------------------------------ + +// +// Dividend = Numerator, Divisor = Denominator +// +// Dividend(EAX:EDX), Divisor([ESP+8]:[ESP+4]) ; before reg pushing +// +// + +procedure __lldiv; +asm + push ebp + push ebx + push esi + push edi + xor edi,edi + + mov ebx,20[esp] // get the divisor low dword + mov ecx,24[esp] // get the divisor high dword + + or ecx,ecx + jnz @__lldiv@slow_ldiv // both high words are zero + + or edx,edx + jz @__lldiv@quick_ldiv + + or ebx,ebx + jz @__lldiv@quick_ldiv // if ecx:ebx == 0 force a zero divide + // we don't expect this to actually + // work + +@__lldiv@slow_ldiv: + +// +// Signed division should be done. Convert negative +// values to positive and do an unsigned division. +// Store the sign value in the next higher bit of +// di (test mask of 4). Thus when we are done, testing +// that bit will determine the sign of the result. +// + or edx,edx // test sign of dividend + jns @__lldiv@onepos + neg edx + neg eax + sbb edx,0 // negate dividend + or edi,1 + +@__lldiv@onepos: + or ecx,ecx // test sign of divisor + jns @__lldiv@positive + neg ecx + neg ebx + sbb ecx,0 // negate divisor + xor edi,1 + +@__lldiv@positive: + mov ebp,ecx + mov ecx,64 // shift counter + push edi // save the flags +// +// Now the stack looks something like this: +// +// 24[esp]: divisor (high dword) +// 20[esp]: divisor (low dword) +// 16[esp]: return EIP +// 12[esp]: previous EBP +// 8[esp]: previous EBX +// 4[esp]: previous ESI +// [esp]: previous EDI +// + xor edi,edi // fake a 64 bit dividend + xor esi,esi + +@__lldiv@xloop: + shl eax,1 // shift dividend left one bit + rcl edx,1 + rcl esi,1 + rcl edi,1 + cmp edi,ebp // dividend larger? + jb @__lldiv@nosub + ja @__lldiv@subtract + cmp esi,ebx // maybe + jb @__lldiv@nosub + +@__lldiv@subtract: + sub esi,ebx + sbb edi,ebp // subtract the divisor + inc eax // build quotient + +@__lldiv@nosub: + loop @__lldiv@xloop +// +// When done with the loop the four registers values' look like: +// +// | edi | esi | edx | eax | +// | remainder | quotient | +// + pop ebx // get control bits + test ebx,1 // needs negative + jz @__lldiv@finish + neg edx + neg eax + sbb edx,0 // negate + +@__lldiv@finish: + pop edi + pop esi + pop ebx + pop ebp + ret 8 + +@__lldiv@quick_ldiv: + div ebx // unsigned divide + xor edx,edx + jmp @__lldiv@finish +end; + +// ------------------------------------------------------------------------------ +// 64-bit signed division with overflow check (98.05.15: not implementated yet) +// ------------------------------------------------------------------------------ + +// +// Dividend = Numerator, Divisor = Denominator +// +// Dividend(EAX:EDX), Divisor([ESP+8]:[ESP+4]) +// Param 1 (EAX:EDX), Param 2([ESP+8]:[ESP+4]) +// +// Param1 ~= U (Uh, Ul) +// Param2 ~= V (Vh, Vl) +// +// compiler-helper function +// O-flag set on exit => result is invalid +// O-flag clear on exit => result is valid +// + +procedure __lldivo; +asm + // check for overflow condition: min(int64) DIV -1 + push esi + mov esi, [esp+12] // Vh + and esi, [esp+8] // Vl + cmp esi, 0ffffffffh // V = -1? + jne @@divok + + mov esi, eax + or esi, edx + cmp esi, 80000000H // U = min(int64)? + jne @@divok + +@@divOvl: + mov eax, esi + pop esi + dec eax // turn on O-flag + ret + +@@divok: + pop esi + push dword ptr [esp+8] // Vh + push dword ptr [esp+8] // Vl (offset is changed from push) + call __lldiv + and eax, eax // turn off O-flag + ret 8 +end; + +// ------------------------------------------------------------------------------ +// 64-bit unsigned division +// ------------------------------------------------------------------------------ + +// Dividend(EAX(hi):EDX(lo)), Divisor([ESP+8](hi):[ESP+4](lo)) // before reg pushing +procedure __lludiv; +asm + push ebp + push ebx + push esi + push edi +// +// Now the stack looks something like this: +// +// 24[esp]: divisor (high dword) +// 20[esp]: divisor (low dword) +// 16[esp]: return EIP +// 12[esp]: previous EBP +// 8[esp]: previous EBX +// 4[esp]: previous ESI +// [esp]: previous EDI +// + +// dividend is pushed last, therefore the first in the args +// divisor next. +// + mov ebx,20[esp] // get the first low word + mov ecx,24[esp] // get the first high word + + or ecx,ecx + jnz @__lludiv@slow_ldiv // both high words are zero + + or edx,edx + jz @__lludiv@quick_ldiv + + or ebx,ebx + jz @__lludiv@quick_ldiv // if ecx:ebx == 0 force a zero divide + // we don't expect this to actually + // work + +@__lludiv@slow_ldiv: + mov ebp,ecx + mov ecx,64 // shift counter + xor edi,edi // fake a 64 bit dividend + xor esi,esi + +@__lludiv@xloop: + shl eax,1 // shift dividend left one bit + rcl edx,1 + rcl esi,1 + rcl edi,1 + cmp edi,ebp // dividend larger? + jb @__lludiv@nosub + ja @__lludiv@subtract + cmp esi,ebx // maybe + jb @__lludiv@nosub + +@__lludiv@subtract: + sub esi,ebx + sbb edi,ebp // subtract the divisor + inc eax // build quotient + +@__lludiv@nosub: + loop @__lludiv@xloop +// +// When done with the loop the four registers values' look like: +// +// | edi | esi | edx | eax | +// | remainder | quotient | +// + +@__lludiv@finish: + pop edi + pop esi + pop ebx + pop ebp + ret 8 + +@__lludiv@quick_ldiv: + div ebx // unsigned divide + xor edx,edx + jmp @__lludiv@finish +end; + +// ------------------------------------------------------------------------------ +// 64-bit modulo +// ------------------------------------------------------------------------------ + +// Dividend(EAX:EDX), Divisor([ESP+8]:[ESP+4]) // before reg pushing +procedure __llmod; +asm + push ebp + push ebx + push esi + push edi + xor edi,edi +// +// dividend is pushed last, therefore the first in the args +// divisor next. +// + mov ebx,20[esp] // get the first low word + mov ecx,24[esp] // get the first high word + or ecx,ecx + jnz @__llmod@slow_ldiv // both high words are zero + + or edx,edx + jz @__llmod@quick_ldiv + + or ebx,ebx + jz @__llmod@quick_ldiv // if ecx:ebx == 0 force a zero divide + // we don't expect this to actually + // work +@__llmod@slow_ldiv: +// +// Signed division should be done. Convert negative +// values to positive and do an unsigned division. +// Store the sign value in the next higher bit of +// di (test mask of 4). Thus when we are done, testing +// that bit will determine the sign of the result. +// + or edx,edx // test sign of dividend + jns @__llmod@onepos + neg edx + neg eax + sbb edx,0 // negate dividend + or edi,1 + +@__llmod@onepos: + or ecx,ecx // test sign of divisor + jns @__llmod@positive + neg ecx + neg ebx + sbb ecx,0 // negate divisor + +@__llmod@positive: + mov ebp,ecx + mov ecx,64 // shift counter + push edi // save the flags +// +// Now the stack looks something like this: +// +// 24[esp]: divisor (high dword) +// 20[esp]: divisor (low dword) +// 16[esp]: return EIP +// 12[esp]: previous EBP +// 8[esp]: previous EBX +// 4[esp]: previous ESI +// [esp]: previous EDI +// + xor edi,edi // fake a 64 bit dividend + xor esi,esi + +@__llmod@xloop: + shl eax,1 // shift dividend left one bit + rcl edx,1 + rcl esi,1 + rcl edi,1 + cmp edi,ebp // dividend larger? + jb @__llmod@nosub + ja @__llmod@subtract + cmp esi,ebx // maybe + jb @__llmod@nosub + +@__llmod@subtract: + sub esi,ebx + sbb edi,ebp // subtract the divisor + inc eax // build quotient + +@__llmod@nosub: + loop @__llmod@xloop +// +// When done with the loop the four registers values' look like: +// +// | edi | esi | edx | eax | +// | remainder | quotient | +// + mov eax,esi + mov edx,edi // use remainder + + pop ebx // get control bits + test ebx,1 // needs negative + jz @__llmod@finish + neg edx + neg eax + sbb edx,0 // negate + +@__llmod@finish: + pop edi + pop esi + pop ebx + pop ebp + ret 8 + +@__llmod@quick_ldiv: + div ebx // unsigned divide + xchg eax,edx + xor edx,edx + jmp @__llmod@finish +end; + +// ------------------------------------------------------------------------------ +// 64-bit signed modulo with overflow (98.05.15: overflow not yet supported) +// ------------------------------------------------------------------------------ + +// Dividend(EAX:EDX), Divisor([ESP+8]:[ESP+4]) +// Param 1 (EAX:EDX), Param 2([ESP+8]:[ESP+4]) +// +// Param1 ~= U (Uh, Ul) +// Param2 ~= V (Vh, Vl) +// +// compiler-helper function +// O-flag set on exit => result is invalid +// O-flag clear on exit => result is valid +// + +procedure __llmodo; +asm + // check for overflow condition: min(int64) MOD -1 + push esi + mov esi, [esp+12] // Vh + and esi, [esp+8] // Vl + cmp esi, 0ffffffffh // V = -1? + jne @@modok + + mov esi, eax + or esi, edx + cmp esi, 80000000H // U = min(int64)? + jne @@modok + +@@modOvl: + mov eax, esi + pop esi + dec eax // turn on O-flag + ret + +@@modok: + pop esi + push dword ptr [esp+8] // Vh + push dword ptr [esp+8] // Vl (offset is changed from push) + call __llmod + and eax, eax // turn off O-flag + ret 8 +end; + +// ------------------------------------------------------------------------------ +// 64-bit unsigned modulo +// ------------------------------------------------------------------------------ +// Dividend(EAX(hi):EDX(lo)), Divisor([ESP+8](hi):[ESP+4](lo)) // before reg pushing + +procedure __llumod; +asm + push ebp + push ebx + push esi + push edi +// +// Now the stack looks something like this: +// +// 24[esp]: divisor (high dword) +// 20[esp]: divisor (low dword) +// 16[esp]: return EIP +// 12[esp]: previous EBP +// 8[esp]: previous EBX +// 4[esp]: previous ESI +// [esp]: previous EDI +// + +// dividend is pushed last, therefore the first in the args +// divisor next. +// + mov ebx,20[esp] // get the first low word + mov ecx,24[esp] // get the first high word + or ecx,ecx + jnz @__llumod@slow_ldiv // both high words are zero + + or edx,edx + jz @__llumod@quick_ldiv + + or ebx,ebx + jz @__llumod@quick_ldiv // if ecx:ebx == 0 force a zero divide + // we don't expect this to actually + // work +@__llumod@slow_ldiv: + mov ebp,ecx + mov ecx,64 // shift counter + xor edi,edi // fake a 64 bit dividend + xor esi,esi // + +@__llumod@xloop: + shl eax,1 // shift dividend left one bit + rcl edx,1 + rcl esi,1 + rcl edi,1 + cmp edi,ebp // dividend larger? + jb @__llumod@nosub + ja @__llumod@subtract + cmp esi,ebx // maybe + jb @__llumod@nosub + +@__llumod@subtract: + sub esi,ebx + sbb edi,ebp // subtract the divisor + inc eax // build quotient + +@__llumod@nosub: + loop @__llumod@xloop +// +// When done with the loop the four registers values' look like: +// +// | edi | esi | edx | eax | +// | remainder | quotient | +// + mov eax,esi + mov edx,edi // use remainder + +@__llumod@finish: + pop edi + pop esi + pop ebx + pop ebp + ret 8 + +@__llumod@quick_ldiv: + div ebx // unsigned divide + xchg eax,edx + xor edx,edx + jmp @__llumod@finish +end; + +// ------------------------------------------------------------------------------ +// 64-bit shift left +// ------------------------------------------------------------------------------ + +// +// target (EAX:EDX) count (ECX) +// +procedure __llshl; +asm + cmp cl, 32 + jl @__llshl@below32 + cmp cl, 64 + jl @__llshl@below64 + xor edx, edx + xor eax, eax + ret + +@__llshl@below64: + mov edx, eax + shl edx, cl + xor eax, eax + ret + +@__llshl@below32: + shld edx, eax, cl + shl eax, cl + ret +end; + +// ------------------------------------------------------------------------------ +// 64-bit signed shift right +// ------------------------------------------------------------------------------ +// target (EAX:EDX) count (ECX) + +procedure __llshr; +asm + cmp cl, 32 + jl @__llshr@below32 + cmp cl, 64 + jl @__llshr@below64 + sar edx, 1fh + mov eax,edx + ret + +@__llshr@below64: + mov eax, edx + cdq + sar eax,cl + ret + +@__llshr@below32: + shrd eax, edx, cl + sar edx, cl + ret +end; + +// ------------------------------------------------------------------------------ +// 64-bit unsigned shift right +// ------------------------------------------------------------------------------ + +// target (EAX:EDX) count (ECX) +procedure __llushr; +asm + cmp cl, 32 + jl @__llushr@below32 + cmp cl, 64 + jl @__llushr@below64 + xor edx, edx + xor eax, eax + ret + +@__llushr@below64: + mov eax, edx + xor edx, edx + shr eax, cl + ret + +@__llushr@below32: + shrd eax, edx, cl + shr edx, cl + ret +end; + +function _StrInt64(val: Int64; width: Integer): ShortString; +var + d: array[0..31] of Char; { need 19 digits and a sign } + i, k: Integer; + sign: Boolean; + spaces: Integer; +begin + { Produce an ASCII representation of the number in reverse order } + i := 0; + sign := val < 0; + repeat + d[i] := Chr( Abs(val mod 10) + Ord('0') ); + Inc(i); + val := val div 10; + until val = 0; + if sign then + begin + d[i] := '-'; + Inc(i); + end; + + { Fill the Result with the appropriate number of blanks } + if width > 255 then + width := 255; + k := 1; + spaces := width - i; + while k <= spaces do + begin + Result[k] := ' '; + Inc(k); + end; + + { Fill the Result with the number } + while i > 0 do + begin + Dec(i); + Result[k] := d[i]; + Inc(k); + end; + + { Result is k-1 characters long } + SetLength(Result, k-1); + +end; + +function _Str0Int64(val: Int64): ShortString; +begin + Result := _StrInt64(val, 0); +end; + +procedure _WriteInt64; +asm +{ PROCEDURE _WriteInt64( VAR t: Text; val: Int64; with: Longint); } +{ ->EAX Pointer to file record } +{ [ESP+4] Value } +{ EDX Field width } + + SUB ESP,32 { VAR s: String[31]; } + + PUSH EAX + PUSH EDX + + PUSH dword ptr [ESP+8+32+8] { Str( val : 0, s ); } + PUSH dword ptr [ESP+8+32+8] + XOR EAX,EAX + LEA EDX,[ESP+8+8] + CALL _StrInt64 + + POP ECX + POP EAX + + MOV EDX,ESP { Write( t, s : width );} + CALL _WriteString + + ADD ESP,32 + RET 8 +end; + +function _StrUInt64Digits(val: UInt64; width: Integer; sign: Boolean): ShortString; +var + d: array[0..31] of Char; { need 19 digits and a sign } + i, k: Integer; + spaces: Integer; +begin + { Produce an ASCII representation of the number in reverse order } + i := 0; + repeat + d[i] := Chr( (val mod 10) + Ord('0') ); + Inc(i); + val := val div 10; + until val = 0; + if sign then + begin + d[i] := '-'; + Inc(i); + end; + + { Fill the Result with the appropriate number of blanks } + if width > 255 then + width := 255; + k := 1; + spaces := width - i; + while k <= spaces do + begin + Result[k] := ' '; + Inc(k); + end; + + { Fill the Result with the number } + while i > 0 do + begin + Dec(i); + Result[k] := d[i]; + Inc(k); + end; + + { Result is k-1 characters long } + SetLength(Result, k-1); +end; + +function _StrUInt64(val: UInt64; width: Integer): ShortString; +begin + Result := _StrUInt64Digits(val, width, False); +end; + +function _Str0UInt64(val: Int64): ShortString; +begin + Result := _StrUInt64(val, 0); +end; + +procedure _Write0Int64; +asm +{ PROCEDURE _Write0Long( VAR t: Text; val: Longint); } +{ ->EAX Pointer to file record } +{ EDX Value } + XOR EDX,EDX + JMP _WriteInt64 +end; + +procedure _WriteUInt64; +asm +{ PROCEDURE _WriteInt64( VAR t: Text; val: Int64; with: Longint); } +{ ->EAX Pointer to file record } +{ [ESP+4] Value } +{ EDX Field width } + + SUB ESP,32 { VAR s: String[31]; } + + PUSH EAX + PUSH EDX + + PUSH dword ptr [ESP+8+32+8] { Str( val : 0, s ); } + PUSH dword ptr [ESP+8+32+8] + XOR EAX,EAX + LEA EDX,[ESP+8+8] + CALL _StrUInt64 + + POP ECX + POP EAX + + MOV EDX,ESP { Write( t, s : width );} + CALL _WriteString + + ADD ESP,32 + RET 8 +end; + +procedure _Write0UInt64; +asm +{ PROCEDURE _Write0Long( VAR t: Text; val: Longint); } +{ ->EAX Pointer to file record } +{ EDX Value } + XOR EDX,EDX + JMP _WriteUInt64 +end; + +procedure _ReadInt64; +asm + // -> EAX Pointer to text record + // <- EAX:EDX Result + + PUSH EBX + PUSH ESI + PUSH EDI + SUB ESP,36 // var numbuf: String[32]; + + MOV ESI,EAX + CALL _SeekEof + DEC AL + JZ @@eof + + MOV EDI,ESP // EDI -> numBuf[0] + MOV BL,32 +@@loop: + MOV EAX,ESI + CALL _ReadChar + CMP AL,' ' + JBE @@endNum + STOSB + DEC BL + JNZ @@loop +@@convert: + MOV byte ptr [EDI],0 + MOV EAX,ESP // EAX -> numBuf + PUSH EDX // allocate code result + MOV EDX,ESP // pass pointer to code + CALL _ValInt64 // convert + POP ECX // pop code result into EDX + TEST ECX,ECX + JZ @@exit + MOV EAX,106 + CALL SetInOutRes + +@@exit: + ADD ESP,36 + POP EDI + POP ESI + POP EBX + RET + +@@endNum: + CMP AH,cEof + JE @@convert + DEC [ESI].TTextRec.BufPos + JMP @@convert + +@@eof: + XOR EAX,EAX + JMP @@exit +end; + +function _ValInt64(const s: AnsiString; var code: Integer): Int64; +var + i: Integer; + dig: Integer; + sign: Boolean; + empty: Boolean; +begin + i := 1; + dig := 0; + Result := 0; + if s = '' then + begin + code := i; + exit; + end; + while s[i] = ' ' do + Inc(i); + sign := False; + if s[i] = '-' then + begin + sign := True; + Inc(i); + end + else if s[i] = '+' then + Inc(i); + empty := True; + if (s[i] = '$') or (s[i] = '0') and (Upcase(s[i+1]) = 'X') then + begin + if s[i] = '0' then + Inc(i); + Inc(i); + while True do + begin + case s[i] of + '0'..'9': dig := Ord(s[i]) - Ord('0'); + 'A'..'F': dig := Ord(s[i]) - (Ord('A') - 10); + 'a'..'f': dig := Ord(s[i]) - (Ord('a') - 10); + else + break; + end; + if (Result < 0) or (Result > (High(Int64) div 16)) then + break; + Result := Result shl 4 + dig; + Inc(i); + empty := False; + end; + if sign then + Result := - Result; + end + else + begin + while True do + begin + case s[i] of + '0'..'9': dig := Ord(s[i]) - Ord('0'); + else + break; + end; + if (Result < 0) or (Result > (High(Int64) div 10)) then + break; + Result := Result*10 + dig; + Inc(i); + empty := False; + end; + if sign then + Result := - Result; + if (Result <> 0) and (sign <> (Result < 0)) then + Dec(i); + end; + if (s[i] <> #0) or empty then + code := i + else + code := 0; +end; + +procedure _DynArrayLength; +asm +{ FUNCTION _DynArrayLength(const a: array of ...): Longint; } +{ ->EAX Pointer to array or nil } +{ <-EAX High bound of array + 1 or 0 } + TEST EAX,EAX + JZ @@skip + MOV EAX,[EAX-4] +@@skip: +end; + +procedure _DynArrayHigh; +asm +{ FUNCTION _DynArrayHigh(const a: array of ...): Longint; } +{ ->EAX Pointer to array or nil } +{ <-EAX High bound of array or -1 } + CALL _DynArrayLength + DEC EAX +end; + +procedure CopyArray(dest, source, typeInfo: Pointer; cnt: Integer); +asm + PUSH dword ptr [EBP+8] + CALL _CopyArray +end; + +procedure FinalizeArray(p, typeInfo: Pointer; cnt: Integer); +asm + JMP _FinalizeArray +end; + +procedure DynArrayClear(var a: Pointer; typeInfo: Pointer); +asm + CALL _DynArrayClear +end; + +procedure DynArraySetLength(var a: Pointer; typeInfo: Pointer; dimCnt: Longint; lengthVec: PLongint); +var + i: Integer; + newLength, oldLength, minLength: Longint; + elSize: Longint; + neededSize: Longint; + p, pp: Pointer; +begin + p := a; + + // Fetch the new length of the array in this dimension, and the old length + newLength := PLongint(lengthVec)^; + if newLength <= 0 then + begin + if newLength < 0 then + Error(reRangeError); + DynArrayClear(a, typeInfo); + exit; + end; + + oldLength := 0; + if p <> nil then + begin + Dec(PLongint(p)); + oldLength := PLongint(p)^; + Dec(PLongint(p)); + end; + + // Calculate the needed size of the heap object + Inc(PChar(typeInfo), Length(PDynArrayTypeInfo(typeInfo).name)); + elSize := PDynArrayTypeInfo(typeInfo).elSize; + if PDynArrayTypeInfo(typeInfo).elType <> nil then + typeInfo := PDynArrayTypeInfo(typeInfo).elType^ + else + typeInfo := nil; + neededSize := newLength*elSize; + if neededSize div newLength <> elSize then + Error(reRangeError); + Inc(neededSize, Sizeof(Longint)*2); + + // If the heap object isn't shared (ref count = 1), just resize it. Otherwise, we make a copy + if (p = nil) or (PLongint(p)^ = 1) then + begin + pp := p; + if (newLength < oldLength) and (typeInfo <> nil) then + FinalizeArray(PChar(p) + Sizeof(Longint)*2 + newLength*elSize, typeInfo, oldLength - newLength); + ReallocMem(pp, neededSize); + p := pp; + end + else + begin + Dec(PLongint(p)^); + GetMem(p, neededSize); + minLength := oldLength; + if minLength > newLength then + minLength := newLength; + if typeInfo <> nil then + begin + FillChar((PChar(p) + Sizeof(Longint)*2)^, minLength*elSize, 0); + CopyArray(PChar(p) + Sizeof(Longint)*2, a, typeInfo, minLength) + end + else + Move(PChar(a)^, (PChar(p) + Sizeof(Longint)*2)^, minLength*elSize); + end; + + // The heap object will now have a ref count of 1 and the new length + PLongint(p)^ := 1; + Inc(PLongint(p)); + PLongint(p)^ := newLength; + Inc(PLongint(p)); + + // Set the new memory to all zero bits + FillChar((PChar(p) + elSize * oldLength)^, elSize * (newLength - oldLength), 0); + + // Take care of the inner dimensions, if any + if dimCnt > 1 then + begin + Inc(lengthVec); + Dec(dimCnt); + for i := 0 to newLength-1 do + DynArraySetLength(PPointerArray(p)[i], typeInfo, dimCnt, lengthVec); + end; + a := p; +end; + +procedure _DynArraySetLength; +asm +{ PROCEDURE _DynArraySetLength(var a: dynarray; typeInfo: PDynArrayTypeInfo; dimCnt: Longint; lengthVec: ^Longint) } +{ ->EAX Pointer to dynamic array (= pointer to pointer to heap object) } +{ EDX Pointer to type info for the dynamic array } +{ ECX number of dimensions } +{ [ESP+4] dimensions } + PUSH ESP + ADD dword ptr [ESP],4 + CALL DynArraySetLength +end; + +procedure _DynArrayCopy(a: Pointer; typeInfo: Pointer; var Result: Pointer); +begin + if a <> nil then + _DynArrayCopyRange(a, typeInfo, 0, PLongint(PChar(a)-4)^, Result) + else + _DynArrayClear(Result, typeInfo); +end; + +procedure _DynArrayCopyRange(a: Pointer; typeInfo: Pointer; index, count : Integer; var Result: Pointer); +var + arrayLength: Integer; + elSize: Integer; + typeInf: PDynArrayTypeInfo; + p: Pointer; +begin + p := nil; + if a <> nil then + begin + typeInf := typeInfo; + + // Limit index and count to values within the array + if index < 0 then + begin + Inc(count, index); + index := 0; + end; + arrayLength := PLongint(PChar(a)-4)^; + if index > arrayLength then + index := arrayLength; + if count > arrayLength - index then + count := arrayLength - index; + if count < 0 then + count := 0; + + if count > 0 then + begin + // Figure out the size and type descriptor of the element type + Inc(PChar(typeInf), Length(typeInf.name)); + elSize := typeInf.elSize; + if typeInf.elType <> nil then + typeInf := typeInf.elType^ + else + typeInf := nil; + + // Allocate the amount of memory needed + GetMem(p, count*elSize + Sizeof(Longint)*2); + + // The reference count of the new array is 1, the length is count + PLongint(p)^ := 1; + Inc(PLongint(p)); + PLongint(p)^ := count; + Inc(PLongint(p)); + Inc(PChar(a), index*elSize); + + // If the element type needs destruction, we must copy each element, + // otherwise we can just copy the bits + if count > 0 then + begin + if typeInf <> nil then + begin + FillChar(p^, count*elSize, 0); + CopyArray(p, a, typeInf, count) + end + else + Move(a^, p^, count*elSize); + end; + end; + end; + DynArrayClear(Result, typeInfo); + Result := p; +end; + +procedure _DynArrayClear; +asm +{ ->EAX Pointer to dynamic array (Pointer to pointer to heap object } +{ EDX Pointer to type info } + + { Nothing to do if Pointer to heap object is nil } + MOV ECX,[EAX] + TEST ECX,ECX + JE @@exit + + { Set the variable to be finalized to nil } + MOV dword ptr [EAX],0 + + { Decrement ref count. Nothing to do if not zero now. } +{X LOCK} DEC dword ptr [ECX-8] + JNE @@exit + + { Save the source - we're supposed to return it } + PUSH EAX + MOV EAX,ECX + + { Fetch the type descriptor of the elements } + XOR ECX,ECX + MOV CL,[EDX].TDynArrayTypeInfo.name; + MOV EDX,[EDX+ECX].TDynArrayTypeInfo.elType; + + { If it's non-nil, finalize the elements } + TEST EDX,EDX + JE @@noFinalize + MOV ECX,[EAX-4] + TEST ECX,ECX + JE @@noFinalize + MOV EDX,[EDX] + CALL _FinalizeArray +@@noFinalize: + { Now deallocate the array } + SUB EAX,8 + CALL _FreeMem + POP EAX +@@exit: +end; + + +procedure _DynArrayAsg; +asm +{ ->EAX Pointer to destination (pointer to pointer to heap object } +{ EDX source (pointer to heap object } +{ ECX Pointer to rtti describing dynamic array } + + PUSH EBX + MOV EBX,[EAX] + + { Increment ref count of source if non-nil } + + TEST EDX,EDX + JE @@skipInc +{X LOCK} INC dword ptr [EDX-8] +@@skipInc: + { Dec ref count of destination - if it becomes 0, clear dest } + TEST EBX,EBX + JE @@skipClear +{X LOCK} DEC dword ptr[EBX-8] + JNZ @@skipClear + PUSH EAX + PUSH EDX + MOV EDX,ECX + INC dword ptr[EBX-8] + CALL _DynArrayClear + POP EDX + POP EAX +@@skipClear: + { Finally store source into destination } + MOV [EAX],EDX + + POP EBX +end; + +procedure _DynArrayAddRef; +asm +{ ->EAX Pointer to heap object } + TEST EAX,EAX + JE @@exit +{X LOCK} INC dword ptr [EAX-8] +@@exit: +end; + + +function DynArrayIndex(const P: Pointer; const Indices: array of Integer; const TypInfo: Pointer): Pointer; +asm + { ->EAX P } + { EDX Pointer to Indices } + { ECX High bound of Indices } + { [EBP+8] TypInfo } + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV ESI,EDX + MOV EDI,[EBP+8] + MOV EBP,EAX + + XOR EBX,EBX { for i := 0 to High(Indices) do } + TEST ECX,ECX + JGE @@start +@@loop: + MOV EBP,[EBP] +@@start: + XOR EAX,EAX + MOV AL,[EDI].TDynArrayTypeInfo.name + ADD EDI,EAX + MOV EAX,[ESI+EBX*4] { P := P + Indices[i]*TypInfo.elSize } + MUL [EDI].TDynArrayTypeInfo.elSize + MOV EDI,[EDI].TDynArrayTypeInfo.elType + TEST EDI,EDI + JE @@skip + MOV EDI,[EDI] +@@skip: + ADD EBP,EAX + INC EBX + CMP EBX,ECX + JLE @@loop + +@@loopEnd: + + MOV EAX,EBP + + POP EBP + POP EDI + POP ESI + POP EBX +end; + + +{ Returns the DynArrayTypeInfo of the Element Type of the specified DynArrayTypeInfo } +function DynArrayElTypeInfo(typeInfo: PDynArrayTypeInfo): PDynArrayTypeInfo; +begin + Result := nil; + if typeInfo <> nil then + begin + Inc(PChar(typeInfo), Length(typeInfo.name)); + if typeInfo.elType <> nil then + Result := typeInfo.elType^; + end; +end; + +{ Returns # of dimemsions of the DynArray described by the specified DynArrayTypeInfo} +function DynArrayDim(typeInfo: PDynArrayTypeInfo): Integer; +begin + Result := 0; + while (typeInfo <> nil) and (typeInfo.kind = tkDynArray) do + begin + Inc(Result); + typeInfo := DynArrayElTypeInfo(typeInfo); + end; +end; + +{ Returns size of the Dynamic Array} +function DynArraySize(a: Pointer): Integer; +asm + TEST EAX, EAX + JZ @@exit + MOV EAX, [EAX-4] +@@exit: +end; + +// Returns whether array is rectangular +function IsDynArrayRectangular(const DynArray: Pointer; typeInfo: PDynArrayTypeInfo): Boolean; +var + Dim, I, J, Size, SubSize: Integer; + P: Pointer; +begin + // Assume we have a rectangular array + Result := True; + + P := DynArray; + Dim := DynArrayDim(typeInfo); + + {NOTE: Start at 1. Don't need to test the first dimension - it's rectangular by definition} + for I := 1 to dim-1 do + begin + if P <> nil then + begin + { Get size of this dimension } + Size := DynArraySize(P); + + { Get Size of first sub. dimension } + SubSize := DynArraySize(PPointerArray(P)[0]); + + { Walk through every dimension making sure they all have the same size} + for J := 1 to Size-1 do + if DynArraySize(PPointerArray(P)[J]) <> SubSize then + begin + Result := False; + Exit; + end; + + { Point to next dimension} + P := PPointerArray(P)[0]; + end; + end; +end; + +// Returns Bounds of Dynamic array as an array of integer containing the 'high' of each dimension +function DynArrayBounds(const DynArray: Pointer; typeInfo: PDynArrayTypeInfo): TBoundArray; +var + Dim, I: Integer; + P: Pointer; +begin + P := DynArray; + + Dim := DynArrayDim(typeInfo); + SetLength(Result, Dim); + + for I := 0 to dim-1 do + if P <> nil then + begin + Result[I] := DynArraySize(P)-1; + P := PPointerArray(P)[0]; // Assume rectangular arrays + end; +end; + +{ Decrements to next lower index - Returns True if successful } +{ Indices: Indices to be decremented } +{ Bounds : High bounds of each dimension } +function DecIndices(var Indices: TBoundArray; const Bounds: TBoundArray): Boolean; +var + I, J: Integer; +begin + { Find out if we're done: all at zeroes } + Result := False; + for I := Low(Indices) to High(Indices) do + if Indices[I] <> 0 then + begin + Result := True; + break; + end; + if not Result then + Exit; + + { Two arrays must be of same length } + Assert(Length(Indices) = Length(Bounds)); + + { Find index of item to tweak } + for I := High(Indices) downto Low(Bounds) do + begin + // If not reach zero, dec and bail out + if Indices[I] <> 0 then + begin + Dec(Indices[I]); + Exit; + end + else + begin + J := I; + while Indices[J] = 0 do + begin + // Restore high bound when we've reached zero on a particular dimension + Indices[J] := Bounds[J]; + // Move to higher dimension + Dec(J); + Assert(J >= 0); + end; + Dec(Indices[J]); + Exit; + end; + end; +end; + +{ Package/Module registration/unregistration } + +{$IFDEF MSWINDOWS} +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 +{$ENDIF} + +function FindModule(Instance: LongWord): PLibModule; +begin + Result := LibModuleList; + while Result <> nil do + begin + if (Instance = Result.Instance) or + (Instance = Result.CodeInstance) or + (Instance = Result.DataInstance) or + (Instance = Result.ResInstance) then + Exit; + Result := Result.Next; + end; +end; + +function FindHInstance(Address: Pointer): LongWord; +{$IFDEF MSWINDOWS} +var + MemInfo: TMemInfo; +begin + VirtualQuery(Address, MemInfo, SizeOf(MemInfo)); + if MemInfo.State = $1000{MEM_COMMIT} then + Result := LongWord(MemInfo.AllocationBase) + else + Result := 0; +end; +{$ENDIF} +{$IFDEF LINUX} +var + Info: TDLInfo; +begin + if (dladdr(Address, Info) = 0) or (Info.BaseAddress = ExeBaseAddress) then + Info.Filename := nil; // if it's not in a library, assume the exe + Result := LongWord(dlopen(Info.Filename, RTLD_LAZY)); + if Result <> 0 then + dlclose(Result); +end; +{$ENDIF} + +function FindClassHInstance(ClassType: TClass): LongWord; +begin + Result := FindHInstance(Pointer(ClassType)); +end; + +{$IFDEF LINUX} +function GetModuleFileName(Module: HMODULE; Buffer: PChar; BufLen: Integer): Integer; +var + Addr: Pointer; + Info: TDLInfo; + FoundInModule: HMODULE; +begin + Result := 0; + if (Module = MainInstance) or (Module = 0) then + begin + // First, try the dlsym approach. + // dladdr fails to return the name of the main executable + // in glibc prior to 2.1.91 + +{ Look for a dynamic symbol exported from this program. + _DYNAMIC is not required in a main program file. + If the main program is compiled with Delphi, it will always + have a resource section, named @Sysinit@ResSym. + If the main program is not compiled with Delphi, dlsym + will search the global name space, potentially returning + the address of a symbol in some other shared object library + loaded by the program. To guard against that, we check + that the address of the symbol found is within the + main program address range. } + + dlerror; // clear error state; dlsym doesn't + Addr := dlsym(Module, '@Sysinit@ResSym'); + if (Addr <> nil) and (dlerror = nil) + and (dladdr(Addr, Info) <> 0) + and (Info.FileName <> nil) + and (Info.BaseAddress = ExeBaseAddress) then + begin + Result := _strlen(Info.FileName); + if Result >= BufLen then Result := BufLen-1; + Move(Info.FileName^, Buffer^, Result); + Buffer[Result] := #0; + Exit; + end; + + // Try inspecting the /proc/ virtual file system + // to find the program filename in the process info + Result := _readlink('/proc/self/exe', Buffer, BufLen); + if Result <> -1 then + begin + if Result >= BufLen then Result := BufLen-1; + Buffer[Result] := #0; + end; +{$IFDEF AllowParamStrModuleName} +{ Using ParamStr(0) to obtain a module name presents a potential + security hole. Resource modules are loaded based upon the filename + of a given module. We use dlopen() to load resource modules, which + means the .init code of the resource module will be executed. + Normally, resource modules contain no code at all - they're just + carriers of resource data. + An unpriviledged user program could launch our trusted, + priviledged program with a bogus parameter list, tricking us + into loading a module that contains malicious code in its + .init section. + Without this ParamStr(0) section, GetModuleFilename cannot be + misdirected by unpriviledged code (unless the system program loader + or the /proc file system or system root directory has been compromised). + Resource modules are always loaded from the same directory as the + given module. Trusted code (programs, packages, and libraries) + should reside in directories that unpriviledged code cannot alter. + + If you need GetModuleFilename to have a chance of working on systems + where glibc < 2.1.91 and /proc is not available, and your + program will not run as a priviledged user (or you don't care), + you can define AllowParamStrModuleNames and rebuild the System unit + and baseCLX package. Note that even with ParamStr(0) support + enabled, GetModuleFilename can still fail to find the name of + a module. C'est la Unix. } + + if Result = -1 then // couldn't access the /proc filesystem + begin // return less accurate ParamStr(0) + +{ ParamStr(0) returns the name of the link used + to launch the app, not the name of the app itself. + Also, if this app was launched by some other program, + there is no guarantee that the launching program has set + up our environment at all. (example: Apache CGI) } + + if (ArgValues = nil) or (ArgValues^ = nil) or + (PCharArray(ArgValues^)[0] = nil) then + begin + Result := 0; + Exit; + end; + Result := _strlen(PCharArray(ArgValues^)[0]); + if Result >= BufLen then Result := BufLen-1; + Move(PCharArray(ArgValues^)[0]^, Buffer^, Result); + Buffer[Result] := #0; + end; +{$ENDIF} + end + else + begin +{ For shared object libraries, we can rely on the dlsym technique. + Look for a dynamic symbol in the requested module. + Don't assume the module was compiled with Delphi. + We look for a dynamic symbol with the name _DYNAMIC. This + exists in all ELF shared object libraries that export + or import symbols; If someone has a shared object library that + contains no imports or exports of any kind, this will probably fail. + If dlsym can't find the requested symbol in the given module, it + will search the global namespace and could return the address + of a symbol from some other module that happens to be loaded + into this process. That would be bad, so we double check + that the module handle of the symbol found matches the + module handle we asked about.} + + dlerror; // clear error state; dlsym doesn't + Addr := dlsym(Module, '_DYNAMIC'); + if (Addr <> nil) and (dlerror = nil) + and (dladdr(Addr, Info) <> 0) then + begin + if Info.BaseAddress = ExeBaseAddress then + Info.FileName := nil; + FoundInModule := HMODULE(dlopen(Info.FileName, RTLD_LAZY)); + if FoundInModule <> 0 then + dlclose(FoundInModule); + if Module = FoundInModule then + begin + Result := _strlen(Info.FileName); + if Result >= BufLen then Result := BufLen-1; + Move(Info.FileName^, Buffer^, Result); + Buffer[Result] := #0; + end; + end; + end; + if Result < 0 then Result := 0; +end; +{$ENDIF} + +function DelayLoadResourceModule(Module: PLibModule): LongWord; +var + FileName: array[0..MAX_PATH] of Char; +begin + if Module.ResInstance = 0 then + begin + GetModuleFileName(Module.Instance, FileName, SizeOf(FileName)); + Module.ResInstance := LoadResourceModule(FileName); + if Module.ResInstance = 0 then + Module.ResInstance := Module.Instance; + end; + Result := Module.ResInstance; +end; + +function FindResourceHInstance(Instance: LongWord): LongWord; +var + CurModule: PLibModule; +begin + CurModule := LibModuleList; + while CurModule <> nil do + begin + if (Instance = CurModule.Instance) or + (Instance = CurModule.CodeInstance) or + (Instance = CurModule.DataInstance) then + begin + Result := DelayLoadResourceModule(CurModule); + Exit; + end; + CurModule := CurModule.Next; + end; + Result := Instance; +end; + +function LoadResourceModule(ModuleName: PChar; CheckOwner: Boolean): LongWord; +{$IFDEF LINUX} +var + FileName: array [0..MAX_PATH] of Char; + LangCode: PChar; // Language and country code. Example: en_US + P: PChar; + ModuleNameLen, FileNameLen, i: Integer; + st1, st2: TStatStruct; +begin + LangCode := __getenv('LANG'); + Result := 0; + if (LangCode = nil) or (LangCode^ = #0) then Exit; + + // look for modulename.en_US (ignoring codeset and modifier suffixes) + P := LangCode; + while P^ in ['a'..'z', 'A'..'Z', '_'] do + Inc(P); + if P = LangCode then Exit; + + if CheckOwner and (__xstat(STAT_VER_LINUX, ModuleName, st1) = -1) then + Exit; + + ModuleNameLen := _strlen(ModuleName); + if (ModuleNameLen + P - LangCode) >= MAX_PATH then Exit; + Move(ModuleName[0], Filename[0], ModuleNameLen); + Filename[ModuleNameLen] := '.'; + Move(LangCode[0], Filename[ModuleNameLen + 1], P - LangCode); + FileNameLen := ModuleNameLen + 1 + (P - LangCode); + Filename[FileNameLen] := #0; + +{ Security check: make sure the user id (owner) and group id of + the base module matches the user id and group id of the resource + module we're considering loading. This is to prevent loading + of malicious code dropped into the base module's directory by + a hostile user. The app and all its resource modules must + have the same owner and group. To disable this security check, + call this function with CheckOwner set to False. } + + if (not CheckOwner) or + ((__xstat(STAT_VER_LINUX, FileName, st2) <> -1) + and (st1.st_uid = st2.st_uid) + and (st1.st_gid = st2.st_gid)) then + begin + Result := dlopen(Filename, RTLD_LAZY); + if Result <> 0 then Exit; + end; + + // look for modulename.en (ignoring country code and suffixes) + i := ModuleNameLen + 1; + while (i <= FileNameLen) and (Filename[i] in ['a'..'z', 'A'..'Z']) do + Inc(i); + if (i = ModuleNameLen + 1) or (i > FileNameLen) then Exit; + FileName[i] := #0; + + { Security check. See notes above. } + if (not CheckOwner) or + ((__xstat(STAT_VER_LINUX, FileName, st2) <> -1) + and (st1.st_uid = st2.st_uid) + and (st1.st_gid = st2.st_gid)) then + begin + Result := dlopen(FileName, RTLD_LAZY); + end; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +var + FileName: array[0..MAX_PATH] of Char; + Key: LongWord; + LocaleName, LocaleOverride: array[0..4] of Char; + Size: Integer; + P: PChar; + + function FindBS(Current: PChar): PChar; + begin + Result := Current; + while (Result^ <> #0) and (Result^ <> '\') do + Result := CharNext(Result); + end; + + function ToLongPath(AFileName: PChar; BufSize: Integer): PChar; + var + CurrBS, NextBS: PChar; + Handle, L: Integer; + FindData: TWin32FindData; + Buffer: array[0..MAX_PATH] of Char; + GetLongPathName: function (ShortPathName: PChar; LongPathName: PChar; + cchBuffer: Integer): Integer stdcall; + begin + Result := AFileName; + Handle := GetModuleHandle(kernel); + if Handle <> 0 then + begin + @GetLongPathName := GetProcAddress(Handle, 'GetLongPathNameA'); + if Assigned(GetLongPathName) and + (GetLongPathName(AFileName, Buffer, SizeOf(Buffer)) <> 0) then + begin + lstrcpyn(AFileName, Buffer, BufSize); + Exit; + end; + end; + + if AFileName[0] = '\' then + begin + if AFileName[1] <> '\' then Exit; + CurrBS := FindBS(AFileName + 2); // skip server name + if CurrBS^ = #0 then Exit; + CurrBS := FindBS(CurrBS + 1); // skip share name + if CurrBS^ = #0 then Exit; + end else + CurrBS := AFileName + 2; // skip drive name + + L := CurrBS - AFileName; + lstrcpyn(Buffer, AFileName, L + 1); + while CurrBS^ <> #0 do + begin + NextBS := FindBS(CurrBS + 1); + if L + (NextBS - CurrBS) + 1 > SizeOf(Buffer) then Exit; + lstrcpyn(Buffer + L, CurrBS, (NextBS - CurrBS) + 1); + + Handle := FindFirstFile(Buffer, FindData); + if (Handle = -1) then Exit; + FindClose(Handle); + + if L + 1 + _strlen(FindData.cFileName) + 1 > SizeOf(Buffer) then Exit; + Buffer[L] := '\'; + lstrcpyn(Buffer + L + 1, FindData.cFileName, Sizeof(Buffer) - L - 1); + Inc(L, _strlen(FindData.cFileName) + 1); + CurrBS := NextBS; + end; + lstrcpyn(AFileName, Buffer, BufSize); + end; +begin + GetModuleFileName(0, FileName, SizeOf(FileName)); // Get host application name + LocaleOverride[0] := #0; + if (RegOpenKeyEx(HKEY_CURRENT_USER, NewLocaleOverrideKey, 0, KEY_READ, Key) = 0) or + (RegOpenKeyEx(HKEY_LOCAL_MACHINE, NewLocaleOverrideKey, 0, KEY_READ, Key) = 0) or + (RegOpenKeyEx(HKEY_CURRENT_USER, OldLocaleOverrideKey, 0, KEY_READ, Key) = 0) then + try + Size := sizeof(LocaleOverride); + ToLongPath(FileName, sizeof(FileName)); + if RegQueryValueEx(Key, FileName, nil, nil, LocaleOverride, @Size) <> 0 then + if RegQueryValueEx(Key, '', nil, nil, LocaleOverride, @Size) <> 0 then + LocaleOverride[0] := #0; + LocaleOverride[sizeof(LocaleOverride)-1] := #0; + finally + RegCloseKey(Key); + end; + lstrcpyn(FileName, ModuleName, sizeof(FileName)); + GetLocaleInfo(GetThreadLocale, LOCALE_SABBREVLANGNAME, LocaleName, sizeof(LocaleName)); + Result := 0; + if (FileName[0] <> #0) and ((LocaleName[0] <> #0) or (LocaleOverride[0] <> #0)) then + begin + P := PChar(@FileName) + _strlen(FileName); + while (P^ <> '.') and (P <> @FileName) do Dec(P); + if P <> @FileName then + begin + Inc(P); + // First look for a locale registry override + if LocaleOverride[0] <> #0 then + begin + lstrcpyn(P, LocaleOverride, sizeof(FileName) - (P - FileName)); + Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE); + end; + if (Result = 0) and (LocaleName[0] <> #0) then + begin + // Then look for a potential language/country translation + lstrcpyn(P, LocaleName, sizeof(FileName) - (P - FileName)); + Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE); + if Result = 0 then + begin + // Finally look for a language only translation + LocaleName[2] := #0; + lstrcpyn(P, LocaleName, sizeof(FileName) - (P - FileName)); + Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE); + end; + end; + end; + end; +end; +{$ENDIF} + +procedure EnumModules(Func: TEnumModuleFunc; Data: Pointer); assembler; +begin + EnumModules(TEnumModuleFuncLW(Func), Data); +end; + +procedure EnumResourceModules(Func: TEnumModuleFunc; Data: Pointer); +begin + EnumResourceModules(TEnumModuleFuncLW(Func), Data); +end; + +procedure EnumModules(Func: TEnumModuleFuncLW; Data: Pointer); +var + CurModule: PLibModule; +begin + CurModule := LibModuleList; + while CurModule <> nil do + begin + if not Func(CurModule.Instance, Data) then Exit; + CurModule := CurModule.Next; + end; +end; + +procedure EnumResourceModules(Func: TEnumModuleFuncLW; Data: Pointer); +var + CurModule: PLibModule; +begin + CurModule := LibModuleList; + while CurModule <> nil do + begin + if not Func(DelayLoadResourceModule(CurModule), Data) then Exit; + CurModule := CurModule.Next; + end; +end; + +procedure AddModuleUnloadProc(Proc: TModuleUnloadProc); +begin + AddModuleUnloadProc(TModuleUnloadProcLW(Proc)); +end; + +procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProc); +begin + RemoveModuleUnloadProc(TModuleUnloadProcLW(Proc)); +end; + +procedure AddModuleUnloadProc(Proc: TModuleUnloadProcLW); +var + P: PModuleUnloadRec; +begin + New(P); + P.Next := ModuleUnloadList; + @P.Proc := @Proc; + ModuleUnloadList := P; +end; + +procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProcLW); +var + P, C: PModuleUnloadRec; +begin + P := ModuleUnloadList; + if (P <> nil) and (@P.Proc = @Proc) then + begin + ModuleUnloadList := ModuleUnloadList.Next; + Dispose(P); + end else + begin + C := P; + while C <> nil do + begin + if (C.Next <> nil) and (@C.Next.Proc = @Proc) then + begin + P := C.Next; + C.Next := C.Next.Next; + Dispose(P); + Break; + end; + C := C.Next; + end; + end; +end; + +procedure NotifyModuleUnload(HInstance: LongWord); +var + P: PModuleUnloadRec; +begin + P := ModuleUnloadList; + while P <> nil do + begin + try + P.Proc(HInstance); + except + // Make sure it doesn't stop notifications + end; + P := P.Next; + end; +{$IFDEF LINUX} + InvalidateModuleCache; +{$ENDIF} +end; + +procedure RegisterModule(LibModule: PLibModule); +begin + LibModule.Next := LibModuleList; + LibModuleList := LibModule; +end; + +{X- procedure UnregisterModule(LibModule: PLibModule); -renamed } +procedure UnRegisterModuleSafely( LibModule: PLibModule ); +var + CurModule: PLibModule; +begin + try + NotifyModuleUnload(LibModule.Instance); + finally + if LibModule = LibModuleList then + LibModuleList := LibModule.Next + else + begin + CurModule := LibModuleList; + while CurModule <> nil do + begin + if CurModule.Next = LibModule then + begin + CurModule.Next := LibModule.Next; + Break; + end; + CurModule := CurModule.Next; + end; + end; + end; +end; + +{X+} // "Light" version of UnRegisterModule - without using of try-except +procedure UnRegisterModuleLight( LibModule: PLibModule ); +var + P: PModuleUnloadRec; +begin + P := ModuleUnloadList; + while P <> nil do + begin + P.Proc(LibModule.Instance); + P := P.Next; + end; +end; +{X-} + +function _IntfClear(var Dest: IInterface): Pointer; +{$IFDEF PUREPASCAL} +var + P: Pointer; +begin + Result := @Dest; + if Dest <> nil then + begin + P := Pointer(Dest); + Pointer(Dest) := nil; + IInterface(P)._Release; + end; +end; +{$ELSE} +asm + MOV EDX,[EAX] + TEST EDX,EDX + JE @@1 + MOV DWORD PTR [EAX],0 + PUSH EAX + PUSH EDX + MOV EAX,[EDX] + CALL DWORD PTR [EAX] + VMTOFFSET IInterface._Release + POP EAX +@@1: +end; +{$ENDIF} + +procedure _IntfCopy(var Dest: IInterface; const Source: IInterface); +{$IFDEF PUREPASCAL} +var + P: Pointer; +begin + P := Pointer(Dest); + if Source <> nil then + Source._AddRef; + Pointer(Dest) := Pointer(Source); + if P <> nil then + IInterface(P)._Release; +end; +{$ELSE} +asm +{ + The most common case is the single assignment of a non-nil interface + to a nil interface. So we streamline that case here. After this, + we give essentially equal weight to other outcomes. + + The semantics are: The source intf must be addrefed *before* it + is assigned to the destination. The old intf must be released + after the new intf is addrefed to support self assignment (I := I). + Either intf can be nil. The first requirement is really to make an + error case function a little better, and to improve the behaviour + of multithreaded applications - if the addref throws an exception, + you don't want the interface to have been assigned here, and if the + assignment is made to a global and another thread references it, + again you don't want the intf to be available until the reference + count is bumped. +} + TEST EDX,EDX // is source nil? + JE @@NilSource + PUSH EDX // save source + PUSH EAX // save dest + MOV EAX,[EDX] // get source vmt + PUSH EDX // source as arg + CALL DWORD PTR [EAX] + VMTOFFSET IInterface._AddRef + POP EAX // retrieve dest + MOV ECX, [EAX] // get current value + POP [EAX] // set dest in place + TEST ECX, ECX // is current value nil? + JNE @@ReleaseDest // no, release it + RET // most common case, we return here +@@ReleaseDest: + MOV EAX,[ECX] // get current value vmt + PUSH ECX // current value as arg + CALL DWORD PTR [EAX] + VMTOFFSET IInterface._Release + RET + +{ Now we're into the less common cases. } +@@NilSource: + MOV ECX, [EAX] // get current value + TEST ECX, ECX // is it nil? + MOV [EAX], EDX // store in dest (which is nil) + JE @@Done + MOV EAX, [ECX] // get current vmt + PUSH ECX // current value as arg + CALL [EAX].vmtRelease.Pointer +@@Done: +end; +{$ENDIF} + +procedure _IntfCast(var Dest: IInterface; const Source: IInterface; const IID: TGUID); +{$IFDEF PUREPASCAL} +// PIC: EBX must be correct before calling QueryInterface +begin + if Source = nil then + Dest := nil + else if Source.QueryInterface(IID, Dest) <> 0 then + Error(reIntfCastError); +end; +{$ELSE} +asm + TEST EDX,EDX + JE _IntfClear + PUSH EAX + PUSH ECX + PUSH EDX + MOV ECX,[EAX] + TEST ECX,ECX + JE @@1 + PUSH ECX + MOV EAX,[ECX] + CALL DWORD PTR [EAX] + VMTOFFSET IInterface._Release + MOV EDX,[ESP] +@@1: MOV EAX,[EDX] + CALL DWORD PTR [EAX] + VMTOFFSET IInterface.QueryInterface + TEST EAX,EAX + JE @@2 + MOV AL,reIntfCastError + JMP Error +@@2: +end; +{$ENDIF} + +procedure _IntfAddRef(const Dest: IInterface); +begin + if Dest <> nil then Dest._AddRef; +end; + +procedure TInterfacedObject.AfterConstruction; +begin +// Release the constructor's implicit refcount + InterlockedDecrement(FRefCount); +end; + +procedure TInterfacedObject.BeforeDestruction; +begin + if RefCount <> 0 then + Error(reInvalidPtr); +end; + +// Set an implicit refcount so that refcounting +// during construction won't destroy the object. +class function TInterfacedObject.NewInstance: TObject; +begin + Result := inherited NewInstance; + TInterfacedObject(Result).FRefCount := 1; +end; + +function TInterfacedObject.QueryInterface(const IID: TGUID; out Obj): HResult; +begin + if GetInterface(IID, Obj) then + Result := 0 + else + Result := E_NOINTERFACE; +end; + +function TInterfacedObject._AddRef: Integer; +begin + Result := InterlockedIncrement(FRefCount); +end; + +function TInterfacedObject._Release: Integer; +begin + Result := InterlockedDecrement(FRefCount); + if Result = 0 then + Destroy; +end; + +{ TAggregatedObject } + +constructor TAggregatedObject.Create(const Controller: IInterface); +begin + // weak reference to controller - don't keep it alive + FController := Pointer(Controller); +end; + +function TAggregatedObject.GetController: IInterface; +begin + Result := IInterface(FController); +end; + +function TAggregatedObject.QueryInterface(const IID: TGUID; out Obj): HResult; +begin + Result := IInterface(FController).QueryInterface(IID, Obj); +end; + +function TAggregatedObject._AddRef: Integer; +begin + Result := IInterface(FController)._AddRef; +end; + +function TAggregatedObject._Release: Integer; stdcall; +begin + Result := IInterface(FController)._Release; +end; + +{ TContainedObject } + +function TContainedObject.QueryInterface(const IID: TGUID; out Obj): HResult; +begin + if GetInterface(IID, Obj) then + Result := S_OK + else + Result := E_NOINTERFACE; +end; + + +function _CheckAutoResult(ResultCode: HResult): HResult; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + if ResultCode < 0 then + begin + if Assigned(SafeCallErrorProc) then + SafeCallErrorProc(ResultCode, Pointer(-1)); // loses error address + Error(reSafeCallError); + end; + Result := ResultCode; +end; +{$ELSE} +asm + TEST EAX,EAX + JNS @@2 + MOV ECX,SafeCallErrorProc + TEST ECX,ECX + JE @@1 + MOV EDX,[ESP] + CALL ECX +@@1: MOV AL,reSafeCallError + JMP Error +@@2: +end; +{$IFEND} + +function CompToDouble(Value: Comp): Double; cdecl; +begin + Result := Value; +end; + +procedure DoubleToComp(Value: Double; var Result: Comp); cdecl; +begin + Result := Value; +end; + +function CompToCurrency(Value: Comp): Currency; cdecl; +begin + Result := Value; +end; + +procedure CurrencyToComp(Value: Currency; var Result: Comp); cdecl; +begin + Result := Value; +end; + +function GetMemory(Size: Integer): Pointer; cdecl; +begin + Result := MemoryManager.GetMem(Size); +end; + +function FreeMemory(P: Pointer): Integer; cdecl; +begin + if P = nil then + Result := 0 + else + Result := MemoryManager.FreeMem(P); +end; + +function ReallocMemory(P: Pointer; Size: Integer): Pointer; cdecl; +begin + Result := MemoryManager.ReallocMem(P, Size); +end; + +procedure SetLineBreakStyle(var T: Text; Style: TTextLineBreakStyle); +begin + if TTextRec(T).Mode = fmClosed then + TTextRec(T).Flags := TTextRec(T).Flags or (tfCRLF * Byte(Style)) + else + SetInOutRes(107); // can't change mode of open file +end; + +// UnicodeToUTF8(3): +// Scans the source data to find the null terminator, up to MaxBytes +// Dest must have MaxBytes available in Dest. + +function UnicodeToUtf8(Dest: PChar; Source: PWideChar; MaxBytes: Integer): Integer; +var + len: Cardinal; +begin + len := 0; + if Source <> nil then + while Source[len] <> #0 do + Inc(len); + Result := UnicodeToUtf8(Dest, MaxBytes, Source, len); +end; + +// UnicodeToUtf8(4): +// MaxDestBytes includes the null terminator (last char in the buffer will be set to null) +// Function result includes the null terminator. +// Nulls in the source data are not considered terminators - SourceChars must be accurate + +function UnicodeToUtf8(Dest: PChar; MaxDestBytes: Cardinal; Source: PWideChar; SourceChars: Cardinal): Cardinal; +var + i, count: Cardinal; + c: Cardinal; +begin + Result := 0; + if Source = nil then Exit; + count := 0; + i := 0; + if Dest <> nil then + begin + while (i < SourceChars) and (count < MaxDestBytes) do + begin + c := Cardinal(Source[i]); + Inc(i); + if c <= $7F then + begin + Dest[count] := Char(c); + Inc(count); + end + else if c > $7FF then + begin + if count + 3 > MaxDestBytes then + break; + Dest[count] := Char($E0 or (c shr 12)); + Dest[count+1] := Char($80 or ((c shr 6) and $3F)); + Dest[count+2] := Char($80 or (c and $3F)); + Inc(count,3); + end + else // $7F < Source[i] <= $7FF + begin + if count + 2 > MaxDestBytes then + break; + Dest[count] := Char($C0 or (c shr 6)); + Dest[count+1] := Char($80 or (c and $3F)); + Inc(count,2); + end; + end; + if count >= MaxDestBytes then count := MaxDestBytes-1; + Dest[count] := #0; + end + else + begin + while i < SourceChars do + begin + c := Integer(Source[i]); + Inc(i); + if c > $7F then + begin + if c > $7FF then + Inc(count); + Inc(count); + end; + Inc(count); + end; + end; + Result := count+1; // convert zero based index to byte count +end; + +function Utf8ToUnicode(Dest: PWideChar; Source: PChar; MaxChars: Integer): Integer; +var + len: Cardinal; +begin + len := 0; + if Source <> nil then + while Source[len] <> #0 do + Inc(len); + Result := Utf8ToUnicode(Dest, MaxChars, Source, len); +end; + +function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: Cardinal; Source: PChar; SourceBytes: Cardinal): Cardinal; +var + i, count: Cardinal; + c: Byte; + wc: Cardinal; +begin + if Source = nil then + begin + Result := 0; + Exit; + end; + Result := Cardinal(-1); + count := 0; + i := 0; + if Dest <> nil then + begin + while (i < SourceBytes) and (count < MaxDestChars) do + begin + wc := Cardinal(Source[i]); + Inc(i); + if (wc and $80) <> 0 then + begin + wc := wc and $3F; + if i > SourceBytes then Exit; // incomplete multibyte char + if (wc and $20) <> 0 then + begin + c := Byte(Source[i]); + Inc(i); + if (c and $C0) <> $80 then Exit; // malformed trail byte or out of range char + if i > SourceBytes then Exit; // incomplete multibyte char + wc := (wc shl 6) or (c and $3F); + end; + c := Byte(Source[i]); + Inc(i); + if (c and $C0) <> $80 then Exit; // malformed trail byte + + Dest[count] := WideChar((wc shl 6) or (c and $3F)); + end + else + Dest[count] := WideChar(wc); + Inc(count); + end; + if count >= MaxDestChars then count := MaxDestChars-1; + Dest[count] := #0; + end + else + begin + while (i <= SourceBytes) do + begin + c := Byte(Source[i]); + Inc(i); + if (c and $80) <> 0 then + begin + if (c and $F0) = $F0 then Exit; // too many bytes for UCS2 + if (c and $40) = 0 then Exit; // malformed lead byte + if i > SourceBytes then Exit; // incomplete multibyte char + + if (Byte(Source[i]) and $C0) <> $80 then Exit; // malformed trail byte + Inc(i); + if i > SourceBytes then Exit; // incomplete multibyte char + if ((c and $20) <> 0) and ((Byte(Source[i]) and $C0) <> $80) then Exit; // malformed trail byte + Inc(i); + end; + Inc(count); + end; + end; + Result := count+1; +end; + +function Utf8Encode(const WS: WideString): UTF8String; +var + L: Integer; + Temp: UTF8String; +begin + Result := ''; + if WS = '' then Exit; + SetLength(Temp, Length(WS) * 3); // SetLength includes space for null terminator + + L := UnicodeToUtf8(PChar(Temp), Length(Temp)+1, PWideChar(WS), Length(WS)); + if L > 0 then + SetLength(Temp, L-1) + else + Temp := ''; + Result := Temp; +end; + +function Utf8Decode(const S: UTF8String): WideString; +var + L: Integer; + Temp: WideString; +begin + Result := ''; + if S = '' then Exit; + SetLength(Temp, Length(S)); + + L := Utf8ToUnicode(PWideChar(Temp), Length(Temp)+1, PChar(S), Length(S)); + if L > 0 then + SetLength(Temp, L-1) + else + Temp := ''; + Result := Temp; +end; + +function AnsiToUtf8(const S: string): UTF8String; +begin + Result := Utf8Encode(S); +end; + +function Utf8ToAnsi(const S: UTF8String): string; +begin + Result := Utf8Decode(S); +end; + +{$IFDEF LINUX} + +function GetCPUType: Integer; +asm + PUSH EBX + // this code assumes ESP is 4 byte aligned + // test for 80386: see if bit #18 of EFLAGS (Alignment fault) can be toggled + PUSHF + POP EAX + MOV ECX, EAX + XOR EAX, $40000 // flip AC bit in EFLAGS + PUSH EAX + POPF + PUSHF + POP EAX + XOR EAX, ECX // zero = 80386 CPU (can't toggle AC bit) + MOV EAX, CPUi386 + JZ @@Exit + PUSH ECX + POPF // restore original flags before next test + + // test for 80486: see if bit #21 of EFLAGS (CPUID supported) can be toggled + MOV EAX, ECX // get original EFLAGS + XOR EAX, $200000 // flip CPUID bit in EFLAGS + PUSH EAX + POPF + PUSHF + POP EAX + XOR EAX, ECX // zero = 80486 (can't toggle EFLAGS bit #21) + MOV EAX, CPUi486 + JZ @@Exit + + // Use CPUID instruction to get CPU family + XOR EAX, EAX + CPUID + CMP EAX, 1 + JL @@Exit // unknown processor response: report as 486 + XOR EAX, EAX + INC EAX // we only care about info level 1 + CPUID + AND EAX, $F00 + SHR EAX, 8 + // Test8086 values are one less than the CPU model number, for historical reasons + DEC EAX + +@@Exit: + POP EBX +end; + + +const + sResSymExport = '@Sysinit@ResSym'; + sResStrExport = '@Sysinit@ResStr'; + sResHashExport = '@Sysinit@ResHash'; + +type + TElf32Sym = record + Name: Cardinal; + Value: Pointer; + Size: Cardinal; + Info: Byte; + Other: Byte; + Section: Word; + end; + PElf32Sym = ^TElf32Sym; + + TElfSymTab = array [0..0] of TElf32Sym; + PElfSymTab = ^TElfSymTab; + + TElfWordTab = array [0..2] of Cardinal; + PElfWordTab = ^TElfWordTab; + + +{ If Name encodes a numeric identifier, return it, else return -1. } +function NameToId(Name: PChar): Longint; +var digit: Longint; +begin + if Longint(Name) and $ffff0000 = 0 then + begin + Result := Longint(Name) and $ffff; + end + else if Name^ = '#' then + begin + Result := 0; + inc (Name); + while (Ord(Name^) <> 0) do + begin + digit := Ord(Name^) - Ord('0'); + if (LongWord(digit) > 9) then + begin + Result := -1; + exit; + end; + Result := Result * 10 + digit; + inc (Name); + end; + end + else + Result := -1; +end; + + +// Return ELF hash value for NAME converted to lower case. +function ElfHashLowercase(Name: PChar): Cardinal; +var + g: Cardinal; + c: Char; +begin + Result := 0; + while name^ <> #0 do + begin + c := name^; + case c of + 'A'..'Z': Inc(c, Ord('a') - Ord('A')); + end; + Result := (Result shl 4) + Ord(c); + g := Result and $f0000000; + Result := (Result xor (g shr 24)) and not g; + Inc(name); + end; +end; + +type + PFindResourceCache = ^TFindResourceCache; + TFindResourceCache = record + ModuleHandle: HMODULE; + Version: Cardinal; + SymbolTable: PElfSymTab; + StringTable: PChar; + HashTable: PElfWordTab; + BaseAddress: Cardinal; + end; + +threadvar + FindResourceCache: TFindResourceCache; + +function GetResourceCache(ModuleHandle: HMODULE): PFindResourceCache; +var + info: TDLInfo; +begin + Result := @FindResourceCache; + if (ModuleHandle <> Result^.ModuleHandle) or (ModuleCacheVersion <> Result^.Version) then + begin + Result^.SymbolTable := dlsym(ModuleHandle, sResSymExport); + Result^.StringTable := dlsym(ModuleHandle, sResStrExport); + Result^.HashTable := dlsym(ModuleHandle, sResHashExport); + Result^.ModuleHandle := ModuleHandle; + if (dladdr(Result^.HashTable, Info) = 0) or (Info.BaseAddress = ExeBaseAddress) then + Result^.BaseAddress := 0 // if it's not in a library, assume the exe + else + Result^.BaseAddress := Cardinal(Info.BaseAddress); + Result^.Version := ModuleCacheVersion; + end; +end; + +function FindResource(ModuleHandle: HMODULE; ResourceName: PChar; ResourceType: PChar): TResourceHandle; +var + P: PFindResourceCache; + nid, tid: Longint; + ucs2_key: array [0..2] of WideChar; + key: array [0..127] of Char; + len: Integer; + pc: PChar; + ch: Char; + nbucket: Cardinal; + bucket, chain: PElfWordTab; + syndx: Cardinal; +begin + Result := 0; + if ResourceName = nil then Exit; + P := GetResourceCache(ModuleHandle); + + tid := NameToId (ResourceType); + if tid = -1 then Exit; { not supported (yet?) } + + { This code must match util-common/elfres.c } + nid := NameToId (ResourceName); + if nid = -1 then + begin + ucs2_key[0] := WideChar(2*tid+2); + ucs2_key[1] := WideChar(0); + len := UnicodeToUtf8 (key, ucs2_key, SizeOf (key)); + pc := key+len; + while Ord(ResourceName^) <> 0 do + begin + ch := ResourceName^; + if Ord(ch) > 127 then exit; { insist on 7bit ASCII for now } + if ('A' <= ch) and (ch <= 'Z') then Inc(ch, Ord('a') - Ord('A')); + pc^ := ch; + inc (pc); + if pc = key + SizeOf(key) then exit; + inc (ResourceName); + end; + pc^ := Char(0); + end + else + begin + ucs2_key[0] := WideChar(2*tid+1); + ucs2_key[1] := WideChar(nid); + ucs2_key[2] := WideChar(0); + UnicodeToUtf8 (key, ucs2_key, SizeOf (key)); + end; + + with P^ do + begin + nbucket := HashTable[0]; + // nsym := HashTable[1]; + bucket := @HashTable[2]; + chain := @HashTable[2+nbucket]; + + syndx := bucket[ElfHashLowercase(key) mod nbucket]; + while (syndx <> 0) + and (strcasecmp(key, @StringTable[SymbolTable[syndx].Name]) <> 0) do + syndx := chain[syndx]; + + if syndx = 0 then + Result := 0 + else + Result := TResourceHandle(@SymbolTable[syndx]); + end; +end; + +function LoadResource(ModuleHandle: HMODULE; ResHandle: TResourceHandle): HGLOBAL; +var + P: PFindResourceCache; +begin + if ResHandle <> 0 then + begin + P := GetResourceCache(ModuleHandle); + Result := HGLOBAL(PElf32Sym(ResHandle)^.Value); + Inc (Cardinal(Result), P^.BaseAddress); + end + else + Result := 0; +end; + +function SizeofResource(ModuleHandle: HMODULE; ResHandle: TResourceHandle): Integer; +begin + if ResHandle <> 0 then + Result := PElf32Sym(ResHandle)^.Size + else + Result := 0; +end; + +function LockResource(ResData: HGLOBAL): Pointer; +begin + Result := Pointer(ResData); +end; + +function UnlockResource(ResData: HGLOBAL): LongBool; +begin + Result := False; +end; + +function FreeResource(ResData: HGLOBAL): LongBool; +begin + Result := True; +end; +{$ENDIF} + +{ ResString support function } + +{$IFDEF MSWINDOWS} +function LoadResString(ResStringRec: PResStringRec): string; +var + Buffer: array [0..1023] of char; +begin + if ResStringRec = nil then Exit; + if ResStringRec.Identifier < 64*1024 then + SetString(Result, Buffer, + LoadString(FindResourceHInstance(ResStringRec.Module^), + ResStringRec.Identifier, Buffer, SizeOf(Buffer))) + else + Result := PChar(ResStringRec.Identifier); +end; +{$ENDIF} +{$IFDEF LINUX} + +const + ResStringTableLen = 16; + +type + ResStringTable = array [0..ResStringTableLen-1] of LongWord; + +function LoadResString(ResStringRec: PResStringRec): string; +var + Handle: TResourceHandle; + Tab: ^ResStringTable; + ResMod: HMODULE; +begin + if ResStringRec = nil then Exit; + ResMod := FindResourceHInstance(ResStringRec^.Module^); + Handle := FindResource(ResMod, + PChar(ResStringRec^.Identifier div ResStringTableLen), + PChar(6)); // RT_STRING + Tab := Pointer(LoadResource(ResMod, Handle)); + if Tab = nil then + Result := '' + else + Result := PChar (Tab) + Tab[ResStringRec^.Identifier mod ResStringTableLen]; +end; + +procedure DbgUnlockX; +begin + if Assigned(DbgUnlockXProc) then + DbgUnlockXProc; +end; + +{ The Win32 program loader sets up the first 64k of process address space + with no read or write access, to help detect use of invalid pointers + (whose integer value is 0..64k). Linux doesn't do this. + + Parts of the Delphi RTL and IDE design environment + rely on the notion that pointer values in the [0..64k] range are + invalid pointers. To accomodate this in Linux, we reserve the range + at startup. If the range is already allocated, we keep going anyway. } + +var + ZeroPageReserved: Boolean = False; + +procedure ReserveZeroPage; +const + PROT_NONE = 0; + MAP_PRIVATE = $02; + MAP_FIXED = $10; + MAP_ANONYMOUS = $20; +var + P: Pointer; +begin + if IsLibrary then Exit; // page reserve is app's job, not .so's + + if not ZeroPageReserved then + begin + P := mmap(nil, High(Word), PROT_NONE, + MAP_ANONYMOUS or MAP_PRIVATE or MAP_FIXED, 0, 0); + ZeroPageReserved := P = nil; + if (Integer(P) <> -1) and (P <> nil) then // we didn't get it + munmap(P, High(Word)); + end; +end; + +procedure ReleaseZeroPage; +begin + if ZeroPageReserved then + begin + munmap(nil, High(Word) - 4096); + ZeroPageReserved := False; + end; +end; +{$ENDIF} + +function PUCS4Chars(const S: UCS4String): PUCS4Char; +const + Null: UCS4Char = 0; + PNull: PUCS4Char = @Null; +begin + if Length(S) > 0 then + Result := @S[0] + else + Result := PNull; +end; + +function WideStringToUCS4String(const S: WideString): UCS4String; +var + I: Integer; +begin + SetLength(Result, Length(S) + 1); + for I := 0 to Length(S) - 1 do + Result[I] := UCS4Char(S[I + 1]); + Result[Length(S)] := 0; +end; + +function UCS4StringToWidestring(const S: UCS4String): WideString; +var + I: Integer; +begin + SetLength(Result, Length(S)); + for I := 0 to Length(S)-1 do + Result[I+1] := WideChar(S[I]); + Result[Length(S)] := #0; +end; + +function StringOfChar(ch: AnsiChar; count: Integer): AnsiString; overload; +asm + { -> AL c } + { EDX count } + { ECX result } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + MOV EAX,ECX + CALL _LStrClr + + TEST ESI,ESI + JLE @@exit + + MOV EAX,ESI + CALL _NewAnsiString + + MOV [EDI],EAX + + MOV EDX,ESI + MOV CL,BL + + CALL _FillChar + +@@exit: + POP EDI + POP ESI + POP EBX + +end; + +function StringOfChar(Ch: WideChar; Count: Integer): WideString; overload; +var + P: PWideChar; +begin + _WStrFromPWCharLen(Result, nil, Count); + P := Pointer(Result); + while Count > 0 do + begin + Dec(Count); + P[Count] := Ch; + end; +end; + +var SaveCmdShow : Integer = -1; +function CmdShow: Integer; +var + SI: TStartupInfo; +begin + if SaveCmdShow < 0 then + begin + SaveCmdShow := 10; { SW_SHOWDEFAULT } + GetStartupInfo(SI); + if SI.dwFlags and 1 <> 0 then { STARTF_USESHOWWINDOW } + SaveCmdShow := SI.wShowWindow; + end; + Result := SaveCmdShow; +end; + +{X} // convert var CmdLine : PChar to a function: +{X} function CmdLine : PChar; +{X} begin +{X} Result := GetCommandLine; +{X} end; + +initialization + + {$IFDEF MSWINDOWS} + {$IFDEF USE_PROCESS_HEAP} + HeapHandle := GetProcessHeap; + {$ELSE} + HeapHandle := HeapCreate( 0, 0, 0 ); + {$ENDIF} + {$ENDIF} + + {$IFDEF MSWINDOWS} + //{X (initialized statically} FileMode := 2; + {$ELSE} + FileMode := 2; + {$ENDIF} + +{$IFDEF LINUX} + FileAccessRights := S_IRUSR or S_IWUSR or S_IRGRP or S_IWGRP or S_IROTH or S_IWOTH; + Test8086 := GetCPUType; + IsConsole := True; + FindResourceCache.ModuleHandle := LongWord(-1); + ReserveZeroPage; +{$ELSE} + //{X (initialized statically} Test8086 := 2; +{$ENDIF} + + DispCallByIDProc := @_DispCallByIDError; + +{$IFDEF MSWINDOWS} + //{X} if _isNECWindows then _FpuMaskInit; +{$ENDIF} + //{X} _FpuInit(); + + TTextRec(Input).Mode := fmClosed; + TTextRec(Output).Mode := fmClosed; + TTextRec(ErrOutput).Mode := fmClosed; + InitVariantManager; + +{$IFDEF MSWINDOWS} +{X- CmdLine := GetCommandLine; converted to a function } +{X- CmdShow := GetCmdShow; converted to a function } +{$ENDIF} + MainThreadID := GetCurrentThreadID; + +{$IFDEF LINUX} + // Ensure DbgUnlockX is linked in, calling it now does nothing + DbgUnlockX; +{$ENDIF} + +finalization + {X+} + {X} CloseInputOutput; + {X- + Close(Input); + Close(Output); + Close(ErrOutput); + X+} +{$IFDEF LINUX} + ReleaseZeroPage; +{$ENDIF} +{$IFDEF MSWINDOWS} +{X UninitAllocator; - replaced with call to UninitMemoryManager handler. } + UninitMemoryManager; +{$ENDIF} +end. + diff --git a/System/D2006beta/Variants.pas b/System/D2006beta/Variants.pas new file mode 100644 index 0000000..727c59d --- /dev/null +++ b/System/D2006beta/Variants.pas @@ -0,0 +1,12 @@ +unit Variants; +{* Fake variants.pas unit for Delphi6 / Delphi7. Place it in a + directory with your KOL/MCK (or other non-VCL) project, and + this will save about 70K of code in the executable. + Certainly, do it so, if you actually do not use Delphi Variant + type in the application. + NEVER REPLACE Variants.pas provided by Borland! + (C) by Kladov Vladimir, 2003 } + +interface +implementation +end. diff --git a/System/D2006beta/getmem.inc b/System/D2006beta/getmem.inc new file mode 100644 index 0000000..f9b4f67 --- /dev/null +++ b/System/D2006beta/getmem.inc @@ -0,0 +1,1541 @@ +{ *********************************************************************** } +{ } +{ Delphi Runtime Library } +{ } +{ Copyright (c) 1996,2001 Borland Software Corporation } +{ } +{ *********************************************************************** } + +// Three layers: +// - Address space administration +// - Committed space administration +// - Suballocator +// +// Helper module: administrating block descriptors +// + + +// +// Operating system interface +// +const + LMEM_FIXED = 0; + LMEM_ZEROINIT = $40; + + MEM_COMMIT = $1000; + MEM_RESERVE = $2000; + MEM_DECOMMIT = $4000; + MEM_RELEASE = $8000; + + PAGE_NOACCESS = 1; + PAGE_READWRITE = 4; + +type + DWORD = Integer; + BOOL = LongBool; + + TRTLCriticalSection = packed record + DebugInfo: Pointer; + LockCount: Longint; + RecursionCount: Longint; + OwningThread: Integer; + LockSemaphore: Integer; + Reserved: DWORD; + end; + +{function LocalAlloc(flags, size: Integer): Pointer; stdcall; + external kernel name 'LocalAlloc'; +function LocalFree(addr: Pointer): Pointer; stdcall; + external kernel name 'LocalFree';} + +function VirtualAlloc(lpAddress: Pointer; + dwSize, flAllocationType, flProtect: DWORD): Pointer; stdcall; + external kernel name 'VirtualAlloc'; +function VirtualFree(lpAddress: Pointer; dwSize, dwFreeType: DWORD): BOOL; stdcall; + external kernel name 'VirtualFree'; + +procedure InitializeCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall; + external kernel name 'InitializeCriticalSection'; +procedure EnterCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall; + external kernel name 'EnterCriticalSection'; +procedure LeaveCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall; + external kernel name 'LeaveCriticalSection'; +procedure DeleteCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall; + external kernel name 'DeleteCriticalSection'; + +// Common Data structure: + +type + TBlock = packed record + addr: PChar; + size: Integer; + end; + +// Heap error codes + +const + cHeapOk = 0; // everything's fine + cReleaseErr = 1; // operating system returned an error when we released + cDecommitErr = 2; // operating system returned an error when we decommited + cBadCommittedList = 3; // list of committed blocks looks bad + cBadFiller1 = 4; // filler block is bad + cBadFiller2 = 5; // filler block is bad + cBadFiller3 = 6; // filler block is bad + cBadCurAlloc = 7; // current allocation zone is bad + cCantInit = 8; // couldn't initialize + cBadUsedBlock = 9; // used block looks bad + cBadPrevBlock = 10; // prev block before a used block is bad + cBadNextBlock = 11; // next block after a used block is bad + cBadFreeList = 12; // free list is bad + cBadFreeBlock = 13; // free block is bad + cBadBalance = 14; // free list doesn't correspond to blocks marked free + +var + initialized : Boolean; + heapErrorCode : Integer; + heapLock : TRTLCriticalSection; + {X} // Handler to set it to UninitAllocator, if Delphi memory manager used: + {X} UninitMemoryManager : procedure = DummyProc; + +// +// Helper module: administrating block descriptors. +// +type + PBlockDesc = ^TBlockDesc; + TBlockDesc = packed record + next: PBlockDesc; + prev: PBlockDesc; + addr: PChar; + size: Integer; + end; + +type + PBlockDescBlock = ^TBlockDescBlock; + TBlockDescBlock = packed record + next: PBlockDescBlock; + data: array [0..99] of TBlockDesc; + end; + +var + blockDescBlockList: PBlockDescBlock; + blockDescFreeList : PBlockDesc; + + +function GetBlockDesc: PBlockDesc; +// Get a block descriptor. +// Will return nil for failure. +var + bd: PBlockDesc; + bdb: PBlockDescBlock; + i: Integer; +begin + if blockDescFreeList = nil then begin + bdb := LocalAlloc(LMEM_FIXED, sizeof(bdb^)); + if bdb = nil then begin + result := nil; + exit; + end; + bdb.next := blockDescBlockList; + blockDescBlockList := bdb; + for i := low(bdb.data) to high(bdb.data) do begin + bd := @bdb.data[i]; + bd.next := blockDescFreeList; + blockDescFreeList := bd; + end; + end; + bd := blockDescFreeList; + blockDescFreeList := bd.next; + result := bd; +end; + + +procedure MakeEmpty(bd: PBlockDesc); +begin + bd.next := bd; + bd.prev := bd; +end; + + +function AddBlockAfter(prev: PBlockDesc; const b: TBlock): Boolean; +var + next, bd: PBlockDesc; +begin + bd := GetBlockDesc; + if bd = nil then + result := False + else begin + bd.addr := b.addr; + bd.size := b.size; + + next := prev.next; + bd.next := next; + bd.prev := prev; + next.prev := bd; + prev.next := bd; + + result := True; + end; +end; + + +procedure DeleteBlock(bd: PBlockDesc); +var + prev, next: PBlockDesc; +begin + prev := bd.prev; + next := bd.next; + prev.next := next; + next.prev := prev; + bd.next := blockDescFreeList; + blockDescFreeList := bd; +end; + + +function MergeBlockAfter(prev: PBlockDesc; const b: TBlock) : TBlock; +var + bd, bdNext: PBlockDesc; +begin + bd := prev.next; + result := b; + repeat + bdNext := bd.next; + if bd.addr + bd.size = result.addr then begin + DeleteBlock(bd); + result.addr := bd.addr; + inc(result.size, bd.size); + end else if result.addr + result.size = bd.addr then begin + DeleteBlock(bd); + inc(result.size, bd.size); + end; + bd := bdNext; + until bd = prev; + if not AddBlockAfter(prev, result) then + result.addr := nil; +end; + + +function RemoveBlock(bd: PBlockDesc; const b: TBlock): Boolean; +var + n: TBlock; + start: PBlockDesc; +begin + start := bd; + repeat + if (bd.addr <= b.addr) and (bd.addr + bd.size >= b.addr + b.size) then begin + if bd.addr = b.addr then begin + Inc(bd.addr, b.size); + Dec(bd.size, b.size); + if bd.size = 0 then + DeleteBlock(bd); + end else if bd.addr + bd.size = b.addr + b.size then + Dec(bd.size, b.size) + else begin + n.addr := b.addr + b.size; + n.size := bd.addr + bd.size - n.addr; + bd.size := b.addr - bd.addr; + if not AddBlockAfter(bd, n) then begin + result := False; + exit; + end; + end; + result := True; + exit; + end; + bd := bd.next; + until bd = start; + result := False; +end; + + + +// +// Address space administration: +// + +const + cSpaceAlign = 64*1024; + cSpaceMin = 1024*1024; + cPageAlign = 4*1024; + +var + spaceRoot: TBlockDesc; + + +function GetSpace(minSize: Integer): TBlock; +// Get at least minSize bytes address space. +// Success: returns a block, possibly much bigger than requested. +// Will not fail - will raise an exception or terminate program. +begin + if minSize < cSpaceMin then + minSize := cSpaceMin + else + minSize := (minSize + (cSpaceAlign-1)) and not (cSpaceAlign-1); + + result.size := minSize; + result.addr := VirtualAlloc(nil, minSize, MEM_RESERVE, PAGE_NOACCESS); + if result.addr = nil then + exit; + + if not AddBlockAfter(@spaceRoot, result) then begin + VirtualFree(result.addr, 0, MEM_RELEASE); + result.addr := nil; + exit; + end; +end; + + +function GetSpaceAt(addr: PChar; minSize: Integer): TBlock; +// Get at least minSize bytes address space at addr. +// Return values as above. +// Failure: returns block with addr = nil. +begin + result.size := cSpaceMin; + result.addr := VirtualAlloc(addr, cSpaceMin, MEM_RESERVE, PAGE_READWRITE); + if result.addr = nil then begin + minSize := (minSize + (cSpaceAlign-1)) and not (cSpaceAlign-1); + result.size := minSize; + result.addr := VirtualAlloc(addr, minSize, MEM_RESERVE, PAGE_READWRITE); + end; + if result.addr <> nil then begin + if not AddBlockAfter(@spaceRoot, result) then begin + VirtualFree(result.addr, 0, MEM_RELEASE); + result.addr := nil; + end; + end; +end; + + +function FreeSpace(addr: Pointer; maxSize: Integer): TBlock; +// Free at most maxSize bytes of address space at addr. +// Returns the block that was actually freed. +var + bd, bdNext: PBlockDesc; + minAddr, maxAddr, startAddr, endAddr: PChar; +begin + minAddr := PChar($FFFFFFFF); + maxAddr := nil; + startAddr := addr; + endAddr := startAddr + maxSize; + bd := spaceRoot.next; + while bd <> @spaceRoot do begin + bdNext := bd.next; + if (bd.addr >= startAddr) and (bd.addr + bd.size <= endAddr) then begin + if minAddr > bd.addr then + minAddr := bd.addr; + if maxAddr < bd.addr + bd.size then + maxAddr := bd.addr + bd.size; + if not VirtualFree(bd.addr, 0, MEM_RELEASE) then + heapErrorCode := cReleaseErr; + DeleteBlock(bd); + end; + bd := bdNext; + end; + result.addr := nil; + if maxAddr <> nil then begin + result.addr := minAddr; + result.size := maxAddr - minAddr; + end; +end; + + +function Commit(addr: Pointer; minSize: Integer): TBlock; +// Commits memory. +// Returns the block that was actually committed. +// Will return a block with addr = nil on failure. +var + bd: PBlockDesc; + loAddr, hiAddr, startAddr, endAddr: PChar; +begin + startAddr := PChar(Integer(addr) and not (cPageAlign-1)); + endAddr := PChar(((Integer(addr) + minSize) + (cPageAlign-1)) and not (cPageAlign-1)); + result.addr := startAddr; + result.size := endAddr - startAddr; + bd := spaceRoot.next; + while bd <> @spaceRoot do begin + // Commit the intersection of the block described by bd and [startAddr..endAddr) + loAddr := bd.addr; + hiAddr := loAddr + bd.size; + if loAddr < startAddr then + loAddr := startAddr; + if hiAddr > endAddr then + hiAddr := endAddr; + if loAddr < hiAddr then begin + if VirtualAlloc(loAddr, hiAddr - loAddr, MEM_COMMIT, PAGE_READWRITE) = nil then begin + result.addr := nil; + exit; + end; + end; + bd := bd.next; + end; +end; + + +function Decommit(addr: Pointer; maxSize: Integer): TBlock; +// Decommits address space. +// Returns the block that was actually decommitted. +var + bd: PBlockDesc; + loAddr, hiAddr, startAddr, endAddr: PChar; +begin + startAddr := PChar((Integer(addr) + + (cPageAlign-1)) and not (cPageAlign-1)); + endAddr := PChar((Integer(addr) + maxSize) and not (cPageAlign-1)); + result.addr := startAddr; + result.size := endAddr - startAddr; + bd := spaceRoot.next; + while bd <> @spaceRoot do begin + // Decommit the intersection of the block described by bd and [startAddr..endAddr) + loAddr := bd.addr; + hiAddr := loAddr + bd.size; + if loAddr < startAddr then + loAddr := startAddr; + if hiAddr > endAddr then + hiAddr := endAddr; + if loAddr < hiAddr then begin + if not VirtualFree(loAddr, hiAddr - loAddr, MEM_DECOMMIT) then + heapErrorCode := cDecommitErr; + end; + bd := bd.next; + end; +end; + + +// +// Committed space administration +// +const + cCommitAlign = 16*1024; + +var + decommittedRoot: TBlockDesc; + + +function GetCommitted(minSize: Integer): TBlock; +// Get a block of committed memory. +// Returns a committed memory block, possibly much bigger than requested. +// Will return a block with a nil addr on failure. +var + bd: PBlockDesc; +begin + minSize := (minSize + (cCommitAlign-1)) and not (cCommitAlign-1); + repeat + bd := decommittedRoot.next; + while bd <> @decommittedRoot do begin + if bd.size >= minSize then begin + result := Commit(bd.addr, minSize); + if result.addr = nil then + exit; + Inc(bd.addr, result.size); + Dec(bd.size, result.size); + if bd.size = 0 then + DeleteBlock(bd); + exit; + end; + bd := bd.next; + end; + result := GetSpace(minSize); + if result.addr = nil then + exit; + if MergeBlockAfter(@decommittedRoot, result).addr = nil then begin + FreeSpace(result.addr, result.size); + result.addr := nil; + exit; + end; + until False; +end; + + +function GetCommittedAt(addr: PChar; minSize: Integer): TBlock; +// Get at least minSize bytes committed space at addr. +// Success: returns a block, possibly much bigger than requested. +// Failure: returns a block with addr = nil. +var + bd: PBlockDesc; + b: TBlock; +begin + minSize := (minSize + (cCommitAlign-1)) and not (cCommitAlign-1); + repeat + + bd := decommittedRoot.next; + while (bd <> @decommittedRoot) and (bd.addr <> addr) do + bd := bd.next; + + if bd.addr = addr then begin + if bd.size >= minSize then + break; + b := GetSpaceAt(bd.addr + bd.size, minSize - bd.size); + if b.addr <> nil then begin + if MergeBlockAfter(@decommittedRoot, b).addr <> nil then + continue + else begin + FreeSpace(b.addr, b.size); + result.addr := nil; + exit; + end; + end; + end; + + b := GetSpaceAt(addr, minSize); + if b.addr = nil then + break; + + if MergeBlockAfter(@decommittedRoot, b).addr = nil then begin + FreeSpace(b.addr, b.size); + result.addr := nil; + exit; + end; + until false; + + if (bd.addr = addr) and (bd.size >= minSize) then begin + result := Commit(bd.addr, minSize); + if result.addr = nil then + exit; + Inc(bd.addr, result.size); + Dec(bd.size, result.size); + if bd.size = 0 then + DeleteBlock(bd); + end else + result.addr := nil; +end; + + +function FreeCommitted(addr: PChar; maxSize: Integer): TBlock; +// Free at most maxSize bytes of address space at addr. +// Returns the block that was actually freed. +var + startAddr, endAddr: PChar; + b: TBlock; +begin + startAddr := PChar(Integer(addr + (cCommitAlign-1)) and not (cCommitAlign-1)); + endAddr := PChar(Integer(addr + maxSize) and not (cCommitAlign-1)); + if endAddr > startAddr then begin + result := Decommit(startAddr, endAddr - startAddr); + b := MergeBlockAfter(@decommittedRoot, result); + if b.addr <> nil then + b := FreeSpace(b.addr, b.size); + if b.addr <> nil then + RemoveBlock(@decommittedRoot, b); + end else + result.addr := nil; +end; + + +// +// Suballocator (what the user program actually calls) +// + +type + PFree = ^TFree; + TFree = packed record + prev: PFree; + next: PFree; + size: Integer; + end; + PUsed = ^TUsed; + TUsed = packed record + sizeFlags: Integer; + end; + +const + cAlign = 4; + cThisUsedFlag = 2; + cPrevFreeFlag = 1; + cFillerFlag = Integer($80000000); + cFlags = cThisUsedFlag or cPrevFreeFlag or cFillerFlag; + cSmallSize = 4*1024; + cDecommitMin = 15*1024; + +type + TSmallTab = array [sizeof(TFree) div cAlign .. cSmallSize div cAlign] of PFree; + +VAR + avail : TFree; + rover : PFree; + remBytes : Integer; + curAlloc : PChar; + smallTab : ^TSmallTab; + committedRoot: TBlockDesc; + + +{X} // UninitAllocator - placed before InitAllocator to refer to. +procedure UninitAllocator; +// Shutdown. +var + bdb: PBlockDescBlock; + bd : PBlockDesc; +begin + if initialized then begin + try + if IsMultiThread then EnterCriticalSection(heapLock); + + initialized := False; + + LocalFree(smallTab); + smallTab := nil; + + bd := spaceRoot.next; + while bd <> @spaceRoot do begin + VirtualFree(bd.addr, 0, MEM_RELEASE); + bd := bd.next; + end; + + MakeEmpty(@spaceRoot); + MakeEmpty(@decommittedRoot); + MakeEmpty(@committedRoot); + + bdb := blockDescBlockList; + while bdb <> nil do begin + blockDescBlockList := bdb^.next; + LocalFree(bdb); + bdb := blockDescBlockList; + end; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + DeleteCriticalSection(heapLock); + end; + end; +end; + +function InitAllocator: Boolean; +// Initialize. No other calls legal before that. +var + i: Integer; + a: PFree; +begin + try + InitializeCriticalSection(heapLock); + if IsMultiThread then EnterCriticalSection(heapLock); + + MakeEmpty(@spaceRoot); + MakeEmpty(@decommittedRoot); + MakeEmpty(@committedRoot); + + smallTab := LocalAlloc(LMEM_FIXED, sizeof(smallTab^)); + if smallTab <> nil then begin + for i:= low(smallTab^) to high(smallTab^) do + smallTab[i] := nil; + + a := @avail; + a.next := a; + a.prev := a; + rover := a; + + initialized := True; + {X} // set here handler UninitMemoryManager to UninitAllocator } + {X} UninitMemoryManager := UninitAllocator; + end; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; + result := initialized; +end; + + + +procedure DeleteFree(f: PFree); +var + n, p: PFree; + size: Integer; +begin + if rover = f then + rover := f.next; + n := f.next; + size := f.size; + if size <= cSmallSize then begin + if n = f then + smallTab[size div cAlign] := nil + else begin + smallTab[size div cAlign] := n; + p := f.prev; + n.prev := p; + p.next := n; + end; + end else begin + p := f.prev; + n.prev := p; + p.next := n; + end; +end; + + +procedure InsertFree(a: Pointer; size: Integer); forward; + + +function FindCommitted(addr: PChar): PBlockDesc; +begin + result := committedRoot.next; + while result <> @committedRoot do begin + if (addr >= result.addr) and (addr < result.addr + result.size) then + exit; + result := result.next; + end; + heapErrorCode := cBadCommittedList; + result := nil; +end; + + +procedure FillBeforeGap(a: PChar; size: Integer); +var + rest: Integer; + e: PUsed; +begin + rest := size - sizeof(TUsed); + e := PUsed(a + rest); + if size >= sizeof(TFree) + sizeof(TUsed) then begin + e.sizeFlags := sizeof(TUsed) or cThisUsedFlag or cPrevFreeFlag or cFillerFlag; + InsertFree(a, rest); + end else if size >= sizeof(TUsed) then begin + PUsed(a).sizeFlags := size or (cThisUsedFlag or cFillerFlag); + e.sizeFlags := size or (cThisUsedFlag or cFillerFlag); + end; +end; + + +procedure InternalFreeMem(a: PChar); +begin + Inc(AllocMemCount); + Inc(AllocMemSize,PUsed(a-sizeof(TUsed)).sizeFlags and not cFlags - sizeof(TUsed)); + SysFreeMem(a); +end; + + +procedure FillAfterGap(a: PChar; size: Integer); +begin + if size >= sizeof(TFree) then begin + PUsed(a).sizeFlags := size or cThisUsedFlag; + InternalFreeMem(a + sizeof(TUsed)); + end else begin + if size >= sizeof(TUsed) then + PUsed(a).sizeFlags := size or (cThisUsedFlag or cFillerFlag); + Inc(a,size); + PUsed(a).sizeFlags := PUsed(a).sizeFlags and not cPrevFreeFlag; + end; +end; + + +function FillerSizeBeforeGap(a: PChar): Integer; +var + sizeFlags : Integer; + freeSize : Integer; + f : PFree; +begin + sizeFlags := PUsed(a - sizeof(TUsed)).sizeFlags; + if (sizeFlags and (cThisUsedFlag or cFillerFlag)) <> (cThisUsedFlag or cFillerFlag) then + heapErrorCode := cBadFiller1; + result := sizeFlags and not cFlags; + Dec(a, result); + if ((PUsed(a).sizeFlags xor sizeFlags) and not cPrevFreeFlag) <> 0 then + HeapErrorCode := cBadFiller2; + if (PUsed(a).sizeFlags and cPrevFreeFlag) <> 0 then begin + freeSize := PFree(a - sizeof(TFree)).size; + f := PFree(a - freeSize); + if f.size <> freeSize then + heapErrorCode := cBadFiller3; + DeleteFree(f); + Inc(result, freeSize); + end; +end; + + +function FillerSizeAfterGap(a: PChar): Integer; +var + sizeFlags: Integer; + f : PFree; +begin + result := 0; + sizeFlags := PUsed(a).sizeFlags; + if (sizeFlags and cFillerFlag) <> 0 then begin + sizeFlags := sizeFlags and not cFlags; + Inc(result,sizeFlags); + Inc(a, sizeFlags); + sizeFlags := PUsed(a).sizeFlags; + end; + if (sizeFlags and cThisUsedFlag) = 0 then begin + f := PFree(a); + DeleteFree(f); + Inc(result, f.size); + Inc(a, f.size); + PUsed(a).sizeFlags := PUsed(a).sizeFlags and not cPrevFreeFlag; + end; +end; + + +function DecommitFree(a: PChar; size: Integer): Boolean; +var + b: TBlock; + bd: PBlockDesc; +begin + Result := False; + bd := FindCommitted(a); + if bd = nil then Exit; + if bd.addr + bd.size - (a + size) <= sizeof(TFree) then + size := bd.addr + bd.size - a; + + if a - bd.addr < sizeof(TFree) then + b := FreeCommitted(bd.addr, size + (a - bd.addr)) + else + b := FreeCommitted(a + sizeof(TUsed), size - sizeof(TUsed)); + + if b.addr <> nil then + begin + FillBeforeGap(a, b.addr - a); + if bd.addr + bd.size > b.addr + b.size then + FillAfterGap(b.addr + b.size, a + size - (b.addr + b.size)); + RemoveBlock(bd,b); + result := True; + end; +end; + + +procedure InsertFree(a: Pointer; size: Integer); +var + f, n, p: PFree; +begin + f := PFree(a); + f.size := size; + PFree(PChar(f) + size - sizeof(TFree)).size := size; + if size <= cSmallSize then begin + n := smallTab[size div cAlign]; + if n = nil then begin + smallTab[size div cAlign] := f; + f.next := f; + f.prev := f; + end else begin + p := n.prev; + f.next := n; + f.prev := p; + n.prev := f; + p.next := f; + end; + end else if (size < cDecommitMin) or not DecommitFree(a, size) then begin + n := rover; + rover := f; + p := n.prev; + f.next := n; + f.prev := p; + n.prev := f; + p.next := f; + end; +end; + + +procedure FreeCurAlloc; +begin + if remBytes > 0 then begin + if remBytes < sizeof(TFree) then + heapErrorCode := cBadCurAlloc + else begin + PUsed(curAlloc).sizeFlags := remBytes or cThisUsedFlag; + InternalFreeMem(curAlloc + sizeof(TUsed)); + curAlloc := nil; + remBytes := 0; + end; + end; +end; + + +function MergeCommit(b: TBlock): Boolean; +var + merged: TBlock; + fSize: Integer; +begin + FreeCurAlloc; + merged := MergeBlockAfter(@committedRoot, b); + if merged.addr = nil then begin + result := False; + exit; + end; + + if merged.addr < b.addr then begin + fSize := FillerSizeBeforeGap(b.addr); + Dec(b.addr, fSize); + Inc(b.size, fSize); + end; + + if merged.addr + merged.size > b.addr + b.size then begin + fSize := FillerSizeAfterGap(b.addr + b.size); + Inc(b.size, fSize); + end; + + if merged.addr + merged.size = b.addr + b.size then begin + FillBeforeGap(b.addr + b.size - sizeof(TUsed), sizeof(TUsed)); + Dec(b.size, sizeof(TUsed)); + end; + + curAlloc := b.addr; + remBytes := b.size; + + result := True; +end; + + +function NewCommit(minSize: Integer): Boolean; +var + b: TBlock; +begin + b := GetCommitted(minSize+sizeof(TUsed)); + result := (b.addr <> nil) and MergeCommit(b); +end; + + +function NewCommitAt(addr: Pointer; minSize: Integer): Boolean; +var + b: TBlock; +begin + b := GetCommittedAt(addr, minSize+sizeof(TUsed)); + result := (b.addr <> nil) and MergeCommit(b); +end; + + +function SearchSmallBlocks(size: Integer): PFree; +var + i: Integer; +begin + result := nil; + for i := size div cAlign to High(smallTab^) do begin + result := smallTab[i]; + if result <> nil then + exit; + end; +end; + + +function TryHarder(size: Integer): Pointer; +var + u: PUsed; f:PFree; saveSize, rest: Integer; +begin + + repeat + + f := avail.next; + if (size <= f.size) then + break; + + f := rover; + if f.size >= size then + break; + + saveSize := f.size; + f.size := size; + repeat + f := f.next + until f.size >= size; + rover.size := saveSize; + if f <> rover then begin + rover := f; + break; + end; + + if size <= cSmallSize then begin + f := SearchSmallBlocks(size); + if f <> nil then + break; + end; + + if not NewCommit(size) then begin + result := nil; + exit; + end; + + if remBytes >= size then begin + Dec(remBytes, size); + if remBytes < sizeof(TFree) then begin + Inc(size, remBytes); + remBytes := 0; + end; + u := PUsed(curAlloc); + Inc(curAlloc, size); + u.sizeFlags := size or cThisUsedFlag; + result := PChar(u) + sizeof(TUsed); + Inc(AllocMemCount); + Inc(AllocMemSize,size - sizeof(TUsed)); + exit; + end; + + until False; + + DeleteFree(f); + + rest := f.size - size; + if rest >= sizeof(TFree) then begin + InsertFree(PChar(f) + size, rest); + end else begin + size := f.size; + if f = rover then + rover := f.next; + u := PUsed(PChar(f) + size); + u.sizeFlags := u.sizeFlags and not cPrevFreeFlag; + end; + + u := PUsed(f); + u.sizeFlags := size or cThisUsedFlag; + + result := PChar(u) + sizeof(TUsed); + Inc(AllocMemCount); + Inc(AllocMemSize,size - sizeof(TUsed)); + +end; + + +function SysGetMem(size: Integer): Pointer; +// Allocate memory block. +var + f, prev, next: PFree; + u: PUsed; +begin + + if (not initialized and not InitAllocator) or + (size > (High(size) - (sizeof(TUsed) + (cAlign-1)))) then + begin + result := nil; + exit; + end; + + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + Inc(size, sizeof(TUsed) + (cAlign-1)); + size := size and not (cAlign-1); + if size < sizeof(TFree) then + size := sizeof(TFree); + + if size <= cSmallSize then begin + f := smallTab[size div cAlign]; + if f <> nil then begin + u := PUsed(PChar(f) + size); + u.sizeFlags := u.sizeFlags and not cPrevFreeFlag; + next := f.next; + if next = f then + smallTab[size div cAlign] := nil + else begin + smallTab[size div cAlign] := next; + prev := f.prev; + prev.next := next; + next.prev := prev; + end; + u := PUsed(f); + u.sizeFlags := f.size or cThisUsedFlag; + result := PChar(u) + sizeof(TUsed); + Inc(AllocMemCount); + Inc(AllocMemSize,size - sizeof(TUsed)); + exit; + end; + end; + + if size <= remBytes then begin + Dec(remBytes, size); + if remBytes < sizeof(TFree) then begin + Inc(size, remBytes); + remBytes := 0; + end; + u := PUsed(curAlloc); + Inc(curAlloc, size); + u.sizeFlags := size or cThisUsedFlag; + result := PChar(u) + sizeof(TUsed); + Inc(AllocMemCount); + Inc(AllocMemSize,size - sizeof(TUsed)); + exit; + end; + + result := TryHarder(size); + + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; + +end; + + +function SysFreeMem(p: Pointer): Integer; +// Deallocate memory block. +label + abort; +var + u, n : PUsed; + f : PFree; + prevSize, nextSize, size : Integer; +begin + heapErrorCode := cHeapOk; + + if not initialized and not InitAllocator then begin + heapErrorCode := cCantInit; + result := cCantInit; + exit; + end; + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + u := p; + u := PUsed(PChar(u) - sizeof(TUsed)); { inv: u = address of allocated block being freed } + size := u.sizeFlags; + { inv: size = SET(block size) + [block flags] } + + { validate that the interpretation of this block as a used block is correct } + if (size and cThisUsedFlag) = 0 then begin + heapErrorCode := cBadUsedBlock; + goto abort; + end; + + { inv: the memory block addressed by 'u' and 'p' is an allocated block } + + Dec(AllocMemCount); + Dec(AllocMemSize,size and not cFlags - sizeof(TUsed)); + + if (size and cPrevFreeFlag) <> 0 then begin + { previous block is free, coalesce } + prevSize := PFree(PChar(u)-sizeof(TFree)).size; + if (prevSize < sizeof(TFree)) or ((prevSize and cFlags) <> 0) then begin + heapErrorCode := cBadPrevBlock; + goto abort; + end; + + f := PFree(PChar(u) - prevSize); + if f^.size <> prevSize then begin + heapErrorCode := cBadPrevBlock; + goto abort; + end; + + inc(size, prevSize); + u := PUsed(f); + DeleteFree(f); + end; + + size := size and not cFlags; + { inv: size = block size } + + n := PUsed(PChar(u) + size); + { inv: n = block following the block to free } + + if PChar(n) = curAlloc then begin + { inv: u = last block allocated } + dec(curAlloc, size); + inc(remBytes, size); + if remBytes > cDecommitMin then + FreeCurAlloc; + result := cHeapOk; + exit; + end; + + if (n.sizeFlags and cThisUsedFlag) <> 0 then begin + { inv: n is a used block } + if (n.sizeFlags and not cFlags) < sizeof(TUsed) then begin + heapErrorCode := cBadNextBlock; + goto abort; + end; + n.sizeFlags := n.sizeFlags or cPrevFreeFlag + end else begin + { inv: block u & n are both free; coalesce } + f := PFree(n); + if (f.next = nil) or (f.prev = nil) or (f.size < sizeof(TFree)) then begin + heapErrorCode := cBadNextBlock; + goto abort; + end; + nextSize := f.size; + inc(size, nextSize); + DeleteFree(f); + { inv: last block (which was free) is not on free list } + end; + + InsertFree(u, size); +abort: + result := heapErrorCode; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; +end; + + +function ResizeInPlace(p: Pointer; newSize: Integer): Boolean; +var u, n: PUsed; f: PFree; oldSize, blkSize, neededSize: Integer; +begin + Inc(newSize, sizeof(TUsed)+cAlign-1); + newSize := newSize and not (cAlign-1); + if newSize < sizeof(TFree) then + newSize := sizeof(TFree); + u := PUsed(PChar(p) - sizeof(TUsed)); + oldSize := u.sizeFlags and not cFlags; + n := PUsed( PChar(u) + oldSize ); + if newSize <= oldSize then begin + blkSize := oldSize - newSize; + if PChar(n) = curAlloc then begin + Dec(curAlloc, blkSize); + Inc(remBytes, blkSize); + if remBytes < sizeof(TFree) then begin + Inc(curAlloc, blkSize); + Dec(remBytes, blkSize); + newSize := oldSize; + end; + end else begin + n := PUsed(PChar(u) + oldSize); + if n.sizeFlags and cThisUsedFlag = 0 then begin + f := PFree(n); + Inc(blkSize, f.size); + DeleteFree(f); + end; + if blkSize >= sizeof(TFree) then begin + n := PUsed(PChar(u) + newSize); + n.sizeFlags := blkSize or cThisUsedFlag; + InternalFreeMem(PChar(n) + sizeof(TUsed)); + end else + newSize := oldSize; + end; + end else begin + repeat + neededSize := newSize - oldSize; + if PChar(n) = curAlloc then begin + if remBytes >= neededSize then begin + Dec(remBytes, neededSize); + Inc(curAlloc, neededSize); + if remBytes < sizeof(TFree) then begin + Inc(curAlloc, remBytes); + Inc(newSize, remBytes); + remBytes := 0; + end; + Inc(AllocMemSize, newSize - oldSize); + u.sizeFlags := newSize or u.sizeFlags and cFlags; + result := true; + exit; + end else begin + FreeCurAlloc; + n := PUsed( PChar(u) + oldSize ); + end; + end; + + if n.sizeFlags and cThisUsedFlag = 0 then begin + f := PFree(n); + blkSize := f.size; + if blkSize < neededSize then begin + n := PUsed(PChar(n) + blkSize); + Dec(neededSize, blkSize); + end else begin + DeleteFree(f); + Dec(blkSize, neededSize); + if blkSize >= sizeof(TFree) then + InsertFree(PChar(u) + newSize, blkSize) + else begin + Inc(newSize, blkSize); + n := PUsed(PChar(u) + newSize); + n.sizeFlags := n.sizeFlags and not cPrevFreeFlag; + end; + break; + end; + end; + + if n.sizeFlags and cFillerFlag <> 0 then begin + n := PUsed(PChar(n) + n.sizeFlags and not cFlags); + if NewCommitAt(n, neededSize) then begin + n := PUsed( PChar(u) + oldSize ); + continue; + end; + end; + + result := False; + exit; + + until False; + + end; + + Inc(AllocMemSize, newSize - oldSize); + u.sizeFlags := newSize or u.sizeFlags and cFlags; + result := True; + +end; + + +function SysReallocMem(p: Pointer; size: Integer): Pointer; +// Resize memory block. +var + n: Pointer; oldSize: Integer; +begin + + if not initialized and not InitAllocator then begin + result := nil; + exit; + end; + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + if ResizeInPlace(p, size) then + result := p + else begin + n := SysGetMem(size); + oldSize := (PUsed(PChar(p)-sizeof(PUsed)).sizeFlags and not cFlags) - sizeof(TUsed); + if oldSize > size then + oldSize := size; + if n <> nil then begin + Move(p^, n^, oldSize); + SysFreeMem(p); + end; + result := n; + end; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; + +end; + + +function BlockSum(root: PBlockDesc): Integer; +var + b : PBlockDesc; +begin + result := 0; + b := root.next; + while b <> root do begin + Inc(result, b.size); + b := b.next; + end; +end; + + +function GetHeapStatus: THeapStatus; +var + size, freeSize, userSize: Cardinal; + f: PFree; + a, e: PChar; + i: Integer; + b: PBlockDesc; + prevFree: Boolean; +begin + + result.TotalAddrSpace := 0; + result.TotalUncommitted := 0; + result.TotalCommitted := 0; + result.TotalAllocated := 0; + result.TotalFree := 0; + result.FreeSmall := 0; + result.FreeBig := 0; + result.Unused := 0; + result.Overhead := 0; + result.HeapErrorCode := cHeapOk; + + if not initialized then exit; + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + result.totalAddrSpace := BlockSum(@spaceRoot); + result.totalUncommitted := BlockSum(@decommittedRoot); + result.totalCommitted := BlockSum(@committedRoot); + + size := 0; + for i := Low(smallTab^) to High(smallTab^) do begin + f := smallTab[i]; + if f <> nil then begin + repeat + Inc(size, f.size); + if (f.prev.next <> f) or (f.next.prev <> f) or (f.size < sizeof(TFree)) then begin + heapErrorCode := cBadFreeList; + break; + end; + f := f.next; + until f = smallTab[i]; + end; + end; + result.freeSmall := size; + + size := 0; + f := avail.next; + while f <> @avail do begin + if (f.prev.next <> f) or (f.next.prev <> f) or (f.size < sizeof(TFree)) then begin + heapErrorCode := cBadFreeList; + break; + end; + Inc(size, f.size); + f := f.next; + end; + result.freeBig := size; + + result.unused := remBytes; + result.totalFree := result.freeSmall + result.freeBig + result.unused; + + freeSize := 0; + userSize := 0; + result.overhead := 0; + + b := committedRoot.next; + prevFree := False; + while b <> @committedRoot do begin + a := b.addr; + e := a + b.size; + while a < e do begin + if (a = curAlloc) and (remBytes > 0) then begin + size := remBytes; + Inc(freeSize, size); + if prevFree then + heapErrorCode := cBadCurAlloc; + prevFree := False; + end else begin + if prevFree <> ((PUsed(a).sizeFlags and cPrevFreeFlag) <> 0) then + heapErrorCode := cBadNextBlock; + if (PUsed(a).sizeFlags and cThisUsedFlag) = 0 then begin + f := PFree(a); + if (f.prev.next <> f) or (f.next.prev <> f) or (f.size < sizeof(TFree)) then + heapErrorCode := cBadFreeBlock; + size := f.size; + Inc(freeSize, size); + prevFree := True; + end else begin + size := PUsed(a).sizeFlags and not cFlags; + if (PUsed(a).sizeFlags and cFillerFlag) <> 0 then begin + Inc(result.overhead, size); + if (a > b.addr) and (a + size < e) then + heapErrorCode := cBadUsedBlock; + end else begin + Inc(userSize, size-sizeof(TUsed)); + Inc(result.overhead, sizeof(TUsed)); + end; + prevFree := False; + end; + end; + Inc(a, size); + end; + b := b.next; + end; + if result.totalFree <> freeSize then + heapErrorCode := cBadBalance; + + result.totalAllocated := userSize; + result.heapErrorCode := heapErrorCode; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; +end; + + +// this section goes into GetMem.Inc + +{$IFDEF DEBUG_FUNCTIONS} +type + THeapReportProc = procedure(HeapBlock: Pointer; AllocatedSize: Integer) of object; + + +procedure WalkHeap(HeapReportProc: THeapReportProc); +var + size : Cardinal; + f: PFree; + a, e: PChar; + b: PBlockDesc; +begin + + if not initialized then exit; + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + b := committedRoot.next; + while b <> @committedRoot do begin + a := b.addr; + e := a + b.size; + while a < e do begin + if (a = curAlloc) and (remBytes > 0) then begin + size := remBytes; + end else begin + if (PUsed(a).sizeFlags and cThisUsedFlag) = 0 then begin + f := PFree(a); + size := f.size; + end else begin + size := PUsed(a).sizeFlags and not cFlags; + if (PUsed(a).sizeFlags and cFillerFlag) = 0 then begin + HeapReportProc(a + sizeof(TUsed), size - sizeof(TUsed)); + end; + end; + end; + Inc(a, size); + end; + b := b.next; + end; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; +end; + +type + THeapBlockCollector = class(TObject) + FCount: Integer; + FObjectTable: TObjectArray; + FHeapBlockTable: THeapBlockArray; + FClass: TClass; + FFindDerived: Boolean; + procedure CollectBlocks(HeapBlock: Pointer; AllocatedSize: Integer); + procedure CollectObjects(HeapBlock: Pointer; AllocatedSize: Integer); + end; + + +procedure THeapBlockCollector.CollectBlocks(HeapBlock: Pointer; AllocatedSize: Integer); +begin + if FCount < Length(FHeapBlockTable) then + begin + FHeapBlockTable[FCount].Start := HeapBlock; + FHeapBlockTable[FCount].Size := AllocatedSize; + end; + Inc(FCount); +end; + + +procedure THeapBlockCollector.CollectObjects(HeapBlock: Pointer; AllocatedSize: Integer); +var + AObject: TObject; + AClass: TClass; +type + PPointer = ^Pointer; +begin + try + if AllocatedSize < 4 then + Exit; + AObject := TObject(HeapBlock); + AClass := AObject.ClassType; + if (AClass = FClass) + or (FFindDerived + and (Integer(AClass) >= 64*1024) + and (PPointer(PChar(AClass) + vmtSelfPtr)^ = Pointer(AClass)) + and (AObject is FClass)) then + begin + if FCount < Length(FObjectTable) then + FObjectTable[FCount] := AObject; + Inc(FCount); + end; + except + // Let's not worry about this block - it's obviously not a valid object + end; +end; + +var + HeapBlockCollector: THeapBlockCollector; + +function GetHeapBlocks: THeapBlockArray; +begin + if not Assigned(HeapBlockCollector) then + HeapBlockCollector := THeapBlockCollector.Create; + + Walkheap(HeapBlockCollector.CollectBlocks); + SetLength(HeapBlockCollector.FHeapBlockTable, HeapBlockCollector.FCount); + HeapBlockCollector.FCount := 0; + Walkheap(HeapBlockCollector.CollectBlocks); + Result := HeapBlockCollector.FHeapBlockTable; + HeapBlockCollector.FCount := 0; + HeapBlockCollector.FHeapBlockTable := nil; +end; + + +function FindObjects(AClass: TClass; FindDerived: Boolean): TObjectArray; +begin + if not Assigned(HeapBlockCollector) then + HeapBlockCollector := THeapBlockCollector.Create; + HeapBlockCollector.FClass := AClass; + HeapBlockCollector.FFindDerived := FindDerived; + + Walkheap(HeapBlockCollector.CollectObjects); + SetLength(HeapBlockCollector.FObjectTable, HeapBlockCollector.FCount); + HeapBlockCollector.FCount := 0; + Walkheap(HeapBlockCollector.CollectObjects); + Result := HeapBlockCollector.FObjectTable; + HeapBlockCollector.FCount := 0; + HeapBlockCollector.FObjectTable := nil; +end; +{$ENDIF} + + diff --git a/System/D2007beta/SYSWSTR.PAS b/System/D2007beta/SYSWSTR.PAS new file mode 100644 index 0000000..ab8a677 --- /dev/null +++ b/System/D2007beta/SYSWSTR.PAS @@ -0,0 +1,18 @@ +unit syswstr; +{X: this unit contains some definitions and initializations, needed to + support wide string variables. To use it, just place reference to syswstr + unit in your dpr/units uses clause *as first as possible* } + +interface + +implementation + +initialization + + WStrAddRefProc := WStrAddRef; + WStrClrProc := WStrClr; + WStrArrayClrProc := WStrArrayClr; + +finalization + +end. diff --git a/System/D2007beta/SysConst.pas b/System/D2007beta/SysConst.pas new file mode 100644 index 0000000..c0f6754 --- /dev/null +++ b/System/D2007beta/SysConst.pas @@ -0,0 +1,184 @@ +{ *********************************************************************** } +{ } +{ Delphi / Kylix Cross-Platform Runtime Library } +{ } +{ Copyright (c) 1995, 2001 Borland Software Corporation } +{ } +{ *********************************************************************** } + +unit SysConst; + +interface + +resourcestring + SUnknown = ''; + SInvalidInteger = '''%s'' is not a valid integer value'; + SInvalidFloat = '''%s'' is not a valid floating point value'; + SInvalidCurrency = '''%s'' is not a valid currency value'; + SInvalidDate = '''%s'' is not a valid date'; + SInvalidTime = '''%s'' is not a valid time'; + SInvalidDateTime = '''%s'' is not a valid date and time'; + SInvalidDateTimeFloat = '''%g'' is not a valid date and time'; + SInvalidTimeStamp = '''%d.%d'' is not a valid timestamp'; + SInvalidGUID = '''%s'' is not a valid GUID value'; + SInvalidBoolean = '''%s'' is not a valid boolean value'; + STimeEncodeError = 'Invalid argument to time encode'; + SDateEncodeError = 'Invalid argument to date encode'; + SOutOfMemory = 'Out of memory'; + SInOutError = 'I/O error %d'; + SFileNotFound = 'File not found'; + SInvalidFilename = 'Invalid filename'; + STooManyOpenFiles = 'Too many open files'; + SAccessDenied = 'File access denied'; + SEndOfFile = 'Read beyond end of file'; + SDiskFull = 'Disk full'; + SInvalidInput = 'Invalid numeric input'; + SDivByZero = 'Division by zero'; + SRangeError = 'Range check error'; + SIntOverflow = 'Integer overflow'; + SInvalidOp = 'Invalid floating point operation'; + SZeroDivide = 'Floating point division by zero'; + SOverflow = 'Floating point overflow'; + SUnderflow = 'Floating point underflow'; + SInvalidPointer = 'Invalid pointer operation'; + SInvalidCast = 'Invalid class typecast'; +{$IFDEF MSWINDOWS} + SAccessViolationArg3 = 'Access violation at address %p. %s of address %p'; +{$ENDIF} +{$IFDEF LINUX} + SAccessViolationArg2 = 'Access violation at address %p, accessing address %p'; +{$ENDIF} + SAccessViolationNoArg = 'Access violation'; + SStackOverflow = 'Stack overflow'; + SControlC = 'Control-C hit'; + SQuit = 'Quit key hit'; + SPrivilege = 'Privileged instruction'; + SOperationAborted = 'Operation aborted'; + SException = 'Exception %s in module %s at %p.' + sLineBreak + '%s%s' + sLineBreak; + SExceptTitle = 'Application Error'; +{$IFDEF LINUX} + SSigactionFailed = 'sigaction call failed'; +{$ENDIF} + SInvalidFormat = 'Format ''%s'' invalid or incompatible with argument'; + SArgumentMissing = 'No argument for format ''%s'''; + SDispatchError = 'Variant method calls not supported'; + SReadAccess = 'Read'; + SWriteAccess = 'Write'; + SResultTooLong = 'Format result longer than 4096 characters'; + SFormatTooLong = 'Format string too long'; + + SVarArrayCreate = 'Error creating variant or safe array'; + SVarArrayBounds = 'Variant or safe array index out of bounds'; + SVarArrayLocked = 'Variant or safe array is locked'; + SVarArrayWithHResult = 'Unexpected variant or safe array error: %s%.8x'; + + SInvalidVarCast = 'Invalid variant type conversion'; + SInvalidVarOp = 'Invalid variant operation'; + SInvalidVarNullOp = 'Invalid NULL variant operation'; + SInvalidVarOpWithHResultWithPrefix = 'Invalid variant operation (%s%.8x)'#10'%s'; + SVarTypeRangeCheck1 = 'Range check error for variant of type (%s)'; + SVarTypeRangeCheck2 = 'Range check error while converting variant of type (%s) into type (%s)'; + SVarTypeOutOfRangeWithPrefix = 'Custom variant type (%s%.4x) is out of range'; + SVarTypeAlreadyUsedWithPrefix = 'Custom variant type (%s%.4x) already used by %s'; + SVarTypeNotUsableWithPrefix = 'Custom variant type (%s%.4x) is not usable'; + SVarTypeTooManyCustom = 'Too many custom variant types have been registered'; + + // the following are not used anymore + SVarNotArray = 'Variant is not an array' deprecated; // not used, use SVarInvalid instead + SVarTypeUnknown = 'Unknown custom variant type ($%.4x)' deprecated; // not used anymore + SVarTypeOutOfRange = 'Custom variant type ($%.4x) is out of range' deprecated; + SVarTypeAlreadyUsed = 'Custom variant type ($%.4x) already used by %s' deprecated; + SVarTypeNotUsable = 'Custom variant type ($%.4x) is not usable' deprecated; + SInvalidVarOpWithHResult = 'Invalid variant operation ($%.8x)' deprecated; + + SVarTypeCouldNotConvert = 'Could not convert variant of type (%s) into type (%s)'; + SVarTypeConvertOverflow = 'Overflow while converting variant of type (%s) into type (%s)'; + SVarOverflow = 'Variant overflow'; + SVarInvalid = 'Invalid argument'; + SVarBadType = 'Invalid variant type'; + SVarNotImplemented = 'Operation not supported'; + SVarOutOfMemory = 'Variant operation ran out memory'; + SVarUnexpected = 'Unexpected variant error'; + + SVarDataClearRecursing = 'Recursion while doing a VarDataClear'; + SVarDataCopyRecursing = 'Recursion while doing a VarDataCopy'; + SVarDataCopyNoIndRecursing = 'Recursion while doing a VarDataCopyNoInd'; + SVarDataInitRecursing = 'Recursion while doing a VarDataInit'; + SVarDataCastToRecursing = 'Recursion while doing a VarDataCastTo'; + SVarIsEmpty = 'Variant is empty'; + sUnknownFromType = 'Cannot convert from the specified type'; + sUnknownToType = 'Cannot convert to the specified type'; + SExternalException = 'External exception %x'; + SAssertionFailed = 'Assertion failed'; + SIntfCastError = 'Interface not supported'; + SSafecallException = 'Exception in safecall method'; + SAssertError = '%s (%s, line %d)'; + SAbstractError = 'Abstract Error'; + SModuleAccessViolation = 'Access violation at address %p in module ''%s''. %s of address %p'; + SCannotReadPackageInfo = 'Cannot access package information for package ''%s'''; + sErrorLoadingPackage = 'Can''t load package %s.'+sLineBreak+'%s'; + SInvalidPackageFile = 'Invalid package file ''%s'''; + SInvalidPackageHandle = 'Invalid package handle'; + SDuplicatePackageUnit = 'Cannot load package ''%s.'' It contains unit ''%s,''' + + 'which is also contained in package ''%s'''; + SOSError = 'System Error. Code: %d.'+sLineBreak+'%s'; + SUnkOSError = 'A call to an OS function failed'; +{$IFDEF MSWINDOWS} + SWin32Error = 'Win32 Error. Code: %d.'#10'%s' deprecated; // use SOSError + SUnkWin32Error = 'A Win32 API function failed' deprecated; // use SUnkOSError +{$ENDIF} + SNL = 'Application is not licensed to use this feature'; + + SShortMonthNameJan = 'Jan'; + SShortMonthNameFeb = 'Feb'; + SShortMonthNameMar = 'Mar'; + SShortMonthNameApr = 'Apr'; + SShortMonthNameMay = 'May'; + SShortMonthNameJun = 'Jun'; + SShortMonthNameJul = 'Jul'; + SShortMonthNameAug = 'Aug'; + SShortMonthNameSep = 'Sep'; + SShortMonthNameOct = 'Oct'; + SShortMonthNameNov = 'Nov'; + SShortMonthNameDec = 'Dec'; + + SLongMonthNameJan = 'January'; + SLongMonthNameFeb = 'February'; + SLongMonthNameMar = 'March'; + SLongMonthNameApr = 'April'; + SLongMonthNameMay = 'May'; + SLongMonthNameJun = 'June'; + SLongMonthNameJul = 'July'; + SLongMonthNameAug = 'August'; + SLongMonthNameSep = 'September'; + SLongMonthNameOct = 'October'; + SLongMonthNameNov = 'November'; + SLongMonthNameDec = 'December'; + + SShortDayNameSun = 'Sun'; + SShortDayNameMon = 'Mon'; + SShortDayNameTue = 'Tue'; + SShortDayNameWed = 'Wed'; + SShortDayNameThu = 'Thu'; + SShortDayNameFri = 'Fri'; + SShortDayNameSat = 'Sat'; + + SLongDayNameSun = 'Sunday'; + SLongDayNameMon = 'Monday'; + SLongDayNameTue = 'Tuesday'; + SLongDayNameWed = 'Wednesday'; + SLongDayNameThu = 'Thursday'; + SLongDayNameFri = 'Friday'; + SLongDayNameSat = 'Saturday'; + +{$IFDEF LINUX} + SEraEntries = ''; +{$ENDIF} + + SCannotCreateDir = 'Unable to create directory'; + SCodesetConversionError = 'Codeset conversion failure'; + +implementation + +end. + diff --git a/System/D2007beta/SysInit.pas b/System/D2007beta/SysInit.pas new file mode 100644 index 0000000..3abc531 --- /dev/null +++ b/System/D2007beta/SysInit.pas @@ -0,0 +1,864 @@ +{ *********************************************************************** } +{ } +{ Delphi / Kylix Cross-Platform Runtime Library } +{ System Initialization Unit } +{ } +{ Copyright (c) 1997-2002 Borland Software Corporation } +{ } +{ This file may be distributed and/or modified under the terms of the } +{ GNU General Public License version 2 as published by the Free Software } +{ Foundation and appearing at http://www.borland.com/kylix/gpl.html. } +{ } +{ Licensees holding a valid Borland No-Nonsense License for this } +{ Software may use this file in accordance with such license, which } +{ appears in the file license.txt that came with this software. } +{ } +{ *********************************************************************** } + +unit SysInit; +//Изменено: Avenger + +interface + +{$H+,I-,R-,S-,O+,W-} +{$WARN SYMBOL_PLATFORM OFF} + +{X} // if your app really need to localize resource, call: +{X} procedure UseLocalizeResources; + +{$IFDEF LINUX} +const + ExeBaseAddress = Pointer($8048000) platform; +{$ENDIF} + +var + Copyright : String = '';//{'Portions Copyright (c) 1999,2003'; //}'Portions Copyright (c) 1999,2003 Avenger by NhT'; + + ModuleIsLib: Boolean; { True if this module is a dll (a library or a package) } + ModuleIsPackage: Boolean; { True if this module is a package } + ModuleIsCpp: Boolean; { True if this module is compiled using C++ Builder } + TlsIndex: Integer = -1; { Thread local storage index } + TlsLast: Byte; { Set by linker so its offset is last in TLS segment } + HInstance: LongWord; { Handle of this instance } + {$EXTERNALSYM HInstance} + (*$HPPEMIT 'namespace Sysinit' *) + (*$HPPEMIT '{' *) + (*$HPPEMIT 'extern PACKAGE HINSTANCE HInstance;' *) + (*$HPPEMIT '} /* namespace Sysinit */' *) + DllProc: TDLLProc; { Called whenever DLL entry point is called } + { DllProcEx passes the Reserved param provided by WinNT on DLL load & exit } + DllProcEx: TDLLProcEx absolute DllProc; + DataMark: Integer = 0; { Used to find the virtual base of DATA seg } + CoverageLibraryName: array [0..128] of char = '*'; { initialized by the linker! } +{$IFDEF ELF} + TypeImportsTable: array [0..0] of Pointer platform; { VMT and RTTI imports table for exes } + _GLOBAL_OFFSET_TABLE_: ARRAY [0..2] OF Cardinal platform; + (* _DYNAMIC: ARRAY [0..0] OF Elf32_Dyn; *) +{$IFDEF PC_MAPPED_EXCEPTIONS} + TextStartAdj: Byte platform; { See GetTextStart } + CodeSegSize: Byte platform; { See GetTextStart } +function GetTextStart : LongInt; platform; +{$ENDIF} +{$ENDIF} + +const + PtrToNil: Pointer = nil; // provides pointer to nil for compiler codegen + +function _GetTls: Pointer; +{$IFDEF LINUX} +procedure _InitLib(Context: PInitContext); +procedure _GetCallerEIP; +procedure _InitExe(InitTable: Pointer; Argc: Integer; Argp: Pointer); +procedure _start; cdecl; +function _ExitLib: Integer; cdecl; +function _InitPkg: LongBool; +{$ENDIF} +{$IFDEF MSWINDOWS} +procedure _InitLib; +procedure _InitExe(InitTable: Pointer); +function _InitPkg(Hinst: Integer; Reason: Integer; Resvd: Pointer): LongBool; stdcall; +{$ENDIF} +procedure _PackageLoad(const Table: PackageInfo); +procedure _PackageUnload(const Table: PackageInfo); + +{ Invoked by C++ startup code to allow initialization of VCL global vars } +procedure VclInit(isDLL, isPkg: Boolean; hInst: LongInt; isGui: Boolean); cdecl; +procedure VclExit; cdecl; + +{$IFDEF LINUX} +function GetThisModuleHandle: LongWord; +{$ENDIF} + +implementation + +{$IFDEF MSWINDOWS} +const + kernel = 'kernel32.dll'; + +function FreeLibrary(ModuleHandle: Longint): LongBool; stdcall; + external kernel name 'FreeLibrary'; + +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 LocalAlloc(flags, size: Integer): Pointer; stdcall; + external kernel name 'LocalAlloc'; + +function LocalFree(addr: Pointer): Pointer; stdcall; + external kernel name 'LocalFree'; + +function TlsAlloc: Integer; stdcall; + external kernel name 'TlsAlloc'; + +function TlsFree(TlsIndex: Integer): Boolean; stdcall; + external kernel name 'TlsFree'; + +function TlsGetValue(TlsIndex: Integer): Pointer; stdcall; + external kernel name 'TlsGetValue'; + +function TlsSetValue(TlsIndex: Integer; TlsValue: Pointer): Boolean; stdcall; + external kernel name 'TlsSetValue'; + +function GetCommandLine: PChar; stdcall; + external kernel name 'GetCommandLineA'; + +const + tlsArray = $2C; { offset of tls array from FS: } + LMEM_ZEROINIT = $40; + +function AllocTlsBuffer(Size: Integer): Pointer; +begin + Result := LocalAlloc(LMEM_ZEROINIT, Size); +end; + +var + tlsBuffer: Pointer; // RTM32 DOS support +{$ENDIF} + +{$IFDEF LINUX} + +{$IFDEF PIC} +function GetGOT: Pointer; export; +begin + asm + MOV Result,EBX + end; +end; +{$ENDIF} + +const + RTLD_LAZY = 1; + RTLD_NOW = 2; + RTLD_BINDING_MASK = RTLD_LAZY or RTLD_NOW; + RTLD_GLOBAL = $100; + RTLD_LOCAL = 0; + RTLD_NEXT = Pointer(-1); + RTLD_DEFAULT = nil; + +type + TDLInfo = record + Filename: PChar; + BaseAddress: Pointer; + NearestSymbolName: PChar; + NearestSymbolAddr: Pointer; + end; + +const + libcmodulename = 'libc.so.6'; + libdlmodulename = 'libdl.so.2'; + libpthreadmodulename = 'libpthread.so.0'; + tlsSizeName = '@Sysinit@tlsSize'; + +function malloc(Size: LongWord): Pointer; cdecl; + external libcmodulename name 'malloc'; + +procedure free(P: Pointer); cdecl; + external libcmodulename name 'free'; + +function dlopen(Filename: PChar; Flag: Integer): LongWord; cdecl; + external libdlmodulename name 'dlopen'; + +function dlerror: PChar; cdecl; + external libdlmodulename name 'dlerror'; + +function dlsym(Handle: LongWord; Symbol: PChar): Pointer; cdecl; + external libdlmodulename name 'dlsym'; + +function dlclose(Handle: LongWord): Integer; cdecl; + external libdlmodulename name 'dlclose'; + +function FreeLibrary(Handle: LongWord): Integer; cdecl; + external libdlmodulename name 'dlclose'; + +function dladdr(Address: Pointer; var Info: TDLInfo): Integer; cdecl; + external libdlmodulename name 'dladdr'; + +type + TInitOnceProc = procedure; cdecl; + TKeyValueDestructor = procedure(ValueInKey: Pointer); cdecl; + +function pthread_once(var InitOnceSemaphore: Integer; InitOnceProc: TInitOnceProc): Integer; cdecl; + external libpthreadmodulename name 'pthread_once'; + +function pthread_key_create(var Key: Integer; KeyValueDestructor: TKeyValueDestructor): Integer; cdecl; + external libpthreadmodulename name 'pthread_key_create'; + +function pthread_key_delete(Key: Integer): Integer; cdecl; + external libpthreadmodulename name 'pthread_key_delete'; + +function TlsGetValue(Key: Integer): Pointer; cdecl; + external libpthreadmodulename name 'pthread_getspecific'; + +function TlsSetValue(Key: Integer; Ptr: Pointer): Integer; cdecl; + external libpthreadmodulename name 'pthread_setspecific'; + +function AllocTlsBuffer(Size: Cardinal): Pointer; +begin + // The C++ rtl handles all tls in a C++ module + if ModuleIsCpp then + RunError(226); + + Result := malloc(Size); + if Result <> nil then + FillChar(Result^, Size, 0); +end; + +procedure FreeTLSBuffer(ValueInKey: Pointer); export cdecl; +begin + // The C++ rtl handles all tls in a C++ module + if ModuleIsCpp then + RunError(226); + free(ValueInKey); +end; + +procedure AllocTlsIndex; cdecl export; +begin + // guaranteed to reach here only once per process + // The C++ rtl handles all tls in a C++ module + if ModuleIsCpp then + RunError(226); + if pthread_key_create(TlsIndex, FreeTLSBuffer) <> 0 then + begin + TlsIndex := -1; + RunError(226); + end; +end; + +function GetThisModuleHandle: LongWord; +var + Info: TDLInfo; +begin + if (dladdr(@GetThisModuleHandle, Info) = 0) or (Info.BaseAddress = ExeBaseAddress) then + Info.FileName := nil; // if we're not in a library, we must be main exe + Result := LongWord(dlopen(Info.Filename, RTLD_LAZY)); + if Result <> 0 then + dlclose(Result); +end; + +var + InitOnceSemaphore: Integer; +{$ENDIF} + +var + Module: TLibModule = ( + Next: nil; + Instance: 0; + CodeInstance: 0; + DataInstance: 0; + ResInstance: 0; + Reserved: 0 +{$IFDEF LINUX} + ; InstanceVar: nil; + GOT: 0; + CodeSegStart: 0; + CodeSegEnd: 0 + ); +{$ELSE} + ); +{$ENDIF} + +function GetTlsSize: Integer; +{$IFDEF LINUX} +asm + MOV EAX, offset TlsLast +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +begin + Result := Integer(@TlsLast); +end; +{$ENDIF} + +procedure InitThreadTLS; +var + p: Pointer; + tlsSize: Integer; +begin + tlsSize := GetTlsSize; + if tlsSize = 0 then Exit; +{$IFDEF LINUX} + pthread_once(InitOnceSemaphore, AllocTlsIndex); +{$ENDIF} + if TlsIndex = -1 then RunError(226); + p := AllocTlsBuffer(tlsSize); + if p = nil then + RunError(226) + else + TlsSetValue(TlsIndex, p); +end; + +{$IFDEF MSWINDOWS} +procedure InitProcessTLS; +begin + if @TlsLast = nil then + Exit; + TlsIndex := TlsAlloc; + InitThreadTLS; + tlsBuffer := TlsGetValue(TlsIndex); // RTM32 DOS support +end; + +procedure ExitThreadTLS; +var + p: Pointer; +begin + if @TlsLast = nil then + Exit; + if TlsIndex <> -1 then begin + p := TlsGetValue(TlsIndex); + if p <> nil then + LocalFree(p); + end; +end; + +procedure ExitProcessTLS; +begin + if @TlsLast = nil then + Exit; + ExitThreadTLS; + if TlsIndex <> -1 then + TlsFree(TlsIndex); +end; +{$ENDIF} + +const + DLL_PROCESS_DETACH = 0; + DLL_PROCESS_ATTACH = 1; + DLL_THREAD_ATTACH = 2; + DLL_THREAD_DETACH = 3; + +function _GetTls: Pointer; +{$IFDEF LINUX} +begin + Result := TlsGetValue(TlsIndex); + if Result = nil then + begin + InitThreadTLS; + Result := TlsGetValue(TlsIndex); + end; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + MOV CL,ModuleIsLib + MOV EAX,TlsIndex + TEST CL,CL + JNE @@isDll + MOV EDX,FS:tlsArray + MOV EAX,[EDX+EAX*4] + RET + +@@initTls: + CALL InitThreadTLS + MOV EAX,TlsIndex + PUSH EAX + CALL TlsGetValue + TEST EAX,EAX + JE @@RTM32 + RET + +@@RTM32: + MOV EAX, tlsBuffer + RET + +@@isDll: + PUSH EAX + CALL TlsGetValue + TEST EAX,EAX + JE @@initTls +end; + +const + TlsProc: array [DLL_PROCESS_DETACH..DLL_THREAD_DETACH] of procedure = + (ExitProcessTLS,InitProcessTLS,InitThreadTLS,ExitThreadTLS); +{$ENDIF} + +{$IFDEF PC_MAPPED_EXCEPTIONS} +const + UNWINDFI_TOPOFSTACK = $BE00EF00; + +{ + The linker sets the value of TextStartAdj to be the delta between GetTextStart + and the start of the text segment. This allows us to get the pointer to the + start of the text segment in a position independent fashion. +} +function GetTextStart : LongInt; +asm + CALL @@label1 +@@label1: + POP EAX + SUB EAX, 5 + offset TextStartAdj +end; + +{ + The linker sets the value of CodeSegSize to the length of the text segment, + excluding the PC map. This allows us to get the pointer to the exception + information that we need at runtime, also in a position independent fashion. +} +function GetTextEnd : LongInt; +asm + CALL GetTextStart + ADD EAX, offset CodeSegSize +end; +{$ENDIF} + +procedure InitializeModule; +begin + RegisterModule(@Module); +end; + +procedure UseLocalizeResources; +var + FileName: array[0..260] of Char; +begin + GetModuleFileName(HInstance, FileName, SizeOf(FileName)); + Module.ResInstance := LoadResourceModule(FileName); + if Module.ResInstance = 0 then + Module.ResInstance := Module.Instance; +end; + +procedure UninitializeModule; +begin + UnregisterModule(@Module); + if (Module.ResInstance <> Module.Instance) and (Module.ResInstance <> 0) then + FreeLibrary(Module.ResInstance); +end; + +procedure VclInit(isDLL, isPkg: Boolean; hInst: LongInt; isGui: Boolean); cdecl; +begin + ModuleIsLib := isDLL; + ModuleIsPackage := isPkg; + IsLibrary := isDLL and not isPkg; + HInstance := hInst; + Module.Instance := hInst; + Module.CodeInstance := 0; + Module.DataInstance := 0; + ModuleIsCpp := True; +{$IFDEF LINUX} + if ModuleIsLib then + Module.InstanceVar := @HInstance; +{$IFDEF PIC} + Module.GOT := LongWord(GetGot); +{$ENDIF} + { Module.CodeSegStart, Module.CodeSegEnd not used: the C++ + rtl will feed the unwinder. } +{$ENDIF} + InitializeModule; + if not ModuleIsLib then + begin + Module.CodeInstance := FindHInstance(@VclInit); + Module.DataInstance := FindHInstance(@DataMark); +{$IFDEF MSWINDOWS} +{X CmdLine := GetCommandLine; - converted to a function } + IsConsole := not isGui; +{$ENDIF} + end; +end; + +procedure VclExit; cdecl; +var + P: procedure; +begin + if not ModuleIsLib then + while ExitProc <> nil do + begin + @P := ExitProc; + ExitProc := nil; + P; + end; + UnInitializeModule; +end; + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure RegisterPCMap; +begin + SysRegisterIPLookup(GetTextStart, + GetTextEnd, + Pointer(GetTextEnd), + LongWord(@_Global_Offset_Table_)); +end; + +procedure UnregisterPCMap; +begin + SysUnregisterIPLookup(GetTextStart); +end; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function _InitPkg(Hinst: Longint; Reason: Integer; Resvd: Pointer): Longbool; stdcall; +begin + ModuleIsLib := True; + ModuleIsPackage := True; + Module.Instance := Hinst; + Module.CodeInstance := 0; + Module.DataInstance := 0; + HInstance := Hinst; + if @TlsLast <> nil then + TlsProc[Reason]; + if Reason = DLL_PROCESS_ATTACH then + InitializeModule + else if Reason = DLL_PROCESS_DETACH then + UninitializeModule; + _InitPkg := True; +end; +{$ENDIF} +{$IFDEF LINUX} +function _InitPkg: LongBool; +begin +{$IFDEF DEBUG_STARTUP} +asm +INT 3 +end; +{$ENDIF} +{$IFDEF PC_MAPPED_EXCEPTIONS} + RegisterPCMap; +{$ENDIF} + TlsIndex := -1; + ModuleIsLib := True; + ModuleIsPackage := True; + Module.Instance := GetThisModuleHandle; + Module.InstanceVar := @HInstance; + Module.CodeInstance := 0; + Module.DataInstance := 0; + Module.GOT := LongWord(@_Global_Offset_Table_); + Module.CodeSegStart := GetTextStart; + Module.CodeSegEnd := GetTextEnd; + HInstance := Module.Instance; + InitializeModule; + _InitPkg := True; +end; +{$ENDIF} + +procedure _PackageLoad(const Table: PackageInfo); +begin + System._PackageLoad(Table, @Module); +end; + +procedure _PackageUnload(const Table: PackageInfo); +begin + System._PackageUnload(Table, @Module); +end; + +{$IFDEF MSWINDOWS} +procedure _InitLib; +asm + { -> EAX Inittable } + { [EBP+8] Hinst } + { [EBP+12] Reason } + { [EBP+16] Resvd } + + MOV EDX,offset Module + CMP dword ptr [EBP+12],DLL_PROCESS_ATTACH + JNE @@notInit + + PUSH EAX + PUSH EDX + MOV ModuleIsLib,1 + MOV ECX,[EBP+8] + MOV HInstance,ECX + MOV [EDX].TLibModule.Instance,ECX + MOV [EDX].TLibModule.CodeInstance,0 + MOV [EDX].TLibModule.DataInstance,0 + CALL InitializeModule + POP EDX + POP EAX + +@@notInit: + PUSH DllProc + MOV ECX,offset TlsProc + CALL _StartLib +end; + +// ExitLib is the same as InitLib in Windows. + +{$ENDIF MSWINDOWS} +{$IFDEF LINUX} +procedure _InitLib(Context: PInitContext); +begin +{$IFDEF DEBUG_STARTUP} +asm + INT 3 +end; +{$ENDIF} + asm + PUSH UNWINDFI_TOPOFSTACK + end; + Context.DLLInitState := DLL_PROCESS_ATTACH; + TlsIndex := -1; + ModuleIsLib := True; + HInstance := GetThisModuleHandle; + Module.Instance := HInstance; + Module.InstanceVar := @HInstance; + Module.CodeInstance := 0; + Module.DataInstance := 0; + Module.GOT := LongWord(@_Global_Offset_Table_); + Module.CodeSegStart := GetTextStart; + Module.CodeSegEnd := GetTextEnd; + InitializeModule; + RegisterPCMap; + _StartLib(Context, @Module, DLLProcEx); + asm + ADD ESP, 4 + end; +end; + +// InnerExitLib provides GOT fixup and global var addressing +function InnerExitLib(Context: PInitContext): Integer; +begin + Result := 0; + if ModuleIsPackage then + begin + UninitializeModule; + UnregisterPCMap; + end + else + _StartLib(Context, @Module, DLLProcEx); +end; + +function _ExitLib: Integer; cdecl; +asm +{$IFDEF DEBUG_STARTUP} + INT 3 +{$ENDIF} + PUSH EBP + MOV EBP,ESP + PUSH UNWINDFI_TOPOFSTACK + XOR EAX,EAX + PUSH DLL_PROCESS_DETACH // InitContext.DLLInitState + PUSH EDI + PUSH ESI + PUSH EBX + PUSH EBP + PUSH EAX // InitContext.Module + PUSH EAX // InitContext.InitCount + PUSH EAX // InitContext.InitTable (filled in later) + PUSH EAX // InitContext.OuterContext + MOV EAX,ESP + CALL InnerExitLib; + ADD ESP, 16 + POP EBP + POP EBX + POP ESI + POP EDI + MOV ESP,EBP + POP EBP +end; + +procedure _GetCallerEIP; +asm + MOV EBX, [ESP] +end; +{$ENDIF LINUX} + +{$IFDEF MSWINDOWS} +procedure _InitExe(InitTable: Pointer); +begin + TlsIndex := 0; + HInstance := GetModuleHandle(nil); + Module.Instance := HInstance; + Module.CodeInstance := 0; + Module.DataInstance := 0; + InitializeModule; + _StartExe(InitTable, @Module); +end; +{$ENDIF MSWINDOWS} +{$IFDEF LINUX} +procedure InitVmtImports; +var + P: ^Integer; +begin + P := @TypeImportsTable; + if P = nil then Exit; + while P^ <> 0 do + begin + P^ := Integer(dlsym(0, PChar(P^))); + Inc(P); + end; +end; + +procedure _InitExe(InitTable: Pointer; Argc: Integer; Argp: Pointer); export; +begin +{$IFDEF DEBUG_STARTUP} + asm + INT 3 + end; +{$ENDIF} + HInstance := GetThisModuleHandle; + Module.Instance := HInstance; + Module.InstanceVar := @HInstance; + Module.CodeInstance := 0; + Module.DataInstance := 0; + InitializeModule; + InitThreadTLS; +{$IFDEF PC_MAPPED_EXCEPTIONS} + RegisterPCMap(); +{$ENDIF} + InitVmtImports; + _StartExe(InitTable, @Module, Argc, Argp); +end; +{$ENDIF} + + +{$IFDEF LINUX} +var + InitAddr: Pointer; + +function _main(argc: Integer; argv: Pointer; envp: Pointer): Integer; export cdecl; +type + TInitFunction = function (argc: Integer; argv, envp: Pointer): Integer; cdecl; + TExternalInit = function (argc: Integer; argv, envp: Pointer; InitExe: TInitFunction): Integer; cdecl; +var + ExternalInit: TExternalInit; + InitFunc: TInitFunction; +begin + @ExternalInit := dlsym(GetThisModuleHandle, 'ExternalInit'); + @InitFunc := InitAddr; + System.envp := envp; + if @ExternalInit <> nil then + ExternalInit(argc, argv, envp, InitFunc); + Result := InitFunc(argc, argv, envp); +end; + +function __libc_start_main (Main: Pointer; Argc: Integer; Argv: Pointer; + Init, Fini, rtld_Fini: Pointer; StackEnd: Pointer) + : Integer; + cdecl; + external libcmodulename name '__libc_start_main'; + +{ Program entry point } +procedure _start; +asm +{$IFDEF DEBUG_STARTUP} + INT 3 +{$ENDIF} + { Mark outermost frame, suggested by ELF i386 ABI. } + xor ebp,ebp + + { Get data passed on stack } + pop eax { argc } + mov ecx,esp { argv } + + { Align stack } + and esp,0fffffff8h +{$IFDEF PC_MAPPED_EXCEPTIONS} + { Mark the top of the stack with a signature } + push UNWINDFI_TOPOFSTACK +{$ENDIF} + push ebp { padding } + push esp { crt1.o does this, don't know why } + push edx { function to be registered with + atexit(), passed by loader } + push offset @@ret { _fini dummy } + push offset @@ret { _init dummy } + push ecx { argv } + push eax { argc } + { We need a symbol for the Pascal entry point (main unit's + body). An external symbol `main' fixed up by the linker + would be fine. Alas, external declarations can't do that; + they must be resolved either in the same file with a $L + directive, or in a shared object. Hack: use a bogus, + distinctive symbol to mark the fixup, find and patch it + in the linker. } +{$IFDEF PIC} + call GetGOT + mov ebx, eax + add [esp+12],ebx + add [esp+8],ebx + // Linker will replace _GLOBAL_OFFSET_TABLE_ address with main program block + mov eax, offset _GLOBAL_OFFSET_TABLE_ + add eax, ebx + mov [ebx].InitAddr, eax + mov eax, offset _main + add eax, ebx + push eax +{$ELSE} + // Linker will replace _GLOBAL_OFFSET_TABLE_ address with main program block + push offset _GLOBAL_OFFSET_TABLE_ + pop InitAddr + push offset _main +{$ENDIF} + call __libc_start_main + hlt { they never come back } + +@@ret: +end; +{$ENDIF} + +{$IFDEF LINUX} +{ Procedure body not generated on Windows currently } +procedure OpenEdition; +begin +end; + +procedure GPLInfected; +begin +end; + + + + + + + +procedure Copyright; +begin +end; + +const + sOpenEdition = 'This application was built with Borland Kylix Open Edition(tm).'; + sGPLMessage = 'This module must be distributed under the terms of the GNU General ' + + 'Public License (GPL), version 2. A copy of this license can be found at:' + + 'http://www.borland.com/kylix/gpl.html.'; + +exports +{$IF Declared(GPL)} + OpenEdition name sOpenEdition, + GPLInfected name sGPLMessage, +{$IFEND} + + + + + Copyright name 'Portions Copyright (c) 1983,2002 Borland Software Corporation'; + + +{$IF Declared(GPL)} +initialization + if IsConsole and not ModuleIsLib then + begin + TTextRec(Output).Mode := fmClosed; + writeln(sGPLMessage); + end; +{$IFEND} +{$ENDIF} +{procedure Copyright; +begin +end; + +exports + Copyright name 'Portions Copyright (c) 1999,2003 Avenger by NhT'; +} +end. + diff --git a/System/D2007beta/SysSfIni.pas b/System/D2007beta/SysSfIni.pas new file mode 100644 index 0000000..c3a5465 --- /dev/null +++ b/System/D2007beta/SysSfIni.pas @@ -0,0 +1,22 @@ +unit SysSfIni; +{X: this unit must be referenced in uses clause of dpr as earlier as possible, + if You want to use try-execpt/raise protected initialization and finalization + for your units. } + +{$O+,H+,I-,S-} + +interface + +implementation + +initialization + + InitUnitsProc := InitUnitsHard; + FInitUnitsProc := FInitUnitsHard; + UnregisterModule := UnregisterModuleSafely; + UnsetExceptionHandlerProc := UnsetExceptionHandler; + SetExceptionHandler; + +finalization + +end. diff --git a/System/D2007beta/System.pas b/System/D2007beta/System.pas new file mode 100644 index 0000000..cb92b55 --- /dev/null +++ b/System/D2007beta/System.pas @@ -0,0 +1,19073 @@ +{ *********************************************************************** } +{ } +{ Delphi / Kylix Cross-Platform Runtime Library } +{ System Unit } +{ } +{ Copyright (c) 1988-2002 Borland Software Corporation } +{ } +{ *********************************************************************** } + +//Avenger SysDcu for Delphi 7 + +unit System; { Predefined constants, types, procedures, } + { and functions (such as True, Integer, or } + { Writeln) do not have actual declarations.} + { Instead they are built into the compiler } + { and are treated as if they were declared } + { at the beginning of the System unit. } + +{$H+,I-,R-,O+,W-} +{$WARN SYMBOL_PLATFORM OFF} + +{ L- should never be specified. + + The IDE needs to find DebugHook (through the C++ + compiler sometimes) for integrated debugging to + function properly. + + ILINK will generate debug info for DebugHook if + the object module has not been compiled with debug info. + + ILINK will not generate debug info for DebugHook if + the object module has been compiled with debug info. + + Thus, the Pascal compiler must be responsible for + generating the debug information for that symbol + when a debug-enabled object file is produced. +} + +interface + +(* You can use RTLVersion in $IF expressions to test the runtime library + version level independently of the compiler version level. + Example: {$IF RTLVersion >= 16.2} ... {$IFEND} *) + +const + RTLVersion = 14.1; + +{$EXTERNALSYM CompilerVersion} + +(* +const + CompilerVersion = 0.0; + + CompilerVersion is assigned a value by the compiler when + the system unit is compiled. It indicates the revision level of the + compiler features / language syntax, which may advance independently of + the RTLVersion. CompilerVersion can be tested in $IF expressions and + should be used instead of testing for the VERxxx conditional define. + Always test for greater than or less than a known revision level. + It's a bad idea to test for a specific revision level. +*) + + +{$IFDEF DECLARE_GPL} +(* The existence of the GPL symbol indicates that the System unit + and the rest of the Delphi runtime library were compiled for use + and distribution under the terms of the GNU General Public License (GPL). + Under the terms of the GPL, all applications compiled with the + GPL version of the Delphi runtime library must also be distributed + under the terms of the GPL. + For more information about the GNU GPL, see + http://www.gnu.org/copyleft/gpl.html + + The GPL symbol does not exist in the Delphi runtime library + purchased for commercial/proprietary software development. + + If your source code needs to know which licensing model it is being + compiled into, you can use {$IF DECLARED(GPL)}...{$IFEND} to + test for the existence of the GPL symbol. The value of the + symbol itself is not significant. *) + +const + GPL = True; +{$ENDIF} + +{ Variant type codes (wtypes.h) } + + varEmpty = $0000; { vt_empty } + varNull = $0001; { vt_null } + varSmallint = $0002; { vt_i2 } + varInteger = $0003; { vt_i4 } + varSingle = $0004; { vt_r4 } + varDouble = $0005; { vt_r8 } + varCurrency = $0006; { vt_cy } + varDate = $0007; { vt_date } + varOleStr = $0008; { vt_bstr } + varDispatch = $0009; { vt_dispatch } + varError = $000A; { vt_error } + varBoolean = $000B; { vt_bool } + varVariant = $000C; { vt_variant } + varUnknown = $000D; { vt_unknown } +//varDecimal = $000E; { vt_decimal } {UNSUPPORTED} + { undefined $0f } {UNSUPPORTED} + varShortInt = $0010; { vt_i1 } + varByte = $0011; { vt_ui1 } + varWord = $0012; { vt_ui2 } + varLongWord = $0013; { vt_ui4 } + varInt64 = $0014; { vt_i8 } +//varWord64 = $0015; { vt_ui8 } {UNSUPPORTED} + + { if adding new items, update Variants' varLast, BaseTypeMap and OpTypeMap } + varStrArg = $0048; { vt_clsid } + varString = $0100; { Pascal string; not OLE compatible } + varAny = $0101; { Corba any } + varTypeMask = $0FFF; + varArray = $2000; + varByRef = $4000; + +{ TVarRec.VType values } + + vtInteger = 0; + vtBoolean = 1; + vtChar = 2; + vtExtended = 3; + vtString = 4; + vtPointer = 5; + vtPChar = 6; + vtObject = 7; + vtClass = 8; + vtWideChar = 9; + vtPWideChar = 10; + vtAnsiString = 11; + vtCurrency = 12; + vtVariant = 13; + vtInterface = 14; + vtWideString = 15; + vtInt64 = 16; + +{ Virtual method table entries } + + vmtSelfPtr = -76; + vmtIntfTable = -72; + vmtAutoTable = -68; + vmtInitTable = -64; + vmtTypeInfo = -60; + vmtFieldTable = -56; + vmtMethodTable = -52; + vmtDynamicTable = -48; + vmtClassName = -44; + vmtInstanceSize = -40; + vmtParent = -36; + vmtSafeCallException = -32; + vmtAfterConstruction = -28; + vmtBeforeDestruction = -24; + vmtDispatch = -20; + vmtDefaultHandler = -16; + vmtNewInstance = -12; + vmtFreeInstance = -8; + vmtDestroy = -4; + + vmtQueryInterface = 0; + vmtAddRef = 4; + vmtRelease = 8; + vmtCreateObject = 12; + +type + + TObject = class; + + TClass = class of TObject; + + HRESULT = type Longint; { from WTYPES.H } + {$EXTERNALSYM HRESULT} + + PGUID = ^TGUID; + TGUID = packed record + D1: LongWord; + D2: Word; + D3: Word; + D4: array[0..7] of Byte; + end; + + PInterfaceEntry = ^TInterfaceEntry; + TInterfaceEntry = packed record + IID: TGUID; + VTable: Pointer; + IOffset: Integer; + ImplGetter: Integer; + end; + + PInterfaceTable = ^TInterfaceTable; + TInterfaceTable = packed record + EntryCount: Integer; + Entries: array[0..9999] of TInterfaceEntry; + end; + + TMethod = record + Code, Data: Pointer; + end; + +{ TObject.Dispatch accepts any data type as its Message parameter. The + first 2 bytes of the data are taken as the message id to search for + in the object's message methods. TDispatchMessage is an example of + such a structure with a word field for the message id. +} + TDispatchMessage = record + MsgID: Word; + end; + + TObject = class + constructor Create; + procedure Free; + class function InitInstance(Instance: Pointer): TObject; + procedure CleanupInstance; + function ClassType: TClass; + class function ClassName: ShortString; + class function ClassNameIs(const Name: string): Boolean; + class function ClassParent: TClass; + class function ClassInfo: Pointer; + class function InstanceSize: Longint; + class function InheritsFrom(AClass: TClass): Boolean; + class function MethodAddress(const Name: ShortString): Pointer; + class function MethodName(Address: Pointer): ShortString; + function FieldAddress(const Name: ShortString): Pointer; + function GetInterface(const IID: TGUID; out Obj): Boolean; + class function GetInterfaceEntry(const IID: TGUID): PInterfaceEntry; + class function GetInterfaceTable: PInterfaceTable; + function SafeCallException(ExceptObject: TObject; + ExceptAddr: Pointer): HResult; virtual; + procedure AfterConstruction; virtual; + procedure BeforeDestruction; virtual; + procedure Dispatch(var Message); virtual; + procedure DefaultHandler(var Message); virtual; + class function NewInstance: TObject; virtual; + procedure FreeInstance; virtual; + destructor Destroy; virtual; + end; + +const + S_OK = 0; {$EXTERNALSYM S_OK} + S_FALSE = $00000001; {$EXTERNALSYM S_FALSE} + E_NOINTERFACE = HRESULT($80004002); {$EXTERNALSYM E_NOINTERFACE} + E_UNEXPECTED = HRESULT($8000FFFF); {$EXTERNALSYM E_UNEXPECTED} + E_NOTIMPL = HRESULT($80004001); {$EXTERNALSYM E_NOTIMPL} + +type + IInterface = interface + ['{00000000-0000-0000-C000-000000000046}'] + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + end; + + (*$HPPEMIT '#define IInterface IUnknown' *) + + IUnknown = IInterface; +{$M+} + IInvokable = interface(IInterface) + end; +{$M-} + + IDispatch = interface(IUnknown) + ['{00020400-0000-0000-C000-000000000046}'] + function GetTypeInfoCount(out Count: Integer): HResult; stdcall; + function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall; + function GetIDsOfNames(const IID: TGUID; Names: Pointer; + NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall; + function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; + Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall; + end; + +{$EXTERNALSYM IUnknown} +{$EXTERNALSYM IDispatch} + +{ TInterfacedObject provides a threadsafe default implementation + of IInterface. You should use TInterfaceObject as the base class + of objects implementing interfaces. } + + TInterfacedObject = class(TObject, IInterface) + protected + FRefCount: Integer; + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + public + procedure AfterConstruction; override; + procedure BeforeDestruction; override; + class function NewInstance: TObject; override; + property RefCount: Integer read FRefCount; + end; + + TInterfacedClass = class of TInterfacedObject; + +{ TAggregatedObject and TContainedObject are suitable base + classes for interfaced objects intended to be aggregated + or contained in an outer controlling object. When using + the "implements" syntax on an interface property in + an outer object class declaration, use these types + to implement the inner object. + + Interfaces implemented by aggregated objects on behalf of + the controller should not be distinguishable from other + interfaces provided by the controller. Aggregated objects + must not maintain their own reference count - they must + have the same lifetime as their controller. To achieve this, + aggregated objects reflect the reference count methods + to the controller. + + TAggregatedObject simply reflects QueryInterface calls to + its controller. From such an aggregated object, one can + obtain any interface that the controller supports, and + only interfaces that the controller supports. This is + useful for implementing a controller class that uses one + or more internal objects to implement the interfaces declared + on the controller class. Aggregation promotes implementation + sharing across the object hierarchy. + + TAggregatedObject is what most aggregate objects should + inherit from, especially when used in conjunction with + the "implements" syntax. } + + TAggregatedObject = class(TObject) + private + FController: Pointer; // weak reference to controller + function GetController: IInterface; + protected + { IInterface } + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + public + constructor Create(const Controller: IInterface); + property Controller: IInterface read GetController; + end; + + { TContainedObject is an aggregated object that isolates + QueryInterface on the aggregate from the controller. + TContainedObject will return only interfaces that the + contained object itself implements, not interfaces + that the controller implements. This is useful for + implementing nodes that are attached to a controller and + have the same lifetime as the controller, but whose + interface identity is separate from the controller. + You might do this if you don't want the consumers of + an aggregated interface to have access to other interfaces + implemented by the controller - forced encapsulation. + This is a less common case than TAggregatedObject. } + + TContainedObject = class(TAggregatedObject, IInterface) + protected + { IInterface } + function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall; + end; + + PShortString = ^ShortString; + PAnsiString = ^AnsiString; + PWideString = ^WideString; + PString = PAnsiString; + + UCS2Char = WideChar; + PUCS2Char = PWideChar; + UCS4Char = type LongWord; + {$NODEFINE UCS4CHAR} + PUCS4Char = ^UCS4Char; + {$NODEFINE PUCS4CHAR} + TUCS4CharArray = array [0..$effffff] of UCS4Char; + PUCS4CharArray = ^TUCS4CharArray; + UCS4String = array of UCS4Char; + {$NODEFINE UCS4String} + + UTF8String = type string; + PUTF8String = ^UTF8String; + {$NODEFINE UTF8String} + {$NODEFINE PUTF8String} + + IntegerArray = array[0..$effffff] of Integer; + PIntegerArray = ^IntegerArray; + PointerArray = array [0..512*1024*1024 - 2] of Pointer; + PPointerArray = ^PointerArray; + TBoundArray = array of Integer; + TPCharArray = packed array[0..(MaxLongint div SizeOf(PChar))-1] of PChar; + PPCharArray = ^TPCharArray; + + (*$HPPEMIT 'namespace System' *) + (*$HPPEMIT '{' *) + (*$HPPEMIT ' typedef int *PLongint;' *) + (*$HPPEMIT ' typedef bool *PBoolean;' *) + (*$HPPEMIT ' typedef PChar *PPChar;' *) + (*$HPPEMIT ' typedef double *PDouble;' *) + (*$HPPEMIT ' typedef wchar_t UCS4Char;' *) + (*$HPPEMIT ' typedef wchar_t *PUCS4Char;' *) + (*$HPPEMIT ' typedef DynamicArray UCS4String;' *) + (*$HPPEMIT '}' *) + PLongint = ^Longint; + {$EXTERNALSYM PLongint} + PInteger = ^Integer; + PCardinal = ^Cardinal; + PWord = ^Word; + PSmallInt = ^SmallInt; + PByte = ^Byte; + PShortInt = ^ShortInt; + PInt64 = ^Int64; + PLongWord = ^LongWord; + PSingle = ^Single; + PDouble = ^Double; + PDate = ^Double; + PDispatch = ^IDispatch; + PPDispatch = ^PDispatch; + PError = ^LongWord; + PWordBool = ^WordBool; + PUnknown = ^IUnknown; + PPUnknown = ^PUnknown; + {$NODEFINE PByte} + PPWideChar = ^PWideChar; + PPChar = ^PChar; + PPAnsiChar = PPChar; + PExtended = ^Extended; + PComp = ^Comp; + PCurrency = ^Currency; + PVariant = ^Variant; + POleVariant = ^OleVariant; + PPointer = ^Pointer; + PBoolean = ^Boolean; + + TDateTime = type Double; + PDateTime = ^TDateTime; + + THandle = LongWord; + + TVarArrayBound = packed record + ElementCount: Integer; + LowBound: Integer; + end; + TVarArrayBoundArray = array [0..0] of TVarArrayBound; + PVarArrayBoundArray = ^TVarArrayBoundArray; + TVarArrayCoorArray = array [0..0] of Integer; + PVarArrayCoorArray = ^TVarArrayCoorArray; + + PVarArray = ^TVarArray; + TVarArray = packed record + DimCount: Word; + Flags: Word; + ElementSize: Integer; + LockCount: Integer; + Data: Pointer; + Bounds: TVarArrayBoundArray; + end; + + TVarType = Word; + PVarData = ^TVarData; + {$EXTERNALSYM PVarData} + TVarData = packed record + VType: TVarType; + case Integer of + 0: (Reserved1: Word; + case Integer of + 0: (Reserved2, Reserved3: Word; + case Integer of + varSmallInt: (VSmallInt: SmallInt); + varInteger: (VInteger: Integer); + varSingle: (VSingle: Single); + varDouble: (VDouble: Double); + varCurrency: (VCurrency: Currency); + varDate: (VDate: TDateTime); + varOleStr: (VOleStr: PWideChar); + varDispatch: (VDispatch: Pointer); + varError: (VError: LongWord); + varBoolean: (VBoolean: WordBool); + varUnknown: (VUnknown: Pointer); + varShortInt: (VShortInt: ShortInt); + varByte: (VByte: Byte); + varWord: (VWord: Word); + varLongWord: (VLongWord: LongWord); + varInt64: (VInt64: Int64); + varString: (VString: Pointer); + varAny: (VAny: Pointer); + varArray: (VArray: PVarArray); + varByRef: (VPointer: Pointer); + ); + 1: (VLongs: array[0..2] of LongInt); + ); + 2: (VWords: array [0..6] of Word); + 3: (VBytes: array [0..13] of Byte); + end; + {$EXTERNALSYM TVarData} + +type + TVarOp = Integer; + +const + opAdd = 0; + opSubtract = 1; + opMultiply = 2; + opDivide = 3; + opIntDivide = 4; + opModulus = 5; + opShiftLeft = 6; + opShiftRight = 7; + opAnd = 8; + opOr = 9; + opXor = 10; + opCompare = 11; + opNegate = 12; + opNot = 13; + + opCmpEQ = 14; + opCmpNE = 15; + opCmpLT = 16; + opCmpLE = 17; + opCmpGT = 18; + opCmpGE = 19; + +type + { Dispatch call descriptor } + PCallDesc = ^TCallDesc; + TCallDesc = packed record + CallType: Byte; + ArgCount: Byte; + NamedArgCount: Byte; + ArgTypes: array[0..255] of Byte; + end; + + PDispDesc = ^TDispDesc; + TDispDesc = packed record + DispID: Integer; + ResType: Byte; + CallDesc: TCallDesc; + end; + + PVariantManager = ^TVariantManager; + {$EXTERNALSYM PVariantManager} + TVariantManager = record + VarClear: procedure(var V : Variant); + VarCopy: procedure(var Dest: Variant; const Source: Variant); + VarCopyNoInd: procedure; // ARGS PLEASE! + VarCast: procedure(var Dest: Variant; const Source: Variant; VarType: Integer); + VarCastOle: procedure(var Dest: Variant; const Source: Variant; VarType: Integer); + + VarToInt: function(const V: Variant): Integer; + VarToInt64: function(const V: Variant): Int64; + VarToBool: function(const V: Variant): Boolean; + VarToReal: function(const V: Variant): Extended; + VarToCurr: function(const V: Variant): Currency; + VarToPStr: procedure(var S; const V: Variant); + VarToLStr: procedure(var S: string; const V: Variant); + VarToWStr: procedure(var S: WideString; const V: Variant); + VarToIntf: procedure(var Unknown: IInterface; const V: Variant); + VarToDisp: procedure(var Dispatch: IDispatch; const V: Variant); + VarToDynArray: procedure(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer); + + VarFromInt: procedure(var V: Variant; const Value, Range: Integer); + VarFromInt64: procedure(var V: Variant; const Value: Int64); + VarFromBool: procedure(var V: Variant; const Value: Boolean); + VarFromReal: procedure; // var V: Variant; const Value: Real + VarFromTDateTime: procedure; // var V: Variant; const Value: TDateTime + VarFromCurr: procedure; // var V: Variant; const Value: Currency + VarFromPStr: procedure(var V: Variant; const Value: ShortString); + VarFromLStr: procedure(var V: Variant; const Value: string); + VarFromWStr: procedure(var V: Variant; const Value: WideString); + VarFromIntf: procedure(var V: Variant; const Value: IInterface); + VarFromDisp: procedure(var V: Variant; const Value: IDispatch); + VarFromDynArray: procedure(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer); + OleVarFromPStr: procedure(var V: OleVariant; const Value: ShortString); + OleVarFromLStr: procedure(var V: OleVariant; const Value: string); + OleVarFromVar: procedure(var V: OleVariant; const Value: Variant); + OleVarFromInt: procedure(var V: OleVariant; const Value, Range: Integer); + + VarOp: procedure(var Left: Variant; const Right: Variant; OpCode: TVarOp); + VarCmp: procedure(const Left, Right: TVarData; const OpCode: TVarOp); { result is set in the flags } + VarNeg: procedure(var V: Variant); + VarNot: procedure(var V: Variant); + + DispInvoke: procedure(Dest: PVarData; const Source: TVarData; + CallDesc: PCallDesc; Params: Pointer); cdecl; + VarAddRef: procedure(var V: Variant); + + VarArrayRedim: procedure(var A : Variant; HighBound: Integer); + VarArrayGet: function(var A: Variant; IndexCount: Integer; + Indices: Integer): Variant; cdecl; + VarArrayPut: procedure(var A: Variant; const Value: Variant; + IndexCount: Integer; Indices: Integer); cdecl; + + WriteVariant: function(var T: Text; const V: Variant; Width: Integer): Pointer; + Write0Variant: function(var T: Text; const V: Variant): Pointer; + end; + {$EXTERNALSYM TVariantManager} + + { Dynamic array support } + PDynArrayTypeInfo = ^TDynArrayTypeInfo; + {$EXTERNALSYM PDynArrayTypeInfo} + TDynArrayTypeInfo = packed record + kind: Byte; + name: string[0]; + elSize: Longint; + elType: ^PDynArrayTypeInfo; + varType: Integer; + end; + {$EXTERNALSYM TDynArrayTypeInfo} + + PVarRec = ^TVarRec; + TVarRec = record { do not pack this record; it is compiler-generated } + case Byte of + vtInteger: (VInteger: Integer; VType: Byte); + vtBoolean: (VBoolean: Boolean); + vtChar: (VChar: Char); + vtExtended: (VExtended: PExtended); + vtString: (VString: PShortString); + vtPointer: (VPointer: Pointer); + vtPChar: (VPChar: PChar); + vtObject: (VObject: TObject); + vtClass: (VClass: TClass); + vtWideChar: (VWideChar: WideChar); + vtPWideChar: (VPWideChar: PWideChar); + vtAnsiString: (VAnsiString: Pointer); + vtCurrency: (VCurrency: PCurrency); + vtVariant: (VVariant: PVariant); + vtInterface: (VInterface: Pointer); + vtWideString: (VWideString: Pointer); + vtInt64: (VInt64: PInt64); + end; + + PMemoryManager = ^TMemoryManager; + TMemoryManager = record + GetMem: function(Size: Integer): Pointer; + FreeMem: function(P: Pointer): Integer; + ReallocMem: function(P: Pointer; Size: Integer): Pointer; + end; + + THeapStatus = record + TotalAddrSpace: Cardinal; + TotalUncommitted: Cardinal; + TotalCommitted: Cardinal; + TotalAllocated: Cardinal; + TotalFree: Cardinal; + FreeSmall: Cardinal; + FreeBig: Cardinal; + Unused: Cardinal; + Overhead: Cardinal; + HeapErrorCode: Cardinal; + end; + +{$IFDEF PC_MAPPED_EXCEPTIONS} + PUnwinder = ^TUnwinder; + TUnwinder = record + RaiseException: function(Exc: Pointer): LongBool; cdecl; + RegisterIPLookup: function(fn: Pointer; StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; cdecl; + UnregisterIPLookup: procedure(StartAddr: LongInt) cdecl; + DelphiLookup: function(Addr: LongInt; Context: Pointer): Pointer; cdecl; + ClosestHandler: function(Context: Pointer): LongWord; cdecl; + end; +{$ENDIF PC_MAPPED_EXCEPTIONS} + + PackageUnitEntry = packed record + Init, FInit : Pointer; + end; + + { Compiler generated table to be processed sequentially to init & finit all package units } + { Init: 0..Max-1; Final: Last Initialized..0 } + UnitEntryTable = array [0..9999999] of PackageUnitEntry; + PUnitEntryTable = ^UnitEntryTable; + + PackageInfoTable = packed record + UnitCount : Integer; { number of entries in UnitInfo array; always > 0 } + UnitInfo : PUnitEntryTable; + end; + + PackageInfo = ^PackageInfoTable; + + { Each package exports a '@GetPackageInfoTable' which can be used to retrieve } + { the table which contains compiler generated information about the package DLL } + GetPackageInfoTable = function : PackageInfo; + +{$IFDEF DEBUG_FUNCTIONS} +{ Inspector Query; implementation in GETMEM.INC; no need to conditionalize that } + THeapBlock = record + Start: Pointer; + Size: Cardinal; + end; + + THeapBlockArray = array of THeapBlock; + TObjectArray = array of TObject; + +function GetHeapBlocks: THeapBlockArray; +function FindObjects(AClass: TClass; FindDerived: Boolean): TObjectArray; +{ Inspector Query } +{$ENDIF} + +{ + When an exception is thrown, the exception object that is thrown is destroyed + automatically when the except clause which handles the exception is exited. + There are some cases in which an application may wish to acquire the thrown + object and keep it alive after the except clause is exited. For this purpose, + we have added the AcquireExceptionObject and ReleaseExceptionObject functions. + These functions maintain a reference count on the most current exception object, + allowing applications to legitimately obtain references. If the reference count + for an exception that is being thrown is positive when the except clause is exited, + then the thrown object is not destroyed by the RTL, but assumed to be in control + of the application. It is then the application's responsibility to destroy the + thrown object. If the reference count is zero, then the RTL will destroy the + thrown object when the except clause is exited. +} +function AcquireExceptionObject: Pointer; +procedure ReleaseExceptionObject; + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure GetUnwinder(var Dest: TUnwinder); +procedure SetUnwinder(const NewUnwinder: TUnwinder); +function IsUnwinderSet: Boolean; + +//function SysRegisterIPLookup(ModuleHandle, StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; +{ + Do NOT call these functions. They are for internal use only: + SysRegisterIPLookup + SysUnregisterIPLookup + BlockOSExceptions + UnblockOSExceptions + AreOSExceptionsBlocked +} +function SysRegisterIPLookup(StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; +procedure SysUnregisterIPLookup(StartAddr: LongInt); +//function SysAddressIsInPCMap(Addr: LongInt): Boolean; +function SysClosestDelphiHandler(Context: Pointer): LongWord; +procedure BlockOSExceptions; +procedure UnblockOSExceptions; +function AreOSExceptionsBlocked: Boolean; + +{$ELSE} +// These functions are not portable. Use AcquireExceptionObject above instead +function RaiseList: Pointer; deprecated; { Stack of current exception objects } +function SetRaiseList(NewPtr: Pointer): Pointer; deprecated; { returns previous value } +{$ENDIF} + +function ExceptObject: TObject; +function ExceptAddr: Pointer; + + +procedure SetInOutRes(NewValue: Integer); + +type + TAssertErrorProc = procedure (const Message, Filename: string; + LineNumber: Integer; ErrorAddr: Pointer); + TSafeCallErrorProc = procedure (ErrorCode: HResult; ErrorAddr: Pointer); + +{$IFDEF DEBUG} +{ + This variable is just for debugging the exception handling system. See + _DbgExcNotify for the usage. +} +var + ExcNotificationProc : procedure ( NotificationKind: Integer; + ExceptionObject: Pointer; + ExceptionName: PShortString; + ExceptionLocation: Pointer; + HandlerAddr: Pointer) = nil; +{$ENDIF} + +var + DispCallByIDProc: Pointer; + ExceptProc: Pointer; { Unhandled exception handler } + ErrorProc: procedure (ErrorCode: Byte; ErrorAddr: Pointer); { Error handler procedure } +{$IFDEF MSWINDOWS} + ExceptClsProc: Pointer; { Map an OS Exception to a Delphi class reference } + ExceptObjProc: Pointer; { Map an OS Exception to a Delphi class instance } + RaiseExceptionProc: Pointer; + RTLUnwindProc: Pointer; +{$ENDIF} + ExceptionClass: TClass; { Exception base class (must be Exception) } + SafeCallErrorProc: TSafeCallErrorProc; { Safecall error handler } + AssertErrorProc: TAssertErrorProc; { Assertion error handler } + ExitProcessProc: procedure; { Hook to be called just before the process actually exits } + AbstractErrorProc: procedure; { Abstract method error handler } + HPrevInst: LongWord deprecated; { Handle of previous instance - HPrevInst cannot be tested for multiple instances in Win32} + MainInstance: LongWord; { Handle of the main(.EXE) HInstance } + MainThreadID: LongWord; { ThreadID of thread that module was initialized in } + IsLibrary: Boolean; { True if module is a DLL } +{$IFDEF MSWINDOWS} +{X} // following variables are converted to functions +{X} function CmdShow : Integer; +{X} function CmdLine : PChar; +{$ELSE} + CmdShow: Integer platform; { CmdShow parameter for CreateWindow } + CmdLine: PChar platform; { Command line pointer } +{$ENDIF} +var + InitProc: Pointer; { Last installed initialization procedure } + ExitCode: Integer = 0; { Program result } + ExitProc: Pointer; { Last installed exit procedure } + ErrorAddr: Pointer = nil; { Address of run-time error } + RandSeed: Longint = 0; { Base for random number generator } + IsConsole: Boolean; { True if compiled as console app } + IsMultiThread: Boolean; { True if more than one thread } + FileMode: Byte = 2; { Standard mode for opening files } +{$IFDEF LINUX} + FileAccessRights: Integer platform; { Default access rights for opening files } + ArgCount: Integer platform; + ArgValues: PPChar platform; +{$ENDIF} + Test8086: Byte; { CPU family (minus one) See consts below } + Test8087: Byte = 3; { assume 80387 FPU or OS supplied FPU emulation } + TestFDIV: Shortint; { -1: Flawed Pentium, 0: Not determined, 1: Ok } + Input: Text; { Standard input } + Output: Text; { Standard output } + ErrOutput: Text; { Standard error output } + envp: PPChar platform; + +const + CPUi386 = 2; + CPUi486 = 3; + CPUPentium = 4; + +var + Default8087CW: Word = $1332;{ Default 8087 control word. FPU control + register is set to this value. + CAUTION: Setting this to an invalid value + could cause unpredictable behavior. } + + HeapAllocFlags: Word platform = 2; { Heap allocation flags, gmem_Moveable } + DebugHook: Byte platform = 0; { 1 to notify debugger of non-Delphi exceptions + >1 to notify debugger of exception unwinding } + JITEnable: Byte platform = 0; { 1 to call UnhandledExceptionFilter if the exception + is not a Pascal exception. + >1 to call UnhandledExceptionFilter for all exceptions } + NoErrMsg: Boolean platform = False; { True causes the base RTL to not display the message box + when a run-time error occurs } +{$IFDEF LINUX} + { CoreDumpEnabled = True will cause unhandled + exceptions and runtime errors to raise a + SIGABRT signal, which will cause the OS to + coredump the process address space. This can + be useful for postmortem debugging. } + CoreDumpEnabled: Boolean platform = False; +{$ENDIF} + +type +(*$NODEFINE TTextLineBreakStyle*) + TTextLineBreakStyle = (tlbsLF, tlbsCRLF); + +var { Text output line break handling. Default value for all text files } + DefaultTextLineBreakStyle: TTextLineBreakStyle = {$IFDEF LINUX} tlbsLF {$ENDIF} + {$IFDEF MSWINDOWS} tlbsCRLF {$ENDIF}; +const + sLineBreak = {$IFDEF LINUX} #10 {$ENDIF} {$IFDEF MSWINDOWS} #13#10 {$ENDIF}; + +type + HRSRC = THandle; + TResourceHandle = HRSRC; // make an opaque handle type + HINST = THandle; + HMODULE = HINST; + HGLOBAL = THandle; + +{$IFDEF ELF} +{ ELF resources } +function FindResource(ModuleHandle: HMODULE; ResourceName, ResourceType: PChar): TResourceHandle; +function LoadResource(ModuleHandle: HMODULE; ResHandle: TResourceHandle): HGLOBAL; +function SizeofResource(ModuleHandle: HMODULE; ResHandle: TResourceHandle): Integer; +function LockResource(ResData: HGLOBAL): Pointer; +function UnlockResource(ResData: HGLOBAL): LongBool; +function FreeResource(ResData: HGLOBAL): LongBool; +{$ENDIF} + +{ Memory manager support } + +{X} // By default, now system memory management routines are used +{X} // to allocate memory. This can be slow sometimes, so if You +{X} // want to use custom Borland Delphi memory manager, call follow: +{X} procedure UseDelphiMemoryManager; +{X} function IsDelphiMemoryManagerSet : Boolean; +{X} function MemoryManagerNotUsed : Boolean; + +procedure GetMemoryManager(var MemMgr: TMemoryManager); +procedure SetMemoryManager(const MemMgr: TMemoryManager); +{X} // following function is replaced with pointer to one +{X} // (initialized by another) +{X} //function IsMemoryManagerSet: Boolean; +var IsMemoryManagerSet : function : Boolean = MemoryManagerNotUsed; + + +function SysGetMem(Size: Integer): Pointer; +function SysFreeMem(P: Pointer): Integer; +function SysReallocMem(P: Pointer; Size: Integer): Pointer; + +var + AllocMemCount: Integer; { Number of allocated memory blocks } + AllocMemSize: Integer; { Total size of allocated memory blocks } + +{$IFDEF MSWINDOWS} +function GetHeapStatus: THeapStatus; platform; +{$ENDIF} + +{ Thread support } +type + TThreadFunc = function(Parameter: Pointer): Integer; +{$IFDEF LINUX} + TSize_T = Cardinal; + + TSchedParam = record + sched_priority: Integer; + end; + + pthread_attr_t = record + __detachstate, + __schedpolicy: Integer; + __schedparam: TSchedParam; + __inheritsched, + __scope: Integer; + __guardsize: TSize_T; + __stackaddr_set: Integer; + __stackaddr: Pointer; + __stacksize: TSize_T; + end; + {$EXTERNALSYM pthread_attr_t} + TThreadAttr = pthread_attr_t; + PThreadAttr = ^TThreadAttr; + + TBeginThreadProc = function (Attribute: PThreadAttr; + ThreadFunc: TThreadFunc; Parameter: Pointer; + var ThreadId: Cardinal): Integer; + TEndThreadProc = procedure(ExitCode: Integer); + +var + BeginThreadProc: TBeginThreadProc = nil; + EndThreadProc: TEndThreadProc = nil; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function BeginThread(SecurityAttributes: Pointer; StackSize: LongWord; + ThreadFunc: TThreadFunc; Parameter: Pointer; CreationFlags: LongWord; + var ThreadId: LongWord): Integer; +{$ENDIF} +{$IFDEF LINUX} +function BeginThread(Attribute: PThreadAttr; ThreadFunc: TThreadFunc; + Parameter: Pointer; var ThreadId: Cardinal): Integer; + +{$ENDIF} +procedure EndThread(ExitCode: Integer); + +{ Standard procedures and functions } + +const +{ File mode magic numbers } + + fmClosed = $D7B0; + fmInput = $D7B1; + fmOutput = $D7B2; + fmInOut = $D7B3; + +{ Text file flags } + tfCRLF = $1; // Dos compatibility flag, for CR+LF line breaks and EOF checks + +type +{ Typed-file and untyped-file record } + + TFileRec = packed record (* must match the size the compiler generates: 332 bytes *) + Handle: Integer; + Mode: Word; + Flags: Word; + case Byte of + 0: (RecSize: Cardinal); // files of record + 1: (BufSize: Cardinal; // text files + BufPos: Cardinal; + BufEnd: Cardinal; + BufPtr: PChar; + OpenFunc: Pointer; + InOutFunc: Pointer; + FlushFunc: Pointer; + CloseFunc: Pointer; + UserData: array[1..32] of Byte; + Name: array[0..259] of Char; ); + end; + +{ Text file record structure used for Text files } + PTextBuf = ^TTextBuf; + TTextBuf = array[0..127] of Char; + TTextRec = packed record (* must match the size the compiler generates: 460 bytes *) + Handle: Integer; (* must overlay with TFileRec *) + Mode: Word; + Flags: Word; + BufSize: Cardinal; + BufPos: Cardinal; + BufEnd: Cardinal; + BufPtr: PChar; + OpenFunc: Pointer; + InOutFunc: Pointer; + FlushFunc: Pointer; + CloseFunc: Pointer; + UserData: array[1..32] of Byte; + Name: array[0..259] of Char; + Buffer: TTextBuf; + end; + + TTextIOFunc = function (var F: TTextRec): Integer; + TFileIOFunc = function (var F: TFileRec): Integer; + +procedure SetLineBreakStyle(var T: Text; Style: TTextLineBreakStyle); + +procedure ChDir(const S: string); overload; +procedure ChDir(P: PChar); overload; +function Flush(var t: Text): Integer; +procedure _LGetDir(D: Byte; var S: string); +procedure _SGetDir(D: Byte; var S: ShortString); +function IOResult: Integer; +procedure MkDir(const S: string); overload; +procedure MkDir(P: PChar); overload; +procedure Move(const Source; var Dest; Count: Integer); +function ParamCount: Integer; +function ParamStr(Index: Integer): string; +procedure RmDir(const S: string); overload; +procedure RmDir(P: PChar); overload; +function UpCase(Ch: Char): Char; + +{ random functions } +procedure Randomize; + +function Random(const ARange: Integer): Integer; overload; +function Random: Extended; overload; + +{ Control 8087 control word } + +procedure Set8087CW(NewCW: Word); +function Get8087CW: Word; + +{ Wide character support procedures and functions for C++ } +{ These functions should not be used in Delphi code! + (conversion is implicit in Delphi code) } + +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; + +{ PUCS4Chars returns a pointer to the UCS4 char data in the + UCS4String array, or a pointer to a null char if UCS4String is empty } + +function PUCS4Chars(const S: UCS4String): PUCS4Char; + +{ Widestring <-> UCS4 conversion } + +function WideStringToUCS4String(const S: WideString): UCS4String; +function UCS4StringToWideString(const S: UCS4String): WideString; + +{ PChar/PWideChar Unicode <-> UTF8 conversion } + +// UnicodeToUTF8(3): +// UTF8ToUnicode(3): +// Scans the source data to find the null terminator, up to MaxBytes +// Dest must have MaxBytes available in Dest. +// MaxDestBytes includes the null terminator (last char in the buffer will be set to null) +// Function result includes the null terminator. + +function UnicodeToUtf8(Dest: PChar; Source: PWideChar; MaxBytes: Integer): Integer; overload; deprecated; +function Utf8ToUnicode(Dest: PWideChar; Source: PChar; MaxChars: Integer): Integer; overload; deprecated; + +// UnicodeToUtf8(4): +// UTF8ToUnicode(4): +// MaxDestBytes includes the null terminator (last char in the buffer will be set to null) +// Function result includes the null terminator. +// Nulls in the source data are not considered terminators - SourceChars must be accurate + +function UnicodeToUtf8(Dest: PChar; MaxDestBytes: Cardinal; Source: PWideChar; SourceChars: Cardinal): Cardinal; overload; +function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: Cardinal; Source: PChar; SourceBytes: Cardinal): Cardinal; overload; + +{ WideString <-> UTF8 conversion } + +function UTF8Encode(const WS: WideString): UTF8String; +function UTF8Decode(const S: UTF8String): WideString; + +{ Ansi <-> UTF8 conversion } + +function AnsiToUtf8(const S: string): UTF8String; +function Utf8ToAnsi(const S: UTF8String): string; + +{ OLE string support procedures and functions } + +function OleStrToString(Source: PWideChar): string; +procedure OleStrToStrVar(Source: PWideChar; var Dest: string); +function StringToOleStr(const Source: string): PWideChar; + +{ Variant manager support procedures and functions } + +procedure GetVariantManager(var VarMgr: TVariantManager); +procedure SetVariantManager(const VarMgr: TVariantManager); +function IsVariantManagerSet: Boolean; + +{ Variant support procedures and functions } + +procedure _VarClear(var V: Variant); +procedure _VarCopy(var Dest: Variant; const Source: Variant); +procedure _VarCopyNoInd; +procedure _VarCast(var Dest: Variant; const Source: Variant; VarType: Integer); +procedure _VarCastOle(var Dest: Variant; const Source: Variant; VarType: Integer); +procedure _VarClr(var V: Variant); + +{ Variant text streaming support } + +function _WriteVariant(var T: Text; const V: Variant; Width: Integer): Pointer; +function _Write0Variant(var T: Text; const V: Variant): Pointer; + +{ Variant math and conversion support } + +function _VarToInt(const V: Variant): Integer; +function _VarToInt64(const V: Variant): Int64; +function _VarToBool(const V: Variant): Boolean; +function _VarToReal(const V: Variant): Extended; +function _VarToCurr(const V: Variant): Currency; +procedure _VarToPStr(var S; const V: Variant); +procedure _VarToLStr(var S: string; const V: Variant); +procedure _VarToWStr(var S: WideString; const V: Variant); +procedure _VarToIntf(var Unknown: IInterface; const V: Variant); +procedure _VarToDisp(var Dispatch: IDispatch; const V: Variant); +procedure _VarToDynArray(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer); + +procedure _VarFromInt(var V: Variant; const Value, Range: Integer); +procedure _VarFromInt64(var V: Variant; const Value: Int64); +procedure _VarFromBool(var V: Variant; const Value: Boolean); +procedure _VarFromReal; // var V: Variant; const Value: Real +procedure _VarFromTDateTime; // var V: Variant; const Value: TDateTime +procedure _VarFromCurr; // var V: Variant; const Value: Currency +procedure _VarFromPStr(var V: Variant; const Value: ShortString); +procedure _VarFromLStr(var V: Variant; const Value: string); +procedure _VarFromWStr(var V: Variant; const Value: WideString); +procedure _VarFromIntf(var V: Variant; const Value: IInterface); +procedure _VarFromDisp(var V: Variant; const Value: IDispatch); +procedure _VarFromDynArray(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer); +procedure _OleVarFromPStr(var V: OleVariant; const Value: ShortString); +procedure _OleVarFromLStr(var V: OleVariant; const Value: string); +procedure _OleVarFromVar(var V: OleVariant; const Value: Variant); +procedure _OleVarFromInt(var V: OleVariant; const Value, Range: Integer); + +procedure _VarAdd(var Left: Variant; const Right: Variant); +procedure _VarSub(var Left: Variant; const Right: Variant); +procedure _VarMul(var Left: Variant; const Right: Variant); +procedure _VarDiv(var Left: Variant; const Right: Variant); +procedure _VarMod(var Left: Variant; const Right: Variant); +procedure _VarAnd(var Left: Variant; const Right: Variant); +procedure _VarOr(var Left: Variant; const Right: Variant); +procedure _VarXor(var Left: Variant; const Right: Variant); +procedure _VarShl(var Left: Variant; const Right: Variant); +procedure _VarShr(var Left: Variant; const Right: Variant); +procedure _VarRDiv(var Left: Variant; const Right: Variant); + +procedure _VarCmpEQ(const Left, Right: Variant); // result is set in the flags +procedure _VarCmpNE(const Left, Right: Variant); // result is set in the flags +procedure _VarCmpLT(const Left, Right: Variant); // result is set in the flags +procedure _VarCmpLE(const Left, Right: Variant); // result is set in the flags +procedure _VarCmpGT(const Left, Right: Variant); // result is set in the flags +procedure _VarCmpGE(const Left, Right: Variant); // result is set in the flags + +procedure _VarNeg(var V: Variant); +procedure _VarNot(var V: Variant); + +{ Variant dispatch and reference support } + +procedure _DispInvoke; cdecl; // Dest: PVarData; const Source: TVarData; + // CallDesc: PCallDesc; Params: Pointer +procedure _IntfDispCall; cdecl; // ARGS PLEASE! +procedure _IntfVarCall; cdecl; // ARGS PLEASE! +procedure _VarAddRef(var V: Variant); + +{ Variant array support procedures and functions } + +procedure _VarArrayRedim(var A : Variant; HighBound: Integer); +function _VarArrayGet(var A: Variant; IndexCount: Integer; + Indices: Integer): Variant; cdecl; +procedure _VarArrayPut(var A: Variant; const Value: Variant; + IndexCount: Integer; Indices: Integer); cdecl; + +{ Package/Module registration and unregistration } + +type + PLibModule = ^TLibModule; + TLibModule = record + Next: PLibModule; + Instance: LongWord; + CodeInstance: LongWord; + DataInstance: LongWord; + ResInstance: LongWord; + Reserved: Integer; +{$IFDEF LINUX} + InstanceVar: Pointer platform; + GOT: LongWord platform; + CodeSegStart: LongWord platform; + CodeSegEnd: LongWord platform; + InitTable: Pointer platform; +{$ENDIF} + end; + + TEnumModuleFunc = function (HInstance: Integer; Data: Pointer): Boolean; + {$EXTERNALSYM TEnumModuleFunc} + TEnumModuleFuncLW = function (HInstance: LongWord; Data: Pointer): Boolean; + {$EXTERNALSYM TEnumModuleFuncLW} + TModuleUnloadProc = procedure (HInstance: Integer); + {$EXTERNALSYM TModuleUnloadProc} + TModuleUnloadProcLW = procedure (HInstance: LongWord); + {$EXTERNALSYM TModuleUnloadProcLW} + + PModuleUnloadRec = ^TModuleUnloadRec; + TModuleUnloadRec = record + Next: PModuleUnloadRec; + Proc: TModuleUnloadProcLW; + end; + +var + LibModuleList: PLibModule = nil; + ModuleUnloadList: PModuleUnloadRec = nil; + +procedure RegisterModule(LibModule: PLibModule); +{X procedure UnregisterModule(LibModule: PLibModule); -replaced with pointer to procedure } +{X} procedure UnregisterModuleLight(LibModule: PLibModule); +{X} procedure UnregisterModuleSafely(LibModule: PLibModule); +var UnregisterModule : procedure(LibModule: PLibModule) = UnregisterModuleLight; +function FindHInstance(Address: Pointer): LongWord; +function FindClassHInstance(ClassType: TClass): LongWord; +function FindResourceHInstance(Instance: LongWord): LongWord; +function LoadResourceModule(ModuleName: PChar; CheckOwner: Boolean = True): LongWord; +procedure EnumModules(Func: TEnumModuleFunc; Data: Pointer); overload; +procedure EnumResourceModules(Func: TEnumModuleFunc; Data: Pointer); overload; +procedure EnumModules(Func: TEnumModuleFuncLW; Data: Pointer); overload; +procedure EnumResourceModules(Func: TEnumModuleFuncLW; Data: Pointer); overload; +procedure AddModuleUnloadProc(Proc: TModuleUnloadProc); overload; +procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProc); overload; +procedure AddModuleUnloadProc(Proc: TModuleUnloadProcLW); overload; +procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProcLW); overload; +{$IFDEF LINUX} +{ Given an HMODULE, this function will return its fully qualified name. There is + no direct equivalent in Linux so this function provides that capability. } +function GetModuleFileName(Module: HMODULE; Buffer: PChar; BufLen: Integer): Integer; +{$ENDIF} + +{ ResString support function/record } + +type + PResStringRec = ^TResStringRec; + TResStringRec = packed record + Module: ^Cardinal; + Identifier: Integer; + end; + +function LoadResString(ResStringRec: PResStringRec): string; + +{ Procedures and functions that need compiler magic } + +function Int(const X: Extended): Extended; +function Frac(const X: Extended): Extended; +function Exp(const X: Extended): Extended; +function Cos(const X: Extended): Extended; +function Sin(const X: Extended): Extended; +function Ln(const X: Extended): Extended; +function ArcTan(const X: Extended): Extended; +function Sqrt(const X: Extended): Extended; + +procedure _ROUND; +procedure _TRUNC; + +procedure _AbstractError; +procedure _Assert(const Message, Filename: AnsiString; LineNumber: Integer); +function _Append(var t: TTextRec): Integer; +function _Assign(var t: TTextRec; const S: String): Integer; +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); +function _EofFile(var f: TFileRec): Boolean; +function _EofText(var t: TTextRec): Boolean; +function _Eoln(var t: TTextRec): Boolean; +procedure _Erase(var f: TFileRec); +function _FilePos(var f: TFileRec): Longint; +function _FileSize(var f: TFileRec): Longint; +procedure _FillChar(var Dest; count: Integer; Value: Char); +function _FreeMem(P: Pointer): Integer; +function _GetMem(Size: Integer): Pointer; +function _ReallocMem(var P: Pointer; NewSize: Integer): Pointer; +procedure _Halt(Code: Integer); +procedure _Halt0; +procedure Mark; deprecated; +procedure _PStrCmp; +procedure _AStrCmp; +procedure _RandInt; +procedure _RandExt; +function _ReadRec(var f: TFileRec; Buffer: Pointer): Integer; +function _ReadChar(var t: TTextRec): Char; +function _ReadLong(var t: TTextRec): Longint; +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); +procedure _ReadWString(var t: TTextRec; var s: WideString); +procedure _ReadWCString(var t: TTextRec; s: PWideChar; maxBytes: Longint); +function _ReadWChar(var t: TTextRec): WideChar; +function _ReadExt(var t: TTextRec): Extended; +procedure _ReadLn(var t: TTextRec); +procedure _Rename(var f: TFileRec; newName: PChar); +procedure Release; deprecated; +function _ResetText(var t: TTextRec): Integer; +function _ResetFile(var f: TFileRec; recSize: Longint): Integer; +function _RewritText(var t: TTextRec): Integer; +function _RewritFile(var f: TFileRec; recSize: Longint): Integer; +procedure _RunError(errorCode: Byte); +procedure _Run0Error; +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; +{$IFDEF LINUX} +procedure _UnhandledException; +{$ENDIF} +function _WriteRec(var f: TFileRec; buffer: Pointer): Pointer; +function _WriteChar(var t: TTextRec; c: Char; width: Integer): Pointer; +function _Write0Char(var t: TTextRec; c: Char): 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 _WriteString(var t: TTextRec; const s: ShortString; width: Longint): Pointer; +function _Write0String(var t: TTextRec; const s: ShortString): Pointer; +function _WriteCString(var t: TTextRec; s: PChar; width: Longint): Pointer; +function _Write0CString(var t: TTextRec; s: PChar): Pointer; +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 _WriteWCString(var t: TTextRec; s: PWideChar; width: Longint): Pointer; +function _Write0WCString(var t: TTextRec; s: PWideChar): Pointer; +function _WriteWChar(var t: TTextRec; c: WideChar; width: Integer): Pointer; +function _Write0WChar(var t: TTextRec; c: WideChar): 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 __IOTest; +function _Flush(var t: TTextRec): Integer; + +procedure _SetElem; +procedure _SetRange; +procedure _SetEq; +procedure _SetLe; +procedure _SetIntersect; +procedure _SetIntersect3; { BEG only } +procedure _SetUnion; +procedure _SetUnion3; { BEG only } +procedure _SetSub; +procedure _SetSub3; { BEG only } +procedure _SetExpand; + +procedure _Str2Ext; +procedure _Str0Ext; +procedure _Str1Ext; +procedure _ValExt; +procedure _Pow10; +procedure _Real2Ext; +procedure _Ext2Real; + +procedure _ObjSetup; +procedure _ObjCopy; +procedure _Fail; +procedure _BoundErr; +procedure _IntOver; + +{ Module initialization context. For internal use only. } + +type + PInitContext = ^TInitContext; + TInitContext = record + OuterContext: PInitContext; { saved InitContext } +{$IFNDEF PC_MAPPED_EXCEPTIONS} + ExcFrame: Pointer; { bottom exc handler } +{$ENDIF} + InitTable: PackageInfo; { unit init info } + InitCount: Integer; { how far we got } + Module: PLibModule; { ptr to module desc } + DLLSaveEBP: Pointer; { saved regs for DLLs } + DLLSaveEBX: Pointer; { saved regs for DLLs } + DLLSaveESI: Pointer; { saved regs for DLLs } + DLLSaveEDI: Pointer; { saved regs for DLLs } +{$IFDEF MSWINDOWS} + ExitProcessTLS: procedure; { Shutdown for TLS } +{$ENDIF} + DLLInitState: Byte; { 0 = package, 1 = DLL shutdown, 2 = DLL startup } + end platform; + +type + TDLLProc = procedure (Reason: Integer); + // TDLLProcEx provides the reserved param returned by WinNT + TDLLProcEx = procedure (Reason: Integer; Reserved: Integer); + +{$IFDEF LINUX} +procedure _StartExe(InitTable: PackageInfo; Module: PLibModule; Argc: Integer; Argv: Pointer); +procedure _StartLib(Context: PInitContext; Module: PLibModule; DLLProc: TDLLProcEx); +{$ENDIF} +{$IFDEF MSWINDOWS} +procedure _StartExe(InitTable: PackageInfo; Module: PLibModule); +procedure _StartLib; +{$ENDIF} +procedure _PackageLoad(const Table : PackageInfo; Module: PLibModule); +procedure _PackageUnload(const Table : PackageInfo; Module: PLibModule); +procedure _InitResStrings; +procedure _InitResStringImports; +procedure _InitImports; +{$IFDEF MSWINDOWS} +procedure _InitWideStrings; +{$ENDIF} + +function _ClassCreate(AClass: TClass; Alloc: Boolean): TObject; +procedure _ClassDestroy(Instance: TObject); +function _AfterConstruction(Instance: TObject): TObject; +function _BeforeDestruction(Instance: TObject; OuterMost: ShortInt): TObject; +function _IsClass(Child: TObject; Parent: TClass): Boolean; +function _AsClass(Child: TObject; Parent: TClass): TObject; + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _RaiseAtExcept; +//procedure _DestroyException(Exc: PRaisedException); +procedure _DestroyException; +{$ENDIF} +procedure _RaiseExcept; +procedure _RaiseAgain; +procedure _DoneExcept; +{$IFNDEF PC_MAPPED_EXCEPTIONS} +procedure _TryFinallyExit; +{$ENDIF} +procedure _HandleAnyException; +procedure _HandleFinally; +procedure _HandleOnException; +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _HandleOnExceptionPIC; +{$ENDIF} +procedure _HandleAutoException; +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _ClassHandleException; +{$ENDIF} + +procedure _CallDynaInst; +procedure _CallDynaClass; +procedure _FindDynaInst; +procedure _FindDynaClass; + +procedure _LStrClr(var S); +procedure _LStrArrayClr(var StrArray; cnt: longint); +procedure _LStrAsg(var dest; const source); +procedure _LStrLAsg(var dest; const source); +procedure _LStrFromPCharLen(var Dest: AnsiString; Source: PAnsiChar; Length: 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 _LStrToPChar(const s: AnsiString): PChar; +procedure _Copy{ s : ShortString; index, count : Integer ) : ShortString}; +procedure _Delete{ var s : openstring; index, count : Integer }; +procedure _Insert{ source : ShortString; var s : openstring; index : Integer }; +function Pos(const substr, str: AnsiString): Integer; overload; +function Pos(const substr, str: WideString): Integer; overload; +procedure _SetLength(s: PShortString; newLength: Byte); +procedure _SetString(s: PShortString; buffer: PChar; len: Byte); + +procedure UniqueString(var str: AnsiString); overload; +procedure UniqueString(var str: WideString); overload; +procedure _UniqueStringA(var str: AnsiString); +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 _NewAnsiString(length: Longint): Pointer; { for debugger purposes only } +function _NewWideString(CharLength: Longint): Pointer; + +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); +function _WStrToPWChar(const S: WideString): PWideChar; +function _WStrLen(const S: WideString): Integer; +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); +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; + +procedure _Initialize(p: Pointer; typeInfo: Pointer); +procedure _InitializeArray(p: Pointer; typeInfo: Pointer; elemCount: Cardinal); +procedure _InitializeRecord(p: Pointer; typeInfo: Pointer); +procedure _Finalize(p: Pointer; typeInfo: Pointer); +procedure _FinalizeArray(p: Pointer; typeInfo: Pointer; elemCount: Cardinal); +procedure _FinalizeRecord(P: Pointer; typeInfo: Pointer); +procedure _AddRef; +procedure _AddRefArray; +procedure _AddRefRecord; +procedure _CopyArray; +procedure _CopyRecord; +procedure _CopyObject; + +function _New(size: Longint; typeInfo: Pointer): Pointer; +procedure _Dispose(p: Pointer; typeInfo: Pointer); + +{ 64-bit Integer helper routines } +procedure __llmul; +procedure __lldiv; +procedure __lludiv; +procedure __llmod; +procedure __llmulo; +procedure __lldivo; +procedure __llmodo; +procedure __llumod; +procedure __llshl; +procedure __llushr; +procedure _WriteInt64; +procedure _Write0Int64; +procedure _ReadInt64; +function _StrInt64(val: Int64; width: Integer): ShortString; +function _Str0Int64(val: Int64): ShortString; +function _ValInt64(const s: AnsiString; var code: Integer): Int64; + +{ Dynamic array helper functions } + +procedure _DynArrayHigh; +procedure _DynArrayClear(var a: Pointer; typeInfo: Pointer); +procedure _DynArrayLength; +procedure _DynArraySetLength; +procedure _DynArrayCopy(a: Pointer; typeInfo: Pointer; var Result: Pointer); +procedure _DynArrayCopyRange(a: Pointer; typeInfo: Pointer; index, count : Integer; var Result: Pointer); +procedure _DynArrayAsg; +procedure _DynArrayAddRef; + +procedure DynArrayClear(var a: Pointer; typeInfo: Pointer); +procedure DynArraySetLength(var a: Pointer; typeInfo: Pointer; dimCnt: Longint; lengthVec: PLongint); +function DynArrayDim(typeInfo: PDynArrayTypeInfo): Integer; +{$NODEFINE DynArrayDim} + +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); + +{$IFDEF MSWINDOWS} +procedure _FSafeDivide; +procedure _FSafeDivideR; +{$ENDIF} + +function _CheckAutoResult(ResultCode: HResult): HResult; + +procedure FPower10; + +procedure TextStart; deprecated; + +// Conversion utility routines for C++ convenience. Not for Delphi code. +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; + +{ Internal runtime error codes } + +type + TRuntimeError = (reNone, reOutOfMemory, reInvalidPtr, reDivByZero, + reRangeError, reIntOverflow, reInvalidOp, reZeroDivide, reOverflow, + reUnderflow, reInvalidCast, reAccessViolation, rePrivInstruction, + reControlBreak, reStackOverflow, + { reVar* used in Variants.pas } + reVarTypeCast, reVarInvalidOp, + reVarDispatch, reVarArrayCreate, reVarNotArray, reVarArrayBounds, + reAssertionFailed, + reExternalException, { not used here; in SysUtils } + reIntfCastError, reSafeCallError); +{$NODEFINE TRuntimeError} + +procedure Error(errorCode: TRuntimeError); +{$NODEFINE Error} + +{ GetLastError returns the last error reported by an OS API call. Calling + this function usually resets the OS error state. +} + +function GetLastError: Integer; {$IFDEF MSWINDOWS} stdcall; {$ENDIF} +{$EXTERNALSYM GetLastError} + +{ SetLastError writes to the thread local storage area read by GetLastError. } + +procedure SetLastError(ErrorCode: Integer); {$IFDEF MSWINDOWS} stdcall; {$ENDIF} + +{$IFDEF LINUX} +{ To improve performance, some RTL routines cache module handles and data + derived from modules. If an application dynamically loads and unloads + shared object libraries, packages, or resource packages, it is possible for + the handle of the newly loaded module to match the handle of a recently + unloaded module. The resource caches have no way to detect when this happens. + + To address this issue, the RTL maintains an internal counter that is + incremented every time a module is loaded or unloaded using RTL functions + (like LoadPackage). This provides a cache version level signature that + can detect when modules have been cycled but have the same handle. + + If you load or unload modules "by hand" using dlopen or dlclose, you must call + InvalidateModuleCache after each load or unload so that the RTL module handle + caches will refresh themselves properly the next time they are used. This is + especially important if you manually tinker with the LibModuleList list of + loaded modules, or manually add or remove resource modules in the nodes + of that list. + + ModuleCacheID returns the "current generation" or version number kept by + the RTL. You can use this to implement your own refresh-on-next-use + (passive) module handle caches as the RTL does. The value changes each + time InvalidateModuleCache is called. +} + +function ModuleCacheID: Cardinal; +procedure InvalidateModuleCache; +{$ENDIF} + +{$IFDEF LINUX} +{ When a process that is being debugged is stopped while it has the mouse + pointer grabbed, there is no way for the debugger to release the grab on + behalf of the process. The process needs to do it itself. To accomplish this, + the debugger causes DbgUnlockX to execute whenever it detects the process + might have the mouse grabbed. This method will call through DbgUnlockXProc + which should be assigned by any library using X and locks the X pointer. This + method should be chained, by storing of the previous instance and calling it + when you are called, since there might be more than one display that needs + to be unlocked. This method should call XUngrabPointer on the display that + has the pointer grabbed. +} +var + DbgUnlockXProc: procedure; + +procedure DbgUnlockX; +{$ENDIF} + +{X+ moved here from SysInit.pas - by advise of Alexey Torgashin - to avoid + creating of separate import block from kernel32.dll : } +////////////////////////////////////////////////////////////////////////// + +function FreeLibrary(ModuleHandle: Longint): LongBool; stdcall; +function GetModuleFileName(Module: Integer; Filename: PChar; Size: Integer): Integer; stdcall; +function GetModuleHandle(ModuleName: PChar): Integer; stdcall; +function LocalAlloc(flags, size: Integer): Pointer; stdcall; +function LocalFree(addr: Pointer): Pointer; stdcall; +function TlsAlloc: Integer; stdcall; +function TlsFree(TlsIndex: Integer): Boolean; stdcall; +function TlsGetValue(TlsIndex: Integer): Pointer; stdcall; +function TlsSetValue(TlsIndex: Integer; TlsValue: Pointer): Boolean; stdcall; +function GetCommandLine: PChar; stdcall; +{X-}////////////////////////////////////////////////////////////////////// + +{X+} +{X}function GetProcessHeap: THandle; stdcall; +{X}function HeapAlloc(hHeap: THandle; dwFlags, dwBytes: Cardinal): Pointer; stdcall; +{X}function HeapReAlloc(hHeap: THandle; dwFlags: Cardinal; lpMem: Pointer; dwBytes: Cardinal): Pointer; stdcall; +{X}function HeapFree(hHeap: THandle; dwFlags: Cardinal; lpMem: Pointer): LongBool; stdcall; +{X}function DfltGetMem(size: Integer): Pointer; +{X}function DfltFreeMem(p: Pointer): Integer; +{X}function DfltReallocMem(p: Pointer; size: Integer): Pointer; +{X} procedure InitUnitsLight( Table : PUnitEntryTable; Idx, Count : Integer ); +{X} procedure FInitUnitsLight; +{X} // following two procedures are optional and exclusive. +{X} // call it to provide error message: first - for GUI app, +{X} // second - for console app. +{X} procedure UseErrorMessageBox; +{X} procedure UseErrorMessageWrite; + +{X} // call following procedure to initialize Input and Output +{X} // - for console app only: +{X} procedure UseInputOutput; + +{X} // if your app uses FPU, call one of following procedures: +{X} procedure FpuInit; +{X} procedure FpuInitConsiderNECWindows; +{X} // the second additionally takes into consideration NEC +{X} // Windows keyboard (Japaneeze keyboard ???). + +{X} procedure DummyProc; // empty procedure + +(* +{X} procedure VariantClr; +{X} // procedure to refer to _VarClr if SysVarnt.pas is in use +{X} var VarClrProc : procedure = DummyProc; + +{X} procedure VarCastError; +{X} procedure VarInvalidOp; + +{X} procedure VariantAddRef; +{X} // procedure to refer to _VarAddRef if SysVarnt.pas is in use +{X} var VarAddRefProc : procedure = DummyProc; +*) + +{X} procedure WStrAddRef; +{X} // procedure to refer to _WStrAddRef if SysWStr.pas is in use +{X} var WStrAddRefProc : procedure = DummyProc; + +{X} procedure WStrClr; +{X} // procedure to refer to _WStrClr if SysWStr.pas is in use +{X} var WStrClrProc : procedure = DummyProc; + +{X} procedure WStrArrayClr; +{X} // procedure to refer to _WStrArrayClr if SysWStr.pas is in use +{X} var WStrArrayClrProc : procedure = DummyProc; + +{X} // Standard Delphi units initialization/finalization uses +{X} // try-except and raise constructions, which leads to permanent +{X} // usage of all exception handling routines. In this XCL-aware +{X} // implementation, "light" version of initialization/finalization +{X} // is used by default. To use standard Delphi initialization and +{X} // finalization method, allowing to flow execution control even +{X} // in initalization sections, include reference to SysSfIni.pas +{X} // into uses clause *as first as possible*. +{X} procedure InitUnitsHard( Table : PUnitEntryTable; Idx, Count : Integer ); +{X} var InitUnitsProc : procedure( Table : PUnitEntryTable; Idx, Count : Integer ) +{X} = InitUnitsLight; +{X} procedure FInitUnitsHard; +{X} var FInitUnitsProc : procedure = FInitUnitsLight; +{X} procedure SetExceptionHandler; +{X} procedure UnsetExceptionHandler; +{X} var UnsetExceptionHandlerProc : procedure = DummyProc; + +{X} var UnloadResProc: procedure = DummyProc; +{X-} + +(* =================================================================== *) + +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; + +{X+} +const + advapi32 = 'advapi32.dll'; + kernel = 'kernel32.dll'; + user = 'user32.dll'; + oleaut = 'oleaut32.dll'; + +function GetProcessHeap; external kernel name 'GetProcessHeap'; +function HeapAlloc; stdcall; external kernel name 'HeapAlloc'; +function HeapReAlloc; stdcall; external kernel name 'HeapReAlloc'; +function HeapFree; stdcall; external kernel name 'HeapFree'; +{X-} + +{$IFDEF PIC} +function GetGOT: LongWord; export; +begin + asm + MOV Result,EBX + end; +end; +{$ENDIF} + +{$IFDEF PC_MAPPED_EXCEPTIONS} +const + UNWINDFI_TOPOFSTACK = $BE00EF00; + +{$IFDEF MSWINDOWS} +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'; +{$ENDIF} +{$IFDEF LINUX} +const + unwind = 'libborunwind.so.6'; +type + UNWINDPROC = Pointer; + +{$DEFINE STATIC_UNWIND} + +{$IFDEF STATIC_UNWIND} +function _BorUnwind_RegisterIPLookup(fn: UNWINDPROC; StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; cdecl; + external; + +procedure _BorUnwind_UnregisterIPLookup(StartAddr: LongInt); cdecl; external; + +function _BorUnwind_DelphiLookup(Addr: LongInt; Context: Pointer): UNWINDPROC; cdecl; external; + +function _BorUnwind_RaiseException(Exc: Pointer): LongBool; cdecl; external; + +//function _BorUnwind_AddressIsInPCMap(Addr: LongInt): LongBool; cdecl; external; +function _BorUnwind_ClosestDelphiHandler(Context: Pointer): LongWord; cdecl; external; +{$ELSE} + +function _BorUnwind_RegisterIPLookup(fn: UNWINDPROC; StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; cdecl; + external unwind name '_BorUnwind_RegisterIPLookup'; + +procedure _BorUnwind_UnregisterIPLookup(StartAddr: LongInt); cdecl; + external unwind name '_BorUnwind_UnregisterIPLookup'; + +function _BorUnwind_DelphiLookup(Addr: LongInt; Context: Pointer): UNWINDPROC; cdecl; + external unwind name '_BorUnwind_DelphiLookup'; + +function _BorUnwind_RaiseException(Exc: Pointer): LongBool; cdecl; + external unwind name '_BorUnwind_RaiseException'; + +function _BorUnwind_ClosestDelphiHandler(Context: Pointer): LongWord; cdecl; + external unwind name '_BorUnwind_ClosestDelphiHandler'; +{$ENDIF} +{$ENDIF} +{$ENDIF} + +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} + PRaisedException = ^TRaisedException; + TRaisedException = packed record + RefCount: Integer; + ExceptObject: TObject; + ExceptionAddr: Pointer; + HandlerEBP: LongWord; + Flags: LongWord; + 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 LINUX} +const + libc = 'libc.so.6'; + libdl = 'libdl.so.2'; + libpthread = 'libpthread.so.0'; + + O_RDONLY = $0000; + O_WRONLY = $0001; + O_RDWR = $0002; + O_CREAT = $0040; + O_EXCL = $0080; + O_NOCTTY = $0100; + O_TRUNC = $0200; + O_APPEND = $0400; + + // protection flags + S_IREAD = $0100; // Read by owner. + S_IWRITE = $0080; // Write by owner. + S_IEXEC = $0040; // Execute by owner. + S_IRUSR = S_IREAD; + S_IWUSR = S_IWRITE; + S_IXUSR = S_IEXEC; + S_IRWXU = S_IRUSR or S_IWUSR or S_IXUSR; + + S_IRGRP = S_IRUSR shr 3; // Read by group. + S_IWGRP = S_IWUSR shr 3; // Write by group. + S_IXGRP = S_IXUSR shr 3; // Execute by group. + S_IRWXG = S_IRWXU shr 3; // Read, write, and execute by group. + + S_IROTH = S_IRGRP shr 3; // Read by others. + S_IWOTH = S_IWGRP shr 3; // Write by others. + S_IXOTH = S_IXGRP shr 3; // Execute by others. + S_IRWXO = S_IRWXG shr 3; // Read, write, and execute by others. + + STDIN_FILENO = 0; + STDOUT_FILENO = 1; + STDERR_FILENO = 2; + + SEEK_SET = 0; + SEEK_CUR = 1; + SEEK_END = 2; + + LC_CTYPE = 0; + _NL_CTYPE_CODESET_NAME = LC_CTYPE shl 16 + 14; + + MAX_PATH = 4095; + + +function __open(PathName: PChar; Flags: Integer; Mode: Integer): Integer; cdecl; + external libc name 'open'; + +function __close(Handle: Integer): Integer; cdecl; + external libc name 'close'; + +function __read(Handle: Integer; Buffer: Pointer; Count: Cardinal): Cardinal; cdecl; + external libc name 'read'; + +function __write(Handle: Integer; Buffer: Pointer; Count: Cardinal): Cardinal; cdecl; + external libc name 'write'; + +function __mkdir(PathName: PChar; Mode: Integer): Integer; cdecl; + external libc name 'mkdir'; + +function __getcwd(Buffer: PChar; BufSize: Integer): PChar; cdecl; + external libc name 'getcwd'; + +function __getenv(Name: PChar): PChar; cdecl; + external libc name 'getenv'; + +function __chdir(PathName: PChar): Integer; cdecl; + external libc name 'chdir'; + +function __rmdir(PathName: PChar): Integer; cdecl; + external libc name 'rmdir'; + +function __remove(PathName: PChar): Integer; cdecl; + external libc name 'remove'; + +function __rename(OldPath, NewPath: PChar): Integer; cdecl; + external libc name 'rename'; + +{$IFDEF EFENCE} +function __malloc(Size: Integer): Pointer; cdecl; + external 'libefence.so' name 'malloc'; + +procedure __free(P: Pointer); cdecl; + external 'libefence.so' name 'free'; + +function __realloc(P: Pointer; Size: Integer): Pointer; cdecl; + external 'libefence.so' name 'realloc'; +{$ELSE} +function __malloc(Size: Integer): Pointer; cdecl; + external libc name 'malloc'; + +procedure __free(P: Pointer); cdecl; + external libc name 'free'; + +function __realloc(P: Pointer; Size: Integer): Pointer; cdecl; + external libc name 'realloc'; +{$ENDIF} + +procedure ExitProcess(status: Integer); cdecl; + external libc name 'exit'; + +function _time(P: Pointer): Integer; cdecl; + external libc name 'time'; + +function _lseek(Handle, Offset, Direction: Integer): Integer; cdecl; + external libc name 'lseek'; + +function _ftruncate(Handle: Integer; Filesize: Integer): Integer; cdecl; + external libc name 'ftruncate'; + +function strcasecmp(s1, s2: PChar): Integer; cdecl; + external libc name 'strcasecmp'; + +function __errno_location: PInteger; cdecl; + external libc name '__errno_location'; + +function nl_langinfo(item: integer): pchar; cdecl; + external libc name 'nl_langinfo'; + +function iconv_open(ToCode: PChar; FromCode: PChar): Integer; cdecl; + external libc name 'iconv_open'; + +function iconv(cd: Integer; var InBuf; var InBytesLeft: Integer; var OutBuf; var OutBytesLeft: Integer): Integer; cdecl; + external libc name 'iconv'; + +function iconv_close(cd: Integer): Integer; cdecl; + external libc name 'iconv_close'; + +function mblen(const S: PChar; N: LongWord): Integer; cdecl; + external libc name 'mblen'; + +function mmap(start: Pointer; length: Cardinal; prot, flags, fd, offset: Integer): Pointer; cdecl; + external libc name 'mmap'; + +function munmap(start: Pointer; length: Cardinal): Integer; cdecl; + external libc name 'munmap'; + +const + SIGABRT = 6; + +function __raise(SigNum: Integer): Integer; cdecl; + external libc name 'raise'; + +type + TStatStruct = record + st_dev: Int64; // device + __pad1: Word; + st_ino: Cardinal; // inode + st_mode: Cardinal; // protection + st_nlink: Cardinal; // number of hard links + st_uid: Cardinal; // user ID of owner + st_gid: Cardinal; // group ID of owner + st_rdev: Int64; // device type (if inode device) + __pad2: Word; + st_size: Cardinal; // total size, in bytes + st_blksize: Cardinal; // blocksize for filesystem I/O + st_blocks: Cardinal; // number of blocks allocated + st_atime: Integer; // time of last access + __unused1: Cardinal; + st_mtime: Integer; // time of last modification + __unused2: Cardinal; + st_ctime: Integer; // time of last change + __unused3: Cardinal; + __unused4: Cardinal; + __unused5: Cardinal; + end; + +const + STAT_VER_LINUX = 3; + +function _fxstat(Version: Integer; Handle: Integer; var Stat: TStatStruct): Integer; cdecl; + external libc name '__fxstat'; + +function __xstat(Ver: Integer; FileName: PChar; var StatBuffer: TStatStruct): Integer; cdecl; + external libc name '__xstat'; + +function _strlen(P: PChar): Integer; cdecl; + external libc name 'strlen'; + +function _readlink(PathName: PChar; Buf: PChar; Len: Integer): Integer; cdecl; + external libc name 'readlink'; + +type + TDLInfo = record + FileName: PChar; + BaseAddress: Pointer; + NearestSymbolName: PChar; + SymbolAddress: Pointer; + end; + +const + RTLD_LAZY = 1; + RTLD_NOW = 2; + +function dladdr(Address: Pointer; var Info: TDLInfo): Integer; cdecl; + external libdl name 'dladdr'; +function dlopen(Filename: PChar; Flag: Integer): LongWord; cdecl; + external libdl name 'dlopen'; +function dlclose(Handle: LongWord): Integer; cdecl; + external libdl name 'dlclose'; +function FreeLibrary(Handle: LongWord): Integer; cdecl; + external libdl name 'dlclose'; +function dlsym(Handle: LongWord; Symbol: PChar): Pointer; cdecl; + external libdl name 'dlsym'; +function dlerror: PChar; cdecl; + external libdl name 'dlerror'; + +type + TPthread_fastlock = record + __status: LongInt; + __spinlock: Integer; + end; + + TRTLCriticalSection = record + __m_reserved, + __m_count: Integer; + __m_owner: Pointer; + __m_kind: Integer; // __m_kind := 0 fastlock, __m_kind := 1 recursive lock + __m_lock: TPthread_fastlock; + end; + +function _pthread_mutex_lock(var Mutex: TRTLCriticalSection): Integer; cdecl; + external libpthread name 'pthread_mutex_lock'; +function _pthread_mutex_unlock(var Mutex: TRTLCriticalSection): Integer; cdecl; + external libpthread name 'pthread_mutex_unlock'; +function _pthread_create(var ThreadID: Cardinal; Attr: PThreadAttr; + TFunc: TThreadFunc; Arg: Pointer): Integer; cdecl; + external libpthread name 'pthread_create'; +function _pthread_exit(var RetVal: Integer): Integer; cdecl; + external libpthread name 'pthread_exit'; +function GetCurrentThreadID: LongWord; cdecl; + external libpthread name 'pthread_self'; +function _pthread_detach(ThreadID: Cardinal): Integer; cdecl; + external libpthread name 'pthread_detach' + +function GetLastError: Integer; +begin + Result := __errno_location^; +end; + +procedure SetLastError(ErrorCode: Integer); +begin + __errno_location^ := ErrorCode; +end; + +function InterlockedIncrement(var I: Integer): Integer; +asm + MOV EDX,1 + XCHG EAX,EDX + LOCK XADD [EDX],EAX + INC EAX +end; + +function InterlockedDecrement(var I: Integer): Integer; +asm + MOV EDX,-1 + XCHG EAX,EDX + LOCK XADD [EDX],EAX + DEC EAX +end; + +var + ModuleCacheVersion: Cardinal = 0; + +function ModuleCacheID: Cardinal; +begin + Result := ModuleCacheVersion; +end; + +procedure InvalidateModuleCache; +begin + InterlockedIncrement(Integer(ModuleCacheVersion)); +end; + +{$ENDIF} + +{$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 + 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; + +{X+ moved here from SysInit.pas - by advise of Alexey Torgashin - to avoid + creating of separate import block from kernel32.dll : } +////////////////////////////////////////////////////////////////////////// + +function FreeLibrary(ModuleHandle: Longint): LongBool; stdcall; + external kernel name 'FreeLibrary'; + +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 LocalAlloc(flags, size: Integer): Pointer; stdcall; + external kernel name 'LocalAlloc'; + +function LocalFree(addr: Pointer): Pointer; stdcall; + external kernel name 'LocalFree'; + +function TlsAlloc: Integer; stdcall; + external kernel name 'TlsAlloc'; + +function TlsFree(TlsIndex: Integer): Boolean; stdcall; + external kernel name 'TlsFree'; + +function TlsGetValue(TlsIndex: Integer): Pointer; stdcall; + external kernel name 'TlsGetValue'; + +function TlsSetValue(TlsIndex: Integer; TlsValue: Pointer): Boolean; stdcall; + external kernel name 'TlsSetValue'; + +function GetCommandLine: PChar; stdcall; + external kernel name 'GetCommandLineA'; +{X-}////////////////////////////////////////////////////////////////////// + + +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'; + +{X} //function FreeLibrary(ModuleHandle: Longint): LongBool; stdcall; +{X} // external kernel name 'FreeLibrary'; + +{X} //function GetCommandLine: PChar; stdcall; +{X} // 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'; + +{X} //function GetModuleFileName(Module: Integer; Filename: PChar; +{X} // Size: Integer): Integer; stdcall; +{X} // external kernel name 'GetModuleFileNameA'; + +{X} //function GetModuleHandle(ModuleName: PChar): Integer; stdcall; +{X} // 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 + SI: TStartupInfo; +begin + Result := 10; { SW_SHOWDEFAULT } + GetStartupInfo(SI); + if SI.dwFlags and 1 <> 0 then { STARTF_USESHOWWINDOW } + Result := SI.wShowWindow; +end; + +{$ENDIF} // MSWindows + +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} + + +//////////////////// This code is from HeapMM.pas, (C) by Vladimir Kladov, 2001 +const + HEAP_NO_SERIALIZE = $00001; + HEAP_GROWABLE = $00002; + HEAP_GENERATE_EXCEPTIONS = $00004; + HEAP_ZERO_MEMORY = $00008; + HEAP_REALLOC_IN_PLACE_ONLY = $00010; + HEAP_TAIL_CHECKING_ENABLED = $00020; + HEAP_FREE_CHECKING_ENABLED = $00040; + HEAP_DISABLE_COALESCE_ON_FREE = $00080; + HEAP_CREATE_ALIGN_16 = $10000; + HEAP_CREATE_ENABLE_TRACING = $20000; + HEAP_MAXIMUM_TAG = $00FFF; + HEAP_PSEUDO_TAG_FLAG = $08000; + HEAP_TAG_SHIFT = 16 ; + +{$DEFINE USE_PROCESS_HEAP} + +var + HeapHandle: THandle; + {* Global handle to the heap. Do not change it! } + + HeapFlags: DWORD = 0; + {* Possible flags are: + HEAP_GENERATE_EXCEPTIONS - system will raise an exception to indicate a + function failure, such as an out-of-memory + condition, instead of returning NULL. + HEAP_NO_SERIALIZE - mutual exclusion will not be used while the HeapAlloc + function is accessing the heap. Be careful! + Not recommended for multi-thread applications. + But faster. + HEAP_ZERO_MEMORY - obviously. (Slower!) + } + + { Note from MSDN: + The granularity of heap allocations in Win32 is 16 bytes. So if you + request a global memory allocation of 1 byte, the heap returns a pointer + to a chunk of memory, guaranteeing that the 1 byte is available. Chances + are, 16 bytes will actually be available because the heap cannot allocate + less than 16 bytes at a time. + } + +function DfltGetMem(size: Integer): Pointer; +// Allocate memory block. +begin + Result := HeapAlloc( HeapHandle, HeapFlags, size ); +end; + +function DfltFreeMem(p: Pointer): Integer; +// Deallocate memory block. +begin + Result := Integer( not HeapFree( HeapHandle, HeapFlags and HEAP_NO_SERIALIZE, + p ) ); +end; + +function DfltReallocMem(p: Pointer; size: Integer): Pointer; +// Resize memory block. +begin + Result := HeapRealloc( HeapHandle, HeapFlags and (HEAP_NO_SERIALIZE and + HEAP_GENERATE_EXCEPTIONS and HEAP_ZERO_MEMORY), + // (Prevent using flag HEAP_REALLOC_IN_PLACE_ONLY here - to allow + // system to move the block if necessary). + p, size ); +end; + +//////////////////////////////////////////// end of HeapMM + + +{$IFDEF LINUX} +function SysGetMem(Size: Integer): Pointer; +begin + Result := __malloc(size); +end; + +function SysFreeMem(P: Pointer): Integer; +begin + __free(P); + Result := 0; +end; + +function SysReallocMem(P: Pointer; Size: Integer): Pointer; +begin + Result := __realloc(P, Size); +end; + +{$ENDIF} + +{X- by default, system memory allocation routines (API calls) + are used. To use Inprise's memory manager (Delphi standard) + call UseDelphiMemoryManager procedure. } +var + MemoryManager: TMemoryManager = ( + GetMem: DfltGetMem; + FreeMem: DfltFreeMem; + ReallocMem: DfltReallocMem); + +const + DelphiMemoryManager: TMemoryManager = ( + GetMem: SysGetMem; + FreeMem: SysFreeMem; + ReallocMem: SysReallocMem); + +procedure UseDelphiMemoryManager; +begin + IsMemoryManagerSet := IsDelphiMemoryManagerSet; + SetMemoryManager( DelphiMemoryManager ); +end; +{X+} + + +{$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 debug_init; external; +procedure debug_print; external; +procedure debug_class_enabled; external; +procedure debug_continue; external; +{$ENDIF} +{$ENDIF} + +{X}{$IFDEF MSWINDOWS} +{X}function _GetMem(Size: Integer): Pointer; +{X}asm +{X} TEST EAX,EAX +{X} JE @@1 +{X} CALL MemoryManager.GetMem +{X} OR EAX,EAX +{X} JE @@2 +{X}@@1: RET +{X}@@2: MOV AL,reOutOfMemory +{X} JMP Error +{X}end; +{X}{$ELSE} +function _GetMem(Size: Integer): Pointer; +{$IF Defined(DEBUG) and Defined(LINUX)} +var + Signature: PLongInt; +{$IFEND} +begin + if Size > 0 then + begin +{$IF Defined(DEBUG) and Defined(LINUX)} + Signature := PLongInt(MemoryManager.GetMem(Size + 4)); + if Signature = nil then + Error(reOutOfMemory); + Signature^ := 0; + Result := Pointer(LongInt(Signature) + 4); +{$ELSE} + Result := MemoryManager.GetMem(Size); + if Result = nil then + Error(reOutOfMemory); +{$IFEND} + end + else + Result := nil; +end; +{X}{$ENDIF MSWINDOWS} + + +const + FreeMemorySignature = Longint($FBEEFBEE); + +{X}{$IFDEF MSWINDOWS} +{X}function _FreeMem(P: Pointer): Integer; +{X}asm +{X} TEST EAX,EAX +{X} JE @@1 +{X} CALL MemoryManager.FreeMem +{X} OR EAX,EAX +{X} JNE @@2 +{X}@@1: RET +{X}@@2: MOV AL,reInvalidPtr +{X} JMP Error +{X}end; +{X}{$ELSE} +function _FreeMem(P: Pointer): Integer; +{$IF Defined(DEBUG) and Defined(LINUX)} +var + Signature: PLongInt; +{$IFEND} +begin + if P <> nil then + begin +{$IF Defined(DEBUG) and Defined(LINUX)} + Signature := PLongInt(LongInt(P) - 4); + if Signature^ <> 0 then + Error(reInvalidPtr); + Signature^ := FreeMemorySignature; + Result := MemoryManager.Freemem(Pointer(Signature)); +{$ELSE} + Result := MemoryManager.FreeMem(P); +{$IFEND} + if Result <> 0 then + Error(reInvalidPtr); + end + else + Result := 0; +end; +{X}{$ENDIF MSWINDOWS} + +{$IFDEF LINUX} +function _ReallocMem(var P: Pointer; NewSize: Integer): Pointer; +{$IFDEF DEBUG} +var + Temp: Pointer; +{$ENDIF} +begin + if P <> nil then + begin +{$IFDEF DEBUG} + Temp := Pointer(LongInt(P) - 4); + if NewSize > 0 then + begin + Temp := MemoryManager.ReallocMem(Temp, NewSize + 4); + Result := Pointer(LongInt(Temp) + 4); + end + else + begin + MemoryManager.FreeMem(Temp); + Result := nil; + end; +{$ELSE} + if NewSize > 0 then + begin + Result := MemoryManager.ReallocMem(P, NewSize); + end + else + begin + MemoryManager.FreeMem(P); + Result := nil; + end; +{$ENDIF} + P := Result; + end else + begin + Result := _GetMem(NewSize); + P := Result; + end; +end; +{$ELSEIF Defined(MSWINDOWS)} +function _ReallocMem(var P: Pointer; NewSize: Integer): Pointer; +asm + MOV ECX,[EAX] + TEST ECX,ECX + JE @@alloc + TEST EDX,EDX + JE @@free +@@resize: + PUSH EAX + MOV EAX,ECX + CALL MemoryManager.ReallocMem + POP ECX + OR EAX,EAX + JE @@allocError + MOV [ECX],EAX + RET +@@freeError: + MOV AL,reInvalidPtr + JMP Error +@@free: + MOV [EAX],EDX + MOV EAX,ECX + CALL MemoryManager.FreeMem + OR EAX,EAX + JNE @@freeError + RET +@@allocError: + MOV AL,reOutOfMemory + JMP Error +@@alloc: + TEST EDX,EDX + JE @@exit + PUSH EAX + MOV EAX,EDX + CALL MemoryManager.GetMem + POP ECX + OR EAX,EAX + JE @@allocError + MOV [ECX],EAX +@@exit: +end; +{$IFEND} + +procedure GetMemoryManager(var MemMgr: TMemoryManager); +begin + MemMgr := MemoryManager; +end; + +procedure SetMemoryManager(const MemMgr: TMemoryManager); +begin + MemoryManager := MemMgr; +end; + +//{X} - function is replaced with pointer to one. +// function IsMemoryManagerSet: Boolean; +function IsDelphiMemoryManagerSet: Boolean; +begin + with MemoryManager do + Result := (@GetMem <> @SysGetMem) or (@FreeMem <> @SysFreeMem) or + (@ReallocMem <> @SysReallocMem); +end; + +{X+ always returns False. Initial handler for IsMemoryManagerSet } +function MemoryManagerNotUsed : Boolean; +begin + Result := False; +end; +{X-} + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure GetUnwinder(var Dest: TUnwinder); +begin + Dest := Unwinder; +end; + +procedure SetUnwinder(const NewUnwinder: TUnwinder); +begin + Unwinder := NewUnwinder; +end; + +function IsUnwinderSet: Boolean; +begin + with Unwinder do + Result := (@RaiseException <> @_BorUnwind_RaiseException) or + (@RegisterIPLookup <> @_BorUnwind_RegisterIPLookup) or + (@UnregisterIPLookup <> @_BorUnwind_UnregisterIPLookup) or + (@DelphiLookup <> @_BorUnwind_DelphiLookup); +end; + +procedure InitUnwinder; +var + Addr: Pointer; +begin + { + We look to see if we can find a dynamic version of the unwinder. This will + be the case if the application used Unwind.pas. If it is present, then we + fire it up. Otherwise, we use our static copy. + } + Addr := dlsym(0, '_BorUnwind_RegisterIPLookup'); + if Addr <> nil then + begin + Unwinder.RegisterIPLookup := Addr; + Addr := dlsym(0, '_BorUnwind_UnregisterIPLookup'); + Unwinder.UnregisterIPLookup := Addr; + Addr := dlsym(0, '_BorUnwind_RaiseException'); + Unwinder.RaiseException := Addr; + Addr := dlsym(0, '_BorUnwind_DelphiLookup'); + Unwinder.DelphiLookup := Addr; + Addr := dlsym(0, '_BorUnwind_ClosestHandler'); + Unwinder.ClosestHandler := Addr; + end + else + begin + dlerror; // clear error state; dlsym doesn't + Unwinder.RegisterIPLookup := _BorUnwind_RegisterIPLookup; + Unwinder.DelphiLookup := _BorUnwind_DelphiLookup; + Unwinder.UnregisterIPLookup := _BorUnwind_UnregisterIPLookup; + Unwinder.RaiseException := _BorUnwind_RaiseException; + Unwinder.ClosestHandler := _BorUnwind_ClosestDelphiHandler; + end; +end; + +function SysClosestDelphiHandler(Context: Pointer): LongWord; +begin + if not Assigned(Unwinder.ClosestHandler) then + InitUnwinder; + Result := Unwinder.ClosestHandler(Context); +end; + +function SysRegisterIPLookup(StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; +begin +// xxx + if not Assigned(Unwinder.RegisterIPLookup) then + begin + InitUnwinder; +// Unwinder.RegisterIPLookup := UnwindRegisterIPLookup; +// Unwinder.DelphiLookup := UnwindDelphiLookup; + end; + Result := Unwinder.RegisterIPLookup(@Unwinder.DelphiLookup, StartAddr, EndAddr, Context, GOT); +end; + +procedure SysUnregisterIPLookup(StartAddr: LongInt); +begin +// if not Assigned(Unwinder.UnregisterIPLookup) then +// Unwinder.UnregisterIPLookup := UnwindUnregisterIPLookup; + Unwinder.UnregisterIPLookup(StartAddr); +end; + +function SysRaiseException(Exc: Pointer): LongBool; export; +begin +// if not Assigned(Unwinder.RaiseException) then +// Unwinder.RaiseException := UnwindRaiseException; + Result := Unwinder.RaiseException(Exc); +end; + +const + MAX_NESTED_EXCEPTIONS = 16; +{$ENDIF} + +threadvar +{$IFDEF PC_MAPPED_EXCEPTIONS} + ExceptionObjects: array[0..MAX_NESTED_EXCEPTIONS-1] of TRaisedException; + ExceptionObjectCount: Integer; + OSExceptionsBlocked: Integer; +{$ELSE} + RaiseListPtr: pointer; +{$ENDIF} + InOutRes: Integer; + +{$IFDEF PUREPASCAL} +var + notimpl: array [0..15] of Char = 'not implemented'#10; + +procedure NotImplemented; +begin + __write (2, @notimpl, 16); + Halt; +end; +{$ENDIF} + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure BlockOSExceptions; +asm + PUSH EAX + PUSH EDX + CALL SysInit.@GetTLS + MOV [EAX].OSExceptionsBlocked, 1 + POP EDX + POP EAX +end; + +procedure UnblockOSExceptions; +asm + PUSH EAX + CALL SysInit.@GetTLS + MOV [EAX].OSExceptionsBlocked, 0 + POP EAX +end; + +function AreOSExceptionsBlocked: Boolean; +asm + CALL SysInit.@GetTLS + MOV EAX, [EAX].OSExceptionsBlocked +end; + +const + TRAISEDEXCEPTION_SIZE = SizeOf(TRaisedException); + +function CurrentException: PRaisedException; +asm + CALL SysInit.@GetTLS + LEA EDX, [EAX].ExceptionObjects + MOV EAX, [EAX].ExceptionObjectCount + OR EAX, EAX + JE @@Done + DEC EAX + IMUL EAX, TRAISEDEXCEPTION_SIZE + ADD EAX, EDX +@@Done: +end; + +function AllocateException(Exception: Pointer; ExceptionAddr: Pointer): PRaisedException; +asm + PUSH EAX + PUSH EDX + CALL SysInit.@GetTLS + CMP [EAX].ExceptionObjectCount, MAX_NESTED_EXCEPTIONS-1 + JE @@TooManyNestedExceptions + INC [EAX].ExceptionObjectCount + CALL CurrentException + POP EDX + POP ECX + MOV [EAX].TRaisedException.ExceptObject, ECX + MOV [EAX].TRaisedException.ExceptionAddr, EDX + MOV [EAX].TRaisedException.RefCount, 0 + MOV [EAX].TRaisedException.HandlerEBP, $FFFFFFFF + MOV [EAX].TRaisedException.Flags, 0 + RET +@@TooManyNestedExceptions: + MOV EAX, 231 + JMP _RunError +end; + +{ + 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; +asm + CALL CurrentException + OR EAX, EAX + JE @@Error + { EAX -> the TRaisedException } + XOR ECX, ECX + { If the exception object has been referenced, we don't return it. } + CMP [EAX].TRaisedException.RefCount, 0 + JA @@GotObject + MOV ECX, [EAX].TRaisedException.ExceptObject +@@GotObject: + PUSH ECX + CALL SysInit.@GetTLS + POP ECX + DEC [EAX].ExceptionObjectCount + MOV EAX, ECX + RET +@@Error: + { Some kind of internal error } + JMP _Run0Error +end; + +function AcquireExceptionObject: Pointer; +asm + CALL CurrentException + OR EAX, EAX + JE @@Error + INC [EAX].TRaisedException.RefCount + MOV EAX, [EAX].TRaisedException.ExceptObject + RET +@@Error: + { This happens if there is no exception pending } + JMP _Run0Error +end; + +procedure ReleaseExceptionObject; +asm + CALL CurrentException + OR EAX, EAX + JE @@Error + CMP [EAX].TRaisedException.RefCount, 0 + JE @@Error + DEC [EAX].TRaisedException.RefCount + RET +@@Error: + +{ + This happens if there is no exception pending, or + if the reference count on a pending exception is + zero. +} + JMP _Run0Error +end; + +function ExceptObject: TObject; +var + Exc: PRaisedException; +begin + Exc := CurrentException; + if Exc <> nil then + Result := TObject(Exc^.ExceptObject) + else + Result := nil; +end; + +{ Return current exception address } + +function ExceptAddr: Pointer; +var + Exc: PRaisedException; +begin + Exc := CurrentException; + if Exc <> nil then + Result := Exc^.ExceptionAddr + else + Result := nil; +end; +{$ELSE} {not PC_MAPPED_EXCEPTIONS} + +function ExceptObject: TObject; +begin + if RaiseListPtr <> nil then + Result := PRaiseFrame(RaiseListPtr)^.ExceptObject + else + Result := nil; +end; + +{ Return current exception address } + +function ExceptAddr: Pointer; +begin + if RaiseListPtr <> nil then + Result := PRaiseFrame(RaiseListPtr)^.ExceptAddr + else + Result := nil; +end; + + +function AcquireExceptionObject: Pointer; +begin + if RaiseListPtr <> nil then + begin + Result := PRaiseFrame(RaiseListPtr)^.ExceptObject; + PRaiseFrame(RaiseListPtr)^.ExceptObject := nil; + end + else + Result := nil; +end; + +procedure ReleaseExceptionObject; +begin +end; + +function RaiseList: Pointer; +begin + Result := RaiseListPtr; +end; + +function SetRaiseList(NewPtr: Pointer): Pointer; +asm + PUSH EAX + CALL SysInit.@GetTLS + MOV EDX, [EAX].RaiseListPtr + POP [EAX].RaiseListPtr + MOV EAX, EDX +end; +{$ENDIF} + +{ ----------------------------------------------------- } +{ local functions & procedures of the system unit } +{ ----------------------------------------------------- } + +procedure RunErrorAt(ErrCode: Integer; ErrorAtAddr: Pointer); +begin + ErrorAddr := ErrorAtAddr; + _Halt(ErrCode); +end; + +procedure ErrorAt(ErrorCode: Byte; ErrorAddr: Pointer); + +const + reMap: array [TRunTimeError] of Byte = ( + 0, + 203, { reOutOfMemory } + 204, { reInvalidPtr } + 200, { reDivByZero } + 201, { reRangeError } +{ 210 abstract error } + 215, { reIntOverflow } + 207, { reInvalidOp } + 200, { reZeroDivide } + 205, { reOverflow } + 206, { reUnderflow } + 219, { reInvalidCast } + 216, { Access violation } + 202, { Stack overflow } + 217, { Control-C } + 218, { Privileged instruction } + 220, { Invalid variant type cast } + 221, { Invalid variant operation } + 222, { No variant method call dispatcher } + 223, { Cannot create variant array } + 224, { Variant does not contain an array } + 225, { Variant array bounds error } +{ 226 thread init failure } + 227, { reAssertionFailed } + 0, { reExternalException not used here; in SysUtils } + 228, { reIntfCastError } + 229 { reSafeCallError } +{ 230 Reserved by the compiler for unhandled exceptions } +{ 231 Too many nested exceptions } +{ 232 Fatal signal raised on a non-Delphi thread }); + +begin + errorCode := errorCode and 127; + if Assigned(ErrorProc) then + ErrorProc(errorCode, ErrorAddr); + if errorCode = 0 then + errorCode := InOutRes + else if errorCode <= Byte(High(TRuntimeError)) then + errorCode := reMap[TRunTimeError(errorCode)]; + RunErrorAt(errorCode, ErrorAddr); +end; + +procedure Error(errorCode: TRuntimeError); +asm + AND EAX,127 + MOV EDX,[ESP] + JMP ErrorAt +end; + +procedure __IOTest; +asm + PUSH EAX + PUSH EDX + PUSH ECX + CALL SysInit.@GetTLS + CMP [EAX].InOutRes,0 + POP ECX + POP EDX + POP EAX + JNE @error + RET +@error: + XOR EAX,EAX + JMP Error +end; + +procedure SetInOutRes(NewValue: Integer); +begin + InOutRes := NewValue; +end; + +procedure InOutError; +begin + SetInOutRes(GetLastError); +end; + +procedure ChDir(const S: string); +begin + ChDir(PChar(S)); +end; + +procedure ChDir(P: PChar); +begin +{$IFDEF MSWINDOWS} + if not SetCurrentDirectory(P) then +{$ENDIF} +{$IFDEF LINUX} + if __chdir(P) <> 0 then +{$ENDIF} + InOutError; +end; + +procedure _Copy{ s : ShortString; index, count : Integer ) : ShortString}; +asm +{ ->EAX Source string } +{ EDX index } +{ ECX count } +{ [ESP+4] Pointer to result string } + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,[ESP+8+4] + + XOR EAX,EAX + OR AL,[ESI] + JZ @@srcEmpty + +{ limit index to satisfy 1 <= index <= Length(src) } + + TEST EDX,EDX + JLE @@smallInx + CMP EDX,EAX + JG @@bigInx +@@cont1: + +{ limit count to satisfy 0 <= count <= Length(src) - index + 1 } + + SUB EAX,EDX { calculate Length(src) - index + 1 } + INC EAX + TEST ECX,ECX + JL @@smallCount + CMP ECX,EAX + JG @@bigCount +@@cont2: + + ADD ESI,EDX + + MOV [EDI],CL + INC EDI + REP MOVSB + JMP @@exit + +@@smallInx: + MOV EDX,1 + JMP @@cont1 +@@bigInx: +{ MOV EDX,EAX + JMP @@cont1 } +@@smallCount: + XOR ECX,ECX + JMP @@cont2 +@@bigCount: + MOV ECX,EAX + JMP @@cont2 +@@srcEmpty: + MOV [EDI],AL +@@exit: + POP EDI + POP ESI + RET 4 +end; + +procedure _Delete{ var s : openstring; index, count : Integer }; +asm +{ ->EAX Pointer to s } +{ EDX index } +{ ECX count } + + PUSH ESI + PUSH EDI + + MOV EDI,EAX + + XOR EAX,EAX + MOV AL,[EDI] + +{ if index not in [1 .. Length(s)] do nothing } + + TEST EDX,EDX + JLE @@exit + CMP EDX,EAX + JG @@exit + +{ limit count to [0 .. Length(s) - index + 1] } + + TEST ECX,ECX + JLE @@exit + SUB EAX,EDX { calculate Length(s) - index + 1 } + INC EAX + CMP ECX,EAX + JLE @@1 + MOV ECX,EAX +@@1: + SUB [EDI],CL { reduce Length(s) by count } + ADD EDI,EDX { point EDI to first char to be deleted } + LEA ESI,[EDI+ECX] { point ESI to first char to be preserved } + SUB EAX,ECX { #chars = Length(s) - index + 1 - count } + MOV ECX,EAX + + REP MOVSB + +@@exit: + POP EDI + POP ESI +end; + +procedure _LGetDir(D: Byte; var S: string); +{$IFDEF MSWINDOWS} +var + Drive: array[0..3] of Char; + DirBuf, SaveBuf: array[0..MAX_PATH] of Char; +begin + if D <> 0 then + begin + Drive[0] := Chr(D + Ord('A') - 1); + Drive[1] := ':'; + Drive[2] := #0; + GetCurrentDirectory(SizeOf(SaveBuf), SaveBuf); + SetCurrentDirectory(Drive); + end; + GetCurrentDirectory(SizeOf(DirBuf), DirBuf); + if D <> 0 then SetCurrentDirectory(SaveBuf); + S := DirBuf; +{$ENDIF} +{$IFDEF LINUX} +var + DirBuf: array[0..MAX_PATH] of Char; +begin + __getcwd(DirBuf, sizeof(DirBuf)); + S := string(DirBuf); +{$ENDIF} +end; + +procedure _SGetDir(D: Byte; var S: ShortString); +var + L: string; +begin + _LGetDir(D, L); + S := L; +end; + +procedure _Insert{ source : ShortString; var s : openstring; index : Integer }; +asm +{ ->EAX Pointer to source string } +{ EDX Pointer to destination string } +{ ECX Length of destination string } +{ [ESP+4] Index } + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH ECX + MOV ECX,[ESP+16+4] + SUB ESP,512 { VAR buf: ARRAY [0..511] of Char } + + MOV EBX,EDX { save pointer to s for later } + MOV ESI,EDX + + XOR EDX,EDX + MOV DL,[ESI] + INC ESI + +{ limit index to [1 .. Length(s)+1] } + + INC EDX + TEST ECX,ECX + JLE @@smallInx + CMP ECX,EDX + JG @@bigInx +@@cont1: + DEC EDX { EDX = Length(s) } + { EAX = Pointer to src } + { ESI = EBX = Pointer to s } + { ECX = Index } + +{ copy index-1 chars from s to buf } + + MOV EDI,ESP + DEC ECX + SUB EDX,ECX { EDX = remaining length of s } + REP MOVSB + +{ copy Length(src) chars from src to buf } + + XCHG EAX,ESI { save pointer into s, point ESI to src } + MOV CL,[ESI] { ECX = Length(src) (ECX was zero after rep) } + INC ESI + REP MOVSB + +{ copy remaining chars of s to buf } + + MOV ESI,EAX { restore pointer into s } + MOV ECX,EDX { copy remaining bytes of s } + REP MOVSB + +{ calculate total chars in buf } + + SUB EDI,ESP { length = bufPtr - buf } + MOV ECX,[ESP+512] { ECX = Min(length, destLength) } +{ MOV ECX,[EBP-16] }{ ECX = Min(length, destLength) } + CMP ECX,EDI + JB @@1 + MOV ECX,EDI +@@1: + MOV EDI,EBX { Point EDI to s } + MOV ESI,ESP { Point ESI to buf } + MOV [EDI],CL { Store length in s } + INC EDI + REP MOVSB { Copy length chars to s } + JMP @@exit + +@@smallInx: + MOV ECX,1 + JMP @@cont1 +@@bigInx: + MOV ECX,EDX + JMP @@cont1 + +@@exit: + ADD ESP,512+4 + POP EDI + POP ESI + POP EBX + RET 4 +end; + +function IOResult: Integer; +begin + Result := InOutRes; + InOutRes := 0; +end; + +procedure MkDir(const S: string); +begin + MkDir(PChar(s)); +end; + +procedure MkDir(P: PChar); +begin +{$IFDEF MSWINDOWS} + if not CreateDirectory(P, 0) then +{$ENDIF} +{$IFDEF LINUX} + if __mkdir(P, -1) <> 0 then +{$ENDIF} + InOutError; +end; + +procedure Move( const Source; var Dest; count : Integer ); +{$IFDEF PUREPASCAL} +var + S, D: PChar; + I: Integer; +begin + S := PChar(@Source); + D := PChar(@Dest); + if S = D then Exit; + if Cardinal(D) > Cardinal(S) then + for I := count-1 downto 0 do + D[I] := S[I] + else + for I := 0 to count-1 do + D[I] := S[I]; +end; +{$ELSE} +asm +{ ->EAX Pointer to source } +{ EDX Pointer to destination } +{ ECX Count } + +(*{X-} // original code. + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + MOV EAX,ECX + + CMP EDI,ESI + JA @@down + JE @@exit + + SAR ECX,2 { copy count DIV 4 dwords } + JS @@exit + + REP MOVSD + + MOV ECX,EAX + AND ECX,03H + REP MOVSB { copy count MOD 4 bytes } + JMP @@exit + +@@down: + LEA ESI,[ESI+ECX-4] { point ESI to last dword of source } + LEA EDI,[EDI+ECX-4] { point EDI to last dword of dest } + + SAR ECX,2 { copy count DIV 4 dwords } + JS @@exit + STD + REP MOVSD + + MOV ECX,EAX + AND ECX,03H { copy count MOD 4 bytes } + ADD ESI,4-1 { point to last byte of rest } + ADD EDI,4-1 + REP MOVSB + CLD +@@exit: + POP EDI + POP ESI +*){X+} +//--------------------------------------- +(* {X+} // Let us write smaller: + JCXZ @@fin + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + MOV EAX,ECX + + AND ECX,3 { copy count mod 4 dwords } + + CMP EDI,ESI + JE @@exit + JA @@up + +//down: + LEA ESI,[ESI+EAX-1] { point ESI to last byte of source } + LEA EDI,[EDI+EAX-1] { point EDI to last byte of dest } + STD + + CMP EAX, 4 + JL @@up + ADD ECX, 3 { move 3 bytes more to correct pos } + +@@up: + REP MOVSB + + SAR EAX, 2 + JS @@exit + + MOV ECX, EAX + REP MOVSD + +@@exit: + CLD + POP EDI + POP ESI + +@@fin: +*) {X-} +//--------------------------------------- +{X+} // And now, let us write speedy: + CMP ECX, 4 + JGE @@long + JCXZ @@fin + + CMP EAX, EDX + JE @@fin + + PUSH ESI + PUSH EDI + MOV ESI, EAX + MOV EDI, EDX + JA @@short_up + + LEA ESI,[ESI+ECX-1] { point ESI to last byte of source } + LEA EDI,[EDI+ECX-1] { point EDI to last byte of dest } + STD + +@@short_up: + REP MOVSB + JMP @@exit_up + +@@long: + CMP EAX, EDX + JE @@fin + + PUSH ESI + PUSH EDI + MOV ESI, EAX + MOV EDI, EDX + MOV EAX, ECX + + JA @@long_up + + { + SAR ECX, 2 + JS @@exit + + LEA ESI,[ESI+EAX-4] + LEA EDI,[EDI+EAX-4] + STD + REP MOVSD + + MOV ECX, EAX + MOV EAX, 3 + AND ECX, EAX + ADD ESI, EAX + ADD EDI, EAX + REP MOVSB + } // let's do it in other order - faster if data are aligned... + + AND ECX, 3 + LEA ESI,[ESI+EAX-1] + LEA EDI,[EDI+EAX-1] + STD + REP MOVSB + + SAR EAX, 2 + //JS @@exit // why to test this? but what does PC do? + MOV ECX, EAX + MOV EAX, 3 + SUB ESI, EAX + SUB EDI, EAX + REP MOVSD + +@@exit_up: + CLD + //JMP @@exit + DEC ECX // the same - loosing 2 tacts... but conveyer! + +@@long_up: + SAR ECX, 2 + JS @@exit + + REP MOVSD + + AND EAX, 3 + MOV ECX, EAX + REP MOVSB + +@@exit: + POP EDI + POP ESI + +@@fin: +{X-} +end; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function GetParamStr(P: PChar; var Param: string): PChar; +var + i, Len: Integer; + Start, S, Q: PChar; +begin + while True do + begin + while (P[0] <> #0) and (P[0] <= ' ') do + P := CharNext(P); + if (P[0] = '"') and (P[1] = '"') then Inc(P, 2) else Break; + end; + Len := 0; + Start := P; + while P[0] > ' ' do + begin + if P[0] = '"' then + begin + P := CharNext(P); + while (P[0] <> #0) and (P[0] <> '"') do + begin + Q := CharNext(P); + Inc(Len, Q - P); + P := Q; + end; + if P[0] <> #0 then + P := CharNext(P); + end + else + begin + Q := CharNext(P); + Inc(Len, Q - P); + P := Q; + end; + end; + + SetLength(Param, Len); + + P := Start; + S := Pointer(Param); + i := 0; + while P[0] > ' ' do + begin + if P[0] = '"' then + begin + P := CharNext(P); + while (P[0] <> #0) and (P[0] <> '"') do + begin + Q := CharNext(P); + while P < Q do + begin + S[i] := P^; + Inc(P); + Inc(i); + end; + end; + if P[0] <> #0 then P := CharNext(P); + end + else + begin + Q := CharNext(P); + while P < Q do + begin + S[i] := P^; + Inc(P); + Inc(i); + end; + end; + end; + + Result := P; +end; +{$ENDIF} + +function ParamCount: Integer; +{$IFDEF MSWINDOWS} +var + P: PChar; + S: string; +begin + Result := 0; + P := GetParamStr(GetCommandLine, S); + while True do + begin + P := GetParamStr(P, S); + if S = '' then Break; + Inc(Result); + end; +{$ENDIF} +{$IFDEF LINUX} +begin + if ArgCount > 1 then + Result := ArgCount - 1 + else Result := 0; +{$ENDIF} +end; + +type + PCharArray = array[0..0] of PChar; + +function ParamStr(Index: Integer): string; +{$IFDEF MSWINDOWS} +var + P: PChar; + Buffer: array[0..260] of Char; +begin + Result := ''; + if Index = 0 then + SetString(Result, Buffer, GetModuleFileName(0, Buffer, SizeOf(Buffer))) + else + begin + P := GetCommandLine; + while True do + begin + P := GetParamStr(P, Result); + if (Index = 0) or (Result = '') then Break; + Dec(Index); + end; + end; +{$ENDIF} +{$IFDEF LINUX} +begin + if Index < ArgCount then + Result := PCharArray(ArgValues^)[Index] + else + Result := ''; +{$ENDIF} +end; + +function Pos(const substr, str: AnsiString): Integer; overload; +asm + push ebx + push esi + add esp, -16 + test edx, edx + jz @NotFound + test eax, eax + jz @NotFound + mov esi, [edx-4] //Length(Str) + mov ebx, [eax-4] //Length(Substr) + cmp esi, ebx + jl @NotFound + test ebx, ebx + jle @NotFound + dec ebx + add esi, edx + add edx, ebx + mov [esp+8], esi + add eax, ebx + mov [esp+4], edx + neg ebx + movzx ecx, byte ptr [eax] + mov [esp], ebx + jnz @FindString + + sub esi, 2 + mov [esp+12], esi + +@FindChar2: + cmp cl, [edx] + jz @Matched0ch + cmp cl, [edx+1] + jz @Matched1ch + add edx, 2 + cmp edx, [esp+12] + jb @FindChar4 + cmp edx, [esp+8] + jb @FindChar2 +@NotFound: + xor eax, eax + jmp @Exit0ch + +@FindChar4: + cmp cl, [edx] + jz @Matched0ch + cmp cl, [edx+1] + jz @Matched1ch + cmp cl, [edx+2] + jz @Matched2ch + cmp cl, [edx+3] + jz @Matched3ch + add edx, 4 + cmp edx, [esp+12] + jb @FindChar4 + cmp edx, [esp+8] + jb @FindChar2 + xor eax, eax + jmp @Exit0ch + +@Matched2ch: + add edx, 2 +@Matched0ch: + inc edx + mov eax, edx + sub eax, [esp+4] +@Exit0ch: + add esp, 16 + pop esi + pop ebx + ret + +@Matched3ch: + add edx, 2 +@Matched1ch: + add edx, 2 + xor eax, eax + cmp edx, [esp+8] + ja @Exit1ch + mov eax, edx + sub eax, [esp+4] +@Exit1ch: + add esp, 16 + pop esi + pop ebx + ret + +@FindString4: + cmp cl, [edx] + jz @Test0 + cmp cl, [edx+1] + jz @Test1 + cmp cl, [edx+2] + jz @Test2 + cmp cl, [edx+3] + jz @Test3 + add edx, 4 + cmp edx, [esp+12] + jb @FindString4 + cmp edx, [esp+8] + jb @FindString2 + xor eax, eax + jmp @Exit1 + +@FindString: + sub esi, 2 + mov [esp+12], esi +@FindString2: + cmp cl, [edx] + jz @Test0 +@AfterTest0: + cmp cl, [edx+1] + jz @Test1 +@AfterTest1: + add edx, 2 + cmp edx, [esp+12] + jb @FindString4 + cmp edx, [esp+8] + jb @FindString2 + xor eax, eax + jmp @Exit1 + +@Test3: + add edx, 2 +@Test1: + mov esi, [esp] +@Loop1: + movzx ebx, word ptr [esi+eax] + cmp bx, word ptr [esi+edx+1] + jnz @AfterTest1 + add esi, 2 + jl @Loop1 + add edx, 2 + xor eax, eax + cmp edx, [esp+8] + ja @Exit1 +@RetCode1: + mov eax, edx + sub eax, [esp+4] +@Exit1: + add esp, 16 + pop esi + pop ebx + ret + +@Test2: + add edx,2 +@Test0: + mov esi, [esp] +@Loop0: + movzx ebx, word ptr [esi+eax] + cmp bx, word ptr [esi+edx] + jnz @AfterTest0 + add esi, 2 + jl @Loop0 + inc edx +@RetCode0: + mov eax, edx + sub eax, [esp+4] + add esp, 16 + pop esi + pop ebx +end; + +function Pos(const substr, str: WideString): Integer; overload; +asm +{ ->EAX Pointer to substr } +{ EDX Pointer to string } +{ <-EAX Position of substr in str or 0 } + + TEST EAX,EAX + JE @@noWork + + TEST EDX,EDX + JE @@stringEmpty + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX { Point ESI to substr } + MOV EDI,EDX { Point EDI to s } + + MOV ECX,[EDI-4] { ECX = Length(s) } + SHR ECX,1 + + PUSH EDI { remember s position to calculate index } + + MOV EDX,[ESI-4] { EDX = Length(substr) } + SHR EDX,1 + + DEC EDX { EDX = Length(substr) - 1 } + JS @@fail { < 0 ? return 0 } + MOV AX,[ESI] { AL = first char of substr } + ADD ESI,2 { Point ESI to 2'nd char of substr } + + SUB ECX,EDX { #positions in s to look at } + { = Length(s) - Length(substr) + 1 } + JLE @@fail +@@loop: + REPNE SCASW + JNE @@fail + MOV EBX,ECX { save outer loop counter } + PUSH ESI { save outer loop substr pointer } + PUSH EDI { save outer loop s pointer } + + MOV ECX,EDX + REPE CMPSW + POP EDI { restore outer loop s pointer } + POP ESI { restore outer loop substr pointer } + JE @@found + MOV ECX,EBX { restore outer loop counter } + JMP @@loop + +@@fail: + POP EDX { get rid of saved s pointer } + XOR EAX,EAX + JMP @@exit + +@@stringEmpty: + XOR EAX,EAX + JMP @@noWork + +@@found: + POP EDX { restore pointer to first char of s } + MOV EAX,EDI { EDI points of char after match } + SUB EAX,EDX { the difference is the correct index } + SHR EAX,1 +@@exit: + POP EDI + POP ESI + POP EBX +@@noWork: +end; + +// 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); +begin + Byte(s^[0]) := newLength; // should also fill new space +end; + +procedure _SetString(s: PShortString; buffer: PChar; len: Byte); +begin + Byte(s^[0]) := len; + if buffer <> nil then + Move(buffer^, s^[1], len); +end; + +procedure Randomize; +{$IFDEF LINUX} +begin + RandSeed := _time(nil); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +var + Counter: Int64; +begin + if QueryPerformanceCounter(Counter) then + RandSeed := Counter + else + RandSeed := GetTickCount; +end; +{$ENDIF} + +function Random(const ARange: Integer): Integer; +{$IF DEFINED(CPU386)} +asm +{ ->EAX Range } +{ <-EAX Result } + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX + MOV ECX,[EBX].OFFSET RandSeed + IMUL EDX,[ECX],08088405H + INC EDX + MOV [ECX],EDX +{$ELSE} + XOR EBX, EBX + IMUL EDX,[EBX].RandSeed,08088405H + INC EDX + MOV [EBX].RandSeed,EDX +{$ENDIF} + MUL EDX + MOV EAX,EDX + POP EBX +end; +{$ELSEIF DEFINED(CLR)} +begin + InitRandom; + Result := RandomEngine.Next(ARange); +end; +{$ELSE} + {$MESSAGE ERROR 'Random(Int):Int unimplemented'} +{$IFEND} + +function Random: Extended; +{$IF DEFINED(CPU386)} +const two2neg32: double = ((1.0/$10000) / $10000); // 2^-32 +asm +{ FUNCTION _RandExt: Extended; } + + PUSH EBX +{$IFDEF PIC} + CALL GetGOT + MOV EBX,EAX + MOV ECX,[EBX].OFFSET RandSeed + IMUL EDX,[ECX],08088405H + INC EDX + MOV [ECX],EDX +{$ELSE} + XOR EBX, EBX + IMUL EDX,[EBX].RandSeed,08088405H + INC EDX + MOV [EBX].RandSeed,EDX +{$ENDIF} + + FLD [EBX].two2neg32 + PUSH 0 + PUSH EDX + FILD qword ptr [ESP] + ADD ESP,8 + FMULP ST(1), ST(0) + POP EBX +end; +{$ELSEIF DEFINED(CLR)} +begin + InitRandom; + Result := RandomEngine.NextDouble; +end; +{$ELSE} + {$MESSAGE ERROR 'Random:Extended unimplemented'} +{$IFEND} + +procedure RmDir(const S: string); +begin + RmDir(PChar(s)); +end; + +procedure RmDir(P: PChar); +begin +{$IFDEF MSWINDOWS} + if not RemoveDirectory(P) then +{$ENDIF} +{$IFDEF LINUX} + if __rmdir(P) <> 0 then +{$ENDIF} + InOutError; +end; + +function UpCase( ch : Char ) : Char; +{$IFDEF PUREPASCAL} +begin + Result := ch; + case Result of + 'a'..'z': Dec(Result, Ord('a') - Ord('A')); + end; +end; +{$ELSE} +asm +{ -> AL Character } +{ <- AL Result } + + CMP AL,'a' + JB @@exit + CMP AL,'z' + JA @@exit + SUB AL,'a' - 'A' +@@exit: +end; +{$ENDIF} + +procedure Set8087CW(NewCW: Word); +begin + Default8087CW := NewCW; + asm + FNCLEX // don't raise pending exceptions enabled by the new flags +{$IFDEF PIC} + MOV EAX,[EBX].OFFSET Default8087CW + FLDCW [EAX] +{$ELSE} + FLDCW Default8087CW +{$ENDIF} + end; +end; + +function Get8087CW: Word; +asm + PUSH 0 + FNSTCW [ESP].Word + POP EAX +end; + + +{ ----------------------------------------------------- } +{ functions & procedures that need compiler magic } +{ ----------------------------------------------------- } + +function Int(const X: Extended): Extended; +asm + FLD X + SUB ESP,4 + FNSTCW [ESP].Word // save + FNSTCW [ESP+2].Word // scratch + FWAIT + OR [ESP+2].Word, $0F00 // trunc toward zero, full precision + FLDCW [ESP+2].Word + FRNDINT + FWAIT + FLDCW [ESP].Word + ADD ESP,4 +end; + +function Frac(const X: Extended): Extended; +asm + FLD X + FLD ST(0) + SUB ESP,4 + FNSTCW [ESP].Word // save + FNSTCW [ESP+2].Word // scratch + FWAIT + OR [ESP+2].Word, $0F00 // trunc toward zero, full precision + FLDCW [ESP+2].Word + FRNDINT + FWAIT + FLDCW [ESP].Word + ADD ESP,4 + FSUB +end; + +function Exp(const X: Extended): Extended; +asm + { e**x = 2**(x*log2(e)) } + FLD X + FLDL2E { y := x*log2e; } + FMUL + FLD ST(0) { i := round(y); } + FRNDINT + FSUB ST(1), ST { f := y - i; } + FXCH ST(1) { z := 2**f } + F2XM1 + FLD1 + FADD + FSCALE { result := z * 2**i } + FSTP ST(1) +end; + +function Cos(const X: Extended): Extended; +asm + FLD X + FCOS + FWAIT +end; + +function Sin(const X: Extended): Extended; +asm + FLD X + FSIN + FWAIT +end; + +function Ln(const X: Extended): Extended; +asm + FLD X + FLDLN2 + FXCH + FYL2X + FWAIT +end; + +function ArcTan(const X: Extended): Extended; +asm + FLD X + FLD1 + FPATAN + FWAIT +end; + +function Sqrt(const X: Extended): Extended; +asm + FLD X + FSQRT + FWAIT +end; + +{ ----------------------------------------------------- } +{ functions & procedures that need compiler magic } +{ ----------------------------------------------------- } + +procedure _ROUND; +asm + { -> FST(0) Extended argument } + { <- EDX:EAX Result } + + SUB ESP,8 + FISTP qword ptr [ESP] + FWAIT + POP EAX + POP EDX +end; + +procedure _TRUNC; +asm + { -> FST(0) Extended argument } + { <- EDX:EAX Result } + + SUB ESP,12 + FNSTCW [ESP].Word // save + FNSTCW [ESP+2].Word // scratch + FWAIT + OR [ESP+2].Word, $0F00 // trunc toward zero, full precision + FLDCW [ESP+2].Word + FISTP qword ptr [ESP+4] + FWAIT + FLDCW [ESP].Word + POP ECX + POP EAX + POP EDX +end; + +procedure _AbstractError; +{$IFDEF PC_MAPPED_EXCEPTIONS} +asm + MOV EAX,210 + JMP _RunError +end; +{$ELSE} +{$IFDEF PIC} +begin + if Assigned(AbstractErrorProc) then + AbstractErrorProc; + _RunError(210); // loses return address +end; +{$ELSE} +asm + CMP AbstractErrorProc, 0 + JE @@NoAbstErrProc + CALL AbstractErrorProc + +@@NoAbstErrProc: + MOV EAX,210 + JMP _RunError +end; +{$ENDIF} +{$ENDIF} + +function TextOpen(var t: TTextRec): Integer; forward; + +function OpenText(var t: TTextRec; Mode: Word): Integer; +begin + if (t.Mode < fmClosed) or (t.Mode > fmInOut) then + Result := 102 + else + begin + if t.Mode <> fmClosed then _Close(t); + t.Mode := Mode; + if (t.Name[0] = #0) and (t.OpenFunc = nil) then // stdio + t.OpenFunc := @TextOpen; + Result := TTextIOFunc(t.OpenFunc)(t); + end; + if Result <> 0 then SetInOutRes(Result); +end; + +function _ResetText(var t: TTextRec): Integer; +begin + Result := OpenText(t, fmInput); +end; + +function _RewritText(var t: TTextRec): Integer; +begin + Result := OpenText(t, fmOutput); +end; + +function _Append(var t: TTextRec): Integer; +begin + Result := OpenText(t, fmInOut); +end; + +function TextIn(var t: TTextRec): Integer; +begin + t.BufEnd := 0; + t.BufPos := 0; +{$IFDEF LINUX} + t.BufEnd := __read(t.Handle, t.BufPtr, t.BufSize); + if Integer(t.BufEnd) = -1 then + begin + t.BufEnd := 0; + Result := GetLastError; + end + else + Result := 0; +{$ENDIF} +{$IFDEF MSWINDOWS} + if ReadFile(t.Handle, t.BufPtr^, t.BufSize, t.BufEnd, nil) = 0 then + begin + Result := GetLastError; + if Result = 109 then + Result := 0; // NT quirk: got "broken pipe"? it's really eof + end + else + Result := 0; +{$ENDIF} +end; + +function FileNOPProc(var t): Integer; +begin + Result := 0; +end; + +function TextOut(var t: TTextRec): Integer; +{$IFDEF MSWINDOWS} +var + Dummy: Cardinal; +{$ENDIF} +begin + if t.BufPos = 0 then + Result := 0 + else + begin +{$IFDEF LINUX} + if __write(t.Handle, t.BufPtr, t.BufPos) = Cardinal(-1) then +{$ENDIF} +{$IFDEF MSWINDOWS} + if WriteFile(t.Handle, t.BufPtr^, t.BufPos, Dummy, nil) = 0 then +{$ENDIF} + Result := GetLastError + else + Result := 0; + t.BufPos := 0; + end; +end; + +function InternalClose(Handle: Integer): Boolean; +begin +{$IFDEF LINUX} + Result := __close(Handle) = 0; +{$ENDIF} +{$IFDEF MSWINDOWS} + Result := CloseHandle(Handle) = 1; +{$ENDIF} +end; + +function TextClose(var t: TTextRec): Integer; +begin + t.Mode := fmClosed; + if not InternalClose(t.Handle) then + Result := GetLastError + else + Result := 0; +end; + +function TextOpenCleanup(var t: TTextRec): Integer; +begin + InternalClose(t.Handle); + t.Mode := fmClosed; + Result := GetLastError; +end; + +function TextOpen(var t: TTextRec): Integer; +{$IFDEF LINUX} +var + Flags: Integer; + Temp, I: Integer; + BytesRead: Integer; +begin + Result := 0; + t.BufPos := 0; + t.BufEnd := 0; + case t.Mode of + fmInput: // called by Reset + begin + Flags := O_RDONLY; + t.InOutFunc := @TextIn; + end; + fmOutput: // called by Rewrite + begin + Flags := O_CREAT or O_TRUNC or O_WRONLY; + t.InOutFunc := @TextOut; + end; + fmInOut: // called by Append + begin + Flags := O_APPEND or O_RDWR; + t.InOutFunc := @TextOut; + end; + else + Exit; + Flags := 0; + end; + + t.FlushFunc := @FileNOPProc; + + if t.Name[0] = #0 then // stdin or stdout + begin + t.BufPtr := @t.Buffer; + t.BufSize := sizeof(t.Buffer); + t.CloseFunc := @FileNOPProc; + if t.Mode = fmOutput then + begin + if @t = @ErrOutput then + t.Handle := STDERR_FILENO + else + t.Handle := STDOUT_FILENO; + t.FlushFunc := @TextOut; + end + else + t.Handle := STDIN_FILENO; + end + else + begin + t.CloseFunc := @TextClose; + + Temp := __open(t.Name, Flags, FileAccessRights); + if Temp = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + t.Handle := Temp; + + if t.Mode = fmInOut then // Append mode + begin + t.Mode := fmOutput; + + if (t.flags and tfCRLF) <> 0 then // DOS mode, EOF significant + begin // scan for EOF char in last 128 byte sector. + Temp := _lseek(t.Handle, 0, SEEK_END); + if Temp = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + Dec(Temp, 128); + if Temp < 0 then Temp := 0; + + if _lseek(t.Handle, Temp, SEEK_SET) = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + BytesRead := __read(t.Handle, t.BufPtr, 128); + if BytesRead = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + for I := 0 to BytesRead - 1 do + begin + if t.Buffer[I] = Char(cEOF) then + begin // truncate the file here + if _ftruncate(t.Handle, _lseek(t.Handle, I - BytesRead, SEEK_END)) = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + Break; + end; + end; + end; + end; + end; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +(* +var + OpenMode: Integer; + Flags, Std: ShortInt; + Temp: Integer; + I, BytesRead: Cardinal; + Mode: Byte; +begin + Result := 0; + if (t.Mode - fmInput) > (fmInOut - fmInput) then Exit; + Mode := t.Mode and 3; + t.BufPos := 0; + t.BufEnd := 0; + t.FlushFunc := @FileNOPProc; + + if t.Name[0] = #0 then // stdin or stdout + begin + t.BufPtr := @t.Buffer; + t.BufSize := sizeof(t.Buffer); + t.CloseFunc := @FileNOPProc; + if Mode = (fmOutput and 3) then + begin + t.InOutFunc := @TextOut; + if @t = @ErrOutput then + Std := STD_ERROR_HANDLE + else + Std := STD_OUTPUT_HANDLE; + end + else + begin + t.InOutFunc := @TextIn; + Std := STD_INPUT_HANDLE; + end; + t.Handle := GetStdHandle(Std); + end + else + begin + t.CloseFunc := @TextClose; + + Flags := OPEN_EXISTING; + if Mode = (fmInput and 3) then + begin // called by Reset + t.InOutFunc := @TextIn; + OpenMode := GENERIC_READ; // open for read + end + else + begin + t.InOutFunc := @TextOut; + if Mode = (fmInOut and 3) then // called by Append + OpenMode := GENERIC_READ OR GENERIC_WRITE // open for read/write + else + begin // called by Rewrite + OpenMode := GENERIC_WRITE; // open for write + Flags := CREATE_ALWAYS; + end; + end; + + Temp := CreateFileA(t.Name, OpenMode, FILE_SHARE_READ, nil, Flags, FILE_ATTRIBUTE_NORMAL, 0); + if Temp = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + t.Handle := Temp; + + if Mode = (fmInOut and 3) then + begin + Dec(t.Mode); // fmInOut -> fmOutput + +{; ??? we really have to look for the first eof byte in the +; ??? last record and truncate the file there. +; Not very nice and clean... +; +; lastRecPos = Max( GetFileSize(...) - 128, 0); +} + Temp := GetFileSize(t.Handle, 0); + if Temp = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + Dec(Temp, 128); + if Temp < 0 then Temp := 0; + + if (SetFilePointer(t.Handle, Temp, nil, FILE_BEGIN) = -1) or + (ReadFile(t.Handle, t.Buffer, 128, BytesRead, nil) = 0) then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + for I := 0 to BytesRead do + begin + if t.Buffer[I] = Char(cEOF) then + begin // truncate the file here + if (SetFilePointer(t.Handle, I - BytesRead, nil, FILE_END) = -1) or + (not SetEndOfFile(t.Handle)) then + begin + Result := TextOpenCleanup(t); + Exit; + end; + Break; + end; + end; + end; + if Mode <> (fmInput and 3) then + begin + case GetFileType(t.Handle) of + 0: begin // bad file type + TextOpenCleanup(t); + Result := 105; + Exit; + end; + 2: t.FlushFunc := @TextOut; + end; + end; + end; +end; +*) + +asm +// -> EAX Pointer to text record + + PUSH ESI + + MOV ESI,EAX + + XOR EAX,EAX + MOV [ESI].TTextRec.BufPos,EAX + MOV [ESI].TTextRec.BufEnd,EAX + MOV AX,[ESI].TTextRec.Mode + + SUB EAX,fmInput + JE @@calledByReset + + DEC EAX + JE @@calledByRewrite + + DEC EAX + JE @@calledByAppend + + JMP @@exit + +@@calledByReset: + + MOV EAX,GENERIC_READ // open for read + MOV EDX,FILE_SHARE_READ + MOV ECX,OPEN_EXISTING + + MOV [ESI].TTextRec.InOutFunc,offset TextIn + + JMP @@common + +@@calledByRewrite: + + MOV EAX,GENERIC_WRITE // open for write + MOV EDX,FILE_SHARE_READ + MOV ECX,CREATE_ALWAYS + JMP @@commonOut + +@@calledByAppend: + + MOV EAX,GENERIC_READ OR GENERIC_WRITE // open for read/write + MOV EDX,FILE_SHARE_READ + MOV ECX,OPEN_EXISTING + +@@commonOut: + + MOV [ESI].TTextRec.InOutFunc,offset TextOut + +@@common: + + MOV [ESI].TTextRec.CloseFunc,offset TextClose + MOV [ESI].TTextRec.FlushFunc,offset FileNOPProc + CMP byte ptr [ESI].TTextRec.Name,0 + JE @@isCon + +// CreateFile(t.Name, EAX, EDX, Nil, ECX, FILE_ATTRIBUTE_NORMAL, 0); + + PUSH 0 + PUSH FILE_ATTRIBUTE_NORMAL + PUSH ECX + PUSH 0 + PUSH EDX + PUSH EAX + LEA EAX,[ESI].TTextRec.Name + PUSH EAX + CALL CreateFileA + + CMP EAX,-1 + JZ @@error + + MOV [ESI].TTextRec.Handle,EAX + CMP [ESI].TTextRec.Mode,fmInOut + JNE @@success + + DEC [ESI].TTextRec.Mode // fmInOut -> fmOutput + +{; ??? we really have to look for the first eof byte in the +; ??? last record and truncate the file there. +; Not very nice and clean... +; +; lastRecPos = Max( GetFileSize(...) - 128, 0); +} + PUSH 0 + PUSH [ESI].TTextRec.Handle + CALL GetFileSize + + INC EAX + JZ @@error + SUB EAX,129 + JNC @@3 + XOR EAX,EAX +@@3: +// lseek(f.Handle, SEEK_SET, lastRecPos); + + PUSH FILE_BEGIN + PUSH 0 + PUSH EAX + PUSH [ESI].TTextRec.Handle + CALL SetFilePointer + + INC EAX + JE @@error + +// bytesRead = read(f.Handle, f.Buffer, 128); + + PUSH 0 + MOV EDX,ESP + PUSH 0 + PUSH EDX + PUSH 128 + LEA EDX,[ESI].TTextRec.Buffer + PUSH EDX + PUSH [ESI].TTextRec.Handle + CALL ReadFile + POP EDX + DEC EAX + JNZ @@error + +// for (i = 0; i < bytesRead; i++) + + XOR EAX,EAX +@@loop: + CMP EAX,EDX + JAE @@success + +// if (f.Buffer[i] == eof) + + CMP byte ptr [ESI].TTextRec.Buffer[EAX],eof + JE @@truncate + INC EAX + JMP @@loop + +@@truncate: + +// lseek( f.Handle, SEEK_END, i - bytesRead ); + + PUSH FILE_END + PUSH 0 + SUB EAX,EDX + PUSH EAX + PUSH [ESI].TTextRec.Handle + CALL SetFilePointer + INC EAX + JE @@error + +// SetEndOfFile( f.Handle ); + + PUSH [ESI].TTextRec.Handle + CALL SetEndOfFile + DEC EAX + JNE @@error + + JMP @@success + +@@isCon: + LEA EAX,[ESI].TTextRec.Buffer + MOV [ESI].TTextRec.BufSize, TYPE TTextRec.Buffer + MOV [ESI].TTextRec.CloseFunc,offset FileNOPProc + MOV [ESI].TTextRec.BufPtr,EAX + CMP [ESI].TTextRec.Mode,fmOutput + JE @@output + PUSH STD_INPUT_HANDLE + JMP @@1 +@@output: + CMP ESI,offset ErrOutput + JNE @@stdout + PUSH STD_ERROR_HANDLE + JMP @@1 +@@stdout: + PUSH STD_OUTPUT_HANDLE +@@1: + CALL GetStdHandle + CMP EAX,-1 + JE @@error + MOV [ESI].TTextRec.Handle,EAX + +@@success: + CMP [ESI].TTextRec.Mode,fmInput + JE @@2 + PUSH [ESI].TTextRec.Handle + CALL GetFileType + TEST EAX,EAX + JE @@badFileType + CMP EAX,2 + JNE @@2 + MOV [ESI].TTextRec.FlushFunc,offset TextOut +@@2: + XOR EAX,EAX +@@exit: + POP ESI + RET + +@@badFileType: + PUSH [ESI].TTextRec.Handle + CALL CloseHandle + MOV [ESI].TTextRec.Mode,fmClosed + MOV EAX,105 + JMP @@exit + +@@error: + MOV [ESI].TTextRec.Mode,fmClosed + CALL GetLastError + JMP @@exit +end; +{$ENDIF} + +const + fNameLen = 260; + +function _Assign(var t: TTextRec; const s: String): Integer; +begin + FillChar(t, sizeof(TFileRec), 0); + t.BufPtr := @t.Buffer; + t.Mode := fmClosed; + t.Flags := tfCRLF * Byte(DefaultTextLineBreakStyle); + t.BufSize := sizeof(t.Buffer); + t.OpenFunc := @TextOpen; + Move(S[1], t.Name, Length(s)); + t.Name[Length(s)] := #0; + Result := 0; +end; + +function InternalFlush(var t: TTextRec; Func: TTextIOFunc): Integer; +begin + case t.Mode of + fmOutput, + fmInOut : Result := Func(t); + fmInput : Result := 0; + else + if (@t = @Output) or (@t = @ErrOutput) then + Result := 0 + else + Result := 103; + end; + if Result <> 0 then SetInOutRes(Result); +end; + +function Flush(var t: Text): Integer; +begin + Result := InternalFlush(TTextRec(t), TTextRec(t).InOutFunc); +end; + +function _Flush(var t: TTextRec): Integer; +begin + Result := InternalFlush(t, t.FlushFunc); +end; + +type +{$IFDEF MSWINDOWS} + 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'; + +{$ENDIF} +{$IFDEF LINUX} + TIOProc = function (Handle: Integer; Buffer: Pointer; Count: Cardinal): Cardinal; cdecl; +{$ENDIF} + +function BlockIO(var f: TFileRec; buffer: Pointer; recCnt: Cardinal; var recsDone: Longint; + ModeMask: Integer; IOProc: TIOProc; ErrorNo: Integer): Cardinal; +// Note: RecsDone ptr can be nil! +begin + if (f.Mode and ModeMask) = ModeMask then // fmOutput or fmInOut / fmInput or fmInOut + begin +{$IFDEF LINUX} + Result := IOProc(f.Handle, buffer, recCnt * f.RecSize); + if Integer(Result) = -1 then +{$ENDIF} +{$IFDEF MSWINDOWS} + if IOProc(f.Handle, buffer, recCnt * f.RecSize, Result, nil) = 0 then +{$ENDIF} + begin + SetInOutRes(GetLastError); + Result := 0; + end + else + begin + Result := Result div f.RecSize; + if @RecsDone <> nil then + RecsDone := Result + else if Result <> recCnt then + begin + SetInOutRes(ErrorNo); + Result := 0; + end + end; + end + else + begin + SetInOutRes(103); // file not open + Result := 0; + end; +end; + +function _BlockRead(var f: TFileRec; buffer: Pointer; recCnt: Longint; var recsRead: Longint): Longint; +begin + Result := BlockIO(f, buffer, recCnt, recsRead, fmInput, + {$IFDEF MSWINDOWS} ReadFileX, {$ENDIF} + {$IFDEF LINUX} __read, {$ENDIF} + 100); +end; + +function _BlockWrite(var f: TFileRec; buffer: Pointer; recCnt: Longint; var recsWritten: Longint): Longint; +begin + Result := BlockIO(f, buffer, recCnt, recsWritten, fmOutput, + {$IFDEF MSWINDOWS} WriteFileX, {$ENDIF} + {$IFDEF LINUX} __write, {$ENDIF} + 101); +end; + +function _Close(var t: TTextRec): Integer; +begin + Result := 0; + if (t.Mode >= fmInput) and (t.Mode <= fmInOut) then + begin + if (t.Mode and fmOutput) = fmOutput then // fmOutput or fmInOut + Result := TTextIOFunc(t.InOutFunc)(t); + if Result = 0 then + Result := TTextIOFunc(t.CloseFunc)(t); + if Result <> 0 then + SetInOutRes(Result); + end + else + if @t <> @Input then + SetInOutRes(103); +end; + +procedure _PStrCat; +asm +{ ->EAX = Pointer to destination string } +{ EDX = Pointer to source string } + + PUSH ESI + PUSH EDI + +{ load dest len into EAX } + + MOV EDI,EAX + XOR EAX,EAX + MOV AL,[EDI] + +{ load source address in ESI, source len in ECX } + + MOV ESI,EDX + XOR ECX,ECX + MOV CL,[ESI] + INC ESI + +{ calculate final length in DL and store it in the destination } + + MOV DL,AL + ADD DL,CL + JC @@trunc + +@@cont: + MOV [EDI],DL + +{ calculate final dest address } + + INC EDI + ADD EDI,EAX + +{ do the copy } + + REP MOVSB + +{ done } + + POP EDI + POP ESI + RET + +@@trunc: + INC DL { DL = #chars to truncate } + SUB CL,DL { CL = source len - #chars to truncate } + MOV DL,255 { DL = maximum length } + JMP @@cont +end; + +procedure _PStrNCat; +asm +{ ->EAX = Pointer to destination string } +{ EDX = Pointer to source string } +{ CL = max length of result (allocated size of dest - 1) } + + PUSH ESI + PUSH EDI + +{ load dest len into EAX } + + MOV EDI,EAX + XOR EAX,EAX + MOV AL,[EDI] + +{ load source address in ESI, source len in EDX } + + MOV ESI,EDX + XOR EDX,EDX + MOV DL,[ESI] + INC ESI + +{ calculate final length in AL and store it in the destination } + + ADD AL,DL + JC @@trunc + CMP AL,CL + JA @@trunc + +@@cont: + MOV ECX,EDX + MOV DL,[EDI] + MOV [EDI],AL + +{ calculate final dest address } + + INC EDI + ADD EDI,EDX + +{ do the copy } + + REP MOVSB + +@@done: + POP EDI + POP ESI + RET + +@@trunc: +{ CL = maxlen } + + MOV AL,CL { AL = final length = maxlen } + SUB CL,[EDI] { CL = length to copy = maxlen - destlen } + JBE @@done + MOV DL,CL + JMP @@cont +end; + +procedure _PStrCpy(Dest: PShortString; Source: PShortString); +begin + Move(Source^, Dest^, Byte(Source^[0])+1); +end; + +procedure _PStrNCpy(Dest: PShortString; Source: PShortString; MaxLen: Byte); +begin + if MaxLen > Byte(Source^[0]) then + MaxLen := Byte(Source^[0]); + Byte(Dest^[0]) := MaxLen; + Move(Source^[1], Dest^[1], MaxLen); +end; + +procedure _PStrCmp; +asm +{ ->EAX = Pointer to left string } +{ EDX = Pointer to right string } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + XOR EAX,EAX + XOR EDX,EDX + MOV AL,[ESI] + MOV DL,[EDI] + INC ESI + INC EDI + + SUB EAX,EDX { eax = len1 - len2 } + JA @@skip1 + ADD EDX,EAX { edx = len2 + (len1 - len2) = len1 } + +@@skip1: + PUSH EDX + SHR EDX,2 + JE @@cmpRest +@@longLoop: + MOV ECX,[ESI] + MOV EBX,[EDI] + CMP ECX,EBX + JNE @@misMatch + DEC EDX + JE @@cmpRestP4 + MOV ECX,[ESI+4] + MOV EBX,[EDI+4] + CMP ECX,EBX + JNE @@misMatch + ADD ESI,8 + ADD EDI,8 + DEC EDX + JNE @@longLoop + JMP @@cmpRest +@@cmpRestP4: + ADD ESI,4 + ADD EDI,4 +@@cmpRest: + POP EDX + AND EDX,3 + JE @@equal + + MOV CL,[ESI] + CMP CL,[EDI] + JNE @@exit + DEC EDX + JE @@equal + MOV CL,[ESI+1] + CMP CL,[EDI+1] + JNE @@exit + DEC EDX + JE @@equal + MOV CL,[ESI+2] + CMP CL,[EDI+2] + JNE @@exit + +@@equal: + ADD EAX,EAX + JMP @@exit + +@@misMatch: + POP EDX + CMP CL,BL + JNE @@exit + CMP CH,BH + JNE @@exit + SHR ECX,16 + SHR EBX,16 + CMP CL,BL + JNE @@exit + CMP CH,BH + +@@exit: + POP EDI + POP ESI + POP EBX +end; + +procedure _AStrCmp; +asm +{ ->EAX = Pointer to left string } +{ EDX = Pointer to right string } +{ ECX = Number of chars to compare} + + PUSH EBX + PUSH ESI + PUSH ECX + MOV ESI,ECX + SHR ESI,2 + JE @@cmpRest + +@@longLoop: + MOV ECX,[EAX] + MOV EBX,[EDX] + CMP ECX,EBX + JNE @@misMatch + DEC ESI + JE @@cmpRestP4 + MOV ECX,[EAX+4] + MOV EBX,[EDX+4] + CMP ECX,EBX + JNE @@misMatch + ADD EAX,8 + ADD EDX,8 + DEC ESI + JNE @@longLoop + JMP @@cmpRest +@@cmpRestp4: + ADD EAX,4 + ADD EDX,4 +@@cmpRest: + POP ESI + AND ESI,3 + JE @@exit + + MOV CL,[EAX] + CMP CL,[EDX] + JNE @@exit + DEC ESI + JE @@equal + MOV CL,[EAX+1] + CMP CL,[EDX+1] + JNE @@exit + DEC ESI + JE @@equal + MOV CL,[EAX+2] + CMP CL,[EDX+2] + JNE @@exit + +@@equal: + XOR EAX,EAX + JMP @@exit + +@@misMatch: + POP ESI + CMP CL,BL + JNE @@exit + CMP CH,BH + JNE @@exit + SHR ECX,16 + SHR EBX,16 + CMP CL,BL + JNE @@exit + CMP CH,BH + +@@exit: + POP ESI + POP EBX +end; + +function _EofFile(var f: TFileRec): Boolean; +begin + Result := _FilePos(f) >= _FileSize(f); +end; + +function _EofText(var t: TTextRec): Boolean; +asm +// -> EAX Pointer to text record +// <- AL Boolean result + CMP [EAX].TTextRec.Mode,fmInput + JNE @@readChar + MOV EDX,[EAX].TTextRec.BufPos + CMP EDX,[EAX].TTextRec.BufEnd + JAE @@readChar + ADD EDX,[EAX].TTextRec.BufPtr + TEST [EAX].TTextRec.Flags,tfCRLF + JZ @@FalseExit + MOV CL,[EDX] + CMP CL,cEof + JNZ @@FalseExit + +@@eof: + MOV AL,1 + JMP @@exit + +@@readChar: + PUSH EAX + CALL _ReadChar + POP EDX + CMP AH,cEof + JE @@eof + DEC [EDX].TTextRec.BufPos +@@FalseExit: + XOR EAX,EAX +@@exit: +end; + +function _Eoln(var t: TTextRec): Boolean; +asm +// -> EAX Pointer to text record +// <- AL Boolean result + + CMP [EAX].TTextRec.Mode,fmInput + JNE @@readChar + MOV EDX,[EAX].TTextRec.BufPos + CMP EDX,[EAX].TTextRec.BufEnd + JAE @@readChar + ADD EDX,[EAX].TTextRec.BufPtr + TEST [EAX].TTextRec.Flags,tfCRLF + MOV AL,0 + MOV CL,[EDX] + JZ @@testLF + CMP CL,cCR + JE @@eol + CMP CL,cEOF + JE @@eof + JMP @@exit + +@@testLF: + CMP CL,cLF + JE @@eol + CMP CL,cEOF + JE @@eof + JMP @@exit + +@@readChar: + PUSH EAX + CALL _ReadChar + POP EDX + CMP AH,cEOF + JE @@eof + DEC [EDX].TTextRec.BufPos + XOR ECX,ECX + XCHG ECX,EAX + TEST [EDX].TTextRec.Mode,tfCRLF + JNE @@testLF + CMP CL,cCR + JE @@eol + JMP @@exit + +@@eol: +@@eof: + MOV AL,1 +@@exit: +end; + +procedure _Erase(var f: TFileRec); +begin + if (f.Mode < fmClosed) or (f.Mode > fmInOut) then + SetInOutRes(102) // file not assigned + else +{$IFDEF LINUX} + if __remove(f.Name) < 0 then + SetInOutRes(GetLastError); +{$ENDIF} +{$IFDEF MSWINDOWS} + if not DeleteFileA(f.Name) then + SetInOutRes(GetLastError); +{$ENDIF} +end; + +{$IFDEF MSWINDOWS} +// Floating-point divide reverse routine +// ST(1) = ST(0) / ST(1), pop ST + +procedure _FSafeDivideR; +asm + FXCH + JMP _FSafeDivide +end; + +// Floating-point divide routine +// ST(1) = ST(1) / ST(0), pop ST + +procedure _FSafeDivide; +type + Z = packed record // helper type to make parameter references more readable + Dividend: Extended; // (TBYTE PTR [ESP]) + Pad: Word; + Divisor: Extended; // (TBYTE PTR [ESP+12]) + end; +asm + CMP TestFDIV,0 //Check FDIV indicator + JLE @@FDivideChecked //Jump if flawed or don't know + FDIV //Known to be ok, so just do FDIV + RET + +// FDIV constants +@@FDIVRiscTable: DB 0,1,0,0,4,0,0,7,0,0,10,0,0,13,0,0; + +@@FDIVScale1: DD $3F700000 // 0.9375 +@@FDIVScale2: DD $3F880000 // 1.0625 +@@FDIV1SHL63: DD $5F000000 // 1 SHL 63 + +@@TestDividend: DD $C0000000,$4150017E // 4195835.0 +@@TestDivisor: DD $80000000,$4147FFFF // 3145727.0 +@@TestOne: DD $00000000,$3FF00000 // 1.0 + +// Flawed FDIV detection +@@FDivideDetect: + MOV TestFDIV,1 //Indicate correct FDIV + PUSH EAX + SUB ESP,12 + FSTP TBYTE PTR [ESP] //Save off ST + FLD QWORD PTR @@TestDividend //Ok if x - (x / y) * y < 1.0 + FDIV QWORD PTR @@TestDivisor + FMUL QWORD PTR @@TestDivisor + FSUBR QWORD PTR @@TestDividend + FCOMP QWORD PTR @@TestOne + FSTSW AX + SHR EAX,7 + AND EAX,002H //Zero if FDIV is flawed + DEC EAX + MOV TestFDIV,AL //1 means Ok, -1 means flawed + FLD TBYTE PTR [ESP] //Restore ST + ADD ESP,12 + POP EAX + JMP _FSafeDivide + +@@FDivideChecked: + JE @@FDivideDetect //Do detection if TestFDIV = 0 + +@@1: PUSH EAX + SUB ESP,24 + FSTP [ESP].Z.Divisor //Store Divisor and Dividend + FSTP [ESP].Z.Dividend + FLD [ESP].Z.Dividend + FLD [ESP].Z.Divisor +@@2: MOV EAX,DWORD PTR [ESP+4].Z.Divisor //Is Divisor a denormal? + ADD EAX,EAX + JNC @@20 //Yes, @@20 + XOR EAX,0E000000H //If these three bits are not all + TEST EAX,0E000000H //ones, FDIV will work + JZ @@10 //Jump if all ones +@@3: FDIV //Do FDIV and exit + ADD ESP,24 + POP EAX + RET + +@@10: SHR EAX,28 //If the four bits following the MSB + //of the mantissa have a decimal + //of 1, 4, 7, 10, or 13, FDIV may + CMP byte ptr @@FDIVRiscTable[EAX],0 //not work correctly + JZ @@3 //Do FDIV if not 1, 4, 7, 10, or 13 + MOV EAX,DWORD PTR [ESP+8].Z.Divisor //Get Divisor exponent + AND EAX,7FFFH + JZ @@3 //Ok to FDIV if denormal + CMP EAX,7FFFH + JE @@3 //Ok to FDIV if NAN or INF + MOV EAX,DWORD PTR [ESP+8].Z.Dividend //Get Dividend exponent + AND EAX,7FFFH + CMP EAX,1 //Small number? + JE @@11 //Yes, @@11 + FMUL DWORD PTR @@FDIVScale1 //Scale by 15/16 + FXCH + FMUL DWORD PTR @@FDIVScale1 + FXCH + JMP @@3 //FDIV is now safe + +@@11: FMUL DWORD PTR @@FDIVScale2 //Scale by 17/16 + FXCH + FMUL DWORD PTR @@FDIVScale2 + FXCH + JMP @@3 //FDIV is now safe + +@@20: MOV EAX,DWORD PTR [ESP].Z.Divisor //Is entire Divisor zero? + OR EAX,DWORD PTR [ESP+4].Z.Divisor + JZ @@3 //Yes, ok to FDIV + MOV EAX,DWORD PTR [ESP+8].Z.Divisor //Get Divisor exponent + AND EAX,7FFFH //Non-zero exponent is invalid + JNZ @@3 //Ok to FDIV if invalid + MOV EAX,DWORD PTR [ESP+8].Z.Dividend //Get Dividend exponent + AND EAX,7FFFH //Denormal? + JZ @@21 //Yes, @@21 + CMP EAX,7FFFH //NAN or INF? + JE @@3 //Yes, ok to FDIV + MOV EAX,DWORD PTR [ESP+4].Z.Dividend //If MSB of mantissa is zero, + ADD EAX,EAX //the number is invalid + JNC @@3 //Ok to FDIV if invalid + JMP @@22 +@@21: MOV EAX,DWORD PTR [ESP+4].Z.Dividend //If MSB of mantissa is zero, + ADD EAX,EAX //the number is invalid + JC @@3 //Ok to FDIV if invalid +@@22: FXCH //Scale stored Divisor image by + FSTP ST(0) //1 SHL 63 and restart + FLD ST(0) + FMUL DWORD PTR @@FDIV1SHL63 + FSTP [ESP].Z.Divisor + FLD [ESP].Z.Dividend + FXCH + JMP @@2 +end; +{$ENDIF} + +function _FilePos(var f: TFileRec): Longint; +begin + if (f.Mode > fmClosed) and (f.Mode <= fmInOut) then + begin +{$IFDEF LINUX} + Result := _lseek(f.Handle, 0, SEEK_CUR); +{$ENDIF} +{$IFDEF MSWINDOWS} + Result := SetFilePointer(f.Handle, 0, nil, FILE_CURRENT); +{$ENDIF} + if Result = -1 then + InOutError + else + Result := Cardinal(Result) div f.RecSize; + end + else + begin + SetInOutRes(103); + Result := -1; + end; +end; + +function _FileSize(var f: TFileRec): Longint; +{$IFDEF MSWINDOWS} +begin + Result := -1; + if (f.Mode > fmClosed) and (f.Mode <= fmInOut) then + begin + Result := GetFileSize(f.Handle, 0); + if Result = -1 then + InOutError + else + Result := Cardinal(Result) div f.RecSize; + end + else + SetInOutRes(103); +{$ENDIF} +{$IFDEF LINUX} +var + stat: TStatStruct; +begin + Result := -1; + if (f.Mode > fmClosed) and (f.Mode <= fmInOut) then + begin + if _fxstat(STAT_VER_LINUX, f.Handle, stat) <> 0 then + InOutError + else + Result := stat.st_size div f.RecSize; + end + else + SetInOutRes(103); +{$ENDIF} +end; + +procedure _FillChar(var Dest; count: Integer; Value: Char); +{$IFDEF PUREPASCAL} +var + I: Integer; + P: PChar; +begin + P := PChar(@Dest); + for I := count-1 downto 0 do + P[I] := Value; +end; +{$ELSE} +asm +{ ->EAX Pointer to destination } +{ EDX count } +{ CL value } + + PUSH EDI + + MOV EDI,EAX { Point EDI to destination } + + MOV CH,CL { Fill EAX with value repeated 4 times } + MOV EAX,ECX + SHL EAX,16 + MOV AX,CX + + MOV ECX,EDX + SAR ECX,2 + JS @@exit + + REP STOSD { Fill count DIV 4 dwords } + + MOV ECX,EDX + AND ECX,3 + REP STOSB { Fill count MOD 4 bytes } + +@@exit: + POP EDI +end; +{$ENDIF} + +procedure Mark; +begin + Error(reInvalidPtr); +end; + +procedure _RandInt; +asm +{ ->EAX Range } +{ <-EAX Result } + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX + MOV ECX,[EBX].OFFSET RandSeed + IMUL EDX,[ECX],08088405H + INC EDX + MOV [ECX],EDX +{$ELSE} + XOR EBX, EBX + IMUL EDX,[EBX].RandSeed,08088405H + INC EDX + MOV [EBX].RandSeed,EDX +{$ENDIF} + MUL EDX + MOV EAX,EDX + POP EBX +end; + +procedure _RandExt; +const two2neg32: double = ((1.0/$10000) / $10000); // 2^-32 +asm +{ FUNCTION _RandExt: Extended; } + + PUSH EBX +{$IFDEF PIC} + CALL GetGOT + MOV EBX,EAX + MOV ECX,[EBX].OFFSET RandSeed + IMUL EDX,[ECX],08088405H + INC EDX + MOV [ECX],EDX +{$ELSE} + XOR EBX, EBX + IMUL EDX,[EBX].RandSeed,08088405H + INC EDX + MOV [EBX].RandSeed,EDX +{$ENDIF} + + FLD [EBX].two2neg32 + PUSH 0 + PUSH EDX + FILD qword ptr [ESP] + ADD ESP,8 + FMULP ST(1), ST(0) + POP EBX +end; + +function _ReadRec(var f: TFileRec; Buffer: Pointer): Integer; +{$IFDEF LINUX} +begin + if (f.Mode and fmInput) = fmInput then // fmInput or fmInOut + begin + Result := __read(f.Handle, Buffer, f.RecSize); + if Result = -1 then + InOutError + else if Cardinal(Result) <> f.RecSize then + SetInOutRes(100); + end + else + begin + SetInOutRes(103); // file not open for input + Result := 0; + end; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm +// -> EAX Pointer to file variable +// EDX Pointer to buffer + + PUSH EBX + XOR ECX,ECX + MOV EBX,EAX + MOV CX,[EAX].TFileRec.Mode // File must be open + SUB ECX,fmInput + JE @@skip + SUB ECX,fmInOut-fmInput + JNE @@fileNotOpen +@@skip: + +// ReadFile(f.Handle, buffer, f.RecSize, @result, Nil); + + PUSH 0 // space for OS result + MOV EAX,ESP + + PUSH 0 // pass lpOverlapped + PUSH EAX // pass @result + + PUSH [EBX].TFileRec.RecSize // pass nNumberOfBytesToRead + + PUSH EDX // pass lpBuffer + PUSH [EBX].TFileRec.Handle // pass hFile + CALL ReadFile + POP EDX // pop result + DEC EAX // check EAX = TRUE + JNZ @@error + + CMP EDX,[EBX].TFileRec.RecSize // result = f.RecSize ? + JE @@exit + +@@readError: + MOV EAX,100 + JMP @@errExit + +@@fileNotOpen: + MOV EAX,103 + JMP @@errExit + +@@error: + CALL GetLastError +@@errExit: + CALL SetInOutRes +@@exit: + POP EBX +end; +{$ENDIF} + + +// If the file is Input std variable, try to open it +// Otherwise, runtime error. +function TryOpenForInput(var t: TTextRec): Boolean; +begin + if @t = @Input then + begin + t.Flags := tfCRLF * Byte(DefaultTextLineBreakStyle); + _ResetText(t); + end; + + Result := t.Mode = fmInput; + if not Result then + SetInOutRes(104); +end; + +function _ReadChar(var t: TTextRec): Char; +asm +// -> EAX Pointer to text record +// <- AL Character read. (may be a pseudo cEOF in DOS mode) +// <- AH cEOF = End of File, else 0 +// For eof, #$1A is returned in AL and in AH. +// For errors, InOutRes is set and #$1A is returned. + + CMP [EAX].TTextRec.Mode, fmInput + JE @@checkBuf + PUSH EAX + CALL TryOpenForInput + TEST AL,AL + POP EAX + JZ @@eofexit + +@@checkBuf: + MOV EDX,[EAX].TTextRec.BufPos + CMP EDX,[EAX].TTextRec.BufEnd + JAE @@fillBuf +@@cont: + TEST [EAX].TTextRec.Flags,tfCRLF + MOV ECX,[EAX].TTextRec.BufPtr + MOV CL,[ECX+EDX] + JZ @@cont2 + CMP CL,cEof // Check for EOF char in DOS mode + JE @@eofexit +@@cont2: + INC EDX + MOV [EAX].TTextRec.BufPos,EDX + XOR EAX,EAX + JMP @@exit + +@@fillBuf: + PUSH EAX + CALL [EAX].TTextRec.InOutFunc + TEST EAX,EAX + JNE @@error + POP EAX + MOV EDX,[EAX].TTextRec.BufPos + CMP EDX,[EAX].TTextRec.BufEnd + JB @@cont + +// We didn't get characters. Must be eof then. + +@@eof: + TEST [EAX].TTextRec.Flags,tfCRLF + JZ @@eofexit +// In DOS CRLF compatibility mode, synthesize an EOF char +// Store one eof in the buffer and increment BufEnd + MOV ECX,[EAX].TTextRec.BufPtr + MOV byte ptr [ECX+EDX],cEof + INC [EAX].TTextRec.BufEnd + JMP @@eofexit + +@@error: + CALL SetInOutRes + POP EAX +@@eofexit: + MOV CL,cEof + MOV AH,CL +@@exit: + MOV AL,CL +end; + +function _ReadLong(var t: TTextRec): Longint; +asm +// -> EAX Pointer to text record +// <- EAX Result + + PUSH EBX + PUSH ESI + PUSH EDI + SUB ESP,36 // var numbuf: String[32]; + + MOV ESI,EAX + CALL _SeekEof + DEC AL + JZ @@eof + + MOV EDI,ESP // EDI -> numBuf[0] + MOV BL,32 +@@loop: + MOV EAX,ESI + CALL _ReadChar + CMP AL,' ' + JBE @@endNum + STOSB + DEC BL + JNZ @@loop +@@convert: + MOV byte ptr [EDI],0 + MOV EAX,ESP // EAX -> numBuf + PUSH EDX // allocate code result + MOV EDX,ESP // pass pointer to code + CALL _ValLong // convert + POP EDX // pop code result into EDX + TEST EDX,EDX + JZ @@exit + MOV EAX,106 + CALL SetInOutRes + JMP @@exit + +@@endNum: + CMP AH,cEof + JE @@convert + DEC [ESI].TTextRec.BufPos + JMP @@convert + +@@eof: + XOR EAX,EAX +@@exit: + ADD ESP,36 + POP EDI + POP ESI + POP EBX +end; + +function ReadLine(var t: TTextRec; buf: Pointer; maxLen: Longint): Pointer; +asm +// -> EAX Pointer to text record +// EDX Pointer to buffer +// ECX Maximum count of chars to read +// <- ECX Actual count of chars in buffer +// <- EAX Pointer to text record + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH ECX + MOV ESI,ECX + MOV EDI,EDX + + CMP [EAX].TTextRec.Mode,fmInput + JE @@start + PUSH EAX + CALL TryOpenForInput + TEST AL,AL + POP EAX + JZ @@exit + +@@start: + MOV EBX,EAX + + TEST ESI,ESI + JLE @@exit + + MOV EDX,[EBX].TTextRec.BufPos + MOV ECX,[EBX].TTextRec.BufEnd + SUB ECX,EDX + ADD EDX,[EBX].TTextRec.BufPtr + +@@loop: + DEC ECX + JL @@readChar + MOV AL,[EDX] + INC EDX +@@cont: + CMP AL,cLF + JE @@lf + + CMP AL,cCR + JE @@cr + + STOSB + DEC ESI + JG @@loop + JMP @@finish + +@@cr: + MOV AL,[EDX] + CMP AL,cLF + JNE @@loop +@@lf: + DEC EDX +@@finish: + SUB EDX,[EBX].TTextRec.BufPtr + MOV [EBX].TTextRec.BufPos,EDX + JMP @@exit + +@@readChar: + MOV [EBX].TTextRec.BufPos,EDX + MOV EAX,EBX + CALL _ReadChar + MOV EDX,[EBX].TTextRec.BufPos + MOV ECX,[EBX].TTextRec.BufEnd + SUB ECX,EDX + ADD EDX,[EBX].TTextRec.BufPtr + TEST AH,AH //eof + JZ @@cont + +@@exit: + MOV EAX,EBX + POP ECX + SUB ECX,ESI + POP EDI + POP ESI + POP EBX +end; + +procedure _ReadString(var t: TTextRec; s: PShortString; maxLen: Longint); +asm +// -> EAX Pointer to text record +// EDX Pointer to string +// ECX Maximum length of string + + PUSH EDX + INC EDX + CALL ReadLine + POP EDX + MOV [EDX],CL +end; + +procedure _ReadCString(var t: TTextRec; s: PChar; maxLen: Longint); +asm +// -> EAX Pointer to text record +// EDX Pointer to string +// ECX Maximum length of string + + PUSH EDX + CALL ReadLine + POP EDX + MOV byte ptr [EDX+ECX],0 +end; + +procedure _ReadLString(var t: TTextRec; var s: AnsiString); +asm + { -> EAX pointer to Text } + { EDX pointer to AnsiString } + + PUSH EBX + PUSH ESI + MOV EBX,EAX + MOV ESI,EDX + + MOV EAX,EDX + CALL _LStrClr + + SUB ESP,256 + + MOV EAX,EBX + MOV EDX,ESP + MOV ECX,255 + CALL _ReadString + + MOV EAX,ESI + MOV EDX,ESP + CALL _LStrFromString + + CMP byte ptr [ESP],255 + JNE @@exit +@@loop: + + MOV EAX,EBX + MOV EDX,ESP + MOV ECX,255 + CALL _ReadString + + MOV EDX,ESP + PUSH 0 + MOV EAX,ESP + CALL _LStrFromString + + MOV EAX,ESI + MOV EDX,[ESP] + CALL _LStrCat + + MOV EAX,ESP + CALL _LStrClr + POP EAX + + CMP byte ptr [ESP],255 + JE @@loop + +@@exit: + ADD ESP,256 + POP ESI + POP EBX +end; + + +function IsValidMultibyteChar(const Src: PChar; SrcBytes: Integer): Boolean; +{$IFDEF MSWINDOWS} +const + ERROR_NO_UNICODE_TRANSLATION = 1113; // Win32 GetLastError when result = 0 + MB_ERR_INVALID_CHARS = 8; +var + Dest: WideChar; +begin + Result := MultiByteToWideChar(0, MB_ERR_INVALID_CHARS, Src, SrcBytes, @Dest, 1) <> 0; +{$ENDIF} +{$IFDEF LINUX} +begin + Result := mblen(Src, SrcBytes) <> -1; +{$ENDIF} +end; + + +function _ReadWChar(var t: TTextRec): WideChar; +var + scratch: array [0..7] of AnsiChar; + wc: WideChar; + i: Integer; +begin + i := 0; + while i < High(scratch) do + begin + scratch[i] := _ReadChar(t); + Inc(i); + scratch[i] := #0; + if IsValidMultibyteChar(scratch, i) then + begin + WCharFromChar(@wc, 1, scratch, i); + Result := wc; + Exit; + end; + end; + SetInOutRes(106); // Invalid Input + Result := #0; +end; + + +procedure _ReadWCString(var t: TTextRec; s: PWideChar; maxBytes: Longint); +var + i, maxLen: Integer; + wc: WideChar; +begin + if s = nil then Exit; + i := 0; + maxLen := maxBytes div sizeof(WideChar); + while i < maxLen do + begin + wc := _ReadWChar(t); + case Integer(wc) of + cEOF: if _EOFText(t) then Break; + cLF : begin + Dec(t.BufPos); + Break; + end; + cCR : if Byte(t.BufPtr[t.BufPos]) = cLF then + begin + Dec(t.BufPos); + Break; + end; + end; + s[i] := wc; + Inc(i); + end; + s[i] := #0; +end; + +procedure _ReadWString(var t: TTextRec; var s: WideString); +var + Temp: AnsiString; +begin + _ReadLString(t, Temp); + s := Temp; +end; + +function _ReadExt(var t: TTextRec): Extended; +asm +// -> EAX Pointer to text record +// <- FST(0) Result + + PUSH EBX + PUSH ESI + PUSH EDI + SUB ESP,68 // var numbuf: array[0..64] of char; + + MOV ESI,EAX + CALL _SeekEof + DEC AL + JZ @@eof + + MOV EDI,ESP // EDI -> numBuf[0] + MOV BL,64 +@@loop: + MOV EAX,ESI + CALL _ReadChar + CMP AL,' ' + JBE @@endNum + STOSB + DEC BL + JNZ @@loop +@@convert: + MOV byte ptr [EDI],0 + MOV EAX,ESP // EAX -> numBuf + PUSH EDX // allocate code result + MOV EDX,ESP // pass pointer to code + CALL _ValExt // convert + POP EDX // pop code result into EDX + TEST EDX,EDX + JZ @@exit + MOV EAX,106 + CALL SetInOutRes + JMP @@exit + +@@endNum: + CMP AH,cEOF + JE @@convert + DEC [ESI].TTextRec.BufPos + JMP @@convert + +@@eof: + FLDZ +@@exit: + ADD ESP,68 + POP EDI + POP ESI + POP EBX +end; + +procedure _ReadLn(var t: TTextRec); +asm +// -> EAX Pointer to text record + + PUSH EBX + MOV EBX,EAX +@@loop: + MOV EAX,EBX + CALL _ReadChar + + CMP AL,cLF // accept LF as end of line + JE @@exit + CMP AH,cEOF + JE @@eof + CMP AL,cCR + JNE @@loop + + MOV EAX,EBX + CALL _ReadChar + + CMP AL,cLF // accept CR+LF as end of line + JE @@exit + CMP AH,cEOF // accept CR+EOF as end of line + JE @@eof + DEC [EBX].TTextRec.BufPos + JMP @@loop // else CR+ anything else is not a line break. + +@@exit: +@@eof: + POP EBX +end; + +procedure _Rename(var f: TFileRec; newName: PChar); +var + I: Integer; +begin + if f.Mode = fmClosed then + begin + if newName = nil then newName := ''; +{$IFDEF LINUX} + if __rename(f.Name, newName) = 0 then +{$ENDIF} +{$IFDEF MSWINDOWS} + if MoveFileA(f.Name, newName) then +{$ENDIF} + begin + I := 0; + while (newName[I] <> #0) and (I < High(f.Name)) do + begin + f.Name[I] := newName[I]; + Inc(I); + end + end + else + SetInOutRes(GetLastError); + end + else + SetInOutRes(102); +end; + +procedure Release; +begin + Error(reInvalidPtr); +end; + +function _CloseFile(var f: TFileRec): Integer; +begin + f.Mode := fmClosed; + Result := 0; + if not InternalClose(f.Handle) then + begin + InOutError; + Result := 1; + end; +end; + +function OpenFile(var f: TFileRec; recSiz: Longint; mode: Longint): Integer; +{$IFDEF LINUX} +var + Flags: Integer; +begin + Result := 0; + if (f.Mode >= fmClosed) and (f.Mode <= fmInOut) then + begin + if f.Mode <> fmClosed then // not yet closed: close it + begin + Result := TFileIOFunc(f.CloseFunc)(f); + if Result <> 0 then + SetInOutRes(Result); + end; + + if recSiz <= 0 then + SetInOutRes(106); + + f.RecSize := recSiz; + f.InOutFunc := @FileNopProc; + + if f.Name[0] <> #0 then + begin + f.CloseFunc := @_CloseFile; + case mode of + 1: begin + Flags := O_APPEND or O_WRONLY; + f.Mode := fmOutput; + end; + 2: begin + Flags := O_RDWR; + f.Mode := fmInOut; + end; + 3: begin + Flags := O_CREAT or O_TRUNC or O_RDWR; + f.Mode := fmInOut; + end; + else + Flags := O_RDONLY; + f.Mode := fmInput; + end; + + f.Handle := __open(f.Name, Flags, FileAccessRights); + end + else // stdin or stdout + begin + f.CloseFunc := @FileNopProc; + if mode = 3 then + f.Handle := STDOUT_FILENO + else + f.Handle := STDIN_FILENO; + end; + + if f.Handle = -1 then + begin + f.Mode := fmClosed; + InOutError; + end; + end + else + SetInOutRes(102); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +const + ShareTab: array [0..7] of Integer = + (FILE_SHARE_READ OR FILE_SHARE_WRITE, // OF_SHARE_COMPAT 0x00000000 + 0, // OF_SHARE_EXCLUSIVE 0x00000010 + FILE_SHARE_READ, // OF_SHARE_DENY_WRITE 0x00000020 + FILE_SHARE_WRITE, // OF_SHARE_DENY_READ 0x00000030 + FILE_SHARE_READ OR FILE_SHARE_WRITE, // OF_SHARE_DENY_NONE 0x00000040 + 0,0,0); +asm +//-> EAX Pointer to file record +// EDX Record size +// ECX File mode + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EDX + MOV EDI,ECX + XOR EDX,EDX + MOV EBX,EAX + + MOV DX,[EAX].TFileRec.Mode + SUB EDX,fmClosed + JE @@alreadyClosed + CMP EDX,fmInOut-fmClosed + JA @@notAssignedError + +// not yet closed: close it. File parameter is still in EAX + + CALL [EBX].TFileRec.CloseFunc + TEST EAX,EAX + JE @@alreadyClosed + CALL SetInOutRes + +@@alreadyClosed: + + MOV [EBX].TFileRec.Mode,fmInOut + MOV [EBX].TFileRec.RecSize,ESI + MOV [EBX].TFileRec.CloseFunc,offset _CloseFile + MOV [EBX].TFileRec.InOutFunc,offset FileNopProc + + CMP byte ptr [EBX].TFileRec.Name,0 + JE @@isCon + + MOV EAX,GENERIC_READ OR GENERIC_WRITE + MOV DL,FileMode + AND EDX,070H + SHR EDX,4-2 + MOV EDX,dword ptr [shareTab+EDX] + MOV ECX,CREATE_ALWAYS + + SUB EDI,3 + JE @@calledByRewrite + + MOV ECX,OPEN_EXISTING + INC EDI + JE @@skip + + MOV EAX,GENERIC_WRITE + INC EDI + MOV [EBX].TFileRec.Mode,fmOutput + JE @@skip + + MOV EAX,GENERIC_READ + MOV [EBX].TFileRec.Mode,fmInput + +@@skip: +@@calledByRewrite: + +// CreateFile(t.FileName, EAX, EDX, Nil, ECX, FILE_ATTRIBUTE_NORMAL, 0); + + PUSH 0 + PUSH FILE_ATTRIBUTE_NORMAL + PUSH ECX + PUSH 0 + PUSH EDX + PUSH EAX + LEA EAX,[EBX].TFileRec.Name + PUSH EAX + CALL CreateFileA +@@checkHandle: + CMP EAX,-1 + JZ @@error + + MOV [EBX].TFileRec.Handle,EAX + JMP @@exit + +@@isCon: + MOV [EBX].TFileRec.CloseFunc,offset FileNopProc + CMP EDI,3 + JE @@output + PUSH STD_INPUT_HANDLE + JMP @@1 +@@output: + PUSH STD_OUTPUT_HANDLE +@@1: + CALL GetStdHandle + JMP @@checkHandle + +@@notAssignedError: + MOV EAX,102 + JMP @@errExit + +@@error: + MOV [EBX].TFileRec.Mode,fmClosed + CALL GetLastError +@@errExit: + CALL SetInOutRes + +@@exit: + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +function _ResetFile(var f: TFileRec; recSize: Longint): Integer; +var + m: Byte; +begin + m := FileMode and 3; + if m > 2 then m := 2; + Result := OpenFile(f, recSize, m); +end; + +function _RewritFile(var f: TFileRec; recSize: Longint): Integer; +begin + Result := OpenFile(f, recSize, 3); +end; + +procedure _Seek(var f: TFileRec; recNum: Cardinal); +{$IFDEF LINUX} +begin + if (f.Mode >= fmInput) and (f.Mode <= fmInOut) then + begin + if _lseek(f.Handle, f.RecSize * recNum, SEEK_SET) = -1 then + InOutError; + end + else + SetInOutRes(103); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm +// -> EAX Pointer to file variable +// EDX Record number + + MOV ECX,EAX + MOVZX EAX,[EAX].TFileRec.Mode // check whether file is open + SUB EAX,fmInput + CMP EAX,fmInOut-fmInput + JA @@fileNotOpen + +// SetFilePointer(f.Handle, recNum*f.RecSize, FILE_BEGIN + PUSH FILE_BEGIN // pass dwMoveMethod + MOV EAX,[ECX].TFileRec.RecSize + MUL EDX + PUSH 0 // pass lpDistanceToMoveHigh + PUSH EAX // pass lDistanceToMove + PUSH [ECX].TFileRec.Handle // pass hFile + CALL SetFilePointer // get current position + INC EAX + JZ InOutError + JMP @@exit + +@@fileNotOpen: + MOV EAX,103 + JMP SetInOutRes + +@@exit: +end; +{$ENDIF} + +function _SeekEof(var t: TTextRec): Boolean; +asm +// -> EAX Pointer to text record +// <- AL Boolean result + + PUSH EBX + MOV EBX,EAX +@@loop: + MOV EAX,EBX + CALL _ReadChar + CMP AL,' ' + JA @@endloop + CMP AH,cEOF + JE @@eof + JMP @@loop +@@eof: + MOV AL,1 + JMP @@exit + +@@endloop: + DEC [EBX].TTextRec.BufPos + XOR AL,AL +@@exit: + POP EBX +end; + +function _SeekEoln(var t: TTextRec): Boolean; +asm +// -> EAX Pointer to text record +// <- AL Boolean result + + PUSH EBX + MOV EBX,EAX +@@loop: + MOV EAX,EBX + CALL _ReadChar + CMP AL,' ' + JA @@falseExit + CMP AH,cEOF + JE @@eof + CMP AL,cLF + JE @@trueExit + CMP AL,cCR + JNE @@loop + +@@trueExit: + MOV AL,1 + JMP @@exitloop + +@@falseExit: + XOR AL,AL +@@exitloop: + DEC [EBX].TTextRec.BufPos + JMP @@exit + +@@eof: + MOV AL,1 +@@exit: + POP EBX +end; + +procedure _SetTextBuf(var t: TTextRec; p: Pointer; size: Longint); +begin + t.BufPtr := P; + t.BufSize := size; + t.BufPos := 0; + t.BufEnd := 0; +end; + +procedure _StrLong(val, width: Longint; s: PShortString); +{$IFDEF PUREPASCAL} +var + I: Integer; + sign: Longint; + a: array [0..19] of char; + P: PChar; +begin + sign := val; + val := Abs(val); + I := 0; + repeat + a[I] := Chr((val mod 10) + Ord('0')); + Inc(I); + val := val div 10; + until val = 0; + + if sign < 0 then + begin + a[I] := '-'; + Inc(I); + end; + + if width < I then + width := I; + if width > 255 then + width := 255; + s^[0] := Chr(width); + P := @S^[1]; + while width > I do + begin + P^ := ' '; + Inc(P); + Dec(width); + end; + repeat + Dec(I); + P^ := a[I]; + Inc(P); + until I <= 0; +end; +{$ELSE} +asm +{ PROCEDURE _StrLong( val: Longint; width: Longint; VAR s: ShortString ); + ->EAX Value + EDX Width + ECX Pointer to string } + + PUSH EBX { VAR i: Longint; } + PUSH ESI { VAR sign : Longint; } + PUSH EDI + PUSH EDX { store width on the stack } + SUB ESP,20 { VAR a: array [0..19] of Char; } + + MOV EDI,ECX + + MOV ESI,EAX { sign := val } + + CDQ { val := Abs(val); canned sequence } + XOR EAX,EDX + SUB EAX,EDX + + MOV ECX,10 + XOR EBX,EBX { i := 0; } + +@@repeat1: { repeat } + XOR EDX,EDX { a[i] := Chr( val MOD 10 + Ord('0') );} + + DIV ECX { val := val DIV 10; } + + ADD EDX,'0' + MOV [ESP+EBX],DL + INC EBX { i := i + 1; } + TEST EAX,EAX { until val = 0; } + JNZ @@repeat1 + + TEST ESI,ESI + JGE @@2 + MOV byte ptr [ESP+EBX],'-' + INC EBX +@@2: + MOV [EDI],BL { s^++ := Chr(i); } + INC EDI + + MOV ECX,[ESP+20] { spaceCnt := width - i; } + CMP ECX,255 + JLE @@3 + MOV ECX,255 +@@3: + SUB ECX,EBX + JLE @@repeat2 { for k := 1 to spaceCnt do s^++ := ' '; } + ADD [EDI-1],CL + MOV AL,' ' + REP STOSB + +@@repeat2: { repeat } + MOV AL,[ESP+EBX-1] { s^ := a[i-1]; } + MOV [EDI],AL + INC EDI { s := s + 1 } + DEC EBX { i := i - 1; } + JNZ @@repeat2 { until i = 0; } + + ADD ESP,20+4 + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +procedure _Str0Long(val: Longint; s: PShortString); +begin + _StrLong(val, 0, s); +end; + +procedure _Truncate(var f: TFileRec); +{$IFDEF LINUX} +begin + if (f.Mode and fmOutput) = fmOutput then // fmOutput or fmInOut + begin + if _ftruncate(f.Handle, _lseek(f.Handle, 0, SEEK_CUR)) = -1 then + InOutError; + end + else + SetInOutRes(103); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm +// -> EAX Pointer to text or file variable + + MOVZX EDX,[EAX].TFileRec.Mode // check whether file is open + SUB EDX,fmInput + CMP EDX,fmInOut-fmInput + JA @@fileNotOpen + + PUSH [EAX].TFileRec.Handle + CALL SetEndOfFile + DEC EAX + JZ @@exit + JMP InOutError + +@@fileNotOpen: + MOV EAX,103 + JMP SetInOutRes + +@@exit: +end; +{$ENDIF} + +function _ValLong(const s: String; var code: Integer): Longint; +{$IFDEF PUREPASCAL} +var + I: Integer; + Negative, Hex: Boolean; +begin + I := 1; + code := -1; + Result := 0; + Negative := False; + Hex := False; + while (I <= Length(s)) and (s[I] = ' ') do Inc(I); + if I > Length(s) then Exit; + case s[I] of + '$', + 'x', + 'X': begin + Hex := True; + Inc(I); + end; + '0': begin + Hex := (Length(s) > I) and (UpCase(s[I+1]) = 'X'); + if Hex then Inc(I,2); + end; + '-': begin + Negative := True; + Inc(I); + end; + '+': Inc(I); + end; + if Hex then + while I <= Length(s) do + begin + if Result > (High(Result) div 16) then + begin + code := I; + Exit; + end; + case s[I] of + '0'..'9': Result := Result * 16 + Ord(s[I]) - Ord('0'); + 'a'..'f': Result := Result * 16 + Ord(s[I]) - Ord('a') + 10; + 'A'..'F': Result := Result * 16 + Ord(s[I]) - Ord('A') + 10; + else + code := I; + Exit; + end; + end + else + while I <= Length(s) do + begin + if Result > (High(Result) div 10) then + begin + code := I; + Exit; + end; + Result := Result * 10 + Ord(s[I]) - Ord('0'); + Inc(I); + end; + if Negative then + Result := -Result; + code := 0; +end; +{$ELSE} +asm +{ FUNCTION _ValLong( s: AnsiString; VAR code: Integer ) : Longint; } +{ ->EAX Pointer to string } +{ EDX Pointer to code result } +{ <-EAX Result } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX + PUSH EAX { save for the error case } + + TEST EAX,EAX + JE @@empty + + XOR EAX,EAX + XOR EBX,EBX + MOV EDI,07FFFFFFFH / 10 { limit } + +@@blankLoop: + MOV BL,[ESI] + INC ESI + CMP BL,' ' + JE @@blankLoop + +@@endBlanks: + MOV CH,0 + CMP BL,'-' + JE @@minus + CMP BL,'+' + JE @@plus + CMP BL,'$' + JE @@dollar + + CMP BL, 'x' + JE @@dollar + CMP BL, 'X' + JE @@dollar + CMP BL, '0' + JNE @@firstDigit + MOV BL, [ESI] + INC ESI + CMP BL, 'x' + JE @@dollar + CMP BL, 'X' + JE @@dollar + TEST BL, BL + JE @@endDigits + JMP @@digLoop + +@@firstDigit: + TEST BL,BL + JE @@error + +@@digLoop: + SUB BL,'0' + CMP BL,9 + JA @@error + CMP EAX,EDI { value > limit ? } + JA @@overFlow + LEA EAX,[EAX+EAX*4] + ADD EAX,EAX + ADD EAX,EBX { fortunately, we can't have a carry } + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JNE @@digLoop + +@@endDigits: + DEC CH + JE @@negate + TEST EAX,EAX + JGE @@successExit + JMP @@overFlow + +@@empty: + INC ESI + JMP @@error + +@@negate: + NEG EAX + JLE @@successExit + JS @@successExit { to handle 2**31 correctly, where the negate overflows } + +@@error: +@@overFlow: + POP EBX + SUB ESI,EBX + JMP @@exit + +@@minus: + INC CH +@@plus: + MOV BL,[ESI] + INC ESI + JMP @@firstDigit + +@@dollar: + MOV EDI,0FFFFFFFH + + MOV BL,[ESI] + INC ESI + TEST BL,BL + JZ @@empty + +@@hDigLoop: + CMP BL,'a' + JB @@upper + SUB BL,'a' - 'A' +@@upper: + SUB BL,'0' + CMP BL,9 + JBE @@digOk + SUB BL,'A' - '0' + CMP BL,5 + JA @@error + ADD BL,10 +@@digOk: + CMP EAX,EDI + JA @@overFlow + SHL EAX,4 + ADD EAX,EBX + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JNE @@hDigLoop + +@@successExit: + POP ECX { saved copy of string pointer } + XOR ESI,ESI { signal no error to caller } + +@@exit: + MOV [EDX],ESI + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +function _WriteRec(var f: TFileRec; buffer: Pointer): Pointer; +{$IFDEF LINUX} +var + Dummy: Integer; +begin + _BlockWrite(f, Buffer, 1, Dummy); + Result := @F; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm +// -> EAX Pointer to file variable +// EDX Pointer to buffer +// <- EAX Pointer to file variable + PUSH EBX + + MOV EBX,EAX + + MOVZX EAX,[EAX].TFileRec.Mode + SUB EAX,fmOutput + CMP EAX,fmInOut-fmOutput // File must be fmInOut or fmOutput + JA @@fileNotOpen + +// WriteFile(f.Handle, buffer, f.RecSize, @result, Nil); + + PUSH 0 // space for OS result + MOV EAX,ESP + + PUSH 0 // pass lpOverlapped + PUSH EAX // pass @result + PUSH [EBX].TFileRec.RecSize // pass nNumberOfBytesToRead + PUSH EDX // pass lpBuffer + PUSH [EBX].TFileRec.Handle // pass hFile + CALL WriteFile + POP EDX // pop result + DEC EAX // check EAX = TRUE + JNZ @@error + + CMP EDX,[EBX].TFileRec.RecSize // result = f.RecSize ? + JE @@exit + +@@writeError: + MOV EAX,101 + JMP @@errExit + +@@fileNotOpen: + MOV EAX,5 + JMP @@errExit + +@@error: + CALL GetLastError +@@errExit: + CALL SetInOutRes +@@exit: + MOV EAX,EBX + POP EBX +end; +{$ENDIF} + +// If the file is Output or ErrOutput std variable, try to open it +// Otherwise, runtime error. +function TryOpenForOutput(var t: TTextRec): Boolean; +begin + if (@t = @Output) or (@t = @ErrOutput) then + begin + t.Flags := tfCRLF * Byte(DefaultTextLineBreakStyle); + _RewritText(t); + end; + + Result := t.Mode = fmOutput; + if not Result then + SetInOutRes(105); +end; + +function _WriteBytes(var t: TTextRec; const b; cnt : Longint): Pointer; +{$IFDEF PUREPASCAL} +var + P: PChar; + RemainingBytes: Longint; + Temp: Integer; +begin + Result := @t; + if t.Mode <> fmOutput and not TryOpenForOutput(t) then Exit; + + P := t.BufPtr + t.BufPos; + RemainingBytes := t.BufSize - t.BufPos; + while RemainingBytes <= cnt do + begin + Inc(t.BufPos, RemainingBytes); + Dec(cnt, RemainingBytes); + Move(B, P^, RemainingBytes); + Temp := TTextIOFunc(t.InOutFunc)(t); + if Temp <> 0 then + begin + SetInOutRes(Temp); + Exit; + end; + P := t.BufPtr + t.BufPos; + RemainingBytes := t.BufSize - t.BufPos; + end; + Inc(t.BufPos, cnt); + Move(B, P^, cnt); +end; +{$ELSE} +asm +// -> EAX Pointer to file record +// EDX Pointer to buffer +// ECX Number of bytes to write +// <- EAX Pointer to file record + + PUSH ESI + PUSH EDI + + MOV ESI,EDX + + CMP [EAX].TTextRec.Mode,fmOutput + JE @@loop + PUSH EAX + PUSH EDX + PUSH ECX + CALL TryOpenForOutput + TEST AL,AL + POP ECX + POP EDX + POP EAX + JE @@exit + +@@loop: + MOV EDI,[EAX].TTextRec.BufPtr + ADD EDI,[EAX].TTextRec.BufPos + +// remainingBytes = t.bufSize - t.bufPos + + MOV EDX,[EAX].TTextRec.BufSize + SUB EDX,[EAX].TTextRec.BufPos + +// if (remainingBytes <= cnt) + + CMP EDX,ECX + JG @@1 + +// t.BufPos += remainingBytes, cnt -= remainingBytes + + ADD [EAX].TTextRec.BufPos,EDX + SUB ECX,EDX + +// copy remainingBytes, advancing ESI + + PUSH EAX + PUSH ECX + MOV ECX,EDX + REP MOVSB + + CALL [EAX].TTextRec.InOutFunc + TEST EAX,EAX + JNZ @@error + + POP ECX + POP EAX + JMP @@loop + +@@error: + CALL SetInOutRes + POP ECX + POP EAX + JMP @@exit +@@1: + ADD [EAX].TTextRec.BufPos,ECX + REP MOVSB + +@@exit: + POP EDI + POP ESI +end; +{$ENDIF} + +function _WriteSpaces(var t: TTextRec; cnt: Longint): Pointer; +{$IFDEF PUREPASCAL} +const + s64Spaces = ' '; +begin + Result := @t; + while cnt > 64 do + begin + _WriteBytes(t, s64Spaces, 64); + if InOutRes <> 0 then Exit; + Dec(cnt, 64); + end; + if cnt > 0 then + _WriteBytes(t, s64Spaces, cnt); +end; +{$ELSE} +const + spCnt = 64; +asm +// -> EAX Pointer to text record +// EDX Number of spaces (<= 0: None) + + MOV ECX,EDX +@@loop: +{$IFDEF PIC} + LEA EDX, [EBX] + offset @@spBuf +{$ELSE} + MOV EDX,offset @@spBuf +{$ENDIF} + + CMP ECX,spCnt + JLE @@1 + + SUB ECX,spCnt + PUSH EAX + PUSH ECX + MOV ECX,spCnt + CALL _WriteBytes + CALL SysInit.@GetTLS + CMP [EAX].InOutRes,0 + JNE @@error + POP ECX + POP EAX + JMP @@loop + +@@error: + POP ECX + POP EAX + JMP @@exit + +@@spBuf: // 64 spaces + DB ' '; +@@1: + TEST ECX,ECX + JG _WriteBytes +@@exit: +end; +{$ENDIF} + +function _Write0Char(var t: TTextRec; c: Char): Pointer; +{$IFDEF PUREPASCAL} +var + Temp: Integer; +begin + Result := @t; + if not TryOpenForOutput(t) then Exit; + + if t.BufPos >= t.BufSize then + begin + Temp := TTextIOFunc(t.InOutFunc)(t); + if Temp <> 0 then + begin + SetInOutRes(Temp); + Exit; + end; + end; + + t.BufPtr[t.BufPos] := c; + Inc(t.BufPos); +end; +{$ELSE} +asm +// -> EAX Pointer to text record +// DL Character + + CMP [EAX].TTextRec.Mode,fmOutput + JE @@loop + PUSH EAX + PUSH EDX + CALL TryOpenForOutput + TEST AL,AL + POP EDX + POP EAX + JNE @@loop + JMP @@exit + +@@flush: + PUSH EAX + PUSH EDX + CALL [EAX].TTextRec.InOutFunc + TEST EAX,EAX + JNZ @@error + POP EDX + POP EAX + JMP @@loop + +@@error: + CALL SetInOutRes + POP EDX + POP EAX + JMP @@exit + +@@loop: + MOV ECX,[EAX].TTextRec.BufPos + CMP ECX,[EAX].TTextRec.BufSize + JGE @@flush + + ADD ECX,[EAX].TTextRec.BufPtr + MOV [ECX],DL + + INC [EAX].TTextRec.BufPos +@@exit: +end; +{$ENDIF} + +function _WriteChar(var t: TTextRec; c: Char; width: Integer): Pointer; +begin + _WriteSpaces(t, width-1); + Result := _WriteBytes(t, c, 1); +end; + +function _WriteBool(var t: TTextRec; val: Boolean; width: Longint): Pointer; +const + BoolStrs: array [Boolean] of ShortString = ('FALSE', 'TRUE'); +begin + Result := _WriteString(t, BoolStrs[val], width); +end; + +function _Write0Bool(var t: TTextRec; val: Boolean): Pointer; +begin + Result := _WriteBool(t, val, 0); +end; + +function _WriteLong(var t: TTextRec; val, width: Longint): Pointer; +var + S: string[31]; +begin + Str(val:0, S); + Result := _WriteString(t, S, width); +end; + +function _Write0Long(var t: TTextRec; val: Longint): Pointer; +begin + Result := _WriteLong(t, val, 0); +end; + +function _Write0String(var t: TTextRec; const s: ShortString): Pointer; +begin + Result := _WriteBytes(t, S[1], Byte(S[0])); +end; + +function _WriteString(var t: TTextRec; const s: ShortString; width: Longint): Pointer; +begin + _WriteSpaces(t, Width - Byte(S[0])); + Result := _WriteBytes(t, S[1], Byte(S[0])); +end; + +function _Write0CString(var t: TTextRec; s: PChar): Pointer; +begin + Result := _WriteCString(t, s, 0); +end; + +function _WriteCString(var t: TTextRec; s: PChar; width: Longint): Pointer; +var + len: Longint; +begin + len := _strlen(s); + _WriteSpaces(t, width - len); + Result := _WriteBytes(t, s^, len); +end; + +procedure _Write2Ext; +asm +{ PROCEDURE _Write2Ext( VAR t: Text; val: Extended; width, prec: Longint); + ->EAX Pointer to file record + [ESP+4] Extended value + EDX Field width + ECX precision (<0: scientific, >= 0: fixed point) } + + FLD tbyte ptr [ESP+4] { load value } + SUB ESP,256 { VAR s: String; } + + PUSH EAX + PUSH EDX + +{ Str( val, width, prec, s ); } + + SUB ESP,12 + FSTP tbyte ptr [ESP] { pass value } + MOV EAX,EDX { pass field width } + MOV EDX,ECX { pass precision } + LEA ECX,[ESP+8+12] { pass destination string } + CALL _Str2Ext + +{ Write( t, s, width ); } + + POP ECX { pass width } + POP EAX { pass text } + MOV EDX,ESP { pass string } + CALL _WriteString + + ADD ESP,256 + RET 12 +end; + +procedure _Write1Ext; +asm +{ PROCEDURE _Write1Ext( VAR t: Text; val: Extended; width: Longint); + -> EAX Pointer to file record + [ESP+4] Extended value + EDX Field width } + + OR ECX,-1 + JMP _Write2Ext +end; + +procedure _Write0Ext; +asm +{ PROCEDURE _Write0Ext( VAR t: Text; val: Extended); + ->EAX Pointer to file record + [ESP+4] Extended value } + + MOV EDX,23 { field width } + OR ECX,-1 + JMP _Write2Ext +end; + +function _WriteLn(var t: TTextRec): Pointer; +var + Buf: array [0..1] of Char; +begin + if (t.flags and tfCRLF) <> 0 then + begin + Buf[0] := #13; + Buf[1] := #10; + Result := _WriteBytes(t, Buf, 2); + end + else + begin + Buf[0] := #10; + Result := _WriteBytes(t, Buf, 1); + end; + _Flush(t); +end; + +procedure __CToPasStr(Dest: PShortString; const Source: PChar); +begin + __CLenToPasStr(Dest, Source, 255); +end; + +procedure __CLenToPasStr(Dest: PShortString; const Source: PChar; MaxLen: Integer); +{$IFDEF PUREPASCAL} +var + I: Integer; +begin + I := 0; + if MaxLen > 255 then MaxLen := 255; + while (Source[I] <> #0) and (I <= MaxLen) do + begin + Dest^[I+1] := Source[I]; + Inc(I); + end; + if I > 0 then Dec(I); + Byte(Dest^[0]) := I; +end; +{$ELSE} +asm +{ ->EAX Pointer to destination } +{ EDX Pointer to source } +{ ECX cnt } + + PUSH EBX + PUSH EAX { save destination } + + CMP ECX,255 + JBE @@loop + MOV ECX,255 +@@loop: + MOV BL,[EDX] { ch = *src++; } + INC EDX + TEST BL,BL { if (ch == 0) break } + JE @@endLoop + INC EAX { *++dest = ch; } + MOV [EAX],BL + DEC ECX { while (--cnt != 0) } + JNZ @@loop + +@@endLoop: + POP EDX + SUB EAX,EDX + MOV [EDX],AL + POP EBX +end; +{$ENDIF} + +procedure __ArrayToPasStr(Dest: PShortString; const Source: PChar; Len: Integer); +begin + if Len > 255 then Len := 255; + Byte(Dest^[0]) := Len; + Move(Source^, Dest^[1], Len); +end; + +procedure __PasToCStr(const Source: PShortString; const Dest: PChar); +begin + Move(Source^[1], Dest^, Byte(Source^[0])); + Dest[Byte(Source^[0])] := #0; +end; + +procedure _SetElem; +asm + { PROCEDURE _SetElem( VAR d: SET; elem, size: Byte); } + { EAX = dest address } + { DL = element number } + { CL = size of set } + + PUSH EBX + PUSH EDI + + MOV EDI,EAX + + XOR EBX,EBX { zero extend set size into ebx } + MOV BL,CL + MOV ECX,EBX { and use it for the fill } + + XOR EAX,EAX { for zero fill } + REP STOSB + + SUB EDI,EBX { point edi at beginning of set again } + + INC EAX { eax is still zero - make it 1 } + MOV CL,DL + ROL AL,CL { generate a mask } + SHR ECX,3 { generate the index } + CMP ECX,EBX { if index >= siz then exit } + JAE @@exit + OR [EDI+ECX],AL{ set bit } + +@@exit: + POP EDI + POP EBX +end; + +procedure _SetRange; +asm +{ PROCEDURE _SetRange( lo, hi, size: Byte; VAR d: SET ); } +{ ->AL low limit of range } +{ DL high limit of range } +{ ECX Pointer to set } +{ AH size of set } + + PUSH EBX + PUSH ESI + PUSH EDI + + XOR EBX,EBX { EBX = set size } + MOV BL,AH + MOVZX ESI,AL { ESI = low zero extended } + MOVZX EDX,DL { EDX = high zero extended } + MOV EDI,ECX + +{ clear the set } + + MOV ECX,EBX + XOR EAX,EAX + REP STOSB + +{ prepare for setting the bits } + + SUB EDI,EBX { point EDI at start of set } + SHL EBX,3 { EBX = highest bit in set + 1 } + CMP EDX,EBX + JB @@inrange + LEA EDX,[EBX-1] { ECX = highest bit in set } + +@@inrange: + CMP ESI,EDX { if lo > hi then exit; } + JA @@exit + + DEC EAX { loMask = 0xff << (lo & 7) } + MOV ECX,ESI + AND CL,07H + SHL AL,CL + + SHR ESI,3 { loIndex = lo >> 3; } + + MOV CL,DL { hiMask = 0xff >> (7 - (hi & 7)); } + NOT CL + AND CL,07 + SHR AH,CL + + SHR EDX,3 { hiIndex = hi >> 3; } + + ADD EDI,ESI { point EDI to set[loIndex] } + MOV ECX,EDX + SUB ECX,ESI { if ((inxDiff = (hiIndex - loIndex)) == 0) } + JNE @@else + + AND AL,AH { set[loIndex] = hiMask & loMask; } + MOV [EDI],AL + JMP @@exit + +@@else: + STOSB { set[loIndex++] = loMask; } + DEC ECX + MOV AL,0FFH { while (loIndex < hiIndex) } + REP STOSB { set[loIndex++] = 0xff; } + MOV [EDI],AH { set[hiIndex] = hiMask; } + +@@exit: + POP EDI + POP ESI + POP EBX +end; + +procedure _SetEq; +asm +{ FUNCTION _SetEq( CONST l, r: Set; size: Byte): ConditionCode; } +{ EAX = left operand } +{ EDX = right operand } +{ CL = size of set } + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + AND ECX,0FFH + REP CMPSB + + POP EDI + POP ESI +end; + +procedure _SetLe; +asm +{ FUNCTION _SetLe( CONST l, r: Set; size: Byte): ConditionCode; } +{ EAX = left operand } +{ EDX = right operand } +{ CL = size of set (>0 && <= 32) } + +@@loop: + MOV CH,[EDX] + NOT CH + AND CH,[EAX] + JNE @@exit + INC EDX + INC EAX + DEC CL + JNZ @@loop +@@exit: +end; + +procedure _SetIntersect; +asm +{ PROCEDURE _SetIntersect( VAR dest: Set; CONST src: Set; size: Byte);} +{ EAX = destination operand } +{ EDX = source operand } +{ CL = size of set (0 < size <= 32) } + +@@loop: + MOV CH,[EDX] + INC EDX + AND [EAX],CH + INC EAX + DEC CL + JNZ @@loop +end; + +procedure _SetIntersect3; +asm +{ PROCEDURE _SetIntersect3( VAR dest: Set; CONST src: Set; size: Longint; src2: Set);} +{ EAX = destination operand } +{ EDX = source operand } +{ ECX = size of set (0 < size <= 32) } +{ [ESP+4] = 2nd source operand } + + PUSH EBX + PUSH ESI + MOV ESI,[ESP+8+4] +@@loop: + MOV BL,[EDX+ECX-1] + AND BL,[ESI+ECX-1] + MOV [EAX+ECX-1],BL + DEC ECX + JNZ @@loop + + POP ESI + POP EBX +end; + +procedure _SetUnion; +asm +{ PROCEDURE _SetUnion( VAR dest: Set; CONST src: Set; size: Byte); } +{ EAX = destination operand } +{ EDX = source operand } +{ CL = size of set (0 < size <= 32) } + +@@loop: + MOV CH,[EDX] + INC EDX + OR [EAX],CH + INC EAX + DEC CL + JNZ @@loop +end; + +procedure _SetUnion3; +asm +{ PROCEDURE _SetUnion3( VAR dest: Set; CONST src: Set; size: Longint; src2: Set);} +{ EAX = destination operand } +{ EDX = source operand } +{ ECX = size of set (0 < size <= 32) } +{ [ESP+4] = 2nd source operand } + + PUSH EBX + PUSH ESI + MOV ESI,[ESP+8+4] +@@loop: + MOV BL,[EDX+ECX-1] + OR BL,[ESI+ECX-1] + MOV [EAX+ECX-1],BL + DEC ECX + JNZ @@loop + + POP ESI + POP EBX +end; + +procedure _SetSub; +asm +{ PROCEDURE _SetSub( VAR dest: Set; CONST src: Set; size: Byte); } +{ EAX = destination operand } +{ EDX = source operand } +{ CL = size of set (0 < size <= 32) } + +@@loop: + MOV CH,[EDX] + NOT CH + INC EDX + AND [EAX],CH + INC EAX + DEC CL + JNZ @@loop +end; + +procedure _SetSub3; +asm +{ PROCEDURE _SetSub3( VAR dest: Set; CONST src: Set; size: Longint; src2: Set);} +{ EAX = destination operand } +{ EDX = source operand } +{ ECX = size of set (0 < size <= 32) } +{ [ESP+4] = 2nd source operand } + + PUSH EBX + PUSH ESI + MOV ESI,[ESP+8+4] +@@loop: + MOV BL,[ESI+ECX-1] + NOT BL + AND BL,[EDX+ECX-1] + MOV [EAX+ECX-1],BL + DEC ECX + JNZ @@loop + + POP ESI + POP EBX +end; + +procedure _SetExpand; +asm +{ PROCEDURE _SetExpand( CONST src: Set; VAR dest: Set; lo, hi: Byte); } +{ ->EAX Pointer to source (packed set) } +{ EDX Pointer to destination (expanded set) } +{ CH high byte of source } +{ CL low byte of source } + +{ algorithm: } +{ clear low bytes } +{ copy high-low+1 bytes } +{ clear 31-high bytes } + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + MOV EDX,ECX { save low, high in dl, dh } + XOR ECX,ECX + XOR EAX,EAX + + MOV CL,DL { clear low bytes } + REP STOSB + + MOV CL,DH { copy high - low bytes } + SUB CL,DL + REP MOVSB + + MOV CL,32 { copy 32 - high bytes } + SUB CL,DH + REP STOSB + + POP EDI + POP ESI +end; + +procedure _EmitDigits; +const + tenE17: Double = 1e17; + tenE18: Double = 1e18; +asm +// -> FST(0) Value, 0 <= value < 10.0 +// EAX Count of digits to generate +// EDX Pointer to digit buffer + + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX +{$ELSE} + XOR EBX,EBX +{$ENDIF} + PUSH EDI + MOV EDI,EDX + MOV ECX,EAX + + SUB ESP,10 // VAR bcdBuf: array [0..9] of Byte + MOV byte ptr [EDI],'0' // digBuf[0] := '0'// + FMUL qword ptr [EBX] + offset tenE17 // val := Round(val*1e17); + FRNDINT + + FCOM qword ptr [EBX] + offset tenE18 // if val >= 1e18 then + FSTSW AX + SAHF + JB @@1 + + FSUB qword ptr [EBX] + offset tenE18 // val := val - 1e18; + MOV byte ptr [EDI],'1' // digBuf[0] := '1'; +@@1: + FBSTP tbyte ptr [ESP] // store packed bcd digits in bcdBuf + + MOV EDX,8 + INC EDI + +@@2: + WAIT + MOV AL,[ESP+EDX] // unpack 18 bcd digits in 9 bytes + MOV AH,AL // into 9 words = 18 bytes + SHR AL,4 + AND AH,0FH + ADD AX,'00' + STOSW + DEC EDX + JNS @@2 + + SUB ECX,18 // we need at least digCnt digits + JL @@3 // we have generated 18 + + MOV AL,'0' // if this is not enough, append zeroes + REP STOSB + JMP @@4 // in this case, we don't need to round + +@@3: + ADD EDI,ECX // point EDI to the round digit + CMP byte ptr [EDI],'5' + JL @@4 +@@5: + DEC EDI + INC byte ptr [EDI] + CMP byte ptr [EDI],'9' + JLE @@4 + MOV byte ptr [EDI],'0' + JMP @@5 + +@@4: + ADD ESP,10 + POP EDI + POP EBX +end; + +procedure _ScaleExt; +asm +// -> FST(0) Value +// <- EAX exponent (base 10) +// FST(0) Value / 10**eax +// PIC safe - uses EBX, but only call is to _POW10, which fixes up EBX itself + + PUSH EBX + SUB ESP,12 + + XOR EBX,EBX + +@@normLoop: // loop necessary for denormals + + FLD ST(0) + FSTP tbyte ptr [ESP] + MOV AX,[ESP+8] + TEST AX,AX + JE @@testZero +@@cont: + SUB AX,3FFFH + MOV DX,4D10H // log10(2) * 2**16 + IMUL DX + MOVSX EAX,DX // exp10 = exp2 * log10(2) + NEG EAX + JE @@exit + SUB EBX,EAX + CALL _Pow10 + JMP @@normLoop + +@@testZero: + CMP dword ptr [ESP+4],0 + JNE @@cont + CMP dword ptr [ESP+0],0 + JNE @@cont + +@@exit: + ADD ESP,12 + MOV EAX,EBX + POP EBX +end; + +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 ); +const + MAXDIGS = 256; +asm +// -> [ESP+4] Extended value +// EAX Width +// EDX Precision +// ECX Pointer to string + + FLD tbyte ptr [ESP+4] + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV ESI,EDX + PUSH ECX // save string pointer + SUB ESP,MAXDIGS // VAR digBuf: array [0..MAXDIGS-1] of Char + +// limit width to 255 + + CMP EBX,255 // if width > 255 then width := 255; + JLE @@1 + MOV EBX,255 +@@1: + +// save sign bit in bit 0 of EDI, take absolute value of val, check for +// Nan and infinity. + + FLD ST(0) + FSTP tbyte ptr [ESP] + XOR EAX,EAX + MOV AX,word ptr [ESP+8] + MOV EDI,EAX + SHR EDI,15 + AND AX,7FFFH + CMP AX,7FFFH + JE @@nanInf + FABS + +// if precision < 0 then do scientific else do fixed; + + TEST ESI,ESI + JGE @@fixed + +// the following call finds a decimal exponent and a reduced +// mantissa such that val = mant * 10**exp + + CALL _ScaleExt // val is FST(0), exp is EAX + +// for scientific notation, we have width - 8 significant digits +// however, we can not have less than 2 or more than 18 digits. + +@@scientific: + + MOV ESI,EBX // digCnt := width - 8; + SUB ESI,8 + CMP ESI,2 // if digCnt < 2 then digCnt := 2 + JGE @@2 + MOV ESI,2 + JMP @@3 +@@2: + CMP ESI,18 // else if digCnt > 18 then digCnt := 18; + JLE @@3 + MOV ESI,18 +@@3: + +// _EmitDigits( val, digCnt, digBuf ) + + MOV EDX,ESP // pass digBuf + PUSH EAX // save exponent + MOV EAX,ESI // pass digCnt + CALL _EmitDigits // convert val to ASCII + + MOV EDX,EDI // save sign in EDX + MOV EDI,[ESP+MAXDIGS+4] // load result string pointer + + MOV [EDI],BL // length of result string := width + INC EDI + + MOV AL,' ' // prepare for leading blanks and sign + + MOV ECX,EBX // blankCnt := width - digCnt - 8 + SUB ECX,ESI + SUB ECX,8 + JLE @@4 + + REP STOSB // emit blankCnt blanks +@@4: + SUB [EDI-1],CL // if blankCnt < 0, adjust length + + TEST DL,DL // emit the sign (' ' or '-') + JE @@5 + MOV AL,'-' +@@5: + STOSB + + POP EAX + MOV ECX,ESI // emit digCnt digits + MOV ESI,ESP // point ESI to digBuf + + CMP byte ptr [ESI],'0' + JE @@5a // if rounding overflowed, adjust exponent and ESI + INC EAX + DEC ESI +@@5a: + INC ESI + + MOVSB // emit one digit + MOV byte ptr [EDI],'.' // emit dot + INC EDI // adjust dest pointer + DEC ECX // adjust count + + REP MOVSB + + MOV byte ptr [EDI],'E' + + MOV CL,'+' // emit sign of exponent ('+' or '-') + TEST EAX,EAX + JGE @@6 + MOV CL,'-' + NEG EAX +@@6: + MOV [EDI+1],CL + + XOR EDX,EDX // emit exponent + MOV CX,10 + DIV CX + ADD DL,'0' + MOV [EDI+5],DL + + XOR EDX,EDX + DIV CX + ADD DL,'0' + MOV [EDI+4],DL + + XOR EDX,EDX + DIV CX + ADD DL,'0' + MOV [EDI+3],DL + + ADD AL,'0' + MOV [EDI+2],AL + + JMP @@exit + +@@fixed: + +// FST(0) = value >= 0.0 +// EBX = width +// ESI = precision +// EDI = sign + + CMP ESI,MAXDIGS-40 // else if precision > MAXDIGS-40 then precision := MAXDIGS-40; + JLE @@6a + MOV ESI,MAXDIGS-40 +@@6a: +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + FCOM qword ptr [EAX] + offset Ten + POP EAX +{$ELSE} + FCOM qword ptr ten +{$ENDIF} + FSTSW AX + SAHF + MOV EAX,0 + JB @@7 + + CALL _ScaleExt // val is FST(0), exp is EAX + + CMP EAX,35 // if val is too large, use scientific + JG @@scientific + +@@7: +// FST(0) = scaled value, 0.0 <= value < 10.0 +// EAX = exponent, 0 <= exponent + +// intDigCnt := exponent + 1; + + INC EAX + +// _EmitDigits( value, intDigCnt + precision, digBuf ); + + MOV EDX,ESP + PUSH EAX + ADD EAX,ESI + CALL _EmitDigits + POP EAX + +// Now we need to check whether rounding to the right number of +// digits overflowed, and if so, adjust things accordingly + + MOV EDX,ESI // put precision in EDX + MOV ESI,ESP // point EDI to digBuf + CMP byte ptr [ESI],'0' + JE @@8 + INC EAX + DEC ESI +@@8: + INC ESI + + MOV ECX,EAX // numWidth := sign + intDigCnt; + ADD ECX,EDI + + TEST EDX,EDX // if precision > 0 then + JE @@9 + INC ECX // numWidth := numWidth + 1 + precision + ADD ECX,EDX + + CMP EBX,ECX // if width <= numWidth + JG @@9 + MOV EBX,ECX // width := numWidth +@@9: + PUSH EAX + PUSH EDI + + MOV EDI,[ESP+MAXDIGS+2*4] // point EDI to dest string + + MOV [EDI],BL // store final length in dest string + INC EDI + + SUB EBX,ECX // width := width - numWidth + MOV ECX,EBX + JLE @@10 + + MOV AL,' ' // emit width blanks + REP STOSB +@@10: + SUB [EDI-1],CL // if blankCnt < 0, adjust length + POP EAX + POP ECX + + TEST EAX,EAX + JE @@11 + + MOV byte ptr [EDI],'-' + INC EDI + +@@11: + REP MOVSB // copy intDigCnt digits + + TEST EDX,EDX // if precision > 0 then + JE @@12 + + MOV byte ptr [EDI],'.' // emit '.' + INC EDI + MOV ECX,EDX // emit precision digits + REP MOVSB + +@@12: + +@@exit: + ADD ESP,MAXDIGS + POP ECX + POP EDI + POP ESI + POP EBX + RET 12 + +@@nanInf: +// here: EBX = width, ECX = string pointer, EDI = sign, [ESP] = value + +{$IFDEF PIC} + CALL GetGOT +{$ELSE} + XOR EAX,EAX +{$ENDIF} + FSTP ST(0) + CMP dword ptr [ESP+4],80000000H + LEA ESI,[EAX] + offset nanStr + JNE @@13 + DEC EDI + LEA ESI,[EAX] + offset plusInfStr + JNZ @@13 + LEA ESI,[EAX] + offset minInfStr +@@13: + MOV EDI,ECX + MOV ECX,EBX + MOV [EDI],CL + INC EDI + SUB CL,[ESI] + JBE @@14 + MOV AL,' ' + REP STOSB +@@14: + SUB [EDI-1],CL + MOV CL,[ESI] + INC ESI + REP MOVSB + + JMP @@exit +end; + +procedure _Str0Ext; +asm +// -> [ESP+4] Extended value +// EAX Pointer to string + + MOV ECX,EAX // pass string + MOV EAX,23 // pass default field width + OR EDX,-1 // pass precision -1 + JMP _Str2Ext +end; + +procedure _Str1Ext;//( val: Extended; width: Longint; var s: String ); +asm +// -> [ESP+4] Extended value +// EAX Field width +// EDX Pointer to string + + MOV ECX,EDX + OR EDX,-1 // pass precision -1 + JMP _Str2Ext +end; + +//function _ValExt( s: AnsiString; VAR code: Integer ) : Extended; +procedure _ValExt; +asm +// -> EAX Pointer to string +// EDX Pointer to code result +// <- FST(0) Result + + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX +{$ELSE} + XOR EBX,EBX +{$ENDIF} + PUSH ESI + PUSH EDI + + PUSH EBX // SaveGOT = ESP+8 + MOV ESI,EAX + PUSH EAX // save for the error case + + FLDZ + XOR EAX,EAX + XOR EBX,EBX + XOR EDI,EDI + + PUSH EBX // temp to get digs to fpu + + TEST ESI,ESI + JE @@empty + +@@blankLoop: + MOV BL,[ESI] + INC ESI + CMP BL,' ' + JE @@blankLoop + +@@endBlanks: + MOV CH,0 + CMP BL,'-' + JE @@minus + CMP BL,'+' + JE @@plus + JMP @@firstDigit + +@@minus: + INC CH +@@plus: + MOV BL,[ESI] + INC ESI + +@@firstDigit: + TEST BL,BL + JE @@error + + MOV EDI,[ESP+8] // SaveGOT + +@@digLoop: + SUB BL,'0' + CMP BL,9 + JA @@dotExp + FMUL qword ptr [EDI] + offset Ten + MOV dword ptr [ESP],EBX + FIADD dword ptr [ESP] + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JNE @@digLoop + JMP @@prefinish + +@@dotExp: + CMP BL,'.' - '0' + JNE @@exp + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JE @@prefinish + +// EDI = SaveGot +@@fracDigLoop: + SUB BL,'0' + CMP BL,9 + JA @@exp + FMUL qword ptr [EDI] + offset Ten + MOV dword ptr [ESP],EBX + FIADD dword ptr [ESP] + DEC EAX + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JNE @@fracDigLoop + +@@prefinish: + XOR EDI,EDI + JMP @@finish + +@@exp: + CMP BL,'E' - '0' + JE @@foundExp + CMP BL,'e' - '0' + JNE @@error +@@foundExp: + MOV BL,[ESI] + INC ESI + MOV AH,0 + CMP BL,'-' + JE @@minusExp + CMP BL,'+' + JE @@plusExp + JMP @@firstExpDigit +@@minusExp: + INC AH +@@plusExp: + MOV BL,[ESI] + INC ESI +@@firstExpDigit: + SUB BL,'0' + CMP BL,9 + JA @@error + MOV EDI,EBX + MOV BL,[ESI] + INC ESI + TEST BL,BL + JZ @@endExp +@@expDigLoop: + SUB BL,'0' + CMP BL,9 + JA @@error + LEA EDI,[EDI+EDI*4] + ADD EDI,EDI + ADD EDI,EBX + MOV BL,[ESI] + INC ESI + TEST BL,BL + JNZ @@expDigLoop +@@endExp: + DEC AH + JNZ @@expPositive + NEG EDI +@@expPositive: + MOVSX EAX,AL + +@@finish: + ADD EAX,EDI + PUSH EDX + PUSH ECX + CALL _Pow10 + POP ECX + POP EDX + + DEC CH + JE @@negate + +@@successExit: + + ADD ESP,12 // pop temp and saved copy of string pointer + + XOR ESI,ESI // signal no error to caller + +@@exit: + MOV [EDX],ESI + + POP EDI + POP ESI + POP EBX + RET + +@@negate: + FCHS + JMP @@successExit + +@@empty: + INC ESI + +@@error: + POP EAX + POP EBX + SUB ESI,EBX + ADD ESP,4 + JMP @@exit +end; + +procedure FPower10; +asm + JMP _Pow10 +end; + +//function _Pow10(val: Extended; Power: Integer): Extended; +procedure _Pow10; +asm +// -> FST(0) val +// -> EAX Power +// <- FST(0) val * 10**Power + +// This routine generates 10**power with no more than two +// floating point multiplications. Up to 10**31, no multiplications +// are needed. + + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX +{$ELSE} + XOR EBX,EBX +{$ENDIF} + TEST EAX,EAX + JL @@neg + JE @@exit + CMP EAX,5120 + JGE @@inf + MOV EDX,EAX + AND EDX,01FH + LEA EDX,[EDX+EDX*4] + FLD tbyte ptr @@tab0[EBX+EDX*2] + + FMULP + + SHR EAX,5 + JE @@exit + + MOV EDX,EAX + AND EDX,0FH + JE @@skip2ndMul + LEA EDX,[EDX+EDX*4] + FLD tbyte ptr @@tab1-10[EBX+EDX*2] + FMULP + +@@skip2ndMul: + + SHR EAX,4 + JE @@exit + LEA EAX,[EAX+EAX*4] + FLD tbyte ptr @@tab2-10[EBX+EAX*2] + FMULP + JMP @@exit + +@@neg: + NEG EAX + CMP EAX,5120 + JGE @@zero + MOV EDX,EAX + AND EDX,01FH + LEA EDX,[EDX+EDX*4] + FLD tbyte ptr @@tab0[EBX+EDX*2] + FDIVP + + SHR EAX,5 + JE @@exit + + MOV EDX,EAX + AND EDX,0FH + JE @@skip2ndDiv + LEA EDX,[EDX+EDX*4] + FLD tbyte ptr @@tab1-10[EBX+EDX*2] + FDIVP + +@@skip2ndDiv: + + SHR EAX,4 + JE @@exit + LEA EAX,[EAX+EAX*4] + FLD tbyte ptr @@tab2-10[EBX+EAX*2] + FDIVP + + JMP @@exit + +@@inf: + FLD tbyte ptr @@infval[EBX] + JMP @@exit + +@@zero: + FLDZ + +@@exit: + POP EBX + RET + +@@infval: DW $0000,$0000,$0000,$8000,$7FFF +@@tab0: DW $0000,$0000,$0000,$8000,$3FFF // 10**0 + DW $0000,$0000,$0000,$A000,$4002 // 10**1 + DW $0000,$0000,$0000,$C800,$4005 // 10**2 + DW $0000,$0000,$0000,$FA00,$4008 // 10**3 + DW $0000,$0000,$0000,$9C40,$400C // 10**4 + DW $0000,$0000,$0000,$C350,$400F // 10**5 + DW $0000,$0000,$0000,$F424,$4012 // 10**6 + DW $0000,$0000,$8000,$9896,$4016 // 10**7 + DW $0000,$0000,$2000,$BEBC,$4019 // 10**8 + DW $0000,$0000,$2800,$EE6B,$401C // 10**9 + DW $0000,$0000,$F900,$9502,$4020 // 10**10 + DW $0000,$0000,$B740,$BA43,$4023 // 10**11 + DW $0000,$0000,$A510,$E8D4,$4026 // 10**12 + DW $0000,$0000,$E72A,$9184,$402A // 10**13 + DW $0000,$8000,$20F4,$B5E6,$402D // 10**14 + DW $0000,$A000,$A931,$E35F,$4030 // 10**15 + DW $0000,$0400,$C9BF,$8E1B,$4034 // 10**16 + DW $0000,$C500,$BC2E,$B1A2,$4037 // 10**17 + DW $0000,$7640,$6B3A,$DE0B,$403A // 10**18 + DW $0000,$89E8,$2304,$8AC7,$403E // 10**19 + DW $0000,$AC62,$EBC5,$AD78,$4041 // 10**20 + DW $8000,$177A,$26B7,$D8D7,$4044 // 10**21 + DW $9000,$6EAC,$7832,$8786,$4048 // 10**22 + DW $B400,$0A57,$163F,$A968,$404B // 10**23 + DW $A100,$CCED,$1BCE,$D3C2,$404E // 10**24 + DW $84A0,$4014,$5161,$8459,$4052 // 10**25 + DW $A5C8,$9019,$A5B9,$A56F,$4055 // 10**26 + DW $0F3A,$F420,$8F27,$CECB,$4058 // 10**27 + DW $0984,$F894,$3978,$813F,$405C // 10**28 + DW $0BE5,$36B9,$07D7,$A18F,$405F // 10**29 + DW $4EDF,$0467,$C9CD,$C9F2,$4062 // 10**30 + DW $2296,$4581,$7C40,$FC6F,$4065 // 10**31 + +@@tab1: DW $B59E,$2B70,$ADA8,$9DC5,$4069 // 10**32 + DW $A6D5,$FFCF,$1F49,$C278,$40D3 // 10**64 + DW $14A3,$C59B,$AB16,$EFB3,$413D // 10**96 + DW $8CE0,$80E9,$47C9,$93BA,$41A8 // 10**128 + DW $17AA,$7FE6,$A12B,$B616,$4212 // 10**160 + DW $556B,$3927,$F78D,$E070,$427C // 10**192 + DW $C930,$E33C,$96FF,$8A52,$42E7 // 10**224 + DW $DE8E,$9DF9,$EBFB,$AA7E,$4351 // 10**256 + DW $2F8C,$5C6A,$FC19,$D226,$43BB // 10**288 + DW $E376,$F2CC,$2F29,$8184,$4426 // 10**320 + DW $0AD2,$DB90,$2700,$9FA4,$4490 // 10**352 + DW $AA17,$AEF8,$E310,$C4C5,$44FA // 10**384 + DW $9C59,$E9B0,$9C07,$F28A,$4564 // 10**416 + DW $F3D4,$EBF7,$4AE1,$957A,$45CF // 10**448 + DW $A262,$0795,$D8DC,$B83E,$4639 // 10**480 + +@@tab2: DW $91C7,$A60E,$A0AE,$E319,$46A3 // 10**512 + DW $0C17,$8175,$7586,$C976,$4D48 // 10**1024 + DW $A7E4,$3993,$353B,$B2B8,$53ED // 10**1536 + DW $5DE5,$C53D,$3B5D,$9E8B,$5A92 // 10**2048 + DW $F0A6,$20A1,$54C0,$8CA5,$6137 // 10**2560 + DW $5A8B,$D88B,$5D25,$F989,$67DB // 10**3072 + DW $F3F8,$BF27,$C8A2,$DD5D,$6E80 // 10**3584 + DW $979B,$8A20,$5202,$C460,$7525 // 10**4096 + DW $59F0,$6ED5,$1162,$AE35,$7BCA // 10**4608 +end; + +const + RealBias = 129; + ExtBias = $3FFF; + +procedure _Real2Ext;//( val : Real ) : Extended; +asm +// -> EAX Pointer to value +// <- FST(0) Result + +// the REAL data type has the following format: +// 8 bit exponent (bias 129), 39 bit fraction, 1 bit sign + + MOV DH,[EAX+5] // isolate the sign bit + AND DH,80H + MOV DL,[EAX] // fetch exponent + TEST DL,DL // exponent zero means number is zero + JE @@zero + + ADD DX,ExtBias-RealBias // adjust exponent bias + + PUSH EDX // the exponent is at the highest address + + MOV EDX,[EAX+2] // load high fraction part, set hidden bit + OR EDX,80000000H + PUSH EDX // push high fraction part + + MOV DL,[EAX+1] // load remaining low byte of fraction + SHL EDX,24 // clear low 24 bits + PUSH EDX + + FLD tbyte ptr [ESP] // pop result onto chip + ADD ESP,12 + + RET + +@@zero: + FLDZ + RET +end; + +procedure _Ext2Real;//( val : Extended ) : Real; +asm +// -> FST(0) Value +// EAX Pointer to result + + PUSH EBX + + SUB ESP,12 + FSTP tbyte ptr [ESP] + + POP EBX // EBX is low half of fraction + POP EDX // EDX is high half of fraction + POP ECX // CX is exponent and sign + + SHR EBX,24 // set carry to last bit shifted out + ADC BL,0 // if bit was 1, round up + ADC EDX,0 + ADC CX,0 + JO @@overflow + + ADD EDX,EDX // shift fraction 1 bit left + ADD CX,CX // shift sign bit into carry + RCR EDX,1 // attach sign bit to fraction + SHR CX,1 // restore exponent, deleting sign + + SUB CX,ExtBias-RealBias // adjust exponent + JLE @@underflow + TEST CH,CH // CX must be in 1..255 + JG @@overflow + + MOV [EAX],CL + MOV [EAX+1],BL + MOV [EAX+2],EDX + + POP EBX + RET + +@@underflow: + XOR ECX,ECX + MOV [EAX],ECX + MOV [EAX+4],CX + POP EBX + RET + +@@overflow: + POP EBX + MOV AL,8 + JMP Error +end; + +const + ovtInstanceSize = -8; { Offset of instance size in OBJECTs } + ovtVmtPtrOffs = -4; + +procedure _ObjSetup; +asm +{ FUNCTION _ObjSetup( self: ^OBJECT; vmt: ^VMT): ^OBJECT; } +{ ->EAX Pointer to self (possibly nil) } +{ EDX Pointer to vmt (possibly nil) } +{ <-EAX Pointer to self } +{ EDX <> 0: an object was allocated } +{ Z-Flag Set: failure, Cleared: Success } + + CMP EDX,1 { is vmt = 0, indicating a call } + JAE @@skip1 { from a constructor? } + RET { return immediately with Z-flag cleared } + +@@skip1: + PUSH ECX + TEST EAX,EAX { is self already allocated? } + JNE @@noAlloc + MOV EAX,[EDX].ovtInstanceSize + TEST EAX,EAX + JE @@zeroSize + PUSH EDX + CALL _GetMem + POP EDX + TEST EAX,EAX + JZ @@fail + + { Zero fill the memory } + PUSH EDI + MOV ECX,[EDX].ovtInstanceSize + MOV EDI,EAX + PUSH EAX + XOR EAX,EAX + SHR ECX,2 + REP STOSD + MOV ECX,[EDX].ovtInstanceSize + AND ECX,3 + REP STOSB + POP EAX + POP EDI + + MOV ECX,[EDX].ovtVmtPtrOffs + TEST ECX,ECX + JL @@skip + MOV [EAX+ECX],EDX { store vmt in object at this offset } +@@skip: + TEST EAX,EAX { clear zero flag } + POP ECX + RET + +@@fail: + XOR EDX,EDX + POP ECX + RET + +@@zeroSize: + XOR EDX,EDX + CMP EAX,1 { clear zero flag - we were successful (kind of) } + POP ECX + RET + +@@noAlloc: + MOV ECX,[EDX].ovtVmtPtrOffs + TEST ECX,ECX + JL @@exit + MOV [EAX+ECX],EDX { store vmt in object at this offset } +@@exit: + XOR EDX,EDX { clear allocated flag } + TEST EAX,EAX { clear zero flag } + POP ECX +end; + +procedure _ObjCopy; +asm +{ PROCEDURE _ObjCopy( dest, src: ^OBJECT; vmtPtrOff: Longint); } +{ ->EAX Pointer to destination } +{ EDX Pointer to source } +{ ECX Offset of vmt in those objects. } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EDX + MOV EDI,EAX + + LEA EAX,[EDI+ECX] { remember pointer to dest vmt pointer } + MOV EDX,[EAX] { fetch dest vmt pointer } + + MOV EBX,[EDX].ovtInstanceSize + + MOV ECX,EBX { copy size DIV 4 dwords } + SHR ECX,2 + REP MOVSD + + MOV ECX,EBX { copy size MOD 4 bytes } + AND ECX,3 + REP MOVSB + + MOV [EAX],EDX { restore dest vmt } + + POP EDI + POP ESI + POP EBX +end; + +procedure _Fail; +asm +{ FUNCTION _Fail( self: ^OBJECT; allocFlag:Longint): ^OBJECT; } +{ ->EAX Pointer to self (possibly nil) } +{ EDX <> 0: Object must be deallocated } +{ <-EAX Nil } + + TEST EDX,EDX + JE @@exit { if no object was allocated, return } + CALL _FreeMem +@@exit: + XOR EAX,EAX +end; + +{$IFDEF MSWINDOWS} +function GetKeyboardType(nTypeFlag: Integer): Integer; stdcall; + external user name 'GetKeyboardType'; + +function _isNECWindows: Boolean; +var + KbSubType: Integer; +begin + Result := False; + if GetKeyboardType(0) = $7 then + begin + KbSubType := GetKeyboardType(1) and $FF00; + if (KbSubType = $0D00) or (KbSubType = $0400) then + Result := True; + end; +end; + +const + HKEY_LOCAL_MACHINE = $80000002; + +// workaround a Japanese Win95 bug +procedure _FpuMaskInit; +const + KEY_QUERY_VALUE = $00000001; + REG_DWORD = 4; + FPUMASKKEY = 'SOFTWARE\Borland\Delphi\RTL'; + FPUMASKNAME = 'FPUMaskValue'; +var + phkResult: LongWord; + lpData, DataSize: Longint; +begin + lpData := Default8087CW; + + if RegOpenKeyEx(HKEY_LOCAL_MACHINE, FPUMASKKEY, 0, KEY_QUERY_VALUE, phkResult) = 0 then + try + DataSize := Sizeof(lpData); + RegQueryValueEx(phkResult, FPUMASKNAME, nil, nil, @lpData, @DataSize); + finally + RegCloseKey(phkResult); + end; + Default8087CW := (Default8087CW and $ffc0) or (lpData and $3f); +end; +{$ENDIF} + +procedure _FpuInit; +asm + FNINIT + FWAIT +{$IFDEF PIC} + CALL GetGOT + MOV EAX,[EAX].OFFSET Default8087CW + FLDCW [EAX] +{$ELSE} + FLDCW Default8087CW +{$ENDIF} +end; + +procedure FpuInit; +//const cwDefault: Word = $1332 { $133F}; +asm + JMP _FpuInit +end; + +procedure FpuInitConsiderNECWindows; +begin + if _isNECWindows then _FpuMaskInit; + FpuInit(); +end; + +procedure _BoundErr; +asm + MOV AL,reRangeError + JMP Error +end; + +procedure _IntOver; +asm + MOV AL,reIntOverflow + JMP Error +end; + +function TObject.ClassType: TClass; +begin + Pointer(Result) := PPointer(Self)^; +end; + +class function TObject.ClassName: ShortString; +{$IFDEF PUREPASCAL} +begin + Result := PShortString(PPointer(Integer(Self) + vmtClassName)^)^; +end; +{$ELSE} +asm + { -> EAX VMT } + { EDX Pointer to result string } + PUSH ESI + PUSH EDI + MOV EDI,EDX + MOV ESI,[EAX].vmtClassName + XOR ECX,ECX + MOV CL,[ESI] + INC ECX + REP MOVSB + POP EDI + POP ESI +end; +{$ENDIF} + +class function TObject.ClassNameIs(const Name: string): Boolean; +{$IFDEF PUREPASCAL} +var + Temp: ShortString; + I: Byte; +begin + Result := False; + Temp := ClassName; + for I := 0 to Byte(Temp[0]) do + if Temp[I] <> Name[I] then Exit; + Result := True; +end; +{$ELSE} +asm + PUSH EBX + XOR EBX,EBX + OR EDX,EDX + JE @@exit + MOV EAX,[EAX].vmtClassName + XOR ECX,ECX + MOV CL,[EAX] + CMP ECX,[EDX-4] + JNE @@exit + DEC EDX +@@loop: + MOV BH,[EAX+ECX] + XOR BH,[EDX+ECX] + AND BH,0DFH + JNE @@exit + DEC ECX + JNE @@loop + INC EBX +@@exit: + MOV AL,BL + POP EBX +end; +{$ENDIF} + +class function TObject.ClassParent: TClass; +{$IFDEF PUREPASCAL} +begin + Pointer(Result) := PPointer(Integer(Self) + vmtParent)^; + if Result <> nil then + Pointer(Result) := PPointer(Result)^; +end; +{$ELSE} +asm + MOV EAX,[EAX].vmtParent + TEST EAX,EAX + JE @@exit + MOV EAX,[EAX] +@@exit: +end; +{$ENDIF} + +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; +begin +end; + +destructor TObject.Destroy; +begin +end; + +procedure TObject.Free; +begin + if Self <> nil then + Destroy; +end; + +class function TObject.InitInstance(Instance: Pointer): TObject; +{$IFDEF PUREPASCAL} +var + IntfTable: PInterfaceTable; + ClassPtr: TClass; + I: Integer; +begin + FillChar(Instance^, InstanceSize, 0); + PInteger(Instance)^ := Integer(Self); + ClassPtr := Self; + while ClassPtr <> nil do + begin + IntfTable := ClassPtr.GetInterfaceTable; + if IntfTable <> nil then + for I := 0 to IntfTable.EntryCount-1 do + with IntfTable.Entries[I] do + begin + if VTable <> nil then + PInteger(@PChar(Instance)[IOffset])^ := Integer(VTable); + end; + ClassPtr := ClassPtr.ClassParent; + end; + Result := Instance; +end; +{$ELSE} +asm + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV EDI,EDX + STOSD + MOV ECX,[EBX].vmtInstanceSize + XOR EAX,EAX + PUSH ECX + SHR ECX,2 + DEC ECX + REP STOSD + POP ECX + AND ECX,3 + REP STOSB + MOV EAX,EDX + MOV EDX,ESP +@@0: MOV ECX,[EBX].vmtIntfTable + TEST ECX,ECX + JE @@1 + PUSH ECX +@@1: MOV EBX,[EBX].vmtParent + TEST EBX,EBX + JE @@2 + MOV EBX,[EBX] + JMP @@0 +@@2: CMP ESP,EDX + JE @@5 +@@3: POP EBX + MOV ECX,[EBX].TInterfaceTable.EntryCount + ADD EBX,4 +@@4: MOV ESI,[EBX].TInterfaceEntry.VTable + TEST ESI,ESI + JE @@4a + MOV EDI,[EBX].TInterfaceEntry.IOffset + MOV [EAX+EDI],ESI +@@4a: ADD EBX,TYPE TInterfaceEntry + DEC ECX + JNE @@4 + CMP ESP,EDX + JNE @@3 +@@5: POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +procedure TObject.CleanupInstance; +{$IFDEF PUREPASCAL} +var + ClassPtr: TClass; + InitTable: Pointer; +begin + ClassPtr := ClassType; + InitTable := PPointer(Integer(ClassPtr) + vmtInitTable)^; + while (ClassPtr <> nil) and (InitTable <> nil) do + begin + _FinalizeRecord(Self, InitTable); + ClassPtr := ClassPtr.ClassParent; + if ClassPtr <> nil then + InitTable := PPointer(Integer(ClassPtr) + vmtInitTable)^; + end; +end; +{$ELSE} +asm + PUSH EBX + PUSH ESI + MOV EBX,EAX + MOV ESI,EAX +@@loop: + MOV ESI,[ESI] + MOV EDX,[ESI].vmtInitTable + MOV ESI,[ESI].vmtParent + TEST EDX,EDX + JE @@skip + CALL _FinalizeRecord + MOV EAX,EBX +@@skip: + TEST ESI,ESI + JNE @@loop + + POP ESI + POP EBX +end; +{$ENDIF} + +function InvokeImplGetter(Self: TObject; ImplGetter: Cardinal): IInterface; +{$IFDEF PUREPASCAL} +var + M: function: IInterface of object; +begin + TMethod(M).Data := Self; + case ImplGetter of + $FF000000..$FFFFFFFF: // Field + Result := IInterface(Pointer(Cardinal(Self) + (ImplGetter and $00FFFFFF))); + $FE000000..$FEFFFFFF: // virtual method + begin + // sign extend vmt slot offset = smallint cast + TMethod(M).Code := PPointer(Integer(Self) + SmallInt(ImplGetter))^; + Result := M; + end; + else // static method + TMethod(M).Code := Pointer(ImplGetter); + Result := M; + end; +end; +{$ELSE} +asm + XCHG EDX,ECX + CMP ECX,$FF000000 + JAE @@isField + CMP ECX,$FE000000 + JB @@isStaticMethod + + { the GetProc is a virtual method } + MOVSX ECX,CX { sign extend slot offs } + ADD ECX,[EAX] { vmt + slotoffs } + JMP dword ptr [ECX] { call vmt[slot] } + +@@isStaticMethod: + JMP ECX + +@@isField: + AND ECX,$00FFFFFF + ADD ECX,EAX + MOV EAX,EDX + MOV EDX,[ECX] + JMP _IntfCopy +end; +{$ENDIF} + +function TObject.GetInterface(const IID: TGUID; out Obj): Boolean; +var + InterfaceEntry: PInterfaceEntry; +begin + Pointer(Obj) := nil; + InterfaceEntry := GetInterfaceEntry(IID); + if InterfaceEntry <> nil then + begin + if InterfaceEntry^.IOffset <> 0 then + begin + Pointer(Obj) := Pointer(Integer(Self) + InterfaceEntry^.IOffset); + if Pointer(Obj) <> nil then IInterface(Obj)._AddRef; + end + else + IInterface(Obj) := InvokeImplGetter(Self, InterfaceEntry^.ImplGetter); + end; + Result := Pointer(Obj) <> nil; +end; + +class function TObject.GetInterfaceEntry(const IID: TGUID): PInterfaceEntry; +{$IFDEF PUREPASCAL} +var + ClassPtr: TClass; + IntfTable: PInterfaceTable; + I: Integer; +begin + ClassPtr := Self; + while ClassPtr <> nil do + begin + IntfTable := ClassPtr.GetInterfaceTable; + if IntfTable <> nil then + for I := 0 to IntfTable.EntryCount-1 do + begin + Result := @IntfTable.Entries[I]; +// if Result^.IID = IID then Exit; + if (Int64(Result^.IID.D1) = Int64(IID.D1)) and + (Int64(Result^.IID.D4) = Int64(IID.D4)) then Exit; + end; + ClassPtr := ClassPtr.ClassParent; + end; + Result := nil; +end; +{$ELSE} +asm + PUSH EBX + PUSH ESI + MOV EBX,EAX +@@1: MOV EAX,[EBX].vmtIntfTable + TEST EAX,EAX + JE @@4 + MOV ECX,[EAX].TInterfaceTable.EntryCount + ADD EAX,4 +@@2: MOV ESI,[EDX].Integer[0] + CMP ESI,[EAX].TInterfaceEntry.IID.Integer[0] + JNE @@3 + MOV ESI,[EDX].Integer[4] + CMP ESI,[EAX].TInterfaceEntry.IID.Integer[4] + JNE @@3 + MOV ESI,[EDX].Integer[8] + CMP ESI,[EAX].TInterfaceEntry.IID.Integer[8] + JNE @@3 + MOV ESI,[EDX].Integer[12] + CMP ESI,[EAX].TInterfaceEntry.IID.Integer[12] + JE @@5 +@@3: ADD EAX,type TInterfaceEntry + DEC ECX + JNE @@2 +@@4: MOV EBX,[EBX].vmtParent + TEST EBX,EBX + JE @@4a + MOV EBX,[EBX] + JMP @@1 +@@4a: XOR EAX,EAX +@@5: POP ESI + POP EBX +end; +{$ENDIF} + +class function TObject.GetInterfaceTable: PInterfaceTable; +begin + Result := PPointer(Integer(Self) + vmtIntfTable)^; +end; + +function _IsClass(Child: TObject; Parent: TClass): Boolean; +begin + Result := (Child <> nil) and Child.InheritsFrom(Parent); +end; + +function _AsClass(Child: TObject; Parent: TClass): TObject; +{$IFDEF PUREPASCAL} +begin + Result := Child; + if not (Child is Parent) then + Error(reInvalidCast); // loses return address +end; +{$ELSE} +asm + { -> EAX left operand (class) } + { EDX VMT of right operand } + { <- EAX if left is derived from right, else runtime error } + TEST EAX,EAX + JE @@exit + MOV ECX,EAX +@@loop: + MOV ECX,[ECX] + CMP ECX,EDX + JE @@exit + MOV ECX,[ECX].vmtParent + TEST ECX,ECX + JNE @@loop + + { do runtime error } + MOV AL,reInvalidCast + JMP Error + +@@exit: +end; +{$ENDIF} + + +procedure GetDynaMethod; +{ function GetDynaMethod(vmt: TClass; selector: Smallint) : Pointer; } +asm + { -> EAX vmt of class } + { SI dynamic method index } + { <- ESI pointer to routine } + { ZF = 0 if found } + { trashes: EAX, ECX } + + PUSH EDI + XCHG EAX,ESI + JMP @@haveVMT +@@outerLoop: + MOV ESI,[ESI] +@@haveVMT: + MOV EDI,[ESI].vmtDynamicTable + TEST EDI,EDI + JE @@parent + MOVZX ECX,word ptr [EDI] + PUSH ECX + ADD EDI,2 + REPNE SCASW + JE @@found + POP ECX +@@parent: + MOV ESI,[ESI].vmtParent + TEST ESI,ESI + JNE @@outerLoop + JMP @@exit + +@@found: + POP EAX + ADD EAX,EAX + SUB EAX,ECX { this will always clear the Z-flag ! } + MOV ESI,[EDI+EAX*2-4] + +@@exit: + POP EDI +end; + +procedure _CallDynaInst; +asm + PUSH EAX + PUSH ECX + MOV EAX,[EAX] + CALL GetDynaMethod + POP ECX + POP EAX + JE @@Abstract + JMP ESI +@@Abstract: + POP ECX + JMP _AbstractError +end; + + +procedure _CallDynaClass; +asm + PUSH EAX + PUSH ECX + CALL GetDynaMethod + POP ECX + POP EAX + JE @@Abstract + JMP ESI +@@Abstract: + POP ECX + JMP _AbstractError +end; + + +procedure _FindDynaInst; +asm + PUSH ESI + MOV ESI,EDX + MOV EAX,[EAX] + CALL GetDynaMethod + MOV EAX,ESI + POP ESI + JNE @@exit + POP ECX + JMP _AbstractError +@@exit: +end; + + +procedure _FindDynaClass; +asm + PUSH ESI + MOV ESI,EDX + CALL GetDynaMethod + MOV EAX,ESI + POP ESI + JNE @@exit + POP ECX + JMP _AbstractError +@@exit: +end; + +class function TObject.InheritsFrom(AClass: TClass): Boolean; +{$IFDEF PUREPASCAL} +var + ClassPtr: TClass; +begin + ClassPtr := Self; + while (ClassPtr <> nil) and (ClassPtr <> AClass) do + ClassPtr := PPointer(Integer(ClassPtr) + vmtParent)^; + Result := ClassPtr = AClass; +end; +{$ELSE} +asm + { -> EAX Pointer to our class } + { EDX Pointer to AClass } + { <- AL Boolean result } + JMP @@haveVMT +@@loop: + MOV EAX,[EAX] +@@haveVMT: + CMP EAX,EDX + JE @@success + MOV EAX,[EAX].vmtParent + TEST EAX,EAX + JNE @@loop + JMP @@exit +@@success: + MOV AL,1 +@@exit: +end; +{$ENDIF} + + +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); +begin +end; + + +procedure TObject.AfterConstruction; +begin +end; + +procedure TObject.BeforeDestruction; +begin +end; + +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].vmtDefaultHandler +end; + + +class function TObject.MethodAddress(const Name: ShortString): Pointer; +asm + { -> EAX Pointer to class } + { EDX Pointer to name } + PUSH EBX + PUSH ESI + PUSH EDI + XOR ECX,ECX + XOR EDI,EDI + MOV BL,[EDX] + JMP @@haveVMT +@@outer: { upper 16 bits of ECX are 0 ! } + MOV EAX,[EAX] +@@haveVMT: + MOV ESI,[EAX].vmtMethodTable + TEST ESI,ESI + JE @@parent + MOV DI,[ESI] { EDI := method count } + ADD ESI,2 +@@inner: { upper 16 bits of ECX are 0 ! } + MOV CL,[ESI+6] { compare length of strings } + CMP CL,BL + JE @@cmpChar +@@cont: { upper 16 bits of ECX are 0 ! } + MOV CX,[ESI] { fetch length of method desc } + ADD ESI,ECX { point ESI to next method } + DEC EDI + JNZ @@inner +@@parent: + MOV EAX,[EAX].vmtParent { fetch parent vmt } + TEST EAX,EAX + JNE @@outer + JMP @@exit { return NIL } + +@@notEqual: + MOV BL,[EDX] { restore BL to length of name } + JMP @@cont + +@@cmpChar: { upper 16 bits of ECX are 0 ! } + MOV CH,0 { upper 24 bits of ECX are 0 ! } +@@cmpCharLoop: + MOV BL,[ESI+ECX+6] { case insensitive string cmp } + XOR BL,[EDX+ECX+0] { last char is compared first } + AND BL,$DF + JNE @@notEqual + DEC ECX { ECX serves as counter } + JNZ @@cmpCharLoop + + { found it } + MOV EAX,[ESI+2] + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +class function TObject.MethodName(Address: Pointer): ShortString; +asm + { -> EAX Pointer to class } + { EDX Address } + { ECX Pointer to result } + PUSH EBX + PUSH ESI + PUSH EDI + MOV EDI,ECX + XOR EBX,EBX + XOR ECX,ECX + JMP @@haveVMT +@@outer: + MOV EAX,[EAX] +@@haveVMT: + MOV ESI,[EAX].vmtMethodTable { fetch pointer to method table } + TEST ESI,ESI + JE @@parent + MOV CX,[ESI] + ADD ESI,2 +@@inner: + CMP EDX,[ESI+2] + JE @@found + MOV BX,[ESI] + ADD ESI,EBX + DEC ECX + JNZ @@inner +@@parent: + MOV EAX,[EAX].vmtParent + TEST EAX,EAX + JNE @@outer + MOV [EDI],AL + JMP @@exit + +@@found: + ADD ESI,6 + XOR ECX,ECX + MOV CL,[ESI] + INC ECX + REP MOVSB + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +function TObject.FieldAddress(const Name: ShortString): Pointer; +asm + { -> EAX Pointer to instance } + { EDX Pointer to name } + PUSH EBX + PUSH ESI + PUSH EDI + XOR ECX,ECX + XOR EDI,EDI + MOV BL,[EDX] + + PUSH EAX { save instance pointer } + +@@outer: + MOV EAX,[EAX] { fetch class pointer } + MOV ESI,[EAX].vmtFieldTable + TEST ESI,ESI + JE @@parent + MOV DI,[ESI] { fetch count of fields } + ADD ESI,6 +@@inner: + MOV CL,[ESI+6] { compare string lengths } + CMP CL,BL + JE @@cmpChar +@@cont: + LEA ESI,[ESI+ECX+7] { point ESI to next field } + DEC EDI + JNZ @@inner +@@parent: + MOV EAX,[EAX].vmtParent { fetch parent VMT } + TEST EAX,EAX + JNE @@outer + POP EDX { forget instance, return Nil } + JMP @@exit + +@@notEqual: + MOV BL,[EDX] { restore BL to length of name } + MOV CL,[ESI+6] { ECX := length of field name } + JMP @@cont + +@@cmpChar: + MOV BL,[ESI+ECX+6] { case insensitive string cmp } + XOR BL,[EDX+ECX+0] { starting with last char } + AND BL,$DF + JNE @@notEqual + DEC ECX { ECX serves as counter } + JNZ @@cmpChar + + { found it } + MOV EAX,[ESI] { result is field offset plus ... } + POP EDX + ADD EAX,EDX { instance pointer } + +@@exit: + POP EDI + POP ESI + POP EBX +end; + +function _ClassCreate(AClass: TClass; Alloc: Boolean): TObject; +asm + { -> EAX = pointer to VMT } + { <- EAX = pointer to instance } + PUSH EDX + PUSH ECX + PUSH EBX + TEST DL,DL + JL @@noAlloc + CALL dword ptr [EAX].vmtNewInstance +@@noAlloc: +{$IFNDEF PC_MAPPED_EXCEPTIONS} + XOR EDX,EDX + LEA ECX,[ESP+16] + MOV EBX,FS:[EDX] + MOV [ECX].TExcFrame.next,EBX + MOV [ECX].TExcFrame.hEBP,EBP + MOV [ECX].TExcFrame.desc,offset @desc + MOV [ECX].TexcFrame.ConstructedObject,EAX { trick: remember copy to instance } + MOV FS:[EDX],ECX +{$ENDIF} + POP EBX + POP ECX + POP EDX + RET + +{$IFNDEF PC_MAPPED_EXCEPTIONS} +@desc: + JMP _HandleAnyException + + { destroy the object } + + MOV EAX,[ESP+8+9*4] + MOV EAX,[EAX].TExcFrame.ConstructedObject + TEST EAX,EAX + JE @@skip + MOV ECX,[EAX] + MOV DL,$81 + PUSH EAX + CALL dword ptr [ECX].vmtDestroy + POP EAX + CALL _ClassDestroy +@@skip: + { reraise the exception } + CALL _RaiseAgain +{$ENDIF} +end; + +procedure _ClassDestroy(Instance: TObject); +begin + Instance.FreeInstance; +end; + + +function _AfterConstruction(Instance: TObject): TObject; +begin + Instance.AfterConstruction; + Result := Instance; +end; + +function _BeforeDestruction(Instance: TObject; OuterMost: ShortInt): TObject; +// Must preserve DL on return! +{$IFDEF PUREPASCAL} +begin + Result := Instance; + if OuterMost > 0 then Exit; + Instance.BeforeDestruction; +end; +{$ELSE} +asm + { -> EAX = pointer to instance } + { DL = dealloc flag } + + TEST DL,DL + JG @@outerMost + RET +@@outerMost: + PUSH EAX + PUSH EDX + MOV EDX,[EAX] + CALL dword ptr [EDX].vmtBeforeDestruction + POP EDX + POP EAX +end; +{$ENDIF} + +{ + 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_CONTINE so that normal processing will occur. +} + +{$IFDEF LINUX} +const + excRaise = 0; { an exception is being raised by the user (could be a reraise) } + excCatch = 1; { an exception is about to be caught } + excFinally = 2; { a finally block is about to be executed because of an exception } + excUnhandled = 3; { no user exception handler was found (the app will die) } + +procedure _DbgExcNotify( + NotificationKind: Integer; + ExceptionObject: Pointer; + ExceptionName: PShortString; + ExceptionLocation: Pointer; + HandlerAddr: Pointer); cdecl; export; +begin +{$IFDEF DEBUG} + { + This code is just for debugging the exception handling system. The debugger + needs _DbgExcNotify, however to place breakpoints in, so the function itself + cannot be removed. + } + asm + PUSH EAX + PUSH EDX + end; + if Assigned(ExcNotificationProc) then + ExcNotificationProc(NotificationKind, ExceptionObject, ExceptionName, ExceptionLocation, HandlerAddr); + asm + POP EDX + POP EAX + end; +{$ENDIF} +end; + +{ + The following functions are used by the debugger for the evaluator. If you + change them IN ANY WAY, the debugger will cease to function correctly. +} +procedure _DbgEvalMarker; +begin +end; + +procedure _DbgEvalExcept(E: TObject); +begin +end; + +procedure _DbgEvalEnd; +begin +end; + +{ + This function is used by the debugger to provide a soft landing spot + when evaluating a function call that may raise an unhandled exception. + The return address of _DbgEvalMarker is pushed onto the stack so that + the unwinder will transfer control to the except block. +} +procedure _DbgEvalFrame; +begin + try + _DbgEvalMarker; + except on E: TObject do + _DbgEvalExcept(E); + end; + _DbgEvalEnd; +end; + +{ + These export names need to match the names that will be generated into + the .symtab section, so that the debugger can find them if stabs + debug information is being generated. +} +exports + _DbgExcNotify name '@DbgExcNotify', + _DbgEvalFrame name '@DbgEvalFrame', + _DbgEvalMarker name '@DbgEvalMarker', + _DbgEvalExcept name '@DbgEvalExcept', + _DbgEvalEnd name '@DbgEvalEnd'; +{$ENDIF} + +{ tell the debugger that the next raise is a re-raise of the current non-Delphi + exception } +procedure NotifyReRaise; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX location of exception } + PUSH 0 { handler addr } + PUSH EDX { location of exception } + MOV ECX, [EAX] + PUSH [ECX].vmtClassName { exception name } + PUSH EAX { exception object } + PUSH excRaise { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 +{$ELSE} + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH 0 + PUSH 0 + PUSH cContinuable + PUSH cDelphiReRaise + CALL RaiseExceptionProc +@@1: +{$ENDIF} +end; + +{ tell the debugger about the raise of a non-Delphi exception } +{$IFNDEF LINUX} +procedure NotifyNonDelphiException; +asm + CMP BYTE PTR DebugHook,0 + JE @@1 + PUSH EAX + PUSH EAX + PUSH EDX + PUSH ESP + PUSH 2 + PUSH cContinuable + PUSH cNonDelphiException + CALL RaiseExceptionProc + ADD ESP,8 + POP EAX +@@1: +end; +{$ENDIF} + +{ Tell the debugger where the handler for the current exception is located } +procedure NotifyExcept; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX handler addr } + PUSH EAX + MOV EAX, [EAX].TRaisedException.ExceptObject + + PUSH EDX { handler addr } + PUSH 0 { location of exception } + MOV ECX, [EAX] + PUSH [ECX].vmtClassName { exception name } + PUSH EAX { exception object } + PUSH excCatch { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 + + POP EAX +{$ELSE} + PUSH ESP + PUSH 1 + PUSH cContinuable + PUSH cDelphiExcept { our magic exception code } + CALL RaiseExceptionProc + ADD ESP,4 + POP EAX +{$ENDIF} +end; + +procedure NotifyOnExcept; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX handler addr } + PUSH EDX { handler addr } + PUSH 0 { location of exception } + MOV ECX, [EAX] + PUSH [ECX].vmtClassName { exception name } + PUSH EAX { exception object } + PUSH excCatch { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 +{$ELSE} + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH EAX + PUSH [EBX].TExcDescEntry.handler + JMP NotifyExcept +@@1: +{$ENDIF} +end; + +{$IFNDEF LINUX} +procedure NotifyAnyExcept; +asm + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH EAX + PUSH EBX + JMP NotifyExcept +@@1: +end; + +procedure CheckJmp; +asm + TEST ECX,ECX + JE @@3 + MOV EAX,[ECX + 1] + CMP BYTE PTR [ECX],0E9H { near jmp } + JE @@1 + CMP BYTE PTR [ECX],0EBH { short jmp } + JNE @@3 + MOVSX EAX,AL + INC ECX + INC ECX + JMP @@2 +@@1: + ADD ECX,5 +@@2: + ADD ECX,EAX +@@3: +end; +{$ENDIF} { not LINUX } + +{ Notify debugger of a finally during an exception unwind } +procedure NotifyExceptFinally; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX handler addr } + PUSH EDX { handler addr } + PUSH 0 { location of exception } + PUSH 0 { exception name } + PUSH 0 { exception object } + PUSH excFinally { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 +{$ELSE} + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH EAX + PUSH EDX + PUSH ECX + CALL CheckJmp + PUSH ECX + PUSH ESP { pass pointer to arguments } + PUSH 1 { there is 1 argument } + PUSH cContinuable { continuable execution } + PUSH cDelphiFinally { our magic exception code } + CALL RaiseExceptionProc + POP ECX + POP ECX + POP EDX + POP EAX +@@1: +{$ENDIF} +end; + + +{ Tell the debugger that the current exception is handled and cleaned up. + Also indicate where execution is about to resume. } +{$IFNDEF LINUX} +procedure NotifyTerminate; +asm + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH EDX + PUSH ESP + PUSH 1 + PUSH cContinuable + PUSH cDelphiTerminate { our magic exception code } + CALL RaiseExceptionProc + POP EDX +@@1: +end; +{$ENDIF} + +{ 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; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX location of exception } + PUSH EAX + MOV EAX, [EAX].TRaisedException.ExceptObject + + PUSH 0 { handler addr } + PUSH EDX { location of exception } + MOV ECX, [EAX] + PUSH [ECX].vmtClassName { exception name } + PUSH EAX { exception object } + PUSH excUnhandled { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 + + POP EAX +{$ELSE} + PUSH EAX + PUSH EDX + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH ESP + PUSH 2 + PUSH cContinuable + PUSH cDelphiUnhandled + CALL RaiseExceptionProc +@@1: + POP EDX + POP EAX +{$ENDIF} +end; + +procedure _HandleAnyException; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + CALL UnblockOSExceptions + OR [EAX].TRaisedException.Flags, excIsBeingHandled + MOV ESI, EBX + MOV EDX, [ESP] + CALL NotifyExcept + MOV EBX, ESI +{$ENDIF} +{$IFNDEF PC_MAPPED_EXCEPTIONS} + { -> [ESP+ 4] excPtr: PExceptionRecord } + { [ESP+ 8] errPtr: PExcFrame } + { [ESP+12] ctxPtr: Pointer } + { [ESP+16] dspPtr: Pointer } + { <- EAX return value - always one } + + MOV EAX,[ESP+4] + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JNE @@exit + + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + MOV EDX,[EAX].TExceptionRecord.ExceptObject + MOV ECX,[EAX].TExceptionRecord.ExceptAddr + JE @@DelphiException + CLD + CALL _FpuInit + MOV EDX,ExceptObjProc + TEST EDX,EDX + JE @@exit + CALL EDX + TEST EAX,EAX + JE @@exit + MOV EDX,[ESP+12] + MOV ECX,[ESP+4] + CMP [ECX].TExceptionRecord.ExceptionCode,cCppException + JE @@CppException + CALL NotifyNonDelphiException +{$IFDEF MSWINDOWS} + CMP BYTE PTR JITEnable,0 + JBE @@CppException + CMP BYTE PTR DebugHook,0 + JA @@CppException // Do not JIT if debugging + LEA ECX,[ESP+4] + PUSH EAX + PUSH ECX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + POP EAX + JE @@exit + MOV EDX,EAX + MOV EAX,[ESP+4] + MOV ECX,[EAX].TExceptionRecord.ExceptionAddress + JMP @@GoUnwind +{$ENDIF} +@@CppException: + MOV EDX,EAX + MOV EAX,[ESP+4] + MOV ECX,[EAX].TExceptionRecord.ExceptionAddress + +@@DelphiException: +{$IFDEF MSWINDOWS} + CMP BYTE PTR JITEnable,1 + JBE @@GoUnwind + CMP BYTE PTR DebugHook,0 { Do not JIT if debugging } + JA @@GoUnwind + PUSH EAX + LEA EAX,[ESP+8] + PUSH EDX + PUSH ECX + PUSH EAX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + POP ECX + POP EDX + POP EAX + JE @@exit +{$ENDIF} + +@@GoUnwind: + OR [EAX].TExceptionRecord.ExceptionFlags,cUnwinding + + PUSH EBX + XOR EBX,EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBX,FS:[EBX] + PUSH EBX { Save pointer to topmost frame } + PUSH EAX { Save OS exception pointer } + PUSH EDX { Save exception object } + PUSH ECX { Save exception address } + + MOV EDX,[ESP+8+8*4] + + PUSH 0 + PUSH EAX + PUSH offset @@returnAddress + PUSH EDX + CALL RtlUnwindProc +@@returnAddress: + + MOV EDI,[ESP+8+8*4] + + { Make the RaiseList entry on the stack } + + CALL SysInit.@GetTLS + PUSH [EAX].RaiseListPtr + MOV [EAX].RaiseListPtr,ESP + + MOV EBP,[EDI].TExcFrame.hEBP + MOV EBX,[EDI].TExcFrame.desc + MOV [EDI].TExcFrame.desc,offset @@exceptFinally + + ADD EBX,TExcDesc.instructions + CALL NotifyAnyExcept + JMP EBX + +@@exceptFinally: + JMP _HandleFinally + +@@destroyExcept: + { we come here if an exception handler has thrown yet another exception } + { we need to destroy the exception object and pop the raise list. } + + CALL SysInit.@GetTLS + MOV ECX,[EAX].RaiseListPtr + MOV EDX,[ECX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,EDX + + MOV EAX,[ECX].TRaiseFrame.ExceptObject + JMP TObject.Free + +@@exit: + MOV EAX,1 +{$ENDIF} { not PC_MAPPED_EXCEPTIONS } +end; + +{$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; +asm + { -> EAX raised object: Pointer } + { EDX descriptor table: ^TExcDesc } + { EBX GOT of user code, or 0 if not an SO } + { <- EAX matching descriptor: ^TExcDescEntry } + PUSH EBP + MOV EBP, ESP + SUB ESP, 8 { Room for vtable temp, and adjustor } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV [EBP - 8], EBX { Store the potential GOT } + MOV EAX, [EAX] { load vtable of exception object } + MOV EBX,[EDX].TExcDesc.cnt + LEA ESI,[EDX].TExcDesc.excTab { point ECX to exc descriptor table } + MOV [EBP - 4], EAX { temp for vtable of exception object } + +@@innerLoop: + MOV EAX,[ESI].TExcDescEntry.vTable + TEST EAX,EAX { catch all clause? } + JE @@found { yes: This is the handler } + ADD EAX, [EBP - 8] { add in the adjustor (could be 0) } + MOV EDI,[EBP - 4] { load vtable of exception object } + JMP @@haveVMT + +@@vtLoop: + MOV EDI,[EDI] +@@haveVMT: + MOV EAX,[EAX] + CMP EAX,EDI + JE @@found + + MOV ECX,[EAX].vmtInstanceSize + CMP ECX,[EDI].vmtInstanceSize + JNE @@parent + + MOV EAX,[EAX].vmtClassName + MOV EDX,[EDI].vmtClassName + + XOR ECX,ECX + MOV CL,[EAX] + CMP CL,[EDX] + JNE @@parent + + INC EAX + INC EDX + CALL _AStrCmp + JE @@found + +@@parent: + MOV EDI,[EDI].vmtParent { load vtable of parent } + MOV EAX,[ESI].TExcDescEntry.vTable + ADD EAX, [EBP - 8] { add in the adjustor (could be 0) } + TEST EDI,EDI + JNE @@vtLoop + + ADD ESI,8 + DEC EBX + JNZ @@innerLoop + + { Didn't find a handler. } + XOR ESI, ESI + +@@found: + MOV EAX, ESI +@@done: + POP EDI + POP ESI + POP EBX + MOV ESP, EBP + POP EBP +end; +{$ENDIF} + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _HandleOnExceptionPIC; +asm + { -> EAX obj : Exception object } + { [RA] desc: ^TExcDesc } + { <- Doesn't return } + + // Mark the exception as being handled + OR [EAX].TRaisedException.Flags, excIsBeingHandled + + MOV ESI, EBX // Save the GOT + MOV EDX, [ESP] // Get the addr of the TExcDesc + PUSH EAX // Save the object + MOV EAX, [EAX].TRaisedException.ExceptObject + CALL FindOnExceptionDescEntry + OR EAX, EAX + JE @@NotForMe + + MOV EBX, ESI // Set back to user's GOT + MOV EDX, EAX + POP EAX // Get the object back + POP ECX // Ditch the return addr + + // Get the Pascal object itself. + MOV EAX, [EAX].TRaisedException.ExceptObject + + MOV EDX, [EDX].TExcDescEntry.handler + ADD EDX, EBX // adjust for GOT + CALL NotifyOnExcept + + MOV EBX, ESI // Make sure of user's GOT + JMP EDX // Back to the user code + // never returns +@@NotForMe: + POP EAX // Get the exception object + + // Mark that we're reraising this exception, so that the + // compiler generated exception handler for the 'except on' clause + // will not get confused + OR [EAX].TRaisedException.Flags, excIsBeingReRaised + + JMP SysRaiseException // Should be using resume here +end; +{$ENDIF} + +procedure _HandleOnException; +{$IFDEF PC_MAPPED_EXCEPTIONS} +asm + { -> EAX obj : Exception object } + { [RA] desc: ^TExcDesc } + { <- Doesn't return } + + // Mark the exception as being handled + OR [EAX].TRaisedException.Flags, excIsBeingHandled + + MOV EDX, [ESP] // Get the addr of the TExcDesc + PUSH EAX // Save the object + PUSH EBX // Save EBX + XOR EBX, EBX // No GOT + MOV EAX, [EAX].TRaisedException.ExceptObject + CALL FindOnExceptionDescEntry + POP EBX // Restore EBX + OR EAX, EAX // Is the exception for me? + JE @@NotForMe + + MOV EDX, EAX + POP EAX // Get the object back + POP ECX // Ditch the return addr + + // Get the Pascal object itself. + MOV EAX, [EAX].TRaisedException.ExceptObject + + MOV EDX, [EDX].TExcDescEntry.handler + CALL NotifyOnExcept // Tell the debugger about it + + JMP EDX // Back to the user code + // never returns +@@NotForMe: + POP EAX // Get the exception object + + // Mark that we're reraising this exception, so that the + // compiler generated exception handler for the 'except on' clause + // will not get confused + OR [EAX].TRaisedException.Flags, excIsBeingReRaised + JMP SysRaiseException // Should be using resume here +end; +{$ENDIF} +{$IFNDEF PC_MAPPED_EXCEPTIONS} +asm + { -> [ESP+ 4] excPtr: PExceptionRecord } + { [ESP+ 8] errPtr: PExcFrame } + { [ESP+12] ctxPtr: Pointer } + { [ESP+16] dspPtr: Pointer } + { <- EAX return value - always one } + + MOV EAX,[ESP+4] + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JNE @@exit + + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + JE @@DelphiException + CLD + CALL _FpuInit + MOV EDX,ExceptClsProc + TEST EDX,EDX + JE @@exit + CALL EDX + TEST EAX,EAX + JNE @@common + JMP @@exit + +@@DelphiException: + MOV EAX,[EAX].TExceptionRecord.ExceptObject + MOV EAX,[EAX] { load vtable of exception object } + +@@common: + + MOV EDX,[ESP+8] + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV ECX,[EDX].TExcFrame.desc + MOV EBX,[ECX].TExcDesc.cnt + LEA ESI,[ECX].TExcDesc.excTab { point ECX to exc descriptor table } + MOV EBP,EAX { load vtable of exception object } + +@@innerLoop: + MOV EAX,[ESI].TExcDescEntry.vTable + TEST EAX,EAX { catch all clause? } + JE @@doHandler { yes: go execute handler } + MOV EDI,EBP { load vtable of exception object } + JMP @@haveVMT + +@@vtLoop: + MOV EDI,[EDI] +@@haveVMT: + MOV EAX,[EAX] + CMP EAX,EDI + JE @@doHandler + + MOV ECX,[EAX].vmtInstanceSize + CMP ECX,[EDI].vmtInstanceSize + JNE @@parent + + MOV EAX,[EAX].vmtClassName + MOV EDX,[EDI].vmtClassName + + XOR ECX,ECX + MOV CL,[EAX] + CMP CL,[EDX] + JNE @@parent + + INC EAX + INC EDX + CALL _AStrCmp + JE @@doHandler + +@@parent: + MOV EDI,[EDI].vmtParent { load vtable of parent } + MOV EAX,[ESI].TExcDescEntry.vTable + TEST EDI,EDI + JNE @@vtLoop + + ADD ESI,8 + DEC EBX + JNZ @@innerLoop + + POP EBP + POP EDI + POP ESI + POP EBX + JMP @@exit + +@@doHandler: + MOV EAX,[ESP+4+4*4] + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + MOV EDX,[EAX].TExceptionRecord.ExceptObject + MOV ECX,[EAX].TExceptionRecord.ExceptAddr + JE @@haveObject + CALL ExceptObjProc + MOV EDX,[ESP+12+4*4] + CALL NotifyNonDelphiException +{$IFDEF MSWINDOWS} + CMP BYTE PTR JITEnable,0 + JBE @@NoJIT + CMP BYTE PTR DebugHook,0 + JA @@noJIT { Do not JIT if debugging } + LEA ECX,[ESP+4] + PUSH EAX + PUSH ECX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + POP EAX + JE @@exit +{$ENDIF} +@@noJIT: + MOV EDX,EAX + MOV EAX,[ESP+4+4*4] + MOV ECX,[EAX].TExceptionRecord.ExceptionAddress + JMP @@GoUnwind + +@@haveObject: +{$IFDEF MSWINDOWS} + CMP BYTE PTR JITEnable,1 + JBE @@GoUnwind + CMP BYTE PTR DebugHook,0 + JA @@GoUnwind + PUSH EAX + LEA EAX,[ESP+8] + PUSH EDX + PUSH ECX + PUSH EAX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + POP ECX + POP EDX + POP EAX + JE @@exit +{$ENDIF} + +@@GoUnwind: + XOR EBX,EBX + MOV EBX,FS:[EBX] + PUSH EBX { Save topmost frame } + PUSH EAX { Save exception record } + PUSH EDX { Save exception object } + PUSH ECX { Save exception address } + + MOV EDX,[ESP+8+8*4] + OR [EAX].TExceptionRecord.ExceptionFlags,cUnwinding + + PUSH ESI { Save handler entry } + + PUSH 0 + PUSH EAX + PUSH offset @@returnAddress + PUSH EDX + CALL RtlUnwindProc +@@returnAddress: + + POP EBX { Restore handler entry } + + MOV EDI,[ESP+8+8*4] + + { Make the RaiseList entry on the stack } + + CALL SysInit.@GetTLS + PUSH [EAX].RaiseListPtr + MOV [EAX].RaiseListPtr,ESP + + MOV EBP,[EDI].TExcFrame.hEBP + MOV [EDI].TExcFrame.desc,offset @@exceptFinally + MOV EAX,[ESP].TRaiseFrame.ExceptObject + CALL NotifyOnExcept + JMP [EBX].TExcDescEntry.handler + +@@exceptFinally: + JMP _HandleFinally + +@@destroyExcept: + { we come here if an exception handler has thrown yet another exception } + { we need to destroy the exception object and pop the raise list. } + + CALL SysInit.@GetTLS + MOV ECX,[EAX].RaiseListPtr + MOV EDX,[ECX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,EDX + + MOV EAX,[ECX].TRaiseFrame.ExceptObject + JMP TObject.Free +@@exit: + MOV EAX,1 +end; +{$ENDIF} + +procedure _HandleFinally; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} +{$IFDEF PIC} + MOV ESI, EBX +{$ENDIF} + CALL UnblockOSExceptions + MOV EDX, [ESP] + CALL NotifyExceptFinally + PUSH EAX +{$IFDEF PIC} + MOV EBX, ESI +{$ENDIF} + { + Mark the current exception with the EBP of the handler. If + an exception is raised from the finally block, then this + exception will be orphaned. We will catch this later, when + we clean up the next except block to complete execution. + See DoneExcept. + } + MOV [EAX].TRaisedException.HandlerEBP, EBP + CALL EDX + POP EAX + { + We executed the finally handler without adverse reactions. + It's safe to clear the marker now. + } + MOV [EAX].TRaisedException.HandlerEBP, $FFFFFFFF + PUSH EBP + MOV EBP, ESP + CALL SysRaiseException // Should be using resume here +{$ENDIF} +{$IFDEF MSWINDOWS} + { -> [ESP+ 4] excPtr: PExceptionRecord } + { [ESP+ 8] errPtr: PExcFrame } + { [ESP+12] ctxPtr: Pointer } + { [ESP+16] dspPtr: Pointer } + { <- EAX return value - always one } + + MOV EAX,[ESP+4] + MOV EDX,[ESP+8] + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JE @@exit + MOV ECX,[EDX].TExcFrame.desc + MOV [EDX].TExcFrame.desc,offset @@exit + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBP,[EDX].TExcFrame.hEBP + ADD ECX,TExcDesc.instructions + CALL NotifyExceptFinally + CALL ECX + + POP EBP + POP EDI + POP ESI + POP EBX + +@@exit: + MOV EAX,1 +{$ENDIF} +end; + + +procedure _HandleAutoException; +{$IFDEF LINUX} +{$IFDEF PC_MAPPED_EXCEPTIONS} +asm + // EAX = TObject reference, or nil + // [ESP] = ret addr + + CALL UnblockOSExceptions +// +// The compiler wants the stack to look like this: +// ESP+4-> HRESULT +// ESP+0-> ret addr +// +// Make it so. +// + POP EDX + PUSH 8000FFFFH + PUSH EDX + + OR EAX, EAX // Was this a method call? + JE @@Done + + PUSH EAX + CALL CurrentException + MOV EDX, [EAX].TRaisedException.ExceptObject + MOV ECX, [EAX].TRaisedException.ExceptionAddr; + POP EAX + MOV EAX, [EAX] + CALL [EAX].vmtSafeCallException.Pointer; + MOV [ESP+4], EAX +@@Done: + CALL _DoneExcept +end; +{$ELSE} +begin + Error(reSafeCallError); //!! +end; +{$ENDIF} +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + { -> [ESP+ 4] excPtr: PExceptionRecord } + { [ESP+ 8] errPtr: PExcFrame } + { [ESP+12] ctxPtr: Pointer } + { [ESP+16] dspPtr: Pointer } + { <- EAX return value - always one } + + MOV EAX,[ESP+4] + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JNE @@exit + + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + CLD + CALL _FpuInit + JE @@DelphiException + CMP BYTE PTR JITEnable,0 + JBE @@DelphiException + CMP BYTE PTR DebugHook,0 + JA @@DelphiException + +@@DoUnhandled: + LEA EAX,[ESP+4] + PUSH EAX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + JE @@exit + MOV EAX,[ESP+4] + JMP @@GoUnwind + +@@DelphiException: + CMP BYTE PTR JITEnable,1 + JBE @@GoUnwind + CMP BYTE PTR DebugHook,0 + JA @@GoUnwind + JMP @@DoUnhandled + +@@GoUnwind: + OR [EAX].TExceptionRecord.ExceptionFlags,cUnwinding + + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EDX,[ESP+8+3*4] + + PUSH 0 + PUSH EAX + PUSH offset @@returnAddress + PUSH EDX + CALL RtlUnwindProc + +@@returnAddress: + POP EBP + POP EDI + POP ESI + MOV EAX,[ESP+4] + MOV EBX,8000FFFFH + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + JNE @@done + + MOV EDX,[EAX].TExceptionRecord.ExceptObject + MOV ECX,[EAX].TExceptionRecord.ExceptAddr + MOV EAX,[ESP+8] + MOV EAX,[EAX].TExcFrame.SelfOfMethod + TEST EAX,EAX + JZ @@freeException + MOV EBX,[EAX] + CALL [EBX].vmtSafeCallException.Pointer + MOV EBX,EAX +@@freeException: + MOV EAX,[ESP+4] + MOV EAX,[EAX].TExceptionRecord.ExceptObject + CALL TObject.Free +@@done: + XOR EAX,EAX + MOV ESP,[ESP+8] + POP ECX + MOV FS:[EAX],ECX + POP EDX + POP EBP + LEA EDX,[EDX].TExcDesc.instructions + POP ECX + JMP EDX +@@exit: + MOV EAX,1 +end; +{$ENDIF} + + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _RaiseAtExcept; +asm + { -> EAX Pointer to exception object } + { -> EDX Purported addr of exception } + { Be careful: EBX is not set up in PIC mode. } + { Outward bound calls must go through an exported fn, like SysRaiseException } + OR EAX, EAX + JNE @@GoAhead + MOV EAX, 216 + CALL _RunError + +@@GoAhead: + CALL BlockOSExceptions + PUSH EBP + MOV EBP, ESP + CALL NotifyReRaise + CALL AllocateException + CALL SysRaiseException + { + This can only return if there was a terrible error. In this event, + we have to bail out. + } + JMP _Run0Error +end; +{$ENDIF} + +procedure _RaiseExcept; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + { -> EAX Pointer to exception object } + MOV EDX, [ESP] + JMP _RaiseAtExcept +{$ENDIF} +{$IFDEF MSWINDOWS} + { When making changes to the way Delphi Exceptions are raised, } + { please realize that the C++ Exception handling code reraises } + { some exceptions as Delphi Exceptions. Of course we want to } + { keep exception raising compatible between Delphi and C++, so } + { when you make changes here, consult with the relevant C++ } + { exception handling engineer. The C++ code is in xx.cpp, in } + { the RTL sources, in function tossAnException. } + + { -> EAX Pointer to exception object } + { [ESP] Error address } + + OR EAX, EAX + JNE @@GoAhead + MOV EAX, 216 + CALL _RunError +@@GoAhead: + POP EDX + + PUSH ESP + PUSH EBP + PUSH EDI + PUSH ESI + PUSH EBX + PUSH EAX { pass class argument } + PUSH EDX { pass address argument } + + PUSH ESP { pass pointer to arguments } + PUSH 7 { there are seven arguments } + PUSH cNonContinuable { we can't continue execution } + PUSH cDelphiException { our magic exception code } + PUSH EDX { pass the user's return address } + JMP RaiseExceptionProc +{$ENDIF} +end; + + +{$IFDEF PC_MAPPED_EXCEPTIONS} +{ + Used in the PC mapping exception implementation to handle exceptions in constructors. +} +procedure _ClassHandleException; +asm + { + EAX = self + EDX = top flag + } + TEST DL, DL + JE _RaiseAgain + MOV ECX,[EAX] + MOV DL,$81 + PUSH EAX + CALL dword ptr [ECX].vmtDestroy + POP EAX + CALL _ClassDestroy + JMP _RaiseAgain +end; +{$ENDIF} + +procedure _RaiseAgain; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + CALL CurrentException +// The following notifies the debugger of a reraise of exceptions. This will +// be supported in a later release, but is disabled for now. +// PUSH EAX +// MOV EDX, [EAX].TRaisedException.ExceptionAddr +// MOV EAX, [EAX].TRaisedException.ExceptObject +// CALL NotifyReRaise { Tell the debugger } +// POP EAX + TEST [EAX].TRaisedException.Flags, excIsBeingHandled + JZ @@DoIt + OR [EAX].TRaisedException.Flags, excIsBeingReRaised +@@DoIt: + MOV EDX, [ESP] { Get the user's addr } + JMP SysRaiseException +{$ENDIF} +{$IFDEF MSWINDOWS} + { -> [ESP ] return address to user program } + { [ESP+ 4 ] raise list entry (4 dwords) } + { [ESP+ 4+ 4*4] saved topmost frame } + { [ESP+ 4+ 5*4] saved registers (4 dwords) } + { [ESP+ 4+ 9*4] return address to OS } + { -> [ESP+ 4+10*4] excPtr: PExceptionRecord } + { [ESP+ 8+10*4] errPtr: PExcFrame } + + { Point the error handler of the exception frame to something harmless } + + MOV EAX,[ESP+8+10*4] + MOV [EAX].TExcFrame.desc,offset @@exit + + { Pop the RaiseList } + + CALL SysInit.@GetTLS + MOV EDX,[EAX].RaiseListPtr + MOV ECX,[EDX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,ECX + + { Destroy any objects created for non-delphi exceptions } + + MOV EAX,[EDX].TRaiseFrame.ExceptionRecord + AND [EAX].TExceptionRecord.ExceptionFlags,NOT cUnwinding + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + JE @@delphiException + MOV EAX,[EDX].TRaiseFrame.ExceptObject + CALL TObject.Free + CALL NotifyReRaise + +@@delphiException: + + XOR EAX,EAX + ADD ESP,5*4 + MOV EDX,FS:[EAX] + POP ECX + MOV EDX,[EDX].TExcFrame.next + MOV [ECX].TExcFrame.next,EDX + + POP EBP + POP EDI + POP ESI + POP EBX +@@exit: + MOV EAX,1 +{$ENDIF} +end; + +{$IFDEF DEBUG_EXCEPTIONS} +procedure NoteDE; +begin + Writeln('DoneExcept: Skipped the destructor'); +end; + +procedure NoteDE2; +begin + Writeln('DoneExcept: Destroyed the object'); +end; +{$ENDIF} + +{$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; +var + Exc: PRaisedException; + RefCount: Integer; + ExcObj: Pointer; + ExcAddr: Pointer; +begin + asm + MOV Exc, EAX + end; + + if (Exc^.Flags and excIsBeingReRaised) = 0 then + begin + RefCount := Exc^.RefCount; + ExcObj := Exc^.ExceptObject; + ExcAddr := Exc^.ExceptionAddr; + Exc^.RefCount := 1; + FreeException; + _DoneExcept; + Exc := AllocateException(ExcObj, ExcAddr); + Exc^.RefCount := RefCount; + end; + + Exc^.Flags := Exc^.Flags and not (excIsBeingReRaised or excIsBeingHandled); + + SysRaiseException(Exc); +end; +{$ENDIF} + +procedure _DoneExcept; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + CALL FreeException + OR EAX, EAX + JE @@Done + CALL TObject.Free +@@Done: + { + Take a peek at the next exception object on the stack. + If its EBP marker is at an address lower than our current + EBP, then we know that it was orphaned when an exception was + thrown from within the execution of a finally block. We clean + it up now, so that we won't leak exception records/objects. + } + CALL CurrentException + OR EAX, EAX + JE @@Done2 + CMP [EAX].TRaisedException.HandlerEBP, EBP + JA @@Done2 + CALL FreeException + OR EAX, EAX + JE @@Done2 + CALL TObject.Free +@@Done2: +{$ENDIF} +{$IFDEF MSWINDOWS} + { -> [ESP+ 4+10*4] excPtr: PExceptionRecord } + { [ESP+ 8+10*4] errPtr: PExcFrame } + + { Pop the RaiseList } + + CALL SysInit.@GetTLS + MOV EDX,[EAX].RaiseListPtr + MOV ECX,[EDX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,ECX + + { Destroy exception object } + + MOV EAX,[EDX].TRaiseFrame.ExceptObject + CALL TObject.Free + + POP EDX + MOV ESP,[ESP+8+9*4] + XOR EAX,EAX + POP ECX + MOV FS:[EAX],ECX + POP EAX + POP EBP + CALL NotifyTerminate + JMP EDX +{$ENDIF} +end; + +{$IFNDEF PC_MAPPED_EXCEPTIONS} +procedure _TryFinallyExit; +asm +{$IFDEF MSWINDOWS} + XOR EDX,EDX + MOV ECX,[ESP+4].TExcFrame.desc + MOV EAX,[ESP+4].TExcFrame.next + ADD ECX,TExcDesc.instructions + MOV FS:[EDX],EAX + CALL ECX +@@1: RET 12 +{$ENDIF} +end; +{$ENDIF} + + +var + InitContext: TInitContext; + +{$IFNDEF PC_MAPPED_EXCEPTIONS} +procedure MapToRunError(P: PExceptionRecord); stdcall; +const + STATUS_ACCESS_VIOLATION = $C0000005; + STATUS_ARRAY_BOUNDS_EXCEEDED = $C000008C; + STATUS_FLOAT_DENORMAL_OPERAND = $C000008D; + STATUS_FLOAT_DIVIDE_BY_ZERO = $C000008E; + STATUS_FLOAT_INEXACT_RESULT = $C000008F; + STATUS_FLOAT_INVALID_OPERATION = $C0000090; + STATUS_FLOAT_OVERFLOW = $C0000091; + STATUS_FLOAT_STACK_CHECK = $C0000092; + STATUS_FLOAT_UNDERFLOW = $C0000093; + STATUS_INTEGER_DIVIDE_BY_ZERO = $C0000094; + STATUS_INTEGER_OVERFLOW = $C0000095; + STATUS_PRIVILEGED_INSTRUCTION = $C0000096; + STATUS_STACK_OVERFLOW = $C00000FD; + STATUS_CONTROL_C_EXIT = $C000013A; +var + ErrCode: Byte; +begin + case P.ExceptionCode of + STATUS_INTEGER_DIVIDE_BY_ZERO: ErrCode := 200; + STATUS_ARRAY_BOUNDS_EXCEEDED: ErrCode := 201; + STATUS_FLOAT_OVERFLOW: ErrCode := 205; + STATUS_FLOAT_INEXACT_RESULT, + STATUS_FLOAT_INVALID_OPERATION, + STATUS_FLOAT_STACK_CHECK: ErrCode := 207; + STATUS_FLOAT_DIVIDE_BY_ZERO: ErrCode := 200; + STATUS_INTEGER_OVERFLOW: ErrCode := 215; + STATUS_FLOAT_UNDERFLOW, + STATUS_FLOAT_DENORMAL_OPERAND: ErrCode := 206; + STATUS_ACCESS_VIOLATION: ErrCode := 216; + STATUS_PRIVILEGED_INSTRUCTION: ErrCode := 218; + STATUS_CONTROL_C_EXIT: ErrCode := 217; + STATUS_STACK_OVERFLOW: ErrCode := 202; + else ErrCode := 255; + end; + RunErrorAt(ErrCode, P.ExceptionAddress); +end; + + +procedure _ExceptionHandler; +asm + MOV EAX,[ESP+4] + + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JNE @@exit +{$IFDEF MSWINDOWS} + CMP BYTE PTR DebugHook,0 + JA @@ExecuteHandler + LEA EAX,[ESP+4] + PUSH EAX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + JNE @@ExecuteHandler + JMP @@exit +{$ENDIF} + +@@ExecuteHandler: + MOV EAX,[ESP+4] + CLD + CALL _FpuInit + MOV EDX,[ESP+8] + + PUSH 0 + PUSH EAX + PUSH offset @@returnAddress + PUSH EDX + CALL RtlUnwindProc + +@@returnAddress: + MOV EBX,[ESP+4] + CMP [EBX].TExceptionRecord.ExceptionCode,cDelphiException + MOV EDX,[EBX].TExceptionRecord.ExceptAddr + MOV EAX,[EBX].TExceptionRecord.ExceptObject + JE @@DelphiException2 + + MOV EDX,ExceptObjProc + TEST EDX,EDX + JE MapToRunError + MOV EAX,EBX + CALL EDX + TEST EAX,EAX + JE MapToRunError + MOV EDX,[EBX].TExceptionRecord.ExceptionAddress + +@@DelphiException2: + + CALL NotifyUnhandled + MOV ECX,ExceptProc + TEST ECX,ECX + JE @@noExceptProc + CALL ECX { call ExceptProc(ExceptObject, ExceptAddr) } + +@@noExceptProc: + MOV ECX,[ESP+4] + MOV EAX,217 + MOV EDX,[ECX].TExceptionRecord.ExceptAddr + MOV [ESP],EDX + JMP _RunError + +@@exit: + XOR EAX,EAX +end; + +procedure SetExceptionHandler; +asm + XOR EDX,EDX { using [EDX] saves some space over [0] } +{X} // now we come here from another place, and EBP is used above for loop counter +{X} // let us restore it... +{X} PUSH EBP +{X} LEA EBP, [ESP + $50] + LEA EAX,[EBP-12] + MOV ECX,FS:[EDX] { ECX := head of chain } + MOV FS:[EDX],EAX { head of chain := @exRegRec } + + MOV [EAX].TExcFrame.next,ECX +{$IFDEF PIC} + LEA EDX, [EBX]._ExceptionHandler + MOV [EAX].TExcFrame.desc, EDX +{$ELSE} + MOV [EAX].TExcFrame.desc,offset _ExceptionHandler +{$ENDIF} + MOV [EAX].TExcFrame.hEBP,EBP +{$IFDEF PIC} + MOV [EBX].InitContext.ExcFrame,EAX +{$ELSE} + MOV InitContext.ExcFrame,EAX +{$ENDIF} + +{X} POP EBP +end; + + +procedure UnsetExceptionHandler; +asm + XOR EDX,EDX +{$IFDEF PIC} + MOV EAX,[EBX].InitContext.ExcFrame +{$ELSE} + MOV EAX,InitContext.ExcFrame +{$ENDIF} + TEST EAX,EAX + JZ @@exit + MOV ECX,FS:[EDX] { ECX := head of chain } + CMP EAX,ECX { simple case: our record is first } + JNE @@search + MOV EAX,[EAX] { head of chain := exRegRec.next } + MOV FS:[EDX],EAX + JMP @@exit + +@@loop: + MOV ECX,[ECX] +@@search: + CMP ECX,-1 { at end of list? } + JE @@exit { yes - didn't find it } + CMP [ECX],EAX { is it the next one on the list? } + JNE @@loop { no - look at next one on list } +@@unlink: { yes - unlink our record } + MOV EAX,[EAX] { get next record on list } + MOV [ECX],EAX { unlink our record } +@@exit: +end; +{$ENDIF} // not PC_MAPPED_EXCEPTIONS + +type + TProc = procedure; + +{$IFDEF LINUX} +procedure CallProc(Proc: Pointer; GOT: Cardinal); +asm + PUSH EBX + MOV EBX,EDX + ADD EAX,EBX + CALL EAX + POP EBX +end; +{$ENDIF} + +(*X- Original version... discarded +procedure FinalizeUnits; +var + Count: Integer; + Table: PUnitEntryTable; + P: Pointer; +begin + if InitContext.InitTable = nil then + exit; + Count := InitContext.InitCount; + Table := InitContext.InitTable^.UnitInfo; +{$IFDEF LINUX} + Inc(Cardinal(Table), InitContext.Module^.GOT); +{$ENDIF} + try + while Count > 0 do + begin + Dec(Count); + InitContext.InitCount := Count; + P := Table^[Count].FInit; + if Assigned(P) then + begin +{$IFDEF LINUX} + CallProc(P, InitContext.Module^.GOT); +{$ENDIF} +{$IFDEF MSWINDOWS} + TProc(P)(); +{$ENDIF} + end; + end; + except + FinalizeUnits; { try to finalize the others } + raise; + end; +end; +X+*) + +{X+ see comments in InitUnits below } +//procedure FInitUnits; {X} - renamed to FInitUnitsHard +{X} procedure FInitUnitsHard; +var + Count: Integer; + Table: PUnitEntryTable; + P: procedure; +begin + if InitContext.InitTable = nil then + exit; + Count := InitContext.InitCount; + Table := InitContext.InitTable^.UnitInfo; +{$IFDEF LINUX} + Inc(Cardinal(Table), InitContext.Module^.GOT); +{$ENDIF} + try + while Count > 0 do + begin + Dec(Count); + InitContext.InitCount := Count; + P := Table^[Count].FInit; + if Assigned(P) then +{$IFDEF LINUX} + CallProc(P, InitContext.Module^.GOT); +{$ENDIF} +{$IFDEF MSWINDOWS} + TProc(P)(); +{$ENDIF} + end; + except + {X- rename: FInitUnits; { try to finalize the others } + FInitUnitsHard; + raise; + end; +end; + +// This handler can be set in initialization section of +// unit SysSfIni.pas only. +procedure InitUnitsHard( Table : PUnitEntryTable; Idx, Count : Integer ); +begin + try + InitUnitsLight( Table, Idx, Count ); + except + FInitUnitsHard; + raise; + end; +end; + +{X+ see comments in InitUnits below } +procedure FInitUnitsLight; +var + Count: Integer; + Table: PUnitEntryTable; + P: procedure; +begin + if InitContext.InitTable = nil then + exit; + Count := InitContext.InitCount; + Table := InitContext.InitTable^.UnitInfo; +{$IFDEF LINUX} + Inc(Cardinal(Table), InitContext.Module^.GOT); +{$ENDIF} + while Count > 0 do + begin + Dec(Count); + InitContext.InitCount := Count; + P := Table^[Count].FInit; + if Assigned(P) then +{$IFDEF LINUX} + CallProc(P, InitContext.Module^.GOT); +{$ENDIF} +{$IFDEF MSWINDOWS} + TProc(P)(); +{$ENDIF} + end; +end; + +{X+ see comments in InitUnits below } +procedure InitUnitsLight( Table : PUnitEntryTable; Idx, Count : Integer ); +var P : procedure; + Light : Boolean; +begin + Light := @InitUnitsProc = @InitUnitsLight; + while Idx < Count do + begin + P := Table^[ Idx ].Init; + Inc( Idx ); + InitContext.InitCount := Idx; + if Assigned( P ) then + P; + if Light and (@InitUnitsProc <> @InitUnitsLight) then + begin + InitUnitsProc( Table, Idx, Count ); + break; + end; + end; +end; + +{X+ see comments in body of InitUnits below } +procedure InitUnits; +var + Count, I: Integer; + Table: PUnitEntryTable; + {X- P: Pointer; } +begin + if InitContext.InitTable = nil then + exit; + Count := InitContext.InitTable^.UnitCount; + I := 0; + Table := InitContext.InitTable^.UnitInfo; +{$IFDEF LINUX} + Inc(Cardinal(Table), InitContext.Module^.GOT); +{$ENDIF} + (*X- by default, Delphi InitUnits uses try-except & raise constructions, + which leads to permanent use of all exception handler routines. + Let us make this by another way. + try + while I < Count do + begin + P := Table^[I].Init; + Inc(I); + InitContext.InitCount := I; + if Assigned(P) then + begin +{$IFDEF LINUX} + CallProc(P, InitContext.Module^.GOT); +{$ENDIF} +{$IFDEF MSWINDOWS} + TProc(P)(); +{$ENDIF} + end; + end; + except + FinalizeUnits; + raise; + end; + X+*) + InitUnitsProc( Table, I, Count ); //{X} +end; + +procedure _PackageLoad(const Table : PackageInfo; Module: PLibModule); +var + SavedContext: TInitContext; +begin + SavedContext := InitContext; + InitContext.DLLInitState := 0; + InitContext.InitTable := Table; + InitContext.InitCount := 0; + InitContext.Module := Module; + InitContext.OuterContext := @SavedContext; + try + InitUnits; + finally + InitContext := SavedContext; + end; +end; + + +procedure _PackageUnload(const Table : PackageInfo; Module: PLibModule); +var + SavedContext: TInitContext; +begin + SavedContext := InitContext; + InitContext.DLLInitState := 0; + InitContext.InitTable := Table; + InitContext.InitCount := Table^.UnitCount; + InitContext.Module := Module; + InitContext.OuterContext := @SavedContext; + try + {X} //FinalizeUnits; + FInitUnitsProc; + finally + InitContext := SavedContext; + end; +end; + +{$IFDEF LINUX} +procedure _StartExe(InitTable: PackageInfo; Module: PLibModule; Argc: Integer; Argv: Pointer); +begin + ArgCount := Argc; + ArgValues := Argv; +{$ENDIF} +{$IFDEF MSWINDOWS} +procedure _StartExe(InitTable: PackageInfo; Module: PLibModule); +begin + RaiseExceptionProc := @RaiseException; + RTLUnwindProc := @RTLUnwind; +{$ENDIF} + InitContext.InitTable := InitTable; + InitContext.InitCount := 0; + InitContext.Module := Module; + MainInstance := Module.Instance; +{$IFNDEF PC_MAPPED_EXCEPTIONS} + + {X SetExceptionHandler; - moved to SysSfIni.pas } + +{$ENDIF} + IsLibrary := False; + InitUnits; +end; + +{$IFDEF MSWINDOWS} +procedure _StartLib; +asm + { -> EAX InitTable } + { EDX Module } + { ECX InitTLS } + { [ESP+4] DllProc } + { [EBP+8] HInst } + { [EBP+12] Reason } + + { Push some desperately needed registers } + + PUSH ECX + PUSH ESI + PUSH EDI + + { Save the current init context into the stackframe of our caller } + + MOV ESI,offset InitContext + LEA EDI,[EBP- (type TExcFrame) - (type TInitContext)] + MOV ECX,(type TInitContext)/4 + REP MOVSD + + { Setup the current InitContext } + + POP InitContext.DLLSaveEDI + POP InitContext.DLLSaveESI + MOV InitContext.DLLSaveEBP,EBP + MOV InitContext.DLLSaveEBX,EBX + MOV InitContext.InitTable,EAX + MOV InitContext.Module,EDX + LEA ECX,[EBP- (type TExcFrame) - (type TInitContext)] + MOV InitContext.OuterContext,ECX + XOR ECX,ECX + CMP dword ptr [EBP+12],0 + JNE @@notShutDown + MOV ECX,[EAX].PackageInfoTable.UnitCount +@@notShutDown: + MOV InitContext.InitCount,ECX + + MOV EAX, offset RaiseException + MOV RaiseExceptionProc, EAX + MOV EAX, offset RTLUnwind + MOV RTLUnwindProc, EAX + + CALL SetExceptionHandler + + MOV EAX,[EBP+12] + INC EAX + MOV InitContext.DLLInitState,AL + DEC EAX + + { Init any needed TLS } + + POP ECX + MOV EDX,[ECX] + MOV InitContext.ExitProcessTLS,EDX + JE @@skipTLSproc + CMP AL,3 // DLL_THREAD_DETACH + JGE @@skipTLSproc // call ExitThreadTLS proc after DLLProc + CALL dword ptr [ECX+EAX*4] +@@skipTLSproc: + + { Call any DllProc } + + PUSH ECX + MOV ECX,[ESP+4] + TEST ECX,ECX + JE @@noDllProc + MOV EAX,[EBP+12] + MOV EDX,[EBP+16] + CALL ECX +@@noDllProc: + + POP ECX + MOV EAX, [EBP+12] + CMP AL,3 // DLL_THREAD_DETACH + JL @@afterDLLproc // don't free TLS on process shutdown + CALL dword ptr [ECX+EAX*4] + +@@afterDLLProc: + + { Set IsLibrary if there was no exe yet } + + CMP MainInstance,0 + JNE @@haveExe + MOV IsLibrary,1 + FNSTCW Default8087CW // save host exe's FPU preferences + +@@haveExe: + + MOV EAX,[EBP+12] + DEC EAX + JNE _Halt0 + CALL InitUnits + RET 4 +end; +{$ENDIF MSWINDOWS} +{$IFDEF LINUX} +procedure _StartLib(Context: PInitContext; Module: PLibModule; DLLProc: TDLLProcEx); +var + TempSwap: TInitContext; +begin + // Context's register save fields are already initialized. + // Save the current InitContext and activate the new Context by swapping them + TempSwap := InitContext; + InitContext := PInitContext(Context)^; + PInitContext(Context)^ := TempSwap; + + InitContext.Module := Module; + InitContext.OuterContext := Context; + + // DLLInitState is initialized by SysInit to 0 for shutdown, 1 for startup + // Inc DLLInitState to distinguish from package init: + // 0 for package, 1 for DLL shutdown, 2 for DLL startup + + Inc(InitContext.DLLInitState); + + if InitContext.DLLInitState = 1 then + begin + InitContext.InitTable := Module.InitTable; + if Assigned(InitContext.InitTable) then + InitContext.InitCount := InitContext.InitTable.UnitCount // shutdown + end + else + begin + Module.InitTable := InitContext.InitTable; // save for shutdown + InitContext.InitCount := 0; // startup + end; + + if Assigned(DLLProc) then + DLLProc(InitContext.DLLInitState-1,0); + + if MainInstance = 0 then { Set IsLibrary if there was no exe yet } + begin + IsLibrary := True; + Default8087CW := Get8087CW; + end; + + if InitContext.DLLInitState = 1 then + _Halt0 + else + InitUnits; +end; +{$ENDIF} + +procedure _InitResStrings; +asm + { -> EAX Pointer to init table } + { record } + { cnt: Integer; } + { tab: array [1..cnt] record } + { variableAddress: Pointer; } + { resStringAddress: Pointer; } + { end; } + { end; } + { EBX = caller's GOT for PIC callers, 0 for non-PIC } + +{$IFDEF MSWINDOWS} + PUSH EBX + XOR EBX,EBX +{$ENDIF} + PUSH EDI + PUSH ESI + MOV EDI,[EBX+EAX] + LEA ESI,[EBX+EAX+4] +@@loop: + MOV EAX,[ESI+4] { load resStringAddress } + MOV EDX,[ESI] { load variableAddress } + ADD EAX,EBX + ADD EDX,EBX + CALL LoadResString + ADD ESI,8 + DEC EDI + JNZ @@loop + + POP ESI + POP EDI +{$IFDEF MSWINDOWS} + POP EBX +{$ENDIF} +end; + +procedure _InitResStringImports; +asm + { -> EAX Pointer to init table } + { record } + { cnt: Integer; } + { tab: array [1..cnt] record } + { variableAddress: Pointer; } + { resStringAddress: ^Pointer; } + { end; } + { end; } + { EBX = caller's GOT for PIC callers, 0 for non-PIC } + +{$IFDEF MSWINDOWS} + PUSH EBX + XOR EBX,EBX +{$ENDIF} + PUSH EDI + PUSH ESI + MOV EDI,[EBX+EAX] + LEA ESI,[EBX+EAX+4] +@@loop: + MOV EAX,[ESI+4] { load address of import } + MOV EDX,[ESI] { load address of variable } + MOV EAX,[EBX+EAX] { load contents of import } + ADD EDX,EBX + CALL LoadResString + ADD ESI,8 + DEC EDI + JNZ @@loop + + POP ESI + POP EDI +{$IFDEF MSWINDOWS} + POP EBX +{$ENDIF} +end; + +procedure _InitImports; +asm + { -> EAX Pointer to init table } + { record } + { cnt: Integer; } + { tab: array [1..cnt] record } + { variableAddress: Pointer; } + { sourceAddress: ^Pointer; } + { sourceOffset: Longint; } + { end; } + { end; } + { EBX = caller's GOT for PIC callers, 0 for non-PIC } + +{$IFDEF MSWINDOWS} + PUSH EBX + XOR EBX,EBX +{$ENDIF} + PUSH EDI + PUSH ESI + MOV EDI,[EBX+EAX] + LEA ESI,[EBX+EAX+4] +@@loop: + MOV EAX,[ESI+4] { load address of import } + MOV EDX,[ESI] { load address of variable } + MOV EAX,[EBX+EAX] { load contents of import } + ADD EAX,[ESI+8] { calc address of variable } + MOV [EBX+EDX],EAX { store result } + ADD ESI,12 + DEC EDI + JNZ @@loop + + POP ESI + POP EDI +{$IFDEF MSWINDOWS} + POP EBX +{$ENDIF} +end; + +{$IFDEF MSWINDOWS} +procedure _InitWideStrings; +asm + { -> EAX Pointer to init table } + { record } + { cnt: Integer; } + { tab: array [1..cnt] record } + { variableAddress: Pointer; } + { stringAddress: ^Pointer; } + { end; } + { end; } + + PUSH EBX + PUSH ESI + MOV EBX,[EAX] + LEA ESI,[EAX+4] +@@loop: + MOV EDX,[ESI+4] { load address of string } + MOV EAX,[ESI] { load address of variable } + CALL _WStrAsg + ADD ESI,8 + DEC EBX + JNZ @@loop + + POP ESI + POP EBX +end; +{$ENDIF} + +var + runErrMsg: array[0..29] of Char = 'Runtime error at 00000000'#0; + // columns: 0123456789012345678901234567890 + errCaption: array[0..5] of Char = 'Error'#0; + + +procedure MakeErrorMessage; +const + dig : array [0..15] of Char = '0123456789ABCDEF'; +var + digit: Byte; + Temp: Integer; + Addr: Cardinal; +begin + digit := 16; + Temp := ExitCode; + repeat + runErrMsg[digit] := Char(Ord('0') + (Temp mod 10)); + Temp := Temp div 10; + Dec(digit); + until Temp = 0; + digit := 28; + Addr := Cardinal(ErrorAddr); + repeat + runErrMsg[digit] := dig[Addr and $F]; + Addr := Addr div 16; + Dec(digit); + until Addr = 0; +end; + + +procedure ExitDll; +asm + { Return False if ExitCode <> 0, and set ExitCode to 0 } + + XOR EAX,EAX +{$IFDEF PIC} + MOV ECX,[EBX].ExitCode + XCHG EAX,[ECX] +{$ELSE} + XCHG EAX, ExitCode +{$ENDIF} + NEG EAX + SBB EAX,EAX + INC EAX + + { Restore the InitContext } +{$IFDEF PIC} + LEA EDI, [EBX].InitContext +{$ELSE} + MOV EDI, offset InitContext +{$ENDIF} + + MOV EBX,[EDI].TInitContext.DLLSaveEBX + MOV EBP,[EDI].TInitContext.DLLSaveEBP + PUSH [EDI].TInitContext.DLLSaveESI + PUSH [EDI].TInitContext.DLLSaveEDI + + MOV ESI,[EDI].TInitContext.OuterContext + MOV ECX,(type TInitContext)/4 + REP MOVSD + POP EDI + POP ESI + + LEAVE +{$IFDEF MSWINDOWS} + RET 12 +{$ENDIF} +{$IFDEF LINUX} + RET +{$ENDIF} +end; + +// {X} Procedure Halt0 refers to WriteLn and MessageBox +// but actually such code can be not used really. +// So, implementation changed to avoid such references. +// +// Either call UseErrorMessageBox or UseErrorMessageWrite +// to provide error message output in GUI or console app. +// {X}+ + +var ErrorMessageOutProc : procedure = DummyProc; + +procedure ErrorMessageBox; +begin + MakeErrorMessage; + if not NoErrMsg then + MessageBox(0, runErrMsg, errCaption, 0); +end; + +procedure UseErrorMessageBox; +begin + ErrorMessageOutProc := ErrorMessageBox; +end; + +procedure ErrorMessageWrite; +begin + MakeErrorMessage; + WriteLn(PChar(@runErrMsg)); +end; + +procedure UseErrorMessageWrite; +begin + ErrorMessageOutProc := ErrorMessageWrite; +end; + +procedure DoCloseInputOutput; +begin + Close( Input ); + Close( Output ); + Close(ErrOutput); +end; + +var CloseInputOutput : procedure = DummyProc; + +procedure UseInputOutput; +begin + if not assigned( CloseInputOutput ) then + begin + CloseInputOutput := DoCloseInputOutput; + //_Assign( Input, '' ); was for D5 so - changed + //_Assign( Output, '' ); was for D5 so - changed + TTextRec(Input).Mode := fmClosed; + TTextRec(Output).Mode := fmClosed; + TTextRec(ErrOutput).Mode := fmClosed; + end; +end; + +// {X}- +(*X- +procedure WriteErrorMessage; +{$IFDEF MSWINDOWS} +var + Dummy: Cardinal; +begin + if IsConsole then + begin + with TTextRec(Output) do + begin + if (Mode = fmOutput) and (BufPos > 0) then + TTextIOFunc(InOutFunc)(TTextRec(Output)); // flush out text buffer + end; + WriteFile(GetStdHandle(STD_OUTPUT_HANDLE), runErrMsg, Sizeof(runErrMsg), Dummy, nil); + WriteFile(GetStdHandle(STD_OUTPUT_HANDLE), sLineBreak, 2, Dummy, nil); + end + else if not NoErrMsg then + MessageBox(0, runErrMsg, errCaption, 0); +{$ENDIF} +{$IFDEF LINUX} +var + c: Char; +begin + with TTextRec(Output) do + begin + if (Mode = fmOutput) and (BufPos > 0) then + TTextIOFunc(InOutFunc)(TTextRec(Output)); // flush out text buffer + end; + __write(STDERR_FILENO, @runErrMsg, Sizeof(runErrMsg)-1); + c := sLineBreak; + __write(STDERR_FILENO, @c, 1); +{$ENDIF} +end; +X+*) + +procedure _Halt0; +var + P: procedure; +begin +{$IFDEF LINUX} + if (ExitCode <> 0) and CoreDumpEnabled then + __raise(SIGABRT); +{$ENDIF} + + if InitContext.DLLInitState = 0 then + while ExitProc <> nil do + begin + @P := ExitProc; + ExitProc := nil; + P; + end; + + { If there was some kind of runtime error, alert the user } + + if ErrorAddr <> nil then + begin + {X+} + ErrorMessageOutProc; + { + MakeErrorMessage; + if IsConsole then + WriteLn(PChar(@runErrMsg)) + else if not NoErrMsg then + MessageBox(0, runErrMsg, errCaption, 0); + } {X-} + + {X- As it is said by Alexey Torgashin, it is better not to clear ErrorAddr + to make possible check ErrorAddr <> nil in finalization of rest units. + If you want, you can uncomment it again: } + //ErrorAddr := nil; + {X+} + end; + + { This loop exists because we might be nested in PackageLoad calls when } + { Halt got called. We need to unwind these contexts. } + + while True do + begin + + { If we are a library, and we are starting up fine, there are no units to finalize } + + if (InitContext.DLLInitState = 2) and (ExitCode = 0) then + InitContext.InitCount := 0; + + { Undo any unit initializations accomplished so far } + + // {X} FinalizeUnits; -- renamed + FInitUnitsProc; + + if (InitContext.DLLInitState <= 1) or (ExitCode <> 0) then + begin + if InitContext.Module <> nil then + with InitContext do + begin + UnregisterModule(Module); +{$IFDEF PC_MAPPED_EXCEPTIONS} + SysUnregisterIPLookup(Module.CodeSegStart); +{$ENDIF} + if (Module.ResInstance <> Module.Instance) and (Module.ResInstance <> 0) then + FreeLibrary(Module.ResInstance); + end; + end; + +{$IFNDEF PC_MAPPED_EXCEPTIONS} + {X UnsetExceptionHandler; - changed to call of handler } + UnsetExceptionHandlerProc; +{$ENDIF} + +{$IFDEF MSWINDOWS} + if InitContext.DllInitState = 1 then + InitContext.ExitProcessTLS; +{$ENDIF} + + if InitContext.DllInitState <> 0 then + ExitDll; + + if InitContext.OuterContext = nil then + begin + { + If an ExitProcessProc is set, we call it. Note that at this + point the RTL is completely shutdown. The only thing this is used + for right now is the proper semantic handling of signals under Linux. + } + if Assigned(ExitProcessProc) then + ExitProcessProc; + ExitProcess(ExitCode); + end; + + InitContext := InitContext.OuterContext^ + end; +end; + +procedure _Halt; +begin + ExitCode := Code; + _Halt0; +end; + + +procedure _Run0Error; +{$IFDEF PUREPASCAL} +begin + _RunError(0); // loses return address +end; +{$ELSE} +asm + XOR EAX,EAX + JMP _RunError +end; +{$ENDIF} + + +procedure _RunError(errorCode: Byte); +{$IFDEF PUREPASCAL} +begin + ErrorAddr := Pointer(-1); // no return address available + Halt(errorCode); +end; +{$ELSE} +asm +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX, EAX + POP EAX + MOV ECX, [EBX].ErrorAddr + POP [ECX] +{$ELSE} + POP ErrorAddr +{$ENDIF} + JMP _Halt +end; +{$ENDIF} + +procedure _UnhandledException; +type TExceptProc = procedure (Obj: TObject; Addr: Pointer); +begin + if Assigned(ExceptProc) then + TExceptProc(ExceptProc)(ExceptObject, ExceptAddr) + else + RunError(230); +end; + +procedure _Assert(const Message, Filename: AnsiString; LineNumber: Integer); +{$IFDEF PUREPASCAL} +begin + if Assigned(AssertErrorProc) then + AssertErrorProc(Message, Filename, LineNumber, Pointer(-1)) + else + Error(reAssertionFailed); // loses return address +end; +{$ELSE} +asm + PUSH EBX +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + MOV EBX, EAX + MOV EAX, [EBX].AssertErrorProc + CMP [EAX], 0 + POP ECX + POP EAX +{$ELSE} + CMP AssertErrorProc,0 +{$ENDIF} + JNZ @@1 + MOV AL,reAssertionFailed + CALL Error + JMP @@exit + +@@1: PUSH [ESP+4].Pointer +{$IFDEF PIC} + MOV EBX, [EBX].AssertErrorProc + CALL [EBX] +{$ELSE} + CALL AssertErrorProc +{$ENDIF} +@@exit: + POP EBX +end; +{$ENDIF} + +type + PThreadRec = ^TThreadRec; + TThreadRec = record + Func: TThreadFunc; + Parameter: Pointer; + end; + +{$IFDEF MSWINDOWS} +function ThreadWrapper(Parameter: Pointer): Integer; stdcall; +{$ELSE} +function ThreadWrapper(Parameter: Pointer): Pointer; cdecl; +{$ENDIF} +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + { Mark the top of the stack with a signature } + PUSH UNWINDFI_TOPOFSTACK +{$ENDIF} + CALL _FpuInit + PUSH EBP +{$IFNDEF PC_MAPPED_EXCEPTIONS} + XOR ECX,ECX + PUSH offset _ExceptionHandler + MOV EDX,FS:[ECX] + PUSH EDX + MOV FS:[ECX],ESP +{$ENDIF} + MOV EAX,Parameter + + MOV ECX,[EAX].TThreadRec.Parameter + MOV EDX,[EAX].TThreadRec.Func + PUSH ECX + PUSH EDX + CALL _FreeMem + POP EDX + POP EAX + CALL EDX + +{$IFNDEF PC_MAPPED_EXCEPTIONS} + XOR EDX,EDX + POP ECX + MOV FS:[EDX],ECX + POP ECX +{$ENDIF} + POP EBP +{$IFDEF PC_MAPPED_EXCEPTIONS} + { Ditch our TOS marker } + ADD ESP, 4 +{$ENDIF} +end; + + +{$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} + +{$IFDEF LINUX} +function BeginThread(Attribute: PThreadAttr; + ThreadFunc: TThreadFunc; + Parameter: Pointer; + var ThreadId: Cardinal): Integer; +var + P: PThreadRec; +begin + if Assigned(BeginThreadProc) then + Result := BeginThreadProc(Attribute, ThreadFunc, Parameter, ThreadId) + else + begin + New(P); + P.Func := ThreadFunc; + P.Parameter := Parameter; + IsMultiThread := True; + Result := _pthread_create(ThreadID, Attribute, @ThreadWrapper, P); + end; +end; + +procedure EndThread(ExitCode: Integer); +begin + if Assigned(EndThreadProc) then + EndThreadProc(ExitCode); + // No "else" required since EndThreadProc does not (!!should not!!) return. + _pthread_detach(GetCurrentThreadID); + _pthread_exit(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); +{$IFDEF PUREPASCAL} +var + P: PStrRec; +begin + if Pointer(S) <> nil then + begin + P := Pointer(Integer(S) - Sizeof(StrRec)); + Pointer(S) := nil; + if P.refCnt > 0 then + if InterlockedDecrement(P.refCnt) = 0 then + FreeMem(P); + end; +end; +{$ELSE} +asm + { -> EAX pointer to str } + + MOV EDX,[EAX] { fetch str } + TEST EDX,EDX { if nil, nothing to do } + JE @@done + MOV dword ptr [EAX],0 { clear str } + MOV ECX,[EDX-skew].StrRec.refCnt { fetch refCnt } + DEC ECX { if < 0: literal str } + JL @@done +{X LOCK} DEC [EDX-skew].StrRec.refCnt { NONthreadsafe dec refCount } + JNE @@done + PUSH EAX + LEA EAX,[EDX-skew].StrRec.refCnt { if refCnt now zero, deallocate} + CALL _FreeMem + POP EAX +@@done: +end; +{$ENDIF} + +procedure _LStrArrayClr(var StrArray; cnt: longint); +{$IFDEF PUREPASCAL} +var + P: Pointer; +begin + P := @StrArray; + while cnt > 0 do + begin + _LStrClr(P^); + Dec(cnt); + Inc(Integer(P), sizeof(Pointer)); + end; +end; +{$ELSE} +asm + { -> EAX pointer to str } + { EDX cnt } + + PUSH EBX + PUSH ESI + MOV EBX,EAX + MOV ESI,EDX + +@@loop: + MOV EDX,[EBX] { fetch str } + TEST EDX,EDX { if nil, nothing to do } + JE @@doneEntry + MOV dword ptr [EBX],0 { clear str } + MOV ECX,[EDX-skew].StrRec.refCnt { fetch refCnt } + DEC ECX { if < 0: literal str } + JL @@doneEntry +{X LOCK} DEC [EDX-skew].StrRec.refCnt { NONthreadsafe dec refCount } + JNE @@doneEntry + LEA EAX,[EDX-skew].StrRec.refCnt { if refCnt now zero, deallocate} + CALL _FreeMem +@@doneEntry: + ADD EBX,4 + DEC ESI + JNE @@loop + + POP ESI + POP EBX +end; +{$ENDIF} + +{ 99.03.11 + This function is used when assigning to global variables. + + Literals are copied to prevent a situation where a dynamically + allocated DLL or package assigns a literal to a variable and then + is unloaded -- thereby causing the string memory (in the code + segment of the DLL) to be removed -- and therefore leaving the + global variable pointing to invalid memory. +} +procedure _LStrAsg(var dest; const source); +{$IFDEF PUREPASCAL} +var + S, D: Pointer; + P: PStrRec; + Temp: Longint; +begin + S := Pointer(source); + if S <> nil then + begin + P := PStrRec(Integer(S) - sizeof(StrRec)); + if P.refCnt < 0 then // make copy of string literal + begin + Temp := P.length; + S := _NewAnsiString(Temp); + Move(Pointer(source)^, S^, Temp); + P := PStrRec(Integer(S) - sizeof(StrRec)); + end; + InterlockedIncrement(P.refCnt); + end; + + D := Pointer(dest); + Pointer(dest) := S; + if D <> nil then + begin + P := PStrRec(Integer(D) - sizeof(StrRec)); + if P.refCnt > 0 then + if InterlockedDecrement(P.refCnt) = 0 then + FreeMem(P); + end; +end; +{$ELSE} +asm + { -> EAX pointer to dest str } + { -> EDX pointer to source str } + + TEST EDX,EDX { have a source? } + JE @@2 { no -> jump } + + MOV ECX,[EDX-skew].StrRec.refCnt + INC ECX + JG @@1 { literal string -> jump not taken } + + PUSH EAX + PUSH EDX + MOV EAX,[EDX-skew].StrRec.length + CALL _NewAnsiString + MOV EDX,EAX + POP EAX + PUSH EDX + MOV ECX,[EAX-skew].StrRec.length + CALL Move + POP EDX + POP EAX + JMP @@2 + +@@1: + {X LOCK} INC [EDX-skew].StrRec.refCnt + +@@2: XCHG EDX,[EAX] + TEST EDX,EDX + JE @@3 + MOV ECX,[EDX-skew].StrRec.refCnt + DEC ECX + JL @@3 + {X LOCK} DEC [EDX-skew].StrRec.refCnt + JNE @@3 + LEA EAX,[EDX-skew].StrRec.refCnt + CALL _FreeMem +@@3: +end; +{$ENDIF} + +procedure _LStrLAsg(var dest; const source); +{$IFDEF PUREPASCAL} +var + P: Pointer; +begin + P := Pointer(source); + _LStrAddRef(P); + P := Pointer(dest); + Pointer(dest) := Pointer(source); + _LStrClr(P); +end; +{$ELSE} +asm +{ -> EAX pointer to dest } +{ EDX source } + + TEST EDX,EDX + JE @@sourceDone + + { bump up the ref count of the source } + + MOV ECX,[EDX-skew].StrRec.refCnt + INC ECX + JLE @@sourceDone { literal assignment -> jump taken } + {X LOCK} INC [EDX-skew].StrRec.refCnt +@@sourceDone: + + { we need to release whatever the dest is pointing to } + + XCHG EDX,[EAX] { fetch str } + TEST EDX,EDX { if nil, nothing to do } + JE @@done + MOV ECX,[EDX-skew].StrRec.refCnt { fetch refCnt } + DEC ECX { if < 0: literal str } + JL @@done + {X LOCK} DEC [EDX-skew].StrRec.refCnt { NONthreadsafe dec refCount } + JNE @@done + LEA EAX,[EDX-skew].StrRec.refCnt { if refCnt now zero, deallocate} + CALL _FreeMem +@@done: +end; +{$ENDIF} + +function _NewAnsiString(length: Longint): Pointer; +{$IFDEF PUREPASCAL} +var + P: PStrRec; +begin + Result := nil; + if length <= 0 then Exit; + // Alloc an extra null for strings with even length. This has no actual cost + // since the allocator will round up the request to an even size anyway. + // All widestring allocations have even length, and need a double null terminator. + GetMem(P, length + sizeof(StrRec) + 1 + ((length + 1) and 1)); + Result := Pointer(Integer(P) + sizeof(StrRec)); + P.length := length; + P.refcnt := 1; + PWideChar(Result)[length div 2] := #0; // length guaranteed >= 2 +end; +{$ELSE} +asm + { -> EAX length } + { <- EAX pointer to new string } + + TEST EAX,EAX + JLE @@null + PUSH EAX + ADD EAX,rOff+2 // one or two nulls (Ansi/Wide) + AND EAX, not 1 // round up to even length + PUSH EAX + CALL _GetMem + POP EDX // actual allocated length (>= 2) + MOV word ptr [EAX+EDX-2],0 // double null terminator + ADD EAX,rOff + POP EDX // requested string length + MOV [EAX-skew].StrRec.length,EDX + MOV [EAX-skew].StrRec.refCnt,1 + RET +@@null: + XOR EAX,EAX +end; +{$ENDIF} + +procedure _LStrFromPCharLen(var Dest: AnsiString; Source: PAnsiChar; Length: Integer); +asm + { -> EAX pointer to dest } + { EDX source } + { ECX length } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + { allocate new string } + + MOV EAX,EDI + + CALL _NewAnsiString + MOV ECX,EDI + MOV EDI,EAX + + TEST ESI,ESI + JE @@noMove + + MOV EDX,EAX + MOV EAX,ESI + CALL Move + + { assign the result to dest } + +@@noMove: + MOV EAX,EBX + CALL _LStrClr + MOV [EBX],EDI + + POP EDI + POP ESI + POP EBX +end; + + +{$IFDEF LINUX} +function BufConvert(var Dest; DestBytes: Integer; + const Source; SrcBytes: Integer; + context: Integer): Integer; +var + SrcBytesLeft, DestBytesLeft: Integer; + s, d: Pointer; +begin + if context = -1 then + begin + Result := -1; + Exit; + end; + // make copies of params... iconv modifies param ptrs + DestBytesLeft := DestBytes; + SrcBytesLeft := SrcBytes; + s := Pointer(Source); + d := Pointer(Dest); + if (SrcBytes = 0) or (DestBytes = 0) then + Result := 0 + else + begin + Result := iconv(context, s, SrcBytesLeft, d, DestBytesLeft); + while (SrcBytesLeft > 0) and (DestBytesLeft > 0) + and (Result = -1) and (GetLastError = 7) do + begin + Result := iconv(context, s, SrcBytesLeft, d, DestBytesLeft); + end; + + if Result <> -1 then + Result := DestBytes - DestBytesLeft; + end; + + iconv_close(context); +end; +{$ENDIF} + + +function CharFromWChar(CharDest: PChar; DestBytes: Integer; const WCharSource: PWideChar; SrcChars: Integer): Integer; +begin +{$IFDEF LINUX} + Result := BufConvert(CharDest, DestBytes, WCharSource, SrcChars * sizeof(WideChar), + iconv_open(nl_langinfo(_NL_CTYPE_CODESET_NAME), 'UNICODELITTLE')); +{$ENDIF} +{$IFDEF MSWINDOWS} + Result := WideCharToMultiByte(0, 0, WCharSource, SrcChars, + CharDest, DestBytes, nil, nil); +{$ENDIF} +end; + + +function WCharFromChar(WCharDest: PWideChar; DestChars: Integer; const CharSource: PChar; SrcBytes: Integer): Integer; +begin +{$IFDEF LINUX} + Result := BufConvert(WCharDest, DestChars * sizeof(WideChar), CharSource, SrcBytes, + iconv_open('UNICODELITTLE', nl_langinfo(_NL_CTYPE_CODESET_NAME))) div sizeof(WideChar); +{$ENDIF} +{$IFDEF MSWINDOWS} + Result := MultiByteToWideChar(0, 0, CharSource, SrcBytes, + WCharDest, DestChars); +{$ENDIF} +end; + + +procedure _LStrFromPWCharLen(var Dest: AnsiString; Source: PWideChar; Length: Integer); +var + DestLen: Integer; + Buffer: array[0..4095] of Char; +begin + if Length <= 0 then + begin + _LStrClr(Dest); + Exit; + end; + if Length+1 < (High(Buffer) div sizeof(WideChar)) then + begin + DestLen := CharFromWChar(Buffer, High(Buffer), Source, Length); + if DestLen >= 0 then + begin + _LStrFromPCharLen(Dest, Buffer, DestLen); + Exit; + end; + end; + + DestLen := (Length + 1) * sizeof(WideChar); + SetLength(Dest, DestLen); // overallocate, trim later + DestLen := CharFromWChar(Pointer(Dest), DestLen, Source, Length); + if DestLen < 0 then DestLen := 0; + SetLength(Dest, DestLen); +end; + + +procedure _LStrFromChar(var Dest: AnsiString; Source: AnsiChar); +asm + PUSH EDX + MOV EDX,ESP + MOV ECX,1 + CALL _LStrFromPCharLen + POP EDX +end; + + +procedure _LStrFromWChar(var Dest: AnsiString; Source: WideChar); +asm + PUSH EDX + MOV EDX,ESP + MOV ECX,1 + CALL _LStrFromPWCharLen + POP EDX +end; + + +procedure _LStrFromPChar(var Dest: AnsiString; Source: PAnsiChar); +asm + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CL,[EDX+0] + JE @@4 + CMP CL,[EDX+1] + JE @@3 + CMP CL,[EDX+2] + JE @@2 + CMP CL,[EDX+3] + JE @@1 + ADD EDX,4 + JMP @@0 +@@1: INC EDX +@@2: INC EDX +@@3: INC EDX +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX +@@5: JMP _LStrFromPCharLen +end; + + +procedure _LStrFromPWChar(var Dest: AnsiString; Source: PWideChar); +asm + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CX,[EDX+0] + JE @@4 + CMP CX,[EDX+2] + JE @@3 + CMP CX,[EDX+4] + JE @@2 + CMP CX,[EDX+6] + JE @@1 + ADD EDX,8 + JMP @@0 +@@1: ADD EDX,2 +@@2: ADD EDX,2 +@@3: ADD EDX,2 +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX + SHR ECX,1 +@@5: JMP _LStrFromPWCharLen +end; + + +procedure _LStrFromString(var Dest: AnsiString; const Source: ShortString); +asm + XOR ECX,ECX + MOV CL,[EDX] + INC EDX + JMP _LStrFromPCharLen +end; + + +procedure _LStrFromArray(var Dest: AnsiString; Source: PAnsiChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASB + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _LStrFromPCharLen +end; + + +procedure _LStrFromWArray(var Dest: AnsiString; Source: PWideChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASW + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _LStrFromPWCharLen +end; + + +procedure _LStrFromWStr(var Dest: AnsiString; const Source: WideString); +asm + { -> EAX pointer to dest } + { EDX pointer to WideString data } + + XOR ECX,ECX + TEST EDX,EDX + JE @@1 + MOV ECX,[EDX-4] + SHR ECX,1 +@@1: JMP _LStrFromPWCharLen +end; + + +procedure _LStrToString{(var Dest: ShortString; const Source: AnsiString; MaxLen: Integer)}; +asm + { -> EAX pointer to result } + { EDX AnsiString s } + { ECX length of result } + + PUSH EBX + TEST EDX,EDX + JE @@empty + MOV EBX,[EDX-skew].StrRec.length + TEST EBX,EBX + JE @@empty + + CMP ECX,EBX + JL @@truncate + MOV ECX,EBX +@@truncate: + MOV [EAX],CL + INC EAX + + XCHG EAX,EDX + CALL Move + + JMP @@exit + +@@empty: + MOV byte ptr [EAX],0 + +@@exit: + POP EBX +end; + +function _LStrLen(const s: AnsiString): Longint; +{$IFDEF PUREPASCAL} +begin + Result := 0; + if Pointer(s) <> nil then + Result := PStrRec(Integer(s) - sizeof(StrRec)).length; +end; +{$ELSE} +asm + { -> EAX str } + + TEST EAX,EAX + JE @@done + MOV EAX,[EAX-skew].StrRec.length; +@@done: +end; +{$ENDIF} + + +procedure _LStrCat{var dest: AnsiString; source: AnsiString}; +asm + { -> EAX pointer to dest } + { EDX source } + + TEST EDX,EDX + JE @@exit + + MOV ECX,[EAX] + TEST ECX,ECX + JE _LStrAsg + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,[ECX-skew].StrRec.length + + MOV EDX,[ESI-skew].StrRec.length + ADD EDX,EDI + CMP ESI,ECX + JE @@appendSelf + + CALL _LStrSetLength + MOV EAX,ESI + MOV ECX,[ESI-skew].StrRec.length + +@@appendStr: + MOV EDX,[EBX] + ADD EDX,EDI + CALL Move + POP EDI + POP ESI + POP EBX + RET + +@@appendSelf: + CALL _LStrSetLength + MOV EAX,[EBX] + MOV ECX,EDI + JMP @@appendStr + +@@exit: +end; + + +procedure _LStrCat3{var dest:AnsiString; source1: AnsiString; source2: AnsiString}; +asm + { ->EAX = Pointer to dest } + { EDX = source1 } + { ECX = source2 } + + TEST EDX,EDX + JE @@assignSource2 + + TEST ECX,ECX + JE _LStrAsg + + CMP EDX,[EAX] + JE @@appendToDest + + CMP ECX,[EAX] + JE @@theHardWay + + PUSH EAX + PUSH ECX + CALL _LStrAsg + + POP EDX + POP EAX + JMP _LStrCat + +@@theHardWay: + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EDX + MOV ESI,ECX + PUSH EAX + + MOV EAX,[EBX-skew].StrRec.length + ADD EAX,[ESI-skew].StrRec.length + CALL _NewAnsiString + + MOV EDI,EAX + MOV EDX,EAX + MOV EAX,EBX + MOV ECX,[EBX-skew].StrRec.length + CALL Move + + MOV EDX,EDI + MOV EAX,ESI + MOV ECX,[ESI-skew].StrRec.length + ADD EDX,[EBX-skew].StrRec.length + CALL Move + + POP EAX + MOV EDX,EDI + TEST EDI,EDI + JE @@skip + DEC [EDI-skew].StrRec.refCnt // EDI = local temp str +@@skip: + CALL _LStrAsg + + POP EDI + POP ESI + POP EBX + + JMP @@exit + +@@assignSource2: + MOV EDX,ECX + JMP _LStrAsg + +@@appendToDest: + MOV EDX,ECX + JMP _LStrCat + +@@exit: +end; + + +procedure _LStrCatN{var dest:AnsiString; argCnt: Integer; ...}; +asm + { ->EAX = Pointer to dest } + { EDX = number of args (>= 3) } + { [ESP+4], [ESP+8], ... crgCnt AnsiString arguments, reverse order } + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EDX + PUSH EAX + MOV EBX,EDX + + XOR EDI,EDI + MOV ECX,[ESP+EDX*4+5*4] // first arg is furthest out + TEST ECX,ECX + JZ @@0 + CMP [EAX],ECX // is dest = first arg? + JNE @@0 + MOV EDI,EAX // EDI nonzero -> potential appendstr case +@@0: + XOR EAX,EAX +@@loop1: + MOV ECX,[ESP+EDX*4+5*4] + TEST ECX,ECX + JE @@1 + ADD EAX,[ECX-skew].StrRec.length + CMP EDI,ECX // is dest an arg besides arg1? + JNE @@1 + XOR EDI,EDI // can't appendstr - dest is multiple args +@@1: + DEC EDX + JNE @@loop1 + +@@append: + TEST EDI,EDI // dest is 1st and only 1st arg? + JZ @@copy + MOV EDX,EAX // length into EDX + MOV EAX,EDI // ptr to str into EAX + MOV ESI,[EDI] + MOV ESI,[ESI-skew].StrRec.Length // save old size before realloc + CALL _LStrSetLength + PUSH EDI // append other strs to dest + ADD ESI,[EDI] // end of old string + DEC EBX + JMP @@loop2 + +@@copy: + CALL _NewAnsiString + PUSH EAX + MOV ESI,EAX + +@@loop2: + MOV EAX,[ESP+EBX*4+6*4] + MOV EDX,ESI + TEST EAX,EAX + JE @@2 + MOV ECX,[EAX-skew].StrRec.length + ADD ESI,ECX + CALL Move +@@2: + DEC EBX + JNE @@loop2 + + POP EDX + POP EAX + TEST EDI,EDI + JNZ @@exit + + TEST EDX,EDX + JE @@skip + DEC [EDX-skew].StrRec.refCnt // EDX = local temp str +@@skip: + CALL _LStrAsg + +@@exit: + POP EDX + POP EDI + POP ESI + POP EBX + POP EAX + LEA ESP,[ESP+EDX*4] + JMP EAX +end; + + +procedure _LStrCmp{left: AnsiString; right: AnsiString}; +asm +{ ->EAX = Pointer to left string } +{ EDX = Pointer to right string } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + CMP EAX,EDX + JE @@exit + + TEST ESI,ESI + JE @@str1null + + TEST EDI,EDI + JE @@str2null + + MOV EAX,[ESI-skew].StrRec.length + MOV EDX,[EDI-skew].StrRec.length + + SUB EAX,EDX { eax = len1 - len2 } + JA @@skip1 + ADD EDX,EAX { edx = len2 + (len1 - len2) = len1 } + +@@skip1: + PUSH EDX + SHR EDX,2 + JE @@cmpRest +@@longLoop: + MOV ECX,[ESI] + MOV EBX,[EDI] + CMP ECX,EBX + JNE @@misMatch + DEC EDX + JE @@cmpRestP4 + MOV ECX,[ESI+4] + MOV EBX,[EDI+4] + CMP ECX,EBX + JNE @@misMatch + ADD ESI,8 + ADD EDI,8 + DEC EDX + JNE @@longLoop + JMP @@cmpRest +@@cmpRestP4: + ADD ESI,4 + ADD EDI,4 +@@cmpRest: + POP EDX + AND EDX,3 + JE @@equal + + MOV ECX,[ESI] + MOV EBX,[EDI] + CMP CL,BL + JNE @@exit + DEC EDX + JE @@equal + CMP CH,BH + JNE @@exit + DEC EDX + JE @@equal + AND EBX,$00FF0000 + AND ECX,$00FF0000 + CMP ECX,EBX + JNE @@exit + +@@equal: + ADD EAX,EAX + JMP @@exit + +@@str1null: + MOV EDX,[EDI-skew].StrRec.length + SUB EAX,EDX + JMP @@exit + +@@str2null: + MOV EAX,[ESI-skew].StrRec.length + SUB EAX,EDX + JMP @@exit + +@@misMatch: + POP EDX + CMP CL,BL + JNE @@exit + CMP CH,BH + JNE @@exit + SHR ECX,16 + SHR EBX,16 + CMP CL,BL + JNE @@exit + CMP CH,BH + +@@exit: + POP EDI + POP ESI + POP EBX + +end; + +function _LStrAddRef(var str): Pointer; +{$IFDEF PUREPASCAL} +var + P: PStrRec; +begin + P := Pointer(Integer(str) - sizeof(StrRec)); + if P <> nil then + if P.refcnt >= 0 then + InterlockedIncrement(P.refcnt); + Result := Pointer(str); +end; +{$ELSE} +asm + { -> EAX str } + TEST EAX,EAX + JE @@exit + MOV EDX,[EAX-skew].StrRec.refCnt + INC EDX + JLE @@exit +{X LOCK} INC [EAX-skew].StrRec.refCnt +@@exit: +end; +{$ENDIF} + +function PICEmptyString: PWideChar; +begin + Result := ''; +end; + +function _LStrToPChar(const s: AnsiString): PChar; +{$IFDEF PUREPASCAL} +const + EmptyString = ''; +begin + if Pointer(s) = nil then + Result := EmptyString + else + Result := Pointer(s); +end; +{$ELSE} +asm + { -> EAX pointer to str } + { <- EAX pointer to PChar } + + TEST EAX,EAX + JE @@handle0 + RET +{$IFDEF PIC} +@@handle0: + JMP PICEmptyString +{$ELSE} +@@zeroByte: + DB 0 +@@handle0: + MOV EAX,offset @@zeroByte +{$ENDIF} +end; +{$ENDIF} + +function InternalUniqueString(var str): Pointer; +asm + { -> EAX pointer to str } + { <- EAX pointer to unique copy } + MOV EDX,[EAX] + TEST EDX,EDX + JE @@exit + MOV ECX,[EDX-skew].StrRec.refCnt + DEC ECX + JE @@exit + + PUSH EBX + MOV EBX,EAX + MOV EAX,[EDX-skew].StrRec.length + CALL _NewAnsiString + MOV EDX,EAX + MOV EAX,[EBX] + MOV [EBX],EDX + PUSH EAX + MOV ECX,[EAX-skew].StrRec.length + CALL Move + POP EAX + MOV ECX,[EAX-skew].StrRec.refCnt + DEC ECX + JL @@skip +{X LOCK} DEC [EAX-skew].StrRec.refCnt + JNZ @@skip + LEA EAX,[EAX-skew].StrRec.refCnt { if refCnt now zero, deallocate} + CALL _FreeMem +@@skip: + MOV EDX,[EBX] + POP EBX +@@exit: + MOV EAX,EDX +end; + + +procedure UniqueString(var str: AnsiString); +asm + JMP InternalUniqueString +end; + +procedure _UniqueStringA(var str: AnsiString); +asm + JMP InternalUniqueString +end; + +procedure UniqueString(var str: WideString); +asm +{$IFDEF LINUX} + JMP InternalUniqueString +{$ENDIF} +{$IFDEF MSWINDOWS} + // nothing to do - Windows WideStrings are always single reference +{$ENDIF} +end; + +procedure _UniqueStringW(var str: WideString); +asm +{$IFDEF LINUX} + JMP InternalUniqueString +{$ENDIF} +{$IFDEF MSWINDOWS} + // nothing to do - Windows WideStrings are always single reference +{$ENDIF} +end; + +procedure _LStrCopy{ const s : AnsiString; index, count : Integer) : AnsiString}; +asm + { ->EAX Source string } + { EDX index } + { ECX count } + { [ESP+4] Pointer to result string } + + PUSH EBX + + TEST EAX,EAX + JE @@srcEmpty + + MOV EBX,[EAX-skew].StrRec.length + TEST EBX,EBX + JE @@srcEmpty + +{ make index 0-based and limit to 0 <= index < Length(src) } + + DEC EDX + JL @@smallInx + CMP EDX,EBX + JGE @@bigInx + +@@cont1: + +{ limit count to satisfy 0 <= count <= Length(src) - index } + + SUB EBX,EDX { calculate Length(src) - index } + TEST ECX,ECX + JL @@smallCount + CMP ECX,EBX + JG @@bigCount + +@@cont2: + + ADD EDX,EAX + MOV EAX,[ESP+4+4] + CALL _LStrFromPCharLen + JMP @@exit + +@@smallInx: + XOR EDX,EDX + JMP @@cont1 +@@bigCount: + MOV ECX,EBX + JMP @@cont2 +@@bigInx: +@@smallCount: +@@srcEmpty: + MOV EAX,[ESP+4+4] + CALL _LStrClr +@@exit: + POP EBX + RET 4 +end; + + +procedure _LStrDelete{ var s : AnsiString; index, count : Integer }; +asm + { ->EAX Pointer to s } + { EDX index } + { ECX count } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + CALL UniqueString + + MOV EDX,[EBX] + TEST EDX,EDX { source already empty: nothing to do } + JE @@exit + + MOV ECX,[EDX-skew].StrRec.length + +{ make index 0-based, if not in [0 .. Length(s)-1] do nothing } + + DEC ESI + JL @@exit + CMP ESI,ECX + JGE @@exit + +{ limit count to [0 .. Length(s) - index] } + + TEST EDI,EDI + JLE @@exit + SUB ECX,ESI { ECX = Length(s) - index } + CMP EDI,ECX + JLE @@1 + MOV EDI,ECX +@@1: + +{ move length - index - count characters from s+index+count to s+index } + + SUB ECX,EDI { ECX = Length(s) - index - count } + ADD EDX,ESI { EDX = s+index } + LEA EAX,[EDX+EDI] { EAX = s+index+count } + CALL Move + +{ set length(s) to length(s) - count } + + MOV EDX,[EBX] + MOV EAX,EBX + MOV EDX,[EDX-skew].StrRec.length + SUB EDX,EDI + CALL _LStrSetLength + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +procedure _LStrInsert{ const source : AnsiString; var s : AnsiString; index : Integer }; +asm + { -> EAX source string } + { EDX pointer to destination string } + { ECX index } + + TEST EAX,EAX + JE @@nothingToDo + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + +{ make index 0-based and limit to 0 <= index <= Length(s) } + + MOV EDX,[EDX] + PUSH EDX + TEST EDX,EDX + JE @@sIsNull + MOV EDX,[EDX-skew].StrRec.length +@@sIsNull: + DEC EDI + JGE @@indexNotLow + XOR EDI,EDI +@@indexNotLow: + CMP EDI,EDX + JLE @@indexNotHigh + MOV EDI,EDX +@@indexNotHigh: + + MOV EBP,[EBX-skew].StrRec.length + +{ set length of result to length(source) + length(s) } + + MOV EAX,ESI + ADD EDX,EBP + CALL _LStrSetLength + POP EAX + + CMP EAX,EBX + JNE @@notInsertSelf + MOV EBX,[ESI] + +@@notInsertSelf: + +{ move length(s) - length(source) - index chars from s+index to s+index+length(source) } + + MOV EAX,[ESI] { EAX = s } + LEA EDX,[EDI+EBP] { EDX = index + length(source) } + MOV ECX,[EAX-skew].StrRec.length + SUB ECX,EDX { ECX = length(s) - length(source) - index } + ADD EDX,EAX { EDX = s + index + length(source) } + ADD EAX,EDI { EAX = s + index } + CALL Move + +{ copy length(source) chars from source to s+index } + + MOV EAX,EBX + MOV EDX,[ESI] + MOV ECX,EBP + ADD EDX,EDI + CALL Move + +@@exit: + POP EBP + POP EDI + POP ESI + POP EBX +@@nothingToDo: +end; + + +procedure _LStrPos{ const substr : AnsiString; const s : AnsiString ) : Integer}; +asm +{ ->EAX Pointer to substr } +{ EDX Pointer to string } +{ <-EAX Position of substr in s or 0 } + + TEST EAX,EAX + JE @@noWork + + TEST EDX,EDX + JE @@stringEmpty + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX { Point ESI to substr } + MOV EDI,EDX { Point EDI to s } + + MOV ECX,[EDI-skew].StrRec.length { ECX = Length(s) } + + PUSH EDI { remember s position to calculate index } + + MOV EDX,[ESI-skew].StrRec.length { EDX = Length(substr) } + + DEC EDX { EDX = Length(substr) - 1 } + JS @@fail { < 0 ? return 0 } + MOV AL,[ESI] { AL = first char of substr } + INC ESI { Point ESI to 2'nd char of substr } + + SUB ECX,EDX { #positions in s to look at } + { = Length(s) - Length(substr) + 1 } + JLE @@fail +@@loop: + REPNE SCASB + JNE @@fail + MOV EBX,ECX { save outer loop counter } + PUSH ESI { save outer loop substr pointer } + PUSH EDI { save outer loop s pointer } + + MOV ECX,EDX + REPE CMPSB + POP EDI { restore outer loop s pointer } + POP ESI { restore outer loop substr pointer } + JE @@found + MOV ECX,EBX { restore outer loop counter } + JMP @@loop + +@@fail: + POP EDX { get rid of saved s pointer } + XOR EAX,EAX + JMP @@exit + +@@stringEmpty: + XOR EAX,EAX + JMP @@noWork + +@@found: + POP EDX { restore pointer to first char of s } + MOV EAX,EDI { EDI points of char after match } + SUB EAX,EDX { the difference is the correct index } +@@exit: + POP EDI + POP ESI + POP EBX +@@noWork: +end; + + +procedure _LStrSetLength{ var str: AnsiString; newLength: Integer}; +asm + { -> EAX Pointer to str } + { EDX new length } + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV ESI,EDX + XOR EDI,EDI + + TEST EDX,EDX + JLE @@setString + + MOV EAX,[EBX] + TEST EAX,EAX + JE @@copyString + + CMP [EAX-skew].StrRec.refCnt,1 + JNE @@copyString + + SUB EAX,rOff + ADD EDX,rOff+1 + PUSH EAX + MOV EAX,ESP + CALL _ReallocMem + POP EAX + ADD EAX,rOff + MOV [EBX],EAX + MOV [EAX-skew].StrRec.length,ESI + MOV BYTE PTR [EAX+ESI],0 + JMP @@exit + +@@copyString: + MOV EAX,EDX + CALL _NewAnsiString + MOV EDI,EAX + + MOV EAX,[EBX] + TEST EAX,EAX + JE @@setString + + MOV EDX,EDI + MOV ECX,[EAX-skew].StrRec.length + CMP ECX,ESI + JL @@moveString + MOV ECX,ESI + +@@moveString: + CALL Move + +@@setString: + MOV EAX,EBX + CALL _LStrClr + MOV [EBX],EDI + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +procedure _LStrOfChar{ c: Char; count: Integer): AnsiString }; +asm + { -> AL c } + { EDX count } + { ECX result } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + MOV EAX,ECX + CALL _LStrClr + + TEST ESI,ESI + JLE @@exit + + MOV EAX,ESI + CALL _NewAnsiString + + MOV [EDI],EAX + + MOV EDX,ESI + MOV CL,BL + + CALL _FillChar + +@@exit: + POP EDI + POP ESI + POP EBX + +end; + + +function _Write0LString(var t: TTextRec; const s: AnsiString): Pointer; +begin + Result := _WriteLString(t, s, 0); +end; + + +function _WriteLString(var t: TTextRec; const s: AnsiString; width: Longint): Pointer; +{$IFDEF PUREPASCAL} +var + i: Integer; +begin + i := Length(s); + _WriteSpaces(t, width - i); + Result := _WriteBytes(t, s[1], i); +end; +{$ELSE} +asm + { -> EAX Pointer to text record } + { EDX Pointer to AnsiString } + { ECX Field width } + + PUSH EBX + + MOV EBX,EDX + + MOV EDX,ECX + XOR ECX,ECX + TEST EBX,EBX + JE @@skip + MOV ECX,[EBX-skew].StrRec.length + SUB EDX,ECX +@@skip: + PUSH ECX + CALL _WriteSpaces + POP ECX + + MOV EDX,EBX + POP EBX + JMP _WriteBytes +end; +{$ENDIF} + + +function _Write0WString(var t: TTextRec; const s: WideString): Pointer; +begin + Result := _WriteWString(t, s, 0); +end; + + +function _WriteWString(var t: TTextRec; const s: WideString; width: Longint): Pointer; +var + i: Integer; +begin + i := Length(s); + _WriteSpaces(t, width - i); + Result := _WriteLString(t, AnsiString(s), 0); +end; + + +function _Write0WCString(var t: TTextRec; s: PWideChar): Pointer; +begin + Result := _WriteWCString(t, s, 0); +end; + + +function _WriteWCString(var t: TTextRec; s: PWideChar; width: Longint): Pointer; +var + i: Integer; +begin + i := 0; + if (s <> nil) then + while s[i] <> #0 do + Inc(i); + + _WriteSpaces(t, width - i); + Result := _WriteLString(t, AnsiString(s), 0); +end; + + +function _Write0WChar(var t: TTextRec; c: WideChar): Pointer; +begin + Result := _WriteWChar(t, c, 0); +end; + + +function _WriteWChar(var t: TTextRec; c: WideChar; width: Integer): Pointer; +begin + _WriteSpaces(t, width - 1); + Result := _WriteLString(t, AnsiString(c), 0); +end; + + +{$IFDEF MSWINDOWS} +procedure WStrError; +asm + MOV AL,reOutOfMemory + JMP Error +end; +{$ENDIF} + +function _NewWideString(CharLength: Longint): Pointer; +{$IFDEF LINUX} +begin + Result := _NewAnsiString(CharLength*2); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + TEST EAX,EAX + JE @@1 + PUSH EAX + PUSH 0 + CALL SysAllocStringLen + TEST EAX,EAX + JE WStrError +@@1: +end; +{$ENDIF} + +procedure WStrSet(var S: WideString; P: PWideChar); +{$IFDEF PUREPASCAL} +var + Temp: Pointer; +begin + Temp := Pointer(InterlockedExchange(Pointer(S), Pointer(P))); + if Temp <> nil then + _WStrClr(Temp); +end; +{$ELSE} +asm +{$IFDEF LINUX} + XCHG [EAX],EDX + TEST EDX,EDX + JZ @@1 + PUSH EDX + MOV EAX, ESP + CALL _WStrClr + POP EAX +{$ENDIF} +{$IFDEF MSWINDOWS} + XCHG [EAX],EDX + TEST EDX,EDX + JZ @@1 + PUSH EDX + CALL SysFreeString +{$ENDIF} +@@1: +end; +{$ENDIF} + + +procedure WStrClr; +asm + JMP _WStrClr +end; + +procedure _WStrClr(var S); +{$IFDEF LINUX} +asm + JMP _LStrClr; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + { -> EAX Pointer to WideString } + + MOV EDX,[EAX] + TEST EDX,EDX + JE @@1 + MOV DWORD PTR [EAX],0 + PUSH EAX + PUSH EDX + CALL SysFreeString + POP EAX +@@1: +end; +{$ENDIF} + + +procedure WStrArrayClr; +asm + JMP _WStrArrayClr; +end; + +procedure _WStrArrayClr(var StrArray; Count: Integer); +{$IFDEF LINUX} +asm + JMP _LStrArrayClr +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + PUSH EBX + PUSH ESI + MOV EBX,EAX + MOV ESI,EDX +@@1: MOV EAX,[EBX] + TEST EAX,EAX + JE @@2 + MOV DWORD PTR [EBX],0 + PUSH EAX + CALL SysFreeString +@@2: ADD EBX,4 + DEC ESI + JNE @@1 + POP ESI + POP EBX +end; +{$ENDIF} + + +procedure _WStrAsg(var Dest: WideString; const Source: WideString); +{$IFDEF LINUX} +asm + JMP _LStrAsg +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + { -> EAX Pointer to WideString } + { EDX Pointer to data } + TEST EDX,EDX + JE _WStrClr + MOV ECX,[EDX-4] + SHR ECX,1 + JE _WStrClr + PUSH ECX + PUSH EDX + PUSH EAX + CALL SysReAllocStringLen + TEST EAX,EAX + JE WStrError +end; +{$ENDIF} + +procedure _WStrLAsg(var Dest: WideString; const Source: WideString); +{$IFDEF LINUX} +asm + JMP _LStrLAsg +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + JMP _WStrAsg +end; +{$ENDIF} + +procedure _WStrFromPCharLen(var Dest: WideString; Source: PAnsiChar; Length: Integer); +var + DestLen: Integer; + Buffer: array[0..2047] of WideChar; +begin + if Length <= 0 then + begin + _WStrClr(Dest); + Exit; + end; + if Length+1 < High(Buffer) then + begin + DestLen := WCharFromChar(Buffer, High(Buffer), Source, Length); + if DestLen > 0 then + begin + _WStrFromPWCharLen(Dest, @Buffer, DestLen); + Exit; + end; + end; + + DestLen := (Length + 1); + _WStrSetLength(Dest, DestLen); // overallocate, trim later + DestLen := WCharFromChar(Pointer(Dest), DestLen, Source, Length); + if DestLen < 0 then DestLen := 0; + _WStrSetLength(Dest, DestLen); +end; + +procedure _WStrFromPWCharLen(var Dest: WideString; Source: PWideChar; CharLength: Integer); +{$IFDEF LINUX} +var + Temp: Pointer; +begin + Temp := Pointer(Dest); + if CharLength > 0 then + begin + Pointer(Dest) := _NewWideString(CharLength); + if Source <> nil then + Move(Source^, Pointer(Dest)^, CharLength * sizeof(WideChar)); + end + else + Pointer(Dest) := nil; + _WStrClr(Temp); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + { -> EAX Pointer to WideString (dest) } + { EDX Pointer to characters (source) } + { ECX number of characters (not bytes) } + TEST ECX,ECX + JE _WStrClr + + PUSH EAX + + PUSH ECX + PUSH EDX + CALL SysAllocStringLen + TEST EAX,EAX + JE WStrError + + POP EDX + PUSH [EDX].PWideChar + MOV [EDX],EAX + + CALL SysFreeString +end; +{$ENDIF} + + +procedure _WStrFromChar(var Dest: WideString; Source: AnsiChar); +asm + PUSH EDX + MOV EDX,ESP + MOV ECX,1 + CALL _WStrFromPCharLen + POP EDX +end; + + +procedure _WStrFromWChar(var Dest: WideString; Source: WideChar); +asm + { -> EAX Pointer to WideString (dest) } + { EDX character (source) } + PUSH EDX + MOV EDX,ESP + MOV ECX,1 + CALL _WStrFromPWCharLen + POP EDX +end; + + +procedure _WStrFromPChar(var Dest: WideString; Source: PAnsiChar); +asm + { -> EAX Pointer to WideString (dest) } + { EDX Pointer to character (source) } + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CL,[EDX+0] + JE @@4 + CMP CL,[EDX+1] + JE @@3 + CMP CL,[EDX+2] + JE @@2 + CMP CL,[EDX+3] + JE @@1 + ADD EDX,4 + JMP @@0 +@@1: INC EDX +@@2: INC EDX +@@3: INC EDX +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX +@@5: JMP _WStrFromPCharLen +end; + + +procedure _WStrFromPWChar(var Dest: WideString; Source: PWideChar); +asm + { -> EAX Pointer to WideString (dest) } + { EDX Pointer to character (source) } + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CX,[EDX+0] + JE @@4 + CMP CX,[EDX+2] + JE @@3 + CMP CX,[EDX+4] + JE @@2 + CMP CX,[EDX+6] + JE @@1 + ADD EDX,8 + JMP @@0 +@@1: ADD EDX,2 +@@2: ADD EDX,2 +@@3: ADD EDX,2 +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX + SHR ECX,1 +@@5: JMP _WStrFromPWCharLen +end; + + +procedure _WStrFromString(var Dest: WideString; const Source: ShortString); +asm + XOR ECX,ECX + MOV CL,[EDX] + INC EDX + JMP _WStrFromPCharLen +end; + + +procedure _WStrFromArray(var Dest: WideString; Source: PAnsiChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASB + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _WStrFromPCharLen +end; + + +procedure _WStrFromWArray(var Dest: WideString; Source: PWideChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASW + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _WStrFromPWCharLen +end; + + +procedure _WStrFromLStr(var Dest: WideString; const Source: AnsiString); +asm + XOR ECX,ECX + TEST EDX,EDX + JE @@1 + MOV ECX,[EDX-4] +@@1: JMP _WStrFromPCharLen +end; + + +procedure _WStrToString(Dest: PShortString; const Source: WideString; MaxLen: Integer); +var + SourceLen, DestLen: Integer; + Buffer: array[0..511] of Char; +begin + if MaxLen > 255 then MaxLen := 255; + SourceLen := Length(Source); + if SourceLen >= MaxLen then SourceLen := MaxLen; + if SourceLen = 0 then + DestLen := 0 + else + begin + DestLen := CharFromWChar(Buffer, High(Buffer), PWideChar(Pointer(Source)), SourceLen); + if DestLen < 0 then + DestLen := 0 + else if DestLen > MaxLen then + DestLen := MaxLen; + end; + Dest^[0] := Chr(DestLen); + if DestLen > 0 then Move(Buffer, Dest^[1], DestLen); +end; + +function _WStrToPWChar(const S: WideString): PWideChar; +{$IFDEF PUREPASCAL} +const + EmptyString = ''; +begin + if Pointer(S) = nil then + Result := EmptyString + else + Result := Pointer(S); +end; +{$ELSE} +asm + TEST EAX,EAX + JE @@1 + RET +{$IFDEF PIC} +@@1: JMP PICEmptyString +{$ELSE} + NOP +@@0: DW 0 +@@1: MOV EAX,OFFSET @@0 +{$ENDIF} +end; +{$ENDIF} + + +function _WStrLen(const S: WideString): Integer; +{$IFDEF PUREPASCAL} +begin + if Pointer(S) = nil then + Result := 0 + else + Result := PInteger(Integer(S) - 4)^ div sizeof(WideChar); +end; +{$ELSE} +asm + { -> EAX Pointer to WideString data } + TEST EAX,EAX + JE @@1 + MOV EAX,[EAX-4] + SHR EAX,1 +@@1: +end; +{$ENDIF} + +procedure _WStrCat(var Dest: WideString; const Source: WideString); +var + DestLen, SourceLen: Integer; + NewStr: PWideChar; +begin + SourceLen := Length(Source); + if SourceLen <> 0 then + begin + DestLen := Length(Dest); + NewStr := _NewWideString(DestLen + SourceLen); + if DestLen > 0 then + Move(Pointer(Dest)^, NewStr^, DestLen * sizeof(WideChar)); + Move(Pointer(Source)^, NewStr[DestLen], SourceLen * sizeof(WideChar)); + WStrSet(Dest, NewStr); + end; +end; + + +procedure _WStrCat3(var Dest: WideString; const Source1, Source2: WideString); +var + Source1Len, Source2Len: Integer; + NewStr: PWideChar; +begin + Source1Len := Length(Source1); + Source2Len := Length(Source2); + if (Source1Len <> 0) or (Source2Len <> 0) then + begin + NewStr := _NewWideString(Source1Len + Source2Len); + Move(Pointer(Source1)^, Pointer(NewStr)^, Source1Len * sizeof(WideChar)); + Move(Pointer(Source2)^, NewStr[Source1Len], Source2Len * sizeof(WideChar)); + WStrSet(Dest, NewStr); + end; +end; + + +procedure _WStrCatN{var Dest: WideString; ArgCnt: Integer; ...}; +asm + { ->EAX = Pointer to dest } + { EDX = number of args (>= 3) } + { [ESP+4], [ESP+8], ... crgCnt WideString arguments } + + PUSH EBX + PUSH ESI + PUSH EDX + PUSH EAX + MOV EBX,EDX + + XOR EAX,EAX +@@loop1: + MOV ECX,[ESP+EDX*4+4*4] + TEST ECX,ECX + JE @@1 + ADD EAX,[ECX-4] +@@1: + DEC EDX + JNE @@loop1 + + SHR EAX,1 + CALL _NewWideString + PUSH EAX + MOV ESI,EAX + +@@loop2: + MOV EAX,[ESP+EBX*4+5*4] + MOV EDX,ESI + TEST EAX,EAX + JE @@2 + MOV ECX,[EAX-4] + ADD ESI,ECX + CALL Move +@@2: + DEC EBX + JNE @@loop2 + + POP EDX + POP EAX + CALL WStrSet + + POP EDX + POP ESI + POP EBX + POP EAX + LEA ESP,[ESP+EDX*4] + JMP EAX +end; + + +procedure _WStrCmp{left: WideString; right: WideString}; +asm +{ ->EAX = Pointer to left string } +{ EDX = Pointer to right string } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + CMP EAX,EDX + JE @@exit + + TEST ESI,ESI + JE @@str1null + + TEST EDI,EDI + JE @@str2null + + MOV EAX,[ESI-4] + MOV EDX,[EDI-4] + + SUB EAX,EDX { eax = len1 - len2 } + JA @@skip1 + ADD EDX,EAX { edx = len2 + (len1 - len2) = len1 } + +@@skip1: + PUSH EDX + SHR EDX,2 + JE @@cmpRest +@@longLoop: + MOV ECX,[ESI] + MOV EBX,[EDI] + CMP ECX,EBX + JNE @@misMatch + DEC EDX + JE @@cmpRestP4 + MOV ECX,[ESI+4] + MOV EBX,[EDI+4] + CMP ECX,EBX + JNE @@misMatch + ADD ESI,8 + ADD EDI,8 + DEC EDX + JNE @@longLoop + JMP @@cmpRest +@@cmpRestP4: + ADD ESI,4 + ADD EDI,4 +@@cmpRest: + POP EDX + AND EDX,2 + JE @@equal + + MOV CX,[ESI] + MOV BX,[EDI] + CMP CX,BX + JNE @@exit + +@@equal: + ADD EAX,EAX + JMP @@exit + +@@str1null: + MOV EDX,[EDI-4] + SUB EAX,EDX + JMP @@exit + +@@str2null: + MOV EAX,[ESI-4] + SUB EAX,EDX + JMP @@exit + +@@misMatch: + POP EDX + CMP CX,BX + JNE @@exit + SHR ECX,16 + SHR EBX,16 + CMP CX,BX + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +function _WStrCopy(const S: WideString; Index, Count: Integer): WideString; +var + L, N: Integer; +begin + L := Length(S); + if Index < 1 then Index := 0 else + begin + Dec(Index); + if Index > L then Index := L; + end; + if Count < 0 then N := 0 else + begin + N := L - Index; + if N > Count then N := Count; + end; + _WStrFromPWCharLen(Result, PWideChar(Pointer(S)) + Index, N); +end; + + +procedure _WStrDelete(var S: WideString; Index, Count: Integer); +var + L, N: Integer; + NewStr: PWideChar; +begin + L := Length(S); + if (L > 0) and (Index >= 1) and (Index <= L) and (Count > 0) then + begin + Dec(Index); + N := L - Index - Count; + if N < 0 then N := 0; + if (Index = 0) and (N = 0) then NewStr := nil else + begin + NewStr := _NewWideString(Index + N); + if Index > 0 then + Move(Pointer(S)^, NewStr^, Index * 2); + if N > 0 then + Move(PWideChar(Pointer(S))[L - N], NewStr[Index], N * 2); + end; + WStrSet(S, NewStr); + end; +end; + + +procedure _WStrInsert(const Source: WideString; var Dest: WideString; Index: Integer); +var + SourceLen, DestLen: Integer; + NewStr: PWideChar; +begin + SourceLen := Length(Source); + if SourceLen > 0 then + begin + DestLen := Length(Dest); + if Index < 1 then Index := 0 else + begin + Dec(Index); + if Index > DestLen then Index := DestLen; + end; + NewStr := _NewWideString(DestLen + SourceLen); + if Index > 0 then + Move(Pointer(Dest)^, NewStr^, Index * 2); + Move(Pointer(Source)^, NewStr[Index], SourceLen * 2); + if Index < DestLen then + Move(PWideChar(Pointer(Dest))[Index], NewStr[Index + SourceLen], + (DestLen - Index) * 2); + WStrSet(Dest, NewStr); + end; +end; + + +procedure _WStrPos{ const substr : WideString; const s : WideString ) : Integer}; +asm +{ ->EAX Pointer to substr } +{ EDX Pointer to string } +{ <-EAX Position of substr in s or 0 } + + TEST EAX,EAX + JE @@noWork + + TEST EDX,EDX + JE @@stringEmpty + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX { Point ESI to substr } + MOV EDI,EDX { Point EDI to s } + + MOV ECX,[EDI-4] { ECX = Length(s) } + SHR ECX,1 + + PUSH EDI { remember s position to calculate index } + + MOV EDX,[ESI-4] { EDX = Length(substr) } + SHR EDX,1 + + DEC EDX { EDX = Length(substr) - 1 } + JS @@fail { < 0 ? return 0 } + MOV AX,[ESI] { AL = first char of substr } + ADD ESI,2 { Point ESI to 2'nd char of substr } + + SUB ECX,EDX { #positions in s to look at } + { = Length(s) - Length(substr) + 1 } + JLE @@fail +@@loop: + REPNE SCASW + JNE @@fail + MOV EBX,ECX { save outer loop counter } + PUSH ESI { save outer loop substr pointer } + PUSH EDI { save outer loop s pointer } + + MOV ECX,EDX + REPE CMPSW + POP EDI { restore outer loop s pointer } + POP ESI { restore outer loop substr pointer } + JE @@found + MOV ECX,EBX { restore outer loop counter } + JMP @@loop + +@@fail: + POP EDX { get rid of saved s pointer } + XOR EAX,EAX + JMP @@exit + +@@stringEmpty: + XOR EAX,EAX + JMP @@noWork + +@@found: + POP EDX { restore pointer to first char of s } + MOV EAX,EDI { EDI points of char after match } + SUB EAX,EDX { the difference is the correct index } + SHR EAX,1 +@@exit: + POP EDI + POP ESI + POP EBX +@@noWork: +end; + + +procedure _WStrSetLength(var S: WideString; NewLength: Integer); +var + NewStr: PWideChar; + Count: Integer; +begin + NewStr := nil; + if NewLength > 0 then + begin + NewStr := _NewWideString(NewLength); + Count := Length(S); + if Count > 0 then + begin + if Count > NewLength then Count := NewLength; + Move(Pointer(S)^, NewStr^, Count * 2); + end; + end; + WStrSet(S, NewStr); +end; + + +function _WStrOfWChar(Ch: WideChar; Count: Integer): WideString; +var + P: PWideChar; +begin + _WStrFromPWCharLen(Result, nil, Count); + P := Pointer(Result); + while Count > 0 do + begin + Dec(Count); + P[Count] := Ch; + end; +end; + +procedure WStrAddRef; +asm + JMP _WStrAddRef +end; + +function _WStrAddRef(var str: WideString): Pointer; +{$IFDEF LINUX} +asm + JMP _LStrAddRef +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + MOV EDX,[EAX] + TEST EDX,EDX + JE @@1 + PUSH EAX + MOV ECX,[EDX-4] + SHR ECX,1 + PUSH ECX + PUSH EDX + CALL SysAllocStringLen + POP EDX + TEST EAX,EAX + JE WStrError + MOV [EDX],EAX +@@1: +end; +{$ENDIF} + +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); +{$IFDEF PUREPASCAL} +var + FT: PFieldTable; + I: Cardinal; +begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + for I := FT.Count-1 downto 0 do + _InitializeArray(Pointer(Cardinal(P) + FT.Fields[I].Offset), FT.Fields[I].TypeInfo^, 1); +end; +{$ELSE} +asm + { -> EAX pointer to record to be initialized } + { EDX pointer to type info } + + XOR ECX,ECX + + PUSH EBX + MOV CL,[EDX+1] { type name length } + + PUSH ESI + PUSH EDI + + MOV EBX,EAX // PIC safe. See comment above + LEA ESI,[EDX+ECX+2+8] { address of destructable fields } + MOV EDI,[EDX+ECX+2+4] { number of destructable fields } + +@@loop: + + MOV EDX,[ESI] + MOV EAX,[ESI+4] + ADD EAX,EBX + MOV EDX,[EDX] + MOV ECX,1 + CALL _InitializeArray + ADD ESI,8 + DEC EDI + JG @@loop + + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + + +const + tkLString = 10; + tkWString = 11; + tkVariant = 12; + tkArray = 13; + tkRecord = 14; + tkInterface = 15; + tkDynArray = 17; + +procedure _InitializeArray(p: Pointer; typeInfo: Pointer; elemCount: Cardinal); +{$IFDEF PUREPASCAL} +var + FT: PFieldTable; +begin + if elemCount = 0 then Exit; + case PTypeInfo(typeInfo).Kind of + tkLString, tkWString, tkInterface, tkDynArray: + while elemCount > 0 do + begin + PInteger(P)^ := 0; + Inc(Integer(P), 4); + Dec(elemCount); + end; + tkVariant: + while elemCount > 0 do + begin + PInteger(P)^ := 0; + PInteger(Integer(P)+4)^ := 0; + PInteger(Integer(P)+8)^ := 0; + PInteger(Integer(P)+12)^ := 0; + Inc(Integer(P), sizeof(Variant)); + Dec(elemCount); + end; + tkArray: + begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + while elemCount > 0 do + begin + _InitializeArray(P, FT.Fields[0].TypeInfo^, FT.Count); + Inc(Integer(P), FT.Size); + Dec(elemCount); + end; + end; + tkRecord: + begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + while elemCount > 0 do + begin + _InitializeRecord(P, typeInfo); + Inc(Integer(P), FT.Size); + Dec(elemCount); + end; + end; + else + Error(reInvalidPtr); + end; +end; +{$ELSE} +asm + { -> EAX pointer to data to be initialized } + { EDX pointer to type info describing data } + { ECX number of elements of that type } + + TEST ECX, ECX + JZ @@zerolength + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX // PIC safe. See comment above + MOV ESI,EDX + MOV EDI,ECX + + XOR EDX,EDX + MOV AL,[ESI] + MOV DL,[ESI+1] + XOR ECX,ECX + + CMP AL,tkLString + JE @@LString + CMP AL,tkWString + JE @@WString + CMP AL,tkVariant + JE @@Variant + CMP AL,tkArray + JE @@Array + CMP AL,tkRecord + JE @@Record + CMP AL,tkInterface + JE @@Interface + CMP AL,tkDynArray + JE @@DynArray + MOV AL,reInvalidPtr + POP EDI + POP ESI + POP EBX + JMP Error + +@@LString: +@@WString: +@@Interface: +@@DynArray: + MOV [EBX],ECX + ADD EBX,4 + DEC EDI + JG @@LString + JMP @@exit + +@@Variant: + MOV [EBX ],ECX + MOV [EBX+ 4],ECX + MOV [EBX+ 8],ECX + MOV [EBX+12],ECX + ADD EBX,16 + DEC EDI + JG @@Variant + JMP @@exit + +@@Array: + PUSH EBP + MOV EBP,EDX +@@ArrayLoop: + MOV EDX,[ESI+EBP+2+8] // address of destructable fields typeinfo + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] // size in bytes of the array data + MOV ECX,[ESI+EBP+2+4] // number of destructable fields + MOV EDX,[EDX] + CALL _InitializeArray + DEC EDI + JG @@ArrayLoop + POP EBP + JMP @@exit + +@@Record: + PUSH EBP + MOV EBP,EDX +@@RecordLoop: + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV EDX,ESI + CALL _InitializeRecord + DEC EDI + JG @@RecordLoop + POP EBP + +@@exit: + + POP EDI + POP ESI + POP EBX +@@zerolength: +end; +{$ENDIF} + +procedure _Initialize(p: Pointer; typeInfo: Pointer); +{$IFDEF PUREPASCAL} +begin + _InitializeArray(p, typeInfo, 1); +end; +{$ELSE} +asm + MOV ECX,1 + JMP _InitializeArray +end; +{$ENDIF} + +procedure _FinalizeRecord(p: Pointer; typeInfo: Pointer); +{$IFDEF PUREPASCAL} +var + FT: PFieldTable; + I: Cardinal; +begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + for I := 0 to FT.Count-1 do + _FinalizeArray(Pointer(Cardinal(P) + FT.Fields[I].Offset), FT.Fields[I].TypeInfo^, 1); +end; +{$ELSE} +asm + { -> EAX pointer to record to be finalized } + { EDX pointer to type info } + + XOR ECX,ECX + + PUSH EBX + MOV CL,[EDX+1] + + PUSH ESI + PUSH EDI + + MOV EBX,EAX + LEA ESI,[EDX+ECX+2+8] + MOV EDI,[EDX+ECX+2+4] + +@@loop: + + MOV EDX,[ESI] + MOV EAX,[ESI+4] + ADD EAX,EBX + MOV EDX,[EDX] + MOV ECX,1 + CALL _FinalizeArray + ADD ESI,8 + DEC EDI + JG @@loop + + MOV EAX,EBX + + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +procedure _FinalizeArray(p: Pointer; typeInfo: Pointer; elemCount: Cardinal); +{$IFDEF PUREPASCAL} +var + FT: PFieldTable; +begin + if elemCount = 0 then Exit; + case PTypeInfo(typeInfo).Kind of + tkLString: _LStrArrayClr(P^, elemCount); + tkWString: {X-_WStrArrayClr X+}WStrArrayClrProc(P^, elemCount); + tkVariant: + while elemCount > 0 do + begin + VarClrProc(P); + Inc(Integer(P), sizeof(Variant)); + Dec(elemCount); + end; + tkArray: + begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + while elemCount > 0 do + begin + _FinalizeArray(P, FT.Fields[0].TypeInfo^, FT.Count); + Inc(Integer(P), FT.Size); + Dec(elemCount); + end; + end; + tkRecord: + begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + while elemCount > 0 do + begin + _FinalizeRecord(P, typeInfo); + Inc(Integer(P), FT.Size); + Dec(elemCount); + end; + end; + tkInterface: + while elemCount > 0 do + begin + _IntfClear(IInterface(P^)); + Inc(Integer(P), 4); + Dec(elemCount); + end; + tkDynArray: + while elemCount > 0 do + begin + _DynArrayClr(P); + Inc(Integer(P), 4); + Dec(elemCount); + end; + else + Error(reInvalidPtr); + end; +end; +{$ELSE} +asm + { -> EAX pointer to data to be finalized } + { EDX pointer to type info describing data } + { ECX number of elements of that type } + + { This code appears to be PIC safe. The functions called from + here either don't make external calls or call Pascal + routines that will fix up EBX in their prolog code + (FreeMem, VarClr, IntfClr). } + + CMP ECX, 0 { no array -> nop } + JE @@zerolength + + PUSH EAX + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + XOR EDX,EDX + MOV AL,[ESI] + MOV DL,[ESI+1] + + CMP AL,tkLString + JE @@LString + + CMP AL,tkWString + JE @@WString + + CMP AL,tkVariant + JE @@Variant + + CMP AL,tkArray + JE @@Array + + CMP AL,tkRecord + JE @@Record + + CMP AL,tkInterface + JE @@Interface + + CMP AL,tkDynArray + JE @@DynArray + + JMP @@error + +@@LString: + CMP ECX,1 + MOV EAX,EBX + JG @@LStringArray + CALL _LStrClr + JMP @@exit +@@LStringArray: + MOV EDX,ECX + CALL _LStrArrayClr + JMP @@exit + +@@WString: + CMP ECX,1 + MOV EAX,EBX + JG @@WStringArray + //CALL _WStrClr {X} + CALL [WStrClrProc] {X} + JMP @@exit +@@WStringArray: + MOV EDX,ECX + //CALL _WStrArrayClr {X} + CALL [WStrArrayClrProc] {X} + JMP @@exit +@@Variant: + MOV EAX,EBX + ADD EBX,16 + CALL _VarClr + DEC EDI + JG @@Variant + JMP @@exit +@@Array: + PUSH EBP + MOV EBP,EDX +@@ArrayLoop: + MOV EDX,[ESI+EBP+2+8] + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV ECX,[ESI+EBP+2+4] + MOV EDX,[EDX] + CALL _FinalizeArray + DEC EDI + JG @@ArrayLoop + POP EBP + JMP @@exit + +@@Record: + PUSH EBP + MOV EBP,EDX +@@RecordLoop: + { inv: EDI = number of array elements to finalize } + + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV EDX,ESI + CALL _FinalizeRecord + DEC EDI + JG @@RecordLoop + POP EBP + JMP @@exit + +@@Interface: + MOV EAX,EBX + ADD EBX,4 + CALL _IntfClear + DEC EDI + JG @@Interface + JMP @@exit + +@@DynArray: + MOV EAX,EBX + MOV EDX,ESI + ADD EBX,4 + CALL _DynArrayClear + DEC EDI + JG @@DynArray + JMP @@exit + +@@error: + POP EDI + POP ESI + POP EBX + POP EAX + MOV AL,reInvalidPtr + JMP Error + +@@exit: + POP EDI + POP ESI + POP EBX + POP EAX +@@zerolength: +end; +{$ENDIF} + +procedure _Finalize(p: Pointer; typeInfo: Pointer); +{$IFDEF PUREPASCAL} +begin + _FinalizeArray(p, typeInfo, 1); +end; +{$ELSE} +asm + MOV ECX,1 + JMP _FinalizeArray +end; +{$ENDIF} + +procedure _AddRefRecord{ p: Pointer; typeInfo: Pointer }; +asm + { -> EAX pointer to record to be referenced } + { EDX pointer to type info } + + XOR ECX,ECX + + PUSH EBX + MOV CL,[EDX+1] + + PUSH ESI + PUSH EDI + + MOV EBX,EAX + LEA ESI,[EDX+ECX+2+8] + MOV EDI,[EDX+ECX+2+4] + +@@loop: + + MOV EDX,[ESI] + MOV EAX,[ESI+4] + ADD EAX,EBX + MOV EDX,[EDX] + MOV ECX, 1 + CALL _AddRefArray + ADD ESI,8 + DEC EDI + JG @@loop + + POP EDI + POP ESI + POP EBX +end; + + +{X}procedure DummyProc; +{X}begin +{X}end; + +procedure _AddRefArray{ p: Pointer; typeInfo: Pointer; elemCount: Longint}; +asm + { -> EAX pointer to data to be referenced } + { EDX pointer to type info describing data } + { ECX number of elements of that type } + + { This code appears to be PIC safe. The functions called from + here either don't make external calls (LStrAddRef, WStrAddRef) or + are Pascal routines that will fix up EBX in their prolog code + (VarAddRef, IntfAddRef). } + + PUSH EBX + PUSH ESI + PUSH EDI + + TEST ECX,ECX + JZ @@exit + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + XOR EDX,EDX + MOV AL,[ESI] + MOV DL,[ESI+1] + + CMP AL,tkLString + JE @@LString + CMP AL,tkWString + JE @@WString + CMP AL,tkVariant + JE @@Variant + CMP AL,tkArray + JE @@Array + CMP AL,tkRecord + JE @@Record + CMP AL,tkInterface + JE @@Interface + CMP AL,tkDynArray + JE @@DynArray + MOV AL,reInvalidPtr + POP EDI + POP ESI + POP EBX + JMP Error + +@@LString: + MOV EAX,[EBX] + ADD EBX,4 + CALL _LStrAddRef + DEC EDI + JG @@LString + JMP @@exit + +@@WString: + MOV EAX,EBX + ADD EBX,4 + //CALL _WStrAddRef + CALL [WStrAddRefProc] + DEC EDI + JG @@WString + JMP @@exit +@@Variant: + MOV EAX,EBX + ADD EBX,16 + CALL _VarAddRef + DEC EDI + JG @@Variant + JMP @@exit + +@@Array: + PUSH EBP + MOV EBP,EDX +@@ArrayLoop: + MOV EDX,[ESI+EBP+2+8] + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV ECX,[ESI+EBP+2+4] + MOV EDX,[EDX] + CALL _AddRefArray + DEC EDI + JG @@ArrayLoop + POP EBP + JMP @@exit + +@@Record: + PUSH EBP + MOV EBP,EDX +@@RecordLoop: + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV EDX,ESI + CALL _AddRefRecord + DEC EDI + JG @@RecordLoop + POP EBP + JMP @@exit + +@@Interface: + MOV EAX,[EBX] + ADD EBX,4 + CALL _IntfAddRef + DEC EDI + JG @@Interface + JMP @@exit + +@@DynArray: + MOV EAX,[EBX] + ADD EBX,4 + CALL _DynArrayAddRef + DEC EDI + JG @@DynArray +@@exit: + + POP EDI + POP ESI + POP EBX +end; + + +procedure _AddRef{ p: Pointer; typeInfo: Pointer}; +asm + MOV ECX,1 + JMP _AddRefArray +end; + + +procedure _CopyRecord{ dest, source, typeInfo: Pointer }; +asm + { -> EAX pointer to dest } + { EDX pointer to source } + { ECX pointer to typeInfo } + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBX,EAX + MOV ESI,EDX + + XOR EAX,EAX + MOV AL,[ECX+1] + + LEA EDI,[ECX+EAX+2+8] + MOV EBP,[EDI-4] + XOR EAX,EAX + MOV ECX,[EDI-8] + PUSH ECX +@@loop: + MOV ECX,[EDI+4] + SUB ECX,EAX + JLE @@nomove1 + MOV EDX,EAX + ADD EAX,ESI + ADD EDX,EBX + CALL Move +@@noMove1: + MOV EAX,[EDI+4] + + MOV EDX,[EDI] + MOV EDX,[EDX] + MOV CL,[EDX] + + CMP CL,tkLString + JE @@LString + CMP CL,tkWString + JE @@WString + CMP CL,tkVariant + JE @@Variant + CMP CL,tkArray + JE @@Array + CMP CL,tkRecord + JE @@Record + CMP CL,tkInterface + JE @@Interface + CMP CL,tkDynArray + JE @@DynArray + MOV AL,reInvalidPtr + POP EBP + POP EDI + POP ESI + POP EBX + JMP Error + +@@LString: + MOV EDX,[ESI+EAX] + ADD EAX,EBX + CALL _LStrAsg + MOV EAX,4 + JMP @@common + +@@WString: + MOV EDX,[ESI+EAX] + ADD EAX,EBX + CALL _WStrAsg + MOV EAX,4 + JMP @@common + +@@Variant: + LEA EDX,[ESI+EAX] + ADD EAX,EBX + CALL _VarCopy + MOV EAX,16 + JMP @@common + +@@Array: + XOR ECX,ECX + MOV CL,[EDX+1] + PUSH dword ptr [EDX+ECX+2] + PUSH dword ptr [EDX+ECX+2+4] + MOV ECX,[EDX+ECX+2+8] + MOV ECX,[ECX] + LEA EDX,[ESI+EAX] + ADD EAX,EBX + CALL _CopyArray + POP EAX + JMP @@common + +@@Record: + XOR ECX,ECX + MOV CL,[EDX+1] + MOV ECX,[EDX+ECX+2] + PUSH ECX + MOV ECX,EDX + LEA EDX,[ESI+EAX] + ADD EAX,EBX + CALL _CopyRecord + POP EAX + JMP @@common + +@@Interface: + MOV EDX,[ESI+EAX] + ADD EAX,EBX + CALL _IntfCopy + MOV EAX,4 + JMP @@common + +@@DynArray: + MOV ECX,EDX + MOV EDX,[ESI+EAX] + ADD EAX,EBX + CALL _DynArrayAsg + MOV EAX,4 + +@@common: + ADD EAX,[EDI+4] + ADD EDI,8 + DEC EBP + JNZ @@loop + + POP ECX + SUB ECX,EAX + JLE @@noMove2 + LEA EDX,[EBX+EAX] + ADD EAX,ESI + CALL Move +@@noMove2: + + POP EBP + POP EDI + POP ESI + POP EBX +end; + + +procedure _CopyObject{ dest, source: Pointer; vmtPtrOffs: Longint; typeInfo: Pointer }; +asm + { -> EAX pointer to dest } + { EDX pointer to source } + { ECX offset of vmt in object } + { [ESP+4] pointer to typeInfo } + + ADD ECX,EAX { pointer to dest vmt } + PUSH dword ptr [ECX] { save dest vmt } + PUSH ECX + MOV ECX,[ESP+4+4+4] + CALL _CopyRecord + POP ECX + POP dword ptr [ECX] { restore dest vmt } + RET 4 + +end; + +procedure _CopyArray{ dest, source, typeInfo: Pointer; cnt: Integer }; +asm + { -> EAX pointer to dest } + { EDX pointer to source } + { ECX pointer to typeInfo } + { [ESP+4] count } + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + MOV EBP,[ESP+4+4*4] + + MOV CL,[EDI] + + CMP CL,tkLString + JE @@LString + CMP CL,tkWString + JE @@WString + CMP CL,tkVariant + JE @@Variant + CMP CL,tkArray + JE @@Array + CMP CL,tkRecord + JE @@Record + CMP CL,tkInterface + JE @@Interface + CMP CL,tkDynArray + JE @@DynArray + MOV AL,reInvalidPtr + POP EBP + POP EDI + POP ESI + POP EBX + JMP Error + +@@LString: + MOV EAX,EBX + MOV EDX,[ESI] + CALL _LStrAsg + ADD EBX,4 + ADD ESI,4 + DEC EBP + JNE @@LString + JMP @@exit + +@@WString: + MOV EAX,EBX + MOV EDX,[ESI] + CALL _WStrAsg + ADD EBX,4 + ADD ESI,4 + DEC EBP + JNE @@WString + JMP @@exit + +@@Variant: + MOV EAX,EBX + MOV EDX,ESI + CALL _VarCopy + ADD EBX,16 + ADD ESI,16 + DEC EBP + JNE @@Variant + JMP @@exit + +@@Array: + XOR ECX,ECX + MOV CL,[EDI+1] + LEA EDI,[EDI+ECX+2] +@@ArrayLoop: + MOV EAX,EBX + MOV EDX,ESI + MOV ECX,[EDI+8] + PUSH dword ptr [EDI+4] + CALL _CopyArray + ADD EBX,[EDI] + ADD ESI,[EDI] + DEC EBP + JNE @@ArrayLoop + JMP @@exit + +@@Record: + MOV EAX,EBX + MOV EDX,ESI + MOV ECX,EDI + CALL _CopyRecord + XOR EAX,EAX + MOV AL,[EDI+1] + ADD EBX,[EDI+EAX+2] + ADD ESI,[EDI+EAX+2] + DEC EBP + JNE @@Record + JMP @@exit + +@@Interface: + MOV EAX,EBX + MOV EDX,[ESI] + CALL _IntfCopy + ADD EBX,4 + ADD ESI,4 + DEC EBP + JNE @@Interface + JMP @@exit + +@@DynArray: + MOV EAX,EBX + MOV EDX,[ESI] + MOV ECX,EDI + CALL _DynArrayAsg + ADD EBX,4 + ADD ESI,4 + DEC EBP + JNE @@DynArray + +@@exit: + POP EBP + POP EDI + POP ESI + POP EBX + RET 4 +end; + + +function _New(size: Longint; typeInfo: Pointer): Pointer; +{$IFDEF PUREPASCAL} +begin + GetMem(Result, size); + if Result <> nil then + _Initialize(Result, typeInfo); +end; +{$ELSE} +asm + { -> EAX size of object to allocate } + { EDX pointer to typeInfo } + + PUSH EDX + CALL _GetMem + POP EDX + TEST EAX,EAX + JE @@exit + PUSH EAX + CALL _Initialize + POP EAX +@@exit: +end; +{$ENDIF} + +procedure _Dispose(p: Pointer; typeInfo: Pointer); +{$IFDEF PUREPASCAL} +begin + _Finalize(p, typeinfo); + FreeMem(p); +end; +{$ELSE} +asm + { -> EAX Pointer to object to be disposed } + { EDX Pointer to type info } + + PUSH EAX + CALL _Finalize + POP EAX + CALL _FreeMem +end; +{$ENDIF} + +{ ----------------------------------------------------- } +{ Wide character support } +{ ----------------------------------------------------- } + +function WideCharToString(Source: PWideChar): string; +begin + WideCharToStrVar(Source, Result); +end; + +function WideCharLenToString(Source: PWideChar; SourceLen: Integer): string; +begin + WideCharLenToStrVar(Source, SourceLen, Result); +end; + +procedure WideCharToStrVar(Source: PWideChar; var Dest: string); +begin + _LStrFromPWChar(Dest, Source); +end; + +procedure WideCharLenToStrVar(Source: PWideChar; SourceLen: Integer; + var Dest: string); +begin + _LStrFromPWCharLen(Dest, Source, SourceLen); +end; + +function StringToWideChar(const Source: string; Dest: PWideChar; + DestSize: Integer): PWideChar; +begin + Dest[WCharFromChar(Dest, DestSize - 1, PChar(Source), Length(Source))] := #0; + Result := Dest; +end; + +{ ----------------------------------------------------- } +{ OLE string support } +{ ----------------------------------------------------- } + +function OleStrToString(Source: PWideChar): string; +begin + OleStrToStrVar(Source, Result); +end; + +procedure OleStrToStrVar(Source: PWideChar; var Dest: string); +begin + WideCharLenToStrVar(Source, Length(WideString(Pointer(Source))), Dest); +end; + +function StringToOleStr(const Source: string): PWideChar; +begin + Result := nil; + _WStrFromPCharLen(WideString(Pointer(Result)), PChar(Pointer(Source)), Length(Source)); +end; + +{ ----------------------------------------------------- } +{ Variant manager support } +{ ----------------------------------------------------- } + +var + VariantManager: TVariantManager; + +procedure VariantSystemUndefinedError; +asm + MOV AL,reVarInvalidOp + JMP Error; +end; + +procedure VariantSystemDefaultVarClear(var V: TVarData); +begin + case V.VType of + varEmpty, varNull, varError:; + else + VariantSystemUndefinedError; + end; +end; + +procedure InitVariantManager; +type + TPtrArray = array [Word] of Pointer; +var + P: ^TPtrArray; + I: Integer; +begin + P := @VariantManager; + for I := 0 to (SizeOf(VariantManager) div SizeOf(Pointer))-1 do + P[I] := @VariantSystemUndefinedError; + VariantManager.VarClear := @VariantSystemDefaultVarClear; +end; + +procedure GetVariantManager(var VarMgr: TVariantManager); +begin + VarMgr := VariantManager; +end; + +procedure SetVariantManager(const VarMgr: TVariantManager); +begin + VariantManager := VarMgr; +end; + +function IsVariantManagerSet: Boolean; +type + TPtrArray = array [Word] of Pointer; +var + P: ^TPtrArray; + I: Integer; +begin + Result := True; + P := @VariantManager; + for I := 0 to (SizeOf(VariantManager) div SizeOf(Pointer))-1 do + if P[I] <> @VariantSystemUndefinedError then + begin + Result := False; + Break; + end; +end; + +{ ----------------------------------------------------- } +{ Variant support } +{ ----------------------------------------------------- } + +procedure _DispInvoke;//(var Dest: Variant; const Source: Variant; + //CallDesc: PCallDesc; Params: Pointer); cdecl; +asm +{$IFDEF PIC} + CALL GetGOT + LEA EAX,[EAX].OFFSET VariantManager + JMP [EAX].TVariantManager.DispInvoke +{$ELSE} + JMP VariantManager.DispInvoke +{$ENDIF} +end; + +procedure _VarClear(var V : Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarClear(V); +{$ELSE} +asm + JMP VariantManager.VarClear +{$IFEND} +end; + +procedure _VarCopy(var Dest: Variant; const Source: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarCopy(Dest, Source); +{$ELSE} +asm + JMP VariantManager.VarCopy +{$IFEND} +end; + +procedure _VarCast(var Dest: Variant; const Source: Variant; VarType: Integer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarCast(Dest, Source, VarType); +{$ELSE} +asm + JMP VariantManager.VarCast +{$IFEND} +end; + +procedure _VarCastOle(var Dest: Variant; const Source: Variant; VarType: Integer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarCastOle(Dest, Source, VarType); +{$ELSE} +asm + JMP VariantManager.VarCastOle +{$IFEND} +end; + +function _VarToInt(const V: Variant): Integer; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.VarToInt(V); +{$ELSE} +asm + JMP VariantManager.VarToInt +{$IFEND} +end; + +function _VarToInt64(const V: Variant): Int64; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.VarToInt64(V); +{$ELSE} +asm + JMP VariantManager.VarToInt64 +{$IFEND} +end; + +function _VarToBool(const V: Variant): Boolean; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.VarToBool(V); +{$ELSE} +asm + JMP VariantManager.VarToBool +{$IFEND} +end; + +function _VarToReal(const V: Variant): Extended; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.VarToReal(V); +{$ELSE} +asm + JMP VariantManager.VarToReal +{$IFEND} +end; + +function _VarToCurr(const V: Variant): Currency; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.VarToCurr(V); +{$ELSE} +asm + JMP VariantManager.VarToCurr +{$IFEND} +end; + +procedure _VarToPStr(var S; const V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarToPStr(S, V); +{$ELSE} +asm + JMP VariantManager.VarToPStr +{$IFEND} +end; + +procedure _VarToLStr(var S: string; const V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarToLStr(S, V); +{$ELSE} +asm + JMP VariantManager.VarToLStr +{$IFEND} +end; + +procedure _VarToWStr(var S: WideString; const V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarToWStr(S, V); +{$ELSE} +asm + JMP VariantManager.VarToWStr +{$IFEND} +end; + +procedure _VarToIntf(var Unknown: IInterface; const V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarToIntf(Unknown, V); +{$ELSE} +asm + JMP VariantManager.VarToIntf +{$IFEND} +end; + +procedure _VarToDisp(var Dispatch: IDispatch; const V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarToDisp(Dispatch, V); +{$ELSE} +asm + JMP VariantManager.VarToDisp +{$IFEND} +end; + +procedure _VarToDynArray(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarToDynArray(DynArray, V, TypeInfo); +{$ELSE} +asm + JMP VariantManager.VarToDynArray +{$IFEND} +end; + +procedure _VarFromInt(var V: Variant; const Value, Range: Integer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromInt(V, Value, Range); +{$ELSE} +asm + JMP VariantManager.VarFromInt +{$IFEND} +end; + +procedure _VarFromInt64(var V: Variant; const Value: Int64); +begin + VariantManager.VarFromInt64(V, Value); +end; + +procedure _VarFromBool(var V: Variant; const Value: Boolean); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromBool(V, Value); +{$ELSE} +asm + JMP VariantManager.VarFromBool +{$IFEND} +end; + +procedure _VarFromReal; // var V: Variant; const Value: Real +asm +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + POP ECX + LEA EAX,[EAX].OFFSET VariantManager + MOV EAX,[EAX].TVariantManager.VarFromReal + XCHG EAX,[ESP] + RET +{$ELSE} + JMP VariantManager.VarFromReal +{$ENDIF} +end; + +procedure _VarFromTDateTime; // var V: Variant; const Value: TDateTime +asm +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + POP ECX + LEA EAX,[EAX].OFFSET VariantManager + MOV EAX,[EAX].TVariantManager.VarFromTDateTime + XCHG EAX,[ESP] + RET +{$ELSE} + JMP VariantManager.VarFromTDateTime +{$ENDIF} +end; + +procedure _VarFromCurr; // var V: Variant; const Value: Currency +asm +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + POP ECX + LEA EAX,[EAX].OFFSET VariantManager + MOV EAX,[EAX].TVariantManager.VarFromCurr + XCHG EAX,[ESP] + RET +{$ELSE} + JMP VariantManager.VarFromCurr +{$ENDIF} +end; + +procedure _VarFromPStr(var V: Variant; const Value: ShortString); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromPStr(V, Value); +{$ELSE} +asm + JMP VariantManager.VarFromPStr +{$IFEND} +end; + +procedure _VarFromLStr(var V: Variant; const Value: string); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromLStr(V, Value); +{$ELSE} +asm + JMP VariantManager.VarFromLStr +{$IFEND} +end; + +procedure _VarFromWStr(var V: Variant; const Value: WideString); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromWStr(V, Value); +{$ELSE} +asm + JMP VariantManager.VarFromWStr +{$IFEND} +end; + +procedure _VarFromIntf(var V: Variant; const Value: IInterface); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromIntf(V, Value); +{$ELSE} +asm + JMP VariantManager.VarFromIntf +{$IFEND} +end; + +procedure _VarFromDisp(var V: Variant; const Value: IDispatch); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromDisp(V, Value); +{$ELSE} +asm + JMP VariantManager.VarFromDisp +{$IFEND} +end; + +procedure _VarFromDynArray(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromDynArray(V, DynArray, TypeInfo); +{$ELSE} +asm + JMP VariantManager.VarFromDynArray +{$IFEND} +end; + +procedure _OleVarFromPStr(var V: OleVariant; const Value: ShortString); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.OleVarFromPStr(V, Value); +{$ELSE} +asm + JMP VariantManager.OleVarFromPStr +{$IFEND} +end; + +procedure _OleVarFromLStr(var V: OleVariant; const Value: string); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.OleVarFromLStr(V, Value); +{$ELSE} +asm + JMP VariantManager.OleVarFromLStr +{$IFEND} +end; + +procedure _OleVarFromVar(var V: OleVariant; const Value: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.OleVarFromVar(V, Value); +{$ELSE} +asm + JMP VariantManager.OleVarFromVar +{$IFEND} +end; + +procedure _OleVarFromInt(var V: OleVariant; const Value, Range: Integer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.OleVarFromInt(V, Value, Range); +{$ELSE} +asm + JMP VariantManager.OleVarFromInt +{$IFEND} +end; + +procedure _VarAdd(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opAdd); +{$ELSE} +asm + MOV ECX,opAdd + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarSub(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opSubtract); +{$ELSE} +asm + MOV ECX,opSubtract + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarMul(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opMultiply); +{$ELSE} +asm + MOV ECX,opMultiply + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarDiv(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opIntDivide); +{$ELSE} +asm + MOV ECX,opIntDivide + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarMod(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opModulus); +{$ELSE} +asm + MOV ECX,opModulus + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarAnd(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opAnd); +{$ELSE} +asm + MOV ECX,opAnd + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarOr(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opOr); +{$ELSE} +asm + MOV ECX,opOr + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarXor(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opXor); +{$ELSE} +asm + MOV ECX,opXor + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarShl(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opShiftLeft); +{$ELSE} +asm + MOV ECX,opShiftLeft + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarShr(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opShiftRight); +{$ELSE} +asm + MOV ECX,opShiftRight + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarRDiv(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opDivide); +{$ELSE} +asm + MOV ECX,opDivide + JMP VariantManager.VarOp +{$IFEND} +end; + +{$IF Defined(PIC) or Defined(PUREPASCAL)} +// result is set in the flags +procedure DoVarCmp(const Left, Right: Variant; OpCode: Integer); +begin + VariantManager.VarCmp(TVarData(Left), TVarData(Right), OpCode); +end; +{$IFEND} + +procedure _VarCmpEQ(const Left, Right: Variant); // result is set in the flags +asm + MOV ECX, opCmpEQ +{$IFDEF PIC} + JMP DoVarCmp +{$ELSE} + JMP VariantManager.VarCmp +{$ENDIF} +end; + +procedure _VarCmpNE(const Left, Right: Variant); // result is set in the flags +asm + MOV ECX, opCmpNE +{$IFDEF PIC} + JMP DoVarCmp +{$ELSE} + JMP VariantManager.VarCmp +{$ENDIF} +end; + +procedure _VarCmpLT(const Left, Right: Variant); // result is set in the flags +asm + MOV ECX, opCmpLT +{$IFDEF PIC} + JMP DoVarCmp +{$ELSE} + JMP VariantManager.VarCmp +{$ENDIF} +end; + +procedure _VarCmpLE(const Left, Right: Variant); // result is set in the flags +asm + MOV ECX, opCmpLE +{$IFDEF PIC} + JMP DoVarCmp +{$ELSE} + JMP VariantManager.VarCmp +{$ENDIF} +end; + +procedure _VarCmpGT(const Left, Right: Variant); // result is set in the flags +asm + MOV ECX, opCmpGT +{$IFDEF PIC} + JMP DoVarCmp +{$ELSE} + JMP VariantManager.VarCmp +{$ENDIF} +end; + +procedure _VarCmpGE(const Left, Right: Variant); // result is set in the flags +asm + MOV ECX, opCmpGE +{$IFDEF PIC} + JMP DoVarCmp +{$ELSE} + JMP VariantManager.VarCmp +{$ENDIF} +end; + + +procedure _VarNeg(var V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarNeg(V); +{$ELSE} +asm + JMP VariantManager.VarNeg +{$IFEND} +end; + +procedure _VarNot(var V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarNot(V); +{$ELSE} +asm + JMP VariantManager.VarNot +{$IFEND} +end; + +procedure _VarCopyNoInd; +asm +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + POP ECX + LEA EAX,[EAX].OFFSET VariantManager + MOV EAX,[EAX].TVariantManager.VarCopyNoInd + XCHG EAX,[ESP] + RET +{$ELSE} + JMP VariantManager.VarCopyNoInd +{$ENDIF} +end; + +procedure _VarClr(var V: Variant); +asm + PUSH EAX + CALL _VarClear + POP EAX +end; + +procedure _VarAddRef(var V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarAddRef(V); +{$ELSE} +asm + JMP VariantManager.VarAddRef +{$IFEND} +end; + +procedure _IntfDispCall; +asm +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + POP ECX + LEA EAX,[EAX].OFFSET DispCallByIDProc + MOV EAX,[EAX] + XCHG EAX,[ESP] + RET +{$ELSE} + JMP DispCallByIDProc +{$ENDIF} +end; + +procedure _DispCallByIDError; +asm + MOV AL,reVarDispatch + JMP Error +end; + +procedure _IntfVarCall; +asm +end; + +function _WriteVariant(var T: Text; const V: Variant; Width: Integer): Pointer; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.WriteVariant(T, V, Width); +{$ELSE} +asm + JMP VariantManager.WriteVariant +{$IFEND} +end; + +function _Write0Variant(var T: Text; const V: Variant): Pointer; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.Write0Variant(T, V); +{$ELSE} +asm + JMP VariantManager.Write0Variant +{$IFEND} +end; + +{ ----------------------------------------------------- } +{ Variant array support } +{ ----------------------------------------------------- } + +procedure _VarArrayRedim(var A : Variant; HighBound: Integer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarArrayRedim(A, HighBound); +{$ELSE} +asm + JMP VariantManager.VarArrayRedim +{$IFEND} +end; + +function _VarArrayGet(var A: Variant; IndexCount: Integer; + Indices: Integer): Variant; cdecl; +asm + POP EBP +{$IFDEF PIC} + CALL GetGOT + LEA EAX,[EAX].OFFSET VariantManager + MOV EAX,[EAX].TVariantManager.VarArrayGet + PUSH EAX + RET +{$ELSE} + JMP VariantManager.VarArrayGet +{$ENDIF} +end; + +procedure _VarArrayPut(var A: Variant; const Value: Variant; + IndexCount: Integer; Indices: Integer); cdecl; +asm + POP EBP +{$IFDEF PIC} + CALL GetGOT + LEA EAX,[EAX].OFFSET VariantManager + MOV EAX,[EAX].TVariantManager.VarArrayPut + PUSH EAX + RET +{$ELSE} + JMP VariantManager.VarArrayPut +{$ENDIF} +end; + +// 64 bit integer helper routines +// +// These functions always return the 64-bit result in EAX:EDX + +// ------------------------------------------------------------------------------ +// 64-bit signed multiply +// ------------------------------------------------------------------------------ +// +// Param 1(EAX:EDX), Param 2([ESP+8]:[ESP+4]) ; before reg pushing +// + +procedure __llmul; +asm + push edx + push eax + + // Param2 : [ESP+16]:[ESP+12] (hi:lo) + // Param1 : [ESP+4]:[ESP] (hi:lo) + + mov eax, [esp+16] + mul dword ptr [esp] + mov ecx, eax + + mov eax, [esp+4] + mul dword ptr [esp+12] + add ecx, eax + + mov eax, [esp] + mul dword ptr [esp+12] + add edx, ecx + + pop ecx + pop ecx + + ret 8 +end; + +// ------------------------------------------------------------------------------ +// 64-bit signed multiply, with overflow check (98.05.15: overflow not supported yet) +// ------------------------------------------------------------------------------ +// +// Param1 ~= U (Uh, Ul) +// Param2 ~= V (Vh, Vl) +// +// Param 1(EAX:EDX), Param 2([ESP+8]:[ESP+4]) ; before reg pushing +// +// compiler-helper function +// O-flag set on exit => result is invalid +// O-flag clear on exit => result is valid + +procedure __llmulo; +asm + push edx + push eax + + // Param2 : [ESP+16]:[ESP+12] (hi:lo) + // Param1 : [ESP+4]:[ESP] (hi:lo) + + mov eax, [esp+16] + mul dword ptr [esp] + mov ecx, eax + + mov eax, [esp+4] + mul dword ptr [esp+12] + add ecx, eax + + mov eax, [esp] + mul dword ptr [esp+12] + add edx, ecx + + pop ecx + pop ecx + + ret 8 +end; + +// ------------------------------------------------------------------------------ +// 64-bit signed division +// ------------------------------------------------------------------------------ + +// +// Dividend = Numerator, Divisor = Denominator +// +// Dividend(EAX:EDX), Divisor([ESP+8]:[ESP+4]) ; before reg pushing +// +// + +procedure __lldiv; +asm + push ebp + push ebx + push esi + push edi + xor edi,edi + + mov ebx,20[esp] // get the divisor low dword + mov ecx,24[esp] // get the divisor high dword + + or ecx,ecx + jnz @__lldiv@slow_ldiv // both high words are zero + + or edx,edx + jz @__lldiv@quick_ldiv + + or ebx,ebx + jz @__lldiv@quick_ldiv // if ecx:ebx == 0 force a zero divide + // we don't expect this to actually + // work + +@__lldiv@slow_ldiv: + +// +// Signed division should be done. Convert negative +// values to positive and do an unsigned division. +// Store the sign value in the next higher bit of +// di (test mask of 4). Thus when we are done, testing +// that bit will determine the sign of the result. +// + or edx,edx // test sign of dividend + jns @__lldiv@onepos + neg edx + neg eax + sbb edx,0 // negate dividend + or edi,1 + +@__lldiv@onepos: + or ecx,ecx // test sign of divisor + jns @__lldiv@positive + neg ecx + neg ebx + sbb ecx,0 // negate divisor + xor edi,1 + +@__lldiv@positive: + mov ebp,ecx + mov ecx,64 // shift counter + push edi // save the flags +// +// Now the stack looks something like this: +// +// 24[esp]: divisor (high dword) +// 20[esp]: divisor (low dword) +// 16[esp]: return EIP +// 12[esp]: previous EBP +// 8[esp]: previous EBX +// 4[esp]: previous ESI +// [esp]: previous EDI +// + xor edi,edi // fake a 64 bit dividend + xor esi,esi + +@__lldiv@xloop: + shl eax,1 // shift dividend left one bit + rcl edx,1 + rcl esi,1 + rcl edi,1 + cmp edi,ebp // dividend larger? + jb @__lldiv@nosub + ja @__lldiv@subtract + cmp esi,ebx // maybe + jb @__lldiv@nosub + +@__lldiv@subtract: + sub esi,ebx + sbb edi,ebp // subtract the divisor + inc eax // build quotient + +@__lldiv@nosub: + loop @__lldiv@xloop +// +// When done with the loop the four registers values' look like: +// +// | edi | esi | edx | eax | +// | remainder | quotient | +// + pop ebx // get control bits + test ebx,1 // needs negative + jz @__lldiv@finish + neg edx + neg eax + sbb edx,0 // negate + +@__lldiv@finish: + pop edi + pop esi + pop ebx + pop ebp + ret 8 + +@__lldiv@quick_ldiv: + div ebx // unsigned divide + xor edx,edx + jmp @__lldiv@finish +end; + +// ------------------------------------------------------------------------------ +// 64-bit signed division with overflow check (98.05.15: not implementated yet) +// ------------------------------------------------------------------------------ + +// +// Dividend = Numerator, Divisor = Denominator +// +// Dividend(EAX:EDX), Divisor([ESP+8]:[ESP+4]) +// Param 1 (EAX:EDX), Param 2([ESP+8]:[ESP+4]) +// +// Param1 ~= U (Uh, Ul) +// Param2 ~= V (Vh, Vl) +// +// compiler-helper function +// O-flag set on exit => result is invalid +// O-flag clear on exit => result is valid +// + +procedure __lldivo; +asm + // check for overflow condition: min(int64) DIV -1 + push esi + mov esi, [esp+12] // Vh + and esi, [esp+8] // Vl + cmp esi, 0ffffffffh // V = -1? + jne @@divok + + mov esi, eax + or esi, edx + cmp esi, 80000000H // U = min(int64)? + jne @@divok + +@@divOvl: + mov eax, esi + pop esi + dec eax // turn on O-flag + ret + +@@divok: + pop esi + push dword ptr [esp+8] // Vh + push dword ptr [esp+8] // Vl (offset is changed from push) + call __lldiv + and eax, eax // turn off O-flag + ret 8 +end; + +// ------------------------------------------------------------------------------ +// 64-bit unsigned division +// ------------------------------------------------------------------------------ + +// Dividend(EAX(hi):EDX(lo)), Divisor([ESP+8](hi):[ESP+4](lo)) // before reg pushing +procedure __lludiv; +asm + push ebp + push ebx + push esi + push edi +// +// Now the stack looks something like this: +// +// 24[esp]: divisor (high dword) +// 20[esp]: divisor (low dword) +// 16[esp]: return EIP +// 12[esp]: previous EBP +// 8[esp]: previous EBX +// 4[esp]: previous ESI +// [esp]: previous EDI +// + +// dividend is pushed last, therefore the first in the args +// divisor next. +// + mov ebx,20[esp] // get the first low word + mov ecx,24[esp] // get the first high word + + or ecx,ecx + jnz @__lludiv@slow_ldiv // both high words are zero + + or edx,edx + jz @__lludiv@quick_ldiv + + or ebx,ebx + jz @__lludiv@quick_ldiv // if ecx:ebx == 0 force a zero divide + // we don't expect this to actually + // work + +@__lludiv@slow_ldiv: + mov ebp,ecx + mov ecx,64 // shift counter + xor edi,edi // fake a 64 bit dividend + xor esi,esi + +@__lludiv@xloop: + shl eax,1 // shift dividend left one bit + rcl edx,1 + rcl esi,1 + rcl edi,1 + cmp edi,ebp // dividend larger? + jb @__lludiv@nosub + ja @__lludiv@subtract + cmp esi,ebx // maybe + jb @__lludiv@nosub + +@__lludiv@subtract: + sub esi,ebx + sbb edi,ebp // subtract the divisor + inc eax // build quotient + +@__lludiv@nosub: + loop @__lludiv@xloop +// +// When done with the loop the four registers values' look like: +// +// | edi | esi | edx | eax | +// | remainder | quotient | +// + +@__lludiv@finish: + pop edi + pop esi + pop ebx + pop ebp + ret 8 + +@__lludiv@quick_ldiv: + div ebx // unsigned divide + xor edx,edx + jmp @__lludiv@finish +end; + +// ------------------------------------------------------------------------------ +// 64-bit modulo +// ------------------------------------------------------------------------------ + +// Dividend(EAX:EDX), Divisor([ESP+8]:[ESP+4]) // before reg pushing +procedure __llmod; +asm + push ebp + push ebx + push esi + push edi + xor edi,edi +// +// dividend is pushed last, therefore the first in the args +// divisor next. +// + mov ebx,20[esp] // get the first low word + mov ecx,24[esp] // get the first high word + or ecx,ecx + jnz @__llmod@slow_ldiv // both high words are zero + + or edx,edx + jz @__llmod@quick_ldiv + + or ebx,ebx + jz @__llmod@quick_ldiv // if ecx:ebx == 0 force a zero divide + // we don't expect this to actually + // work +@__llmod@slow_ldiv: +// +// Signed division should be done. Convert negative +// values to positive and do an unsigned division. +// Store the sign value in the next higher bit of +// di (test mask of 4). Thus when we are done, testing +// that bit will determine the sign of the result. +// + or edx,edx // test sign of dividend + jns @__llmod@onepos + neg edx + neg eax + sbb edx,0 // negate dividend + or edi,1 + +@__llmod@onepos: + or ecx,ecx // test sign of divisor + jns @__llmod@positive + neg ecx + neg ebx + sbb ecx,0 // negate divisor + +@__llmod@positive: + mov ebp,ecx + mov ecx,64 // shift counter + push edi // save the flags +// +// Now the stack looks something like this: +// +// 24[esp]: divisor (high dword) +// 20[esp]: divisor (low dword) +// 16[esp]: return EIP +// 12[esp]: previous EBP +// 8[esp]: previous EBX +// 4[esp]: previous ESI +// [esp]: previous EDI +// + xor edi,edi // fake a 64 bit dividend + xor esi,esi + +@__llmod@xloop: + shl eax,1 // shift dividend left one bit + rcl edx,1 + rcl esi,1 + rcl edi,1 + cmp edi,ebp // dividend larger? + jb @__llmod@nosub + ja @__llmod@subtract + cmp esi,ebx // maybe + jb @__llmod@nosub + +@__llmod@subtract: + sub esi,ebx + sbb edi,ebp // subtract the divisor + inc eax // build quotient + +@__llmod@nosub: + loop @__llmod@xloop +// +// When done with the loop the four registers values' look like: +// +// | edi | esi | edx | eax | +// | remainder | quotient | +// + mov eax,esi + mov edx,edi // use remainder + + pop ebx // get control bits + test ebx,1 // needs negative + jz @__llmod@finish + neg edx + neg eax + sbb edx,0 // negate + +@__llmod@finish: + pop edi + pop esi + pop ebx + pop ebp + ret 8 + +@__llmod@quick_ldiv: + div ebx // unsigned divide + xchg eax,edx + xor edx,edx + jmp @__llmod@finish +end; + +// ------------------------------------------------------------------------------ +// 64-bit signed modulo with overflow (98.05.15: overflow not yet supported) +// ------------------------------------------------------------------------------ + +// Dividend(EAX:EDX), Divisor([ESP+8]:[ESP+4]) +// Param 1 (EAX:EDX), Param 2([ESP+8]:[ESP+4]) +// +// Param1 ~= U (Uh, Ul) +// Param2 ~= V (Vh, Vl) +// +// compiler-helper function +// O-flag set on exit => result is invalid +// O-flag clear on exit => result is valid +// + +procedure __llmodo; +asm + // check for overflow condition: min(int64) MOD -1 + push esi + mov esi, [esp+12] // Vh + and esi, [esp+8] // Vl + cmp esi, 0ffffffffh // V = -1? + jne @@modok + + mov esi, eax + or esi, edx + cmp esi, 80000000H // U = min(int64)? + jne @@modok + +@@modOvl: + mov eax, esi + pop esi + dec eax // turn on O-flag + ret + +@@modok: + pop esi + push dword ptr [esp+8] // Vh + push dword ptr [esp+8] // Vl (offset is changed from push) + call __llmod + and eax, eax // turn off O-flag + ret 8 +end; + +// ------------------------------------------------------------------------------ +// 64-bit unsigned modulo +// ------------------------------------------------------------------------------ +// Dividend(EAX(hi):EDX(lo)), Divisor([ESP+8](hi):[ESP+4](lo)) // before reg pushing + +procedure __llumod; +asm + push ebp + push ebx + push esi + push edi +// +// Now the stack looks something like this: +// +// 24[esp]: divisor (high dword) +// 20[esp]: divisor (low dword) +// 16[esp]: return EIP +// 12[esp]: previous EBP +// 8[esp]: previous EBX +// 4[esp]: previous ESI +// [esp]: previous EDI +// + +// dividend is pushed last, therefore the first in the args +// divisor next. +// + mov ebx,20[esp] // get the first low word + mov ecx,24[esp] // get the first high word + or ecx,ecx + jnz @__llumod@slow_ldiv // both high words are zero + + or edx,edx + jz @__llumod@quick_ldiv + + or ebx,ebx + jz @__llumod@quick_ldiv // if ecx:ebx == 0 force a zero divide + // we don't expect this to actually + // work +@__llumod@slow_ldiv: + mov ebp,ecx + mov ecx,64 // shift counter + xor edi,edi // fake a 64 bit dividend + xor esi,esi // + +@__llumod@xloop: + shl eax,1 // shift dividend left one bit + rcl edx,1 + rcl esi,1 + rcl edi,1 + cmp edi,ebp // dividend larger? + jb @__llumod@nosub + ja @__llumod@subtract + cmp esi,ebx // maybe + jb @__llumod@nosub + +@__llumod@subtract: + sub esi,ebx + sbb edi,ebp // subtract the divisor + inc eax // build quotient + +@__llumod@nosub: + loop @__llumod@xloop +// +// When done with the loop the four registers values' look like: +// +// | edi | esi | edx | eax | +// | remainder | quotient | +// + mov eax,esi + mov edx,edi // use remainder + +@__llumod@finish: + pop edi + pop esi + pop ebx + pop ebp + ret 8 + +@__llumod@quick_ldiv: + div ebx // unsigned divide + xchg eax,edx + xor edx,edx + jmp @__llumod@finish +end; + +// ------------------------------------------------------------------------------ +// 64-bit shift left +// ------------------------------------------------------------------------------ + +// +// target (EAX:EDX) count (ECX) +// +procedure __llshl; +asm + cmp cl, 32 + jl @__llshl@below32 + cmp cl, 64 + jl @__llshl@below64 + xor edx, edx + xor eax, eax + ret + +@__llshl@below64: + mov edx, eax + shl edx, cl + xor eax, eax + ret + +@__llshl@below32: + shld edx, eax, cl + shl eax, cl + ret +end; + +// ------------------------------------------------------------------------------ +// 64-bit signed shift right +// ------------------------------------------------------------------------------ +// target (EAX:EDX) count (ECX) + +procedure __llshr; +asm + cmp cl, 32 + jl @__llshr@below32 + cmp cl, 64 + jl @__llshr@below64 + sar edx, 1fh + mov eax,edx + ret + +@__llshr@below64: + mov eax, edx + cdq + sar eax,cl + ret + +@__llshr@below32: + shrd eax, edx, cl + sar edx, cl + ret +end; + +// ------------------------------------------------------------------------------ +// 64-bit unsigned shift right +// ------------------------------------------------------------------------------ + +// target (EAX:EDX) count (ECX) +procedure __llushr; +asm + cmp cl, 32 + jl @__llushr@below32 + cmp cl, 64 + jl @__llushr@below64 + xor edx, edx + xor eax, eax + ret + +@__llushr@below64: + mov eax, edx + xor edx, edx + shr eax, cl + ret + +@__llushr@below32: + shrd eax, edx, cl + shr edx, cl + ret +end; + +function _StrInt64(val: Int64; width: Integer): ShortString; +var + d: array[0..31] of Char; { need 19 digits and a sign } + i, k: Integer; + sign: Boolean; + spaces: Integer; +begin + { Produce an ASCII representation of the number in reverse order } + i := 0; + sign := val < 0; + repeat + d[i] := Chr( Abs(val mod 10) + Ord('0') ); + Inc(i); + val := val div 10; + until val = 0; + if sign then + begin + d[i] := '-'; + Inc(i); + end; + + { Fill the Result with the appropriate number of blanks } + if width > 255 then + width := 255; + k := 1; + spaces := width - i; + while k <= spaces do + begin + Result[k] := ' '; + Inc(k); + end; + + { Fill the Result with the number } + while i > 0 do + begin + Dec(i); + Result[k] := d[i]; + Inc(k); + end; + + { Result is k-1 characters long } + SetLength(Result, k-1); + +end; + +function _Str0Int64(val: Int64): ShortString; +begin + Result := _StrInt64(val, 0); +end; + +procedure _WriteInt64; +asm +{ PROCEDURE _WriteInt64( VAR t: Text; val: Int64; with: Longint); } +{ ->EAX Pointer to file record } +{ [ESP+4] Value } +{ EDX Field width } + + SUB ESP,32 { VAR s: String[31]; } + + PUSH EAX + PUSH EDX + + PUSH dword ptr [ESP+8+32+8] { Str( val : 0, s ); } + PUSH dword ptr [ESP+8+32+8] + XOR EAX,EAX + LEA EDX,[ESP+8+8] + CALL _StrInt64 + + POP ECX + POP EAX + + MOV EDX,ESP { Write( t, s : width );} + CALL _WriteString + + ADD ESP,32 + RET 8 +end; + +procedure _Write0Int64; +asm +{ PROCEDURE _Write0Long( VAR t: Text; val: Longint); } +{ ->EAX Pointer to file record } +{ EDX Value } + XOR EDX,EDX + JMP _WriteInt64 +end; + +procedure _ReadInt64; +asm + // -> EAX Pointer to text record + // <- EAX:EDX Result + + PUSH EBX + PUSH ESI + PUSH EDI + SUB ESP,36 // var numbuf: String[32]; + + MOV ESI,EAX + CALL _SeekEof + DEC AL + JZ @@eof + + MOV EDI,ESP // EDI -> numBuf[0] + MOV BL,32 +@@loop: + MOV EAX,ESI + CALL _ReadChar + CMP AL,' ' + JBE @@endNum + STOSB + DEC BL + JNZ @@loop +@@convert: + MOV byte ptr [EDI],0 + MOV EAX,ESP // EAX -> numBuf + PUSH EDX // allocate code result + MOV EDX,ESP // pass pointer to code + CALL _ValInt64 // convert + POP ECX // pop code result into EDX + TEST ECX,ECX + JZ @@exit + MOV EAX,106 + CALL SetInOutRes + +@@exit: + ADD ESP,36 + POP EDI + POP ESI + POP EBX + RET + +@@endNum: + CMP AH,cEof + JE @@convert + DEC [ESI].TTextRec.BufPos + JMP @@convert + +@@eof: + XOR EAX,EAX + JMP @@exit +end; + +function _ValInt64(const s: AnsiString; var code: Integer): Int64; +var + i: Integer; + dig: Integer; + sign: Boolean; + empty: Boolean; +begin + i := 1; + dig := 0; + Result := 0; + if s = '' then + begin + code := i; + exit; + end; + while s[i] = ' ' do + Inc(i); + sign := False; + if s[i] = '-' then + begin + sign := True; + Inc(i); + end + else if s[i] = '+' then + Inc(i); + empty := True; + if (s[i] = '$') or (s[i] = '0') and (Upcase(s[i+1]) = 'X') then + begin + if s[i] = '0' then + Inc(i); + Inc(i); + while True do + begin + case s[i] of + '0'..'9': dig := Ord(s[i]) - Ord('0'); + 'A'..'F': dig := Ord(s[i]) - (Ord('A') - 10); + 'a'..'f': dig := Ord(s[i]) - (Ord('a') - 10); + else + break; + end; + if (Result < 0) or (Result > (High(Int64) div 16)) then + break; + Result := Result shl 4 + dig; + Inc(i); + empty := False; + end; + if sign then + Result := - Result; + end + else + begin + while True do + begin + case s[i] of + '0'..'9': dig := Ord(s[i]) - Ord('0'); + else + break; + end; + if (Result < 0) or (Result > (High(Int64) div 10)) then + break; + Result := Result*10 + dig; + Inc(i); + empty := False; + end; + if sign then + Result := - Result; + if (Result <> 0) and (sign <> (Result < 0)) then + Dec(i); + end; + if (s[i] <> #0) or empty then + code := i + else + code := 0; +end; + +procedure _DynArrayLength; +asm +{ FUNCTION _DynArrayLength(const a: array of ...): Longint; } +{ ->EAX Pointer to array or nil } +{ <-EAX High bound of array + 1 or 0 } + TEST EAX,EAX + JZ @@skip + MOV EAX,[EAX-4] +@@skip: +end; + +procedure _DynArrayHigh; +asm +{ FUNCTION _DynArrayHigh(const a: array of ...): Longint; } +{ ->EAX Pointer to array or nil } +{ <-EAX High bound of array or -1 } + CALL _DynArrayLength + DEC EAX +end; + +procedure CopyArray(dest, source, typeInfo: Pointer; cnt: Integer); +asm + PUSH dword ptr [EBP+8] + CALL _CopyArray +end; + +procedure FinalizeArray(p, typeInfo: Pointer; cnt: Integer); +asm + JMP _FinalizeArray +end; + +procedure DynArrayClear(var a: Pointer; typeInfo: Pointer); +asm + CALL _DynArrayClear +end; + +procedure DynArraySetLength(var a: Pointer; typeInfo: Pointer; dimCnt: Longint; lengthVec: PLongint); +var + i: Integer; + newLength, oldLength, minLength: Longint; + elSize: Longint; + neededSize: Longint; + p, pp: Pointer; +begin + p := a; + + // Fetch the new length of the array in this dimension, and the old length + newLength := PLongint(lengthVec)^; + if newLength <= 0 then + begin + if newLength < 0 then + Error(reRangeError); + DynArrayClear(a, typeInfo); + exit; + end; + + oldLength := 0; + if p <> nil then + begin + Dec(PLongint(p)); + oldLength := PLongint(p)^; + Dec(PLongint(p)); + end; + + // Calculate the needed size of the heap object + Inc(PChar(typeInfo), Length(PDynArrayTypeInfo(typeInfo).name)); + elSize := PDynArrayTypeInfo(typeInfo).elSize; + if PDynArrayTypeInfo(typeInfo).elType <> nil then + typeInfo := PDynArrayTypeInfo(typeInfo).elType^ + else + typeInfo := nil; + neededSize := newLength*elSize; + if neededSize div newLength <> elSize then + Error(reRangeError); + Inc(neededSize, Sizeof(Longint)*2); + + // If the heap object isn't shared (ref count = 1), just resize it. Otherwise, we make a copy + if (p = nil) or (PLongint(p)^ = 1) then + begin + pp := p; + if (newLength < oldLength) and (typeInfo <> nil) then + FinalizeArray(PChar(p) + Sizeof(Longint)*2 + newLength*elSize, typeInfo, oldLength - newLength); + ReallocMem(pp, neededSize); + p := pp; + end + else + begin + Dec(PLongint(p)^); + GetMem(p, neededSize); + minLength := oldLength; + if minLength > newLength then + minLength := newLength; + if typeInfo <> nil then + begin + FillChar((PChar(p) + Sizeof(Longint)*2)^, minLength*elSize, 0); + CopyArray(PChar(p) + Sizeof(Longint)*2, a, typeInfo, minLength) + end + else + Move(PChar(a)^, (PChar(p) + Sizeof(Longint)*2)^, minLength*elSize); + end; + + // The heap object will now have a ref count of 1 and the new length + PLongint(p)^ := 1; + Inc(PLongint(p)); + PLongint(p)^ := newLength; + Inc(PLongint(p)); + + // Set the new memory to all zero bits + FillChar((PChar(p) + elSize * oldLength)^, elSize * (newLength - oldLength), 0); + + // Take care of the inner dimensions, if any + if dimCnt > 1 then + begin + Inc(lengthVec); + Dec(dimCnt); + for i := 0 to newLength-1 do + DynArraySetLength(PPointerArray(p)[i], typeInfo, dimCnt, lengthVec); + end; + a := p; +end; + +procedure _DynArraySetLength; +asm +{ PROCEDURE _DynArraySetLength(var a: dynarray; typeInfo: PDynArrayTypeInfo; dimCnt: Longint; lengthVec: ^Longint) } +{ ->EAX Pointer to dynamic array (= pointer to pointer to heap object) } +{ EDX Pointer to type info for the dynamic array } +{ ECX number of dimensions } +{ [ESP+4] dimensions } + PUSH ESP + ADD dword ptr [ESP],4 + CALL DynArraySetLength +end; + +procedure _DynArrayCopy(a: Pointer; typeInfo: Pointer; var Result: Pointer); +begin + if a <> nil then + _DynArrayCopyRange(a, typeInfo, 0, PLongint(PChar(a)-4)^, Result) + else + _DynArrayClear(Result, typeInfo); +end; + +procedure _DynArrayCopyRange(a: Pointer; typeInfo: Pointer; index, count : Integer; var Result: Pointer); +var + arrayLength: Integer; + elSize: Integer; + typeInf: PDynArrayTypeInfo; + p: Pointer; +begin + p := nil; + if a <> nil then + begin + typeInf := typeInfo; + + // Limit index and count to values within the array + if index < 0 then + begin + Inc(count, index); + index := 0; + end; + arrayLength := PLongint(PChar(a)-4)^; + if index > arrayLength then + index := arrayLength; + if count > arrayLength - index then + count := arrayLength - index; + if count < 0 then + count := 0; + + if count > 0 then + begin + // Figure out the size and type descriptor of the element type + Inc(PChar(typeInf), Length(typeInf.name)); + elSize := typeInf.elSize; + if typeInf.elType <> nil then + typeInf := typeInf.elType^ + else + typeInf := nil; + + // Allocate the amount of memory needed + GetMem(p, count*elSize + Sizeof(Longint)*2); + + // The reference count of the new array is 1, the length is count + PLongint(p)^ := 1; + Inc(PLongint(p)); + PLongint(p)^ := count; + Inc(PLongint(p)); + Inc(PChar(a), index*elSize); + + // If the element type needs destruction, we must copy each element, + // otherwise we can just copy the bits + if count > 0 then + begin + if typeInf <> nil then + begin + FillChar(p^, count*elSize, 0); + CopyArray(p, a, typeInf, count) + end + else + Move(a^, p^, count*elSize); + end; + end; + end; + DynArrayClear(Result, typeInfo); + Result := p; +end; + +procedure _DynArrayClear; +asm +{ ->EAX Pointer to dynamic array (Pointer to pointer to heap object } +{ EDX Pointer to type info } + + { Nothing to do if Pointer to heap object is nil } + MOV ECX,[EAX] + TEST ECX,ECX + JE @@exit + + { Set the variable to be finalized to nil } + MOV dword ptr [EAX],0 + + { Decrement ref count. Nothing to do if not zero now. } +{X LOCK} DEC dword ptr [ECX-8] + JNE @@exit + + { Save the source - we're supposed to return it } + PUSH EAX + MOV EAX,ECX + + { Fetch the type descriptor of the elements } + XOR ECX,ECX + MOV CL,[EDX].TDynArrayTypeInfo.name; + MOV EDX,[EDX+ECX].TDynArrayTypeInfo.elType; + + { If it's non-nil, finalize the elements } + TEST EDX,EDX + JE @@noFinalize + MOV ECX,[EAX-4] + TEST ECX,ECX + JE @@noFinalize + MOV EDX,[EDX] + CALL _FinalizeArray +@@noFinalize: + { Now deallocate the array } + SUB EAX,8 + CALL _FreeMem + POP EAX +@@exit: +end; + + +procedure _DynArrayAsg; +asm +{ ->EAX Pointer to destination (pointer to pointer to heap object } +{ EDX source (pointer to heap object } +{ ECX Pointer to rtti describing dynamic array } + + PUSH EBX + MOV EBX,[EAX] + + { Increment ref count of source if non-nil } + + TEST EDX,EDX + JE @@skipInc +{X LOCK} INC dword ptr [EDX-8] +@@skipInc: + { Dec ref count of destination - if it becomes 0, clear dest } + TEST EBX,EBX + JE @@skipClear +{X LOCK} DEC dword ptr[EBX-8] + JNZ @@skipClear + PUSH EAX + PUSH EDX + MOV EDX,ECX + INC dword ptr[EBX-8] + CALL _DynArrayClear + POP EDX + POP EAX +@@skipClear: + { Finally store source into destination } + MOV [EAX],EDX + + POP EBX +end; + +procedure _DynArrayAddRef; +asm +{ ->EAX Pointer to heap object } + TEST EAX,EAX + JE @@exit +{X LOCK} INC dword ptr [EAX-8] +@@exit: +end; + + +function DynArrayIndex(const P: Pointer; const Indices: array of Integer; const TypInfo: Pointer): Pointer; +asm + { ->EAX P } + { EDX Pointer to Indices } + { ECX High bound of Indices } + { [EBP+8] TypInfo } + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV ESI,EDX + MOV EDI,[EBP+8] + MOV EBP,EAX + + XOR EBX,EBX { for i := 0 to High(Indices) do } + TEST ECX,ECX + JGE @@start +@@loop: + MOV EBP,[EBP] +@@start: + XOR EAX,EAX + MOV AL,[EDI].TDynArrayTypeInfo.name + ADD EDI,EAX + MOV EAX,[ESI+EBX*4] { P := P + Indices[i]*TypInfo.elSize } + MUL [EDI].TDynArrayTypeInfo.elSize + MOV EDI,[EDI].TDynArrayTypeInfo.elType + TEST EDI,EDI + JE @@skip + MOV EDI,[EDI] +@@skip: + ADD EBP,EAX + INC EBX + CMP EBX,ECX + JLE @@loop + +@@loopEnd: + + MOV EAX,EBP + + POP EBP + POP EDI + POP ESI + POP EBX +end; + + +{ Returns the DynArrayTypeInfo of the Element Type of the specified DynArrayTypeInfo } +function DynArrayElTypeInfo(typeInfo: PDynArrayTypeInfo): PDynArrayTypeInfo; +begin + Result := nil; + if typeInfo <> nil then + begin + Inc(PChar(typeInfo), Length(typeInfo.name)); + if typeInfo.elType <> nil then + Result := typeInfo.elType^; + end; +end; + +{ Returns # of dimemsions of the DynArray described by the specified DynArrayTypeInfo} +function DynArrayDim(typeInfo: PDynArrayTypeInfo): Integer; +begin + Result := 0; + while (typeInfo <> nil) and (typeInfo.kind = tkDynArray) do + begin + Inc(Result); + typeInfo := DynArrayElTypeInfo(typeInfo); + end; +end; + +{ Returns size of the Dynamic Array} +function DynArraySize(a: Pointer): Integer; +asm + TEST EAX, EAX + JZ @@exit + MOV EAX, [EAX-4] +@@exit: +end; + +// Returns whether array is rectangular +function IsDynArrayRectangular(const DynArray: Pointer; typeInfo: PDynArrayTypeInfo): Boolean; +var + Dim, I, J, Size, SubSize: Integer; + P: Pointer; +begin + // Assume we have a rectangular array + Result := True; + + P := DynArray; + Dim := DynArrayDim(typeInfo); + + {NOTE: Start at 1. Don't need to test the first dimension - it's rectangular by definition} + for I := 1 to dim-1 do + begin + if P <> nil then + begin + { Get size of this dimension } + Size := DynArraySize(P); + + { Get Size of first sub. dimension } + SubSize := DynArraySize(PPointerArray(P)[0]); + + { Walk through every dimension making sure they all have the same size} + for J := 1 to Size-1 do + if DynArraySize(PPointerArray(P)[J]) <> SubSize then + begin + Result := False; + Exit; + end; + + { Point to next dimension} + P := PPointerArray(P)[0]; + end; + end; +end; + +// Returns Bounds of Dynamic array as an array of integer containing the 'high' of each dimension +function DynArrayBounds(const DynArray: Pointer; typeInfo: PDynArrayTypeInfo): TBoundArray; +var + Dim, I: Integer; + P: Pointer; +begin + P := DynArray; + + Dim := DynArrayDim(typeInfo); + SetLength(Result, Dim); + + for I := 0 to dim-1 do + if P <> nil then + begin + Result[I] := DynArraySize(P)-1; + P := PPointerArray(P)[0]; // Assume rectangular arrays + end; +end; + +{ Decrements to next lower index - Returns True if successful } +{ Indices: Indices to be decremented } +{ Bounds : High bounds of each dimension } +function DecIndices(var Indices: TBoundArray; const Bounds: TBoundArray): Boolean; +var + I, J: Integer; +begin + { Find out if we're done: all at zeroes } + Result := False; + for I := Low(Indices) to High(Indices) do + if Indices[I] <> 0 then + begin + Result := True; + break; + end; + if not Result then + Exit; + + { Two arrays must be of same length } + Assert(Length(Indices) = Length(Bounds)); + + { Find index of item to tweak } + for I := High(Indices) downto Low(Bounds) do + begin + // If not reach zero, dec and bail out + if Indices[I] <> 0 then + begin + Dec(Indices[I]); + Exit; + end + else + begin + J := I; + while Indices[J] = 0 do + begin + // Restore high bound when we've reached zero on a particular dimension + Indices[J] := Bounds[J]; + // Move to higher dimension + Dec(J); + Assert(J >= 0); + end; + Dec(Indices[J]); + Exit; + end; + end; +end; + +{ Package/Module registration/unregistration } + +{$IFDEF MSWINDOWS} +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 +{$ENDIF} + +function FindModule(Instance: LongWord): PLibModule; +begin + Result := LibModuleList; + while Result <> nil do + begin + if (Instance = Result.Instance) or + (Instance = Result.CodeInstance) or + (Instance = Result.DataInstance) or + (Instance = Result.ResInstance) then + Exit; + Result := Result.Next; + end; +end; + +function FindHInstance(Address: Pointer): LongWord; +{$IFDEF MSWINDOWS} +var + MemInfo: TMemInfo; +begin + VirtualQuery(Address, MemInfo, SizeOf(MemInfo)); + if MemInfo.State = $1000{MEM_COMMIT} then + Result := LongWord(MemInfo.AllocationBase) + else + Result := 0; +end; +{$ENDIF} +{$IFDEF LINUX} +var + Info: TDLInfo; +begin + if (dladdr(Address, Info) = 0) or (Info.BaseAddress = ExeBaseAddress) then + Info.Filename := nil; // if it's not in a library, assume the exe + Result := LongWord(dlopen(Info.Filename, RTLD_LAZY)); + if Result <> 0 then + dlclose(Result); +end; +{$ENDIF} + +function FindClassHInstance(ClassType: TClass): LongWord; +begin + Result := FindHInstance(Pointer(ClassType)); +end; + +{$IFDEF LINUX} +function GetModuleFileName(Module: HMODULE; Buffer: PChar; BufLen: Integer): Integer; +var + Addr: Pointer; + Info: TDLInfo; + FoundInModule: HMODULE; +begin + Result := 0; + if (Module = MainInstance) or (Module = 0) then + begin + // First, try the dlsym approach. + // dladdr fails to return the name of the main executable + // in glibc prior to 2.1.91 + +{ Look for a dynamic symbol exported from this program. + _DYNAMIC is not required in a main program file. + If the main program is compiled with Delphi, it will always + have a resource section, named @Sysinit@ResSym. + If the main program is not compiled with Delphi, dlsym + will search the global name space, potentially returning + the address of a symbol in some other shared object library + loaded by the program. To guard against that, we check + that the address of the symbol found is within the + main program address range. } + + dlerror; // clear error state; dlsym doesn't + Addr := dlsym(Module, '@Sysinit@ResSym'); + if (Addr <> nil) and (dlerror = nil) + and (dladdr(Addr, Info) <> 0) + and (Info.FileName <> nil) + and (Info.BaseAddress = ExeBaseAddress) then + begin + Result := _strlen(Info.FileName); + if Result >= BufLen then Result := BufLen-1; + Move(Info.FileName^, Buffer^, Result); + Buffer[Result] := #0; + Exit; + end; + + // Try inspecting the /proc/ virtual file system + // to find the program filename in the process info + Result := _readlink('/proc/self/exe', Buffer, BufLen); + if Result <> -1 then + begin + if Result >= BufLen then Result := BufLen-1; + Buffer[Result] := #0; + end; +{$IFDEF AllowParamStrModuleName} +{ Using ParamStr(0) to obtain a module name presents a potential + security hole. Resource modules are loaded based upon the filename + of a given module. We use dlopen() to load resource modules, which + means the .init code of the resource module will be executed. + Normally, resource modules contain no code at all - they're just + carriers of resource data. + An unpriviledged user program could launch our trusted, + priviledged program with a bogus parameter list, tricking us + into loading a module that contains malicious code in its + .init section. + Without this ParamStr(0) section, GetModuleFilename cannot be + misdirected by unpriviledged code (unless the system program loader + or the /proc file system or system root directory has been compromised). + Resource modules are always loaded from the same directory as the + given module. Trusted code (programs, packages, and libraries) + should reside in directories that unpriviledged code cannot alter. + + If you need GetModuleFilename to have a chance of working on systems + where glibc < 2.1.91 and /proc is not available, and your + program will not run as a priviledged user (or you don't care), + you can define AllowParamStrModuleNames and rebuild the System unit + and baseCLX package. Note that even with ParamStr(0) support + enabled, GetModuleFilename can still fail to find the name of + a module. C'est la Unix. } + + if Result = -1 then // couldn't access the /proc filesystem + begin // return less accurate ParamStr(0) + +{ ParamStr(0) returns the name of the link used + to launch the app, not the name of the app itself. + Also, if this app was launched by some other program, + there is no guarantee that the launching program has set + up our environment at all. (example: Apache CGI) } + + if (ArgValues = nil) or (ArgValues^ = nil) or + (PCharArray(ArgValues^)[0] = nil) then + begin + Result := 0; + Exit; + end; + Result := _strlen(PCharArray(ArgValues^)[0]); + if Result >= BufLen then Result := BufLen-1; + Move(PCharArray(ArgValues^)[0]^, Buffer^, Result); + Buffer[Result] := #0; + end; +{$ENDIF} + end + else + begin +{ For shared object libraries, we can rely on the dlsym technique. + Look for a dynamic symbol in the requested module. + Don't assume the module was compiled with Delphi. + We look for a dynamic symbol with the name _DYNAMIC. This + exists in all ELF shared object libraries that export + or import symbols; If someone has a shared object library that + contains no imports or exports of any kind, this will probably fail. + If dlsym can't find the requested symbol in the given module, it + will search the global namespace and could return the address + of a symbol from some other module that happens to be loaded + into this process. That would be bad, so we double check + that the module handle of the symbol found matches the + module handle we asked about.} + + dlerror; // clear error state; dlsym doesn't + Addr := dlsym(Module, '_DYNAMIC'); + if (Addr <> nil) and (dlerror = nil) + and (dladdr(Addr, Info) <> 0) then + begin + if Info.BaseAddress = ExeBaseAddress then + Info.FileName := nil; + FoundInModule := HMODULE(dlopen(Info.FileName, RTLD_LAZY)); + if FoundInModule <> 0 then + dlclose(FoundInModule); + if Module = FoundInModule then + begin + Result := _strlen(Info.FileName); + if Result >= BufLen then Result := BufLen-1; + Move(Info.FileName^, Buffer^, Result); + Buffer[Result] := #0; + end; + end; + end; + if Result < 0 then Result := 0; +end; +{$ENDIF} + +function DelayLoadResourceModule(Module: PLibModule): LongWord; +var + FileName: array[0..MAX_PATH] of Char; +begin + if Module.ResInstance = 0 then + begin + GetModuleFileName(Module.Instance, FileName, SizeOf(FileName)); + Module.ResInstance := LoadResourceModule(FileName); + if Module.ResInstance = 0 then + Module.ResInstance := Module.Instance; + end; + Result := Module.ResInstance; +end; + +function FindResourceHInstance(Instance: LongWord): LongWord; +var + CurModule: PLibModule; +begin + CurModule := LibModuleList; + while CurModule <> nil do + begin + if (Instance = CurModule.Instance) or + (Instance = CurModule.CodeInstance) or + (Instance = CurModule.DataInstance) then + begin + Result := DelayLoadResourceModule(CurModule); + Exit; + end; + CurModule := CurModule.Next; + end; + Result := Instance; +end; + +function LoadResourceModule(ModuleName: PChar; CheckOwner: Boolean): LongWord; +{$IFDEF LINUX} +var + FileName: array [0..MAX_PATH] of Char; + LangCode: PChar; // Language and country code. Example: en_US + P: PChar; + ModuleNameLen, FileNameLen, i: Integer; + st1, st2: TStatStruct; +begin + LangCode := __getenv('LANG'); + Result := 0; + if (LangCode = nil) or (LangCode^ = #0) then Exit; + + // look for modulename.en_US (ignoring codeset and modifier suffixes) + P := LangCode; + while P^ in ['a'..'z', 'A'..'Z', '_'] do + Inc(P); + if P = LangCode then Exit; + + if CheckOwner and (__xstat(STAT_VER_LINUX, ModuleName, st1) = -1) then + Exit; + + ModuleNameLen := _strlen(ModuleName); + if (ModuleNameLen + P - LangCode) >= MAX_PATH then Exit; + Move(ModuleName[0], Filename[0], ModuleNameLen); + Filename[ModuleNameLen] := '.'; + Move(LangCode[0], Filename[ModuleNameLen + 1], P - LangCode); + FileNameLen := ModuleNameLen + 1 + (P - LangCode); + Filename[FileNameLen] := #0; + +{ Security check: make sure the user id (owner) and group id of + the base module matches the user id and group id of the resource + module we're considering loading. This is to prevent loading + of malicious code dropped into the base module's directory by + a hostile user. The app and all its resource modules must + have the same owner and group. To disable this security check, + call this function with CheckOwner set to False. } + + if (not CheckOwner) or + ((__xstat(STAT_VER_LINUX, FileName, st2) <> -1) + and (st1.st_uid = st2.st_uid) + and (st1.st_gid = st2.st_gid)) then + begin + Result := dlopen(Filename, RTLD_LAZY); + if Result <> 0 then Exit; + end; + + // look for modulename.en (ignoring country code and suffixes) + i := ModuleNameLen + 1; + while (i <= FileNameLen) and (Filename[i] in ['a'..'z', 'A'..'Z']) do + Inc(i); + if (i = ModuleNameLen + 1) or (i > FileNameLen) then Exit; + FileName[i] := #0; + + { Security check. See notes above. } + if (not CheckOwner) or + ((__xstat(STAT_VER_LINUX, FileName, st2) <> -1) + and (st1.st_uid = st2.st_uid) + and (st1.st_gid = st2.st_gid)) then + begin + Result := dlopen(FileName, RTLD_LAZY); + end; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +var + FileName: array[0..MAX_PATH] of Char; + Key: LongWord; + LocaleName, LocaleOverride: array[0..4] of Char; + Size: Integer; + P: PChar; + + function FindBS(Current: PChar): PChar; + begin + Result := Current; + while (Result^ <> #0) and (Result^ <> '\') do + Result := CharNext(Result); + end; + + function ToLongPath(AFileName: PChar; BufSize: Integer): PChar; + var + CurrBS, NextBS: PChar; + Handle, L: Integer; + FindData: TWin32FindData; + Buffer: array[0..MAX_PATH] of Char; + GetLongPathName: function (ShortPathName: PChar; LongPathName: PChar; + cchBuffer: Integer): Integer stdcall; + begin + Result := AFileName; + Handle := GetModuleHandle(kernel); + if Handle <> 0 then + begin + @GetLongPathName := GetProcAddress(Handle, 'GetLongPathNameA'); + if Assigned(GetLongPathName) and + (GetLongPathName(AFileName, Buffer, SizeOf(Buffer)) <> 0) then + begin + lstrcpyn(AFileName, Buffer, BufSize); + Exit; + end; + end; + + if AFileName[0] = '\' then + begin + if AFileName[1] <> '\' then Exit; + CurrBS := FindBS(AFileName + 2); // skip server name + if CurrBS^ = #0 then Exit; + CurrBS := FindBS(CurrBS + 1); // skip share name + if CurrBS^ = #0 then Exit; + end else + CurrBS := AFileName + 2; // skip drive name + + L := CurrBS - AFileName; + lstrcpyn(Buffer, AFileName, L + 1); + while CurrBS^ <> #0 do + begin + NextBS := FindBS(CurrBS + 1); + if L + (NextBS - CurrBS) + 1 > SizeOf(Buffer) then Exit; + lstrcpyn(Buffer + L, CurrBS, (NextBS - CurrBS) + 1); + + Handle := FindFirstFile(Buffer, FindData); + if (Handle = -1) then Exit; + FindClose(Handle); + + if L + 1 + _strlen(FindData.cFileName) + 1 > SizeOf(Buffer) then Exit; + Buffer[L] := '\'; + lstrcpyn(Buffer + L + 1, FindData.cFileName, Sizeof(Buffer) - L - 1); + Inc(L, _strlen(FindData.cFileName) + 1); + CurrBS := NextBS; + end; + lstrcpyn(AFileName, Buffer, BufSize); + end; +begin + GetModuleFileName(0, FileName, SizeOf(FileName)); // Get host application name + LocaleOverride[0] := #0; + if (RegOpenKeyEx(HKEY_CURRENT_USER, NewLocaleOverrideKey, 0, KEY_READ, Key) = 0) or + (RegOpenKeyEx(HKEY_LOCAL_MACHINE, NewLocaleOverrideKey, 0, KEY_READ, Key) = 0) or + (RegOpenKeyEx(HKEY_CURRENT_USER, OldLocaleOverrideKey, 0, KEY_READ, Key) = 0) then + try + Size := sizeof(LocaleOverride); + ToLongPath(FileName, sizeof(FileName)); + if RegQueryValueEx(Key, FileName, nil, nil, LocaleOverride, @Size) <> 0 then + if RegQueryValueEx(Key, '', nil, nil, LocaleOverride, @Size) <> 0 then + LocaleOverride[0] := #0; + LocaleOverride[sizeof(LocaleOverride)-1] := #0; + finally + RegCloseKey(Key); + end; + lstrcpyn(FileName, ModuleName, sizeof(FileName)); + GetLocaleInfo(GetThreadLocale, LOCALE_SABBREVLANGNAME, LocaleName, sizeof(LocaleName)); + Result := 0; + if (FileName[0] <> #0) and ((LocaleName[0] <> #0) or (LocaleOverride[0] <> #0)) then + begin + P := PChar(@FileName) + _strlen(FileName); + while (P^ <> '.') and (P <> @FileName) do Dec(P); + if P <> @FileName then + begin + Inc(P); + // First look for a locale registry override + if LocaleOverride[0] <> #0 then + begin + lstrcpyn(P, LocaleOverride, sizeof(FileName) - (P - FileName)); + Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE); + end; + if (Result = 0) and (LocaleName[0] <> #0) then + begin + // Then look for a potential language/country translation + lstrcpyn(P, LocaleName, sizeof(FileName) - (P - FileName)); + Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE); + if Result = 0 then + begin + // Finally look for a language only translation + LocaleName[2] := #0; + lstrcpyn(P, LocaleName, sizeof(FileName) - (P - FileName)); + Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE); + end; + end; + end; + end; +end; +{$ENDIF} + +procedure EnumModules(Func: TEnumModuleFunc; Data: Pointer); assembler; +begin + EnumModules(TEnumModuleFuncLW(Func), Data); +end; + +procedure EnumResourceModules(Func: TEnumModuleFunc; Data: Pointer); +begin + EnumResourceModules(TEnumModuleFuncLW(Func), Data); +end; + +procedure EnumModules(Func: TEnumModuleFuncLW; Data: Pointer); +var + CurModule: PLibModule; +begin + CurModule := LibModuleList; + while CurModule <> nil do + begin + if not Func(CurModule.Instance, Data) then Exit; + CurModule := CurModule.Next; + end; +end; + +procedure EnumResourceModules(Func: TEnumModuleFuncLW; Data: Pointer); +var + CurModule: PLibModule; +begin + CurModule := LibModuleList; + while CurModule <> nil do + begin + if not Func(DelayLoadResourceModule(CurModule), Data) then Exit; + CurModule := CurModule.Next; + end; +end; + +procedure AddModuleUnloadProc(Proc: TModuleUnloadProc); +begin + AddModuleUnloadProc(TModuleUnloadProcLW(Proc)); +end; + +procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProc); +begin + RemoveModuleUnloadProc(TModuleUnloadProcLW(Proc)); +end; + +procedure AddModuleUnloadProc(Proc: TModuleUnloadProcLW); +var + P: PModuleUnloadRec; +begin + New(P); + P.Next := ModuleUnloadList; + @P.Proc := @Proc; + ModuleUnloadList := P; +end; + +procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProcLW); +var + P, C: PModuleUnloadRec; +begin + P := ModuleUnloadList; + if (P <> nil) and (@P.Proc = @Proc) then + begin + ModuleUnloadList := ModuleUnloadList.Next; + Dispose(P); + end else + begin + C := P; + while C <> nil do + begin + if (C.Next <> nil) and (@C.Next.Proc = @Proc) then + begin + P := C.Next; + C.Next := C.Next.Next; + Dispose(P); + Break; + end; + C := C.Next; + end; + end; +end; + +procedure NotifyModuleUnload(HInstance: LongWord); +var + P: PModuleUnloadRec; +begin + P := ModuleUnloadList; + while P <> nil do + begin + try + P.Proc(HInstance); + except + // Make sure it doesn't stop notifications + end; + P := P.Next; + end; +{$IFDEF LINUX} + InvalidateModuleCache; +{$ENDIF} +end; + +procedure RegisterModule(LibModule: PLibModule); +begin + LibModule.Next := LibModuleList; + LibModuleList := LibModule; +end; + +{X- procedure UnregisterModule(LibModule: PLibModule); -renamed } +procedure UnRegisterModuleSafely( LibModule: PLibModule ); +var + CurModule: PLibModule; +begin + try + NotifyModuleUnload(LibModule.Instance); + finally + if LibModule = LibModuleList then + LibModuleList := LibModule.Next + else + begin + CurModule := LibModuleList; + while CurModule <> nil do + begin + if CurModule.Next = LibModule then + begin + CurModule.Next := LibModule.Next; + Break; + end; + CurModule := CurModule.Next; + end; + end; + end; +end; + +{X+} // "Light" version of UnRegisterModule - without using of try-except +procedure UnRegisterModuleLight( LibModule: PLibModule ); +var + P: PModuleUnloadRec; +begin + P := ModuleUnloadList; + while P <> nil do + begin + P.Proc(LibModule.Instance); + P := P.Next; + end; +end; +{X-} + +function _IntfClear(var Dest: IInterface): Pointer; +{$IFDEF PUREPASCAL} +var + P: Pointer; +begin + Result := @Dest; + if Dest <> nil then + begin + P := Pointer(Dest); + Pointer(Dest) := nil; + IInterface(P)._Release; + end; +end; +{$ELSE} +asm + MOV EDX,[EAX] + TEST EDX,EDX + JE @@1 + MOV DWORD PTR [EAX],0 + PUSH EAX + PUSH EDX + MOV EAX,[EDX] + CALL DWORD PTR [EAX] + VMTOFFSET IInterface._Release + POP EAX +@@1: +end; +{$ENDIF} + +procedure _IntfCopy(var Dest: IInterface; const Source: IInterface); +{$IFDEF PUREPASCAL} +var + P: Pointer; +begin + P := Pointer(Dest); + if Source <> nil then + Source._AddRef; + Pointer(Dest) := Pointer(Source); + if P <> nil then + IInterface(P)._Release; +end; +{$ELSE} +asm +{ + The most common case is the single assignment of a non-nil interface + to a nil interface. So we streamline that case here. After this, + we give essentially equal weight to other outcomes. + + The semantics are: The source intf must be addrefed *before* it + is assigned to the destination. The old intf must be released + after the new intf is addrefed to support self assignment (I := I). + Either intf can be nil. The first requirement is really to make an + error case function a little better, and to improve the behaviour + of multithreaded applications - if the addref throws an exception, + you don't want the interface to have been assigned here, and if the + assignment is made to a global and another thread references it, + again you don't want the intf to be available until the reference + count is bumped. +} + TEST EDX,EDX // is source nil? + JE @@NilSource + PUSH EDX // save source + PUSH EAX // save dest + MOV EAX,[EDX] // get source vmt + PUSH EDX // source as arg + CALL DWORD PTR [EAX] + VMTOFFSET IInterface._AddRef + POP EAX // retrieve dest + MOV ECX, [EAX] // get current value + POP [EAX] // set dest in place + TEST ECX, ECX // is current value nil? + JNE @@ReleaseDest // no, release it + RET // most common case, we return here +@@ReleaseDest: + MOV EAX,[ECX] // get current value vmt + PUSH ECX // current value as arg + CALL DWORD PTR [EAX] + VMTOFFSET IInterface._Release + RET + +{ Now we're into the less common cases. } +@@NilSource: + MOV ECX, [EAX] // get current value + TEST ECX, ECX // is it nil? + MOV [EAX], EDX // store in dest (which is nil) + JE @@Done + MOV EAX, [ECX] // get current vmt + PUSH ECX // current value as arg + CALL [EAX].vmtRelease.Pointer +@@Done: +end; +{$ENDIF} + +procedure _IntfCast(var Dest: IInterface; const Source: IInterface; const IID: TGUID); +{$IFDEF PUREPASCAL} +// PIC: EBX must be correct before calling QueryInterface +begin + if Source = nil then + Dest := nil + else if Source.QueryInterface(IID, Dest) <> 0 then + Error(reIntfCastError); +end; +{$ELSE} +asm + TEST EDX,EDX + JE _IntfClear + PUSH EAX + PUSH ECX + PUSH EDX + MOV ECX,[EAX] + TEST ECX,ECX + JE @@1 + PUSH ECX + MOV EAX,[ECX] + CALL DWORD PTR [EAX] + VMTOFFSET IInterface._Release + MOV EDX,[ESP] +@@1: MOV EAX,[EDX] + CALL DWORD PTR [EAX] + VMTOFFSET IInterface.QueryInterface + TEST EAX,EAX + JE @@2 + MOV AL,reIntfCastError + JMP Error +@@2: +end; +{$ENDIF} + +procedure _IntfAddRef(const Dest: IInterface); +begin + if Dest <> nil then Dest._AddRef; +end; + +procedure TInterfacedObject.AfterConstruction; +begin +// Release the constructor's implicit refcount + InterlockedDecrement(FRefCount); +end; + +procedure TInterfacedObject.BeforeDestruction; +begin + if RefCount <> 0 then + Error(reInvalidPtr); +end; + +// Set an implicit refcount so that refcounting +// during construction won't destroy the object. +class function TInterfacedObject.NewInstance: TObject; +begin + Result := inherited NewInstance; + TInterfacedObject(Result).FRefCount := 1; +end; + +function TInterfacedObject.QueryInterface(const IID: TGUID; out Obj): HResult; +begin + if GetInterface(IID, Obj) then + Result := 0 + else + Result := E_NOINTERFACE; +end; + +function TInterfacedObject._AddRef: Integer; +begin + Result := InterlockedIncrement(FRefCount); +end; + +function TInterfacedObject._Release: Integer; +begin + Result := InterlockedDecrement(FRefCount); + if Result = 0 then + Destroy; +end; + +{ TAggregatedObject } + +constructor TAggregatedObject.Create(const Controller: IInterface); +begin + // weak reference to controller - don't keep it alive + FController := Pointer(Controller); +end; + +function TAggregatedObject.GetController: IInterface; +begin + Result := IInterface(FController); +end; + +function TAggregatedObject.QueryInterface(const IID: TGUID; out Obj): HResult; +begin + Result := IInterface(FController).QueryInterface(IID, Obj); +end; + +function TAggregatedObject._AddRef: Integer; +begin + Result := IInterface(FController)._AddRef; +end; + +function TAggregatedObject._Release: Integer; stdcall; +begin + Result := IInterface(FController)._Release; +end; + +{ TContainedObject } + +function TContainedObject.QueryInterface(const IID: TGUID; out Obj): HResult; +begin + if GetInterface(IID, Obj) then + Result := S_OK + else + Result := E_NOINTERFACE; +end; + + +function _CheckAutoResult(ResultCode: HResult): HResult; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + if ResultCode < 0 then + begin + if Assigned(SafeCallErrorProc) then + SafeCallErrorProc(ResultCode, Pointer(-1)); // loses error address + Error(reSafeCallError); + end; + Result := ResultCode; +end; +{$ELSE} +asm + TEST EAX,EAX + JNS @@2 + MOV ECX,SafeCallErrorProc + TEST ECX,ECX + JE @@1 + MOV EDX,[ESP] + CALL ECX +@@1: MOV AL,reSafeCallError + JMP Error +@@2: +end; +{$IFEND} + +function CompToDouble(Value: Comp): Double; cdecl; +begin + Result := Value; +end; + +procedure DoubleToComp(Value: Double; var Result: Comp); cdecl; +begin + Result := Value; +end; + +function CompToCurrency(Value: Comp): Currency; cdecl; +begin + Result := Value; +end; + +procedure CurrencyToComp(Value: Currency; var Result: Comp); cdecl; +begin + Result := Value; +end; + +function GetMemory(Size: Integer): Pointer; cdecl; +begin + Result := MemoryManager.GetMem(Size); +end; + +function FreeMemory(P: Pointer): Integer; cdecl; +begin + if P = nil then + Result := 0 + else + Result := MemoryManager.FreeMem(P); +end; + +function ReallocMemory(P: Pointer; Size: Integer): Pointer; cdecl; +begin + Result := MemoryManager.ReallocMem(P, Size); +end; + +procedure SetLineBreakStyle(var T: Text; Style: TTextLineBreakStyle); +begin + if TTextRec(T).Mode = fmClosed then + TTextRec(T).Flags := TTextRec(T).Flags or (tfCRLF * Byte(Style)) + else + SetInOutRes(107); // can't change mode of open file +end; + +// UnicodeToUTF8(3): +// Scans the source data to find the null terminator, up to MaxBytes +// Dest must have MaxBytes available in Dest. + +function UnicodeToUtf8(Dest: PChar; Source: PWideChar; MaxBytes: Integer): Integer; +var + len: Cardinal; +begin + len := 0; + if Source <> nil then + while Source[len] <> #0 do + Inc(len); + Result := UnicodeToUtf8(Dest, MaxBytes, Source, len); +end; + +// UnicodeToUtf8(4): +// MaxDestBytes includes the null terminator (last char in the buffer will be set to null) +// Function result includes the null terminator. +// Nulls in the source data are not considered terminators - SourceChars must be accurate + +function UnicodeToUtf8(Dest: PChar; MaxDestBytes: Cardinal; Source: PWideChar; SourceChars: Cardinal): Cardinal; +var + i, count: Cardinal; + c: Cardinal; +begin + Result := 0; + if Source = nil then Exit; + count := 0; + i := 0; + if Dest <> nil then + begin + while (i < SourceChars) and (count < MaxDestBytes) do + begin + c := Cardinal(Source[i]); + Inc(i); + if c <= $7F then + begin + Dest[count] := Char(c); + Inc(count); + end + else if c > $7FF then + begin + if count + 3 > MaxDestBytes then + break; + Dest[count] := Char($E0 or (c shr 12)); + Dest[count+1] := Char($80 or ((c shr 6) and $3F)); + Dest[count+2] := Char($80 or (c and $3F)); + Inc(count,3); + end + else // $7F < Source[i] <= $7FF + begin + if count + 2 > MaxDestBytes then + break; + Dest[count] := Char($C0 or (c shr 6)); + Dest[count+1] := Char($80 or (c and $3F)); + Inc(count,2); + end; + end; + if count >= MaxDestBytes then count := MaxDestBytes-1; + Dest[count] := #0; + end + else + begin + while i < SourceChars do + begin + c := Integer(Source[i]); + Inc(i); + if c > $7F then + begin + if c > $7FF then + Inc(count); + Inc(count); + end; + Inc(count); + end; + end; + Result := count+1; // convert zero based index to byte count +end; + +function Utf8ToUnicode(Dest: PWideChar; Source: PChar; MaxChars: Integer): Integer; +var + len: Cardinal; +begin + len := 0; + if Source <> nil then + while Source[len] <> #0 do + Inc(len); + Result := Utf8ToUnicode(Dest, MaxChars, Source, len); +end; + +function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: Cardinal; Source: PChar; SourceBytes: Cardinal): Cardinal; +var + i, count: Cardinal; + c: Byte; + wc: Cardinal; +begin + if Source = nil then + begin + Result := 0; + Exit; + end; + Result := Cardinal(-1); + count := 0; + i := 0; + if Dest <> nil then + begin + while (i < SourceBytes) and (count < MaxDestChars) do + begin + wc := Cardinal(Source[i]); + Inc(i); + if (wc and $80) <> 0 then + begin + wc := wc and $3F; + if i > SourceBytes then Exit; // incomplete multibyte char + if (wc and $20) <> 0 then + begin + c := Byte(Source[i]); + Inc(i); + if (c and $C0) <> $80 then Exit; // malformed trail byte or out of range char + if i > SourceBytes then Exit; // incomplete multibyte char + wc := (wc shl 6) or (c and $3F); + end; + c := Byte(Source[i]); + Inc(i); + if (c and $C0) <> $80 then Exit; // malformed trail byte + + Dest[count] := WideChar((wc shl 6) or (c and $3F)); + end + else + Dest[count] := WideChar(wc); + Inc(count); + end; + if count >= MaxDestChars then count := MaxDestChars-1; + Dest[count] := #0; + end + else + begin + while (i <= SourceBytes) do + begin + c := Byte(Source[i]); + Inc(i); + if (c and $80) <> 0 then + begin + if (c and $F0) = $F0 then Exit; // too many bytes for UCS2 + if (c and $40) = 0 then Exit; // malformed lead byte + if i > SourceBytes then Exit; // incomplete multibyte char + + if (Byte(Source[i]) and $C0) <> $80 then Exit; // malformed trail byte + Inc(i); + if i > SourceBytes then Exit; // incomplete multibyte char + if ((c and $20) <> 0) and ((Byte(Source[i]) and $C0) <> $80) then Exit; // malformed trail byte + Inc(i); + end; + Inc(count); + end; + end; + Result := count+1; +end; + +function Utf8Encode(const WS: WideString): UTF8String; +var + L: Integer; + Temp: UTF8String; +begin + Result := ''; + if WS = '' then Exit; + SetLength(Temp, Length(WS) * 3); // SetLength includes space for null terminator + + L := UnicodeToUtf8(PChar(Temp), Length(Temp)+1, PWideChar(WS), Length(WS)); + if L > 0 then + SetLength(Temp, L-1) + else + Temp := ''; + Result := Temp; +end; + +function Utf8Decode(const S: UTF8String): WideString; +var + L: Integer; + Temp: WideString; +begin + Result := ''; + if S = '' then Exit; + SetLength(Temp, Length(S)); + + L := Utf8ToUnicode(PWideChar(Temp), Length(Temp)+1, PChar(S), Length(S)); + if L > 0 then + SetLength(Temp, L-1) + else + Temp := ''; + Result := Temp; +end; + +function AnsiToUtf8(const S: string): UTF8String; +begin + Result := Utf8Encode(S); +end; + +function Utf8ToAnsi(const S: UTF8String): string; +begin + Result := Utf8Decode(S); +end; + +{$IFDEF LINUX} + +function GetCPUType: Integer; +asm + PUSH EBX + // this code assumes ESP is 4 byte aligned + // test for 80386: see if bit #18 of EFLAGS (Alignment fault) can be toggled + PUSHF + POP EAX + MOV ECX, EAX + XOR EAX, $40000 // flip AC bit in EFLAGS + PUSH EAX + POPF + PUSHF + POP EAX + XOR EAX, ECX // zero = 80386 CPU (can't toggle AC bit) + MOV EAX, CPUi386 + JZ @@Exit + PUSH ECX + POPF // restore original flags before next test + + // test for 80486: see if bit #21 of EFLAGS (CPUID supported) can be toggled + MOV EAX, ECX // get original EFLAGS + XOR EAX, $200000 // flip CPUID bit in EFLAGS + PUSH EAX + POPF + PUSHF + POP EAX + XOR EAX, ECX // zero = 80486 (can't toggle EFLAGS bit #21) + MOV EAX, CPUi486 + JZ @@Exit + + // Use CPUID instruction to get CPU family + XOR EAX, EAX + CPUID + CMP EAX, 1 + JL @@Exit // unknown processor response: report as 486 + XOR EAX, EAX + INC EAX // we only care about info level 1 + CPUID + AND EAX, $F00 + SHR EAX, 8 + // Test8086 values are one less than the CPU model number, for historical reasons + DEC EAX + +@@Exit: + POP EBX +end; + + +const + sResSymExport = '@Sysinit@ResSym'; + sResStrExport = '@Sysinit@ResStr'; + sResHashExport = '@Sysinit@ResHash'; + +type + TElf32Sym = record + Name: Cardinal; + Value: Pointer; + Size: Cardinal; + Info: Byte; + Other: Byte; + Section: Word; + end; + PElf32Sym = ^TElf32Sym; + + TElfSymTab = array [0..0] of TElf32Sym; + PElfSymTab = ^TElfSymTab; + + TElfWordTab = array [0..2] of Cardinal; + PElfWordTab = ^TElfWordTab; + + +{ If Name encodes a numeric identifier, return it, else return -1. } +function NameToId(Name: PChar): Longint; +var digit: Longint; +begin + if Longint(Name) and $ffff0000 = 0 then + begin + Result := Longint(Name) and $ffff; + end + else if Name^ = '#' then + begin + Result := 0; + inc (Name); + while (Ord(Name^) <> 0) do + begin + digit := Ord(Name^) - Ord('0'); + if (LongWord(digit) > 9) then + begin + Result := -1; + exit; + end; + Result := Result * 10 + digit; + inc (Name); + end; + end + else + Result := -1; +end; + + +// Return ELF hash value for NAME converted to lower case. +function ElfHashLowercase(Name: PChar): Cardinal; +var + g: Cardinal; + c: Char; +begin + Result := 0; + while name^ <> #0 do + begin + c := name^; + case c of + 'A'..'Z': Inc(c, Ord('a') - Ord('A')); + end; + Result := (Result shl 4) + Ord(c); + g := Result and $f0000000; + Result := (Result xor (g shr 24)) and not g; + Inc(name); + end; +end; + +type + PFindResourceCache = ^TFindResourceCache; + TFindResourceCache = record + ModuleHandle: HMODULE; + Version: Cardinal; + SymbolTable: PElfSymTab; + StringTable: PChar; + HashTable: PElfWordTab; + BaseAddress: Cardinal; + end; + +threadvar + FindResourceCache: TFindResourceCache; + +function GetResourceCache(ModuleHandle: HMODULE): PFindResourceCache; +var + info: TDLInfo; +begin + Result := @FindResourceCache; + if (ModuleHandle <> Result^.ModuleHandle) or (ModuleCacheVersion <> Result^.Version) then + begin + Result^.SymbolTable := dlsym(ModuleHandle, sResSymExport); + Result^.StringTable := dlsym(ModuleHandle, sResStrExport); + Result^.HashTable := dlsym(ModuleHandle, sResHashExport); + Result^.ModuleHandle := ModuleHandle; + if (dladdr(Result^.HashTable, Info) = 0) or (Info.BaseAddress = ExeBaseAddress) then + Result^.BaseAddress := 0 // if it's not in a library, assume the exe + else + Result^.BaseAddress := Cardinal(Info.BaseAddress); + Result^.Version := ModuleCacheVersion; + end; +end; + +function FindResource(ModuleHandle: HMODULE; ResourceName: PChar; ResourceType: PChar): TResourceHandle; +var + P: PFindResourceCache; + nid, tid: Longint; + ucs2_key: array [0..2] of WideChar; + key: array [0..127] of Char; + len: Integer; + pc: PChar; + ch: Char; + nbucket: Cardinal; + bucket, chain: PElfWordTab; + syndx: Cardinal; +begin + Result := 0; + if ResourceName = nil then Exit; + P := GetResourceCache(ModuleHandle); + + tid := NameToId (ResourceType); + if tid = -1 then Exit; { not supported (yet?) } + + { This code must match util-common/elfres.c } + nid := NameToId (ResourceName); + if nid = -1 then + begin + ucs2_key[0] := WideChar(2*tid+2); + ucs2_key[1] := WideChar(0); + len := UnicodeToUtf8 (key, ucs2_key, SizeOf (key)); + pc := key+len; + while Ord(ResourceName^) <> 0 do + begin + ch := ResourceName^; + if Ord(ch) > 127 then exit; { insist on 7bit ASCII for now } + if ('A' <= ch) and (ch <= 'Z') then Inc(ch, Ord('a') - Ord('A')); + pc^ := ch; + inc (pc); + if pc = key + SizeOf(key) then exit; + inc (ResourceName); + end; + pc^ := Char(0); + end + else + begin + ucs2_key[0] := WideChar(2*tid+1); + ucs2_key[1] := WideChar(nid); + ucs2_key[2] := WideChar(0); + UnicodeToUtf8 (key, ucs2_key, SizeOf (key)); + end; + + with P^ do + begin + nbucket := HashTable[0]; + // nsym := HashTable[1]; + bucket := @HashTable[2]; + chain := @HashTable[2+nbucket]; + + syndx := bucket[ElfHashLowercase(key) mod nbucket]; + while (syndx <> 0) + and (strcasecmp(key, @StringTable[SymbolTable[syndx].Name]) <> 0) do + syndx := chain[syndx]; + + if syndx = 0 then + Result := 0 + else + Result := TResourceHandle(@SymbolTable[syndx]); + end; +end; + +function LoadResource(ModuleHandle: HMODULE; ResHandle: TResourceHandle): HGLOBAL; +var + P: PFindResourceCache; +begin + if ResHandle <> 0 then + begin + P := GetResourceCache(ModuleHandle); + Result := HGLOBAL(PElf32Sym(ResHandle)^.Value); + Inc (Cardinal(Result), P^.BaseAddress); + end + else + Result := 0; +end; + +function SizeofResource(ModuleHandle: HMODULE; ResHandle: TResourceHandle): Integer; +begin + if ResHandle <> 0 then + Result := PElf32Sym(ResHandle)^.Size + else + Result := 0; +end; + +function LockResource(ResData: HGLOBAL): Pointer; +begin + Result := Pointer(ResData); +end; + +function UnlockResource(ResData: HGLOBAL): LongBool; +begin + Result := False; +end; + +function FreeResource(ResData: HGLOBAL): LongBool; +begin + Result := True; +end; +{$ENDIF} + +{ ResString support function } + +{$IFDEF MSWINDOWS} +function LoadResString(ResStringRec: PResStringRec): string; +var + Buffer: array [0..1023] of char; +begin + if ResStringRec = nil then Exit; + if ResStringRec.Identifier < 64*1024 then + SetString(Result, Buffer, + LoadString(FindResourceHInstance(ResStringRec.Module^), + ResStringRec.Identifier, Buffer, SizeOf(Buffer))) + else + Result := PChar(ResStringRec.Identifier); +end; +{$ENDIF} +{$IFDEF LINUX} + +const + ResStringTableLen = 16; + +type + ResStringTable = array [0..ResStringTableLen-1] of LongWord; + +function LoadResString(ResStringRec: PResStringRec): string; +var + Handle: TResourceHandle; + Tab: ^ResStringTable; + ResMod: HMODULE; +begin + if ResStringRec = nil then Exit; + ResMod := FindResourceHInstance(ResStringRec^.Module^); + Handle := FindResource(ResMod, + PChar(ResStringRec^.Identifier div ResStringTableLen), + PChar(6)); // RT_STRING + Tab := Pointer(LoadResource(ResMod, Handle)); + if Tab = nil then + Result := '' + else + Result := PChar (Tab) + Tab[ResStringRec^.Identifier mod ResStringTableLen]; +end; + +procedure DbgUnlockX; +begin + if Assigned(DbgUnlockXProc) then + DbgUnlockXProc; +end; + +{ The Win32 program loader sets up the first 64k of process address space + with no read or write access, to help detect use of invalid pointers + (whose integer value is 0..64k). Linux doesn't do this. + + Parts of the Delphi RTL and IDE design environment + rely on the notion that pointer values in the [0..64k] range are + invalid pointers. To accomodate this in Linux, we reserve the range + at startup. If the range is already allocated, we keep going anyway. } + +var + ZeroPageReserved: Boolean = False; + +procedure ReserveZeroPage; +const + PROT_NONE = 0; + MAP_PRIVATE = $02; + MAP_FIXED = $10; + MAP_ANONYMOUS = $20; +var + P: Pointer; +begin + if IsLibrary then Exit; // page reserve is app's job, not .so's + + if not ZeroPageReserved then + begin + P := mmap(nil, High(Word), PROT_NONE, + MAP_ANONYMOUS or MAP_PRIVATE or MAP_FIXED, 0, 0); + ZeroPageReserved := P = nil; + if (Integer(P) <> -1) and (P <> nil) then // we didn't get it + munmap(P, High(Word)); + end; +end; + +procedure ReleaseZeroPage; +begin + if ZeroPageReserved then + begin + munmap(nil, High(Word) - 4096); + ZeroPageReserved := False; + end; +end; +{$ENDIF} + +function PUCS4Chars(const S: UCS4String): PUCS4Char; +const + Null: UCS4Char = 0; + PNull: PUCS4Char = @Null; +begin + if Length(S) > 0 then + Result := @S[0] + else + Result := PNull; +end; + +function WideStringToUCS4String(const S: WideString): UCS4String; +var + I: Integer; +begin + SetLength(Result, Length(S) + 1); + for I := 0 to Length(S) - 1 do + Result[I] := UCS4Char(S[I + 1]); + Result[Length(S)] := 0; +end; + +function UCS4StringToWidestring(const S: UCS4String): WideString; +var + I: Integer; +begin + SetLength(Result, Length(S)); + for I := 0 to Length(S)-1 do + Result[I+1] := WideChar(S[I]); + Result[Length(S)] := #0; +end; + +var SaveCmdShow : Integer = -1; +function CmdShow: Integer; +var + SI: TStartupInfo; +begin + if SaveCmdShow < 0 then + begin + SaveCmdShow := 10; { SW_SHOWDEFAULT } + GetStartupInfo(SI); + if SI.dwFlags and 1 <> 0 then { STARTF_USESHOWWINDOW } + SaveCmdShow := SI.wShowWindow; + end; + Result := SaveCmdShow; +end; + +{X} // convert var CmdLine : PChar to a function: +{X} function CmdLine : PChar; +{X} begin +{X} Result := GetCommandLine; +{X} end; + +initialization + + {$IFDEF MSWINDOWS} + {$IFDEF USE_PROCESS_HEAP} + HeapHandle := GetProcessHeap; + {$ELSE} + HeapHandle := HeapCreate( 0, 0, 0 ); + {$ENDIF} + {$ENDIF} + + {$IFDEF MSWINDOWS} + //{X (initialized statically} FileMode := 2; + {$ELSE} + FileMode := 2; + {$ENDIF} + +{$IFDEF LINUX} + FileAccessRights := S_IRUSR or S_IWUSR or S_IRGRP or S_IWGRP or S_IROTH or S_IWOTH; + Test8086 := GetCPUType; + IsConsole := True; + FindResourceCache.ModuleHandle := LongWord(-1); + ReserveZeroPage; +{$ELSE} + //{X (initialized statically} Test8086 := 2; +{$ENDIF} + + DispCallByIDProc := @_DispCallByIDError; + +{$IFDEF MSWINDOWS} + //{X} if _isNECWindows then _FpuMaskInit; +{$ENDIF} + //{X} _FpuInit(); + + TTextRec(Input).Mode := fmClosed; + TTextRec(Output).Mode := fmClosed; + TTextRec(ErrOutput).Mode := fmClosed; + InitVariantManager; + +{$IFDEF MSWINDOWS} +{X- CmdLine := GetCommandLine; converted to a function } +{X- CmdShow := GetCmdShow; converted to a function } +{$ENDIF} + MainThreadID := GetCurrentThreadID; + +{$IFDEF LINUX} + // Ensure DbgUnlockX is linked in, calling it now does nothing + DbgUnlockX; +{$ENDIF} + +finalization + {X+} + {X} CloseInputOutput; + {X- + Close(Input); + Close(Output); + Close(ErrOutput); + X+} +{$IFDEF LINUX} + ReleaseZeroPage; +{$ENDIF} +{$IFDEF MSWINDOWS} +{X UninitAllocator; - replaced with call to UninitMemoryManager handler. } + UninitMemoryManager; +{$ENDIF} +end. + diff --git a/System/D2007beta/Variants.pas b/System/D2007beta/Variants.pas new file mode 100644 index 0000000..727c59d --- /dev/null +++ b/System/D2007beta/Variants.pas @@ -0,0 +1,12 @@ +unit Variants; +{* Fake variants.pas unit for Delphi6 / Delphi7. Place it in a + directory with your KOL/MCK (or other non-VCL) project, and + this will save about 70K of code in the executable. + Certainly, do it so, if you actually do not use Delphi Variant + type in the application. + NEVER REPLACE Variants.pas provided by Borland! + (C) by Kladov Vladimir, 2003 } + +interface +implementation +end. diff --git a/System/D2007beta/getmem.inc b/System/D2007beta/getmem.inc new file mode 100644 index 0000000..f9b4f67 --- /dev/null +++ b/System/D2007beta/getmem.inc @@ -0,0 +1,1541 @@ +{ *********************************************************************** } +{ } +{ Delphi Runtime Library } +{ } +{ Copyright (c) 1996,2001 Borland Software Corporation } +{ } +{ *********************************************************************** } + +// Three layers: +// - Address space administration +// - Committed space administration +// - Suballocator +// +// Helper module: administrating block descriptors +// + + +// +// Operating system interface +// +const + LMEM_FIXED = 0; + LMEM_ZEROINIT = $40; + + MEM_COMMIT = $1000; + MEM_RESERVE = $2000; + MEM_DECOMMIT = $4000; + MEM_RELEASE = $8000; + + PAGE_NOACCESS = 1; + PAGE_READWRITE = 4; + +type + DWORD = Integer; + BOOL = LongBool; + + TRTLCriticalSection = packed record + DebugInfo: Pointer; + LockCount: Longint; + RecursionCount: Longint; + OwningThread: Integer; + LockSemaphore: Integer; + Reserved: DWORD; + end; + +{function LocalAlloc(flags, size: Integer): Pointer; stdcall; + external kernel name 'LocalAlloc'; +function LocalFree(addr: Pointer): Pointer; stdcall; + external kernel name 'LocalFree';} + +function VirtualAlloc(lpAddress: Pointer; + dwSize, flAllocationType, flProtect: DWORD): Pointer; stdcall; + external kernel name 'VirtualAlloc'; +function VirtualFree(lpAddress: Pointer; dwSize, dwFreeType: DWORD): BOOL; stdcall; + external kernel name 'VirtualFree'; + +procedure InitializeCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall; + external kernel name 'InitializeCriticalSection'; +procedure EnterCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall; + external kernel name 'EnterCriticalSection'; +procedure LeaveCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall; + external kernel name 'LeaveCriticalSection'; +procedure DeleteCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall; + external kernel name 'DeleteCriticalSection'; + +// Common Data structure: + +type + TBlock = packed record + addr: PChar; + size: Integer; + end; + +// Heap error codes + +const + cHeapOk = 0; // everything's fine + cReleaseErr = 1; // operating system returned an error when we released + cDecommitErr = 2; // operating system returned an error when we decommited + cBadCommittedList = 3; // list of committed blocks looks bad + cBadFiller1 = 4; // filler block is bad + cBadFiller2 = 5; // filler block is bad + cBadFiller3 = 6; // filler block is bad + cBadCurAlloc = 7; // current allocation zone is bad + cCantInit = 8; // couldn't initialize + cBadUsedBlock = 9; // used block looks bad + cBadPrevBlock = 10; // prev block before a used block is bad + cBadNextBlock = 11; // next block after a used block is bad + cBadFreeList = 12; // free list is bad + cBadFreeBlock = 13; // free block is bad + cBadBalance = 14; // free list doesn't correspond to blocks marked free + +var + initialized : Boolean; + heapErrorCode : Integer; + heapLock : TRTLCriticalSection; + {X} // Handler to set it to UninitAllocator, if Delphi memory manager used: + {X} UninitMemoryManager : procedure = DummyProc; + +// +// Helper module: administrating block descriptors. +// +type + PBlockDesc = ^TBlockDesc; + TBlockDesc = packed record + next: PBlockDesc; + prev: PBlockDesc; + addr: PChar; + size: Integer; + end; + +type + PBlockDescBlock = ^TBlockDescBlock; + TBlockDescBlock = packed record + next: PBlockDescBlock; + data: array [0..99] of TBlockDesc; + end; + +var + blockDescBlockList: PBlockDescBlock; + blockDescFreeList : PBlockDesc; + + +function GetBlockDesc: PBlockDesc; +// Get a block descriptor. +// Will return nil for failure. +var + bd: PBlockDesc; + bdb: PBlockDescBlock; + i: Integer; +begin + if blockDescFreeList = nil then begin + bdb := LocalAlloc(LMEM_FIXED, sizeof(bdb^)); + if bdb = nil then begin + result := nil; + exit; + end; + bdb.next := blockDescBlockList; + blockDescBlockList := bdb; + for i := low(bdb.data) to high(bdb.data) do begin + bd := @bdb.data[i]; + bd.next := blockDescFreeList; + blockDescFreeList := bd; + end; + end; + bd := blockDescFreeList; + blockDescFreeList := bd.next; + result := bd; +end; + + +procedure MakeEmpty(bd: PBlockDesc); +begin + bd.next := bd; + bd.prev := bd; +end; + + +function AddBlockAfter(prev: PBlockDesc; const b: TBlock): Boolean; +var + next, bd: PBlockDesc; +begin + bd := GetBlockDesc; + if bd = nil then + result := False + else begin + bd.addr := b.addr; + bd.size := b.size; + + next := prev.next; + bd.next := next; + bd.prev := prev; + next.prev := bd; + prev.next := bd; + + result := True; + end; +end; + + +procedure DeleteBlock(bd: PBlockDesc); +var + prev, next: PBlockDesc; +begin + prev := bd.prev; + next := bd.next; + prev.next := next; + next.prev := prev; + bd.next := blockDescFreeList; + blockDescFreeList := bd; +end; + + +function MergeBlockAfter(prev: PBlockDesc; const b: TBlock) : TBlock; +var + bd, bdNext: PBlockDesc; +begin + bd := prev.next; + result := b; + repeat + bdNext := bd.next; + if bd.addr + bd.size = result.addr then begin + DeleteBlock(bd); + result.addr := bd.addr; + inc(result.size, bd.size); + end else if result.addr + result.size = bd.addr then begin + DeleteBlock(bd); + inc(result.size, bd.size); + end; + bd := bdNext; + until bd = prev; + if not AddBlockAfter(prev, result) then + result.addr := nil; +end; + + +function RemoveBlock(bd: PBlockDesc; const b: TBlock): Boolean; +var + n: TBlock; + start: PBlockDesc; +begin + start := bd; + repeat + if (bd.addr <= b.addr) and (bd.addr + bd.size >= b.addr + b.size) then begin + if bd.addr = b.addr then begin + Inc(bd.addr, b.size); + Dec(bd.size, b.size); + if bd.size = 0 then + DeleteBlock(bd); + end else if bd.addr + bd.size = b.addr + b.size then + Dec(bd.size, b.size) + else begin + n.addr := b.addr + b.size; + n.size := bd.addr + bd.size - n.addr; + bd.size := b.addr - bd.addr; + if not AddBlockAfter(bd, n) then begin + result := False; + exit; + end; + end; + result := True; + exit; + end; + bd := bd.next; + until bd = start; + result := False; +end; + + + +// +// Address space administration: +// + +const + cSpaceAlign = 64*1024; + cSpaceMin = 1024*1024; + cPageAlign = 4*1024; + +var + spaceRoot: TBlockDesc; + + +function GetSpace(minSize: Integer): TBlock; +// Get at least minSize bytes address space. +// Success: returns a block, possibly much bigger than requested. +// Will not fail - will raise an exception or terminate program. +begin + if minSize < cSpaceMin then + minSize := cSpaceMin + else + minSize := (minSize + (cSpaceAlign-1)) and not (cSpaceAlign-1); + + result.size := minSize; + result.addr := VirtualAlloc(nil, minSize, MEM_RESERVE, PAGE_NOACCESS); + if result.addr = nil then + exit; + + if not AddBlockAfter(@spaceRoot, result) then begin + VirtualFree(result.addr, 0, MEM_RELEASE); + result.addr := nil; + exit; + end; +end; + + +function GetSpaceAt(addr: PChar; minSize: Integer): TBlock; +// Get at least minSize bytes address space at addr. +// Return values as above. +// Failure: returns block with addr = nil. +begin + result.size := cSpaceMin; + result.addr := VirtualAlloc(addr, cSpaceMin, MEM_RESERVE, PAGE_READWRITE); + if result.addr = nil then begin + minSize := (minSize + (cSpaceAlign-1)) and not (cSpaceAlign-1); + result.size := minSize; + result.addr := VirtualAlloc(addr, minSize, MEM_RESERVE, PAGE_READWRITE); + end; + if result.addr <> nil then begin + if not AddBlockAfter(@spaceRoot, result) then begin + VirtualFree(result.addr, 0, MEM_RELEASE); + result.addr := nil; + end; + end; +end; + + +function FreeSpace(addr: Pointer; maxSize: Integer): TBlock; +// Free at most maxSize bytes of address space at addr. +// Returns the block that was actually freed. +var + bd, bdNext: PBlockDesc; + minAddr, maxAddr, startAddr, endAddr: PChar; +begin + minAddr := PChar($FFFFFFFF); + maxAddr := nil; + startAddr := addr; + endAddr := startAddr + maxSize; + bd := spaceRoot.next; + while bd <> @spaceRoot do begin + bdNext := bd.next; + if (bd.addr >= startAddr) and (bd.addr + bd.size <= endAddr) then begin + if minAddr > bd.addr then + minAddr := bd.addr; + if maxAddr < bd.addr + bd.size then + maxAddr := bd.addr + bd.size; + if not VirtualFree(bd.addr, 0, MEM_RELEASE) then + heapErrorCode := cReleaseErr; + DeleteBlock(bd); + end; + bd := bdNext; + end; + result.addr := nil; + if maxAddr <> nil then begin + result.addr := minAddr; + result.size := maxAddr - minAddr; + end; +end; + + +function Commit(addr: Pointer; minSize: Integer): TBlock; +// Commits memory. +// Returns the block that was actually committed. +// Will return a block with addr = nil on failure. +var + bd: PBlockDesc; + loAddr, hiAddr, startAddr, endAddr: PChar; +begin + startAddr := PChar(Integer(addr) and not (cPageAlign-1)); + endAddr := PChar(((Integer(addr) + minSize) + (cPageAlign-1)) and not (cPageAlign-1)); + result.addr := startAddr; + result.size := endAddr - startAddr; + bd := spaceRoot.next; + while bd <> @spaceRoot do begin + // Commit the intersection of the block described by bd and [startAddr..endAddr) + loAddr := bd.addr; + hiAddr := loAddr + bd.size; + if loAddr < startAddr then + loAddr := startAddr; + if hiAddr > endAddr then + hiAddr := endAddr; + if loAddr < hiAddr then begin + if VirtualAlloc(loAddr, hiAddr - loAddr, MEM_COMMIT, PAGE_READWRITE) = nil then begin + result.addr := nil; + exit; + end; + end; + bd := bd.next; + end; +end; + + +function Decommit(addr: Pointer; maxSize: Integer): TBlock; +// Decommits address space. +// Returns the block that was actually decommitted. +var + bd: PBlockDesc; + loAddr, hiAddr, startAddr, endAddr: PChar; +begin + startAddr := PChar((Integer(addr) + + (cPageAlign-1)) and not (cPageAlign-1)); + endAddr := PChar((Integer(addr) + maxSize) and not (cPageAlign-1)); + result.addr := startAddr; + result.size := endAddr - startAddr; + bd := spaceRoot.next; + while bd <> @spaceRoot do begin + // Decommit the intersection of the block described by bd and [startAddr..endAddr) + loAddr := bd.addr; + hiAddr := loAddr + bd.size; + if loAddr < startAddr then + loAddr := startAddr; + if hiAddr > endAddr then + hiAddr := endAddr; + if loAddr < hiAddr then begin + if not VirtualFree(loAddr, hiAddr - loAddr, MEM_DECOMMIT) then + heapErrorCode := cDecommitErr; + end; + bd := bd.next; + end; +end; + + +// +// Committed space administration +// +const + cCommitAlign = 16*1024; + +var + decommittedRoot: TBlockDesc; + + +function GetCommitted(minSize: Integer): TBlock; +// Get a block of committed memory. +// Returns a committed memory block, possibly much bigger than requested. +// Will return a block with a nil addr on failure. +var + bd: PBlockDesc; +begin + minSize := (minSize + (cCommitAlign-1)) and not (cCommitAlign-1); + repeat + bd := decommittedRoot.next; + while bd <> @decommittedRoot do begin + if bd.size >= minSize then begin + result := Commit(bd.addr, minSize); + if result.addr = nil then + exit; + Inc(bd.addr, result.size); + Dec(bd.size, result.size); + if bd.size = 0 then + DeleteBlock(bd); + exit; + end; + bd := bd.next; + end; + result := GetSpace(minSize); + if result.addr = nil then + exit; + if MergeBlockAfter(@decommittedRoot, result).addr = nil then begin + FreeSpace(result.addr, result.size); + result.addr := nil; + exit; + end; + until False; +end; + + +function GetCommittedAt(addr: PChar; minSize: Integer): TBlock; +// Get at least minSize bytes committed space at addr. +// Success: returns a block, possibly much bigger than requested. +// Failure: returns a block with addr = nil. +var + bd: PBlockDesc; + b: TBlock; +begin + minSize := (minSize + (cCommitAlign-1)) and not (cCommitAlign-1); + repeat + + bd := decommittedRoot.next; + while (bd <> @decommittedRoot) and (bd.addr <> addr) do + bd := bd.next; + + if bd.addr = addr then begin + if bd.size >= minSize then + break; + b := GetSpaceAt(bd.addr + bd.size, minSize - bd.size); + if b.addr <> nil then begin + if MergeBlockAfter(@decommittedRoot, b).addr <> nil then + continue + else begin + FreeSpace(b.addr, b.size); + result.addr := nil; + exit; + end; + end; + end; + + b := GetSpaceAt(addr, minSize); + if b.addr = nil then + break; + + if MergeBlockAfter(@decommittedRoot, b).addr = nil then begin + FreeSpace(b.addr, b.size); + result.addr := nil; + exit; + end; + until false; + + if (bd.addr = addr) and (bd.size >= minSize) then begin + result := Commit(bd.addr, minSize); + if result.addr = nil then + exit; + Inc(bd.addr, result.size); + Dec(bd.size, result.size); + if bd.size = 0 then + DeleteBlock(bd); + end else + result.addr := nil; +end; + + +function FreeCommitted(addr: PChar; maxSize: Integer): TBlock; +// Free at most maxSize bytes of address space at addr. +// Returns the block that was actually freed. +var + startAddr, endAddr: PChar; + b: TBlock; +begin + startAddr := PChar(Integer(addr + (cCommitAlign-1)) and not (cCommitAlign-1)); + endAddr := PChar(Integer(addr + maxSize) and not (cCommitAlign-1)); + if endAddr > startAddr then begin + result := Decommit(startAddr, endAddr - startAddr); + b := MergeBlockAfter(@decommittedRoot, result); + if b.addr <> nil then + b := FreeSpace(b.addr, b.size); + if b.addr <> nil then + RemoveBlock(@decommittedRoot, b); + end else + result.addr := nil; +end; + + +// +// Suballocator (what the user program actually calls) +// + +type + PFree = ^TFree; + TFree = packed record + prev: PFree; + next: PFree; + size: Integer; + end; + PUsed = ^TUsed; + TUsed = packed record + sizeFlags: Integer; + end; + +const + cAlign = 4; + cThisUsedFlag = 2; + cPrevFreeFlag = 1; + cFillerFlag = Integer($80000000); + cFlags = cThisUsedFlag or cPrevFreeFlag or cFillerFlag; + cSmallSize = 4*1024; + cDecommitMin = 15*1024; + +type + TSmallTab = array [sizeof(TFree) div cAlign .. cSmallSize div cAlign] of PFree; + +VAR + avail : TFree; + rover : PFree; + remBytes : Integer; + curAlloc : PChar; + smallTab : ^TSmallTab; + committedRoot: TBlockDesc; + + +{X} // UninitAllocator - placed before InitAllocator to refer to. +procedure UninitAllocator; +// Shutdown. +var + bdb: PBlockDescBlock; + bd : PBlockDesc; +begin + if initialized then begin + try + if IsMultiThread then EnterCriticalSection(heapLock); + + initialized := False; + + LocalFree(smallTab); + smallTab := nil; + + bd := spaceRoot.next; + while bd <> @spaceRoot do begin + VirtualFree(bd.addr, 0, MEM_RELEASE); + bd := bd.next; + end; + + MakeEmpty(@spaceRoot); + MakeEmpty(@decommittedRoot); + MakeEmpty(@committedRoot); + + bdb := blockDescBlockList; + while bdb <> nil do begin + blockDescBlockList := bdb^.next; + LocalFree(bdb); + bdb := blockDescBlockList; + end; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + DeleteCriticalSection(heapLock); + end; + end; +end; + +function InitAllocator: Boolean; +// Initialize. No other calls legal before that. +var + i: Integer; + a: PFree; +begin + try + InitializeCriticalSection(heapLock); + if IsMultiThread then EnterCriticalSection(heapLock); + + MakeEmpty(@spaceRoot); + MakeEmpty(@decommittedRoot); + MakeEmpty(@committedRoot); + + smallTab := LocalAlloc(LMEM_FIXED, sizeof(smallTab^)); + if smallTab <> nil then begin + for i:= low(smallTab^) to high(smallTab^) do + smallTab[i] := nil; + + a := @avail; + a.next := a; + a.prev := a; + rover := a; + + initialized := True; + {X} // set here handler UninitMemoryManager to UninitAllocator } + {X} UninitMemoryManager := UninitAllocator; + end; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; + result := initialized; +end; + + + +procedure DeleteFree(f: PFree); +var + n, p: PFree; + size: Integer; +begin + if rover = f then + rover := f.next; + n := f.next; + size := f.size; + if size <= cSmallSize then begin + if n = f then + smallTab[size div cAlign] := nil + else begin + smallTab[size div cAlign] := n; + p := f.prev; + n.prev := p; + p.next := n; + end; + end else begin + p := f.prev; + n.prev := p; + p.next := n; + end; +end; + + +procedure InsertFree(a: Pointer; size: Integer); forward; + + +function FindCommitted(addr: PChar): PBlockDesc; +begin + result := committedRoot.next; + while result <> @committedRoot do begin + if (addr >= result.addr) and (addr < result.addr + result.size) then + exit; + result := result.next; + end; + heapErrorCode := cBadCommittedList; + result := nil; +end; + + +procedure FillBeforeGap(a: PChar; size: Integer); +var + rest: Integer; + e: PUsed; +begin + rest := size - sizeof(TUsed); + e := PUsed(a + rest); + if size >= sizeof(TFree) + sizeof(TUsed) then begin + e.sizeFlags := sizeof(TUsed) or cThisUsedFlag or cPrevFreeFlag or cFillerFlag; + InsertFree(a, rest); + end else if size >= sizeof(TUsed) then begin + PUsed(a).sizeFlags := size or (cThisUsedFlag or cFillerFlag); + e.sizeFlags := size or (cThisUsedFlag or cFillerFlag); + end; +end; + + +procedure InternalFreeMem(a: PChar); +begin + Inc(AllocMemCount); + Inc(AllocMemSize,PUsed(a-sizeof(TUsed)).sizeFlags and not cFlags - sizeof(TUsed)); + SysFreeMem(a); +end; + + +procedure FillAfterGap(a: PChar; size: Integer); +begin + if size >= sizeof(TFree) then begin + PUsed(a).sizeFlags := size or cThisUsedFlag; + InternalFreeMem(a + sizeof(TUsed)); + end else begin + if size >= sizeof(TUsed) then + PUsed(a).sizeFlags := size or (cThisUsedFlag or cFillerFlag); + Inc(a,size); + PUsed(a).sizeFlags := PUsed(a).sizeFlags and not cPrevFreeFlag; + end; +end; + + +function FillerSizeBeforeGap(a: PChar): Integer; +var + sizeFlags : Integer; + freeSize : Integer; + f : PFree; +begin + sizeFlags := PUsed(a - sizeof(TUsed)).sizeFlags; + if (sizeFlags and (cThisUsedFlag or cFillerFlag)) <> (cThisUsedFlag or cFillerFlag) then + heapErrorCode := cBadFiller1; + result := sizeFlags and not cFlags; + Dec(a, result); + if ((PUsed(a).sizeFlags xor sizeFlags) and not cPrevFreeFlag) <> 0 then + HeapErrorCode := cBadFiller2; + if (PUsed(a).sizeFlags and cPrevFreeFlag) <> 0 then begin + freeSize := PFree(a - sizeof(TFree)).size; + f := PFree(a - freeSize); + if f.size <> freeSize then + heapErrorCode := cBadFiller3; + DeleteFree(f); + Inc(result, freeSize); + end; +end; + + +function FillerSizeAfterGap(a: PChar): Integer; +var + sizeFlags: Integer; + f : PFree; +begin + result := 0; + sizeFlags := PUsed(a).sizeFlags; + if (sizeFlags and cFillerFlag) <> 0 then begin + sizeFlags := sizeFlags and not cFlags; + Inc(result,sizeFlags); + Inc(a, sizeFlags); + sizeFlags := PUsed(a).sizeFlags; + end; + if (sizeFlags and cThisUsedFlag) = 0 then begin + f := PFree(a); + DeleteFree(f); + Inc(result, f.size); + Inc(a, f.size); + PUsed(a).sizeFlags := PUsed(a).sizeFlags and not cPrevFreeFlag; + end; +end; + + +function DecommitFree(a: PChar; size: Integer): Boolean; +var + b: TBlock; + bd: PBlockDesc; +begin + Result := False; + bd := FindCommitted(a); + if bd = nil then Exit; + if bd.addr + bd.size - (a + size) <= sizeof(TFree) then + size := bd.addr + bd.size - a; + + if a - bd.addr < sizeof(TFree) then + b := FreeCommitted(bd.addr, size + (a - bd.addr)) + else + b := FreeCommitted(a + sizeof(TUsed), size - sizeof(TUsed)); + + if b.addr <> nil then + begin + FillBeforeGap(a, b.addr - a); + if bd.addr + bd.size > b.addr + b.size then + FillAfterGap(b.addr + b.size, a + size - (b.addr + b.size)); + RemoveBlock(bd,b); + result := True; + end; +end; + + +procedure InsertFree(a: Pointer; size: Integer); +var + f, n, p: PFree; +begin + f := PFree(a); + f.size := size; + PFree(PChar(f) + size - sizeof(TFree)).size := size; + if size <= cSmallSize then begin + n := smallTab[size div cAlign]; + if n = nil then begin + smallTab[size div cAlign] := f; + f.next := f; + f.prev := f; + end else begin + p := n.prev; + f.next := n; + f.prev := p; + n.prev := f; + p.next := f; + end; + end else if (size < cDecommitMin) or not DecommitFree(a, size) then begin + n := rover; + rover := f; + p := n.prev; + f.next := n; + f.prev := p; + n.prev := f; + p.next := f; + end; +end; + + +procedure FreeCurAlloc; +begin + if remBytes > 0 then begin + if remBytes < sizeof(TFree) then + heapErrorCode := cBadCurAlloc + else begin + PUsed(curAlloc).sizeFlags := remBytes or cThisUsedFlag; + InternalFreeMem(curAlloc + sizeof(TUsed)); + curAlloc := nil; + remBytes := 0; + end; + end; +end; + + +function MergeCommit(b: TBlock): Boolean; +var + merged: TBlock; + fSize: Integer; +begin + FreeCurAlloc; + merged := MergeBlockAfter(@committedRoot, b); + if merged.addr = nil then begin + result := False; + exit; + end; + + if merged.addr < b.addr then begin + fSize := FillerSizeBeforeGap(b.addr); + Dec(b.addr, fSize); + Inc(b.size, fSize); + end; + + if merged.addr + merged.size > b.addr + b.size then begin + fSize := FillerSizeAfterGap(b.addr + b.size); + Inc(b.size, fSize); + end; + + if merged.addr + merged.size = b.addr + b.size then begin + FillBeforeGap(b.addr + b.size - sizeof(TUsed), sizeof(TUsed)); + Dec(b.size, sizeof(TUsed)); + end; + + curAlloc := b.addr; + remBytes := b.size; + + result := True; +end; + + +function NewCommit(minSize: Integer): Boolean; +var + b: TBlock; +begin + b := GetCommitted(minSize+sizeof(TUsed)); + result := (b.addr <> nil) and MergeCommit(b); +end; + + +function NewCommitAt(addr: Pointer; minSize: Integer): Boolean; +var + b: TBlock; +begin + b := GetCommittedAt(addr, minSize+sizeof(TUsed)); + result := (b.addr <> nil) and MergeCommit(b); +end; + + +function SearchSmallBlocks(size: Integer): PFree; +var + i: Integer; +begin + result := nil; + for i := size div cAlign to High(smallTab^) do begin + result := smallTab[i]; + if result <> nil then + exit; + end; +end; + + +function TryHarder(size: Integer): Pointer; +var + u: PUsed; f:PFree; saveSize, rest: Integer; +begin + + repeat + + f := avail.next; + if (size <= f.size) then + break; + + f := rover; + if f.size >= size then + break; + + saveSize := f.size; + f.size := size; + repeat + f := f.next + until f.size >= size; + rover.size := saveSize; + if f <> rover then begin + rover := f; + break; + end; + + if size <= cSmallSize then begin + f := SearchSmallBlocks(size); + if f <> nil then + break; + end; + + if not NewCommit(size) then begin + result := nil; + exit; + end; + + if remBytes >= size then begin + Dec(remBytes, size); + if remBytes < sizeof(TFree) then begin + Inc(size, remBytes); + remBytes := 0; + end; + u := PUsed(curAlloc); + Inc(curAlloc, size); + u.sizeFlags := size or cThisUsedFlag; + result := PChar(u) + sizeof(TUsed); + Inc(AllocMemCount); + Inc(AllocMemSize,size - sizeof(TUsed)); + exit; + end; + + until False; + + DeleteFree(f); + + rest := f.size - size; + if rest >= sizeof(TFree) then begin + InsertFree(PChar(f) + size, rest); + end else begin + size := f.size; + if f = rover then + rover := f.next; + u := PUsed(PChar(f) + size); + u.sizeFlags := u.sizeFlags and not cPrevFreeFlag; + end; + + u := PUsed(f); + u.sizeFlags := size or cThisUsedFlag; + + result := PChar(u) + sizeof(TUsed); + Inc(AllocMemCount); + Inc(AllocMemSize,size - sizeof(TUsed)); + +end; + + +function SysGetMem(size: Integer): Pointer; +// Allocate memory block. +var + f, prev, next: PFree; + u: PUsed; +begin + + if (not initialized and not InitAllocator) or + (size > (High(size) - (sizeof(TUsed) + (cAlign-1)))) then + begin + result := nil; + exit; + end; + + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + Inc(size, sizeof(TUsed) + (cAlign-1)); + size := size and not (cAlign-1); + if size < sizeof(TFree) then + size := sizeof(TFree); + + if size <= cSmallSize then begin + f := smallTab[size div cAlign]; + if f <> nil then begin + u := PUsed(PChar(f) + size); + u.sizeFlags := u.sizeFlags and not cPrevFreeFlag; + next := f.next; + if next = f then + smallTab[size div cAlign] := nil + else begin + smallTab[size div cAlign] := next; + prev := f.prev; + prev.next := next; + next.prev := prev; + end; + u := PUsed(f); + u.sizeFlags := f.size or cThisUsedFlag; + result := PChar(u) + sizeof(TUsed); + Inc(AllocMemCount); + Inc(AllocMemSize,size - sizeof(TUsed)); + exit; + end; + end; + + if size <= remBytes then begin + Dec(remBytes, size); + if remBytes < sizeof(TFree) then begin + Inc(size, remBytes); + remBytes := 0; + end; + u := PUsed(curAlloc); + Inc(curAlloc, size); + u.sizeFlags := size or cThisUsedFlag; + result := PChar(u) + sizeof(TUsed); + Inc(AllocMemCount); + Inc(AllocMemSize,size - sizeof(TUsed)); + exit; + end; + + result := TryHarder(size); + + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; + +end; + + +function SysFreeMem(p: Pointer): Integer; +// Deallocate memory block. +label + abort; +var + u, n : PUsed; + f : PFree; + prevSize, nextSize, size : Integer; +begin + heapErrorCode := cHeapOk; + + if not initialized and not InitAllocator then begin + heapErrorCode := cCantInit; + result := cCantInit; + exit; + end; + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + u := p; + u := PUsed(PChar(u) - sizeof(TUsed)); { inv: u = address of allocated block being freed } + size := u.sizeFlags; + { inv: size = SET(block size) + [block flags] } + + { validate that the interpretation of this block as a used block is correct } + if (size and cThisUsedFlag) = 0 then begin + heapErrorCode := cBadUsedBlock; + goto abort; + end; + + { inv: the memory block addressed by 'u' and 'p' is an allocated block } + + Dec(AllocMemCount); + Dec(AllocMemSize,size and not cFlags - sizeof(TUsed)); + + if (size and cPrevFreeFlag) <> 0 then begin + { previous block is free, coalesce } + prevSize := PFree(PChar(u)-sizeof(TFree)).size; + if (prevSize < sizeof(TFree)) or ((prevSize and cFlags) <> 0) then begin + heapErrorCode := cBadPrevBlock; + goto abort; + end; + + f := PFree(PChar(u) - prevSize); + if f^.size <> prevSize then begin + heapErrorCode := cBadPrevBlock; + goto abort; + end; + + inc(size, prevSize); + u := PUsed(f); + DeleteFree(f); + end; + + size := size and not cFlags; + { inv: size = block size } + + n := PUsed(PChar(u) + size); + { inv: n = block following the block to free } + + if PChar(n) = curAlloc then begin + { inv: u = last block allocated } + dec(curAlloc, size); + inc(remBytes, size); + if remBytes > cDecommitMin then + FreeCurAlloc; + result := cHeapOk; + exit; + end; + + if (n.sizeFlags and cThisUsedFlag) <> 0 then begin + { inv: n is a used block } + if (n.sizeFlags and not cFlags) < sizeof(TUsed) then begin + heapErrorCode := cBadNextBlock; + goto abort; + end; + n.sizeFlags := n.sizeFlags or cPrevFreeFlag + end else begin + { inv: block u & n are both free; coalesce } + f := PFree(n); + if (f.next = nil) or (f.prev = nil) or (f.size < sizeof(TFree)) then begin + heapErrorCode := cBadNextBlock; + goto abort; + end; + nextSize := f.size; + inc(size, nextSize); + DeleteFree(f); + { inv: last block (which was free) is not on free list } + end; + + InsertFree(u, size); +abort: + result := heapErrorCode; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; +end; + + +function ResizeInPlace(p: Pointer; newSize: Integer): Boolean; +var u, n: PUsed; f: PFree; oldSize, blkSize, neededSize: Integer; +begin + Inc(newSize, sizeof(TUsed)+cAlign-1); + newSize := newSize and not (cAlign-1); + if newSize < sizeof(TFree) then + newSize := sizeof(TFree); + u := PUsed(PChar(p) - sizeof(TUsed)); + oldSize := u.sizeFlags and not cFlags; + n := PUsed( PChar(u) + oldSize ); + if newSize <= oldSize then begin + blkSize := oldSize - newSize; + if PChar(n) = curAlloc then begin + Dec(curAlloc, blkSize); + Inc(remBytes, blkSize); + if remBytes < sizeof(TFree) then begin + Inc(curAlloc, blkSize); + Dec(remBytes, blkSize); + newSize := oldSize; + end; + end else begin + n := PUsed(PChar(u) + oldSize); + if n.sizeFlags and cThisUsedFlag = 0 then begin + f := PFree(n); + Inc(blkSize, f.size); + DeleteFree(f); + end; + if blkSize >= sizeof(TFree) then begin + n := PUsed(PChar(u) + newSize); + n.sizeFlags := blkSize or cThisUsedFlag; + InternalFreeMem(PChar(n) + sizeof(TUsed)); + end else + newSize := oldSize; + end; + end else begin + repeat + neededSize := newSize - oldSize; + if PChar(n) = curAlloc then begin + if remBytes >= neededSize then begin + Dec(remBytes, neededSize); + Inc(curAlloc, neededSize); + if remBytes < sizeof(TFree) then begin + Inc(curAlloc, remBytes); + Inc(newSize, remBytes); + remBytes := 0; + end; + Inc(AllocMemSize, newSize - oldSize); + u.sizeFlags := newSize or u.sizeFlags and cFlags; + result := true; + exit; + end else begin + FreeCurAlloc; + n := PUsed( PChar(u) + oldSize ); + end; + end; + + if n.sizeFlags and cThisUsedFlag = 0 then begin + f := PFree(n); + blkSize := f.size; + if blkSize < neededSize then begin + n := PUsed(PChar(n) + blkSize); + Dec(neededSize, blkSize); + end else begin + DeleteFree(f); + Dec(blkSize, neededSize); + if blkSize >= sizeof(TFree) then + InsertFree(PChar(u) + newSize, blkSize) + else begin + Inc(newSize, blkSize); + n := PUsed(PChar(u) + newSize); + n.sizeFlags := n.sizeFlags and not cPrevFreeFlag; + end; + break; + end; + end; + + if n.sizeFlags and cFillerFlag <> 0 then begin + n := PUsed(PChar(n) + n.sizeFlags and not cFlags); + if NewCommitAt(n, neededSize) then begin + n := PUsed( PChar(u) + oldSize ); + continue; + end; + end; + + result := False; + exit; + + until False; + + end; + + Inc(AllocMemSize, newSize - oldSize); + u.sizeFlags := newSize or u.sizeFlags and cFlags; + result := True; + +end; + + +function SysReallocMem(p: Pointer; size: Integer): Pointer; +// Resize memory block. +var + n: Pointer; oldSize: Integer; +begin + + if not initialized and not InitAllocator then begin + result := nil; + exit; + end; + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + if ResizeInPlace(p, size) then + result := p + else begin + n := SysGetMem(size); + oldSize := (PUsed(PChar(p)-sizeof(PUsed)).sizeFlags and not cFlags) - sizeof(TUsed); + if oldSize > size then + oldSize := size; + if n <> nil then begin + Move(p^, n^, oldSize); + SysFreeMem(p); + end; + result := n; + end; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; + +end; + + +function BlockSum(root: PBlockDesc): Integer; +var + b : PBlockDesc; +begin + result := 0; + b := root.next; + while b <> root do begin + Inc(result, b.size); + b := b.next; + end; +end; + + +function GetHeapStatus: THeapStatus; +var + size, freeSize, userSize: Cardinal; + f: PFree; + a, e: PChar; + i: Integer; + b: PBlockDesc; + prevFree: Boolean; +begin + + result.TotalAddrSpace := 0; + result.TotalUncommitted := 0; + result.TotalCommitted := 0; + result.TotalAllocated := 0; + result.TotalFree := 0; + result.FreeSmall := 0; + result.FreeBig := 0; + result.Unused := 0; + result.Overhead := 0; + result.HeapErrorCode := cHeapOk; + + if not initialized then exit; + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + result.totalAddrSpace := BlockSum(@spaceRoot); + result.totalUncommitted := BlockSum(@decommittedRoot); + result.totalCommitted := BlockSum(@committedRoot); + + size := 0; + for i := Low(smallTab^) to High(smallTab^) do begin + f := smallTab[i]; + if f <> nil then begin + repeat + Inc(size, f.size); + if (f.prev.next <> f) or (f.next.prev <> f) or (f.size < sizeof(TFree)) then begin + heapErrorCode := cBadFreeList; + break; + end; + f := f.next; + until f = smallTab[i]; + end; + end; + result.freeSmall := size; + + size := 0; + f := avail.next; + while f <> @avail do begin + if (f.prev.next <> f) or (f.next.prev <> f) or (f.size < sizeof(TFree)) then begin + heapErrorCode := cBadFreeList; + break; + end; + Inc(size, f.size); + f := f.next; + end; + result.freeBig := size; + + result.unused := remBytes; + result.totalFree := result.freeSmall + result.freeBig + result.unused; + + freeSize := 0; + userSize := 0; + result.overhead := 0; + + b := committedRoot.next; + prevFree := False; + while b <> @committedRoot do begin + a := b.addr; + e := a + b.size; + while a < e do begin + if (a = curAlloc) and (remBytes > 0) then begin + size := remBytes; + Inc(freeSize, size); + if prevFree then + heapErrorCode := cBadCurAlloc; + prevFree := False; + end else begin + if prevFree <> ((PUsed(a).sizeFlags and cPrevFreeFlag) <> 0) then + heapErrorCode := cBadNextBlock; + if (PUsed(a).sizeFlags and cThisUsedFlag) = 0 then begin + f := PFree(a); + if (f.prev.next <> f) or (f.next.prev <> f) or (f.size < sizeof(TFree)) then + heapErrorCode := cBadFreeBlock; + size := f.size; + Inc(freeSize, size); + prevFree := True; + end else begin + size := PUsed(a).sizeFlags and not cFlags; + if (PUsed(a).sizeFlags and cFillerFlag) <> 0 then begin + Inc(result.overhead, size); + if (a > b.addr) and (a + size < e) then + heapErrorCode := cBadUsedBlock; + end else begin + Inc(userSize, size-sizeof(TUsed)); + Inc(result.overhead, sizeof(TUsed)); + end; + prevFree := False; + end; + end; + Inc(a, size); + end; + b := b.next; + end; + if result.totalFree <> freeSize then + heapErrorCode := cBadBalance; + + result.totalAllocated := userSize; + result.heapErrorCode := heapErrorCode; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; +end; + + +// this section goes into GetMem.Inc + +{$IFDEF DEBUG_FUNCTIONS} +type + THeapReportProc = procedure(HeapBlock: Pointer; AllocatedSize: Integer) of object; + + +procedure WalkHeap(HeapReportProc: THeapReportProc); +var + size : Cardinal; + f: PFree; + a, e: PChar; + b: PBlockDesc; +begin + + if not initialized then exit; + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + b := committedRoot.next; + while b <> @committedRoot do begin + a := b.addr; + e := a + b.size; + while a < e do begin + if (a = curAlloc) and (remBytes > 0) then begin + size := remBytes; + end else begin + if (PUsed(a).sizeFlags and cThisUsedFlag) = 0 then begin + f := PFree(a); + size := f.size; + end else begin + size := PUsed(a).sizeFlags and not cFlags; + if (PUsed(a).sizeFlags and cFillerFlag) = 0 then begin + HeapReportProc(a + sizeof(TUsed), size - sizeof(TUsed)); + end; + end; + end; + Inc(a, size); + end; + b := b.next; + end; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; +end; + +type + THeapBlockCollector = class(TObject) + FCount: Integer; + FObjectTable: TObjectArray; + FHeapBlockTable: THeapBlockArray; + FClass: TClass; + FFindDerived: Boolean; + procedure CollectBlocks(HeapBlock: Pointer; AllocatedSize: Integer); + procedure CollectObjects(HeapBlock: Pointer; AllocatedSize: Integer); + end; + + +procedure THeapBlockCollector.CollectBlocks(HeapBlock: Pointer; AllocatedSize: Integer); +begin + if FCount < Length(FHeapBlockTable) then + begin + FHeapBlockTable[FCount].Start := HeapBlock; + FHeapBlockTable[FCount].Size := AllocatedSize; + end; + Inc(FCount); +end; + + +procedure THeapBlockCollector.CollectObjects(HeapBlock: Pointer; AllocatedSize: Integer); +var + AObject: TObject; + AClass: TClass; +type + PPointer = ^Pointer; +begin + try + if AllocatedSize < 4 then + Exit; + AObject := TObject(HeapBlock); + AClass := AObject.ClassType; + if (AClass = FClass) + or (FFindDerived + and (Integer(AClass) >= 64*1024) + and (PPointer(PChar(AClass) + vmtSelfPtr)^ = Pointer(AClass)) + and (AObject is FClass)) then + begin + if FCount < Length(FObjectTable) then + FObjectTable[FCount] := AObject; + Inc(FCount); + end; + except + // Let's not worry about this block - it's obviously not a valid object + end; +end; + +var + HeapBlockCollector: THeapBlockCollector; + +function GetHeapBlocks: THeapBlockArray; +begin + if not Assigned(HeapBlockCollector) then + HeapBlockCollector := THeapBlockCollector.Create; + + Walkheap(HeapBlockCollector.CollectBlocks); + SetLength(HeapBlockCollector.FHeapBlockTable, HeapBlockCollector.FCount); + HeapBlockCollector.FCount := 0; + Walkheap(HeapBlockCollector.CollectBlocks); + Result := HeapBlockCollector.FHeapBlockTable; + HeapBlockCollector.FCount := 0; + HeapBlockCollector.FHeapBlockTable := nil; +end; + + +function FindObjects(AClass: TClass; FindDerived: Boolean): TObjectArray; +begin + if not Assigned(HeapBlockCollector) then + HeapBlockCollector := THeapBlockCollector.Create; + HeapBlockCollector.FClass := AClass; + HeapBlockCollector.FFindDerived := FindDerived; + + Walkheap(HeapBlockCollector.CollectObjects); + SetLength(HeapBlockCollector.FObjectTable, HeapBlockCollector.FCount); + HeapBlockCollector.FCount := 0; + Walkheap(HeapBlockCollector.CollectObjects); + Result := HeapBlockCollector.FObjectTable; + HeapBlockCollector.FCount := 0; + HeapBlockCollector.FObjectTable := nil; +end; +{$ENDIF} + + diff --git a/System/D2009beta/SYSWSTR.PAS b/System/D2009beta/SYSWSTR.PAS new file mode 100644 index 0000000..ab8a677 --- /dev/null +++ b/System/D2009beta/SYSWSTR.PAS @@ -0,0 +1,18 @@ +unit syswstr; +{X: this unit contains some definitions and initializations, needed to + support wide string variables. To use it, just place reference to syswstr + unit in your dpr/units uses clause *as first as possible* } + +interface + +implementation + +initialization + + WStrAddRefProc := WStrAddRef; + WStrClrProc := WStrClr; + WStrArrayClrProc := WStrArrayClr; + +finalization + +end. diff --git a/System/D2009beta/SysConst.pas b/System/D2009beta/SysConst.pas new file mode 100644 index 0000000..c0f6754 --- /dev/null +++ b/System/D2009beta/SysConst.pas @@ -0,0 +1,184 @@ +{ *********************************************************************** } +{ } +{ Delphi / Kylix Cross-Platform Runtime Library } +{ } +{ Copyright (c) 1995, 2001 Borland Software Corporation } +{ } +{ *********************************************************************** } + +unit SysConst; + +interface + +resourcestring + SUnknown = ''; + SInvalidInteger = '''%s'' is not a valid integer value'; + SInvalidFloat = '''%s'' is not a valid floating point value'; + SInvalidCurrency = '''%s'' is not a valid currency value'; + SInvalidDate = '''%s'' is not a valid date'; + SInvalidTime = '''%s'' is not a valid time'; + SInvalidDateTime = '''%s'' is not a valid date and time'; + SInvalidDateTimeFloat = '''%g'' is not a valid date and time'; + SInvalidTimeStamp = '''%d.%d'' is not a valid timestamp'; + SInvalidGUID = '''%s'' is not a valid GUID value'; + SInvalidBoolean = '''%s'' is not a valid boolean value'; + STimeEncodeError = 'Invalid argument to time encode'; + SDateEncodeError = 'Invalid argument to date encode'; + SOutOfMemory = 'Out of memory'; + SInOutError = 'I/O error %d'; + SFileNotFound = 'File not found'; + SInvalidFilename = 'Invalid filename'; + STooManyOpenFiles = 'Too many open files'; + SAccessDenied = 'File access denied'; + SEndOfFile = 'Read beyond end of file'; + SDiskFull = 'Disk full'; + SInvalidInput = 'Invalid numeric input'; + SDivByZero = 'Division by zero'; + SRangeError = 'Range check error'; + SIntOverflow = 'Integer overflow'; + SInvalidOp = 'Invalid floating point operation'; + SZeroDivide = 'Floating point division by zero'; + SOverflow = 'Floating point overflow'; + SUnderflow = 'Floating point underflow'; + SInvalidPointer = 'Invalid pointer operation'; + SInvalidCast = 'Invalid class typecast'; +{$IFDEF MSWINDOWS} + SAccessViolationArg3 = 'Access violation at address %p. %s of address %p'; +{$ENDIF} +{$IFDEF LINUX} + SAccessViolationArg2 = 'Access violation at address %p, accessing address %p'; +{$ENDIF} + SAccessViolationNoArg = 'Access violation'; + SStackOverflow = 'Stack overflow'; + SControlC = 'Control-C hit'; + SQuit = 'Quit key hit'; + SPrivilege = 'Privileged instruction'; + SOperationAborted = 'Operation aborted'; + SException = 'Exception %s in module %s at %p.' + sLineBreak + '%s%s' + sLineBreak; + SExceptTitle = 'Application Error'; +{$IFDEF LINUX} + SSigactionFailed = 'sigaction call failed'; +{$ENDIF} + SInvalidFormat = 'Format ''%s'' invalid or incompatible with argument'; + SArgumentMissing = 'No argument for format ''%s'''; + SDispatchError = 'Variant method calls not supported'; + SReadAccess = 'Read'; + SWriteAccess = 'Write'; + SResultTooLong = 'Format result longer than 4096 characters'; + SFormatTooLong = 'Format string too long'; + + SVarArrayCreate = 'Error creating variant or safe array'; + SVarArrayBounds = 'Variant or safe array index out of bounds'; + SVarArrayLocked = 'Variant or safe array is locked'; + SVarArrayWithHResult = 'Unexpected variant or safe array error: %s%.8x'; + + SInvalidVarCast = 'Invalid variant type conversion'; + SInvalidVarOp = 'Invalid variant operation'; + SInvalidVarNullOp = 'Invalid NULL variant operation'; + SInvalidVarOpWithHResultWithPrefix = 'Invalid variant operation (%s%.8x)'#10'%s'; + SVarTypeRangeCheck1 = 'Range check error for variant of type (%s)'; + SVarTypeRangeCheck2 = 'Range check error while converting variant of type (%s) into type (%s)'; + SVarTypeOutOfRangeWithPrefix = 'Custom variant type (%s%.4x) is out of range'; + SVarTypeAlreadyUsedWithPrefix = 'Custom variant type (%s%.4x) already used by %s'; + SVarTypeNotUsableWithPrefix = 'Custom variant type (%s%.4x) is not usable'; + SVarTypeTooManyCustom = 'Too many custom variant types have been registered'; + + // the following are not used anymore + SVarNotArray = 'Variant is not an array' deprecated; // not used, use SVarInvalid instead + SVarTypeUnknown = 'Unknown custom variant type ($%.4x)' deprecated; // not used anymore + SVarTypeOutOfRange = 'Custom variant type ($%.4x) is out of range' deprecated; + SVarTypeAlreadyUsed = 'Custom variant type ($%.4x) already used by %s' deprecated; + SVarTypeNotUsable = 'Custom variant type ($%.4x) is not usable' deprecated; + SInvalidVarOpWithHResult = 'Invalid variant operation ($%.8x)' deprecated; + + SVarTypeCouldNotConvert = 'Could not convert variant of type (%s) into type (%s)'; + SVarTypeConvertOverflow = 'Overflow while converting variant of type (%s) into type (%s)'; + SVarOverflow = 'Variant overflow'; + SVarInvalid = 'Invalid argument'; + SVarBadType = 'Invalid variant type'; + SVarNotImplemented = 'Operation not supported'; + SVarOutOfMemory = 'Variant operation ran out memory'; + SVarUnexpected = 'Unexpected variant error'; + + SVarDataClearRecursing = 'Recursion while doing a VarDataClear'; + SVarDataCopyRecursing = 'Recursion while doing a VarDataCopy'; + SVarDataCopyNoIndRecursing = 'Recursion while doing a VarDataCopyNoInd'; + SVarDataInitRecursing = 'Recursion while doing a VarDataInit'; + SVarDataCastToRecursing = 'Recursion while doing a VarDataCastTo'; + SVarIsEmpty = 'Variant is empty'; + sUnknownFromType = 'Cannot convert from the specified type'; + sUnknownToType = 'Cannot convert to the specified type'; + SExternalException = 'External exception %x'; + SAssertionFailed = 'Assertion failed'; + SIntfCastError = 'Interface not supported'; + SSafecallException = 'Exception in safecall method'; + SAssertError = '%s (%s, line %d)'; + SAbstractError = 'Abstract Error'; + SModuleAccessViolation = 'Access violation at address %p in module ''%s''. %s of address %p'; + SCannotReadPackageInfo = 'Cannot access package information for package ''%s'''; + sErrorLoadingPackage = 'Can''t load package %s.'+sLineBreak+'%s'; + SInvalidPackageFile = 'Invalid package file ''%s'''; + SInvalidPackageHandle = 'Invalid package handle'; + SDuplicatePackageUnit = 'Cannot load package ''%s.'' It contains unit ''%s,''' + + 'which is also contained in package ''%s'''; + SOSError = 'System Error. Code: %d.'+sLineBreak+'%s'; + SUnkOSError = 'A call to an OS function failed'; +{$IFDEF MSWINDOWS} + SWin32Error = 'Win32 Error. Code: %d.'#10'%s' deprecated; // use SOSError + SUnkWin32Error = 'A Win32 API function failed' deprecated; // use SUnkOSError +{$ENDIF} + SNL = 'Application is not licensed to use this feature'; + + SShortMonthNameJan = 'Jan'; + SShortMonthNameFeb = 'Feb'; + SShortMonthNameMar = 'Mar'; + SShortMonthNameApr = 'Apr'; + SShortMonthNameMay = 'May'; + SShortMonthNameJun = 'Jun'; + SShortMonthNameJul = 'Jul'; + SShortMonthNameAug = 'Aug'; + SShortMonthNameSep = 'Sep'; + SShortMonthNameOct = 'Oct'; + SShortMonthNameNov = 'Nov'; + SShortMonthNameDec = 'Dec'; + + SLongMonthNameJan = 'January'; + SLongMonthNameFeb = 'February'; + SLongMonthNameMar = 'March'; + SLongMonthNameApr = 'April'; + SLongMonthNameMay = 'May'; + SLongMonthNameJun = 'June'; + SLongMonthNameJul = 'July'; + SLongMonthNameAug = 'August'; + SLongMonthNameSep = 'September'; + SLongMonthNameOct = 'October'; + SLongMonthNameNov = 'November'; + SLongMonthNameDec = 'December'; + + SShortDayNameSun = 'Sun'; + SShortDayNameMon = 'Mon'; + SShortDayNameTue = 'Tue'; + SShortDayNameWed = 'Wed'; + SShortDayNameThu = 'Thu'; + SShortDayNameFri = 'Fri'; + SShortDayNameSat = 'Sat'; + + SLongDayNameSun = 'Sunday'; + SLongDayNameMon = 'Monday'; + SLongDayNameTue = 'Tuesday'; + SLongDayNameWed = 'Wednesday'; + SLongDayNameThu = 'Thursday'; + SLongDayNameFri = 'Friday'; + SLongDayNameSat = 'Saturday'; + +{$IFDEF LINUX} + SEraEntries = ''; +{$ENDIF} + + SCannotCreateDir = 'Unable to create directory'; + SCodesetConversionError = 'Codeset conversion failure'; + +implementation + +end. + diff --git a/System/D2009beta/SysInit.pas b/System/D2009beta/SysInit.pas new file mode 100644 index 0000000..3abc531 --- /dev/null +++ b/System/D2009beta/SysInit.pas @@ -0,0 +1,864 @@ +{ *********************************************************************** } +{ } +{ Delphi / Kylix Cross-Platform Runtime Library } +{ System Initialization Unit } +{ } +{ Copyright (c) 1997-2002 Borland Software Corporation } +{ } +{ This file may be distributed and/or modified under the terms of the } +{ GNU General Public License version 2 as published by the Free Software } +{ Foundation and appearing at http://www.borland.com/kylix/gpl.html. } +{ } +{ Licensees holding a valid Borland No-Nonsense License for this } +{ Software may use this file in accordance with such license, which } +{ appears in the file license.txt that came with this software. } +{ } +{ *********************************************************************** } + +unit SysInit; +//Изменено: Avenger + +interface + +{$H+,I-,R-,S-,O+,W-} +{$WARN SYMBOL_PLATFORM OFF} + +{X} // if your app really need to localize resource, call: +{X} procedure UseLocalizeResources; + +{$IFDEF LINUX} +const + ExeBaseAddress = Pointer($8048000) platform; +{$ENDIF} + +var + Copyright : String = '';//{'Portions Copyright (c) 1999,2003'; //}'Portions Copyright (c) 1999,2003 Avenger by NhT'; + + ModuleIsLib: Boolean; { True if this module is a dll (a library or a package) } + ModuleIsPackage: Boolean; { True if this module is a package } + ModuleIsCpp: Boolean; { True if this module is compiled using C++ Builder } + TlsIndex: Integer = -1; { Thread local storage index } + TlsLast: Byte; { Set by linker so its offset is last in TLS segment } + HInstance: LongWord; { Handle of this instance } + {$EXTERNALSYM HInstance} + (*$HPPEMIT 'namespace Sysinit' *) + (*$HPPEMIT '{' *) + (*$HPPEMIT 'extern PACKAGE HINSTANCE HInstance;' *) + (*$HPPEMIT '} /* namespace Sysinit */' *) + DllProc: TDLLProc; { Called whenever DLL entry point is called } + { DllProcEx passes the Reserved param provided by WinNT on DLL load & exit } + DllProcEx: TDLLProcEx absolute DllProc; + DataMark: Integer = 0; { Used to find the virtual base of DATA seg } + CoverageLibraryName: array [0..128] of char = '*'; { initialized by the linker! } +{$IFDEF ELF} + TypeImportsTable: array [0..0] of Pointer platform; { VMT and RTTI imports table for exes } + _GLOBAL_OFFSET_TABLE_: ARRAY [0..2] OF Cardinal platform; + (* _DYNAMIC: ARRAY [0..0] OF Elf32_Dyn; *) +{$IFDEF PC_MAPPED_EXCEPTIONS} + TextStartAdj: Byte platform; { See GetTextStart } + CodeSegSize: Byte platform; { See GetTextStart } +function GetTextStart : LongInt; platform; +{$ENDIF} +{$ENDIF} + +const + PtrToNil: Pointer = nil; // provides pointer to nil for compiler codegen + +function _GetTls: Pointer; +{$IFDEF LINUX} +procedure _InitLib(Context: PInitContext); +procedure _GetCallerEIP; +procedure _InitExe(InitTable: Pointer; Argc: Integer; Argp: Pointer); +procedure _start; cdecl; +function _ExitLib: Integer; cdecl; +function _InitPkg: LongBool; +{$ENDIF} +{$IFDEF MSWINDOWS} +procedure _InitLib; +procedure _InitExe(InitTable: Pointer); +function _InitPkg(Hinst: Integer; Reason: Integer; Resvd: Pointer): LongBool; stdcall; +{$ENDIF} +procedure _PackageLoad(const Table: PackageInfo); +procedure _PackageUnload(const Table: PackageInfo); + +{ Invoked by C++ startup code to allow initialization of VCL global vars } +procedure VclInit(isDLL, isPkg: Boolean; hInst: LongInt; isGui: Boolean); cdecl; +procedure VclExit; cdecl; + +{$IFDEF LINUX} +function GetThisModuleHandle: LongWord; +{$ENDIF} + +implementation + +{$IFDEF MSWINDOWS} +const + kernel = 'kernel32.dll'; + +function FreeLibrary(ModuleHandle: Longint): LongBool; stdcall; + external kernel name 'FreeLibrary'; + +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 LocalAlloc(flags, size: Integer): Pointer; stdcall; + external kernel name 'LocalAlloc'; + +function LocalFree(addr: Pointer): Pointer; stdcall; + external kernel name 'LocalFree'; + +function TlsAlloc: Integer; stdcall; + external kernel name 'TlsAlloc'; + +function TlsFree(TlsIndex: Integer): Boolean; stdcall; + external kernel name 'TlsFree'; + +function TlsGetValue(TlsIndex: Integer): Pointer; stdcall; + external kernel name 'TlsGetValue'; + +function TlsSetValue(TlsIndex: Integer; TlsValue: Pointer): Boolean; stdcall; + external kernel name 'TlsSetValue'; + +function GetCommandLine: PChar; stdcall; + external kernel name 'GetCommandLineA'; + +const + tlsArray = $2C; { offset of tls array from FS: } + LMEM_ZEROINIT = $40; + +function AllocTlsBuffer(Size: Integer): Pointer; +begin + Result := LocalAlloc(LMEM_ZEROINIT, Size); +end; + +var + tlsBuffer: Pointer; // RTM32 DOS support +{$ENDIF} + +{$IFDEF LINUX} + +{$IFDEF PIC} +function GetGOT: Pointer; export; +begin + asm + MOV Result,EBX + end; +end; +{$ENDIF} + +const + RTLD_LAZY = 1; + RTLD_NOW = 2; + RTLD_BINDING_MASK = RTLD_LAZY or RTLD_NOW; + RTLD_GLOBAL = $100; + RTLD_LOCAL = 0; + RTLD_NEXT = Pointer(-1); + RTLD_DEFAULT = nil; + +type + TDLInfo = record + Filename: PChar; + BaseAddress: Pointer; + NearestSymbolName: PChar; + NearestSymbolAddr: Pointer; + end; + +const + libcmodulename = 'libc.so.6'; + libdlmodulename = 'libdl.so.2'; + libpthreadmodulename = 'libpthread.so.0'; + tlsSizeName = '@Sysinit@tlsSize'; + +function malloc(Size: LongWord): Pointer; cdecl; + external libcmodulename name 'malloc'; + +procedure free(P: Pointer); cdecl; + external libcmodulename name 'free'; + +function dlopen(Filename: PChar; Flag: Integer): LongWord; cdecl; + external libdlmodulename name 'dlopen'; + +function dlerror: PChar; cdecl; + external libdlmodulename name 'dlerror'; + +function dlsym(Handle: LongWord; Symbol: PChar): Pointer; cdecl; + external libdlmodulename name 'dlsym'; + +function dlclose(Handle: LongWord): Integer; cdecl; + external libdlmodulename name 'dlclose'; + +function FreeLibrary(Handle: LongWord): Integer; cdecl; + external libdlmodulename name 'dlclose'; + +function dladdr(Address: Pointer; var Info: TDLInfo): Integer; cdecl; + external libdlmodulename name 'dladdr'; + +type + TInitOnceProc = procedure; cdecl; + TKeyValueDestructor = procedure(ValueInKey: Pointer); cdecl; + +function pthread_once(var InitOnceSemaphore: Integer; InitOnceProc: TInitOnceProc): Integer; cdecl; + external libpthreadmodulename name 'pthread_once'; + +function pthread_key_create(var Key: Integer; KeyValueDestructor: TKeyValueDestructor): Integer; cdecl; + external libpthreadmodulename name 'pthread_key_create'; + +function pthread_key_delete(Key: Integer): Integer; cdecl; + external libpthreadmodulename name 'pthread_key_delete'; + +function TlsGetValue(Key: Integer): Pointer; cdecl; + external libpthreadmodulename name 'pthread_getspecific'; + +function TlsSetValue(Key: Integer; Ptr: Pointer): Integer; cdecl; + external libpthreadmodulename name 'pthread_setspecific'; + +function AllocTlsBuffer(Size: Cardinal): Pointer; +begin + // The C++ rtl handles all tls in a C++ module + if ModuleIsCpp then + RunError(226); + + Result := malloc(Size); + if Result <> nil then + FillChar(Result^, Size, 0); +end; + +procedure FreeTLSBuffer(ValueInKey: Pointer); export cdecl; +begin + // The C++ rtl handles all tls in a C++ module + if ModuleIsCpp then + RunError(226); + free(ValueInKey); +end; + +procedure AllocTlsIndex; cdecl export; +begin + // guaranteed to reach here only once per process + // The C++ rtl handles all tls in a C++ module + if ModuleIsCpp then + RunError(226); + if pthread_key_create(TlsIndex, FreeTLSBuffer) <> 0 then + begin + TlsIndex := -1; + RunError(226); + end; +end; + +function GetThisModuleHandle: LongWord; +var + Info: TDLInfo; +begin + if (dladdr(@GetThisModuleHandle, Info) = 0) or (Info.BaseAddress = ExeBaseAddress) then + Info.FileName := nil; // if we're not in a library, we must be main exe + Result := LongWord(dlopen(Info.Filename, RTLD_LAZY)); + if Result <> 0 then + dlclose(Result); +end; + +var + InitOnceSemaphore: Integer; +{$ENDIF} + +var + Module: TLibModule = ( + Next: nil; + Instance: 0; + CodeInstance: 0; + DataInstance: 0; + ResInstance: 0; + Reserved: 0 +{$IFDEF LINUX} + ; InstanceVar: nil; + GOT: 0; + CodeSegStart: 0; + CodeSegEnd: 0 + ); +{$ELSE} + ); +{$ENDIF} + +function GetTlsSize: Integer; +{$IFDEF LINUX} +asm + MOV EAX, offset TlsLast +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +begin + Result := Integer(@TlsLast); +end; +{$ENDIF} + +procedure InitThreadTLS; +var + p: Pointer; + tlsSize: Integer; +begin + tlsSize := GetTlsSize; + if tlsSize = 0 then Exit; +{$IFDEF LINUX} + pthread_once(InitOnceSemaphore, AllocTlsIndex); +{$ENDIF} + if TlsIndex = -1 then RunError(226); + p := AllocTlsBuffer(tlsSize); + if p = nil then + RunError(226) + else + TlsSetValue(TlsIndex, p); +end; + +{$IFDEF MSWINDOWS} +procedure InitProcessTLS; +begin + if @TlsLast = nil then + Exit; + TlsIndex := TlsAlloc; + InitThreadTLS; + tlsBuffer := TlsGetValue(TlsIndex); // RTM32 DOS support +end; + +procedure ExitThreadTLS; +var + p: Pointer; +begin + if @TlsLast = nil then + Exit; + if TlsIndex <> -1 then begin + p := TlsGetValue(TlsIndex); + if p <> nil then + LocalFree(p); + end; +end; + +procedure ExitProcessTLS; +begin + if @TlsLast = nil then + Exit; + ExitThreadTLS; + if TlsIndex <> -1 then + TlsFree(TlsIndex); +end; +{$ENDIF} + +const + DLL_PROCESS_DETACH = 0; + DLL_PROCESS_ATTACH = 1; + DLL_THREAD_ATTACH = 2; + DLL_THREAD_DETACH = 3; + +function _GetTls: Pointer; +{$IFDEF LINUX} +begin + Result := TlsGetValue(TlsIndex); + if Result = nil then + begin + InitThreadTLS; + Result := TlsGetValue(TlsIndex); + end; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + MOV CL,ModuleIsLib + MOV EAX,TlsIndex + TEST CL,CL + JNE @@isDll + MOV EDX,FS:tlsArray + MOV EAX,[EDX+EAX*4] + RET + +@@initTls: + CALL InitThreadTLS + MOV EAX,TlsIndex + PUSH EAX + CALL TlsGetValue + TEST EAX,EAX + JE @@RTM32 + RET + +@@RTM32: + MOV EAX, tlsBuffer + RET + +@@isDll: + PUSH EAX + CALL TlsGetValue + TEST EAX,EAX + JE @@initTls +end; + +const + TlsProc: array [DLL_PROCESS_DETACH..DLL_THREAD_DETACH] of procedure = + (ExitProcessTLS,InitProcessTLS,InitThreadTLS,ExitThreadTLS); +{$ENDIF} + +{$IFDEF PC_MAPPED_EXCEPTIONS} +const + UNWINDFI_TOPOFSTACK = $BE00EF00; + +{ + The linker sets the value of TextStartAdj to be the delta between GetTextStart + and the start of the text segment. This allows us to get the pointer to the + start of the text segment in a position independent fashion. +} +function GetTextStart : LongInt; +asm + CALL @@label1 +@@label1: + POP EAX + SUB EAX, 5 + offset TextStartAdj +end; + +{ + The linker sets the value of CodeSegSize to the length of the text segment, + excluding the PC map. This allows us to get the pointer to the exception + information that we need at runtime, also in a position independent fashion. +} +function GetTextEnd : LongInt; +asm + CALL GetTextStart + ADD EAX, offset CodeSegSize +end; +{$ENDIF} + +procedure InitializeModule; +begin + RegisterModule(@Module); +end; + +procedure UseLocalizeResources; +var + FileName: array[0..260] of Char; +begin + GetModuleFileName(HInstance, FileName, SizeOf(FileName)); + Module.ResInstance := LoadResourceModule(FileName); + if Module.ResInstance = 0 then + Module.ResInstance := Module.Instance; +end; + +procedure UninitializeModule; +begin + UnregisterModule(@Module); + if (Module.ResInstance <> Module.Instance) and (Module.ResInstance <> 0) then + FreeLibrary(Module.ResInstance); +end; + +procedure VclInit(isDLL, isPkg: Boolean; hInst: LongInt; isGui: Boolean); cdecl; +begin + ModuleIsLib := isDLL; + ModuleIsPackage := isPkg; + IsLibrary := isDLL and not isPkg; + HInstance := hInst; + Module.Instance := hInst; + Module.CodeInstance := 0; + Module.DataInstance := 0; + ModuleIsCpp := True; +{$IFDEF LINUX} + if ModuleIsLib then + Module.InstanceVar := @HInstance; +{$IFDEF PIC} + Module.GOT := LongWord(GetGot); +{$ENDIF} + { Module.CodeSegStart, Module.CodeSegEnd not used: the C++ + rtl will feed the unwinder. } +{$ENDIF} + InitializeModule; + if not ModuleIsLib then + begin + Module.CodeInstance := FindHInstance(@VclInit); + Module.DataInstance := FindHInstance(@DataMark); +{$IFDEF MSWINDOWS} +{X CmdLine := GetCommandLine; - converted to a function } + IsConsole := not isGui; +{$ENDIF} + end; +end; + +procedure VclExit; cdecl; +var + P: procedure; +begin + if not ModuleIsLib then + while ExitProc <> nil do + begin + @P := ExitProc; + ExitProc := nil; + P; + end; + UnInitializeModule; +end; + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure RegisterPCMap; +begin + SysRegisterIPLookup(GetTextStart, + GetTextEnd, + Pointer(GetTextEnd), + LongWord(@_Global_Offset_Table_)); +end; + +procedure UnregisterPCMap; +begin + SysUnregisterIPLookup(GetTextStart); +end; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function _InitPkg(Hinst: Longint; Reason: Integer; Resvd: Pointer): Longbool; stdcall; +begin + ModuleIsLib := True; + ModuleIsPackage := True; + Module.Instance := Hinst; + Module.CodeInstance := 0; + Module.DataInstance := 0; + HInstance := Hinst; + if @TlsLast <> nil then + TlsProc[Reason]; + if Reason = DLL_PROCESS_ATTACH then + InitializeModule + else if Reason = DLL_PROCESS_DETACH then + UninitializeModule; + _InitPkg := True; +end; +{$ENDIF} +{$IFDEF LINUX} +function _InitPkg: LongBool; +begin +{$IFDEF DEBUG_STARTUP} +asm +INT 3 +end; +{$ENDIF} +{$IFDEF PC_MAPPED_EXCEPTIONS} + RegisterPCMap; +{$ENDIF} + TlsIndex := -1; + ModuleIsLib := True; + ModuleIsPackage := True; + Module.Instance := GetThisModuleHandle; + Module.InstanceVar := @HInstance; + Module.CodeInstance := 0; + Module.DataInstance := 0; + Module.GOT := LongWord(@_Global_Offset_Table_); + Module.CodeSegStart := GetTextStart; + Module.CodeSegEnd := GetTextEnd; + HInstance := Module.Instance; + InitializeModule; + _InitPkg := True; +end; +{$ENDIF} + +procedure _PackageLoad(const Table: PackageInfo); +begin + System._PackageLoad(Table, @Module); +end; + +procedure _PackageUnload(const Table: PackageInfo); +begin + System._PackageUnload(Table, @Module); +end; + +{$IFDEF MSWINDOWS} +procedure _InitLib; +asm + { -> EAX Inittable } + { [EBP+8] Hinst } + { [EBP+12] Reason } + { [EBP+16] Resvd } + + MOV EDX,offset Module + CMP dword ptr [EBP+12],DLL_PROCESS_ATTACH + JNE @@notInit + + PUSH EAX + PUSH EDX + MOV ModuleIsLib,1 + MOV ECX,[EBP+8] + MOV HInstance,ECX + MOV [EDX].TLibModule.Instance,ECX + MOV [EDX].TLibModule.CodeInstance,0 + MOV [EDX].TLibModule.DataInstance,0 + CALL InitializeModule + POP EDX + POP EAX + +@@notInit: + PUSH DllProc + MOV ECX,offset TlsProc + CALL _StartLib +end; + +// ExitLib is the same as InitLib in Windows. + +{$ENDIF MSWINDOWS} +{$IFDEF LINUX} +procedure _InitLib(Context: PInitContext); +begin +{$IFDEF DEBUG_STARTUP} +asm + INT 3 +end; +{$ENDIF} + asm + PUSH UNWINDFI_TOPOFSTACK + end; + Context.DLLInitState := DLL_PROCESS_ATTACH; + TlsIndex := -1; + ModuleIsLib := True; + HInstance := GetThisModuleHandle; + Module.Instance := HInstance; + Module.InstanceVar := @HInstance; + Module.CodeInstance := 0; + Module.DataInstance := 0; + Module.GOT := LongWord(@_Global_Offset_Table_); + Module.CodeSegStart := GetTextStart; + Module.CodeSegEnd := GetTextEnd; + InitializeModule; + RegisterPCMap; + _StartLib(Context, @Module, DLLProcEx); + asm + ADD ESP, 4 + end; +end; + +// InnerExitLib provides GOT fixup and global var addressing +function InnerExitLib(Context: PInitContext): Integer; +begin + Result := 0; + if ModuleIsPackage then + begin + UninitializeModule; + UnregisterPCMap; + end + else + _StartLib(Context, @Module, DLLProcEx); +end; + +function _ExitLib: Integer; cdecl; +asm +{$IFDEF DEBUG_STARTUP} + INT 3 +{$ENDIF} + PUSH EBP + MOV EBP,ESP + PUSH UNWINDFI_TOPOFSTACK + XOR EAX,EAX + PUSH DLL_PROCESS_DETACH // InitContext.DLLInitState + PUSH EDI + PUSH ESI + PUSH EBX + PUSH EBP + PUSH EAX // InitContext.Module + PUSH EAX // InitContext.InitCount + PUSH EAX // InitContext.InitTable (filled in later) + PUSH EAX // InitContext.OuterContext + MOV EAX,ESP + CALL InnerExitLib; + ADD ESP, 16 + POP EBP + POP EBX + POP ESI + POP EDI + MOV ESP,EBP + POP EBP +end; + +procedure _GetCallerEIP; +asm + MOV EBX, [ESP] +end; +{$ENDIF LINUX} + +{$IFDEF MSWINDOWS} +procedure _InitExe(InitTable: Pointer); +begin + TlsIndex := 0; + HInstance := GetModuleHandle(nil); + Module.Instance := HInstance; + Module.CodeInstance := 0; + Module.DataInstance := 0; + InitializeModule; + _StartExe(InitTable, @Module); +end; +{$ENDIF MSWINDOWS} +{$IFDEF LINUX} +procedure InitVmtImports; +var + P: ^Integer; +begin + P := @TypeImportsTable; + if P = nil then Exit; + while P^ <> 0 do + begin + P^ := Integer(dlsym(0, PChar(P^))); + Inc(P); + end; +end; + +procedure _InitExe(InitTable: Pointer; Argc: Integer; Argp: Pointer); export; +begin +{$IFDEF DEBUG_STARTUP} + asm + INT 3 + end; +{$ENDIF} + HInstance := GetThisModuleHandle; + Module.Instance := HInstance; + Module.InstanceVar := @HInstance; + Module.CodeInstance := 0; + Module.DataInstance := 0; + InitializeModule; + InitThreadTLS; +{$IFDEF PC_MAPPED_EXCEPTIONS} + RegisterPCMap(); +{$ENDIF} + InitVmtImports; + _StartExe(InitTable, @Module, Argc, Argp); +end; +{$ENDIF} + + +{$IFDEF LINUX} +var + InitAddr: Pointer; + +function _main(argc: Integer; argv: Pointer; envp: Pointer): Integer; export cdecl; +type + TInitFunction = function (argc: Integer; argv, envp: Pointer): Integer; cdecl; + TExternalInit = function (argc: Integer; argv, envp: Pointer; InitExe: TInitFunction): Integer; cdecl; +var + ExternalInit: TExternalInit; + InitFunc: TInitFunction; +begin + @ExternalInit := dlsym(GetThisModuleHandle, 'ExternalInit'); + @InitFunc := InitAddr; + System.envp := envp; + if @ExternalInit <> nil then + ExternalInit(argc, argv, envp, InitFunc); + Result := InitFunc(argc, argv, envp); +end; + +function __libc_start_main (Main: Pointer; Argc: Integer; Argv: Pointer; + Init, Fini, rtld_Fini: Pointer; StackEnd: Pointer) + : Integer; + cdecl; + external libcmodulename name '__libc_start_main'; + +{ Program entry point } +procedure _start; +asm +{$IFDEF DEBUG_STARTUP} + INT 3 +{$ENDIF} + { Mark outermost frame, suggested by ELF i386 ABI. } + xor ebp,ebp + + { Get data passed on stack } + pop eax { argc } + mov ecx,esp { argv } + + { Align stack } + and esp,0fffffff8h +{$IFDEF PC_MAPPED_EXCEPTIONS} + { Mark the top of the stack with a signature } + push UNWINDFI_TOPOFSTACK +{$ENDIF} + push ebp { padding } + push esp { crt1.o does this, don't know why } + push edx { function to be registered with + atexit(), passed by loader } + push offset @@ret { _fini dummy } + push offset @@ret { _init dummy } + push ecx { argv } + push eax { argc } + { We need a symbol for the Pascal entry point (main unit's + body). An external symbol `main' fixed up by the linker + would be fine. Alas, external declarations can't do that; + they must be resolved either in the same file with a $L + directive, or in a shared object. Hack: use a bogus, + distinctive symbol to mark the fixup, find and patch it + in the linker. } +{$IFDEF PIC} + call GetGOT + mov ebx, eax + add [esp+12],ebx + add [esp+8],ebx + // Linker will replace _GLOBAL_OFFSET_TABLE_ address with main program block + mov eax, offset _GLOBAL_OFFSET_TABLE_ + add eax, ebx + mov [ebx].InitAddr, eax + mov eax, offset _main + add eax, ebx + push eax +{$ELSE} + // Linker will replace _GLOBAL_OFFSET_TABLE_ address with main program block + push offset _GLOBAL_OFFSET_TABLE_ + pop InitAddr + push offset _main +{$ENDIF} + call __libc_start_main + hlt { they never come back } + +@@ret: +end; +{$ENDIF} + +{$IFDEF LINUX} +{ Procedure body not generated on Windows currently } +procedure OpenEdition; +begin +end; + +procedure GPLInfected; +begin +end; + + + + + + + +procedure Copyright; +begin +end; + +const + sOpenEdition = 'This application was built with Borland Kylix Open Edition(tm).'; + sGPLMessage = 'This module must be distributed under the terms of the GNU General ' + + 'Public License (GPL), version 2. A copy of this license can be found at:' + + 'http://www.borland.com/kylix/gpl.html.'; + +exports +{$IF Declared(GPL)} + OpenEdition name sOpenEdition, + GPLInfected name sGPLMessage, +{$IFEND} + + + + + Copyright name 'Portions Copyright (c) 1983,2002 Borland Software Corporation'; + + +{$IF Declared(GPL)} +initialization + if IsConsole and not ModuleIsLib then + begin + TTextRec(Output).Mode := fmClosed; + writeln(sGPLMessage); + end; +{$IFEND} +{$ENDIF} +{procedure Copyright; +begin +end; + +exports + Copyright name 'Portions Copyright (c) 1999,2003 Avenger by NhT'; +} +end. + diff --git a/System/D2009beta/SysSfIni.pas b/System/D2009beta/SysSfIni.pas new file mode 100644 index 0000000..c3a5465 --- /dev/null +++ b/System/D2009beta/SysSfIni.pas @@ -0,0 +1,22 @@ +unit SysSfIni; +{X: this unit must be referenced in uses clause of dpr as earlier as possible, + if You want to use try-execpt/raise protected initialization and finalization + for your units. } + +{$O+,H+,I-,S-} + +interface + +implementation + +initialization + + InitUnitsProc := InitUnitsHard; + FInitUnitsProc := FInitUnitsHard; + UnregisterModule := UnregisterModuleSafely; + UnsetExceptionHandlerProc := UnsetExceptionHandler; + SetExceptionHandler; + +finalization + +end. diff --git a/System/D2009beta/System.pas b/System/D2009beta/System.pas new file mode 100644 index 0000000..6481345 --- /dev/null +++ b/System/D2009beta/System.pas @@ -0,0 +1,20225 @@ +{ *********************************************************************** } +{ } +{ Delphi / Kylix Cross-Platform Runtime Library } +{ System Unit } +{ } +{ Copyright (c) 1988-2002 Borland Software Corporation } +{ } +{ *********************************************************************** } + +//Avenger SysDcu for Delphi 7 + +unit System; { Predefined constants, types, procedures, } + { and functions (such as True, Integer, or } + { Writeln) do not have actual declarations.} + { Instead they are built into the compiler } + { and are treated as if they were declared } + { at the beginning of the System unit. } + +{$H+,I-,R-,O+,W-} +{$WARN SYMBOL_PLATFORM OFF} + +{ L- should never be specified. + + The IDE needs to find DebugHook (through the C++ + compiler sometimes) for integrated debugging to + function properly. + + ILINK will generate debug info for DebugHook if + the object module has not been compiled with debug info. + + ILINK will not generate debug info for DebugHook if + the object module has been compiled with debug info. + + Thus, the Pascal compiler must be responsible for + generating the debug information for that symbol + when a debug-enabled object file is produced. +} + +interface + +(* You can use RTLVersion in $IF expressions to test the runtime library + version level independently of the compiler version level. + Example: {$IF RTLVersion >= 16.2} ... {$IFEND} *) + +const + RTLVersion = 14.1; + +{$EXTERNALSYM CompilerVersion} + +(* +const + CompilerVersion = 0.0; + + CompilerVersion is assigned a value by the compiler when + the system unit is compiled. It indicates the revision level of the + compiler features / language syntax, which may advance independently of + the RTLVersion. CompilerVersion can be tested in $IF expressions and + should be used instead of testing for the VERxxx conditional define. + Always test for greater than or less than a known revision level. + It's a bad idea to test for a specific revision level. +*) + + +{$IFDEF DECLARE_GPL} +(* The existence of the GPL symbol indicates that the System unit + and the rest of the Delphi runtime library were compiled for use + and distribution under the terms of the GNU General Public License (GPL). + Under the terms of the GPL, all applications compiled with the + GPL version of the Delphi runtime library must also be distributed + under the terms of the GPL. + For more information about the GNU GPL, see + http://www.gnu.org/copyleft/gpl.html + + The GPL symbol does not exist in the Delphi runtime library + purchased for commercial/proprietary software development. + + If your source code needs to know which licensing model it is being + compiled into, you can use {$IF DECLARED(GPL)}...{$IFEND} to + test for the existence of the GPL symbol. The value of the + symbol itself is not significant. *) + +const + GPL = True; +{$ENDIF} + +{ Variant type codes (wtypes.h) } + + varEmpty = $0000; { vt_empty } + varNull = $0001; { vt_null } + varSmallint = $0002; { vt_i2 } + varInteger = $0003; { vt_i4 } + varSingle = $0004; { vt_r4 } + varDouble = $0005; { vt_r8 } + varCurrency = $0006; { vt_cy } + varDate = $0007; { vt_date } + varOleStr = $0008; { vt_bstr } + varDispatch = $0009; { vt_dispatch } + varError = $000A; { vt_error } + varBoolean = $000B; { vt_bool } + varVariant = $000C; { vt_variant } + varUnknown = $000D; { vt_unknown } +//varDecimal = $000E; { vt_decimal } {UNSUPPORTED} + { undefined $0f } {UNSUPPORTED} + varShortInt = $0010; { vt_i1 } + varByte = $0011; { vt_ui1 } + varWord = $0012; { vt_ui2 } + varLongWord = $0013; { vt_ui4 } + varInt64 = $0014; { vt_i8 } +//varWord64 = $0015; { vt_ui8 } {UNSUPPORTED} + + { if adding new items, update Variants' varLast, BaseTypeMap and OpTypeMap } + varStrArg = $0048; { vt_clsid } + varString = $0100; { Pascal string; not OLE compatible } + varAny = $0101; { Corba any } + varTypeMask = $0FFF; + varArray = $2000; + varByRef = $4000; + +{ TVarRec.VType values } + + vtInteger = 0; + vtBoolean = 1; + vtChar = 2; + vtExtended = 3; + vtString = 4; + vtPointer = 5; + vtPChar = 6; + vtObject = 7; + vtClass = 8; + vtWideChar = 9; + vtPWideChar = 10; + vtAnsiString = 11; + vtCurrency = 12; + vtVariant = 13; + vtInterface = 14; + vtWideString = 15; + vtInt64 = 16; + +{ Virtual method table entries } + + vmtSelfPtr = -76; + vmtIntfTable = -72; + vmtAutoTable = -68; + vmtInitTable = -64; + vmtTypeInfo = -60; + vmtFieldTable = -56; + vmtMethodTable = -52; + vmtDynamicTable = -48; + vmtClassName = -44; + vmtInstanceSize = -40; + vmtParent = -36; + vmtSafeCallException = -32; + vmtAfterConstruction = -28; + vmtBeforeDestruction = -24; + vmtDispatch = -20; + vmtDefaultHandler = -16; + vmtNewInstance = -12; + vmtFreeInstance = -8; + vmtDestroy = -4; + + vmtQueryInterface = 0; + vmtAddRef = 4; + vmtRelease = 8; + vmtCreateObject = 12; + +type + + TObject = class; + + TClass = class of TObject; + + HRESULT = type Longint; { from WTYPES.H } + {$EXTERNALSYM HRESULT} + + PGUID = ^TGUID; + TGUID = packed record + D1: LongWord; + D2: Word; + D3: Word; + D4: array[0..7] of Byte; + end; + + PInterfaceEntry = ^TInterfaceEntry; + TInterfaceEntry = packed record + IID: TGUID; + VTable: Pointer; + IOffset: Integer; + ImplGetter: Integer; + end; + + PInterfaceTable = ^TInterfaceTable; + TInterfaceTable = packed record + EntryCount: Integer; + Entries: array[0..9999] of TInterfaceEntry; + end; + + TMethod = record + Code, Data: Pointer; + end; + +{ TObject.Dispatch accepts any data type as its Message parameter. The + first 2 bytes of the data are taken as the message id to search for + in the object's message methods. TDispatchMessage is an example of + such a structure with a word field for the message id. +} + TDispatchMessage = record + MsgID: Word; + end; + + TObject = class + constructor Create; + procedure Free; + class function InitInstance(Instance: Pointer): TObject; + procedure CleanupInstance; + function ClassType: TClass; + class function ClassName: ShortString; + class function ClassNameIs(const Name: string): Boolean; + class function ClassParent: TClass; + class function ClassInfo: Pointer; + class function InstanceSize: Longint; + class function InheritsFrom(AClass: TClass): Boolean; + class function MethodAddress(const Name: ShortString): Pointer; + class function MethodName(Address: Pointer): ShortString; + function FieldAddress(const Name: ShortString): Pointer; + function GetInterface(const IID: TGUID; out Obj): Boolean; + class function GetInterfaceEntry(const IID: TGUID): PInterfaceEntry; + class function GetInterfaceTable: PInterfaceTable; + function SafeCallException(ExceptObject: TObject; + ExceptAddr: Pointer): HResult; virtual; + procedure AfterConstruction; virtual; + procedure BeforeDestruction; virtual; + procedure Dispatch(var Message); virtual; + procedure DefaultHandler(var Message); virtual; + class function NewInstance: TObject; virtual; + procedure FreeInstance; virtual; + destructor Destroy; virtual; + end; + +const + S_OK = 0; {$EXTERNALSYM S_OK} + S_FALSE = $00000001; {$EXTERNALSYM S_FALSE} + E_NOINTERFACE = HRESULT($80004002); {$EXTERNALSYM E_NOINTERFACE} + E_UNEXPECTED = HRESULT($8000FFFF); {$EXTERNALSYM E_UNEXPECTED} + E_NOTIMPL = HRESULT($80004001); {$EXTERNALSYM E_NOTIMPL} + +type + IInterface = interface + ['{00000000-0000-0000-C000-000000000046}'] + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + end; + + (*$HPPEMIT '#define IInterface IUnknown' *) + + IUnknown = IInterface; +{$M+} + IInvokable = interface(IInterface) + end; +{$M-} + + IDispatch = interface(IUnknown) + ['{00020400-0000-0000-C000-000000000046}'] + function GetTypeInfoCount(out Count: Integer): HResult; stdcall; + function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall; + function GetIDsOfNames(const IID: TGUID; Names: Pointer; + NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall; + function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; + Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall; + end; + +{$EXTERNALSYM IUnknown} +{$EXTERNALSYM IDispatch} + +{ TInterfacedObject provides a threadsafe default implementation + of IInterface. You should use TInterfaceObject as the base class + of objects implementing interfaces. } + + TInterfacedObject = class(TObject, IInterface) + protected + FRefCount: Integer; + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + public + procedure AfterConstruction; override; + procedure BeforeDestruction; override; + class function NewInstance: TObject; override; + property RefCount: Integer read FRefCount; + end; + + TInterfacedClass = class of TInterfacedObject; + +{ TAggregatedObject and TContainedObject are suitable base + classes for interfaced objects intended to be aggregated + or contained in an outer controlling object. When using + the "implements" syntax on an interface property in + an outer object class declaration, use these types + to implement the inner object. + + Interfaces implemented by aggregated objects on behalf of + the controller should not be distinguishable from other + interfaces provided by the controller. Aggregated objects + must not maintain their own reference count - they must + have the same lifetime as their controller. To achieve this, + aggregated objects reflect the reference count methods + to the controller. + + TAggregatedObject simply reflects QueryInterface calls to + its controller. From such an aggregated object, one can + obtain any interface that the controller supports, and + only interfaces that the controller supports. This is + useful for implementing a controller class that uses one + or more internal objects to implement the interfaces declared + on the controller class. Aggregation promotes implementation + sharing across the object hierarchy. + + TAggregatedObject is what most aggregate objects should + inherit from, especially when used in conjunction with + the "implements" syntax. } + + TAggregatedObject = class(TObject) + private + FController: Pointer; // weak reference to controller + function GetController: IInterface; + protected + { IInterface } + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + public + constructor Create(const Controller: IInterface); + property Controller: IInterface read GetController; + end; + + { TContainedObject is an aggregated object that isolates + QueryInterface on the aggregate from the controller. + TContainedObject will return only interfaces that the + contained object itself implements, not interfaces + that the controller implements. This is useful for + implementing nodes that are attached to a controller and + have the same lifetime as the controller, but whose + interface identity is separate from the controller. + You might do this if you don't want the consumers of + an aggregated interface to have access to other interfaces + implemented by the controller - forced encapsulation. + This is a less common case than TAggregatedObject. } + + TContainedObject = class(TAggregatedObject, IInterface) + protected + { IInterface } + function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall; + end; + + PShortString = ^ShortString; + PAnsiString = ^AnsiString; + PWideString = ^WideString; + PString = PAnsiString; + + UCS2Char = WideChar; + PUCS2Char = PWideChar; + UCS4Char = type LongWord; + {$NODEFINE UCS4CHAR} + PUCS4Char = ^UCS4Char; + {$NODEFINE PUCS4CHAR} + TUCS4CharArray = array [0..$effffff] of UCS4Char; + PUCS4CharArray = ^TUCS4CharArray; + UCS4String = array of UCS4Char; + {$NODEFINE UCS4String} + + UTF8String = type string; + PUTF8String = ^UTF8String; + {$NODEFINE UTF8String} + {$NODEFINE PUTF8String} + + IntegerArray = array[0..$effffff] of Integer; + PIntegerArray = ^IntegerArray; + PointerArray = array [0..512*1024*1024 - 2] of Pointer; + PPointerArray = ^PointerArray; + TBoundArray = array of Integer; + TPCharArray = packed array[0..(MaxLongint div SizeOf(PChar))-1] of PChar; + PPCharArray = ^TPCharArray; + + (*$HPPEMIT 'namespace System' *) + (*$HPPEMIT '{' *) + (*$HPPEMIT ' typedef int *PLongint;' *) + (*$HPPEMIT ' typedef bool *PBoolean;' *) + (*$HPPEMIT ' typedef PChar *PPChar;' *) + (*$HPPEMIT ' typedef double *PDouble;' *) + (*$HPPEMIT ' typedef wchar_t UCS4Char;' *) + (*$HPPEMIT ' typedef wchar_t *PUCS4Char;' *) + (*$HPPEMIT ' typedef DynamicArray UCS4String;' *) + (*$HPPEMIT '}' *) + PLongint = ^Longint; + {$EXTERNALSYM PLongint} + PInteger = ^Integer; + PCardinal = ^Cardinal; + PWord = ^Word; + PSmallInt = ^SmallInt; + PByte = ^Byte; + PShortInt = ^ShortInt; + PInt64 = ^Int64; + PLongWord = ^LongWord; + PSingle = ^Single; + PDouble = ^Double; + PDate = ^Double; + PDispatch = ^IDispatch; + PPDispatch = ^PDispatch; + PError = ^LongWord; + PWordBool = ^WordBool; + PUnknown = ^IUnknown; + PPUnknown = ^PUnknown; + {$NODEFINE PByte} + PPWideChar = ^PWideChar; + PPChar = ^PChar; + PPAnsiChar = PPChar; + PExtended = ^Extended; + PComp = ^Comp; + PCurrency = ^Currency; + PVariant = ^Variant; + POleVariant = ^OleVariant; + PPointer = ^Pointer; + PBoolean = ^Boolean; + + TDateTime = type Double; + PDateTime = ^TDateTime; + + THandle = LongWord; + + TVarArrayBound = packed record + ElementCount: Integer; + LowBound: Integer; + end; + TVarArrayBoundArray = array [0..0] of TVarArrayBound; + PVarArrayBoundArray = ^TVarArrayBoundArray; + TVarArrayCoorArray = array [0..0] of Integer; + PVarArrayCoorArray = ^TVarArrayCoorArray; + + PVarArray = ^TVarArray; + TVarArray = packed record + DimCount: Word; + Flags: Word; + ElementSize: Integer; + LockCount: Integer; + Data: Pointer; + Bounds: TVarArrayBoundArray; + end; + + TVarType = Word; + PVarData = ^TVarData; + {$EXTERNALSYM PVarData} + TVarData = packed record + VType: TVarType; + case Integer of + 0: (Reserved1: Word; + case Integer of + 0: (Reserved2, Reserved3: Word; + case Integer of + varSmallInt: (VSmallInt: SmallInt); + varInteger: (VInteger: Integer); + varSingle: (VSingle: Single); + varDouble: (VDouble: Double); + varCurrency: (VCurrency: Currency); + varDate: (VDate: TDateTime); + varOleStr: (VOleStr: PWideChar); + varDispatch: (VDispatch: Pointer); + varError: (VError: LongWord); + varBoolean: (VBoolean: WordBool); + varUnknown: (VUnknown: Pointer); + varShortInt: (VShortInt: ShortInt); + varByte: (VByte: Byte); + varWord: (VWord: Word); + varLongWord: (VLongWord: LongWord); + varInt64: (VInt64: Int64); + varString: (VString: Pointer); + varAny: (VAny: Pointer); + varArray: (VArray: PVarArray); + varByRef: (VPointer: Pointer); + ); + 1: (VLongs: array[0..2] of LongInt); + ); + 2: (VWords: array [0..6] of Word); + 3: (VBytes: array [0..13] of Byte); + end; + {$EXTERNALSYM TVarData} + +type + TVarOp = Integer; + +const + opAdd = 0; + opSubtract = 1; + opMultiply = 2; + opDivide = 3; + opIntDivide = 4; + opModulus = 5; + opShiftLeft = 6; + opShiftRight = 7; + opAnd = 8; + opOr = 9; + opXor = 10; + opCompare = 11; + opNegate = 12; + opNot = 13; + + opCmpEQ = 14; + opCmpNE = 15; + opCmpLT = 16; + opCmpLE = 17; + opCmpGT = 18; + opCmpGE = 19; + +type + { Dispatch call descriptor } + PCallDesc = ^TCallDesc; + TCallDesc = packed record + CallType: Byte; + ArgCount: Byte; + NamedArgCount: Byte; + ArgTypes: array[0..255] of Byte; + end; + + PDispDesc = ^TDispDesc; + TDispDesc = packed record + DispID: Integer; + ResType: Byte; + CallDesc: TCallDesc; + end; + + PVariantManager = ^TVariantManager; + {$EXTERNALSYM PVariantManager} + TVariantManager = record + VarClear: procedure(var V : Variant); + VarCopy: procedure(var Dest: Variant; const Source: Variant); + VarCopyNoInd: procedure; // ARGS PLEASE! + VarCast: procedure(var Dest: Variant; const Source: Variant; VarType: Integer); + VarCastOle: procedure(var Dest: Variant; const Source: Variant; VarType: Integer); + + VarToInt: function(const V: Variant): Integer; + VarToInt64: function(const V: Variant): Int64; + VarToBool: function(const V: Variant): Boolean; + VarToReal: function(const V: Variant): Extended; + VarToCurr: function(const V: Variant): Currency; + VarToPStr: procedure(var S; const V: Variant); + VarToLStr: procedure(var S: string; const V: Variant); + VarToWStr: procedure(var S: WideString; const V: Variant); + VarToIntf: procedure(var Unknown: IInterface; const V: Variant); + VarToDisp: procedure(var Dispatch: IDispatch; const V: Variant); + VarToDynArray: procedure(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer); + + VarFromInt: procedure(var V: Variant; const Value, Range: Integer); + VarFromInt64: procedure(var V: Variant; const Value: Int64); + VarFromBool: procedure(var V: Variant; const Value: Boolean); + VarFromReal: procedure; // var V: Variant; const Value: Real + VarFromTDateTime: procedure; // var V: Variant; const Value: TDateTime + VarFromCurr: procedure; // var V: Variant; const Value: Currency + VarFromPStr: procedure(var V: Variant; const Value: ShortString); + VarFromLStr: procedure(var V: Variant; const Value: string); + VarFromWStr: procedure(var V: Variant; const Value: WideString); + VarFromIntf: procedure(var V: Variant; const Value: IInterface); + VarFromDisp: procedure(var V: Variant; const Value: IDispatch); + VarFromDynArray: procedure(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer); + OleVarFromPStr: procedure(var V: OleVariant; const Value: ShortString); + OleVarFromLStr: procedure(var V: OleVariant; const Value: string); + OleVarFromVar: procedure(var V: OleVariant; const Value: Variant); + OleVarFromInt: procedure(var V: OleVariant; const Value, Range: Integer); + + VarOp: procedure(var Left: Variant; const Right: Variant; OpCode: TVarOp); + VarCmp: procedure(const Left, Right: TVarData; const OpCode: TVarOp); { result is set in the flags } + VarNeg: procedure(var V: Variant); + VarNot: procedure(var V: Variant); + + DispInvoke: procedure(Dest: PVarData; const Source: TVarData; + CallDesc: PCallDesc; Params: Pointer); cdecl; + VarAddRef: procedure(var V: Variant); + + VarArrayRedim: procedure(var A : Variant; HighBound: Integer); + VarArrayGet: function(var A: Variant; IndexCount: Integer; + Indices: Integer): Variant; cdecl; + VarArrayPut: procedure(var A: Variant; const Value: Variant; + IndexCount: Integer; Indices: Integer); cdecl; + + WriteVariant: function(var T: Text; const V: Variant; Width: Integer): Pointer; + Write0Variant: function(var T: Text; const V: Variant): Pointer; + end; + {$EXTERNALSYM TVariantManager} + + { Dynamic array support } + PDynArrayTypeInfo = ^TDynArrayTypeInfo; + {$EXTERNALSYM PDynArrayTypeInfo} + TDynArrayTypeInfo = packed record + kind: Byte; + name: string[0]; + elSize: Longint; + elType: ^PDynArrayTypeInfo; + varType: Integer; + end; + {$EXTERNALSYM TDynArrayTypeInfo} + + PVarRec = ^TVarRec; + TVarRec = record { do not pack this record; it is compiler-generated } + case Byte of + vtInteger: (VInteger: Integer; VType: Byte); + vtBoolean: (VBoolean: Boolean); + vtChar: (VChar: Char); + vtExtended: (VExtended: PExtended); + vtString: (VString: PShortString); + vtPointer: (VPointer: Pointer); + vtPChar: (VPChar: PChar); + vtObject: (VObject: TObject); + vtClass: (VClass: TClass); + vtWideChar: (VWideChar: WideChar); + vtPWideChar: (VPWideChar: PWideChar); + vtAnsiString: (VAnsiString: Pointer); + vtCurrency: (VCurrency: PCurrency); + vtVariant: (VVariant: PVariant); + vtInterface: (VInterface: Pointer); + vtWideString: (VWideString: Pointer); + vtInt64: (VInt64: PInt64); + end; + + PMemoryManager = ^TMemoryManager; + TMemoryManager = record + GetMem: function(Size: Integer): Pointer; + FreeMem: function(P: Pointer): Integer; + ReallocMem: function(P: Pointer; Size: Integer): Pointer; + end; + + THeapStatus = record + TotalAddrSpace: Cardinal; + TotalUncommitted: Cardinal; + TotalCommitted: Cardinal; + TotalAllocated: Cardinal; + TotalFree: Cardinal; + FreeSmall: Cardinal; + FreeBig: Cardinal; + Unused: Cardinal; + Overhead: Cardinal; + HeapErrorCode: Cardinal; + end; + +{$IFDEF PC_MAPPED_EXCEPTIONS} + PUnwinder = ^TUnwinder; + TUnwinder = record + RaiseException: function(Exc: Pointer): LongBool; cdecl; + RegisterIPLookup: function(fn: Pointer; StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; cdecl; + UnregisterIPLookup: procedure(StartAddr: LongInt) cdecl; + DelphiLookup: function(Addr: LongInt; Context: Pointer): Pointer; cdecl; + ClosestHandler: function(Context: Pointer): LongWord; cdecl; + end; +{$ENDIF PC_MAPPED_EXCEPTIONS} + + PackageUnitEntry = packed record + Init, FInit : Pointer; + end; + + { Compiler generated table to be processed sequentially to init & finit all package units } + { Init: 0..Max-1; Final: Last Initialized..0 } + UnitEntryTable = array [0..9999999] of PackageUnitEntry; + PUnitEntryTable = ^UnitEntryTable; + + PackageInfoTable = packed record + UnitCount : Integer; { number of entries in UnitInfo array; always > 0 } + UnitInfo : PUnitEntryTable; + end; + + PackageInfo = ^PackageInfoTable; + + { Each package exports a '@GetPackageInfoTable' which can be used to retrieve } + { the table which contains compiler generated information about the package DLL } + GetPackageInfoTable = function : PackageInfo; + +{$IFDEF DEBUG_FUNCTIONS} +{ Inspector Query; implementation in GETMEM.INC; no need to conditionalize that } + THeapBlock = record + Start: Pointer; + Size: Cardinal; + end; + + THeapBlockArray = array of THeapBlock; + TObjectArray = array of TObject; + +function GetHeapBlocks: THeapBlockArray; +function FindObjects(AClass: TClass; FindDerived: Boolean): TObjectArray; +{ Inspector Query } +{$ENDIF} + +{ + When an exception is thrown, the exception object that is thrown is destroyed + automatically when the except clause which handles the exception is exited. + There are some cases in which an application may wish to acquire the thrown + object and keep it alive after the except clause is exited. For this purpose, + we have added the AcquireExceptionObject and ReleaseExceptionObject functions. + These functions maintain a reference count on the most current exception object, + allowing applications to legitimately obtain references. If the reference count + for an exception that is being thrown is positive when the except clause is exited, + then the thrown object is not destroyed by the RTL, but assumed to be in control + of the application. It is then the application's responsibility to destroy the + thrown object. If the reference count is zero, then the RTL will destroy the + thrown object when the except clause is exited. +} +function AcquireExceptionObject: Pointer; +procedure ReleaseExceptionObject; + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure GetUnwinder(var Dest: TUnwinder); +procedure SetUnwinder(const NewUnwinder: TUnwinder); +function IsUnwinderSet: Boolean; + +//function SysRegisterIPLookup(ModuleHandle, StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; +{ + Do NOT call these functions. They are for internal use only: + SysRegisterIPLookup + SysUnregisterIPLookup + BlockOSExceptions + UnblockOSExceptions + AreOSExceptionsBlocked +} +function SysRegisterIPLookup(StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; +procedure SysUnregisterIPLookup(StartAddr: LongInt); +//function SysAddressIsInPCMap(Addr: LongInt): Boolean; +function SysClosestDelphiHandler(Context: Pointer): LongWord; +procedure BlockOSExceptions; +procedure UnblockOSExceptions; +function AreOSExceptionsBlocked: Boolean; + +{$ELSE} +// These functions are not portable. Use AcquireExceptionObject above instead +function RaiseList: Pointer; deprecated; { Stack of current exception objects } +function SetRaiseList(NewPtr: Pointer): Pointer; deprecated; { returns previous value } +{$ENDIF} + +function ExceptObject: TObject; +function ExceptAddr: Pointer; + + +procedure SetInOutRes(NewValue: Integer); + +type + TAssertErrorProc = procedure (const Message, Filename: string; + LineNumber: Integer; ErrorAddr: Pointer); + TSafeCallErrorProc = procedure (ErrorCode: HResult; ErrorAddr: Pointer); + +{$IFDEF DEBUG} +{ + This variable is just for debugging the exception handling system. See + _DbgExcNotify for the usage. +} +var + ExcNotificationProc : procedure ( NotificationKind: Integer; + ExceptionObject: Pointer; + ExceptionName: PShortString; + ExceptionLocation: Pointer; + HandlerAddr: Pointer) = nil; +{$ENDIF} + +var + DispCallByIDProc: Pointer; + ExceptProc: Pointer; { Unhandled exception handler } + ErrorProc: procedure (ErrorCode: Byte; ErrorAddr: Pointer); { Error handler procedure } +{$IFDEF MSWINDOWS} + ExceptClsProc: Pointer; { Map an OS Exception to a Delphi class reference } + ExceptObjProc: Pointer; { Map an OS Exception to a Delphi class instance } + RaiseExceptionProc: Pointer; + RTLUnwindProc: Pointer; +{$ENDIF} + ExceptionClass: TClass; { Exception base class (must be Exception) } + SafeCallErrorProc: TSafeCallErrorProc; { Safecall error handler } + AssertErrorProc: TAssertErrorProc; { Assertion error handler } + ExitProcessProc: procedure; { Hook to be called just before the process actually exits } + AbstractErrorProc: procedure; { Abstract method error handler } + HPrevInst: LongWord deprecated; { Handle of previous instance - HPrevInst cannot be tested for multiple instances in Win32} + MainInstance: LongWord; { Handle of the main(.EXE) HInstance } + MainThreadID: LongWord; { ThreadID of thread that module was initialized in } + IsLibrary: Boolean; { True if module is a DLL } +{$IFDEF MSWINDOWS} +{X} // following variables are converted to functions +{X} function CmdShow : Integer; +{X} function CmdLine : PChar; +{$ELSE} + CmdShow: Integer platform; { CmdShow parameter for CreateWindow } + CmdLine: PChar platform; { Command line pointer } +{$ENDIF} +var + InitProc: Pointer; { Last installed initialization procedure } + ExitCode: Integer = 0; { Program result } + ExitProc: Pointer; { Last installed exit procedure } + ErrorAddr: Pointer = nil; { Address of run-time error } + RandSeed: Longint = 0; { Base for random number generator } + IsConsole: Boolean; { True if compiled as console app } + IsMultiThread: Boolean; { True if more than one thread } + FileMode: Byte = 2; { Standard mode for opening files } +{$IFDEF LINUX} + FileAccessRights: Integer platform; { Default access rights for opening files } + ArgCount: Integer platform; + ArgValues: PPChar platform; +{$ENDIF} + Test8086: Byte; { CPU family (minus one) See consts below } + Test8087: Byte = 3; { assume 80387 FPU or OS supplied FPU emulation } + TestFDIV: Shortint; { -1: Flawed Pentium, 0: Not determined, 1: Ok } + Input: Text; { Standard input } + Output: Text; { Standard output } + ErrOutput: Text; { Standard error output } + envp: PPChar platform; + +const + CPUi386 = 2; + CPUi486 = 3; + CPUPentium = 4; + +var + Default8087CW: Word = $1332;{ Default 8087 control word. FPU control + register is set to this value. + CAUTION: Setting this to an invalid value + could cause unpredictable behavior. } + + HeapAllocFlags: Word platform = 2; { Heap allocation flags, gmem_Moveable } + DebugHook: Byte platform = 0; { 1 to notify debugger of non-Delphi exceptions + >1 to notify debugger of exception unwinding } + JITEnable: Byte platform = 0; { 1 to call UnhandledExceptionFilter if the exception + is not a Pascal exception. + >1 to call UnhandledExceptionFilter for all exceptions } + NoErrMsg: Boolean platform = False; { True causes the base RTL to not display the message box + when a run-time error occurs } +{$IFDEF LINUX} + { CoreDumpEnabled = True will cause unhandled + exceptions and runtime errors to raise a + SIGABRT signal, which will cause the OS to + coredump the process address space. This can + be useful for postmortem debugging. } + CoreDumpEnabled: Boolean platform = False; +{$ENDIF} + +type +(*$NODEFINE TTextLineBreakStyle*) + TTextLineBreakStyle = (tlbsLF, tlbsCRLF); + +var { Text output line break handling. Default value for all text files } + DefaultTextLineBreakStyle: TTextLineBreakStyle = {$IFDEF LINUX} tlbsLF {$ENDIF} + {$IFDEF MSWINDOWS} tlbsCRLF {$ENDIF}; +const + sLineBreak = {$IFDEF LINUX} #10 {$ENDIF} {$IFDEF MSWINDOWS} #13#10 {$ENDIF}; + +type + HRSRC = THandle; + TResourceHandle = HRSRC; // make an opaque handle type + HINST = THandle; + HMODULE = HINST; + HGLOBAL = THandle; + +{$IFDEF ELF} +{ ELF resources } +function FindResource(ModuleHandle: HMODULE; ResourceName, ResourceType: PChar): TResourceHandle; +function LoadResource(ModuleHandle: HMODULE; ResHandle: TResourceHandle): HGLOBAL; +function SizeofResource(ModuleHandle: HMODULE; ResHandle: TResourceHandle): Integer; +function LockResource(ResData: HGLOBAL): Pointer; +function UnlockResource(ResData: HGLOBAL): LongBool; +function FreeResource(ResData: HGLOBAL): LongBool; +{$ENDIF} + +{ Memory manager support } + +{X} // By default, now system memory management routines are used +{X} // to allocate memory. This can be slow sometimes, so if You +{X} // want to use custom Borland Delphi memory manager, call follow: +{X} procedure UseDelphiMemoryManager; +{X} function IsDelphiMemoryManagerSet : Boolean; +{X} function MemoryManagerNotUsed : Boolean; + +procedure GetMemoryManager(var MemMgr: TMemoryManager); +procedure SetMemoryManager(const MemMgr: TMemoryManager); +{X} // following function is replaced with pointer to one +{X} // (initialized by another) +{X} //function IsMemoryManagerSet: Boolean; +var IsMemoryManagerSet : function : Boolean = MemoryManagerNotUsed; + + +function SysGetMem(Size: Integer): Pointer; +function SysFreeMem(P: Pointer): Integer; +function SysReallocMem(P: Pointer; Size: Integer): Pointer; + +var + AllocMemCount: Integer; { Number of allocated memory blocks } + AllocMemSize: Integer; { Total size of allocated memory blocks } + +{$IFDEF MSWINDOWS} +function GetHeapStatus: THeapStatus; platform; +{$ENDIF} + +{ Thread support } +type + TThreadFunc = function(Parameter: Pointer): Integer; +{$IFDEF LINUX} + TSize_T = Cardinal; + + TSchedParam = record + sched_priority: Integer; + end; + + pthread_attr_t = record + __detachstate, + __schedpolicy: Integer; + __schedparam: TSchedParam; + __inheritsched, + __scope: Integer; + __guardsize: TSize_T; + __stackaddr_set: Integer; + __stackaddr: Pointer; + __stacksize: TSize_T; + end; + {$EXTERNALSYM pthread_attr_t} + TThreadAttr = pthread_attr_t; + PThreadAttr = ^TThreadAttr; + + TBeginThreadProc = function (Attribute: PThreadAttr; + ThreadFunc: TThreadFunc; Parameter: Pointer; + var ThreadId: Cardinal): Integer; + TEndThreadProc = procedure(ExitCode: Integer); + +var + BeginThreadProc: TBeginThreadProc = nil; + EndThreadProc: TEndThreadProc = nil; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function BeginThread(SecurityAttributes: Pointer; StackSize: LongWord; + ThreadFunc: TThreadFunc; Parameter: Pointer; CreationFlags: LongWord; + var ThreadId: LongWord): Integer; +{$ENDIF} +{$IFDEF LINUX} +function BeginThread(Attribute: PThreadAttr; ThreadFunc: TThreadFunc; + Parameter: Pointer; var ThreadId: Cardinal): Integer; + +{$ENDIF} +procedure EndThread(ExitCode: Integer); + +{ Standard procedures and functions } + +const +{ File mode magic numbers } + + fmClosed = $D7B0; + fmInput = $D7B1; + fmOutput = $D7B2; + fmInOut = $D7B3; + +{ Text file flags } + tfCRLF = $1; // Dos compatibility flag, for CR+LF line breaks and EOF checks + +type +{ Typed-file and untyped-file record } + + TFileRec = packed record (* must match the size the compiler generates: 332 bytes *) + Handle: Integer; + Mode: Word; + Flags: Word; + case Byte of + 0: (RecSize: Cardinal); // files of record + 1: (BufSize: Cardinal; // text files + BufPos: Cardinal; + BufEnd: Cardinal; + BufPtr: PChar; + OpenFunc: Pointer; + InOutFunc: Pointer; + FlushFunc: Pointer; + CloseFunc: Pointer; + UserData: array[1..32] of Byte; + Name: array[0..259] of Char; ); + end; + +{ Text file record structure used for Text files } + PTextBuf = ^TTextBuf; + TTextBuf = array[0..127] of Char; + TTextRec = packed record (* must match the size the compiler generates: 460 bytes *) + Handle: Integer; (* must overlay with TFileRec *) + Mode: Word; + Flags: Word; + BufSize: Cardinal; + BufPos: Cardinal; + BufEnd: Cardinal; + BufPtr: PChar; + OpenFunc: Pointer; + InOutFunc: Pointer; + FlushFunc: Pointer; + CloseFunc: Pointer; + UserData: array[1..32] of Byte; + Name: array[0..259] of Char; + Buffer: TTextBuf; + end; + + TTextIOFunc = function (var F: TTextRec): Integer; + TFileIOFunc = function (var F: TFileRec): Integer; + +procedure SetLineBreakStyle(var T: Text; Style: TTextLineBreakStyle); + +procedure ChDir(const S: string); overload; +procedure ChDir(P: PChar); overload; +function Flush(var t: Text): Integer; +procedure _LGetDir(D: Byte; var S: string); +procedure _SGetDir(D: Byte; var S: ShortString); +function IOResult: Integer; +procedure MkDir(const S: string); overload; +procedure MkDir(P: PChar); overload; +procedure Move(const Source; var Dest; Count: Integer); +function ParamCount: Integer; +function ParamStr(Index: Integer): string; +procedure RmDir(const S: string); overload; +procedure RmDir(P: PChar); overload; +function UpCase(Ch: Char): Char; + +{ random functions } +procedure Randomize; + +function Random(const ARange: Integer): Integer; overload; +function Random: Extended; overload; + +{ Control 8087 control word } + +procedure Set8087CW(NewCW: Word); +function Get8087CW: Word; + +{ Wide character support procedures and functions for C++ } +{ These functions should not be used in Delphi code! + (conversion is implicit in Delphi code) } + +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; + +{ PUCS4Chars returns a pointer to the UCS4 char data in the + UCS4String array, or a pointer to a null char if UCS4String is empty } + +function PUCS4Chars(const S: UCS4String): PUCS4Char; + +{ Widestring <-> UCS4 conversion } + +function WideStringToUCS4String(const S: WideString): UCS4String; +function UCS4StringToWideString(const S: UCS4String): WideString; + +{ PChar/PWideChar Unicode <-> UTF8 conversion } + +// UnicodeToUTF8(3): +// UTF8ToUnicode(3): +// Scans the source data to find the null terminator, up to MaxBytes +// Dest must have MaxBytes available in Dest. +// MaxDestBytes includes the null terminator (last char in the buffer will be set to null) +// Function result includes the null terminator. + +function UnicodeToUtf8(Dest: PChar; Source: PWideChar; MaxBytes: Integer): Integer; overload; deprecated; +function Utf8ToUnicode(Dest: PWideChar; Source: PChar; MaxChars: Integer): Integer; overload; deprecated; + +// UnicodeToUtf8(4): +// UTF8ToUnicode(4): +// MaxDestBytes includes the null terminator (last char in the buffer will be set to null) +// Function result includes the null terminator. +// Nulls in the source data are not considered terminators - SourceChars must be accurate + +function UnicodeToUtf8(Dest: PChar; MaxDestBytes: Cardinal; Source: PWideChar; SourceChars: Cardinal): Cardinal; overload; +function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: Cardinal; Source: PChar; SourceBytes: Cardinal): Cardinal; overload; + +{ WideString <-> UTF8 conversion } + +function UTF8Encode(const WS: WideString): UTF8String; +function UTF8Decode(const S: UTF8String): WideString; + +{ Ansi <-> UTF8 conversion } + +function AnsiToUtf8(const S: string): UTF8String; +function Utf8ToAnsi(const S: UTF8String): string; + +{ OLE string support procedures and functions } + +function OleStrToString(Source: PWideChar): string; +procedure OleStrToStrVar(Source: PWideChar; var Dest: string); +function StringToOleStr(const Source: string): PWideChar; + +{ Variant manager support procedures and functions } + +procedure GetVariantManager(var VarMgr: TVariantManager); +procedure SetVariantManager(const VarMgr: TVariantManager); +function IsVariantManagerSet: Boolean; + +{ Variant support procedures and functions } + +procedure _VarClear(var V: Variant); +procedure _VarCopy(var Dest: Variant; const Source: Variant); +procedure _VarCopyNoInd; +procedure _VarCast(var Dest: Variant; const Source: Variant; VarType: Integer); +procedure _VarCastOle(var Dest: Variant; const Source: Variant; VarType: Integer); +procedure _VarClr(var V: Variant); + +{ Variant text streaming support } + +function _WriteVariant(var T: Text; const V: Variant; Width: Integer): Pointer; +function _Write0Variant(var T: Text; const V: Variant): Pointer; + +{ Variant math and conversion support } + +function _VarToInt(const V: Variant): Integer; +function _VarToInt64(const V: Variant): Int64; +function _VarToBool(const V: Variant): Boolean; +function _VarToReal(const V: Variant): Extended; +function _VarToCurr(const V: Variant): Currency; +procedure _VarToPStr(var S; const V: Variant); +procedure _VarToLStr(var S: string; const V: Variant); +procedure _VarToWStr(var S: WideString; const V: Variant); +procedure _VarToIntf(var Unknown: IInterface; const V: Variant); +procedure _VarToDisp(var Dispatch: IDispatch; const V: Variant); +procedure _VarToDynArray(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer); + +procedure _VarFromInt(var V: Variant; const Value, Range: Integer); +procedure _VarFromInt64(var V: Variant; const Value: Int64); +procedure _VarFromBool(var V: Variant; const Value: Boolean); +procedure _VarFromReal; // var V: Variant; const Value: Real +procedure _VarFromTDateTime; // var V: Variant; const Value: TDateTime +procedure _VarFromCurr; // var V: Variant; const Value: Currency +procedure _VarFromPStr(var V: Variant; const Value: ShortString); +procedure _VarFromLStr(var V: Variant; const Value: string); +procedure _VarFromWStr(var V: Variant; const Value: WideString); +procedure _VarFromIntf(var V: Variant; const Value: IInterface); +procedure _VarFromDisp(var V: Variant; const Value: IDispatch); +procedure _VarFromDynArray(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer); +procedure _OleVarFromPStr(var V: OleVariant; const Value: ShortString); +procedure _OleVarFromLStr(var V: OleVariant; const Value: string); +procedure _OleVarFromVar(var V: OleVariant; const Value: Variant); +procedure _OleVarFromInt(var V: OleVariant; const Value, Range: Integer); + +procedure _VarAdd(var Left: Variant; const Right: Variant); +procedure _VarSub(var Left: Variant; const Right: Variant); +procedure _VarMul(var Left: Variant; const Right: Variant); +procedure _VarDiv(var Left: Variant; const Right: Variant); +procedure _VarMod(var Left: Variant; const Right: Variant); +procedure _VarAnd(var Left: Variant; const Right: Variant); +procedure _VarOr(var Left: Variant; const Right: Variant); +procedure _VarXor(var Left: Variant; const Right: Variant); +procedure _VarShl(var Left: Variant; const Right: Variant); +procedure _VarShr(var Left: Variant; const Right: Variant); +procedure _VarRDiv(var Left: Variant; const Right: Variant); + +procedure _VarCmpEQ(const Left, Right: Variant); // result is set in the flags +procedure _VarCmpNE(const Left, Right: Variant); // result is set in the flags +procedure _VarCmpLT(const Left, Right: Variant); // result is set in the flags +procedure _VarCmpLE(const Left, Right: Variant); // result is set in the flags +procedure _VarCmpGT(const Left, Right: Variant); // result is set in the flags +procedure _VarCmpGE(const Left, Right: Variant); // result is set in the flags + +procedure _VarNeg(var V: Variant); +procedure _VarNot(var V: Variant); + +{ Variant dispatch and reference support } + +procedure _DispInvoke; cdecl; // Dest: PVarData; const Source: TVarData; + // CallDesc: PCallDesc; Params: Pointer +procedure _IntfDispCall; cdecl; // ARGS PLEASE! +procedure _IntfVarCall; cdecl; // ARGS PLEASE! +procedure _VarAddRef(var V: Variant); + +{ Variant array support procedures and functions } + +procedure _VarArrayRedim(var A : Variant; HighBound: Integer); +function _VarArrayGet(var A: Variant; IndexCount: Integer; + Indices: Integer): Variant; cdecl; +procedure _VarArrayPut(var A: Variant; const Value: Variant; + IndexCount: Integer; Indices: Integer); cdecl; + +{ Package/Module registration and unregistration } + +type + PLibModule = ^TLibModule; + TLibModule = record + Next: PLibModule; + Instance: LongWord; + CodeInstance: LongWord; + DataInstance: LongWord; + ResInstance: LongWord; + Reserved: Integer; +{$IFDEF LINUX} + InstanceVar: Pointer platform; + GOT: LongWord platform; + CodeSegStart: LongWord platform; + CodeSegEnd: LongWord platform; + InitTable: Pointer platform; +{$ENDIF} + end; + + TEnumModuleFunc = function (HInstance: Integer; Data: Pointer): Boolean; + {$EXTERNALSYM TEnumModuleFunc} + TEnumModuleFuncLW = function (HInstance: LongWord; Data: Pointer): Boolean; + {$EXTERNALSYM TEnumModuleFuncLW} + TModuleUnloadProc = procedure (HInstance: Integer); + {$EXTERNALSYM TModuleUnloadProc} + TModuleUnloadProcLW = procedure (HInstance: LongWord); + {$EXTERNALSYM TModuleUnloadProcLW} + + PModuleUnloadRec = ^TModuleUnloadRec; + TModuleUnloadRec = record + Next: PModuleUnloadRec; + Proc: TModuleUnloadProcLW; + end; + +var + LibModuleList: PLibModule = nil; + ModuleUnloadList: PModuleUnloadRec = nil; + +procedure RegisterModule(LibModule: PLibModule); +{X procedure UnregisterModule(LibModule: PLibModule); -replaced with pointer to procedure } +{X} procedure UnregisterModuleLight(LibModule: PLibModule); +{X} procedure UnregisterModuleSafely(LibModule: PLibModule); +var UnregisterModule : procedure(LibModule: PLibModule) = UnregisterModuleLight; +function FindHInstance(Address: Pointer): LongWord; +function FindClassHInstance(ClassType: TClass): LongWord; +function FindResourceHInstance(Instance: LongWord): LongWord; +function LoadResourceModule(ModuleName: PChar; CheckOwner: Boolean = True): LongWord; +procedure EnumModules(Func: TEnumModuleFunc; Data: Pointer); overload; +procedure EnumResourceModules(Func: TEnumModuleFunc; Data: Pointer); overload; +procedure EnumModules(Func: TEnumModuleFuncLW; Data: Pointer); overload; +procedure EnumResourceModules(Func: TEnumModuleFuncLW; Data: Pointer); overload; +procedure AddModuleUnloadProc(Proc: TModuleUnloadProc); overload; +procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProc); overload; +procedure AddModuleUnloadProc(Proc: TModuleUnloadProcLW); overload; +procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProcLW); overload; +{$IFDEF LINUX} +{ Given an HMODULE, this function will return its fully qualified name. There is + no direct equivalent in Linux so this function provides that capability. } +function GetModuleFileName(Module: HMODULE; Buffer: PChar; BufLen: Integer): Integer; +{$ENDIF} + +{ ResString support function/record } + +type + PResStringRec = ^TResStringRec; + TResStringRec = packed record + Module: ^Cardinal; + Identifier: Integer; + end; + +function LoadResString(ResStringRec: PResStringRec): string; + +{ Procedures and functions that need compiler magic } + +function Int(const X: Extended): Extended; +function Frac(const X: Extended): Extended; +function Exp(const X: Extended): Extended; +function Cos(const X: Extended): Extended; +function Sin(const X: Extended): Extended; +function Ln(const X: Extended): Extended; +function ArcTan(const X: Extended): Extended; +function Sqrt(const X: Extended): Extended; + +procedure _ROUND; +procedure _TRUNC; + +procedure _AbstractError; +procedure _Assert(const Message, Filename: AnsiString; LineNumber: Integer); +function _Append(var t: TTextRec): Integer; +function _Assign(var t: TTextRec; const S: String): Integer; +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); +function _EofFile(var f: TFileRec): Boolean; +function _EofText(var t: TTextRec): Boolean; +function _Eoln(var t: TTextRec): Boolean; +procedure _Erase(var f: TFileRec); +function _FilePos(var f: TFileRec): Longint; +function _FileSize(var f: TFileRec): Longint; +procedure _FillChar(var Dest; count: Integer; Value: Char); +function _FreeMem(P: Pointer): Integer; +function _GetMem(Size: Integer): Pointer; +function _ReallocMem(var P: Pointer; NewSize: Integer): Pointer; +procedure _Halt(Code: Integer); +procedure _Halt0; +procedure Mark; deprecated; +procedure _PStrCmp; +procedure _AStrCmp; +procedure _RandInt; +procedure _RandExt; +function _ReadRec(var f: TFileRec; Buffer: Pointer): Integer; +function _ReadChar(var t: TTextRec): Char; +function _ReadLong(var t: TTextRec): Longint; +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); +procedure _ReadWString(var t: TTextRec; var s: WideString); +procedure _ReadWCString(var t: TTextRec; s: PWideChar; maxBytes: Longint); +function _ReadWChar(var t: TTextRec): WideChar; +function _ReadExt(var t: TTextRec): Extended; +procedure _ReadLn(var t: TTextRec); +procedure _Rename(var f: TFileRec; newName: PChar); +procedure Release; deprecated; +function _ResetText(var t: TTextRec): Integer; +function _ResetFile(var f: TFileRec; recSize: Longint): Integer; +function _RewritText(var t: TTextRec): Integer; +function _RewritFile(var f: TFileRec; recSize: Longint): Integer; +procedure _RunError(errorCode: Byte); +procedure _Run0Error; +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; +{$IFDEF LINUX} +procedure _UnhandledException; +{$ENDIF} +function _WriteRec(var f: TFileRec; buffer: Pointer): Pointer; +function _WriteChar(var t: TTextRec; c: Char; width: Integer): Pointer; +function _Write0Char(var t: TTextRec; c: Char): 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 _WriteString(var t: TTextRec; const s: ShortString; width: Longint): Pointer; +function _Write0String(var t: TTextRec; const s: ShortString): Pointer; +function _WriteCString(var t: TTextRec; s: PChar; width: Longint): Pointer; +function _Write0CString(var t: TTextRec; s: PChar): Pointer; +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 _WriteWCString(var t: TTextRec; s: PWideChar; width: Longint): Pointer; +function _Write0WCString(var t: TTextRec; s: PWideChar): Pointer; +function _WriteWChar(var t: TTextRec; c: WideChar; width: Integer): Pointer; +function _Write0WChar(var t: TTextRec; c: WideChar): 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 __IOTest; +function _Flush(var t: TTextRec): Integer; + +procedure _SetElem; +procedure _SetRange; +procedure _SetEq; +procedure _SetLe; +procedure _SetIntersect; +procedure _SetIntersect3; { BEG only } +procedure _SetUnion; +procedure _SetUnion3; { BEG only } +procedure _SetSub; +procedure _SetSub3; { BEG only } +procedure _SetExpand; + +procedure _Str2Ext; +procedure _Str0Ext; +procedure _Str1Ext; +procedure _ValExt; +procedure _Pow10; +procedure _Real2Ext; +procedure _Ext2Real; + +procedure _ObjSetup; +procedure _ObjCopy; +procedure _Fail; +procedure _BoundErr; +procedure _IntOver; + +{ Module initialization context. For internal use only. } + +type + PInitContext = ^TInitContext; + TInitContext = record + OuterContext: PInitContext; { saved InitContext } +{$IFNDEF PC_MAPPED_EXCEPTIONS} + ExcFrame: Pointer; { bottom exc handler } +{$ENDIF} + InitTable: PackageInfo; { unit init info } + InitCount: Integer; { how far we got } + Module: PLibModule; { ptr to module desc } + DLLSaveEBP: Pointer; { saved regs for DLLs } + DLLSaveEBX: Pointer; { saved regs for DLLs } + DLLSaveESI: Pointer; { saved regs for DLLs } + DLLSaveEDI: Pointer; { saved regs for DLLs } +{$IFDEF MSWINDOWS} + ExitProcessTLS: procedure; { Shutdown for TLS } +{$ENDIF} + DLLInitState: Byte; { 0 = package, 1 = DLL shutdown, 2 = DLL startup } + end platform; + +type + TDLLProc = procedure (Reason: Integer); + // TDLLProcEx provides the reserved param returned by WinNT + TDLLProcEx = procedure (Reason: Integer; Reserved: Integer); + +{$IFDEF LINUX} +procedure _StartExe(InitTable: PackageInfo; Module: PLibModule; Argc: Integer; Argv: Pointer); +procedure _StartLib(Context: PInitContext; Module: PLibModule; DLLProc: TDLLProcEx); +{$ENDIF} +{$IFDEF MSWINDOWS} +procedure _StartExe(InitTable: PackageInfo; Module: PLibModule); +procedure _StartLib; +{$ENDIF} +procedure _PackageLoad(const Table : PackageInfo; Module: PLibModule); +procedure _PackageUnload(const Table : PackageInfo; Module: PLibModule); +procedure _InitResStrings; +procedure _InitResStringImports; +procedure _InitImports; +{$IFDEF MSWINDOWS} +procedure _InitWideStrings; +{$ENDIF} + +function _ClassCreate(AClass: TClass; Alloc: Boolean): TObject; +procedure _ClassDestroy(Instance: TObject); +function _AfterConstruction(Instance: TObject): TObject; +function _BeforeDestruction(Instance: TObject; OuterMost: ShortInt): TObject; +function _IsClass(Child: TObject; Parent: TClass): Boolean; +function _AsClass(Child: TObject; Parent: TClass): TObject; + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _RaiseAtExcept; +//procedure _DestroyException(Exc: PRaisedException); +procedure _DestroyException; +{$ENDIF} +procedure _RaiseExcept; +procedure _RaiseAgain; +procedure _DoneExcept; +{$IFNDEF PC_MAPPED_EXCEPTIONS} +procedure _TryFinallyExit; +{$ENDIF} +procedure _HandleAnyException; +procedure _HandleFinally; +procedure _HandleOnException; +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _HandleOnExceptionPIC; +{$ENDIF} +procedure _HandleAutoException; +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _ClassHandleException; +{$ENDIF} + +procedure _CallDynaInst; +procedure _CallDynaClass; +procedure _FindDynaInst; +procedure _FindDynaClass; + +procedure _LStrClr(var S); +procedure _LStrArrayClr(var StrArray; cnt: longint); +procedure _LStrAsg(var dest; const source); +procedure _LStrLAsg(var dest; const source); +procedure _LStrFromPCharLen(var Dest: AnsiString; Source: PAnsiChar; Length: 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 _LStrToPChar(const s: AnsiString): PChar; +procedure _Copy{ s : ShortString; index, count : Integer ) : ShortString}; +procedure _Delete{ var s : openstring; index, count : Integer }; +procedure _Insert{ source : ShortString; var s : openstring; index : Integer }; +function Pos(const substr, str: AnsiString): Integer; overload; +function Pos(const substr, str: WideString): Integer; overload; +procedure _SetLength(s: PShortString; newLength: Byte); +procedure _SetString(s: PShortString; buffer: PChar; len: Byte); + +procedure UniqueString(var str: AnsiString); overload; +procedure UniqueString(var str: WideString); overload; +procedure _UniqueStringA(var str: AnsiString); +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 _NewAnsiString(length: Longint): Pointer; { for debugger purposes only } +function _NewWideString(CharLength: Longint): Pointer; + +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); +function _WStrToPWChar(const S: WideString): PWideChar; +function _WStrLen(const S: WideString): Integer; +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); +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; + +procedure _Initialize(p: Pointer; typeInfo: Pointer); +procedure _InitializeArray(p: Pointer; typeInfo: Pointer; elemCount: Cardinal); +procedure _InitializeRecord(p: Pointer; typeInfo: Pointer); +procedure _Finalize(p: Pointer; typeInfo: Pointer); +procedure _FinalizeArray(p: Pointer; typeInfo: Pointer; elemCount: Cardinal); +procedure _FinalizeRecord(P: Pointer; typeInfo: Pointer); +procedure _AddRef; +procedure _AddRefArray; +procedure _AddRefRecord; +procedure _CopyArray; +procedure _CopyRecord; +procedure _CopyObject; + +function _New(size: Longint; typeInfo: Pointer): Pointer; +procedure _Dispose(p: Pointer; typeInfo: Pointer); + +{ 64-bit Integer helper routines } +procedure __llmul; +procedure __lldiv; +procedure __lludiv; +procedure __llmod; +procedure __llmulo; +procedure __lldivo; +procedure __llmodo; +procedure __llumod; +procedure __llshl; +procedure __llushr; +procedure _WriteInt64; +procedure _Write0Int64; +procedure _ReadInt64; +function _StrInt64(val: Int64; width: Integer): ShortString; +function _Str0Int64(val: Int64): ShortString; +function _ValInt64(const s: AnsiString; var code: Integer): Int64; + +{ Dynamic array helper functions } + +procedure _DynArrayHigh; +procedure _DynArrayClear(var a: Pointer; typeInfo: Pointer); +procedure _DynArrayLength; +procedure _DynArraySetLength; +procedure _DynArrayCopy(a: Pointer; typeInfo: Pointer; var Result: Pointer); +procedure _DynArrayCopyRange(a: Pointer; typeInfo: Pointer; index, count : Integer; var Result: Pointer); +procedure _DynArrayAsg; +procedure _DynArrayAddRef; + +procedure DynArrayClear(var a: Pointer; typeInfo: Pointer); +procedure DynArraySetLength(var a: Pointer; typeInfo: Pointer; dimCnt: Longint; lengthVec: PLongint); +function DynArrayDim(typeInfo: PDynArrayTypeInfo): Integer; +{$NODEFINE DynArrayDim} + +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); + +{$IFDEF MSWINDOWS} +procedure _FSafeDivide; +procedure _FSafeDivideR; +{$ENDIF} + +function _CheckAutoResult(ResultCode: HResult): HResult; + +procedure FPower10; + +procedure TextStart; deprecated; + +// Conversion utility routines for C++ convenience. Not for Delphi code. +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; + +{ Internal runtime error codes } + +type + TRuntimeError = (reNone, reOutOfMemory, reInvalidPtr, reDivByZero, + reRangeError, reIntOverflow, reInvalidOp, reZeroDivide, reOverflow, + reUnderflow, reInvalidCast, reAccessViolation, rePrivInstruction, + reControlBreak, reStackOverflow, + { reVar* used in Variants.pas } + reVarTypeCast, reVarInvalidOp, + reVarDispatch, reVarArrayCreate, reVarNotArray, reVarArrayBounds, + reAssertionFailed, + reExternalException, { not used here; in SysUtils } + reIntfCastError, reSafeCallError); +{$NODEFINE TRuntimeError} + +procedure Error(errorCode: TRuntimeError); +{$NODEFINE Error} + +{ GetLastError returns the last error reported by an OS API call. Calling + this function usually resets the OS error state. +} + +function GetLastError: Integer; {$IFDEF MSWINDOWS} stdcall; {$ENDIF} +{$EXTERNALSYM GetLastError} + +{ SetLastError writes to the thread local storage area read by GetLastError. } + +procedure SetLastError(ErrorCode: Integer); {$IFDEF MSWINDOWS} stdcall; {$ENDIF} + +{$IFDEF LINUX} +{ To improve performance, some RTL routines cache module handles and data + derived from modules. If an application dynamically loads and unloads + shared object libraries, packages, or resource packages, it is possible for + the handle of the newly loaded module to match the handle of a recently + unloaded module. The resource caches have no way to detect when this happens. + + To address this issue, the RTL maintains an internal counter that is + incremented every time a module is loaded or unloaded using RTL functions + (like LoadPackage). This provides a cache version level signature that + can detect when modules have been cycled but have the same handle. + + If you load or unload modules "by hand" using dlopen or dlclose, you must call + InvalidateModuleCache after each load or unload so that the RTL module handle + caches will refresh themselves properly the next time they are used. This is + especially important if you manually tinker with the LibModuleList list of + loaded modules, or manually add or remove resource modules in the nodes + of that list. + + ModuleCacheID returns the "current generation" or version number kept by + the RTL. You can use this to implement your own refresh-on-next-use + (passive) module handle caches as the RTL does. The value changes each + time InvalidateModuleCache is called. +} + +function ModuleCacheID: Cardinal; +procedure InvalidateModuleCache; +{$ENDIF} + +{$IFDEF LINUX} +{ When a process that is being debugged is stopped while it has the mouse + pointer grabbed, there is no way for the debugger to release the grab on + behalf of the process. The process needs to do it itself. To accomplish this, + the debugger causes DbgUnlockX to execute whenever it detects the process + might have the mouse grabbed. This method will call through DbgUnlockXProc + which should be assigned by any library using X and locks the X pointer. This + method should be chained, by storing of the previous instance and calling it + when you are called, since there might be more than one display that needs + to be unlocked. This method should call XUngrabPointer on the display that + has the pointer grabbed. +} +var + DbgUnlockXProc: procedure; + +procedure DbgUnlockX; +{$ENDIF} + +{X+ moved here from SysInit.pas - by advise of Alexey Torgashin - to avoid + creating of separate import block from kernel32.dll : } +////////////////////////////////////////////////////////////////////////// + +function FreeLibrary(ModuleHandle: Longint): LongBool; stdcall; +function GetModuleFileName(Module: Integer; Filename: PChar; Size: Integer): Integer; stdcall; +function GetModuleHandle(ModuleName: PChar): Integer; stdcall; +function LocalAlloc(flags, size: Integer): Pointer; stdcall; +function LocalFree(addr: Pointer): Pointer; stdcall; +function TlsAlloc: Integer; stdcall; +function TlsFree(TlsIndex: Integer): Boolean; stdcall; +function TlsGetValue(TlsIndex: Integer): Pointer; stdcall; +function TlsSetValue(TlsIndex: Integer; TlsValue: Pointer): Boolean; stdcall; +function GetCommandLine: PChar; stdcall; +{X-}////////////////////////////////////////////////////////////////////// + +{X+} +{X}function GetProcessHeap: THandle; stdcall; +{X}function HeapAlloc(hHeap: THandle; dwFlags, dwBytes: Cardinal): Pointer; stdcall; +{X}function HeapReAlloc(hHeap: THandle; dwFlags: Cardinal; lpMem: Pointer; dwBytes: Cardinal): Pointer; stdcall; +{X}function HeapFree(hHeap: THandle; dwFlags: Cardinal; lpMem: Pointer): LongBool; stdcall; +{X}function DfltGetMem(size: Integer): Pointer; +{X}function DfltFreeMem(p: Pointer): Integer; +{X}function DfltReallocMem(p: Pointer; size: Integer): Pointer; +{X} procedure InitUnitsLight( Table : PUnitEntryTable; Idx, Count : Integer ); +{X} procedure FInitUnitsLight; +{X} // following two procedures are optional and exclusive. +{X} // call it to provide error message: first - for GUI app, +{X} // second - for console app. +{X} procedure UseErrorMessageBox; +{X} procedure UseErrorMessageWrite; + +{X} // call following procedure to initialize Input and Output +{X} // - for console app only: +{X} procedure UseInputOutput; + +{X} // if your app uses FPU, call one of following procedures: +{X} procedure FpuInit; +{X} procedure FpuInitConsiderNECWindows; +{X} // the second additionally takes into consideration NEC +{X} // Windows keyboard (Japaneeze keyboard ???). + +{X} procedure DummyProc; // empty procedure + +(* +{X} procedure VariantClr; +{X} // procedure to refer to _VarClr if SysVarnt.pas is in use +{X} var VarClrProc : procedure = DummyProc; + +{X} procedure VarCastError; +{X} procedure VarInvalidOp; + +{X} procedure VariantAddRef; +{X} // procedure to refer to _VarAddRef if SysVarnt.pas is in use +{X} var VarAddRefProc : procedure = DummyProc; +*) + +{X} procedure WStrAddRef; +{X} // procedure to refer to _WStrAddRef if SysWStr.pas is in use +{X} var WStrAddRefProc : procedure = DummyProc; + +{X} procedure WStrClr; +{X} // procedure to refer to _WStrClr if SysWStr.pas is in use +{X} var WStrClrProc : procedure = DummyProc; + +{X} procedure WStrArrayClr; +{X} // procedure to refer to _WStrArrayClr if SysWStr.pas is in use +{X} var WStrArrayClrProc : procedure = DummyProc; + +{X} // Standard Delphi units initialization/finalization uses +{X} // try-except and raise constructions, which leads to permanent +{X} // usage of all exception handling routines. In this XCL-aware +{X} // implementation, "light" version of initialization/finalization +{X} // is used by default. To use standard Delphi initialization and +{X} // finalization method, allowing to flow execution control even +{X} // in initalization sections, include reference to SysSfIni.pas +{X} // into uses clause *as first as possible*. +{X} procedure InitUnitsHard( Table : PUnitEntryTable; Idx, Count : Integer ); +{X} var InitUnitsProc : procedure( Table : PUnitEntryTable; Idx, Count : Integer ) +{X} = InitUnitsLight; +{X} procedure FInitUnitsHard; +{X} var FInitUnitsProc : procedure = FInitUnitsLight; +{X} procedure SetExceptionHandler; +{X} procedure UnsetExceptionHandler; +{X} var UnsetExceptionHandlerProc : procedure = DummyProc; + +{X} var UnloadResProc: procedure = DummyProc; +{X-} + +(* =================================================================== *) + + +{ UnicodeString helper functions } + +function _UStrAddRef(str: Pointer { UnicodeString }): Pointer; +procedure _UStrClr(var S); +procedure _UStrArrayClr(var StrArray; Count: Integer); +procedure _UStrAsg(var Dest: UnicodeString; const Source: UnicodeString); // globals (need copy) +procedure _UStrLAsg(var Dest: UnicodeString; const Source: UnicodeString); // locals +function _UStrToPWChar(const S: UnicodeString): PWideChar; +procedure _UStrFromPCharLen(var Dest: UnicodeString; Source: PAnsiChar; Length: Integer); +procedure _UStrFromPWCharLen(var Dest: UnicodeString; Source: PWideChar; CharLength: Integer); +procedure _UStrFromChar(var Dest: UnicodeString; Source: AnsiChar); +procedure _UStrFromWChar(var Dest: UnicodeString; Source: WideChar); +procedure _UStrFromPChar(var Dest: UnicodeString; Source: PAnsiChar); +procedure _UStrFromPWChar(var Dest: UnicodeString; Source: PWideChar); +procedure _UStrFromArray(var Dest: UnicodeString; Source: PAnsiChar; Length: Integer); +procedure _UStrFromWArray(var Dest: UnicodeString; Source: PWideChar; Length: Integer); +procedure _UStrFromLStr(var Dest: UnicodeString; const Source: AnsiString); +procedure _UStrFromWStr(var Dest: UnicodeString; const Source: WideString); +procedure _UStrToString(Dest: PShortString; const Source: UnicodeString; MaxLen: Integer); +procedure _UStrFromString(var Dest: UnicodeString; const Source: ShortString); +function _UStrLen(const S: UnicodeString): Integer; inline; +procedure _UStrSetLength(var S: UnicodeString; NewLength: Integer); +procedure _UStrCat(var Dest: UnicodeString; const Source: UnicodeString); +procedure _UStrCat3(var Dest: UnicodeString; const Source1, Source2: UnicodeString); +procedure _UStrCatN{var dest:UnicodeString; argCnt: Integer; ...}; +procedure _UStrCmp{left: UnicodeString; right: UnicodeString}; +procedure _UStrEqual{const Left, Right: UnicodeString}; +function _UStrCopy(const S: UnicodeString; Index, Count: Integer): UnicodeString; +procedure _UStrDelete(var S: UnicodeString; Index, Count: Integer); +procedure _UStrInsert(const Source: UnicodeString; var Dest: UnicodeString; Index: Integer); + +implementation + +uses + SysInit; + +type + PStrRec = ^StrRec; + StrRec = packed record + codePage: Word; + elemSize: Word; + refCnt: Longint; + length: Longint; + end; + +const + skew = SizeOf(StrRec); + rOff = SizeOf(StrRec); { codePage offset } + overHead = SizeOf(StrRec) + SizeOf(Char); + CP_UTF8 = 65001; + CP_UTF16 = 1200; + STATUS_WAIT_0 = Cardinal($00000000); + WAIT_OBJECT_0 = (STATUS_WAIT_0 + 0); + +{ UnicodeString helper functions } + +function _UStrAddRef(str: Pointer { UnicodeString }): Pointer; +asm + JMP _LStrAddRef +end; + +procedure _UStrClr(var S); +asm + JMP _LStrClr +end; + +procedure _UStrArrayClr(var StrArray; Count: Integer); +asm + JMP _LStrArrayClr +end; + +procedure _UStrAsg(var Dest: UnicodeString; const Source: UnicodeString); // globals (need copy) +{$IFDEF PUREPASCAL} +var + S, D: Pointer; + P: PStrRec; + Temp: Longint; +begin + S := Pointer(source); + if S <> nil then + begin + P := PStrRec(Integer(S) - sizeof(StrRec)); + if P.refCnt < 0 then // make copy of string literal + begin + Temp := P.length; + S := _NewUnicodeString(Temp); + Move(Pointer(source)^, S^, Temp * SizeOf(WideChar)); + P := PStrRec(Integer(S) - sizeof(StrRec)); + end; + InterlockedIncrement(P.refCnt); + end; + + D := Pointer(dest); + Pointer(dest) := S; + if D <> nil then + begin + P := PStrRec(Integer(D) - sizeof(StrRec)); + if P.refCnt > 0 then + if InterlockedDecrement(P.refCnt) = 0 then + FreeMem(P); + end; +end; +{$ELSE} +asm + { -> EAX pointer to dest str } + { -> EDX pointer to source str } + + TEST EDX,EDX { have a source? } + JE @@2 { no -> jump } + + CMP [EDX-Skew].StrRec.elemSize,2 + JE @@isUnicode + JMP _UStrFromLStr + +@@isUnicode: + MOV ECX,[EDX-skew].StrRec.refCnt + INC ECX + JG @@1 { literal string -> jump not taken } + + PUSH EAX + PUSH EDX + MOV EAX,[EDX-skew].StrRec.length + CALL _NewUnicodeString + MOV EDX,EAX + POP EAX + PUSH EDX + MOV ECX,[EAX-skew].StrRec.length + SHL ECX,1 { length to bytes for move } + CALL Move + POP EDX + POP EAX + JMP @@2 + +@@1: + LOCK INC [EDX-skew].StrRec.refCnt + +@@2: XCHG EDX,[EAX] + TEST EDX,EDX + JE @@3 + MOV ECX,[EDX-skew].StrRec.refCnt + DEC ECX + JL @@3 + LOCK DEC [EDX-skew].StrRec.refCnt + JNE @@3 + LEA EAX,[EDX-skew].StrRec.codePage + CALL _FreeMem +@@3: +end; +{$ENDIF} + +procedure _UStrLAsg(var Dest: UnicodeString; const Source: UnicodeString); // locals +asm +{ -> EAX pointer to dest } +{ EDX source } + + TEST EDX,EDX + JE @@sourceDone + + CMP [EDX-Skew].StrRec.elemSize,2 + JE @@isUnicode + JMP _UStrFromLStr + +@@isUnicode: + { bump up the ref count of the source } + + MOV ECX,[EDX-skew].StrRec.refCnt + INC ECX + JLE @@sourceDone { literal assignment -> jump taken } + LOCK INC [EDX-skew].StrRec.refCnt +@@sourceDone: + + { we need to release whatever the dest is pointing to } + + XCHG EDX,[EAX] { fetch str } + TEST EDX,EDX { if nil, nothing to do } + JE @@done + MOV ECX,[EDX-skew].StrRec.refCnt { fetch refCnt } + DEC ECX { if < 0: literal str } + JL @@done + LOCK DEC [EDX-skew].StrRec.refCnt { threadsafe dec refCount } + JNE @@done + LEA EAX,[EDX-skew].StrRec.codePage { if refCnt now zero, deallocate} + CALL _FreeMem +@@done: +end; + +type + TEmptyStringW = packed record + Rec: StrRec; + Nul: Word; + end; + +const + // Using initialized constant to be sure of alignment. + // Not as read-only as code segment, but code entry points + // have no alignment guarantees. + EmptyStringW: TEmptyStringW = ( + Rec: ( + codePage: Word($FFFF); + elemSize: 2; + refCnt: -1; + length: 0); + Nul: 0); + +function _UStrToPWChar(const S: UnicodeString): PWideChar; +{$IFDEF PUREPASCAL} +const + EmptyString = ''; +begin + if Pointer(S) = nil then + Result := EmptyString + else + Result := Pointer(S); +end; +{$ELSE} +asm + { -> EAX pointer to S } + { <- EAX pointer to PWideChar } + + TEST EAX,EAX + JE @@handle0 + RET +{$IFDEF PIC} +@@handle0: + JMP PICEmptyString +{$ELSE} +@@handle0: + MOV EAX, offset EmptyStringW.Nul +{$ENDIF} +end; +{$ENDIF} + +procedure InternalUStrFromPCharLen(var Dest: UnicodeString; Source: PAnsiChar; Length: Integer; CodePage: Integer); +var + DestLen: Integer; + Buffer: array[0..2047] of WideChar; +begin + if Length <= 0 then + begin + _UStrClr(Dest); + Exit; + end; + if Length+1 < High(Buffer) then + begin + DestLen := WCharFromChar(Buffer, High(Buffer), Source, Length, CodePage); + if DestLen > 0 then + begin + _UStrFromPWCharLen(Dest, @Buffer, DestLen); + Exit; + end; + end; + + DestLen := (Length + 1); + _UStrSetLength(Dest, DestLen); // overallocate, trim later + DestLen := WCharFromChar(Pointer(Dest), DestLen, Source, Length, CodePage); + if DestLen < 0 then DestLen := 0; + _UStrSetLength(Dest, DestLen); +end; + +procedure _UStrFromPCharLen(var Dest: UnicodeString; Source: PAnsiChar; Length: Integer); +begin + InternalUStrFromPCharLen(Dest, Source, Length, DefaultSystemCodePage); +end; + +procedure _UStrFromPWCharLen(var Dest: UnicodeString; Source: PWideChar; CharLength: Integer); +{$IFDEF LINUX} +var + Temp: Pointer; +begin + Temp := Pointer(Dest); + if CharLength > 0 then + begin + Pointer(Dest) := _NewUnicodeString(CharLength); + if Source <> nil then + Move(Source^, Pointer(Dest)^, CharLength * SizeOf(WideChar)); + end + else + Pointer(Dest) := nil; + _UStrClr(Temp); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + { -> EAX pointer to dest } + { EDX source } + { ECX length in characters } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EAX // EBX := addr of Dest (result) in EBX + MOV ESI,EDX // ESI := source + MOV EDI,ECX // EDI := length + + { allocate new string } + + MOV EAX,EDI // EAX := length + + CALL _NewUnicodeString // EAX := new string (result) + MOV ECX,EDI // ECX := length + MOV EDI,EAX // EDI := result + + TEST ESI,ESI // nil source? + JE @@noMove + + MOV EDX,EAX // EDX := result (dest for Move) + MOV EAX,ESI // EAX := source (source for Move) + SHL ECX,1 // ECX := ECX * 2 (turn length into characters) + CALL Move + + { assign the result to dest } + +@@noMove: + MOV EAX,EBX + CALL _LStrClr + MOV [EBX],EDI + + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +procedure _UStrFromChar(var Dest: UnicodeString; Source: AnsiChar); +asm + PUSH EDX // char on stack + MOV EDX,ESP // addr of char on stack in EDX + MOV ECX,1 + CALL _UStrFromPCharLen + POP EDX +end; + +procedure _UStrFromWChar(var Dest: UnicodeString; Source: WideChar); +asm + PUSH EDX + MOV EDX,ESP + MOV ECX,1 + CALL _UStrFromPWCharLen + POP EDX +end; + +procedure _UStrFromPChar(var Dest: UnicodeString; Source: PAnsiChar); +asm + { -> EAX Pointer to WideString (dest) } + { EDX Pointer to character (source) } + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CL,[EDX+0] + JE @@4 + CMP CL,[EDX+1] + JE @@3 + CMP CL,[EDX+2] + JE @@2 + CMP CL,[EDX+3] + JE @@1 + ADD EDX,4 + JMP @@0 +@@1: INC EDX +@@2: INC EDX +@@3: INC EDX +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX +@@5: JMP _UStrFromPCharLen +end; + +procedure _UStrFromPWChar(var Dest: UnicodeString; Source: PWideChar); +asm + { -> EAX Pointer to WideString (dest) } + { EDX Pointer to character (source) } + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CX,[EDX+0] + JE @@4 + CMP CX,[EDX+2] + JE @@3 + CMP CX,[EDX+4] + JE @@2 + CMP CX,[EDX+6] + JE @@1 + ADD EDX,8 + JMP @@0 +@@1: ADD EDX,2 +@@2: ADD EDX,2 +@@3: ADD EDX,2 +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX + SHR ECX,1 +@@5: JMP _UStrFromPWCharLen +end; + +procedure _UStrFromArray(var Dest: UnicodeString; Source: PAnsiChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASB // find #0 + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _UStrFromPCharLen +end; + +procedure _UStrFromWArray(var Dest: UnicodeString; Source: PWideChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASW // find #$0000 + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _UStrFromPWCharLen +end; + +procedure _UStrFromLStr(var Dest: UnicodeString; const Source: AnsiString); +asm + XOR ECX,ECX + TEST EDX,EDX + JE @@1 + CMP [EDX-Skew].StrRec.elemSize,2 + JE @@2 + MOVZX ECX,WORD PTR [EDX-Skew].StrRec.codePage + XCHG ECX,[ESP] + PUSH ECX + MOV ECX,[EDX-Skew].StrRec.length + JMP InternalUStrFromPCharLen +@@1: JMP _UStrFromPCharLen +@@2: JMP _UStrAsg +end; + +procedure _LStrFromUStr(var Dest: AnsiString; const Source: UnicodeString; CodePage: Word); +asm + { -> EAX pointer to dest } + { EDX pointer to UnicodeString data } + { ECX destination codepage } + + XCHG ECX,[ESP] + PUSH ECX + XOR ECX,ECX + TEST EDX,EDX + JE @@1 + CMP [EDX-Skew].StrRec.elemSize,1 + JE @@2 + MOV ECX,[EDX-4] // length in UnicodeString is widechar count +@@1: JMP _LStrFromPWCharLen +@@2: POP ECX + XCHG ECX,[ESP] + JMP _LStrAsg +end; + +procedure _UStrFromWStr(var Dest: UnicodeString; const Source: WideString); +asm + { -> EAX pointer to dest } + { EDX pointer to WideString data } + + XOR ECX,ECX + TEST EDX,EDX + JZ @@1 // nil source => zero length + MOV ECX,[EDX-4] + SHR ECX,1 // length in WideString is byte count +@@1: JMP _UStrFromPWCharLen +end; + +procedure _WStrFromUStr(var Dest: WideString; const Source: UnicodeString); +asm + { -> EAX pointer to dest } + { EDX pointer to UnicodeString data } + + XOR ECX,ECX + TEST EDX,EDX + JZ @@1 // nil source => zero length + MOV ECX,[EDX-Skew].StrRec.length // length in UnicodeString is widechar count + CMP [EDX-Skew].StrRec.elemSize,2 + JNE @@2 +@@1: JMP _WStrFromPWCharLen +// Inject the CodePage parameter onto the stack ahead of the return address +@@2: XCHG ECX,[ESP] + PUSH ECX + MOVZX ECX,[EDX-Skew].StrRec.codePage + XCHG ECX,[ESP + 4] + JMP InternalWStrFromPCharLen +end; + +procedure _UStrToString(Dest: PShortString; const Source: UnicodeString; MaxLen: Integer); +var + SourceLen, DestLen: Integer; + Buffer: array[0..511] of AnsiChar; +begin + if MaxLen > 255 then MaxLen := 255; + SourceLen := Length(Source); + if SourceLen >= MaxLen then SourceLen := MaxLen; + if SourceLen = 0 then + DestLen := 0 + else + begin + DestLen := CharFromWChar(Buffer, High(Buffer), PWideChar(Pointer(Source)), SourceLen); + if DestLen < 0 then + DestLen := 0 + else if DestLen > MaxLen then + DestLen := MaxLen; + end; + Dest^[0] := AnsiChar(Chr(DestLen)); + if DestLen > 0 then Move(Buffer, Dest^[1], DestLen); +end; + +procedure _UStrFromString(var Dest: UnicodeString; const Source: ShortString); +asm + XOR ECX,ECX + MOV CL,[EDX] + INC EDX + JMP _UStrFromPCharLen +end; + +function _UStrLen(const S: UnicodeString): Integer; +begin + Result := Longint(S); + if Result <> 0 then // PStrRec should be used here, but + Result := PLongint(Result - 4)^; // a private symbol can't be inlined +end; + +procedure _UStrSetLength(var S: UnicodeString; NewLength: Integer); +asm + { -> EAX Pointer to S } + { EDX new length } + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX // EBX saves @S + MOV ESI,EDX // ESI saves NewLength (chars) + XOR EDI,EDI // EDI := 0; EDI is Temp (result) + + TEST EDX,EDX // NewLength <= 0? + JLE @@setString // Assign S := Temp + + MOV EAX,[EBX] // EAX := S + TEST EAX,EAX // nil? + JE @@copyString // cannot reallocate (it's nil), so copy + + CMP word ptr [EAX-skew].StrRec.elemSize,2 + JE @@isUnicode + + PUSH 0 + MOV EAX,ESP + MOV EDX,[EBX] + CALL _UStrFromLStr + POP EDI + MOV EAX,EDI + MOV EDX,ESI + XCHG EDI,[EBX] + +@@isUnicode: + CMP [EAX-skew].StrRec.refCnt,1 // !!! MT safety + JNE @@copyString // not unique, so copy + + SUB EAX,rOff // Offset EAX "S" to start of memory block + ADD EDX,EDX // Double length to get size + JO @@overflow + ADD EDX,rOff+2 // Add string rec size + JO @@overflow + PUSH EAX // Put S on stack + MOV EAX,ESP // to pass by reference + CALL _ReallocMem + POP EAX + ADD EAX,rOff // Readjust + MOV [EBX],EAX // Store + MOV [EAX-skew].StrRec.length,ESI + MOV WORD PTR [EAX+ESI*2],0 // Null terminate + TEST EDI,EDI // Was a temp created? + JZ @@exit + PUSH EDI + MOV EAX,ESP + CALL _LStrClr + POP EDI + JMP @@exit + +@@overflow: + JMP _IntOver + +@@copyString: + MOV EAX,EDX // EAX := NewLength + CALL _NewUnicodeString + MOV EDI,EAX // EDI "Temp" := new string + + MOV EAX,[EBX] // EAX := S, also Source of Move + TEST EAX,EAX // nil? + JE @@setString // Assign straight away + + MOV EDX,EDI // EDX := EDI "Temp", also Dest of Move + MOV ECX,[EAX-skew].StrRec.length // ECX := Length(S), also Count of Move + CMP ECX,ESI // ECX "Length(S)" <> NewLength + JL @@moveString // ECX smaller => jump + MOV ECX,ESI // ECX := ESI + +@@moveString: + SHL ECX,1 // Length widechars to bytes translation + CALL Move // Move ECX chars from EAX to EDX + +@@setString: + MOV EAX,EBX // EAX := @S + CALL _LStrClr // clear S + MOV [EBX],EDI // S := Temp + +@@exit: + POP EDI + POP ESI + POP EBX +end; + +procedure _UStrCat(var Dest: UnicodeString; const Source: UnicodeString); +asm + { -> EAX pointer to dest } + { EDX source } + + TEST EDX,EDX // Source empty, nop. + JE @@exit + + MOV ECX,[EAX] // ECX := Dest + TEST ECX,ECX // Nil source => assignment + JE _UStrAsg + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX // EBX := @Dest + MOV ESI,EDX // ESI := Source + MOV EDI,[ECX-skew].StrRec.length // EDI := Length(Dest) + + MOV EDX,[ESI-skew].StrRec.length // EDX := Length(Source) + ADD EDX,EDI // EDX := (Length(Source) + Length(Dest)) * 2 + TEST EDX,$C0000000 + JNZ @@lengthOverflow + CMP ESI,ECX + JE @@appendSelf + + CALL _UStrSetLength // Set length of Dest + MOV EAX,ESI // EAX := Source + MOV ECX,[ESI-skew].StrRec.length // ECX := Length(Source) + +@@appendStr: + PUSH 0 // do this now because it usually won't be needed + CMP [ESI-skew].StrRec.elemSize,2 + JE @@noTemp + + MOV EDX,EAX // we need a real value here now, so put it in place + MOV EAX,ESP // reference it (var parameter) + CALL _UStrAsg // AddRef the string + MOV EAX,[ESP] + MOV ECX,[EAX-Skew].StrRec.length + +@@noTemp: + MOV EDX,[EBX] // EDX := Dest + SHL EDI,1 // EDI to bytes (Length(Dest) * 2) + ADD EDX,EDI // Offset EDX for destination of move + SHL ECX,1 // convert Length(Source) to bytes + CALL Move // Move(Source, Dest + Length(Dest)*2, Length(Source)*2) + MOV EAX,ESP // Need to clear out the temp we may have created above + MOV EDX,[EAX] + TEST EDX,EDX + JE @@tempEmpty + + CALL _LStrClr + +@@tempEmpty: + POP EAX + POP EDI + POP ESI + POP EBX + RET + +@@appendSelf: + CALL _UStrSetLength + MOV EAX,[EBX] + MOV ECX,EDI + PUSH 0 + JMP @@noTemp + +@@lengthOverflow: + JMP _IntOver + +@@exit: +end; + +procedure _UStrCat3(var Dest: UnicodeString; const Source1, Source2: UnicodeString); +asm + { ->EAX = Pointer to dest } + { EDX = source1 } + { ECX = source2 } + + TEST EDX,EDX + JE @@assignSource2 + + TEST ECX,ECX + JE _UStrAsg + + CMP EDX,[EAX] + JE @@appendToDest + + CMP ECX,[EAX] + JE @@theHardWay + + PUSH EAX + PUSH ECX + CALL _UStrAsg + + POP EDX + POP EAX + JMP _UStrCat + +@@theHardWay: // s(*EAX,ECX) := source1(EDX) + s(ECX) + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EDX // EBX := source1 + MOV ESI,ECX // ESI := source2 + PUSH EAX // Push(@s) + + MOV EAX,[EBX-skew].StrRec.length + ADD EAX,[ESI-skew].StrRec.length + + TEST EAX,$C0000000 // either of top two bits set => overflow for size + JNZ @@overflow + CALL _NewUnicodeString // EAX := new string ("result") + + MOV EDI,EAX // EDI := result + + PUSH 0 // Prepare for a possible temp + CMP [EBX-Skew].StrRec.elemSize,2 + JE @@source1IsUnicode + + MOV EDX,EBX + MOV EAX,ESP + CALL _UStrAsg // Assign to the temp and AddRef + MOV EAX,ESP + CALL EnsureUnicodeString // Convert it to Unicode + MOV EBX,[ESP] + +@@source1IsUnicode: + MOV EDX,EDI // EDX := result + MOV EAX,EBX // EAX := source1 + MOV ECX,[EBX-skew].StrRec.length // ECX := Length(source1) + SHL ECX,1 // double ECX for bytes + CALL Move // Move(source1, result, Length(source1)*2) + + CMP [ESI-Skew].StrRec.elemSize,2 + JE @@source2IsUnicode + + MOV EDX,ESI + MOV EAX,ESP + CALL _UStrAsg + MOV ESI,[ESP] + +@@source2IsUnicode: + MOV EAX,ESI // EAX := source2 + MOV ECX,[ESI-skew].StrRec.length // ECX := Length(source2) + SHL ECX,1 // ECX => to bytes + MOV EDX,[EBX-skew].StrRec.length // EDX := Length(source1) + SHL EDX,1 // EDX => to bytes + ADD EDX,EDI // EDX := result + (num bytes in source1) + CALL Move // Move(source2, result+offset, Length(source2)*2) + + MOV EAX,[ESP] // Check if there was a temp created + TEST EAX,EAX + JZ @@noTemp + MOV EAX,ESP + CALL _LStrClr // Call _LStrClr directly since _UStrClr jumps to it + +@@noTemp: + POP EAX // Remove the temp from the stack + POP EAX // EAX := Pop() // @s + MOV EDX,EDI // EDX := result + TEST EDI,EDI + JE @@skip // result is nil? => don't decrement + DEC [EDI-skew].StrRec.refCnt // EDI = local temp str; _UStrAsg will addref, so ensure final refCnt = 1 +@@skip: + CALL _UStrAsg + + POP EDI + POP ESI + POP EBX + + JMP @@exit + +@@assignSource2: + MOV EDX,ECX + JMP _UStrAsg + +@@appendToDest: + MOV EDX,ECX + JMP _UStrCat + +@@overflow: + JMP _IntOver + +@@exit: +end; + +procedure _UStrCatN{var dest:UnicodeString; argCnt: Integer; ...}; +asm + { ->EAX = Pointer to dest } + { EDX = number of args (>= 3) } + { [ESP+4], [ESP+8], ... argCnt UnicodeString arguments, reverse order } + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EDX + PUSH EAX + MOV EBX,EDX + + XOR EDI,EDI + MOV ECX,[ESP+EDX*4+5*4] // first arg is furthest out + TEST ECX,ECX + JZ @@0 + CMP [EAX],ECX // is dest = first arg? + JNE @@0 + MOV EDI,ECX // EDI nonzero -> potential appendstr case + MOV EAX,[ECX-skew].StrRec.length // EAX accumulates final length during @@loop1 + DEC EDX + JMP @@loop1 +@@0: + XOR EAX,EAX +@@loop1: + MOV ECX,[ESP+EDX*4+5*4] + TEST ECX,ECX + JE @@1 + ADD EAX,[ECX-skew].StrRec.length + TEST EAX,$C0000000 + JNZ @@overflow + CMP EDI,ECX // is dest an arg besides arg1? + JNE @@1 + XOR EDI,EDI // can't appendstr - dest is multiple args +@@1: + DEC EDX + JNE @@loop1 + +@@append: + TEST EDI,EDI // dest is 1st and only 1st arg? + JZ @@copy + MOV EDX,EAX // length into EDX + MOV EAX,[ESP] // ptr to str into EAX + MOV ESI,[EDI-skew].StrRec.Length // save old size before realloc + CALL _UStrSetLength + MOV EDI,[ESP] // append other strs to dest + PUSH [EDI] + SHL ESI,1 // Length to bytes for offset into string + ADD ESI,[EDI] // ESI = end of old string + DEC EBX + JMP @@loop2 + +@@copy: + CALL _NewUnicodeString + PUSH EAX + MOV ESI,EAX + +@@loop2: + // Loop invariants: + // - ESI is target of move, going through final dest + // - EBX is arg index in stack to get arguments; + // last argument pushed last => lowest address => addresses decrease from first to last + MOV EAX,[ESP+EBX*4+6*4] // EAX := argN + TEST EAX,EAX + JZ @@2 + PUSH 0 // Push a flag + CMP [EAX-Skew].StrRec.elemSize,2 + JE @@isUnicode + + MOV EAX,[ESP+EBX*4+7*4] + MOV ECX,[EAX-Skew].StrRec.refCnt + INC ECX + JLE @@isConstant + LOCK INC [EAX-Skew].StrRec.refCnt // This will ensure the "const" value isn't deallocted +@@isConstant: + LEA EAX,[ESP+EBX*4+7*4] + CALL EnsureUnicodeString + MOV EAX,[ESP+EBX*4+7*4] + MOV [ESP],1 // Set clear flag + +@@isUnicode: + MOV EDX,ESI // EDX := dest + TEST EAX,EAX // argN nil? + JE @@2 // => skip + MOV ECX,[EAX-skew].StrRec.length // ECX := Length(argN) + SHL ECX,1 // ECX to bytes + ADD ESI,ECX // ESI (running target of move) += ECX + CALL Move // Move(argN, dest, Length(argN) * 2) + + POP EAX // Check if the string was reallocated + TEST EAX,EAX + JZ @@2 + LEA EAX,[ESP+EBX*4+6*4] + CALL _LStrClr +@@2: + DEC EBX + JNE @@loop2 + + POP EDX + POP EAX + TEST EDI,EDI + JNZ @@exit + + TEST EDX,EDX + JE @@skip + DEC [EDX-skew].StrRec.refCnt // EDX = local temp str +@@skip: + CALL _UStrAsg + +@@exit: + POP EDX + POP EDI + POP ESI + POP EBX + POP EAX // ret address from CALL + LEA ESP,[ESP+EDX*4] + JMP EAX // Unbalanced CALL/RET means clobbered branch prediction. + // Should fix codegen and have caller pop arguments, like cdecl. + +@@overflow: + JMP _IntOver +end; + +procedure _UStrCmp{left, right: UnicodeString}; +asm +{ ->EAX = Pointer to left string } +{ EDX = Pointer to right string } + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH 0 + PUSH 0 + + MOV ESI,EAX + MOV EDI,EDX + + CMP EAX,EDX + JE @@exit + + TEST ESI,ESI + JE @@str1null + + TEST EDI,EDI + JE @@str2null + + CMP [ESI-Skew].StrRec.elemSize,2 + JE @@leftUnicode + + LEA EAX,[ESP] + MOV EDX,ESI + CALL _UStrFromLStr + MOV ESI,[ESP] + +@@leftUnicode: + CMP [EDI-Skew].StrRec.elemSize,2 + JE @@rightUnicode + + LEA EAX,[ESP + 4] + MOV EDX,EDI + CALL _UStrFromLStr + MOV EDI,[ESP + 4] + +@@rightUnicode: + MOV EAX,[ESI-4] + MOV EDX,[EDI-4] + + SUB EAX,EDX { eax = len1 - len2 } + JA @@skip1 { len1 > len2 (unsigned)? } + ADD EDX,EAX { edx = len2 + (len1 - len2) = len1 } + // edx := Min(len1, len2) +@@skip1: + PUSH EDX + SHR EDX,1 + JE @@cmpRest +@@longLoop: + MOV ECX,[ESI] + MOV EBX,[EDI] + CMP ECX,EBX + JNE @@misMatch + DEC EDX + JE @@cmpRestP4 + MOV ECX,[ESI+4] + MOV EBX,[EDI+4] + CMP ECX,EBX + JNE @@misMatch + ADD ESI,8 + ADD EDI,8 + DEC EDX + JNE @@longLoop + JMP @@cmpRest +@@cmpRestP4: + ADD ESI,4 + ADD EDI,4 +@@cmpRest: + POP EDX + AND EDX,1 + JE @@equal + + MOV CX,[ESI] + MOV BX,[EDI] + CMP CX,BX + JNE @@exit + +@@equal: + ADD EAX,EAX + JMP @@exit + +@@str1null: + MOV EDX,[EDI-4] + SUB EAX,EDX + JMP @@exit + +@@str2null: + MOV EAX,[ESI-4] + SUB EAX,EDX + JMP @@exit + +@@misMatch: + POP EDX + CMP CX,BX + JNE @@exit + SHR ECX,16 + SHR EBX,16 + CMP CX,BX + +@@exit: + LEA EAX,[ESP] + MOV EDX,2 + PUSHF + MOV ECX,[EAX] + OR ECX,[EAX + 4] + JZ @@NoClear + CALL _LStrArrayClr +@@NoClear: + POPF + POP EAX + POP EAX + POP EDI + POP ESI + POP EBX +end; + +// ZF used for result +procedure _UStrEqual{const Left, Right: UnicodeString}; +asm + JMP _UStrCmp +end; + +function _UStrCopy(const S: UnicodeString; Index, Count: Integer): UnicodeString; +var + L, N: Integer; +begin + L := Length(S); + if Index < 1 then Index := 0 else + begin + Dec(Index); + if Index > L then Index := L; + end; + if Count < 0 then N := 0 else + begin + N := L - Index; + if N > Count then N := Count; + end; + if StringElementSize(S) = SizeOf(WideChar) then + _UStrFromPWCharLen(Result, PWideChar(Pointer(S)) + Index, N) + else + _UStrFromPCharLen(Result, PAnsiChar(Pointer(S)) + Index, N); +end; + +procedure UStrSet(var S: UnicodeString; P: PWideChar); +{$IFDEF PUREPASCAL} +var + Temp: Pointer; +begin + Temp := Pointer(InterlockedExchange(Pointer(S), Pointer(P))); + if Temp <> nil then + _UStrClr(Temp); +end; +{$ELSE} +asm + XCHG [EAX],EDX + TEST EDX,EDX + JZ @@1 + PUSH EDX + MOV EAX,ESP + CALL _UStrClr + POP EAX +@@1: +end; +{$ENDIF} + +procedure _UStrDelete(var S: UnicodeString; Index, Count: Integer); +var + L, N: Integer; +begin + UniqueString(S); + L := Length(S); + if (Index >= 1) and (Index <= L) and (Count > 0) then + begin + Dec(Index); + N := L - Index - Count; + if N < 0 then + N := 0; + Move(PWideChar(Pointer(S))[L - N], PWideChar(Pointer(S))[Index], N * 2); + SetLength(S, Index + N); + end; +end; + +procedure _UStrInsert(const Source: UnicodeString; var Dest: UnicodeString; Index: Integer); +var + SourceLen, DestLen, NewLen: Integer; + SelfInsert: Boolean; +begin + SourceLen := Length(Source); + if SourceLen > 0 then + begin + DestLen := Length(Dest); + if Index < 1 then Index := 0 else + begin + Dec(Index); + if Index > DestLen then Index := DestLen; + end; + SelfInsert := (Pointer(Source) = Pointer(Dest)); + NewLen := DestLen + SourceLen; + if NewLen < 0 then // overflow check + _IntOver; + SetLength(Dest, NewLen); + if Index < DestLen then + Move(PWideChar(Pointer(Dest))[Index], PWideChar(Pointer(Dest))[Index + SourceLen], + (DestLen - Index) * 2); + if SelfInsert then + Move(Pointer(Dest)^, PWideChar(Pointer(Dest))[Index], SourceLen * 2) + else + Move(Pointer(Source)^, PWideChar(Pointer(Dest))[Index], SourceLen * 2); + end; +end; + + +{ 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; + +{X+} +const + advapi32 = 'advapi32.dll'; + kernel = 'kernel32.dll'; + user = 'user32.dll'; + oleaut = 'oleaut32.dll'; + +function GetProcessHeap; external kernel name 'GetProcessHeap'; +function HeapAlloc; stdcall; external kernel name 'HeapAlloc'; +function HeapReAlloc; stdcall; external kernel name 'HeapReAlloc'; +function HeapFree; stdcall; external kernel name 'HeapFree'; +{X-} + +{$IFDEF PIC} +function GetGOT: LongWord; export; +begin + asm + MOV Result,EBX + end; +end; +{$ENDIF} + +{$IFDEF PC_MAPPED_EXCEPTIONS} +const + UNWINDFI_TOPOFSTACK = $BE00EF00; + +{$IFDEF MSWINDOWS} +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'; +{$ENDIF} +{$IFDEF LINUX} +const + unwind = 'libborunwind.so.6'; +type + UNWINDPROC = Pointer; + +{$DEFINE STATIC_UNWIND} + +{$IFDEF STATIC_UNWIND} +function _BorUnwind_RegisterIPLookup(fn: UNWINDPROC; StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; cdecl; + external; + +procedure _BorUnwind_UnregisterIPLookup(StartAddr: LongInt); cdecl; external; + +function _BorUnwind_DelphiLookup(Addr: LongInt; Context: Pointer): UNWINDPROC; cdecl; external; + +function _BorUnwind_RaiseException(Exc: Pointer): LongBool; cdecl; external; + +//function _BorUnwind_AddressIsInPCMap(Addr: LongInt): LongBool; cdecl; external; +function _BorUnwind_ClosestDelphiHandler(Context: Pointer): LongWord; cdecl; external; +{$ELSE} + +function _BorUnwind_RegisterIPLookup(fn: UNWINDPROC; StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; cdecl; + external unwind name '_BorUnwind_RegisterIPLookup'; + +procedure _BorUnwind_UnregisterIPLookup(StartAddr: LongInt); cdecl; + external unwind name '_BorUnwind_UnregisterIPLookup'; + +function _BorUnwind_DelphiLookup(Addr: LongInt; Context: Pointer): UNWINDPROC; cdecl; + external unwind name '_BorUnwind_DelphiLookup'; + +function _BorUnwind_RaiseException(Exc: Pointer): LongBool; cdecl; + external unwind name '_BorUnwind_RaiseException'; + +function _BorUnwind_ClosestDelphiHandler(Context: Pointer): LongWord; cdecl; + external unwind name '_BorUnwind_ClosestDelphiHandler'; +{$ENDIF} +{$ENDIF} +{$ENDIF} + +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} + PRaisedException = ^TRaisedException; + TRaisedException = packed record + RefCount: Integer; + ExceptObject: TObject; + ExceptionAddr: Pointer; + HandlerEBP: LongWord; + Flags: LongWord; + 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 LINUX} +const + libc = 'libc.so.6'; + libdl = 'libdl.so.2'; + libpthread = 'libpthread.so.0'; + + O_RDONLY = $0000; + O_WRONLY = $0001; + O_RDWR = $0002; + O_CREAT = $0040; + O_EXCL = $0080; + O_NOCTTY = $0100; + O_TRUNC = $0200; + O_APPEND = $0400; + + // protection flags + S_IREAD = $0100; // Read by owner. + S_IWRITE = $0080; // Write by owner. + S_IEXEC = $0040; // Execute by owner. + S_IRUSR = S_IREAD; + S_IWUSR = S_IWRITE; + S_IXUSR = S_IEXEC; + S_IRWXU = S_IRUSR or S_IWUSR or S_IXUSR; + + S_IRGRP = S_IRUSR shr 3; // Read by group. + S_IWGRP = S_IWUSR shr 3; // Write by group. + S_IXGRP = S_IXUSR shr 3; // Execute by group. + S_IRWXG = S_IRWXU shr 3; // Read, write, and execute by group. + + S_IROTH = S_IRGRP shr 3; // Read by others. + S_IWOTH = S_IWGRP shr 3; // Write by others. + S_IXOTH = S_IXGRP shr 3; // Execute by others. + S_IRWXO = S_IRWXG shr 3; // Read, write, and execute by others. + + STDIN_FILENO = 0; + STDOUT_FILENO = 1; + STDERR_FILENO = 2; + + SEEK_SET = 0; + SEEK_CUR = 1; + SEEK_END = 2; + + LC_CTYPE = 0; + _NL_CTYPE_CODESET_NAME = LC_CTYPE shl 16 + 14; + + MAX_PATH = 4095; + + +function __open(PathName: PChar; Flags: Integer; Mode: Integer): Integer; cdecl; + external libc name 'open'; + +function __close(Handle: Integer): Integer; cdecl; + external libc name 'close'; + +function __read(Handle: Integer; Buffer: Pointer; Count: Cardinal): Cardinal; cdecl; + external libc name 'read'; + +function __write(Handle: Integer; Buffer: Pointer; Count: Cardinal): Cardinal; cdecl; + external libc name 'write'; + +function __mkdir(PathName: PChar; Mode: Integer): Integer; cdecl; + external libc name 'mkdir'; + +function __getcwd(Buffer: PChar; BufSize: Integer): PChar; cdecl; + external libc name 'getcwd'; + +function __getenv(Name: PChar): PChar; cdecl; + external libc name 'getenv'; + +function __chdir(PathName: PChar): Integer; cdecl; + external libc name 'chdir'; + +function __rmdir(PathName: PChar): Integer; cdecl; + external libc name 'rmdir'; + +function __remove(PathName: PChar): Integer; cdecl; + external libc name 'remove'; + +function __rename(OldPath, NewPath: PChar): Integer; cdecl; + external libc name 'rename'; + +{$IFDEF EFENCE} +function __malloc(Size: Integer): Pointer; cdecl; + external 'libefence.so' name 'malloc'; + +procedure __free(P: Pointer); cdecl; + external 'libefence.so' name 'free'; + +function __realloc(P: Pointer; Size: Integer): Pointer; cdecl; + external 'libefence.so' name 'realloc'; +{$ELSE} +function __malloc(Size: Integer): Pointer; cdecl; + external libc name 'malloc'; + +procedure __free(P: Pointer); cdecl; + external libc name 'free'; + +function __realloc(P: Pointer; Size: Integer): Pointer; cdecl; + external libc name 'realloc'; +{$ENDIF} + +procedure ExitProcess(status: Integer); cdecl; + external libc name 'exit'; + +function _time(P: Pointer): Integer; cdecl; + external libc name 'time'; + +function _lseek(Handle, Offset, Direction: Integer): Integer; cdecl; + external libc name 'lseek'; + +function _ftruncate(Handle: Integer; Filesize: Integer): Integer; cdecl; + external libc name 'ftruncate'; + +function strcasecmp(s1, s2: PChar): Integer; cdecl; + external libc name 'strcasecmp'; + +function __errno_location: PInteger; cdecl; + external libc name '__errno_location'; + +function nl_langinfo(item: integer): pchar; cdecl; + external libc name 'nl_langinfo'; + +function iconv_open(ToCode: PChar; FromCode: PChar): Integer; cdecl; + external libc name 'iconv_open'; + +function iconv(cd: Integer; var InBuf; var InBytesLeft: Integer; var OutBuf; var OutBytesLeft: Integer): Integer; cdecl; + external libc name 'iconv'; + +function iconv_close(cd: Integer): Integer; cdecl; + external libc name 'iconv_close'; + +function mblen(const S: PChar; N: LongWord): Integer; cdecl; + external libc name 'mblen'; + +function mmap(start: Pointer; length: Cardinal; prot, flags, fd, offset: Integer): Pointer; cdecl; + external libc name 'mmap'; + +function munmap(start: Pointer; length: Cardinal): Integer; cdecl; + external libc name 'munmap'; + +const + SIGABRT = 6; + +function __raise(SigNum: Integer): Integer; cdecl; + external libc name 'raise'; + +type + TStatStruct = record + st_dev: Int64; // device + __pad1: Word; + st_ino: Cardinal; // inode + st_mode: Cardinal; // protection + st_nlink: Cardinal; // number of hard links + st_uid: Cardinal; // user ID of owner + st_gid: Cardinal; // group ID of owner + st_rdev: Int64; // device type (if inode device) + __pad2: Word; + st_size: Cardinal; // total size, in bytes + st_blksize: Cardinal; // blocksize for filesystem I/O + st_blocks: Cardinal; // number of blocks allocated + st_atime: Integer; // time of last access + __unused1: Cardinal; + st_mtime: Integer; // time of last modification + __unused2: Cardinal; + st_ctime: Integer; // time of last change + __unused3: Cardinal; + __unused4: Cardinal; + __unused5: Cardinal; + end; + +const + STAT_VER_LINUX = 3; + +function _fxstat(Version: Integer; Handle: Integer; var Stat: TStatStruct): Integer; cdecl; + external libc name '__fxstat'; + +function __xstat(Ver: Integer; FileName: PChar; var StatBuffer: TStatStruct): Integer; cdecl; + external libc name '__xstat'; + +function _strlen(P: PChar): Integer; cdecl; + external libc name 'strlen'; + +function _readlink(PathName: PChar; Buf: PChar; Len: Integer): Integer; cdecl; + external libc name 'readlink'; + +type + TDLInfo = record + FileName: PChar; + BaseAddress: Pointer; + NearestSymbolName: PChar; + SymbolAddress: Pointer; + end; + +const + RTLD_LAZY = 1; + RTLD_NOW = 2; + +function dladdr(Address: Pointer; var Info: TDLInfo): Integer; cdecl; + external libdl name 'dladdr'; +function dlopen(Filename: PChar; Flag: Integer): LongWord; cdecl; + external libdl name 'dlopen'; +function dlclose(Handle: LongWord): Integer; cdecl; + external libdl name 'dlclose'; +function FreeLibrary(Handle: LongWord): Integer; cdecl; + external libdl name 'dlclose'; +function dlsym(Handle: LongWord; Symbol: PChar): Pointer; cdecl; + external libdl name 'dlsym'; +function dlerror: PChar; cdecl; + external libdl name 'dlerror'; + +type + TPthread_fastlock = record + __status: LongInt; + __spinlock: Integer; + end; + + TRTLCriticalSection = record + __m_reserved, + __m_count: Integer; + __m_owner: Pointer; + __m_kind: Integer; // __m_kind := 0 fastlock, __m_kind := 1 recursive lock + __m_lock: TPthread_fastlock; + end; + +function _pthread_mutex_lock(var Mutex: TRTLCriticalSection): Integer; cdecl; + external libpthread name 'pthread_mutex_lock'; +function _pthread_mutex_unlock(var Mutex: TRTLCriticalSection): Integer; cdecl; + external libpthread name 'pthread_mutex_unlock'; +function _pthread_create(var ThreadID: Cardinal; Attr: PThreadAttr; + TFunc: TThreadFunc; Arg: Pointer): Integer; cdecl; + external libpthread name 'pthread_create'; +function _pthread_exit(var RetVal: Integer): Integer; cdecl; + external libpthread name 'pthread_exit'; +function GetCurrentThreadID: LongWord; cdecl; + external libpthread name 'pthread_self'; +function _pthread_detach(ThreadID: Cardinal): Integer; cdecl; + external libpthread name 'pthread_detach' + +function GetLastError: Integer; +begin + Result := __errno_location^; +end; + +procedure SetLastError(ErrorCode: Integer); +begin + __errno_location^ := ErrorCode; +end; + +function InterlockedIncrement(var I: Integer): Integer; +asm + MOV EDX,1 + XCHG EAX,EDX + LOCK XADD [EDX],EAX + INC EAX +end; + +function InterlockedDecrement(var I: Integer): Integer; +asm + MOV EDX,-1 + XCHG EAX,EDX + LOCK XADD [EDX],EAX + DEC EAX +end; + +var + ModuleCacheVersion: Cardinal = 0; + +function ModuleCacheID: Cardinal; +begin + Result := ModuleCacheVersion; +end; + +procedure InvalidateModuleCache; +begin + InterlockedIncrement(Integer(ModuleCacheVersion)); +end; + +{$ENDIF} + +{$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 + 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; + +{X+ moved here from SysInit.pas - by advise of Alexey Torgashin - to avoid + creating of separate import block from kernel32.dll : } +////////////////////////////////////////////////////////////////////////// + +function FreeLibrary(ModuleHandle: Longint): LongBool; stdcall; + external kernel name 'FreeLibrary'; + +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 LocalAlloc(flags, size: Integer): Pointer; stdcall; + external kernel name 'LocalAlloc'; + +function LocalFree(addr: Pointer): Pointer; stdcall; + external kernel name 'LocalFree'; + +function TlsAlloc: Integer; stdcall; + external kernel name 'TlsAlloc'; + +function TlsFree(TlsIndex: Integer): Boolean; stdcall; + external kernel name 'TlsFree'; + +function TlsGetValue(TlsIndex: Integer): Pointer; stdcall; + external kernel name 'TlsGetValue'; + +function TlsSetValue(TlsIndex: Integer; TlsValue: Pointer): Boolean; stdcall; + external kernel name 'TlsSetValue'; + +function GetCommandLine: PChar; stdcall; + external kernel name 'GetCommandLineA'; +{X-}////////////////////////////////////////////////////////////////////// + + +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'; + +{X} //function FreeLibrary(ModuleHandle: Longint): LongBool; stdcall; +{X} // external kernel name 'FreeLibrary'; + +{X} //function GetCommandLine: PChar; stdcall; +{X} // 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'; + +{X} //function GetModuleFileName(Module: Integer; Filename: PChar; +{X} // Size: Integer): Integer; stdcall; +{X} // external kernel name 'GetModuleFileNameA'; + +{X} //function GetModuleHandle(ModuleName: PChar): Integer; stdcall; +{X} // 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 + SI: TStartupInfo; +begin + Result := 10; { SW_SHOWDEFAULT } + GetStartupInfo(SI); + if SI.dwFlags and 1 <> 0 then { STARTF_USESHOWWINDOW } + Result := SI.wShowWindow; +end; + +{$ENDIF} // MSWindows + +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} + + +//////////////////// This code is from HeapMM.pas, (C) by Vladimir Kladov, 2001 +const + HEAP_NO_SERIALIZE = $00001; + HEAP_GROWABLE = $00002; + HEAP_GENERATE_EXCEPTIONS = $00004; + HEAP_ZERO_MEMORY = $00008; + HEAP_REALLOC_IN_PLACE_ONLY = $00010; + HEAP_TAIL_CHECKING_ENABLED = $00020; + HEAP_FREE_CHECKING_ENABLED = $00040; + HEAP_DISABLE_COALESCE_ON_FREE = $00080; + HEAP_CREATE_ALIGN_16 = $10000; + HEAP_CREATE_ENABLE_TRACING = $20000; + HEAP_MAXIMUM_TAG = $00FFF; + HEAP_PSEUDO_TAG_FLAG = $08000; + HEAP_TAG_SHIFT = 16 ; + +{$DEFINE USE_PROCESS_HEAP} + +var + HeapHandle: THandle; + {* Global handle to the heap. Do not change it! } + + HeapFlags: DWORD = 0; + {* Possible flags are: + HEAP_GENERATE_EXCEPTIONS - system will raise an exception to indicate a + function failure, such as an out-of-memory + condition, instead of returning NULL. + HEAP_NO_SERIALIZE - mutual exclusion will not be used while the HeapAlloc + function is accessing the heap. Be careful! + Not recommended for multi-thread applications. + But faster. + HEAP_ZERO_MEMORY - obviously. (Slower!) + } + + { Note from MSDN: + The granularity of heap allocations in Win32 is 16 bytes. So if you + request a global memory allocation of 1 byte, the heap returns a pointer + to a chunk of memory, guaranteeing that the 1 byte is available. Chances + are, 16 bytes will actually be available because the heap cannot allocate + less than 16 bytes at a time. + } + +function DfltGetMem(size: Integer): Pointer; +// Allocate memory block. +begin + Result := HeapAlloc( HeapHandle, HeapFlags, size ); +end; + +function DfltFreeMem(p: Pointer): Integer; +// Deallocate memory block. +begin + Result := Integer( not HeapFree( HeapHandle, HeapFlags and HEAP_NO_SERIALIZE, + p ) ); +end; + +function DfltReallocMem(p: Pointer; size: Integer): Pointer; +// Resize memory block. +begin + Result := HeapRealloc( HeapHandle, HeapFlags and (HEAP_NO_SERIALIZE and + HEAP_GENERATE_EXCEPTIONS and HEAP_ZERO_MEMORY), + // (Prevent using flag HEAP_REALLOC_IN_PLACE_ONLY here - to allow + // system to move the block if necessary). + p, size ); +end; + +//////////////////////////////////////////// end of HeapMM + + +{$IFDEF LINUX} +function SysGetMem(Size: Integer): Pointer; +begin + Result := __malloc(size); +end; + +function SysFreeMem(P: Pointer): Integer; +begin + __free(P); + Result := 0; +end; + +function SysReallocMem(P: Pointer; Size: Integer): Pointer; +begin + Result := __realloc(P, Size); +end; + +{$ENDIF} + +{X- by default, system memory allocation routines (API calls) + are used. To use Inprise's memory manager (Delphi standard) + call UseDelphiMemoryManager procedure. } +var + MemoryManager: TMemoryManager = ( + GetMem: DfltGetMem; + FreeMem: DfltFreeMem; + ReallocMem: DfltReallocMem); + +const + DelphiMemoryManager: TMemoryManager = ( + GetMem: SysGetMem; + FreeMem: SysFreeMem; + ReallocMem: SysReallocMem); + +procedure UseDelphiMemoryManager; +begin + IsMemoryManagerSet := IsDelphiMemoryManagerSet; + SetMemoryManager( DelphiMemoryManager ); +end; +{X+} + + +{$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 debug_init; external; +procedure debug_print; external; +procedure debug_class_enabled; external; +procedure debug_continue; external; +{$ENDIF} +{$ENDIF} + +{X}{$IFDEF MSWINDOWS} +{X}function _GetMem(Size: Integer): Pointer; +{X}asm +{X} TEST EAX,EAX +{X} JE @@1 +{X} CALL MemoryManager.GetMem +{X} OR EAX,EAX +{X} JE @@2 +{X}@@1: RET +{X}@@2: MOV AL,reOutOfMemory +{X} JMP Error +{X}end; +{X}{$ELSE} +function _GetMem(Size: Integer): Pointer; +{$IF Defined(DEBUG) and Defined(LINUX)} +var + Signature: PLongInt; +{$IFEND} +begin + if Size > 0 then + begin +{$IF Defined(DEBUG) and Defined(LINUX)} + Signature := PLongInt(MemoryManager.GetMem(Size + 4)); + if Signature = nil then + Error(reOutOfMemory); + Signature^ := 0; + Result := Pointer(LongInt(Signature) + 4); +{$ELSE} + Result := MemoryManager.GetMem(Size); + if Result = nil then + Error(reOutOfMemory); +{$IFEND} + end + else + Result := nil; +end; +{X}{$ENDIF MSWINDOWS} + + +const + FreeMemorySignature = Longint($FBEEFBEE); + +{X}{$IFDEF MSWINDOWS} +{X}function _FreeMem(P: Pointer): Integer; +{X}asm +{X} TEST EAX,EAX +{X} JE @@1 +{X} CALL MemoryManager.FreeMem +{X} OR EAX,EAX +{X} JNE @@2 +{X}@@1: RET +{X}@@2: MOV AL,reInvalidPtr +{X} JMP Error +{X}end; +{X}{$ELSE} +function _FreeMem(P: Pointer): Integer; +{$IF Defined(DEBUG) and Defined(LINUX)} +var + Signature: PLongInt; +{$IFEND} +begin + if P <> nil then + begin +{$IF Defined(DEBUG) and Defined(LINUX)} + Signature := PLongInt(LongInt(P) - 4); + if Signature^ <> 0 then + Error(reInvalidPtr); + Signature^ := FreeMemorySignature; + Result := MemoryManager.Freemem(Pointer(Signature)); +{$ELSE} + Result := MemoryManager.FreeMem(P); +{$IFEND} + if Result <> 0 then + Error(reInvalidPtr); + end + else + Result := 0; +end; +{X}{$ENDIF MSWINDOWS} + +{$IFDEF LINUX} +function _ReallocMem(var P: Pointer; NewSize: Integer): Pointer; +{$IFDEF DEBUG} +var + Temp: Pointer; +{$ENDIF} +begin + if P <> nil then + begin +{$IFDEF DEBUG} + Temp := Pointer(LongInt(P) - 4); + if NewSize > 0 then + begin + Temp := MemoryManager.ReallocMem(Temp, NewSize + 4); + Result := Pointer(LongInt(Temp) + 4); + end + else + begin + MemoryManager.FreeMem(Temp); + Result := nil; + end; +{$ELSE} + if NewSize > 0 then + begin + Result := MemoryManager.ReallocMem(P, NewSize); + end + else + begin + MemoryManager.FreeMem(P); + Result := nil; + end; +{$ENDIF} + P := Result; + end else + begin + Result := _GetMem(NewSize); + P := Result; + end; +end; +{$ELSEIF Defined(MSWINDOWS)} +function _ReallocMem(var P: Pointer; NewSize: Integer): Pointer; +asm + MOV ECX,[EAX] + TEST ECX,ECX + JE @@alloc + TEST EDX,EDX + JE @@free +@@resize: + PUSH EAX + MOV EAX,ECX + CALL MemoryManager.ReallocMem + POP ECX + OR EAX,EAX + JE @@allocError + MOV [ECX],EAX + RET +@@freeError: + MOV AL,reInvalidPtr + JMP Error +@@free: + MOV [EAX],EDX + MOV EAX,ECX + CALL MemoryManager.FreeMem + OR EAX,EAX + JNE @@freeError + RET +@@allocError: + MOV AL,reOutOfMemory + JMP Error +@@alloc: + TEST EDX,EDX + JE @@exit + PUSH EAX + MOV EAX,EDX + CALL MemoryManager.GetMem + POP ECX + OR EAX,EAX + JE @@allocError + MOV [ECX],EAX +@@exit: +end; +{$IFEND} + +procedure GetMemoryManager(var MemMgr: TMemoryManager); +begin + MemMgr := MemoryManager; +end; + +procedure SetMemoryManager(const MemMgr: TMemoryManager); +begin + MemoryManager := MemMgr; +end; + +//{X} - function is replaced with pointer to one. +// function IsMemoryManagerSet: Boolean; +function IsDelphiMemoryManagerSet: Boolean; +begin + with MemoryManager do + Result := (@GetMem <> @SysGetMem) or (@FreeMem <> @SysFreeMem) or + (@ReallocMem <> @SysReallocMem); +end; + +{X+ always returns False. Initial handler for IsMemoryManagerSet } +function MemoryManagerNotUsed : Boolean; +begin + Result := False; +end; +{X-} + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure GetUnwinder(var Dest: TUnwinder); +begin + Dest := Unwinder; +end; + +procedure SetUnwinder(const NewUnwinder: TUnwinder); +begin + Unwinder := NewUnwinder; +end; + +function IsUnwinderSet: Boolean; +begin + with Unwinder do + Result := (@RaiseException <> @_BorUnwind_RaiseException) or + (@RegisterIPLookup <> @_BorUnwind_RegisterIPLookup) or + (@UnregisterIPLookup <> @_BorUnwind_UnregisterIPLookup) or + (@DelphiLookup <> @_BorUnwind_DelphiLookup); +end; + +procedure InitUnwinder; +var + Addr: Pointer; +begin + { + We look to see if we can find a dynamic version of the unwinder. This will + be the case if the application used Unwind.pas. If it is present, then we + fire it up. Otherwise, we use our static copy. + } + Addr := dlsym(0, '_BorUnwind_RegisterIPLookup'); + if Addr <> nil then + begin + Unwinder.RegisterIPLookup := Addr; + Addr := dlsym(0, '_BorUnwind_UnregisterIPLookup'); + Unwinder.UnregisterIPLookup := Addr; + Addr := dlsym(0, '_BorUnwind_RaiseException'); + Unwinder.RaiseException := Addr; + Addr := dlsym(0, '_BorUnwind_DelphiLookup'); + Unwinder.DelphiLookup := Addr; + Addr := dlsym(0, '_BorUnwind_ClosestHandler'); + Unwinder.ClosestHandler := Addr; + end + else + begin + dlerror; // clear error state; dlsym doesn't + Unwinder.RegisterIPLookup := _BorUnwind_RegisterIPLookup; + Unwinder.DelphiLookup := _BorUnwind_DelphiLookup; + Unwinder.UnregisterIPLookup := _BorUnwind_UnregisterIPLookup; + Unwinder.RaiseException := _BorUnwind_RaiseException; + Unwinder.ClosestHandler := _BorUnwind_ClosestDelphiHandler; + end; +end; + +function SysClosestDelphiHandler(Context: Pointer): LongWord; +begin + if not Assigned(Unwinder.ClosestHandler) then + InitUnwinder; + Result := Unwinder.ClosestHandler(Context); +end; + +function SysRegisterIPLookup(StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; +begin +// xxx + if not Assigned(Unwinder.RegisterIPLookup) then + begin + InitUnwinder; +// Unwinder.RegisterIPLookup := UnwindRegisterIPLookup; +// Unwinder.DelphiLookup := UnwindDelphiLookup; + end; + Result := Unwinder.RegisterIPLookup(@Unwinder.DelphiLookup, StartAddr, EndAddr, Context, GOT); +end; + +procedure SysUnregisterIPLookup(StartAddr: LongInt); +begin +// if not Assigned(Unwinder.UnregisterIPLookup) then +// Unwinder.UnregisterIPLookup := UnwindUnregisterIPLookup; + Unwinder.UnregisterIPLookup(StartAddr); +end; + +function SysRaiseException(Exc: Pointer): LongBool; export; +begin +// if not Assigned(Unwinder.RaiseException) then +// Unwinder.RaiseException := UnwindRaiseException; + Result := Unwinder.RaiseException(Exc); +end; + +const + MAX_NESTED_EXCEPTIONS = 16; +{$ENDIF} + +threadvar +{$IFDEF PC_MAPPED_EXCEPTIONS} + ExceptionObjects: array[0..MAX_NESTED_EXCEPTIONS-1] of TRaisedException; + ExceptionObjectCount: Integer; + OSExceptionsBlocked: Integer; +{$ELSE} + RaiseListPtr: pointer; +{$ENDIF} + InOutRes: Integer; + +{$IFDEF PUREPASCAL} +var + notimpl: array [0..15] of Char = 'not implemented'#10; + +procedure NotImplemented; +begin + __write (2, @notimpl, 16); + Halt; +end; +{$ENDIF} + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure BlockOSExceptions; +asm + PUSH EAX + PUSH EDX + CALL SysInit.@GetTLS + MOV [EAX].OSExceptionsBlocked, 1 + POP EDX + POP EAX +end; + +procedure UnblockOSExceptions; +asm + PUSH EAX + CALL SysInit.@GetTLS + MOV [EAX].OSExceptionsBlocked, 0 + POP EAX +end; + +function AreOSExceptionsBlocked: Boolean; +asm + CALL SysInit.@GetTLS + MOV EAX, [EAX].OSExceptionsBlocked +end; + +const + TRAISEDEXCEPTION_SIZE = SizeOf(TRaisedException); + +function CurrentException: PRaisedException; +asm + CALL SysInit.@GetTLS + LEA EDX, [EAX].ExceptionObjects + MOV EAX, [EAX].ExceptionObjectCount + OR EAX, EAX + JE @@Done + DEC EAX + IMUL EAX, TRAISEDEXCEPTION_SIZE + ADD EAX, EDX +@@Done: +end; + +function AllocateException(Exception: Pointer; ExceptionAddr: Pointer): PRaisedException; +asm + PUSH EAX + PUSH EDX + CALL SysInit.@GetTLS + CMP [EAX].ExceptionObjectCount, MAX_NESTED_EXCEPTIONS-1 + JE @@TooManyNestedExceptions + INC [EAX].ExceptionObjectCount + CALL CurrentException + POP EDX + POP ECX + MOV [EAX].TRaisedException.ExceptObject, ECX + MOV [EAX].TRaisedException.ExceptionAddr, EDX + MOV [EAX].TRaisedException.RefCount, 0 + MOV [EAX].TRaisedException.HandlerEBP, $FFFFFFFF + MOV [EAX].TRaisedException.Flags, 0 + RET +@@TooManyNestedExceptions: + MOV EAX, 231 + JMP _RunError +end; + +{ + 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; +asm + CALL CurrentException + OR EAX, EAX + JE @@Error + { EAX -> the TRaisedException } + XOR ECX, ECX + { If the exception object has been referenced, we don't return it. } + CMP [EAX].TRaisedException.RefCount, 0 + JA @@GotObject + MOV ECX, [EAX].TRaisedException.ExceptObject +@@GotObject: + PUSH ECX + CALL SysInit.@GetTLS + POP ECX + DEC [EAX].ExceptionObjectCount + MOV EAX, ECX + RET +@@Error: + { Some kind of internal error } + JMP _Run0Error +end; + +function AcquireExceptionObject: Pointer; +asm + CALL CurrentException + OR EAX, EAX + JE @@Error + INC [EAX].TRaisedException.RefCount + MOV EAX, [EAX].TRaisedException.ExceptObject + RET +@@Error: + { This happens if there is no exception pending } + JMP _Run0Error +end; + +procedure ReleaseExceptionObject; +asm + CALL CurrentException + OR EAX, EAX + JE @@Error + CMP [EAX].TRaisedException.RefCount, 0 + JE @@Error + DEC [EAX].TRaisedException.RefCount + RET +@@Error: + +{ + This happens if there is no exception pending, or + if the reference count on a pending exception is + zero. +} + JMP _Run0Error +end; + +function ExceptObject: TObject; +var + Exc: PRaisedException; +begin + Exc := CurrentException; + if Exc <> nil then + Result := TObject(Exc^.ExceptObject) + else + Result := nil; +end; + +{ Return current exception address } + +function ExceptAddr: Pointer; +var + Exc: PRaisedException; +begin + Exc := CurrentException; + if Exc <> nil then + Result := Exc^.ExceptionAddr + else + Result := nil; +end; +{$ELSE} {not PC_MAPPED_EXCEPTIONS} + +function ExceptObject: TObject; +begin + if RaiseListPtr <> nil then + Result := PRaiseFrame(RaiseListPtr)^.ExceptObject + else + Result := nil; +end; + +{ Return current exception address } + +function ExceptAddr: Pointer; +begin + if RaiseListPtr <> nil then + Result := PRaiseFrame(RaiseListPtr)^.ExceptAddr + else + Result := nil; +end; + + +function AcquireExceptionObject: Pointer; +begin + if RaiseListPtr <> nil then + begin + Result := PRaiseFrame(RaiseListPtr)^.ExceptObject; + PRaiseFrame(RaiseListPtr)^.ExceptObject := nil; + end + else + Result := nil; +end; + +procedure ReleaseExceptionObject; +begin +end; + +function RaiseList: Pointer; +begin + Result := RaiseListPtr; +end; + +function SetRaiseList(NewPtr: Pointer): Pointer; +asm + PUSH EAX + CALL SysInit.@GetTLS + MOV EDX, [EAX].RaiseListPtr + POP [EAX].RaiseListPtr + MOV EAX, EDX +end; +{$ENDIF} + +{ ----------------------------------------------------- } +{ local functions & procedures of the system unit } +{ ----------------------------------------------------- } + +procedure RunErrorAt(ErrCode: Integer; ErrorAtAddr: Pointer); +begin + ErrorAddr := ErrorAtAddr; + _Halt(ErrCode); +end; + +procedure ErrorAt(ErrorCode: Byte; ErrorAddr: Pointer); + +const + reMap: array [TRunTimeError] of Byte = ( + 0, + 203, { reOutOfMemory } + 204, { reInvalidPtr } + 200, { reDivByZero } + 201, { reRangeError } +{ 210 abstract error } + 215, { reIntOverflow } + 207, { reInvalidOp } + 200, { reZeroDivide } + 205, { reOverflow } + 206, { reUnderflow } + 219, { reInvalidCast } + 216, { Access violation } + 202, { Stack overflow } + 217, { Control-C } + 218, { Privileged instruction } + 220, { Invalid variant type cast } + 221, { Invalid variant operation } + 222, { No variant method call dispatcher } + 223, { Cannot create variant array } + 224, { Variant does not contain an array } + 225, { Variant array bounds error } +{ 226 thread init failure } + 227, { reAssertionFailed } + 0, { reExternalException not used here; in SysUtils } + 228, { reIntfCastError } + 229 { reSafeCallError } +{ 230 Reserved by the compiler for unhandled exceptions } +{ 231 Too many nested exceptions } +{ 232 Fatal signal raised on a non-Delphi thread }); + +begin + errorCode := errorCode and 127; + if Assigned(ErrorProc) then + ErrorProc(errorCode, ErrorAddr); + if errorCode = 0 then + errorCode := InOutRes + else if errorCode <= Byte(High(TRuntimeError)) then + errorCode := reMap[TRunTimeError(errorCode)]; + RunErrorAt(errorCode, ErrorAddr); +end; + +procedure Error(errorCode: TRuntimeError); +asm + AND EAX,127 + MOV EDX,[ESP] + JMP ErrorAt +end; + +procedure __IOTest; +asm + PUSH EAX + PUSH EDX + PUSH ECX + CALL SysInit.@GetTLS + CMP [EAX].InOutRes,0 + POP ECX + POP EDX + POP EAX + JNE @error + RET +@error: + XOR EAX,EAX + JMP Error +end; + +procedure SetInOutRes(NewValue: Integer); +begin + InOutRes := NewValue; +end; + +procedure InOutError; +begin + SetInOutRes(GetLastError); +end; + +procedure ChDir(const S: string); +begin + ChDir(PChar(S)); +end; + +procedure ChDir(P: PChar); +begin +{$IFDEF MSWINDOWS} + if not SetCurrentDirectory(P) then +{$ENDIF} +{$IFDEF LINUX} + if __chdir(P) <> 0 then +{$ENDIF} + InOutError; +end; + +procedure _Copy{ s : ShortString; index, count : Integer ) : ShortString}; +asm +{ ->EAX Source string } +{ EDX index } +{ ECX count } +{ [ESP+4] Pointer to result string } + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,[ESP+8+4] + + XOR EAX,EAX + OR AL,[ESI] + JZ @@srcEmpty + +{ limit index to satisfy 1 <= index <= Length(src) } + + TEST EDX,EDX + JLE @@smallInx + CMP EDX,EAX + JG @@bigInx +@@cont1: + +{ limit count to satisfy 0 <= count <= Length(src) - index + 1 } + + SUB EAX,EDX { calculate Length(src) - index + 1 } + INC EAX + TEST ECX,ECX + JL @@smallCount + CMP ECX,EAX + JG @@bigCount +@@cont2: + + ADD ESI,EDX + + MOV [EDI],CL + INC EDI + REP MOVSB + JMP @@exit + +@@smallInx: + MOV EDX,1 + JMP @@cont1 +@@bigInx: +{ MOV EDX,EAX + JMP @@cont1 } +@@smallCount: + XOR ECX,ECX + JMP @@cont2 +@@bigCount: + MOV ECX,EAX + JMP @@cont2 +@@srcEmpty: + MOV [EDI],AL +@@exit: + POP EDI + POP ESI + RET 4 +end; + +procedure _Delete{ var s : openstring; index, count : Integer }; +asm +{ ->EAX Pointer to s } +{ EDX index } +{ ECX count } + + PUSH ESI + PUSH EDI + + MOV EDI,EAX + + XOR EAX,EAX + MOV AL,[EDI] + +{ if index not in [1 .. Length(s)] do nothing } + + TEST EDX,EDX + JLE @@exit + CMP EDX,EAX + JG @@exit + +{ limit count to [0 .. Length(s) - index + 1] } + + TEST ECX,ECX + JLE @@exit + SUB EAX,EDX { calculate Length(s) - index + 1 } + INC EAX + CMP ECX,EAX + JLE @@1 + MOV ECX,EAX +@@1: + SUB [EDI],CL { reduce Length(s) by count } + ADD EDI,EDX { point EDI to first char to be deleted } + LEA ESI,[EDI+ECX] { point ESI to first char to be preserved } + SUB EAX,ECX { #chars = Length(s) - index + 1 - count } + MOV ECX,EAX + + REP MOVSB + +@@exit: + POP EDI + POP ESI +end; + +procedure _LGetDir(D: Byte; var S: string); +{$IFDEF MSWINDOWS} +var + Drive: array[0..3] of Char; + DirBuf, SaveBuf: array[0..MAX_PATH] of Char; +begin + if D <> 0 then + begin + Drive[0] := Chr(D + Ord('A') - 1); + Drive[1] := ':'; + Drive[2] := #0; + GetCurrentDirectory(SizeOf(SaveBuf), SaveBuf); + SetCurrentDirectory(Drive); + end; + GetCurrentDirectory(SizeOf(DirBuf), DirBuf); + if D <> 0 then SetCurrentDirectory(SaveBuf); + S := DirBuf; +{$ENDIF} +{$IFDEF LINUX} +var + DirBuf: array[0..MAX_PATH] of Char; +begin + __getcwd(DirBuf, sizeof(DirBuf)); + S := string(DirBuf); +{$ENDIF} +end; + +procedure _SGetDir(D: Byte; var S: ShortString); +var + L: string; +begin + _LGetDir(D, L); + S := L; +end; + +procedure _Insert{ source : ShortString; var s : openstring; index : Integer }; +asm +{ ->EAX Pointer to source string } +{ EDX Pointer to destination string } +{ ECX Length of destination string } +{ [ESP+4] Index } + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH ECX + MOV ECX,[ESP+16+4] + SUB ESP,512 { VAR buf: ARRAY [0..511] of Char } + + MOV EBX,EDX { save pointer to s for later } + MOV ESI,EDX + + XOR EDX,EDX + MOV DL,[ESI] + INC ESI + +{ limit index to [1 .. Length(s)+1] } + + INC EDX + TEST ECX,ECX + JLE @@smallInx + CMP ECX,EDX + JG @@bigInx +@@cont1: + DEC EDX { EDX = Length(s) } + { EAX = Pointer to src } + { ESI = EBX = Pointer to s } + { ECX = Index } + +{ copy index-1 chars from s to buf } + + MOV EDI,ESP + DEC ECX + SUB EDX,ECX { EDX = remaining length of s } + REP MOVSB + +{ copy Length(src) chars from src to buf } + + XCHG EAX,ESI { save pointer into s, point ESI to src } + MOV CL,[ESI] { ECX = Length(src) (ECX was zero after rep) } + INC ESI + REP MOVSB + +{ copy remaining chars of s to buf } + + MOV ESI,EAX { restore pointer into s } + MOV ECX,EDX { copy remaining bytes of s } + REP MOVSB + +{ calculate total chars in buf } + + SUB EDI,ESP { length = bufPtr - buf } + MOV ECX,[ESP+512] { ECX = Min(length, destLength) } +{ MOV ECX,[EBP-16] }{ ECX = Min(length, destLength) } + CMP ECX,EDI + JB @@1 + MOV ECX,EDI +@@1: + MOV EDI,EBX { Point EDI to s } + MOV ESI,ESP { Point ESI to buf } + MOV [EDI],CL { Store length in s } + INC EDI + REP MOVSB { Copy length chars to s } + JMP @@exit + +@@smallInx: + MOV ECX,1 + JMP @@cont1 +@@bigInx: + MOV ECX,EDX + JMP @@cont1 + +@@exit: + ADD ESP,512+4 + POP EDI + POP ESI + POP EBX + RET 4 +end; + +function IOResult: Integer; +begin + Result := InOutRes; + InOutRes := 0; +end; + +procedure MkDir(const S: string); +begin + MkDir(PChar(s)); +end; + +procedure MkDir(P: PChar); +begin +{$IFDEF MSWINDOWS} + if not CreateDirectory(P, 0) then +{$ENDIF} +{$IFDEF LINUX} + if __mkdir(P, -1) <> 0 then +{$ENDIF} + InOutError; +end; + +procedure Move( const Source; var Dest; count : Integer ); +{$IFDEF PUREPASCAL} +var + S, D: PChar; + I: Integer; +begin + S := PChar(@Source); + D := PChar(@Dest); + if S = D then Exit; + if Cardinal(D) > Cardinal(S) then + for I := count-1 downto 0 do + D[I] := S[I] + else + for I := 0 to count-1 do + D[I] := S[I]; +end; +{$ELSE} +asm +{ ->EAX Pointer to source } +{ EDX Pointer to destination } +{ ECX Count } + +(*{X-} // original code. + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + MOV EAX,ECX + + CMP EDI,ESI + JA @@down + JE @@exit + + SAR ECX,2 { copy count DIV 4 dwords } + JS @@exit + + REP MOVSD + + MOV ECX,EAX + AND ECX,03H + REP MOVSB { copy count MOD 4 bytes } + JMP @@exit + +@@down: + LEA ESI,[ESI+ECX-4] { point ESI to last dword of source } + LEA EDI,[EDI+ECX-4] { point EDI to last dword of dest } + + SAR ECX,2 { copy count DIV 4 dwords } + JS @@exit + STD + REP MOVSD + + MOV ECX,EAX + AND ECX,03H { copy count MOD 4 bytes } + ADD ESI,4-1 { point to last byte of rest } + ADD EDI,4-1 + REP MOVSB + CLD +@@exit: + POP EDI + POP ESI +*){X+} +//--------------------------------------- +(* {X+} // Let us write smaller: + JCXZ @@fin + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + MOV EAX,ECX + + AND ECX,3 { copy count mod 4 dwords } + + CMP EDI,ESI + JE @@exit + JA @@up + +//down: + LEA ESI,[ESI+EAX-1] { point ESI to last byte of source } + LEA EDI,[EDI+EAX-1] { point EDI to last byte of dest } + STD + + CMP EAX, 4 + JL @@up + ADD ECX, 3 { move 3 bytes more to correct pos } + +@@up: + REP MOVSB + + SAR EAX, 2 + JS @@exit + + MOV ECX, EAX + REP MOVSD + +@@exit: + CLD + POP EDI + POP ESI + +@@fin: +*) {X-} +//--------------------------------------- +{X+} // And now, let us write speedy: + CMP ECX, 4 + JGE @@long + JCXZ @@fin + + CMP EAX, EDX + JE @@fin + + PUSH ESI + PUSH EDI + MOV ESI, EAX + MOV EDI, EDX + JA @@short_up + + LEA ESI,[ESI+ECX-1] { point ESI to last byte of source } + LEA EDI,[EDI+ECX-1] { point EDI to last byte of dest } + STD + +@@short_up: + REP MOVSB + JMP @@exit_up + +@@long: + CMP EAX, EDX + JE @@fin + + PUSH ESI + PUSH EDI + MOV ESI, EAX + MOV EDI, EDX + MOV EAX, ECX + + JA @@long_up + + { + SAR ECX, 2 + JS @@exit + + LEA ESI,[ESI+EAX-4] + LEA EDI,[EDI+EAX-4] + STD + REP MOVSD + + MOV ECX, EAX + MOV EAX, 3 + AND ECX, EAX + ADD ESI, EAX + ADD EDI, EAX + REP MOVSB + } // let's do it in other order - faster if data are aligned... + + AND ECX, 3 + LEA ESI,[ESI+EAX-1] + LEA EDI,[EDI+EAX-1] + STD + REP MOVSB + + SAR EAX, 2 + //JS @@exit // why to test this? but what does PC do? + MOV ECX, EAX + MOV EAX, 3 + SUB ESI, EAX + SUB EDI, EAX + REP MOVSD + +@@exit_up: + CLD + //JMP @@exit + DEC ECX // the same - loosing 2 tacts... but conveyer! + +@@long_up: + SAR ECX, 2 + JS @@exit + + REP MOVSD + + AND EAX, 3 + MOV ECX, EAX + REP MOVSB + +@@exit: + POP EDI + POP ESI + +@@fin: +{X-} +end; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function GetParamStr(P: PChar; var Param: string): PChar; +var + i, Len: Integer; + Start, S, Q: PChar; +begin + while True do + begin + while (P[0] <> #0) and (P[0] <= ' ') do + P := CharNext(P); + if (P[0] = '"') and (P[1] = '"') then Inc(P, 2) else Break; + end; + Len := 0; + Start := P; + while P[0] > ' ' do + begin + if P[0] = '"' then + begin + P := CharNext(P); + while (P[0] <> #0) and (P[0] <> '"') do + begin + Q := CharNext(P); + Inc(Len, Q - P); + P := Q; + end; + if P[0] <> #0 then + P := CharNext(P); + end + else + begin + Q := CharNext(P); + Inc(Len, Q - P); + P := Q; + end; + end; + + SetLength(Param, Len); + + P := Start; + S := Pointer(Param); + i := 0; + while P[0] > ' ' do + begin + if P[0] = '"' then + begin + P := CharNext(P); + while (P[0] <> #0) and (P[0] <> '"') do + begin + Q := CharNext(P); + while P < Q do + begin + S[i] := P^; + Inc(P); + Inc(i); + end; + end; + if P[0] <> #0 then P := CharNext(P); + end + else + begin + Q := CharNext(P); + while P < Q do + begin + S[i] := P^; + Inc(P); + Inc(i); + end; + end; + end; + + Result := P; +end; +{$ENDIF} + +function ParamCount: Integer; +{$IFDEF MSWINDOWS} +var + P: PChar; + S: string; +begin + Result := 0; + P := GetParamStr(GetCommandLine, S); + while True do + begin + P := GetParamStr(P, S); + if S = '' then Break; + Inc(Result); + end; +{$ENDIF} +{$IFDEF LINUX} +begin + if ArgCount > 1 then + Result := ArgCount - 1 + else Result := 0; +{$ENDIF} +end; + +type + PCharArray = array[0..0] of PChar; + +function ParamStr(Index: Integer): string; +{$IFDEF MSWINDOWS} +var + P: PChar; + Buffer: array[0..260] of Char; +begin + Result := ''; + if Index = 0 then + SetString(Result, Buffer, GetModuleFileName(0, Buffer, SizeOf(Buffer))) + else + begin + P := GetCommandLine; + while True do + begin + P := GetParamStr(P, Result); + if (Index = 0) or (Result = '') then Break; + Dec(Index); + end; + end; +{$ENDIF} +{$IFDEF LINUX} +begin + if Index < ArgCount then + Result := PCharArray(ArgValues^)[Index] + else + Result := ''; +{$ENDIF} +end; + +function Pos(const substr, str: AnsiString): Integer; overload; +asm + push ebx + push esi + add esp, -16 + test edx, edx + jz @NotFound + test eax, eax + jz @NotFound + mov esi, [edx-4] //Length(Str) + mov ebx, [eax-4] //Length(Substr) + cmp esi, ebx + jl @NotFound + test ebx, ebx + jle @NotFound + dec ebx + add esi, edx + add edx, ebx + mov [esp+8], esi + add eax, ebx + mov [esp+4], edx + neg ebx + movzx ecx, byte ptr [eax] + mov [esp], ebx + jnz @FindString + + sub esi, 2 + mov [esp+12], esi + +@FindChar2: + cmp cl, [edx] + jz @Matched0ch + cmp cl, [edx+1] + jz @Matched1ch + add edx, 2 + cmp edx, [esp+12] + jb @FindChar4 + cmp edx, [esp+8] + jb @FindChar2 +@NotFound: + xor eax, eax + jmp @Exit0ch + +@FindChar4: + cmp cl, [edx] + jz @Matched0ch + cmp cl, [edx+1] + jz @Matched1ch + cmp cl, [edx+2] + jz @Matched2ch + cmp cl, [edx+3] + jz @Matched3ch + add edx, 4 + cmp edx, [esp+12] + jb @FindChar4 + cmp edx, [esp+8] + jb @FindChar2 + xor eax, eax + jmp @Exit0ch + +@Matched2ch: + add edx, 2 +@Matched0ch: + inc edx + mov eax, edx + sub eax, [esp+4] +@Exit0ch: + add esp, 16 + pop esi + pop ebx + ret + +@Matched3ch: + add edx, 2 +@Matched1ch: + add edx, 2 + xor eax, eax + cmp edx, [esp+8] + ja @Exit1ch + mov eax, edx + sub eax, [esp+4] +@Exit1ch: + add esp, 16 + pop esi + pop ebx + ret + +@FindString4: + cmp cl, [edx] + jz @Test0 + cmp cl, [edx+1] + jz @Test1 + cmp cl, [edx+2] + jz @Test2 + cmp cl, [edx+3] + jz @Test3 + add edx, 4 + cmp edx, [esp+12] + jb @FindString4 + cmp edx, [esp+8] + jb @FindString2 + xor eax, eax + jmp @Exit1 + +@FindString: + sub esi, 2 + mov [esp+12], esi +@FindString2: + cmp cl, [edx] + jz @Test0 +@AfterTest0: + cmp cl, [edx+1] + jz @Test1 +@AfterTest1: + add edx, 2 + cmp edx, [esp+12] + jb @FindString4 + cmp edx, [esp+8] + jb @FindString2 + xor eax, eax + jmp @Exit1 + +@Test3: + add edx, 2 +@Test1: + mov esi, [esp] +@Loop1: + movzx ebx, word ptr [esi+eax] + cmp bx, word ptr [esi+edx+1] + jnz @AfterTest1 + add esi, 2 + jl @Loop1 + add edx, 2 + xor eax, eax + cmp edx, [esp+8] + ja @Exit1 +@RetCode1: + mov eax, edx + sub eax, [esp+4] +@Exit1: + add esp, 16 + pop esi + pop ebx + ret + +@Test2: + add edx,2 +@Test0: + mov esi, [esp] +@Loop0: + movzx ebx, word ptr [esi+eax] + cmp bx, word ptr [esi+edx] + jnz @AfterTest0 + add esi, 2 + jl @Loop0 + inc edx +@RetCode0: + mov eax, edx + sub eax, [esp+4] + add esp, 16 + pop esi + pop ebx +end; + +function Pos(const substr, str: WideString): Integer; overload; +asm +{ ->EAX Pointer to substr } +{ EDX Pointer to string } +{ <-EAX Position of substr in str or 0 } + + TEST EAX,EAX + JE @@noWork + + TEST EDX,EDX + JE @@stringEmpty + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX { Point ESI to substr } + MOV EDI,EDX { Point EDI to s } + + MOV ECX,[EDI-4] { ECX = Length(s) } + SHR ECX,1 + + PUSH EDI { remember s position to calculate index } + + MOV EDX,[ESI-4] { EDX = Length(substr) } + SHR EDX,1 + + DEC EDX { EDX = Length(substr) - 1 } + JS @@fail { < 0 ? return 0 } + MOV AX,[ESI] { AL = first char of substr } + ADD ESI,2 { Point ESI to 2'nd char of substr } + + SUB ECX,EDX { #positions in s to look at } + { = Length(s) - Length(substr) + 1 } + JLE @@fail +@@loop: + REPNE SCASW + JNE @@fail + MOV EBX,ECX { save outer loop counter } + PUSH ESI { save outer loop substr pointer } + PUSH EDI { save outer loop s pointer } + + MOV ECX,EDX + REPE CMPSW + POP EDI { restore outer loop s pointer } + POP ESI { restore outer loop substr pointer } + JE @@found + MOV ECX,EBX { restore outer loop counter } + JMP @@loop + +@@fail: + POP EDX { get rid of saved s pointer } + XOR EAX,EAX + JMP @@exit + +@@stringEmpty: + XOR EAX,EAX + JMP @@noWork + +@@found: + POP EDX { restore pointer to first char of s } + MOV EAX,EDI { EDI points of char after match } + SUB EAX,EDX { the difference is the correct index } + SHR EAX,1 +@@exit: + POP EDI + POP ESI + POP EBX +@@noWork: +end; + +// 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); +begin + Byte(s^[0]) := newLength; // should also fill new space +end; + +procedure _SetString(s: PShortString; buffer: PChar; len: Byte); +begin + Byte(s^[0]) := len; + if buffer <> nil then + Move(buffer^, s^[1], len); +end; + +procedure Randomize; +{$IFDEF LINUX} +begin + RandSeed := _time(nil); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +var + Counter: Int64; +begin + if QueryPerformanceCounter(Counter) then + RandSeed := Counter + else + RandSeed := GetTickCount; +end; +{$ENDIF} + +function Random(const ARange: Integer): Integer; +{$IF DEFINED(CPU386)} +asm +{ ->EAX Range } +{ <-EAX Result } + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX + MOV ECX,[EBX].OFFSET RandSeed + IMUL EDX,[ECX],08088405H + INC EDX + MOV [ECX],EDX +{$ELSE} + XOR EBX, EBX + IMUL EDX,[EBX].RandSeed,08088405H + INC EDX + MOV [EBX].RandSeed,EDX +{$ENDIF} + MUL EDX + MOV EAX,EDX + POP EBX +end; +{$ELSEIF DEFINED(CLR)} +begin + InitRandom; + Result := RandomEngine.Next(ARange); +end; +{$ELSE} + {$MESSAGE ERROR 'Random(Int):Int unimplemented'} +{$IFEND} + +function Random: Extended; +{$IF DEFINED(CPU386)} +const two2neg32: double = ((1.0/$10000) / $10000); // 2^-32 +asm +{ FUNCTION _RandExt: Extended; } + + PUSH EBX +{$IFDEF PIC} + CALL GetGOT + MOV EBX,EAX + MOV ECX,[EBX].OFFSET RandSeed + IMUL EDX,[ECX],08088405H + INC EDX + MOV [ECX],EDX +{$ELSE} + XOR EBX, EBX + IMUL EDX,[EBX].RandSeed,08088405H + INC EDX + MOV [EBX].RandSeed,EDX +{$ENDIF} + + FLD [EBX].two2neg32 + PUSH 0 + PUSH EDX + FILD qword ptr [ESP] + ADD ESP,8 + FMULP ST(1), ST(0) + POP EBX +end; +{$ELSEIF DEFINED(CLR)} +begin + InitRandom; + Result := RandomEngine.NextDouble; +end; +{$ELSE} + {$MESSAGE ERROR 'Random:Extended unimplemented'} +{$IFEND} + +procedure RmDir(const S: string); +begin + RmDir(PChar(s)); +end; + +procedure RmDir(P: PChar); +begin +{$IFDEF MSWINDOWS} + if not RemoveDirectory(P) then +{$ENDIF} +{$IFDEF LINUX} + if __rmdir(P) <> 0 then +{$ENDIF} + InOutError; +end; + +function UpCase( ch : Char ) : Char; +{$IFDEF PUREPASCAL} +begin + Result := ch; + case Result of + 'a'..'z': Dec(Result, Ord('a') - Ord('A')); + end; +end; +{$ELSE} +asm +{ -> AL Character } +{ <- AL Result } + + CMP AL,'a' + JB @@exit + CMP AL,'z' + JA @@exit + SUB AL,'a' - 'A' +@@exit: +end; +{$ENDIF} + +procedure Set8087CW(NewCW: Word); +begin + Default8087CW := NewCW; + asm + FNCLEX // don't raise pending exceptions enabled by the new flags +{$IFDEF PIC} + MOV EAX,[EBX].OFFSET Default8087CW + FLDCW [EAX] +{$ELSE} + FLDCW Default8087CW +{$ENDIF} + end; +end; + +function Get8087CW: Word; +asm + PUSH 0 + FNSTCW [ESP].Word + POP EAX +end; + + +{ ----------------------------------------------------- } +{ functions & procedures that need compiler magic } +{ ----------------------------------------------------- } + +function Int(const X: Extended): Extended; +asm + FLD X + SUB ESP,4 + FNSTCW [ESP].Word // save + FNSTCW [ESP+2].Word // scratch + FWAIT + OR [ESP+2].Word, $0F00 // trunc toward zero, full precision + FLDCW [ESP+2].Word + FRNDINT + FWAIT + FLDCW [ESP].Word + ADD ESP,4 +end; + +function Frac(const X: Extended): Extended; +asm + FLD X + FLD ST(0) + SUB ESP,4 + FNSTCW [ESP].Word // save + FNSTCW [ESP+2].Word // scratch + FWAIT + OR [ESP+2].Word, $0F00 // trunc toward zero, full precision + FLDCW [ESP+2].Word + FRNDINT + FWAIT + FLDCW [ESP].Word + ADD ESP,4 + FSUB +end; + +function Exp(const X: Extended): Extended; +asm + { e**x = 2**(x*log2(e)) } + FLD X + FLDL2E { y := x*log2e; } + FMUL + FLD ST(0) { i := round(y); } + FRNDINT + FSUB ST(1), ST { f := y - i; } + FXCH ST(1) { z := 2**f } + F2XM1 + FLD1 + FADD + FSCALE { result := z * 2**i } + FSTP ST(1) +end; + +function Cos(const X: Extended): Extended; +asm + FLD X + FCOS + FWAIT +end; + +function Sin(const X: Extended): Extended; +asm + FLD X + FSIN + FWAIT +end; + +function Ln(const X: Extended): Extended; +asm + FLD X + FLDLN2 + FXCH + FYL2X + FWAIT +end; + +function ArcTan(const X: Extended): Extended; +asm + FLD X + FLD1 + FPATAN + FWAIT +end; + +function Sqrt(const X: Extended): Extended; +asm + FLD X + FSQRT + FWAIT +end; + +{ ----------------------------------------------------- } +{ functions & procedures that need compiler magic } +{ ----------------------------------------------------- } + +procedure _ROUND; +asm + { -> FST(0) Extended argument } + { <- EDX:EAX Result } + + SUB ESP,8 + FISTP qword ptr [ESP] + FWAIT + POP EAX + POP EDX +end; + +procedure _TRUNC; +asm + { -> FST(0) Extended argument } + { <- EDX:EAX Result } + + SUB ESP,12 + FNSTCW [ESP].Word // save + FNSTCW [ESP+2].Word // scratch + FWAIT + OR [ESP+2].Word, $0F00 // trunc toward zero, full precision + FLDCW [ESP+2].Word + FISTP qword ptr [ESP+4] + FWAIT + FLDCW [ESP].Word + POP ECX + POP EAX + POP EDX +end; + +procedure _AbstractError; +{$IFDEF PC_MAPPED_EXCEPTIONS} +asm + MOV EAX,210 + JMP _RunError +end; +{$ELSE} +{$IFDEF PIC} +begin + if Assigned(AbstractErrorProc) then + AbstractErrorProc; + _RunError(210); // loses return address +end; +{$ELSE} +asm + CMP AbstractErrorProc, 0 + JE @@NoAbstErrProc + CALL AbstractErrorProc + +@@NoAbstErrProc: + MOV EAX,210 + JMP _RunError +end; +{$ENDIF} +{$ENDIF} + +function TextOpen(var t: TTextRec): Integer; forward; + +function OpenText(var t: TTextRec; Mode: Word): Integer; +begin + if (t.Mode < fmClosed) or (t.Mode > fmInOut) then + Result := 102 + else + begin + if t.Mode <> fmClosed then _Close(t); + t.Mode := Mode; + if (t.Name[0] = #0) and (t.OpenFunc = nil) then // stdio + t.OpenFunc := @TextOpen; + Result := TTextIOFunc(t.OpenFunc)(t); + end; + if Result <> 0 then SetInOutRes(Result); +end; + +function _ResetText(var t: TTextRec): Integer; +begin + Result := OpenText(t, fmInput); +end; + +function _RewritText(var t: TTextRec): Integer; +begin + Result := OpenText(t, fmOutput); +end; + +function _Append(var t: TTextRec): Integer; +begin + Result := OpenText(t, fmInOut); +end; + +function TextIn(var t: TTextRec): Integer; +begin + t.BufEnd := 0; + t.BufPos := 0; +{$IFDEF LINUX} + t.BufEnd := __read(t.Handle, t.BufPtr, t.BufSize); + if Integer(t.BufEnd) = -1 then + begin + t.BufEnd := 0; + Result := GetLastError; + end + else + Result := 0; +{$ENDIF} +{$IFDEF MSWINDOWS} + if ReadFile(t.Handle, t.BufPtr^, t.BufSize, t.BufEnd, nil) = 0 then + begin + Result := GetLastError; + if Result = 109 then + Result := 0; // NT quirk: got "broken pipe"? it's really eof + end + else + Result := 0; +{$ENDIF} +end; + +function FileNOPProc(var t): Integer; +begin + Result := 0; +end; + +function TextOut(var t: TTextRec): Integer; +{$IFDEF MSWINDOWS} +var + Dummy: Cardinal; +{$ENDIF} +begin + if t.BufPos = 0 then + Result := 0 + else + begin +{$IFDEF LINUX} + if __write(t.Handle, t.BufPtr, t.BufPos) = Cardinal(-1) then +{$ENDIF} +{$IFDEF MSWINDOWS} + if WriteFile(t.Handle, t.BufPtr^, t.BufPos, Dummy, nil) = 0 then +{$ENDIF} + Result := GetLastError + else + Result := 0; + t.BufPos := 0; + end; +end; + +function InternalClose(Handle: Integer): Boolean; +begin +{$IFDEF LINUX} + Result := __close(Handle) = 0; +{$ENDIF} +{$IFDEF MSWINDOWS} + Result := CloseHandle(Handle) = 1; +{$ENDIF} +end; + +function TextClose(var t: TTextRec): Integer; +begin + t.Mode := fmClosed; + if not InternalClose(t.Handle) then + Result := GetLastError + else + Result := 0; +end; + +function TextOpenCleanup(var t: TTextRec): Integer; +begin + InternalClose(t.Handle); + t.Mode := fmClosed; + Result := GetLastError; +end; + +function TextOpen(var t: TTextRec): Integer; +{$IFDEF LINUX} +var + Flags: Integer; + Temp, I: Integer; + BytesRead: Integer; +begin + Result := 0; + t.BufPos := 0; + t.BufEnd := 0; + case t.Mode of + fmInput: // called by Reset + begin + Flags := O_RDONLY; + t.InOutFunc := @TextIn; + end; + fmOutput: // called by Rewrite + begin + Flags := O_CREAT or O_TRUNC or O_WRONLY; + t.InOutFunc := @TextOut; + end; + fmInOut: // called by Append + begin + Flags := O_APPEND or O_RDWR; + t.InOutFunc := @TextOut; + end; + else + Exit; + Flags := 0; + end; + + t.FlushFunc := @FileNOPProc; + + if t.Name[0] = #0 then // stdin or stdout + begin + t.BufPtr := @t.Buffer; + t.BufSize := sizeof(t.Buffer); + t.CloseFunc := @FileNOPProc; + if t.Mode = fmOutput then + begin + if @t = @ErrOutput then + t.Handle := STDERR_FILENO + else + t.Handle := STDOUT_FILENO; + t.FlushFunc := @TextOut; + end + else + t.Handle := STDIN_FILENO; + end + else + begin + t.CloseFunc := @TextClose; + + Temp := __open(t.Name, Flags, FileAccessRights); + if Temp = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + t.Handle := Temp; + + if t.Mode = fmInOut then // Append mode + begin + t.Mode := fmOutput; + + if (t.flags and tfCRLF) <> 0 then // DOS mode, EOF significant + begin // scan for EOF char in last 128 byte sector. + Temp := _lseek(t.Handle, 0, SEEK_END); + if Temp = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + Dec(Temp, 128); + if Temp < 0 then Temp := 0; + + if _lseek(t.Handle, Temp, SEEK_SET) = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + BytesRead := __read(t.Handle, t.BufPtr, 128); + if BytesRead = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + for I := 0 to BytesRead - 1 do + begin + if t.Buffer[I] = Char(cEOF) then + begin // truncate the file here + if _ftruncate(t.Handle, _lseek(t.Handle, I - BytesRead, SEEK_END)) = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + Break; + end; + end; + end; + end; + end; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +(* +var + OpenMode: Integer; + Flags, Std: ShortInt; + Temp: Integer; + I, BytesRead: Cardinal; + Mode: Byte; +begin + Result := 0; + if (t.Mode - fmInput) > (fmInOut - fmInput) then Exit; + Mode := t.Mode and 3; + t.BufPos := 0; + t.BufEnd := 0; + t.FlushFunc := @FileNOPProc; + + if t.Name[0] = #0 then // stdin or stdout + begin + t.BufPtr := @t.Buffer; + t.BufSize := sizeof(t.Buffer); + t.CloseFunc := @FileNOPProc; + if Mode = (fmOutput and 3) then + begin + t.InOutFunc := @TextOut; + if @t = @ErrOutput then + Std := STD_ERROR_HANDLE + else + Std := STD_OUTPUT_HANDLE; + end + else + begin + t.InOutFunc := @TextIn; + Std := STD_INPUT_HANDLE; + end; + t.Handle := GetStdHandle(Std); + end + else + begin + t.CloseFunc := @TextClose; + + Flags := OPEN_EXISTING; + if Mode = (fmInput and 3) then + begin // called by Reset + t.InOutFunc := @TextIn; + OpenMode := GENERIC_READ; // open for read + end + else + begin + t.InOutFunc := @TextOut; + if Mode = (fmInOut and 3) then // called by Append + OpenMode := GENERIC_READ OR GENERIC_WRITE // open for read/write + else + begin // called by Rewrite + OpenMode := GENERIC_WRITE; // open for write + Flags := CREATE_ALWAYS; + end; + end; + + Temp := CreateFileA(t.Name, OpenMode, FILE_SHARE_READ, nil, Flags, FILE_ATTRIBUTE_NORMAL, 0); + if Temp = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + t.Handle := Temp; + + if Mode = (fmInOut and 3) then + begin + Dec(t.Mode); // fmInOut -> fmOutput + +{; ??? we really have to look for the first eof byte in the +; ??? last record and truncate the file there. +; Not very nice and clean... +; +; lastRecPos = Max( GetFileSize(...) - 128, 0); +} + Temp := GetFileSize(t.Handle, 0); + if Temp = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + Dec(Temp, 128); + if Temp < 0 then Temp := 0; + + if (SetFilePointer(t.Handle, Temp, nil, FILE_BEGIN) = -1) or + (ReadFile(t.Handle, t.Buffer, 128, BytesRead, nil) = 0) then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + for I := 0 to BytesRead do + begin + if t.Buffer[I] = Char(cEOF) then + begin // truncate the file here + if (SetFilePointer(t.Handle, I - BytesRead, nil, FILE_END) = -1) or + (not SetEndOfFile(t.Handle)) then + begin + Result := TextOpenCleanup(t); + Exit; + end; + Break; + end; + end; + end; + if Mode <> (fmInput and 3) then + begin + case GetFileType(t.Handle) of + 0: begin // bad file type + TextOpenCleanup(t); + Result := 105; + Exit; + end; + 2: t.FlushFunc := @TextOut; + end; + end; + end; +end; +*) + +asm +// -> EAX Pointer to text record + + PUSH ESI + + MOV ESI,EAX + + XOR EAX,EAX + MOV [ESI].TTextRec.BufPos,EAX + MOV [ESI].TTextRec.BufEnd,EAX + MOV AX,[ESI].TTextRec.Mode + + SUB EAX,fmInput + JE @@calledByReset + + DEC EAX + JE @@calledByRewrite + + DEC EAX + JE @@calledByAppend + + JMP @@exit + +@@calledByReset: + + MOV EAX,GENERIC_READ // open for read + MOV EDX,FILE_SHARE_READ + MOV ECX,OPEN_EXISTING + + MOV [ESI].TTextRec.InOutFunc,offset TextIn + + JMP @@common + +@@calledByRewrite: + + MOV EAX,GENERIC_WRITE // open for write + MOV EDX,FILE_SHARE_READ + MOV ECX,CREATE_ALWAYS + JMP @@commonOut + +@@calledByAppend: + + MOV EAX,GENERIC_READ OR GENERIC_WRITE // open for read/write + MOV EDX,FILE_SHARE_READ + MOV ECX,OPEN_EXISTING + +@@commonOut: + + MOV [ESI].TTextRec.InOutFunc,offset TextOut + +@@common: + + MOV [ESI].TTextRec.CloseFunc,offset TextClose + MOV [ESI].TTextRec.FlushFunc,offset FileNOPProc + CMP byte ptr [ESI].TTextRec.Name,0 + JE @@isCon + +// CreateFile(t.Name, EAX, EDX, Nil, ECX, FILE_ATTRIBUTE_NORMAL, 0); + + PUSH 0 + PUSH FILE_ATTRIBUTE_NORMAL + PUSH ECX + PUSH 0 + PUSH EDX + PUSH EAX + LEA EAX,[ESI].TTextRec.Name + PUSH EAX + CALL CreateFileA + + CMP EAX,-1 + JZ @@error + + MOV [ESI].TTextRec.Handle,EAX + CMP [ESI].TTextRec.Mode,fmInOut + JNE @@success + + DEC [ESI].TTextRec.Mode // fmInOut -> fmOutput + +{; ??? we really have to look for the first eof byte in the +; ??? last record and truncate the file there. +; Not very nice and clean... +; +; lastRecPos = Max( GetFileSize(...) - 128, 0); +} + PUSH 0 + PUSH [ESI].TTextRec.Handle + CALL GetFileSize + + INC EAX + JZ @@error + SUB EAX,129 + JNC @@3 + XOR EAX,EAX +@@3: +// lseek(f.Handle, SEEK_SET, lastRecPos); + + PUSH FILE_BEGIN + PUSH 0 + PUSH EAX + PUSH [ESI].TTextRec.Handle + CALL SetFilePointer + + INC EAX + JE @@error + +// bytesRead = read(f.Handle, f.Buffer, 128); + + PUSH 0 + MOV EDX,ESP + PUSH 0 + PUSH EDX + PUSH 128 + LEA EDX,[ESI].TTextRec.Buffer + PUSH EDX + PUSH [ESI].TTextRec.Handle + CALL ReadFile + POP EDX + DEC EAX + JNZ @@error + +// for (i = 0; i < bytesRead; i++) + + XOR EAX,EAX +@@loop: + CMP EAX,EDX + JAE @@success + +// if (f.Buffer[i] == eof) + + CMP byte ptr [ESI].TTextRec.Buffer[EAX],eof + JE @@truncate + INC EAX + JMP @@loop + +@@truncate: + +// lseek( f.Handle, SEEK_END, i - bytesRead ); + + PUSH FILE_END + PUSH 0 + SUB EAX,EDX + PUSH EAX + PUSH [ESI].TTextRec.Handle + CALL SetFilePointer + INC EAX + JE @@error + +// SetEndOfFile( f.Handle ); + + PUSH [ESI].TTextRec.Handle + CALL SetEndOfFile + DEC EAX + JNE @@error + + JMP @@success + +@@isCon: + LEA EAX,[ESI].TTextRec.Buffer + MOV [ESI].TTextRec.BufSize, TYPE TTextRec.Buffer + MOV [ESI].TTextRec.CloseFunc,offset FileNOPProc + MOV [ESI].TTextRec.BufPtr,EAX + CMP [ESI].TTextRec.Mode,fmOutput + JE @@output + PUSH STD_INPUT_HANDLE + JMP @@1 +@@output: + CMP ESI,offset ErrOutput + JNE @@stdout + PUSH STD_ERROR_HANDLE + JMP @@1 +@@stdout: + PUSH STD_OUTPUT_HANDLE +@@1: + CALL GetStdHandle + CMP EAX,-1 + JE @@error + MOV [ESI].TTextRec.Handle,EAX + +@@success: + CMP [ESI].TTextRec.Mode,fmInput + JE @@2 + PUSH [ESI].TTextRec.Handle + CALL GetFileType + TEST EAX,EAX + JE @@badFileType + CMP EAX,2 + JNE @@2 + MOV [ESI].TTextRec.FlushFunc,offset TextOut +@@2: + XOR EAX,EAX +@@exit: + POP ESI + RET + +@@badFileType: + PUSH [ESI].TTextRec.Handle + CALL CloseHandle + MOV [ESI].TTextRec.Mode,fmClosed + MOV EAX,105 + JMP @@exit + +@@error: + MOV [ESI].TTextRec.Mode,fmClosed + CALL GetLastError + JMP @@exit +end; +{$ENDIF} + +const + fNameLen = 260; + +function _Assign(var t: TTextRec; const s: String): Integer; +begin + FillChar(t, sizeof(TFileRec), 0); + t.BufPtr := @t.Buffer; + t.Mode := fmClosed; + t.Flags := tfCRLF * Byte(DefaultTextLineBreakStyle); + t.BufSize := sizeof(t.Buffer); + t.OpenFunc := @TextOpen; + Move(S[1], t.Name, Length(s)); + t.Name[Length(s)] := #0; + Result := 0; +end; + +function InternalFlush(var t: TTextRec; Func: TTextIOFunc): Integer; +begin + case t.Mode of + fmOutput, + fmInOut : Result := Func(t); + fmInput : Result := 0; + else + if (@t = @Output) or (@t = @ErrOutput) then + Result := 0 + else + Result := 103; + end; + if Result <> 0 then SetInOutRes(Result); +end; + +function Flush(var t: Text): Integer; +begin + Result := InternalFlush(TTextRec(t), TTextRec(t).InOutFunc); +end; + +function _Flush(var t: TTextRec): Integer; +begin + Result := InternalFlush(t, t.FlushFunc); +end; + +type +{$IFDEF MSWINDOWS} + 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'; + +{$ENDIF} +{$IFDEF LINUX} + TIOProc = function (Handle: Integer; Buffer: Pointer; Count: Cardinal): Cardinal; cdecl; +{$ENDIF} + +function BlockIO(var f: TFileRec; buffer: Pointer; recCnt: Cardinal; var recsDone: Longint; + ModeMask: Integer; IOProc: TIOProc; ErrorNo: Integer): Cardinal; +// Note: RecsDone ptr can be nil! +begin + if (f.Mode and ModeMask) = ModeMask then // fmOutput or fmInOut / fmInput or fmInOut + begin +{$IFDEF LINUX} + Result := IOProc(f.Handle, buffer, recCnt * f.RecSize); + if Integer(Result) = -1 then +{$ENDIF} +{$IFDEF MSWINDOWS} + if IOProc(f.Handle, buffer, recCnt * f.RecSize, Result, nil) = 0 then +{$ENDIF} + begin + SetInOutRes(GetLastError); + Result := 0; + end + else + begin + Result := Result div f.RecSize; + if @RecsDone <> nil then + RecsDone := Result + else if Result <> recCnt then + begin + SetInOutRes(ErrorNo); + Result := 0; + end + end; + end + else + begin + SetInOutRes(103); // file not open + Result := 0; + end; +end; + +function _BlockRead(var f: TFileRec; buffer: Pointer; recCnt: Longint; var recsRead: Longint): Longint; +begin + Result := BlockIO(f, buffer, recCnt, recsRead, fmInput, + {$IFDEF MSWINDOWS} ReadFileX, {$ENDIF} + {$IFDEF LINUX} __read, {$ENDIF} + 100); +end; + +function _BlockWrite(var f: TFileRec; buffer: Pointer; recCnt: Longint; var recsWritten: Longint): Longint; +begin + Result := BlockIO(f, buffer, recCnt, recsWritten, fmOutput, + {$IFDEF MSWINDOWS} WriteFileX, {$ENDIF} + {$IFDEF LINUX} __write, {$ENDIF} + 101); +end; + +function _Close(var t: TTextRec): Integer; +begin + Result := 0; + if (t.Mode >= fmInput) and (t.Mode <= fmInOut) then + begin + if (t.Mode and fmOutput) = fmOutput then // fmOutput or fmInOut + Result := TTextIOFunc(t.InOutFunc)(t); + if Result = 0 then + Result := TTextIOFunc(t.CloseFunc)(t); + if Result <> 0 then + SetInOutRes(Result); + end + else + if @t <> @Input then + SetInOutRes(103); +end; + +procedure _PStrCat; +asm +{ ->EAX = Pointer to destination string } +{ EDX = Pointer to source string } + + PUSH ESI + PUSH EDI + +{ load dest len into EAX } + + MOV EDI,EAX + XOR EAX,EAX + MOV AL,[EDI] + +{ load source address in ESI, source len in ECX } + + MOV ESI,EDX + XOR ECX,ECX + MOV CL,[ESI] + INC ESI + +{ calculate final length in DL and store it in the destination } + + MOV DL,AL + ADD DL,CL + JC @@trunc + +@@cont: + MOV [EDI],DL + +{ calculate final dest address } + + INC EDI + ADD EDI,EAX + +{ do the copy } + + REP MOVSB + +{ done } + + POP EDI + POP ESI + RET + +@@trunc: + INC DL { DL = #chars to truncate } + SUB CL,DL { CL = source len - #chars to truncate } + MOV DL,255 { DL = maximum length } + JMP @@cont +end; + +procedure _PStrNCat; +asm +{ ->EAX = Pointer to destination string } +{ EDX = Pointer to source string } +{ CL = max length of result (allocated size of dest - 1) } + + PUSH ESI + PUSH EDI + +{ load dest len into EAX } + + MOV EDI,EAX + XOR EAX,EAX + MOV AL,[EDI] + +{ load source address in ESI, source len in EDX } + + MOV ESI,EDX + XOR EDX,EDX + MOV DL,[ESI] + INC ESI + +{ calculate final length in AL and store it in the destination } + + ADD AL,DL + JC @@trunc + CMP AL,CL + JA @@trunc + +@@cont: + MOV ECX,EDX + MOV DL,[EDI] + MOV [EDI],AL + +{ calculate final dest address } + + INC EDI + ADD EDI,EDX + +{ do the copy } + + REP MOVSB + +@@done: + POP EDI + POP ESI + RET + +@@trunc: +{ CL = maxlen } + + MOV AL,CL { AL = final length = maxlen } + SUB CL,[EDI] { CL = length to copy = maxlen - destlen } + JBE @@done + MOV DL,CL + JMP @@cont +end; + +procedure _PStrCpy(Dest: PShortString; Source: PShortString); +begin + Move(Source^, Dest^, Byte(Source^[0])+1); +end; + +procedure _PStrNCpy(Dest: PShortString; Source: PShortString; MaxLen: Byte); +begin + if MaxLen > Byte(Source^[0]) then + MaxLen := Byte(Source^[0]); + Byte(Dest^[0]) := MaxLen; + Move(Source^[1], Dest^[1], MaxLen); +end; + +procedure _PStrCmp; +asm +{ ->EAX = Pointer to left string } +{ EDX = Pointer to right string } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + XOR EAX,EAX + XOR EDX,EDX + MOV AL,[ESI] + MOV DL,[EDI] + INC ESI + INC EDI + + SUB EAX,EDX { eax = len1 - len2 } + JA @@skip1 + ADD EDX,EAX { edx = len2 + (len1 - len2) = len1 } + +@@skip1: + PUSH EDX + SHR EDX,2 + JE @@cmpRest +@@longLoop: + MOV ECX,[ESI] + MOV EBX,[EDI] + CMP ECX,EBX + JNE @@misMatch + DEC EDX + JE @@cmpRestP4 + MOV ECX,[ESI+4] + MOV EBX,[EDI+4] + CMP ECX,EBX + JNE @@misMatch + ADD ESI,8 + ADD EDI,8 + DEC EDX + JNE @@longLoop + JMP @@cmpRest +@@cmpRestP4: + ADD ESI,4 + ADD EDI,4 +@@cmpRest: + POP EDX + AND EDX,3 + JE @@equal + + MOV CL,[ESI] + CMP CL,[EDI] + JNE @@exit + DEC EDX + JE @@equal + MOV CL,[ESI+1] + CMP CL,[EDI+1] + JNE @@exit + DEC EDX + JE @@equal + MOV CL,[ESI+2] + CMP CL,[EDI+2] + JNE @@exit + +@@equal: + ADD EAX,EAX + JMP @@exit + +@@misMatch: + POP EDX + CMP CL,BL + JNE @@exit + CMP CH,BH + JNE @@exit + SHR ECX,16 + SHR EBX,16 + CMP CL,BL + JNE @@exit + CMP CH,BH + +@@exit: + POP EDI + POP ESI + POP EBX +end; + +procedure _AStrCmp; +asm +{ ->EAX = Pointer to left string } +{ EDX = Pointer to right string } +{ ECX = Number of chars to compare} + + PUSH EBX + PUSH ESI + PUSH ECX + MOV ESI,ECX + SHR ESI,2 + JE @@cmpRest + +@@longLoop: + MOV ECX,[EAX] + MOV EBX,[EDX] + CMP ECX,EBX + JNE @@misMatch + DEC ESI + JE @@cmpRestP4 + MOV ECX,[EAX+4] + MOV EBX,[EDX+4] + CMP ECX,EBX + JNE @@misMatch + ADD EAX,8 + ADD EDX,8 + DEC ESI + JNE @@longLoop + JMP @@cmpRest +@@cmpRestp4: + ADD EAX,4 + ADD EDX,4 +@@cmpRest: + POP ESI + AND ESI,3 + JE @@exit + + MOV CL,[EAX] + CMP CL,[EDX] + JNE @@exit + DEC ESI + JE @@equal + MOV CL,[EAX+1] + CMP CL,[EDX+1] + JNE @@exit + DEC ESI + JE @@equal + MOV CL,[EAX+2] + CMP CL,[EDX+2] + JNE @@exit + +@@equal: + XOR EAX,EAX + JMP @@exit + +@@misMatch: + POP ESI + CMP CL,BL + JNE @@exit + CMP CH,BH + JNE @@exit + SHR ECX,16 + SHR EBX,16 + CMP CL,BL + JNE @@exit + CMP CH,BH + +@@exit: + POP ESI + POP EBX +end; + +function _EofFile(var f: TFileRec): Boolean; +begin + Result := _FilePos(f) >= _FileSize(f); +end; + +function _EofText(var t: TTextRec): Boolean; +asm +// -> EAX Pointer to text record +// <- AL Boolean result + CMP [EAX].TTextRec.Mode,fmInput + JNE @@readChar + MOV EDX,[EAX].TTextRec.BufPos + CMP EDX,[EAX].TTextRec.BufEnd + JAE @@readChar + ADD EDX,[EAX].TTextRec.BufPtr + TEST [EAX].TTextRec.Flags,tfCRLF + JZ @@FalseExit + MOV CL,[EDX] + CMP CL,cEof + JNZ @@FalseExit + +@@eof: + MOV AL,1 + JMP @@exit + +@@readChar: + PUSH EAX + CALL _ReadChar + POP EDX + CMP AH,cEof + JE @@eof + DEC [EDX].TTextRec.BufPos +@@FalseExit: + XOR EAX,EAX +@@exit: +end; + +function _Eoln(var t: TTextRec): Boolean; +asm +// -> EAX Pointer to text record +// <- AL Boolean result + + CMP [EAX].TTextRec.Mode,fmInput + JNE @@readChar + MOV EDX,[EAX].TTextRec.BufPos + CMP EDX,[EAX].TTextRec.BufEnd + JAE @@readChar + ADD EDX,[EAX].TTextRec.BufPtr + TEST [EAX].TTextRec.Flags,tfCRLF + MOV AL,0 + MOV CL,[EDX] + JZ @@testLF + CMP CL,cCR + JE @@eol + CMP CL,cEOF + JE @@eof + JMP @@exit + +@@testLF: + CMP CL,cLF + JE @@eol + CMP CL,cEOF + JE @@eof + JMP @@exit + +@@readChar: + PUSH EAX + CALL _ReadChar + POP EDX + CMP AH,cEOF + JE @@eof + DEC [EDX].TTextRec.BufPos + XOR ECX,ECX + XCHG ECX,EAX + TEST [EDX].TTextRec.Mode,tfCRLF + JNE @@testLF + CMP CL,cCR + JE @@eol + JMP @@exit + +@@eol: +@@eof: + MOV AL,1 +@@exit: +end; + +procedure _Erase(var f: TFileRec); +begin + if (f.Mode < fmClosed) or (f.Mode > fmInOut) then + SetInOutRes(102) // file not assigned + else +{$IFDEF LINUX} + if __remove(f.Name) < 0 then + SetInOutRes(GetLastError); +{$ENDIF} +{$IFDEF MSWINDOWS} + if not DeleteFileA(f.Name) then + SetInOutRes(GetLastError); +{$ENDIF} +end; + +{$IFDEF MSWINDOWS} +// Floating-point divide reverse routine +// ST(1) = ST(0) / ST(1), pop ST + +procedure _FSafeDivideR; +asm + FXCH + JMP _FSafeDivide +end; + +// Floating-point divide routine +// ST(1) = ST(1) / ST(0), pop ST + +procedure _FSafeDivide; +type + Z = packed record // helper type to make parameter references more readable + Dividend: Extended; // (TBYTE PTR [ESP]) + Pad: Word; + Divisor: Extended; // (TBYTE PTR [ESP+12]) + end; +asm + CMP TestFDIV,0 //Check FDIV indicator + JLE @@FDivideChecked //Jump if flawed or don't know + FDIV //Known to be ok, so just do FDIV + RET + +// FDIV constants +@@FDIVRiscTable: DB 0,1,0,0,4,0,0,7,0,0,10,0,0,13,0,0; + +@@FDIVScale1: DD $3F700000 // 0.9375 +@@FDIVScale2: DD $3F880000 // 1.0625 +@@FDIV1SHL63: DD $5F000000 // 1 SHL 63 + +@@TestDividend: DD $C0000000,$4150017E // 4195835.0 +@@TestDivisor: DD $80000000,$4147FFFF // 3145727.0 +@@TestOne: DD $00000000,$3FF00000 // 1.0 + +// Flawed FDIV detection +@@FDivideDetect: + MOV TestFDIV,1 //Indicate correct FDIV + PUSH EAX + SUB ESP,12 + FSTP TBYTE PTR [ESP] //Save off ST + FLD QWORD PTR @@TestDividend //Ok if x - (x / y) * y < 1.0 + FDIV QWORD PTR @@TestDivisor + FMUL QWORD PTR @@TestDivisor + FSUBR QWORD PTR @@TestDividend + FCOMP QWORD PTR @@TestOne + FSTSW AX + SHR EAX,7 + AND EAX,002H //Zero if FDIV is flawed + DEC EAX + MOV TestFDIV,AL //1 means Ok, -1 means flawed + FLD TBYTE PTR [ESP] //Restore ST + ADD ESP,12 + POP EAX + JMP _FSafeDivide + +@@FDivideChecked: + JE @@FDivideDetect //Do detection if TestFDIV = 0 + +@@1: PUSH EAX + SUB ESP,24 + FSTP [ESP].Z.Divisor //Store Divisor and Dividend + FSTP [ESP].Z.Dividend + FLD [ESP].Z.Dividend + FLD [ESP].Z.Divisor +@@2: MOV EAX,DWORD PTR [ESP+4].Z.Divisor //Is Divisor a denormal? + ADD EAX,EAX + JNC @@20 //Yes, @@20 + XOR EAX,0E000000H //If these three bits are not all + TEST EAX,0E000000H //ones, FDIV will work + JZ @@10 //Jump if all ones +@@3: FDIV //Do FDIV and exit + ADD ESP,24 + POP EAX + RET + +@@10: SHR EAX,28 //If the four bits following the MSB + //of the mantissa have a decimal + //of 1, 4, 7, 10, or 13, FDIV may + CMP byte ptr @@FDIVRiscTable[EAX],0 //not work correctly + JZ @@3 //Do FDIV if not 1, 4, 7, 10, or 13 + MOV EAX,DWORD PTR [ESP+8].Z.Divisor //Get Divisor exponent + AND EAX,7FFFH + JZ @@3 //Ok to FDIV if denormal + CMP EAX,7FFFH + JE @@3 //Ok to FDIV if NAN or INF + MOV EAX,DWORD PTR [ESP+8].Z.Dividend //Get Dividend exponent + AND EAX,7FFFH + CMP EAX,1 //Small number? + JE @@11 //Yes, @@11 + FMUL DWORD PTR @@FDIVScale1 //Scale by 15/16 + FXCH + FMUL DWORD PTR @@FDIVScale1 + FXCH + JMP @@3 //FDIV is now safe + +@@11: FMUL DWORD PTR @@FDIVScale2 //Scale by 17/16 + FXCH + FMUL DWORD PTR @@FDIVScale2 + FXCH + JMP @@3 //FDIV is now safe + +@@20: MOV EAX,DWORD PTR [ESP].Z.Divisor //Is entire Divisor zero? + OR EAX,DWORD PTR [ESP+4].Z.Divisor + JZ @@3 //Yes, ok to FDIV + MOV EAX,DWORD PTR [ESP+8].Z.Divisor //Get Divisor exponent + AND EAX,7FFFH //Non-zero exponent is invalid + JNZ @@3 //Ok to FDIV if invalid + MOV EAX,DWORD PTR [ESP+8].Z.Dividend //Get Dividend exponent + AND EAX,7FFFH //Denormal? + JZ @@21 //Yes, @@21 + CMP EAX,7FFFH //NAN or INF? + JE @@3 //Yes, ok to FDIV + MOV EAX,DWORD PTR [ESP+4].Z.Dividend //If MSB of mantissa is zero, + ADD EAX,EAX //the number is invalid + JNC @@3 //Ok to FDIV if invalid + JMP @@22 +@@21: MOV EAX,DWORD PTR [ESP+4].Z.Dividend //If MSB of mantissa is zero, + ADD EAX,EAX //the number is invalid + JC @@3 //Ok to FDIV if invalid +@@22: FXCH //Scale stored Divisor image by + FSTP ST(0) //1 SHL 63 and restart + FLD ST(0) + FMUL DWORD PTR @@FDIV1SHL63 + FSTP [ESP].Z.Divisor + FLD [ESP].Z.Dividend + FXCH + JMP @@2 +end; +{$ENDIF} + +function _FilePos(var f: TFileRec): Longint; +begin + if (f.Mode > fmClosed) and (f.Mode <= fmInOut) then + begin +{$IFDEF LINUX} + Result := _lseek(f.Handle, 0, SEEK_CUR); +{$ENDIF} +{$IFDEF MSWINDOWS} + Result := SetFilePointer(f.Handle, 0, nil, FILE_CURRENT); +{$ENDIF} + if Result = -1 then + InOutError + else + Result := Cardinal(Result) div f.RecSize; + end + else + begin + SetInOutRes(103); + Result := -1; + end; +end; + +function _FileSize(var f: TFileRec): Longint; +{$IFDEF MSWINDOWS} +begin + Result := -1; + if (f.Mode > fmClosed) and (f.Mode <= fmInOut) then + begin + Result := GetFileSize(f.Handle, 0); + if Result = -1 then + InOutError + else + Result := Cardinal(Result) div f.RecSize; + end + else + SetInOutRes(103); +{$ENDIF} +{$IFDEF LINUX} +var + stat: TStatStruct; +begin + Result := -1; + if (f.Mode > fmClosed) and (f.Mode <= fmInOut) then + begin + if _fxstat(STAT_VER_LINUX, f.Handle, stat) <> 0 then + InOutError + else + Result := stat.st_size div f.RecSize; + end + else + SetInOutRes(103); +{$ENDIF} +end; + +procedure _FillChar(var Dest; count: Integer; Value: Char); +{$IFDEF PUREPASCAL} +var + I: Integer; + P: PChar; +begin + P := PChar(@Dest); + for I := count-1 downto 0 do + P[I] := Value; +end; +{$ELSE} +asm +{ ->EAX Pointer to destination } +{ EDX count } +{ CL value } + + PUSH EDI + + MOV EDI,EAX { Point EDI to destination } + + MOV CH,CL { Fill EAX with value repeated 4 times } + MOV EAX,ECX + SHL EAX,16 + MOV AX,CX + + MOV ECX,EDX + SAR ECX,2 + JS @@exit + + REP STOSD { Fill count DIV 4 dwords } + + MOV ECX,EDX + AND ECX,3 + REP STOSB { Fill count MOD 4 bytes } + +@@exit: + POP EDI +end; +{$ENDIF} + +procedure Mark; +begin + Error(reInvalidPtr); +end; + +procedure _RandInt; +asm +{ ->EAX Range } +{ <-EAX Result } + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX + MOV ECX,[EBX].OFFSET RandSeed + IMUL EDX,[ECX],08088405H + INC EDX + MOV [ECX],EDX +{$ELSE} + XOR EBX, EBX + IMUL EDX,[EBX].RandSeed,08088405H + INC EDX + MOV [EBX].RandSeed,EDX +{$ENDIF} + MUL EDX + MOV EAX,EDX + POP EBX +end; + +procedure _RandExt; +const two2neg32: double = ((1.0/$10000) / $10000); // 2^-32 +asm +{ FUNCTION _RandExt: Extended; } + + PUSH EBX +{$IFDEF PIC} + CALL GetGOT + MOV EBX,EAX + MOV ECX,[EBX].OFFSET RandSeed + IMUL EDX,[ECX],08088405H + INC EDX + MOV [ECX],EDX +{$ELSE} + XOR EBX, EBX + IMUL EDX,[EBX].RandSeed,08088405H + INC EDX + MOV [EBX].RandSeed,EDX +{$ENDIF} + + FLD [EBX].two2neg32 + PUSH 0 + PUSH EDX + FILD qword ptr [ESP] + ADD ESP,8 + FMULP ST(1), ST(0) + POP EBX +end; + +function _ReadRec(var f: TFileRec; Buffer: Pointer): Integer; +{$IFDEF LINUX} +begin + if (f.Mode and fmInput) = fmInput then // fmInput or fmInOut + begin + Result := __read(f.Handle, Buffer, f.RecSize); + if Result = -1 then + InOutError + else if Cardinal(Result) <> f.RecSize then + SetInOutRes(100); + end + else + begin + SetInOutRes(103); // file not open for input + Result := 0; + end; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm +// -> EAX Pointer to file variable +// EDX Pointer to buffer + + PUSH EBX + XOR ECX,ECX + MOV EBX,EAX + MOV CX,[EAX].TFileRec.Mode // File must be open + SUB ECX,fmInput + JE @@skip + SUB ECX,fmInOut-fmInput + JNE @@fileNotOpen +@@skip: + +// ReadFile(f.Handle, buffer, f.RecSize, @result, Nil); + + PUSH 0 // space for OS result + MOV EAX,ESP + + PUSH 0 // pass lpOverlapped + PUSH EAX // pass @result + + PUSH [EBX].TFileRec.RecSize // pass nNumberOfBytesToRead + + PUSH EDX // pass lpBuffer + PUSH [EBX].TFileRec.Handle // pass hFile + CALL ReadFile + POP EDX // pop result + DEC EAX // check EAX = TRUE + JNZ @@error + + CMP EDX,[EBX].TFileRec.RecSize // result = f.RecSize ? + JE @@exit + +@@readError: + MOV EAX,100 + JMP @@errExit + +@@fileNotOpen: + MOV EAX,103 + JMP @@errExit + +@@error: + CALL GetLastError +@@errExit: + CALL SetInOutRes +@@exit: + POP EBX +end; +{$ENDIF} + + +// If the file is Input std variable, try to open it +// Otherwise, runtime error. +function TryOpenForInput(var t: TTextRec): Boolean; +begin + if @t = @Input then + begin + t.Flags := tfCRLF * Byte(DefaultTextLineBreakStyle); + _ResetText(t); + end; + + Result := t.Mode = fmInput; + if not Result then + SetInOutRes(104); +end; + +function _ReadChar(var t: TTextRec): Char; +asm +// -> EAX Pointer to text record +// <- AL Character read. (may be a pseudo cEOF in DOS mode) +// <- AH cEOF = End of File, else 0 +// For eof, #$1A is returned in AL and in AH. +// For errors, InOutRes is set and #$1A is returned. + + CMP [EAX].TTextRec.Mode, fmInput + JE @@checkBuf + PUSH EAX + CALL TryOpenForInput + TEST AL,AL + POP EAX + JZ @@eofexit + +@@checkBuf: + MOV EDX,[EAX].TTextRec.BufPos + CMP EDX,[EAX].TTextRec.BufEnd + JAE @@fillBuf +@@cont: + TEST [EAX].TTextRec.Flags,tfCRLF + MOV ECX,[EAX].TTextRec.BufPtr + MOV CL,[ECX+EDX] + JZ @@cont2 + CMP CL,cEof // Check for EOF char in DOS mode + JE @@eofexit +@@cont2: + INC EDX + MOV [EAX].TTextRec.BufPos,EDX + XOR EAX,EAX + JMP @@exit + +@@fillBuf: + PUSH EAX + CALL [EAX].TTextRec.InOutFunc + TEST EAX,EAX + JNE @@error + POP EAX + MOV EDX,[EAX].TTextRec.BufPos + CMP EDX,[EAX].TTextRec.BufEnd + JB @@cont + +// We didn't get characters. Must be eof then. + +@@eof: + TEST [EAX].TTextRec.Flags,tfCRLF + JZ @@eofexit +// In DOS CRLF compatibility mode, synthesize an EOF char +// Store one eof in the buffer and increment BufEnd + MOV ECX,[EAX].TTextRec.BufPtr + MOV byte ptr [ECX+EDX],cEof + INC [EAX].TTextRec.BufEnd + JMP @@eofexit + +@@error: + CALL SetInOutRes + POP EAX +@@eofexit: + MOV CL,cEof + MOV AH,CL +@@exit: + MOV AL,CL +end; + +function _ReadLong(var t: TTextRec): Longint; +asm +// -> EAX Pointer to text record +// <- EAX Result + + PUSH EBX + PUSH ESI + PUSH EDI + SUB ESP,36 // var numbuf: String[32]; + + MOV ESI,EAX + CALL _SeekEof + DEC AL + JZ @@eof + + MOV EDI,ESP // EDI -> numBuf[0] + MOV BL,32 +@@loop: + MOV EAX,ESI + CALL _ReadChar + CMP AL,' ' + JBE @@endNum + STOSB + DEC BL + JNZ @@loop +@@convert: + MOV byte ptr [EDI],0 + MOV EAX,ESP // EAX -> numBuf + PUSH EDX // allocate code result + MOV EDX,ESP // pass pointer to code + CALL _ValLong // convert + POP EDX // pop code result into EDX + TEST EDX,EDX + JZ @@exit + MOV EAX,106 + CALL SetInOutRes + JMP @@exit + +@@endNum: + CMP AH,cEof + JE @@convert + DEC [ESI].TTextRec.BufPos + JMP @@convert + +@@eof: + XOR EAX,EAX +@@exit: + ADD ESP,36 + POP EDI + POP ESI + POP EBX +end; + +function ReadLine(var t: TTextRec; buf: Pointer; maxLen: Longint): Pointer; +asm +// -> EAX Pointer to text record +// EDX Pointer to buffer +// ECX Maximum count of chars to read +// <- ECX Actual count of chars in buffer +// <- EAX Pointer to text record + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH ECX + MOV ESI,ECX + MOV EDI,EDX + + CMP [EAX].TTextRec.Mode,fmInput + JE @@start + PUSH EAX + CALL TryOpenForInput + TEST AL,AL + POP EAX + JZ @@exit + +@@start: + MOV EBX,EAX + + TEST ESI,ESI + JLE @@exit + + MOV EDX,[EBX].TTextRec.BufPos + MOV ECX,[EBX].TTextRec.BufEnd + SUB ECX,EDX + ADD EDX,[EBX].TTextRec.BufPtr + +@@loop: + DEC ECX + JL @@readChar + MOV AL,[EDX] + INC EDX +@@cont: + CMP AL,cLF + JE @@lf + + CMP AL,cCR + JE @@cr + + STOSB + DEC ESI + JG @@loop + JMP @@finish + +@@cr: + MOV AL,[EDX] + CMP AL,cLF + JNE @@loop +@@lf: + DEC EDX +@@finish: + SUB EDX,[EBX].TTextRec.BufPtr + MOV [EBX].TTextRec.BufPos,EDX + JMP @@exit + +@@readChar: + MOV [EBX].TTextRec.BufPos,EDX + MOV EAX,EBX + CALL _ReadChar + MOV EDX,[EBX].TTextRec.BufPos + MOV ECX,[EBX].TTextRec.BufEnd + SUB ECX,EDX + ADD EDX,[EBX].TTextRec.BufPtr + TEST AH,AH //eof + JZ @@cont + +@@exit: + MOV EAX,EBX + POP ECX + SUB ECX,ESI + POP EDI + POP ESI + POP EBX +end; + +procedure _ReadString(var t: TTextRec; s: PShortString; maxLen: Longint); +asm +// -> EAX Pointer to text record +// EDX Pointer to string +// ECX Maximum length of string + + PUSH EDX + INC EDX + CALL ReadLine + POP EDX + MOV [EDX],CL +end; + +procedure _ReadCString(var t: TTextRec; s: PChar; maxLen: Longint); +asm +// -> EAX Pointer to text record +// EDX Pointer to string +// ECX Maximum length of string + + PUSH EDX + CALL ReadLine + POP EDX + MOV byte ptr [EDX+ECX],0 +end; + +procedure _ReadLString(var t: TTextRec; var s: AnsiString); +asm + { -> EAX pointer to Text } + { EDX pointer to AnsiString } + + PUSH EBX + PUSH ESI + MOV EBX,EAX + MOV ESI,EDX + + MOV EAX,EDX + CALL _LStrClr + + SUB ESP,256 + + MOV EAX,EBX + MOV EDX,ESP + MOV ECX,255 + CALL _ReadString + + MOV EAX,ESI + MOV EDX,ESP + CALL _LStrFromString + + CMP byte ptr [ESP],255 + JNE @@exit +@@loop: + + MOV EAX,EBX + MOV EDX,ESP + MOV ECX,255 + CALL _ReadString + + MOV EDX,ESP + PUSH 0 + MOV EAX,ESP + CALL _LStrFromString + + MOV EAX,ESI + MOV EDX,[ESP] + CALL _LStrCat + + MOV EAX,ESP + CALL _LStrClr + POP EAX + + CMP byte ptr [ESP],255 + JE @@loop + +@@exit: + ADD ESP,256 + POP ESI + POP EBX +end; + + +function IsValidMultibyteChar(const Src: PChar; SrcBytes: Integer): Boolean; +{$IFDEF MSWINDOWS} +const + ERROR_NO_UNICODE_TRANSLATION = 1113; // Win32 GetLastError when result = 0 + MB_ERR_INVALID_CHARS = 8; +var + Dest: WideChar; +begin + Result := MultiByteToWideChar(0, MB_ERR_INVALID_CHARS, Src, SrcBytes, @Dest, 1) <> 0; +{$ENDIF} +{$IFDEF LINUX} +begin + Result := mblen(Src, SrcBytes) <> -1; +{$ENDIF} +end; + + +function _ReadWChar(var t: TTextRec): WideChar; +var + scratch: array [0..7] of AnsiChar; + wc: WideChar; + i: Integer; +begin + i := 0; + while i < High(scratch) do + begin + scratch[i] := _ReadChar(t); + Inc(i); + scratch[i] := #0; + if IsValidMultibyteChar(scratch, i) then + begin + WCharFromChar(@wc, 1, scratch, i); + Result := wc; + Exit; + end; + end; + SetInOutRes(106); // Invalid Input + Result := #0; +end; + + +procedure _ReadWCString(var t: TTextRec; s: PWideChar; maxBytes: Longint); +var + i, maxLen: Integer; + wc: WideChar; +begin + if s = nil then Exit; + i := 0; + maxLen := maxBytes div sizeof(WideChar); + while i < maxLen do + begin + wc := _ReadWChar(t); + case Integer(wc) of + cEOF: if _EOFText(t) then Break; + cLF : begin + Dec(t.BufPos); + Break; + end; + cCR : if Byte(t.BufPtr[t.BufPos]) = cLF then + begin + Dec(t.BufPos); + Break; + end; + end; + s[i] := wc; + Inc(i); + end; + s[i] := #0; +end; + +procedure _ReadWString(var t: TTextRec; var s: WideString); +var + Temp: AnsiString; +begin + _ReadLString(t, Temp); + s := Temp; +end; + +function _ReadExt(var t: TTextRec): Extended; +asm +// -> EAX Pointer to text record +// <- FST(0) Result + + PUSH EBX + PUSH ESI + PUSH EDI + SUB ESP,68 // var numbuf: array[0..64] of char; + + MOV ESI,EAX + CALL _SeekEof + DEC AL + JZ @@eof + + MOV EDI,ESP // EDI -> numBuf[0] + MOV BL,64 +@@loop: + MOV EAX,ESI + CALL _ReadChar + CMP AL,' ' + JBE @@endNum + STOSB + DEC BL + JNZ @@loop +@@convert: + MOV byte ptr [EDI],0 + MOV EAX,ESP // EAX -> numBuf + PUSH EDX // allocate code result + MOV EDX,ESP // pass pointer to code + CALL _ValExt // convert + POP EDX // pop code result into EDX + TEST EDX,EDX + JZ @@exit + MOV EAX,106 + CALL SetInOutRes + JMP @@exit + +@@endNum: + CMP AH,cEOF + JE @@convert + DEC [ESI].TTextRec.BufPos + JMP @@convert + +@@eof: + FLDZ +@@exit: + ADD ESP,68 + POP EDI + POP ESI + POP EBX +end; + +procedure _ReadLn(var t: TTextRec); +asm +// -> EAX Pointer to text record + + PUSH EBX + MOV EBX,EAX +@@loop: + MOV EAX,EBX + CALL _ReadChar + + CMP AL,cLF // accept LF as end of line + JE @@exit + CMP AH,cEOF + JE @@eof + CMP AL,cCR + JNE @@loop + + MOV EAX,EBX + CALL _ReadChar + + CMP AL,cLF // accept CR+LF as end of line + JE @@exit + CMP AH,cEOF // accept CR+EOF as end of line + JE @@eof + DEC [EBX].TTextRec.BufPos + JMP @@loop // else CR+ anything else is not a line break. + +@@exit: +@@eof: + POP EBX +end; + +procedure _Rename(var f: TFileRec; newName: PChar); +var + I: Integer; +begin + if f.Mode = fmClosed then + begin + if newName = nil then newName := ''; +{$IFDEF LINUX} + if __rename(f.Name, newName) = 0 then +{$ENDIF} +{$IFDEF MSWINDOWS} + if MoveFileA(f.Name, newName) then +{$ENDIF} + begin + I := 0; + while (newName[I] <> #0) and (I < High(f.Name)) do + begin + f.Name[I] := newName[I]; + Inc(I); + end + end + else + SetInOutRes(GetLastError); + end + else + SetInOutRes(102); +end; + +procedure Release; +begin + Error(reInvalidPtr); +end; + +function _CloseFile(var f: TFileRec): Integer; +begin + f.Mode := fmClosed; + Result := 0; + if not InternalClose(f.Handle) then + begin + InOutError; + Result := 1; + end; +end; + +function OpenFile(var f: TFileRec; recSiz: Longint; mode: Longint): Integer; +{$IFDEF LINUX} +var + Flags: Integer; +begin + Result := 0; + if (f.Mode >= fmClosed) and (f.Mode <= fmInOut) then + begin + if f.Mode <> fmClosed then // not yet closed: close it + begin + Result := TFileIOFunc(f.CloseFunc)(f); + if Result <> 0 then + SetInOutRes(Result); + end; + + if recSiz <= 0 then + SetInOutRes(106); + + f.RecSize := recSiz; + f.InOutFunc := @FileNopProc; + + if f.Name[0] <> #0 then + begin + f.CloseFunc := @_CloseFile; + case mode of + 1: begin + Flags := O_APPEND or O_WRONLY; + f.Mode := fmOutput; + end; + 2: begin + Flags := O_RDWR; + f.Mode := fmInOut; + end; + 3: begin + Flags := O_CREAT or O_TRUNC or O_RDWR; + f.Mode := fmInOut; + end; + else + Flags := O_RDONLY; + f.Mode := fmInput; + end; + + f.Handle := __open(f.Name, Flags, FileAccessRights); + end + else // stdin or stdout + begin + f.CloseFunc := @FileNopProc; + if mode = 3 then + f.Handle := STDOUT_FILENO + else + f.Handle := STDIN_FILENO; + end; + + if f.Handle = -1 then + begin + f.Mode := fmClosed; + InOutError; + end; + end + else + SetInOutRes(102); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +const + ShareTab: array [0..7] of Integer = + (FILE_SHARE_READ OR FILE_SHARE_WRITE, // OF_SHARE_COMPAT 0x00000000 + 0, // OF_SHARE_EXCLUSIVE 0x00000010 + FILE_SHARE_READ, // OF_SHARE_DENY_WRITE 0x00000020 + FILE_SHARE_WRITE, // OF_SHARE_DENY_READ 0x00000030 + FILE_SHARE_READ OR FILE_SHARE_WRITE, // OF_SHARE_DENY_NONE 0x00000040 + 0,0,0); +asm +//-> EAX Pointer to file record +// EDX Record size +// ECX File mode + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EDX + MOV EDI,ECX + XOR EDX,EDX + MOV EBX,EAX + + MOV DX,[EAX].TFileRec.Mode + SUB EDX,fmClosed + JE @@alreadyClosed + CMP EDX,fmInOut-fmClosed + JA @@notAssignedError + +// not yet closed: close it. File parameter is still in EAX + + CALL [EBX].TFileRec.CloseFunc + TEST EAX,EAX + JE @@alreadyClosed + CALL SetInOutRes + +@@alreadyClosed: + + MOV [EBX].TFileRec.Mode,fmInOut + MOV [EBX].TFileRec.RecSize,ESI + MOV [EBX].TFileRec.CloseFunc,offset _CloseFile + MOV [EBX].TFileRec.InOutFunc,offset FileNopProc + + CMP byte ptr [EBX].TFileRec.Name,0 + JE @@isCon + + MOV EAX,GENERIC_READ OR GENERIC_WRITE + MOV DL,FileMode + AND EDX,070H + SHR EDX,4-2 + MOV EDX,dword ptr [shareTab+EDX] + MOV ECX,CREATE_ALWAYS + + SUB EDI,3 + JE @@calledByRewrite + + MOV ECX,OPEN_EXISTING + INC EDI + JE @@skip + + MOV EAX,GENERIC_WRITE + INC EDI + MOV [EBX].TFileRec.Mode,fmOutput + JE @@skip + + MOV EAX,GENERIC_READ + MOV [EBX].TFileRec.Mode,fmInput + +@@skip: +@@calledByRewrite: + +// CreateFile(t.FileName, EAX, EDX, Nil, ECX, FILE_ATTRIBUTE_NORMAL, 0); + + PUSH 0 + PUSH FILE_ATTRIBUTE_NORMAL + PUSH ECX + PUSH 0 + PUSH EDX + PUSH EAX + LEA EAX,[EBX].TFileRec.Name + PUSH EAX + CALL CreateFileA +@@checkHandle: + CMP EAX,-1 + JZ @@error + + MOV [EBX].TFileRec.Handle,EAX + JMP @@exit + +@@isCon: + MOV [EBX].TFileRec.CloseFunc,offset FileNopProc + CMP EDI,3 + JE @@output + PUSH STD_INPUT_HANDLE + JMP @@1 +@@output: + PUSH STD_OUTPUT_HANDLE +@@1: + CALL GetStdHandle + JMP @@checkHandle + +@@notAssignedError: + MOV EAX,102 + JMP @@errExit + +@@error: + MOV [EBX].TFileRec.Mode,fmClosed + CALL GetLastError +@@errExit: + CALL SetInOutRes + +@@exit: + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +function _ResetFile(var f: TFileRec; recSize: Longint): Integer; +var + m: Byte; +begin + m := FileMode and 3; + if m > 2 then m := 2; + Result := OpenFile(f, recSize, m); +end; + +function _RewritFile(var f: TFileRec; recSize: Longint): Integer; +begin + Result := OpenFile(f, recSize, 3); +end; + +procedure _Seek(var f: TFileRec; recNum: Cardinal); +{$IFDEF LINUX} +begin + if (f.Mode >= fmInput) and (f.Mode <= fmInOut) then + begin + if _lseek(f.Handle, f.RecSize * recNum, SEEK_SET) = -1 then + InOutError; + end + else + SetInOutRes(103); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm +// -> EAX Pointer to file variable +// EDX Record number + + MOV ECX,EAX + MOVZX EAX,[EAX].TFileRec.Mode // check whether file is open + SUB EAX,fmInput + CMP EAX,fmInOut-fmInput + JA @@fileNotOpen + +// SetFilePointer(f.Handle, recNum*f.RecSize, FILE_BEGIN + PUSH FILE_BEGIN // pass dwMoveMethod + MOV EAX,[ECX].TFileRec.RecSize + MUL EDX + PUSH 0 // pass lpDistanceToMoveHigh + PUSH EAX // pass lDistanceToMove + PUSH [ECX].TFileRec.Handle // pass hFile + CALL SetFilePointer // get current position + INC EAX + JZ InOutError + JMP @@exit + +@@fileNotOpen: + MOV EAX,103 + JMP SetInOutRes + +@@exit: +end; +{$ENDIF} + +function _SeekEof(var t: TTextRec): Boolean; +asm +// -> EAX Pointer to text record +// <- AL Boolean result + + PUSH EBX + MOV EBX,EAX +@@loop: + MOV EAX,EBX + CALL _ReadChar + CMP AL,' ' + JA @@endloop + CMP AH,cEOF + JE @@eof + JMP @@loop +@@eof: + MOV AL,1 + JMP @@exit + +@@endloop: + DEC [EBX].TTextRec.BufPos + XOR AL,AL +@@exit: + POP EBX +end; + +function _SeekEoln(var t: TTextRec): Boolean; +asm +// -> EAX Pointer to text record +// <- AL Boolean result + + PUSH EBX + MOV EBX,EAX +@@loop: + MOV EAX,EBX + CALL _ReadChar + CMP AL,' ' + JA @@falseExit + CMP AH,cEOF + JE @@eof + CMP AL,cLF + JE @@trueExit + CMP AL,cCR + JNE @@loop + +@@trueExit: + MOV AL,1 + JMP @@exitloop + +@@falseExit: + XOR AL,AL +@@exitloop: + DEC [EBX].TTextRec.BufPos + JMP @@exit + +@@eof: + MOV AL,1 +@@exit: + POP EBX +end; + +procedure _SetTextBuf(var t: TTextRec; p: Pointer; size: Longint); +begin + t.BufPtr := P; + t.BufSize := size; + t.BufPos := 0; + t.BufEnd := 0; +end; + +procedure _StrLong(val, width: Longint; s: PShortString); +{$IFDEF PUREPASCAL} +var + I: Integer; + sign: Longint; + a: array [0..19] of char; + P: PChar; +begin + sign := val; + val := Abs(val); + I := 0; + repeat + a[I] := Chr((val mod 10) + Ord('0')); + Inc(I); + val := val div 10; + until val = 0; + + if sign < 0 then + begin + a[I] := '-'; + Inc(I); + end; + + if width < I then + width := I; + if width > 255 then + width := 255; + s^[0] := Chr(width); + P := @S^[1]; + while width > I do + begin + P^ := ' '; + Inc(P); + Dec(width); + end; + repeat + Dec(I); + P^ := a[I]; + Inc(P); + until I <= 0; +end; +{$ELSE} +asm +{ PROCEDURE _StrLong( val: Longint; width: Longint; VAR s: ShortString ); + ->EAX Value + EDX Width + ECX Pointer to string } + + PUSH EBX { VAR i: Longint; } + PUSH ESI { VAR sign : Longint; } + PUSH EDI + PUSH EDX { store width on the stack } + SUB ESP,20 { VAR a: array [0..19] of Char; } + + MOV EDI,ECX + + MOV ESI,EAX { sign := val } + + CDQ { val := Abs(val); canned sequence } + XOR EAX,EDX + SUB EAX,EDX + + MOV ECX,10 + XOR EBX,EBX { i := 0; } + +@@repeat1: { repeat } + XOR EDX,EDX { a[i] := Chr( val MOD 10 + Ord('0') );} + + DIV ECX { val := val DIV 10; } + + ADD EDX,'0' + MOV [ESP+EBX],DL + INC EBX { i := i + 1; } + TEST EAX,EAX { until val = 0; } + JNZ @@repeat1 + + TEST ESI,ESI + JGE @@2 + MOV byte ptr [ESP+EBX],'-' + INC EBX +@@2: + MOV [EDI],BL { s^++ := Chr(i); } + INC EDI + + MOV ECX,[ESP+20] { spaceCnt := width - i; } + CMP ECX,255 + JLE @@3 + MOV ECX,255 +@@3: + SUB ECX,EBX + JLE @@repeat2 { for k := 1 to spaceCnt do s^++ := ' '; } + ADD [EDI-1],CL + MOV AL,' ' + REP STOSB + +@@repeat2: { repeat } + MOV AL,[ESP+EBX-1] { s^ := a[i-1]; } + MOV [EDI],AL + INC EDI { s := s + 1 } + DEC EBX { i := i - 1; } + JNZ @@repeat2 { until i = 0; } + + ADD ESP,20+4 + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +procedure _Str0Long(val: Longint; s: PShortString); +begin + _StrLong(val, 0, s); +end; + +procedure _Truncate(var f: TFileRec); +{$IFDEF LINUX} +begin + if (f.Mode and fmOutput) = fmOutput then // fmOutput or fmInOut + begin + if _ftruncate(f.Handle, _lseek(f.Handle, 0, SEEK_CUR)) = -1 then + InOutError; + end + else + SetInOutRes(103); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm +// -> EAX Pointer to text or file variable + + MOVZX EDX,[EAX].TFileRec.Mode // check whether file is open + SUB EDX,fmInput + CMP EDX,fmInOut-fmInput + JA @@fileNotOpen + + PUSH [EAX].TFileRec.Handle + CALL SetEndOfFile + DEC EAX + JZ @@exit + JMP InOutError + +@@fileNotOpen: + MOV EAX,103 + JMP SetInOutRes + +@@exit: +end; +{$ENDIF} + +function _ValLong(const s: String; var code: Integer): Longint; +{$IFDEF PUREPASCAL} +var + I: Integer; + Negative, Hex: Boolean; +begin + I := 1; + code := -1; + Result := 0; + Negative := False; + Hex := False; + while (I <= Length(s)) and (s[I] = ' ') do Inc(I); + if I > Length(s) then Exit; + case s[I] of + '$', + 'x', + 'X': begin + Hex := True; + Inc(I); + end; + '0': begin + Hex := (Length(s) > I) and (UpCase(s[I+1]) = 'X'); + if Hex then Inc(I,2); + end; + '-': begin + Negative := True; + Inc(I); + end; + '+': Inc(I); + end; + if Hex then + while I <= Length(s) do + begin + if Result > (High(Result) div 16) then + begin + code := I; + Exit; + end; + case s[I] of + '0'..'9': Result := Result * 16 + Ord(s[I]) - Ord('0'); + 'a'..'f': Result := Result * 16 + Ord(s[I]) - Ord('a') + 10; + 'A'..'F': Result := Result * 16 + Ord(s[I]) - Ord('A') + 10; + else + code := I; + Exit; + end; + end + else + while I <= Length(s) do + begin + if Result > (High(Result) div 10) then + begin + code := I; + Exit; + end; + Result := Result * 10 + Ord(s[I]) - Ord('0'); + Inc(I); + end; + if Negative then + Result := -Result; + code := 0; +end; +{$ELSE} +asm +{ FUNCTION _ValLong( s: AnsiString; VAR code: Integer ) : Longint; } +{ ->EAX Pointer to string } +{ EDX Pointer to code result } +{ <-EAX Result } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX + PUSH EAX { save for the error case } + + TEST EAX,EAX + JE @@empty + + XOR EAX,EAX + XOR EBX,EBX + MOV EDI,07FFFFFFFH / 10 { limit } + +@@blankLoop: + MOV BL,[ESI] + INC ESI + CMP BL,' ' + JE @@blankLoop + +@@endBlanks: + MOV CH,0 + CMP BL,'-' + JE @@minus + CMP BL,'+' + JE @@plus + CMP BL,'$' + JE @@dollar + + CMP BL, 'x' + JE @@dollar + CMP BL, 'X' + JE @@dollar + CMP BL, '0' + JNE @@firstDigit + MOV BL, [ESI] + INC ESI + CMP BL, 'x' + JE @@dollar + CMP BL, 'X' + JE @@dollar + TEST BL, BL + JE @@endDigits + JMP @@digLoop + +@@firstDigit: + TEST BL,BL + JE @@error + +@@digLoop: + SUB BL,'0' + CMP BL,9 + JA @@error + CMP EAX,EDI { value > limit ? } + JA @@overFlow + LEA EAX,[EAX+EAX*4] + ADD EAX,EAX + ADD EAX,EBX { fortunately, we can't have a carry } + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JNE @@digLoop + +@@endDigits: + DEC CH + JE @@negate + TEST EAX,EAX + JGE @@successExit + JMP @@overFlow + +@@empty: + INC ESI + JMP @@error + +@@negate: + NEG EAX + JLE @@successExit + JS @@successExit { to handle 2**31 correctly, where the negate overflows } + +@@error: +@@overFlow: + POP EBX + SUB ESI,EBX + JMP @@exit + +@@minus: + INC CH +@@plus: + MOV BL,[ESI] + INC ESI + JMP @@firstDigit + +@@dollar: + MOV EDI,0FFFFFFFH + + MOV BL,[ESI] + INC ESI + TEST BL,BL + JZ @@empty + +@@hDigLoop: + CMP BL,'a' + JB @@upper + SUB BL,'a' - 'A' +@@upper: + SUB BL,'0' + CMP BL,9 + JBE @@digOk + SUB BL,'A' - '0' + CMP BL,5 + JA @@error + ADD BL,10 +@@digOk: + CMP EAX,EDI + JA @@overFlow + SHL EAX,4 + ADD EAX,EBX + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JNE @@hDigLoop + +@@successExit: + POP ECX { saved copy of string pointer } + XOR ESI,ESI { signal no error to caller } + +@@exit: + MOV [EDX],ESI + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +function _WriteRec(var f: TFileRec; buffer: Pointer): Pointer; +{$IFDEF LINUX} +var + Dummy: Integer; +begin + _BlockWrite(f, Buffer, 1, Dummy); + Result := @F; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm +// -> EAX Pointer to file variable +// EDX Pointer to buffer +// <- EAX Pointer to file variable + PUSH EBX + + MOV EBX,EAX + + MOVZX EAX,[EAX].TFileRec.Mode + SUB EAX,fmOutput + CMP EAX,fmInOut-fmOutput // File must be fmInOut or fmOutput + JA @@fileNotOpen + +// WriteFile(f.Handle, buffer, f.RecSize, @result, Nil); + + PUSH 0 // space for OS result + MOV EAX,ESP + + PUSH 0 // pass lpOverlapped + PUSH EAX // pass @result + PUSH [EBX].TFileRec.RecSize // pass nNumberOfBytesToRead + PUSH EDX // pass lpBuffer + PUSH [EBX].TFileRec.Handle // pass hFile + CALL WriteFile + POP EDX // pop result + DEC EAX // check EAX = TRUE + JNZ @@error + + CMP EDX,[EBX].TFileRec.RecSize // result = f.RecSize ? + JE @@exit + +@@writeError: + MOV EAX,101 + JMP @@errExit + +@@fileNotOpen: + MOV EAX,5 + JMP @@errExit + +@@error: + CALL GetLastError +@@errExit: + CALL SetInOutRes +@@exit: + MOV EAX,EBX + POP EBX +end; +{$ENDIF} + +// If the file is Output or ErrOutput std variable, try to open it +// Otherwise, runtime error. +function TryOpenForOutput(var t: TTextRec): Boolean; +begin + if (@t = @Output) or (@t = @ErrOutput) then + begin + t.Flags := tfCRLF * Byte(DefaultTextLineBreakStyle); + _RewritText(t); + end; + + Result := t.Mode = fmOutput; + if not Result then + SetInOutRes(105); +end; + +function _WriteBytes(var t: TTextRec; const b; cnt : Longint): Pointer; +{$IFDEF PUREPASCAL} +var + P: PChar; + RemainingBytes: Longint; + Temp: Integer; +begin + Result := @t; + if t.Mode <> fmOutput and not TryOpenForOutput(t) then Exit; + + P := t.BufPtr + t.BufPos; + RemainingBytes := t.BufSize - t.BufPos; + while RemainingBytes <= cnt do + begin + Inc(t.BufPos, RemainingBytes); + Dec(cnt, RemainingBytes); + Move(B, P^, RemainingBytes); + Temp := TTextIOFunc(t.InOutFunc)(t); + if Temp <> 0 then + begin + SetInOutRes(Temp); + Exit; + end; + P := t.BufPtr + t.BufPos; + RemainingBytes := t.BufSize - t.BufPos; + end; + Inc(t.BufPos, cnt); + Move(B, P^, cnt); +end; +{$ELSE} +asm +// -> EAX Pointer to file record +// EDX Pointer to buffer +// ECX Number of bytes to write +// <- EAX Pointer to file record + + PUSH ESI + PUSH EDI + + MOV ESI,EDX + + CMP [EAX].TTextRec.Mode,fmOutput + JE @@loop + PUSH EAX + PUSH EDX + PUSH ECX + CALL TryOpenForOutput + TEST AL,AL + POP ECX + POP EDX + POP EAX + JE @@exit + +@@loop: + MOV EDI,[EAX].TTextRec.BufPtr + ADD EDI,[EAX].TTextRec.BufPos + +// remainingBytes = t.bufSize - t.bufPos + + MOV EDX,[EAX].TTextRec.BufSize + SUB EDX,[EAX].TTextRec.BufPos + +// if (remainingBytes <= cnt) + + CMP EDX,ECX + JG @@1 + +// t.BufPos += remainingBytes, cnt -= remainingBytes + + ADD [EAX].TTextRec.BufPos,EDX + SUB ECX,EDX + +// copy remainingBytes, advancing ESI + + PUSH EAX + PUSH ECX + MOV ECX,EDX + REP MOVSB + + CALL [EAX].TTextRec.InOutFunc + TEST EAX,EAX + JNZ @@error + + POP ECX + POP EAX + JMP @@loop + +@@error: + CALL SetInOutRes + POP ECX + POP EAX + JMP @@exit +@@1: + ADD [EAX].TTextRec.BufPos,ECX + REP MOVSB + +@@exit: + POP EDI + POP ESI +end; +{$ENDIF} + +function _WriteSpaces(var t: TTextRec; cnt: Longint): Pointer; +{$IFDEF PUREPASCAL} +const + s64Spaces = ' '; +begin + Result := @t; + while cnt > 64 do + begin + _WriteBytes(t, s64Spaces, 64); + if InOutRes <> 0 then Exit; + Dec(cnt, 64); + end; + if cnt > 0 then + _WriteBytes(t, s64Spaces, cnt); +end; +{$ELSE} +const + spCnt = 64; +asm +// -> EAX Pointer to text record +// EDX Number of spaces (<= 0: None) + + MOV ECX,EDX +@@loop: +{$IFDEF PIC} + LEA EDX, [EBX] + offset @@spBuf +{$ELSE} + MOV EDX,offset @@spBuf +{$ENDIF} + + CMP ECX,spCnt + JLE @@1 + + SUB ECX,spCnt + PUSH EAX + PUSH ECX + MOV ECX,spCnt + CALL _WriteBytes + CALL SysInit.@GetTLS + CMP [EAX].InOutRes,0 + JNE @@error + POP ECX + POP EAX + JMP @@loop + +@@error: + POP ECX + POP EAX + JMP @@exit + +@@spBuf: // 64 spaces + DB ' '; +@@1: + TEST ECX,ECX + JG _WriteBytes +@@exit: +end; +{$ENDIF} + +function _Write0Char(var t: TTextRec; c: Char): Pointer; +{$IFDEF PUREPASCAL} +var + Temp: Integer; +begin + Result := @t; + if not TryOpenForOutput(t) then Exit; + + if t.BufPos >= t.BufSize then + begin + Temp := TTextIOFunc(t.InOutFunc)(t); + if Temp <> 0 then + begin + SetInOutRes(Temp); + Exit; + end; + end; + + t.BufPtr[t.BufPos] := c; + Inc(t.BufPos); +end; +{$ELSE} +asm +// -> EAX Pointer to text record +// DL Character + + CMP [EAX].TTextRec.Mode,fmOutput + JE @@loop + PUSH EAX + PUSH EDX + CALL TryOpenForOutput + TEST AL,AL + POP EDX + POP EAX + JNE @@loop + JMP @@exit + +@@flush: + PUSH EAX + PUSH EDX + CALL [EAX].TTextRec.InOutFunc + TEST EAX,EAX + JNZ @@error + POP EDX + POP EAX + JMP @@loop + +@@error: + CALL SetInOutRes + POP EDX + POP EAX + JMP @@exit + +@@loop: + MOV ECX,[EAX].TTextRec.BufPos + CMP ECX,[EAX].TTextRec.BufSize + JGE @@flush + + ADD ECX,[EAX].TTextRec.BufPtr + MOV [ECX],DL + + INC [EAX].TTextRec.BufPos +@@exit: +end; +{$ENDIF} + +function _WriteChar(var t: TTextRec; c: Char; width: Integer): Pointer; +begin + _WriteSpaces(t, width-1); + Result := _WriteBytes(t, c, 1); +end; + +function _WriteBool(var t: TTextRec; val: Boolean; width: Longint): Pointer; +const + BoolStrs: array [Boolean] of ShortString = ('FALSE', 'TRUE'); +begin + Result := _WriteString(t, BoolStrs[val], width); +end; + +function _Write0Bool(var t: TTextRec; val: Boolean): Pointer; +begin + Result := _WriteBool(t, val, 0); +end; + +function _WriteLong(var t: TTextRec; val, width: Longint): Pointer; +var + S: string[31]; +begin + Str(val:0, S); + Result := _WriteString(t, S, width); +end; + +function _Write0Long(var t: TTextRec; val: Longint): Pointer; +begin + Result := _WriteLong(t, val, 0); +end; + +function _Write0String(var t: TTextRec; const s: ShortString): Pointer; +begin + Result := _WriteBytes(t, S[1], Byte(S[0])); +end; + +function _WriteString(var t: TTextRec; const s: ShortString; width: Longint): Pointer; +begin + _WriteSpaces(t, Width - Byte(S[0])); + Result := _WriteBytes(t, S[1], Byte(S[0])); +end; + +function _Write0CString(var t: TTextRec; s: PChar): Pointer; +begin + Result := _WriteCString(t, s, 0); +end; + +function _WriteCString(var t: TTextRec; s: PChar; width: Longint): Pointer; +var + len: Longint; +begin + len := _strlen(s); + _WriteSpaces(t, width - len); + Result := _WriteBytes(t, s^, len); +end; + +procedure _Write2Ext; +asm +{ PROCEDURE _Write2Ext( VAR t: Text; val: Extended; width, prec: Longint); + ->EAX Pointer to file record + [ESP+4] Extended value + EDX Field width + ECX precision (<0: scientific, >= 0: fixed point) } + + FLD tbyte ptr [ESP+4] { load value } + SUB ESP,256 { VAR s: String; } + + PUSH EAX + PUSH EDX + +{ Str( val, width, prec, s ); } + + SUB ESP,12 + FSTP tbyte ptr [ESP] { pass value } + MOV EAX,EDX { pass field width } + MOV EDX,ECX { pass precision } + LEA ECX,[ESP+8+12] { pass destination string } + CALL _Str2Ext + +{ Write( t, s, width ); } + + POP ECX { pass width } + POP EAX { pass text } + MOV EDX,ESP { pass string } + CALL _WriteString + + ADD ESP,256 + RET 12 +end; + +procedure _Write1Ext; +asm +{ PROCEDURE _Write1Ext( VAR t: Text; val: Extended; width: Longint); + -> EAX Pointer to file record + [ESP+4] Extended value + EDX Field width } + + OR ECX,-1 + JMP _Write2Ext +end; + +procedure _Write0Ext; +asm +{ PROCEDURE _Write0Ext( VAR t: Text; val: Extended); + ->EAX Pointer to file record + [ESP+4] Extended value } + + MOV EDX,23 { field width } + OR ECX,-1 + JMP _Write2Ext +end; + +function _WriteLn(var t: TTextRec): Pointer; +var + Buf: array [0..1] of Char; +begin + if (t.flags and tfCRLF) <> 0 then + begin + Buf[0] := #13; + Buf[1] := #10; + Result := _WriteBytes(t, Buf, 2); + end + else + begin + Buf[0] := #10; + Result := _WriteBytes(t, Buf, 1); + end; + _Flush(t); +end; + +procedure __CToPasStr(Dest: PShortString; const Source: PChar); +begin + __CLenToPasStr(Dest, Source, 255); +end; + +procedure __CLenToPasStr(Dest: PShortString; const Source: PChar; MaxLen: Integer); +{$IFDEF PUREPASCAL} +var + I: Integer; +begin + I := 0; + if MaxLen > 255 then MaxLen := 255; + while (Source[I] <> #0) and (I <= MaxLen) do + begin + Dest^[I+1] := Source[I]; + Inc(I); + end; + if I > 0 then Dec(I); + Byte(Dest^[0]) := I; +end; +{$ELSE} +asm +{ ->EAX Pointer to destination } +{ EDX Pointer to source } +{ ECX cnt } + + PUSH EBX + PUSH EAX { save destination } + + CMP ECX,255 + JBE @@loop + MOV ECX,255 +@@loop: + MOV BL,[EDX] { ch = *src++; } + INC EDX + TEST BL,BL { if (ch == 0) break } + JE @@endLoop + INC EAX { *++dest = ch; } + MOV [EAX],BL + DEC ECX { while (--cnt != 0) } + JNZ @@loop + +@@endLoop: + POP EDX + SUB EAX,EDX + MOV [EDX],AL + POP EBX +end; +{$ENDIF} + +procedure __ArrayToPasStr(Dest: PShortString; const Source: PChar; Len: Integer); +begin + if Len > 255 then Len := 255; + Byte(Dest^[0]) := Len; + Move(Source^, Dest^[1], Len); +end; + +procedure __PasToCStr(const Source: PShortString; const Dest: PChar); +begin + Move(Source^[1], Dest^, Byte(Source^[0])); + Dest[Byte(Source^[0])] := #0; +end; + +procedure _SetElem; +asm + { PROCEDURE _SetElem( VAR d: SET; elem, size: Byte); } + { EAX = dest address } + { DL = element number } + { CL = size of set } + + PUSH EBX + PUSH EDI + + MOV EDI,EAX + + XOR EBX,EBX { zero extend set size into ebx } + MOV BL,CL + MOV ECX,EBX { and use it for the fill } + + XOR EAX,EAX { for zero fill } + REP STOSB + + SUB EDI,EBX { point edi at beginning of set again } + + INC EAX { eax is still zero - make it 1 } + MOV CL,DL + ROL AL,CL { generate a mask } + SHR ECX,3 { generate the index } + CMP ECX,EBX { if index >= siz then exit } + JAE @@exit + OR [EDI+ECX],AL{ set bit } + +@@exit: + POP EDI + POP EBX +end; + +procedure _SetRange; +asm +{ PROCEDURE _SetRange( lo, hi, size: Byte; VAR d: SET ); } +{ ->AL low limit of range } +{ DL high limit of range } +{ ECX Pointer to set } +{ AH size of set } + + PUSH EBX + PUSH ESI + PUSH EDI + + XOR EBX,EBX { EBX = set size } + MOV BL,AH + MOVZX ESI,AL { ESI = low zero extended } + MOVZX EDX,DL { EDX = high zero extended } + MOV EDI,ECX + +{ clear the set } + + MOV ECX,EBX + XOR EAX,EAX + REP STOSB + +{ prepare for setting the bits } + + SUB EDI,EBX { point EDI at start of set } + SHL EBX,3 { EBX = highest bit in set + 1 } + CMP EDX,EBX + JB @@inrange + LEA EDX,[EBX-1] { ECX = highest bit in set } + +@@inrange: + CMP ESI,EDX { if lo > hi then exit; } + JA @@exit + + DEC EAX { loMask = 0xff << (lo & 7) } + MOV ECX,ESI + AND CL,07H + SHL AL,CL + + SHR ESI,3 { loIndex = lo >> 3; } + + MOV CL,DL { hiMask = 0xff >> (7 - (hi & 7)); } + NOT CL + AND CL,07 + SHR AH,CL + + SHR EDX,3 { hiIndex = hi >> 3; } + + ADD EDI,ESI { point EDI to set[loIndex] } + MOV ECX,EDX + SUB ECX,ESI { if ((inxDiff = (hiIndex - loIndex)) == 0) } + JNE @@else + + AND AL,AH { set[loIndex] = hiMask & loMask; } + MOV [EDI],AL + JMP @@exit + +@@else: + STOSB { set[loIndex++] = loMask; } + DEC ECX + MOV AL,0FFH { while (loIndex < hiIndex) } + REP STOSB { set[loIndex++] = 0xff; } + MOV [EDI],AH { set[hiIndex] = hiMask; } + +@@exit: + POP EDI + POP ESI + POP EBX +end; + +procedure _SetEq; +asm +{ FUNCTION _SetEq( CONST l, r: Set; size: Byte): ConditionCode; } +{ EAX = left operand } +{ EDX = right operand } +{ CL = size of set } + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + AND ECX,0FFH + REP CMPSB + + POP EDI + POP ESI +end; + +procedure _SetLe; +asm +{ FUNCTION _SetLe( CONST l, r: Set; size: Byte): ConditionCode; } +{ EAX = left operand } +{ EDX = right operand } +{ CL = size of set (>0 && <= 32) } + +@@loop: + MOV CH,[EDX] + NOT CH + AND CH,[EAX] + JNE @@exit + INC EDX + INC EAX + DEC CL + JNZ @@loop +@@exit: +end; + +procedure _SetIntersect; +asm +{ PROCEDURE _SetIntersect( VAR dest: Set; CONST src: Set; size: Byte);} +{ EAX = destination operand } +{ EDX = source operand } +{ CL = size of set (0 < size <= 32) } + +@@loop: + MOV CH,[EDX] + INC EDX + AND [EAX],CH + INC EAX + DEC CL + JNZ @@loop +end; + +procedure _SetIntersect3; +asm +{ PROCEDURE _SetIntersect3( VAR dest: Set; CONST src: Set; size: Longint; src2: Set);} +{ EAX = destination operand } +{ EDX = source operand } +{ ECX = size of set (0 < size <= 32) } +{ [ESP+4] = 2nd source operand } + + PUSH EBX + PUSH ESI + MOV ESI,[ESP+8+4] +@@loop: + MOV BL,[EDX+ECX-1] + AND BL,[ESI+ECX-1] + MOV [EAX+ECX-1],BL + DEC ECX + JNZ @@loop + + POP ESI + POP EBX +end; + +procedure _SetUnion; +asm +{ PROCEDURE _SetUnion( VAR dest: Set; CONST src: Set; size: Byte); } +{ EAX = destination operand } +{ EDX = source operand } +{ CL = size of set (0 < size <= 32) } + +@@loop: + MOV CH,[EDX] + INC EDX + OR [EAX],CH + INC EAX + DEC CL + JNZ @@loop +end; + +procedure _SetUnion3; +asm +{ PROCEDURE _SetUnion3( VAR dest: Set; CONST src: Set; size: Longint; src2: Set);} +{ EAX = destination operand } +{ EDX = source operand } +{ ECX = size of set (0 < size <= 32) } +{ [ESP+4] = 2nd source operand } + + PUSH EBX + PUSH ESI + MOV ESI,[ESP+8+4] +@@loop: + MOV BL,[EDX+ECX-1] + OR BL,[ESI+ECX-1] + MOV [EAX+ECX-1],BL + DEC ECX + JNZ @@loop + + POP ESI + POP EBX +end; + +procedure _SetSub; +asm +{ PROCEDURE _SetSub( VAR dest: Set; CONST src: Set; size: Byte); } +{ EAX = destination operand } +{ EDX = source operand } +{ CL = size of set (0 < size <= 32) } + +@@loop: + MOV CH,[EDX] + NOT CH + INC EDX + AND [EAX],CH + INC EAX + DEC CL + JNZ @@loop +end; + +procedure _SetSub3; +asm +{ PROCEDURE _SetSub3( VAR dest: Set; CONST src: Set; size: Longint; src2: Set);} +{ EAX = destination operand } +{ EDX = source operand } +{ ECX = size of set (0 < size <= 32) } +{ [ESP+4] = 2nd source operand } + + PUSH EBX + PUSH ESI + MOV ESI,[ESP+8+4] +@@loop: + MOV BL,[ESI+ECX-1] + NOT BL + AND BL,[EDX+ECX-1] + MOV [EAX+ECX-1],BL + DEC ECX + JNZ @@loop + + POP ESI + POP EBX +end; + +procedure _SetExpand; +asm +{ PROCEDURE _SetExpand( CONST src: Set; VAR dest: Set; lo, hi: Byte); } +{ ->EAX Pointer to source (packed set) } +{ EDX Pointer to destination (expanded set) } +{ CH high byte of source } +{ CL low byte of source } + +{ algorithm: } +{ clear low bytes } +{ copy high-low+1 bytes } +{ clear 31-high bytes } + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + MOV EDX,ECX { save low, high in dl, dh } + XOR ECX,ECX + XOR EAX,EAX + + MOV CL,DL { clear low bytes } + REP STOSB + + MOV CL,DH { copy high - low bytes } + SUB CL,DL + REP MOVSB + + MOV CL,32 { copy 32 - high bytes } + SUB CL,DH + REP STOSB + + POP EDI + POP ESI +end; + +procedure _EmitDigits; +const + tenE17: Double = 1e17; + tenE18: Double = 1e18; +asm +// -> FST(0) Value, 0 <= value < 10.0 +// EAX Count of digits to generate +// EDX Pointer to digit buffer + + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX +{$ELSE} + XOR EBX,EBX +{$ENDIF} + PUSH EDI + MOV EDI,EDX + MOV ECX,EAX + + SUB ESP,10 // VAR bcdBuf: array [0..9] of Byte + MOV byte ptr [EDI],'0' // digBuf[0] := '0'// + FMUL qword ptr [EBX] + offset tenE17 // val := Round(val*1e17); + FRNDINT + + FCOM qword ptr [EBX] + offset tenE18 // if val >= 1e18 then + FSTSW AX + SAHF + JB @@1 + + FSUB qword ptr [EBX] + offset tenE18 // val := val - 1e18; + MOV byte ptr [EDI],'1' // digBuf[0] := '1'; +@@1: + FBSTP tbyte ptr [ESP] // store packed bcd digits in bcdBuf + + MOV EDX,8 + INC EDI + +@@2: + WAIT + MOV AL,[ESP+EDX] // unpack 18 bcd digits in 9 bytes + MOV AH,AL // into 9 words = 18 bytes + SHR AL,4 + AND AH,0FH + ADD AX,'00' + STOSW + DEC EDX + JNS @@2 + + SUB ECX,18 // we need at least digCnt digits + JL @@3 // we have generated 18 + + MOV AL,'0' // if this is not enough, append zeroes + REP STOSB + JMP @@4 // in this case, we don't need to round + +@@3: + ADD EDI,ECX // point EDI to the round digit + CMP byte ptr [EDI],'5' + JL @@4 +@@5: + DEC EDI + INC byte ptr [EDI] + CMP byte ptr [EDI],'9' + JLE @@4 + MOV byte ptr [EDI],'0' + JMP @@5 + +@@4: + ADD ESP,10 + POP EDI + POP EBX +end; + +procedure _ScaleExt; +asm +// -> FST(0) Value +// <- EAX exponent (base 10) +// FST(0) Value / 10**eax +// PIC safe - uses EBX, but only call is to _POW10, which fixes up EBX itself + + PUSH EBX + SUB ESP,12 + + XOR EBX,EBX + +@@normLoop: // loop necessary for denormals + + FLD ST(0) + FSTP tbyte ptr [ESP] + MOV AX,[ESP+8] + TEST AX,AX + JE @@testZero +@@cont: + SUB AX,3FFFH + MOV DX,4D10H // log10(2) * 2**16 + IMUL DX + MOVSX EAX,DX // exp10 = exp2 * log10(2) + NEG EAX + JE @@exit + SUB EBX,EAX + CALL _Pow10 + JMP @@normLoop + +@@testZero: + CMP dword ptr [ESP+4],0 + JNE @@cont + CMP dword ptr [ESP+0],0 + JNE @@cont + +@@exit: + ADD ESP,12 + MOV EAX,EBX + POP EBX +end; + +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 ); +const + MAXDIGS = 256; +asm +// -> [ESP+4] Extended value +// EAX Width +// EDX Precision +// ECX Pointer to string + + FLD tbyte ptr [ESP+4] + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV ESI,EDX + PUSH ECX // save string pointer + SUB ESP,MAXDIGS // VAR digBuf: array [0..MAXDIGS-1] of Char + +// limit width to 255 + + CMP EBX,255 // if width > 255 then width := 255; + JLE @@1 + MOV EBX,255 +@@1: + +// save sign bit in bit 0 of EDI, take absolute value of val, check for +// Nan and infinity. + + FLD ST(0) + FSTP tbyte ptr [ESP] + XOR EAX,EAX + MOV AX,word ptr [ESP+8] + MOV EDI,EAX + SHR EDI,15 + AND AX,7FFFH + CMP AX,7FFFH + JE @@nanInf + FABS + +// if precision < 0 then do scientific else do fixed; + + TEST ESI,ESI + JGE @@fixed + +// the following call finds a decimal exponent and a reduced +// mantissa such that val = mant * 10**exp + + CALL _ScaleExt // val is FST(0), exp is EAX + +// for scientific notation, we have width - 8 significant digits +// however, we can not have less than 2 or more than 18 digits. + +@@scientific: + + MOV ESI,EBX // digCnt := width - 8; + SUB ESI,8 + CMP ESI,2 // if digCnt < 2 then digCnt := 2 + JGE @@2 + MOV ESI,2 + JMP @@3 +@@2: + CMP ESI,18 // else if digCnt > 18 then digCnt := 18; + JLE @@3 + MOV ESI,18 +@@3: + +// _EmitDigits( val, digCnt, digBuf ) + + MOV EDX,ESP // pass digBuf + PUSH EAX // save exponent + MOV EAX,ESI // pass digCnt + CALL _EmitDigits // convert val to ASCII + + MOV EDX,EDI // save sign in EDX + MOV EDI,[ESP+MAXDIGS+4] // load result string pointer + + MOV [EDI],BL // length of result string := width + INC EDI + + MOV AL,' ' // prepare for leading blanks and sign + + MOV ECX,EBX // blankCnt := width - digCnt - 8 + SUB ECX,ESI + SUB ECX,8 + JLE @@4 + + REP STOSB // emit blankCnt blanks +@@4: + SUB [EDI-1],CL // if blankCnt < 0, adjust length + + TEST DL,DL // emit the sign (' ' or '-') + JE @@5 + MOV AL,'-' +@@5: + STOSB + + POP EAX + MOV ECX,ESI // emit digCnt digits + MOV ESI,ESP // point ESI to digBuf + + CMP byte ptr [ESI],'0' + JE @@5a // if rounding overflowed, adjust exponent and ESI + INC EAX + DEC ESI +@@5a: + INC ESI + + MOVSB // emit one digit + MOV byte ptr [EDI],'.' // emit dot + INC EDI // adjust dest pointer + DEC ECX // adjust count + + REP MOVSB + + MOV byte ptr [EDI],'E' + + MOV CL,'+' // emit sign of exponent ('+' or '-') + TEST EAX,EAX + JGE @@6 + MOV CL,'-' + NEG EAX +@@6: + MOV [EDI+1],CL + + XOR EDX,EDX // emit exponent + MOV CX,10 + DIV CX + ADD DL,'0' + MOV [EDI+5],DL + + XOR EDX,EDX + DIV CX + ADD DL,'0' + MOV [EDI+4],DL + + XOR EDX,EDX + DIV CX + ADD DL,'0' + MOV [EDI+3],DL + + ADD AL,'0' + MOV [EDI+2],AL + + JMP @@exit + +@@fixed: + +// FST(0) = value >= 0.0 +// EBX = width +// ESI = precision +// EDI = sign + + CMP ESI,MAXDIGS-40 // else if precision > MAXDIGS-40 then precision := MAXDIGS-40; + JLE @@6a + MOV ESI,MAXDIGS-40 +@@6a: +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + FCOM qword ptr [EAX] + offset Ten + POP EAX +{$ELSE} + FCOM qword ptr ten +{$ENDIF} + FSTSW AX + SAHF + MOV EAX,0 + JB @@7 + + CALL _ScaleExt // val is FST(0), exp is EAX + + CMP EAX,35 // if val is too large, use scientific + JG @@scientific + +@@7: +// FST(0) = scaled value, 0.0 <= value < 10.0 +// EAX = exponent, 0 <= exponent + +// intDigCnt := exponent + 1; + + INC EAX + +// _EmitDigits( value, intDigCnt + precision, digBuf ); + + MOV EDX,ESP + PUSH EAX + ADD EAX,ESI + CALL _EmitDigits + POP EAX + +// Now we need to check whether rounding to the right number of +// digits overflowed, and if so, adjust things accordingly + + MOV EDX,ESI // put precision in EDX + MOV ESI,ESP // point EDI to digBuf + CMP byte ptr [ESI],'0' + JE @@8 + INC EAX + DEC ESI +@@8: + INC ESI + + MOV ECX,EAX // numWidth := sign + intDigCnt; + ADD ECX,EDI + + TEST EDX,EDX // if precision > 0 then + JE @@9 + INC ECX // numWidth := numWidth + 1 + precision + ADD ECX,EDX + + CMP EBX,ECX // if width <= numWidth + JG @@9 + MOV EBX,ECX // width := numWidth +@@9: + PUSH EAX + PUSH EDI + + MOV EDI,[ESP+MAXDIGS+2*4] // point EDI to dest string + + MOV [EDI],BL // store final length in dest string + INC EDI + + SUB EBX,ECX // width := width - numWidth + MOV ECX,EBX + JLE @@10 + + MOV AL,' ' // emit width blanks + REP STOSB +@@10: + SUB [EDI-1],CL // if blankCnt < 0, adjust length + POP EAX + POP ECX + + TEST EAX,EAX + JE @@11 + + MOV byte ptr [EDI],'-' + INC EDI + +@@11: + REP MOVSB // copy intDigCnt digits + + TEST EDX,EDX // if precision > 0 then + JE @@12 + + MOV byte ptr [EDI],'.' // emit '.' + INC EDI + MOV ECX,EDX // emit precision digits + REP MOVSB + +@@12: + +@@exit: + ADD ESP,MAXDIGS + POP ECX + POP EDI + POP ESI + POP EBX + RET 12 + +@@nanInf: +// here: EBX = width, ECX = string pointer, EDI = sign, [ESP] = value + +{$IFDEF PIC} + CALL GetGOT +{$ELSE} + XOR EAX,EAX +{$ENDIF} + FSTP ST(0) + CMP dword ptr [ESP+4],80000000H + LEA ESI,[EAX] + offset nanStr + JNE @@13 + DEC EDI + LEA ESI,[EAX] + offset plusInfStr + JNZ @@13 + LEA ESI,[EAX] + offset minInfStr +@@13: + MOV EDI,ECX + MOV ECX,EBX + MOV [EDI],CL + INC EDI + SUB CL,[ESI] + JBE @@14 + MOV AL,' ' + REP STOSB +@@14: + SUB [EDI-1],CL + MOV CL,[ESI] + INC ESI + REP MOVSB + + JMP @@exit +end; + +procedure _Str0Ext; +asm +// -> [ESP+4] Extended value +// EAX Pointer to string + + MOV ECX,EAX // pass string + MOV EAX,23 // pass default field width + OR EDX,-1 // pass precision -1 + JMP _Str2Ext +end; + +procedure _Str1Ext;//( val: Extended; width: Longint; var s: String ); +asm +// -> [ESP+4] Extended value +// EAX Field width +// EDX Pointer to string + + MOV ECX,EDX + OR EDX,-1 // pass precision -1 + JMP _Str2Ext +end; + +//function _ValExt( s: AnsiString; VAR code: Integer ) : Extended; +procedure _ValExt; +asm +// -> EAX Pointer to string +// EDX Pointer to code result +// <- FST(0) Result + + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX +{$ELSE} + XOR EBX,EBX +{$ENDIF} + PUSH ESI + PUSH EDI + + PUSH EBX // SaveGOT = ESP+8 + MOV ESI,EAX + PUSH EAX // save for the error case + + FLDZ + XOR EAX,EAX + XOR EBX,EBX + XOR EDI,EDI + + PUSH EBX // temp to get digs to fpu + + TEST ESI,ESI + JE @@empty + +@@blankLoop: + MOV BL,[ESI] + INC ESI + CMP BL,' ' + JE @@blankLoop + +@@endBlanks: + MOV CH,0 + CMP BL,'-' + JE @@minus + CMP BL,'+' + JE @@plus + JMP @@firstDigit + +@@minus: + INC CH +@@plus: + MOV BL,[ESI] + INC ESI + +@@firstDigit: + TEST BL,BL + JE @@error + + MOV EDI,[ESP+8] // SaveGOT + +@@digLoop: + SUB BL,'0' + CMP BL,9 + JA @@dotExp + FMUL qword ptr [EDI] + offset Ten + MOV dword ptr [ESP],EBX + FIADD dword ptr [ESP] + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JNE @@digLoop + JMP @@prefinish + +@@dotExp: + CMP BL,'.' - '0' + JNE @@exp + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JE @@prefinish + +// EDI = SaveGot +@@fracDigLoop: + SUB BL,'0' + CMP BL,9 + JA @@exp + FMUL qword ptr [EDI] + offset Ten + MOV dword ptr [ESP],EBX + FIADD dword ptr [ESP] + DEC EAX + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JNE @@fracDigLoop + +@@prefinish: + XOR EDI,EDI + JMP @@finish + +@@exp: + CMP BL,'E' - '0' + JE @@foundExp + CMP BL,'e' - '0' + JNE @@error +@@foundExp: + MOV BL,[ESI] + INC ESI + MOV AH,0 + CMP BL,'-' + JE @@minusExp + CMP BL,'+' + JE @@plusExp + JMP @@firstExpDigit +@@minusExp: + INC AH +@@plusExp: + MOV BL,[ESI] + INC ESI +@@firstExpDigit: + SUB BL,'0' + CMP BL,9 + JA @@error + MOV EDI,EBX + MOV BL,[ESI] + INC ESI + TEST BL,BL + JZ @@endExp +@@expDigLoop: + SUB BL,'0' + CMP BL,9 + JA @@error + LEA EDI,[EDI+EDI*4] + ADD EDI,EDI + ADD EDI,EBX + MOV BL,[ESI] + INC ESI + TEST BL,BL + JNZ @@expDigLoop +@@endExp: + DEC AH + JNZ @@expPositive + NEG EDI +@@expPositive: + MOVSX EAX,AL + +@@finish: + ADD EAX,EDI + PUSH EDX + PUSH ECX + CALL _Pow10 + POP ECX + POP EDX + + DEC CH + JE @@negate + +@@successExit: + + ADD ESP,12 // pop temp and saved copy of string pointer + + XOR ESI,ESI // signal no error to caller + +@@exit: + MOV [EDX],ESI + + POP EDI + POP ESI + POP EBX + RET + +@@negate: + FCHS + JMP @@successExit + +@@empty: + INC ESI + +@@error: + POP EAX + POP EBX + SUB ESI,EBX + ADD ESP,4 + JMP @@exit +end; + +procedure FPower10; +asm + JMP _Pow10 +end; + +//function _Pow10(val: Extended; Power: Integer): Extended; +procedure _Pow10; +asm +// -> FST(0) val +// -> EAX Power +// <- FST(0) val * 10**Power + +// This routine generates 10**power with no more than two +// floating point multiplications. Up to 10**31, no multiplications +// are needed. + + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX +{$ELSE} + XOR EBX,EBX +{$ENDIF} + TEST EAX,EAX + JL @@neg + JE @@exit + CMP EAX,5120 + JGE @@inf + MOV EDX,EAX + AND EDX,01FH + LEA EDX,[EDX+EDX*4] + FLD tbyte ptr @@tab0[EBX+EDX*2] + + FMULP + + SHR EAX,5 + JE @@exit + + MOV EDX,EAX + AND EDX,0FH + JE @@skip2ndMul + LEA EDX,[EDX+EDX*4] + FLD tbyte ptr @@tab1-10[EBX+EDX*2] + FMULP + +@@skip2ndMul: + + SHR EAX,4 + JE @@exit + LEA EAX,[EAX+EAX*4] + FLD tbyte ptr @@tab2-10[EBX+EAX*2] + FMULP + JMP @@exit + +@@neg: + NEG EAX + CMP EAX,5120 + JGE @@zero + MOV EDX,EAX + AND EDX,01FH + LEA EDX,[EDX+EDX*4] + FLD tbyte ptr @@tab0[EBX+EDX*2] + FDIVP + + SHR EAX,5 + JE @@exit + + MOV EDX,EAX + AND EDX,0FH + JE @@skip2ndDiv + LEA EDX,[EDX+EDX*4] + FLD tbyte ptr @@tab1-10[EBX+EDX*2] + FDIVP + +@@skip2ndDiv: + + SHR EAX,4 + JE @@exit + LEA EAX,[EAX+EAX*4] + FLD tbyte ptr @@tab2-10[EBX+EAX*2] + FDIVP + + JMP @@exit + +@@inf: + FLD tbyte ptr @@infval[EBX] + JMP @@exit + +@@zero: + FLDZ + +@@exit: + POP EBX + RET + +@@infval: DW $0000,$0000,$0000,$8000,$7FFF +@@tab0: DW $0000,$0000,$0000,$8000,$3FFF // 10**0 + DW $0000,$0000,$0000,$A000,$4002 // 10**1 + DW $0000,$0000,$0000,$C800,$4005 // 10**2 + DW $0000,$0000,$0000,$FA00,$4008 // 10**3 + DW $0000,$0000,$0000,$9C40,$400C // 10**4 + DW $0000,$0000,$0000,$C350,$400F // 10**5 + DW $0000,$0000,$0000,$F424,$4012 // 10**6 + DW $0000,$0000,$8000,$9896,$4016 // 10**7 + DW $0000,$0000,$2000,$BEBC,$4019 // 10**8 + DW $0000,$0000,$2800,$EE6B,$401C // 10**9 + DW $0000,$0000,$F900,$9502,$4020 // 10**10 + DW $0000,$0000,$B740,$BA43,$4023 // 10**11 + DW $0000,$0000,$A510,$E8D4,$4026 // 10**12 + DW $0000,$0000,$E72A,$9184,$402A // 10**13 + DW $0000,$8000,$20F4,$B5E6,$402D // 10**14 + DW $0000,$A000,$A931,$E35F,$4030 // 10**15 + DW $0000,$0400,$C9BF,$8E1B,$4034 // 10**16 + DW $0000,$C500,$BC2E,$B1A2,$4037 // 10**17 + DW $0000,$7640,$6B3A,$DE0B,$403A // 10**18 + DW $0000,$89E8,$2304,$8AC7,$403E // 10**19 + DW $0000,$AC62,$EBC5,$AD78,$4041 // 10**20 + DW $8000,$177A,$26B7,$D8D7,$4044 // 10**21 + DW $9000,$6EAC,$7832,$8786,$4048 // 10**22 + DW $B400,$0A57,$163F,$A968,$404B // 10**23 + DW $A100,$CCED,$1BCE,$D3C2,$404E // 10**24 + DW $84A0,$4014,$5161,$8459,$4052 // 10**25 + DW $A5C8,$9019,$A5B9,$A56F,$4055 // 10**26 + DW $0F3A,$F420,$8F27,$CECB,$4058 // 10**27 + DW $0984,$F894,$3978,$813F,$405C // 10**28 + DW $0BE5,$36B9,$07D7,$A18F,$405F // 10**29 + DW $4EDF,$0467,$C9CD,$C9F2,$4062 // 10**30 + DW $2296,$4581,$7C40,$FC6F,$4065 // 10**31 + +@@tab1: DW $B59E,$2B70,$ADA8,$9DC5,$4069 // 10**32 + DW $A6D5,$FFCF,$1F49,$C278,$40D3 // 10**64 + DW $14A3,$C59B,$AB16,$EFB3,$413D // 10**96 + DW $8CE0,$80E9,$47C9,$93BA,$41A8 // 10**128 + DW $17AA,$7FE6,$A12B,$B616,$4212 // 10**160 + DW $556B,$3927,$F78D,$E070,$427C // 10**192 + DW $C930,$E33C,$96FF,$8A52,$42E7 // 10**224 + DW $DE8E,$9DF9,$EBFB,$AA7E,$4351 // 10**256 + DW $2F8C,$5C6A,$FC19,$D226,$43BB // 10**288 + DW $E376,$F2CC,$2F29,$8184,$4426 // 10**320 + DW $0AD2,$DB90,$2700,$9FA4,$4490 // 10**352 + DW $AA17,$AEF8,$E310,$C4C5,$44FA // 10**384 + DW $9C59,$E9B0,$9C07,$F28A,$4564 // 10**416 + DW $F3D4,$EBF7,$4AE1,$957A,$45CF // 10**448 + DW $A262,$0795,$D8DC,$B83E,$4639 // 10**480 + +@@tab2: DW $91C7,$A60E,$A0AE,$E319,$46A3 // 10**512 + DW $0C17,$8175,$7586,$C976,$4D48 // 10**1024 + DW $A7E4,$3993,$353B,$B2B8,$53ED // 10**1536 + DW $5DE5,$C53D,$3B5D,$9E8B,$5A92 // 10**2048 + DW $F0A6,$20A1,$54C0,$8CA5,$6137 // 10**2560 + DW $5A8B,$D88B,$5D25,$F989,$67DB // 10**3072 + DW $F3F8,$BF27,$C8A2,$DD5D,$6E80 // 10**3584 + DW $979B,$8A20,$5202,$C460,$7525 // 10**4096 + DW $59F0,$6ED5,$1162,$AE35,$7BCA // 10**4608 +end; + +const + RealBias = 129; + ExtBias = $3FFF; + +procedure _Real2Ext;//( val : Real ) : Extended; +asm +// -> EAX Pointer to value +// <- FST(0) Result + +// the REAL data type has the following format: +// 8 bit exponent (bias 129), 39 bit fraction, 1 bit sign + + MOV DH,[EAX+5] // isolate the sign bit + AND DH,80H + MOV DL,[EAX] // fetch exponent + TEST DL,DL // exponent zero means number is zero + JE @@zero + + ADD DX,ExtBias-RealBias // adjust exponent bias + + PUSH EDX // the exponent is at the highest address + + MOV EDX,[EAX+2] // load high fraction part, set hidden bit + OR EDX,80000000H + PUSH EDX // push high fraction part + + MOV DL,[EAX+1] // load remaining low byte of fraction + SHL EDX,24 // clear low 24 bits + PUSH EDX + + FLD tbyte ptr [ESP] // pop result onto chip + ADD ESP,12 + + RET + +@@zero: + FLDZ + RET +end; + +procedure _Ext2Real;//( val : Extended ) : Real; +asm +// -> FST(0) Value +// EAX Pointer to result + + PUSH EBX + + SUB ESP,12 + FSTP tbyte ptr [ESP] + + POP EBX // EBX is low half of fraction + POP EDX // EDX is high half of fraction + POP ECX // CX is exponent and sign + + SHR EBX,24 // set carry to last bit shifted out + ADC BL,0 // if bit was 1, round up + ADC EDX,0 + ADC CX,0 + JO @@overflow + + ADD EDX,EDX // shift fraction 1 bit left + ADD CX,CX // shift sign bit into carry + RCR EDX,1 // attach sign bit to fraction + SHR CX,1 // restore exponent, deleting sign + + SUB CX,ExtBias-RealBias // adjust exponent + JLE @@underflow + TEST CH,CH // CX must be in 1..255 + JG @@overflow + + MOV [EAX],CL + MOV [EAX+1],BL + MOV [EAX+2],EDX + + POP EBX + RET + +@@underflow: + XOR ECX,ECX + MOV [EAX],ECX + MOV [EAX+4],CX + POP EBX + RET + +@@overflow: + POP EBX + MOV AL,8 + JMP Error +end; + +const + ovtInstanceSize = -8; { Offset of instance size in OBJECTs } + ovtVmtPtrOffs = -4; + +procedure _ObjSetup; +asm +{ FUNCTION _ObjSetup( self: ^OBJECT; vmt: ^VMT): ^OBJECT; } +{ ->EAX Pointer to self (possibly nil) } +{ EDX Pointer to vmt (possibly nil) } +{ <-EAX Pointer to self } +{ EDX <> 0: an object was allocated } +{ Z-Flag Set: failure, Cleared: Success } + + CMP EDX,1 { is vmt = 0, indicating a call } + JAE @@skip1 { from a constructor? } + RET { return immediately with Z-flag cleared } + +@@skip1: + PUSH ECX + TEST EAX,EAX { is self already allocated? } + JNE @@noAlloc + MOV EAX,[EDX].ovtInstanceSize + TEST EAX,EAX + JE @@zeroSize + PUSH EDX + CALL _GetMem + POP EDX + TEST EAX,EAX + JZ @@fail + + { Zero fill the memory } + PUSH EDI + MOV ECX,[EDX].ovtInstanceSize + MOV EDI,EAX + PUSH EAX + XOR EAX,EAX + SHR ECX,2 + REP STOSD + MOV ECX,[EDX].ovtInstanceSize + AND ECX,3 + REP STOSB + POP EAX + POP EDI + + MOV ECX,[EDX].ovtVmtPtrOffs + TEST ECX,ECX + JL @@skip + MOV [EAX+ECX],EDX { store vmt in object at this offset } +@@skip: + TEST EAX,EAX { clear zero flag } + POP ECX + RET + +@@fail: + XOR EDX,EDX + POP ECX + RET + +@@zeroSize: + XOR EDX,EDX + CMP EAX,1 { clear zero flag - we were successful (kind of) } + POP ECX + RET + +@@noAlloc: + MOV ECX,[EDX].ovtVmtPtrOffs + TEST ECX,ECX + JL @@exit + MOV [EAX+ECX],EDX { store vmt in object at this offset } +@@exit: + XOR EDX,EDX { clear allocated flag } + TEST EAX,EAX { clear zero flag } + POP ECX +end; + +procedure _ObjCopy; +asm +{ PROCEDURE _ObjCopy( dest, src: ^OBJECT; vmtPtrOff: Longint); } +{ ->EAX Pointer to destination } +{ EDX Pointer to source } +{ ECX Offset of vmt in those objects. } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EDX + MOV EDI,EAX + + LEA EAX,[EDI+ECX] { remember pointer to dest vmt pointer } + MOV EDX,[EAX] { fetch dest vmt pointer } + + MOV EBX,[EDX].ovtInstanceSize + + MOV ECX,EBX { copy size DIV 4 dwords } + SHR ECX,2 + REP MOVSD + + MOV ECX,EBX { copy size MOD 4 bytes } + AND ECX,3 + REP MOVSB + + MOV [EAX],EDX { restore dest vmt } + + POP EDI + POP ESI + POP EBX +end; + +procedure _Fail; +asm +{ FUNCTION _Fail( self: ^OBJECT; allocFlag:Longint): ^OBJECT; } +{ ->EAX Pointer to self (possibly nil) } +{ EDX <> 0: Object must be deallocated } +{ <-EAX Nil } + + TEST EDX,EDX + JE @@exit { if no object was allocated, return } + CALL _FreeMem +@@exit: + XOR EAX,EAX +end; + +{$IFDEF MSWINDOWS} +function GetKeyboardType(nTypeFlag: Integer): Integer; stdcall; + external user name 'GetKeyboardType'; + +function _isNECWindows: Boolean; +var + KbSubType: Integer; +begin + Result := False; + if GetKeyboardType(0) = $7 then + begin + KbSubType := GetKeyboardType(1) and $FF00; + if (KbSubType = $0D00) or (KbSubType = $0400) then + Result := True; + end; +end; + +const + HKEY_LOCAL_MACHINE = $80000002; + +// workaround a Japanese Win95 bug +procedure _FpuMaskInit; +const + KEY_QUERY_VALUE = $00000001; + REG_DWORD = 4; + FPUMASKKEY = 'SOFTWARE\Borland\Delphi\RTL'; + FPUMASKNAME = 'FPUMaskValue'; +var + phkResult: LongWord; + lpData, DataSize: Longint; +begin + lpData := Default8087CW; + + if RegOpenKeyEx(HKEY_LOCAL_MACHINE, FPUMASKKEY, 0, KEY_QUERY_VALUE, phkResult) = 0 then + try + DataSize := Sizeof(lpData); + RegQueryValueEx(phkResult, FPUMASKNAME, nil, nil, @lpData, @DataSize); + finally + RegCloseKey(phkResult); + end; + Default8087CW := (Default8087CW and $ffc0) or (lpData and $3f); +end; +{$ENDIF} + +procedure _FpuInit; +asm + FNINIT + FWAIT +{$IFDEF PIC} + CALL GetGOT + MOV EAX,[EAX].OFFSET Default8087CW + FLDCW [EAX] +{$ELSE} + FLDCW Default8087CW +{$ENDIF} +end; + +procedure FpuInit; +//const cwDefault: Word = $1332 { $133F}; +asm + JMP _FpuInit +end; + +procedure FpuInitConsiderNECWindows; +begin + if _isNECWindows then _FpuMaskInit; + FpuInit(); +end; + +procedure _BoundErr; +asm + MOV AL,reRangeError + JMP Error +end; + +procedure _IntOver; +asm + MOV AL,reIntOverflow + JMP Error +end; + +function TObject.ClassType: TClass; +begin + Pointer(Result) := PPointer(Self)^; +end; + +class function TObject.ClassName: ShortString; +{$IFDEF PUREPASCAL} +begin + Result := PShortString(PPointer(Integer(Self) + vmtClassName)^)^; +end; +{$ELSE} +asm + { -> EAX VMT } + { EDX Pointer to result string } + PUSH ESI + PUSH EDI + MOV EDI,EDX + MOV ESI,[EAX].vmtClassName + XOR ECX,ECX + MOV CL,[ESI] + INC ECX + REP MOVSB + POP EDI + POP ESI +end; +{$ENDIF} + +class function TObject.ClassNameIs(const Name: string): Boolean; +{$IFDEF PUREPASCAL} +var + Temp: ShortString; + I: Byte; +begin + Result := False; + Temp := ClassName; + for I := 0 to Byte(Temp[0]) do + if Temp[I] <> Name[I] then Exit; + Result := True; +end; +{$ELSE} +asm + PUSH EBX + XOR EBX,EBX + OR EDX,EDX + JE @@exit + MOV EAX,[EAX].vmtClassName + XOR ECX,ECX + MOV CL,[EAX] + CMP ECX,[EDX-4] + JNE @@exit + DEC EDX +@@loop: + MOV BH,[EAX+ECX] + XOR BH,[EDX+ECX] + AND BH,0DFH + JNE @@exit + DEC ECX + JNE @@loop + INC EBX +@@exit: + MOV AL,BL + POP EBX +end; +{$ENDIF} + +class function TObject.ClassParent: TClass; +{$IFDEF PUREPASCAL} +begin + Pointer(Result) := PPointer(Integer(Self) + vmtParent)^; + if Result <> nil then + Pointer(Result) := PPointer(Result)^; +end; +{$ELSE} +asm + MOV EAX,[EAX].vmtParent + TEST EAX,EAX + JE @@exit + MOV EAX,[EAX] +@@exit: +end; +{$ENDIF} + +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; +begin +end; + +destructor TObject.Destroy; +begin +end; + +procedure TObject.Free; +begin + if Self <> nil then + Destroy; +end; + +class function TObject.InitInstance(Instance: Pointer): TObject; +{$IFDEF PUREPASCAL} +var + IntfTable: PInterfaceTable; + ClassPtr: TClass; + I: Integer; +begin + FillChar(Instance^, InstanceSize, 0); + PInteger(Instance)^ := Integer(Self); + ClassPtr := Self; + while ClassPtr <> nil do + begin + IntfTable := ClassPtr.GetInterfaceTable; + if IntfTable <> nil then + for I := 0 to IntfTable.EntryCount-1 do + with IntfTable.Entries[I] do + begin + if VTable <> nil then + PInteger(@PChar(Instance)[IOffset])^ := Integer(VTable); + end; + ClassPtr := ClassPtr.ClassParent; + end; + Result := Instance; +end; +{$ELSE} +asm + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV EDI,EDX + STOSD + MOV ECX,[EBX].vmtInstanceSize + XOR EAX,EAX + PUSH ECX + SHR ECX,2 + DEC ECX + REP STOSD + POP ECX + AND ECX,3 + REP STOSB + MOV EAX,EDX + MOV EDX,ESP +@@0: MOV ECX,[EBX].vmtIntfTable + TEST ECX,ECX + JE @@1 + PUSH ECX +@@1: MOV EBX,[EBX].vmtParent + TEST EBX,EBX + JE @@2 + MOV EBX,[EBX] + JMP @@0 +@@2: CMP ESP,EDX + JE @@5 +@@3: POP EBX + MOV ECX,[EBX].TInterfaceTable.EntryCount + ADD EBX,4 +@@4: MOV ESI,[EBX].TInterfaceEntry.VTable + TEST ESI,ESI + JE @@4a + MOV EDI,[EBX].TInterfaceEntry.IOffset + MOV [EAX+EDI],ESI +@@4a: ADD EBX,TYPE TInterfaceEntry + DEC ECX + JNE @@4 + CMP ESP,EDX + JNE @@3 +@@5: POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +procedure TObject.CleanupInstance; +{$IFDEF PUREPASCAL} +var + ClassPtr: TClass; + InitTable: Pointer; +begin + ClassPtr := ClassType; + InitTable := PPointer(Integer(ClassPtr) + vmtInitTable)^; + while (ClassPtr <> nil) and (InitTable <> nil) do + begin + _FinalizeRecord(Self, InitTable); + ClassPtr := ClassPtr.ClassParent; + if ClassPtr <> nil then + InitTable := PPointer(Integer(ClassPtr) + vmtInitTable)^; + end; +end; +{$ELSE} +asm + PUSH EBX + PUSH ESI + MOV EBX,EAX + MOV ESI,EAX +@@loop: + MOV ESI,[ESI] + MOV EDX,[ESI].vmtInitTable + MOV ESI,[ESI].vmtParent + TEST EDX,EDX + JE @@skip + CALL _FinalizeRecord + MOV EAX,EBX +@@skip: + TEST ESI,ESI + JNE @@loop + + POP ESI + POP EBX +end; +{$ENDIF} + +function InvokeImplGetter(Self: TObject; ImplGetter: Cardinal): IInterface; +{$IFDEF PUREPASCAL} +var + M: function: IInterface of object; +begin + TMethod(M).Data := Self; + case ImplGetter of + $FF000000..$FFFFFFFF: // Field + Result := IInterface(Pointer(Cardinal(Self) + (ImplGetter and $00FFFFFF))); + $FE000000..$FEFFFFFF: // virtual method + begin + // sign extend vmt slot offset = smallint cast + TMethod(M).Code := PPointer(Integer(Self) + SmallInt(ImplGetter))^; + Result := M; + end; + else // static method + TMethod(M).Code := Pointer(ImplGetter); + Result := M; + end; +end; +{$ELSE} +asm + XCHG EDX,ECX + CMP ECX,$FF000000 + JAE @@isField + CMP ECX,$FE000000 + JB @@isStaticMethod + + { the GetProc is a virtual method } + MOVSX ECX,CX { sign extend slot offs } + ADD ECX,[EAX] { vmt + slotoffs } + JMP dword ptr [ECX] { call vmt[slot] } + +@@isStaticMethod: + JMP ECX + +@@isField: + AND ECX,$00FFFFFF + ADD ECX,EAX + MOV EAX,EDX + MOV EDX,[ECX] + JMP _IntfCopy +end; +{$ENDIF} + +function TObject.GetInterface(const IID: TGUID; out Obj): Boolean; +var + InterfaceEntry: PInterfaceEntry; +begin + Pointer(Obj) := nil; + InterfaceEntry := GetInterfaceEntry(IID); + if InterfaceEntry <> nil then + begin + if InterfaceEntry^.IOffset <> 0 then + begin + Pointer(Obj) := Pointer(Integer(Self) + InterfaceEntry^.IOffset); + if Pointer(Obj) <> nil then IInterface(Obj)._AddRef; + end + else + IInterface(Obj) := InvokeImplGetter(Self, InterfaceEntry^.ImplGetter); + end; + Result := Pointer(Obj) <> nil; +end; + +class function TObject.GetInterfaceEntry(const IID: TGUID): PInterfaceEntry; +{$IFDEF PUREPASCAL} +var + ClassPtr: TClass; + IntfTable: PInterfaceTable; + I: Integer; +begin + ClassPtr := Self; + while ClassPtr <> nil do + begin + IntfTable := ClassPtr.GetInterfaceTable; + if IntfTable <> nil then + for I := 0 to IntfTable.EntryCount-1 do + begin + Result := @IntfTable.Entries[I]; +// if Result^.IID = IID then Exit; + if (Int64(Result^.IID.D1) = Int64(IID.D1)) and + (Int64(Result^.IID.D4) = Int64(IID.D4)) then Exit; + end; + ClassPtr := ClassPtr.ClassParent; + end; + Result := nil; +end; +{$ELSE} +asm + PUSH EBX + PUSH ESI + MOV EBX,EAX +@@1: MOV EAX,[EBX].vmtIntfTable + TEST EAX,EAX + JE @@4 + MOV ECX,[EAX].TInterfaceTable.EntryCount + ADD EAX,4 +@@2: MOV ESI,[EDX].Integer[0] + CMP ESI,[EAX].TInterfaceEntry.IID.Integer[0] + JNE @@3 + MOV ESI,[EDX].Integer[4] + CMP ESI,[EAX].TInterfaceEntry.IID.Integer[4] + JNE @@3 + MOV ESI,[EDX].Integer[8] + CMP ESI,[EAX].TInterfaceEntry.IID.Integer[8] + JNE @@3 + MOV ESI,[EDX].Integer[12] + CMP ESI,[EAX].TInterfaceEntry.IID.Integer[12] + JE @@5 +@@3: ADD EAX,type TInterfaceEntry + DEC ECX + JNE @@2 +@@4: MOV EBX,[EBX].vmtParent + TEST EBX,EBX + JE @@4a + MOV EBX,[EBX] + JMP @@1 +@@4a: XOR EAX,EAX +@@5: POP ESI + POP EBX +end; +{$ENDIF} + +class function TObject.GetInterfaceTable: PInterfaceTable; +begin + Result := PPointer(Integer(Self) + vmtIntfTable)^; +end; + +function _IsClass(Child: TObject; Parent: TClass): Boolean; +begin + Result := (Child <> nil) and Child.InheritsFrom(Parent); +end; + +function _AsClass(Child: TObject; Parent: TClass): TObject; +{$IFDEF PUREPASCAL} +begin + Result := Child; + if not (Child is Parent) then + Error(reInvalidCast); // loses return address +end; +{$ELSE} +asm + { -> EAX left operand (class) } + { EDX VMT of right operand } + { <- EAX if left is derived from right, else runtime error } + TEST EAX,EAX + JE @@exit + MOV ECX,EAX +@@loop: + MOV ECX,[ECX] + CMP ECX,EDX + JE @@exit + MOV ECX,[ECX].vmtParent + TEST ECX,ECX + JNE @@loop + + { do runtime error } + MOV AL,reInvalidCast + JMP Error + +@@exit: +end; +{$ENDIF} + + +procedure GetDynaMethod; +{ function GetDynaMethod(vmt: TClass; selector: Smallint) : Pointer; } +asm + { -> EAX vmt of class } + { SI dynamic method index } + { <- ESI pointer to routine } + { ZF = 0 if found } + { trashes: EAX, ECX } + + PUSH EDI + XCHG EAX,ESI + JMP @@haveVMT +@@outerLoop: + MOV ESI,[ESI] +@@haveVMT: + MOV EDI,[ESI].vmtDynamicTable + TEST EDI,EDI + JE @@parent + MOVZX ECX,word ptr [EDI] + PUSH ECX + ADD EDI,2 + REPNE SCASW + JE @@found + POP ECX +@@parent: + MOV ESI,[ESI].vmtParent + TEST ESI,ESI + JNE @@outerLoop + JMP @@exit + +@@found: + POP EAX + ADD EAX,EAX + SUB EAX,ECX { this will always clear the Z-flag ! } + MOV ESI,[EDI+EAX*2-4] + +@@exit: + POP EDI +end; + +procedure _CallDynaInst; +asm + PUSH EAX + PUSH ECX + MOV EAX,[EAX] + CALL GetDynaMethod + POP ECX + POP EAX + JE @@Abstract + JMP ESI +@@Abstract: + POP ECX + JMP _AbstractError +end; + + +procedure _CallDynaClass; +asm + PUSH EAX + PUSH ECX + CALL GetDynaMethod + POP ECX + POP EAX + JE @@Abstract + JMP ESI +@@Abstract: + POP ECX + JMP _AbstractError +end; + + +procedure _FindDynaInst; +asm + PUSH ESI + MOV ESI,EDX + MOV EAX,[EAX] + CALL GetDynaMethod + MOV EAX,ESI + POP ESI + JNE @@exit + POP ECX + JMP _AbstractError +@@exit: +end; + + +procedure _FindDynaClass; +asm + PUSH ESI + MOV ESI,EDX + CALL GetDynaMethod + MOV EAX,ESI + POP ESI + JNE @@exit + POP ECX + JMP _AbstractError +@@exit: +end; + +class function TObject.InheritsFrom(AClass: TClass): Boolean; +{$IFDEF PUREPASCAL} +var + ClassPtr: TClass; +begin + ClassPtr := Self; + while (ClassPtr <> nil) and (ClassPtr <> AClass) do + ClassPtr := PPointer(Integer(ClassPtr) + vmtParent)^; + Result := ClassPtr = AClass; +end; +{$ELSE} +asm + { -> EAX Pointer to our class } + { EDX Pointer to AClass } + { <- AL Boolean result } + JMP @@haveVMT +@@loop: + MOV EAX,[EAX] +@@haveVMT: + CMP EAX,EDX + JE @@success + MOV EAX,[EAX].vmtParent + TEST EAX,EAX + JNE @@loop + JMP @@exit +@@success: + MOV AL,1 +@@exit: +end; +{$ENDIF} + + +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); +begin +end; + + +procedure TObject.AfterConstruction; +begin +end; + +procedure TObject.BeforeDestruction; +begin +end; + +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].vmtDefaultHandler +end; + + +class function TObject.MethodAddress(const Name: ShortString): Pointer; +asm + { -> EAX Pointer to class } + { EDX Pointer to name } + PUSH EBX + PUSH ESI + PUSH EDI + XOR ECX,ECX + XOR EDI,EDI + MOV BL,[EDX] + JMP @@haveVMT +@@outer: { upper 16 bits of ECX are 0 ! } + MOV EAX,[EAX] +@@haveVMT: + MOV ESI,[EAX].vmtMethodTable + TEST ESI,ESI + JE @@parent + MOV DI,[ESI] { EDI := method count } + ADD ESI,2 +@@inner: { upper 16 bits of ECX are 0 ! } + MOV CL,[ESI+6] { compare length of strings } + CMP CL,BL + JE @@cmpChar +@@cont: { upper 16 bits of ECX are 0 ! } + MOV CX,[ESI] { fetch length of method desc } + ADD ESI,ECX { point ESI to next method } + DEC EDI + JNZ @@inner +@@parent: + MOV EAX,[EAX].vmtParent { fetch parent vmt } + TEST EAX,EAX + JNE @@outer + JMP @@exit { return NIL } + +@@notEqual: + MOV BL,[EDX] { restore BL to length of name } + JMP @@cont + +@@cmpChar: { upper 16 bits of ECX are 0 ! } + MOV CH,0 { upper 24 bits of ECX are 0 ! } +@@cmpCharLoop: + MOV BL,[ESI+ECX+6] { case insensitive string cmp } + XOR BL,[EDX+ECX+0] { last char is compared first } + AND BL,$DF + JNE @@notEqual + DEC ECX { ECX serves as counter } + JNZ @@cmpCharLoop + + { found it } + MOV EAX,[ESI+2] + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +class function TObject.MethodName(Address: Pointer): ShortString; +asm + { -> EAX Pointer to class } + { EDX Address } + { ECX Pointer to result } + PUSH EBX + PUSH ESI + PUSH EDI + MOV EDI,ECX + XOR EBX,EBX + XOR ECX,ECX + JMP @@haveVMT +@@outer: + MOV EAX,[EAX] +@@haveVMT: + MOV ESI,[EAX].vmtMethodTable { fetch pointer to method table } + TEST ESI,ESI + JE @@parent + MOV CX,[ESI] + ADD ESI,2 +@@inner: + CMP EDX,[ESI+2] + JE @@found + MOV BX,[ESI] + ADD ESI,EBX + DEC ECX + JNZ @@inner +@@parent: + MOV EAX,[EAX].vmtParent + TEST EAX,EAX + JNE @@outer + MOV [EDI],AL + JMP @@exit + +@@found: + ADD ESI,6 + XOR ECX,ECX + MOV CL,[ESI] + INC ECX + REP MOVSB + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +function TObject.FieldAddress(const Name: ShortString): Pointer; +asm + { -> EAX Pointer to instance } + { EDX Pointer to name } + PUSH EBX + PUSH ESI + PUSH EDI + XOR ECX,ECX + XOR EDI,EDI + MOV BL,[EDX] + + PUSH EAX { save instance pointer } + +@@outer: + MOV EAX,[EAX] { fetch class pointer } + MOV ESI,[EAX].vmtFieldTable + TEST ESI,ESI + JE @@parent + MOV DI,[ESI] { fetch count of fields } + ADD ESI,6 +@@inner: + MOV CL,[ESI+6] { compare string lengths } + CMP CL,BL + JE @@cmpChar +@@cont: + LEA ESI,[ESI+ECX+7] { point ESI to next field } + DEC EDI + JNZ @@inner +@@parent: + MOV EAX,[EAX].vmtParent { fetch parent VMT } + TEST EAX,EAX + JNE @@outer + POP EDX { forget instance, return Nil } + JMP @@exit + +@@notEqual: + MOV BL,[EDX] { restore BL to length of name } + MOV CL,[ESI+6] { ECX := length of field name } + JMP @@cont + +@@cmpChar: + MOV BL,[ESI+ECX+6] { case insensitive string cmp } + XOR BL,[EDX+ECX+0] { starting with last char } + AND BL,$DF + JNE @@notEqual + DEC ECX { ECX serves as counter } + JNZ @@cmpChar + + { found it } + MOV EAX,[ESI] { result is field offset plus ... } + POP EDX + ADD EAX,EDX { instance pointer } + +@@exit: + POP EDI + POP ESI + POP EBX +end; + +function _ClassCreate(AClass: TClass; Alloc: Boolean): TObject; +asm + { -> EAX = pointer to VMT } + { <- EAX = pointer to instance } + PUSH EDX + PUSH ECX + PUSH EBX + TEST DL,DL + JL @@noAlloc + CALL dword ptr [EAX].vmtNewInstance +@@noAlloc: +{$IFNDEF PC_MAPPED_EXCEPTIONS} + XOR EDX,EDX + LEA ECX,[ESP+16] + MOV EBX,FS:[EDX] + MOV [ECX].TExcFrame.next,EBX + MOV [ECX].TExcFrame.hEBP,EBP + MOV [ECX].TExcFrame.desc,offset @desc + MOV [ECX].TexcFrame.ConstructedObject,EAX { trick: remember copy to instance } + MOV FS:[EDX],ECX +{$ENDIF} + POP EBX + POP ECX + POP EDX + RET + +{$IFNDEF PC_MAPPED_EXCEPTIONS} +@desc: + JMP _HandleAnyException + + { destroy the object } + + MOV EAX,[ESP+8+9*4] + MOV EAX,[EAX].TExcFrame.ConstructedObject + TEST EAX,EAX + JE @@skip + MOV ECX,[EAX] + MOV DL,$81 + PUSH EAX + CALL dword ptr [ECX].vmtDestroy + POP EAX + CALL _ClassDestroy +@@skip: + { reraise the exception } + CALL _RaiseAgain +{$ENDIF} +end; + +procedure _ClassDestroy(Instance: TObject); +begin + Instance.FreeInstance; +end; + + +function _AfterConstruction(Instance: TObject): TObject; +begin + Instance.AfterConstruction; + Result := Instance; +end; + +function _BeforeDestruction(Instance: TObject; OuterMost: ShortInt): TObject; +// Must preserve DL on return! +{$IFDEF PUREPASCAL} +begin + Result := Instance; + if OuterMost > 0 then Exit; + Instance.BeforeDestruction; +end; +{$ELSE} +asm + { -> EAX = pointer to instance } + { DL = dealloc flag } + + TEST DL,DL + JG @@outerMost + RET +@@outerMost: + PUSH EAX + PUSH EDX + MOV EDX,[EAX] + CALL dword ptr [EDX].vmtBeforeDestruction + POP EDX + POP EAX +end; +{$ENDIF} + +{ + 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_CONTINE so that normal processing will occur. +} + +{$IFDEF LINUX} +const + excRaise = 0; { an exception is being raised by the user (could be a reraise) } + excCatch = 1; { an exception is about to be caught } + excFinally = 2; { a finally block is about to be executed because of an exception } + excUnhandled = 3; { no user exception handler was found (the app will die) } + +procedure _DbgExcNotify( + NotificationKind: Integer; + ExceptionObject: Pointer; + ExceptionName: PShortString; + ExceptionLocation: Pointer; + HandlerAddr: Pointer); cdecl; export; +begin +{$IFDEF DEBUG} + { + This code is just for debugging the exception handling system. The debugger + needs _DbgExcNotify, however to place breakpoints in, so the function itself + cannot be removed. + } + asm + PUSH EAX + PUSH EDX + end; + if Assigned(ExcNotificationProc) then + ExcNotificationProc(NotificationKind, ExceptionObject, ExceptionName, ExceptionLocation, HandlerAddr); + asm + POP EDX + POP EAX + end; +{$ENDIF} +end; + +{ + The following functions are used by the debugger for the evaluator. If you + change them IN ANY WAY, the debugger will cease to function correctly. +} +procedure _DbgEvalMarker; +begin +end; + +procedure _DbgEvalExcept(E: TObject); +begin +end; + +procedure _DbgEvalEnd; +begin +end; + +{ + This function is used by the debugger to provide a soft landing spot + when evaluating a function call that may raise an unhandled exception. + The return address of _DbgEvalMarker is pushed onto the stack so that + the unwinder will transfer control to the except block. +} +procedure _DbgEvalFrame; +begin + try + _DbgEvalMarker; + except on E: TObject do + _DbgEvalExcept(E); + end; + _DbgEvalEnd; +end; + +{ + These export names need to match the names that will be generated into + the .symtab section, so that the debugger can find them if stabs + debug information is being generated. +} +exports + _DbgExcNotify name '@DbgExcNotify', + _DbgEvalFrame name '@DbgEvalFrame', + _DbgEvalMarker name '@DbgEvalMarker', + _DbgEvalExcept name '@DbgEvalExcept', + _DbgEvalEnd name '@DbgEvalEnd'; +{$ENDIF} + +{ tell the debugger that the next raise is a re-raise of the current non-Delphi + exception } +procedure NotifyReRaise; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX location of exception } + PUSH 0 { handler addr } + PUSH EDX { location of exception } + MOV ECX, [EAX] + PUSH [ECX].vmtClassName { exception name } + PUSH EAX { exception object } + PUSH excRaise { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 +{$ELSE} + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH 0 + PUSH 0 + PUSH cContinuable + PUSH cDelphiReRaise + CALL RaiseExceptionProc +@@1: +{$ENDIF} +end; + +{ tell the debugger about the raise of a non-Delphi exception } +{$IFNDEF LINUX} +procedure NotifyNonDelphiException; +asm + CMP BYTE PTR DebugHook,0 + JE @@1 + PUSH EAX + PUSH EAX + PUSH EDX + PUSH ESP + PUSH 2 + PUSH cContinuable + PUSH cNonDelphiException + CALL RaiseExceptionProc + ADD ESP,8 + POP EAX +@@1: +end; +{$ENDIF} + +{ Tell the debugger where the handler for the current exception is located } +procedure NotifyExcept; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX handler addr } + PUSH EAX + MOV EAX, [EAX].TRaisedException.ExceptObject + + PUSH EDX { handler addr } + PUSH 0 { location of exception } + MOV ECX, [EAX] + PUSH [ECX].vmtClassName { exception name } + PUSH EAX { exception object } + PUSH excCatch { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 + + POP EAX +{$ELSE} + PUSH ESP + PUSH 1 + PUSH cContinuable + PUSH cDelphiExcept { our magic exception code } + CALL RaiseExceptionProc + ADD ESP,4 + POP EAX +{$ENDIF} +end; + +procedure NotifyOnExcept; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX handler addr } + PUSH EDX { handler addr } + PUSH 0 { location of exception } + MOV ECX, [EAX] + PUSH [ECX].vmtClassName { exception name } + PUSH EAX { exception object } + PUSH excCatch { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 +{$ELSE} + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH EAX + PUSH [EBX].TExcDescEntry.handler + JMP NotifyExcept +@@1: +{$ENDIF} +end; + +{$IFNDEF LINUX} +procedure NotifyAnyExcept; +asm + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH EAX + PUSH EBX + JMP NotifyExcept +@@1: +end; + +procedure CheckJmp; +asm + TEST ECX,ECX + JE @@3 + MOV EAX,[ECX + 1] + CMP BYTE PTR [ECX],0E9H { near jmp } + JE @@1 + CMP BYTE PTR [ECX],0EBH { short jmp } + JNE @@3 + MOVSX EAX,AL + INC ECX + INC ECX + JMP @@2 +@@1: + ADD ECX,5 +@@2: + ADD ECX,EAX +@@3: +end; +{$ENDIF} { not LINUX } + +{ Notify debugger of a finally during an exception unwind } +procedure NotifyExceptFinally; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX handler addr } + PUSH EDX { handler addr } + PUSH 0 { location of exception } + PUSH 0 { exception name } + PUSH 0 { exception object } + PUSH excFinally { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 +{$ELSE} + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH EAX + PUSH EDX + PUSH ECX + CALL CheckJmp + PUSH ECX + PUSH ESP { pass pointer to arguments } + PUSH 1 { there is 1 argument } + PUSH cContinuable { continuable execution } + PUSH cDelphiFinally { our magic exception code } + CALL RaiseExceptionProc + POP ECX + POP ECX + POP EDX + POP EAX +@@1: +{$ENDIF} +end; + + +{ Tell the debugger that the current exception is handled and cleaned up. + Also indicate where execution is about to resume. } +{$IFNDEF LINUX} +procedure NotifyTerminate; +asm + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH EDX + PUSH ESP + PUSH 1 + PUSH cContinuable + PUSH cDelphiTerminate { our magic exception code } + CALL RaiseExceptionProc + POP EDX +@@1: +end; +{$ENDIF} + +{ 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; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX location of exception } + PUSH EAX + MOV EAX, [EAX].TRaisedException.ExceptObject + + PUSH 0 { handler addr } + PUSH EDX { location of exception } + MOV ECX, [EAX] + PUSH [ECX].vmtClassName { exception name } + PUSH EAX { exception object } + PUSH excUnhandled { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 + + POP EAX +{$ELSE} + PUSH EAX + PUSH EDX + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH ESP + PUSH 2 + PUSH cContinuable + PUSH cDelphiUnhandled + CALL RaiseExceptionProc +@@1: + POP EDX + POP EAX +{$ENDIF} +end; + +procedure _HandleAnyException; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + CALL UnblockOSExceptions + OR [EAX].TRaisedException.Flags, excIsBeingHandled + MOV ESI, EBX + MOV EDX, [ESP] + CALL NotifyExcept + MOV EBX, ESI +{$ENDIF} +{$IFNDEF PC_MAPPED_EXCEPTIONS} + { -> [ESP+ 4] excPtr: PExceptionRecord } + { [ESP+ 8] errPtr: PExcFrame } + { [ESP+12] ctxPtr: Pointer } + { [ESP+16] dspPtr: Pointer } + { <- EAX return value - always one } + + MOV EAX,[ESP+4] + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JNE @@exit + + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + MOV EDX,[EAX].TExceptionRecord.ExceptObject + MOV ECX,[EAX].TExceptionRecord.ExceptAddr + JE @@DelphiException + CLD + CALL _FpuInit + MOV EDX,ExceptObjProc + TEST EDX,EDX + JE @@exit + CALL EDX + TEST EAX,EAX + JE @@exit + MOV EDX,[ESP+12] + MOV ECX,[ESP+4] + CMP [ECX].TExceptionRecord.ExceptionCode,cCppException + JE @@CppException + CALL NotifyNonDelphiException +{$IFDEF MSWINDOWS} + CMP BYTE PTR JITEnable,0 + JBE @@CppException + CMP BYTE PTR DebugHook,0 + JA @@CppException // Do not JIT if debugging + LEA ECX,[ESP+4] + PUSH EAX + PUSH ECX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + POP EAX + JE @@exit + MOV EDX,EAX + MOV EAX,[ESP+4] + MOV ECX,[EAX].TExceptionRecord.ExceptionAddress + JMP @@GoUnwind +{$ENDIF} +@@CppException: + MOV EDX,EAX + MOV EAX,[ESP+4] + MOV ECX,[EAX].TExceptionRecord.ExceptionAddress + +@@DelphiException: +{$IFDEF MSWINDOWS} + CMP BYTE PTR JITEnable,1 + JBE @@GoUnwind + CMP BYTE PTR DebugHook,0 { Do not JIT if debugging } + JA @@GoUnwind + PUSH EAX + LEA EAX,[ESP+8] + PUSH EDX + PUSH ECX + PUSH EAX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + POP ECX + POP EDX + POP EAX + JE @@exit +{$ENDIF} + +@@GoUnwind: + OR [EAX].TExceptionRecord.ExceptionFlags,cUnwinding + + PUSH EBX + XOR EBX,EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBX,FS:[EBX] + PUSH EBX { Save pointer to topmost frame } + PUSH EAX { Save OS exception pointer } + PUSH EDX { Save exception object } + PUSH ECX { Save exception address } + + MOV EDX,[ESP+8+8*4] + + PUSH 0 + PUSH EAX + PUSH offset @@returnAddress + PUSH EDX + CALL RtlUnwindProc +@@returnAddress: + + MOV EDI,[ESP+8+8*4] + + { Make the RaiseList entry on the stack } + + CALL SysInit.@GetTLS + PUSH [EAX].RaiseListPtr + MOV [EAX].RaiseListPtr,ESP + + MOV EBP,[EDI].TExcFrame.hEBP + MOV EBX,[EDI].TExcFrame.desc + MOV [EDI].TExcFrame.desc,offset @@exceptFinally + + ADD EBX,TExcDesc.instructions + CALL NotifyAnyExcept + JMP EBX + +@@exceptFinally: + JMP _HandleFinally + +@@destroyExcept: + { we come here if an exception handler has thrown yet another exception } + { we need to destroy the exception object and pop the raise list. } + + CALL SysInit.@GetTLS + MOV ECX,[EAX].RaiseListPtr + MOV EDX,[ECX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,EDX + + MOV EAX,[ECX].TRaiseFrame.ExceptObject + JMP TObject.Free + +@@exit: + MOV EAX,1 +{$ENDIF} { not PC_MAPPED_EXCEPTIONS } +end; + +{$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; +asm + { -> EAX raised object: Pointer } + { EDX descriptor table: ^TExcDesc } + { EBX GOT of user code, or 0 if not an SO } + { <- EAX matching descriptor: ^TExcDescEntry } + PUSH EBP + MOV EBP, ESP + SUB ESP, 8 { Room for vtable temp, and adjustor } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV [EBP - 8], EBX { Store the potential GOT } + MOV EAX, [EAX] { load vtable of exception object } + MOV EBX,[EDX].TExcDesc.cnt + LEA ESI,[EDX].TExcDesc.excTab { point ECX to exc descriptor table } + MOV [EBP - 4], EAX { temp for vtable of exception object } + +@@innerLoop: + MOV EAX,[ESI].TExcDescEntry.vTable + TEST EAX,EAX { catch all clause? } + JE @@found { yes: This is the handler } + ADD EAX, [EBP - 8] { add in the adjustor (could be 0) } + MOV EDI,[EBP - 4] { load vtable of exception object } + JMP @@haveVMT + +@@vtLoop: + MOV EDI,[EDI] +@@haveVMT: + MOV EAX,[EAX] + CMP EAX,EDI + JE @@found + + MOV ECX,[EAX].vmtInstanceSize + CMP ECX,[EDI].vmtInstanceSize + JNE @@parent + + MOV EAX,[EAX].vmtClassName + MOV EDX,[EDI].vmtClassName + + XOR ECX,ECX + MOV CL,[EAX] + CMP CL,[EDX] + JNE @@parent + + INC EAX + INC EDX + CALL _AStrCmp + JE @@found + +@@parent: + MOV EDI,[EDI].vmtParent { load vtable of parent } + MOV EAX,[ESI].TExcDescEntry.vTable + ADD EAX, [EBP - 8] { add in the adjustor (could be 0) } + TEST EDI,EDI + JNE @@vtLoop + + ADD ESI,8 + DEC EBX + JNZ @@innerLoop + + { Didn't find a handler. } + XOR ESI, ESI + +@@found: + MOV EAX, ESI +@@done: + POP EDI + POP ESI + POP EBX + MOV ESP, EBP + POP EBP +end; +{$ENDIF} + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _HandleOnExceptionPIC; +asm + { -> EAX obj : Exception object } + { [RA] desc: ^TExcDesc } + { <- Doesn't return } + + // Mark the exception as being handled + OR [EAX].TRaisedException.Flags, excIsBeingHandled + + MOV ESI, EBX // Save the GOT + MOV EDX, [ESP] // Get the addr of the TExcDesc + PUSH EAX // Save the object + MOV EAX, [EAX].TRaisedException.ExceptObject + CALL FindOnExceptionDescEntry + OR EAX, EAX + JE @@NotForMe + + MOV EBX, ESI // Set back to user's GOT + MOV EDX, EAX + POP EAX // Get the object back + POP ECX // Ditch the return addr + + // Get the Pascal object itself. + MOV EAX, [EAX].TRaisedException.ExceptObject + + MOV EDX, [EDX].TExcDescEntry.handler + ADD EDX, EBX // adjust for GOT + CALL NotifyOnExcept + + MOV EBX, ESI // Make sure of user's GOT + JMP EDX // Back to the user code + // never returns +@@NotForMe: + POP EAX // Get the exception object + + // Mark that we're reraising this exception, so that the + // compiler generated exception handler for the 'except on' clause + // will not get confused + OR [EAX].TRaisedException.Flags, excIsBeingReRaised + + JMP SysRaiseException // Should be using resume here +end; +{$ENDIF} + +procedure _HandleOnException; +{$IFDEF PC_MAPPED_EXCEPTIONS} +asm + { -> EAX obj : Exception object } + { [RA] desc: ^TExcDesc } + { <- Doesn't return } + + // Mark the exception as being handled + OR [EAX].TRaisedException.Flags, excIsBeingHandled + + MOV EDX, [ESP] // Get the addr of the TExcDesc + PUSH EAX // Save the object + PUSH EBX // Save EBX + XOR EBX, EBX // No GOT + MOV EAX, [EAX].TRaisedException.ExceptObject + CALL FindOnExceptionDescEntry + POP EBX // Restore EBX + OR EAX, EAX // Is the exception for me? + JE @@NotForMe + + MOV EDX, EAX + POP EAX // Get the object back + POP ECX // Ditch the return addr + + // Get the Pascal object itself. + MOV EAX, [EAX].TRaisedException.ExceptObject + + MOV EDX, [EDX].TExcDescEntry.handler + CALL NotifyOnExcept // Tell the debugger about it + + JMP EDX // Back to the user code + // never returns +@@NotForMe: + POP EAX // Get the exception object + + // Mark that we're reraising this exception, so that the + // compiler generated exception handler for the 'except on' clause + // will not get confused + OR [EAX].TRaisedException.Flags, excIsBeingReRaised + JMP SysRaiseException // Should be using resume here +end; +{$ENDIF} +{$IFNDEF PC_MAPPED_EXCEPTIONS} +asm + { -> [ESP+ 4] excPtr: PExceptionRecord } + { [ESP+ 8] errPtr: PExcFrame } + { [ESP+12] ctxPtr: Pointer } + { [ESP+16] dspPtr: Pointer } + { <- EAX return value - always one } + + MOV EAX,[ESP+4] + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JNE @@exit + + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + JE @@DelphiException + CLD + CALL _FpuInit + MOV EDX,ExceptClsProc + TEST EDX,EDX + JE @@exit + CALL EDX + TEST EAX,EAX + JNE @@common + JMP @@exit + +@@DelphiException: + MOV EAX,[EAX].TExceptionRecord.ExceptObject + MOV EAX,[EAX] { load vtable of exception object } + +@@common: + + MOV EDX,[ESP+8] + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV ECX,[EDX].TExcFrame.desc + MOV EBX,[ECX].TExcDesc.cnt + LEA ESI,[ECX].TExcDesc.excTab { point ECX to exc descriptor table } + MOV EBP,EAX { load vtable of exception object } + +@@innerLoop: + MOV EAX,[ESI].TExcDescEntry.vTable + TEST EAX,EAX { catch all clause? } + JE @@doHandler { yes: go execute handler } + MOV EDI,EBP { load vtable of exception object } + JMP @@haveVMT + +@@vtLoop: + MOV EDI,[EDI] +@@haveVMT: + MOV EAX,[EAX] + CMP EAX,EDI + JE @@doHandler + + MOV ECX,[EAX].vmtInstanceSize + CMP ECX,[EDI].vmtInstanceSize + JNE @@parent + + MOV EAX,[EAX].vmtClassName + MOV EDX,[EDI].vmtClassName + + XOR ECX,ECX + MOV CL,[EAX] + CMP CL,[EDX] + JNE @@parent + + INC EAX + INC EDX + CALL _AStrCmp + JE @@doHandler + +@@parent: + MOV EDI,[EDI].vmtParent { load vtable of parent } + MOV EAX,[ESI].TExcDescEntry.vTable + TEST EDI,EDI + JNE @@vtLoop + + ADD ESI,8 + DEC EBX + JNZ @@innerLoop + + POP EBP + POP EDI + POP ESI + POP EBX + JMP @@exit + +@@doHandler: + MOV EAX,[ESP+4+4*4] + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + MOV EDX,[EAX].TExceptionRecord.ExceptObject + MOV ECX,[EAX].TExceptionRecord.ExceptAddr + JE @@haveObject + CALL ExceptObjProc + MOV EDX,[ESP+12+4*4] + CALL NotifyNonDelphiException +{$IFDEF MSWINDOWS} + CMP BYTE PTR JITEnable,0 + JBE @@NoJIT + CMP BYTE PTR DebugHook,0 + JA @@noJIT { Do not JIT if debugging } + LEA ECX,[ESP+4] + PUSH EAX + PUSH ECX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + POP EAX + JE @@exit +{$ENDIF} +@@noJIT: + MOV EDX,EAX + MOV EAX,[ESP+4+4*4] + MOV ECX,[EAX].TExceptionRecord.ExceptionAddress + JMP @@GoUnwind + +@@haveObject: +{$IFDEF MSWINDOWS} + CMP BYTE PTR JITEnable,1 + JBE @@GoUnwind + CMP BYTE PTR DebugHook,0 + JA @@GoUnwind + PUSH EAX + LEA EAX,[ESP+8] + PUSH EDX + PUSH ECX + PUSH EAX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + POP ECX + POP EDX + POP EAX + JE @@exit +{$ENDIF} + +@@GoUnwind: + XOR EBX,EBX + MOV EBX,FS:[EBX] + PUSH EBX { Save topmost frame } + PUSH EAX { Save exception record } + PUSH EDX { Save exception object } + PUSH ECX { Save exception address } + + MOV EDX,[ESP+8+8*4] + OR [EAX].TExceptionRecord.ExceptionFlags,cUnwinding + + PUSH ESI { Save handler entry } + + PUSH 0 + PUSH EAX + PUSH offset @@returnAddress + PUSH EDX + CALL RtlUnwindProc +@@returnAddress: + + POP EBX { Restore handler entry } + + MOV EDI,[ESP+8+8*4] + + { Make the RaiseList entry on the stack } + + CALL SysInit.@GetTLS + PUSH [EAX].RaiseListPtr + MOV [EAX].RaiseListPtr,ESP + + MOV EBP,[EDI].TExcFrame.hEBP + MOV [EDI].TExcFrame.desc,offset @@exceptFinally + MOV EAX,[ESP].TRaiseFrame.ExceptObject + CALL NotifyOnExcept + JMP [EBX].TExcDescEntry.handler + +@@exceptFinally: + JMP _HandleFinally + +@@destroyExcept: + { we come here if an exception handler has thrown yet another exception } + { we need to destroy the exception object and pop the raise list. } + + CALL SysInit.@GetTLS + MOV ECX,[EAX].RaiseListPtr + MOV EDX,[ECX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,EDX + + MOV EAX,[ECX].TRaiseFrame.ExceptObject + JMP TObject.Free +@@exit: + MOV EAX,1 +end; +{$ENDIF} + +procedure _HandleFinally; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} +{$IFDEF PIC} + MOV ESI, EBX +{$ENDIF} + CALL UnblockOSExceptions + MOV EDX, [ESP] + CALL NotifyExceptFinally + PUSH EAX +{$IFDEF PIC} + MOV EBX, ESI +{$ENDIF} + { + Mark the current exception with the EBP of the handler. If + an exception is raised from the finally block, then this + exception will be orphaned. We will catch this later, when + we clean up the next except block to complete execution. + See DoneExcept. + } + MOV [EAX].TRaisedException.HandlerEBP, EBP + CALL EDX + POP EAX + { + We executed the finally handler without adverse reactions. + It's safe to clear the marker now. + } + MOV [EAX].TRaisedException.HandlerEBP, $FFFFFFFF + PUSH EBP + MOV EBP, ESP + CALL SysRaiseException // Should be using resume here +{$ENDIF} +{$IFDEF MSWINDOWS} + { -> [ESP+ 4] excPtr: PExceptionRecord } + { [ESP+ 8] errPtr: PExcFrame } + { [ESP+12] ctxPtr: Pointer } + { [ESP+16] dspPtr: Pointer } + { <- EAX return value - always one } + + MOV EAX,[ESP+4] + MOV EDX,[ESP+8] + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JE @@exit + MOV ECX,[EDX].TExcFrame.desc + MOV [EDX].TExcFrame.desc,offset @@exit + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBP,[EDX].TExcFrame.hEBP + ADD ECX,TExcDesc.instructions + CALL NotifyExceptFinally + CALL ECX + + POP EBP + POP EDI + POP ESI + POP EBX + +@@exit: + MOV EAX,1 +{$ENDIF} +end; + + +procedure _HandleAutoException; +{$IFDEF LINUX} +{$IFDEF PC_MAPPED_EXCEPTIONS} +asm + // EAX = TObject reference, or nil + // [ESP] = ret addr + + CALL UnblockOSExceptions +// +// The compiler wants the stack to look like this: +// ESP+4-> HRESULT +// ESP+0-> ret addr +// +// Make it so. +// + POP EDX + PUSH 8000FFFFH + PUSH EDX + + OR EAX, EAX // Was this a method call? + JE @@Done + + PUSH EAX + CALL CurrentException + MOV EDX, [EAX].TRaisedException.ExceptObject + MOV ECX, [EAX].TRaisedException.ExceptionAddr; + POP EAX + MOV EAX, [EAX] + CALL [EAX].vmtSafeCallException.Pointer; + MOV [ESP+4], EAX +@@Done: + CALL _DoneExcept +end; +{$ELSE} +begin + Error(reSafeCallError); //!! +end; +{$ENDIF} +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + { -> [ESP+ 4] excPtr: PExceptionRecord } + { [ESP+ 8] errPtr: PExcFrame } + { [ESP+12] ctxPtr: Pointer } + { [ESP+16] dspPtr: Pointer } + { <- EAX return value - always one } + + MOV EAX,[ESP+4] + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JNE @@exit + + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + CLD + CALL _FpuInit + JE @@DelphiException + CMP BYTE PTR JITEnable,0 + JBE @@DelphiException + CMP BYTE PTR DebugHook,0 + JA @@DelphiException + +@@DoUnhandled: + LEA EAX,[ESP+4] + PUSH EAX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + JE @@exit + MOV EAX,[ESP+4] + JMP @@GoUnwind + +@@DelphiException: + CMP BYTE PTR JITEnable,1 + JBE @@GoUnwind + CMP BYTE PTR DebugHook,0 + JA @@GoUnwind + JMP @@DoUnhandled + +@@GoUnwind: + OR [EAX].TExceptionRecord.ExceptionFlags,cUnwinding + + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EDX,[ESP+8+3*4] + + PUSH 0 + PUSH EAX + PUSH offset @@returnAddress + PUSH EDX + CALL RtlUnwindProc + +@@returnAddress: + POP EBP + POP EDI + POP ESI + MOV EAX,[ESP+4] + MOV EBX,8000FFFFH + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + JNE @@done + + MOV EDX,[EAX].TExceptionRecord.ExceptObject + MOV ECX,[EAX].TExceptionRecord.ExceptAddr + MOV EAX,[ESP+8] + MOV EAX,[EAX].TExcFrame.SelfOfMethod + TEST EAX,EAX + JZ @@freeException + MOV EBX,[EAX] + CALL [EBX].vmtSafeCallException.Pointer + MOV EBX,EAX +@@freeException: + MOV EAX,[ESP+4] + MOV EAX,[EAX].TExceptionRecord.ExceptObject + CALL TObject.Free +@@done: + XOR EAX,EAX + MOV ESP,[ESP+8] + POP ECX + MOV FS:[EAX],ECX + POP EDX + POP EBP + LEA EDX,[EDX].TExcDesc.instructions + POP ECX + JMP EDX +@@exit: + MOV EAX,1 +end; +{$ENDIF} + + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _RaiseAtExcept; +asm + { -> EAX Pointer to exception object } + { -> EDX Purported addr of exception } + { Be careful: EBX is not set up in PIC mode. } + { Outward bound calls must go through an exported fn, like SysRaiseException } + OR EAX, EAX + JNE @@GoAhead + MOV EAX, 216 + CALL _RunError + +@@GoAhead: + CALL BlockOSExceptions + PUSH EBP + MOV EBP, ESP + CALL NotifyReRaise + CALL AllocateException + CALL SysRaiseException + { + This can only return if there was a terrible error. In this event, + we have to bail out. + } + JMP _Run0Error +end; +{$ENDIF} + +procedure _RaiseExcept; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + { -> EAX Pointer to exception object } + MOV EDX, [ESP] + JMP _RaiseAtExcept +{$ENDIF} +{$IFDEF MSWINDOWS} + { When making changes to the way Delphi Exceptions are raised, } + { please realize that the C++ Exception handling code reraises } + { some exceptions as Delphi Exceptions. Of course we want to } + { keep exception raising compatible between Delphi and C++, so } + { when you make changes here, consult with the relevant C++ } + { exception handling engineer. The C++ code is in xx.cpp, in } + { the RTL sources, in function tossAnException. } + + { -> EAX Pointer to exception object } + { [ESP] Error address } + + OR EAX, EAX + JNE @@GoAhead + MOV EAX, 216 + CALL _RunError +@@GoAhead: + POP EDX + + PUSH ESP + PUSH EBP + PUSH EDI + PUSH ESI + PUSH EBX + PUSH EAX { pass class argument } + PUSH EDX { pass address argument } + + PUSH ESP { pass pointer to arguments } + PUSH 7 { there are seven arguments } + PUSH cNonContinuable { we can't continue execution } + PUSH cDelphiException { our magic exception code } + PUSH EDX { pass the user's return address } + JMP RaiseExceptionProc +{$ENDIF} +end; + + +{$IFDEF PC_MAPPED_EXCEPTIONS} +{ + Used in the PC mapping exception implementation to handle exceptions in constructors. +} +procedure _ClassHandleException; +asm + { + EAX = self + EDX = top flag + } + TEST DL, DL + JE _RaiseAgain + MOV ECX,[EAX] + MOV DL,$81 + PUSH EAX + CALL dword ptr [ECX].vmtDestroy + POP EAX + CALL _ClassDestroy + JMP _RaiseAgain +end; +{$ENDIF} + +procedure _RaiseAgain; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + CALL CurrentException +// The following notifies the debugger of a reraise of exceptions. This will +// be supported in a later release, but is disabled for now. +// PUSH EAX +// MOV EDX, [EAX].TRaisedException.ExceptionAddr +// MOV EAX, [EAX].TRaisedException.ExceptObject +// CALL NotifyReRaise { Tell the debugger } +// POP EAX + TEST [EAX].TRaisedException.Flags, excIsBeingHandled + JZ @@DoIt + OR [EAX].TRaisedException.Flags, excIsBeingReRaised +@@DoIt: + MOV EDX, [ESP] { Get the user's addr } + JMP SysRaiseException +{$ENDIF} +{$IFDEF MSWINDOWS} + { -> [ESP ] return address to user program } + { [ESP+ 4 ] raise list entry (4 dwords) } + { [ESP+ 4+ 4*4] saved topmost frame } + { [ESP+ 4+ 5*4] saved registers (4 dwords) } + { [ESP+ 4+ 9*4] return address to OS } + { -> [ESP+ 4+10*4] excPtr: PExceptionRecord } + { [ESP+ 8+10*4] errPtr: PExcFrame } + + { Point the error handler of the exception frame to something harmless } + + MOV EAX,[ESP+8+10*4] + MOV [EAX].TExcFrame.desc,offset @@exit + + { Pop the RaiseList } + + CALL SysInit.@GetTLS + MOV EDX,[EAX].RaiseListPtr + MOV ECX,[EDX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,ECX + + { Destroy any objects created for non-delphi exceptions } + + MOV EAX,[EDX].TRaiseFrame.ExceptionRecord + AND [EAX].TExceptionRecord.ExceptionFlags,NOT cUnwinding + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + JE @@delphiException + MOV EAX,[EDX].TRaiseFrame.ExceptObject + CALL TObject.Free + CALL NotifyReRaise + +@@delphiException: + + XOR EAX,EAX + ADD ESP,5*4 + MOV EDX,FS:[EAX] + POP ECX + MOV EDX,[EDX].TExcFrame.next + MOV [ECX].TExcFrame.next,EDX + + POP EBP + POP EDI + POP ESI + POP EBX +@@exit: + MOV EAX,1 +{$ENDIF} +end; + +{$IFDEF DEBUG_EXCEPTIONS} +procedure NoteDE; +begin + Writeln('DoneExcept: Skipped the destructor'); +end; + +procedure NoteDE2; +begin + Writeln('DoneExcept: Destroyed the object'); +end; +{$ENDIF} + +{$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; +var + Exc: PRaisedException; + RefCount: Integer; + ExcObj: Pointer; + ExcAddr: Pointer; +begin + asm + MOV Exc, EAX + end; + + if (Exc^.Flags and excIsBeingReRaised) = 0 then + begin + RefCount := Exc^.RefCount; + ExcObj := Exc^.ExceptObject; + ExcAddr := Exc^.ExceptionAddr; + Exc^.RefCount := 1; + FreeException; + _DoneExcept; + Exc := AllocateException(ExcObj, ExcAddr); + Exc^.RefCount := RefCount; + end; + + Exc^.Flags := Exc^.Flags and not (excIsBeingReRaised or excIsBeingHandled); + + SysRaiseException(Exc); +end; +{$ENDIF} + +procedure _DoneExcept; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + CALL FreeException + OR EAX, EAX + JE @@Done + CALL TObject.Free +@@Done: + { + Take a peek at the next exception object on the stack. + If its EBP marker is at an address lower than our current + EBP, then we know that it was orphaned when an exception was + thrown from within the execution of a finally block. We clean + it up now, so that we won't leak exception records/objects. + } + CALL CurrentException + OR EAX, EAX + JE @@Done2 + CMP [EAX].TRaisedException.HandlerEBP, EBP + JA @@Done2 + CALL FreeException + OR EAX, EAX + JE @@Done2 + CALL TObject.Free +@@Done2: +{$ENDIF} +{$IFDEF MSWINDOWS} + { -> [ESP+ 4+10*4] excPtr: PExceptionRecord } + { [ESP+ 8+10*4] errPtr: PExcFrame } + + { Pop the RaiseList } + + CALL SysInit.@GetTLS + MOV EDX,[EAX].RaiseListPtr + MOV ECX,[EDX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,ECX + + { Destroy exception object } + + MOV EAX,[EDX].TRaiseFrame.ExceptObject + CALL TObject.Free + + POP EDX + MOV ESP,[ESP+8+9*4] + XOR EAX,EAX + POP ECX + MOV FS:[EAX],ECX + POP EAX + POP EBP + CALL NotifyTerminate + JMP EDX +{$ENDIF} +end; + +{$IFNDEF PC_MAPPED_EXCEPTIONS} +procedure _TryFinallyExit; +asm +{$IFDEF MSWINDOWS} + XOR EDX,EDX + MOV ECX,[ESP+4].TExcFrame.desc + MOV EAX,[ESP+4].TExcFrame.next + ADD ECX,TExcDesc.instructions + MOV FS:[EDX],EAX + CALL ECX +@@1: RET 12 +{$ENDIF} +end; +{$ENDIF} + + +var + InitContext: TInitContext; + +{$IFNDEF PC_MAPPED_EXCEPTIONS} +procedure MapToRunError(P: PExceptionRecord); stdcall; +const + STATUS_ACCESS_VIOLATION = $C0000005; + STATUS_ARRAY_BOUNDS_EXCEEDED = $C000008C; + STATUS_FLOAT_DENORMAL_OPERAND = $C000008D; + STATUS_FLOAT_DIVIDE_BY_ZERO = $C000008E; + STATUS_FLOAT_INEXACT_RESULT = $C000008F; + STATUS_FLOAT_INVALID_OPERATION = $C0000090; + STATUS_FLOAT_OVERFLOW = $C0000091; + STATUS_FLOAT_STACK_CHECK = $C0000092; + STATUS_FLOAT_UNDERFLOW = $C0000093; + STATUS_INTEGER_DIVIDE_BY_ZERO = $C0000094; + STATUS_INTEGER_OVERFLOW = $C0000095; + STATUS_PRIVILEGED_INSTRUCTION = $C0000096; + STATUS_STACK_OVERFLOW = $C00000FD; + STATUS_CONTROL_C_EXIT = $C000013A; +var + ErrCode: Byte; +begin + case P.ExceptionCode of + STATUS_INTEGER_DIVIDE_BY_ZERO: ErrCode := 200; + STATUS_ARRAY_BOUNDS_EXCEEDED: ErrCode := 201; + STATUS_FLOAT_OVERFLOW: ErrCode := 205; + STATUS_FLOAT_INEXACT_RESULT, + STATUS_FLOAT_INVALID_OPERATION, + STATUS_FLOAT_STACK_CHECK: ErrCode := 207; + STATUS_FLOAT_DIVIDE_BY_ZERO: ErrCode := 200; + STATUS_INTEGER_OVERFLOW: ErrCode := 215; + STATUS_FLOAT_UNDERFLOW, + STATUS_FLOAT_DENORMAL_OPERAND: ErrCode := 206; + STATUS_ACCESS_VIOLATION: ErrCode := 216; + STATUS_PRIVILEGED_INSTRUCTION: ErrCode := 218; + STATUS_CONTROL_C_EXIT: ErrCode := 217; + STATUS_STACK_OVERFLOW: ErrCode := 202; + else ErrCode := 255; + end; + RunErrorAt(ErrCode, P.ExceptionAddress); +end; + + +procedure _ExceptionHandler; +asm + MOV EAX,[ESP+4] + + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JNE @@exit +{$IFDEF MSWINDOWS} + CMP BYTE PTR DebugHook,0 + JA @@ExecuteHandler + LEA EAX,[ESP+4] + PUSH EAX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + JNE @@ExecuteHandler + JMP @@exit +{$ENDIF} + +@@ExecuteHandler: + MOV EAX,[ESP+4] + CLD + CALL _FpuInit + MOV EDX,[ESP+8] + + PUSH 0 + PUSH EAX + PUSH offset @@returnAddress + PUSH EDX + CALL RtlUnwindProc + +@@returnAddress: + MOV EBX,[ESP+4] + CMP [EBX].TExceptionRecord.ExceptionCode,cDelphiException + MOV EDX,[EBX].TExceptionRecord.ExceptAddr + MOV EAX,[EBX].TExceptionRecord.ExceptObject + JE @@DelphiException2 + + MOV EDX,ExceptObjProc + TEST EDX,EDX + JE MapToRunError + MOV EAX,EBX + CALL EDX + TEST EAX,EAX + JE MapToRunError + MOV EDX,[EBX].TExceptionRecord.ExceptionAddress + +@@DelphiException2: + + CALL NotifyUnhandled + MOV ECX,ExceptProc + TEST ECX,ECX + JE @@noExceptProc + CALL ECX { call ExceptProc(ExceptObject, ExceptAddr) } + +@@noExceptProc: + MOV ECX,[ESP+4] + MOV EAX,217 + MOV EDX,[ECX].TExceptionRecord.ExceptAddr + MOV [ESP],EDX + JMP _RunError + +@@exit: + XOR EAX,EAX +end; + +procedure SetExceptionHandler; +asm + XOR EDX,EDX { using [EDX] saves some space over [0] } +{X} // now we come here from another place, and EBP is used above for loop counter +{X} // let us restore it... +{X} PUSH EBP +{X} LEA EBP, [ESP + $50] + LEA EAX,[EBP-12] + MOV ECX,FS:[EDX] { ECX := head of chain } + MOV FS:[EDX],EAX { head of chain := @exRegRec } + + MOV [EAX].TExcFrame.next,ECX +{$IFDEF PIC} + LEA EDX, [EBX]._ExceptionHandler + MOV [EAX].TExcFrame.desc, EDX +{$ELSE} + MOV [EAX].TExcFrame.desc,offset _ExceptionHandler +{$ENDIF} + MOV [EAX].TExcFrame.hEBP,EBP +{$IFDEF PIC} + MOV [EBX].InitContext.ExcFrame,EAX +{$ELSE} + MOV InitContext.ExcFrame,EAX +{$ENDIF} + +{X} POP EBP +end; + + +procedure UnsetExceptionHandler; +asm + XOR EDX,EDX +{$IFDEF PIC} + MOV EAX,[EBX].InitContext.ExcFrame +{$ELSE} + MOV EAX,InitContext.ExcFrame +{$ENDIF} + TEST EAX,EAX + JZ @@exit + MOV ECX,FS:[EDX] { ECX := head of chain } + CMP EAX,ECX { simple case: our record is first } + JNE @@search + MOV EAX,[EAX] { head of chain := exRegRec.next } + MOV FS:[EDX],EAX + JMP @@exit + +@@loop: + MOV ECX,[ECX] +@@search: + CMP ECX,-1 { at end of list? } + JE @@exit { yes - didn't find it } + CMP [ECX],EAX { is it the next one on the list? } + JNE @@loop { no - look at next one on list } +@@unlink: { yes - unlink our record } + MOV EAX,[EAX] { get next record on list } + MOV [ECX],EAX { unlink our record } +@@exit: +end; +{$ENDIF} // not PC_MAPPED_EXCEPTIONS + +type + TProc = procedure; + +{$IFDEF LINUX} +procedure CallProc(Proc: Pointer; GOT: Cardinal); +asm + PUSH EBX + MOV EBX,EDX + ADD EAX,EBX + CALL EAX + POP EBX +end; +{$ENDIF} + +(*X- Original version... discarded +procedure FinalizeUnits; +var + Count: Integer; + Table: PUnitEntryTable; + P: Pointer; +begin + if InitContext.InitTable = nil then + exit; + Count := InitContext.InitCount; + Table := InitContext.InitTable^.UnitInfo; +{$IFDEF LINUX} + Inc(Cardinal(Table), InitContext.Module^.GOT); +{$ENDIF} + try + while Count > 0 do + begin + Dec(Count); + InitContext.InitCount := Count; + P := Table^[Count].FInit; + if Assigned(P) then + begin +{$IFDEF LINUX} + CallProc(P, InitContext.Module^.GOT); +{$ENDIF} +{$IFDEF MSWINDOWS} + TProc(P)(); +{$ENDIF} + end; + end; + except + FinalizeUnits; { try to finalize the others } + raise; + end; +end; +X+*) + +{X+ see comments in InitUnits below } +//procedure FInitUnits; {X} - renamed to FInitUnitsHard +{X} procedure FInitUnitsHard; +var + Count: Integer; + Table: PUnitEntryTable; + P: procedure; +begin + if InitContext.InitTable = nil then + exit; + Count := InitContext.InitCount; + Table := InitContext.InitTable^.UnitInfo; +{$IFDEF LINUX} + Inc(Cardinal(Table), InitContext.Module^.GOT); +{$ENDIF} + try + while Count > 0 do + begin + Dec(Count); + InitContext.InitCount := Count; + P := Table^[Count].FInit; + if Assigned(P) then +{$IFDEF LINUX} + CallProc(P, InitContext.Module^.GOT); +{$ENDIF} +{$IFDEF MSWINDOWS} + TProc(P)(); +{$ENDIF} + end; + except + {X- rename: FInitUnits; { try to finalize the others } + FInitUnitsHard; + raise; + end; +end; + +// This handler can be set in initialization section of +// unit SysSfIni.pas only. +procedure InitUnitsHard( Table : PUnitEntryTable; Idx, Count : Integer ); +begin + try + InitUnitsLight( Table, Idx, Count ); + except + FInitUnitsHard; + raise; + end; +end; + +{X+ see comments in InitUnits below } +procedure FInitUnitsLight; +var + Count: Integer; + Table: PUnitEntryTable; + P: procedure; +begin + if InitContext.InitTable = nil then + exit; + Count := InitContext.InitCount; + Table := InitContext.InitTable^.UnitInfo; +{$IFDEF LINUX} + Inc(Cardinal(Table), InitContext.Module^.GOT); +{$ENDIF} + while Count > 0 do + begin + Dec(Count); + InitContext.InitCount := Count; + P := Table^[Count].FInit; + if Assigned(P) then +{$IFDEF LINUX} + CallProc(P, InitContext.Module^.GOT); +{$ENDIF} +{$IFDEF MSWINDOWS} + TProc(P)(); +{$ENDIF} + end; +end; + +{X+ see comments in InitUnits below } +procedure InitUnitsLight( Table : PUnitEntryTable; Idx, Count : Integer ); +var P : procedure; + Light : Boolean; +begin + Light := @InitUnitsProc = @InitUnitsLight; + while Idx < Count do + begin + P := Table^[ Idx ].Init; + Inc( Idx ); + InitContext.InitCount := Idx; + if Assigned( P ) then + P; + if Light and (@InitUnitsProc <> @InitUnitsLight) then + begin + InitUnitsProc( Table, Idx, Count ); + break; + end; + end; +end; + +{X+ see comments in body of InitUnits below } +procedure InitUnits; +var + Count, I: Integer; + Table: PUnitEntryTable; + {X- P: Pointer; } +begin + if InitContext.InitTable = nil then + exit; + Count := InitContext.InitTable^.UnitCount; + I := 0; + Table := InitContext.InitTable^.UnitInfo; +{$IFDEF LINUX} + Inc(Cardinal(Table), InitContext.Module^.GOT); +{$ENDIF} + (*X- by default, Delphi InitUnits uses try-except & raise constructions, + which leads to permanent use of all exception handler routines. + Let us make this by another way. + try + while I < Count do + begin + P := Table^[I].Init; + Inc(I); + InitContext.InitCount := I; + if Assigned(P) then + begin +{$IFDEF LINUX} + CallProc(P, InitContext.Module^.GOT); +{$ENDIF} +{$IFDEF MSWINDOWS} + TProc(P)(); +{$ENDIF} + end; + end; + except + FinalizeUnits; + raise; + end; + X+*) + InitUnitsProc( Table, I, Count ); //{X} +end; + +procedure _PackageLoad(const Table : PackageInfo; Module: PLibModule); +var + SavedContext: TInitContext; +begin + SavedContext := InitContext; + InitContext.DLLInitState := 0; + InitContext.InitTable := Table; + InitContext.InitCount := 0; + InitContext.Module := Module; + InitContext.OuterContext := @SavedContext; + try + InitUnits; + finally + InitContext := SavedContext; + end; +end; + + +procedure _PackageUnload(const Table : PackageInfo; Module: PLibModule); +var + SavedContext: TInitContext; +begin + SavedContext := InitContext; + InitContext.DLLInitState := 0; + InitContext.InitTable := Table; + InitContext.InitCount := Table^.UnitCount; + InitContext.Module := Module; + InitContext.OuterContext := @SavedContext; + try + {X} //FinalizeUnits; + FInitUnitsProc; + finally + InitContext := SavedContext; + end; +end; + +{$IFDEF LINUX} +procedure _StartExe(InitTable: PackageInfo; Module: PLibModule; Argc: Integer; Argv: Pointer); +begin + ArgCount := Argc; + ArgValues := Argv; +{$ENDIF} +{$IFDEF MSWINDOWS} +procedure _StartExe(InitTable: PackageInfo; Module: PLibModule); +begin + RaiseExceptionProc := @RaiseException; + RTLUnwindProc := @RTLUnwind; +{$ENDIF} + InitContext.InitTable := InitTable; + InitContext.InitCount := 0; + InitContext.Module := Module; + MainInstance := Module.Instance; +{$IFNDEF PC_MAPPED_EXCEPTIONS} + + {X SetExceptionHandler; - moved to SysSfIni.pas } + +{$ENDIF} + IsLibrary := False; + InitUnits; +end; + +{$IFDEF MSWINDOWS} +procedure _StartLib; +asm + { -> EAX InitTable } + { EDX Module } + { ECX InitTLS } + { [ESP+4] DllProc } + { [EBP+8] HInst } + { [EBP+12] Reason } + + { Push some desperately needed registers } + + PUSH ECX + PUSH ESI + PUSH EDI + + { Save the current init context into the stackframe of our caller } + + MOV ESI,offset InitContext + LEA EDI,[EBP- (type TExcFrame) - (type TInitContext)] + MOV ECX,(type TInitContext)/4 + REP MOVSD + + { Setup the current InitContext } + + POP InitContext.DLLSaveEDI + POP InitContext.DLLSaveESI + MOV InitContext.DLLSaveEBP,EBP + MOV InitContext.DLLSaveEBX,EBX + MOV InitContext.InitTable,EAX + MOV InitContext.Module,EDX + LEA ECX,[EBP- (type TExcFrame) - (type TInitContext)] + MOV InitContext.OuterContext,ECX + XOR ECX,ECX + CMP dword ptr [EBP+12],0 + JNE @@notShutDown + MOV ECX,[EAX].PackageInfoTable.UnitCount +@@notShutDown: + MOV InitContext.InitCount,ECX + + MOV EAX, offset RaiseException + MOV RaiseExceptionProc, EAX + MOV EAX, offset RTLUnwind + MOV RTLUnwindProc, EAX + + CALL SetExceptionHandler + + MOV EAX,[EBP+12] + INC EAX + MOV InitContext.DLLInitState,AL + DEC EAX + + { Init any needed TLS } + + POP ECX + MOV EDX,[ECX] + MOV InitContext.ExitProcessTLS,EDX + JE @@skipTLSproc + CMP AL,3 // DLL_THREAD_DETACH + JGE @@skipTLSproc // call ExitThreadTLS proc after DLLProc + CALL dword ptr [ECX+EAX*4] +@@skipTLSproc: + + { Call any DllProc } + + PUSH ECX + MOV ECX,[ESP+4] + TEST ECX,ECX + JE @@noDllProc + MOV EAX,[EBP+12] + MOV EDX,[EBP+16] + CALL ECX +@@noDllProc: + + POP ECX + MOV EAX, [EBP+12] + CMP AL,3 // DLL_THREAD_DETACH + JL @@afterDLLproc // don't free TLS on process shutdown + CALL dword ptr [ECX+EAX*4] + +@@afterDLLProc: + + { Set IsLibrary if there was no exe yet } + + CMP MainInstance,0 + JNE @@haveExe + MOV IsLibrary,1 + FNSTCW Default8087CW // save host exe's FPU preferences + +@@haveExe: + + MOV EAX,[EBP+12] + DEC EAX + JNE _Halt0 + CALL InitUnits + RET 4 +end; +{$ENDIF MSWINDOWS} +{$IFDEF LINUX} +procedure _StartLib(Context: PInitContext; Module: PLibModule; DLLProc: TDLLProcEx); +var + TempSwap: TInitContext; +begin + // Context's register save fields are already initialized. + // Save the current InitContext and activate the new Context by swapping them + TempSwap := InitContext; + InitContext := PInitContext(Context)^; + PInitContext(Context)^ := TempSwap; + + InitContext.Module := Module; + InitContext.OuterContext := Context; + + // DLLInitState is initialized by SysInit to 0 for shutdown, 1 for startup + // Inc DLLInitState to distinguish from package init: + // 0 for package, 1 for DLL shutdown, 2 for DLL startup + + Inc(InitContext.DLLInitState); + + if InitContext.DLLInitState = 1 then + begin + InitContext.InitTable := Module.InitTable; + if Assigned(InitContext.InitTable) then + InitContext.InitCount := InitContext.InitTable.UnitCount // shutdown + end + else + begin + Module.InitTable := InitContext.InitTable; // save for shutdown + InitContext.InitCount := 0; // startup + end; + + if Assigned(DLLProc) then + DLLProc(InitContext.DLLInitState-1,0); + + if MainInstance = 0 then { Set IsLibrary if there was no exe yet } + begin + IsLibrary := True; + Default8087CW := Get8087CW; + end; + + if InitContext.DLLInitState = 1 then + _Halt0 + else + InitUnits; +end; +{$ENDIF} + +procedure _InitResStrings; +asm + { -> EAX Pointer to init table } + { record } + { cnt: Integer; } + { tab: array [1..cnt] record } + { variableAddress: Pointer; } + { resStringAddress: Pointer; } + { end; } + { end; } + { EBX = caller's GOT for PIC callers, 0 for non-PIC } + +{$IFDEF MSWINDOWS} + PUSH EBX + XOR EBX,EBX +{$ENDIF} + PUSH EDI + PUSH ESI + MOV EDI,[EBX+EAX] + LEA ESI,[EBX+EAX+4] +@@loop: + MOV EAX,[ESI+4] { load resStringAddress } + MOV EDX,[ESI] { load variableAddress } + ADD EAX,EBX + ADD EDX,EBX + CALL LoadResString + ADD ESI,8 + DEC EDI + JNZ @@loop + + POP ESI + POP EDI +{$IFDEF MSWINDOWS} + POP EBX +{$ENDIF} +end; + +procedure _InitResStringImports; +asm + { -> EAX Pointer to init table } + { record } + { cnt: Integer; } + { tab: array [1..cnt] record } + { variableAddress: Pointer; } + { resStringAddress: ^Pointer; } + { end; } + { end; } + { EBX = caller's GOT for PIC callers, 0 for non-PIC } + +{$IFDEF MSWINDOWS} + PUSH EBX + XOR EBX,EBX +{$ENDIF} + PUSH EDI + PUSH ESI + MOV EDI,[EBX+EAX] + LEA ESI,[EBX+EAX+4] +@@loop: + MOV EAX,[ESI+4] { load address of import } + MOV EDX,[ESI] { load address of variable } + MOV EAX,[EBX+EAX] { load contents of import } + ADD EDX,EBX + CALL LoadResString + ADD ESI,8 + DEC EDI + JNZ @@loop + + POP ESI + POP EDI +{$IFDEF MSWINDOWS} + POP EBX +{$ENDIF} +end; + +procedure _InitImports; +asm + { -> EAX Pointer to init table } + { record } + { cnt: Integer; } + { tab: array [1..cnt] record } + { variableAddress: Pointer; } + { sourceAddress: ^Pointer; } + { sourceOffset: Longint; } + { end; } + { end; } + { EBX = caller's GOT for PIC callers, 0 for non-PIC } + +{$IFDEF MSWINDOWS} + PUSH EBX + XOR EBX,EBX +{$ENDIF} + PUSH EDI + PUSH ESI + MOV EDI,[EBX+EAX] + LEA ESI,[EBX+EAX+4] +@@loop: + MOV EAX,[ESI+4] { load address of import } + MOV EDX,[ESI] { load address of variable } + MOV EAX,[EBX+EAX] { load contents of import } + ADD EAX,[ESI+8] { calc address of variable } + MOV [EBX+EDX],EAX { store result } + ADD ESI,12 + DEC EDI + JNZ @@loop + + POP ESI + POP EDI +{$IFDEF MSWINDOWS} + POP EBX +{$ENDIF} +end; + +{$IFDEF MSWINDOWS} +procedure _InitWideStrings; +asm + { -> EAX Pointer to init table } + { record } + { cnt: Integer; } + { tab: array [1..cnt] record } + { variableAddress: Pointer; } + { stringAddress: ^Pointer; } + { end; } + { end; } + + PUSH EBX + PUSH ESI + MOV EBX,[EAX] + LEA ESI,[EAX+4] +@@loop: + MOV EDX,[ESI+4] { load address of string } + MOV EAX,[ESI] { load address of variable } + CALL _WStrAsg + ADD ESI,8 + DEC EBX + JNZ @@loop + + POP ESI + POP EBX +end; +{$ENDIF} + +var + runErrMsg: array[0..29] of Char = 'Runtime error at 00000000'#0; + // columns: 0123456789012345678901234567890 + errCaption: array[0..5] of Char = 'Error'#0; + + +procedure MakeErrorMessage; +const + dig : array [0..15] of Char = '0123456789ABCDEF'; +var + digit: Byte; + Temp: Integer; + Addr: Cardinal; +begin + digit := 16; + Temp := ExitCode; + repeat + runErrMsg[digit] := Char(Ord('0') + (Temp mod 10)); + Temp := Temp div 10; + Dec(digit); + until Temp = 0; + digit := 28; + Addr := Cardinal(ErrorAddr); + repeat + runErrMsg[digit] := dig[Addr and $F]; + Addr := Addr div 16; + Dec(digit); + until Addr = 0; +end; + + +procedure ExitDll; +asm + { Return False if ExitCode <> 0, and set ExitCode to 0 } + + XOR EAX,EAX +{$IFDEF PIC} + MOV ECX,[EBX].ExitCode + XCHG EAX,[ECX] +{$ELSE} + XCHG EAX, ExitCode +{$ENDIF} + NEG EAX + SBB EAX,EAX + INC EAX + + { Restore the InitContext } +{$IFDEF PIC} + LEA EDI, [EBX].InitContext +{$ELSE} + MOV EDI, offset InitContext +{$ENDIF} + + MOV EBX,[EDI].TInitContext.DLLSaveEBX + MOV EBP,[EDI].TInitContext.DLLSaveEBP + PUSH [EDI].TInitContext.DLLSaveESI + PUSH [EDI].TInitContext.DLLSaveEDI + + MOV ESI,[EDI].TInitContext.OuterContext + MOV ECX,(type TInitContext)/4 + REP MOVSD + POP EDI + POP ESI + + LEAVE +{$IFDEF MSWINDOWS} + RET 12 +{$ENDIF} +{$IFDEF LINUX} + RET +{$ENDIF} +end; + +// {X} Procedure Halt0 refers to WriteLn and MessageBox +// but actually such code can be not used really. +// So, implementation changed to avoid such references. +// +// Either call UseErrorMessageBox or UseErrorMessageWrite +// to provide error message output in GUI or console app. +// {X}+ + +var ErrorMessageOutProc : procedure = DummyProc; + +procedure ErrorMessageBox; +begin + MakeErrorMessage; + if not NoErrMsg then + MessageBox(0, runErrMsg, errCaption, 0); +end; + +procedure UseErrorMessageBox; +begin + ErrorMessageOutProc := ErrorMessageBox; +end; + +procedure ErrorMessageWrite; +begin + MakeErrorMessage; + WriteLn(PChar(@runErrMsg)); +end; + +procedure UseErrorMessageWrite; +begin + ErrorMessageOutProc := ErrorMessageWrite; +end; + +procedure DoCloseInputOutput; +begin + Close( Input ); + Close( Output ); + Close(ErrOutput); +end; + +var CloseInputOutput : procedure = DummyProc; + +procedure UseInputOutput; +begin + if not assigned( CloseInputOutput ) then + begin + CloseInputOutput := DoCloseInputOutput; + //_Assign( Input, '' ); was for D5 so - changed + //_Assign( Output, '' ); was for D5 so - changed + TTextRec(Input).Mode := fmClosed; + TTextRec(Output).Mode := fmClosed; + TTextRec(ErrOutput).Mode := fmClosed; + end; +end; + +// {X}- +(*X- +procedure WriteErrorMessage; +{$IFDEF MSWINDOWS} +var + Dummy: Cardinal; +begin + if IsConsole then + begin + with TTextRec(Output) do + begin + if (Mode = fmOutput) and (BufPos > 0) then + TTextIOFunc(InOutFunc)(TTextRec(Output)); // flush out text buffer + end; + WriteFile(GetStdHandle(STD_OUTPUT_HANDLE), runErrMsg, Sizeof(runErrMsg), Dummy, nil); + WriteFile(GetStdHandle(STD_OUTPUT_HANDLE), sLineBreak, 2, Dummy, nil); + end + else if not NoErrMsg then + MessageBox(0, runErrMsg, errCaption, 0); +{$ENDIF} +{$IFDEF LINUX} +var + c: Char; +begin + with TTextRec(Output) do + begin + if (Mode = fmOutput) and (BufPos > 0) then + TTextIOFunc(InOutFunc)(TTextRec(Output)); // flush out text buffer + end; + __write(STDERR_FILENO, @runErrMsg, Sizeof(runErrMsg)-1); + c := sLineBreak; + __write(STDERR_FILENO, @c, 1); +{$ENDIF} +end; +X+*) + +procedure _Halt0; +var + P: procedure; +begin +{$IFDEF LINUX} + if (ExitCode <> 0) and CoreDumpEnabled then + __raise(SIGABRT); +{$ENDIF} + + if InitContext.DLLInitState = 0 then + while ExitProc <> nil do + begin + @P := ExitProc; + ExitProc := nil; + P; + end; + + { If there was some kind of runtime error, alert the user } + + if ErrorAddr <> nil then + begin + {X+} + ErrorMessageOutProc; + { + MakeErrorMessage; + if IsConsole then + WriteLn(PChar(@runErrMsg)) + else if not NoErrMsg then + MessageBox(0, runErrMsg, errCaption, 0); + } {X-} + + {X- As it is said by Alexey Torgashin, it is better not to clear ErrorAddr + to make possible check ErrorAddr <> nil in finalization of rest units. + If you want, you can uncomment it again: } + //ErrorAddr := nil; + {X+} + end; + + { This loop exists because we might be nested in PackageLoad calls when } + { Halt got called. We need to unwind these contexts. } + + while True do + begin + + { If we are a library, and we are starting up fine, there are no units to finalize } + + if (InitContext.DLLInitState = 2) and (ExitCode = 0) then + InitContext.InitCount := 0; + + { Undo any unit initializations accomplished so far } + + // {X} FinalizeUnits; -- renamed + FInitUnitsProc; + + if (InitContext.DLLInitState <= 1) or (ExitCode <> 0) then + begin + if InitContext.Module <> nil then + with InitContext do + begin + UnregisterModule(Module); +{$IFDEF PC_MAPPED_EXCEPTIONS} + SysUnregisterIPLookup(Module.CodeSegStart); +{$ENDIF} + if (Module.ResInstance <> Module.Instance) and (Module.ResInstance <> 0) then + FreeLibrary(Module.ResInstance); + end; + end; + +{$IFNDEF PC_MAPPED_EXCEPTIONS} + {X UnsetExceptionHandler; - changed to call of handler } + UnsetExceptionHandlerProc; +{$ENDIF} + +{$IFDEF MSWINDOWS} + if InitContext.DllInitState = 1 then + InitContext.ExitProcessTLS; +{$ENDIF} + + if InitContext.DllInitState <> 0 then + ExitDll; + + if InitContext.OuterContext = nil then + begin + { + If an ExitProcessProc is set, we call it. Note that at this + point the RTL is completely shutdown. The only thing this is used + for right now is the proper semantic handling of signals under Linux. + } + if Assigned(ExitProcessProc) then + ExitProcessProc; + ExitProcess(ExitCode); + end; + + InitContext := InitContext.OuterContext^ + end; +end; + +procedure _Halt; +begin + ExitCode := Code; + _Halt0; +end; + + +procedure _Run0Error; +{$IFDEF PUREPASCAL} +begin + _RunError(0); // loses return address +end; +{$ELSE} +asm + XOR EAX,EAX + JMP _RunError +end; +{$ENDIF} + + +procedure _RunError(errorCode: Byte); +{$IFDEF PUREPASCAL} +begin + ErrorAddr := Pointer(-1); // no return address available + Halt(errorCode); +end; +{$ELSE} +asm +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX, EAX + POP EAX + MOV ECX, [EBX].ErrorAddr + POP [ECX] +{$ELSE} + POP ErrorAddr +{$ENDIF} + JMP _Halt +end; +{$ENDIF} + +procedure _UnhandledException; +type TExceptProc = procedure (Obj: TObject; Addr: Pointer); +begin + if Assigned(ExceptProc) then + TExceptProc(ExceptProc)(ExceptObject, ExceptAddr) + else + RunError(230); +end; + +procedure _Assert(const Message, Filename: AnsiString; LineNumber: Integer); +{$IFDEF PUREPASCAL} +begin + if Assigned(AssertErrorProc) then + AssertErrorProc(Message, Filename, LineNumber, Pointer(-1)) + else + Error(reAssertionFailed); // loses return address +end; +{$ELSE} +asm + PUSH EBX +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + MOV EBX, EAX + MOV EAX, [EBX].AssertErrorProc + CMP [EAX], 0 + POP ECX + POP EAX +{$ELSE} + CMP AssertErrorProc,0 +{$ENDIF} + JNZ @@1 + MOV AL,reAssertionFailed + CALL Error + JMP @@exit + +@@1: PUSH [ESP+4].Pointer +{$IFDEF PIC} + MOV EBX, [EBX].AssertErrorProc + CALL [EBX] +{$ELSE} + CALL AssertErrorProc +{$ENDIF} +@@exit: + POP EBX +end; +{$ENDIF} + +type + PThreadRec = ^TThreadRec; + TThreadRec = record + Func: TThreadFunc; + Parameter: Pointer; + end; + +{$IFDEF MSWINDOWS} +function ThreadWrapper(Parameter: Pointer): Integer; stdcall; +{$ELSE} +function ThreadWrapper(Parameter: Pointer): Pointer; cdecl; +{$ENDIF} +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + { Mark the top of the stack with a signature } + PUSH UNWINDFI_TOPOFSTACK +{$ENDIF} + CALL _FpuInit + PUSH EBP +{$IFNDEF PC_MAPPED_EXCEPTIONS} + XOR ECX,ECX + PUSH offset _ExceptionHandler + MOV EDX,FS:[ECX] + PUSH EDX + MOV FS:[ECX],ESP +{$ENDIF} + MOV EAX,Parameter + + MOV ECX,[EAX].TThreadRec.Parameter + MOV EDX,[EAX].TThreadRec.Func + PUSH ECX + PUSH EDX + CALL _FreeMem + POP EDX + POP EAX + CALL EDX + +{$IFNDEF PC_MAPPED_EXCEPTIONS} + XOR EDX,EDX + POP ECX + MOV FS:[EDX],ECX + POP ECX +{$ENDIF} + POP EBP +{$IFDEF PC_MAPPED_EXCEPTIONS} + { Ditch our TOS marker } + ADD ESP, 4 +{$ENDIF} +end; + + +{$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} + +{$IFDEF LINUX} +function BeginThread(Attribute: PThreadAttr; + ThreadFunc: TThreadFunc; + Parameter: Pointer; + var ThreadId: Cardinal): Integer; +var + P: PThreadRec; +begin + if Assigned(BeginThreadProc) then + Result := BeginThreadProc(Attribute, ThreadFunc, Parameter, ThreadId) + else + begin + New(P); + P.Func := ThreadFunc; + P.Parameter := Parameter; + IsMultiThread := True; + Result := _pthread_create(ThreadID, Attribute, @ThreadWrapper, P); + end; +end; + +procedure EndThread(ExitCode: Integer); +begin + if Assigned(EndThreadProc) then + EndThreadProc(ExitCode); + // No "else" required since EndThreadProc does not (!!should not!!) return. + _pthread_detach(GetCurrentThreadID); + _pthread_exit(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); +{$IFDEF PUREPASCAL} +var + P: PStrRec; +begin + if Pointer(S) <> nil then + begin + P := Pointer(Integer(S) - Sizeof(StrRec)); + Pointer(S) := nil; + if P.refCnt > 0 then + if InterlockedDecrement(P.refCnt) = 0 then + FreeMem(P); + end; +end; +{$ELSE} +asm + { -> EAX pointer to str } + + MOV EDX,[EAX] { fetch str } + TEST EDX,EDX { if nil, nothing to do } + JE @@done + MOV dword ptr [EAX],0 { clear str } + MOV ECX,[EDX-skew].StrRec.refCnt { fetch refCnt } + DEC ECX { if < 0: literal str } + JL @@done +{X LOCK} DEC [EDX-skew].StrRec.refCnt { NONthreadsafe dec refCount } + JNE @@done + PUSH EAX + LEA EAX,[EDX-skew].StrRec.refCnt { if refCnt now zero, deallocate} + CALL _FreeMem + POP EAX +@@done: +end; +{$ENDIF} + +procedure _LStrArrayClr(var StrArray; cnt: longint); +{$IFDEF PUREPASCAL} +var + P: Pointer; +begin + P := @StrArray; + while cnt > 0 do + begin + _LStrClr(P^); + Dec(cnt); + Inc(Integer(P), sizeof(Pointer)); + end; +end; +{$ELSE} +asm + { -> EAX pointer to str } + { EDX cnt } + + PUSH EBX + PUSH ESI + MOV EBX,EAX + MOV ESI,EDX + +@@loop: + MOV EDX,[EBX] { fetch str } + TEST EDX,EDX { if nil, nothing to do } + JE @@doneEntry + MOV dword ptr [EBX],0 { clear str } + MOV ECX,[EDX-skew].StrRec.refCnt { fetch refCnt } + DEC ECX { if < 0: literal str } + JL @@doneEntry +{X LOCK} DEC [EDX-skew].StrRec.refCnt { NONthreadsafe dec refCount } + JNE @@doneEntry + LEA EAX,[EDX-skew].StrRec.refCnt { if refCnt now zero, deallocate} + CALL _FreeMem +@@doneEntry: + ADD EBX,4 + DEC ESI + JNE @@loop + + POP ESI + POP EBX +end; +{$ENDIF} + +{ 99.03.11 + This function is used when assigning to global variables. + + Literals are copied to prevent a situation where a dynamically + allocated DLL or package assigns a literal to a variable and then + is unloaded -- thereby causing the string memory (in the code + segment of the DLL) to be removed -- and therefore leaving the + global variable pointing to invalid memory. +} +procedure _LStrAsg(var dest; const source); +{$IFDEF PUREPASCAL} +var + S, D: Pointer; + P: PStrRec; + Temp: Longint; +begin + S := Pointer(source); + if S <> nil then + begin + P := PStrRec(Integer(S) - sizeof(StrRec)); + if P.refCnt < 0 then // make copy of string literal + begin + Temp := P.length; + S := _NewAnsiString(Temp); + Move(Pointer(source)^, S^, Temp); + P := PStrRec(Integer(S) - sizeof(StrRec)); + end; + InterlockedIncrement(P.refCnt); + end; + + D := Pointer(dest); + Pointer(dest) := S; + if D <> nil then + begin + P := PStrRec(Integer(D) - sizeof(StrRec)); + if P.refCnt > 0 then + if InterlockedDecrement(P.refCnt) = 0 then + FreeMem(P); + end; +end; +{$ELSE} +asm + { -> EAX pointer to dest str } + { -> EDX pointer to source str } + + TEST EDX,EDX { have a source? } + JE @@2 { no -> jump } + + MOV ECX,[EDX-skew].StrRec.refCnt + INC ECX + JG @@1 { literal string -> jump not taken } + + PUSH EAX + PUSH EDX + MOV EAX,[EDX-skew].StrRec.length + CALL _NewAnsiString + MOV EDX,EAX + POP EAX + PUSH EDX + MOV ECX,[EAX-skew].StrRec.length + CALL Move + POP EDX + POP EAX + JMP @@2 + +@@1: + {X LOCK} INC [EDX-skew].StrRec.refCnt + +@@2: XCHG EDX,[EAX] + TEST EDX,EDX + JE @@3 + MOV ECX,[EDX-skew].StrRec.refCnt + DEC ECX + JL @@3 + {X LOCK} DEC [EDX-skew].StrRec.refCnt + JNE @@3 + LEA EAX,[EDX-skew].StrRec.refCnt + CALL _FreeMem +@@3: +end; +{$ENDIF} + +procedure _LStrLAsg(var dest; const source); +{$IFDEF PUREPASCAL} +var + P: Pointer; +begin + P := Pointer(source); + _LStrAddRef(P); + P := Pointer(dest); + Pointer(dest) := Pointer(source); + _LStrClr(P); +end; +{$ELSE} +asm +{ -> EAX pointer to dest } +{ EDX source } + + TEST EDX,EDX + JE @@sourceDone + + { bump up the ref count of the source } + + MOV ECX,[EDX-skew].StrRec.refCnt + INC ECX + JLE @@sourceDone { literal assignment -> jump taken } + {X LOCK} INC [EDX-skew].StrRec.refCnt +@@sourceDone: + + { we need to release whatever the dest is pointing to } + + XCHG EDX,[EAX] { fetch str } + TEST EDX,EDX { if nil, nothing to do } + JE @@done + MOV ECX,[EDX-skew].StrRec.refCnt { fetch refCnt } + DEC ECX { if < 0: literal str } + JL @@done + {X LOCK} DEC [EDX-skew].StrRec.refCnt { NONthreadsafe dec refCount } + JNE @@done + LEA EAX,[EDX-skew].StrRec.refCnt { if refCnt now zero, deallocate} + CALL _FreeMem +@@done: +end; +{$ENDIF} + +function _NewAnsiString(length: Longint): Pointer; +{$IFDEF PUREPASCAL} +var + P: PStrRec; +begin + Result := nil; + if length <= 0 then Exit; + // Alloc an extra null for strings with even length. This has no actual cost + // since the allocator will round up the request to an even size anyway. + // All widestring allocations have even length, and need a double null terminator. + GetMem(P, length + sizeof(StrRec) + 1 + ((length + 1) and 1)); + Result := Pointer(Integer(P) + sizeof(StrRec)); + P.length := length; + P.refcnt := 1; + PWideChar(Result)[length div 2] := #0; // length guaranteed >= 2 +end; +{$ELSE} +asm + { -> EAX length } + { <- EAX pointer to new string } + + TEST EAX,EAX + JLE @@null + PUSH EAX + ADD EAX,rOff+2 // one or two nulls (Ansi/Wide) + AND EAX, not 1 // round up to even length + PUSH EAX + CALL _GetMem + POP EDX // actual allocated length (>= 2) + MOV word ptr [EAX+EDX-2],0 // double null terminator + ADD EAX,rOff + POP EDX // requested string length + MOV [EAX-skew].StrRec.length,EDX + MOV [EAX-skew].StrRec.refCnt,1 + RET +@@null: + XOR EAX,EAX +end; +{$ENDIF} + +procedure _LStrFromPCharLen(var Dest: AnsiString; Source: PAnsiChar; Length: Integer); +asm + { -> EAX pointer to dest } + { EDX source } + { ECX length } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + { allocate new string } + + MOV EAX,EDI + + CALL _NewAnsiString + MOV ECX,EDI + MOV EDI,EAX + + TEST ESI,ESI + JE @@noMove + + MOV EDX,EAX + MOV EAX,ESI + CALL Move + + { assign the result to dest } + +@@noMove: + MOV EAX,EBX + CALL _LStrClr + MOV [EBX],EDI + + POP EDI + POP ESI + POP EBX +end; + + +{$IFDEF LINUX} +function BufConvert(var Dest; DestBytes: Integer; + const Source; SrcBytes: Integer; + context: Integer): Integer; +var + SrcBytesLeft, DestBytesLeft: Integer; + s, d: Pointer; +begin + if context = -1 then + begin + Result := -1; + Exit; + end; + // make copies of params... iconv modifies param ptrs + DestBytesLeft := DestBytes; + SrcBytesLeft := SrcBytes; + s := Pointer(Source); + d := Pointer(Dest); + if (SrcBytes = 0) or (DestBytes = 0) then + Result := 0 + else + begin + Result := iconv(context, s, SrcBytesLeft, d, DestBytesLeft); + while (SrcBytesLeft > 0) and (DestBytesLeft > 0) + and (Result = -1) and (GetLastError = 7) do + begin + Result := iconv(context, s, SrcBytesLeft, d, DestBytesLeft); + end; + + if Result <> -1 then + Result := DestBytes - DestBytesLeft; + end; + + iconv_close(context); +end; +{$ENDIF} + + +function CharFromWChar(CharDest: PChar; DestBytes: Integer; const WCharSource: PWideChar; SrcChars: Integer): Integer; +begin +{$IFDEF LINUX} + Result := BufConvert(CharDest, DestBytes, WCharSource, SrcChars * sizeof(WideChar), + iconv_open(nl_langinfo(_NL_CTYPE_CODESET_NAME), 'UNICODELITTLE')); +{$ENDIF} +{$IFDEF MSWINDOWS} + Result := WideCharToMultiByte(0, 0, WCharSource, SrcChars, + CharDest, DestBytes, nil, nil); +{$ENDIF} +end; + + +function WCharFromChar(WCharDest: PWideChar; DestChars: Integer; const CharSource: PChar; SrcBytes: Integer): Integer; +begin +{$IFDEF LINUX} + Result := BufConvert(WCharDest, DestChars * sizeof(WideChar), CharSource, SrcBytes, + iconv_open('UNICODELITTLE', nl_langinfo(_NL_CTYPE_CODESET_NAME))) div sizeof(WideChar); +{$ENDIF} +{$IFDEF MSWINDOWS} + Result := MultiByteToWideChar(0, 0, CharSource, SrcBytes, + WCharDest, DestChars); +{$ENDIF} +end; + + +procedure _LStrFromPWCharLen(var Dest: AnsiString; Source: PWideChar; Length: Integer); +var + DestLen: Integer; + Buffer: array[0..4095] of Char; +begin + if Length <= 0 then + begin + _LStrClr(Dest); + Exit; + end; + if Length+1 < (High(Buffer) div sizeof(WideChar)) then + begin + DestLen := CharFromWChar(Buffer, High(Buffer), Source, Length); + if DestLen >= 0 then + begin + _LStrFromPCharLen(Dest, Buffer, DestLen); + Exit; + end; + end; + + DestLen := (Length + 1) * sizeof(WideChar); + SetLength(Dest, DestLen); // overallocate, trim later + DestLen := CharFromWChar(Pointer(Dest), DestLen, Source, Length); + if DestLen < 0 then DestLen := 0; + SetLength(Dest, DestLen); +end; + + +procedure _LStrFromChar(var Dest: AnsiString; Source: AnsiChar); +asm + PUSH EDX + MOV EDX,ESP + MOV ECX,1 + CALL _LStrFromPCharLen + POP EDX +end; + + +procedure _LStrFromWChar(var Dest: AnsiString; Source: WideChar); +asm + PUSH EDX + MOV EDX,ESP + MOV ECX,1 + CALL _LStrFromPWCharLen + POP EDX +end; + + +procedure _LStrFromPChar(var Dest: AnsiString; Source: PAnsiChar); +asm + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CL,[EDX+0] + JE @@4 + CMP CL,[EDX+1] + JE @@3 + CMP CL,[EDX+2] + JE @@2 + CMP CL,[EDX+3] + JE @@1 + ADD EDX,4 + JMP @@0 +@@1: INC EDX +@@2: INC EDX +@@3: INC EDX +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX +@@5: JMP _LStrFromPCharLen +end; + + +procedure _LStrFromPWChar(var Dest: AnsiString; Source: PWideChar); +asm + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CX,[EDX+0] + JE @@4 + CMP CX,[EDX+2] + JE @@3 + CMP CX,[EDX+4] + JE @@2 + CMP CX,[EDX+6] + JE @@1 + ADD EDX,8 + JMP @@0 +@@1: ADD EDX,2 +@@2: ADD EDX,2 +@@3: ADD EDX,2 +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX + SHR ECX,1 +@@5: JMP _LStrFromPWCharLen +end; + + +procedure _LStrFromString(var Dest: AnsiString; const Source: ShortString); +asm + XOR ECX,ECX + MOV CL,[EDX] + INC EDX + JMP _LStrFromPCharLen +end; + + +procedure _LStrFromArray(var Dest: AnsiString; Source: PAnsiChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASB + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _LStrFromPCharLen +end; + + +procedure _LStrFromWArray(var Dest: AnsiString; Source: PWideChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASW + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _LStrFromPWCharLen +end; + + +procedure _LStrFromWStr(var Dest: AnsiString; const Source: WideString); +asm + { -> EAX pointer to dest } + { EDX pointer to WideString data } + + XOR ECX,ECX + TEST EDX,EDX + JE @@1 + MOV ECX,[EDX-4] + SHR ECX,1 +@@1: JMP _LStrFromPWCharLen +end; + + +procedure _LStrToString{(var Dest: ShortString; const Source: AnsiString; MaxLen: Integer)}; +asm + { -> EAX pointer to result } + { EDX AnsiString s } + { ECX length of result } + + PUSH EBX + TEST EDX,EDX + JE @@empty + MOV EBX,[EDX-skew].StrRec.length + TEST EBX,EBX + JE @@empty + + CMP ECX,EBX + JL @@truncate + MOV ECX,EBX +@@truncate: + MOV [EAX],CL + INC EAX + + XCHG EAX,EDX + CALL Move + + JMP @@exit + +@@empty: + MOV byte ptr [EAX],0 + +@@exit: + POP EBX +end; + +function _LStrLen(const s: AnsiString): Longint; +{$IFDEF PUREPASCAL} +begin + Result := 0; + if Pointer(s) <> nil then + Result := PStrRec(Integer(s) - sizeof(StrRec)).length; +end; +{$ELSE} +asm + { -> EAX str } + + TEST EAX,EAX + JE @@done + MOV EAX,[EAX-skew].StrRec.length; +@@done: +end; +{$ENDIF} + + +procedure _LStrCat{var dest: AnsiString; source: AnsiString}; +asm + { -> EAX pointer to dest } + { EDX source } + + TEST EDX,EDX + JE @@exit + + MOV ECX,[EAX] + TEST ECX,ECX + JE _LStrAsg + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,[ECX-skew].StrRec.length + + MOV EDX,[ESI-skew].StrRec.length + ADD EDX,EDI + CMP ESI,ECX + JE @@appendSelf + + CALL _LStrSetLength + MOV EAX,ESI + MOV ECX,[ESI-skew].StrRec.length + +@@appendStr: + MOV EDX,[EBX] + ADD EDX,EDI + CALL Move + POP EDI + POP ESI + POP EBX + RET + +@@appendSelf: + CALL _LStrSetLength + MOV EAX,[EBX] + MOV ECX,EDI + JMP @@appendStr + +@@exit: +end; + + +procedure _LStrCat3{var dest:AnsiString; source1: AnsiString; source2: AnsiString}; +asm + { ->EAX = Pointer to dest } + { EDX = source1 } + { ECX = source2 } + + TEST EDX,EDX + JE @@assignSource2 + + TEST ECX,ECX + JE _LStrAsg + + CMP EDX,[EAX] + JE @@appendToDest + + CMP ECX,[EAX] + JE @@theHardWay + + PUSH EAX + PUSH ECX + CALL _LStrAsg + + POP EDX + POP EAX + JMP _LStrCat + +@@theHardWay: + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EDX + MOV ESI,ECX + PUSH EAX + + MOV EAX,[EBX-skew].StrRec.length + ADD EAX,[ESI-skew].StrRec.length + CALL _NewAnsiString + + MOV EDI,EAX + MOV EDX,EAX + MOV EAX,EBX + MOV ECX,[EBX-skew].StrRec.length + CALL Move + + MOV EDX,EDI + MOV EAX,ESI + MOV ECX,[ESI-skew].StrRec.length + ADD EDX,[EBX-skew].StrRec.length + CALL Move + + POP EAX + MOV EDX,EDI + TEST EDI,EDI + JE @@skip + DEC [EDI-skew].StrRec.refCnt // EDI = local temp str +@@skip: + CALL _LStrAsg + + POP EDI + POP ESI + POP EBX + + JMP @@exit + +@@assignSource2: + MOV EDX,ECX + JMP _LStrAsg + +@@appendToDest: + MOV EDX,ECX + JMP _LStrCat + +@@exit: +end; + + +procedure _LStrCatN{var dest:AnsiString; argCnt: Integer; ...}; +asm + { ->EAX = Pointer to dest } + { EDX = number of args (>= 3) } + { [ESP+4], [ESP+8], ... crgCnt AnsiString arguments, reverse order } + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EDX + PUSH EAX + MOV EBX,EDX + + XOR EDI,EDI + MOV ECX,[ESP+EDX*4+5*4] // first arg is furthest out + TEST ECX,ECX + JZ @@0 + CMP [EAX],ECX // is dest = first arg? + JNE @@0 + MOV EDI,EAX // EDI nonzero -> potential appendstr case +@@0: + XOR EAX,EAX +@@loop1: + MOV ECX,[ESP+EDX*4+5*4] + TEST ECX,ECX + JE @@1 + ADD EAX,[ECX-skew].StrRec.length + CMP EDI,ECX // is dest an arg besides arg1? + JNE @@1 + XOR EDI,EDI // can't appendstr - dest is multiple args +@@1: + DEC EDX + JNE @@loop1 + +@@append: + TEST EDI,EDI // dest is 1st and only 1st arg? + JZ @@copy + MOV EDX,EAX // length into EDX + MOV EAX,EDI // ptr to str into EAX + MOV ESI,[EDI] + MOV ESI,[ESI-skew].StrRec.Length // save old size before realloc + CALL _LStrSetLength + PUSH EDI // append other strs to dest + ADD ESI,[EDI] // end of old string + DEC EBX + JMP @@loop2 + +@@copy: + CALL _NewAnsiString + PUSH EAX + MOV ESI,EAX + +@@loop2: + MOV EAX,[ESP+EBX*4+6*4] + MOV EDX,ESI + TEST EAX,EAX + JE @@2 + MOV ECX,[EAX-skew].StrRec.length + ADD ESI,ECX + CALL Move +@@2: + DEC EBX + JNE @@loop2 + + POP EDX + POP EAX + TEST EDI,EDI + JNZ @@exit + + TEST EDX,EDX + JE @@skip + DEC [EDX-skew].StrRec.refCnt // EDX = local temp str +@@skip: + CALL _LStrAsg + +@@exit: + POP EDX + POP EDI + POP ESI + POP EBX + POP EAX + LEA ESP,[ESP+EDX*4] + JMP EAX +end; + + +procedure _LStrCmp{left: AnsiString; right: AnsiString}; +asm +{ ->EAX = Pointer to left string } +{ EDX = Pointer to right string } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + CMP EAX,EDX + JE @@exit + + TEST ESI,ESI + JE @@str1null + + TEST EDI,EDI + JE @@str2null + + MOV EAX,[ESI-skew].StrRec.length + MOV EDX,[EDI-skew].StrRec.length + + SUB EAX,EDX { eax = len1 - len2 } + JA @@skip1 + ADD EDX,EAX { edx = len2 + (len1 - len2) = len1 } + +@@skip1: + PUSH EDX + SHR EDX,2 + JE @@cmpRest +@@longLoop: + MOV ECX,[ESI] + MOV EBX,[EDI] + CMP ECX,EBX + JNE @@misMatch + DEC EDX + JE @@cmpRestP4 + MOV ECX,[ESI+4] + MOV EBX,[EDI+4] + CMP ECX,EBX + JNE @@misMatch + ADD ESI,8 + ADD EDI,8 + DEC EDX + JNE @@longLoop + JMP @@cmpRest +@@cmpRestP4: + ADD ESI,4 + ADD EDI,4 +@@cmpRest: + POP EDX + AND EDX,3 + JE @@equal + + MOV ECX,[ESI] + MOV EBX,[EDI] + CMP CL,BL + JNE @@exit + DEC EDX + JE @@equal + CMP CH,BH + JNE @@exit + DEC EDX + JE @@equal + AND EBX,$00FF0000 + AND ECX,$00FF0000 + CMP ECX,EBX + JNE @@exit + +@@equal: + ADD EAX,EAX + JMP @@exit + +@@str1null: + MOV EDX,[EDI-skew].StrRec.length + SUB EAX,EDX + JMP @@exit + +@@str2null: + MOV EAX,[ESI-skew].StrRec.length + SUB EAX,EDX + JMP @@exit + +@@misMatch: + POP EDX + CMP CL,BL + JNE @@exit + CMP CH,BH + JNE @@exit + SHR ECX,16 + SHR EBX,16 + CMP CL,BL + JNE @@exit + CMP CH,BH + +@@exit: + POP EDI + POP ESI + POP EBX + +end; + +function _LStrAddRef(var str): Pointer; +{$IFDEF PUREPASCAL} +var + P: PStrRec; +begin + P := Pointer(Integer(str) - sizeof(StrRec)); + if P <> nil then + if P.refcnt >= 0 then + InterlockedIncrement(P.refcnt); + Result := Pointer(str); +end; +{$ELSE} +asm + { -> EAX str } + TEST EAX,EAX + JE @@exit + MOV EDX,[EAX-skew].StrRec.refCnt + INC EDX + JLE @@exit +{X LOCK} INC [EAX-skew].StrRec.refCnt +@@exit: +end; +{$ENDIF} + +function PICEmptyString: PWideChar; +begin + Result := ''; +end; + +function _LStrToPChar(const s: AnsiString): PChar; +{$IFDEF PUREPASCAL} +const + EmptyString = ''; +begin + if Pointer(s) = nil then + Result := EmptyString + else + Result := Pointer(s); +end; +{$ELSE} +asm + { -> EAX pointer to str } + { <- EAX pointer to PChar } + + TEST EAX,EAX + JE @@handle0 + RET +{$IFDEF PIC} +@@handle0: + JMP PICEmptyString +{$ELSE} +@@zeroByte: + DB 0 +@@handle0: + MOV EAX,offset @@zeroByte +{$ENDIF} +end; +{$ENDIF} + +function InternalUniqueString(var str): Pointer; +asm + { -> EAX pointer to str } + { <- EAX pointer to unique copy } + MOV EDX,[EAX] + TEST EDX,EDX + JE @@exit + MOV ECX,[EDX-skew].StrRec.refCnt + DEC ECX + JE @@exit + + PUSH EBX + MOV EBX,EAX + MOV EAX,[EDX-skew].StrRec.length + CALL _NewAnsiString + MOV EDX,EAX + MOV EAX,[EBX] + MOV [EBX],EDX + PUSH EAX + MOV ECX,[EAX-skew].StrRec.length + CALL Move + POP EAX + MOV ECX,[EAX-skew].StrRec.refCnt + DEC ECX + JL @@skip +{X LOCK} DEC [EAX-skew].StrRec.refCnt + JNZ @@skip + LEA EAX,[EAX-skew].StrRec.refCnt { if refCnt now zero, deallocate} + CALL _FreeMem +@@skip: + MOV EDX,[EBX] + POP EBX +@@exit: + MOV EAX,EDX +end; + + +procedure UniqueString(var str: AnsiString); +asm + JMP InternalUniqueString +end; + +procedure _UniqueStringA(var str: AnsiString); +asm + JMP InternalUniqueString +end; + +procedure UniqueString(var str: WideString); +asm +{$IFDEF LINUX} + JMP InternalUniqueString +{$ENDIF} +{$IFDEF MSWINDOWS} + // nothing to do - Windows WideStrings are always single reference +{$ENDIF} +end; + +procedure _UniqueStringW(var str: WideString); +asm +{$IFDEF LINUX} + JMP InternalUniqueString +{$ENDIF} +{$IFDEF MSWINDOWS} + // nothing to do - Windows WideStrings are always single reference +{$ENDIF} +end; + +procedure _LStrCopy{ const s : AnsiString; index, count : Integer) : AnsiString}; +asm + { ->EAX Source string } + { EDX index } + { ECX count } + { [ESP+4] Pointer to result string } + + PUSH EBX + + TEST EAX,EAX + JE @@srcEmpty + + MOV EBX,[EAX-skew].StrRec.length + TEST EBX,EBX + JE @@srcEmpty + +{ make index 0-based and limit to 0 <= index < Length(src) } + + DEC EDX + JL @@smallInx + CMP EDX,EBX + JGE @@bigInx + +@@cont1: + +{ limit count to satisfy 0 <= count <= Length(src) - index } + + SUB EBX,EDX { calculate Length(src) - index } + TEST ECX,ECX + JL @@smallCount + CMP ECX,EBX + JG @@bigCount + +@@cont2: + + ADD EDX,EAX + MOV EAX,[ESP+4+4] + CALL _LStrFromPCharLen + JMP @@exit + +@@smallInx: + XOR EDX,EDX + JMP @@cont1 +@@bigCount: + MOV ECX,EBX + JMP @@cont2 +@@bigInx: +@@smallCount: +@@srcEmpty: + MOV EAX,[ESP+4+4] + CALL _LStrClr +@@exit: + POP EBX + RET 4 +end; + + +procedure _LStrDelete{ var s : AnsiString; index, count : Integer }; +asm + { ->EAX Pointer to s } + { EDX index } + { ECX count } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + CALL UniqueString + + MOV EDX,[EBX] + TEST EDX,EDX { source already empty: nothing to do } + JE @@exit + + MOV ECX,[EDX-skew].StrRec.length + +{ make index 0-based, if not in [0 .. Length(s)-1] do nothing } + + DEC ESI + JL @@exit + CMP ESI,ECX + JGE @@exit + +{ limit count to [0 .. Length(s) - index] } + + TEST EDI,EDI + JLE @@exit + SUB ECX,ESI { ECX = Length(s) - index } + CMP EDI,ECX + JLE @@1 + MOV EDI,ECX +@@1: + +{ move length - index - count characters from s+index+count to s+index } + + SUB ECX,EDI { ECX = Length(s) - index - count } + ADD EDX,ESI { EDX = s+index } + LEA EAX,[EDX+EDI] { EAX = s+index+count } + CALL Move + +{ set length(s) to length(s) - count } + + MOV EDX,[EBX] + MOV EAX,EBX + MOV EDX,[EDX-skew].StrRec.length + SUB EDX,EDI + CALL _LStrSetLength + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +procedure _LStrInsert{ const source : AnsiString; var s : AnsiString; index : Integer }; +asm + { -> EAX source string } + { EDX pointer to destination string } + { ECX index } + + TEST EAX,EAX + JE @@nothingToDo + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + +{ make index 0-based and limit to 0 <= index <= Length(s) } + + MOV EDX,[EDX] + PUSH EDX + TEST EDX,EDX + JE @@sIsNull + MOV EDX,[EDX-skew].StrRec.length +@@sIsNull: + DEC EDI + JGE @@indexNotLow + XOR EDI,EDI +@@indexNotLow: + CMP EDI,EDX + JLE @@indexNotHigh + MOV EDI,EDX +@@indexNotHigh: + + MOV EBP,[EBX-skew].StrRec.length + +{ set length of result to length(source) + length(s) } + + MOV EAX,ESI + ADD EDX,EBP + CALL _LStrSetLength + POP EAX + + CMP EAX,EBX + JNE @@notInsertSelf + MOV EBX,[ESI] + +@@notInsertSelf: + +{ move length(s) - length(source) - index chars from s+index to s+index+length(source) } + + MOV EAX,[ESI] { EAX = s } + LEA EDX,[EDI+EBP] { EDX = index + length(source) } + MOV ECX,[EAX-skew].StrRec.length + SUB ECX,EDX { ECX = length(s) - length(source) - index } + ADD EDX,EAX { EDX = s + index + length(source) } + ADD EAX,EDI { EAX = s + index } + CALL Move + +{ copy length(source) chars from source to s+index } + + MOV EAX,EBX + MOV EDX,[ESI] + MOV ECX,EBP + ADD EDX,EDI + CALL Move + +@@exit: + POP EBP + POP EDI + POP ESI + POP EBX +@@nothingToDo: +end; + + +procedure _LStrPos{ const substr : AnsiString; const s : AnsiString ) : Integer}; +asm +{ ->EAX Pointer to substr } +{ EDX Pointer to string } +{ <-EAX Position of substr in s or 0 } + + TEST EAX,EAX + JE @@noWork + + TEST EDX,EDX + JE @@stringEmpty + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX { Point ESI to substr } + MOV EDI,EDX { Point EDI to s } + + MOV ECX,[EDI-skew].StrRec.length { ECX = Length(s) } + + PUSH EDI { remember s position to calculate index } + + MOV EDX,[ESI-skew].StrRec.length { EDX = Length(substr) } + + DEC EDX { EDX = Length(substr) - 1 } + JS @@fail { < 0 ? return 0 } + MOV AL,[ESI] { AL = first char of substr } + INC ESI { Point ESI to 2'nd char of substr } + + SUB ECX,EDX { #positions in s to look at } + { = Length(s) - Length(substr) + 1 } + JLE @@fail +@@loop: + REPNE SCASB + JNE @@fail + MOV EBX,ECX { save outer loop counter } + PUSH ESI { save outer loop substr pointer } + PUSH EDI { save outer loop s pointer } + + MOV ECX,EDX + REPE CMPSB + POP EDI { restore outer loop s pointer } + POP ESI { restore outer loop substr pointer } + JE @@found + MOV ECX,EBX { restore outer loop counter } + JMP @@loop + +@@fail: + POP EDX { get rid of saved s pointer } + XOR EAX,EAX + JMP @@exit + +@@stringEmpty: + XOR EAX,EAX + JMP @@noWork + +@@found: + POP EDX { restore pointer to first char of s } + MOV EAX,EDI { EDI points of char after match } + SUB EAX,EDX { the difference is the correct index } +@@exit: + POP EDI + POP ESI + POP EBX +@@noWork: +end; + + +procedure _LStrSetLength{ var str: AnsiString; newLength: Integer}; +asm + { -> EAX Pointer to str } + { EDX new length } + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV ESI,EDX + XOR EDI,EDI + + TEST EDX,EDX + JLE @@setString + + MOV EAX,[EBX] + TEST EAX,EAX + JE @@copyString + + CMP [EAX-skew].StrRec.refCnt,1 + JNE @@copyString + + SUB EAX,rOff + ADD EDX,rOff+1 + PUSH EAX + MOV EAX,ESP + CALL _ReallocMem + POP EAX + ADD EAX,rOff + MOV [EBX],EAX + MOV [EAX-skew].StrRec.length,ESI + MOV BYTE PTR [EAX+ESI],0 + JMP @@exit + +@@copyString: + MOV EAX,EDX + CALL _NewAnsiString + MOV EDI,EAX + + MOV EAX,[EBX] + TEST EAX,EAX + JE @@setString + + MOV EDX,EDI + MOV ECX,[EAX-skew].StrRec.length + CMP ECX,ESI + JL @@moveString + MOV ECX,ESI + +@@moveString: + CALL Move + +@@setString: + MOV EAX,EBX + CALL _LStrClr + MOV [EBX],EDI + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +procedure _LStrOfChar{ c: Char; count: Integer): AnsiString }; +asm + { -> AL c } + { EDX count } + { ECX result } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + MOV EAX,ECX + CALL _LStrClr + + TEST ESI,ESI + JLE @@exit + + MOV EAX,ESI + CALL _NewAnsiString + + MOV [EDI],EAX + + MOV EDX,ESI + MOV CL,BL + + CALL _FillChar + +@@exit: + POP EDI + POP ESI + POP EBX + +end; + + +function _Write0LString(var t: TTextRec; const s: AnsiString): Pointer; +begin + Result := _WriteLString(t, s, 0); +end; + + +function _WriteLString(var t: TTextRec; const s: AnsiString; width: Longint): Pointer; +{$IFDEF PUREPASCAL} +var + i: Integer; +begin + i := Length(s); + _WriteSpaces(t, width - i); + Result := _WriteBytes(t, s[1], i); +end; +{$ELSE} +asm + { -> EAX Pointer to text record } + { EDX Pointer to AnsiString } + { ECX Field width } + + PUSH EBX + + MOV EBX,EDX + + MOV EDX,ECX + XOR ECX,ECX + TEST EBX,EBX + JE @@skip + MOV ECX,[EBX-skew].StrRec.length + SUB EDX,ECX +@@skip: + PUSH ECX + CALL _WriteSpaces + POP ECX + + MOV EDX,EBX + POP EBX + JMP _WriteBytes +end; +{$ENDIF} + + +function _Write0WString(var t: TTextRec; const s: WideString): Pointer; +begin + Result := _WriteWString(t, s, 0); +end; + + +function _WriteWString(var t: TTextRec; const s: WideString; width: Longint): Pointer; +var + i: Integer; +begin + i := Length(s); + _WriteSpaces(t, width - i); + Result := _WriteLString(t, AnsiString(s), 0); +end; + + +function _Write0WCString(var t: TTextRec; s: PWideChar): Pointer; +begin + Result := _WriteWCString(t, s, 0); +end; + + +function _WriteWCString(var t: TTextRec; s: PWideChar; width: Longint): Pointer; +var + i: Integer; +begin + i := 0; + if (s <> nil) then + while s[i] <> #0 do + Inc(i); + + _WriteSpaces(t, width - i); + Result := _WriteLString(t, AnsiString(s), 0); +end; + + +function _Write0WChar(var t: TTextRec; c: WideChar): Pointer; +begin + Result := _WriteWChar(t, c, 0); +end; + + +function _WriteWChar(var t: TTextRec; c: WideChar; width: Integer): Pointer; +begin + _WriteSpaces(t, width - 1); + Result := _WriteLString(t, AnsiString(c), 0); +end; + + +{$IFDEF MSWINDOWS} +procedure WStrError; +asm + MOV AL,reOutOfMemory + JMP Error +end; +{$ENDIF} + +function _NewWideString(CharLength: Longint): Pointer; +{$IFDEF LINUX} +begin + Result := _NewAnsiString(CharLength*2); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + TEST EAX,EAX + JE @@1 + PUSH EAX + PUSH 0 + CALL SysAllocStringLen + TEST EAX,EAX + JE WStrError +@@1: +end; +{$ENDIF} + +procedure WStrSet(var S: WideString; P: PWideChar); +{$IFDEF PUREPASCAL} +var + Temp: Pointer; +begin + Temp := Pointer(InterlockedExchange(Pointer(S), Pointer(P))); + if Temp <> nil then + _WStrClr(Temp); +end; +{$ELSE} +asm +{$IFDEF LINUX} + XCHG [EAX],EDX + TEST EDX,EDX + JZ @@1 + PUSH EDX + MOV EAX, ESP + CALL _WStrClr + POP EAX +{$ENDIF} +{$IFDEF MSWINDOWS} + XCHG [EAX],EDX + TEST EDX,EDX + JZ @@1 + PUSH EDX + CALL SysFreeString +{$ENDIF} +@@1: +end; +{$ENDIF} + + +procedure WStrClr; +asm + JMP _WStrClr +end; + +procedure _WStrClr(var S); +{$IFDEF LINUX} +asm + JMP _LStrClr; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + { -> EAX Pointer to WideString } + + MOV EDX,[EAX] + TEST EDX,EDX + JE @@1 + MOV DWORD PTR [EAX],0 + PUSH EAX + PUSH EDX + CALL SysFreeString + POP EAX +@@1: +end; +{$ENDIF} + + +procedure WStrArrayClr; +asm + JMP _WStrArrayClr; +end; + +procedure _WStrArrayClr(var StrArray; Count: Integer); +{$IFDEF LINUX} +asm + JMP _LStrArrayClr +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + PUSH EBX + PUSH ESI + MOV EBX,EAX + MOV ESI,EDX +@@1: MOV EAX,[EBX] + TEST EAX,EAX + JE @@2 + MOV DWORD PTR [EBX],0 + PUSH EAX + CALL SysFreeString +@@2: ADD EBX,4 + DEC ESI + JNE @@1 + POP ESI + POP EBX +end; +{$ENDIF} + + +procedure _WStrAsg(var Dest: WideString; const Source: WideString); +{$IFDEF LINUX} +asm + JMP _LStrAsg +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + { -> EAX Pointer to WideString } + { EDX Pointer to data } + TEST EDX,EDX + JE _WStrClr + MOV ECX,[EDX-4] + SHR ECX,1 + JE _WStrClr + PUSH ECX + PUSH EDX + PUSH EAX + CALL SysReAllocStringLen + TEST EAX,EAX + JE WStrError +end; +{$ENDIF} + +procedure _WStrLAsg(var Dest: WideString; const Source: WideString); +{$IFDEF LINUX} +asm + JMP _LStrLAsg +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + JMP _WStrAsg +end; +{$ENDIF} + +procedure _WStrFromPCharLen(var Dest: WideString; Source: PAnsiChar; Length: Integer); +var + DestLen: Integer; + Buffer: array[0..2047] of WideChar; +begin + if Length <= 0 then + begin + _WStrClr(Dest); + Exit; + end; + if Length+1 < High(Buffer) then + begin + DestLen := WCharFromChar(Buffer, High(Buffer), Source, Length); + if DestLen > 0 then + begin + _WStrFromPWCharLen(Dest, @Buffer, DestLen); + Exit; + end; + end; + + DestLen := (Length + 1); + _WStrSetLength(Dest, DestLen); // overallocate, trim later + DestLen := WCharFromChar(Pointer(Dest), DestLen, Source, Length); + if DestLen < 0 then DestLen := 0; + _WStrSetLength(Dest, DestLen); +end; + +procedure _WStrFromPWCharLen(var Dest: WideString; Source: PWideChar; CharLength: Integer); +{$IFDEF LINUX} +var + Temp: Pointer; +begin + Temp := Pointer(Dest); + if CharLength > 0 then + begin + Pointer(Dest) := _NewWideString(CharLength); + if Source <> nil then + Move(Source^, Pointer(Dest)^, CharLength * sizeof(WideChar)); + end + else + Pointer(Dest) := nil; + _WStrClr(Temp); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + { -> EAX Pointer to WideString (dest) } + { EDX Pointer to characters (source) } + { ECX number of characters (not bytes) } + TEST ECX,ECX + JE _WStrClr + + PUSH EAX + + PUSH ECX + PUSH EDX + CALL SysAllocStringLen + TEST EAX,EAX + JE WStrError + + POP EDX + PUSH [EDX].PWideChar + MOV [EDX],EAX + + CALL SysFreeString +end; +{$ENDIF} + + +procedure _WStrFromChar(var Dest: WideString; Source: AnsiChar); +asm + PUSH EDX + MOV EDX,ESP + MOV ECX,1 + CALL _WStrFromPCharLen + POP EDX +end; + + +procedure _WStrFromWChar(var Dest: WideString; Source: WideChar); +asm + { -> EAX Pointer to WideString (dest) } + { EDX character (source) } + PUSH EDX + MOV EDX,ESP + MOV ECX,1 + CALL _WStrFromPWCharLen + POP EDX +end; + + +procedure _WStrFromPChar(var Dest: WideString; Source: PAnsiChar); +asm + { -> EAX Pointer to WideString (dest) } + { EDX Pointer to character (source) } + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CL,[EDX+0] + JE @@4 + CMP CL,[EDX+1] + JE @@3 + CMP CL,[EDX+2] + JE @@2 + CMP CL,[EDX+3] + JE @@1 + ADD EDX,4 + JMP @@0 +@@1: INC EDX +@@2: INC EDX +@@3: INC EDX +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX +@@5: JMP _WStrFromPCharLen +end; + + +procedure _WStrFromPWChar(var Dest: WideString; Source: PWideChar); +asm + { -> EAX Pointer to WideString (dest) } + { EDX Pointer to character (source) } + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CX,[EDX+0] + JE @@4 + CMP CX,[EDX+2] + JE @@3 + CMP CX,[EDX+4] + JE @@2 + CMP CX,[EDX+6] + JE @@1 + ADD EDX,8 + JMP @@0 +@@1: ADD EDX,2 +@@2: ADD EDX,2 +@@3: ADD EDX,2 +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX + SHR ECX,1 +@@5: JMP _WStrFromPWCharLen +end; + + +procedure _WStrFromString(var Dest: WideString; const Source: ShortString); +asm + XOR ECX,ECX + MOV CL,[EDX] + INC EDX + JMP _WStrFromPCharLen +end; + + +procedure _WStrFromArray(var Dest: WideString; Source: PAnsiChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASB + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _WStrFromPCharLen +end; + + +procedure _WStrFromWArray(var Dest: WideString; Source: PWideChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASW + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _WStrFromPWCharLen +end; + + +procedure _WStrFromLStr(var Dest: WideString; const Source: AnsiString); +asm + XOR ECX,ECX + TEST EDX,EDX + JE @@1 + MOV ECX,[EDX-4] +@@1: JMP _WStrFromPCharLen +end; + + +procedure _WStrToString(Dest: PShortString; const Source: WideString; MaxLen: Integer); +var + SourceLen, DestLen: Integer; + Buffer: array[0..511] of Char; +begin + if MaxLen > 255 then MaxLen := 255; + SourceLen := Length(Source); + if SourceLen >= MaxLen then SourceLen := MaxLen; + if SourceLen = 0 then + DestLen := 0 + else + begin + DestLen := CharFromWChar(Buffer, High(Buffer), PWideChar(Pointer(Source)), SourceLen); + if DestLen < 0 then + DestLen := 0 + else if DestLen > MaxLen then + DestLen := MaxLen; + end; + Dest^[0] := Chr(DestLen); + if DestLen > 0 then Move(Buffer, Dest^[1], DestLen); +end; + +function _WStrToPWChar(const S: WideString): PWideChar; +{$IFDEF PUREPASCAL} +const + EmptyString = ''; +begin + if Pointer(S) = nil then + Result := EmptyString + else + Result := Pointer(S); +end; +{$ELSE} +asm + TEST EAX,EAX + JE @@1 + RET +{$IFDEF PIC} +@@1: JMP PICEmptyString +{$ELSE} + NOP +@@0: DW 0 +@@1: MOV EAX,OFFSET @@0 +{$ENDIF} +end; +{$ENDIF} + + +function _WStrLen(const S: WideString): Integer; +{$IFDEF PUREPASCAL} +begin + if Pointer(S) = nil then + Result := 0 + else + Result := PInteger(Integer(S) - 4)^ div sizeof(WideChar); +end; +{$ELSE} +asm + { -> EAX Pointer to WideString data } + TEST EAX,EAX + JE @@1 + MOV EAX,[EAX-4] + SHR EAX,1 +@@1: +end; +{$ENDIF} + +procedure _WStrCat(var Dest: WideString; const Source: WideString); +var + DestLen, SourceLen: Integer; + NewStr: PWideChar; +begin + SourceLen := Length(Source); + if SourceLen <> 0 then + begin + DestLen := Length(Dest); + NewStr := _NewWideString(DestLen + SourceLen); + if DestLen > 0 then + Move(Pointer(Dest)^, NewStr^, DestLen * sizeof(WideChar)); + Move(Pointer(Source)^, NewStr[DestLen], SourceLen * sizeof(WideChar)); + WStrSet(Dest, NewStr); + end; +end; + + +procedure _WStrCat3(var Dest: WideString; const Source1, Source2: WideString); +var + Source1Len, Source2Len: Integer; + NewStr: PWideChar; +begin + Source1Len := Length(Source1); + Source2Len := Length(Source2); + if (Source1Len <> 0) or (Source2Len <> 0) then + begin + NewStr := _NewWideString(Source1Len + Source2Len); + Move(Pointer(Source1)^, Pointer(NewStr)^, Source1Len * sizeof(WideChar)); + Move(Pointer(Source2)^, NewStr[Source1Len], Source2Len * sizeof(WideChar)); + WStrSet(Dest, NewStr); + end; +end; + + +procedure _WStrCatN{var Dest: WideString; ArgCnt: Integer; ...}; +asm + { ->EAX = Pointer to dest } + { EDX = number of args (>= 3) } + { [ESP+4], [ESP+8], ... crgCnt WideString arguments } + + PUSH EBX + PUSH ESI + PUSH EDX + PUSH EAX + MOV EBX,EDX + + XOR EAX,EAX +@@loop1: + MOV ECX,[ESP+EDX*4+4*4] + TEST ECX,ECX + JE @@1 + ADD EAX,[ECX-4] +@@1: + DEC EDX + JNE @@loop1 + + SHR EAX,1 + CALL _NewWideString + PUSH EAX + MOV ESI,EAX + +@@loop2: + MOV EAX,[ESP+EBX*4+5*4] + MOV EDX,ESI + TEST EAX,EAX + JE @@2 + MOV ECX,[EAX-4] + ADD ESI,ECX + CALL Move +@@2: + DEC EBX + JNE @@loop2 + + POP EDX + POP EAX + CALL WStrSet + + POP EDX + POP ESI + POP EBX + POP EAX + LEA ESP,[ESP+EDX*4] + JMP EAX +end; + + +procedure _WStrCmp{left: WideString; right: WideString}; +asm +{ ->EAX = Pointer to left string } +{ EDX = Pointer to right string } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + CMP EAX,EDX + JE @@exit + + TEST ESI,ESI + JE @@str1null + + TEST EDI,EDI + JE @@str2null + + MOV EAX,[ESI-4] + MOV EDX,[EDI-4] + + SUB EAX,EDX { eax = len1 - len2 } + JA @@skip1 + ADD EDX,EAX { edx = len2 + (len1 - len2) = len1 } + +@@skip1: + PUSH EDX + SHR EDX,2 + JE @@cmpRest +@@longLoop: + MOV ECX,[ESI] + MOV EBX,[EDI] + CMP ECX,EBX + JNE @@misMatch + DEC EDX + JE @@cmpRestP4 + MOV ECX,[ESI+4] + MOV EBX,[EDI+4] + CMP ECX,EBX + JNE @@misMatch + ADD ESI,8 + ADD EDI,8 + DEC EDX + JNE @@longLoop + JMP @@cmpRest +@@cmpRestP4: + ADD ESI,4 + ADD EDI,4 +@@cmpRest: + POP EDX + AND EDX,2 + JE @@equal + + MOV CX,[ESI] + MOV BX,[EDI] + CMP CX,BX + JNE @@exit + +@@equal: + ADD EAX,EAX + JMP @@exit + +@@str1null: + MOV EDX,[EDI-4] + SUB EAX,EDX + JMP @@exit + +@@str2null: + MOV EAX,[ESI-4] + SUB EAX,EDX + JMP @@exit + +@@misMatch: + POP EDX + CMP CX,BX + JNE @@exit + SHR ECX,16 + SHR EBX,16 + CMP CX,BX + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +function _WStrCopy(const S: WideString; Index, Count: Integer): WideString; +var + L, N: Integer; +begin + L := Length(S); + if Index < 1 then Index := 0 else + begin + Dec(Index); + if Index > L then Index := L; + end; + if Count < 0 then N := 0 else + begin + N := L - Index; + if N > Count then N := Count; + end; + _WStrFromPWCharLen(Result, PWideChar(Pointer(S)) + Index, N); +end; + + +procedure _WStrDelete(var S: WideString; Index, Count: Integer); +var + L, N: Integer; + NewStr: PWideChar; +begin + L := Length(S); + if (L > 0) and (Index >= 1) and (Index <= L) and (Count > 0) then + begin + Dec(Index); + N := L - Index - Count; + if N < 0 then N := 0; + if (Index = 0) and (N = 0) then NewStr := nil else + begin + NewStr := _NewWideString(Index + N); + if Index > 0 then + Move(Pointer(S)^, NewStr^, Index * 2); + if N > 0 then + Move(PWideChar(Pointer(S))[L - N], NewStr[Index], N * 2); + end; + WStrSet(S, NewStr); + end; +end; + + +procedure _WStrInsert(const Source: WideString; var Dest: WideString; Index: Integer); +var + SourceLen, DestLen: Integer; + NewStr: PWideChar; +begin + SourceLen := Length(Source); + if SourceLen > 0 then + begin + DestLen := Length(Dest); + if Index < 1 then Index := 0 else + begin + Dec(Index); + if Index > DestLen then Index := DestLen; + end; + NewStr := _NewWideString(DestLen + SourceLen); + if Index > 0 then + Move(Pointer(Dest)^, NewStr^, Index * 2); + Move(Pointer(Source)^, NewStr[Index], SourceLen * 2); + if Index < DestLen then + Move(PWideChar(Pointer(Dest))[Index], NewStr[Index + SourceLen], + (DestLen - Index) * 2); + WStrSet(Dest, NewStr); + end; +end; + + +procedure _WStrPos{ const substr : WideString; const s : WideString ) : Integer}; +asm +{ ->EAX Pointer to substr } +{ EDX Pointer to string } +{ <-EAX Position of substr in s or 0 } + + TEST EAX,EAX + JE @@noWork + + TEST EDX,EDX + JE @@stringEmpty + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX { Point ESI to substr } + MOV EDI,EDX { Point EDI to s } + + MOV ECX,[EDI-4] { ECX = Length(s) } + SHR ECX,1 + + PUSH EDI { remember s position to calculate index } + + MOV EDX,[ESI-4] { EDX = Length(substr) } + SHR EDX,1 + + DEC EDX { EDX = Length(substr) - 1 } + JS @@fail { < 0 ? return 0 } + MOV AX,[ESI] { AL = first char of substr } + ADD ESI,2 { Point ESI to 2'nd char of substr } + + SUB ECX,EDX { #positions in s to look at } + { = Length(s) - Length(substr) + 1 } + JLE @@fail +@@loop: + REPNE SCASW + JNE @@fail + MOV EBX,ECX { save outer loop counter } + PUSH ESI { save outer loop substr pointer } + PUSH EDI { save outer loop s pointer } + + MOV ECX,EDX + REPE CMPSW + POP EDI { restore outer loop s pointer } + POP ESI { restore outer loop substr pointer } + JE @@found + MOV ECX,EBX { restore outer loop counter } + JMP @@loop + +@@fail: + POP EDX { get rid of saved s pointer } + XOR EAX,EAX + JMP @@exit + +@@stringEmpty: + XOR EAX,EAX + JMP @@noWork + +@@found: + POP EDX { restore pointer to first char of s } + MOV EAX,EDI { EDI points of char after match } + SUB EAX,EDX { the difference is the correct index } + SHR EAX,1 +@@exit: + POP EDI + POP ESI + POP EBX +@@noWork: +end; + + +procedure _WStrSetLength(var S: WideString; NewLength: Integer); +var + NewStr: PWideChar; + Count: Integer; +begin + NewStr := nil; + if NewLength > 0 then + begin + NewStr := _NewWideString(NewLength); + Count := Length(S); + if Count > 0 then + begin + if Count > NewLength then Count := NewLength; + Move(Pointer(S)^, NewStr^, Count * 2); + end; + end; + WStrSet(S, NewStr); +end; + + +function _WStrOfWChar(Ch: WideChar; Count: Integer): WideString; +var + P: PWideChar; +begin + _WStrFromPWCharLen(Result, nil, Count); + P := Pointer(Result); + while Count > 0 do + begin + Dec(Count); + P[Count] := Ch; + end; +end; + +procedure WStrAddRef; +asm + JMP _WStrAddRef +end; + +function _WStrAddRef(var str: WideString): Pointer; +{$IFDEF LINUX} +asm + JMP _LStrAddRef +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + MOV EDX,[EAX] + TEST EDX,EDX + JE @@1 + PUSH EAX + MOV ECX,[EDX-4] + SHR ECX,1 + PUSH ECX + PUSH EDX + CALL SysAllocStringLen + POP EDX + TEST EAX,EAX + JE WStrError + MOV [EDX],EAX +@@1: +end; +{$ENDIF} + +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); +{$IFDEF PUREPASCAL} +var + FT: PFieldTable; + I: Cardinal; +begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + for I := FT.Count-1 downto 0 do + _InitializeArray(Pointer(Cardinal(P) + FT.Fields[I].Offset), FT.Fields[I].TypeInfo^, 1); +end; +{$ELSE} +asm + { -> EAX pointer to record to be initialized } + { EDX pointer to type info } + + XOR ECX,ECX + + PUSH EBX + MOV CL,[EDX+1] { type name length } + + PUSH ESI + PUSH EDI + + MOV EBX,EAX // PIC safe. See comment above + LEA ESI,[EDX+ECX+2+8] { address of destructable fields } + MOV EDI,[EDX+ECX+2+4] { number of destructable fields } + +@@loop: + + MOV EDX,[ESI] + MOV EAX,[ESI+4] + ADD EAX,EBX + MOV EDX,[EDX] + MOV ECX,1 + CALL _InitializeArray + ADD ESI,8 + DEC EDI + JG @@loop + + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + + +const + tkLString = 10; + tkWString = 11; + tkVariant = 12; + tkArray = 13; + tkRecord = 14; + tkInterface = 15; + tkDynArray = 17; + +procedure _InitializeArray(p: Pointer; typeInfo: Pointer; elemCount: Cardinal); +{$IFDEF PUREPASCAL} +var + FT: PFieldTable; +begin + if elemCount = 0 then Exit; + case PTypeInfo(typeInfo).Kind of + tkLString, tkWString, tkInterface, tkDynArray: + while elemCount > 0 do + begin + PInteger(P)^ := 0; + Inc(Integer(P), 4); + Dec(elemCount); + end; + tkVariant: + while elemCount > 0 do + begin + PInteger(P)^ := 0; + PInteger(Integer(P)+4)^ := 0; + PInteger(Integer(P)+8)^ := 0; + PInteger(Integer(P)+12)^ := 0; + Inc(Integer(P), sizeof(Variant)); + Dec(elemCount); + end; + tkArray: + begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + while elemCount > 0 do + begin + _InitializeArray(P, FT.Fields[0].TypeInfo^, FT.Count); + Inc(Integer(P), FT.Size); + Dec(elemCount); + end; + end; + tkRecord: + begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + while elemCount > 0 do + begin + _InitializeRecord(P, typeInfo); + Inc(Integer(P), FT.Size); + Dec(elemCount); + end; + end; + else + Error(reInvalidPtr); + end; +end; +{$ELSE} +asm + { -> EAX pointer to data to be initialized } + { EDX pointer to type info describing data } + { ECX number of elements of that type } + + TEST ECX, ECX + JZ @@zerolength + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX // PIC safe. See comment above + MOV ESI,EDX + MOV EDI,ECX + + XOR EDX,EDX + MOV AL,[ESI] + MOV DL,[ESI+1] + XOR ECX,ECX + + CMP AL,tkLString + JE @@LString + CMP AL,tkWString + JE @@WString + CMP AL,tkVariant + JE @@Variant + CMP AL,tkArray + JE @@Array + CMP AL,tkRecord + JE @@Record + CMP AL,tkInterface + JE @@Interface + CMP AL,tkDynArray + JE @@DynArray + MOV AL,reInvalidPtr + POP EDI + POP ESI + POP EBX + JMP Error + +@@LString: +@@WString: +@@Interface: +@@DynArray: + MOV [EBX],ECX + ADD EBX,4 + DEC EDI + JG @@LString + JMP @@exit + +@@Variant: + MOV [EBX ],ECX + MOV [EBX+ 4],ECX + MOV [EBX+ 8],ECX + MOV [EBX+12],ECX + ADD EBX,16 + DEC EDI + JG @@Variant + JMP @@exit + +@@Array: + PUSH EBP + MOV EBP,EDX +@@ArrayLoop: + MOV EDX,[ESI+EBP+2+8] // address of destructable fields typeinfo + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] // size in bytes of the array data + MOV ECX,[ESI+EBP+2+4] // number of destructable fields + MOV EDX,[EDX] + CALL _InitializeArray + DEC EDI + JG @@ArrayLoop + POP EBP + JMP @@exit + +@@Record: + PUSH EBP + MOV EBP,EDX +@@RecordLoop: + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV EDX,ESI + CALL _InitializeRecord + DEC EDI + JG @@RecordLoop + POP EBP + +@@exit: + + POP EDI + POP ESI + POP EBX +@@zerolength: +end; +{$ENDIF} + +procedure _Initialize(p: Pointer; typeInfo: Pointer); +{$IFDEF PUREPASCAL} +begin + _InitializeArray(p, typeInfo, 1); +end; +{$ELSE} +asm + MOV ECX,1 + JMP _InitializeArray +end; +{$ENDIF} + +procedure _FinalizeRecord(p: Pointer; typeInfo: Pointer); +{$IFDEF PUREPASCAL} +var + FT: PFieldTable; + I: Cardinal; +begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + for I := 0 to FT.Count-1 do + _FinalizeArray(Pointer(Cardinal(P) + FT.Fields[I].Offset), FT.Fields[I].TypeInfo^, 1); +end; +{$ELSE} +asm + { -> EAX pointer to record to be finalized } + { EDX pointer to type info } + + XOR ECX,ECX + + PUSH EBX + MOV CL,[EDX+1] + + PUSH ESI + PUSH EDI + + MOV EBX,EAX + LEA ESI,[EDX+ECX+2+8] + MOV EDI,[EDX+ECX+2+4] + +@@loop: + + MOV EDX,[ESI] + MOV EAX,[ESI+4] + ADD EAX,EBX + MOV EDX,[EDX] + MOV ECX,1 + CALL _FinalizeArray + ADD ESI,8 + DEC EDI + JG @@loop + + MOV EAX,EBX + + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +procedure _FinalizeArray(p: Pointer; typeInfo: Pointer; elemCount: Cardinal); +{$IFDEF PUREPASCAL} +var + FT: PFieldTable; +begin + if elemCount = 0 then Exit; + case PTypeInfo(typeInfo).Kind of + tkLString: _LStrArrayClr(P^, elemCount); + tkWString: {X-_WStrArrayClr X+}WStrArrayClrProc(P^, elemCount); + tkVariant: + while elemCount > 0 do + begin + VarClrProc(P); + Inc(Integer(P), sizeof(Variant)); + Dec(elemCount); + end; + tkArray: + begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + while elemCount > 0 do + begin + _FinalizeArray(P, FT.Fields[0].TypeInfo^, FT.Count); + Inc(Integer(P), FT.Size); + Dec(elemCount); + end; + end; + tkRecord: + begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + while elemCount > 0 do + begin + _FinalizeRecord(P, typeInfo); + Inc(Integer(P), FT.Size); + Dec(elemCount); + end; + end; + tkInterface: + while elemCount > 0 do + begin + _IntfClear(IInterface(P^)); + Inc(Integer(P), 4); + Dec(elemCount); + end; + tkDynArray: + while elemCount > 0 do + begin + _DynArrayClr(P); + Inc(Integer(P), 4); + Dec(elemCount); + end; + else + Error(reInvalidPtr); + end; +end; +{$ELSE} +asm + { -> EAX pointer to data to be finalized } + { EDX pointer to type info describing data } + { ECX number of elements of that type } + + { This code appears to be PIC safe. The functions called from + here either don't make external calls or call Pascal + routines that will fix up EBX in their prolog code + (FreeMem, VarClr, IntfClr). } + + CMP ECX, 0 { no array -> nop } + JE @@zerolength + + PUSH EAX + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + XOR EDX,EDX + MOV AL,[ESI] + MOV DL,[ESI+1] + + CMP AL,tkLString + JE @@LString + + CMP AL,tkWString + JE @@WString + + CMP AL,tkVariant + JE @@Variant + + CMP AL,tkArray + JE @@Array + + CMP AL,tkRecord + JE @@Record + + CMP AL,tkInterface + JE @@Interface + + CMP AL,tkDynArray + JE @@DynArray + + JMP @@error + +@@LString: + CMP ECX,1 + MOV EAX,EBX + JG @@LStringArray + CALL _LStrClr + JMP @@exit +@@LStringArray: + MOV EDX,ECX + CALL _LStrArrayClr + JMP @@exit + +@@WString: + CMP ECX,1 + MOV EAX,EBX + JG @@WStringArray + //CALL _WStrClr {X} + CALL [WStrClrProc] {X} + JMP @@exit +@@WStringArray: + MOV EDX,ECX + //CALL _WStrArrayClr {X} + CALL [WStrArrayClrProc] {X} + JMP @@exit +@@Variant: + MOV EAX,EBX + ADD EBX,16 + CALL _VarClr + DEC EDI + JG @@Variant + JMP @@exit +@@Array: + PUSH EBP + MOV EBP,EDX +@@ArrayLoop: + MOV EDX,[ESI+EBP+2+8] + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV ECX,[ESI+EBP+2+4] + MOV EDX,[EDX] + CALL _FinalizeArray + DEC EDI + JG @@ArrayLoop + POP EBP + JMP @@exit + +@@Record: + PUSH EBP + MOV EBP,EDX +@@RecordLoop: + { inv: EDI = number of array elements to finalize } + + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV EDX,ESI + CALL _FinalizeRecord + DEC EDI + JG @@RecordLoop + POP EBP + JMP @@exit + +@@Interface: + MOV EAX,EBX + ADD EBX,4 + CALL _IntfClear + DEC EDI + JG @@Interface + JMP @@exit + +@@DynArray: + MOV EAX,EBX + MOV EDX,ESI + ADD EBX,4 + CALL _DynArrayClear + DEC EDI + JG @@DynArray + JMP @@exit + +@@error: + POP EDI + POP ESI + POP EBX + POP EAX + MOV AL,reInvalidPtr + JMP Error + +@@exit: + POP EDI + POP ESI + POP EBX + POP EAX +@@zerolength: +end; +{$ENDIF} + +procedure _Finalize(p: Pointer; typeInfo: Pointer); +{$IFDEF PUREPASCAL} +begin + _FinalizeArray(p, typeInfo, 1); +end; +{$ELSE} +asm + MOV ECX,1 + JMP _FinalizeArray +end; +{$ENDIF} + +procedure _AddRefRecord{ p: Pointer; typeInfo: Pointer }; +asm + { -> EAX pointer to record to be referenced } + { EDX pointer to type info } + + XOR ECX,ECX + + PUSH EBX + MOV CL,[EDX+1] + + PUSH ESI + PUSH EDI + + MOV EBX,EAX + LEA ESI,[EDX+ECX+2+8] + MOV EDI,[EDX+ECX+2+4] + +@@loop: + + MOV EDX,[ESI] + MOV EAX,[ESI+4] + ADD EAX,EBX + MOV EDX,[EDX] + MOV ECX, 1 + CALL _AddRefArray + ADD ESI,8 + DEC EDI + JG @@loop + + POP EDI + POP ESI + POP EBX +end; + + +{X}procedure DummyProc; +{X}begin +{X}end; + +procedure _AddRefArray{ p: Pointer; typeInfo: Pointer; elemCount: Longint}; +asm + { -> EAX pointer to data to be referenced } + { EDX pointer to type info describing data } + { ECX number of elements of that type } + + { This code appears to be PIC safe. The functions called from + here either don't make external calls (LStrAddRef, WStrAddRef) or + are Pascal routines that will fix up EBX in their prolog code + (VarAddRef, IntfAddRef). } + + PUSH EBX + PUSH ESI + PUSH EDI + + TEST ECX,ECX + JZ @@exit + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + XOR EDX,EDX + MOV AL,[ESI] + MOV DL,[ESI+1] + + CMP AL,tkLString + JE @@LString + CMP AL,tkWString + JE @@WString + CMP AL,tkVariant + JE @@Variant + CMP AL,tkArray + JE @@Array + CMP AL,tkRecord + JE @@Record + CMP AL,tkInterface + JE @@Interface + CMP AL,tkDynArray + JE @@DynArray + MOV AL,reInvalidPtr + POP EDI + POP ESI + POP EBX + JMP Error + +@@LString: + MOV EAX,[EBX] + ADD EBX,4 + CALL _LStrAddRef + DEC EDI + JG @@LString + JMP @@exit + +@@WString: + MOV EAX,EBX + ADD EBX,4 + //CALL _WStrAddRef + CALL [WStrAddRefProc] + DEC EDI + JG @@WString + JMP @@exit +@@Variant: + MOV EAX,EBX + ADD EBX,16 + CALL _VarAddRef + DEC EDI + JG @@Variant + JMP @@exit + +@@Array: + PUSH EBP + MOV EBP,EDX +@@ArrayLoop: + MOV EDX,[ESI+EBP+2+8] + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV ECX,[ESI+EBP+2+4] + MOV EDX,[EDX] + CALL _AddRefArray + DEC EDI + JG @@ArrayLoop + POP EBP + JMP @@exit + +@@Record: + PUSH EBP + MOV EBP,EDX +@@RecordLoop: + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV EDX,ESI + CALL _AddRefRecord + DEC EDI + JG @@RecordLoop + POP EBP + JMP @@exit + +@@Interface: + MOV EAX,[EBX] + ADD EBX,4 + CALL _IntfAddRef + DEC EDI + JG @@Interface + JMP @@exit + +@@DynArray: + MOV EAX,[EBX] + ADD EBX,4 + CALL _DynArrayAddRef + DEC EDI + JG @@DynArray +@@exit: + + POP EDI + POP ESI + POP EBX +end; + + +procedure _AddRef{ p: Pointer; typeInfo: Pointer}; +asm + MOV ECX,1 + JMP _AddRefArray +end; + + +procedure _CopyRecord{ dest, source, typeInfo: Pointer }; +asm + { -> EAX pointer to dest } + { EDX pointer to source } + { ECX pointer to typeInfo } + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBX,EAX + MOV ESI,EDX + + XOR EAX,EAX + MOV AL,[ECX+1] + + LEA EDI,[ECX+EAX+2+8] + MOV EBP,[EDI-4] + XOR EAX,EAX + MOV ECX,[EDI-8] + PUSH ECX +@@loop: + MOV ECX,[EDI+4] + SUB ECX,EAX + JLE @@nomove1 + MOV EDX,EAX + ADD EAX,ESI + ADD EDX,EBX + CALL Move +@@noMove1: + MOV EAX,[EDI+4] + + MOV EDX,[EDI] + MOV EDX,[EDX] + MOV CL,[EDX] + + CMP CL,tkLString + JE @@LString + CMP CL,tkWString + JE @@WString + CMP CL,tkVariant + JE @@Variant + CMP CL,tkArray + JE @@Array + CMP CL,tkRecord + JE @@Record + CMP CL,tkInterface + JE @@Interface + CMP CL,tkDynArray + JE @@DynArray + MOV AL,reInvalidPtr + POP EBP + POP EDI + POP ESI + POP EBX + JMP Error + +@@LString: + MOV EDX,[ESI+EAX] + ADD EAX,EBX + CALL _LStrAsg + MOV EAX,4 + JMP @@common + +@@WString: + MOV EDX,[ESI+EAX] + ADD EAX,EBX + CALL _WStrAsg + MOV EAX,4 + JMP @@common + +@@Variant: + LEA EDX,[ESI+EAX] + ADD EAX,EBX + CALL _VarCopy + MOV EAX,16 + JMP @@common + +@@Array: + XOR ECX,ECX + MOV CL,[EDX+1] + PUSH dword ptr [EDX+ECX+2] + PUSH dword ptr [EDX+ECX+2+4] + MOV ECX,[EDX+ECX+2+8] + MOV ECX,[ECX] + LEA EDX,[ESI+EAX] + ADD EAX,EBX + CALL _CopyArray + POP EAX + JMP @@common + +@@Record: + XOR ECX,ECX + MOV CL,[EDX+1] + MOV ECX,[EDX+ECX+2] + PUSH ECX + MOV ECX,EDX + LEA EDX,[ESI+EAX] + ADD EAX,EBX + CALL _CopyRecord + POP EAX + JMP @@common + +@@Interface: + MOV EDX,[ESI+EAX] + ADD EAX,EBX + CALL _IntfCopy + MOV EAX,4 + JMP @@common + +@@DynArray: + MOV ECX,EDX + MOV EDX,[ESI+EAX] + ADD EAX,EBX + CALL _DynArrayAsg + MOV EAX,4 + +@@common: + ADD EAX,[EDI+4] + ADD EDI,8 + DEC EBP + JNZ @@loop + + POP ECX + SUB ECX,EAX + JLE @@noMove2 + LEA EDX,[EBX+EAX] + ADD EAX,ESI + CALL Move +@@noMove2: + + POP EBP + POP EDI + POP ESI + POP EBX +end; + + +procedure _CopyObject{ dest, source: Pointer; vmtPtrOffs: Longint; typeInfo: Pointer }; +asm + { -> EAX pointer to dest } + { EDX pointer to source } + { ECX offset of vmt in object } + { [ESP+4] pointer to typeInfo } + + ADD ECX,EAX { pointer to dest vmt } + PUSH dword ptr [ECX] { save dest vmt } + PUSH ECX + MOV ECX,[ESP+4+4+4] + CALL _CopyRecord + POP ECX + POP dword ptr [ECX] { restore dest vmt } + RET 4 + +end; + +procedure _CopyArray{ dest, source, typeInfo: Pointer; cnt: Integer }; +asm + { -> EAX pointer to dest } + { EDX pointer to source } + { ECX pointer to typeInfo } + { [ESP+4] count } + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + MOV EBP,[ESP+4+4*4] + + MOV CL,[EDI] + + CMP CL,tkLString + JE @@LString + CMP CL,tkWString + JE @@WString + CMP CL,tkVariant + JE @@Variant + CMP CL,tkArray + JE @@Array + CMP CL,tkRecord + JE @@Record + CMP CL,tkInterface + JE @@Interface + CMP CL,tkDynArray + JE @@DynArray + MOV AL,reInvalidPtr + POP EBP + POP EDI + POP ESI + POP EBX + JMP Error + +@@LString: + MOV EAX,EBX + MOV EDX,[ESI] + CALL _LStrAsg + ADD EBX,4 + ADD ESI,4 + DEC EBP + JNE @@LString + JMP @@exit + +@@WString: + MOV EAX,EBX + MOV EDX,[ESI] + CALL _WStrAsg + ADD EBX,4 + ADD ESI,4 + DEC EBP + JNE @@WString + JMP @@exit + +@@Variant: + MOV EAX,EBX + MOV EDX,ESI + CALL _VarCopy + ADD EBX,16 + ADD ESI,16 + DEC EBP + JNE @@Variant + JMP @@exit + +@@Array: + XOR ECX,ECX + MOV CL,[EDI+1] + LEA EDI,[EDI+ECX+2] +@@ArrayLoop: + MOV EAX,EBX + MOV EDX,ESI + MOV ECX,[EDI+8] + PUSH dword ptr [EDI+4] + CALL _CopyArray + ADD EBX,[EDI] + ADD ESI,[EDI] + DEC EBP + JNE @@ArrayLoop + JMP @@exit + +@@Record: + MOV EAX,EBX + MOV EDX,ESI + MOV ECX,EDI + CALL _CopyRecord + XOR EAX,EAX + MOV AL,[EDI+1] + ADD EBX,[EDI+EAX+2] + ADD ESI,[EDI+EAX+2] + DEC EBP + JNE @@Record + JMP @@exit + +@@Interface: + MOV EAX,EBX + MOV EDX,[ESI] + CALL _IntfCopy + ADD EBX,4 + ADD ESI,4 + DEC EBP + JNE @@Interface + JMP @@exit + +@@DynArray: + MOV EAX,EBX + MOV EDX,[ESI] + MOV ECX,EDI + CALL _DynArrayAsg + ADD EBX,4 + ADD ESI,4 + DEC EBP + JNE @@DynArray + +@@exit: + POP EBP + POP EDI + POP ESI + POP EBX + RET 4 +end; + + +function _New(size: Longint; typeInfo: Pointer): Pointer; +{$IFDEF PUREPASCAL} +begin + GetMem(Result, size); + if Result <> nil then + _Initialize(Result, typeInfo); +end; +{$ELSE} +asm + { -> EAX size of object to allocate } + { EDX pointer to typeInfo } + + PUSH EDX + CALL _GetMem + POP EDX + TEST EAX,EAX + JE @@exit + PUSH EAX + CALL _Initialize + POP EAX +@@exit: +end; +{$ENDIF} + +procedure _Dispose(p: Pointer; typeInfo: Pointer); +{$IFDEF PUREPASCAL} +begin + _Finalize(p, typeinfo); + FreeMem(p); +end; +{$ELSE} +asm + { -> EAX Pointer to object to be disposed } + { EDX Pointer to type info } + + PUSH EAX + CALL _Finalize + POP EAX + CALL _FreeMem +end; +{$ENDIF} + +{ ----------------------------------------------------- } +{ Wide character support } +{ ----------------------------------------------------- } + +function WideCharToString(Source: PWideChar): string; +begin + WideCharToStrVar(Source, Result); +end; + +function WideCharLenToString(Source: PWideChar; SourceLen: Integer): string; +begin + WideCharLenToStrVar(Source, SourceLen, Result); +end; + +procedure WideCharToStrVar(Source: PWideChar; var Dest: string); +begin + _LStrFromPWChar(Dest, Source); +end; + +procedure WideCharLenToStrVar(Source: PWideChar; SourceLen: Integer; + var Dest: string); +begin + _LStrFromPWCharLen(Dest, Source, SourceLen); +end; + +function StringToWideChar(const Source: string; Dest: PWideChar; + DestSize: Integer): PWideChar; +begin + Dest[WCharFromChar(Dest, DestSize - 1, PChar(Source), Length(Source))] := #0; + Result := Dest; +end; + +{ ----------------------------------------------------- } +{ OLE string support } +{ ----------------------------------------------------- } + +function OleStrToString(Source: PWideChar): string; +begin + OleStrToStrVar(Source, Result); +end; + +procedure OleStrToStrVar(Source: PWideChar; var Dest: string); +begin + WideCharLenToStrVar(Source, Length(WideString(Pointer(Source))), Dest); +end; + +function StringToOleStr(const Source: string): PWideChar; +begin + Result := nil; + _WStrFromPCharLen(WideString(Pointer(Result)), PChar(Pointer(Source)), Length(Source)); +end; + +{ ----------------------------------------------------- } +{ Variant manager support } +{ ----------------------------------------------------- } + +var + VariantManager: TVariantManager; + +procedure VariantSystemUndefinedError; +asm + MOV AL,reVarInvalidOp + JMP Error; +end; + +procedure VariantSystemDefaultVarClear(var V: TVarData); +begin + case V.VType of + varEmpty, varNull, varError:; + else + VariantSystemUndefinedError; + end; +end; + +procedure InitVariantManager; +type + TPtrArray = array [Word] of Pointer; +var + P: ^TPtrArray; + I: Integer; +begin + P := @VariantManager; + for I := 0 to (SizeOf(VariantManager) div SizeOf(Pointer))-1 do + P[I] := @VariantSystemUndefinedError; + VariantManager.VarClear := @VariantSystemDefaultVarClear; +end; + +procedure GetVariantManager(var VarMgr: TVariantManager); +begin + VarMgr := VariantManager; +end; + +procedure SetVariantManager(const VarMgr: TVariantManager); +begin + VariantManager := VarMgr; +end; + +function IsVariantManagerSet: Boolean; +type + TPtrArray = array [Word] of Pointer; +var + P: ^TPtrArray; + I: Integer; +begin + Result := True; + P := @VariantManager; + for I := 0 to (SizeOf(VariantManager) div SizeOf(Pointer))-1 do + if P[I] <> @VariantSystemUndefinedError then + begin + Result := False; + Break; + end; +end; + +{ ----------------------------------------------------- } +{ Variant support } +{ ----------------------------------------------------- } + +procedure _DispInvoke;//(var Dest: Variant; const Source: Variant; + //CallDesc: PCallDesc; Params: Pointer); cdecl; +asm +{$IFDEF PIC} + CALL GetGOT + LEA EAX,[EAX].OFFSET VariantManager + JMP [EAX].TVariantManager.DispInvoke +{$ELSE} + JMP VariantManager.DispInvoke +{$ENDIF} +end; + +procedure _VarClear(var V : Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarClear(V); +{$ELSE} +asm + JMP VariantManager.VarClear +{$IFEND} +end; + +procedure _VarCopy(var Dest: Variant; const Source: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarCopy(Dest, Source); +{$ELSE} +asm + JMP VariantManager.VarCopy +{$IFEND} +end; + +procedure _VarCast(var Dest: Variant; const Source: Variant; VarType: Integer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarCast(Dest, Source, VarType); +{$ELSE} +asm + JMP VariantManager.VarCast +{$IFEND} +end; + +procedure _VarCastOle(var Dest: Variant; const Source: Variant; VarType: Integer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarCastOle(Dest, Source, VarType); +{$ELSE} +asm + JMP VariantManager.VarCastOle +{$IFEND} +end; + +function _VarToInt(const V: Variant): Integer; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.VarToInt(V); +{$ELSE} +asm + JMP VariantManager.VarToInt +{$IFEND} +end; + +function _VarToInt64(const V: Variant): Int64; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.VarToInt64(V); +{$ELSE} +asm + JMP VariantManager.VarToInt64 +{$IFEND} +end; + +function _VarToBool(const V: Variant): Boolean; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.VarToBool(V); +{$ELSE} +asm + JMP VariantManager.VarToBool +{$IFEND} +end; + +function _VarToReal(const V: Variant): Extended; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.VarToReal(V); +{$ELSE} +asm + JMP VariantManager.VarToReal +{$IFEND} +end; + +function _VarToCurr(const V: Variant): Currency; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.VarToCurr(V); +{$ELSE} +asm + JMP VariantManager.VarToCurr +{$IFEND} +end; + +procedure _VarToPStr(var S; const V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarToPStr(S, V); +{$ELSE} +asm + JMP VariantManager.VarToPStr +{$IFEND} +end; + +procedure _VarToLStr(var S: string; const V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarToLStr(S, V); +{$ELSE} +asm + JMP VariantManager.VarToLStr +{$IFEND} +end; + +procedure _VarToWStr(var S: WideString; const V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarToWStr(S, V); +{$ELSE} +asm + JMP VariantManager.VarToWStr +{$IFEND} +end; + +procedure _VarToIntf(var Unknown: IInterface; const V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarToIntf(Unknown, V); +{$ELSE} +asm + JMP VariantManager.VarToIntf +{$IFEND} +end; + +procedure _VarToDisp(var Dispatch: IDispatch; const V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarToDisp(Dispatch, V); +{$ELSE} +asm + JMP VariantManager.VarToDisp +{$IFEND} +end; + +procedure _VarToDynArray(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarToDynArray(DynArray, V, TypeInfo); +{$ELSE} +asm + JMP VariantManager.VarToDynArray +{$IFEND} +end; + +procedure _VarFromInt(var V: Variant; const Value, Range: Integer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromInt(V, Value, Range); +{$ELSE} +asm + JMP VariantManager.VarFromInt +{$IFEND} +end; + +procedure _VarFromInt64(var V: Variant; const Value: Int64); +begin + VariantManager.VarFromInt64(V, Value); +end; + +procedure _VarFromBool(var V: Variant; const Value: Boolean); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromBool(V, Value); +{$ELSE} +asm + JMP VariantManager.VarFromBool +{$IFEND} +end; + +procedure _VarFromReal; // var V: Variant; const Value: Real +asm +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + POP ECX + LEA EAX,[EAX].OFFSET VariantManager + MOV EAX,[EAX].TVariantManager.VarFromReal + XCHG EAX,[ESP] + RET +{$ELSE} + JMP VariantManager.VarFromReal +{$ENDIF} +end; + +procedure _VarFromTDateTime; // var V: Variant; const Value: TDateTime +asm +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + POP ECX + LEA EAX,[EAX].OFFSET VariantManager + MOV EAX,[EAX].TVariantManager.VarFromTDateTime + XCHG EAX,[ESP] + RET +{$ELSE} + JMP VariantManager.VarFromTDateTime +{$ENDIF} +end; + +procedure _VarFromCurr; // var V: Variant; const Value: Currency +asm +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + POP ECX + LEA EAX,[EAX].OFFSET VariantManager + MOV EAX,[EAX].TVariantManager.VarFromCurr + XCHG EAX,[ESP] + RET +{$ELSE} + JMP VariantManager.VarFromCurr +{$ENDIF} +end; + +procedure _VarFromPStr(var V: Variant; const Value: ShortString); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromPStr(V, Value); +{$ELSE} +asm + JMP VariantManager.VarFromPStr +{$IFEND} +end; + +procedure _VarFromLStr(var V: Variant; const Value: string); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromLStr(V, Value); +{$ELSE} +asm + JMP VariantManager.VarFromLStr +{$IFEND} +end; + +procedure _VarFromWStr(var V: Variant; const Value: WideString); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromWStr(V, Value); +{$ELSE} +asm + JMP VariantManager.VarFromWStr +{$IFEND} +end; + +procedure _VarFromIntf(var V: Variant; const Value: IInterface); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromIntf(V, Value); +{$ELSE} +asm + JMP VariantManager.VarFromIntf +{$IFEND} +end; + +procedure _VarFromDisp(var V: Variant; const Value: IDispatch); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromDisp(V, Value); +{$ELSE} +asm + JMP VariantManager.VarFromDisp +{$IFEND} +end; + +procedure _VarFromDynArray(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromDynArray(V, DynArray, TypeInfo); +{$ELSE} +asm + JMP VariantManager.VarFromDynArray +{$IFEND} +end; + +procedure _OleVarFromPStr(var V: OleVariant; const Value: ShortString); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.OleVarFromPStr(V, Value); +{$ELSE} +asm + JMP VariantManager.OleVarFromPStr +{$IFEND} +end; + +procedure _OleVarFromLStr(var V: OleVariant; const Value: string); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.OleVarFromLStr(V, Value); +{$ELSE} +asm + JMP VariantManager.OleVarFromLStr +{$IFEND} +end; + +procedure _OleVarFromVar(var V: OleVariant; const Value: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.OleVarFromVar(V, Value); +{$ELSE} +asm + JMP VariantManager.OleVarFromVar +{$IFEND} +end; + +procedure _OleVarFromInt(var V: OleVariant; const Value, Range: Integer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.OleVarFromInt(V, Value, Range); +{$ELSE} +asm + JMP VariantManager.OleVarFromInt +{$IFEND} +end; + +procedure _VarAdd(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opAdd); +{$ELSE} +asm + MOV ECX,opAdd + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarSub(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opSubtract); +{$ELSE} +asm + MOV ECX,opSubtract + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarMul(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opMultiply); +{$ELSE} +asm + MOV ECX,opMultiply + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarDiv(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opIntDivide); +{$ELSE} +asm + MOV ECX,opIntDivide + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarMod(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opModulus); +{$ELSE} +asm + MOV ECX,opModulus + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarAnd(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opAnd); +{$ELSE} +asm + MOV ECX,opAnd + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarOr(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opOr); +{$ELSE} +asm + MOV ECX,opOr + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarXor(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opXor); +{$ELSE} +asm + MOV ECX,opXor + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarShl(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opShiftLeft); +{$ELSE} +asm + MOV ECX,opShiftLeft + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarShr(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opShiftRight); +{$ELSE} +asm + MOV ECX,opShiftRight + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarRDiv(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opDivide); +{$ELSE} +asm + MOV ECX,opDivide + JMP VariantManager.VarOp +{$IFEND} +end; + +{$IF Defined(PIC) or Defined(PUREPASCAL)} +// result is set in the flags +procedure DoVarCmp(const Left, Right: Variant; OpCode: Integer); +begin + VariantManager.VarCmp(TVarData(Left), TVarData(Right), OpCode); +end; +{$IFEND} + +procedure _VarCmpEQ(const Left, Right: Variant); // result is set in the flags +asm + MOV ECX, opCmpEQ +{$IFDEF PIC} + JMP DoVarCmp +{$ELSE} + JMP VariantManager.VarCmp +{$ENDIF} +end; + +procedure _VarCmpNE(const Left, Right: Variant); // result is set in the flags +asm + MOV ECX, opCmpNE +{$IFDEF PIC} + JMP DoVarCmp +{$ELSE} + JMP VariantManager.VarCmp +{$ENDIF} +end; + +procedure _VarCmpLT(const Left, Right: Variant); // result is set in the flags +asm + MOV ECX, opCmpLT +{$IFDEF PIC} + JMP DoVarCmp +{$ELSE} + JMP VariantManager.VarCmp +{$ENDIF} +end; + +procedure _VarCmpLE(const Left, Right: Variant); // result is set in the flags +asm + MOV ECX, opCmpLE +{$IFDEF PIC} + JMP DoVarCmp +{$ELSE} + JMP VariantManager.VarCmp +{$ENDIF} +end; + +procedure _VarCmpGT(const Left, Right: Variant); // result is set in the flags +asm + MOV ECX, opCmpGT +{$IFDEF PIC} + JMP DoVarCmp +{$ELSE} + JMP VariantManager.VarCmp +{$ENDIF} +end; + +procedure _VarCmpGE(const Left, Right: Variant); // result is set in the flags +asm + MOV ECX, opCmpGE +{$IFDEF PIC} + JMP DoVarCmp +{$ELSE} + JMP VariantManager.VarCmp +{$ENDIF} +end; + + +procedure _VarNeg(var V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarNeg(V); +{$ELSE} +asm + JMP VariantManager.VarNeg +{$IFEND} +end; + +procedure _VarNot(var V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarNot(V); +{$ELSE} +asm + JMP VariantManager.VarNot +{$IFEND} +end; + +procedure _VarCopyNoInd; +asm +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + POP ECX + LEA EAX,[EAX].OFFSET VariantManager + MOV EAX,[EAX].TVariantManager.VarCopyNoInd + XCHG EAX,[ESP] + RET +{$ELSE} + JMP VariantManager.VarCopyNoInd +{$ENDIF} +end; + +procedure _VarClr(var V: Variant); +asm + PUSH EAX + CALL _VarClear + POP EAX +end; + +procedure _VarAddRef(var V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarAddRef(V); +{$ELSE} +asm + JMP VariantManager.VarAddRef +{$IFEND} +end; + +procedure _IntfDispCall; +asm +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + POP ECX + LEA EAX,[EAX].OFFSET DispCallByIDProc + MOV EAX,[EAX] + XCHG EAX,[ESP] + RET +{$ELSE} + JMP DispCallByIDProc +{$ENDIF} +end; + +procedure _DispCallByIDError; +asm + MOV AL,reVarDispatch + JMP Error +end; + +procedure _IntfVarCall; +asm +end; + +function _WriteVariant(var T: Text; const V: Variant; Width: Integer): Pointer; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.WriteVariant(T, V, Width); +{$ELSE} +asm + JMP VariantManager.WriteVariant +{$IFEND} +end; + +function _Write0Variant(var T: Text; const V: Variant): Pointer; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.Write0Variant(T, V); +{$ELSE} +asm + JMP VariantManager.Write0Variant +{$IFEND} +end; + +{ ----------------------------------------------------- } +{ Variant array support } +{ ----------------------------------------------------- } + +procedure _VarArrayRedim(var A : Variant; HighBound: Integer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarArrayRedim(A, HighBound); +{$ELSE} +asm + JMP VariantManager.VarArrayRedim +{$IFEND} +end; + +function _VarArrayGet(var A: Variant; IndexCount: Integer; + Indices: Integer): Variant; cdecl; +asm + POP EBP +{$IFDEF PIC} + CALL GetGOT + LEA EAX,[EAX].OFFSET VariantManager + MOV EAX,[EAX].TVariantManager.VarArrayGet + PUSH EAX + RET +{$ELSE} + JMP VariantManager.VarArrayGet +{$ENDIF} +end; + +procedure _VarArrayPut(var A: Variant; const Value: Variant; + IndexCount: Integer; Indices: Integer); cdecl; +asm + POP EBP +{$IFDEF PIC} + CALL GetGOT + LEA EAX,[EAX].OFFSET VariantManager + MOV EAX,[EAX].TVariantManager.VarArrayPut + PUSH EAX + RET +{$ELSE} + JMP VariantManager.VarArrayPut +{$ENDIF} +end; + +// 64 bit integer helper routines +// +// These functions always return the 64-bit result in EAX:EDX + +// ------------------------------------------------------------------------------ +// 64-bit signed multiply +// ------------------------------------------------------------------------------ +// +// Param 1(EAX:EDX), Param 2([ESP+8]:[ESP+4]) ; before reg pushing +// + +procedure __llmul; +asm + push edx + push eax + + // Param2 : [ESP+16]:[ESP+12] (hi:lo) + // Param1 : [ESP+4]:[ESP] (hi:lo) + + mov eax, [esp+16] + mul dword ptr [esp] + mov ecx, eax + + mov eax, [esp+4] + mul dword ptr [esp+12] + add ecx, eax + + mov eax, [esp] + mul dword ptr [esp+12] + add edx, ecx + + pop ecx + pop ecx + + ret 8 +end; + +// ------------------------------------------------------------------------------ +// 64-bit signed multiply, with overflow check (98.05.15: overflow not supported yet) +// ------------------------------------------------------------------------------ +// +// Param1 ~= U (Uh, Ul) +// Param2 ~= V (Vh, Vl) +// +// Param 1(EAX:EDX), Param 2([ESP+8]:[ESP+4]) ; before reg pushing +// +// compiler-helper function +// O-flag set on exit => result is invalid +// O-flag clear on exit => result is valid + +procedure __llmulo; +asm + push edx + push eax + + // Param2 : [ESP+16]:[ESP+12] (hi:lo) + // Param1 : [ESP+4]:[ESP] (hi:lo) + + mov eax, [esp+16] + mul dword ptr [esp] + mov ecx, eax + + mov eax, [esp+4] + mul dword ptr [esp+12] + add ecx, eax + + mov eax, [esp] + mul dword ptr [esp+12] + add edx, ecx + + pop ecx + pop ecx + + ret 8 +end; + +// ------------------------------------------------------------------------------ +// 64-bit signed division +// ------------------------------------------------------------------------------ + +// +// Dividend = Numerator, Divisor = Denominator +// +// Dividend(EAX:EDX), Divisor([ESP+8]:[ESP+4]) ; before reg pushing +// +// + +procedure __lldiv; +asm + push ebp + push ebx + push esi + push edi + xor edi,edi + + mov ebx,20[esp] // get the divisor low dword + mov ecx,24[esp] // get the divisor high dword + + or ecx,ecx + jnz @__lldiv@slow_ldiv // both high words are zero + + or edx,edx + jz @__lldiv@quick_ldiv + + or ebx,ebx + jz @__lldiv@quick_ldiv // if ecx:ebx == 0 force a zero divide + // we don't expect this to actually + // work + +@__lldiv@slow_ldiv: + +// +// Signed division should be done. Convert negative +// values to positive and do an unsigned division. +// Store the sign value in the next higher bit of +// di (test mask of 4). Thus when we are done, testing +// that bit will determine the sign of the result. +// + or edx,edx // test sign of dividend + jns @__lldiv@onepos + neg edx + neg eax + sbb edx,0 // negate dividend + or edi,1 + +@__lldiv@onepos: + or ecx,ecx // test sign of divisor + jns @__lldiv@positive + neg ecx + neg ebx + sbb ecx,0 // negate divisor + xor edi,1 + +@__lldiv@positive: + mov ebp,ecx + mov ecx,64 // shift counter + push edi // save the flags +// +// Now the stack looks something like this: +// +// 24[esp]: divisor (high dword) +// 20[esp]: divisor (low dword) +// 16[esp]: return EIP +// 12[esp]: previous EBP +// 8[esp]: previous EBX +// 4[esp]: previous ESI +// [esp]: previous EDI +// + xor edi,edi // fake a 64 bit dividend + xor esi,esi + +@__lldiv@xloop: + shl eax,1 // shift dividend left one bit + rcl edx,1 + rcl esi,1 + rcl edi,1 + cmp edi,ebp // dividend larger? + jb @__lldiv@nosub + ja @__lldiv@subtract + cmp esi,ebx // maybe + jb @__lldiv@nosub + +@__lldiv@subtract: + sub esi,ebx + sbb edi,ebp // subtract the divisor + inc eax // build quotient + +@__lldiv@nosub: + loop @__lldiv@xloop +// +// When done with the loop the four registers values' look like: +// +// | edi | esi | edx | eax | +// | remainder | quotient | +// + pop ebx // get control bits + test ebx,1 // needs negative + jz @__lldiv@finish + neg edx + neg eax + sbb edx,0 // negate + +@__lldiv@finish: + pop edi + pop esi + pop ebx + pop ebp + ret 8 + +@__lldiv@quick_ldiv: + div ebx // unsigned divide + xor edx,edx + jmp @__lldiv@finish +end; + +// ------------------------------------------------------------------------------ +// 64-bit signed division with overflow check (98.05.15: not implementated yet) +// ------------------------------------------------------------------------------ + +// +// Dividend = Numerator, Divisor = Denominator +// +// Dividend(EAX:EDX), Divisor([ESP+8]:[ESP+4]) +// Param 1 (EAX:EDX), Param 2([ESP+8]:[ESP+4]) +// +// Param1 ~= U (Uh, Ul) +// Param2 ~= V (Vh, Vl) +// +// compiler-helper function +// O-flag set on exit => result is invalid +// O-flag clear on exit => result is valid +// + +procedure __lldivo; +asm + // check for overflow condition: min(int64) DIV -1 + push esi + mov esi, [esp+12] // Vh + and esi, [esp+8] // Vl + cmp esi, 0ffffffffh // V = -1? + jne @@divok + + mov esi, eax + or esi, edx + cmp esi, 80000000H // U = min(int64)? + jne @@divok + +@@divOvl: + mov eax, esi + pop esi + dec eax // turn on O-flag + ret + +@@divok: + pop esi + push dword ptr [esp+8] // Vh + push dword ptr [esp+8] // Vl (offset is changed from push) + call __lldiv + and eax, eax // turn off O-flag + ret 8 +end; + +// ------------------------------------------------------------------------------ +// 64-bit unsigned division +// ------------------------------------------------------------------------------ + +// Dividend(EAX(hi):EDX(lo)), Divisor([ESP+8](hi):[ESP+4](lo)) // before reg pushing +procedure __lludiv; +asm + push ebp + push ebx + push esi + push edi +// +// Now the stack looks something like this: +// +// 24[esp]: divisor (high dword) +// 20[esp]: divisor (low dword) +// 16[esp]: return EIP +// 12[esp]: previous EBP +// 8[esp]: previous EBX +// 4[esp]: previous ESI +// [esp]: previous EDI +// + +// dividend is pushed last, therefore the first in the args +// divisor next. +// + mov ebx,20[esp] // get the first low word + mov ecx,24[esp] // get the first high word + + or ecx,ecx + jnz @__lludiv@slow_ldiv // both high words are zero + + or edx,edx + jz @__lludiv@quick_ldiv + + or ebx,ebx + jz @__lludiv@quick_ldiv // if ecx:ebx == 0 force a zero divide + // we don't expect this to actually + // work + +@__lludiv@slow_ldiv: + mov ebp,ecx + mov ecx,64 // shift counter + xor edi,edi // fake a 64 bit dividend + xor esi,esi + +@__lludiv@xloop: + shl eax,1 // shift dividend left one bit + rcl edx,1 + rcl esi,1 + rcl edi,1 + cmp edi,ebp // dividend larger? + jb @__lludiv@nosub + ja @__lludiv@subtract + cmp esi,ebx // maybe + jb @__lludiv@nosub + +@__lludiv@subtract: + sub esi,ebx + sbb edi,ebp // subtract the divisor + inc eax // build quotient + +@__lludiv@nosub: + loop @__lludiv@xloop +// +// When done with the loop the four registers values' look like: +// +// | edi | esi | edx | eax | +// | remainder | quotient | +// + +@__lludiv@finish: + pop edi + pop esi + pop ebx + pop ebp + ret 8 + +@__lludiv@quick_ldiv: + div ebx // unsigned divide + xor edx,edx + jmp @__lludiv@finish +end; + +// ------------------------------------------------------------------------------ +// 64-bit modulo +// ------------------------------------------------------------------------------ + +// Dividend(EAX:EDX), Divisor([ESP+8]:[ESP+4]) // before reg pushing +procedure __llmod; +asm + push ebp + push ebx + push esi + push edi + xor edi,edi +// +// dividend is pushed last, therefore the first in the args +// divisor next. +// + mov ebx,20[esp] // get the first low word + mov ecx,24[esp] // get the first high word + or ecx,ecx + jnz @__llmod@slow_ldiv // both high words are zero + + or edx,edx + jz @__llmod@quick_ldiv + + or ebx,ebx + jz @__llmod@quick_ldiv // if ecx:ebx == 0 force a zero divide + // we don't expect this to actually + // work +@__llmod@slow_ldiv: +// +// Signed division should be done. Convert negative +// values to positive and do an unsigned division. +// Store the sign value in the next higher bit of +// di (test mask of 4). Thus when we are done, testing +// that bit will determine the sign of the result. +// + or edx,edx // test sign of dividend + jns @__llmod@onepos + neg edx + neg eax + sbb edx,0 // negate dividend + or edi,1 + +@__llmod@onepos: + or ecx,ecx // test sign of divisor + jns @__llmod@positive + neg ecx + neg ebx + sbb ecx,0 // negate divisor + +@__llmod@positive: + mov ebp,ecx + mov ecx,64 // shift counter + push edi // save the flags +// +// Now the stack looks something like this: +// +// 24[esp]: divisor (high dword) +// 20[esp]: divisor (low dword) +// 16[esp]: return EIP +// 12[esp]: previous EBP +// 8[esp]: previous EBX +// 4[esp]: previous ESI +// [esp]: previous EDI +// + xor edi,edi // fake a 64 bit dividend + xor esi,esi + +@__llmod@xloop: + shl eax,1 // shift dividend left one bit + rcl edx,1 + rcl esi,1 + rcl edi,1 + cmp edi,ebp // dividend larger? + jb @__llmod@nosub + ja @__llmod@subtract + cmp esi,ebx // maybe + jb @__llmod@nosub + +@__llmod@subtract: + sub esi,ebx + sbb edi,ebp // subtract the divisor + inc eax // build quotient + +@__llmod@nosub: + loop @__llmod@xloop +// +// When done with the loop the four registers values' look like: +// +// | edi | esi | edx | eax | +// | remainder | quotient | +// + mov eax,esi + mov edx,edi // use remainder + + pop ebx // get control bits + test ebx,1 // needs negative + jz @__llmod@finish + neg edx + neg eax + sbb edx,0 // negate + +@__llmod@finish: + pop edi + pop esi + pop ebx + pop ebp + ret 8 + +@__llmod@quick_ldiv: + div ebx // unsigned divide + xchg eax,edx + xor edx,edx + jmp @__llmod@finish +end; + +// ------------------------------------------------------------------------------ +// 64-bit signed modulo with overflow (98.05.15: overflow not yet supported) +// ------------------------------------------------------------------------------ + +// Dividend(EAX:EDX), Divisor([ESP+8]:[ESP+4]) +// Param 1 (EAX:EDX), Param 2([ESP+8]:[ESP+4]) +// +// Param1 ~= U (Uh, Ul) +// Param2 ~= V (Vh, Vl) +// +// compiler-helper function +// O-flag set on exit => result is invalid +// O-flag clear on exit => result is valid +// + +procedure __llmodo; +asm + // check for overflow condition: min(int64) MOD -1 + push esi + mov esi, [esp+12] // Vh + and esi, [esp+8] // Vl + cmp esi, 0ffffffffh // V = -1? + jne @@modok + + mov esi, eax + or esi, edx + cmp esi, 80000000H // U = min(int64)? + jne @@modok + +@@modOvl: + mov eax, esi + pop esi + dec eax // turn on O-flag + ret + +@@modok: + pop esi + push dword ptr [esp+8] // Vh + push dword ptr [esp+8] // Vl (offset is changed from push) + call __llmod + and eax, eax // turn off O-flag + ret 8 +end; + +// ------------------------------------------------------------------------------ +// 64-bit unsigned modulo +// ------------------------------------------------------------------------------ +// Dividend(EAX(hi):EDX(lo)), Divisor([ESP+8](hi):[ESP+4](lo)) // before reg pushing + +procedure __llumod; +asm + push ebp + push ebx + push esi + push edi +// +// Now the stack looks something like this: +// +// 24[esp]: divisor (high dword) +// 20[esp]: divisor (low dword) +// 16[esp]: return EIP +// 12[esp]: previous EBP +// 8[esp]: previous EBX +// 4[esp]: previous ESI +// [esp]: previous EDI +// + +// dividend is pushed last, therefore the first in the args +// divisor next. +// + mov ebx,20[esp] // get the first low word + mov ecx,24[esp] // get the first high word + or ecx,ecx + jnz @__llumod@slow_ldiv // both high words are zero + + or edx,edx + jz @__llumod@quick_ldiv + + or ebx,ebx + jz @__llumod@quick_ldiv // if ecx:ebx == 0 force a zero divide + // we don't expect this to actually + // work +@__llumod@slow_ldiv: + mov ebp,ecx + mov ecx,64 // shift counter + xor edi,edi // fake a 64 bit dividend + xor esi,esi // + +@__llumod@xloop: + shl eax,1 // shift dividend left one bit + rcl edx,1 + rcl esi,1 + rcl edi,1 + cmp edi,ebp // dividend larger? + jb @__llumod@nosub + ja @__llumod@subtract + cmp esi,ebx // maybe + jb @__llumod@nosub + +@__llumod@subtract: + sub esi,ebx + sbb edi,ebp // subtract the divisor + inc eax // build quotient + +@__llumod@nosub: + loop @__llumod@xloop +// +// When done with the loop the four registers values' look like: +// +// | edi | esi | edx | eax | +// | remainder | quotient | +// + mov eax,esi + mov edx,edi // use remainder + +@__llumod@finish: + pop edi + pop esi + pop ebx + pop ebp + ret 8 + +@__llumod@quick_ldiv: + div ebx // unsigned divide + xchg eax,edx + xor edx,edx + jmp @__llumod@finish +end; + +// ------------------------------------------------------------------------------ +// 64-bit shift left +// ------------------------------------------------------------------------------ + +// +// target (EAX:EDX) count (ECX) +// +procedure __llshl; +asm + cmp cl, 32 + jl @__llshl@below32 + cmp cl, 64 + jl @__llshl@below64 + xor edx, edx + xor eax, eax + ret + +@__llshl@below64: + mov edx, eax + shl edx, cl + xor eax, eax + ret + +@__llshl@below32: + shld edx, eax, cl + shl eax, cl + ret +end; + +// ------------------------------------------------------------------------------ +// 64-bit signed shift right +// ------------------------------------------------------------------------------ +// target (EAX:EDX) count (ECX) + +procedure __llshr; +asm + cmp cl, 32 + jl @__llshr@below32 + cmp cl, 64 + jl @__llshr@below64 + sar edx, 1fh + mov eax,edx + ret + +@__llshr@below64: + mov eax, edx + cdq + sar eax,cl + ret + +@__llshr@below32: + shrd eax, edx, cl + sar edx, cl + ret +end; + +// ------------------------------------------------------------------------------ +// 64-bit unsigned shift right +// ------------------------------------------------------------------------------ + +// target (EAX:EDX) count (ECX) +procedure __llushr; +asm + cmp cl, 32 + jl @__llushr@below32 + cmp cl, 64 + jl @__llushr@below64 + xor edx, edx + xor eax, eax + ret + +@__llushr@below64: + mov eax, edx + xor edx, edx + shr eax, cl + ret + +@__llushr@below32: + shrd eax, edx, cl + shr edx, cl + ret +end; + +function _StrInt64(val: Int64; width: Integer): ShortString; +var + d: array[0..31] of Char; { need 19 digits and a sign } + i, k: Integer; + sign: Boolean; + spaces: Integer; +begin + { Produce an ASCII representation of the number in reverse order } + i := 0; + sign := val < 0; + repeat + d[i] := Chr( Abs(val mod 10) + Ord('0') ); + Inc(i); + val := val div 10; + until val = 0; + if sign then + begin + d[i] := '-'; + Inc(i); + end; + + { Fill the Result with the appropriate number of blanks } + if width > 255 then + width := 255; + k := 1; + spaces := width - i; + while k <= spaces do + begin + Result[k] := ' '; + Inc(k); + end; + + { Fill the Result with the number } + while i > 0 do + begin + Dec(i); + Result[k] := d[i]; + Inc(k); + end; + + { Result is k-1 characters long } + SetLength(Result, k-1); + +end; + +function _Str0Int64(val: Int64): ShortString; +begin + Result := _StrInt64(val, 0); +end; + +procedure _WriteInt64; +asm +{ PROCEDURE _WriteInt64( VAR t: Text; val: Int64; with: Longint); } +{ ->EAX Pointer to file record } +{ [ESP+4] Value } +{ EDX Field width } + + SUB ESP,32 { VAR s: String[31]; } + + PUSH EAX + PUSH EDX + + PUSH dword ptr [ESP+8+32+8] { Str( val : 0, s ); } + PUSH dword ptr [ESP+8+32+8] + XOR EAX,EAX + LEA EDX,[ESP+8+8] + CALL _StrInt64 + + POP ECX + POP EAX + + MOV EDX,ESP { Write( t, s : width );} + CALL _WriteString + + ADD ESP,32 + RET 8 +end; + +procedure _Write0Int64; +asm +{ PROCEDURE _Write0Long( VAR t: Text; val: Longint); } +{ ->EAX Pointer to file record } +{ EDX Value } + XOR EDX,EDX + JMP _WriteInt64 +end; + +procedure _ReadInt64; +asm + // -> EAX Pointer to text record + // <- EAX:EDX Result + + PUSH EBX + PUSH ESI + PUSH EDI + SUB ESP,36 // var numbuf: String[32]; + + MOV ESI,EAX + CALL _SeekEof + DEC AL + JZ @@eof + + MOV EDI,ESP // EDI -> numBuf[0] + MOV BL,32 +@@loop: + MOV EAX,ESI + CALL _ReadChar + CMP AL,' ' + JBE @@endNum + STOSB + DEC BL + JNZ @@loop +@@convert: + MOV byte ptr [EDI],0 + MOV EAX,ESP // EAX -> numBuf + PUSH EDX // allocate code result + MOV EDX,ESP // pass pointer to code + CALL _ValInt64 // convert + POP ECX // pop code result into EDX + TEST ECX,ECX + JZ @@exit + MOV EAX,106 + CALL SetInOutRes + +@@exit: + ADD ESP,36 + POP EDI + POP ESI + POP EBX + RET + +@@endNum: + CMP AH,cEof + JE @@convert + DEC [ESI].TTextRec.BufPos + JMP @@convert + +@@eof: + XOR EAX,EAX + JMP @@exit +end; + +function _ValInt64(const s: AnsiString; var code: Integer): Int64; +var + i: Integer; + dig: Integer; + sign: Boolean; + empty: Boolean; +begin + i := 1; + dig := 0; + Result := 0; + if s = '' then + begin + code := i; + exit; + end; + while s[i] = ' ' do + Inc(i); + sign := False; + if s[i] = '-' then + begin + sign := True; + Inc(i); + end + else if s[i] = '+' then + Inc(i); + empty := True; + if (s[i] = '$') or (s[i] = '0') and (Upcase(s[i+1]) = 'X') then + begin + if s[i] = '0' then + Inc(i); + Inc(i); + while True do + begin + case s[i] of + '0'..'9': dig := Ord(s[i]) - Ord('0'); + 'A'..'F': dig := Ord(s[i]) - (Ord('A') - 10); + 'a'..'f': dig := Ord(s[i]) - (Ord('a') - 10); + else + break; + end; + if (Result < 0) or (Result > (High(Int64) div 16)) then + break; + Result := Result shl 4 + dig; + Inc(i); + empty := False; + end; + if sign then + Result := - Result; + end + else + begin + while True do + begin + case s[i] of + '0'..'9': dig := Ord(s[i]) - Ord('0'); + else + break; + end; + if (Result < 0) or (Result > (High(Int64) div 10)) then + break; + Result := Result*10 + dig; + Inc(i); + empty := False; + end; + if sign then + Result := - Result; + if (Result <> 0) and (sign <> (Result < 0)) then + Dec(i); + end; + if (s[i] <> #0) or empty then + code := i + else + code := 0; +end; + +procedure _DynArrayLength; +asm +{ FUNCTION _DynArrayLength(const a: array of ...): Longint; } +{ ->EAX Pointer to array or nil } +{ <-EAX High bound of array + 1 or 0 } + TEST EAX,EAX + JZ @@skip + MOV EAX,[EAX-4] +@@skip: +end; + +procedure _DynArrayHigh; +asm +{ FUNCTION _DynArrayHigh(const a: array of ...): Longint; } +{ ->EAX Pointer to array or nil } +{ <-EAX High bound of array or -1 } + CALL _DynArrayLength + DEC EAX +end; + +procedure CopyArray(dest, source, typeInfo: Pointer; cnt: Integer); +asm + PUSH dword ptr [EBP+8] + CALL _CopyArray +end; + +procedure FinalizeArray(p, typeInfo: Pointer; cnt: Integer); +asm + JMP _FinalizeArray +end; + +procedure DynArrayClear(var a: Pointer; typeInfo: Pointer); +asm + CALL _DynArrayClear +end; + +procedure DynArraySetLength(var a: Pointer; typeInfo: Pointer; dimCnt: Longint; lengthVec: PLongint); +var + i: Integer; + newLength, oldLength, minLength: Longint; + elSize: Longint; + neededSize: Longint; + p, pp: Pointer; +begin + p := a; + + // Fetch the new length of the array in this dimension, and the old length + newLength := PLongint(lengthVec)^; + if newLength <= 0 then + begin + if newLength < 0 then + Error(reRangeError); + DynArrayClear(a, typeInfo); + exit; + end; + + oldLength := 0; + if p <> nil then + begin + Dec(PLongint(p)); + oldLength := PLongint(p)^; + Dec(PLongint(p)); + end; + + // Calculate the needed size of the heap object + Inc(PChar(typeInfo), Length(PDynArrayTypeInfo(typeInfo).name)); + elSize := PDynArrayTypeInfo(typeInfo).elSize; + if PDynArrayTypeInfo(typeInfo).elType <> nil then + typeInfo := PDynArrayTypeInfo(typeInfo).elType^ + else + typeInfo := nil; + neededSize := newLength*elSize; + if neededSize div newLength <> elSize then + Error(reRangeError); + Inc(neededSize, Sizeof(Longint)*2); + + // If the heap object isn't shared (ref count = 1), just resize it. Otherwise, we make a copy + if (p = nil) or (PLongint(p)^ = 1) then + begin + pp := p; + if (newLength < oldLength) and (typeInfo <> nil) then + FinalizeArray(PChar(p) + Sizeof(Longint)*2 + newLength*elSize, typeInfo, oldLength - newLength); + ReallocMem(pp, neededSize); + p := pp; + end + else + begin + Dec(PLongint(p)^); + GetMem(p, neededSize); + minLength := oldLength; + if minLength > newLength then + minLength := newLength; + if typeInfo <> nil then + begin + FillChar((PChar(p) + Sizeof(Longint)*2)^, minLength*elSize, 0); + CopyArray(PChar(p) + Sizeof(Longint)*2, a, typeInfo, minLength) + end + else + Move(PChar(a)^, (PChar(p) + Sizeof(Longint)*2)^, minLength*elSize); + end; + + // The heap object will now have a ref count of 1 and the new length + PLongint(p)^ := 1; + Inc(PLongint(p)); + PLongint(p)^ := newLength; + Inc(PLongint(p)); + + // Set the new memory to all zero bits + FillChar((PChar(p) + elSize * oldLength)^, elSize * (newLength - oldLength), 0); + + // Take care of the inner dimensions, if any + if dimCnt > 1 then + begin + Inc(lengthVec); + Dec(dimCnt); + for i := 0 to newLength-1 do + DynArraySetLength(PPointerArray(p)[i], typeInfo, dimCnt, lengthVec); + end; + a := p; +end; + +procedure _DynArraySetLength; +asm +{ PROCEDURE _DynArraySetLength(var a: dynarray; typeInfo: PDynArrayTypeInfo; dimCnt: Longint; lengthVec: ^Longint) } +{ ->EAX Pointer to dynamic array (= pointer to pointer to heap object) } +{ EDX Pointer to type info for the dynamic array } +{ ECX number of dimensions } +{ [ESP+4] dimensions } + PUSH ESP + ADD dword ptr [ESP],4 + CALL DynArraySetLength +end; + +procedure _DynArrayCopy(a: Pointer; typeInfo: Pointer; var Result: Pointer); +begin + if a <> nil then + _DynArrayCopyRange(a, typeInfo, 0, PLongint(PChar(a)-4)^, Result) + else + _DynArrayClear(Result, typeInfo); +end; + +procedure _DynArrayCopyRange(a: Pointer; typeInfo: Pointer; index, count : Integer; var Result: Pointer); +var + arrayLength: Integer; + elSize: Integer; + typeInf: PDynArrayTypeInfo; + p: Pointer; +begin + p := nil; + if a <> nil then + begin + typeInf := typeInfo; + + // Limit index and count to values within the array + if index < 0 then + begin + Inc(count, index); + index := 0; + end; + arrayLength := PLongint(PChar(a)-4)^; + if index > arrayLength then + index := arrayLength; + if count > arrayLength - index then + count := arrayLength - index; + if count < 0 then + count := 0; + + if count > 0 then + begin + // Figure out the size and type descriptor of the element type + Inc(PChar(typeInf), Length(typeInf.name)); + elSize := typeInf.elSize; + if typeInf.elType <> nil then + typeInf := typeInf.elType^ + else + typeInf := nil; + + // Allocate the amount of memory needed + GetMem(p, count*elSize + Sizeof(Longint)*2); + + // The reference count of the new array is 1, the length is count + PLongint(p)^ := 1; + Inc(PLongint(p)); + PLongint(p)^ := count; + Inc(PLongint(p)); + Inc(PChar(a), index*elSize); + + // If the element type needs destruction, we must copy each element, + // otherwise we can just copy the bits + if count > 0 then + begin + if typeInf <> nil then + begin + FillChar(p^, count*elSize, 0); + CopyArray(p, a, typeInf, count) + end + else + Move(a^, p^, count*elSize); + end; + end; + end; + DynArrayClear(Result, typeInfo); + Result := p; +end; + +procedure _DynArrayClear; +asm +{ ->EAX Pointer to dynamic array (Pointer to pointer to heap object } +{ EDX Pointer to type info } + + { Nothing to do if Pointer to heap object is nil } + MOV ECX,[EAX] + TEST ECX,ECX + JE @@exit + + { Set the variable to be finalized to nil } + MOV dword ptr [EAX],0 + + { Decrement ref count. Nothing to do if not zero now. } +{X LOCK} DEC dword ptr [ECX-8] + JNE @@exit + + { Save the source - we're supposed to return it } + PUSH EAX + MOV EAX,ECX + + { Fetch the type descriptor of the elements } + XOR ECX,ECX + MOV CL,[EDX].TDynArrayTypeInfo.name; + MOV EDX,[EDX+ECX].TDynArrayTypeInfo.elType; + + { If it's non-nil, finalize the elements } + TEST EDX,EDX + JE @@noFinalize + MOV ECX,[EAX-4] + TEST ECX,ECX + JE @@noFinalize + MOV EDX,[EDX] + CALL _FinalizeArray +@@noFinalize: + { Now deallocate the array } + SUB EAX,8 + CALL _FreeMem + POP EAX +@@exit: +end; + + +procedure _DynArrayAsg; +asm +{ ->EAX Pointer to destination (pointer to pointer to heap object } +{ EDX source (pointer to heap object } +{ ECX Pointer to rtti describing dynamic array } + + PUSH EBX + MOV EBX,[EAX] + + { Increment ref count of source if non-nil } + + TEST EDX,EDX + JE @@skipInc +{X LOCK} INC dword ptr [EDX-8] +@@skipInc: + { Dec ref count of destination - if it becomes 0, clear dest } + TEST EBX,EBX + JE @@skipClear +{X LOCK} DEC dword ptr[EBX-8] + JNZ @@skipClear + PUSH EAX + PUSH EDX + MOV EDX,ECX + INC dword ptr[EBX-8] + CALL _DynArrayClear + POP EDX + POP EAX +@@skipClear: + { Finally store source into destination } + MOV [EAX],EDX + + POP EBX +end; + +procedure _DynArrayAddRef; +asm +{ ->EAX Pointer to heap object } + TEST EAX,EAX + JE @@exit +{X LOCK} INC dword ptr [EAX-8] +@@exit: +end; + + +function DynArrayIndex(const P: Pointer; const Indices: array of Integer; const TypInfo: Pointer): Pointer; +asm + { ->EAX P } + { EDX Pointer to Indices } + { ECX High bound of Indices } + { [EBP+8] TypInfo } + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV ESI,EDX + MOV EDI,[EBP+8] + MOV EBP,EAX + + XOR EBX,EBX { for i := 0 to High(Indices) do } + TEST ECX,ECX + JGE @@start +@@loop: + MOV EBP,[EBP] +@@start: + XOR EAX,EAX + MOV AL,[EDI].TDynArrayTypeInfo.name + ADD EDI,EAX + MOV EAX,[ESI+EBX*4] { P := P + Indices[i]*TypInfo.elSize } + MUL [EDI].TDynArrayTypeInfo.elSize + MOV EDI,[EDI].TDynArrayTypeInfo.elType + TEST EDI,EDI + JE @@skip + MOV EDI,[EDI] +@@skip: + ADD EBP,EAX + INC EBX + CMP EBX,ECX + JLE @@loop + +@@loopEnd: + + MOV EAX,EBP + + POP EBP + POP EDI + POP ESI + POP EBX +end; + + +{ Returns the DynArrayTypeInfo of the Element Type of the specified DynArrayTypeInfo } +function DynArrayElTypeInfo(typeInfo: PDynArrayTypeInfo): PDynArrayTypeInfo; +begin + Result := nil; + if typeInfo <> nil then + begin + Inc(PChar(typeInfo), Length(typeInfo.name)); + if typeInfo.elType <> nil then + Result := typeInfo.elType^; + end; +end; + +{ Returns # of dimemsions of the DynArray described by the specified DynArrayTypeInfo} +function DynArrayDim(typeInfo: PDynArrayTypeInfo): Integer; +begin + Result := 0; + while (typeInfo <> nil) and (typeInfo.kind = tkDynArray) do + begin + Inc(Result); + typeInfo := DynArrayElTypeInfo(typeInfo); + end; +end; + +{ Returns size of the Dynamic Array} +function DynArraySize(a: Pointer): Integer; +asm + TEST EAX, EAX + JZ @@exit + MOV EAX, [EAX-4] +@@exit: +end; + +// Returns whether array is rectangular +function IsDynArrayRectangular(const DynArray: Pointer; typeInfo: PDynArrayTypeInfo): Boolean; +var + Dim, I, J, Size, SubSize: Integer; + P: Pointer; +begin + // Assume we have a rectangular array + Result := True; + + P := DynArray; + Dim := DynArrayDim(typeInfo); + + {NOTE: Start at 1. Don't need to test the first dimension - it's rectangular by definition} + for I := 1 to dim-1 do + begin + if P <> nil then + begin + { Get size of this dimension } + Size := DynArraySize(P); + + { Get Size of first sub. dimension } + SubSize := DynArraySize(PPointerArray(P)[0]); + + { Walk through every dimension making sure they all have the same size} + for J := 1 to Size-1 do + if DynArraySize(PPointerArray(P)[J]) <> SubSize then + begin + Result := False; + Exit; + end; + + { Point to next dimension} + P := PPointerArray(P)[0]; + end; + end; +end; + +// Returns Bounds of Dynamic array as an array of integer containing the 'high' of each dimension +function DynArrayBounds(const DynArray: Pointer; typeInfo: PDynArrayTypeInfo): TBoundArray; +var + Dim, I: Integer; + P: Pointer; +begin + P := DynArray; + + Dim := DynArrayDim(typeInfo); + SetLength(Result, Dim); + + for I := 0 to dim-1 do + if P <> nil then + begin + Result[I] := DynArraySize(P)-1; + P := PPointerArray(P)[0]; // Assume rectangular arrays + end; +end; + +{ Decrements to next lower index - Returns True if successful } +{ Indices: Indices to be decremented } +{ Bounds : High bounds of each dimension } +function DecIndices(var Indices: TBoundArray; const Bounds: TBoundArray): Boolean; +var + I, J: Integer; +begin + { Find out if we're done: all at zeroes } + Result := False; + for I := Low(Indices) to High(Indices) do + if Indices[I] <> 0 then + begin + Result := True; + break; + end; + if not Result then + Exit; + + { Two arrays must be of same length } + Assert(Length(Indices) = Length(Bounds)); + + { Find index of item to tweak } + for I := High(Indices) downto Low(Bounds) do + begin + // If not reach zero, dec and bail out + if Indices[I] <> 0 then + begin + Dec(Indices[I]); + Exit; + end + else + begin + J := I; + while Indices[J] = 0 do + begin + // Restore high bound when we've reached zero on a particular dimension + Indices[J] := Bounds[J]; + // Move to higher dimension + Dec(J); + Assert(J >= 0); + end; + Dec(Indices[J]); + Exit; + end; + end; +end; + +{ Package/Module registration/unregistration } + +{$IFDEF MSWINDOWS} +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 +{$ENDIF} + +function FindModule(Instance: LongWord): PLibModule; +begin + Result := LibModuleList; + while Result <> nil do + begin + if (Instance = Result.Instance) or + (Instance = Result.CodeInstance) or + (Instance = Result.DataInstance) or + (Instance = Result.ResInstance) then + Exit; + Result := Result.Next; + end; +end; + +function FindHInstance(Address: Pointer): LongWord; +{$IFDEF MSWINDOWS} +var + MemInfo: TMemInfo; +begin + VirtualQuery(Address, MemInfo, SizeOf(MemInfo)); + if MemInfo.State = $1000{MEM_COMMIT} then + Result := LongWord(MemInfo.AllocationBase) + else + Result := 0; +end; +{$ENDIF} +{$IFDEF LINUX} +var + Info: TDLInfo; +begin + if (dladdr(Address, Info) = 0) or (Info.BaseAddress = ExeBaseAddress) then + Info.Filename := nil; // if it's not in a library, assume the exe + Result := LongWord(dlopen(Info.Filename, RTLD_LAZY)); + if Result <> 0 then + dlclose(Result); +end; +{$ENDIF} + +function FindClassHInstance(ClassType: TClass): LongWord; +begin + Result := FindHInstance(Pointer(ClassType)); +end; + +{$IFDEF LINUX} +function GetModuleFileName(Module: HMODULE; Buffer: PChar; BufLen: Integer): Integer; +var + Addr: Pointer; + Info: TDLInfo; + FoundInModule: HMODULE; +begin + Result := 0; + if (Module = MainInstance) or (Module = 0) then + begin + // First, try the dlsym approach. + // dladdr fails to return the name of the main executable + // in glibc prior to 2.1.91 + +{ Look for a dynamic symbol exported from this program. + _DYNAMIC is not required in a main program file. + If the main program is compiled with Delphi, it will always + have a resource section, named @Sysinit@ResSym. + If the main program is not compiled with Delphi, dlsym + will search the global name space, potentially returning + the address of a symbol in some other shared object library + loaded by the program. To guard against that, we check + that the address of the symbol found is within the + main program address range. } + + dlerror; // clear error state; dlsym doesn't + Addr := dlsym(Module, '@Sysinit@ResSym'); + if (Addr <> nil) and (dlerror = nil) + and (dladdr(Addr, Info) <> 0) + and (Info.FileName <> nil) + and (Info.BaseAddress = ExeBaseAddress) then + begin + Result := _strlen(Info.FileName); + if Result >= BufLen then Result := BufLen-1; + Move(Info.FileName^, Buffer^, Result); + Buffer[Result] := #0; + Exit; + end; + + // Try inspecting the /proc/ virtual file system + // to find the program filename in the process info + Result := _readlink('/proc/self/exe', Buffer, BufLen); + if Result <> -1 then + begin + if Result >= BufLen then Result := BufLen-1; + Buffer[Result] := #0; + end; +{$IFDEF AllowParamStrModuleName} +{ Using ParamStr(0) to obtain a module name presents a potential + security hole. Resource modules are loaded based upon the filename + of a given module. We use dlopen() to load resource modules, which + means the .init code of the resource module will be executed. + Normally, resource modules contain no code at all - they're just + carriers of resource data. + An unpriviledged user program could launch our trusted, + priviledged program with a bogus parameter list, tricking us + into loading a module that contains malicious code in its + .init section. + Without this ParamStr(0) section, GetModuleFilename cannot be + misdirected by unpriviledged code (unless the system program loader + or the /proc file system or system root directory has been compromised). + Resource modules are always loaded from the same directory as the + given module. Trusted code (programs, packages, and libraries) + should reside in directories that unpriviledged code cannot alter. + + If you need GetModuleFilename to have a chance of working on systems + where glibc < 2.1.91 and /proc is not available, and your + program will not run as a priviledged user (or you don't care), + you can define AllowParamStrModuleNames and rebuild the System unit + and baseCLX package. Note that even with ParamStr(0) support + enabled, GetModuleFilename can still fail to find the name of + a module. C'est la Unix. } + + if Result = -1 then // couldn't access the /proc filesystem + begin // return less accurate ParamStr(0) + +{ ParamStr(0) returns the name of the link used + to launch the app, not the name of the app itself. + Also, if this app was launched by some other program, + there is no guarantee that the launching program has set + up our environment at all. (example: Apache CGI) } + + if (ArgValues = nil) or (ArgValues^ = nil) or + (PCharArray(ArgValues^)[0] = nil) then + begin + Result := 0; + Exit; + end; + Result := _strlen(PCharArray(ArgValues^)[0]); + if Result >= BufLen then Result := BufLen-1; + Move(PCharArray(ArgValues^)[0]^, Buffer^, Result); + Buffer[Result] := #0; + end; +{$ENDIF} + end + else + begin +{ For shared object libraries, we can rely on the dlsym technique. + Look for a dynamic symbol in the requested module. + Don't assume the module was compiled with Delphi. + We look for a dynamic symbol with the name _DYNAMIC. This + exists in all ELF shared object libraries that export + or import symbols; If someone has a shared object library that + contains no imports or exports of any kind, this will probably fail. + If dlsym can't find the requested symbol in the given module, it + will search the global namespace and could return the address + of a symbol from some other module that happens to be loaded + into this process. That would be bad, so we double check + that the module handle of the symbol found matches the + module handle we asked about.} + + dlerror; // clear error state; dlsym doesn't + Addr := dlsym(Module, '_DYNAMIC'); + if (Addr <> nil) and (dlerror = nil) + and (dladdr(Addr, Info) <> 0) then + begin + if Info.BaseAddress = ExeBaseAddress then + Info.FileName := nil; + FoundInModule := HMODULE(dlopen(Info.FileName, RTLD_LAZY)); + if FoundInModule <> 0 then + dlclose(FoundInModule); + if Module = FoundInModule then + begin + Result := _strlen(Info.FileName); + if Result >= BufLen then Result := BufLen-1; + Move(Info.FileName^, Buffer^, Result); + Buffer[Result] := #0; + end; + end; + end; + if Result < 0 then Result := 0; +end; +{$ENDIF} + +function DelayLoadResourceModule(Module: PLibModule): LongWord; +var + FileName: array[0..MAX_PATH] of Char; +begin + if Module.ResInstance = 0 then + begin + GetModuleFileName(Module.Instance, FileName, SizeOf(FileName)); + Module.ResInstance := LoadResourceModule(FileName); + if Module.ResInstance = 0 then + Module.ResInstance := Module.Instance; + end; + Result := Module.ResInstance; +end; + +function FindResourceHInstance(Instance: LongWord): LongWord; +var + CurModule: PLibModule; +begin + CurModule := LibModuleList; + while CurModule <> nil do + begin + if (Instance = CurModule.Instance) or + (Instance = CurModule.CodeInstance) or + (Instance = CurModule.DataInstance) then + begin + Result := DelayLoadResourceModule(CurModule); + Exit; + end; + CurModule := CurModule.Next; + end; + Result := Instance; +end; + +function LoadResourceModule(ModuleName: PChar; CheckOwner: Boolean): LongWord; +{$IFDEF LINUX} +var + FileName: array [0..MAX_PATH] of Char; + LangCode: PChar; // Language and country code. Example: en_US + P: PChar; + ModuleNameLen, FileNameLen, i: Integer; + st1, st2: TStatStruct; +begin + LangCode := __getenv('LANG'); + Result := 0; + if (LangCode = nil) or (LangCode^ = #0) then Exit; + + // look for modulename.en_US (ignoring codeset and modifier suffixes) + P := LangCode; + while P^ in ['a'..'z', 'A'..'Z', '_'] do + Inc(P); + if P = LangCode then Exit; + + if CheckOwner and (__xstat(STAT_VER_LINUX, ModuleName, st1) = -1) then + Exit; + + ModuleNameLen := _strlen(ModuleName); + if (ModuleNameLen + P - LangCode) >= MAX_PATH then Exit; + Move(ModuleName[0], Filename[0], ModuleNameLen); + Filename[ModuleNameLen] := '.'; + Move(LangCode[0], Filename[ModuleNameLen + 1], P - LangCode); + FileNameLen := ModuleNameLen + 1 + (P - LangCode); + Filename[FileNameLen] := #0; + +{ Security check: make sure the user id (owner) and group id of + the base module matches the user id and group id of the resource + module we're considering loading. This is to prevent loading + of malicious code dropped into the base module's directory by + a hostile user. The app and all its resource modules must + have the same owner and group. To disable this security check, + call this function with CheckOwner set to False. } + + if (not CheckOwner) or + ((__xstat(STAT_VER_LINUX, FileName, st2) <> -1) + and (st1.st_uid = st2.st_uid) + and (st1.st_gid = st2.st_gid)) then + begin + Result := dlopen(Filename, RTLD_LAZY); + if Result <> 0 then Exit; + end; + + // look for modulename.en (ignoring country code and suffixes) + i := ModuleNameLen + 1; + while (i <= FileNameLen) and (Filename[i] in ['a'..'z', 'A'..'Z']) do + Inc(i); + if (i = ModuleNameLen + 1) or (i > FileNameLen) then Exit; + FileName[i] := #0; + + { Security check. See notes above. } + if (not CheckOwner) or + ((__xstat(STAT_VER_LINUX, FileName, st2) <> -1) + and (st1.st_uid = st2.st_uid) + and (st1.st_gid = st2.st_gid)) then + begin + Result := dlopen(FileName, RTLD_LAZY); + end; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +var + FileName: array[0..MAX_PATH] of Char; + Key: LongWord; + LocaleName, LocaleOverride: array[0..4] of Char; + Size: Integer; + P: PChar; + + function FindBS(Current: PChar): PChar; + begin + Result := Current; + while (Result^ <> #0) and (Result^ <> '\') do + Result := CharNext(Result); + end; + + function ToLongPath(AFileName: PChar; BufSize: Integer): PChar; + var + CurrBS, NextBS: PChar; + Handle, L: Integer; + FindData: TWin32FindData; + Buffer: array[0..MAX_PATH] of Char; + GetLongPathName: function (ShortPathName: PChar; LongPathName: PChar; + cchBuffer: Integer): Integer stdcall; + begin + Result := AFileName; + Handle := GetModuleHandle(kernel); + if Handle <> 0 then + begin + @GetLongPathName := GetProcAddress(Handle, 'GetLongPathNameA'); + if Assigned(GetLongPathName) and + (GetLongPathName(AFileName, Buffer, SizeOf(Buffer)) <> 0) then + begin + lstrcpyn(AFileName, Buffer, BufSize); + Exit; + end; + end; + + if AFileName[0] = '\' then + begin + if AFileName[1] <> '\' then Exit; + CurrBS := FindBS(AFileName + 2); // skip server name + if CurrBS^ = #0 then Exit; + CurrBS := FindBS(CurrBS + 1); // skip share name + if CurrBS^ = #0 then Exit; + end else + CurrBS := AFileName + 2; // skip drive name + + L := CurrBS - AFileName; + lstrcpyn(Buffer, AFileName, L + 1); + while CurrBS^ <> #0 do + begin + NextBS := FindBS(CurrBS + 1); + if L + (NextBS - CurrBS) + 1 > SizeOf(Buffer) then Exit; + lstrcpyn(Buffer + L, CurrBS, (NextBS - CurrBS) + 1); + + Handle := FindFirstFile(Buffer, FindData); + if (Handle = -1) then Exit; + FindClose(Handle); + + if L + 1 + _strlen(FindData.cFileName) + 1 > SizeOf(Buffer) then Exit; + Buffer[L] := '\'; + lstrcpyn(Buffer + L + 1, FindData.cFileName, Sizeof(Buffer) - L - 1); + Inc(L, _strlen(FindData.cFileName) + 1); + CurrBS := NextBS; + end; + lstrcpyn(AFileName, Buffer, BufSize); + end; +begin + GetModuleFileName(0, FileName, SizeOf(FileName)); // Get host application name + LocaleOverride[0] := #0; + if (RegOpenKeyEx(HKEY_CURRENT_USER, NewLocaleOverrideKey, 0, KEY_READ, Key) = 0) or + (RegOpenKeyEx(HKEY_LOCAL_MACHINE, NewLocaleOverrideKey, 0, KEY_READ, Key) = 0) or + (RegOpenKeyEx(HKEY_CURRENT_USER, OldLocaleOverrideKey, 0, KEY_READ, Key) = 0) then + try + Size := sizeof(LocaleOverride); + ToLongPath(FileName, sizeof(FileName)); + if RegQueryValueEx(Key, FileName, nil, nil, LocaleOverride, @Size) <> 0 then + if RegQueryValueEx(Key, '', nil, nil, LocaleOverride, @Size) <> 0 then + LocaleOverride[0] := #0; + LocaleOverride[sizeof(LocaleOverride)-1] := #0; + finally + RegCloseKey(Key); + end; + lstrcpyn(FileName, ModuleName, sizeof(FileName)); + GetLocaleInfo(GetThreadLocale, LOCALE_SABBREVLANGNAME, LocaleName, sizeof(LocaleName)); + Result := 0; + if (FileName[0] <> #0) and ((LocaleName[0] <> #0) or (LocaleOverride[0] <> #0)) then + begin + P := PChar(@FileName) + _strlen(FileName); + while (P^ <> '.') and (P <> @FileName) do Dec(P); + if P <> @FileName then + begin + Inc(P); + // First look for a locale registry override + if LocaleOverride[0] <> #0 then + begin + lstrcpyn(P, LocaleOverride, sizeof(FileName) - (P - FileName)); + Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE); + end; + if (Result = 0) and (LocaleName[0] <> #0) then + begin + // Then look for a potential language/country translation + lstrcpyn(P, LocaleName, sizeof(FileName) - (P - FileName)); + Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE); + if Result = 0 then + begin + // Finally look for a language only translation + LocaleName[2] := #0; + lstrcpyn(P, LocaleName, sizeof(FileName) - (P - FileName)); + Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE); + end; + end; + end; + end; +end; +{$ENDIF} + +procedure EnumModules(Func: TEnumModuleFunc; Data: Pointer); assembler; +begin + EnumModules(TEnumModuleFuncLW(Func), Data); +end; + +procedure EnumResourceModules(Func: TEnumModuleFunc; Data: Pointer); +begin + EnumResourceModules(TEnumModuleFuncLW(Func), Data); +end; + +procedure EnumModules(Func: TEnumModuleFuncLW; Data: Pointer); +var + CurModule: PLibModule; +begin + CurModule := LibModuleList; + while CurModule <> nil do + begin + if not Func(CurModule.Instance, Data) then Exit; + CurModule := CurModule.Next; + end; +end; + +procedure EnumResourceModules(Func: TEnumModuleFuncLW; Data: Pointer); +var + CurModule: PLibModule; +begin + CurModule := LibModuleList; + while CurModule <> nil do + begin + if not Func(DelayLoadResourceModule(CurModule), Data) then Exit; + CurModule := CurModule.Next; + end; +end; + +procedure AddModuleUnloadProc(Proc: TModuleUnloadProc); +begin + AddModuleUnloadProc(TModuleUnloadProcLW(Proc)); +end; + +procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProc); +begin + RemoveModuleUnloadProc(TModuleUnloadProcLW(Proc)); +end; + +procedure AddModuleUnloadProc(Proc: TModuleUnloadProcLW); +var + P: PModuleUnloadRec; +begin + New(P); + P.Next := ModuleUnloadList; + @P.Proc := @Proc; + ModuleUnloadList := P; +end; + +procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProcLW); +var + P, C: PModuleUnloadRec; +begin + P := ModuleUnloadList; + if (P <> nil) and (@P.Proc = @Proc) then + begin + ModuleUnloadList := ModuleUnloadList.Next; + Dispose(P); + end else + begin + C := P; + while C <> nil do + begin + if (C.Next <> nil) and (@C.Next.Proc = @Proc) then + begin + P := C.Next; + C.Next := C.Next.Next; + Dispose(P); + Break; + end; + C := C.Next; + end; + end; +end; + +procedure NotifyModuleUnload(HInstance: LongWord); +var + P: PModuleUnloadRec; +begin + P := ModuleUnloadList; + while P <> nil do + begin + try + P.Proc(HInstance); + except + // Make sure it doesn't stop notifications + end; + P := P.Next; + end; +{$IFDEF LINUX} + InvalidateModuleCache; +{$ENDIF} +end; + +procedure RegisterModule(LibModule: PLibModule); +begin + LibModule.Next := LibModuleList; + LibModuleList := LibModule; +end; + +{X- procedure UnregisterModule(LibModule: PLibModule); -renamed } +procedure UnRegisterModuleSafely( LibModule: PLibModule ); +var + CurModule: PLibModule; +begin + try + NotifyModuleUnload(LibModule.Instance); + finally + if LibModule = LibModuleList then + LibModuleList := LibModule.Next + else + begin + CurModule := LibModuleList; + while CurModule <> nil do + begin + if CurModule.Next = LibModule then + begin + CurModule.Next := LibModule.Next; + Break; + end; + CurModule := CurModule.Next; + end; + end; + end; +end; + +{X+} // "Light" version of UnRegisterModule - without using of try-except +procedure UnRegisterModuleLight( LibModule: PLibModule ); +var + P: PModuleUnloadRec; +begin + P := ModuleUnloadList; + while P <> nil do + begin + P.Proc(LibModule.Instance); + P := P.Next; + end; +end; +{X-} + +function _IntfClear(var Dest: IInterface): Pointer; +{$IFDEF PUREPASCAL} +var + P: Pointer; +begin + Result := @Dest; + if Dest <> nil then + begin + P := Pointer(Dest); + Pointer(Dest) := nil; + IInterface(P)._Release; + end; +end; +{$ELSE} +asm + MOV EDX,[EAX] + TEST EDX,EDX + JE @@1 + MOV DWORD PTR [EAX],0 + PUSH EAX + PUSH EDX + MOV EAX,[EDX] + CALL DWORD PTR [EAX] + VMTOFFSET IInterface._Release + POP EAX +@@1: +end; +{$ENDIF} + +procedure _IntfCopy(var Dest: IInterface; const Source: IInterface); +{$IFDEF PUREPASCAL} +var + P: Pointer; +begin + P := Pointer(Dest); + if Source <> nil then + Source._AddRef; + Pointer(Dest) := Pointer(Source); + if P <> nil then + IInterface(P)._Release; +end; +{$ELSE} +asm +{ + The most common case is the single assignment of a non-nil interface + to a nil interface. So we streamline that case here. After this, + we give essentially equal weight to other outcomes. + + The semantics are: The source intf must be addrefed *before* it + is assigned to the destination. The old intf must be released + after the new intf is addrefed to support self assignment (I := I). + Either intf can be nil. The first requirement is really to make an + error case function a little better, and to improve the behaviour + of multithreaded applications - if the addref throws an exception, + you don't want the interface to have been assigned here, and if the + assignment is made to a global and another thread references it, + again you don't want the intf to be available until the reference + count is bumped. +} + TEST EDX,EDX // is source nil? + JE @@NilSource + PUSH EDX // save source + PUSH EAX // save dest + MOV EAX,[EDX] // get source vmt + PUSH EDX // source as arg + CALL DWORD PTR [EAX] + VMTOFFSET IInterface._AddRef + POP EAX // retrieve dest + MOV ECX, [EAX] // get current value + POP [EAX] // set dest in place + TEST ECX, ECX // is current value nil? + JNE @@ReleaseDest // no, release it + RET // most common case, we return here +@@ReleaseDest: + MOV EAX,[ECX] // get current value vmt + PUSH ECX // current value as arg + CALL DWORD PTR [EAX] + VMTOFFSET IInterface._Release + RET + +{ Now we're into the less common cases. } +@@NilSource: + MOV ECX, [EAX] // get current value + TEST ECX, ECX // is it nil? + MOV [EAX], EDX // store in dest (which is nil) + JE @@Done + MOV EAX, [ECX] // get current vmt + PUSH ECX // current value as arg + CALL [EAX].vmtRelease.Pointer +@@Done: +end; +{$ENDIF} + +procedure _IntfCast(var Dest: IInterface; const Source: IInterface; const IID: TGUID); +{$IFDEF PUREPASCAL} +// PIC: EBX must be correct before calling QueryInterface +begin + if Source = nil then + Dest := nil + else if Source.QueryInterface(IID, Dest) <> 0 then + Error(reIntfCastError); +end; +{$ELSE} +asm + TEST EDX,EDX + JE _IntfClear + PUSH EAX + PUSH ECX + PUSH EDX + MOV ECX,[EAX] + TEST ECX,ECX + JE @@1 + PUSH ECX + MOV EAX,[ECX] + CALL DWORD PTR [EAX] + VMTOFFSET IInterface._Release + MOV EDX,[ESP] +@@1: MOV EAX,[EDX] + CALL DWORD PTR [EAX] + VMTOFFSET IInterface.QueryInterface + TEST EAX,EAX + JE @@2 + MOV AL,reIntfCastError + JMP Error +@@2: +end; +{$ENDIF} + +procedure _IntfAddRef(const Dest: IInterface); +begin + if Dest <> nil then Dest._AddRef; +end; + +procedure TInterfacedObject.AfterConstruction; +begin +// Release the constructor's implicit refcount + InterlockedDecrement(FRefCount); +end; + +procedure TInterfacedObject.BeforeDestruction; +begin + if RefCount <> 0 then + Error(reInvalidPtr); +end; + +// Set an implicit refcount so that refcounting +// during construction won't destroy the object. +class function TInterfacedObject.NewInstance: TObject; +begin + Result := inherited NewInstance; + TInterfacedObject(Result).FRefCount := 1; +end; + +function TInterfacedObject.QueryInterface(const IID: TGUID; out Obj): HResult; +begin + if GetInterface(IID, Obj) then + Result := 0 + else + Result := E_NOINTERFACE; +end; + +function TInterfacedObject._AddRef: Integer; +begin + Result := InterlockedIncrement(FRefCount); +end; + +function TInterfacedObject._Release: Integer; +begin + Result := InterlockedDecrement(FRefCount); + if Result = 0 then + Destroy; +end; + +{ TAggregatedObject } + +constructor TAggregatedObject.Create(const Controller: IInterface); +begin + // weak reference to controller - don't keep it alive + FController := Pointer(Controller); +end; + +function TAggregatedObject.GetController: IInterface; +begin + Result := IInterface(FController); +end; + +function TAggregatedObject.QueryInterface(const IID: TGUID; out Obj): HResult; +begin + Result := IInterface(FController).QueryInterface(IID, Obj); +end; + +function TAggregatedObject._AddRef: Integer; +begin + Result := IInterface(FController)._AddRef; +end; + +function TAggregatedObject._Release: Integer; stdcall; +begin + Result := IInterface(FController)._Release; +end; + +{ TContainedObject } + +function TContainedObject.QueryInterface(const IID: TGUID; out Obj): HResult; +begin + if GetInterface(IID, Obj) then + Result := S_OK + else + Result := E_NOINTERFACE; +end; + + +function _CheckAutoResult(ResultCode: HResult): HResult; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + if ResultCode < 0 then + begin + if Assigned(SafeCallErrorProc) then + SafeCallErrorProc(ResultCode, Pointer(-1)); // loses error address + Error(reSafeCallError); + end; + Result := ResultCode; +end; +{$ELSE} +asm + TEST EAX,EAX + JNS @@2 + MOV ECX,SafeCallErrorProc + TEST ECX,ECX + JE @@1 + MOV EDX,[ESP] + CALL ECX +@@1: MOV AL,reSafeCallError + JMP Error +@@2: +end; +{$IFEND} + +function CompToDouble(Value: Comp): Double; cdecl; +begin + Result := Value; +end; + +procedure DoubleToComp(Value: Double; var Result: Comp); cdecl; +begin + Result := Value; +end; + +function CompToCurrency(Value: Comp): Currency; cdecl; +begin + Result := Value; +end; + +procedure CurrencyToComp(Value: Currency; var Result: Comp); cdecl; +begin + Result := Value; +end; + +function GetMemory(Size: Integer): Pointer; cdecl; +begin + Result := MemoryManager.GetMem(Size); +end; + +function FreeMemory(P: Pointer): Integer; cdecl; +begin + if P = nil then + Result := 0 + else + Result := MemoryManager.FreeMem(P); +end; + +function ReallocMemory(P: Pointer; Size: Integer): Pointer; cdecl; +begin + Result := MemoryManager.ReallocMem(P, Size); +end; + +procedure SetLineBreakStyle(var T: Text; Style: TTextLineBreakStyle); +begin + if TTextRec(T).Mode = fmClosed then + TTextRec(T).Flags := TTextRec(T).Flags or (tfCRLF * Byte(Style)) + else + SetInOutRes(107); // can't change mode of open file +end; + +// UnicodeToUTF8(3): +// Scans the source data to find the null terminator, up to MaxBytes +// Dest must have MaxBytes available in Dest. + +function UnicodeToUtf8(Dest: PChar; Source: PWideChar; MaxBytes: Integer): Integer; +var + len: Cardinal; +begin + len := 0; + if Source <> nil then + while Source[len] <> #0 do + Inc(len); + Result := UnicodeToUtf8(Dest, MaxBytes, Source, len); +end; + +// UnicodeToUtf8(4): +// MaxDestBytes includes the null terminator (last char in the buffer will be set to null) +// Function result includes the null terminator. +// Nulls in the source data are not considered terminators - SourceChars must be accurate + +function UnicodeToUtf8(Dest: PChar; MaxDestBytes: Cardinal; Source: PWideChar; SourceChars: Cardinal): Cardinal; +var + i, count: Cardinal; + c: Cardinal; +begin + Result := 0; + if Source = nil then Exit; + count := 0; + i := 0; + if Dest <> nil then + begin + while (i < SourceChars) and (count < MaxDestBytes) do + begin + c := Cardinal(Source[i]); + Inc(i); + if c <= $7F then + begin + Dest[count] := Char(c); + Inc(count); + end + else if c > $7FF then + begin + if count + 3 > MaxDestBytes then + break; + Dest[count] := Char($E0 or (c shr 12)); + Dest[count+1] := Char($80 or ((c shr 6) and $3F)); + Dest[count+2] := Char($80 or (c and $3F)); + Inc(count,3); + end + else // $7F < Source[i] <= $7FF + begin + if count + 2 > MaxDestBytes then + break; + Dest[count] := Char($C0 or (c shr 6)); + Dest[count+1] := Char($80 or (c and $3F)); + Inc(count,2); + end; + end; + if count >= MaxDestBytes then count := MaxDestBytes-1; + Dest[count] := #0; + end + else + begin + while i < SourceChars do + begin + c := Integer(Source[i]); + Inc(i); + if c > $7F then + begin + if c > $7FF then + Inc(count); + Inc(count); + end; + Inc(count); + end; + end; + Result := count+1; // convert zero based index to byte count +end; + +function Utf8ToUnicode(Dest: PWideChar; Source: PChar; MaxChars: Integer): Integer; +var + len: Cardinal; +begin + len := 0; + if Source <> nil then + while Source[len] <> #0 do + Inc(len); + Result := Utf8ToUnicode(Dest, MaxChars, Source, len); +end; + +function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: Cardinal; Source: PChar; SourceBytes: Cardinal): Cardinal; +var + i, count: Cardinal; + c: Byte; + wc: Cardinal; +begin + if Source = nil then + begin + Result := 0; + Exit; + end; + Result := Cardinal(-1); + count := 0; + i := 0; + if Dest <> nil then + begin + while (i < SourceBytes) and (count < MaxDestChars) do + begin + wc := Cardinal(Source[i]); + Inc(i); + if (wc and $80) <> 0 then + begin + wc := wc and $3F; + if i > SourceBytes then Exit; // incomplete multibyte char + if (wc and $20) <> 0 then + begin + c := Byte(Source[i]); + Inc(i); + if (c and $C0) <> $80 then Exit; // malformed trail byte or out of range char + if i > SourceBytes then Exit; // incomplete multibyte char + wc := (wc shl 6) or (c and $3F); + end; + c := Byte(Source[i]); + Inc(i); + if (c and $C0) <> $80 then Exit; // malformed trail byte + + Dest[count] := WideChar((wc shl 6) or (c and $3F)); + end + else + Dest[count] := WideChar(wc); + Inc(count); + end; + if count >= MaxDestChars then count := MaxDestChars-1; + Dest[count] := #0; + end + else + begin + while (i <= SourceBytes) do + begin + c := Byte(Source[i]); + Inc(i); + if (c and $80) <> 0 then + begin + if (c and $F0) = $F0 then Exit; // too many bytes for UCS2 + if (c and $40) = 0 then Exit; // malformed lead byte + if i > SourceBytes then Exit; // incomplete multibyte char + + if (Byte(Source[i]) and $C0) <> $80 then Exit; // malformed trail byte + Inc(i); + if i > SourceBytes then Exit; // incomplete multibyte char + if ((c and $20) <> 0) and ((Byte(Source[i]) and $C0) <> $80) then Exit; // malformed trail byte + Inc(i); + end; + Inc(count); + end; + end; + Result := count+1; +end; + +function Utf8Encode(const WS: WideString): UTF8String; +var + L: Integer; + Temp: UTF8String; +begin + Result := ''; + if WS = '' then Exit; + SetLength(Temp, Length(WS) * 3); // SetLength includes space for null terminator + + L := UnicodeToUtf8(PChar(Temp), Length(Temp)+1, PWideChar(WS), Length(WS)); + if L > 0 then + SetLength(Temp, L-1) + else + Temp := ''; + Result := Temp; +end; + +function Utf8Decode(const S: UTF8String): WideString; +var + L: Integer; + Temp: WideString; +begin + Result := ''; + if S = '' then Exit; + SetLength(Temp, Length(S)); + + L := Utf8ToUnicode(PWideChar(Temp), Length(Temp)+1, PChar(S), Length(S)); + if L > 0 then + SetLength(Temp, L-1) + else + Temp := ''; + Result := Temp; +end; + +function AnsiToUtf8(const S: string): UTF8String; +begin + Result := Utf8Encode(S); +end; + +function Utf8ToAnsi(const S: UTF8String): string; +begin + Result := Utf8Decode(S); +end; + +{$IFDEF LINUX} + +function GetCPUType: Integer; +asm + PUSH EBX + // this code assumes ESP is 4 byte aligned + // test for 80386: see if bit #18 of EFLAGS (Alignment fault) can be toggled + PUSHF + POP EAX + MOV ECX, EAX + XOR EAX, $40000 // flip AC bit in EFLAGS + PUSH EAX + POPF + PUSHF + POP EAX + XOR EAX, ECX // zero = 80386 CPU (can't toggle AC bit) + MOV EAX, CPUi386 + JZ @@Exit + PUSH ECX + POPF // restore original flags before next test + + // test for 80486: see if bit #21 of EFLAGS (CPUID supported) can be toggled + MOV EAX, ECX // get original EFLAGS + XOR EAX, $200000 // flip CPUID bit in EFLAGS + PUSH EAX + POPF + PUSHF + POP EAX + XOR EAX, ECX // zero = 80486 (can't toggle EFLAGS bit #21) + MOV EAX, CPUi486 + JZ @@Exit + + // Use CPUID instruction to get CPU family + XOR EAX, EAX + CPUID + CMP EAX, 1 + JL @@Exit // unknown processor response: report as 486 + XOR EAX, EAX + INC EAX // we only care about info level 1 + CPUID + AND EAX, $F00 + SHR EAX, 8 + // Test8086 values are one less than the CPU model number, for historical reasons + DEC EAX + +@@Exit: + POP EBX +end; + + +const + sResSymExport = '@Sysinit@ResSym'; + sResStrExport = '@Sysinit@ResStr'; + sResHashExport = '@Sysinit@ResHash'; + +type + TElf32Sym = record + Name: Cardinal; + Value: Pointer; + Size: Cardinal; + Info: Byte; + Other: Byte; + Section: Word; + end; + PElf32Sym = ^TElf32Sym; + + TElfSymTab = array [0..0] of TElf32Sym; + PElfSymTab = ^TElfSymTab; + + TElfWordTab = array [0..2] of Cardinal; + PElfWordTab = ^TElfWordTab; + + +{ If Name encodes a numeric identifier, return it, else return -1. } +function NameToId(Name: PChar): Longint; +var digit: Longint; +begin + if Longint(Name) and $ffff0000 = 0 then + begin + Result := Longint(Name) and $ffff; + end + else if Name^ = '#' then + begin + Result := 0; + inc (Name); + while (Ord(Name^) <> 0) do + begin + digit := Ord(Name^) - Ord('0'); + if (LongWord(digit) > 9) then + begin + Result := -1; + exit; + end; + Result := Result * 10 + digit; + inc (Name); + end; + end + else + Result := -1; +end; + + +// Return ELF hash value for NAME converted to lower case. +function ElfHashLowercase(Name: PChar): Cardinal; +var + g: Cardinal; + c: Char; +begin + Result := 0; + while name^ <> #0 do + begin + c := name^; + case c of + 'A'..'Z': Inc(c, Ord('a') - Ord('A')); + end; + Result := (Result shl 4) + Ord(c); + g := Result and $f0000000; + Result := (Result xor (g shr 24)) and not g; + Inc(name); + end; +end; + +type + PFindResourceCache = ^TFindResourceCache; + TFindResourceCache = record + ModuleHandle: HMODULE; + Version: Cardinal; + SymbolTable: PElfSymTab; + StringTable: PChar; + HashTable: PElfWordTab; + BaseAddress: Cardinal; + end; + +threadvar + FindResourceCache: TFindResourceCache; + +function GetResourceCache(ModuleHandle: HMODULE): PFindResourceCache; +var + info: TDLInfo; +begin + Result := @FindResourceCache; + if (ModuleHandle <> Result^.ModuleHandle) or (ModuleCacheVersion <> Result^.Version) then + begin + Result^.SymbolTable := dlsym(ModuleHandle, sResSymExport); + Result^.StringTable := dlsym(ModuleHandle, sResStrExport); + Result^.HashTable := dlsym(ModuleHandle, sResHashExport); + Result^.ModuleHandle := ModuleHandle; + if (dladdr(Result^.HashTable, Info) = 0) or (Info.BaseAddress = ExeBaseAddress) then + Result^.BaseAddress := 0 // if it's not in a library, assume the exe + else + Result^.BaseAddress := Cardinal(Info.BaseAddress); + Result^.Version := ModuleCacheVersion; + end; +end; + +function FindResource(ModuleHandle: HMODULE; ResourceName: PChar; ResourceType: PChar): TResourceHandle; +var + P: PFindResourceCache; + nid, tid: Longint; + ucs2_key: array [0..2] of WideChar; + key: array [0..127] of Char; + len: Integer; + pc: PChar; + ch: Char; + nbucket: Cardinal; + bucket, chain: PElfWordTab; + syndx: Cardinal; +begin + Result := 0; + if ResourceName = nil then Exit; + P := GetResourceCache(ModuleHandle); + + tid := NameToId (ResourceType); + if tid = -1 then Exit; { not supported (yet?) } + + { This code must match util-common/elfres.c } + nid := NameToId (ResourceName); + if nid = -1 then + begin + ucs2_key[0] := WideChar(2*tid+2); + ucs2_key[1] := WideChar(0); + len := UnicodeToUtf8 (key, ucs2_key, SizeOf (key)); + pc := key+len; + while Ord(ResourceName^) <> 0 do + begin + ch := ResourceName^; + if Ord(ch) > 127 then exit; { insist on 7bit ASCII for now } + if ('A' <= ch) and (ch <= 'Z') then Inc(ch, Ord('a') - Ord('A')); + pc^ := ch; + inc (pc); + if pc = key + SizeOf(key) then exit; + inc (ResourceName); + end; + pc^ := Char(0); + end + else + begin + ucs2_key[0] := WideChar(2*tid+1); + ucs2_key[1] := WideChar(nid); + ucs2_key[2] := WideChar(0); + UnicodeToUtf8 (key, ucs2_key, SizeOf (key)); + end; + + with P^ do + begin + nbucket := HashTable[0]; + // nsym := HashTable[1]; + bucket := @HashTable[2]; + chain := @HashTable[2+nbucket]; + + syndx := bucket[ElfHashLowercase(key) mod nbucket]; + while (syndx <> 0) + and (strcasecmp(key, @StringTable[SymbolTable[syndx].Name]) <> 0) do + syndx := chain[syndx]; + + if syndx = 0 then + Result := 0 + else + Result := TResourceHandle(@SymbolTable[syndx]); + end; +end; + +function LoadResource(ModuleHandle: HMODULE; ResHandle: TResourceHandle): HGLOBAL; +var + P: PFindResourceCache; +begin + if ResHandle <> 0 then + begin + P := GetResourceCache(ModuleHandle); + Result := HGLOBAL(PElf32Sym(ResHandle)^.Value); + Inc (Cardinal(Result), P^.BaseAddress); + end + else + Result := 0; +end; + +function SizeofResource(ModuleHandle: HMODULE; ResHandle: TResourceHandle): Integer; +begin + if ResHandle <> 0 then + Result := PElf32Sym(ResHandle)^.Size + else + Result := 0; +end; + +function LockResource(ResData: HGLOBAL): Pointer; +begin + Result := Pointer(ResData); +end; + +function UnlockResource(ResData: HGLOBAL): LongBool; +begin + Result := False; +end; + +function FreeResource(ResData: HGLOBAL): LongBool; +begin + Result := True; +end; +{$ENDIF} + +{ ResString support function } + +{$IFDEF MSWINDOWS} +function LoadResString(ResStringRec: PResStringRec): string; +var + Buffer: array [0..1023] of char; +begin + if ResStringRec = nil then Exit; + if ResStringRec.Identifier < 64*1024 then + SetString(Result, Buffer, + LoadString(FindResourceHInstance(ResStringRec.Module^), + ResStringRec.Identifier, Buffer, SizeOf(Buffer))) + else + Result := PChar(ResStringRec.Identifier); +end; +{$ENDIF} +{$IFDEF LINUX} + +const + ResStringTableLen = 16; + +type + ResStringTable = array [0..ResStringTableLen-1] of LongWord; + +function LoadResString(ResStringRec: PResStringRec): string; +var + Handle: TResourceHandle; + Tab: ^ResStringTable; + ResMod: HMODULE; +begin + if ResStringRec = nil then Exit; + ResMod := FindResourceHInstance(ResStringRec^.Module^); + Handle := FindResource(ResMod, + PChar(ResStringRec^.Identifier div ResStringTableLen), + PChar(6)); // RT_STRING + Tab := Pointer(LoadResource(ResMod, Handle)); + if Tab = nil then + Result := '' + else + Result := PChar (Tab) + Tab[ResStringRec^.Identifier mod ResStringTableLen]; +end; + +procedure DbgUnlockX; +begin + if Assigned(DbgUnlockXProc) then + DbgUnlockXProc; +end; + +{ The Win32 program loader sets up the first 64k of process address space + with no read or write access, to help detect use of invalid pointers + (whose integer value is 0..64k). Linux doesn't do this. + + Parts of the Delphi RTL and IDE design environment + rely on the notion that pointer values in the [0..64k] range are + invalid pointers. To accomodate this in Linux, we reserve the range + at startup. If the range is already allocated, we keep going anyway. } + +var + ZeroPageReserved: Boolean = False; + +procedure ReserveZeroPage; +const + PROT_NONE = 0; + MAP_PRIVATE = $02; + MAP_FIXED = $10; + MAP_ANONYMOUS = $20; +var + P: Pointer; +begin + if IsLibrary then Exit; // page reserve is app's job, not .so's + + if not ZeroPageReserved then + begin + P := mmap(nil, High(Word), PROT_NONE, + MAP_ANONYMOUS or MAP_PRIVATE or MAP_FIXED, 0, 0); + ZeroPageReserved := P = nil; + if (Integer(P) <> -1) and (P <> nil) then // we didn't get it + munmap(P, High(Word)); + end; +end; + +procedure ReleaseZeroPage; +begin + if ZeroPageReserved then + begin + munmap(nil, High(Word) - 4096); + ZeroPageReserved := False; + end; +end; +{$ENDIF} + +function PUCS4Chars(const S: UCS4String): PUCS4Char; +const + Null: UCS4Char = 0; + PNull: PUCS4Char = @Null; +begin + if Length(S) > 0 then + Result := @S[0] + else + Result := PNull; +end; + +function WideStringToUCS4String(const S: WideString): UCS4String; +var + I: Integer; +begin + SetLength(Result, Length(S) + 1); + for I := 0 to Length(S) - 1 do + Result[I] := UCS4Char(S[I + 1]); + Result[Length(S)] := 0; +end; + +function UCS4StringToWidestring(const S: UCS4String): WideString; +var + I: Integer; +begin + SetLength(Result, Length(S)); + for I := 0 to Length(S)-1 do + Result[I+1] := WideChar(S[I]); + Result[Length(S)] := #0; +end; + +var SaveCmdShow : Integer = -1; +function CmdShow: Integer; +var + SI: TStartupInfo; +begin + if SaveCmdShow < 0 then + begin + SaveCmdShow := 10; { SW_SHOWDEFAULT } + GetStartupInfo(SI); + if SI.dwFlags and 1 <> 0 then { STARTF_USESHOWWINDOW } + SaveCmdShow := SI.wShowWindow; + end; + Result := SaveCmdShow; +end; + +{X} // convert var CmdLine : PChar to a function: +{X} function CmdLine : PChar; +{X} begin +{X} Result := GetCommandLine; +{X} end; + +initialization + + {$IFDEF MSWINDOWS} + {$IFDEF USE_PROCESS_HEAP} + HeapHandle := GetProcessHeap; + {$ELSE} + HeapHandle := HeapCreate( 0, 0, 0 ); + {$ENDIF} + {$ENDIF} + + {$IFDEF MSWINDOWS} + //{X (initialized statically} FileMode := 2; + {$ELSE} + FileMode := 2; + {$ENDIF} + +{$IFDEF LINUX} + FileAccessRights := S_IRUSR or S_IWUSR or S_IRGRP or S_IWGRP or S_IROTH or S_IWOTH; + Test8086 := GetCPUType; + IsConsole := True; + FindResourceCache.ModuleHandle := LongWord(-1); + ReserveZeroPage; +{$ELSE} + //{X (initialized statically} Test8086 := 2; +{$ENDIF} + + DispCallByIDProc := @_DispCallByIDError; + +{$IFDEF MSWINDOWS} + //{X} if _isNECWindows then _FpuMaskInit; +{$ENDIF} + //{X} _FpuInit(); + + TTextRec(Input).Mode := fmClosed; + TTextRec(Output).Mode := fmClosed; + TTextRec(ErrOutput).Mode := fmClosed; + InitVariantManager; + +{$IFDEF MSWINDOWS} +{X- CmdLine := GetCommandLine; converted to a function } +{X- CmdShow := GetCmdShow; converted to a function } +{$ENDIF} + MainThreadID := GetCurrentThreadID; + +{$IFDEF LINUX} + // Ensure DbgUnlockX is linked in, calling it now does nothing + DbgUnlockX; +{$ENDIF} + +finalization + {X+} + {X} CloseInputOutput; + {X- + Close(Input); + Close(Output); + Close(ErrOutput); + X+} +{$IFDEF LINUX} + ReleaseZeroPage; +{$ENDIF} +{$IFDEF MSWINDOWS} +{X UninitAllocator; - replaced with call to UninitMemoryManager handler. } + UninitMemoryManager; +{$ENDIF} +end. + diff --git a/System/D2009beta/Variants.pas b/System/D2009beta/Variants.pas new file mode 100644 index 0000000..727c59d --- /dev/null +++ b/System/D2009beta/Variants.pas @@ -0,0 +1,12 @@ +unit Variants; +{* Fake variants.pas unit for Delphi6 / Delphi7. Place it in a + directory with your KOL/MCK (or other non-VCL) project, and + this will save about 70K of code in the executable. + Certainly, do it so, if you actually do not use Delphi Variant + type in the application. + NEVER REPLACE Variants.pas provided by Borland! + (C) by Kladov Vladimir, 2003 } + +interface +implementation +end. diff --git a/System/D2009beta/getmem.inc b/System/D2009beta/getmem.inc new file mode 100644 index 0000000..f9b4f67 --- /dev/null +++ b/System/D2009beta/getmem.inc @@ -0,0 +1,1541 @@ +{ *********************************************************************** } +{ } +{ Delphi Runtime Library } +{ } +{ Copyright (c) 1996,2001 Borland Software Corporation } +{ } +{ *********************************************************************** } + +// Three layers: +// - Address space administration +// - Committed space administration +// - Suballocator +// +// Helper module: administrating block descriptors +// + + +// +// Operating system interface +// +const + LMEM_FIXED = 0; + LMEM_ZEROINIT = $40; + + MEM_COMMIT = $1000; + MEM_RESERVE = $2000; + MEM_DECOMMIT = $4000; + MEM_RELEASE = $8000; + + PAGE_NOACCESS = 1; + PAGE_READWRITE = 4; + +type + DWORD = Integer; + BOOL = LongBool; + + TRTLCriticalSection = packed record + DebugInfo: Pointer; + LockCount: Longint; + RecursionCount: Longint; + OwningThread: Integer; + LockSemaphore: Integer; + Reserved: DWORD; + end; + +{function LocalAlloc(flags, size: Integer): Pointer; stdcall; + external kernel name 'LocalAlloc'; +function LocalFree(addr: Pointer): Pointer; stdcall; + external kernel name 'LocalFree';} + +function VirtualAlloc(lpAddress: Pointer; + dwSize, flAllocationType, flProtect: DWORD): Pointer; stdcall; + external kernel name 'VirtualAlloc'; +function VirtualFree(lpAddress: Pointer; dwSize, dwFreeType: DWORD): BOOL; stdcall; + external kernel name 'VirtualFree'; + +procedure InitializeCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall; + external kernel name 'InitializeCriticalSection'; +procedure EnterCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall; + external kernel name 'EnterCriticalSection'; +procedure LeaveCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall; + external kernel name 'LeaveCriticalSection'; +procedure DeleteCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall; + external kernel name 'DeleteCriticalSection'; + +// Common Data structure: + +type + TBlock = packed record + addr: PChar; + size: Integer; + end; + +// Heap error codes + +const + cHeapOk = 0; // everything's fine + cReleaseErr = 1; // operating system returned an error when we released + cDecommitErr = 2; // operating system returned an error when we decommited + cBadCommittedList = 3; // list of committed blocks looks bad + cBadFiller1 = 4; // filler block is bad + cBadFiller2 = 5; // filler block is bad + cBadFiller3 = 6; // filler block is bad + cBadCurAlloc = 7; // current allocation zone is bad + cCantInit = 8; // couldn't initialize + cBadUsedBlock = 9; // used block looks bad + cBadPrevBlock = 10; // prev block before a used block is bad + cBadNextBlock = 11; // next block after a used block is bad + cBadFreeList = 12; // free list is bad + cBadFreeBlock = 13; // free block is bad + cBadBalance = 14; // free list doesn't correspond to blocks marked free + +var + initialized : Boolean; + heapErrorCode : Integer; + heapLock : TRTLCriticalSection; + {X} // Handler to set it to UninitAllocator, if Delphi memory manager used: + {X} UninitMemoryManager : procedure = DummyProc; + +// +// Helper module: administrating block descriptors. +// +type + PBlockDesc = ^TBlockDesc; + TBlockDesc = packed record + next: PBlockDesc; + prev: PBlockDesc; + addr: PChar; + size: Integer; + end; + +type + PBlockDescBlock = ^TBlockDescBlock; + TBlockDescBlock = packed record + next: PBlockDescBlock; + data: array [0..99] of TBlockDesc; + end; + +var + blockDescBlockList: PBlockDescBlock; + blockDescFreeList : PBlockDesc; + + +function GetBlockDesc: PBlockDesc; +// Get a block descriptor. +// Will return nil for failure. +var + bd: PBlockDesc; + bdb: PBlockDescBlock; + i: Integer; +begin + if blockDescFreeList = nil then begin + bdb := LocalAlloc(LMEM_FIXED, sizeof(bdb^)); + if bdb = nil then begin + result := nil; + exit; + end; + bdb.next := blockDescBlockList; + blockDescBlockList := bdb; + for i := low(bdb.data) to high(bdb.data) do begin + bd := @bdb.data[i]; + bd.next := blockDescFreeList; + blockDescFreeList := bd; + end; + end; + bd := blockDescFreeList; + blockDescFreeList := bd.next; + result := bd; +end; + + +procedure MakeEmpty(bd: PBlockDesc); +begin + bd.next := bd; + bd.prev := bd; +end; + + +function AddBlockAfter(prev: PBlockDesc; const b: TBlock): Boolean; +var + next, bd: PBlockDesc; +begin + bd := GetBlockDesc; + if bd = nil then + result := False + else begin + bd.addr := b.addr; + bd.size := b.size; + + next := prev.next; + bd.next := next; + bd.prev := prev; + next.prev := bd; + prev.next := bd; + + result := True; + end; +end; + + +procedure DeleteBlock(bd: PBlockDesc); +var + prev, next: PBlockDesc; +begin + prev := bd.prev; + next := bd.next; + prev.next := next; + next.prev := prev; + bd.next := blockDescFreeList; + blockDescFreeList := bd; +end; + + +function MergeBlockAfter(prev: PBlockDesc; const b: TBlock) : TBlock; +var + bd, bdNext: PBlockDesc; +begin + bd := prev.next; + result := b; + repeat + bdNext := bd.next; + if bd.addr + bd.size = result.addr then begin + DeleteBlock(bd); + result.addr := bd.addr; + inc(result.size, bd.size); + end else if result.addr + result.size = bd.addr then begin + DeleteBlock(bd); + inc(result.size, bd.size); + end; + bd := bdNext; + until bd = prev; + if not AddBlockAfter(prev, result) then + result.addr := nil; +end; + + +function RemoveBlock(bd: PBlockDesc; const b: TBlock): Boolean; +var + n: TBlock; + start: PBlockDesc; +begin + start := bd; + repeat + if (bd.addr <= b.addr) and (bd.addr + bd.size >= b.addr + b.size) then begin + if bd.addr = b.addr then begin + Inc(bd.addr, b.size); + Dec(bd.size, b.size); + if bd.size = 0 then + DeleteBlock(bd); + end else if bd.addr + bd.size = b.addr + b.size then + Dec(bd.size, b.size) + else begin + n.addr := b.addr + b.size; + n.size := bd.addr + bd.size - n.addr; + bd.size := b.addr - bd.addr; + if not AddBlockAfter(bd, n) then begin + result := False; + exit; + end; + end; + result := True; + exit; + end; + bd := bd.next; + until bd = start; + result := False; +end; + + + +// +// Address space administration: +// + +const + cSpaceAlign = 64*1024; + cSpaceMin = 1024*1024; + cPageAlign = 4*1024; + +var + spaceRoot: TBlockDesc; + + +function GetSpace(minSize: Integer): TBlock; +// Get at least minSize bytes address space. +// Success: returns a block, possibly much bigger than requested. +// Will not fail - will raise an exception or terminate program. +begin + if minSize < cSpaceMin then + minSize := cSpaceMin + else + minSize := (minSize + (cSpaceAlign-1)) and not (cSpaceAlign-1); + + result.size := minSize; + result.addr := VirtualAlloc(nil, minSize, MEM_RESERVE, PAGE_NOACCESS); + if result.addr = nil then + exit; + + if not AddBlockAfter(@spaceRoot, result) then begin + VirtualFree(result.addr, 0, MEM_RELEASE); + result.addr := nil; + exit; + end; +end; + + +function GetSpaceAt(addr: PChar; minSize: Integer): TBlock; +// Get at least minSize bytes address space at addr. +// Return values as above. +// Failure: returns block with addr = nil. +begin + result.size := cSpaceMin; + result.addr := VirtualAlloc(addr, cSpaceMin, MEM_RESERVE, PAGE_READWRITE); + if result.addr = nil then begin + minSize := (minSize + (cSpaceAlign-1)) and not (cSpaceAlign-1); + result.size := minSize; + result.addr := VirtualAlloc(addr, minSize, MEM_RESERVE, PAGE_READWRITE); + end; + if result.addr <> nil then begin + if not AddBlockAfter(@spaceRoot, result) then begin + VirtualFree(result.addr, 0, MEM_RELEASE); + result.addr := nil; + end; + end; +end; + + +function FreeSpace(addr: Pointer; maxSize: Integer): TBlock; +// Free at most maxSize bytes of address space at addr. +// Returns the block that was actually freed. +var + bd, bdNext: PBlockDesc; + minAddr, maxAddr, startAddr, endAddr: PChar; +begin + minAddr := PChar($FFFFFFFF); + maxAddr := nil; + startAddr := addr; + endAddr := startAddr + maxSize; + bd := spaceRoot.next; + while bd <> @spaceRoot do begin + bdNext := bd.next; + if (bd.addr >= startAddr) and (bd.addr + bd.size <= endAddr) then begin + if minAddr > bd.addr then + minAddr := bd.addr; + if maxAddr < bd.addr + bd.size then + maxAddr := bd.addr + bd.size; + if not VirtualFree(bd.addr, 0, MEM_RELEASE) then + heapErrorCode := cReleaseErr; + DeleteBlock(bd); + end; + bd := bdNext; + end; + result.addr := nil; + if maxAddr <> nil then begin + result.addr := minAddr; + result.size := maxAddr - minAddr; + end; +end; + + +function Commit(addr: Pointer; minSize: Integer): TBlock; +// Commits memory. +// Returns the block that was actually committed. +// Will return a block with addr = nil on failure. +var + bd: PBlockDesc; + loAddr, hiAddr, startAddr, endAddr: PChar; +begin + startAddr := PChar(Integer(addr) and not (cPageAlign-1)); + endAddr := PChar(((Integer(addr) + minSize) + (cPageAlign-1)) and not (cPageAlign-1)); + result.addr := startAddr; + result.size := endAddr - startAddr; + bd := spaceRoot.next; + while bd <> @spaceRoot do begin + // Commit the intersection of the block described by bd and [startAddr..endAddr) + loAddr := bd.addr; + hiAddr := loAddr + bd.size; + if loAddr < startAddr then + loAddr := startAddr; + if hiAddr > endAddr then + hiAddr := endAddr; + if loAddr < hiAddr then begin + if VirtualAlloc(loAddr, hiAddr - loAddr, MEM_COMMIT, PAGE_READWRITE) = nil then begin + result.addr := nil; + exit; + end; + end; + bd := bd.next; + end; +end; + + +function Decommit(addr: Pointer; maxSize: Integer): TBlock; +// Decommits address space. +// Returns the block that was actually decommitted. +var + bd: PBlockDesc; + loAddr, hiAddr, startAddr, endAddr: PChar; +begin + startAddr := PChar((Integer(addr) + + (cPageAlign-1)) and not (cPageAlign-1)); + endAddr := PChar((Integer(addr) + maxSize) and not (cPageAlign-1)); + result.addr := startAddr; + result.size := endAddr - startAddr; + bd := spaceRoot.next; + while bd <> @spaceRoot do begin + // Decommit the intersection of the block described by bd and [startAddr..endAddr) + loAddr := bd.addr; + hiAddr := loAddr + bd.size; + if loAddr < startAddr then + loAddr := startAddr; + if hiAddr > endAddr then + hiAddr := endAddr; + if loAddr < hiAddr then begin + if not VirtualFree(loAddr, hiAddr - loAddr, MEM_DECOMMIT) then + heapErrorCode := cDecommitErr; + end; + bd := bd.next; + end; +end; + + +// +// Committed space administration +// +const + cCommitAlign = 16*1024; + +var + decommittedRoot: TBlockDesc; + + +function GetCommitted(minSize: Integer): TBlock; +// Get a block of committed memory. +// Returns a committed memory block, possibly much bigger than requested. +// Will return a block with a nil addr on failure. +var + bd: PBlockDesc; +begin + minSize := (minSize + (cCommitAlign-1)) and not (cCommitAlign-1); + repeat + bd := decommittedRoot.next; + while bd <> @decommittedRoot do begin + if bd.size >= minSize then begin + result := Commit(bd.addr, minSize); + if result.addr = nil then + exit; + Inc(bd.addr, result.size); + Dec(bd.size, result.size); + if bd.size = 0 then + DeleteBlock(bd); + exit; + end; + bd := bd.next; + end; + result := GetSpace(minSize); + if result.addr = nil then + exit; + if MergeBlockAfter(@decommittedRoot, result).addr = nil then begin + FreeSpace(result.addr, result.size); + result.addr := nil; + exit; + end; + until False; +end; + + +function GetCommittedAt(addr: PChar; minSize: Integer): TBlock; +// Get at least minSize bytes committed space at addr. +// Success: returns a block, possibly much bigger than requested. +// Failure: returns a block with addr = nil. +var + bd: PBlockDesc; + b: TBlock; +begin + minSize := (minSize + (cCommitAlign-1)) and not (cCommitAlign-1); + repeat + + bd := decommittedRoot.next; + while (bd <> @decommittedRoot) and (bd.addr <> addr) do + bd := bd.next; + + if bd.addr = addr then begin + if bd.size >= minSize then + break; + b := GetSpaceAt(bd.addr + bd.size, minSize - bd.size); + if b.addr <> nil then begin + if MergeBlockAfter(@decommittedRoot, b).addr <> nil then + continue + else begin + FreeSpace(b.addr, b.size); + result.addr := nil; + exit; + end; + end; + end; + + b := GetSpaceAt(addr, minSize); + if b.addr = nil then + break; + + if MergeBlockAfter(@decommittedRoot, b).addr = nil then begin + FreeSpace(b.addr, b.size); + result.addr := nil; + exit; + end; + until false; + + if (bd.addr = addr) and (bd.size >= minSize) then begin + result := Commit(bd.addr, minSize); + if result.addr = nil then + exit; + Inc(bd.addr, result.size); + Dec(bd.size, result.size); + if bd.size = 0 then + DeleteBlock(bd); + end else + result.addr := nil; +end; + + +function FreeCommitted(addr: PChar; maxSize: Integer): TBlock; +// Free at most maxSize bytes of address space at addr. +// Returns the block that was actually freed. +var + startAddr, endAddr: PChar; + b: TBlock; +begin + startAddr := PChar(Integer(addr + (cCommitAlign-1)) and not (cCommitAlign-1)); + endAddr := PChar(Integer(addr + maxSize) and not (cCommitAlign-1)); + if endAddr > startAddr then begin + result := Decommit(startAddr, endAddr - startAddr); + b := MergeBlockAfter(@decommittedRoot, result); + if b.addr <> nil then + b := FreeSpace(b.addr, b.size); + if b.addr <> nil then + RemoveBlock(@decommittedRoot, b); + end else + result.addr := nil; +end; + + +// +// Suballocator (what the user program actually calls) +// + +type + PFree = ^TFree; + TFree = packed record + prev: PFree; + next: PFree; + size: Integer; + end; + PUsed = ^TUsed; + TUsed = packed record + sizeFlags: Integer; + end; + +const + cAlign = 4; + cThisUsedFlag = 2; + cPrevFreeFlag = 1; + cFillerFlag = Integer($80000000); + cFlags = cThisUsedFlag or cPrevFreeFlag or cFillerFlag; + cSmallSize = 4*1024; + cDecommitMin = 15*1024; + +type + TSmallTab = array [sizeof(TFree) div cAlign .. cSmallSize div cAlign] of PFree; + +VAR + avail : TFree; + rover : PFree; + remBytes : Integer; + curAlloc : PChar; + smallTab : ^TSmallTab; + committedRoot: TBlockDesc; + + +{X} // UninitAllocator - placed before InitAllocator to refer to. +procedure UninitAllocator; +// Shutdown. +var + bdb: PBlockDescBlock; + bd : PBlockDesc; +begin + if initialized then begin + try + if IsMultiThread then EnterCriticalSection(heapLock); + + initialized := False; + + LocalFree(smallTab); + smallTab := nil; + + bd := spaceRoot.next; + while bd <> @spaceRoot do begin + VirtualFree(bd.addr, 0, MEM_RELEASE); + bd := bd.next; + end; + + MakeEmpty(@spaceRoot); + MakeEmpty(@decommittedRoot); + MakeEmpty(@committedRoot); + + bdb := blockDescBlockList; + while bdb <> nil do begin + blockDescBlockList := bdb^.next; + LocalFree(bdb); + bdb := blockDescBlockList; + end; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + DeleteCriticalSection(heapLock); + end; + end; +end; + +function InitAllocator: Boolean; +// Initialize. No other calls legal before that. +var + i: Integer; + a: PFree; +begin + try + InitializeCriticalSection(heapLock); + if IsMultiThread then EnterCriticalSection(heapLock); + + MakeEmpty(@spaceRoot); + MakeEmpty(@decommittedRoot); + MakeEmpty(@committedRoot); + + smallTab := LocalAlloc(LMEM_FIXED, sizeof(smallTab^)); + if smallTab <> nil then begin + for i:= low(smallTab^) to high(smallTab^) do + smallTab[i] := nil; + + a := @avail; + a.next := a; + a.prev := a; + rover := a; + + initialized := True; + {X} // set here handler UninitMemoryManager to UninitAllocator } + {X} UninitMemoryManager := UninitAllocator; + end; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; + result := initialized; +end; + + + +procedure DeleteFree(f: PFree); +var + n, p: PFree; + size: Integer; +begin + if rover = f then + rover := f.next; + n := f.next; + size := f.size; + if size <= cSmallSize then begin + if n = f then + smallTab[size div cAlign] := nil + else begin + smallTab[size div cAlign] := n; + p := f.prev; + n.prev := p; + p.next := n; + end; + end else begin + p := f.prev; + n.prev := p; + p.next := n; + end; +end; + + +procedure InsertFree(a: Pointer; size: Integer); forward; + + +function FindCommitted(addr: PChar): PBlockDesc; +begin + result := committedRoot.next; + while result <> @committedRoot do begin + if (addr >= result.addr) and (addr < result.addr + result.size) then + exit; + result := result.next; + end; + heapErrorCode := cBadCommittedList; + result := nil; +end; + + +procedure FillBeforeGap(a: PChar; size: Integer); +var + rest: Integer; + e: PUsed; +begin + rest := size - sizeof(TUsed); + e := PUsed(a + rest); + if size >= sizeof(TFree) + sizeof(TUsed) then begin + e.sizeFlags := sizeof(TUsed) or cThisUsedFlag or cPrevFreeFlag or cFillerFlag; + InsertFree(a, rest); + end else if size >= sizeof(TUsed) then begin + PUsed(a).sizeFlags := size or (cThisUsedFlag or cFillerFlag); + e.sizeFlags := size or (cThisUsedFlag or cFillerFlag); + end; +end; + + +procedure InternalFreeMem(a: PChar); +begin + Inc(AllocMemCount); + Inc(AllocMemSize,PUsed(a-sizeof(TUsed)).sizeFlags and not cFlags - sizeof(TUsed)); + SysFreeMem(a); +end; + + +procedure FillAfterGap(a: PChar; size: Integer); +begin + if size >= sizeof(TFree) then begin + PUsed(a).sizeFlags := size or cThisUsedFlag; + InternalFreeMem(a + sizeof(TUsed)); + end else begin + if size >= sizeof(TUsed) then + PUsed(a).sizeFlags := size or (cThisUsedFlag or cFillerFlag); + Inc(a,size); + PUsed(a).sizeFlags := PUsed(a).sizeFlags and not cPrevFreeFlag; + end; +end; + + +function FillerSizeBeforeGap(a: PChar): Integer; +var + sizeFlags : Integer; + freeSize : Integer; + f : PFree; +begin + sizeFlags := PUsed(a - sizeof(TUsed)).sizeFlags; + if (sizeFlags and (cThisUsedFlag or cFillerFlag)) <> (cThisUsedFlag or cFillerFlag) then + heapErrorCode := cBadFiller1; + result := sizeFlags and not cFlags; + Dec(a, result); + if ((PUsed(a).sizeFlags xor sizeFlags) and not cPrevFreeFlag) <> 0 then + HeapErrorCode := cBadFiller2; + if (PUsed(a).sizeFlags and cPrevFreeFlag) <> 0 then begin + freeSize := PFree(a - sizeof(TFree)).size; + f := PFree(a - freeSize); + if f.size <> freeSize then + heapErrorCode := cBadFiller3; + DeleteFree(f); + Inc(result, freeSize); + end; +end; + + +function FillerSizeAfterGap(a: PChar): Integer; +var + sizeFlags: Integer; + f : PFree; +begin + result := 0; + sizeFlags := PUsed(a).sizeFlags; + if (sizeFlags and cFillerFlag) <> 0 then begin + sizeFlags := sizeFlags and not cFlags; + Inc(result,sizeFlags); + Inc(a, sizeFlags); + sizeFlags := PUsed(a).sizeFlags; + end; + if (sizeFlags and cThisUsedFlag) = 0 then begin + f := PFree(a); + DeleteFree(f); + Inc(result, f.size); + Inc(a, f.size); + PUsed(a).sizeFlags := PUsed(a).sizeFlags and not cPrevFreeFlag; + end; +end; + + +function DecommitFree(a: PChar; size: Integer): Boolean; +var + b: TBlock; + bd: PBlockDesc; +begin + Result := False; + bd := FindCommitted(a); + if bd = nil then Exit; + if bd.addr + bd.size - (a + size) <= sizeof(TFree) then + size := bd.addr + bd.size - a; + + if a - bd.addr < sizeof(TFree) then + b := FreeCommitted(bd.addr, size + (a - bd.addr)) + else + b := FreeCommitted(a + sizeof(TUsed), size - sizeof(TUsed)); + + if b.addr <> nil then + begin + FillBeforeGap(a, b.addr - a); + if bd.addr + bd.size > b.addr + b.size then + FillAfterGap(b.addr + b.size, a + size - (b.addr + b.size)); + RemoveBlock(bd,b); + result := True; + end; +end; + + +procedure InsertFree(a: Pointer; size: Integer); +var + f, n, p: PFree; +begin + f := PFree(a); + f.size := size; + PFree(PChar(f) + size - sizeof(TFree)).size := size; + if size <= cSmallSize then begin + n := smallTab[size div cAlign]; + if n = nil then begin + smallTab[size div cAlign] := f; + f.next := f; + f.prev := f; + end else begin + p := n.prev; + f.next := n; + f.prev := p; + n.prev := f; + p.next := f; + end; + end else if (size < cDecommitMin) or not DecommitFree(a, size) then begin + n := rover; + rover := f; + p := n.prev; + f.next := n; + f.prev := p; + n.prev := f; + p.next := f; + end; +end; + + +procedure FreeCurAlloc; +begin + if remBytes > 0 then begin + if remBytes < sizeof(TFree) then + heapErrorCode := cBadCurAlloc + else begin + PUsed(curAlloc).sizeFlags := remBytes or cThisUsedFlag; + InternalFreeMem(curAlloc + sizeof(TUsed)); + curAlloc := nil; + remBytes := 0; + end; + end; +end; + + +function MergeCommit(b: TBlock): Boolean; +var + merged: TBlock; + fSize: Integer; +begin + FreeCurAlloc; + merged := MergeBlockAfter(@committedRoot, b); + if merged.addr = nil then begin + result := False; + exit; + end; + + if merged.addr < b.addr then begin + fSize := FillerSizeBeforeGap(b.addr); + Dec(b.addr, fSize); + Inc(b.size, fSize); + end; + + if merged.addr + merged.size > b.addr + b.size then begin + fSize := FillerSizeAfterGap(b.addr + b.size); + Inc(b.size, fSize); + end; + + if merged.addr + merged.size = b.addr + b.size then begin + FillBeforeGap(b.addr + b.size - sizeof(TUsed), sizeof(TUsed)); + Dec(b.size, sizeof(TUsed)); + end; + + curAlloc := b.addr; + remBytes := b.size; + + result := True; +end; + + +function NewCommit(minSize: Integer): Boolean; +var + b: TBlock; +begin + b := GetCommitted(minSize+sizeof(TUsed)); + result := (b.addr <> nil) and MergeCommit(b); +end; + + +function NewCommitAt(addr: Pointer; minSize: Integer): Boolean; +var + b: TBlock; +begin + b := GetCommittedAt(addr, minSize+sizeof(TUsed)); + result := (b.addr <> nil) and MergeCommit(b); +end; + + +function SearchSmallBlocks(size: Integer): PFree; +var + i: Integer; +begin + result := nil; + for i := size div cAlign to High(smallTab^) do begin + result := smallTab[i]; + if result <> nil then + exit; + end; +end; + + +function TryHarder(size: Integer): Pointer; +var + u: PUsed; f:PFree; saveSize, rest: Integer; +begin + + repeat + + f := avail.next; + if (size <= f.size) then + break; + + f := rover; + if f.size >= size then + break; + + saveSize := f.size; + f.size := size; + repeat + f := f.next + until f.size >= size; + rover.size := saveSize; + if f <> rover then begin + rover := f; + break; + end; + + if size <= cSmallSize then begin + f := SearchSmallBlocks(size); + if f <> nil then + break; + end; + + if not NewCommit(size) then begin + result := nil; + exit; + end; + + if remBytes >= size then begin + Dec(remBytes, size); + if remBytes < sizeof(TFree) then begin + Inc(size, remBytes); + remBytes := 0; + end; + u := PUsed(curAlloc); + Inc(curAlloc, size); + u.sizeFlags := size or cThisUsedFlag; + result := PChar(u) + sizeof(TUsed); + Inc(AllocMemCount); + Inc(AllocMemSize,size - sizeof(TUsed)); + exit; + end; + + until False; + + DeleteFree(f); + + rest := f.size - size; + if rest >= sizeof(TFree) then begin + InsertFree(PChar(f) + size, rest); + end else begin + size := f.size; + if f = rover then + rover := f.next; + u := PUsed(PChar(f) + size); + u.sizeFlags := u.sizeFlags and not cPrevFreeFlag; + end; + + u := PUsed(f); + u.sizeFlags := size or cThisUsedFlag; + + result := PChar(u) + sizeof(TUsed); + Inc(AllocMemCount); + Inc(AllocMemSize,size - sizeof(TUsed)); + +end; + + +function SysGetMem(size: Integer): Pointer; +// Allocate memory block. +var + f, prev, next: PFree; + u: PUsed; +begin + + if (not initialized and not InitAllocator) or + (size > (High(size) - (sizeof(TUsed) + (cAlign-1)))) then + begin + result := nil; + exit; + end; + + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + Inc(size, sizeof(TUsed) + (cAlign-1)); + size := size and not (cAlign-1); + if size < sizeof(TFree) then + size := sizeof(TFree); + + if size <= cSmallSize then begin + f := smallTab[size div cAlign]; + if f <> nil then begin + u := PUsed(PChar(f) + size); + u.sizeFlags := u.sizeFlags and not cPrevFreeFlag; + next := f.next; + if next = f then + smallTab[size div cAlign] := nil + else begin + smallTab[size div cAlign] := next; + prev := f.prev; + prev.next := next; + next.prev := prev; + end; + u := PUsed(f); + u.sizeFlags := f.size or cThisUsedFlag; + result := PChar(u) + sizeof(TUsed); + Inc(AllocMemCount); + Inc(AllocMemSize,size - sizeof(TUsed)); + exit; + end; + end; + + if size <= remBytes then begin + Dec(remBytes, size); + if remBytes < sizeof(TFree) then begin + Inc(size, remBytes); + remBytes := 0; + end; + u := PUsed(curAlloc); + Inc(curAlloc, size); + u.sizeFlags := size or cThisUsedFlag; + result := PChar(u) + sizeof(TUsed); + Inc(AllocMemCount); + Inc(AllocMemSize,size - sizeof(TUsed)); + exit; + end; + + result := TryHarder(size); + + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; + +end; + + +function SysFreeMem(p: Pointer): Integer; +// Deallocate memory block. +label + abort; +var + u, n : PUsed; + f : PFree; + prevSize, nextSize, size : Integer; +begin + heapErrorCode := cHeapOk; + + if not initialized and not InitAllocator then begin + heapErrorCode := cCantInit; + result := cCantInit; + exit; + end; + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + u := p; + u := PUsed(PChar(u) - sizeof(TUsed)); { inv: u = address of allocated block being freed } + size := u.sizeFlags; + { inv: size = SET(block size) + [block flags] } + + { validate that the interpretation of this block as a used block is correct } + if (size and cThisUsedFlag) = 0 then begin + heapErrorCode := cBadUsedBlock; + goto abort; + end; + + { inv: the memory block addressed by 'u' and 'p' is an allocated block } + + Dec(AllocMemCount); + Dec(AllocMemSize,size and not cFlags - sizeof(TUsed)); + + if (size and cPrevFreeFlag) <> 0 then begin + { previous block is free, coalesce } + prevSize := PFree(PChar(u)-sizeof(TFree)).size; + if (prevSize < sizeof(TFree)) or ((prevSize and cFlags) <> 0) then begin + heapErrorCode := cBadPrevBlock; + goto abort; + end; + + f := PFree(PChar(u) - prevSize); + if f^.size <> prevSize then begin + heapErrorCode := cBadPrevBlock; + goto abort; + end; + + inc(size, prevSize); + u := PUsed(f); + DeleteFree(f); + end; + + size := size and not cFlags; + { inv: size = block size } + + n := PUsed(PChar(u) + size); + { inv: n = block following the block to free } + + if PChar(n) = curAlloc then begin + { inv: u = last block allocated } + dec(curAlloc, size); + inc(remBytes, size); + if remBytes > cDecommitMin then + FreeCurAlloc; + result := cHeapOk; + exit; + end; + + if (n.sizeFlags and cThisUsedFlag) <> 0 then begin + { inv: n is a used block } + if (n.sizeFlags and not cFlags) < sizeof(TUsed) then begin + heapErrorCode := cBadNextBlock; + goto abort; + end; + n.sizeFlags := n.sizeFlags or cPrevFreeFlag + end else begin + { inv: block u & n are both free; coalesce } + f := PFree(n); + if (f.next = nil) or (f.prev = nil) or (f.size < sizeof(TFree)) then begin + heapErrorCode := cBadNextBlock; + goto abort; + end; + nextSize := f.size; + inc(size, nextSize); + DeleteFree(f); + { inv: last block (which was free) is not on free list } + end; + + InsertFree(u, size); +abort: + result := heapErrorCode; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; +end; + + +function ResizeInPlace(p: Pointer; newSize: Integer): Boolean; +var u, n: PUsed; f: PFree; oldSize, blkSize, neededSize: Integer; +begin + Inc(newSize, sizeof(TUsed)+cAlign-1); + newSize := newSize and not (cAlign-1); + if newSize < sizeof(TFree) then + newSize := sizeof(TFree); + u := PUsed(PChar(p) - sizeof(TUsed)); + oldSize := u.sizeFlags and not cFlags; + n := PUsed( PChar(u) + oldSize ); + if newSize <= oldSize then begin + blkSize := oldSize - newSize; + if PChar(n) = curAlloc then begin + Dec(curAlloc, blkSize); + Inc(remBytes, blkSize); + if remBytes < sizeof(TFree) then begin + Inc(curAlloc, blkSize); + Dec(remBytes, blkSize); + newSize := oldSize; + end; + end else begin + n := PUsed(PChar(u) + oldSize); + if n.sizeFlags and cThisUsedFlag = 0 then begin + f := PFree(n); + Inc(blkSize, f.size); + DeleteFree(f); + end; + if blkSize >= sizeof(TFree) then begin + n := PUsed(PChar(u) + newSize); + n.sizeFlags := blkSize or cThisUsedFlag; + InternalFreeMem(PChar(n) + sizeof(TUsed)); + end else + newSize := oldSize; + end; + end else begin + repeat + neededSize := newSize - oldSize; + if PChar(n) = curAlloc then begin + if remBytes >= neededSize then begin + Dec(remBytes, neededSize); + Inc(curAlloc, neededSize); + if remBytes < sizeof(TFree) then begin + Inc(curAlloc, remBytes); + Inc(newSize, remBytes); + remBytes := 0; + end; + Inc(AllocMemSize, newSize - oldSize); + u.sizeFlags := newSize or u.sizeFlags and cFlags; + result := true; + exit; + end else begin + FreeCurAlloc; + n := PUsed( PChar(u) + oldSize ); + end; + end; + + if n.sizeFlags and cThisUsedFlag = 0 then begin + f := PFree(n); + blkSize := f.size; + if blkSize < neededSize then begin + n := PUsed(PChar(n) + blkSize); + Dec(neededSize, blkSize); + end else begin + DeleteFree(f); + Dec(blkSize, neededSize); + if blkSize >= sizeof(TFree) then + InsertFree(PChar(u) + newSize, blkSize) + else begin + Inc(newSize, blkSize); + n := PUsed(PChar(u) + newSize); + n.sizeFlags := n.sizeFlags and not cPrevFreeFlag; + end; + break; + end; + end; + + if n.sizeFlags and cFillerFlag <> 0 then begin + n := PUsed(PChar(n) + n.sizeFlags and not cFlags); + if NewCommitAt(n, neededSize) then begin + n := PUsed( PChar(u) + oldSize ); + continue; + end; + end; + + result := False; + exit; + + until False; + + end; + + Inc(AllocMemSize, newSize - oldSize); + u.sizeFlags := newSize or u.sizeFlags and cFlags; + result := True; + +end; + + +function SysReallocMem(p: Pointer; size: Integer): Pointer; +// Resize memory block. +var + n: Pointer; oldSize: Integer; +begin + + if not initialized and not InitAllocator then begin + result := nil; + exit; + end; + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + if ResizeInPlace(p, size) then + result := p + else begin + n := SysGetMem(size); + oldSize := (PUsed(PChar(p)-sizeof(PUsed)).sizeFlags and not cFlags) - sizeof(TUsed); + if oldSize > size then + oldSize := size; + if n <> nil then begin + Move(p^, n^, oldSize); + SysFreeMem(p); + end; + result := n; + end; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; + +end; + + +function BlockSum(root: PBlockDesc): Integer; +var + b : PBlockDesc; +begin + result := 0; + b := root.next; + while b <> root do begin + Inc(result, b.size); + b := b.next; + end; +end; + + +function GetHeapStatus: THeapStatus; +var + size, freeSize, userSize: Cardinal; + f: PFree; + a, e: PChar; + i: Integer; + b: PBlockDesc; + prevFree: Boolean; +begin + + result.TotalAddrSpace := 0; + result.TotalUncommitted := 0; + result.TotalCommitted := 0; + result.TotalAllocated := 0; + result.TotalFree := 0; + result.FreeSmall := 0; + result.FreeBig := 0; + result.Unused := 0; + result.Overhead := 0; + result.HeapErrorCode := cHeapOk; + + if not initialized then exit; + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + result.totalAddrSpace := BlockSum(@spaceRoot); + result.totalUncommitted := BlockSum(@decommittedRoot); + result.totalCommitted := BlockSum(@committedRoot); + + size := 0; + for i := Low(smallTab^) to High(smallTab^) do begin + f := smallTab[i]; + if f <> nil then begin + repeat + Inc(size, f.size); + if (f.prev.next <> f) or (f.next.prev <> f) or (f.size < sizeof(TFree)) then begin + heapErrorCode := cBadFreeList; + break; + end; + f := f.next; + until f = smallTab[i]; + end; + end; + result.freeSmall := size; + + size := 0; + f := avail.next; + while f <> @avail do begin + if (f.prev.next <> f) or (f.next.prev <> f) or (f.size < sizeof(TFree)) then begin + heapErrorCode := cBadFreeList; + break; + end; + Inc(size, f.size); + f := f.next; + end; + result.freeBig := size; + + result.unused := remBytes; + result.totalFree := result.freeSmall + result.freeBig + result.unused; + + freeSize := 0; + userSize := 0; + result.overhead := 0; + + b := committedRoot.next; + prevFree := False; + while b <> @committedRoot do begin + a := b.addr; + e := a + b.size; + while a < e do begin + if (a = curAlloc) and (remBytes > 0) then begin + size := remBytes; + Inc(freeSize, size); + if prevFree then + heapErrorCode := cBadCurAlloc; + prevFree := False; + end else begin + if prevFree <> ((PUsed(a).sizeFlags and cPrevFreeFlag) <> 0) then + heapErrorCode := cBadNextBlock; + if (PUsed(a).sizeFlags and cThisUsedFlag) = 0 then begin + f := PFree(a); + if (f.prev.next <> f) or (f.next.prev <> f) or (f.size < sizeof(TFree)) then + heapErrorCode := cBadFreeBlock; + size := f.size; + Inc(freeSize, size); + prevFree := True; + end else begin + size := PUsed(a).sizeFlags and not cFlags; + if (PUsed(a).sizeFlags and cFillerFlag) <> 0 then begin + Inc(result.overhead, size); + if (a > b.addr) and (a + size < e) then + heapErrorCode := cBadUsedBlock; + end else begin + Inc(userSize, size-sizeof(TUsed)); + Inc(result.overhead, sizeof(TUsed)); + end; + prevFree := False; + end; + end; + Inc(a, size); + end; + b := b.next; + end; + if result.totalFree <> freeSize then + heapErrorCode := cBadBalance; + + result.totalAllocated := userSize; + result.heapErrorCode := heapErrorCode; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; +end; + + +// this section goes into GetMem.Inc + +{$IFDEF DEBUG_FUNCTIONS} +type + THeapReportProc = procedure(HeapBlock: Pointer; AllocatedSize: Integer) of object; + + +procedure WalkHeap(HeapReportProc: THeapReportProc); +var + size : Cardinal; + f: PFree; + a, e: PChar; + b: PBlockDesc; +begin + + if not initialized then exit; + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + b := committedRoot.next; + while b <> @committedRoot do begin + a := b.addr; + e := a + b.size; + while a < e do begin + if (a = curAlloc) and (remBytes > 0) then begin + size := remBytes; + end else begin + if (PUsed(a).sizeFlags and cThisUsedFlag) = 0 then begin + f := PFree(a); + size := f.size; + end else begin + size := PUsed(a).sizeFlags and not cFlags; + if (PUsed(a).sizeFlags and cFillerFlag) = 0 then begin + HeapReportProc(a + sizeof(TUsed), size - sizeof(TUsed)); + end; + end; + end; + Inc(a, size); + end; + b := b.next; + end; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; +end; + +type + THeapBlockCollector = class(TObject) + FCount: Integer; + FObjectTable: TObjectArray; + FHeapBlockTable: THeapBlockArray; + FClass: TClass; + FFindDerived: Boolean; + procedure CollectBlocks(HeapBlock: Pointer; AllocatedSize: Integer); + procedure CollectObjects(HeapBlock: Pointer; AllocatedSize: Integer); + end; + + +procedure THeapBlockCollector.CollectBlocks(HeapBlock: Pointer; AllocatedSize: Integer); +begin + if FCount < Length(FHeapBlockTable) then + begin + FHeapBlockTable[FCount].Start := HeapBlock; + FHeapBlockTable[FCount].Size := AllocatedSize; + end; + Inc(FCount); +end; + + +procedure THeapBlockCollector.CollectObjects(HeapBlock: Pointer; AllocatedSize: Integer); +var + AObject: TObject; + AClass: TClass; +type + PPointer = ^Pointer; +begin + try + if AllocatedSize < 4 then + Exit; + AObject := TObject(HeapBlock); + AClass := AObject.ClassType; + if (AClass = FClass) + or (FFindDerived + and (Integer(AClass) >= 64*1024) + and (PPointer(PChar(AClass) + vmtSelfPtr)^ = Pointer(AClass)) + and (AObject is FClass)) then + begin + if FCount < Length(FObjectTable) then + FObjectTable[FCount] := AObject; + Inc(FCount); + end; + except + // Let's not worry about this block - it's obviously not a valid object + end; +end; + +var + HeapBlockCollector: THeapBlockCollector; + +function GetHeapBlocks: THeapBlockArray; +begin + if not Assigned(HeapBlockCollector) then + HeapBlockCollector := THeapBlockCollector.Create; + + Walkheap(HeapBlockCollector.CollectBlocks); + SetLength(HeapBlockCollector.FHeapBlockTable, HeapBlockCollector.FCount); + HeapBlockCollector.FCount := 0; + Walkheap(HeapBlockCollector.CollectBlocks); + Result := HeapBlockCollector.FHeapBlockTable; + HeapBlockCollector.FCount := 0; + HeapBlockCollector.FHeapBlockTable := nil; +end; + + +function FindObjects(AClass: TClass; FindDerived: Boolean): TObjectArray; +begin + if not Assigned(HeapBlockCollector) then + HeapBlockCollector := THeapBlockCollector.Create; + HeapBlockCollector.FClass := AClass; + HeapBlockCollector.FFindDerived := FindDerived; + + Walkheap(HeapBlockCollector.CollectObjects); + SetLength(HeapBlockCollector.FObjectTable, HeapBlockCollector.FCount); + HeapBlockCollector.FCount := 0; + Walkheap(HeapBlockCollector.CollectObjects); + Result := HeapBlockCollector.FObjectTable; + HeapBlockCollector.FCount := 0; + HeapBlockCollector.FObjectTable := nil; +end; +{$ENDIF} + + diff --git a/System/D5/SysSfIni.pas b/System/D5/SysSfIni.pas new file mode 100644 index 0000000..c3a5465 --- /dev/null +++ b/System/D5/SysSfIni.pas @@ -0,0 +1,22 @@ +unit SysSfIni; +{X: this unit must be referenced in uses clause of dpr as earlier as possible, + if You want to use try-execpt/raise protected initialization and finalization + for your units. } + +{$O+,H+,I-,S-} + +interface + +implementation + +initialization + + InitUnitsProc := InitUnitsHard; + FInitUnitsProc := FInitUnitsHard; + UnregisterModule := UnregisterModuleSafely; + UnsetExceptionHandlerProc := UnsetExceptionHandler; + SetExceptionHandler; + +finalization + +end. diff --git a/System/D5/getmem.inc b/System/D5/getmem.inc new file mode 100644 index 0000000..eead1f2 --- /dev/null +++ b/System/D5/getmem.inc @@ -0,0 +1,1568 @@ +// Three layers: // XCL version of GetMem.inc +// - Address space administration // unit. Created Jun-2000 +// - Committed space administration // (C) by Kladov Vladimir +// - Suballocator // +// // purpose: make XCL Delphi +// Helper module: administrating block descriptors // programs even smaller. +// // + // Changes are marked as {X} + +// +// Operating system interface +// +const + LMEM_FIXED = 0; + LMEM_ZEROINIT = $40; + + MEM_COMMIT = $1000; + MEM_RESERVE = $2000; + MEM_DECOMMIT = $4000; + MEM_RELEASE = $8000; + + PAGE_NOACCESS = 1; + PAGE_READWRITE = 4; + +type + DWORD = Integer; + BOOL = LongBool; + + TRTLCriticalSection = packed record + DebugInfo: Pointer; + LockCount: Longint; + RecursionCount: Longint; + OwningThread: Integer; + LockSemaphore: Integer; + Reserved: DWORD; + end; + +{X} //function LocalAlloc(flags, size: Integer): Pointer; stdcall; +{X} // external kernel name 'LocalAlloc'; +{X} //function LocalFree(addr: Pointer): Pointer; stdcall; +{X} // external kernel name 'LocalFree'; + +function VirtualAlloc(lpAddress: Pointer; + dwSize, flAllocationType, flProtect: DWORD): Pointer; stdcall; + external kernel name 'VirtualAlloc'; +function VirtualFree(lpAddress: Pointer; dwSize, dwFreeType: DWORD): BOOL; stdcall; + external kernel name 'VirtualFree'; + +procedure InitializeCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall; + external kernel name 'InitializeCriticalSection'; +procedure EnterCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall; + external kernel name 'EnterCriticalSection'; +procedure LeaveCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall; + external kernel name 'LeaveCriticalSection'; +procedure DeleteCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall; + external kernel name 'DeleteCriticalSection'; + +// Common Data structure: + +type + TBlock = packed record + addr: PChar; + size: Integer; + end; + +// Heap error codes + +const + cHeapOk = 0; // everything's fine + cReleaseErr = 1; // operating system returned an error when we released + cDecommitErr = 2; // operating system returned an error when we decommited + cBadCommittedList = 3; // list of committed blocks looks bad + cBadFiller1 = 4; // filler block is bad + cBadFiller2 = 5; // filler block is bad + cBadFiller3 = 6; // filler block is bad + cBadCurAlloc = 7; // current allocation zone is bad + cCantInit = 8; // couldn't initialize + cBadUsedBlock = 9; // used block looks bad + cBadPrevBlock = 10; // prev block before a used block is bad + cBadNextBlock = 11; // next block after a used block is bad + cBadFreeList = 12; // free list is bad + cBadFreeBlock = 13; // free block is bad + cBadBalance = 14; // free list doesn't correspond to blocks marked free + +var + initialized : Boolean; + heapErrorCode : Integer; + heapLock : TRTLCriticalSection; + {X} // Handler to set it to UninitAllocator, if Delphi memory manager used: + {X} UninitMemoryManager : procedure = DummyProc; + +// +// Helper module: administrating block descriptors. +// +type + PBlockDesc = ^TBlockDesc; + TBlockDesc = packed record + next: PBlockDesc; + prev: PBlockDesc; + addr: PChar; + size: Integer; + end; + +type + PBlockDescBlock = ^TBlockDescBlock; + TBlockDescBlock = packed record + next: PBlockDescBlock; + data: array [0..99] of TBlockDesc; + end; + +var + blockDescBlockList: PBlockDescBlock; + blockDescFreeList : PBlockDesc; + + +function GetBlockDesc: PBlockDesc; +// Get a block descriptor. +// Will return nil for failure. +var + bd: PBlockDesc; + bdb: PBlockDescBlock; + i: Integer; +begin + if blockDescFreeList = nil then begin + bdb := LocalAlloc(LMEM_FIXED, sizeof(bdb^)); + if bdb = nil then begin + result := nil; + exit; + end; + bdb.next := blockDescBlockList; + blockDescBlockList := bdb; + for i := low(bdb.data) to high(bdb.data) do begin + bd := @bdb.data[i]; + bd.next := blockDescFreeList; + blockDescFreeList := bd; + end; + end; + bd := blockDescFreeList; + blockDescFreeList := bd.next; + result := bd; +end; + + +procedure MakeEmpty(bd: PBlockDesc); +begin + bd.next := bd; + bd.prev := bd; +end; + + +function AddBlockAfter(prev: PBlockDesc; const b: TBlock): Boolean; +var + next, bd: PBlockDesc; +begin + bd := GetBlockDesc; + if bd = nil then + result := False + else begin + bd.addr := b.addr; + bd.size := b.size; + + next := prev.next; + bd.next := next; + bd.prev := prev; + next.prev := bd; + prev.next := bd; + + result := True; + end; +end; + + +procedure DeleteBlock(bd: PBlockDesc); +var + prev, next: PBlockDesc; +begin + prev := bd.prev; + next := bd.next; + prev.next := next; + next.prev := prev; + bd.next := blockDescFreeList; + blockDescFreeList := bd; +end; + + +function MergeBlockAfter(prev: PBlockDesc; const b: TBlock) : TBlock; +var + bd, bdNext: PBlockDesc; +begin + bd := prev.next; + result := b; + repeat + bdNext := bd.next; + if bd.addr + bd.size = result.addr then begin + DeleteBlock(bd); + result.addr := bd.addr; + inc(result.size, bd.size); + end else if result.addr + result.size = bd.addr then begin + DeleteBlock(bd); + inc(result.size, bd.size); + end; + bd := bdNext; + until bd = prev; + if not AddBlockAfter(prev, result) then + result.addr := nil; +end; + + +function RemoveBlock(bd: PBlockDesc; const b: TBlock): Boolean; +var + n: TBlock; + start: PBlockDesc; +begin + start := bd; + repeat + if (bd.addr <= b.addr) and (bd.addr + bd.size >= b.addr + b.size) then begin + if bd.addr = b.addr then begin + Inc(bd.addr, b.size); + Dec(bd.size, b.size); + if bd.size = 0 then + DeleteBlock(bd); + end else if bd.addr + bd.size = b.addr + b.size then + Dec(bd.size, b.size) + else begin + n.addr := b.addr + b.size; + n.size := bd.addr + bd.size - n.addr; + bd.size := b.addr - bd.addr; + if not AddBlockAfter(bd, n) then begin + result := False; + exit; + end; + end; + result := True; + exit; + end; + bd := bd.next; + until bd = start; + result := False; +end; + + + +// +// Address space administration: +// + +const + cSpaceAlign = 64*1024; + cSpaceMin = 1024*1024; + cPageAlign = 4*1024; + +var + spaceRoot: TBlockDesc; + + +function GetSpace(minSize: Integer): TBlock; +// Get at least minSize bytes address space. +// Success: returns a block, possibly much bigger than requested. +// Will not fail - will raise an exception or terminate program. +begin + if minSize < cSpaceMin then + minSize := cSpaceMin + else + minSize := (minSize + (cSpaceAlign-1)) and not (cSpaceAlign-1); + + result.size := minSize; + result.addr := VirtualAlloc(nil, minSize, MEM_RESERVE, PAGE_NOACCESS); + if result.addr = nil then + exit; + + if not AddBlockAfter(@spaceRoot, result) then begin + VirtualFree(result.addr, 0, MEM_RELEASE); + result.addr := nil; + exit; + end; +end; + + +function GetSpaceAt(addr: PChar; minSize: Integer): TBlock; +// Get at least minSize bytes address space at addr. +// Return values as above. +// Failure: returns block with addr = nil. +begin + result.size := cSpaceMin; + result.addr := VirtualAlloc(addr, cSpaceMin, MEM_RESERVE, PAGE_READWRITE); + if result.addr = nil then begin + minSize := (minSize + (cSpaceAlign-1)) and not (cSpaceAlign-1); + result.size := minSize; + result.addr := VirtualAlloc(addr, minSize, MEM_RESERVE, PAGE_READWRITE); + end; + if result.addr <> nil then begin + if not AddBlockAfter(@spaceRoot, result) then begin + VirtualFree(result.addr, 0, MEM_RELEASE); + result.addr := nil; + end; + end; +end; + + +function FreeSpace(addr: Pointer; maxSize: Integer): TBlock; +// Free at most maxSize bytes of address space at addr. +// Returns the block that was actually freed. +var + bd, bdNext: PBlockDesc; + minAddr, maxAddr, startAddr, endAddr: PChar; +begin + minAddr := PChar($FFFFFFFF); + maxAddr := nil; + startAddr := addr; + endAddr := startAddr + maxSize; + bd := spaceRoot.next; + while bd <> @spaceRoot do begin + bdNext := bd.next; + if (bd.addr >= startAddr) and (bd.addr + bd.size <= endAddr) then begin + if minAddr > bd.addr then + minAddr := bd.addr; + if maxAddr < bd.addr + bd.size then + maxAddr := bd.addr + bd.size; + if not VirtualFree(bd.addr, 0, MEM_RELEASE) then + heapErrorCode := cReleaseErr; + DeleteBlock(bd); + end; + bd := bdNext; + end; + result.addr := nil; + if maxAddr <> nil then begin + result.addr := minAddr; + result.size := maxAddr - minAddr; + end; +end; + + +function Commit(addr: Pointer; minSize: Integer): TBlock; +// Commits memory. +// Returns the block that was actually committed. +// Will return a block with addr = nil on failure. +var + bd: PBlockDesc; + loAddr, hiAddr, startAddr, endAddr: PChar; +begin + startAddr := PChar(Integer(addr) and not (cPageAlign-1)); + endAddr := PChar(((Integer(addr) + minSize) + (cPageAlign-1)) and not (cPageAlign-1)); + result.addr := startAddr; + result.size := endAddr - startAddr; + bd := spaceRoot.next; + while bd <> @spaceRoot do begin + // Commit the intersection of the block described by bd and [startAddr..endAddr) + loAddr := bd.addr; + hiAddr := loAddr + bd.size; + if loAddr < startAddr then + loAddr := startAddr; + if hiAddr > endAddr then + hiAddr := endAddr; + if loAddr < hiAddr then begin + if VirtualAlloc(loAddr, hiAddr - loAddr, MEM_COMMIT, PAGE_READWRITE) = nil then begin + result.addr := nil; + exit; + end; + end; + bd := bd.next; + end; +end; + + +function Decommit(addr: Pointer; maxSize: Integer): TBlock; +// Decommits address space. +// Returns the block that was actually decommitted. +var + bd: PBlockDesc; + loAddr, hiAddr, startAddr, endAddr: PChar; +begin + startAddr := PChar((Integer(addr) + + (cPageAlign-1)) and not (cPageAlign-1)); + endAddr := PChar((Integer(addr) + maxSize) and not (cPageAlign-1)); + result.addr := startAddr; + result.size := endAddr - startAddr; + bd := spaceRoot.next; + while bd <> @spaceRoot do begin + // Decommit the intersection of the block described by bd and [startAddr..endAddr) + loAddr := bd.addr; + hiAddr := loAddr + bd.size; + if loAddr < startAddr then + loAddr := startAddr; + if hiAddr > endAddr then + hiAddr := endAddr; + if loAddr < hiAddr then begin + if not VirtualFree(loAddr, hiAddr - loAddr, MEM_DECOMMIT) then + heapErrorCode := cDecommitErr; + end; + bd := bd.next; + end; +end; + + +// +// Committed space administration +// +const + cCommitAlign = 16*1024; + +var + decommittedRoot: TBlockDesc; + + +function GetCommitted(minSize: Integer): TBlock; +// Get a block of committed memory. +// Returns a committed memory block, possibly much bigger than requested. +// Will return a block with a nil addr on failure. +var + bd: PBlockDesc; +begin + minSize := (minSize + (cCommitAlign-1)) and not (cCommitAlign-1); + repeat + bd := decommittedRoot.next; + while bd <> @decommittedRoot do begin + if bd.size >= minSize then begin + result := Commit(bd.addr, minSize); + if result.addr = nil then + exit; + Inc(bd.addr, result.size); + Dec(bd.size, result.size); + if bd.size = 0 then + DeleteBlock(bd); + exit; + end; + bd := bd.next; + end; + result := GetSpace(minSize); + if result.addr = nil then + exit; + if MergeBlockAfter(@decommittedRoot, result).addr = nil then begin + FreeSpace(result.addr, result.size); + result.addr := nil; + exit; + end; + until False; +end; + + +function GetCommittedAt(addr: PChar; minSize: Integer): TBlock; +// Get at least minSize bytes committed space at addr. +// Success: returns a block, possibly much bigger than requested. +// Failure: returns a block with addr = nil. +var + bd: PBlockDesc; + b: TBlock; +begin + minSize := (minSize + (cCommitAlign-1)) and not (cCommitAlign-1); + repeat + + bd := decommittedRoot.next; + while (bd <> @decommittedRoot) and (bd.addr <> addr) do + bd := bd.next; + + if bd.addr = addr then begin + if bd.size >= minSize then + break; + b := GetSpaceAt(bd.addr + bd.size, minSize - bd.size); + if b.addr <> nil then begin + if MergeBlockAfter(@decommittedRoot, b).addr <> nil then + continue + else begin + FreeSpace(b.addr, b.size); + result.addr := nil; + exit; + end; + end; + end; + + b := GetSpaceAt(addr, minSize); + if b.addr = nil then + break; + + if MergeBlockAfter(@decommittedRoot, b).addr = nil then begin + FreeSpace(b.addr, b.size); + result.addr := nil; + exit; + end; + until false; + + if (bd.addr = addr) and (bd.size >= minSize) then begin + result := Commit(bd.addr, minSize); + if result.addr = nil then + exit; + Inc(bd.addr, result.size); + Dec(bd.size, result.size); + if bd.size = 0 then + DeleteBlock(bd); + end else + result.addr := nil; +end; + + +function FreeCommitted(addr: PChar; maxSize: Integer): TBlock; +// Free at most maxSize bytes of address space at addr. +// Returns the block that was actually freed. +var + startAddr, endAddr: PChar; + b: TBlock; +begin + startAddr := PChar(Integer(addr + (cCommitAlign-1)) and not (cCommitAlign-1)); + endAddr := PChar(Integer(addr + maxSize) and not (cCommitAlign-1)); + if endAddr > startAddr then begin + result := Decommit(startAddr, endAddr - startAddr); + b := MergeBlockAfter(@decommittedRoot, result); + if b.addr <> nil then + b := FreeSpace(b.addr, b.size); + if b.addr <> nil then + RemoveBlock(@decommittedRoot, b); + end else + result.addr := nil; +end; + + +// +// Suballocator (what the user program actually calls) +// + +type + PFree = ^TFree; + TFree = packed record + prev: PFree; + next: PFree; + size: Integer; + end; + PUsed = ^TUsed; + TUsed = packed record + sizeFlags: Integer; + end; + +const + cAlign = 4; + cThisUsedFlag = 2; + cPrevFreeFlag = 1; + cFillerFlag = Integer($80000000); + cFlags = cThisUsedFlag or cPrevFreeFlag or cFillerFlag; + cSmallSize = 4*1024; + cDecommitMin = 15*1024; + +type + TSmallTab = array [sizeof(TFree) div cAlign .. cSmallSize div cAlign] of PFree; + +VAR + avail : TFree; + rover : PFree; + remBytes : Integer; + curAlloc : PChar; + smallTab : ^TSmallTab; + committedRoot: TBlockDesc; + +{X} // UninitAllocator - placed before InitAllocator to refer to. +procedure UninitAllocator; +// Shutdown. +var + bdb: PBlockDescBlock; + bd : PBlockDesc; +begin + if initialized then begin + try + if IsMultiThread then EnterCriticalSection(heapLock); + + initialized := False; + + LocalFree(smallTab); + smallTab := nil; + + bd := spaceRoot.next; + while bd <> @spaceRoot do begin + VirtualFree(bd.addr, 0, MEM_RELEASE); + bd := bd.next; + end; + + MakeEmpty(@spaceRoot); + MakeEmpty(@decommittedRoot); + MakeEmpty(@committedRoot); + + bdb := blockDescBlockList; + while bdb <> nil do begin + blockDescBlockList := bdb^.next; + LocalFree(bdb); + bdb := blockDescBlockList; + end; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + DeleteCriticalSection(heapLock); + end; + end; +end; + +function InitAllocator: Boolean; +// Initialize. No other calls legal before that. +var + i: Integer; + a: PFree; +begin + try + InitializeCriticalSection(heapLock); + if IsMultiThread then EnterCriticalSection(heapLock); + + MakeEmpty(@spaceRoot); + MakeEmpty(@decommittedRoot); + MakeEmpty(@committedRoot); + + smallTab := LocalAlloc(LMEM_FIXED, sizeof(smallTab^)); + if smallTab <> nil then begin + for i:= low(smallTab^) to high(smallTab^) do + smallTab[i] := nil; + + a := @avail; + a.next := a; + a.prev := a; + rover := a; + + initialized := True; + {X} // set here handler UninitMemoryManager to UninitAllocator } + {X} UninitMemoryManager := UninitAllocator; + end; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; + result := initialized; +end; + + + +procedure DeleteFree(f: PFree); +var + n, p: PFree; + size: Integer; +begin + if rover = f then + rover := f.next; + n := f.next; + size := f.size; + if size <= cSmallSize then begin + if n = f then + smallTab[size div cAlign] := nil + else begin + smallTab[size div cAlign] := n; + p := f.prev; + n.prev := p; + p.next := n; + end; + end else begin + p := f.prev; + n.prev := p; + p.next := n; + end; +end; + + +procedure InsertFree(a: Pointer; size: Integer); forward; + + +function FindCommitted(addr: PChar): PBlockDesc; +begin + result := committedRoot.next; + while result <> @committedRoot do begin + if (addr >= result.addr) and (addr < result.addr + result.size) then + exit; + result := result.next; + end; + heapErrorCode := cBadCommittedList; + result := nil; +end; + + +procedure FillBeforeGap(a: PChar; size: Integer); +var + rest: Integer; + e: PUsed; +begin + rest := size - sizeof(TUsed); + e := PUsed(a + rest); + if size >= sizeof(TFree) + sizeof(TUsed) then begin + e.sizeFlags := sizeof(TUsed) or cThisUsedFlag or cPrevFreeFlag or cFillerFlag; + InsertFree(a, rest); + end else if size >= sizeof(TUsed) then begin + PUsed(a).sizeFlags := size or (cThisUsedFlag or cFillerFlag); + e.sizeFlags := size or (cThisUsedFlag or cFillerFlag); + end; +end; + + +procedure InternalFreeMem(a: PChar); +begin + Inc(AllocMemCount); + Inc(AllocMemSize,PUsed(a-sizeof(TUsed)).sizeFlags and not cFlags - sizeof(TUsed)); + SysFreeMem(a); +end; + + +procedure FillAfterGap(a: PChar; size: Integer); +begin + if size >= sizeof(TFree) then begin + PUsed(a).sizeFlags := size or cThisUsedFlag; + InternalFreeMem(a + sizeof(TUsed)); + end else begin + if size >= sizeof(TUsed) then + PUsed(a).sizeFlags := size or (cThisUsedFlag or cFillerFlag); + Inc(a,size); + PUsed(a).sizeFlags := PUsed(a).sizeFlags and not cPrevFreeFlag; + end; +end; + + +function FillerSizeBeforeGap(a: PChar): Integer; +var + sizeFlags : Integer; + freeSize : Integer; + f : PFree; +begin + sizeFlags := PUsed(a - sizeof(TUsed)).sizeFlags; + if (sizeFlags and (cThisUsedFlag or cFillerFlag)) <> (cThisUsedFlag or cFillerFlag) then + heapErrorCode := cBadFiller1; + result := sizeFlags and not cFlags; + Dec(a, result); + if ((PUsed(a).sizeFlags xor sizeFlags) and not cPrevFreeFlag) <> 0 then + HeapErrorCode := cBadFiller2; + if (PUsed(a).sizeFlags and cPrevFreeFlag) <> 0 then begin + freeSize := PFree(a - sizeof(TFree)).size; + f := PFree(a - freeSize); + if f.size <> freeSize then + heapErrorCode := cBadFiller3; + DeleteFree(f); + Inc(result, freeSize); + end; +end; + + +function FillerSizeAfterGap(a: PChar): Integer; +var + sizeFlags: Integer; + f : PFree; +begin + result := 0; + sizeFlags := PUsed(a).sizeFlags; + if (sizeFlags and cFillerFlag) <> 0 then begin + sizeFlags := sizeFlags and not cFlags; + Inc(result,sizeFlags); + Inc(a, sizeFlags); + sizeFlags := PUsed(a).sizeFlags; + end; + if (sizeFlags and cThisUsedFlag) = 0 then begin + f := PFree(a); + DeleteFree(f); + Inc(result, f.size); + Inc(a, f.size); + PUsed(a).sizeFlags := PUsed(a).sizeFlags and not cPrevFreeFlag; + end; +end; + + +function DecommitFree(a: PChar; size: Integer): Boolean; +var + b: TBlock; + bd: PBlockDesc; +begin + bd := FindCommitted(a); + if bd.addr + bd.size - (a + size) <= sizeof(TFree) then + size := bd.addr + bd.size - a; + + if a - bd.addr < sizeof(TFree) then + b := FreeCommitted(bd.addr, size + (a - bd.addr)) + else + b := FreeCommitted(a + sizeof(TUsed), size - sizeof(TUsed)); + + if b.addr = nil then + result := False + else begin + FillBeforeGap(a, b.addr - a); + if bd.addr + bd.size > b.addr + b.size then + FillAfterGap(b.addr + b.size, a + size - (b.addr + b.size)); + RemoveBlock(bd,b); + result := True; + end; +end; + + +procedure InsertFree(a: Pointer; size: Integer); +var + f, n, p: PFree; +begin + f := PFree(a); + f.size := size; + PFree(PChar(f) + size - sizeof(TFree)).size := size; + if size <= cSmallSize then begin + n := smallTab[size div cAlign]; + if n = nil then begin + smallTab[size div cAlign] := f; + f.next := f; + f.prev := f; + end else begin + p := n.prev; + f.next := n; + f.prev := p; + n.prev := f; + p.next := f; + end; + end else if (size < cDecommitMin) or not DecommitFree(a, size) then begin + n := rover; + rover := f; + p := n.prev; + f.next := n; + f.prev := p; + n.prev := f; + p.next := f; + end; +end; + + +procedure FreeCurAlloc; +begin + if remBytes > 0 then begin + if remBytes < sizeof(TFree) then + heapErrorCode := cBadCurAlloc + else begin + PUsed(curAlloc).sizeFlags := remBytes or cThisUsedFlag; + InternalFreeMem(curAlloc + sizeof(TUsed)); + curAlloc := nil; + remBytes := 0; + end; + end; +end; + + +function MergeCommit(b: TBlock): Boolean; +var + merged: TBlock; + fSize: Integer; +begin + FreeCurAlloc; + merged := MergeBlockAfter(@committedRoot, b); + if merged.addr = nil then begin + result := False; + exit; + end; + + if merged.addr < b.addr then begin + fSize := FillerSizeBeforeGap(b.addr); + Dec(b.addr, fSize); + Inc(b.size, fSize); + end; + + if merged.addr + merged.size > b.addr + b.size then begin + fSize := FillerSizeAfterGap(b.addr + b.size); + Inc(b.size, fSize); + end; + + if merged.addr + merged.size = b.addr + b.size then begin + FillBeforeGap(b.addr + b.size - sizeof(TUsed), sizeof(TUsed)); + Dec(b.size, sizeof(TUsed)); + end; + + curAlloc := b.addr; + remBytes := b.size; + + result := True; +end; + + +function NewCommit(minSize: Integer): Boolean; +var + b: TBlock; +begin + b := GetCommitted(minSize+sizeof(TUsed)); + result := (b.addr <> nil) and MergeCommit(b); +end; + + +function NewCommitAt(addr: Pointer; minSize: Integer): Boolean; +var + b: TBlock; +begin + b := GetCommittedAt(addr, minSize+sizeof(TUsed)); + result := (b.addr <> nil) and MergeCommit(b); +end; + + +function SearchSmallBlocks(size: Integer): PFree; +var + i: Integer; +begin + result := nil; + for i := size div cAlign to High(smallTab^) do begin + result := smallTab[i]; + if result <> nil then + exit; + end; +end; + + +function TryHarder(size: Integer): Pointer; +var + u: PUsed; f:PFree; saveSize, rest: Integer; +begin + + repeat + + f := avail.next; + if (size <= f.size) then + break; + + f := rover; + if f.size >= size then + break; + + saveSize := f.size; + f.size := size; + repeat + f := f.next + until f.size >= size; + rover.size := saveSize; + if f <> rover then begin + rover := f; + break; + end; + + if size <= cSmallSize then begin + f := SearchSmallBlocks(size); + if f <> nil then + break; + end; + + if not NewCommit(size) then begin + result := nil; + exit; + end; + + if remBytes >= size then begin + Dec(remBytes, size); + if remBytes < sizeof(TFree) then begin + Inc(size, remBytes); + remBytes := 0; + end; + u := PUsed(curAlloc); + Inc(curAlloc, size); + u.sizeFlags := size or cThisUsedFlag; + result := PChar(u) + sizeof(TUsed); + Inc(AllocMemCount); + Inc(AllocMemSize,size - sizeof(TUsed)); + exit; + end; + + until False; + + DeleteFree(f); + + rest := f.size - size; + if rest >= sizeof(TFree) then begin + InsertFree(PChar(f) + size, rest); + end else begin + size := f.size; + if f = rover then + rover := f.next; + u := PUsed(PChar(f) + size); + u.sizeFlags := u.sizeFlags and not cPrevFreeFlag; + end; + + u := PUsed(f); + u.sizeFlags := size or cThisUsedFlag; + + result := PChar(u) + sizeof(TUsed); + Inc(AllocMemCount); + Inc(AllocMemSize,size - sizeof(TUsed)); + +end; + + +function SysGetMem(size: Integer): Pointer; +// Allocate memory block. +var + f, prev, next: PFree; + u: PUsed; +begin + + if not initialized and not InitAllocator then begin + result := nil; + exit; + end; + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + Inc(size, sizeof(TUsed) + (cAlign-1)); + size := size and not (cAlign-1); + if size < sizeof(TFree) then + size := sizeof(TFree); + + if size <= cSmallSize then begin + f := smallTab[size div cAlign]; + if f <> nil then begin + u := PUsed(PChar(f) + size); + u.sizeFlags := u.sizeFlags and not cPrevFreeFlag; + next := f.next; + if next = f then + smallTab[size div cAlign] := nil + else begin + smallTab[size div cAlign] := next; + prev := f.prev; + prev.next := next; + next.prev := prev; + end; + u := PUsed(f); + u.sizeFlags := f.size or cThisUsedFlag; + result := PChar(u) + sizeof(TUsed); + Inc(AllocMemCount); + Inc(AllocMemSize,size - sizeof(TUsed)); + exit; + end; + end; + + if size <= remBytes then begin + Dec(remBytes, size); + if remBytes < sizeof(TFree) then begin + Inc(size, remBytes); + remBytes := 0; + end; + u := PUsed(curAlloc); + Inc(curAlloc, size); + u.sizeFlags := size or cThisUsedFlag; + result := PChar(u) + sizeof(TUsed); + Inc(AllocMemCount); + Inc(AllocMemSize,size - sizeof(TUsed)); + exit; + end; + + result := TryHarder(size); + + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; + +end; + + +function SysFreeMem(p: Pointer): Integer; +// Deallocate memory block. +label + abort; +var + u, n : PUsed; + f : PFree; + prevSize, nextSize, size : Integer; +begin + heapErrorCode := cHeapOk; + + if not initialized and not InitAllocator then begin + heapErrorCode := cCantInit; + result := cCantInit; + exit; + end; + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + u := p; + u := PUsed(PChar(u) - sizeof(TUsed)); { inv: u = address of allocated block being freed } + size := u.sizeFlags; + { inv: size = SET(block size) + [block flags] } + + { validate that the interpretation of this block as a used block is correct } + if (size and cThisUsedFlag) = 0 then begin + heapErrorCode := cBadUsedBlock; + goto abort; + end; + + { inv: the memory block addressed by 'u' and 'p' is an allocated block } + + Dec(AllocMemCount); + Dec(AllocMemSize,size and not cFlags - sizeof(TUsed)); + + if (size and cPrevFreeFlag) <> 0 then begin + { previous block is free, coalesce } + prevSize := PFree(PChar(u)-sizeof(TFree)).size; + if (prevSize < sizeof(TFree)) or ((prevSize and cFlags) <> 0) then begin + heapErrorCode := cBadPrevBlock; + goto abort; + end; + + f := PFree(PChar(u) - prevSize); + if f^.size <> prevSize then begin + heapErrorCode := cBadPrevBlock; + goto abort; + end; + + inc(size, prevSize); + u := PUsed(f); + DeleteFree(f); + end; + + size := size and not cFlags; + { inv: size = block size } + + n := PUsed(PChar(u) + size); + { inv: n = block following the block to free } + + if PChar(n) = curAlloc then begin + { inv: u = last block allocated } + dec(curAlloc, size); + inc(remBytes, size); + if remBytes > cDecommitMin then + FreeCurAlloc; + result := cHeapOk; + exit; + end; + + if (n.sizeFlags and cThisUsedFlag) <> 0 then begin + { inv: n is a used block } + if (n.sizeFlags and not cFlags) < sizeof(TUsed) then begin + heapErrorCode := cBadNextBlock; + goto abort; + end; + n.sizeFlags := n.sizeFlags or cPrevFreeFlag + end else begin + { inv: block u & n are both free; coalesce } + f := PFree(n); + if (f.next = nil) or (f.prev = nil) or (f.size < sizeof(TFree)) then begin + heapErrorCode := cBadNextBlock; + goto abort; + end; + nextSize := f.size; + inc(size, nextSize); + DeleteFree(f); + { inv: last block (which was free) is not on free list } + end; + + InsertFree(u, size); +abort: + result := heapErrorCode; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; +end; + + +function ResizeInPlace(p: Pointer; newSize: Integer): Boolean; +var u, n: PUsed; f: PFree; oldSize, blkSize, neededSize: Integer; +begin + Inc(newSize, sizeof(TUsed)+cAlign-1); + newSize := newSize and not (cAlign-1); + if newSize < sizeof(TFree) then + newSize := sizeof(TFree); + u := PUsed(PChar(p) - sizeof(TUsed)); + oldSize := u.sizeFlags and not cFlags; + n := PUsed( PChar(u) + oldSize ); + if newSize <= oldSize then begin + blkSize := oldSize - newSize; + if PChar(n) = curAlloc then begin + Dec(curAlloc, blkSize); + Inc(remBytes, blkSize); + if remBytes < sizeof(TFree) then begin + Inc(curAlloc, blkSize); + Dec(remBytes, blkSize); + newSize := oldSize; + end; + end else begin + n := PUsed(PChar(u) + oldSize); + if n.sizeFlags and cThisUsedFlag = 0 then begin + f := PFree(n); + Inc(blkSize, f.size); + DeleteFree(f); + end; + if blkSize >= sizeof(TFree) then begin + n := PUsed(PChar(u) + newSize); + n.sizeFlags := blkSize or cThisUsedFlag; + InternalFreeMem(PChar(n) + sizeof(TUsed)); + end else + newSize := oldSize; + end; + end else begin + repeat + neededSize := newSize - oldSize; + if PChar(n) = curAlloc then begin + if remBytes >= neededSize then begin + Dec(remBytes, neededSize); + Inc(curAlloc, neededSize); + if remBytes < sizeof(TFree) then begin + Inc(curAlloc, remBytes); + Inc(newSize, remBytes); + remBytes := 0; + end; + Inc(AllocMemSize, newSize - oldSize); + u.sizeFlags := newSize or u.sizeFlags and cFlags; + result := true; + exit; + end else begin + FreeCurAlloc; + n := PUsed( PChar(u) + oldSize ); + end; + end; + + if n.sizeFlags and cThisUsedFlag = 0 then begin + f := PFree(n); + blkSize := f.size; + if blkSize < neededSize then begin + n := PUsed(PChar(n) + blkSize); + Dec(neededSize, blkSize); + end else begin + DeleteFree(f); + Dec(blkSize, neededSize); + if blkSize >= sizeof(TFree) then + InsertFree(PChar(u) + newSize, blkSize) + else begin + Inc(newSize, blkSize); + n := PUsed(PChar(u) + newSize); + n.sizeFlags := n.sizeFlags and not cPrevFreeFlag; + end; + break; + end; + end; + + if n.sizeFlags and cFillerFlag <> 0 then begin + n := PUsed(PChar(n) + n.sizeFlags and not cFlags); + if NewCommitAt(n, neededSize) then begin + n := PUsed( PChar(u) + oldSize ); + continue; + end; + end; + + result := False; + exit; + + until False; + + end; + + Inc(AllocMemSize, newSize - oldSize); + u.sizeFlags := newSize or u.sizeFlags and cFlags; + result := True; + +end; + + +function SysReallocMem(p: Pointer; size: Integer): Pointer; +// Resize memory block. +var + n: Pointer; oldSize: Integer; +begin + + if not initialized and not InitAllocator then begin + result := nil; + exit; + end; + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + if ResizeInPlace(p, size) then + result := p + else begin + n := SysGetMem(size); + oldSize := (PUsed(PChar(p)-sizeof(PUsed)).sizeFlags and not cFlags) - sizeof(TUsed); + if oldSize > size then + oldSize := size; + if n <> nil then begin + Move(p^, n^, oldSize); + SysFreeMem(p); + end; + result := n; + end; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; + +end; + + +function BlockSum(root: PBlockDesc): Integer; +var + b : PBlockDesc; +begin + result := 0; + b := root.next; + while b <> root do begin + Inc(result, b.size); + b := b.next; + end; +end; + + +function GetHeapStatus: THeapStatus; +var + size, freeSize, userSize: Cardinal; + f: PFree; + a, e: PChar; + i: Integer; + b: PBlockDesc; + prevFree: Boolean; +begin + + heapErrorCode := cHeapOk; + + result.TotalAddrSpace := 0; + result.TotalUncommitted := 0; + result.TotalCommitted := 0; + result.TotalAllocated := 0; + result.TotalFree := 0; + result.FreeSmall := 0; + result.FreeBig := 0; + result.Unused := 0; + result.Overhead := 0; + result.HeapErrorCode := cHeapOk; + + if not initialized then exit; + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + result.totalAddrSpace := BlockSum(@spaceRoot); + result.totalUncommitted := BlockSum(@decommittedRoot); + result.totalCommitted := BlockSum(@committedRoot); + + size := 0; + for i := Low(smallTab^) to High(smallTab^) do begin + f := smallTab[i]; + if f <> nil then begin + repeat + Inc(size, f.size); + if (f.prev.next <> f) or (f.next.prev <> f) or (f.size < sizeof(TFree)) then begin + heapErrorCode := cBadFreeList; + break; + end; + f := f.next; + until f = smallTab[i]; + end; + end; + result.freeSmall := size; + + size := 0; + f := avail.next; + while f <> @avail do begin + if (f.prev.next <> f) or (f.next.prev <> f) or (f.size < sizeof(TFree)) then begin + heapErrorCode := cBadFreeList; + break; + end; + Inc(size, f.size); + f := f.next; + end; + result.freeBig := size; + + result.unused := remBytes; + result.totalFree := result.freeSmall + result.freeBig + result.unused; + + freeSize := 0; + userSize := 0; + result.overhead := 0; + + b := committedRoot.next; + prevFree := False; + while b <> @committedRoot do begin + a := b.addr; + e := a + b.size; + while a < e do begin + if (a = curAlloc) and (remBytes > 0) then begin + size := remBytes; + Inc(freeSize, size); + if prevFree then + heapErrorCode := cBadCurAlloc; + prevFree := False; + end else begin + if prevFree <> ((PUsed(a).sizeFlags and cPrevFreeFlag) <> 0) then + heapErrorCode := cBadNextBlock; + if (PUsed(a).sizeFlags and cThisUsedFlag) = 0 then begin + f := PFree(a); + if (f.prev.next <> f) or (f.next.prev <> f) or (f.size < sizeof(TFree)) then + heapErrorCode := cBadFreeBlock; + size := f.size; + Inc(freeSize, size); + prevFree := True; + end else begin + size := PUsed(a).sizeFlags and not cFlags; + if (PUsed(a).sizeFlags and cFillerFlag) <> 0 then begin + Inc(result.overhead, size); + if (a > b.addr) and (a + size < e) then + heapErrorCode := cBadUsedBlock; + end else begin + Inc(userSize, size-sizeof(TUsed)); + Inc(result.overhead, sizeof(TUsed)); + end; + prevFree := False; + end; + end; + Inc(a, size); + end; + b := b.next; + end; + if result.totalFree <> freeSize then + heapErrorCode := cBadBalance; + + result.totalAllocated := userSize; + result.heapErrorCode := heapErrorCode; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; +end; + + +// this section goes into GetMem.Inc + +{$IFDEF DEBUG_FUNCTIONS} +type + THeapReportProc = procedure(HeapBlock: Pointer; AllocatedSize: Integer) of object; + + +procedure WalkHeap(HeapReportProc: THeapReportProc); +var + size : Cardinal; + f: PFree; + a, e: PChar; + b: PBlockDesc; +begin + + if not initialized then exit; + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + b := committedRoot.next; + while b <> @committedRoot do begin + a := b.addr; + e := a + b.size; + while a < e do begin + if (a = curAlloc) and (remBytes > 0) then begin + size := remBytes; + end else begin + if (PUsed(a).sizeFlags and cThisUsedFlag) = 0 then begin + f := PFree(a); + size := f.size; + end else begin + size := PUsed(a).sizeFlags and not cFlags; + if (PUsed(a).sizeFlags and cFillerFlag) = 0 then begin + HeapReportProc(a + sizeof(TUsed), size - sizeof(TUsed)); + end; + end; + end; + Inc(a, size); + end; + b := b.next; + end; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; +end; + +type + THeapBlockCollector = class(TObject) + FCount: Integer; + FObjectTable: TObjectArray; + FHeapBlockTable: THeapBlockArray; + FClass: TClass; + FFindDerived: Boolean; + procedure CollectBlocks(HeapBlock: Pointer; AllocatedSize: Integer); + procedure CollectObjects(HeapBlock: Pointer; AllocatedSize: Integer); + end; + + +procedure THeapBlockCollector.CollectBlocks(HeapBlock: Pointer; AllocatedSize: Integer); +begin + if FCount < Length(FHeapBlockTable) then + begin + FHeapBlockTable[FCount].Start := HeapBlock; + FHeapBlockTable[FCount].Size := AllocatedSize; + end; + Inc(FCount); +end; + + +procedure THeapBlockCollector.CollectObjects(HeapBlock: Pointer; AllocatedSize: Integer); +var + AObject: TObject; + AClass: TClass; +type + PPointer = ^Pointer; +begin + try + if AllocatedSize < 4 then + Exit; + AObject := TObject(HeapBlock); + AClass := AObject.ClassType; + if (AClass = FClass) + or (FFindDerived + and (Integer(AClass) >= 64*1024) + and (PPointer(PChar(AClass) + vmtSelfPtr)^ = Pointer(AClass)) + and (AObject is FClass)) then + begin + if FCount < Length(FObjectTable) then + FObjectTable[FCount] := AObject; + Inc(FCount); + end; + except + // Let's not worry about this block - it's obviously not a valid object + end; +end; + +var + HeapBlockCollector: THeapBlockCollector; + +function GetHeapBlocks: THeapBlockArray; +begin + if not Assigned(HeapBlockCollector) then + HeapBlockCollector := THeapBlockCollector.Create; + + Walkheap(HeapBlockCollector.CollectBlocks); + SetLength(HeapBlockCollector.FHeapBlockTable, HeapBlockCollector.FCount); + HeapBlockCollector.FCount := 0; + Walkheap(HeapBlockCollector.CollectBlocks); + Result := HeapBlockCollector.FHeapBlockTable; + HeapBlockCollector.FCount := 0; + HeapBlockCollector.FHeapBlockTable := nil; +end; + + +function FindObjects(AClass: TClass; FindDerived: Boolean): TObjectArray; +begin + if not Assigned(HeapBlockCollector) then + HeapBlockCollector := THeapBlockCollector.Create; + HeapBlockCollector.FClass := AClass; + HeapBlockCollector.FFindDerived := FindDerived; + + Walkheap(HeapBlockCollector.CollectObjects); + SetLength(HeapBlockCollector.FObjectTable, HeapBlockCollector.FCount); + HeapBlockCollector.FCount := 0; + Walkheap(HeapBlockCollector.CollectObjects); + Result := HeapBlockCollector.FObjectTable; + HeapBlockCollector.FCount := 0; + HeapBlockCollector.FObjectTable := nil; +end; +{$ENDIF} + +{X+} +// Set of simple memory management routines to replace Delphi +// standard memory manager with Windows standard one: +function LocalReAlloc(hMem: Pointer; uBytes, uFlags: Integer): Pointer; stdcall; + external kernel name 'LocalReAlloc'; +function LocalSize(hMem: Pointer) : Integer; stdcall; + external kernel name 'LocalSize'; + +function DfltGetMem(size: Integer): Pointer; +// Allocate memory block. +begin + Result := Pointer( LocalAlloc( LMEM_FIXED, size ) ); +end; + +function DfltFreeMem(p: Pointer): Integer; +// Deallocate memory block. +begin + Result := Integer( LocalFree( p ) ); +end; + +function DfltReallocMem(p: Pointer; size: Integer): Pointer; +// Resize memory block. +var OldSize : Integer; +begin + Result := LocalReAlloc( p, size, 0 ); + if Result = nil then + begin + Result := LocalAlloc( LMEM_FIXED, size ); + if Result <> nil then + begin + OldSize := LocalSize( p ); + if OldSize > size then + OldSize := size; + Move( p^, Result^, OldSize ); + LocalFree( p ); + end; + end; +end; + diff --git a/System/D5/makefile b/System/D5/makefile new file mode 100644 index 0000000..1428af9 --- /dev/null +++ b/System/D5/makefile @@ -0,0 +1,287 @@ + +# ******************************************************* +# * * +# * Delphi Runtime Library * +# * MAKE script * +# * * +# * Copyright (C) 1988,98 Inprise Corporation * +# * * +# ******************************************************* + +# This MAKE script requires Borland MAKE Version 3.7 or later (MAKE.EXE), +# Turbo Assembler Version 4.0 or later (TASM32.EXE), and Borland Resource +# Compiler Version 4.0 or later (BRCC32.EXE). + +# The script assumes that DCC32.EXE, TASM32.EXE, and BRCC32.EXE are present +# on the current search path--if this is not the case, modify the DCC, TASM, +# and BRCC macros below to reflect the location of these executables. + +# To build the runtime library without debug information (the default), +# simply run MAKE.EXE from the directory containing this MAKEFILE. To +# build a debug version of the runtime library, specify a -DDEBUG command +# line parameter when running MAKE.EXE. + +# The BIN and LIB macros define the output directories for binaries and +# compiled units. + +# DCC = dcc32 -q +# TASM = tasm32 +# BRCC = brcc32 + +DCC = c:\delphi5\bin\dcc32 -q +TASM = c:\tasm5\bin\tasm32 +BRCC = c:\delphi5\bin\brcc32 + +BIN = bin +LIB = lib + +!if $d(DEBUG) +RTLDEBUG = -$$D+ +ASMDEBUG = -zi +!else +RTLDEBUG = -$$D- +ASMDEBUG = -zn +!endif + +SYSTEMOBJ = \ +sys\assign.obj \ +sys\blockrea.obj \ +sys\blockwri.obj \ +sys\close.obj \ +sys\eoffile.obj \ +sys\eoftext.obj \ +sys\eoln.obj \ +sys\erase.obj \ +sys\ext2real.obj \ +sys\fdiv.obj \ +sys\filepos.obj \ +sys\filesize.obj \ +sys\halt.obj \ +sys\openfile.obj \ +sys\opentext.obj \ +sys\pow10.obj \ +sys\readchar.obj \ +sys\readext.obj \ +sys\readint64.obj \ +sys\readln.obj \ +sys\readlong.obj \ +sys\readrec.obj \ +sys\readstri.obj \ +sys\real2ext.obj \ +sys\rename.obj \ +sys\seek.obj \ +sys\seekeof.obj \ +sys\seekeoln.obj \ +sys\settextb.obj \ +sys\strext.obj \ +sys\truncate.obj \ +sys\valext.obj \ +sys\writerec.obj \ +sys\writestr.obj \ +sys\_ll.obj + +SYSUTILSOBJ = \ +sys\ffmt.obj + +.asm.obj: + $(TASM) -zn -m3 -t -w- $(ASMDEBUG) -isys $*,$*.obj + +default: \ +$(LIB)\system.dcu \ +$(LIB)\sysvarnt.dcu \ +$(LIB)\syssfini.dcu \ +$(LIB)\syswstr.dcu \ +$(LIB)\sharemem.dcu \ +$(LIB)\comobj.dcu \ +$(LIB)\comserv.dcu \ +$(LIB)\windows.dcu \ +$(LIB)\sysutils.dcu \ +$(LIB)\messages.dcu \ +$(LIB)\shellapi.dcu \ +$(LIB)\shlobj.dcu \ +$(LIB)\dlgs.dcu \ +$(LIB)\commdlg.dcu \ +$(LIB)\commctrl.dcu \ +$(LIB)\ddeml.dcu \ +$(LIB)\flatsb.dcu \ +$(LIB)\mmsystem.dcu \ +$(LIB)\nsapi.dcu \ +$(LIB)\isapi.dcu \ +$(LIB)\isapi2.dcu \ +$(LIB)\wininet.dcu \ +$(LIB)\winspool.dcu \ +$(LIB)\winsock.dcu \ +$(LIB)\winsvc.dcu \ +$(LIB)\mapi.dcu \ +$(LIB)\multimon.dcu \ +$(LIB)\lzexpand.dcu \ +$(LIB)\nb30.dcu \ +$(LIB)\ole2.dcu \ +$(LIB)\olectl.dcu \ +$(LIB)\oledlg.dcu \ +$(LIB)\richedit.dcu \ +$(LIB)\tlhelp32.dcu \ +$(LIB)\math.dcu \ +$(LIB)\imm.dcu \ +$(LIB)\activex.dcu \ +$(LIB)\cpl.dcu \ +$(LIB)\imagehlp.dcu \ +$(LIB)\opengl.dcu \ +$(LIB)\penwin.dcu \ +$(LIB)\regstr.dcu \ +$(LIB)\urlmon.dcu + + +$(LIB)\system.dcu: sys\system.pas sys\sysinit.pas sys\getmem.inc $(SYSTEMOBJ) + $(DCC) sys\system -m -y -z $(RTLDEBUG) -n$(LIB) + +# follow lines are added to compile additional units (sysvarnt, syswstr): + +$(LIB)\sysvarnt.dcu: sys\sysvarnt.pas $(LIB)\system.dcu + $(DCC) sys\sysvarnt -z $(RTLDEBUG) -u$(LIB) -n$(LIB) + +$(LIB)\syswstr.dcu: sys\syswstr.pas $(LIB)\system.dcu + $(DCC) sys\syswstr -z $(RTLDEBUG) -u$(LIB) -n$(LIB) + +$(LIB)\syssfini.dcu: sys\syssfini.pas $(LIB)\system.dcu + $(DCC) sys\syssfini -z $(RTLDEBUG) -u$(LIB) -n$(LIB) + +$(LIB)\comobj.dcu: sys\comobj.pas $(LIB)\system.dcu \ +$(LIB)\sysutils.dcu $(LIB)\windows.dcu $(LIB)\activex.dcu + $(DCC) sys\comobj -z $(RTLDEBUG) -u$(LIB) -n$(LIB) + +$(LIB)\comserv.dcu: sys\comserv.pas $(LIB)\system.dcu \ +$(LIB)\comobj.dcu $(LIB)\sysutils.dcu $(LIB)\windows.dcu + $(DCC) sys\comserv -z $(RTLDEBUG) -u$(LIB) -n$(LIB) + +$(LIB)\sharemem.dcu: sys\sharemem.pas $(LIB)\system.dcu + $(DCC) sys\sharemem -z $(RTLDEBUG) -u$(LIB) -n$(LIB) + +$(LIB)\windows.dcu: win\windows.pas $(LIB)\system.dcu + $(DCC) win\windows -z $(RTLDEBUG) -u$(LIB) -n$(LIB) + +$(LIB)\sysutils.dcu: sys\sysutils.pas $(SYSUTILSOBJ) \ +$(LIB)\system.dcu $(LIB)\windows.dcu + $(DCC) sys\sysutils -z $(RTLDEBUG) -u$(LIB) -r$(LIB) -n$(LIB) + +$(LIB)\messages.dcu: win\messages.pas $(LIB)\system.dcu \ +$(LIB)\windows.dcu + $(DCC) win\messages -z $(RTLDEBUG) -u$(LIB) -n$(LIB) + +$(LIB)\shellapi.dcu: win\shellapi.pas $(LIB)\system.dcu \ +$(LIB)\windows.dcu + $(DCC) win\shellapi -z $(RTLDEBUG) -u$(LIB) -n$(LIB) + +$(LIB)\regstr.dcu: win\regstr.pas $(LIB)\system.dcu \ +$(LIB)\windows.dcu + $(DCC) win\regstr -z $(RTLDEBUG) -u$(LIB) -n$(LIB) + +$(LIB)\shlobj.dcu: win\shlobj.pas $(LIB)\system.dcu \ +$(LIB)\windows.dcu $(LIB)\ole2.dcu $(LIB)\commctrl.dcu \ +$(LIB)\shellapi.dcu $(LIB)\regstr.dcu + $(DCC) win\shlobj -z $(RTLDEBUG) -u$(LIB) -n$(LIB) + +$(LIB)\dlgs.dcu: win\dlgs.pas $(LIB)\system.dcu + $(DCC) win\dlgs -z $(RTLDEBUG) -u$(LIB) -n$(LIB) + +$(LIB)\commdlg.dcu: win\commdlg.pas $(LIB)\system.dcu \ +$(LIB)\windows.dcu $(LIB)\messages.dcu + $(DCC) win\commdlg -z $(RTLDEBUG) -u$(LIB) -n$(LIB) + +$(LIB)\commctrl.dcu: win\commctrl.pas $(LIB)\system.dcu \ +$(LIB)\windows.dcu + $(DCC) win\commctrl -z $(RTLDEBUG) -u$(LIB) -n$(LIB) + +$(LIB)\ddeml.dcu: win\ddeml.pas $(LIB)\system.dcu $(LIB)\windows.dcu + $(DCC) win\ddeml -z $(RTLDEBUG) -u$(LIB) -n$(LIB) + +$(LIB)\mmsystem.dcu: win\mmsystem.pas $(LIB)\system.dcu \ +$(LIB)\windows.dcu + $(DCC) win\mmsystem -z $(RTLDEBUG) -u$(LIB) -n$(LIB) + +$(LIB)\winspool.dcu: win\winspool.pas $(LIB)\system.dcu \ +$(LIB)\windows.dcu + $(DCC) win\winspool -z $(RTLDEBUG) -u$(LIB) -n$(LIB) + +$(LIB)\isapi.dcu: win\isapi.pas $(LIB)\system.dcu $(LIB)\windows.dcu + $(DCC) win\isapi -z $(RTLDEBUG) -u$(LIB) -n$(LIB) + +$(LIB)\isapi2.dcu: win\isapi2.pas $(LIB)\system.dcu $(LIB)\windows.dcu + $(DCC) win\isapi2 -z $(RTLDEBUG) -u$(LIB) -n$(LIB) + +$(LIB)\nsapi.dcu: win\nsapi.pas $(LIB)\system.dcu $(LIB)\windows.dcu + $(DCC) win\nsapi -z $(RTLDEBUG) -u$(LIB);win -n$(LIB) + +$(LIB)\wininet.dcu: win\wininet.pas $(LIB)\system.dcu \ +$(LIB)\windows.dcu + $(DCC) win\wininet -z $(RTLDEBUG) -u$(LIB) -n$(LIB) + +$(LIB)\winsock.dcu: win\winsock.pas $(LIB)\system.dcu \ +$(LIB)\windows.dcu + $(DCC) win\winsock -z $(RTLDEBUG) -u$(LIB) -n$(LIB) + +$(LIB)\winsvc.dcu: win\winsvc.pas $(LIB)\system.dcu \ +$(LIB)\windows.dcu + $(DCC) win\winsvc -z $(RTLDEBUG) -u$(LIB) -n$(LIB) + +$(LIB)\mapi.dcu: win\mapi.pas $(LIB)\system.dcu \ +$(LIB)\windows.dcu + $(DCC) win\mapi -z $(RTLDEBUG) -u$(LIB) -n$(LIB) + +$(LIB)\lzexpand.dcu: win\lzexpand.pas $(LIB)\system.dcu \ +$(LIB)\windows.dcu + $(DCC) win\lzexpand -z $(RTLDEBUG) -u$(LIB) -n$(LIB) + +$(LIB)\nb30.dcu: win\nb30.pas $(LIB)\system.dcu $(LIB)\windows.dcu + $(DCC) win\nb30 -z $(RTLDEBUG) -u$(LIB) -n$(LIB) + +$(LIB)\ole2.dcu: win\ole2.pas $(LIB)\system.dcu \ +$(LIB)\windows.dcu + $(DCC) win\ole2 -z $(RTLDEBUG) -u$(LIB) -n$(LIB) + +$(LIB)\olectl.dcu: win\olectl.pas $(LIB)\system.dcu \ +$(LIB)\windows.dcu $(LIB)\messages.dcu $(LIB)\ole2.dcu + $(DCC) win\olectl -z $(RTLDEBUG) -u$(LIB) -n$(LIB) + +$(LIB)\oledlg.dcu: win\oledlg.pas $(LIB)\system.dcu \ +$(LIB)\windows.dcu $(LIB)\commctrl.dcu $(LIB)\ole2.dcu + $(DCC) win\oledlg -z $(RTLDEBUG) -u$(LIB) -n$(LIB) + +$(LIB)\richedit.dcu: win\richedit.pas $(LIB)\system.dcu \ +$(LIB)\windows.dcu + $(DCC) win\richedit -z $(RTLDEBUG) -u$(LIB) -n$(LIB) + +$(LIB)\tlhelp32.dcu: win\tlhelp32.pas $(LIB)\system.dcu \ +$(LIB)\windows.dcu + $(DCC) win\tlhelp32 -z $(RTLDEBUG) -u$(LIB) -n$(LIB) + +$(LIB)\math.dcu: sys\math.pas $(LIB)\system.dcu + $(DCC) sys\math -z $(RTLDEBUG) -u$(LIB) -r$(LIB) -n$(LIB) + +$(LIB)\imm.dcu: win\imm.pas $(LIB)\windows.dcu + $(DCC) win\imm -z $(RTLDEBUG) -u$(LIB) -r$(LIB) -n$(LIB) + +$(LIB)\activex.dcu: win\activex.pas $(LIB)\windows.dcu $(LIB)\messages.dcu + $(DCC) win\activex -z $(RTLDEBUG) -u$(LIB) -r$(LIB) -n$(LIB) + +$(LIB)\cpl.dcu: win\cpl.pas $(LIB)\windows.dcu $(LIB)\messages.dcu + $(DCC) win\cpl -z $(RTLDEBUG) -u$(LIB) -r$(LIB) -n$(LIB) + +$(LIB)\imagehlp.dcu: win\imagehlp.pas $(LIB)\windows.dcu + $(DCC) win\imagehlp -z $(RTLDEBUG) -u$(LIB) -r$(LIB) -n$(LIB) + +$(LIB)\opengl.dcu: win\opengl.pas $(LIB)\windows.dcu + $(DCC) win\opengl -z $(RTLDEBUG) -u$(LIB) -r$(LIB) -n$(LIB) + +$(LIB)\penwin.dcu: win\penwin.pas $(LIB)\windows.dcu $(LIB)\messages.dcu \ +$(LIB)\mmsystem.dcu + $(DCC) win\penwin -z $(RTLDEBUG) -u$(LIB) -r$(LIB) -n$(LIB) + +$(LIB)\urlmon.dcu: win\urlmon.pas $(LIB)\windows.dcu $(LIB)\activex.dcu + $(DCC) win\urlmon -z $(RTLDEBUG) -u$(LIB) -r$(LIB) -n$(LIB) + +$(LIB)\flatsb.dcu: win\flatsb.pas $(LIB)\windows.dcu + $(DCC) win\flatsb -z $(RTLDEBUG) -u$(LIB) -r$(LIB) -n$(LIB) + +$(LIB)\multimon.dcu: win\multimon.pas $(LIB)\windows.dcu + $(DCC) win\multimon -z $(RTLDEBUG) -u$(LIB) -r$(LIB) -n$(LIB) diff --git a/System/D5/sysinit.pas b/System/D5/sysinit.pas new file mode 100644 index 0000000..6e44c46 --- /dev/null +++ b/System/D5/sysinit.pas @@ -0,0 +1,334 @@ + +{*******************************************************} // XCL version of SysInit +{ } // unit. Created Jun-2000 +{ Borland Delphi Runtime Library } // (C) by Kladov Vladimir +{ System Initialization Unit } // +{ } // purpose: make XCL Delphi +{ Copyright (C) 1997,99 Inprise Corporation } // programs even smaller. +{ } // +{*******************************************************} // Changes are marked as {X} + +unit SysInit; + +interface + +{X} // if your app really need to localize resource, call: +{X} procedure UseLocalizeResources; + +var + ModuleIsLib: Boolean; { True if this module is a dll (a library or a package) } + ModuleIsPackage: Boolean; { True if this module is a package } + ModuleIsCpp: Boolean; { True if this module is compiled using C++ Builder } + TlsIndex: Integer; { Thread local storage index } + TlsLast: Byte; { Set by linker so its offset is last in TLS segment } + HInstance: LongWord; { Handle of this instance } + {$EXTERNALSYM HInstance} + (*$HPPEMIT 'namespace Sysinit' *) + (*$HPPEMIT '{' *) + (*$HPPEMIT 'extern PACKAGE HINSTANCE HInstance;' *) + (*$HPPEMIT '} /* namespace Sysinit */' *) + DllProc: Pointer; { Called whenever DLL entry point is called } + DataMark: Integer = 0; { Used to find the virtual base of DATA seg } + +procedure _GetTls; +function _InitPkg(Hinst: Integer; Reason: Integer; Resvd: Pointer): LongBool; stdcall; +procedure _InitLib; +procedure _InitExe; + +{ Invoked by C++ startup code to allow initialization of VCL global vars } +procedure VclInit(isDLL, isPkg: Boolean; hInst: LongInt; isGui: Boolean); cdecl; +procedure VclExit; cdecl; + +implementation + +{X- moved to System.pas (by A.Torgashin) + +const + kernel = 'kernel32.dll'; + +function FreeLibrary(ModuleHandle: Longint): LongBool; stdcall; + external kernel name 'FreeLibrary'; + +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 LocalAlloc(flags, size: Integer): Pointer; stdcall; + external kernel name 'LocalAlloc'; + +function LocalFree(addr: Pointer): Pointer; stdcall; + external kernel name 'LocalFree'; + +function TlsAlloc: Integer; stdcall; + external kernel name 'TlsAlloc'; + +function TlsFree(TlsIndex: Integer): Boolean; stdcall; + external kernel name 'TlsFree'; + +function TlsGetValue(TlsIndex: Integer): Pointer; stdcall; + external kernel name 'TlsGetValue'; + +function TlsSetValue(TlsIndex: Integer; TlsValue: Pointer): Boolean; stdcall; + external kernel name 'TlsSetValue'; + +function GetCommandLine: PChar; stdcall; + external kernel name 'GetCommandLineA'; + +{X+} + +const + tlsArray = $2C; { offset of tls array from FS: } + LMEM_ZEROINIT = $40; + +var + TlsBuffer: Pointer; + Module: TLibModule = ( + Next: nil; + Instance: 0; + CodeInstance: 0; + DataInstance: 0; + ResInstance: 0; + Reserved: 0); + +procedure InitThreadTLS; +var + p: Pointer; +begin + if @TlsLast = nil then + Exit; + if TlsIndex < 0 then + RunError(226); + p := LocalAlloc(LMEM_ZEROINIT, Longint(@TlsLast)); + if p = nil then + RunError(226) + else + TlsSetValue(TlsIndex, p); + tlsBuffer := p; +end; + + +procedure InitProcessTLS; +var + i: Integer; +begin + if @TlsLast = nil then + Exit; + i := TlsAlloc; + TlsIndex := i; + if i < 0 then + RunError(226); + InitThreadTLS; +end; + + +procedure ExitThreadTLS; +var + p: Pointer; +begin + if @TlsLast = nil then + Exit; + if TlsIndex >= 0 then begin + p := TlsGetValue(TlsIndex); + if p <> nil then + LocalFree(p); + end; +end; + + +procedure ExitProcessTLS; +begin + if @TlsLast = nil then + Exit; + ExitThreadTLS; + if TlsIndex >= 0 then + TlsFree(TlsIndex); +end; + + +procedure _GetTls; +asm + MOV CL,ModuleIsLib + MOV EAX,TlsIndex + TEST CL,CL + JNE @@isDll + MOV EDX,FS:tlsArray + MOV EAX,[EDX+EAX*4] + RET + +@@initTls: + CALL InitThreadTLS + MOV EAX,TlsIndex + PUSH EAX + CALL TlsGetValue + TEST EAX,EAX + JE @@RTM32 + RET + +@@RTM32: + MOV EAX, tlsBuffer + RET + +@@isDll: + PUSH EAX + CALL TlsGetValue + TEST EAX,EAX + JE @@initTls +end; + + +const + DLL_PROCESS_DETACH = 0; + DLL_PROCESS_ATTACH = 1; + DLL_THREAD_ATTACH = 2; + DLL_THREAD_DETACH = 3; + + TlsProc: array [DLL_PROCESS_DETACH..DLL_THREAD_DETACH] of procedure = + (ExitProcessTLS,InitProcessTLS,InitThreadTLS,ExitThreadTLS); + +procedure InitializeModule; +{X+ +var + FileName: array[0..260] of Char; +X-} +begin + {X+ + GetModuleFileName(HInstance, FileName, SizeOf(FileName)); + Module.ResInstance := LoadResourceModule(FileName); + if Module.ResInstance = 0 then + X-} + Module.ResInstance := Module.Instance; + RegisterModule(@Module); +end; + +procedure UseLocalizeResources; +var + FileName: array[0..260] of Char; +begin + GetModuleFileName(HInstance, FileName, SizeOf(FileName)); + Module.ResInstance := LoadResourceModule(FileName); + if Module.ResInstance = 0 then + Module.ResInstance := Module.Instance; +end; + +procedure UninitializeModule; +begin + UnregisterModule(@Module); + if Module.ResInstance <> Module.Instance then FreeLibrary(Module.ResInstance); +end; + +procedure VclInit(isDLL, isPkg: Boolean; hInst: LongInt; isGui: Boolean); cdecl; +begin + if isPkg then + begin + ModuleIsLib := True; + ModuleIsPackage := True; + end else + begin + IsLibrary := isDLL; + ModuleIsLib := isDLL; + ModuleIsPackage := False; //!!! really unnessesary since DATASEG should be nulled + end; + HInstance := hInst; + Module.Instance := hInst; + Module.CodeInstance := 0; + Module.DataInstance := 0; + ModuleIsCpp := True; + InitializeModule; + if not ModuleIsLib then + begin + Module.CodeInstance := FindHInstance(@VclInit); + Module.DataInstance := FindHInstance(@DataMark); +{X CmdLine := GetCommandLine; - converted to a function } + IsConsole := not isGui; + end; +end; + +procedure VclExit; cdecl; +var + P: procedure; +begin + if not ModuleIsLib then + while ExitProc <> nil do + begin + @P := ExitProc; + ExitProc := nil; + P; + end; + UnInitializeModule; +end; + +function _InitPkg(Hinst: Longint; Reason: Integer; Resvd: Pointer): Longbool; stdcall; +begin + ModuleIsLib := True; + ModuleIsPackage := True; + Module.Instance := Hinst; + Module.CodeInstance := 0; + Module.DataInstance := 0; + HInstance := Hinst; + if @TlsLast <> nil then + TlsProc[Reason]; + if Reason = DLL_PROCESS_ATTACH then + InitializeModule + else if Reason = DLL_PROCESS_DETACH then + UninitializeModule; + _InitPkg := True; +end; + + +procedure _InitLib; +asm + { -> EAX Inittable } + { [EBP+8] Hinst } + { [EBP+12] Reason } + { [EBP+16] Resvd } + + MOV EDX,offset Module + CMP dword ptr [EBP+12],DLL_PROCESS_ATTACH + JNE @@notInit + + PUSH EAX + PUSH EDX + MOV ModuleIsLib,1 + MOV ECX,[EBP+8] + MOV HInstance,ECX + MOV [EDX].TLibModule.Instance,ECX + MOV [EDX].TLibModule.CodeInstance,0 + MOV [EDX].TLibModule.DataInstance,0 + CALL InitializeModule + POP EDX + POP EAX + +@@notInit: + PUSH DllProc + MOV ECX,offset TlsProc + CALL _StartLib +end; + + +procedure _InitExe; +asm + { -> EAX Inittable } + +{ MOV ModuleIsLib,0 ; zero initialized anyway } + + PUSH EAX + + PUSH 0 + CALL GetModuleHandle + + MOV EDX,offset Module + PUSH EDX + MOV HInstance,EAX + MOV [EDX].TLibModule.Instance,EAX + MOV [EDX].TLibModule.CodeInstance,0 + MOV [EDX].TLibModule.DataInstance,0 + CALL InitializeModule + POP EDX + POP EAX + + CALL _StartExe +end; + +end. diff --git a/System/D5/system.pas b/System/D5/system.pas new file mode 100644 index 0000000..2985462 --- /dev/null +++ b/System/D5/system.pas @@ -0,0 +1,12006 @@ + +{*******************************************************} // XCL version of System +{ } // unit. Created Jun-2000 +{ Borland Delphi Runtime Library } // (C) by Kladov Vladimir +{ System Unit } // +{ } // purpose: make XCL Delphi +{ Copyright (C) 1988,99 Inprise Corporation } // programs even smaller. +{ } // +{*******************************************************} // Changes are marked as {X} + +unit System; { Predefined constants, types, procedures, } + { and functions (such as True, Integer, or } + { Writeln) do not have actual declarations.} + { Instead they are built into the compiler } + { and are treated as if they were declared } + { at the beginning of the System unit. } + +{$H+,I-,S-} + +{ L- should never be specified. + + The IDE needs to find debug hook (through the C++ + compiler sometimes) for integrated debugging to + function properly. + + ILINK will generate debug info for DebugHook if + the object module has not been compiled with debug info. + + ILINK will not generate debug info for DebugHook if + the object module has been compiled with debug info. + + Thus, the Pascal compiler must be responsible for + generating the debug information for that symbol + when a debug-enabled object file is produced. +} + +interface + +const + +{ Variant type codes (wtypes.h) } + + varEmpty = $0000; { vt_empty } + varNull = $0001; { vt_null } + varSmallint = $0002; { vt_i2 } + varInteger = $0003; { vt_i4 } + varSingle = $0004; { vt_r4 } + varDouble = $0005; { vt_r8 } + varCurrency = $0006; { vt_cy } + varDate = $0007; { vt_date } + varOleStr = $0008; { vt_bstr } + varDispatch = $0009; { vt_dispatch } + varError = $000A; { vt_error } + varBoolean = $000B; { vt_bool } + varVariant = $000C; { vt_variant } + varUnknown = $000D; { vt_unknown } + { vt_decimal $e } + { undefined $f } + { vt_i1 $10 } + varByte = $0011; { vt_ui1 } + { vt_ui2 $12 } + { vt_ui4 $13 } + { vt_i8 $14 } + { if adding new items, update varLast, BaseTypeMap and OpTypeMap } + varStrArg = $0048; { vt_clsid } + varString = $0100; { Pascal string; not OLE compatible } + varAny = $0101; + varTypeMask = $0FFF; + varArray = $2000; + varByRef = $4000; + +{ TVarRec.VType values } + + vtInteger = 0; + vtBoolean = 1; + vtChar = 2; + vtExtended = 3; + vtString = 4; + vtPointer = 5; + vtPChar = 6; + vtObject = 7; + vtClass = 8; + vtWideChar = 9; + vtPWideChar = 10; + vtAnsiString = 11; + vtCurrency = 12; + vtVariant = 13; + vtInterface = 14; + vtWideString = 15; + vtInt64 = 16; + +{ Virtual method table entries } + + vmtSelfPtr = -76; + vmtIntfTable = -72; + vmtAutoTable = -68; + vmtInitTable = -64; + vmtTypeInfo = -60; + vmtFieldTable = -56; + vmtMethodTable = -52; + vmtDynamicTable = -48; + vmtClassName = -44; + vmtInstanceSize = -40; + vmtParent = -36; + vmtSafeCallException = -32; + vmtAfterConstruction = -28; + vmtBeforeDestruction = -24; + vmtDispatch = -20; + vmtDefaultHandler = -16; + vmtNewInstance = -12; + vmtFreeInstance = -8; + vmtDestroy = -4; + + vmtQueryInterface = 0; + vmtAddRef = 4; + vmtRelease = 8; + vmtCreateObject = 12; + +type + + TObject = class; + + TClass = class of TObject; + + {$EXTERNALSYM HRESULT} + HRESULT = type Longint; { from WTYPES.H } + +{$EXTERNALSYM IUnknown} +{$EXTERNALSYM IDispatch} + + PGUID = ^TGUID; + TGUID = packed record + D1: LongWord; + D2: Word; + D3: Word; + D4: array[0..7] of Byte; + end; + + PInterfaceEntry = ^TInterfaceEntry; + TInterfaceEntry = packed record + IID: TGUID; + VTable: Pointer; + IOffset: Integer; + ImplGetter: Integer; + end; + + PInterfaceTable = ^TInterfaceTable; + TInterfaceTable = packed record + EntryCount: Integer; + Entries: array[0..9999] of TInterfaceEntry; + end; + + TObject = class + constructor Create; + procedure Free; + class function InitInstance(Instance: Pointer): TObject; + procedure CleanupInstance; + function ClassType: TClass; + class function ClassName: ShortString; + class function ClassNameIs(const Name: string): Boolean; + class function ClassParent: TClass; + class function ClassInfo: Pointer; + class function InstanceSize: Longint; + class function InheritsFrom(AClass: TClass): Boolean; + class function MethodAddress(const Name: ShortString): Pointer; + class function MethodName(Address: Pointer): ShortString; + function FieldAddress(const Name: ShortString): Pointer; + function GetInterface(const IID: TGUID; out Obj): Boolean; + class function GetInterfaceEntry(const IID: TGUID): PInterfaceEntry; + class function GetInterfaceTable: PInterfaceTable; + function SafeCallException(ExceptObject: TObject; + ExceptAddr: Pointer): HResult; virtual; + procedure AfterConstruction; virtual; + procedure BeforeDestruction; virtual; + procedure Dispatch(var Message); virtual; + procedure DefaultHandler(var Message); virtual; + class function NewInstance: TObject; virtual; + procedure FreeInstance; virtual; + destructor Destroy; virtual; + end; + + IUnknown = interface + ['{00000000-0000-0000-C000-000000000046}'] + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + end; + + IDispatch = interface(IUnknown) + ['{00020400-0000-0000-C000-000000000046}'] + function GetTypeInfoCount(out Count: Integer): HResult; stdcall; + function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall; + function GetIDsOfNames(const IID: TGUID; Names: Pointer; + NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall; + function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; + Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall; + end; + + TInterfacedObject = class(TObject, IUnknown) + protected + FRefCount: Integer; + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + public + procedure AfterConstruction; override; + procedure BeforeDestruction; override; + class function NewInstance: TObject; override; + property RefCount: Integer read FRefCount; + end; + + TInterfacedClass = class of TInterfacedObject; + + TVarArrayBound = packed record + ElementCount: Integer; + LowBound: Integer; + end; + + PVarArray = ^TVarArray; + TVarArray = packed record + DimCount: Word; + Flags: Word; + ElementSize: Integer; + LockCount: Integer; + Data: Pointer; + Bounds: array[0..255] of TVarArrayBound; + end; + + PVarData = ^TVarData; + TVarData = packed record + VType: Word; + Reserved1, Reserved2, Reserved3: Word; + case Integer of + varSmallint: (VSmallint: Smallint); + varInteger: (VInteger: Integer); + varSingle: (VSingle: Single); + varDouble: (VDouble: Double); + varCurrency: (VCurrency: Currency); + varDate: (VDate: Double); + varOleStr: (VOleStr: PWideChar); + varDispatch: (VDispatch: Pointer); + varError: (VError: LongWord); + varBoolean: (VBoolean: WordBool); + varUnknown: (VUnknown: Pointer); + varByte: (VByte: Byte); + varString: (VString: Pointer); + varAny: (VAny: Pointer); + varArray: (VArray: PVarArray); + varByRef: (VPointer: Pointer); + end; + + PShortString = ^ShortString; + PAnsiString = ^AnsiString; + PWideString = ^WideString; + PString = PAnsiString; + + PExtended = ^Extended; + PCurrency = ^Currency; + PVariant = ^Variant; + POleVariant = ^OleVariant; + PInt64 = ^Int64; + + TDateTime = type Double; + PDateTime = ^TDateTime; + + PVarRec = ^TVarRec; + TVarRec = record { do not pack this record; it is compiler-generated } + case Byte of + vtInteger: (VInteger: Integer; VType: Byte); + vtBoolean: (VBoolean: Boolean); + vtChar: (VChar: Char); + vtExtended: (VExtended: PExtended); + vtString: (VString: PShortString); + vtPointer: (VPointer: Pointer); + vtPChar: (VPChar: PChar); + vtObject: (VObject: TObject); + vtClass: (VClass: TClass); + vtWideChar: (VWideChar: WideChar); + vtPWideChar: (VPWideChar: PWideChar); + vtAnsiString: (VAnsiString: Pointer); + vtCurrency: (VCurrency: PCurrency); + vtVariant: (VVariant: PVariant); + vtInterface: (VInterface: Pointer); + vtWideString: (VWideString: Pointer); + vtInt64: (VInt64: PInt64); + end; + + PMemoryManager = ^TMemoryManager; + TMemoryManager = record + GetMem: function(Size: Integer): Pointer; + FreeMem: function(P: Pointer): Integer; + ReallocMem: function(P: Pointer; Size: Integer): Pointer; + end; + + THeapStatus = record + TotalAddrSpace: Cardinal; + TotalUncommitted: Cardinal; + TotalCommitted: Cardinal; + TotalAllocated: Cardinal; + TotalFree: Cardinal; + FreeSmall: Cardinal; + FreeBig: Cardinal; + Unused: Cardinal; + Overhead: Cardinal; + HeapErrorCode: Cardinal; + end; + + PackageUnitEntry = packed record + Init, FInit : procedure; + end; + + { Compiler generated table to be processed sequentially to init & finit all package units } + { Init: 0..Max-1; Final: Last Initialized..0 } + UnitEntryTable = array [0..9999999] of PackageUnitEntry; + PUnitEntryTable = ^UnitEntryTable; + + PackageInfoTable = packed record + UnitCount : Integer; { number of entries in UnitInfo array; always > 0 } + UnitInfo : PUnitEntryTable; + end; + + PackageInfo = ^PackageInfoTable; + + { Each package exports a '@GetPackageInfoTable' which can be used to retrieve } + { the table which contains compiler generated information about the package DLL } + GetPackageInfoTable = function : PackageInfo; + + + + + +const + advapi32 = 'advapi32.dll'; + kernel = 'kernel32.dll'; + user = 'user32.dll'; + oleaut = 'oleaut32.dll'; + +{X+ moved here from SysInit.pas - by advise of Alexey Torgashin - to avoid + creating of separate import block from kernel32.dll : } +////////////////////////////////////////////////////////////////////////// + +function FreeLibrary(ModuleHandle: Longint): LongBool; stdcall; + external kernel name 'FreeLibrary'; + +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 LocalAlloc(flags, size: Integer): Pointer; stdcall; + external kernel name 'LocalAlloc'; + +function LocalFree(addr: Pointer): Pointer; stdcall; + external kernel name 'LocalFree'; + +function TlsAlloc: Integer; stdcall; + external kernel name 'TlsAlloc'; + +function TlsFree(TlsIndex: Integer): Boolean; stdcall; + external kernel name 'TlsFree'; + +function TlsGetValue(TlsIndex: Integer): Pointer; stdcall; + external kernel name 'TlsGetValue'; + +function TlsSetValue(TlsIndex: Integer; TlsValue: Pointer): Boolean; stdcall; + external kernel name 'TlsSetValue'; + +function GetCommandLine: PChar; stdcall; + external kernel name 'GetCommandLineA'; + +{X-}////////////////////////////////////////////////////////////////////// + + + +{X} // following two procedures are optional and exclusive. +{X} // call it to provide error message: first - for GUI app, +{X} // second - for console app. +{X} procedure UseErrorMessageBox; +{X} procedure UseErrorMessageWrite; + +{X} // call following procedure to initialize Input and Output +{X} // - for console app only: +{X} procedure UseInputOutput; + +{X} // if your app uses FPU, call one of following procedures: +{X} procedure FpuInit; +{X} procedure FpuInitConsiderNECWindows; +{X} // the second additionally takes into consideration NEC +{X} // Windows keyboard (Japaneeze keyboard ???). + +{X} // following variables are converted to a functions: +{X} function CmdShow : Integer; +{X} function CmdLine : PChar; + +{X} procedure VarCastError; +{X} procedure VarInvalidOp; + +{X} procedure DummyProc; // empty procedure + +{X} procedure VariantAddRef; +{X} // procedure to refer to _VarAddRef if SysVarnt.pas is in use +{X} var VarAddRefProc : procedure = DummyProc; + +{X} procedure VariantClr; +{X} // procedure to refer to _VarClr if SysVarnt.pas is in use +{X} var VarClrProc : procedure = DummyProc; + +{X} procedure WStrAddRef; +{X} // procedure to refer to _WStrAddRef if SysWStr.pas is in use +{X} var WStrAddRefProc : procedure = DummyProc; + +{X} procedure WStrClr; +{X} // procedure to refer to _WStrClr if SysWStr.pas is in use +{X} var WStrClrProc : procedure = DummyProc; + +{X} procedure WStrArrayClr; +{X} // procedure to refer to _WStrArrayClr if SysWStr.pas is in use +{X} var WStrArrayClrProc : procedure = DummyProc; + +{X} // By default, now system memory management routines are used +{X} // to allocate memory. This can be slow sometimes, so if You +{X} // want to use custom Borland Delphi memory manager, call follow: +{X} procedure UseDelphiMemoryManager; +{X} function IsDelphiMemoryManagerSet : Boolean; +{X} function MemoryManagerNotUsed : Boolean; + +{X} // Standard Delphi units initialization/finalization uses +{X} // try-except and raise constructions, which leads to permanent +{X} // usage of all exception handling routines. In this XCL-aware +{X} // implementation, "light" version of initialization/finalization +{X} // is used by default. To use standard Delphi initialization and +{X} // finalization method, allowing to flow execution control even +{X} // in initalization sections, include reference to SysSfIni.pas +{X} // into uses clause *as first as possible*. +{X} procedure InitUnitsLight( Table : PUnitEntryTable; Idx, Count : Integer ); +{X} procedure InitUnitsHard( Table : PUnitEntryTable; Idx, Count : Integer ); +{X} var InitUnitsProc : procedure( Table : PUnitEntryTable; Idx, Count : Integer ) +{X} = InitUnitsLight; +{X} procedure FInitUnitsLight; +{X} procedure FInitUnitsHard; +{X} var FInitUnitsProc : procedure = FInitUnitsLight; +{X} procedure SetExceptionHandler; +{X} procedure UnsetExceptionHandler; +{X} var UnsetExceptionHandlerProc : procedure = DummyProc; + +{X} var UnloadResProc: procedure = DummyProc; + + + + + +function RaiseList: Pointer; { Stack of current exception objects } +function SetRaiseList(NewPtr: Pointer): Pointer; { returns previous value } +procedure SetInOutRes(NewValue: Integer); + +var + + ExceptProc: Pointer; { Unhandled exception handler } + ErrorProc: Pointer; { Error handler procedure } + ExceptClsProc: Pointer; { Map an OS Exception to a Delphi class reference } + ExceptObjProc: Pointer; { Map an OS Exception to a Delphi class instance } + ExceptionClass: TClass; { Exception base class (must be Exception) } + SafeCallErrorProc: Pointer; { Safecall error handler } + AssertErrorProc: Pointer; { Assertion error handler } + AbstractErrorProc: Pointer; { Abstract method error handler } + HPrevInst: LongWord; { Handle of previous instance - HPrevInst cannot be tested for multiple instances in Win32} + MainInstance: LongWord; { Handle of the main(.EXE) HInstance } + MainThreadID: LongWord; { ThreadID of thread that module was initialized in } + IsLibrary: Boolean; { True if module is a DLL } +{X CmdShow: Integer; { CmdShow parameter for CreateWindow - converted to a function X} +{X CmdLine: PChar; { Command line pointer - converted to a function X} + InitProc: Pointer; { Last installed initialization procedure } + ExitCode: Integer; { Program result } + ExitProc: Pointer; { Last installed exit procedure } + ErrorAddr: Pointer; { Address of run-time error } + RandSeed: Longint; { Base for random number generator } + IsConsole: Boolean; { True if compiled as console app } + IsMultiThread: Boolean; { True if more than one thread } + FileMode: Byte {X} = 2; { Standard mode for opening files } + Test8086: Byte {X} = 2; { Will always be 2 (386 or later) } + Test8087: Byte {X} = 3; { Will always be 3 (387 or later) } + TestFDIV: Shortint; { -1: Flawed Pentium, 0: Not determined, 1: Ok } + Input: Text; { Standard input } + Output: Text; { Standard output } + + ClearAnyProc: Pointer; { Handler clearing a varAny } + ChangeAnyProc: Pointer; { Handler to change any to variant } + RefAnyProc: Pointer; { Handler to add a reference to an varAny } + +var + Default8087CW: Word = $1332;{ Default 8087 control word. FPU control + register is set to this value. + CAUTION: Setting this to an invalid value + could cause unpredictable behavior. } + + HeapAllocFlags: Word = 2; { Heap allocation flags, gmem_Moveable } + DebugHook: Byte = 0; { 1 to notify debugger of non-Delphi exceptions + >1 to notify debugger of exception unwinding } + JITEnable: Byte = 0; { 1 to call UnhandledExceptionFilter if the exception + is not a Pascal exception. + >1 to call UnhandledExceptionFilter for all exceptions } + NoErrMsg: Boolean = False; { True causes the base RTL to not display the message box + when a run-time error occurs } + +var + (* {X-} moved to SysVarnt.pas + + Unassigned: Variant; { Unassigned standard constant } + Null: Variant; { Null standard constant } + EmptyParam: OleVariant; { "Empty parameter" standard constant which can be + passed as an optional parameter on a dual interface. } + {X+} *) + + AllocMemCount: Integer; { Number of allocated memory blocks } + AllocMemSize: Integer; { Total size of allocated memory blocks } + +{ Memory manager support } + +procedure GetMemoryManager(var MemMgr: TMemoryManager); +procedure SetMemoryManager(const MemMgr: TMemoryManager); +{X} // following function is replaced with pointer to one +{X} // (initialized by another) +{X} //function IsMemoryManagerSet: Boolean; +var IsMemoryManagerSet : function : Boolean = MemoryManagerNotUsed; + +function SysGetMem(Size: Integer): Pointer; +function SysFreeMem(P: Pointer): Integer; +function SysReallocMem(P: Pointer; Size: Integer): Pointer; + +function GetHeapStatus: THeapStatus; + +{ Thread support } +type + TThreadFunc = function(Parameter: Pointer): Integer; + +function BeginThread(SecurityAttributes: Pointer; StackSize: LongWord; + ThreadFunc: TThreadFunc; Parameter: Pointer; CreationFlags: LongWord; + var ThreadId: LongWord): Integer; + +procedure EndThread(ExitCode: Integer); + +{ Standard procedures and functions } + +procedure _ChDir(const S: string); +procedure __Flush(var F: Text); +procedure _LGetDir(D: Byte; var S: string); +procedure _SGetDir(D: Byte; var S: ShortString); +function IOResult: Integer; +procedure _MkDir(const S: string); +procedure Move(const Source; var Dest; Count: Integer); +function ParamCount: Integer; +function ParamStr(Index: Integer): string; +procedure Randomize; +procedure _RmDir(const S: string); +function UpCase(Ch: Char): Char; + +{ Control 8087 control word } + +procedure Set8087CW(NewCW: Word); + +{ Wide character support procedures and functions } + +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; + +{ OLE string support procedures and functions } + +function OleStrToString(Source: PWideChar): string; +procedure OleStrToStrVar(Source: PWideChar; var Dest: string); +function StringToOleStr(const Source: string): PWideChar; + +{ Variant support procedures and functions } + +procedure _VarClear(var V : Variant); +procedure _VarCopy(var Dest : Variant; const Source: Variant); +procedure _VarCast(var Dest : Variant; const Source: Variant; VarType: Integer); +procedure _VarCastOle(var Dest : Variant; const Source: Variant; VarType: Integer); +procedure VarCopyNoInd(var Dest: Variant; const Source: Variant); +function VarType(const V: Variant): Integer; +function VarAsType(const V: Variant; VarType: Integer): Variant; +function VarIsEmpty(const V: Variant): Boolean; +function VarIsNull(const V: Variant): Boolean; +function VarToStr(const V: Variant): string; +function VarFromDateTime(DateTime: TDateTime): Variant; +function VarToDateTime(const V: Variant): TDateTime; + +{ Variant array support procedures and functions } + +function VarArrayCreate(const Bounds: array of Integer; + VarType: Integer): Variant; +function VarArrayOf(const Values: array of Variant): Variant; +procedure _VarArrayRedim(var A : Variant; HighBound: Integer); +function VarArrayDimCount(const A: Variant): Integer; +function VarArrayLowBound(const A: Variant; Dim: Integer): Integer; +function VarArrayHighBound(const A: Variant; Dim: Integer): Integer; +function VarArrayLock(const A: Variant): Pointer; +procedure VarArrayUnlock(const A: Variant); +function VarArrayRef(const A: Variant): Variant; +function VarIsArray(const A: Variant): Boolean; + +{ Variant IDispatch call support } + +procedure _DispInvokeError; + +var + VarDispProc: Pointer = @_DispInvokeError; + DispCallByIDProc: Pointer = @_DispInvokeError; + +{ Package/Module registration and unregistration } + +type + PLibModule = ^TLibModule; + TLibModule = record + Next: PLibModule; + Instance: LongWord; + CodeInstance: LongWord; + DataInstance: LongWord; + ResInstance: LongWord; + Reserved: Integer; + end; + + TEnumModuleFunc = function (HInstance: Integer; Data: Pointer): Boolean; + {$EXTERNALSYM TEnumModuleFunc} + TEnumModuleFuncLW = function (HInstance: LongWord; Data: Pointer): Boolean; + {$EXTERNALSYM TEnumModuleFuncLW} + TModuleUnloadProc = procedure (HInstance: Integer); + {$EXTERNALSYM TModuleUnloadProc} + TModuleUnloadProcLW = procedure (HInstance: LongWord); + {$EXTERNALSYM TModuleUnloadProcLW} + + PModuleUnloadRec = ^TModuleUnloadRec; + TModuleUnloadRec = record + Next: PModuleUnloadRec; + Proc: TModuleUnloadProcLW; + end; + +var + LibModuleList: PLibModule = nil; + ModuleUnloadList: PModuleUnloadRec = nil; + +procedure RegisterModule(LibModule: PLibModule); +{X procedure UnregisterModule(LibModule: PLibModule); -replaced with pointer to procedure } +{X} procedure UnregisterModuleLight(LibModule: PLibModule); +{X} procedure UnregisterModuleSafely(LibModule: PLibModule); +var UnregisterModule : procedure(LibModule: PLibModule) = UnregisterModuleLight; +function FindHInstance(Address: Pointer): LongWord; +function FindClassHInstance(ClassType: TClass): LongWord; +function FindResourceHInstance(Instance: LongWord): LongWord; +function LoadResourceModule(ModuleName: PChar): LongWord; +procedure EnumModules(Func: TEnumModuleFunc; Data: Pointer); overload; +procedure EnumResourceModules(Func: TEnumModuleFunc; Data: Pointer); overload; +procedure EnumModules(Func: TEnumModuleFuncLW; Data: Pointer); overload; +procedure EnumResourceModules(Func: TEnumModuleFuncLW; Data: Pointer); overload; +procedure AddModuleUnloadProc(Proc: TModuleUnloadProc); overload; +procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProc); overload; +procedure AddModuleUnloadProc(Proc: TModuleUnloadProcLW); overload; +procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProcLW); overload; + +{ ResString support function/record } + +type + PResStringRec = ^TResStringRec; + TResStringRec = packed record + Module: ^Longint; + Identifier: Integer; + end; + +function LoadResString(ResStringRec: PResStringRec): string; + +{ Procedures and functions that need compiler magic } + +procedure _COS; +procedure _EXP; +procedure _INT; +procedure _SIN; +procedure _FRAC; +procedure _ROUND; +procedure _TRUNC; + +procedure _AbstractError; +procedure _Assert(const Message, Filename: AnsiString; LineNumber: Integer); +procedure _Append; +procedure _Assign(var T: Text; S: ShortString); +procedure _BlockRead; +procedure _BlockWrite; +procedure _Close; +procedure _PStrCat; +procedure _PStrNCat; +procedure _PStrCpy; +procedure _PStrNCpy; +procedure _EofFile; +procedure _EofText; +procedure _Eoln; +procedure _Erase; +procedure _FilePos; +procedure _FileSize; +procedure _FillChar; +procedure _FreeMem; +procedure _GetMem; +procedure _ReallocMem; +procedure _Halt; +procedure _Halt0; +procedure _Mark; +procedure _PStrCmp; +procedure _AStrCmp; +procedure _RandInt; +procedure _RandExt; +procedure _ReadRec; +procedure _ReadChar; +procedure _ReadLong; +procedure _ReadString; +procedure _ReadCString; +procedure _ReadLString; +procedure _ReadExt; +procedure _ReadLn; +procedure _Rename; +procedure _Release; +procedure _ResetText(var T: Text); +procedure _ResetFile; +procedure _RewritText(var T: Text); +procedure _RewritFile; +procedure _RunError; +procedure _Run0Error; +procedure _Seek; +procedure _SeekEof; +procedure _SeekEoln; +procedure _SetTextBuf; +procedure _StrLong; +procedure _Str0Long; +procedure _Truncate; +procedure _ValLong; +procedure _WriteRec; +procedure _WriteChar; +procedure _Write0Char; +procedure _WriteBool; +procedure _Write0Bool; +procedure _WriteLong; +procedure _Write0Long; +procedure _WriteString; +procedure _Write0String; +procedure _WriteCString; +procedure _Write0CString; +procedure _WriteLString; +procedure _Write0LString; +function _WriteVariant(var T: Text; const V: Variant; Width: Integer): Pointer; +function _Write0Variant(var T: Text; const V: Variant): Pointer; +procedure _Write2Ext; +procedure _Write1Ext; +procedure _Write0Ext; +procedure _WriteLn; + +procedure __CToPasStr; +procedure __CLenToPasStr; +procedure __ArrayToPasStr; +procedure __PasToCStr; + +procedure __IOTest; +procedure _Flush(var F: Text); + +procedure _SetElem; +procedure _SetRange; +procedure _SetEq; +procedure _SetLe; +procedure _SetIntersect; +procedure _SetIntersect3; { BEG only } +procedure _SetUnion; +procedure _SetUnion3; { BEG only } +procedure _SetSub; +procedure _SetSub3; { BEG only } +procedure _SetExpand; + +procedure _Str2Ext; +procedure _Str0Ext; +procedure _Str1Ext; +procedure _ValExt; +procedure _Pow10; +procedure _Real2Ext; +procedure _Ext2Real; + +procedure _ObjSetup; +procedure _ObjCopy; +procedure _Fail; +procedure _BoundErr; +procedure _IntOver; +procedure _StartExe; +procedure _StartLib; +procedure _PackageLoad (const Table : PackageInfo); +procedure _PackageUnload(const Table : PackageInfo); +procedure _InitResStrings; +procedure _InitResStringImports; +procedure _InitImports; +procedure _InitWideStrings; + +procedure _ClassCreate; +procedure _ClassDestroy; +procedure _AfterConstruction; +procedure _BeforeDestruction; +procedure _IsClass; +procedure _AsClass; + +procedure _RaiseExcept; +procedure _RaiseAgain; +procedure _DoneExcept; +procedure _TryFinallyExit; + +procedure _CallDynaInst; +procedure _CallDynaClass; +procedure _FindDynaInst; +procedure _FindDynaClass; + +procedure _LStrClr(var S: AnsiString); +procedure _LStrArrayClr{var str: AnsiString; cnt: longint}; +procedure _LStrAsg{var dest: AnsiString; source: AnsiString}; +procedure _LStrLAsg{var dest: AnsiString; source: AnsiString}; +procedure _LStrFromPCharLen(var Dest: AnsiString; Source: PAnsiChar; Length: 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{str: 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}; +procedure _LStrAddRef{str: AnsiString}; +procedure _LStrToPChar{str: AnsiString): PChar}; +procedure _Copy{ s : ShortString; index, count : Integer ) : ShortString}; +procedure _Delete{ var s : openstring; index, count : Integer }; +procedure _Insert{ source : ShortString; var s : openstring; index : Integer }; +procedure _Pos{ substr : ShortString; s : ShortString ) : Integer}; +procedure _SetLength{var s: ShortString; newLength: Integer}; +procedure _SetString{var s: ShortString: buffer: PChar; len: Integer}; + +procedure UniqueString(var str: string); +procedure _NewAnsiString{length: Longint}; { for debugger purposes only } + +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 }; + +procedure _WStrClr(var S: WideString); +procedure _WStrArrayClr(var StrArray; Count: Integer); +procedure _WStrAsg(var Dest: WideString; const Source: WideString); +procedure _WStrFromPCharLen(var Dest: WideString; Source: PAnsiChar; Length: Integer); +procedure _WStrFromPWCharLen(var Dest: WideString; Source: PWideChar; Length: 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 _NewWideString(Length: Integer): PWideChar; +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; +procedure _WStrAddRef{var str: WideString}; + +procedure _Initialize; +procedure _InitializeArray; +procedure _InitializeRecord; +procedure _Finalize; +procedure _FinalizeArray; +procedure _FinalizeRecord; +procedure _AddRef; +procedure _AddRefArray; +procedure _AddRefRecord; +procedure _CopyArray; +procedure _CopyRecord; +procedure _CopyObject; + +procedure _New; +procedure _Dispose; + +procedure _DispInvoke; cdecl; +procedure _IntfDispCall; cdecl; +procedure _IntfVarCall; cdecl; + +procedure _VarToInt; +procedure _VarToBool; +procedure _VarToReal; +procedure _VarToCurr; +procedure _VarToPStr(var S; const V: Variant); +procedure _VarToLStr(var S: string; const V: Variant); +procedure _VarToWStr(var S: WideString; const V: Variant); +procedure _VarToIntf(var Unknown: IUnknown; const V: Variant); +procedure _VarToDisp(var Dispatch: IDispatch; const V: Variant); +procedure _VarToDynArray(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer); + +procedure _VarFromInt; +procedure _VarFromBool; +procedure _VarFromReal; +procedure _VarFromTDateTime; +procedure _VarFromCurr; +procedure _VarFromPStr(var V: Variant; const Value: ShortString); +procedure _VarFromLStr(var V: Variant; const Value: string); +procedure _VarFromWStr(var V: Variant; const Value: WideString); +procedure _VarFromIntf(var V: Variant; const Value: IUnknown); +procedure _VarFromDisp(var V: Variant; const Value: IDispatch); +procedure _VarFromDynArray(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer); +procedure _OleVarFromPStr(var V: OleVariant; const Value: ShortString); +procedure _OleVarFromLStr(var V: OleVariant; const Value: string); +procedure _OleVarFromVar(var V: OleVariant; const Value: Variant); + +procedure _VarAdd; +procedure _VarSub; +procedure _VarMul; +procedure _VarDiv; +procedure _VarMod; +procedure _VarAnd; +procedure _VarOr; +procedure _VarXor; +procedure _VarShl; +procedure _VarShr; +procedure _VarRDiv; +procedure _VarCmp; + +procedure _VarNeg; +procedure _VarNot; + +procedure _VarCopyNoInd; +procedure _VarClr; +procedure _VarAddRef; + +{ 64-bit Integer helper routines } + +procedure __llmul; +procedure __lldiv; +procedure __lludiv; +procedure __llmod; +procedure __llmulo; +procedure __lldivo; +procedure __llmodo; +procedure __llumod; +procedure __llshl; +procedure __llushr; +procedure _WriteInt64; +procedure _Write0Int64; +procedure _ReadInt64; +function _StrInt64(val: Int64; width: Integer): ShortString; +function _Str0Int64(val: Int64): ShortString; +function _ValInt64(const s: AnsiString; var code: Integer): Int64; + +{ Dynamic array helper functions } + +procedure _DynArrayHigh; +procedure _DynArrayClear(var a: Pointer; typeInfo: Pointer); +procedure _DynArrayLength; +procedure _DynArraySetLength; +procedure _DynArrayCopy(a: Pointer; typeInfo: Pointer; var Result: Pointer); +procedure _DynArrayCopyRange(a: Pointer; typeInfo: Pointer; index, count : Integer; var Result: Pointer); +procedure _DynArrayAsg; +procedure _DynArrayAddRef; +procedure DynArrayToVariant(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer); +procedure DynArrayFromVariant(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer); + +procedure _IntfClear(var Dest: IUnknown); +procedure _IntfCopy(var Dest: IUnknown; const Source: IUnknown); +procedure _IntfCast(var Dest: IUnknown; const Source: IUnknown; const IID: TGUID); +procedure _IntfAddRef(const Dest: IUnknown); + +function _VarArrayGet(var A: Variant; IndexCount: Integer; + Indices: Integer): Variant; cdecl; +procedure _VarArrayPut(var A: Variant; const Value: Variant; + IndexCount: Integer; Indices: Integer); cdecl; + +procedure _HandleAnyException; +procedure _HandleOnException; +procedure _HandleFinally; +procedure _HandleAutoException; + +procedure _FSafeDivide; +procedure _FSafeDivideR; + +procedure _CheckAutoResult; + +procedure FPower10; + +procedure TextStart; + +function CompToDouble(acomp: Comp): Double; cdecl; +procedure DoubleToComp(adouble: Double; var result: Comp); cdecl; +function CompToCurrency(acomp: Comp): Currency; cdecl; +procedure CurrencyToComp(acurrency: 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; + +(* =================================================================== *) + +implementation + +uses + SysInit; + +{ Internal runtime error codes } + +const + reOutOfMemory = 1; + reInvalidPtr = 2; + reDivByZero = 3; + reRangeError = 4; + reIntOverflow = 5; + reInvalidOp = 6; + reZeroDivide = 7; + reOverflow = 8; + reUnderflow = 9; + reInvalidCast = 10; + reAccessViolation = 11; + reStackOverflow = 12; + reControlBreak = 13; + rePrivInstruction = 14; + reVarTypeCast = 15; + reVarInvalidOp = 16; + reVarDispatch = 17; + reVarArrayCreate = 18; + reVarNotArray = 19; + reVarArrayBounds = 20; + reAssertionFailed = 21; + reExternalException = 22; { not used here; in SysUtils } + reIntfCastError = 23; + reSafeCallError = 24; + +{ this procedure should be at the very beginning of the } +{ text segment. it is only used by _RunError to find } +{ start address of the text segment so a nice error } +{ location can be shown. } + +procedure TextStart; +begin +end; + +{ ----------------------------------------------------- } +{ NT Calls necessary for the .asm files } +{ ----------------------------------------------------- } + +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; + + + + +procedure CloseHandle; external kernel name 'CloseHandle'; +procedure CreateFileA; external kernel name 'CreateFileA'; +procedure DeleteFileA; external kernel name 'DeleteFileA'; +procedure GetFileType; external kernel name 'GetFileType'; +procedure GetSystemTime; external kernel name 'GetSystemTime'; +procedure GetFileSize; external kernel name 'GetFileSize'; +procedure GetStdHandle; external kernel name 'GetStdHandle'; +//procedure GetStartupInfo; external kernel name 'GetStartupInfo'; +procedure MoveFileA; external kernel name 'MoveFileA'; +procedure RaiseException; external kernel name 'RaiseException'; +procedure ReadFile; external kernel name 'ReadFile'; +procedure RtlUnwind; external kernel name 'RtlUnwind'; +procedure SetEndOfFile; external kernel name 'SetEndOfFile'; +procedure SetFilePointer; external kernel name 'SetFilePointer'; +procedure UnhandledExceptionFilter; external kernel name 'UnhandledExceptionFilter'; +procedure WriteFile; 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'; + +{X} //function FreeLibrary(ModuleHandle: Longint): LongBool; stdcall; +{X} // external kernel name 'FreeLibrary'; + +{X} //function GetCommandLine: PChar; stdcall; +{X} // external kernel name 'GetCommandLineA'; + +function GetCurrentDirectory(BufSize: Integer; Buffer: PChar): Integer; stdcall; + external kernel name 'GetCurrentDirectoryA'; + +function GetLastError: Integer; stdcall; + external kernel name 'GetLastError'; + +function GetLocaleInfo(Locale: Longint; LCType: Longint; lpLCData: PChar; cchData: Integer): Integer; stdcall; + external kernel name 'GetLocaleInfoA'; + +{X} //function GetModuleFileName(Module: Integer; Filename: PChar; +{X} // Size: Integer): Integer; stdcall; +{X} // external kernel name 'GetModuleFileNameA'; + +{X} //function GetModuleHandle(ModuleName: PChar): Integer; stdcall; +{X} // 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 lstrlen(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'; + +//procedure VariantInit(var V: Variant); stdcall; +// external oleaut name 'VariantInit'; + +function VariantClear(var V: Variant): Integer; stdcall; + external oleaut name 'VariantClear'; + +function VariantCopy(var Dest: Variant; const Source: Variant): Integer; stdcall; + external oleaut name 'VariantCopy'; + +function VariantCopyInd(var Dest: Variant; const Source: Variant): Integer; stdcall; + external oleaut name 'VariantCopyInd'; + +//function VariantChangeType(var Dest: Variant; const Source: Variant; +// Flags: Word; VarType: Word): Integer; stdcall; +// external oleaut name 'VariantChangeType'; + +function VariantChangeTypeEx(var Dest: Variant; const Source: Variant; + LCID: Integer; Flags: Word; VarType: Word): Integer; stdcall; + external oleaut name 'VariantChangeTypeEx'; + +function SafeArrayCreate(VarType, DimCount: Integer; + const Bounds): PVarArray; stdcall; + external oleaut name 'SafeArrayCreate'; + +function SafeArrayRedim(VarArray: PVarArray; + var NewBound: TVarArrayBound): Integer; stdcall; + external oleaut name 'SafeArrayRedim'; + +function SafeArrayGetLBound(VarArray: PVarArray; Dim: Integer; + var LBound: Integer): Integer; stdcall; + external oleaut name 'SafeArrayGetLBound'; + +function SafeArrayGetUBound(VarArray: PVarArray; Dim: Integer; + var UBound: Integer): Integer; stdcall; + external oleaut name 'SafeArrayGetUBound'; + +function SafeArrayAccessData(VarArray: PVarArray; + var Data: Pointer): Integer; stdcall; + external oleaut name 'SafeArrayAccessData'; + +function SafeArrayUnaccessData(VarArray: PVarArray): Integer; stdcall; + external oleaut name 'SafeArrayUnaccessData'; + +function SafeArrayGetElement(VarArray: PVarArray; Indices, + Data: Pointer): Integer; stdcall; + external oleaut name 'SafeArrayGetElement'; + +function SafeArrayPtrOfIndex(VarArray: PVarArray; Indices: Pointer; + var pvData: Pointer): HResult; stdcall; + external oleaut name 'SafeArrayPtrOfIndex'; + +function SafeArrayPutElement(VarArray: PVarArray; Indices, + Data: Pointer): Integer; stdcall; + external oleaut name 'SafeArrayPutElement'; + +function InterlockedIncrement(var Addend: Integer): Integer; stdcall; + external kernel name 'InterlockedIncrement'; + +function InterlockedDecrement(var Addend: Integer): Integer; stdcall; + external kernel name 'InterlockedDecrement'; + +var SaveCmdShow : Integer = -1; +function CmdShow: Integer; +var + SI: TStartupInfo; +begin + if SaveCmdShow < 0 then + begin + SaveCmdShow := 10; { SW_SHOWDEFAULT } + GetStartupInfo(SI); + if SI.dwFlags and 1 <> 0 then { STARTF_USESHOWWINDOW } + SaveCmdShow := SI.wShowWindow; + end; + Result := SaveCmdShow; +end; + +{ ----------------------------------------------------- } +{ Memory manager } +{ ----------------------------------------------------- } + +procedure Error(errorCode: Byte); forward; + +{$I GETMEM.INC } + +{X- by default, system memory allocation routines (API calls) + are used. To use Inprise's memory manager (Delphi standard) + call UseDelphiMemoryManager procedure. } +var + MemoryManager: TMemoryManager = ( + GetMem: DfltGetMem; + FreeMem: DfltFreeMem; + ReallocMem: DfltReallocMem); + +const + DelphiMemoryManager: TMemoryManager = ( + GetMem: SysGetMem; + FreeMem: SysFreeMem; + ReallocMem: SysReallocMem); + +procedure UseDelphiMemoryManager; +begin + IsMemoryManagerSet := IsDelphiMemoryManagerSet; + SetMemoryManager( DelphiMemoryManager ); +end; +{X+} + +procedure _GetMem; +asm + TEST EAX,EAX + JE @@1 + CALL MemoryManager.GetMem + OR EAX,EAX + JE @@2 +@@1: RET +@@2: MOV AL,reOutOfMemory + JMP Error +end; + +procedure _FreeMem; +asm + TEST EAX,EAX + JE @@1 + CALL MemoryManager.FreeMem + OR EAX,EAX + JNE @@2 +@@1: RET +@@2: MOV AL,reInvalidPtr + JMP Error +end; + +procedure _ReallocMem; +asm + MOV ECX,[EAX] + TEST ECX,ECX + JE @@alloc + TEST EDX,EDX + JE @@free +@@resize: + PUSH EAX + MOV EAX,ECX + CALL MemoryManager.ReallocMem + POP ECX + OR EAX,EAX + JE @@allocError + MOV [ECX],EAX + RET +@@freeError: + MOV AL,reInvalidPtr + JMP Error +@@free: + MOV [EAX],EDX + MOV EAX,ECX + CALL MemoryManager.FreeMem + OR EAX,EAX + JNE @@freeError + RET +@@allocError: + MOV AL,reOutOfMemory + JMP Error +@@alloc: + TEST EDX,EDX + JE @@exit + PUSH EAX + MOV EAX,EDX + CALL MemoryManager.GetMem + POP ECX + OR EAX,EAX + JE @@allocError + MOV [ECX],EAX +@@exit: +end; + +procedure GetMemoryManager(var MemMgr: TMemoryManager); +begin + MemMgr := MemoryManager; +end; + +procedure SetMemoryManager(const MemMgr: TMemoryManager); +begin + MemoryManager := MemMgr; +end; + +//{X} - function is replaced with pointer to one. +// function IsMemoryManagerSet: Boolean; +function IsDelphiMemoryManagerSet; +begin + with MemoryManager do + Result := (@GetMem <> @SysGetMem) or (@FreeMem <> @SysFreeMem) or + (@ReallocMem <> @SysReallocMem); +end; + +{X+ always returns False. Initial handler for IsMemoryManagerSet } +function MemoryManagerNotUsed : Boolean; +begin + Result := False; +end; +{X-} + +threadvar + RaiseListPtr: pointer; + InOutRes: Integer; + +function RaiseList: Pointer; +asm + CALL SysInit.@GetTLS + MOV EAX, [EAX].RaiseListPtr +end; + +function SetRaiseList(NewPtr: Pointer): Pointer; +asm + MOV ECX, EAX + CALL SysInit.@GetTLS + MOV EDX, [EAX].RaiseListPtr + MOV [EAX].RaiseListPtr, ECX + MOV EAX, EDX +end; + +{ ----------------------------------------------------- } +{ local functions & procedures of the system unit } +{ ----------------------------------------------------- } + +procedure Error(errorCode: Byte); +asm + AND EAX,127 + MOV ECX,ErrorProc + TEST ECX,ECX + JE @@term + POP EDX + CALL ECX +@@term: + DEC EAX + MOV AL,byte ptr @@errorTable[EAX] + JNS @@skip + CALL SysInit.@GetTLS + MOV EAX,[EAX].InOutRes +@@skip: + JMP _RunError + +@@errorTable: + DB 203 { reOutOfMemory } + DB 204 { reInvalidPtr } + DB 200 { reDivByZero } + DB 201 { reRangeError } +{ 210 abstract error } + DB 215 { reIntOverflow } + DB 207 { reInvalidOp } + DB 200 { reZeroDivide } + DB 205 { reOverflow } + DB 206 { reUnderflow } + DB 219 { reInvalidCast } + DB 216 { Access violation } + DB 202 { Stack overflow } + DB 217 { Control-C } + DB 218 { Privileged instruction } + DB 220 { Invalid variant type cast } + DB 221 { Invalid variant operation } + DB 222 { No variant method call dispatcher } + DB 223 { Cannot create variant array } + DB 224 { Variant does not contain an array } + DB 225 { Variant array bounds error } +{ 226 thread init failure } + DB 227 { reAssertionFailed } + DB 0 { reExternalException not used here; in SysUtils } + DB 228 { reIntfCastError } + DB 229 { reSafeCallError } +end; + +procedure __IOTest; +asm + PUSH EAX + PUSH EDX + PUSH ECX + CALL SysInit.@GetTLS + CMP [EAX].InOutRes,0 + POP ECX + POP EDX + POP EAX + JNE @error + RET +@error: + XOR EAX,EAX + JMP Error +end; + +procedure SetInOutRes; +asm + PUSH EAX + CALL SysInit.@GetTLS + POP [EAX].InOutRes +end; + + +procedure InOutError; +asm + CALL GetLastError + JMP SetInOutRes +end; + +procedure _ChDir(const S: string); +begin + if not SetCurrentDirectory(PChar(S)) then InOutError; +end; + +procedure _Copy{ s : ShortString; index, count : Integer ) : ShortString}; +asm +{ ->EAX Source string } +{ EDX index } +{ ECX count } +{ [ESP+4] Pointer to result string } + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,[ESP+8+4] + + XOR EAX,EAX + OR AL,[ESI] + JZ @@srcEmpty + +{ limit index to satisfy 1 <= index <= Length(src) } + + TEST EDX,EDX + JLE @@smallInx + CMP EDX,EAX + JG @@bigInx +@@cont1: + +{ limit count to satisfy 0 <= count <= Length(src) - index + 1 } + + SUB EAX,EDX { calculate Length(src) - index + 1 } + INC EAX + TEST ECX,ECX + JL @@smallCount + CMP ECX,EAX + JG @@bigCount +@@cont2: + + ADD ESI,EDX + + MOV [EDI],CL + INC EDI + REP MOVSB + JMP @@exit + +@@smallInx: + MOV EDX,1 + JMP @@cont1 +@@bigInx: +{ MOV EDX,EAX + JMP @@cont1 } +@@smallCount: + XOR ECX,ECX + JMP @@cont2 +@@bigCount: + MOV ECX,EAX + JMP @@cont2 +@@srcEmpty: + MOV [EDI],AL +@@exit: + POP EDI + POP ESI + RET 4 +end; + +procedure _Delete{ var s : openstring; index, count : Integer }; +asm +{ ->EAX Pointer to s } +{ EDX index } +{ ECX count } + + PUSH ESI + PUSH EDI + + MOV EDI,EAX + + XOR EAX,EAX + MOV AL,[EDI] + +{ if index not in [1 .. Length(s)] do nothing } + + TEST EDX,EDX + JLE @@exit + CMP EDX,EAX + JG @@exit + +{ limit count to [0 .. Length(s) - index + 1] } + + TEST ECX,ECX + JLE @@exit + SUB EAX,EDX { calculate Length(s) - index + 1 } + INC EAX + CMP ECX,EAX + JLE @@1 + MOV ECX,EAX +@@1: + SUB [EDI],CL { reduce Length(s) by count } + ADD EDI,EDX { point EDI to first char to be deleted } + LEA ESI,[EDI+ECX] { point ESI to first char to be preserved } + SUB EAX,ECX { #chars = Length(s) - index + 1 - count } + MOV ECX,EAX + + REP MOVSB + +@@exit: + POP EDI + POP ESI +end; + +procedure __Flush( var f : Text ); +external; { Assign } + +procedure _Flush( var f : Text ); +external; { Assign } + +procedure _LGetDir(D: Byte; var S: string); +var + Drive: array[0..3] of Char; + DirBuf, SaveBuf: array[0..259] of Char; +begin + if D <> 0 then + begin + Drive[0] := Chr(D + Ord('A') - 1); + Drive[1] := ':'; + Drive[2] := #0; + GetCurrentDirectory(SizeOf(SaveBuf), SaveBuf); + SetCurrentDirectory(Drive); + end; + GetCurrentDirectory(SizeOf(DirBuf), DirBuf); + if D <> 0 then SetCurrentDirectory(SaveBuf); + S := DirBuf; +end; + +procedure _SGetDir(D: Byte; var S: ShortString); +var + L: string; +begin + GetDir(D, L); + S := L; +end; + +procedure _Insert{ source : ShortString; var s : openstring; index : Integer }; +asm +{ ->EAX Pointer to source string } +{ EDX Pointer to destination string } +{ ECX Length of destination string } +{ [ESP+4] Index } + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH ECX + MOV ECX,[ESP+16+4] + SUB ESP,512 { VAR buf: ARRAY [0..511] of Char } + + MOV EBX,EDX { save pointer to s for later } + MOV ESI,EDX + + XOR EDX,EDX + MOV DL,[ESI] + INC ESI + +{ limit index to [1 .. Length(s)+1] } + + INC EDX + TEST ECX,ECX + JLE @@smallInx + CMP ECX,EDX + JG @@bigInx +@@cont1: + DEC EDX { EDX = Length(s) } + { EAX = Pointer to src } + { ESI = EBX = Pointer to s } + { ECX = Index } + +{ copy index-1 chars from s to buf } + + MOV EDI,ESP + DEC ECX + SUB EDX,ECX { EDX = remaining length of s } + REP MOVSB + +{ copy Length(src) chars from src to buf } + + XCHG EAX,ESI { save pointer into s, point ESI to src } + MOV CL,[ESI] { ECX = Length(src) (ECX was zero after rep) } + INC ESI + REP MOVSB + +{ copy remaining chars of s to buf } + + MOV ESI,EAX { restore pointer into s } + MOV ECX,EDX { copy remaining bytes of s } + REP MOVSB + +{ calculate total chars in buf } + + SUB EDI,ESP { length = bufPtr - buf } + MOV ECX,[ESP+512] { ECX = Min(length, destLength) } +{ MOV ECX,[EBP-16] }{ ECX = Min(length, destLength) } + CMP ECX,EDI + JB @@1 + MOV ECX,EDI +@@1: + MOV EDI,EBX { Point EDI to s } + MOV ESI,ESP { Point ESI to buf } + MOV [EDI],CL { Store length in s } + INC EDI + REP MOVSB { Copy length chars to s } + JMP @@exit + +@@smallInx: + MOV ECX,1 + JMP @@cont1 +@@bigInx: + MOV ECX,EDX + JMP @@cont1 + +@@exit: + ADD ESP,512+4 + POP EDI + POP ESI + POP EBX + RET 4 +end; + +function IOResult: Integer; +asm + CALL SysInit.@GetTLS + XOR EDX,EDX + MOV ECX,[EAX].InOutRes + MOV [EAX].InOutRes,EDX + MOV EAX,ECX +end; + +procedure _MkDir(const S: string); +begin + if not CreateDirectory(PChar(S), 0) then InOutError; +end; + +procedure Move( const Source; var Dest; count : Integer ); +asm +{ ->EAX Pointer to source } +{ EDX Pointer to destination } +{ ECX Count } + +(*{X-} // original code. + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + MOV EAX,ECX + + CMP EDI,ESI + JA @@down + JE @@exit + + SAR ECX,2 { copy count DIV 4 dwords } + JS @@exit + + REP MOVSD + + MOV ECX,EAX + AND ECX,03H + REP MOVSB { copy count MOD 4 bytes } + JMP @@exit + +@@down: + LEA ESI,[ESI+ECX-4] { point ESI to last dword of source } + LEA EDI,[EDI+ECX-4] { point EDI to last dword of dest } + + SAR ECX,2 { copy count DIV 4 dwords } + JS @@exit + STD + REP MOVSD + + MOV ECX,EAX + AND ECX,03H { copy count MOD 4 bytes } + ADD ESI,4-1 { point to last byte of rest } + ADD EDI,4-1 + REP MOVSB + CLD +@@exit: + POP EDI + POP ESI +*){X+} +//--------------------------------------- +(* {X+} // Let us write smaller: + JCXZ @@fin + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + MOV EAX,ECX + + AND ECX,3 { copy count mod 4 dwords } + + CMP EDI,ESI + JE @@exit + JA @@up + +//down: + LEA ESI,[ESI+EAX-1] { point ESI to last byte of source } + LEA EDI,[EDI+EAX-1] { point EDI to last byte of dest } + STD + + CMP EAX, 4 + JL @@up + ADD ECX, 3 { move 3 bytes more to correct pos } + +@@up: + REP MOVSB + + SAR EAX, 2 + JS @@exit + + MOV ECX, EAX + REP MOVSD + +@@exit: + CLD + POP EDI + POP ESI + +@@fin: +*) {X-} +//--------------------------------------- +{X+} // And now, let us write speedy: + CMP ECX, 4 + JGE @@long + JCXZ @@fin + + CMP EAX, EDX + JE @@fin + + PUSH ESI + PUSH EDI + MOV ESI, EAX + MOV EDI, EDX + JA @@short_up + + LEA ESI,[ESI+ECX-1] { point ESI to last byte of source } + LEA EDI,[EDI+ECX-1] { point EDI to last byte of dest } + STD + +@@short_up: + REP MOVSB + JMP @@exit_up + +@@long: + CMP EAX, EDX + JE @@fin + + PUSH ESI + PUSH EDI + MOV ESI, EAX + MOV EDI, EDX + MOV EAX, ECX + + JA @@long_up + + { + SAR ECX, 2 + JS @@exit + + LEA ESI,[ESI+EAX-4] + LEA EDI,[EDI+EAX-4] + STD + REP MOVSD + + MOV ECX, EAX + MOV EAX, 3 + AND ECX, EAX + ADD ESI, EAX + ADD EDI, EAX + REP MOVSB + } // let's do it in other order - faster if data are aligned... + + AND ECX, 3 + LEA ESI,[ESI+EAX-1] + LEA EDI,[EDI+EAX-1] + STD + REP MOVSB + + SAR EAX, 2 + //JS @@exit // why to test this? but what does PC do? + MOV ECX, EAX + MOV EAX, 3 + SUB ESI, EAX + SUB EDI, EAX + REP MOVSD + +@@exit_up: + CLD + //JMP @@exit + DEC ECX // the same - loosing 2 tacts... but conveyer! + +@@long_up: + SAR ECX, 2 + JS @@exit + + REP MOVSD + + AND EAX, 3 + MOV ECX, EAX + REP MOVSB + +@@exit: + POP EDI + POP ESI + +@@fin: +{X-} +end; + +function GetParamStr(P: PChar; var Param: string): PChar; +var + Len: Integer; + Buffer: array[0..4095] of Char; +begin + while True do + begin + while (P[0] <> #0) and (P[0] <= ' ') do Inc(P); + if (P[0] = '"') and (P[1] = '"') then Inc(P, 2) else Break; + end; + Len := 0; + while (P[0] > ' ') and (Len < SizeOf(Buffer)) do + if P[0] = '"' then + begin + Inc(P); + while (P[0] <> #0) and (P[0] <> '"') do + begin + Buffer[Len] := P[0]; + Inc(Len); + Inc(P); + end; + if P[0] <> #0 then Inc(P); + end else + begin + Buffer[Len] := P[0]; + Inc(Len); + Inc(P); + end; + SetString(Param, Buffer, Len); + Result := P; +end; + +function ParamCount: Integer; +var + P: PChar; + S: string; +begin + P := GetParamStr(GetCommandLine, S); + Result := 0; + while True do + begin + P := GetParamStr(P, S); + if S = '' then Break; + Inc(Result); + end; +end; + +function ParamStr(Index: Integer): string; +var + P: PChar; + Buffer: array[0..260] of Char; +begin + if Index = 0 then + SetString(Result, Buffer, GetModuleFileName(0, Buffer, SizeOf(Buffer))) + else + begin + P := GetCommandLine; + while True do + begin + P := GetParamStr(P, Result); + if (Index = 0) or (Result = '') then Break; + Dec(Index); + end; + end; +end; + +procedure _Pos{ substr : ShortString; s : ShortString ) : Integer}; +asm +{ ->EAX Pointer to substr } +{ EDX Pointer to string } +{ <-EAX Position of substr in s or 0 } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX { Point ESI to substr } + MOV EDI,EDX { Point EDI to s } + + XOR ECX,ECX { ECX = Length(s) } + MOV CL,[EDI] + INC EDI { Point EDI to first char of s } + + PUSH EDI { remember s position to calculate index } + + XOR EDX,EDX { EDX = Length(substr) } + MOV DL,[ESI] + INC ESI { Point ESI to first char of substr } + + DEC EDX { EDX = Length(substr) - 1 } + JS @@fail { < 0 ? return 0 } + MOV AL,[ESI] { AL = first char of substr } + INC ESI { Point ESI to 2'nd char of substr } + + SUB ECX,EDX { #positions in s to look at } + { = Length(s) - Length(substr) + 1 } + JLE @@fail +@@loop: + REPNE SCASB + JNE @@fail + MOV EBX,ECX { save outer loop counter } + PUSH ESI { save outer loop substr pointer } + PUSH EDI { save outer loop s pointer } + + MOV ECX,EDX + REPE CMPSB + POP EDI { restore outer loop s pointer } + POP ESI { restore outer loop substr pointer } + JE @@found + MOV ECX,EBX { restore outer loop counter } + JMP @@loop + +@@fail: + POP EDX { get rid of saved s pointer } + XOR EAX,EAX + JMP @@exit + +@@found: + POP EDX { restore pointer to first char of s } + MOV EAX,EDI { EDI points of char after match } + SUB EAX,EDX { the difference is the correct index } +@@exit: + POP EDI + POP ESI + POP EBX +end; + +procedure _SetLength{var s: ShortString; newLength: Integer}; +asm + { -> EAX pointer to string } + { EDX new length } + + MOV [EAX],DL { should also fill new space, parameter should be openstring } + +end; + +procedure _SetString{var s: ShortString: buffer: PChar; len: Integer}; +asm + { -> EAX pointer to string } + { EDX pointer to buffer } + { ECX len } + + MOV [EAX],CL + TEST EDX,EDX + JE @@noMove + XCHG EAX,EDX + INC EDX + CALL Move +@@noMove: +end; + +procedure Randomize; +var + systemTime : + record + wYear : Word; + wMonth : Word; + wDayOfWeek : Word; + wDay : Word; + wHour : Word; + wMinute : Word; + wSecond : Word; + wMilliSeconds: Word; + reserved : array [0..7] of char; + end; +asm + LEA EAX,systemTime + PUSH EAX + CALL GetSystemTime + MOVZX EAX,systemTime.wHour + IMUL EAX,60 + ADD AX,systemTime.wMinute { sum = hours * 60 + minutes } + IMUL EAX,60 + XOR EDX,EDX + MOV DX,systemTime.wSecond + ADD EAX,EDX { sum = sum * 60 + seconds } + IMUL EAX,1000 + MOV DX,systemTime.wMilliSeconds + ADD EAX,EDX { sum = sum * 1000 + milliseconds } + MOV RandSeed,EAX +end; + +procedure _RmDir(const S: string); +begin + if not RemoveDirectory(PChar(S)) then InOutError; +end; + +function UpCase( ch : Char ) : Char; +asm +{ -> AL Character } +{ <- AL Result } + + CMP AL,'a' + JB @@exit + CMP AL,'z' + JA @@exit + SUB AL,'a' - 'A' +@@exit: +end; + + +procedure Set8087CW(NewCW: Word); +asm + MOV Default8087CW,AX + FNCLEX // don't raise pending exceptions enabled by the new flags + FLDCW Default8087CW +end; + +{ ----------------------------------------------------- } +{ functions & procedures that need compiler magic } +{ ----------------------------------------------------- } + +const cwChop : Word = $1F32; + +procedure _COS; +asm + FCOS + FNSTSW AX + SAHF + JP @@outOfRange + RET +@@outOfRange: + FSTP st(0) { for now, return 0. result would } + FLDZ { have little significance anyway } +end; + +procedure _EXP; +asm + { e**x = 2**(x*log2(e)) } + + FLDL2E { y := x*log2e; } + FMUL + FLD ST(0) { i := round(y); } + FRNDINT + FSUB ST(1), ST { f := y - i; } + FXCH ST(1) { z := 2**f } + F2XM1 + FLD1 + FADD + FSCALE { result := z * 2**i } + FSTP ST(1) +end; + +procedure _INT; +asm + SUB ESP,4 + FSTCW [ESP] + FWAIT + FLDCW cwChop + FRNDINT + FWAIT + FLDCW [ESP] + ADD ESP,4 +end; + +procedure _SIN; +asm + FSIN + FNSTSW AX + SAHF + JP @@outOfRange + RET +@@outOfRange: + FSTP st(0) { for now, return 0. result would } + FLDZ { have little significance anyway } +end; + +procedure _FRAC; +asm + FLD ST(0) + SUB ESP,4 + FSTCW [ESP] + FWAIT + FLDCW cwChop + FRNDINT + FWAIT + FLDCW [ESP] + ADD ESP,4 + FSUB +end; + +procedure _ROUND; +asm + { -> FST(0) Extended argument } + { <- EDX:EAX Result } + + SUB ESP,8 + FISTP qword ptr [ESP] + FWAIT + POP EAX + POP EDX +end; + +procedure _TRUNC; +asm + { -> FST(0) Extended argument } + { <- EDX:EAX Result } + + SUB ESP,12 + FSTCW [ESP] + FWAIT + FLDCW cwChop + FISTP qword ptr [ESP+4] + FWAIT + FLDCW [ESP] + POP ECX + POP EAX + POP EDX +end; + +procedure _AbstractError; +asm + CMP AbstractErrorProc, 0 + JE @@NoAbstErrProc + CALL AbstractErrorProc + +@@NoAbstErrProc: + MOV EAX,210 + JMP _RunError +end; + +procedure _Append; external; { OpenText} +procedure _Assign(var t: text; s: ShortString); external; {$L Assign } +procedure _BlockRead; external; {$L BlockRea} +procedure _BlockWrite; external; {$L BlockWri} +procedure _Close; external; {$L Close } + +procedure _PStrCat; +asm +{ ->EAX = Pointer to destination string } +{ EDX = Pointer to source string } + + PUSH ESI + PUSH EDI + +{ load dest len into EAX } + + MOV EDI,EAX + XOR EAX,EAX + MOV AL,[EDI] + +{ load source address in ESI, source len in ECX } + + MOV ESI,EDX + XOR ECX,ECX + MOV CL,[ESI] + INC ESI + +{ calculate final length in DL and store it in the destination } + + MOV DL,AL + ADD DL,CL + JC @@trunc + +@@cont: + MOV [EDI],DL + +{ calculate final dest address } + + INC EDI + ADD EDI,EAX + +{ do the copy } + + REP MOVSB + +{ done } + + POP EDI + POP ESI + RET + +@@trunc: + INC DL { DL = #chars to truncate } + SUB CL,DL { CL = source len - #chars to truncate } + MOV DL,255 { DL = maximum length } + JMP @@cont +end; + +procedure _PStrNCat; +asm +{ ->EAX = Pointer to destination string } +{ EDX = Pointer to source string } +{ CL = max length of result (allocated size of dest - 1) } + + PUSH ESI + PUSH EDI + +{ load dest len into EAX } + + MOV EDI,EAX + XOR EAX,EAX + MOV AL,[EDI] + +{ load source address in ESI, source len in EDX } + + MOV ESI,EDX + XOR EDX,EDX + MOV DL,[ESI] + INC ESI + +{ calculate final length in AL and store it in the destination } + + ADD AL,DL + JC @@trunc + CMP AL,CL + JA @@trunc + +@@cont: + MOV ECX,EDX + MOV DL,[EDI] + MOV [EDI],AL + +{ calculate final dest address } + + INC EDI + ADD EDI,EDX + +{ do the copy } + + REP MOVSB + +@@done: + POP EDI + POP ESI + RET + +@@trunc: +{ CL = maxlen } + + MOV AL,CL { AL = final length = maxlen } + SUB CL,[EDI] { CL = length to copy = maxlen - destlen } + JBE @@done + MOV DL,CL + JMP @@cont +end; + +procedure _PStrCpy; +asm +{ ->EAX = Pointer to dest string } +{ EDX = Pointer to source string } + + XOR ECX,ECX + + PUSH ESI + PUSH EDI + + MOV CL,[EDX] + + MOV EDI,EAX + + INC ECX { we must copy len+1 bytes } + + MOV ESI,EDX + + MOV EAX,ECX + SHR ECX,2 + AND EAX,3 + REP MOVSD + + MOV ECX,EAX + REP MOVSB + + POP EDI + POP ESI +end; + +procedure _PStrNCpy; +asm +{ ->EAX = Pointer to dest string } +{ EDX = Pointer to source string } +{ CL = Maximum length to copy (allocated size of dest - 1) } + + PUSH ESI + PUSH EDI + + MOV EDI,EAX + XOR EAX,EAX + MOV ESI,EDX + + MOV AL,[EDX] + CMP AL,CL + JA @@trunc + + INC EAX + + MOV ECX,EAX + AND EAX,3 + SHR ECX,2 + REP MOVSD + + MOV ECX,EAX + REP MOVSB + + POP EDI + POP ESI + RET + +@@trunc: + MOV [EDI],CL { result length is maxLen } + INC ESI { advance pointers } + INC EDI + AND ECX,0FFH { should be cheaper than MOVZX } + REP MOVSB { copy maxLen bytes } + + POP EDI + POP ESI +end; + +procedure _PStrCmp; +asm +{ ->EAX = Pointer to left string } +{ EDX = Pointer to right string } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + XOR EAX,EAX + XOR EDX,EDX + MOV AL,[ESI] + MOV DL,[EDI] + INC ESI + INC EDI + + SUB EAX,EDX { eax = len1 - len2 } + JA @@skip1 + ADD EDX,EAX { edx = len2 + (len1 - len2) = len1 } + +@@skip1: + PUSH EDX + SHR EDX,2 + JE @@cmpRest +@@longLoop: + MOV ECX,[ESI] + MOV EBX,[EDI] + CMP ECX,EBX + JNE @@misMatch + DEC EDX + JE @@cmpRestP4 + MOV ECX,[ESI+4] + MOV EBX,[EDI+4] + CMP ECX,EBX + JNE @@misMatch + ADD ESI,8 + ADD EDI,8 + DEC EDX + JNE @@longLoop + JMP @@cmpRest +@@cmpRestP4: + ADD ESI,4 + ADD EDI,4 +@@cmpRest: + POP EDX + AND EDX,3 + JE @@equal + + MOV CL,[ESI] + CMP CL,[EDI] + JNE @@exit + DEC EDX + JE @@equal + MOV CL,[ESI+1] + CMP CL,[EDI+1] + JNE @@exit + DEC EDX + JE @@equal + MOV CL,[ESI+2] + CMP CL,[EDI+2] + JNE @@exit + +@@equal: + ADD EAX,EAX + JMP @@exit + +@@misMatch: + POP EDX + CMP CL,BL + JNE @@exit + CMP CH,BH + JNE @@exit + SHR ECX,16 + SHR EBX,16 + CMP CL,BL + JNE @@exit + CMP CH,BH + +@@exit: + POP EDI + POP ESI + POP EBX +end; + +procedure _AStrCmp; +asm +{ ->EAX = Pointer to left string } +{ EDX = Pointer to right string } +{ ECX = Number of chars to compare} + + PUSH EBX + PUSH ESI + PUSH ECX + MOV ESI,ECX + SHR ESI,2 + JE @@cmpRest + +@@longLoop: + MOV ECX,[EAX] + MOV EBX,[EDX] + CMP ECX,EBX + JNE @@misMatch + DEC ESI + JE @@cmpRestP4 + MOV ECX,[EAX+4] + MOV EBX,[EDX+4] + CMP ECX,EBX + JNE @@misMatch + ADD EAX,8 + ADD EDX,8 + DEC ESI + JNE @@longLoop + JMP @@cmpRest +@@cmpRestp4: + ADD EAX,4 + ADD EDX,4 +@@cmpRest: + POP ESI + AND ESI,3 + JE @@exit + + MOV CL,[EAX] + CMP CL,[EDX] + JNE @@exit + DEC ESI + JE @@equal + MOV CL,[EAX+1] + CMP CL,[EDX+1] + JNE @@exit + DEC ESI + JE @@equal + MOV CL,[EAX+2] + CMP CL,[EDX+2] + JNE @@exit + +@@equal: + XOR EAX,EAX + JMP @@exit + +@@misMatch: + POP ESI + CMP CL,BL + JNE @@exit + CMP CH,BH + JNE @@exit + SHR ECX,16 + SHR EBX,16 + CMP CL,BL + JNE @@exit + CMP CH,BH + +@@exit: + POP ESI + POP EBX +end; + +procedure _EofFile; external; {$L EofFile } +procedure _EofText; external; {$L EofText } +procedure _Eoln; external; {$L Eoln } +procedure _Erase; external; {$L Erase } + +procedure _FSafeDivide; external; {$L FDIV } +procedure _FSafeDivideR; external; { FDIV } + +procedure _FilePos; external; {$L FilePos } +procedure _FileSize; external; {$L FileSize} + +procedure _FillChar; +asm +{ ->EAX Pointer to destination } +{ EDX count } +{ CL value } + + PUSH EDI + + MOV EDI,EAX { Point EDI to destination } + + MOV CH,CL { Fill EAX with value repeated 4 times } + MOV EAX,ECX + SHL EAX,16 + MOV AX,CX + + MOV ECX,EDX + SAR ECX,2 + JS @@exit + + REP STOSD { Fill count DIV 4 dwords } + + MOV ECX,EDX + AND ECX,3 + REP STOSB { Fill count MOD 4 bytes } + +@@exit: + POP EDI +end; + +procedure _Mark; +begin + Error(reInvalidPtr); +end; + +procedure _RandInt; +asm +{ ->EAX Range } +{ <-EAX Result } + IMUL EDX,RandSeed,08088405H + INC EDX + MOV RandSeed,EDX + MUL EDX + MOV EAX,EDX +end; + +procedure _RandExt; +const two2neg32: double = ((1.0/$10000) / $10000); // 2^-32 +asm +{ FUNCTION _RandExt: Extended; } + + IMUL EDX,RandSeed,08088405H + INC EDX + MOV RandSeed,EDX + + FLD two2neg32 + PUSH 0 + PUSH EDX + FILD qword ptr [ESP] + ADD ESP,8 + FMULP ST(1), ST(0) +end; + +procedure _ReadRec; external; {$L ReadRec } + +procedure _ReadChar; external; {$L ReadChar} +procedure _ReadLong; external; {$L ReadLong} +procedure _ReadString; external; {$L ReadStri} +procedure _ReadCString; external; { ReadStri} + +procedure _ReadExt; external; {$L ReadExt } +procedure _ReadLn; external; {$L ReadLn } + +procedure _Rename; external; {$L Rename } + +procedure _Release; +begin + Error(reInvalidPtr); +end; + +procedure _ResetText(var t: text); external; {$L OpenText} +procedure _ResetFile; external; {$L OpenFile} +procedure _RewritText(var t: text); external; { OpenText} +procedure _RewritFile; external; { OpenFile} + +procedure _Seek; external; {$L Seek } +procedure _SeekEof; external; {$L SeekEof } +procedure _SeekEoln; external; {$L SeekEoln} + +procedure _SetTextBuf; external; {$L SetTextB} + +procedure _StrLong; +asm +{ PROCEDURE _StrLong( val: Longint; width: Longint; VAR s: ShortString ); + ->EAX Value + EDX Width + ECX Pointer to string } + + PUSH EBX { VAR i: Longint; } + PUSH ESI { VAR sign : Longint; } + PUSH EDI + PUSH EDX { store width on the stack } + SUB ESP,20 { VAR a: array [0..19] of Char; } + + MOV EDI,ECX + + MOV ESI,EAX { sign := val } + + CDQ { val := Abs(val); canned sequence } + XOR EAX,EDX + SUB EAX,EDX + + MOV ECX,10 + XOR EBX,EBX { i := 0; } + +@@repeat1: { repeat } + XOR EDX,EDX { a[i] := Chr( val MOD 10 + Ord('0') );} + + DIV ECX { val := val DIV 10; } + + ADD EDX,'0' + MOV [ESP+EBX],DL + INC EBX { i := i + 1; } + TEST EAX,EAX { until val = 0; } + JNZ @@repeat1 + + TEST ESI,ESI + JGE @@2 + MOV byte ptr [ESP+EBX],'-' + INC EBX +@@2: + MOV [EDI],BL { s^++ := Chr(i); } + INC EDI + + MOV ECX,[ESP+20] { spaceCnt := width - i; } + CMP ECX,255 + JLE @@3 + MOV ECX,255 +@@3: + SUB ECX,EBX + JLE @@repeat2 { for k := 1 to spaceCnt do s^++ := ' '; } + ADD [EDI-1],CL + MOV AL,' ' + REP STOSB + +@@repeat2: { repeat } + MOV AL,[ESP+EBX-1] { s^ := a[i-1]; } + MOV [EDI],AL + INC EDI { s := s + 1 } + DEC EBX { i := i - 1; } + JNZ @@repeat2 { until i = 0; } + + ADD ESP,20+4 + POP EDI + POP ESI + POP EBX +end; + +procedure _Str0Long; +asm +{ ->EAX Value } +{ EDX Pointer to string } + + MOV ECX,EDX + XOR EDX,EDX + JMP _StrLong +end; + +procedure _Truncate; external; {$L Truncate} + +procedure _ValLong; +asm +{ FUNCTION _ValLong( s: AnsiString; VAR code: Integer ) : Longint; } +{ ->EAX Pointer to string } +{ EDX Pointer to code result } +{ <-EAX Result } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX + PUSH EAX { save for the error case } + + TEST EAX,EAX + JE @@empty + + XOR EAX,EAX + XOR EBX,EBX + MOV EDI,07FFFFFFFH / 10 { limit } + +@@blankLoop: + MOV BL,[ESI] + INC ESI + CMP BL,' ' + JE @@blankLoop + +@@endBlanks: + MOV CH,0 + CMP BL,'-' + JE @@minus + CMP BL,'+' + JE @@plus + CMP BL,'$' + JE @@dollar + + CMP BL, 'x' + JE @@dollar + CMP BL, 'X' + JE @@dollar + CMP BL, '0' + JNE @@firstDigit + MOV BL, [ESI] + INC ESI + CMP BL, 'x' + JE @@dollar + CMP BL, 'X' + JE @@dollar + TEST BL, BL + JE @@endDigits + JMP @@digLoop + +@@firstDigit: + TEST BL,BL + JE @@error + +@@digLoop: + SUB BL,'0' + CMP BL,9 + JA @@error + CMP EAX,EDI { value > limit ? } + JA @@overFlow + LEA EAX,[EAX+EAX*4] + ADD EAX,EAX + ADD EAX,EBX { fortunately, we can't have a carry } + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JNE @@digLoop + +@@endDigits: + DEC CH + JE @@negate + TEST EAX,EAX + JL @@overFlow + +@@successExit: + + POP ECX { saved copy of string pointer } + + XOR ESI,ESI { signal no error to caller } + +@@exit: + MOV [EDX],ESI + + POP EDI + POP ESI + POP EBX + RET + +@@empty: + INC ESI + JMP @@error + +@@negate: + NEG EAX + JLE @@successExit + JS @@successExit { to handle 2**31 correctly, where the negate overflows } + +@@error: +@@overFlow: + POP EBX + SUB ESI,EBX + JMP @@exit + +@@minus: + INC CH +@@plus: + MOV BL,[ESI] + INC ESI + JMP @@firstDigit + +@@dollar: + MOV EDI,0FFFFFFFH + + MOV BL,[ESI] + INC ESI + TEST BL,BL + JZ @@empty + +@@hDigLoop: + CMP BL,'a' + JB @@upper + SUB BL,'a' - 'A' +@@upper: + SUB BL,'0' + CMP BL,9 + JBE @@digOk + SUB BL,'A' - '0' + CMP BL,5 + JA @@error + ADD BL,10 +@@digOk: + CMP EAX,EDI + JA @@overFlow + SHL EAX,4 + ADD EAX,EBX + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JNE @@hDigLoop + + JMP @@successExit +end; + +procedure _WriteRec; external; {$L WriteRec} + +procedure _WriteChar; external; { WriteStr} +procedure _Write0Char; external; { WriteStr} + +procedure _WriteBool; +asm +{ PROCEDURE _WriteBool( VAR t: Text; val: Boolean; width: Longint); } +{ ->EAX Pointer to file record } +{ DL Boolean value } +{ ECX Field width } + + TEST DL,DL + JE @@false + MOV EDX,offset @trueString + JMP _WriteString +@@false: + MOV EDX,offset @falseString + JMP _WriteString +@trueString: db 4,'TRUE' +@falseString: db 5,'FALSE' +end; + +procedure _Write0Bool; +asm +{ PROCEDURE _Write0Bool( VAR t: Text; val: Boolean); } +{ ->EAX Pointer to file record } +{ DL Boolean value } + + XOR ECX,ECX + JMP _WriteBool +end; + +procedure _WriteLong; +asm +{ PROCEDURE _WriteLong( VAR t: Text; val: Longint; with: Longint); } +{ ->EAX Pointer to file record } +{ EDX Value } +{ ECX Field width } + + SUB ESP,32 { VAR s: String[31]; } + + PUSH EAX + PUSH ECX + + MOV EAX,EDX { Str( val : 0, s ); } + XOR EDX,EDX + CMP ECX,31 + JG @@1 + MOV EDX,ECX +@@1: + LEA ECX,[ESP+8] + CALL _StrLong + + POP ECX + POP EAX + + MOV EDX,ESP { Write( t, s : width );} + CALL _WriteString + + ADD ESP,32 +end; + +procedure _Write0Long; +asm +{ PROCEDURE _Write0Long( VAR t: Text; val: Longint); } +{ ->EAX Pointer to file record } +{ EDX Value } + XOR ECX,ECX + JMP _WriteLong +end; + +procedure _WriteString; external; {$L WriteStr} +procedure _Write0String; external; { WriteStr} + +procedure _WriteCString; external; { WriteStr} +procedure _Write0CString; external; { WriteStr} + +procedure _WriteBytes; external; { WriteStr} +procedure _WriteSpaces; external; { WriteStr} + +procedure _Write2Ext; +asm +{ PROCEDURE _Write2Ext( VAR t: Text; val: Extended; width, prec: Longint); + ->EAX Pointer to file record + [ESP+4] Extended value + EDX Field width + ECX precision (<0: scientific, >= 0: fixed point) } + + FLD tbyte ptr [ESP+4] { load value } + SUB ESP,256 { VAR s: String; } + + PUSH EAX + PUSH EDX + +{ Str( val, width, prec, s ); } + + SUB ESP,12 + FSTP tbyte ptr [ESP] { pass value } + MOV EAX,EDX { pass field width } + MOV EDX,ECX { pass precision } + LEA ECX,[ESP+8+12] { pass destination string } + CALL _Str2Ext + +{ Write( t, s, width ); } + + POP ECX { pass width } + POP EAX { pass text } + MOV EDX,ESP { pass string } + CALL _WriteString + + ADD ESP,256 + RET 12 +end; + +procedure _Write1Ext; +asm +{ PROCEDURE _Write1Ext( VAR t: Text; val: Extended; width: Longint); + -> EAX Pointer to file record + [ESP+4] Extended value + EDX Field width } + + OR ECX,-1 + JMP _Write2Ext +end; + +procedure _Write0Ext; +asm +{ PROCEDURE _Write0Ext( VAR t: Text; val: Extended); + ->EAX Pointer to file record + [ESP+4] Extended value } + + MOV EDX,23 { field width } + OR ECX,-1 + JMP _Write2Ext +end; + +procedure _WriteLn; external; { WriteStr} + +procedure __CToPasStr; +asm +{ ->EAX Pointer to destination } +{ EDX Pointer to source } + + PUSH EAX { save destination } + + MOV CL,255 +@@loop: + MOV CH,[EDX] { ch = *src++; } + INC EDX + TEST CH,CH { if (ch == 0) break } + JE @@endLoop + INC EAX { *++dest = ch; } + MOV [EAX],CH + DEC CL + JNE @@loop + +@@endLoop: + POP EDX + SUB EAX,EDX + MOV [EDX],AL +end; + +procedure __CLenToPasStr; +asm +{ ->EAX Pointer to destination } +{ EDX Pointer to source } +{ ECX cnt } + + PUSH EBX + PUSH EAX { save destination } + + CMP ECX,255 + JBE @@loop + MOV ECX,255 +@@loop: + MOV BL,[EDX] { ch = *src++; } + INC EDX + TEST BL,BL { if (ch == 0) break } + JE @@endLoop + INC EAX { *++dest = ch; } + MOV [EAX],BL + DEC ECX { while (--cnt != 0) } + JNZ @@loop + +@@endLoop: + POP EDX + SUB EAX,EDX + MOV [EDX],AL + POP EBX +end; + +procedure __ArrayToPasStr; +asm +{ ->EAX Pointer to destination } +{ EDX Pointer to source } +{ ECX cnt } + + XCHG EAX,EDX + + { limit the length to 255 } + + CMP ECX,255 + JBE @@skip + MOV ECX,255 +@@skip: + MOV [EDX],CL + + { copy the source to destination + 1 } + + INC EDX + JMP Move +end; + + +procedure __PasToCStr; +asm +{ ->EAX Pointer to source } +{ EDX Pointer to destination } + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + XOR ECX,ECX + MOV CL,[ESI] + INC ESI + + REP MOVSB + MOV byte ptr [EDI],CL { Append terminator: CL is zero here } + + POP EDI + POP ESI +end; + +procedure _SetElem; +asm + { PROCEDURE _SetElem( VAR d: SET; elem, size: Byte); } + { EAX = dest address } + { DL = element number } + { CL = size of set } + + PUSH EBX + PUSH EDI + + MOV EDI,EAX + + XOR EBX,EBX { zero extend set size into ebx } + MOV BL,CL + MOV ECX,EBX { and use it for the fill } + + XOR EAX,EAX { for zero fill } + REP STOSB + + SUB EDI,EBX { point edi at beginning of set again } + + INC EAX { eax is still zero - make it 1 } + MOV CL,DL + ROL AL,CL { generate a mask } + SHR ECX,3 { generate the index } + CMP ECX,EBX { if index >= siz then exit } + JAE @@exit + OR [EDI+ECX],AL{ set bit } + +@@exit: + POP EDI + POP EBX +end; + +procedure _SetRange; +asm +{ PROCEDURE _SetRange( lo, hi, size: Byte; VAR d: SET ); } +{ ->AL low limit of range } +{ DL high limit of range } +{ ECX Pointer to set } +{ AH size of set } + + PUSH EBX + PUSH ESI + PUSH EDI + + XOR EBX,EBX { EBX = set size } + MOV BL,AH + MOVZX ESI,AL { ESI = low zero extended } + MOVZX EDX,DL { EDX = high zero extended } + MOV EDI,ECX + +{ clear the set } + + MOV ECX,EBX + XOR EAX,EAX + REP STOSB + +{ prepare for setting the bits } + + SUB EDI,EBX { point EDI at start of set } + SHL EBX,3 { EBX = highest bit in set + 1 } + CMP EDX,EBX + JB @@inrange + LEA EDX,[EBX-1] { ECX = highest bit in set } + +@@inrange: + CMP ESI,EDX { if lo > hi then exit; } + JA @@exit + + DEC EAX { loMask = 0xff << (lo & 7) } + MOV ECX,ESI + AND CL,07H + SHL AL,CL + + SHR ESI,3 { loIndex = lo >> 3; } + + MOV CL,DL { hiMask = 0xff >> (7 - (hi & 7)); } + NOT CL + AND CL,07 + SHR AH,CL + + SHR EDX,3 { hiIndex = hi >> 3; } + + ADD EDI,ESI { point EDI to set[loIndex] } + MOV ECX,EDX + SUB ECX,ESI { if ((inxDiff = (hiIndex - loIndex)) == 0) } + JNE @@else + + AND AL,AH { set[loIndex] = hiMask & loMask; } + MOV [EDI],AL + JMP @@exit + +@@else: + STOSB { set[loIndex++] = loMask; } + DEC ECX + MOV AL,0FFH { while (loIndex < hiIndex) } + REP STOSB { set[loIndex++] = 0xff; } + MOV [EDI],AH { set[hiIndex] = hiMask; } + +@@exit: + POP EDI + POP ESI + POP EBX +end; + +procedure _SetEq; +asm +{ FUNCTION _SetEq( CONST l, r: Set; size: Byte): ConditionCode; } +{ EAX = left operand } +{ EDX = right operand } +{ CL = size of set } + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + AND ECX,0FFH + REP CMPSB + + POP EDI + POP ESI +end; + +procedure _SetLe; +asm +{ FUNCTION _SetLe( CONST l, r: Set; size: Byte): ConditionCode; } +{ EAX = left operand } +{ EDX = right operand } +{ CL = size of set (>0 && <= 32) } + +@@loop: + MOV CH,[EDX] + NOT CH + AND CH,[EAX] + JNE @@exit + INC EDX + INC EAX + DEC CL + JNZ @@loop +@@exit: +end; + +procedure _SetIntersect; +asm +{ PROCEDURE _SetIntersect( VAR dest: Set; CONST src: Set; size: Byte);} +{ EAX = destination operand } +{ EDX = source operand } +{ CL = size of set (0 < size <= 32) } + +@@loop: + MOV CH,[EDX] + INC EDX + AND [EAX],CH + INC EAX + DEC CL + JNZ @@loop +end; + +procedure _SetIntersect3; +asm +{ PROCEDURE _SetIntersect3( VAR dest: Set; CONST src: Set; size: Longint; src2: Set);} +{ EAX = destination operand } +{ EDX = source operand } +{ ECX = size of set (0 < size <= 32) } +{ [ESP+4] = 2nd source operand } + + PUSH EBX + PUSH ESI + MOV ESI,[ESP+8+4] +@@loop: + MOV BL,[EDX+ECX-1] + AND BL,[ESI+ECX-1] + MOV [EAX+ECX-1],BL + DEC ECX + JNZ @@loop + + POP ESI + POP EBX +end; + +procedure _SetUnion; +asm +{ PROCEDURE _SetUnion( VAR dest: Set; CONST src: Set; size: Byte); } +{ EAX = destination operand } +{ EDX = source operand } +{ CL = size of set (0 < size <= 32) } + +@@loop: + MOV CH,[EDX] + INC EDX + OR [EAX],CH + INC EAX + DEC CL + JNZ @@loop +end; + +procedure _SetUnion3; +asm +{ PROCEDURE _SetUnion3( VAR dest: Set; CONST src: Set; size: Longint; src2: Set);} +{ EAX = destination operand } +{ EDX = source operand } +{ ECX = size of set (0 < size <= 32) } +{ [ESP+4] = 2nd source operand } + + PUSH EBX + PUSH ESI + MOV ESI,[ESP+8+4] +@@loop: + MOV BL,[EDX+ECX-1] + OR BL,[ESI+ECX-1] + MOV [EAX+ECX-1],BL + DEC ECX + JNZ @@loop + + POP ESI + POP EBX +end; + +procedure _SetSub; +asm +{ PROCEDURE _SetSub( VAR dest: Set; CONST src: Set; size: Byte); } +{ EAX = destination operand } +{ EDX = source operand } +{ CL = size of set (0 < size <= 32) } + +@@loop: + MOV CH,[EDX] + NOT CH + INC EDX + AND [EAX],CH + INC EAX + DEC CL + JNZ @@loop +end; + +procedure _SetSub3; +asm +{ PROCEDURE _SetSub3( VAR dest: Set; CONST src: Set; size: Longint; src2: Set);} +{ EAX = destination operand } +{ EDX = source operand } +{ ECX = size of set (0 < size <= 32) } +{ [ESP+4] = 2nd source operand } + + PUSH EBX + PUSH ESI + MOV ESI,[ESP+8+4] +@@loop: + MOV BL,[ESI+ECX-1] + NOT BL + AND BL,[EDX+ECX-1] + MOV [EAX+ECX-1],BL + DEC ECX + JNZ @@loop + + POP ESI + POP EBX +end; + +procedure _SetExpand; +asm +{ PROCEDURE _SetExpand( CONST src: Set; VAR dest: Set; lo, hi: Byte); } +{ ->EAX Pointer to source (packed set) } +{ EDX Pointer to destination (expanded set) } +{ CH high byte of source } +{ CL low byte of source } + +{ algorithm: } +{ clear low bytes } +{ copy high-low+1 bytes } +{ clear 31-high bytes } + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + MOV EDX,ECX { save low, high in dl, dh } + XOR ECX,ECX + XOR EAX,EAX + + MOV CL,DL { clear low bytes } + REP STOSB + + MOV CL,DH { copy high - low bytes } + SUB CL,DL + REP MOVSB + + MOV CL,32 { copy 32 - high bytes } + SUB CL,DH + REP STOSB + + POP EDI + POP ESI +end; + +procedure _Str2Ext; external; {$L StrExt } +procedure _Str0Ext; external; { StrExt } +procedure _Str1Ext; external; { StrExt } + +procedure _ValExt; external; {$L ValExt } + +procedure _Pow10; external; {$L Pow10 } +procedure FPower10; external; { Pow10 } +procedure _Real2Ext; external; {$L Real2Ext} +procedure _Ext2Real; external; {$L Ext2Real} + +const + ovtInstanceSize = -8; { Offset of instance size in OBJECTs } + ovtVmtPtrOffs = -4; + +procedure _ObjSetup; +asm +{ FUNCTION _ObjSetup( self: ^OBJECT; vmt: ^VMT): ^OBJECT; } +{ ->EAX Pointer to self (possibly nil) } +{ EDX Pointer to vmt (possibly nil) } +{ <-EAX Pointer to self } +{ EDX <> 0: an object was allocated } +{ Z-Flag Set: failure, Cleared: Success } + + CMP EDX,1 { is vmt = 0, indicating a call } + JAE @@skip1 { from a constructor? } + RET { return immediately with Z-flag cleared } + +@@skip1: + PUSH ECX + TEST EAX,EAX { is self already allocated? } + JNE @@noAlloc + MOV EAX,[EDX].ovtInstanceSize + TEST EAX,EAX + JE @@zeroSize + PUSH EDX + CALL MemoryManager.GetMem + POP EDX + TEST EAX,EAX + JZ @@fail + + { Zero fill the memory } + PUSH EDI + MOV ECX,[EDX].ovtInstanceSize + MOV EDI,EAX + PUSH EAX + XOR EAX,EAX + SHR ECX,2 + REP STOSD + MOV ECX,[EDX].ovtInstanceSize + AND ECX,3 + REP STOSB + POP EAX + POP EDI + + MOV ECX,[EDX].ovtVmtPtrOffs + TEST ECX,ECX + JL @@skip + MOV [EAX+ECX],EDX { store vmt in object at this offset } +@@skip: + TEST EAX,EAX { clear zero flag } + POP ECX + RET + +@@fail: + XOR EDX,EDX + POP ECX + RET + +@@zeroSize: + XOR EDX,EDX + CMP EAX,1 { clear zero flag - we were successful (kind of) } + POP ECX + RET + +@@noAlloc: + MOV ECX,[EDX].ovtVmtPtrOffs + TEST ECX,ECX + JL @@exit + MOV [EAX+ECX],EDX { store vmt in object at this offset } +@@exit: + XOR EDX,EDX { clear allocated flag } + TEST EAX,EAX { clear zero flag } + POP ECX +end; + +procedure _ObjCopy; +asm +{ PROCEDURE _ObjCopy( dest, src: ^OBJECT; vmtPtrOff: Longint); } +{ ->EAX Pointer to destination } +{ EDX Pointer to source } +{ ECX Offset of vmt in those objects. } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EDX + MOV EDI,EAX + + LEA EAX,[EDI+ECX] { remember pointer to dest vmt pointer } + MOV EDX,[EAX] { fetch dest vmt pointer } + + MOV EBX,[EDX].ovtInstanceSize + + MOV ECX,EBX { copy size DIV 4 dwords } + SHR ECX,2 + REP MOVSD + + MOV ECX,EBX { copy size MOD 4 bytes } + AND ECX,3 + REP MOVSB + + MOV [EAX],EDX { restore dest vmt } + + POP EDI + POP ESI + POP EBX +end; + +procedure _Fail; +asm +{ FUNCTION _Fail( self: ^OBJECT; allocFlag:Longint): ^OBJECT; } +{ ->EAX Pointer to self (possibly nil) } +{ EDX <> 0: Object must be deallocated } +{ <-EAX Nil } + + TEST EDX,EDX + JE @@exit { if no object was allocated, return } + CALL _FreeMem +@@exit: + XOR EAX,EAX +end; + +function GetKeyboardType(nTypeFlag: Integer): Integer; stdcall; + external user name 'GetKeyboardType'; + +function _isNECWindows: Boolean; +var + KbSubType: Integer; +begin + Result := False; + if GetKeyboardType(0) = $7 then + begin + KbSubType := GetKeyboardType(1) and $FF00; + if (KbSubType = $0D00) or (KbSubType = $0400) then + Result := True; + end; +end; + +procedure _FpuMaskInit; +const + HKEY_LOCAL_MACHINE = $80000002; + KEY_QUERY_VALUE = $00000001; + REG_DWORD = 4; + FPUMASKKEY = 'SOFTWARE\Borland\Delphi\RTL'; + FPUMASKNAME = 'FPUMaskValue'; +var + phkResult: LongWord; + lpData, DataSize: Longint; +begin + lpData := Default8087CW; + + if RegOpenKeyEx(HKEY_LOCAL_MACHINE, FPUMASKKEY, 0, KEY_QUERY_VALUE, phkResult) = 0 then + try + DataSize := Sizeof(lpData); + RegQueryValueEx(phkResult, FPUMASKNAME, nil, nil, @lpData, @DataSize); + finally + RegCloseKey(phkResult); + end; + + Default8087CW := (Default8087CW and $ffc0) or (lpData and $3f); +end; + +procedure FpuInit; +//const cwDefault: Word = $1332 { $133F}; +asm + FNINIT + FWAIT + FLDCW Default8087CW +end; + +procedure FpuInitConsiderNECWindows; +begin + if _isNECWindows then _FpuMaskInit; + FpuInit(); +end; + +procedure _BoundErr; +asm + MOV AL,reRangeError + JMP Error +end; + +procedure _IntOver; +asm + MOV AL,reIntOverflow + JMP Error +end; + +function TObject.ClassType: TClass; +asm + mov eax,[eax] +end; + +class function TObject.ClassName: ShortString; +asm + { -> EAX VMT } + { EDX Pointer to result string } + PUSH ESI + PUSH EDI + MOV EDI,EDX + MOV ESI,[EAX].vmtClassName + XOR ECX,ECX + MOV CL,[ESI] + INC ECX + REP MOVSB + POP EDI + POP ESI +end; + +class function TObject.ClassNameIs(const Name: string): Boolean; +asm + PUSH EBX + XOR EBX,EBX + OR EDX,EDX + JE @@exit + MOV EAX,[EAX].vmtClassName + XOR ECX,ECX + MOV CL,[EAX] + CMP ECX,[EDX-4] + JNE @@exit + DEC EDX +@@loop: + MOV BH,[EAX+ECX] + XOR BH,[EDX+ECX] + AND BH,0DFH + JNE @@exit + DEC ECX + JNE @@loop + INC EBX +@@exit: + MOV AL,BL + POP EBX +end; + +class function TObject.ClassParent: TClass; +asm + MOV EAX,[EAX].vmtParent + TEST EAX,EAX + JE @@exit + MOV EAX,[EAX] +@@exit: +end; + +class function TObject.NewInstance: TObject; +asm + PUSH EAX + MOV EAX,[EAX].vmtInstanceSize + CALL _GetMem + MOV EDX,EAX + POP EAX + JMP TObject.InitInstance +end; + +procedure TObject.FreeInstance; +asm + PUSH EBX + PUSH ESI + MOV EBX,EAX + MOV ESI,EAX +@@loop: + MOV ESI,[ESI] + MOV EDX,[ESI].vmtInitTable + MOV ESI,[ESI].vmtParent + TEST EDX,EDX + JE @@skip + CALL _FinalizeRecord + MOV EAX,EBX +@@skip: + TEST ESI,ESI + JNE @@loop + + CALL _FreeMem + POP ESI + POP EBX +end; + +class function TObject.InstanceSize: Longint; +asm + MOV EAX,[EAX].vmtInstanceSize +end; + +constructor TObject.Create; +begin +end; + +destructor TObject.Destroy; +begin +end; + +procedure TObject.Free; +asm + TEST EAX,EAX + JE @@exit + MOV ECX,[EAX] + MOV DL,1 + CALL dword ptr [ECX].vmtDestroy +@@exit: +end; + +class function TObject.InitInstance(Instance: Pointer): TObject; +asm + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV EDI,EDX + STOSD + MOV ECX,[EBX].vmtInstanceSize + XOR EAX,EAX + PUSH ECX + SHR ECX,2 + DEC ECX + REP STOSD + POP ECX + AND ECX,3 + REP STOSB + MOV EAX,EDX + MOV EDX,ESP +@@0: MOV ECX,[EBX].vmtIntfTable + TEST ECX,ECX + JE @@1 + PUSH ECX +@@1: MOV EBX,[EBX].vmtParent + TEST EBX,EBX + JE @@2 + MOV EBX,[EBX] + JMP @@0 +@@2: CMP ESP,EDX + JE @@5 +@@3: POP EBX + MOV ECX,[EBX].TInterfaceTable.EntryCount + ADD EBX,4 +@@4: MOV ESI,[EBX].TInterfaceEntry.VTable + TEST ESI,ESI + JE @@4a + MOV EDI,[EBX].TInterfaceEntry.IOffset + MOV [EAX+EDI],ESI +@@4a: ADD EBX,TYPE TInterfaceEntry + DEC ECX + JNE @@4 + CMP ESP,EDX + JNE @@3 +@@5: POP EDI + POP ESI + POP EBX +end; + +procedure TObject.CleanupInstance; +asm + PUSH EBX + PUSH ESI + MOV EBX,EAX + MOV ESI,EAX +@@loop: + MOV ESI,[ESI] + MOV EDX,[ESI].vmtInitTable + MOV ESI,[ESI].vmtParent + TEST EDX,EDX + JE @@skip + CALL _FinalizeRecord + MOV EAX,EBX +@@skip: + TEST ESI,ESI + JNE @@loop + + POP ESI + POP EBX +end; + +function InvokeImplGetter(Self: TObject; ImplGetter: Integer): IUnknown; +asm + XCHG EDX,ECX + CMP ECX,$FF000000 + JAE @@isField + CMP ECX,$FE000000 + JB @@isStaticMethod + + { the GetProc is a virtual method } + MOVSX ECX,CX { sign extend slot offs } + ADD ECX,[EAX] { vmt + slotoffs } + JMP dword ptr [ECX] { call vmt[slot] } + +@@isStaticMethod: + JMP ECX + +@@isField: + AND ECX,$00FFFFFF + ADD ECX,EAX + MOV EAX,EDX + MOV EDX,[ECX] + JMP _IntfCopy +end; + +function TObject.GetInterface(const IID: TGUID; out Obj): Boolean; +var + InterfaceEntry: PInterfaceEntry; +begin + InterfaceEntry := GetInterfaceEntry(IID); + if InterfaceEntry <> nil then + begin + if InterfaceEntry^.IOffset <> 0 then + Pointer(Obj) := Pointer(Integer(Self) + InterfaceEntry^.IOffset) + else + IUnknown(Obj) := InvokeImplGetter(Self, InterfaceEntry^.ImplGetter); + if Pointer(Obj) <> nil then + begin + if InterfaceEntry^.IOffset <> 0 then IUnknown(Obj)._AddRef; + Result := True; + end + else + Result := False; + end else + begin + Pointer(Obj) := nil; + Result := False; + end; +end; + +class function TObject.GetInterfaceEntry(const IID: TGUID): PInterfaceEntry; +asm + PUSH EBX + PUSH ESI + MOV EBX,EAX +@@1: MOV EAX,[EBX].vmtIntfTable + TEST EAX,EAX + JE @@4 + MOV ECX,[EAX].TInterfaceTable.EntryCount + ADD EAX,4 +@@2: MOV ESI,[EDX].Integer[0] + CMP ESI,[EAX].TInterfaceEntry.IID.Integer[0] + JNE @@3 + MOV ESI,[EDX].Integer[4] + CMP ESI,[EAX].TInterfaceEntry.IID.Integer[4] + JNE @@3 + MOV ESI,[EDX].Integer[8] + CMP ESI,[EAX].TInterfaceEntry.IID.Integer[8] + JNE @@3 + MOV ESI,[EDX].Integer[12] + CMP ESI,[EAX].TInterfaceEntry.IID.Integer[12] + JE @@5 +@@3: ADD EAX,type TInterfaceEntry + DEC ECX + JNE @@2 +@@4: MOV EBX,[EBX].vmtParent + TEST EBX,EBX + JE @@4a + MOV EBX,[EBX] + JMP @@1 +@@4a: XOR EAX,EAX +@@5: POP ESI + POP EBX +end; + +class function TObject.GetInterfaceTable: PInterfaceTable; +asm + MOV EAX,[EAX].vmtIntfTable +end; + + +procedure _IsClass; +asm + { -> EAX left operand (class) } + { EDX VMT of right operand } + { <- AL left is derived from right } + TEST EAX,EAX + JE @@exit +@@loop: + MOV EAX,[EAX] + CMP EAX,EDX + JE @@success + MOV EAX,[EAX].vmtParent + TEST EAX,EAX + JNE @@loop + JMP @@exit +@@success: + MOV AL,1 +@@exit: +end; + + +procedure _AsClass; +asm + { -> EAX left operand (class) } + { EDX VMT of right operand } + { <- EAX if left is derived from right, else runtime error } + TEST EAX,EAX + JE @@exit + MOV ECX,EAX +@@loop: + MOV ECX,[ECX] + CMP ECX,EDX + JE @@exit + MOV ECX,[ECX].vmtParent + TEST ECX,ECX + JNE @@loop + + { do runtime error } + MOV AL,reInvalidCast + JMP Error + +@@exit: +end; + + +procedure GetDynaMethod; +{ function GetDynaMethod(vmt: TClass; selector: Smallint) : Pointer; } +asm + { -> EAX vmt of class } + { BX dynamic method index } + { <- EBX pointer to routine } + { ZF = 0 if found } + { trashes: EAX, ECX } + + PUSH EDI + XCHG EAX,EBX + JMP @@haveVMT +@@outerLoop: + MOV EBX,[EBX] +@@haveVMT: + MOV EDI,[EBX].vmtDynamicTable + TEST EDI,EDI + JE @@parent + MOVZX ECX,word ptr [EDI] + PUSH ECX + ADD EDI,2 + REPNE SCASW + JE @@found + POP ECX +@@parent: + MOV EBX,[EBX].vmtParent + TEST EBX,EBX + JNE @@outerLoop + JMP @@exit + +@@found: + POP EAX + ADD EAX,EAX + SUB EAX,ECX { this will always clear the Z-flag ! } + MOV EBX,[EDI+EAX*2-4] + +@@exit: + POP EDI +end; + +procedure _CallDynaInst; +asm + PUSH EAX + PUSH ECX + MOV EAX,[EAX] + CALL GetDynaMethod + POP ECX + POP EAX + JE @@Abstract + JMP EBX +@@Abstract: + POP ECX + JMP _AbstractError +end; + + +procedure _CallDynaClass; +asm + PUSH EAX + PUSH ECX + CALL GetDynaMethod + POP ECX + POP EAX + JE @@Abstract + JMP EBX +@@Abstract: + POP ECX + JMP _AbstractError +end; + + +procedure _FindDynaInst; +asm + PUSH EBX + MOV EBX,EDX + MOV EAX,[EAX] + CALL GetDynaMethod + MOV EAX,EBX + POP EBX + JNE @@exit + POP ECX + JMP _AbstractError +@@exit: +end; + + +procedure _FindDynaClass; +asm + PUSH EBX + MOV EBX,EDX + CALL GetDynaMethod + MOV EAX,EBX + POP EBX + JNE @@exit + POP ECX + JMP _AbstractError +@@exit: +end; + + +class function TObject.InheritsFrom(AClass: TClass): Boolean; +asm + { -> EAX Pointer to our class } + { EDX Pointer to AClass } + { <- AL Boolean result } + JMP @@haveVMT +@@loop: + MOV EAX,[EAX] +@@haveVMT: + CMP EAX,EDX + JE @@success + MOV EAX,[EAX].vmtParent + TEST EAX,EAX + JNE @@loop + JMP @@exit +@@success: + MOV AL,1 +@@exit: +end; + + +class function TObject.ClassInfo: Pointer; +asm + MOV EAX,[EAX].vmtTypeInfo +end; + + +function TObject.SafeCallException(ExceptObject: TObject; + ExceptAddr: Pointer): HResult; +begin + Result := HResult($8000FFFF); { E_UNEXPECTED } +end; + + +procedure TObject.DefaultHandler(var Message); +begin +end; + + +procedure TObject.AfterConstruction; +begin +end; + +procedure TObject.BeforeDestruction; +begin +end; + +procedure TObject.Dispatch(var Message); +asm + PUSH EBX + MOV BX,[EDX] + OR BX,BX + JE @@default + CMP BX,0C000H + JAE @@default + PUSH EAX + MOV EAX,[EAX] + CALL GetDynaMethod + POP EAX + JE @@default + MOV ECX,EBX + POP EBX + JMP ECX + +@@default: + POP EBX + MOV ECX,[EAX] + JMP dword ptr [ECX].vmtDefaultHandler +end; + + +class function TObject.MethodAddress(const Name: ShortString): Pointer; +asm + { -> EAX Pointer to class } + { EDX Pointer to name } + PUSH EBX + PUSH ESI + PUSH EDI + XOR ECX,ECX + XOR EDI,EDI + MOV BL,[EDX] + JMP @@haveVMT +@@outer: { upper 16 bits of ECX are 0 ! } + MOV EAX,[EAX] +@@haveVMT: + MOV ESI,[EAX].vmtMethodTable + TEST ESI,ESI + JE @@parent + MOV DI,[ESI] { EDI := method count } + ADD ESI,2 +@@inner: { upper 16 bits of ECX are 0 ! } + MOV CL,[ESI+6] { compare length of strings } + CMP CL,BL + JE @@cmpChar +@@cont: { upper 16 bits of ECX are 0 ! } + MOV CX,[ESI] { fetch length of method desc } + ADD ESI,ECX { point ESI to next method } + DEC EDI + JNZ @@inner +@@parent: + MOV EAX,[EAX].vmtParent { fetch parent vmt } + TEST EAX,EAX + JNE @@outer + JMP @@exit { return NIL } + +@@notEqual: + MOV BL,[EDX] { restore BL to length of name } + JMP @@cont + +@@cmpChar: { upper 16 bits of ECX are 0 ! } + MOV CH,0 { upper 24 bits of ECX are 0 ! } +@@cmpCharLoop: + MOV BL,[ESI+ECX+6] { case insensitive string cmp } + XOR BL,[EDX+ECX+0] { last char is compared first } + AND BL,$DF + JNE @@notEqual + DEC ECX { ECX serves as counter } + JNZ @@cmpCharLoop + + { found it } + MOV EAX,[ESI+2] + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +class function TObject.MethodName(Address: Pointer): ShortString; +asm + { -> EAX Pointer to class } + { EDX Address } + { ECX Pointer to result } + PUSH EBX + PUSH ESI + PUSH EDI + MOV EDI,ECX + XOR EBX,EBX + XOR ECX,ECX + JMP @@haveVMT +@@outer: + MOV EAX,[EAX] +@@haveVMT: + MOV ESI,[EAX].vmtMethodTable { fetch pointer to method table } + TEST ESI,ESI + JE @@parent + MOV CX,[ESI] + ADD ESI,2 +@@inner: + CMP EDX,[ESI+2] + JE @@found + MOV BX,[ESI] + ADD ESI,EBX + DEC ECX + JNZ @@inner +@@parent: + MOV EAX,[EAX].vmtParent + TEST EAX,EAX + JNE @@outer + MOV [EDI],AL + JMP @@exit + +@@found: + ADD ESI,6 + XOR ECX,ECX + MOV CL,[ESI] + INC ECX + REP MOVSB + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +function TObject.FieldAddress(const Name: ShortString): Pointer; +asm + { -> EAX Pointer to instance } + { EDX Pointer to name } + PUSH EBX + PUSH ESI + PUSH EDI + XOR ECX,ECX + XOR EDI,EDI + MOV BL,[EDX] + + PUSH EAX { save instance pointer } + +@@outer: + MOV EAX,[EAX] { fetch class pointer } + MOV ESI,[EAX].vmtFieldTable + TEST ESI,ESI + JE @@parent + MOV DI,[ESI] { fetch count of fields } + ADD ESI,6 +@@inner: + MOV CL,[ESI+6] { compare string lengths } + CMP CL,BL + JE @@cmpChar +@@cont: + LEA ESI,[ESI+ECX+7] { point ESI to next field } + DEC EDI + JNZ @@inner +@@parent: + MOV EAX,[EAX].vmtParent { fetch parent VMT } + TEST EAX,EAX + JNE @@outer + POP EDX { forget instance, return Nil } + JMP @@exit + +@@notEqual: + MOV BL,[EDX] { restore BL to length of name } + MOV CL,[ESI+6] { ECX := length of field name } + JMP @@cont + +@@cmpChar: + MOV BL,[ESI+ECX+6] { case insensitive string cmp } + XOR BL,[EDX+ECX+0] { starting with last char } + AND BL,$DF + JNE @@notEqual + DEC ECX { ECX serves as counter } + JNZ @@cmpChar + + { found it } + MOV EAX,[ESI] { result is field offset plus ... } + POP EDX + ADD EAX,EDX { instance pointer } + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +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; + +type + JmpInstruction = + packed record + opCode: Byte; + distance: Longint; + end; + TExcDescEntry = + record + vTable: Pointer; + handler: Pointer; + end; + PExcDesc = ^TExcDesc; + TExcDesc = + packed record + jmp: JmpInstruction; + case Integer of + 0: (instructions: array [0..0] of Byte); + 1{...}: (cnt: Integer; excTab: array [0..0{cnt-1}] of TExcDescEntry); + end; + + 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; + + PRaiseFrame = ^TRaiseFrame; + TRaiseFrame = packed record + NextRaise: PRaiseFrame; + ExceptAddr: Pointer; + ExceptObject: TObject; + ExceptionRecord: PExceptionRecord; + end; + + +procedure _ClassCreate; +asm + { -> EAX = pointer to VMT } + { <- EAX = pointer to instance } + PUSH EDX + PUSH ECX + PUSH EBX + TEST DL,DL + JL @@noAlloc + CALL dword ptr [EAX].vmtNewInstance +@@noAlloc: + XOR EDX,EDX + LEA ECX,[ESP+16] + MOV EBX,FS:[EDX] + MOV [ECX].TExcFrame.next,EBX + MOV [ECX].TExcFrame.hEBP,EBP + MOV [ECX].TExcFrame.desc,offset @desc + MOV [ECX].TexcFrame.ConstructedObject,EAX { trick: remember copy to instance } + MOV FS:[EDX],ECX + POP EBX + POP ECX + POP EDX + RET + +@desc: + JMP _HandleAnyException + + { destroy the object } + + MOV EAX,[ESP+8+9*4] + MOV EAX,[EAX].TExcFrame.ConstructedObject + TEST EAX,EAX + JE @@skip + MOV ECX,[EAX] + MOV DL,$81 + PUSH EAX + CALL dword ptr [ECX].vmtDestroy + POP EAX + CALL _ClassDestroy +@@skip: + { reraise the exception } + CALL _RaiseAgain +end; + + +procedure _ClassDestroy; +asm + MOV EDX,[EAX] + CALL dword ptr [EDX].vmtFreeInstance +end; + + +procedure _AfterConstruction; +asm + { -> EAX = pointer to instance } + + PUSH EAX + MOV EDX,[EAX] + CALL dword ptr [EDX].vmtAfterConstruction + POP EAX +end; + +procedure _BeforeDestruction; +asm + { -> EAX = pointer to instance } + { DL = dealloc flag } + + TEST DL,DL + JG @@outerMost + RET +@@outerMost: + PUSH EAX + PUSH EDX + MOV EDX,[EAX] + CALL dword ptr [EDX].vmtBeforeDestruction + POP EDX + POP EAX +end; + +{ + 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_CONTINE 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; +asm + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH 0 + PUSH 0 + PUSH cContinuable + PUSH cDelphiReRaise + CALL RaiseException +@@1: +end; + +{ tell the debugger about the raise of a non-Delphi exception } +procedure NotifyNonDelphiException; +asm + CMP BYTE PTR DebugHook,0 + JE @@1 + PUSH EAX + PUSH EAX + PUSH EDX + PUSH ESP + PUSH 2 + PUSH cContinuable + PUSH cNonDelphiException + CALL RaiseException + ADD ESP,8 + POP EAX +@@1: +end; + +{ Tell the debugger where the handler for the current exception is located } +procedure NotifyExcept; +asm + PUSH ESP + PUSH 1 + PUSH cContinuable + PUSH cDelphiExcept { our magic exception code } + CALL RaiseException + ADD ESP,4 + POP EAX +end; + +procedure NotifyOnExcept; +asm + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH EAX + PUSH [EBX].TExcDescEntry.handler + JMP NotifyExcept +@@1: +end; + +procedure NotifyAnyExcept; +asm + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH EAX + PUSH EBX + JMP NotifyExcept +@@1: +end; + +procedure CheckJmp; +asm + TEST ECX,ECX + JE @@3 + MOV EAX,[ECX + 1] + CMP BYTE PTR [ECX],0E9H { near jmp } + JE @@1 + CMP BYTE PTR [ECX],0EBH { short jmp } + JNE @@3 + MOVSX EAX,AL + INC ECX + INC ECX + JMP @@2 +@@1: + ADD ECX,5 +@@2: + ADD ECX,EAX +@@3: +end; + +{ Notify debugger of a finally during an exception unwind } +procedure NotifyExceptFinally; +asm + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH EAX + PUSH EDX + PUSH ECX + CALL CheckJmp + PUSH ECX + PUSH ESP { pass pointer to arguments } + PUSH 1 { there is 1 argument } + PUSH cContinuable { continuable execution } + PUSH cDelphiFinally { our magic exception code } + CALL RaiseException + POP ECX + POP ECX + POP EDX + POP EAX +@@1: +end; + + +{ Tell the debugger that the current exception is handled and cleaned up. + Also indicate where execution is about to resume. } +procedure NotifyTerminate; +asm + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH EDX + PUSH ESP + PUSH 1 + PUSH cContinuable + PUSH cDelphiTerminate { our magic exception code } + CALL RaiseException + POP EDX +@@1: +end; + +{ Tell the debugger that there was no handler found for the current execption + and we are about to go to the default handler } +procedure NotifyUnhandled; +asm + PUSH EAX + PUSH EDX + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH ESP + PUSH 2 + PUSH cContinuable + PUSH cDelphiUnhandled + CALL RaiseException +@@1: + POP EDX + POP EAX +end; + + +procedure _HandleAnyException; +asm + { -> [ESP+ 4] excPtr: PExceptionRecord } + { [ESP+ 8] errPtr: PExcFrame } + { [ESP+12] ctxPtr: Pointer } + { [ESP+16] dspPtr: Pointer } + { <- EAX return value - always one } + + MOV EAX,[ESP+4] + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JNE @@exit + + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + MOV EDX,[EAX].TExceptionRecord.ExceptObject + MOV ECX,[EAX].TExceptionRecord.ExceptAddr + JE @@DelphiException + CLD + CALL FpuInit + MOV EDX,ExceptObjProc + TEST EDX,EDX + JE @@exit + CALL EDX + TEST EAX,EAX + JE @@exit + MOV EDX,[ESP+12] + MOV ECX,[ESP+4] + CMP [ECX].TExceptionRecord.ExceptionCode,cCppException + JE @@CppException + CALL NotifyNonDelphiException + CMP BYTE PTR JITEnable,0 + JBE @@CppException + CMP BYTE PTR DebugHook,0 + JA @@CppException { Do not JIT if debugging } + LEA ECX,[ESP+4] + PUSH EAX + PUSH ECX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + POP EAX + JE @@exit + MOV EDX,EAX + MOV EAX,[ESP+4] + MOV ECX,[EAX].TExceptionRecord.ExceptionAddress + JMP @@GoUnwind + +@@CppException: + MOV EDX,EAX + MOV EAX,[ESP+4] + MOV ECX,[EAX].TExceptionRecord.ExceptionAddress + +@@DelphiException: + CMP BYTE PTR JITEnable,1 + JBE @@GoUnwind + CMP BYTE PTR DebugHook,0 { Do not JIT if debugging } + JA @@GoUnwind + PUSH EAX + LEA EAX,[ESP+8] + PUSH EDX + PUSH ECX + PUSH EAX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + POP ECX + POP EDX + POP EAX + JE @@exit + +@@GoUnwind: + OR [EAX].TExceptionRecord.ExceptionFlags,cUnwinding + + PUSH EBX + XOR EBX,EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBX,FS:[EBX] + PUSH EBX { Save pointer to topmost frame } + PUSH EAX { Save OS exception pointer } + PUSH EDX { Save exception object } + PUSH ECX { Save exception address } + + MOV EDX,[ESP+8+8*4] + + PUSH 0 + PUSH EAX + PUSH offset @@returnAddress + PUSH EDX + CALL RtlUnwind +@@returnAddress: + + MOV EDI,[ESP+8+8*4] + + { Make the RaiseList entry on the stack } + + CALL SysInit.@GetTLS + PUSH [EAX].RaiseListPtr + MOV [EAX].RaiseListPtr,ESP + + MOV EBP,[EDI].TExcFrame.hEBP + MOV EBX,[EDI].TExcFrame.desc + MOV [EDI].TExcFrame.desc,offset @@exceptFinally + + ADD EBX,TExcDesc.instructions + CALL NotifyAnyExcept + JMP EBX + +@@exceptFinally: + JMP _HandleFinally + +@@destroyExcept: + { we come here if an exception handler has thrown yet another exception } + { we need to destroy the exception object and pop the raise list. } + + CALL SysInit.@GetTLS + MOV ECX,[EAX].RaiseListPtr + MOV EDX,[ECX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,EDX + + MOV EAX,[ECX].TRaiseFrame.ExceptObject + JMP TObject.Free + +@@exit: + MOV EAX,1 +end; + + +procedure _HandleOnException; +asm + { -> [ESP+ 4] excPtr: PExceptionRecord } + { [ESP+ 8] errPtr: PExcFrame } + { [ESP+12] ctxPtr: Pointer } + { [ESP+16] dspPtr: Pointer } + { <- EAX return value - always one } + + MOV EAX,[ESP+4] + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JNE @@exit + + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + JE @@DelphiException + CLD + CALL FpuInit + MOV EDX,ExceptClsProc + TEST EDX,EDX + JE @@exit + CALL EDX + TEST EAX,EAX + JNE @@common + JMP @@exit + +@@DelphiException: + MOV EAX,[EAX].TExceptionRecord.ExceptObject + MOV EAX,[EAX] { load vtable of exception object } + +@@common: + + MOV EDX,[ESP+8] + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV ECX,[EDX].TExcFrame.desc + MOV EBX,[ECX].TExcDesc.cnt + LEA ESI,[ECX].TExcDesc.excTab { point ECX to exc descriptor table } + MOV EBP,EAX { load vtable of exception object } + +@@innerLoop: + MOV EAX,[ESI].TExcDescEntry.vTable + TEST EAX,EAX { catch all clause? } + JE @@doHandler { yes: go execute handler } + MOV EDI,EBP { load vtable of exception object } + JMP @@haveVMT + +@@vtLoop: + MOV EDI,[EDI] +@@haveVMT: + MOV EAX,[EAX] + CMP EAX,EDI + JE @@doHandler + + MOV ECX,[EAX].vmtInstanceSize + CMP ECX,[EDI].vmtInstanceSize + JNE @@parent + + MOV EAX,[EAX].vmtClassName + MOV EDX,[EDI].vmtClassName + + XOR ECX,ECX + MOV CL,[EAX] + CMP CL,[EDX] + JNE @@parent + + INC EAX + INC EDX + CALL _AStrCmp + JE @@doHandler + +@@parent: + MOV EDI,[EDI].vmtParent { load vtable of parent } + MOV EAX,[ESI].TExcDescEntry.vTable + TEST EDI,EDI + JNE @@vtLoop + + ADD ESI,8 + DEC EBX + JNZ @@innerLoop + + POP EBP + POP EDI + POP ESI + POP EBX + JMP @@exit + +@@doHandler: + MOV EAX,[ESP+4+4*4] + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + MOV EDX,[EAX].TExceptionRecord.ExceptObject + MOV ECX,[EAX].TExceptionRecord.ExceptAddr + JE @@haveObject + CALL ExceptObjProc + MOV EDX,[ESP+12+4*4] + CALL NotifyNonDelphiException + CMP BYTE PTR JITEnable,0 + JBE @@NoJIT + CMP BYTE PTR DebugHook,0 + JA @@noJIT { Do not JIT if debugging } + LEA ECX,[ESP+4] + PUSH EAX + PUSH ECX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + POP EAX + JE @@exit +@@noJIT: + MOV EDX,EAX + MOV EAX,[ESP+4+4*4] + MOV ECX,[EAX].TExceptionRecord.ExceptionAddress + JMP @@GoUnwind + +@@haveObject: + CMP BYTE PTR JITEnable,1 + JBE @@GoUnwind + CMP BYTE PTR DebugHook,0 + JA @@GoUnwind + PUSH EAX + LEA EAX,[ESP+8] + PUSH EDX + PUSH ECX + PUSH EAX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + POP ECX + POP EDX + POP EAX + JE @@exit + +@@GoUnwind: + XOR EBX,EBX + MOV EBX,FS:[EBX] + PUSH EBX { Save topmost frame } + PUSH EAX { Save exception record } + PUSH EDX { Save exception object } + PUSH ECX { Save exception address } + + MOV EDX,[ESP+8+8*4] + OR [EAX].TExceptionRecord.ExceptionFlags,cUnwinding + + PUSH ESI { Save handler entry } + + PUSH 0 + PUSH EAX + PUSH offset @@returnAddress + PUSH EDX + CALL RtlUnwind +@@returnAddress: + + POP EBX { Restore handler entry } + + MOV EDI,[ESP+8+8*4] + + { Make the RaiseList entry on the stack } + + CALL SysInit.@GetTLS + PUSH [EAX].RaiseListPtr + MOV [EAX].RaiseListPtr,ESP + + MOV EBP,[EDI].TExcFrame.hEBP + MOV [EDI].TExcFrame.desc,offset @@exceptFinally + MOV EAX,[ESP].TRaiseFrame.ExceptObject + CALL NotifyOnExcept + JMP [EBX].TExcDescEntry.handler + +@@exceptFinally: + JMP _HandleFinally + +@@destroyExcept: + { we come here if an exception handler has thrown yet another exception } + { we need to destroy the exception object and pop the raise list. } + + CALL SysInit.@GetTLS + MOV ECX,[EAX].RaiseListPtr + MOV EDX,[ECX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,EDX + + MOV EAX,[ECX].TRaiseFrame.ExceptObject + JMP TObject.Free +@@exit: + MOV EAX,1 +end; + + +procedure _HandleFinally; +asm + { -> [ESP+ 4] excPtr: PExceptionRecord } + { [ESP+ 8] errPtr: PExcFrame } + { [ESP+12] ctxPtr: Pointer } + { [ESP+16] dspPtr: Pointer } + { <- EAX return value - always one } + + MOV EAX,[ESP+4] + MOV EDX,[ESP+8] + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JE @@exit + MOV ECX,[EDX].TExcFrame.desc + MOV [EDX].TExcFrame.desc,offset @@exit + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBP,[EDX].TExcFrame.hEBP + ADD ECX,TExcDesc.instructions + CALL NotifyExceptFinally + CALL ECX + + POP EBP + POP EDI + POP ESI + POP EBX + +@@exit: + MOV EAX,1 +end; + + +procedure _HandleAutoException; +asm + { -> [ESP+ 4] excPtr: PExceptionRecord } + { [ESP+ 8] errPtr: PExcFrame } + { [ESP+12] ctxPtr: Pointer } + { [ESP+16] dspPtr: Pointer } + { <- EAX return value - always one } + + MOV EAX,[ESP+4] + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JNE @@exit + + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + CLD + CALL FpuInit + JE @@DelphiException + CMP BYTE PTR JITEnable,0 + JBE @@DelphiException + CMP BYTE PTR DebugHook,0 + JA @@DelphiException + +@@DoUnhandled: + LEA EAX,[ESP+4] + PUSH EAX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + JE @@exit + MOV EAX,[ESP+4] + JMP @@GoUnwind + +@@DelphiException: + CMP BYTE PTR JITEnable,1 + JBE @@GoUnwind + CMP BYTE PTR DebugHook,0 + JA @@GoUnwind + JMP @@DoUnhandled + +@@GoUnwind: + OR [EAX].TExceptionRecord.ExceptionFlags,cUnwinding + + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EDX,[ESP+8+3*4] + + PUSH 0 + PUSH EAX + PUSH offset @@returnAddress + PUSH EDX + CALL RtlUnwind + +@@returnAddress: + POP EBP + POP EDI + POP ESI + MOV EAX,[ESP+4] + MOV EBX,8000FFFFH + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + JNE @@done + + MOV EDX,[EAX].TExceptionRecord.ExceptObject + MOV ECX,[EAX].TExceptionRecord.ExceptAddr + MOV EAX,[ESP+8] + MOV EAX,[EAX].TExcFrame.SelfOfMethod + MOV EBX,[EAX] + CALL [EBX].vmtSafeCallException.Pointer + MOV EBX,EAX + MOV EAX,[ESP+4] + MOV EAX,[EAX].TExceptionRecord.ExceptObject + CALL TObject.Free +@@done: + XOR EAX,EAX + MOV ESP,[ESP+8] + POP ECX + MOV FS:[EAX],ECX + POP EDX + POP EBP + LEA EDX,[EDX].TExcDesc.instructions + POP ECX + JMP EDX +@@exit: + MOV EAX,1 +end; + + +procedure _RaiseExcept; +asm + { When making changes to the way Delphi Exceptions are raised, } + { please realize that the C++ Exception handling code reraises } + { some exceptions as Delphi Exceptions. Of course we want to } + { keep exception raising compatible between Delphi and C++, so } + { when you make changes here, consult with the relevant C++ } + { exception handling engineer. The C++ code is in xx.cpp, in } + { the RTL sources, in function tossAnException. } + + { -> EAX Pointer to exception object } + { [ESP] Error address } + + POP EDX + + PUSH ESP + PUSH EBP + PUSH EDI + PUSH ESI + PUSH EBX + PUSH EAX { pass class argument } + PUSH EDX { pass address argument } + + PUSH ESP { pass pointer to arguments } + PUSH 7 { there are seven arguments } + PUSH cNonContinuable { we can't continue execution } + PUSH cDelphiException { our magic exception code } + PUSH EDX { pass the user's return address } + JMP RaiseException +end; + + +procedure _RaiseAgain; +asm + { -> [ESP ] return address to user program } + { [ESP+ 4 ] raise list entry (4 dwords) } + { [ESP+ 4+ 4*4] saved topmost frame } + { [ESP+ 4+ 5*4] saved registers (4 dwords) } + { [ESP+ 4+ 9*4] return address to OS } + { -> [ESP+ 4+10*4] excPtr: PExceptionRecord } + { [ESP+ 8+10*4] errPtr: PExcFrame } + + { Point the error handler of the exception frame to something harmless } + + MOV EAX,[ESP+8+10*4] + MOV [EAX].TExcFrame.desc,offset @@exit + + { Pop the RaiseList } + + CALL SysInit.@GetTLS + MOV EDX,[EAX].RaiseListPtr + MOV ECX,[EDX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,ECX + + { Destroy any objects created for non-delphi exceptions } + + MOV EAX,[EDX].TRaiseFrame.ExceptionRecord + AND [EAX].TExceptionRecord.ExceptionFlags,NOT cUnwinding + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + JE @@delphiException + MOV EAX,[EDX].TRaiseFrame.ExceptObject + CALL TObject.Free + CALL NotifyReRaise + +@@delphiException: + + XOR EAX,EAX + ADD ESP,5*4 + MOV EDX,FS:[EAX] + POP ECX + MOV EDX,[EDX].TExcFrame.next + MOV [ECX].TExcFrame.next,EDX + + POP EBP + POP EDI + POP ESI + POP EBX +@@exit: + MOV EAX,1 +end; + + +procedure _DoneExcept; +asm + { -> [ESP+ 4+10*4] excPtr: PExceptionRecord } + { [ESP+ 8+10*4] errPtr: PExcFrame } + + { Pop the RaiseList } + + CALL SysInit.@GetTLS + MOV EDX,[EAX].RaiseListPtr + MOV ECX,[EDX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,ECX + + { Destroy exception object } + + MOV EAX,[EDX].TRaiseFrame.ExceptObject + CALL TObject.Free + + POP EDX + MOV ESP,[ESP+8+9*4] + XOR EAX,EAX + POP ECX + MOV FS:[EAX],ECX + POP EAX + POP EBP + CALL NotifyTerminate + JMP EDX +end; + + +procedure _TryFinallyExit; +asm + XOR EDX,EDX + MOV ECX,[ESP+4].TExcFrame.desc + MOV EAX,[ESP+4].TExcFrame.next + ADD ECX,TExcDesc.instructions + MOV FS:[EDX],EAX + CALL ECX +@@1: RET 12 +end; + + +type + PInitContext = ^TInitContext; + TInitContext = record + OuterContext: PInitContext; { saved InitContext } + ExcFrame: PExcFrame; { bottom exc handler } + InitTable: PackageInfo; { unit init info } + InitCount: Integer; { how far we got } + Module: PLibModule; { ptr to module desc } + DLLSaveEBP: Pointer; { saved regs for DLLs } + DLLSaveEBX: Pointer; { saved regs for DLLs } + DLLSaveESI: Pointer; { saved regs for DLLs } + DLLSaveEDI: Pointer; { saved regs for DLLs } + DLLInitState: Byte; + ExitProcessTLS: procedure; { Shutdown for TLS } + end; + +var + InitContext: TInitContext; + +procedure RunErrorAt(ErrCode: Integer; ErrorAddr: Pointer); +asm + MOV [ESP],ErrorAddr + JMP _RunError +end; + +procedure MapToRunError(P: PExceptionRecord); stdcall; +const + STATUS_ACCESS_VIOLATION = $C0000005; + STATUS_ARRAY_BOUNDS_EXCEEDED = $C000008C; + STATUS_FLOAT_DENORMAL_OPERAND = $C000008D; + STATUS_FLOAT_DIVIDE_BY_ZERO = $C000008E; + STATUS_FLOAT_INEXACT_RESULT = $C000008F; + STATUS_FLOAT_INVALID_OPERATION = $C0000090; + STATUS_FLOAT_OVERFLOW = $C0000091; + STATUS_FLOAT_STACK_CHECK = $C0000092; + STATUS_FLOAT_UNDERFLOW = $C0000093; + STATUS_INTEGER_DIVIDE_BY_ZERO = $C0000094; + STATUS_INTEGER_OVERFLOW = $C0000095; + STATUS_PRIVILEGED_INSTRUCTION = $C0000096; + STATUS_STACK_OVERFLOW = $C00000FD; + STATUS_CONTROL_C_EXIT = $C000013A; +var + ErrCode: Byte; +begin + case P.ExceptionCode of + STATUS_INTEGER_DIVIDE_BY_ZERO: ErrCode := 200; + STATUS_ARRAY_BOUNDS_EXCEEDED: ErrCode := 201; + STATUS_FLOAT_OVERFLOW: ErrCode := 205; + STATUS_FLOAT_INEXACT_RESULT, + STATUS_FLOAT_INVALID_OPERATION, + STATUS_FLOAT_STACK_CHECK: ErrCode := 207; + STATUS_FLOAT_DIVIDE_BY_ZERO: ErrCode := 200; + STATUS_INTEGER_OVERFLOW: ErrCode := 215; + STATUS_FLOAT_UNDERFLOW, + STATUS_FLOAT_DENORMAL_OPERAND: ErrCode := 206; + STATUS_ACCESS_VIOLATION: ErrCode := 216; + STATUS_PRIVILEGED_INSTRUCTION: ErrCode := 218; + STATUS_CONTROL_C_EXIT: ErrCode := 217; + STATUS_STACK_OVERFLOW: ErrCode := 202; + else ErrCode := 255; + end; + RunErrorAt(ErrCode, P.ExceptionAddress); +end; + +procedure _ExceptionHandler; +asm + MOV EAX,[ESP+4] + + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JNE @@exit + CMP BYTE PTR DebugHook,0 + JA @@ExecuteHandler + LEA EAX,[ESP+4] + PUSH EAX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + JNE @@ExecuteHandler + JMP @@exit +// MOV EAX,1 +// RET + +@@ExecuteHandler: + MOV EAX,[ESP+4] + CLD + CALL FpuInit + MOV EDX,[ESP+8] + + PUSH 0 + PUSH EAX + PUSH offset @@returnAddress + PUSH EDX + CALL RtlUnwind +@@returnAddress: + + MOV EBX,[ESP+4] + CMP [EBX].TExceptionRecord.ExceptionCode,cDelphiException + MOV EDX,[EBX].TExceptionRecord.ExceptAddr + MOV EAX,[EBX].TExceptionRecord.ExceptObject + JE @@DelphiException2 + + MOV EDX,ExceptObjProc + TEST EDX,EDX + JE MapToRunError + MOV EAX,EBX + CALL EDX + TEST EAX,EAX + JE MapToRunError + MOV EDX,[EBX].TExceptionRecord.ExceptionAddress + +@@DelphiException2: + + CALL NotifyUnhandled + MOV ECX,ExceptProc + TEST ECX,ECX + JE @@noExceptProc + CALL ECX { call ExceptProc(ExceptObject, ExceptAddr) } + +@@noExceptProc: + MOV ECX,[ESP+4] + MOV EAX,217 + MOV EDX,[ECX].TExceptionRecord.ExceptAddr + MOV [ESP],EDX + JMP _RunError + +@@exit: + XOR EAX,EAX +end; + + +procedure SetExceptionHandler; +asm + XOR EDX,EDX { using [EDX] saves some space over [0] } +{X} // now we come here from another place, and EBP is used above for loop counter +{X} // let us restore it... +{X} PUSH EBP +{X} LEA EBP, [ESP + $60] + + LEA EAX,[EBP-12] + + MOV ECX,FS:[EDX] { ECX := head of chain } + MOV FS:[EDX],EAX { head of chain := @exRegRec } + + MOV [EAX].TExcFrame.next,ECX + MOV [EAX].TExcFrame.desc,offset _ExceptionHandler + MOV [EAX].TExcFrame.hEBP,EBP + MOV InitContext.ExcFrame,EAX + +{X} POP EBP +end; + + +procedure UnsetExceptionHandler; +asm + XOR EDX,EDX + MOV EAX,InitContext.ExcFrame + MOV ECX,FS:[EDX] { ECX := head of chain } + CMP EAX,ECX { simple case: our record is first } + JNE @@search + MOV EAX,[EAX] { head of chain := exRegRec.next } + MOV FS:[EDX],EAX + JMP @@exit + +@@loop: + MOV ECX,[ECX] +@@search: + CMP ECX,-1 { at end of list? } + JE @@exit { yes - didn't find it } + CMP [ECX],EAX { is it the next one on the list? } + JNE @@loop { no - look at next one on list } +@@unlink: { yes - unlink our record } + MOV EAX,[EAX] { get next record on list } + MOV [ECX],EAX { unlink our record } +@@exit: +end; + + +{X+ see comments in InitUnits below } +//procedure FInitUnits; {X} - renamed to FInitUnitsHard +{X} procedure FInitUnitsHard; +var + Count: Integer; + Table: PUnitEntryTable; + P: procedure; +begin + if InitContext.InitTable = nil then + exit; + Count := InitContext.InitCount; + Table := InitContext.InitTable^.UnitInfo; + try + while Count > 0 do + begin + Dec(Count); + InitContext.InitCount := Count; + P := Table^[Count].FInit; + if Assigned(P) then + P; + end; + except + {X- rename: FInitUnits; { try to finalize the others } + FInitUnitsHard; + raise; + end; +end; + +// This handler can be set in initialization section of +// unit SysSfIni.pas only. +procedure InitUnitsHard( Table : PUnitEntryTable; Idx, Count : Integer ); +begin + try + InitUnitsLight( Table, Idx, Count ); + except + FInitUnitsHard; + raise; + end; +end; + +{X+ see comments in InitUnits below } +procedure FInitUnitsLight; +var + Count: Integer; + Table: PUnitEntryTable; + P: procedure; +begin + if InitContext.InitTable = nil then + exit; + Count := InitContext.InitCount; + Table := InitContext.InitTable^.UnitInfo; + while Count > 0 do + begin + Dec(Count); + InitContext.InitCount := Count; + P := Table^[Count].FInit; + if Assigned(P) then + P; + end; +end; + +{X+ see comments in InitUnits below } +procedure InitUnitsLight( Table : PUnitEntryTable; Idx, Count : Integer ); +var P : procedure; + Light : Boolean; +begin + Light := @InitUnitsProc = @InitUnitsLight; + while Idx < Count do + begin + P := Table^[ Idx ].Init; + Inc( Idx ); + InitContext.InitCount := Idx; + if Assigned( P ) then + P; + if Light and (@InitUnitsProc <> @InitUnitsLight) then + begin + InitUnitsProc( Table, Idx, Count ); + break; + end; + end; +end; + +{X+ see comments in body of InitUnits below } +procedure InitUnits; +var + Count, I: Integer; + Table: PUnitEntryTable; + {X- P: procedure; } +begin + if InitContext.InitTable = nil then + exit; + Count := InitContext.InitTable^.UnitCount; + I := 0; + Table := InitContext.InitTable^.UnitInfo; + {X- by default, Delphi InitUnits uses try-except & raise constructions, + which leads to permanent use of all exception handler routines. + Let us make this by another way. + try + while I < Count do + begin + P := Table^[I].Init; + Inc(I); + InitContext.InitCount := I; + if Assigned(P) then + P; + end; + except + FInitUnits; + raise; + end; + X+} + InitUnitsProc( Table, I, Count ); +end; + + +procedure _PackageLoad(const Table : PackageInfo); +var + SavedContext: TInitContext; +begin + SavedContext := InitContext; + InitContext.DLLInitState := 0; + InitContext.InitTable := Table; + InitContext.InitCount := 0; + InitContext.OuterContext := @SavedContext; + try + InitUnits; + finally + InitContext := SavedContext; + end; +end; + + +procedure _PackageUnload(const Table : PackageInfo); +var + SavedContext: TInitContext; +begin + SavedContext := InitContext; + InitContext.DLLInitState := 0; + InitContext.InitTable := Table; + InitContext.InitCount := Table^.UnitCount; + InitContext.OuterContext := @SavedContext; + try + FInitUnitsProc; + finally + InitContext := SavedContext; + end; +end; + + +procedure _StartExe; +asm + { -> EAX InitTable } + { EDX Module } + MOV InitContext.InitTable,EAX + XOR EAX,EAX + MOV InitContext.InitCount,EAX + MOV InitContext.Module,EDX + MOV EAX,[EDX].TLibModule.Instance + MOV MainInstance,EAX + + {X CALL SetExceptionHandler - moved to SysSfIni.pas } + + MOV IsLibrary,0 + + CALL InitUnits; +end; + + +procedure _StartLib; +asm + { -> EAX InitTable } + { EDX Module } + { ECX InitTLS } + { [ESP+4] DllProc } + { [EBP+8] HInst } + { [EBP+12] Reason } + + { Push some desperately needed registers } + + PUSH ECX + PUSH ESI + PUSH EDI + + { Save the current init context into the stackframe of our caller } + + MOV ESI,offset InitContext + LEA EDI,[EBP- (type TExcFrame) - (type TInitContext)] + MOV ECX,(type TInitContext)/4 + REP MOVSD + + { Setup the current InitContext } + + POP InitContext.DLLSaveEDI + POP InitContext.DLLSaveESI + MOV InitContext.DLLSaveEBP,EBP + MOV InitContext.DLLSaveEBX,EBX + MOV InitContext.InitTable,EAX + MOV InitContext.Module,EDX + LEA ECX,[EBP- (type TExcFrame) - (type TInitContext)] + MOV InitContext.OuterContext,ECX + XOR ECX,ECX + CMP dword ptr [EBP+12],0 + JNE @@notShutDown + MOV ECX,[EAX].PackageInfoTable.UnitCount +@@notShutDown: + MOV InitContext.InitCount,ECX + + CALL SetExceptionHandler {X-- could be moved to SysSfIni.pas but ...} + + MOV EAX,[EBP+12] + INC EAX + MOV InitContext.DLLInitState,AL + DEC EAX + + { Init any needed TLS } + + POP ECX + MOV EDX,[ECX] + MOV InitContext.ExitProcessTLS,EDX + JE @@noTLSproc + CALL dword ptr [ECX+EAX*4] +@@noTLSproc: + + { Call any DllProc } + + MOV EDX,[ESP+4] + TEST EDX,EDX + JE @@noDllProc + MOV EAX,[EBP+12] + CALL EDX +@@noDllProc: + + { Set IsLibrary if there was no exe yet } + + CMP MainInstance,0 + JNE @@haveExe + MOV IsLibrary,1 + FNSTCW Default8087CW // save host exe's FPU preferences + +@@haveExe: + + MOV EAX,[EBP+12] + DEC EAX + JNE _Halt0 + CALL InitUnits + RET 4 +end; + + +procedure _InitResStrings; +asm + { -> EAX Pointer to init table } + { record } + { cnt: Integer; } + { tab: array [1..cnt] record } + { variableAddress: Pointer; } + { resStringAddress: Pointer; } + { end; } + { end; } + + PUSH EBX + PUSH ESI + MOV EBX,[EAX] + LEA ESI,[EAX+4] +@@loop: + MOV EAX,[ESI+4] { load resStringAddress } + MOV EDX,[ESI] { load variableAddress } + CALL LoadResString + ADD ESI,8 + DEC EBX + JNZ @@loop + + POP ESI + POP EBX +end; + +procedure _InitResStringImports; +asm + { -> EAX Pointer to init table } + { record } + { cnt: Integer; } + { tab: array [1..cnt] record } + { variableAddress: Pointer; } + { resStringAddress: ^Pointer; } + { end; } + { end; } + + PUSH EBX + PUSH ESI + MOV EBX,[EAX] + LEA ESI,[EAX+4] +@@loop: + MOV EAX,[ESI+4] { load address of import } + MOV EDX,[ESI] { load address of variable } + MOV EAX,[EAX] { load contents of import } + CALL LoadResString + ADD ESI,8 + DEC EBX + JNZ @@loop + + POP ESI + POP EBX +end; + +procedure _InitImports; +asm + { -> EAX Pointer to init table } + { record } + { cnt: Integer; } + { tab: array [1..cnt] record } + { variableAddress: Pointer; } + { sourceAddress: ^Pointer; } + { sourceOffset: Longint; } + { end; } + { end; } + + PUSH EBX + PUSH ESI + MOV EBX,[EAX] + LEA ESI,[EAX+4] +@@loop: + MOV EAX,[ESI+4] { load address of import } + MOV EDX,[ESI] { load address of variable } + MOV ECX,[ESI+8] { load offset } + MOV EAX,[EAX] { load contents of import } + ADD EAX,ECX { calc address of variable } + MOV [EDX],EAX { store result } + ADD ESI,12 + DEC EBX + JNZ @@loop + + POP ESI + POP EBX +end; + +procedure _InitWideStrings; +asm + { -> EAX Pointer to init table } + { record } + { cnt: Integer; } + { tab: array [1..cnt] record } + { variableAddress: Pointer; } + { stringAddress: ^Pointer; } + { end; } + { end; } + + PUSH EBX + PUSH ESI + MOV EBX,[EAX] + LEA ESI,[EAX+4] +@@loop: + MOV EDX,[ESI+4] { load address of string } + MOV EAX,[ESI] { load address of variable } + CALL _WStrAsg + ADD ESI,8 + DEC EBX + JNZ @@loop + + POP ESI + POP EBX +end; + +var + runErrMsg: array[0..29] of Char = 'Runtime error at 00000000'#0; + // columns: 0123456789012345678901234567890 + errCaption: array[0..5] of Char = 'Error'#0; + + +procedure MakeErrorMessage; +const + dig : array [0..15] of Char = '0123456789ABCDEF'; +asm + PUSH EBX + MOV EAX,ExitCode + MOV EBX,offset runErrMsg + 16 + MOV ECX,10 + +@@digLoop: + XOR EDX,EDX + DIV ECX + ADD DL,'0' + MOV [EBX],DL + DEC EBX + TEST EAX,EAX + JNZ @@digLoop + + MOV EAX,ErrorAddr + + CALL FindHInstance + MOV EDX, ErrorAddr + XCHG EAX, EDX + SUB EAX, EDX { EAX <=> offset from start of code for HINSTANCE } + MOV EBX,offset runErrMsg + 28 + +@@hdigLoop: + MOV EDX,EAX + AND EDX,0FH + MOV DL,byte ptr dig[EDX] + MOV [EBX],DL + DEC EBX + SHR EAX,4 + JNE @@hdigLoop + POP EBX +end; + + +procedure ExitDll; +asm + { Restore the InitContext } + + MOV EDI,offset InitContext + + MOV EBX,InitContext.DLLSaveEBX + MOV EBP,InitContext.DLLSaveEBP + PUSH [EDI].TInitContext.DLLSaveESI + PUSH [EDI].TInitContext.DLLSaveEDI + + MOV ESI,[EDI].TInitContext.OuterContext + MOV ECX,(type TInitContext)/4 + REP MOVSD + POP EDI + POP ESI + + { Return False if ExitCode <> 0, and set ExitCode to 0 } + + XOR EAX,EAX + XCHG EAX,ExitCode + NEG EAX + SBB EAX,EAX + INC EAX + LEAVE + RET 12 +end; + +// {X} Procedure Halt0 refers to WriteLn and MessageBox +// but actually such code can be not used really. +// So, implementation changed to avoid such references. +// +// Either call UseErrorMessageBox or UseErrorMessageWrite +// to provide error message output in GUI or console app. +// {X}+ + +var ErrorMessageOutProc : procedure = DummyProc; + +procedure ErrorMessageBox; +begin + MakeErrorMessage; + if not NoErrMsg then + MessageBox(0, runErrMsg, errCaption, 0); +end; + +procedure UseErrorMessageBox; +begin + ErrorMessageOutProc := ErrorMessageBox; +end; + +procedure ErrorMessageWrite; +begin + MakeErrorMessage; + WriteLn(PChar(@runErrMsg)); +end; + +procedure UseErrorMessageWrite; +begin + ErrorMessageOutProc := ErrorMessageWrite; +end; + +procedure DoCloseInputOutput; +begin + Close( Input ); + Close( Output ); +end; + +var CloseInputOutput : procedure; + +procedure UseInputOutput; +begin + if not assigned( CloseInputOutput ) then + begin + CloseInputOutput := DoCloseInputOutput; + _Assign( Input, '' ); + _Assign( Output, '' ); + end; +end; + +// {X}- + +procedure _Halt0; +var + P: procedure; +begin + + if InitContext.DLLInitState = 0 then + while ExitProc <> nil do + begin + @P := ExitProc; + ExitProc := nil; + P; + end; + + { If there was some kind of runtime error, alert the user } + + if ErrorAddr <> nil then + begin + {X+} + ErrorMessageOutProc; + { + MakeErrorMessage; + if IsConsole then + WriteLn(PChar(@runErrMsg)) + else if not NoErrMsg then + MessageBox(0, runErrMsg, errCaption, 0); + } {X-} + + {X- As it is said by Alexey Torgashin, it is better not to clear ErrorAddr + to make possible check ErrorAddr <> nil in finalization of rest units. + If You want, You can uncomment it again: } + //ErrorAddr := nil; + {X+} + end; + + { This loop exists because we might be nested in PackageLoad calls when } + { Halt got called. We need to unwind these contexts. } + + while True do + begin + + { If we are a library, and we are starting up fine, there are no units to finalize } + + if (InitContext.DLLInitState = 2) and (ExitCode = 0) then + InitContext.InitCount := 0; + + { Undo any unit initializations accomplished so far } + + FInitUnitsProc; + + if (InitContext.DLLInitState <= 1) or (ExitCode <> 0) then + if InitContext.Module <> nil then + with InitContext do + begin + UnregisterModule(Module); + if Module.ResInstance <> Module.Instance then + FreeLibrary(Module.ResInstance); + end; + + {X UnsetExceptionHandler; - changed to call of handler } + UnsetExceptionHandlerProc; + + if InitContext.DllInitState = 1 then + InitContext.ExitProcessTLS; + + if InitContext.DllInitState <> 0 then + ExitDll; + + if InitContext.OuterContext = nil then + ExitProcess(ExitCode); + + InitContext := InitContext.OuterContext^ + end; + + asm + db 'Portions Copyright (c) 1983,99 Borland',0 + end; + +end; + + +procedure _Halt; +asm + MOV ExitCode,EAX + JMP _Halt0 +end; + + +procedure _Run0Error; +asm + XOR EAX,EAX + JMP _RunError +end; + + +procedure _RunError; +asm + POP ErrorAddr + JMP _Halt +end; + + +procedure _Assert(const Message, Filename: AnsiString; LineNumber: Integer); +asm + CMP AssertErrorProc,0 + JE @@1 + PUSH [ESP].Pointer + CALL AssertErrorProc + RET +@@1: MOV AL,reAssertionFailed + JMP Error +end; + +type + PThreadRec = ^TThreadRec; + TThreadRec = record + Func: TThreadFunc; + Parameter: Pointer; + end; + + +function ThreadWrapper(Parameter: Pointer): Integer; stdcall; +asm + CALL FpuInit + XOR ECX,ECX + PUSH EBP + PUSH offset _ExceptionHandler + MOV EDX,FS:[ECX] + PUSH EDX + MOV EAX,Parameter + MOV FS:[ECX],ESP + + MOV ECX,[EAX].TThreadRec.Parameter + MOV EDX,[EAX].TThreadRec.Func + PUSH ECX + PUSH EDX + CALL _FreeMem + POP EDX + POP EAX + CALL EDX + + XOR EDX,EDX + POP ECX + MOV FS:[EDX],ECX + POP ECX + POP EBP +end; + + +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; + + +type + StrRec = packed record + allocSiz: Longint; + refCnt: Longint; + length: Longint; + end; + +const + skew = sizeof(StrRec); + rOff = sizeof(StrRec) - sizeof(Longint); { refCnt offset } + overHead = sizeof(StrRec) + 1; + + +procedure _LStrClr(var S: AnsiString); +asm + { -> EAX pointer to str } + + MOV EDX,[EAX] { fetch str } + TEST EDX,EDX { if nil, nothing to do } + JE @@done + MOV dword ptr [EAX],0 { clear str } + MOV ECX,[EDX-skew].StrRec.refCnt { fetch refCnt } + DEC ECX { if < 0: literal str } + JL @@done +{X LOCK} DEC [EDX-skew].StrRec.refCnt { NONthreadsafe dec refCount } + JNE @@done + PUSH EAX + LEA EAX,[EDX-skew].StrRec.refCnt { if refCnt now zero, deallocate} + CALL _FreeMem + POP EAX +@@done: +end; + + +procedure _LStrArrayClr{var str: AnsiString; cnt: longint}; +asm + { -> EAX pointer to str } + { EDX cnt } + + PUSH EBX + PUSH ESI + MOV EBX,EAX + MOV ESI,EDX + +@@loop: + MOV EDX,[EBX] { fetch str } + TEST EDX,EDX { if nil, nothing to do } + JE @@doneEntry + MOV dword ptr [EBX],0 { clear str } + MOV ECX,[EDX-skew].StrRec.refCnt { fetch refCnt } + DEC ECX { if < 0: literal str } + JL @@doneEntry +{X LOCK} DEC [EDX-skew].StrRec.refCnt { NONthreadsafe dec refCount } + JNE @@doneEntry + LEA EAX,[EDX-skew].StrRec.refCnt { if refCnt now zero, deallocate} + CALL _FreeMem +@@doneEntry: + ADD EBX,4 + DEC ESI + JNE @@loop + + POP ESI + POP EBX +end; + +{ 99.03.11 + This function is used when assigning to global variables. + + Literals are copied to prevent a situation where a dynamically + allocated DLL or package assigns a literal to a variable and then + is unloaded -- thereby causing the string memory (in the code + segment of the DLL) to be removed -- and therefore leaving the + global variable pointing to invalid memory. +} +procedure _LStrAsg{var dest: AnsiString; source: AnsiString}; +asm + { -> EAX pointer to dest str } + { -> EDX pointer to source str } + + TEST EDX,EDX { have a source? } + JE @@2 { no -> jump } + + MOV ECX,[EDX-skew].StrRec.refCnt + INC ECX + JG @@1 { literal string -> jump not taken } + + PUSH EAX + PUSH EDX + MOV EAX,[EDX-skew].StrRec.length + CALL _NewAnsiString + MOV EDX,EAX + POP EAX + PUSH EDX + MOV ECX,[EAX-skew].StrRec.length + CALL Move + POP EDX + POP EAX + JMP @@2 + +@@1: + {X LOCK} INC [EDX-skew].StrRec.refCnt + +@@2: XCHG EDX,[EAX] + TEST EDX,EDX + JE @@3 + MOV ECX,[EDX-skew].StrRec.refCnt + DEC ECX + JL @@3 + {X LOCK} DEC [EDX-skew].StrRec.refCnt + JNE @@3 + LEA EAX,[EDX-skew].StrRec.refCnt + CALL _FreeMem +@@3: +end; + +procedure _LStrLAsg{var dest: AnsiString; source: AnsiString}; +asm +{ -> EAX pointer to dest } +{ EDX source } + + TEST EDX,EDX + JE @@sourceDone + + { bump up the ref count of the source } + + MOV ECX,[EDX-skew].StrRec.refCnt + INC ECX + JLE @@sourceDone { literal assignment -> jump taken } +{X LOCK} INC [EDX-skew].StrRec.refCnt +@@sourceDone: + + { we need to release whatever the dest is pointing to } + + XCHG EDX,[EAX] { fetch str } + TEST EDX,EDX { if nil, nothing to do } + JE @@done + MOV ECX,[EDX-skew].StrRec.refCnt { fetch refCnt } + DEC ECX { if < 0: literal str } + JL @@done +{X LOCK} DEC [EDX-skew].StrRec.refCnt { NONthreadsafe dec refCount } + JNE @@done + LEA EAX,[EDX-skew].StrRec.refCnt { if refCnt now zero, deallocate} + CALL _FreeMem +@@done: +end; + +procedure _NewAnsiString{length: Longint}; +asm + { -> EAX length } + { <- EAX pointer to new string } + + TEST EAX,EAX + JLE @@null + PUSH EAX + ADD EAX,rOff+1 + CALL _GetMem + ADD EAX,rOff + POP EDX + MOV [EAX-skew].StrRec.length,EDX + MOV [EAX-skew].StrRec.refCnt,1 + MOV byte ptr [EAX+EDX],0 + RET + +@@null: + XOR EAX,EAX +end; + + +procedure _LStrFromPCharLen(var Dest: AnsiString; Source: PAnsiChar; Length: Integer); +asm + { -> EAX pointer to dest } + { EDX source } + { ECX length } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + { allocate new string } + + MOV EAX,EDI + + CALL _NewAnsiString + MOV ECX,EDI + MOV EDI,EAX + + TEST ESI,ESI + JE @@noMove + + MOV EDX,EAX + MOV EAX,ESI + CALL Move + + { assign the result to dest } + +@@noMove: + MOV EAX,EBX + CALL _LStrClr + MOV [EBX],EDI + + POP EDI + POP ESI + POP EBX +end; + + +procedure _LStrFromPWCharLen(var Dest: AnsiString; Source: PWideChar; Length: Integer); +var + DestLen: Integer; + Buffer: array[0..2047] of Char; +begin + if Length <= 0 then + begin + _LStrClr(Dest); + Exit; + end; + if Length < SizeOf(Buffer) div 2 then + begin + DestLen := WideCharToMultiByte(0, 0, Source, Length, + Buffer, SizeOf(Buffer), nil, nil); + if DestLen > 0 then + begin + _LStrFromPCharLen(Dest, Buffer, DestLen); + Exit; + end; + end; + DestLen := WideCharToMultiByte(0, 0, Source, Length, nil, 0, nil, nil); + _LStrFromPCharLen(Dest, nil, DestLen); + WideCharToMultiByte(0, 0, Source, Length, Pointer(Dest), DestLen, nil, nil); +end; + + +procedure _LStrFromChar(var Dest: AnsiString; Source: AnsiChar); +asm + PUSH EDX + MOV EDX,ESP + MOV ECX,1 + CALL _LStrFromPCharLen + POP EDX +end; + + +procedure _LStrFromWChar(var Dest: AnsiString; Source: WideChar); +asm + PUSH EDX + MOV EDX,ESP + MOV ECX,1 + CALL _LStrFromPWCharLen + POP EDX +end; + + +procedure _LStrFromPChar(var Dest: AnsiString; Source: PAnsiChar); +asm + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CL,[EDX+0] + JE @@4 + CMP CL,[EDX+1] + JE @@3 + CMP CL,[EDX+2] + JE @@2 + CMP CL,[EDX+3] + JE @@1 + ADD EDX,4 + JMP @@0 +@@1: INC EDX +@@2: INC EDX +@@3: INC EDX +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX +@@5: JMP _LStrFromPCharLen +end; + + +procedure _LStrFromPWChar(var Dest: AnsiString; Source: PWideChar); +asm + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CX,[EDX+0] + JE @@4 + CMP CX,[EDX+2] + JE @@3 + CMP CX,[EDX+4] + JE @@2 + CMP CX,[EDX+6] + JE @@1 + ADD EDX,8 + JMP @@0 +@@1: ADD EDX,2 +@@2: ADD EDX,2 +@@3: ADD EDX,2 +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX + SHR ECX,1 +@@5: JMP _LStrFromPWCharLen +end; + + +procedure _LStrFromString(var Dest: AnsiString; const Source: ShortString); +asm + XOR ECX,ECX + MOV CL,[EDX] + INC EDX + JMP _LStrFromPCharLen +end; + + +procedure _LStrFromArray(var Dest: AnsiString; Source: PAnsiChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASB + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _LStrFromPCharLen +end; + + +procedure _LStrFromWArray(var Dest: AnsiString; Source: PWideChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASW + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _LStrFromPWCharLen +end; + + +procedure _LStrFromWStr(var Dest: AnsiString; const Source: WideString); +asm + { -> EAX pointer to dest } + { EDX pointer to WideString data } + + XOR ECX,ECX + TEST EDX,EDX + JE @@1 + MOV ECX,[EDX-4] + SHR ECX,1 +@@1: JMP _LStrFromPWCharLen +end; + + +procedure _LStrToString{(var Dest: ShortString; const Source: AnsiString; MaxLen: Integer)}; +asm + { -> EAX pointer to result } + { EDX AnsiString s } + { ECX length of result } + + PUSH EBX + TEST EDX,EDX + JE @@empty + MOV EBX,[EDX-skew].StrRec.length + TEST EBX,EBX + JE @@empty + + CMP ECX,EBX + JL @@truncate + MOV ECX,EBX +@@truncate: + MOV [EAX],CL + INC EAX + + XCHG EAX,EDX + CALL Move + + JMP @@exit + +@@empty: + MOV byte ptr [EAX],0 + +@@exit: + POP EBX +end; + + +function _LStrLen{str: AnsiString}: Longint; +asm + { -> EAX str } + + TEST EAX,EAX + JE @@done + MOV EAX,[EAX-skew].StrRec.length; +@@done: +end; + + +procedure _LStrCat{var dest: AnsiString; source: AnsiString}; +asm + { -> EAX pointer to dest } + { EDX source } + + TEST EDX,EDX + JE @@exit + + MOV ECX,[EAX] + TEST ECX,ECX + JE _LStrAsg + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,[ECX-skew].StrRec.length + + MOV EDX,[ESI-skew].StrRec.length + ADD EDX,EDI + CMP ESI,ECX + JE @@appendSelf + + CALL _LStrSetLength + MOV EAX,ESI + MOV ECX,[ESI-skew].StrRec.length + +@@appendStr: + MOV EDX,[EBX] + ADD EDX,EDI + CALL Move + POP EDI + POP ESI + POP EBX + RET + +@@appendSelf: + CALL _LStrSetLength + MOV EAX,[EBX] + MOV ECX,EDI + JMP @@appendStr + +@@exit: +end; + + +procedure _LStrCat3{var dest:AnsiString; source1: AnsiString; source2: AnsiString}; +asm + { ->EAX = Pointer to dest } + { EDX = source1 } + { ECX = source2 } + + TEST EDX,EDX + JE @@assignSource2 + + TEST ECX,ECX + JE _LStrAsg + + CMP EDX,[EAX] + JE @@appendToDest + + CMP ECX,[EAX] + JE @@theHardWay + + PUSH EAX + PUSH ECX + CALL _LStrAsg + + POP EDX + POP EAX + JMP _LStrCat + +@@theHardWay: + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EDX + MOV ESI,ECX + PUSH EAX + + MOV EAX,[EBX-skew].StrRec.length + ADD EAX,[ESI-skew].StrRec.length + CALL _NewAnsiString + + MOV EDI,EAX + MOV EDX,EAX + MOV EAX,EBX + MOV ECX,[EBX-skew].StrRec.length + CALL Move + + MOV EDX,EDI + MOV EAX,ESI + MOV ECX,[ESI-skew].StrRec.length + ADD EDX,[EBX-skew].StrRec.length + CALL Move + + POP EAX + MOV EDX,EDI + TEST EDI,EDI + JE @@skip + DEC [EDI-skew].StrRec.refCnt // EDI = local temp str +@@skip: + CALL _LStrAsg + + POP EDI + POP ESI + POP EBX + + JMP @@exit + +@@assignSource2: + MOV EDX,ECX + JMP _LStrAsg + +@@appendToDest: + MOV EDX,ECX + JMP _LStrCat + +@@exit: +end; + + +procedure _LStrCatN{var dest:AnsiString; argCnt: Integer; ...}; +asm + { ->EAX = Pointer to dest } + { EDX = number of args (>= 3) } + { [ESP+4], [ESP+8], ... crgCnt AnsiString arguments } + + PUSH EBX + PUSH ESI + PUSH EDX + PUSH EAX + MOV EBX,EDX + + XOR EAX,EAX +@@loop1: + MOV ECX,[ESP+EDX*4+4*4] + TEST ECX,ECX + JE @@1 + ADD EAX,[ECX-skew].StrRec.length +@@1: + DEC EDX + JNE @@loop1 + + CALL _NewAnsiString + PUSH EAX + MOV ESI,EAX + +@@loop2: + MOV EAX,[ESP+EBX*4+5*4] + MOV EDX,ESI + TEST EAX,EAX + JE @@2 + MOV ECX,[EAX-skew].StrRec.length + ADD ESI,ECX + CALL Move +@@2: + DEC EBX + JNE @@loop2 + + POP EDX + POP EAX + TEST EDX,EDX + JE @@skip + DEC [EDX-skew].StrRec.refCnt // EDX = local temp str +@@skip: + CALL _LStrAsg + + POP EDX + POP ESI + POP EBX + POP EAX + LEA ESP,[ESP+EDX*4] + JMP EAX +end; + + +procedure _LStrCmp{left: AnsiString; right: AnsiString}; +asm +{ ->EAX = Pointer to left string } +{ EDX = Pointer to right string } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + CMP EAX,EDX + JE @@exit + + TEST ESI,ESI + JE @@str1null + + TEST EDI,EDI + JE @@str2null + + MOV EAX,[ESI-skew].StrRec.length + MOV EDX,[EDI-skew].StrRec.length + + SUB EAX,EDX { eax = len1 - len2 } + JA @@skip1 + ADD EDX,EAX { edx = len2 + (len1 - len2) = len1 } + +@@skip1: + PUSH EDX + SHR EDX,2 + JE @@cmpRest +@@longLoop: + MOV ECX,[ESI] + MOV EBX,[EDI] + CMP ECX,EBX + JNE @@misMatch + DEC EDX + JE @@cmpRestP4 + MOV ECX,[ESI+4] + MOV EBX,[EDI+4] + CMP ECX,EBX + JNE @@misMatch + ADD ESI,8 + ADD EDI,8 + DEC EDX + JNE @@longLoop + JMP @@cmpRest +@@cmpRestP4: + ADD ESI,4 + ADD EDI,4 +@@cmpRest: + POP EDX + AND EDX,3 + JE @@equal + + MOV ECX,[ESI] + MOV EBX,[EDI] + CMP CL,BL + JNE @@exit + DEC EDX + JE @@equal + CMP CH,BH + JNE @@exit + DEC EDX + JE @@equal + AND EBX,$00FF0000 + AND ECX,$00FF0000 + CMP ECX,EBX + JNE @@exit + +@@equal: + ADD EAX,EAX + JMP @@exit + +@@str1null: + MOV EDX,[EDI-skew].StrRec.length + SUB EAX,EDX + JMP @@exit + +@@str2null: + MOV EAX,[ESI-skew].StrRec.length + SUB EAX,EDX + JMP @@exit + +@@misMatch: + POP EDX + CMP CL,BL + JNE @@exit + CMP CH,BH + JNE @@exit + SHR ECX,16 + SHR EBX,16 + CMP CL,BL + JNE @@exit + CMP CH,BH + +@@exit: + POP EDI + POP ESI + POP EBX + +end; + + +procedure _LStrAddRef{str: AnsiString}; +asm + { -> EAX str } + TEST EAX,EAX + JE @@exit + MOV EDX,[EAX-skew].StrRec.refCnt + INC EDX + JLE @@exit +{X LOCK} INC [EAX-skew].StrRec.refCnt +@@exit: +end; + + +procedure _LStrToPChar{str: AnsiString): PChar}; +asm + { -> EAX pointer to str } + { <- EAX pointer to PChar } + + TEST EAX,EAX + JE @@handle0 + RET +@@zeroByte: + DB 0 +@@handle0: + MOV EAX,offset @@zeroByte +end; + + +procedure UniqueString(var str: string); +asm + { -> EAX pointer to str } + { <- EAX pointer to unique copy } + MOV EDX,[EAX] + TEST EDX,EDX + JE @@exit + MOV ECX,[EDX-skew].StrRec.refCnt + DEC ECX + JE @@exit + + PUSH EBX + MOV EBX,EAX + MOV EAX,[EDX-skew].StrRec.length + CALL _NewAnsiString + MOV EDX,EAX + MOV EAX,[EBX] + MOV [EBX],EDX + MOV ECX,[EAX-skew].StrRec.refCnt + DEC ECX + JL @@skip +{X LOCK} DEC [EAX-skew].StrRec.refCnt +@@skip: + MOV ECX,[EAX-skew].StrRec.length + CALL Move + MOV EDX,[EBX] + POP EBX +@@exit: + MOV EAX,EDX +end; + + +procedure _LStrCopy{ const s : AnsiString; index, count : Integer) : AnsiString}; +asm + { ->EAX Source string } + { EDX index } + { ECX count } + { [ESP+4] Pointer to result string } + + PUSH EBX + + TEST EAX,EAX + JE @@srcEmpty + + MOV EBX,[EAX-skew].StrRec.length + TEST EBX,EBX + JE @@srcEmpty + +{ make index 0-based and limit to 0 <= index < Length(src) } + + DEC EDX + JL @@smallInx + CMP EDX,EBX + JGE @@bigInx + +@@cont1: + +{ limit count to satisfy 0 <= count <= Length(src) - index } + + SUB EBX,EDX { calculate Length(src) - index } + TEST ECX,ECX + JL @@smallCount + CMP ECX,EBX + JG @@bigCount + +@@cont2: + + ADD EDX,EAX + MOV EAX,[ESP+4+4] + CALL _LStrFromPCharLen + JMP @@exit + +@@smallInx: + XOR EDX,EDX + JMP @@cont1 +@@bigCount: + MOV ECX,EBX + JMP @@cont2 +@@bigInx: +@@smallCount: +@@srcEmpty: + MOV EAX,[ESP+4+4] + CALL _LStrClr +@@exit: + POP EBX + RET 4 +end; + + +procedure _LStrDelete{ var s : AnsiString; index, count : Integer }; +asm + { ->EAX Pointer to s } + { EDX index } + { ECX count } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + CALL UniqueString + + MOV EDX,[EBX] + TEST EDX,EDX { source already empty: nothing to do } + JE @@exit + + MOV ECX,[EDX-skew].StrRec.length + +{ make index 0-based, if not in [0 .. Length(s)-1] do nothing } + + DEC ESI + JL @@exit + CMP ESI,ECX + JGE @@exit + +{ limit count to [0 .. Length(s) - index] } + + TEST EDI,EDI + JLE @@exit + SUB ECX,ESI { ECX = Length(s) - index } + CMP EDI,ECX + JLE @@1 + MOV EDI,ECX +@@1: + +{ move length - index - count characters from s+index+count to s+index } + + SUB ECX,EDI { ECX = Length(s) - index - count } + ADD EDX,ESI { EDX = s+index } + LEA EAX,[EDX+EDI] { EAX = s+index+count } + CALL Move + +{ set length(s) to length(s) - count } + + MOV EDX,[EBX] + MOV EAX,EBX + MOV EDX,[EDX-skew].StrRec.length + SUB EDX,EDI + CALL _LStrSetLength + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +procedure _LStrInsert{ const source : AnsiString; var s : AnsiString; index : Integer }; +asm + { -> EAX source string } + { EDX pointer to destination string } + { ECX index } + + TEST EAX,EAX + JE @@nothingToDo + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + +{ make index 0-based and limit to 0 <= index <= Length(s) } + + MOV EDX,[EDX] + PUSH EDX + TEST EDX,EDX + JE @@sIsNull + MOV EDX,[EDX-skew].StrRec.length +@@sIsNull: + DEC EDI + JGE @@indexNotLow + XOR EDI,EDI +@@indexNotLow: + CMP EDI,EDX + JLE @@indexNotHigh + MOV EDI,EDX +@@indexNotHigh: + + MOV EBP,[EBX-skew].StrRec.length + +{ set length of result to length(source) + length(s) } + + MOV EAX,ESI + ADD EDX,EBP + CALL _LStrSetLength + POP EAX + + CMP EAX,EBX + JNE @@notInsertSelf + MOV EBX,[ESI] + +@@notInsertSelf: + +{ move length(s) - length(source) - index chars from s+index to s+index+length(source) } + + MOV EAX,[ESI] { EAX = s } + LEA EDX,[EDI+EBP] { EDX = index + length(source) } + MOV ECX,[EAX-skew].StrRec.length + SUB ECX,EDX { ECX = length(s) - length(source) - index } + ADD EDX,EAX { EDX = s + index + length(source) } + ADD EAX,EDI { EAX = s + index } + CALL Move + +{ copy length(source) chars from source to s+index } + + MOV EAX,EBX + MOV EDX,[ESI] + MOV ECX,EBP + ADD EDX,EDI + CALL Move + +@@exit: + POP EBP + POP EDI + POP ESI + POP EBX +@@nothingToDo: +end; + + +procedure _LStrPos{ const substr : AnsiString; const s : AnsiString ) : Integer}; +asm +{ ->EAX Pointer to substr } +{ EDX Pointer to string } +{ <-EAX Position of substr in s or 0 } + + TEST EAX,EAX + JE @@noWork + + TEST EDX,EDX + JE @@stringEmpty + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX { Point ESI to substr } + MOV EDI,EDX { Point EDI to s } + + MOV ECX,[EDI-skew].StrRec.length { ECX = Length(s) } + + PUSH EDI { remember s position to calculate index } + + MOV EDX,[ESI-skew].StrRec.length { EDX = Length(substr) } + + DEC EDX { EDX = Length(substr) - 1 } + JS @@fail { < 0 ? return 0 } + MOV AL,[ESI] { AL = first char of substr } + INC ESI { Point ESI to 2'nd char of substr } + + SUB ECX,EDX { #positions in s to look at } + { = Length(s) - Length(substr) + 1 } + JLE @@fail +@@loop: + REPNE SCASB + JNE @@fail + MOV EBX,ECX { save outer loop counter } + PUSH ESI { save outer loop substr pointer } + PUSH EDI { save outer loop s pointer } + + MOV ECX,EDX + REPE CMPSB + POP EDI { restore outer loop s pointer } + POP ESI { restore outer loop substr pointer } + JE @@found + MOV ECX,EBX { restore outer loop counter } + JMP @@loop + +@@fail: + POP EDX { get rid of saved s pointer } + XOR EAX,EAX + JMP @@exit + +@@stringEmpty: + XOR EAX,EAX + JMP @@noWork + +@@found: + POP EDX { restore pointer to first char of s } + MOV EAX,EDI { EDI points of char after match } + SUB EAX,EDX { the difference is the correct index } +@@exit: + POP EDI + POP ESI + POP EBX +@@noWork: +end; + + +procedure _LStrSetLength{ var str: AnsiString; newLength: Integer}; +asm + { -> EAX Pointer to str } + { EDX new length } + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV ESI,EDX + XOR EDI,EDI + + TEST EDX,EDX + JE @@setString + + MOV EAX,[EBX] + TEST EAX,EAX + JE @@copyString + + CMP [EAX-skew].StrRec.refCnt,1 + JNE @@copyString + + SUB EAX,rOff + ADD EDX,rOff+1 + PUSH EAX + MOV EAX,ESP + CALL _ReallocMem + POP EAX + ADD EAX,rOff + MOV [EBX],EAX + MOV [EAX-skew].StrRec.length,ESI + MOV BYTE PTR [EAX+ESI],0 + JMP @@exit + +@@copyString: + MOV EAX,EDX + CALL _NewAnsiString + MOV EDI,EAX + + MOV EAX,[EBX] + TEST EAX,EAX + JE @@setString + + MOV EDX,EDI + MOV ECX,[EAX-skew].StrRec.length + CMP ECX,ESI + JL @@moveString + MOV ECX,ESI + +@@moveString: + CALL Move + +@@setString: + MOV EAX,EBX + CALL _LStrClr + MOV [EBX],EDI + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +procedure _LStrOfChar{ c: Char; count: Integer): AnsiString }; +asm + { -> AL c } + { EDX count } + { ECX result } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + MOV EAX,ECX + CALL _LStrClr + + TEST ESI,ESI + JLE @@exit + + MOV EAX,ESI + CALL _NewAnsiString + + MOV [EDI],EAX + + MOV EDX,ESI + MOV CL,BL + + CALL _FillChar + +@@exit: + POP EDI + POP ESI + POP EBX + +end; + + +procedure _Write0LString{ VAR t: Text; s: AnsiString }; +asm + { -> EAX Pointer to text record } + { EDX Pointer to AnsiString } + + XOR ECX,ECX + JMP _WriteLString +end; + + +procedure _WriteLString{ VAR t: Text; s: AnsiString; width: Longint }; +asm + { -> EAX Pointer to text record } + { EDX Pointer to AnsiString } + { ECX Field width } + + PUSH EBX + + MOV EBX,EDX + + MOV EDX,ECX + XOR ECX,ECX + TEST EBX,EBX + JE @@skip + MOV ECX,[EBX-skew].StrRec.length + SUB EDX,ECX +@@skip: + PUSH ECX + CALL _WriteSpaces + POP ECX + + MOV EDX,EBX + POP EBX + JMP _WriteBytes +end; + + +procedure _ReadLString{var t: Text; var str: AnsiString}; +asm + { -> EAX pointer to Text } + { EDX pointer to AnsiString } + + PUSH EBX + PUSH ESI + MOV EBX,EAX + MOV ESI,EDX + + MOV EAX,EDX + CALL _LStrClr + + SUB ESP,256 + + MOV EAX,EBX + MOV EDX,ESP + MOV ECX,255 + CALL _ReadString + + MOV EAX,ESI + MOV EDX,ESP + CALL _LStrFromString + + CMP byte ptr [ESP],255 + JNE @@exit +@@loop: + + MOV EAX,EBX + MOV EDX,ESP + MOV ECX,255 + CALL _ReadString + + MOV EDX,ESP + PUSH 0 + MOV EAX,ESP + CALL _LStrFromString + + MOV EAX,ESI + MOV EDX,[ESP] + CALL _LStrCat + + MOV EAX,ESP + CALL _LStrClr + POP EAX + + CMP byte ptr [ESP],255 + JE @@loop + +@@exit: + ADD ESP,256 + POP ESI + POP EBX +end; + + +procedure WStrError; +asm + MOV AL,reOutOfMemory + JMP Error +end; + + +procedure WStrSet(var S: WideString; P: PWideChar); +asm + MOV ECX,[EAX] + MOV [EAX],EDX + TEST ECX,ECX + JE @@1 + PUSH ECX + CALL SysFreeString +@@1: +end; + + +procedure WStrClr; +asm + JMP _WStrClr +end; + +procedure _WStrClr(var S: WideString); +asm + { -> EAX Pointer to WideString } + + MOV EDX,[EAX] + TEST EDX,EDX + JE @@1 + MOV DWORD PTR [EAX],0 + PUSH EAX + PUSH EDX + CALL SysFreeString + POP EAX +@@1: +end; + + +procedure WStrArrayClr; +asm + JMP _WStrArrayClr; +end; + +procedure _WStrArrayClr(var StrArray; Count: Integer); +asm + PUSH EBX + PUSH ESI + MOV EBX,EAX + MOV ESI,EDX +@@1: MOV EAX,[EBX] + TEST EAX,EAX + JE @@2 + MOV DWORD PTR [EBX],0 + PUSH EAX + CALL SysFreeString +@@2: ADD EBX,4 + DEC ESI + JNE @@1 + POP ESI + POP EBX +end; + + +procedure _WStrAsg(var Dest: WideString; const Source: WideString); +asm + { -> EAX Pointer to WideString } + { EDX Pointer to data } + TEST EDX,EDX + JE _WStrClr + MOV ECX,[EDX-4] + SHR ECX,1 + JE _WStrClr + PUSH ECX + PUSH EDX + PUSH EAX + CALL SysReAllocStringLen + TEST EAX,EAX + JE WStrError +end; + + +procedure _WStrFromPCharLen(var Dest: WideString; Source: PAnsiChar; Length: Integer); +var + DestLen: Integer; + Buffer: array[0..1023] of WideChar; +begin + if Length <= 0 then + begin + _WStrClr(Dest); + Exit; + end; + if Length < SizeOf(Buffer) div 2 then + begin + DestLen := MultiByteToWideChar(0, 0, Source, Length, + Buffer, SizeOf(Buffer) div 2); + if DestLen > 0 then + begin + _WStrFromPWCharLen(Dest, Buffer, DestLen); + Exit; + end; + end; + DestLen := MultiByteToWideChar(0, 0, Source, Length, nil, 0); + _WStrFromPWCharLen(Dest, nil, DestLen); + MultiByteToWideChar(0, 0, Source, Length, Pointer(Dest), DestLen); +end; + + +procedure _WStrFromPWCharLen(var Dest: WideString; Source: PWideChar; Length: Integer); +asm + { -> EAX Pointer to WideString (dest) } + { EDX Pointer to characters (source) } + { ECX number of characters (not bytes) } + TEST ECX,ECX + JE _WStrClr + + PUSH EAX + + PUSH ECX + PUSH EDX + CALL SysAllocStringLen + TEST EAX,EAX + JE WStrError + + POP EDX + PUSH [EDX].PWideChar + MOV [EDX],EAX + + CALL SysFreeString +end; + + +procedure _WStrFromChar(var Dest: WideString; Source: AnsiChar); +asm + PUSH EDX + MOV EDX,ESP + MOV ECX,1 + CALL _WStrFromPCharLen + POP EDX +end; + + +procedure _WStrFromWChar(var Dest: WideString; Source: WideChar); +asm + { -> EAX Pointer to WideString (dest) } + { EDX character (source) } + PUSH EDX + MOV EDX,ESP + MOV ECX,1 + CALL _WStrFromPWCharLen + POP EDX +end; + + +procedure _WStrFromPChar(var Dest: WideString; Source: PAnsiChar); +asm + { -> EAX Pointer to WideString (dest) } + { EDX Pointer to character (source) } + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CL,[EDX+0] + JE @@4 + CMP CL,[EDX+1] + JE @@3 + CMP CL,[EDX+2] + JE @@2 + CMP CL,[EDX+3] + JE @@1 + ADD EDX,4 + JMP @@0 +@@1: INC EDX +@@2: INC EDX +@@3: INC EDX +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX +@@5: JMP _WStrFromPCharLen +end; + + +procedure _WStrFromPWChar(var Dest: WideString; Source: PWideChar); +asm + { -> EAX Pointer to WideString (dest) } + { EDX Pointer to character (source) } + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CX,[EDX+0] + JE @@4 + CMP CX,[EDX+2] + JE @@3 + CMP CX,[EDX+4] + JE @@2 + CMP CX,[EDX+6] + JE @@1 + ADD EDX,8 + JMP @@0 +@@1: ADD EDX,2 +@@2: ADD EDX,2 +@@3: ADD EDX,2 +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX + SHR ECX,1 +@@5: JMP _WStrFromPWCharLen +end; + + +procedure _WStrFromString(var Dest: WideString; const Source: ShortString); +asm + XOR ECX,ECX + MOV CL,[EDX] + INC EDX + JMP _WStrFromPCharLen +end; + + +procedure _WStrFromArray(var Dest: WideString; Source: PAnsiChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASB + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _WStrFromPCharLen +end; + + +procedure _WStrFromWArray(var Dest: WideString; Source: PWideChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASW + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _WStrFromPWCharLen +end; + + +procedure _WStrFromLStr(var Dest: WideString; const Source: AnsiString); +asm + XOR ECX,ECX + TEST EDX,EDX + JE @@1 + MOV ECX,[EDX-4] +@@1: JMP _WStrFromPCharLen +end; + + +procedure _WStrToString(Dest: PShortString; const Source: WideString; MaxLen: Integer); +var + SourceLen, DestLen: Integer; + Buffer: array[0..511] of Char; +begin + SourceLen := Length(Source); + if SourceLen >= 255 then SourceLen := 255; + if SourceLen = 0 then DestLen := 0 else + begin + DestLen := WideCharToMultiByte(0, 0, Pointer(Source), SourceLen, + Buffer, SizeOf(Buffer), nil, nil); + if DestLen > MaxLen then DestLen := MaxLen; + end; + Dest^[0] := Chr(DestLen); + if DestLen > 0 then Move(Buffer, Dest^[1], DestLen); +end; + + +function _WStrToPWChar(const S: WideString): PWideChar; +asm + TEST EAX,EAX + JE @@1 + RET + NOP +@@0: DW 0 +@@1: MOV EAX,OFFSET @@0 +end; + + +function _WStrLen(const S: WideString): Integer; +asm + { -> EAX Pointer to WideString data } + TEST EAX,EAX + JE @@1 + MOV EAX,[EAX-4] + SHR EAX,1 +@@1: +end; + + +procedure _WStrCat(var Dest: WideString; const Source: WideString); +var + DestLen, SourceLen: Integer; + NewStr: PWideChar; +begin + SourceLen := Length(Source); + if SourceLen <> 0 then + begin + DestLen := Length(Dest); + NewStr := _NewWideString(DestLen + SourceLen); + if DestLen > 0 then + Move(Pointer(Dest)^, NewStr^, DestLen * 2); + Move(Pointer(Source)^, NewStr[DestLen], SourceLen * 2); + WStrSet(Dest, NewStr); + end; +end; + + +procedure _WStrCat3(var Dest: WideString; const Source1, Source2: WideString); +var + Source1Len, Source2Len: Integer; + NewStr: PWideChar; +begin + Source1Len := Length(Source1); + Source2Len := Length(Source2); + if (Source1Len <> 0) or (Source2Len <> 0) then + begin + NewStr := _NewWideString(Source1Len + Source2Len); + Move(Pointer(Source1)^, Pointer(NewStr)^, Source1Len * 2); + Move(Pointer(Source2)^, NewStr[Source1Len], Source2Len * 2); + WStrSet(Dest, NewStr); + end; +end; + + +procedure _WStrCatN{var Dest: WideString; ArgCnt: Integer; ...}; +asm + { ->EAX = Pointer to dest } + { EDX = number of args (>= 3) } + { [ESP+4], [ESP+8], ... crgCnt WideString arguments } + + PUSH EBX + PUSH ESI + PUSH EDX + PUSH EAX + MOV EBX,EDX + + XOR EAX,EAX +@@loop1: + MOV ECX,[ESP+EDX*4+4*4] + TEST ECX,ECX + JE @@1 + ADD EAX,[ECX-4] +@@1: + DEC EDX + JNE @@loop1 + + SHR EAX,1 + CALL _NewWideString + PUSH EAX + MOV ESI,EAX + +@@loop2: + MOV EAX,[ESP+EBX*4+5*4] + MOV EDX,ESI + TEST EAX,EAX + JE @@2 + MOV ECX,[EAX-4] + ADD ESI,ECX + CALL Move +@@2: + DEC EBX + JNE @@loop2 + + POP EDX + POP EAX + CALL WStrSet + + POP EDX + POP ESI + POP EBX + POP EAX + LEA ESP,[ESP+EDX*4] + JMP EAX +end; + + +procedure _WStrCmp{left: WideString; right: WideString}; +asm +{ ->EAX = Pointer to left string } +{ EDX = Pointer to right string } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + CMP EAX,EDX + JE @@exit + + TEST ESI,ESI + JE @@str1null + + TEST EDI,EDI + JE @@str2null + + MOV EAX,[ESI-4] + MOV EDX,[EDI-4] + + SUB EAX,EDX { eax = len1 - len2 } + JA @@skip1 + ADD EDX,EAX { edx = len2 + (len1 - len2) = len1 } + +@@skip1: + PUSH EDX + SHR EDX,2 + JE @@cmpRest +@@longLoop: + MOV ECX,[ESI] + MOV EBX,[EDI] + CMP ECX,EBX + JNE @@misMatch + DEC EDX + JE @@cmpRestP4 + MOV ECX,[ESI+4] + MOV EBX,[EDI+4] + CMP ECX,EBX + JNE @@misMatch + ADD ESI,8 + ADD EDI,8 + DEC EDX + JNE @@longLoop + JMP @@cmpRest +@@cmpRestP4: + ADD ESI,4 + ADD EDI,4 +@@cmpRest: + POP EDX + AND EDX,2 + JE @@equal + + MOV CX,[ESI] + MOV BX,[EDI] + CMP CX,BX + JNE @@exit + +@@equal: + ADD EAX,EAX + JMP @@exit + +@@str1null: + MOV EDX,[EDI-4] + SUB EAX,EDX + JMP @@exit + +@@str2null: + MOV EAX,[ESI-4] + SUB EAX,EDX + JMP @@exit + +@@misMatch: + POP EDX + CMP CX,BX + JNE @@exit + SHR ECX,16 + SHR EBX,16 + CMP CX,BX + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +function _NewWideString(Length: Integer): PWideChar; +asm + TEST EAX,EAX + JE @@1 + PUSH EAX + PUSH 0 + CALL SysAllocStringLen + TEST EAX,EAX + JE WStrError +@@1: +end; + + +function _WStrCopy(const S: WideString; Index, Count: Integer): WideString; +var + L, N: Integer; +begin + L := Length(S); + if Index < 1 then Index := 0 else + begin + Dec(Index); + if Index > L then Index := L; + end; + if Count < 0 then N := 0 else + begin + N := L - Index; + if N > Count then N := Count; + end; + _WStrFromPWCharLen(Result, PWideChar(Pointer(S)) + Index, N); +end; + + +procedure _WStrDelete(var S: WideString; Index, Count: Integer); +var + L, N: Integer; + NewStr: PWideChar; +begin + L := Length(S); + if (L > 0) and (Index >= 1) and (Index <= L) and (Count > 0) then + begin + Dec(Index); + N := L - Index - Count; + if N < 0 then N := 0; + if (Index = 0) and (N = 0) then NewStr := nil else + begin + NewStr := _NewWideString(Index + N); + if Index > 0 then + Move(Pointer(S)^, NewStr^, Index * 2); + if N > 0 then + Move(PWideChar(Pointer(S))[L - N], NewStr[Index], N * 2); + end; + WStrSet(S, NewStr); + end; +end; + + +procedure _WStrInsert(const Source: WideString; var Dest: WideString; Index: Integer); +var + SourceLen, DestLen: Integer; + NewStr: PWideChar; +begin + SourceLen := Length(Source); + if SourceLen > 0 then + begin + DestLen := Length(Dest); + if Index < 1 then Index := 0 else + begin + Dec(Index); + if Index > DestLen then Index := DestLen; + end; + NewStr := _NewWideString(DestLen + SourceLen); + if Index > 0 then + Move(Pointer(Dest)^, NewStr^, Index * 2); + Move(Pointer(Source)^, NewStr[Index], SourceLen * 2); + if Index < DestLen then + Move(PWideChar(Pointer(Dest))[Index], NewStr[Index + SourceLen], + (DestLen - Index) * 2); + WStrSet(Dest, NewStr); + end; +end; + + +procedure _WStrPos{ const substr : WideString; const s : WideString ) : Integer}; +asm +{ ->EAX Pointer to substr } +{ EDX Pointer to string } +{ <-EAX Position of substr in s or 0 } + + TEST EAX,EAX + JE @@noWork + + TEST EDX,EDX + JE @@stringEmpty + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX { Point ESI to substr } + MOV EDI,EDX { Point EDI to s } + + MOV ECX,[EDI-4] { ECX = Length(s) } + SHR ECX,1 + + PUSH EDI { remember s position to calculate index } + + MOV EDX,[ESI-4] { EDX = Length(substr) } + SHR EDX,1 + + DEC EDX { EDX = Length(substr) - 1 } + JS @@fail { < 0 ? return 0 } + MOV AX,[ESI] { AL = first char of substr } + ADD ESI,2 { Point ESI to 2'nd char of substr } + + SUB ECX,EDX { #positions in s to look at } + { = Length(s) - Length(substr) + 1 } + JLE @@fail +@@loop: + REPNE SCASW + JNE @@fail + MOV EBX,ECX { save outer loop counter } + PUSH ESI { save outer loop substr pointer } + PUSH EDI { save outer loop s pointer } + + MOV ECX,EDX + REPE CMPSW + POP EDI { restore outer loop s pointer } + POP ESI { restore outer loop substr pointer } + JE @@found + MOV ECX,EBX { restore outer loop counter } + JMP @@loop + +@@fail: + POP EDX { get rid of saved s pointer } + XOR EAX,EAX + JMP @@exit + +@@stringEmpty: + XOR EAX,EAX + JMP @@noWork + +@@found: + POP EDX { restore pointer to first char of s } + MOV EAX,EDI { EDI points of char after match } + SUB EAX,EDX { the difference is the correct index } + SHR EAX,1 +@@exit: + POP EDI + POP ESI + POP EBX +@@noWork: +end; + + +procedure _WStrSetLength(var S: WideString; NewLength: Integer); +var + NewStr: PWideChar; + Count: Integer; +begin + NewStr := nil; + if NewLength > 0 then + begin + NewStr := _NewWideString(NewLength); + Count := Length(S); + if Count > 0 then + begin + if Count > NewLength then Count := NewLength; + Move(Pointer(S)^, NewStr^, Count * 2); + end; + end; + WStrSet(S, NewStr); +end; + + +function _WStrOfWChar(Ch: WideChar; Count: Integer): WideString; +var + P: PWideChar; +begin + _WStrFromPWCharLen(Result, nil, Count); + P := Pointer(Result); + while Count > 0 do + begin + Dec(Count); + P[Count] := Ch; + end; +end; + +procedure WStrAddRef; +asm + JMP _WStrAddRef +end; + +procedure _WStrAddRef{var str: WideString}; +asm + MOV EDX,[EAX] + TEST EDX,EDX + JE @@1 + PUSH EAX + MOV ECX,[EDX-4] + SHR ECX,1 + PUSH ECX + PUSH EDX + CALL SysAllocStringLen + POP EDX + TEST EAX,EAX + JE WStrError + MOV [EDX],EAX +@@1: +end; + + +procedure _InitializeRecord{ p: Pointer; typeInfo: Pointer }; +asm + { -> EAX pointer to record to be initialized } + { EDX pointer to type info } + + XOR ECX,ECX + + PUSH EBX + MOV CL,[EDX+1] { type name length } + + PUSH ESI + PUSH EDI + + MOV EBX,EAX + LEA ESI,[EDX+ECX+2+8] { address of destructable fields } + MOV EDI,[EDX+ECX+2+4] { number of destructable fields } + +@@loop: + + MOV EDX,[ESI] + MOV EAX,[ESI+4] + ADD EAX,EBX + MOV EDX,[EDX] + CALL _Initialize + ADD ESI,8 + DEC EDI + JG @@loop + + POP EDI + POP ESI + POP EBX +end; + + +const + tkLString = 10; + tkWString = 11; + tkVariant = 12; + tkArray = 13; + tkRecord = 14; + tkInterface = 15; + tkDynArray = 17; + +procedure _InitializeArray{ p: Pointer; typeInfo: Pointer; elemCount: Longint}; +asm + { -> EAX pointer to data to be initialized } + { EDX pointer to type info describing data } + { ECX number of elements of that type } + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + XOR EDX,EDX + MOV AL,[ESI] + MOV DL,[ESI+1] + XOR ECX,ECX + + CMP AL,tkLString + JE @@LString + CMP AL,tkWString + JE @@WString + CMP AL,tkVariant + JE @@Variant + CMP AL,tkArray + JE @@Array + CMP AL,tkRecord + JE @@Record + CMP AL,tkInterface + JE @@Interface + CMP AL,tkDynArray + JE @@DynArray + MOV AL,reInvalidPtr + POP EDI + POP ESI + POP EBX + JMP Error + +@@LString: +@@WString: +@@Interface: +@@DynArray: + MOV [EBX],ECX + ADD EBX,4 + DEC EDI + JG @@LString + JMP @@exit + +@@Variant: + MOV [EBX ],ECX + MOV [EBX+ 4],ECX + MOV [EBX+ 8],ECX + MOV [EBX+12],ECX + ADD EBX,16 + DEC EDI + JG @@Variant + JMP @@exit + +@@Array: + PUSH EBP + MOV EBP,EDX +@@ArrayLoop: + MOV EDX,[ESI+EBP+2+8] + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV ECX,[ESI+EBP+2+4] + MOV EDX,[EDX] + CALL _InitializeArray + DEC EDI + JG @@ArrayLoop + POP EBP + JMP @@exit + +@@Record: + PUSH EBP + MOV EBP,EDX +@@RecordLoop: + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV EDX,ESI + CALL _InitializeRecord + DEC EDI + JG @@RecordLoop + POP EBP + +@@exit: + + POP EDI + POP ESI + POP EBX +end; + + +procedure _Initialize{ p: Pointer; typeInfo: Pointer}; +asm + MOV ECX,1 + JMP _InitializeArray +end; + +procedure _FinalizeRecord{ p: Pointer; typeInfo: Pointer }; +asm + { -> EAX pointer to record to be finalized } + { EDX pointer to type info } + + XOR ECX,ECX + + PUSH EBX + MOV CL,[EDX+1] + + PUSH ESI + PUSH EDI + + MOV EBX,EAX + LEA ESI,[EDX+ECX+2+8] + MOV EDI,[EDX+ECX+2+4] + +@@loop: + + MOV EDX,[ESI] + MOV EAX,[ESI+4] + ADD EAX,EBX + MOV EDX,[EDX] + CALL _Finalize + ADD ESI,8 + DEC EDI + JG @@loop + + MOV EAX,EBX + + POP EDI + POP ESI + POP EBX +end; + + +procedure _FinalizeArray{ p: Pointer; typeInfo: Pointer; elemCount: Longint}; +asm + { -> EAX pointer to data to be finalized } + { EDX pointer to type info describing data } + { ECX number of elements of that type } + + CMP ECX, 0 { no array -> nop } + JE @@zerolength + + PUSH EAX + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + XOR EDX,EDX + MOV AL,[ESI] + MOV DL,[ESI+1] + + CMP AL,tkLString + JE @@LString + + CMP AL,tkWString + JE @@WString + + CMP AL,tkVariant + JE @@Variant + + CMP AL,tkArray + JE @@Array + + CMP AL,tkRecord + JE @@Record + + CMP AL,tkInterface + JE @@Interface + + CMP AL,tkDynArray + JE @@DynArray + POP EDI + POP ESI + POP EBX + POP EAX + MOV AL,reInvalidPtr + JMP Error + +@@LString: + CMP ECX,1 + MOV EAX,EBX + JG @@LStringArray + CALL _LStrClr + JMP @@exit +@@LStringArray: + MOV EDX,ECX + CALL _LStrArrayClr + JMP @@exit + +@@WString: + CMP ECX,1 + MOV EAX,EBX + JG @@WStringArray + //CALL _WStrClr + CALL [WStrClrProc] + JMP @@exit +@@WStringArray: + MOV EDX,ECX + //CALL _WStrArrayClr + CALL [WStrArrayClrProc] + JMP @@exit + +@@Variant: + MOV EAX,EBX + ADD EBX,16 + //CALL _VarClr + CALL [VarClrProc] + DEC EDI + JG @@Variant + JMP @@exit + +@@Array: + PUSH EBP + MOV EBP,EDX +@@ArrayLoop: + MOV EDX,[ESI+EBP+2+8] + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV ECX,[ESI+EBP+2+4] + MOV EDX,[EDX] + CALL _FinalizeArray + DEC EDI + JG @@ArrayLoop + POP EBP + JMP @@exit + +@@Record: + PUSH EBP + MOV EBP,EDX +@@RecordLoop: + { inv: EDI = number of array elements to finalize } + + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV EDX,ESI + CALL _FinalizeRecord + DEC EDI + JG @@RecordLoop + POP EBP + JMP @@exit + +@@Interface: + MOV EAX,EBX + ADD EBX,4 + CALL _IntfClear + DEC EDI + JG @@Interface + JMP @@exit + +@@DynArray: + MOV EAX,EBX + MOV EDX,ESI + ADD EBX,4 + CALL _DynArrayClear + DEC EDI + JG @@DynArray + +@@exit: + + POP EDI + POP ESI + POP EBX + POP EAX +@@zerolength: +end; + + +procedure _Finalize{ p: Pointer; typeInfo: Pointer}; +asm + MOV ECX,1 + JMP _FinalizeArray +end; + +procedure _AddRefRecord{ p: Pointer; typeInfo: Pointer }; +asm + { -> EAX pointer to record to be referenced } + { EDX pointer to type info } + + XOR ECX,ECX + + PUSH EBX + MOV CL,[EDX+1] + + PUSH ESI + PUSH EDI + + MOV EBX,EAX + LEA ESI,[EDX+ECX+2+8] + MOV EDI,[EDX+ECX+2+4] + +@@loop: + + MOV EDX,[ESI] + MOV EAX,[ESI+4] + ADD EAX,EBX + MOV EDX,[EDX] + CALL _AddRef + ADD ESI,8 + DEC EDI + JG @@loop + + POP EDI + POP ESI + POP EBX +end; + +procedure DummyProc; +begin +end; + +procedure _AddRefArray{ p: Pointer; typeInfo: Pointer; elemCount: Longint}; +asm + { -> EAX pointer to data to be referenced } + { EDX pointer to type info describing data } + { ECX number of elements of that type } + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + XOR EDX,EDX + MOV AL,[ESI] + MOV DL,[ESI+1] + + CMP AL,tkLString + JE @@LString + CMP AL,tkWString + JE @@WString + CMP AL,tkVariant + JE @@Variant + CMP AL,tkArray + JE @@Array + CMP AL,tkRecord + JE @@Record + CMP AL,tkInterface + JE @@Interface + CMP AL,tkDynArray + JE @@DynArray + MOV AL,reInvalidPtr + POP EDI + POP ESI + POP EBX + JMP Error + +@@LString: + MOV EAX,[EBX] + ADD EBX,4 + CALL _LStrAddRef + DEC EDI + JG @@LString + JMP @@exit + +@@WString: + MOV EAX,EBX + ADD EBX,4 + //CALL _WStrAddRef + CALL [WStrAddRefProc] + DEC EDI + JG @@WString + JMP @@exit + +@@Variant: + MOV EAX,EBX + ADD EBX,16 + //CALL _VarAddRef + CALL [VarAddRefProc] + DEC EDI + JG @@Variant + JMP @@exit + +@@Array: + PUSH EBP + MOV EBP,EDX +@@ArrayLoop: + MOV EDX,[ESI+EBP+2+8] + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV ECX,[ESI+EBP+2+4] + MOV EDX,[EDX] + CALL _AddRefArray + DEC EDI + JG @@ArrayLoop + POP EBP + JMP @@exit + +@@Record: + PUSH EBP + MOV EBP,EDX +@@RecordLoop: + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV EDX,ESI + CALL _AddRefRecord + DEC EDI + JG @@RecordLoop + POP EBP + JMP @@exit + +@@Interface: + MOV EAX,[EBX] + ADD EBX,4 + CALL _IntfAddRef + DEC EDI + JG @@Interface + JMP @@exit + +@@DynArray: + MOV EAX,[EBX] + ADD EBX,4 + CALL _DynArrayAddRef + DEC EDI + JG @@DynArray +@@exit: + + POP EDI + POP ESI + POP EBX +end; + + +procedure _AddRef{ p: Pointer; typeInfo: Pointer}; +asm + MOV ECX,1 + JMP _AddRefArray +end; + + +procedure _CopyRecord{ dest, source, typeInfo: Pointer }; +asm + { -> EAX pointer to dest } + { EDX pointer to source } + { ECX pointer to typeInfo } + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBX,EAX + MOV ESI,EDX + + XOR EAX,EAX + MOV AL,[ECX+1] + + LEA EDI,[ECX+EAX+2+8] + MOV EBP,[EDI-4] + XOR EAX,EAX + MOV ECX,[EDI-8] + PUSH ECX +@@loop: + MOV ECX,[EDI+4] + SUB ECX,EAX + JLE @@nomove1 + MOV EDX,EAX + ADD EAX,ESI + ADD EDX,EBX + CALL Move +@@noMove1: + MOV EAX,[EDI+4] + + MOV EDX,[EDI] + MOV EDX,[EDX] + MOV CL,[EDX] + + CMP CL,tkLString + JE @@LString + CMP CL,tkWString + JE @@WString + CMP CL,tkVariant + JE @@Variant + CMP CL,tkArray + JE @@Array + CMP CL,tkRecord + JE @@Record + CMP CL,tkInterface + JE @@Interface + CMP CL,tkDynArray + JE @@DynArray + MOV AL,reInvalidPtr + POP EBP + POP EDI + POP ESI + POP EBX + JMP Error + +@@LString: + MOV EDX,[ESI+EAX] + ADD EAX,EBX + CALL _LStrAsg + MOV EAX,4 + JMP @@common + +@@WString: + MOV EDX,[ESI+EAX] + ADD EAX,EBX + CALL _WStrAsg + MOV EAX,4 + JMP @@common + +@@Variant: + LEA EDX,[ESI+EAX] + ADD EAX,EBX + CALL _VarCopy + MOV EAX,16 + JMP @@common + +@@Array: + XOR ECX,ECX + MOV CL,[EDX+1] + PUSH dword ptr [EDX+ECX+2] + PUSH dword ptr [EDX+ECX+2+4] + MOV ECX,[EDX+ECX+2+8] + MOV ECX,[ECX] + LEA EDX,[ESI+EAX] + ADD EAX,EBX + CALL _CopyArray + POP EAX + JMP @@common + +@@Record: + XOR ECX,ECX + MOV CL,[EDX+1] + MOV ECX,[EDX+ECX+2] + PUSH ECX + MOV ECX,EDX + LEA EDX,[ESI+EAX] + ADD EAX,EBX + CALL _CopyRecord + POP EAX + JMP @@common + +@@Interface: + MOV EDX,[ESI+EAX] + ADD EAX,EBX + CALL _IntfCopy + MOV EAX,4 + JMP @@common + +@@DynArray: + MOV ECX,EDX + MOV EDX,[ESI+EAX] + ADD EAX,EBX + CALL _DynArrayAsg + MOV EAX,4 + +@@common: + ADD EAX,[EDI+4] + ADD EDI,8 + DEC EBP + JNZ @@loop + + POP ECX + SUB ECX,EAX + JLE @@noMove2 + LEA EDX,[EBX+EAX] + ADD EAX,ESI + CALL Move +@@noMove2: + + POP EBP + POP EDI + POP ESI + POP EBX +end; + + +procedure _CopyObject{ dest, source: Pointer; vmtPtrOffs: Longint; typeInfo: Pointer }; +asm + { -> EAX pointer to dest } + { EDX pointer to source } + { ECX offset of vmt in object } + { [ESP+4] pointer to typeInfo } + + ADD ECX,EAX { pointer to dest vmt } + PUSH dword ptr [ECX] { save dest vmt } + PUSH ECX + MOV ECX,[ESP+4+4+4] + CALL _CopyRecord + POP ECX + POP dword ptr [ECX] { restore dest vmt } + RET 4 + +end; + +procedure _CopyArray{ dest, source, typeInfo: Pointer; cnt: Integer }; +asm + { -> EAX pointer to dest } + { EDX pointer to source } + { ECX pointer to typeInfo } + { [ESP+4] count } + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + MOV EBP,[ESP+4+4*4] + + MOV CL,[EDI] + + CMP CL,tkLString + JE @@LString + CMP CL,tkWString + JE @@WString + CMP CL,tkVariant + JE @@Variant + CMP CL,tkArray + JE @@Array + CMP CL,tkRecord + JE @@Record + CMP CL,tkInterface + JE @@Interface + CMP CL,tkDynArray + JE @@DynArray + MOV AL,reInvalidPtr + POP EBP + POP EDI + POP ESI + POP EBX + JMP Error + +@@LString: + MOV EAX,EBX + MOV EDX,[ESI] + CALL _LStrAsg + ADD EBX,4 + ADD ESI,4 + DEC EBP + JNE @@LString + JMP @@exit + +@@WString: + MOV EAX,EBX + MOV EDX,[ESI] + CALL _WStrAsg + ADD EBX,4 + ADD ESI,4 + DEC EBP + JNE @@WString + JMP @@exit + +@@Variant: + MOV EAX,EBX + MOV EDX,ESI + CALL _VarCopy + ADD EBX,16 + ADD ESI,16 + DEC EBP + JNE @@Variant + JMP @@exit + +@@Array: + XOR ECX,ECX + MOV CL,[EDI+1] + LEA EDI,[EDI+ECX+2] +@@ArrayLoop: + MOV EAX,EBX + MOV EDX,ESI + MOV ECX,[EDI+8] + PUSH dword ptr [EDI+4] + CALL _CopyArray + ADD EBX,[EDI] + ADD ESI,[EDI] + DEC EBP + JNE @@ArrayLoop + JMP @@exit + +@@Record: + MOV EAX,EBX + MOV EDX,ESI + MOV ECX,EDI + CALL _CopyRecord + XOR EAX,EAX + MOV AL,[EDI+1] + ADD EBX,[EDI+EAX+2] + ADD ESI,[EDI+EAX+2] + DEC EBP + JNE @@Record + JMP @@exit + +@@Interface: + MOV EAX,EBX + MOV EDX,[ESI] + CALL _IntfCopy + ADD EBX,4 + ADD ESI,4 + DEC EBP + JNE @@Interface + JMP @@exit + +@@DynArray: + MOV EAX,EBX + MOV EDX,[ESI] + MOV ECX,EDI + CALL _DynArrayAsg + ADD EBX,4 + ADD ESI,4 + DEC EBP + JNE @@DynArray + +@@exit: + POP EBP + POP EDI + POP ESI + POP EBX + RET 4 +end; + + +procedure _New{ size: Longint; typeInfo: Pointer}; +asm + { -> EAX size of object to allocate } + { EDX pointer to typeInfo } + + PUSH EDX + CALL _GetMem + POP EDX + TEST EAX,EAX + JE @@exit + PUSH EAX + CALL _Initialize + POP EAX +@@exit: +end; + +procedure _Dispose{ p: Pointer; typeInfo: Pointer}; +asm + { -> EAX Pointer to object to be disposed } + { EDX Pointer to type info } + + PUSH EAX + CALL _Finalize + POP EAX + CALL _FreeMem +end; + +{ ----------------------------------------------------- } +{ Wide character support } +{ ----------------------------------------------------- } + +function WideCharToString(Source: PWideChar): string; +begin + WideCharToStrVar(Source, Result); +end; + +function WideCharLenToString(Source: PWideChar; SourceLen: Integer): string; +begin + WideCharLenToStrVar(Source, SourceLen, Result); +end; + +procedure WideCharToStrVar(Source: PWideChar; var Dest: string); +var + SourceLen: Integer; +begin + SourceLen := 0; + while Source[SourceLen] <> #0 do Inc(SourceLen); + WideCharLenToStrVar(Source, SourceLen, Dest); +end; + +procedure WideCharLenToStrVar(Source: PWideChar; SourceLen: Integer; + var Dest: string); +var + DestLen: Integer; + Buffer: array[0..2047] of Char; +begin + if SourceLen = 0 then + Dest := '' + else + if SourceLen < SizeOf(Buffer) div 2 then + SetString(Dest, Buffer, WideCharToMultiByte(0, 0, + Source, SourceLen, Buffer, SizeOf(Buffer), nil, nil)) + else + begin + DestLen := WideCharToMultiByte(0, 0, Source, SourceLen, + nil, 0, nil, nil); + SetString(Dest, nil, DestLen); + WideCharToMultiByte(0, 0, Source, SourceLen, Pointer(Dest), + DestLen, nil, nil); + end; +end; + +function StringToWideChar(const Source: string; Dest: PWideChar; + DestSize: Integer): PWideChar; +begin + Dest[MultiByteToWideChar(0, 0, PChar(Source), Length(Source), + Dest, DestSize - 1)] := #0; + Result := Dest; +end; + +{ ----------------------------------------------------- } +{ OLE string support } +{ ----------------------------------------------------- } + +function OleStrToString(Source: PWideChar): string; +begin + OleStrToStrVar(Source, Result); +end; + +procedure OleStrToStrVar(Source: PWideChar; var Dest: string); +begin + WideCharLenToStrVar(Source, SysStringLen(WideString(Pointer(Source))), Dest); +end; + +function StringToOleStr(const Source: string): PWideChar; +var + SourceLen, ResultLen: Integer; + Buffer: array[0..1023] of WideChar; +begin + SourceLen := Length(Source); + if Length(Source) < SizeOf(Buffer) div 2 then + Result := SysAllocStringLen(Buffer, MultiByteToWideChar(0, 0, + PChar(Source), SourceLen, Buffer, SizeOf(Buffer) div 2)) + else + begin + ResultLen := MultiByteToWideChar(0, 0, + Pointer(Source), SourceLen, nil, 0); + Result := SysAllocStringLen(nil, ResultLen); + MultiByteToWideChar(0, 0, Pointer(Source), SourceLen, + Result, ResultLen); + end; +end; + +{ ----------------------------------------------------- } +{ Variant support } +{ ----------------------------------------------------- } + +type + TBaseType = (btErr, btNul, btInt, btFlt, btCur, btStr, btBol, btDat); + +const + varLast = varByte; + +const + BaseTypeMap: array[0..varLast] of TBaseType = ( + btErr, { varEmpty } + btNul, { varNull } + btInt, { varSmallint } + btInt, { varInteger } + btFlt, { varSingle } + btFlt, { varDouble } + btCur, { varCurrency } + btDat, { varDate } + btStr, { varOleStr } + btErr, { varDispatch } + btErr, { varError } + btBol, { varBoolean } + btErr, { varVariant } + btErr, { varUnknown } + btErr, { vt_decimal } + btErr, { undefined } + btErr, { vt_i1 } + btInt); { varByte } + +const + OpTypeMap: array[TBaseType, TBaseType] of TBaseType = ( + (btErr, btErr, btErr, btErr, btErr, btErr, btErr, btErr), + (btErr, btNul, btNul, btNul, btNul, btNul, btNul, btNul), + (btErr, btNul, btInt, btFlt, btCur, btFlt, btInt, btDat), + (btErr, btNul, btFlt, btFlt, btCur, btFlt, btFlt, btDat), + (btErr, btNul, btCur, btCur, btCur, btCur, btCur, btDat), + (btErr, btNul, btFlt, btFlt, btCur, btStr, btBol, btDat), + (btErr, btNul, btInt, btFlt, btCur, btBol, btBol, btDat), + (btErr, btNul, btDat, btDat, btDat, btDat, btDat, btDat)); + +const + C10000: Single = 10000; + +const + opAdd = 0; + opSub = 1; + opMul = 2; + opDvd = 3; + opDiv = 4; + opMod = 5; + opShl = 6; + opShr = 7; + opAnd = 8; + opOr = 9; + opXor = 10; + +procedure _DispInvoke; +asm + { -> [ESP+4] Pointer to result or nil } + { [ESP+8] Pointer to variant } + { [ESP+12] Pointer to call descriptor } + { [ESP+16] Additional parameters, if any } + JMP VarDispProc +end; + + +procedure _DispInvokeError; +asm + MOV AL,reVarDispatch + JMP Error +end; + +procedure VarCastError; +asm + MOV AL,reVarTypeCast + JMP Error +end; + +procedure VarInvalidOp; +asm + MOV AL,reVarInvalidOp + JMP Error +end; + +procedure _VarClear(var V : Variant); +asm + XOR EDX,EDX + MOV DX,[EAX].TVarData.VType + TEST EDX,varByRef + JNE @@2 + CMP EDX,varOleStr + JB @@2 + CMP EDX,varString + JE @@1 + CMP EDX,varAny + JNE @@3 + JMP [ClearAnyProc] +@@1: MOV [EAX].TVarData.VType,varEmpty + ADD EAX,OFFSET TVarData.VString + JMP _LStrClr +@@2: MOV [EAX].TVarData.VType,varEmpty + RET +@@3: PUSH EAX + CALL VariantClear +end; + +procedure _VarCopy(var Dest : Variant; const Source: Variant); +asm + CMP EAX,EDX + JE @@9 + CMP [EAX].TVarData.VType,varOleStr + JB @@3 + PUSH EAX + PUSH EDX + CMP [EAX].TVarData.VType,varString + JE @@1 + CMP [EAX].TVarData.VType,varAny + JE @@0 + PUSH EAX + CALL VariantClear + JMP @@2 +@@0: CALL [ClearAnyProc] + JMP @@2 +@@1: ADD EAX,OFFSET TVarData.VString + CALL _LStrClr +@@2: POP EDX + POP EAX +@@3: CMP [EDX].TVarData.VType,varOleStr + JAE @@5 +@@4: MOV ECX,[EDX] + MOV [EAX],ECX + MOV ECX,[EDX+8] + MOV [EAX+8],ECX + MOV ECX,[EDX+12] + MOV [EAX+12],ECX + RET +@@5: CMP [EDX].TVarData.VType,varString + JE @@6 + CMP [EDX].TVarData.VType,varAny + JNE @@8 + PUSH EAX + CALL @@4 + POP EAX + JMP [RefAnyProc] +@@6: MOV EDX,[EDX].TVarData.VString + OR EDX,EDX + JE @@7 + MOV ECX,[EDX-skew].StrRec.refCnt + INC ECX + JLE @@7 +{X LOCK} INC [EDX-skew].StrRec.refCnt +@@7: MOV [EAX].TVarData.VType,varString + MOV [EAX].TVarData.VString,EDX + RET +@@8: MOV [EAX].TVarData.VType,varEmpty + PUSH EDX + PUSH EAX + CALL VariantCopyInd + OR EAX,EAX + JNE VarInvalidOp +@@9: +end; + +procedure VarCopyNoInd(var Dest: Variant; const Source: Variant); +asm + CMP EAX,EDX + JE @@9 + CMP [EAX].TVarData.VType,varOleStr + JB @@3 + PUSH EAX + PUSH EDX + CMP [EAX].TVarData.VType,varString + JE @@1 + CMP [EAX].TVarData.VType,varAny + JE @@0 + PUSH EAX + CALL VariantClear + JMP @@2 +@@0: CALL [ClearAnyProc] + JMP @@2 +@@1: ADD EAX,OFFSET TVarData.VString + CALL _LStrClr +@@2: POP EDX + POP EAX +@@3: CMP [EDX].TVarData.VType,varOleStr + JAE @@5 +@@4: MOV ECX,[EDX] + MOV [EAX],ECX + MOV ECX,[EDX+8] + MOV [EAX+8],ECX + MOV ECX,[EDX+12] + MOV [EAX+12],ECX + RET +@@5: CMP [EDX].TVarData.VType,varString + JNE @@6 + CMP [EDX].TVarData.VType,varAny + JNE @@8 + CALL @@4 + JMP [RefAnyProc] +@@6: MOV EDX,[EDX].TVarData.VString + OR EDX,EDX + JE @@7 + MOV ECX,[EDX-skew].StrRec.refCnt + INC ECX + JLE @@7 +{X LOCK} INC [EDX-skew].StrRec.refCnt +@@7: MOV [EAX].TVarData.VType,varString + MOV [EAX].TVarData.VString,EDX + RET +@@8: MOV [EAX].TVarData.VType,varEmpty + PUSH EDX + PUSH EAX + CALL VariantCopy +@@9: +end; + +type + TAnyProc = procedure (var V: Variant); + +procedure VarChangeType(var Dest: Variant; const Source: Variant; + DestType: Word); forward; + +procedure AnyChangeType(var Dest: Variant; Source: Variant; DestType: Word); +begin + TAnyProc(ChangeAnyProc)(Source); + VarChangeType(Dest, Source, DestType); +end; + +procedure VarChangeType(var Dest: Variant; const Source: Variant; + DestType: Word); +type + TVarMem = array[0..3] of Integer; + + function ChangeSourceAny(var Dest: Variant; const Source: Variant; + DestType: Word): Boolean; + begin + Result := False; + if TVarData(Source).VType = varAny then + begin + AnyChangeType(Dest, Source, DestType); + Result := True; + end; + end; + +var + Temp: TVarData; +begin + case TVarData(Dest).VType of + varString: + begin + if not ChangeSourceAny(Dest, Source, DestType) then + begin + Temp.VType := varEmpty; + if VariantChangeTypeEx(Variant(Temp), Source, $400, 0, DestType) <> 0 then + VarCastError; + _VarClear(Dest); + TVarMem(Dest)[0] := TVarMem(Temp)[0]; + TVarMem(Dest)[2] := TVarMem(Temp)[2]; + TVarMem(Dest)[3] := TVarMem(Temp)[3]; + end; + end; + varAny: AnyChangeType(Dest, Source, DestType); + else if not ChangeSourceAny(Dest, Source, DestType) then + if VariantChangeTypeEx(Dest, Source, $400, 0, DestType) <> 0 then + VarCastError; + end; +end; + +procedure VarOleStrToString(var Dest: Variant; const Source: Variant); +var + StringPtr: Pointer; +begin + StringPtr := nil; + OleStrToStrVar(TVarData(Source).VOleStr, string(StringPtr)); + _VarClear(Dest); + TVarData(Dest).VType := varString; + TVarData(Dest).VString := StringPtr; +end; + +procedure VarStringToOleStr(var Dest: Variant; const Source: Variant); +var + OleStrPtr: PWideChar; +begin + OleStrPtr := StringToOleStr(string(TVarData(Source).VString)); + _VarClear(Dest); + TVarData(Dest).VType := varOleStr; + TVarData(Dest).VOleStr := OleStrPtr; +end; + +procedure _VarCast(var Dest : Variant; const Source: Variant; VarType: Integer); +var + SourceType, DestType: Word; + Temp: TVarData; +begin + SourceType := TVarData(Source).VType; + DestType := Word(VarType); + if SourceType = DestType then + _VarCopy(Dest, Source) + else + if SourceType = varString then + if DestType = varOleStr then + VarStringToOleStr(Variant(Dest), Source) + else + begin + Temp.VType := varEmpty; + VarStringToOleStr(Variant(Temp), Source); + try + VarChangeType(Variant(Dest), Variant(Temp), DestType); + finally + _VarClear(PVariant(@Temp)^); + end; + end + else + if (DestType = varString) and (SourceType <> varAny) then + if SourceType = varOleStr then + VarOleStrToString(Variant(Dest), Source) + else + begin + Temp.VType := varEmpty; + VarChangeType(Variant(Temp), Source, varOleStr); + try + VarOleStrToString(Variant(Dest), Variant(Temp)); + finally + _VarClear(Variant(Temp)); + end; + end + else + VarChangeType(Variant(Dest), Source, DestType); +end; + +(* VarCast when the destination is OleVariant *) +procedure _VarCastOle(var Dest : Variant; const Source: Variant; VarType: Integer); +begin + if (VarType = varString) or (VarType = varAny) then + VarCastError + else + _VarCast(Dest, Source, VarType); +end; + +procedure _VarToInt; +asm + XOR EDX,EDX + MOV DX,[EAX].TVarData.VType + CMP EDX,varInteger + JE @@0 + CMP EDX,varSmallint + JE @@1 + CMP EDX,varByte + JE @@2 + CMP EDX,varDouble + JE @@5 + CMP EDX,varSingle + JE @@4 + CMP EDX,varCurrency + JE @@3 + SUB ESP,16 + MOV [ESP].TVarData.VType,varEmpty + MOV EDX,EAX + MOV EAX,ESP + MOV ECX,varInteger + CALL _VarCast + MOV EAX,[ESP].TVarData.VInteger + ADD ESP,16 + RET +@@0: MOV EAX,[EAX].TVarData.VInteger + RET +@@1: MOVSX EAX,[EAX].TVarData.VSmallint + RET +@@2: MOVZX EAX,[EAX].TVarData.VByte + RET +@@3: FILD [EAX].TVarData.VCurrency + FDIV C10000 + JMP @@6 +@@4: FLD [EAX].TVarData.VSingle + JMP @@6 +@@5: FLD [EAX].TVarData.VDouble +@@6: PUSH EAX + FISTP DWORD PTR [ESP] + FWAIT + POP EAX +end; + +procedure _VarToBool; +asm + CMP [EAX].TVarData.VType,varBoolean + JE @@1 + SUB ESP,16 + MOV [ESP].TVarData.VType,varEmpty + MOV EDX,EAX + MOV EAX,ESP + MOV ECX,varBoolean + CALL _VarCast + MOV AX,[ESP].TVarData.VBoolean + ADD ESP,16 + JMP @@2 +@@1: MOV AX,[EAX].TVarData.VBoolean +@@2: NEG AX + SBB EAX,EAX + NEG EAX +end; + +procedure _VarToReal; +asm + XOR EDX,EDX + MOV DX,[EAX].TVarData.VType + CMP EDX,varDouble + JE @@1 + CMP EDX,varSingle + JE @@2 + CMP EDX,varCurrency + JE @@3 + CMP EDX,varInteger + JE @@4 + CMP EDX,varSmallint + JE @@5 + CMP EDX,varDate + JE @@1 + SUB ESP,16 + MOV [ESP].TVarData.VType,varEmpty + MOV EDX,EAX + MOV EAX,ESP + MOV ECX,varDouble + CALL _VarCast + FLD [ESP].TVarData.VDouble + ADD ESP,16 + RET +@@1: FLD [EAX].TVarData.VDouble + RET +@@2: FLD [EAX].TVarData.VSingle + RET +@@3: FILD [EAX].TVarData.VCurrency + FDIV C10000 + RET +@@4: FILD [EAX].TVarData.VInteger + RET +@@5: FILD [EAX].TVarData.VSmallint +end; + +procedure _VarToCurr; +asm + XOR EDX,EDX + MOV DX,[EAX].TVarData.VType + CMP EDX,varCurrency + JE @@1 + CMP EDX,varDouble + JE @@2 + CMP EDX,varSingle + JE @@3 + CMP EDX,varInteger + JE @@4 + CMP EDX,varSmallint + JE @@5 + SUB ESP,16 + MOV [ESP].TVarData.VType,varEmpty + MOV EDX,EAX + MOV EAX,ESP + MOV ECX,varCurrency + CALL _VarCast + FILD [ESP].TVarData.VCurrency + ADD ESP,16 + RET +@@1: FILD [EAX].TVarData.VCurrency + RET +@@2: FLD [EAX].TVarData.VDouble + JMP @@6 +@@3: FLD [EAX].TVarData.VSingle + JMP @@6 +@@4: FILD [EAX].TVarData.VInteger + JMP @@6 +@@5: FILD [EAX].TVarData.VSmallint +@@6: FMUL C10000 +end; + +procedure _VarToPStr(var S; const V: Variant); +var + Temp: string; +begin + _VarToLStr(Temp, V); + ShortString(S) := Temp; +end; + +procedure _VarToLStr(var S: string; const V: Variant); +asm + { -> EAX: destination string } + { EDX: source variant } + { <- none } + + CMP [EDX].TVarData.VType,varString + JNE @@1 + MOV EDX,[EDX].TVarData.VString + JMP _LStrAsg +@@1: PUSH EBX + MOV EBX,EAX + SUB ESP,16 + MOV [ESP].TVarData.VType,varEmpty + MOV EAX,ESP + MOV ECX,varString + CALL _VarCast + MOV EAX,EBX + CALL _LStrClr + MOV EAX,[ESP].TVarData.VString + MOV [EBX],EAX + ADD ESP,16 + POP EBX +end; + +procedure _VarToWStr(var S: WideString; const V: Variant); +asm + CMP [EDX].TVarData.VType,varOleStr + JNE @@1 + MOV EDX,[EDX].TVarData.VOleStr + JMP _WStrAsg +@@1: PUSH EBX + MOV EBX,EAX + SUB ESP,16 + MOV [ESP].TVarData.VType,varEmpty + MOV EAX,ESP + MOV ECX,varOleStr + CALL _VarCast + MOV EAX,EBX + MOV EDX,[ESP].TVarData.VOleStr + CALL WStrSet + ADD ESP,16 + POP EBX +end; + +procedure AnyToIntf(var Unknown: IUnknown; V: Variant); +begin + TAnyProc(ChangeAnyProc)(V); + if TVarData(V).VType <> varUnknown then + VarCastError; + Unknown := IUnknown(TVarData(V).VUnknown); +end; + +procedure _VarToIntf(var Unknown: IUnknown; const V: Variant); +asm + CMP [EDX].TVarData.VType,varEmpty + JE _IntfClear + CMP [EDX].TVarData.VType,varUnknown + JE @@2 + CMP [EDX].TVarData.VType,varDispatch + JE @@2 + CMP [EDX].TVarData.VType,varUnknown+varByRef + JE @@1 + CMP [EDX].TVarData.VType,varDispatch+varByRef + JE @@1 + CMP [EDX].TVarData.VType,varAny + JNE VarCastError + JMP AnyToIntf +@@0: CALL _VarClear + ADD ESP,16 + JMP VarCastError +@@1: MOV EDX,[EDX].TVarData.VPointer + MOV EDX,[EDX] + JMP _IntfCopy +@@2: MOV EDX,[EDX].TVarData.VUnknown + JMP _IntfCopy +end; + +procedure _VarToDisp(var Dispatch: IDispatch; const V: Variant); +asm + CMP [EDX].TVarData.VType,varEmpty + JE _IntfClear + CMP [EDX].TVarData.VType,varDispatch + JE @@1 + CMP [EDX].TVarData.VType,varDispatch+varByRef + JNE VarCastError + MOV EDX,[EDX].TVarData.VPointer + MOV EDX,[EDX] + JMP _IntfCopy +@@1: MOV EDX,[EDX].TVarData.VDispatch + JMP _IntfCopy +end; + +procedure _VarToDynArray(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer); +asm + CALL DynArrayFromVariant + OR EAX, EAX + JNZ @@1 + JMP VarCastError +@@1: +end; + +procedure _VarFromInt; +asm + CMP [EAX].TVarData.VType,varOleStr + JB @@1 + PUSH EAX + PUSH EDX + CALL _VarClear + POP EDX + POP EAX +@@1: MOV [EAX].TVarData.VType,varInteger + MOV [EAX].TVarData.VInteger,EDX +end; + +procedure _VarFromBool; +asm + CMP [EAX].TVarData.VType,varOleStr + JB @@1 + PUSH EAX + PUSH EDX + CALL _VarClear + POP EDX + POP EAX +@@1: MOV [EAX].TVarData.VType,varBoolean + NEG DL + SBB EDX,EDX + MOV [EAX].TVarData.VBoolean,DX +end; + +procedure _VarFromReal; +asm + CMP [EAX].TVarData.VType,varOleStr + JB @@1 + PUSH EAX + CALL _VarClear + POP EAX +@@1: MOV [EAX].TVarData.VType,varDouble + FSTP [EAX].TVarData.VDouble + FWAIT +end; + +procedure _VarFromTDateTime; +asm + CMP [EAX].TVarData.VType,varOleStr + JB @@1 + PUSH EAX + CALL _VarClear + POP EAX +@@1: MOV [EAX].TVarData.VType,varDate + FSTP [EAX].TVarData.VDouble + FWAIT +end; + +procedure _VarFromCurr; +asm + CMP [EAX].TVarData.VType,varOleStr + JB @@1 + PUSH EAX + CALL _VarClear + POP EAX +@@1: MOV [EAX].TVarData.VType,varCurrency + FISTP [EAX].TVarData.VCurrency + FWAIT +end; + +procedure _VarFromPStr(var V: Variant; const Value: ShortString); +begin + _VarFromLStr(V, Value); +end; + +procedure _VarFromLStr(var V: Variant; const Value: string); +asm + CMP [EAX].TVarData.VType,varOleStr + JB @@1 + PUSH EAX + PUSH EDX + CALL _VarClear + POP EDX + POP EAX +@@1: TEST EDX,EDX + JE @@3 + MOV ECX,[EDX-skew].StrRec.refCnt + INC ECX + JLE @@2 +{X LOCK} INC [EDX-skew].StrRec.refCnt + JMP @@3 +@@2: PUSH EAX + PUSH EDX + MOV EAX,[EDX-skew].StrRec.length + CALL _NewAnsiString + MOV EDX,EAX + POP EAX + PUSH EDX + MOV ECX,[EDX-skew].StrRec.length + CALL Move + POP EDX + POP EAX +@@3: MOV [EAX].TVarData.VType,varString + MOV [EAX].TVarData.VString,EDX +end; + +procedure _VarFromWStr(var V: Variant; const Value: WideString); +asm + PUSH EAX + CMP [EAX].TVarData.VType,varOleStr + JB @@1 + PUSH EDX + CALL _VarClear + POP EDX +@@1: XOR EAX,EAX + TEST EDX,EDX + JE @@2 + MOV EAX,[EDX-4] + SHR EAX,1 + JE @@2 + PUSH EAX + PUSH EDX + CALL SysAllocStringLen + TEST EAX,EAX + JE WStrError +@@2: POP EDX + MOV [EDX].TVarData.VType,varOleStr + MOV [EDX].TVarData.VOleStr,EAX +end; + +procedure _VarFromIntf(var V: Variant; const Value: IUnknown); +asm + CMP [EAX].TVarData.VType,varOleStr + JB @@1 + PUSH EAX + PUSH EDX + CALL _VarClear + POP EDX + POP EAX +@@1: MOV [EAX].TVarData.VType,varUnknown + MOV [EAX].TVarData.VUnknown,EDX + TEST EDX,EDX + JE @@2 + PUSH EDX + MOV EAX,[EDX] + CALL [EAX].vmtAddRef.Pointer +@@2: +end; + +procedure _VarFromDisp(var V: Variant; const Value: IDispatch); +asm + CMP [EAX].TVarData.VType,varOleStr + JB @@1 + PUSH EAX + PUSH EDX + CALL _VarClear + POP EDX + POP EAX +@@1: MOV [EAX].TVarData.VType,varDispatch + MOV [EAX].TVarData.VDispatch,EDX + TEST EDX,EDX + JE @@2 + PUSH EDX + MOV EAX,[EDX] + CALL [EAX].vmtAddRef.Pointer +@@2: +end; + +procedure _VarFromDynArray(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer); +asm + PUSH EAX + CALL DynArrayToVariant + POP EAX + CMP [EAX].TVarData.VType,varEmpty + JNE @@1 + JMP VarCastError +@@1: +end; + +procedure _OleVarFromPStr(var V: OleVariant; const Value: ShortString); +begin + _OleVarFromLStr(V, Value); +end; + + +procedure _OleVarFromLStr(var V: OleVariant; const Value: string); +asm + CMP [EAX].TVarData.VType,varOleStr + JB @@1 + PUSH EAX + PUSH EDX + CALL _VarClear + POP EDX + POP EAX +@@1: MOV [EAX].TVarData.VType,varOleStr + ADD EAX,TVarData.VOleStr + XOR ECX,ECX + MOV [EAX],ECX + JMP _WStrFromLStr +end; + +procedure OleVarFromAny(var V: OleVariant; Value: Variant); +begin + TAnyProc(ChangeAnyProc)(Value); + V := Value; +end; + +procedure _OleVarFromVar(var V: OleVariant; const Value: Variant); +asm + CMP [EDX].TVarData.VType,varAny + JE OleVarFromAny + CMP [EDX].TVarData.VType,varString + JNE _VarCopy + CMP [EAX].TVarData.VType,varOleStr + JB @@1 + PUSH EAX + PUSH EDX + CALL _VarClear + POP EDX + POP EAX +@@1: MOV [EAX].TVarData.VType,varOleStr + ADD EAX,TVarData.VOleStr + ADD EDX,TVarData.VString + XOR ECX,ECX + MOV EDX,[EDX] + MOV [EAX],ECX + JMP _WStrFromLStr +@@2: +end; + + +procedure VarStrCat(var Dest: Variant; const Source: Variant); +begin + if TVarData(Dest).VType = varString then + Dest := string(Dest) + string(Source) + else + Dest := WideString(Dest) + WideString(Source); +end; + +procedure VarOp(var Dest: Variant; const Source: Variant; OpCode: Integer); forward; + +procedure AnyOp(var Dest: Variant; Source: Variant; OpCode: Integer); +begin + if TVarData(Dest).VType = varAny then TAnyProc(ChangeAnyProc)(Dest); + if TVarData(Source).VType = varAny then TAnyProc(ChangeAnyProc)(Source); + VarOp(Dest, Source, OpCode); +end; + +procedure VarOp(var Dest: Variant; const Source: Variant; OpCode: Integer); +asm + PUSH EBX + PUSH ESI + PUSH EDI + MOV EDI,EAX + MOV ESI,EDX + MOV EBX,ECX + MOV EAX,[EDI].TVarData.VType.Integer + MOV EDX,[ESI].TVarData.VType.Integer + AND EAX,varTypeMask + AND EDX,varTypeMask + CMP EAX,varLast + JBE @@1 + CMP EAX,varString + JNE @@4 + MOV EAX,varOleStr +@@1: CMP EDX,varLast + JBE @@2 + CMP EDX,varString + JNE @@3 + MOV EDX,varOleStr +@@2: MOV AL,BaseTypeMap.Byte[EAX] + MOV DL,BaseTypeMap.Byte[EDX] + MOVZX ECX,OpTypeMap.Byte[EAX*8+EDX] + CALL @VarOpTable.Pointer[ECX*4] + POP EDI + POP ESI + POP EBX + RET +@@3: MOV EAX,EDX +@@4: CMP EAX,varAny + JNE @InvalidOp + POP EDI + POP ESI + POP EBX + JMP AnyOp + +@VarOpTable: + DD @VarOpError + DD @VarOpNull + DD @VarOpInteger + DD @VarOpReal + DD @VarOpCurr + DD @VarOpString + DD @VarOpBoolean + DD @VarOpDate + +@VarOpError: + POP EAX + +@InvalidOp: + POP EDI + POP ESI + POP EBX + JMP VarInvalidOp + +@VarOpNull: + MOV EAX,EDI + CALL _VarClear + MOV [EDI].TVarData.VType,varNull + RET + +@VarOpInteger: + CMP BL,opDvd + JE @RealOp + +@IntegerOp: + MOV EAX,ESI + CALL _VarToInt + PUSH EAX + MOV EAX,EDI + CALL _VarToInt + POP EDX + CALL @IntegerOpTable.Pointer[EBX*4] + MOV EDX,EAX + MOV EAX,EDI + JMP _VarFromInt + +@IntegerOpTable: + DD @IntegerAdd + DD @IntegerSub + DD @IntegerMul + DD 0 + DD @IntegerDiv + DD @IntegerMod + DD @IntegerShl + DD @IntegerShr + DD @IntegerAnd + DD @IntegerOr + DD @IntegerXor + +@IntegerAdd: + ADD EAX,EDX + JO @IntToRealOp + RET + +@IntegerSub: + SUB EAX,EDX + JO @IntToRealOp + RET + +@IntegerMul: + IMUL EDX + JO @IntToRealOp + RET + +@IntegerDiv: + MOV ECX,EDX + CDQ + IDIV ECX + RET + +@IntegerMod: + MOV ECX,EDX + CDQ + IDIV ECX + MOV EAX,EDX + RET + +@IntegerShl: + MOV ECX,EDX + SHL EAX,CL + RET + +@IntegerShr: + MOV ECX,EDX + SHR EAX,CL + RET + +@IntegerAnd: + AND EAX,EDX + RET + +@IntegerOr: + OR EAX,EDX + RET + +@IntegerXor: + XOR EAX,EDX + RET + +@IntToRealOp: + POP EAX + JMP @RealOp + +@VarOpReal: + CMP BL,opDiv + JAE @IntegerOp + +@RealOp: + MOV EAX,ESI + CALL _VarToReal + SUB ESP,12 + FSTP TBYTE PTR [ESP] + MOV EAX,EDI + CALL _VarToReal + FLD TBYTE PTR [ESP] + ADD ESP,12 + CALL @RealOpTable.Pointer[EBX*4] + +@RealResult: + MOV EAX,EDI + JMP _VarFromReal + +@VarOpCurr: + CMP BL,opDiv + JAE @IntegerOp + CMP BL,opMul + JAE @CurrMulDvd + MOV EAX,ESI + CALL _VarToCurr + SUB ESP,12 + FSTP TBYTE PTR [ESP] + MOV EAX,EDI + CALL _VarToCurr + FLD TBYTE PTR [ESP] + ADD ESP,12 + CALL @RealOpTable.Pointer[EBX*4] + +@CurrResult: + MOV EAX,EDI + JMP _VarFromCurr + +@CurrMulDvd: + CMP DL,btCur + JE @CurrOpCurr + MOV EAX,ESI + CALL _VarToReal + FILD [EDI].TVarData.VCurrency + FXCH + CALL @RealOpTable.Pointer[EBX*4] + JMP @CurrResult + +@CurrOpCurr: + CMP BL,opDvd + JE @CurrDvdCurr + CMP AL,btCur + JE @CurrMulCurr + MOV EAX,EDI + CALL _VarToReal + FILD [ESI].TVarData.VCurrency + FMUL + JMP @CurrResult + +@CurrMulCurr: + FILD [EDI].TVarData.VCurrency + FILD [ESI].TVarData.VCurrency + FMUL + FDIV C10000 + JMP @CurrResult + +@CurrDvdCurr: + MOV EAX,EDI + CALL _VarToCurr + FILD [ESI].TVarData.VCurrency + FDIV + JMP @RealResult + +@RealOpTable: + DD @RealAdd + DD @RealSub + DD @RealMul + DD @RealDvd + +@RealAdd: + FADD + RET + +@RealSub: + FSUB + RET + +@RealMul: + FMUL + RET + +@RealDvd: + FDIV + RET + +@VarOpString: + CMP BL,opAdd + JNE @VarOpReal + MOV EAX,EDI + MOV EDX,ESI + JMP VarStrCat + +@VarOpBoolean: + CMP BL,opAnd + JB @VarOpReal + MOV EAX,ESI + CALL _VarToBool + PUSH EAX + MOV EAX,EDI + CALL _VarToBool + POP EDX + CALL @IntegerOpTable.Pointer[EBX*4] + MOV EDX,EAX + MOV EAX,EDI + JMP _VarFromBool + +@VarOpDate: + CMP BL,opSub + JA @VarOpReal + JB @DateOp + MOV AH,DL + CMP AX,btDat+btDat*256 + JE @RealOp + +@DateOp: + CALL @RealOp + MOV [EDI].TVarData.VType,varDate + RET +end; + +procedure _VarAdd; +asm + MOV ECX,opAdd + JMP VarOp +end; + +procedure _VarSub; +asm + MOV ECX,opSub + JMP VarOp +end; + +procedure _VarMul; +asm + MOV ECX,opMul + JMP VarOp +end; + +procedure _VarDiv; +asm + MOV ECX,opDiv + JMP VarOp +end; + +procedure _VarMod; +asm + MOV ECX,opMod + JMP VarOp +end; + +procedure _VarAnd; +asm + MOV ECX,opAnd + JMP VarOp +end; + +procedure _VarOr; +asm + MOV ECX,opOr + JMP VarOp +end; + +procedure _VarXor; +asm + MOV ECX,opXor + JMP VarOp +end; + +procedure _VarShl; +asm + MOV ECX,opShl + JMP VarOp +end; + +procedure _VarShr; +asm + MOV ECX,opShr + JMP VarOp +end; + +procedure _VarRDiv; +asm + MOV ECX,opDvd + JMP VarOp +end; + +function VarCompareString(const S1, S2: string): Integer; +asm + PUSH ESI + PUSH EDI + MOV ESI,EAX + MOV EDI,EDX + OR EAX,EAX + JE @@1 + MOV EAX,[EAX-4] +@@1: OR EDX,EDX + JE @@2 + MOV EDX,[EDX-4] +@@2: MOV ECX,EAX + CMP ECX,EDX + JBE @@3 + MOV ECX,EDX +@@3: CMP ECX,ECX + REPE CMPSB + JE @@4 + MOVZX EAX,BYTE PTR [ESI-1] + MOVZX EDX,BYTE PTR [EDI-1] +@@4: SUB EAX,EDX + POP EDI + POP ESI +end; + +function VarCmpStr(const V1, V2: Variant): Integer; +begin + Result := VarCompareString(V1, V2); +end; + +function AnyCmp(var Dest: Variant; const Source: Variant): Integer; +var + Temp: Variant; + P: ^Variant; +begin + asm + PUSH Dest + end; + P := @Source; + if TVarData(Dest).VType = varAny then TAnyProc(ChangeAnyProc)(Dest); + if TVarData(Source).VType = varAny then + begin + Temp := Source; + TAnyProc(ChangeAnyProc)(Temp); + P := @Temp; + end; + asm + MOV EDX,P + POP EAX + CALL _VarCmp + PUSHF + POP EAX + MOV Result,EAX + end; +end; + +procedure _VarCmp; +asm + PUSH ESI + PUSH EDI + MOV EDI,EAX + MOV ESI,EDX + MOV EAX,[EDI].TVarData.VType.Integer + MOV EDX,[ESI].TVarData.VType.Integer + AND EAX,varTypeMask + AND EDX,varTypeMask + CMP EAX,varLast + JBE @@1 + CMP EAX,varString + JNE @@4 + MOV EAX,varOleStr +@@1: CMP EDX,varLast + JBE @@2 + CMP EDX,varString + JNE @@3 + MOV EDX,varOleStr +@@2: MOV AL,BaseTypeMap.Byte[EAX] + MOV DL,BaseTypeMap.Byte[EDX] + MOVZX ECX,OpTypeMap.Byte[EAX*8+EDX] + JMP @VarCmpTable.Pointer[ECX*4] +@@3: MOV EAX,EDX +@@4: CMP EAX,varAny + JNE @VarCmpError + POP EDI + POP ESI + CALL AnyCmp + PUSH EAX + POPF + RET + +@VarCmpTable: + DD @VarCmpError + DD @VarCmpNull + DD @VarCmpInteger + DD @VarCmpReal + DD @VarCmpCurr + DD @VarCmpString + DD @VarCmpBoolean + DD @VarCmpDate + +@VarCmpError: + POP EDI + POP ESI + JMP VarInvalidOp + +@VarCmpNull: + CMP AL,DL + JMP @Exit + +@VarCmpInteger: + MOV EAX,ESI + CALL _VarToInt + XCHG EAX,EDI + CALL _VarToInt + CMP EAX,EDI + JMP @Exit + +@VarCmpReal: +@VarCmpDate: + MOV EAX,EDI + CALL _VarToReal + SUB ESP,12 + FSTP TBYTE PTR [ESP] + MOV EAX,ESI + CALL _VarToReal + FLD TBYTE PTR [ESP] + ADD ESP,12 + +@RealCmp: + FCOMPP + FNSTSW AX + MOV AL,AH { Move CF into SF } + AND AX,4001H + ROR AL,1 + OR AH,AL + SAHF + JMP @Exit + +@VarCmpCurr: + MOV EAX,EDI + CALL _VarToCurr + SUB ESP,12 + FSTP TBYTE PTR [ESP] + MOV EAX,ESI + CALL _VarToCurr + FLD TBYTE PTR [ESP] + ADD ESP,12 + JMP @RealCmp + +@VarCmpString: + MOV EAX,EDI + MOV EDX,ESI + CALL VarCmpStr + CMP EAX,0 + JMP @Exit + +@VarCmpBoolean: + MOV EAX,ESI + CALL _VarToBool + XCHG EAX,EDI + CALL _VarToBool + MOV EDX,EDI + CMP AL,DL + +@Exit: + POP EDI + POP ESI +end; + +procedure _VarNeg; +asm + MOV EDX,[EAX].TVarData.VType.Integer + AND EDX,varTypeMask + CMP EDX,varLast + JBE @@1 + CMP EDX,varString + JNE @VarNegError + MOV EDX,varOleStr +@@1: MOV DL,BaseTypeMap.Byte[EDX] + JMP @VarNegTable.Pointer[EDX*4] +@@2: CMP EAX,varAny + JNE @VarNegError + PUSH EAX + CALL [ChangeAnyProc] + POP EAX + JMP _VarNeg + +@VarNegTable: + DD @VarNegError + DD @VarNegNull + DD @VarNegInteger + DD @VarNegReal + DD @VarNegCurr + DD @VarNegReal + DD @VarNegInteger + DD @VarNegDate + +@VarNegError: + JMP VarInvalidOp + +@VarNegNull: + RET + +@VarNegInteger: + PUSH EAX + CALL _VarToInt + NEG EAX + MOV EDX,EAX + POP EAX + JMP _VarFromInt + +@VarNegReal: + PUSH EAX + CALL _VarToReal + FCHS + POP EAX + JMP _VarFromReal + +@VarNegCurr: + FILD [EAX].TVarData.VCurrency + FCHS + FISTP [EAX].TVarData.VCurrency + FWAIT + RET + +@VarNegDate: + FLD [EAX].TVarData.VDate + FCHS + FSTP [EAX].TVarData.VDate + FWAIT +end; + +procedure _VarNot; +asm + MOV EDX,[EAX].TVarData.VType.Integer + AND EDX,varTypeMask + JE @@2 + CMP EDX,varBoolean + JE @@3 + CMP EDX,varNull + JE @@4 + CMP EDX,varLast + JBE @@1 + CMP EDX,varString + JE @@1 + CMP EAX,varAny + JNE @@2 + PUSH EAX + CALL [ChangeAnyProc] + POP EAX + JMP _VarNot +@@1: PUSH EAX + CALL _VarToInt + NOT EAX + MOV EDX,EAX + POP EAX + JMP _VarFromInt +@@2: JMP VarInvalidOp +@@3: MOV DX,[EAX].TVarData.VBoolean + NEG DX + SBB EDX,EDX + NOT EDX + MOV [EAX].TVarData.VBoolean,DX +@@4: +end; + +procedure _VarCopyNoInd; +asm + JMP VarCopyNoInd +end; + +procedure VariantClr; +asm + JMP _VarClr +end; + +procedure _VarClr; +asm + PUSH EAX + CALL _VarClear + POP EAX +end; + +procedure VariantAddRef; +asm + JMP _VarAddRef +end; + +procedure _VarAddRef; +asm + CMP [EAX].TVarData.VType,varOleStr + JB @@1 + PUSH [EAX].Integer[12] + PUSH [EAX].Integer[8] + PUSH [EAX].Integer[4] + PUSH [EAX].Integer[0] + MOV [EAX].TVarData.VType,varEmpty + MOV EDX,ESP + CALL _VarCopy + ADD ESP,16 +@@1: +end; + +function VarType(const V: Variant): Integer; +asm + MOVZX EAX,[EAX].TVarData.VType +end; + +function VarAsType(const V: Variant; VarType: Integer): Variant; +begin + _VarCast(Result, V, VarType); +end; + +function VarIsEmpty(const V: Variant): Boolean; +begin + with TVarData(V) do + Result := (VType = varEmpty) or ((VType = varDispatch) or + (VType = varUnknown)) and (VDispatch = nil); +end; + +function VarIsNull(const V: Variant): Boolean; +begin + Result := TVarData(V).VType = varNull; +end; + +function VarToStr(const V: Variant): string; +begin + if TVarData(V).VType <> varNull then Result := V else Result := ''; +end; + +function VarFromDateTime(DateTime: TDateTime): Variant; +begin + _VarClear(Result); + TVarData(Result).VType := varDate; + TVarData(Result).VDate := DateTime; +end; + +function VarToDateTime(const V: Variant): TDateTime; +var + Temp: TVarData; +begin + Temp.VType := varEmpty; + _VarCast(Variant(Temp), V, varDate); + Result := Temp.VDate; +end; + +function _WriteVariant(var T: Text; const V: Variant; Width: Integer): Pointer; +var + S: string; +begin + if TVarData(V).VType >= varSmallint then S := V; + Write(T, S: Width); + Result := @T; +end; + +function _Write0Variant(var T: Text; const V: Variant): Pointer; +begin + Result := _WriteVariant(T, V, 0); +end; + +{ ----------------------------------------------------- } +{ Variant array support } +{ ----------------------------------------------------- } + +function VarArrayCreate(const Bounds: array of Integer; + VarType: Integer): Variant; +var + I, DimCount: Integer; + VarArrayRef: PVarArray; + VarBounds: array[0..63] of TVarArrayBound; +begin + if not Odd(High(Bounds)) or (High(Bounds) > 127) then + Error(reVarArrayCreate); + DimCount := (High(Bounds) + 1) div 2; + for I := 0 to DimCount - 1 do + with VarBounds[I] do + begin + LowBound := Bounds[I * 2]; + ElementCount := Bounds[I * 2 + 1] - LowBound + 1; + end; + VarArrayRef := SafeArrayCreate(VarType, DimCount, VarBounds); + if VarArrayRef = nil then Error(reVarArrayCreate); + _VarClear(Result); + TVarData(Result).VType := VarType or varArray; + TVarData(Result).VArray := VarArrayRef; +end; + +function VarArrayOf(const Values: array of Variant): Variant; +var + I: Integer; +begin + Result := VarArrayCreate([0, High(Values)], varVariant); + for I := 0 to High(Values) do Result[I] := Values[I]; +end; + +procedure _VarArrayRedim(var A : Variant; HighBound: Integer); +var + VarBound: TVarArrayBound; +begin + if (TVarData(A).VType and (varArray or varByRef)) <> varArray then + Error(reVarNotArray); + with TVarData(A).VArray^ do + VarBound.LowBound := Bounds[DimCount - 1].LowBound; + VarBound.ElementCount := HighBound - VarBound.LowBound + 1; + if SafeArrayRedim(TVarData(A).VArray, VarBound) <> 0 then + Error(reVarArrayCreate); +end; + +function GetVarArray(const A: Variant): PVarArray; +begin + if TVarData(A).VType and varArray = 0 then Error(reVarNotArray); + if TVarData(A).VType and varByRef <> 0 then + Result := PVarArray(TVarData(A).VPointer^) else + Result := TVarData(A).VArray; +end; + +function VarArrayDimCount(const A: Variant): Integer; +begin + if TVarData(A).VType and varArray <> 0 then + Result := GetVarArray(A)^.DimCount else + Result := 0; +end; + +function VarArrayLowBound(const A: Variant; Dim: Integer): Integer; +begin + if SafeArrayGetLBound(GetVarArray(A), Dim, Result) <> 0 then + Error(reVarArrayBounds); +end; + +function VarArrayHighBound(const A: Variant; Dim: Integer): Integer; +begin + if SafeArrayGetUBound(GetVarArray(A), Dim, Result) <> 0 then + Error(reVarArrayBounds); +end; + +function VarArrayLock(const A: Variant): Pointer; +begin + if SafeArrayAccessData(GetVarArray(A), Result) <> 0 then + Error(reVarNotArray); +end; + +procedure VarArrayUnlock(const A: Variant); +begin + if SafeArrayUnaccessData(GetVarArray(A)) <> 0 then + Error(reVarNotArray); +end; + +function VarArrayRef(const A: Variant): Variant; +begin + if TVarData(A).VType and varArray = 0 then Error(reVarNotArray); + _VarClear(Result); + TVarData(Result).VType := TVarData(A).VType or varByRef; + if TVarData(A).VType and varByRef <> 0 then + TVarData(Result).VPointer := TVarData(A).VPointer else + TVarData(Result).VPointer := @TVarData(A).VArray; +end; + +function VarIsArray(const A: Variant): Boolean; +begin + Result := TVarData(A).VType and varArray <> 0; +end; + +function _VarArrayGet(var A: Variant; IndexCount: Integer; + Indices: Integer): Variant; cdecl; +var + VarArrayPtr: PVarArray; + VarType: Integer; + P: Pointer; +begin + if TVarData(A).VType and varArray = 0 then Error(reVarNotArray); + VarArrayPtr := GetVarArray(A); + if VarArrayPtr^.DimCount <> IndexCount then Error(reVarArrayBounds); + VarType := TVarData(A).VType and varTypeMask; + _VarClear(Result); + if VarType = varVariant then + begin + if SafeArrayPtrOfIndex(VarArrayPtr, @Indices, P) <> 0 then + Error(reVarArrayBounds); + Result := PVariant(P)^; + end else + begin + if SafeArrayGetElement(VarArrayPtr, @Indices, + @TVarData(Result).VPointer) <> 0 then Error(reVarArrayBounds); + TVarData(Result).VType := VarType; + end; +end; + +procedure _VarArrayPut(var A: Variant; const Value: Variant; + IndexCount: Integer; Indices: Integer); cdecl; +type + TAnyPutArrayProc = procedure (var A: Variant; const Value: Variant; Index: Integer); +var + VarArrayPtr: PVarArray; + VarType: Integer; + P: Pointer; + Temp: TVarData; +begin + if TVarData(A).VType and varArray = 0 then Error(reVarNotArray); + VarArrayPtr := GetVarArray(A); + if VarArrayPtr^.DimCount <> IndexCount then Error(reVarArrayBounds); + VarType := TVarData(A).VType and varTypeMask; + if (VarType = varVariant) and (TVarData(Value).VType <> varString) then + begin + if SafeArrayPtrOfIndex(VarArrayPtr, @Indices, P) <> 0 then + Error(reVarArrayBounds); + PVariant(P)^ := Value; + end else + begin + Temp.VType := varEmpty; + try + if VarType = varVariant then + begin + VarStringToOleStr(Variant(Temp), Value); + P := @Temp; + end else + begin + _VarCast(Variant(Temp), Value, VarType); + case VarType of + varOleStr, varDispatch, varUnknown: + P := Temp.VPointer; + else + P := @Temp.VPointer; + end; + end; + if SafeArrayPutElement(VarArrayPtr, @Indices, P) <> 0 then + Error(reVarArrayBounds); + finally + _VarClear(Variant(Temp)); + end; + end; +end; + + +function VarArrayGet(const A: Variant; const Indices: array of Integer): Variant; +asm + { ->EAX Pointer to A } + { EDX Pointer to Indices } + { ECX High bound of Indices } + { [EBP+8] Pointer to result } + + PUSH EBX + + MOV EBX,ECX + INC EBX + JLE @@endLoop +@@loop: + PUSH [EDX+ECX*4].Integer + DEC ECX + JNS @@loop +@@endLoop: + PUSH EBX + PUSH EAX + MOV EAX,[EBP+8] + PUSH EAX + CALL _VarArrayGet + LEA ESP,[ESP+EBX*4+3*4] + + POP EBX +end; + +procedure VarArrayPut(var A: Variant; const Value: Variant; const Indices: array of Integer); +asm + { ->EAX Pointer to A } + { EDX Pointer to Value } + { ECX Pointer to Indices } + { [EBP+8] High bound of Indices } + + PUSH EBX + + MOV EBX,[EBP+8] + + TEST EBX,EBX + JS @@endLoop +@@loop: + PUSH [ECX+EBX*4].Integer + DEC EBX + JNS @@loop +@@endLoop: + MOV EBX,[EBP+8] + INC EBX + PUSH EBX + PUSH EDX + PUSH EAX + CALL _VarArrayPut + LEA ESP,[ESP+EBX*4+3*4] + + POP EBX +end; + + +{ 64-bit Integer helper routines - recycling C++ RTL routines } + +procedure __llmul; external; {$L _LL } +procedure __lldiv; external; { _LL } +procedure __llmod; external; { _LL } +procedure __llmulo; external; { _LL (overflow version) } +procedure __lldivo; external; { _LL (overflow version) } +procedure __llmodo; external; { _LL (overflow version) } +procedure __llshl; external; { _LL } +procedure __llushr; external; { _LL } +procedure __llumod; external; { _LL } +procedure __lludiv; external; { _LL } + +function _StrInt64(val: Int64; width: Integer): ShortString; +var + d: array[0..31] of Char; { need 19 digits and a sign } + i, k: Integer; + sign: Boolean; + spaces: Integer; +begin + { Produce an ASCII representation of the number in reverse order } + i := 0; + sign := val < 0; + repeat + d[i] := Chr( Abs(val mod 10) + Ord('0') ); + Inc(i); + val := val div 10; + until val = 0; + if sign then + begin + d[i] := '-'; + Inc(i); + end; + + { Fill the Result with the appropriate number of blanks } + if width > 255 then + width := 255; + k := 1; + spaces := width - i; + while k <= spaces do + begin + Result[k] := ' '; + Inc(k); + end; + + { Fill the Result with the number } + while i > 0 do + begin + Dec(i); + Result[k] := d[i]; + Inc(k); + end; + + { Result is k-1 characters long } + SetLength(Result, k-1); + +end; + +function _Str0Int64(val: Int64): ShortString; +begin + Result := _StrInt64(val, 0); +end; + +procedure _WriteInt64; +asm +{ PROCEDURE _WriteInt64( VAR t: Text; val: Int64; with: Longint); } +{ ->EAX Pointer to file record } +{ [ESP+4] Value } +{ EDX Field width } + + SUB ESP,32 { VAR s: String[31]; } + + PUSH EAX + PUSH EDX + + PUSH dword ptr [ESP+8+32+8] { Str( val : 0, s ); } + PUSH dword ptr [ESP+8+32+8] + XOR EAX,EAX + LEA EDX,[ESP+8+8] + CALL _StrInt64 + + POP ECX + POP EAX + + MOV EDX,ESP { Write( t, s : width );} + CALL _WriteString + + ADD ESP,32 + RET 8 +end; + +procedure _Write0Int64; +asm +{ PROCEDURE _Write0Long( VAR t: Text; val: Longint); } +{ ->EAX Pointer to file record } +{ EDX Value } + XOR EDX,EDX + JMP _WriteInt64 +end; + +procedure _ReadInt64; external; {$L ReadInt64 } + +function _ValInt64(const s: AnsiString; var code: Integer): Int64; +var + i: Integer; + dig: Integer; + sign: Boolean; + empty: Boolean; +begin + i := 1; + dig := 0; + Result := 0; + if s = '' then + begin + code := i; + exit; + end; + while s[i] = ' ' do + Inc(i); + sign := False; + if s[i] = '-' then + begin + sign := True; + Inc(i); + end + else if s[i] = '+' then + Inc(i); + empty := True; + if (s[i] = '$') or (s[i] = '0') and (Upcase(s[i+1]) = 'X') then + begin + if s[i] = '0' then + Inc(i); + Inc(i); + while True do + begin + case s[i] of + '0'..'9': dig := Ord(s[i]) - Ord('0'); + 'A'..'F': dig := Ord(s[i]) - (Ord('A') - 10); + 'a'..'f': dig := Ord(s[i]) - (Ord('a') - 10); + else + break; + end; + if (Result < 0) or (Result > $0FFFFFFFFFFFFFFF) then + break; + Result := Result shl 4 + dig; + Inc(i); + empty := False; + end; + if sign then + Result := - Result; + end + else + begin + while True do + begin + case s[i] of + '0'..'9': dig := Ord(s[i]) - Ord('0'); + else + break; + end; + if (Result < 0) or (Result > $7FFFFFFFFFFFFFFF div 10) then + break; + Result := Result*10 + dig; + Inc(i); + empty := False; + end; + if sign then + Result := - Result; + if (Result <> 0) and (sign <> (Result < 0)) then + Dec(i); + end; + if (s[i] <> #0) or empty then + code := i + else + code := 0; +end; + +procedure _DynArrayLength; +asm +{ FUNCTION _DynArrayLength(const a: array of ...): Longint; } +{ ->EAX Pointer to array or nil } +{ <-EAX High bound of array + 1 or 0 } + TEST EAX,EAX + JZ @@skip + MOV EAX,[EAX-4] +@@skip: +end; + +procedure _DynArrayHigh; +asm +{ FUNCTION _DynArrayHigh(const a: array of ...): Longint; } +{ ->EAX Pointer to array or nil } +{ <-EAX High bound of array or -1 } + CALL _DynArrayLength + DEC EAX +end; + +type + PLongint = ^Longint; + PointerArray = array [0..512*1024*1024 -2] of Pointer; + PPointerArray = ^PointerArray; + PDynArrayTypeInfo = ^TDynArrayTypeInfo; + TDynArrayTypeInfo = packed record + kind: Byte; + name: string[0]; + elSize: Longint; + elType: ^PDynArrayTypeInfo; + varType: Integer; + end; + + +procedure CopyArray(dest, source, typeInfo: Pointer; cnt: Integer); +asm + PUSH dword ptr [EBP+8] + CALL _CopyArray +end; + +procedure FinalizeArray(p, typeInfo: Pointer; cnt: Integer); +asm + JMP _FinalizeArray +end; + +procedure DynArrayClear(var a: Pointer; typeInfo: Pointer); +asm + CALL _DynArrayClear +end; + +procedure DynArraySetLength(var a: Pointer; typeInfo: PDynArrayTypeInfo; dimCnt: Longint; lengthVec: PLongint); +var + i: Integer; + newLength, oldLength, minLength: Longint; + elSize: Longint; + neededSize: Longint; + p, pp: Pointer; +begin + p := a; + + // Fetch the new length of the array in this dimension, and the old length + newLength := PLongint(lengthVec)^; + if newLength <= 0 then + begin + if newLength < 0 then + Error(reRangeError); + DynArrayClear(a, typeInfo); + exit; + end; + + oldLength := 0; + if p <> nil then + begin + Dec(PLongint(p)); + oldLength := PLongint(p)^; + Dec(PLongint(p)); + end; + + // Calculate the needed size of the heap object + Inc(PChar(typeInfo), Length(typeInfo.name)); + elSize := typeInfo.elSize; + if typeInfo.elType <> nil then + typeInfo := typeInfo.elType^ + else + typeInfo := nil; + neededSize := newLength*elSize; + if neededSize div newLength <> elSize then + Error(reRangeError); + Inc(neededSize, Sizeof(Longint)*2); + + // If the heap object isn't shared (ref count = 1), just resize it. Otherwise, we make a copy + if (p = nil) or (PLongint(p)^ = 1) then + begin + pp := p; + if (newLength < oldLength) and (typeInfo <> nil) then + FinalizeArray(PChar(p) + Sizeof(Longint)*2 + newLength*elSize, typeInfo, oldLength - newLength); + ReallocMem(pp, neededSize); + p := pp; + end + else + begin + Dec(PLongint(p)^); + GetMem(p, neededSize); + minLength := oldLength; + if minLength > newLength then + minLength := newLength; + if typeInfo <> nil then + begin + FillChar((PChar(p) + Sizeof(Longint)*2)^, minLength*elSize, 0); + CopyArray(PChar(p) + Sizeof(Longint)*2, a, typeInfo, minLength) + end + else + Move(PChar(a)^, (PChar(p) + Sizeof(Longint)*2)^, minLength*elSize); + end; + + // The heap object will now have a ref count of 1 and the new length + PLongint(p)^ := 1; + Inc(PLongint(p)); + PLongint(p)^ := newLength; + Inc(PLongint(p)); + + // Set the new memory to all zero bits + FillChar((PChar(p) + elSize * oldLength)^, elSize * (newLength - oldLength), 0); + + // Take care of the inner dimensions, if any + if dimCnt > 1 then + begin + Inc(lengthVec); + Dec(dimCnt); + for i := 0 to newLength-1 do + DynArraySetLength(PPointerArray(p)[i], typeInfo, dimCnt, lengthVec); + end; + a := p; +end; + +procedure _DynArraySetLength; +asm +{ PROCEDURE _DynArraySetLength(var a: dynarray; typeInfo: PDynArrayTypeInfo; dimCnt: Longint; lengthVec: ^Longint) } +{ ->EAX Pointer to dynamic array (= pointer to pointer to heap object) } +{ EDX Pointer to type info for the dynamic array } +{ ECX number of dimensions } +{ [ESP+4] dimensions } + PUSH ESP + ADD dword ptr [ESP],4 + CALL DynArraySetLength +end; + +procedure _DynArrayCopy(a: Pointer; typeInfo: Pointer; var Result: Pointer); +begin + if a <> nil then + _DynArrayCopyRange(a, typeInfo, 0, PLongint(PChar(a)-4)^, Result); +end; + +procedure _DynArrayCopyRange(a: Pointer; typeInfo: Pointer; index, count : Integer; var Result: Pointer); +var + arrayLength: Integer; + elSize: Integer; + typeInf: PDynArrayTypeInfo; + p: Pointer; +begin + p := nil; + if a <> nil then + begin + typeInf := typeInfo; + + // Limit index and count to values within the array + if index < 0 then + begin + Inc(count, index); + index := 0; + end; + arrayLength := PLongint(PChar(a)-4)^; + if index > arrayLength then + index := arrayLength; + if count > arrayLength - index then + count := arrayLength - index; + if count < 0 then + count := 0; + + if count > 0 then + begin + // Figure out the size and type descriptor of the element type + Inc(PChar(typeInf), Length(typeInf.name)); + elSize := typeInf.elSize; + if typeInf.elType <> nil then + typeInf := typeInf.elType^ + else + typeInf := nil; + + // Allocate the amount of memory needed + GetMem(p, count*elSize + Sizeof(Longint)*2); + + // The reference count of the new array is 1, the length is count + PLongint(p)^ := 1; + Inc(PLongint(p)); + PLongint(p)^ := count; + Inc(PLongint(p)); + Inc(PChar(a), index*elSize); + + // If the element type needs destruction, we must copy each element, + // otherwise we can just copy the bits + if count > 0 then + begin + if typeInf <> nil then + begin + FillChar(p^, count*elSize, 0); + CopyArray(p, a, typeInf, count) + end + else + Move(a^, p^, count*elSize); + end; + end; + end; + DynArrayClear(Result, typeInfo); + Result := p; +end; + +procedure _DynArrayClear; +asm +{ ->EAX Pointer to dynamic array (Pointer to pointer to heap object } +{ EDX Pointer to type info } + + { Nothing to do if Pointer to heap object is nil } + MOV ECX,[EAX] + TEST ECX,ECX + JE @@exit + + { Set the variable to be finalized to nil } + MOV dword ptr [EAX],0 + + { Decrement ref count. Nothing to do if not zero now. } +{X LOCK} DEC dword ptr [ECX-8] + JNE @@exit + + { Save the source - we're supposed to return it } + PUSH EAX + MOV EAX,ECX + + { Fetch the type descriptor of the elements } + XOR ECX,ECX + MOV CL,[EDX].TDynArrayTypeInfo.name; + MOV EDX,[EDX+ECX].TDynArrayTypeInfo.elType; + + { If it's non-nil, finalize the elements } + TEST EDX,EDX + JE @@noFinalize + MOV ECX,[EAX-4] + TEST ECX,ECX + JE @@noFinalize + MOV EDX,[EDX] + CALL _FinalizeArray +@@noFinalize: + { Now deallocate the array } + SUB EAX,8 + CALL _FreeMem + POP EAX +@@exit: +end; + + +procedure _DynArrayAsg; +asm +{ ->EAX Pointer to destination (pointer to pointer to heap object } +{ EDX source (pointer to heap object } +{ ECX Pointer to rtti describing dynamic array } + + PUSH EBX + MOV EBX,[EAX] + + { Increment ref count of source if non-nil } + + TEST EDX,EDX + JE @@skipInc +{X LOCK} INC dword ptr [EDX-8] +@@skipInc: + { Dec ref count of destination - if it becomes 0, clear dest } + TEST EBX,EBX + JE @@skipClear +{X LOCK} DEC dword ptr[EBX-8] + JNZ @@skipClear + PUSH EAX + PUSH EDX + MOV EDX,ECX + INC dword ptr[EBX-8] + CALL _DynArrayClear + POP EDX + POP EAX +@@skipClear: + { Finally store source into destination } + MOV [EAX],EDX + + POP EBX +end; + +procedure _DynArrayAddRef; +asm +{ ->EAX Pointer to heap object } + TEST EAX,EAX + JE @@exit +{X LOCK} INC dword ptr [EAX-8] +@@exit: +end; + + +function DynArrayIndex(const P: Pointer; const Indices: array of Integer; const TypInfo: Pointer): Pointer; +asm + { ->EAX P } + { EDX Pointer to Indices } + { ECX High bound of Indices } + { [EBP+8] TypInfo } + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV ESI,EDX + MOV EDI,[EBP+8] + MOV EBP,EAX + + XOR EBX,EBX { for i := 0 to High(Indices) do } + TEST ECX,ECX + JGE @@start +@@loop: + MOV EBP,[EBP] +@@start: + XOR EAX,EAX + MOV AL,[EDI].TDynArrayTypeInfo.name + ADD EDI,EAX + MOV EAX,[ESI+EBX*4] { P := P + Indices[i]*TypInfo.elSize } + MUL [EDI].TDynArrayTypeInfo.elSize + MOV EDI,[EDI].TDynArrayTypeInfo.elType + TEST EDI,EDI + JE @@skip + MOV EDI,[EDI] +@@skip: + ADD EBP,EAX + INC EBX + CMP EBX,ECX + JLE @@loop + +@@loopEnd: + + MOV EAX,EBP + + POP EBP + POP EDI + POP ESI + POP EBX +end; + + + +type + TBoundArray = array of Integer; + PPointer = ^Pointer; + + +{ Returns the DynArrayTypeInfo of the Element Type of the specified DynArrayTypeInfo } +function DynArrayElTypeInfo(typeInfo: PDynArrayTypeInfo): PDynArrayTypeInfo; +begin + Result := nil; + if typeInfo <> nil then + begin + Inc(PChar(typeInfo), Length(typeInfo.name)); + if typeInfo.elType <> nil then + Result := typeInfo.elType^; + end; +end; + +{ Returns # of dimemsions of the DynArray described by the specified DynArrayTypeInfo} +function DynArrayDim(typeInfo: PDynArrayTypeInfo): Integer; +begin + Result := 0; + while (typeInfo <> nil) and (typeInfo.kind = tkDynArray) do + begin + Inc(Result); + typeInfo := DynArrayElTypeInfo(typeInfo); + end; +end; + +{ Returns size of the Dynamic Array} +function DynArraySize(a: Pointer): Integer; +asm + TEST EAX, EAX + JZ @@exit + MOV EAX, [EAX-4] +@@exit: +end; + +// Returns whether array is rectangular +function IsDynArrayRectangular(const DynArray: Pointer; typeInfo: PDynArrayTypeInfo): Boolean; +var + Dim, I, J, Size, SubSize: Integer; + P: Pointer; +begin + // Assume we have a rectangular array + Result := True; + + P := DynArray; + Dim := DynArrayDim(typeInfo); + + {NOTE: Start at 1. Don't need to test the first dimension - it's rectangular by definition} + for I := 1 to dim-1 do + begin + if P <> nil then + begin + { Get size of this dimension } + Size := DynArraySize(P); + + { Get Size of first sub. dimension } + SubSize := DynArraySize(PPointerArray(P)[0]); + + { Walk through every dimension making sure they all have the same size} + for J := 1 to Size-1 do + if DynArraySize(PPointerArray(P)[J]) <> SubSize then + begin + Result := False; + Exit; + end; + + { Point to next dimension} + P := PPointerArray(P)[0]; + end; + end; +end; + +// Returns Bounds of a DynamicArray in a format usable for creating a Variant. +// i.e. The format of the bounds returns contains pairs of lo and hi bounds where +// lo is always 0, and hi is the size dimension of the array-1. +function DynArrayVariantBounds(const DynArray: Pointer; typeInfo: PDynArrayTypeInfo): TBoundArray; +var + Dim, I: Integer; + P: Pointer; +begin + P := DynArray; + + Dim := DynArrayDim(typeInfo); + SetLength(Result, Dim*2); + + I := 0; + while I < dim*2 do + begin + Result[I] := 0; // Always use 0 as low-bound in low/high pair + Inc(I); + if P <> nil then + begin + Result[I] := DynArraySize(P)-1; // Adjust for 0-base low-bound + P := PPointerArray(p)[0]; // Assume rectangular arrays + end; + Inc(I); + end; +end; + +// Returns Bounds of Dynamic array as an array of integer containing the 'high' of each dimension +function DynArrayBounds(const DynArray: Pointer; typeInfo: PDynArrayTypeInfo): TBoundArray; +var + Dim, I: Integer; + P: Pointer; +begin + P := DynArray; + + Dim := DynArrayDim(typeInfo); + SetLength(Result, Dim); + + for I := 0 to dim-1 do + if P <> nil then + begin + Result[I] := DynArraySize(P)-1; + P := PPointerArray(P)[0]; // Assume rectangular arrays + end; +end; + +// The dynamicArrayTypeInformation contains the VariantType of the element type +// when the kind == tkDynArray. This function returns that VariantType. +function DynArrayVarType(typeInfo: PDynArrayTypeInfo): Integer; +begin + Result := varNull; + if (typeInfo <> nil) and (typeInfo.Kind = tkDynArray) then + begin + Inc(PChar(typeInfo), Length(typeInfo.name)); + Result := typeInfo.varType; + end; + + { NOTE: DECL.H and SYSTEM.PAS have different values for varString } + if Result = $48 then + Result := varString; +end; + +type + IntegerArray = array[0..$effffff] of Integer; + PIntegerArray = ^IntegerArray; + PSmallInt = ^SmallInt; + PInteger = ^Integer; + PSingle = ^Single; + PDouble = ^Double; + PDate = ^Double; + PDispatch = ^IDispatch; + PPDispatch = ^PDispatch; + PError = ^LongWord; + PWordBool = ^WordBool; + PUnknown = ^IUnknown; + PPUnknown = ^PUnknown; + PByte = ^Byte; + PPWideChar = ^PWideChar; + +{ Decrements to next lower index - Returns True if successful } +{ Indices: Indices to be decremented } +{ Bounds : High bounds of each dimension } +function DecIndices(var Indices: TBoundArray; const Bounds: TBoundArray): Boolean; +var + I, J: Integer; +begin + { Find out if we're done: all at zeroes } + Result := False; + for I := Low(Indices) to High(Indices) do + if Indices[I] <> 0 then + begin + Result := True; + break; + end; + if not Result then + Exit; + + { Two arrays must be of same length } + Assert(Length(Indices) = Length(Bounds)); + + { Find index of item to tweak } + for I := High(Indices) downto Low(Bounds) do + begin + // If not reach zero, dec and bail out + if Indices[I] <> 0 then + begin + Dec(Indices[I]); + Exit; + end + else + begin + J := I; + while Indices[J] = 0 do + begin + // Restore high bound when we've reached zero on a particular dimension + Indices[J] := Bounds[J]; + // Move to higher dimension + Dec(J); + Assert(J >= 0); + end; + Dec(Indices[J]); + Exit; + end; + end; +end; + +// Copy Contents of Dynamic Array to Variant +// NOTE: The Dynamic array must be rectangular +// The Dynamic array must contain items whose type is Automation compatible +// In case of failure, the function returns with a Variant of type VT_EMPTY. +procedure DynArrayToVariant(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer); +var + VarBounds, Bounds, Indices: TBoundArray; + DAVarType, VVarType, DynDim: Integer; + PDAData: Pointer; + Value: Variant; +begin + VarBounds := nil; + Bounds := nil; + { This resets the Variant to VT_EMPTY - flag which is used to determine whether the } + { the cast to Variant succeeded or not } + VarClear(V); + + { Get variantType code from DynArrayTypeInfo } + DAVarType := DynArrayVarType(PDynArrayTypeInfo(TypeInfo)); + + { Validate the Variant Type } + if ((DAVarType > varNull) and (DAVarType <= varByte)) or (DAVarType = varString) then + begin + {NOTE: Map varString to varOleStr for SafeArrayCreate call } + if DAVarType = varString then + VVarType := varOleStr + else + VVarType := DAVarType; + + { Get dimension of Dynamic Array } + DynDim := DynarrayDim(PDynArrayTypeInfo(TypeInfo)); + + { If more than one dimension, make sure we're dealing with a rectangular array } + if DynDim > 1 then + if not IsDynArrayRectangular(DynArray, PDynArrayTypeInfo(TypeInfo)) then + Exit; + + { Get Variant-style Bounds (lo/hi pair) of Dynamic Array } + VarBounds := DynArrayVariantBounds(DynArray, TypeInfo); + + { Get DynArray Bounds } + Bounds := DynArrayBounds(DynArray, TypeInfo); + Indices:= Copy(Bounds); + + { Create Variant of SAFEARRAY } + V := VarArrayCreate(VarBounds, VVarType); + Assert(VarArrayDimCount(V) = DynDim); + + repeat + PDAData := DynArrayIndex(DynArray, Indices, TypeInfo); + if PDAData <> nil then + begin + case DAVarType of + varSmallInt: Value := PSmallInt(PDAData)^; + varInteger: Value := PInteger(PDAData)^; + varSingle: value := PSingle(PDAData)^; + varDouble: value := PDouble(PDAData)^; + varCurrency: Value := PCurrency(PDAData)^; + varDate: Value := PDouble(PDAData)^; + varOleStr: Value := PWideString(PDAData)^; + varDispatch: Value := PDispatch(PDAData)^; + varError: Value := PError(PDAData)^; + varBoolean: Value := PWordBool(PDAData)^; + varVariant: Value := PVariant(PDAData)^; + varUnknown: Value := PUnknown(PDAData)^; + varByte: Value := PByte(PDAData)^; + varString: Value := PString(PDAData)^; + else + VarClear(Value); + end; { case } + VarArrayPut(V, Value, Indices); + end; + until not DecIndices(Indices, Bounds); + end; +end; + +// Copies data from the Variant to the DynamicArray +procedure DynArrayFromVariant(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer); +var + DADimCount, VDimCount : Integer; + DAVarType, I: Integer; + lengthVec: PLongInt; + Bounds, Indices: TBoundArray; + Value: Variant; + PDAData: Pointer; +begin + { Get Variant information } + VDimCount:= VarArrayDimCount(V); + + { Allocate vector for lengths } + GetMem(lengthVec, VDimCount * sizeof(Integer)); + + { Initialize lengths - NOTE: VarArrayxxxxBound are 1-based.} + for I := 0 to VDimCount-1 do + PIntegerArray(lengthVec)[I]:= (VarArrayHighBound(V, I+1) - VarArrayLowBound(V, I+1)) + 1; + + { Set Length of DynArray } + DynArraySetLength(DynArray, PDynArrayTypeInfo(TypeInfo), VDimCount, lengthVec); + + { Get DynArray information } + DADimCount:= DynArrayDim(PDynArrayTypeInfo(TypeInfo)); + DAVarType := DynArrayVarType(PDynArrayTypeInfo(TypeInfo)); + Assert(VDimCount = DADimCount); + + { Get DynArray Bounds } + Bounds := DynArrayBounds(DynArray, TypeInfo); + Indices:= Copy(Bounds); + + { Copy data over} + repeat + Value := VarArrayGet(V, Indices); + PDAData := DynArrayIndex(DynArray, Indices, TypeInfo); + case DAVarType of + varSmallInt: PSmallInt(PDAData)^ := Value; + varInteger: PInteger(PDAData)^ := Value; + varSingle: PSingle(PDAData)^ := Value; + varDouble: PDouble(PDAData)^ := Value; + varCurrency: PCurrency(PDAData)^ := Value; + varDate: PDouble(PDAData)^ := Value; + varOleStr: PWideString(PDAData)^ := Value; + varDispatch: PDispatch(PDAData)^ := Value; + varError: PError(PDAData)^ := Value; + varBoolean: PWordBool(PDAData)^ := Value; + varVariant: PVariant(PDAData)^ := Value; + varUnknown: PUnknown(PDAData)^ := value; + varByte: PByte(PDAData)^ := Value; + varString: PString(PDAData)^ := Value; + end; { case } + until not DecIndices(Indices, Bounds); + + { Free vector of lengths } + FreeMem(lengthVec); +end; + + + +{ Package/Module registration/unregistration } + +const + LOCALE_SABBREVLANGNAME = $00000003; { abbreviated language name } + LOAD_LIBRARY_AS_DATAFILE = 2; + HKEY_CURRENT_USER = $80000001; + KEY_ALL_ACCESS = $000F003F; + + OldLocaleOverrideKey = 'Software\Borland\Delphi\Locales'; // do not localize + NewLocaleOverrideKey = 'Software\Borland\Locales'; // do not localize + +function FindHInstance(Address: Pointer): LongWord; +var + MemInfo: TMemInfo; +begin + VirtualQuery(Address, MemInfo, SizeOf(MemInfo)); + if MemInfo.State = $1000{MEM_COMMIT} then + Result := Longint(MemInfo.AllocationBase) + else Result := 0; +end; + +function FindClassHInstance(ClassType: TClass): LongWord; +begin + Result := FindHInstance(Pointer(ClassType)); +end; + +function FindResourceHInstance(Instance: LongWord): LongWord; +var + CurModule: PLibModule; +begin + CurModule := LibModuleList; + while CurModule <> nil do + begin + if (Instance = CurModule.Instance) or + (Instance = CurModule.CodeInstance) or + (Instance = CurModule.DataInstance) then + begin + Result := CurModule.ResInstance; + Exit; + end; + CurModule := CurModule.Next; + end; + Result := Instance; +end; + +function LoadResourceModule(ModuleName: PChar): LongWord; +var + FileName: array[0..260] of Char; + Key: LongWord; + LocaleName, LocaleOverride: array[0..4] of Char; + Size: Integer; + P: PChar; + + function FindBS(Current: PChar): PChar; + begin + Result := Current; + while (Result^ <> #0) and (Result^ <> '\') do + Result := CharNext(Result); + end; + + function ToLongPath(AFileName: PChar): PChar; + var + CurrBS, NextBS: PChar; + Handle, L: Integer; + FindData: TWin32FindData; + Buffer: array[0..260] of Char; + GetLongPathName: function (ShortPathName: PChar; LongPathName: PChar; + cchBuffer: Integer): Integer stdcall; + begin + Result := AFileName; + Handle := GetModuleHandle(kernel); + if Handle <> 0 then + begin + @GetLongPathName := GetProcAddress(Handle, 'GetLongPathNameA'); + if Assigned(GetLongPathName) and + (GetLongPathName(AFileName, Buffer, SizeOf(Buffer)) <> 0) then + begin + lstrcpy(AFileName, Buffer); + Exit; + end; + end; + + if AFileName[0] = '\' then + begin + if AFileName[1] <> '\' then Exit; + CurrBS := FindBS(AFileName + 2); // skip server name + if CurrBS^ = #0 then Exit; + CurrBS := FindBS(CurrBS + 1); // skip share name + if CurrBS^ = #0 then Exit; + end else + CurrBS := AFileName + 2; // skip drive name + + L := CurrBS - AFileName; + lstrcpyn(Buffer, AFileName, L + 1); + while CurrBS^ <> #0 do + begin + NextBS := FindBS(CurrBS + 1); + if L + (NextBS - CurrBS) + 1 > SizeOf(Buffer) then Exit; + lstrcpyn(Buffer + L, CurrBS, (NextBS - CurrBS) + 1); + + Handle := FindFirstFile(Buffer, FindData); + if (Handle = -1) then Exit; + FindClose(Handle); + + if L + 1 + lstrlen(FindData.cFileName) + 1 > SizeOf(Buffer) then Exit; + Buffer[L] := '\'; + lstrcpy(Buffer + L + 1, FindData.cFileName); + Inc(L, lstrlen(FindData.cFileName) + 1); + CurrBS := NextBS; + end; + lstrcpy(AFileName, Buffer); + end; + +begin + GetModuleFileName(0, FileName, SizeOf(FileName)); // Get host appliation name + LocaleOverride[0] := #0; + if (RegOpenKeyEx(HKEY_CURRENT_USER, NewLocaleOverrideKey, 0, KEY_ALL_ACCESS, Key) = 0) or + (RegOpenKeyEx(HKEY_CURRENT_USER, OldLocaleOverrideKey, 0, KEY_ALL_ACCESS, Key) = 0) then + try + Size := SizeOf(LocaleOverride); + if RegQueryValueEx(Key, ToLongPath(FileName), nil, nil, LocaleOverride, @Size) <> 0 then + RegQueryValueEx(Key, '', nil, nil, LocaleOverride, @Size); + finally + RegCloseKey(Key); + end; + lstrcpy(FileName, ModuleName); + GetLocaleInfo(GetThreadLocale, LOCALE_SABBREVLANGNAME, LocaleName, SizeOf(LocaleName)); + Result := 0; + if (FileName[0] <> #0) and ((LocaleName[0] <> #0) or (LocaleOverride[0] <> #0)) then + begin + P := PChar(@FileName) + lstrlen(FileName); + while (P^ <> '.') and (P <> @FileName) do Dec(P); + if P <> @FileName then + begin + Inc(P); + // First look for a locale registry override + if LocaleOverride[0] <> #0 then + begin + lstrcpy(P, LocaleOverride); + Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE); + end; + if (Result = 0) and (LocaleName[0] <> #0) then + begin + // Then look for a potential language/country translation + lstrcpy(P, LocaleName); + Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE); + if Result = 0 then + begin + // Finally look for a language only translation + LocaleName[2] := #0; + lstrcpy(P, LocaleName); + Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE); + end; + end; + end; + end; +end; + +procedure EnumModules(Func: TEnumModuleFunc; Data: Pointer); assembler; +begin + EnumModules(TEnumModuleFuncLW(Func), Data); +end; + +procedure EnumResourceModules(Func: TEnumModuleFunc; Data: Pointer); +begin + EnumResourceModules(TEnumModuleFuncLW(Func), Data); +end; + +procedure EnumModules(Func: TEnumModuleFuncLW; Data: Pointer); +var + CurModule: PLibModule; +begin + CurModule := LibModuleList; + while CurModule <> nil do + begin + if not Func(CurModule.Instance, Data) then Exit; + CurModule := CurModule.Next; + end; +end; + +procedure EnumResourceModules(Func: TEnumModuleFuncLW; Data: Pointer); +var + CurModule: PLibModule; +begin + CurModule := LibModuleList; + while CurModule <> nil do + begin + if not Func(CurModule.ResInstance, Data) then Exit; + CurModule := CurModule.Next; + end; +end; + +procedure AddModuleUnloadProc(Proc: TModuleUnloadProc); +begin + AddModuleUnloadProc(TModuleUnloadProcLW(Proc)); +end; + +procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProc); +begin + RemoveModuleUnloadProc(TModuleUnloadProcLW(Proc)); +end; + +procedure AddModuleUnloadProc(Proc: TModuleUnloadProcLW); +var + P: PModuleUnloadRec; +begin + New(P); + P.Next := ModuleUnloadList; + @P.Proc := @Proc; + ModuleUnloadList := P; +end; + +procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProcLW); +var + P, C: PModuleUnloadRec; +begin + P := ModuleUnloadList; + if (P <> nil) and (@P.Proc = @Proc) then + begin + ModuleUnloadList := ModuleUnloadList.Next; + Dispose(P); + end else + begin + C := P; + while C <> nil do + begin + if (C.Next <> nil) and (@C.Next.Proc = @Proc) then + begin + P := C.Next; + C.Next := C.Next.Next; + Dispose(P); + Break; + end; + C := C.Next; + end; + end; +end; + +procedure NotifyModuleUnload(HInstance: LongWord); +var + P: PModuleUnloadRec; +begin + P := ModuleUnloadList; + while P <> nil do + begin + try + P.Proc(HInstance); + except + // Make sure it doesn't stop notifications + end; + P := P.Next; + end; +end; + +procedure RegisterModule(LibModule: PLibModule); +begin + LibModule.Next := LibModuleList; + LibModuleList := LibModule; +end; + +{X- procedure UnregisterModule(LibModule: PLibModule); -renamed } +procedure UnRegisterModuleSafely( LibModule: PLibModule ); +var + CurModule: PLibModule; +begin + try + NotifyModuleUnload(LibModule.Instance); + finally + if LibModule = LibModuleList then + LibModuleList := LibModule.Next + else + begin + CurModule := LibModuleList; + while CurModule <> nil do + begin + if CurModule.Next = LibModule then + begin + CurModule.Next := LibModule.Next; + Break; + end; + CurModule := CurModule.Next; + end; + end; + end; +end; + +{X+} // "Light" version of UnRegisterModule - without using of try-except +procedure UnRegisterModuleLight( LibModule: PLibModule ); +var + P: PModuleUnloadRec; +begin + P := ModuleUnloadList; + while P <> nil do + begin + P.Proc(LibModule.Instance); + P := P.Next; + end; +end; +{X-} + +{ ResString support function } + +function LoadResString(ResStringRec: PResStringRec): string; +var + Buffer: array[0..1023] of Char; +begin + if ResStringRec <> nil then + if ResStringRec.Identifier < 64*1024 then + SetString(Result, Buffer, LoadString(FindResourceHInstance(ResStringRec.Module^), + ResStringRec.Identifier, Buffer, SizeOf(Buffer))) + else + Result := PChar(ResStringRec.Identifier); +end; + +procedure _IntfClear(var Dest: IUnknown); +asm + MOV EDX,[EAX] + TEST EDX,EDX + JE @@1 + MOV DWORD PTR [EAX],0 + PUSH EAX + PUSH EDX + MOV EAX,[EDX] + CALL [EAX].vmtRelease.Pointer + POP EAX +@@1: +end; + +procedure _IntfCopy(var Dest: IUnknown; const Source: IUnknown); +asm + MOV ECX,[EAX] { save dest } + MOV [EAX],EDX { assign dest } + TEST EDX,EDX { need to addref source before releasing dest } + JE @@1 { to make self assignment (I := I) work right } + PUSH ECX + PUSH EDX + MOV EAX,[EDX] + CALL [EAX].vmtAddRef.Pointer + POP ECX +@@1: TEST ECX,ECX + JE @@2 + PUSH ECX + MOV EAX,[ECX] + CALL [EAX].vmtRelease.Pointer +@@2: +end; + +procedure _IntfCast(var Dest: IUnknown; const Source: IUnknown; const IID: TGUID); +asm + TEST EDX,EDX + JE _IntfClear + PUSH EAX + PUSH ECX + PUSH EDX + MOV ECX,[EAX] + TEST ECX,ECX + JE @@1 + PUSH ECX + MOV EAX,[ECX] + CALL [EAX].vmtRelease.Pointer + MOV EDX,[ESP] +@@1: MOV EAX,[EDX] + CALL [EAX].vmtQueryInterface.Pointer + TEST EAX,EAX + JE @@2 + MOV AL,reIntfCastError + JMP Error +@@2: +end; + +procedure _IntfAddRef(const Dest: IUnknown); +begin + if Dest <> nil then Dest._AddRef; +end; + +procedure TInterfacedObject.AfterConstruction; +begin +// Release the constructor's implicit refcount + InterlockedDecrement(FRefCount); +end; + +procedure TInterfacedObject.BeforeDestruction; +begin + if RefCount <> 0 then Error(reInvalidPtr); +end; + +// Set an implicit refcount so that refcounting +// during construction won't destroy the object. +class function TInterfacedObject.NewInstance: TObject; +begin + Result := inherited NewInstance; + TInterfacedObject(Result).FRefCount := 1; +end; + +function TInterfacedObject.QueryInterface(const IID: TGUID; out Obj): HResult; +const + E_NOINTERFACE = HResult($80004002); +begin + if GetInterface(IID, Obj) then Result := 0 else Result := E_NOINTERFACE; +end; + +function TInterfacedObject._AddRef: Integer; +begin + Result := InterlockedIncrement(FRefCount); +end; + +function TInterfacedObject._Release: Integer; +begin + Result := InterlockedDecrement(FRefCount); + if Result = 0 then + Destroy; +end; + +procedure _CheckAutoResult; +asm + TEST EAX,EAX + JNS @@2 + MOV ECX,SafeCallErrorProc + TEST ECX,ECX + JE @@1 + MOV EDX,[ESP] + CALL ECX +@@1: MOV AL,reSafeCallError + JMP Error +@@2: +end; + + +procedure _IntfDispCall; +asm + JMP DispCallByIDProc +end; + + +procedure _IntfVarCall; +asm +end; + +function CompToDouble(acomp: Comp): Double; cdecl; +begin + Result := acomp; +end; + +procedure DoubleToComp(adouble: Double; var result: Comp); cdecl; +begin + result := adouble; +end; + +function CompToCurrency(acomp: Comp): Currency; cdecl; +begin + Result := acomp; +end; + +procedure CurrencyToComp(acurrency: Currency; var result: Comp); cdecl; +begin + result := acurrency +end; + +function GetMemory(Size: Integer): Pointer; cdecl; +begin + Result := {X- SysGetMem(Size); -replaced to use current memory manager} + MemoryManager.GetMem( Size ); +end; + +function FreeMemory(P: Pointer): Integer; cdecl; +begin + if P = nil then + Result := 0 + else + Result := {X- SysFreeMem(P); - replaced to use current memory manager} + MemoryManager.FreeMem( P ); +end; + +function ReallocMemory(P: Pointer; Size: Integer): Pointer; cdecl; +begin + {X- Result := SysReallocMem(P, Size); - replaced to use current memory manager} + Result := MemoryManager.ReallocMem( P, Size ); +end; + +function GetCurrentThreadId: DWORD; stdcall; external kernel name 'GetCurrentThreadId'; + +{X} // convert var CmdLine : PChar to a function: +{X} function CmdLine : PChar; +{X} begin +{X} Result := GetCommandLine; +{X} end; + +initialization + + {X- initialized by 0 anyway + ExitCode := 0; + ErrorAddr := nil; + + RandSeed := 0; + X+} + + {X- initialized statically + FileMode := 2; + + Test8086 := 2; + Test8087 := 3; + X+} + + {X- moved to SysVarnt.pas + + TVarData(Unassigned).VType := varEmpty; + TVarData(Null).VType := varNull; + TVarData(EmptyParam).VType := varError; + TVarData(EmptyParam).VError := $80020004; //DISP_E_PARAMNOTFOUND + + ClearAnyProc := @VarInvalidOp; + ChangeAnyProc := @VarCastError; + RefAnyProc := @VarInvalidOp; + + X+} + + {X- + if _isNECWindows then _FpuMaskInit; + FpuInit(); + X+} + + {X- to use Input/Output, call UseInputOutput (or include + following two lines into your code and call Close(Input), + Close(Output) at the end of execution). + _Assign( Input, '' ); + _Assign( Output, '' ); + X+} + +{X- CmdLine := GetCommandLine; converted to a function } +{X- CmdShow := GetCmdShow; converted to a function } + MainThreadID := GetCurrentThreadID; + +finalization + {X}if assigned( CloseInputOutput ) then + {X} CloseInputOutput; + {X- + Close(Input); + Close(Output); + X+} +{X UninitAllocator; - replaced with call to UninitMemoryManager handler. } + UninitMemoryManager; +end. diff --git a/System/D5/sysvarnt.pas b/System/D5/sysvarnt.pas new file mode 100644 index 0000000..f571120 --- /dev/null +++ b/System/D5/sysvarnt.pas @@ -0,0 +1,32 @@ +unit sysvarnt; +{X: this unit contains some definitions and initializations, needed to + support variants. To use variants, just place reference to sysvarnt + unit in your unit uses clause *first* } + +interface + +var + Unassigned: Variant; { Unassigned standard constant } + Null: Variant; { Null standard constant } + EmptyParam: OleVariant; { "Empty parameter" standard constant which can be + passed as an optional parameter on a dual interface. } + +implementation + +initialization + + VarAddRefProc := VariantAddRef; + VarClrProc := VariantClr; + + TVarData(Unassigned).VType := varEmpty; + TVarData(Null).VType := varNull; + TVarData(EmptyParam).VType := varError; + TVarData(EmptyParam).VError := $80020004; //DISP_E_PARAMNOTFOUND + + ClearAnyProc := @VarInvalidOp; + ChangeAnyProc := @VarCastError; + RefAnyProc := @VarInvalidOp; + +finalization + +end. diff --git a/System/D5/syswstr.pas b/System/D5/syswstr.pas new file mode 100644 index 0000000..ab8a677 --- /dev/null +++ b/System/D5/syswstr.pas @@ -0,0 +1,18 @@ +unit syswstr; +{X: this unit contains some definitions and initializations, needed to + support wide string variables. To use it, just place reference to syswstr + unit in your dpr/units uses clause *as first as possible* } + +interface + +implementation + +initialization + + WStrAddRefProc := WStrAddRef; + WStrClrProc := WStrClr; + WStrArrayClrProc := WStrArrayClr; + +finalization + +end. diff --git a/System/D7_ECM/SYSWSTR.PAS b/System/D7_ECM/SYSWSTR.PAS new file mode 100644 index 0000000..ab8a677 --- /dev/null +++ b/System/D7_ECM/SYSWSTR.PAS @@ -0,0 +1,18 @@ +unit syswstr; +{X: this unit contains some definitions and initializations, needed to + support wide string variables. To use it, just place reference to syswstr + unit in your dpr/units uses clause *as first as possible* } + +interface + +implementation + +initialization + + WStrAddRefProc := WStrAddRef; + WStrClrProc := WStrClr; + WStrArrayClrProc := WStrArrayClr; + +finalization + +end. diff --git a/System/D7_ECM/ShareMem.pas b/System/D7_ECM/ShareMem.pas new file mode 100644 index 0000000..714cbba --- /dev/null +++ b/System/D7_ECM/ShareMem.pas @@ -0,0 +1,148 @@ +{ *********************************************************************** } +{ } +{ Delphi / Kylix Cross-Platform Runtime Library } +{ } +{ Copyright (c) 1995-2001 Borland Software Corporation } +{ } +{ *********************************************************************** } + +unit ShareMem; + +interface + +{$IFDEF MEMORY_DIAG} +type + TBlockEnumProc = function (Block: Pointer): Boolean; +{$ENDIF} + +function SysGetMem(Size: Integer): Pointer; +function SysFreeMem(P: Pointer): Integer; +function SysReallocMem(P: Pointer; Size: Integer): Pointer; +function GetHeapStatus: THeapStatus; +function GetAllocMemCount: Integer; +function GetAllocMemSize: Integer; +procedure DumpBlocks; + +{$IFDEF MEMORY_DIAG} +function InitBlockMarking: Boolean; +function MarkBlocks: Integer; +function GetMarkedBlocks(MarkID: Integer; Proc: TBlockEnumProc): Boolean; +{$ENDIF} + +implementation + +{$IFDEF GLOBALALLOC} +uses Windows; +{$ENDIF} + +{$IFDEF MEMORY_DIAG} +type + TInitBlockMarking = function: Boolean; + TMarkBlocks = function: Integer; + TGetMarkedBlocks = function (MarkID: Integer; Proc: TBlockEnumProc): Boolean; + +var + MMHandle: Integer = 0; + SysInitBlockMarking: TInitBlockMarking = nil; + SysMarkBlocks: TMarkBlocks = nil; + SysGetMarkedBlocks: TGetMarkedBlocks = nil; +{$ENDIF} + +const + DelphiMM = 'borlndmm.dll'; + +function SysGetMem(Size: Integer): Pointer; external DelphiMM name '@Borlndmm@SysGetMem$qqri'; +function SysFreeMem(P: Pointer): Integer; external DelphiMM name '@Borlndmm@SysFreeMem$qqrpv'; +function SysReallocMem(P: Pointer; Size: Integer): Pointer; external DelphiMM name '@Borlndmm@SysReallocMem$qqrpvi'; +function GetHeapStatus: THeapStatus; external DelphiMM; +function GetAllocMemCount: Integer; external DelphiMM; +function GetAllocMemSize: Integer; external DelphiMM; +procedure DumpBlocks; external DelphiMM; + +function GetModuleHandle(lpModuleName: PChar): Integer; stdcall; + external 'kernel32.dll' name 'GetModuleHandleA'; +function GetProcAddress(hModule: Integer; lpProcName: PChar): Pointer; stdcall; + external 'kernel32.dll' name 'GetProcAddress'; + +{$IFDEF MEMORY_DIAG} + +procedure InitMMHandle; +begin + if MMHandle = 0 then MMHandle := GetModuleHandle(DelphiMM); +end; + +function InitBlockMarking: Boolean; +begin + InitMMHandle; + if @SysInitBlockMarking = nil then + @SysInitBlockMarking := GetProcAddress(MMHandle, 'InitBlockMarking'); + if @SysInitBlockMarking <> nil then + Result := SysInitBlockMarking + else Result := False; +end; + +function MarkBlocks: Integer; +begin + InitMMHandle; + if @SysMarkBlocks = nil then + @SysMarkBlocks := GetProcAddress(MMHandle, 'MarkBlocks'); + if @SysMarkBlocks <> nil then + Result := SysMarkBlocks + else Result := -1; +end; + +function GetMarkedBlocks(MarkID: Integer; Proc: TBlockEnumProc): Boolean; +begin + InitMMHandle; + if @SysGetMarkedBlocks = nil then + @SysGetMarkedBlocks := GetProcAddress(MMHandle, 'GetMarkedBlocks'); + if @SysGetMarkedBlocks <> nil then + Result := SysGetMarkedBlocks(MarkID, Proc) + else Result := False; +end; +{$ENDIF} + +{$IFDEF GLOBALALLOC} +function xSysGetMem(Size: Integer): Pointer; +begin + Result := GlobalAllocPtr(HeapAllocFlags, Size); +end; + +function xSysFreeMem(P: Pointer): Integer; +begin + Result := GlobalFreePtr(P); +end; + +function xSysReallocMem(P: Pointer; Size: Integer): Pointer; +begin + Result := GlobalReallocPtr(P, Size, 0); +end; +{$ENDIF} + + +procedure InitMemoryManager; +var + SharedMemoryManager: TMemoryManager; + MM: Integer; +begin + // force a static reference to borlndmm.dll, so we don't have to LoadLibrary + SharedMemoryManager.GetMem := SysGetMem; + + MM := GetModuleHandle(DelphiMM); +{$IFDEF GLOBALALLOC} + SharedMemoryManager.GetMem := xSysGetMem; + SharedMemoryManager.FreeMem := xSysFreeMem; + SharedMemoryManager.ReallocMem := xSysReallocMem; +{$ELSE} + SharedMemoryManager.GetMem := GetProcAddress(MM,'@Borlndmm@SysGetMem$qqri'); + SharedMemoryManager.FreeMem := GetProcAddress(MM,'@Borlndmm@SysFreeMem$qqrpv'); + SharedMemoryManager.ReallocMem := GetProcAddress(MM, '@Borlndmm@SysReallocMem$qqrpvi'); +{$ENDIF} + SetMemoryManager(SharedMemoryManager); +end; + +initialization + if not IsMemoryManagerSet then + InitMemoryManager; +end. + diff --git a/System/D7_ECM/SysConst.pas b/System/D7_ECM/SysConst.pas new file mode 100644 index 0000000..c0f6754 --- /dev/null +++ b/System/D7_ECM/SysConst.pas @@ -0,0 +1,184 @@ +{ *********************************************************************** } +{ } +{ Delphi / Kylix Cross-Platform Runtime Library } +{ } +{ Copyright (c) 1995, 2001 Borland Software Corporation } +{ } +{ *********************************************************************** } + +unit SysConst; + +interface + +resourcestring + SUnknown = ''; + SInvalidInteger = '''%s'' is not a valid integer value'; + SInvalidFloat = '''%s'' is not a valid floating point value'; + SInvalidCurrency = '''%s'' is not a valid currency value'; + SInvalidDate = '''%s'' is not a valid date'; + SInvalidTime = '''%s'' is not a valid time'; + SInvalidDateTime = '''%s'' is not a valid date and time'; + SInvalidDateTimeFloat = '''%g'' is not a valid date and time'; + SInvalidTimeStamp = '''%d.%d'' is not a valid timestamp'; + SInvalidGUID = '''%s'' is not a valid GUID value'; + SInvalidBoolean = '''%s'' is not a valid boolean value'; + STimeEncodeError = 'Invalid argument to time encode'; + SDateEncodeError = 'Invalid argument to date encode'; + SOutOfMemory = 'Out of memory'; + SInOutError = 'I/O error %d'; + SFileNotFound = 'File not found'; + SInvalidFilename = 'Invalid filename'; + STooManyOpenFiles = 'Too many open files'; + SAccessDenied = 'File access denied'; + SEndOfFile = 'Read beyond end of file'; + SDiskFull = 'Disk full'; + SInvalidInput = 'Invalid numeric input'; + SDivByZero = 'Division by zero'; + SRangeError = 'Range check error'; + SIntOverflow = 'Integer overflow'; + SInvalidOp = 'Invalid floating point operation'; + SZeroDivide = 'Floating point division by zero'; + SOverflow = 'Floating point overflow'; + SUnderflow = 'Floating point underflow'; + SInvalidPointer = 'Invalid pointer operation'; + SInvalidCast = 'Invalid class typecast'; +{$IFDEF MSWINDOWS} + SAccessViolationArg3 = 'Access violation at address %p. %s of address %p'; +{$ENDIF} +{$IFDEF LINUX} + SAccessViolationArg2 = 'Access violation at address %p, accessing address %p'; +{$ENDIF} + SAccessViolationNoArg = 'Access violation'; + SStackOverflow = 'Stack overflow'; + SControlC = 'Control-C hit'; + SQuit = 'Quit key hit'; + SPrivilege = 'Privileged instruction'; + SOperationAborted = 'Operation aborted'; + SException = 'Exception %s in module %s at %p.' + sLineBreak + '%s%s' + sLineBreak; + SExceptTitle = 'Application Error'; +{$IFDEF LINUX} + SSigactionFailed = 'sigaction call failed'; +{$ENDIF} + SInvalidFormat = 'Format ''%s'' invalid or incompatible with argument'; + SArgumentMissing = 'No argument for format ''%s'''; + SDispatchError = 'Variant method calls not supported'; + SReadAccess = 'Read'; + SWriteAccess = 'Write'; + SResultTooLong = 'Format result longer than 4096 characters'; + SFormatTooLong = 'Format string too long'; + + SVarArrayCreate = 'Error creating variant or safe array'; + SVarArrayBounds = 'Variant or safe array index out of bounds'; + SVarArrayLocked = 'Variant or safe array is locked'; + SVarArrayWithHResult = 'Unexpected variant or safe array error: %s%.8x'; + + SInvalidVarCast = 'Invalid variant type conversion'; + SInvalidVarOp = 'Invalid variant operation'; + SInvalidVarNullOp = 'Invalid NULL variant operation'; + SInvalidVarOpWithHResultWithPrefix = 'Invalid variant operation (%s%.8x)'#10'%s'; + SVarTypeRangeCheck1 = 'Range check error for variant of type (%s)'; + SVarTypeRangeCheck2 = 'Range check error while converting variant of type (%s) into type (%s)'; + SVarTypeOutOfRangeWithPrefix = 'Custom variant type (%s%.4x) is out of range'; + SVarTypeAlreadyUsedWithPrefix = 'Custom variant type (%s%.4x) already used by %s'; + SVarTypeNotUsableWithPrefix = 'Custom variant type (%s%.4x) is not usable'; + SVarTypeTooManyCustom = 'Too many custom variant types have been registered'; + + // the following are not used anymore + SVarNotArray = 'Variant is not an array' deprecated; // not used, use SVarInvalid instead + SVarTypeUnknown = 'Unknown custom variant type ($%.4x)' deprecated; // not used anymore + SVarTypeOutOfRange = 'Custom variant type ($%.4x) is out of range' deprecated; + SVarTypeAlreadyUsed = 'Custom variant type ($%.4x) already used by %s' deprecated; + SVarTypeNotUsable = 'Custom variant type ($%.4x) is not usable' deprecated; + SInvalidVarOpWithHResult = 'Invalid variant operation ($%.8x)' deprecated; + + SVarTypeCouldNotConvert = 'Could not convert variant of type (%s) into type (%s)'; + SVarTypeConvertOverflow = 'Overflow while converting variant of type (%s) into type (%s)'; + SVarOverflow = 'Variant overflow'; + SVarInvalid = 'Invalid argument'; + SVarBadType = 'Invalid variant type'; + SVarNotImplemented = 'Operation not supported'; + SVarOutOfMemory = 'Variant operation ran out memory'; + SVarUnexpected = 'Unexpected variant error'; + + SVarDataClearRecursing = 'Recursion while doing a VarDataClear'; + SVarDataCopyRecursing = 'Recursion while doing a VarDataCopy'; + SVarDataCopyNoIndRecursing = 'Recursion while doing a VarDataCopyNoInd'; + SVarDataInitRecursing = 'Recursion while doing a VarDataInit'; + SVarDataCastToRecursing = 'Recursion while doing a VarDataCastTo'; + SVarIsEmpty = 'Variant is empty'; + sUnknownFromType = 'Cannot convert from the specified type'; + sUnknownToType = 'Cannot convert to the specified type'; + SExternalException = 'External exception %x'; + SAssertionFailed = 'Assertion failed'; + SIntfCastError = 'Interface not supported'; + SSafecallException = 'Exception in safecall method'; + SAssertError = '%s (%s, line %d)'; + SAbstractError = 'Abstract Error'; + SModuleAccessViolation = 'Access violation at address %p in module ''%s''. %s of address %p'; + SCannotReadPackageInfo = 'Cannot access package information for package ''%s'''; + sErrorLoadingPackage = 'Can''t load package %s.'+sLineBreak+'%s'; + SInvalidPackageFile = 'Invalid package file ''%s'''; + SInvalidPackageHandle = 'Invalid package handle'; + SDuplicatePackageUnit = 'Cannot load package ''%s.'' It contains unit ''%s,''' + + 'which is also contained in package ''%s'''; + SOSError = 'System Error. Code: %d.'+sLineBreak+'%s'; + SUnkOSError = 'A call to an OS function failed'; +{$IFDEF MSWINDOWS} + SWin32Error = 'Win32 Error. Code: %d.'#10'%s' deprecated; // use SOSError + SUnkWin32Error = 'A Win32 API function failed' deprecated; // use SUnkOSError +{$ENDIF} + SNL = 'Application is not licensed to use this feature'; + + SShortMonthNameJan = 'Jan'; + SShortMonthNameFeb = 'Feb'; + SShortMonthNameMar = 'Mar'; + SShortMonthNameApr = 'Apr'; + SShortMonthNameMay = 'May'; + SShortMonthNameJun = 'Jun'; + SShortMonthNameJul = 'Jul'; + SShortMonthNameAug = 'Aug'; + SShortMonthNameSep = 'Sep'; + SShortMonthNameOct = 'Oct'; + SShortMonthNameNov = 'Nov'; + SShortMonthNameDec = 'Dec'; + + SLongMonthNameJan = 'January'; + SLongMonthNameFeb = 'February'; + SLongMonthNameMar = 'March'; + SLongMonthNameApr = 'April'; + SLongMonthNameMay = 'May'; + SLongMonthNameJun = 'June'; + SLongMonthNameJul = 'July'; + SLongMonthNameAug = 'August'; + SLongMonthNameSep = 'September'; + SLongMonthNameOct = 'October'; + SLongMonthNameNov = 'November'; + SLongMonthNameDec = 'December'; + + SShortDayNameSun = 'Sun'; + SShortDayNameMon = 'Mon'; + SShortDayNameTue = 'Tue'; + SShortDayNameWed = 'Wed'; + SShortDayNameThu = 'Thu'; + SShortDayNameFri = 'Fri'; + SShortDayNameSat = 'Sat'; + + SLongDayNameSun = 'Sunday'; + SLongDayNameMon = 'Monday'; + SLongDayNameTue = 'Tuesday'; + SLongDayNameWed = 'Wednesday'; + SLongDayNameThu = 'Thursday'; + SLongDayNameFri = 'Friday'; + SLongDayNameSat = 'Saturday'; + +{$IFDEF LINUX} + SEraEntries = ''; +{$ENDIF} + + SCannotCreateDir = 'Unable to create directory'; + SCodesetConversionError = 'Codeset conversion failure'; + +implementation + +end. + diff --git a/System/D7_ECM/SysInit.pas b/System/D7_ECM/SysInit.pas new file mode 100644 index 0000000..0ee3140 --- /dev/null +++ b/System/D7_ECM/SysInit.pas @@ -0,0 +1,858 @@ +{ *********************************************************************** } +{ } +{ Delphi / Kylix Cross-Platform Runtime Library } +{ System Initialization Unit } +{ } +{ Copyright (c) 1997-2002 Borland Software Corporation } +{ } +{ This file may be distributed and/or modified under the terms of the } +{ GNU General Public License version 2 as published by the Free Software } +{ Foundation and appearing at http://www.borland.com/kylix/gpl.html. } +{ } +{ Licensees holding a valid Borland No-Nonsense License for this } +{ Software may use this file in accordance with such license, which } +{ appears in the file license.txt that came with this software. } +{ } +{ *********************************************************************** } + +unit SysInit; + +interface + +{$H+,I-,R-,S-,O+,W-} +{$WARN SYMBOL_PLATFORM OFF} + +{X+} // if your app really need to localize resource, call: +{X+} procedure UseLocalizeResources; + +{$IFDEF LINUX} +const + ExeBaseAddress = Pointer($8048000) platform; +{$ENDIF} + +var + ModuleIsLib: Boolean; { True if this module is a dll (a library or a package) } + ModuleIsPackage: Boolean; { True if this module is a package } + ModuleIsCpp: Boolean; { True if this module is compiled using C++ Builder } + TlsIndex: Integer = -1; { Thread local storage index } + TlsLast: Byte; { Set by linker so its offset is last in TLS segment } + HInstance: LongWord; { Handle of this instance } + {$EXTERNALSYM HInstance} + (*$HPPEMIT 'namespace Sysinit' *) + (*$HPPEMIT '{' *) + (*$HPPEMIT 'extern PACKAGE HINSTANCE HInstance;' *) + (*$HPPEMIT '} /* namespace Sysinit */' *) + DllProc: TDLLProc; { Called whenever DLL entry point is called } + { DllProcEx passes the Reserved param provided by WinNT on DLL load & exit } + DllProcEx: TDLLProcEx absolute DllProc; + DataMark: Integer = 0; { Used to find the virtual base of DATA seg } + CoverageLibraryName: array [0..128] of char = '*'; { initialized by the linker! } +{$IFDEF ELF} + TypeImportsTable: array [0..0] of Pointer platform; { VMT and RTTI imports table for exes } + _GLOBAL_OFFSET_TABLE_: ARRAY [0..2] OF Cardinal platform; + (* _DYNAMIC: ARRAY [0..0] OF Elf32_Dyn; *) +{$IFDEF PC_MAPPED_EXCEPTIONS} + TextStartAdj: Byte platform; { See GetTextStart } + CodeSegSize: Byte platform; { See GetTextStart } +function GetTextStart : LongInt; platform; +{$ENDIF} +{$ENDIF} + +const + PtrToNil: Pointer = nil; // provides pointer to nil for compiler codegen + +function _GetTls: Pointer; +{$IFDEF LINUX} +procedure _InitLib(Context: PInitContext); +procedure _GetCallerEIP; +procedure _InitExe(InitTable: Pointer; Argc: Integer; Argp: Pointer); +procedure _start; cdecl; +function _ExitLib: Integer; cdecl; +function _InitPkg: LongBool; +{$ENDIF} +{$IFDEF MSWINDOWS} +procedure _InitLib; +procedure _InitExe(InitTable: Pointer); +function _InitPkg(Hinst: Integer; Reason: Integer; Resvd: Pointer): LongBool; stdcall; +{$ENDIF} +procedure _PackageLoad(const Table: PackageInfo); +procedure _PackageUnload(const Table: PackageInfo); + +{ Invoked by C++ startup code to allow initialization of VCL global vars } +procedure VclInit(isDLL, isPkg: Boolean; hInst: LongInt; isGui: Boolean); cdecl; +procedure VclExit; cdecl; + +{$IFDEF LINUX} +function GetThisModuleHandle: LongWord; +{$ENDIF} + +implementation + +{$IFDEF MSWINDOWS} +{X+}// *********************************************************************** +{X+}// Moved to System.pas {by A.Torgashin} +{X+}//const +{X+}// kernel = 'kernel32.dll'; +{X+}// +{X+}//function FreeLibrary(ModuleHandle: Longint): LongBool; stdcall; +{X+}// external kernel name 'FreeLibrary'; +{X+}// +{X+}//function GetModuleFileName(Module: Integer; Filename: PChar; Size: Integer): Integer; stdcall; +{X+}// external kernel name 'GetModuleFileNameA'; +{X+}// +{X+}//function GetModuleHandle(ModuleName: PChar): Integer; stdcall; +{X+}// external kernel name 'GetModuleHandleA'; +{X+}// +{X+}//function LocalAlloc(flags, size: Integer): Pointer; stdcall; +{X+}// external kernel name 'LocalAlloc'; +{X+}// +{X+}//function LocalFree(addr: Pointer): Pointer; stdcall; +{X+}// external kernel name 'LocalFree'; +{X+}// +{X+}//function TlsAlloc: Integer; stdcall; +{X+}// external kernel name 'TlsAlloc'; +{X+}// +{X+}//function TlsFree(TlsIndex: Integer): Boolean; stdcall; +{X+}// external kernel name 'TlsFree'; +{X+}// +{X+}//function TlsGetValue(TlsIndex: Integer): Pointer; stdcall; +{X+}// external kernel name 'TlsGetValue'; +{X+}// +{X+}//function TlsSetValue(TlsIndex: Integer; TlsValue: Pointer): Boolean; stdcall; +{X+}// external kernel name 'TlsSetValue'; +{X+}// +{X+}//function GetCommandLine: PChar; stdcall; +{X+}// external kernel name 'GetCommandLineA'; +{X+}// *********************************************************************** + +const + tlsArray = $2C; { offset of tls array from FS: } + LMEM_ZEROINIT = $40; + +function AllocTlsBuffer(Size: Integer): Pointer; +begin + Result := LocalAlloc(LMEM_ZEROINIT, Size); +end; + +var + tlsBuffer: Pointer; // RTM32 DOS support +{$ENDIF} + +{$IFDEF LINUX} + +{$IFDEF PIC} +function GetGOT: Pointer; export; +begin + asm + MOV Result,EBX + end; +end; +{$ENDIF} + +const + RTLD_LAZY = 1; + RTLD_NOW = 2; + RTLD_BINDING_MASK = RTLD_LAZY or RTLD_NOW; + RTLD_GLOBAL = $100; + RTLD_LOCAL = 0; + RTLD_NEXT = Pointer(-1); + RTLD_DEFAULT = nil; + +type + TDLInfo = record + Filename: PChar; + BaseAddress: Pointer; + NearestSymbolName: PChar; + NearestSymbolAddr: Pointer; + end; + +const + libcmodulename = 'libc.so.6'; + libdlmodulename = 'libdl.so.2'; + libpthreadmodulename = 'libpthread.so.0'; + tlsSizeName = '@Sysinit@tlsSize'; + +function malloc(Size: LongWord): Pointer; cdecl; + external libcmodulename name 'malloc'; + +procedure free(P: Pointer); cdecl; + external libcmodulename name 'free'; + +function dlopen(Filename: PChar; Flag: Integer): LongWord; cdecl; + external libdlmodulename name 'dlopen'; + +function dlerror: PChar; cdecl; + external libdlmodulename name 'dlerror'; + +function dlsym(Handle: LongWord; Symbol: PChar): Pointer; cdecl; + external libdlmodulename name 'dlsym'; + +function dlclose(Handle: LongWord): Integer; cdecl; + external libdlmodulename name 'dlclose'; + +function FreeLibrary(Handle: LongWord): Integer; cdecl; + external libdlmodulename name 'dlclose'; + +function dladdr(Address: Pointer; var Info: TDLInfo): Integer; cdecl; + external libdlmodulename name 'dladdr'; + +type + TInitOnceProc = procedure; cdecl; + TKeyValueDestructor = procedure(ValueInKey: Pointer); cdecl; + +function pthread_once(var InitOnceSemaphore: Integer; InitOnceProc: TInitOnceProc): Integer; cdecl; + external libpthreadmodulename name 'pthread_once'; + +function pthread_key_create(var Key: Integer; KeyValueDestructor: TKeyValueDestructor): Integer; cdecl; + external libpthreadmodulename name 'pthread_key_create'; + +function pthread_key_delete(Key: Integer): Integer; cdecl; + external libpthreadmodulename name 'pthread_key_delete'; + +function TlsGetValue(Key: Integer): Pointer; cdecl; + external libpthreadmodulename name 'pthread_getspecific'; + +function TlsSetValue(Key: Integer; Ptr: Pointer): Integer; cdecl; + external libpthreadmodulename name 'pthread_setspecific'; + +function AllocTlsBuffer(Size: Cardinal): Pointer; +begin + // The C++ rtl handles all tls in a C++ module + if ModuleIsCpp then + RunError(226); + + Result := malloc(Size); + if Result <> nil then + FillChar(Result^, Size, 0); +end; + +procedure FreeTLSBuffer(ValueInKey: Pointer); export cdecl; +begin + // The C++ rtl handles all tls in a C++ module + if ModuleIsCpp then + RunError(226); + free(ValueInKey); +end; + +procedure AllocTlsIndex; cdecl export; +begin + // guaranteed to reach here only once per process + // The C++ rtl handles all tls in a C++ module + if ModuleIsCpp then + RunError(226); + if pthread_key_create(TlsIndex, FreeTLSBuffer) <> 0 then + begin + TlsIndex := -1; + RunError(226); + end; +end; + +function GetThisModuleHandle: LongWord; +var + Info: TDLInfo; +begin + if (dladdr(@GetThisModuleHandle, Info) = 0) or (Info.BaseAddress = ExeBaseAddress) then + Info.FileName := nil; // if we're not in a library, we must be main exe + Result := LongWord(dlopen(Info.Filename, RTLD_LAZY)); + if Result <> 0 then + dlclose(Result); +end; + +var + InitOnceSemaphore: Integer; +{$ENDIF} + +var + Module: TLibModule = ( + Next: nil; + Instance: 0; + CodeInstance: 0; + DataInstance: 0; + ResInstance: 0; + Reserved: 0 +{$IFDEF LINUX} + ; InstanceVar: nil; + GOT: 0; + CodeSegStart: 0; + CodeSegEnd: 0 + ); +{$ELSE} + ); +{$ENDIF} + +function GetTlsSize: Integer; +{$IFDEF LINUX} +asm + MOV EAX, offset TlsLast +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +begin + Result := Integer(@TlsLast); +end; +{$ENDIF} + +procedure InitThreadTLS; +var + p: Pointer; + tlsSize: Integer; +begin + tlsSize := GetTlsSize; + if tlsSize = 0 then Exit; +{$IFDEF LINUX} + pthread_once(InitOnceSemaphore, AllocTlsIndex); +{$ENDIF} + if TlsIndex = -1 then RunError(226); + p := AllocTlsBuffer(tlsSize); + if p = nil then + RunError(226) + else + TlsSetValue(TlsIndex, p); +end; + +{$IFDEF MSWINDOWS} +procedure InitProcessTLS; +begin + if @TlsLast = nil then + Exit; + TlsIndex := TlsAlloc; + InitThreadTLS; + tlsBuffer := TlsGetValue(TlsIndex); // RTM32 DOS support +end; + +procedure ExitThreadTLS; +var + p: Pointer; +begin + if @TlsLast = nil then + Exit; + if TlsIndex <> -1 then begin + p := TlsGetValue(TlsIndex); + if p <> nil then + LocalFree(p); + end; +end; + +procedure ExitProcessTLS; +begin + if @TlsLast = nil then + Exit; + ExitThreadTLS; + if TlsIndex <> -1 then + TlsFree(TlsIndex); +end; +{$ENDIF} + +const + DLL_PROCESS_DETACH = 0; + DLL_PROCESS_ATTACH = 1; + DLL_THREAD_ATTACH = 2; + DLL_THREAD_DETACH = 3; + +function _GetTls: Pointer; +{$IFDEF LINUX} +begin + Result := TlsGetValue(TlsIndex); + if Result = nil then + begin + InitThreadTLS; + Result := TlsGetValue(TlsIndex); + end; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + MOV CL,ModuleIsLib + MOV EAX,TlsIndex + TEST CL,CL + JNE @@isDll + MOV EDX,FS:tlsArray + MOV EAX,[EDX+EAX*4] + RET + +@@initTls: + CALL InitThreadTLS + MOV EAX,TlsIndex + PUSH EAX + CALL TlsGetValue + TEST EAX,EAX + JE @@RTM32 + RET + +@@RTM32: + MOV EAX, tlsBuffer + RET + +@@isDll: + PUSH EAX + CALL TlsGetValue + TEST EAX,EAX + JE @@initTls +end; + +const + TlsProc: array [DLL_PROCESS_DETACH..DLL_THREAD_DETACH] of procedure = + (ExitProcessTLS,InitProcessTLS,InitThreadTLS,ExitThreadTLS); +{$ENDIF} + +{$IFDEF PC_MAPPED_EXCEPTIONS} +const + UNWINDFI_TOPOFSTACK = $BE00EF00; + +{ + The linker sets the value of TextStartAdj to be the delta between GetTextStart + and the start of the text segment. This allows us to get the pointer to the + start of the text segment in a position independent fashion. +} +function GetTextStart : LongInt; +asm + CALL @@label1 +@@label1: + POP EAX + SUB EAX, 5 + offset TextStartAdj +end; + +{ + The linker sets the value of CodeSegSize to the length of the text segment, + excluding the PC map. This allows us to get the pointer to the exception + information that we need at runtime, also in a position independent fashion. +} +function GetTextEnd : LongInt; +asm + CALL GetTextStart + ADD EAX, offset CodeSegSize +end; +{$ENDIF} + +procedure InitializeModule; +begin + RegisterModule(@Module); +end; + +{X+}procedure UseLocalizeResources; +{X+}var +{X+} FileName: array[0..260] of Char; +{X+}begin +{X+} GetModuleFileName(HInstance, FileName, SizeOf(FileName)); +{X+} Module.ResInstance := LoadResourceModule(FileName); +{X+} if Module.ResInstance = 0 then +{X+} Module.ResInstance := Module.Instance; +{X+}end; + +procedure UninitializeModule; +begin + UnregisterModule(@Module); + if (Module.ResInstance <> Module.Instance) and (Module.ResInstance <> 0) then + FreeLibrary(Module.ResInstance); +end; + +procedure VclInit(isDLL, isPkg: Boolean; hInst: LongInt; isGui: Boolean); cdecl; +begin + ModuleIsLib := isDLL; + ModuleIsPackage := isPkg; + IsLibrary := isDLL and not isPkg; + HInstance := hInst; + Module.Instance := hInst; + Module.CodeInstance := 0; + Module.DataInstance := 0; + ModuleIsCpp := True; +{$IFDEF LINUX} + if ModuleIsLib then + Module.InstanceVar := @HInstance; +{$IFDEF PIC} + Module.GOT := LongWord(GetGot); +{$ENDIF} + { Module.CodeSegStart, Module.CodeSegEnd not used: the C++ + rtl will feed the unwinder. } +{$ENDIF} + InitializeModule; + if not ModuleIsLib then + begin + Module.CodeInstance := FindHInstance(@VclInit); + Module.DataInstance := FindHInstance(@DataMark); +{$IFDEF MSWINDOWS} +{X}// CmdLine := GetCommandLine; + IsConsole := not isGui; +{$ENDIF} + end; +end; + +procedure VclExit; cdecl; +var + P: procedure; +begin + if not ModuleIsLib then + while ExitProc <> nil do + begin + @P := ExitProc; + ExitProc := nil; + P; + end; + UnInitializeModule; +end; + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure RegisterPCMap; +begin + SysRegisterIPLookup(GetTextStart, + GetTextEnd, + Pointer(GetTextEnd), + LongWord(@_Global_Offset_Table_)); +end; + +procedure UnregisterPCMap; +begin + SysUnregisterIPLookup(GetTextStart); +end; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function _InitPkg(Hinst: Longint; Reason: Integer; Resvd: Pointer): Longbool; stdcall; +begin + ModuleIsLib := True; + ModuleIsPackage := True; + Module.Instance := Hinst; + Module.CodeInstance := 0; + Module.DataInstance := 0; + HInstance := Hinst; + if @TlsLast <> nil then + TlsProc[Reason]; + if Reason = DLL_PROCESS_ATTACH then + InitializeModule + else if Reason = DLL_PROCESS_DETACH then + UninitializeModule; + _InitPkg := True; +end; +{$ENDIF} +{$IFDEF LINUX} +function _InitPkg: LongBool; +begin +{$IFDEF DEBUG_STARTUP} +asm +INT 3 +end; +{$ENDIF} +{$IFDEF PC_MAPPED_EXCEPTIONS} + RegisterPCMap; +{$ENDIF} + TlsIndex := -1; + ModuleIsLib := True; + ModuleIsPackage := True; + Module.Instance := GetThisModuleHandle; + Module.InstanceVar := @HInstance; + Module.CodeInstance := 0; + Module.DataInstance := 0; + Module.GOT := LongWord(@_Global_Offset_Table_); + Module.CodeSegStart := GetTextStart; + Module.CodeSegEnd := GetTextEnd; + HInstance := Module.Instance; + InitializeModule; + _InitPkg := True; +end; +{$ENDIF} + +procedure _PackageLoad(const Table: PackageInfo); +begin + System._PackageLoad(Table, @Module); +end; + +procedure _PackageUnload(const Table: PackageInfo); +begin + System._PackageUnload(Table, @Module); +end; + +{$IFDEF MSWINDOWS} +procedure _InitLib; +asm + { -> EAX Inittable } + { [EBP+8] Hinst } + { [EBP+12] Reason } + { [EBP+16] Resvd } + + MOV EDX,offset Module + CMP dword ptr [EBP+12],DLL_PROCESS_ATTACH + JNE @@notInit + + PUSH EAX + PUSH EDX + MOV ModuleIsLib,1 + MOV ECX,[EBP+8] + MOV HInstance,ECX + MOV [EDX].TLibModule.Instance,ECX + MOV [EDX].TLibModule.CodeInstance,0 + MOV [EDX].TLibModule.DataInstance,0 + CALL InitializeModule + POP EDX + POP EAX + +@@notInit: + PUSH DllProc + MOV ECX,offset TlsProc + CALL _StartLib +end; + +// ExitLib is the same as InitLib in Windows. + +{$ENDIF MSWINDOWS} +{$IFDEF LINUX} +procedure _InitLib(Context: PInitContext); +begin +{$IFDEF DEBUG_STARTUP} +asm + INT 3 +end; +{$ENDIF} + asm + PUSH UNWINDFI_TOPOFSTACK + end; + Context.DLLInitState := DLL_PROCESS_ATTACH; + TlsIndex := -1; + ModuleIsLib := True; + HInstance := GetThisModuleHandle; + Module.Instance := HInstance; + Module.InstanceVar := @HInstance; + Module.CodeInstance := 0; + Module.DataInstance := 0; + Module.GOT := LongWord(@_Global_Offset_Table_); + Module.CodeSegStart := GetTextStart; + Module.CodeSegEnd := GetTextEnd; + InitializeModule; + RegisterPCMap; + _StartLib(Context, @Module, DLLProcEx); + asm + ADD ESP, 4 + end; +end; + +// InnerExitLib provides GOT fixup and global var addressing +function InnerExitLib(Context: PInitContext): Integer; +begin + Result := 0; + if ModuleIsPackage then + begin + UninitializeModule; + UnregisterPCMap; + end + else + _StartLib(Context, @Module, DLLProcEx); +end; + +function _ExitLib: Integer; cdecl; +asm +{$IFDEF DEBUG_STARTUP} + INT 3 +{$ENDIF} + PUSH EBP + MOV EBP,ESP + PUSH UNWINDFI_TOPOFSTACK + XOR EAX,EAX + PUSH DLL_PROCESS_DETACH // InitContext.DLLInitState + PUSH EDI + PUSH ESI + PUSH EBX + PUSH EBP + PUSH EAX // InitContext.Module + PUSH EAX // InitContext.InitCount + PUSH EAX // InitContext.InitTable (filled in later) + PUSH EAX // InitContext.OuterContext + MOV EAX,ESP + CALL InnerExitLib; + ADD ESP, 16 + POP EBP + POP EBX + POP ESI + POP EDI + MOV ESP,EBP + POP EBP +end; + +procedure _GetCallerEIP; +asm + MOV EBX, [ESP] +end; +{$ENDIF LINUX} + +{$IFDEF MSWINDOWS} +procedure _InitExe(InitTable: Pointer); +begin + TlsIndex := 0; + HInstance := GetModuleHandle(nil); + Module.Instance := HInstance; + Module.CodeInstance := 0; + Module.DataInstance := 0; + InitializeModule; + _StartExe(InitTable, @Module); +end; +{$ENDIF MSWINDOWS} +{$IFDEF LINUX} +procedure InitVmtImports; +var + P: ^Integer; +begin + P := @TypeImportsTable; + if P = nil then Exit; + while P^ <> 0 do + begin + P^ := Integer(dlsym(0, PChar(P^))); + Inc(P); + end; +end; + +procedure _InitExe(InitTable: Pointer; Argc: Integer; Argp: Pointer); export; +begin +{$IFDEF DEBUG_STARTUP} + asm + INT 3 + end; +{$ENDIF} + HInstance := GetThisModuleHandle; + Module.Instance := HInstance; + Module.InstanceVar := @HInstance; + Module.CodeInstance := 0; + Module.DataInstance := 0; + InitializeModule; + InitThreadTLS; +{$IFDEF PC_MAPPED_EXCEPTIONS} + RegisterPCMap(); +{$ENDIF} + InitVmtImports; + _StartExe(InitTable, @Module, Argc, Argp); +end; +{$ENDIF} + + +{$IFDEF LINUX} +var + InitAddr: Pointer; + +function _main(argc: Integer; argv: Pointer; envp: Pointer): Integer; export cdecl; +type + TInitFunction = function (argc: Integer; argv, envp: Pointer): Integer; cdecl; + TExternalInit = function (argc: Integer; argv, envp: Pointer; InitExe: TInitFunction): Integer; cdecl; +var + ExternalInit: TExternalInit; + InitFunc: TInitFunction; +begin + @ExternalInit := dlsym(GetThisModuleHandle, 'ExternalInit'); + @InitFunc := InitAddr; + System.envp := envp; + if @ExternalInit <> nil then + ExternalInit(argc, argv, envp, InitFunc); + Result := InitFunc(argc, argv, envp); +end; + +function __libc_start_main (Main: Pointer; Argc: Integer; Argv: Pointer; + Init, Fini, rtld_Fini: Pointer; StackEnd: Pointer) + : Integer; + cdecl; + external libcmodulename name '__libc_start_main'; + +{ Program entry point } +procedure _start; +asm +{$IFDEF DEBUG_STARTUP} + INT 3 +{$ENDIF} + { Mark outermost frame, suggested by ELF i386 ABI. } + xor ebp,ebp + + { Get data passed on stack } + pop eax { argc } + mov ecx,esp { argv } + + { Align stack } + and esp,0fffffff8h +{$IFDEF PC_MAPPED_EXCEPTIONS} + { Mark the top of the stack with a signature } + push UNWINDFI_TOPOFSTACK +{$ENDIF} + push ebp { padding } + push esp { crt1.o does this, don't know why } + push edx { function to be registered with + atexit(), passed by loader } + push offset @@ret { _fini dummy } + push offset @@ret { _init dummy } + push ecx { argv } + push eax { argc } + { We need a symbol for the Pascal entry point (main unit's + body). An external symbol `main' fixed up by the linker + would be fine. Alas, external declarations can't do that; + they must be resolved either in the same file with a $L + directive, or in a shared object. Hack: use a bogus, + distinctive symbol to mark the fixup, find and patch it + in the linker. } +{$IFDEF PIC} + call GetGOT + mov ebx, eax + add [esp+12],ebx + add [esp+8],ebx + // Linker will replace _GLOBAL_OFFSET_TABLE_ address with main program block + mov eax, offset _GLOBAL_OFFSET_TABLE_ + add eax, ebx + mov [ebx].InitAddr, eax + mov eax, offset _main + add eax, ebx + push eax +{$ELSE} + // Linker will replace _GLOBAL_OFFSET_TABLE_ address with main program block + push offset _GLOBAL_OFFSET_TABLE_ + pop InitAddr + push offset _main +{$ENDIF} + call __libc_start_main + hlt { they never come back } + +@@ret: +end; +{$ENDIF} + +{$IFDEF LINUX} +{ Procedure body not generated on Windows currently } +procedure OpenEdition; +begin +end; + +procedure GPLInfected; +begin +end; + + + + + + + +procedure Copyright; +begin +end; + +const + sOpenEdition = 'This application was built with Borland Kylix Open Edition(tm).'; + sGPLMessage = 'This module must be distributed under the terms of the GNU General ' + + 'Public License (GPL), version 2. A copy of this license can be found at:' + + 'http://www.borland.com/kylix/gpl.html.'; + +exports +{$IF Declared(GPL)} + OpenEdition name sOpenEdition, + GPLInfected name sGPLMessage, +{$IFEND} + + + + + Copyright name 'Portions Copyright (c) 1983,2002 Borland Software Corporation'; + + +{$IF Declared(GPL)} +initialization + if IsConsole and not ModuleIsLib then + begin + TTextRec(Output).Mode := fmClosed; + writeln(sGPLMessage); + end; +{$IFEND} +{$ENDIF} +end. + + diff --git a/System/D7_ECM/SysSfIni.pas b/System/D7_ECM/SysSfIni.pas new file mode 100644 index 0000000..c3a5465 --- /dev/null +++ b/System/D7_ECM/SysSfIni.pas @@ -0,0 +1,22 @@ +unit SysSfIni; +{X: this unit must be referenced in uses clause of dpr as earlier as possible, + if You want to use try-execpt/raise protected initialization and finalization + for your units. } + +{$O+,H+,I-,S-} + +interface + +implementation + +initialization + + InitUnitsProc := InitUnitsHard; + FInitUnitsProc := FInitUnitsHard; + UnregisterModule := UnregisterModuleSafely; + UnsetExceptionHandlerProc := UnsetExceptionHandler; + SetExceptionHandler; + +finalization + +end. diff --git a/System/D7_ECM/System.pas b/System/D7_ECM/System.pas new file mode 100644 index 0000000..561751a --- /dev/null +++ b/System/D7_ECM/System.pas @@ -0,0 +1,18498 @@ +{ *********************************************************************** } +{ } +{ Delphi / Kylix Cross-Platform Runtime Library } +{ System Unit } +{ } +{ Copyright (c) 1988, 2001 Borland Software Corporation } +{ } +{ *********************************************************************** } + +unit System; { Predefined constants, types, procedures, } + { and functions (such as True, Integer, or } + { Writeln) do not have actual declarations.} + { Instead they are built into the compiler } + { and are treated as if they were declared } + { at the beginning of the System unit. } + +{$H+,I-,R-,O+,W-} +{$WARN SYMBOL_PLATFORM OFF} + +{ L- should never be specified. + + The IDE needs to find DebugHook (through the C++ + compiler sometimes) for integrated debugging to + function properly. + + ILINK will generate debug info for DebugHook if + the object module has not been compiled with debug info. + + ILINK will not generate debug info for DebugHook if + the object module has been compiled with debug info. + + Thus, the Pascal compiler must be responsible for + generating the debug information for that symbol + when a debug-enabled object file is produced. +} + +interface + +(* You can use RTLVersion in $IF expressions to test the runtime library + version level independently of the compiler version level. + Example: {$IF RTLVersion >= 16.2} ... {$IFEND} *) + +const + RTLVersion = 15.00; + +{$EXTERNALSYM CompilerVersion} + +(* +const + CompilerVersion = 0.0; + + CompilerVersion is assigned a value by the compiler when + the system unit is compiled. It indicates the revision level of the + compiler features / language syntax, which may advance independently of + the RTLVersion. CompilerVersion can be tested in $IF expressions and + should be used instead of testing for the VERxxx conditional define. + Always test for greater than or less than a known revision level. + It's a bad idea to test for a specific revision level. +*) + +{$IFDEF DECLARE_GPL} +(* The existence of the GPL symbol indicates that the System unit + and the rest of the Delphi runtime library were compiled for use + and distribution under the terms of the GNU General Public License (GPL). + Under the terms of the GPL, all applications compiled with the + GPL version of the Delphi runtime library must also be distributed + under the terms of the GPL. + For more information about the GNU GPL, see + http://www.gnu.org/copyleft/gpl.html + + The GPL symbol does not exist in the Delphi runtime library + purchased for commercial/proprietary software development. + + If your source code needs to know which licensing model it is being + compiled into, you can use {$IF DECLARED(GPL)}...{$IFEND} to + test for the existence of the GPL symbol. The value of the + symbol itself is not significant. *) + +const + GPL = True; +{$ENDIF} + +{ Variant type codes (wtypes.h) } + + varEmpty = $0000; { vt_empty 0 } + varNull = $0001; { vt_null 1 } + varSmallint = $0002; { vt_i2 2 } + varInteger = $0003; { vt_i4 3 } + varSingle = $0004; { vt_r4 4 } + varDouble = $0005; { vt_r8 5 } + varCurrency = $0006; { vt_cy 6 } + varDate = $0007; { vt_date 7 } + varOleStr = $0008; { vt_bstr 8 } + varDispatch = $0009; { vt_dispatch 9 } + varError = $000A; { vt_error 10 } + varBoolean = $000B; { vt_bool 11 } + varVariant = $000C; { vt_variant 12 } + varUnknown = $000D; { vt_unknown 13 } +//varDecimal = $000E; { vt_decimal 14 } {UNSUPPORTED as of v6.x code base} +//varUndef0F = $000F; { undefined 15 } {UNSUPPORTED per Microsoft} + varShortInt = $0010; { vt_i1 16 } + varByte = $0011; { vt_ui1 17 } + varWord = $0012; { vt_ui2 18 } + varLongWord = $0013; { vt_ui4 19 } + varInt64 = $0014; { vt_i8 20 } +//varWord64 = $0015; { vt_ui8 21 } {UNSUPPORTED as of v6.x code base} +{ if adding new items, update Variants' varLast, BaseTypeMap and OpTypeMap } + + varStrArg = $0048; { vt_clsid 72 } + varString = $0100; { Pascal string 256 } {not OLE compatible } + varAny = $0101; { Corba any 257 } {not OLE compatible } + // custom types range from $110 (272) to $7FF (2047) + + varTypeMask = $0FFF; + varArray = $2000; + varByRef = $4000; + +{ TVarRec.VType values } + + vtInteger = 0; + vtBoolean = 1; + vtChar = 2; + vtExtended = 3; + vtString = 4; + vtPointer = 5; + vtPChar = 6; + vtObject = 7; + vtClass = 8; + vtWideChar = 9; + vtPWideChar = 10; + vtAnsiString = 11; + vtCurrency = 12; + vtVariant = 13; + vtInterface = 14; + vtWideString = 15; + vtInt64 = 16; + +{ Virtual method table entries } + + vmtSelfPtr = -76; + vmtIntfTable = -72; + vmtAutoTable = -68; + vmtInitTable = -64; + vmtTypeInfo = -60; + vmtFieldTable = -56; + vmtMethodTable = -52; + vmtDynamicTable = -48; + vmtClassName = -44; + vmtInstanceSize = -40; + vmtParent = -36; + vmtSafeCallException = -32 deprecated; // don't use these constants. + vmtAfterConstruction = -28 deprecated; // use VMTOFFSET in asm code instead + vmtBeforeDestruction = -24 deprecated; + vmtDispatch = -20 deprecated; + vmtDefaultHandler = -16 deprecated; + vmtNewInstance = -12 deprecated; + vmtFreeInstance = -8 deprecated; + vmtDestroy = -4 deprecated; + + vmtQueryInterface = 0 deprecated; + vmtAddRef = 4 deprecated; + vmtRelease = 8 deprecated; + vmtCreateObject = 12 deprecated; + +type + + TObject = class; + + TClass = class of TObject; + + HRESULT = type Longint; { from WTYPES.H } + {$EXTERNALSYM HRESULT} + + PGUID = ^TGUID; + TGUID = packed record + D1: LongWord; + D2: Word; + D3: Word; + D4: array[0..7] of Byte; + end; + + PInterfaceEntry = ^TInterfaceEntry; + TInterfaceEntry = packed record + IID: TGUID; + VTable: Pointer; + IOffset: Integer; + ImplGetter: Integer; + end; + + PInterfaceTable = ^TInterfaceTable; + TInterfaceTable = packed record + EntryCount: Integer; + Entries: array[0..9999] of TInterfaceEntry; + end; + + TMethod = record + Code, Data: Pointer; + end; + +{ TObject.Dispatch accepts any data type as its Message parameter. The + first 2 bytes of the data are taken as the message id to search for + in the object's message methods. TDispatchMessage is an example of + such a structure with a word field for the message id. +} + TDispatchMessage = record + MsgID: Word; + end; + + TObject = class + constructor Create; + procedure Free; + class function InitInstance(Instance: Pointer): TObject; + procedure CleanupInstance; + function ClassType: TClass; + class function ClassName: ShortString; + class function ClassNameIs(const Name: string): Boolean; + class function ClassParent: TClass; + class function ClassInfo: Pointer; + class function InstanceSize: Longint; + class function InheritsFrom(AClass: TClass): Boolean; + class function MethodAddress(const Name: ShortString): Pointer; + class function MethodName(Address: Pointer): ShortString; + function FieldAddress(const Name: ShortString): Pointer; + function GetInterface(const IID: TGUID; out Obj): Boolean; + class function GetInterfaceEntry(const IID: TGUID): PInterfaceEntry; + class function GetInterfaceTable: PInterfaceTable; + function SafeCallException(ExceptObject: TObject; + ExceptAddr: Pointer): HResult; virtual; + procedure AfterConstruction; virtual; + procedure BeforeDestruction; virtual; + procedure Dispatch(var Message); virtual; + procedure DefaultHandler(var Message); virtual; + class function NewInstance: TObject; virtual; + procedure FreeInstance; virtual; + destructor Destroy; virtual; + end; + +const + S_OK = 0; {$EXTERNALSYM S_OK} + S_FALSE = $00000001; {$EXTERNALSYM S_FALSE} + E_NOINTERFACE = HRESULT($80004002); {$EXTERNALSYM E_NOINTERFACE} + E_UNEXPECTED = HRESULT($8000FFFF); {$EXTERNALSYM E_UNEXPECTED} + E_NOTIMPL = HRESULT($80004001); {$EXTERNALSYM E_NOTIMPL} + +type + IInterface = interface + ['{00000000-0000-0000-C000-000000000046}'] + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + end; + +{X+}(*$HPPEMIT '#define IInterface IUnknown' *) + + IUnknown = IInterface; +{$M+} + IInvokable = interface(IInterface) + end; +{$M-} + + IDispatch = interface(IUnknown) + ['{00020400-0000-0000-C000-000000000046}'] + function GetTypeInfoCount(out Count: Integer): HResult; stdcall; + function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall; + function GetIDsOfNames(const IID: TGUID; Names: Pointer; + NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall; + function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; + Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall; + end; + +{$EXTERNALSYM IUnknown} +{$EXTERNALSYM IDispatch} + +{ TInterfacedObject provides a threadsafe default implementation + of IInterface. You should use TInterfaceObject as the base class + of objects implementing interfaces. } + + TInterfacedObject = class(TObject, IInterface) + protected + FRefCount: Integer; + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + public + procedure AfterConstruction; override; + procedure BeforeDestruction; override; + class function NewInstance: TObject; override; + property RefCount: Integer read FRefCount; + end; + + TInterfacedClass = class of TInterfacedObject; + +{ TAggregatedObject and TContainedObject are suitable base + classes for interfaced objects intended to be aggregated + or contained in an outer controlling object. When using + the "implements" syntax on an interface property in + an outer object class declaration, use these types + to implement the inner object. + + Interfaces implemented by aggregated objects on behalf of + the controller should not be distinguishable from other + interfaces provided by the controller. Aggregated objects + must not maintain their own reference count - they must + have the same lifetime as their controller. To achieve this, + aggregated objects reflect the reference count methods + to the controller. + + TAggregatedObject simply reflects QueryInterface calls to + its controller. From such an aggregated object, one can + obtain any interface that the controller supports, and + only interfaces that the controller supports. This is + useful for implementing a controller class that uses one + or more internal objects to implement the interfaces declared + on the controller class. Aggregation promotes implementation + sharing across the object hierarchy. + + TAggregatedObject is what most aggregate objects should + inherit from, especially when used in conjunction with + the "implements" syntax. } + + TAggregatedObject = class(TObject) + private + FController: Pointer; // weak reference to controller + function GetController: IInterface; + protected + { IInterface } + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + public + constructor Create(const Controller: IInterface); + property Controller: IInterface read GetController; + end; + + { TContainedObject is an aggregated object that isolates + QueryInterface on the aggregate from the controller. + TContainedObject will return only interfaces that the + contained object itself implements, not interfaces + that the controller implements. This is useful for + implementing nodes that are attached to a controller and + have the same lifetime as the controller, but whose + interface identity is separate from the controller. + You might do this if you don't want the consumers of + an aggregated interface to have access to other interfaces + implemented by the controller - forced encapsulation. + This is a less common case than TAggregatedObject. } + + TContainedObject = class(TAggregatedObject, IInterface) + protected + { IInterface } + function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall; + end; + + PShortString = ^ShortString; + PAnsiString = ^AnsiString; + PWideString = ^WideString; + PString = PAnsiString; + + UCS2Char = WideChar; + PUCS2Char = PWideChar; + UCS4Char = type LongWord; + {$NODEFINE UCS4CHAR} + PUCS4Char = ^UCS4Char; + {$NODEFINE PUCS4CHAR} + TUCS4CharArray = array [0..$effffff] of UCS4Char; + PUCS4CharArray = ^TUCS4CharArray; + UCS4String = array of UCS4Char; + {$NODEFINE UCS4String} + + UTF8String = type string; + PUTF8String = ^UTF8String; + {$NODEFINE UTF8String} + {$NODEFINE PUTF8String} + + IntegerArray = array[0..$effffff] of Integer; + PIntegerArray = ^IntegerArray; + PointerArray = array [0..512*1024*1024 - 2] of Pointer; + PPointerArray = ^PointerArray; + TBoundArray = array of Integer; + TPCharArray = packed array[0..(MaxLongint div SizeOf(PChar))-1] of PChar; + PPCharArray = ^TPCharArray; + + (*$HPPEMIT 'namespace System' *) + (*$HPPEMIT '{' *) + (*$HPPEMIT ' typedef int *PLongint;' *) +{X+}(*$HPPEMIT ' typedef bool *PBoolean;' *) +{X+}(*$HPPEMIT ' typedef PChar *PPChar;' *) +{X+}(*$HPPEMIT ' typedef double *PDouble;' *) +{X+}(*$HPPEMIT ' typedef wchar_t UCS4Char;' *) +{X+}(*$HPPEMIT ' typedef wchar_t *PUCS4Char;' *) +{X+}(*$HPPEMIT ' typedef DynamicArray UCS4String;' *) + (*$HPPEMIT '}' *) + PLongint = ^Longint; + {$EXTERNALSYM PLongint} + PInteger = ^Integer; + PCardinal = ^Cardinal; + PWord = ^Word; + PSmallInt = ^SmallInt; + PByte = ^Byte; + PShortInt = ^ShortInt; + PInt64 = ^Int64; + PLongWord = ^LongWord; + PSingle = ^Single; + PDouble = ^Double; + PDate = ^Double; + PDispatch = ^IDispatch; + PPDispatch = ^PDispatch; + PError = ^LongWord; + PWordBool = ^WordBool; + PUnknown = ^IUnknown; + PPUnknown = ^PUnknown; + {$NODEFINE PByte} + PPWideChar = ^PWideChar; + PPChar = ^PChar; + PPAnsiChar = PPChar; + PExtended = ^Extended; + PComp = ^Comp; + PCurrency = ^Currency; + PVariant = ^Variant; + POleVariant = ^OleVariant; + PPointer = ^Pointer; + PBoolean = ^Boolean; + + TDateTime = type Double; + PDateTime = ^TDateTime; + + THandle = LongWord; + + TVarArrayBound = packed record + ElementCount: Integer; + LowBound: Integer; + end; + TVarArrayBoundArray = array [0..0] of TVarArrayBound; + PVarArrayBoundArray = ^TVarArrayBoundArray; + TVarArrayCoorArray = array [0..0] of Integer; + PVarArrayCoorArray = ^TVarArrayCoorArray; + + PVarArray = ^TVarArray; + TVarArray = packed record + DimCount: Word; + Flags: Word; + ElementSize: Integer; + LockCount: Integer; + Data: Pointer; + Bounds: TVarArrayBoundArray; + end; + + TVarType = Word; + PVarData = ^TVarData; + {$EXTERNALSYM PVarData} + TVarData = packed record + case Integer of + 0: (VType: TVarType; + case Integer of + 0: (Reserved1: Word; + case Integer of + 0: (Reserved2, Reserved3: Word; + case Integer of + varSmallInt: (VSmallInt: SmallInt); + varInteger: (VInteger: Integer); + varSingle: (VSingle: Single); + varDouble: (VDouble: Double); + varCurrency: (VCurrency: Currency); + varDate: (VDate: TDateTime); + varOleStr: (VOleStr: PWideChar); + varDispatch: (VDispatch: Pointer); + varError: (VError: HRESULT); + varBoolean: (VBoolean: WordBool); + varUnknown: (VUnknown: Pointer); + varShortInt: (VShortInt: ShortInt); + varByte: (VByte: Byte); + varWord: (VWord: Word); + varLongWord: (VLongWord: LongWord); + varInt64: (VInt64: Int64); + varString: (VString: Pointer); + varAny: (VAny: Pointer); + varArray: (VArray: PVarArray); + varByRef: (VPointer: Pointer); + ); + 1: (VLongs: array[0..2] of LongInt); + ); + 2: (VWords: array [0..6] of Word); + 3: (VBytes: array [0..13] of Byte); + ); + 1: (RawData: array [0..3] of LongInt); + end; + {$EXTERNALSYM TVarData} + +type + TVarOp = Integer; + +const + opAdd = 0; + opSubtract = 1; + opMultiply = 2; + opDivide = 3; + opIntDivide = 4; + opModulus = 5; + opShiftLeft = 6; + opShiftRight = 7; + opAnd = 8; + opOr = 9; + opXor = 10; + opCompare = 11; + opNegate = 12; + opNot = 13; + + opCmpEQ = 14; + opCmpNE = 15; + opCmpLT = 16; + opCmpLE = 17; + opCmpGT = 18; + opCmpGE = 19; + +type + { Dispatch call descriptor } + PCallDesc = ^TCallDesc; + TCallDesc = packed record + CallType: Byte; + ArgCount: Byte; + NamedArgCount: Byte; + ArgTypes: array[0..255] of Byte; + end; + + PDispDesc = ^TDispDesc; + TDispDesc = packed record + DispID: Integer; + ResType: Byte; + CallDesc: TCallDesc; + end; + + PVariantManager = ^TVariantManager; + {$EXTERNALSYM PVariantManager} + TVariantManager = record + VarClear: procedure(var V : Variant); + VarCopy: procedure(var Dest: Variant; const Source: Variant); + VarCopyNoInd: procedure; // ARGS PLEASE! + VarCast: procedure(var Dest: Variant; const Source: Variant; VarType: Integer); + VarCastOle: procedure(var Dest: Variant; const Source: Variant; VarType: Integer); + + VarToInt: function(const V: Variant): Integer; + VarToInt64: function(const V: Variant): Int64; + VarToBool: function(const V: Variant): Boolean; + VarToReal: function(const V: Variant): Extended; + VarToCurr: function(const V: Variant): Currency; + VarToPStr: procedure(var S; const V: Variant); + VarToLStr: procedure(var S: string; const V: Variant); + VarToWStr: procedure(var S: WideString; const V: Variant); + VarToIntf: procedure(var Unknown: IInterface; const V: Variant); + VarToDisp: procedure(var Dispatch: IDispatch; const V: Variant); + VarToDynArray: procedure(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer); + + VarFromInt: procedure(var V: Variant; const Value: Integer; const Range: ShortInt); + VarFromInt64: procedure(var V: Variant; const Value: Int64); + VarFromBool: procedure(var V: Variant; const Value: Boolean); + VarFromReal: procedure; // var V: Variant; const Value: Real + VarFromTDateTime: procedure; // var V: Variant; const Value: TDateTime + VarFromCurr: procedure; // var V: Variant; const Value: Currency + VarFromPStr: procedure(var V: Variant; const Value: ShortString); + VarFromLStr: procedure(var V: Variant; const Value: string); + VarFromWStr: procedure(var V: Variant; const Value: WideString); + VarFromIntf: procedure(var V: Variant; const Value: IInterface); + VarFromDisp: procedure(var V: Variant; const Value: IDispatch); + VarFromDynArray: procedure(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer); + OleVarFromPStr: procedure(var V: OleVariant; const Value: ShortString); + OleVarFromLStr: procedure(var V: OleVariant; const Value: string); + OleVarFromVar: procedure(var V: OleVariant; const Value: Variant); + OleVarFromInt: procedure(var V: OleVariant; const Value: Integer; const Range: ShortInt); + + VarOp: procedure(var Left: Variant; const Right: Variant; OpCode: TVarOp); + VarCmp: procedure(const Left, Right: TVarData; const OpCode: TVarOp); { result is set in the flags } + VarNeg: procedure(var V: Variant); + VarNot: procedure(var V: Variant); + + DispInvoke: procedure(Dest: PVarData; const Source: TVarData; + CallDesc: PCallDesc; Params: Pointer); cdecl; + VarAddRef: procedure(var V: Variant); + + VarArrayRedim: procedure(var A : Variant; HighBound: Integer); + VarArrayGet: function(var A: Variant; IndexCount: Integer; + Indices: Integer): Variant; cdecl; + VarArrayPut: procedure(var A: Variant; const Value: Variant; + IndexCount: Integer; Indices: Integer); cdecl; + + WriteVariant: function(var T: Text; const V: Variant; Width: Integer): Pointer; + Write0Variant: function(var T: Text; const V: Variant): Pointer; + end deprecated; + {$EXTERNALSYM TVariantManager} + + { Dynamic array support } + PDynArrayTypeInfo = ^TDynArrayTypeInfo; + {$EXTERNALSYM PDynArrayTypeInfo} + TDynArrayTypeInfo = packed record + kind: Byte; + name: string[0]; + elSize: Longint; + elType: ^PDynArrayTypeInfo; + varType: Integer; + end; + {$EXTERNALSYM TDynArrayTypeInfo} + + PVarRec = ^TVarRec; + TVarRec = record { do not pack this record; it is compiler-generated } + case Byte of + vtInteger: (VInteger: Integer; VType: Byte); + vtBoolean: (VBoolean: Boolean); + vtChar: (VChar: Char); + vtExtended: (VExtended: PExtended); + vtString: (VString: PShortString); + vtPointer: (VPointer: Pointer); + vtPChar: (VPChar: PChar); + vtObject: (VObject: TObject); + vtClass: (VClass: TClass); + vtWideChar: (VWideChar: WideChar); + vtPWideChar: (VPWideChar: PWideChar); + vtAnsiString: (VAnsiString: Pointer); + vtCurrency: (VCurrency: PCurrency); + vtVariant: (VVariant: PVariant); + vtInterface: (VInterface: Pointer); + vtWideString: (VWideString: Pointer); + vtInt64: (VInt64: PInt64); + end; + + PMemoryManager = ^TMemoryManager; + TMemoryManager = record + GetMem: function(Size: Integer): Pointer; + FreeMem: function(P: Pointer): Integer; + ReallocMem: function(P: Pointer; Size: Integer): Pointer; + end; + + THeapStatus = record + TotalAddrSpace: Cardinal; + TotalUncommitted: Cardinal; + TotalCommitted: Cardinal; + TotalAllocated: Cardinal; + TotalFree: Cardinal; + FreeSmall: Cardinal; + FreeBig: Cardinal; + Unused: Cardinal; + Overhead: Cardinal; + HeapErrorCode: Cardinal; + end; + +{$IFDEF PC_MAPPED_EXCEPTIONS} + PUnwinder = ^TUnwinder; + TUnwinder = record + RaiseException: function(Exc: Pointer): LongBool; cdecl; + RegisterIPLookup: function(fn: Pointer; StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; cdecl; + UnregisterIPLookup: procedure(StartAddr: LongInt) cdecl; + DelphiLookup: function(Addr: LongInt; Context: Pointer): Pointer; cdecl; + ClosestHandler: function(Context: Pointer): LongWord; cdecl; + end; +{$ENDIF PC_MAPPED_EXCEPTIONS} + + PackageUnitEntry = packed record + Init, FInit : Pointer; + end; + + { Compiler generated table to be processed sequentially to init & finit all package units } + { Init: 0..Max-1; Final: Last Initialized..0 } + UnitEntryTable = array [0..9999999] of PackageUnitEntry; + PUnitEntryTable = ^UnitEntryTable; + + PackageInfoTable = packed record + UnitCount : Integer; { number of entries in UnitInfo array; always > 0 } + UnitInfo : PUnitEntryTable; + end; + + PackageInfo = ^PackageInfoTable; + + { Each package exports a '@GetPackageInfoTable' which can be used to retrieve } + { the table which contains compiler generated information about the package DLL } + GetPackageInfoTable = function : PackageInfo; + +{$IFDEF DEBUG_FUNCTIONS} +{ Inspector Query; implementation in GETMEM.INC; no need to conditionalize that } + THeapBlock = record + Start: Pointer; + Size: Cardinal; + end; + + THeapBlockArray = array of THeapBlock; + TObjectArray = array of TObject; + +function GetHeapBlocks: THeapBlockArray; +function FindObjects(AClass: TClass; FindDerived: Boolean): TObjectArray; +{ Inspector Query } +{$ENDIF} + +{ + When an exception is thrown, the exception object that is thrown is destroyed + automatically when the except clause which handles the exception is exited. + There are some cases in which an application may wish to acquire the thrown + object and keep it alive after the except clause is exited. For this purpose, + we have added the AcquireExceptionObject and ReleaseExceptionObject functions. + These functions maintain a reference count on the most current exception object, + allowing applications to legitimately obtain references. If the reference count + for an exception that is being thrown is positive when the except clause is exited, + then the thrown object is not destroyed by the RTL, but assumed to be in control + of the application. It is then the application's responsibility to destroy the + thrown object. If the reference count is zero, then the RTL will destroy the + thrown object when the except clause is exited. +} +function AcquireExceptionObject: Pointer; +procedure ReleaseExceptionObject; + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure GetUnwinder(var Dest: TUnwinder); +procedure SetUnwinder(const NewUnwinder: TUnwinder); +function IsUnwinderSet: Boolean; + +//function SysRegisterIPLookup(ModuleHandle, StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; +{ + Do NOT call these functions. They are for internal use only: + SysRegisterIPLookup + SysUnregisterIPLookup + BlockOSExceptions + UnblockOSExceptions + AreOSExceptionsBlocked +} +function SysRegisterIPLookup(StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; +procedure SysUnregisterIPLookup(StartAddr: LongInt); +//function SysAddressIsInPCMap(Addr: LongInt): Boolean; +function SysClosestDelphiHandler(Context: Pointer): LongWord; +procedure BlockOSExceptions; +procedure UnblockOSExceptions; +function AreOSExceptionsBlocked: Boolean; + +{$ELSE} +// These functions are not portable. Use AcquireExceptionObject above instead +function RaiseList: Pointer; deprecated; { Stack of current exception objects } +function SetRaiseList(NewPtr: Pointer): Pointer; deprecated; { returns previous value } +{$ENDIF} + +function ExceptObject: TObject; +function ExceptAddr: Pointer; + + +{ + Coverage support. These are internal use structures referenced by compiler + helper functions for QA coverage support. +} +type + TCVModInfo = packed record + ModName: PChar; + LibName: PChar; + UserData: PChar; + end; + PCVModInfo = ^TCVModInfo; + +{$EXTERNALSYM _CVR_PROBE} +procedure _CVR_PROBE(mi: PCVModInfo; probeNum: Cardinal); cdecl; +{$EXTERNALSYM _CVR_STMTPROBE} +function _CVR_STMTPROBE(mi: PCVModInfo; probeNum: Cardinal; TrueFalse: Cardinal): Boolean; cdecl; + +procedure SetInOutRes(NewValue: Integer); + +type + TAssertErrorProc = procedure (const Message, Filename: string; + LineNumber: Integer; ErrorAddr: Pointer); + TSafeCallErrorProc = procedure (ErrorCode: HResult; ErrorAddr: Pointer); + +{$IFDEF DEBUG} +{ + This variable is just for debugging the exception handling system. See + _DbgExcNotify for the usage. +} +var + ExcNotificationProc : procedure ( NotificationKind: Integer; + ExceptionObject: Pointer; + ExceptionName: PShortString; + ExceptionLocation: Pointer; + HandlerAddr: Pointer) = nil; +{$ENDIF} + +var + DispCallByIDProc: Pointer; + ExceptProc: Pointer; { Unhandled exception handler } + ErrorProc: procedure (ErrorCode: Byte; ErrorAddr: Pointer); { Error handler procedure } +{$IFDEF MSWINDOWS} + ExceptClsProc: Pointer; { Map an OS Exception to a Delphi class reference } + ExceptObjProc: Pointer; { Map an OS Exception to a Delphi class instance } + RaiseExceptionProc: Pointer; + RTLUnwindProc: Pointer; +{$ENDIF} + ExceptionClass: TClass; { Exception base class (must be Exception) } + SafeCallErrorProc: TSafeCallErrorProc; { Safecall error handler } + AssertErrorProc: TAssertErrorProc; { Assertion error handler } + ExitProcessProc: procedure; { Hook to be called just before the process actually exits } + AbstractErrorProc: procedure; { Abstract method error handler } + HPrevInst: LongWord deprecated; { Handle of previous instance - HPrevInst cannot be tested for multiple instances in Win32} + MainInstance: LongWord; { Handle of the main(.EXE) HInstance } + MainThreadID: LongWord; { ThreadID of thread that module was initialized in } + IsLibrary: Boolean; { True if module is a DLL } +{X+}{$IFDEF MSWINDOWS} +{X}function CmdShow: Integer; +{X}function CmdLine: PChar; +{X+}{$ELSE} + CmdShow: Integer platform; { CmdShow parameter for CreateWindow } + CmdLine: PChar platform; { Command line pointer } +{X+}{$ENDIF} +{X+}var + InitProc: Pointer; { Last installed initialization procedure } + ExitCode: Integer = 0; { Program result } + ExitProc: Pointer; { Last installed exit procedure } + ErrorAddr: Pointer = nil; { Address of run-time error } + RandSeed: Longint = 0; { Base for random number generator } + IsConsole: Boolean; { True if compiled as console app } + IsMultiThread: Boolean; { True if more than one thread } + FileMode: Byte = 2; { Standard mode for opening files } +{$IFDEF LINUX} + FileAccessRights: Integer platform; { Default access rights for opening files } + ArgCount: Integer platform; + ArgValues: PPChar platform; +{$ENDIF} + Test8086: Byte; { CPU family (minus one) See consts below } + Test8087: Byte = 3; { assume 80387 FPU or OS supplied FPU emulation } + TestFDIV: Shortint; { -1: Flawed Pentium, 0: Not determined, 1: Ok } + Input: Text; { Standard input } + Output: Text; { Standard output } + ErrOutput: Text; { Standard error output } + envp: PPChar platform; + +{$HPPEMIT 'struct TVarData;'} + VarClearProc: procedure (var v: TVarData) = nil; // for internal use only + VarAddRefProc: procedure (var v: TVarData) = nil; // for internal use only + VarCopyProc: procedure (var Dest: TVarData; const Source: TVarData) = nil; // for internal use only + VarToLStrProc: procedure (var Dest: AnsiString; const Source: TVarData) = nil; // for internal use only + VarToWStrProc: procedure (var Dest: WideString; const Source: TVarData) = nil; // for internal use only + +const + CPUi386 = 2; + CPUi486 = 3; + CPUPentium = 4; + +var + Default8087CW: Word = $1332;{ Default 8087 control word. FPU control + register is set to this value. + CAUTION: Setting this to an invalid value + could cause unpredictable behavior. } + + HeapAllocFlags: Word platform = 2; { Heap allocation flags, gmem_Moveable } + DebugHook: Byte platform = 0; { 1 to notify debugger of non-Delphi exceptions + >1 to notify debugger of exception unwinding } + JITEnable: Byte platform = 0; { 1 to call UnhandledExceptionFilter if the exception + is not a Pascal exception. + >1 to call UnhandledExceptionFilter for all exceptions } + NoErrMsg: Boolean platform = False; { True causes the base RTL to not display the message box + when a run-time error occurs } +{$IFDEF LINUX} + { CoreDumpEnabled = True will cause unhandled + exceptions and runtime errors to raise a + SIGABRT signal, which will cause the OS to + coredump the process address space. This can + be useful for postmortem debugging. } + CoreDumpEnabled: Boolean platform = False; +{$ENDIF} + +type +(*$NODEFINE TTextLineBreakStyle*) + TTextLineBreakStyle = (tlbsLF, tlbsCRLF); + +var { Text output line break handling. Default value for all text files } + DefaultTextLineBreakStyle: TTextLineBreakStyle = {$IFDEF LINUX} tlbsLF {$ENDIF} + {$IFDEF MSWINDOWS} tlbsCRLF {$ENDIF}; +const + sLineBreak = {$IFDEF LINUX} #10 {$ENDIF} {$IFDEF MSWINDOWS} #13#10 {$ENDIF}; + +type + HRSRC = THandle; + TResourceHandle = HRSRC; // make an opaque handle type + HINST = THandle; + HMODULE = HINST; + HGLOBAL = THandle; + +{$IFDEF ELF} +{ ELF resources } +function FindResource(ModuleHandle: HMODULE; ResourceName, ResourceType: PChar): TResourceHandle; +function LoadResource(ModuleHandle: HMODULE; ResHandle: TResourceHandle): HGLOBAL; +function SizeofResource(ModuleHandle: HMODULE; ResHandle: TResourceHandle): Integer; +function LockResource(ResData: HGLOBAL): Pointer; +function UnlockResource(ResData: HGLOBAL): LongBool; +function FreeResource(ResData: HGLOBAL): LongBool; +{$ENDIF} + +{ Memory manager support } + +{X+}// ************ Memory Manager replacement ****************************** +{X+}// +{X+}// By default, now system memory management routines are used +{X+}// to allocate memory. This can be slow sometimes, so if You +{X+}// want to use custom Borland Delphi memory manager, call follow: +{X+}procedure UseDelphiMemoryManager; +{X+}function IsDelphiMemoryManagerSet : Boolean; +{X+}function MemoryManagerNotUsed : Boolean; +{X+}var +{X+} IsMemoryManagerSet : function : Boolean = MemoryManagerNotUsed; +{X+}function GetProcessHeap: THandle; stdcall; +{X+}function HeapAlloc(hHeap: THandle; dwFlags, dwBytes: Cardinal): Pointer; stdcall; +{X+}function HeapReAlloc(hHeap: THandle; dwFlags: Cardinal; lpMem: Pointer; dwBytes: Cardinal): Pointer; stdcall; +{X+}function HeapFree(hHeap: THandle; dwFlags: Cardinal; lpMem: Pointer): LongBool; stdcall; +{X+}function DfltGetMem(size: Integer): Pointer; +{X+}function DfltFreeMem(p: Pointer): Integer; +{X+}function DfltReallocMem(p: Pointer; size: Integer): Pointer; +{X+}// ********************************************************************** + +procedure GetMemoryManager(var MemMgr: TMemoryManager); +procedure SetMemoryManager(const MemMgr: TMemoryManager); + +{X+} // following function is replaced with pointer to one +{X+} // (initialized by another) +{X-} //function IsMemoryManagerSet: Boolean; + +function SysGetMem(Size: Integer): Pointer; +function SysFreeMem(P: Pointer): Integer; +function SysReallocMem(P: Pointer; Size: Integer): Pointer; + +var + AllocMemCount: Integer; { Number of allocated memory blocks } + AllocMemSize: Integer; { Total size of allocated memory blocks } + +{$IFDEF MSWINDOWS} +function GetHeapStatus: THeapStatus; platform; +{$ENDIF} + +{ Thread support } +type + TThreadFunc = function(Parameter: Pointer): Integer; +{$IFDEF LINUX} + TSize_T = Cardinal; + + TSchedParam = record + sched_priority: Integer; + end; + + pthread_attr_t = record + __detachstate, + __schedpolicy: Integer; + __schedparam: TSchedParam; + __inheritsched, + __scope: Integer; + __guardsize: TSize_T; + __stackaddr_set: Integer; + __stackaddr: Pointer; + __stacksize: TSize_T; + end; + {$EXTERNALSYM pthread_attr_t} + TThreadAttr = pthread_attr_t; + PThreadAttr = ^TThreadAttr; + + TBeginThreadProc = function (Attribute: PThreadAttr; + ThreadFunc: TThreadFunc; Parameter: Pointer; + var ThreadId: Cardinal): Integer; + TEndThreadProc = procedure(ExitCode: Integer); + +var + BeginThreadProc: TBeginThreadProc = nil; + EndThreadProc: TEndThreadProc = nil; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function BeginThread(SecurityAttributes: Pointer; StackSize: LongWord; + ThreadFunc: TThreadFunc; Parameter: Pointer; CreationFlags: LongWord; + var ThreadId: LongWord): Integer; +{$ENDIF} +{$IFDEF LINUX} +function BeginThread(Attribute: PThreadAttr; ThreadFunc: TThreadFunc; + Parameter: Pointer; var ThreadId: Cardinal): Integer; + +{$ENDIF} +procedure EndThread(ExitCode: Integer); + +{ Standard procedures and functions } + +const +{ File mode magic numbers } + + fmClosed = $D7B0; + fmInput = $D7B1; + fmOutput = $D7B2; + fmInOut = $D7B3; + +{ Text file flags } + tfCRLF = $1; // Dos compatibility flag, for CR+LF line breaks and EOF checks + +type +{ Typed-file and untyped-file record } + + TFileRec = packed record (* must match the size the compiler generates: 332 bytes *) + Handle: Integer; + Mode: Word; + Flags: Word; + case Byte of + 0: (RecSize: Cardinal); // files of record + 1: (BufSize: Cardinal; // text files + BufPos: Cardinal; + BufEnd: Cardinal; + BufPtr: PChar; + OpenFunc: Pointer; + InOutFunc: Pointer; + FlushFunc: Pointer; + CloseFunc: Pointer; + UserData: array[1..32] of Byte; + Name: array[0..259] of Char; ); + end; + +{ Text file record structure used for Text files } + PTextBuf = ^TTextBuf; + TTextBuf = array[0..127] of Char; + TTextRec = packed record (* must match the size the compiler generates: 460 bytes *) + Handle: Integer; (* must overlay with TFileRec *) + Mode: Word; + Flags: Word; + BufSize: Cardinal; + BufPos: Cardinal; + BufEnd: Cardinal; + BufPtr: PChar; + OpenFunc: Pointer; + InOutFunc: Pointer; + FlushFunc: Pointer; + CloseFunc: Pointer; + UserData: array[1..32] of Byte; + Name: array[0..259] of Char; + Buffer: TTextBuf; + end; + + TTextIOFunc = function (var F: TTextRec): Integer; + TFileIOFunc = function (var F: TFileRec): Integer; + +procedure SetLineBreakStyle(var T: Text; Style: TTextLineBreakStyle); + +procedure ChDir(const S: string); overload; +procedure ChDir(P: PChar); overload; +function Flush(var t: Text): Integer; +procedure _LGetDir(D: Byte; var S: string); +procedure _SGetDir(D: Byte; var S: ShortString); +function IOResult: Integer; +procedure MkDir(const S: string); overload; +procedure MkDir(P: PChar); overload; +procedure Move(const Source; var Dest; Count: Integer); +function ParamCount: Integer; +function ParamStr(Index: Integer): string; +procedure Randomize; +procedure RmDir(const S: string); overload; +procedure RmDir(P: PChar); overload; +function UpCase(Ch: Char): Char; + +{ Control 8087 control word } + +procedure Set8087CW(NewCW: Word); +function Get8087CW: Word; + +{ Wide character support procedures and functions for C++ } +{ These functions should not be used in Delphi code! + (conversion is implicit in Delphi code) } + +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; + +{ PUCS4Chars returns a pointer to the UCS4 char data in the + UCS4String array, or a pointer to a null char if UCS4String is empty } + +function PUCS4Chars(const S: UCS4String): PUCS4Char; + +{ Widestring <-> UCS4 conversion } + +function WideStringToUCS4String(const S: WideString): UCS4String; +function UCS4StringToWideString(const S: UCS4String): WideString; + +{ PChar/PWideChar Unicode <-> UTF8 conversion } + +// UnicodeToUTF8(3): +// UTF8ToUnicode(3): +// Scans the source data to find the null terminator, up to MaxBytes +// Dest must have MaxBytes available in Dest. +// MaxDestBytes includes the null terminator (last char in the buffer will be set to null) +// Function result includes the null terminator. + +function UnicodeToUtf8(Dest: PChar; Source: PWideChar; MaxBytes: Integer): Integer; overload; deprecated; +function Utf8ToUnicode(Dest: PWideChar; Source: PChar; MaxChars: Integer): Integer; overload; deprecated; + +// UnicodeToUtf8(4): +// UTF8ToUnicode(4): +// MaxDestBytes includes the null terminator (last char in the buffer will be set to null) +// Function result includes the null terminator. +// Nulls in the source data are not considered terminators - SourceChars must be accurate + +function UnicodeToUtf8(Dest: PChar; MaxDestBytes: Cardinal; Source: PWideChar; SourceChars: Cardinal): Cardinal; overload; +function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: Cardinal; Source: PChar; SourceBytes: Cardinal): Cardinal; overload; + +{ WideString <-> UTF8 conversion } + +function UTF8Encode(const WS: WideString): UTF8String; +function UTF8Decode(const S: UTF8String): WideString; + +{ Ansi <-> UTF8 conversion } + +function AnsiToUtf8(const S: string): UTF8String; +function Utf8ToAnsi(const S: UTF8String): string; + +{ OLE string support procedures and functions } + +function OleStrToString(Source: PWideChar): string; +procedure OleStrToStrVar(Source: PWideChar; var Dest: string); +function StringToOleStr(const Source: string): PWideChar; + +{ Variant manager support procedures and functions (obsolete - see Variants.pas) } + +procedure GetVariantManager(var VarMgr: TVariantManager); deprecated; +procedure SetVariantManager(const VarMgr: TVariantManager); deprecated; +function IsVariantManagerSet: Boolean; deprecated; + +{ Interface dispatch support } + +procedure _IntfDispCall; cdecl; // ARGS PLEASE! +procedure _IntfVarCall; cdecl; // ARGS PLEASE! + +{ Package/Module registration and unregistration } + +type + PLibModule = ^TLibModule; + TLibModule = record + Next: PLibModule; + Instance: LongWord; + CodeInstance: LongWord; + DataInstance: LongWord; + ResInstance: LongWord; + Reserved: Integer; +{$IFDEF LINUX} + InstanceVar: Pointer platform; + GOT: LongWord platform; + CodeSegStart: LongWord platform; + CodeSegEnd: LongWord platform; + InitTable: Pointer platform; +{$ENDIF} + end; + + TEnumModuleFunc = function (HInstance: Integer; Data: Pointer): Boolean; + {$EXTERNALSYM TEnumModuleFunc} + TEnumModuleFuncLW = function (HInstance: LongWord; Data: Pointer): Boolean; + {$EXTERNALSYM TEnumModuleFuncLW} + TModuleUnloadProc = procedure (HInstance: Integer); + {$EXTERNALSYM TModuleUnloadProc} + TModuleUnloadProcLW = procedure (HInstance: LongWord); + {$EXTERNALSYM TModuleUnloadProcLW} + + PModuleUnloadRec = ^TModuleUnloadRec; + TModuleUnloadRec = record + Next: PModuleUnloadRec; + Proc: TModuleUnloadProcLW; + end; + +var + LibModuleList: PLibModule = nil; + ModuleUnloadList: PModuleUnloadRec = nil; + +procedure RegisterModule(LibModule: PLibModule); +{X+}// ************ UnregisterModule replacement ****************************** +{X+}// +{X+}// Standard Delphi UnregisterModule uses +{X+}// try-except and raise constructions, which leads to permanent +{X+}// usage of all exception handling routines. In this XCL-aware +{X+}// implementation, "light" version of UnregisterModule +{X+}// is used by default. To use standard Delphi +{X+}// UnregisterModule method, allowing to flow execution control +{X+}// include reference to SysSfIni.pas +{X+}// into uses clause *as first as possible*. +{X-}// procedure UnregisterModule(LibModule: PLibModule); -replaced with pointer to procedure +{X+}procedure UnregisterModuleSafely(LibModule: PLibModule); +{X+}procedure UnregisterModuleLight(LibModule: PLibModule); +{X+}var +{X+} UnregisterModule : procedure(LibModule: PLibModule) = UnregisterModuleLight; +{X+}// ************************************************************************ + +function FindHInstance(Address: Pointer): LongWord; +function FindClassHInstance(ClassType: TClass): LongWord; +function FindResourceHInstance(Instance: LongWord): LongWord; +function LoadResourceModule(ModuleName: PChar; CheckOwner: Boolean = True): LongWord; +procedure EnumModules(Func: TEnumModuleFunc; Data: Pointer); overload; +procedure EnumResourceModules(Func: TEnumModuleFunc; Data: Pointer); overload; +procedure EnumModules(Func: TEnumModuleFuncLW; Data: Pointer); overload; +procedure EnumResourceModules(Func: TEnumModuleFuncLW; Data: Pointer); overload; +procedure AddModuleUnloadProc(Proc: TModuleUnloadProc); overload; +procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProc); overload; +procedure AddModuleUnloadProc(Proc: TModuleUnloadProcLW); overload; +procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProcLW); overload; +{$IFDEF LINUX} +{ Given an HMODULE, this function will return its fully qualified name. There is + no direct equivalent in Linux so this function provides that capability. } +function GetModuleFileName(Module: HMODULE; Buffer: PChar; BufLen: Integer): Integer; +{$ENDIF} + +{ ResString support function/record } + +type + PResStringRec = ^TResStringRec; + TResStringRec = packed record + Module: ^Cardinal; + Identifier: Integer; + end; + +function LoadResString(ResStringRec: PResStringRec): string; + +{ Procedures and functions that need compiler magic } + +procedure _COS; +procedure _EXP; +procedure _INT; +procedure _SIN; +procedure _FRAC; +procedure _ROUND; +procedure _TRUNC; + +procedure _AbstractError; +procedure _Assert(const Message, Filename: AnsiString; LineNumber: Integer); +function _Append(var t: TTextRec): Integer; +function _Assign(var t: TTextRec; const S: String): Integer; +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); +function _EofFile(var f: TFileRec): Boolean; +function _EofText(var t: TTextRec): Boolean; +function _Eoln(var t: TTextRec): Boolean; +procedure _Erase(var f: TFileRec); + + + +function _FilePos(var f: TFileRec): Longint; +function _FileSize(var f: TFileRec): Longint; +procedure _FillChar(var Dest; count: Integer; Value: Char); +function _FreeMem(P: Pointer): Integer; +function _GetMem(Size: Integer): Pointer; +function _ReallocMem(var P: Pointer; NewSize: Integer): Pointer; +procedure _Halt(Code: Integer); +procedure _Halt0; + + + + + + + + +procedure Mark; deprecated; +procedure _PStrCmp; +procedure _AStrCmp; +procedure _RandInt; +procedure _RandExt; +function _ReadRec(var f: TFileRec; Buffer: Pointer): Integer; +function _ReadChar(var t: TTextRec): Char; +function _ReadLong(var t: TTextRec): Longint; +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); +procedure _ReadWString(var t: TTextRec; var s: WideString); +procedure _ReadWCString(var t: TTextRec; s: PWideChar; maxBytes: Longint); +function _ReadWChar(var t: TTextRec): WideChar; +function _ReadExt(var t: TTextRec): Extended; +procedure _ReadLn(var t: TTextRec); +procedure _Rename(var f: TFileRec; newName: PChar); +procedure Release; deprecated; +function _ResetText(var t: TTextRec): Integer; +function _ResetFile(var f: TFileRec; recSize: Longint): Integer; +function _RewritText(var t: TTextRec): Integer; +function _RewritFile(var f: TFileRec; recSize: Longint): Integer; +procedure _RunError(errorCode: Byte); +procedure _Run0Error; +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; +{$IFDEF LINUX} +procedure _UnhandledException; +{$ENDIF} +function _WriteRec(var f: TFileRec; buffer: Pointer): Pointer; +function _WriteChar(var t: TTextRec; c: Char; width: Integer): Pointer; +function _Write0Char(var t: TTextRec; c: Char): 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 _WriteString(var t: TTextRec; const s: ShortString; width: Longint): Pointer; +function _Write0String(var t: TTextRec; const s: ShortString): Pointer; +function _WriteCString(var t: TTextRec; s: PChar; width: Longint): Pointer; +function _Write0CString(var t: TTextRec; s: PChar): Pointer; +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 _WriteWCString(var t: TTextRec; s: PWideChar; width: Longint): Pointer; +function _Write0WCString(var t: TTextRec; s: PWideChar): Pointer; +function _WriteWChar(var t: TTextRec; c: WideChar; width: Integer): Pointer; +function _Write0WChar(var t: TTextRec; c: WideChar): Pointer; +function _WriteVariant(var T: TTextRec; const V: TVarData; Width: Integer): Pointer; +function _Write0Variant(var T: TTextRec; const V: TVarData): 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 __IOTest; +function _Flush(var t: TTextRec): Integer; + +procedure _SetElem; +procedure _SetRange; +procedure _SetEq; +procedure _SetLe; +procedure _SetIntersect; +procedure _SetIntersect3; { BEG only } +procedure _SetUnion; +procedure _SetUnion3; { BEG only } +procedure _SetSub; +procedure _SetSub3; { BEG only } +procedure _SetExpand; + +procedure _Str2Ext; +procedure _Str0Ext; +procedure _Str1Ext; +procedure _ValExt; +procedure _Pow10; +procedure _Real2Ext; +procedure _Ext2Real; + +procedure _ObjSetup; +procedure _ObjCopy; +procedure _Fail; +procedure _BoundErr; +procedure _IntOver; + +{ Module initialization context. For internal use only. } + +type + PInitContext = ^TInitContext; + TInitContext = record + OuterContext: PInitContext; { saved InitContext } +{$IFNDEF PC_MAPPED_EXCEPTIONS} + ExcFrame: Pointer; { bottom exc handler } +{$ENDIF} + InitTable: PackageInfo; { unit init info } + InitCount: Integer; { how far we got } + Module: PLibModule; { ptr to module desc } + DLLSaveEBP: Pointer; { saved regs for DLLs } + DLLSaveEBX: Pointer; { saved regs for DLLs } + DLLSaveESI: Pointer; { saved regs for DLLs } + DLLSaveEDI: Pointer; { saved regs for DLLs } +{$IFDEF MSWINDOWS} + ExitProcessTLS: procedure; { Shutdown for TLS } +{$ENDIF} + DLLInitState: Byte; { 0 = package, 1 = DLL shutdown, 2 = DLL startup } + end platform; + +type + TDLLProc = procedure (Reason: Integer); + // TDLLProcEx provides the reserved param returned by WinNT + TDLLProcEx = procedure (Reason: Integer; Reserved: Integer); + +{$IFDEF LINUX} +procedure _StartExe(InitTable: PackageInfo; Module: PLibModule; Argc: Integer; Argv: Pointer); +procedure _StartLib(Context: PInitContext; Module: PLibModule; DLLProc: TDLLProcEx); +{$ENDIF} +{$IFDEF MSWINDOWS} +procedure _StartExe(InitTable: PackageInfo; Module: PLibModule); +procedure _StartLib; +{$ENDIF} +procedure _PackageLoad(const Table : PackageInfo; Module: PLibModule); +procedure _PackageUnload(const Table : PackageInfo; Module: PLibModule); +procedure _InitResStrings; +procedure _InitResStringImports; +procedure _InitImports; +{$IFDEF MSWINDOWS} +procedure _InitWideStrings; +{$ENDIF} + +function _ClassCreate(AClass: TClass; Alloc: Boolean): TObject; +procedure _ClassDestroy(Instance: TObject); +function _AfterConstruction(Instance: TObject): TObject; +function _BeforeDestruction(Instance: TObject; OuterMost: ShortInt): TObject; +function _IsClass(Child: TObject; Parent: TClass): Boolean; +function _AsClass(Child: TObject; Parent: TClass): TObject; + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _RaiseAtExcept; +//procedure _DestroyException(Exc: PRaisedException); +procedure _DestroyException; +{$ENDIF} +procedure _RaiseExcept; +procedure _RaiseAgain; +procedure _DoneExcept; +{$IFNDEF PC_MAPPED_EXCEPTIONS} +procedure _TryFinallyExit; +{$ENDIF} +procedure _HandleAnyException; +procedure _HandleFinally; +procedure _HandleOnException; +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _HandleOnExceptionPIC; +{$ENDIF} +procedure _HandleAutoException; +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _ClassHandleException; +{$ENDIF} + +procedure _CallDynaInst; +procedure _CallDynaClass; +procedure _FindDynaInst; +procedure _FindDynaClass; + +procedure _LStrClr(var S); +procedure _LStrArrayClr(var StrArray; cnt: longint); +procedure _LStrAsg(var dest; const source); +procedure _LStrLAsg(var dest; const source); +procedure _LStrFromPCharLen(var Dest: AnsiString; Source: PAnsiChar; Length: 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 _LStrToPChar(const s: AnsiString): PChar; +procedure _Copy{ s : ShortString; index, count : Integer ) : ShortString}; +procedure _Delete{ var s : openstring; index, count : Integer }; +procedure _Insert{ source : ShortString; var s : openstring; index : Integer }; +procedure _Pos{ substr : ShortString; s : ShortString ) : Integer}; +procedure _SetLength(s: PShortString; newLength: Byte); +procedure _SetString(s: PShortString; buffer: PChar; len: Byte); + +procedure UniqueString(var str: AnsiString); overload; +procedure UniqueString(var str: WideString); overload; +procedure _UniqueStringA(var str: AnsiString); +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 _NewAnsiString(length: Longint): Pointer; { for debugger purposes only } +function _NewWideString(CharLength: Longint): Pointer; + +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); +function _WStrToPWChar(const S: WideString): PWideChar; +function _WStrLen(const S: WideString): Integer; +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); +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; + +procedure _Initialize(p: Pointer; typeInfo: Pointer); +procedure _InitializeArray(p: Pointer; typeInfo: Pointer; elemCount: Cardinal); +procedure _InitializeRecord(p: Pointer; typeInfo: Pointer); +procedure _Finalize(p: Pointer; typeInfo: Pointer); +procedure _FinalizeArray(p: Pointer; typeInfo: Pointer; elemCount: Cardinal); +procedure _FinalizeRecord(P: Pointer; typeInfo: Pointer); +procedure _AddRef; +procedure _AddRefArray; +procedure _AddRefRecord; +procedure _CopyArray; +procedure _CopyRecord; +procedure _CopyObject; + +function _New(size: Longint; typeInfo: Pointer): Pointer; +procedure _Dispose(p: Pointer; typeInfo: Pointer); + +{ 64-bit Integer helper routines } +procedure __llmul; +procedure __lldiv; +procedure __lludiv; +procedure __llmod; +procedure __llmulo; +procedure __lldivo; +procedure __llmodo; +procedure __llumod; +procedure __llshl; +procedure __llushr; +procedure _WriteInt64; +procedure _Write0Int64; +procedure _ReadInt64; +function _StrInt64(val: Int64; width: Integer): ShortString; +function _Str0Int64(val: Int64): ShortString; +function _ValInt64(const s: AnsiString; var code: Integer): Int64; + +{ Dynamic array helper functions } + +procedure _DynArrayHigh; +procedure _DynArrayClear(var a: Pointer; typeInfo: Pointer); +procedure _DynArrayLength; +procedure _DynArraySetLength; +procedure _DynArrayCopy(a: Pointer; typeInfo: Pointer; var Result: Pointer); +procedure _DynArrayCopyRange(a: Pointer; typeInfo: Pointer; index, count : Integer; var Result: Pointer); +procedure _DynArrayAsg; +procedure _DynArrayAddRef; + +procedure DynArrayClear(var a: Pointer; typeInfo: Pointer); +procedure DynArraySetLength(var a: Pointer; typeInfo: Pointer; dimCnt: Longint; lengthVec: PLongint); +function DynArrayDim(typeInfo: PDynArrayTypeInfo): Integer; +{$NODEFINE DynArrayDim} + +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); + +{$IFDEF MSWINDOWS} +procedure _FSafeDivide; +procedure _FSafeDivideR; +{$ENDIF} + +function _CheckAutoResult(ResultCode: HResult): HResult; + +procedure FPower10; + +procedure TextStart; deprecated; + +// Conversion utility routines for C++ convenience. Not for Delphi code. +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; + +{ Internal runtime error codes } + +type + TRuntimeError = (reNone, reOutOfMemory, reInvalidPtr, reDivByZero, + reRangeError, reIntOverflow, reInvalidOp, reZeroDivide, reOverflow, + reUnderflow, reInvalidCast, reAccessViolation, rePrivInstruction, + reControlBreak, reStackOverflow, + { reVar* used in Variants.pas } + reVarTypeCast, reVarInvalidOp, + reVarDispatch, reVarArrayCreate, reVarNotArray, reVarArrayBounds, + reAssertionFailed, + reExternalException, { not used here; in SysUtils } + reIntfCastError, reSafeCallError +{$IFDEF LINUX} + , reQuit, reCodesetConversion +{$ENDIF} + ); +{$NODEFINE TRuntimeError} + +procedure Error(errorCode: TRuntimeError); +{$NODEFINE Error} + +{ GetLastError returns the last error reported by an OS API call. Calling + this function usually resets the OS error state. +} + +function GetLastError: Integer; {$IFDEF MSWINDOWS} stdcall; {$ENDIF} +{$EXTERNALSYM GetLastError} + +{ SetLastError writes to the thread local storage area read by GetLastError. } + +procedure SetLastError(ErrorCode: Integer); {$IFDEF MSWINDOWS} stdcall; {$ENDIF} + +{$IFDEF LINUX} +{ To improve performance, some RTL routines cache module handles and data + derived from modules. If an application dynamically loads and unloads + shared object libraries, packages, or resource packages, it is possible for + the handle of the newly loaded module to match the handle of a recently + unloaded module. The resource caches have no way to detect when this happens. + + To address this issue, the RTL maintains an internal counter that is + incremented every time a module is loaded or unloaded using RTL functions + (like LoadPackage). This provides a cache version level signature that + can detect when modules have been cycled but have the same handle. + + If you load or unload modules "by hand" using dlopen or dlclose, you must call + InvalidateModuleCache after each load or unload so that the RTL module handle + caches will refresh themselves properly the next time they are used. This is + especially important if you manually tinker with the LibModuleList list of + loaded modules, or manually add or remove resource modules in the nodes + of that list. + + ModuleCacheID returns the "current generation" or version number kept by + the RTL. You can use this to implement your own refresh-on-next-use + (passive) module handle caches as the RTL does. The value changes each + time InvalidateModuleCache is called. +} + +function ModuleCacheID: Cardinal; +procedure InvalidateModuleCache; +{$ENDIF} +{X+} // ************ InitUnits replacement ****************************** +{X+} // +{X+} // Standard Delphi units initialization/finalization uses +{X+} // try-except and raise constructions, which leads to permanent +{X+} // usage of all exception handling routines. In this XCL-aware +{X+} // implementation, "light" version of initialization/finalization +{X+} // is used by default. To use standard Delphi initialization and +{X+} // finalization method, allowing to flow execution control even +{X+} // in initalization sections, include reference to SysSfIni.pas +{X+} // into uses clause *as first as possible*. +{X+}procedure InitUnitsLight( Table : PUnitEntryTable; Idx, Count : Integer ); +{X+}procedure FinitUnitsLight; +{X+}procedure InitUnitsHard( Table : PUnitEntryTable; Idx, Count : Integer ); +{X+}var +{X+} InitUnitsProc : procedure( Table : PUnitEntryTable; Idx, Count : Integer ) +{X+} = InitUnitsLight; +{X+}procedure FinitUnitsHard; +{X+}var +{X+} FinitUnitsProc : procedure = FInitUnitsLight; + +{X+}// *********************************************************************** +{X+}// moved here from SysInit.pas - by advise of Alexey Torgashin - to avoid +{X+}// creating of separate import block from kernel32.dll : } +{X+}function FreeLibrary(ModuleHandle: Longint): LongBool; stdcall; +{X+}function GetModuleFileName(Module: Integer; Filename: PChar; Size: Integer): Integer; stdcall; +{X+}function GetModuleHandle(ModuleName: PChar): Integer; stdcall; +{X+}function LocalAlloc(flags, size: Integer): Pointer; stdcall; +{X+}function LocalFree(addr: Pointer): Pointer; stdcall; +{X+}function TlsAlloc: Integer; stdcall; +{X+}function TlsFree(TlsIndex: Integer): Boolean; stdcall; +{X+}function TlsGetValue(TlsIndex: Integer): Pointer; stdcall; +{X+}function TlsSetValue(TlsIndex: Integer; TlsValue: Pointer): Boolean; stdcall; +{X+}function GetCommandLine: PChar; stdcall; +{X+}// *********************************************************************** + +{X+} // if your app uses FPU, call one of following procedures: +{X+} procedure FpuInit; +{X+} procedure FpuInitConsiderNECWindows; +{X+} // the second additionally takes into consideration NEC +{X+} // Windows keyboard (Japaneeze keyboard ???). + +{X+} procedure DummyProc; // empty procedure +{X+} procedure SetExceptionHandler; +{X+} procedure UnsetExceptionHandler; +{X+} var UnsetExceptionHandlerProc : procedure = DummyProc; + +{X+} var UnloadResProc: procedure = DummyProc; + +{X+} procedure WStrAddRef; +{X+} // procedure to refer to _WStrAddRef if SysWStr.pas is in use +{X+} var WStrAddRefProc : procedure = DummyProc; + +{X+} procedure WStrClr; +{X+} // procedure to refer to _WStrClr if SysWStr.pas is in use +{X+} var WStrClrProc : procedure = DummyProc; + +{X+} procedure WStrArrayClr; +{X+} // procedure to refer to _WStrArrayClr if SysWStr.pas is in use +{X+} var WStrArrayClrProc : procedure = DummyProc; + + +(* =================================================================== *) + +implementation + +uses + SysInit; + +{X+}// Moved here from below +{X+}const +{X+} advapi32 = 'advapi32.dll'; +{X+} kernel = 'kernel32.dll'; +{X+} user = 'user32.dll'; +{X+} oleaut = 'oleaut32.dll'; +{X+} +{X+}function GetProcessHeap; external kernel name 'GetProcessHeap'; +{X+}function HeapAlloc; stdcall; external kernel name 'HeapAlloc'; +{X+}function HeapReAlloc; stdcall; external kernel name 'HeapReAlloc'; +{X+}function HeapFree; stdcall; external kernel name 'HeapFree'; + +{X+}// *********************************************************************** +{X+}// moved here from SysInit.pas - by advise of Alexey Torgashin - to avoid +{X+}// creating of separate import block from kernel32.dll : } +{X+}function TlsAlloc: Integer; stdcall; external kernel name 'TlsAlloc'; +{X+}function TlsFree(TlsIndex: Integer): Boolean; stdcall; +{X+} external kernel name 'TlsFree'; +{X+}function TlsGetValue(TlsIndex: Integer): Pointer; stdcall; +{X+} external kernel name 'TlsGetValue'; +{X+}function TlsSetValue(TlsIndex: Integer; TlsValue: Pointer): Boolean; stdcall; +{X+} external kernel name 'TlsSetValue'; +{X+}// *********************************************************************** + +{ 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; + +{$IFDEF PIC} +function GetGOT: LongWord; export; +begin + asm + MOV Result,EBX + end; +end; +{$ENDIF} + +{$IFDEF PC_MAPPED_EXCEPTIONS} +const + UNWINDFI_TOPOFSTACK = $BE00EF00; + +const +{$IFDEF MSWINDOWS} + 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'; +{$ENDIF} +{$IFDEF LINUX} + unwind = 'libborunwind.so.6'; +type + UNWINDPROC = Pointer; + +//{$DEFINE STATIC_UNWIND} + +{$IFDEF STATIC_UNWIND} +function _BorUnwind_RegisterIPLookup(fn: UNWINDPROC; StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; cdecl; + external; + +procedure _BorUnwind_UnregisterIPLookup(StartAddr: LongInt); cdecl; external; + +function _BorUnwind_DelphiLookup(Addr: LongInt; Context: Pointer): UNWINDPROC; cdecl; external; + +function _BorUnwind_RaiseException(Exc: Pointer): LongBool; cdecl; external; + +//function _BorUnwind_AddressIsInPCMap(Addr: LongInt): LongBool; cdecl; external; +function _BorUnwind_ClosestDelphiHandler(Context: Pointer): LongWord; cdecl; external; +{$ELSE} + +function _BorUnwind_RegisterIPLookup(fn: UNWINDPROC; StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; cdecl; + external unwind name '_BorUnwind_RegisterIPLookup'; + +procedure _BorUnwind_UnregisterIPLookup(StartAddr: LongInt); cdecl; + external unwind name '_BorUnwind_UnregisterIPLookup'; + +function _BorUnwind_DelphiLookup(Addr: LongInt; Context: Pointer): UNWINDPROC; cdecl; + external unwind name '_BorUnwind_DelphiLookup'; + +function _BorUnwind_RaiseException(Exc: Pointer): LongBool; cdecl; + external unwind name '_BorUnwind_RaiseException'; + +function _BorUnwind_ClosestDelphiHandler(Context: Pointer): LongWord; cdecl; + external unwind name '_BorUnwind_ClosestDelphiHandler'; +{$ENDIF} +{$ENDIF} +{$ENDIF} + +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 LINUX} +const + libc = 'libc.so.6'; + libdl = 'libdl.so.2'; + libpthread = 'libpthread.so.0'; + + O_RDONLY = $0000; + O_WRONLY = $0001; + O_RDWR = $0002; + O_CREAT = $0040; + O_EXCL = $0080; + O_NOCTTY = $0100; + O_TRUNC = $0200; + O_APPEND = $0400; + + // protection flags + S_IREAD = $0100; // Read by owner. + S_IWRITE = $0080; // Write by owner. + S_IEXEC = $0040; // Execute by owner. + S_IRUSR = S_IREAD; + S_IWUSR = S_IWRITE; + S_IXUSR = S_IEXEC; + S_IRWXU = S_IRUSR or S_IWUSR or S_IXUSR; + + S_IRGRP = S_IRUSR shr 3; // Read by group. + S_IWGRP = S_IWUSR shr 3; // Write by group. + S_IXGRP = S_IXUSR shr 3; // Execute by group. + S_IRWXG = S_IRWXU shr 3; // Read, write, and execute by group. + + S_IROTH = S_IRGRP shr 3; // Read by others. + S_IWOTH = S_IWGRP shr 3; // Write by others. + S_IXOTH = S_IXGRP shr 3; // Execute by others. + S_IRWXO = S_IRWXG shr 3; // Read, write, and execute by others. + + STDIN_FILENO = 0; + STDOUT_FILENO = 1; + STDERR_FILENO = 2; + + SEEK_SET = 0; + SEEK_CUR = 1; + SEEK_END = 2; + + LC_CTYPE = 0; + _NL_CTYPE_CODESET_NAME = LC_CTYPE shl 16 + 14; + + MAX_PATH = 4095; + + +function __open(PathName: PChar; Flags: Integer; Mode: Integer): Integer; cdecl; + external libc name 'open'; + +function __close(Handle: Integer): Integer; cdecl; + external libc name 'close'; + +function __read(Handle: Integer; Buffer: Pointer; Count: Cardinal): Cardinal; cdecl; + external libc name 'read'; + +function __write(Handle: Integer; Buffer: Pointer; Count: Cardinal): Cardinal; cdecl; + external libc name 'write'; + +function __mkdir(PathName: PChar; Mode: Integer): Integer; cdecl; + external libc name 'mkdir'; + +function __getcwd(Buffer: PChar; BufSize: Integer): PChar; cdecl; + external libc name 'getcwd'; + +function __getenv(Name: PChar): PChar; cdecl; + external libc name 'getenv'; + +function __chdir(PathName: PChar): Integer; cdecl; + external libc name 'chdir'; + +function __rmdir(PathName: PChar): Integer; cdecl; + external libc name 'rmdir'; + +function __remove(PathName: PChar): Integer; cdecl; + external libc name 'remove'; + +function __rename(OldPath, NewPath: PChar): Integer; cdecl; + external libc name 'rename'; + +function strlen(OldPath, NewPath: PChar): Integer; cdecl; + external libc name 'strlen'; + +procedure memcpy(Dest: Pointer; Source: Pointer; N: Integer); cdecl; + external libc name 'memcpy'; + +{$IFDEF EFENCE} +function __malloc(Size: Integer): Pointer; cdecl; + external 'libefence.so' name 'malloc'; + +procedure __free(P: Pointer); cdecl; + external 'libefence.so' name 'free'; + +function __realloc(P: Pointer; Size: Integer): Pointer; cdecl; + external 'libefence.so' name 'realloc'; +{$ELSE} +function __malloc(Size: Integer): Pointer; cdecl; + external libc name 'malloc'; + +procedure __free(P: Pointer); cdecl; + external libc name 'free'; + +function __realloc(P: Pointer; Size: Integer): Pointer; cdecl; + external libc name 'realloc'; +{$ENDIF} + +procedure ExitProcess(status: Integer); cdecl; + external libc name 'exit'; + +function _time(P: Pointer): Integer; cdecl; + external libc name 'time'; + +function _lseek(Handle, Offset, Direction: Integer): Integer; cdecl; + external libc name 'lseek'; + +function _ftruncate(Handle: Integer; Filesize: Integer): Integer; cdecl; + external libc name 'ftruncate'; + +function strcasecmp(s1, s2: PChar): Integer; cdecl; + external libc name 'strcasecmp'; + +function __errno_location: PInteger; cdecl; + external libc name '__errno_location'; + +function nl_langinfo(item: integer): pchar; cdecl; + external libc name 'nl_langinfo'; + +function iconv_open(ToCode: PChar; FromCode: PChar): Integer; cdecl; + external libc name 'iconv_open'; + +function iconv(cd: Integer; var InBuf; var InBytesLeft: Integer; var OutBuf; var OutBytesLeft: Integer): Integer; cdecl; + external libc name 'iconv'; + +function iconv_close(cd: Integer): Integer; cdecl; + external libc name 'iconv_close'; + +function mblen(const S: PChar; N: LongWord): Integer; cdecl; + external libc name 'mblen'; + +function mmap(start: Pointer; length: Cardinal; prot, flags, fd, offset: Integer): Pointer; cdecl; + external libc name 'mmap'; + +function munmap(start: Pointer; length: Cardinal): Integer; cdecl; + external libc name 'munmap'; + +const + SIGABRT = 6; + +function __raise(SigNum: Integer): Integer; cdecl; + external libc name 'raise'; + +type + TStatStruct = record + st_dev: Int64; // device + __pad1: Word; + st_ino: Cardinal; // inode + st_mode: Cardinal; // protection + st_nlink: Cardinal; // number of hard links + st_uid: Cardinal; // user ID of owner + st_gid: Cardinal; // group ID of owner + st_rdev: Int64; // device type (if inode device) + __pad2: Word; + st_size: Cardinal; // total size, in bytes + st_blksize: Cardinal; // blocksize for filesystem I/O + st_blocks: Cardinal; // number of blocks allocated + st_atime: Integer; // time of last access + __unused1: Cardinal; + st_mtime: Integer; // time of last modification + __unused2: Cardinal; + st_ctime: Integer; // time of last change + __unused3: Cardinal; + __unused4: Cardinal; + __unused5: Cardinal; + end; + +const + STAT_VER_LINUX = 3; + +function _fxstat(Version: Integer; Handle: Integer; var Stat: TStatStruct): Integer; cdecl; + external libc name '__fxstat'; + +function __xstat(Ver: Integer; FileName: PChar; var StatBuffer: TStatStruct): Integer; cdecl; + external libc name '__xstat'; + +function _strlen(P: PChar): Integer; cdecl; + external libc name 'strlen'; + +function _readlink(PathName: PChar; Buf: PChar; Len: Integer): Integer; cdecl; + external libc name 'readlink'; + +type + TDLInfo = record + FileName: PChar; + BaseAddress: Pointer; + NearestSymbolName: PChar; + SymbolAddress: Pointer; + end; + +const + RTLD_LAZY = 1; + RTLD_NOW = 2; + +function dladdr(Address: Pointer; var Info: TDLInfo): Integer; cdecl; + external libdl name 'dladdr'; +function dlopen(Filename: PChar; Flag: Integer): LongWord; cdecl; + external libdl name 'dlopen'; +function dlclose(Handle: LongWord): Integer; cdecl; + external libdl name 'dlclose'; +function FreeLibrary(Handle: LongWord): Integer; cdecl; + external libdl name 'dlclose'; +function dlsym(Handle: LongWord; Symbol: PChar): Pointer; cdecl; + external libdl name 'dlsym'; +function dlerror: PChar; cdecl; + external libdl name 'dlerror'; + +type + TPthread_fastlock = record + __status: LongInt; + __spinlock: Integer; + end; + + TRTLCriticalSection = record + __m_reserved, + __m_count: Integer; + __m_owner: Pointer; + __m_kind: Integer; // __m_kind := 0 fastlock, __m_kind := 1 recursive lock + __m_lock: TPthread_fastlock; + end; + +function _pthread_mutex_lock(var Mutex: TRTLCriticalSection): Integer; cdecl; + external libpthread name 'pthread_mutex_lock'; +function _pthread_mutex_unlock(var Mutex: TRTLCriticalSection): Integer; cdecl; + external libpthread name 'pthread_mutex_unlock'; +function _pthread_create(var ThreadID: Cardinal; Attr: PThreadAttr; + TFunc: TThreadFunc; Arg: Pointer): Integer; cdecl; + external libpthread name 'pthread_create'; +function _pthread_exit(var RetVal: Integer): Integer; cdecl; + external libpthread name 'pthread_exit'; +function GetCurrentThreadID: LongWord; cdecl; + external libpthread name 'pthread_self'; +function _pthread_detach(ThreadID: Cardinal): Integer; cdecl; + external libpthread name 'pthread_detach' + +function GetLastError: Integer; +begin + Result := __errno_location^; +end; + +procedure SetLastError(ErrorCode: Integer); +begin + __errno_location^ := ErrorCode; +end; + +function InterlockedIncrement(var I: Integer): Integer; +asm + MOV EDX,1 + XCHG EAX,EDX + LOCK XADD [EDX],EAX + INC EAX +end; + +function InterlockedDecrement(var I: Integer): Integer; +asm + MOV EDX,-1 + XCHG EAX,EDX + LOCK XADD [EDX],EAX + DEC EAX +end; + +var + ModuleCacheVersion: Cardinal = 0; + +function ModuleCacheID: Cardinal; +begin + Result := ModuleCacheVersion; +end; + +procedure InvalidateModuleCache; +begin + InterlockedIncrement(Integer(ModuleCacheVersion)); +end; + +{$ENDIF} + +{$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 +{X+}// Moved up.... +{X-}// advapi32 = 'advapi32.dll'; +{X-}// kernel = 'kernel32.dll'; +{X-}// user = 'user32.dll'; +{X-}// 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'; + + +{X}function CmdShow: Integer;//GetCmdShow: Integer; +var + SI: TStartupInfo; +begin + Result := 10; { SW_SHOWDEFAULT } + GetStartupInfo(SI); + if SI.dwFlags and 1 <> 0 then { STARTF_USESHOWWINDOW } + Result := SI.wShowWindow; +end; + +{X+}// convert var CmdLine : PChar to a function: +{X+}function CmdLine : PChar; +{X+}begin +{X+} Result := GetCommandLine; +{X+}end; +var + DefaultUserCodePage: Integer; + +{$ENDIF} // MSWindows + +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} + +{X+}// ****** This code is from HeapMM.pas, (C) by Vladimir Kladov, 2001**** +{X+}const +{X+} HEAP_NO_SERIALIZE = $00001; +{X+} HEAP_GROWABLE = $00002; +{X+} HEAP_GENERATE_EXCEPTIONS = $00004; +{X+} HEAP_ZERO_MEMORY = $00008; +{X+} HEAP_REALLOC_IN_PLACE_ONLY = $00010; +{X+} HEAP_TAIL_CHECKING_ENABLED = $00020; +{X+} HEAP_FREE_CHECKING_ENABLED = $00040; +{X+} HEAP_DISABLE_COALESCE_ON_FREE = $00080; +{X+} HEAP_CREATE_ALIGN_16 = $10000; +{X+} HEAP_CREATE_ENABLE_TRACING = $20000; +{X+} HEAP_MAXIMUM_TAG = $00FFF; +{X+} HEAP_PSEUDO_TAG_FLAG = $08000; +{X+} HEAP_TAG_SHIFT = 16 ; +{X+} +{X+}{$DEFINE USE_PROCESS_HEAP} +{X+} +{X+}var +{X+} HeapHandle: THandle; +{X+} {* Global handle to the heap. Do not change it! } +{X+} +{X+} HeapFlags: DWORD = 0; +{X+}// Possible flags are: +{X+}// HEAP_GENERATE_EXCEPTIONS - system will raise an exception to indicate a +{X+}// function failure, such as an out-of-memory +{X+}// condition, instead of returning NULL. +{X+}// HEAP_NO_SERIALIZE - mutual exclusion will not be used while the HeapAlloc +{X+}// function is accessing the heap. Be careful! +{X+}// Not recommended for multi-thread applications. +{X+}// But faster. +{X+}// HEAP_ZERO_MEMORY - obviously. (Slower!) +{X+} +{X+}// Note from MSDN: +{X+}// The granularity of heap allocations in Win32 is 16 bytes. So if you +{X+}// request a global memory allocation of 1 byte, the heap returns a pointer +{X+}// to a chunk of memory, guaranteeing that the 1 byte is available. Chances +{X+}// are, 16 bytes will actually be available because the heap cannot allocate +{X+}// less than 16 bytes at a time. +{X+} +{X+}function DfltGetMem(size: Integer): Pointer; +{X+}// Allocate memory block. +{X+}begin +{X+} Result := HeapAlloc( HeapHandle, HeapFlags, size ); +{X+}end; +{X+} +{X+}function DfltFreeMem(p: Pointer): Integer; +{X+}// Deallocate memory block. +{X+}begin +{X+} Result := Integer( not HeapFree( HeapHandle, HeapFlags and HEAP_NO_SERIALIZE, +{X+} p ) ); +{X+}end; +{X+} +{X+}function DfltReallocMem(p: Pointer; size: Integer): Pointer; +{X+}// Resize memory block. +{X+}begin +{X+} Result := HeapRealloc( HeapHandle, HeapFlags and (HEAP_NO_SERIALIZE and +{X+} HEAP_GENERATE_EXCEPTIONS and HEAP_ZERO_MEMORY), +{X+} // (Prevent using flag HEAP_REALLOC_IN_PLACE_ONLY here - to allow +{X+} // system to move the block if necessary). +{X+} p, size ); +{X+}end; +{X+} +{X+}// ********************************end of HeapMM + +{$IFDEF LINUX} +function SysGetMem(Size: Integer): Pointer; +begin + Result := __malloc(size); +end; + +function SysFreeMem(P: Pointer): Integer; +begin + __free(P); + Result := 0; +end; + +function SysReallocMem(P: Pointer; Size: Integer): Pointer; +begin + Result := __realloc(P, Size); +end; + +{$ENDIF} + +var + MemoryManager: TMemoryManager = ( +{X} GetMem: DfltGetMem; +{X} FreeMem: DfltFreeMem; +{X} ReallocMem: DfltReallocMem); + +{X+}// by default, system memory allocation routines (API calls) +{X+}// are used. To use Inprise's memory manager (Delphi standard) +{X+}// call UseDelphiMemoryManager procedure. +{X+}const +{X+} DelphiMemoryManager: TMemoryManager = ( +{X+} GetMem: SysGetMem; +{X+} FreeMem: SysFreeMem; +{X+} ReallocMem: SysReallocMem); +{X+} +{X+}procedure UseDelphiMemoryManager; +{X+}begin +{X+} IsMemoryManagerSet := IsDelphiMemoryManagerSet; +{X+} SetMemoryManager( DelphiMemoryManager ); +{X+}end; +{X+} + +{$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} + +{X+}{$IFDEF MSWINDOWS} +{X+}function _GetMem(Size: Integer): Pointer; +{X+}asm +{X+} TEST EAX,EAX +{X+} JE @@1 +{X+} CALL MemoryManager.GetMem +{X+} OR EAX,EAX +{X+} JE @@2 +{X+}@@1: RET +{X+}@@2: MOV AL,reOutOfMemory +{X+} JMP Error +{X+}end; +{X+}{$ELSE} +function _GetMem(Size: Integer): Pointer; +{$IF Defined(DEBUG) and Defined(LINUX)} +var + Signature: PLongInt; +{$IFEND} +begin + if Size > 0 then + begin +{$IF Defined(DEBUG) and Defined(LINUX)} + Signature := PLongInt(MemoryManager.GetMem(Size + 4)); + if Signature = nil then + Error(reOutOfMemory); + Signature^ := 0; + Result := Pointer(LongInt(Signature) + 4); +{$ELSE} + Result := MemoryManager.GetMem(Size); + if Result = nil then + Error(reOutOfMemory); +{$IFEND} + end + else + Result := nil; +end; +{X+}{$ENDIF MSWINDOWS} + +const + FreeMemorySignature = Longint($FBEEFBEE); + +{X+}{$IFDEF MSWINDOWS} +{X+}function _FreeMem(P: Pointer): Integer; +{X+}asm +{X+} TEST EAX,EAX +{X+} JE @@1 +{X+} CALL MemoryManager.FreeMem +{X+} OR EAX,EAX +{X+} JNE @@2 +{X+}@@1: RET +{X+}@@2: MOV AL,reInvalidPtr +{X+} JMP Error +{X+}end; +{X+}{$ELSE} +function _FreeMem(P: Pointer): Integer; +{$IF Defined(DEBUG) and Defined(LINUX)} +var + Signature: PLongInt; +{$IFEND} +begin + if P <> nil then + begin +{$IF Defined(DEBUG) and Defined(LINUX)} + Signature := PLongInt(LongInt(P) - 4); + if Signature^ <> 0 then + Error(reInvalidPtr); + Signature^ := FreeMemorySignature; + Result := MemoryManager.Freemem(Pointer(Signature)); +{$ELSE} + Result := MemoryManager.FreeMem(P); +{$IFEND} + if Result <> 0 then + Error(reInvalidPtr); + end + else + Result := 0; +end; +{X+}{$ENDIF MSWINDOWS} + +{$IFDEF LINUX} +function _ReallocMem(var P: Pointer; NewSize: Integer): Pointer; +{$IFDEF DEBUG} +var + Temp: Pointer; +{$ENDIF} +begin + if P <> nil then + begin +{$IFDEF DEBUG} + Temp := Pointer(LongInt(P) - 4); + if NewSize > 0 then + begin + Temp := MemoryManager.ReallocMem(Temp, NewSize + 4); + Result := Pointer(LongInt(Temp) + 4); + end + else + begin + MemoryManager.FreeMem(Temp); + Result := nil; + end; +{$ELSE} + if NewSize > 0 then + begin + Result := MemoryManager.ReallocMem(P, NewSize); + end + else + begin + if MemoryManager.FreeMem(P) <> 0 then + Error(reInvalidPtr); + Result := nil; + end; +{$ENDIF} + P := Result; + end else + begin + Result := _GetMem(NewSize); + P := Result; + end; +end; +{$ELSEIF Defined(MSWINDOWS)} +function _ReallocMem(var P: Pointer; NewSize: Integer): Pointer; +asm + MOV ECX,[EAX] + TEST ECX,ECX + JE @@alloc + TEST EDX,EDX + JE @@free +@@resize: + PUSH EAX + MOV EAX,ECX + CALL MemoryManager.ReallocMem + POP ECX + OR EAX,EAX + JE @@allocError + MOV [ECX],EAX + RET +@@freeError: + MOV AL,reInvalidPtr + JMP Error +@@free: + MOV [EAX],EDX + MOV EAX,ECX + CALL MemoryManager.FreeMem + OR EAX,EAX + JNE @@freeError + RET +@@allocError: + MOV AL,reOutOfMemory + JMP Error +@@alloc: + TEST EDX,EDX + JE @@exit + PUSH EAX + MOV EAX,EDX + CALL MemoryManager.GetMem + POP ECX + OR EAX,EAX + JE @@allocError + MOV [ECX],EAX +@@exit: +end; +{$IFEND} + +procedure GetMemoryManager(var MemMgr: TMemoryManager); +begin + MemMgr := MemoryManager; +end; + +procedure SetMemoryManager(const MemMgr: TMemoryManager); +begin + MemoryManager := MemMgr; +end; + +{X+}// - function is replaced with pointer to one. +{X-}// function IsMemoryManagerSet: Boolean; +{X+}function IsDelphiMemoryManagerSet: Boolean; +begin + with MemoryManager do + Result := (@GetMem <> @SysGetMem) or (@FreeMem <> @SysFreeMem) or + (@ReallocMem <> @SysReallocMem); +end; + +{X+}// always returns False. Initial handler for IsMemoryManagerSet +{X+}function MemoryManagerNotUsed : Boolean; +{X+}begin +{X+} Result := False; +{X+}end; + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure GetUnwinder(var Dest: TUnwinder); +begin + Dest := Unwinder; +end; + +procedure SetUnwinder(const NewUnwinder: TUnwinder); +begin + Unwinder := NewUnwinder; +end; + +function IsUnwinderSet: Boolean; +begin + with Unwinder do + Result := (@RaiseException <> @_BorUnwind_RaiseException) or + (@RegisterIPLookup <> @_BorUnwind_RegisterIPLookup) or + (@UnregisterIPLookup <> @_BorUnwind_UnregisterIPLookup) or + (@DelphiLookup <> @_BorUnwind_DelphiLookup); +end; + +procedure InitUnwinder; +var + Addr: Pointer; +begin + { + We look to see if we can find a dynamic version of the unwinder. This + will be the case if the application used ShareExcept.pas. If it is + present, then we fire it up. Otherwise, we use our static copy. + } + Addr := dlsym(0, '_BorUnwind_RegisterIPLookup'); + if Addr <> nil then + begin + Unwinder.RegisterIPLookup := Addr; + Addr := dlsym(0, '_BorUnwind_UnregisterIPLookup'); + Unwinder.UnregisterIPLookup := Addr; + Addr := dlsym(0, '_BorUnwind_RaiseException'); + Unwinder.RaiseException := Addr; + Addr := dlsym(0, '_BorUnwind_DelphiLookup'); + Unwinder.DelphiLookup := Addr; + Addr := dlsym(0, '_BorUnwind_ClosestDelphiHandler'); + Unwinder.ClosestHandler := Addr; + end + else + begin + dlerror; // clear error state; dlsym doesn't + Unwinder.RegisterIPLookup := _BorUnwind_RegisterIPLookup; + Unwinder.DelphiLookup := _BorUnwind_DelphiLookup; + Unwinder.UnregisterIPLookup := _BorUnwind_UnregisterIPLookup; + Unwinder.RaiseException := _BorUnwind_RaiseException; + Unwinder.ClosestHandler := _BorUnwind_ClosestDelphiHandler; + end; +end; + +function SysClosestDelphiHandler(Context: Pointer): LongWord; +begin + if not Assigned(Unwinder.ClosestHandler) then + InitUnwinder; + Result := Unwinder.ClosestHandler(Context); +end; + +function SysRegisterIPLookup(StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; +begin +// xxx + if not Assigned(Unwinder.RegisterIPLookup) then + begin + InitUnwinder; +// Unwinder.RegisterIPLookup := UnwindRegisterIPLookup; +// Unwinder.DelphiLookup := UnwindDelphiLookup; + end; + Result := Unwinder.RegisterIPLookup(@Unwinder.DelphiLookup, StartAddr, EndAddr, Context, GOT); +end; + +procedure SysUnregisterIPLookup(StartAddr: LongInt); +begin +// if not Assigned(Unwinder.UnregisterIPLookup) then +// Unwinder.UnregisterIPLookup := UnwindUnregisterIPLookup; + Unwinder.UnregisterIPLookup(StartAddr); +end; + +function SysRaiseException(Exc: Pointer): LongBool; export; +var + uexc: _Unwind_Exception; +begin + uexc.exception_class := UW_EXC_CLASS_BORLANDDELPHI; + uexc.private_1 := _Unwind_Word(Exc); + uexc.private_2 := 0; + Result := Unwinder.RaiseException(@uexc); +end; + + +// SysRaiseCPPException +// Called to reraise a C++ exception that is unwinding through pascal code. +function SysRaiseCPPException(Exc: Pointer; priv2: Pointer; cls: LongWord): LongBool; +var + uexc: _Unwind_Exception; +begin + uexc.exception_class := cls; + uexc.private_1 := _Unwind_Word(Exc); + uexc.private_2 := _Unwind_Word(priv2); + Result := Unwinder.RaiseException(@uexc); +end; + +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; + +{$IFDEF PUREPASCAL} +var + notimpl: array [0..15] of Char = 'not implemented'#10; + +procedure NotImplemented; +begin + __write (2, @notimpl, 16); + Halt; +end; +{$ENDIF} + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure BlockOSExceptions; +asm + PUSH EAX + PUSH EDX + CALL SysInit.@GetTLS + MOV [EAX].OSExceptionsBlocked, 1 + POP EDX + POP EAX +end; + +procedure UnblockOSExceptions; +asm + CALL SysInit.@GetTLS + MOV [EAX].OSExceptionsBlocked, 0 +end; + +// Access to a TLS variable. Note the comment in BeginThread before +// you change the implementation of this function. +function AreOSExceptionsBlocked: Boolean; +asm + CALL SysInit.@GetTLS + MOV EAX, [EAX].OSExceptionsBlocked +end; + +const + TRAISEDEXCEPTION_SIZE = SizeOf(TRaisedException); + +function CurrentException: PRaisedException; +asm + CALL SysInit.@GetTLS + LEA EDX, [EAX].ExceptionObjects + MOV EAX, [EAX].ExceptionObjectCount + OR EAX, EAX + JE @@Done + DEC EAX + IMUL EAX, TRAISEDEXCEPTION_SIZE + ADD EAX, EDX + JMP @@Exit +@@Done: + CALL SysInit.@GetTLS + MOV EAX,[EAX].ExceptionList +@@Exit: +end; + +function CurrentPrivateException: PRaisedException; +asm + CALL SysInit.@GetTLS + LEA EDX, [EAX].ExceptionObjects + MOV EAX, [EAX].ExceptionObjectCount + OR EAX, EAX + JE @@Done + DEC EAX + IMUL EAX, TRAISEDEXCEPTION_SIZE + ADD EAX, EDX +@@Done: +end; + +{ + 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; +asm + CALL CurrentPrivateException + OR EAX, EAX + JE @@Error + { EAX -> the TRaisedException } + XOR ECX, ECX + { If the exception object has been referenced, we don't return it. } + CMP [EAX].TRaisedException.RefCount, 0 + JA @@GotObject + MOV ECX, [EAX].TRaisedException.ExceptObject +@@GotObject: + PUSH ECX + CALL SysInit.@GetTLS + POP ECX + DEC [EAX].ExceptionObjectCount + MOV EAX, ECX + RET +@@Error: + CALL SysInit.@GetTLS + MOV EAX, [EAX].ExceptionList + CALL [EAX].TRaisedException.Cleanup + RET +end; + +procedure ReleaseDelphiException; +begin + FreeException; +end; + +function AllocateException(Exception: Pointer; ExceptionAddr: Pointer): PRaisedException; +asm +{$IFDEF PIC} + PUSH EBX + PUSH EAX + PUSH EDX + CALL GetGOT + MOV EBX,EAX +{$ELSE} + PUSH EAX + PUSH EDX +{$ENDIF} + CALL SysInit.@GetTLS + CMP [EAX].ExceptionObjectCount, MAX_NESTED_EXCEPTIONS-1 + JE @@TooManyNestedExceptions + INC [EAX].ExceptionObjectCount + CALL CurrentException + POP EDX + POP ECX + MOV [EAX].TRaisedException.ExceptObject, ECX + MOV [EAX].TRaisedException.ExceptionAddr, EDX + MOV [EAX].TRaisedException.RefCount, 0 + MOV [EAX].TRaisedException.HandlerEBP, $FFFFFFFF + MOV [EAX].TRaisedException.Flags, 0 + MOV [EAX].TRaisedException.Prev, 0 +{$IFDEF PIC} + LEA EDX,[EBX].OFFSET FreeException +{$ELSE} + LEA EDX, FreeException +{$ENDIF} + MOV [EAX].TRaisedException.Cleanup, EDX +{$IFDEF PIC} + LEA EDX,[EBX].OFFSET FreeException + LEA EDX, ReleaseDelphiException +{$ELSE} + LEA EDX, ReleaseDelphiException +{$ENDIF} + MOV [EAX].TRaisedException.ReleaseProc, EDX +{$IFDEF PIC} + POP EBX +{$ENDIF} + RET +@@TooManyNestedExceptions: + MOV EAX, 231 + JMP _RunError +end; + +function AcquireExceptionObject: Pointer; +asm + CALL CurrentException + OR EAX, EAX + JE @@Error + INC [EAX].TRaisedException.RefCount + MOV EAX, [EAX].TRaisedException.ExceptObject + RET +@@Error: + { This happens if there is no exception pending } + JMP _Run0Error +end; + +procedure ReleaseExceptionObject; +asm + CALL CurrentException + OR EAX, EAX + JE @@Error + CMP [EAX].TRaisedException.RefCount, 0 + JE @@Error + DEC [EAX].TRaisedException.RefCount + RET +@@Error: + +{ + This happens if there is no exception pending, or + if the reference count on a pending exception is + zero. +} + JMP _Run0Error +end; + +function ExceptObject: TObject; +var + Exc: PRaisedException; +begin + Exc := CurrentException; + if Exc <> nil then + Result := TObject(Exc^.ExceptObject) + else + Result := nil; +end; + +{ Return current exception address } + +function ExceptAddr: Pointer; +var + Exc: PRaisedException; +begin + Exc := CurrentException; + if Exc <> nil then + Result := Exc^.ExceptionAddr + else + Result := nil; +end; +{$ELSE} {not PC_MAPPED_EXCEPTIONS} + +function ExceptObject: TObject; +begin + if RaiseListPtr <> nil then + Result := PRaiseFrame(RaiseListPtr)^.ExceptObject + else + Result := nil; +end; + +{ Return current exception address } + +function ExceptAddr: Pointer; +begin + if RaiseListPtr <> nil then + Result := PRaiseFrame(RaiseListPtr)^.ExceptAddr + else + Result := nil; +end; + + +function AcquireExceptionObject: Pointer; +begin + if RaiseListPtr <> nil then + begin + Result := PRaiseFrame(RaiseListPtr)^.ExceptObject; + PRaiseFrame(RaiseListPtr)^.ExceptObject := nil; + end + else + Result := nil; +end; + +procedure ReleaseExceptionObject; +begin +end; + +function RaiseList: Pointer; +begin + Result := RaiseListPtr; +end; + +function SetRaiseList(NewPtr: Pointer): Pointer; +asm + PUSH EAX + CALL SysInit.@GetTLS + MOV EDX, [EAX].RaiseListPtr + POP [EAX].RaiseListPtr + MOV EAX, EDX +end; +{$ENDIF} + +{ + Coverage helper glue - just go directly to the external coverage + library. NEVER put code in here, because we sometimes want to run + coverage analysis on the System unit. +} +{ + Note: names are wrong for linux, but we'll be fixing that soon. +} +procedure _CVR_PROBE; external 'coverage.dll' name '__CVR_PROBE' +function _CVR_STMTPROBE; external 'coverage.dll' name '__CVR_STMTPROBE' + +{ ----------------------------------------------------- } +{ local functions & procedures of the system unit } +{ ----------------------------------------------------- } + +procedure RunErrorAt(ErrCode: Integer; ErrorAtAddr: Pointer); +begin + ErrorAddr := ErrorAtAddr; + _Halt(ErrCode); +end; + +procedure ErrorAt(ErrorCode: Byte; ErrorAddr: Pointer); + +const + reMap: array [TRunTimeError] of Byte = ( + 0, { reNone } + 203, { reOutOfMemory } + 204, { reInvalidPtr } + 200, { reDivByZero } + 201, { reRangeError } +{ 210 Abstract error } + 215, { reIntOverflow } + 207, { reInvalidOp } + 200, { reZeroDivide } + 205, { reOverflow } + 206, { reUnderflow } + 219, { reInvalidCast } + 216, { reAccessViolation } + 218, { rePrivInstruction } + 217, { reControlBreak } + 202, { reStackOverflow } + 220, { reVarTypeCast } + 221, { reVarInvalidOp } + 222, { reVarDispatch } + 223, { reVarArrayCreate } + 224, { reVarNotArray } + 225, { reVarArrayBounds } +{ 226 Thread init failure } + 227, { reAssertionFailed } + 0, { reExternalException not used here; in SysUtils } + 228, { reIntfCastError } + 229 { reSafeCallError } +{$IFDEF LINUX} +{ 230 Reserved by the compiler for unhandled exceptions } +{ 231 Too many nested exceptions } +{ 232 Fatal signal raised on a non-Delphi thread } + , 233, { reQuit } + 234 { reCodesetConversion } +{$ENDIF} +); + +begin + errorCode := errorCode and 127; + if Assigned(ErrorProc) then + ErrorProc(errorCode, ErrorAddr); + if errorCode = 0 then + errorCode := InOutRes + else if errorCode <= Byte(High(TRuntimeError)) then + errorCode := reMap[TRunTimeError(errorCode)]; + RunErrorAt(errorCode, ErrorAddr); +end; + +procedure Error(errorCode: TRuntimeError); +asm + AND EAX,127 + MOV EDX,[ESP] + JMP ErrorAt +end; + +procedure __IOTest; +asm + PUSH EAX + PUSH EDX + PUSH ECX + CALL SysInit.@GetTLS + CMP [EAX].InOutRes,0 + POP ECX + POP EDX + POP EAX + JNE @error + RET +@error: + XOR EAX,EAX + JMP Error +end; + +procedure SetInOutRes(NewValue: Integer); +begin + InOutRes := NewValue; +end; + +procedure InOutError; +begin + SetInOutRes(GetLastError); +end; + +procedure ChDir(const S: string); +begin + ChDir(PChar(S)); +end; + +procedure ChDir(P: PChar); +begin +{$IFDEF MSWINDOWS} + if not SetCurrentDirectory(P) then +{$ENDIF} +{$IFDEF LINUX} + if __chdir(P) <> 0 then +{$ENDIF} + InOutError; +end; + +procedure _Copy{ s : ShortString; index, count : Integer ) : ShortString}; +asm +{ ->EAX Source string } +{ EDX index } +{ ECX count } +{ [ESP+4] Pointer to result string } + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,[ESP+8+4] + + XOR EAX,EAX + OR AL,[ESI] + JZ @@srcEmpty + +{ limit index to satisfy 1 <= index <= Length(src) } + + TEST EDX,EDX + JLE @@smallInx + CMP EDX,EAX + JG @@bigInx +@@cont1: + +{ limit count to satisfy 0 <= count <= Length(src) - index + 1 } + + SUB EAX,EDX { calculate Length(src) - index + 1 } + INC EAX + TEST ECX,ECX + JL @@smallCount + CMP ECX,EAX + JG @@bigCount +@@cont2: + + ADD ESI,EDX + + MOV [EDI],CL + INC EDI + REP MOVSB + JMP @@exit + +@@smallInx: + MOV EDX,1 + JMP @@cont1 +@@bigInx: +{ MOV EDX,EAX + JMP @@cont1 } +@@smallCount: + XOR ECX,ECX + JMP @@cont2 +@@bigCount: + MOV ECX,EAX + JMP @@cont2 +@@srcEmpty: + MOV [EDI],AL +@@exit: + POP EDI + POP ESI + RET 4 +end; + +procedure _Delete{ var s : openstring; index, count : Integer }; +asm +{ ->EAX Pointer to s } +{ EDX index } +{ ECX count } + + PUSH ESI + PUSH EDI + + MOV EDI,EAX + + XOR EAX,EAX + MOV AL,[EDI] + +{ if index not in [1 .. Length(s)] do nothing } + + TEST EDX,EDX + JLE @@exit + CMP EDX,EAX + JG @@exit + +{ limit count to [0 .. Length(s) - index + 1] } + + TEST ECX,ECX + JLE @@exit + SUB EAX,EDX { calculate Length(s) - index + 1 } + INC EAX + CMP ECX,EAX + JLE @@1 + MOV ECX,EAX +@@1: + SUB [EDI],CL { reduce Length(s) by count } + ADD EDI,EDX { point EDI to first char to be deleted } + LEA ESI,[EDI+ECX] { point ESI to first char to be preserved } + SUB EAX,ECX { #chars = Length(s) - index + 1 - count } + MOV ECX,EAX + + REP MOVSB + +@@exit: + POP EDI + POP ESI +end; + +procedure _LGetDir(D: Byte; var S: string); +{$IFDEF MSWINDOWS} +var + Drive: array[0..3] of Char; + DirBuf, SaveBuf: array[0..MAX_PATH] of Char; +begin + if D <> 0 then + begin + Drive[0] := Chr(D + Ord('A') - 1); + Drive[1] := ':'; + Drive[2] := #0; + GetCurrentDirectory(SizeOf(SaveBuf), SaveBuf); + SetCurrentDirectory(Drive); + end; + GetCurrentDirectory(SizeOf(DirBuf), DirBuf); + if D <> 0 then SetCurrentDirectory(SaveBuf); + S := DirBuf; +{$ENDIF} +{$IFDEF LINUX} +var + DirBuf: array[0..MAX_PATH] of Char; +begin + __getcwd(DirBuf, sizeof(DirBuf)); + S := string(DirBuf); +{$ENDIF} +end; + +procedure _SGetDir(D: Byte; var S: ShortString); +var + L: string; +begin + _LGetDir(D, L); + S := L; +end; + +procedure _Insert{ source : ShortString; var s : openstring; index : Integer }; +asm +{ ->EAX Pointer to source string } +{ EDX Pointer to destination string } +{ ECX Length of destination string } +{ [ESP+4] Index } + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH ECX + MOV ECX,[ESP+16+4] + SUB ESP,512 { VAR buf: ARRAY [0..511] of Char } + + MOV EBX,EDX { save pointer to s for later } + MOV ESI,EDX + + XOR EDX,EDX + MOV DL,[ESI] + INC ESI + +{ limit index to [1 .. Length(s)+1] } + + INC EDX + TEST ECX,ECX + JLE @@smallInx + CMP ECX,EDX + JG @@bigInx +@@cont1: + DEC EDX { EDX = Length(s) } + { EAX = Pointer to src } + { ESI = EBX = Pointer to s } + { ECX = Index } + +{ copy index-1 chars from s to buf } + + MOV EDI,ESP + DEC ECX + SUB EDX,ECX { EDX = remaining length of s } + REP MOVSB + +{ copy Length(src) chars from src to buf } + + XCHG EAX,ESI { save pointer into s, point ESI to src } + MOV CL,[ESI] { ECX = Length(src) (ECX was zero after rep) } + INC ESI + REP MOVSB + +{ copy remaining chars of s to buf } + + MOV ESI,EAX { restore pointer into s } + MOV ECX,EDX { copy remaining bytes of s } + REP MOVSB + +{ calculate total chars in buf } + + SUB EDI,ESP { length = bufPtr - buf } + MOV ECX,[ESP+512] { ECX = Min(length, destLength) } +{ MOV ECX,[EBP-16] }{ ECX = Min(length, destLength) } + CMP ECX,EDI + JB @@1 + MOV ECX,EDI +@@1: + MOV EDI,EBX { Point EDI to s } + MOV ESI,ESP { Point ESI to buf } + MOV [EDI],CL { Store length in s } + INC EDI + REP MOVSB { Copy length chars to s } + JMP @@exit + +@@smallInx: + MOV ECX,1 + JMP @@cont1 +@@bigInx: + MOV ECX,EDX + JMP @@cont1 + +@@exit: + ADD ESP,512+4 + POP EDI + POP ESI + POP EBX + RET 4 +end; + +function IOResult: Integer; +begin + Result := InOutRes; + InOutRes := 0; +end; + +procedure MkDir(const S: string); +begin + MkDir(PChar(s)); +end; + +procedure MkDir(P: PChar); +begin +{$IFDEF MSWINDOWS} + if not CreateDirectory(P, 0) then +{$ENDIF} +{$IFDEF LINUX} + if __mkdir(P, -1) <> 0 then +{$ENDIF} + InOutError; +end; + +procedure Move( const Source; var Dest; count : Integer ); +{$IFDEF PUREPASCAL} +var + S, D: PChar; + I: Integer; +begin + S := PChar(@Source); + D := PChar(@Dest); + if S = D then Exit; + if Cardinal(D) > Cardinal(S) then + for I := count-1 downto 0 do + D[I] := S[I] + else + for I := 0 to count-1 do + D[I] := S[I]; +end; +{$ELSE} +asm +{ ->EAX Pointer to source } +{ EDX Pointer to destination } +{ ECX Count } +{X+}(* // original code. + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + MOV EAX,ECX + + CMP EDI,ESI + JA @@down + JE @@exit + + SAR ECX,2 { copy count DIV 4 dwords } + JS @@exit + + REP MOVSD + + MOV ECX,EAX + AND ECX,03H + REP MOVSB { copy count MOD 4 bytes } + JMP @@exit + +@@down: + LEA ESI,[ESI+ECX-4] { point ESI to last dword of source } + LEA EDI,[EDI+ECX-4] { point EDI to last dword of dest } + + SAR ECX,2 { copy count DIV 4 dwords } + JS @@exit + STD + REP MOVSD + + MOV ECX,EAX + AND ECX,03H { copy count MOD 4 bytes } + ADD ESI,4-1 { point to last byte of rest } + ADD EDI,4-1 + REP MOVSB + CLD +@@exit: + POP EDI + POP ESI +{X+}*) // original code. +//--------------------------------------- +(* {X+} // Let us write smaller: + JCXZ @@fin + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + MOV EAX,ECX + + AND ECX,3 { copy count mod 4 dwords } + + CMP EDI,ESI + JE @@exit + JA @@up + +//down: + LEA ESI,[ESI+EAX-1] { point ESI to last byte of source } + LEA EDI,[EDI+EAX-1] { point EDI to last byte of dest } + STD + + CMP EAX, 4 + JL @@up + ADD ECX, 3 { move 3 bytes more to correct pos } + +@@up: + REP MOVSB + + SAR EAX, 2 + JS @@exit + + MOV ECX, EAX + REP MOVSD + +@@exit: + CLD + POP EDI + POP ESI + +@@fin: +*) {X-} +{X+} //--------------------------------------- +{X+} // And now, let us write speedy: +{X+} CMP ECX, 4 +{X+} JGE @@long +{X+} JCXZ @@fin +{X+} +{X+} CMP EAX, EDX +{X+} JE @@fin +{X+} +{X+} PUSH ESI +{X+} PUSH EDI +{X+} MOV ESI, EAX +{X+} MOV EDI, EDX +{X+} JA @@short_up +{X+} +{X+} LEA ESI,[ESI+ECX-1] { point ESI to last byte of source } +{X+} LEA EDI,[EDI+ECX-1] { point EDI to last byte of dest } +{X+} STD +{X+} +{X+}@@short_up: +{X+} REP MOVSB +{X+} JMP @@exit_up +{X+} +{X+}@@long: +{X+} CMP EAX, EDX +{X+} JE @@fin +{X+} +{X+} PUSH ESI +{X+} PUSH EDI +{X+} MOV ESI, EAX +{X+} MOV EDI, EDX +{X+} MOV EAX, ECX +{X+} +{X+} JA @@long_up +{X+} +{X+} (* +{X+} SAR ECX, 2 +{X+} JS @@exit +{X+} +{X+} LEA ESI,[ESI+EAX-4] +{X+} LEA EDI,[EDI+EAX-4] +{X+} STD +{X+} REP MOVSD +{X+} +{X+} MOV ECX, EAX +{X+} MOV EAX, 3 +{X+} AND ECX, EAX +{X+} ADD ESI, EAX +{X+} ADD EDI, EAX +{X+} REP MOVSB +{X+} *) // let's do it in other order - faster if data are aligned... +{X+} +{X+} AND ECX, 3 +{X+} LEA ESI,[ESI+EAX-1] +{X+} LEA EDI,[EDI+EAX-1] +{X+} STD +{X+} REP MOVSB +{X+} +{X+} SAR EAX, 2 +{X+} //JS @@exit // why to test this? but what does PC do? +{X+} MOV ECX, EAX +{X+} MOV EAX, 3 +{X+} SUB ESI, EAX +{X+} SUB EDI, EAX +{X+} REP MOVSD +{X+} +{X+}@@exit_up: +{X+} CLD +{X+} //JMP @@exit +{X+} DEC ECX // the same - loosing 2 tacts... but conveyer! +{X+} +{X+}@@long_up: +{X+} SAR ECX, 2 +{X+} JS @@exit +{X+} +{X+} REP MOVSD +{X+} +{X+} AND EAX, 3 +{X+} MOV ECX, EAX +{X+} REP MOVSB +{X+} +{X+}@@exit: +{X+} POP EDI +{X+} POP ESI +{X+} +{X+}@@fin: +{X+} +end; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function GetParamStr(P: PChar; var Param: string): PChar; +var + i, Len: Integer; + Start, S, Q: PChar; +begin + while True do + begin + while (P[0] <> #0) and (P[0] <= ' ') do + P := CharNext(P); + if (P[0] = '"') and (P[1] = '"') then Inc(P, 2) else Break; + end; + Len := 0; + Start := P; + while P[0] > ' ' do + begin + if P[0] = '"' then + begin + P := CharNext(P); + while (P[0] <> #0) and (P[0] <> '"') do + begin + Q := CharNext(P); + Inc(Len, Q - P); + P := Q; + end; + if P[0] <> #0 then + P := CharNext(P); + end + else + begin + Q := CharNext(P); + Inc(Len, Q - P); + P := Q; + end; + end; + + SetLength(Param, Len); + + P := Start; + S := Pointer(Param); + i := 0; + while P[0] > ' ' do + begin + if P[0] = '"' then + begin + P := CharNext(P); + while (P[0] <> #0) and (P[0] <> '"') do + begin + Q := CharNext(P); + while P < Q do + begin + S[i] := P^; + Inc(P); + Inc(i); + end; + end; + if P[0] <> #0 then P := CharNext(P); + end + else + begin + Q := CharNext(P); + while P < Q do + begin + S[i] := P^; + Inc(P); + Inc(i); + end; + end; + end; + + Result := P; +end; +{$ENDIF} + +function ParamCount: Integer; +{$IFDEF MSWINDOWS} +var + P: PChar; + S: string; +begin + Result := 0; + P := GetParamStr(GetCommandLine, S); + while True do + begin + P := GetParamStr(P, S); + if S = '' then Break; + Inc(Result); + end; +{$ENDIF} +{$IFDEF LINUX} +begin + if ArgCount > 1 then + Result := ArgCount - 1 + else Result := 0; +{$ENDIF} +end; + +type + PCharArray = array[0..0] of PChar; + +function ParamStr(Index: Integer): string; +{$IFDEF MSWINDOWS} +var + P: PChar; + Buffer: array[0..260] of Char; +begin + Result := ''; + if Index = 0 then + SetString(Result, Buffer, GetModuleFileName(0, Buffer, SizeOf(Buffer))) + else + begin + P := GetCommandLine; + while True do + begin + P := GetParamStr(P, Result); + if (Index = 0) or (Result = '') then Break; + Dec(Index); + end; + end; +{$ENDIF} +{$IFDEF LINUX} +begin + if Index < ArgCount then + Result := PCharArray(ArgValues^)[Index] + else + Result := ''; +{$ENDIF} +end; + +procedure _Pos{ substr : ShortString; s : ShortString ) : Integer}; +asm +{ ->EAX Pointer to substr } +{ EDX Pointer to string } +{ <-EAX Position of substr in s or 0 } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX { Point ESI to substr } + MOV EDI,EDX { Point EDI to s } + + XOR ECX,ECX { ECX = Length(s) } + MOV CL,[EDI] + INC EDI { Point EDI to first char of s } + + PUSH EDI { remember s position to calculate index } + + XOR EDX,EDX { EDX = Length(substr) } + MOV DL,[ESI] + INC ESI { Point ESI to first char of substr } + + DEC EDX { EDX = Length(substr) - 1 } + JS @@fail { < 0 ? return 0 } + MOV AL,[ESI] { AL = first char of substr } + INC ESI { Point ESI to 2'nd char of substr } + + SUB ECX,EDX { #positions in s to look at } + { = Length(s) - Length(substr) + 1 } + JLE @@fail +@@loop: + REPNE SCASB + JNE @@fail + MOV EBX,ECX { save outer loop counter } + PUSH ESI { save outer loop substr pointer } + PUSH EDI { save outer loop s pointer } + + MOV ECX,EDX + REPE CMPSB + POP EDI { restore outer loop s pointer } + POP ESI { restore outer loop substr pointer } + JE @@found + MOV ECX,EBX { restore outer loop counter } + JMP @@loop + +@@fail: + POP EDX { get rid of saved s pointer } + XOR EAX,EAX + JMP @@exit + +@@found: + POP EDX { restore pointer to first char of s } + MOV EAX,EDI { EDI points of char after match } + SUB EAX,EDX { the difference is the correct index } +@@exit: + POP EDI + POP ESI + POP EBX +end; + +// 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); +begin + Byte(s^[0]) := newLength; // should also fill new space +end; + +procedure _SetString(s: PShortString; buffer: PChar; len: Byte); +begin + Byte(s^[0]) := len; + if buffer <> nil then + Move(buffer^, s^[1], len); +end; + +procedure Randomize; +{$IFDEF LINUX} +begin + RandSeed := _time(nil); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +var + Counter: Int64; +begin + if QueryPerformanceCounter(Counter) then + RandSeed := Counter + else + RandSeed := GetTickCount; +end; +{$ENDIF} + +procedure RmDir(const S: string); +begin + RmDir(PChar(s)); +end; + +procedure RmDir(P: PChar); +begin +{$IFDEF MSWINDOWS} + if not RemoveDirectory(P) then +{$ENDIF} +{$IFDEF LINUX} + if __rmdir(P) <> 0 then +{$ENDIF} + InOutError; +end; + +function UpCase( ch : Char ) : Char; +{$IFDEF PUREPASCAL} +begin + Result := ch; + case Result of + 'a'..'z': Dec(Result, Ord('a') - Ord('A')); + end; +end; +{$ELSE} +asm +{ -> AL Character } +{ <- AL Result } + + CMP AL,'a' + JB @@exit + CMP AL,'z' + JA @@exit + SUB AL,'a' - 'A' +@@exit: +end; +{$ENDIF} + +procedure Set8087CW(NewCW: Word); +begin + Default8087CW := NewCW; + asm + FNCLEX // don't raise pending exceptions enabled by the new flags +{$IFDEF PIC} + MOV EAX,[EBX].OFFSET Default8087CW + FLDCW [EAX] +{$ELSE} + FLDCW Default8087CW +{$ENDIF} + end; +end; + +function Get8087CW: Word; +asm + PUSH 0 + FNSTCW [ESP].Word + POP EAX +end; + + +{ ----------------------------------------------------- } +{ functions & procedures that need compiler magic } +{ ----------------------------------------------------- } + +procedure _COS; +asm + FCOS + FNSTSW AX + SAHF + JP @@outOfRange + RET +@@outOfRange: + FSTP st(0) { for now, return 0. result would } + FLDZ { have little significance anyway } +end; + +procedure _EXP; +asm + { e**x = 2**(x*log2(e)) } + + FLDL2E { y := x*log2e; } + FMUL + FLD ST(0) { i := round(y); } + FRNDINT + FSUB ST(1), ST { f := y - i; } + FXCH ST(1) { z := 2**f } + F2XM1 + FLD1 + FADD + FSCALE { result := z * 2**i } + FSTP ST(1) +end; + +procedure _INT; +asm + SUB ESP,4 + FNSTCW [ESP].Word // save + FNSTCW [ESP+2].Word // scratch + FWAIT + OR [ESP+2].Word, $0F00 // trunc toward zero, full precision + FLDCW [ESP+2].Word + FRNDINT + FWAIT + FLDCW [ESP].Word + ADD ESP,4 +end; + +procedure _SIN; +asm + FSIN + FNSTSW AX + SAHF + JP @@outOfRange + RET +@@outOfRange: + FSTP st(0) { for now, return 0. result would } + FLDZ { have little significance anyway } +end; + +procedure _FRAC; +asm + FLD ST(0) + SUB ESP,4 + FNSTCW [ESP].Word // save + FNSTCW [ESP+2].Word // scratch + FWAIT + OR [ESP+2].Word, $0F00 // trunc toward zero, full precision + FLDCW [ESP+2].Word + FRNDINT + FWAIT + FLDCW [ESP].Word + ADD ESP,4 + FSUB +end; + +procedure _ROUND; +asm + { -> FST(0) Extended argument } + { <- EDX:EAX Result } + + SUB ESP,8 + FISTP qword ptr [ESP] + FWAIT + POP EAX + POP EDX +end; + +procedure _TRUNC; +asm + { -> FST(0) Extended argument } + { <- EDX:EAX Result } + + SUB ESP,12 + FNSTCW [ESP].Word // save + FNSTCW [ESP+2].Word // scratch + FWAIT + OR [ESP+2].Word, $0F00 // trunc toward zero, full precision + FLDCW [ESP+2].Word + FISTP qword ptr [ESP+4] + FWAIT + FLDCW [ESP].Word + POP ECX + POP EAX + POP EDX +end; + +procedure _AbstractError; +{$IFDEF PIC} +begin + if Assigned(AbstractErrorProc) then + AbstractErrorProc; + _RunError(210); // loses return address +end; +{$ELSE} +asm + CMP AbstractErrorProc, 0 + JE @@NoAbstErrProc + CALL AbstractErrorProc + +@@NoAbstErrProc: + MOV EAX,210 + JMP _RunError +end; +{$ENDIF} + +function TextOpen(var t: TTextRec): Integer; forward; + +function OpenText(var t: TTextRec; Mode: Word): Integer; +begin + if (t.Mode < fmClosed) or (t.Mode > fmInOut) then + Result := 102 + else + begin + if t.Mode <> fmClosed then _Close(t); + t.Mode := Mode; + if (t.Name[0] = #0) and (t.OpenFunc = nil) then // stdio + t.OpenFunc := @TextOpen; + Result := TTextIOFunc(t.OpenFunc)(t); + end; + if Result <> 0 then SetInOutRes(Result); +end; + +function _ResetText(var t: TTextRec): Integer; +begin + Result := OpenText(t, fmInput); +end; + +function _RewritText(var t: TTextRec): Integer; +begin + Result := OpenText(t, fmOutput); +end; + +function _Append(var t: TTextRec): Integer; +begin + Result := OpenText(t, fmInOut); +end; + +function TextIn(var t: TTextRec): Integer; +const + ERROR_BROKEN_PIPE = 109; +begin + t.BufEnd := 0; + t.BufPos := 0; +{$IFDEF LINUX} + t.BufEnd := __read(t.Handle, t.BufPtr, t.BufSize); + if Integer(t.BufEnd) = -1 then + begin + t.BufEnd := 0; + Result := GetLastError; + end + else + Result := 0; +{$ENDIF} +{$IFDEF MSWINDOWS} + if ReadFile(t.Handle, t.BufPtr^, t.BufSize, t.BufEnd, nil) = 0 then + begin + Result := GetLastError; + if Result = ERROR_BROKEN_PIPE then + Result := 0; // NT quirk: got "broken pipe"? it's really eof + end + else + Result := 0; +{$ENDIF} +end; + +function FileNOPProc(var t): Integer; +begin + Result := 0; +end; + +function TextOut(var t: TTextRec): Integer; +{$IFDEF MSWINDOWS} +var + Dummy: Cardinal; +{$ENDIF} +begin + if t.BufPos = 0 then + Result := 0 + else + begin +{$IFDEF LINUX} + if __write(t.Handle, t.BufPtr, t.BufPos) = Cardinal(-1) then +{$ENDIF} +{$IFDEF MSWINDOWS} + if WriteFile(t.Handle, t.BufPtr^, t.BufPos, Dummy, nil) = 0 then +{$ENDIF} + Result := GetLastError + else + Result := 0; + t.BufPos := 0; + end; +end; + +function InternalClose(Handle: Integer): Boolean; +begin +{$IFDEF LINUX} + Result := __close(Handle) = 0; +{$ENDIF} +{$IFDEF MSWINDOWS} + Result := CloseHandle(Handle) = 1; +{$ENDIF} +end; + +function TextClose(var t: TTextRec): Integer; +begin + t.Mode := fmClosed; + if not InternalClose(t.Handle) then + Result := GetLastError + else + Result := 0; +end; + +function TextOpenCleanup(var t: TTextRec): Integer; +begin + InternalClose(t.Handle); + t.Mode := fmClosed; + Result := GetLastError; +end; + +function TextOpen(var t: TTextRec): Integer; +{$IFDEF LINUX} +var + Flags: Integer; + Temp, I: Integer; + BytesRead: Integer; +begin + Result := 0; + t.BufPos := 0; + t.BufEnd := 0; + case t.Mode of + fmInput: // called by Reset + begin + Flags := O_RDONLY; + t.InOutFunc := @TextIn; + end; + fmOutput: // called by Rewrite + begin + Flags := O_CREAT or O_TRUNC or O_WRONLY; + t.InOutFunc := @TextOut; + end; + fmInOut: // called by Append + begin + Flags := O_APPEND or O_RDWR; + t.InOutFunc := @TextOut; + end; + else + Exit; + Flags := 0; + end; + + t.FlushFunc := @FileNOPProc; + + if t.Name[0] = #0 then // stdin or stdout + begin + if t.BufPtr = nil then // don't overwrite bufptr provided by SetTextBuf + begin + t.BufPtr := @t.Buffer; + t.BufSize := sizeof(t.Buffer); + end; + t.CloseFunc := @FileNOPProc; + if t.Mode = fmOutput then + begin + if @t = @ErrOutput then + t.Handle := STDERR_FILENO + else + t.Handle := STDOUT_FILENO; + t.FlushFunc := @TextOut; + end + else + t.Handle := STDIN_FILENO; + end + else + begin + t.CloseFunc := @TextClose; + + Temp := __open(t.Name, Flags, FileAccessRights); + if Temp = -1 then + begin + t.Mode := fmClosed; + Result := GetLastError; + Exit; + end; + + t.Handle := Temp; + + if t.Mode = fmInOut then // Append mode + begin + t.Mode := fmOutput; + + if (t.flags and tfCRLF) <> 0 then // DOS mode, EOF significant + begin // scan for EOF char in last 128 byte sector. + Temp := _lseek(t.Handle, 0, SEEK_END); + if Temp = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + Dec(Temp, 128); + if Temp < 0 then Temp := 0; + + if _lseek(t.Handle, Temp, SEEK_SET) = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + BytesRead := __read(t.Handle, t.BufPtr, 128); + if BytesRead = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + for I := 0 to BytesRead - 1 do + begin + if t.Buffer[I] = Char(cEOF) then + begin // truncate the file here + if _ftruncate(t.Handle, _lseek(t.Handle, I - BytesRead, SEEK_END)) = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + Break; + end; + end; + end; + end; + end; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +(* +var + OpenMode: Integer; + Flags, Std: ShortInt; + Temp: Integer; + I, BytesRead: Cardinal; + Mode: Byte; +begin + Result := 0; + if (t.Mode - fmInput) > (fmInOut - fmInput) then Exit; + Mode := t.Mode and 3; + t.BufPos := 0; + t.BufEnd := 0; + t.FlushFunc := @FileNOPProc; + + if t.Name[0] = #0 then // stdin or stdout + begin + t.BufPtr := @t.Buffer; + t.BufSize := sizeof(t.Buffer); + t.CloseFunc := @FileNOPProc; + if Mode = (fmOutput and 3) then + begin + t.InOutFunc := @TextOut; + if @t = @ErrOutput then + Std := STD_ERROR_HANDLE + else + Std := STD_OUTPUT_HANDLE; + end + else + begin + t.InOutFunc := @TextIn; + Std := STD_INPUT_HANDLE; + end; + t.Handle := GetStdHandle(Std); + end + else + begin + t.CloseFunc := @TextClose; + + Flags := OPEN_EXISTING; + if Mode = (fmInput and 3) then + begin // called by Reset + t.InOutFunc := @TextIn; + OpenMode := GENERIC_READ; // open for read + end + else + begin + t.InOutFunc := @TextOut; + if Mode = (fmInOut and 3) then // called by Append + OpenMode := GENERIC_READ OR GENERIC_WRITE // open for read/write + else + begin // called by Rewrite + OpenMode := GENERIC_WRITE; // open for write + Flags := CREATE_ALWAYS; + end; + end; + + Temp := CreateFileA(t.Name, OpenMode, FILE_SHARE_READ, nil, Flags, FILE_ATTRIBUTE_NORMAL, 0); + if Temp = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + t.Handle := Temp; + + if Mode = (fmInOut and 3) then + begin + Dec(t.Mode); // fmInOut -> fmOutput + +{; ??? we really have to look for the first eof byte in the +; ??? last record and truncate the file there. +; Not very nice and clean... +; +; lastRecPos = Max( GetFileSize(...) - 128, 0); +} + Temp := GetFileSize(t.Handle, 0); + if Temp = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + Dec(Temp, 128); + if Temp < 0 then Temp := 0; + + if (SetFilePointer(t.Handle, Temp, nil, FILE_BEGIN) = -1) or + (ReadFile(t.Handle, t.Buffer, 128, BytesRead, nil) = 0) then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + for I := 0 to BytesRead do + begin + if t.Buffer[I] = Char(cEOF) then + begin // truncate the file here + if (SetFilePointer(t.Handle, I - BytesRead, nil, FILE_END) = -1) or + (not SetEndOfFile(t.Handle)) then + begin + Result := TextOpenCleanup(t); + Exit; + end; + Break; + end; + end; + end; + if Mode <> (fmInput and 3) then + begin + case GetFileType(t.Handle) of + 0: begin // bad file type + TextOpenCleanup(t); + Result := 105; + Exit; + end; + 2: t.FlushFunc := @TextOut; + end; + end; + end; +end; +*) + +asm +// -> EAX Pointer to text record + + PUSH ESI + + MOV ESI,EAX + + XOR EAX,EAX + MOV [ESI].TTextRec.BufPos,EAX + MOV [ESI].TTextRec.BufEnd,EAX + MOV AX,[ESI].TTextRec.Mode + + SUB EAX,fmInput + JE @@calledByReset + + DEC EAX + JE @@calledByRewrite + + DEC EAX + JE @@calledByAppend + + JMP @@exit + +@@calledByReset: + + MOV EAX,GENERIC_READ // open for read + MOV EDX,FILE_SHARE_READ + MOV ECX,OPEN_EXISTING + + MOV [ESI].TTextRec.InOutFunc,offset TextIn + + JMP @@common + +@@calledByRewrite: + + MOV EAX,GENERIC_WRITE // open for write + MOV EDX,FILE_SHARE_READ + MOV ECX,CREATE_ALWAYS + JMP @@commonOut + +@@calledByAppend: + + MOV EAX,GENERIC_READ OR GENERIC_WRITE // open for read/write + MOV EDX,FILE_SHARE_READ + MOV ECX,OPEN_EXISTING + +@@commonOut: + + MOV [ESI].TTextRec.InOutFunc,offset TextOut + +@@common: + + MOV [ESI].TTextRec.CloseFunc,offset TextClose + MOV [ESI].TTextRec.FlushFunc,offset FileNOPProc + CMP byte ptr [ESI].TTextRec.Name,0 + JE @@isCon + +// CreateFile(t.Name, EAX, EDX, Nil, ECX, FILE_ATTRIBUTE_NORMAL, 0); + + PUSH 0 + PUSH FILE_ATTRIBUTE_NORMAL + PUSH ECX + PUSH 0 + PUSH EDX + PUSH EAX + LEA EAX,[ESI].TTextRec.Name + PUSH EAX + CALL CreateFileA + + CMP EAX,-1 + JZ @@error + + MOV [ESI].TTextRec.Handle,EAX + CMP [ESI].TTextRec.Mode,fmInOut + JNE @@success + + DEC [ESI].TTextRec.Mode // fmInOut -> fmOutput + +{; ??? we really have to look for the first eof byte in the +; ??? last record and truncate the file there. +; Not very nice and clean... +; +; lastRecPos = Max( GetFileSize(...) - 128, 0); +} + PUSH 0 + PUSH [ESI].TTextRec.Handle + CALL GetFileSize + + INC EAX + JZ @@error + SUB EAX,129 + JNC @@3 + XOR EAX,EAX +@@3: +// lseek(f.Handle, SEEK_SET, lastRecPos); + + PUSH FILE_BEGIN + PUSH 0 + PUSH EAX + PUSH [ESI].TTextRec.Handle + CALL SetFilePointer + + INC EAX + JE @@error + +// bytesRead = read(f.Handle, f.Buffer, 128); + + PUSH 0 + MOV EDX,ESP + PUSH 0 + PUSH EDX + PUSH 128 + LEA EDX,[ESI].TTextRec.Buffer + PUSH EDX + PUSH [ESI].TTextRec.Handle + CALL ReadFile + POP EDX + DEC EAX + JNZ @@error + +// for (i = 0; i < bytesRead; i++) + + XOR EAX,EAX +@@loop: + CMP EAX,EDX + JAE @@success + +// if (f.Buffer[i] == eof) + + CMP byte ptr [ESI].TTextRec.Buffer[EAX],eof + JE @@truncate + INC EAX + JMP @@loop + +@@truncate: + +// lseek( f.Handle, SEEK_END, i - bytesRead ); + + PUSH FILE_END + PUSH 0 + SUB EAX,EDX + PUSH EAX + PUSH [ESI].TTextRec.Handle + CALL SetFilePointer + INC EAX + JE @@error + +// SetEndOfFile( f.Handle ); + + PUSH [ESI].TTextRec.Handle + CALL SetEndOfFile + DEC EAX + JNE @@error + + JMP @@success + +@@isCon: + LEA EAX,[ESI].TTextRec.Buffer + MOV [ESI].TTextRec.BufSize, TYPE TTextRec.Buffer + MOV [ESI].TTextRec.CloseFunc,offset FileNOPProc + MOV [ESI].TTextRec.BufPtr,EAX + CMP [ESI].TTextRec.Mode,fmOutput + JE @@output + PUSH STD_INPUT_HANDLE + JMP @@1 +@@output: + CMP ESI,offset ErrOutput + JNE @@stdout + PUSH STD_ERROR_HANDLE + JMP @@1 +@@stdout: + PUSH STD_OUTPUT_HANDLE +@@1: + CALL GetStdHandle + CMP EAX,-1 + JE @@error + MOV [ESI].TTextRec.Handle,EAX + +@@success: + CMP [ESI].TTextRec.Mode,fmInput + JE @@2 + PUSH [ESI].TTextRec.Handle + CALL GetFileType + TEST EAX,EAX + JE @@badFileType + CMP EAX,2 + JNE @@2 + MOV [ESI].TTextRec.FlushFunc,offset TextOut +@@2: + XOR EAX,EAX +@@exit: + POP ESI + RET + +@@badFileType: + PUSH [ESI].TTextRec.Handle + CALL CloseHandle + MOV [ESI].TTextRec.Mode,fmClosed + MOV EAX,105 + JMP @@exit + +@@error: + MOV [ESI].TTextRec.Mode,fmClosed + CALL GetLastError + JMP @@exit +end; +{$ENDIF} + +const + fNameLen = 260; + +function _Assign(var t: TTextRec; const s: String): Integer; +begin + FillChar(t, sizeof(TFileRec), 0); + t.BufPtr := @t.Buffer; + t.Mode := fmClosed; + t.Flags := tfCRLF * Byte(DefaultTextLineBreakStyle); + t.BufSize := sizeof(t.Buffer); + t.OpenFunc := @TextOpen; + Move(S[1], t.Name, Length(s)); + t.Name[Length(s)] := #0; + Result := 0; +end; + +function InternalFlush(var t: TTextRec; Func: TTextIOFunc): Integer; +begin + case t.Mode of + fmOutput, + fmInOut : Result := Func(t); + fmInput : Result := 0; + else + if (@t = @Output) or (@t = @ErrOutput) then + Result := 0 + else + Result := 103; + end; + if Result <> 0 then SetInOutRes(Result); +end; + +function Flush(var t: Text): Integer; +begin + Result := InternalFlush(TTextRec(t), TTextRec(t).InOutFunc); +end; + +function _Flush(var t: TTextRec): Integer; +begin + Result := InternalFlush(t, t.FlushFunc); +end; + +type +{$IFDEF MSWINDOWS} + 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'; + +{$ENDIF} +{$IFDEF LINUX} + TIOProc = function (Handle: Integer; Buffer: Pointer; Count: Cardinal): Cardinal; cdecl; +{$ENDIF} + +function BlockIO(var f: TFileRec; buffer: Pointer; recCnt: Cardinal; var recsDone: Longint; + ModeMask: Integer; IOProc: TIOProc; ErrorNo: Integer): Cardinal; +// Note: RecsDone ptr can be nil! +begin + if (f.Mode and ModeMask) = ModeMask then // fmOutput or fmInOut / fmInput or fmInOut + begin +{$IFDEF LINUX} + Result := IOProc(f.Handle, buffer, recCnt * f.RecSize); + if Integer(Result) = -1 then +{$ENDIF} +{$IFDEF MSWINDOWS} + if IOProc(f.Handle, buffer, recCnt * f.RecSize, Result, nil) = 0 then +{$ENDIF} + begin + SetInOutRes(GetLastError); + Result := 0; + end + else + begin + Result := Result div f.RecSize; + if @RecsDone <> nil then + RecsDone := Result + else if Result <> recCnt then + begin + SetInOutRes(ErrorNo); + Result := 0; + end + end; + end + else + begin + SetInOutRes(103); // file not open + Result := 0; + end; +end; + +function _BlockRead(var f: TFileRec; buffer: Pointer; recCnt: Longint; var recsRead: Longint): Longint; +begin + Result := BlockIO(f, buffer, recCnt, recsRead, fmInput, + {$IFDEF MSWINDOWS} ReadFileX, {$ENDIF} + {$IFDEF LINUX} __read, {$ENDIF} + 100); +end; + +function _BlockWrite(var f: TFileRec; buffer: Pointer; recCnt: Longint; var recsWritten: Longint): Longint; +begin + Result := BlockIO(f, buffer, recCnt, recsWritten, fmOutput, + {$IFDEF MSWINDOWS} WriteFileX, {$ENDIF} + {$IFDEF LINUX} __write, {$ENDIF} + 101); +end; + +function _Close(var t: TTextRec): Integer; +begin + Result := 0; + if (t.Mode >= fmInput) and (t.Mode <= fmInOut) then + begin + if (t.Mode and fmOutput) = fmOutput then // fmOutput or fmInOut + Result := TTextIOFunc(t.InOutFunc)(t); + if Result = 0 then + Result := TTextIOFunc(t.CloseFunc)(t); + if Result <> 0 then + SetInOutRes(Result); + end + else + if @t <> @Input then + SetInOutRes(103); +end; + +procedure _PStrCat; +asm +{ ->EAX = Pointer to destination string } +{ EDX = Pointer to source string } + + PUSH ESI + PUSH EDI + +{ load dest len into EAX } + + MOV EDI,EAX + XOR EAX,EAX + MOV AL,[EDI] + +{ load source address in ESI, source len in ECX } + + MOV ESI,EDX + XOR ECX,ECX + MOV CL,[ESI] + INC ESI + +{ calculate final length in DL and store it in the destination } + + MOV DL,AL + ADD DL,CL + JC @@trunc + +@@cont: + MOV [EDI],DL + +{ calculate final dest address } + + INC EDI + ADD EDI,EAX + +{ do the copy } + + REP MOVSB + +{ done } + + POP EDI + POP ESI + RET + +@@trunc: + INC DL { DL = #chars to truncate } + SUB CL,DL { CL = source len - #chars to truncate } + MOV DL,255 { DL = maximum length } + JMP @@cont +end; + +procedure _PStrNCat; +asm +{ ->EAX = Pointer to destination string } +{ EDX = Pointer to source string } +{ CL = max length of result (allocated size of dest - 1) } + + PUSH ESI + PUSH EDI + +{ load dest len into EAX } + + MOV EDI,EAX + XOR EAX,EAX + MOV AL,[EDI] + +{ load source address in ESI, source len in EDX } + + MOV ESI,EDX + XOR EDX,EDX + MOV DL,[ESI] + INC ESI + +{ calculate final length in AL and store it in the destination } + + ADD AL,DL + JC @@trunc + CMP AL,CL + JA @@trunc + +@@cont: + MOV ECX,EDX + MOV DL,[EDI] + MOV [EDI],AL + +{ calculate final dest address } + + INC EDI + ADD EDI,EDX + +{ do the copy } + + REP MOVSB + +@@done: + POP EDI + POP ESI + RET + +@@trunc: +{ CL = maxlen } + + MOV AL,CL { AL = final length = maxlen } + SUB CL,[EDI] { CL = length to copy = maxlen - destlen } + JBE @@done + MOV DL,CL + JMP @@cont +end; + +procedure _PStrCpy(Dest: PShortString; Source: PShortString); +begin + Move(Source^, Dest^, Byte(Source^[0])+1); +end; + +procedure _PStrNCpy(Dest: PShortString; Source: PShortString; MaxLen: Byte); +begin + if MaxLen > Byte(Source^[0]) then + MaxLen := Byte(Source^[0]); + Byte(Dest^[0]) := MaxLen; + Move(Source^[1], Dest^[1], MaxLen); +end; + +procedure _PStrCmp; +asm +{ ->EAX = Pointer to left string } +{ EDX = Pointer to right string } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + XOR EAX,EAX + XOR EDX,EDX + MOV AL,[ESI] + MOV DL,[EDI] + INC ESI + INC EDI + + SUB EAX,EDX { eax = len1 - len2 } + JA @@skip1 + ADD EDX,EAX { edx = len2 + (len1 - len2) = len1 } + +@@skip1: + PUSH EDX + SHR EDX,2 + JE @@cmpRest +@@longLoop: + MOV ECX,[ESI] + MOV EBX,[EDI] + CMP ECX,EBX + JNE @@misMatch + DEC EDX + JE @@cmpRestP4 + MOV ECX,[ESI+4] + MOV EBX,[EDI+4] + CMP ECX,EBX + JNE @@misMatch + ADD ESI,8 + ADD EDI,8 + DEC EDX + JNE @@longLoop + JMP @@cmpRest +@@cmpRestP4: + ADD ESI,4 + ADD EDI,4 +@@cmpRest: + POP EDX + AND EDX,3 + JE @@equal + + MOV CL,[ESI] + CMP CL,[EDI] + JNE @@exit + DEC EDX + JE @@equal + MOV CL,[ESI+1] + CMP CL,[EDI+1] + JNE @@exit + DEC EDX + JE @@equal + MOV CL,[ESI+2] + CMP CL,[EDI+2] + JNE @@exit + +@@equal: + ADD EAX,EAX + JMP @@exit + +@@misMatch: + POP EDX + CMP CL,BL + JNE @@exit + CMP CH,BH + JNE @@exit + SHR ECX,16 + SHR EBX,16 + CMP CL,BL + JNE @@exit + CMP CH,BH + +@@exit: + POP EDI + POP ESI + POP EBX +end; + +procedure _AStrCmp; +asm +{ ->EAX = Pointer to left string } +{ EDX = Pointer to right string } +{ ECX = Number of chars to compare} + + PUSH EBX + PUSH ESI + PUSH ECX + MOV ESI,ECX + SHR ESI,2 + JE @@cmpRest + +@@longLoop: + MOV ECX,[EAX] + MOV EBX,[EDX] + CMP ECX,EBX + JNE @@misMatch + DEC ESI + JE @@cmpRestP4 + MOV ECX,[EAX+4] + MOV EBX,[EDX+4] + CMP ECX,EBX + JNE @@misMatch + ADD EAX,8 + ADD EDX,8 + DEC ESI + JNE @@longLoop + JMP @@cmpRest +@@cmpRestp4: + ADD EAX,4 + ADD EDX,4 +@@cmpRest: + POP ESI + AND ESI,3 + JE @@exit + + MOV CL,[EAX] + CMP CL,[EDX] + JNE @@exit + DEC ESI + JE @@equal + MOV CL,[EAX+1] + CMP CL,[EDX+1] + JNE @@exit + DEC ESI + JE @@equal + MOV CL,[EAX+2] + CMP CL,[EDX+2] + JNE @@exit + +@@equal: + XOR EAX,EAX + JMP @@exit + +@@misMatch: + POP ESI + CMP CL,BL + JNE @@exit + CMP CH,BH + JNE @@exit + SHR ECX,16 + SHR EBX,16 + CMP CL,BL + JNE @@exit + CMP CH,BH + +@@exit: + POP ESI + POP EBX +end; + +function _EofFile(var f: TFileRec): Boolean; +begin + Result := _FilePos(f) >= _FileSize(f); +end; + +function _EofText(var t: TTextRec): Boolean; +asm +// -> EAX Pointer to text record +// <- AL Boolean result + CMP [EAX].TTextRec.Mode,fmInput + JNE @@readChar + MOV EDX,[EAX].TTextRec.BufPos + CMP EDX,[EAX].TTextRec.BufEnd + JAE @@readChar + ADD EDX,[EAX].TTextRec.BufPtr + TEST [EAX].TTextRec.Flags,tfCRLF + JZ @@FalseExit + MOV CL,[EDX] + CMP CL,cEof + JNZ @@FalseExit + +@@eof: + MOV AL,1 + JMP @@exit + +@@readChar: + PUSH EAX + CALL _ReadChar + POP EDX + CMP AH,cEof + JE @@eof + DEC [EDX].TTextRec.BufPos +@@FalseExit: + XOR EAX,EAX +@@exit: +end; + +function _Eoln(var t: TTextRec): Boolean; +asm +// -> EAX Pointer to text record +// <- AL Boolean result + + CMP [EAX].TTextRec.Mode,fmInput + JNE @@readChar + MOV EDX,[EAX].TTextRec.BufPos + CMP EDX,[EAX].TTextRec.BufEnd + JAE @@readChar + ADD EDX,[EAX].TTextRec.BufPtr + TEST [EAX].TTextRec.Flags,tfCRLF + MOV AL,0 + MOV CL,[EDX] + JZ @@testLF + CMP CL,cCR + JE @@eol + CMP CL,cEOF + JE @@eof + JMP @@exit + +@@testLF: + CMP CL,cLF + JE @@eol + CMP CL,cEOF + JE @@eof + JMP @@exit + +@@readChar: + PUSH EAX + CALL _ReadChar + POP EDX + CMP AH,cEOF + JE @@eof + DEC [EDX].TTextRec.BufPos + XOR ECX,ECX + XCHG ECX,EAX + TEST [EDX].TTextRec.Mode,tfCRLF + JNE @@testLF + CMP CL,cCR + JE @@eol + JMP @@exit + +@@eol: +@@eof: + MOV AL,1 +@@exit: +end; + +procedure _Erase(var f: TFileRec); +begin + if (f.Mode < fmClosed) or (f.Mode > fmInOut) then + SetInOutRes(102) // file not assigned + else +{$IFDEF LINUX} + if __remove(f.Name) < 0 then + SetInOutRes(GetLastError); +{$ENDIF} +{$IFDEF MSWINDOWS} + if not DeleteFileA(f.Name) then + SetInOutRes(GetLastError); +{$ENDIF} +end; + +{$IFDEF MSWINDOWS} +// Floating-point divide reverse routine +// ST(1) = ST(0) / ST(1), pop ST + +procedure _FSafeDivideR; +asm + FXCH + JMP _FSafeDivide +end; + +// Floating-point divide routine +// ST(1) = ST(1) / ST(0), pop ST + +procedure _FSafeDivide; +type + Z = packed record // helper type to make parameter references more readable + Dividend: Extended; // (TBYTE PTR [ESP]) + Pad: Word; + Divisor: Extended; // (TBYTE PTR [ESP+12]) + end; +asm + CMP TestFDIV,0 //Check FDIV indicator + JLE @@FDivideChecked //Jump if flawed or don't know + FDIV //Known to be ok, so just do FDIV + RET + +// FDIV constants +@@FDIVRiscTable: DB 0,1,0,0,4,0,0,7,0,0,10,0,0,13,0,0; + +@@FDIVScale1: DD $3F700000 // 0.9375 +@@FDIVScale2: DD $3F880000 // 1.0625 +@@FDIV1SHL63: DD $5F000000 // 1 SHL 63 + +@@TestDividend: DD $C0000000,$4150017E // 4195835.0 +@@TestDivisor: DD $80000000,$4147FFFF // 3145727.0 +@@TestOne: DD $00000000,$3FF00000 // 1.0 + +// Flawed FDIV detection +@@FDivideDetect: + MOV TestFDIV,1 //Indicate correct FDIV + PUSH EAX + SUB ESP,12 + FSTP TBYTE PTR [ESP] //Save off ST + FLD QWORD PTR @@TestDividend //Ok if x - (x / y) * y < 1.0 + FDIV QWORD PTR @@TestDivisor + FMUL QWORD PTR @@TestDivisor + FSUBR QWORD PTR @@TestDividend + FCOMP QWORD PTR @@TestOne + FSTSW AX + SHR EAX,7 + AND EAX,002H //Zero if FDIV is flawed + DEC EAX + MOV TestFDIV,AL //1 means Ok, -1 means flawed + FLD TBYTE PTR [ESP] //Restore ST + ADD ESP,12 + POP EAX + JMP _FSafeDivide + +@@FDivideChecked: + JE @@FDivideDetect //Do detection if TestFDIV = 0 + +@@1: PUSH EAX + SUB ESP,24 + FSTP [ESP].Z.Divisor //Store Divisor and Dividend + FSTP [ESP].Z.Dividend + FLD [ESP].Z.Dividend + FLD [ESP].Z.Divisor +@@2: MOV EAX,DWORD PTR [ESP+4].Z.Divisor //Is Divisor a denormal? + ADD EAX,EAX + JNC @@20 //Yes, @@20 + XOR EAX,0E000000H //If these three bits are not all + TEST EAX,0E000000H //ones, FDIV will work + JZ @@10 //Jump if all ones +@@3: FDIV //Do FDIV and exit + ADD ESP,24 + POP EAX + RET + +@@10: SHR EAX,28 //If the four bits following the MSB + //of the mantissa have a decimal + //of 1, 4, 7, 10, or 13, FDIV may + CMP byte ptr @@FDIVRiscTable[EAX],0 //not work correctly + JZ @@3 //Do FDIV if not 1, 4, 7, 10, or 13 + MOV EAX,DWORD PTR [ESP+8].Z.Divisor //Get Divisor exponent + AND EAX,7FFFH + JZ @@3 //Ok to FDIV if denormal + CMP EAX,7FFFH + JE @@3 //Ok to FDIV if NAN or INF + MOV EAX,DWORD PTR [ESP+8].Z.Dividend //Get Dividend exponent + AND EAX,7FFFH + CMP EAX,1 //Small number? + JE @@11 //Yes, @@11 + FMUL DWORD PTR @@FDIVScale1 //Scale by 15/16 + FXCH + FMUL DWORD PTR @@FDIVScale1 + FXCH + JMP @@3 //FDIV is now safe + +@@11: FMUL DWORD PTR @@FDIVScale2 //Scale by 17/16 + FXCH + FMUL DWORD PTR @@FDIVScale2 + FXCH + JMP @@3 //FDIV is now safe + +@@20: MOV EAX,DWORD PTR [ESP].Z.Divisor //Is entire Divisor zero? + OR EAX,DWORD PTR [ESP+4].Z.Divisor + JZ @@3 //Yes, ok to FDIV + MOV EAX,DWORD PTR [ESP+8].Z.Divisor //Get Divisor exponent + AND EAX,7FFFH //Non-zero exponent is invalid + JNZ @@3 //Ok to FDIV if invalid + MOV EAX,DWORD PTR [ESP+8].Z.Dividend //Get Dividend exponent + AND EAX,7FFFH //Denormal? + JZ @@21 //Yes, @@21 + CMP EAX,7FFFH //NAN or INF? + JE @@3 //Yes, ok to FDIV + MOV EAX,DWORD PTR [ESP+4].Z.Dividend //If MSB of mantissa is zero, + ADD EAX,EAX //the number is invalid + JNC @@3 //Ok to FDIV if invalid + JMP @@22 +@@21: MOV EAX,DWORD PTR [ESP+4].Z.Dividend //If MSB of mantissa is zero, + ADD EAX,EAX //the number is invalid + JC @@3 //Ok to FDIV if invalid +@@22: FXCH //Scale stored Divisor image by + FSTP ST(0) //1 SHL 63 and restart + FLD ST(0) + FMUL DWORD PTR @@FDIV1SHL63 + FSTP [ESP].Z.Divisor + FLD [ESP].Z.Dividend + FXCH + JMP @@2 +end; +{$ENDIF} + +function _FilePos(var f: TFileRec): Longint; +begin + if (f.Mode > fmClosed) and (f.Mode <= fmInOut) then + begin +{$IFDEF LINUX} + Result := _lseek(f.Handle, 0, SEEK_CUR); +{$ENDIF} +{$IFDEF MSWINDOWS} + Result := SetFilePointer(f.Handle, 0, nil, FILE_CURRENT); +{$ENDIF} + if Result = -1 then + InOutError + else + Result := Cardinal(Result) div f.RecSize; + end + else + begin + SetInOutRes(103); + Result := -1; + end; +end; + +function _FileSize(var f: TFileRec): Longint; +{$IFDEF MSWINDOWS} +begin + Result := -1; + if (f.Mode > fmClosed) and (f.Mode <= fmInOut) then + begin + Result := GetFileSize(f.Handle, 0); + if Result = -1 then + InOutError + else + Result := Cardinal(Result) div f.RecSize; + end + else + SetInOutRes(103); +{$ENDIF} +{$IFDEF LINUX} +var + stat: TStatStruct; +begin + Result := -1; + if (f.Mode > fmClosed) and (f.Mode <= fmInOut) then + begin + if _fxstat(STAT_VER_LINUX, f.Handle, stat) <> 0 then + InOutError + else + Result := stat.st_size div f.RecSize; + end + else + SetInOutRes(103); +{$ENDIF} +end; + +procedure _FillChar(var Dest; count: Integer; Value: Char); +{$IFDEF PUREPASCAL} +var + I: Integer; + P: PChar; +begin + P := PChar(@Dest); + for I := count-1 downto 0 do + P[I] := Value; +end; +{$ELSE} +asm +{ ->EAX Pointer to destination } +{ EDX count } +{ CL value } + + PUSH EDI + + MOV EDI,EAX { Point EDI to destination } + + MOV CH,CL { Fill EAX with value repeated 4 times } + MOV EAX,ECX + SHL EAX,16 + MOV AX,CX + + MOV ECX,EDX + SAR ECX,2 + JS @@exit + + REP STOSD { Fill count DIV 4 dwords } + + MOV ECX,EDX + AND ECX,3 + REP STOSB { Fill count MOD 4 bytes } + +@@exit: + POP EDI +end; +{$ENDIF} + +procedure Mark; +begin + Error(reInvalidPtr); +end; + +procedure _RandInt; +asm +{ ->EAX Range } +{ <-EAX Result } + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX + MOV ECX,[EBX].OFFSET RandSeed + IMUL EDX,[ECX],08088405H + INC EDX + MOV [ECX],EDX +{$ELSE} + XOR EBX, EBX + IMUL EDX,[EBX].RandSeed,08088405H + INC EDX + MOV [EBX].RandSeed,EDX +{$ENDIF} + MUL EDX + MOV EAX,EDX + POP EBX +end; + +procedure _RandExt; +const two2neg32: double = ((1.0/$10000) / $10000); // 2^-32 +asm +{ FUNCTION _RandExt: Extended; } + + PUSH EBX +{$IFDEF PIC} + CALL GetGOT + MOV EBX,EAX + MOV ECX,[EBX].OFFSET RandSeed + IMUL EDX,[ECX],08088405H + INC EDX + MOV [ECX],EDX +{$ELSE} + XOR EBX, EBX + IMUL EDX,[EBX].RandSeed,08088405H + INC EDX + MOV [EBX].RandSeed,EDX +{$ENDIF} + + FLD [EBX].two2neg32 + PUSH 0 + PUSH EDX + FILD qword ptr [ESP] + ADD ESP,8 + FMULP ST(1), ST(0) + POP EBX +end; + +function _ReadRec(var f: TFileRec; Buffer: Pointer): Integer; +{$IFDEF LINUX} +begin + if (f.Mode and fmInput) = fmInput then // fmInput or fmInOut + begin + Result := __read(f.Handle, Buffer, f.RecSize); + if Result = -1 then + InOutError + else if Cardinal(Result) <> f.RecSize then + SetInOutRes(100); + end + else + begin + SetInOutRes(103); // file not open for input + Result := 0; + end; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm +// -> EAX Pointer to file variable +// EDX Pointer to buffer + + PUSH EBX + XOR ECX,ECX + MOV EBX,EAX + MOV CX,[EAX].TFileRec.Mode // File must be open + SUB ECX,fmInput + JE @@skip + SUB ECX,fmInOut-fmInput + JNE @@fileNotOpen +@@skip: + +// ReadFile(f.Handle, buffer, f.RecSize, @result, Nil); + + PUSH 0 // space for OS result + MOV EAX,ESP + + PUSH 0 // pass lpOverlapped + PUSH EAX // pass @result + + PUSH [EBX].TFileRec.RecSize // pass nNumberOfBytesToRead + + PUSH EDX // pass lpBuffer + PUSH [EBX].TFileRec.Handle // pass hFile + CALL ReadFile + POP EDX // pop result + DEC EAX // check EAX = TRUE + JNZ @@error + + CMP EDX,[EBX].TFileRec.RecSize // result = f.RecSize ? + JE @@exit + +@@readError: + MOV EAX,100 + JMP @@errExit + +@@fileNotOpen: + MOV EAX,103 + JMP @@errExit + +@@error: + CALL GetLastError +@@errExit: + CALL SetInOutRes +@@exit: + POP EBX +end; +{$ENDIF} + + +// If the file is Input std variable, try to open it +// Otherwise, runtime error. +function TryOpenForInput(var t: TTextRec): Boolean; +begin + if @t = @Input then + begin + t.Flags := tfCRLF * Byte(DefaultTextLineBreakStyle); + _ResetText(t); + end; + + Result := t.Mode = fmInput; + if not Result then + SetInOutRes(104); +end; + +function _ReadChar(var t: TTextRec): Char; +asm +// -> EAX Pointer to text record +// <- AL Character read. (may be a pseudo cEOF in DOS mode) +// <- AH cEOF = End of File, else 0 +// For eof, #$1A is returned in AL and in AH. +// For errors, InOutRes is set and #$1A is returned. + + CMP [EAX].TTextRec.Mode, fmInput + JE @@checkBuf + PUSH EAX + CALL TryOpenForInput + TEST AL,AL + POP EAX + JZ @@eofexit + +@@checkBuf: + MOV EDX,[EAX].TTextRec.BufPos + CMP EDX,[EAX].TTextRec.BufEnd + JAE @@fillBuf +@@cont: + TEST [EAX].TTextRec.Flags,tfCRLF + MOV ECX,[EAX].TTextRec.BufPtr + MOV CL,[ECX+EDX] + JZ @@cont2 + CMP CL,cEof // Check for EOF char in DOS mode + JE @@eofexit +@@cont2: + INC EDX + MOV [EAX].TTextRec.BufPos,EDX + XOR EAX,EAX + JMP @@exit + +@@fillBuf: + PUSH EAX + CALL [EAX].TTextRec.InOutFunc + TEST EAX,EAX + JNE @@error + POP EAX + MOV EDX,[EAX].TTextRec.BufPos + CMP EDX,[EAX].TTextRec.BufEnd + JB @@cont + +// We didn't get characters. Must be eof then. + +@@eof: + TEST [EAX].TTextRec.Flags,tfCRLF + JZ @@eofexit +// In DOS CRLF compatibility mode, synthesize an EOF char +// Store one eof in the buffer and increment BufEnd + MOV ECX,[EAX].TTextRec.BufPtr + MOV byte ptr [ECX+EDX],cEof + INC [EAX].TTextRec.BufEnd + JMP @@eofexit + +@@error: + CALL SetInOutRes + POP EAX +@@eofexit: + MOV CL,cEof + MOV AH,CL +@@exit: + MOV AL,CL +end; + +function _ReadLong(var t: TTextRec): Longint; +asm +// -> EAX Pointer to text record +// <- EAX Result + + PUSH EBX + PUSH ESI + PUSH EDI + SUB ESP,36 // var numbuf: String[32]; + + MOV ESI,EAX + CALL _SeekEof + DEC AL + JZ @@eof + + MOV EDI,ESP // EDI -> numBuf[0] + MOV BL,32 +@@loop: + MOV EAX,ESI + CALL _ReadChar + CMP AL,' ' + JBE @@endNum + STOSB + DEC BL + JNZ @@loop +@@convert: + MOV byte ptr [EDI],0 + MOV EAX,ESP // EAX -> numBuf + PUSH EDX // allocate code result + MOV EDX,ESP // pass pointer to code + CALL _ValLong // convert + POP EDX // pop code result into EDX + TEST EDX,EDX + JZ @@exit + MOV EAX,106 + CALL SetInOutRes + JMP @@exit + +@@endNum: + CMP AH,cEof + JE @@convert + DEC [ESI].TTextRec.BufPos + JMP @@convert + +@@eof: + XOR EAX,EAX +@@exit: + ADD ESP,36 + POP EDI + POP ESI + POP EBX +end; + +function ReadLine(var t: TTextRec; buf: Pointer; maxLen: Longint): Pointer; +asm +// -> EAX Pointer to text record +// EDX Pointer to buffer +// ECX Maximum count of chars to read +// <- ECX Actual count of chars in buffer +// <- EAX Pointer to text record + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH ECX + MOV ESI,ECX + MOV EDI,EDX + + CMP [EAX].TTextRec.Mode,fmInput + JE @@start + PUSH EAX + CALL TryOpenForInput + TEST AL,AL + POP EAX + JZ @@exit + +@@start: + MOV EBX,EAX + + TEST ESI,ESI + JLE @@exit + + MOV EDX,[EBX].TTextRec.BufPos + MOV ECX,[EBX].TTextRec.BufEnd + SUB ECX,EDX + ADD EDX,[EBX].TTextRec.BufPtr + +@@loop: + DEC ECX + JL @@readChar + MOV AL,[EDX] + INC EDX +@@cont: + CMP AL,cLF + JE @@lf + + CMP AL,cCR + JE @@cr + + CMP AL,cEOF + JE @@eof + +@@store: + STOSB + DEC ESI + JG @@loop + JMP @@finish + +@@eof: + TEST [EBX].TTextRec.Flags,tfCRLF + JZ @@store + JMP @@finish + +@@cr: + MOV AL,[EDX] + CMP AL,cLF + JNE @@loop +@@lf: + DEC EDX +@@finish: + SUB EDX,[EBX].TTextRec.BufPtr + MOV [EBX].TTextRec.BufPos,EDX + JMP @@exit + +@@readChar: + MOV [EBX].TTextRec.BufPos,EDX + MOV EAX,EBX + CALL _ReadChar + MOV EDX,[EBX].TTextRec.BufPos + MOV ECX,[EBX].TTextRec.BufEnd + SUB ECX,EDX + ADD EDX,[EBX].TTextRec.BufPtr + TEST AH,AH //eof + JZ @@cont + +@@exit: + MOV EAX,EBX + POP ECX + SUB ECX,ESI + POP EDI + POP ESI + POP EBX +end; + +procedure _ReadString(var t: TTextRec; s: PShortString; maxLen: Longint); +asm +// -> EAX Pointer to text record +// EDX Pointer to string +// ECX Maximum length of string + + PUSH EDX + INC EDX + CALL ReadLine + POP EDX + MOV [EDX],CL +end; + +procedure _ReadCString(var t: TTextRec; s: PChar; maxLen: Longint); +asm +// -> EAX Pointer to text record +// EDX Pointer to string +// ECX Maximum length of string + + PUSH EDX + CALL ReadLine + POP EDX + MOV byte ptr [EDX+ECX],0 +end; + +procedure _ReadLString(var t: TTextRec; var s: AnsiString); +asm + { -> EAX pointer to Text } + { EDX pointer to AnsiString } + + PUSH EBX + PUSH ESI + MOV EBX,EAX + MOV ESI,EDX + + MOV EAX,EDX + CALL _LStrClr + + SUB ESP,256 + + MOV EAX,EBX + MOV EDX,ESP + MOV ECX,255 + CALL _ReadString + + MOV EAX,ESI + MOV EDX,ESP + CALL _LStrFromString + + CMP byte ptr [ESP],255 + JNE @@exit +@@loop: + + MOV EAX,EBX + MOV EDX,ESP + MOV ECX,255 + CALL _ReadString + + MOV EDX,ESP + PUSH 0 + MOV EAX,ESP + CALL _LStrFromString + + MOV EAX,ESI + MOV EDX,[ESP] + CALL _LStrCat + + MOV EAX,ESP + CALL _LStrClr + POP EAX + + CMP byte ptr [ESP],255 + JE @@loop + +@@exit: + ADD ESP,256 + POP ESI + POP EBX +end; + + +function IsValidMultibyteChar(const Src: PChar; SrcBytes: Integer): Boolean; +{$IFDEF MSWINDOWS} +const + ERROR_NO_UNICODE_TRANSLATION = 1113; // Win32 GetLastError when result = 0 + MB_ERR_INVALID_CHARS = 8; +var + Dest: WideChar; +begin + Result := MultiByteToWideChar(DefaultUserCodePage, MB_ERR_INVALID_CHARS, Src, SrcBytes, @Dest, 1) <> 0; +{$ENDIF} +{$IFDEF LINUX} +begin + Result := mblen(Src, SrcBytes) <> -1; +{$ENDIF} +end; + + +function _ReadWChar(var t: TTextRec): WideChar; +var + scratch: array [0..7] of AnsiChar; + wc: WideChar; + i: Integer; +begin + i := 0; + while i < High(scratch) do + begin + scratch[i] := _ReadChar(t); + Inc(i); + scratch[i] := #0; + if IsValidMultibyteChar(scratch, i) then + begin + WCharFromChar(@wc, 1, scratch, i); + Result := wc; + Exit; + end; + end; + SetInOutRes(106); // Invalid Input + Result := #0; +end; + + +procedure _ReadWCString(var t: TTextRec; s: PWideChar; maxBytes: Longint); +var + i, maxLen: Integer; + wc: WideChar; +begin + if s = nil then Exit; + i := 0; + maxLen := maxBytes div sizeof(WideChar); + while i < maxLen do + begin + wc := _ReadWChar(t); + case Integer(wc) of + cEOF: if _EOFText(t) then Break; + cLF : begin + Dec(t.BufPos); + Break; + end; + cCR : if Byte(t.BufPtr[t.BufPos]) = cLF then + begin + Dec(t.BufPos); + Break; + end; + end; + s[i] := wc; + Inc(i); + end; + s[i] := #0; +end; + +procedure _ReadWString(var t: TTextRec; var s: WideString); +var + Temp: AnsiString; +begin + _ReadLString(t, Temp); + s := Temp; +end; + +function _ReadExt(var t: TTextRec): Extended; +asm +// -> EAX Pointer to text record +// <- FST(0) Result + + PUSH EBX + PUSH ESI + PUSH EDI + SUB ESP,68 // var numbuf: array[0..64] of char; + + MOV ESI,EAX + CALL _SeekEof + DEC AL + JZ @@eof + + MOV EDI,ESP // EDI -> numBuf[0] + MOV BL,64 +@@loop: + MOV EAX,ESI + CALL _ReadChar + CMP AL,' ' + JBE @@endNum + STOSB + DEC BL + JNZ @@loop +@@convert: + MOV byte ptr [EDI],0 + MOV EAX,ESP // EAX -> numBuf + PUSH EDX // allocate code result + MOV EDX,ESP // pass pointer to code + CALL _ValExt // convert + POP EDX // pop code result into EDX + TEST EDX,EDX + JZ @@exit + MOV EAX,106 + CALL SetInOutRes + JMP @@exit + +@@endNum: + CMP AH,cEOF + JE @@convert + DEC [ESI].TTextRec.BufPos + JMP @@convert + +@@eof: + FLDZ +@@exit: + ADD ESP,68 + POP EDI + POP ESI + POP EBX +end; + +procedure _ReadLn(var t: TTextRec); +asm +// -> EAX Pointer to text record + + PUSH EBX + MOV EBX,EAX +@@loop: + MOV EAX,EBX + CALL _ReadChar + + CMP AL,cLF // accept LF as end of line + JE @@exit + CMP AH,cEOF + JE @@eof + CMP AL,cCR + JNE @@loop + + MOV EAX,EBX + CALL _ReadChar + + CMP AL,cLF // accept CR+LF as end of line + JE @@exit + CMP AH,cEOF // accept CR+EOF as end of line + JE @@eof + DEC [EBX].TTextRec.BufPos + JMP @@loop // else CR+ anything else is not a line break. + +@@exit: +@@eof: + POP EBX +end; + +procedure _Rename(var f: TFileRec; newName: PChar); +var + I: Integer; +begin + if f.Mode = fmClosed then + begin + if newName = nil then newName := ''; +{$IFDEF LINUX} + if __rename(f.Name, newName) = 0 then +{$ENDIF} +{$IFDEF MSWINDOWS} + if MoveFileA(f.Name, newName) then +{$ENDIF} + begin + I := 0; + while (newName[I] <> #0) and (I < High(f.Name)) do + begin + f.Name[I] := newName[I]; + Inc(I); + end + end + else + SetInOutRes(GetLastError); + end + else + SetInOutRes(102); +end; + +procedure Release; +begin + Error(reInvalidPtr); +end; + +function _CloseFile(var f: TFileRec): Integer; +begin + f.Mode := fmClosed; + Result := 0; + if not InternalClose(f.Handle) then + begin + InOutError; + Result := 1; + end; +end; + +function OpenFile(var f: TFileRec; recSiz: Longint; mode: Longint): Integer; +{$IFDEF LINUX} +var + Flags: Integer; +begin + Result := 0; + if (f.Mode >= fmClosed) and (f.Mode <= fmInOut) then + begin + if f.Mode <> fmClosed then // not yet closed: close it + begin + Result := TFileIOFunc(f.CloseFunc)(f); + if Result <> 0 then + SetInOutRes(Result); + end; + + if recSiz <= 0 then + SetInOutRes(106); + + f.RecSize := recSiz; + f.InOutFunc := @FileNopProc; + + if f.Name[0] <> #0 then + begin + f.CloseFunc := @_CloseFile; + case mode of + 1: begin + Flags := O_APPEND or O_WRONLY; + f.Mode := fmOutput; + end; + 2: begin + Flags := O_RDWR; + f.Mode := fmInOut; + end; + 3: begin + Flags := O_CREAT or O_TRUNC or O_RDWR; + f.Mode := fmInOut; + end; + else + Flags := O_RDONLY; + f.Mode := fmInput; + end; + + f.Handle := __open(f.Name, Flags, FileAccessRights); + end + else // stdin or stdout + begin + f.CloseFunc := @FileNopProc; + if mode = 3 then + f.Handle := STDOUT_FILENO + else + f.Handle := STDIN_FILENO; + end; + + if f.Handle = -1 then + begin + f.Mode := fmClosed; + InOutError; + end; + end + else + SetInOutRes(102); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +const + ShareTab: array [0..7] of Integer = + (FILE_SHARE_READ OR FILE_SHARE_WRITE, // OF_SHARE_COMPAT 0x00000000 + 0, // OF_SHARE_EXCLUSIVE 0x00000010 + FILE_SHARE_READ, // OF_SHARE_DENY_WRITE 0x00000020 + FILE_SHARE_WRITE, // OF_SHARE_DENY_READ 0x00000030 + FILE_SHARE_READ OR FILE_SHARE_WRITE, // OF_SHARE_DENY_NONE 0x00000040 + 0,0,0); +asm +//-> EAX Pointer to file record +// EDX Record size +// ECX File mode + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EDX + MOV EDI,ECX + XOR EDX,EDX + MOV EBX,EAX + + MOV DX,[EAX].TFileRec.Mode + SUB EDX,fmClosed + JE @@alreadyClosed + CMP EDX,fmInOut-fmClosed + JA @@notAssignedError + +// not yet closed: close it. File parameter is still in EAX + + CALL [EBX].TFileRec.CloseFunc + TEST EAX,EAX + JE @@alreadyClosed + CALL SetInOutRes + +@@alreadyClosed: + + MOV [EBX].TFileRec.Mode,fmInOut + MOV [EBX].TFileRec.RecSize,ESI + MOV [EBX].TFileRec.CloseFunc,offset _CloseFile + MOV [EBX].TFileRec.InOutFunc,offset FileNopProc + + CMP byte ptr [EBX].TFileRec.Name,0 + JE @@isCon + + MOV EAX,GENERIC_READ OR GENERIC_WRITE + MOV DL,FileMode + AND EDX,070H + SHR EDX,4-2 + MOV EDX,dword ptr [shareTab+EDX] + MOV ECX,CREATE_ALWAYS + + SUB EDI,3 + JE @@calledByRewrite + + MOV ECX,OPEN_EXISTING + INC EDI + JE @@skip + + MOV EAX,GENERIC_WRITE + INC EDI + MOV [EBX].TFileRec.Mode,fmOutput + JE @@skip + + MOV EAX,GENERIC_READ + MOV [EBX].TFileRec.Mode,fmInput + +@@skip: +@@calledByRewrite: + +// CreateFile(t.FileName, EAX, EDX, Nil, ECX, FILE_ATTRIBUTE_NORMAL, 0); + + PUSH 0 + PUSH FILE_ATTRIBUTE_NORMAL + PUSH ECX + PUSH 0 + PUSH EDX + PUSH EAX + LEA EAX,[EBX].TFileRec.Name + PUSH EAX + CALL CreateFileA +@@checkHandle: + CMP EAX,-1 + JZ @@error + + MOV [EBX].TFileRec.Handle,EAX + JMP @@exit + +@@isCon: + MOV [EBX].TFileRec.CloseFunc,offset FileNopProc + CMP EDI,3 + JE @@output + PUSH STD_INPUT_HANDLE + JMP @@1 +@@output: + PUSH STD_OUTPUT_HANDLE +@@1: + CALL GetStdHandle + JMP @@checkHandle + +@@notAssignedError: + MOV EAX,102 + JMP @@errExit + +@@error: + MOV [EBX].TFileRec.Mode,fmClosed + CALL GetLastError +@@errExit: + CALL SetInOutRes + +@@exit: + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +function _ResetFile(var f: TFileRec; recSize: Longint): Integer; +var + m: Byte; +begin + m := FileMode and 3; + if m > 2 then m := 2; + Result := OpenFile(f, recSize, m); +end; + +function _RewritFile(var f: TFileRec; recSize: Longint): Integer; +begin + Result := OpenFile(f, recSize, 3); +end; + +procedure _Seek(var f: TFileRec; recNum: Cardinal); +{$IFDEF LINUX} +begin + if (f.Mode >= fmInput) and (f.Mode <= fmInOut) then + begin + if _lseek(f.Handle, f.RecSize * recNum, SEEK_SET) = -1 then + InOutError; + end + else + SetInOutRes(103); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm +// -> EAX Pointer to file variable +// EDX Record number + + MOV ECX,EAX + MOVZX EAX,[EAX].TFileRec.Mode // check whether file is open + SUB EAX,fmInput + CMP EAX,fmInOut-fmInput + JA @@fileNotOpen + +// SetFilePointer(f.Handle, recNum*f.RecSize, FILE_BEGIN + PUSH FILE_BEGIN // pass dwMoveMethod + MOV EAX,[ECX].TFileRec.RecSize + MUL EDX + PUSH 0 // pass lpDistanceToMoveHigh + PUSH EAX // pass lDistanceToMove + PUSH [ECX].TFileRec.Handle // pass hFile + CALL SetFilePointer // get current position + INC EAX + JZ InOutError + JMP @@exit + +@@fileNotOpen: + MOV EAX,103 + JMP SetInOutRes + +@@exit: +end; +{$ENDIF} + +function _SeekEof(var t: TTextRec): Boolean; +asm +// -> EAX Pointer to text record +// <- AL Boolean result + + PUSH EBX + MOV EBX,EAX +@@loop: + MOV EAX,EBX + CALL _ReadChar + CMP AL,' ' + JA @@endloop + CMP AH,cEOF + JE @@eof + JMP @@loop +@@eof: + MOV AL,1 + JMP @@exit + +@@endloop: + DEC [EBX].TTextRec.BufPos + XOR AL,AL +@@exit: + POP EBX +end; + +function _SeekEoln(var t: TTextRec): Boolean; +asm +// -> EAX Pointer to text record +// <- AL Boolean result + + PUSH EBX + MOV EBX,EAX +@@loop: + MOV EAX,EBX + CALL _ReadChar + CMP AL,' ' + JA @@falseExit + CMP AH,cEOF + JE @@eof + CMP AL,cLF + JE @@trueExit + CMP AL,cCR + JNE @@loop + +@@trueExit: + MOV AL,1 + JMP @@exitloop + +@@falseExit: + XOR AL,AL +@@exitloop: + DEC [EBX].TTextRec.BufPos + JMP @@exit + +@@eof: + MOV AL,1 +@@exit: + POP EBX +end; + +procedure _SetTextBuf(var t: TTextRec; p: Pointer; size: Longint); +begin + if size < 0 then + Error(reRangeError); + t.BufPtr := P; + t.BufSize := size; + t.BufPos := 0; + t.BufEnd := 0; +end; + +procedure _StrLong(val, width: Longint; s: PShortString); +{$IFDEF PUREPASCAL} +var + I: Integer; + sign: Longint; + a: array [0..19] of char; + P: PChar; +begin + sign := val; + val := Abs(val); + I := 0; + repeat + a[I] := Chr((val mod 10) + Ord('0')); + Inc(I); + val := val div 10; + until val = 0; + + if sign < 0 then + begin + a[I] := '-'; + Inc(I); + end; + + if width < I then + width := I; + if width > 255 then + width := 255; + s^[0] := Chr(width); + P := @S^[1]; + while width > I do + begin + P^ := ' '; + Inc(P); + Dec(width); + end; + repeat + Dec(I); + P^ := a[I]; + Inc(P); + until I <= 0; +end; +{$ELSE} +asm +{ PROCEDURE _StrLong( val: Longint; width: Longint; VAR s: ShortString ); + ->EAX Value + EDX Width + ECX Pointer to string } + + PUSH EBX { VAR i: Longint; } + PUSH ESI { VAR sign : Longint; } + PUSH EDI + PUSH EDX { store width on the stack } + SUB ESP,20 { VAR a: array [0..19] of Char; } + + MOV EDI,ECX + + MOV ESI,EAX { sign := val } + + CDQ { val := Abs(val); canned sequence } + XOR EAX,EDX + SUB EAX,EDX + + MOV ECX,10 + XOR EBX,EBX { i := 0; } + +@@repeat1: { repeat } + XOR EDX,EDX { a[i] := Chr( val MOD 10 + Ord('0') );} + + DIV ECX { val := val DIV 10; } + + ADD EDX,'0' + MOV [ESP+EBX],DL + INC EBX { i := i + 1; } + TEST EAX,EAX { until val = 0; } + JNZ @@repeat1 + + TEST ESI,ESI + JGE @@2 + MOV byte ptr [ESP+EBX],'-' + INC EBX +@@2: + MOV [EDI],BL { s^++ := Chr(i); } + INC EDI + + MOV ECX,[ESP+20] { spaceCnt := width - i; } + CMP ECX,255 + JLE @@3 + MOV ECX,255 +@@3: + SUB ECX,EBX + JLE @@repeat2 { for k := 1 to spaceCnt do s^++ := ' '; } + ADD [EDI-1],CL + MOV AL,' ' + REP STOSB + +@@repeat2: { repeat } + MOV AL,[ESP+EBX-1] { s^ := a[i-1]; } + MOV [EDI],AL + INC EDI { s := s + 1 } + DEC EBX { i := i - 1; } + JNZ @@repeat2 { until i = 0; } + + ADD ESP,20+4 + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +procedure _Str0Long(val: Longint; s: PShortString); +begin + _StrLong(val, 0, s); +end; + +procedure _Truncate(var f: TFileRec); +{$IFDEF LINUX} +begin + if (f.Mode and fmOutput) = fmOutput then // fmOutput or fmInOut + begin + if _ftruncate(f.Handle, _lseek(f.Handle, 0, SEEK_CUR)) = -1 then + InOutError; + end + else + SetInOutRes(103); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm +// -> EAX Pointer to text or file variable + + MOVZX EDX,[EAX].TFileRec.Mode // check whether file is open + SUB EDX,fmInput + CMP EDX,fmInOut-fmInput + JA @@fileNotOpen + + PUSH [EAX].TFileRec.Handle + CALL SetEndOfFile + DEC EAX + JZ @@exit + JMP InOutError + +@@fileNotOpen: + MOV EAX,103 + JMP SetInOutRes + +@@exit: +end; +{$ENDIF} + +function _ValLong(const s: String; var code: Integer): Longint; +{$IFDEF PUREPASCAL} +var + I: Integer; + Negative, Hex: Boolean; +begin + I := 1; + code := -1; + Result := 0; + Negative := False; + Hex := False; + while (I <= Length(s)) and (s[I] = ' ') do Inc(I); + if I > Length(s) then Exit; + case s[I] of + '$', + 'x', + 'X': begin + Hex := True; + Inc(I); + end; + '0': begin + Hex := (Length(s) > I) and (UpCase(s[I+1]) = 'X'); + if Hex then Inc(I,2); + end; + '-': begin + Negative := True; + Inc(I); + end; + '+': Inc(I); + end; + if Hex then + while I <= Length(s) do + begin + if Result > (High(Result) div 16) then + begin + code := I; + Exit; + end; + case s[I] of + '0'..'9': Result := Result * 16 + Ord(s[I]) - Ord('0'); + 'a'..'f': Result := Result * 16 + Ord(s[I]) - Ord('a') + 10; + 'A'..'F': Result := Result * 16 + Ord(s[I]) - Ord('A') + 10; + else + code := I; + Exit; + end; + end + else + while I <= Length(s) do + begin + if Result > (High(Result) div 10) then + begin + code := I; + Exit; + end; + Result := Result * 10 + Ord(s[I]) - Ord('0'); + Inc(I); + end; + if Negative then + Result := -Result; + code := 0; +end; +{$ELSE} +asm +{ FUNCTION _ValLong( s: AnsiString; VAR code: Integer ) : Longint; } +{ ->EAX Pointer to string } +{ EDX Pointer to code result } +{ <-EAX Result } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX + PUSH EAX { save for the error case } + + TEST EAX,EAX + JE @@empty + + XOR EAX,EAX + XOR EBX,EBX + MOV EDI,07FFFFFFFH / 10 { limit } + +@@blankLoop: + MOV BL,[ESI] + INC ESI + CMP BL,' ' + JE @@blankLoop + +@@endBlanks: + MOV CH,0 + CMP BL,'-' + JE @@minus + CMP BL,'+' + JE @@plus + +@@checkDollar: + CMP BL,'$' + JE @@dollar + + CMP BL, 'x' + JE @@dollar + CMP BL, 'X' + JE @@dollar + CMP BL, '0' + JNE @@firstDigit + MOV BL, [ESI] + INC ESI + CMP BL, 'x' + JE @@dollar + CMP BL, 'X' + JE @@dollar + TEST BL, BL + JE @@endDigits + JMP @@digLoop + +@@firstDigit: + TEST BL,BL + JE @@error + +@@digLoop: + SUB BL,'0' + CMP BL,9 + JA @@error + CMP EAX,EDI { value > limit ? } + JA @@overFlow + LEA EAX,[EAX+EAX*4] + ADD EAX,EAX + ADD EAX,EBX { fortunately, we can't have a carry } + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JNE @@digLoop + +@@endDigits: + DEC CH + JE @@negate + TEST EAX,EAX + JGE @@successExit + JMP @@overFlow + +@@empty: + INC ESI + JMP @@error + +@@negate: + NEG EAX + JLE @@successExit + JS @@successExit { to handle 2**31 correctly, where the negate overflows } + +@@error: +@@overFlow: + POP EBX + SUB ESI,EBX + JMP @@exit + +@@minus: + INC CH +@@plus: + MOV BL,[ESI] + INC ESI + JMP @@checkDollar + +@@dollar: + MOV EDI,0FFFFFFFH + + MOV BL,[ESI] + INC ESI + TEST BL,BL + JZ @@empty + +@@hDigLoop: + CMP BL,'a' + JB @@upper + SUB BL,'a' - 'A' +@@upper: + SUB BL,'0' + CMP BL,9 + JBE @@digOk + SUB BL,'A' - '0' + CMP BL,5 + JA @@error + ADD BL,10 +@@digOk: + CMP EAX,EDI + JA @@overFlow + SHL EAX,4 + ADD EAX,EBX + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JNE @@hDigLoop + + DEC CH + JNE @@successExit + NEG EAX + +@@successExit: + POP ECX { saved copy of string pointer } + XOR ESI,ESI { signal no error to caller } + +@@exit: + MOV [EDX],ESI + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +function _WriteRec(var f: TFileRec; buffer: Pointer): Pointer; +{$IFDEF LINUX} +var + Dummy: Integer; +begin + _BlockWrite(f, Buffer, 1, Dummy); + Result := @F; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm +// -> EAX Pointer to file variable +// EDX Pointer to buffer +// <- EAX Pointer to file variable + PUSH EBX + + MOV EBX,EAX + + MOVZX EAX,[EAX].TFileRec.Mode + SUB EAX,fmOutput + CMP EAX,fmInOut-fmOutput // File must be fmInOut or fmOutput + JA @@fileNotOpen + +// WriteFile(f.Handle, buffer, f.RecSize, @result, Nil); + + PUSH 0 // space for OS result + MOV EAX,ESP + + PUSH 0 // pass lpOverlapped + PUSH EAX // pass @result + PUSH [EBX].TFileRec.RecSize // pass nNumberOfBytesToRead + PUSH EDX // pass lpBuffer + PUSH [EBX].TFileRec.Handle // pass hFile + CALL WriteFile + POP EDX // pop result + DEC EAX // check EAX = TRUE + JNZ @@error + + CMP EDX,[EBX].TFileRec.RecSize // result = f.RecSize ? + JE @@exit + +@@writeError: + MOV EAX,101 + JMP @@errExit + +@@fileNotOpen: + MOV EAX,5 + JMP @@errExit + +@@error: + CALL GetLastError +@@errExit: + CALL SetInOutRes +@@exit: + MOV EAX,EBX + POP EBX +end; +{$ENDIF} + +// If the file is Output or ErrOutput std variable, try to open it +// Otherwise, runtime error. +function TryOpenForOutput(var t: TTextRec): Boolean; +begin + if (@t = @Output) or (@t = @ErrOutput) then + begin + t.Flags := tfCRLF * Byte(DefaultTextLineBreakStyle); + _RewritText(t); + end; + + Result := t.Mode = fmOutput; + if not Result then + SetInOutRes(105); +end; + +function _WriteBytes(var t: TTextRec; const b; cnt : Longint): Pointer; +{$IFDEF PUREPASCAL} +var + P: PChar; + RemainingBytes: Longint; + Temp: Integer; +begin + Result := @t; + if t.Mode <> fmOutput and not TryOpenForOutput(t) then Exit; + + P := t.BufPtr + t.BufPos; + RemainingBytes := t.BufSize - t.BufPos; + while RemainingBytes <= cnt do + begin + Inc(t.BufPos, RemainingBytes); + Dec(cnt, RemainingBytes); + Move(B, P^, RemainingBytes); + Temp := TTextIOFunc(t.InOutFunc)(t); + if Temp <> 0 then + begin + SetInOutRes(Temp); + Exit; + end; + P := t.BufPtr + t.BufPos; + RemainingBytes := t.BufSize - t.BufPos; + end; + Inc(t.BufPos, cnt); + Move(B, P^, cnt); +end; +{$ELSE} +asm +// -> EAX Pointer to file record +// EDX Pointer to buffer +// ECX Number of bytes to write +// <- EAX Pointer to file record + + PUSH ESI + PUSH EDI + + MOV ESI,EDX + + CMP [EAX].TTextRec.Mode,fmOutput + JE @@loop + PUSH EAX + PUSH EDX + PUSH ECX + CALL TryOpenForOutput + TEST AL,AL + POP ECX + POP EDX + POP EAX + JE @@exit + +@@loop: + MOV EDI,[EAX].TTextRec.BufPtr + ADD EDI,[EAX].TTextRec.BufPos + +// remainingBytes = t.bufSize - t.bufPos + + MOV EDX,[EAX].TTextRec.BufSize + SUB EDX,[EAX].TTextRec.BufPos + +// if (remainingBytes <= cnt) + + CMP EDX,ECX + JG @@1 + +// t.BufPos += remainingBytes, cnt -= remainingBytes + + ADD [EAX].TTextRec.BufPos,EDX + SUB ECX,EDX + +// copy remainingBytes, advancing ESI + + PUSH EAX + PUSH ECX + MOV ECX,EDX + REP MOVSB + + CALL [EAX].TTextRec.InOutFunc + TEST EAX,EAX + JNZ @@error + + POP ECX + POP EAX + JMP @@loop + +@@error: + CALL SetInOutRes + POP ECX + POP EAX + JMP @@exit +@@1: + ADD [EAX].TTextRec.BufPos,ECX + REP MOVSB + +@@exit: + POP EDI + POP ESI +end; +{$ENDIF} + +function _WriteSpaces(var t: TTextRec; cnt: Longint): Pointer; +{$IFDEF PUREPASCAL} +const + s64Spaces = ' '; +begin + Result := @t; + while cnt > 64 do + begin + _WriteBytes(t, s64Spaces, 64); + if InOutRes <> 0 then Exit; + Dec(cnt, 64); + end; + if cnt > 0 then + _WriteBytes(t, s64Spaces, cnt); +end; +{$ELSE} +const + spCnt = 64; +asm +// -> EAX Pointer to text record +// EDX Number of spaces (<= 0: None) + + MOV ECX,EDX +@@loop: +{$IFDEF PIC} + LEA EDX, [EBX] + offset @@spBuf +{$ELSE} + MOV EDX,offset @@spBuf +{$ENDIF} + + CMP ECX,spCnt + JLE @@1 + + SUB ECX,spCnt + PUSH EAX + PUSH ECX + MOV ECX,spCnt + CALL _WriteBytes + CALL SysInit.@GetTLS + CMP [EAX].InOutRes,0 + JNE @@error + POP ECX + POP EAX + JMP @@loop + +@@error: + POP ECX + POP EAX + JMP @@exit + +@@spBuf: // 64 spaces + DB ' '; +@@1: + TEST ECX,ECX + JG _WriteBytes +@@exit: +end; +{$ENDIF} + +function _Write0Char(var t: TTextRec; c: Char): Pointer; +{$IFDEF PUREPASCAL} +var + Temp: Integer; +begin + Result := @t; + if not TryOpenForOutput(t) then Exit; + + if t.BufPos >= t.BufSize then + begin + Temp := TTextIOFunc(t.InOutFunc)(t); + if Temp <> 0 then + begin + SetInOutRes(Temp); + Exit; + end; + end; + + t.BufPtr[t.BufPos] := c; + Inc(t.BufPos); +end; +{$ELSE} +asm +// -> EAX Pointer to text record +// DL Character + + CMP [EAX].TTextRec.Mode,fmOutput + JE @@loop + PUSH EAX + PUSH EDX + CALL TryOpenForOutput + TEST AL,AL + POP EDX + POP EAX + JNE @@loop + JMP @@exit + +@@flush: + PUSH EAX + PUSH EDX + CALL [EAX].TTextRec.InOutFunc + TEST EAX,EAX + JNZ @@error + POP EDX + POP EAX + JMP @@loop + +@@error: + CALL SetInOutRes + POP EDX + POP EAX + JMP @@exit + +@@loop: + MOV ECX,[EAX].TTextRec.BufPos + CMP ECX,[EAX].TTextRec.BufSize + JGE @@flush + + ADD ECX,[EAX].TTextRec.BufPtr + MOV [ECX],DL + + INC [EAX].TTextRec.BufPos +@@exit: +end; +{$ENDIF} + +function _WriteChar(var t: TTextRec; c: Char; width: Integer): Pointer; +begin + _WriteSpaces(t, width-1); + Result := _WriteBytes(t, c, 1); +end; + +function _WriteBool(var t: TTextRec; val: Boolean; width: Longint): Pointer; +const + BoolStrs: array [Boolean] of ShortString = ('FALSE', 'TRUE'); +begin + Result := _WriteString(t, BoolStrs[val], width); +end; + +function _Write0Bool(var t: TTextRec; val: Boolean): Pointer; +begin + Result := _WriteBool(t, val, 0); +end; + +function _WriteLong(var t: TTextRec; val, width: Longint): Pointer; +var + S: string[31]; +begin + Str(val:0, S); + Result := _WriteString(t, S, width); +end; + +function _Write0Long(var t: TTextRec; val: Longint): Pointer; +begin + Result := _WriteLong(t, val, 0); +end; + +function _Write0String(var t: TTextRec; const s: ShortString): Pointer; +begin + Result := _WriteBytes(t, S[1], Byte(S[0])); +end; + +function _WriteString(var t: TTextRec; const s: ShortString; width: Longint): Pointer; +begin + _WriteSpaces(t, Width - Byte(S[0])); + Result := _WriteBytes(t, S[1], Byte(S[0])); +end; + +function _Write0CString(var t: TTextRec; s: PChar): Pointer; +begin + Result := _WriteCString(t, s, 0); +end; + +function _WriteCString(var t: TTextRec; s: PChar; width: Longint): Pointer; +var + len: Longint; +begin + {$IFDEF LINUX} + if Assigned(s) then + len := _strlen(s) + else + len := 0; + {$ENDIF} + {$IFDEF MSWINDOWS} + len := _strlen(s); + {$ENDIF} + _WriteSpaces(t, width - len); + Result := _WriteBytes(t, s^, len); +end; + +procedure _Write2Ext; +asm +{ PROCEDURE _Write2Ext( VAR t: Text; val: Extended; width, prec: Longint); + ->EAX Pointer to file record + [ESP+4] Extended value + EDX Field width + ECX precision (<0: scientific, >= 0: fixed point) } + + FLD tbyte ptr [ESP+4] { load value } + SUB ESP,256 { VAR s: String; } + + PUSH EAX + PUSH EDX + +{ Str( val, width, prec, s ); } + + SUB ESP,12 + FSTP tbyte ptr [ESP] { pass value } + MOV EAX,EDX { pass field width } + MOV EDX,ECX { pass precision } + LEA ECX,[ESP+8+12] { pass destination string } + CALL _Str2Ext + +{ Write( t, s, width ); } + + POP ECX { pass width } + POP EAX { pass text } + MOV EDX,ESP { pass string } + CALL _WriteString + + ADD ESP,256 + RET 12 +end; + +procedure _Write1Ext; +asm +{ PROCEDURE _Write1Ext( VAR t: Text; val: Extended; width: Longint); + -> EAX Pointer to file record + [ESP+4] Extended value + EDX Field width } + + OR ECX,-1 + JMP _Write2Ext +end; + +procedure _Write0Ext; +asm +{ PROCEDURE _Write0Ext( VAR t: Text; val: Extended); + ->EAX Pointer to file record + [ESP+4] Extended value } + + MOV EDX,23 { field width } + OR ECX,-1 + JMP _Write2Ext +end; + +function _WriteLn(var t: TTextRec): Pointer; +var + Buf: array [0..1] of Char; +begin + if (t.flags and tfCRLF) <> 0 then + begin + Buf[0] := #13; + Buf[1] := #10; + Result := _WriteBytes(t, Buf, 2); + end + else + begin + Buf[0] := #10; + Result := _WriteBytes(t, Buf, 1); + end; + _Flush(t); +end; + +procedure __CToPasStr(Dest: PShortString; const Source: PChar); +begin + __CLenToPasStr(Dest, Source, 255); +end; + +procedure __CLenToPasStr(Dest: PShortString; const Source: PChar; MaxLen: Integer); +{$IFDEF PUREPASCAL} +var + I: Integer; +begin + I := 0; + if MaxLen > 255 then MaxLen := 255; + while (Source[I] <> #0) and (I <= MaxLen) do + begin + Dest^[I+1] := Source[I]; + Inc(I); + end; + if I > 0 then Dec(I); + Byte(Dest^[0]) := I; +end; +{$ELSE} +asm +{ ->EAX Pointer to destination } +{ EDX Pointer to source } +{ ECX cnt } + + PUSH EBX + PUSH EAX { save destination } + + CMP ECX,255 + JBE @@loop + MOV ECX,255 +@@loop: + MOV BL,[EDX] { ch = *src++; } + INC EDX + TEST BL,BL { if (ch == 0) break } + JE @@endLoop + INC EAX { *++dest = ch; } + MOV [EAX],BL + DEC ECX { while (--cnt != 0) } + JNZ @@loop + +@@endLoop: + POP EDX + SUB EAX,EDX + MOV [EDX],AL + POP EBX +end; +{$ENDIF} + +procedure __ArrayToPasStr(Dest: PShortString; const Source: PChar; Len: Integer); +begin + if Len > 255 then Len := 255; + Byte(Dest^[0]) := Len; + Move(Source^, Dest^[1], Len); +end; + +procedure __PasToCStr(const Source: PShortString; const Dest: PChar); +begin + Move(Source^[1], Dest^, Byte(Source^[0])); + Dest[Byte(Source^[0])] := #0; +end; + +procedure _SetElem; +asm + { PROCEDURE _SetElem( VAR d: SET; elem, size: Byte); } + { EAX = dest address } + { DL = element number } + { CL = size of set } + + PUSH EBX + PUSH EDI + + MOV EDI,EAX + + XOR EBX,EBX { zero extend set size into ebx } + MOV BL,CL + MOV ECX,EBX { and use it for the fill } + + XOR EAX,EAX { for zero fill } + REP STOSB + + SUB EDI,EBX { point edi at beginning of set again } + + INC EAX { eax is still zero - make it 1 } + MOV CL,DL + ROL AL,CL { generate a mask } + SHR ECX,3 { generate the index } + CMP ECX,EBX { if index >= siz then exit } + JAE @@exit + OR [EDI+ECX],AL{ set bit } + +@@exit: + POP EDI + POP EBX +end; + +procedure _SetRange; +asm +{ PROCEDURE _SetRange( lo, hi, size: Byte; VAR d: SET ); } +{ ->AL low limit of range } +{ DL high limit of range } +{ ECX Pointer to set } +{ AH size of set } + + PUSH EBX + PUSH ESI + PUSH EDI + + XOR EBX,EBX { EBX = set size } + MOV BL,AH + MOVZX ESI,AL { ESI = low zero extended } + MOVZX EDX,DL { EDX = high zero extended } + MOV EDI,ECX + +{ clear the set } + + MOV ECX,EBX + XOR EAX,EAX + REP STOSB + +{ prepare for setting the bits } + + SUB EDI,EBX { point EDI at start of set } + SHL EBX,3 { EBX = highest bit in set + 1 } + CMP EDX,EBX + JB @@inrange + LEA EDX,[EBX-1] { ECX = highest bit in set } + +@@inrange: + CMP ESI,EDX { if lo > hi then exit; } + JA @@exit + + DEC EAX { loMask = 0xff << (lo & 7) } + MOV ECX,ESI + AND CL,07H + SHL AL,CL + + SHR ESI,3 { loIndex = lo >> 3; } + + MOV CL,DL { hiMask = 0xff >> (7 - (hi & 7)); } + NOT CL + AND CL,07 + SHR AH,CL + + SHR EDX,3 { hiIndex = hi >> 3; } + + ADD EDI,ESI { point EDI to set[loIndex] } + MOV ECX,EDX + SUB ECX,ESI { if ((inxDiff = (hiIndex - loIndex)) == 0) } + JNE @@else + + AND AL,AH { set[loIndex] = hiMask & loMask; } + MOV [EDI],AL + JMP @@exit + +@@else: + STOSB { set[loIndex++] = loMask; } + DEC ECX + MOV AL,0FFH { while (loIndex < hiIndex) } + REP STOSB { set[loIndex++] = 0xff; } + MOV [EDI],AH { set[hiIndex] = hiMask; } + +@@exit: + POP EDI + POP ESI + POP EBX +end; + +procedure _SetEq; +asm +{ FUNCTION _SetEq( CONST l, r: Set; size: Byte): ConditionCode; } +{ EAX = left operand } +{ EDX = right operand } +{ CL = size of set } + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + AND ECX,0FFH + REP CMPSB + + POP EDI + POP ESI +end; + +procedure _SetLe; +asm +{ FUNCTION _SetLe( CONST l, r: Set; size: Byte): ConditionCode; } +{ EAX = left operand } +{ EDX = right operand } +{ CL = size of set (>0 && <= 32) } + +@@loop: + MOV CH,[EDX] + NOT CH + AND CH,[EAX] + JNE @@exit + INC EDX + INC EAX + DEC CL + JNZ @@loop +@@exit: +end; + +procedure _SetIntersect; +asm +{ PROCEDURE _SetIntersect( VAR dest: Set; CONST src: Set; size: Byte);} +{ EAX = destination operand } +{ EDX = source operand } +{ CL = size of set (0 < size <= 32) } + +@@loop: + MOV CH,[EDX] + INC EDX + AND [EAX],CH + INC EAX + DEC CL + JNZ @@loop +end; + +procedure _SetIntersect3; +asm +{ PROCEDURE _SetIntersect3( VAR dest: Set; CONST src: Set; size: Longint; src2: Set);} +{ EAX = destination operand } +{ EDX = source operand } +{ ECX = size of set (0 < size <= 32) } +{ [ESP+4] = 2nd source operand } + + PUSH EBX + PUSH ESI + MOV ESI,[ESP+8+4] +@@loop: + MOV BL,[EDX+ECX-1] + AND BL,[ESI+ECX-1] + MOV [EAX+ECX-1],BL + DEC ECX + JNZ @@loop + + POP ESI + POP EBX +end; + +procedure _SetUnion; +asm +{ PROCEDURE _SetUnion( VAR dest: Set; CONST src: Set; size: Byte); } +{ EAX = destination operand } +{ EDX = source operand } +{ CL = size of set (0 < size <= 32) } + +@@loop: + MOV CH,[EDX] + INC EDX + OR [EAX],CH + INC EAX + DEC CL + JNZ @@loop +end; + +procedure _SetUnion3; +asm +{ PROCEDURE _SetUnion3( VAR dest: Set; CONST src: Set; size: Longint; src2: Set);} +{ EAX = destination operand } +{ EDX = source operand } +{ ECX = size of set (0 < size <= 32) } +{ [ESP+4] = 2nd source operand } + + PUSH EBX + PUSH ESI + MOV ESI,[ESP+8+4] +@@loop: + MOV BL,[EDX+ECX-1] + OR BL,[ESI+ECX-1] + MOV [EAX+ECX-1],BL + DEC ECX + JNZ @@loop + + POP ESI + POP EBX +end; + +procedure _SetSub; +asm +{ PROCEDURE _SetSub( VAR dest: Set; CONST src: Set; size: Byte); } +{ EAX = destination operand } +{ EDX = source operand } +{ CL = size of set (0 < size <= 32) } + +@@loop: + MOV CH,[EDX] + NOT CH + INC EDX + AND [EAX],CH + INC EAX + DEC CL + JNZ @@loop +end; + +procedure _SetSub3; +asm +{ PROCEDURE _SetSub3( VAR dest: Set; CONST src: Set; size: Longint; src2: Set);} +{ EAX = destination operand } +{ EDX = source operand } +{ ECX = size of set (0 < size <= 32) } +{ [ESP+4] = 2nd source operand } + + PUSH EBX + PUSH ESI + MOV ESI,[ESP+8+4] +@@loop: + MOV BL,[ESI+ECX-1] + NOT BL + AND BL,[EDX+ECX-1] + MOV [EAX+ECX-1],BL + DEC ECX + JNZ @@loop + + POP ESI + POP EBX +end; + +procedure _SetExpand; +asm +{ PROCEDURE _SetExpand( CONST src: Set; VAR dest: Set; lo, hi: Byte); } +{ ->EAX Pointer to source (packed set) } +{ EDX Pointer to destination (expanded set) } +{ CH high byte of source } +{ CL low byte of source } + +{ algorithm: } +{ clear low bytes } +{ copy high-low+1 bytes } +{ clear 31-high bytes } + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + MOV EDX,ECX { save low, high in dl, dh } + XOR ECX,ECX + XOR EAX,EAX + + MOV CL,DL { clear low bytes } + REP STOSB + + MOV CL,DH { copy high - low bytes } + SUB CL,DL + REP MOVSB + + MOV CL,32 { copy 32 - high bytes } + SUB CL,DH + REP STOSB + + POP EDI + POP ESI +end; + +procedure _EmitDigits; +const + tenE17: Double = 1e17; + tenE18: Double = 1e18; +asm +// -> FST(0) Value, 0 <= value < 10.0 +// EAX Count of digits to generate +// EDX Pointer to digit buffer + + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX +{$ELSE} + XOR EBX,EBX +{$ENDIF} + PUSH EDI + MOV EDI,EDX + MOV ECX,EAX + + SUB ESP,10 // VAR bcdBuf: array [0..9] of Byte + MOV byte ptr [EDI],'0' // digBuf[0] := '0'// + FMUL qword ptr [EBX] + offset tenE17 // val := Round(val*1e17); + FRNDINT + + FCOM qword ptr [EBX] + offset tenE18 // if val >= 1e18 then + FSTSW AX + SAHF + JB @@1 + + FSUB qword ptr [EBX] + offset tenE18 // val := val - 1e18; + MOV byte ptr [EDI],'1' // digBuf[0] := '1'; +@@1: + FBSTP tbyte ptr [ESP] // store packed bcd digits in bcdBuf + + MOV EDX,8 + INC EDI + +@@2: + WAIT + MOV AL,[ESP+EDX] // unpack 18 bcd digits in 9 bytes + MOV AH,AL // into 9 words = 18 bytes + SHR AL,4 + AND AH,0FH + ADD AX,'00' + STOSW + DEC EDX + JNS @@2 + + SUB ECX,18 // we need at least digCnt digits + JL @@3 // we have generated 18 + + MOV AL,'0' // if this is not enough, append zeroes + REP STOSB + JMP @@4 // in this case, we don't need to round + +@@3: + ADD EDI,ECX // point EDI to the round digit + CMP byte ptr [EDI],'5' + JL @@4 +@@5: + DEC EDI + INC byte ptr [EDI] + CMP byte ptr [EDI],'9' + JLE @@4 + MOV byte ptr [EDI],'0' + JMP @@5 + +@@4: + ADD ESP,10 + POP EDI + POP EBX +end; + +procedure _ScaleExt; +asm +// -> FST(0) Value +// <- EAX exponent (base 10) +// FST(0) Value / 10**eax +// PIC safe - uses EBX, but only call is to _POW10, which fixes up EBX itself + + PUSH EBX + SUB ESP,12 + + XOR EBX,EBX + +@@normLoop: // loop necessary for denormals + + FLD ST(0) + FSTP tbyte ptr [ESP] + MOV AX,[ESP+8] + TEST AX,AX + JE @@testZero +@@cont: + SUB AX,3FFFH + MOV DX,4D10H // log10(2) * 2**16 + IMUL DX + MOVSX EAX,DX // exp10 = exp2 * log10(2) + NEG EAX + JE @@exit + SUB EBX,EAX + CALL _Pow10 + JMP @@normLoop + +@@testZero: + CMP dword ptr [ESP+4],0 + JNE @@cont + CMP dword ptr [ESP+0],0 + JNE @@cont + +@@exit: + ADD ESP,12 + MOV EAX,EBX + POP EBX +end; + +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 ); +const + MAXDIGS = 256; +asm +// -> [ESP+4] Extended value +// EAX Width +// EDX Precision +// ECX Pointer to string + + FLD tbyte ptr [ESP+4] + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV ESI,EDX + PUSH ECX // save string pointer + SUB ESP,MAXDIGS // VAR digBuf: array [0..MAXDIGS-1] of Char + +// limit width to 255 + + CMP EBX,255 // if width > 255 then width := 255; + JLE @@1 + MOV EBX,255 +@@1: + +// save sign bit in bit 0 of EDI, take absolute value of val, check for +// Nan and infinity. + + FLD ST(0) + FSTP tbyte ptr [ESP] + XOR EAX,EAX + MOV AX,word ptr [ESP+8] + MOV EDI,EAX + SHR EDI,15 + AND AX,7FFFH + CMP AX,7FFFH + JE @@nanInf + FABS + +// if precision < 0 then do scientific else do fixed; + + TEST ESI,ESI + JGE @@fixed + +// the following call finds a decimal exponent and a reduced +// mantissa such that val = mant * 10**exp + + CALL _ScaleExt // val is FST(0), exp is EAX + +// for scientific notation, we have width - 8 significant digits +// however, we can not have less than 2 or more than 18 digits. + +@@scientific: + + MOV ESI,EBX // digCnt := width - 8; + SUB ESI,8 + CMP ESI,2 // if digCnt < 2 then digCnt := 2 + JGE @@2 + MOV ESI,2 + JMP @@3 +@@2: + CMP ESI,18 // else if digCnt > 18 then digCnt := 18; + JLE @@3 + MOV ESI,18 +@@3: + +// _EmitDigits( val, digCnt, digBuf ) + + MOV EDX,ESP // pass digBuf + PUSH EAX // save exponent + MOV EAX,ESI // pass digCnt + CALL _EmitDigits // convert val to ASCII + + MOV EDX,EDI // save sign in EDX + MOV EDI,[ESP+MAXDIGS+4] // load result string pointer + + MOV [EDI],BL // length of result string := width + INC EDI + + MOV AL,' ' // prepare for leading blanks and sign + + MOV ECX,EBX // blankCnt := width - digCnt - 8 + SUB ECX,ESI + SUB ECX,8 + JLE @@4 + + REP STOSB // emit blankCnt blanks +@@4: + SUB [EDI-1],CL // if blankCnt < 0, adjust length + + TEST DL,DL // emit the sign (' ' or '-') + JE @@5 + MOV AL,'-' +@@5: + STOSB + + POP EAX + MOV ECX,ESI // emit digCnt digits + MOV ESI,ESP // point ESI to digBuf + + CMP byte ptr [ESI],'0' + JE @@5a // if rounding overflowed, adjust exponent and ESI + INC EAX + DEC ESI +@@5a: + INC ESI + + MOVSB // emit one digit + MOV byte ptr [EDI],'.' // emit dot + INC EDI // adjust dest pointer + DEC ECX // adjust count + + REP MOVSB + + MOV byte ptr [EDI],'E' + + MOV CL,'+' // emit sign of exponent ('+' or '-') + TEST EAX,EAX + JGE @@6 + MOV CL,'-' + NEG EAX +@@6: + MOV [EDI+1],CL + + XOR EDX,EDX // emit exponent + MOV CX,10 + DIV CX + ADD DL,'0' + MOV [EDI+5],DL + + XOR EDX,EDX + DIV CX + ADD DL,'0' + MOV [EDI+4],DL + + XOR EDX,EDX + DIV CX + ADD DL,'0' + MOV [EDI+3],DL + + ADD AL,'0' + MOV [EDI+2],AL + + JMP @@exit + +@@fixed: + +// FST(0) = value >= 0.0 +// EBX = width +// ESI = precision +// EDI = sign + + CMP ESI,MAXDIGS-40 // else if precision > MAXDIGS-40 then precision := MAXDIGS-40; + JLE @@6a + MOV ESI,MAXDIGS-40 +@@6a: +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + FCOM qword ptr [EAX] + offset Ten + POP EAX +{$ELSE} + FCOM qword ptr ten +{$ENDIF} + FSTSW AX + SAHF + MOV EAX,0 + JB @@7 + + CALL _ScaleExt // val is FST(0), exp is EAX + + CMP EAX,35 // if val is too large, use scientific + JG @@scientific + +@@7: +// FST(0) = scaled value, 0.0 <= value < 10.0 +// EAX = exponent, 0 <= exponent + +// intDigCnt := exponent + 1; + + INC EAX + +// _EmitDigits( value, intDigCnt + precision, digBuf ); + + MOV EDX,ESP + PUSH EAX + ADD EAX,ESI + CALL _EmitDigits + POP EAX + +// Now we need to check whether rounding to the right number of +// digits overflowed, and if so, adjust things accordingly + + MOV EDX,ESI // put precision in EDX + MOV ESI,ESP // point EDI to digBuf + CMP byte ptr [ESI],'0' + JE @@8 + INC EAX + DEC ESI +@@8: + INC ESI + + MOV ECX,EAX // numWidth := sign + intDigCnt; + ADD ECX,EDI + + TEST EDX,EDX // if precision > 0 then + JE @@9 + INC ECX // numWidth := numWidth + 1 + precision + ADD ECX,EDX + + CMP EBX,ECX // if width <= numWidth + JG @@9 + MOV EBX,ECX // width := numWidth +@@9: + PUSH EAX + PUSH EDI + + MOV EDI,[ESP+MAXDIGS+2*4] // point EDI to dest string + + MOV [EDI],BL // store final length in dest string + INC EDI + + SUB EBX,ECX // width := width - numWidth + MOV ECX,EBX + JLE @@10 + + MOV AL,' ' // emit width blanks + REP STOSB +@@10: + SUB [EDI-1],CL // if blankCnt < 0, adjust length + POP EAX + POP ECX + + TEST EAX,EAX + JE @@11 + + MOV byte ptr [EDI],'-' + INC EDI + +@@11: + REP MOVSB // copy intDigCnt digits + + TEST EDX,EDX // if precision > 0 then + JE @@12 + + MOV byte ptr [EDI],'.' // emit '.' + INC EDI + MOV ECX,EDX // emit precision digits + REP MOVSB + +@@12: + +@@exit: + ADD ESP,MAXDIGS + POP ECX + POP EDI + POP ESI + POP EBX + RET 12 + +@@nanInf: +// here: EBX = width, ECX = string pointer, EDI = sign, [ESP] = value + +{$IFDEF PIC} + CALL GetGOT +{$ELSE} + XOR EAX,EAX +{$ENDIF} + FSTP ST(0) + CMP dword ptr [ESP+4],80000000H + LEA ESI,[EAX] + offset nanStr + JNE @@13 + DEC EDI + LEA ESI,[EAX] + offset plusInfStr + JNZ @@13 + LEA ESI,[EAX] + offset minInfStr +@@13: + MOV EDI,ECX + MOV ECX,EBX + MOV [EDI],CL + INC EDI + SUB CL,[ESI] + JBE @@14 + MOV AL,' ' + REP STOSB +@@14: + SUB [EDI-1],CL + MOV CL,[ESI] + INC ESI + REP MOVSB + + JMP @@exit +end; + +procedure _Str0Ext; +asm +// -> [ESP+4] Extended value +// EAX Pointer to string + + MOV ECX,EAX // pass string + MOV EAX,23 // pass default field width + OR EDX,-1 // pass precision -1 + JMP _Str2Ext +end; + +procedure _Str1Ext;//( val: Extended; width: Longint; var s: String ); +asm +// -> [ESP+4] Extended value +// EAX Field width +// EDX Pointer to string + + MOV ECX,EDX + OR EDX,-1 // pass precision -1 + JMP _Str2Ext +end; + +//function _ValExt( s: AnsiString; VAR code: Integer ) : Extended; +procedure _ValExt; +asm +// -> EAX Pointer to string +// EDX Pointer to code result +// <- FST(0) Result + + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX +{$ELSE} + XOR EBX,EBX +{$ENDIF} + PUSH ESI + PUSH EDI + + PUSH EBX // SaveGOT = ESP+8 + MOV ESI,EAX + PUSH EAX // save for the error case + + FLDZ + XOR EAX,EAX + XOR EBX,EBX + XOR EDI,EDI + + PUSH EBX // temp to get digs to fpu + + TEST ESI,ESI + JE @@empty + +@@blankLoop: + MOV BL,[ESI] + INC ESI + CMP BL,' ' + JE @@blankLoop + +@@endBlanks: + MOV CH,0 + CMP BL,'-' + JE @@minus + CMP BL,'+' + JE @@plus + JMP @@firstDigit + +@@minus: + INC CH +@@plus: + MOV BL,[ESI] + INC ESI + +@@firstDigit: + TEST BL,BL + JE @@error + + MOV EDI,[ESP+8] // SaveGOT + +@@digLoop: + SUB BL,'0' + CMP BL,9 + JA @@dotExp + FMUL qword ptr [EDI] + offset Ten + MOV dword ptr [ESP],EBX + FIADD dword ptr [ESP] + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JNE @@digLoop + JMP @@prefinish + +@@dotExp: + CMP BL,'.' - '0' + JNE @@exp + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JE @@prefinish + +// EDI = SaveGot +@@fracDigLoop: + SUB BL,'0' + CMP BL,9 + JA @@exp + FMUL qword ptr [EDI] + offset Ten + MOV dword ptr [ESP],EBX + FIADD dword ptr [ESP] + DEC EAX + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JNE @@fracDigLoop + +@@prefinish: + XOR EDI,EDI + JMP @@finish + +@@exp: + CMP BL,'E' - '0' + JE @@foundExp + CMP BL,'e' - '0' + JNE @@error +@@foundExp: + MOV BL,[ESI] + INC ESI + MOV AH,0 + CMP BL,'-' + JE @@minusExp + CMP BL,'+' + JE @@plusExp + JMP @@firstExpDigit +@@minusExp: + INC AH +@@plusExp: + MOV BL,[ESI] + INC ESI +@@firstExpDigit: + SUB BL,'0' + CMP BL,9 + JA @@error + MOV EDI,EBX + MOV BL,[ESI] + INC ESI + TEST BL,BL + JZ @@endExp +@@expDigLoop: + SUB BL,'0' + CMP BL,9 + JA @@error + LEA EDI,[EDI+EDI*4] + ADD EDI,EDI + ADD EDI,EBX + MOV BL,[ESI] + INC ESI + TEST BL,BL + JNZ @@expDigLoop +@@endExp: + DEC AH + JNZ @@expPositive + NEG EDI +@@expPositive: + MOVSX EAX,AL + +@@finish: + ADD EAX,EDI + PUSH EDX + PUSH ECX + CALL _Pow10 + POP ECX + POP EDX + + DEC CH + JE @@negate + +@@successExit: + + ADD ESP,12 // pop temp and saved copy of string pointer + + XOR ESI,ESI // signal no error to caller + +@@exit: + MOV [EDX],ESI + + POP EDI + POP ESI + POP EBX + RET + +@@negate: + FCHS + JMP @@successExit + +@@empty: + INC ESI + +@@error: + POP EAX + POP EBX + SUB ESI,EBX + ADD ESP,4 + JMP @@exit +end; + +procedure FPower10; +asm + JMP _Pow10 +end; + +//function _Pow10(val: Extended; Power: Integer): Extended; +procedure _Pow10; +asm +// -> FST(0) val +// -> EAX Power +// <- FST(0) val * 10**Power + +// This routine generates 10**power with no more than two +// floating point multiplications. Up to 10**31, no multiplications +// are needed. + + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX +{$ELSE} + XOR EBX,EBX +{$ENDIF} + TEST EAX,EAX + JL @@neg + JE @@exit + CMP EAX,5120 + JGE @@inf + MOV EDX,EAX + AND EDX,01FH + LEA EDX,[EDX+EDX*4] + FLD tbyte ptr @@tab0[EBX+EDX*2] + + FMULP + + SHR EAX,5 + JE @@exit + + MOV EDX,EAX + AND EDX,0FH + JE @@skip2ndMul + LEA EDX,[EDX+EDX*4] + FLD tbyte ptr @@tab1-10[EBX+EDX*2] + FMULP + +@@skip2ndMul: + + SHR EAX,4 + JE @@exit + LEA EAX,[EAX+EAX*4] + FLD tbyte ptr @@tab2-10[EBX+EAX*2] + FMULP + JMP @@exit + +@@neg: + NEG EAX + CMP EAX,5120 + JGE @@zero + MOV EDX,EAX + AND EDX,01FH + LEA EDX,[EDX+EDX*4] + FLD tbyte ptr @@tab0[EBX+EDX*2] + FDIVP + + SHR EAX,5 + JE @@exit + + MOV EDX,EAX + AND EDX,0FH + JE @@skip2ndDiv + LEA EDX,[EDX+EDX*4] + FLD tbyte ptr @@tab1-10[EBX+EDX*2] + FDIVP + +@@skip2ndDiv: + + SHR EAX,4 + JE @@exit + LEA EAX,[EAX+EAX*4] + FLD tbyte ptr @@tab2-10[EBX+EAX*2] + FDIVP + + JMP @@exit + +@@inf: + FSTP ST(0) + FLD tbyte ptr @@infval[EBX] + JMP @@exit + +@@zero: + FSTP ST(0) + FLDZ + +@@exit: + POP EBX + RET + +@@infval: DW $0000,$0000,$0000,$8000,$7FFF +@@tab0: DW $0000,$0000,$0000,$8000,$3FFF // 10**0 + DW $0000,$0000,$0000,$A000,$4002 // 10**1 + DW $0000,$0000,$0000,$C800,$4005 // 10**2 + DW $0000,$0000,$0000,$FA00,$4008 // 10**3 + DW $0000,$0000,$0000,$9C40,$400C // 10**4 + DW $0000,$0000,$0000,$C350,$400F // 10**5 + DW $0000,$0000,$0000,$F424,$4012 // 10**6 + DW $0000,$0000,$8000,$9896,$4016 // 10**7 + DW $0000,$0000,$2000,$BEBC,$4019 // 10**8 + DW $0000,$0000,$2800,$EE6B,$401C // 10**9 + DW $0000,$0000,$F900,$9502,$4020 // 10**10 + DW $0000,$0000,$B740,$BA43,$4023 // 10**11 + DW $0000,$0000,$A510,$E8D4,$4026 // 10**12 + DW $0000,$0000,$E72A,$9184,$402A // 10**13 + DW $0000,$8000,$20F4,$B5E6,$402D // 10**14 + DW $0000,$A000,$A931,$E35F,$4030 // 10**15 + DW $0000,$0400,$C9BF,$8E1B,$4034 // 10**16 + DW $0000,$C500,$BC2E,$B1A2,$4037 // 10**17 + DW $0000,$7640,$6B3A,$DE0B,$403A // 10**18 + DW $0000,$89E8,$2304,$8AC7,$403E // 10**19 + DW $0000,$AC62,$EBC5,$AD78,$4041 // 10**20 + DW $8000,$177A,$26B7,$D8D7,$4044 // 10**21 + DW $9000,$6EAC,$7832,$8786,$4048 // 10**22 + DW $B400,$0A57,$163F,$A968,$404B // 10**23 + DW $A100,$CCED,$1BCE,$D3C2,$404E // 10**24 + DW $84A0,$4014,$5161,$8459,$4052 // 10**25 + DW $A5C8,$9019,$A5B9,$A56F,$4055 // 10**26 + DW $0F3A,$F420,$8F27,$CECB,$4058 // 10**27 + DW $0984,$F894,$3978,$813F,$405C // 10**28 + DW $0BE5,$36B9,$07D7,$A18F,$405F // 10**29 + DW $4EDF,$0467,$C9CD,$C9F2,$4062 // 10**30 + DW $2296,$4581,$7C40,$FC6F,$4065 // 10**31 + +@@tab1: DW $B59E,$2B70,$ADA8,$9DC5,$4069 // 10**32 + DW $A6D5,$FFCF,$1F49,$C278,$40D3 // 10**64 + DW $14A3,$C59B,$AB16,$EFB3,$413D // 10**96 + DW $8CE0,$80E9,$47C9,$93BA,$41A8 // 10**128 + DW $17AA,$7FE6,$A12B,$B616,$4212 // 10**160 + DW $556B,$3927,$F78D,$E070,$427C // 10**192 + DW $C930,$E33C,$96FF,$8A52,$42E7 // 10**224 + DW $DE8E,$9DF9,$EBFB,$AA7E,$4351 // 10**256 + DW $2F8C,$5C6A,$FC19,$D226,$43BB // 10**288 + DW $E376,$F2CC,$2F29,$8184,$4426 // 10**320 + DW $0AD2,$DB90,$2700,$9FA4,$4490 // 10**352 + DW $AA17,$AEF8,$E310,$C4C5,$44FA // 10**384 + DW $9C59,$E9B0,$9C07,$F28A,$4564 // 10**416 + DW $F3D4,$EBF7,$4AE1,$957A,$45CF // 10**448 + DW $A262,$0795,$D8DC,$B83E,$4639 // 10**480 + +@@tab2: DW $91C7,$A60E,$A0AE,$E319,$46A3 // 10**512 + DW $0C17,$8175,$7586,$C976,$4D48 // 10**1024 + DW $A7E4,$3993,$353B,$B2B8,$53ED // 10**1536 + DW $5DE5,$C53D,$3B5D,$9E8B,$5A92 // 10**2048 + DW $F0A6,$20A1,$54C0,$8CA5,$6137 // 10**2560 + DW $5A8B,$D88B,$5D25,$F989,$67DB // 10**3072 + DW $F3F8,$BF27,$C8A2,$DD5D,$6E80 // 10**3584 + DW $979B,$8A20,$5202,$C460,$7525 // 10**4096 + DW $59F0,$6ED5,$1162,$AE35,$7BCA // 10**4608 +end; + +const + RealBias = 129; + ExtBias = $3FFF; + +procedure _Real2Ext;//( val : Real ) : Extended; +asm +// -> EAX Pointer to value +// <- FST(0) Result + +// the REAL data type has the following format: +// 8 bit exponent (bias 129), 39 bit fraction, 1 bit sign + + MOV DH,[EAX+5] // isolate the sign bit + AND DH,80H + MOV DL,[EAX] // fetch exponent + TEST DL,DL // exponent zero means number is zero + JE @@zero + + ADD DX,ExtBias-RealBias // adjust exponent bias + + PUSH EDX // the exponent is at the highest address + + MOV EDX,[EAX+2] // load high fraction part, set hidden bit + OR EDX,80000000H + PUSH EDX // push high fraction part + + MOV DL,[EAX+1] // load remaining low byte of fraction + SHL EDX,24 // clear low 24 bits + PUSH EDX + + FLD tbyte ptr [ESP] // pop result onto chip + ADD ESP,12 + + RET + +@@zero: + FLDZ + RET +end; + +procedure _Ext2Real;//( val : Extended ) : Real; +asm +// -> FST(0) Value +// EAX Pointer to result + + PUSH EBX + + SUB ESP,12 + FSTP tbyte ptr [ESP] + + POP EBX // EBX is low half of fraction + POP EDX // EDX is high half of fraction + POP ECX // CX is exponent and sign + + SHR EBX,24 // set carry to last bit shifted out + ADC BL,0 // if bit was 1, round up + ADC EDX,0 + ADC CX,0 + JO @@overflow + + ADD EDX,EDX // shift fraction 1 bit left + ADD CX,CX // shift sign bit into carry + RCR EDX,1 // attach sign bit to fraction + SHR CX,1 // restore exponent, deleting sign + + SUB CX,ExtBias-RealBias // adjust exponent + JLE @@underflow + TEST CH,CH // CX must be in 1..255 + JG @@overflow + + MOV [EAX],CL + MOV [EAX+1],BL + MOV [EAX+2],EDX + + POP EBX + RET + +@@underflow: + XOR ECX,ECX + MOV [EAX],ECX + MOV [EAX+4],CX + POP EBX + RET + +@@overflow: + POP EBX + MOV AL,8 + JMP Error +end; + +const + ovtInstanceSize = -8; { Offset of instance size in OBJECTs } + ovtVmtPtrOffs = -4; + +procedure _ObjSetup; +asm +{ FUNCTION _ObjSetup( self: ^OBJECT; vmt: ^VMT): ^OBJECT; } +{ ->EAX Pointer to self (possibly nil) } +{ EDX Pointer to vmt (possibly nil) } +{ <-EAX Pointer to self } +{ EDX <> 0: an object was allocated } +{ Z-Flag Set: failure, Cleared: Success } + + CMP EDX,1 { is vmt = 0, indicating a call } + JAE @@skip1 { from a constructor? } + RET { return immediately with Z-flag cleared } + +@@skip1: + PUSH ECX + TEST EAX,EAX { is self already allocated? } + JNE @@noAlloc + MOV EAX,[EDX].ovtInstanceSize + TEST EAX,EAX + JE @@zeroSize + PUSH EDX + CALL _GetMem + POP EDX + TEST EAX,EAX + JZ @@fail + + { Zero fill the memory } + PUSH EDI + MOV ECX,[EDX].ovtInstanceSize + MOV EDI,EAX + PUSH EAX + XOR EAX,EAX + SHR ECX,2 + REP STOSD + MOV ECX,[EDX].ovtInstanceSize + AND ECX,3 + REP STOSB + POP EAX + POP EDI + + MOV ECX,[EDX].ovtVmtPtrOffs + TEST ECX,ECX + JL @@skip + MOV [EAX+ECX],EDX { store vmt in object at this offset } +@@skip: + TEST EAX,EAX { clear zero flag } + POP ECX + RET + +@@fail: + XOR EDX,EDX + POP ECX + RET + +@@zeroSize: + XOR EDX,EDX + CMP EAX,1 { clear zero flag - we were successful (kind of) } + POP ECX + RET + +@@noAlloc: + MOV ECX,[EDX].ovtVmtPtrOffs + TEST ECX,ECX + JL @@exit + MOV [EAX+ECX],EDX { store vmt in object at this offset } +@@exit: + XOR EDX,EDX { clear allocated flag } + TEST EAX,EAX { clear zero flag } + POP ECX +end; + +procedure _ObjCopy; +asm +{ PROCEDURE _ObjCopy( dest, src: ^OBJECT; vmtPtrOff: Longint); } +{ ->EAX Pointer to destination } +{ EDX Pointer to source } +{ ECX Offset of vmt in those objects. } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EDX + MOV EDI,EAX + + LEA EAX,[EDI+ECX] { remember pointer to dest vmt pointer } + MOV EDX,[EAX] { fetch dest vmt pointer } + + MOV EBX,[EDX].ovtInstanceSize + + MOV ECX,EBX { copy size DIV 4 dwords } + SHR ECX,2 + REP MOVSD + + MOV ECX,EBX { copy size MOD 4 bytes } + AND ECX,3 + REP MOVSB + + MOV [EAX],EDX { restore dest vmt } + + POP EDI + POP ESI + POP EBX +end; + +procedure _Fail; +asm +{ FUNCTION _Fail( self: ^OBJECT; allocFlag:Longint): ^OBJECT; } +{ ->EAX Pointer to self (possibly nil) } +{ EDX <> 0: Object must be deallocated } +{ <-EAX Nil } + + TEST EDX,EDX + JE @@exit { if no object was allocated, return } + CALL _FreeMem +@@exit: + XOR EAX,EAX +end; + +{$IFDEF MSWINDOWS} +function GetKeyboardType(nTypeFlag: Integer): Integer; stdcall; + external user name 'GetKeyboardType'; + +function _isNECWindows: Boolean; +var + KbSubType: Integer; +begin + Result := False; + if GetKeyboardType(0) = $7 then + begin + KbSubType := GetKeyboardType(1) and $FF00; + if (KbSubType = $0D00) or (KbSubType = $0400) then + Result := True; + end; +end; + +const + HKEY_LOCAL_MACHINE = $80000002; + +// workaround a Japanese Win95 bug +procedure _FpuMaskInit; +const + KEY_QUERY_VALUE = $00000001; + REG_DWORD = 4; + FPUMASKKEY = 'SOFTWARE\Borland\Delphi\RTL'; + FPUMASKNAME = 'FPUMaskValue'; +var + phkResult: LongWord; + lpData, DataSize: Longint; +begin + lpData := Default8087CW; + + if RegOpenKeyEx(HKEY_LOCAL_MACHINE, FPUMASKKEY, 0, KEY_QUERY_VALUE, phkResult) = 0 then + try + DataSize := Sizeof(lpData); + RegQueryValueEx(phkResult, FPUMASKNAME, nil, nil, @lpData, @DataSize); + finally + RegCloseKey(phkResult); + end; + Default8087CW := (Default8087CW and $ffc0) or (lpData and $3f); +end; +{$ENDIF} + +procedure _FpuInit; +asm + FNINIT + FWAIT +{$IFDEF PIC} + CALL GetGOT + MOV EAX,[EAX].OFFSET Default8087CW + FLDCW [EAX] +{$ELSE} + FLDCW Default8087CW +{$ENDIF} +end; + +{X+}procedure FpuInit; +{X+}//const cwDefault: Word = $1332 { $133F}; +{X+}asm +{X+} JMP _FpuInit +{X+}end; +{X+} +{X+}procedure FpuInitConsiderNECWindows; +{X+}begin +{X+} if _isNECWindows then _FpuMaskInit; +{X+} FpuInit(); +{X+}end; + + +procedure _BoundErr; +asm + MOV AL,reRangeError + JMP Error +end; + +procedure _IntOver; +asm + MOV AL,reIntOverflow + JMP Error +end; + +function TObject.ClassType: TClass; +begin + Pointer(Result) := PPointer(Self)^; +end; + +class function TObject.ClassName: ShortString; +{$IFDEF PUREPASCAL} +begin + Result := PShortString(PPointer(Integer(Self) + vmtClassName)^)^; +end; +{$ELSE} +asm + { -> EAX VMT } + { EDX Pointer to result string } + PUSH ESI + PUSH EDI + MOV EDI,EDX + MOV ESI,[EAX].vmtClassName + XOR ECX,ECX + MOV CL,[ESI] + INC ECX + REP MOVSB + POP EDI + POP ESI +end; +{$ENDIF} + +class function TObject.ClassNameIs(const Name: string): Boolean; +{$IFDEF PUREPASCAL} +var + Temp: ShortString; + I: Byte; +begin + Result := False; + Temp := ClassName; + for I := 0 to Byte(Temp[0]) do + if Temp[I] <> Name[I] then Exit; + Result := True; +end; +{$ELSE} +asm + PUSH EBX + XOR EBX,EBX + OR EDX,EDX + JE @@exit + MOV EAX,[EAX].vmtClassName + XOR ECX,ECX + MOV CL,[EAX] + CMP ECX,[EDX-4] + JNE @@exit + DEC EDX +@@loop: + MOV BH,[EAX+ECX] + XOR BH,[EDX+ECX] + AND BH,0DFH + JNE @@exit + DEC ECX + JNE @@loop + INC EBX +@@exit: + MOV AL,BL + POP EBX +end; +{$ENDIF} + +class function TObject.ClassParent: TClass; +{$IFDEF PUREPASCAL} +begin + Pointer(Result) := PPointer(Integer(Self) + vmtParent)^; + if Result <> nil then + Pointer(Result) := PPointer(Result)^; +end; +{$ELSE} +asm + MOV EAX,[EAX].vmtParent + TEST EAX,EAX + JE @@exit + MOV EAX,[EAX] +@@exit: +end; +{$ENDIF} + +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; +begin +end; + +destructor TObject.Destroy; +begin +end; + +procedure TObject.Free; +begin + if Self <> nil then + Destroy; +end; + +class function TObject.InitInstance(Instance: Pointer): TObject; +{$IFDEF PUREPASCAL} +var + IntfTable: PInterfaceTable; + ClassPtr: TClass; + I: Integer; +begin + FillChar(Instance^, InstanceSize, 0); + PInteger(Instance)^ := Integer(Self); + ClassPtr := Self; + while ClassPtr <> nil do + begin + IntfTable := ClassPtr.GetInterfaceTable; + if IntfTable <> nil then + for I := 0 to IntfTable.EntryCount-1 do + with IntfTable.Entries[I] do + begin + if VTable <> nil then + PInteger(@PChar(Instance)[IOffset])^ := Integer(VTable); + end; + ClassPtr := ClassPtr.ClassParent; + end; + Result := Instance; +end; +{$ELSE} +asm + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV EDI,EDX + STOSD + MOV ECX,[EBX].vmtInstanceSize + XOR EAX,EAX + PUSH ECX + SHR ECX,2 + DEC ECX + REP STOSD + POP ECX + AND ECX,3 + REP STOSB + MOV EAX,EDX + MOV EDX,ESP +@@0: MOV ECX,[EBX].vmtIntfTable + TEST ECX,ECX + JE @@1 + PUSH ECX +@@1: MOV EBX,[EBX].vmtParent + TEST EBX,EBX + JE @@2 + MOV EBX,[EBX] + JMP @@0 +@@2: CMP ESP,EDX + JE @@5 +@@3: POP EBX + MOV ECX,[EBX].TInterfaceTable.EntryCount + ADD EBX,4 +@@4: MOV ESI,[EBX].TInterfaceEntry.VTable + TEST ESI,ESI + JE @@4a + MOV EDI,[EBX].TInterfaceEntry.IOffset + MOV [EAX+EDI],ESI +@@4a: ADD EBX,TYPE TInterfaceEntry + DEC ECX + JNE @@4 + CMP ESP,EDX + JNE @@3 +@@5: POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +procedure TObject.CleanupInstance; +{$IFDEF PUREPASCAL} +var + ClassPtr: TClass; + InitTable: Pointer; +begin + ClassPtr := ClassType; + InitTable := PPointer(Integer(ClassPtr) + vmtInitTable)^; + while (ClassPtr <> nil) and (InitTable <> nil) do + begin + _FinalizeRecord(Self, InitTable); + ClassPtr := ClassPtr.ClassParent; + if ClassPtr <> nil then + InitTable := PPointer(Integer(ClassPtr) + vmtInitTable)^; + end; +end; +{$ELSE} +asm + PUSH EBX + PUSH ESI + MOV EBX,EAX + MOV ESI,EAX +@@loop: + MOV ESI,[ESI] + MOV EDX,[ESI].vmtInitTable + MOV ESI,[ESI].vmtParent + TEST EDX,EDX + JE @@skip + CALL _FinalizeRecord + MOV EAX,EBX +@@skip: + TEST ESI,ESI + JNE @@loop + + POP ESI + POP EBX +end; +{$ENDIF} + +function InvokeImplGetter(Self: TObject; ImplGetter: Cardinal): IInterface; +{$IFDEF PUREPASCAL} +var + M: function: IInterface of object; +begin + TMethod(M).Data := Self; + case ImplGetter of + $FF000000..$FFFFFFFF: // Field + Result := IInterface(Pointer(Cardinal(Self) + (ImplGetter and $00FFFFFF))); + $FE000000..$FEFFFFFF: // virtual method + begin + // sign extend vmt slot offset = smallint cast + TMethod(M).Code := PPointer(Integer(Self) + SmallInt(ImplGetter))^; + Result := M; + end; + else // static method + TMethod(M).Code := Pointer(ImplGetter); + Result := M; + end; +end; +{$ELSE} +asm + XCHG EDX,ECX + CMP ECX,$FF000000 + JAE @@isField + CMP ECX,$FE000000 + JB @@isStaticMethod + + { the GetProc is a virtual method } + MOVSX ECX,CX { sign extend slot offs } + ADD ECX,[EAX] { vmt + slotoffs } + JMP dword ptr [ECX] { call vmt[slot] } + +@@isStaticMethod: + JMP ECX + +@@isField: + AND ECX,$00FFFFFF + ADD ECX,EAX + MOV EAX,EDX + MOV EDX,[ECX] + JMP _IntfCopy +end; +{$ENDIF} + +function TObject.GetInterface(const IID: TGUID; out Obj): Boolean; +var + InterfaceEntry: PInterfaceEntry; +begin + Pointer(Obj) := nil; + InterfaceEntry := GetInterfaceEntry(IID); + if InterfaceEntry <> nil then + begin + if InterfaceEntry^.IOffset <> 0 then + begin + Pointer(Obj) := Pointer(Integer(Self) + InterfaceEntry^.IOffset); + if Pointer(Obj) <> nil then IInterface(Obj)._AddRef; + end + else + IInterface(Obj) := InvokeImplGetter(Self, InterfaceEntry^.ImplGetter); + end; + Result := Pointer(Obj) <> nil; +end; + +class function TObject.GetInterfaceEntry(const IID: TGUID): PInterfaceEntry; +{$IFDEF PUREPASCAL} +var + ClassPtr: TClass; + IntfTable: PInterfaceTable; + I: Integer; +begin + ClassPtr := Self; + while ClassPtr <> nil do + begin + IntfTable := ClassPtr.GetInterfaceTable; + if IntfTable <> nil then + for I := 0 to IntfTable.EntryCount-1 do + begin + Result := @IntfTable.Entries[I]; +// if Result^.IID = IID then Exit; + if (Int64(Result^.IID.D1) = Int64(IID.D1)) and + (Int64(Result^.IID.D4) = Int64(IID.D4)) then Exit; + end; + ClassPtr := ClassPtr.ClassParent; + end; + Result := nil; +end; +{$ELSE} +asm + PUSH EBX + PUSH ESI + MOV EBX,EAX +@@1: MOV EAX,[EBX].vmtIntfTable + TEST EAX,EAX + JE @@4 + MOV ECX,[EAX].TInterfaceTable.EntryCount + ADD EAX,4 +@@2: MOV ESI,[EDX].Integer[0] + CMP ESI,[EAX].TInterfaceEntry.IID.Integer[0] + JNE @@3 + MOV ESI,[EDX].Integer[4] + CMP ESI,[EAX].TInterfaceEntry.IID.Integer[4] + JNE @@3 + MOV ESI,[EDX].Integer[8] + CMP ESI,[EAX].TInterfaceEntry.IID.Integer[8] + JNE @@3 + MOV ESI,[EDX].Integer[12] + CMP ESI,[EAX].TInterfaceEntry.IID.Integer[12] + JE @@5 +@@3: ADD EAX,type TInterfaceEntry + DEC ECX + JNE @@2 +@@4: MOV EBX,[EBX].vmtParent + TEST EBX,EBX + JE @@4a + MOV EBX,[EBX] + JMP @@1 +@@4a: XOR EAX,EAX +@@5: POP ESI + POP EBX +end; +{$ENDIF} + +class function TObject.GetInterfaceTable: PInterfaceTable; +begin + Result := PPointer(Integer(Self) + vmtIntfTable)^; +end; + +function _IsClass(Child: TObject; Parent: TClass): Boolean; +begin + Result := (Child <> nil) and Child.InheritsFrom(Parent); +end; + +function _AsClass(Child: TObject; Parent: TClass): TObject; +{$IFDEF PUREPASCAL} +begin + Result := Child; + if not (Child is Parent) then + Error(reInvalidCast); // loses return address +end; +{$ELSE} +asm + { -> EAX left operand (class) } + { EDX VMT of right operand } + { <- EAX if left is derived from right, else runtime error } + TEST EAX,EAX + JE @@exit + MOV ECX,EAX +@@loop: + MOV ECX,[ECX] + CMP ECX,EDX + JE @@exit + MOV ECX,[ECX].vmtParent + TEST ECX,ECX + JNE @@loop + + { do runtime error } + MOV AL,reInvalidCast + JMP Error + +@@exit: +end; +{$ENDIF} + +procedure GetDynaMethod; +{ function GetDynaMethod(vmt: TClass; selector: Smallint) : Pointer; } +asm + { -> EAX vmt of class } + { SI dynamic method index } + { <- ESI pointer to routine } + { ZF = 0 if found } + { trashes: EAX, ECX } + + PUSH EDI + XCHG EAX,ESI + JMP @@haveVMT +@@outerLoop: + MOV ESI,[ESI] +@@haveVMT: + MOV EDI,[ESI].vmtDynamicTable + TEST EDI,EDI + JE @@parent + MOVZX ECX,word ptr [EDI] + PUSH ECX + ADD EDI,2 + REPNE SCASW + JE @@found + POP ECX +@@parent: + MOV ESI,[ESI].vmtParent + TEST ESI,ESI + JNE @@outerLoop + JMP @@exit + +@@found: + POP EAX + ADD EAX,EAX + SUB EAX,ECX { this will always clear the Z-flag ! } + MOV ESI,[EDI+EAX*2-4] + +@@exit: + POP EDI +end; + +procedure _CallDynaInst; +asm + PUSH EAX + PUSH ECX + MOV EAX,[EAX] + CALL GetDynaMethod + POP ECX + POP EAX + JE @@Abstract + JMP ESI +@@Abstract: + POP ECX + JMP _AbstractError +end; + + +procedure _CallDynaClass; +asm + PUSH EAX + PUSH ECX + CALL GetDynaMethod + POP ECX + POP EAX + JE @@Abstract + JMP ESI +@@Abstract: + POP ECX + JMP _AbstractError +end; + + +procedure _FindDynaInst; +asm + PUSH ESI + MOV ESI,EDX + MOV EAX,[EAX] + CALL GetDynaMethod + MOV EAX,ESI + POP ESI + JNE @@exit + POP ECX + JMP _AbstractError +@@exit: +end; + + +procedure _FindDynaClass; +asm + PUSH ESI + MOV ESI,EDX + CALL GetDynaMethod + MOV EAX,ESI + POP ESI + JNE @@exit + POP ECX + JMP _AbstractError +@@exit: +end; + +class function TObject.InheritsFrom(AClass: TClass): Boolean; +{$IFDEF PUREPASCAL} +var + ClassPtr: TClass; +begin + ClassPtr := Self; + while (ClassPtr <> nil) and (ClassPtr <> AClass) do + ClassPtr := PPointer(Integer(ClassPtr) + vmtParent)^; + Result := ClassPtr = AClass; +end; +{$ELSE} +asm + { -> EAX Pointer to our class } + { EDX Pointer to AClass } + { <- AL Boolean result } + JMP @@haveVMT +@@loop: + MOV EAX,[EAX] +@@haveVMT: + CMP EAX,EDX + JE @@success + MOV EAX,[EAX].vmtParent + TEST EAX,EAX + JNE @@loop + JMP @@exit +@@success: + MOV AL,1 +@@exit: +end; +{$ENDIF} + + +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); +begin +end; + + +procedure TObject.AfterConstruction; +begin +end; + +procedure TObject.BeforeDestruction; +begin +end; + +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; +asm + { -> EAX Pointer to class } + { EDX Pointer to name } + PUSH EBX + PUSH ESI + PUSH EDI + XOR ECX,ECX + XOR EDI,EDI + MOV BL,[EDX] + JMP @@haveVMT +@@outer: { upper 16 bits of ECX are 0 ! } + MOV EAX,[EAX] +@@haveVMT: + MOV ESI,[EAX].vmtMethodTable + TEST ESI,ESI + JE @@parent + MOV DI,[ESI] { EDI := method count } + ADD ESI,2 +@@inner: { upper 16 bits of ECX are 0 ! } + MOV CL,[ESI+6] { compare length of strings } + CMP CL,BL + JE @@cmpChar +@@cont: { upper 16 bits of ECX are 0 ! } + MOV CX,[ESI] { fetch length of method desc } + ADD ESI,ECX { point ESI to next method } + DEC EDI + JNZ @@inner +@@parent: + MOV EAX,[EAX].vmtParent { fetch parent vmt } + TEST EAX,EAX + JNE @@outer + JMP @@exit { return NIL } + +@@notEqual: + MOV BL,[EDX] { restore BL to length of name } + JMP @@cont + +@@cmpChar: { upper 16 bits of ECX are 0 ! } + MOV CH,0 { upper 24 bits of ECX are 0 ! } +@@cmpCharLoop: + MOV BL,[ESI+ECX+6] { case insensitive string cmp } + XOR BL,[EDX+ECX+0] { last char is compared first } + AND BL,$DF + JNE @@notEqual + DEC ECX { ECX serves as counter } + JNZ @@cmpCharLoop + + { found it } + MOV EAX,[ESI+2] + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +class function TObject.MethodName(Address: Pointer): ShortString; +asm + { -> EAX Pointer to class } + { EDX Address } + { ECX Pointer to result } + PUSH EBX + PUSH ESI + PUSH EDI + MOV EDI,ECX + XOR EBX,EBX + XOR ECX,ECX + JMP @@haveVMT +@@outer: + MOV EAX,[EAX] +@@haveVMT: + MOV ESI,[EAX].vmtMethodTable { fetch pointer to method table } + TEST ESI,ESI + JE @@parent + MOV CX,[ESI] + ADD ESI,2 +@@inner: + CMP EDX,[ESI+2] + JE @@found + MOV BX,[ESI] + ADD ESI,EBX + DEC ECX + JNZ @@inner +@@parent: + MOV EAX,[EAX].vmtParent + TEST EAX,EAX + JNE @@outer + MOV [EDI],AL + JMP @@exit + +@@found: + ADD ESI,6 + XOR ECX,ECX + MOV CL,[ESI] + INC ECX + REP MOVSB + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +function TObject.FieldAddress(const Name: ShortString): Pointer; +asm + { -> EAX Pointer to instance } + { EDX Pointer to name } + PUSH EBX + PUSH ESI + PUSH EDI + XOR ECX,ECX + XOR EDI,EDI + MOV BL,[EDX] + + PUSH EAX { save instance pointer } + +@@outer: + MOV EAX,[EAX] { fetch class pointer } + MOV ESI,[EAX].vmtFieldTable + TEST ESI,ESI + JE @@parent + MOV DI,[ESI] { fetch count of fields } + ADD ESI,6 +@@inner: + MOV CL,[ESI+6] { compare string lengths } + CMP CL,BL + JE @@cmpChar +@@cont: + LEA ESI,[ESI+ECX+7] { point ESI to next field } + DEC EDI + JNZ @@inner +@@parent: + MOV EAX,[EAX].vmtParent { fetch parent VMT } + TEST EAX,EAX + JNE @@outer + POP EDX { forget instance, return Nil } + JMP @@exit + +@@notEqual: + MOV BL,[EDX] { restore BL to length of name } + MOV CL,[ESI+6] { ECX := length of field name } + JMP @@cont + +@@cmpChar: + MOV BL,[ESI+ECX+6] { case insensitive string cmp } + XOR BL,[EDX+ECX+0] { starting with last char } + AND BL,$DF + JNE @@notEqual + DEC ECX { ECX serves as counter } + JNZ @@cmpChar + + { found it } + MOV EAX,[ESI] { result is field offset plus ... } + POP EDX + ADD EAX,EDX { instance pointer } + +@@exit: + POP EDI + POP ESI + POP EBX +end; + +function _ClassCreate(AClass: TClass; Alloc: Boolean): TObject; +asm + { -> EAX = pointer to VMT } + { <- EAX = pointer to instance } + PUSH EDX + PUSH ECX + PUSH EBX + TEST DL,DL + JL @@noAlloc + CALL DWORD PTR [EAX] + VMTOFFSET TObject.NewInstance +@@noAlloc: +{$IFNDEF PC_MAPPED_EXCEPTIONS} + XOR EDX,EDX + LEA ECX,[ESP+16] + MOV EBX,FS:[EDX] + MOV [ECX].TExcFrame.next,EBX + MOV [ECX].TExcFrame.hEBP,EBP + MOV [ECX].TExcFrame.desc,offset @desc + MOV [ECX].TexcFrame.ConstructedObject,EAX { trick: remember copy to instance } + MOV FS:[EDX],ECX +{$ENDIF} + POP EBX + POP ECX + POP EDX + RET + +{$IFNDEF PC_MAPPED_EXCEPTIONS} +@desc: + JMP _HandleAnyException + + { destroy the object } + + MOV EAX,[ESP+8+9*4] + MOV EAX,[EAX].TExcFrame.ConstructedObject + TEST EAX,EAX + JE @@skip + MOV ECX,[EAX] + MOV DL,$81 + PUSH EAX + CALL DWORD PTR [ECX] + VMTOFFSET TObject.Destroy + POP EAX + CALL _ClassDestroy +@@skip: + { reraise the exception } + CALL _RaiseAgain +{$ENDIF} +end; + +procedure _ClassDestroy(Instance: TObject); +begin + Instance.FreeInstance; +end; + + +function _AfterConstruction(Instance: TObject): TObject; +begin + Instance.AfterConstruction; + Result := Instance; +end; + +function _BeforeDestruction(Instance: TObject; OuterMost: ShortInt): TObject; +// Must preserve DL on return! +{$IFDEF PUREPASCAL} +begin + Result := Instance; + if OuterMost > 0 then Exit; + Instance.BeforeDestruction; +end; +{$ELSE} +asm + { -> EAX = pointer to instance } + { DL = dealloc flag } + + TEST DL,DL + JG @@outerMost + RET +@@outerMost: + PUSH EAX + PUSH EDX + MOV EDX,[EAX] + CALL DWORD PTR [EDX] + VMTOFFSET TObject.BeforeDestruction + POP EDX + POP EAX +end; +{$ENDIF} + +{ + 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. +} + +{$IFDEF LINUX} +const + excRaise = 0; { an exception is being raised by the user (could be a reraise) } + excCatch = 1; { an exception is about to be caught } + excFinally = 2; { a finally block is about to be executed because of an exception } + excUnhandled = 3; { no user exception handler was found (the app will die) } + +procedure _DbgExcNotify( + NotificationKind: Integer; + ExceptionObject: Pointer; + ExceptionName: PShortString; + ExceptionLocation: Pointer; + HandlerAddr: Pointer); cdecl; export; +begin +{$IFDEF DEBUG} + { + This code is just for debugging the exception handling system. The debugger + needs _DbgExcNotify, however to place breakpoints in, so the function itself + cannot be removed. + } + asm + PUSH EAX + PUSH EDX + end; + if Assigned(ExcNotificationProc) then + ExcNotificationProc(NotificationKind, ExceptionObject, ExceptionName, ExceptionLocation, HandlerAddr); + asm + POP EDX + POP EAX + end; +{$ENDIF} +end; + +{ + The following functions are used by the debugger for the evaluator. If you + change them IN ANY WAY, the debugger will cease to function correctly. +} +procedure _DbgEvalMarker; +begin +end; + +procedure _DbgEvalExcept(E: TObject); +begin +end; + +procedure _DbgEvalEnd; +begin +end; + +{ + This function is used by the debugger to provide a soft landing spot + when evaluating a function call that may raise an unhandled exception. + The return address of _DbgEvalMarker is pushed onto the stack so that + the unwinder will transfer control to the except block. +} +procedure _DbgEvalFrame; +begin + try + _DbgEvalMarker; + except on E: TObject do + _DbgEvalExcept(E); + end; + _DbgEvalEnd; +end; + +{ + These export names need to match the names that will be generated into + the .symtab section, so that the debugger can find them if stabs + debug information is being generated. +} +exports + _DbgExcNotify name '@DbgExcNotify', + _DbgEvalFrame name '@DbgEvalFrame', + _DbgEvalMarker name '@DbgEvalMarker', + _DbgEvalExcept name '@DbgEvalExcept', + _DbgEvalEnd name '@DbgEvalEnd'; +{$ENDIF} + +{ tell the debugger that the next raise is a re-raise of the current non-Delphi + exception } +procedure NotifyReRaise; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX location of exception } + PUSH 0 { handler addr } + PUSH EDX { location of exception } + MOV ECX, [EAX] + PUSH [ECX].vmtClassName { exception name } + PUSH EAX { exception object } + PUSH excRaise { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 +{$ELSE} + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH 0 + PUSH 0 + PUSH cContinuable + PUSH cDelphiReRaise + CALL RaiseExceptionProc +@@1: +{$ENDIF} +end; + +{ tell the debugger about the raise of a non-Delphi exception } +{$IFNDEF LINUX} +procedure NotifyNonDelphiException; +asm + CMP BYTE PTR DebugHook,0 + JE @@1 + PUSH EAX + PUSH EAX + PUSH EDX + PUSH ESP + PUSH 2 + PUSH cContinuable + PUSH cNonDelphiException + CALL RaiseExceptionProc + ADD ESP,8 + POP EAX +@@1: +end; +{$ENDIF} + +{ Tell the debugger where the handler for the current exception is located } +procedure NotifyExcept; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX handler addr } + PUSH EAX + MOV EAX, [EAX].TRaisedException.ExceptObject + + PUSH EDX { handler addr } + PUSH 0 { location of exception } + MOV ECX, [EAX] + PUSH [ECX].vmtClassName { exception name } + PUSH EAX { exception object } + PUSH excCatch { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 + + POP EAX +{$ELSE} + PUSH ESP + PUSH 1 + PUSH cContinuable + PUSH cDelphiExcept { our magic exception code } + CALL RaiseExceptionProc + ADD ESP,4 + POP EAX +{$ENDIF} +end; + +procedure NotifyOnExcept; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX handler addr } + PUSH EDX { handler addr } + PUSH 0 { location of exception } + MOV ECX, [EAX] + PUSH [ECX].vmtClassName { exception name } + PUSH EAX { exception object } + PUSH excCatch { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 +{$ELSE} + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH EAX + PUSH [EBX].TExcDescEntry.handler + JMP NotifyExcept +@@1: +{$ENDIF} +end; + +{$IFNDEF LINUX} +procedure NotifyAnyExcept; +asm + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH EAX + PUSH EBX + JMP NotifyExcept +@@1: +end; + +procedure CheckJmp; +asm + TEST ECX,ECX + JE @@3 + MOV EAX,[ECX + 1] + CMP BYTE PTR [ECX],0E9H { near jmp } + JE @@1 + CMP BYTE PTR [ECX],0EBH { short jmp } + JNE @@3 + MOVSX EAX,AL + INC ECX + INC ECX + JMP @@2 +@@1: + ADD ECX,5 +@@2: + ADD ECX,EAX +@@3: +end; +{$ENDIF} { not LINUX } + +{ Notify debugger of a finally during an exception unwind } +procedure NotifyExceptFinally; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX handler addr } + PUSH EDX { handler addr } + PUSH 0 { location of exception } + PUSH 0 { exception name } + PUSH 0 { exception object } + PUSH excFinally { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 +{$ELSE} + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH EAX + PUSH EDX + PUSH ECX + CALL CheckJmp + PUSH ECX + PUSH ESP { pass pointer to arguments } + PUSH 1 { there is 1 argument } + PUSH cContinuable { continuable execution } + PUSH cDelphiFinally { our magic exception code } + CALL RaiseExceptionProc + POP ECX + POP ECX + POP EDX + POP EAX +@@1: +{$ENDIF} +end; + + +{ Tell the debugger that the current exception is handled and cleaned up. + Also indicate where execution is about to resume. } +{$IFNDEF LINUX} +procedure NotifyTerminate; +asm + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH EDX + PUSH ESP + PUSH 1 + PUSH cContinuable + PUSH cDelphiTerminate { our magic exception code } + CALL RaiseExceptionProc + POP EDX +@@1: +end; +{$ENDIF} + +{ 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; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX location of exception } + PUSH EAX + MOV EAX, [EAX].TRaisedException.ExceptObject + + PUSH 0 { handler addr } + PUSH EDX { location of exception } + MOV ECX, [EAX] + PUSH [ECX].vmtClassName { exception name } + PUSH EAX { exception object } + PUSH excUnhandled { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 + + POP EAX +{$ELSE} + PUSH EAX + PUSH EDX + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH ESP + PUSH 2 + PUSH cContinuable + PUSH cDelphiUnhandled + CALL RaiseExceptionProc +@@1: + POP EDX + POP EAX +{$ENDIF} +end; + +{$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; +asm + // If this exception is from C++, then private_2 will be a + // throw address. If not, then it will be zero. private_1 + // will be either the exception object itself, or a TRaisedException. + OR EDX, EDX // From C++? + JZ @@ExcAllocated + + // We've decided that the exception is from C++, but it is a + // Delphi exception object. We will coopt the exception now + // by installing a TRaisedException into the unwinder exception, + // and setting private_2 to 0. Then the exception will look + // like it was truly thrown from this RTL. + CALL AllocateException + +@@ExcAllocated: +end; + +function LinkException(Exc: PRaisedException): PRaisedException; +asm + PUSH EDX // preserve EDX because of HandleOnException + PUSH EAX + CALL SysInit.@GetTLS + POP EDX + MOV ECX, [EAX].ExceptionList + MOV [EDX].TRaisedException.Prev, ECX + MOV [EAX].ExceptionList, EDX + MOV EAX, EDX + POP EDX +end; + +function UnlinkException: PRaisedException; +asm + CALL SysInit.@GetTLS + MOV EDX, [EAX].ExceptionList + MOV EDX, [EDX].TRaisedException.Prev + MOV [EAX].ExceptionList, EDX +end; +{$ENDIF} + +procedure _HandleAnyException; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + CMP ECX, UW_EXC_CLASS_BORLANDCPP // C++ exception? + JNE @@handleIt // nope, handle it + // C++ exceptions aren't wanted here. Retoss them as is + CALL SysRaiseCPPException + +@@handleIt: + PUSH EAX + PUSH EDX + CALL UnblockOSExceptions + POP EDX + POP EAX + + // If the exception is a Delphi exception thrown from C++, coopt it. + CALL MaybeCooptException + + OR [EAX].TRaisedException.Flags, excIsBeingHandled + CALL LinkException + MOV ESI, EBX + MOV EDX, [ESP] + CALL NotifyExcept + MOV EBX, ESI +{$ENDIF} +{$IFNDEF PC_MAPPED_EXCEPTIONS} + { -> [ESP+ 4] excPtr: PExceptionRecord } + { [ESP+ 8] errPtr: PExcFrame } + { [ESP+12] ctxPtr: Pointer } + { [ESP+16] dspPtr: Pointer } + { <- EAX return value - always one } + + MOV EAX,[ESP+4] + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JNE @@exit + + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + MOV EDX,[EAX].TExceptionRecord.ExceptObject + MOV ECX,[EAX].TExceptionRecord.ExceptAddr + JE @@DelphiException + CLD + CALL _FpuInit + MOV EDX,ExceptObjProc + TEST EDX,EDX + JE @@exit + CALL EDX + TEST EAX,EAX + JE @@exit + MOV EDX,[ESP+12] + MOV ECX,[ESP+4] + CMP [ECX].TExceptionRecord.ExceptionCode,cCppException + JE @@CppException + CALL NotifyNonDelphiException +{$IFDEF MSWINDOWS} + CMP BYTE PTR JITEnable,0 + JBE @@CppException + CMP BYTE PTR DebugHook,0 + JA @@CppException // Do not JIT if debugging + LEA ECX,[ESP+4] + PUSH EAX + PUSH ECX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + POP EAX + JE @@exit + MOV EDX,EAX + MOV EAX,[ESP+4] + MOV ECX,[EAX].TExceptionRecord.ExceptionAddress + JMP @@GoUnwind +{$ENDIF} +@@CppException: + MOV EDX,EAX + MOV EAX,[ESP+4] + MOV ECX,[EAX].TExceptionRecord.ExceptionAddress + +@@DelphiException: +{$IFDEF MSWINDOWS} + CMP BYTE PTR JITEnable,1 + JBE @@GoUnwind + CMP BYTE PTR DebugHook,0 { Do not JIT if debugging } + JA @@GoUnwind + PUSH EAX + LEA EAX,[ESP+8] + PUSH EDX + PUSH ECX + PUSH EAX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + POP ECX + POP EDX + POP EAX + JE @@exit +{$ENDIF} + +@@GoUnwind: + OR [EAX].TExceptionRecord.ExceptionFlags,cUnwinding + + PUSH EBX + XOR EBX,EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBX,FS:[EBX] + PUSH EBX { Save pointer to topmost frame } + PUSH EAX { Save OS exception pointer } + PUSH EDX { Save exception object } + PUSH ECX { Save exception address } + + MOV EDX,[ESP+8+8*4] + + PUSH 0 + PUSH EAX + PUSH offset @@returnAddress + PUSH EDX + CALL RtlUnwindProc +@@returnAddress: + + MOV EDI,[ESP+8+8*4] + + { Make the RaiseList entry on the stack } + + CALL SysInit.@GetTLS + PUSH [EAX].RaiseListPtr + MOV [EAX].RaiseListPtr,ESP + + MOV EBP,[EDI].TExcFrame.hEBP + MOV EBX,[EDI].TExcFrame.desc + MOV [EDI].TExcFrame.desc,offset @@exceptFinally + + ADD EBX,TExcDesc.instructions + CALL NotifyAnyExcept + JMP EBX + +@@exceptFinally: + JMP _HandleFinally + +@@destroyExcept: + { we come here if an exception handler has thrown yet another exception } + { we need to destroy the exception object and pop the raise list. } + + CALL SysInit.@GetTLS + MOV ECX,[EAX].RaiseListPtr + MOV EDX,[ECX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,EDX + + MOV EAX,[ECX].TRaiseFrame.ExceptObject + JMP TObject.Free + +@@exit: + MOV EAX,1 +{$ENDIF} { not PC_MAPPED_EXCEPTIONS } +end; + +{$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; +asm + { -> EAX raised object: Pointer } + { EDX descriptor table: ^TExcDesc } + { EBX GOT of user code, or 0 if not an SO } + { <- EAX matching descriptor: ^TExcDescEntry } + PUSH EBP + MOV EBP, ESP + SUB ESP, 8 { Room for vtable temp, and adjustor } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV [EBP - 8], EBX { Store the potential GOT } + MOV EAX, [EAX] { load vtable of exception object } + MOV EBX,[EDX].TExcDesc.cnt + LEA ESI,[EDX].TExcDesc.excTab { point ECX to exc descriptor table } + MOV [EBP - 4], EAX { temp for vtable of exception object } + +@@innerLoop: + MOV EAX,[ESI].TExcDescEntry.vTable + TEST EAX,EAX { catch all clause? } + JE @@found { yes: This is the handler } + ADD EAX, [EBP - 8] { add in the adjustor (could be 0) } + MOV EDI,[EBP - 4] { load vtable of exception object } + JMP @@haveVMT + +@@vtLoop: + MOV EDI,[EDI] +@@haveVMT: + MOV EAX,[EAX] + CMP EAX,EDI + JE @@found + + MOV ECX,[EAX].vmtInstanceSize + CMP ECX,[EDI].vmtInstanceSize + JNE @@parent + + MOV EAX,[EAX].vmtClassName + MOV EDX,[EDI].vmtClassName + + XOR ECX,ECX + MOV CL,[EAX] + CMP CL,[EDX] + JNE @@parent + + INC EAX + INC EDX + CALL _AStrCmp + JE @@found + +@@parent: + MOV EDI,[EDI].vmtParent { load vtable of parent } + MOV EAX,[ESI].TExcDescEntry.vTable + ADD EAX, [EBP - 8] { add in the adjustor (could be 0) } + TEST EDI,EDI + JNE @@vtLoop + + ADD ESI,8 + DEC EBX + JNZ @@innerLoop + + { Didn't find a handler. } + XOR ESI, ESI + +@@found: + MOV EAX, ESI +@@done: + POP EDI + POP ESI + POP EBX + MOV ESP, EBP + POP EBP +end; +{$ENDIF} + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _HandleOnExceptionPIC; +asm + { -> EAX obj : Exception object } + { [RA] desc: ^TExcDesc } + { <- Doesn't return } + + // Mark the exception as being handled + OR [EAX].TRaisedException.Flags, excIsBeingHandled + + MOV ESI, EBX // Save the GOT + MOV EDX, [ESP] // Get the addr of the TExcDesc + PUSH EAX // Save the object + MOV EAX, [EAX].TRaisedException.ExceptObject + CALL FindOnExceptionDescEntry + OR EAX, EAX + JE @@NotForMe + + MOV EBX, ESI // Set back to user's GOT + MOV EDX, EAX + POP EAX // Get the object back + POP ECX // Ditch the return addr + + CALL LinkException + + // Get the Pascal object itself. + MOV EAX, [EAX].TRaisedException.ExceptObject + + MOV EDX, [EDX].TExcDescEntry.handler + ADD EDX, EBX // adjust for GOT + CALL NotifyOnExcept + + MOV EBX, ESI // Make sure of user's GOT + JMP EDX // Back to the user code + // never returns +@@NotForMe: + POP EAX // Get the exception object + + // Mark that we're reraising this exception, so that the + // compiler generated exception handler for the 'except on' clause + // will not get confused + OR [EAX].TRaisedException.Flags, excIsBeingReRaised + + JMP SysRaiseException // Should be using resume here +end; +{$ENDIF} + +procedure _HandleOnException; +{$IFDEF PC_MAPPED_EXCEPTIONS} +asm + { -> EAX obj : Exception object } + { [RA] desc: ^TExcDesc } + { <- Doesn't return } + + CMP ECX, UW_EXC_CLASS_BORLANDCPP // C++ exception? + JNE @@handleIt // nope, handle it + // C++ exceptions aren't wanted here. Retoss them as is + CALL SysRaiseCPPException + +@@handleIt: + // If the exception is a Delphi exception thrown from C++, coopt it. + CALL MaybeCooptException + + // Mark the exception as being handled + OR [EAX].TRaisedException.Flags, excIsBeingHandled + + MOV EDX, [ESP] // Get the addr of the TExcDesc + PUSH EAX // Save the object + PUSH EBX // Save EBX + XOR EBX, EBX // No GOT + MOV EAX, [EAX].TRaisedException.ExceptObject + CALL FindOnExceptionDescEntry + POP EBX // Restore EBX + OR EAX, EAX // Is the exception for me? + JE @@NotForMe + + MOV EDX, EAX + POP EAX // Get the object back + POP ECX // Ditch the return addr + + CALL LinkException + + // Get the Pascal object itself. + MOV EAX, [EAX].TRaisedException.ExceptObject + + MOV EDX, [EDX].TExcDescEntry.handler + CALL NotifyOnExcept // Tell the debugger about it + + JMP EDX // Back to the user code + // never returns +@@NotForMe: + POP EAX // Get the exception object + + // Mark that we're reraising this exception, so that the + // compiler generated exception handler for the 'except on' clause + // will not get confused + OR [EAX].TRaisedException.Flags, excIsBeingReRaised + JMP SysRaiseException // Should be using resume here +end; +{$ENDIF} +{$IFNDEF PC_MAPPED_EXCEPTIONS} +asm + { -> [ESP+ 4] excPtr: PExceptionRecord } + { [ESP+ 8] errPtr: PExcFrame } + { [ESP+12] ctxPtr: Pointer } + { [ESP+16] dspPtr: Pointer } + { <- EAX return value - always one } + + MOV EAX,[ESP+4] + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JNE @@exit + + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + JE @@DelphiException + CLD + CALL _FpuInit + MOV EDX,ExceptClsProc + TEST EDX,EDX + JE @@exit + CALL EDX + TEST EAX,EAX + JNE @@common + JMP @@exit + +@@DelphiException: + MOV EAX,[EAX].TExceptionRecord.ExceptObject + MOV EAX,[EAX] { load vtable of exception object } + +@@common: + + MOV EDX,[ESP+8] + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV ECX,[EDX].TExcFrame.desc + MOV EBX,[ECX].TExcDesc.cnt + LEA ESI,[ECX].TExcDesc.excTab { point ECX to exc descriptor table } + MOV EBP,EAX { load vtable of exception object } + +@@innerLoop: + MOV EAX,[ESI].TExcDescEntry.vTable + TEST EAX,EAX { catch all clause? } + JE @@doHandler { yes: go execute handler } + MOV EDI,EBP { load vtable of exception object } + JMP @@haveVMT + +@@vtLoop: + MOV EDI,[EDI] +@@haveVMT: + MOV EAX,[EAX] + CMP EAX,EDI + JE @@doHandler + + MOV ECX,[EAX].vmtInstanceSize + CMP ECX,[EDI].vmtInstanceSize + JNE @@parent + + MOV EAX,[EAX].vmtClassName + MOV EDX,[EDI].vmtClassName + + XOR ECX,ECX + MOV CL,[EAX] + CMP CL,[EDX] + JNE @@parent + + INC EAX + INC EDX + CALL _AStrCmp + JE @@doHandler + +@@parent: + MOV EDI,[EDI].vmtParent { load vtable of parent } + MOV EAX,[ESI].TExcDescEntry.vTable + TEST EDI,EDI + JNE @@vtLoop + + ADD ESI,8 + DEC EBX + JNZ @@innerLoop + + POP EBP + POP EDI + POP ESI + POP EBX + JMP @@exit + +@@doHandler: + MOV EAX,[ESP+4+4*4] + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + MOV EDX,[EAX].TExceptionRecord.ExceptObject + MOV ECX,[EAX].TExceptionRecord.ExceptAddr + JE @@haveObject + CALL ExceptObjProc + MOV EDX,[ESP+12+4*4] + CALL NotifyNonDelphiException +{$IFDEF MSWINDOWS} + CMP BYTE PTR JITEnable,0 + JBE @@NoJIT + CMP BYTE PTR DebugHook,0 + JA @@noJIT { Do not JIT if debugging } + LEA ECX,[ESP+4] + PUSH EAX + PUSH ECX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + POP EAX + JE @@exit +{$ENDIF} +@@noJIT: + MOV EDX,EAX + MOV EAX,[ESP+4+4*4] + MOV ECX,[EAX].TExceptionRecord.ExceptionAddress + JMP @@GoUnwind + +@@haveObject: +{$IFDEF MSWINDOWS} + CMP BYTE PTR JITEnable,1 + JBE @@GoUnwind + CMP BYTE PTR DebugHook,0 + JA @@GoUnwind + PUSH EAX + LEA EAX,[ESP+8] + PUSH EDX + PUSH ECX + PUSH EAX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + POP ECX + POP EDX + POP EAX + JE @@exit +{$ENDIF} + +@@GoUnwind: + XOR EBX,EBX + MOV EBX,FS:[EBX] + PUSH EBX { Save topmost frame } + PUSH EAX { Save exception record } + PUSH EDX { Save exception object } + PUSH ECX { Save exception address } + + MOV EDX,[ESP+8+8*4] + OR [EAX].TExceptionRecord.ExceptionFlags,cUnwinding + + PUSH ESI { Save handler entry } + + PUSH 0 + PUSH EAX + PUSH offset @@returnAddress + PUSH EDX + CALL RtlUnwindProc +@@returnAddress: + + POP EBX { Restore handler entry } + + MOV EDI,[ESP+8+8*4] + + { Make the RaiseList entry on the stack } + + CALL SysInit.@GetTLS + PUSH [EAX].RaiseListPtr + MOV [EAX].RaiseListPtr,ESP + + MOV EBP,[EDI].TExcFrame.hEBP + MOV [EDI].TExcFrame.desc,offset @@exceptFinally + MOV EAX,[ESP].TRaiseFrame.ExceptObject + CALL NotifyOnExcept + JMP [EBX].TExcDescEntry.handler + +@@exceptFinally: + JMP _HandleFinally + +@@destroyExcept: + { we come here if an exception handler has thrown yet another exception } + { we need to destroy the exception object and pop the raise list. } + + CALL SysInit.@GetTLS + MOV ECX,[EAX].RaiseListPtr + MOV EDX,[ECX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,EDX + + MOV EAX,[ECX].TRaiseFrame.ExceptObject + JMP TObject.Free +@@exit: + MOV EAX,1 +end; +{$ENDIF} + +procedure _HandleFinally; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} +{$IFDEF PIC} + MOV ESI, EBX +{$ENDIF} + CMP ECX, UW_EXC_CLASS_BORLANDCPP // C++ exception? + JNE @@handleIt // nope, handle it + // unwinding a C++ exception. We handle that specially. + PUSH EAX + PUSH EDX + PUSH ECX + MOV EDX, [ESP+12] + CALL EDX + POP ECX + POP EDX + POP EAX + CALL SysRaiseCPPException + +@@handleIt: + PUSH EAX + PUSH EDX + CALL UnblockOSExceptions + POP EDX + POP EAX + + // If the exception is a Delphi exception thrown from C++, coopt it. + CALL MaybeCooptException + + MOV EDX, [ESP] + CALL NotifyExceptFinally + PUSH EAX +{$IFDEF PIC} + MOV EBX, ESI +{$ENDIF} + { + Mark the current exception with the EBP of the handler. If + an exception is raised from the finally block, then this + exception will be orphaned. We will catch this later, when + we clean up the next except block to complete execution. + See DoneExcept. + } + MOV [EAX].TRaisedException.HandlerEBP, EBP + CALL EDX + POP EAX + { + We executed the finally handler without adverse reactions. + It's safe to clear the marker now. + } + MOV [EAX].TRaisedException.HandlerEBP, $FFFFFFFF + PUSH EBP + MOV EBP, ESP + CALL SysRaiseException // Should be using resume here +{$ENDIF} +{$IFDEF MSWINDOWS} + { -> [ESP+ 4] excPtr: PExceptionRecord } + { [ESP+ 8] errPtr: PExcFrame } + { [ESP+12] ctxPtr: Pointer } + { [ESP+16] dspPtr: Pointer } + { <- EAX return value - always one } + + MOV EAX,[ESP+4] + MOV EDX,[ESP+8] + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JE @@exit + MOV ECX,[EDX].TExcFrame.desc + MOV [EDX].TExcFrame.desc,offset @@exit + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBP,[EDX].TExcFrame.hEBP + ADD ECX,TExcDesc.instructions + CALL NotifyExceptFinally + CALL ECX + + POP EBP + POP EDI + POP ESI + POP EBX + +@@exit: + MOV EAX,1 +{$ENDIF} +end; + + +procedure _HandleAutoException; +{$IFDEF LINUX} +{$IFDEF PC_MAPPED_EXCEPTIONS} +asm + // EAX = TObject reference, or nil + // [ESP] = ret addr + + PUSH EAX + PUSH EDX + CALL UnblockOSExceptions + POP EDX + POP EAX + + // If the exception is a Delphi exception thrown from C++, coopt it. + CALL MaybeCooptException + + CALL LinkException +// +// The compiler wants the stack to look like this: +// ESP+4-> HRESULT +// ESP+0-> ret addr +// +// Make it so. +// + POP EDX + PUSH 8000FFFFH + PUSH EDX + + OR EAX, EAX // Was this a method call? + JE @@Done + + PUSH EAX + CALL CurrentException + MOV EDX, [EAX].TRaisedException.ExceptObject + MOV ECX, [EAX].TRaisedException.ExceptionAddr; + POP EAX + MOV EAX, [EAX] + CALL DWORD PTR [EAX] + VMTOFFSET TObject.SafeCallException; + MOV [ESP+4], EAX +@@Done: + CALL _DoneExcept +end; +{$ELSE} +begin + Error(reSafeCallError); //!! +end; +{$ENDIF} +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + { -> [ESP+ 4] excPtr: PExceptionRecord } + { [ESP+ 8] errPtr: PExcFrame } + { [ESP+12] ctxPtr: Pointer } + { [ESP+16] dspPtr: Pointer } + { <- EAX return value - always one } + + MOV EAX,[ESP+4] + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JNE @@exit + + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + CLD + CALL _FpuInit + JE @@DelphiException + CMP BYTE PTR JITEnable,0 + JBE @@DelphiException + CMP BYTE PTR DebugHook,0 + JA @@DelphiException + +@@DoUnhandled: + LEA EAX,[ESP+4] + PUSH EAX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + JE @@exit + MOV EAX,[ESP+4] + JMP @@GoUnwind + +@@DelphiException: + CMP BYTE PTR JITEnable,1 + JBE @@GoUnwind + CMP BYTE PTR DebugHook,0 + JA @@GoUnwind + JMP @@DoUnhandled + +@@GoUnwind: + OR [EAX].TExceptionRecord.ExceptionFlags,cUnwinding + + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EDX,[ESP+8+3*4] + + PUSH 0 + PUSH EAX + PUSH offset @@returnAddress + PUSH EDX + CALL RtlUnwindProc + +@@returnAddress: + POP EBP + POP EDI + POP ESI + MOV EAX,[ESP+4] + MOV EBX,8000FFFFH + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + JNE @@done + + MOV EDX,[EAX].TExceptionRecord.ExceptObject + MOV ECX,[EAX].TExceptionRecord.ExceptAddr + MOV EAX,[ESP+8] + MOV EAX,[EAX].TExcFrame.SelfOfMethod + TEST EAX,EAX + JZ @@freeException + MOV EBX,[EAX] + CALL DWORD PTR [EBX] + VMTOFFSET TObject.SafeCallException + MOV EBX,EAX +@@freeException: + MOV EAX,[ESP+4] + MOV EAX,[EAX].TExceptionRecord.ExceptObject + CALL TObject.Free +@@done: + XOR EAX,EAX + MOV ESP,[ESP+8] + POP ECX + MOV FS:[EAX],ECX + POP EDX + POP EBP + LEA EDX,[EDX].TExcDesc.instructions + POP ECX + JMP EDX +@@exit: + MOV EAX,1 +end; +{$ENDIF} + + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _RaiseAtExcept; +asm + { -> EAX Pointer to exception object } + { -> EDX Purported addr of exception } + { Be careful: EBX is not set up in PIC mode. } + { Outward bound calls must go through an exported fn, like SysRaiseException } + OR EAX, EAX + JNE @@GoAhead + MOV EAX, 216 + CALL _RunError + +@@GoAhead: + CALL BlockOSExceptions + PUSH EBP + MOV EBP, ESP + CALL NotifyReRaise + CALL AllocateException + CALL SysRaiseException + { + This can only return if there was a terrible error. In this event, + we have to bail out. + } + JMP _Run0Error +end; +{$ENDIF} + +procedure _RaiseExcept; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + { -> EAX Pointer to exception object } + MOV EDX, [ESP] + JMP _RaiseAtExcept +{$ENDIF} +{$IFDEF MSWINDOWS} + { When making changes to the way Delphi Exceptions are raised, } + { please realize that the C++ Exception handling code reraises } + { some exceptions as Delphi Exceptions. Of course we want to } + { keep exception raising compatible between Delphi and C++, so } + { when you make changes here, consult with the relevant C++ } + { exception handling engineer. The C++ code is in xx.cpp, in } + { the RTL sources, in function tossAnException. } + + { -> EAX Pointer to exception object } + { [ESP] Error address } + + OR EAX, EAX + JNE @@GoAhead + MOV EAX, 216 + CALL _RunError +@@GoAhead: + POP EDX + + PUSH ESP + PUSH EBP + PUSH EDI + PUSH ESI + PUSH EBX + PUSH EAX { pass class argument } + PUSH EDX { pass address argument } + + PUSH ESP { pass pointer to arguments } + PUSH 7 { there are seven arguments } + PUSH cNonContinuable { we can't continue execution } + PUSH cDelphiException { our magic exception code } + PUSH EDX { pass the user's return address } + JMP RaiseExceptionProc +{$ENDIF} +end; + + +{$IFDEF PC_MAPPED_EXCEPTIONS} +{ + Used in the PC mapping exception implementation to handle exceptions in constructors. +} +procedure _ClassHandleException; +asm + { + EAX = Ptr to TRaisedException + EDX = self + ECX = top flag + } + PUSH ECX + CALL LinkException + MOV EAX,EDX + POP EDX + TEST DL, DL + JE _RaiseAgain + MOV ECX,[EAX] + MOV DL,$81 + PUSH EAX + CALL DWORD PTR [ECX] + VMTOFFSET TObject.Destroy + POP EAX + CALL _ClassDestroy + JMP _RaiseAgain +end; +{$ENDIF} + +procedure _RaiseAgain; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + CALL CurrentException +// The following notifies the debugger of a reraise of exceptions. This will +// be supported in a later release, but is disabled for now. +// PUSH EAX +// MOV EDX, [EAX].TRaisedException.ExceptionAddr +// MOV EAX, [EAX].TRaisedException.ExceptObject +// CALL NotifyReRaise { Tell the debugger } +// POP EAX + TEST [EAX].TRaisedException.Flags, excIsBeingHandled + JZ @@DoIt + OR [EAX].TRaisedException.Flags, excIsBeingReRaised +@@DoIt: + PUSH EAX + CALL UnlinkException + POP EAX + MOV EDX, [ESP] { Get the user's addr } + JMP SysRaiseException +{$ENDIF} +{$IFDEF MSWINDOWS} + { -> [ESP ] return address to user program } + { [ESP+ 4 ] raise list entry (4 dwords) } + { [ESP+ 4+ 4*4] saved topmost frame } + { [ESP+ 4+ 5*4] saved registers (4 dwords) } + { [ESP+ 4+ 9*4] return address to OS } + { -> [ESP+ 4+10*4] excPtr: PExceptionRecord } + { [ESP+ 8+10*4] errPtr: PExcFrame } + + { Point the error handler of the exception frame to something harmless } + + MOV EAX,[ESP+8+10*4] + MOV [EAX].TExcFrame.desc,offset @@exit + + { Pop the RaiseList } + + CALL SysInit.@GetTLS + MOV EDX,[EAX].RaiseListPtr + MOV ECX,[EDX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,ECX + + { Destroy any objects created for non-delphi exceptions } + + MOV EAX,[EDX].TRaiseFrame.ExceptionRecord + AND [EAX].TExceptionRecord.ExceptionFlags,NOT cUnwinding + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + JE @@delphiException + MOV EAX,[EDX].TRaiseFrame.ExceptObject + CALL TObject.Free + CALL NotifyReRaise + +@@delphiException: + + XOR EAX,EAX + ADD ESP,5*4 + MOV EDX,FS:[EAX] + POP ECX + MOV EDX,[EDX].TExcFrame.next + MOV [ECX].TExcFrame.next,EDX + + POP EBP + POP EDI + POP ESI + POP EBX +@@exit: + MOV EAX,1 +{$ENDIF} +end; + +{$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; +var + Exc: PRaisedException; + RefCount: Integer; + ExcObj: Pointer; + ExcAddr: Pointer; +begin + asm + CMP ECX, UW_EXC_CLASS_BORLANDCPP + JNE @@notCPP + CALL SysRaiseCPPException +@@notCPP: + MOV Exc, EAX + end; + + if (Exc^.Flags and excIsBeingReRaised) = 0 then + begin + RefCount := Exc^.RefCount; + ExcObj := Exc^.ExceptObject; + ExcAddr := Exc^.ExceptionAddr; + Exc^.RefCount := 1; + FreeException; + _DoneExcept; + Exc := AllocateException(ExcObj, ExcAddr); + Exc^.RefCount := RefCount; + end; + + Exc^.Flags := Exc^.Flags and not (excIsBeingReRaised or excIsBeingHandled); + + SysRaiseException(Exc); +end; + +procedure CleanupException; +asm + CALL FreeException + OR EAX, EAX + JE @@Done + CALL TObject.Free +@@Done: +end; +{$ENDIF} + +procedure _DoneExcept; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + CALL FreeException + OR EAX, EAX + JE @@Done + CALL TObject.Free +@@Done: + CALL UnlinkException + { + Take a peek at the next exception object on the stack. + If its EBP marker is at an address lower than our current + EBP, then we know that it was orphaned when an exception was + thrown from within the execution of a finally block. We clean + it up now, so that we won't leak exception records/objects. + } + CALL CurrentException + OR EAX, EAX + JE @@Done2 + CMP [EAX].TRaisedException.HandlerEBP, EBP + JA @@Done2 + CALL FreeException + OR EAX, EAX + JE @@Done2 + CALL TObject.Free +@@Done2: +{$ENDIF} +{$IFDEF MSWINDOWS} + { -> [ESP+ 4+10*4] excPtr: PExceptionRecord } + { [ESP+ 8+10*4] errPtr: PExcFrame } + + { Pop the RaiseList } + + CALL SysInit.@GetTLS + MOV EDX,[EAX].RaiseListPtr + MOV ECX,[EDX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,ECX + + { Destroy exception object } + + MOV EAX,[EDX].TRaiseFrame.ExceptObject + CALL TObject.Free + + POP EDX + MOV ESP,[ESP+8+9*4] + XOR EAX,EAX + POP ECX + MOV FS:[EAX],ECX + POP EAX + POP EBP + CALL NotifyTerminate + JMP EDX +{$ENDIF} +end; + +{$IFNDEF PC_MAPPED_EXCEPTIONS} +procedure _TryFinallyExit; +asm +{$IFDEF MSWINDOWS} + XOR EDX,EDX + MOV ECX,[ESP+4].TExcFrame.desc + MOV EAX,[ESP+4].TExcFrame.next + ADD ECX,TExcDesc.instructions + MOV FS:[EDX],EAX + CALL ECX +@@1: RET 12 +{$ENDIF} +end; +{$ENDIF} + + +var + InitContext: TInitContext; + +{$IFNDEF PC_MAPPED_EXCEPTIONS} +procedure MapToRunError(P: PExceptionRecord); stdcall; +const + STATUS_ACCESS_VIOLATION = $C0000005; + STATUS_ARRAY_BOUNDS_EXCEEDED = $C000008C; + STATUS_FLOAT_DENORMAL_OPERAND = $C000008D; + STATUS_FLOAT_DIVIDE_BY_ZERO = $C000008E; + STATUS_FLOAT_INEXACT_RESULT = $C000008F; + STATUS_FLOAT_INVALID_OPERATION = $C0000090; + STATUS_FLOAT_OVERFLOW = $C0000091; + STATUS_FLOAT_STACK_CHECK = $C0000092; + STATUS_FLOAT_UNDERFLOW = $C0000093; + STATUS_INTEGER_DIVIDE_BY_ZERO = $C0000094; + STATUS_INTEGER_OVERFLOW = $C0000095; + STATUS_PRIVILEGED_INSTRUCTION = $C0000096; + STATUS_STACK_OVERFLOW = $C00000FD; + STATUS_CONTROL_C_EXIT = $C000013A; +var + ErrCode: Byte; +begin + case P.ExceptionCode of + STATUS_INTEGER_DIVIDE_BY_ZERO: ErrCode := 200; { reDivByZero } + STATUS_ARRAY_BOUNDS_EXCEEDED: ErrCode := 201; { reRangeError } + STATUS_FLOAT_OVERFLOW: ErrCode := 205; { reOverflow } + STATUS_FLOAT_INEXACT_RESULT, + STATUS_FLOAT_INVALID_OPERATION, + STATUS_FLOAT_STACK_CHECK: ErrCode := 207; { reInvalidOp } + STATUS_FLOAT_DIVIDE_BY_ZERO: ErrCode := 200; { reZeroDivide } + STATUS_INTEGER_OVERFLOW: ErrCode := 215; { reIntOverflow} + STATUS_FLOAT_UNDERFLOW, + STATUS_FLOAT_DENORMAL_OPERAND: ErrCode := 206; { reUnderflow } + STATUS_ACCESS_VIOLATION: ErrCode := 216; { reAccessViolation } + STATUS_PRIVILEGED_INSTRUCTION: ErrCode := 218; { rePrivInstruction } + STATUS_CONTROL_C_EXIT: ErrCode := 217; { reControlBreak } + STATUS_STACK_OVERFLOW: ErrCode := 202; { reStackOverflow } + else ErrCode := 255; + end; + RunErrorAt(ErrCode, P.ExceptionAddress); +end; + +procedure _ExceptionHandler; +asm + MOV EAX,[ESP+4] + + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JNE @@exit +{$IFDEF MSWINDOWS} + CMP BYTE PTR DebugHook,0 + JA @@ExecuteHandler + LEA EAX,[ESP+4] + PUSH EAX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + JNE @@ExecuteHandler + JMP @@exit +{$ENDIF} + +@@ExecuteHandler: + MOV EAX,[ESP+4] + CLD + CALL _FpuInit + MOV EDX,[ESP+8] + + PUSH 0 + PUSH EAX + PUSH offset @@returnAddress + PUSH EDX + CALL RtlUnwindProc + +@@returnAddress: + MOV EBX,[ESP+4] + CMP [EBX].TExceptionRecord.ExceptionCode,cDelphiException + MOV EDX,[EBX].TExceptionRecord.ExceptAddr + MOV EAX,[EBX].TExceptionRecord.ExceptObject + JE @@DelphiException2 + + MOV EDX,ExceptObjProc + TEST EDX,EDX + JE MapToRunError + MOV EAX,EBX + CALL EDX + TEST EAX,EAX + JE MapToRunError + MOV EDX,[EBX].TExceptionRecord.ExceptionAddress + +@@DelphiException2: + + CALL NotifyUnhandled + MOV ECX,ExceptProc + TEST ECX,ECX + JE @@noExceptProc + CALL ECX { call ExceptProc(ExceptObject, ExceptAddr) } + +@@noExceptProc: + MOV ECX,[ESP+4] + MOV EAX,217 + MOV EDX,[ECX].TExceptionRecord.ExceptAddr + MOV [ESP],EDX + JMP _RunError + +@@exit: + XOR EAX,EAX +end; + +procedure SetExceptionHandler; +asm + XOR EDX,EDX { using [EDX] saves some space over [0] } +{X+} // now we come here from another place, and EBP is used above for loop counter +{X+} // let us restore it... +{X+} PUSH EBP +{X+} LEA EBP, [ESP + $50] + LEA EAX,[EBP-12] + MOV ECX,FS:[EDX] { ECX := head of chain } + MOV FS:[EDX],EAX { head of chain := @exRegRec } + + MOV [EAX].TExcFrame.next,ECX +{$IFDEF PIC} + LEA EDX, [EBX]._ExceptionHandler + MOV [EAX].TExcFrame.desc, EDX +{$ELSE} + MOV [EAX].TExcFrame.desc,offset _ExceptionHandler +{$ENDIF} + MOV [EAX].TExcFrame.hEBP,EBP +{$IFDEF PIC} + MOV [EBX].InitContext.ExcFrame,EAX +{$ELSE} + MOV InitContext.ExcFrame,EAX +{$ENDIF} +{X+} POP EBP +end; + + +procedure UnsetExceptionHandler; +asm + XOR EDX,EDX +{$IFDEF PIC} + MOV EAX,[EBX].InitContext.ExcFrame +{$ELSE} + MOV EAX,InitContext.ExcFrame +{$ENDIF} + TEST EAX,EAX + JZ @@exit + MOV ECX,FS:[EDX] { ECX := head of chain } + CMP EAX,ECX { simple case: our record is first } + JNE @@search + MOV EAX,[EAX] { head of chain := exRegRec.next } + MOV FS:[EDX],EAX + JMP @@exit + +@@loop: + MOV ECX,[ECX] +@@search: + CMP ECX,-1 { at end of list? } + JE @@exit { yes - didn't find it } + CMP [ECX],EAX { is it the next one on the list? } + JNE @@loop { no - look at next one on list } +@@unlink: { yes - unlink our record } + MOV EAX,[EAX] { get next record on list } + MOV [ECX],EAX { unlink our record } +@@exit: +end; +{$ENDIF} // not PC_MAPPED_EXCEPTIONS + +type + TProc = procedure; + +{$IFDEF LINUX} +procedure CallProc(Proc: Pointer; GOT: Cardinal); +asm + PUSH EBX + MOV EBX,EDX + ADD EAX,EBX + CALL EAX + POP EBX +end; +{$ENDIF} +(*X- Original version... discarded +procedure FinalizeUnits; +var + Count: Integer; + Table: PUnitEntryTable; + P: Pointer; +begin + if InitContext.InitTable = nil then + exit; + Count := InitContext.InitCount; + Table := InitContext.InitTable^.UnitInfo; +{$IFDEF LINUX} + Inc(Cardinal(Table), InitContext.Module^.GOT); +{$ENDIF} + try + while Count > 0 do + begin + Dec(Count); + InitContext.InitCount := Count; + P := Table^[Count].FInit; + if Assigned(P) then + begin +{$IFDEF LINUX} + CallProc(P, InitContext.Module^.GOT); +{$ENDIF} +{$IFDEF MSWINDOWS} + TProc(P)(); +{$ENDIF} + end; + end; + except + FinalizeUnits; { try to finalize the others } + raise; + end; +end; +X-*) +const + errCaption: array[0..5] of Char = 'Error'#0; + +{***********************************************************} + + +{X+}// see comments in InitUnits below +{X+}procedure InitUnitsLight( Table : PUnitEntryTable; Idx, Count : Integer ); +{X+}var +{X+} P : Pointer; +{X+} Light : Boolean; +{X+}begin +{X+} Light := @InitUnitsProc = @InitUnitsLight; +{X+} while Idx < Count do +{X+} begin +{X+} P := Table^[ Idx ].Init; +{X+} Inc( Idx ); +{X+} InitContext.InitCount := Idx; +{X+} if Assigned( P ) then begin +{X+}{$IFDEF LINUX} +{X+} CallProc(P, InitContext.Module^.GOT); +{X+}{$ENDIF} +{X+}{$IFDEF MSWINDOWS} +{X+} TProc(P)(); +{X+}{$ENDIF} +{X+} end; +{X+} if Light and (@InitUnitsProc <> @InitUnitsLight) then +{X+} begin +{X+} InitUnitsProc( Table, Idx, Count ); +{X+} break; +{X+} end; +{X+} end; +{X+}end; + +{X+}// see comments in InitUnits below } +{X+}procedure FinitUnitsLight; +{X+}var +{X+} Count: Integer; +{X+} Table: PUnitEntryTable; +{X+} P: Pointer; +{X+}begin +{X+} if InitContext.InitTable = nil then +{X+} exit; +{X+} Count := InitContext.InitCount; +{X+} Table := InitContext.InitTable^.UnitInfo; +{X+}{$IFDEF LINUX} +{X+} Inc(Cardinal(Table), InitContext.Module^.GOT); +{X+}{$ENDIF} +{X+} while Count > 0 do +{X+} begin +{X+} Dec(Count); +{X+} InitContext.InitCount := Count; +{X+} P := Table^[Count].FInit; +{X+} if Assigned(P) then +{X+}{$IFDEF LINUX} +{X+} CallProc(P, InitContext.Module^.GOT); +{X+}{$ENDIF} +{X+}{$IFDEF MSWINDOWS} +{X+} TProc(P)(); +{X+}{$ENDIF} +{X+} end; +{X+}end; + +{X+}procedure InitUnitsHard( Table : PUnitEntryTable; Idx, Count : Integer ); +{X+}begin +{X+} try +{X+} InitUnitsLight( Table, Idx, Count ); +{X+} except +{X+} FInitUnitsHard; +{X+} raise; +{X+} end; +{X+}end; + +{X+}// see comments in InitUnits below } +{X+}procedure FinitUnitsHard; +{X+}var +{X+} Count: Integer; +{X+} Table: PUnitEntryTable; +{X+} P: Pointer; +{X+}begin +{X+} if InitContext.InitTable = nil then +{X+} exit; +{X+} Count := InitContext.InitCount; +{X+} Table := InitContext.InitTable^.UnitInfo; +{X+}{$IFDEF LINUX} +{X+} Inc(Cardinal(Table), InitContext.Module^.GOT); +{X+}{$ENDIF} +{X+} try +{X+} while Count > 0 do +{X+} begin +{X+} Dec(Count); +{X+} InitContext.InitCount := Count; +{X+} P := Table^[Count].FInit; +{X+} if Assigned(P) then +{X+}{$IFDEF LINUX} +{X+} CallProc(P, InitContext.Module^.GOT); +{X+}{$ENDIF} +{X+}{$IFDEF MSWINDOWS} +{X+} TProc(P)(); +{X+}{$ENDIF} +{X+} end; +{X+} except +{X+} {X- rename: FInitUnits; { try to finalize the others } +{X+} FInitUnitsHard; +{X+} raise; +{X+} end; +{X+}end; + + +procedure InitUnits; +var + Count, I: Integer; + Table: PUnitEntryTable; +{X-}// P: Pointer; +begin + if InitContext.InitTable = nil then + exit; + Count := InitContext.InitTable^.UnitCount; + I := 0; + Table := InitContext.InitTable^.UnitInfo; +{$IFDEF LINUX} + Inc(Cardinal(Table), InitContext.Module^.GOT); +{$ENDIF} +{X+}//********************************************************************** +{X+}// by default, Delphi InitUnits uses try-except & raise constructions, +{X+}// which leads to permanent use of all exception handler routines. +{X+}// Let us make this by another way. +{X+}//********************************************************************** +{X-}// try +{X-}// while I < Count do +{X-}// begin +{X-}// P := Table^[I].Init; +{X-}// Inc(I); +{X-}// InitContext.InitCount := I; +{X-}// if Assigned(P) then +{X-}// begin +{X-}//{$IFDEF LINUX} +{X-}// CallProc(P, InitContext.Module^.GOT); +{X-}//{$ENDIF} +{X-}//{$IFDEF MSWINDOWS} +{X-}// TProc(P)(); +{X-}//{$ENDIF} +{X-}// end; +{X-}// end; +{X-}// except +{X-}// FinalizeUnits; +{X-}// raise; +{X-}// end; +{X-}// +{X+} InitUnitsProc( Table, I, Count ); + +end; + +procedure _PackageLoad(const Table : PackageInfo; Module: PLibModule); +var + SavedContext: TInitContext; +begin + SavedContext := InitContext; + InitContext.DLLInitState := 0; + InitContext.InitTable := Table; + InitContext.InitCount := 0; + InitContext.Module := Module; + InitContext.OuterContext := @SavedContext; + try + InitUnits; + finally + InitContext := SavedContext; + end; +end; + + +procedure _PackageUnload(const Table : PackageInfo; Module: PLibModule); +var + SavedContext: TInitContext; +begin + SavedContext := InitContext; + InitContext.DLLInitState := 0; + InitContext.InitTable := Table; + InitContext.InitCount := Table^.UnitCount; + InitContext.Module := Module; + InitContext.OuterContext := @SavedContext; + try +{X-}// FinalizeUnits; +{X+} FinitUnitsProc; + finally + InitContext := SavedContext; + end; +end; + +{$IFDEF LINUX} +procedure _StartExe(InitTable: PackageInfo; Module: PLibModule; Argc: Integer; Argv: Pointer); +begin + ArgCount := Argc; + ArgValues := Argv; +{$ENDIF} +{$IFDEF MSWINDOWS} +procedure _StartExe(InitTable: PackageInfo; Module: PLibModule); +begin + RaiseExceptionProc := @RaiseException; + RTLUnwindProc := @RTLUnwind; +{$ENDIF} + InitContext.InitTable := InitTable; + InitContext.InitCount := 0; + InitContext.Module := Module; + MainInstance := Module.Instance; +{$IFNDEF PC_MAPPED_EXCEPTIONS} +{X-}// SetExceptionHandler; - moved to SysSfIni.pas } +{$ENDIF} + IsLibrary := False; + InitUnits; +end; + +{$IFDEF MSWINDOWS} +procedure _StartLib; +asm + { -> EAX InitTable } + { EDX Module } + { ECX InitTLS } + { [ESP+4] DllProc } + { [EBP+8] HInst } + { [EBP+12] Reason } + + { Push some desperately needed registers } + + PUSH ECX + PUSH ESI + PUSH EDI + + { Save the current init context into the stackframe of our caller } + + MOV ESI,offset InitContext + LEA EDI,[EBP- (type TExcFrame) - (type TInitContext)] + MOV ECX,(type TInitContext)/4 + REP MOVSD + + { Setup the current InitContext } + + POP InitContext.DLLSaveEDI + POP InitContext.DLLSaveESI + MOV InitContext.DLLSaveEBP,EBP + MOV InitContext.DLLSaveEBX,EBX + MOV InitContext.InitTable,EAX + MOV InitContext.Module,EDX + LEA ECX,[EBP- (type TExcFrame) - (type TInitContext)] + MOV InitContext.OuterContext,ECX + XOR ECX,ECX + CMP DWORD PTR [EBP+12],0 + JNE @@notShutDown + MOV ECX,[EAX].PackageInfoTable.UnitCount +@@notShutDown: + MOV InitContext.InitCount,ECX + + MOV EAX, offset RaiseException + MOV RaiseExceptionProc, EAX + MOV EAX, offset RTLUnwind + MOV RTLUnwindProc, EAX + + CALL SetExceptionHandler + + MOV EAX,[EBP+12] + INC EAX + MOV InitContext.DLLInitState,AL + DEC EAX + + { Init any needed TLS } + + POP ECX + MOV EDX,[ECX] + MOV InitContext.ExitProcessTLS,EDX + JE @@skipTLSproc + CMP AL,3 // DLL_THREAD_DETACH + JGE @@skipTLSproc // call ExitThreadTLS proc after DLLProc + CALL dword ptr [ECX+EAX*4] +@@skipTLSproc: + + { Call any DllProc } + + PUSH ECX + MOV ECX,[ESP+8] + TEST ECX,ECX + JE @@noDllProc + MOV EAX,[EBP+12] + MOV EDX,[EBP+16] + CALL ECX +@@noDllProc: + + POP ECX + MOV EAX, [EBP+12] + CMP AL,3 // DLL_THREAD_DETACH + JL @@afterDLLproc // don't free TLS on process shutdown + CALL dword ptr [ECX+EAX*4] + +@@afterDLLProc: + + { Set IsLibrary if there was no exe yet } + + CMP MainInstance,0 + JNE @@haveExe + MOV IsLibrary,1 + FNSTCW Default8087CW // save host exe's FPU preferences + +@@haveExe: + + MOV EAX,[EBP+12] + DEC EAX + JNE _Halt0 + CALL InitUnits + RET 4 +end; +{$ENDIF MSWINDOWS} +{$IFDEF LINUX} +procedure _StartLib(Context: PInitContext; Module: PLibModule; DLLProc: TDLLProcEx); +var + TempSwap: TInitContext; +begin + // Context's register save fields are already initialized. + // Save the current InitContext and activate the new Context by swapping them + TempSwap := InitContext; + InitContext := PInitContext(Context)^; + PInitContext(Context)^ := TempSwap; + + InitContext.Module := Module; + InitContext.OuterContext := Context; + + // DLLInitState is initialized by SysInit to 0 for shutdown, 1 for startup + // Inc DLLInitState to distinguish from package init: + // 0 for package, 1 for DLL shutdown, 2 for DLL startup + + Inc(InitContext.DLLInitState); + + if InitContext.DLLInitState = 1 then + begin + InitContext.InitTable := Module.InitTable; + if Assigned(InitContext.InitTable) then + InitContext.InitCount := InitContext.InitTable.UnitCount // shutdown + end + else + begin + Module.InitTable := InitContext.InitTable; // save for shutdown + InitContext.InitCount := 0; // startup + end; + + if Assigned(DLLProc) then + DLLProc(InitContext.DLLInitState-1,0); + + if MainInstance = 0 then { Set IsLibrary if there was no exe yet } + begin + IsLibrary := True; + Default8087CW := Get8087CW; + end; + + if InitContext.DLLInitState = 1 then + _Halt0 + else + InitUnits; +end; +{$ENDIF} + +procedure _InitResStrings; +asm + { -> EAX Pointer to init table } + { record } + { cnt: Integer; } + { tab: array [1..cnt] record } + { variableAddress: Pointer; } + { resStringAddress: Pointer; } + { end; } + { end; } + { EBX = caller's GOT for PIC callers, 0 for non-PIC } + +{$IFDEF MSWINDOWS} + PUSH EBX + XOR EBX,EBX +{$ENDIF} + PUSH EDI + PUSH ESI + MOV EDI,[EBX+EAX] + LEA ESI,[EBX+EAX+4] +@@loop: + MOV EAX,[ESI+4] { load resStringAddress } + MOV EDX,[ESI] { load variableAddress } + ADD EAX,EBX + ADD EDX,EBX + CALL LoadResString + ADD ESI,8 + DEC EDI + JNZ @@loop + + POP ESI + POP EDI +{$IFDEF MSWINDOWS} + POP EBX +{$ENDIF} +end; + +procedure _InitResStringImports; +asm + { -> EAX Pointer to init table } + { record } + { cnt: Integer; } + { tab: array [1..cnt] record } + { variableAddress: Pointer; } + { resStringAddress: ^Pointer; } + { end; } + { end; } + { EBX = caller's GOT for PIC callers, 0 for non-PIC } + +{$IFDEF MSWINDOWS} + PUSH EBX + XOR EBX,EBX +{$ENDIF} + PUSH EDI + PUSH ESI + MOV EDI,[EBX+EAX] + LEA ESI,[EBX+EAX+4] +@@loop: + MOV EAX,[ESI+4] { load address of import } + MOV EDX,[ESI] { load address of variable } + MOV EAX,[EBX+EAX] { load contents of import } + ADD EDX,EBX + CALL LoadResString + ADD ESI,8 + DEC EDI + JNZ @@loop + + POP ESI + POP EDI +{$IFDEF MSWINDOWS} + POP EBX +{$ENDIF} +end; + +procedure _InitImports; +asm + { -> EAX Pointer to init table } + { record } + { cnt: Integer; } + { tab: array [1..cnt] record } + { variableAddress: Pointer; } + { sourceAddress: ^Pointer; } + { sourceOffset: Longint; } + { end; } + { end; } + { -> EDX Linux only, this points to } + { SysInit.ModuleIsCpp } + { EBX = caller's GOT for PIC callers, 0 for non-PIC } + +{$IFDEF MSWINDOWS} + PUSH EBX + XOR EBX,EBX +{$ENDIF} + PUSH EDI + PUSH ESI + MOV EDI,[EBX+EAX] + LEA ESI,[EBX+EAX+4] +{$IFDEF LINUX} + { + The C++ linker may have already fixed these things up to valid + addresses. In this case, we don't want to do this pass. If this + module's init tab was linked with ilink, then SysInit.ModuleIsCpp + will be set, and we'll bail out. + } + CMP BYTE PTR[EDX+EBX], 0 { SysInit.ModuleIsCpp } + JNE @@exit +{$ENDIF} +@@loop: + MOV EAX,[ESI+4] { load address of import } + MOV EDX,[ESI] { load address of variable } + MOV EAX,[EBX+EAX] { load contents of import } + ADD EAX,[ESI+8] { calc address of variable } + MOV [EBX+EDX],EAX { store result } + ADD ESI,12 + DEC EDI + JNZ @@loop + +@@exit: + + POP ESI + POP EDI +{$IFDEF MSWINDOWS} + POP EBX +{$ENDIF} +end; + +{$IFDEF MSWINDOWS} +procedure _InitWideStrings; +asm + { -> EAX Pointer to init table } + { record } + { cnt: Integer; } + { tab: array [1..cnt] record } + { variableAddress: Pointer; } + { stringAddress: ^Pointer; } + { end; } + { end; } + + PUSH EBX + PUSH ESI + MOV EBX,[EAX] + LEA ESI,[EAX+4] +@@loop: + MOV EDX,[ESI+4] { load address of string } + MOV EAX,[ESI] { load address of variable } + CALL _WStrAsg + ADD ESI,8 + DEC EBX + JNZ @@loop + + POP ESI + POP EBX +end; +{$ENDIF} + +var + runErrMsg: array[0..29] of Char = 'Runtime error at 00000000'#0; + // columns: 0123456789012345678901234567890 + + +procedure MakeErrorMessage; +const + dig : array [0..15] of Char = '0123456789ABCDEF'; +var + digit: Byte; + Temp: Integer; + Addr: Cardinal; +begin + digit := 16; + Temp := ExitCode; + repeat + runErrMsg[digit] := Char(Ord('0') + (Temp mod 10)); + Temp := Temp div 10; + Dec(digit); + until Temp = 0; + digit := 28; + Addr := Cardinal(ErrorAddr); + repeat + runErrMsg[digit] := dig[Addr and $F]; + Addr := Addr div 16; + Dec(digit); + until Addr = 0; +end; + + +procedure ExitDll; +asm + // Linux: + // Setting ExitCode to non-zero in library initialization to force + // module load failure is not supported in Linux. There is no way to + // communicate failure back to the Linux loader. + // Upon error in library initialization, all initialized units will be + // finalized. Subsequent calls into exported library functions that + // make use of initialized data or RTL routines will fail. + // ExitCode <> zero indicates that the library failed its initialization. + +{$IFDEF MSWINDOWS} + { Return False if ExitCode <> 0, and set ExitCode to 0 } + XOR EAX,EAX + XCHG EAX, ExitCode + NEG EAX + SBB EAX,EAX + INC EAX +{$ENDIF} + + { Restore the InitContext } +{$IFDEF PIC} + LEA EDI, [EBX].InitContext +{$ELSE} + MOV EDI, offset InitContext +{$ENDIF} + + MOV EBX,[EDI].TInitContext.DLLSaveEBX + MOV EBP,[EDI].TInitContext.DLLSaveEBP + PUSH [EDI].TInitContext.DLLSaveESI + PUSH [EDI].TInitContext.DLLSaveEDI + + MOV ESI,[EDI].TInitContext.OuterContext + MOV ECX,(type TInitContext)/4 + REP MOVSD + POP EDI + POP ESI + + LEAVE +{$IFDEF MSWINDOWS} + RET 12 +{$ENDIF} +{$IFDEF LINUX} + RET +{$ENDIF} +end; + +{X+}// Procedure Halt0 refers to WriteLn and MessageBox +{X+}// but actually such code can be not used really. +{X+}// So, implementation changed to avoid such references. +{X+}// +{X+}// Either call UseErrorMessageBox or UseErrorMessageWrite +{X+}// to provide error message output in GUI or console app. +{X+}// +{X+} +{X+}procedure DummyProc; +{X+}begin +{X+}end; +{X+} +{X+}var ErrorMessageOutProc : procedure = DummyProc; +{X+} +{X+}procedure ErrorMessageBox; +{X+}begin +{X+} MakeErrorMessage; +{X+} if not NoErrMsg then +{X+} MessageBox(0, runErrMsg, errCaption, 0); +{X+}end; +{X+} +{X+}procedure UseErrorMessageBox; +{X+}begin +{X+} ErrorMessageOutProc := ErrorMessageBox; +{X+}end; +{X+} +{X+}procedure ErrorMessageWrite; +{X+}begin +{X+} MakeErrorMessage; +{X+} WriteLn(PChar(@runErrMsg)); +{X+}end; +{X+} +{X+}procedure UseErrorMessageWrite; +{X+}begin +{X+} ErrorMessageOutProc := ErrorMessageWrite; +{X+}end; +{X+} +{X+}procedure DoCloseInputOutput; +{X+}begin +{X+} Close( Input ); +{X+} Close( Output ); +{X+} Close(ErrOutput); +{X+}end; +{X+} +{X+}var CloseInputOutput : procedure = DummyProc; +{X+} +{X+}procedure UseInputOutput; +{X+}begin +{X+} if not assigned( CloseInputOutput ) then +{X+} begin +{X+} CloseInputOutput := DoCloseInputOutput; +{X+} //_Assign( Input, '' ); was for D5 so - changed +{X+} //_Assign( Output, '' ); was for D5 so - changed +{X+} TTextRec(Input).Mode := fmClosed; +{X+} TTextRec(Output).Mode := fmClosed; +{X+} TTextRec(ErrOutput).Mode := fmClosed; +{X+} end; +{X+}end; +{X+} + +{X-}//procedure WriteErrorMessage; +{X-}//{$IFDEF MSWINDOWS} +{X-}//var +{X-}// Dummy: Cardinal; +{X-}//begin +{X-}// if IsConsole then +{X-}// begin +{X-}// with TTextRec(Output) do +{X-}// begin +{X-}// if (Mode = fmOutput) and (BufPos > 0) then +{X-}// TTextIOFunc(InOutFunc)(TTextRec(Output)); // flush out text buffer +{X-}// end; +{X-}// WriteFile(GetStdHandle(STD_OUTPUT_HANDLE), runErrMsg, Sizeof(runErrMsg), Dummy, nil); +{X-}// WriteFile(GetStdHandle(STD_OUTPUT_HANDLE), sLineBreak, 2, Dummy, nil); +{X-}// end +{X-}// else if not NoErrMsg then +{X-}// MessageBox(0, runErrMsg, errCaption, 0); +{X-}//{$ENDIF} +{X-}//{$IFDEF LINUX} +{X-}//var +{X-}// c: Char; +{X-}//begin +{X-}// with TTextRec(Output) do +{X-}// begin +{X-}// if (Mode = fmOutput) and (BufPos > 0) then +{X-}// TTextIOFunc(InOutFunc)(TTextRec(Output)); // flush out text buffer +{X-}// end; +{X-}// __write(STDERR_FILENO, @runErrMsg, Sizeof(runErrMsg)-1); +{X-}// c := sLineBreak; +{X-}// __write(STDERR_FILENO, @c, 1); +{X-}//{$ENDIF} +{X-}//end; + +var + RTLInitFailed: Boolean = False; + +procedure _Halt0; +var + P: procedure; +begin +{$IFDEF LINUX} + if (ExitCode <> 0) and CoreDumpEnabled then + __raise(SIGABRT); + + if (InitContext.DLLInitState = 2) and (ExitCode <> 0) then + RTLInitFailed := True; + + if (InitContext.DLLInitState = 1) and RTLInitFailed then + // RTL failed to initialized in library startup. Units have already been + // finalized, don't finalize them again. + ExitDll; +{$ENDIF} + + if InitContext.DLLInitState = 0 then + while ExitProc <> nil do + begin + @P := ExitProc; + ExitProc := nil; + P; + end; + + { If there was some kind of runtime error, alert the user } + + if ErrorAddr <> nil then + begin +{X+} ErrorMessageOutProc; +{X-}// MakeErrorMessage; +{X-}// WriteErrorMessage; +{X-}// ErrorAddr := nil; + end; + + { This loop exists because we might be nested in PackageLoad calls when } + { Halt got called. We need to unwind these contexts. } + + while True do + begin + + { If we are a library, and we are starting up fine, there are no units to finalize } + + if (InitContext.DLLInitState = 2) and (ExitCode = 0) then + InitContext.InitCount := 0; + + { Undo any unit initializations accomplished so far } + +{X-}// FinalizeUnits; +{X+} FinitUnitsProc; + if (InitContext.DLLInitState <= 1) or (ExitCode <> 0) then + begin + if InitContext.Module <> nil then + with InitContext do + begin + UnregisterModule(Module); +{$IFDEF PC_MAPPED_EXCEPTIONS} + SysUnregisterIPLookup(Module.CodeSegStart); +{$ENDIF} + if (Module.ResInstance <> Module.Instance) and (Module.ResInstance <> 0) then + FreeLibrary(Module.ResInstance); + end; + end; + +{$IFNDEF PC_MAPPED_EXCEPTIONS} +{X-}// UnsetExceptionHandler; +{X+} UnsetExceptionHandlerProc; +{$ENDIF} + +{$IFDEF MSWINDOWS} + if InitContext.DllInitState = 1 then + InitContext.ExitProcessTLS; +{$ENDIF} + + if InitContext.DllInitState <> 0 then + ExitDll; + + if InitContext.OuterContext = nil then + begin + { + If an ExitProcessProc is set, we call it. Note that at this + point the RTL is completely shutdown. The only thing this is used + for right now is the proper semantic handling of signals under Linux. + } + if Assigned(ExitProcessProc) then + ExitProcessProc; + ExitProcess(ExitCode); + end; + + InitContext := InitContext.OuterContext^ + end; +end; + +procedure _Halt; +begin + ExitCode := Code; + _Halt0; +end; + + +procedure _Run0Error; +{$IFDEF PUREPASCAL} +begin + _RunError(0); // loses return address +end; +{$ELSE} +asm + XOR EAX,EAX + JMP _RunError +end; +{$ENDIF} + + +procedure _RunError(errorCode: Byte); +{$IFDEF PUREPASCAL} +begin + ErrorAddr := Pointer(-1); // no return address available + Halt(errorCode); +end; +{$ELSE} +asm +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX, EAX + POP EAX + MOV ECX, [EBX].ErrorAddr + POP [ECX] +{$ELSE} + POP ErrorAddr +{$ENDIF} + JMP _Halt +end; +{$ENDIF} + +procedure _UnhandledException; +type TExceptProc = procedure (Obj: TObject; Addr: Pointer); +begin + if Assigned(ExceptProc) then + TExceptProc(ExceptProc)(ExceptObject, ExceptAddr) + else + RunErrorAt(230, ExceptAddr); +end; + +procedure _Assert(const Message, Filename: AnsiString; LineNumber: Integer); +{$IFDEF PUREPASCAL} +begin + if Assigned(AssertErrorProc) then + AssertErrorProc(Message, Filename, LineNumber, Pointer(-1)) + else + Error(reAssertionFailed); // loses return address +end; +{$ELSE} +asm + PUSH EBX +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + MOV EBX, EAX + MOV EAX, [EBX].AssertErrorProc + CMP [EAX], 0 + POP ECX + POP EAX +{$ELSE} + CMP AssertErrorProc,0 +{$ENDIF} + JNZ @@1 + MOV AL,reAssertionFailed + CALL Error + JMP @@exit + +@@1: PUSH [ESP+4].Pointer +{$IFDEF PIC} + MOV EBX, [EBX].AssertErrorProc + CALL [EBX] +{$ELSE} + CALL AssertErrorProc +{$ENDIF} +@@exit: + POP EBX +end; +{$ENDIF} + +type + PThreadRec = ^TThreadRec; + TThreadRec = record + Func: TThreadFunc; + Parameter: Pointer; + end; + +{$IFDEF MSWINDOWS} +function ThreadWrapper(Parameter: Pointer): Integer; stdcall; +{$ELSE} +function ThreadWrapper(Parameter: Pointer): Pointer; cdecl; +{$ENDIF} +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + { Mark the top of the stack with a signature } + PUSH UNWINDFI_TOPOFSTACK +{$ENDIF} + CALL _FpuInit + PUSH EBP +{$IFNDEF PC_MAPPED_EXCEPTIONS} + XOR ECX,ECX + PUSH offset _ExceptionHandler + MOV EDX,FS:[ECX] + PUSH EDX + MOV FS:[ECX],ESP +{$ENDIF} +{$IFDEF PC_MAPPED_EXCEPTIONS} + // The signal handling code in SysUtils depends on being able to + // discriminate between Delphi threads and foreign threads in order + // to choose the disposition of certain signals. It does this by + // testing a TLS index. However, we allocate TLS in a lazy fashion, + // so this test can fail unless we've already allocated the TLS segment. + // So we force the allocation of the TLS index value by touching a TLS + // value here. So don't remove this silly call to AreOSExceptionsBlocked. + CALL AreOSExceptionsBlocked +{$ENDIF} + MOV EAX,Parameter + + MOV ECX,[EAX].TThreadRec.Parameter + MOV EDX,[EAX].TThreadRec.Func + PUSH ECX + PUSH EDX + CALL _FreeMem + POP EDX + POP EAX + CALL EDX + +{$IFNDEF PC_MAPPED_EXCEPTIONS} + XOR EDX,EDX + POP ECX + MOV FS:[EDX],ECX + POP ECX +{$ENDIF} + POP EBP +{$IFDEF PC_MAPPED_EXCEPTIONS} + { Ditch our TOS marker } + ADD ESP, 4 +{$ENDIF} +end; + + +{$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} + +{$IFDEF LINUX} +function BeginThread(Attribute: PThreadAttr; + ThreadFunc: TThreadFunc; + Parameter: Pointer; + var ThreadId: Cardinal): Integer; +var + P: PThreadRec; +begin + if Assigned(BeginThreadProc) then + Result := BeginThreadProc(Attribute, ThreadFunc, Parameter, ThreadId) + else + begin + New(P); + P.Func := ThreadFunc; + P.Parameter := Parameter; + IsMultiThread := True; + Result := _pthread_create(ThreadID, Attribute, @ThreadWrapper, P); + end; +end; + +procedure EndThread(ExitCode: Integer); +begin + if Assigned(EndThreadProc) then + EndThreadProc(ExitCode); + // No "else" required since EndThreadProc does not (!!should not!!) return. + _pthread_detach(GetCurrentThreadID); + _pthread_exit(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); +{$IFDEF PUREPASCAL} +var + P: PStrRec; +begin + if Pointer(S) <> nil then + begin + P := Pointer(Integer(S) - Sizeof(StrRec)); + Pointer(S) := nil; + if P.refCnt > 0 then + if InterlockedDecrement(P.refCnt) = 0 then + FreeMem(P); + end; +end; +{$ELSE} +asm + { -> EAX pointer to str } + + MOV EDX,[EAX] { fetch str } + TEST EDX,EDX { if nil, nothing to do } + JE @@done + MOV dword ptr [EAX],0 { clear str } + MOV ECX,[EDX-skew].StrRec.refCnt { fetch refCnt } + DEC ECX { if < 0: literal str } + JL @@done + LOCK DEC [EDX-skew].StrRec.refCnt { threadsafe dec refCount } + JNE @@done + PUSH EAX + LEA EAX,[EDX-skew].StrRec.refCnt { if refCnt now zero, deallocate} + CALL _FreeMem + POP EAX +@@done: +end; +{$ENDIF} + +procedure _LStrArrayClr(var StrArray; cnt: longint); +{$IFDEF PUREPASCAL} +var + P: Pointer; +begin + P := @StrArray; + while cnt > 0 do + begin + _LStrClr(P^); + Dec(cnt); + Inc(Integer(P), sizeof(Pointer)); + end; +end; +{$ELSE} +asm + { -> EAX pointer to str } + { EDX cnt } + + PUSH EBX + PUSH ESI + MOV EBX,EAX + MOV ESI,EDX + +@@loop: + MOV EDX,[EBX] { fetch str } + TEST EDX,EDX { if nil, nothing to do } + JE @@doneEntry + MOV dword ptr [EBX],0 { clear str } + MOV ECX,[EDX-skew].StrRec.refCnt { fetch refCnt } + DEC ECX { if < 0: literal str } + JL @@doneEntry +{X LOCK} DEC [EDX-skew].StrRec.refCnt { threadsafe dec refCount } + JNE @@doneEntry + LEA EAX,[EDX-skew].StrRec.refCnt { if refCnt now zero, deallocate} + CALL _FreeMem +@@doneEntry: + ADD EBX,4 + DEC ESI + JNE @@loop + + POP ESI + POP EBX +end; +{$ENDIF} + +{ 99.03.11 + This function is used when assigning to global variables. + + Literals are copied to prevent a situation where a dynamically + allocated DLL or package assigns a literal to a variable and then + is unloaded -- thereby causing the string memory (in the code + segment of the DLL) to be removed -- and therefore leaving the + global variable pointing to invalid memory. +} +procedure _LStrAsg(var dest; const source); +{$IFDEF PUREPASCAL} +var + S, D: Pointer; + P: PStrRec; + Temp: Longint; +begin + S := Pointer(source); + if S <> nil then + begin + P := PStrRec(Integer(S) - sizeof(StrRec)); + if P.refCnt < 0 then // make copy of string literal + begin + Temp := P.length; + S := _NewAnsiString(Temp); + Move(Pointer(source)^, S^, Temp); + P := PStrRec(Integer(S) - sizeof(StrRec)); + end; + InterlockedIncrement(P.refCnt); + end; + + D := Pointer(dest); + Pointer(dest) := S; + if D <> nil then + begin + P := PStrRec(Integer(D) - sizeof(StrRec)); + if P.refCnt > 0 then + if InterlockedDecrement(P.refCnt) = 0 then + FreeMem(P); + end; +end; +{$ELSE} +asm + { -> EAX pointer to dest str } + { -> EDX pointer to source str } + + TEST EDX,EDX { have a source? } + JE @@2 { no -> jump } + + MOV ECX,[EDX-skew].StrRec.refCnt + INC ECX + JG @@1 { literal string -> jump not taken } + + PUSH EAX + PUSH EDX + MOV EAX,[EDX-skew].StrRec.length + CALL _NewAnsiString + MOV EDX,EAX + POP EAX + PUSH EDX + MOV ECX,[EAX-skew].StrRec.length + CALL Move + POP EDX + POP EAX + JMP @@2 + +@@1: +{X LOCK }INC [EDX-skew].StrRec.refCnt + +@@2: XCHG EDX,[EAX] + TEST EDX,EDX + JE @@3 + MOV ECX,[EDX-skew].StrRec.refCnt + DEC ECX + JL @@3 +{X LOCK} DEC [EDX-skew].StrRec.refCnt + JNE @@3 + LEA EAX,[EDX-skew].StrRec.refCnt + CALL _FreeMem +@@3: +end; +{$ENDIF} + +procedure _LStrLAsg(var dest; const source); +{$IFDEF PUREPASCAL} +var + P: Pointer; +begin + P := Pointer(source); + _LStrAddRef(P); + P := Pointer(dest); + Pointer(dest) := Pointer(source); + _LStrClr(P); +end; +{$ELSE} +asm +{ -> EAX pointer to dest } +{ EDX source } + + TEST EDX,EDX + JE @@sourceDone + + { bump up the ref count of the source } + + MOV ECX,[EDX-skew].StrRec.refCnt + INC ECX + JLE @@sourceDone { literal assignment -> jump taken } +{X LOCK} INC [EDX-skew].StrRec.refCnt +@@sourceDone: + + { we need to release whatever the dest is pointing to } + + XCHG EDX,[EAX] { fetch str } + TEST EDX,EDX { if nil, nothing to do } + JE @@done + MOV ECX,[EDX-skew].StrRec.refCnt { fetch refCnt } + DEC ECX { if < 0: literal str } + JL @@done +{X LOCK} DEC [EDX-skew].StrRec.refCnt { threadsafe dec refCount } + JNE @@done + LEA EAX,[EDX-skew].StrRec.refCnt { if refCnt now zero, deallocate} + CALL _FreeMem +@@done: +end; +{$ENDIF} + +function _NewAnsiString(length: Longint): Pointer; +{$IFDEF PUREPASCAL} +var + P: PStrRec; +begin + Result := nil; + if length <= 0 then Exit; + // Alloc an extra null for strings with even length. This has no actual cost + // since the allocator will round up the request to an even size anyway. + // All widestring allocations have even length, and need a double null terminator. + GetMem(P, length + sizeof(StrRec) + 1 + ((length + 1) and 1)); + Result := Pointer(Integer(P) + sizeof(StrRec)); + P.length := length; + P.refcnt := 1; + PWideChar(Result)[length div 2] := #0; // length guaranteed >= 2 +end; +{$ELSE} +asm + { -> EAX length } + { <- EAX pointer to new string } + + TEST EAX,EAX + JLE @@null + PUSH EAX + ADD EAX,rOff+2 // one or two nulls (Ansi/Wide) + AND EAX, not 1 // round up to even length + PUSH EAX + CALL _GetMem + POP EDX // actual allocated length (>= 2) + MOV word ptr [EAX+EDX-2],0 // double null terminator + ADD EAX,rOff + POP EDX // requested string length + MOV [EAX-skew].StrRec.length,EDX + MOV [EAX-skew].StrRec.refCnt,1 + RET +@@null: + XOR EAX,EAX +end; +{$ENDIF} + +procedure _LStrFromPCharLen(var Dest: AnsiString; Source: PAnsiChar; Length: Integer); +asm + { -> EAX pointer to dest } + { EDX source } + { ECX length } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + { allocate new string } + + MOV EAX,EDI + + CALL _NewAnsiString + MOV ECX,EDI + MOV EDI,EAX + + TEST ESI,ESI + JE @@noMove + + MOV EDX,EAX + MOV EAX,ESI + CALL Move + + { assign the result to dest } + +@@noMove: + MOV EAX,EBX + CALL _LStrClr + MOV [EBX],EDI + + POP EDI + POP ESI + POP EBX +end; + +{$IFDEF LINUX} +procedure LocaleConversionError; +begin + Error(reCodesetConversion); +end; + +type + TCharacterSizeProc = function(P: Pointer; MaxLen: Integer): Integer; + +function CharacterSizeWideChar(P: Pointer; MaxLen: Integer): Integer; +begin + Result := SizeOf(WideChar); +end; + +function CharacterSizeLocaleChar(P: Pointer; MaxLen: Integer): Integer; +begin + Assert(Assigned(P)); + Result := mblen(P, MaxLen); + if Result <= 0 then + begin + mblen(nil, 0); + Result := SizeOf(Char); + end; +end; + +function BufConvert(var Dest; DestBytes: Integer; + const Source; SrcBytes: Integer; + context: Integer; + DestCharSize: Integer; + SourceCharSize: TCharacterSizeProc): Integer; +const + E2BIG = 7; + EINVAL = 22; + EILSEQ = 84; +const + UnknownCharIndicator = '?'; +var + SrcBytesLeft, DestBytesLeft, Zero: Integer; + s, d, pNil: Pointer; + LastError: Integer; + cs: Integer; +begin + Result := -1; + + // Make copies of parameters. iconv modifies param pointers. + DestBytesLeft := DestBytes; + SrcBytesLeft := SrcBytes; + s := Pointer(Source); + d := Pointer(Dest); + + while True do + begin + Result := iconv(context, s, SrcBytesLeft, d, DestBytesLeft); + if Result <> -1 then + Break + else + begin + LastError := GetLastError; + if (LastError = E2BIG) and (SrcBytesLeft > 0) and (DestBytesLeft > 0) then + Continue; + + if (LastError <> EINVAL) and (LastError <> EILSEQ) then + LocaleConversionError; + pNil := nil; + Zero := 0; + iconv(context, pNil, Zero, pNil, Zero); // Reset state of context + + // Invalid input character in conversion stream. + // Skip input character and write '?' to output stream. + // The glibc iconv() implementation also returns EILSEQ + // for a valid input character that cannot be converted + // into the requested codeset. + cs := SourceCharSize(s, SrcBytesLeft); + Inc(Cardinal(s), cs); + Dec(SrcBytesLeft, cs); + + Assert(DestCharSize in [1, 2]); + case DestCharSize of + 1: + begin + PChar(d)^ := UnknownCharIndicator; + Inc(PChar(d)); + Dec(DestBytesLeft, SizeOf(Char)); + end; + + 2: + begin + PWideChar(d)^ := UnknownCharIndicator; + Inc(PWideChar(d)); + Dec(DestBytesLeft, SizeOf(WideChar)); + end; + end; + end; + end; + + if Result <> -1 then + Result := DestBytes - DestBytesLeft; +end; +{$ENDIF} + +function CharFromWChar(CharDest: PChar; DestBytes: Integer; const WCharSource: PWideChar; SrcChars: Integer): Integer; +{$IFDEF LINUX} +var + IconvContext: Integer; +{$ENDIF} +begin +{$IFDEF LINUX} + if (DestBytes <> 0) and (SrcChars <> 0) then + begin + IconvContext := iconv_open(nl_langinfo(_NL_CTYPE_CODESET_NAME), 'UNICODELITTLE'); + if IconvContext = -1 then + LocaleConversionError; + try + Result := BufConvert(CharDest, DestBytes, WCharSource, SrcChars * SizeOf(WideChar), + IconvContext, 1, CharacterSizeWideChar); + finally + iconv_close(IconvContext); + end; + end + else + Result := 0; +{$ENDIF} +{$IFDEF MSWINDOWS} + Result := WideCharToMultiByte(DefaultUserCodePage, 0, WCharSource, SrcChars, + CharDest, DestBytes, nil, nil); +{$ENDIF} +end; + +function WCharFromChar(WCharDest: PWideChar; DestChars: Integer; const CharSource: PChar; SrcBytes: Integer): Integer; +{$IFDEF LINUX} +var + IconvContext: Integer; +{$ENDIF} +begin +{$IFDEF LINUX} + if (DestChars <> 0) and (SrcBytes <> 0) then + begin + IconvContext := iconv_open('UNICODELITTLE', nl_langinfo(_NL_CTYPE_CODESET_NAME)); + if IconvContext = -1 then + LocaleConversionError; + try + Result := BufConvert(WCharDest, DestChars * SizeOf(WideChar), CharSource, SrcBytes, + IconvContext, 2, CharacterSizeLocaleChar); + finally + iconv_close(IconvContext); + end; + if Result <> -1 then + Result := Result div SizeOf(WideChar); + end + else + Result := 0; +{$ENDIF} +{$IFDEF MSWINDOWS} + Result := MultiByteToWideChar(DefaultUserCodePage, 0, CharSource, SrcBytes, + WCharDest, DestChars); +{$ENDIF} +end; + +procedure _LStrFromPWCharLen(var Dest: AnsiString; Source: PWideChar; Length: Integer); +var + DestLen: Integer; + Buffer: array[0..4095] of Char; +begin + if Length <= 0 then + begin + _LStrClr(Dest); + Exit; + end; + if Length+1 < (High(Buffer) div sizeof(WideChar)) then + begin + DestLen := CharFromWChar(Buffer, High(Buffer), Source, Length); + if DestLen >= 0 then + begin + _LStrFromPCharLen(Dest, Buffer, DestLen); + Exit; + end; + end; + + DestLen := (Length + 1) * sizeof(WideChar); + SetLength(Dest, DestLen); // overallocate, trim later + DestLen := CharFromWChar(Pointer(Dest), DestLen, Source, Length); + if DestLen < 0 then DestLen := 0; + SetLength(Dest, DestLen); +end; + + +procedure _LStrFromChar(var Dest: AnsiString; Source: AnsiChar); +asm + PUSH EDX + MOV EDX,ESP + MOV ECX,1 + CALL _LStrFromPCharLen + POP EDX +end; + + +procedure _LStrFromWChar(var Dest: AnsiString; Source: WideChar); +asm + PUSH EDX + MOV EDX,ESP + MOV ECX,1 + CALL _LStrFromPWCharLen + POP EDX +end; + + +procedure _LStrFromPChar(var Dest: AnsiString; Source: PAnsiChar); +asm + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CL,[EDX+0] + JE @@4 + CMP CL,[EDX+1] + JE @@3 + CMP CL,[EDX+2] + JE @@2 + CMP CL,[EDX+3] + JE @@1 + ADD EDX,4 + JMP @@0 +@@1: INC EDX +@@2: INC EDX +@@3: INC EDX +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX +@@5: JMP _LStrFromPCharLen +end; + + +procedure _LStrFromPWChar(var Dest: AnsiString; Source: PWideChar); +asm + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CX,[EDX+0] + JE @@4 + CMP CX,[EDX+2] + JE @@3 + CMP CX,[EDX+4] + JE @@2 + CMP CX,[EDX+6] + JE @@1 + ADD EDX,8 + JMP @@0 +@@1: ADD EDX,2 +@@2: ADD EDX,2 +@@3: ADD EDX,2 +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX + SHR ECX,1 +@@5: JMP _LStrFromPWCharLen +end; + + +procedure _LStrFromString(var Dest: AnsiString; const Source: ShortString); +asm + XOR ECX,ECX + MOV CL,[EDX] + INC EDX + JMP _LStrFromPCharLen +end; + + +procedure _LStrFromArray(var Dest: AnsiString; Source: PAnsiChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASB + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _LStrFromPCharLen +end; + + +procedure _LStrFromWArray(var Dest: AnsiString; Source: PWideChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASW + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _LStrFromPWCharLen +end; + + +procedure _LStrFromWStr(var Dest: AnsiString; const Source: WideString); +asm + { -> EAX pointer to dest } + { EDX pointer to WideString data } + + XOR ECX,ECX + TEST EDX,EDX + JE @@1 + MOV ECX,[EDX-4] + SHR ECX,1 +@@1: JMP _LStrFromPWCharLen +end; + + +procedure _LStrToString{(var Dest: ShortString; const Source: AnsiString; MaxLen: Integer)}; +asm + { -> EAX pointer to result } + { EDX AnsiString s } + { ECX length of result } + + PUSH EBX + TEST EDX,EDX + JE @@empty + MOV EBX,[EDX-skew].StrRec.length + TEST EBX,EBX + JE @@empty + + CMP ECX,EBX + JL @@truncate + MOV ECX,EBX +@@truncate: + MOV [EAX],CL + INC EAX + + XCHG EAX,EDX + CALL Move + + JMP @@exit + +@@empty: + MOV byte ptr [EAX],0 + +@@exit: + POP EBX +end; + +function _LStrLen(const s: AnsiString): Longint; +{$IFDEF PUREPASCAL} +begin + Result := 0; + if Pointer(s) <> nil then + Result := PStrRec(Integer(s) - sizeof(StrRec)).length; +end; +{$ELSE} +asm + { -> EAX str } + + TEST EAX,EAX + JE @@done + MOV EAX,[EAX-skew].StrRec.length; +@@done: +end; +{$ENDIF} + + +procedure _LStrCat{var dest: AnsiString; source: AnsiString}; +asm + { -> EAX pointer to dest } + { EDX source } + + TEST EDX,EDX + JE @@exit + + MOV ECX,[EAX] + TEST ECX,ECX + JE _LStrAsg + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,[ECX-skew].StrRec.length + + MOV EDX,[ESI-skew].StrRec.length + ADD EDX,EDI + CMP ESI,ECX + JE @@appendSelf + + CALL _LStrSetLength + MOV EAX,ESI + MOV ECX,[ESI-skew].StrRec.length + +@@appendStr: + MOV EDX,[EBX] + ADD EDX,EDI + CALL Move + POP EDI + POP ESI + POP EBX + RET + +@@appendSelf: + CALL _LStrSetLength + MOV EAX,[EBX] + MOV ECX,EDI + JMP @@appendStr + +@@exit: +end; + + +procedure _LStrCat3{var dest:AnsiString; source1: AnsiString; source2: AnsiString}; +asm + { ->EAX = Pointer to dest } + { EDX = source1 } + { ECX = source2 } + + TEST EDX,EDX + JE @@assignSource2 + + TEST ECX,ECX + JE _LStrAsg + + CMP EDX,[EAX] + JE @@appendToDest + + CMP ECX,[EAX] + JE @@theHardWay + + PUSH EAX + PUSH ECX + CALL _LStrAsg + + POP EDX + POP EAX + JMP _LStrCat + +@@theHardWay: + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EDX + MOV ESI,ECX + PUSH EAX + + MOV EAX,[EBX-skew].StrRec.length + ADD EAX,[ESI-skew].StrRec.length + CALL _NewAnsiString + + MOV EDI,EAX + MOV EDX,EAX + MOV EAX,EBX + MOV ECX,[EBX-skew].StrRec.length + CALL Move + + MOV EDX,EDI + MOV EAX,ESI + MOV ECX,[ESI-skew].StrRec.length + ADD EDX,[EBX-skew].StrRec.length + CALL Move + + POP EAX + MOV EDX,EDI + TEST EDI,EDI + JE @@skip + DEC [EDI-skew].StrRec.refCnt // EDI = local temp str +@@skip: + CALL _LStrAsg + + POP EDI + POP ESI + POP EBX + + JMP @@exit + +@@assignSource2: + MOV EDX,ECX + JMP _LStrAsg + +@@appendToDest: + MOV EDX,ECX + JMP _LStrCat + +@@exit: +end; + + +procedure _LStrCatN{var dest:AnsiString; argCnt: Integer; ...}; +asm + { ->EAX = Pointer to dest } + { EDX = number of args (>= 3) } + { [ESP+4], [ESP+8], ... crgCnt AnsiString arguments, reverse order } + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EDX + PUSH EAX + MOV EBX,EDX + + XOR EDI,EDI + MOV ECX,[ESP+EDX*4+5*4] // first arg is furthest out + TEST ECX,ECX + JZ @@0 + CMP [EAX],ECX // is dest = first arg? + JNE @@0 + MOV EDI,ECX // EDI nonzero -> potential appendstr case + MOV EAX,[ECX-skew].StrRec.length + DEC EDX + JMP @@loop1 +@@0: + XOR EAX,EAX +@@loop1: + MOV ECX,[ESP+EDX*4+5*4] + TEST ECX,ECX + JE @@1 + ADD EAX,[ECX-skew].StrRec.length + CMP EDI,ECX // is dest an arg besides arg1? + JNE @@1 + XOR EDI,EDI // can't appendstr - dest is multiple args +@@1: + DEC EDX + JNE @@loop1 + +@@append: + TEST EDI,EDI // dest is 1st and only 1st arg? + JZ @@copy + MOV EDX,EAX // length into EDX + MOV EAX,[ESP] // ptr to str into EAX + MOV ESI,[EDI-skew].StrRec.Length // save old size before realloc + CALL _LStrSetLength + MOV EDI,[ESP] // append other strs to dest + PUSH [EDI] + ADD ESI,[EDI] // ESI = end of old string + DEC EBX + JMP @@loop2 + +@@copy: + CALL _NewAnsiString + PUSH EAX + MOV ESI,EAX + +@@loop2: + MOV EAX,[ESP+EBX*4+6*4] + MOV EDX,ESI + TEST EAX,EAX + JE @@2 + MOV ECX,[EAX-skew].StrRec.length + ADD ESI,ECX + CALL Move +@@2: + DEC EBX + JNE @@loop2 + + POP EDX + POP EAX + TEST EDI,EDI + JNZ @@exit + + TEST EDX,EDX + JE @@skip + DEC [EDX-skew].StrRec.refCnt // EDX = local temp str +@@skip: + CALL _LStrAsg + +@@exit: + POP EDX + POP EDI + POP ESI + POP EBX + POP EAX + LEA ESP,[ESP+EDX*4] + JMP EAX +end; + + +procedure _LStrCmp{left: AnsiString; right: AnsiString}; +asm +{ ->EAX = Pointer to left string } +{ EDX = Pointer to right string } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + CMP EAX,EDX + JE @@exit + + TEST ESI,ESI + JE @@str1null + + TEST EDI,EDI + JE @@str2null + + MOV EAX,[ESI-skew].StrRec.length + MOV EDX,[EDI-skew].StrRec.length + + SUB EAX,EDX { eax = len1 - len2 } + JA @@skip1 + ADD EDX,EAX { edx = len2 + (len1 - len2) = len1 } + +@@skip1: + PUSH EDX + SHR EDX,2 + JE @@cmpRest +@@longLoop: + MOV ECX,[ESI] + MOV EBX,[EDI] + CMP ECX,EBX + JNE @@misMatch + DEC EDX + JE @@cmpRestP4 + MOV ECX,[ESI+4] + MOV EBX,[EDI+4] + CMP ECX,EBX + JNE @@misMatch + ADD ESI,8 + ADD EDI,8 + DEC EDX + JNE @@longLoop + JMP @@cmpRest +@@cmpRestP4: + ADD ESI,4 + ADD EDI,4 +@@cmpRest: + POP EDX + AND EDX,3 + JE @@equal + + MOV ECX,[ESI] + MOV EBX,[EDI] + CMP CL,BL + JNE @@exit + DEC EDX + JE @@equal + CMP CH,BH + JNE @@exit + DEC EDX + JE @@equal + AND EBX,$00FF0000 + AND ECX,$00FF0000 + CMP ECX,EBX + JNE @@exit + +@@equal: + ADD EAX,EAX + JMP @@exit + +@@str1null: + MOV EDX,[EDI-skew].StrRec.length + SUB EAX,EDX + JMP @@exit + +@@str2null: + MOV EAX,[ESI-skew].StrRec.length + SUB EAX,EDX + JMP @@exit + +@@misMatch: + POP EDX + CMP CL,BL + JNE @@exit + CMP CH,BH + JNE @@exit + SHR ECX,16 + SHR EBX,16 + CMP CL,BL + JNE @@exit + CMP CH,BH + +@@exit: + POP EDI + POP ESI + POP EBX + +end; + +function _LStrAddRef(var str): Pointer; +{$IFDEF PUREPASCAL} +var + P: PStrRec; +begin + P := Pointer(Integer(str) - sizeof(StrRec)); + if P <> nil then + if P.refcnt >= 0 then + InterlockedIncrement(P.refcnt); + Result := Pointer(str); +end; +{$ELSE} +asm + { -> EAX str } + TEST EAX,EAX + JE @@exit + MOV EDX,[EAX-skew].StrRec.refCnt + INC EDX + JLE @@exit +{X LOCK} INC [EAX-skew].StrRec.refCnt +@@exit: +end; +{$ENDIF} + +function PICEmptyString: PWideChar; +begin + Result := ''; +end; + +function _LStrToPChar(const s: AnsiString): PChar; +{$IFDEF PUREPASCAL} +const + EmptyString = ''; +begin + if Pointer(s) = nil then + Result := EmptyString + else + Result := Pointer(s); +end; +{$ELSE} +asm + { -> EAX pointer to str } + { <- EAX pointer to PChar } + + TEST EAX,EAX + JE @@handle0 + RET +{$IFDEF PIC} +@@handle0: + JMP PICEmptyString +{$ELSE} +@@zeroByte: + DB 0 +@@handle0: + MOV EAX,offset @@zeroByte +{$ENDIF} +end; +{$ENDIF} + +function InternalUniqueString(var str): Pointer; +asm + { -> EAX pointer to str } + { <- EAX pointer to unique copy } + MOV EDX,[EAX] + TEST EDX,EDX + JE @@exit + MOV ECX,[EDX-skew].StrRec.refCnt + DEC ECX + JE @@exit + + PUSH EBX + MOV EBX,EAX + MOV EAX,[EDX-skew].StrRec.length + CALL _NewAnsiString + MOV EDX,EAX + MOV EAX,[EBX] + MOV [EBX],EDX + PUSH EAX + MOV ECX,[EAX-skew].StrRec.length + CALL Move + POP EAX + MOV ECX,[EAX-skew].StrRec.refCnt + DEC ECX + JL @@skip +{X LOCK} DEC [EAX-skew].StrRec.refCnt + JNZ @@skip + LEA EAX,[EAX-skew].StrRec.refCnt { if refCnt now zero, deallocate} + CALL _FreeMem +@@skip: + MOV EDX,[EBX] + POP EBX +@@exit: + MOV EAX,EDX +end; + + +procedure UniqueString(var str: AnsiString); +asm + JMP InternalUniqueString +end; + +procedure _UniqueStringA(var str: AnsiString); +asm + JMP InternalUniqueString +end; + +procedure UniqueString(var str: WideString); +asm +{$IFDEF LINUX} + JMP InternalUniqueString +{$ENDIF} +{$IFDEF MSWINDOWS} + // nothing to do - Windows WideStrings are always single reference +{$ENDIF} +end; + +procedure _UniqueStringW(var str: WideString); +asm +{$IFDEF LINUX} + JMP InternalUniqueString +{$ENDIF} +{$IFDEF MSWINDOWS} + // nothing to do - Windows WideStrings are always single reference +{$ENDIF} +end; + +procedure _LStrCopy{ const s : AnsiString; index, count : Integer) : AnsiString}; +asm + { ->EAX Source string } + { EDX index } + { ECX count } + { [ESP+4] Pointer to result string } + + PUSH EBX + + TEST EAX,EAX + JE @@srcEmpty + + MOV EBX,[EAX-skew].StrRec.length + TEST EBX,EBX + JE @@srcEmpty + +{ make index 0-based and limit to 0 <= index < Length(src) } + + DEC EDX + JL @@smallInx + CMP EDX,EBX + JGE @@bigInx + +@@cont1: + +{ limit count to satisfy 0 <= count <= Length(src) - index } + + SUB EBX,EDX { calculate Length(src) - index } + TEST ECX,ECX + JL @@smallCount + CMP ECX,EBX + JG @@bigCount + +@@cont2: + + ADD EDX,EAX + MOV EAX,[ESP+4+4] + CALL _LStrFromPCharLen + JMP @@exit + +@@smallInx: + XOR EDX,EDX + JMP @@cont1 +@@bigCount: + MOV ECX,EBX + JMP @@cont2 +@@bigInx: +@@smallCount: +@@srcEmpty: + MOV EAX,[ESP+4+4] + CALL _LStrClr +@@exit: + POP EBX + RET 4 +end; + + +procedure _LStrDelete{ var s : AnsiString; index, count : Integer }; +asm + { ->EAX Pointer to s } + { EDX index } + { ECX count } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + CALL UniqueString + + MOV EDX,[EBX] + TEST EDX,EDX { source already empty: nothing to do } + JE @@exit + + MOV ECX,[EDX-skew].StrRec.length + +{ make index 0-based, if not in [0 .. Length(s)-1] do nothing } + + DEC ESI + JL @@exit + CMP ESI,ECX + JGE @@exit + +{ limit count to [0 .. Length(s) - index] } + + TEST EDI,EDI + JLE @@exit + SUB ECX,ESI { ECX = Length(s) - index } + CMP EDI,ECX + JLE @@1 + MOV EDI,ECX +@@1: + +{ move length - index - count characters from s+index+count to s+index } + + SUB ECX,EDI { ECX = Length(s) - index - count } + ADD EDX,ESI { EDX = s+index } + LEA EAX,[EDX+EDI] { EAX = s+index+count } + CALL Move + +{ set length(s) to length(s) - count } + + MOV EDX,[EBX] + MOV EAX,EBX + MOV EDX,[EDX-skew].StrRec.length + SUB EDX,EDI + CALL _LStrSetLength + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +procedure _LStrInsert{ const source : AnsiString; var s : AnsiString; index : Integer }; +asm + { -> EAX source string } + { EDX pointer to destination string } + { ECX index } + + TEST EAX,EAX + JE @@nothingToDo + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + +{ make index 0-based and limit to 0 <= index <= Length(s) } + + MOV EDX,[EDX] + PUSH EDX + TEST EDX,EDX + JE @@sIsNull + MOV EDX,[EDX-skew].StrRec.length +@@sIsNull: + DEC EDI + JGE @@indexNotLow + XOR EDI,EDI +@@indexNotLow: + CMP EDI,EDX + JLE @@indexNotHigh + MOV EDI,EDX +@@indexNotHigh: + + MOV EBP,[EBX-skew].StrRec.length + +{ set length of result to length(source) + length(s) } + + MOV EAX,ESI + ADD EDX,EBP + CALL _LStrSetLength + POP EAX + + CMP EAX,EBX + JNE @@notInsertSelf + MOV EBX,[ESI] + +@@notInsertSelf: + +{ move length(s) - length(source) - index chars from s+index to s+index+length(source) } + + MOV EAX,[ESI] { EAX = s } + LEA EDX,[EDI+EBP] { EDX = index + length(source) } + MOV ECX,[EAX-skew].StrRec.length + SUB ECX,EDX { ECX = length(s) - length(source) - index } + ADD EDX,EAX { EDX = s + index + length(source) } + ADD EAX,EDI { EAX = s + index } + CALL Move + +{ copy length(source) chars from source to s+index } + + MOV EAX,EBX + MOV EDX,[ESI] + MOV ECX,EBP + ADD EDX,EDI + CALL Move + +@@exit: + POP EBP + POP EDI + POP ESI + POP EBX +@@nothingToDo: +end; + + +procedure _LStrPos{ const substr : AnsiString; const s : AnsiString ) : Integer}; +asm +{ ->EAX Pointer to substr } +{ EDX Pointer to string } +{ <-EAX Position of substr in s or 0 } + + TEST EAX,EAX + JE @@noWork + + TEST EDX,EDX + JE @@stringEmpty + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX { Point ESI to substr } + MOV EDI,EDX { Point EDI to s } + + MOV ECX,[EDI-skew].StrRec.length { ECX = Length(s) } + + PUSH EDI { remember s position to calculate index } + + MOV EDX,[ESI-skew].StrRec.length { EDX = Length(substr) } + + DEC EDX { EDX = Length(substr) - 1 } + JS @@fail { < 0 ? return 0 } + MOV AL,[ESI] { AL = first char of substr } + INC ESI { Point ESI to 2'nd char of substr } + + SUB ECX,EDX { #positions in s to look at } + { = Length(s) - Length(substr) + 1 } + JLE @@fail +@@loop: + REPNE SCASB + JNE @@fail + MOV EBX,ECX { save outer loop counter } + PUSH ESI { save outer loop substr pointer } + PUSH EDI { save outer loop s pointer } + + MOV ECX,EDX + REPE CMPSB + POP EDI { restore outer loop s pointer } + POP ESI { restore outer loop substr pointer } + JE @@found + MOV ECX,EBX { restore outer loop counter } + JMP @@loop + +@@fail: + POP EDX { get rid of saved s pointer } + XOR EAX,EAX + JMP @@exit + +@@stringEmpty: + XOR EAX,EAX + JMP @@noWork + +@@found: + POP EDX { restore pointer to first char of s } + MOV EAX,EDI { EDI points of char after match } + SUB EAX,EDX { the difference is the correct index } +@@exit: + POP EDI + POP ESI + POP EBX +@@noWork: +end; + + +procedure _LStrSetLength{ var str: AnsiString; newLength: Integer}; +asm + { -> EAX Pointer to str } + { EDX new length } + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV ESI,EDX + XOR EDI,EDI + + TEST EDX,EDX + JLE @@setString + + MOV EAX,[EBX] + TEST EAX,EAX + JE @@copyString + + CMP [EAX-skew].StrRec.refCnt,1 + JNE @@copyString + + SUB EAX,rOff + ADD EDX,rOff+1 + PUSH EAX + MOV EAX,ESP + CALL _ReallocMem + POP EAX + ADD EAX,rOff + MOV [EBX],EAX + MOV [EAX-skew].StrRec.length,ESI + MOV BYTE PTR [EAX+ESI],0 + JMP @@exit + +@@copyString: + MOV EAX,EDX + CALL _NewAnsiString + MOV EDI,EAX + + MOV EAX,[EBX] + TEST EAX,EAX + JE @@setString + + MOV EDX,EDI + MOV ECX,[EAX-skew].StrRec.length + CMP ECX,ESI + JL @@moveString + MOV ECX,ESI + +@@moveString: + CALL Move + +@@setString: + MOV EAX,EBX + CALL _LStrClr + MOV [EBX],EDI + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +procedure _LStrOfChar{ c: Char; count: Integer): AnsiString }; +asm + { -> AL c } + { EDX count } + { ECX result } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + MOV EAX,ECX + CALL _LStrClr + + TEST ESI,ESI + JLE @@exit + + MOV EAX,ESI + CALL _NewAnsiString + + MOV [EDI],EAX + + MOV EDX,ESI + MOV CL,BL + + CALL _FillChar + +@@exit: + POP EDI + POP ESI + POP EBX + +end; + + +function _Write0LString(var t: TTextRec; const s: AnsiString): Pointer; +begin + Result := _WriteLString(t, s, 0); +end; + + +function _WriteLString(var t: TTextRec; const s: AnsiString; width: Longint): Pointer; +{$IFDEF PUREPASCAL} +var + i: Integer; +begin + i := Length(s); + _WriteSpaces(t, width - i); + Result := _WriteBytes(t, s[1], i); +end; +{$ELSE} +asm + { -> EAX Pointer to text record } + { EDX Pointer to AnsiString } + { ECX Field width } + + PUSH EBX + + MOV EBX,EDX + + MOV EDX,ECX + XOR ECX,ECX + TEST EBX,EBX + JE @@skip + MOV ECX,[EBX-skew].StrRec.length + SUB EDX,ECX +@@skip: + PUSH ECX + CALL _WriteSpaces + POP ECX + + MOV EDX,EBX + POP EBX + JMP _WriteBytes +end; +{$ENDIF} + + +function _Write0WString(var t: TTextRec; const s: WideString): Pointer; +begin + Result := _WriteWString(t, s, 0); +end; + + +function _WriteWString(var t: TTextRec; const s: WideString; width: Longint): Pointer; +var + i: Integer; +begin + i := Length(s); + _WriteSpaces(t, width - i); + Result := _WriteLString(t, AnsiString(s), 0); +end; + + +function _Write0WCString(var t: TTextRec; s: PWideChar): Pointer; +begin + Result := _WriteWCString(t, s, 0); +end; + + +function _WriteWCString(var t: TTextRec; s: PWideChar; width: Longint): Pointer; +var + i: Integer; +begin + i := 0; + if (s <> nil) then + while s[i] <> #0 do + Inc(i); + + _WriteSpaces(t, width - i); + Result := _WriteLString(t, AnsiString(s), 0); +end; + + +function _Write0WChar(var t: TTextRec; c: WideChar): Pointer; +begin + Result := _WriteWChar(t, c, 0); +end; + + +function _WriteWChar(var t: TTextRec; c: WideChar; width: Integer): Pointer; +begin + _WriteSpaces(t, width - 1); + Result := _WriteLString(t, AnsiString(c), 0); +end; + +function _WriteVariant(var T: TTextRec; const V: TVarData; Width: Integer): Pointer; +var + S: AnsiString; +begin + if Assigned(VarToLStrProc) then + begin + VarToLStrProc(S, V); + _WriteLString(T, S, Width); + end + else + Error(reVarInvalidOp); + Result := @T; +end; + +function _Write0Variant(var T: TTextRec; const V: TVarData): Pointer; +begin + Result := _WriteVariant(T, V, 0); +end; + +{$IFDEF MSWINDOWS} +procedure WStrError; +asm + MOV AL,reOutOfMemory + JMP Error +end; +{$ENDIF} + +function _NewWideString(CharLength: Longint): Pointer; +{$IFDEF LINUX} +begin + Result := _NewAnsiString(CharLength*2); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + TEST EAX,EAX + JE @@1 + PUSH EAX + PUSH 0 + CALL SysAllocStringLen + TEST EAX,EAX + JE WStrError +@@1: +end; +{$ENDIF} + +procedure WStrSet(var S: WideString; P: PWideChar); +{$IFDEF PUREPASCAL} +var + Temp: Pointer; +begin + Temp := Pointer(InterlockedExchange(Pointer(S), Pointer(P))); + if Temp <> nil then + _WStrClr(Temp); +end; +{$ELSE} +asm +{$IFDEF LINUX} + XCHG [EAX],EDX + TEST EDX,EDX + JZ @@1 + PUSH EDX + MOV EAX, ESP + CALL _WStrClr + POP EAX +{$ENDIF} +{$IFDEF MSWINDOWS} + XCHG [EAX],EDX + TEST EDX,EDX + JZ @@1 + PUSH EDX + CALL SysFreeString +{$ENDIF} +@@1: +end; +{$ENDIF} + +{X+}procedure WStrClr; +{X+}asm +{X+} JMP _WStrClr +{X+}end; + +procedure _WStrClr(var S); +{$IFDEF LINUX} +asm + JMP _LStrClr; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + { -> EAX Pointer to WideString } + + MOV EDX,[EAX] + TEST EDX,EDX + JE @@1 + MOV DWORD PTR [EAX],0 + PUSH EAX + PUSH EDX + CALL SysFreeString + POP EAX +@@1: +end; +{$ENDIF} + +{X+}procedure WStrArrayClr; +{X+}asm +{X+} JMP _WStrArrayClr; +{X+}end; + + +procedure _WStrArrayClr(var StrArray; Count: Integer); +{$IFDEF LINUX} +asm + JMP _LStrArrayClr +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + PUSH EBX + PUSH ESI + MOV EBX,EAX + MOV ESI,EDX +@@1: MOV EAX,[EBX] + TEST EAX,EAX + JE @@2 + MOV DWORD PTR [EBX],0 + PUSH EAX + CALL SysFreeString +@@2: ADD EBX,4 + DEC ESI + JNE @@1 + POP ESI + POP EBX +end; +{$ENDIF} + + +procedure _WStrAsg(var Dest: WideString; const Source: WideString); +{$IFDEF LINUX} +asm + JMP _LStrAsg +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + { -> EAX Pointer to WideString } + { EDX Pointer to data } + TEST EDX,EDX + JE _WStrClr + MOV ECX,[EDX-4] + SHR ECX,1 + JE _WStrClr + PUSH ECX + PUSH EDX + PUSH EAX + CALL SysReAllocStringLen + TEST EAX,EAX + JE WStrError +end; +{$ENDIF} + +procedure _WStrLAsg(var Dest: WideString; const Source: WideString); +{$IFDEF LINUX} +asm + JMP _LStrLAsg +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + JMP _WStrAsg +end; +{$ENDIF} + +procedure _WStrFromPCharLen(var Dest: WideString; Source: PAnsiChar; Length: Integer); +var + DestLen: Integer; + Buffer: array[0..2047] of WideChar; +begin + if Length <= 0 then + begin + _WStrClr(Dest); + Exit; + end; + if Length+1 < High(Buffer) then + begin + DestLen := WCharFromChar(Buffer, High(Buffer), Source, Length); + if DestLen > 0 then + begin + _WStrFromPWCharLen(Dest, @Buffer, DestLen); + Exit; + end; + end; + + DestLen := (Length + 1); + _WStrSetLength(Dest, DestLen); // overallocate, trim later + DestLen := WCharFromChar(Pointer(Dest), DestLen, Source, Length); + if DestLen < 0 then DestLen := 0; + _WStrSetLength(Dest, DestLen); +end; + +procedure _WStrFromPWCharLen(var Dest: WideString; Source: PWideChar; CharLength: Integer); +{$IFDEF LINUX} +var + Temp: Pointer; +begin + Temp := Pointer(Dest); + if CharLength > 0 then + begin + Pointer(Dest) := _NewWideString(CharLength); + if Source <> nil then + Move(Source^, Pointer(Dest)^, CharLength * sizeof(WideChar)); + end + else + Pointer(Dest) := nil; + _WStrClr(Temp); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + { -> EAX Pointer to WideString (dest) } + { EDX Pointer to characters (source) } + { ECX number of characters (not bytes) } + TEST ECX,ECX + JE _WStrClr + + PUSH EAX + + PUSH ECX + PUSH EDX + CALL SysAllocStringLen + TEST EAX,EAX + JE WStrError + + POP EDX + PUSH [EDX].PWideChar + MOV [EDX],EAX + + CALL SysFreeString +end; +{$ENDIF} + + +procedure _WStrFromChar(var Dest: WideString; Source: AnsiChar); +asm + PUSH EDX + MOV EDX,ESP + MOV ECX,1 + CALL _WStrFromPCharLen + POP EDX +end; + + +procedure _WStrFromWChar(var Dest: WideString; Source: WideChar); +asm + { -> EAX Pointer to WideString (dest) } + { EDX character (source) } + PUSH EDX + MOV EDX,ESP + MOV ECX,1 + CALL _WStrFromPWCharLen + POP EDX +end; + + +procedure _WStrFromPChar(var Dest: WideString; Source: PAnsiChar); +asm + { -> EAX Pointer to WideString (dest) } + { EDX Pointer to character (source) } + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CL,[EDX+0] + JE @@4 + CMP CL,[EDX+1] + JE @@3 + CMP CL,[EDX+2] + JE @@2 + CMP CL,[EDX+3] + JE @@1 + ADD EDX,4 + JMP @@0 +@@1: INC EDX +@@2: INC EDX +@@3: INC EDX +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX +@@5: JMP _WStrFromPCharLen +end; + + +procedure _WStrFromPWChar(var Dest: WideString; Source: PWideChar); +asm + { -> EAX Pointer to WideString (dest) } + { EDX Pointer to character (source) } + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CX,[EDX+0] + JE @@4 + CMP CX,[EDX+2] + JE @@3 + CMP CX,[EDX+4] + JE @@2 + CMP CX,[EDX+6] + JE @@1 + ADD EDX,8 + JMP @@0 +@@1: ADD EDX,2 +@@2: ADD EDX,2 +@@3: ADD EDX,2 +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX + SHR ECX,1 +@@5: JMP _WStrFromPWCharLen +end; + + +procedure _WStrFromString(var Dest: WideString; const Source: ShortString); +asm + XOR ECX,ECX + MOV CL,[EDX] + INC EDX + JMP _WStrFromPCharLen +end; + + +procedure _WStrFromArray(var Dest: WideString; Source: PAnsiChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASB + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _WStrFromPCharLen +end; + + +procedure _WStrFromWArray(var Dest: WideString; Source: PWideChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASW + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _WStrFromPWCharLen +end; + + +procedure _WStrFromLStr(var Dest: WideString; const Source: AnsiString); +asm + XOR ECX,ECX + TEST EDX,EDX + JE @@1 + MOV ECX,[EDX-4] +@@1: JMP _WStrFromPCharLen +end; + + +procedure _WStrToString(Dest: PShortString; const Source: WideString; MaxLen: Integer); +var + SourceLen, DestLen: Integer; + Buffer: array[0..511] of Char; +begin + if MaxLen > 255 then MaxLen := 255; + SourceLen := Length(Source); + if SourceLen >= MaxLen then SourceLen := MaxLen; + if SourceLen = 0 then + DestLen := 0 + else + begin + DestLen := CharFromWChar(Buffer, High(Buffer), PWideChar(Pointer(Source)), SourceLen); + if DestLen < 0 then + DestLen := 0 + else if DestLen > MaxLen then + DestLen := MaxLen; + end; + Dest^[0] := Chr(DestLen); + if DestLen > 0 then Move(Buffer, Dest^[1], DestLen); +end; + +function _WStrToPWChar(const S: WideString): PWideChar; +{$IFDEF PUREPASCAL} +const + EmptyString = ''; +begin + if Pointer(S) = nil then + Result := EmptyString + else + Result := Pointer(S); +end; +{$ELSE} +asm + TEST EAX,EAX + JE @@1 + RET +{$IFDEF PIC} +@@1: JMP PICEmptyString +{$ELSE} + NOP +@@0: DW 0 +@@1: MOV EAX,OFFSET @@0 +{$ENDIF} +end; +{$ENDIF} + + +function _WStrLen(const S: WideString): Integer; +{$IFDEF PUREPASCAL} +begin + if Pointer(S) = nil then + Result := 0 + else + Result := PInteger(Integer(S) - 4)^ div sizeof(WideChar); +end; +{$ELSE} +asm + { -> EAX Pointer to WideString data } + TEST EAX,EAX + JE @@1 + MOV EAX,[EAX-4] + SHR EAX,1 +@@1: +end; +{$ENDIF} + +procedure _WStrCat(var Dest: WideString; const Source: WideString); +var + DestLen, SourceLen: Integer; + NewStr: PWideChar; +begin + SourceLen := Length(Source); + if SourceLen <> 0 then + begin + DestLen := Length(Dest); + NewStr := _NewWideString(DestLen + SourceLen); + if DestLen > 0 then + Move(Pointer(Dest)^, NewStr^, DestLen * sizeof(WideChar)); + Move(Pointer(Source)^, NewStr[DestLen], SourceLen * sizeof(WideChar)); + WStrSet(Dest, NewStr); + end; +end; + + +procedure _WStrCat3(var Dest: WideString; const Source1, Source2: WideString); +var + Source1Len, Source2Len: Integer; + NewStr: PWideChar; +begin + Source1Len := Length(Source1); + Source2Len := Length(Source2); + if (Source1Len <> 0) or (Source2Len <> 0) then + begin + NewStr := _NewWideString(Source1Len + Source2Len); + Move(Pointer(Source1)^, Pointer(NewStr)^, Source1Len * sizeof(WideChar)); + Move(Pointer(Source2)^, NewStr[Source1Len], Source2Len * sizeof(WideChar)); + WStrSet(Dest, NewStr); + end; +end; + + +procedure _WStrCatN{var Dest: WideString; ArgCnt: Integer; ...}; +asm + { ->EAX = Pointer to dest } + { EDX = number of args (>= 3) } + { [ESP+4], [ESP+8], ... crgCnt WideString arguments } + + PUSH EBX + PUSH ESI + PUSH EDX + PUSH EAX + MOV EBX,EDX + + XOR EAX,EAX +@@loop1: + MOV ECX,[ESP+EDX*4+4*4] + TEST ECX,ECX + JE @@1 + ADD EAX,[ECX-4] +@@1: + DEC EDX + JNE @@loop1 + + SHR EAX,1 + CALL _NewWideString + PUSH EAX + MOV ESI,EAX + +@@loop2: + MOV EAX,[ESP+EBX*4+5*4] + MOV EDX,ESI + TEST EAX,EAX + JE @@2 + MOV ECX,[EAX-4] + ADD ESI,ECX + CALL Move +@@2: + DEC EBX + JNE @@loop2 + + POP EDX + POP EAX + CALL WStrSet + + POP EDX + POP ESI + POP EBX + POP EAX + LEA ESP,[ESP+EDX*4] + JMP EAX +end; + +procedure _WStrCmp{left: WideString; right: WideString}; +asm +{ ->EAX = Pointer to left string } +{ EDX = Pointer to right string } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + CMP EAX,EDX + JE @@exit + + TEST ESI,ESI + JE @@str1null + + TEST EDI,EDI + JE @@str2null + + MOV EAX,[ESI-4] + MOV EDX,[EDI-4] + + SUB EAX,EDX { eax = len1 - len2 } + JA @@skip1 + ADD EDX,EAX { edx = len2 + (len1 - len2) = len1 } + +@@skip1: + PUSH EDX + SHR EDX,2 + JE @@cmpRest +@@longLoop: + MOV ECX,[ESI] + MOV EBX,[EDI] + CMP ECX,EBX + JNE @@misMatch + DEC EDX + JE @@cmpRestP4 + MOV ECX,[ESI+4] + MOV EBX,[EDI+4] + CMP ECX,EBX + JNE @@misMatch + ADD ESI,8 + ADD EDI,8 + DEC EDX + JNE @@longLoop + JMP @@cmpRest +@@cmpRestP4: + ADD ESI,4 + ADD EDI,4 +@@cmpRest: + POP EDX + AND EDX,2 + JE @@equal + + MOV CX,[ESI] + MOV BX,[EDI] + CMP CX,BX + JNE @@exit + +@@equal: + ADD EAX,EAX + JMP @@exit + +@@str1null: + MOV EDX,[EDI-4] + SUB EAX,EDX + JMP @@exit + +@@str2null: + MOV EAX,[ESI-4] + SUB EAX,EDX + JMP @@exit + +@@misMatch: + POP EDX + CMP CX,BX + JNE @@exit + SHR ECX,16 + SHR EBX,16 + CMP CX,BX + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +function _WStrCopy(const S: WideString; Index, Count: Integer): WideString; +var + L, N: Integer; +begin + L := Length(S); + if Index < 1 then Index := 0 else + begin + Dec(Index); + if Index > L then Index := L; + end; + if Count < 0 then N := 0 else + begin + N := L - Index; + if N > Count then N := Count; + end; + _WStrFromPWCharLen(Result, PWideChar(Pointer(S)) + Index, N); +end; + + +procedure _WStrDelete(var S: WideString; Index, Count: Integer); +var + L, N: Integer; + NewStr: PWideChar; +begin + L := Length(S); + if (L > 0) and (Index >= 1) and (Index <= L) and (Count > 0) then + begin + Dec(Index); + N := L - Index - Count; + if N < 0 then N := 0; + if (Index = 0) and (N = 0) then NewStr := nil else + begin + NewStr := _NewWideString(Index + N); + if Index > 0 then + Move(Pointer(S)^, NewStr^, Index * 2); + if N > 0 then + Move(PWideChar(Pointer(S))[L - N], NewStr[Index], N * 2); + end; + WStrSet(S, NewStr); + end; +end; + + +procedure _WStrInsert(const Source: WideString; var Dest: WideString; Index: Integer); +var + SourceLen, DestLen: Integer; + NewStr: PWideChar; +begin + SourceLen := Length(Source); + if SourceLen > 0 then + begin + DestLen := Length(Dest); + if Index < 1 then Index := 0 else + begin + Dec(Index); + if Index > DestLen then Index := DestLen; + end; + NewStr := _NewWideString(DestLen + SourceLen); + if Index > 0 then + Move(Pointer(Dest)^, NewStr^, Index * 2); + Move(Pointer(Source)^, NewStr[Index], SourceLen * 2); + if Index < DestLen then + Move(PWideChar(Pointer(Dest))[Index], NewStr[Index + SourceLen], + (DestLen - Index) * 2); + WStrSet(Dest, NewStr); + end; +end; + + +procedure _WStrPos{ const substr : WideString; const s : WideString ) : Integer}; +asm +{ ->EAX Pointer to substr } +{ EDX Pointer to string } +{ <-EAX Position of substr in s or 0 } + + TEST EAX,EAX + JE @@noWork + + TEST EDX,EDX + JE @@stringEmpty + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX { Point ESI to substr } + MOV EDI,EDX { Point EDI to s } + + MOV ECX,[EDI-4] { ECX = Length(s) } + SHR ECX,1 + + PUSH EDI { remember s position to calculate index } + + MOV EDX,[ESI-4] { EDX = Length(substr) } + SHR EDX,1 + + DEC EDX { EDX = Length(substr) - 1 } + JS @@fail { < 0 ? return 0 } + MOV AX,[ESI] { AL = first char of substr } + ADD ESI,2 { Point ESI to 2'nd char of substr } + + SUB ECX,EDX { #positions in s to look at } + { = Length(s) - Length(substr) + 1 } + JLE @@fail +@@loop: + REPNE SCASW + JNE @@fail + MOV EBX,ECX { save outer loop counter } + PUSH ESI { save outer loop substr pointer } + PUSH EDI { save outer loop s pointer } + + MOV ECX,EDX + REPE CMPSW + POP EDI { restore outer loop s pointer } + POP ESI { restore outer loop substr pointer } + JE @@found + MOV ECX,EBX { restore outer loop counter } + JMP @@loop + +@@fail: + POP EDX { get rid of saved s pointer } + XOR EAX,EAX + JMP @@exit + +@@stringEmpty: + XOR EAX,EAX + JMP @@noWork + +@@found: + POP EDX { restore pointer to first char of s } + MOV EAX,EDI { EDI points of char after match } + SUB EAX,EDX { the difference is the correct index } + SHR EAX,1 +@@exit: + POP EDI + POP ESI + POP EBX +@@noWork: +end; + + +procedure _WStrSetLength(var S: WideString; NewLength: Integer); +var + NewStr: PWideChar; + Count: Integer; +begin + NewStr := nil; + if NewLength > 0 then + begin + NewStr := _NewWideString(NewLength); + Count := Length(S); + if Count > 0 then + begin + if Count > NewLength then Count := NewLength; + Move(Pointer(S)^, NewStr^, Count * 2); + end; + end; + WStrSet(S, NewStr); +end; + + +function _WStrOfWChar(Ch: WideChar; Count: Integer): WideString; +var + P: PWideChar; +begin + _WStrFromPWCharLen(Result, nil, Count); + P := Pointer(Result); + while Count > 0 do + begin + Dec(Count); + P[Count] := Ch; + end; +end; + +{X+}procedure WStrAddRef; +{X+}asm +{X+} JMP _WStrAddRef +{X+}end; + +function _WStrAddRef(var str: WideString): Pointer; +{$IFDEF LINUX} +asm + JMP _LStrAddRef +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + MOV EDX,[EAX] + TEST EDX,EDX + JE @@1 + PUSH EAX + MOV ECX,[EDX-4] + SHR ECX,1 + PUSH ECX + PUSH EDX + CALL SysAllocStringLen + POP EDX + TEST EAX,EAX + JE WStrError + MOV [EDX],EAX +@@1: +end; +{$ENDIF} + +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); +{$IFDEF PUREPASCAL} +var + FT: PFieldTable; + I: Cardinal; +begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + for I := FT.Count-1 downto 0 do + _InitializeArray(Pointer(Cardinal(P) + FT.Fields[I].Offset), FT.Fields[I].TypeInfo^, 1); +end; +{$ELSE} +asm + { -> EAX pointer to record to be initialized } + { EDX pointer to type info } + + XOR ECX,ECX + + PUSH EBX + MOV CL,[EDX+1] { type name length } + + PUSH ESI + PUSH EDI + + MOV EBX,EAX // PIC safe. See comment above + LEA ESI,[EDX+ECX+2+8] { address of destructable fields } + MOV EDI,[EDX+ECX+2+4] { number of destructable fields } + +@@loop: + + MOV EDX,[ESI] + MOV EAX,[ESI+4] + ADD EAX,EBX + MOV EDX,[EDX] + MOV ECX,1 + CALL _InitializeArray + ADD ESI,8 + DEC EDI + JG @@loop + + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + + +const + tkLString = 10; + tkWString = 11; + tkVariant = 12; + tkArray = 13; + tkRecord = 14; + tkInterface = 15; + tkDynArray = 17; + +procedure _InitializeArray(p: Pointer; typeInfo: Pointer; elemCount: Cardinal); +{$IFDEF PUREPASCAL} +var + FT: PFieldTable; +begin + if elemCount = 0 then Exit; + case PTypeInfo(typeInfo).Kind of + tkLString, tkWString, tkInterface, tkDynArray: + while elemCount > 0 do + begin + PInteger(P)^ := 0; + Inc(Integer(P), 4); + Dec(elemCount); + end; + tkVariant: + while elemCount > 0 do + begin + PInteger(P)^ := 0; + PInteger(Integer(P)+4)^ := 0; + PInteger(Integer(P)+8)^ := 0; + PInteger(Integer(P)+12)^ := 0; + Inc(Integer(P), sizeof(Variant)); + Dec(elemCount); + end; + tkArray: + begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + while elemCount > 0 do + begin + _InitializeArray(P, FT.Fields[0].TypeInfo^, FT.Count); + Inc(Integer(P), FT.Size); + Dec(elemCount); + end; + end; + tkRecord: + begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + while elemCount > 0 do + begin + _InitializeRecord(P, typeInfo); + Inc(Integer(P), FT.Size); + Dec(elemCount); + end; + end; + else + Error(reInvalidPtr); + end; +end; +{$ELSE} +asm + { -> EAX pointer to data to be initialized } + { EDX pointer to type info describing data } + { ECX number of elements of that type } + + TEST ECX, ECX + JZ @@zerolength + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX // PIC safe. See comment above + MOV ESI,EDX + MOV EDI,ECX + + XOR EDX,EDX + MOV AL,[ESI] + MOV DL,[ESI+1] + XOR ECX,ECX + + CMP AL,tkLString + JE @@LString + CMP AL,tkWString + JE @@WString + CMP AL,tkVariant + JE @@Variant + CMP AL,tkArray + JE @@Array + CMP AL,tkRecord + JE @@Record + CMP AL,tkInterface + JE @@Interface + CMP AL,tkDynArray + JE @@DynArray + MOV AL,reInvalidPtr + POP EDI + POP ESI + POP EBX + JMP Error + +@@LString: +@@WString: +@@Interface: +@@DynArray: + MOV [EBX],ECX + ADD EBX,4 + DEC EDI + JG @@LString + JMP @@exit + +@@Variant: + MOV [EBX ],ECX + MOV [EBX+ 4],ECX + MOV [EBX+ 8],ECX + MOV [EBX+12],ECX + ADD EBX,16 + DEC EDI + JG @@Variant + JMP @@exit + +@@Array: + PUSH EBP + MOV EBP,EDX +@@ArrayLoop: + MOV EDX,[ESI+EBP+2+8] // address of destructable fields typeinfo + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] // size in bytes of the array data + MOV ECX,[ESI+EBP+2+4] // number of destructable fields + MOV EDX,[EDX] + CALL _InitializeArray + DEC EDI + JG @@ArrayLoop + POP EBP + JMP @@exit + +@@Record: + PUSH EBP + MOV EBP,EDX +@@RecordLoop: + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV EDX,ESI + CALL _InitializeRecord + DEC EDI + JG @@RecordLoop + POP EBP + +@@exit: + + POP EDI + POP ESI + POP EBX +@@zerolength: +end; +{$ENDIF} + +procedure _Initialize(p: Pointer; typeInfo: Pointer); +{$IFDEF PUREPASCAL} +begin + _InitializeArray(p, typeInfo, 1); +end; +{$ELSE} +asm + MOV ECX,1 + JMP _InitializeArray +end; +{$ENDIF} + +procedure _FinalizeRecord(p: Pointer; typeInfo: Pointer); +{$IFDEF PUREPASCAL} +var + FT: PFieldTable; + I: Cardinal; +begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + for I := 0 to FT.Count-1 do + _FinalizeArray(Pointer(Cardinal(P) + FT.Fields[I].Offset), FT.Fields[I].TypeInfo^, 1); +end; +{$ELSE} +asm + { -> EAX pointer to record to be finalized } + { EDX pointer to type info } + + XOR ECX,ECX + + PUSH EBX + MOV CL,[EDX+1] + + PUSH ESI + PUSH EDI + + MOV EBX,EAX + LEA ESI,[EDX+ECX+2+8] + MOV EDI,[EDX+ECX+2+4] + +@@loop: + + MOV EDX,[ESI] + MOV EAX,[ESI+4] + ADD EAX,EBX + MOV EDX,[EDX] + MOV ECX,1 + CALL _FinalizeArray + ADD ESI,8 + DEC EDI + JG @@loop + + MOV EAX,EBX + + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +procedure _VarClr(var v: TVarData); +begin + if Assigned(VarClearProc) then + VarClearProc(v) + else + Error(reVarInvalidOp); +end; + +procedure _FinalizeArray(p: Pointer; typeInfo: Pointer; elemCount: Cardinal); +{$IFDEF PUREPASCAL} +var + FT: PFieldTable; +begin + if elemCount = 0 then Exit; + case PTypeInfo(typeInfo).Kind of + tkLString: _LStrArrayClr(P^, elemCount); +{X-}// tkWString: _WStrArrayClr(P^, elemCount); +{X+}tkWString: WStrArrayClrProc(P^, elemCount); + tkVariant: + while elemCount > 0 do + begin +{X-}// _VarClr(PVarData(P)^); +{X+} VarClrProc(PVarData(P)^); + Inc(Integer(P), sizeof(Variant)); + Dec(elemCount); + end; + tkArray: + begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + while elemCount > 0 do + begin + _FinalizeArray(P, FT.Fields[0].TypeInfo^, FT.Count); + Inc(Integer(P), FT.Size); + Dec(elemCount); + end; + end; + tkRecord: + begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + while elemCount > 0 do + begin + _FinalizeRecord(P, typeInfo); + Inc(Integer(P), FT.Size); + Dec(elemCount); + end; + end; + tkInterface: + while elemCount > 0 do + begin + _IntfClear(IInterface(P^)); + Inc(Integer(P), 4); + Dec(elemCount); + end; + tkDynArray: + while elemCount > 0 do + begin + _DynArrayClr(P); + Inc(Integer(P), 4); + Dec(elemCount); + end; + else + Error(reInvalidPtr); + end; +end; +{$ELSE} +asm + { -> EAX pointer to data to be finalized } + { EDX pointer to type info describing data } + { ECX number of elements of that type } + + { This code appears to be PIC safe. The functions called from + here either don't make external calls or call Pascal + routines that will fix up EBX in their prolog code + (FreeMem, VarClr, IntfClr). } + + CMP ECX, 0 { no array -> nop } + JE @@zerolength + + PUSH EAX + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + XOR EDX,EDX + MOV AL,[ESI] + MOV DL,[ESI+1] + + CMP AL,tkLString + JE @@LString + + CMP AL,tkWString + JE @@WString + + CMP AL,tkVariant + JE @@Variant + + CMP AL,tkArray + JE @@Array + + CMP AL,tkRecord + JE @@Record + + CMP AL,tkInterface + JE @@Interface + + CMP AL,tkDynArray + JE @@DynArray + + JMP @@error + +@@LString: + CMP ECX,1 + MOV EAX,EBX + JG @@LStringArray + CALL _LStrClr + JMP @@exit +@@LStringArray: + MOV EDX,ECX + CALL _LStrArrayClr + JMP @@exit + +@@WString: + CMP ECX,1 + MOV EAX,EBX + JG @@WStringArray +{X-}// CALL _WStrClr +{X+} CALL [WStrClrProc] + JMP @@exit +@@WStringArray: + MOV EDX,ECX +{X-}// CALL _WStrArrayClr +{X+} CALL [WStrArrayClrProc] + JMP @@exit +@@Variant: + MOV EAX,EBX + ADD EBX,16 + CALL _VarClr + DEC EDI + JG @@Variant + JMP @@exit +@@Array: + PUSH EBP + MOV EBP,EDX +@@ArrayLoop: + MOV EDX,[ESI+EBP+2+8] + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV ECX,[ESI+EBP+2+4] + MOV EDX,[EDX] + CALL _FinalizeArray + DEC EDI + JG @@ArrayLoop + POP EBP + JMP @@exit + +@@Record: + PUSH EBP + MOV EBP,EDX +@@RecordLoop: + { inv: EDI = number of array elements to finalize } + + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV EDX,ESI + CALL _FinalizeRecord + DEC EDI + JG @@RecordLoop + POP EBP + JMP @@exit + +@@Interface: + MOV EAX,EBX + ADD EBX,4 + CALL _IntfClear + DEC EDI + JG @@Interface + JMP @@exit + +@@DynArray: + MOV EAX,EBX + MOV EDX,ESI + ADD EBX,4 + CALL _DynArrayClear + DEC EDI + JG @@DynArray + JMP @@exit + +@@error: + POP EDI + POP ESI + POP EBX + POP EAX + MOV AL,reInvalidPtr + JMP Error + +@@exit: + POP EDI + POP ESI + POP EBX + POP EAX +@@zerolength: +end; +{$ENDIF} + +procedure _Finalize(p: Pointer; typeInfo: Pointer); +{$IFDEF PUREPASCAL} +begin + _FinalizeArray(p, typeInfo, 1); +end; +{$ELSE} +asm + MOV ECX,1 + JMP _FinalizeArray +end; +{$ENDIF} + +procedure _AddRefRecord{ p: Pointer; typeInfo: Pointer }; +asm + { -> EAX pointer to record to be referenced } + { EDX pointer to type info } + + XOR ECX,ECX + + PUSH EBX + MOV CL,[EDX+1] + + PUSH ESI + PUSH EDI + + MOV EBX,EAX + LEA ESI,[EDX+ECX+2+8] + MOV EDI,[EDX+ECX+2+4] + +@@loop: + + MOV EDX,[ESI] + MOV EAX,[ESI+4] + ADD EAX,EBX + MOV EDX,[EDX] + MOV ECX, 1 + CALL _AddRefArray + ADD ESI,8 + DEC EDI + JG @@loop + + POP EDI + POP ESI + POP EBX +end; + +procedure _VarAddRef(var v: TVarData); +begin + if Assigned(VarAddRefProc) then + VarAddRefProc(v) + else + Error(reVarInvalidOp); +end; + +procedure _AddRefArray{ p: Pointer; typeInfo: Pointer; elemCount: Longint}; +asm + { -> EAX pointer to data to be referenced } + { EDX pointer to type info describing data } + { ECX number of elements of that type } + + { This code appears to be PIC safe. The functions called from + here either don't make external calls (LStrAddRef, WStrAddRef) or + are Pascal routines that will fix up EBX in their prolog code + (VarAddRef, IntfAddRef). } + + PUSH EBX + PUSH ESI + PUSH EDI + + TEST ECX,ECX + JZ @@exit + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + XOR EDX,EDX + MOV AL,[ESI] + MOV DL,[ESI+1] + + CMP AL,tkLString + JE @@LString + CMP AL,tkWString + JE @@WString + CMP AL,tkVariant + JE @@Variant + CMP AL,tkArray + JE @@Array + CMP AL,tkRecord + JE @@Record + CMP AL,tkInterface + JE @@Interface + CMP AL,tkDynArray + JE @@DynArray + MOV AL,reInvalidPtr + POP EDI + POP ESI + POP EBX + JMP Error + +@@LString: +{$IFDEF LINUX} +@@WString: +{$ENDIF} + MOV EAX,[EBX] + ADD EBX,4 + CALL _LStrAddRef + DEC EDI + JG @@LString + JMP @@exit + +{$IFDEF MSWINDOWS} +@@WString: + MOV EAX,EBX + ADD EBX,4 +{X-}// CALL _WStrAddRef +{X+} CALL [WStrAddRefProc] + DEC EDI + JG @@WString + JMP @@exit +{$ENDIF} +@@Variant: + MOV EAX,EBX + ADD EBX,16 + CALL _VarAddRef + DEC EDI + JG @@Variant + JMP @@exit + +@@Array: + PUSH EBP + MOV EBP,EDX +@@ArrayLoop: + MOV EDX,[ESI+EBP+2+8] + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV ECX,[ESI+EBP+2+4] + MOV EDX,[EDX] + CALL _AddRefArray + DEC EDI + JG @@ArrayLoop + POP EBP + JMP @@exit + +@@Record: + PUSH EBP + MOV EBP,EDX +@@RecordLoop: + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV EDX,ESI + CALL _AddRefRecord + DEC EDI + JG @@RecordLoop + POP EBP + JMP @@exit + +@@Interface: + MOV EAX,[EBX] + ADD EBX,4 + CALL _IntfAddRef + DEC EDI + JG @@Interface + JMP @@exit + +@@DynArray: + MOV EAX,[EBX] + ADD EBX,4 + CALL _DynArrayAddRef + DEC EDI + JG @@DynArray +@@exit: + + POP EDI + POP ESI + POP EBX +end; + + +procedure _AddRef{ p: Pointer; typeInfo: Pointer}; +asm + MOV ECX,1 + JMP _AddRefArray +end; + +procedure _VarCopy(var Dest: TVarData; const Src: TVarData); +begin + if Assigned(VarCopyProc) then + VarCopyProc(Dest, Src) + else + Error(reVarInvalidOp); +end; + +procedure _CopyRecord{ dest, source, typeInfo: Pointer }; +asm + { -> EAX pointer to dest } + { EDX pointer to source } + { ECX pointer to typeInfo } + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBX,EAX + MOV ESI,EDX + + XOR EAX,EAX + MOV AL,[ECX+1] + + LEA EDI,[ECX+EAX+2+8] + MOV EBP,[EDI-4] + XOR EAX,EAX + MOV ECX,[EDI-8] + PUSH ECX +@@loop: + MOV ECX,[EDI+4] + SUB ECX,EAX + JLE @@nomove1 + MOV EDX,EAX + ADD EAX,ESI + ADD EDX,EBX + CALL Move +@@noMove1: + MOV EAX,[EDI+4] + + MOV EDX,[EDI] + MOV EDX,[EDX] + MOV CL,[EDX] + + CMP CL,tkLString + JE @@LString + CMP CL,tkWString + JE @@WString + CMP CL,tkVariant + JE @@Variant + CMP CL,tkArray + JE @@Array + CMP CL,tkRecord + JE @@Record + CMP CL,tkInterface + JE @@Interface + CMP CL,tkDynArray + JE @@DynArray + MOV AL,reInvalidPtr + POP EBP + POP EDI + POP ESI + POP EBX + JMP Error + +@@LString: + MOV EDX,[ESI+EAX] + ADD EAX,EBX + CALL _LStrAsg + MOV EAX,4 + JMP @@common + +@@WString: + MOV EDX,[ESI+EAX] + ADD EAX,EBX + CALL _WStrAsg + MOV EAX,4 + JMP @@common + +@@Variant: + LEA EDX,[ESI+EAX] + ADD EAX,EBX + CALL _VarCopy + MOV EAX,16 + JMP @@common + +@@Array: + XOR ECX,ECX + MOV CL,[EDX+1] + PUSH dword ptr [EDX+ECX+2] + PUSH dword ptr [EDX+ECX+2+4] + MOV ECX,[EDX+ECX+2+8] + MOV ECX,[ECX] + LEA EDX,[ESI+EAX] + ADD EAX,EBX + CALL _CopyArray + POP EAX + JMP @@common + +@@Record: + XOR ECX,ECX + MOV CL,[EDX+1] + MOV ECX,[EDX+ECX+2] + PUSH ECX + MOV ECX,EDX + LEA EDX,[ESI+EAX] + ADD EAX,EBX + CALL _CopyRecord + POP EAX + JMP @@common + +@@Interface: + MOV EDX,[ESI+EAX] + ADD EAX,EBX + CALL _IntfCopy + MOV EAX,4 + JMP @@common + +@@DynArray: + MOV ECX,EDX + MOV EDX,[ESI+EAX] + ADD EAX,EBX + CALL _DynArrayAsg + MOV EAX,4 + +@@common: + ADD EAX,[EDI+4] + ADD EDI,8 + DEC EBP + JNZ @@loop + + POP ECX + SUB ECX,EAX + JLE @@noMove2 + LEA EDX,[EBX+EAX] + ADD EAX,ESI + CALL Move +@@noMove2: + + POP EBP + POP EDI + POP ESI + POP EBX +end; + + +procedure _CopyObject{ dest, source: Pointer; vmtPtrOffs: Longint; typeInfo: Pointer }; +asm + { -> EAX pointer to dest } + { EDX pointer to source } + { ECX offset of vmt in object } + { [ESP+4] pointer to typeInfo } + + ADD ECX,EAX { pointer to dest vmt } + PUSH dword ptr [ECX] { save dest vmt } + PUSH ECX + MOV ECX,[ESP+4+4+4] + CALL _CopyRecord + POP ECX + POP dword ptr [ECX] { restore dest vmt } + RET 4 + +end; + +procedure _CopyArray{ dest, source, typeInfo: Pointer; cnt: Integer }; +asm + { -> EAX pointer to dest } + { EDX pointer to source } + { ECX pointer to typeInfo } + { [ESP+4] count } + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + MOV EBP,[ESP+4+4*4] + + MOV CL,[EDI] + + CMP CL,tkLString + JE @@LString + CMP CL,tkWString + JE @@WString + CMP CL,tkVariant + JE @@Variant + CMP CL,tkArray + JE @@Array + CMP CL,tkRecord + JE @@Record + CMP CL,tkInterface + JE @@Interface + CMP CL,tkDynArray + JE @@DynArray + MOV AL,reInvalidPtr + POP EBP + POP EDI + POP ESI + POP EBX + JMP Error + +@@LString: + MOV EAX,EBX + MOV EDX,[ESI] + CALL _LStrAsg + ADD EBX,4 + ADD ESI,4 + DEC EBP + JNE @@LString + JMP @@exit + +@@WString: + MOV EAX,EBX + MOV EDX,[ESI] + CALL _WStrAsg + ADD EBX,4 + ADD ESI,4 + DEC EBP + JNE @@WString + JMP @@exit + +@@Variant: + MOV EAX,EBX + MOV EDX,ESI + CALL _VarCopy + ADD EBX,16 + ADD ESI,16 + DEC EBP + JNE @@Variant + JMP @@exit + +@@Array: + XOR ECX,ECX + MOV CL,[EDI+1] + LEA EDI,[EDI+ECX+2] +@@ArrayLoop: + MOV EAX,EBX + MOV EDX,ESI + MOV ECX,[EDI+8] + PUSH dword ptr [EDI+4] + CALL _CopyArray + ADD EBX,[EDI] + ADD ESI,[EDI] + DEC EBP + JNE @@ArrayLoop + JMP @@exit + +@@Record: + MOV EAX,EBX + MOV EDX,ESI + MOV ECX,EDI + CALL _CopyRecord + XOR EAX,EAX + MOV AL,[EDI+1] + ADD EBX,[EDI+EAX+2] + ADD ESI,[EDI+EAX+2] + DEC EBP + JNE @@Record + JMP @@exit + +@@Interface: + MOV EAX,EBX + MOV EDX,[ESI] + CALL _IntfCopy + ADD EBX,4 + ADD ESI,4 + DEC EBP + JNE @@Interface + JMP @@exit + +@@DynArray: + MOV EAX,EBX + MOV EDX,[ESI] + MOV ECX,EDI + CALL _DynArrayAsg + ADD EBX,4 + ADD ESI,4 + DEC EBP + JNE @@DynArray + +@@exit: + POP EBP + POP EDI + POP ESI + POP EBX + RET 4 +end; + + +function _New(size: Longint; typeInfo: Pointer): Pointer; +{$IFDEF PUREPASCAL} +begin + GetMem(Result, size); + if Result <> nil then + _Initialize(Result, typeInfo); +end; +{$ELSE} +asm + { -> EAX size of object to allocate } + { EDX pointer to typeInfo } + + PUSH EDX + CALL _GetMem + POP EDX + TEST EAX,EAX + JE @@exit + PUSH EAX + CALL _Initialize + POP EAX +@@exit: +end; +{$ENDIF} + +procedure _Dispose(p: Pointer; typeInfo: Pointer); +{$IFDEF PUREPASCAL} +begin + _Finalize(p, typeinfo); + FreeMem(p); +end; +{$ELSE} +asm + { -> EAX Pointer to object to be disposed } + { EDX Pointer to type info } + + PUSH EAX + CALL _Finalize + POP EAX + CALL _FreeMem +end; +{$ENDIF} + +{ ----------------------------------------------------- } +{ Wide character support } +{ ----------------------------------------------------- } + +function WideCharToString(Source: PWideChar): string; +begin + WideCharToStrVar(Source, Result); +end; + +function WideCharLenToString(Source: PWideChar; SourceLen: Integer): string; +begin + WideCharLenToStrVar(Source, SourceLen, Result); +end; + +procedure WideCharToStrVar(Source: PWideChar; var Dest: string); +begin + _LStrFromPWChar(Dest, Source); +end; + +procedure WideCharLenToStrVar(Source: PWideChar; SourceLen: Integer; + var Dest: string); +begin + _LStrFromPWCharLen(Dest, Source, SourceLen); +end; + +function StringToWideChar(const Source: string; Dest: PWideChar; + DestSize: Integer): PWideChar; +begin + Dest[WCharFromChar(Dest, DestSize - 1, PChar(Source), Length(Source))] := #0; + Result := Dest; +end; + +{ ----------------------------------------------------- } +{ OLE string support } +{ ----------------------------------------------------- } + +function OleStrToString(Source: PWideChar): string; +begin + OleStrToStrVar(Source, Result); +end; + +procedure OleStrToStrVar(Source: PWideChar; var Dest: string); +begin + WideCharLenToStrVar(Source, Length(WideString(Pointer(Source))), Dest); +end; + +function StringToOleStr(const Source: string): PWideChar; +begin + Result := nil; + _WStrFromPCharLen(WideString(Pointer(Result)), PChar(Pointer(Source)), Length(Source)); +end; + +{ ----------------------------------------------------- } +{ Variant manager support (obsolete) } +{ ----------------------------------------------------- } + +procedure GetVariantManager(var VarMgr: TVariantManager); +begin + FillChar(VarMgr, sizeof(VarMgr), 0); +end; + +procedure SetVariantManager(const VarMgr: TVariantManager); +begin +end; + +function IsVariantManagerSet: Boolean; +begin + Result := False; +end; + +procedure _IntfDispCall; +asm +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + POP ECX + LEA EAX,[EAX].OFFSET DispCallByIDProc + MOV EAX,[EAX] + XCHG EAX,[ESP] + RET +{$ELSE} + JMP DispCallByIDProc +{$ENDIF} +end; + +procedure _DispCallByIDError; +asm + MOV AL,reVarDispatch + JMP Error +end; + +procedure _IntfVarCall; +asm +end; + +// 64 bit integer helper routines +// +// These functions always return the 64-bit result in EAX:EDX + +// ------------------------------------------------------------------------------ +// 64-bit signed multiply +// ------------------------------------------------------------------------------ +// +// Param 1(EAX:EDX), Param 2([ESP+8]:[ESP+4]) ; before reg pushing +// + +procedure __llmul; +asm + push edx + push eax + + // Param2 : [ESP+16]:[ESP+12] (hi:lo) + // Param1 : [ESP+4]:[ESP] (hi:lo) + + mov eax, [esp+16] + mul dword ptr [esp] + mov ecx, eax + + mov eax, [esp+4] + mul dword ptr [esp+12] + add ecx, eax + + mov eax, [esp] + mul dword ptr [esp+12] + add edx, ecx + + pop ecx + pop ecx + + ret 8 +end; + +// ------------------------------------------------------------------------------ +// 64-bit signed multiply, with overflow check (98.05.15: overflow not supported yet) +// ------------------------------------------------------------------------------ +// +// Param1 ~= U (Uh, Ul) +// Param2 ~= V (Vh, Vl) +// +// Param 1(EAX:EDX), Param 2([ESP+8]:[ESP+4]) ; before reg pushing +// +// compiler-helper function +// O-flag set on exit => result is invalid +// O-flag clear on exit => result is valid + +procedure __llmulo; +asm + push edx + push eax + + // Param2 : [ESP+16]:[ESP+12] (hi:lo) + // Param1 : [ESP+4]:[ESP] (hi:lo) + + mov eax, [esp+16] + mul dword ptr [esp] + mov ecx, eax + + mov eax, [esp+4] + mul dword ptr [esp+12] + add ecx, eax + + mov eax, [esp] + mul dword ptr [esp+12] + add edx, ecx + + pop ecx + pop ecx + + ret 8 +end; + +// ------------------------------------------------------------------------------ +// 64-bit signed division +// ------------------------------------------------------------------------------ + +// +// Dividend = Numerator, Divisor = Denominator +// +// Dividend(EAX:EDX), Divisor([ESP+8]:[ESP+4]) ; before reg pushing +// +// + +procedure __lldiv; +asm + push ebp + push ebx + push esi + push edi + xor edi,edi + + mov ebx,20[esp] // get the divisor low dword + mov ecx,24[esp] // get the divisor high dword + + or ecx,ecx + jnz @__lldiv@slow_ldiv // both high words are zero + + or edx,edx + jz @__lldiv@quick_ldiv + + or ebx,ebx + jz @__lldiv@quick_ldiv // if ecx:ebx == 0 force a zero divide + // we don't expect this to actually + // work + +@__lldiv@slow_ldiv: + +// +// Signed division should be done. Convert negative +// values to positive and do an unsigned division. +// Store the sign value in the next higher bit of +// di (test mask of 4). Thus when we are done, testing +// that bit will determine the sign of the result. +// + or edx,edx // test sign of dividend + jns @__lldiv@onepos + neg edx + neg eax + sbb edx,0 // negate dividend + or edi,1 + +@__lldiv@onepos: + or ecx,ecx // test sign of divisor + jns @__lldiv@positive + neg ecx + neg ebx + sbb ecx,0 // negate divisor + xor edi,1 + +@__lldiv@positive: + mov ebp,ecx + mov ecx,64 // shift counter + push edi // save the flags +// +// Now the stack looks something like this: +// +// 24[esp]: divisor (high dword) +// 20[esp]: divisor (low dword) +// 16[esp]: return EIP +// 12[esp]: previous EBP +// 8[esp]: previous EBX +// 4[esp]: previous ESI +// [esp]: previous EDI +// + xor edi,edi // fake a 64 bit dividend + xor esi,esi + +@__lldiv@xloop: + shl eax,1 // shift dividend left one bit + rcl edx,1 + rcl esi,1 + rcl edi,1 + cmp edi,ebp // dividend larger? + jb @__lldiv@nosub + ja @__lldiv@subtract + cmp esi,ebx // maybe + jb @__lldiv@nosub + +@__lldiv@subtract: + sub esi,ebx + sbb edi,ebp // subtract the divisor + inc eax // build quotient + +@__lldiv@nosub: + loop @__lldiv@xloop +// +// When done with the loop the four registers values' look like: +// +// | edi | esi | edx | eax | +// | remainder | quotient | +// + pop ebx // get control bits + test ebx,1 // needs negative + jz @__lldiv@finish + neg edx + neg eax + sbb edx,0 // negate + +@__lldiv@finish: + pop edi + pop esi + pop ebx + pop ebp + ret 8 + +@__lldiv@quick_ldiv: + div ebx // unsigned divide + xor edx,edx + jmp @__lldiv@finish +end; + +// ------------------------------------------------------------------------------ +// 64-bit signed division with overflow check (98.05.15: not implementated yet) +// ------------------------------------------------------------------------------ + +// +// Dividend = Numerator, Divisor = Denominator +// +// Dividend(EAX:EDX), Divisor([ESP+8]:[ESP+4]) +// Param 1 (EAX:EDX), Param 2([ESP+8]:[ESP+4]) +// +// Param1 ~= U (Uh, Ul) +// Param2 ~= V (Vh, Vl) +// +// compiler-helper function +// O-flag set on exit => result is invalid +// O-flag clear on exit => result is valid +// + +procedure __lldivo; +asm + // check for overflow condition: min(int64) DIV -1 + push esi + mov esi, [esp+12] // Vh + and esi, [esp+8] // Vl + cmp esi, 0ffffffffh // V = -1? + jne @@divok + + mov esi, eax + or esi, edx + cmp esi, 80000000H // U = min(int64)? + jne @@divok + +@@divOvl: + mov eax, esi + pop esi + dec eax // turn on O-flag + ret + +@@divok: + pop esi + push dword ptr [esp+8] // Vh + push dword ptr [esp+8] // Vl (offset is changed from push) + call __lldiv + and eax, eax // turn off O-flag + ret 8 +end; + +// ------------------------------------------------------------------------------ +// 64-bit unsigned division +// ------------------------------------------------------------------------------ + +// Dividend(EAX(hi):EDX(lo)), Divisor([ESP+8](hi):[ESP+4](lo)) // before reg pushing +procedure __lludiv; +asm + push ebp + push ebx + push esi + push edi +// +// Now the stack looks something like this: +// +// 24[esp]: divisor (high dword) +// 20[esp]: divisor (low dword) +// 16[esp]: return EIP +// 12[esp]: previous EBP +// 8[esp]: previous EBX +// 4[esp]: previous ESI +// [esp]: previous EDI +// + +// dividend is pushed last, therefore the first in the args +// divisor next. +// + mov ebx,20[esp] // get the first low word + mov ecx,24[esp] // get the first high word + + or ecx,ecx + jnz @__lludiv@slow_ldiv // both high words are zero + + or edx,edx + jz @__lludiv@quick_ldiv + + or ebx,ebx + jz @__lludiv@quick_ldiv // if ecx:ebx == 0 force a zero divide + // we don't expect this to actually + // work + +@__lludiv@slow_ldiv: + mov ebp,ecx + mov ecx,64 // shift counter + xor edi,edi // fake a 64 bit dividend + xor esi,esi + +@__lludiv@xloop: + shl eax,1 // shift dividend left one bit + rcl edx,1 + rcl esi,1 + rcl edi,1 + cmp edi,ebp // dividend larger? + jb @__lludiv@nosub + ja @__lludiv@subtract + cmp esi,ebx // maybe + jb @__lludiv@nosub + +@__lludiv@subtract: + sub esi,ebx + sbb edi,ebp // subtract the divisor + inc eax // build quotient + +@__lludiv@nosub: + loop @__lludiv@xloop +// +// When done with the loop the four registers values' look like: +// +// | edi | esi | edx | eax | +// | remainder | quotient | +// + +@__lludiv@finish: + pop edi + pop esi + pop ebx + pop ebp + ret 8 + +@__lludiv@quick_ldiv: + div ebx // unsigned divide + xor edx,edx + jmp @__lludiv@finish +end; + +// ------------------------------------------------------------------------------ +// 64-bit modulo +// ------------------------------------------------------------------------------ + +// Dividend(EAX:EDX), Divisor([ESP+8]:[ESP+4]) // before reg pushing +procedure __llmod; +asm + push ebp + push ebx + push esi + push edi + xor edi,edi +// +// dividend is pushed last, therefore the first in the args +// divisor next. +// + mov ebx,20[esp] // get the first low word + mov ecx,24[esp] // get the first high word + or ecx,ecx + jnz @__llmod@slow_ldiv // both high words are zero + + or edx,edx + jz @__llmod@quick_ldiv + + or ebx,ebx + jz @__llmod@quick_ldiv // if ecx:ebx == 0 force a zero divide + // we don't expect this to actually + // work +@__llmod@slow_ldiv: +// +// Signed division should be done. Convert negative +// values to positive and do an unsigned division. +// Store the sign value in the next higher bit of +// di (test mask of 4). Thus when we are done, testing +// that bit will determine the sign of the result. +// + or edx,edx // test sign of dividend + jns @__llmod@onepos + neg edx + neg eax + sbb edx,0 // negate dividend + or edi,1 + +@__llmod@onepos: + or ecx,ecx // test sign of divisor + jns @__llmod@positive + neg ecx + neg ebx + sbb ecx,0 // negate divisor + +@__llmod@positive: + mov ebp,ecx + mov ecx,64 // shift counter + push edi // save the flags +// +// Now the stack looks something like this: +// +// 24[esp]: divisor (high dword) +// 20[esp]: divisor (low dword) +// 16[esp]: return EIP +// 12[esp]: previous EBP +// 8[esp]: previous EBX +// 4[esp]: previous ESI +// [esp]: previous EDI +// + xor edi,edi // fake a 64 bit dividend + xor esi,esi + +@__llmod@xloop: + shl eax,1 // shift dividend left one bit + rcl edx,1 + rcl esi,1 + rcl edi,1 + cmp edi,ebp // dividend larger? + jb @__llmod@nosub + ja @__llmod@subtract + cmp esi,ebx // maybe + jb @__llmod@nosub + +@__llmod@subtract: + sub esi,ebx + sbb edi,ebp // subtract the divisor + inc eax // build quotient + +@__llmod@nosub: + loop @__llmod@xloop +// +// When done with the loop the four registers values' look like: +// +// | edi | esi | edx | eax | +// | remainder | quotient | +// + mov eax,esi + mov edx,edi // use remainder + + pop ebx // get control bits + test ebx,1 // needs negative + jz @__llmod@finish + neg edx + neg eax + sbb edx,0 // negate + +@__llmod@finish: + pop edi + pop esi + pop ebx + pop ebp + ret 8 + +@__llmod@quick_ldiv: + div ebx // unsigned divide + xchg eax,edx + xor edx,edx + jmp @__llmod@finish +end; + +// ------------------------------------------------------------------------------ +// 64-bit signed modulo with overflow (98.05.15: overflow not yet supported) +// ------------------------------------------------------------------------------ + +// Dividend(EAX:EDX), Divisor([ESP+8]:[ESP+4]) +// Param 1 (EAX:EDX), Param 2([ESP+8]:[ESP+4]) +// +// Param1 ~= U (Uh, Ul) +// Param2 ~= V (Vh, Vl) +// +// compiler-helper function +// O-flag set on exit => result is invalid +// O-flag clear on exit => result is valid +// + +procedure __llmodo; +asm + // check for overflow condition: min(int64) MOD -1 + push esi + mov esi, [esp+12] // Vh + and esi, [esp+8] // Vl + cmp esi, 0ffffffffh // V = -1? + jne @@modok + + mov esi, eax + or esi, edx + cmp esi, 80000000H // U = min(int64)? + jne @@modok + +@@modOvl: + mov eax, esi + pop esi + dec eax // turn on O-flag + ret + +@@modok: + pop esi + push dword ptr [esp+8] // Vh + push dword ptr [esp+8] // Vl (offset is changed from push) + call __llmod + and eax, eax // turn off O-flag + ret 8 +end; + +// ------------------------------------------------------------------------------ +// 64-bit unsigned modulo +// ------------------------------------------------------------------------------ +// Dividend(EAX(hi):EDX(lo)), Divisor([ESP+8](hi):[ESP+4](lo)) // before reg pushing + +procedure __llumod; +asm + push ebp + push ebx + push esi + push edi +// +// Now the stack looks something like this: +// +// 24[esp]: divisor (high dword) +// 20[esp]: divisor (low dword) +// 16[esp]: return EIP +// 12[esp]: previous EBP +// 8[esp]: previous EBX +// 4[esp]: previous ESI +// [esp]: previous EDI +// + +// dividend is pushed last, therefore the first in the args +// divisor next. +// + mov ebx,20[esp] // get the first low word + mov ecx,24[esp] // get the first high word + or ecx,ecx + jnz @__llumod@slow_ldiv // both high words are zero + + or edx,edx + jz @__llumod@quick_ldiv + + or ebx,ebx + jz @__llumod@quick_ldiv // if ecx:ebx == 0 force a zero divide + // we don't expect this to actually + // work +@__llumod@slow_ldiv: + mov ebp,ecx + mov ecx,64 // shift counter + xor edi,edi // fake a 64 bit dividend + xor esi,esi // + +@__llumod@xloop: + shl eax,1 // shift dividend left one bit + rcl edx,1 + rcl esi,1 + rcl edi,1 + cmp edi,ebp // dividend larger? + jb @__llumod@nosub + ja @__llumod@subtract + cmp esi,ebx // maybe + jb @__llumod@nosub + +@__llumod@subtract: + sub esi,ebx + sbb edi,ebp // subtract the divisor + inc eax // build quotient + +@__llumod@nosub: + loop @__llumod@xloop +// +// When done with the loop the four registers values' look like: +// +// | edi | esi | edx | eax | +// | remainder | quotient | +// + mov eax,esi + mov edx,edi // use remainder + +@__llumod@finish: + pop edi + pop esi + pop ebx + pop ebp + ret 8 + +@__llumod@quick_ldiv: + div ebx // unsigned divide + xchg eax,edx + xor edx,edx + jmp @__llumod@finish +end; + +// ------------------------------------------------------------------------------ +// 64-bit shift left +// ------------------------------------------------------------------------------ + +// +// target (EAX:EDX) count (ECX) +// +procedure __llshl; +asm + cmp cl, 32 + jl @__llshl@below32 + cmp cl, 64 + jl @__llshl@below64 + xor edx, edx + xor eax, eax + ret + +@__llshl@below64: + mov edx, eax + shl edx, cl + xor eax, eax + ret + +@__llshl@below32: + shld edx, eax, cl + shl eax, cl + ret +end; + +// ------------------------------------------------------------------------------ +// 64-bit signed shift right +// ------------------------------------------------------------------------------ +// target (EAX:EDX) count (ECX) + +procedure __llshr; +asm + cmp cl, 32 + jl @__llshr@below32 + cmp cl, 64 + jl @__llshr@below64 + sar edx, 1fh + mov eax,edx + ret + +@__llshr@below64: + mov eax, edx + cdq + sar eax,cl + ret + +@__llshr@below32: + shrd eax, edx, cl + sar edx, cl + ret +end; + +// ------------------------------------------------------------------------------ +// 64-bit unsigned shift right +// ------------------------------------------------------------------------------ + +// target (EAX:EDX) count (ECX) +procedure __llushr; +asm + cmp cl, 32 + jl @__llushr@below32 + cmp cl, 64 + jl @__llushr@below64 + xor edx, edx + xor eax, eax + ret + +@__llushr@below64: + mov eax, edx + xor edx, edx + shr eax, cl + ret + +@__llushr@below32: + shrd eax, edx, cl + shr edx, cl + ret +end; + +function _StrInt64(val: Int64; width: Integer): ShortString; +var + d: array[0..31] of Char; { need 19 digits and a sign } + i, k: Integer; + sign: Boolean; + spaces: Integer; +begin + { Produce an ASCII representation of the number in reverse order } + i := 0; + sign := val < 0; + repeat + d[i] := Chr( Abs(val mod 10) + Ord('0') ); + Inc(i); + val := val div 10; + until val = 0; + if sign then + begin + d[i] := '-'; + Inc(i); + end; + + { Fill the Result with the appropriate number of blanks } + if width > 255 then + width := 255; + k := 1; + spaces := width - i; + while k <= spaces do + begin + Result[k] := ' '; + Inc(k); + end; + + { Fill the Result with the number } + while i > 0 do + begin + Dec(i); + Result[k] := d[i]; + Inc(k); + end; + + { Result is k-1 characters long } + SetLength(Result, k-1); + +end; + +function _Str0Int64(val: Int64): ShortString; +begin + Result := _StrInt64(val, 0); +end; + +procedure _WriteInt64; +asm +{ PROCEDURE _WriteInt64( VAR t: Text; val: Int64; with: Longint); } +{ ->EAX Pointer to file record } +{ [ESP+4] Value } +{ EDX Field width } + + SUB ESP,32 { VAR s: String[31]; } + + PUSH EAX + PUSH EDX + + PUSH dword ptr [ESP+8+32+8] { Str( val : 0, s ); } + PUSH dword ptr [ESP+8+32+8] + XOR EAX,EAX + LEA EDX,[ESP+8+8] + CALL _StrInt64 + + POP ECX + POP EAX + + MOV EDX,ESP { Write( t, s : width );} + CALL _WriteString + + ADD ESP,32 + RET 8 +end; + +procedure _Write0Int64; +asm +{ PROCEDURE _Write0Long( VAR t: Text; val: Longint); } +{ ->EAX Pointer to file record } +{ EDX Value } + XOR EDX,EDX + JMP _WriteInt64 +end; + +procedure _ReadInt64; +asm + // -> EAX Pointer to text record + // <- EAX:EDX Result + + PUSH EBX + PUSH ESI + PUSH EDI + SUB ESP,36 // var numbuf: String[32]; + + MOV ESI,EAX + CALL _SeekEof + DEC AL + JZ @@eof + + MOV EDI,ESP // EDI -> numBuf[0] + MOV BL,32 +@@loop: + MOV EAX,ESI + CALL _ReadChar + CMP AL,' ' + JBE @@endNum + STOSB + DEC BL + JNZ @@loop +@@convert: + MOV byte ptr [EDI],0 + MOV EAX,ESP // EAX -> numBuf + PUSH EDX // allocate code result + MOV EDX,ESP // pass pointer to code + CALL _ValInt64 // convert + POP ECX // pop code result into EDX + TEST ECX,ECX + JZ @@exit + MOV EAX,106 + CALL SetInOutRes + +@@exit: + ADD ESP,36 + POP EDI + POP ESI + POP EBX + RET + +@@endNum: + CMP AH,cEof + JE @@convert + DEC [ESI].TTextRec.BufPos + JMP @@convert + +@@eof: + XOR EAX,EAX + JMP @@exit +end; + +function _ValInt64(const s: AnsiString; var code: Integer): Int64; +var + i: Integer; + dig: Integer; + sign: Boolean; + empty: Boolean; +begin + i := 1; + dig := 0; + Result := 0; + if s = '' then + begin + code := i; + exit; + end; + while s[i] = ' ' do + Inc(i); + sign := False; + if s[i] = '-' then + begin + sign := True; + Inc(i); + end + else if s[i] = '+' then + Inc(i); + empty := True; + if (s[i] = '$') or (Upcase(s[i]) = 'X') + or ((s[i] = '0') and (Upcase(s[i+1]) = 'X')) then + begin + if s[i] = '0' then + Inc(i); + Inc(i); + while True do + begin + case s[i] of + '0'..'9': dig := Ord(s[i]) - Ord('0'); + 'A'..'F': dig := Ord(s[i]) - (Ord('A') - 10); + 'a'..'f': dig := Ord(s[i]) - (Ord('a') - 10); + else + break; + end; + if (Result < 0) or (Result > (High(Int64) shr 3)) then + Break; + Result := Result shl 4 + dig; + Inc(i); + empty := False; + end; + if sign then + Result := - Result; + end + else + begin + while True do + begin + case s[i] of + '0'..'9': dig := Ord(s[i]) - Ord('0'); + else + break; + end; + if (Result < 0) or (Result > (High(Int64) div 10)) then + break; + Result := Result*10 + dig; + Inc(i); + empty := False; + end; + if sign then + Result := - Result; + if (Result <> 0) and (sign <> (Result < 0)) then + Dec(i); + end; + if (s[i] <> #0) or empty then + code := i + else + code := 0; +end; + +procedure _DynArrayLength; +asm +{ FUNCTION _DynArrayLength(const a: array of ...): Longint; } +{ ->EAX Pointer to array or nil } +{ <-EAX High bound of array + 1 or 0 } + TEST EAX,EAX + JZ @@skip + MOV EAX,[EAX-4] +@@skip: +end; + +procedure _DynArrayHigh; +asm +{ FUNCTION _DynArrayHigh(const a: array of ...): Longint; } +{ ->EAX Pointer to array or nil } +{ <-EAX High bound of array or -1 } + CALL _DynArrayLength + DEC EAX +end; + +procedure CopyArray(dest, source, typeInfo: Pointer; cnt: Integer); +asm + PUSH dword ptr [EBP+8] + CALL _CopyArray +end; + +procedure FinalizeArray(p, typeInfo: Pointer; cnt: Integer); +asm + JMP _FinalizeArray +end; + +procedure DynArrayClear(var a: Pointer; typeInfo: Pointer); +asm + CALL _DynArrayClear +end; + +procedure DynArraySetLength(var a: Pointer; typeInfo: Pointer; dimCnt: Longint; lengthVec: PLongint); +var + i: Integer; + newLength, oldLength, minLength: Longint; + elSize: Longint; + neededSize: Longint; + p, pp: Pointer; +begin + p := a; + + // Fetch the new length of the array in this dimension, and the old length + newLength := PLongint(lengthVec)^; + if newLength <= 0 then + begin + if newLength < 0 then + Error(reRangeError); + DynArrayClear(a, typeInfo); + exit; + end; + + oldLength := 0; + if p <> nil then + begin + Dec(PLongint(p)); + oldLength := PLongint(p)^; + Dec(PLongint(p)); + end; + + // Calculate the needed size of the heap object + Inc(PChar(typeInfo), Length(PDynArrayTypeInfo(typeInfo).name)); + elSize := PDynArrayTypeInfo(typeInfo).elSize; + if PDynArrayTypeInfo(typeInfo).elType <> nil then + typeInfo := PDynArrayTypeInfo(typeInfo).elType^ + else + typeInfo := nil; + neededSize := newLength*elSize; + if neededSize div newLength <> elSize then + Error(reRangeError); + Inc(neededSize, Sizeof(Longint)*2); + + // If the heap object isn't shared (ref count = 1), just resize it. Otherwise, we make a copy + if (p = nil) or (PLongint(p)^ = 1) then + begin + pp := p; + if (newLength < oldLength) and (typeInfo <> nil) then + FinalizeArray(PChar(p) + Sizeof(Longint)*2 + newLength*elSize, typeInfo, oldLength - newLength); + ReallocMem(pp, neededSize); + p := pp; + end + else + begin + Dec(PLongint(p)^); + GetMem(p, neededSize); + minLength := oldLength; + if minLength > newLength then + minLength := newLength; + if typeInfo <> nil then + begin + FillChar((PChar(p) + Sizeof(Longint)*2)^, minLength*elSize, 0); + CopyArray(PChar(p) + Sizeof(Longint)*2, a, typeInfo, minLength) + end + else + Move(PChar(a)^, (PChar(p) + Sizeof(Longint)*2)^, minLength*elSize); + end; + + // The heap object will now have a ref count of 1 and the new length + PLongint(p)^ := 1; + Inc(PLongint(p)); + PLongint(p)^ := newLength; + Inc(PLongint(p)); + + // Set the new memory to all zero bits + FillChar((PChar(p) + elSize * oldLength)^, elSize * (newLength - oldLength), 0); + + // Take care of the inner dimensions, if any + if dimCnt > 1 then + begin + Inc(lengthVec); + Dec(dimCnt); + for i := 0 to newLength-1 do + DynArraySetLength(PPointerArray(p)[i], typeInfo, dimCnt, lengthVec); + end; + a := p; +end; + +procedure _DynArraySetLength; +asm +{ PROCEDURE _DynArraySetLength(var a: dynarray; typeInfo: PDynArrayTypeInfo; dimCnt: Longint; lengthVec: ^Longint) } +{ ->EAX Pointer to dynamic array (= pointer to pointer to heap object) } +{ EDX Pointer to type info for the dynamic array } +{ ECX number of dimensions } +{ [ESP+4] dimensions } + PUSH ESP + ADD dword ptr [ESP],4 + CALL DynArraySetLength +end; + +procedure _DynArrayCopy(a: Pointer; typeInfo: Pointer; var Result: Pointer); +begin + if a <> nil then + _DynArrayCopyRange(a, typeInfo, 0, PLongint(PChar(a)-4)^, Result) + else + _DynArrayClear(Result, typeInfo); +end; + +procedure _DynArrayCopyRange(a: Pointer; typeInfo: Pointer; index, count : Integer; var Result: Pointer); +var + arrayLength: Integer; + elSize: Integer; + typeInf: PDynArrayTypeInfo; + p: Pointer; +begin + p := nil; + if a <> nil then + begin + typeInf := typeInfo; + + // Limit index and count to values within the array + if index < 0 then + begin + Inc(count, index); + index := 0; + end; + arrayLength := PLongint(PChar(a)-4)^; + if index > arrayLength then + index := arrayLength; + if count > arrayLength - index then + count := arrayLength - index; + if count < 0 then + count := 0; + + if count > 0 then + begin + // Figure out the size and type descriptor of the element type + Inc(PChar(typeInf), Length(typeInf.name)); + elSize := typeInf.elSize; + if typeInf.elType <> nil then + typeInf := typeInf.elType^ + else + typeInf := nil; + + // Allocate the amount of memory needed + GetMem(p, count*elSize + Sizeof(Longint)*2); + + // The reference count of the new array is 1, the length is count + PLongint(p)^ := 1; + Inc(PLongint(p)); + PLongint(p)^ := count; + Inc(PLongint(p)); + Inc(PChar(a), index*elSize); + + // If the element type needs destruction, we must copy each element, + // otherwise we can just copy the bits + if count > 0 then + begin + if typeInf <> nil then + begin + FillChar(p^, count*elSize, 0); + CopyArray(p, a, typeInf, count) + end + else + Move(a^, p^, count*elSize); + end; + end; + end; + DynArrayClear(Result, typeInfo); + Result := p; +end; + +procedure _DynArrayClear; +asm +{ ->EAX Pointer to dynamic array (Pointer to pointer to heap object } +{ EDX Pointer to type info } + + { Nothing to do if Pointer to heap object is nil } + MOV ECX,[EAX] + TEST ECX,ECX + JE @@exit + + { Set the variable to be finalized to nil } + MOV dword ptr [EAX],0 + + { Decrement ref count. Nothing to do if not zero now. } +{X LOCK} DEC dword ptr [ECX-8] + JNE @@exit + + { Save the source - we're supposed to return it } + PUSH EAX + MOV EAX,ECX + + { Fetch the type descriptor of the elements } + XOR ECX,ECX + MOV CL,[EDX].TDynArrayTypeInfo.name; + MOV EDX,[EDX+ECX].TDynArrayTypeInfo.elType; + + { If it's non-nil, finalize the elements } + TEST EDX,EDX + JE @@noFinalize + MOV ECX,[EAX-4] + TEST ECX,ECX + JE @@noFinalize + MOV EDX,[EDX] + CALL _FinalizeArray +@@noFinalize: + { Now deallocate the array } + SUB EAX,8 + CALL _FreeMem + POP EAX +@@exit: +end; + + +procedure _DynArrayAsg; +asm +{ ->EAX Pointer to destination (pointer to pointer to heap object } +{ EDX source (pointer to heap object } +{ ECX Pointer to rtti describing dynamic array } + + PUSH EBX + MOV EBX,[EAX] + + { Increment ref count of source if non-nil } + + TEST EDX,EDX + JE @@skipInc +{X LOCK} INC dword ptr [EDX-8] +@@skipInc: + { Dec ref count of destination - if it becomes 0, clear dest } + TEST EBX,EBX + JE @@skipClear +{X LOCK} DEC dword ptr[EBX-8] + JNZ @@skipClear + PUSH EAX + PUSH EDX + MOV EDX,ECX + INC dword ptr[EBX-8] + CALL _DynArrayClear + POP EDX + POP EAX +@@skipClear: + { Finally store source into destination } + MOV [EAX],EDX + + POP EBX +end; + +procedure _DynArrayAddRef; +asm +{ ->EAX Pointer to heap object } + TEST EAX,EAX + JE @@exit +{X LOCK} INC dword ptr [EAX-8] +@@exit: +end; + + +function DynArrayIndex(const P: Pointer; const Indices: array of Integer; const TypInfo: Pointer): Pointer; +asm + { ->EAX P } + { EDX Pointer to Indices } + { ECX High bound of Indices } + { [EBP+8] TypInfo } + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV ESI,EDX + MOV EDI,[EBP+8] + MOV EBP,EAX + + XOR EBX,EBX { for i := 0 to High(Indices) do } + TEST ECX,ECX + JGE @@start +@@loop: + MOV EBP,[EBP] +@@start: + XOR EAX,EAX + MOV AL,[EDI].TDynArrayTypeInfo.name + ADD EDI,EAX + MOV EAX,[ESI+EBX*4] { P := P + Indices[i]*TypInfo.elSize } + MUL [EDI].TDynArrayTypeInfo.elSize + MOV EDI,[EDI].TDynArrayTypeInfo.elType + TEST EDI,EDI + JE @@skip + MOV EDI,[EDI] +@@skip: + ADD EBP,EAX + INC EBX + CMP EBX,ECX + JLE @@loop + +@@loopEnd: + + MOV EAX,EBP + + POP EBP + POP EDI + POP ESI + POP EBX +end; + + +{ Returns the DynArrayTypeInfo of the Element Type of the specified DynArrayTypeInfo } +function DynArrayElTypeInfo(typeInfo: PDynArrayTypeInfo): PDynArrayTypeInfo; +begin + Result := nil; + if typeInfo <> nil then + begin + Inc(PChar(typeInfo), Length(typeInfo.name)); + if typeInfo.elType <> nil then + Result := typeInfo.elType^; + end; +end; + +{ Returns # of dimemsions of the DynArray described by the specified DynArrayTypeInfo} +function DynArrayDim(typeInfo: PDynArrayTypeInfo): Integer; +begin + Result := 0; + while (typeInfo <> nil) and (typeInfo.kind = tkDynArray) do + begin + Inc(Result); + typeInfo := DynArrayElTypeInfo(typeInfo); + end; +end; + +{ Returns size of the Dynamic Array} +function DynArraySize(a: Pointer): Integer; +asm + TEST EAX, EAX + JZ @@exit + MOV EAX, [EAX-4] +@@exit: +end; + +// Returns whether array is rectangular +function IsDynArrayRectangular(const DynArray: Pointer; typeInfo: PDynArrayTypeInfo): Boolean; +var + Dim, I, J, Size, SubSize: Integer; + P: Pointer; +begin + // Assume we have a rectangular array + Result := True; + + P := DynArray; + Dim := DynArrayDim(typeInfo); + + {NOTE: Start at 1. Don't need to test the first dimension - it's rectangular by definition} + for I := 1 to dim-1 do + begin + if P <> nil then + begin + { Get size of this dimension } + Size := DynArraySize(P); + + { Get Size of first sub. dimension } + SubSize := DynArraySize(PPointerArray(P)[0]); + + { Walk through every dimension making sure they all have the same size} + for J := 1 to Size-1 do + if DynArraySize(PPointerArray(P)[J]) <> SubSize then + begin + Result := False; + Exit; + end; + + { Point to next dimension} + P := PPointerArray(P)[0]; + end; + end; +end; + +// Returns Bounds of Dynamic array as an array of integer containing the 'high' of each dimension +function DynArrayBounds(const DynArray: Pointer; typeInfo: PDynArrayTypeInfo): TBoundArray; +var + Dim, I: Integer; + P: Pointer; +begin + P := DynArray; + + Dim := DynArrayDim(typeInfo); + SetLength(Result, Dim); + + for I := 0 to dim-1 do + if P <> nil then + begin + Result[I] := DynArraySize(P)-1; + P := PPointerArray(P)[0]; // Assume rectangular arrays + end; +end; + +{ Decrements to next lower index - Returns True if successful } +{ Indices: Indices to be decremented } +{ Bounds : High bounds of each dimension } +function DecIndices(var Indices: TBoundArray; const Bounds: TBoundArray): Boolean; +var + I, J: Integer; +begin + { Find out if we're done: all at zeroes } + Result := False; + for I := Low(Indices) to High(Indices) do + if Indices[I] <> 0 then + begin + Result := True; + break; + end; + if not Result then + Exit; + + { Two arrays must be of same length } + Assert(Length(Indices) = Length(Bounds)); + + { Find index of item to tweak } + for I := High(Indices) downto Low(Bounds) do + begin + // If not reach zero, dec and bail out + if Indices[I] <> 0 then + begin + Dec(Indices[I]); + Exit; + end + else + begin + J := I; + while Indices[J] = 0 do + begin + // Restore high bound when we've reached zero on a particular dimension + Indices[J] := Bounds[J]; + // Move to higher dimension + Dec(J); + Assert(J >= 0); + end; + Dec(Indices[J]); + Exit; + end; + end; +end; + +{ Package/Module registration/unregistration } + +{$IFDEF MSWINDOWS} +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 +{$ENDIF} + +function FindModule(Instance: LongWord): PLibModule; +begin + Result := LibModuleList; + while Result <> nil do + begin + if (Instance = Result.Instance) or + (Instance = Result.CodeInstance) or + (Instance = Result.DataInstance) or + (Instance = Result.ResInstance) then + Exit; + Result := Result.Next; + end; +end; + +function FindHInstance(Address: Pointer): LongWord; +{$IFDEF MSWINDOWS} +var + MemInfo: TMemInfo; +begin + VirtualQuery(Address, MemInfo, SizeOf(MemInfo)); + if MemInfo.State = $1000{MEM_COMMIT} then + Result := LongWord(MemInfo.AllocationBase) + else + Result := 0; +end; +{$ENDIF} +{$IFDEF LINUX} +var + Info: TDLInfo; +begin + if (dladdr(Address, Info) = 0) or (Info.BaseAddress = ExeBaseAddress) then + Info.Filename := nil; // if it's not in a library, assume the exe + Result := LongWord(dlopen(Info.Filename, RTLD_LAZY)); + if Result <> 0 then + dlclose(Result); +end; +{$ENDIF} + +function FindClassHInstance(ClassType: TClass): LongWord; +begin + Result := FindHInstance(Pointer(ClassType)); +end; + +{$IFDEF LINUX} +function GetModuleFileName(Module: HMODULE; Buffer: PChar; BufLen: Integer): Integer; +var + Addr: Pointer; + Info: TDLInfo; + FoundInModule: HMODULE; + Temp: Integer; +begin + Result := 0; + if BufLen <= 0 then Exit; + if (Module = MainInstance) or (Module = 0) then + begin + // First, try the dlsym approach. + // dladdr fails to return the name of the main executable + // in glibc prior to 2.1.91 + +{ Look for a dynamic symbol exported from this program. + _DYNAMIC is not required in a main program file. + If the main program is compiled with Delphi, it will always + have a resource section, named @Sysinit@ResSym. + If the main program is not compiled with Delphi, dlsym + will search the global name space, potentially returning + the address of a symbol in some other shared object library + loaded by the program. To guard against that, we check + that the address of the symbol found is within the + main program address range. } + + dlerror; // clear error state; dlsym doesn't + Addr := dlsym(Module, '@Sysinit@ResSym'); + if (Addr <> nil) and (dlerror = nil) + and (dladdr(Addr, Info) <> 0) + and (Info.FileName <> nil) + and (Info.BaseAddress = ExeBaseAddress) then + begin + Result := _strlen(Info.FileName); + if Result >= BufLen then Result := BufLen-1; + + // dlinfo may not give a full path. Compare to /proc/self/exe, + // take longest result. + Temp := _readlink('/proc/self/exe', Buffer, BufLen); + if Temp >= BufLen then Temp := BufLen-1; + if Temp > Result then + Result := Temp + else + Move(Info.FileName^, Buffer^, Result); + Buffer[Result] := #0; + Exit; + end; + + // Try inspecting the /proc/ virtual file system + // to find the program filename in the process info + Result := _readlink('/proc/self/exe', Buffer, BufLen); + if Result <> -1 then + begin + if Result >= BufLen then Result := BufLen-1; + Buffer[Result] := #0; + end; +{$IFDEF AllowParamStrModuleName} +{ Using ParamStr(0) to obtain a module name presents a potential + security hole. Resource modules are loaded based upon the filename + of a given module. We use dlopen() to load resource modules, which + means the .init code of the resource module will be executed. + Normally, resource modules contain no code at all - they're just + carriers of resource data. + An unpriviledged user program could launch our trusted, + priviledged program with a bogus parameter list, tricking us + into loading a module that contains malicious code in its + .init section. + Without this ParamStr(0) section, GetModuleFilename cannot be + misdirected by unpriviledged code (unless the system program loader + or the /proc file system or system root directory has been compromised). + Resource modules are always loaded from the same directory as the + given module. Trusted code (programs, packages, and libraries) + should reside in directories that unpriviledged code cannot alter. + + If you need GetModuleFilename to have a chance of working on systems + where glibc < 2.1.91 and /proc is not available, and your + program will not run as a priviledged user (or you don't care), + you can define AllowParamStrModuleNames and rebuild the System unit + and baseCLX package. Note that even with ParamStr(0) support + enabled, GetModuleFilename can still fail to find the name of + a module. C'est la Unix. } + + if Result = -1 then // couldn't access the /proc filesystem + begin // return less accurate ParamStr(0) + +{ ParamStr(0) returns the name of the link used + to launch the app, not the name of the app itself. + Also, if this app was launched by some other program, + there is no guarantee that the launching program has set + up our environment at all. (example: Apache CGI) } + + if (ArgValues = nil) or (ArgValues^ = nil) or + (PCharArray(ArgValues^)[0] = nil) then + begin + Result := 0; + Exit; + end; + Result := _strlen(PCharArray(ArgValues^)[0]); + if Result >= BufLen then Result := BufLen-1; + Move(PCharArray(ArgValues^)[0]^, Buffer^, Result); + Buffer[Result] := #0; + end; +{$ENDIF} + end + else + begin +{ For shared object libraries, we can rely on the dlsym technique. + Look for a dynamic symbol in the requested module. + Don't assume the module was compiled with Delphi. + We look for a dynamic symbol with the name _DYNAMIC. This + exists in all ELF shared object libraries that export + or import symbols; If someone has a shared object library that + contains no imports or exports of any kind, this will probably fail. + If dlsym can't find the requested symbol in the given module, it + will search the global namespace and could return the address + of a symbol from some other module that happens to be loaded + into this process. That would be bad, so we double check + that the module handle of the symbol found matches the + module handle we asked about.} + + dlerror; // clear error state; dlsym doesn't + Addr := dlsym(Module, '_DYNAMIC'); + if (Addr <> nil) and (dlerror = nil) + and (dladdr(Addr, Info) <> 0) then + begin + if Info.BaseAddress = ExeBaseAddress then + Info.FileName := nil; + FoundInModule := HMODULE(dlopen(Info.FileName, RTLD_LAZY)); + if FoundInModule <> 0 then + dlclose(FoundInModule); + if Module = FoundInModule then + begin + if Assigned(Info.FileName) then + begin + Result := _strlen(Info.FileName); + if Result >= BufLen then Result := BufLen-1; + Move(Info.FileName^, Buffer^, Result); + end + else + Result := 0; + Buffer[Result] := #0; + end; + end; + end; + if Result < 0 then Result := 0; +end; +{$ENDIF} + +function DelayLoadResourceModule(Module: PLibModule): LongWord; +var + FileName: array[0..MAX_PATH] of Char; +begin + if Module.ResInstance = 0 then + begin + GetModuleFileName(Module.Instance, FileName, SizeOf(FileName)); + Module.ResInstance := LoadResourceModule(FileName); + if Module.ResInstance = 0 then + Module.ResInstance := Module.Instance; + end; + Result := Module.ResInstance; +end; + +function FindResourceHInstance(Instance: LongWord): LongWord; +var + CurModule: PLibModule; +begin + CurModule := LibModuleList; + while CurModule <> nil do + begin + if (Instance = CurModule.Instance) or + (Instance = CurModule.CodeInstance) or + (Instance = CurModule.DataInstance) then + begin + Result := DelayLoadResourceModule(CurModule); + Exit; + end; + CurModule := CurModule.Next; + end; + Result := Instance; +end; + +function LoadResourceModule(ModuleName: PChar; CheckOwner: Boolean): LongWord; +{$IFDEF LINUX} +var + FileName: array [0..MAX_PATH] of Char; + LangCode: PChar; // Language and country code. Example: en_US + P: PChar; + ModuleNameLen, FileNameLen, i: Integer; + st1, st2: TStatStruct; +begin + LangCode := __getenv('LANG'); + Result := 0; + if (LangCode = nil) or (LangCode^ = #0) or (ModuleName = nil) then Exit; + + // look for modulename.en_US (ignoring codeset and modifier suffixes) + P := LangCode; + while P^ in ['a'..'z', 'A'..'Z', '_'] do + Inc(P); + if P = LangCode then Exit; + + if CheckOwner and (__xstat(STAT_VER_LINUX, ModuleName, st1) = -1) then + Exit; + + ModuleNameLen := _strlen(ModuleName); + if (ModuleNameLen + P - LangCode) >= MAX_PATH then Exit; + Move(ModuleName[0], Filename[0], ModuleNameLen); + Filename[ModuleNameLen] := '.'; + Move(LangCode[0], Filename[ModuleNameLen + 1], P - LangCode); + FileNameLen := ModuleNameLen + 1 + (P - LangCode); + Filename[FileNameLen] := #0; + +{ Security check: make sure the user id (owner) and group id of + the base module matches the user id and group id of the resource + module we're considering loading. This is to prevent loading + of malicious code dropped into the base module's directory by + a hostile user. The app and all its resource modules must + have the same owner and group. To disable this security check, + call this function with CheckOwner set to False. } + + if (not CheckOwner) or + ((__xstat(STAT_VER_LINUX, FileName, st2) <> -1) + and (st1.st_uid = st2.st_uid) + and (st1.st_gid = st2.st_gid)) then + begin + Result := dlopen(Filename, RTLD_LAZY); + if Result <> 0 then Exit; + end; + + // look for modulename.en (ignoring country code and suffixes) + i := ModuleNameLen + 1; + while (i <= FileNameLen) and (Filename[i] in ['a'..'z', 'A'..'Z']) do + Inc(i); + if (i = ModuleNameLen + 1) or (i > FileNameLen) then Exit; + FileName[i] := #0; + + { Security check. See notes above. } + if (not CheckOwner) or + ((__xstat(STAT_VER_LINUX, FileName, st2) <> -1) + and (st1.st_uid = st2.st_uid) + and (st1.st_gid = st2.st_gid)) then + begin + Result := dlopen(FileName, RTLD_LAZY); + end; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +var + FileName: array[0..MAX_PATH] of Char; + Key: LongWord; + LocaleName, LocaleOverride: array[0..4] of Char; + Size: Integer; + P: PChar; + + function FindBS(Current: PChar): PChar; + begin + Result := Current; + while (Result^ <> #0) and (Result^ <> '\') do + Result := CharNext(Result); + end; + + function ToLongPath(AFileName: PChar; BufSize: Integer): PChar; + var + CurrBS, NextBS: PChar; + Handle, L: Integer; + FindData: TWin32FindData; + Buffer: array[0..MAX_PATH] of Char; + GetLongPathName: function (ShortPathName: PChar; LongPathName: PChar; + cchBuffer: Integer): Integer stdcall; + begin + Result := AFileName; + Handle := GetModuleHandle(kernel); + if Handle <> 0 then + begin + @GetLongPathName := GetProcAddress(Handle, 'GetLongPathNameA'); + if Assigned(GetLongPathName) and + (GetLongPathName(AFileName, Buffer, SizeOf(Buffer)) <> 0) then + begin + lstrcpyn(AFileName, Buffer, BufSize); + Exit; + end; + end; + + if AFileName[0] = '\' then + begin + if AFileName[1] <> '\' then Exit; + CurrBS := FindBS(AFileName + 2); // skip server name + if CurrBS^ = #0 then Exit; + CurrBS := FindBS(CurrBS + 1); // skip share name + if CurrBS^ = #0 then Exit; + end else + CurrBS := AFileName + 2; // skip drive name + + L := CurrBS - AFileName; + lstrcpyn(Buffer, AFileName, L + 1); + while CurrBS^ <> #0 do + begin + NextBS := FindBS(CurrBS + 1); + if L + (NextBS - CurrBS) + 1 > SizeOf(Buffer) then Exit; + lstrcpyn(Buffer + L, CurrBS, (NextBS - CurrBS) + 1); + + Handle := FindFirstFile(Buffer, FindData); + if (Handle = -1) then Exit; + FindClose(Handle); + + if L + 1 + _strlen(FindData.cFileName) + 1 > SizeOf(Buffer) then Exit; + Buffer[L] := '\'; + lstrcpyn(Buffer + L + 1, FindData.cFileName, Sizeof(Buffer) - L - 1); + Inc(L, _strlen(FindData.cFileName) + 1); + CurrBS := NextBS; + end; + lstrcpyn(AFileName, Buffer, BufSize); + end; +begin + GetModuleFileName(0, FileName, SizeOf(FileName)); // Get host application name + LocaleOverride[0] := #0; + if (RegOpenKeyEx(HKEY_CURRENT_USER, NewLocaleOverrideKey, 0, KEY_READ, Key) = 0) or + (RegOpenKeyEx(HKEY_LOCAL_MACHINE, NewLocaleOverrideKey, 0, KEY_READ, Key) = 0) or + (RegOpenKeyEx(HKEY_CURRENT_USER, OldLocaleOverrideKey, 0, KEY_READ, Key) = 0) then + try + Size := sizeof(LocaleOverride); + ToLongPath(FileName, sizeof(FileName)); + if RegQueryValueEx(Key, FileName, nil, nil, LocaleOverride, @Size) <> 0 then + if RegQueryValueEx(Key, '', nil, nil, LocaleOverride, @Size) <> 0 then + LocaleOverride[0] := #0; + LocaleOverride[sizeof(LocaleOverride)-1] := #0; + finally + RegCloseKey(Key); + end; + lstrcpyn(FileName, ModuleName, sizeof(FileName)); + GetLocaleInfo(GetThreadLocale, LOCALE_SABBREVLANGNAME, LocaleName, sizeof(LocaleName)); + Result := 0; + if (FileName[0] <> #0) and ((LocaleName[0] <> #0) or (LocaleOverride[0] <> #0)) then + begin + P := PChar(@FileName) + _strlen(FileName); + while (P^ <> '.') and (P <> @FileName) do Dec(P); + if P <> @FileName then + begin + Inc(P); + // First look for a locale registry override + if LocaleOverride[0] <> #0 then + begin + lstrcpyn(P, LocaleOverride, sizeof(FileName) - (P - FileName)); + Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE); + end; + if (Result = 0) and (LocaleName[0] <> #0) then + begin + // Then look for a potential language/country translation + lstrcpyn(P, LocaleName, sizeof(FileName) - (P - FileName)); + Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE); + if Result = 0 then + begin + // Finally look for a language only translation + LocaleName[2] := #0; + lstrcpyn(P, LocaleName, sizeof(FileName) - (P - FileName)); + Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE); + end; + end; + end; + end; +end; +{$ENDIF} + +procedure EnumModules(Func: TEnumModuleFunc; Data: Pointer); assembler; +begin + EnumModules(TEnumModuleFuncLW(Func), Data); +end; + +procedure EnumResourceModules(Func: TEnumModuleFunc; Data: Pointer); +begin + EnumResourceModules(TEnumModuleFuncLW(Func), Data); +end; + +procedure EnumModules(Func: TEnumModuleFuncLW; Data: Pointer); +var + CurModule: PLibModule; +begin + CurModule := LibModuleList; + while CurModule <> nil do + begin + if not Func(CurModule.Instance, Data) then Exit; + CurModule := CurModule.Next; + end; +end; + +procedure EnumResourceModules(Func: TEnumModuleFuncLW; Data: Pointer); +var + CurModule: PLibModule; +begin + CurModule := LibModuleList; + while CurModule <> nil do + begin + if not Func(DelayLoadResourceModule(CurModule), Data) then Exit; + CurModule := CurModule.Next; + end; +end; + +procedure AddModuleUnloadProc(Proc: TModuleUnloadProc); +begin + AddModuleUnloadProc(TModuleUnloadProcLW(Proc)); +end; + +procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProc); +begin + RemoveModuleUnloadProc(TModuleUnloadProcLW(Proc)); +end; + +procedure AddModuleUnloadProc(Proc: TModuleUnloadProcLW); +var + P: PModuleUnloadRec; +begin + New(P); + P.Next := ModuleUnloadList; + @P.Proc := @Proc; + ModuleUnloadList := P; +end; + +procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProcLW); +var + P, C: PModuleUnloadRec; +begin + P := ModuleUnloadList; + if (P <> nil) and (@P.Proc = @Proc) then + begin + ModuleUnloadList := ModuleUnloadList.Next; + Dispose(P); + end else + begin + C := P; + while C <> nil do + begin + if (C.Next <> nil) and (@C.Next.Proc = @Proc) then + begin + P := C.Next; + C.Next := C.Next.Next; + Dispose(P); + Break; + end; + C := C.Next; + end; + end; +end; + +procedure NotifyModuleUnload(HInstance: LongWord); +var + P: PModuleUnloadRec; +begin + P := ModuleUnloadList; + while P <> nil do + begin + try + P.Proc(HInstance); + except + // Make sure it doesn't stop notifications + end; + P := P.Next; + end; +{$IFDEF LINUX} + InvalidateModuleCache; +{$ENDIF} +end; + +procedure RegisterModule(LibModule: PLibModule); +begin + LibModule.Next := LibModuleList; + LibModuleList := LibModule; +end; + +{X-}//procedure UnregisterModule(LibModule: PLibModule); +{X+}procedure UnregisterModuleSafely(LibModule: PLibModule); +var + CurModule: PLibModule; +begin + try + NotifyModuleUnload(LibModule.Instance); + finally + if LibModule = LibModuleList then + LibModuleList := LibModule.Next + else + begin + CurModule := LibModuleList; + while CurModule <> nil do + begin + if CurModule.Next = LibModule then + begin + CurModule.Next := LibModule.Next; + Break; + end; + CurModule := CurModule.Next; + end; + end; + end; +end; + +{X+}// "Light" version of UnRegisterModule - without using of try-except +{X+}procedure UnRegisterModuleLight( LibModule: PLibModule ); +{X+}var +{X+} P: PModuleUnloadRec; +{X+}begin +{X+} P := ModuleUnloadList; +{X+} while P <> nil do begin +{X+} P.Proc(LibModule.Instance); +{X+} P := P.Next; +{X+} end; +{X+}{$IFDEF LINUX} +{X+} InvalidateModuleCache; +{X+}{$ENDIF} +{X+}end; + +function _IntfClear(var Dest: IInterface): Pointer; +{$IFDEF PUREPASCAL} +var + P: Pointer; +begin + Result := @Dest; + if Dest <> nil then + begin + P := Pointer(Dest); + Pointer(Dest) := nil; + IInterface(P)._Release; + end; +end; +{$ELSE} +asm + MOV EDX,[EAX] + TEST EDX,EDX + JE @@1 + MOV DWORD PTR [EAX],0 + PUSH EAX + PUSH EDX + MOV EAX,[EDX] + CALL DWORD PTR [EAX] + VMTOFFSET IInterface._Release + POP EAX +@@1: +end; +{$ENDIF} + +procedure _IntfCopy(var Dest: IInterface; const Source: IInterface); +{$IFDEF PUREPASCAL} +var + P: Pointer; +begin + P := Pointer(Dest); + if Source <> nil then + Source._AddRef; + Pointer(Dest) := Pointer(Source); + if P <> nil then + IInterface(P)._Release; +end; +{$ELSE} +asm +{ + The most common case is the single assignment of a non-nil interface + to a nil interface. So we streamline that case here. After this, + we give essentially equal weight to other outcomes. + + The semantics are: The source intf must be addrefed *before* it + is assigned to the destination. The old intf must be released + after the new intf is addrefed to support self assignment (I := I). + Either intf can be nil. The first requirement is really to make an + error case function a little better, and to improve the behaviour + of multithreaded applications - if the addref throws an exception, + you don't want the interface to have been assigned here, and if the + assignment is made to a global and another thread references it, + again you don't want the intf to be available until the reference + count is bumped. +} + TEST EDX,EDX // is source nil? + JE @@NilSource + PUSH EDX // save source + PUSH EAX // save dest + MOV EAX,[EDX] // get source vmt + PUSH EDX // source as arg + CALL DWORD PTR [EAX] + VMTOFFSET IInterface._AddRef + POP EAX // retrieve dest + MOV ECX, [EAX] // get current value + POP [EAX] // set dest in place + TEST ECX, ECX // is current value nil? + JNE @@ReleaseDest // no, release it + RET // most common case, we return here +@@ReleaseDest: + MOV EAX,[ECX] // get current value vmt + PUSH ECX // current value as arg + CALL DWORD PTR [EAX] + VMTOFFSET IInterface._Release + RET + +{ Now we're into the less common cases. } +@@NilSource: + MOV ECX, [EAX] // get current value + TEST ECX, ECX // is it nil? + MOV [EAX], EDX // store in dest (which is nil) + JE @@Done + MOV EAX, [ECX] // get current vmt + PUSH ECX // current value as arg + CALL DWORD PTR [EAX] + VMTOFFSET IInterface._Release +@@Done: +end; +{$ENDIF} + +procedure _IntfCast(var Dest: IInterface; const Source: IInterface; const IID: TGUID); +{$IFDEF PUREPASCAL} +// PIC: EBX must be correct before calling QueryInterface +var + Temp: IInterface; +begin + if Source = nil then + Dest := nil + else + begin + Temp := nil; + if Source.QueryInterface(IID, Temp) <> 0 then + Error(reIntfCastError) + else + Dest := Temp; + end; +end; +{$ELSE} +asm + TEST EDX,EDX + JE _IntfClear + PUSH EDI + MOV EDI, EAX // ptr to dest + PUSH 0 + PUSH ESP // ptr to temp + PUSH ECX // ptr to GUID + PUSH EDX // ptr to source +@@1: MOV EAX,[EDX] + CALL DWORD PTR [EAX] + VMTOFFSET IInterface.QueryInterface + TEST EAX,EAX + JE @@2 + MOV AL,reIntfCastError + JMP Error +@@2: MOV EAX, [EDI] + TEST EAX, EAX + JE @@3 + PUSH EAX + MOV EAX,[EAX] + CALL DWORD PTR [EAX] + VMTOFFSET IInterface._Release +@@3: POP EAX // value of temp + MOV [EDI], EAX + POP EDI +end; +{$ENDIF} + +procedure _IntfAddRef(const Dest: IInterface); +begin + if Dest <> nil then Dest._AddRef; +end; + +procedure TInterfacedObject.AfterConstruction; +begin +// Release the constructor's implicit refcount + InterlockedDecrement(FRefCount); +end; + +procedure TInterfacedObject.BeforeDestruction; +begin + if RefCount <> 0 then + Error(reInvalidPtr); +end; + +// Set an implicit refcount so that refcounting +// during construction won't destroy the object. +class function TInterfacedObject.NewInstance: TObject; +begin + Result := inherited NewInstance; + TInterfacedObject(Result).FRefCount := 1; +end; + +function TInterfacedObject.QueryInterface(const IID: TGUID; out Obj): HResult; +begin + if GetInterface(IID, Obj) then + Result := 0 + else + Result := E_NOINTERFACE; +end; + +function TInterfacedObject._AddRef: Integer; +begin + Result := InterlockedIncrement(FRefCount); +end; + +function TInterfacedObject._Release: Integer; +begin + Result := InterlockedDecrement(FRefCount); + if Result = 0 then + Destroy; +end; + +{ TAggregatedObject } + +constructor TAggregatedObject.Create(const Controller: IInterface); +begin + // weak reference to controller - don't keep it alive + FController := Pointer(Controller); +end; + +function TAggregatedObject.GetController: IInterface; +begin + Result := IInterface(FController); +end; + +function TAggregatedObject.QueryInterface(const IID: TGUID; out Obj): HResult; +begin + Result := IInterface(FController).QueryInterface(IID, Obj); +end; + +function TAggregatedObject._AddRef: Integer; +begin + Result := IInterface(FController)._AddRef; +end; + +function TAggregatedObject._Release: Integer; stdcall; +begin + Result := IInterface(FController)._Release; +end; + +{ TContainedObject } + +function TContainedObject.QueryInterface(const IID: TGUID; out Obj): HResult; +begin + if GetInterface(IID, Obj) then + Result := S_OK + else + Result := E_NOINTERFACE; +end; + +function _CheckAutoResult(ResultCode: HResult): HResult; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + if ResultCode < 0 then + begin + if Assigned(SafeCallErrorProc) then + SafeCallErrorProc(ResultCode, Pointer(-1)); // loses error address + Error(reSafeCallError); + end; + Result := ResultCode; +end; +{$ELSE} +asm + TEST EAX,EAX + JNS @@2 + MOV ECX,SafeCallErrorProc + TEST ECX,ECX + JE @@1 + MOV EDX,[ESP] + CALL ECX +@@1: MOV AL,reSafeCallError + JMP Error +@@2: +end; +{$IFEND} + +function CompToDouble(Value: Comp): Double; cdecl; +begin + Result := Value; +end; + +procedure DoubleToComp(Value: Double; var Result: Comp); cdecl; +begin + Result := Value; +end; + +function CompToCurrency(Value: Comp): Currency; cdecl; +begin + Result := Value; +end; + +procedure CurrencyToComp(Value: Currency; var Result: Comp); cdecl; +begin + Result := Value; +end; + +function GetMemory(Size: Integer): Pointer; cdecl; +begin + Result := MemoryManager.GetMem(Size); +end; + +function FreeMemory(P: Pointer): Integer; cdecl; +begin + if P = nil then + Result := 0 + else + Result := MemoryManager.FreeMem(P); +end; + +function ReallocMemory(P: Pointer; Size: Integer): Pointer; cdecl; +begin + if P = nil then + Result := GetMemory(Size) + else + Result := MemoryManager.ReallocMem(P, Size); +end; + +procedure SetLineBreakStyle(var T: Text; Style: TTextLineBreakStyle); +begin + if TTextRec(T).Mode = fmClosed then + TTextRec(T).Flags := (TTextRec(T).Flags and not tfCRLF) or (tfCRLF * Byte(Style)) + else + SetInOutRes(107); // can't change mode of open file +end; + +// UnicodeToUTF8(3): +// Scans the source data to find the null terminator, up to MaxBytes +// Dest must have MaxBytes available in Dest. + +function UnicodeToUtf8(Dest: PChar; Source: PWideChar; MaxBytes: Integer): Integer; +var + len: Cardinal; +begin + len := 0; + if Source <> nil then + while Source[len] <> #0 do + Inc(len); + Result := UnicodeToUtf8(Dest, MaxBytes, Source, len); +end; + +// UnicodeToUtf8(4): +// MaxDestBytes includes the null terminator (last char in the buffer will be set to null) +// Function result includes the null terminator. +// Nulls in the source data are not considered terminators - SourceChars must be accurate + +function UnicodeToUtf8(Dest: PChar; MaxDestBytes: Cardinal; Source: PWideChar; SourceChars: Cardinal): Cardinal; +var + i, count: Cardinal; + c: Cardinal; +begin + Result := 0; + if Source = nil then Exit; + count := 0; + i := 0; + if Dest <> nil then + begin + while (i < SourceChars) and (count < MaxDestBytes) do + begin + c := Cardinal(Source[i]); + Inc(i); + if c <= $7F then + begin + Dest[count] := Char(c); + Inc(count); + end + else if c > $7FF then + begin + if count + 3 > MaxDestBytes then + break; + Dest[count] := Char($E0 or (c shr 12)); + Dest[count+1] := Char($80 or ((c shr 6) and $3F)); + Dest[count+2] := Char($80 or (c and $3F)); + Inc(count,3); + end + else // $7F < Source[i] <= $7FF + begin + if count + 2 > MaxDestBytes then + break; + Dest[count] := Char($C0 or (c shr 6)); + Dest[count+1] := Char($80 or (c and $3F)); + Inc(count,2); + end; + end; + if count >= MaxDestBytes then count := MaxDestBytes-1; + Dest[count] := #0; + end + else + begin + while i < SourceChars do + begin + c := Integer(Source[i]); + Inc(i); + if c > $7F then + begin + if c > $7FF then + Inc(count); + Inc(count); + end; + Inc(count); + end; + end; + Result := count+1; // convert zero based index to byte count +end; + +function Utf8ToUnicode(Dest: PWideChar; Source: PChar; MaxChars: Integer): Integer; +var + len: Cardinal; +begin + len := 0; + if Source <> nil then + while Source[len] <> #0 do + Inc(len); + Result := Utf8ToUnicode(Dest, MaxChars, Source, len); +end; + +function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: Cardinal; Source: PChar; SourceBytes: Cardinal): Cardinal; +var + i, count: Cardinal; + c: Byte; + wc: Cardinal; +begin + if Source = nil then + begin + Result := 0; + Exit; + end; + Result := Cardinal(-1); + count := 0; + i := 0; + if Dest <> nil then + begin + while (i < SourceBytes) and (count < MaxDestChars) do + begin + wc := Cardinal(Source[i]); + Inc(i); + if (wc and $80) <> 0 then + begin + if i >= SourceBytes then Exit; // incomplete multibyte char + wc := wc and $3F; + if (wc and $20) <> 0 then + begin + c := Byte(Source[i]); + Inc(i); + if (c and $C0) <> $80 then Exit; // malformed trail byte or out of range char + if i >= SourceBytes then Exit; // incomplete multibyte char + wc := (wc shl 6) or (c and $3F); + end; + c := Byte(Source[i]); + Inc(i); + if (c and $C0) <> $80 then Exit; // malformed trail byte + + Dest[count] := WideChar((wc shl 6) or (c and $3F)); + end + else + Dest[count] := WideChar(wc); + Inc(count); + end; + if count >= MaxDestChars then count := MaxDestChars-1; + Dest[count] := #0; + end + else + begin + while (i < SourceBytes) do + begin + c := Byte(Source[i]); + Inc(i); + if (c and $80) <> 0 then + begin + if i >= SourceBytes then Exit; // incomplete multibyte char + c := c and $3F; + if (c and $20) <> 0 then + begin + c := Byte(Source[i]); + Inc(i); + if (c and $C0) <> $80 then Exit; // malformed trail byte or out of range char + if i >= SourceBytes then Exit; // incomplete multibyte char + end; + c := Byte(Source[i]); + Inc(i); + if (c and $C0) <> $80 then Exit; // malformed trail byte + end; + Inc(count); + end; + end; + Result := count+1; +end; + +function Utf8Encode(const WS: WideString): UTF8String; +var + L: Integer; + Temp: UTF8String; +begin + Result := ''; + if WS = '' then Exit; + SetLength(Temp, Length(WS) * 3); // SetLength includes space for null terminator + + L := UnicodeToUtf8(PChar(Temp), Length(Temp)+1, PWideChar(WS), Length(WS)); + if L > 0 then + SetLength(Temp, L-1) + else + Temp := ''; + Result := Temp; +end; + +function Utf8Decode(const S: UTF8String): WideString; +var + L: Integer; + Temp: WideString; +begin + Result := ''; + if S = '' then Exit; + SetLength(Temp, Length(S)); + + L := Utf8ToUnicode(PWideChar(Temp), Length(Temp)+1, PChar(S), Length(S)); + if L > 0 then + SetLength(Temp, L-1) + else + Temp := ''; + Result := Temp; +end; + +function AnsiToUtf8(const S: string): UTF8String; +begin + Result := Utf8Encode(S); +end; + +function Utf8ToAnsi(const S: UTF8String): string; +begin + Result := Utf8Decode(S); +end; + +{$IFDEF LINUX} + +function GetCPUType: Integer; +asm + PUSH EBX + // this code assumes ESP is 4 byte aligned + // test for 80386: see if bit #18 of EFLAGS (Alignment fault) can be toggled + PUSHFD + POP EAX + MOV ECX, EAX + XOR EAX, $40000 // flip AC bit in EFLAGS + PUSH EAX + POPFD + PUSHFD + POP EAX + XOR EAX, ECX // zero = 80386 CPU (can't toggle AC bit) + MOV EAX, CPUi386 + JZ @@Exit + PUSH ECX + POPFD // restore original flags before next test + + // test for 80486: see if bit #21 of EFLAGS (CPUID supported) can be toggled + MOV EAX, ECX // get original EFLAGS + XOR EAX, $200000 // flip CPUID bit in EFLAGS + PUSH EAX + POPFD + PUSHFD + POP EAX + XOR EAX, ECX // zero = 80486 (can't toggle EFLAGS bit #21) + MOV EAX, CPUi486 + JZ @@Exit + + // Use CPUID instruction to get CPU family + XOR EAX, EAX + CPUID + CMP EAX, 1 + JL @@Exit // unknown processor response: report as 486 + XOR EAX, EAX + INC EAX // we only care about info level 1 + CPUID + AND EAX, $F00 + SHR EAX, 8 + // Test8086 values are one less than the CPU model number, for historical reasons + DEC EAX + +@@Exit: + POP EBX +end; + + +const + sResSymExport = '@Sysinit@ResSym'; + sResStrExport = '@Sysinit@ResStr'; + sResHashExport = '@Sysinit@ResHash'; + +type + TElf32Sym = record + Name: Cardinal; + Value: Pointer; + Size: Cardinal; + Info: Byte; + Other: Byte; + Section: Word; + end; + PElf32Sym = ^TElf32Sym; + + TElfSymTab = array [0..0] of TElf32Sym; + PElfSymTab = ^TElfSymTab; + + TElfWordTab = array [0..2] of Cardinal; + PElfWordTab = ^TElfWordTab; + + +{ If Name encodes a numeric identifier, return it, else return -1. } +function NameToId(Name: PChar): Longint; +var digit: Longint; +begin + if Longint(Name) and $ffff0000 = 0 then + begin + Result := Longint(Name) and $ffff; + end + else if Name^ = '#' then + begin + Result := 0; + inc (Name); + while (Ord(Name^) <> 0) do + begin + digit := Ord(Name^) - Ord('0'); + if (LongWord(digit) > 9) then + begin + Result := -1; + exit; + end; + Result := Result * 10 + digit; + inc (Name); + end; + end + else + Result := -1; +end; + + +// Return ELF hash value for NAME converted to lower case. +function ElfHashLowercase(Name: PChar): Cardinal; +var + g: Cardinal; + c: Char; +begin + Result := 0; + while name^ <> #0 do + begin + c := name^; + case c of + 'A'..'Z': Inc(c, Ord('a') - Ord('A')); + end; + Result := (Result shl 4) + Ord(c); + g := Result and $f0000000; + Result := (Result xor (g shr 24)) and not g; + Inc(name); + end; +end; + +type + PFindResourceCache = ^TFindResourceCache; + TFindResourceCache = record + ModuleHandle: HMODULE; + Version: Cardinal; + SymbolTable: PElfSymTab; + StringTable: PChar; + HashTable: PElfWordTab; + BaseAddress: Cardinal; + end; + +threadvar + FindResourceCache: TFindResourceCache; + +function GetResourceCache(ModuleHandle: HMODULE): PFindResourceCache; +var + info: TDLInfo; +begin + Result := @FindResourceCache; + if (ModuleHandle <> Result^.ModuleHandle) or (ModuleCacheVersion <> Result^.Version) then + begin + Result^.SymbolTable := dlsym(ModuleHandle, sResSymExport); + Result^.StringTable := dlsym(ModuleHandle, sResStrExport); + Result^.HashTable := dlsym(ModuleHandle, sResHashExport); + Result^.ModuleHandle := ModuleHandle; + if (dladdr(Result^.HashTable, Info) = 0) or (Info.BaseAddress = ExeBaseAddress) then + Result^.BaseAddress := 0 // if it's not in a library, assume the exe + else + Result^.BaseAddress := Cardinal(Info.BaseAddress); + Result^.Version := ModuleCacheVersion; + end; +end; + +function FindResource(ModuleHandle: HMODULE; ResourceName: PChar; ResourceType: PChar): TResourceHandle; +var + P: PFindResourceCache; + nid, tid: Longint; + ucs2_key: array [0..2] of WideChar; + key: array [0..127] of Char; + len: Integer; + pc: PChar; + ch: Char; + nbucket: Cardinal; + bucket, chain: PElfWordTab; + syndx: Cardinal; +begin + Result := 0; + if ResourceName = nil then Exit; + P := GetResourceCache(ModuleHandle); + + tid := NameToId (ResourceType); + if tid = -1 then Exit; { not supported (yet?) } + + { This code must match util-common/elfres.c } + nid := NameToId (ResourceName); + if nid = -1 then + begin + ucs2_key[0] := WideChar(2*tid+2); + ucs2_key[1] := WideChar(0); + len := UnicodeToUtf8 (key, ucs2_key, SizeOf (key)) - 1; + pc := key+len; + while Ord(ResourceName^) <> 0 do + begin + ch := ResourceName^; + if Ord(ch) > 127 then exit; { insist on 7bit ASCII for now } + if ('A' <= ch) and (ch <= 'Z') then Inc(ch, Ord('a') - Ord('A')); + pc^ := ch; + inc (pc); + if pc = key + SizeOf(key) then exit; + inc (ResourceName); + end; + pc^ := Char(0); + end + else + begin + ucs2_key[0] := WideChar(2*tid+1); + ucs2_key[1] := WideChar(nid); + ucs2_key[2] := WideChar(0); + UnicodeToUtf8 (key, ucs2_key, SizeOf (key)); + end; + + with P^ do + begin + nbucket := HashTable[0]; + // nsym := HashTable[1]; + bucket := @HashTable[2]; + chain := @HashTable[2+nbucket]; + + syndx := bucket[ElfHashLowercase(key) mod nbucket]; + while (syndx <> 0) + and (strcasecmp(key, @StringTable[SymbolTable[syndx].Name]) <> 0) do + syndx := chain[syndx]; + + if syndx = 0 then + Result := 0 + else + Result := TResourceHandle(@SymbolTable[syndx]); + end; +end; + +function LoadResource(ModuleHandle: HMODULE; ResHandle: TResourceHandle): HGLOBAL; +var + P: PFindResourceCache; +begin + if ResHandle <> 0 then + begin + P := GetResourceCache(ModuleHandle); + Result := HGLOBAL(PElf32Sym(ResHandle)^.Value); + Inc (Cardinal(Result), P^.BaseAddress); + end + else + Result := 0; +end; + +function SizeofResource(ModuleHandle: HMODULE; ResHandle: TResourceHandle): Integer; +begin + if ResHandle <> 0 then + Result := PElf32Sym(ResHandle)^.Size + else + Result := 0; +end; + +function LockResource(ResData: HGLOBAL): Pointer; +begin + Result := Pointer(ResData); +end; + +function UnlockResource(ResData: HGLOBAL): LongBool; +begin + Result := False; +end; + +function FreeResource(ResData: HGLOBAL): LongBool; +begin + Result := True; +end; +{$ENDIF} + +{ ResString support function } + +{$IFDEF MSWINDOWS} +function LoadResString(ResStringRec: PResStringRec): string; +var + Buffer: array [0..4095] of char; +begin + if ResStringRec = nil then Exit; + if ResStringRec.Identifier < 64*1024 then + SetString(Result, Buffer, + LoadString(FindResourceHInstance(ResStringRec.Module^), + ResStringRec.Identifier, Buffer, SizeOf(Buffer))) + else + Result := PChar(ResStringRec.Identifier); +end; +{$ENDIF} +{$IFDEF LINUX} + +const + ResStringTableLen = 16; + +type + ResStringTable = array [0..ResStringTableLen-1] of LongWord; + +//function _printf(Format: PChar): Integer; cdecl; varargs; +//external libc name 'printf'; + +function LoadResString(ResStringRec: PResStringRec): string; +var + Handle: TResourceHandle; + Tab: ^ResStringTable; + ResMod: HMODULE; +begin + if ResStringRec = nil then Exit; + ResMod := FindResourceHInstance(ResStringRec^.Module^); + Handle := FindResource(ResMod, + PChar(ResStringRec^.Identifier div ResStringTableLen), + PChar(6)); // RT_STRING + Tab := Pointer(LoadResource(ResMod, Handle)); + if Tab = nil then + Result := '' + else + begin + Result := PWideChar(PChar(Tab) + Tab[ResStringRec^.Identifier mod ResStringTableLen]); + end; +end; + +{ The Win32 program loader sets up the first 64k of process address space + with no read or write access, to help detect use of invalid pointers + (whose integer value is 0..64k). Linux doesn't do this. + + Parts of the Delphi RTL and IDE design environment + rely on the notion that pointer values in the [0..64k] range are + invalid pointers. To accomodate this in Linux, we reserve the range + at startup. If the range is already allocated, we keep going anyway. } + +var + ZeroPageReserved: Boolean = False; + +procedure ReserveZeroPage; +const + PROT_NONE = 0; + MAP_PRIVATE = $02; + MAP_FIXED = $10; + MAP_ANONYMOUS = $20; +var + P: Pointer; +begin + if IsLibrary then Exit; // page reserve is app's job, not .so's + + if not ZeroPageReserved then + begin + P := mmap(nil, High(Word), PROT_NONE, + MAP_ANONYMOUS or MAP_PRIVATE or MAP_FIXED, 0, 0); + ZeroPageReserved := P = nil; + if (Integer(P) <> -1) and (P <> nil) then // we didn't get it + munmap(P, High(Word)); + end; +end; + +procedure ReleaseZeroPage; +begin + if ZeroPageReserved then + begin + munmap(nil, High(Word) - 4096); + ZeroPageReserved := False; + end; +end; +{$ENDIF} + +function PUCS4Chars(const S: UCS4String): PUCS4Char; +const + Null: UCS4Char = 0; + PNull: PUCS4Char = @Null; +begin + if Length(S) > 0 then + Result := @S[0] + else + Result := PNull; +end; + +function WideStringToUCS4String(const S: WideString): UCS4String; +var + I: Integer; +begin + SetLength(Result, Length(S) + 1); + for I := 0 to Length(S) - 1 do + Result[I] := UCS4Char(S[I + 1]); + Result[Length(S)] := 0; +end; + +function UCS4StringToWidestring(const S: UCS4String): WideString; +var + I: Integer; +begin + SetLength(Result, Length(S)-1); + for I := 0 to Length(S)-2 do + Result[I+1] := WideChar(S[I]); +end; + +{$IFDEF MSWINDOWS} +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; +{$ENDIF} + +{$IFDEF LINUX} +const + LC_ALL = 6; + +function _setlocale(__category: Integer; __locale: PChar): PChar; cdecl; +external libc name 'setlocale'; +{$ENDIF} + +initialization +{$IFDEF LINUX} + _setlocale(LC_ALL, ''); +{$ENDIF} + +{X+}{$IFDEF MSWINDOWS} +{X+} {$IFDEF USE_PROCESS_HEAP} +{X+} HeapHandle := GetProcessHeap; +{X+} {$ELSE} +{X+} HeapHandle := HeapCreate( 0, 0, 0 ); +{X+} {$ENDIF} +{X+}{$ENDIF} + +{X+} {$IFDEF MSWINDOWS} +{X+}// (initialized statically} FileMode := 2; +{X+} {$ELSE} + FileMode := 2; +{X+} {$ENDIF} + +{X-}// RaiseExceptionProc := @RaiseException; +{X-}// RTLUnwindProc := @RTLUnwind; + +{$IFDEF LINUX} + FileAccessRights := S_IRUSR or S_IWUSR or S_IRGRP or S_IWGRP or S_IROTH or S_IWOTH; + Test8086 := GetCPUType; + IsConsole := True; + FindResourceCache.ModuleHandle := LongWord(-1); + ReserveZeroPage; +{$ELSE} +{X+}// (initialized statically} Test8086 := 2; +{$ENDIF} + + DispCallByIDProc := @_DispCallByIDError; + +{$IFDEF MSWINDOWS} +{X-}// if _isNECWindows then _FpuMaskInit; +{$ENDIF} +{X-}// _FpuInit(); +{X- + TTextRec(Input).Mode := fmClosed; + TTextRec(Output).Mode := fmClosed; + TTextRec(ErrOutput).Mode := fmClosed; +{X-} +{$IFDEF MSWINDOWS} +{X-}// CmdLine := GetCommandLine; +{X-}// 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 +{X-}// Close(Input); +{X-}// Close(Output); +{X-}// Close(ErrOutput); +{X+} CloseInputOutput; +{$IFDEF LINUX} + ReleaseZeroPage; +{$ENDIF} +{$IFDEF MSWINDOWS} + UninitAllocator; +{$ENDIF} +end. + diff --git a/System/D7_ECM/getmem.inc b/System/D7_ECM/getmem.inc new file mode 100644 index 0000000..4999e62 --- /dev/null +++ b/System/D7_ECM/getmem.inc @@ -0,0 +1,1541 @@ +{ *********************************************************************** } +{ } +{ Delphi Runtime Library } +{ } +{ Copyright (c) 1996,2001 Borland Software Corporation } +{ } +{ *********************************************************************** } + +// Three layers: +// - Address space administration +// - Committed space administration +// - Suballocator +// +// Helper module: administrating block descriptors +// + + +// +// Operating system interface +// +const + LMEM_FIXED = 0; + LMEM_ZEROINIT = $40; + + MEM_COMMIT = $1000; + MEM_RESERVE = $2000; + MEM_DECOMMIT = $4000; + MEM_RELEASE = $8000; + + PAGE_NOACCESS = 1; + PAGE_READWRITE = 4; + +type + DWORD = Integer; + BOOL = LongBool; + + TRTLCriticalSection = packed record + DebugInfo: Pointer; + LockCount: Longint; + RecursionCount: Longint; + OwningThread: Integer; + LockSemaphore: Integer; + Reserved: DWORD; + end; + +function LocalAlloc(flags, size: Integer): Pointer; stdcall; + external kernel name 'LocalAlloc'; +function LocalFree(addr: Pointer): Pointer; stdcall; + external kernel name 'LocalFree'; + +function VirtualAlloc(lpAddress: Pointer; + dwSize, flAllocationType, flProtect: DWORD): Pointer; stdcall; + external kernel name 'VirtualAlloc'; +function VirtualFree(lpAddress: Pointer; dwSize, dwFreeType: DWORD): BOOL; stdcall; + external kernel name 'VirtualFree'; + +procedure InitializeCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall; + external kernel name 'InitializeCriticalSection'; +procedure EnterCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall; + external kernel name 'EnterCriticalSection'; +procedure LeaveCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall; + external kernel name 'LeaveCriticalSection'; +procedure DeleteCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall; + external kernel name 'DeleteCriticalSection'; + +// Common Data structure: + +type + TBlock = packed record + addr: PChar; + size: Integer; + end; + +// Heap error codes + +const + cHeapOk = 0; // everything's fine + cReleaseErr = 1; // operating system returned an error when we released + cDecommitErr = 2; // operating system returned an error when we decommited + cBadCommittedList = 3; // list of committed blocks looks bad + cBadFiller1 = 4; // filler block is bad + cBadFiller2 = 5; // filler block is bad + cBadFiller3 = 6; // filler block is bad + cBadCurAlloc = 7; // current allocation zone is bad + cCantInit = 8; // couldn't initialize + cBadUsedBlock = 9; // used block looks bad + cBadPrevBlock = 10; // prev block before a used block is bad + cBadNextBlock = 11; // next block after a used block is bad + cBadFreeList = 12; // free list is bad + cBadFreeBlock = 13; // free block is bad + cBadBalance = 14; // free list doesn't correspond to blocks marked free + +var + initialized : Boolean; + heapErrorCode : Integer; + heapLock : TRTLCriticalSection; + +// +// Helper module: administrating block descriptors. +// +type + PBlockDesc = ^TBlockDesc; + TBlockDesc = packed record + next: PBlockDesc; + prev: PBlockDesc; + addr: PChar; + size: Integer; + end; + +type + PBlockDescBlock = ^TBlockDescBlock; + TBlockDescBlock = packed record + next: PBlockDescBlock; + data: array [0..99] of TBlockDesc; + end; + +var + blockDescBlockList: PBlockDescBlock; + blockDescFreeList : PBlockDesc; + + +function GetBlockDesc: PBlockDesc; +// Get a block descriptor. +// Will return nil for failure. +var + bd: PBlockDesc; + bdb: PBlockDescBlock; + i: Integer; +begin + if blockDescFreeList = nil then begin + bdb := LocalAlloc(LMEM_FIXED, sizeof(bdb^)); + if bdb = nil then begin + result := nil; + exit; + end; + bdb.next := blockDescBlockList; + blockDescBlockList := bdb; + for i := low(bdb.data) to high(bdb.data) do begin + bd := @bdb.data[i]; + bd.next := blockDescFreeList; + blockDescFreeList := bd; + end; + end; + bd := blockDescFreeList; + blockDescFreeList := bd.next; + result := bd; +end; + + +procedure MakeEmpty(bd: PBlockDesc); +begin + bd.next := bd; + bd.prev := bd; +end; + + +function AddBlockAfter(prev: PBlockDesc; const b: TBlock): Boolean; +var + next, bd: PBlockDesc; +begin + bd := GetBlockDesc; + if bd = nil then + result := False + else begin + bd.addr := b.addr; + bd.size := b.size; + + next := prev.next; + bd.next := next; + bd.prev := prev; + next.prev := bd; + prev.next := bd; + + result := True; + end; +end; + + +procedure DeleteBlock(bd: PBlockDesc); +var + prev, next: PBlockDesc; +begin + prev := bd.prev; + next := bd.next; + prev.next := next; + next.prev := prev; + bd.next := blockDescFreeList; + blockDescFreeList := bd; +end; + + +function MergeBlockAfter(prev: PBlockDesc; const b: TBlock) : TBlock; +var + bd, bdNext: PBlockDesc; +begin + bd := prev.next; + result := b; + repeat + bdNext := bd.next; + if bd.addr + bd.size = result.addr then begin + DeleteBlock(bd); + result.addr := bd.addr; + inc(result.size, bd.size); + end else if result.addr + result.size = bd.addr then begin + DeleteBlock(bd); + inc(result.size, bd.size); + end; + bd := bdNext; + until bd = prev; + if not AddBlockAfter(prev, result) then + result.addr := nil; +end; + + +function RemoveBlock(bd: PBlockDesc; const b: TBlock): Boolean; +var + n: TBlock; + start: PBlockDesc; +begin + start := bd; + repeat + if (bd.addr <= b.addr) and (bd.addr + bd.size >= b.addr + b.size) then begin + if bd.addr = b.addr then begin + Inc(bd.addr, b.size); + Dec(bd.size, b.size); + if bd.size = 0 then + DeleteBlock(bd); + end else if bd.addr + bd.size = b.addr + b.size then + Dec(bd.size, b.size) + else begin + n.addr := b.addr + b.size; + n.size := bd.addr + bd.size - n.addr; + bd.size := b.addr - bd.addr; + if not AddBlockAfter(bd, n) then begin + result := False; + exit; + end; + end; + result := True; + exit; + end; + bd := bd.next; + until bd = start; + result := False; +end; + + + +// +// Address space administration: +// + +const + cSpaceAlign = 64*1024; + cSpaceMin = 1024*1024; + cPageAlign = 4*1024; + +var + spaceRoot: TBlockDesc; + + +function GetSpace(minSize: Integer): TBlock; +// Get at least minSize bytes address space. +// Success: returns a block, possibly much bigger than requested. +// Will not fail - will raise an exception or terminate program. +begin + if minSize < cSpaceMin then + minSize := cSpaceMin + else + minSize := (minSize + (cSpaceAlign-1)) and not (cSpaceAlign-1); + + result.size := minSize; + result.addr := VirtualAlloc(nil, minSize, MEM_RESERVE, PAGE_NOACCESS); + if result.addr = nil then + exit; + + if not AddBlockAfter(@spaceRoot, result) then begin + VirtualFree(result.addr, 0, MEM_RELEASE); + result.addr := nil; + exit; + end; +end; + + +function GetSpaceAt(addr: PChar; minSize: Integer): TBlock; +// Get at least minSize bytes address space at addr. +// Return values as above. +// Failure: returns block with addr = nil. +begin + result.size := cSpaceMin; + result.addr := VirtualAlloc(addr, cSpaceMin, MEM_RESERVE, PAGE_READWRITE); + if result.addr = nil then begin + minSize := (minSize + (cSpaceAlign-1)) and not (cSpaceAlign-1); + result.size := minSize; + result.addr := VirtualAlloc(addr, minSize, MEM_RESERVE, PAGE_READWRITE); + end; + if result.addr <> nil then begin + if not AddBlockAfter(@spaceRoot, result) then begin + VirtualFree(result.addr, 0, MEM_RELEASE); + result.addr := nil; + end; + end; +end; + + +function FreeSpace(addr: Pointer; maxSize: Integer): TBlock; +// Free at most maxSize bytes of address space at addr. +// Returns the block that was actually freed. +var + bd, bdNext: PBlockDesc; + minAddr, maxAddr, startAddr, endAddr: PChar; +begin + minAddr := PChar($FFFFFFFF); + maxAddr := nil; + startAddr := addr; + endAddr := startAddr + maxSize; + bd := spaceRoot.next; + while bd <> @spaceRoot do begin + bdNext := bd.next; + if (bd.addr >= startAddr) and (bd.addr + bd.size <= endAddr) then begin + if minAddr > bd.addr then + minAddr := bd.addr; + if maxAddr < bd.addr + bd.size then + maxAddr := bd.addr + bd.size; + if not VirtualFree(bd.addr, 0, MEM_RELEASE) then + heapErrorCode := cReleaseErr; + DeleteBlock(bd); + end; + bd := bdNext; + end; + result.addr := nil; + if maxAddr <> nil then begin + result.addr := minAddr; + result.size := maxAddr - minAddr; + end; +end; + + +function Commit(addr: Pointer; minSize: Integer): TBlock; +// Commits memory. +// Returns the block that was actually committed. +// Will return a block with addr = nil on failure. +var + bd: PBlockDesc; + loAddr, hiAddr, startAddr, endAddr: PChar; +begin + startAddr := PChar(Integer(addr) and not (cPageAlign-1)); + endAddr := PChar(((Integer(addr) + minSize) + (cPageAlign-1)) and not (cPageAlign-1)); + result.addr := startAddr; + result.size := endAddr - startAddr; + bd := spaceRoot.next; + while bd <> @spaceRoot do begin + // Commit the intersection of the block described by bd and [startAddr..endAddr) + loAddr := bd.addr; + hiAddr := loAddr + bd.size; + if loAddr < startAddr then + loAddr := startAddr; + if hiAddr > endAddr then + hiAddr := endAddr; + if loAddr < hiAddr then begin + if VirtualAlloc(loAddr, hiAddr - loAddr, MEM_COMMIT, PAGE_READWRITE) = nil then begin + result.addr := nil; + exit; + end; + end; + bd := bd.next; + end; +end; + + +function Decommit(addr: Pointer; maxSize: Integer): TBlock; +// Decommits address space. +// Returns the block that was actually decommitted. +var + bd: PBlockDesc; + loAddr, hiAddr, startAddr, endAddr: PChar; +begin + startAddr := PChar((Integer(addr) + + (cPageAlign-1)) and not (cPageAlign-1)); + endAddr := PChar((Integer(addr) + maxSize) and not (cPageAlign-1)); + result.addr := startAddr; + result.size := endAddr - startAddr; + bd := spaceRoot.next; + while bd <> @spaceRoot do begin + // Decommit the intersection of the block described by bd and [startAddr..endAddr) + loAddr := bd.addr; + hiAddr := loAddr + bd.size; + if loAddr < startAddr then + loAddr := startAddr; + if hiAddr > endAddr then + hiAddr := endAddr; + if loAddr < hiAddr then begin + if not VirtualFree(loAddr, hiAddr - loAddr, MEM_DECOMMIT) then + heapErrorCode := cDecommitErr; + end; + bd := bd.next; + end; +end; + + +// +// Committed space administration +// +const + cCommitAlign = 16*1024; + +var + decommittedRoot: TBlockDesc; + + +function GetCommitted(minSize: Integer): TBlock; +// Get a block of committed memory. +// Returns a committed memory block, possibly much bigger than requested. +// Will return a block with a nil addr on failure. +var + bd: PBlockDesc; +begin + minSize := (minSize + (cCommitAlign-1)) and not (cCommitAlign-1); + repeat + bd := decommittedRoot.next; + while bd <> @decommittedRoot do begin + if bd.size >= minSize then begin + result := Commit(bd.addr, minSize); + if result.addr = nil then + exit; + Inc(bd.addr, result.size); + Dec(bd.size, result.size); + if bd.size = 0 then + DeleteBlock(bd); + exit; + end; + bd := bd.next; + end; + result := GetSpace(minSize); + if result.addr = nil then + exit; + if MergeBlockAfter(@decommittedRoot, result).addr = nil then begin + FreeSpace(result.addr, result.size); + result.addr := nil; + exit; + end; + until False; +end; + + +function GetCommittedAt(addr: PChar; minSize: Integer): TBlock; +// Get at least minSize bytes committed space at addr. +// Success: returns a block, possibly much bigger than requested. +// Failure: returns a block with addr = nil. +var + bd: PBlockDesc; + b: TBlock; +begin + minSize := (minSize + (cCommitAlign-1)) and not (cCommitAlign-1); + repeat + + bd := decommittedRoot.next; + while (bd <> @decommittedRoot) and (bd.addr <> addr) do + bd := bd.next; + + if bd.addr = addr then begin + if bd.size >= minSize then + break; + b := GetSpaceAt(bd.addr + bd.size, minSize - bd.size); + if b.addr <> nil then begin + if MergeBlockAfter(@decommittedRoot, b).addr <> nil then + continue + else begin + FreeSpace(b.addr, b.size); + result.addr := nil; + exit; + end; + end; + end; + + b := GetSpaceAt(addr, minSize); + if b.addr = nil then + break; + + if MergeBlockAfter(@decommittedRoot, b).addr = nil then begin + FreeSpace(b.addr, b.size); + result.addr := nil; + exit; + end; + until false; + + if (bd.addr = addr) and (bd.size >= minSize) then begin + result := Commit(bd.addr, minSize); + if result.addr = nil then + exit; + Inc(bd.addr, result.size); + Dec(bd.size, result.size); + if bd.size = 0 then + DeleteBlock(bd); + end else + result.addr := nil; +end; + + +function FreeCommitted(addr: PChar; maxSize: Integer): TBlock; +// Free at most maxSize bytes of address space at addr. +// Returns the block that was actually freed. +var + startAddr, endAddr: PChar; + b: TBlock; +begin + startAddr := PChar(Integer(addr + (cCommitAlign-1)) and not (cCommitAlign-1)); + endAddr := PChar(Integer(addr + maxSize) and not (cCommitAlign-1)); + if endAddr > startAddr then begin + result := Decommit(startAddr, endAddr - startAddr); + b := MergeBlockAfter(@decommittedRoot, result); + if b.addr <> nil then + b := FreeSpace(b.addr, b.size); + if b.addr <> nil then + RemoveBlock(@decommittedRoot, b); + end else + result.addr := nil; +end; + + +// +// Suballocator (what the user program actually calls) +// + +type + PFree = ^TFree; + TFree = packed record + prev: PFree; + next: PFree; + size: Integer; + end; + PUsed = ^TUsed; + TUsed = packed record + sizeFlags: Integer; + end; + +const + cAlign = 4; + cThisUsedFlag = 2; + cPrevFreeFlag = 1; + cFillerFlag = Integer($80000000); + cFlags = cThisUsedFlag or cPrevFreeFlag or cFillerFlag; + cSmallSize = 4*1024; + cDecommitMin = 15*1024; + +type + TSmallTab = array [sizeof(TFree) div cAlign .. cSmallSize div cAlign] of PFree; + +VAR + avail : TFree; + rover : PFree; + remBytes : Integer; + curAlloc : PChar; + smallTab : ^TSmallTab; + committedRoot: TBlockDesc; + + +function InitAllocator: Boolean; +// Initialize. No other calls legal before that. +var + i: Integer; + a: PFree; +begin + try + InitializeCriticalSection(heapLock); + if IsMultiThread then EnterCriticalSection(heapLock); + + MakeEmpty(@spaceRoot); + MakeEmpty(@decommittedRoot); + MakeEmpty(@committedRoot); + + smallTab := LocalAlloc(LMEM_FIXED, sizeof(smallTab^)); + if smallTab <> nil then begin + for i:= low(smallTab^) to high(smallTab^) do + smallTab[i] := nil; + + a := @avail; + a.next := a; + a.prev := a; + rover := a; + + initialized := True; + end; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; + result := initialized; +end; + + +procedure UninitAllocator; +// Shutdown. +var + bdb: PBlockDescBlock; + bd : PBlockDesc; +begin + if initialized then begin + try + if IsMultiThread then EnterCriticalSection(heapLock); + + initialized := False; + + LocalFree(smallTab); + smallTab := nil; + + bd := spaceRoot.next; + while bd <> @spaceRoot do begin + VirtualFree(bd.addr, 0, MEM_RELEASE); + bd := bd.next; + end; + + MakeEmpty(@spaceRoot); + MakeEmpty(@decommittedRoot); + MakeEmpty(@committedRoot); + + bdb := blockDescBlockList; + while bdb <> nil do begin + blockDescBlockList := bdb^.next; + LocalFree(bdb); + bdb := blockDescBlockList; + end; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + DeleteCriticalSection(heapLock); + end; + end; +end; + + +procedure DeleteFree(f: PFree); +var + n, p: PFree; + size: Integer; +begin + if rover = f then + rover := f.next; + n := f.next; + size := f.size; + if size <= cSmallSize then begin + if n = f then + smallTab[size div cAlign] := nil + else begin + smallTab[size div cAlign] := n; + p := f.prev; + n.prev := p; + p.next := n; + end; + end else begin + p := f.prev; + n.prev := p; + p.next := n; + end; +end; + + +procedure InsertFree(a: Pointer; size: Integer); forward; + + +function FindCommitted(addr: PChar): PBlockDesc; +begin + result := committedRoot.next; + while result <> @committedRoot do begin + if (addr >= result.addr) and (addr < result.addr + result.size) then + exit; + result := result.next; + end; + heapErrorCode := cBadCommittedList; + result := nil; +end; + + +procedure FillBeforeGap(a: PChar; size: Integer); +var + rest: Integer; + e: PUsed; +begin + rest := size - sizeof(TUsed); + e := PUsed(a + rest); + if size >= sizeof(TFree) + sizeof(TUsed) then begin + e.sizeFlags := sizeof(TUsed) or cThisUsedFlag or cPrevFreeFlag or cFillerFlag; + InsertFree(a, rest); + end else if size >= sizeof(TUsed) then begin + PUsed(a).sizeFlags := size or (cThisUsedFlag or cFillerFlag); + e.sizeFlags := size or (cThisUsedFlag or cFillerFlag); + end; +end; + + +procedure InternalFreeMem(a: PChar); +begin + Inc(AllocMemCount); + Inc(AllocMemSize,PUsed(a-sizeof(TUsed)).sizeFlags and not cFlags - sizeof(TUsed)); + SysFreeMem(a); +end; + + +procedure FillAfterGap(a: PChar; size: Integer); +begin + if size >= sizeof(TFree) then begin + PUsed(a).sizeFlags := size or cThisUsedFlag; + InternalFreeMem(a + sizeof(TUsed)); + end else begin + if size >= sizeof(TUsed) then + PUsed(a).sizeFlags := size or (cThisUsedFlag or cFillerFlag); + Inc(a,size); + PUsed(a).sizeFlags := PUsed(a).sizeFlags and not cPrevFreeFlag; + end; +end; + + +function FillerSizeBeforeGap(a: PChar): Integer; +var + sizeFlags : Integer; + freeSize : Integer; + f : PFree; +begin + sizeFlags := PUsed(a - sizeof(TUsed)).sizeFlags; + if (sizeFlags and (cThisUsedFlag or cFillerFlag)) <> (cThisUsedFlag or cFillerFlag) then + heapErrorCode := cBadFiller1; + result := sizeFlags and not cFlags; + Dec(a, result); + if ((PUsed(a).sizeFlags xor sizeFlags) and not cPrevFreeFlag) <> 0 then + HeapErrorCode := cBadFiller2; + if (PUsed(a).sizeFlags and cPrevFreeFlag) <> 0 then begin + freeSize := PFree(a - sizeof(TFree)).size; + f := PFree(a - freeSize); + if f.size <> freeSize then + heapErrorCode := cBadFiller3; + DeleteFree(f); + Inc(result, freeSize); + end; +end; + + +function FillerSizeAfterGap(a: PChar): Integer; +var + sizeFlags: Integer; + f : PFree; +begin + result := 0; + sizeFlags := PUsed(a).sizeFlags; + if (sizeFlags and cFillerFlag) <> 0 then begin + sizeFlags := sizeFlags and not cFlags; + Inc(result,sizeFlags); + Inc(a, sizeFlags); + sizeFlags := PUsed(a).sizeFlags; + end; + if (sizeFlags and cThisUsedFlag) = 0 then begin + f := PFree(a); + DeleteFree(f); + Inc(result, f.size); + Inc(a, f.size); + PUsed(a).sizeFlags := PUsed(a).sizeFlags and not cPrevFreeFlag; + end; +end; + + +function DecommitFree(a: PChar; size: Integer): Boolean; +var + b: TBlock; + bd: PBlockDesc; +begin + Result := False; + bd := FindCommitted(a); + if bd = nil then Exit; + if bd.addr + bd.size - (a + size) <= sizeof(TFree) then + size := bd.addr + bd.size - a; + + if a - bd.addr < sizeof(TFree) then + b := FreeCommitted(bd.addr, size + (a - bd.addr)) + else + b := FreeCommitted(a + sizeof(TUsed), size - sizeof(TUsed)); + + if b.addr <> nil then + begin + FillBeforeGap(a, b.addr - a); + if bd.addr + bd.size > b.addr + b.size then + FillAfterGap(b.addr + b.size, a + size - (b.addr + b.size)); + RemoveBlock(bd,b); + result := True; + end; +end; + + +procedure InsertFree(a: Pointer; size: Integer); +var + f, n, p: PFree; +begin + f := PFree(a); + f.size := size; + PFree(PChar(f) + size - sizeof(TFree)).size := size; + if size <= cSmallSize then begin + n := smallTab[size div cAlign]; + if n = nil then begin + smallTab[size div cAlign] := f; + f.next := f; + f.prev := f; + end else begin + p := n.prev; + f.next := n; + f.prev := p; + n.prev := f; + p.next := f; + end; + end else if (size < cDecommitMin) or not DecommitFree(a, size) then begin + n := rover; + rover := f; + p := n.prev; + f.next := n; + f.prev := p; + n.prev := f; + p.next := f; + end; +end; + + +procedure FreeCurAlloc; +begin + if remBytes > 0 then begin + if remBytes < sizeof(TFree) then + heapErrorCode := cBadCurAlloc + else begin + PUsed(curAlloc).sizeFlags := remBytes or cThisUsedFlag; + InternalFreeMem(curAlloc + sizeof(TUsed)); + curAlloc := nil; + remBytes := 0; + end; + end; +end; + + +function MergeCommit(b: TBlock): Boolean; +var + merged: TBlock; + fSize: Integer; +begin + FreeCurAlloc; + merged := MergeBlockAfter(@committedRoot, b); + if merged.addr = nil then begin + result := False; + exit; + end; + + if merged.addr < b.addr then begin + fSize := FillerSizeBeforeGap(b.addr); + Dec(b.addr, fSize); + Inc(b.size, fSize); + end; + + if merged.addr + merged.size > b.addr + b.size then begin + fSize := FillerSizeAfterGap(b.addr + b.size); + Inc(b.size, fSize); + end; + + if merged.addr + merged.size = b.addr + b.size then begin + FillBeforeGap(b.addr + b.size - sizeof(TUsed), sizeof(TUsed)); + Dec(b.size, sizeof(TUsed)); + end; + + curAlloc := b.addr; + remBytes := b.size; + + result := True; +end; + + +function NewCommit(minSize: Integer): Boolean; +var + b: TBlock; +begin + b := GetCommitted(minSize+sizeof(TUsed)); + result := (b.addr <> nil) and MergeCommit(b); +end; + + +function NewCommitAt(addr: Pointer; minSize: Integer): Boolean; +var + b: TBlock; +begin + b := GetCommittedAt(addr, minSize+sizeof(TUsed)); + result := (b.addr <> nil) and MergeCommit(b); +end; + + +function SearchSmallBlocks(size: Integer): PFree; +var + i: Integer; +begin + result := nil; + for i := size div cAlign to High(smallTab^) do begin + result := smallTab[i]; + if result <> nil then + exit; + end; +end; + + +function TryHarder(size: Integer): Pointer; +var + u: PUsed; f:PFree; saveSize, rest: Integer; +begin + + repeat + + f := avail.next; + if (size <= f.size) then + break; + + f := rover; + if f.size >= size then + break; + + saveSize := f.size; + f.size := size; + repeat + f := f.next + until f.size >= size; + rover.size := saveSize; + if f <> rover then begin + rover := f; + break; + end; + + if size <= cSmallSize then begin + f := SearchSmallBlocks(size); + if f <> nil then + break; + end; + + if not NewCommit(size) then begin + result := nil; + exit; + end; + + if remBytes >= size then begin + Dec(remBytes, size); + if remBytes < sizeof(TFree) then begin + Inc(size, remBytes); + remBytes := 0; + end; + u := PUsed(curAlloc); + Inc(curAlloc, size); + u.sizeFlags := size or cThisUsedFlag; + result := PChar(u) + sizeof(TUsed); + Inc(AllocMemCount); + Inc(AllocMemSize,size - sizeof(TUsed)); + exit; + end; + + until False; + + DeleteFree(f); + + rest := f.size - size; + if rest >= sizeof(TFree) then begin + InsertFree(PChar(f) + size, rest); + end else begin + size := f.size; + if f = rover then + rover := f.next; + u := PUsed(PChar(f) + size); + u.sizeFlags := u.sizeFlags and not cPrevFreeFlag; + end; + + u := PUsed(f); + u.sizeFlags := size or cThisUsedFlag; + + result := PChar(u) + sizeof(TUsed); + Inc(AllocMemCount); + Inc(AllocMemSize,size - sizeof(TUsed)); + +end; + + +function SysGetMem(size: Integer): Pointer; +// Allocate memory block. +var + f, prev, next: PFree; + u: PUsed; +begin + + if (not initialized and not InitAllocator) or + (size > (High(size) - (sizeof(TUsed) + (cAlign-1)))) then + begin + result := nil; + exit; + end; + + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + Inc(size, sizeof(TUsed) + (cAlign-1)); + size := size and not (cAlign-1); + if size < sizeof(TFree) then + size := sizeof(TFree); + + if size <= cSmallSize then begin + f := smallTab[size div cAlign]; + if f <> nil then begin + u := PUsed(PChar(f) + size); + u.sizeFlags := u.sizeFlags and not cPrevFreeFlag; + next := f.next; + if next = f then + smallTab[size div cAlign] := nil + else begin + smallTab[size div cAlign] := next; + prev := f.prev; + prev.next := next; + next.prev := prev; + end; + u := PUsed(f); + u.sizeFlags := f.size or cThisUsedFlag; + result := PChar(u) + sizeof(TUsed); + Inc(AllocMemCount); + Inc(AllocMemSize,size - sizeof(TUsed)); + exit; + end; + end; + + if size <= remBytes then begin + Dec(remBytes, size); + if remBytes < sizeof(TFree) then begin + Inc(size, remBytes); + remBytes := 0; + end; + u := PUsed(curAlloc); + Inc(curAlloc, size); + u.sizeFlags := size or cThisUsedFlag; + result := PChar(u) + sizeof(TUsed); + Inc(AllocMemCount); + Inc(AllocMemSize,size - sizeof(TUsed)); + exit; + end; + + result := TryHarder(size); + + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; + +end; + + +function SysFreeMem(p: Pointer): Integer; +// Deallocate memory block. +label + abort; +var + u, n : PUsed; + f : PFree; + prevSize, nextSize, size : Integer; +begin + heapErrorCode := cHeapOk; + + if not initialized and not InitAllocator then begin + heapErrorCode := cCantInit; + result := cCantInit; + exit; + end; + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + u := p; + u := PUsed(PChar(u) - sizeof(TUsed)); { inv: u = address of allocated block being freed } + size := u.sizeFlags; + { inv: size = SET(block size) + [block flags] } + + { validate that the interpretation of this block as a used block is correct } + if (size and cThisUsedFlag) = 0 then begin + heapErrorCode := cBadUsedBlock; + goto abort; + end; + + { inv: the memory block addressed by 'u' and 'p' is an allocated block } + + Dec(AllocMemCount); + Dec(AllocMemSize,size and not cFlags - sizeof(TUsed)); + + if (size and cPrevFreeFlag) <> 0 then begin + { previous block is free, coalesce } + prevSize := PFree(PChar(u)-sizeof(TFree)).size; + if (prevSize < sizeof(TFree)) or ((prevSize and cFlags) <> 0) then begin + heapErrorCode := cBadPrevBlock; + goto abort; + end; + + f := PFree(PChar(u) - prevSize); + if f^.size <> prevSize then begin + heapErrorCode := cBadPrevBlock; + goto abort; + end; + + inc(size, prevSize); + u := PUsed(f); + DeleteFree(f); + end; + + size := size and not cFlags; + { inv: size = block size } + + n := PUsed(PChar(u) + size); + { inv: n = block following the block to free } + + if PChar(n) = curAlloc then begin + { inv: u = last block allocated } + dec(curAlloc, size); + inc(remBytes, size); + if remBytes > cDecommitMin then + FreeCurAlloc; + result := cHeapOk; + exit; + end; + + if (n.sizeFlags and cThisUsedFlag) <> 0 then begin + { inv: n is a used block } + if (n.sizeFlags and not cFlags) < sizeof(TUsed) then begin + heapErrorCode := cBadNextBlock; + goto abort; + end; + n.sizeFlags := n.sizeFlags or cPrevFreeFlag + end else begin + { inv: block u & n are both free; coalesce } + f := PFree(n); + if (f.next = nil) or (f.prev = nil) or (f.size < sizeof(TFree)) then begin + heapErrorCode := cBadNextBlock; + goto abort; + end; + nextSize := f.size; + inc(size, nextSize); + DeleteFree(f); + { inv: last block (which was free) is not on free list } + end; + + InsertFree(u, size); +abort: + result := heapErrorCode; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; +end; + + +function ResizeInPlace(p: Pointer; newSize: Integer): Boolean; +var u, n: PUsed; f: PFree; oldSize, blkSize, neededSize: Integer; +begin + Inc(newSize, sizeof(TUsed)+cAlign-1); + newSize := newSize and not (cAlign-1); + if newSize < sizeof(TFree) then + newSize := sizeof(TFree); + u := PUsed(PChar(p) - sizeof(TUsed)); + oldSize := u.sizeFlags and not cFlags; + n := PUsed( PChar(u) + oldSize ); + if newSize = oldSize then + begin + Result := True; + Exit; + end; + if newSize < oldSize then begin + blkSize := oldSize - newSize; + if PChar(n) = curAlloc then begin + Dec(curAlloc, blkSize); + Inc(remBytes, blkSize); + if remBytes < sizeof(TFree) then begin + Inc(curAlloc, blkSize); + Dec(remBytes, blkSize); + newSize := oldSize; + end; + end else begin + n := PUsed(PChar(u) + oldSize); + if n.sizeFlags and cThisUsedFlag = 0 then begin + f := PFree(n); + Inc(blkSize, f.size); + DeleteFree(f); + end; + if blkSize >= sizeof(TFree) then begin + n := PUsed(PChar(u) + newSize); + n.sizeFlags := blkSize or cThisUsedFlag; + InternalFreeMem(PChar(n) + sizeof(TUsed)); + end else + newSize := oldSize; + end; + end else begin + repeat + neededSize := newSize - oldSize; + if PChar(n) = curAlloc then begin + if remBytes >= neededSize then begin + Dec(remBytes, neededSize); + Inc(curAlloc, neededSize); + if remBytes < sizeof(TFree) then begin + Inc(curAlloc, remBytes); + Inc(newSize, remBytes); + remBytes := 0; + end; + Inc(AllocMemSize, newSize - oldSize); + u.sizeFlags := newSize or u.sizeFlags and cFlags; + result := true; + exit; + end else begin + FreeCurAlloc; + n := PUsed( PChar(u) + oldSize ); + end; + end; + + if n.sizeFlags and cThisUsedFlag = 0 then begin + f := PFree(n); + blkSize := f.size; + if blkSize < neededSize then begin + n := PUsed(PChar(n) + blkSize); + Dec(neededSize, blkSize); + end else begin + DeleteFree(f); + Dec(blkSize, neededSize); + if blkSize >= sizeof(TFree) then + InsertFree(PChar(u) + newSize, blkSize) + else begin + Inc(newSize, blkSize); + n := PUsed(PChar(u) + newSize); + n.sizeFlags := n.sizeFlags and not cPrevFreeFlag; + end; + break; + end; + end; + + if n.sizeFlags and cFillerFlag <> 0 then begin + n := PUsed(PChar(n) + n.sizeFlags and not cFlags); + if NewCommitAt(n, neededSize) then begin + n := PUsed( PChar(u) + oldSize ); + continue; + end; + end; + + result := False; + exit; + + until False; + + end; + + Inc(AllocMemSize, newSize - oldSize); + u.sizeFlags := newSize or u.sizeFlags and cFlags; + result := True; + +end; + + +function SysReallocMem(p: Pointer; size: Integer): Pointer; +// Resize memory block. +var + n: Pointer; oldSize: Integer; +begin + + if not initialized and not InitAllocator then begin + result := nil; + exit; + end; + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + if ResizeInPlace(p, size) then + result := p + else begin + n := SysGetMem(size); + oldSize := (PUsed(PChar(p)-sizeof(PUsed)).sizeFlags and not cFlags) - sizeof(TUsed); + if oldSize > size then + oldSize := size; + if n <> nil then begin + Move(p^, n^, oldSize); + SysFreeMem(p); + end; + result := n; + end; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; + +end; + + +function BlockSum(root: PBlockDesc): Integer; +var + b : PBlockDesc; +begin + result := 0; + b := root.next; + while b <> root do begin + Inc(result, b.size); + b := b.next; + end; +end; + + +function GetHeapStatus: THeapStatus; +var + size, freeSize, userSize: Cardinal; + f: PFree; + a, e: PChar; + i: Integer; + b: PBlockDesc; + prevFree: Boolean; +begin + + result.TotalAddrSpace := 0; + result.TotalUncommitted := 0; + result.TotalCommitted := 0; + result.TotalAllocated := 0; + result.TotalFree := 0; + result.FreeSmall := 0; + result.FreeBig := 0; + result.Unused := 0; + result.Overhead := 0; + result.HeapErrorCode := cHeapOk; + + if not initialized then exit; + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + result.totalAddrSpace := BlockSum(@spaceRoot); + result.totalUncommitted := BlockSum(@decommittedRoot); + result.totalCommitted := BlockSum(@committedRoot); + + size := 0; + for i := Low(smallTab^) to High(smallTab^) do begin + f := smallTab[i]; + if f <> nil then begin + repeat + Inc(size, f.size); + if (f.prev.next <> f) or (f.next.prev <> f) or (f.size < sizeof(TFree)) then begin + heapErrorCode := cBadFreeList; + break; + end; + f := f.next; + until f = smallTab[i]; + end; + end; + result.freeSmall := size; + + size := 0; + f := avail.next; + while f <> @avail do begin + if (f.prev.next <> f) or (f.next.prev <> f) or (f.size < sizeof(TFree)) then begin + heapErrorCode := cBadFreeList; + break; + end; + Inc(size, f.size); + f := f.next; + end; + result.freeBig := size; + + result.unused := remBytes; + result.totalFree := result.freeSmall + result.freeBig + result.unused; + + freeSize := 0; + userSize := 0; + result.overhead := 0; + + b := committedRoot.next; + prevFree := False; + while b <> @committedRoot do begin + a := b.addr; + e := a + b.size; + while a < e do begin + if (a = curAlloc) and (remBytes > 0) then begin + size := remBytes; + Inc(freeSize, size); + if prevFree then + heapErrorCode := cBadCurAlloc; + prevFree := False; + end else begin + if prevFree <> ((PUsed(a).sizeFlags and cPrevFreeFlag) <> 0) then + heapErrorCode := cBadNextBlock; + if (PUsed(a).sizeFlags and cThisUsedFlag) = 0 then begin + f := PFree(a); + if (f.prev.next <> f) or (f.next.prev <> f) or (f.size < sizeof(TFree)) then + heapErrorCode := cBadFreeBlock; + size := f.size; + Inc(freeSize, size); + prevFree := True; + end else begin + size := PUsed(a).sizeFlags and not cFlags; + if (PUsed(a).sizeFlags and cFillerFlag) <> 0 then begin + Inc(result.overhead, size); + if (a > b.addr) and (a + size < e) then + heapErrorCode := cBadUsedBlock; + end else begin + Inc(userSize, size-sizeof(TUsed)); + Inc(result.overhead, sizeof(TUsed)); + end; + prevFree := False; + end; + end; + Inc(a, size); + end; + b := b.next; + end; + if result.totalFree <> freeSize then + heapErrorCode := cBadBalance; + + result.totalAllocated := userSize; + result.heapErrorCode := heapErrorCode; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; +end; + + +// this section goes into GetMem.Inc + +{$IFDEF DEBUG_FUNCTIONS} +type + THeapReportProc = procedure(HeapBlock: Pointer; AllocatedSize: Integer) of object; + + +procedure WalkHeap(HeapReportProc: THeapReportProc); +var + size : Cardinal; + f: PFree; + a, e: PChar; + b: PBlockDesc; +begin + + if not initialized then exit; + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + b := committedRoot.next; + while b <> @committedRoot do begin + a := b.addr; + e := a + b.size; + while a < e do begin + if (a = curAlloc) and (remBytes > 0) then begin + size := remBytes; + end else begin + if (PUsed(a).sizeFlags and cThisUsedFlag) = 0 then begin + f := PFree(a); + size := f.size; + end else begin + size := PUsed(a).sizeFlags and not cFlags; + if (PUsed(a).sizeFlags and cFillerFlag) = 0 then begin + HeapReportProc(a + sizeof(TUsed), size - sizeof(TUsed)); + end; + end; + end; + Inc(a, size); + end; + b := b.next; + end; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; +end; + +type + THeapBlockCollector = class(TObject) + FCount: Integer; + FObjectTable: TObjectArray; + FHeapBlockTable: THeapBlockArray; + FClass: TClass; + FFindDerived: Boolean; + procedure CollectBlocks(HeapBlock: Pointer; AllocatedSize: Integer); + procedure CollectObjects(HeapBlock: Pointer; AllocatedSize: Integer); + end; + + +procedure THeapBlockCollector.CollectBlocks(HeapBlock: Pointer; AllocatedSize: Integer); +begin + if FCount < Length(FHeapBlockTable) then + begin + FHeapBlockTable[FCount].Start := HeapBlock; + FHeapBlockTable[FCount].Size := AllocatedSize; + end; + Inc(FCount); +end; + + +procedure THeapBlockCollector.CollectObjects(HeapBlock: Pointer; AllocatedSize: Integer); +var + AObject: TObject; + AClass: TClass; +type + PPointer = ^Pointer; +begin + try + if AllocatedSize < 4 then + Exit; + AObject := TObject(HeapBlock); + AClass := AObject.ClassType; + if (AClass = FClass) + or (FFindDerived + and (Integer(AClass) >= 64*1024) + and (PPointer(PChar(AClass) + vmtSelfPtr)^ = Pointer(AClass)) + and (AObject is FClass)) then + begin + if FCount < Length(FObjectTable) then + FObjectTable[FCount] := AObject; + Inc(FCount); + end; + except + // Let's not worry about this block - it's obviously not a valid object + end; +end; + +var + HeapBlockCollector: THeapBlockCollector; + +function GetHeapBlocks: THeapBlockArray; +begin + if not Assigned(HeapBlockCollector) then + HeapBlockCollector := THeapBlockCollector.Create; + + Walkheap(HeapBlockCollector.CollectBlocks); + SetLength(HeapBlockCollector.FHeapBlockTable, HeapBlockCollector.FCount); + HeapBlockCollector.FCount := 0; + Walkheap(HeapBlockCollector.CollectBlocks); + Result := HeapBlockCollector.FHeapBlockTable; + HeapBlockCollector.FCount := 0; + HeapBlockCollector.FHeapBlockTable := nil; +end; + + +function FindObjects(AClass: TClass; FindDerived: Boolean): TObjectArray; +begin + if not Assigned(HeapBlockCollector) then + HeapBlockCollector := THeapBlockCollector.Create; + HeapBlockCollector.FClass := AClass; + HeapBlockCollector.FFindDerived := FindDerived; + + Walkheap(HeapBlockCollector.CollectObjects); + SetLength(HeapBlockCollector.FObjectTable, HeapBlockCollector.FCount); + HeapBlockCollector.FCount := 0; + Walkheap(HeapBlockCollector.CollectObjects); + Result := HeapBlockCollector.FObjectTable; + HeapBlockCollector.FCount := 0; + HeapBlockCollector.FObjectTable := nil; +end; +{$ENDIF} + + diff --git a/System/D7_ECM/makefile b/System/D7_ECM/makefile new file mode 100644 index 0000000..d997a51 --- /dev/null +++ b/System/D7_ECM/makefile @@ -0,0 +1,43 @@ +# ****************************************************************** +# * * +# * DELPHI7 KOL RTL Replacement * +# * MAKE script * +# * * +# * (C) 2005 by ECM * +# * * +# ****************************************************************** + +# To build the runtime library without debug information (the default), +# simply run MAKE.EXE from the directory containing this MAKEFILE. To +# build a debug version of the runtime library, specify a -DDEBUG command +# line parameter when running MAKE.EXE. + +DCC = dcc32 -q + +BIN = bin +LIB = lib + +!if $d(DEBUG) +RTLDEBUG = -$$D+ +!else +RTLDEBUG = -$$D- +!endif + +default: \ +system.dcu \ +SysConst.dcu \ +SysSfIni.dcu \ +SysWStr.dcu + + +system.dcu: system.pas sysinit.pas getmem.inc + $(DCC) system -m -y -z $(RTLDEBUG) + +SysConst.dcu: SysConst.pas system.dcu + $(DCC) SysConst -z $(RTLDEBUG) + +SysSfIni.dcu: SysSfIni.pas + $(DCC) SysSfIni -z $(RTLDEBUG) + +SysWStr.dcu: SysWStr.pas + $(DCC) SysWStr -z $(RTLDEBUG) \ No newline at end of file diff --git a/System/D7_avenger/SYSWSTR.PAS b/System/D7_avenger/SYSWSTR.PAS new file mode 100644 index 0000000..ab8a677 --- /dev/null +++ b/System/D7_avenger/SYSWSTR.PAS @@ -0,0 +1,18 @@ +unit syswstr; +{X: this unit contains some definitions and initializations, needed to + support wide string variables. To use it, just place reference to syswstr + unit in your dpr/units uses clause *as first as possible* } + +interface + +implementation + +initialization + + WStrAddRefProc := WStrAddRef; + WStrClrProc := WStrClr; + WStrArrayClrProc := WStrArrayClr; + +finalization + +end. diff --git a/System/D7_avenger/SysConst.pas b/System/D7_avenger/SysConst.pas new file mode 100644 index 0000000..c0f6754 --- /dev/null +++ b/System/D7_avenger/SysConst.pas @@ -0,0 +1,184 @@ +{ *********************************************************************** } +{ } +{ Delphi / Kylix Cross-Platform Runtime Library } +{ } +{ Copyright (c) 1995, 2001 Borland Software Corporation } +{ } +{ *********************************************************************** } + +unit SysConst; + +interface + +resourcestring + SUnknown = ''; + SInvalidInteger = '''%s'' is not a valid integer value'; + SInvalidFloat = '''%s'' is not a valid floating point value'; + SInvalidCurrency = '''%s'' is not a valid currency value'; + SInvalidDate = '''%s'' is not a valid date'; + SInvalidTime = '''%s'' is not a valid time'; + SInvalidDateTime = '''%s'' is not a valid date and time'; + SInvalidDateTimeFloat = '''%g'' is not a valid date and time'; + SInvalidTimeStamp = '''%d.%d'' is not a valid timestamp'; + SInvalidGUID = '''%s'' is not a valid GUID value'; + SInvalidBoolean = '''%s'' is not a valid boolean value'; + STimeEncodeError = 'Invalid argument to time encode'; + SDateEncodeError = 'Invalid argument to date encode'; + SOutOfMemory = 'Out of memory'; + SInOutError = 'I/O error %d'; + SFileNotFound = 'File not found'; + SInvalidFilename = 'Invalid filename'; + STooManyOpenFiles = 'Too many open files'; + SAccessDenied = 'File access denied'; + SEndOfFile = 'Read beyond end of file'; + SDiskFull = 'Disk full'; + SInvalidInput = 'Invalid numeric input'; + SDivByZero = 'Division by zero'; + SRangeError = 'Range check error'; + SIntOverflow = 'Integer overflow'; + SInvalidOp = 'Invalid floating point operation'; + SZeroDivide = 'Floating point division by zero'; + SOverflow = 'Floating point overflow'; + SUnderflow = 'Floating point underflow'; + SInvalidPointer = 'Invalid pointer operation'; + SInvalidCast = 'Invalid class typecast'; +{$IFDEF MSWINDOWS} + SAccessViolationArg3 = 'Access violation at address %p. %s of address %p'; +{$ENDIF} +{$IFDEF LINUX} + SAccessViolationArg2 = 'Access violation at address %p, accessing address %p'; +{$ENDIF} + SAccessViolationNoArg = 'Access violation'; + SStackOverflow = 'Stack overflow'; + SControlC = 'Control-C hit'; + SQuit = 'Quit key hit'; + SPrivilege = 'Privileged instruction'; + SOperationAborted = 'Operation aborted'; + SException = 'Exception %s in module %s at %p.' + sLineBreak + '%s%s' + sLineBreak; + SExceptTitle = 'Application Error'; +{$IFDEF LINUX} + SSigactionFailed = 'sigaction call failed'; +{$ENDIF} + SInvalidFormat = 'Format ''%s'' invalid or incompatible with argument'; + SArgumentMissing = 'No argument for format ''%s'''; + SDispatchError = 'Variant method calls not supported'; + SReadAccess = 'Read'; + SWriteAccess = 'Write'; + SResultTooLong = 'Format result longer than 4096 characters'; + SFormatTooLong = 'Format string too long'; + + SVarArrayCreate = 'Error creating variant or safe array'; + SVarArrayBounds = 'Variant or safe array index out of bounds'; + SVarArrayLocked = 'Variant or safe array is locked'; + SVarArrayWithHResult = 'Unexpected variant or safe array error: %s%.8x'; + + SInvalidVarCast = 'Invalid variant type conversion'; + SInvalidVarOp = 'Invalid variant operation'; + SInvalidVarNullOp = 'Invalid NULL variant operation'; + SInvalidVarOpWithHResultWithPrefix = 'Invalid variant operation (%s%.8x)'#10'%s'; + SVarTypeRangeCheck1 = 'Range check error for variant of type (%s)'; + SVarTypeRangeCheck2 = 'Range check error while converting variant of type (%s) into type (%s)'; + SVarTypeOutOfRangeWithPrefix = 'Custom variant type (%s%.4x) is out of range'; + SVarTypeAlreadyUsedWithPrefix = 'Custom variant type (%s%.4x) already used by %s'; + SVarTypeNotUsableWithPrefix = 'Custom variant type (%s%.4x) is not usable'; + SVarTypeTooManyCustom = 'Too many custom variant types have been registered'; + + // the following are not used anymore + SVarNotArray = 'Variant is not an array' deprecated; // not used, use SVarInvalid instead + SVarTypeUnknown = 'Unknown custom variant type ($%.4x)' deprecated; // not used anymore + SVarTypeOutOfRange = 'Custom variant type ($%.4x) is out of range' deprecated; + SVarTypeAlreadyUsed = 'Custom variant type ($%.4x) already used by %s' deprecated; + SVarTypeNotUsable = 'Custom variant type ($%.4x) is not usable' deprecated; + SInvalidVarOpWithHResult = 'Invalid variant operation ($%.8x)' deprecated; + + SVarTypeCouldNotConvert = 'Could not convert variant of type (%s) into type (%s)'; + SVarTypeConvertOverflow = 'Overflow while converting variant of type (%s) into type (%s)'; + SVarOverflow = 'Variant overflow'; + SVarInvalid = 'Invalid argument'; + SVarBadType = 'Invalid variant type'; + SVarNotImplemented = 'Operation not supported'; + SVarOutOfMemory = 'Variant operation ran out memory'; + SVarUnexpected = 'Unexpected variant error'; + + SVarDataClearRecursing = 'Recursion while doing a VarDataClear'; + SVarDataCopyRecursing = 'Recursion while doing a VarDataCopy'; + SVarDataCopyNoIndRecursing = 'Recursion while doing a VarDataCopyNoInd'; + SVarDataInitRecursing = 'Recursion while doing a VarDataInit'; + SVarDataCastToRecursing = 'Recursion while doing a VarDataCastTo'; + SVarIsEmpty = 'Variant is empty'; + sUnknownFromType = 'Cannot convert from the specified type'; + sUnknownToType = 'Cannot convert to the specified type'; + SExternalException = 'External exception %x'; + SAssertionFailed = 'Assertion failed'; + SIntfCastError = 'Interface not supported'; + SSafecallException = 'Exception in safecall method'; + SAssertError = '%s (%s, line %d)'; + SAbstractError = 'Abstract Error'; + SModuleAccessViolation = 'Access violation at address %p in module ''%s''. %s of address %p'; + SCannotReadPackageInfo = 'Cannot access package information for package ''%s'''; + sErrorLoadingPackage = 'Can''t load package %s.'+sLineBreak+'%s'; + SInvalidPackageFile = 'Invalid package file ''%s'''; + SInvalidPackageHandle = 'Invalid package handle'; + SDuplicatePackageUnit = 'Cannot load package ''%s.'' It contains unit ''%s,''' + + 'which is also contained in package ''%s'''; + SOSError = 'System Error. Code: %d.'+sLineBreak+'%s'; + SUnkOSError = 'A call to an OS function failed'; +{$IFDEF MSWINDOWS} + SWin32Error = 'Win32 Error. Code: %d.'#10'%s' deprecated; // use SOSError + SUnkWin32Error = 'A Win32 API function failed' deprecated; // use SUnkOSError +{$ENDIF} + SNL = 'Application is not licensed to use this feature'; + + SShortMonthNameJan = 'Jan'; + SShortMonthNameFeb = 'Feb'; + SShortMonthNameMar = 'Mar'; + SShortMonthNameApr = 'Apr'; + SShortMonthNameMay = 'May'; + SShortMonthNameJun = 'Jun'; + SShortMonthNameJul = 'Jul'; + SShortMonthNameAug = 'Aug'; + SShortMonthNameSep = 'Sep'; + SShortMonthNameOct = 'Oct'; + SShortMonthNameNov = 'Nov'; + SShortMonthNameDec = 'Dec'; + + SLongMonthNameJan = 'January'; + SLongMonthNameFeb = 'February'; + SLongMonthNameMar = 'March'; + SLongMonthNameApr = 'April'; + SLongMonthNameMay = 'May'; + SLongMonthNameJun = 'June'; + SLongMonthNameJul = 'July'; + SLongMonthNameAug = 'August'; + SLongMonthNameSep = 'September'; + SLongMonthNameOct = 'October'; + SLongMonthNameNov = 'November'; + SLongMonthNameDec = 'December'; + + SShortDayNameSun = 'Sun'; + SShortDayNameMon = 'Mon'; + SShortDayNameTue = 'Tue'; + SShortDayNameWed = 'Wed'; + SShortDayNameThu = 'Thu'; + SShortDayNameFri = 'Fri'; + SShortDayNameSat = 'Sat'; + + SLongDayNameSun = 'Sunday'; + SLongDayNameMon = 'Monday'; + SLongDayNameTue = 'Tuesday'; + SLongDayNameWed = 'Wednesday'; + SLongDayNameThu = 'Thursday'; + SLongDayNameFri = 'Friday'; + SLongDayNameSat = 'Saturday'; + +{$IFDEF LINUX} + SEraEntries = ''; +{$ENDIF} + + SCannotCreateDir = 'Unable to create directory'; + SCodesetConversionError = 'Codeset conversion failure'; + +implementation + +end. + diff --git a/System/D7_avenger/SysInit.pas b/System/D7_avenger/SysInit.pas new file mode 100644 index 0000000..787c279 --- /dev/null +++ b/System/D7_avenger/SysInit.pas @@ -0,0 +1,858 @@ +{ *********************************************************************** } +{ } +{ Delphi / Kylix Cross-Platform Runtime Library } +{ System Initialization Unit } +{ } +{ Copyright (c) 1997-2002 Borland Software Corporation } +{ } +{ This file may be distributed and/or modified under the terms of the } +{ GNU General Public License version 2 as published by the Free Software } +{ Foundation and appearing at http://www.borland.com/kylix/gpl.html. } +{ } +{ Licensees holding a valid Borland No-Nonsense License for this } +{ Software may use this file in accordance with such license, which } +{ appears in the file license.txt that came with this software. } +{ } +{ *********************************************************************** } + +unit SysInit; +//Изменено: Avenger + +interface + +{$H+,I-,R-,S-,O+,W-} +{$WARN SYMBOL_PLATFORM OFF} + +{X} // if your app really need to localize resource, call: +{X} procedure UseLocalizeResources; + +{$IFDEF LINUX} +const + ExeBaseAddress = Pointer($8048000) platform; +{$ENDIF} + +var + Copyright : String = ''; //'Portions Copyright (c) 1999,2003 Avenger by NhT'; + + ModuleIsLib: Boolean; { True if this module is a dll (a library or a package) } + ModuleIsPackage: Boolean; { True if this module is a package } + ModuleIsCpp: Boolean; { True if this module is compiled using C++ Builder } + TlsIndex: Integer = -1; { Thread local storage index } + TlsLast: Byte; { Set by linker so its offset is last in TLS segment } + HInstance: LongWord; { Handle of this instance } + {$EXTERNALSYM HInstance} + (*$HPPEMIT 'namespace Sysinit' *) + (*$HPPEMIT '{' *) + (*$HPPEMIT 'extern PACKAGE HINSTANCE HInstance;' *) + (*$HPPEMIT '} /* namespace Sysinit */' *) + DllProc: TDLLProc; { Called whenever DLL entry point is called } + { DllProcEx passes the Reserved param provided by WinNT on DLL load & exit } + DllProcEx: TDLLProcEx absolute DllProc; + DataMark: Integer = 0; { Used to find the virtual base of DATA seg } + CoverageLibraryName: array [0..128] of char = '*'; { initialized by the linker! } +{$IFDEF ELF} + TypeImportsTable: array [0..0] of Pointer platform; { VMT and RTTI imports table for exes } + _GLOBAL_OFFSET_TABLE_: ARRAY [0..2] OF Cardinal platform; + (* _DYNAMIC: ARRAY [0..0] OF Elf32_Dyn; *) +{$IFDEF PC_MAPPED_EXCEPTIONS} + TextStartAdj: Byte platform; { See GetTextStart } + CodeSegSize: Byte platform; { See GetTextStart } +function GetTextStart : LongInt; platform; +{$ENDIF} +{$ENDIF} + +const + PtrToNil: Pointer = nil; // provides pointer to nil for compiler codegen + +function _GetTls: Pointer; +{$IFDEF LINUX} +procedure _InitLib(Context: PInitContext); +procedure _GetCallerEIP; +procedure _InitExe(InitTable: Pointer; Argc: Integer; Argp: Pointer); +procedure _start; cdecl; +function _ExitLib: Integer; cdecl; +function _InitPkg: LongBool; +{$ENDIF} +{$IFDEF MSWINDOWS} +procedure _InitLib; +procedure _InitExe(InitTable: Pointer); +function _InitPkg(Hinst: Integer; Reason: Integer; Resvd: Pointer): LongBool; stdcall; +{$ENDIF} +procedure _PackageLoad(const Table: PackageInfo); +procedure _PackageUnload(const Table: PackageInfo); + +{ Invoked by C++ startup code to allow initialization of VCL global vars } +procedure VclInit(isDLL, isPkg: Boolean; hInst: LongInt; isGui: Boolean); cdecl; +procedure VclExit; cdecl; + +{$IFDEF LINUX} +function GetThisModuleHandle: LongWord; +{$ENDIF} + +implementation + +{$IFDEF MSWINDOWS} +const + kernel = 'kernel32.dll'; + +function FreeLibrary(ModuleHandle: Longint): LongBool; stdcall; + external kernel name 'FreeLibrary'; + +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 LocalAlloc(flags, size: Integer): Pointer; stdcall; + external kernel name 'LocalAlloc'; + +function LocalFree(addr: Pointer): Pointer; stdcall; + external kernel name 'LocalFree'; + +function TlsAlloc: Integer; stdcall; + external kernel name 'TlsAlloc'; + +function TlsFree(TlsIndex: Integer): Boolean; stdcall; + external kernel name 'TlsFree'; + +function TlsGetValue(TlsIndex: Integer): Pointer; stdcall; + external kernel name 'TlsGetValue'; + +function TlsSetValue(TlsIndex: Integer; TlsValue: Pointer): Boolean; stdcall; + external kernel name 'TlsSetValue'; + +function GetCommandLine: PChar; stdcall; + external kernel name 'GetCommandLineA'; + +const + tlsArray = $2C; { offset of tls array from FS: } + LMEM_ZEROINIT = $40; + +function AllocTlsBuffer(Size: Integer): Pointer; +begin + Result := LocalAlloc(LMEM_ZEROINIT, Size); +end; + +var + tlsBuffer: Pointer; // RTM32 DOS support +{$ENDIF} + +{$IFDEF LINUX} + +{$IFDEF PIC} +function GetGOT: Pointer; export; +begin + asm + MOV Result,EBX + end; +end; +{$ENDIF} + +const + RTLD_LAZY = 1; + RTLD_NOW = 2; + RTLD_BINDING_MASK = RTLD_LAZY or RTLD_NOW; + RTLD_GLOBAL = $100; + RTLD_LOCAL = 0; + RTLD_NEXT = Pointer(-1); + RTLD_DEFAULT = nil; + +type + TDLInfo = record + Filename: PChar; + BaseAddress: Pointer; + NearestSymbolName: PChar; + NearestSymbolAddr: Pointer; + end; + +const + libcmodulename = 'libc.so.6'; + libdlmodulename = 'libdl.so.2'; + libpthreadmodulename = 'libpthread.so.0'; + tlsSizeName = '@Sysinit@tlsSize'; + +function malloc(Size: LongWord): Pointer; cdecl; + external libcmodulename name 'malloc'; + +procedure free(P: Pointer); cdecl; + external libcmodulename name 'free'; + +function dlopen(Filename: PChar; Flag: Integer): LongWord; cdecl; + external libdlmodulename name 'dlopen'; + +function dlerror: PChar; cdecl; + external libdlmodulename name 'dlerror'; + +function dlsym(Handle: LongWord; Symbol: PChar): Pointer; cdecl; + external libdlmodulename name 'dlsym'; + +function dlclose(Handle: LongWord): Integer; cdecl; + external libdlmodulename name 'dlclose'; + +function FreeLibrary(Handle: LongWord): Integer; cdecl; + external libdlmodulename name 'dlclose'; + +function dladdr(Address: Pointer; var Info: TDLInfo): Integer; cdecl; + external libdlmodulename name 'dladdr'; + +type + TInitOnceProc = procedure; cdecl; + TKeyValueDestructor = procedure(ValueInKey: Pointer); cdecl; + +function pthread_once(var InitOnceSemaphore: Integer; InitOnceProc: TInitOnceProc): Integer; cdecl; + external libpthreadmodulename name 'pthread_once'; + +function pthread_key_create(var Key: Integer; KeyValueDestructor: TKeyValueDestructor): Integer; cdecl; + external libpthreadmodulename name 'pthread_key_create'; + +function pthread_key_delete(Key: Integer): Integer; cdecl; + external libpthreadmodulename name 'pthread_key_delete'; + +function TlsGetValue(Key: Integer): Pointer; cdecl; + external libpthreadmodulename name 'pthread_getspecific'; + +function TlsSetValue(Key: Integer; Ptr: Pointer): Integer; cdecl; + external libpthreadmodulename name 'pthread_setspecific'; + +function AllocTlsBuffer(Size: Cardinal): Pointer; +begin + // The C++ rtl handles all tls in a C++ module + if ModuleIsCpp then + RunError(226); + + Result := malloc(Size); + if Result <> nil then + FillChar(Result^, Size, 0); +end; + +procedure FreeTLSBuffer(ValueInKey: Pointer); export cdecl; +begin + // The C++ rtl handles all tls in a C++ module + if ModuleIsCpp then + RunError(226); + free(ValueInKey); +end; + +procedure AllocTlsIndex; cdecl export; +begin + // guaranteed to reach here only once per process + // The C++ rtl handles all tls in a C++ module + if ModuleIsCpp then + RunError(226); + if pthread_key_create(TlsIndex, FreeTLSBuffer) <> 0 then + begin + TlsIndex := -1; + RunError(226); + end; +end; + +function GetThisModuleHandle: LongWord; +var + Info: TDLInfo; +begin + if (dladdr(@GetThisModuleHandle, Info) = 0) or (Info.BaseAddress = ExeBaseAddress) then + Info.FileName := nil; // if we're not in a library, we must be main exe + Result := LongWord(dlopen(Info.Filename, RTLD_LAZY)); + if Result <> 0 then + dlclose(Result); +end; + +var + InitOnceSemaphore: Integer; +{$ENDIF} + +var + Module: TLibModule = ( + Next: nil; + Instance: 0; + CodeInstance: 0; + DataInstance: 0; + ResInstance: 0; + Reserved: 0 +{$IFDEF LINUX} + ; InstanceVar: nil; + GOT: 0; + CodeSegStart: 0; + CodeSegEnd: 0 + ); +{$ELSE} + ); +{$ENDIF} + +function GetTlsSize: Integer; +{$IFDEF LINUX} +asm + MOV EAX, offset TlsLast +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +begin + Result := Integer(@TlsLast); +end; +{$ENDIF} + +procedure InitThreadTLS; +var + p: Pointer; + tlsSize: Integer; +begin + tlsSize := GetTlsSize; + if tlsSize = 0 then Exit; +{$IFDEF LINUX} + pthread_once(InitOnceSemaphore, AllocTlsIndex); +{$ENDIF} + if TlsIndex = -1 then RunError(226); + p := AllocTlsBuffer(tlsSize); + if p = nil then + RunError(226) + else + TlsSetValue(TlsIndex, p); +end; + +{$IFDEF MSWINDOWS} +procedure InitProcessTLS; +begin + if @TlsLast = nil then + Exit; + TlsIndex := TlsAlloc; + InitThreadTLS; + tlsBuffer := TlsGetValue(TlsIndex); // RTM32 DOS support +end; + +procedure ExitThreadTLS; +var + p: Pointer; +begin + if @TlsLast = nil then + Exit; + if TlsIndex <> -1 then begin + p := TlsGetValue(TlsIndex); + if p <> nil then + LocalFree(p); + end; +end; + +procedure ExitProcessTLS; +begin + if @TlsLast = nil then + Exit; + ExitThreadTLS; + if TlsIndex <> -1 then + TlsFree(TlsIndex); +end; +{$ENDIF} + +const + DLL_PROCESS_DETACH = 0; + DLL_PROCESS_ATTACH = 1; + DLL_THREAD_ATTACH = 2; + DLL_THREAD_DETACH = 3; + +function _GetTls: Pointer; +{$IFDEF LINUX} +begin + Result := TlsGetValue(TlsIndex); + if Result = nil then + begin + InitThreadTLS; + Result := TlsGetValue(TlsIndex); + end; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + MOV CL,ModuleIsLib + MOV EAX,TlsIndex + TEST CL,CL + JNE @@isDll + MOV EDX,FS:tlsArray + MOV EAX,[EDX+EAX*4] + RET + +@@initTls: + CALL InitThreadTLS + MOV EAX,TlsIndex + PUSH EAX + CALL TlsGetValue + TEST EAX,EAX + JE @@RTM32 + RET + +@@RTM32: + MOV EAX, tlsBuffer + RET + +@@isDll: + PUSH EAX + CALL TlsGetValue + TEST EAX,EAX + JE @@initTls +end; + +const + TlsProc: array [DLL_PROCESS_DETACH..DLL_THREAD_DETACH] of procedure = + (ExitProcessTLS,InitProcessTLS,InitThreadTLS,ExitThreadTLS); +{$ENDIF} + +{$IFDEF PC_MAPPED_EXCEPTIONS} +const + UNWINDFI_TOPOFSTACK = $BE00EF00; + +{ + The linker sets the value of TextStartAdj to be the delta between GetTextStart + and the start of the text segment. This allows us to get the pointer to the + start of the text segment in a position independent fashion. +} +function GetTextStart : LongInt; +asm + CALL @@label1 +@@label1: + POP EAX + SUB EAX, 5 + offset TextStartAdj +end; + +{ + The linker sets the value of CodeSegSize to the length of the text segment, + excluding the PC map. This allows us to get the pointer to the exception + information that we need at runtime, also in a position independent fashion. +} +function GetTextEnd : LongInt; +asm + CALL GetTextStart + ADD EAX, offset CodeSegSize +end; +{$ENDIF} + +procedure InitializeModule; +begin + RegisterModule(@Module); +end; + +procedure UseLocalizeResources; +var + FileName: array[0..260] of Char; +begin + GetModuleFileName(HInstance, FileName, SizeOf(FileName)); + Module.ResInstance := LoadResourceModule(FileName); + if Module.ResInstance = 0 then + Module.ResInstance := Module.Instance; +end; + +procedure UninitializeModule; +begin + UnregisterModule(@Module); + if (Module.ResInstance <> Module.Instance) and (Module.ResInstance <> 0) then + FreeLibrary(Module.ResInstance); +end; + +procedure VclInit(isDLL, isPkg: Boolean; hInst: LongInt; isGui: Boolean); cdecl; +begin + ModuleIsLib := isDLL; + ModuleIsPackage := isPkg; + IsLibrary := isDLL and not isPkg; + HInstance := hInst; + Module.Instance := hInst; + Module.CodeInstance := 0; + Module.DataInstance := 0; + ModuleIsCpp := True; +{$IFDEF LINUX} + if ModuleIsLib then + Module.InstanceVar := @HInstance; +{$IFDEF PIC} + Module.GOT := LongWord(GetGot); +{$ENDIF} + { Module.CodeSegStart, Module.CodeSegEnd not used: the C++ + rtl will feed the unwinder. } +{$ENDIF} + InitializeModule; + if not ModuleIsLib then + begin + Module.CodeInstance := FindHInstance(@VclInit); + Module.DataInstance := FindHInstance(@DataMark); +{$IFDEF MSWINDOWS} +{X CmdLine := GetCommandLine; - converted to a function } + IsConsole := not isGui; +{$ENDIF} + end; +end; + +procedure VclExit; cdecl; +var + P: procedure; +begin + if not ModuleIsLib then + while ExitProc <> nil do + begin + @P := ExitProc; + ExitProc := nil; + P; + end; + UnInitializeModule; +end; + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure RegisterPCMap; +begin + SysRegisterIPLookup(GetTextStart, + GetTextEnd, + Pointer(GetTextEnd), + LongWord(@_Global_Offset_Table_)); +end; + +procedure UnregisterPCMap; +begin + SysUnregisterIPLookup(GetTextStart); +end; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function _InitPkg(Hinst: Longint; Reason: Integer; Resvd: Pointer): Longbool; stdcall; +begin + ModuleIsLib := True; + ModuleIsPackage := True; + Module.Instance := Hinst; + Module.CodeInstance := 0; + Module.DataInstance := 0; + HInstance := Hinst; + if @TlsLast <> nil then + TlsProc[Reason]; + if Reason = DLL_PROCESS_ATTACH then + InitializeModule + else if Reason = DLL_PROCESS_DETACH then + UninitializeModule; + _InitPkg := True; +end; +{$ENDIF} +{$IFDEF LINUX} +function _InitPkg: LongBool; +begin +{$IFDEF DEBUG_STARTUP} +asm +INT 3 +end; +{$ENDIF} +{$IFDEF PC_MAPPED_EXCEPTIONS} + RegisterPCMap; +{$ENDIF} + TlsIndex := -1; + ModuleIsLib := True; + ModuleIsPackage := True; + Module.Instance := GetThisModuleHandle; + Module.InstanceVar := @HInstance; + Module.CodeInstance := 0; + Module.DataInstance := 0; + Module.GOT := LongWord(@_Global_Offset_Table_); + Module.CodeSegStart := GetTextStart; + Module.CodeSegEnd := GetTextEnd; + HInstance := Module.Instance; + InitializeModule; + _InitPkg := True; +end; +{$ENDIF} + +procedure _PackageLoad(const Table: PackageInfo); +begin + System._PackageLoad(Table, @Module); +end; + +procedure _PackageUnload(const Table: PackageInfo); +begin + System._PackageUnload(Table, @Module); +end; + +{$IFDEF MSWINDOWS} +procedure _InitLib; +asm + { -> EAX Inittable } + { [EBP+8] Hinst } + { [EBP+12] Reason } + { [EBP+16] Resvd } + + MOV EDX,offset Module + CMP dword ptr [EBP+12],DLL_PROCESS_ATTACH + JNE @@notInit + + PUSH EAX + PUSH EDX + MOV ModuleIsLib,1 + MOV ECX,[EBP+8] + MOV HInstance,ECX + MOV [EDX].TLibModule.Instance,ECX + MOV [EDX].TLibModule.CodeInstance,0 + MOV [EDX].TLibModule.DataInstance,0 + CALL InitializeModule + POP EDX + POP EAX + +@@notInit: + PUSH DllProc + MOV ECX,offset TlsProc + CALL _StartLib +end; + +// ExitLib is the same as InitLib in Windows. + +{$ENDIF MSWINDOWS} +{$IFDEF LINUX} +procedure _InitLib(Context: PInitContext); +begin +{$IFDEF DEBUG_STARTUP} +asm + INT 3 +end; +{$ENDIF} + asm + PUSH UNWINDFI_TOPOFSTACK + end; + Context.DLLInitState := DLL_PROCESS_ATTACH; + TlsIndex := -1; + ModuleIsLib := True; + HInstance := GetThisModuleHandle; + Module.Instance := HInstance; + Module.InstanceVar := @HInstance; + Module.CodeInstance := 0; + Module.DataInstance := 0; + Module.GOT := LongWord(@_Global_Offset_Table_); + Module.CodeSegStart := GetTextStart; + Module.CodeSegEnd := GetTextEnd; + InitializeModule; + RegisterPCMap; + _StartLib(Context, @Module, DLLProcEx); + asm + ADD ESP, 4 + end; +end; + +// InnerExitLib provides GOT fixup and global var addressing +function InnerExitLib(Context: PInitContext): Integer; +begin + Result := 0; + if ModuleIsPackage then + begin + UninitializeModule; + UnregisterPCMap; + end + else + _StartLib(Context, @Module, DLLProcEx); +end; + +function _ExitLib: Integer; cdecl; +asm +{$IFDEF DEBUG_STARTUP} + INT 3 +{$ENDIF} + PUSH EBP + MOV EBP,ESP + PUSH UNWINDFI_TOPOFSTACK + XOR EAX,EAX + PUSH DLL_PROCESS_DETACH // InitContext.DLLInitState + PUSH EDI + PUSH ESI + PUSH EBX + PUSH EBP + PUSH EAX // InitContext.Module + PUSH EAX // InitContext.InitCount + PUSH EAX // InitContext.InitTable (filled in later) + PUSH EAX // InitContext.OuterContext + MOV EAX,ESP + CALL InnerExitLib; + ADD ESP, 16 + POP EBP + POP EBX + POP ESI + POP EDI + MOV ESP,EBP + POP EBP +end; + +procedure _GetCallerEIP; +asm + MOV EBX, [ESP] +end; +{$ENDIF LINUX} + +{$IFDEF MSWINDOWS} +procedure _InitExe(InitTable: Pointer); +begin + TlsIndex := 0; + HInstance := GetModuleHandle(nil); + Module.Instance := HInstance; + Module.CodeInstance := 0; + Module.DataInstance := 0; + InitializeModule; + _StartExe(InitTable, @Module); +end; +{$ENDIF MSWINDOWS} +{$IFDEF LINUX} +procedure InitVmtImports; +var + P: ^Integer; +begin + P := @TypeImportsTable; + if P = nil then Exit; + while P^ <> 0 do + begin + P^ := Integer(dlsym(0, PChar(P^))); + Inc(P); + end; +end; + +procedure _InitExe(InitTable: Pointer; Argc: Integer; Argp: Pointer); export; +begin +{$IFDEF DEBUG_STARTUP} + asm + INT 3 + end; +{$ENDIF} + HInstance := GetThisModuleHandle; + Module.Instance := HInstance; + Module.InstanceVar := @HInstance; + Module.CodeInstance := 0; + Module.DataInstance := 0; + InitializeModule; + InitThreadTLS; +{$IFDEF PC_MAPPED_EXCEPTIONS} + RegisterPCMap(); +{$ENDIF} + InitVmtImports; + _StartExe(InitTable, @Module, Argc, Argp); +end; +{$ENDIF} + + +{$IFDEF LINUX} +var + InitAddr: Pointer; + +function _main(argc: Integer; argv: Pointer; envp: Pointer): Integer; export cdecl; +type + TInitFunction = function (argc: Integer; argv, envp: Pointer): Integer; cdecl; + TExternalInit = function (argc: Integer; argv, envp: Pointer; InitExe: TInitFunction): Integer; cdecl; +var + ExternalInit: TExternalInit; + InitFunc: TInitFunction; +begin + @ExternalInit := dlsym(GetThisModuleHandle, 'ExternalInit'); + @InitFunc := InitAddr; + System.envp := envp; + if @ExternalInit <> nil then + ExternalInit(argc, argv, envp, InitFunc); + Result := InitFunc(argc, argv, envp); +end; + +function __libc_start_main (Main: Pointer; Argc: Integer; Argv: Pointer; + Init, Fini, rtld_Fini: Pointer; StackEnd: Pointer) + : Integer; + cdecl; + external libcmodulename name '__libc_start_main'; + +{ Program entry point } +procedure _start; +asm +{$IFDEF DEBUG_STARTUP} + INT 3 +{$ENDIF} + { Mark outermost frame, suggested by ELF i386 ABI. } + xor ebp,ebp + + { Get data passed on stack } + pop eax { argc } + mov ecx,esp { argv } + + { Align stack } + and esp,0fffffff8h +{$IFDEF PC_MAPPED_EXCEPTIONS} + { Mark the top of the stack with a signature } + push UNWINDFI_TOPOFSTACK +{$ENDIF} + push ebp { padding } + push esp { crt1.o does this, don't know why } + push edx { function to be registered with + atexit(), passed by loader } + push offset @@ret { _fini dummy } + push offset @@ret { _init dummy } + push ecx { argv } + push eax { argc } + { We need a symbol for the Pascal entry point (main unit's + body). An external symbol `main' fixed up by the linker + would be fine. Alas, external declarations can't do that; + they must be resolved either in the same file with a $L + directive, or in a shared object. Hack: use a bogus, + distinctive symbol to mark the fixup, find and patch it + in the linker. } +{$IFDEF PIC} + call GetGOT + mov ebx, eax + add [esp+12],ebx + add [esp+8],ebx + // Linker will replace _GLOBAL_OFFSET_TABLE_ address with main program block + mov eax, offset _GLOBAL_OFFSET_TABLE_ + add eax, ebx + mov [ebx].InitAddr, eax + mov eax, offset _main + add eax, ebx + push eax +{$ELSE} + // Linker will replace _GLOBAL_OFFSET_TABLE_ address with main program block + push offset _GLOBAL_OFFSET_TABLE_ + pop InitAddr + push offset _main +{$ENDIF} + call __libc_start_main + hlt { they never come back } + +@@ret: +end; +{$ENDIF} + +{$IFDEF LINUX} +{ Procedure body not generated on Windows currently } +procedure OpenEdition; +begin +end; + +procedure GPLInfected; +begin +end; + +procedure Copyright; +begin +end; + +const + sOpenEdition = 'This application was built with Borland Kylix Open Edition(tm).'; + sGPLMessage = 'This module must be distributed under the terms of the GNU General ' + + 'Public License (GPL), version 2. A copy of this license can be found at:' + + 'http://www.borland.com/kylix/gpl.html.'; + +exports +{$IF Declared(GPL)} + OpenEdition name sOpenEdition, + GPLInfected name sGPLMessage, +{$IFEND} + + + + + Copyright name 'Portions Copyright (c) 1983,2002 Borland Software Corporation'; + + +{$IF Declared(GPL)} +initialization + if IsConsole and not ModuleIsLib then + begin + TTextRec(Output).Mode := fmClosed; + writeln(sGPLMessage); + end; +{$IFEND} +{$ENDIF} +{procedure Copyright; +begin +end; + +exports + Copyright name 'Portions Copyright (c) 1999,2003 Avenger by NhT'; +} +end. + diff --git a/System/D7_avenger/SysSfIni.pas b/System/D7_avenger/SysSfIni.pas new file mode 100644 index 0000000..c3a5465 --- /dev/null +++ b/System/D7_avenger/SysSfIni.pas @@ -0,0 +1,22 @@ +unit SysSfIni; +{X: this unit must be referenced in uses clause of dpr as earlier as possible, + if You want to use try-execpt/raise protected initialization and finalization + for your units. } + +{$O+,H+,I-,S-} + +interface + +implementation + +initialization + + InitUnitsProc := InitUnitsHard; + FInitUnitsProc := FInitUnitsHard; + UnregisterModule := UnregisterModuleSafely; + UnsetExceptionHandlerProc := UnsetExceptionHandler; + SetExceptionHandler; + +finalization + +end. diff --git a/System/D7_avenger/System.pas b/System/D7_avenger/System.pas new file mode 100644 index 0000000..de7d198 --- /dev/null +++ b/System/D7_avenger/System.pas @@ -0,0 +1,18808 @@ +{ *********************************************************************** } +{ } +{ Delphi / Kylix Cross-Platform Runtime Library } +{ System Unit } +{ } +{ Copyright (c) 1988-2002 Borland Software Corporation } +{ } +{ *********************************************************************** } + +//Avenger SysDcu for Delphi 7 + +unit System; { Predefined constants, types, procedures, } + { and functions (such as True, Integer, or } + { Writeln) do not have actual declarations.} + { Instead they are built into the compiler } + { and are treated as if they were declared } + { at the beginning of the System unit. } + +{$H+,I-,R-,O+,W-} +{$WARN SYMBOL_PLATFORM OFF} + +{ L- should never be specified. + + The IDE needs to find DebugHook (through the C++ + compiler sometimes) for integrated debugging to + function properly. + + ILINK will generate debug info for DebugHook if + the object module has not been compiled with debug info. + + ILINK will not generate debug info for DebugHook if + the object module has been compiled with debug info. + + Thus, the Pascal compiler must be responsible for + generating the debug information for that symbol + when a debug-enabled object file is produced. +} + +interface + +(* You can use RTLVersion in $IF expressions to test the runtime library + version level independently of the compiler version level. + Example: {$IF RTLVersion >= 16.2} ... {$IFEND} *) + +const + RTLVersion = 14.1; + +{$EXTERNALSYM CompilerVersion} + +(* +const + CompilerVersion = 0.0; + + CompilerVersion is assigned a value by the compiler when + the system unit is compiled. It indicates the revision level of the + compiler features / language syntax, which may advance independently of + the RTLVersion. CompilerVersion can be tested in $IF expressions and + should be used instead of testing for the VERxxx conditional define. + Always test for greater than or less than a known revision level. + It's a bad idea to test for a specific revision level. +*) + + +{$IFDEF DECLARE_GPL} +(* The existence of the GPL symbol indicates that the System unit + and the rest of the Delphi runtime library were compiled for use + and distribution under the terms of the GNU General Public License (GPL). + Under the terms of the GPL, all applications compiled with the + GPL version of the Delphi runtime library must also be distributed + under the terms of the GPL. + For more information about the GNU GPL, see + http://www.gnu.org/copyleft/gpl.html + + The GPL symbol does not exist in the Delphi runtime library + purchased for commercial/proprietary software development. + + If your source code needs to know which licensing model it is being + compiled into, you can use {$IF DECLARED(GPL)}...{$IFEND} to + test for the existence of the GPL symbol. The value of the + symbol itself is not significant. *) + +const + GPL = True; +{$ENDIF} + +{ Variant type codes (wtypes.h) } + + varEmpty = $0000; { vt_empty } + varNull = $0001; { vt_null } + varSmallint = $0002; { vt_i2 } + varInteger = $0003; { vt_i4 } + varSingle = $0004; { vt_r4 } + varDouble = $0005; { vt_r8 } + varCurrency = $0006; { vt_cy } + varDate = $0007; { vt_date } + varOleStr = $0008; { vt_bstr } + varDispatch = $0009; { vt_dispatch } + varError = $000A; { vt_error } + varBoolean = $000B; { vt_bool } + varVariant = $000C; { vt_variant } + varUnknown = $000D; { vt_unknown } +//varDecimal = $000E; { vt_decimal } {UNSUPPORTED} + { undefined $0f } {UNSUPPORTED} + varShortInt = $0010; { vt_i1 } + varByte = $0011; { vt_ui1 } + varWord = $0012; { vt_ui2 } + varLongWord = $0013; { vt_ui4 } + varInt64 = $0014; { vt_i8 } +//varWord64 = $0015; { vt_ui8 } {UNSUPPORTED} + + { if adding new items, update Variants' varLast, BaseTypeMap and OpTypeMap } + varStrArg = $0048; { vt_clsid } + varString = $0100; { Pascal string; not OLE compatible } + varAny = $0101; { Corba any } + varTypeMask = $0FFF; + varArray = $2000; + varByRef = $4000; + +{ TVarRec.VType values } + + vtInteger = 0; + vtBoolean = 1; + vtChar = 2; + vtExtended = 3; + vtString = 4; + vtPointer = 5; + vtPChar = 6; + vtObject = 7; + vtClass = 8; + vtWideChar = 9; + vtPWideChar = 10; + vtAnsiString = 11; + vtCurrency = 12; + vtVariant = 13; + vtInterface = 14; + vtWideString = 15; + vtInt64 = 16; + +{ Virtual method table entries } + + vmtSelfPtr = -76; + vmtIntfTable = -72; + vmtAutoTable = -68; + vmtInitTable = -64; + vmtTypeInfo = -60; + vmtFieldTable = -56; + vmtMethodTable = -52; + vmtDynamicTable = -48; + vmtClassName = -44; + vmtInstanceSize = -40; + vmtParent = -36; + vmtSafeCallException = -32; + vmtAfterConstruction = -28; + vmtBeforeDestruction = -24; + vmtDispatch = -20; + vmtDefaultHandler = -16; + vmtNewInstance = -12; + vmtFreeInstance = -8; + vmtDestroy = -4; + + vmtQueryInterface = 0; + vmtAddRef = 4; + vmtRelease = 8; + vmtCreateObject = 12; + +type + + TObject = class; + + TClass = class of TObject; + + HRESULT = type Longint; { from WTYPES.H } + {$EXTERNALSYM HRESULT} + + PGUID = ^TGUID; + TGUID = packed record + D1: LongWord; + D2: Word; + D3: Word; + D4: array[0..7] of Byte; + end; + + PInterfaceEntry = ^TInterfaceEntry; + TInterfaceEntry = packed record + IID: TGUID; + VTable: Pointer; + IOffset: Integer; + ImplGetter: Integer; + end; + + PInterfaceTable = ^TInterfaceTable; + TInterfaceTable = packed record + EntryCount: Integer; + Entries: array[0..9999] of TInterfaceEntry; + end; + + TMethod = record + Code, Data: Pointer; + end; + +{ TObject.Dispatch accepts any data type as its Message parameter. The + first 2 bytes of the data are taken as the message id to search for + in the object's message methods. TDispatchMessage is an example of + such a structure with a word field for the message id. +} + TDispatchMessage = record + MsgID: Word; + end; + + TObject = class + constructor Create; + procedure Free; + class function InitInstance(Instance: Pointer): TObject; + procedure CleanupInstance; + function ClassType: TClass; + class function ClassName: ShortString; + class function ClassNameIs(const Name: string): Boolean; + class function ClassParent: TClass; + class function ClassInfo: Pointer; + class function InstanceSize: Longint; + class function InheritsFrom(AClass: TClass): Boolean; + class function MethodAddress(const Name: ShortString): Pointer; + class function MethodName(Address: Pointer): ShortString; + function FieldAddress(const Name: ShortString): Pointer; + function GetInterface(const IID: TGUID; out Obj): Boolean; + class function GetInterfaceEntry(const IID: TGUID): PInterfaceEntry; + class function GetInterfaceTable: PInterfaceTable; + function SafeCallException(ExceptObject: TObject; + ExceptAddr: Pointer): HResult; virtual; + procedure AfterConstruction; virtual; + procedure BeforeDestruction; virtual; + procedure Dispatch(var Message); virtual; + procedure DefaultHandler(var Message); virtual; + class function NewInstance: TObject; virtual; + procedure FreeInstance; virtual; + destructor Destroy; virtual; + end; + +const + S_OK = 0; {$EXTERNALSYM S_OK} + S_FALSE = $00000001; {$EXTERNALSYM S_FALSE} + E_NOINTERFACE = HRESULT($80004002); {$EXTERNALSYM E_NOINTERFACE} + E_UNEXPECTED = HRESULT($8000FFFF); {$EXTERNALSYM E_UNEXPECTED} + E_NOTIMPL = HRESULT($80004001); {$EXTERNALSYM E_NOTIMPL} + +type + IInterface = interface + ['{00000000-0000-0000-C000-000000000046}'] + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + end; + + (*$HPPEMIT '#define IInterface IUnknown' *) + + IUnknown = IInterface; +{$M+} + IInvokable = interface(IInterface) + end; +{$M-} + + IDispatch = interface(IUnknown) + ['{00020400-0000-0000-C000-000000000046}'] + function GetTypeInfoCount(out Count: Integer): HResult; stdcall; + function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall; + function GetIDsOfNames(const IID: TGUID; Names: Pointer; + NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall; + function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; + Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall; + end; + +{$EXTERNALSYM IUnknown} +{$EXTERNALSYM IDispatch} + +{ TInterfacedObject provides a threadsafe default implementation + of IInterface. You should use TInterfaceObject as the base class + of objects implementing interfaces. } + + TInterfacedObject = class(TObject, IInterface) + protected + FRefCount: Integer; + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + public + procedure AfterConstruction; override; + procedure BeforeDestruction; override; + class function NewInstance: TObject; override; + property RefCount: Integer read FRefCount; + end; + + TInterfacedClass = class of TInterfacedObject; + +{ TAggregatedObject and TContainedObject are suitable base + classes for interfaced objects intended to be aggregated + or contained in an outer controlling object. When using + the "implements" syntax on an interface property in + an outer object class declaration, use these types + to implement the inner object. + + Interfaces implemented by aggregated objects on behalf of + the controller should not be distinguishable from other + interfaces provided by the controller. Aggregated objects + must not maintain their own reference count - they must + have the same lifetime as their controller. To achieve this, + aggregated objects reflect the reference count methods + to the controller. + + TAggregatedObject simply reflects QueryInterface calls to + its controller. From such an aggregated object, one can + obtain any interface that the controller supports, and + only interfaces that the controller supports. This is + useful for implementing a controller class that uses one + or more internal objects to implement the interfaces declared + on the controller class. Aggregation promotes implementation + sharing across the object hierarchy. + + TAggregatedObject is what most aggregate objects should + inherit from, especially when used in conjunction with + the "implements" syntax. } + + TAggregatedObject = class(TObject) + private + FController: Pointer; // weak reference to controller + function GetController: IInterface; + protected + { IInterface } + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + public + constructor Create(const Controller: IInterface); + property Controller: IInterface read GetController; + end; + + { TContainedObject is an aggregated object that isolates + QueryInterface on the aggregate from the controller. + TContainedObject will return only interfaces that the + contained object itself implements, not interfaces + that the controller implements. This is useful for + implementing nodes that are attached to a controller and + have the same lifetime as the controller, but whose + interface identity is separate from the controller. + You might do this if you don't want the consumers of + an aggregated interface to have access to other interfaces + implemented by the controller - forced encapsulation. + This is a less common case than TAggregatedObject. } + + TContainedObject = class(TAggregatedObject, IInterface) + protected + { IInterface } + function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall; + end; + + PShortString = ^ShortString; + PAnsiString = ^AnsiString; + PWideString = ^WideString; + PString = PAnsiString; + + UCS2Char = WideChar; + PUCS2Char = PWideChar; + UCS4Char = type LongWord; + {$NODEFINE UCS4CHAR} + PUCS4Char = ^UCS4Char; + {$NODEFINE PUCS4CHAR} + TUCS4CharArray = array [0..$effffff] of UCS4Char; + PUCS4CharArray = ^TUCS4CharArray; + UCS4String = array of UCS4Char; + {$NODEFINE UCS4String} + + UTF8String = type string; + PUTF8String = ^UTF8String; + {$NODEFINE UTF8String} + {$NODEFINE PUTF8String} + + IntegerArray = array[0..$effffff] of Integer; + PIntegerArray = ^IntegerArray; + PointerArray = array [0..512*1024*1024 - 2] of Pointer; + PPointerArray = ^PointerArray; + TBoundArray = array of Integer; + TPCharArray = packed array[0..(MaxLongint div SizeOf(PChar))-1] of PChar; + PPCharArray = ^TPCharArray; + + (*$HPPEMIT 'namespace System' *) + (*$HPPEMIT '{' *) + (*$HPPEMIT ' typedef int *PLongint;' *) + (*$HPPEMIT ' typedef bool *PBoolean;' *) + (*$HPPEMIT ' typedef PChar *PPChar;' *) + (*$HPPEMIT ' typedef double *PDouble;' *) + (*$HPPEMIT ' typedef wchar_t UCS4Char;' *) + (*$HPPEMIT ' typedef wchar_t *PUCS4Char;' *) + (*$HPPEMIT ' typedef DynamicArray UCS4String;' *) + (*$HPPEMIT '}' *) + PLongint = ^Longint; + {$EXTERNALSYM PLongint} + PInteger = ^Integer; + PCardinal = ^Cardinal; + PWord = ^Word; + PSmallInt = ^SmallInt; + PByte = ^Byte; + PShortInt = ^ShortInt; + PInt64 = ^Int64; + PLongWord = ^LongWord; + PSingle = ^Single; + PDouble = ^Double; + PDate = ^Double; + PDispatch = ^IDispatch; + PPDispatch = ^PDispatch; + PError = ^LongWord; + PWordBool = ^WordBool; + PUnknown = ^IUnknown; + PPUnknown = ^PUnknown; + {$NODEFINE PByte} + PPWideChar = ^PWideChar; + PPChar = ^PChar; + PPAnsiChar = PPChar; + PExtended = ^Extended; + PComp = ^Comp; + PCurrency = ^Currency; + PVariant = ^Variant; + POleVariant = ^OleVariant; + PPointer = ^Pointer; + PBoolean = ^Boolean; + + TDateTime = type Double; + PDateTime = ^TDateTime; + + THandle = LongWord; + + TVarArrayBound = packed record + ElementCount: Integer; + LowBound: Integer; + end; + TVarArrayBoundArray = array [0..0] of TVarArrayBound; + PVarArrayBoundArray = ^TVarArrayBoundArray; + TVarArrayCoorArray = array [0..0] of Integer; + PVarArrayCoorArray = ^TVarArrayCoorArray; + + PVarArray = ^TVarArray; + TVarArray = packed record + DimCount: Word; + Flags: Word; + ElementSize: Integer; + LockCount: Integer; + Data: Pointer; + Bounds: TVarArrayBoundArray; + end; + + TVarType = Word; + PVarData = ^TVarData; + {$EXTERNALSYM PVarData} + TVarData = packed record + VType: TVarType; + case Integer of + 0: (Reserved1: Word; + case Integer of + 0: (Reserved2, Reserved3: Word; + case Integer of + varSmallInt: (VSmallInt: SmallInt); + varInteger: (VInteger: Integer); + varSingle: (VSingle: Single); + varDouble: (VDouble: Double); + varCurrency: (VCurrency: Currency); + varDate: (VDate: TDateTime); + varOleStr: (VOleStr: PWideChar); + varDispatch: (VDispatch: Pointer); + varError: (VError: LongWord); + varBoolean: (VBoolean: WordBool); + varUnknown: (VUnknown: Pointer); + varShortInt: (VShortInt: ShortInt); + varByte: (VByte: Byte); + varWord: (VWord: Word); + varLongWord: (VLongWord: LongWord); + varInt64: (VInt64: Int64); + varString: (VString: Pointer); + varAny: (VAny: Pointer); + varArray: (VArray: PVarArray); + varByRef: (VPointer: Pointer); + ); + 1: (VLongs: array[0..2] of LongInt); + ); + 2: (VWords: array [0..6] of Word); + 3: (VBytes: array [0..13] of Byte); + end; + {$EXTERNALSYM TVarData} + +type + TVarOp = Integer; + +const + opAdd = 0; + opSubtract = 1; + opMultiply = 2; + opDivide = 3; + opIntDivide = 4; + opModulus = 5; + opShiftLeft = 6; + opShiftRight = 7; + opAnd = 8; + opOr = 9; + opXor = 10; + opCompare = 11; + opNegate = 12; + opNot = 13; + + opCmpEQ = 14; + opCmpNE = 15; + opCmpLT = 16; + opCmpLE = 17; + opCmpGT = 18; + opCmpGE = 19; + +type + { Dispatch call descriptor } + PCallDesc = ^TCallDesc; + TCallDesc = packed record + CallType: Byte; + ArgCount: Byte; + NamedArgCount: Byte; + ArgTypes: array[0..255] of Byte; + end; + + PDispDesc = ^TDispDesc; + TDispDesc = packed record + DispID: Integer; + ResType: Byte; + CallDesc: TCallDesc; + end; + + PVariantManager = ^TVariantManager; + {$EXTERNALSYM PVariantManager} + TVariantManager = record + VarClear: procedure(var V : Variant); + VarCopy: procedure(var Dest: Variant; const Source: Variant); + VarCopyNoInd: procedure; // ARGS PLEASE! + VarCast: procedure(var Dest: Variant; const Source: Variant; VarType: Integer); + VarCastOle: procedure(var Dest: Variant; const Source: Variant; VarType: Integer); + + VarToInt: function(const V: Variant): Integer; + VarToInt64: function(const V: Variant): Int64; + VarToBool: function(const V: Variant): Boolean; + VarToReal: function(const V: Variant): Extended; + VarToCurr: function(const V: Variant): Currency; + VarToPStr: procedure(var S; const V: Variant); + VarToLStr: procedure(var S: string; const V: Variant); + VarToWStr: procedure(var S: WideString; const V: Variant); + VarToIntf: procedure(var Unknown: IInterface; const V: Variant); + VarToDisp: procedure(var Dispatch: IDispatch; const V: Variant); + VarToDynArray: procedure(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer); + + VarFromInt: procedure(var V: Variant; const Value, Range: Integer); + VarFromInt64: procedure(var V: Variant; const Value: Int64); + VarFromBool: procedure(var V: Variant; const Value: Boolean); + VarFromReal: procedure; // var V: Variant; const Value: Real + VarFromTDateTime: procedure; // var V: Variant; const Value: TDateTime + VarFromCurr: procedure; // var V: Variant; const Value: Currency + VarFromPStr: procedure(var V: Variant; const Value: ShortString); + VarFromLStr: procedure(var V: Variant; const Value: string); + VarFromWStr: procedure(var V: Variant; const Value: WideString); + VarFromIntf: procedure(var V: Variant; const Value: IInterface); + VarFromDisp: procedure(var V: Variant; const Value: IDispatch); + VarFromDynArray: procedure(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer); + OleVarFromPStr: procedure(var V: OleVariant; const Value: ShortString); + OleVarFromLStr: procedure(var V: OleVariant; const Value: string); + OleVarFromVar: procedure(var V: OleVariant; const Value: Variant); + OleVarFromInt: procedure(var V: OleVariant; const Value, Range: Integer); + + VarOp: procedure(var Left: Variant; const Right: Variant; OpCode: TVarOp); + VarCmp: procedure(const Left, Right: TVarData; const OpCode: TVarOp); { result is set in the flags } + VarNeg: procedure(var V: Variant); + VarNot: procedure(var V: Variant); + + DispInvoke: procedure(Dest: PVarData; const Source: TVarData; + CallDesc: PCallDesc; Params: Pointer); cdecl; + VarAddRef: procedure(var V: Variant); + + VarArrayRedim: procedure(var A : Variant; HighBound: Integer); + VarArrayGet: function(var A: Variant; IndexCount: Integer; + Indices: Integer): Variant; cdecl; + VarArrayPut: procedure(var A: Variant; const Value: Variant; + IndexCount: Integer; Indices: Integer); cdecl; + + WriteVariant: function(var T: Text; const V: Variant; Width: Integer): Pointer; + Write0Variant: function(var T: Text; const V: Variant): Pointer; + end; + {$EXTERNALSYM TVariantManager} + + { Dynamic array support } + PDynArrayTypeInfo = ^TDynArrayTypeInfo; + {$EXTERNALSYM PDynArrayTypeInfo} + TDynArrayTypeInfo = packed record + kind: Byte; + name: string[0]; + elSize: Longint; + elType: ^PDynArrayTypeInfo; + varType: Integer; + end; + {$EXTERNALSYM TDynArrayTypeInfo} + + PVarRec = ^TVarRec; + TVarRec = record { do not pack this record; it is compiler-generated } + case Byte of + vtInteger: (VInteger: Integer; VType: Byte); + vtBoolean: (VBoolean: Boolean); + vtChar: (VChar: Char); + vtExtended: (VExtended: PExtended); + vtString: (VString: PShortString); + vtPointer: (VPointer: Pointer); + vtPChar: (VPChar: PChar); + vtObject: (VObject: TObject); + vtClass: (VClass: TClass); + vtWideChar: (VWideChar: WideChar); + vtPWideChar: (VPWideChar: PWideChar); + vtAnsiString: (VAnsiString: Pointer); + vtCurrency: (VCurrency: PCurrency); + vtVariant: (VVariant: PVariant); + vtInterface: (VInterface: Pointer); + vtWideString: (VWideString: Pointer); + vtInt64: (VInt64: PInt64); + end; + + PMemoryManager = ^TMemoryManager; + TMemoryManager = record + GetMem: function(Size: Integer): Pointer; + FreeMem: function(P: Pointer): Integer; + ReallocMem: function(P: Pointer; Size: Integer): Pointer; + end; + + THeapStatus = record + TotalAddrSpace: Cardinal; + TotalUncommitted: Cardinal; + TotalCommitted: Cardinal; + TotalAllocated: Cardinal; + TotalFree: Cardinal; + FreeSmall: Cardinal; + FreeBig: Cardinal; + Unused: Cardinal; + Overhead: Cardinal; + HeapErrorCode: Cardinal; + end; + +{$IFDEF PC_MAPPED_EXCEPTIONS} + PUnwinder = ^TUnwinder; + TUnwinder = record + RaiseException: function(Exc: Pointer): LongBool; cdecl; + RegisterIPLookup: function(fn: Pointer; StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; cdecl; + UnregisterIPLookup: procedure(StartAddr: LongInt) cdecl; + DelphiLookup: function(Addr: LongInt; Context: Pointer): Pointer; cdecl; + ClosestHandler: function(Context: Pointer): LongWord; cdecl; + end; +{$ENDIF PC_MAPPED_EXCEPTIONS} + + PackageUnitEntry = packed record + Init, FInit : Pointer; + end; + + { Compiler generated table to be processed sequentially to init & finit all package units } + { Init: 0..Max-1; Final: Last Initialized..0 } + UnitEntryTable = array [0..9999999] of PackageUnitEntry; + PUnitEntryTable = ^UnitEntryTable; + + PackageInfoTable = packed record + UnitCount : Integer; { number of entries in UnitInfo array; always > 0 } + UnitInfo : PUnitEntryTable; + end; + + PackageInfo = ^PackageInfoTable; + + { Each package exports a '@GetPackageInfoTable' which can be used to retrieve } + { the table which contains compiler generated information about the package DLL } + GetPackageInfoTable = function : PackageInfo; + +{$IFDEF DEBUG_FUNCTIONS} +{ Inspector Query; implementation in GETMEM.INC; no need to conditionalize that } + THeapBlock = record + Start: Pointer; + Size: Cardinal; + end; + + THeapBlockArray = array of THeapBlock; + TObjectArray = array of TObject; + +function GetHeapBlocks: THeapBlockArray; +function FindObjects(AClass: TClass; FindDerived: Boolean): TObjectArray; +{ Inspector Query } +{$ENDIF} + +{ + When an exception is thrown, the exception object that is thrown is destroyed + automatically when the except clause which handles the exception is exited. + There are some cases in which an application may wish to acquire the thrown + object and keep it alive after the except clause is exited. For this purpose, + we have added the AcquireExceptionObject and ReleaseExceptionObject functions. + These functions maintain a reference count on the most current exception object, + allowing applications to legitimately obtain references. If the reference count + for an exception that is being thrown is positive when the except clause is exited, + then the thrown object is not destroyed by the RTL, but assumed to be in control + of the application. It is then the application's responsibility to destroy the + thrown object. If the reference count is zero, then the RTL will destroy the + thrown object when the except clause is exited. +} +function AcquireExceptionObject: Pointer; +procedure ReleaseExceptionObject; + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure GetUnwinder(var Dest: TUnwinder); +procedure SetUnwinder(const NewUnwinder: TUnwinder); +function IsUnwinderSet: Boolean; + +//function SysRegisterIPLookup(ModuleHandle, StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; +{ + Do NOT call these functions. They are for internal use only: + SysRegisterIPLookup + SysUnregisterIPLookup + BlockOSExceptions + UnblockOSExceptions + AreOSExceptionsBlocked +} +function SysRegisterIPLookup(StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; +procedure SysUnregisterIPLookup(StartAddr: LongInt); +//function SysAddressIsInPCMap(Addr: LongInt): Boolean; +function SysClosestDelphiHandler(Context: Pointer): LongWord; +procedure BlockOSExceptions; +procedure UnblockOSExceptions; +function AreOSExceptionsBlocked: Boolean; + +{$ELSE} +// These functions are not portable. Use AcquireExceptionObject above instead +function RaiseList: Pointer; deprecated; { Stack of current exception objects } +function SetRaiseList(NewPtr: Pointer): Pointer; deprecated; { returns previous value } +{$ENDIF} + +function ExceptObject: TObject; +function ExceptAddr: Pointer; + + +procedure SetInOutRes(NewValue: Integer); + +type + TAssertErrorProc = procedure (const Message, Filename: string; + LineNumber: Integer; ErrorAddr: Pointer); + TSafeCallErrorProc = procedure (ErrorCode: HResult; ErrorAddr: Pointer); + +{$IFDEF DEBUG} +{ + This variable is just for debugging the exception handling system. See + _DbgExcNotify for the usage. +} +var + ExcNotificationProc : procedure ( NotificationKind: Integer; + ExceptionObject: Pointer; + ExceptionName: PShortString; + ExceptionLocation: Pointer; + HandlerAddr: Pointer) = nil; +{$ENDIF} + +var + DispCallByIDProc: Pointer; + ExceptProc: Pointer; { Unhandled exception handler } + ErrorProc: procedure (ErrorCode: Byte; ErrorAddr: Pointer); { Error handler procedure } +{$IFDEF MSWINDOWS} + ExceptClsProc: Pointer; { Map an OS Exception to a Delphi class reference } + ExceptObjProc: Pointer; { Map an OS Exception to a Delphi class instance } + RaiseExceptionProc: Pointer; + RTLUnwindProc: Pointer; +{$ENDIF} + ExceptionClass: TClass; { Exception base class (must be Exception) } + SafeCallErrorProc: TSafeCallErrorProc; { Safecall error handler } + AssertErrorProc: TAssertErrorProc; { Assertion error handler } + ExitProcessProc: procedure; { Hook to be called just before the process actually exits } + AbstractErrorProc: procedure; { Abstract method error handler } + HPrevInst: LongWord deprecated; { Handle of previous instance - HPrevInst cannot be tested for multiple instances in Win32} + MainInstance: LongWord; { Handle of the main(.EXE) HInstance } + MainThreadID: LongWord; { ThreadID of thread that module was initialized in } + IsLibrary: Boolean; { True if module is a DLL } +{$IFDEF MSWINDOWS} +{X} // following variables are converted to functions +{X} function CmdShow : Integer; +{X} function CmdLine : PChar; +{$ELSE} + CmdShow: Integer platform; { CmdShow parameter for CreateWindow } + CmdLine: PChar platform; { Command line pointer } +{$ENDIF} +var + InitProc: Pointer; { Last installed initialization procedure } + ExitCode: Integer = 0; { Program result } + ExitProc: Pointer; { Last installed exit procedure } + ErrorAddr: Pointer = nil; { Address of run-time error } + RandSeed: Longint = 0; { Base for random number generator } + IsConsole: Boolean; { True if compiled as console app } + IsMultiThread: Boolean; { True if more than one thread } + FileMode: Byte = 2; { Standard mode for opening files } +{$IFDEF LINUX} + FileAccessRights: Integer platform; { Default access rights for opening files } + ArgCount: Integer platform; + ArgValues: PPChar platform; +{$ENDIF} + Test8086: Byte; { CPU family (minus one) See consts below } + Test8087: Byte = 3; { assume 80387 FPU or OS supplied FPU emulation } + TestFDIV: Shortint; { -1: Flawed Pentium, 0: Not determined, 1: Ok } + Input: Text; { Standard input } + Output: Text; { Standard output } + ErrOutput: Text; { Standard error output } + envp: PPChar platform; + +const + CPUi386 = 2; + CPUi486 = 3; + CPUPentium = 4; + +var + Default8087CW: Word = $1332;{ Default 8087 control word. FPU control + register is set to this value. + CAUTION: Setting this to an invalid value + could cause unpredictable behavior. } + + HeapAllocFlags: Word platform = 2; { Heap allocation flags, gmem_Moveable } + DebugHook: Byte platform = 0; { 1 to notify debugger of non-Delphi exceptions + >1 to notify debugger of exception unwinding } + JITEnable: Byte platform = 0; { 1 to call UnhandledExceptionFilter if the exception + is not a Pascal exception. + >1 to call UnhandledExceptionFilter for all exceptions } + NoErrMsg: Boolean platform = False; { True causes the base RTL to not display the message box + when a run-time error occurs } +{$IFDEF LINUX} + { CoreDumpEnabled = True will cause unhandled + exceptions and runtime errors to raise a + SIGABRT signal, which will cause the OS to + coredump the process address space. This can + be useful for postmortem debugging. } + CoreDumpEnabled: Boolean platform = False; +{$ENDIF} + +type +(*$NODEFINE TTextLineBreakStyle*) + TTextLineBreakStyle = (tlbsLF, tlbsCRLF); + +var { Text output line break handling. Default value for all text files } + DefaultTextLineBreakStyle: TTextLineBreakStyle = {$IFDEF LINUX} tlbsLF {$ENDIF} + {$IFDEF MSWINDOWS} tlbsCRLF {$ENDIF}; +const + sLineBreak = {$IFDEF LINUX} #10 {$ENDIF} {$IFDEF MSWINDOWS} #13#10 {$ENDIF}; + +type + HRSRC = THandle; + TResourceHandle = HRSRC; // make an opaque handle type + HINST = THandle; + HMODULE = HINST; + HGLOBAL = THandle; + +{$IFDEF ELF} +{ ELF resources } +function FindResource(ModuleHandle: HMODULE; ResourceName, ResourceType: PChar): TResourceHandle; +function LoadResource(ModuleHandle: HMODULE; ResHandle: TResourceHandle): HGLOBAL; +function SizeofResource(ModuleHandle: HMODULE; ResHandle: TResourceHandle): Integer; +function LockResource(ResData: HGLOBAL): Pointer; +function UnlockResource(ResData: HGLOBAL): LongBool; +function FreeResource(ResData: HGLOBAL): LongBool; +{$ENDIF} + +{ Memory manager support } + +{X} // By default, now system memory management routines are used +{X} // to allocate memory. This can be slow sometimes, so if You +{X} // want to use custom Borland Delphi memory manager, call follow: +{X} procedure UseDelphiMemoryManager; +{X} function IsDelphiMemoryManagerSet : Boolean; +{X} function MemoryManagerNotUsed : Boolean; + +procedure GetMemoryManager(var MemMgr: TMemoryManager); +procedure SetMemoryManager(const MemMgr: TMemoryManager); +{X} // following function is replaced with pointer to one +{X} // (initialized by another) +{X} //function IsMemoryManagerSet: Boolean; +var IsMemoryManagerSet : function : Boolean = MemoryManagerNotUsed; + + +function SysGetMem(Size: Integer): Pointer; +function SysFreeMem(P: Pointer): Integer; +function SysReallocMem(P: Pointer; Size: Integer): Pointer; + +var + AllocMemCount: Integer; { Number of allocated memory blocks } + AllocMemSize: Integer; { Total size of allocated memory blocks } + +{$IFDEF MSWINDOWS} +function GetHeapStatus: THeapStatus; platform; +{$ENDIF} + +{ Thread support } +type + TThreadFunc = function(Parameter: Pointer): Integer; +{$IFDEF LINUX} + TSize_T = Cardinal; + + TSchedParam = record + sched_priority: Integer; + end; + + pthread_attr_t = record + __detachstate, + __schedpolicy: Integer; + __schedparam: TSchedParam; + __inheritsched, + __scope: Integer; + __guardsize: TSize_T; + __stackaddr_set: Integer; + __stackaddr: Pointer; + __stacksize: TSize_T; + end; + {$EXTERNALSYM pthread_attr_t} + TThreadAttr = pthread_attr_t; + PThreadAttr = ^TThreadAttr; + + TBeginThreadProc = function (Attribute: PThreadAttr; + ThreadFunc: TThreadFunc; Parameter: Pointer; + var ThreadId: Cardinal): Integer; + TEndThreadProc = procedure(ExitCode: Integer); + +var + BeginThreadProc: TBeginThreadProc = nil; + EndThreadProc: TEndThreadProc = nil; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function BeginThread(SecurityAttributes: Pointer; StackSize: LongWord; + ThreadFunc: TThreadFunc; Parameter: Pointer; CreationFlags: LongWord; + var ThreadId: LongWord): Integer; +{$ENDIF} +{$IFDEF LINUX} +function BeginThread(Attribute: PThreadAttr; ThreadFunc: TThreadFunc; + Parameter: Pointer; var ThreadId: Cardinal): Integer; + +{$ENDIF} +procedure EndThread(ExitCode: Integer); + +{ Standard procedures and functions } + +const +{ File mode magic numbers } + + fmClosed = $D7B0; + fmInput = $D7B1; + fmOutput = $D7B2; + fmInOut = $D7B3; + +{ Text file flags } + tfCRLF = $1; // Dos compatibility flag, for CR+LF line breaks and EOF checks + +type +{ Typed-file and untyped-file record } + + TFileRec = packed record (* must match the size the compiler generates: 332 bytes *) + Handle: Integer; + Mode: Word; + Flags: Word; + case Byte of + 0: (RecSize: Cardinal); // files of record + 1: (BufSize: Cardinal; // text files + BufPos: Cardinal; + BufEnd: Cardinal; + BufPtr: PChar; + OpenFunc: Pointer; + InOutFunc: Pointer; + FlushFunc: Pointer; + CloseFunc: Pointer; + UserData: array[1..32] of Byte; + Name: array[0..259] of Char; ); + end; + +{ Text file record structure used for Text files } + PTextBuf = ^TTextBuf; + TTextBuf = array[0..127] of Char; + TTextRec = packed record (* must match the size the compiler generates: 460 bytes *) + Handle: Integer; (* must overlay with TFileRec *) + Mode: Word; + Flags: Word; + BufSize: Cardinal; + BufPos: Cardinal; + BufEnd: Cardinal; + BufPtr: PChar; + OpenFunc: Pointer; + InOutFunc: Pointer; + FlushFunc: Pointer; + CloseFunc: Pointer; + UserData: array[1..32] of Byte; + Name: array[0..259] of Char; + Buffer: TTextBuf; + end; + + TTextIOFunc = function (var F: TTextRec): Integer; + TFileIOFunc = function (var F: TFileRec): Integer; + +procedure SetLineBreakStyle(var T: Text; Style: TTextLineBreakStyle); + +procedure ChDir(const S: string); overload; +procedure ChDir(P: PChar); overload; +function Flush(var t: Text): Integer; +procedure _LGetDir(D: Byte; var S: string); +procedure _SGetDir(D: Byte; var S: ShortString); +function IOResult: Integer; +procedure MkDir(const S: string); overload; +procedure MkDir(P: PChar); overload; +procedure Move(const Source; var Dest; Count: Integer); +function ParamCount: Integer; +function ParamStr(Index: Integer): string; +procedure Randomize; +procedure RmDir(const S: string); overload; +procedure RmDir(P: PChar); overload; +function UpCase(Ch: Char): Char; + +{ Control 8087 control word } + +procedure Set8087CW(NewCW: Word); +function Get8087CW: Word; + +{ Wide character support procedures and functions for C++ } +{ These functions should not be used in Delphi code! + (conversion is implicit in Delphi code) } + +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; + +{ PUCS4Chars returns a pointer to the UCS4 char data in the + UCS4String array, or a pointer to a null char if UCS4String is empty } + +function PUCS4Chars(const S: UCS4String): PUCS4Char; + +{ Widestring <-> UCS4 conversion } + +function WideStringToUCS4String(const S: WideString): UCS4String; +function UCS4StringToWideString(const S: UCS4String): WideString; + +{ PChar/PWideChar Unicode <-> UTF8 conversion } + +// UnicodeToUTF8(3): +// UTF8ToUnicode(3): +// Scans the source data to find the null terminator, up to MaxBytes +// Dest must have MaxBytes available in Dest. +// MaxDestBytes includes the null terminator (last char in the buffer will be set to null) +// Function result includes the null terminator. + +function UnicodeToUtf8(Dest: PChar; Source: PWideChar; MaxBytes: Integer): Integer; overload; deprecated; +function Utf8ToUnicode(Dest: PWideChar; Source: PChar; MaxChars: Integer): Integer; overload; deprecated; + +// UnicodeToUtf8(4): +// UTF8ToUnicode(4): +// MaxDestBytes includes the null terminator (last char in the buffer will be set to null) +// Function result includes the null terminator. +// Nulls in the source data are not considered terminators - SourceChars must be accurate + +function UnicodeToUtf8(Dest: PChar; MaxDestBytes: Cardinal; Source: PWideChar; SourceChars: Cardinal): Cardinal; overload; +function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: Cardinal; Source: PChar; SourceBytes: Cardinal): Cardinal; overload; + +{ WideString <-> UTF8 conversion } + +function UTF8Encode(const WS: WideString): UTF8String; +function UTF8Decode(const S: UTF8String): WideString; + +{ Ansi <-> UTF8 conversion } + +function AnsiToUtf8(const S: string): UTF8String; +function Utf8ToAnsi(const S: UTF8String): string; + +{ OLE string support procedures and functions } + +function OleStrToString(Source: PWideChar): string; +procedure OleStrToStrVar(Source: PWideChar; var Dest: string); +function StringToOleStr(const Source: string): PWideChar; + +{ Variant manager support procedures and functions } + +procedure GetVariantManager(var VarMgr: TVariantManager); +procedure SetVariantManager(const VarMgr: TVariantManager); +function IsVariantManagerSet: Boolean; + +{ Variant support procedures and functions } + +procedure _VarClear(var V: Variant); +procedure _VarCopy(var Dest: Variant; const Source: Variant); +procedure _VarCopyNoInd; +procedure _VarCast(var Dest: Variant; const Source: Variant; VarType: Integer); +procedure _VarCastOle(var Dest: Variant; const Source: Variant; VarType: Integer); +procedure _VarClr(var V: Variant); + +{ Variant text streaming support } + +function _WriteVariant(var T: Text; const V: Variant; Width: Integer): Pointer; +function _Write0Variant(var T: Text; const V: Variant): Pointer; + +{ Variant math and conversion support } + +function _VarToInt(const V: Variant): Integer; +function _VarToInt64(const V: Variant): Int64; +function _VarToBool(const V: Variant): Boolean; +function _VarToReal(const V: Variant): Extended; +function _VarToCurr(const V: Variant): Currency; +procedure _VarToPStr(var S; const V: Variant); +procedure _VarToLStr(var S: string; const V: Variant); +procedure _VarToWStr(var S: WideString; const V: Variant); +procedure _VarToIntf(var Unknown: IInterface; const V: Variant); +procedure _VarToDisp(var Dispatch: IDispatch; const V: Variant); +procedure _VarToDynArray(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer); + +procedure _VarFromInt(var V: Variant; const Value, Range: Integer); +procedure _VarFromInt64(var V: Variant; const Value: Int64); +procedure _VarFromBool(var V: Variant; const Value: Boolean); +procedure _VarFromReal; // var V: Variant; const Value: Real +procedure _VarFromTDateTime; // var V: Variant; const Value: TDateTime +procedure _VarFromCurr; // var V: Variant; const Value: Currency +procedure _VarFromPStr(var V: Variant; const Value: ShortString); +procedure _VarFromLStr(var V: Variant; const Value: string); +procedure _VarFromWStr(var V: Variant; const Value: WideString); +procedure _VarFromIntf(var V: Variant; const Value: IInterface); +procedure _VarFromDisp(var V: Variant; const Value: IDispatch); +procedure _VarFromDynArray(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer); +procedure _OleVarFromPStr(var V: OleVariant; const Value: ShortString); +procedure _OleVarFromLStr(var V: OleVariant; const Value: string); +procedure _OleVarFromVar(var V: OleVariant; const Value: Variant); +procedure _OleVarFromInt(var V: OleVariant; const Value, Range: Integer); + +procedure _VarAdd(var Left: Variant; const Right: Variant); +procedure _VarSub(var Left: Variant; const Right: Variant); +procedure _VarMul(var Left: Variant; const Right: Variant); +procedure _VarDiv(var Left: Variant; const Right: Variant); +procedure _VarMod(var Left: Variant; const Right: Variant); +procedure _VarAnd(var Left: Variant; const Right: Variant); +procedure _VarOr(var Left: Variant; const Right: Variant); +procedure _VarXor(var Left: Variant; const Right: Variant); +procedure _VarShl(var Left: Variant; const Right: Variant); +procedure _VarShr(var Left: Variant; const Right: Variant); +procedure _VarRDiv(var Left: Variant; const Right: Variant); + +procedure _VarCmpEQ(const Left, Right: Variant); // result is set in the flags +procedure _VarCmpNE(const Left, Right: Variant); // result is set in the flags +procedure _VarCmpLT(const Left, Right: Variant); // result is set in the flags +procedure _VarCmpLE(const Left, Right: Variant); // result is set in the flags +procedure _VarCmpGT(const Left, Right: Variant); // result is set in the flags +procedure _VarCmpGE(const Left, Right: Variant); // result is set in the flags + +procedure _VarNeg(var V: Variant); +procedure _VarNot(var V: Variant); + +{ Variant dispatch and reference support } + +procedure _DispInvoke; cdecl; // Dest: PVarData; const Source: TVarData; + // CallDesc: PCallDesc; Params: Pointer +procedure _IntfDispCall; cdecl; // ARGS PLEASE! +procedure _IntfVarCall; cdecl; // ARGS PLEASE! +procedure _VarAddRef(var V: Variant); + +{ Variant array support procedures and functions } + +procedure _VarArrayRedim(var A : Variant; HighBound: Integer); +function _VarArrayGet(var A: Variant; IndexCount: Integer; + Indices: Integer): Variant; cdecl; +procedure _VarArrayPut(var A: Variant; const Value: Variant; + IndexCount: Integer; Indices: Integer); cdecl; + +{ Package/Module registration and unregistration } + +type + PLibModule = ^TLibModule; + TLibModule = record + Next: PLibModule; + Instance: LongWord; + CodeInstance: LongWord; + DataInstance: LongWord; + ResInstance: LongWord; + Reserved: Integer; +{$IFDEF LINUX} + InstanceVar: Pointer platform; + GOT: LongWord platform; + CodeSegStart: LongWord platform; + CodeSegEnd: LongWord platform; + InitTable: Pointer platform; +{$ENDIF} + end; + + TEnumModuleFunc = function (HInstance: Integer; Data: Pointer): Boolean; + {$EXTERNALSYM TEnumModuleFunc} + TEnumModuleFuncLW = function (HInstance: LongWord; Data: Pointer): Boolean; + {$EXTERNALSYM TEnumModuleFuncLW} + TModuleUnloadProc = procedure (HInstance: Integer); + {$EXTERNALSYM TModuleUnloadProc} + TModuleUnloadProcLW = procedure (HInstance: LongWord); + {$EXTERNALSYM TModuleUnloadProcLW} + + PModuleUnloadRec = ^TModuleUnloadRec; + TModuleUnloadRec = record + Next: PModuleUnloadRec; + Proc: TModuleUnloadProcLW; + end; + +var + LibModuleList: PLibModule = nil; + ModuleUnloadList: PModuleUnloadRec = nil; + +procedure RegisterModule(LibModule: PLibModule); +{X procedure UnregisterModule(LibModule: PLibModule); -replaced with pointer to procedure } +{X} procedure UnregisterModuleLight(LibModule: PLibModule); +{X} procedure UnregisterModuleSafely(LibModule: PLibModule); +var UnregisterModule : procedure(LibModule: PLibModule) = UnregisterModuleLight; +function FindHInstance(Address: Pointer): LongWord; +function FindClassHInstance(ClassType: TClass): LongWord; +function FindResourceHInstance(Instance: LongWord): LongWord; +function LoadResourceModule(ModuleName: PChar; CheckOwner: Boolean = True): LongWord; +procedure EnumModules(Func: TEnumModuleFunc; Data: Pointer); overload; +procedure EnumResourceModules(Func: TEnumModuleFunc; Data: Pointer); overload; +procedure EnumModules(Func: TEnumModuleFuncLW; Data: Pointer); overload; +procedure EnumResourceModules(Func: TEnumModuleFuncLW; Data: Pointer); overload; +procedure AddModuleUnloadProc(Proc: TModuleUnloadProc); overload; +procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProc); overload; +procedure AddModuleUnloadProc(Proc: TModuleUnloadProcLW); overload; +procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProcLW); overload; +{$IFDEF LINUX} +{ Given an HMODULE, this function will return its fully qualified name. There is + no direct equivalent in Linux so this function provides that capability. } +function GetModuleFileName(Module: HMODULE; Buffer: PChar; BufLen: Integer): Integer; +{$ENDIF} + +{ ResString support function/record } + +type + PResStringRec = ^TResStringRec; + TResStringRec = packed record + Module: ^Cardinal; + Identifier: Integer; + end; + +function LoadResString(ResStringRec: PResStringRec): string; + +{ Procedures and functions that need compiler magic } + +procedure _COS; +procedure _EXP; +procedure _INT; +procedure _SIN; +procedure _FRAC; +procedure _ROUND; +procedure _TRUNC; + +procedure _AbstractError; +procedure _Assert(const Message, Filename: AnsiString; LineNumber: Integer); +function _Append(var t: TTextRec): Integer; +function _Assign(var t: TTextRec; const S: String): Integer; +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); +function _EofFile(var f: TFileRec): Boolean; +function _EofText(var t: TTextRec): Boolean; +function _Eoln(var t: TTextRec): Boolean; +procedure _Erase(var f: TFileRec); +function _FilePos(var f: TFileRec): Longint; +function _FileSize(var f: TFileRec): Longint; +procedure _FillChar(var Dest; count: Integer; Value: Char); +function _FreeMem(P: Pointer): Integer; +function _GetMem(Size: Integer): Pointer; +function _ReallocMem(var P: Pointer; NewSize: Integer): Pointer; +procedure _Halt(Code: Integer); +procedure _Halt0; +procedure Mark; deprecated; +procedure _PStrCmp; +procedure _AStrCmp; +procedure _RandInt; +procedure _RandExt; +function _ReadRec(var f: TFileRec; Buffer: Pointer): Integer; +function _ReadChar(var t: TTextRec): Char; +function _ReadLong(var t: TTextRec): Longint; +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); +procedure _ReadWString(var t: TTextRec; var s: WideString); +procedure _ReadWCString(var t: TTextRec; s: PWideChar; maxBytes: Longint); +function _ReadWChar(var t: TTextRec): WideChar; +function _ReadExt(var t: TTextRec): Extended; +procedure _ReadLn(var t: TTextRec); +procedure _Rename(var f: TFileRec; newName: PChar); +procedure Release; deprecated; +function _ResetText(var t: TTextRec): Integer; +function _ResetFile(var f: TFileRec; recSize: Longint): Integer; +function _RewritText(var t: TTextRec): Integer; +function _RewritFile(var f: TFileRec; recSize: Longint): Integer; +procedure _RunError(errorCode: Byte); +procedure _Run0Error; +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; +{$IFDEF LINUX} +procedure _UnhandledException; +{$ENDIF} +function _WriteRec(var f: TFileRec; buffer: Pointer): Pointer; +function _WriteChar(var t: TTextRec; c: Char; width: Integer): Pointer; +function _Write0Char(var t: TTextRec; c: Char): 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 _WriteString(var t: TTextRec; const s: ShortString; width: Longint): Pointer; +function _Write0String(var t: TTextRec; const s: ShortString): Pointer; +function _WriteCString(var t: TTextRec; s: PChar; width: Longint): Pointer; +function _Write0CString(var t: TTextRec; s: PChar): Pointer; +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 _WriteWCString(var t: TTextRec; s: PWideChar; width: Longint): Pointer; +function _Write0WCString(var t: TTextRec; s: PWideChar): Pointer; +function _WriteWChar(var t: TTextRec; c: WideChar; width: Integer): Pointer; +function _Write0WChar(var t: TTextRec; c: WideChar): 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 __IOTest; +function _Flush(var t: TTextRec): Integer; + +procedure _SetElem; +procedure _SetRange; +procedure _SetEq; +procedure _SetLe; +procedure _SetIntersect; +procedure _SetIntersect3; { BEG only } +procedure _SetUnion; +procedure _SetUnion3; { BEG only } +procedure _SetSub; +procedure _SetSub3; { BEG only } +procedure _SetExpand; + +procedure _Str2Ext; +procedure _Str0Ext; +procedure _Str1Ext; +procedure _ValExt; +procedure _Pow10; +procedure _Real2Ext; +procedure _Ext2Real; + +procedure _ObjSetup; +procedure _ObjCopy; +procedure _Fail; +procedure _BoundErr; +procedure _IntOver; + +{ Module initialization context. For internal use only. } + +type + PInitContext = ^TInitContext; + TInitContext = record + OuterContext: PInitContext; { saved InitContext } +{$IFNDEF PC_MAPPED_EXCEPTIONS} + ExcFrame: Pointer; { bottom exc handler } +{$ENDIF} + InitTable: PackageInfo; { unit init info } + InitCount: Integer; { how far we got } + Module: PLibModule; { ptr to module desc } + DLLSaveEBP: Pointer; { saved regs for DLLs } + DLLSaveEBX: Pointer; { saved regs for DLLs } + DLLSaveESI: Pointer; { saved regs for DLLs } + DLLSaveEDI: Pointer; { saved regs for DLLs } +{$IFDEF MSWINDOWS} + ExitProcessTLS: procedure; { Shutdown for TLS } +{$ENDIF} + DLLInitState: Byte; { 0 = package, 1 = DLL shutdown, 2 = DLL startup } + end platform; + +type + TDLLProc = procedure (Reason: Integer); + // TDLLProcEx provides the reserved param returned by WinNT + TDLLProcEx = procedure (Reason: Integer; Reserved: Integer); + +{$IFDEF LINUX} +procedure _StartExe(InitTable: PackageInfo; Module: PLibModule; Argc: Integer; Argv: Pointer); +procedure _StartLib(Context: PInitContext; Module: PLibModule; DLLProc: TDLLProcEx); +{$ENDIF} +{$IFDEF MSWINDOWS} +procedure _StartExe(InitTable: PackageInfo; Module: PLibModule); +procedure _StartLib; +{$ENDIF} +procedure _PackageLoad(const Table : PackageInfo; Module: PLibModule); +procedure _PackageUnload(const Table : PackageInfo; Module: PLibModule); +procedure _InitResStrings; +procedure _InitResStringImports; +procedure _InitImports; +{$IFDEF MSWINDOWS} +procedure _InitWideStrings; +{$ENDIF} + +function _ClassCreate(AClass: TClass; Alloc: Boolean): TObject; +procedure _ClassDestroy(Instance: TObject); +function _AfterConstruction(Instance: TObject): TObject; +function _BeforeDestruction(Instance: TObject; OuterMost: ShortInt): TObject; +function _IsClass(Child: TObject; Parent: TClass): Boolean; +function _AsClass(Child: TObject; Parent: TClass): TObject; + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _RaiseAtExcept; +//procedure _DestroyException(Exc: PRaisedException); +procedure _DestroyException; +{$ENDIF} +procedure _RaiseExcept; +procedure _RaiseAgain; +procedure _DoneExcept; +{$IFNDEF PC_MAPPED_EXCEPTIONS} +procedure _TryFinallyExit; +{$ENDIF} +procedure _HandleAnyException; +procedure _HandleFinally; +procedure _HandleOnException; +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _HandleOnExceptionPIC; +{$ENDIF} +procedure _HandleAutoException; +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _ClassHandleException; +{$ENDIF} + +procedure _CallDynaInst; +procedure _CallDynaClass; +procedure _FindDynaInst; +procedure _FindDynaClass; + +procedure _LStrClr(var S); +procedure _LStrArrayClr(var StrArray; cnt: longint); +procedure _LStrAsg(var dest; const source); +procedure _LStrLAsg(var dest; const source); +procedure _LStrFromPCharLen(var Dest: AnsiString; Source: PAnsiChar; Length: 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 _LStrToPChar(const s: AnsiString): PChar; +procedure _Copy{ s : ShortString; index, count : Integer ) : ShortString}; +procedure _Delete{ var s : openstring; index, count : Integer }; +procedure _Insert{ source : ShortString; var s : openstring; index : Integer }; +procedure _Pos{ substr : ShortString; s : ShortString ) : Integer}; +procedure _SetLength(s: PShortString; newLength: Byte); +procedure _SetString(s: PShortString; buffer: PChar; len: Byte); + +procedure UniqueString(var str: AnsiString); overload; +procedure UniqueString(var str: WideString); overload; +procedure _UniqueStringA(var str: AnsiString); +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 _NewAnsiString(length: Longint): Pointer; { for debugger purposes only } +function _NewWideString(CharLength: Longint): Pointer; + +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); +function _WStrToPWChar(const S: WideString): PWideChar; +function _WStrLen(const S: WideString): Integer; +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); +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; + +procedure _Initialize(p: Pointer; typeInfo: Pointer); +procedure _InitializeArray(p: Pointer; typeInfo: Pointer; elemCount: Cardinal); +procedure _InitializeRecord(p: Pointer; typeInfo: Pointer); +procedure _Finalize(p: Pointer; typeInfo: Pointer); +procedure _FinalizeArray(p: Pointer; typeInfo: Pointer; elemCount: Cardinal); +procedure _FinalizeRecord(P: Pointer; typeInfo: Pointer); +procedure _AddRef; +procedure _AddRefArray; +procedure _AddRefRecord; +procedure _CopyArray; +procedure _CopyRecord; +procedure _CopyObject; + +function _New(size: Longint; typeInfo: Pointer): Pointer; +procedure _Dispose(p: Pointer; typeInfo: Pointer); + +{ 64-bit Integer helper routines } +procedure __llmul; +procedure __lldiv; +procedure __lludiv; +procedure __llmod; +procedure __llmulo; +procedure __lldivo; +procedure __llmodo; +procedure __llumod; +procedure __llshl; +procedure __llushr; +procedure _WriteInt64; +procedure _Write0Int64; +procedure _ReadInt64; +function _StrInt64(val: Int64; width: Integer): ShortString; +function _Str0Int64(val: Int64): ShortString; +function _ValInt64(const s: AnsiString; var code: Integer): Int64; + +{ Dynamic array helper functions } + +procedure _DynArrayHigh; +procedure _DynArrayClear(var a: Pointer; typeInfo: Pointer); +procedure _DynArrayLength; +procedure _DynArraySetLength; +procedure _DynArrayCopy(a: Pointer; typeInfo: Pointer; var Result: Pointer); +procedure _DynArrayCopyRange(a: Pointer; typeInfo: Pointer; index, count : Integer; var Result: Pointer); +procedure _DynArrayAsg; +procedure _DynArrayAddRef; + +procedure DynArrayClear(var a: Pointer; typeInfo: Pointer); +procedure DynArraySetLength(var a: Pointer; typeInfo: Pointer; dimCnt: Longint; lengthVec: PLongint); +function DynArrayDim(typeInfo: PDynArrayTypeInfo): Integer; +{$NODEFINE DynArrayDim} + +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); + +{$IFDEF MSWINDOWS} +procedure _FSafeDivide; +procedure _FSafeDivideR; +{$ENDIF} + +function _CheckAutoResult(ResultCode: HResult): HResult; + +procedure FPower10; + +procedure TextStart; deprecated; + +// Conversion utility routines for C++ convenience. Not for Delphi code. +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; + +{ Internal runtime error codes } + +type + TRuntimeError = (reNone, reOutOfMemory, reInvalidPtr, reDivByZero, + reRangeError, reIntOverflow, reInvalidOp, reZeroDivide, reOverflow, + reUnderflow, reInvalidCast, reAccessViolation, rePrivInstruction, + reControlBreak, reStackOverflow, + { reVar* used in Variants.pas } + reVarTypeCast, reVarInvalidOp, + reVarDispatch, reVarArrayCreate, reVarNotArray, reVarArrayBounds, + reAssertionFailed, + reExternalException, { not used here; in SysUtils } + reIntfCastError, reSafeCallError); +{$NODEFINE TRuntimeError} + +procedure Error(errorCode: TRuntimeError); +{$NODEFINE Error} + +{ GetLastError returns the last error reported by an OS API call. Calling + this function usually resets the OS error state. +} + +function GetLastError: Integer; {$IFDEF MSWINDOWS} stdcall; {$ENDIF} +{$EXTERNALSYM GetLastError} + +{ SetLastError writes to the thread local storage area read by GetLastError. } + +procedure SetLastError(ErrorCode: Integer); {$IFDEF MSWINDOWS} stdcall; {$ENDIF} + +{$IFDEF LINUX} +{ To improve performance, some RTL routines cache module handles and data + derived from modules. If an application dynamically loads and unloads + shared object libraries, packages, or resource packages, it is possible for + the handle of the newly loaded module to match the handle of a recently + unloaded module. The resource caches have no way to detect when this happens. + + To address this issue, the RTL maintains an internal counter that is + incremented every time a module is loaded or unloaded using RTL functions + (like LoadPackage). This provides a cache version level signature that + can detect when modules have been cycled but have the same handle. + + If you load or unload modules "by hand" using dlopen or dlclose, you must call + InvalidateModuleCache after each load or unload so that the RTL module handle + caches will refresh themselves properly the next time they are used. This is + especially important if you manually tinker with the LibModuleList list of + loaded modules, or manually add or remove resource modules in the nodes + of that list. + + ModuleCacheID returns the "current generation" or version number kept by + the RTL. You can use this to implement your own refresh-on-next-use + (passive) module handle caches as the RTL does. The value changes each + time InvalidateModuleCache is called. +} + +function ModuleCacheID: Cardinal; +procedure InvalidateModuleCache; +{$ENDIF} + +{$IFDEF LINUX} +{ When a process that is being debugged is stopped while it has the mouse + pointer grabbed, there is no way for the debugger to release the grab on + behalf of the process. The process needs to do it itself. To accomplish this, + the debugger causes DbgUnlockX to execute whenever it detects the process + might have the mouse grabbed. This method will call through DbgUnlockXProc + which should be assigned by any library using X and locks the X pointer. This + method should be chained, by storing of the previous instance and calling it + when you are called, since there might be more than one display that needs + to be unlocked. This method should call XUngrabPointer on the display that + has the pointer grabbed. +} +var + DbgUnlockXProc: procedure; + +procedure DbgUnlockX; +{$ENDIF} + +{X+ moved here from SysInit.pas - by advise of Alexey Torgashin - to avoid + creating of separate import block from kernel32.dll : } +////////////////////////////////////////////////////////////////////////// + +function FreeLibrary(ModuleHandle: Longint): LongBool; stdcall; +function GetModuleFileName(Module: Integer; Filename: PChar; Size: Integer): Integer; stdcall; +function GetModuleHandle(ModuleName: PChar): Integer; stdcall; +function LocalAlloc(flags, size: Integer): Pointer; stdcall; +function LocalFree(addr: Pointer): Pointer; stdcall; +function TlsAlloc: Integer; stdcall; +function TlsFree(TlsIndex: Integer): Boolean; stdcall; +function TlsGetValue(TlsIndex: Integer): Pointer; stdcall; +function TlsSetValue(TlsIndex: Integer; TlsValue: Pointer): Boolean; stdcall; +function GetCommandLine: PChar; stdcall; +{X-}////////////////////////////////////////////////////////////////////// + +{X+} +{X}function GetProcessHeap: THandle; stdcall; +{X}function HeapAlloc(hHeap: THandle; dwFlags, dwBytes: Cardinal): Pointer; stdcall; +{X}function HeapReAlloc(hHeap: THandle; dwFlags: Cardinal; lpMem: Pointer; dwBytes: Cardinal): Pointer; stdcall; +{X}function HeapFree(hHeap: THandle; dwFlags: Cardinal; lpMem: Pointer): LongBool; stdcall; +{X}function DfltGetMem(size: Integer): Pointer; +{X}function DfltFreeMem(p: Pointer): Integer; +{X}function DfltReallocMem(p: Pointer; size: Integer): Pointer; +{X} procedure InitUnitsLight( Table : PUnitEntryTable; Idx, Count : Integer ); +{X} procedure FInitUnitsLight; +{X} // following two procedures are optional and exclusive. +{X} // call it to provide error message: first - for GUI app, +{X} // second - for console app. +{X} procedure UseErrorMessageBox; +{X} procedure UseErrorMessageWrite; + +{X} // call following procedure to initialize Input and Output +{X} // - for console app only: +{X} procedure UseInputOutput; + +{X} // if your app uses FPU, call one of following procedures: +{X} procedure FpuInit; +{X} procedure FpuInitConsiderNECWindows; +{X} // the second additionally takes into consideration NEC +{X} // Windows keyboard (Japaneeze keyboard ???). + +{X} procedure DummyProc; // empty procedure + +(* +{X} procedure VariantClr; +{X} // procedure to refer to _VarClr if SysVarnt.pas is in use +{X} var VarClrProc : procedure = DummyProc; + +{X} procedure VarCastError; +{X} procedure VarInvalidOp; + +{X} procedure VariantAddRef; +{X} // procedure to refer to _VarAddRef if SysVarnt.pas is in use +{X} var VarAddRefProc : procedure = DummyProc; +*) + +{X} procedure WStrAddRef; +{X} // procedure to refer to _WStrAddRef if SysWStr.pas is in use +{X} var WStrAddRefProc : procedure = DummyProc; + +{X} procedure WStrClr; +{X} // procedure to refer to _WStrClr if SysWStr.pas is in use +{X} var WStrClrProc : procedure = DummyProc; + +{X} procedure WStrArrayClr; +{X} // procedure to refer to _WStrArrayClr if SysWStr.pas is in use +{X} var WStrArrayClrProc : procedure = DummyProc; + +{X} // Standard Delphi units initialization/finalization uses +{X} // try-except and raise constructions, which leads to permanent +{X} // usage of all exception handling routines. In this XCL-aware +{X} // implementation, "light" version of initialization/finalization +{X} // is used by default. To use standard Delphi initialization and +{X} // finalization method, allowing to flow execution control even +{X} // in initalization sections, include reference to SysSfIni.pas +{X} // into uses clause *as first as possible*. +{X} procedure InitUnitsHard( Table : PUnitEntryTable; Idx, Count : Integer ); +{X} var InitUnitsProc : procedure( Table : PUnitEntryTable; Idx, Count : Integer ) +{X} = InitUnitsLight; +{X} procedure FInitUnitsHard; +{X} var FInitUnitsProc : procedure = FInitUnitsLight; +{X} procedure SetExceptionHandler; +{X} procedure UnsetExceptionHandler; +{X} var UnsetExceptionHandlerProc : procedure = DummyProc; + +{X} var UnloadResProc: procedure = DummyProc; +{X-} + +(* =================================================================== *) + +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; + +{X+} +const + advapi32 = 'advapi32.dll'; + kernel = 'kernel32.dll'; + user = 'user32.dll'; + oleaut = 'oleaut32.dll'; + +function GetProcessHeap; external kernel name 'GetProcessHeap'; +function HeapAlloc; stdcall; external kernel name 'HeapAlloc'; +function HeapReAlloc; stdcall; external kernel name 'HeapReAlloc'; +function HeapFree; stdcall; external kernel name 'HeapFree'; +{X-} + +{$IFDEF PIC} +function GetGOT: LongWord; export; +begin + asm + MOV Result,EBX + end; +end; +{$ENDIF} + +{$IFDEF PC_MAPPED_EXCEPTIONS} +const + UNWINDFI_TOPOFSTACK = $BE00EF00; + +{$IFDEF MSWINDOWS} +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'; +{$ENDIF} +{$IFDEF LINUX} +const + unwind = 'libborunwind.so.6'; +type + UNWINDPROC = Pointer; + +{$DEFINE STATIC_UNWIND} + +{$IFDEF STATIC_UNWIND} +function _BorUnwind_RegisterIPLookup(fn: UNWINDPROC; StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; cdecl; + external; + +procedure _BorUnwind_UnregisterIPLookup(StartAddr: LongInt); cdecl; external; + +function _BorUnwind_DelphiLookup(Addr: LongInt; Context: Pointer): UNWINDPROC; cdecl; external; + +function _BorUnwind_RaiseException(Exc: Pointer): LongBool; cdecl; external; + +//function _BorUnwind_AddressIsInPCMap(Addr: LongInt): LongBool; cdecl; external; +function _BorUnwind_ClosestDelphiHandler(Context: Pointer): LongWord; cdecl; external; +{$ELSE} + +function _BorUnwind_RegisterIPLookup(fn: UNWINDPROC; StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; cdecl; + external unwind name '_BorUnwind_RegisterIPLookup'; + +procedure _BorUnwind_UnregisterIPLookup(StartAddr: LongInt); cdecl; + external unwind name '_BorUnwind_UnregisterIPLookup'; + +function _BorUnwind_DelphiLookup(Addr: LongInt; Context: Pointer): UNWINDPROC; cdecl; + external unwind name '_BorUnwind_DelphiLookup'; + +function _BorUnwind_RaiseException(Exc: Pointer): LongBool; cdecl; + external unwind name '_BorUnwind_RaiseException'; + +function _BorUnwind_ClosestDelphiHandler(Context: Pointer): LongWord; cdecl; + external unwind name '_BorUnwind_ClosestDelphiHandler'; +{$ENDIF} +{$ENDIF} +{$ENDIF} + +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} + PRaisedException = ^TRaisedException; + TRaisedException = packed record + RefCount: Integer; + ExceptObject: TObject; + ExceptionAddr: Pointer; + HandlerEBP: LongWord; + Flags: LongWord; + 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 LINUX} +const + libc = 'libc.so.6'; + libdl = 'libdl.so.2'; + libpthread = 'libpthread.so.0'; + + O_RDONLY = $0000; + O_WRONLY = $0001; + O_RDWR = $0002; + O_CREAT = $0040; + O_EXCL = $0080; + O_NOCTTY = $0100; + O_TRUNC = $0200; + O_APPEND = $0400; + + // protection flags + S_IREAD = $0100; // Read by owner. + S_IWRITE = $0080; // Write by owner. + S_IEXEC = $0040; // Execute by owner. + S_IRUSR = S_IREAD; + S_IWUSR = S_IWRITE; + S_IXUSR = S_IEXEC; + S_IRWXU = S_IRUSR or S_IWUSR or S_IXUSR; + + S_IRGRP = S_IRUSR shr 3; // Read by group. + S_IWGRP = S_IWUSR shr 3; // Write by group. + S_IXGRP = S_IXUSR shr 3; // Execute by group. + S_IRWXG = S_IRWXU shr 3; // Read, write, and execute by group. + + S_IROTH = S_IRGRP shr 3; // Read by others. + S_IWOTH = S_IWGRP shr 3; // Write by others. + S_IXOTH = S_IXGRP shr 3; // Execute by others. + S_IRWXO = S_IRWXG shr 3; // Read, write, and execute by others. + + STDIN_FILENO = 0; + STDOUT_FILENO = 1; + STDERR_FILENO = 2; + + SEEK_SET = 0; + SEEK_CUR = 1; + SEEK_END = 2; + + LC_CTYPE = 0; + _NL_CTYPE_CODESET_NAME = LC_CTYPE shl 16 + 14; + + MAX_PATH = 4095; + + +function __open(PathName: PChar; Flags: Integer; Mode: Integer): Integer; cdecl; + external libc name 'open'; + +function __close(Handle: Integer): Integer; cdecl; + external libc name 'close'; + +function __read(Handle: Integer; Buffer: Pointer; Count: Cardinal): Cardinal; cdecl; + external libc name 'read'; + +function __write(Handle: Integer; Buffer: Pointer; Count: Cardinal): Cardinal; cdecl; + external libc name 'write'; + +function __mkdir(PathName: PChar; Mode: Integer): Integer; cdecl; + external libc name 'mkdir'; + +function __getcwd(Buffer: PChar; BufSize: Integer): PChar; cdecl; + external libc name 'getcwd'; + +function __getenv(Name: PChar): PChar; cdecl; + external libc name 'getenv'; + +function __chdir(PathName: PChar): Integer; cdecl; + external libc name 'chdir'; + +function __rmdir(PathName: PChar): Integer; cdecl; + external libc name 'rmdir'; + +function __remove(PathName: PChar): Integer; cdecl; + external libc name 'remove'; + +function __rename(OldPath, NewPath: PChar): Integer; cdecl; + external libc name 'rename'; + +{$IFDEF EFENCE} +function __malloc(Size: Integer): Pointer; cdecl; + external 'libefence.so' name 'malloc'; + +procedure __free(P: Pointer); cdecl; + external 'libefence.so' name 'free'; + +function __realloc(P: Pointer; Size: Integer): Pointer; cdecl; + external 'libefence.so' name 'realloc'; +{$ELSE} +function __malloc(Size: Integer): Pointer; cdecl; + external libc name 'malloc'; + +procedure __free(P: Pointer); cdecl; + external libc name 'free'; + +function __realloc(P: Pointer; Size: Integer): Pointer; cdecl; + external libc name 'realloc'; +{$ENDIF} + +procedure ExitProcess(status: Integer); cdecl; + external libc name 'exit'; + +function _time(P: Pointer): Integer; cdecl; + external libc name 'time'; + +function _lseek(Handle, Offset, Direction: Integer): Integer; cdecl; + external libc name 'lseek'; + +function _ftruncate(Handle: Integer; Filesize: Integer): Integer; cdecl; + external libc name 'ftruncate'; + +function strcasecmp(s1, s2: PChar): Integer; cdecl; + external libc name 'strcasecmp'; + +function __errno_location: PInteger; cdecl; + external libc name '__errno_location'; + +function nl_langinfo(item: integer): pchar; cdecl; + external libc name 'nl_langinfo'; + +function iconv_open(ToCode: PChar; FromCode: PChar): Integer; cdecl; + external libc name 'iconv_open'; + +function iconv(cd: Integer; var InBuf; var InBytesLeft: Integer; var OutBuf; var OutBytesLeft: Integer): Integer; cdecl; + external libc name 'iconv'; + +function iconv_close(cd: Integer): Integer; cdecl; + external libc name 'iconv_close'; + +function mblen(const S: PChar; N: LongWord): Integer; cdecl; + external libc name 'mblen'; + +function mmap(start: Pointer; length: Cardinal; prot, flags, fd, offset: Integer): Pointer; cdecl; + external libc name 'mmap'; + +function munmap(start: Pointer; length: Cardinal): Integer; cdecl; + external libc name 'munmap'; + +const + SIGABRT = 6; + +function __raise(SigNum: Integer): Integer; cdecl; + external libc name 'raise'; + +type + TStatStruct = record + st_dev: Int64; // device + __pad1: Word; + st_ino: Cardinal; // inode + st_mode: Cardinal; // protection + st_nlink: Cardinal; // number of hard links + st_uid: Cardinal; // user ID of owner + st_gid: Cardinal; // group ID of owner + st_rdev: Int64; // device type (if inode device) + __pad2: Word; + st_size: Cardinal; // total size, in bytes + st_blksize: Cardinal; // blocksize for filesystem I/O + st_blocks: Cardinal; // number of blocks allocated + st_atime: Integer; // time of last access + __unused1: Cardinal; + st_mtime: Integer; // time of last modification + __unused2: Cardinal; + st_ctime: Integer; // time of last change + __unused3: Cardinal; + __unused4: Cardinal; + __unused5: Cardinal; + end; + +const + STAT_VER_LINUX = 3; + +function _fxstat(Version: Integer; Handle: Integer; var Stat: TStatStruct): Integer; cdecl; + external libc name '__fxstat'; + +function __xstat(Ver: Integer; FileName: PChar; var StatBuffer: TStatStruct): Integer; cdecl; + external libc name '__xstat'; + +function _strlen(P: PChar): Integer; cdecl; + external libc name 'strlen'; + +function _readlink(PathName: PChar; Buf: PChar; Len: Integer): Integer; cdecl; + external libc name 'readlink'; + +type + TDLInfo = record + FileName: PChar; + BaseAddress: Pointer; + NearestSymbolName: PChar; + SymbolAddress: Pointer; + end; + +const + RTLD_LAZY = 1; + RTLD_NOW = 2; + +function dladdr(Address: Pointer; var Info: TDLInfo): Integer; cdecl; + external libdl name 'dladdr'; +function dlopen(Filename: PChar; Flag: Integer): LongWord; cdecl; + external libdl name 'dlopen'; +function dlclose(Handle: LongWord): Integer; cdecl; + external libdl name 'dlclose'; +function FreeLibrary(Handle: LongWord): Integer; cdecl; + external libdl name 'dlclose'; +function dlsym(Handle: LongWord; Symbol: PChar): Pointer; cdecl; + external libdl name 'dlsym'; +function dlerror: PChar; cdecl; + external libdl name 'dlerror'; + +type + TPthread_fastlock = record + __status: LongInt; + __spinlock: Integer; + end; + + TRTLCriticalSection = record + __m_reserved, + __m_count: Integer; + __m_owner: Pointer; + __m_kind: Integer; // __m_kind := 0 fastlock, __m_kind := 1 recursive lock + __m_lock: TPthread_fastlock; + end; + +function _pthread_mutex_lock(var Mutex: TRTLCriticalSection): Integer; cdecl; + external libpthread name 'pthread_mutex_lock'; +function _pthread_mutex_unlock(var Mutex: TRTLCriticalSection): Integer; cdecl; + external libpthread name 'pthread_mutex_unlock'; +function _pthread_create(var ThreadID: Cardinal; Attr: PThreadAttr; + TFunc: TThreadFunc; Arg: Pointer): Integer; cdecl; + external libpthread name 'pthread_create'; +function _pthread_exit(var RetVal: Integer): Integer; cdecl; + external libpthread name 'pthread_exit'; +function GetCurrentThreadID: LongWord; cdecl; + external libpthread name 'pthread_self'; +function _pthread_detach(ThreadID: Cardinal): Integer; cdecl; + external libpthread name 'pthread_detach' + +function GetLastError: Integer; +begin + Result := __errno_location^; +end; + +procedure SetLastError(ErrorCode: Integer); +begin + __errno_location^ := ErrorCode; +end; + +function InterlockedIncrement(var I: Integer): Integer; +asm + MOV EDX,1 + XCHG EAX,EDX + LOCK XADD [EDX],EAX + INC EAX +end; + +function InterlockedDecrement(var I: Integer): Integer; +asm + MOV EDX,-1 + XCHG EAX,EDX + LOCK XADD [EDX],EAX + DEC EAX +end; + +var + ModuleCacheVersion: Cardinal = 0; + +function ModuleCacheID: Cardinal; +begin + Result := ModuleCacheVersion; +end; + +procedure InvalidateModuleCache; +begin + InterlockedIncrement(Integer(ModuleCacheVersion)); +end; + +{$ENDIF} + +{$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 + 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; + +{X+ moved here from SysInit.pas - by advise of Alexey Torgashin - to avoid + creating of separate import block from kernel32.dll : } +////////////////////////////////////////////////////////////////////////// + +function FreeLibrary(ModuleHandle: Longint): LongBool; stdcall; + external kernel name 'FreeLibrary'; + +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 LocalAlloc(flags, size: Integer): Pointer; stdcall; + external kernel name 'LocalAlloc'; + +function LocalFree(addr: Pointer): Pointer; stdcall; + external kernel name 'LocalFree'; + +function TlsAlloc: Integer; stdcall; + external kernel name 'TlsAlloc'; + +function TlsFree(TlsIndex: Integer): Boolean; stdcall; + external kernel name 'TlsFree'; + +function TlsGetValue(TlsIndex: Integer): Pointer; stdcall; + external kernel name 'TlsGetValue'; + +function TlsSetValue(TlsIndex: Integer; TlsValue: Pointer): Boolean; stdcall; + external kernel name 'TlsSetValue'; + +function GetCommandLine: PChar; stdcall; + external kernel name 'GetCommandLineA'; +{X-}////////////////////////////////////////////////////////////////////// + + +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'; + +{X} //function FreeLibrary(ModuleHandle: Longint): LongBool; stdcall; +{X} // external kernel name 'FreeLibrary'; + +{X} //function GetCommandLine: PChar; stdcall; +{X} // 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'; + +{X} //function GetModuleFileName(Module: Integer; Filename: PChar; +{X} // Size: Integer): Integer; stdcall; +{X} // external kernel name 'GetModuleFileNameA'; + +{X} //function GetModuleHandle(ModuleName: PChar): Integer; stdcall; +{X} // 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 GetCmdShow: Integer; +var + SI: TStartupInfo; +begin + Result := 10; { SW_SHOWDEFAULT } + GetStartupInfo(SI); + if SI.dwFlags and 1 <> 0 then { STARTF_USESHOWWINDOW } + Result := SI.wShowWindow; +end; + +{$ENDIF} // MSWindows + +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} + + +//////////////////// This code is from HeapMM.pas, (C) by Vladimir Kladov, 2001 +const + HEAP_NO_SERIALIZE = $00001; + HEAP_GROWABLE = $00002; + HEAP_GENERATE_EXCEPTIONS = $00004; + HEAP_ZERO_MEMORY = $00008; + HEAP_REALLOC_IN_PLACE_ONLY = $00010; + HEAP_TAIL_CHECKING_ENABLED = $00020; + HEAP_FREE_CHECKING_ENABLED = $00040; + HEAP_DISABLE_COALESCE_ON_FREE = $00080; + HEAP_CREATE_ALIGN_16 = $10000; + HEAP_CREATE_ENABLE_TRACING = $20000; + HEAP_MAXIMUM_TAG = $00FFF; + HEAP_PSEUDO_TAG_FLAG = $08000; + HEAP_TAG_SHIFT = 16 ; + +{$DEFINE USE_PROCESS_HEAP} + +var + HeapHandle: THandle; + {* Global handle to the heap. Do not change it! } + + HeapFlags: DWORD = 0; + {* Possible flags are: + HEAP_GENERATE_EXCEPTIONS - system will raise an exception to indicate a + function failure, such as an out-of-memory + condition, instead of returning NULL. + HEAP_NO_SERIALIZE - mutual exclusion will not be used while the HeapAlloc + function is accessing the heap. Be careful! + Not recommended for multi-thread applications. + But faster. + HEAP_ZERO_MEMORY - obviously. (Slower!) + } + + { Note from MSDN: + The granularity of heap allocations in Win32 is 16 bytes. So if you + request a global memory allocation of 1 byte, the heap returns a pointer + to a chunk of memory, guaranteeing that the 1 byte is available. Chances + are, 16 bytes will actually be available because the heap cannot allocate + less than 16 bytes at a time. + } + +function DfltGetMem(size: Integer): Pointer; +// Allocate memory block. +begin + Result := HeapAlloc( HeapHandle, HeapFlags, size ); +end; + +function DfltFreeMem(p: Pointer): Integer; +// Deallocate memory block. +begin + Result := Integer( not HeapFree( HeapHandle, HeapFlags and HEAP_NO_SERIALIZE, + p ) ); +end; + +function DfltReallocMem(p: Pointer; size: Integer): Pointer; +// Resize memory block. +begin + Result := HeapRealloc( HeapHandle, HeapFlags and (HEAP_NO_SERIALIZE and + HEAP_GENERATE_EXCEPTIONS and HEAP_ZERO_MEMORY), + // (Prevent using flag HEAP_REALLOC_IN_PLACE_ONLY here - to allow + // system to move the block if necessary). + p, size ); +end; + +//////////////////////////////////////////// end of HeapMM + + +{$IFDEF LINUX} +function SysGetMem(Size: Integer): Pointer; +begin + Result := __malloc(size); +end; + +function SysFreeMem(P: Pointer): Integer; +begin + __free(P); + Result := 0; +end; + +function SysReallocMem(P: Pointer; Size: Integer): Pointer; +begin + Result := __realloc(P, Size); +end; + +{$ENDIF} + +{X- by default, system memory allocation routines (API calls) + are used. To use Inprise's memory manager (Delphi standard) + call UseDelphiMemoryManager procedure. } +var + MemoryManager: TMemoryManager = ( + GetMem: DfltGetMem; + FreeMem: DfltFreeMem; + ReallocMem: DfltReallocMem); + +const + DelphiMemoryManager: TMemoryManager = ( + GetMem: SysGetMem; + FreeMem: SysFreeMem; + ReallocMem: SysReallocMem); + +procedure UseDelphiMemoryManager; +begin + IsMemoryManagerSet := IsDelphiMemoryManagerSet; + SetMemoryManager( DelphiMemoryManager ); +end; +{X+} + + +{$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 debug_init; external; +procedure debug_print; external; +procedure debug_class_enabled; external; +procedure debug_continue; external; +{$ENDIF} +{$ENDIF} + +{X}{$IFDEF MSWINDOWS} +{X}function _GetMem(Size: Integer): Pointer; +{X}asm +{X} TEST EAX,EAX +{X} JE @@1 +{X} CALL MemoryManager.GetMem +{X} OR EAX,EAX +{X} JE @@2 +{X}@@1: RET +{X}@@2: MOV AL,reOutOfMemory +{X} JMP Error +{X}end; +{X}{$ELSE} +function _GetMem(Size: Integer): Pointer; +{$IF Defined(DEBUG) and Defined(LINUX)} +var + Signature: PLongInt; +{$IFEND} +begin + if Size > 0 then + begin +{$IF Defined(DEBUG) and Defined(LINUX)} + Signature := PLongInt(MemoryManager.GetMem(Size + 4)); + if Signature = nil then + Error(reOutOfMemory); + Signature^ := 0; + Result := Pointer(LongInt(Signature) + 4); +{$ELSE} + Result := MemoryManager.GetMem(Size); + if Result = nil then + Error(reOutOfMemory); +{$IFEND} + end + else + Result := nil; +end; +{X}{$ENDIF MSWINDOWS} + + +const + FreeMemorySignature = Longint($FBEEFBEE); + +{X}{$IFDEF MSWINDOWS} +{X}function _FreeMem(P: Pointer): Integer; +{X}asm +{X} TEST EAX,EAX +{X} JE @@1 +{X} CALL MemoryManager.FreeMem +{X} OR EAX,EAX +{X} JNE @@2 +{X}@@1: RET +{X}@@2: MOV AL,reInvalidPtr +{X} JMP Error +{X}end; +{X}{$ELSE} +function _FreeMem(P: Pointer): Integer; +{$IF Defined(DEBUG) and Defined(LINUX)} +var + Signature: PLongInt; +{$IFEND} +begin + if P <> nil then + begin +{$IF Defined(DEBUG) and Defined(LINUX)} + Signature := PLongInt(LongInt(P) - 4); + if Signature^ <> 0 then + Error(reInvalidPtr); + Signature^ := FreeMemorySignature; + Result := MemoryManager.Freemem(Pointer(Signature)); +{$ELSE} + Result := MemoryManager.FreeMem(P); +{$IFEND} + if Result <> 0 then + Error(reInvalidPtr); + end + else + Result := 0; +end; +{X}{$ENDIF MSWINDOWS} + +{$IFDEF LINUX} +function _ReallocMem(var P: Pointer; NewSize: Integer): Pointer; +{$IFDEF DEBUG} +var + Temp: Pointer; +{$ENDIF} +begin + if P <> nil then + begin +{$IFDEF DEBUG} + Temp := Pointer(LongInt(P) - 4); + if NewSize > 0 then + begin + Temp := MemoryManager.ReallocMem(Temp, NewSize + 4); + Result := Pointer(LongInt(Temp) + 4); + end + else + begin + MemoryManager.FreeMem(Temp); + Result := nil; + end; +{$ELSE} + if NewSize > 0 then + begin + Result := MemoryManager.ReallocMem(P, NewSize); + end + else + begin + MemoryManager.FreeMem(P); + Result := nil; + end; +{$ENDIF} + P := Result; + end else + begin + Result := _GetMem(NewSize); + P := Result; + end; +end; +{$ELSEIF Defined(MSWINDOWS)} +function _ReallocMem(var P: Pointer; NewSize: Integer): Pointer; +asm + MOV ECX,[EAX] + TEST ECX,ECX + JE @@alloc + TEST EDX,EDX + JE @@free +@@resize: + PUSH EAX + MOV EAX,ECX + CALL MemoryManager.ReallocMem + POP ECX + OR EAX,EAX + JE @@allocError + MOV [ECX],EAX + RET +@@freeError: + MOV AL,reInvalidPtr + JMP Error +@@free: + MOV [EAX],EDX + MOV EAX,ECX + CALL MemoryManager.FreeMem + OR EAX,EAX + JNE @@freeError + RET +@@allocError: + MOV AL,reOutOfMemory + JMP Error +@@alloc: + TEST EDX,EDX + JE @@exit + PUSH EAX + MOV EAX,EDX + CALL MemoryManager.GetMem + POP ECX + OR EAX,EAX + JE @@allocError + MOV [ECX],EAX +@@exit: +end; +{$IFEND} + +procedure GetMemoryManager(var MemMgr: TMemoryManager); +begin + MemMgr := MemoryManager; +end; + +procedure SetMemoryManager(const MemMgr: TMemoryManager); +begin + MemoryManager := MemMgr; +end; + +//{X} - function is replaced with pointer to one. +// function IsMemoryManagerSet: Boolean; +function IsDelphiMemoryManagerSet: Boolean; +begin + with MemoryManager do + Result := (@GetMem <> @SysGetMem) or (@FreeMem <> @SysFreeMem) or + (@ReallocMem <> @SysReallocMem); +end; + +{X+ always returns False. Initial handler for IsMemoryManagerSet } +function MemoryManagerNotUsed : Boolean; +begin + Result := False; +end; +{X-} + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure GetUnwinder(var Dest: TUnwinder); +begin + Dest := Unwinder; +end; + +procedure SetUnwinder(const NewUnwinder: TUnwinder); +begin + Unwinder := NewUnwinder; +end; + +function IsUnwinderSet: Boolean; +begin + with Unwinder do + Result := (@RaiseException <> @_BorUnwind_RaiseException) or + (@RegisterIPLookup <> @_BorUnwind_RegisterIPLookup) or + (@UnregisterIPLookup <> @_BorUnwind_UnregisterIPLookup) or + (@DelphiLookup <> @_BorUnwind_DelphiLookup); +end; + +procedure InitUnwinder; +var + Addr: Pointer; +begin + { + We look to see if we can find a dynamic version of the unwinder. This will + be the case if the application used Unwind.pas. If it is present, then we + fire it up. Otherwise, we use our static copy. + } + Addr := dlsym(0, '_BorUnwind_RegisterIPLookup'); + if Addr <> nil then + begin + Unwinder.RegisterIPLookup := Addr; + Addr := dlsym(0, '_BorUnwind_UnregisterIPLookup'); + Unwinder.UnregisterIPLookup := Addr; + Addr := dlsym(0, '_BorUnwind_RaiseException'); + Unwinder.RaiseException := Addr; + Addr := dlsym(0, '_BorUnwind_DelphiLookup'); + Unwinder.DelphiLookup := Addr; + Addr := dlsym(0, '_BorUnwind_ClosestHandler'); + Unwinder.ClosestHandler := Addr; + end + else + begin + dlerror; // clear error state; dlsym doesn't + Unwinder.RegisterIPLookup := _BorUnwind_RegisterIPLookup; + Unwinder.DelphiLookup := _BorUnwind_DelphiLookup; + Unwinder.UnregisterIPLookup := _BorUnwind_UnregisterIPLookup; + Unwinder.RaiseException := _BorUnwind_RaiseException; + Unwinder.ClosestHandler := _BorUnwind_ClosestDelphiHandler; + end; +end; + +function SysClosestDelphiHandler(Context: Pointer): LongWord; +begin + if not Assigned(Unwinder.ClosestHandler) then + InitUnwinder; + Result := Unwinder.ClosestHandler(Context); +end; + +function SysRegisterIPLookup(StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; +begin +// xxx + if not Assigned(Unwinder.RegisterIPLookup) then + begin + InitUnwinder; +// Unwinder.RegisterIPLookup := UnwindRegisterIPLookup; +// Unwinder.DelphiLookup := UnwindDelphiLookup; + end; + Result := Unwinder.RegisterIPLookup(@Unwinder.DelphiLookup, StartAddr, EndAddr, Context, GOT); +end; + +procedure SysUnregisterIPLookup(StartAddr: LongInt); +begin +// if not Assigned(Unwinder.UnregisterIPLookup) then +// Unwinder.UnregisterIPLookup := UnwindUnregisterIPLookup; + Unwinder.UnregisterIPLookup(StartAddr); +end; + +function SysRaiseException(Exc: Pointer): LongBool; export; +begin +// if not Assigned(Unwinder.RaiseException) then +// Unwinder.RaiseException := UnwindRaiseException; + Result := Unwinder.RaiseException(Exc); +end; + +const + MAX_NESTED_EXCEPTIONS = 16; +{$ENDIF} + +threadvar +{$IFDEF PC_MAPPED_EXCEPTIONS} + ExceptionObjects: array[0..MAX_NESTED_EXCEPTIONS-1] of TRaisedException; + ExceptionObjectCount: Integer; + OSExceptionsBlocked: Integer; +{$ELSE} + RaiseListPtr: pointer; +{$ENDIF} + InOutRes: Integer; + +{$IFDEF PUREPASCAL} +var + notimpl: array [0..15] of Char = 'not implemented'#10; + +procedure NotImplemented; +begin + __write (2, @notimpl, 16); + Halt; +end; +{$ENDIF} + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure BlockOSExceptions; +asm + PUSH EAX + PUSH EDX + CALL SysInit.@GetTLS + MOV [EAX].OSExceptionsBlocked, 1 + POP EDX + POP EAX +end; + +procedure UnblockOSExceptions; +asm + PUSH EAX + CALL SysInit.@GetTLS + MOV [EAX].OSExceptionsBlocked, 0 + POP EAX +end; + +function AreOSExceptionsBlocked: Boolean; +asm + CALL SysInit.@GetTLS + MOV EAX, [EAX].OSExceptionsBlocked +end; + +const + TRAISEDEXCEPTION_SIZE = SizeOf(TRaisedException); + +function CurrentException: PRaisedException; +asm + CALL SysInit.@GetTLS + LEA EDX, [EAX].ExceptionObjects + MOV EAX, [EAX].ExceptionObjectCount + OR EAX, EAX + JE @@Done + DEC EAX + IMUL EAX, TRAISEDEXCEPTION_SIZE + ADD EAX, EDX +@@Done: +end; + +function AllocateException(Exception: Pointer; ExceptionAddr: Pointer): PRaisedException; +asm + PUSH EAX + PUSH EDX + CALL SysInit.@GetTLS + CMP [EAX].ExceptionObjectCount, MAX_NESTED_EXCEPTIONS-1 + JE @@TooManyNestedExceptions + INC [EAX].ExceptionObjectCount + CALL CurrentException + POP EDX + POP ECX + MOV [EAX].TRaisedException.ExceptObject, ECX + MOV [EAX].TRaisedException.ExceptionAddr, EDX + MOV [EAX].TRaisedException.RefCount, 0 + MOV [EAX].TRaisedException.HandlerEBP, $FFFFFFFF + MOV [EAX].TRaisedException.Flags, 0 + RET +@@TooManyNestedExceptions: + MOV EAX, 231 + JMP _RunError +end; + +{ + 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; +asm + CALL CurrentException + OR EAX, EAX + JE @@Error + { EAX -> the TRaisedException } + XOR ECX, ECX + { If the exception object has been referenced, we don't return it. } + CMP [EAX].TRaisedException.RefCount, 0 + JA @@GotObject + MOV ECX, [EAX].TRaisedException.ExceptObject +@@GotObject: + PUSH ECX + CALL SysInit.@GetTLS + POP ECX + DEC [EAX].ExceptionObjectCount + MOV EAX, ECX + RET +@@Error: + { Some kind of internal error } + JMP _Run0Error +end; + +function AcquireExceptionObject: Pointer; +asm + CALL CurrentException + OR EAX, EAX + JE @@Error + INC [EAX].TRaisedException.RefCount + MOV EAX, [EAX].TRaisedException.ExceptObject + RET +@@Error: + { This happens if there is no exception pending } + JMP _Run0Error +end; + +procedure ReleaseExceptionObject; +asm + CALL CurrentException + OR EAX, EAX + JE @@Error + CMP [EAX].TRaisedException.RefCount, 0 + JE @@Error + DEC [EAX].TRaisedException.RefCount + RET +@@Error: + +{ + This happens if there is no exception pending, or + if the reference count on a pending exception is + zero. +} + JMP _Run0Error +end; + +function ExceptObject: TObject; +var + Exc: PRaisedException; +begin + Exc := CurrentException; + if Exc <> nil then + Result := TObject(Exc^.ExceptObject) + else + Result := nil; +end; + +{ Return current exception address } + +function ExceptAddr: Pointer; +var + Exc: PRaisedException; +begin + Exc := CurrentException; + if Exc <> nil then + Result := Exc^.ExceptionAddr + else + Result := nil; +end; +{$ELSE} {not PC_MAPPED_EXCEPTIONS} + +function ExceptObject: TObject; +begin + if RaiseListPtr <> nil then + Result := PRaiseFrame(RaiseListPtr)^.ExceptObject + else + Result := nil; +end; + +{ Return current exception address } + +function ExceptAddr: Pointer; +begin + if RaiseListPtr <> nil then + Result := PRaiseFrame(RaiseListPtr)^.ExceptAddr + else + Result := nil; +end; + + +function AcquireExceptionObject: Pointer; +begin + if RaiseListPtr <> nil then + begin + Result := PRaiseFrame(RaiseListPtr)^.ExceptObject; + PRaiseFrame(RaiseListPtr)^.ExceptObject := nil; + end + else + Result := nil; +end; + +procedure ReleaseExceptionObject; +begin +end; + +function RaiseList: Pointer; +begin + Result := RaiseListPtr; +end; + +function SetRaiseList(NewPtr: Pointer): Pointer; +asm + PUSH EAX + CALL SysInit.@GetTLS + MOV EDX, [EAX].RaiseListPtr + POP [EAX].RaiseListPtr + MOV EAX, EDX +end; +{$ENDIF} + +{ ----------------------------------------------------- } +{ local functions & procedures of the system unit } +{ ----------------------------------------------------- } + +procedure RunErrorAt(ErrCode: Integer; ErrorAtAddr: Pointer); +begin + ErrorAddr := ErrorAtAddr; + _Halt(ErrCode); +end; + +procedure ErrorAt(ErrorCode: Byte; ErrorAddr: Pointer); + +const + reMap: array [TRunTimeError] of Byte = ( + 0, + 203, { reOutOfMemory } + 204, { reInvalidPtr } + 200, { reDivByZero } + 201, { reRangeError } +{ 210 abstract error } + 215, { reIntOverflow } + 207, { reInvalidOp } + 200, { reZeroDivide } + 205, { reOverflow } + 206, { reUnderflow } + 219, { reInvalidCast } + 216, { Access violation } + 202, { Stack overflow } + 217, { Control-C } + 218, { Privileged instruction } + 220, { Invalid variant type cast } + 221, { Invalid variant operation } + 222, { No variant method call dispatcher } + 223, { Cannot create variant array } + 224, { Variant does not contain an array } + 225, { Variant array bounds error } +{ 226 thread init failure } + 227, { reAssertionFailed } + 0, { reExternalException not used here; in SysUtils } + 228, { reIntfCastError } + 229 { reSafeCallError } +{ 230 Reserved by the compiler for unhandled exceptions } +{ 231 Too many nested exceptions } +{ 232 Fatal signal raised on a non-Delphi thread }); + +begin + errorCode := errorCode and 127; + if Assigned(ErrorProc) then + ErrorProc(errorCode, ErrorAddr); + if errorCode = 0 then + errorCode := InOutRes + else if errorCode <= Byte(High(TRuntimeError)) then + errorCode := reMap[TRunTimeError(errorCode)]; + RunErrorAt(errorCode, ErrorAddr); +end; + +procedure Error(errorCode: TRuntimeError); +asm + AND EAX,127 + MOV EDX,[ESP] + JMP ErrorAt +end; + +procedure __IOTest; +asm + PUSH EAX + PUSH EDX + PUSH ECX + CALL SysInit.@GetTLS + CMP [EAX].InOutRes,0 + POP ECX + POP EDX + POP EAX + JNE @error + RET +@error: + XOR EAX,EAX + JMP Error +end; + +procedure SetInOutRes(NewValue: Integer); +begin + InOutRes := NewValue; +end; + +procedure InOutError; +begin + SetInOutRes(GetLastError); +end; + +procedure ChDir(const S: string); +begin + ChDir(PChar(S)); +end; + +procedure ChDir(P: PChar); +begin +{$IFDEF MSWINDOWS} + if not SetCurrentDirectory(P) then +{$ENDIF} +{$IFDEF LINUX} + if __chdir(P) <> 0 then +{$ENDIF} + InOutError; +end; + +procedure _Copy{ s : ShortString; index, count : Integer ) : ShortString}; +asm +{ ->EAX Source string } +{ EDX index } +{ ECX count } +{ [ESP+4] Pointer to result string } + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,[ESP+8+4] + + XOR EAX,EAX + OR AL,[ESI] + JZ @@srcEmpty + +{ limit index to satisfy 1 <= index <= Length(src) } + + TEST EDX,EDX + JLE @@smallInx + CMP EDX,EAX + JG @@bigInx +@@cont1: + +{ limit count to satisfy 0 <= count <= Length(src) - index + 1 } + + SUB EAX,EDX { calculate Length(src) - index + 1 } + INC EAX + TEST ECX,ECX + JL @@smallCount + CMP ECX,EAX + JG @@bigCount +@@cont2: + + ADD ESI,EDX + + MOV [EDI],CL + INC EDI + REP MOVSB + JMP @@exit + +@@smallInx: + MOV EDX,1 + JMP @@cont1 +@@bigInx: +{ MOV EDX,EAX + JMP @@cont1 } +@@smallCount: + XOR ECX,ECX + JMP @@cont2 +@@bigCount: + MOV ECX,EAX + JMP @@cont2 +@@srcEmpty: + MOV [EDI],AL +@@exit: + POP EDI + POP ESI + RET 4 +end; + +procedure _Delete{ var s : openstring; index, count : Integer }; +asm +{ ->EAX Pointer to s } +{ EDX index } +{ ECX count } + + PUSH ESI + PUSH EDI + + MOV EDI,EAX + + XOR EAX,EAX + MOV AL,[EDI] + +{ if index not in [1 .. Length(s)] do nothing } + + TEST EDX,EDX + JLE @@exit + CMP EDX,EAX + JG @@exit + +{ limit count to [0 .. Length(s) - index + 1] } + + TEST ECX,ECX + JLE @@exit + SUB EAX,EDX { calculate Length(s) - index + 1 } + INC EAX + CMP ECX,EAX + JLE @@1 + MOV ECX,EAX +@@1: + SUB [EDI],CL { reduce Length(s) by count } + ADD EDI,EDX { point EDI to first char to be deleted } + LEA ESI,[EDI+ECX] { point ESI to first char to be preserved } + SUB EAX,ECX { #chars = Length(s) - index + 1 - count } + MOV ECX,EAX + + REP MOVSB + +@@exit: + POP EDI + POP ESI +end; + +procedure _LGetDir(D: Byte; var S: string); +{$IFDEF MSWINDOWS} +var + Drive: array[0..3] of Char; + DirBuf, SaveBuf: array[0..MAX_PATH] of Char; +begin + if D <> 0 then + begin + Drive[0] := Chr(D + Ord('A') - 1); + Drive[1] := ':'; + Drive[2] := #0; + GetCurrentDirectory(SizeOf(SaveBuf), SaveBuf); + SetCurrentDirectory(Drive); + end; + GetCurrentDirectory(SizeOf(DirBuf), DirBuf); + if D <> 0 then SetCurrentDirectory(SaveBuf); + S := DirBuf; +{$ENDIF} +{$IFDEF LINUX} +var + DirBuf: array[0..MAX_PATH] of Char; +begin + __getcwd(DirBuf, sizeof(DirBuf)); + S := string(DirBuf); +{$ENDIF} +end; + +procedure _SGetDir(D: Byte; var S: ShortString); +var + L: string; +begin + _LGetDir(D, L); + S := L; +end; + +procedure _Insert{ source : ShortString; var s : openstring; index : Integer }; +asm +{ ->EAX Pointer to source string } +{ EDX Pointer to destination string } +{ ECX Length of destination string } +{ [ESP+4] Index } + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH ECX + MOV ECX,[ESP+16+4] + SUB ESP,512 { VAR buf: ARRAY [0..511] of Char } + + MOV EBX,EDX { save pointer to s for later } + MOV ESI,EDX + + XOR EDX,EDX + MOV DL,[ESI] + INC ESI + +{ limit index to [1 .. Length(s)+1] } + + INC EDX + TEST ECX,ECX + JLE @@smallInx + CMP ECX,EDX + JG @@bigInx +@@cont1: + DEC EDX { EDX = Length(s) } + { EAX = Pointer to src } + { ESI = EBX = Pointer to s } + { ECX = Index } + +{ copy index-1 chars from s to buf } + + MOV EDI,ESP + DEC ECX + SUB EDX,ECX { EDX = remaining length of s } + REP MOVSB + +{ copy Length(src) chars from src to buf } + + XCHG EAX,ESI { save pointer into s, point ESI to src } + MOV CL,[ESI] { ECX = Length(src) (ECX was zero after rep) } + INC ESI + REP MOVSB + +{ copy remaining chars of s to buf } + + MOV ESI,EAX { restore pointer into s } + MOV ECX,EDX { copy remaining bytes of s } + REP MOVSB + +{ calculate total chars in buf } + + SUB EDI,ESP { length = bufPtr - buf } + MOV ECX,[ESP+512] { ECX = Min(length, destLength) } +{ MOV ECX,[EBP-16] }{ ECX = Min(length, destLength) } + CMP ECX,EDI + JB @@1 + MOV ECX,EDI +@@1: + MOV EDI,EBX { Point EDI to s } + MOV ESI,ESP { Point ESI to buf } + MOV [EDI],CL { Store length in s } + INC EDI + REP MOVSB { Copy length chars to s } + JMP @@exit + +@@smallInx: + MOV ECX,1 + JMP @@cont1 +@@bigInx: + MOV ECX,EDX + JMP @@cont1 + +@@exit: + ADD ESP,512+4 + POP EDI + POP ESI + POP EBX + RET 4 +end; + +function IOResult: Integer; +begin + Result := InOutRes; + InOutRes := 0; +end; + +procedure MkDir(const S: string); +begin + MkDir(PChar(s)); +end; + +procedure MkDir(P: PChar); +begin +{$IFDEF MSWINDOWS} + if not CreateDirectory(P, 0) then +{$ENDIF} +{$IFDEF LINUX} + if __mkdir(P, -1) <> 0 then +{$ENDIF} + InOutError; +end; + +procedure Move( const Source; var Dest; count : Integer ); +{$IFDEF PUREPASCAL} +var + S, D: PChar; + I: Integer; +begin + S := PChar(@Source); + D := PChar(@Dest); + if S = D then Exit; + if Cardinal(D) > Cardinal(S) then + for I := count-1 downto 0 do + D[I] := S[I] + else + for I := 0 to count-1 do + D[I] := S[I]; +end; +{$ELSE} +asm +{ ->EAX Pointer to source } +{ EDX Pointer to destination } +{ ECX Count } + +(*{X-} // original code. + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + MOV EAX,ECX + + CMP EDI,ESI + JA @@down + JE @@exit + + SAR ECX,2 { copy count DIV 4 dwords } + JS @@exit + + REP MOVSD + + MOV ECX,EAX + AND ECX,03H + REP MOVSB { copy count MOD 4 bytes } + JMP @@exit + +@@down: + LEA ESI,[ESI+ECX-4] { point ESI to last dword of source } + LEA EDI,[EDI+ECX-4] { point EDI to last dword of dest } + + SAR ECX,2 { copy count DIV 4 dwords } + JS @@exit + STD + REP MOVSD + + MOV ECX,EAX + AND ECX,03H { copy count MOD 4 bytes } + ADD ESI,4-1 { point to last byte of rest } + ADD EDI,4-1 + REP MOVSB + CLD +@@exit: + POP EDI + POP ESI +*){X+} +//--------------------------------------- +(* {X+} // Let us write smaller: + JCXZ @@fin + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + MOV EAX,ECX + + AND ECX,3 { copy count mod 4 dwords } + + CMP EDI,ESI + JE @@exit + JA @@up + +//down: + LEA ESI,[ESI+EAX-1] { point ESI to last byte of source } + LEA EDI,[EDI+EAX-1] { point EDI to last byte of dest } + STD + + CMP EAX, 4 + JL @@up + ADD ECX, 3 { move 3 bytes more to correct pos } + +@@up: + REP MOVSB + + SAR EAX, 2 + JS @@exit + + MOV ECX, EAX + REP MOVSD + +@@exit: + CLD + POP EDI + POP ESI + +@@fin: +*) {X-} +//--------------------------------------- +{X+} // And now, let us write speedy: + CMP ECX, 4 + JGE @@long + JCXZ @@fin + + CMP EAX, EDX + JE @@fin + + PUSH ESI + PUSH EDI + MOV ESI, EAX + MOV EDI, EDX + JA @@short_up + + LEA ESI,[ESI+ECX-1] { point ESI to last byte of source } + LEA EDI,[EDI+ECX-1] { point EDI to last byte of dest } + STD + +@@short_up: + REP MOVSB + JMP @@exit_up + +@@long: + CMP EAX, EDX + JE @@fin + + PUSH ESI + PUSH EDI + MOV ESI, EAX + MOV EDI, EDX + MOV EAX, ECX + + JA @@long_up + + { + SAR ECX, 2 + JS @@exit + + LEA ESI,[ESI+EAX-4] + LEA EDI,[EDI+EAX-4] + STD + REP MOVSD + + MOV ECX, EAX + MOV EAX, 3 + AND ECX, EAX + ADD ESI, EAX + ADD EDI, EAX + REP MOVSB + } // let's do it in other order - faster if data are aligned... + + AND ECX, 3 + LEA ESI,[ESI+EAX-1] + LEA EDI,[EDI+EAX-1] + STD + REP MOVSB + + SAR EAX, 2 + //JS @@exit // why to test this? but what does PC do? + MOV ECX, EAX + MOV EAX, 3 + SUB ESI, EAX + SUB EDI, EAX + REP MOVSD + +@@exit_up: + CLD + //JMP @@exit + DEC ECX // the same - loosing 2 tacts... but conveyer! + +@@long_up: + SAR ECX, 2 + JS @@exit + + REP MOVSD + + AND EAX, 3 + MOV ECX, EAX + REP MOVSB + +@@exit: + POP EDI + POP ESI + +@@fin: +{X-} +end; +{$ENDIF} + +{$IFDEF MSWINDOWS} +function GetParamStr(P: PChar; var Param: string): PChar; +var + i, Len: Integer; + Start, S, Q: PChar; +begin + while True do + begin + while (P[0] <> #0) and (P[0] <= ' ') do + P := CharNext(P); + if (P[0] = '"') and (P[1] = '"') then Inc(P, 2) else Break; + end; + Len := 0; + Start := P; + while P[0] > ' ' do + begin + if P[0] = '"' then + begin + P := CharNext(P); + while (P[0] <> #0) and (P[0] <> '"') do + begin + Q := CharNext(P); + Inc(Len, Q - P); + P := Q; + end; + if P[0] <> #0 then + P := CharNext(P); + end + else + begin + Q := CharNext(P); + Inc(Len, Q - P); + P := Q; + end; + end; + + SetLength(Param, Len); + + P := Start; + S := Pointer(Param); + i := 0; + while P[0] > ' ' do + begin + if P[0] = '"' then + begin + P := CharNext(P); + while (P[0] <> #0) and (P[0] <> '"') do + begin + Q := CharNext(P); + while P < Q do + begin + S[i] := P^; + Inc(P); + Inc(i); + end; + end; + if P[0] <> #0 then P := CharNext(P); + end + else + begin + Q := CharNext(P); + while P < Q do + begin + S[i] := P^; + Inc(P); + Inc(i); + end; + end; + end; + + Result := P; +end; +{$ENDIF} + +function ParamCount: Integer; +{$IFDEF MSWINDOWS} +var + P: PChar; + S: string; +begin + Result := 0; + P := GetParamStr(GetCommandLine, S); + while True do + begin + P := GetParamStr(P, S); + if S = '' then Break; + Inc(Result); + end; +{$ENDIF} +{$IFDEF LINUX} +begin + if ArgCount > 1 then + Result := ArgCount - 1 + else Result := 0; +{$ENDIF} +end; + +type + PCharArray = array[0..0] of PChar; + +function ParamStr(Index: Integer): string; +{$IFDEF MSWINDOWS} +var + P: PChar; + Buffer: array[0..260] of Char; +begin + Result := ''; + if Index = 0 then + SetString(Result, Buffer, GetModuleFileName(0, Buffer, SizeOf(Buffer))) + else + begin + P := GetCommandLine; + while True do + begin + P := GetParamStr(P, Result); + if (Index = 0) or (Result = '') then Break; + Dec(Index); + end; + end; +{$ENDIF} +{$IFDEF LINUX} +begin + if Index < ArgCount then + Result := PCharArray(ArgValues^)[Index] + else + Result := ''; +{$ENDIF} +end; + +procedure _Pos{ substr : ShortString; s : ShortString ) : Integer}; +asm +{ ->EAX Pointer to substr } +{ EDX Pointer to string } +{ <-EAX Position of substr in s or 0 } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX { Point ESI to substr } + MOV EDI,EDX { Point EDI to s } + + XOR ECX,ECX { ECX = Length(s) } + MOV CL,[EDI] + INC EDI { Point EDI to first char of s } + + PUSH EDI { remember s position to calculate index } + + XOR EDX,EDX { EDX = Length(substr) } + MOV DL,[ESI] + INC ESI { Point ESI to first char of substr } + + DEC EDX { EDX = Length(substr) - 1 } + JS @@fail { < 0 ? return 0 } + MOV AL,[ESI] { AL = first char of substr } + INC ESI { Point ESI to 2'nd char of substr } + + SUB ECX,EDX { #positions in s to look at } + { = Length(s) - Length(substr) + 1 } + JLE @@fail +@@loop: + REPNE SCASB + JNE @@fail + MOV EBX,ECX { save outer loop counter } + PUSH ESI { save outer loop substr pointer } + PUSH EDI { save outer loop s pointer } + + MOV ECX,EDX + REPE CMPSB + POP EDI { restore outer loop s pointer } + POP ESI { restore outer loop substr pointer } + JE @@found + MOV ECX,EBX { restore outer loop counter } + JMP @@loop + +@@fail: + POP EDX { get rid of saved s pointer } + XOR EAX,EAX + JMP @@exit + +@@found: + POP EDX { restore pointer to first char of s } + MOV EAX,EDI { EDI points of char after match } + SUB EAX,EDX { the difference is the correct index } +@@exit: + POP EDI + POP ESI + POP EBX +end; + +// 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); +begin + Byte(s^[0]) := newLength; // should also fill new space +end; + +procedure _SetString(s: PShortString; buffer: PChar; len: Byte); +begin + Byte(s^[0]) := len; + if buffer <> nil then + Move(buffer^, s^[1], len); +end; + +procedure Randomize; +{$IFDEF LINUX} +begin + RandSeed := _time(nil); +{$ENDIF} +{$IFDEF MSWINDOWS} +var + systemTime : + record + wYear : Word; + wMonth : Word; + wDayOfWeek : Word; + wDay : Word; + wHour : Word; + wMinute : Word; + wSecond : Word; + wMilliSeconds: Word; + reserved : array [0..7] of char; + end; +asm + LEA EAX,systemTime + PUSH EAX + CALL GetSystemTime + MOVZX EAX,systemTime.wHour + IMUL EAX,60 + ADD AX,systemTime.wMinute { sum = hours * 60 + minutes } + IMUL EAX,60 + XOR EDX,EDX + MOV DX,systemTime.wSecond + ADD EAX,EDX { sum = sum * 60 + seconds } + IMUL EAX,1000 + MOV DX,systemTime.wMilliSeconds + ADD EAX,EDX { sum = sum * 1000 + milliseconds } + MOV RandSeed,EAX +{$ENDIF} +end; + +procedure RmDir(const S: string); +begin + RmDir(PChar(s)); +end; + +procedure RmDir(P: PChar); +begin +{$IFDEF MSWINDOWS} + if not RemoveDirectory(P) then +{$ENDIF} +{$IFDEF LINUX} + if __rmdir(P) <> 0 then +{$ENDIF} + InOutError; +end; + +function UpCase( ch : Char ) : Char; +{$IFDEF PUREPASCAL} +begin + Result := ch; + case Result of + 'a'..'z': Dec(Result, Ord('a') - Ord('A')); + end; +end; +{$ELSE} +asm +{ -> AL Character } +{ <- AL Result } + + CMP AL,'a' + JB @@exit + CMP AL,'z' + JA @@exit + SUB AL,'a' - 'A' +@@exit: +end; +{$ENDIF} + +procedure Set8087CW(NewCW: Word); +begin + Default8087CW := NewCW; + asm + FNCLEX // don't raise pending exceptions enabled by the new flags +{$IFDEF PIC} + MOV EAX,[EBX].OFFSET Default8087CW + FLDCW [EAX] +{$ELSE} + FLDCW Default8087CW +{$ENDIF} + end; +end; + +function Get8087CW: Word; +asm + PUSH 0 + FNSTCW [ESP].Word + POP EAX +end; + + +{ ----------------------------------------------------- } +{ functions & procedures that need compiler magic } +{ ----------------------------------------------------- } + +procedure _COS; +asm + FCOS + FNSTSW AX + SAHF + JP @@outOfRange + RET +@@outOfRange: + FSTP st(0) { for now, return 0. result would } + FLDZ { have little significance anyway } +end; + +procedure _EXP; +asm + { e**x = 2**(x*log2(e)) } + + FLDL2E { y := x*log2e; } + FMUL + FLD ST(0) { i := round(y); } + FRNDINT + FSUB ST(1), ST { f := y - i; } + FXCH ST(1) { z := 2**f } + F2XM1 + FLD1 + FADD + FSCALE { result := z * 2**i } + FSTP ST(1) +end; + +procedure _INT; +asm + SUB ESP,4 + FNSTCW [ESP].Word // save + FNSTCW [ESP+2].Word // scratch + FWAIT + OR [ESP+2].Word, $0F00 // trunc toward zero, full precision + FLDCW [ESP+2].Word + FRNDINT + FWAIT + FLDCW [ESP].Word + ADD ESP,4 +end; + +procedure _SIN; +asm + FSIN + FNSTSW AX + SAHF + JP @@outOfRange + RET +@@outOfRange: + FSTP st(0) { for now, return 0. result would } + FLDZ { have little significance anyway } +end; + +procedure _FRAC; +asm + FLD ST(0) + SUB ESP,4 + FNSTCW [ESP].Word // save + FNSTCW [ESP+2].Word // scratch + FWAIT + OR [ESP+2].Word, $0F00 // trunc toward zero, full precision + FLDCW [ESP+2].Word + FRNDINT + FWAIT + FLDCW [ESP].Word + ADD ESP,4 + FSUB +end; + +procedure _ROUND; +asm + { -> FST(0) Extended argument } + { <- EDX:EAX Result } + + SUB ESP,8 + FISTP qword ptr [ESP] + FWAIT + POP EAX + POP EDX +end; + +procedure _TRUNC; +asm + { -> FST(0) Extended argument } + { <- EDX:EAX Result } + + SUB ESP,12 + FNSTCW [ESP].Word // save + FNSTCW [ESP+2].Word // scratch + FWAIT + OR [ESP+2].Word, $0F00 // trunc toward zero, full precision + FLDCW [ESP+2].Word + FISTP qword ptr [ESP+4] + FWAIT + FLDCW [ESP].Word + POP ECX + POP EAX + POP EDX +end; + +procedure _AbstractError; +{$IFDEF PC_MAPPED_EXCEPTIONS} +asm + MOV EAX,210 + JMP _RunError +end; +{$ELSE} +{$IFDEF PIC} +begin + if Assigned(AbstractErrorProc) then + AbstractErrorProc; + _RunError(210); // loses return address +end; +{$ELSE} +asm + CMP AbstractErrorProc, 0 + JE @@NoAbstErrProc + CALL AbstractErrorProc + +@@NoAbstErrProc: + MOV EAX,210 + JMP _RunError +end; +{$ENDIF} +{$ENDIF} + +function TextOpen(var t: TTextRec): Integer; forward; + +function OpenText(var t: TTextRec; Mode: Word): Integer; +begin + if (t.Mode < fmClosed) or (t.Mode > fmInOut) then + Result := 102 + else + begin + if t.Mode <> fmClosed then _Close(t); + t.Mode := Mode; + if (t.Name[0] = #0) and (t.OpenFunc = nil) then // stdio + t.OpenFunc := @TextOpen; + Result := TTextIOFunc(t.OpenFunc)(t); + end; + if Result <> 0 then SetInOutRes(Result); +end; + +function _ResetText(var t: TTextRec): Integer; +begin + Result := OpenText(t, fmInput); +end; + +function _RewritText(var t: TTextRec): Integer; +begin + Result := OpenText(t, fmOutput); +end; + +function _Append(var t: TTextRec): Integer; +begin + Result := OpenText(t, fmInOut); +end; + +function TextIn(var t: TTextRec): Integer; +begin + t.BufEnd := 0; + t.BufPos := 0; +{$IFDEF LINUX} + t.BufEnd := __read(t.Handle, t.BufPtr, t.BufSize); + if Integer(t.BufEnd) = -1 then + begin + t.BufEnd := 0; + Result := GetLastError; + end + else + Result := 0; +{$ENDIF} +{$IFDEF MSWINDOWS} + if ReadFile(t.Handle, t.BufPtr^, t.BufSize, t.BufEnd, nil) = 0 then + begin + Result := GetLastError; + if Result = 109 then + Result := 0; // NT quirk: got "broken pipe"? it's really eof + end + else + Result := 0; +{$ENDIF} +end; + +function FileNOPProc(var t): Integer; +begin + Result := 0; +end; + +function TextOut(var t: TTextRec): Integer; +{$IFDEF MSWINDOWS} +var + Dummy: Cardinal; +{$ENDIF} +begin + if t.BufPos = 0 then + Result := 0 + else + begin +{$IFDEF LINUX} + if __write(t.Handle, t.BufPtr, t.BufPos) = Cardinal(-1) then +{$ENDIF} +{$IFDEF MSWINDOWS} + if WriteFile(t.Handle, t.BufPtr^, t.BufPos, Dummy, nil) = 0 then +{$ENDIF} + Result := GetLastError + else + Result := 0; + t.BufPos := 0; + end; +end; + +function InternalClose(Handle: Integer): Boolean; +begin +{$IFDEF LINUX} + Result := __close(Handle) = 0; +{$ENDIF} +{$IFDEF MSWINDOWS} + Result := CloseHandle(Handle) = 1; +{$ENDIF} +end; + +function TextClose(var t: TTextRec): Integer; +begin + t.Mode := fmClosed; + if not InternalClose(t.Handle) then + Result := GetLastError + else + Result := 0; +end; + +function TextOpenCleanup(var t: TTextRec): Integer; +begin + InternalClose(t.Handle); + t.Mode := fmClosed; + Result := GetLastError; +end; + +function TextOpen(var t: TTextRec): Integer; +{$IFDEF LINUX} +var + Flags: Integer; + Temp, I: Integer; + BytesRead: Integer; +begin + Result := 0; + t.BufPos := 0; + t.BufEnd := 0; + case t.Mode of + fmInput: // called by Reset + begin + Flags := O_RDONLY; + t.InOutFunc := @TextIn; + end; + fmOutput: // called by Rewrite + begin + Flags := O_CREAT or O_TRUNC or O_WRONLY; + t.InOutFunc := @TextOut; + end; + fmInOut: // called by Append + begin + Flags := O_APPEND or O_RDWR; + t.InOutFunc := @TextOut; + end; + else + Exit; + Flags := 0; + end; + + t.FlushFunc := @FileNOPProc; + + if t.Name[0] = #0 then // stdin or stdout + begin + t.BufPtr := @t.Buffer; + t.BufSize := sizeof(t.Buffer); + t.CloseFunc := @FileNOPProc; + if t.Mode = fmOutput then + begin + if @t = @ErrOutput then + t.Handle := STDERR_FILENO + else + t.Handle := STDOUT_FILENO; + t.FlushFunc := @TextOut; + end + else + t.Handle := STDIN_FILENO; + end + else + begin + t.CloseFunc := @TextClose; + + Temp := __open(t.Name, Flags, FileAccessRights); + if Temp = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + t.Handle := Temp; + + if t.Mode = fmInOut then // Append mode + begin + t.Mode := fmOutput; + + if (t.flags and tfCRLF) <> 0 then // DOS mode, EOF significant + begin // scan for EOF char in last 128 byte sector. + Temp := _lseek(t.Handle, 0, SEEK_END); + if Temp = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + Dec(Temp, 128); + if Temp < 0 then Temp := 0; + + if _lseek(t.Handle, Temp, SEEK_SET) = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + BytesRead := __read(t.Handle, t.BufPtr, 128); + if BytesRead = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + for I := 0 to BytesRead - 1 do + begin + if t.Buffer[I] = Char(cEOF) then + begin // truncate the file here + if _ftruncate(t.Handle, _lseek(t.Handle, I - BytesRead, SEEK_END)) = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + Break; + end; + end; + end; + end; + end; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +(* +var + OpenMode: Integer; + Flags, Std: ShortInt; + Temp: Integer; + I, BytesRead: Cardinal; + Mode: Byte; +begin + Result := 0; + if (t.Mode - fmInput) > (fmInOut - fmInput) then Exit; + Mode := t.Mode and 3; + t.BufPos := 0; + t.BufEnd := 0; + t.FlushFunc := @FileNOPProc; + + if t.Name[0] = #0 then // stdin or stdout + begin + t.BufPtr := @t.Buffer; + t.BufSize := sizeof(t.Buffer); + t.CloseFunc := @FileNOPProc; + if Mode = (fmOutput and 3) then + begin + t.InOutFunc := @TextOut; + if @t = @ErrOutput then + Std := STD_ERROR_HANDLE + else + Std := STD_OUTPUT_HANDLE; + end + else + begin + t.InOutFunc := @TextIn; + Std := STD_INPUT_HANDLE; + end; + t.Handle := GetStdHandle(Std); + end + else + begin + t.CloseFunc := @TextClose; + + Flags := OPEN_EXISTING; + if Mode = (fmInput and 3) then + begin // called by Reset + t.InOutFunc := @TextIn; + OpenMode := GENERIC_READ; // open for read + end + else + begin + t.InOutFunc := @TextOut; + if Mode = (fmInOut and 3) then // called by Append + OpenMode := GENERIC_READ OR GENERIC_WRITE // open for read/write + else + begin // called by Rewrite + OpenMode := GENERIC_WRITE; // open for write + Flags := CREATE_ALWAYS; + end; + end; + + Temp := CreateFileA(t.Name, OpenMode, FILE_SHARE_READ, nil, Flags, FILE_ATTRIBUTE_NORMAL, 0); + if Temp = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + t.Handle := Temp; + + if Mode = (fmInOut and 3) then + begin + Dec(t.Mode); // fmInOut -> fmOutput + +{; ??? we really have to look for the first eof byte in the +; ??? last record and truncate the file there. +; Not very nice and clean... +; +; lastRecPos = Max( GetFileSize(...) - 128, 0); +} + Temp := GetFileSize(t.Handle, 0); + if Temp = -1 then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + Dec(Temp, 128); + if Temp < 0 then Temp := 0; + + if (SetFilePointer(t.Handle, Temp, nil, FILE_BEGIN) = -1) or + (ReadFile(t.Handle, t.Buffer, 128, BytesRead, nil) = 0) then + begin + Result := TextOpenCleanup(t); + Exit; + end; + + for I := 0 to BytesRead do + begin + if t.Buffer[I] = Char(cEOF) then + begin // truncate the file here + if (SetFilePointer(t.Handle, I - BytesRead, nil, FILE_END) = -1) or + (not SetEndOfFile(t.Handle)) then + begin + Result := TextOpenCleanup(t); + Exit; + end; + Break; + end; + end; + end; + if Mode <> (fmInput and 3) then + begin + case GetFileType(t.Handle) of + 0: begin // bad file type + TextOpenCleanup(t); + Result := 105; + Exit; + end; + 2: t.FlushFunc := @TextOut; + end; + end; + end; +end; +*) + +asm +// -> EAX Pointer to text record + + PUSH ESI + + MOV ESI,EAX + + XOR EAX,EAX + MOV [ESI].TTextRec.BufPos,EAX + MOV [ESI].TTextRec.BufEnd,EAX + MOV AX,[ESI].TTextRec.Mode + + SUB EAX,fmInput + JE @@calledByReset + + DEC EAX + JE @@calledByRewrite + + DEC EAX + JE @@calledByAppend + + JMP @@exit + +@@calledByReset: + + MOV EAX,GENERIC_READ // open for read + MOV EDX,FILE_SHARE_READ + MOV ECX,OPEN_EXISTING + + MOV [ESI].TTextRec.InOutFunc,offset TextIn + + JMP @@common + +@@calledByRewrite: + + MOV EAX,GENERIC_WRITE // open for write + MOV EDX,FILE_SHARE_READ + MOV ECX,CREATE_ALWAYS + JMP @@commonOut + +@@calledByAppend: + + MOV EAX,GENERIC_READ OR GENERIC_WRITE // open for read/write + MOV EDX,FILE_SHARE_READ + MOV ECX,OPEN_EXISTING + +@@commonOut: + + MOV [ESI].TTextRec.InOutFunc,offset TextOut + +@@common: + + MOV [ESI].TTextRec.CloseFunc,offset TextClose + MOV [ESI].TTextRec.FlushFunc,offset FileNOPProc + CMP byte ptr [ESI].TTextRec.Name,0 + JE @@isCon + +// CreateFile(t.Name, EAX, EDX, Nil, ECX, FILE_ATTRIBUTE_NORMAL, 0); + + PUSH 0 + PUSH FILE_ATTRIBUTE_NORMAL + PUSH ECX + PUSH 0 + PUSH EDX + PUSH EAX + LEA EAX,[ESI].TTextRec.Name + PUSH EAX + CALL CreateFileA + + CMP EAX,-1 + JZ @@error + + MOV [ESI].TTextRec.Handle,EAX + CMP [ESI].TTextRec.Mode,fmInOut + JNE @@success + + DEC [ESI].TTextRec.Mode // fmInOut -> fmOutput + +{; ??? we really have to look for the first eof byte in the +; ??? last record and truncate the file there. +; Not very nice and clean... +; +; lastRecPos = Max( GetFileSize(...) - 128, 0); +} + PUSH 0 + PUSH [ESI].TTextRec.Handle + CALL GetFileSize + + INC EAX + JZ @@error + SUB EAX,129 + JNC @@3 + XOR EAX,EAX +@@3: +// lseek(f.Handle, SEEK_SET, lastRecPos); + + PUSH FILE_BEGIN + PUSH 0 + PUSH EAX + PUSH [ESI].TTextRec.Handle + CALL SetFilePointer + + INC EAX + JE @@error + +// bytesRead = read(f.Handle, f.Buffer, 128); + + PUSH 0 + MOV EDX,ESP + PUSH 0 + PUSH EDX + PUSH 128 + LEA EDX,[ESI].TTextRec.Buffer + PUSH EDX + PUSH [ESI].TTextRec.Handle + CALL ReadFile + POP EDX + DEC EAX + JNZ @@error + +// for (i = 0; i < bytesRead; i++) + + XOR EAX,EAX +@@loop: + CMP EAX,EDX + JAE @@success + +// if (f.Buffer[i] == eof) + + CMP byte ptr [ESI].TTextRec.Buffer[EAX],eof + JE @@truncate + INC EAX + JMP @@loop + +@@truncate: + +// lseek( f.Handle, SEEK_END, i - bytesRead ); + + PUSH FILE_END + PUSH 0 + SUB EAX,EDX + PUSH EAX + PUSH [ESI].TTextRec.Handle + CALL SetFilePointer + INC EAX + JE @@error + +// SetEndOfFile( f.Handle ); + + PUSH [ESI].TTextRec.Handle + CALL SetEndOfFile + DEC EAX + JNE @@error + + JMP @@success + +@@isCon: + LEA EAX,[ESI].TTextRec.Buffer + MOV [ESI].TTextRec.BufSize, TYPE TTextRec.Buffer + MOV [ESI].TTextRec.CloseFunc,offset FileNOPProc + MOV [ESI].TTextRec.BufPtr,EAX + CMP [ESI].TTextRec.Mode,fmOutput + JE @@output + PUSH STD_INPUT_HANDLE + JMP @@1 +@@output: + CMP ESI,offset ErrOutput + JNE @@stdout + PUSH STD_ERROR_HANDLE + JMP @@1 +@@stdout: + PUSH STD_OUTPUT_HANDLE +@@1: + CALL GetStdHandle + CMP EAX,-1 + JE @@error + MOV [ESI].TTextRec.Handle,EAX + +@@success: + CMP [ESI].TTextRec.Mode,fmInput + JE @@2 + PUSH [ESI].TTextRec.Handle + CALL GetFileType + TEST EAX,EAX + JE @@badFileType + CMP EAX,2 + JNE @@2 + MOV [ESI].TTextRec.FlushFunc,offset TextOut +@@2: + XOR EAX,EAX +@@exit: + POP ESI + RET + +@@badFileType: + PUSH [ESI].TTextRec.Handle + CALL CloseHandle + MOV [ESI].TTextRec.Mode,fmClosed + MOV EAX,105 + JMP @@exit + +@@error: + MOV [ESI].TTextRec.Mode,fmClosed + CALL GetLastError + JMP @@exit +end; +{$ENDIF} + +const + fNameLen = 260; + +function _Assign(var t: TTextRec; const s: String): Integer; +begin + FillChar(t, sizeof(TFileRec), 0); + t.BufPtr := @t.Buffer; + t.Mode := fmClosed; + t.Flags := tfCRLF * Byte(DefaultTextLineBreakStyle); + t.BufSize := sizeof(t.Buffer); + t.OpenFunc := @TextOpen; + Move(S[1], t.Name, Length(s)); + t.Name[Length(s)] := #0; + Result := 0; +end; + +function InternalFlush(var t: TTextRec; Func: TTextIOFunc): Integer; +begin + case t.Mode of + fmOutput, + fmInOut : Result := Func(t); + fmInput : Result := 0; + else + if (@t = @Output) or (@t = @ErrOutput) then + Result := 0 + else + Result := 103; + end; + if Result <> 0 then SetInOutRes(Result); +end; + +function Flush(var t: Text): Integer; +begin + Result := InternalFlush(TTextRec(t), TTextRec(t).InOutFunc); +end; + +function _Flush(var t: TTextRec): Integer; +begin + Result := InternalFlush(t, t.FlushFunc); +end; + +type +{$IFDEF MSWINDOWS} + 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'; + +{$ENDIF} +{$IFDEF LINUX} + TIOProc = function (Handle: Integer; Buffer: Pointer; Count: Cardinal): Cardinal; cdecl; +{$ENDIF} + +function BlockIO(var f: TFileRec; buffer: Pointer; recCnt: Cardinal; var recsDone: Longint; + ModeMask: Integer; IOProc: TIOProc; ErrorNo: Integer): Cardinal; +// Note: RecsDone ptr can be nil! +begin + if (f.Mode and ModeMask) = ModeMask then // fmOutput or fmInOut / fmInput or fmInOut + begin +{$IFDEF LINUX} + Result := IOProc(f.Handle, buffer, recCnt * f.RecSize); + if Integer(Result) = -1 then +{$ENDIF} +{$IFDEF MSWINDOWS} + if IOProc(f.Handle, buffer, recCnt * f.RecSize, Result, nil) = 0 then +{$ENDIF} + begin + SetInOutRes(GetLastError); + Result := 0; + end + else + begin + Result := Result div f.RecSize; + if @RecsDone <> nil then + RecsDone := Result + else if Result <> recCnt then + begin + SetInOutRes(ErrorNo); + Result := 0; + end + end; + end + else + begin + SetInOutRes(103); // file not open + Result := 0; + end; +end; + +function _BlockRead(var f: TFileRec; buffer: Pointer; recCnt: Longint; var recsRead: Longint): Longint; +begin + Result := BlockIO(f, buffer, recCnt, recsRead, fmInput, + {$IFDEF MSWINDOWS} ReadFileX, {$ENDIF} + {$IFDEF LINUX} __read, {$ENDIF} + 100); +end; + +function _BlockWrite(var f: TFileRec; buffer: Pointer; recCnt: Longint; var recsWritten: Longint): Longint; +begin + Result := BlockIO(f, buffer, recCnt, recsWritten, fmOutput, + {$IFDEF MSWINDOWS} WriteFileX, {$ENDIF} + {$IFDEF LINUX} __write, {$ENDIF} + 101); +end; + +function _Close(var t: TTextRec): Integer; +begin + Result := 0; + if (t.Mode >= fmInput) and (t.Mode <= fmInOut) then + begin + if (t.Mode and fmOutput) = fmOutput then // fmOutput or fmInOut + Result := TTextIOFunc(t.InOutFunc)(t); + if Result = 0 then + Result := TTextIOFunc(t.CloseFunc)(t); + if Result <> 0 then + SetInOutRes(Result); + end + else + if @t <> @Input then + SetInOutRes(103); +end; + +procedure _PStrCat; +asm +{ ->EAX = Pointer to destination string } +{ EDX = Pointer to source string } + + PUSH ESI + PUSH EDI + +{ load dest len into EAX } + + MOV EDI,EAX + XOR EAX,EAX + MOV AL,[EDI] + +{ load source address in ESI, source len in ECX } + + MOV ESI,EDX + XOR ECX,ECX + MOV CL,[ESI] + INC ESI + +{ calculate final length in DL and store it in the destination } + + MOV DL,AL + ADD DL,CL + JC @@trunc + +@@cont: + MOV [EDI],DL + +{ calculate final dest address } + + INC EDI + ADD EDI,EAX + +{ do the copy } + + REP MOVSB + +{ done } + + POP EDI + POP ESI + RET + +@@trunc: + INC DL { DL = #chars to truncate } + SUB CL,DL { CL = source len - #chars to truncate } + MOV DL,255 { DL = maximum length } + JMP @@cont +end; + +procedure _PStrNCat; +asm +{ ->EAX = Pointer to destination string } +{ EDX = Pointer to source string } +{ CL = max length of result (allocated size of dest - 1) } + + PUSH ESI + PUSH EDI + +{ load dest len into EAX } + + MOV EDI,EAX + XOR EAX,EAX + MOV AL,[EDI] + +{ load source address in ESI, source len in EDX } + + MOV ESI,EDX + XOR EDX,EDX + MOV DL,[ESI] + INC ESI + +{ calculate final length in AL and store it in the destination } + + ADD AL,DL + JC @@trunc + CMP AL,CL + JA @@trunc + +@@cont: + MOV ECX,EDX + MOV DL,[EDI] + MOV [EDI],AL + +{ calculate final dest address } + + INC EDI + ADD EDI,EDX + +{ do the copy } + + REP MOVSB + +@@done: + POP EDI + POP ESI + RET + +@@trunc: +{ CL = maxlen } + + MOV AL,CL { AL = final length = maxlen } + SUB CL,[EDI] { CL = length to copy = maxlen - destlen } + JBE @@done + MOV DL,CL + JMP @@cont +end; + +procedure _PStrCpy(Dest: PShortString; Source: PShortString); +begin + Move(Source^, Dest^, Byte(Source^[0])+1); +end; + +procedure _PStrNCpy(Dest: PShortString; Source: PShortString; MaxLen: Byte); +begin + if MaxLen > Byte(Source^[0]) then + MaxLen := Byte(Source^[0]); + Byte(Dest^[0]) := MaxLen; + Move(Source^[1], Dest^[1], MaxLen); +end; + +procedure _PStrCmp; +asm +{ ->EAX = Pointer to left string } +{ EDX = Pointer to right string } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + XOR EAX,EAX + XOR EDX,EDX + MOV AL,[ESI] + MOV DL,[EDI] + INC ESI + INC EDI + + SUB EAX,EDX { eax = len1 - len2 } + JA @@skip1 + ADD EDX,EAX { edx = len2 + (len1 - len2) = len1 } + +@@skip1: + PUSH EDX + SHR EDX,2 + JE @@cmpRest +@@longLoop: + MOV ECX,[ESI] + MOV EBX,[EDI] + CMP ECX,EBX + JNE @@misMatch + DEC EDX + JE @@cmpRestP4 + MOV ECX,[ESI+4] + MOV EBX,[EDI+4] + CMP ECX,EBX + JNE @@misMatch + ADD ESI,8 + ADD EDI,8 + DEC EDX + JNE @@longLoop + JMP @@cmpRest +@@cmpRestP4: + ADD ESI,4 + ADD EDI,4 +@@cmpRest: + POP EDX + AND EDX,3 + JE @@equal + + MOV CL,[ESI] + CMP CL,[EDI] + JNE @@exit + DEC EDX + JE @@equal + MOV CL,[ESI+1] + CMP CL,[EDI+1] + JNE @@exit + DEC EDX + JE @@equal + MOV CL,[ESI+2] + CMP CL,[EDI+2] + JNE @@exit + +@@equal: + ADD EAX,EAX + JMP @@exit + +@@misMatch: + POP EDX + CMP CL,BL + JNE @@exit + CMP CH,BH + JNE @@exit + SHR ECX,16 + SHR EBX,16 + CMP CL,BL + JNE @@exit + CMP CH,BH + +@@exit: + POP EDI + POP ESI + POP EBX +end; + +procedure _AStrCmp; +asm +{ ->EAX = Pointer to left string } +{ EDX = Pointer to right string } +{ ECX = Number of chars to compare} + + PUSH EBX + PUSH ESI + PUSH ECX + MOV ESI,ECX + SHR ESI,2 + JE @@cmpRest + +@@longLoop: + MOV ECX,[EAX] + MOV EBX,[EDX] + CMP ECX,EBX + JNE @@misMatch + DEC ESI + JE @@cmpRestP4 + MOV ECX,[EAX+4] + MOV EBX,[EDX+4] + CMP ECX,EBX + JNE @@misMatch + ADD EAX,8 + ADD EDX,8 + DEC ESI + JNE @@longLoop + JMP @@cmpRest +@@cmpRestp4: + ADD EAX,4 + ADD EDX,4 +@@cmpRest: + POP ESI + AND ESI,3 + JE @@exit + + MOV CL,[EAX] + CMP CL,[EDX] + JNE @@exit + DEC ESI + JE @@equal + MOV CL,[EAX+1] + CMP CL,[EDX+1] + JNE @@exit + DEC ESI + JE @@equal + MOV CL,[EAX+2] + CMP CL,[EDX+2] + JNE @@exit + +@@equal: + XOR EAX,EAX + JMP @@exit + +@@misMatch: + POP ESI + CMP CL,BL + JNE @@exit + CMP CH,BH + JNE @@exit + SHR ECX,16 + SHR EBX,16 + CMP CL,BL + JNE @@exit + CMP CH,BH + +@@exit: + POP ESI + POP EBX +end; + +function _EofFile(var f: TFileRec): Boolean; +begin + Result := _FilePos(f) >= _FileSize(f); +end; + +function _EofText(var t: TTextRec): Boolean; +asm +// -> EAX Pointer to text record +// <- AL Boolean result + CMP [EAX].TTextRec.Mode,fmInput + JNE @@readChar + MOV EDX,[EAX].TTextRec.BufPos + CMP EDX,[EAX].TTextRec.BufEnd + JAE @@readChar + ADD EDX,[EAX].TTextRec.BufPtr + TEST [EAX].TTextRec.Flags,tfCRLF + JZ @@FalseExit + MOV CL,[EDX] + CMP CL,cEof + JNZ @@FalseExit + +@@eof: + MOV AL,1 + JMP @@exit + +@@readChar: + PUSH EAX + CALL _ReadChar + POP EDX + CMP AH,cEof + JE @@eof + DEC [EDX].TTextRec.BufPos +@@FalseExit: + XOR EAX,EAX +@@exit: +end; + +function _Eoln(var t: TTextRec): Boolean; +asm +// -> EAX Pointer to text record +// <- AL Boolean result + + CMP [EAX].TTextRec.Mode,fmInput + JNE @@readChar + MOV EDX,[EAX].TTextRec.BufPos + CMP EDX,[EAX].TTextRec.BufEnd + JAE @@readChar + ADD EDX,[EAX].TTextRec.BufPtr + TEST [EAX].TTextRec.Flags,tfCRLF + MOV AL,0 + MOV CL,[EDX] + JZ @@testLF + CMP CL,cCR + JE @@eol + CMP CL,cEOF + JE @@eof + JMP @@exit + +@@testLF: + CMP CL,cLF + JE @@eol + CMP CL,cEOF + JE @@eof + JMP @@exit + +@@readChar: + PUSH EAX + CALL _ReadChar + POP EDX + CMP AH,cEOF + JE @@eof + DEC [EDX].TTextRec.BufPos + XOR ECX,ECX + XCHG ECX,EAX + TEST [EDX].TTextRec.Mode,tfCRLF + JNE @@testLF + CMP CL,cCR + JE @@eol + JMP @@exit + +@@eol: +@@eof: + MOV AL,1 +@@exit: +end; + +procedure _Erase(var f: TFileRec); +begin + if (f.Mode < fmClosed) or (f.Mode > fmInOut) then + SetInOutRes(102) // file not assigned + else +{$IFDEF LINUX} + if __remove(f.Name) < 0 then + SetInOutRes(GetLastError); +{$ENDIF} +{$IFDEF MSWINDOWS} + if not DeleteFileA(f.Name) then + SetInOutRes(GetLastError); +{$ENDIF} +end; + +{$IFDEF MSWINDOWS} +// Floating-point divide reverse routine +// ST(1) = ST(0) / ST(1), pop ST + +procedure _FSafeDivideR; +asm + FXCH + JMP _FSafeDivide +end; + +// Floating-point divide routine +// ST(1) = ST(1) / ST(0), pop ST + +procedure _FSafeDivide; +type + Z = packed record // helper type to make parameter references more readable + Dividend: Extended; // (TBYTE PTR [ESP]) + Pad: Word; + Divisor: Extended; // (TBYTE PTR [ESP+12]) + end; +asm + CMP TestFDIV,0 //Check FDIV indicator + JLE @@FDivideChecked //Jump if flawed or don't know + FDIV //Known to be ok, so just do FDIV + RET + +// FDIV constants +@@FDIVRiscTable: DB 0,1,0,0,4,0,0,7,0,0,10,0,0,13,0,0; + +@@FDIVScale1: DD $3F700000 // 0.9375 +@@FDIVScale2: DD $3F880000 // 1.0625 +@@FDIV1SHL63: DD $5F000000 // 1 SHL 63 + +@@TestDividend: DD $C0000000,$4150017E // 4195835.0 +@@TestDivisor: DD $80000000,$4147FFFF // 3145727.0 +@@TestOne: DD $00000000,$3FF00000 // 1.0 + +// Flawed FDIV detection +@@FDivideDetect: + MOV TestFDIV,1 //Indicate correct FDIV + PUSH EAX + SUB ESP,12 + FSTP TBYTE PTR [ESP] //Save off ST + FLD QWORD PTR @@TestDividend //Ok if x - (x / y) * y < 1.0 + FDIV QWORD PTR @@TestDivisor + FMUL QWORD PTR @@TestDivisor + FSUBR QWORD PTR @@TestDividend + FCOMP QWORD PTR @@TestOne + FSTSW AX + SHR EAX,7 + AND EAX,002H //Zero if FDIV is flawed + DEC EAX + MOV TestFDIV,AL //1 means Ok, -1 means flawed + FLD TBYTE PTR [ESP] //Restore ST + ADD ESP,12 + POP EAX + JMP _FSafeDivide + +@@FDivideChecked: + JE @@FDivideDetect //Do detection if TestFDIV = 0 + +@@1: PUSH EAX + SUB ESP,24 + FSTP [ESP].Z.Divisor //Store Divisor and Dividend + FSTP [ESP].Z.Dividend + FLD [ESP].Z.Dividend + FLD [ESP].Z.Divisor +@@2: MOV EAX,DWORD PTR [ESP+4].Z.Divisor //Is Divisor a denormal? + ADD EAX,EAX + JNC @@20 //Yes, @@20 + XOR EAX,0E000000H //If these three bits are not all + TEST EAX,0E000000H //ones, FDIV will work + JZ @@10 //Jump if all ones +@@3: FDIV //Do FDIV and exit + ADD ESP,24 + POP EAX + RET + +@@10: SHR EAX,28 //If the four bits following the MSB + //of the mantissa have a decimal + //of 1, 4, 7, 10, or 13, FDIV may + CMP byte ptr @@FDIVRiscTable[EAX],0 //not work correctly + JZ @@3 //Do FDIV if not 1, 4, 7, 10, or 13 + MOV EAX,DWORD PTR [ESP+8].Z.Divisor //Get Divisor exponent + AND EAX,7FFFH + JZ @@3 //Ok to FDIV if denormal + CMP EAX,7FFFH + JE @@3 //Ok to FDIV if NAN or INF + MOV EAX,DWORD PTR [ESP+8].Z.Dividend //Get Dividend exponent + AND EAX,7FFFH + CMP EAX,1 //Small number? + JE @@11 //Yes, @@11 + FMUL DWORD PTR @@FDIVScale1 //Scale by 15/16 + FXCH + FMUL DWORD PTR @@FDIVScale1 + FXCH + JMP @@3 //FDIV is now safe + +@@11: FMUL DWORD PTR @@FDIVScale2 //Scale by 17/16 + FXCH + FMUL DWORD PTR @@FDIVScale2 + FXCH + JMP @@3 //FDIV is now safe + +@@20: MOV EAX,DWORD PTR [ESP].Z.Divisor //Is entire Divisor zero? + OR EAX,DWORD PTR [ESP+4].Z.Divisor + JZ @@3 //Yes, ok to FDIV + MOV EAX,DWORD PTR [ESP+8].Z.Divisor //Get Divisor exponent + AND EAX,7FFFH //Non-zero exponent is invalid + JNZ @@3 //Ok to FDIV if invalid + MOV EAX,DWORD PTR [ESP+8].Z.Dividend //Get Dividend exponent + AND EAX,7FFFH //Denormal? + JZ @@21 //Yes, @@21 + CMP EAX,7FFFH //NAN or INF? + JE @@3 //Yes, ok to FDIV + MOV EAX,DWORD PTR [ESP+4].Z.Dividend //If MSB of mantissa is zero, + ADD EAX,EAX //the number is invalid + JNC @@3 //Ok to FDIV if invalid + JMP @@22 +@@21: MOV EAX,DWORD PTR [ESP+4].Z.Dividend //If MSB of mantissa is zero, + ADD EAX,EAX //the number is invalid + JC @@3 //Ok to FDIV if invalid +@@22: FXCH //Scale stored Divisor image by + FSTP ST(0) //1 SHL 63 and restart + FLD ST(0) + FMUL DWORD PTR @@FDIV1SHL63 + FSTP [ESP].Z.Divisor + FLD [ESP].Z.Dividend + FXCH + JMP @@2 +end; +{$ENDIF} + +function _FilePos(var f: TFileRec): Longint; +begin + if (f.Mode > fmClosed) and (f.Mode <= fmInOut) then + begin +{$IFDEF LINUX} + Result := _lseek(f.Handle, 0, SEEK_CUR); +{$ENDIF} +{$IFDEF MSWINDOWS} + Result := SetFilePointer(f.Handle, 0, nil, FILE_CURRENT); +{$ENDIF} + if Result = -1 then + InOutError + else + Result := Cardinal(Result) div f.RecSize; + end + else + begin + SetInOutRes(103); + Result := -1; + end; +end; + +function _FileSize(var f: TFileRec): Longint; +{$IFDEF MSWINDOWS} +begin + Result := -1; + if (f.Mode > fmClosed) and (f.Mode <= fmInOut) then + begin + Result := GetFileSize(f.Handle, 0); + if Result = -1 then + InOutError + else + Result := Cardinal(Result) div f.RecSize; + end + else + SetInOutRes(103); +{$ENDIF} +{$IFDEF LINUX} +var + stat: TStatStruct; +begin + Result := -1; + if (f.Mode > fmClosed) and (f.Mode <= fmInOut) then + begin + if _fxstat(STAT_VER_LINUX, f.Handle, stat) <> 0 then + InOutError + else + Result := stat.st_size div f.RecSize; + end + else + SetInOutRes(103); +{$ENDIF} +end; + +procedure _FillChar(var Dest; count: Integer; Value: Char); +{$IFDEF PUREPASCAL} +var + I: Integer; + P: PChar; +begin + P := PChar(@Dest); + for I := count-1 downto 0 do + P[I] := Value; +end; +{$ELSE} +asm +{ ->EAX Pointer to destination } +{ EDX count } +{ CL value } + + PUSH EDI + + MOV EDI,EAX { Point EDI to destination } + + MOV CH,CL { Fill EAX with value repeated 4 times } + MOV EAX,ECX + SHL EAX,16 + MOV AX,CX + + MOV ECX,EDX + SAR ECX,2 + JS @@exit + + REP STOSD { Fill count DIV 4 dwords } + + MOV ECX,EDX + AND ECX,3 + REP STOSB { Fill count MOD 4 bytes } + +@@exit: + POP EDI +end; +{$ENDIF} + +procedure Mark; +begin + Error(reInvalidPtr); +end; + +procedure _RandInt; +asm +{ ->EAX Range } +{ <-EAX Result } + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX + MOV ECX,[EBX].OFFSET RandSeed + IMUL EDX,[ECX],08088405H + INC EDX + MOV [ECX],EDX +{$ELSE} + XOR EBX, EBX + IMUL EDX,[EBX].RandSeed,08088405H + INC EDX + MOV [EBX].RandSeed,EDX +{$ENDIF} + MUL EDX + MOV EAX,EDX + POP EBX +end; + +procedure _RandExt; +const two2neg32: double = ((1.0/$10000) / $10000); // 2^-32 +asm +{ FUNCTION _RandExt: Extended; } + + PUSH EBX +{$IFDEF PIC} + CALL GetGOT + MOV EBX,EAX + MOV ECX,[EBX].OFFSET RandSeed + IMUL EDX,[ECX],08088405H + INC EDX + MOV [ECX],EDX +{$ELSE} + XOR EBX, EBX + IMUL EDX,[EBX].RandSeed,08088405H + INC EDX + MOV [EBX].RandSeed,EDX +{$ENDIF} + + FLD [EBX].two2neg32 + PUSH 0 + PUSH EDX + FILD qword ptr [ESP] + ADD ESP,8 + FMULP ST(1), ST(0) + POP EBX +end; + +function _ReadRec(var f: TFileRec; Buffer: Pointer): Integer; +{$IFDEF LINUX} +begin + if (f.Mode and fmInput) = fmInput then // fmInput or fmInOut + begin + Result := __read(f.Handle, Buffer, f.RecSize); + if Result = -1 then + InOutError + else if Cardinal(Result) <> f.RecSize then + SetInOutRes(100); + end + else + begin + SetInOutRes(103); // file not open for input + Result := 0; + end; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm +// -> EAX Pointer to file variable +// EDX Pointer to buffer + + PUSH EBX + XOR ECX,ECX + MOV EBX,EAX + MOV CX,[EAX].TFileRec.Mode // File must be open + SUB ECX,fmInput + JE @@skip + SUB ECX,fmInOut-fmInput + JNE @@fileNotOpen +@@skip: + +// ReadFile(f.Handle, buffer, f.RecSize, @result, Nil); + + PUSH 0 // space for OS result + MOV EAX,ESP + + PUSH 0 // pass lpOverlapped + PUSH EAX // pass @result + + PUSH [EBX].TFileRec.RecSize // pass nNumberOfBytesToRead + + PUSH EDX // pass lpBuffer + PUSH [EBX].TFileRec.Handle // pass hFile + CALL ReadFile + POP EDX // pop result + DEC EAX // check EAX = TRUE + JNZ @@error + + CMP EDX,[EBX].TFileRec.RecSize // result = f.RecSize ? + JE @@exit + +@@readError: + MOV EAX,100 + JMP @@errExit + +@@fileNotOpen: + MOV EAX,103 + JMP @@errExit + +@@error: + CALL GetLastError +@@errExit: + CALL SetInOutRes +@@exit: + POP EBX +end; +{$ENDIF} + + +// If the file is Input std variable, try to open it +// Otherwise, runtime error. +function TryOpenForInput(var t: TTextRec): Boolean; +begin + if @t = @Input then + begin + t.Flags := tfCRLF * Byte(DefaultTextLineBreakStyle); + _ResetText(t); + end; + + Result := t.Mode = fmInput; + if not Result then + SetInOutRes(104); +end; + +function _ReadChar(var t: TTextRec): Char; +asm +// -> EAX Pointer to text record +// <- AL Character read. (may be a pseudo cEOF in DOS mode) +// <- AH cEOF = End of File, else 0 +// For eof, #$1A is returned in AL and in AH. +// For errors, InOutRes is set and #$1A is returned. + + CMP [EAX].TTextRec.Mode, fmInput + JE @@checkBuf + PUSH EAX + CALL TryOpenForInput + TEST AL,AL + POP EAX + JZ @@eofexit + +@@checkBuf: + MOV EDX,[EAX].TTextRec.BufPos + CMP EDX,[EAX].TTextRec.BufEnd + JAE @@fillBuf +@@cont: + TEST [EAX].TTextRec.Flags,tfCRLF + MOV ECX,[EAX].TTextRec.BufPtr + MOV CL,[ECX+EDX] + JZ @@cont2 + CMP CL,cEof // Check for EOF char in DOS mode + JE @@eofexit +@@cont2: + INC EDX + MOV [EAX].TTextRec.BufPos,EDX + XOR EAX,EAX + JMP @@exit + +@@fillBuf: + PUSH EAX + CALL [EAX].TTextRec.InOutFunc + TEST EAX,EAX + JNE @@error + POP EAX + MOV EDX,[EAX].TTextRec.BufPos + CMP EDX,[EAX].TTextRec.BufEnd + JB @@cont + +// We didn't get characters. Must be eof then. + +@@eof: + TEST [EAX].TTextRec.Flags,tfCRLF + JZ @@eofexit +// In DOS CRLF compatibility mode, synthesize an EOF char +// Store one eof in the buffer and increment BufEnd + MOV ECX,[EAX].TTextRec.BufPtr + MOV byte ptr [ECX+EDX],cEof + INC [EAX].TTextRec.BufEnd + JMP @@eofexit + +@@error: + CALL SetInOutRes + POP EAX +@@eofexit: + MOV CL,cEof + MOV AH,CL +@@exit: + MOV AL,CL +end; + +function _ReadLong(var t: TTextRec): Longint; +asm +// -> EAX Pointer to text record +// <- EAX Result + + PUSH EBX + PUSH ESI + PUSH EDI + SUB ESP,36 // var numbuf: String[32]; + + MOV ESI,EAX + CALL _SeekEof + DEC AL + JZ @@eof + + MOV EDI,ESP // EDI -> numBuf[0] + MOV BL,32 +@@loop: + MOV EAX,ESI + CALL _ReadChar + CMP AL,' ' + JBE @@endNum + STOSB + DEC BL + JNZ @@loop +@@convert: + MOV byte ptr [EDI],0 + MOV EAX,ESP // EAX -> numBuf + PUSH EDX // allocate code result + MOV EDX,ESP // pass pointer to code + CALL _ValLong // convert + POP EDX // pop code result into EDX + TEST EDX,EDX + JZ @@exit + MOV EAX,106 + CALL SetInOutRes + JMP @@exit + +@@endNum: + CMP AH,cEof + JE @@convert + DEC [ESI].TTextRec.BufPos + JMP @@convert + +@@eof: + XOR EAX,EAX +@@exit: + ADD ESP,36 + POP EDI + POP ESI + POP EBX +end; + +function ReadLine(var t: TTextRec; buf: Pointer; maxLen: Longint): Pointer; +asm +// -> EAX Pointer to text record +// EDX Pointer to buffer +// ECX Maximum count of chars to read +// <- ECX Actual count of chars in buffer +// <- EAX Pointer to text record + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH ECX + MOV ESI,ECX + MOV EDI,EDX + + CMP [EAX].TTextRec.Mode,fmInput + JE @@start + PUSH EAX + CALL TryOpenForInput + TEST AL,AL + POP EAX + JZ @@exit + +@@start: + MOV EBX,EAX + + TEST ESI,ESI + JLE @@exit + + MOV EDX,[EBX].TTextRec.BufPos + MOV ECX,[EBX].TTextRec.BufEnd + SUB ECX,EDX + ADD EDX,[EBX].TTextRec.BufPtr + +@@loop: + DEC ECX + JL @@readChar + MOV AL,[EDX] + INC EDX +@@cont: + CMP AL,cLF + JE @@lf + + CMP AL,cCR + JE @@cr + + STOSB + DEC ESI + JG @@loop + JMP @@finish + +@@cr: + MOV AL,[EDX] + CMP AL,cLF + JNE @@loop +@@lf: + DEC EDX +@@finish: + SUB EDX,[EBX].TTextRec.BufPtr + MOV [EBX].TTextRec.BufPos,EDX + JMP @@exit + +@@readChar: + MOV [EBX].TTextRec.BufPos,EDX + MOV EAX,EBX + CALL _ReadChar + MOV EDX,[EBX].TTextRec.BufPos + MOV ECX,[EBX].TTextRec.BufEnd + SUB ECX,EDX + ADD EDX,[EBX].TTextRec.BufPtr + TEST AH,AH //eof + JZ @@cont + +@@exit: + MOV EAX,EBX + POP ECX + SUB ECX,ESI + POP EDI + POP ESI + POP EBX +end; + +procedure _ReadString(var t: TTextRec; s: PShortString; maxLen: Longint); +asm +// -> EAX Pointer to text record +// EDX Pointer to string +// ECX Maximum length of string + + PUSH EDX + INC EDX + CALL ReadLine + POP EDX + MOV [EDX],CL +end; + +procedure _ReadCString(var t: TTextRec; s: PChar; maxLen: Longint); +asm +// -> EAX Pointer to text record +// EDX Pointer to string +// ECX Maximum length of string + + PUSH EDX + CALL ReadLine + POP EDX + MOV byte ptr [EDX+ECX],0 +end; + +procedure _ReadLString(var t: TTextRec; var s: AnsiString); +asm + { -> EAX pointer to Text } + { EDX pointer to AnsiString } + + PUSH EBX + PUSH ESI + MOV EBX,EAX + MOV ESI,EDX + + MOV EAX,EDX + CALL _LStrClr + + SUB ESP,256 + + MOV EAX,EBX + MOV EDX,ESP + MOV ECX,255 + CALL _ReadString + + MOV EAX,ESI + MOV EDX,ESP + CALL _LStrFromString + + CMP byte ptr [ESP],255 + JNE @@exit +@@loop: + + MOV EAX,EBX + MOV EDX,ESP + MOV ECX,255 + CALL _ReadString + + MOV EDX,ESP + PUSH 0 + MOV EAX,ESP + CALL _LStrFromString + + MOV EAX,ESI + MOV EDX,[ESP] + CALL _LStrCat + + MOV EAX,ESP + CALL _LStrClr + POP EAX + + CMP byte ptr [ESP],255 + JE @@loop + +@@exit: + ADD ESP,256 + POP ESI + POP EBX +end; + + +function IsValidMultibyteChar(const Src: PChar; SrcBytes: Integer): Boolean; +{$IFDEF MSWINDOWS} +const + ERROR_NO_UNICODE_TRANSLATION = 1113; // Win32 GetLastError when result = 0 + MB_ERR_INVALID_CHARS = 8; +var + Dest: WideChar; +begin + Result := MultiByteToWideChar(0, MB_ERR_INVALID_CHARS, Src, SrcBytes, @Dest, 1) <> 0; +{$ENDIF} +{$IFDEF LINUX} +begin + Result := mblen(Src, SrcBytes) <> -1; +{$ENDIF} +end; + + +function _ReadWChar(var t: TTextRec): WideChar; +var + scratch: array [0..7] of AnsiChar; + wc: WideChar; + i: Integer; +begin + i := 0; + while i < High(scratch) do + begin + scratch[i] := _ReadChar(t); + Inc(i); + scratch[i] := #0; + if IsValidMultibyteChar(scratch, i) then + begin + WCharFromChar(@wc, 1, scratch, i); + Result := wc; + Exit; + end; + end; + SetInOutRes(106); // Invalid Input + Result := #0; +end; + + +procedure _ReadWCString(var t: TTextRec; s: PWideChar; maxBytes: Longint); +var + i, maxLen: Integer; + wc: WideChar; +begin + if s = nil then Exit; + i := 0; + maxLen := maxBytes div sizeof(WideChar); + while i < maxLen do + begin + wc := _ReadWChar(t); + case Integer(wc) of + cEOF: if _EOFText(t) then Break; + cLF : begin + Dec(t.BufPos); + Break; + end; + cCR : if Byte(t.BufPtr[t.BufPos]) = cLF then + begin + Dec(t.BufPos); + Break; + end; + end; + s[i] := wc; + Inc(i); + end; + s[i] := #0; +end; + +procedure _ReadWString(var t: TTextRec; var s: WideString); +var + Temp: AnsiString; +begin + _ReadLString(t, Temp); + s := Temp; +end; + +function _ReadExt(var t: TTextRec): Extended; +asm +// -> EAX Pointer to text record +// <- FST(0) Result + + PUSH EBX + PUSH ESI + PUSH EDI + SUB ESP,68 // var numbuf: array[0..64] of char; + + MOV ESI,EAX + CALL _SeekEof + DEC AL + JZ @@eof + + MOV EDI,ESP // EDI -> numBuf[0] + MOV BL,64 +@@loop: + MOV EAX,ESI + CALL _ReadChar + CMP AL,' ' + JBE @@endNum + STOSB + DEC BL + JNZ @@loop +@@convert: + MOV byte ptr [EDI],0 + MOV EAX,ESP // EAX -> numBuf + PUSH EDX // allocate code result + MOV EDX,ESP // pass pointer to code + CALL _ValExt // convert + POP EDX // pop code result into EDX + TEST EDX,EDX + JZ @@exit + MOV EAX,106 + CALL SetInOutRes + JMP @@exit + +@@endNum: + CMP AH,cEOF + JE @@convert + DEC [ESI].TTextRec.BufPos + JMP @@convert + +@@eof: + FLDZ +@@exit: + ADD ESP,68 + POP EDI + POP ESI + POP EBX +end; + +procedure _ReadLn(var t: TTextRec); +asm +// -> EAX Pointer to text record + + PUSH EBX + MOV EBX,EAX +@@loop: + MOV EAX,EBX + CALL _ReadChar + + CMP AL,cLF // accept LF as end of line + JE @@exit + CMP AH,cEOF + JE @@eof + CMP AL,cCR + JNE @@loop + + MOV EAX,EBX + CALL _ReadChar + + CMP AL,cLF // accept CR+LF as end of line + JE @@exit + CMP AH,cEOF // accept CR+EOF as end of line + JE @@eof + DEC [EBX].TTextRec.BufPos + JMP @@loop // else CR+ anything else is not a line break. + +@@exit: +@@eof: + POP EBX +end; + +procedure _Rename(var f: TFileRec; newName: PChar); +var + I: Integer; +begin + if f.Mode = fmClosed then + begin + if newName = nil then newName := ''; +{$IFDEF LINUX} + if __rename(f.Name, newName) = 0 then +{$ENDIF} +{$IFDEF MSWINDOWS} + if MoveFileA(f.Name, newName) then +{$ENDIF} + begin + I := 0; + while (newName[I] <> #0) and (I < High(f.Name)) do + begin + f.Name[I] := newName[I]; + Inc(I); + end + end + else + SetInOutRes(GetLastError); + end + else + SetInOutRes(102); +end; + +procedure Release; +begin + Error(reInvalidPtr); +end; + +function _CloseFile(var f: TFileRec): Integer; +begin + f.Mode := fmClosed; + Result := 0; + if not InternalClose(f.Handle) then + begin + InOutError; + Result := 1; + end; +end; + +function OpenFile(var f: TFileRec; recSiz: Longint; mode: Longint): Integer; +{$IFDEF LINUX} +var + Flags: Integer; +begin + Result := 0; + if (f.Mode >= fmClosed) and (f.Mode <= fmInOut) then + begin + if f.Mode <> fmClosed then // not yet closed: close it + begin + Result := TFileIOFunc(f.CloseFunc)(f); + if Result <> 0 then + SetInOutRes(Result); + end; + + if recSiz <= 0 then + SetInOutRes(106); + + f.RecSize := recSiz; + f.InOutFunc := @FileNopProc; + + if f.Name[0] <> #0 then + begin + f.CloseFunc := @_CloseFile; + case mode of + 1: begin + Flags := O_APPEND or O_WRONLY; + f.Mode := fmOutput; + end; + 2: begin + Flags := O_RDWR; + f.Mode := fmInOut; + end; + 3: begin + Flags := O_CREAT or O_TRUNC or O_RDWR; + f.Mode := fmInOut; + end; + else + Flags := O_RDONLY; + f.Mode := fmInput; + end; + + f.Handle := __open(f.Name, Flags, FileAccessRights); + end + else // stdin or stdout + begin + f.CloseFunc := @FileNopProc; + if mode = 3 then + f.Handle := STDOUT_FILENO + else + f.Handle := STDIN_FILENO; + end; + + if f.Handle = -1 then + begin + f.Mode := fmClosed; + InOutError; + end; + end + else + SetInOutRes(102); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +const + ShareTab: array [0..7] of Integer = + (FILE_SHARE_READ OR FILE_SHARE_WRITE, // OF_SHARE_COMPAT 0x00000000 + 0, // OF_SHARE_EXCLUSIVE 0x00000010 + FILE_SHARE_READ, // OF_SHARE_DENY_WRITE 0x00000020 + FILE_SHARE_WRITE, // OF_SHARE_DENY_READ 0x00000030 + FILE_SHARE_READ OR FILE_SHARE_WRITE, // OF_SHARE_DENY_NONE 0x00000040 + 0,0,0); +asm +//-> EAX Pointer to file record +// EDX Record size +// ECX File mode + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EDX + MOV EDI,ECX + XOR EDX,EDX + MOV EBX,EAX + + MOV DX,[EAX].TFileRec.Mode + SUB EDX,fmClosed + JE @@alreadyClosed + CMP EDX,fmInOut-fmClosed + JA @@notAssignedError + +// not yet closed: close it. File parameter is still in EAX + + CALL [EBX].TFileRec.CloseFunc + TEST EAX,EAX + JE @@alreadyClosed + CALL SetInOutRes + +@@alreadyClosed: + + MOV [EBX].TFileRec.Mode,fmInOut + MOV [EBX].TFileRec.RecSize,ESI + MOV [EBX].TFileRec.CloseFunc,offset _CloseFile + MOV [EBX].TFileRec.InOutFunc,offset FileNopProc + + CMP byte ptr [EBX].TFileRec.Name,0 + JE @@isCon + + MOV EAX,GENERIC_READ OR GENERIC_WRITE + MOV DL,FileMode + AND EDX,070H + SHR EDX,4-2 + MOV EDX,dword ptr [shareTab+EDX] + MOV ECX,CREATE_ALWAYS + + SUB EDI,3 + JE @@calledByRewrite + + MOV ECX,OPEN_EXISTING + INC EDI + JE @@skip + + MOV EAX,GENERIC_WRITE + INC EDI + MOV [EBX].TFileRec.Mode,fmOutput + JE @@skip + + MOV EAX,GENERIC_READ + MOV [EBX].TFileRec.Mode,fmInput + +@@skip: +@@calledByRewrite: + +// CreateFile(t.FileName, EAX, EDX, Nil, ECX, FILE_ATTRIBUTE_NORMAL, 0); + + PUSH 0 + PUSH FILE_ATTRIBUTE_NORMAL + PUSH ECX + PUSH 0 + PUSH EDX + PUSH EAX + LEA EAX,[EBX].TFileRec.Name + PUSH EAX + CALL CreateFileA +@@checkHandle: + CMP EAX,-1 + JZ @@error + + MOV [EBX].TFileRec.Handle,EAX + JMP @@exit + +@@isCon: + MOV [EBX].TFileRec.CloseFunc,offset FileNopProc + CMP EDI,3 + JE @@output + PUSH STD_INPUT_HANDLE + JMP @@1 +@@output: + PUSH STD_OUTPUT_HANDLE +@@1: + CALL GetStdHandle + JMP @@checkHandle + +@@notAssignedError: + MOV EAX,102 + JMP @@errExit + +@@error: + MOV [EBX].TFileRec.Mode,fmClosed + CALL GetLastError +@@errExit: + CALL SetInOutRes + +@@exit: + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +function _ResetFile(var f: TFileRec; recSize: Longint): Integer; +var + m: Byte; +begin + m := FileMode and 3; + if m > 2 then m := 2; + Result := OpenFile(f, recSize, m); +end; + +function _RewritFile(var f: TFileRec; recSize: Longint): Integer; +begin + Result := OpenFile(f, recSize, 3); +end; + +procedure _Seek(var f: TFileRec; recNum: Cardinal); +{$IFDEF LINUX} +begin + if (f.Mode >= fmInput) and (f.Mode <= fmInOut) then + begin + if _lseek(f.Handle, f.RecSize * recNum, SEEK_SET) = -1 then + InOutError; + end + else + SetInOutRes(103); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm +// -> EAX Pointer to file variable +// EDX Record number + + MOV ECX,EAX + MOVZX EAX,[EAX].TFileRec.Mode // check whether file is open + SUB EAX,fmInput + CMP EAX,fmInOut-fmInput + JA @@fileNotOpen + +// SetFilePointer(f.Handle, recNum*f.RecSize, FILE_BEGIN + PUSH FILE_BEGIN // pass dwMoveMethod + MOV EAX,[ECX].TFileRec.RecSize + MUL EDX + PUSH 0 // pass lpDistanceToMoveHigh + PUSH EAX // pass lDistanceToMove + PUSH [ECX].TFileRec.Handle // pass hFile + CALL SetFilePointer // get current position + INC EAX + JZ InOutError + JMP @@exit + +@@fileNotOpen: + MOV EAX,103 + JMP SetInOutRes + +@@exit: +end; +{$ENDIF} + +function _SeekEof(var t: TTextRec): Boolean; +asm +// -> EAX Pointer to text record +// <- AL Boolean result + + PUSH EBX + MOV EBX,EAX +@@loop: + MOV EAX,EBX + CALL _ReadChar + CMP AL,' ' + JA @@endloop + CMP AH,cEOF + JE @@eof + JMP @@loop +@@eof: + MOV AL,1 + JMP @@exit + +@@endloop: + DEC [EBX].TTextRec.BufPos + XOR AL,AL +@@exit: + POP EBX +end; + +function _SeekEoln(var t: TTextRec): Boolean; +asm +// -> EAX Pointer to text record +// <- AL Boolean result + + PUSH EBX + MOV EBX,EAX +@@loop: + MOV EAX,EBX + CALL _ReadChar + CMP AL,' ' + JA @@falseExit + CMP AH,cEOF + JE @@eof + CMP AL,cLF + JE @@trueExit + CMP AL,cCR + JNE @@loop + +@@trueExit: + MOV AL,1 + JMP @@exitloop + +@@falseExit: + XOR AL,AL +@@exitloop: + DEC [EBX].TTextRec.BufPos + JMP @@exit + +@@eof: + MOV AL,1 +@@exit: + POP EBX +end; + +procedure _SetTextBuf(var t: TTextRec; p: Pointer; size: Longint); +begin + t.BufPtr := P; + t.BufSize := size; + t.BufPos := 0; + t.BufEnd := 0; +end; + +procedure _StrLong(val, width: Longint; s: PShortString); +{$IFDEF PUREPASCAL} +var + I: Integer; + sign: Longint; + a: array [0..19] of char; + P: PChar; +begin + sign := val; + val := Abs(val); + I := 0; + repeat + a[I] := Chr((val mod 10) + Ord('0')); + Inc(I); + val := val div 10; + until val = 0; + + if sign < 0 then + begin + a[I] := '-'; + Inc(I); + end; + + if width < I then + width := I; + if width > 255 then + width := 255; + s^[0] := Chr(width); + P := @S^[1]; + while width > I do + begin + P^ := ' '; + Inc(P); + Dec(width); + end; + repeat + Dec(I); + P^ := a[I]; + Inc(P); + until I <= 0; +end; +{$ELSE} +asm +{ PROCEDURE _StrLong( val: Longint; width: Longint; VAR s: ShortString ); + ->EAX Value + EDX Width + ECX Pointer to string } + + PUSH EBX { VAR i: Longint; } + PUSH ESI { VAR sign : Longint; } + PUSH EDI + PUSH EDX { store width on the stack } + SUB ESP,20 { VAR a: array [0..19] of Char; } + + MOV EDI,ECX + + MOV ESI,EAX { sign := val } + + CDQ { val := Abs(val); canned sequence } + XOR EAX,EDX + SUB EAX,EDX + + MOV ECX,10 + XOR EBX,EBX { i := 0; } + +@@repeat1: { repeat } + XOR EDX,EDX { a[i] := Chr( val MOD 10 + Ord('0') );} + + DIV ECX { val := val DIV 10; } + + ADD EDX,'0' + MOV [ESP+EBX],DL + INC EBX { i := i + 1; } + TEST EAX,EAX { until val = 0; } + JNZ @@repeat1 + + TEST ESI,ESI + JGE @@2 + MOV byte ptr [ESP+EBX],'-' + INC EBX +@@2: + MOV [EDI],BL { s^++ := Chr(i); } + INC EDI + + MOV ECX,[ESP+20] { spaceCnt := width - i; } + CMP ECX,255 + JLE @@3 + MOV ECX,255 +@@3: + SUB ECX,EBX + JLE @@repeat2 { for k := 1 to spaceCnt do s^++ := ' '; } + ADD [EDI-1],CL + MOV AL,' ' + REP STOSB + +@@repeat2: { repeat } + MOV AL,[ESP+EBX-1] { s^ := a[i-1]; } + MOV [EDI],AL + INC EDI { s := s + 1 } + DEC EBX { i := i - 1; } + JNZ @@repeat2 { until i = 0; } + + ADD ESP,20+4 + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +procedure _Str0Long(val: Longint; s: PShortString); +begin + _StrLong(val, 0, s); +end; + +procedure _Truncate(var f: TFileRec); +{$IFDEF LINUX} +begin + if (f.Mode and fmOutput) = fmOutput then // fmOutput or fmInOut + begin + if _ftruncate(f.Handle, _lseek(f.Handle, 0, SEEK_CUR)) = -1 then + InOutError; + end + else + SetInOutRes(103); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm +// -> EAX Pointer to text or file variable + + MOVZX EDX,[EAX].TFileRec.Mode // check whether file is open + SUB EDX,fmInput + CMP EDX,fmInOut-fmInput + JA @@fileNotOpen + + PUSH [EAX].TFileRec.Handle + CALL SetEndOfFile + DEC EAX + JZ @@exit + JMP InOutError + +@@fileNotOpen: + MOV EAX,103 + JMP SetInOutRes + +@@exit: +end; +{$ENDIF} + +function _ValLong(const s: String; var code: Integer): Longint; +{$IFDEF PUREPASCAL} +var + I: Integer; + Negative, Hex: Boolean; +begin + I := 1; + code := -1; + Result := 0; + Negative := False; + Hex := False; + while (I <= Length(s)) and (s[I] = ' ') do Inc(I); + if I > Length(s) then Exit; + case s[I] of + '$', + 'x', + 'X': begin + Hex := True; + Inc(I); + end; + '0': begin + Hex := (Length(s) > I) and (UpCase(s[I+1]) = 'X'); + if Hex then Inc(I,2); + end; + '-': begin + Negative := True; + Inc(I); + end; + '+': Inc(I); + end; + if Hex then + while I <= Length(s) do + begin + if Result > (High(Result) div 16) then + begin + code := I; + Exit; + end; + case s[I] of + '0'..'9': Result := Result * 16 + Ord(s[I]) - Ord('0'); + 'a'..'f': Result := Result * 16 + Ord(s[I]) - Ord('a') + 10; + 'A'..'F': Result := Result * 16 + Ord(s[I]) - Ord('A') + 10; + else + code := I; + Exit; + end; + end + else + while I <= Length(s) do + begin + if Result > (High(Result) div 10) then + begin + code := I; + Exit; + end; + Result := Result * 10 + Ord(s[I]) - Ord('0'); + Inc(I); + end; + if Negative then + Result := -Result; + code := 0; +end; +{$ELSE} +asm +{ FUNCTION _ValLong( s: AnsiString; VAR code: Integer ) : Longint; } +{ ->EAX Pointer to string } +{ EDX Pointer to code result } +{ <-EAX Result } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX + PUSH EAX { save for the error case } + + TEST EAX,EAX + JE @@empty + + XOR EAX,EAX + XOR EBX,EBX + MOV EDI,07FFFFFFFH / 10 { limit } + +@@blankLoop: + MOV BL,[ESI] + INC ESI + CMP BL,' ' + JE @@blankLoop + +@@endBlanks: + MOV CH,0 + CMP BL,'-' + JE @@minus + CMP BL,'+' + JE @@plus + CMP BL,'$' + JE @@dollar + + CMP BL, 'x' + JE @@dollar + CMP BL, 'X' + JE @@dollar + CMP BL, '0' + JNE @@firstDigit + MOV BL, [ESI] + INC ESI + CMP BL, 'x' + JE @@dollar + CMP BL, 'X' + JE @@dollar + TEST BL, BL + JE @@endDigits + JMP @@digLoop + +@@firstDigit: + TEST BL,BL + JE @@error + +@@digLoop: + SUB BL,'0' + CMP BL,9 + JA @@error + CMP EAX,EDI { value > limit ? } + JA @@overFlow + LEA EAX,[EAX+EAX*4] + ADD EAX,EAX + ADD EAX,EBX { fortunately, we can't have a carry } + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JNE @@digLoop + +@@endDigits: + DEC CH + JE @@negate + TEST EAX,EAX + JGE @@successExit + JMP @@overFlow + +@@empty: + INC ESI + JMP @@error + +@@negate: + NEG EAX + JLE @@successExit + JS @@successExit { to handle 2**31 correctly, where the negate overflows } + +@@error: +@@overFlow: + POP EBX + SUB ESI,EBX + JMP @@exit + +@@minus: + INC CH +@@plus: + MOV BL,[ESI] + INC ESI + JMP @@firstDigit + +@@dollar: + MOV EDI,0FFFFFFFH + + MOV BL,[ESI] + INC ESI + TEST BL,BL + JZ @@empty + +@@hDigLoop: + CMP BL,'a' + JB @@upper + SUB BL,'a' - 'A' +@@upper: + SUB BL,'0' + CMP BL,9 + JBE @@digOk + SUB BL,'A' - '0' + CMP BL,5 + JA @@error + ADD BL,10 +@@digOk: + CMP EAX,EDI + JA @@overFlow + SHL EAX,4 + ADD EAX,EBX + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JNE @@hDigLoop + +@@successExit: + POP ECX { saved copy of string pointer } + XOR ESI,ESI { signal no error to caller } + +@@exit: + MOV [EDX],ESI + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +function _WriteRec(var f: TFileRec; buffer: Pointer): Pointer; +{$IFDEF LINUX} +var + Dummy: Integer; +begin + _BlockWrite(f, Buffer, 1, Dummy); + Result := @F; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm +// -> EAX Pointer to file variable +// EDX Pointer to buffer +// <- EAX Pointer to file variable + PUSH EBX + + MOV EBX,EAX + + MOVZX EAX,[EAX].TFileRec.Mode + SUB EAX,fmOutput + CMP EAX,fmInOut-fmOutput // File must be fmInOut or fmOutput + JA @@fileNotOpen + +// WriteFile(f.Handle, buffer, f.RecSize, @result, Nil); + + PUSH 0 // space for OS result + MOV EAX,ESP + + PUSH 0 // pass lpOverlapped + PUSH EAX // pass @result + PUSH [EBX].TFileRec.RecSize // pass nNumberOfBytesToRead + PUSH EDX // pass lpBuffer + PUSH [EBX].TFileRec.Handle // pass hFile + CALL WriteFile + POP EDX // pop result + DEC EAX // check EAX = TRUE + JNZ @@error + + CMP EDX,[EBX].TFileRec.RecSize // result = f.RecSize ? + JE @@exit + +@@writeError: + MOV EAX,101 + JMP @@errExit + +@@fileNotOpen: + MOV EAX,5 + JMP @@errExit + +@@error: + CALL GetLastError +@@errExit: + CALL SetInOutRes +@@exit: + MOV EAX,EBX + POP EBX +end; +{$ENDIF} + +// If the file is Output or ErrOutput std variable, try to open it +// Otherwise, runtime error. +function TryOpenForOutput(var t: TTextRec): Boolean; +begin + if (@t = @Output) or (@t = @ErrOutput) then + begin + t.Flags := tfCRLF * Byte(DefaultTextLineBreakStyle); + _RewritText(t); + end; + + Result := t.Mode = fmOutput; + if not Result then + SetInOutRes(105); +end; + +function _WriteBytes(var t: TTextRec; const b; cnt : Longint): Pointer; +{$IFDEF PUREPASCAL} +var + P: PChar; + RemainingBytes: Longint; + Temp: Integer; +begin + Result := @t; + if t.Mode <> fmOutput and not TryOpenForOutput(t) then Exit; + + P := t.BufPtr + t.BufPos; + RemainingBytes := t.BufSize - t.BufPos; + while RemainingBytes <= cnt do + begin + Inc(t.BufPos, RemainingBytes); + Dec(cnt, RemainingBytes); + Move(B, P^, RemainingBytes); + Temp := TTextIOFunc(t.InOutFunc)(t); + if Temp <> 0 then + begin + SetInOutRes(Temp); + Exit; + end; + P := t.BufPtr + t.BufPos; + RemainingBytes := t.BufSize - t.BufPos; + end; + Inc(t.BufPos, cnt); + Move(B, P^, cnt); +end; +{$ELSE} +asm +// -> EAX Pointer to file record +// EDX Pointer to buffer +// ECX Number of bytes to write +// <- EAX Pointer to file record + + PUSH ESI + PUSH EDI + + MOV ESI,EDX + + CMP [EAX].TTextRec.Mode,fmOutput + JE @@loop + PUSH EAX + PUSH EDX + PUSH ECX + CALL TryOpenForOutput + TEST AL,AL + POP ECX + POP EDX + POP EAX + JE @@exit + +@@loop: + MOV EDI,[EAX].TTextRec.BufPtr + ADD EDI,[EAX].TTextRec.BufPos + +// remainingBytes = t.bufSize - t.bufPos + + MOV EDX,[EAX].TTextRec.BufSize + SUB EDX,[EAX].TTextRec.BufPos + +// if (remainingBytes <= cnt) + + CMP EDX,ECX + JG @@1 + +// t.BufPos += remainingBytes, cnt -= remainingBytes + + ADD [EAX].TTextRec.BufPos,EDX + SUB ECX,EDX + +// copy remainingBytes, advancing ESI + + PUSH EAX + PUSH ECX + MOV ECX,EDX + REP MOVSB + + CALL [EAX].TTextRec.InOutFunc + TEST EAX,EAX + JNZ @@error + + POP ECX + POP EAX + JMP @@loop + +@@error: + CALL SetInOutRes + POP ECX + POP EAX + JMP @@exit +@@1: + ADD [EAX].TTextRec.BufPos,ECX + REP MOVSB + +@@exit: + POP EDI + POP ESI +end; +{$ENDIF} + +function _WriteSpaces(var t: TTextRec; cnt: Longint): Pointer; +{$IFDEF PUREPASCAL} +const + s64Spaces = ' '; +begin + Result := @t; + while cnt > 64 do + begin + _WriteBytes(t, s64Spaces, 64); + if InOutRes <> 0 then Exit; + Dec(cnt, 64); + end; + if cnt > 0 then + _WriteBytes(t, s64Spaces, cnt); +end; +{$ELSE} +const + spCnt = 64; +asm +// -> EAX Pointer to text record +// EDX Number of spaces (<= 0: None) + + MOV ECX,EDX +@@loop: +{$IFDEF PIC} + LEA EDX, [EBX] + offset @@spBuf +{$ELSE} + MOV EDX,offset @@spBuf +{$ENDIF} + + CMP ECX,spCnt + JLE @@1 + + SUB ECX,spCnt + PUSH EAX + PUSH ECX + MOV ECX,spCnt + CALL _WriteBytes + CALL SysInit.@GetTLS + CMP [EAX].InOutRes,0 + JNE @@error + POP ECX + POP EAX + JMP @@loop + +@@error: + POP ECX + POP EAX + JMP @@exit + +@@spBuf: // 64 spaces + DB ' '; +@@1: + TEST ECX,ECX + JG _WriteBytes +@@exit: +end; +{$ENDIF} + +function _Write0Char(var t: TTextRec; c: Char): Pointer; +{$IFDEF PUREPASCAL} +var + Temp: Integer; +begin + Result := @t; + if not TryOpenForOutput(t) then Exit; + + if t.BufPos >= t.BufSize then + begin + Temp := TTextIOFunc(t.InOutFunc)(t); + if Temp <> 0 then + begin + SetInOutRes(Temp); + Exit; + end; + end; + + t.BufPtr[t.BufPos] := c; + Inc(t.BufPos); +end; +{$ELSE} +asm +// -> EAX Pointer to text record +// DL Character + + CMP [EAX].TTextRec.Mode,fmOutput + JE @@loop + PUSH EAX + PUSH EDX + CALL TryOpenForOutput + TEST AL,AL + POP EDX + POP EAX + JNE @@loop + JMP @@exit + +@@flush: + PUSH EAX + PUSH EDX + CALL [EAX].TTextRec.InOutFunc + TEST EAX,EAX + JNZ @@error + POP EDX + POP EAX + JMP @@loop + +@@error: + CALL SetInOutRes + POP EDX + POP EAX + JMP @@exit + +@@loop: + MOV ECX,[EAX].TTextRec.BufPos + CMP ECX,[EAX].TTextRec.BufSize + JGE @@flush + + ADD ECX,[EAX].TTextRec.BufPtr + MOV [ECX],DL + + INC [EAX].TTextRec.BufPos +@@exit: +end; +{$ENDIF} + +function _WriteChar(var t: TTextRec; c: Char; width: Integer): Pointer; +begin + _WriteSpaces(t, width-1); + Result := _WriteBytes(t, c, 1); +end; + +function _WriteBool(var t: TTextRec; val: Boolean; width: Longint): Pointer; +const + BoolStrs: array [Boolean] of ShortString = ('FALSE', 'TRUE'); +begin + Result := _WriteString(t, BoolStrs[val], width); +end; + +function _Write0Bool(var t: TTextRec; val: Boolean): Pointer; +begin + Result := _WriteBool(t, val, 0); +end; + +function _WriteLong(var t: TTextRec; val, width: Longint): Pointer; +var + S: string[31]; +begin + Str(val:0, S); + Result := _WriteString(t, S, width); +end; + +function _Write0Long(var t: TTextRec; val: Longint): Pointer; +begin + Result := _WriteLong(t, val, 0); +end; + +function _Write0String(var t: TTextRec; const s: ShortString): Pointer; +begin + Result := _WriteBytes(t, S[1], Byte(S[0])); +end; + +function _WriteString(var t: TTextRec; const s: ShortString; width: Longint): Pointer; +begin + _WriteSpaces(t, Width - Byte(S[0])); + Result := _WriteBytes(t, S[1], Byte(S[0])); +end; + +function _Write0CString(var t: TTextRec; s: PChar): Pointer; +begin + Result := _WriteCString(t, s, 0); +end; + +function _WriteCString(var t: TTextRec; s: PChar; width: Longint): Pointer; +var + len: Longint; +begin + len := _strlen(s); + _WriteSpaces(t, width - len); + Result := _WriteBytes(t, s^, len); +end; + +procedure _Write2Ext; +asm +{ PROCEDURE _Write2Ext( VAR t: Text; val: Extended; width, prec: Longint); + ->EAX Pointer to file record + [ESP+4] Extended value + EDX Field width + ECX precision (<0: scientific, >= 0: fixed point) } + + FLD tbyte ptr [ESP+4] { load value } + SUB ESP,256 { VAR s: String; } + + PUSH EAX + PUSH EDX + +{ Str( val, width, prec, s ); } + + SUB ESP,12 + FSTP tbyte ptr [ESP] { pass value } + MOV EAX,EDX { pass field width } + MOV EDX,ECX { pass precision } + LEA ECX,[ESP+8+12] { pass destination string } + CALL _Str2Ext + +{ Write( t, s, width ); } + + POP ECX { pass width } + POP EAX { pass text } + MOV EDX,ESP { pass string } + CALL _WriteString + + ADD ESP,256 + RET 12 +end; + +procedure _Write1Ext; +asm +{ PROCEDURE _Write1Ext( VAR t: Text; val: Extended; width: Longint); + -> EAX Pointer to file record + [ESP+4] Extended value + EDX Field width } + + OR ECX,-1 + JMP _Write2Ext +end; + +procedure _Write0Ext; +asm +{ PROCEDURE _Write0Ext( VAR t: Text; val: Extended); + ->EAX Pointer to file record + [ESP+4] Extended value } + + MOV EDX,23 { field width } + OR ECX,-1 + JMP _Write2Ext +end; + +function _WriteLn(var t: TTextRec): Pointer; +var + Buf: array [0..1] of Char; +begin + if (t.flags and tfCRLF) <> 0 then + begin + Buf[0] := #13; + Buf[1] := #10; + Result := _WriteBytes(t, Buf, 2); + end + else + begin + Buf[0] := #10; + Result := _WriteBytes(t, Buf, 1); + end; + _Flush(t); +end; + +procedure __CToPasStr(Dest: PShortString; const Source: PChar); +begin + __CLenToPasStr(Dest, Source, 255); +end; + +procedure __CLenToPasStr(Dest: PShortString; const Source: PChar; MaxLen: Integer); +{$IFDEF PUREPASCAL} +var + I: Integer; +begin + I := 0; + if MaxLen > 255 then MaxLen := 255; + while (Source[I] <> #0) and (I <= MaxLen) do + begin + Dest^[I+1] := Source[I]; + Inc(I); + end; + if I > 0 then Dec(I); + Byte(Dest^[0]) := I; +end; +{$ELSE} +asm +{ ->EAX Pointer to destination } +{ EDX Pointer to source } +{ ECX cnt } + + PUSH EBX + PUSH EAX { save destination } + + CMP ECX,255 + JBE @@loop + MOV ECX,255 +@@loop: + MOV BL,[EDX] { ch = *src++; } + INC EDX + TEST BL,BL { if (ch == 0) break } + JE @@endLoop + INC EAX { *++dest = ch; } + MOV [EAX],BL + DEC ECX { while (--cnt != 0) } + JNZ @@loop + +@@endLoop: + POP EDX + SUB EAX,EDX + MOV [EDX],AL + POP EBX +end; +{$ENDIF} + +procedure __ArrayToPasStr(Dest: PShortString; const Source: PChar; Len: Integer); +begin + if Len > 255 then Len := 255; + Byte(Dest^[0]) := Len; + Move(Source^, Dest^[1], Len); +end; + +procedure __PasToCStr(const Source: PShortString; const Dest: PChar); +begin + Move(Source^[1], Dest^, Byte(Source^[0])); + Dest[Byte(Source^[0])] := #0; +end; + +procedure _SetElem; +asm + { PROCEDURE _SetElem( VAR d: SET; elem, size: Byte); } + { EAX = dest address } + { DL = element number } + { CL = size of set } + + PUSH EBX + PUSH EDI + + MOV EDI,EAX + + XOR EBX,EBX { zero extend set size into ebx } + MOV BL,CL + MOV ECX,EBX { and use it for the fill } + + XOR EAX,EAX { for zero fill } + REP STOSB + + SUB EDI,EBX { point edi at beginning of set again } + + INC EAX { eax is still zero - make it 1 } + MOV CL,DL + ROL AL,CL { generate a mask } + SHR ECX,3 { generate the index } + CMP ECX,EBX { if index >= siz then exit } + JAE @@exit + OR [EDI+ECX],AL{ set bit } + +@@exit: + POP EDI + POP EBX +end; + +procedure _SetRange; +asm +{ PROCEDURE _SetRange( lo, hi, size: Byte; VAR d: SET ); } +{ ->AL low limit of range } +{ DL high limit of range } +{ ECX Pointer to set } +{ AH size of set } + + PUSH EBX + PUSH ESI + PUSH EDI + + XOR EBX,EBX { EBX = set size } + MOV BL,AH + MOVZX ESI,AL { ESI = low zero extended } + MOVZX EDX,DL { EDX = high zero extended } + MOV EDI,ECX + +{ clear the set } + + MOV ECX,EBX + XOR EAX,EAX + REP STOSB + +{ prepare for setting the bits } + + SUB EDI,EBX { point EDI at start of set } + SHL EBX,3 { EBX = highest bit in set + 1 } + CMP EDX,EBX + JB @@inrange + LEA EDX,[EBX-1] { ECX = highest bit in set } + +@@inrange: + CMP ESI,EDX { if lo > hi then exit; } + JA @@exit + + DEC EAX { loMask = 0xff << (lo & 7) } + MOV ECX,ESI + AND CL,07H + SHL AL,CL + + SHR ESI,3 { loIndex = lo >> 3; } + + MOV CL,DL { hiMask = 0xff >> (7 - (hi & 7)); } + NOT CL + AND CL,07 + SHR AH,CL + + SHR EDX,3 { hiIndex = hi >> 3; } + + ADD EDI,ESI { point EDI to set[loIndex] } + MOV ECX,EDX + SUB ECX,ESI { if ((inxDiff = (hiIndex - loIndex)) == 0) } + JNE @@else + + AND AL,AH { set[loIndex] = hiMask & loMask; } + MOV [EDI],AL + JMP @@exit + +@@else: + STOSB { set[loIndex++] = loMask; } + DEC ECX + MOV AL,0FFH { while (loIndex < hiIndex) } + REP STOSB { set[loIndex++] = 0xff; } + MOV [EDI],AH { set[hiIndex] = hiMask; } + +@@exit: + POP EDI + POP ESI + POP EBX +end; + +procedure _SetEq; +asm +{ FUNCTION _SetEq( CONST l, r: Set; size: Byte): ConditionCode; } +{ EAX = left operand } +{ EDX = right operand } +{ CL = size of set } + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + AND ECX,0FFH + REP CMPSB + + POP EDI + POP ESI +end; + +procedure _SetLe; +asm +{ FUNCTION _SetLe( CONST l, r: Set; size: Byte): ConditionCode; } +{ EAX = left operand } +{ EDX = right operand } +{ CL = size of set (>0 && <= 32) } + +@@loop: + MOV CH,[EDX] + NOT CH + AND CH,[EAX] + JNE @@exit + INC EDX + INC EAX + DEC CL + JNZ @@loop +@@exit: +end; + +procedure _SetIntersect; +asm +{ PROCEDURE _SetIntersect( VAR dest: Set; CONST src: Set; size: Byte);} +{ EAX = destination operand } +{ EDX = source operand } +{ CL = size of set (0 < size <= 32) } + +@@loop: + MOV CH,[EDX] + INC EDX + AND [EAX],CH + INC EAX + DEC CL + JNZ @@loop +end; + +procedure _SetIntersect3; +asm +{ PROCEDURE _SetIntersect3( VAR dest: Set; CONST src: Set; size: Longint; src2: Set);} +{ EAX = destination operand } +{ EDX = source operand } +{ ECX = size of set (0 < size <= 32) } +{ [ESP+4] = 2nd source operand } + + PUSH EBX + PUSH ESI + MOV ESI,[ESP+8+4] +@@loop: + MOV BL,[EDX+ECX-1] + AND BL,[ESI+ECX-1] + MOV [EAX+ECX-1],BL + DEC ECX + JNZ @@loop + + POP ESI + POP EBX +end; + +procedure _SetUnion; +asm +{ PROCEDURE _SetUnion( VAR dest: Set; CONST src: Set; size: Byte); } +{ EAX = destination operand } +{ EDX = source operand } +{ CL = size of set (0 < size <= 32) } + +@@loop: + MOV CH,[EDX] + INC EDX + OR [EAX],CH + INC EAX + DEC CL + JNZ @@loop +end; + +procedure _SetUnion3; +asm +{ PROCEDURE _SetUnion3( VAR dest: Set; CONST src: Set; size: Longint; src2: Set);} +{ EAX = destination operand } +{ EDX = source operand } +{ ECX = size of set (0 < size <= 32) } +{ [ESP+4] = 2nd source operand } + + PUSH EBX + PUSH ESI + MOV ESI,[ESP+8+4] +@@loop: + MOV BL,[EDX+ECX-1] + OR BL,[ESI+ECX-1] + MOV [EAX+ECX-1],BL + DEC ECX + JNZ @@loop + + POP ESI + POP EBX +end; + +procedure _SetSub; +asm +{ PROCEDURE _SetSub( VAR dest: Set; CONST src: Set; size: Byte); } +{ EAX = destination operand } +{ EDX = source operand } +{ CL = size of set (0 < size <= 32) } + +@@loop: + MOV CH,[EDX] + NOT CH + INC EDX + AND [EAX],CH + INC EAX + DEC CL + JNZ @@loop +end; + +procedure _SetSub3; +asm +{ PROCEDURE _SetSub3( VAR dest: Set; CONST src: Set; size: Longint; src2: Set);} +{ EAX = destination operand } +{ EDX = source operand } +{ ECX = size of set (0 < size <= 32) } +{ [ESP+4] = 2nd source operand } + + PUSH EBX + PUSH ESI + MOV ESI,[ESP+8+4] +@@loop: + MOV BL,[ESI+ECX-1] + NOT BL + AND BL,[EDX+ECX-1] + MOV [EAX+ECX-1],BL + DEC ECX + JNZ @@loop + + POP ESI + POP EBX +end; + +procedure _SetExpand; +asm +{ PROCEDURE _SetExpand( CONST src: Set; VAR dest: Set; lo, hi: Byte); } +{ ->EAX Pointer to source (packed set) } +{ EDX Pointer to destination (expanded set) } +{ CH high byte of source } +{ CL low byte of source } + +{ algorithm: } +{ clear low bytes } +{ copy high-low+1 bytes } +{ clear 31-high bytes } + + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + MOV EDX,ECX { save low, high in dl, dh } + XOR ECX,ECX + XOR EAX,EAX + + MOV CL,DL { clear low bytes } + REP STOSB + + MOV CL,DH { copy high - low bytes } + SUB CL,DL + REP MOVSB + + MOV CL,32 { copy 32 - high bytes } + SUB CL,DH + REP STOSB + + POP EDI + POP ESI +end; + +procedure _EmitDigits; +const + tenE17: Double = 1e17; + tenE18: Double = 1e18; +asm +// -> FST(0) Value, 0 <= value < 10.0 +// EAX Count of digits to generate +// EDX Pointer to digit buffer + + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX +{$ELSE} + XOR EBX,EBX +{$ENDIF} + PUSH EDI + MOV EDI,EDX + MOV ECX,EAX + + SUB ESP,10 // VAR bcdBuf: array [0..9] of Byte + MOV byte ptr [EDI],'0' // digBuf[0] := '0'// + FMUL qword ptr [EBX] + offset tenE17 // val := Round(val*1e17); + FRNDINT + + FCOM qword ptr [EBX] + offset tenE18 // if val >= 1e18 then + FSTSW AX + SAHF + JB @@1 + + FSUB qword ptr [EBX] + offset tenE18 // val := val - 1e18; + MOV byte ptr [EDI],'1' // digBuf[0] := '1'; +@@1: + FBSTP tbyte ptr [ESP] // store packed bcd digits in bcdBuf + + MOV EDX,8 + INC EDI + +@@2: + WAIT + MOV AL,[ESP+EDX] // unpack 18 bcd digits in 9 bytes + MOV AH,AL // into 9 words = 18 bytes + SHR AL,4 + AND AH,0FH + ADD AX,'00' + STOSW + DEC EDX + JNS @@2 + + SUB ECX,18 // we need at least digCnt digits + JL @@3 // we have generated 18 + + MOV AL,'0' // if this is not enough, append zeroes + REP STOSB + JMP @@4 // in this case, we don't need to round + +@@3: + ADD EDI,ECX // point EDI to the round digit + CMP byte ptr [EDI],'5' + JL @@4 +@@5: + DEC EDI + INC byte ptr [EDI] + CMP byte ptr [EDI],'9' + JLE @@4 + MOV byte ptr [EDI],'0' + JMP @@5 + +@@4: + ADD ESP,10 + POP EDI + POP EBX +end; + +procedure _ScaleExt; +asm +// -> FST(0) Value +// <- EAX exponent (base 10) +// FST(0) Value / 10**eax +// PIC safe - uses EBX, but only call is to _POW10, which fixes up EBX itself + + PUSH EBX + SUB ESP,12 + + XOR EBX,EBX + +@@normLoop: // loop necessary for denormals + + FLD ST(0) + FSTP tbyte ptr [ESP] + MOV AX,[ESP+8] + TEST AX,AX + JE @@testZero +@@cont: + SUB AX,3FFFH + MOV DX,4D10H // log10(2) * 2**16 + IMUL DX + MOVSX EAX,DX // exp10 = exp2 * log10(2) + NEG EAX + JE @@exit + SUB EBX,EAX + CALL _Pow10 + JMP @@normLoop + +@@testZero: + CMP dword ptr [ESP+4],0 + JNE @@cont + CMP dword ptr [ESP+0],0 + JNE @@cont + +@@exit: + ADD ESP,12 + MOV EAX,EBX + POP EBX +end; + +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 ); +const + MAXDIGS = 256; +asm +// -> [ESP+4] Extended value +// EAX Width +// EDX Precision +// ECX Pointer to string + + FLD tbyte ptr [ESP+4] + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV ESI,EDX + PUSH ECX // save string pointer + SUB ESP,MAXDIGS // VAR digBuf: array [0..MAXDIGS-1] of Char + +// limit width to 255 + + CMP EBX,255 // if width > 255 then width := 255; + JLE @@1 + MOV EBX,255 +@@1: + +// save sign bit in bit 0 of EDI, take absolute value of val, check for +// Nan and infinity. + + FLD ST(0) + FSTP tbyte ptr [ESP] + XOR EAX,EAX + MOV AX,word ptr [ESP+8] + MOV EDI,EAX + SHR EDI,15 + AND AX,7FFFH + CMP AX,7FFFH + JE @@nanInf + FABS + +// if precision < 0 then do scientific else do fixed; + + TEST ESI,ESI + JGE @@fixed + +// the following call finds a decimal exponent and a reduced +// mantissa such that val = mant * 10**exp + + CALL _ScaleExt // val is FST(0), exp is EAX + +// for scientific notation, we have width - 8 significant digits +// however, we can not have less than 2 or more than 18 digits. + +@@scientific: + + MOV ESI,EBX // digCnt := width - 8; + SUB ESI,8 + CMP ESI,2 // if digCnt < 2 then digCnt := 2 + JGE @@2 + MOV ESI,2 + JMP @@3 +@@2: + CMP ESI,18 // else if digCnt > 18 then digCnt := 18; + JLE @@3 + MOV ESI,18 +@@3: + +// _EmitDigits( val, digCnt, digBuf ) + + MOV EDX,ESP // pass digBuf + PUSH EAX // save exponent + MOV EAX,ESI // pass digCnt + CALL _EmitDigits // convert val to ASCII + + MOV EDX,EDI // save sign in EDX + MOV EDI,[ESP+MAXDIGS+4] // load result string pointer + + MOV [EDI],BL // length of result string := width + INC EDI + + MOV AL,' ' // prepare for leading blanks and sign + + MOV ECX,EBX // blankCnt := width - digCnt - 8 + SUB ECX,ESI + SUB ECX,8 + JLE @@4 + + REP STOSB // emit blankCnt blanks +@@4: + SUB [EDI-1],CL // if blankCnt < 0, adjust length + + TEST DL,DL // emit the sign (' ' or '-') + JE @@5 + MOV AL,'-' +@@5: + STOSB + + POP EAX + MOV ECX,ESI // emit digCnt digits + MOV ESI,ESP // point ESI to digBuf + + CMP byte ptr [ESI],'0' + JE @@5a // if rounding overflowed, adjust exponent and ESI + INC EAX + DEC ESI +@@5a: + INC ESI + + MOVSB // emit one digit + MOV byte ptr [EDI],'.' // emit dot + INC EDI // adjust dest pointer + DEC ECX // adjust count + + REP MOVSB + + MOV byte ptr [EDI],'E' + + MOV CL,'+' // emit sign of exponent ('+' or '-') + TEST EAX,EAX + JGE @@6 + MOV CL,'-' + NEG EAX +@@6: + MOV [EDI+1],CL + + XOR EDX,EDX // emit exponent + MOV CX,10 + DIV CX + ADD DL,'0' + MOV [EDI+5],DL + + XOR EDX,EDX + DIV CX + ADD DL,'0' + MOV [EDI+4],DL + + XOR EDX,EDX + DIV CX + ADD DL,'0' + MOV [EDI+3],DL + + ADD AL,'0' + MOV [EDI+2],AL + + JMP @@exit + +@@fixed: + +// FST(0) = value >= 0.0 +// EBX = width +// ESI = precision +// EDI = sign + + CMP ESI,MAXDIGS-40 // else if precision > MAXDIGS-40 then precision := MAXDIGS-40; + JLE @@6a + MOV ESI,MAXDIGS-40 +@@6a: +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + FCOM qword ptr [EAX] + offset Ten + POP EAX +{$ELSE} + FCOM qword ptr ten +{$ENDIF} + FSTSW AX + SAHF + MOV EAX,0 + JB @@7 + + CALL _ScaleExt // val is FST(0), exp is EAX + + CMP EAX,35 // if val is too large, use scientific + JG @@scientific + +@@7: +// FST(0) = scaled value, 0.0 <= value < 10.0 +// EAX = exponent, 0 <= exponent + +// intDigCnt := exponent + 1; + + INC EAX + +// _EmitDigits( value, intDigCnt + precision, digBuf ); + + MOV EDX,ESP + PUSH EAX + ADD EAX,ESI + CALL _EmitDigits + POP EAX + +// Now we need to check whether rounding to the right number of +// digits overflowed, and if so, adjust things accordingly + + MOV EDX,ESI // put precision in EDX + MOV ESI,ESP // point EDI to digBuf + CMP byte ptr [ESI],'0' + JE @@8 + INC EAX + DEC ESI +@@8: + INC ESI + + MOV ECX,EAX // numWidth := sign + intDigCnt; + ADD ECX,EDI + + TEST EDX,EDX // if precision > 0 then + JE @@9 + INC ECX // numWidth := numWidth + 1 + precision + ADD ECX,EDX + + CMP EBX,ECX // if width <= numWidth + JG @@9 + MOV EBX,ECX // width := numWidth +@@9: + PUSH EAX + PUSH EDI + + MOV EDI,[ESP+MAXDIGS+2*4] // point EDI to dest string + + MOV [EDI],BL // store final length in dest string + INC EDI + + SUB EBX,ECX // width := width - numWidth + MOV ECX,EBX + JLE @@10 + + MOV AL,' ' // emit width blanks + REP STOSB +@@10: + SUB [EDI-1],CL // if blankCnt < 0, adjust length + POP EAX + POP ECX + + TEST EAX,EAX + JE @@11 + + MOV byte ptr [EDI],'-' + INC EDI + +@@11: + REP MOVSB // copy intDigCnt digits + + TEST EDX,EDX // if precision > 0 then + JE @@12 + + MOV byte ptr [EDI],'.' // emit '.' + INC EDI + MOV ECX,EDX // emit precision digits + REP MOVSB + +@@12: + +@@exit: + ADD ESP,MAXDIGS + POP ECX + POP EDI + POP ESI + POP EBX + RET 12 + +@@nanInf: +// here: EBX = width, ECX = string pointer, EDI = sign, [ESP] = value + +{$IFDEF PIC} + CALL GetGOT +{$ELSE} + XOR EAX,EAX +{$ENDIF} + FSTP ST(0) + CMP dword ptr [ESP+4],80000000H + LEA ESI,[EAX] + offset nanStr + JNE @@13 + DEC EDI + LEA ESI,[EAX] + offset plusInfStr + JNZ @@13 + LEA ESI,[EAX] + offset minInfStr +@@13: + MOV EDI,ECX + MOV ECX,EBX + MOV [EDI],CL + INC EDI + SUB CL,[ESI] + JBE @@14 + MOV AL,' ' + REP STOSB +@@14: + SUB [EDI-1],CL + MOV CL,[ESI] + INC ESI + REP MOVSB + + JMP @@exit +end; + +procedure _Str0Ext; +asm +// -> [ESP+4] Extended value +// EAX Pointer to string + + MOV ECX,EAX // pass string + MOV EAX,23 // pass default field width + OR EDX,-1 // pass precision -1 + JMP _Str2Ext +end; + +procedure _Str1Ext;//( val: Extended; width: Longint; var s: String ); +asm +// -> [ESP+4] Extended value +// EAX Field width +// EDX Pointer to string + + MOV ECX,EDX + OR EDX,-1 // pass precision -1 + JMP _Str2Ext +end; + +//function _ValExt( s: AnsiString; VAR code: Integer ) : Extended; +procedure _ValExt; +asm +// -> EAX Pointer to string +// EDX Pointer to code result +// <- FST(0) Result + + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX +{$ELSE} + XOR EBX,EBX +{$ENDIF} + PUSH ESI + PUSH EDI + + PUSH EBX // SaveGOT = ESP+8 + MOV ESI,EAX + PUSH EAX // save for the error case + + FLDZ + XOR EAX,EAX + XOR EBX,EBX + XOR EDI,EDI + + PUSH EBX // temp to get digs to fpu + + TEST ESI,ESI + JE @@empty + +@@blankLoop: + MOV BL,[ESI] + INC ESI + CMP BL,' ' + JE @@blankLoop + +@@endBlanks: + MOV CH,0 + CMP BL,'-' + JE @@minus + CMP BL,'+' + JE @@plus + JMP @@firstDigit + +@@minus: + INC CH +@@plus: + MOV BL,[ESI] + INC ESI + +@@firstDigit: + TEST BL,BL + JE @@error + + MOV EDI,[ESP+8] // SaveGOT + +@@digLoop: + SUB BL,'0' + CMP BL,9 + JA @@dotExp + FMUL qword ptr [EDI] + offset Ten + MOV dword ptr [ESP],EBX + FIADD dword ptr [ESP] + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JNE @@digLoop + JMP @@prefinish + +@@dotExp: + CMP BL,'.' - '0' + JNE @@exp + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JE @@prefinish + +// EDI = SaveGot +@@fracDigLoop: + SUB BL,'0' + CMP BL,9 + JA @@exp + FMUL qword ptr [EDI] + offset Ten + MOV dword ptr [ESP],EBX + FIADD dword ptr [ESP] + DEC EAX + + MOV BL,[ESI] + INC ESI + + TEST BL,BL + JNE @@fracDigLoop + +@@prefinish: + XOR EDI,EDI + JMP @@finish + +@@exp: + CMP BL,'E' - '0' + JE @@foundExp + CMP BL,'e' - '0' + JNE @@error +@@foundExp: + MOV BL,[ESI] + INC ESI + MOV AH,0 + CMP BL,'-' + JE @@minusExp + CMP BL,'+' + JE @@plusExp + JMP @@firstExpDigit +@@minusExp: + INC AH +@@plusExp: + MOV BL,[ESI] + INC ESI +@@firstExpDigit: + SUB BL,'0' + CMP BL,9 + JA @@error + MOV EDI,EBX + MOV BL,[ESI] + INC ESI + TEST BL,BL + JZ @@endExp +@@expDigLoop: + SUB BL,'0' + CMP BL,9 + JA @@error + LEA EDI,[EDI+EDI*4] + ADD EDI,EDI + ADD EDI,EBX + MOV BL,[ESI] + INC ESI + TEST BL,BL + JNZ @@expDigLoop +@@endExp: + DEC AH + JNZ @@expPositive + NEG EDI +@@expPositive: + MOVSX EAX,AL + +@@finish: + ADD EAX,EDI + PUSH EDX + PUSH ECX + CALL _Pow10 + POP ECX + POP EDX + + DEC CH + JE @@negate + +@@successExit: + + ADD ESP,12 // pop temp and saved copy of string pointer + + XOR ESI,ESI // signal no error to caller + +@@exit: + MOV [EDX],ESI + + POP EDI + POP ESI + POP EBX + RET + +@@negate: + FCHS + JMP @@successExit + +@@empty: + INC ESI + +@@error: + POP EAX + POP EBX + SUB ESI,EBX + ADD ESP,4 + JMP @@exit +end; + +procedure FPower10; +asm + JMP _Pow10 +end; + +//function _Pow10(val: Extended; Power: Integer): Extended; +procedure _Pow10; +asm +// -> FST(0) val +// -> EAX Power +// <- FST(0) val * 10**Power + +// This routine generates 10**power with no more than two +// floating point multiplications. Up to 10**31, no multiplications +// are needed. + + PUSH EBX +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX,EAX + POP EAX +{$ELSE} + XOR EBX,EBX +{$ENDIF} + TEST EAX,EAX + JL @@neg + JE @@exit + CMP EAX,5120 + JGE @@inf + MOV EDX,EAX + AND EDX,01FH + LEA EDX,[EDX+EDX*4] + FLD tbyte ptr @@tab0[EBX+EDX*2] + + FMULP + + SHR EAX,5 + JE @@exit + + MOV EDX,EAX + AND EDX,0FH + JE @@skip2ndMul + LEA EDX,[EDX+EDX*4] + FLD tbyte ptr @@tab1-10[EBX+EDX*2] + FMULP + +@@skip2ndMul: + + SHR EAX,4 + JE @@exit + LEA EAX,[EAX+EAX*4] + FLD tbyte ptr @@tab2-10[EBX+EAX*2] + FMULP + JMP @@exit + +@@neg: + NEG EAX + CMP EAX,5120 + JGE @@zero + MOV EDX,EAX + AND EDX,01FH + LEA EDX,[EDX+EDX*4] + FLD tbyte ptr @@tab0[EBX+EDX*2] + FDIVP + + SHR EAX,5 + JE @@exit + + MOV EDX,EAX + AND EDX,0FH + JE @@skip2ndDiv + LEA EDX,[EDX+EDX*4] + FLD tbyte ptr @@tab1-10[EBX+EDX*2] + FDIVP + +@@skip2ndDiv: + + SHR EAX,4 + JE @@exit + LEA EAX,[EAX+EAX*4] + FLD tbyte ptr @@tab2-10[EBX+EAX*2] + FDIVP + + JMP @@exit + +@@inf: + FLD tbyte ptr @@infval[EBX] + JMP @@exit + +@@zero: + FLDZ + +@@exit: + POP EBX + RET + +@@infval: DW $0000,$0000,$0000,$8000,$7FFF +@@tab0: DW $0000,$0000,$0000,$8000,$3FFF // 10**0 + DW $0000,$0000,$0000,$A000,$4002 // 10**1 + DW $0000,$0000,$0000,$C800,$4005 // 10**2 + DW $0000,$0000,$0000,$FA00,$4008 // 10**3 + DW $0000,$0000,$0000,$9C40,$400C // 10**4 + DW $0000,$0000,$0000,$C350,$400F // 10**5 + DW $0000,$0000,$0000,$F424,$4012 // 10**6 + DW $0000,$0000,$8000,$9896,$4016 // 10**7 + DW $0000,$0000,$2000,$BEBC,$4019 // 10**8 + DW $0000,$0000,$2800,$EE6B,$401C // 10**9 + DW $0000,$0000,$F900,$9502,$4020 // 10**10 + DW $0000,$0000,$B740,$BA43,$4023 // 10**11 + DW $0000,$0000,$A510,$E8D4,$4026 // 10**12 + DW $0000,$0000,$E72A,$9184,$402A // 10**13 + DW $0000,$8000,$20F4,$B5E6,$402D // 10**14 + DW $0000,$A000,$A931,$E35F,$4030 // 10**15 + DW $0000,$0400,$C9BF,$8E1B,$4034 // 10**16 + DW $0000,$C500,$BC2E,$B1A2,$4037 // 10**17 + DW $0000,$7640,$6B3A,$DE0B,$403A // 10**18 + DW $0000,$89E8,$2304,$8AC7,$403E // 10**19 + DW $0000,$AC62,$EBC5,$AD78,$4041 // 10**20 + DW $8000,$177A,$26B7,$D8D7,$4044 // 10**21 + DW $9000,$6EAC,$7832,$8786,$4048 // 10**22 + DW $B400,$0A57,$163F,$A968,$404B // 10**23 + DW $A100,$CCED,$1BCE,$D3C2,$404E // 10**24 + DW $84A0,$4014,$5161,$8459,$4052 // 10**25 + DW $A5C8,$9019,$A5B9,$A56F,$4055 // 10**26 + DW $0F3A,$F420,$8F27,$CECB,$4058 // 10**27 + DW $0984,$F894,$3978,$813F,$405C // 10**28 + DW $0BE5,$36B9,$07D7,$A18F,$405F // 10**29 + DW $4EDF,$0467,$C9CD,$C9F2,$4062 // 10**30 + DW $2296,$4581,$7C40,$FC6F,$4065 // 10**31 + +@@tab1: DW $B59E,$2B70,$ADA8,$9DC5,$4069 // 10**32 + DW $A6D5,$FFCF,$1F49,$C278,$40D3 // 10**64 + DW $14A3,$C59B,$AB16,$EFB3,$413D // 10**96 + DW $8CE0,$80E9,$47C9,$93BA,$41A8 // 10**128 + DW $17AA,$7FE6,$A12B,$B616,$4212 // 10**160 + DW $556B,$3927,$F78D,$E070,$427C // 10**192 + DW $C930,$E33C,$96FF,$8A52,$42E7 // 10**224 + DW $DE8E,$9DF9,$EBFB,$AA7E,$4351 // 10**256 + DW $2F8C,$5C6A,$FC19,$D226,$43BB // 10**288 + DW $E376,$F2CC,$2F29,$8184,$4426 // 10**320 + DW $0AD2,$DB90,$2700,$9FA4,$4490 // 10**352 + DW $AA17,$AEF8,$E310,$C4C5,$44FA // 10**384 + DW $9C59,$E9B0,$9C07,$F28A,$4564 // 10**416 + DW $F3D4,$EBF7,$4AE1,$957A,$45CF // 10**448 + DW $A262,$0795,$D8DC,$B83E,$4639 // 10**480 + +@@tab2: DW $91C7,$A60E,$A0AE,$E319,$46A3 // 10**512 + DW $0C17,$8175,$7586,$C976,$4D48 // 10**1024 + DW $A7E4,$3993,$353B,$B2B8,$53ED // 10**1536 + DW $5DE5,$C53D,$3B5D,$9E8B,$5A92 // 10**2048 + DW $F0A6,$20A1,$54C0,$8CA5,$6137 // 10**2560 + DW $5A8B,$D88B,$5D25,$F989,$67DB // 10**3072 + DW $F3F8,$BF27,$C8A2,$DD5D,$6E80 // 10**3584 + DW $979B,$8A20,$5202,$C460,$7525 // 10**4096 + DW $59F0,$6ED5,$1162,$AE35,$7BCA // 10**4608 +end; + +const + RealBias = 129; + ExtBias = $3FFF; + +procedure _Real2Ext;//( val : Real ) : Extended; +asm +// -> EAX Pointer to value +// <- FST(0) Result + +// the REAL data type has the following format: +// 8 bit exponent (bias 129), 39 bit fraction, 1 bit sign + + MOV DH,[EAX+5] // isolate the sign bit + AND DH,80H + MOV DL,[EAX] // fetch exponent + TEST DL,DL // exponent zero means number is zero + JE @@zero + + ADD DX,ExtBias-RealBias // adjust exponent bias + + PUSH EDX // the exponent is at the highest address + + MOV EDX,[EAX+2] // load high fraction part, set hidden bit + OR EDX,80000000H + PUSH EDX // push high fraction part + + MOV DL,[EAX+1] // load remaining low byte of fraction + SHL EDX,24 // clear low 24 bits + PUSH EDX + + FLD tbyte ptr [ESP] // pop result onto chip + ADD ESP,12 + + RET + +@@zero: + FLDZ + RET +end; + +procedure _Ext2Real;//( val : Extended ) : Real; +asm +// -> FST(0) Value +// EAX Pointer to result + + PUSH EBX + + SUB ESP,12 + FSTP tbyte ptr [ESP] + + POP EBX // EBX is low half of fraction + POP EDX // EDX is high half of fraction + POP ECX // CX is exponent and sign + + SHR EBX,24 // set carry to last bit shifted out + ADC BL,0 // if bit was 1, round up + ADC EDX,0 + ADC CX,0 + JO @@overflow + + ADD EDX,EDX // shift fraction 1 bit left + ADD CX,CX // shift sign bit into carry + RCR EDX,1 // attach sign bit to fraction + SHR CX,1 // restore exponent, deleting sign + + SUB CX,ExtBias-RealBias // adjust exponent + JLE @@underflow + TEST CH,CH // CX must be in 1..255 + JG @@overflow + + MOV [EAX],CL + MOV [EAX+1],BL + MOV [EAX+2],EDX + + POP EBX + RET + +@@underflow: + XOR ECX,ECX + MOV [EAX],ECX + MOV [EAX+4],CX + POP EBX + RET + +@@overflow: + POP EBX + MOV AL,8 + JMP Error +end; + +const + ovtInstanceSize = -8; { Offset of instance size in OBJECTs } + ovtVmtPtrOffs = -4; + +procedure _ObjSetup; +asm +{ FUNCTION _ObjSetup( self: ^OBJECT; vmt: ^VMT): ^OBJECT; } +{ ->EAX Pointer to self (possibly nil) } +{ EDX Pointer to vmt (possibly nil) } +{ <-EAX Pointer to self } +{ EDX <> 0: an object was allocated } +{ Z-Flag Set: failure, Cleared: Success } + + CMP EDX,1 { is vmt = 0, indicating a call } + JAE @@skip1 { from a constructor? } + RET { return immediately with Z-flag cleared } + +@@skip1: + PUSH ECX + TEST EAX,EAX { is self already allocated? } + JNE @@noAlloc + MOV EAX,[EDX].ovtInstanceSize + TEST EAX,EAX + JE @@zeroSize + PUSH EDX + CALL _GetMem + POP EDX + TEST EAX,EAX + JZ @@fail + + { Zero fill the memory } + PUSH EDI + MOV ECX,[EDX].ovtInstanceSize + MOV EDI,EAX + PUSH EAX + XOR EAX,EAX + SHR ECX,2 + REP STOSD + MOV ECX,[EDX].ovtInstanceSize + AND ECX,3 + REP STOSB + POP EAX + POP EDI + + MOV ECX,[EDX].ovtVmtPtrOffs + TEST ECX,ECX + JL @@skip + MOV [EAX+ECX],EDX { store vmt in object at this offset } +@@skip: + TEST EAX,EAX { clear zero flag } + POP ECX + RET + +@@fail: + XOR EDX,EDX + POP ECX + RET + +@@zeroSize: + XOR EDX,EDX + CMP EAX,1 { clear zero flag - we were successful (kind of) } + POP ECX + RET + +@@noAlloc: + MOV ECX,[EDX].ovtVmtPtrOffs + TEST ECX,ECX + JL @@exit + MOV [EAX+ECX],EDX { store vmt in object at this offset } +@@exit: + XOR EDX,EDX { clear allocated flag } + TEST EAX,EAX { clear zero flag } + POP ECX +end; + +procedure _ObjCopy; +asm +{ PROCEDURE _ObjCopy( dest, src: ^OBJECT; vmtPtrOff: Longint); } +{ ->EAX Pointer to destination } +{ EDX Pointer to source } +{ ECX Offset of vmt in those objects. } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EDX + MOV EDI,EAX + + LEA EAX,[EDI+ECX] { remember pointer to dest vmt pointer } + MOV EDX,[EAX] { fetch dest vmt pointer } + + MOV EBX,[EDX].ovtInstanceSize + + MOV ECX,EBX { copy size DIV 4 dwords } + SHR ECX,2 + REP MOVSD + + MOV ECX,EBX { copy size MOD 4 bytes } + AND ECX,3 + REP MOVSB + + MOV [EAX],EDX { restore dest vmt } + + POP EDI + POP ESI + POP EBX +end; + +procedure _Fail; +asm +{ FUNCTION _Fail( self: ^OBJECT; allocFlag:Longint): ^OBJECT; } +{ ->EAX Pointer to self (possibly nil) } +{ EDX <> 0: Object must be deallocated } +{ <-EAX Nil } + + TEST EDX,EDX + JE @@exit { if no object was allocated, return } + CALL _FreeMem +@@exit: + XOR EAX,EAX +end; + +{$IFDEF MSWINDOWS} +function GetKeyboardType(nTypeFlag: Integer): Integer; stdcall; + external user name 'GetKeyboardType'; + +function _isNECWindows: Boolean; +var + KbSubType: Integer; +begin + Result := False; + if GetKeyboardType(0) = $7 then + begin + KbSubType := GetKeyboardType(1) and $FF00; + if (KbSubType = $0D00) or (KbSubType = $0400) then + Result := True; + end; +end; + +const + HKEY_LOCAL_MACHINE = $80000002; + +// workaround a Japanese Win95 bug +procedure _FpuMaskInit; +const + KEY_QUERY_VALUE = $00000001; + REG_DWORD = 4; + FPUMASKKEY = 'SOFTWARE\Borland\Delphi\RTL'; + FPUMASKNAME = 'FPUMaskValue'; +var + phkResult: LongWord; + lpData, DataSize: Longint; +begin + lpData := Default8087CW; + + if RegOpenKeyEx(HKEY_LOCAL_MACHINE, FPUMASKKEY, 0, KEY_QUERY_VALUE, phkResult) = 0 then + try + DataSize := Sizeof(lpData); + RegQueryValueEx(phkResult, FPUMASKNAME, nil, nil, @lpData, @DataSize); + finally + RegCloseKey(phkResult); + end; + Default8087CW := (Default8087CW and $ffc0) or (lpData and $3f); +end; +{$ENDIF} + +procedure _FpuInit; +asm + FNINIT + FWAIT +{$IFDEF PIC} + CALL GetGOT + MOV EAX,[EAX].OFFSET Default8087CW + FLDCW [EAX] +{$ELSE} + FLDCW Default8087CW +{$ENDIF} +end; + +procedure FpuInit; +//const cwDefault: Word = $1332 { $133F}; +asm + JMP _FpuInit +end; + +procedure FpuInitConsiderNECWindows; +begin + if _isNECWindows then _FpuMaskInit; + FpuInit(); +end; + +procedure _BoundErr; +asm + MOV AL,reRangeError + JMP Error +end; + +procedure _IntOver; +asm + MOV AL,reIntOverflow + JMP Error +end; + +function TObject.ClassType: TClass; +begin + Pointer(Result) := PPointer(Self)^; +end; + +class function TObject.ClassName: ShortString; +{$IFDEF PUREPASCAL} +begin + Result := PShortString(PPointer(Integer(Self) + vmtClassName)^)^; +end; +{$ELSE} +asm + { -> EAX VMT } + { EDX Pointer to result string } + PUSH ESI + PUSH EDI + MOV EDI,EDX + MOV ESI,[EAX].vmtClassName + XOR ECX,ECX + MOV CL,[ESI] + INC ECX + REP MOVSB + POP EDI + POP ESI +end; +{$ENDIF} + +class function TObject.ClassNameIs(const Name: string): Boolean; +{$IFDEF PUREPASCAL} +var + Temp: ShortString; + I: Byte; +begin + Result := False; + Temp := ClassName; + for I := 0 to Byte(Temp[0]) do + if Temp[I] <> Name[I] then Exit; + Result := True; +end; +{$ELSE} +asm + PUSH EBX + XOR EBX,EBX + OR EDX,EDX + JE @@exit + MOV EAX,[EAX].vmtClassName + XOR ECX,ECX + MOV CL,[EAX] + CMP ECX,[EDX-4] + JNE @@exit + DEC EDX +@@loop: + MOV BH,[EAX+ECX] + XOR BH,[EDX+ECX] + AND BH,0DFH + JNE @@exit + DEC ECX + JNE @@loop + INC EBX +@@exit: + MOV AL,BL + POP EBX +end; +{$ENDIF} + +class function TObject.ClassParent: TClass; +{$IFDEF PUREPASCAL} +begin + Pointer(Result) := PPointer(Integer(Self) + vmtParent)^; + if Result <> nil then + Pointer(Result) := PPointer(Result)^; +end; +{$ELSE} +asm + MOV EAX,[EAX].vmtParent + TEST EAX,EAX + JE @@exit + MOV EAX,[EAX] +@@exit: +end; +{$ENDIF} + +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; +begin +end; + +destructor TObject.Destroy; +begin +end; + +procedure TObject.Free; +begin + if Self <> nil then + Destroy; +end; + +class function TObject.InitInstance(Instance: Pointer): TObject; +{$IFDEF PUREPASCAL} +var + IntfTable: PInterfaceTable; + ClassPtr: TClass; + I: Integer; +begin + FillChar(Instance^, InstanceSize, 0); + PInteger(Instance)^ := Integer(Self); + ClassPtr := Self; + while ClassPtr <> nil do + begin + IntfTable := ClassPtr.GetInterfaceTable; + if IntfTable <> nil then + for I := 0 to IntfTable.EntryCount-1 do + with IntfTable.Entries[I] do + begin + if VTable <> nil then + PInteger(@PChar(Instance)[IOffset])^ := Integer(VTable); + end; + ClassPtr := ClassPtr.ClassParent; + end; + Result := Instance; +end; +{$ELSE} +asm + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV EDI,EDX + STOSD + MOV ECX,[EBX].vmtInstanceSize + XOR EAX,EAX + PUSH ECX + SHR ECX,2 + DEC ECX + REP STOSD + POP ECX + AND ECX,3 + REP STOSB + MOV EAX,EDX + MOV EDX,ESP +@@0: MOV ECX,[EBX].vmtIntfTable + TEST ECX,ECX + JE @@1 + PUSH ECX +@@1: MOV EBX,[EBX].vmtParent + TEST EBX,EBX + JE @@2 + MOV EBX,[EBX] + JMP @@0 +@@2: CMP ESP,EDX + JE @@5 +@@3: POP EBX + MOV ECX,[EBX].TInterfaceTable.EntryCount + ADD EBX,4 +@@4: MOV ESI,[EBX].TInterfaceEntry.VTable + TEST ESI,ESI + JE @@4a + MOV EDI,[EBX].TInterfaceEntry.IOffset + MOV [EAX+EDI],ESI +@@4a: ADD EBX,TYPE TInterfaceEntry + DEC ECX + JNE @@4 + CMP ESP,EDX + JNE @@3 +@@5: POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +procedure TObject.CleanupInstance; +{$IFDEF PUREPASCAL} +var + ClassPtr: TClass; + InitTable: Pointer; +begin + ClassPtr := ClassType; + InitTable := PPointer(Integer(ClassPtr) + vmtInitTable)^; + while (ClassPtr <> nil) and (InitTable <> nil) do + begin + _FinalizeRecord(Self, InitTable); + ClassPtr := ClassPtr.ClassParent; + if ClassPtr <> nil then + InitTable := PPointer(Integer(ClassPtr) + vmtInitTable)^; + end; +end; +{$ELSE} +asm + PUSH EBX + PUSH ESI + MOV EBX,EAX + MOV ESI,EAX +@@loop: + MOV ESI,[ESI] + MOV EDX,[ESI].vmtInitTable + MOV ESI,[ESI].vmtParent + TEST EDX,EDX + JE @@skip + CALL _FinalizeRecord + MOV EAX,EBX +@@skip: + TEST ESI,ESI + JNE @@loop + + POP ESI + POP EBX +end; +{$ENDIF} + +function InvokeImplGetter(Self: TObject; ImplGetter: Cardinal): IInterface; +{$IFDEF PUREPASCAL} +var + M: function: IInterface of object; +begin + TMethod(M).Data := Self; + case ImplGetter of + $FF000000..$FFFFFFFF: // Field + Result := IInterface(Pointer(Cardinal(Self) + (ImplGetter and $00FFFFFF))); + $FE000000..$FEFFFFFF: // virtual method + begin + // sign extend vmt slot offset = smallint cast + TMethod(M).Code := PPointer(Integer(Self) + SmallInt(ImplGetter))^; + Result := M; + end; + else // static method + TMethod(M).Code := Pointer(ImplGetter); + Result := M; + end; +end; +{$ELSE} +asm + XCHG EDX,ECX + CMP ECX,$FF000000 + JAE @@isField + CMP ECX,$FE000000 + JB @@isStaticMethod + + { the GetProc is a virtual method } + MOVSX ECX,CX { sign extend slot offs } + ADD ECX,[EAX] { vmt + slotoffs } + JMP dword ptr [ECX] { call vmt[slot] } + +@@isStaticMethod: + JMP ECX + +@@isField: + AND ECX,$00FFFFFF + ADD ECX,EAX + MOV EAX,EDX + MOV EDX,[ECX] + JMP _IntfCopy +end; +{$ENDIF} + +function TObject.GetInterface(const IID: TGUID; out Obj): Boolean; +var + InterfaceEntry: PInterfaceEntry; +begin + Pointer(Obj) := nil; + InterfaceEntry := GetInterfaceEntry(IID); + if InterfaceEntry <> nil then + begin + if InterfaceEntry^.IOffset <> 0 then + begin + Pointer(Obj) := Pointer(Integer(Self) + InterfaceEntry^.IOffset); + if Pointer(Obj) <> nil then IInterface(Obj)._AddRef; + end + else + IInterface(Obj) := InvokeImplGetter(Self, InterfaceEntry^.ImplGetter); + end; + Result := Pointer(Obj) <> nil; +end; + +class function TObject.GetInterfaceEntry(const IID: TGUID): PInterfaceEntry; +{$IFDEF PUREPASCAL} +var + ClassPtr: TClass; + IntfTable: PInterfaceTable; + I: Integer; +begin + ClassPtr := Self; + while ClassPtr <> nil do + begin + IntfTable := ClassPtr.GetInterfaceTable; + if IntfTable <> nil then + for I := 0 to IntfTable.EntryCount-1 do + begin + Result := @IntfTable.Entries[I]; +// if Result^.IID = IID then Exit; + if (Int64(Result^.IID.D1) = Int64(IID.D1)) and + (Int64(Result^.IID.D4) = Int64(IID.D4)) then Exit; + end; + ClassPtr := ClassPtr.ClassParent; + end; + Result := nil; +end; +{$ELSE} +asm + PUSH EBX + PUSH ESI + MOV EBX,EAX +@@1: MOV EAX,[EBX].vmtIntfTable + TEST EAX,EAX + JE @@4 + MOV ECX,[EAX].TInterfaceTable.EntryCount + ADD EAX,4 +@@2: MOV ESI,[EDX].Integer[0] + CMP ESI,[EAX].TInterfaceEntry.IID.Integer[0] + JNE @@3 + MOV ESI,[EDX].Integer[4] + CMP ESI,[EAX].TInterfaceEntry.IID.Integer[4] + JNE @@3 + MOV ESI,[EDX].Integer[8] + CMP ESI,[EAX].TInterfaceEntry.IID.Integer[8] + JNE @@3 + MOV ESI,[EDX].Integer[12] + CMP ESI,[EAX].TInterfaceEntry.IID.Integer[12] + JE @@5 +@@3: ADD EAX,type TInterfaceEntry + DEC ECX + JNE @@2 +@@4: MOV EBX,[EBX].vmtParent + TEST EBX,EBX + JE @@4a + MOV EBX,[EBX] + JMP @@1 +@@4a: XOR EAX,EAX +@@5: POP ESI + POP EBX +end; +{$ENDIF} + +class function TObject.GetInterfaceTable: PInterfaceTable; +begin + Result := PPointer(Integer(Self) + vmtIntfTable)^; +end; + +function _IsClass(Child: TObject; Parent: TClass): Boolean; +begin + Result := (Child <> nil) and Child.InheritsFrom(Parent); +end; + +function _AsClass(Child: TObject; Parent: TClass): TObject; +{$IFDEF PUREPASCAL} +begin + Result := Child; + if not (Child is Parent) then + Error(reInvalidCast); // loses return address +end; +{$ELSE} +asm + { -> EAX left operand (class) } + { EDX VMT of right operand } + { <- EAX if left is derived from right, else runtime error } + TEST EAX,EAX + JE @@exit + MOV ECX,EAX +@@loop: + MOV ECX,[ECX] + CMP ECX,EDX + JE @@exit + MOV ECX,[ECX].vmtParent + TEST ECX,ECX + JNE @@loop + + { do runtime error } + MOV AL,reInvalidCast + JMP Error + +@@exit: +end; +{$ENDIF} + + +procedure GetDynaMethod; +{ function GetDynaMethod(vmt: TClass; selector: Smallint) : Pointer; } +asm + { -> EAX vmt of class } + { SI dynamic method index } + { <- ESI pointer to routine } + { ZF = 0 if found } + { trashes: EAX, ECX } + + PUSH EDI + XCHG EAX,ESI + JMP @@haveVMT +@@outerLoop: + MOV ESI,[ESI] +@@haveVMT: + MOV EDI,[ESI].vmtDynamicTable + TEST EDI,EDI + JE @@parent + MOVZX ECX,word ptr [EDI] + PUSH ECX + ADD EDI,2 + REPNE SCASW + JE @@found + POP ECX +@@parent: + MOV ESI,[ESI].vmtParent + TEST ESI,ESI + JNE @@outerLoop + JMP @@exit + +@@found: + POP EAX + ADD EAX,EAX + SUB EAX,ECX { this will always clear the Z-flag ! } + MOV ESI,[EDI+EAX*2-4] + +@@exit: + POP EDI +end; + +procedure _CallDynaInst; +asm + PUSH EAX + PUSH ECX + MOV EAX,[EAX] + CALL GetDynaMethod + POP ECX + POP EAX + JE @@Abstract + JMP ESI +@@Abstract: + POP ECX + JMP _AbstractError +end; + + +procedure _CallDynaClass; +asm + PUSH EAX + PUSH ECX + CALL GetDynaMethod + POP ECX + POP EAX + JE @@Abstract + JMP ESI +@@Abstract: + POP ECX + JMP _AbstractError +end; + + +procedure _FindDynaInst; +asm + PUSH ESI + MOV ESI,EDX + MOV EAX,[EAX] + CALL GetDynaMethod + MOV EAX,ESI + POP ESI + JNE @@exit + POP ECX + JMP _AbstractError +@@exit: +end; + + +procedure _FindDynaClass; +asm + PUSH ESI + MOV ESI,EDX + CALL GetDynaMethod + MOV EAX,ESI + POP ESI + JNE @@exit + POP ECX + JMP _AbstractError +@@exit: +end; + +class function TObject.InheritsFrom(AClass: TClass): Boolean; +{$IFDEF PUREPASCAL} +var + ClassPtr: TClass; +begin + ClassPtr := Self; + while (ClassPtr <> nil) and (ClassPtr <> AClass) do + ClassPtr := PPointer(Integer(ClassPtr) + vmtParent)^; + Result := ClassPtr = AClass; +end; +{$ELSE} +asm + { -> EAX Pointer to our class } + { EDX Pointer to AClass } + { <- AL Boolean result } + JMP @@haveVMT +@@loop: + MOV EAX,[EAX] +@@haveVMT: + CMP EAX,EDX + JE @@success + MOV EAX,[EAX].vmtParent + TEST EAX,EAX + JNE @@loop + JMP @@exit +@@success: + MOV AL,1 +@@exit: +end; +{$ENDIF} + + +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); +begin +end; + + +procedure TObject.AfterConstruction; +begin +end; + +procedure TObject.BeforeDestruction; +begin +end; + +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].vmtDefaultHandler +end; + + +class function TObject.MethodAddress(const Name: ShortString): Pointer; +asm + { -> EAX Pointer to class } + { EDX Pointer to name } + PUSH EBX + PUSH ESI + PUSH EDI + XOR ECX,ECX + XOR EDI,EDI + MOV BL,[EDX] + JMP @@haveVMT +@@outer: { upper 16 bits of ECX are 0 ! } + MOV EAX,[EAX] +@@haveVMT: + MOV ESI,[EAX].vmtMethodTable + TEST ESI,ESI + JE @@parent + MOV DI,[ESI] { EDI := method count } + ADD ESI,2 +@@inner: { upper 16 bits of ECX are 0 ! } + MOV CL,[ESI+6] { compare length of strings } + CMP CL,BL + JE @@cmpChar +@@cont: { upper 16 bits of ECX are 0 ! } + MOV CX,[ESI] { fetch length of method desc } + ADD ESI,ECX { point ESI to next method } + DEC EDI + JNZ @@inner +@@parent: + MOV EAX,[EAX].vmtParent { fetch parent vmt } + TEST EAX,EAX + JNE @@outer + JMP @@exit { return NIL } + +@@notEqual: + MOV BL,[EDX] { restore BL to length of name } + JMP @@cont + +@@cmpChar: { upper 16 bits of ECX are 0 ! } + MOV CH,0 { upper 24 bits of ECX are 0 ! } +@@cmpCharLoop: + MOV BL,[ESI+ECX+6] { case insensitive string cmp } + XOR BL,[EDX+ECX+0] { last char is compared first } + AND BL,$DF + JNE @@notEqual + DEC ECX { ECX serves as counter } + JNZ @@cmpCharLoop + + { found it } + MOV EAX,[ESI+2] + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +class function TObject.MethodName(Address: Pointer): ShortString; +asm + { -> EAX Pointer to class } + { EDX Address } + { ECX Pointer to result } + PUSH EBX + PUSH ESI + PUSH EDI + MOV EDI,ECX + XOR EBX,EBX + XOR ECX,ECX + JMP @@haveVMT +@@outer: + MOV EAX,[EAX] +@@haveVMT: + MOV ESI,[EAX].vmtMethodTable { fetch pointer to method table } + TEST ESI,ESI + JE @@parent + MOV CX,[ESI] + ADD ESI,2 +@@inner: + CMP EDX,[ESI+2] + JE @@found + MOV BX,[ESI] + ADD ESI,EBX + DEC ECX + JNZ @@inner +@@parent: + MOV EAX,[EAX].vmtParent + TEST EAX,EAX + JNE @@outer + MOV [EDI],AL + JMP @@exit + +@@found: + ADD ESI,6 + XOR ECX,ECX + MOV CL,[ESI] + INC ECX + REP MOVSB + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +function TObject.FieldAddress(const Name: ShortString): Pointer; +asm + { -> EAX Pointer to instance } + { EDX Pointer to name } + PUSH EBX + PUSH ESI + PUSH EDI + XOR ECX,ECX + XOR EDI,EDI + MOV BL,[EDX] + + PUSH EAX { save instance pointer } + +@@outer: + MOV EAX,[EAX] { fetch class pointer } + MOV ESI,[EAX].vmtFieldTable + TEST ESI,ESI + JE @@parent + MOV DI,[ESI] { fetch count of fields } + ADD ESI,6 +@@inner: + MOV CL,[ESI+6] { compare string lengths } + CMP CL,BL + JE @@cmpChar +@@cont: + LEA ESI,[ESI+ECX+7] { point ESI to next field } + DEC EDI + JNZ @@inner +@@parent: + MOV EAX,[EAX].vmtParent { fetch parent VMT } + TEST EAX,EAX + JNE @@outer + POP EDX { forget instance, return Nil } + JMP @@exit + +@@notEqual: + MOV BL,[EDX] { restore BL to length of name } + MOV CL,[ESI+6] { ECX := length of field name } + JMP @@cont + +@@cmpChar: + MOV BL,[ESI+ECX+6] { case insensitive string cmp } + XOR BL,[EDX+ECX+0] { starting with last char } + AND BL,$DF + JNE @@notEqual + DEC ECX { ECX serves as counter } + JNZ @@cmpChar + + { found it } + MOV EAX,[ESI] { result is field offset plus ... } + POP EDX + ADD EAX,EDX { instance pointer } + +@@exit: + POP EDI + POP ESI + POP EBX +end; + +function _ClassCreate(AClass: TClass; Alloc: Boolean): TObject; +asm + { -> EAX = pointer to VMT } + { <- EAX = pointer to instance } + PUSH EDX + PUSH ECX + PUSH EBX + TEST DL,DL + JL @@noAlloc + CALL dword ptr [EAX].vmtNewInstance +@@noAlloc: +{$IFNDEF PC_MAPPED_EXCEPTIONS} + XOR EDX,EDX + LEA ECX,[ESP+16] + MOV EBX,FS:[EDX] + MOV [ECX].TExcFrame.next,EBX + MOV [ECX].TExcFrame.hEBP,EBP + MOV [ECX].TExcFrame.desc,offset @desc + MOV [ECX].TexcFrame.ConstructedObject,EAX { trick: remember copy to instance } + MOV FS:[EDX],ECX +{$ENDIF} + POP EBX + POP ECX + POP EDX + RET + +{$IFNDEF PC_MAPPED_EXCEPTIONS} +@desc: + JMP _HandleAnyException + + { destroy the object } + + MOV EAX,[ESP+8+9*4] + MOV EAX,[EAX].TExcFrame.ConstructedObject + TEST EAX,EAX + JE @@skip + MOV ECX,[EAX] + MOV DL,$81 + PUSH EAX + CALL dword ptr [ECX].vmtDestroy + POP EAX + CALL _ClassDestroy +@@skip: + { reraise the exception } + CALL _RaiseAgain +{$ENDIF} +end; + +procedure _ClassDestroy(Instance: TObject); +begin + Instance.FreeInstance; +end; + + +function _AfterConstruction(Instance: TObject): TObject; +begin + Instance.AfterConstruction; + Result := Instance; +end; + +function _BeforeDestruction(Instance: TObject; OuterMost: ShortInt): TObject; +// Must preserve DL on return! +{$IFDEF PUREPASCAL} +begin + Result := Instance; + if OuterMost > 0 then Exit; + Instance.BeforeDestruction; +end; +{$ELSE} +asm + { -> EAX = pointer to instance } + { DL = dealloc flag } + + TEST DL,DL + JG @@outerMost + RET +@@outerMost: + PUSH EAX + PUSH EDX + MOV EDX,[EAX] + CALL dword ptr [EDX].vmtBeforeDestruction + POP EDX + POP EAX +end; +{$ENDIF} + +{ + 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_CONTINE so that normal processing will occur. +} + +{$IFDEF LINUX} +const + excRaise = 0; { an exception is being raised by the user (could be a reraise) } + excCatch = 1; { an exception is about to be caught } + excFinally = 2; { a finally block is about to be executed because of an exception } + excUnhandled = 3; { no user exception handler was found (the app will die) } + +procedure _DbgExcNotify( + NotificationKind: Integer; + ExceptionObject: Pointer; + ExceptionName: PShortString; + ExceptionLocation: Pointer; + HandlerAddr: Pointer); cdecl; export; +begin +{$IFDEF DEBUG} + { + This code is just for debugging the exception handling system. The debugger + needs _DbgExcNotify, however to place breakpoints in, so the function itself + cannot be removed. + } + asm + PUSH EAX + PUSH EDX + end; + if Assigned(ExcNotificationProc) then + ExcNotificationProc(NotificationKind, ExceptionObject, ExceptionName, ExceptionLocation, HandlerAddr); + asm + POP EDX + POP EAX + end; +{$ENDIF} +end; + +{ + The following functions are used by the debugger for the evaluator. If you + change them IN ANY WAY, the debugger will cease to function correctly. +} +procedure _DbgEvalMarker; +begin +end; + +procedure _DbgEvalExcept(E: TObject); +begin +end; + +procedure _DbgEvalEnd; +begin +end; + +{ + This function is used by the debugger to provide a soft landing spot + when evaluating a function call that may raise an unhandled exception. + The return address of _DbgEvalMarker is pushed onto the stack so that + the unwinder will transfer control to the except block. +} +procedure _DbgEvalFrame; +begin + try + _DbgEvalMarker; + except on E: TObject do + _DbgEvalExcept(E); + end; + _DbgEvalEnd; +end; + +{ + These export names need to match the names that will be generated into + the .symtab section, so that the debugger can find them if stabs + debug information is being generated. +} +exports + _DbgExcNotify name '@DbgExcNotify', + _DbgEvalFrame name '@DbgEvalFrame', + _DbgEvalMarker name '@DbgEvalMarker', + _DbgEvalExcept name '@DbgEvalExcept', + _DbgEvalEnd name '@DbgEvalEnd'; +{$ENDIF} + +{ tell the debugger that the next raise is a re-raise of the current non-Delphi + exception } +procedure NotifyReRaise; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX location of exception } + PUSH 0 { handler addr } + PUSH EDX { location of exception } + MOV ECX, [EAX] + PUSH [ECX].vmtClassName { exception name } + PUSH EAX { exception object } + PUSH excRaise { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 +{$ELSE} + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH 0 + PUSH 0 + PUSH cContinuable + PUSH cDelphiReRaise + CALL RaiseExceptionProc +@@1: +{$ENDIF} +end; + +{ tell the debugger about the raise of a non-Delphi exception } +{$IFNDEF LINUX} +procedure NotifyNonDelphiException; +asm + CMP BYTE PTR DebugHook,0 + JE @@1 + PUSH EAX + PUSH EAX + PUSH EDX + PUSH ESP + PUSH 2 + PUSH cContinuable + PUSH cNonDelphiException + CALL RaiseExceptionProc + ADD ESP,8 + POP EAX +@@1: +end; +{$ENDIF} + +{ Tell the debugger where the handler for the current exception is located } +procedure NotifyExcept; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX handler addr } + PUSH EAX + MOV EAX, [EAX].TRaisedException.ExceptObject + + PUSH EDX { handler addr } + PUSH 0 { location of exception } + MOV ECX, [EAX] + PUSH [ECX].vmtClassName { exception name } + PUSH EAX { exception object } + PUSH excCatch { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 + + POP EAX +{$ELSE} + PUSH ESP + PUSH 1 + PUSH cContinuable + PUSH cDelphiExcept { our magic exception code } + CALL RaiseExceptionProc + ADD ESP,4 + POP EAX +{$ENDIF} +end; + +procedure NotifyOnExcept; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX handler addr } + PUSH EDX { handler addr } + PUSH 0 { location of exception } + MOV ECX, [EAX] + PUSH [ECX].vmtClassName { exception name } + PUSH EAX { exception object } + PUSH excCatch { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 +{$ELSE} + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH EAX + PUSH [EBX].TExcDescEntry.handler + JMP NotifyExcept +@@1: +{$ENDIF} +end; + +{$IFNDEF LINUX} +procedure NotifyAnyExcept; +asm + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH EAX + PUSH EBX + JMP NotifyExcept +@@1: +end; + +procedure CheckJmp; +asm + TEST ECX,ECX + JE @@3 + MOV EAX,[ECX + 1] + CMP BYTE PTR [ECX],0E9H { near jmp } + JE @@1 + CMP BYTE PTR [ECX],0EBH { short jmp } + JNE @@3 + MOVSX EAX,AL + INC ECX + INC ECX + JMP @@2 +@@1: + ADD ECX,5 +@@2: + ADD ECX,EAX +@@3: +end; +{$ENDIF} { not LINUX } + +{ Notify debugger of a finally during an exception unwind } +procedure NotifyExceptFinally; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX handler addr } + PUSH EDX { handler addr } + PUSH 0 { location of exception } + PUSH 0 { exception name } + PUSH 0 { exception object } + PUSH excFinally { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 +{$ELSE} + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH EAX + PUSH EDX + PUSH ECX + CALL CheckJmp + PUSH ECX + PUSH ESP { pass pointer to arguments } + PUSH 1 { there is 1 argument } + PUSH cContinuable { continuable execution } + PUSH cDelphiFinally { our magic exception code } + CALL RaiseExceptionProc + POP ECX + POP ECX + POP EDX + POP EAX +@@1: +{$ENDIF} +end; + + +{ Tell the debugger that the current exception is handled and cleaned up. + Also indicate where execution is about to resume. } +{$IFNDEF LINUX} +procedure NotifyTerminate; +asm + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH EDX + PUSH ESP + PUSH 1 + PUSH cContinuable + PUSH cDelphiTerminate { our magic exception code } + CALL RaiseExceptionProc + POP EDX +@@1: +end; +{$ENDIF} + +{ 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; +asm +{$IFDEF LINUX} +{ ->EAX Pointer to exception object } +{ EDX location of exception } + PUSH EAX + MOV EAX, [EAX].TRaisedException.ExceptObject + + PUSH 0 { handler addr } + PUSH EDX { location of exception } + MOV ECX, [EAX] + PUSH [ECX].vmtClassName { exception name } + PUSH EAX { exception object } + PUSH excUnhandled { notification kind } + CALL _DbgExcNotify + ADD ESP, 20 + + POP EAX +{$ELSE} + PUSH EAX + PUSH EDX + CMP BYTE PTR DebugHook,1 + JBE @@1 + PUSH ESP + PUSH 2 + PUSH cContinuable + PUSH cDelphiUnhandled + CALL RaiseExceptionProc +@@1: + POP EDX + POP EAX +{$ENDIF} +end; + +procedure _HandleAnyException; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + CALL UnblockOSExceptions + OR [EAX].TRaisedException.Flags, excIsBeingHandled + MOV ESI, EBX + MOV EDX, [ESP] + CALL NotifyExcept + MOV EBX, ESI +{$ENDIF} +{$IFNDEF PC_MAPPED_EXCEPTIONS} + { -> [ESP+ 4] excPtr: PExceptionRecord } + { [ESP+ 8] errPtr: PExcFrame } + { [ESP+12] ctxPtr: Pointer } + { [ESP+16] dspPtr: Pointer } + { <- EAX return value - always one } + + MOV EAX,[ESP+4] + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JNE @@exit + + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + MOV EDX,[EAX].TExceptionRecord.ExceptObject + MOV ECX,[EAX].TExceptionRecord.ExceptAddr + JE @@DelphiException + CLD + CALL _FpuInit + MOV EDX,ExceptObjProc + TEST EDX,EDX + JE @@exit + CALL EDX + TEST EAX,EAX + JE @@exit + MOV EDX,[ESP+12] + MOV ECX,[ESP+4] + CMP [ECX].TExceptionRecord.ExceptionCode,cCppException + JE @@CppException + CALL NotifyNonDelphiException +{$IFDEF MSWINDOWS} + CMP BYTE PTR JITEnable,0 + JBE @@CppException + CMP BYTE PTR DebugHook,0 + JA @@CppException // Do not JIT if debugging + LEA ECX,[ESP+4] + PUSH EAX + PUSH ECX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + POP EAX + JE @@exit + MOV EDX,EAX + MOV EAX,[ESP+4] + MOV ECX,[EAX].TExceptionRecord.ExceptionAddress + JMP @@GoUnwind +{$ENDIF} +@@CppException: + MOV EDX,EAX + MOV EAX,[ESP+4] + MOV ECX,[EAX].TExceptionRecord.ExceptionAddress + +@@DelphiException: +{$IFDEF MSWINDOWS} + CMP BYTE PTR JITEnable,1 + JBE @@GoUnwind + CMP BYTE PTR DebugHook,0 { Do not JIT if debugging } + JA @@GoUnwind + PUSH EAX + LEA EAX,[ESP+8] + PUSH EDX + PUSH ECX + PUSH EAX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + POP ECX + POP EDX + POP EAX + JE @@exit +{$ENDIF} + +@@GoUnwind: + OR [EAX].TExceptionRecord.ExceptionFlags,cUnwinding + + PUSH EBX + XOR EBX,EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBX,FS:[EBX] + PUSH EBX { Save pointer to topmost frame } + PUSH EAX { Save OS exception pointer } + PUSH EDX { Save exception object } + PUSH ECX { Save exception address } + + MOV EDX,[ESP+8+8*4] + + PUSH 0 + PUSH EAX + PUSH offset @@returnAddress + PUSH EDX + CALL RtlUnwindProc +@@returnAddress: + + MOV EDI,[ESP+8+8*4] + + { Make the RaiseList entry on the stack } + + CALL SysInit.@GetTLS + PUSH [EAX].RaiseListPtr + MOV [EAX].RaiseListPtr,ESP + + MOV EBP,[EDI].TExcFrame.hEBP + MOV EBX,[EDI].TExcFrame.desc + MOV [EDI].TExcFrame.desc,offset @@exceptFinally + + ADD EBX,TExcDesc.instructions + CALL NotifyAnyExcept + JMP EBX + +@@exceptFinally: + JMP _HandleFinally + +@@destroyExcept: + { we come here if an exception handler has thrown yet another exception } + { we need to destroy the exception object and pop the raise list. } + + CALL SysInit.@GetTLS + MOV ECX,[EAX].RaiseListPtr + MOV EDX,[ECX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,EDX + + MOV EAX,[ECX].TRaiseFrame.ExceptObject + JMP TObject.Free + +@@exit: + MOV EAX,1 +{$ENDIF} { not PC_MAPPED_EXCEPTIONS } +end; + +{$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; +asm + { -> EAX raised object: Pointer } + { EDX descriptor table: ^TExcDesc } + { EBX GOT of user code, or 0 if not an SO } + { <- EAX matching descriptor: ^TExcDescEntry } + PUSH EBP + MOV EBP, ESP + SUB ESP, 8 { Room for vtable temp, and adjustor } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV [EBP - 8], EBX { Store the potential GOT } + MOV EAX, [EAX] { load vtable of exception object } + MOV EBX,[EDX].TExcDesc.cnt + LEA ESI,[EDX].TExcDesc.excTab { point ECX to exc descriptor table } + MOV [EBP - 4], EAX { temp for vtable of exception object } + +@@innerLoop: + MOV EAX,[ESI].TExcDescEntry.vTable + TEST EAX,EAX { catch all clause? } + JE @@found { yes: This is the handler } + ADD EAX, [EBP - 8] { add in the adjustor (could be 0) } + MOV EDI,[EBP - 4] { load vtable of exception object } + JMP @@haveVMT + +@@vtLoop: + MOV EDI,[EDI] +@@haveVMT: + MOV EAX,[EAX] + CMP EAX,EDI + JE @@found + + MOV ECX,[EAX].vmtInstanceSize + CMP ECX,[EDI].vmtInstanceSize + JNE @@parent + + MOV EAX,[EAX].vmtClassName + MOV EDX,[EDI].vmtClassName + + XOR ECX,ECX + MOV CL,[EAX] + CMP CL,[EDX] + JNE @@parent + + INC EAX + INC EDX + CALL _AStrCmp + JE @@found + +@@parent: + MOV EDI,[EDI].vmtParent { load vtable of parent } + MOV EAX,[ESI].TExcDescEntry.vTable + ADD EAX, [EBP - 8] { add in the adjustor (could be 0) } + TEST EDI,EDI + JNE @@vtLoop + + ADD ESI,8 + DEC EBX + JNZ @@innerLoop + + { Didn't find a handler. } + XOR ESI, ESI + +@@found: + MOV EAX, ESI +@@done: + POP EDI + POP ESI + POP EBX + MOV ESP, EBP + POP EBP +end; +{$ENDIF} + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _HandleOnExceptionPIC; +asm + { -> EAX obj : Exception object } + { [RA] desc: ^TExcDesc } + { <- Doesn't return } + + // Mark the exception as being handled + OR [EAX].TRaisedException.Flags, excIsBeingHandled + + MOV ESI, EBX // Save the GOT + MOV EDX, [ESP] // Get the addr of the TExcDesc + PUSH EAX // Save the object + MOV EAX, [EAX].TRaisedException.ExceptObject + CALL FindOnExceptionDescEntry + OR EAX, EAX + JE @@NotForMe + + MOV EBX, ESI // Set back to user's GOT + MOV EDX, EAX + POP EAX // Get the object back + POP ECX // Ditch the return addr + + // Get the Pascal object itself. + MOV EAX, [EAX].TRaisedException.ExceptObject + + MOV EDX, [EDX].TExcDescEntry.handler + ADD EDX, EBX // adjust for GOT + CALL NotifyOnExcept + + MOV EBX, ESI // Make sure of user's GOT + JMP EDX // Back to the user code + // never returns +@@NotForMe: + POP EAX // Get the exception object + + // Mark that we're reraising this exception, so that the + // compiler generated exception handler for the 'except on' clause + // will not get confused + OR [EAX].TRaisedException.Flags, excIsBeingReRaised + + JMP SysRaiseException // Should be using resume here +end; +{$ENDIF} + +procedure _HandleOnException; +{$IFDEF PC_MAPPED_EXCEPTIONS} +asm + { -> EAX obj : Exception object } + { [RA] desc: ^TExcDesc } + { <- Doesn't return } + + // Mark the exception as being handled + OR [EAX].TRaisedException.Flags, excIsBeingHandled + + MOV EDX, [ESP] // Get the addr of the TExcDesc + PUSH EAX // Save the object + PUSH EBX // Save EBX + XOR EBX, EBX // No GOT + MOV EAX, [EAX].TRaisedException.ExceptObject + CALL FindOnExceptionDescEntry + POP EBX // Restore EBX + OR EAX, EAX // Is the exception for me? + JE @@NotForMe + + MOV EDX, EAX + POP EAX // Get the object back + POP ECX // Ditch the return addr + + // Get the Pascal object itself. + MOV EAX, [EAX].TRaisedException.ExceptObject + + MOV EDX, [EDX].TExcDescEntry.handler + CALL NotifyOnExcept // Tell the debugger about it + + JMP EDX // Back to the user code + // never returns +@@NotForMe: + POP EAX // Get the exception object + + // Mark that we're reraising this exception, so that the + // compiler generated exception handler for the 'except on' clause + // will not get confused + OR [EAX].TRaisedException.Flags, excIsBeingReRaised + JMP SysRaiseException // Should be using resume here +end; +{$ENDIF} +{$IFNDEF PC_MAPPED_EXCEPTIONS} +asm + { -> [ESP+ 4] excPtr: PExceptionRecord } + { [ESP+ 8] errPtr: PExcFrame } + { [ESP+12] ctxPtr: Pointer } + { [ESP+16] dspPtr: Pointer } + { <- EAX return value - always one } + + MOV EAX,[ESP+4] + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JNE @@exit + + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + JE @@DelphiException + CLD + CALL _FpuInit + MOV EDX,ExceptClsProc + TEST EDX,EDX + JE @@exit + CALL EDX + TEST EAX,EAX + JNE @@common + JMP @@exit + +@@DelphiException: + MOV EAX,[EAX].TExceptionRecord.ExceptObject + MOV EAX,[EAX] { load vtable of exception object } + +@@common: + + MOV EDX,[ESP+8] + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV ECX,[EDX].TExcFrame.desc + MOV EBX,[ECX].TExcDesc.cnt + LEA ESI,[ECX].TExcDesc.excTab { point ECX to exc descriptor table } + MOV EBP,EAX { load vtable of exception object } + +@@innerLoop: + MOV EAX,[ESI].TExcDescEntry.vTable + TEST EAX,EAX { catch all clause? } + JE @@doHandler { yes: go execute handler } + MOV EDI,EBP { load vtable of exception object } + JMP @@haveVMT + +@@vtLoop: + MOV EDI,[EDI] +@@haveVMT: + MOV EAX,[EAX] + CMP EAX,EDI + JE @@doHandler + + MOV ECX,[EAX].vmtInstanceSize + CMP ECX,[EDI].vmtInstanceSize + JNE @@parent + + MOV EAX,[EAX].vmtClassName + MOV EDX,[EDI].vmtClassName + + XOR ECX,ECX + MOV CL,[EAX] + CMP CL,[EDX] + JNE @@parent + + INC EAX + INC EDX + CALL _AStrCmp + JE @@doHandler + +@@parent: + MOV EDI,[EDI].vmtParent { load vtable of parent } + MOV EAX,[ESI].TExcDescEntry.vTable + TEST EDI,EDI + JNE @@vtLoop + + ADD ESI,8 + DEC EBX + JNZ @@innerLoop + + POP EBP + POP EDI + POP ESI + POP EBX + JMP @@exit + +@@doHandler: + MOV EAX,[ESP+4+4*4] + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + MOV EDX,[EAX].TExceptionRecord.ExceptObject + MOV ECX,[EAX].TExceptionRecord.ExceptAddr + JE @@haveObject + CALL ExceptObjProc + MOV EDX,[ESP+12+4*4] + CALL NotifyNonDelphiException +{$IFDEF MSWINDOWS} + CMP BYTE PTR JITEnable,0 + JBE @@NoJIT + CMP BYTE PTR DebugHook,0 + JA @@noJIT { Do not JIT if debugging } + LEA ECX,[ESP+4] + PUSH EAX + PUSH ECX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + POP EAX + JE @@exit +{$ENDIF} +@@noJIT: + MOV EDX,EAX + MOV EAX,[ESP+4+4*4] + MOV ECX,[EAX].TExceptionRecord.ExceptionAddress + JMP @@GoUnwind + +@@haveObject: +{$IFDEF MSWINDOWS} + CMP BYTE PTR JITEnable,1 + JBE @@GoUnwind + CMP BYTE PTR DebugHook,0 + JA @@GoUnwind + PUSH EAX + LEA EAX,[ESP+8] + PUSH EDX + PUSH ECX + PUSH EAX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + POP ECX + POP EDX + POP EAX + JE @@exit +{$ENDIF} + +@@GoUnwind: + XOR EBX,EBX + MOV EBX,FS:[EBX] + PUSH EBX { Save topmost frame } + PUSH EAX { Save exception record } + PUSH EDX { Save exception object } + PUSH ECX { Save exception address } + + MOV EDX,[ESP+8+8*4] + OR [EAX].TExceptionRecord.ExceptionFlags,cUnwinding + + PUSH ESI { Save handler entry } + + PUSH 0 + PUSH EAX + PUSH offset @@returnAddress + PUSH EDX + CALL RtlUnwindProc +@@returnAddress: + + POP EBX { Restore handler entry } + + MOV EDI,[ESP+8+8*4] + + { Make the RaiseList entry on the stack } + + CALL SysInit.@GetTLS + PUSH [EAX].RaiseListPtr + MOV [EAX].RaiseListPtr,ESP + + MOV EBP,[EDI].TExcFrame.hEBP + MOV [EDI].TExcFrame.desc,offset @@exceptFinally + MOV EAX,[ESP].TRaiseFrame.ExceptObject + CALL NotifyOnExcept + JMP [EBX].TExcDescEntry.handler + +@@exceptFinally: + JMP _HandleFinally + +@@destroyExcept: + { we come here if an exception handler has thrown yet another exception } + { we need to destroy the exception object and pop the raise list. } + + CALL SysInit.@GetTLS + MOV ECX,[EAX].RaiseListPtr + MOV EDX,[ECX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,EDX + + MOV EAX,[ECX].TRaiseFrame.ExceptObject + JMP TObject.Free +@@exit: + MOV EAX,1 +end; +{$ENDIF} + +procedure _HandleFinally; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} +{$IFDEF PIC} + MOV ESI, EBX +{$ENDIF} + CALL UnblockOSExceptions + MOV EDX, [ESP] + CALL NotifyExceptFinally + PUSH EAX +{$IFDEF PIC} + MOV EBX, ESI +{$ENDIF} + { + Mark the current exception with the EBP of the handler. If + an exception is raised from the finally block, then this + exception will be orphaned. We will catch this later, when + we clean up the next except block to complete execution. + See DoneExcept. + } + MOV [EAX].TRaisedException.HandlerEBP, EBP + CALL EDX + POP EAX + { + We executed the finally handler without adverse reactions. + It's safe to clear the marker now. + } + MOV [EAX].TRaisedException.HandlerEBP, $FFFFFFFF + PUSH EBP + MOV EBP, ESP + CALL SysRaiseException // Should be using resume here +{$ENDIF} +{$IFDEF MSWINDOWS} + { -> [ESP+ 4] excPtr: PExceptionRecord } + { [ESP+ 8] errPtr: PExcFrame } + { [ESP+12] ctxPtr: Pointer } + { [ESP+16] dspPtr: Pointer } + { <- EAX return value - always one } + + MOV EAX,[ESP+4] + MOV EDX,[ESP+8] + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JE @@exit + MOV ECX,[EDX].TExcFrame.desc + MOV [EDX].TExcFrame.desc,offset @@exit + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBP,[EDX].TExcFrame.hEBP + ADD ECX,TExcDesc.instructions + CALL NotifyExceptFinally + CALL ECX + + POP EBP + POP EDI + POP ESI + POP EBX + +@@exit: + MOV EAX,1 +{$ENDIF} +end; + + +procedure _HandleAutoException; +{$IFDEF LINUX} +{$IFDEF PC_MAPPED_EXCEPTIONS} +asm + // EAX = TObject reference, or nil + // [ESP] = ret addr + + CALL UnblockOSExceptions +// +// The compiler wants the stack to look like this: +// ESP+4-> HRESULT +// ESP+0-> ret addr +// +// Make it so. +// + POP EDX + PUSH 8000FFFFH + PUSH EDX + + OR EAX, EAX // Was this a method call? + JE @@Done + + PUSH EAX + CALL CurrentException + MOV EDX, [EAX].TRaisedException.ExceptObject + MOV ECX, [EAX].TRaisedException.ExceptionAddr; + POP EAX + MOV EAX, [EAX] + CALL [EAX].vmtSafeCallException.Pointer; + MOV [ESP+4], EAX +@@Done: + CALL _DoneExcept +end; +{$ELSE} +begin + Error(reSafeCallError); //!! +end; +{$ENDIF} +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + { -> [ESP+ 4] excPtr: PExceptionRecord } + { [ESP+ 8] errPtr: PExcFrame } + { [ESP+12] ctxPtr: Pointer } + { [ESP+16] dspPtr: Pointer } + { <- EAX return value - always one } + + MOV EAX,[ESP+4] + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JNE @@exit + + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + CLD + CALL _FpuInit + JE @@DelphiException + CMP BYTE PTR JITEnable,0 + JBE @@DelphiException + CMP BYTE PTR DebugHook,0 + JA @@DelphiException + +@@DoUnhandled: + LEA EAX,[ESP+4] + PUSH EAX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + JE @@exit + MOV EAX,[ESP+4] + JMP @@GoUnwind + +@@DelphiException: + CMP BYTE PTR JITEnable,1 + JBE @@GoUnwind + CMP BYTE PTR DebugHook,0 + JA @@GoUnwind + JMP @@DoUnhandled + +@@GoUnwind: + OR [EAX].TExceptionRecord.ExceptionFlags,cUnwinding + + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EDX,[ESP+8+3*4] + + PUSH 0 + PUSH EAX + PUSH offset @@returnAddress + PUSH EDX + CALL RtlUnwindProc + +@@returnAddress: + POP EBP + POP EDI + POP ESI + MOV EAX,[ESP+4] + MOV EBX,8000FFFFH + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + JNE @@done + + MOV EDX,[EAX].TExceptionRecord.ExceptObject + MOV ECX,[EAX].TExceptionRecord.ExceptAddr + MOV EAX,[ESP+8] + MOV EAX,[EAX].TExcFrame.SelfOfMethod + TEST EAX,EAX + JZ @@freeException + MOV EBX,[EAX] + CALL [EBX].vmtSafeCallException.Pointer + MOV EBX,EAX +@@freeException: + MOV EAX,[ESP+4] + MOV EAX,[EAX].TExceptionRecord.ExceptObject + CALL TObject.Free +@@done: + XOR EAX,EAX + MOV ESP,[ESP+8] + POP ECX + MOV FS:[EAX],ECX + POP EDX + POP EBP + LEA EDX,[EDX].TExcDesc.instructions + POP ECX + JMP EDX +@@exit: + MOV EAX,1 +end; +{$ENDIF} + + +{$IFDEF PC_MAPPED_EXCEPTIONS} +procedure _RaiseAtExcept; +asm + { -> EAX Pointer to exception object } + { -> EDX Purported addr of exception } + { Be careful: EBX is not set up in PIC mode. } + { Outward bound calls must go through an exported fn, like SysRaiseException } + OR EAX, EAX + JNE @@GoAhead + MOV EAX, 216 + CALL _RunError + +@@GoAhead: + CALL BlockOSExceptions + PUSH EBP + MOV EBP, ESP + CALL NotifyReRaise + CALL AllocateException + CALL SysRaiseException + { + This can only return if there was a terrible error. In this event, + we have to bail out. + } + JMP _Run0Error +end; +{$ENDIF} + +procedure _RaiseExcept; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + { -> EAX Pointer to exception object } + MOV EDX, [ESP] + JMP _RaiseAtExcept +{$ENDIF} +{$IFDEF MSWINDOWS} + { When making changes to the way Delphi Exceptions are raised, } + { please realize that the C++ Exception handling code reraises } + { some exceptions as Delphi Exceptions. Of course we want to } + { keep exception raising compatible between Delphi and C++, so } + { when you make changes here, consult with the relevant C++ } + { exception handling engineer. The C++ code is in xx.cpp, in } + { the RTL sources, in function tossAnException. } + + { -> EAX Pointer to exception object } + { [ESP] Error address } + + OR EAX, EAX + JNE @@GoAhead + MOV EAX, 216 + CALL _RunError +@@GoAhead: + POP EDX + + PUSH ESP + PUSH EBP + PUSH EDI + PUSH ESI + PUSH EBX + PUSH EAX { pass class argument } + PUSH EDX { pass address argument } + + PUSH ESP { pass pointer to arguments } + PUSH 7 { there are seven arguments } + PUSH cNonContinuable { we can't continue execution } + PUSH cDelphiException { our magic exception code } + PUSH EDX { pass the user's return address } + JMP RaiseExceptionProc +{$ENDIF} +end; + + +{$IFDEF PC_MAPPED_EXCEPTIONS} +{ + Used in the PC mapping exception implementation to handle exceptions in constructors. +} +procedure _ClassHandleException; +asm + { + EAX = self + EDX = top flag + } + TEST DL, DL + JE _RaiseAgain + MOV ECX,[EAX] + MOV DL,$81 + PUSH EAX + CALL dword ptr [ECX].vmtDestroy + POP EAX + CALL _ClassDestroy + JMP _RaiseAgain +end; +{$ENDIF} + +procedure _RaiseAgain; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + CALL CurrentException +// The following notifies the debugger of a reraise of exceptions. This will +// be supported in a later release, but is disabled for now. +// PUSH EAX +// MOV EDX, [EAX].TRaisedException.ExceptionAddr +// MOV EAX, [EAX].TRaisedException.ExceptObject +// CALL NotifyReRaise { Tell the debugger } +// POP EAX + TEST [EAX].TRaisedException.Flags, excIsBeingHandled + JZ @@DoIt + OR [EAX].TRaisedException.Flags, excIsBeingReRaised +@@DoIt: + MOV EDX, [ESP] { Get the user's addr } + JMP SysRaiseException +{$ENDIF} +{$IFDEF MSWINDOWS} + { -> [ESP ] return address to user program } + { [ESP+ 4 ] raise list entry (4 dwords) } + { [ESP+ 4+ 4*4] saved topmost frame } + { [ESP+ 4+ 5*4] saved registers (4 dwords) } + { [ESP+ 4+ 9*4] return address to OS } + { -> [ESP+ 4+10*4] excPtr: PExceptionRecord } + { [ESP+ 8+10*4] errPtr: PExcFrame } + + { Point the error handler of the exception frame to something harmless } + + MOV EAX,[ESP+8+10*4] + MOV [EAX].TExcFrame.desc,offset @@exit + + { Pop the RaiseList } + + CALL SysInit.@GetTLS + MOV EDX,[EAX].RaiseListPtr + MOV ECX,[EDX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,ECX + + { Destroy any objects created for non-delphi exceptions } + + MOV EAX,[EDX].TRaiseFrame.ExceptionRecord + AND [EAX].TExceptionRecord.ExceptionFlags,NOT cUnwinding + CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException + JE @@delphiException + MOV EAX,[EDX].TRaiseFrame.ExceptObject + CALL TObject.Free + CALL NotifyReRaise + +@@delphiException: + + XOR EAX,EAX + ADD ESP,5*4 + MOV EDX,FS:[EAX] + POP ECX + MOV EDX,[EDX].TExcFrame.next + MOV [ECX].TExcFrame.next,EDX + + POP EBP + POP EDI + POP ESI + POP EBX +@@exit: + MOV EAX,1 +{$ENDIF} +end; + +{$IFDEF DEBUG_EXCEPTIONS} +procedure NoteDE; +begin + Writeln('DoneExcept: Skipped the destructor'); +end; + +procedure NoteDE2; +begin + Writeln('DoneExcept: Destroyed the object'); +end; +{$ENDIF} + +{$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; +var + Exc: PRaisedException; + RefCount: Integer; + ExcObj: Pointer; + ExcAddr: Pointer; +begin + asm + MOV Exc, EAX + end; + + if (Exc^.Flags and excIsBeingReRaised) = 0 then + begin + RefCount := Exc^.RefCount; + ExcObj := Exc^.ExceptObject; + ExcAddr := Exc^.ExceptionAddr; + Exc^.RefCount := 1; + FreeException; + _DoneExcept; + Exc := AllocateException(ExcObj, ExcAddr); + Exc^.RefCount := RefCount; + end; + + Exc^.Flags := Exc^.Flags and not (excIsBeingReRaised or excIsBeingHandled); + + SysRaiseException(Exc); +end; +{$ENDIF} + +procedure _DoneExcept; +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + CALL FreeException + OR EAX, EAX + JE @@Done + CALL TObject.Free +@@Done: + { + Take a peek at the next exception object on the stack. + If its EBP marker is at an address lower than our current + EBP, then we know that it was orphaned when an exception was + thrown from within the execution of a finally block. We clean + it up now, so that we won't leak exception records/objects. + } + CALL CurrentException + OR EAX, EAX + JE @@Done2 + CMP [EAX].TRaisedException.HandlerEBP, EBP + JA @@Done2 + CALL FreeException + OR EAX, EAX + JE @@Done2 + CALL TObject.Free +@@Done2: +{$ENDIF} +{$IFDEF MSWINDOWS} + { -> [ESP+ 4+10*4] excPtr: PExceptionRecord } + { [ESP+ 8+10*4] errPtr: PExcFrame } + + { Pop the RaiseList } + + CALL SysInit.@GetTLS + MOV EDX,[EAX].RaiseListPtr + MOV ECX,[EDX].TRaiseFrame.NextRaise + MOV [EAX].RaiseListPtr,ECX + + { Destroy exception object } + + MOV EAX,[EDX].TRaiseFrame.ExceptObject + CALL TObject.Free + + POP EDX + MOV ESP,[ESP+8+9*4] + XOR EAX,EAX + POP ECX + MOV FS:[EAX],ECX + POP EAX + POP EBP + CALL NotifyTerminate + JMP EDX +{$ENDIF} +end; + +{$IFNDEF PC_MAPPED_EXCEPTIONS} +procedure _TryFinallyExit; +asm +{$IFDEF MSWINDOWS} + XOR EDX,EDX + MOV ECX,[ESP+4].TExcFrame.desc + MOV EAX,[ESP+4].TExcFrame.next + ADD ECX,TExcDesc.instructions + MOV FS:[EDX],EAX + CALL ECX +@@1: RET 12 +{$ENDIF} +end; +{$ENDIF} + + +var + InitContext: TInitContext; + +{$IFNDEF PC_MAPPED_EXCEPTIONS} +procedure MapToRunError(P: PExceptionRecord); stdcall; +const + STATUS_ACCESS_VIOLATION = $C0000005; + STATUS_ARRAY_BOUNDS_EXCEEDED = $C000008C; + STATUS_FLOAT_DENORMAL_OPERAND = $C000008D; + STATUS_FLOAT_DIVIDE_BY_ZERO = $C000008E; + STATUS_FLOAT_INEXACT_RESULT = $C000008F; + STATUS_FLOAT_INVALID_OPERATION = $C0000090; + STATUS_FLOAT_OVERFLOW = $C0000091; + STATUS_FLOAT_STACK_CHECK = $C0000092; + STATUS_FLOAT_UNDERFLOW = $C0000093; + STATUS_INTEGER_DIVIDE_BY_ZERO = $C0000094; + STATUS_INTEGER_OVERFLOW = $C0000095; + STATUS_PRIVILEGED_INSTRUCTION = $C0000096; + STATUS_STACK_OVERFLOW = $C00000FD; + STATUS_CONTROL_C_EXIT = $C000013A; +var + ErrCode: Byte; +begin + case P.ExceptionCode of + STATUS_INTEGER_DIVIDE_BY_ZERO: ErrCode := 200; + STATUS_ARRAY_BOUNDS_EXCEEDED: ErrCode := 201; + STATUS_FLOAT_OVERFLOW: ErrCode := 205; + STATUS_FLOAT_INEXACT_RESULT, + STATUS_FLOAT_INVALID_OPERATION, + STATUS_FLOAT_STACK_CHECK: ErrCode := 207; + STATUS_FLOAT_DIVIDE_BY_ZERO: ErrCode := 200; + STATUS_INTEGER_OVERFLOW: ErrCode := 215; + STATUS_FLOAT_UNDERFLOW, + STATUS_FLOAT_DENORMAL_OPERAND: ErrCode := 206; + STATUS_ACCESS_VIOLATION: ErrCode := 216; + STATUS_PRIVILEGED_INSTRUCTION: ErrCode := 218; + STATUS_CONTROL_C_EXIT: ErrCode := 217; + STATUS_STACK_OVERFLOW: ErrCode := 202; + else ErrCode := 255; + end; + RunErrorAt(ErrCode, P.ExceptionAddress); +end; + + +procedure _ExceptionHandler; +asm + MOV EAX,[ESP+4] + + TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress + JNE @@exit +{$IFDEF MSWINDOWS} + CMP BYTE PTR DebugHook,0 + JA @@ExecuteHandler + LEA EAX,[ESP+4] + PUSH EAX + CALL UnhandledExceptionFilter + CMP EAX,EXCEPTION_CONTINUE_SEARCH + JNE @@ExecuteHandler + JMP @@exit +{$ENDIF} + +@@ExecuteHandler: + MOV EAX,[ESP+4] + CLD + CALL _FpuInit + MOV EDX,[ESP+8] + + PUSH 0 + PUSH EAX + PUSH offset @@returnAddress + PUSH EDX + CALL RtlUnwindProc + +@@returnAddress: + MOV EBX,[ESP+4] + CMP [EBX].TExceptionRecord.ExceptionCode,cDelphiException + MOV EDX,[EBX].TExceptionRecord.ExceptAddr + MOV EAX,[EBX].TExceptionRecord.ExceptObject + JE @@DelphiException2 + + MOV EDX,ExceptObjProc + TEST EDX,EDX + JE MapToRunError + MOV EAX,EBX + CALL EDX + TEST EAX,EAX + JE MapToRunError + MOV EDX,[EBX].TExceptionRecord.ExceptionAddress + +@@DelphiException2: + + CALL NotifyUnhandled + MOV ECX,ExceptProc + TEST ECX,ECX + JE @@noExceptProc + CALL ECX { call ExceptProc(ExceptObject, ExceptAddr) } + +@@noExceptProc: + MOV ECX,[ESP+4] + MOV EAX,217 + MOV EDX,[ECX].TExceptionRecord.ExceptAddr + MOV [ESP],EDX + JMP _RunError + +@@exit: + XOR EAX,EAX +end; + +procedure SetExceptionHandler; +asm + XOR EDX,EDX { using [EDX] saves some space over [0] } +{X} // now we come here from another place, and EBP is used above for loop counter +{X} // let us restore it... +{X} PUSH EBP +{X} LEA EBP, [ESP + $50] + LEA EAX,[EBP-12] + MOV ECX,FS:[EDX] { ECX := head of chain } + MOV FS:[EDX],EAX { head of chain := @exRegRec } + + MOV [EAX].TExcFrame.next,ECX +{$IFDEF PIC} + LEA EDX, [EBX]._ExceptionHandler + MOV [EAX].TExcFrame.desc, EDX +{$ELSE} + MOV [EAX].TExcFrame.desc,offset _ExceptionHandler +{$ENDIF} + MOV [EAX].TExcFrame.hEBP,EBP +{$IFDEF PIC} + MOV [EBX].InitContext.ExcFrame,EAX +{$ELSE} + MOV InitContext.ExcFrame,EAX +{$ENDIF} + +{X} POP EBP +end; + + +procedure UnsetExceptionHandler; +asm + XOR EDX,EDX +{$IFDEF PIC} + MOV EAX,[EBX].InitContext.ExcFrame +{$ELSE} + MOV EAX,InitContext.ExcFrame +{$ENDIF} + TEST EAX,EAX + JZ @@exit + MOV ECX,FS:[EDX] { ECX := head of chain } + CMP EAX,ECX { simple case: our record is first } + JNE @@search + MOV EAX,[EAX] { head of chain := exRegRec.next } + MOV FS:[EDX],EAX + JMP @@exit + +@@loop: + MOV ECX,[ECX] +@@search: + CMP ECX,-1 { at end of list? } + JE @@exit { yes - didn't find it } + CMP [ECX],EAX { is it the next one on the list? } + JNE @@loop { no - look at next one on list } +@@unlink: { yes - unlink our record } + MOV EAX,[EAX] { get next record on list } + MOV [ECX],EAX { unlink our record } +@@exit: +end; +{$ENDIF} // not PC_MAPPED_EXCEPTIONS + +type + TProc = procedure; + +{$IFDEF LINUX} +procedure CallProc(Proc: Pointer; GOT: Cardinal); +asm + PUSH EBX + MOV EBX,EDX + ADD EAX,EBX + CALL EAX + POP EBX +end; +{$ENDIF} + +(*X- Original version... discarded +procedure FinalizeUnits; +var + Count: Integer; + Table: PUnitEntryTable; + P: Pointer; +begin + if InitContext.InitTable = nil then + exit; + Count := InitContext.InitCount; + Table := InitContext.InitTable^.UnitInfo; +{$IFDEF LINUX} + Inc(Cardinal(Table), InitContext.Module^.GOT); +{$ENDIF} + try + while Count > 0 do + begin + Dec(Count); + InitContext.InitCount := Count; + P := Table^[Count].FInit; + if Assigned(P) then + begin +{$IFDEF LINUX} + CallProc(P, InitContext.Module^.GOT); +{$ENDIF} +{$IFDEF MSWINDOWS} + TProc(P)(); +{$ENDIF} + end; + end; + except + FinalizeUnits; { try to finalize the others } + raise; + end; +end; +X+*) + +{X+ see comments in InitUnits below } +//procedure FInitUnits; {X} - renamed to FInitUnitsHard +{X} procedure FInitUnitsHard; +var + Count: Integer; + Table: PUnitEntryTable; + P: procedure; +begin + if InitContext.InitTable = nil then + exit; + Count := InitContext.InitCount; + Table := InitContext.InitTable^.UnitInfo; +{$IFDEF LINUX} + Inc(Cardinal(Table), InitContext.Module^.GOT); +{$ENDIF} + try + while Count > 0 do + begin + Dec(Count); + InitContext.InitCount := Count; + P := Table^[Count].FInit; + if Assigned(P) then +{$IFDEF LINUX} + CallProc(P, InitContext.Module^.GOT); +{$ENDIF} +{$IFDEF MSWINDOWS} + TProc(P)(); +{$ENDIF} + end; + except + {X- rename: FInitUnits; { try to finalize the others } + FInitUnitsHard; + raise; + end; +end; + +// This handler can be set in initialization section of +// unit SysSfIni.pas only. +procedure InitUnitsHard( Table : PUnitEntryTable; Idx, Count : Integer ); +begin + try + InitUnitsLight( Table, Idx, Count ); + except + FInitUnitsHard; + raise; + end; +end; + +{X+ see comments in InitUnits below } +procedure FInitUnitsLight; +var + Count: Integer; + Table: PUnitEntryTable; + P: procedure; +begin + if InitContext.InitTable = nil then + exit; + Count := InitContext.InitCount; + Table := InitContext.InitTable^.UnitInfo; +{$IFDEF LINUX} + Inc(Cardinal(Table), InitContext.Module^.GOT); +{$ENDIF} + while Count > 0 do + begin + Dec(Count); + InitContext.InitCount := Count; + P := Table^[Count].FInit; + if Assigned(P) then +{$IFDEF LINUX} + CallProc(P, InitContext.Module^.GOT); +{$ENDIF} +{$IFDEF MSWINDOWS} + TProc(P)(); +{$ENDIF} + end; +end; + +{X+ see comments in InitUnits below } +procedure InitUnitsLight( Table : PUnitEntryTable; Idx, Count : Integer ); +var P : procedure; + Light : Boolean; +begin + Light := @InitUnitsProc = @InitUnitsLight; + while Idx < Count do + begin + P := Table^[ Idx ].Init; + Inc( Idx ); + InitContext.InitCount := Idx; + if Assigned( P ) then + P; + if Light and (@InitUnitsProc <> @InitUnitsLight) then + begin + InitUnitsProc( Table, Idx, Count ); + break; + end; + end; +end; + +{X+ see comments in body of InitUnits below } +procedure InitUnits; +var + Count, I: Integer; + Table: PUnitEntryTable; + {X- P: Pointer; } +begin + if InitContext.InitTable = nil then + exit; + Count := InitContext.InitTable^.UnitCount; + I := 0; + Table := InitContext.InitTable^.UnitInfo; +{$IFDEF LINUX} + Inc(Cardinal(Table), InitContext.Module^.GOT); +{$ENDIF} + (*X- by default, Delphi InitUnits uses try-except & raise constructions, + which leads to permanent use of all exception handler routines. + Let us make this by another way. + try + while I < Count do + begin + P := Table^[I].Init; + Inc(I); + InitContext.InitCount := I; + if Assigned(P) then + begin +{$IFDEF LINUX} + CallProc(P, InitContext.Module^.GOT); +{$ENDIF} +{$IFDEF MSWINDOWS} + TProc(P)(); +{$ENDIF} + end; + end; + except + FinalizeUnits; + raise; + end; + X+*) + InitUnitsProc( Table, I, Count ); //{X} +end; + +procedure _PackageLoad(const Table : PackageInfo; Module: PLibModule); +var + SavedContext: TInitContext; +begin + SavedContext := InitContext; + InitContext.DLLInitState := 0; + InitContext.InitTable := Table; + InitContext.InitCount := 0; + InitContext.Module := Module; + InitContext.OuterContext := @SavedContext; + try + InitUnits; + finally + InitContext := SavedContext; + end; +end; + + +procedure _PackageUnload(const Table : PackageInfo; Module: PLibModule); +var + SavedContext: TInitContext; +begin + SavedContext := InitContext; + InitContext.DLLInitState := 0; + InitContext.InitTable := Table; + InitContext.InitCount := Table^.UnitCount; + InitContext.Module := Module; + InitContext.OuterContext := @SavedContext; + try + {X} //FinalizeUnits; + FInitUnitsProc; + finally + InitContext := SavedContext; + end; +end; + +{$IFDEF LINUX} +procedure _StartExe(InitTable: PackageInfo; Module: PLibModule; Argc: Integer; Argv: Pointer); +begin + ArgCount := Argc; + ArgValues := Argv; +{$ENDIF} +{$IFDEF MSWINDOWS} +procedure _StartExe(InitTable: PackageInfo; Module: PLibModule); +begin + RaiseExceptionProc := @RaiseException; + RTLUnwindProc := @RTLUnwind; +{$ENDIF} + InitContext.InitTable := InitTable; + InitContext.InitCount := 0; + InitContext.Module := Module; + MainInstance := Module.Instance; +{$IFNDEF PC_MAPPED_EXCEPTIONS} + + {X SetExceptionHandler; - moved to SysSfIni.pas } + +{$ENDIF} + IsLibrary := False; + InitUnits; +end; + +{$IFDEF MSWINDOWS} +procedure _StartLib; +asm + { -> EAX InitTable } + { EDX Module } + { ECX InitTLS } + { [ESP+4] DllProc } + { [EBP+8] HInst } + { [EBP+12] Reason } + + { Push some desperately needed registers } + + PUSH ECX + PUSH ESI + PUSH EDI + + { Save the current init context into the stackframe of our caller } + + MOV ESI,offset InitContext + LEA EDI,[EBP- (type TExcFrame) - (type TInitContext)] + MOV ECX,(type TInitContext)/4 + REP MOVSD + + { Setup the current InitContext } + + POP InitContext.DLLSaveEDI + POP InitContext.DLLSaveESI + MOV InitContext.DLLSaveEBP,EBP + MOV InitContext.DLLSaveEBX,EBX + MOV InitContext.InitTable,EAX + MOV InitContext.Module,EDX + LEA ECX,[EBP- (type TExcFrame) - (type TInitContext)] + MOV InitContext.OuterContext,ECX + XOR ECX,ECX + CMP dword ptr [EBP+12],0 + JNE @@notShutDown + MOV ECX,[EAX].PackageInfoTable.UnitCount +@@notShutDown: + MOV InitContext.InitCount,ECX + + MOV EAX, offset RaiseException + MOV RaiseExceptionProc, EAX + MOV EAX, offset RTLUnwind + MOV RTLUnwindProc, EAX + + CALL SetExceptionHandler + + MOV EAX,[EBP+12] + INC EAX + MOV InitContext.DLLInitState,AL + DEC EAX + + { Init any needed TLS } + + POP ECX + MOV EDX,[ECX] + MOV InitContext.ExitProcessTLS,EDX + JE @@skipTLSproc + CMP AL,3 // DLL_THREAD_DETACH + JGE @@skipTLSproc // call ExitThreadTLS proc after DLLProc + CALL dword ptr [ECX+EAX*4] +@@skipTLSproc: + + { Call any DllProc } + + PUSH ECX + MOV ECX,[ESP+4] + TEST ECX,ECX + JE @@noDllProc + MOV EAX,[EBP+12] + MOV EDX,[EBP+16] + CALL ECX +@@noDllProc: + + POP ECX + MOV EAX, [EBP+12] + CMP AL,3 // DLL_THREAD_DETACH + JL @@afterDLLproc // don't free TLS on process shutdown + CALL dword ptr [ECX+EAX*4] + +@@afterDLLProc: + + { Set IsLibrary if there was no exe yet } + + CMP MainInstance,0 + JNE @@haveExe + MOV IsLibrary,1 + FNSTCW Default8087CW // save host exe's FPU preferences + +@@haveExe: + + MOV EAX,[EBP+12] + DEC EAX + JNE _Halt0 + CALL InitUnits + RET 4 +end; +{$ENDIF MSWINDOWS} +{$IFDEF LINUX} +procedure _StartLib(Context: PInitContext; Module: PLibModule; DLLProc: TDLLProcEx); +var + TempSwap: TInitContext; +begin + // Context's register save fields are already initialized. + // Save the current InitContext and activate the new Context by swapping them + TempSwap := InitContext; + InitContext := PInitContext(Context)^; + PInitContext(Context)^ := TempSwap; + + InitContext.Module := Module; + InitContext.OuterContext := Context; + + // DLLInitState is initialized by SysInit to 0 for shutdown, 1 for startup + // Inc DLLInitState to distinguish from package init: + // 0 for package, 1 for DLL shutdown, 2 for DLL startup + + Inc(InitContext.DLLInitState); + + if InitContext.DLLInitState = 1 then + begin + InitContext.InitTable := Module.InitTable; + if Assigned(InitContext.InitTable) then + InitContext.InitCount := InitContext.InitTable.UnitCount // shutdown + end + else + begin + Module.InitTable := InitContext.InitTable; // save for shutdown + InitContext.InitCount := 0; // startup + end; + + if Assigned(DLLProc) then + DLLProc(InitContext.DLLInitState-1,0); + + if MainInstance = 0 then { Set IsLibrary if there was no exe yet } + begin + IsLibrary := True; + Default8087CW := Get8087CW; + end; + + if InitContext.DLLInitState = 1 then + _Halt0 + else + InitUnits; +end; +{$ENDIF} + +procedure _InitResStrings; +asm + { -> EAX Pointer to init table } + { record } + { cnt: Integer; } + { tab: array [1..cnt] record } + { variableAddress: Pointer; } + { resStringAddress: Pointer; } + { end; } + { end; } + { EBX = caller's GOT for PIC callers, 0 for non-PIC } + +{$IFDEF MSWINDOWS} + PUSH EBX + XOR EBX,EBX +{$ENDIF} + PUSH EDI + PUSH ESI + MOV EDI,[EBX+EAX] + LEA ESI,[EBX+EAX+4] +@@loop: + MOV EAX,[ESI+4] { load resStringAddress } + MOV EDX,[ESI] { load variableAddress } + ADD EAX,EBX + ADD EDX,EBX + CALL LoadResString + ADD ESI,8 + DEC EDI + JNZ @@loop + + POP ESI + POP EDI +{$IFDEF MSWINDOWS} + POP EBX +{$ENDIF} +end; + +procedure _InitResStringImports; +asm + { -> EAX Pointer to init table } + { record } + { cnt: Integer; } + { tab: array [1..cnt] record } + { variableAddress: Pointer; } + { resStringAddress: ^Pointer; } + { end; } + { end; } + { EBX = caller's GOT for PIC callers, 0 for non-PIC } + +{$IFDEF MSWINDOWS} + PUSH EBX + XOR EBX,EBX +{$ENDIF} + PUSH EDI + PUSH ESI + MOV EDI,[EBX+EAX] + LEA ESI,[EBX+EAX+4] +@@loop: + MOV EAX,[ESI+4] { load address of import } + MOV EDX,[ESI] { load address of variable } + MOV EAX,[EBX+EAX] { load contents of import } + ADD EDX,EBX + CALL LoadResString + ADD ESI,8 + DEC EDI + JNZ @@loop + + POP ESI + POP EDI +{$IFDEF MSWINDOWS} + POP EBX +{$ENDIF} +end; + +procedure _InitImports; +asm + { -> EAX Pointer to init table } + { record } + { cnt: Integer; } + { tab: array [1..cnt] record } + { variableAddress: Pointer; } + { sourceAddress: ^Pointer; } + { sourceOffset: Longint; } + { end; } + { end; } + { EBX = caller's GOT for PIC callers, 0 for non-PIC } + +{$IFDEF MSWINDOWS} + PUSH EBX + XOR EBX,EBX +{$ENDIF} + PUSH EDI + PUSH ESI + MOV EDI,[EBX+EAX] + LEA ESI,[EBX+EAX+4] +@@loop: + MOV EAX,[ESI+4] { load address of import } + MOV EDX,[ESI] { load address of variable } + MOV EAX,[EBX+EAX] { load contents of import } + ADD EAX,[ESI+8] { calc address of variable } + MOV [EBX+EDX],EAX { store result } + ADD ESI,12 + DEC EDI + JNZ @@loop + + POP ESI + POP EDI +{$IFDEF MSWINDOWS} + POP EBX +{$ENDIF} +end; + +{$IFDEF MSWINDOWS} +procedure _InitWideStrings; +asm + { -> EAX Pointer to init table } + { record } + { cnt: Integer; } + { tab: array [1..cnt] record } + { variableAddress: Pointer; } + { stringAddress: ^Pointer; } + { end; } + { end; } + + PUSH EBX + PUSH ESI + MOV EBX,[EAX] + LEA ESI,[EAX+4] +@@loop: + MOV EDX,[ESI+4] { load address of string } + MOV EAX,[ESI] { load address of variable } + CALL _WStrAsg + ADD ESI,8 + DEC EBX + JNZ @@loop + + POP ESI + POP EBX +end; +{$ENDIF} + +var + runErrMsg: array[0..29] of Char = 'Runtime error at 00000000'#0; + // columns: 0123456789012345678901234567890 + errCaption: array[0..5] of Char = 'Error'#0; + + +procedure MakeErrorMessage; +const + dig : array [0..15] of Char = '0123456789ABCDEF'; +var + digit: Byte; + Temp: Integer; + Addr: Cardinal; +begin + digit := 16; + Temp := ExitCode; + repeat + runErrMsg[digit] := Char(Ord('0') + (Temp mod 10)); + Temp := Temp div 10; + Dec(digit); + until Temp = 0; + digit := 28; + Addr := Cardinal(ErrorAddr); + repeat + runErrMsg[digit] := dig[Addr and $F]; + Addr := Addr div 16; + Dec(digit); + until Addr = 0; +end; + + +procedure ExitDll; +asm + { Return False if ExitCode <> 0, and set ExitCode to 0 } + + XOR EAX,EAX +{$IFDEF PIC} + MOV ECX,[EBX].ExitCode + XCHG EAX,[ECX] +{$ELSE} + XCHG EAX, ExitCode +{$ENDIF} + NEG EAX + SBB EAX,EAX + INC EAX + + { Restore the InitContext } +{$IFDEF PIC} + LEA EDI, [EBX].InitContext +{$ELSE} + MOV EDI, offset InitContext +{$ENDIF} + + MOV EBX,[EDI].TInitContext.DLLSaveEBX + MOV EBP,[EDI].TInitContext.DLLSaveEBP + PUSH [EDI].TInitContext.DLLSaveESI + PUSH [EDI].TInitContext.DLLSaveEDI + + MOV ESI,[EDI].TInitContext.OuterContext + MOV ECX,(type TInitContext)/4 + REP MOVSD + POP EDI + POP ESI + + LEAVE +{$IFDEF MSWINDOWS} + RET 12 +{$ENDIF} +{$IFDEF LINUX} + RET +{$ENDIF} +end; + +// {X} Procedure Halt0 refers to WriteLn and MessageBox +// but actually such code can be not used really. +// So, implementation changed to avoid such references. +// +// Either call UseErrorMessageBox or UseErrorMessageWrite +// to provide error message output in GUI or console app. +// {X}+ + +var ErrorMessageOutProc : procedure = DummyProc; + +procedure ErrorMessageBox; +begin + MakeErrorMessage; + if not NoErrMsg then + MessageBox(0, runErrMsg, errCaption, 0); +end; + +procedure UseErrorMessageBox; +begin + ErrorMessageOutProc := ErrorMessageBox; +end; + +procedure ErrorMessageWrite; +begin + MakeErrorMessage; + WriteLn(PChar(@runErrMsg)); +end; + +procedure UseErrorMessageWrite; +begin + ErrorMessageOutProc := ErrorMessageWrite; +end; + +procedure DoCloseInputOutput; +begin + Close( Input ); + Close( Output ); + Close(ErrOutput); +end; + +var CloseInputOutput : procedure = DummyProc; + +procedure UseInputOutput; +begin + if not assigned( CloseInputOutput ) then + begin + CloseInputOutput := DoCloseInputOutput; + //_Assign( Input, '' ); was for D5 so - changed + //_Assign( Output, '' ); was for D5 so - changed + TTextRec(Input).Mode := fmClosed; + TTextRec(Output).Mode := fmClosed; + TTextRec(ErrOutput).Mode := fmClosed; + end; +end; + +// {X}- +(*X- +procedure WriteErrorMessage; +{$IFDEF MSWINDOWS} +var + Dummy: Cardinal; +begin + if IsConsole then + begin + with TTextRec(Output) do + begin + if (Mode = fmOutput) and (BufPos > 0) then + TTextIOFunc(InOutFunc)(TTextRec(Output)); // flush out text buffer + end; + WriteFile(GetStdHandle(STD_OUTPUT_HANDLE), runErrMsg, Sizeof(runErrMsg), Dummy, nil); + WriteFile(GetStdHandle(STD_OUTPUT_HANDLE), sLineBreak, 2, Dummy, nil); + end + else if not NoErrMsg then + MessageBox(0, runErrMsg, errCaption, 0); +{$ENDIF} +{$IFDEF LINUX} +var + c: Char; +begin + with TTextRec(Output) do + begin + if (Mode = fmOutput) and (BufPos > 0) then + TTextIOFunc(InOutFunc)(TTextRec(Output)); // flush out text buffer + end; + __write(STDERR_FILENO, @runErrMsg, Sizeof(runErrMsg)-1); + c := sLineBreak; + __write(STDERR_FILENO, @c, 1); +{$ENDIF} +end; +X+*) + +procedure _Halt0; +var + P: procedure; +begin +{$IFDEF LINUX} + if (ExitCode <> 0) and CoreDumpEnabled then + __raise(SIGABRT); +{$ENDIF} + + if InitContext.DLLInitState = 0 then + while ExitProc <> nil do + begin + @P := ExitProc; + ExitProc := nil; + P; + end; + + { If there was some kind of runtime error, alert the user } + + if ErrorAddr <> nil then + begin + {X+} + ErrorMessageOutProc; + { + MakeErrorMessage; + if IsConsole then + WriteLn(PChar(@runErrMsg)) + else if not NoErrMsg then + MessageBox(0, runErrMsg, errCaption, 0); + } {X-} + + {X- As it is said by Alexey Torgashin, it is better not to clear ErrorAddr + to make possible check ErrorAddr <> nil in finalization of rest units. + If you want, you can uncomment it again: } + //ErrorAddr := nil; + {X+} + end; + + { This loop exists because we might be nested in PackageLoad calls when } + { Halt got called. We need to unwind these contexts. } + + while True do + begin + + { If we are a library, and we are starting up fine, there are no units to finalize } + + if (InitContext.DLLInitState = 2) and (ExitCode = 0) then + InitContext.InitCount := 0; + + { Undo any unit initializations accomplished so far } + + // {X} FinalizeUnits; -- renamed + FInitUnitsProc; + + if (InitContext.DLLInitState <= 1) or (ExitCode <> 0) then + begin + if InitContext.Module <> nil then + with InitContext do + begin + UnregisterModule(Module); +{$IFDEF PC_MAPPED_EXCEPTIONS} + SysUnregisterIPLookup(Module.CodeSegStart); +{$ENDIF} + if (Module.ResInstance <> Module.Instance) and (Module.ResInstance <> 0) then + FreeLibrary(Module.ResInstance); + end; + end; + +{$IFNDEF PC_MAPPED_EXCEPTIONS} + {X UnsetExceptionHandler; - changed to call of handler } + UnsetExceptionHandlerProc; +{$ENDIF} + +{$IFDEF MSWINDOWS} + if InitContext.DllInitState = 1 then + InitContext.ExitProcessTLS; +{$ENDIF} + + if InitContext.DllInitState <> 0 then + ExitDll; + + if InitContext.OuterContext = nil then + begin + { + If an ExitProcessProc is set, we call it. Note that at this + point the RTL is completely shutdown. The only thing this is used + for right now is the proper semantic handling of signals under Linux. + } + if Assigned(ExitProcessProc) then + ExitProcessProc; + ExitProcess(ExitCode); + end; + + InitContext := InitContext.OuterContext^ + end; +end; + +procedure _Halt; +begin + ExitCode := Code; + _Halt0; +end; + + +procedure _Run0Error; +{$IFDEF PUREPASCAL} +begin + _RunError(0); // loses return address +end; +{$ELSE} +asm + XOR EAX,EAX + JMP _RunError +end; +{$ENDIF} + + +procedure _RunError(errorCode: Byte); +{$IFDEF PUREPASCAL} +begin + ErrorAddr := Pointer(-1); // no return address available + Halt(errorCode); +end; +{$ELSE} +asm +{$IFDEF PIC} + PUSH EAX + CALL GetGOT + MOV EBX, EAX + POP EAX + MOV ECX, [EBX].ErrorAddr + POP [ECX] +{$ELSE} + POP ErrorAddr +{$ENDIF} + JMP _Halt +end; +{$ENDIF} + +procedure _UnhandledException; +type TExceptProc = procedure (Obj: TObject; Addr: Pointer); +begin + if Assigned(ExceptProc) then + TExceptProc(ExceptProc)(ExceptObject, ExceptAddr) + else + RunError(230); +end; + +procedure _Assert(const Message, Filename: AnsiString; LineNumber: Integer); +{$IFDEF PUREPASCAL} +begin + if Assigned(AssertErrorProc) then + AssertErrorProc(Message, Filename, LineNumber, Pointer(-1)) + else + Error(reAssertionFailed); // loses return address +end; +{$ELSE} +asm + PUSH EBX +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + MOV EBX, EAX + MOV EAX, [EBX].AssertErrorProc + CMP [EAX], 0 + POP ECX + POP EAX +{$ELSE} + CMP AssertErrorProc,0 +{$ENDIF} + JNZ @@1 + MOV AL,reAssertionFailed + CALL Error + JMP @@exit + +@@1: PUSH [ESP+4].Pointer +{$IFDEF PIC} + MOV EBX, [EBX].AssertErrorProc + CALL [EBX] +{$ELSE} + CALL AssertErrorProc +{$ENDIF} +@@exit: + POP EBX +end; +{$ENDIF} + +type + PThreadRec = ^TThreadRec; + TThreadRec = record + Func: TThreadFunc; + Parameter: Pointer; + end; + +{$IFDEF MSWINDOWS} +function ThreadWrapper(Parameter: Pointer): Integer; stdcall; +{$ELSE} +function ThreadWrapper(Parameter: Pointer): Pointer; cdecl; +{$ENDIF} +asm +{$IFDEF PC_MAPPED_EXCEPTIONS} + { Mark the top of the stack with a signature } + PUSH UNWINDFI_TOPOFSTACK +{$ENDIF} + CALL _FpuInit + PUSH EBP +{$IFNDEF PC_MAPPED_EXCEPTIONS} + XOR ECX,ECX + PUSH offset _ExceptionHandler + MOV EDX,FS:[ECX] + PUSH EDX + MOV FS:[ECX],ESP +{$ENDIF} + MOV EAX,Parameter + + MOV ECX,[EAX].TThreadRec.Parameter + MOV EDX,[EAX].TThreadRec.Func + PUSH ECX + PUSH EDX + CALL _FreeMem + POP EDX + POP EAX + CALL EDX + +{$IFNDEF PC_MAPPED_EXCEPTIONS} + XOR EDX,EDX + POP ECX + MOV FS:[EDX],ECX + POP ECX +{$ENDIF} + POP EBP +{$IFDEF PC_MAPPED_EXCEPTIONS} + { Ditch our TOS marker } + ADD ESP, 4 +{$ENDIF} +end; + + +{$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} + +{$IFDEF LINUX} +function BeginThread(Attribute: PThreadAttr; + ThreadFunc: TThreadFunc; + Parameter: Pointer; + var ThreadId: Cardinal): Integer; +var + P: PThreadRec; +begin + if Assigned(BeginThreadProc) then + Result := BeginThreadProc(Attribute, ThreadFunc, Parameter, ThreadId) + else + begin + New(P); + P.Func := ThreadFunc; + P.Parameter := Parameter; + IsMultiThread := True; + Result := _pthread_create(ThreadID, Attribute, @ThreadWrapper, P); + end; +end; + +procedure EndThread(ExitCode: Integer); +begin + if Assigned(EndThreadProc) then + EndThreadProc(ExitCode); + // No "else" required since EndThreadProc does not (!!should not!!) return. + _pthread_detach(GetCurrentThreadID); + _pthread_exit(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); +{$IFDEF PUREPASCAL} +var + P: PStrRec; +begin + if Pointer(S) <> nil then + begin + P := Pointer(Integer(S) - Sizeof(StrRec)); + Pointer(S) := nil; + if P.refCnt > 0 then + if InterlockedDecrement(P.refCnt) = 0 then + FreeMem(P); + end; +end; +{$ELSE} +asm + { -> EAX pointer to str } + + MOV EDX,[EAX] { fetch str } + TEST EDX,EDX { if nil, nothing to do } + JE @@done + MOV dword ptr [EAX],0 { clear str } + MOV ECX,[EDX-skew].StrRec.refCnt { fetch refCnt } + DEC ECX { if < 0: literal str } + JL @@done +{X LOCK} DEC [EDX-skew].StrRec.refCnt { NONthreadsafe dec refCount } + JNE @@done + PUSH EAX + LEA EAX,[EDX-skew].StrRec.refCnt { if refCnt now zero, deallocate} + CALL _FreeMem + POP EAX +@@done: +end; +{$ENDIF} + +procedure _LStrArrayClr(var StrArray; cnt: longint); +{$IFDEF PUREPASCAL} +var + P: Pointer; +begin + P := @StrArray; + while cnt > 0 do + begin + _LStrClr(P^); + Dec(cnt); + Inc(Integer(P), sizeof(Pointer)); + end; +end; +{$ELSE} +asm + { -> EAX pointer to str } + { EDX cnt } + + PUSH EBX + PUSH ESI + MOV EBX,EAX + MOV ESI,EDX + +@@loop: + MOV EDX,[EBX] { fetch str } + TEST EDX,EDX { if nil, nothing to do } + JE @@doneEntry + MOV dword ptr [EBX],0 { clear str } + MOV ECX,[EDX-skew].StrRec.refCnt { fetch refCnt } + DEC ECX { if < 0: literal str } + JL @@doneEntry +{X LOCK} DEC [EDX-skew].StrRec.refCnt { NONthreadsafe dec refCount } + JNE @@doneEntry + LEA EAX,[EDX-skew].StrRec.refCnt { if refCnt now zero, deallocate} + CALL _FreeMem +@@doneEntry: + ADD EBX,4 + DEC ESI + JNE @@loop + + POP ESI + POP EBX +end; +{$ENDIF} + +{ 99.03.11 + This function is used when assigning to global variables. + + Literals are copied to prevent a situation where a dynamically + allocated DLL or package assigns a literal to a variable and then + is unloaded -- thereby causing the string memory (in the code + segment of the DLL) to be removed -- and therefore leaving the + global variable pointing to invalid memory. +} +procedure _LStrAsg(var dest; const source); +{$IFDEF PUREPASCAL} +var + S, D: Pointer; + P: PStrRec; + Temp: Longint; +begin + S := Pointer(source); + if S <> nil then + begin + P := PStrRec(Integer(S) - sizeof(StrRec)); + if P.refCnt < 0 then // make copy of string literal + begin + Temp := P.length; + S := _NewAnsiString(Temp); + Move(Pointer(source)^, S^, Temp); + P := PStrRec(Integer(S) - sizeof(StrRec)); + end; + InterlockedIncrement(P.refCnt); + end; + + D := Pointer(dest); + Pointer(dest) := S; + if D <> nil then + begin + P := PStrRec(Integer(D) - sizeof(StrRec)); + if P.refCnt > 0 then + if InterlockedDecrement(P.refCnt) = 0 then + FreeMem(P); + end; +end; +{$ELSE} +asm + { -> EAX pointer to dest str } + { -> EDX pointer to source str } + + TEST EDX,EDX { have a source? } + JE @@2 { no -> jump } + + MOV ECX,[EDX-skew].StrRec.refCnt + INC ECX + JG @@1 { literal string -> jump not taken } + + PUSH EAX + PUSH EDX + MOV EAX,[EDX-skew].StrRec.length + CALL _NewAnsiString + MOV EDX,EAX + POP EAX + PUSH EDX + MOV ECX,[EAX-skew].StrRec.length + CALL Move + POP EDX + POP EAX + JMP @@2 + +@@1: + {X LOCK} INC [EDX-skew].StrRec.refCnt + +@@2: XCHG EDX,[EAX] + TEST EDX,EDX + JE @@3 + MOV ECX,[EDX-skew].StrRec.refCnt + DEC ECX + JL @@3 + {X LOCK} DEC [EDX-skew].StrRec.refCnt + JNE @@3 + LEA EAX,[EDX-skew].StrRec.refCnt + CALL _FreeMem +@@3: +end; +{$ENDIF} + +procedure _LStrLAsg(var dest; const source); +{$IFDEF PUREPASCAL} +var + P: Pointer; +begin + P := Pointer(source); + _LStrAddRef(P); + P := Pointer(dest); + Pointer(dest) := Pointer(source); + _LStrClr(P); +end; +{$ELSE} +asm +{ -> EAX pointer to dest } +{ EDX source } + + TEST EDX,EDX + JE @@sourceDone + + { bump up the ref count of the source } + + MOV ECX,[EDX-skew].StrRec.refCnt + INC ECX + JLE @@sourceDone { literal assignment -> jump taken } + {X LOCK} INC [EDX-skew].StrRec.refCnt +@@sourceDone: + + { we need to release whatever the dest is pointing to } + + XCHG EDX,[EAX] { fetch str } + TEST EDX,EDX { if nil, nothing to do } + JE @@done + MOV ECX,[EDX-skew].StrRec.refCnt { fetch refCnt } + DEC ECX { if < 0: literal str } + JL @@done + {X LOCK} DEC [EDX-skew].StrRec.refCnt { NONthreadsafe dec refCount } + JNE @@done + LEA EAX,[EDX-skew].StrRec.refCnt { if refCnt now zero, deallocate} + CALL _FreeMem +@@done: +end; +{$ENDIF} + +function _NewAnsiString(length: Longint): Pointer; +{$IFDEF PUREPASCAL} +var + P: PStrRec; +begin + Result := nil; + if length <= 0 then Exit; + // Alloc an extra null for strings with even length. This has no actual cost + // since the allocator will round up the request to an even size anyway. + // All widestring allocations have even length, and need a double null terminator. + GetMem(P, length + sizeof(StrRec) + 1 + ((length + 1) and 1)); + Result := Pointer(Integer(P) + sizeof(StrRec)); + P.length := length; + P.refcnt := 1; + PWideChar(Result)[length div 2] := #0; // length guaranteed >= 2 +end; +{$ELSE} +asm + { -> EAX length } + { <- EAX pointer to new string } + + TEST EAX,EAX + JLE @@null + PUSH EAX + ADD EAX,rOff+2 // one or two nulls (Ansi/Wide) + AND EAX, not 1 // round up to even length + PUSH EAX + CALL _GetMem + POP EDX // actual allocated length (>= 2) + MOV word ptr [EAX+EDX-2],0 // double null terminator + ADD EAX,rOff + POP EDX // requested string length + MOV [EAX-skew].StrRec.length,EDX + MOV [EAX-skew].StrRec.refCnt,1 + RET +@@null: + XOR EAX,EAX +end; +{$ENDIF} + +procedure _LStrFromPCharLen(var Dest: AnsiString; Source: PAnsiChar; Length: Integer); +asm + { -> EAX pointer to dest } + { EDX source } + { ECX length } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + { allocate new string } + + MOV EAX,EDI + + CALL _NewAnsiString + MOV ECX,EDI + MOV EDI,EAX + + TEST ESI,ESI + JE @@noMove + + MOV EDX,EAX + MOV EAX,ESI + CALL Move + + { assign the result to dest } + +@@noMove: + MOV EAX,EBX + CALL _LStrClr + MOV [EBX],EDI + + POP EDI + POP ESI + POP EBX +end; + + +{$IFDEF LINUX} +function BufConvert(var Dest; DestBytes: Integer; + const Source; SrcBytes: Integer; + context: Integer): Integer; +var + SrcBytesLeft, DestBytesLeft: Integer; + s, d: Pointer; +begin + if context = -1 then + begin + Result := -1; + Exit; + end; + // make copies of params... iconv modifies param ptrs + DestBytesLeft := DestBytes; + SrcBytesLeft := SrcBytes; + s := Pointer(Source); + d := Pointer(Dest); + if (SrcBytes = 0) or (DestBytes = 0) then + Result := 0 + else + begin + Result := iconv(context, s, SrcBytesLeft, d, DestBytesLeft); + while (SrcBytesLeft > 0) and (DestBytesLeft > 0) + and (Result = -1) and (GetLastError = 7) do + begin + Result := iconv(context, s, SrcBytesLeft, d, DestBytesLeft); + end; + + if Result <> -1 then + Result := DestBytes - DestBytesLeft; + end; + + iconv_close(context); +end; +{$ENDIF} + + +function CharFromWChar(CharDest: PChar; DestBytes: Integer; const WCharSource: PWideChar; SrcChars: Integer): Integer; +begin +{$IFDEF LINUX} + Result := BufConvert(CharDest, DestBytes, WCharSource, SrcChars * sizeof(WideChar), + iconv_open(nl_langinfo(_NL_CTYPE_CODESET_NAME), 'UNICODELITTLE')); +{$ENDIF} +{$IFDEF MSWINDOWS} + Result := WideCharToMultiByte(0, 0, WCharSource, SrcChars, + CharDest, DestBytes, nil, nil); +{$ENDIF} +end; + + +function WCharFromChar(WCharDest: PWideChar; DestChars: Integer; const CharSource: PChar; SrcBytes: Integer): Integer; +begin +{$IFDEF LINUX} + Result := BufConvert(WCharDest, DestChars * sizeof(WideChar), CharSource, SrcBytes, + iconv_open('UNICODELITTLE', nl_langinfo(_NL_CTYPE_CODESET_NAME))) div sizeof(WideChar); +{$ENDIF} +{$IFDEF MSWINDOWS} + Result := MultiByteToWideChar(0, 0, CharSource, SrcBytes, + WCharDest, DestChars); +{$ENDIF} +end; + + +procedure _LStrFromPWCharLen(var Dest: AnsiString; Source: PWideChar; Length: Integer); +var + DestLen: Integer; + Buffer: array[0..4095] of Char; +begin + if Length <= 0 then + begin + _LStrClr(Dest); + Exit; + end; + if Length+1 < (High(Buffer) div sizeof(WideChar)) then + begin + DestLen := CharFromWChar(Buffer, High(Buffer), Source, Length); + if DestLen >= 0 then + begin + _LStrFromPCharLen(Dest, Buffer, DestLen); + Exit; + end; + end; + + DestLen := (Length + 1) * sizeof(WideChar); + SetLength(Dest, DestLen); // overallocate, trim later + DestLen := CharFromWChar(Pointer(Dest), DestLen, Source, Length); + if DestLen < 0 then DestLen := 0; + SetLength(Dest, DestLen); +end; + + +procedure _LStrFromChar(var Dest: AnsiString; Source: AnsiChar); +asm + PUSH EDX + MOV EDX,ESP + MOV ECX,1 + CALL _LStrFromPCharLen + POP EDX +end; + + +procedure _LStrFromWChar(var Dest: AnsiString; Source: WideChar); +asm + PUSH EDX + MOV EDX,ESP + MOV ECX,1 + CALL _LStrFromPWCharLen + POP EDX +end; + + +procedure _LStrFromPChar(var Dest: AnsiString; Source: PAnsiChar); +asm + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CL,[EDX+0] + JE @@4 + CMP CL,[EDX+1] + JE @@3 + CMP CL,[EDX+2] + JE @@2 + CMP CL,[EDX+3] + JE @@1 + ADD EDX,4 + JMP @@0 +@@1: INC EDX +@@2: INC EDX +@@3: INC EDX +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX +@@5: JMP _LStrFromPCharLen +end; + + +procedure _LStrFromPWChar(var Dest: AnsiString; Source: PWideChar); +asm + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CX,[EDX+0] + JE @@4 + CMP CX,[EDX+2] + JE @@3 + CMP CX,[EDX+4] + JE @@2 + CMP CX,[EDX+6] + JE @@1 + ADD EDX,8 + JMP @@0 +@@1: ADD EDX,2 +@@2: ADD EDX,2 +@@3: ADD EDX,2 +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX + SHR ECX,1 +@@5: JMP _LStrFromPWCharLen +end; + + +procedure _LStrFromString(var Dest: AnsiString; const Source: ShortString); +asm + XOR ECX,ECX + MOV CL,[EDX] + INC EDX + JMP _LStrFromPCharLen +end; + + +procedure _LStrFromArray(var Dest: AnsiString; Source: PAnsiChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASB + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _LStrFromPCharLen +end; + + +procedure _LStrFromWArray(var Dest: AnsiString; Source: PWideChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASW + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _LStrFromPWCharLen +end; + + +procedure _LStrFromWStr(var Dest: AnsiString; const Source: WideString); +asm + { -> EAX pointer to dest } + { EDX pointer to WideString data } + + XOR ECX,ECX + TEST EDX,EDX + JE @@1 + MOV ECX,[EDX-4] + SHR ECX,1 +@@1: JMP _LStrFromPWCharLen +end; + + +procedure _LStrToString{(var Dest: ShortString; const Source: AnsiString; MaxLen: Integer)}; +asm + { -> EAX pointer to result } + { EDX AnsiString s } + { ECX length of result } + + PUSH EBX + TEST EDX,EDX + JE @@empty + MOV EBX,[EDX-skew].StrRec.length + TEST EBX,EBX + JE @@empty + + CMP ECX,EBX + JL @@truncate + MOV ECX,EBX +@@truncate: + MOV [EAX],CL + INC EAX + + XCHG EAX,EDX + CALL Move + + JMP @@exit + +@@empty: + MOV byte ptr [EAX],0 + +@@exit: + POP EBX +end; + +function _LStrLen(const s: AnsiString): Longint; +{$IFDEF PUREPASCAL} +begin + Result := 0; + if Pointer(s) <> nil then + Result := PStrRec(Integer(s) - sizeof(StrRec)).length; +end; +{$ELSE} +asm + { -> EAX str } + + TEST EAX,EAX + JE @@done + MOV EAX,[EAX-skew].StrRec.length; +@@done: +end; +{$ENDIF} + + +procedure _LStrCat{var dest: AnsiString; source: AnsiString}; +asm + { -> EAX pointer to dest } + { EDX source } + + TEST EDX,EDX + JE @@exit + + MOV ECX,[EAX] + TEST ECX,ECX + JE _LStrAsg + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,[ECX-skew].StrRec.length + + MOV EDX,[ESI-skew].StrRec.length + ADD EDX,EDI + CMP ESI,ECX + JE @@appendSelf + + CALL _LStrSetLength + MOV EAX,ESI + MOV ECX,[ESI-skew].StrRec.length + +@@appendStr: + MOV EDX,[EBX] + ADD EDX,EDI + CALL Move + POP EDI + POP ESI + POP EBX + RET + +@@appendSelf: + CALL _LStrSetLength + MOV EAX,[EBX] + MOV ECX,EDI + JMP @@appendStr + +@@exit: +end; + + +procedure _LStrCat3{var dest:AnsiString; source1: AnsiString; source2: AnsiString}; +asm + { ->EAX = Pointer to dest } + { EDX = source1 } + { ECX = source2 } + + TEST EDX,EDX + JE @@assignSource2 + + TEST ECX,ECX + JE _LStrAsg + + CMP EDX,[EAX] + JE @@appendToDest + + CMP ECX,[EAX] + JE @@theHardWay + + PUSH EAX + PUSH ECX + CALL _LStrAsg + + POP EDX + POP EAX + JMP _LStrCat + +@@theHardWay: + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EDX + MOV ESI,ECX + PUSH EAX + + MOV EAX,[EBX-skew].StrRec.length + ADD EAX,[ESI-skew].StrRec.length + CALL _NewAnsiString + + MOV EDI,EAX + MOV EDX,EAX + MOV EAX,EBX + MOV ECX,[EBX-skew].StrRec.length + CALL Move + + MOV EDX,EDI + MOV EAX,ESI + MOV ECX,[ESI-skew].StrRec.length + ADD EDX,[EBX-skew].StrRec.length + CALL Move + + POP EAX + MOV EDX,EDI + TEST EDI,EDI + JE @@skip + DEC [EDI-skew].StrRec.refCnt // EDI = local temp str +@@skip: + CALL _LStrAsg + + POP EDI + POP ESI + POP EBX + + JMP @@exit + +@@assignSource2: + MOV EDX,ECX + JMP _LStrAsg + +@@appendToDest: + MOV EDX,ECX + JMP _LStrCat + +@@exit: +end; + + +procedure _LStrCatN{var dest:AnsiString; argCnt: Integer; ...}; +asm + { ->EAX = Pointer to dest } + { EDX = number of args (>= 3) } + { [ESP+4], [ESP+8], ... crgCnt AnsiString arguments, reverse order } + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EDX + PUSH EAX + MOV EBX,EDX + + XOR EDI,EDI + MOV ECX,[ESP+EDX*4+5*4] // first arg is furthest out + TEST ECX,ECX + JZ @@0 + CMP [EAX],ECX // is dest = first arg? + JNE @@0 + MOV EDI,EAX // EDI nonzero -> potential appendstr case +@@0: + XOR EAX,EAX +@@loop1: + MOV ECX,[ESP+EDX*4+5*4] + TEST ECX,ECX + JE @@1 + ADD EAX,[ECX-skew].StrRec.length + CMP EDI,ECX // is dest an arg besides arg1? + JNE @@1 + XOR EDI,EDI // can't appendstr - dest is multiple args +@@1: + DEC EDX + JNE @@loop1 + +@@append: + TEST EDI,EDI // dest is 1st and only 1st arg? + JZ @@copy + MOV EDX,EAX // length into EDX + MOV EAX,EDI // ptr to str into EAX + MOV ESI,[EDI] + MOV ESI,[ESI-skew].StrRec.Length // save old size before realloc + CALL _LStrSetLength + PUSH EDI // append other strs to dest + ADD ESI,[EDI] // end of old string + DEC EBX + JMP @@loop2 + +@@copy: + CALL _NewAnsiString + PUSH EAX + MOV ESI,EAX + +@@loop2: + MOV EAX,[ESP+EBX*4+6*4] + MOV EDX,ESI + TEST EAX,EAX + JE @@2 + MOV ECX,[EAX-skew].StrRec.length + ADD ESI,ECX + CALL Move +@@2: + DEC EBX + JNE @@loop2 + + POP EDX + POP EAX + TEST EDI,EDI + JNZ @@exit + + TEST EDX,EDX + JE @@skip + DEC [EDX-skew].StrRec.refCnt // EDX = local temp str +@@skip: + CALL _LStrAsg + +@@exit: + POP EDX + POP EDI + POP ESI + POP EBX + POP EAX + LEA ESP,[ESP+EDX*4] + JMP EAX +end; + + +procedure _LStrCmp{left: AnsiString; right: AnsiString}; +asm +{ ->EAX = Pointer to left string } +{ EDX = Pointer to right string } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + CMP EAX,EDX + JE @@exit + + TEST ESI,ESI + JE @@str1null + + TEST EDI,EDI + JE @@str2null + + MOV EAX,[ESI-skew].StrRec.length + MOV EDX,[EDI-skew].StrRec.length + + SUB EAX,EDX { eax = len1 - len2 } + JA @@skip1 + ADD EDX,EAX { edx = len2 + (len1 - len2) = len1 } + +@@skip1: + PUSH EDX + SHR EDX,2 + JE @@cmpRest +@@longLoop: + MOV ECX,[ESI] + MOV EBX,[EDI] + CMP ECX,EBX + JNE @@misMatch + DEC EDX + JE @@cmpRestP4 + MOV ECX,[ESI+4] + MOV EBX,[EDI+4] + CMP ECX,EBX + JNE @@misMatch + ADD ESI,8 + ADD EDI,8 + DEC EDX + JNE @@longLoop + JMP @@cmpRest +@@cmpRestP4: + ADD ESI,4 + ADD EDI,4 +@@cmpRest: + POP EDX + AND EDX,3 + JE @@equal + + MOV ECX,[ESI] + MOV EBX,[EDI] + CMP CL,BL + JNE @@exit + DEC EDX + JE @@equal + CMP CH,BH + JNE @@exit + DEC EDX + JE @@equal + AND EBX,$00FF0000 + AND ECX,$00FF0000 + CMP ECX,EBX + JNE @@exit + +@@equal: + ADD EAX,EAX + JMP @@exit + +@@str1null: + MOV EDX,[EDI-skew].StrRec.length + SUB EAX,EDX + JMP @@exit + +@@str2null: + MOV EAX,[ESI-skew].StrRec.length + SUB EAX,EDX + JMP @@exit + +@@misMatch: + POP EDX + CMP CL,BL + JNE @@exit + CMP CH,BH + JNE @@exit + SHR ECX,16 + SHR EBX,16 + CMP CL,BL + JNE @@exit + CMP CH,BH + +@@exit: + POP EDI + POP ESI + POP EBX + +end; + +function _LStrAddRef(var str): Pointer; +{$IFDEF PUREPASCAL} +var + P: PStrRec; +begin + P := Pointer(Integer(str) - sizeof(StrRec)); + if P <> nil then + if P.refcnt >= 0 then + InterlockedIncrement(P.refcnt); + Result := Pointer(str); +end; +{$ELSE} +asm + { -> EAX str } + TEST EAX,EAX + JE @@exit + MOV EDX,[EAX-skew].StrRec.refCnt + INC EDX + JLE @@exit +{X LOCK} INC [EAX-skew].StrRec.refCnt +@@exit: +end; +{$ENDIF} + +function PICEmptyString: PWideChar; +begin + Result := ''; +end; + +function _LStrToPChar(const s: AnsiString): PChar; +{$IFDEF PUREPASCAL} +const + EmptyString = ''; +begin + if Pointer(s) = nil then + Result := EmptyString + else + Result := Pointer(s); +end; +{$ELSE} +asm + { -> EAX pointer to str } + { <- EAX pointer to PChar } + + TEST EAX,EAX + JE @@handle0 + RET +{$IFDEF PIC} +@@handle0: + JMP PICEmptyString +{$ELSE} +@@zeroByte: + DB 0 +@@handle0: + MOV EAX,offset @@zeroByte +{$ENDIF} +end; +{$ENDIF} + +function InternalUniqueString(var str): Pointer; +asm + { -> EAX pointer to str } + { <- EAX pointer to unique copy } + MOV EDX,[EAX] + TEST EDX,EDX + JE @@exit + MOV ECX,[EDX-skew].StrRec.refCnt + DEC ECX + JE @@exit + + PUSH EBX + MOV EBX,EAX + MOV EAX,[EDX-skew].StrRec.length + CALL _NewAnsiString + MOV EDX,EAX + MOV EAX,[EBX] + MOV [EBX],EDX + PUSH EAX + MOV ECX,[EAX-skew].StrRec.length + CALL Move + POP EAX + MOV ECX,[EAX-skew].StrRec.refCnt + DEC ECX + JL @@skip +{X LOCK} DEC [EAX-skew].StrRec.refCnt + JNZ @@skip + LEA EAX,[EAX-skew].StrRec.refCnt { if refCnt now zero, deallocate} + CALL _FreeMem +@@skip: + MOV EDX,[EBX] + POP EBX +@@exit: + MOV EAX,EDX +end; + + +procedure UniqueString(var str: AnsiString); +asm + JMP InternalUniqueString +end; + +procedure _UniqueStringA(var str: AnsiString); +asm + JMP InternalUniqueString +end; + +procedure UniqueString(var str: WideString); +asm +{$IFDEF LINUX} + JMP InternalUniqueString +{$ENDIF} +{$IFDEF MSWINDOWS} + // nothing to do - Windows WideStrings are always single reference +{$ENDIF} +end; + +procedure _UniqueStringW(var str: WideString); +asm +{$IFDEF LINUX} + JMP InternalUniqueString +{$ENDIF} +{$IFDEF MSWINDOWS} + // nothing to do - Windows WideStrings are always single reference +{$ENDIF} +end; + +procedure _LStrCopy{ const s : AnsiString; index, count : Integer) : AnsiString}; +asm + { ->EAX Source string } + { EDX index } + { ECX count } + { [ESP+4] Pointer to result string } + + PUSH EBX + + TEST EAX,EAX + JE @@srcEmpty + + MOV EBX,[EAX-skew].StrRec.length + TEST EBX,EBX + JE @@srcEmpty + +{ make index 0-based and limit to 0 <= index < Length(src) } + + DEC EDX + JL @@smallInx + CMP EDX,EBX + JGE @@bigInx + +@@cont1: + +{ limit count to satisfy 0 <= count <= Length(src) - index } + + SUB EBX,EDX { calculate Length(src) - index } + TEST ECX,ECX + JL @@smallCount + CMP ECX,EBX + JG @@bigCount + +@@cont2: + + ADD EDX,EAX + MOV EAX,[ESP+4+4] + CALL _LStrFromPCharLen + JMP @@exit + +@@smallInx: + XOR EDX,EDX + JMP @@cont1 +@@bigCount: + MOV ECX,EBX + JMP @@cont2 +@@bigInx: +@@smallCount: +@@srcEmpty: + MOV EAX,[ESP+4+4] + CALL _LStrClr +@@exit: + POP EBX + RET 4 +end; + + +procedure _LStrDelete{ var s : AnsiString; index, count : Integer }; +asm + { ->EAX Pointer to s } + { EDX index } + { ECX count } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + CALL UniqueString + + MOV EDX,[EBX] + TEST EDX,EDX { source already empty: nothing to do } + JE @@exit + + MOV ECX,[EDX-skew].StrRec.length + +{ make index 0-based, if not in [0 .. Length(s)-1] do nothing } + + DEC ESI + JL @@exit + CMP ESI,ECX + JGE @@exit + +{ limit count to [0 .. Length(s) - index] } + + TEST EDI,EDI + JLE @@exit + SUB ECX,ESI { ECX = Length(s) - index } + CMP EDI,ECX + JLE @@1 + MOV EDI,ECX +@@1: + +{ move length - index - count characters from s+index+count to s+index } + + SUB ECX,EDI { ECX = Length(s) - index - count } + ADD EDX,ESI { EDX = s+index } + LEA EAX,[EDX+EDI] { EAX = s+index+count } + CALL Move + +{ set length(s) to length(s) - count } + + MOV EDX,[EBX] + MOV EAX,EBX + MOV EDX,[EDX-skew].StrRec.length + SUB EDX,EDI + CALL _LStrSetLength + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +procedure _LStrInsert{ const source : AnsiString; var s : AnsiString; index : Integer }; +asm + { -> EAX source string } + { EDX pointer to destination string } + { ECX index } + + TEST EAX,EAX + JE @@nothingToDo + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + +{ make index 0-based and limit to 0 <= index <= Length(s) } + + MOV EDX,[EDX] + PUSH EDX + TEST EDX,EDX + JE @@sIsNull + MOV EDX,[EDX-skew].StrRec.length +@@sIsNull: + DEC EDI + JGE @@indexNotLow + XOR EDI,EDI +@@indexNotLow: + CMP EDI,EDX + JLE @@indexNotHigh + MOV EDI,EDX +@@indexNotHigh: + + MOV EBP,[EBX-skew].StrRec.length + +{ set length of result to length(source) + length(s) } + + MOV EAX,ESI + ADD EDX,EBP + CALL _LStrSetLength + POP EAX + + CMP EAX,EBX + JNE @@notInsertSelf + MOV EBX,[ESI] + +@@notInsertSelf: + +{ move length(s) - length(source) - index chars from s+index to s+index+length(source) } + + MOV EAX,[ESI] { EAX = s } + LEA EDX,[EDI+EBP] { EDX = index + length(source) } + MOV ECX,[EAX-skew].StrRec.length + SUB ECX,EDX { ECX = length(s) - length(source) - index } + ADD EDX,EAX { EDX = s + index + length(source) } + ADD EAX,EDI { EAX = s + index } + CALL Move + +{ copy length(source) chars from source to s+index } + + MOV EAX,EBX + MOV EDX,[ESI] + MOV ECX,EBP + ADD EDX,EDI + CALL Move + +@@exit: + POP EBP + POP EDI + POP ESI + POP EBX +@@nothingToDo: +end; + + +procedure _LStrPos{ const substr : AnsiString; const s : AnsiString ) : Integer}; +asm +{ ->EAX Pointer to substr } +{ EDX Pointer to string } +{ <-EAX Position of substr in s or 0 } + + TEST EAX,EAX + JE @@noWork + + TEST EDX,EDX + JE @@stringEmpty + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX { Point ESI to substr } + MOV EDI,EDX { Point EDI to s } + + MOV ECX,[EDI-skew].StrRec.length { ECX = Length(s) } + + PUSH EDI { remember s position to calculate index } + + MOV EDX,[ESI-skew].StrRec.length { EDX = Length(substr) } + + DEC EDX { EDX = Length(substr) - 1 } + JS @@fail { < 0 ? return 0 } + MOV AL,[ESI] { AL = first char of substr } + INC ESI { Point ESI to 2'nd char of substr } + + SUB ECX,EDX { #positions in s to look at } + { = Length(s) - Length(substr) + 1 } + JLE @@fail +@@loop: + REPNE SCASB + JNE @@fail + MOV EBX,ECX { save outer loop counter } + PUSH ESI { save outer loop substr pointer } + PUSH EDI { save outer loop s pointer } + + MOV ECX,EDX + REPE CMPSB + POP EDI { restore outer loop s pointer } + POP ESI { restore outer loop substr pointer } + JE @@found + MOV ECX,EBX { restore outer loop counter } + JMP @@loop + +@@fail: + POP EDX { get rid of saved s pointer } + XOR EAX,EAX + JMP @@exit + +@@stringEmpty: + XOR EAX,EAX + JMP @@noWork + +@@found: + POP EDX { restore pointer to first char of s } + MOV EAX,EDI { EDI points of char after match } + SUB EAX,EDX { the difference is the correct index } +@@exit: + POP EDI + POP ESI + POP EBX +@@noWork: +end; + + +procedure _LStrSetLength{ var str: AnsiString; newLength: Integer}; +asm + { -> EAX Pointer to str } + { EDX new length } + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV ESI,EDX + XOR EDI,EDI + + TEST EDX,EDX + JLE @@setString + + MOV EAX,[EBX] + TEST EAX,EAX + JE @@copyString + + CMP [EAX-skew].StrRec.refCnt,1 + JNE @@copyString + + SUB EAX,rOff + ADD EDX,rOff+1 + PUSH EAX + MOV EAX,ESP + CALL _ReallocMem + POP EAX + ADD EAX,rOff + MOV [EBX],EAX + MOV [EAX-skew].StrRec.length,ESI + MOV BYTE PTR [EAX+ESI],0 + JMP @@exit + +@@copyString: + MOV EAX,EDX + CALL _NewAnsiString + MOV EDI,EAX + + MOV EAX,[EBX] + TEST EAX,EAX + JE @@setString + + MOV EDX,EDI + MOV ECX,[EAX-skew].StrRec.length + CMP ECX,ESI + JL @@moveString + MOV ECX,ESI + +@@moveString: + CALL Move + +@@setString: + MOV EAX,EBX + CALL _LStrClr + MOV [EBX],EDI + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +procedure _LStrOfChar{ c: Char; count: Integer): AnsiString }; +asm + { -> AL c } + { EDX count } + { ECX result } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + MOV EAX,ECX + CALL _LStrClr + + TEST ESI,ESI + JLE @@exit + + MOV EAX,ESI + CALL _NewAnsiString + + MOV [EDI],EAX + + MOV EDX,ESI + MOV CL,BL + + CALL _FillChar + +@@exit: + POP EDI + POP ESI + POP EBX + +end; + + +function _Write0LString(var t: TTextRec; const s: AnsiString): Pointer; +begin + Result := _WriteLString(t, s, 0); +end; + + +function _WriteLString(var t: TTextRec; const s: AnsiString; width: Longint): Pointer; +{$IFDEF PUREPASCAL} +var + i: Integer; +begin + i := Length(s); + _WriteSpaces(t, width - i); + Result := _WriteBytes(t, s[1], i); +end; +{$ELSE} +asm + { -> EAX Pointer to text record } + { EDX Pointer to AnsiString } + { ECX Field width } + + PUSH EBX + + MOV EBX,EDX + + MOV EDX,ECX + XOR ECX,ECX + TEST EBX,EBX + JE @@skip + MOV ECX,[EBX-skew].StrRec.length + SUB EDX,ECX +@@skip: + PUSH ECX + CALL _WriteSpaces + POP ECX + + MOV EDX,EBX + POP EBX + JMP _WriteBytes +end; +{$ENDIF} + + +function _Write0WString(var t: TTextRec; const s: WideString): Pointer; +begin + Result := _WriteWString(t, s, 0); +end; + + +function _WriteWString(var t: TTextRec; const s: WideString; width: Longint): Pointer; +var + i: Integer; +begin + i := Length(s); + _WriteSpaces(t, width - i); + Result := _WriteLString(t, AnsiString(s), 0); +end; + + +function _Write0WCString(var t: TTextRec; s: PWideChar): Pointer; +begin + Result := _WriteWCString(t, s, 0); +end; + + +function _WriteWCString(var t: TTextRec; s: PWideChar; width: Longint): Pointer; +var + i: Integer; +begin + i := 0; + if (s <> nil) then + while s[i] <> #0 do + Inc(i); + + _WriteSpaces(t, width - i); + Result := _WriteLString(t, AnsiString(s), 0); +end; + + +function _Write0WChar(var t: TTextRec; c: WideChar): Pointer; +begin + Result := _WriteWChar(t, c, 0); +end; + + +function _WriteWChar(var t: TTextRec; c: WideChar; width: Integer): Pointer; +begin + _WriteSpaces(t, width - 1); + Result := _WriteLString(t, AnsiString(c), 0); +end; + + +{$IFDEF MSWINDOWS} +procedure WStrError; +asm + MOV AL,reOutOfMemory + JMP Error +end; +{$ENDIF} + +function _NewWideString(CharLength: Longint): Pointer; +{$IFDEF LINUX} +begin + Result := _NewAnsiString(CharLength*2); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + TEST EAX,EAX + JE @@1 + PUSH EAX + PUSH 0 + CALL SysAllocStringLen + TEST EAX,EAX + JE WStrError +@@1: +end; +{$ENDIF} + +procedure WStrSet(var S: WideString; P: PWideChar); +{$IFDEF PUREPASCAL} +var + Temp: Pointer; +begin + Temp := Pointer(InterlockedExchange(Pointer(S), Pointer(P))); + if Temp <> nil then + _WStrClr(Temp); +end; +{$ELSE} +asm +{$IFDEF LINUX} + XCHG [EAX],EDX + TEST EDX,EDX + JZ @@1 + PUSH EDX + MOV EAX, ESP + CALL _WStrClr + POP EAX +{$ENDIF} +{$IFDEF MSWINDOWS} + XCHG [EAX],EDX + TEST EDX,EDX + JZ @@1 + PUSH EDX + CALL SysFreeString +{$ENDIF} +@@1: +end; +{$ENDIF} + + +procedure WStrClr; +asm + JMP _WStrClr +end; + +procedure _WStrClr(var S); +{$IFDEF LINUX} +asm + JMP _LStrClr; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + { -> EAX Pointer to WideString } + + MOV EDX,[EAX] + TEST EDX,EDX + JE @@1 + MOV DWORD PTR [EAX],0 + PUSH EAX + PUSH EDX + CALL SysFreeString + POP EAX +@@1: +end; +{$ENDIF} + + +procedure WStrArrayClr; +asm + JMP _WStrArrayClr; +end; + +procedure _WStrArrayClr(var StrArray; Count: Integer); +{$IFDEF LINUX} +asm + JMP _LStrArrayClr +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + PUSH EBX + PUSH ESI + MOV EBX,EAX + MOV ESI,EDX +@@1: MOV EAX,[EBX] + TEST EAX,EAX + JE @@2 + MOV DWORD PTR [EBX],0 + PUSH EAX + CALL SysFreeString +@@2: ADD EBX,4 + DEC ESI + JNE @@1 + POP ESI + POP EBX +end; +{$ENDIF} + + +procedure _WStrAsg(var Dest: WideString; const Source: WideString); +{$IFDEF LINUX} +asm + JMP _LStrAsg +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + { -> EAX Pointer to WideString } + { EDX Pointer to data } + TEST EDX,EDX + JE _WStrClr + MOV ECX,[EDX-4] + SHR ECX,1 + JE _WStrClr + PUSH ECX + PUSH EDX + PUSH EAX + CALL SysReAllocStringLen + TEST EAX,EAX + JE WStrError +end; +{$ENDIF} + +procedure _WStrLAsg(var Dest: WideString; const Source: WideString); +{$IFDEF LINUX} +asm + JMP _LStrLAsg +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + JMP _WStrAsg +end; +{$ENDIF} + +procedure _WStrFromPCharLen(var Dest: WideString; Source: PAnsiChar; Length: Integer); +var + DestLen: Integer; + Buffer: array[0..2047] of WideChar; +begin + if Length <= 0 then + begin + _WStrClr(Dest); + Exit; + end; + if Length+1 < High(Buffer) then + begin + DestLen := WCharFromChar(Buffer, High(Buffer), Source, Length); + if DestLen > 0 then + begin + _WStrFromPWCharLen(Dest, @Buffer, DestLen); + Exit; + end; + end; + + DestLen := (Length + 1); + _WStrSetLength(Dest, DestLen); // overallocate, trim later + DestLen := WCharFromChar(Pointer(Dest), DestLen, Source, Length); + if DestLen < 0 then DestLen := 0; + _WStrSetLength(Dest, DestLen); +end; + +procedure _WStrFromPWCharLen(var Dest: WideString; Source: PWideChar; CharLength: Integer); +{$IFDEF LINUX} +var + Temp: Pointer; +begin + Temp := Pointer(Dest); + if CharLength > 0 then + begin + Pointer(Dest) := _NewWideString(CharLength); + if Source <> nil then + Move(Source^, Pointer(Dest)^, CharLength * sizeof(WideChar)); + end + else + Pointer(Dest) := nil; + _WStrClr(Temp); +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + { -> EAX Pointer to WideString (dest) } + { EDX Pointer to characters (source) } + { ECX number of characters (not bytes) } + TEST ECX,ECX + JE _WStrClr + + PUSH EAX + + PUSH ECX + PUSH EDX + CALL SysAllocStringLen + TEST EAX,EAX + JE WStrError + + POP EDX + PUSH [EDX].PWideChar + MOV [EDX],EAX + + CALL SysFreeString +end; +{$ENDIF} + + +procedure _WStrFromChar(var Dest: WideString; Source: AnsiChar); +asm + PUSH EDX + MOV EDX,ESP + MOV ECX,1 + CALL _WStrFromPCharLen + POP EDX +end; + + +procedure _WStrFromWChar(var Dest: WideString; Source: WideChar); +asm + { -> EAX Pointer to WideString (dest) } + { EDX character (source) } + PUSH EDX + MOV EDX,ESP + MOV ECX,1 + CALL _WStrFromPWCharLen + POP EDX +end; + + +procedure _WStrFromPChar(var Dest: WideString; Source: PAnsiChar); +asm + { -> EAX Pointer to WideString (dest) } + { EDX Pointer to character (source) } + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CL,[EDX+0] + JE @@4 + CMP CL,[EDX+1] + JE @@3 + CMP CL,[EDX+2] + JE @@2 + CMP CL,[EDX+3] + JE @@1 + ADD EDX,4 + JMP @@0 +@@1: INC EDX +@@2: INC EDX +@@3: INC EDX +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX +@@5: JMP _WStrFromPCharLen +end; + + +procedure _WStrFromPWChar(var Dest: WideString; Source: PWideChar); +asm + { -> EAX Pointer to WideString (dest) } + { EDX Pointer to character (source) } + XOR ECX,ECX + TEST EDX,EDX + JE @@5 + PUSH EDX +@@0: CMP CX,[EDX+0] + JE @@4 + CMP CX,[EDX+2] + JE @@3 + CMP CX,[EDX+4] + JE @@2 + CMP CX,[EDX+6] + JE @@1 + ADD EDX,8 + JMP @@0 +@@1: ADD EDX,2 +@@2: ADD EDX,2 +@@3: ADD EDX,2 +@@4: MOV ECX,EDX + POP EDX + SUB ECX,EDX + SHR ECX,1 +@@5: JMP _WStrFromPWCharLen +end; + + +procedure _WStrFromString(var Dest: WideString; const Source: ShortString); +asm + XOR ECX,ECX + MOV CL,[EDX] + INC EDX + JMP _WStrFromPCharLen +end; + + +procedure _WStrFromArray(var Dest: WideString; Source: PAnsiChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASB + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _WStrFromPCharLen +end; + + +procedure _WStrFromWArray(var Dest: WideString; Source: PWideChar; Length: Integer); +asm + PUSH EDI + PUSH EAX + PUSH ECX + MOV EDI,EDX + XOR EAX,EAX + REPNE SCASW + JNE @@1 + NOT ECX +@@1: POP EAX + ADD ECX,EAX + POP EAX + POP EDI + JMP _WStrFromPWCharLen +end; + + +procedure _WStrFromLStr(var Dest: WideString; const Source: AnsiString); +asm + XOR ECX,ECX + TEST EDX,EDX + JE @@1 + MOV ECX,[EDX-4] +@@1: JMP _WStrFromPCharLen +end; + + +procedure _WStrToString(Dest: PShortString; const Source: WideString; MaxLen: Integer); +var + SourceLen, DestLen: Integer; + Buffer: array[0..511] of Char; +begin + if MaxLen > 255 then MaxLen := 255; + SourceLen := Length(Source); + if SourceLen >= MaxLen then SourceLen := MaxLen; + if SourceLen = 0 then + DestLen := 0 + else + begin + DestLen := CharFromWChar(Buffer, High(Buffer), PWideChar(Pointer(Source)), SourceLen); + if DestLen < 0 then + DestLen := 0 + else if DestLen > MaxLen then + DestLen := MaxLen; + end; + Dest^[0] := Chr(DestLen); + if DestLen > 0 then Move(Buffer, Dest^[1], DestLen); +end; + +function _WStrToPWChar(const S: WideString): PWideChar; +{$IFDEF PUREPASCAL} +const + EmptyString = ''; +begin + if Pointer(S) = nil then + Result := EmptyString + else + Result := Pointer(S); +end; +{$ELSE} +asm + TEST EAX,EAX + JE @@1 + RET +{$IFDEF PIC} +@@1: JMP PICEmptyString +{$ELSE} + NOP +@@0: DW 0 +@@1: MOV EAX,OFFSET @@0 +{$ENDIF} +end; +{$ENDIF} + + +function _WStrLen(const S: WideString): Integer; +{$IFDEF PUREPASCAL} +begin + if Pointer(S) = nil then + Result := 0 + else + Result := PInteger(Integer(S) - 4)^ div sizeof(WideChar); +end; +{$ELSE} +asm + { -> EAX Pointer to WideString data } + TEST EAX,EAX + JE @@1 + MOV EAX,[EAX-4] + SHR EAX,1 +@@1: +end; +{$ENDIF} + +procedure _WStrCat(var Dest: WideString; const Source: WideString); +var + DestLen, SourceLen: Integer; + NewStr: PWideChar; +begin + SourceLen := Length(Source); + if SourceLen <> 0 then + begin + DestLen := Length(Dest); + NewStr := _NewWideString(DestLen + SourceLen); + if DestLen > 0 then + Move(Pointer(Dest)^, NewStr^, DestLen * sizeof(WideChar)); + Move(Pointer(Source)^, NewStr[DestLen], SourceLen * sizeof(WideChar)); + WStrSet(Dest, NewStr); + end; +end; + + +procedure _WStrCat3(var Dest: WideString; const Source1, Source2: WideString); +var + Source1Len, Source2Len: Integer; + NewStr: PWideChar; +begin + Source1Len := Length(Source1); + Source2Len := Length(Source2); + if (Source1Len <> 0) or (Source2Len <> 0) then + begin + NewStr := _NewWideString(Source1Len + Source2Len); + Move(Pointer(Source1)^, Pointer(NewStr)^, Source1Len * sizeof(WideChar)); + Move(Pointer(Source2)^, NewStr[Source1Len], Source2Len * sizeof(WideChar)); + WStrSet(Dest, NewStr); + end; +end; + + +procedure _WStrCatN{var Dest: WideString; ArgCnt: Integer; ...}; +asm + { ->EAX = Pointer to dest } + { EDX = number of args (>= 3) } + { [ESP+4], [ESP+8], ... crgCnt WideString arguments } + + PUSH EBX + PUSH ESI + PUSH EDX + PUSH EAX + MOV EBX,EDX + + XOR EAX,EAX +@@loop1: + MOV ECX,[ESP+EDX*4+4*4] + TEST ECX,ECX + JE @@1 + ADD EAX,[ECX-4] +@@1: + DEC EDX + JNE @@loop1 + + SHR EAX,1 + CALL _NewWideString + PUSH EAX + MOV ESI,EAX + +@@loop2: + MOV EAX,[ESP+EBX*4+5*4] + MOV EDX,ESI + TEST EAX,EAX + JE @@2 + MOV ECX,[EAX-4] + ADD ESI,ECX + CALL Move +@@2: + DEC EBX + JNE @@loop2 + + POP EDX + POP EAX + CALL WStrSet + + POP EDX + POP ESI + POP EBX + POP EAX + LEA ESP,[ESP+EDX*4] + JMP EAX +end; + + +procedure _WStrCmp{left: WideString; right: WideString}; +asm +{ ->EAX = Pointer to left string } +{ EDX = Pointer to right string } + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX + MOV EDI,EDX + + CMP EAX,EDX + JE @@exit + + TEST ESI,ESI + JE @@str1null + + TEST EDI,EDI + JE @@str2null + + MOV EAX,[ESI-4] + MOV EDX,[EDI-4] + + SUB EAX,EDX { eax = len1 - len2 } + JA @@skip1 + ADD EDX,EAX { edx = len2 + (len1 - len2) = len1 } + +@@skip1: + PUSH EDX + SHR EDX,2 + JE @@cmpRest +@@longLoop: + MOV ECX,[ESI] + MOV EBX,[EDI] + CMP ECX,EBX + JNE @@misMatch + DEC EDX + JE @@cmpRestP4 + MOV ECX,[ESI+4] + MOV EBX,[EDI+4] + CMP ECX,EBX + JNE @@misMatch + ADD ESI,8 + ADD EDI,8 + DEC EDX + JNE @@longLoop + JMP @@cmpRest +@@cmpRestP4: + ADD ESI,4 + ADD EDI,4 +@@cmpRest: + POP EDX + AND EDX,2 + JE @@equal + + MOV CX,[ESI] + MOV BX,[EDI] + CMP CX,BX + JNE @@exit + +@@equal: + ADD EAX,EAX + JMP @@exit + +@@str1null: + MOV EDX,[EDI-4] + SUB EAX,EDX + JMP @@exit + +@@str2null: + MOV EAX,[ESI-4] + SUB EAX,EDX + JMP @@exit + +@@misMatch: + POP EDX + CMP CX,BX + JNE @@exit + SHR ECX,16 + SHR EBX,16 + CMP CX,BX + +@@exit: + POP EDI + POP ESI + POP EBX +end; + + +function _WStrCopy(const S: WideString; Index, Count: Integer): WideString; +var + L, N: Integer; +begin + L := Length(S); + if Index < 1 then Index := 0 else + begin + Dec(Index); + if Index > L then Index := L; + end; + if Count < 0 then N := 0 else + begin + N := L - Index; + if N > Count then N := Count; + end; + _WStrFromPWCharLen(Result, PWideChar(Pointer(S)) + Index, N); +end; + + +procedure _WStrDelete(var S: WideString; Index, Count: Integer); +var + L, N: Integer; + NewStr: PWideChar; +begin + L := Length(S); + if (L > 0) and (Index >= 1) and (Index <= L) and (Count > 0) then + begin + Dec(Index); + N := L - Index - Count; + if N < 0 then N := 0; + if (Index = 0) and (N = 0) then NewStr := nil else + begin + NewStr := _NewWideString(Index + N); + if Index > 0 then + Move(Pointer(S)^, NewStr^, Index * 2); + if N > 0 then + Move(PWideChar(Pointer(S))[L - N], NewStr[Index], N * 2); + end; + WStrSet(S, NewStr); + end; +end; + + +procedure _WStrInsert(const Source: WideString; var Dest: WideString; Index: Integer); +var + SourceLen, DestLen: Integer; + NewStr: PWideChar; +begin + SourceLen := Length(Source); + if SourceLen > 0 then + begin + DestLen := Length(Dest); + if Index < 1 then Index := 0 else + begin + Dec(Index); + if Index > DestLen then Index := DestLen; + end; + NewStr := _NewWideString(DestLen + SourceLen); + if Index > 0 then + Move(Pointer(Dest)^, NewStr^, Index * 2); + Move(Pointer(Source)^, NewStr[Index], SourceLen * 2); + if Index < DestLen then + Move(PWideChar(Pointer(Dest))[Index], NewStr[Index + SourceLen], + (DestLen - Index) * 2); + WStrSet(Dest, NewStr); + end; +end; + + +procedure _WStrPos{ const substr : WideString; const s : WideString ) : Integer}; +asm +{ ->EAX Pointer to substr } +{ EDX Pointer to string } +{ <-EAX Position of substr in s or 0 } + + TEST EAX,EAX + JE @@noWork + + TEST EDX,EDX + JE @@stringEmpty + + PUSH EBX + PUSH ESI + PUSH EDI + + MOV ESI,EAX { Point ESI to substr } + MOV EDI,EDX { Point EDI to s } + + MOV ECX,[EDI-4] { ECX = Length(s) } + SHR ECX,1 + + PUSH EDI { remember s position to calculate index } + + MOV EDX,[ESI-4] { EDX = Length(substr) } + SHR EDX,1 + + DEC EDX { EDX = Length(substr) - 1 } + JS @@fail { < 0 ? return 0 } + MOV AX,[ESI] { AL = first char of substr } + ADD ESI,2 { Point ESI to 2'nd char of substr } + + SUB ECX,EDX { #positions in s to look at } + { = Length(s) - Length(substr) + 1 } + JLE @@fail +@@loop: + REPNE SCASW + JNE @@fail + MOV EBX,ECX { save outer loop counter } + PUSH ESI { save outer loop substr pointer } + PUSH EDI { save outer loop s pointer } + + MOV ECX,EDX + REPE CMPSW + POP EDI { restore outer loop s pointer } + POP ESI { restore outer loop substr pointer } + JE @@found + MOV ECX,EBX { restore outer loop counter } + JMP @@loop + +@@fail: + POP EDX { get rid of saved s pointer } + XOR EAX,EAX + JMP @@exit + +@@stringEmpty: + XOR EAX,EAX + JMP @@noWork + +@@found: + POP EDX { restore pointer to first char of s } + MOV EAX,EDI { EDI points of char after match } + SUB EAX,EDX { the difference is the correct index } + SHR EAX,1 +@@exit: + POP EDI + POP ESI + POP EBX +@@noWork: +end; + + +procedure _WStrSetLength(var S: WideString; NewLength: Integer); +var + NewStr: PWideChar; + Count: Integer; +begin + NewStr := nil; + if NewLength > 0 then + begin + NewStr := _NewWideString(NewLength); + Count := Length(S); + if Count > 0 then + begin + if Count > NewLength then Count := NewLength; + Move(Pointer(S)^, NewStr^, Count * 2); + end; + end; + WStrSet(S, NewStr); +end; + + +function _WStrOfWChar(Ch: WideChar; Count: Integer): WideString; +var + P: PWideChar; +begin + _WStrFromPWCharLen(Result, nil, Count); + P := Pointer(Result); + while Count > 0 do + begin + Dec(Count); + P[Count] := Ch; + end; +end; + +procedure WStrAddRef; +asm + JMP _WStrAddRef +end; + +function _WStrAddRef(var str: WideString): Pointer; +{$IFDEF LINUX} +asm + JMP _LStrAddRef +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +asm + MOV EDX,[EAX] + TEST EDX,EDX + JE @@1 + PUSH EAX + MOV ECX,[EDX-4] + SHR ECX,1 + PUSH ECX + PUSH EDX + CALL SysAllocStringLen + POP EDX + TEST EAX,EAX + JE WStrError + MOV [EDX],EAX +@@1: +end; +{$ENDIF} + +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); +{$IFDEF PUREPASCAL} +var + FT: PFieldTable; + I: Cardinal; +begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + for I := FT.Count-1 downto 0 do + _InitializeArray(Pointer(Cardinal(P) + FT.Fields[I].Offset), FT.Fields[I].TypeInfo^, 1); +end; +{$ELSE} +asm + { -> EAX pointer to record to be initialized } + { EDX pointer to type info } + + XOR ECX,ECX + + PUSH EBX + MOV CL,[EDX+1] { type name length } + + PUSH ESI + PUSH EDI + + MOV EBX,EAX // PIC safe. See comment above + LEA ESI,[EDX+ECX+2+8] { address of destructable fields } + MOV EDI,[EDX+ECX+2+4] { number of destructable fields } + +@@loop: + + MOV EDX,[ESI] + MOV EAX,[ESI+4] + ADD EAX,EBX + MOV EDX,[EDX] + MOV ECX,1 + CALL _InitializeArray + ADD ESI,8 + DEC EDI + JG @@loop + + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + + +const + tkLString = 10; + tkWString = 11; + tkVariant = 12; + tkArray = 13; + tkRecord = 14; + tkInterface = 15; + tkDynArray = 17; + +procedure _InitializeArray(p: Pointer; typeInfo: Pointer; elemCount: Cardinal); +{$IFDEF PUREPASCAL} +var + FT: PFieldTable; +begin + if elemCount = 0 then Exit; + case PTypeInfo(typeInfo).Kind of + tkLString, tkWString, tkInterface, tkDynArray: + while elemCount > 0 do + begin + PInteger(P)^ := 0; + Inc(Integer(P), 4); + Dec(elemCount); + end; + tkVariant: + while elemCount > 0 do + begin + PInteger(P)^ := 0; + PInteger(Integer(P)+4)^ := 0; + PInteger(Integer(P)+8)^ := 0; + PInteger(Integer(P)+12)^ := 0; + Inc(Integer(P), sizeof(Variant)); + Dec(elemCount); + end; + tkArray: + begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + while elemCount > 0 do + begin + _InitializeArray(P, FT.Fields[0].TypeInfo^, FT.Count); + Inc(Integer(P), FT.Size); + Dec(elemCount); + end; + end; + tkRecord: + begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + while elemCount > 0 do + begin + _InitializeRecord(P, typeInfo); + Inc(Integer(P), FT.Size); + Dec(elemCount); + end; + end; + else + Error(reInvalidPtr); + end; +end; +{$ELSE} +asm + { -> EAX pointer to data to be initialized } + { EDX pointer to type info describing data } + { ECX number of elements of that type } + + TEST ECX, ECX + JZ @@zerolength + + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX // PIC safe. See comment above + MOV ESI,EDX + MOV EDI,ECX + + XOR EDX,EDX + MOV AL,[ESI] + MOV DL,[ESI+1] + XOR ECX,ECX + + CMP AL,tkLString + JE @@LString + CMP AL,tkWString + JE @@WString + CMP AL,tkVariant + JE @@Variant + CMP AL,tkArray + JE @@Array + CMP AL,tkRecord + JE @@Record + CMP AL,tkInterface + JE @@Interface + CMP AL,tkDynArray + JE @@DynArray + MOV AL,reInvalidPtr + POP EDI + POP ESI + POP EBX + JMP Error + +@@LString: +@@WString: +@@Interface: +@@DynArray: + MOV [EBX],ECX + ADD EBX,4 + DEC EDI + JG @@LString + JMP @@exit + +@@Variant: + MOV [EBX ],ECX + MOV [EBX+ 4],ECX + MOV [EBX+ 8],ECX + MOV [EBX+12],ECX + ADD EBX,16 + DEC EDI + JG @@Variant + JMP @@exit + +@@Array: + PUSH EBP + MOV EBP,EDX +@@ArrayLoop: + MOV EDX,[ESI+EBP+2+8] // address of destructable fields typeinfo + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] // size in bytes of the array data + MOV ECX,[ESI+EBP+2+4] // number of destructable fields + MOV EDX,[EDX] + CALL _InitializeArray + DEC EDI + JG @@ArrayLoop + POP EBP + JMP @@exit + +@@Record: + PUSH EBP + MOV EBP,EDX +@@RecordLoop: + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV EDX,ESI + CALL _InitializeRecord + DEC EDI + JG @@RecordLoop + POP EBP + +@@exit: + + POP EDI + POP ESI + POP EBX +@@zerolength: +end; +{$ENDIF} + +procedure _Initialize(p: Pointer; typeInfo: Pointer); +{$IFDEF PUREPASCAL} +begin + _InitializeArray(p, typeInfo, 1); +end; +{$ELSE} +asm + MOV ECX,1 + JMP _InitializeArray +end; +{$ENDIF} + +procedure _FinalizeRecord(p: Pointer; typeInfo: Pointer); +{$IFDEF PUREPASCAL} +var + FT: PFieldTable; + I: Cardinal; +begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + for I := 0 to FT.Count-1 do + _FinalizeArray(Pointer(Cardinal(P) + FT.Fields[I].Offset), FT.Fields[I].TypeInfo^, 1); +end; +{$ELSE} +asm + { -> EAX pointer to record to be finalized } + { EDX pointer to type info } + + XOR ECX,ECX + + PUSH EBX + MOV CL,[EDX+1] + + PUSH ESI + PUSH EDI + + MOV EBX,EAX + LEA ESI,[EDX+ECX+2+8] + MOV EDI,[EDX+ECX+2+4] + +@@loop: + + MOV EDX,[ESI] + MOV EAX,[ESI+4] + ADD EAX,EBX + MOV EDX,[EDX] + MOV ECX,1 + CALL _FinalizeArray + ADD ESI,8 + DEC EDI + JG @@loop + + MOV EAX,EBX + + POP EDI + POP ESI + POP EBX +end; +{$ENDIF} + +procedure _FinalizeArray(p: Pointer; typeInfo: Pointer; elemCount: Cardinal); +{$IFDEF PUREPASCAL} +var + FT: PFieldTable; +begin + if elemCount = 0 then Exit; + case PTypeInfo(typeInfo).Kind of + tkLString: _LStrArrayClr(P^, elemCount); + tkWString: {X-_WStrArrayClr X+}WStrArrayClrProc(P^, elemCount); + tkVariant: + while elemCount > 0 do + begin + VarClrProc(P); + Inc(Integer(P), sizeof(Variant)); + Dec(elemCount); + end; + tkArray: + begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + while elemCount > 0 do + begin + _FinalizeArray(P, FT.Fields[0].TypeInfo^, FT.Count); + Inc(Integer(P), FT.Size); + Dec(elemCount); + end; + end; + tkRecord: + begin + FT := PFieldTable(Integer(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0])); + while elemCount > 0 do + begin + _FinalizeRecord(P, typeInfo); + Inc(Integer(P), FT.Size); + Dec(elemCount); + end; + end; + tkInterface: + while elemCount > 0 do + begin + _IntfClear(IInterface(P^)); + Inc(Integer(P), 4); + Dec(elemCount); + end; + tkDynArray: + while elemCount > 0 do + begin + _DynArrayClr(P); + Inc(Integer(P), 4); + Dec(elemCount); + end; + else + Error(reInvalidPtr); + end; +end; +{$ELSE} +asm + { -> EAX pointer to data to be finalized } + { EDX pointer to type info describing data } + { ECX number of elements of that type } + + { This code appears to be PIC safe. The functions called from + here either don't make external calls or call Pascal + routines that will fix up EBX in their prolog code + (FreeMem, VarClr, IntfClr). } + + CMP ECX, 0 { no array -> nop } + JE @@zerolength + + PUSH EAX + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + XOR EDX,EDX + MOV AL,[ESI] + MOV DL,[ESI+1] + + CMP AL,tkLString + JE @@LString + + CMP AL,tkWString + JE @@WString + + CMP AL,tkVariant + JE @@Variant + + CMP AL,tkArray + JE @@Array + + CMP AL,tkRecord + JE @@Record + + CMP AL,tkInterface + JE @@Interface + + CMP AL,tkDynArray + JE @@DynArray + + JMP @@error + +@@LString: + CMP ECX,1 + MOV EAX,EBX + JG @@LStringArray + CALL _LStrClr + JMP @@exit +@@LStringArray: + MOV EDX,ECX + CALL _LStrArrayClr + JMP @@exit + +@@WString: + CMP ECX,1 + MOV EAX,EBX + JG @@WStringArray + //CALL _WStrClr {X} + CALL [WStrClrProc] {X} + JMP @@exit +@@WStringArray: + MOV EDX,ECX + //CALL _WStrArrayClr {X} + CALL [WStrArrayClrProc] {X} + JMP @@exit +@@Variant: + MOV EAX,EBX + ADD EBX,16 + CALL _VarClr + DEC EDI + JG @@Variant + JMP @@exit +@@Array: + PUSH EBP + MOV EBP,EDX +@@ArrayLoop: + MOV EDX,[ESI+EBP+2+8] + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV ECX,[ESI+EBP+2+4] + MOV EDX,[EDX] + CALL _FinalizeArray + DEC EDI + JG @@ArrayLoop + POP EBP + JMP @@exit + +@@Record: + PUSH EBP + MOV EBP,EDX +@@RecordLoop: + { inv: EDI = number of array elements to finalize } + + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV EDX,ESI + CALL _FinalizeRecord + DEC EDI + JG @@RecordLoop + POP EBP + JMP @@exit + +@@Interface: + MOV EAX,EBX + ADD EBX,4 + CALL _IntfClear + DEC EDI + JG @@Interface + JMP @@exit + +@@DynArray: + MOV EAX,EBX + MOV EDX,ESI + ADD EBX,4 + CALL _DynArrayClear + DEC EDI + JG @@DynArray + JMP @@exit + +@@error: + POP EDI + POP ESI + POP EBX + POP EAX + MOV AL,reInvalidPtr + JMP Error + +@@exit: + POP EDI + POP ESI + POP EBX + POP EAX +@@zerolength: +end; +{$ENDIF} + +procedure _Finalize(p: Pointer; typeInfo: Pointer); +{$IFDEF PUREPASCAL} +begin + _FinalizeArray(p, typeInfo, 1); +end; +{$ELSE} +asm + MOV ECX,1 + JMP _FinalizeArray +end; +{$ENDIF} + +procedure _AddRefRecord{ p: Pointer; typeInfo: Pointer }; +asm + { -> EAX pointer to record to be referenced } + { EDX pointer to type info } + + XOR ECX,ECX + + PUSH EBX + MOV CL,[EDX+1] + + PUSH ESI + PUSH EDI + + MOV EBX,EAX + LEA ESI,[EDX+ECX+2+8] + MOV EDI,[EDX+ECX+2+4] + +@@loop: + + MOV EDX,[ESI] + MOV EAX,[ESI+4] + ADD EAX,EBX + MOV EDX,[EDX] + MOV ECX, 1 + CALL _AddRefArray + ADD ESI,8 + DEC EDI + JG @@loop + + POP EDI + POP ESI + POP EBX +end; + + +{X}procedure DummyProc; +{X}begin +{X}end; + +procedure _AddRefArray{ p: Pointer; typeInfo: Pointer; elemCount: Longint}; +asm + { -> EAX pointer to data to be referenced } + { EDX pointer to type info describing data } + { ECX number of elements of that type } + + { This code appears to be PIC safe. The functions called from + here either don't make external calls (LStrAddRef, WStrAddRef) or + are Pascal routines that will fix up EBX in their prolog code + (VarAddRef, IntfAddRef). } + + PUSH EBX + PUSH ESI + PUSH EDI + + TEST ECX,ECX + JZ @@exit + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + + XOR EDX,EDX + MOV AL,[ESI] + MOV DL,[ESI+1] + + CMP AL,tkLString + JE @@LString + CMP AL,tkWString + JE @@WString + CMP AL,tkVariant + JE @@Variant + CMP AL,tkArray + JE @@Array + CMP AL,tkRecord + JE @@Record + CMP AL,tkInterface + JE @@Interface + CMP AL,tkDynArray + JE @@DynArray + MOV AL,reInvalidPtr + POP EDI + POP ESI + POP EBX + JMP Error + +@@LString: + MOV EAX,[EBX] + ADD EBX,4 + CALL _LStrAddRef + DEC EDI + JG @@LString + JMP @@exit + +@@WString: + MOV EAX,EBX + ADD EBX,4 + //CALL _WStrAddRef + CALL [WStrAddRefProc] + DEC EDI + JG @@WString + JMP @@exit +@@Variant: + MOV EAX,EBX + ADD EBX,16 + CALL _VarAddRef + DEC EDI + JG @@Variant + JMP @@exit + +@@Array: + PUSH EBP + MOV EBP,EDX +@@ArrayLoop: + MOV EDX,[ESI+EBP+2+8] + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV ECX,[ESI+EBP+2+4] + MOV EDX,[EDX] + CALL _AddRefArray + DEC EDI + JG @@ArrayLoop + POP EBP + JMP @@exit + +@@Record: + PUSH EBP + MOV EBP,EDX +@@RecordLoop: + MOV EAX,EBX + ADD EBX,[ESI+EBP+2] + MOV EDX,ESI + CALL _AddRefRecord + DEC EDI + JG @@RecordLoop + POP EBP + JMP @@exit + +@@Interface: + MOV EAX,[EBX] + ADD EBX,4 + CALL _IntfAddRef + DEC EDI + JG @@Interface + JMP @@exit + +@@DynArray: + MOV EAX,[EBX] + ADD EBX,4 + CALL _DynArrayAddRef + DEC EDI + JG @@DynArray +@@exit: + + POP EDI + POP ESI + POP EBX +end; + + +procedure _AddRef{ p: Pointer; typeInfo: Pointer}; +asm + MOV ECX,1 + JMP _AddRefArray +end; + + +procedure _CopyRecord{ dest, source, typeInfo: Pointer }; +asm + { -> EAX pointer to dest } + { EDX pointer to source } + { ECX pointer to typeInfo } + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBX,EAX + MOV ESI,EDX + + XOR EAX,EAX + MOV AL,[ECX+1] + + LEA EDI,[ECX+EAX+2+8] + MOV EBP,[EDI-4] + XOR EAX,EAX + MOV ECX,[EDI-8] + PUSH ECX +@@loop: + MOV ECX,[EDI+4] + SUB ECX,EAX + JLE @@nomove1 + MOV EDX,EAX + ADD EAX,ESI + ADD EDX,EBX + CALL Move +@@noMove1: + MOV EAX,[EDI+4] + + MOV EDX,[EDI] + MOV EDX,[EDX] + MOV CL,[EDX] + + CMP CL,tkLString + JE @@LString + CMP CL,tkWString + JE @@WString + CMP CL,tkVariant + JE @@Variant + CMP CL,tkArray + JE @@Array + CMP CL,tkRecord + JE @@Record + CMP CL,tkInterface + JE @@Interface + CMP CL,tkDynArray + JE @@DynArray + MOV AL,reInvalidPtr + POP EBP + POP EDI + POP ESI + POP EBX + JMP Error + +@@LString: + MOV EDX,[ESI+EAX] + ADD EAX,EBX + CALL _LStrAsg + MOV EAX,4 + JMP @@common + +@@WString: + MOV EDX,[ESI+EAX] + ADD EAX,EBX + CALL _WStrAsg + MOV EAX,4 + JMP @@common + +@@Variant: + LEA EDX,[ESI+EAX] + ADD EAX,EBX + CALL _VarCopy + MOV EAX,16 + JMP @@common + +@@Array: + XOR ECX,ECX + MOV CL,[EDX+1] + PUSH dword ptr [EDX+ECX+2] + PUSH dword ptr [EDX+ECX+2+4] + MOV ECX,[EDX+ECX+2+8] + MOV ECX,[ECX] + LEA EDX,[ESI+EAX] + ADD EAX,EBX + CALL _CopyArray + POP EAX + JMP @@common + +@@Record: + XOR ECX,ECX + MOV CL,[EDX+1] + MOV ECX,[EDX+ECX+2] + PUSH ECX + MOV ECX,EDX + LEA EDX,[ESI+EAX] + ADD EAX,EBX + CALL _CopyRecord + POP EAX + JMP @@common + +@@Interface: + MOV EDX,[ESI+EAX] + ADD EAX,EBX + CALL _IntfCopy + MOV EAX,4 + JMP @@common + +@@DynArray: + MOV ECX,EDX + MOV EDX,[ESI+EAX] + ADD EAX,EBX + CALL _DynArrayAsg + MOV EAX,4 + +@@common: + ADD EAX,[EDI+4] + ADD EDI,8 + DEC EBP + JNZ @@loop + + POP ECX + SUB ECX,EAX + JLE @@noMove2 + LEA EDX,[EBX+EAX] + ADD EAX,ESI + CALL Move +@@noMove2: + + POP EBP + POP EDI + POP ESI + POP EBX +end; + + +procedure _CopyObject{ dest, source: Pointer; vmtPtrOffs: Longint; typeInfo: Pointer }; +asm + { -> EAX pointer to dest } + { EDX pointer to source } + { ECX offset of vmt in object } + { [ESP+4] pointer to typeInfo } + + ADD ECX,EAX { pointer to dest vmt } + PUSH dword ptr [ECX] { save dest vmt } + PUSH ECX + MOV ECX,[ESP+4+4+4] + CALL _CopyRecord + POP ECX + POP dword ptr [ECX] { restore dest vmt } + RET 4 + +end; + +procedure _CopyArray{ dest, source, typeInfo: Pointer; cnt: Integer }; +asm + { -> EAX pointer to dest } + { EDX pointer to source } + { ECX pointer to typeInfo } + { [ESP+4] count } + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV EBX,EAX + MOV ESI,EDX + MOV EDI,ECX + MOV EBP,[ESP+4+4*4] + + MOV CL,[EDI] + + CMP CL,tkLString + JE @@LString + CMP CL,tkWString + JE @@WString + CMP CL,tkVariant + JE @@Variant + CMP CL,tkArray + JE @@Array + CMP CL,tkRecord + JE @@Record + CMP CL,tkInterface + JE @@Interface + CMP CL,tkDynArray + JE @@DynArray + MOV AL,reInvalidPtr + POP EBP + POP EDI + POP ESI + POP EBX + JMP Error + +@@LString: + MOV EAX,EBX + MOV EDX,[ESI] + CALL _LStrAsg + ADD EBX,4 + ADD ESI,4 + DEC EBP + JNE @@LString + JMP @@exit + +@@WString: + MOV EAX,EBX + MOV EDX,[ESI] + CALL _WStrAsg + ADD EBX,4 + ADD ESI,4 + DEC EBP + JNE @@WString + JMP @@exit + +@@Variant: + MOV EAX,EBX + MOV EDX,ESI + CALL _VarCopy + ADD EBX,16 + ADD ESI,16 + DEC EBP + JNE @@Variant + JMP @@exit + +@@Array: + XOR ECX,ECX + MOV CL,[EDI+1] + LEA EDI,[EDI+ECX+2] +@@ArrayLoop: + MOV EAX,EBX + MOV EDX,ESI + MOV ECX,[EDI+8] + PUSH dword ptr [EDI+4] + CALL _CopyArray + ADD EBX,[EDI] + ADD ESI,[EDI] + DEC EBP + JNE @@ArrayLoop + JMP @@exit + +@@Record: + MOV EAX,EBX + MOV EDX,ESI + MOV ECX,EDI + CALL _CopyRecord + XOR EAX,EAX + MOV AL,[EDI+1] + ADD EBX,[EDI+EAX+2] + ADD ESI,[EDI+EAX+2] + DEC EBP + JNE @@Record + JMP @@exit + +@@Interface: + MOV EAX,EBX + MOV EDX,[ESI] + CALL _IntfCopy + ADD EBX,4 + ADD ESI,4 + DEC EBP + JNE @@Interface + JMP @@exit + +@@DynArray: + MOV EAX,EBX + MOV EDX,[ESI] + MOV ECX,EDI + CALL _DynArrayAsg + ADD EBX,4 + ADD ESI,4 + DEC EBP + JNE @@DynArray + +@@exit: + POP EBP + POP EDI + POP ESI + POP EBX + RET 4 +end; + + +function _New(size: Longint; typeInfo: Pointer): Pointer; +{$IFDEF PUREPASCAL} +begin + GetMem(Result, size); + if Result <> nil then + _Initialize(Result, typeInfo); +end; +{$ELSE} +asm + { -> EAX size of object to allocate } + { EDX pointer to typeInfo } + + PUSH EDX + CALL _GetMem + POP EDX + TEST EAX,EAX + JE @@exit + PUSH EAX + CALL _Initialize + POP EAX +@@exit: +end; +{$ENDIF} + +procedure _Dispose(p: Pointer; typeInfo: Pointer); +{$IFDEF PUREPASCAL} +begin + _Finalize(p, typeinfo); + FreeMem(p); +end; +{$ELSE} +asm + { -> EAX Pointer to object to be disposed } + { EDX Pointer to type info } + + PUSH EAX + CALL _Finalize + POP EAX + CALL _FreeMem +end; +{$ENDIF} + +{ ----------------------------------------------------- } +{ Wide character support } +{ ----------------------------------------------------- } + +function WideCharToString(Source: PWideChar): string; +begin + WideCharToStrVar(Source, Result); +end; + +function WideCharLenToString(Source: PWideChar; SourceLen: Integer): string; +begin + WideCharLenToStrVar(Source, SourceLen, Result); +end; + +procedure WideCharToStrVar(Source: PWideChar; var Dest: string); +begin + _LStrFromPWChar(Dest, Source); +end; + +procedure WideCharLenToStrVar(Source: PWideChar; SourceLen: Integer; + var Dest: string); +begin + _LStrFromPWCharLen(Dest, Source, SourceLen); +end; + +function StringToWideChar(const Source: string; Dest: PWideChar; + DestSize: Integer): PWideChar; +begin + Dest[WCharFromChar(Dest, DestSize - 1, PChar(Source), Length(Source))] := #0; + Result := Dest; +end; + +{ ----------------------------------------------------- } +{ OLE string support } +{ ----------------------------------------------------- } + +function OleStrToString(Source: PWideChar): string; +begin + OleStrToStrVar(Source, Result); +end; + +procedure OleStrToStrVar(Source: PWideChar; var Dest: string); +begin + WideCharLenToStrVar(Source, Length(WideString(Pointer(Source))), Dest); +end; + +function StringToOleStr(const Source: string): PWideChar; +begin + Result := nil; + _WStrFromPCharLen(WideString(Pointer(Result)), PChar(Pointer(Source)), Length(Source)); +end; + +{ ----------------------------------------------------- } +{ Variant manager support } +{ ----------------------------------------------------- } + +var + VariantManager: TVariantManager; + +procedure VariantSystemUndefinedError; +asm + MOV AL,reVarInvalidOp + JMP Error; +end; + +procedure VariantSystemDefaultVarClear(var V: TVarData); +begin + case V.VType of + varEmpty, varNull, varError:; + else + VariantSystemUndefinedError; + end; +end; + +procedure InitVariantManager; +type + TPtrArray = array [Word] of Pointer; +var + P: ^TPtrArray; + I: Integer; +begin + P := @VariantManager; + for I := 0 to (SizeOf(VariantManager) div SizeOf(Pointer))-1 do + P[I] := @VariantSystemUndefinedError; + VariantManager.VarClear := @VariantSystemDefaultVarClear; +end; + +procedure GetVariantManager(var VarMgr: TVariantManager); +begin + VarMgr := VariantManager; +end; + +procedure SetVariantManager(const VarMgr: TVariantManager); +begin + VariantManager := VarMgr; +end; + +function IsVariantManagerSet: Boolean; +type + TPtrArray = array [Word] of Pointer; +var + P: ^TPtrArray; + I: Integer; +begin + Result := True; + P := @VariantManager; + for I := 0 to (SizeOf(VariantManager) div SizeOf(Pointer))-1 do + if P[I] <> @VariantSystemUndefinedError then + begin + Result := False; + Break; + end; +end; + +{ ----------------------------------------------------- } +{ Variant support } +{ ----------------------------------------------------- } + +procedure _DispInvoke;//(var Dest: Variant; const Source: Variant; + //CallDesc: PCallDesc; Params: Pointer); cdecl; +asm +{$IFDEF PIC} + CALL GetGOT + LEA EAX,[EAX].OFFSET VariantManager + JMP [EAX].TVariantManager.DispInvoke +{$ELSE} + JMP VariantManager.DispInvoke +{$ENDIF} +end; + +procedure _VarClear(var V : Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarClear(V); +{$ELSE} +asm + JMP VariantManager.VarClear +{$IFEND} +end; + +procedure _VarCopy(var Dest: Variant; const Source: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarCopy(Dest, Source); +{$ELSE} +asm + JMP VariantManager.VarCopy +{$IFEND} +end; + +procedure _VarCast(var Dest: Variant; const Source: Variant; VarType: Integer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarCast(Dest, Source, VarType); +{$ELSE} +asm + JMP VariantManager.VarCast +{$IFEND} +end; + +procedure _VarCastOle(var Dest: Variant; const Source: Variant; VarType: Integer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarCastOle(Dest, Source, VarType); +{$ELSE} +asm + JMP VariantManager.VarCastOle +{$IFEND} +end; + +function _VarToInt(const V: Variant): Integer; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.VarToInt(V); +{$ELSE} +asm + JMP VariantManager.VarToInt +{$IFEND} +end; + +function _VarToInt64(const V: Variant): Int64; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.VarToInt64(V); +{$ELSE} +asm + JMP VariantManager.VarToInt64 +{$IFEND} +end; + +function _VarToBool(const V: Variant): Boolean; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.VarToBool(V); +{$ELSE} +asm + JMP VariantManager.VarToBool +{$IFEND} +end; + +function _VarToReal(const V: Variant): Extended; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.VarToReal(V); +{$ELSE} +asm + JMP VariantManager.VarToReal +{$IFEND} +end; + +function _VarToCurr(const V: Variant): Currency; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.VarToCurr(V); +{$ELSE} +asm + JMP VariantManager.VarToCurr +{$IFEND} +end; + +procedure _VarToPStr(var S; const V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarToPStr(S, V); +{$ELSE} +asm + JMP VariantManager.VarToPStr +{$IFEND} +end; + +procedure _VarToLStr(var S: string; const V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarToLStr(S, V); +{$ELSE} +asm + JMP VariantManager.VarToLStr +{$IFEND} +end; + +procedure _VarToWStr(var S: WideString; const V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarToWStr(S, V); +{$ELSE} +asm + JMP VariantManager.VarToWStr +{$IFEND} +end; + +procedure _VarToIntf(var Unknown: IInterface; const V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarToIntf(Unknown, V); +{$ELSE} +asm + JMP VariantManager.VarToIntf +{$IFEND} +end; + +procedure _VarToDisp(var Dispatch: IDispatch; const V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarToDisp(Dispatch, V); +{$ELSE} +asm + JMP VariantManager.VarToDisp +{$IFEND} +end; + +procedure _VarToDynArray(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarToDynArray(DynArray, V, TypeInfo); +{$ELSE} +asm + JMP VariantManager.VarToDynArray +{$IFEND} +end; + +procedure _VarFromInt(var V: Variant; const Value, Range: Integer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromInt(V, Value, Range); +{$ELSE} +asm + JMP VariantManager.VarFromInt +{$IFEND} +end; + +procedure _VarFromInt64(var V: Variant; const Value: Int64); +begin + VariantManager.VarFromInt64(V, Value); +end; + +procedure _VarFromBool(var V: Variant; const Value: Boolean); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromBool(V, Value); +{$ELSE} +asm + JMP VariantManager.VarFromBool +{$IFEND} +end; + +procedure _VarFromReal; // var V: Variant; const Value: Real +asm +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + POP ECX + LEA EAX,[EAX].OFFSET VariantManager + MOV EAX,[EAX].TVariantManager.VarFromReal + XCHG EAX,[ESP] + RET +{$ELSE} + JMP VariantManager.VarFromReal +{$ENDIF} +end; + +procedure _VarFromTDateTime; // var V: Variant; const Value: TDateTime +asm +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + POP ECX + LEA EAX,[EAX].OFFSET VariantManager + MOV EAX,[EAX].TVariantManager.VarFromTDateTime + XCHG EAX,[ESP] + RET +{$ELSE} + JMP VariantManager.VarFromTDateTime +{$ENDIF} +end; + +procedure _VarFromCurr; // var V: Variant; const Value: Currency +asm +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + POP ECX + LEA EAX,[EAX].OFFSET VariantManager + MOV EAX,[EAX].TVariantManager.VarFromCurr + XCHG EAX,[ESP] + RET +{$ELSE} + JMP VariantManager.VarFromCurr +{$ENDIF} +end; + +procedure _VarFromPStr(var V: Variant; const Value: ShortString); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromPStr(V, Value); +{$ELSE} +asm + JMP VariantManager.VarFromPStr +{$IFEND} +end; + +procedure _VarFromLStr(var V: Variant; const Value: string); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromLStr(V, Value); +{$ELSE} +asm + JMP VariantManager.VarFromLStr +{$IFEND} +end; + +procedure _VarFromWStr(var V: Variant; const Value: WideString); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromWStr(V, Value); +{$ELSE} +asm + JMP VariantManager.VarFromWStr +{$IFEND} +end; + +procedure _VarFromIntf(var V: Variant; const Value: IInterface); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromIntf(V, Value); +{$ELSE} +asm + JMP VariantManager.VarFromIntf +{$IFEND} +end; + +procedure _VarFromDisp(var V: Variant; const Value: IDispatch); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromDisp(V, Value); +{$ELSE} +asm + JMP VariantManager.VarFromDisp +{$IFEND} +end; + +procedure _VarFromDynArray(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarFromDynArray(V, DynArray, TypeInfo); +{$ELSE} +asm + JMP VariantManager.VarFromDynArray +{$IFEND} +end; + +procedure _OleVarFromPStr(var V: OleVariant; const Value: ShortString); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.OleVarFromPStr(V, Value); +{$ELSE} +asm + JMP VariantManager.OleVarFromPStr +{$IFEND} +end; + +procedure _OleVarFromLStr(var V: OleVariant; const Value: string); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.OleVarFromLStr(V, Value); +{$ELSE} +asm + JMP VariantManager.OleVarFromLStr +{$IFEND} +end; + +procedure _OleVarFromVar(var V: OleVariant; const Value: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.OleVarFromVar(V, Value); +{$ELSE} +asm + JMP VariantManager.OleVarFromVar +{$IFEND} +end; + +procedure _OleVarFromInt(var V: OleVariant; const Value, Range: Integer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.OleVarFromInt(V, Value, Range); +{$ELSE} +asm + JMP VariantManager.OleVarFromInt +{$IFEND} +end; + +procedure _VarAdd(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opAdd); +{$ELSE} +asm + MOV ECX,opAdd + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarSub(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opSubtract); +{$ELSE} +asm + MOV ECX,opSubtract + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarMul(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opMultiply); +{$ELSE} +asm + MOV ECX,opMultiply + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarDiv(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opIntDivide); +{$ELSE} +asm + MOV ECX,opIntDivide + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarMod(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opModulus); +{$ELSE} +asm + MOV ECX,opModulus + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarAnd(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opAnd); +{$ELSE} +asm + MOV ECX,opAnd + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarOr(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opOr); +{$ELSE} +asm + MOV ECX,opOr + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarXor(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opXor); +{$ELSE} +asm + MOV ECX,opXor + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarShl(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opShiftLeft); +{$ELSE} +asm + MOV ECX,opShiftLeft + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarShr(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opShiftRight); +{$ELSE} +asm + MOV ECX,opShiftRight + JMP VariantManager.VarOp +{$IFEND} +end; + +procedure _VarRDiv(var Left: Variant; const Right: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarOp(Left, Right, opDivide); +{$ELSE} +asm + MOV ECX,opDivide + JMP VariantManager.VarOp +{$IFEND} +end; + +{$IF Defined(PIC) or Defined(PUREPASCAL)} +// result is set in the flags +procedure DoVarCmp(const Left, Right: Variant; OpCode: Integer); +begin + VariantManager.VarCmp(TVarData(Left), TVarData(Right), OpCode); +end; +{$IFEND} + +procedure _VarCmpEQ(const Left, Right: Variant); // result is set in the flags +asm + MOV ECX, opCmpEQ +{$IFDEF PIC} + JMP DoVarCmp +{$ELSE} + JMP VariantManager.VarCmp +{$ENDIF} +end; + +procedure _VarCmpNE(const Left, Right: Variant); // result is set in the flags +asm + MOV ECX, opCmpNE +{$IFDEF PIC} + JMP DoVarCmp +{$ELSE} + JMP VariantManager.VarCmp +{$ENDIF} +end; + +procedure _VarCmpLT(const Left, Right: Variant); // result is set in the flags +asm + MOV ECX, opCmpLT +{$IFDEF PIC} + JMP DoVarCmp +{$ELSE} + JMP VariantManager.VarCmp +{$ENDIF} +end; + +procedure _VarCmpLE(const Left, Right: Variant); // result is set in the flags +asm + MOV ECX, opCmpLE +{$IFDEF PIC} + JMP DoVarCmp +{$ELSE} + JMP VariantManager.VarCmp +{$ENDIF} +end; + +procedure _VarCmpGT(const Left, Right: Variant); // result is set in the flags +asm + MOV ECX, opCmpGT +{$IFDEF PIC} + JMP DoVarCmp +{$ELSE} + JMP VariantManager.VarCmp +{$ENDIF} +end; + +procedure _VarCmpGE(const Left, Right: Variant); // result is set in the flags +asm + MOV ECX, opCmpGE +{$IFDEF PIC} + JMP DoVarCmp +{$ELSE} + JMP VariantManager.VarCmp +{$ENDIF} +end; + + +procedure _VarNeg(var V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarNeg(V); +{$ELSE} +asm + JMP VariantManager.VarNeg +{$IFEND} +end; + +procedure _VarNot(var V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarNot(V); +{$ELSE} +asm + JMP VariantManager.VarNot +{$IFEND} +end; + +procedure _VarCopyNoInd; +asm +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + POP ECX + LEA EAX,[EAX].OFFSET VariantManager + MOV EAX,[EAX].TVariantManager.VarCopyNoInd + XCHG EAX,[ESP] + RET +{$ELSE} + JMP VariantManager.VarCopyNoInd +{$ENDIF} +end; + +procedure _VarClr(var V: Variant); +asm + PUSH EAX + CALL _VarClear + POP EAX +end; + +procedure _VarAddRef(var V: Variant); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarAddRef(V); +{$ELSE} +asm + JMP VariantManager.VarAddRef +{$IFEND} +end; + +procedure _IntfDispCall; +asm +{$IFDEF PIC} + PUSH EAX + PUSH ECX + CALL GetGOT + POP ECX + LEA EAX,[EAX].OFFSET DispCallByIDProc + MOV EAX,[EAX] + XCHG EAX,[ESP] + RET +{$ELSE} + JMP DispCallByIDProc +{$ENDIF} +end; + +procedure _DispCallByIDError; +asm + MOV AL,reVarDispatch + JMP Error +end; + +procedure _IntfVarCall; +asm +end; + +function _WriteVariant(var T: Text; const V: Variant; Width: Integer): Pointer; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.WriteVariant(T, V, Width); +{$ELSE} +asm + JMP VariantManager.WriteVariant +{$IFEND} +end; + +function _Write0Variant(var T: Text; const V: Variant): Pointer; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + Result := VariantManager.Write0Variant(T, V); +{$ELSE} +asm + JMP VariantManager.Write0Variant +{$IFEND} +end; + +{ ----------------------------------------------------- } +{ Variant array support } +{ ----------------------------------------------------- } + +procedure _VarArrayRedim(var A : Variant; HighBound: Integer); +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + VariantManager.VarArrayRedim(A, HighBound); +{$ELSE} +asm + JMP VariantManager.VarArrayRedim +{$IFEND} +end; + +function _VarArrayGet(var A: Variant; IndexCount: Integer; + Indices: Integer): Variant; cdecl; +asm + POP EBP +{$IFDEF PIC} + CALL GetGOT + LEA EAX,[EAX].OFFSET VariantManager + MOV EAX,[EAX].TVariantManager.VarArrayGet + PUSH EAX + RET +{$ELSE} + JMP VariantManager.VarArrayGet +{$ENDIF} +end; + +procedure _VarArrayPut(var A: Variant; const Value: Variant; + IndexCount: Integer; Indices: Integer); cdecl; +asm + POP EBP +{$IFDEF PIC} + CALL GetGOT + LEA EAX,[EAX].OFFSET VariantManager + MOV EAX,[EAX].TVariantManager.VarArrayPut + PUSH EAX + RET +{$ELSE} + JMP VariantManager.VarArrayPut +{$ENDIF} +end; + +// 64 bit integer helper routines +// +// These functions always return the 64-bit result in EAX:EDX + +// ------------------------------------------------------------------------------ +// 64-bit signed multiply +// ------------------------------------------------------------------------------ +// +// Param 1(EAX:EDX), Param 2([ESP+8]:[ESP+4]) ; before reg pushing +// + +procedure __llmul; +asm + push edx + push eax + + // Param2 : [ESP+16]:[ESP+12] (hi:lo) + // Param1 : [ESP+4]:[ESP] (hi:lo) + + mov eax, [esp+16] + mul dword ptr [esp] + mov ecx, eax + + mov eax, [esp+4] + mul dword ptr [esp+12] + add ecx, eax + + mov eax, [esp] + mul dword ptr [esp+12] + add edx, ecx + + pop ecx + pop ecx + + ret 8 +end; + +// ------------------------------------------------------------------------------ +// 64-bit signed multiply, with overflow check (98.05.15: overflow not supported yet) +// ------------------------------------------------------------------------------ +// +// Param1 ~= U (Uh, Ul) +// Param2 ~= V (Vh, Vl) +// +// Param 1(EAX:EDX), Param 2([ESP+8]:[ESP+4]) ; before reg pushing +// +// compiler-helper function +// O-flag set on exit => result is invalid +// O-flag clear on exit => result is valid + +procedure __llmulo; +asm + push edx + push eax + + // Param2 : [ESP+16]:[ESP+12] (hi:lo) + // Param1 : [ESP+4]:[ESP] (hi:lo) + + mov eax, [esp+16] + mul dword ptr [esp] + mov ecx, eax + + mov eax, [esp+4] + mul dword ptr [esp+12] + add ecx, eax + + mov eax, [esp] + mul dword ptr [esp+12] + add edx, ecx + + pop ecx + pop ecx + + ret 8 +end; + +// ------------------------------------------------------------------------------ +// 64-bit signed division +// ------------------------------------------------------------------------------ + +// +// Dividend = Numerator, Divisor = Denominator +// +// Dividend(EAX:EDX), Divisor([ESP+8]:[ESP+4]) ; before reg pushing +// +// + +procedure __lldiv; +asm + push ebp + push ebx + push esi + push edi + xor edi,edi + + mov ebx,20[esp] // get the divisor low dword + mov ecx,24[esp] // get the divisor high dword + + or ecx,ecx + jnz @__lldiv@slow_ldiv // both high words are zero + + or edx,edx + jz @__lldiv@quick_ldiv + + or ebx,ebx + jz @__lldiv@quick_ldiv // if ecx:ebx == 0 force a zero divide + // we don't expect this to actually + // work + +@__lldiv@slow_ldiv: + +// +// Signed division should be done. Convert negative +// values to positive and do an unsigned division. +// Store the sign value in the next higher bit of +// di (test mask of 4). Thus when we are done, testing +// that bit will determine the sign of the result. +// + or edx,edx // test sign of dividend + jns @__lldiv@onepos + neg edx + neg eax + sbb edx,0 // negate dividend + or edi,1 + +@__lldiv@onepos: + or ecx,ecx // test sign of divisor + jns @__lldiv@positive + neg ecx + neg ebx + sbb ecx,0 // negate divisor + xor edi,1 + +@__lldiv@positive: + mov ebp,ecx + mov ecx,64 // shift counter + push edi // save the flags +// +// Now the stack looks something like this: +// +// 24[esp]: divisor (high dword) +// 20[esp]: divisor (low dword) +// 16[esp]: return EIP +// 12[esp]: previous EBP +// 8[esp]: previous EBX +// 4[esp]: previous ESI +// [esp]: previous EDI +// + xor edi,edi // fake a 64 bit dividend + xor esi,esi + +@__lldiv@xloop: + shl eax,1 // shift dividend left one bit + rcl edx,1 + rcl esi,1 + rcl edi,1 + cmp edi,ebp // dividend larger? + jb @__lldiv@nosub + ja @__lldiv@subtract + cmp esi,ebx // maybe + jb @__lldiv@nosub + +@__lldiv@subtract: + sub esi,ebx + sbb edi,ebp // subtract the divisor + inc eax // build quotient + +@__lldiv@nosub: + loop @__lldiv@xloop +// +// When done with the loop the four registers values' look like: +// +// | edi | esi | edx | eax | +// | remainder | quotient | +// + pop ebx // get control bits + test ebx,1 // needs negative + jz @__lldiv@finish + neg edx + neg eax + sbb edx,0 // negate + +@__lldiv@finish: + pop edi + pop esi + pop ebx + pop ebp + ret 8 + +@__lldiv@quick_ldiv: + div ebx // unsigned divide + xor edx,edx + jmp @__lldiv@finish +end; + +// ------------------------------------------------------------------------------ +// 64-bit signed division with overflow check (98.05.15: not implementated yet) +// ------------------------------------------------------------------------------ + +// +// Dividend = Numerator, Divisor = Denominator +// +// Dividend(EAX:EDX), Divisor([ESP+8]:[ESP+4]) +// Param 1 (EAX:EDX), Param 2([ESP+8]:[ESP+4]) +// +// Param1 ~= U (Uh, Ul) +// Param2 ~= V (Vh, Vl) +// +// compiler-helper function +// O-flag set on exit => result is invalid +// O-flag clear on exit => result is valid +// + +procedure __lldivo; +asm + // check for overflow condition: min(int64) DIV -1 + push esi + mov esi, [esp+12] // Vh + and esi, [esp+8] // Vl + cmp esi, 0ffffffffh // V = -1? + jne @@divok + + mov esi, eax + or esi, edx + cmp esi, 80000000H // U = min(int64)? + jne @@divok + +@@divOvl: + mov eax, esi + pop esi + dec eax // turn on O-flag + ret + +@@divok: + pop esi + push dword ptr [esp+8] // Vh + push dword ptr [esp+8] // Vl (offset is changed from push) + call __lldiv + and eax, eax // turn off O-flag + ret 8 +end; + +// ------------------------------------------------------------------------------ +// 64-bit unsigned division +// ------------------------------------------------------------------------------ + +// Dividend(EAX(hi):EDX(lo)), Divisor([ESP+8](hi):[ESP+4](lo)) // before reg pushing +procedure __lludiv; +asm + push ebp + push ebx + push esi + push edi +// +// Now the stack looks something like this: +// +// 24[esp]: divisor (high dword) +// 20[esp]: divisor (low dword) +// 16[esp]: return EIP +// 12[esp]: previous EBP +// 8[esp]: previous EBX +// 4[esp]: previous ESI +// [esp]: previous EDI +// + +// dividend is pushed last, therefore the first in the args +// divisor next. +// + mov ebx,20[esp] // get the first low word + mov ecx,24[esp] // get the first high word + + or ecx,ecx + jnz @__lludiv@slow_ldiv // both high words are zero + + or edx,edx + jz @__lludiv@quick_ldiv + + or ebx,ebx + jz @__lludiv@quick_ldiv // if ecx:ebx == 0 force a zero divide + // we don't expect this to actually + // work + +@__lludiv@slow_ldiv: + mov ebp,ecx + mov ecx,64 // shift counter + xor edi,edi // fake a 64 bit dividend + xor esi,esi + +@__lludiv@xloop: + shl eax,1 // shift dividend left one bit + rcl edx,1 + rcl esi,1 + rcl edi,1 + cmp edi,ebp // dividend larger? + jb @__lludiv@nosub + ja @__lludiv@subtract + cmp esi,ebx // maybe + jb @__lludiv@nosub + +@__lludiv@subtract: + sub esi,ebx + sbb edi,ebp // subtract the divisor + inc eax // build quotient + +@__lludiv@nosub: + loop @__lludiv@xloop +// +// When done with the loop the four registers values' look like: +// +// | edi | esi | edx | eax | +// | remainder | quotient | +// + +@__lludiv@finish: + pop edi + pop esi + pop ebx + pop ebp + ret 8 + +@__lludiv@quick_ldiv: + div ebx // unsigned divide + xor edx,edx + jmp @__lludiv@finish +end; + +// ------------------------------------------------------------------------------ +// 64-bit modulo +// ------------------------------------------------------------------------------ + +// Dividend(EAX:EDX), Divisor([ESP+8]:[ESP+4]) // before reg pushing +procedure __llmod; +asm + push ebp + push ebx + push esi + push edi + xor edi,edi +// +// dividend is pushed last, therefore the first in the args +// divisor next. +// + mov ebx,20[esp] // get the first low word + mov ecx,24[esp] // get the first high word + or ecx,ecx + jnz @__llmod@slow_ldiv // both high words are zero + + or edx,edx + jz @__llmod@quick_ldiv + + or ebx,ebx + jz @__llmod@quick_ldiv // if ecx:ebx == 0 force a zero divide + // we don't expect this to actually + // work +@__llmod@slow_ldiv: +// +// Signed division should be done. Convert negative +// values to positive and do an unsigned division. +// Store the sign value in the next higher bit of +// di (test mask of 4). Thus when we are done, testing +// that bit will determine the sign of the result. +// + or edx,edx // test sign of dividend + jns @__llmod@onepos + neg edx + neg eax + sbb edx,0 // negate dividend + or edi,1 + +@__llmod@onepos: + or ecx,ecx // test sign of divisor + jns @__llmod@positive + neg ecx + neg ebx + sbb ecx,0 // negate divisor + +@__llmod@positive: + mov ebp,ecx + mov ecx,64 // shift counter + push edi // save the flags +// +// Now the stack looks something like this: +// +// 24[esp]: divisor (high dword) +// 20[esp]: divisor (low dword) +// 16[esp]: return EIP +// 12[esp]: previous EBP +// 8[esp]: previous EBX +// 4[esp]: previous ESI +// [esp]: previous EDI +// + xor edi,edi // fake a 64 bit dividend + xor esi,esi + +@__llmod@xloop: + shl eax,1 // shift dividend left one bit + rcl edx,1 + rcl esi,1 + rcl edi,1 + cmp edi,ebp // dividend larger? + jb @__llmod@nosub + ja @__llmod@subtract + cmp esi,ebx // maybe + jb @__llmod@nosub + +@__llmod@subtract: + sub esi,ebx + sbb edi,ebp // subtract the divisor + inc eax // build quotient + +@__llmod@nosub: + loop @__llmod@xloop +// +// When done with the loop the four registers values' look like: +// +// | edi | esi | edx | eax | +// | remainder | quotient | +// + mov eax,esi + mov edx,edi // use remainder + + pop ebx // get control bits + test ebx,1 // needs negative + jz @__llmod@finish + neg edx + neg eax + sbb edx,0 // negate + +@__llmod@finish: + pop edi + pop esi + pop ebx + pop ebp + ret 8 + +@__llmod@quick_ldiv: + div ebx // unsigned divide + xchg eax,edx + xor edx,edx + jmp @__llmod@finish +end; + +// ------------------------------------------------------------------------------ +// 64-bit signed modulo with overflow (98.05.15: overflow not yet supported) +// ------------------------------------------------------------------------------ + +// Dividend(EAX:EDX), Divisor([ESP+8]:[ESP+4]) +// Param 1 (EAX:EDX), Param 2([ESP+8]:[ESP+4]) +// +// Param1 ~= U (Uh, Ul) +// Param2 ~= V (Vh, Vl) +// +// compiler-helper function +// O-flag set on exit => result is invalid +// O-flag clear on exit => result is valid +// + +procedure __llmodo; +asm + // check for overflow condition: min(int64) MOD -1 + push esi + mov esi, [esp+12] // Vh + and esi, [esp+8] // Vl + cmp esi, 0ffffffffh // V = -1? + jne @@modok + + mov esi, eax + or esi, edx + cmp esi, 80000000H // U = min(int64)? + jne @@modok + +@@modOvl: + mov eax, esi + pop esi + dec eax // turn on O-flag + ret + +@@modok: + pop esi + push dword ptr [esp+8] // Vh + push dword ptr [esp+8] // Vl (offset is changed from push) + call __llmod + and eax, eax // turn off O-flag + ret 8 +end; + +// ------------------------------------------------------------------------------ +// 64-bit unsigned modulo +// ------------------------------------------------------------------------------ +// Dividend(EAX(hi):EDX(lo)), Divisor([ESP+8](hi):[ESP+4](lo)) // before reg pushing + +procedure __llumod; +asm + push ebp + push ebx + push esi + push edi +// +// Now the stack looks something like this: +// +// 24[esp]: divisor (high dword) +// 20[esp]: divisor (low dword) +// 16[esp]: return EIP +// 12[esp]: previous EBP +// 8[esp]: previous EBX +// 4[esp]: previous ESI +// [esp]: previous EDI +// + +// dividend is pushed last, therefore the first in the args +// divisor next. +// + mov ebx,20[esp] // get the first low word + mov ecx,24[esp] // get the first high word + or ecx,ecx + jnz @__llumod@slow_ldiv // both high words are zero + + or edx,edx + jz @__llumod@quick_ldiv + + or ebx,ebx + jz @__llumod@quick_ldiv // if ecx:ebx == 0 force a zero divide + // we don't expect this to actually + // work +@__llumod@slow_ldiv: + mov ebp,ecx + mov ecx,64 // shift counter + xor edi,edi // fake a 64 bit dividend + xor esi,esi // + +@__llumod@xloop: + shl eax,1 // shift dividend left one bit + rcl edx,1 + rcl esi,1 + rcl edi,1 + cmp edi,ebp // dividend larger? + jb @__llumod@nosub + ja @__llumod@subtract + cmp esi,ebx // maybe + jb @__llumod@nosub + +@__llumod@subtract: + sub esi,ebx + sbb edi,ebp // subtract the divisor + inc eax // build quotient + +@__llumod@nosub: + loop @__llumod@xloop +// +// When done with the loop the four registers values' look like: +// +// | edi | esi | edx | eax | +// | remainder | quotient | +// + mov eax,esi + mov edx,edi // use remainder + +@__llumod@finish: + pop edi + pop esi + pop ebx + pop ebp + ret 8 + +@__llumod@quick_ldiv: + div ebx // unsigned divide + xchg eax,edx + xor edx,edx + jmp @__llumod@finish +end; + +// ------------------------------------------------------------------------------ +// 64-bit shift left +// ------------------------------------------------------------------------------ + +// +// target (EAX:EDX) count (ECX) +// +procedure __llshl; +asm + cmp cl, 32 + jl @__llshl@below32 + cmp cl, 64 + jl @__llshl@below64 + xor edx, edx + xor eax, eax + ret + +@__llshl@below64: + mov edx, eax + shl edx, cl + xor eax, eax + ret + +@__llshl@below32: + shld edx, eax, cl + shl eax, cl + ret +end; + +// ------------------------------------------------------------------------------ +// 64-bit signed shift right +// ------------------------------------------------------------------------------ +// target (EAX:EDX) count (ECX) + +procedure __llshr; +asm + cmp cl, 32 + jl @__llshr@below32 + cmp cl, 64 + jl @__llshr@below64 + sar edx, 1fh + mov eax,edx + ret + +@__llshr@below64: + mov eax, edx + cdq + sar eax,cl + ret + +@__llshr@below32: + shrd eax, edx, cl + sar edx, cl + ret +end; + +// ------------------------------------------------------------------------------ +// 64-bit unsigned shift right +// ------------------------------------------------------------------------------ + +// target (EAX:EDX) count (ECX) +procedure __llushr; +asm + cmp cl, 32 + jl @__llushr@below32 + cmp cl, 64 + jl @__llushr@below64 + xor edx, edx + xor eax, eax + ret + +@__llushr@below64: + mov eax, edx + xor edx, edx + shr eax, cl + ret + +@__llushr@below32: + shrd eax, edx, cl + shr edx, cl + ret +end; + +function _StrInt64(val: Int64; width: Integer): ShortString; +var + d: array[0..31] of Char; { need 19 digits and a sign } + i, k: Integer; + sign: Boolean; + spaces: Integer; +begin + { Produce an ASCII representation of the number in reverse order } + i := 0; + sign := val < 0; + repeat + d[i] := Chr( Abs(val mod 10) + Ord('0') ); + Inc(i); + val := val div 10; + until val = 0; + if sign then + begin + d[i] := '-'; + Inc(i); + end; + + { Fill the Result with the appropriate number of blanks } + if width > 255 then + width := 255; + k := 1; + spaces := width - i; + while k <= spaces do + begin + Result[k] := ' '; + Inc(k); + end; + + { Fill the Result with the number } + while i > 0 do + begin + Dec(i); + Result[k] := d[i]; + Inc(k); + end; + + { Result is k-1 characters long } + SetLength(Result, k-1); + +end; + +function _Str0Int64(val: Int64): ShortString; +begin + Result := _StrInt64(val, 0); +end; + +procedure _WriteInt64; +asm +{ PROCEDURE _WriteInt64( VAR t: Text; val: Int64; with: Longint); } +{ ->EAX Pointer to file record } +{ [ESP+4] Value } +{ EDX Field width } + + SUB ESP,32 { VAR s: String[31]; } + + PUSH EAX + PUSH EDX + + PUSH dword ptr [ESP+8+32+8] { Str( val : 0, s ); } + PUSH dword ptr [ESP+8+32+8] + XOR EAX,EAX + LEA EDX,[ESP+8+8] + CALL _StrInt64 + + POP ECX + POP EAX + + MOV EDX,ESP { Write( t, s : width );} + CALL _WriteString + + ADD ESP,32 + RET 8 +end; + +procedure _Write0Int64; +asm +{ PROCEDURE _Write0Long( VAR t: Text; val: Longint); } +{ ->EAX Pointer to file record } +{ EDX Value } + XOR EDX,EDX + JMP _WriteInt64 +end; + +procedure _ReadInt64; +asm + // -> EAX Pointer to text record + // <- EAX:EDX Result + + PUSH EBX + PUSH ESI + PUSH EDI + SUB ESP,36 // var numbuf: String[32]; + + MOV ESI,EAX + CALL _SeekEof + DEC AL + JZ @@eof + + MOV EDI,ESP // EDI -> numBuf[0] + MOV BL,32 +@@loop: + MOV EAX,ESI + CALL _ReadChar + CMP AL,' ' + JBE @@endNum + STOSB + DEC BL + JNZ @@loop +@@convert: + MOV byte ptr [EDI],0 + MOV EAX,ESP // EAX -> numBuf + PUSH EDX // allocate code result + MOV EDX,ESP // pass pointer to code + CALL _ValInt64 // convert + POP ECX // pop code result into EDX + TEST ECX,ECX + JZ @@exit + MOV EAX,106 + CALL SetInOutRes + +@@exit: + ADD ESP,36 + POP EDI + POP ESI + POP EBX + RET + +@@endNum: + CMP AH,cEof + JE @@convert + DEC [ESI].TTextRec.BufPos + JMP @@convert + +@@eof: + XOR EAX,EAX + JMP @@exit +end; + +function _ValInt64(const s: AnsiString; var code: Integer): Int64; +var + i: Integer; + dig: Integer; + sign: Boolean; + empty: Boolean; +begin + i := 1; + dig := 0; + Result := 0; + if s = '' then + begin + code := i; + exit; + end; + while s[i] = ' ' do + Inc(i); + sign := False; + if s[i] = '-' then + begin + sign := True; + Inc(i); + end + else if s[i] = '+' then + Inc(i); + empty := True; + if (s[i] = '$') or (s[i] = '0') and (Upcase(s[i+1]) = 'X') then + begin + if s[i] = '0' then + Inc(i); + Inc(i); + while True do + begin + case s[i] of + '0'..'9': dig := Ord(s[i]) - Ord('0'); + 'A'..'F': dig := Ord(s[i]) - (Ord('A') - 10); + 'a'..'f': dig := Ord(s[i]) - (Ord('a') - 10); + else + break; + end; + if (Result < 0) or (Result > (High(Int64) div 16)) then + break; + Result := Result shl 4 + dig; + Inc(i); + empty := False; + end; + if sign then + Result := - Result; + end + else + begin + while True do + begin + case s[i] of + '0'..'9': dig := Ord(s[i]) - Ord('0'); + else + break; + end; + if (Result < 0) or (Result > (High(Int64) div 10)) then + break; + Result := Result*10 + dig; + Inc(i); + empty := False; + end; + if sign then + Result := - Result; + if (Result <> 0) and (sign <> (Result < 0)) then + Dec(i); + end; + if (s[i] <> #0) or empty then + code := i + else + code := 0; +end; + +procedure _DynArrayLength; +asm +{ FUNCTION _DynArrayLength(const a: array of ...): Longint; } +{ ->EAX Pointer to array or nil } +{ <-EAX High bound of array + 1 or 0 } + TEST EAX,EAX + JZ @@skip + MOV EAX,[EAX-4] +@@skip: +end; + +procedure _DynArrayHigh; +asm +{ FUNCTION _DynArrayHigh(const a: array of ...): Longint; } +{ ->EAX Pointer to array or nil } +{ <-EAX High bound of array or -1 } + CALL _DynArrayLength + DEC EAX +end; + +procedure CopyArray(dest, source, typeInfo: Pointer; cnt: Integer); +asm + PUSH dword ptr [EBP+8] + CALL _CopyArray +end; + +procedure FinalizeArray(p, typeInfo: Pointer; cnt: Integer); +asm + JMP _FinalizeArray +end; + +procedure DynArrayClear(var a: Pointer; typeInfo: Pointer); +asm + CALL _DynArrayClear +end; + +procedure DynArraySetLength(var a: Pointer; typeInfo: Pointer; dimCnt: Longint; lengthVec: PLongint); +var + i: Integer; + newLength, oldLength, minLength: Longint; + elSize: Longint; + neededSize: Longint; + p, pp: Pointer; +begin + p := a; + + // Fetch the new length of the array in this dimension, and the old length + newLength := PLongint(lengthVec)^; + if newLength <= 0 then + begin + if newLength < 0 then + Error(reRangeError); + DynArrayClear(a, typeInfo); + exit; + end; + + oldLength := 0; + if p <> nil then + begin + Dec(PLongint(p)); + oldLength := PLongint(p)^; + Dec(PLongint(p)); + end; + + // Calculate the needed size of the heap object + Inc(PChar(typeInfo), Length(PDynArrayTypeInfo(typeInfo).name)); + elSize := PDynArrayTypeInfo(typeInfo).elSize; + if PDynArrayTypeInfo(typeInfo).elType <> nil then + typeInfo := PDynArrayTypeInfo(typeInfo).elType^ + else + typeInfo := nil; + neededSize := newLength*elSize; + if neededSize div newLength <> elSize then + Error(reRangeError); + Inc(neededSize, Sizeof(Longint)*2); + + // If the heap object isn't shared (ref count = 1), just resize it. Otherwise, we make a copy + if (p = nil) or (PLongint(p)^ = 1) then + begin + pp := p; + if (newLength < oldLength) and (typeInfo <> nil) then + FinalizeArray(PChar(p) + Sizeof(Longint)*2 + newLength*elSize, typeInfo, oldLength - newLength); + ReallocMem(pp, neededSize); + p := pp; + end + else + begin + Dec(PLongint(p)^); + GetMem(p, neededSize); + minLength := oldLength; + if minLength > newLength then + minLength := newLength; + if typeInfo <> nil then + begin + FillChar((PChar(p) + Sizeof(Longint)*2)^, minLength*elSize, 0); + CopyArray(PChar(p) + Sizeof(Longint)*2, a, typeInfo, minLength) + end + else + Move(PChar(a)^, (PChar(p) + Sizeof(Longint)*2)^, minLength*elSize); + end; + + // The heap object will now have a ref count of 1 and the new length + PLongint(p)^ := 1; + Inc(PLongint(p)); + PLongint(p)^ := newLength; + Inc(PLongint(p)); + + // Set the new memory to all zero bits + FillChar((PChar(p) + elSize * oldLength)^, elSize * (newLength - oldLength), 0); + + // Take care of the inner dimensions, if any + if dimCnt > 1 then + begin + Inc(lengthVec); + Dec(dimCnt); + for i := 0 to newLength-1 do + DynArraySetLength(PPointerArray(p)[i], typeInfo, dimCnt, lengthVec); + end; + a := p; +end; + +procedure _DynArraySetLength; +asm +{ PROCEDURE _DynArraySetLength(var a: dynarray; typeInfo: PDynArrayTypeInfo; dimCnt: Longint; lengthVec: ^Longint) } +{ ->EAX Pointer to dynamic array (= pointer to pointer to heap object) } +{ EDX Pointer to type info for the dynamic array } +{ ECX number of dimensions } +{ [ESP+4] dimensions } + PUSH ESP + ADD dword ptr [ESP],4 + CALL DynArraySetLength +end; + +procedure _DynArrayCopy(a: Pointer; typeInfo: Pointer; var Result: Pointer); +begin + if a <> nil then + _DynArrayCopyRange(a, typeInfo, 0, PLongint(PChar(a)-4)^, Result) + else + _DynArrayClear(Result, typeInfo); +end; + +procedure _DynArrayCopyRange(a: Pointer; typeInfo: Pointer; index, count : Integer; var Result: Pointer); +var + arrayLength: Integer; + elSize: Integer; + typeInf: PDynArrayTypeInfo; + p: Pointer; +begin + p := nil; + if a <> nil then + begin + typeInf := typeInfo; + + // Limit index and count to values within the array + if index < 0 then + begin + Inc(count, index); + index := 0; + end; + arrayLength := PLongint(PChar(a)-4)^; + if index > arrayLength then + index := arrayLength; + if count > arrayLength - index then + count := arrayLength - index; + if count < 0 then + count := 0; + + if count > 0 then + begin + // Figure out the size and type descriptor of the element type + Inc(PChar(typeInf), Length(typeInf.name)); + elSize := typeInf.elSize; + if typeInf.elType <> nil then + typeInf := typeInf.elType^ + else + typeInf := nil; + + // Allocate the amount of memory needed + GetMem(p, count*elSize + Sizeof(Longint)*2); + + // The reference count of the new array is 1, the length is count + PLongint(p)^ := 1; + Inc(PLongint(p)); + PLongint(p)^ := count; + Inc(PLongint(p)); + Inc(PChar(a), index*elSize); + + // If the element type needs destruction, we must copy each element, + // otherwise we can just copy the bits + if count > 0 then + begin + if typeInf <> nil then + begin + FillChar(p^, count*elSize, 0); + CopyArray(p, a, typeInf, count) + end + else + Move(a^, p^, count*elSize); + end; + end; + end; + DynArrayClear(Result, typeInfo); + Result := p; +end; + +procedure _DynArrayClear; +asm +{ ->EAX Pointer to dynamic array (Pointer to pointer to heap object } +{ EDX Pointer to type info } + + { Nothing to do if Pointer to heap object is nil } + MOV ECX,[EAX] + TEST ECX,ECX + JE @@exit + + { Set the variable to be finalized to nil } + MOV dword ptr [EAX],0 + + { Decrement ref count. Nothing to do if not zero now. } +{X LOCK} DEC dword ptr [ECX-8] + JNE @@exit + + { Save the source - we're supposed to return it } + PUSH EAX + MOV EAX,ECX + + { Fetch the type descriptor of the elements } + XOR ECX,ECX + MOV CL,[EDX].TDynArrayTypeInfo.name; + MOV EDX,[EDX+ECX].TDynArrayTypeInfo.elType; + + { If it's non-nil, finalize the elements } + TEST EDX,EDX + JE @@noFinalize + MOV ECX,[EAX-4] + TEST ECX,ECX + JE @@noFinalize + MOV EDX,[EDX] + CALL _FinalizeArray +@@noFinalize: + { Now deallocate the array } + SUB EAX,8 + CALL _FreeMem + POP EAX +@@exit: +end; + + +procedure _DynArrayAsg; +asm +{ ->EAX Pointer to destination (pointer to pointer to heap object } +{ EDX source (pointer to heap object } +{ ECX Pointer to rtti describing dynamic array } + + PUSH EBX + MOV EBX,[EAX] + + { Increment ref count of source if non-nil } + + TEST EDX,EDX + JE @@skipInc +{X LOCK} INC dword ptr [EDX-8] +@@skipInc: + { Dec ref count of destination - if it becomes 0, clear dest } + TEST EBX,EBX + JE @@skipClear +{X LOCK} DEC dword ptr[EBX-8] + JNZ @@skipClear + PUSH EAX + PUSH EDX + MOV EDX,ECX + INC dword ptr[EBX-8] + CALL _DynArrayClear + POP EDX + POP EAX +@@skipClear: + { Finally store source into destination } + MOV [EAX],EDX + + POP EBX +end; + +procedure _DynArrayAddRef; +asm +{ ->EAX Pointer to heap object } + TEST EAX,EAX + JE @@exit +{X LOCK} INC dword ptr [EAX-8] +@@exit: +end; + + +function DynArrayIndex(const P: Pointer; const Indices: array of Integer; const TypInfo: Pointer): Pointer; +asm + { ->EAX P } + { EDX Pointer to Indices } + { ECX High bound of Indices } + { [EBP+8] TypInfo } + + PUSH EBX + PUSH ESI + PUSH EDI + PUSH EBP + + MOV ESI,EDX + MOV EDI,[EBP+8] + MOV EBP,EAX + + XOR EBX,EBX { for i := 0 to High(Indices) do } + TEST ECX,ECX + JGE @@start +@@loop: + MOV EBP,[EBP] +@@start: + XOR EAX,EAX + MOV AL,[EDI].TDynArrayTypeInfo.name + ADD EDI,EAX + MOV EAX,[ESI+EBX*4] { P := P + Indices[i]*TypInfo.elSize } + MUL [EDI].TDynArrayTypeInfo.elSize + MOV EDI,[EDI].TDynArrayTypeInfo.elType + TEST EDI,EDI + JE @@skip + MOV EDI,[EDI] +@@skip: + ADD EBP,EAX + INC EBX + CMP EBX,ECX + JLE @@loop + +@@loopEnd: + + MOV EAX,EBP + + POP EBP + POP EDI + POP ESI + POP EBX +end; + + +{ Returns the DynArrayTypeInfo of the Element Type of the specified DynArrayTypeInfo } +function DynArrayElTypeInfo(typeInfo: PDynArrayTypeInfo): PDynArrayTypeInfo; +begin + Result := nil; + if typeInfo <> nil then + begin + Inc(PChar(typeInfo), Length(typeInfo.name)); + if typeInfo.elType <> nil then + Result := typeInfo.elType^; + end; +end; + +{ Returns # of dimemsions of the DynArray described by the specified DynArrayTypeInfo} +function DynArrayDim(typeInfo: PDynArrayTypeInfo): Integer; +begin + Result := 0; + while (typeInfo <> nil) and (typeInfo.kind = tkDynArray) do + begin + Inc(Result); + typeInfo := DynArrayElTypeInfo(typeInfo); + end; +end; + +{ Returns size of the Dynamic Array} +function DynArraySize(a: Pointer): Integer; +asm + TEST EAX, EAX + JZ @@exit + MOV EAX, [EAX-4] +@@exit: +end; + +// Returns whether array is rectangular +function IsDynArrayRectangular(const DynArray: Pointer; typeInfo: PDynArrayTypeInfo): Boolean; +var + Dim, I, J, Size, SubSize: Integer; + P: Pointer; +begin + // Assume we have a rectangular array + Result := True; + + P := DynArray; + Dim := DynArrayDim(typeInfo); + + {NOTE: Start at 1. Don't need to test the first dimension - it's rectangular by definition} + for I := 1 to dim-1 do + begin + if P <> nil then + begin + { Get size of this dimension } + Size := DynArraySize(P); + + { Get Size of first sub. dimension } + SubSize := DynArraySize(PPointerArray(P)[0]); + + { Walk through every dimension making sure they all have the same size} + for J := 1 to Size-1 do + if DynArraySize(PPointerArray(P)[J]) <> SubSize then + begin + Result := False; + Exit; + end; + + { Point to next dimension} + P := PPointerArray(P)[0]; + end; + end; +end; + +// Returns Bounds of Dynamic array as an array of integer containing the 'high' of each dimension +function DynArrayBounds(const DynArray: Pointer; typeInfo: PDynArrayTypeInfo): TBoundArray; +var + Dim, I: Integer; + P: Pointer; +begin + P := DynArray; + + Dim := DynArrayDim(typeInfo); + SetLength(Result, Dim); + + for I := 0 to dim-1 do + if P <> nil then + begin + Result[I] := DynArraySize(P)-1; + P := PPointerArray(P)[0]; // Assume rectangular arrays + end; +end; + +{ Decrements to next lower index - Returns True if successful } +{ Indices: Indices to be decremented } +{ Bounds : High bounds of each dimension } +function DecIndices(var Indices: TBoundArray; const Bounds: TBoundArray): Boolean; +var + I, J: Integer; +begin + { Find out if we're done: all at zeroes } + Result := False; + for I := Low(Indices) to High(Indices) do + if Indices[I] <> 0 then + begin + Result := True; + break; + end; + if not Result then + Exit; + + { Two arrays must be of same length } + Assert(Length(Indices) = Length(Bounds)); + + { Find index of item to tweak } + for I := High(Indices) downto Low(Bounds) do + begin + // If not reach zero, dec and bail out + if Indices[I] <> 0 then + begin + Dec(Indices[I]); + Exit; + end + else + begin + J := I; + while Indices[J] = 0 do + begin + // Restore high bound when we've reached zero on a particular dimension + Indices[J] := Bounds[J]; + // Move to higher dimension + Dec(J); + Assert(J >= 0); + end; + Dec(Indices[J]); + Exit; + end; + end; +end; + +{ Package/Module registration/unregistration } + +{$IFDEF MSWINDOWS} +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 +{$ENDIF} + +function FindModule(Instance: LongWord): PLibModule; +begin + Result := LibModuleList; + while Result <> nil do + begin + if (Instance = Result.Instance) or + (Instance = Result.CodeInstance) or + (Instance = Result.DataInstance) or + (Instance = Result.ResInstance) then + Exit; + Result := Result.Next; + end; +end; + +function FindHInstance(Address: Pointer): LongWord; +{$IFDEF MSWINDOWS} +var + MemInfo: TMemInfo; +begin + VirtualQuery(Address, MemInfo, SizeOf(MemInfo)); + if MemInfo.State = $1000{MEM_COMMIT} then + Result := LongWord(MemInfo.AllocationBase) + else + Result := 0; +end; +{$ENDIF} +{$IFDEF LINUX} +var + Info: TDLInfo; +begin + if (dladdr(Address, Info) = 0) or (Info.BaseAddress = ExeBaseAddress) then + Info.Filename := nil; // if it's not in a library, assume the exe + Result := LongWord(dlopen(Info.Filename, RTLD_LAZY)); + if Result <> 0 then + dlclose(Result); +end; +{$ENDIF} + +function FindClassHInstance(ClassType: TClass): LongWord; +begin + Result := FindHInstance(Pointer(ClassType)); +end; + +{$IFDEF LINUX} +function GetModuleFileName(Module: HMODULE; Buffer: PChar; BufLen: Integer): Integer; +var + Addr: Pointer; + Info: TDLInfo; + FoundInModule: HMODULE; +begin + Result := 0; + if (Module = MainInstance) or (Module = 0) then + begin + // First, try the dlsym approach. + // dladdr fails to return the name of the main executable + // in glibc prior to 2.1.91 + +{ Look for a dynamic symbol exported from this program. + _DYNAMIC is not required in a main program file. + If the main program is compiled with Delphi, it will always + have a resource section, named @Sysinit@ResSym. + If the main program is not compiled with Delphi, dlsym + will search the global name space, potentially returning + the address of a symbol in some other shared object library + loaded by the program. To guard against that, we check + that the address of the symbol found is within the + main program address range. } + + dlerror; // clear error state; dlsym doesn't + Addr := dlsym(Module, '@Sysinit@ResSym'); + if (Addr <> nil) and (dlerror = nil) + and (dladdr(Addr, Info) <> 0) + and (Info.FileName <> nil) + and (Info.BaseAddress = ExeBaseAddress) then + begin + Result := _strlen(Info.FileName); + if Result >= BufLen then Result := BufLen-1; + Move(Info.FileName^, Buffer^, Result); + Buffer[Result] := #0; + Exit; + end; + + // Try inspecting the /proc/ virtual file system + // to find the program filename in the process info + Result := _readlink('/proc/self/exe', Buffer, BufLen); + if Result <> -1 then + begin + if Result >= BufLen then Result := BufLen-1; + Buffer[Result] := #0; + end; +{$IFDEF AllowParamStrModuleName} +{ Using ParamStr(0) to obtain a module name presents a potential + security hole. Resource modules are loaded based upon the filename + of a given module. We use dlopen() to load resource modules, which + means the .init code of the resource module will be executed. + Normally, resource modules contain no code at all - they're just + carriers of resource data. + An unpriviledged user program could launch our trusted, + priviledged program with a bogus parameter list, tricking us + into loading a module that contains malicious code in its + .init section. + Without this ParamStr(0) section, GetModuleFilename cannot be + misdirected by unpriviledged code (unless the system program loader + or the /proc file system or system root directory has been compromised). + Resource modules are always loaded from the same directory as the + given module. Trusted code (programs, packages, and libraries) + should reside in directories that unpriviledged code cannot alter. + + If you need GetModuleFilename to have a chance of working on systems + where glibc < 2.1.91 and /proc is not available, and your + program will not run as a priviledged user (or you don't care), + you can define AllowParamStrModuleNames and rebuild the System unit + and baseCLX package. Note that even with ParamStr(0) support + enabled, GetModuleFilename can still fail to find the name of + a module. C'est la Unix. } + + if Result = -1 then // couldn't access the /proc filesystem + begin // return less accurate ParamStr(0) + +{ ParamStr(0) returns the name of the link used + to launch the app, not the name of the app itself. + Also, if this app was launched by some other program, + there is no guarantee that the launching program has set + up our environment at all. (example: Apache CGI) } + + if (ArgValues = nil) or (ArgValues^ = nil) or + (PCharArray(ArgValues^)[0] = nil) then + begin + Result := 0; + Exit; + end; + Result := _strlen(PCharArray(ArgValues^)[0]); + if Result >= BufLen then Result := BufLen-1; + Move(PCharArray(ArgValues^)[0]^, Buffer^, Result); + Buffer[Result] := #0; + end; +{$ENDIF} + end + else + begin +{ For shared object libraries, we can rely on the dlsym technique. + Look for a dynamic symbol in the requested module. + Don't assume the module was compiled with Delphi. + We look for a dynamic symbol with the name _DYNAMIC. This + exists in all ELF shared object libraries that export + or import symbols; If someone has a shared object library that + contains no imports or exports of any kind, this will probably fail. + If dlsym can't find the requested symbol in the given module, it + will search the global namespace and could return the address + of a symbol from some other module that happens to be loaded + into this process. That would be bad, so we double check + that the module handle of the symbol found matches the + module handle we asked about.} + + dlerror; // clear error state; dlsym doesn't + Addr := dlsym(Module, '_DYNAMIC'); + if (Addr <> nil) and (dlerror = nil) + and (dladdr(Addr, Info) <> 0) then + begin + if Info.BaseAddress = ExeBaseAddress then + Info.FileName := nil; + FoundInModule := HMODULE(dlopen(Info.FileName, RTLD_LAZY)); + if FoundInModule <> 0 then + dlclose(FoundInModule); + if Module = FoundInModule then + begin + Result := _strlen(Info.FileName); + if Result >= BufLen then Result := BufLen-1; + Move(Info.FileName^, Buffer^, Result); + Buffer[Result] := #0; + end; + end; + end; + if Result < 0 then Result := 0; +end; +{$ENDIF} + +function DelayLoadResourceModule(Module: PLibModule): LongWord; +var + FileName: array[0..MAX_PATH] of Char; +begin + if Module.ResInstance = 0 then + begin + GetModuleFileName(Module.Instance, FileName, SizeOf(FileName)); + Module.ResInstance := LoadResourceModule(FileName); + if Module.ResInstance = 0 then + Module.ResInstance := Module.Instance; + end; + Result := Module.ResInstance; +end; + +function FindResourceHInstance(Instance: LongWord): LongWord; +var + CurModule: PLibModule; +begin + CurModule := LibModuleList; + while CurModule <> nil do + begin + if (Instance = CurModule.Instance) or + (Instance = CurModule.CodeInstance) or + (Instance = CurModule.DataInstance) then + begin + Result := DelayLoadResourceModule(CurModule); + Exit; + end; + CurModule := CurModule.Next; + end; + Result := Instance; +end; + +function LoadResourceModule(ModuleName: PChar; CheckOwner: Boolean): LongWord; +{$IFDEF LINUX} +var + FileName: array [0..MAX_PATH] of Char; + LangCode: PChar; // Language and country code. Example: en_US + P: PChar; + ModuleNameLen, FileNameLen, i: Integer; + st1, st2: TStatStruct; +begin + LangCode := __getenv('LANG'); + Result := 0; + if (LangCode = nil) or (LangCode^ = #0) then Exit; + + // look for modulename.en_US (ignoring codeset and modifier suffixes) + P := LangCode; + while P^ in ['a'..'z', 'A'..'Z', '_'] do + Inc(P); + if P = LangCode then Exit; + + if CheckOwner and (__xstat(STAT_VER_LINUX, ModuleName, st1) = -1) then + Exit; + + ModuleNameLen := _strlen(ModuleName); + if (ModuleNameLen + P - LangCode) >= MAX_PATH then Exit; + Move(ModuleName[0], Filename[0], ModuleNameLen); + Filename[ModuleNameLen] := '.'; + Move(LangCode[0], Filename[ModuleNameLen + 1], P - LangCode); + FileNameLen := ModuleNameLen + 1 + (P - LangCode); + Filename[FileNameLen] := #0; + +{ Security check: make sure the user id (owner) and group id of + the base module matches the user id and group id of the resource + module we're considering loading. This is to prevent loading + of malicious code dropped into the base module's directory by + a hostile user. The app and all its resource modules must + have the same owner and group. To disable this security check, + call this function with CheckOwner set to False. } + + if (not CheckOwner) or + ((__xstat(STAT_VER_LINUX, FileName, st2) <> -1) + and (st1.st_uid = st2.st_uid) + and (st1.st_gid = st2.st_gid)) then + begin + Result := dlopen(Filename, RTLD_LAZY); + if Result <> 0 then Exit; + end; + + // look for modulename.en (ignoring country code and suffixes) + i := ModuleNameLen + 1; + while (i <= FileNameLen) and (Filename[i] in ['a'..'z', 'A'..'Z']) do + Inc(i); + if (i = ModuleNameLen + 1) or (i > FileNameLen) then Exit; + FileName[i] := #0; + + { Security check. See notes above. } + if (not CheckOwner) or + ((__xstat(STAT_VER_LINUX, FileName, st2) <> -1) + and (st1.st_uid = st2.st_uid) + and (st1.st_gid = st2.st_gid)) then + begin + Result := dlopen(FileName, RTLD_LAZY); + end; +end; +{$ENDIF} +{$IFDEF MSWINDOWS} +var + FileName: array[0..MAX_PATH] of Char; + Key: LongWord; + LocaleName, LocaleOverride: array[0..4] of Char; + Size: Integer; + P: PChar; + + function FindBS(Current: PChar): PChar; + begin + Result := Current; + while (Result^ <> #0) and (Result^ <> '\') do + Result := CharNext(Result); + end; + + function ToLongPath(AFileName: PChar; BufSize: Integer): PChar; + var + CurrBS, NextBS: PChar; + Handle, L: Integer; + FindData: TWin32FindData; + Buffer: array[0..MAX_PATH] of Char; + GetLongPathName: function (ShortPathName: PChar; LongPathName: PChar; + cchBuffer: Integer): Integer stdcall; + begin + Result := AFileName; + Handle := GetModuleHandle(kernel); + if Handle <> 0 then + begin + @GetLongPathName := GetProcAddress(Handle, 'GetLongPathNameA'); + if Assigned(GetLongPathName) and + (GetLongPathName(AFileName, Buffer, SizeOf(Buffer)) <> 0) then + begin + lstrcpyn(AFileName, Buffer, BufSize); + Exit; + end; + end; + + if AFileName[0] = '\' then + begin + if AFileName[1] <> '\' then Exit; + CurrBS := FindBS(AFileName + 2); // skip server name + if CurrBS^ = #0 then Exit; + CurrBS := FindBS(CurrBS + 1); // skip share name + if CurrBS^ = #0 then Exit; + end else + CurrBS := AFileName + 2; // skip drive name + + L := CurrBS - AFileName; + lstrcpyn(Buffer, AFileName, L + 1); + while CurrBS^ <> #0 do + begin + NextBS := FindBS(CurrBS + 1); + if L + (NextBS - CurrBS) + 1 > SizeOf(Buffer) then Exit; + lstrcpyn(Buffer + L, CurrBS, (NextBS - CurrBS) + 1); + + Handle := FindFirstFile(Buffer, FindData); + if (Handle = -1) then Exit; + FindClose(Handle); + + if L + 1 + _strlen(FindData.cFileName) + 1 > SizeOf(Buffer) then Exit; + Buffer[L] := '\'; + lstrcpyn(Buffer + L + 1, FindData.cFileName, Sizeof(Buffer) - L - 1); + Inc(L, _strlen(FindData.cFileName) + 1); + CurrBS := NextBS; + end; + lstrcpyn(AFileName, Buffer, BufSize); + end; +begin + GetModuleFileName(0, FileName, SizeOf(FileName)); // Get host application name + LocaleOverride[0] := #0; + if (RegOpenKeyEx(HKEY_CURRENT_USER, NewLocaleOverrideKey, 0, KEY_READ, Key) = 0) or + (RegOpenKeyEx(HKEY_LOCAL_MACHINE, NewLocaleOverrideKey, 0, KEY_READ, Key) = 0) or + (RegOpenKeyEx(HKEY_CURRENT_USER, OldLocaleOverrideKey, 0, KEY_READ, Key) = 0) then + try + Size := sizeof(LocaleOverride); + ToLongPath(FileName, sizeof(FileName)); + if RegQueryValueEx(Key, FileName, nil, nil, LocaleOverride, @Size) <> 0 then + if RegQueryValueEx(Key, '', nil, nil, LocaleOverride, @Size) <> 0 then + LocaleOverride[0] := #0; + LocaleOverride[sizeof(LocaleOverride)-1] := #0; + finally + RegCloseKey(Key); + end; + lstrcpyn(FileName, ModuleName, sizeof(FileName)); + GetLocaleInfo(GetThreadLocale, LOCALE_SABBREVLANGNAME, LocaleName, sizeof(LocaleName)); + Result := 0; + if (FileName[0] <> #0) and ((LocaleName[0] <> #0) or (LocaleOverride[0] <> #0)) then + begin + P := PChar(@FileName) + _strlen(FileName); + while (P^ <> '.') and (P <> @FileName) do Dec(P); + if P <> @FileName then + begin + Inc(P); + // First look for a locale registry override + if LocaleOverride[0] <> #0 then + begin + lstrcpyn(P, LocaleOverride, sizeof(FileName) - (P - FileName)); + Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE); + end; + if (Result = 0) and (LocaleName[0] <> #0) then + begin + // Then look for a potential language/country translation + lstrcpyn(P, LocaleName, sizeof(FileName) - (P - FileName)); + Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE); + if Result = 0 then + begin + // Finally look for a language only translation + LocaleName[2] := #0; + lstrcpyn(P, LocaleName, sizeof(FileName) - (P - FileName)); + Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE); + end; + end; + end; + end; +end; +{$ENDIF} + +procedure EnumModules(Func: TEnumModuleFunc; Data: Pointer); assembler; +begin + EnumModules(TEnumModuleFuncLW(Func), Data); +end; + +procedure EnumResourceModules(Func: TEnumModuleFunc; Data: Pointer); +begin + EnumResourceModules(TEnumModuleFuncLW(Func), Data); +end; + +procedure EnumModules(Func: TEnumModuleFuncLW; Data: Pointer); +var + CurModule: PLibModule; +begin + CurModule := LibModuleList; + while CurModule <> nil do + begin + if not Func(CurModule.Instance, Data) then Exit; + CurModule := CurModule.Next; + end; +end; + +procedure EnumResourceModules(Func: TEnumModuleFuncLW; Data: Pointer); +var + CurModule: PLibModule; +begin + CurModule := LibModuleList; + while CurModule <> nil do + begin + if not Func(DelayLoadResourceModule(CurModule), Data) then Exit; + CurModule := CurModule.Next; + end; +end; + +procedure AddModuleUnloadProc(Proc: TModuleUnloadProc); +begin + AddModuleUnloadProc(TModuleUnloadProcLW(Proc)); +end; + +procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProc); +begin + RemoveModuleUnloadProc(TModuleUnloadProcLW(Proc)); +end; + +procedure AddModuleUnloadProc(Proc: TModuleUnloadProcLW); +var + P: PModuleUnloadRec; +begin + New(P); + P.Next := ModuleUnloadList; + @P.Proc := @Proc; + ModuleUnloadList := P; +end; + +procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProcLW); +var + P, C: PModuleUnloadRec; +begin + P := ModuleUnloadList; + if (P <> nil) and (@P.Proc = @Proc) then + begin + ModuleUnloadList := ModuleUnloadList.Next; + Dispose(P); + end else + begin + C := P; + while C <> nil do + begin + if (C.Next <> nil) and (@C.Next.Proc = @Proc) then + begin + P := C.Next; + C.Next := C.Next.Next; + Dispose(P); + Break; + end; + C := C.Next; + end; + end; +end; + +procedure NotifyModuleUnload(HInstance: LongWord); +var + P: PModuleUnloadRec; +begin + P := ModuleUnloadList; + while P <> nil do + begin + try + P.Proc(HInstance); + except + // Make sure it doesn't stop notifications + end; + P := P.Next; + end; +{$IFDEF LINUX} + InvalidateModuleCache; +{$ENDIF} +end; + +procedure RegisterModule(LibModule: PLibModule); +begin + LibModule.Next := LibModuleList; + LibModuleList := LibModule; +end; + +{X- procedure UnregisterModule(LibModule: PLibModule); -renamed } +procedure UnRegisterModuleSafely( LibModule: PLibModule ); +var + CurModule: PLibModule; +begin + try + NotifyModuleUnload(LibModule.Instance); + finally + if LibModule = LibModuleList then + LibModuleList := LibModule.Next + else + begin + CurModule := LibModuleList; + while CurModule <> nil do + begin + if CurModule.Next = LibModule then + begin + CurModule.Next := LibModule.Next; + Break; + end; + CurModule := CurModule.Next; + end; + end; + end; +end; + +{X+} // "Light" version of UnRegisterModule - without using of try-except +procedure UnRegisterModuleLight( LibModule: PLibModule ); +var + P: PModuleUnloadRec; +begin + P := ModuleUnloadList; + while P <> nil do + begin + P.Proc(LibModule.Instance); + P := P.Next; + end; +end; +{X-} + +function _IntfClear(var Dest: IInterface): Pointer; +{$IFDEF PUREPASCAL} +var + P: Pointer; +begin + Result := @Dest; + if Dest <> nil then + begin + P := Pointer(Dest); + Pointer(Dest) := nil; + IInterface(P)._Release; + end; +end; +{$ELSE} +asm + MOV EDX,[EAX] + TEST EDX,EDX + JE @@1 + MOV DWORD PTR [EAX],0 + PUSH EAX + PUSH EDX + MOV EAX,[EDX] + CALL DWORD PTR [EAX] + VMTOFFSET IInterface._Release + POP EAX +@@1: +end; +{$ENDIF} + +procedure _IntfCopy(var Dest: IInterface; const Source: IInterface); +{$IFDEF PUREPASCAL} +var + P: Pointer; +begin + P := Pointer(Dest); + if Source <> nil then + Source._AddRef; + Pointer(Dest) := Pointer(Source); + if P <> nil then + IInterface(P)._Release; +end; +{$ELSE} +asm +{ + The most common case is the single assignment of a non-nil interface + to a nil interface. So we streamline that case here. After this, + we give essentially equal weight to other outcomes. + + The semantics are: The source intf must be addrefed *before* it + is assigned to the destination. The old intf must be released + after the new intf is addrefed to support self assignment (I := I). + Either intf can be nil. The first requirement is really to make an + error case function a little better, and to improve the behaviour + of multithreaded applications - if the addref throws an exception, + you don't want the interface to have been assigned here, and if the + assignment is made to a global and another thread references it, + again you don't want the intf to be available until the reference + count is bumped. +} + TEST EDX,EDX // is source nil? + JE @@NilSource + PUSH EDX // save source + PUSH EAX // save dest + MOV EAX,[EDX] // get source vmt + PUSH EDX // source as arg + CALL DWORD PTR [EAX] + VMTOFFSET IInterface._AddRef + POP EAX // retrieve dest + MOV ECX, [EAX] // get current value + POP [EAX] // set dest in place + TEST ECX, ECX // is current value nil? + JNE @@ReleaseDest // no, release it + RET // most common case, we return here +@@ReleaseDest: + MOV EAX,[ECX] // get current value vmt + PUSH ECX // current value as arg + CALL DWORD PTR [EAX] + VMTOFFSET IInterface._Release + RET + +{ Now we're into the less common cases. } +@@NilSource: + MOV ECX, [EAX] // get current value + TEST ECX, ECX // is it nil? + MOV [EAX], EDX // store in dest (which is nil) + JE @@Done + MOV EAX, [ECX] // get current vmt + PUSH ECX // current value as arg + CALL [EAX].vmtRelease.Pointer +@@Done: +end; +{$ENDIF} + +procedure _IntfCast(var Dest: IInterface; const Source: IInterface; const IID: TGUID); +{$IFDEF PUREPASCAL} +// PIC: EBX must be correct before calling QueryInterface +begin + if Source = nil then + Dest := nil + else if Source.QueryInterface(IID, Dest) <> 0 then + Error(reIntfCastError); +end; +{$ELSE} +asm + TEST EDX,EDX + JE _IntfClear + PUSH EAX + PUSH ECX + PUSH EDX + MOV ECX,[EAX] + TEST ECX,ECX + JE @@1 + PUSH ECX + MOV EAX,[ECX] + CALL DWORD PTR [EAX] + VMTOFFSET IInterface._Release + MOV EDX,[ESP] +@@1: MOV EAX,[EDX] + CALL DWORD PTR [EAX] + VMTOFFSET IInterface.QueryInterface + TEST EAX,EAX + JE @@2 + MOV AL,reIntfCastError + JMP Error +@@2: +end; +{$ENDIF} + +procedure _IntfAddRef(const Dest: IInterface); +begin + if Dest <> nil then Dest._AddRef; +end; + +procedure TInterfacedObject.AfterConstruction; +begin +// Release the constructor's implicit refcount + InterlockedDecrement(FRefCount); +end; + +procedure TInterfacedObject.BeforeDestruction; +begin + if RefCount <> 0 then + Error(reInvalidPtr); +end; + +// Set an implicit refcount so that refcounting +// during construction won't destroy the object. +class function TInterfacedObject.NewInstance: TObject; +begin + Result := inherited NewInstance; + TInterfacedObject(Result).FRefCount := 1; +end; + +function TInterfacedObject.QueryInterface(const IID: TGUID; out Obj): HResult; +begin + if GetInterface(IID, Obj) then + Result := 0 + else + Result := E_NOINTERFACE; +end; + +function TInterfacedObject._AddRef: Integer; +begin + Result := InterlockedIncrement(FRefCount); +end; + +function TInterfacedObject._Release: Integer; +begin + Result := InterlockedDecrement(FRefCount); + if Result = 0 then + Destroy; +end; + +{ TAggregatedObject } + +constructor TAggregatedObject.Create(const Controller: IInterface); +begin + // weak reference to controller - don't keep it alive + FController := Pointer(Controller); +end; + +function TAggregatedObject.GetController: IInterface; +begin + Result := IInterface(FController); +end; + +function TAggregatedObject.QueryInterface(const IID: TGUID; out Obj): HResult; +begin + Result := IInterface(FController).QueryInterface(IID, Obj); +end; + +function TAggregatedObject._AddRef: Integer; +begin + Result := IInterface(FController)._AddRef; +end; + +function TAggregatedObject._Release: Integer; stdcall; +begin + Result := IInterface(FController)._Release; +end; + +{ TContainedObject } + +function TContainedObject.QueryInterface(const IID: TGUID; out Obj): HResult; +begin + if GetInterface(IID, Obj) then + Result := S_OK + else + Result := E_NOINTERFACE; +end; + + +function _CheckAutoResult(ResultCode: HResult): HResult; +{$IF Defined(PIC) or Defined(PUREPASCAL)} +begin + if ResultCode < 0 then + begin + if Assigned(SafeCallErrorProc) then + SafeCallErrorProc(ResultCode, Pointer(-1)); // loses error address + Error(reSafeCallError); + end; + Result := ResultCode; +end; +{$ELSE} +asm + TEST EAX,EAX + JNS @@2 + MOV ECX,SafeCallErrorProc + TEST ECX,ECX + JE @@1 + MOV EDX,[ESP] + CALL ECX +@@1: MOV AL,reSafeCallError + JMP Error +@@2: +end; +{$IFEND} + +function CompToDouble(Value: Comp): Double; cdecl; +begin + Result := Value; +end; + +procedure DoubleToComp(Value: Double; var Result: Comp); cdecl; +begin + Result := Value; +end; + +function CompToCurrency(Value: Comp): Currency; cdecl; +begin + Result := Value; +end; + +procedure CurrencyToComp(Value: Currency; var Result: Comp); cdecl; +begin + Result := Value; +end; + +function GetMemory(Size: Integer): Pointer; cdecl; +begin + Result := MemoryManager.GetMem(Size); +end; + +function FreeMemory(P: Pointer): Integer; cdecl; +begin + if P = nil then + Result := 0 + else + Result := MemoryManager.FreeMem(P); +end; + +function ReallocMemory(P: Pointer; Size: Integer): Pointer; cdecl; +begin + Result := MemoryManager.ReallocMem(P, Size); +end; + +procedure SetLineBreakStyle(var T: Text; Style: TTextLineBreakStyle); +begin + if TTextRec(T).Mode = fmClosed then + TTextRec(T).Flags := TTextRec(T).Flags or (tfCRLF * Byte(Style)) + else + SetInOutRes(107); // can't change mode of open file +end; + +// UnicodeToUTF8(3): +// Scans the source data to find the null terminator, up to MaxBytes +// Dest must have MaxBytes available in Dest. + +function UnicodeToUtf8(Dest: PChar; Source: PWideChar; MaxBytes: Integer): Integer; +var + len: Cardinal; +begin + len := 0; + if Source <> nil then + while Source[len] <> #0 do + Inc(len); + Result := UnicodeToUtf8(Dest, MaxBytes, Source, len); +end; + +// UnicodeToUtf8(4): +// MaxDestBytes includes the null terminator (last char in the buffer will be set to null) +// Function result includes the null terminator. +// Nulls in the source data are not considered terminators - SourceChars must be accurate + +function UnicodeToUtf8(Dest: PChar; MaxDestBytes: Cardinal; Source: PWideChar; SourceChars: Cardinal): Cardinal; +var + i, count: Cardinal; + c: Cardinal; +begin + Result := 0; + if Source = nil then Exit; + count := 0; + i := 0; + if Dest <> nil then + begin + while (i < SourceChars) and (count < MaxDestBytes) do + begin + c := Cardinal(Source[i]); + Inc(i); + if c <= $7F then + begin + Dest[count] := Char(c); + Inc(count); + end + else if c > $7FF then + begin + if count + 3 > MaxDestBytes then + break; + Dest[count] := Char($E0 or (c shr 12)); + Dest[count+1] := Char($80 or ((c shr 6) and $3F)); + Dest[count+2] := Char($80 or (c and $3F)); + Inc(count,3); + end + else // $7F < Source[i] <= $7FF + begin + if count + 2 > MaxDestBytes then + break; + Dest[count] := Char($C0 or (c shr 6)); + Dest[count+1] := Char($80 or (c and $3F)); + Inc(count,2); + end; + end; + if count >= MaxDestBytes then count := MaxDestBytes-1; + Dest[count] := #0; + end + else + begin + while i < SourceChars do + begin + c := Integer(Source[i]); + Inc(i); + if c > $7F then + begin + if c > $7FF then + Inc(count); + Inc(count); + end; + Inc(count); + end; + end; + Result := count+1; // convert zero based index to byte count +end; + +function Utf8ToUnicode(Dest: PWideChar; Source: PChar; MaxChars: Integer): Integer; +var + len: Cardinal; +begin + len := 0; + if Source <> nil then + while Source[len] <> #0 do + Inc(len); + Result := Utf8ToUnicode(Dest, MaxChars, Source, len); +end; + +function Utf8ToUnicode(Dest: PWideChar; MaxDestChars: Cardinal; Source: PChar; SourceBytes: Cardinal): Cardinal; +var + i, count: Cardinal; + c: Byte; + wc: Cardinal; +begin + if Source = nil then + begin + Result := 0; + Exit; + end; + Result := Cardinal(-1); + count := 0; + i := 0; + if Dest <> nil then + begin + while (i < SourceBytes) and (count < MaxDestChars) do + begin + wc := Cardinal(Source[i]); + Inc(i); + if (wc and $80) <> 0 then + begin + wc := wc and $3F; + if i > SourceBytes then Exit; // incomplete multibyte char + if (wc and $20) <> 0 then + begin + c := Byte(Source[i]); + Inc(i); + if (c and $C0) <> $80 then Exit; // malformed trail byte or out of range char + if i > SourceBytes then Exit; // incomplete multibyte char + wc := (wc shl 6) or (c and $3F); + end; + c := Byte(Source[i]); + Inc(i); + if (c and $C0) <> $80 then Exit; // malformed trail byte + + Dest[count] := WideChar((wc shl 6) or (c and $3F)); + end + else + Dest[count] := WideChar(wc); + Inc(count); + end; + if count >= MaxDestChars then count := MaxDestChars-1; + Dest[count] := #0; + end + else + begin + while (i <= SourceBytes) do + begin + c := Byte(Source[i]); + Inc(i); + if (c and $80) <> 0 then + begin + if (c and $F0) = $F0 then Exit; // too many bytes for UCS2 + if (c and $40) = 0 then Exit; // malformed lead byte + if i > SourceBytes then Exit; // incomplete multibyte char + + if (Byte(Source[i]) and $C0) <> $80 then Exit; // malformed trail byte + Inc(i); + if i > SourceBytes then Exit; // incomplete multibyte char + if ((c and $20) <> 0) and ((Byte(Source[i]) and $C0) <> $80) then Exit; // malformed trail byte + Inc(i); + end; + Inc(count); + end; + end; + Result := count+1; +end; + +function Utf8Encode(const WS: WideString): UTF8String; +var + L: Integer; + Temp: UTF8String; +begin + Result := ''; + if WS = '' then Exit; + SetLength(Temp, Length(WS) * 3); // SetLength includes space for null terminator + + L := UnicodeToUtf8(PChar(Temp), Length(Temp)+1, PWideChar(WS), Length(WS)); + if L > 0 then + SetLength(Temp, L-1) + else + Temp := ''; + Result := Temp; +end; + +function Utf8Decode(const S: UTF8String): WideString; +var + L: Integer; + Temp: WideString; +begin + Result := ''; + if S = '' then Exit; + SetLength(Temp, Length(S)); + + L := Utf8ToUnicode(PWideChar(Temp), Length(Temp)+1, PChar(S), Length(S)); + if L > 0 then + SetLength(Temp, L-1) + else + Temp := ''; + Result := Temp; +end; + +function AnsiToUtf8(const S: string): UTF8String; +begin + Result := Utf8Encode(S); +end; + +function Utf8ToAnsi(const S: UTF8String): string; +begin + Result := Utf8Decode(S); +end; + +{$IFDEF LINUX} + +function GetCPUType: Integer; +asm + PUSH EBX + // this code assumes ESP is 4 byte aligned + // test for 80386: see if bit #18 of EFLAGS (Alignment fault) can be toggled + PUSHF + POP EAX + MOV ECX, EAX + XOR EAX, $40000 // flip AC bit in EFLAGS + PUSH EAX + POPF + PUSHF + POP EAX + XOR EAX, ECX // zero = 80386 CPU (can't toggle AC bit) + MOV EAX, CPUi386 + JZ @@Exit + PUSH ECX + POPF // restore original flags before next test + + // test for 80486: see if bit #21 of EFLAGS (CPUID supported) can be toggled + MOV EAX, ECX // get original EFLAGS + XOR EAX, $200000 // flip CPUID bit in EFLAGS + PUSH EAX + POPF + PUSHF + POP EAX + XOR EAX, ECX // zero = 80486 (can't toggle EFLAGS bit #21) + MOV EAX, CPUi486 + JZ @@Exit + + // Use CPUID instruction to get CPU family + XOR EAX, EAX + CPUID + CMP EAX, 1 + JL @@Exit // unknown processor response: report as 486 + XOR EAX, EAX + INC EAX // we only care about info level 1 + CPUID + AND EAX, $F00 + SHR EAX, 8 + // Test8086 values are one less than the CPU model number, for historical reasons + DEC EAX + +@@Exit: + POP EBX +end; + + +const + sResSymExport = '@Sysinit@ResSym'; + sResStrExport = '@Sysinit@ResStr'; + sResHashExport = '@Sysinit@ResHash'; + +type + TElf32Sym = record + Name: Cardinal; + Value: Pointer; + Size: Cardinal; + Info: Byte; + Other: Byte; + Section: Word; + end; + PElf32Sym = ^TElf32Sym; + + TElfSymTab = array [0..0] of TElf32Sym; + PElfSymTab = ^TElfSymTab; + + TElfWordTab = array [0..2] of Cardinal; + PElfWordTab = ^TElfWordTab; + + +{ If Name encodes a numeric identifier, return it, else return -1. } +function NameToId(Name: PChar): Longint; +var digit: Longint; +begin + if Longint(Name) and $ffff0000 = 0 then + begin + Result := Longint(Name) and $ffff; + end + else if Name^ = '#' then + begin + Result := 0; + inc (Name); + while (Ord(Name^) <> 0) do + begin + digit := Ord(Name^) - Ord('0'); + if (LongWord(digit) > 9) then + begin + Result := -1; + exit; + end; + Result := Result * 10 + digit; + inc (Name); + end; + end + else + Result := -1; +end; + + +// Return ELF hash value for NAME converted to lower case. +function ElfHashLowercase(Name: PChar): Cardinal; +var + g: Cardinal; + c: Char; +begin + Result := 0; + while name^ <> #0 do + begin + c := name^; + case c of + 'A'..'Z': Inc(c, Ord('a') - Ord('A')); + end; + Result := (Result shl 4) + Ord(c); + g := Result and $f0000000; + Result := (Result xor (g shr 24)) and not g; + Inc(name); + end; +end; + +type + PFindResourceCache = ^TFindResourceCache; + TFindResourceCache = record + ModuleHandle: HMODULE; + Version: Cardinal; + SymbolTable: PElfSymTab; + StringTable: PChar; + HashTable: PElfWordTab; + BaseAddress: Cardinal; + end; + +threadvar + FindResourceCache: TFindResourceCache; + +function GetResourceCache(ModuleHandle: HMODULE): PFindResourceCache; +var + info: TDLInfo; +begin + Result := @FindResourceCache; + if (ModuleHandle <> Result^.ModuleHandle) or (ModuleCacheVersion <> Result^.Version) then + begin + Result^.SymbolTable := dlsym(ModuleHandle, sResSymExport); + Result^.StringTable := dlsym(ModuleHandle, sResStrExport); + Result^.HashTable := dlsym(ModuleHandle, sResHashExport); + Result^.ModuleHandle := ModuleHandle; + if (dladdr(Result^.HashTable, Info) = 0) or (Info.BaseAddress = ExeBaseAddress) then + Result^.BaseAddress := 0 // if it's not in a library, assume the exe + else + Result^.BaseAddress := Cardinal(Info.BaseAddress); + Result^.Version := ModuleCacheVersion; + end; +end; + +function FindResource(ModuleHandle: HMODULE; ResourceName: PChar; ResourceType: PChar): TResourceHandle; +var + P: PFindResourceCache; + nid, tid: Longint; + ucs2_key: array [0..2] of WideChar; + key: array [0..127] of Char; + len: Integer; + pc: PChar; + ch: Char; + nbucket: Cardinal; + bucket, chain: PElfWordTab; + syndx: Cardinal; +begin + Result := 0; + if ResourceName = nil then Exit; + P := GetResourceCache(ModuleHandle); + + tid := NameToId (ResourceType); + if tid = -1 then Exit; { not supported (yet?) } + + { This code must match util-common/elfres.c } + nid := NameToId (ResourceName); + if nid = -1 then + begin + ucs2_key[0] := WideChar(2*tid+2); + ucs2_key[1] := WideChar(0); + len := UnicodeToUtf8 (key, ucs2_key, SizeOf (key)); + pc := key+len; + while Ord(ResourceName^) <> 0 do + begin + ch := ResourceName^; + if Ord(ch) > 127 then exit; { insist on 7bit ASCII for now } + if ('A' <= ch) and (ch <= 'Z') then Inc(ch, Ord('a') - Ord('A')); + pc^ := ch; + inc (pc); + if pc = key + SizeOf(key) then exit; + inc (ResourceName); + end; + pc^ := Char(0); + end + else + begin + ucs2_key[0] := WideChar(2*tid+1); + ucs2_key[1] := WideChar(nid); + ucs2_key[2] := WideChar(0); + UnicodeToUtf8 (key, ucs2_key, SizeOf (key)); + end; + + with P^ do + begin + nbucket := HashTable[0]; + // nsym := HashTable[1]; + bucket := @HashTable[2]; + chain := @HashTable[2+nbucket]; + + syndx := bucket[ElfHashLowercase(key) mod nbucket]; + while (syndx <> 0) + and (strcasecmp(key, @StringTable[SymbolTable[syndx].Name]) <> 0) do + syndx := chain[syndx]; + + if syndx = 0 then + Result := 0 + else + Result := TResourceHandle(@SymbolTable[syndx]); + end; +end; + +function LoadResource(ModuleHandle: HMODULE; ResHandle: TResourceHandle): HGLOBAL; +var + P: PFindResourceCache; +begin + if ResHandle <> 0 then + begin + P := GetResourceCache(ModuleHandle); + Result := HGLOBAL(PElf32Sym(ResHandle)^.Value); + Inc (Cardinal(Result), P^.BaseAddress); + end + else + Result := 0; +end; + +function SizeofResource(ModuleHandle: HMODULE; ResHandle: TResourceHandle): Integer; +begin + if ResHandle <> 0 then + Result := PElf32Sym(ResHandle)^.Size + else + Result := 0; +end; + +function LockResource(ResData: HGLOBAL): Pointer; +begin + Result := Pointer(ResData); +end; + +function UnlockResource(ResData: HGLOBAL): LongBool; +begin + Result := False; +end; + +function FreeResource(ResData: HGLOBAL): LongBool; +begin + Result := True; +end; +{$ENDIF} + +{ ResString support function } + +{$IFDEF MSWINDOWS} +function LoadResString(ResStringRec: PResStringRec): string; +var + Buffer: array [0..1023] of char; +begin + if ResStringRec = nil then Exit; + if ResStringRec.Identifier < 64*1024 then + SetString(Result, Buffer, + LoadString(FindResourceHInstance(ResStringRec.Module^), + ResStringRec.Identifier, Buffer, SizeOf(Buffer))) + else + Result := PChar(ResStringRec.Identifier); +end; +{$ENDIF} +{$IFDEF LINUX} + +const + ResStringTableLen = 16; + +type + ResStringTable = array [0..ResStringTableLen-1] of LongWord; + +function LoadResString(ResStringRec: PResStringRec): string; +var + Handle: TResourceHandle; + Tab: ^ResStringTable; + ResMod: HMODULE; +begin + if ResStringRec = nil then Exit; + ResMod := FindResourceHInstance(ResStringRec^.Module^); + Handle := FindResource(ResMod, + PChar(ResStringRec^.Identifier div ResStringTableLen), + PChar(6)); // RT_STRING + Tab := Pointer(LoadResource(ResMod, Handle)); + if Tab = nil then + Result := '' + else + Result := PChar (Tab) + Tab[ResStringRec^.Identifier mod ResStringTableLen]; +end; + +procedure DbgUnlockX; +begin + if Assigned(DbgUnlockXProc) then + DbgUnlockXProc; +end; + +{ The Win32 program loader sets up the first 64k of process address space + with no read or write access, to help detect use of invalid pointers + (whose integer value is 0..64k). Linux doesn't do this. + + Parts of the Delphi RTL and IDE design environment + rely on the notion that pointer values in the [0..64k] range are + invalid pointers. To accomodate this in Linux, we reserve the range + at startup. If the range is already allocated, we keep going anyway. } + +var + ZeroPageReserved: Boolean = False; + +procedure ReserveZeroPage; +const + PROT_NONE = 0; + MAP_PRIVATE = $02; + MAP_FIXED = $10; + MAP_ANONYMOUS = $20; +var + P: Pointer; +begin + if IsLibrary then Exit; // page reserve is app's job, not .so's + + if not ZeroPageReserved then + begin + P := mmap(nil, High(Word), PROT_NONE, + MAP_ANONYMOUS or MAP_PRIVATE or MAP_FIXED, 0, 0); + ZeroPageReserved := P = nil; + if (Integer(P) <> -1) and (P <> nil) then // we didn't get it + munmap(P, High(Word)); + end; +end; + +procedure ReleaseZeroPage; +begin + if ZeroPageReserved then + begin + munmap(nil, High(Word) - 4096); + ZeroPageReserved := False; + end; +end; +{$ENDIF} + +function PUCS4Chars(const S: UCS4String): PUCS4Char; +const + Null: UCS4Char = 0; + PNull: PUCS4Char = @Null; +begin + if Length(S) > 0 then + Result := @S[0] + else + Result := PNull; +end; + +function WideStringToUCS4String(const S: WideString): UCS4String; +var + I: Integer; +begin + SetLength(Result, Length(S) + 1); + for I := 0 to Length(S) - 1 do + Result[I] := UCS4Char(S[I + 1]); + Result[Length(S)] := 0; +end; + +function UCS4StringToWidestring(const S: UCS4String): WideString; +var + I: Integer; +begin + SetLength(Result, Length(S)); + for I := 0 to Length(S)-1 do + Result[I+1] := WideChar(S[I]); + Result[Length(S)] := #0; +end; + +var SaveCmdShow : Integer = -1; +function CmdShow: Integer; +var + SI: TStartupInfo; +begin + if SaveCmdShow < 0 then + begin + SaveCmdShow := 10; { SW_SHOWDEFAULT } + GetStartupInfo(SI); + if SI.dwFlags and 1 <> 0 then { STARTF_USESHOWWINDOW } + SaveCmdShow := SI.wShowWindow; + end; + Result := SaveCmdShow; +end; + +{X} // convert var CmdLine : PChar to a function: +{X} function CmdLine : PChar; +{X} begin +{X} Result := GetCommandLine; +{X} end; + +initialization + {$IFDEF MSWINDOWS} + {$IFDEF USE_PROCESS_HEAP} + HeapHandle := GetProcessHeap; + {$ELSE} + HeapHandle := HeapCreate( 0, 0, 0 ); + {$ENDIF} + {$ENDIF} + + {$IFDEF MSWINDOWS} + //{X (initialized statically} FileMode := 2; + {$ELSE} + FileMode := 2; + {$ENDIF} + +{$IFDEF LINUX} + FileAccessRights := S_IRUSR or S_IWUSR or S_IRGRP or S_IWGRP or S_IROTH or S_IWOTH; + Test8086 := GetCPUType; + IsConsole := True; + FindResourceCache.ModuleHandle := LongWord(-1); + ReserveZeroPage; +{$ELSE} + //{X (initialized statically} Test8086 := 2; +{$ENDIF} + + DispCallByIDProc := @_DispCallByIDError; + +{$IFDEF MSWINDOWS} + //{X} if _isNECWindows then _FpuMaskInit; +{$ENDIF} + //{X} _FpuInit(); + + TTextRec(Input).Mode := fmClosed; + TTextRec(Output).Mode := fmClosed; + TTextRec(ErrOutput).Mode := fmClosed; + InitVariantManager; + +{$IFDEF MSWINDOWS} +{X- CmdLine := GetCommandLine; converted to a function } +{X- CmdShow := GetCmdShow; converted to a function } +{$ENDIF} + MainThreadID := GetCurrentThreadID; + +{$IFDEF LINUX} + // Ensure DbgUnlockX is linked in, calling it now does nothing + DbgUnlockX; +{$ENDIF} + +finalization + {X+} + {X} CloseInputOutput; + {X- + Close(Input); + Close(Output); + Close(ErrOutput); + X+} +{$IFDEF LINUX} + ReleaseZeroPage; +{$ENDIF} +{$IFDEF MSWINDOWS} +{X UninitAllocator; - replaced with call to UninitMemoryManager handler. } + UninitMemoryManager; +{$ENDIF} +end. + diff --git a/System/D7_avenger/getmem.inc b/System/D7_avenger/getmem.inc new file mode 100644 index 0000000..f9b4f67 --- /dev/null +++ b/System/D7_avenger/getmem.inc @@ -0,0 +1,1541 @@ +{ *********************************************************************** } +{ } +{ Delphi Runtime Library } +{ } +{ Copyright (c) 1996,2001 Borland Software Corporation } +{ } +{ *********************************************************************** } + +// Three layers: +// - Address space administration +// - Committed space administration +// - Suballocator +// +// Helper module: administrating block descriptors +// + + +// +// Operating system interface +// +const + LMEM_FIXED = 0; + LMEM_ZEROINIT = $40; + + MEM_COMMIT = $1000; + MEM_RESERVE = $2000; + MEM_DECOMMIT = $4000; + MEM_RELEASE = $8000; + + PAGE_NOACCESS = 1; + PAGE_READWRITE = 4; + +type + DWORD = Integer; + BOOL = LongBool; + + TRTLCriticalSection = packed record + DebugInfo: Pointer; + LockCount: Longint; + RecursionCount: Longint; + OwningThread: Integer; + LockSemaphore: Integer; + Reserved: DWORD; + end; + +{function LocalAlloc(flags, size: Integer): Pointer; stdcall; + external kernel name 'LocalAlloc'; +function LocalFree(addr: Pointer): Pointer; stdcall; + external kernel name 'LocalFree';} + +function VirtualAlloc(lpAddress: Pointer; + dwSize, flAllocationType, flProtect: DWORD): Pointer; stdcall; + external kernel name 'VirtualAlloc'; +function VirtualFree(lpAddress: Pointer; dwSize, dwFreeType: DWORD): BOOL; stdcall; + external kernel name 'VirtualFree'; + +procedure InitializeCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall; + external kernel name 'InitializeCriticalSection'; +procedure EnterCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall; + external kernel name 'EnterCriticalSection'; +procedure LeaveCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall; + external kernel name 'LeaveCriticalSection'; +procedure DeleteCriticalSection(var lpCriticalSection: TRTLCriticalSection); stdcall; + external kernel name 'DeleteCriticalSection'; + +// Common Data structure: + +type + TBlock = packed record + addr: PChar; + size: Integer; + end; + +// Heap error codes + +const + cHeapOk = 0; // everything's fine + cReleaseErr = 1; // operating system returned an error when we released + cDecommitErr = 2; // operating system returned an error when we decommited + cBadCommittedList = 3; // list of committed blocks looks bad + cBadFiller1 = 4; // filler block is bad + cBadFiller2 = 5; // filler block is bad + cBadFiller3 = 6; // filler block is bad + cBadCurAlloc = 7; // current allocation zone is bad + cCantInit = 8; // couldn't initialize + cBadUsedBlock = 9; // used block looks bad + cBadPrevBlock = 10; // prev block before a used block is bad + cBadNextBlock = 11; // next block after a used block is bad + cBadFreeList = 12; // free list is bad + cBadFreeBlock = 13; // free block is bad + cBadBalance = 14; // free list doesn't correspond to blocks marked free + +var + initialized : Boolean; + heapErrorCode : Integer; + heapLock : TRTLCriticalSection; + {X} // Handler to set it to UninitAllocator, if Delphi memory manager used: + {X} UninitMemoryManager : procedure = DummyProc; + +// +// Helper module: administrating block descriptors. +// +type + PBlockDesc = ^TBlockDesc; + TBlockDesc = packed record + next: PBlockDesc; + prev: PBlockDesc; + addr: PChar; + size: Integer; + end; + +type + PBlockDescBlock = ^TBlockDescBlock; + TBlockDescBlock = packed record + next: PBlockDescBlock; + data: array [0..99] of TBlockDesc; + end; + +var + blockDescBlockList: PBlockDescBlock; + blockDescFreeList : PBlockDesc; + + +function GetBlockDesc: PBlockDesc; +// Get a block descriptor. +// Will return nil for failure. +var + bd: PBlockDesc; + bdb: PBlockDescBlock; + i: Integer; +begin + if blockDescFreeList = nil then begin + bdb := LocalAlloc(LMEM_FIXED, sizeof(bdb^)); + if bdb = nil then begin + result := nil; + exit; + end; + bdb.next := blockDescBlockList; + blockDescBlockList := bdb; + for i := low(bdb.data) to high(bdb.data) do begin + bd := @bdb.data[i]; + bd.next := blockDescFreeList; + blockDescFreeList := bd; + end; + end; + bd := blockDescFreeList; + blockDescFreeList := bd.next; + result := bd; +end; + + +procedure MakeEmpty(bd: PBlockDesc); +begin + bd.next := bd; + bd.prev := bd; +end; + + +function AddBlockAfter(prev: PBlockDesc; const b: TBlock): Boolean; +var + next, bd: PBlockDesc; +begin + bd := GetBlockDesc; + if bd = nil then + result := False + else begin + bd.addr := b.addr; + bd.size := b.size; + + next := prev.next; + bd.next := next; + bd.prev := prev; + next.prev := bd; + prev.next := bd; + + result := True; + end; +end; + + +procedure DeleteBlock(bd: PBlockDesc); +var + prev, next: PBlockDesc; +begin + prev := bd.prev; + next := bd.next; + prev.next := next; + next.prev := prev; + bd.next := blockDescFreeList; + blockDescFreeList := bd; +end; + + +function MergeBlockAfter(prev: PBlockDesc; const b: TBlock) : TBlock; +var + bd, bdNext: PBlockDesc; +begin + bd := prev.next; + result := b; + repeat + bdNext := bd.next; + if bd.addr + bd.size = result.addr then begin + DeleteBlock(bd); + result.addr := bd.addr; + inc(result.size, bd.size); + end else if result.addr + result.size = bd.addr then begin + DeleteBlock(bd); + inc(result.size, bd.size); + end; + bd := bdNext; + until bd = prev; + if not AddBlockAfter(prev, result) then + result.addr := nil; +end; + + +function RemoveBlock(bd: PBlockDesc; const b: TBlock): Boolean; +var + n: TBlock; + start: PBlockDesc; +begin + start := bd; + repeat + if (bd.addr <= b.addr) and (bd.addr + bd.size >= b.addr + b.size) then begin + if bd.addr = b.addr then begin + Inc(bd.addr, b.size); + Dec(bd.size, b.size); + if bd.size = 0 then + DeleteBlock(bd); + end else if bd.addr + bd.size = b.addr + b.size then + Dec(bd.size, b.size) + else begin + n.addr := b.addr + b.size; + n.size := bd.addr + bd.size - n.addr; + bd.size := b.addr - bd.addr; + if not AddBlockAfter(bd, n) then begin + result := False; + exit; + end; + end; + result := True; + exit; + end; + bd := bd.next; + until bd = start; + result := False; +end; + + + +// +// Address space administration: +// + +const + cSpaceAlign = 64*1024; + cSpaceMin = 1024*1024; + cPageAlign = 4*1024; + +var + spaceRoot: TBlockDesc; + + +function GetSpace(minSize: Integer): TBlock; +// Get at least minSize bytes address space. +// Success: returns a block, possibly much bigger than requested. +// Will not fail - will raise an exception or terminate program. +begin + if minSize < cSpaceMin then + minSize := cSpaceMin + else + minSize := (minSize + (cSpaceAlign-1)) and not (cSpaceAlign-1); + + result.size := minSize; + result.addr := VirtualAlloc(nil, minSize, MEM_RESERVE, PAGE_NOACCESS); + if result.addr = nil then + exit; + + if not AddBlockAfter(@spaceRoot, result) then begin + VirtualFree(result.addr, 0, MEM_RELEASE); + result.addr := nil; + exit; + end; +end; + + +function GetSpaceAt(addr: PChar; minSize: Integer): TBlock; +// Get at least minSize bytes address space at addr. +// Return values as above. +// Failure: returns block with addr = nil. +begin + result.size := cSpaceMin; + result.addr := VirtualAlloc(addr, cSpaceMin, MEM_RESERVE, PAGE_READWRITE); + if result.addr = nil then begin + minSize := (minSize + (cSpaceAlign-1)) and not (cSpaceAlign-1); + result.size := minSize; + result.addr := VirtualAlloc(addr, minSize, MEM_RESERVE, PAGE_READWRITE); + end; + if result.addr <> nil then begin + if not AddBlockAfter(@spaceRoot, result) then begin + VirtualFree(result.addr, 0, MEM_RELEASE); + result.addr := nil; + end; + end; +end; + + +function FreeSpace(addr: Pointer; maxSize: Integer): TBlock; +// Free at most maxSize bytes of address space at addr. +// Returns the block that was actually freed. +var + bd, bdNext: PBlockDesc; + minAddr, maxAddr, startAddr, endAddr: PChar; +begin + minAddr := PChar($FFFFFFFF); + maxAddr := nil; + startAddr := addr; + endAddr := startAddr + maxSize; + bd := spaceRoot.next; + while bd <> @spaceRoot do begin + bdNext := bd.next; + if (bd.addr >= startAddr) and (bd.addr + bd.size <= endAddr) then begin + if minAddr > bd.addr then + minAddr := bd.addr; + if maxAddr < bd.addr + bd.size then + maxAddr := bd.addr + bd.size; + if not VirtualFree(bd.addr, 0, MEM_RELEASE) then + heapErrorCode := cReleaseErr; + DeleteBlock(bd); + end; + bd := bdNext; + end; + result.addr := nil; + if maxAddr <> nil then begin + result.addr := minAddr; + result.size := maxAddr - minAddr; + end; +end; + + +function Commit(addr: Pointer; minSize: Integer): TBlock; +// Commits memory. +// Returns the block that was actually committed. +// Will return a block with addr = nil on failure. +var + bd: PBlockDesc; + loAddr, hiAddr, startAddr, endAddr: PChar; +begin + startAddr := PChar(Integer(addr) and not (cPageAlign-1)); + endAddr := PChar(((Integer(addr) + minSize) + (cPageAlign-1)) and not (cPageAlign-1)); + result.addr := startAddr; + result.size := endAddr - startAddr; + bd := spaceRoot.next; + while bd <> @spaceRoot do begin + // Commit the intersection of the block described by bd and [startAddr..endAddr) + loAddr := bd.addr; + hiAddr := loAddr + bd.size; + if loAddr < startAddr then + loAddr := startAddr; + if hiAddr > endAddr then + hiAddr := endAddr; + if loAddr < hiAddr then begin + if VirtualAlloc(loAddr, hiAddr - loAddr, MEM_COMMIT, PAGE_READWRITE) = nil then begin + result.addr := nil; + exit; + end; + end; + bd := bd.next; + end; +end; + + +function Decommit(addr: Pointer; maxSize: Integer): TBlock; +// Decommits address space. +// Returns the block that was actually decommitted. +var + bd: PBlockDesc; + loAddr, hiAddr, startAddr, endAddr: PChar; +begin + startAddr := PChar((Integer(addr) + + (cPageAlign-1)) and not (cPageAlign-1)); + endAddr := PChar((Integer(addr) + maxSize) and not (cPageAlign-1)); + result.addr := startAddr; + result.size := endAddr - startAddr; + bd := spaceRoot.next; + while bd <> @spaceRoot do begin + // Decommit the intersection of the block described by bd and [startAddr..endAddr) + loAddr := bd.addr; + hiAddr := loAddr + bd.size; + if loAddr < startAddr then + loAddr := startAddr; + if hiAddr > endAddr then + hiAddr := endAddr; + if loAddr < hiAddr then begin + if not VirtualFree(loAddr, hiAddr - loAddr, MEM_DECOMMIT) then + heapErrorCode := cDecommitErr; + end; + bd := bd.next; + end; +end; + + +// +// Committed space administration +// +const + cCommitAlign = 16*1024; + +var + decommittedRoot: TBlockDesc; + + +function GetCommitted(minSize: Integer): TBlock; +// Get a block of committed memory. +// Returns a committed memory block, possibly much bigger than requested. +// Will return a block with a nil addr on failure. +var + bd: PBlockDesc; +begin + minSize := (minSize + (cCommitAlign-1)) and not (cCommitAlign-1); + repeat + bd := decommittedRoot.next; + while bd <> @decommittedRoot do begin + if bd.size >= minSize then begin + result := Commit(bd.addr, minSize); + if result.addr = nil then + exit; + Inc(bd.addr, result.size); + Dec(bd.size, result.size); + if bd.size = 0 then + DeleteBlock(bd); + exit; + end; + bd := bd.next; + end; + result := GetSpace(minSize); + if result.addr = nil then + exit; + if MergeBlockAfter(@decommittedRoot, result).addr = nil then begin + FreeSpace(result.addr, result.size); + result.addr := nil; + exit; + end; + until False; +end; + + +function GetCommittedAt(addr: PChar; minSize: Integer): TBlock; +// Get at least minSize bytes committed space at addr. +// Success: returns a block, possibly much bigger than requested. +// Failure: returns a block with addr = nil. +var + bd: PBlockDesc; + b: TBlock; +begin + minSize := (minSize + (cCommitAlign-1)) and not (cCommitAlign-1); + repeat + + bd := decommittedRoot.next; + while (bd <> @decommittedRoot) and (bd.addr <> addr) do + bd := bd.next; + + if bd.addr = addr then begin + if bd.size >= minSize then + break; + b := GetSpaceAt(bd.addr + bd.size, minSize - bd.size); + if b.addr <> nil then begin + if MergeBlockAfter(@decommittedRoot, b).addr <> nil then + continue + else begin + FreeSpace(b.addr, b.size); + result.addr := nil; + exit; + end; + end; + end; + + b := GetSpaceAt(addr, minSize); + if b.addr = nil then + break; + + if MergeBlockAfter(@decommittedRoot, b).addr = nil then begin + FreeSpace(b.addr, b.size); + result.addr := nil; + exit; + end; + until false; + + if (bd.addr = addr) and (bd.size >= minSize) then begin + result := Commit(bd.addr, minSize); + if result.addr = nil then + exit; + Inc(bd.addr, result.size); + Dec(bd.size, result.size); + if bd.size = 0 then + DeleteBlock(bd); + end else + result.addr := nil; +end; + + +function FreeCommitted(addr: PChar; maxSize: Integer): TBlock; +// Free at most maxSize bytes of address space at addr. +// Returns the block that was actually freed. +var + startAddr, endAddr: PChar; + b: TBlock; +begin + startAddr := PChar(Integer(addr + (cCommitAlign-1)) and not (cCommitAlign-1)); + endAddr := PChar(Integer(addr + maxSize) and not (cCommitAlign-1)); + if endAddr > startAddr then begin + result := Decommit(startAddr, endAddr - startAddr); + b := MergeBlockAfter(@decommittedRoot, result); + if b.addr <> nil then + b := FreeSpace(b.addr, b.size); + if b.addr <> nil then + RemoveBlock(@decommittedRoot, b); + end else + result.addr := nil; +end; + + +// +// Suballocator (what the user program actually calls) +// + +type + PFree = ^TFree; + TFree = packed record + prev: PFree; + next: PFree; + size: Integer; + end; + PUsed = ^TUsed; + TUsed = packed record + sizeFlags: Integer; + end; + +const + cAlign = 4; + cThisUsedFlag = 2; + cPrevFreeFlag = 1; + cFillerFlag = Integer($80000000); + cFlags = cThisUsedFlag or cPrevFreeFlag or cFillerFlag; + cSmallSize = 4*1024; + cDecommitMin = 15*1024; + +type + TSmallTab = array [sizeof(TFree) div cAlign .. cSmallSize div cAlign] of PFree; + +VAR + avail : TFree; + rover : PFree; + remBytes : Integer; + curAlloc : PChar; + smallTab : ^TSmallTab; + committedRoot: TBlockDesc; + + +{X} // UninitAllocator - placed before InitAllocator to refer to. +procedure UninitAllocator; +// Shutdown. +var + bdb: PBlockDescBlock; + bd : PBlockDesc; +begin + if initialized then begin + try + if IsMultiThread then EnterCriticalSection(heapLock); + + initialized := False; + + LocalFree(smallTab); + smallTab := nil; + + bd := spaceRoot.next; + while bd <> @spaceRoot do begin + VirtualFree(bd.addr, 0, MEM_RELEASE); + bd := bd.next; + end; + + MakeEmpty(@spaceRoot); + MakeEmpty(@decommittedRoot); + MakeEmpty(@committedRoot); + + bdb := blockDescBlockList; + while bdb <> nil do begin + blockDescBlockList := bdb^.next; + LocalFree(bdb); + bdb := blockDescBlockList; + end; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + DeleteCriticalSection(heapLock); + end; + end; +end; + +function InitAllocator: Boolean; +// Initialize. No other calls legal before that. +var + i: Integer; + a: PFree; +begin + try + InitializeCriticalSection(heapLock); + if IsMultiThread then EnterCriticalSection(heapLock); + + MakeEmpty(@spaceRoot); + MakeEmpty(@decommittedRoot); + MakeEmpty(@committedRoot); + + smallTab := LocalAlloc(LMEM_FIXED, sizeof(smallTab^)); + if smallTab <> nil then begin + for i:= low(smallTab^) to high(smallTab^) do + smallTab[i] := nil; + + a := @avail; + a.next := a; + a.prev := a; + rover := a; + + initialized := True; + {X} // set here handler UninitMemoryManager to UninitAllocator } + {X} UninitMemoryManager := UninitAllocator; + end; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; + result := initialized; +end; + + + +procedure DeleteFree(f: PFree); +var + n, p: PFree; + size: Integer; +begin + if rover = f then + rover := f.next; + n := f.next; + size := f.size; + if size <= cSmallSize then begin + if n = f then + smallTab[size div cAlign] := nil + else begin + smallTab[size div cAlign] := n; + p := f.prev; + n.prev := p; + p.next := n; + end; + end else begin + p := f.prev; + n.prev := p; + p.next := n; + end; +end; + + +procedure InsertFree(a: Pointer; size: Integer); forward; + + +function FindCommitted(addr: PChar): PBlockDesc; +begin + result := committedRoot.next; + while result <> @committedRoot do begin + if (addr >= result.addr) and (addr < result.addr + result.size) then + exit; + result := result.next; + end; + heapErrorCode := cBadCommittedList; + result := nil; +end; + + +procedure FillBeforeGap(a: PChar; size: Integer); +var + rest: Integer; + e: PUsed; +begin + rest := size - sizeof(TUsed); + e := PUsed(a + rest); + if size >= sizeof(TFree) + sizeof(TUsed) then begin + e.sizeFlags := sizeof(TUsed) or cThisUsedFlag or cPrevFreeFlag or cFillerFlag; + InsertFree(a, rest); + end else if size >= sizeof(TUsed) then begin + PUsed(a).sizeFlags := size or (cThisUsedFlag or cFillerFlag); + e.sizeFlags := size or (cThisUsedFlag or cFillerFlag); + end; +end; + + +procedure InternalFreeMem(a: PChar); +begin + Inc(AllocMemCount); + Inc(AllocMemSize,PUsed(a-sizeof(TUsed)).sizeFlags and not cFlags - sizeof(TUsed)); + SysFreeMem(a); +end; + + +procedure FillAfterGap(a: PChar; size: Integer); +begin + if size >= sizeof(TFree) then begin + PUsed(a).sizeFlags := size or cThisUsedFlag; + InternalFreeMem(a + sizeof(TUsed)); + end else begin + if size >= sizeof(TUsed) then + PUsed(a).sizeFlags := size or (cThisUsedFlag or cFillerFlag); + Inc(a,size); + PUsed(a).sizeFlags := PUsed(a).sizeFlags and not cPrevFreeFlag; + end; +end; + + +function FillerSizeBeforeGap(a: PChar): Integer; +var + sizeFlags : Integer; + freeSize : Integer; + f : PFree; +begin + sizeFlags := PUsed(a - sizeof(TUsed)).sizeFlags; + if (sizeFlags and (cThisUsedFlag or cFillerFlag)) <> (cThisUsedFlag or cFillerFlag) then + heapErrorCode := cBadFiller1; + result := sizeFlags and not cFlags; + Dec(a, result); + if ((PUsed(a).sizeFlags xor sizeFlags) and not cPrevFreeFlag) <> 0 then + HeapErrorCode := cBadFiller2; + if (PUsed(a).sizeFlags and cPrevFreeFlag) <> 0 then begin + freeSize := PFree(a - sizeof(TFree)).size; + f := PFree(a - freeSize); + if f.size <> freeSize then + heapErrorCode := cBadFiller3; + DeleteFree(f); + Inc(result, freeSize); + end; +end; + + +function FillerSizeAfterGap(a: PChar): Integer; +var + sizeFlags: Integer; + f : PFree; +begin + result := 0; + sizeFlags := PUsed(a).sizeFlags; + if (sizeFlags and cFillerFlag) <> 0 then begin + sizeFlags := sizeFlags and not cFlags; + Inc(result,sizeFlags); + Inc(a, sizeFlags); + sizeFlags := PUsed(a).sizeFlags; + end; + if (sizeFlags and cThisUsedFlag) = 0 then begin + f := PFree(a); + DeleteFree(f); + Inc(result, f.size); + Inc(a, f.size); + PUsed(a).sizeFlags := PUsed(a).sizeFlags and not cPrevFreeFlag; + end; +end; + + +function DecommitFree(a: PChar; size: Integer): Boolean; +var + b: TBlock; + bd: PBlockDesc; +begin + Result := False; + bd := FindCommitted(a); + if bd = nil then Exit; + if bd.addr + bd.size - (a + size) <= sizeof(TFree) then + size := bd.addr + bd.size - a; + + if a - bd.addr < sizeof(TFree) then + b := FreeCommitted(bd.addr, size + (a - bd.addr)) + else + b := FreeCommitted(a + sizeof(TUsed), size - sizeof(TUsed)); + + if b.addr <> nil then + begin + FillBeforeGap(a, b.addr - a); + if bd.addr + bd.size > b.addr + b.size then + FillAfterGap(b.addr + b.size, a + size - (b.addr + b.size)); + RemoveBlock(bd,b); + result := True; + end; +end; + + +procedure InsertFree(a: Pointer; size: Integer); +var + f, n, p: PFree; +begin + f := PFree(a); + f.size := size; + PFree(PChar(f) + size - sizeof(TFree)).size := size; + if size <= cSmallSize then begin + n := smallTab[size div cAlign]; + if n = nil then begin + smallTab[size div cAlign] := f; + f.next := f; + f.prev := f; + end else begin + p := n.prev; + f.next := n; + f.prev := p; + n.prev := f; + p.next := f; + end; + end else if (size < cDecommitMin) or not DecommitFree(a, size) then begin + n := rover; + rover := f; + p := n.prev; + f.next := n; + f.prev := p; + n.prev := f; + p.next := f; + end; +end; + + +procedure FreeCurAlloc; +begin + if remBytes > 0 then begin + if remBytes < sizeof(TFree) then + heapErrorCode := cBadCurAlloc + else begin + PUsed(curAlloc).sizeFlags := remBytes or cThisUsedFlag; + InternalFreeMem(curAlloc + sizeof(TUsed)); + curAlloc := nil; + remBytes := 0; + end; + end; +end; + + +function MergeCommit(b: TBlock): Boolean; +var + merged: TBlock; + fSize: Integer; +begin + FreeCurAlloc; + merged := MergeBlockAfter(@committedRoot, b); + if merged.addr = nil then begin + result := False; + exit; + end; + + if merged.addr < b.addr then begin + fSize := FillerSizeBeforeGap(b.addr); + Dec(b.addr, fSize); + Inc(b.size, fSize); + end; + + if merged.addr + merged.size > b.addr + b.size then begin + fSize := FillerSizeAfterGap(b.addr + b.size); + Inc(b.size, fSize); + end; + + if merged.addr + merged.size = b.addr + b.size then begin + FillBeforeGap(b.addr + b.size - sizeof(TUsed), sizeof(TUsed)); + Dec(b.size, sizeof(TUsed)); + end; + + curAlloc := b.addr; + remBytes := b.size; + + result := True; +end; + + +function NewCommit(minSize: Integer): Boolean; +var + b: TBlock; +begin + b := GetCommitted(minSize+sizeof(TUsed)); + result := (b.addr <> nil) and MergeCommit(b); +end; + + +function NewCommitAt(addr: Pointer; minSize: Integer): Boolean; +var + b: TBlock; +begin + b := GetCommittedAt(addr, minSize+sizeof(TUsed)); + result := (b.addr <> nil) and MergeCommit(b); +end; + + +function SearchSmallBlocks(size: Integer): PFree; +var + i: Integer; +begin + result := nil; + for i := size div cAlign to High(smallTab^) do begin + result := smallTab[i]; + if result <> nil then + exit; + end; +end; + + +function TryHarder(size: Integer): Pointer; +var + u: PUsed; f:PFree; saveSize, rest: Integer; +begin + + repeat + + f := avail.next; + if (size <= f.size) then + break; + + f := rover; + if f.size >= size then + break; + + saveSize := f.size; + f.size := size; + repeat + f := f.next + until f.size >= size; + rover.size := saveSize; + if f <> rover then begin + rover := f; + break; + end; + + if size <= cSmallSize then begin + f := SearchSmallBlocks(size); + if f <> nil then + break; + end; + + if not NewCommit(size) then begin + result := nil; + exit; + end; + + if remBytes >= size then begin + Dec(remBytes, size); + if remBytes < sizeof(TFree) then begin + Inc(size, remBytes); + remBytes := 0; + end; + u := PUsed(curAlloc); + Inc(curAlloc, size); + u.sizeFlags := size or cThisUsedFlag; + result := PChar(u) + sizeof(TUsed); + Inc(AllocMemCount); + Inc(AllocMemSize,size - sizeof(TUsed)); + exit; + end; + + until False; + + DeleteFree(f); + + rest := f.size - size; + if rest >= sizeof(TFree) then begin + InsertFree(PChar(f) + size, rest); + end else begin + size := f.size; + if f = rover then + rover := f.next; + u := PUsed(PChar(f) + size); + u.sizeFlags := u.sizeFlags and not cPrevFreeFlag; + end; + + u := PUsed(f); + u.sizeFlags := size or cThisUsedFlag; + + result := PChar(u) + sizeof(TUsed); + Inc(AllocMemCount); + Inc(AllocMemSize,size - sizeof(TUsed)); + +end; + + +function SysGetMem(size: Integer): Pointer; +// Allocate memory block. +var + f, prev, next: PFree; + u: PUsed; +begin + + if (not initialized and not InitAllocator) or + (size > (High(size) - (sizeof(TUsed) + (cAlign-1)))) then + begin + result := nil; + exit; + end; + + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + Inc(size, sizeof(TUsed) + (cAlign-1)); + size := size and not (cAlign-1); + if size < sizeof(TFree) then + size := sizeof(TFree); + + if size <= cSmallSize then begin + f := smallTab[size div cAlign]; + if f <> nil then begin + u := PUsed(PChar(f) + size); + u.sizeFlags := u.sizeFlags and not cPrevFreeFlag; + next := f.next; + if next = f then + smallTab[size div cAlign] := nil + else begin + smallTab[size div cAlign] := next; + prev := f.prev; + prev.next := next; + next.prev := prev; + end; + u := PUsed(f); + u.sizeFlags := f.size or cThisUsedFlag; + result := PChar(u) + sizeof(TUsed); + Inc(AllocMemCount); + Inc(AllocMemSize,size - sizeof(TUsed)); + exit; + end; + end; + + if size <= remBytes then begin + Dec(remBytes, size); + if remBytes < sizeof(TFree) then begin + Inc(size, remBytes); + remBytes := 0; + end; + u := PUsed(curAlloc); + Inc(curAlloc, size); + u.sizeFlags := size or cThisUsedFlag; + result := PChar(u) + sizeof(TUsed); + Inc(AllocMemCount); + Inc(AllocMemSize,size - sizeof(TUsed)); + exit; + end; + + result := TryHarder(size); + + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; + +end; + + +function SysFreeMem(p: Pointer): Integer; +// Deallocate memory block. +label + abort; +var + u, n : PUsed; + f : PFree; + prevSize, nextSize, size : Integer; +begin + heapErrorCode := cHeapOk; + + if not initialized and not InitAllocator then begin + heapErrorCode := cCantInit; + result := cCantInit; + exit; + end; + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + u := p; + u := PUsed(PChar(u) - sizeof(TUsed)); { inv: u = address of allocated block being freed } + size := u.sizeFlags; + { inv: size = SET(block size) + [block flags] } + + { validate that the interpretation of this block as a used block is correct } + if (size and cThisUsedFlag) = 0 then begin + heapErrorCode := cBadUsedBlock; + goto abort; + end; + + { inv: the memory block addressed by 'u' and 'p' is an allocated block } + + Dec(AllocMemCount); + Dec(AllocMemSize,size and not cFlags - sizeof(TUsed)); + + if (size and cPrevFreeFlag) <> 0 then begin + { previous block is free, coalesce } + prevSize := PFree(PChar(u)-sizeof(TFree)).size; + if (prevSize < sizeof(TFree)) or ((prevSize and cFlags) <> 0) then begin + heapErrorCode := cBadPrevBlock; + goto abort; + end; + + f := PFree(PChar(u) - prevSize); + if f^.size <> prevSize then begin + heapErrorCode := cBadPrevBlock; + goto abort; + end; + + inc(size, prevSize); + u := PUsed(f); + DeleteFree(f); + end; + + size := size and not cFlags; + { inv: size = block size } + + n := PUsed(PChar(u) + size); + { inv: n = block following the block to free } + + if PChar(n) = curAlloc then begin + { inv: u = last block allocated } + dec(curAlloc, size); + inc(remBytes, size); + if remBytes > cDecommitMin then + FreeCurAlloc; + result := cHeapOk; + exit; + end; + + if (n.sizeFlags and cThisUsedFlag) <> 0 then begin + { inv: n is a used block } + if (n.sizeFlags and not cFlags) < sizeof(TUsed) then begin + heapErrorCode := cBadNextBlock; + goto abort; + end; + n.sizeFlags := n.sizeFlags or cPrevFreeFlag + end else begin + { inv: block u & n are both free; coalesce } + f := PFree(n); + if (f.next = nil) or (f.prev = nil) or (f.size < sizeof(TFree)) then begin + heapErrorCode := cBadNextBlock; + goto abort; + end; + nextSize := f.size; + inc(size, nextSize); + DeleteFree(f); + { inv: last block (which was free) is not on free list } + end; + + InsertFree(u, size); +abort: + result := heapErrorCode; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; +end; + + +function ResizeInPlace(p: Pointer; newSize: Integer): Boolean; +var u, n: PUsed; f: PFree; oldSize, blkSize, neededSize: Integer; +begin + Inc(newSize, sizeof(TUsed)+cAlign-1); + newSize := newSize and not (cAlign-1); + if newSize < sizeof(TFree) then + newSize := sizeof(TFree); + u := PUsed(PChar(p) - sizeof(TUsed)); + oldSize := u.sizeFlags and not cFlags; + n := PUsed( PChar(u) + oldSize ); + if newSize <= oldSize then begin + blkSize := oldSize - newSize; + if PChar(n) = curAlloc then begin + Dec(curAlloc, blkSize); + Inc(remBytes, blkSize); + if remBytes < sizeof(TFree) then begin + Inc(curAlloc, blkSize); + Dec(remBytes, blkSize); + newSize := oldSize; + end; + end else begin + n := PUsed(PChar(u) + oldSize); + if n.sizeFlags and cThisUsedFlag = 0 then begin + f := PFree(n); + Inc(blkSize, f.size); + DeleteFree(f); + end; + if blkSize >= sizeof(TFree) then begin + n := PUsed(PChar(u) + newSize); + n.sizeFlags := blkSize or cThisUsedFlag; + InternalFreeMem(PChar(n) + sizeof(TUsed)); + end else + newSize := oldSize; + end; + end else begin + repeat + neededSize := newSize - oldSize; + if PChar(n) = curAlloc then begin + if remBytes >= neededSize then begin + Dec(remBytes, neededSize); + Inc(curAlloc, neededSize); + if remBytes < sizeof(TFree) then begin + Inc(curAlloc, remBytes); + Inc(newSize, remBytes); + remBytes := 0; + end; + Inc(AllocMemSize, newSize - oldSize); + u.sizeFlags := newSize or u.sizeFlags and cFlags; + result := true; + exit; + end else begin + FreeCurAlloc; + n := PUsed( PChar(u) + oldSize ); + end; + end; + + if n.sizeFlags and cThisUsedFlag = 0 then begin + f := PFree(n); + blkSize := f.size; + if blkSize < neededSize then begin + n := PUsed(PChar(n) + blkSize); + Dec(neededSize, blkSize); + end else begin + DeleteFree(f); + Dec(blkSize, neededSize); + if blkSize >= sizeof(TFree) then + InsertFree(PChar(u) + newSize, blkSize) + else begin + Inc(newSize, blkSize); + n := PUsed(PChar(u) + newSize); + n.sizeFlags := n.sizeFlags and not cPrevFreeFlag; + end; + break; + end; + end; + + if n.sizeFlags and cFillerFlag <> 0 then begin + n := PUsed(PChar(n) + n.sizeFlags and not cFlags); + if NewCommitAt(n, neededSize) then begin + n := PUsed( PChar(u) + oldSize ); + continue; + end; + end; + + result := False; + exit; + + until False; + + end; + + Inc(AllocMemSize, newSize - oldSize); + u.sizeFlags := newSize or u.sizeFlags and cFlags; + result := True; + +end; + + +function SysReallocMem(p: Pointer; size: Integer): Pointer; +// Resize memory block. +var + n: Pointer; oldSize: Integer; +begin + + if not initialized and not InitAllocator then begin + result := nil; + exit; + end; + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + if ResizeInPlace(p, size) then + result := p + else begin + n := SysGetMem(size); + oldSize := (PUsed(PChar(p)-sizeof(PUsed)).sizeFlags and not cFlags) - sizeof(TUsed); + if oldSize > size then + oldSize := size; + if n <> nil then begin + Move(p^, n^, oldSize); + SysFreeMem(p); + end; + result := n; + end; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; + +end; + + +function BlockSum(root: PBlockDesc): Integer; +var + b : PBlockDesc; +begin + result := 0; + b := root.next; + while b <> root do begin + Inc(result, b.size); + b := b.next; + end; +end; + + +function GetHeapStatus: THeapStatus; +var + size, freeSize, userSize: Cardinal; + f: PFree; + a, e: PChar; + i: Integer; + b: PBlockDesc; + prevFree: Boolean; +begin + + result.TotalAddrSpace := 0; + result.TotalUncommitted := 0; + result.TotalCommitted := 0; + result.TotalAllocated := 0; + result.TotalFree := 0; + result.FreeSmall := 0; + result.FreeBig := 0; + result.Unused := 0; + result.Overhead := 0; + result.HeapErrorCode := cHeapOk; + + if not initialized then exit; + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + result.totalAddrSpace := BlockSum(@spaceRoot); + result.totalUncommitted := BlockSum(@decommittedRoot); + result.totalCommitted := BlockSum(@committedRoot); + + size := 0; + for i := Low(smallTab^) to High(smallTab^) do begin + f := smallTab[i]; + if f <> nil then begin + repeat + Inc(size, f.size); + if (f.prev.next <> f) or (f.next.prev <> f) or (f.size < sizeof(TFree)) then begin + heapErrorCode := cBadFreeList; + break; + end; + f := f.next; + until f = smallTab[i]; + end; + end; + result.freeSmall := size; + + size := 0; + f := avail.next; + while f <> @avail do begin + if (f.prev.next <> f) or (f.next.prev <> f) or (f.size < sizeof(TFree)) then begin + heapErrorCode := cBadFreeList; + break; + end; + Inc(size, f.size); + f := f.next; + end; + result.freeBig := size; + + result.unused := remBytes; + result.totalFree := result.freeSmall + result.freeBig + result.unused; + + freeSize := 0; + userSize := 0; + result.overhead := 0; + + b := committedRoot.next; + prevFree := False; + while b <> @committedRoot do begin + a := b.addr; + e := a + b.size; + while a < e do begin + if (a = curAlloc) and (remBytes > 0) then begin + size := remBytes; + Inc(freeSize, size); + if prevFree then + heapErrorCode := cBadCurAlloc; + prevFree := False; + end else begin + if prevFree <> ((PUsed(a).sizeFlags and cPrevFreeFlag) <> 0) then + heapErrorCode := cBadNextBlock; + if (PUsed(a).sizeFlags and cThisUsedFlag) = 0 then begin + f := PFree(a); + if (f.prev.next <> f) or (f.next.prev <> f) or (f.size < sizeof(TFree)) then + heapErrorCode := cBadFreeBlock; + size := f.size; + Inc(freeSize, size); + prevFree := True; + end else begin + size := PUsed(a).sizeFlags and not cFlags; + if (PUsed(a).sizeFlags and cFillerFlag) <> 0 then begin + Inc(result.overhead, size); + if (a > b.addr) and (a + size < e) then + heapErrorCode := cBadUsedBlock; + end else begin + Inc(userSize, size-sizeof(TUsed)); + Inc(result.overhead, sizeof(TUsed)); + end; + prevFree := False; + end; + end; + Inc(a, size); + end; + b := b.next; + end; + if result.totalFree <> freeSize then + heapErrorCode := cBadBalance; + + result.totalAllocated := userSize; + result.heapErrorCode := heapErrorCode; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; +end; + + +// this section goes into GetMem.Inc + +{$IFDEF DEBUG_FUNCTIONS} +type + THeapReportProc = procedure(HeapBlock: Pointer; AllocatedSize: Integer) of object; + + +procedure WalkHeap(HeapReportProc: THeapReportProc); +var + size : Cardinal; + f: PFree; + a, e: PChar; + b: PBlockDesc; +begin + + if not initialized then exit; + + try + if IsMultiThread then EnterCriticalSection(heapLock); + + b := committedRoot.next; + while b <> @committedRoot do begin + a := b.addr; + e := a + b.size; + while a < e do begin + if (a = curAlloc) and (remBytes > 0) then begin + size := remBytes; + end else begin + if (PUsed(a).sizeFlags and cThisUsedFlag) = 0 then begin + f := PFree(a); + size := f.size; + end else begin + size := PUsed(a).sizeFlags and not cFlags; + if (PUsed(a).sizeFlags and cFillerFlag) = 0 then begin + HeapReportProc(a + sizeof(TUsed), size - sizeof(TUsed)); + end; + end; + end; + Inc(a, size); + end; + b := b.next; + end; + finally + if IsMultiThread then LeaveCriticalSection(heapLock); + end; +end; + +type + THeapBlockCollector = class(TObject) + FCount: Integer; + FObjectTable: TObjectArray; + FHeapBlockTable: THeapBlockArray; + FClass: TClass; + FFindDerived: Boolean; + procedure CollectBlocks(HeapBlock: Pointer; AllocatedSize: Integer); + procedure CollectObjects(HeapBlock: Pointer; AllocatedSize: Integer); + end; + + +procedure THeapBlockCollector.CollectBlocks(HeapBlock: Pointer; AllocatedSize: Integer); +begin + if FCount < Length(FHeapBlockTable) then + begin + FHeapBlockTable[FCount].Start := HeapBlock; + FHeapBlockTable[FCount].Size := AllocatedSize; + end; + Inc(FCount); +end; + + +procedure THeapBlockCollector.CollectObjects(HeapBlock: Pointer; AllocatedSize: Integer); +var + AObject: TObject; + AClass: TClass; +type + PPointer = ^Pointer; +begin + try + if AllocatedSize < 4 then + Exit; + AObject := TObject(HeapBlock); + AClass := AObject.ClassType; + if (AClass = FClass) + or (FFindDerived + and (Integer(AClass) >= 64*1024) + and (PPointer(PChar(AClass) + vmtSelfPtr)^ = Pointer(AClass)) + and (AObject is FClass)) then + begin + if FCount < Length(FObjectTable) then + FObjectTable[FCount] := AObject; + Inc(FCount); + end; + except + // Let's not worry about this block - it's obviously not a valid object + end; +end; + +var + HeapBlockCollector: THeapBlockCollector; + +function GetHeapBlocks: THeapBlockArray; +begin + if not Assigned(HeapBlockCollector) then + HeapBlockCollector := THeapBlockCollector.Create; + + Walkheap(HeapBlockCollector.CollectBlocks); + SetLength(HeapBlockCollector.FHeapBlockTable, HeapBlockCollector.FCount); + HeapBlockCollector.FCount := 0; + Walkheap(HeapBlockCollector.CollectBlocks); + Result := HeapBlockCollector.FHeapBlockTable; + HeapBlockCollector.FCount := 0; + HeapBlockCollector.FHeapBlockTable := nil; +end; + + +function FindObjects(AClass: TClass; FindDerived: Boolean): TObjectArray; +begin + if not Assigned(HeapBlockCollector) then + HeapBlockCollector := THeapBlockCollector.Create; + HeapBlockCollector.FClass := AClass; + HeapBlockCollector.FFindDerived := FindDerived; + + Walkheap(HeapBlockCollector.CollectObjects); + SetLength(HeapBlockCollector.FObjectTable, HeapBlockCollector.FCount); + HeapBlockCollector.FCount := 0; + Walkheap(HeapBlockCollector.CollectObjects); + Result := HeapBlockCollector.FObjectTable; + HeapBlockCollector.FCount := 0; + HeapBlockCollector.FObjectTable := nil; +end; +{$ENDIF} + + diff --git a/System/read.txt b/System/read.txt new file mode 100644 index 0000000..4b96794 --- /dev/null +++ b/System/read.txt @@ -0,0 +1,13 @@ +------------------------------------------------------------------- +19.08.09 +------------------------------------------------------------------- + +Чтобы скомпилировать системные замены, нужно выполнить: + DCC32.EXE -q system SysSfIni SYSWSTR sysinit -m -y -z -$D- +либо: + DCC32.EXE -q system sysinit -m -y -z -$D- +либо + MAKE + +D2006beta-D2009beta - это бета версии замен, они основаны на D7_avenger, возможны лаги +D2006_orig - чуть облегченная версия оригинальных модулей \ No newline at end of file