paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-16 20:19:26 +02:00
Code Issues Packages Projects Releases Wiki Activity
b4d4d4b208
fpc/rtl/inc/generic.inc
florian b4d4d4b208 * compilation fix 
git-svn-id: branches/avr@17021 -
2011-02-26 20:56:36 +00:00

2523 lines
61 KiB
PHP
Raw Blame History

{
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2000 by the Free Pascal development team.
Processor independent implementation for the system unit
(adapted for intel i386.inc file)
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.
**********************************************************************}
{****************************************************************************
Primitives
****************************************************************************}
type
pstring = ^shortstring;
{$ifndef FPC_SYSTEM_HAS_MOVE}
procedure Move(const source;var dest;count:SizeInt);[public, alias: 'FPC_MOVE'];
var
aligncount : sizeint;
pdest,psrc,pend : pbyte;
begin
if (@dest=@source) or (count<=0) then
exit;
if (@dest<@source) or (@source+count<@dest) then
begin
{ Forward Move }
psrc:=@source;
pdest:=@dest;
if (Count>4*sizeof(ptruint)-11)
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
and ((PtrUInt(pdest) and (sizeof(PtrUInt)-1))=(PtrUInt(psrc) and (sizeof(PtrUInt)-1)))
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
then
begin
{ Align on native pointer size }
aligncount:=(PtrUInt(pdest) and (sizeof(PtrUInt)-1));
dec(count,aligncount);
pend:=psrc+aligncount;
while psrc<pend do
begin
pdest^:=psrc^;
inc(pdest);
inc(psrc);
end;
{ use sizeuint typecast to force shr optimization }
pptruint(pend):=pptruint(psrc)+(sizeuint(count) div sizeof(ptruint));
while psrc<pend do
begin
pptruint(pdest)^:=pptruint(psrc)^;
inc(pptruint(pdest));
inc(pptruint(psrc));
end;
count:=count and (sizeof(PtrUInt)-1);
end;
pend:=psrc+count;
while psrc<pend do
begin
pdest^:=psrc^;
inc(pdest);
inc(psrc);
end;
end
else
begin
{ Backward Move }
psrc:=@source+count;
pdest:=@dest+count;
if (Count>4*sizeof(ptruint)-11)
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
and ((PtrUInt(pdest) and (sizeof(PtrUInt)-1))=(PtrUInt(psrc) and (sizeof(PtrUInt)-1)))
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
then
begin
{ Align on native pointer size }
aligncount:=(PtrUInt(pdest) and (sizeof(PtrUInt)-1));
dec(count,aligncount);
pend:=psrc-aligncount;
while psrc>pend do
begin
dec(pdest);
dec(psrc);
pdest^:=psrc^;
end;
{ use sizeuint typecast to force shr optimization }
pptruint(pend):=pptruint(psrc)-(sizeuint(count) div sizeof(ptruint));
while psrc>pend do
begin
dec(pptruint(pdest));
dec(pptruint(psrc));
pptruint(pdest)^:=pptruint(psrc)^;
end;
count:=count and (sizeof(PtrUInt)-1);
end;
pend:=psrc-count;
while psrc>pend do
begin
dec(pdest);
dec(psrc);
pdest^:=psrc^;
end;
end;
end;
{$endif not FPC_SYSTEM_HAS_MOVE}
{$ifndef FPC_SYSTEM_HAS_FILLCHAR}
Procedure FillChar(var x;count:SizeInt;value:byte);
var
pdest,pend : pbyte;
v : ptruint;
begin
if count <= 0 then
exit;
pdest:=@x;
if Count>4*sizeof(ptruint)-1 then
begin
v:=(value shl 8) or value;
v:=(v shl 16) or v;
{$ifdef CPU64}
v:=(v shl 32) or v;
{$endif CPU64}
{ Align on native pointer size }
pend:=pbyte(align(pdest,sizeof(PtrUInt)));
dec(count,pend-pdest);
while pdest<pend do
begin
pdest^:=value;
inc(pdest);
end;
{ use sizeuint typecast to force shr optimization }
pptruint(pend):=pptruint(pdest)+(sizeuint(count) div sizeof(ptruint));
while pdest<pend do
begin
pptruint(pdest)^:=v;
inc(pptruint(pdest));
end;
count:=count and (sizeof(ptruint)-1);
end;
pend:=pdest+count;
while pdest<pend do
begin
pdest^:=value;
inc(pdest);
end;
end;
{$endif FPC_SYSTEM_HAS_FILLCHAR}
{$ifndef FPC_SYSTEM_HAS_FILLWORD}
procedure fillword(var x;count : SizeInt;value : word);
var
aligncount : sizeint;
pdest,pend : pword;
v : ptruint;
begin
if count <= 0 then
exit;
pdest:=@x;
if Count>4*sizeof(ptruint)-1 then
begin
v:=(value shl 16) or value;
{$ifdef CPU64}
v:=(v shl 32) or v;
{$endif CPU64}
{ Align on native pointer size }
aligncount:=(PtrUInt(pdest) and (sizeof(PtrUInt)-1)) shr 1;
dec(count,aligncount);
pend:=pdest+aligncount;
while pdest<pend do
begin
pdest^:=value;
inc(pdest);
end;
{ use sizeuint typecast to force shr optimization }
pptruint(pend):=pptruint(pdest)+((sizeuint(count)*2) div sizeof(ptruint));
while pdest<pend do
begin
pptruint(pdest)^:=v;
inc(pptruint(pdest));
end;
count:=((count*2) and (sizeof(ptruint)-1)) shr 1;
end;
pend:=pdest+count;
while pdest<pend do
begin
pdest^:=value;
inc(pdest);
end;
end;
{$endif not FPC_SYSTEM_HAS_FILLWORD}
{$ifndef FPC_SYSTEM_HAS_FILLDWORD}
procedure filldword(var x;count : SizeInt;value : dword);
var
aligncount : sizeint;
pdest,pend : pdword;
v : ptruint;
begin
if count <= 0 then
exit;
pdest:=@x;
if Count>4*sizeof(ptruint)-1 then
begin
v:=value;
{$ifdef CPU64}
v:=(v shl 32) or v;
{$endif CPU64}
{ Align on native pointer size }
aligncount:=(PtrUInt(pdest) and (sizeof(PtrUInt)-1)) shr 2;
dec(count,aligncount);
pend:=pdest+aligncount;
while pdest<pend do
begin
pdest^:=value;
inc(pdest);
end;
{ use sizeuint typecast to force shr optimization }
pptruint(pend):=pptruint(pdest)+((sizeuint(count)*4) div sizeof(ptruint));
while pdest<pend do
begin
pptruint(pdest)^:=v;
inc(pptruint(pdest));
end;
count:=((count*4) and (sizeof(ptruint)-1)) shr 2;
end;
pend:=pdest+count;
while pdest<pend do
begin
pdest^:=value;
inc(pdest);
end;
end;
{$endif FPC_SYSTEM_HAS_FILLDWORD}
{$ifndef FPC_SYSTEM_HAS_FILLQWORD}
procedure fillqword(var x;count : SizeInt;value : qword);
var
pdest,pend : pqword;
begin
if count <= 0 then
exit;
pdest:=@x;
pend:=pdest+count;
while pdest<pend do
begin
pdest^:=value;
inc(pdest);
end;
end;
{$endif FPC_SYSTEM_HAS_FILLQWORD}
{$ifndef FPC_SYSTEM_HAS_INDEXBYTE}
function IndexByte(Const buf;len:SizeInt;b:byte):SizeInt;
var
psrc,pend : pbyte;
begin
psrc:=@buf;
{ simulate assembler implementations behaviour, which is expected }
{ fpc_pchar_to_ansistr in astrings.inc }
if (len < 0) or
(psrc+len < psrc) then
pend:=pbyte(high(PtrUInt)-sizeof(byte))
else
pend:=psrc+len;
while (psrc<pend) do
begin
if psrc^=b then
begin
result:=psrc-pbyte(@buf);
exit;
end;
inc(psrc);
end;
result:=-1;
end;
{$endif not FPC_SYSTEM_HAS_INDEXBYTE}
{$ifndef FPC_SYSTEM_HAS_INDEXWORD}
function Indexword(Const buf;len:SizeInt;b:word):SizeInt;
var
psrc,pend : pword;
begin
psrc:=@buf;
{ simulate assembler implementations behaviour, which is expected }
{ fpc_pchar_to_ansistr in astrings.inc }
if (len < 0) or
{ is this ever true? }
(len > high(PtrInt)) or
(psrc+len < psrc) then
pend:=pword(high(PtrUInt)-sizeof(word))
else
pend:=psrc+len;
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
if (ptruint(psrc) mod 2)<>0 then
while psrc<pend do
begin
if unaligned(psrc^)=b then
begin
result:=psrc-pword(@buf);
exit;
end;
inc(psrc);
end
else
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
while psrc<pend do
begin
if psrc^=b then
begin
result:=psrc-pword(@buf);
exit;
end;
inc(psrc);
end;
result:=-1;
end;
{$endif not FPC_SYSTEM_HAS_INDEXWORD}
{$ifndef FPC_SYSTEM_HAS_INDEXDWORD}
function IndexDWord(Const buf;len:SizeInt;b:DWord):SizeInt;
var
psrc,pend : pdword;
begin
psrc:=@buf;
{ simulate assembler implementations behaviour, which is expected }
{ fpc_pchar_to_ansistr in astrings.inc }
if (len < 0) or
(len > high(PtrInt) div 2) or
(psrc+len < psrc) then
pend:=pdword(high(PtrUInt)-sizeof(dword))
else
pend:=psrc+len;
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
if (ptruint(psrc) mod 4)<>0 then
while psrc<pend do
begin
if unaligned(psrc^)=b then
begin
result:=psrc-pdword(@buf);
exit;
end;
inc(psrc);
end
else
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
while psrc<pend do
begin
if psrc^=b then
begin
result:=psrc-pdword(@buf);
exit;
end;
inc(psrc);
end;
result:=-1;
end;
{$endif not FPC_SYSTEM_HAS_INDEXDWORD}
{$ifndef FPC_SYSTEM_HAS_INDEXQWORD}
function IndexQWord(Const buf;len:SizeInt;b:QWord):SizeInt;
var
psrc,pend : pqword;
begin
psrc:=@buf;
{ simulate assembler implementations behaviour, which is expected }
{ fpc_pchar_to_ansistr in astrings.inc }
if (len < 0) or
(len > high(PtrInt) div 4) or
(psrc+len < psrc) then
pend:=pqword(high(PtrUInt)-sizeof(qword))
else
pend:=psrc+len;
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
if (ptruint(psrc) mod 8)<>0 then
while psrc<pend do
begin
if unaligned(psrc^)=b then
begin
result:=psrc-pqword(@buf);
exit;
end;
inc(psrc);
end
else
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
while psrc<pend do
begin
if psrc^=b then
begin
result:=psrc-pqword(@buf);
exit;
end;
inc(psrc);
end;
result:=-1;
end;
{$endif not FPC_SYSTEM_HAS_INDEXQWORD}
{$ifndef FPC_SYSTEM_HAS_COMPAREBYTE}
function CompareByte(Const buf1,buf2;len:SizeInt):SizeInt;
var
aligncount : sizeint;
psrc,pdest,pend : pbyte;
b : ptrint;
begin
b:=0;
psrc:=@buf1;
pdest:=@buf2;
if (len>4*sizeof(ptruint)-1)
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
and ((PtrUInt(pdest) and (sizeof(PtrUInt)-1))=(PtrUInt(psrc) and (sizeof(PtrUInt)-1)))
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
then
begin
{ Align on native pointer size }
aligncount:=(sizeof(PtrUInt)-(PtrUInt(pdest) and (sizeof(PtrUInt)-1))) and (sizeof(PtrUInt)-1);
dec(len,aligncount);
pend:=psrc+aligncount;
while psrc<pend do
begin
b:=(ptrint(psrc^)-ptrint(pdest^));
if b<>0 then
begin
if b<0 then
exit(-1)
else
exit(1);
end;
inc(pdest);
inc(psrc);
end;
{ use sizeuint typecast to force shr optimization }
pptruint(pend):=pptruint(psrc)+(sizeuint(len) div sizeof(ptruint));
len:=len and (sizeof(PtrUInt)-1);
while psrc<pend do
begin
b:=(pptrint(psrc)^-pptrint(pdest)^);
if b<>0 then
begin
len:=sizeof(ptruint);
break;
end;
inc(pptruint(pdest));
inc(pptruint(psrc));
end;
end;
if (psrc+len >= psrc) then
pend:=psrc+len
else
pend:=pbyte(high(ptruint)-1);
while psrc<pend do
begin
b:=(ptrint(psrc^)-ptrint(pdest^));
if b<>0 then
begin
if b<0 then
exit(-1)
else
exit(1);
end;
inc(pdest);
inc(psrc);
end;
result:=0;
end;
{$endif not FPC_SYSTEM_HAS_COMPAREBYTE}
{$ifndef FPC_SYSTEM_HAS_COMPAREWORD}
function CompareWord(Const buf1,buf2;len:SizeInt):SizeInt;
var
aligncount : sizeint;
psrc,pdest,pend : pword;
b : ptrint;
begin
b:=0;
psrc:=@buf1;
pdest:=@buf2;
if (len>4*sizeof(ptruint)-1)
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
and ((PtrUInt(pdest) and (sizeof(PtrUInt)-1))=(PtrUInt(psrc) and (sizeof(PtrUInt)-1)))
and (((PtrUInt(pdest) and 1) or (PtrUInt(psrc) and 1))=0)
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
then
begin
{ Align on native pointer size }
aligncount:=((sizeof(PtrUInt)-(PtrUInt(pdest) and (sizeof(PtrUInt)-1))) and (sizeof(PtrUInt)-1)) shr 1;
dec(len,aligncount);
pend:=psrc+aligncount;
while psrc<pend do
begin
b:=(ptrint(psrc^)-ptrint(pdest^));
if b<>0 then
begin
if b<0 then
exit(-1)
else
exit(1);
end;
inc(pdest);
inc(psrc);
end;
{ use sizeuint typecast to force shr optimization }
pptruint(pend):=pptruint(psrc)+(sizeuint(len)*2 div sizeof(ptruint));
len:=((len*2) and (sizeof(PtrUInt)-1)) shr 1;
while psrc<pend do
begin
b:=(pptrint(psrc)^-pptrint(pdest)^);
if b<>0 then
begin
len:=sizeof(ptruint) shr 1;
break;
end;
inc(pptruint(pdest));
inc(pptruint(psrc));
end;
end;
if (len <= high(ptrint)) and
(psrc+len >= psrc) then
pend:=psrc+len
else
pend:=pword(high(ptruint)-2);
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
if ((PtrUInt(pdest) and 1) or (PtrUInt(psrc) and 1))<>0 then
while psrc<pend do
begin
b:=(ptrint(unaligned(psrc^))-ptrint(unaligned(pdest^)));
if b<>0 then
begin
if b<0 then
exit(-1)
else
exit(1);
end;
inc(pdest);
inc(psrc);
end
else
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
while psrc<pend do
begin
b:=(ptrint(psrc^)-ptrint(pdest^));
if b<>0 then
begin
if b<0 then
exit(-1)
else
exit(1);
end;
inc(pdest);
inc(psrc);
end;
result:=0;
end;
{$endif not FPC_SYSTEM_HAS_COMPAREWORD}
{$ifndef FPC_SYSTEM_HAS_COMPAREDWORD}
function CompareDWord(Const buf1,buf2;len:SizeInt):SizeInt;
var
aligncount : sizeint;
psrc,pdest,pend : pdword;
begin
psrc:=@buf1;
pdest:=@buf2;
if (len>4*sizeof(ptruint)-11)
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
and (((PtrUInt(pdest) and 3) or (PtrUInt(psrc) and 3))=0)
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
then
begin
{ Align on native pointer size }
aligncount:=((sizeof(PtrUInt)-(PtrUInt(pdest) and (sizeof(PtrUInt)-1))) and (sizeof(PtrUInt)-1)) shr 2;
dec(len,aligncount);
pend:=psrc+aligncount;
while psrc<pend do
begin
if psrc^<>pdest^ then
if psrc^>pdest^ then
exit(1)
else
exit(-1);
inc(pdest);
inc(psrc);
end;
{ use sizeuint typecast to force shr optimization }
pptruint(pend):=pptruint(psrc)+(sizeuint(len)*4 div sizeof(ptruint));
len:=((len*4) and (sizeof(PtrUInt)-1)) shr 2;
while psrc<pend do
begin
if pptrint(psrc)^<>pptrint(pdest)^ then
begin
len:=sizeof(ptruint) shr 2;
break;
end;
inc(pptruint(pdest));
inc(pptruint(psrc));
end;
end;
if (len <= high(ptrint) div 2) and
(psrc+len >= psrc) then
pend:=psrc+len
else
pend:=pdword(high(ptruint)-4);
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
if ((PtrUInt(pdest) and 3) or (PtrUInt(psrc) and 3))<>0 then
while psrc<pend do
begin
if unaligned(psrc^)<>unaligned(pdest^) then
if unaligned(psrc^)>unaligned(pdest^) then
exit(1)
else
exit(-1);
inc(pdest);
inc(psrc);
end
else
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
while psrc<pend do
begin
if psrc^<>pdest^ then
if psrc^>pdest^ then
exit(1)
else
exit(-1);
inc(pdest);
inc(psrc);
end;
result:=0;
end;
{$endif ndef FPC_SYSTEM_HAS_COMPAREDWORD}
{$ifndef FPC_SYSTEM_HAS_MOVECHAR0}
procedure MoveChar0(Const buf1;var buf2;len:SizeInt);
var
I : SizeInt;
begin
if Len = 0 then
exit;
I:=IndexByte(Buf1,Len,0);
if I<>-1 then
Move(Buf1,Buf2,I)
else
Move(Buf1,Buf2,len);
end;
{$endif ndef FPC_SYSTEM_HAS_MOVECHAR0}
{$ifndef FPC_SYSTEM_HAS_INDEXCHAR0}
function IndexChar0(Const buf;len:SizeInt;b:Char):SizeInt;
var
psrc,pend : pbyte;
begin
psrc:=@buf;
{ simulate assembler implementations behaviour, which is expected }
{ fpc_pchar_to_ansistr in astrings.inc }
if (len < 0) then
pend:=pbyte(high(PtrUInt)-sizeof(byte))
else
pend:=psrc+len;
while (psrc<pend) and (psrc^<>0) do
begin
if (psrc^=byte(b)) then
begin
result:=psrc-pbyte(@buf);
exit;
end;
inc(psrc);
end;
result:=-1;
end;
{$endif ndef FPC_SYSTEM_HAS_INDEXCHAR0}
{$ifndef FPC_SYSTEM_HAS_COMPARECHAR0}
function CompareChar0(Const buf1,buf2;len:SizeInt):SizeInt;
var
psrc,pdest,pend : pbyte;
b : ptrint;
begin
b:=0;
psrc:=@buf1;
pdest:=@buf2;
pend:=psrc+len;
while psrc<pend do
begin
b:=(ptrint(psrc^)-ptrint(pdest^));
if b<0 then
exit(-1)
else if b>0 then
exit(1);
if (psrc^=0) or (pdest^=0) then
exit(0);
inc(pdest);
inc(psrc);
end;
result:=0;
end;
{$endif not FPC_SYSTEM_HAS_COMPARECHAR0}
{****************************************************************************
Object Helpers
****************************************************************************}
{$ifdef FPC_HAS_FEATURE_OBJECTS}
{$ifndef FPC_SYSTEM_HAS_FPC_HELP_CONSTRUCTOR}
{ Note: _vmt will be reset to -1 when memory is allocated,
this is needed for fpc_help_fail }
function fpc_help_constructor(_self:pointer;var _vmt:pointer;_vmt_pos:cardinal):pointer;[public,alias:'FPC_HELP_CONSTRUCTOR'];compilerproc;
type
ppointer = ^pointer;
pvmt = ^tvmt;
tvmt=packed record
size,msize:ptruint;
parent:pointer;
end;
var
vmtcopy : pointer;
begin
{ Inherited call? }
if _vmt=nil then
begin
fpc_help_constructor:=_self;
exit;
end;
vmtcopy:=_vmt;
if (_self=nil) and
(pvmt(_vmt)^.size>0) then
begin
getmem(_self,pvmt(_vmt)^.size);
{ reset vmt needed for fail }
_vmt:=pointer(-1);
end;
if _self<>nil then
begin
fillchar(_self^,pvmt(vmtcopy)^.size,#0);
ppointer(_self+_vmt_pos)^:=vmtcopy;
end;
fpc_help_constructor:=_self;
end;
{$endif FPC_SYSTEM_HAS_FPC_HELP_CONSTRUCTOR}
{$ifndef FPC_SYSTEM_HAS_FPC_HELP_DESTRUCTOR}
{ Note: _self will not be reset, the compiler has to generate the reset }
procedure fpc_help_destructor(_self,_vmt:pointer;vmt_pos:cardinal);[public,alias:'FPC_HELP_DESTRUCTOR']; compilerproc;
type
ppointer = ^pointer;
pvmt = ^tvmt;
tvmt = packed record
size,msize : ptruint;
parent : pointer;
end;
begin
{ already released? }
if (_self=nil) or
(_vmt=nil) or
(ppointer(_self+vmt_pos)^=nil) then
exit;
if (pvmt(ppointer(_self+vmt_pos)^)^.size=0) or
(pvmt(ppointer(_self+vmt_pos)^)^.size+pvmt(ppointer(_self+vmt_pos)^)^.msize<>0) then
RunError(210);
{ reset vmt to nil for protection }
ppointer(_self+vmt_pos)^:=nil;
freemem(_self);
end;
{$endif FPC_SYSTEM_HAS_FPC_HELP_DESTRUCTOR}
{$ifndef FPC_SYSTEM_HAS_FPC_HELP_FAIL}
{ Note: _self will not be reset, the compiler has to generate the reset }
procedure fpc_help_fail(_self:pointer;var _vmt:pointer;vmt_pos:cardinal);[public,alias:'FPC_HELP_FAIL'];compilerproc;
begin
if (_self=nil) or (_vmt=nil) then
exit;
{ vmt=$ffffffff when memory was allocated }
if ptruint(_vmt)=high(ptruint) then
begin
if (_self=nil) or (ppointer(_self+vmt_pos)^=nil) then
HandleError(210)
else
begin
ppointer(_self+vmt_pos)^:=nil;
freemem(_self);
{ reset _vmt to nil so it will not be freed a
second time }
_vmt:=nil;
end;
end
else
ppointer(_self+vmt_pos)^:=nil;
end;
{$endif FPC_SYSTEM_HAS_FPC_HELP_FAIL}
{$ifndef FPC_SYSTEM_HAS_FPC_CHECK_OBJECT}
procedure fpc_check_object(_vmt : pointer); [public,alias:'FPC_CHECK_OBJECT']; compilerproc;
type
pvmt = ^tvmt;
tvmt = packed record
size,msize : ptruint;
parent : pointer;
end;
begin
if (_vmt=nil) or
(pvmt(_vmt)^.size=0) or
(pvmt(_vmt)^.size+pvmt(_vmt)^.msize<>0) then
RunError(210);
end;
{$endif ndef FPC_SYSTEM_HAS_FPC_CHECK_OBJECT}
{$ifndef FPC_SYSTEM_HAS_FPC_CHECK_OBJECT_EXT}
{ checks for a correct vmt pointer }
{ deeper check to see if the current object is }
{ really related to the true }
procedure fpc_check_object_ext(vmt, expvmt : pointer); [public,alias:'FPC_CHECK_OBJECT_EXT']; compilerproc;
type
pvmt = ^tvmt;
tvmt = packed record
size,msize : ptruint;
parent : pointer;
end;
begin
if (vmt=nil) or
(pvmt(vmt)^.size=0) or
(pvmt(vmt)^.size+pvmt(vmt)^.msize<>0) then
RunError(210);
while assigned(vmt) do
if vmt=expvmt then
exit
else
vmt:=pvmt(vmt)^.parent;
RunError(219);
end;
{$endif not FPC_SYSTEM_HAS_FPC_CHECK_OBJECT_EXT}
{$endif FPC_HAS_FEATURE_OBJECTS}
{****************************************************************************
String
****************************************************************************}
{$ifndef FPC_SYSTEM_HAS_FPC_SHORTSTR_ASSIGN}
{$ifndef FPC_STRTOSHORTSTRINGPROC}
function fpc_shortstr_to_shortstr(len:longint;const sstr:shortstring): shortstring;[public,alias:'FPC_SHORTSTR_TO_SHORTSTR']; compilerproc;
var
slen : byte;
begin
slen:=length(sstr);
if slen<len then
len:=slen;
move(sstr[0],result[0],len+1);
if slen>len then
result[0]:=chr(len);
end;
{$else FPC_STRTOSHORTSTRINGPROC}
procedure fpc_shortstr_to_shortstr(out res:shortstring; const sstr: shortstring);[public,alias:'FPC_SHORTSTR_TO_SHORTSTR']; compilerproc;
var
slen : byte;
begin
slen:=length(sstr);
if slen>high(res) then
slen:=high(res);
move(sstr[0],res[0],slen+1);
res[0]:=chr(slen);
end;
{$endif FPC_STRTOSHORTSTRINGPROC}
procedure fpc_shortstr_assign(len:longint;sstr,dstr:pointer);[public,alias:'FPC_SHORTSTR_ASSIGN']; {$ifdef HAS_COMPILER_PROC} compilerproc; {$endif}
var
slen : byte;
type
pstring = ^string;
begin
slen:=length(pstring(sstr)^);
if slen<len then
len:=slen;
move(sstr^,dstr^,len+1);
if slen>len then
pchar(dstr)^:=chr(len);
end;
{$endif ndef FPC_SYSTEM_HAS_FPC_SHORTSTR_ASSIGN}
{$ifndef FPC_SYSTEM_HAS_FPC_SHORTSTR_CONCAT}
{$ifndef STR_CONCAT_PROCS}
function fpc_shortstr_concat(const s1,s2:shortstring): shortstring;[public,alias:'FPC_SHORTSTR_CONCAT']; compilerproc;
var
s1l, s2l : byte;
begin
s1l:=length(s1);
s2l:=length(s2);
if s1l+s2l>255 then
s2l:=255-s1l;
move(s1[1],fpc_shortstr_concat[1],s1l);
move(s2[1],fpc_shortstr_concat[s1l+1],s2l);
fpc_shortstr_concat[0]:=chr(s1l+s2l);
end;
{$else STR_CONCAT_PROCS}
procedure fpc_shortstr_concat(var dests:shortstring;const s1,s2:shortstring);compilerproc;
var
s1l, s2l : longint;
begin
s1l:=length(s1);
s2l:=length(s2);
if s1l+s2l>high(dests) then
s2l:=high(dests)-s1l;
if @dests=@s1 then
move(s2[1],dests[s1l+1],s2l)
else
if @dests=@s2 then
begin
move(dests[1],dests[s1l+1],s2l);
move(s1[1],dests[1],s1l);
end
else
begin
move(s1[1],dests[1],s1l);
move(s2[1],dests[s1l+1],s2l);
end;
dests[0]:=chr(s1l+s2l);
end;
procedure fpc_shortstr_concat_multi(var dests:shortstring;const sarr:array of pshortstring);compilerproc;
var
s2l : byte;
LowStart,i,
Len : longint;
pc : pchar;
needtemp : boolean;
tmpstr : shortstring;
p,pdest : pshortstring;
begin
if high(sarr)=0 then
begin
DestS:='';
exit;
end;
lowstart:=low(sarr);
if Pointer(@DestS)=Pointer(sarr[lowstart]) then
inc(lowstart);
{ Check for another reuse, then we can't use
the append optimization and need to use a temp }
needtemp:=false;
for i:=lowstart to high(sarr) do
begin
if Pointer(@DestS)=Pointer(sarr[i]) then
begin
needtemp:=true;
break;
end;
end;
if needtemp then
begin
lowstart:=low(sarr);
tmpstr:='';
pdest:=@tmpstr
end
else
begin
{ Start with empty DestS if we start with concatting
the first array element }
if lowstart=low(sarr) then
DestS:='';
pdest:=@DestS;
end;
{ Concat all strings, except the string we already
copied in DestS }
Len:=length(pdest^);
pc:=@pdest^[1+Length(pdest^)];
for i:=lowstart to high(sarr) do
begin
p:=sarr[i];
if assigned(p) then
begin
s2l:=length(p^);
if Len+s2l>high(dests) then
s2l:=high(dests)-Len;
Move(p^[1],pc^,s2l);
inc(pc,s2l);
inc(Len,s2l);
end;
end;
pdest^[0]:=Chr(Len);
if needtemp then
DestS:=TmpStr;
end;
{$endif STR_CONCAT_PROCS}
{$endif ndef FPC_SYSTEM_HAS_FPC_SHORTSTR_CONCAT}
{$ifndef FPC_SYSTEM_HAS_FPC_SHORTSTR_APPEND_SHORTSTR}
procedure fpc_shortstr_append_shortstr(var s1:shortstring;const s2:shortstring);compilerproc;
[public,alias:'FPC_SHORTSTR_APPEND_SHORTSTR'];
var
s1l, s2l : integer;
begin
s1l:=length(s1);
s2l:=length(s2);
if s1l+s2l>high(s1) then
s2l:=high(s1)-s1l;
move(s2[1],s1[s1l+1],s2l);
s1[0]:=chr(s1l+s2l);
end;
{$endif ndef FPC_SYSTEM_HAS_FPC_SHORTSTR_APPEND_SHORTSTR}
{$ifndef FPC_SYSTEM_HAS_FPC_SHORTSTR_COMPARE}
function fpc_shortstr_compare(const left,right:shortstring) : longint;[public,alias:'FPC_SHORTSTR_COMPARE']; compilerproc;
var
s1,s2,max,i : byte;
d : longint;
begin
s1:=length(left);
s2:=length(right);
if s1<s2 then
max:=s1
else
max:=s2;
for i:=1 to max do
begin
d:=byte(left[i])-byte(right[i]);
if d>0 then
exit(1)
else if d<0 then
exit(-1);
end;
if s1>s2 then
exit(1)
else if s1<s2 then
exit(-1)
else
exit(0);
end;
{$endif ndef FPC_SYSTEM_HAS_FPC_SHORTSTR_COMPARE}
{$ifndef FPC_SYSTEM_HAS_FPC_SHORTSTR_COMPARE_EQUAL}
function fpc_shortstr_compare_equal(const left,right:shortstring): longint; [public,alias:'FPC_SHORTSTR_COMPARE_EQUAL']; compilerproc;
begin
Result := longint(left[0]) - longint(right[0]);
if Result = 0 then
Result := CompareByte(left[1],right[1], longint(left[0]));
end;
{$endif ndef FPC_SYSTEM_HAS_FPC_SHORTSTR_COMPARE_EQUAL}
{$ifndef FPC_SYSTEM_HAS_FPC_PCHAR_TO_SHORTSTR}
{$ifndef FPC_STRTOSHORTSTRINGPROC}
function fpc_pchar_to_shortstr(p:pchar):shortstring;[public,alias:'FPC_PCHAR_TO_SHORTSTR']; compilerproc;
var
l : longint;
s: shortstring;
begin
if p=nil then
l:=0
else
l:=strlen(p);
if l>255 then
l:=255;
if l>0 then
move(p^,s[1],l);
s[0]:=chr(l);
fpc_pchar_to_shortstr := s;
end;
{$else FPC_STRTOSHORTSTRINGPROC}
procedure fpc_pchar_to_shortstr(out res : shortstring;p:pchar);[public,alias:'FPC_PCHAR_TO_SHORTSTR']; compilerproc;
var
l : longint;
s: shortstring;
begin
if p=nil then
l:=0
else
l:=strlen(p);
if l>high(res) then
l:=high(res);
if l>0 then
move(p^,s[1],l);
s[0]:=chr(l);
res:=s;
end;
{$endif FPC_STRTOSHORTSTRINGPROC}
{$endif ndef FPC_SYSTEM_HAS_FPC_PCHAR_TO_SHORTSTR}
{$ifndef FPC_STRTOSHORTSTRINGPROC}
{ also define alias which can be used inside the system unit }
function fpc_pchar_to_shortstr(p:pchar):shortstring;[external name 'FPC_PCHAR_TO_SHORTSTR'];
{$else FPC_STRTOSHORTSTRINGPROC}
{ also define alias which can be used inside the system unit }
procedure fpc_pchar_to_shortstr(out res : shortstring;p:pchar);[external name 'FPC_PCHAR_TO_SHORTSTR'];
{$endif FPC_STRTOSHORTSTRINGPROC}
function strpas(p:pchar):shortstring;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
{$ifndef FPC_STRTOSHORTSTRINGPROC}
result:=fpc_pchar_to_shortstr(p);
{$else FPC_STRTOSHORTSTRINGPROC}
fpc_pchar_to_shortstr(result,p);
{$endif FPC_STRTOSHORTSTRINGPROC}
end;
{$ifndef FPC_SYSTEM_HAS_FPC_CHARARRAY_TO_SHORTSTR}
{$ifndef FPC_STRTOSHORTSTRINGPROC}
function fpc_chararray_to_shortstr(const arr: array of char; zerobased: boolean = true):shortstring;[public,alias:'FPC_CHARARRAY_TO_SHORTSTR']; compilerproc;
var
l: longint;
index: longint;
len: byte;
begin
l := high(arr)+1;
if l>=256 then
l:=255
else if l<0 then
l:=0;
if (zerobased) then
begin
index:=IndexByte(arr[0],l,0);
if (index < 0) then
len := l
else
len := index;
end
else
len := l;
move(arr[0],fpc_chararray_to_shortstr[1],len);
fpc_chararray_to_shortstr[0]:=chr(len);
end;
{$else FPC_STRTOSHORTSTRINGPROC}
procedure fpc_chararray_to_shortstr(out res : shortstring;const arr: array of char; zerobased: boolean = true);[public,alias:'FPC_CHARARRAY_TO_SHORTSTR']; compilerproc;
var
l: longint;
index: longint;
len: byte;
begin
l:=high(arr)+1;
if l>=high(res)+1 then
l:=high(res)
else if l<0 then
l:=0;
if zerobased then
begin
index:=IndexByte(arr[0],l,0);
if index<0 then
len:=l
else
len:=index;
end
else
len:=l;
move(arr[0],res[1],len);
res[0]:=chr(len);
end;
{$endif FPC_STRTOSHORTSTRINGPROC}
{$endif ndef FPC_SYSTEM_HAS_FPC_CHARARRAY_TO_SHORTSTR}
{$ifndef FPC_SYSTEM_HAS_FPC_SHORTSTR_TO_CHARARRAY}
{$ifndef FPC_STRTOCHARARRAYPROC}
{ inside the compiler, the resulttype is modified to that of the actual }
{ chararray we're converting to (JM) }
function fpc_shortstr_to_chararray(arraysize: longint; const src: ShortString): fpc_big_chararray;[public,alias: 'FPC_SHORTSTR_TO_CHARARRAY']; compilerproc;
var
len: longint;
begin
len := length(src);
if len > arraysize then
len := arraysize;
{$r-}
{ make sure we don't access char 1 if length is 0 (JM) }
if len > 0 then
move(src[1],fpc_shortstr_to_chararray[0],len);
fillchar(fpc_shortstr_to_chararray[len],arraysize-len,0);
{$ifdef RangeCheckWasOn}
{$r+}
{$endif}
end;
{$else ndef FPC_STRTOCHARARRAYPROC}
procedure fpc_shortstr_to_chararray(out res: array of char; const src: ShortString); compilerproc;
var
len: longint;
begin
len := length(src);
if len > length(res) then
len := length(res);
{$r-}
{ make sure we don't access char 1 if length is 0 (JM) }
if len > 0 then
move(src[1],res[0],len);
fillchar(res[len],length(res)-len,0);
{$ifdef RangeCheckWasOn}
{$r+}
{$endif}
end;
{$endif ndef FPC_STRTOCHARARRAYPROC}
{$endif FPC_SYSTEM_HAS_FPC_SHORTSTR_TO_CHARARRAY}
{$ifndef FPC_SYSTEM_HAS_FPC_PCHAR_LENGTH}
function fpc_pchar_length(p:pchar):longint;[public,alias:'FPC_PCHAR_LENGTH']; compilerproc;
var i : longint;
begin
i:=0;
if assigned(p) then
while p[i]<>#0 do
inc(i);
exit(i);
end;
{$endif ndef FPC_SYSTEM_HAS_FPC_PCHAR_LENGTH}
{$ifndef FPC_SYSTEM_HAS_FPC_PWIDECHAR_LENGTH}
function fpc_pwidechar_length(p:pwidechar):longint;[public,alias:'FPC_PWIDECHAR_LENGTH']; compilerproc;
var i : longint;
begin
i:=0;
while p[i]<>#0 do inc(i);
exit(i);
end;
{$endif ndef FPC_SYSTEM_HAS_FPC_PWIDECHAR_LENGTH}
{****************************************************************************
Caller/StackFrame Helpers
****************************************************************************}
{$ifndef FPC_SYSTEM_HAS_GET_FRAME}
{_$error Get_frame must be defined for each processor }
{$endif ndef FPC_SYSTEM_HAS_GET_FRAME}
{$ifndef FPC_SYSTEM_HAS_GET_CALLER_ADDR}
{_$error Get_caller_addr must be defined for each processor }
{$endif ndef FPC_SYSTEM_HAS_GET_CALLER_ADDR}
{$ifndef FPC_SYSTEM_HAS_GET_CALLER_FRAME}
{_$error Get_caller_frame must be defined for each processor }
{$endif ndef FPC_SYSTEM_HAS_GET_CALLER_FRAME}
{****************************************************************************
Math
****************************************************************************}
{****************************************************************************
Software multiplication
****************************************************************************}
{$ifndef FPC_SYSTEM_HAS_MUL_INTEGER}
function fpc_mul_integer(f1,f2 : integer;checkoverflow : boolean) : integer;[public,alias: 'FPC_MUL_INTEGER']; compilerproc;
var
sign : boolean;
q1,q2,q3 : word;
begin
begin
sign:=false;
if f1<0 then
begin
sign:=not(sign);
q1:=word(-f1);
end
else
q1:=f1;
if f2<0 then
begin
sign:=not(sign);
q2:=word(-f2);
end
else
q2:=f2;
{ the q1*q2 is coded as call to mulqword }
q3:=q1*q2;
if checkoverflow and (q1 <> 0) and (q2 <>0) and
((q1>q3) or (q2>q3) or
{ the bit 63 can be only set if we have $8000 }
{ and sign is true }
(q3 shr 15<>0) and
((q3<>word(word(1) shl 15)) or not(sign))
) then
HandleErrorFrame(215,get_frame);
if sign then
fpc_mul_integer:=-q3
else
fpc_mul_integer:=q3;
end;
end;
{$endif FPC_SYSTEM_HAS_MUL_INTEGER}
{$ifndef FPC_SYSTEM_HAS_MUL_WORD}
function fpc_mul_word(f1,f2 : word;checkoverflow : boolean) : qword;[public,alias: 'FPC_MUL_WORD']; compilerproc;
var
_f1,bitpos : word;
b : byte;
f1overflowed : boolean;
begin
fpc_mul_word:=0;
bitpos:=1;
f1overflowed:=false;
for b:=0 to 15 do
begin
if (f2 and bitpos)<>0 then
begin
_f1:=fpc_mul_word;
fpc_mul_word:=fpc_mul_word+f1;
{ if one of the operands is greater than the result an
overflow occurs }
if checkoverflow and (f1overflowed or ((_f1<>0) and (f1<>0) and
((_f1>fpc_mul_word) or (f1>fpc_mul_word)))) then
HandleErrorFrame(215,get_frame);
end;
{ when bootstrapping, we forget about overflow checking for qword :) }
f1overflowed:=f1overflowed or ((f1 and (1 shl 15))<>0);
f1:=f1 shl 1;
bitpos:=bitpos shl 1;
end;
end;
{$endif FPC_SYSTEM_HAS_MUL_WORD}
{$ifndef FPC_SYSTEM_HAS_MUL_LONGINT}
function fpc_mul_longint(f1,f2 : longint;checkoverflow : boolean) : longint;[public,alias: 'FPC_MUL_LONGINT']; compilerproc;
var
sign : boolean;
q1,q2,q3 : dword;
begin
begin
sign:=false;
if f1<0 then
begin
sign:=not(sign);
q1:=dword(-f1);
end
else
q1:=f1;
if f2<0 then
begin
sign:=not(sign);
q2:=dword(-f2);
end
else
q2:=f2;
{ the q1*q2 is coded as call to mulqword }
q3:=q1*q2;
if checkoverflow and (q1 <> 0) and (q2 <>0) and
((q1>q3) or (q2>q3) or
{ the bit 31 can be only set if we have $8000 0000 }
{ and sign is true }
(q3 shr 15<>0) and
((q3<>dword(dword(1) shl 31)) or not(sign))
) then
HandleErrorFrame(215,get_frame);
if sign then
fpc_mul_longint:=-q3
else
fpc_mul_longint:=q3;
end;
end;
{$endif FPC_SYSTEM_HAS_MUL_INTEGER}
{$ifndef FPC_SYSTEM_HAS_MUL_DWORD}
{ multiplies two dwords
the longbool for checkoverflow avoids a misaligned stack
}
function fpc_mul_dword(f1,f2 : dword;checkoverflow : boolean) : qword;[public,alias: 'FPC_MUL_DWORD']; compilerproc;
var
_f1,bitpos : dword;
b : byte;
f1overflowed : boolean;
begin
fpc_mul_dword:=0;
bitpos:=1;
f1overflowed:=false;
for b:=0 to 31 do
begin
if (f2 and bitpos)<>0 then
begin
_f1:=fpc_mul_dword;
fpc_mul_dword:=fpc_mul_dword+f1;
{ if one of the operands is greater than the result an
overflow occurs }
if checkoverflow and (f1overflowed or ((_f1<>0) and (f1<>0) and
((_f1>fpc_mul_dword) or (f1>fpc_mul_dword)))) then
HandleErrorFrame(215,get_frame);
end;
{ when bootstrapping, we forget about overflow checking for qword :) }
f1overflowed:=f1overflowed or ((f1 and (1 shl 31))<>0);
f1:=f1 shl 1;
bitpos:=bitpos shl 1;
end;
end;
{$endif FPC_SYSTEM_HAS_MUL_DWORD}
{****************************************************************************
Software longint/dword division
****************************************************************************}
{$ifdef FPC_INCLUDE_SOFTWARE_MOD_DIV}
function count_leading_zeros_32bit(l : longint) : longint;
var
i : longint;
begin
for i:=0 to 31 do
begin
if (l and (longint($80000000) shr i))<>0 then
begin
result:=i;
exit;
end;
end;
result:=i;
end;
{$ifndef FPC_SYSTEM_HAS_DIV_DWORD}
function fpc_div_dword(n,z : dword) : dword; [public,alias: 'FPC_DIV_DWORD']; compilerproc;
var
shift,lzz,lzn : longint;
begin
result:=0;
if n=0 then
HandleErrorFrame(200,get_frame);
lzz:=count_leading_zeros_32bit(z);
lzn:=count_leading_zeros_32bit(n);
{ if the denominator contains less zeros
then the numerator
the d is greater than the n }
if lzn<lzz then
exit;
shift:=lzn-lzz;
n:=n shl shift;
repeat
if z>=n then
begin
z:=z-n;
result:=result+dword(1 shl shift);
end;
dec(shift);
n:=n shr 1;
until shift<0;
end;
{$endif FPC_SYSTEM_HAS_DIV_DWORD}
{$ifndef FPC_SYSTEM_HAS_MOD_DWORD}
function fpc_mod_dword(n,z : dword) : dword; [public,alias: 'FPC_MOD_DWORD']; compilerproc;
var
shift,lzz,lzn : longint;
begin
result:=0;
if n=0 then
HandleErrorFrame(200,get_frame);
lzz:=count_leading_zeros_32bit(z);
lzn:=count_leading_zeros_32bit(n);
{ if the denominator contains less zeros
then the numerator
the d is greater than the n }
if lzn<lzz then
begin
result:=z;
exit;
end;
shift:=lzn-lzz;
n:=n shl shift;
repeat
if z>=n then
z:=z-n;
dec(shift);
n:=n shr 1;
until shift<0;
result:=z;
end;
{$endif FPC_SYSTEM_HAS_MOD_DWORD}
{$ifndef FPC_SYSTEM_HAS_DIV_LONGINT}
function fpc_div_longint(n,z : longint) : longint; [public,alias: 'FPC_DIV_LONGINT']; compilerproc;
var
sign : boolean;
d1,d2 : dword;
begin
if n=0 then
HandleErrorFrame(200,get_frame);
sign:=false;
if z<0 then
begin
sign:=not(sign);
d1:=dword(-z);
end
else
d1:=z;
if n<0 then
begin
sign:=not(sign);
d2:=dword(-n);
end
else
d2:=n;
{ the div is coded by the compiler as call to divdword }
if sign then
result:=-(d1 div d2)
else
result:=d1 div d2;
end;
{$endif FPC_SYSTEM_HAS_DIV_LONGINT}
{$ifndef FPC_SYSTEM_HAS_MOD_LONGINT}
function fpc_mod_longint(n,z : longint) : longint; [public,alias: 'FPC_MOD_LONGINT']; compilerproc;
var
signed : boolean;
r,nq,zq : dword;
begin
if n=0 then
HandleErrorFrame(200,get_frame);
nq:=abs(n);
if z<0 then
begin
zq:=dword(-z);
signed:=true;
end
else
begin
zq:=z;
signed:=false;
end;
r:=zq mod nq;
if signed then
result:=-longint(r)
else
result:=r;
end;
{$endif FPC_SYSTEM_HAS_MOD_LONGINT}
{$endif FPC_INCLUDE_SOFTWARE_MOD_DIV}
{****************************************************************************}
{$ifndef FPC_SYSTEM_HAS_ABS_LONGINT}
function abs(l:longint):longint;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
if l<0 then
abs:=-l
else
abs:=l;
end;
{$endif not FPC_SYSTEM_HAS_ABS_LONGINT}
{$ifndef FPC_SYSTEM_HAS_ODD_LONGINT}
function odd(l:longint):boolean;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
odd:=boolean(l and 1);
end;
{$endif ndef FPC_SYSTEM_HAS_ODD_LONGINT}
{$ifndef FPC_SYSTEM_HAS_ODD_LONGWORD}
function odd(l:longword):boolean;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
odd:=boolean(l and 1);
end;
{$endif ndef FPC_SYSTEM_HAS_ODD_LONGWORD}
{$ifndef FPC_SYSTEM_HAS_ODD_INT64}
function odd(l:int64):boolean;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
odd:=boolean(longint(l) and 1);
end;
{$endif ndef FPC_SYSTEM_HAS_ODD_INT64}
{$ifndef FPC_SYSTEM_HAS_ODD_QWORD}
function odd(l:qword):boolean;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
odd:=boolean(longint(l) and 1);
end;
{$endif ndef FPC_SYSTEM_HAS_ODD_QWORD}
{$ifndef FPC_SYSTEM_HAS_SQR_LONGINT}
function sqr(l:longint):longint;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
sqr:=l*l;
end;
{$endif ndef FPC_SYSTEM_HAS_SQR_LONGINT}
{$ifndef FPC_SYSTEM_HAS_ABS_INT64}
function abs(l: Int64): Int64;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
if l < 0 then
abs := -l
else
abs := l;
end;
{$endif ndef FPC_SYSTEM_HAS_ABS_INT64}
{$ifndef FPC_SYSTEM_HAS_SQR_INT64}
function sqr(l: Int64): Int64;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
sqr := l*l;
end;
{$endif ndef FPC_SYSTEM_HAS_SQR_INT64}
{$ifndef FPC_SYSTEM_HAS_SQR_QWORD}
function sqr(l: QWord): QWord;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
sqr := l*l;
end;
{$endif ndef FPC_SYSTEM_HAS_SQR_INT64}
{$ifdef CPU16}
{$ifndef FPC_SYSTEM_HAS_DECLOCKED_SMALLINT}
function declocked(var l:smallint):boolean;
begin
Dec(l);
declocked:=(l=0);
end;
{$endif FPC_SYSTEM_HAS_DECLOCKED_SMALLINT}
{$endif CPU16}
{$ifndef FPC_SYSTEM_HAS_DECLOCKED_LONGINT}
function declocked(var l:longint):boolean;
begin
Dec(l);
declocked:=(l=0);
end;
{$endif FPC_SYSTEM_HAS_DECLOCKED_LONGINT}
{$ifndef FPC_SYSTEM_HAS_DECLOCKED_INT64}
function declocked(var l:int64):boolean;
begin
Dec(l);
declocked:=(l=0);
end;
{$endif FPC_SYSTEM_HAS_DECLOCKED_INT64}
{$ifdef CPU16}
{$ifndef FPC_SYSTEM_HAS_INCLOCKED_SMALLINT}
procedure inclocked(var l:smallint);
begin
Inc(l);
end;
{$endif FPC_SYSTEM_HAS_INCLOCKED_SMALLINT}
{$endif CPU16}
{$ifndef FPC_SYSTEM_HAS_INCLOCKED_LONGINT}
procedure inclocked(var l:longint);
begin
Inc(l);
end;
{$endif FPC_SYSTEM_HAS_INCLOCKED_LONGINT}
{$ifndef FPC_SYSTEM_HAS_INCLOCKED_INT64}
procedure inclocked(var l:int64);
begin
Inc(l);
end;
{$endif FPC_SYSTEM_HAS_INCLOCKED_INT64}
{$ifndef FPC_SYSTEM_HAS_SPTR}
{_$error Sptr must be defined for each processor }
{$endif ndef FPC_SYSTEM_HAS_SPTR}
function align(addr : PtrUInt;alignment : PtrUInt) : PtrUInt;{$ifdef SYSTEMINLINE}inline;{$endif}
var
tmp: PtrUInt;
begin
tmp:=addr+alignment-1;
result:=tmp-(tmp mod alignment)
end;
function align(addr : Pointer;alignment : PtrUInt) : Pointer;{$ifdef SYSTEMINLINE}inline;{$endif}
var
tmp: PtrUInt;
begin
tmp:=PtrUInt(addr)+alignment-1;
result:=pointer(tmp-(tmp mod alignment));
end;
{****************************************************************************
Str()
****************************************************************************}
{$ifndef FPC_SYSTEM_HAS_INT_STR_LONGINT}
procedure int_str(l:longint;out s:string);
var
m,m1 : longword;
pcstart,
pc2start,
pc,pc2 : pchar;
hs : string[32];
overflow : longint;
begin
pc2start:=@s[1];
pc2:=pc2start;
if (l<0) then
begin
pc2^:='-';
inc(pc2);
m:=longword(-l);
end
else
m:=longword(l);
pcstart:=pchar(@hs[0]);
pc:=pcstart;
repeat
m1:=m div 10;
inc(pc);
pc^:=char(m-(m1*10)+byte('0'));
m:=m1;
until m=0;
overflow:=(pc-pcstart)+(pc2-pc2start)-high(s);
if overflow>0 then
inc(pcstart,overflow);
while (pc>pcstart) do
begin
pc2^:=pc^;
inc(pc2);
dec(pc);
end;
s[0]:=char(pc2-pc2start);
end;
{$endif ndef FPC_SYSTEM_HAS_INT_STR_LONGINT}
{$ifndef FPC_SYSTEM_HAS_INT_STR_LONGWORD}
procedure int_str(l:longword;out s:string);
var
m1 : longword;
pcstart,
pc2start,
pc,pc2 : pchar;
hs : string[32];
overflow : longint;
begin
pc2start:=@s[1];
pc2:=pc2start;
pcstart:=pchar(@hs[0]);
pc:=pcstart;
repeat
inc(pc);
m1:=l div 10;
pc^:=char(l-(m1*10)+byte('0'));
l:=m1;
until l=0;
overflow:=(pc-pcstart)-high(s);
if overflow>0 then
inc(pcstart,overflow);
while (pc>pcstart) do
begin
pc2^:=pc^;
inc(pc2);
dec(pc);
end;
s[0]:=char(pc2-pc2start);
end;
{$endif ndef FPC_SYSTEM_HAS_INT_STR_LONGWORD}
{$ifndef FPC_SYSTEM_HAS_INT_STR_INT64}
procedure int_str(l:int64;out s:string);
var
m,m1 : qword;
pcstart,
pc2start,
pc,pc2 : pchar;
hs : string[32];
overflow : longint;
begin
pc2start:=@s[1];
pc2:=pc2start;
if (l<0) then
begin
pc2^:='-';
inc(pc2);
m:=qword(-l);
end
else
m:=qword(l);
pcstart:=pchar(@hs[0]);
pc:=pcstart;
repeat
m1:=m div 10;
inc(pc);
pc^:=char(m-(m1*10)+byte('0'));
m:=m1;
until m=0;
overflow:=(pc-pcstart)+(pc2-pc2start)-high(s);
if overflow>0 then
inc(pcstart,overflow);
while (pc>pcstart) do
begin
pc2^:=pc^;
inc(pc2);
dec(pc);
end;
s[0]:=char(pc2-pc2start);
end;
{$endif ndef FPC_SYSTEM_HAS_INT_STR_INT64}
{$ifndef FPC_SYSTEM_HAS_INT_STR_QWORD}
procedure int_str(l:qword;out s:string);
var
m1 : qword;
pcstart,
pc2start,
pc,pc2 : pchar;
hs : string[64];
overflow : longint;
begin
pc2start:=@s[1];
pc2:=pc2start;
pcstart:=pchar(@hs[0]);
pc:=pcstart;
repeat
inc(pc);
m1:=l div 10;
pc^:=char(l-(m1*10)+byte('0'));
l:=m1;
until l=0;
overflow:=(pc-pcstart)-high(s);
if overflow>0 then
inc(pcstart,overflow);
while (pc>pcstart) do
begin
pc2^:=pc^;
inc(pc2);
dec(pc);
end;
s[0]:=char(pc2-pc2start);
end;
{$endif ndef FPC_SYSTEM_HAS_INT_STR_QWORD}
{$ifndef FPUNONE}
{$ifndef FPC_SYSTEM_HAS_SYSRESETFPU}
procedure SysResetFpu;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
softfloat_exception_flags:=0;
end;
{$endif FPC_SYSTEM_HAS_SYSRESETFPU}
{$ifndef FPC_SYSTEM_HAS_SYSINITFPU}
procedure SysInitFpu;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
softfloat_exception_mask:=float_flag_underflow or float_flag_inexact or float_flag_denormal;
end;
{$endif FPC_SYSTEM_HAS_SYSINITFPU}
{$endif}
{$ifndef FPC_SYSTEM_HAS_SWAPENDIAN}
function SwapEndian(const AValue: SmallInt): SmallInt;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
{ the extra Word type cast is necessary because the "AValue shr 8" }
{ is turned into "longint(AValue) shr 8", so if AValue < 0 then }
{ the sign bits from the upper 16 bits are shifted in rather than }
{ zeroes. }
Result := SmallInt((Word(AValue) shr 8) or (Word(AValue) shl 8));
end;
function SwapEndian(const AValue: Word): Word;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
Result := Word((AValue shr 8) or (AValue shl 8));
end;
function SwapEndian(const AValue: LongInt): LongInt;
begin
Result := (AValue shl 24)
or ((AValue and $0000FF00) shl 8)
or ((AValue and $00FF0000) shr 8)
or (AValue shr 24);
end;
function SwapEndian(const AValue: DWord): DWord;
begin
Result := (AValue shl 24)
or ((AValue and $0000FF00) shl 8)
or ((AValue and $00FF0000) shr 8)
or (AValue shr 24);
end;
function SwapEndian(const AValue: Int64): Int64;
begin
Result := (AValue shl 56)
or ((AValue and $000000000000FF00) shl 40)
or ((AValue and $0000000000FF0000) shl 24)
or ((AValue and $00000000FF000000) shl 8)
or ((AValue and $000000FF00000000) shr 8)
or ((AValue and $0000FF0000000000) shr 24)
or ((AValue and $00FF000000000000) shr 40)
or (AValue shr 56);
end;
function SwapEndian(const AValue: QWord): QWord;
begin
Result := (AValue shl 56)
or ((AValue and $000000000000FF00) shl 40)
or ((AValue and $0000000000FF0000) shl 24)
or ((AValue and $00000000FF000000) shl 8)
or ((AValue and $000000FF00000000) shr 8)
or ((AValue and $0000FF0000000000) shr 24)
or ((AValue and $00FF000000000000) shr 40)
or (AValue shr 56);
end;
{$endif FPC_SYSTEM_HAS_SWAPENDIAN}
function BEtoN(const AValue: SmallInt): SmallInt;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
{$IFDEF ENDIAN_BIG}
Result := AValue;
{$ELSE}
Result := SwapEndian(AValue);
{$ENDIF}
end;
function BEtoN(const AValue: Word): Word;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
{$IFDEF ENDIAN_BIG}
Result := AValue;
{$ELSE}
Result := SwapEndian(AValue);
{$ENDIF}
end;
function BEtoN(const AValue: LongInt): LongInt;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
{$IFDEF ENDIAN_BIG}
Result := AValue;
{$ELSE}
Result := SwapEndian(AValue);
{$ENDIF}
end;
function BEtoN(const AValue: DWord): DWord;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
{$IFDEF ENDIAN_BIG}
Result := AValue;
{$ELSE}
Result := SwapEndian(AValue);
{$ENDIF}
end;
function BEtoN(const AValue: Int64): Int64;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
{$IFDEF ENDIAN_BIG}
Result := AValue;
{$ELSE}
Result := SwapEndian(AValue);
{$ENDIF}
end;
function BEtoN(const AValue: QWord): QWord;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
{$IFDEF ENDIAN_BIG}
Result := AValue;
{$ELSE}
Result := SwapEndian(AValue);
{$ENDIF}
end;
function LEtoN(const AValue: SmallInt): SmallInt;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
{$IFDEF ENDIAN_LITTLE}
Result := AValue;
{$ELSE}
Result := SwapEndian(AValue);
{$ENDIF}
end;
function LEtoN(const AValue: Word): Word;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
{$IFDEF ENDIAN_LITTLE}
Result := AValue;
{$ELSE}
Result := SwapEndian(AValue);
{$ENDIF}
end;
function LEtoN(const AValue: LongInt): LongInt;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
{$IFDEF ENDIAN_LITTLE}
Result := AValue;
{$ELSE}
Result := SwapEndian(AValue);
{$ENDIF}
end;
function LEtoN(const AValue: DWord): DWord;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
{$IFDEF ENDIAN_LITTLE}
Result := AValue;
{$ELSE}
Result := SwapEndian(AValue);
{$ENDIF}
end;
function LEtoN(const AValue: Int64): Int64;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
{$IFDEF ENDIAN_LITTLE}
Result := AValue;
{$ELSE}
Result := SwapEndian(AValue);
{$ENDIF}
end;
function LEtoN(const AValue: QWord): QWord;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
{$IFDEF ENDIAN_LITTLE}
Result := AValue;
{$ELSE}
Result := SwapEndian(AValue);
{$ENDIF}
end;
function NtoBE(const AValue: SmallInt): SmallInt;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
{$IFDEF ENDIAN_BIG}
Result := AValue;
{$ELSE}
Result := SwapEndian(AValue);
{$ENDIF}
end;
function NtoBE(const AValue: Word): Word;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
{$IFDEF ENDIAN_BIG}
Result := AValue;
{$ELSE}
Result := SwapEndian(AValue);
{$ENDIF}
end;
function NtoBE(const AValue: LongInt): LongInt;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
{$IFDEF ENDIAN_BIG}
Result := AValue;
{$ELSE}
Result := SwapEndian(AValue);
{$ENDIF}
end;
function NtoBE(const AValue: DWord): DWord;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
{$IFDEF ENDIAN_BIG}
Result := AValue;
{$ELSE}
Result := SwapEndian(AValue);
{$ENDIF}
end;
function NtoBE(const AValue: Int64): Int64;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
{$IFDEF ENDIAN_BIG}
Result := AValue;
{$ELSE}
Result := SwapEndian(AValue);
{$ENDIF}
end;
function NtoBE(const AValue: QWord): QWord;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
{$IFDEF ENDIAN_BIG}
Result := AValue;
{$ELSE}
Result := SwapEndian(AValue);
{$ENDIF}
end;
function NtoLE(const AValue: SmallInt): SmallInt;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
{$IFDEF ENDIAN_LITTLE}
Result := AValue;
{$ELSE}
Result := SwapEndian(AValue);
{$ENDIF}
end;
function NtoLE(const AValue: Word): Word;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
{$IFDEF ENDIAN_LITTLE}
Result := AValue;
{$ELSE}
Result := SwapEndian(AValue);
{$ENDIF}
end;
function NtoLE(const AValue: LongInt): LongInt;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
{$IFDEF ENDIAN_LITTLE}
Result := AValue;
{$ELSE}
Result := SwapEndian(AValue);
{$ENDIF}
end;
function NtoLE(const AValue: DWord): DWord;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
{$IFDEF ENDIAN_LITTLE}
Result := AValue;
{$ELSE}
Result := SwapEndian(AValue);
{$ENDIF}
end;
function NtoLE(const AValue: Int64): Int64;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
{$IFDEF ENDIAN_LITTLE}
Result := AValue;
{$ELSE}
Result := SwapEndian(AValue);
{$ENDIF}
end;
function NtoLE(const AValue: QWord): QWord;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
{$IFDEF ENDIAN_LITTLE}
Result := AValue;
{$ELSE}
Result := SwapEndian(AValue);
{$ENDIF}
end;
{$ifndef FPC_SYSTEM_HAS_MEM_BARRIER}
procedure ReadBarrier;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
end;
procedure ReadDependencyBarrier;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
end;
procedure ReadWriteBarrier;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
end;
procedure WriteBarrier;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
end;
{$endif FPC_SYSTEM_HAS_MEM_BARRIER}
{$ifndef FPC_HAS_INTERNAL_ROX_BYTE}
{$ifndef FPC_SYSTEM_HAS_ROX_BYTE}
function RorByte(Const AValue : Byte): Byte;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
Result:=(AValue shr 1) or (AValue shl 7);
end;
function RorByte(Const AValue : Byte;Dist : Byte): Byte;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
Dist:=Dist and 7;
Result:=(AValue shr Dist) or (AValue shl (8-Dist));
end;
function RolByte(Const AValue : Byte): Byte;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
Result:=(AValue shl 1) or (AValue shr 7);
end;
function RolByte(Const AValue : Byte;Dist : Byte): Byte;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
Dist:=Dist and 7;
Result:=(AValue shl Dist) or (AValue shr (8-Dist));
end;
{$endif FPC_SYSTEM_HAS_ROX_BYTE}
{$endif FPC_HAS_INTERNAL_ROX_BYTE}
{$ifndef FPC_HAS_INTERNAL_ROX_WORD}
{$ifndef FPC_SYSTEM_HAS_ROX_WORD}
function RorWord(Const AValue : Word): Word;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
Result:=(AValue shr 1) or (AValue shl 15);
end;
function RorWord(Const AValue : Word;Dist : Byte): Word;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
Dist:=Dist and 15;
Result:=(AValue shr Dist) or (AValue shl (16-Dist));
end;
function RolWord(Const AValue : Word): Word;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
Result:=(AValue shl 1) or (AValue shr 15);
end;
function RolWord(Const AValue : Word;Dist : Byte): Word;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
Dist:=Dist and 15;
Result:=(AValue shl Dist) or (AValue shr (16-Dist));
end;
{$endif FPC_SYSTEM_HAS_ROX_WORD}
{$endif FPC_HAS_INTERNAL_ROX_WORD}
{$ifndef FPC_HAS_INTERNAL_ROX_DWORD}
{$ifndef FPC_SYSTEM_HAS_ROX_DWORD}
function RorDWord(Const AValue : DWord): DWord;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
Result:=(AValue shr 1) or (AValue shl 31);
end;
function RorDWord(Const AValue : DWord;Dist : Byte): DWord;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
Dist:=Dist and 31;
Result:=(AValue shr Dist) or (AValue shl (32-Dist));
end;
function RolDWord(Const AValue : DWord): DWord;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
Result:=(AValue shl 1) or (AValue shr 31);
end;
function RolDWord(Const AValue : DWord;Dist : Byte): DWord;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
Dist:=Dist and 31;
Result:=(AValue shl Dist) or (AValue shr (32-Dist));
end;
{$endif FPC_SYSTEM_HAS_ROX_DWORD}
{$endif FPC_HAS_INTERNAL_ROX_DWORD}
{$ifndef FPC_HAS_INTERNAL_ROX_QWORD}
{$ifndef FPC_SYSTEM_HAS_ROX_QWORD}
function RorQWord(Const AValue : QWord): QWord;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
Result:=(AValue shr 1) or (AValue shl 63);
end;
function RorQWord(Const AValue : QWord;Dist : Byte): QWord;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
Dist:=Dist and 63;
Result:=(AValue shr Dist) or (AValue shl (64-Dist));
end;
function RolQWord(Const AValue : QWord): QWord;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
Result:=(AValue shl 1) or (AValue shr 63);
end;
function RolQWord(Const AValue : QWord;Dist : Byte): QWord;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
Dist:=Dist and 63;
Result:=(AValue shl Dist) or (AValue shr (64-Dist));
end;
{$endif FPC_SYSTEM_HAS_ROX_QWORD}
{$endif FPC_HAS_INTERNAL_ROX_QWORD}
{$ifndef FPC_HAS_INTERNAL_SAR_BYTE}
{$ifndef FPC_SYSTEM_HAS_SAR_BYTE}
function SarShortint(Const AValue : Shortint;Shift : Byte): Shortint;
begin
Shift:=Shift and 7;
Result:=shortint(byte(byte(byte(AValue) shr Shift) or (byte(shortint(byte(0-byte(byte(AValue) shr 7)) and byte(shortint(0-(ord(Shift<>0){ and 1}))))) shl (8-Shift))));
end;
{$endif FPC_HAS_INTERNAL_SAR_BYTE}
{$endif FPC_SYSTEM_HAS_SAR_BYTE}
{$ifndef FPC_HAS_INTERNAL_SAR_WORD}
{$ifndef FPC_SYSTEM_HAS_SAR_WORD}
function SarSmallint(Const AValue : Smallint;Shift : Byte): Smallint;
begin
Shift:=Shift and 15;
Result:=smallint(word(word(word(AValue) shr Shift) or (word(smallint(word(0-word(word(AValue) shr 15)) and word(smallint(0-(ord(Shift<>0){ and 1}))))) shl (16-Shift))));
end;
{$endif FPC_HAS_INTERNAL_SAR_WORD}
{$endif FPC_SYSTEM_HAS_SAR_WORD}
{$ifndef FPC_HAS_INTERNAL_SAR_DWORD}
{$ifndef FPC_SYSTEM_HAS_SAR_DWORD}
function SarLongint(Const AValue : Longint;Shift : Byte): Longint;
begin
Shift:=Shift and 31;
Result:=longint(dword(dword(dword(AValue) shr Shift) or (dword(longint(dword(0-dword(dword(AValue) shr 31)) and dword(longint(0-(ord(Shift<>0){ and 1}))))) shl (32-Shift))));
end;
{$endif FPC_HAS_INTERNAL_SAR_DWORD}
{$endif FPC_SYSTEM_HAS_SAR_DWORD}
{$ifndef FPC_HAS_INTERNAL_SAR_QWORD}
{$ifndef FPC_SYSTEM_HAS_SAR_QWORD}
function SarInt64(Const AValue : Int64;Shift : Byte): Int64;
begin
Shift:=Shift and 63;
Result:=int64(qword(qword(qword(AValue) shr Shift) or (qword(int64(qword(0-qword(qword(AValue) shr 63)) and qword(int64(0-(ord(Shift<>0){ and 1}))))) shl (64-Shift))));
end;
{$endif FPC_HAS_INTERNAL_SAR_QWORD}
{$endif FPC_SYSTEM_HAS_SAR_QWORD}
{$ifndef FPC_HAS_INTERNAL_BSX_BYTE}
{$ifndef FPC_SYSTEM_HAS_BSX_BYTE}
function BsfByte(Const AValue: Byte): Byte;
const bsf8bit: array [Byte] of Byte = (
$ff,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,
5,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,
6,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,
5,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,
7,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,
5,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,
6,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,
5,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0
);
begin
result:=bsf8bit[AValue];
end;
function BsrByte(Const AValue: Byte): Byte;
const bsr8bit: array [Byte] of Byte = (
$ff,0,1,1,2,2,2,2,3,3,3,3,3,3,3,3,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,
5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,
6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,
6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,
7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,
7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,
7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,
7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7
);
begin
result:=bsr8bit[AValue];
end;
{$endif}
{$endif}
{$ifndef FPC_SYSTEM_HAS_BSX_WORD}
{$ifndef FPC_HAS_INTERNAL_BSX_WORD}
function BsfWord(Const AValue: Word): cardinal;
begin
if lo(AValue)<>0 then
result:=BsfByte(lo(AValue))
else
result:=BsfByte(hi(AValue))+8
end;
function BsrWord(Const AValue: Word): cardinal;
begin
if hi(AValue)<>0 then
result:=BsrByte(hi(AValue))+8
else
result:=BsrByte(lo(AValue))
end;
{$endif}
{$endif}
{$ifndef FPC_HAS_INTERNAL_BSX_DWORD}
{$ifndef FPC_SYSTEM_HAS_BSX_DWORD}
function BsfDWord(Const AValue : DWord): cardinal;
begin
if lo(AValue)<>0 then
result:=BsfWord(lo(AValue))
else
result:=BsfWord(hi(AValue))+16
end;
function BsrDWord(Const AValue : DWord): cardinal;
begin
if hi(AValue)<>0 then
result:=BsrWord(hi(AValue))+16
else
result:=BsrWord(lo(AValue))
end;
{$endif}
{$endif}
{$ifndef FPC_HAS_INTERNAL_BSX_QWORD}
{$ifndef FPC_SYSTEM_HAS_BSX_QWORD}
function BsfQWord(Const AValue : QWord): cardinal;
begin
if lo(AValue) <> 0 then
result:=BsfDWord(lo(AValue))
else
result:=BsfDWord(hi(AValue)) + 32
end;
function BsrQWord(Const AValue : QWord): cardinal;
begin
if hi(AValue) <> 0 then
result:=BsrDWord(hi(AValue)) + 32
else
result:=BsrDWord(lo(AValue))
end;
{$endif}
{$endif}
Reference in New Issue View Git Blame Copy Permalink