git-svn-id: https://svn.code.sf.net/p/kolmck/code@38 91bb2d04-0c0c-4d2d-88a5-bbb6f4c1fa07
This commit is contained in:
dkolmck
18
System/D2006betaECM/SYSWSTR.PAS
Normal file
18
System/D2006betaECM/SYSWSTR.PAS
Normal file
@ -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.
|
||||||
148
System/D2006betaECM/ShareMem.pas
Normal file
148
System/D2006betaECM/ShareMem.pas
Normal file
@ -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.
|
||||||
|
|
||||||
184
System/D2006betaECM/SysConst.pas
Normal file
184
System/D2006betaECM/SysConst.pas
Normal file
@ -0,0 +1,184 @@
|
|||||||
|
{ *********************************************************************** }
|
||||||
|
{ }
|
||||||
|
{ Delphi / Kylix Cross-Platform Runtime Library }
|
||||||
|
{ }
|
||||||
|
{ Copyright (c) 1995, 2001 Borland Software Corporation }
|
||||||
|
{ }
|
||||||
|
{ *********************************************************************** }
|
||||||
|
|
||||||
|
unit SysConst;
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
resourcestring
|
||||||
|
SUnknown = '<unknown>';
|
||||||
|
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.
|
||||||
|
|
||||||
858
System/D2006betaECM/SysInit.pas
Normal file
858
System/D2006betaECM/SysInit.pas
Normal file
@ -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.
|
||||||
|
|
||||||
|
|
||||||
22
System/D2006betaECM/SysSfIni.pas
Normal file
22
System/D2006betaECM/SysSfIni.pas
Normal file
@ -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.
|
||||||
18874
System/D2006betaECM/System.pas
Normal file
18874
System/D2006betaECM/System.pas
Normal file
File diff suppressed because it is too large
Load Diff
1541
System/D2006betaECM/getmem.inc
Normal file
1541
System/D2006betaECM/getmem.inc
Normal file
File diff suppressed because it is too large
Load Diff
43
System/D2006betaECM/makefile
Normal file
43
System/D2006betaECM/makefile
Normal file
@ -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)
|
||||||
Reference in New Issue
Block a user