paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-10-31 14:12:32 +01:00
Code Issues Packages Projects Releases Wiki Activity
4ba6f1b4dc
fpc/rtl/wince/system.pp
yury 385232c11c * reworked cleanup on exit for wince. 
git-svn-id: trunk@4535 -
2006-09-02 09:39:32 +00:00

1817 lines
48 KiB
ObjectPascal
Raw Blame History

{
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2005 by Florian Klaempfl and Pavel Ozerski
and Yury Sidorov member of the Free Pascal development team.
FPC Pascal system unit for the WinCE.
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
unit System;
interface
{$ifdef SYSTEMDEBUG}
{$define SYSTEMEXCEPTIONDEBUG}
{$endif SYSTEMDEBUG}
{$define WINCE_EXCEPTION_HANDLING}
{$define DISABLE_NO_THREAD_MANAGER}
{$define HAS_CMDLINE}
{$define HAS_MT_MEMORYMANAGER} // comment this line to switch from wincemm to fpcmm
{ include system-independent routine headers }
{$I systemh.inc}
const
LineEnding = #13#10;
LFNSupport = true;
DirectorySeparator = '\';
DriveSeparator = ':';
PathSeparator = ';';
{ FileNameCaseSensitive is defined separately below!!! }
maxExitCode = 65535;
MaxPathLen = 260;
const
{ Default filehandles }
UnusedHandle : THandle = -1;
StdInputHandle : THandle = 0;
StdOutputHandle : THandle = 0;
StdErrorHandle : THandle = 0;
FileNameCaseSensitive : boolean = true;
CtrlZMarksEOF: boolean = true; (* #26 not considered as end of file *)
sLineBreak = LineEnding;
DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsCRLF;
{ Thread count for DLL }
Thread_count : longint = 0;
var
{ WinCE Info }
hprevinst,
MainInstance,
DLLreason,DLLparam:DWord;
type
TDLL_Process_Entry_Hook = function (dllparam : longint) : longbool;
TDLL_Entry_Hook = procedure (dllparam : longint);
const
Dll_Process_Attach_Hook : TDLL_Process_Entry_Hook = nil;
Dll_Process_Detach_Hook : TDLL_Entry_Hook = nil;
Dll_Thread_Attach_Hook : TDLL_Entry_Hook = nil;
Dll_Thread_Detach_Hook : TDLL_Entry_Hook = nil;
{ ANSI <-> Wide }
function AnsiToWideBuf(AnsiBuf: PChar; AnsiBufLen: longint; WideBuf: PWideChar; WideBufLen: longint): longint;
function WideToAnsiBuf(WideBuf: PWideChar; WideBufLen: longint; AnsiBuf: PChar; AnsiBufLen: longint): longint;
function PCharToPWideChar(str: PChar; strlen: longint = -1; outlen: PLongInt = nil): PWideChar;
function StringToPWideChar(const s: AnsiString; outlen: PLongInt = nil): PWideChar;
{ Wrappers for some WinAPI calls }
function CreateEvent(lpEventAttributes:pointer;bManualReset:longbool;bInitialState:longbool;lpName:pchar): THandle; stdcall;
function ResetEvent(h: THandle): LONGBOOL; stdcall;
function SetEvent(h: THandle): LONGBOOL; stdcall;
function GetCurrentProcessId:DWORD; stdcall;
function Win32GetCurrentThreadId:DWORD; stdcall;
function TlsAlloc : DWord; stdcall;
function TlsFree(dwTlsIndex : DWord) : LongBool; stdcall;
function GetFileAttributes(p : pchar) : dword; stdcall;
function DeleteFile(p : pchar) : longint; stdcall;
function MoveFile(old,_new : pchar) : longint; stdcall;
function CreateFile(lpFileName:pchar; dwDesiredAccess:DWORD; dwShareMode:DWORD;
lpSecurityAttributes:pointer; dwCreationDisposition:DWORD;
dwFlagsAndAttributes:DWORD; hTemplateFile:DWORD):longint; stdcall;
function CreateDirectory(name : pointer;sec : pointer) : longbool; stdcall;
function RemoveDirectory(name:pointer):longbool; stdcall;
{$ifdef CPUARM}
{ the external directive isn't really necessary here because it is overriden by external (FK) }
function addd(d1,d2 : double) : double; compilerproc;
cdecl;external 'coredll' name '__addd';
function subd(d1,d2 : double) : double; compilerproc;
cdecl;external 'coredll' name '__subd';
function muld(d1,d2 : double) : double; compilerproc;
cdecl;external 'coredll' name '__muld';
function divd(d1,d2 : double) : double; compilerproc;
cdecl;external 'coredll' name '__divd';
function eqd(d1,d2 : double) : boolean; compilerproc;
cdecl;external 'coredll' name '__eqd';
function ned(d1,d2 : double) : boolean; compilerproc;
cdecl;external 'coredll' name '__ned';
function ltd(d1,d2 : double) : boolean; compilerproc;
cdecl;external 'coredll' name '__ltd';
function gtd(d1,d2 : double) : boolean; compilerproc;
cdecl;external 'coredll' name '__gtd';
function ged(d1,d2 : double) : boolean; compilerproc;
cdecl;external 'coredll' name '__ged';
function led(d1,d2 : double) : boolean; compilerproc;
cdecl;external 'coredll' name '__led';
{ ***************** single ******************** }
function eqs(d1,d2 : single) : boolean; compilerproc;
cdecl;external 'coredll' name '__eqs';
function nes(d1,d2 : single) : boolean; compilerproc;
cdecl;external 'coredll' name '__nes';
function lts(d1,d2 : single) : boolean; compilerproc;
cdecl;external 'coredll' name '__lts';
function gts(d1,d2 : single) : boolean; compilerproc;
cdecl;external 'coredll' name '__gts';
function ges(d1,d2 : single) : boolean; compilerproc;
cdecl;external 'coredll' name '__ges';
function les(d1,d2 : single) : boolean; compilerproc;
cdecl;external 'coredll' name '__les';
function dtos(d : double) : single; compilerproc;
cdecl;external 'coredll' name '__dtos';
function stod(d : single) : double; compilerproc;
cdecl;external 'coredll' name '__stod';
function negs(d : single) : single; compilerproc;
cdecl;external 'coredll' name '__negs';
function negd(d : double) : double; compilerproc;
cdecl;external 'coredll' name '__negd';
function utod(i : dword) : double; compilerproc;
cdecl;external 'coredll' name '__utod';
function itod(i : longint) : double; compilerproc;
cdecl;external 'coredll' name '__itod';
function ui64tod(i : qword) : double; compilerproc;
cdecl;external 'coredll' name '__u64tod';
function i64tod(i : int64) : double; compilerproc;
cdecl;external 'coredll' name '__i64tod';
function adds(s1,s2 : single) : single; compilerproc;
function subs(s1,s2 : single) : single; compilerproc;
function muls(s1,s2 : single) : single; compilerproc;
function divs(s1,s2 : single) : single; compilerproc;
{$endif CPUARM}
function CmdLine: PChar;
{ C compatible arguments }
function argc: longint;
function argv: ppchar;
implementation
var
SysInstance : Longint;
{$define HAS_RESOURCES}
{$i winres.inc}
function MessageBox(w1:longint;l1,l2:PWideChar;w2:longint):longint;
stdcall;external 'coredll' name 'MessageBoxW';
{*****************************************************************************}
{$define FPC_SYSTEM_HAS_MOVE}
procedure memmove(dest, src: pointer; count: longint);
cdecl; external 'coredll' name 'memmove';
procedure Move(const source;var dest;count:SizeInt);[public, alias: 'FPC_MOVE']; {$ifdef SYSTEMINLINE}inline;{$endif}
begin
if count > 0 then
memmove(@dest, @source, count);
end;
{$define FPC_SYSTEM_HAS_COMPAREBYTE}
function memcmp(buf1, buf2: pointer; count: longint): longint;
cdecl; external 'coredll' name 'memcmp';
function CompareByte(Const buf1,buf2;len:SizeInt):SizeInt; {$ifdef SYSTEMINLINE}inline;{$endif}
begin
CompareByte := memcmp(@buf1, @buf2, len);
end;
{$ifdef CPUARM}
{$define FPC_SYSTEM_HAS_INT}
function floor(d : double) : double;
cdecl;external 'coredll' name 'floor';
function ceil(d : double) : double;
cdecl;external 'coredll' name 'ceil';
function fpc_int_real(d: ValReal): ValReal;compilerproc;
begin
if d > 0 then
fpc_int_real:=floor(d)
else
fpc_int_real:=ceil(d);
end;
{$define FPC_SYSTEM_HAS_TRUNC}
function __dtoi64(d: double) : int64; external 'coredll';
function fpc_trunc_real(d : ValReal) : int64; assembler; nostackframe; compilerproc;
asm
b __dtoi64
end;
{$define FPC_SYSTEM_HAS_ABS}
function fabs(d: double): double; external 'coredll';
function fpc_abs_real(d : ValReal) : ValReal; assembler; nostackframe; compilerproc;
asm
b fabs
end;
{$define FPC_SYSTEM_HAS_SQRT}
function coresqrt(d: double): double; external 'coredll' name 'sqrt';
function fpc_sqrt_real(d : ValReal) : ValReal; assembler; nostackframe; compilerproc;
asm
b coresqrt
end;
function adds(s1,s2 : single) : single;
begin
adds := addd(s1, s2);
end;
function subs(s1,s2 : single) : single;
begin
subs := subd(s1, s2);
end;
function muls(s1,s2 : single) : single;
begin
muls := muld(s1, s2);
end;
function divs(s1,s2 : single) : single;
begin
divs := divd(s1, s2);
end;
{$endif CPUARM}
{*****************************************************************************}
{ include system independent routines }
{$I system.inc}
{*****************************************************************************
ANSI <-> Wide
*****************************************************************************}
const
{ MultiByteToWideChar }
MB_PRECOMPOSED = 1;
MB_COMPOSITE = 2;
MB_ERR_INVALID_CHARS = 8;
MB_USEGLYPHCHARS = 4;
CP_ACP = 0;
CP_OEMCP = 1;
function MultiByteToWideChar(CodePage:UINT; dwFlags:DWORD; lpMultiByteStr:PChar; cchMultiByte:longint; lpWideCharStr:PWideChar;cchWideChar:longint):longint;
stdcall; external 'coredll' name 'MultiByteToWideChar';
function WideCharToMultiByte(CodePage:UINT; dwFlags:DWORD; lpWideCharStr:PWideChar; cchWideChar:longint; lpMultiByteStr:PChar;cchMultiByte:longint; lpDefaultChar:PChar; lpUsedDefaultChar:pointer):longint;
stdcall; external 'coredll' name 'WideCharToMultiByte';
function AnsiToWideBuf(AnsiBuf: PChar; AnsiBufLen: longint; WideBuf: PWideChar; WideBufLen: longint): longint;
begin
Result := MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, AnsiBuf, AnsiBufLen, WideBuf, WideBufLen div SizeOf(WideChar));
if ((AnsiBufLen <> -1) or (Result = 0)) and (WideBuf <> nil) then
begin
if (Result + 1)*SizeOf(WideChar) > WideBufLen then
begin
Result := 0;
if WideBufLen < SizeOf(WideChar) then
exit;
end;
WideBuf[Result] := #0;
if (Result <> 0) or (AnsiBufLen = 0) then
Inc(Result);
end;
Result:=Result*SizeOf(WideChar);
end;
function WideToAnsiBuf(WideBuf: PWideChar; WideBufLen: longint; AnsiBuf: PChar; AnsiBufLen: longint): longint;
begin
Result := WideCharToMultiByte(CP_ACP, 0, WideBuf, WideBufLen, AnsiBuf, AnsiBufLen, nil, nil);
if ((WideBufLen <> -1) or (Result = 0)) and (AnsiBuf <> nil) then
begin
if Result + 1 > AnsiBufLen then
begin
Result := 0;
if AnsiBufLen < 1 then
exit;
end;
AnsiBuf[Result] := #0;
if (Result <> 0) or (WideBufLen = 0) then
Inc(Result);
end;
end;
function PCharToPWideChar(str: PChar; strlen: longint = -1; outlen: PLongInt = nil): PWideChar;
var
len: longint;
begin
while True do begin
if strlen <> -1 then
len:=(strlen + 1)
else
len:=AnsiToWideBuf(str, -1, nil, 0);
if len > 0 then
begin
len:=len*SizeOf(WideChar);
GetMem(Result, len);
if (AnsiToWideBuf(str, -1, Result, len) = 0) and (strlen <> -1) then
begin
strlen:=-1;
continue;
end;
end
else begin
GetMem(Result, SizeOf(WideChar));
Inc(len);
Result^:=#0;
end;
break;
end;
if outlen <> nil then
outlen^:=(len - 1)*SizeOf(WideChar);
end;
function StringToPWideChar(const s: AnsiString; outlen: PLongInt = nil): PWideChar;
var
len, wlen: longint;
begin
len:=Length(s);
wlen:=(len + 1)*SizeOf(WideChar);
GetMem(Result, wlen);
wlen:=AnsiToWideBuf(PChar(s), len, Result, wlen);
if wlen = 0 then
begin
wlen:=AnsiToWideBuf(PChar(s), len, nil, 0);
if wlen > 0 then
begin
ReAllocMem(Result, wlen);
wlen:=AnsiToWideBuf(PChar(s), len, Result, wlen);
end
else
begin
Result^:=#0;
wlen:=SizeOf(WideChar);
end;
end;
if outlen <> nil then
outlen^:=(wlen - 1) div SizeOf(WideChar);
end;
{*****************************************************************************
WinAPI wrappers implementation
*****************************************************************************}
function GetFileAttributesW(p : pwidechar) : dword;
stdcall;external KernelDLL name 'GetFileAttributesW';
function DeleteFileW(p : pwidechar) : longint;
stdcall;external KernelDLL name 'DeleteFileW';
function MoveFileW(old,_new : pwidechar) : longint;
stdcall;external KernelDLL name 'MoveFileW';
function CreateFileW(lpFileName:pwidechar; dwDesiredAccess:DWORD; dwShareMode:DWORD;
lpSecurityAttributes:pointer; dwCreationDisposition:DWORD;
dwFlagsAndAttributes:DWORD; hTemplateFile:DWORD):longint;
stdcall;external KernelDLL name 'CreateFileW';
function CreateDirectoryW(name : pwidechar;sec : pointer) : longbool;
stdcall;external KernelDLL name 'CreateDirectoryW';
function RemoveDirectoryW(name:pwidechar):longbool;
stdcall;external KernelDLL name 'RemoveDirectoryW';
function GetFileAttributes(p : pchar) : dword; stdcall;
var
buf: array[0..MaxPathLen] of WideChar;
begin
AnsiToWideBuf(p, -1, buf, SizeOf(buf));
GetFileAttributes := GetFileAttributesW(buf);
end;
function DeleteFile(p : pchar) : longint; stdcall;
var
buf: array[0..MaxPathLen] of WideChar;
begin
AnsiToWideBuf(p, -1, buf, SizeOf(buf));
DeleteFile := DeleteFileW(buf);
end;
function MoveFile(old,_new : pchar) : longint; stdcall;
var
buf_old, buf_new: array[0..MaxPathLen] of WideChar;
begin
AnsiToWideBuf(old, -1, buf_old, SizeOf(buf_old));
AnsiToWideBuf(_new, -1, buf_new, SizeOf(buf_new));
MoveFile := MoveFileW(buf_old, buf_new);
end;
function CreateFile(lpFileName:pchar; dwDesiredAccess:DWORD; dwShareMode:DWORD;
lpSecurityAttributes:pointer; dwCreationDisposition:DWORD;
dwFlagsAndAttributes:DWORD; hTemplateFile:DWORD):longint; stdcall;
var
buf: array[0..MaxPathLen] of WideChar;
begin
AnsiToWideBuf(lpFileName, -1, buf, SizeOf(buf));
CreateFile := CreateFileW(buf, dwDesiredAccess, dwShareMode, lpSecurityAttributes,
dwCreationDisposition, dwFlagsAndAttributes, hTemplateFile);
end;
function CreateDirectory(name : pointer;sec : pointer) : longbool; stdcall;
var
buf: array[0..MaxPathLen] of WideChar;
begin
AnsiToWideBuf(name, -1, buf, SizeOf(buf));
CreateDirectory := CreateDirectoryW(buf, sec);
end;
function RemoveDirectory(name:pointer):longbool; stdcall;
var
buf: array[0..MaxPathLen] of WideChar;
begin
AnsiToWideBuf(name, -1, buf, SizeOf(buf));
RemoveDirectory := RemoveDirectoryW(buf);
end;
const
{$ifdef CPUARM}
UserKData = $FFFFC800;
{$else CPUARM}
UserKData = $00005800;
{$endif CPUARM}
SYSHANDLE_OFFSET = $004;
SYS_HANDLE_BASE = 64;
SH_CURTHREAD = 1;
SH_CURPROC = 2;
type
PHandle = ^THandle;
const
EVENT_PULSE = 1;
EVENT_RESET = 2;
EVENT_SET = 3;
function CreateEventW(lpEventAttributes:pointer;bManualReset:longbool;bInitialState:longbool;lpName:PWideChar): THandle;
stdcall; external KernelDLL name 'CreateEventW';
function CreateEvent(lpEventAttributes:pointer;bManualReset:longbool;bInitialState:longbool;lpName:pchar): THandle; stdcall;
var
buf: array[0..MaxPathLen] of WideChar;
begin
AnsiToWideBuf(lpName, -1, buf, SizeOf(buf));
CreateEvent := CreateEventW(lpEventAttributes, bManualReset, bInitialState, buf);
end;
function EventModify(h: THandle; func: DWORD): LONGBOOL;
stdcall; external KernelDLL name 'EventModify';
function TlsCall(p1, p2: DWORD): DWORD;
stdcall; external KernelDLL name 'TlsCall';
function ResetEvent(h: THandle): LONGBOOL; stdcall;
begin
ResetEvent := EventModify(h,EVENT_RESET);
end;
function SetEvent(h: THandle): LONGBOOL; stdcall;
begin
SetEvent := EventModify(h,EVENT_SET);
end;
function GetCurrentProcessId:DWORD; stdcall;
var
p: PHandle;
begin
p:=PHandle(UserKData+SYSHANDLE_OFFSET + SH_CURPROC*SizeOf(THandle));
GetCurrentProcessId := p^;
end;
function Win32GetCurrentThreadId:DWORD; stdcall;
var
p: PHandle;
begin
p:=PHandle(UserKData+SYSHANDLE_OFFSET + SH_CURTHREAD*SizeOf(THandle));
Win32GetCurrentThreadId := p^;
end;
const
TLS_FUNCALLOC = 0;
TLS_FUNCFREE = 1;
function TlsAlloc : DWord; stdcall;
begin
TlsAlloc := TlsCall(TLS_FUNCALLOC, 0);
end;
function TlsFree(dwTlsIndex : DWord) : LongBool; stdcall;
begin
TlsFree := LongBool(TlsCall(TLS_FUNCFREE, dwTlsIndex));
end;
{*****************************************************************************
Parameter Handling
*****************************************************************************}
function GetCommandLine : pwidechar;
stdcall;external KernelDLL name 'GetCommandLineW';
var
ModuleName : array[0..255] of char;
function GetCommandFile:pchar;
var
buf: array[0..MaxPathLen] of WideChar;
begin
if ModuleName[0] = #0 then begin
GetModuleFileName(0, @buf, SizeOf(buf));
WideToAnsiBuf(buf, -1, @ModuleName, SizeOf(ModuleName));
end;
GetCommandFile:=@ModuleName;
end;
var
Fargc: longint;
Fargv: ppchar;
FCmdLine: PChar;
procedure setup_arguments;
var
arglen,
count : longint;
argstart,
pc,arg : pchar;
quote : char;
argvlen : longint;
procedure allocarg(idx,len:longint);
var
oldargvlen : longint;
begin
if idx>=argvlen then
begin
oldargvlen:=argvlen;
argvlen:=(idx+8) and (not 7);
sysreallocmem(Fargv,argvlen*sizeof(pointer));
fillchar(Fargv[oldargvlen],(argvlen-oldargvlen)*sizeof(pointer),0);
end;
{ use realloc to reuse already existing memory }
{ always allocate, even if length is zero, since }
{ the arg. is still present! }
sysreallocmem(Fargv[idx],len+1);
end;
begin
{ create commandline, it starts with the executed filename which is argv[0] }
{ WinCE passes the command NOT via the args, but via getmodulefilename}
if FCmdLine <> nil then exit;
argvlen:=0;
pc:=getcommandfile;
Arglen:=0;
while pc[Arglen] <> #0 do
Inc(Arglen);
allocarg(0,arglen);
move(pc^,Fargv[0]^,arglen+1);
{ Setup FCmdLine variable }
arg:=PChar(GetCommandLine);
count:=WideToAnsiBuf(PWideChar(arg), -1, nil, 0);
FCmdLine:=SysGetMem(arglen + count + 3);
FCmdLine^:='"';
move(pc^, (FCmdLine + 1)^, arglen);
(FCmdLine + arglen + 1)^:='"';
(FCmdLine + arglen + 2)^:=' ';
WideToAnsiBuf(PWideChar(arg), -1, FCmdLine + arglen + 3, count);
{ process arguments }
count:=0;
pc:=FCmdLine;
{$IfDef SYSTEM_DEBUG_STARTUP}
Writeln(stderr,'WinCE GetCommandLine is #',pc,'#');
{$EndIf }
while pc^<>#0 do
begin
{ skip leading spaces }
while pc^ in [#1..#32] do
inc(pc);
if pc^=#0 then
break;
{ calc argument length }
quote:=' ';
argstart:=pc;
arglen:=0;
while (pc^<>#0) do
begin
case pc^ of
#1..#32 :
begin
if quote<>' ' then
inc(arglen)
else
break;
end;
'"' :
begin
if quote<>'''' then
begin
if pchar(pc+1)^<>'"' then
begin
if quote='"' then
quote:=' '
else
quote:='"';
end
else
inc(pc);
end
else
inc(arglen);
end;
'''' :
begin
if quote<>'"' then
begin
if pchar(pc+1)^<>'''' then
begin
if quote='''' then
quote:=' '
else
quote:='''';
end
else
inc(pc);
end
else
inc(arglen);
end;
else
inc(arglen);
end;
inc(pc);
end;
{ copy argument }
{ Don't copy the first one, it is already there.}
If Count<>0 then
begin
allocarg(count,arglen);
quote:=' ';
pc:=argstart;
arg:=Fargv[count];
while (pc^<>#0) do
begin
case pc^ of
#1..#32 :
begin
if quote<>' ' then
begin
arg^:=pc^;
inc(arg);
end
else
break;
end;
'"' :
begin
if quote<>'''' then
begin
if pchar(pc+1)^<>'"' then
begin
if quote='"' then
quote:=' '
else
quote:='"';
end
else
inc(pc);
end
else
begin
arg^:=pc^;
inc(arg);
end;
end;
'''' :
begin
if quote<>'"' then
begin
if pchar(pc+1)^<>'''' then
begin
if quote='''' then
quote:=' '
else
quote:='''';
end
else
inc(pc);
end
else
begin
arg^:=pc^;
inc(arg);
end;
end;
else
begin
arg^:=pc^;
inc(arg);
end;
end;
inc(pc);
end;
arg^:=#0;
end;
{$IfDef SYSTEM_DEBUG_STARTUP}
Writeln(stderr,'dos arg ',count,' #',arglen,'#',Fargv[count],'#');
{$EndIf SYSTEM_DEBUG_STARTUP}
inc(count);
end;
{ get argc and create an nil entry }
Fargc:=count;
allocarg(argc,0);
{ free unused memory }
sysreallocmem(Fargv,(argc+1)*sizeof(pointer));
end;
function CmdLine: PChar;
begin
setup_arguments;
Result:=FCmdLine;
end;
function argc: longint;
begin
setup_arguments;
Result:=Fargc;
end;
function argv: ppchar;
begin
setup_arguments;
Result:=Fargv;
end;
function paramcount : longint;
begin
paramcount := argc - 1;
end;
function paramstr(l : longint) : string;
begin
setup_arguments;
if (l>=0) and (l<Fargc) then
paramstr:=strpas(Fargv[l])
else
paramstr:='';
end;
procedure randomize;
begin
randseed:=GetTickCount;
end;
{*****************************************************************************
System Dependent Exit code
*****************************************************************************}
procedure PascalMain;stdcall;external name 'PASCALMAIN';
procedure ExitThread(Exitcode : longint); external 'coredll';
Procedure system_exit;
begin
if IsLibrary then
exit;
if not IsConsole then
begin
Close(stderr);
Close(stdout);
Close(erroutput);
Close(Input);
Close(Output);
end;
ExitThread(exitcode);
end;
{$ifdef cpu386}
var
{ value of the stack segment
to check if the call stack can be written on exceptions }
_SS : Cardinal;
{$endif cpu386}
Const
{ DllEntryPoint }
DLL_PROCESS_ATTACH = 1;
DLL_THREAD_ATTACH = 2;
DLL_PROCESS_DETACH = 0;
DLL_THREAD_DETACH = 3;
Const
DLLExitOK : boolean = true;
function Dll_entry : longbool;[public, alias : '_FPC_DLL_Entry'];
var
res : longbool;
begin
IsLibrary:=true;
Dll_entry:=false;
case DLLreason of
DLL_PROCESS_ATTACH :
begin
if assigned(Dll_Process_Attach_Hook) then
begin
res:=Dll_Process_Attach_Hook(DllParam);
if not res then
exit(false);
end;
PASCALMAIN;
Dll_entry:=true;
end;
DLL_THREAD_ATTACH :
begin
inclocked(Thread_count);
{$warning Allocate Threadvars !}
if assigned(Dll_Thread_Attach_Hook) then
Dll_Thread_Attach_Hook(DllParam);
end;
DLL_THREAD_DETACH :
begin
declocked(Thread_count);
if assigned(Dll_Thread_Detach_Hook) then
Dll_Thread_Detach_Hook(DllParam);
{$warning Release Threadvars !}
end;
DLL_PROCESS_DETACH :
begin
Lib_Exit;
if assigned(Dll_Process_Detach_Hook) then
Dll_Process_Detach_Hook(DllParam);
end;
end;
end;
{$ifdef WINCE_EXCEPTION_HANDLING}
//
// Hardware exception handling
//
{
Error code definitions for the WinCE API functions
Values are 32 bit values layed out as follows:
3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1
1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
+---+-+-+-----------------------+-------------------------------+
|Sev|C|R| Facility | Code |
+---+-+-+-----------------------+-------------------------------+
where
Sev - is the severity code
00 - Success
01 - Informational
10 - Warning
11 - Error
C - is the Customer code flag
R - is a reserved bit
Facility - is the facility code
Code - is the facility's status code
}
const
SEVERITY_SUCCESS = $00000000;
SEVERITY_INFORMATIONAL = $40000000;
SEVERITY_WARNING = $80000000;
SEVERITY_ERROR = $C0000000;
const
STATUS_SEGMENT_NOTIFICATION = $40000005;
DBG_TERMINATE_THREAD = $40010003;
DBG_TERMINATE_PROCESS = $40010004;
DBG_CONTROL_C = $40010005;
DBG_CONTROL_BREAK = $40010008;
STATUS_GUARD_PAGE_VIOLATION = $80000001;
STATUS_DATATYPE_MISALIGNMENT = $80000002;
STATUS_BREAKPOINT = $80000003;
STATUS_SINGLE_STEP = $80000004;
DBG_EXCEPTION_NOT_HANDLED = $80010001;
STATUS_ACCESS_VIOLATION = $C0000005;
STATUS_IN_PAGE_ERROR = $C0000006;
STATUS_INVALID_HANDLE = $C0000008;
STATUS_NO_MEMORY = $C0000017;
STATUS_ILLEGAL_INSTRUCTION = $C000001D;
STATUS_NONCONTINUABLE_EXCEPTION = $C0000025;
STATUS_INVALID_DISPOSITION = $C0000026;
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;
STATUS_FLOAT_MULTIPLE_FAULTS = $C00002B4;
STATUS_FLOAT_MULTIPLE_TRAPS = $C00002B5;
STATUS_REG_NAT_CONSUMPTION = $C00002C9;
const
ExceptionContinueExecution = 0;
ExceptionContinueSearch = 1;
ExceptionNestedException = 2;
ExceptionCollidedUnwind = 3;
ExceptionExecuteHandler = 4;
MaxExceptionLevel = 16;
exceptLevel : Byte = 0;
{$ifdef CPUARM}
const
CONTEXT_ARM = $0000040;
CONTEXT_CONTROL = CONTEXT_ARM or $00000001;
CONTEXT_INTEGER = CONTEXT_ARM or $00000002;
CONTEXT_SEGMENTS = CONTEXT_ARM or $00000004;
CONTEXT_FLOATING_POINT = CONTEXT_ARM or $00000008;
CONTEXT_DEBUG_REGISTERS = CONTEXT_ARM or $00000010;
CONTEXT_EXTENDED_REGISTERS = CONTEXT_ARM or $00000020;
CONTEXT_FULL = CONTEXT_CONTROL or CONTEXT_INTEGER or CONTEXT_SEGMENTS;
EXCEPTION_MAXIMUM_PARAMETERS = 15;
NUM_VFP_REGS = 32;
NUM_EXTRA_CONTROL_REGS = 8;
type
PContext = ^TContext;
TContext = record
ContextFlags : LongWord;
// This section is specified/returned if the ContextFlags word contains
// the flag CONTEXT_INTEGER.
R0 : LongWord;
R1 : LongWord;
R2 : LongWord;
R3 : LongWord;
R4 : LongWord;
R5 : LongWord;
R6 : LongWord;
R7 : LongWord;
R8 : LongWord;
R9 : LongWord;
R10 : LongWord;
R11 : LongWord;
R12 : LongWord;
// This section is specified/returned if the ContextFlags word contains
// the flag CONTEXT_CONTROL.
Sp : LongWord;
Lr : LongWord;
Pc : LongWord;
Psr : LongWord;
Fpscr : LongWord;
FpExc : LongWord;
// Floating point registers
S : array[0..(NUM_VFP_REGS + 1)-1] of LongWord;
FpExtra : array[0..(NUM_EXTRA_CONTROL_REGS)-1] of LongWord;
end;
{$endif CPUARM}
{$ifdef CPUI386}
const
CONTEXT_X86 = $00010000;
CONTEXT_CONTROL = CONTEXT_X86 or $00000001;
CONTEXT_INTEGER = CONTEXT_X86 or $00000002;
CONTEXT_SEGMENTS = CONTEXT_X86 or $00000004;
CONTEXT_FLOATING_POINT = CONTEXT_X86 or $00000008;
CONTEXT_DEBUG_REGISTERS = CONTEXT_X86 or $00000010;
CONTEXT_EXTENDED_REGISTERS = CONTEXT_X86 or $00000020;
MAXIMUM_SUPPORTED_EXTENSION = 512;
EXCEPTION_MAXIMUM_PARAMETERS = 15;
type
PFloatingSaveArea = ^TFloatingSaveArea;
TFloatingSaveArea = packed record
ControlWord : Cardinal;
StatusWord : Cardinal;
TagWord : Cardinal;
ErrorOffset : Cardinal;
ErrorSelector : Cardinal;
DataOffset : Cardinal;
DataSelector : Cardinal;
RegisterArea : array[0..79] of Byte;
Cr0NpxState : Cardinal;
end;
PContext = ^TContext;
TContext = packed record
//
// The flags values within this flag control the contents of
// a CONTEXT record.
//
ContextFlags : Cardinal;
//
// This section is specified/returned if CONTEXT_DEBUG_REGISTERS is
// set in ContextFlags. Note that CONTEXT_DEBUG_REGISTERS is NOT
// included in CONTEXT_FULL.
//
Dr0, Dr1, Dr2,
Dr3, Dr6, Dr7 : Cardinal;
//
// This section is specified/returned if the
// ContextFlags word contains the flag CONTEXT_FLOATING_POINT.
//
FloatSave : TFloatingSaveArea;
//
// This section is specified/returned if the
// ContextFlags word contains the flag CONTEXT_SEGMENTS.
//
SegGs, SegFs,
SegEs, SegDs : Cardinal;
//
// This section is specified/returned if the
// ContextFlags word contains the flag CONTEXT_INTEGER.
//
Edi, Esi, Ebx,
Edx, Ecx, Eax : Cardinal;
//
// This section is specified/returned if the
// ContextFlags word contains the flag CONTEXT_CONTROL.
//
Ebp : Cardinal;
Eip : Cardinal;
SegCs : Cardinal;
EFlags, Esp, SegSs : Cardinal;
//
// This section is specified/returned if the ContextFlags word
// contains the flag CONTEXT_EXTENDED_REGISTERS.
// The format and contexts are processor specific
//
ExtendedRegisters : array[0..MAXIMUM_SUPPORTED_EXTENSION-1] of Byte;
end;
{$endif CPUI386}
type
PExceptionRecord = ^TExceptionRecord;
TExceptionRecord = packed record
ExceptionCode : Longint;
ExceptionFlags : Longint;
ExceptionRecord : PExceptionRecord;
ExceptionAddress : Pointer;
NumberParameters : Longint;
ExceptionInformation : array[0..EXCEPTION_MAXIMUM_PARAMETERS-1] of Pointer;
end;
PExceptionPointers = ^TExceptionPointers;
TExceptionPointers = packed record
ExceptionRecord : PExceptionRecord;
ContextRecord : PContext;
end;
{$ifdef CPUI386}
{**************************** i386 Exception handling *****************************************}
function GetCurrentProcess:DWORD; stdcall;
begin
GetCurrentProcess := SH_CURPROC+SYS_HANDLE_BASE;
end;
function ReadProcessMemory(process : dword;address : pointer;dest : pointer;size : dword;bytesread : pdword) : longbool;
stdcall;external 'coredll' name 'ReadProcessMemory';
function is_prefetch(p : pointer) : boolean;
var
a : array[0..15] of byte;
doagain : boolean;
instrlo,instrhi,opcode : byte;
i : longint;
begin
result:=false;
{ read memory savely without causing another exeception }
if not(ReadProcessMemory(GetCurrentProcess,p,@a,sizeof(a),nil)) then
exit;
i:=0;
doagain:=true;
while doagain and (i<15) do
begin
opcode:=a[i];
instrlo:=opcode and $f;
instrhi:=opcode and $f0;
case instrhi of
{ prefix? }
$20,$30:
doagain:=(instrlo and 7)=6;
$60:
doagain:=(instrlo and $c)=4;
$f0:
doagain:=instrlo in [0,2,3];
$0:
begin
result:=(instrlo=$f) and (a[i+1] in [$d,$18]);
exit;
end;
else
doagain:=false;
end;
inc(i);
end;
end;
var
exceptEip : array[0..MaxExceptionLevel-1] of Longint;
exceptError : array[0..MaxExceptionLevel-1] of Byte;
resetFPU : array[0..MaxExceptionLevel-1] of Boolean;
{$ifdef SYSTEMEXCEPTIONDEBUG}
procedure DebugHandleErrorAddrFrame(error, addr, frame : longint);
begin
if IsConsole then
begin
write(stderr,'HandleErrorAddrFrame(error=',error);
write(stderr,',addr=',hexstr(addr,8));
writeln(stderr,',frame=',hexstr(frame,8),')');
end;
HandleErrorAddrFrame(error,addr,frame);
end;
{$endif SYSTEMEXCEPTIONDEBUG}
procedure JumpToHandleErrorFrame;
var
eip, ebp, error : Longint;
begin
// save ebp
asm
movl (%ebp),%eax
movl %eax,ebp
end;
if (exceptLevel > 0) then
dec(exceptLevel);
eip:=exceptEip[exceptLevel];
error:=exceptError[exceptLevel];
{$ifdef SYSTEMEXCEPTIONDEBUG}
if IsConsole then
writeln(stderr,'In JumpToHandleErrorFrame error=',error);
{$endif SYSTEMEXCEPTIONDEBUG}
if resetFPU[exceptLevel] then asm
fninit
fldcw fpucw
end;
{ build a fake stack }
asm
{$ifdef REGCALL}
movl ebp,%ecx
movl eip,%edx
movl error,%eax
pushl eip
movl ebp,%ebp // Change frame pointer
{$else}
movl ebp,%eax
pushl %eax
movl eip,%eax
pushl %eax
movl error,%eax
pushl %eax
movl eip,%eax
pushl %eax
movl ebp,%ebp // Change frame pointer
{$endif}
{$ifdef SYSTEMEXCEPTIONDEBUG}
jmpl DebugHandleErrorAddrFrame
{$else not SYSTEMEXCEPTIONDEBUG}
jmpl HandleErrorAddrFrame
{$endif SYSTEMEXCEPTIONDEBUG}
end;
end;
function i386_exception_handler(ExceptionRecord: PExceptionRecord;
EstablisherFrame: pointer; ContextRecord: PContext;
DispatcherContext: pointer): longint; cdecl;
var
res: longint;
must_reset_fpu: boolean;
begin
res := ExceptionContinueSearch;
if ContextRecord^.SegSs=_SS then begin
must_reset_fpu := true;
{$ifdef SYSTEMEXCEPTIONDEBUG}
if IsConsole then Writeln(stderr,'Exception ',
hexstr(excep^.ExceptionRecord^.ExceptionCode, 8));
{$endif SYSTEMEXCEPTIONDEBUG}
case cardinal(ExceptionRecord^.ExceptionCode) of
STATUS_INTEGER_DIVIDE_BY_ZERO,
STATUS_FLOAT_DIVIDE_BY_ZERO :
res := 200;
STATUS_ARRAY_BOUNDS_EXCEEDED :
begin
res := 201;
must_reset_fpu := false;
end;
STATUS_STACK_OVERFLOW :
begin
res := 202;
must_reset_fpu := false;
end;
STATUS_FLOAT_OVERFLOW :
res := 205;
STATUS_FLOAT_DENORMAL_OPERAND,
STATUS_FLOAT_UNDERFLOW :
res := 206;
{excep^.ContextRecord^.FloatSave.StatusWord := excep^.ContextRecord^.FloatSave.StatusWord and $ffffff00;}
STATUS_FLOAT_INEXACT_RESULT,
STATUS_FLOAT_INVALID_OPERATION,
STATUS_FLOAT_STACK_CHECK :
res := 207;
STATUS_INTEGER_OVERFLOW :
begin
res := 215;
must_reset_fpu := false;
end;
STATUS_ILLEGAL_INSTRUCTION:
res := 216;
STATUS_ACCESS_VIOLATION:
{ Athlon prefetch bug? }
if is_prefetch(pointer(ContextRecord^.Eip)) then
begin
{ if yes, then retry }
ExceptionRecord^.ExceptionCode := 0;
res:=ExceptionContinueExecution;
end
else
res := 216;
STATUS_CONTROL_C_EXIT:
res := 217;
STATUS_PRIVILEGED_INSTRUCTION:
begin
res := 218;
must_reset_fpu := false;
end;
else
begin
if ((ExceptionRecord^.ExceptionCode and SEVERITY_ERROR) = SEVERITY_ERROR) then
res := 217
else
res := 255;
end;
end;
if (res >= 200) and (exceptLevel < MaxExceptionLevel) then begin
exceptEip[exceptLevel] := ContextRecord^.Eip;
exceptError[exceptLevel] := res;
resetFPU[exceptLevel] := must_reset_fpu;
inc(exceptLevel);
ContextRecord^.Eip := Longint(@JumpToHandleErrorFrame);
ExceptionRecord^.ExceptionCode := 0;
res := ExceptionContinueExecution;
{$ifdef SYSTEMEXCEPTIONDEBUG}
if IsConsole then begin
writeln(stderr,'Exception Continue Exception set at ',
hexstr(exceptEip[exceptLevel],8));
writeln(stderr,'Eip changed to ',
hexstr(longint(@JumpToHandleErrorFrame),8), ' error=', error);
end;
{$endif SYSTEMEXCEPTIONDEBUG}
end;
end;
i386_exception_handler := res;
end;
{$endif CPUI386}
{$ifdef CPUARM}
{**************************** ARM Exception handling *****************************************}
var
exceptPC : array[0..MaxExceptionLevel-1] of Longint;
exceptError : array[0..MaxExceptionLevel-1] of Byte;
procedure JumpToHandleErrorFrame;
var
_pc, _fp, _error : Longint;
begin
// get original fp
asm
ldr r0,[r11,#-12]
str r0,_fp
end;
if (exceptLevel > 0) then
dec(exceptLevel);
_pc:=exceptPC[exceptLevel];
_error:=exceptError[exceptLevel];
asm
ldr r0,_error
ldr r1,_pc
ldr r2,_fp
mov r11,r2 // Change frame pointer
b HandleErrorAddrFrame
end;
end;
function ARM_ExceptionHandler(ExceptionRecord: PExceptionRecord;
EstablisherFrame: pointer; ContextRecord: PContext;
DispatcherContext: pointer): longint; [public, alias : '_ARM_ExceptionHandler'];
var
res: longint;
begin
res := ExceptionContinueSearch;
case cardinal(ExceptionRecord^.ExceptionCode) of
STATUS_INTEGER_DIVIDE_BY_ZERO,
STATUS_FLOAT_DIVIDE_BY_ZERO :
res := 200;
STATUS_ARRAY_BOUNDS_EXCEEDED :
res := 201;
STATUS_STACK_OVERFLOW :
res := 202;
STATUS_FLOAT_OVERFLOW :
res := 205;
STATUS_FLOAT_DENORMAL_OPERAND,
STATUS_FLOAT_UNDERFLOW :
res := 206;
STATUS_FLOAT_INEXACT_RESULT,
STATUS_FLOAT_INVALID_OPERATION,
STATUS_FLOAT_STACK_CHECK :
res := 207;
STATUS_INTEGER_OVERFLOW :
res := 215;
STATUS_ILLEGAL_INSTRUCTION:
res := 216;
STATUS_ACCESS_VIOLATION:
res := 216;
STATUS_DATATYPE_MISALIGNMENT:
res := 214;
STATUS_CONTROL_C_EXIT:
res := 217;
STATUS_PRIVILEGED_INSTRUCTION:
res := 218;
else
begin
if ((cardinal(ExceptionRecord^.ExceptionCode) and SEVERITY_ERROR) = SEVERITY_ERROR) then
res := 217
else
res := 255;
end;
end;
if (res <> ExceptionContinueSearch) and (exceptLevel < MaxExceptionLevel) then begin
exceptPC[exceptLevel] := ContextRecord^.PC;
exceptError[exceptLevel] := res;
inc(exceptLevel);
ContextRecord^.PC := Longint(@JumpToHandleErrorFrame);
ExceptionRecord^.ExceptionCode := 0;
res := ExceptionContinueExecution;
{$ifdef SYSTEMEXCEPTIONDEBUG}
if IsConsole then begin
writeln(stderr,'Exception Continue Exception set at ',
hexstr(exceptEip[exceptLevel],8));
writeln(stderr,'Eip changed to ',
hexstr(longint(@JumpToHandleErrorFrame),8), ' error=', error);
end;
{$endif SYSTEMEXCEPTIONDEBUG}
end;
ARM_ExceptionHandler := res;
end;
{$endif CPUARM}
{$endif WINCE_EXCEPTION_HANDLING}
procedure Exe_entry;[public, alias : '_FPC_EXE_Entry'];
var
st: pointer;
begin
IsLibrary:=false;
{$ifdef CPUARM}
asm
str sp,st
end;
StackTop:=st;
asm
mov fp,#0
bl PASCALMAIN;
end;
{$endif CPUARM}
{$ifdef CPUI386}
asm
{$ifdef WINCE_EXCEPTION_HANDLING}
pushl i386_exception_handler
pushl %fs:(0)
mov %esp,%fs:(0)
{$endif WINCE_EXCEPTION_HANDLING}
pushl %ebp
movl %esp,%eax
movl %eax,st
end;
StackTop:=st;
asm
xorl %eax,%eax
movw %ss,%ax
movl %eax,_SS
call SysResetFPU
xorl %ebp,%ebp
call PASCALMAIN
popl %ebp
{$ifdef WINCE_EXCEPTION_HANDLING}
popl %fs:(0)
addl $4, %esp
{$endif WINCE_EXCEPTION_HANDLING}
end;
{$endif CPUI386}
end;
procedure _FPC_mainCRTStartup;stdcall;public name '_mainCRTStartup';
begin
IsConsole:=True;
Exe_entry;
end;
procedure _FPC_WinMainCRTStartup;stdcall;public name '_WinMainCRTStartup';
begin
IsConsole:=False;
Exe_entry;
end;
procedure _FPC_DLLMainCRTStartup(_hinstance,_dllreason,_dllparam:longint);stdcall;public name '_DLLMainCRTStartup';
begin
IsConsole:=true;
sysinstance:=_hinstance;
dllreason:=_dllreason;
dllparam:=_dllparam;
DLL_Entry;
end;
procedure _FPC_DLLWinMainCRTStartup(_hinstance,_dllreason,_dllparam:longint);stdcall;public name '_DLLWinMainCRTStartup';
begin
IsConsole:=false;
sysinstance:=_hinstance;
dllreason:=_dllreason;
dllparam:=_dllparam;
DLL_Entry;
end;
{****************************************************************************
OS dependend widestrings
****************************************************************************}
function CharUpperBuff(lpsz:LPWSTR; cchLength:DWORD):DWORD; stdcall; external KernelDLL name 'CharUpperBuffW';
function CharLowerBuff(lpsz:LPWSTR; cchLength:DWORD):DWORD; stdcall; external KernelDLL name 'CharLowerBuffW';
procedure WinCEWide2AnsiMove(source:pwidechar;var dest:ansistring;len:SizeInt);
var
i: integer;
begin
if len = 0 then
dest:=''
else
begin
for i:=1 to 2 do begin
setlength(dest, len);
len:=WideCharToMultiByte(CP_ACP, 0, source, len, @dest[1], len, nil, nil);
if len > 0 then
break;
len:=WideCharToMultiByte(CP_ACP, 0, source, len, nil, 0, nil, nil);
end;
setlength(dest, len);
end;
end;
procedure WinCEAnsi2WideMove(source:pchar;var dest:widestring;len:SizeInt);
var
i: integer;
begin
if len = 0 then
dest:=''
else
begin
for i:=1 to 2 do begin
setlength(dest, len);
len:=MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, source, len, @dest[1], len);
if len > 0 then
break;
len:=MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, source, len, nil, 0);
end;
setlength(dest, len);
end;
end;
function WinCEWideUpper(const s : WideString) : WideString;
begin
result:=s;
UniqueString(result);
if length(result)>0 then
CharUpperBuff(LPWSTR(result),length(result));
end;
function WinCEWideLower(const s : WideString) : WideString;
begin
result:=s;
UniqueString(result);
if length(result)>0 then
CharLowerBuff(LPWSTR(result),length(result));
end;
{ there is a similiar procedure in sysutils which inits the fields which
are only relevant for the sysutils units }
procedure InitWinCEWidestrings;
begin
widestringmanager.Wide2AnsiMoveProc:=@WinCEWide2AnsiMove;
widestringmanager.Ansi2WideMoveProc:=@WinCEAnsi2WideMove;
widestringmanager.UpperWideStringProc:=@WinCEWideUpper;
widestringmanager.LowerWideStringProc:=@WinCEWideLower;
end;
{$IFDEF HAS_MT_MEMORYMANAGER}
{****************************************************************************
Memory manager
****************************************************************************}
function malloc(Size : ptrint) : Pointer; external 'coredll';
procedure free(P : pointer); external 'coredll';
function realloc(P : Pointer; Size : ptrint) : pointer; external 'coredll';
function _msize(P : pointer): ptrint; external 'coredll';
function SysGetMem (Size : ptrint) : Pointer;
begin
Result:=malloc(Size);
end;
Function SysFreeMem (P : pointer) : ptrint;
begin
free(P);
Result:=0;
end;
Function SysFreeMemSize(p:pointer;Size:ptrint):ptrint;
begin
Result:=0;
if size < 0 then
runerror(204)
else
if (size > 0) and (p <> nil) then
Result:=SysFreeMem(P);
end;
Function SysAllocMem(Size : ptrint) : Pointer;
begin
Result:=SysGetMem(Size);
if Result <> nil then
FillChar(Result^, Size, 0);
end;
Function SysReAllocMem (var p:pointer;Size:ptrint):Pointer;
begin
Result:=realloc(p, Size);
p:=Result;
end;
function SysTryResizeMem(var p:pointer;size : ptrint):boolean;
var
res: pointer;
begin
res:=realloc(p, Size);
Result:=(res <> nil) or (Size = 0);
if Result then
p:=res;
end;
function SysMemSize(P : pointer): ptrint;
begin
Result:=_msize(P);
end;
function SysGetHeapStatus:THeapStatus;
begin
fillchar(Result,sizeof(Result),0);
end;
function SysGetFPCHeapStatus:TFPCHeapStatus;
begin
fillchar(Result,sizeof(Result),0);
end;
{$ENDIF HAS_MT_MEMORYMANAGER}
{****************************************************************************
Error Message writing using messageboxes
****************************************************************************}
const
ErrorBufferLength = 1024;
var
ErrorBuf : array[0..ErrorBufferLength] of char;
ErrorBufW : array[0..ErrorBufferLength] of widechar;
ErrorLen : longint;
Function ErrorWrite(Var F: TextRec): Integer;
{
An error message should always end with #13#10#13#10
}
var
p : pchar;
i : longint;
Begin
if F.BufPos>0 then
begin
if F.BufPos+ErrorLen>ErrorBufferLength then
i:=ErrorBufferLength-ErrorLen
else
i:=F.BufPos;
Move(F.BufPtr^,ErrorBuf[ErrorLen],i);
inc(ErrorLen,i);
ErrorBuf[ErrorLen]:=#0;
end;
if ErrorLen>3 then
begin
p:=@ErrorBuf[ErrorLen];
for i:=1 to 4 do
begin
dec(p);
if not(p^ in [#10,#13]) then
break;
end;
end;
if ErrorLen=ErrorBufferLength then
i:=4;
if (i=4) then
begin
AnsiToWideBuf(@ErrorBuf, -1, @ErrorBufW, SizeOf(ErrorBufW));
MessageBox(0,@ErrorBufW,'Error',0);
ErrorLen:=0;
end;
F.BufPos:=0;
ErrorWrite:=0;
End;
Function ErrorClose(Var F: TextRec): Integer;
begin
if ErrorLen>0 then
begin
AnsiToWideBuf(@ErrorBuf, -1, @ErrorBufW, SizeOf(ErrorBufW));
MessageBox(0,@ErrorBufW,'Error',0);
ErrorLen:=0;
end;
ErrorLen:=0;
ErrorClose:=0;
end;
Function ErrorOpen(Var F: TextRec): Integer;
Begin
TextRec(F).InOutFunc:=@ErrorWrite;
TextRec(F).FlushFunc:=@ErrorWrite;
TextRec(F).CloseFunc:=@ErrorClose;
ErrorOpen:=0;
End;
procedure AssignError(Var T: Text);
begin
Assign(T,'');
TextRec(T).OpenFunc:=@ErrorOpen;
Rewrite(T);
end;
function _getstdfilex(fd: integer): pointer; cdecl; external 'coredll';
function _fileno(fd: pointer): THandle; cdecl; external 'coredll';
function _controlfp(new: DWORD; mask: DWORD): DWORD; cdecl; external 'coredll';
procedure SysInitStdIO;
begin
{ Setup stdin, stdout and stderr, for GUI apps redirect stderr,stdout to be
displayed in and messagebox }
if not IsConsole then begin
AssignError(stderr);
AssignError(stdout);
Assign(Output,'');
Assign(Input,'');
Assign(ErrOutput,'');
end
else begin
StdInputHandle:=_fileno(_getstdfilex(0));
StdOutputHandle:=_fileno(_getstdfilex(1));
StdErrorHandle:=_fileno(_getstdfilex(2));
OpenStdIO(Input,fmInput,StdInputHandle);
OpenStdIO(Output,fmOutput,StdOutputHandle);
OpenStdIO(ErrOutput,fmOutput,StdErrorHandle);
OpenStdIO(StdOut,fmOutput,StdOutputHandle);
OpenStdIO(StdErr,fmOutput,StdErrorHandle);
end;
end;
(* ProcessID cached to avoid repeated calls to GetCurrentProcess. *)
var
ProcessID: SizeUInt;
function GetProcessID: SizeUInt;
begin
GetProcessID := ProcessID;
end;
function CheckInitialStkLen(stklen : SizeUInt) : SizeUInt;
begin
result := stklen;
end;
procedure SysCleanup;
var
i: integer;
begin
SysFreeMem(FCmdLine);
for i:=0 to argc do
sysfreemem(argv[i]);
sysfreemem(argv);
end;
initialization
StackLength := CheckInitialStkLen(InitialStkLen);
StackBottom := StackTop - StackLength;
{ Enable FPU exceptions }
_controlfp(1, $0008001F);
{ some misc stuff }
hprevinst:=0;
if not IsLibrary then
SysInstance:=GetModuleHandle(nil);
MainInstance:=SysInstance;
{$IFNDEF HAS_MT_MEMORYMANAGER}
{ Setup Heap }
InitHeap;
{$ENDIF HAS_MT_MEMORYMANAGER}
SysInitExceptions;
if not IsLibrary then
begin
SysInitStdIO;
end;
{ Reset IO Error }
InOutRes:=0;
ProcessID := GetCurrentProcessID;
{ threading }
InitSystemThreads;
{ Reset internal error variable }
errno:=0;
initvariantmanager;
initwidestringmanager;
InitWinCEWidestrings
finalization
{ Cleanup }
SysCleanup;
end.
Reference in New Issue View Git Blame Copy Permalink