unit system;
{$MODE FPC}
{$MEMORY 1073741824 2147483648}
{$POINTERMATH ON}
interface
{$IFDEF CPU32}
const maxheap=16777216*4;
maxsection=16384;
{$ELSE CPU32}
const maxheap=67108864*4;
maxsection=65536;
{$ENDIF CPU32}
type
hresult = LongInt;
DWord = LongWord;
Cardinal = LongWord;
Integer = SmallInt;
UInt64 = QWord;
Pbyte=^byte;
Pchar=^char;
PWideChar=^WideChar;
PPWideChar=^PWideChar;
PWChar=^WideChar;
PPWChar=^PWChar;
Pword=^word;
Pdword=^dword;
Pqword=^qword;
PPointer=^Pointer;
Pboolean=^boolean;
{$IFDEF CPU32}
NatUint=dword;
PNatUint=^dword;
Natint=integer;
PNatint=^integer;
{$ELSE CPU32}
NatUint=qword;
PNatUint=^qword;
Natint=int64;
PNatint=^int64;
{$ENDIF CPU32}
TTypeKind = (tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat, tkSet,
tkMethod, tkSString, tkLString, tkAString, tkWString, tkVariant, tkArray,
tkRecord, tkInterface, tkClass, tkObject, tkWChar, tkBool, tkInt64, tkQWord,
tkDynArray, tkInterfaceRaw, tkProcVar, tkUString, tkUChar, tkHelper, tkFile,
tkClassRef, tkPointer);
PTypeKind=^TTypekind;
jmp_buf = packed record
rbx, rbp, r12, r13, r14, r15, rsp, rip: QWord;
{$IFDEF CPU64}
rsi, rdi: QWord;
xmm6, xmm7, xmm8, xmm9, xmm10, xmm11, xmm12, xmm13, xmm14, xmm15: record
m1, m2: QWord;
end;
mxcsr: LongWord;
fpucw: word;
padding: word;
{$ENDIF CPU64}
end;
Pjmp_buf = ^jmp_buf;
PExceptAddr = ^TExceptAddr;
TExceptAddr = record
buf: Pjmp_buf;
next: PExceptAddr;
{$IFDEF CPU16}
frametype: SmallInt;
{$ELSE CPU16}
frametype: LongInt;
{$ENDIF CPU16}
end;
PGuid = ^TGuid;
TGuid = packed record
case Integer of
1:
(Data1: DWord;
Data2: word;
Data3: word;
Data4: array [0 .. 7] of byte;
);
2:
(D1: DWord;
D2: word;
D3: word;
D4: array [0 .. 7] of byte;
);
3:
( { uuid fields according to RFC4122 }
time_low: DWord; // The low field of the timestamp
time_mid: word; // The middle field of the timestamp
time_hi_and_version: word;
// The high field of the timestamp multiplexed with the version number
clock_seq_hi_and_reserved: byte;
// The high field of the clock sequence multiplexed with the variant
clock_seq_low: byte; // The low field of the clock sequence
node: array [0 .. 5] of byte; // The spatially unique node identifier
);
end;
systemheap=record
heapcontent:array[1..maxheap] of byte;
heapsection:array[1..maxsection,1..2] of natuint;
heapcount,heaprest:natuint;
end;
procedure fpc_initialize(data,info:Pointer);compilerproc;
procedure fpc_finalize(data,Info:Pointer);compilerproc;
procedure fpc_specific_handler;compilerproc;
function sys_getmem(size:natuint):Pointer;compilerproc;
procedure sys_freemem(var p:pointer);compilerproc;
function sys_allocmem(size:natuint):Pointer;compilerproc;
procedure sys_reallocmem(var p:Pointer;size:natuint);compilerproc;
procedure sys_move(const source;var dest;count:natuint);compilerproc;
function getmem(size:natuint):Pointer;
procedure freemem(var p:pointer);
function allocmem(size:natuint):Pointer;
procedure reallocmem(var p:Pointer;size:natuint);
procedure move(const source;var dest;count:natuint);
var compheap,sysheap:systemheap;
implementation
procedure fpc_initialize(Data,Info:Pointer);compilerproc;[public,alias:'FPC_INITIALIZE'];
begin
end;
procedure fpc_finalize(Data,Info:Pointer);compilerproc;[public,alias:'FPC_FINALIZE'];
begin
end;
procedure fpc_specific_handler;compilerproc;[public,alias:'__FPC_specific_handler'];
begin
end;
procedure compheap_delete_item(p:pointer);
var i,j,len:natuint;
begin
for i:=1 to compheap.heapcount do
begin
if(natuint(p)>=compheap.heapsection[i,1]) and (natuint(p)<=compheap.heapsection[i,2]) then break;
end;
if(i>compheap.heapcount) then exit;
len:=compheap.heapsection[i,2]-compheap.heapsection[i,1];
for j:=i+1 to compheap.heapcount do
begin
compheap.heapsection[j-1,1]:=compheap.heapsection[j,1]-len;
compheap.heapsection[j-1,2]:=compheap.heapsection[j,2]-len;
end;
compheap.heapsection[compheap.heapcount,1]:=0;
compheap.heapsection[compheap.heapcount,2]:=0;
dec(compheap.heapcount); inc(compheap.heaprest,len);
end;
function sys_getmem(size:natuint):Pointer;compilerproc;[public,alias:'FPC_GETMEM'];
var i,istart:natuint;
begin
if(compheap.heapcount>=maxsection) then sys_getmem:=nil;
if(compheap.heaprest<size) then sys_getmem:=nil;
if(size=0) then sys_getmem:=nil;
if(compheap.heapcount>0) then istart:=compheap.heapsection[compheap.heapcount,2]+1 else istart:=Natuint(@compheap.heapcontent);
inc(compheap.heapcount);
compheap.heapsection[compheap.heapcount,1]:=istart;
compheap.heapsection[compheap.heapcount,2]:=istart+size-1;
for i:=1 to size do
begin
compheap.heapcontent[istart+i-1]:=0;
end;
dec(compheap.heaprest,size);
sys_getmem:=Pointer(compheap.heapsection[compheap.heapcount,1]);
end;
procedure sys_freemem(var p:pointer);compilerproc;[public,alias:'FPC_FREEMEM'];
begin
compheap_delete_item(p); p:=nil;
end;
function sys_allocmem(size:natuint):Pointer;compilerproc;[public,alias:'FPC_ALLOCMEM'];
var i,istart:natuint;
begin
if(compheap.heapcount>=maxsection) then sys_allocmem:=nil;
if(compheap.heaprest<size) then sys_allocmem:=nil;
if(size=0) then sys_allocmem:=nil;
if(compheap.heapcount>0) then istart:=compheap.heapsection[compheap.heapcount,2]+1 else istart:=NatUint(@compheap.heapcontent);
inc(compheap.heapcount);
compheap.heapsection[compheap.heapcount,1]:=istart;
compheap.heapsection[compheap.heapcount,2]:=istart+size-1;
for i:=1 to size do
begin
compheap.heapcontent[istart+i-1]:=0;
end;
dec(compheap.heaprest,size);
sys_allocmem:=Pointer(compheap.heapsection[compheap.heapcount,1]);
end;
procedure sys_reallocmem(var p:Pointer;size:natuint);compilerproc;[public,alias:'FPC_REALLOCMEM'];
var i,istart,len:Natuint;
newp:Pointer;
p1,p2:Pchar;
begin
if(compheap.heapcount>=maxsection) then exit;
if(compheap.heaprest<size) then exit;
if(size=0) then exit;
if(compheap.heapcount>0) then istart:=compheap.heapsection[compheap.heapcount,2]+1 else istart:=Natuint(@compheap.heapcontent);
inc(compheap.heapcount);
compheap.heapsection[compheap.heapcount,1]:=istart;
compheap.heapsection[compheap.heapcount,2]:=istart+size-1;
for i:=1 to size do
begin
compheap.heapcontent[istart+i-1]:=0;
end;
dec(compheap.heaprest,size);
newp:=Pointer(compheap.heapsection[compheap.heapcount,1]);
for i:=1 to compheap.heapcount do
begin
if(NatUint(p)>=compheap.heapsection[i,1]) and (NatUint(p)<=compheap.heapsection[i,2]) then break;
end;
len:=NatUint(p)-compheap.heapsection[i,1];
p1:=@p^; p2:=@newp^;
for i:=1 to compheap.heapsection[i,2]-compheap.heapsection[i,1]+1 do p2^:=p1^;
compheap_delete_item(p); p:=newp+len;
end;
procedure sys_move(const source;var dest;count:natuint);compilerproc;[public,alias:'FPC_MOVE'];
var p1,p2:Pchar;
i:natuint;
begin
p1:=@source; p2:=@dest;
for i:=1 to count do p2^:=p1^;
end;
function fpc_copy_proc(src,dest,typeinfo:Pointer):natint;compilerproc;[public,alias:'fpc_copy_proc'];
var address1,address2:Pbyte;
i:natuint;
begin
address1:=src; address2:=dest;
for i:=1 to sizeof(src^) do
begin
(address2+i-1)^:=(address1+i-1)^;
end;
end;
procedure sysheap_delete_item(p:pointer);
var i,j,len:natuint;
begin
for i:=1 to sysheap.heapcount do
begin
if(natuint(p)>=sysheap.heapsection[i,1]) and (natuint(p)<=sysheap.heapsection[i,2]) then break;
end;
if(i>sysheap.heapcount) then exit;
len:=sysheap.heapsection[i,2]- sysheap.heapsection[i,1];
for j:=i+1 to sysheap.heapcount do
begin
sysheap.heapsection[j-1,1]:= sysheap.heapsection[j,1]-len;
sysheap.heapsection[j-1,2]:= sysheap.heapsection[j,2]-len;
end;
sysheap.heapsection[sysheap.heapcount,1]:=0;
sysheap.heapsection[sysheap.heapcount,2]:=0;
dec(sysheap.heapcount); inc(sysheap.heaprest,len);
end;
function getmem(size:natuint):Pointer;[public,alias:'getmem'];
var i,istart:natuint;
begin
if(sysheap.heapcount>=maxsection) then getmem:=nil;
if(sysheap.heaprest<size) then getmem:=nil;
if(size=0) then getmem:=nil;
if(sysheap.heapcount>0) then istart:=sysheap.heapsection[sysheap.heapcount,2]+1 else istart:=Natuint(@sysheap.heapcontent);
inc(sysheap.heapcount);
sysheap.heapsection[sysheap.heapcount,1]:=istart;
sysheap.heapsection[sysheap.heapcount,2]:=istart+size-1;
for i:=1 to size do
begin
sysheap.heapcontent[istart+i-1]:=0;
end;
dec(sysheap.heaprest,size);
getmem:=Pointer(sysheap.heapsection[sysheap.heapcount,1]);
end;
procedure freemem(var p:pointer);[public,alias:'freemem'];
begin
sysheap_delete_item(p); p:=nil;
end;
function allocmem(size:natuint):Pointer;[public,alias:'allocmem'];
var i,istart:natuint;
begin
if(sysheap.heapcount>=maxsection) then allocmem:=nil;
if(sysheap.heaprest<size) then allocmem:=nil;
if(size=0) then allocmem:=nil;
if(sysheap.heapcount>0) then istart:=sysheap.heapsection[sysheap.heapcount,2]+1 else istart:=NatUint(@sysheap.heapcontent);
inc(sysheap.heapcount);
sysheap.heapsection[sysheap.heapcount,1]:=istart;
sysheap.heapsection[sysheap.heapcount,2]:=istart+size-1;
for i:=1 to size do
begin
sysheap.heapcontent[istart+i-1]:=0;
end;
dec(sysheap.heaprest,size);
allocmem:=Pointer(sysheap.heapsection[sysheap.heapcount,1]);
end;
procedure reallocmem(var p:Pointer;size:natuint);[public,alias:'reallocmem'];
var i,len:Natuint;
newp:Pointer;
begin
newp:=getmem(size);
for i:=1 to sysheap.heapcount do
begin
if(NatUint(p)>=sysheap.heapsection[i,1]) and (NatUint(p)<=sysheap.heapsection[i,2]) then break;
end;
len:=NatUint(p)-compheap.heapsection[i,1];
move(p^,newp^,sysheap.heapsection[i,2]-sysheap.heapsection[i,1]+1);
sysheap_delete_item(p); p:=newp+len;
end;
procedure move(const source;var dest;count:natuint);[public,alias:'move'];
var p1,p2:Pchar;
i:natuint;
begin
p1:=@source; p2:=@dest;
for i:=1 to count do p2^:=p1^;
end;
function strlen(str:Pchar):natuint;[public,alias:'strlen'];
var res:natuint;
begin
res:=0;
while(str^<>#0) do
begin
inc(str); inc(res);
end;
dec(str,res);
strlen:=res;
end;
function wstrlen(str:PWideChar):natuint;[public,alias:'wstrlen'];
var res:natuint;
begin
res:=0;
while(str^<>#0) do
begin
inc(str); inc(res);
end;
dec(str,res);
wstrlen:=res;
end;
function strcmp(str1,str2:Pchar):natint;[public,alias:'strcmp'];
var i:natint;
begin
i:=0;
while((str1+i)^=(str2+i)^) and ((str1+i)^<>#0) and ((str2+i)^<>#0) do inc(i);
if((str1+i)^>(str2+i)^) then strcmp:=1
else if((str1+i)^<(str2+i)^) then strcmp:=-1
else strcmp:=0;
end;
function Wstrcmp(str1,str2:PwideChar):natint;[public,alias:'Wstrcmp'];
var i:natint;
begin
i:=0;
while((str1+i)^=(str2+i)^) and ((str1+i)^<>#0) and ((str2+i)^<>#0) do inc(i);
if((str1+i)^>(str2+i)^) then Wstrcmp:=1
else if((str1+i)^<(str2+i)^) then Wstrcmp:=-1
else Wstrcmp:=0;
end;
var i:dword;
begin
compheap.heapcount:=0; compheap.heaprest:=maxheap;
sysheap.heapcount:=0; sysheap.heaprest:=maxheap;
end.
Recent
