pascal/kolmck
1
0
Fork 0
Code Issues Releases Activity

git-svn-id: https://svn.code.sf.net/p/kolmck/code@38 91bb2d04-0c0c-4d2d-88a5-bbb6f4c1fa07

Browse Source
This commit is contained in:
dkolmck
2009-09-09 06:37:15 +00:00
parent 9ac77195ab
commit cbb0fe46ab
8 changed files with 21688 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

18
System/D2006betaECM/SYSWSTR.PAS Normal file
View 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
View 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
View 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
View 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
View 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
View File

File diff suppressed because it is too large Load Diff

1541
System/D2006betaECM/getmem.inc Normal file
View File

File diff suppressed because it is too large Load Diff

43
System/D2006betaECM/makefile Normal file
View 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)