paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-12 21:49:09 +02:00
Code Issues Packages Projects Releases Wiki Activity

* primitives added

Browse Source
This commit is contained in:
peter 2000-01-10 09:54:30 +00:00
parent 021303c54e
commit c775ade1d6
4 changed files with 601 additions and 102 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

347
rtl/i386/i386.inc
View File

@ -19,14 +19,12 @@
{****************************************************************************
Move / Fill
Primitives
****************************************************************************}
{$define FPC_SYSTEM_HAS_MOVE}
procedure Move(var source;var dest;count:longint);
begin
asm
procedure Move(var source;var dest;count:longint);assembler;
asm
movl dest,%edi
movl source,%esi
movl %edi,%eax
@ -88,18 +86,14 @@ begin
movsb
cld
.LMoveEnd:
end;
end;
{$define FPC_SYSTEM_HAS_FILLCHAR}
Procedure FillChar(var x;count:longint;value:byte);
begin
asm
Procedure FillChar(var x;count:longint;value:byte);assembler;
asm
cld
movl x,%edi
{ movl value,%eax Only lower 8 bits will be used }
movb value,%al
movl count,%ecx
cmpl $7,%ecx
@ -124,41 +118,290 @@ begin
.LFill1:
rep
stosb
end;
end;
{$define FPC_SYSTEM_HAS_FILLWORD}
procedure fillword(var x;count : longint;value : word);
begin
asm
movl 8(%ebp),%edi
movl 12(%ebp),%ecx
movl 16(%ebp),%eax
movl %eax,%edx
shll $16,%eax
movw %dx,%ax
movl %ecx,%edx
shrl $1,%ecx
procedure fillword(var x;count : longint;value : word);assembler;
asm
movl 8(%ebp),%edi
movl 12(%ebp),%ecx
movl 16(%ebp),%eax
movl %eax,%edx
shll $16,%eax
movw %dx,%ax
movl %ecx,%edx
shrl $1,%ecx
cld
rep
stosl
movl %edx,%ecx
andl $1,%ecx
movl %edx,%ecx
andl $1,%ecx
rep
stosw
end ['EAX','ECX','EDX','EDI'];
end;
end ['EAX','ECX','EDX','EDI'];
{$define FPC_SYSTEM_HAS_FILLDWORD}
procedure filldword(var x;count : longint;value : dword);assembler;
asm
movl 8(%ebp),%edi
movl 12(%ebp),%ecx
movl 16(%ebp),%eax
cld
rep
stosl
end ['EAX','ECX','EDX','EDI'];
{$define FPC_SYSTEM_HAS_INDEXBYTE}
function IndexByte(var buf;len:longint;b:byte):longint; assembler;
asm
movl Len,%ecx // Load len
movl Buf,%edi // Load String
testl %ecx,%ecx
jz .Lready
cld
movl %ecx,%ebx // Copy for easy manipulation
movb b,%al
repne
scasb
jne .Lcharposnotfound
incl %ecx
subl %ecx,%ebx
movl %ebx,%eax
jmp .Lready
.Lcharposnotfound:
movl $-1,%eax
.Lready:
end ['EAX','EBX','ECX','EDI'];
{$define FPC_SYSTEM_HAS_INDEXWORD}
function Indexword(var buf;len:longint;b:word):longint; assembler;
asm
movl Len,%ecx // Load len
movl Buf,%edi // Load String
testl %ecx,%ecx
jz .Lready
cld
movl %ecx,%ebx // Copy for easy manipulation
movw b,%ax
repne
scasw
jne .Lcharposnotfound
incl %ecx
subl %ecx,%ebx
movl %ebx,%eax
jmp .Lready
.Lcharposnotfound:
movl $-1,%eax
.Lready:
end ['EAX','EBX','ECX','EDI'];
{$define FPC_SYSTEM_HAS_INDEXDWORD}
function IndexDWord(var buf;len:longint;b:DWord):longint; assembler;
asm
movl Len,%ecx // Load len
movl Buf,%edi // Load String
testl %ecx,%ecx
jz .Lready
cld
movl %ecx,%ebx // Copy for easy manipulation
movl b,%eax
repne
scasd
jne .Lcharposnotfound
incl %ecx
subl %ecx,%ebx
movl %ebx,%eax
jmp .Lready
.Lcharposnotfound:
movl $-1,%eax
.Lready:
end ['EAX','EBX','ECX','EDI'];
{$define FPC_SYSTEM_HAS_COMPAREBYTE}
function CompareByte(var buf1,buf2;len:longint):longint; assembler;
asm
cld
movl len,%eax
movl buf2,%esi { Load params}
movl buf1,%edi
testl %eax,%eax {We address -1(%esi), so we have to deal with len=0}
je .LCmpbyteExit
cmpl $7,%eax {<7 not worth aligning and go through all trouble}
jl .LCmpbyte2
movl %edi,%ecx { Align on 32bits }
negl %ecx { calc bytes to align (%edi and 3) xor 3= -%edi and 3}
andl $3,%ecx
subl %ecx,%eax { Subtract from number of bytes to go}
orl %ecx,%ecx
rep
cmpsb {The actual 32-bit Aligning}
jne .LCmpbyte3
movl %eax,%ecx {bytes to do, divide by 4}
andl $3,%eax {remainder}
shrl $2,%ecx {The actual division}
orl %ecx,%ecx {Sets zero flag if ecx=0 -> no cmp}
rep
cmpsl
je .LCmpbyte2 { All equal? then to the left over bytes}
movl $4,%eax { Not equal. Rescan the last 4 bytes bytewise}
subl %eax,%esi
subl %eax,%edi
.LCmpbyte2:
movl %eax,%ecx {bytes still to (re)scan}
orl %eax,%eax {prevent disaster in case %eax=0}
rep
cmpsb
.LCmpbyte3:
movzbl -1(%esi),%ecx
movzbl -1(%edi),%eax // Compare failing (or equal) position
subl %ecx,%eax
.LCmpbyteExit:
end ['ECX','EAX','ESI','EDI'];
{$define FPC_SYSTEM_HAS_COMPAREWORD}
function CompareWord(var buf1,buf2;len:longint):longint; assembler;
asm
cld
movl len,%eax
movl buf2,%esi { Load params}
movl buf1,%edi
testl %eax,%eax {We address -2(%esi), so we have to deal with len=0}
je .LCmpwordExit
cmpl $5,%eax {<5 (3 bytes align + 4 bytes cmpsl = 4 words}
jl .LCmpword2 { not worth aligning and go through all trouble}
movl (%edi),%ebx // Compare alignment bytes.
cmpl (%esi),%ebx
jne .LCmpword2 // Aligning will go wrong already. Max 2 words will be scanned Branch NOW
shll $1,%eax {Convert word count to bytes}
movl %edi,%edx { Align comparing is already done, so simply add}
negl %edx { calc bytes to align -%edi and 3}
andl $3,%edx
addl %edx,%esi { Skip max 3 bytes alignment}
addl %edx,%edi
subl %edx,%eax { Subtract from number of bytes to go}
movl %eax,%ecx { Make copy of bytes to go}
andl $3,%eax { Calc remainder (mod 4) }
andl $1,%edx { %edx is 1 if array not 2-aligned, 0 otherwise}
shrl $2,%ecx { divide bytes to go by 4, DWords to go}
orl %ecx,%ecx { Sets zero flag if ecx=0 -> no cmp}
rep { Compare entire DWords}
cmpsl
je .LCmpword2a { All equal? then to the left over bytes}
movl $4,%eax { Not equal. Rescan the last 4 bytes bytewise}
subl %eax,%esi { Go back one DWord}
subl %eax,%edi
incl %eax {if not odd then this does nothing, else it makes
sure that adding %edx increases from 2 to 3 words}
.LCmpword2a:
subl %edx,%esi { Subtract alignment}
subl %edx,%edi
addl %edx,%eax
shrl $1,%eax
.LCmpword2:
movl %eax,%ecx {words still to (re)scan}
orl %eax,%eax {prevent disaster in case %eax=0}
rep
cmpsw
.LCmpword3:
movzwl -2(%esi),%ecx
movzwl -2(%edi),%eax // Compare failing (or equal) position
subl %ecx,%eax // calculate end result.
.LCmpwordExit:
end ['EBX','EDX','ECX','EAX','ESI','EDI'];
{$define FPC_SYSTEM_HAS_COMPAREDWORD}
function CompareDWord(var buf1,buf2;len:longint):longint; assembler;
asm
cld
movl len,%eax
movl buf2,%esi { Load params}
movl buf1,%edi
testl %eax,%eax {We address -2(%esi), so we have to deal with len=0}
je .LCmpDwordExit
cmpl $3,%eax {<3 (3 bytes align + 4 bytes cmpsl) = 2 DWords}
jl .LCmpDword2 { not worth aligning and go through all trouble}
movl (%edi),%ebx // Compare alignment bytes.
cmpl (%esi),%ebx
jne .LCmpDword2 // Aligning will go wrong already. Max 2 words will be scanned Branch NOW
shll $2,%eax {Convert word count to bytes}
movl %edi,%edx { Align comparing is already done, so simply add}
negl %edx { calc bytes to align -%edi and 3}
andl $3,%edx
addl %edx,%esi { Skip max 3 bytes alignment}
addl %edx,%edi
subl %edx,%eax { Subtract from number of bytes to go}
movl %eax,%ecx { Make copy of bytes to go}
andl $3,%eax { Calc remainder (mod 4) }
shrl $2,%ecx { divide bytes to go by 4, DWords to go}
orl %ecx,%ecx { Sets zero flag if ecx=0 -> no cmp}
rep { Compare entire DWords}
cmpsl
je .LCmpDword2a { All equal? then to the left over bytes}
movl $4,%eax { Not equal. Rescan the last 4 bytes bytewise}
subl %eax,%esi { Go back one DWord}
subl %eax,%edi
addl $3,%eax {if align<>0 this causes repcount to be 2}
.LCmpDword2a:
subl %edx,%esi { Subtract alignment}
subl %edx,%edi
addl %edx,%eax
shrl $2,%eax
.LCmpDword2:
movl %eax,%ecx {words still to (re)scan}
orl %eax,%eax {prevent disaster in case %eax=0}
rep
cmpsl
.LCmpDword3:
movzwl -4(%esi),%ecx
movzwl -4(%edi),%eax // Compare failing (or equal) position
subl %ecx,%eax // calculate end result.
.LCmpDwordExit:
end ['EBX','EDX','ECX','EAX','ESI','EDI'];
{$define FPC_SYSTEM_HAS_INDEXCHAR0}
function IndexChar0(var buf;len:longint;b:Char):longint; assembler;
asm
// Can't use scasb, or will have to do it twice, think this
// is faster for small "len"
movl Buf,%esi // Load address
movl len,%edx // load maximal searchdistance
movzbl b,%ebx // Load searchpattern
testl %edx,%edx
je .LFound
xorl %ecx,%ecx // zero index in Buf
xorl %eax,%eax // To make DWord compares possible
.LLoop:
movb (%esi),%al // Load byte
cmpb %al,%bl
je .LFound // byte the same?
incl %ecx
incl %esi
cmpl %edx,%ecx // Maximal distance reached?
je .LNotFound
testl %eax,%eax // Nullchar = end of search?
jne .LLoop
.LNotFound:
movl $-1,%ecx // Not found return -1
.LFound:
movl %ecx,%eax
end['EAX','EBX','ECX','EDX','ESI'];
{****************************************************************************
Object Helpers
****************************************************************************}
{$define FPC_SYSTEM_HAS_FPC_HELP_CONSTRUCTOR}
procedure int_help_constructor;assembler; [public,alias:'FPC_HELP_CONSTRUCTOR'];
asm
{ Entry without preamble, since we need the ESP of the constructor
@ -231,8 +474,9 @@ asm
orl %eax,%eax
.LHC_5:
end;
{$define FPC_SYSTEM_HAS_FPC_HELP_FAIL}
{$define FPC_SYSTEM_HAS_FPC_HELP_FAIL}
procedure int_help_fail;assembler;[public,alias:'FPC_HELP_FAIL'];
{ should be called with a object that needs to be
freed if VMT field is at -1
@ -265,8 +509,8 @@ asm
.LHF_1:
end;
{$define FPC_SYSTEM_HAS_FPC_HELP_DESTRUCTOR}
{$define FPC_SYSTEM_HAS_FPC_HELP_DESTRUCTOR}
procedure int_help_destructor;assembler;[public,alias:'FPC_HELP_DESTRUCTOR'];
asm
{ Stack (relative to %ebp):
@ -301,8 +545,8 @@ asm
popal
end;
{$define FPC_SYSTEM_HAS_FPC_NEW_CLASS}
{$define FPC_SYSTEM_HAS_FPC_NEW_CLASS}
procedure int_new_class;assembler;[public,alias:'FPC_NEW_CLASS'];
asm
{ to be sure in the future, we save also edit }
@ -341,7 +585,6 @@ end;
{$define FPC_SYSTEM_HAS_FPC_DISPOSE_CLASS}
procedure int_dispose_class;assembler;[public,alias:'FPC_DISPOSE_CLASS'];
asm
{ to be sure in the future, we save also edit }
@ -374,7 +617,6 @@ asm
end;
{$define FPC_SYSTEM_HAS_FPC_HELP_FAIL_CLASS}
procedure int_help_fail_class;assembler;[public,alias:'FPC_HELP_FAIL_CLASS'];
{ a non zero class must allways be disposed
VMT is allways at pos 0 }
@ -429,13 +671,12 @@ end;
end;
{$endif not SYSTEMDEBUG}
{$define FPC_SYSTEM_HAS_FPC_CHECK_OBJECT_EXT}
procedure int_check_object_ext;assembler;[public,alias:'FPC_CHECK_OBJECT_EXT'];
{ checks for a correct vmt pointer }
{ deeper check to see if the current object is }
{ really related to the true }
{$define FPC_SYSTEM_HAS_FPC_CHECK_OBJECT_EXT}
procedure int_check_object_ext;assembler;[public,alias:'FPC_CHECK_OBJECT_EXT'];
asm
pushl %ebp
movl %esp,%ebp
@ -478,7 +719,6 @@ end;
****************************************************************************}
{$define FPC_SYSTEM_HAS_FPC_SHORTSTR_COPY}
procedure int_strcopy(len:longint;sstr,dstr:pointer);[public,alias:'FPC_SHORTSTR_COPY'];
{
this procedure must save all modified registers except EDI and ESI !!!
@ -520,8 +760,8 @@ begin
end ['ESI','EDI'];
end;
{$define FPC_SYSTEM_HAS_FPC_SHORTSTR_CONCAT}
{$define FPC_SYSTEM_HAS_FPC_SHORTSTR_CONCAT}
procedure int_strconcat(s1,s2:pointer);[public,alias:'FPC_SHORTSTR_CONCAT'];
begin
asm
@ -560,8 +800,8 @@ begin
end ['EBX','ECX','EAX','ESI','EDI'];
end;
{$define FPC_SYSTEM_HAS_FPC_SHORTSTR_COMPARE}
{$define FPC_SYSTEM_HAS_FPC_SHORTSTR_COMPARE}
procedure int_strcmp(dstr,sstr:pointer);[public,alias:'FPC_SHORTSTR_COMPARE'];
begin
asm
@ -610,8 +850,8 @@ begin
end ['EDX','ECX','EBX','EAX','ESI','EDI'];
end;
{$define FPC_SYSTEM_HAS_FPC_PCHAR_TO_SHORTSTR}
{$define FPC_SYSTEM_HAS_FPC_PCHAR_TO_SHORTSTR}
function strpas(p:pchar):shortstring;[public,alias:'FPC_PCHAR_TO_SHORTSTR'];
begin
asm
@ -653,8 +893,8 @@ begin
end ['ECX','EAX','ESI','EDI'];
end;
{$define FPC_SYSTEM_HAS_FPC_CHARARRAY_TO_SHORTSTR}
{$define FPC_SYSTEM_HAS_FPC_CHARARRAY_TO_SHORTSTR}
function strchararray(p:pchar; l : longint):shortstring;[public,alias:'FPC_CHARARRAY_TO_SHORTSTR'];
begin
asm
@ -688,8 +928,8 @@ begin
end ['ECX','EAX','ESI','EDI'];
end;
{$define FPC_SYSTEM_HAS_STRLEN}
{$define FPC_SYSTEM_HAS_STRLEN}
function strlen(p:pchar):longint;assembler;
asm
movl p,%edi
@ -708,14 +948,13 @@ end ['EDI','ECX','EAX'];
****************************************************************************}
{$define FPC_SYSTEM_HAS_GET_FRAME}
function get_frame:longint;assembler;
asm
movl %ebp,%eax
end ['EAX'];
{$define FPC_SYSTEM_HAS_GET_CALLER_ADDR}
{$define FPC_SYSTEM_HAS_GET_CALLER_ADDR}
function get_caller_addr(framebp:longint):longint;assembler;
asm
movl framebp,%eax
@ -725,8 +964,8 @@ asm
.Lg_a_null:
end ['EAX'];
{$define FPC_SYSTEM_HAS_GET_CALLER_FRAME}
{$define FPC_SYSTEM_HAS_GET_CALLER_FRAME}
function get_caller_frame(framebp:longint):longint;assembler;
asm
movl framebp,%eax
@ -742,7 +981,6 @@ end ['EAX'];
****************************************************************************}
{$define FPC_SYSTEM_HAS_ABS_LONGINT}
function abs(l:longint):longint; assembler;[internconst:in_const_abs];
asm
movl l,%eax
@ -751,8 +989,8 @@ asm
subl %edx,%eax
end ['EAX','EDX'];
{$define FPC_SYSTEM_HAS_ODD_LONGINT}
{$define FPC_SYSTEM_HAS_ODD_LONGINT}
function odd(l:longint):boolean;assembler;[internconst:in_const_odd];
asm
movl l,%eax
@ -760,8 +998,8 @@ asm
setnz %al
end ['EAX'];
{$define FPC_SYSTEM_HAS_SQR_LONGINT}
{$define FPC_SYSTEM_HAS_SQR_LONGINT}
function sqr(l:longint):longint;assembler;[internconst:in_const_sqr];
asm
mov l,%eax
@ -770,7 +1008,6 @@ end ['EAX'];
{$define FPC_SYSTEM_HAS_SPTR}
Function Sptr : Longint;assembler;
asm
movl %esp,%eax
@ -782,7 +1019,6 @@ end;
****************************************************************************}
{$define FPC_SYSTEM_HAS_INT_STR_LONGINT}
procedure int_str(l : longint;var s : string);
var
buffer : array[0..11] of byte;
@ -823,8 +1059,8 @@ begin
end;
end;
{$define FPC_SYSTEM_HAS_INT_STR_CARDINAL}
{$define FPC_SYSTEM_HAS_INT_STR_CARDINAL}
procedure int_str(c : cardinal;var s : string);
var
buffer : array[0..14] of byte;
@ -918,7 +1154,10 @@ end;
{
$Log$
Revision 1.65 2000-01-07 16:41:32 daniel
Revision 1.66 2000-01-10 09:54:30 peter
* primitives added
Revision 1.65 2000/01/07 16:41:32 daniel
* copyright 2000
Revision 1.64 2000/01/07 16:32:24 daniel

322
rtl/inc/generic.inc
View File

@ -17,69 +17,297 @@
{****************************************************************************
Move / Fill
Primitives
****************************************************************************}
{$ifndef FPC_SYSTEM_HAS_MOVE}
procedure Move(var source;var dest;count:longint);
type
longintarray = array [0..maxlongint] of longint;
bytearray = array [0..maxlongint] of byte;
var
i,size : longint;
type
longintarray = array [0..maxlongint] of longint;
bytearray = array [0..maxlongint] of byte;
var
i,size : longint;
begin
size:=count div sizeof(longint);
if (@dest)<@source) or
(@dest>@source+count) then
begin
for i:=0 to size-1 do
longintarray(dest)[i]:=longintarray(source)[i];
for i:=size*sizeof(longint) to count-1 do
bytearray(dest)[i]:=bytearray(source)[i];
end
else
begin
for i:=count-1 downto size*sizeof(longint) do
bytearray(dest)[i]:=bytearray(source)[i];
for i:=size-1 downto 0 do
longintarray(dest)[i]:=longintarray(source)[i];
end;
size:=count div sizeof(longint);
if (@dest)<@source) or
(@dest>@source+count) then
begin
for i:=0 to size-1 do
longintarray(dest)[i]:=longintarray(source)[i];
for i:=size*sizeof(longint) to count-1 do
bytearray(dest)[i]:=bytearray(source)[i];
end
else
begin
for i:=count-1 downto size*sizeof(longint) do
bytearray(dest)[i]:=bytearray(source)[i];
for i:=size-1 downto 0 do
longintarray(dest)[i]:=longintarray(source)[i];
end;
end;
{$endif ndef FPC_SYSTEM_HAS_MOVE}
{$ifndef FPC_SYSTEM_HAS_FILLCHAR}
Procedure FillChar(var x;count:longint;value:byte);
type
longintarray = array [0..maxlongint] of longint;
bytearray = array [0..maxlongint] of byte;
var i,v : longint;
type
longintarray = array [0..maxlongint] of longint;
bytearray = array [0..maxlongint] of byte;
var
i,v : longint;
begin
v:=value*256+value;
v:=v*$10000+v;
for i:=0 to (count div 4) -1 do
longintarray(x)[i]:=v;
for i:=(count div 4)*4 to count-1 do
bytearray(x)[i]:=value;
v:=value*256+value;
v:=v*$10000+v;
for i:=0 to (count div 4) -1 do
longintarray(x)[i]:=v;
for i:=(count div 4)*4 to count-1 do
bytearray(x)[i]:=value;
end;
{$endif ndef FPC_SYSTEM_HAS_FILLCHAR}
{$ifndef RTLLITE}
{$ifndef FPC_SYSTEM_HAS_FILLBYTE}
procedure FillByte (var x;count : longint;value : byte );
begin
FillChar (X,Count,CHR(VALUE));
end;
{$endif ndef FPC_SYSTEM_HAS_FILLBYTE}
{$ifndef FPC_SYSTEM_HAS_FILLWORD}
procedure fillword(var x;count : longint;value : word);
type
longintarray = array [0..maxlongint] of longint;
wordarray = array [0..maxlongint] of word;
var i,v : longint;
type
longintarray = array [0..maxlongint] of longint;
wordarray = array [0..maxlongint] of word;
var
i,v : longint;
begin
v:=value*$10000+value;
for i:=0 to (count div 2) -1 do
longintarray(x)[i]:=v;
for i:=(count div 2)*2 to count-1 do
wordarray(x)[i]:=value;
v:=value*$10000+value;
for i:=0 to (count div 2) -1 do
longintarray(x)[i]:=v;
for i:=(count div 2)*2 to count-1 do
wordarray(x)[i]:=value;
end;
{$endif ndef FPC_SYSTEM_HAS_FILLWORD}
{$ifndef FPC_SYSTEM_HAS_FILLDWORD}
procedure FillDWord(var x;count : longint;value : DWord);
var
I : longint;
begin
if Count<>0 then
begin
I:=Count;
while I<>0 do
begin
PDWord(@X)[I-1]:=Value;
Dec(I);
end;
end;
end;
{$endif ndef FPC_SYSTEM_HAS_FILLDWORD}
{$ifndef FPC_SYSTEM_HAS_INDEXCHAR}
function IndexChar(var buf;len:longint;b:char):longint;
begin
IndexChar:=IndexByte(Buf,Len,byte(B));
end;
{$endif ndef FPC_SYSTEM_HAS_INDEXCHAR}
{$ifndef FPC_SYSTEM_HAS_INDEXBYTE}
function IndexByte(var buf;len:longint;b:byte):longint;
var
I : longint;
begin
I:=0;
while (pbyte(@buf)[I]<>b) and (I<Len) do
inc(I);
if (i=Len) then
i:=-1; {Can't use 0, since it is a possible value}
IndexByte:=I;
end;
{$endif ndef FPC_SYSTEM_HAS_INDEXBYTE}
{$ifndef FPC_SYSTEM_HAS_INDEXWORD}
function Indexword(var buf;len:longint;b:word):longint;
var
I : longint;
begin
I:=0;
while (pword(@buf)[I]<>b) and (I<Len) do
inc(I);
if (i=Len) then
i:=-1; {Can't use 0, since it is a possible value for index}
Indexword:=I;
end;
{$endif ndef FPC_SYSTEM_HAS_INDEXWORD}
{$ifndef FPC_SYSTEM_HAS_INDEXDWORD}
function IndexDWord(var buf;len:longint;b:DWord):longint;
var
I : longint;
begin
I:=0;
while (PDWord(@buf)[I]<>b) and (I<Len) do inc(I);
if (i=Len) then
i:=-1; {Can't use 0, since it is a possible value for index}
IndexDWord:=I;
end;
{$endif ndef FPC_SYSTEM_HAS_INDEXDWORD}
{$ifndef FPC_SYSTEM_HAS_COMPARECHAR}
function CompareChar(var buf1,buf2;len:longint):longint;
begin
CompareChar:=CompareByte(buf1,buf2,len);
end;
{$endif ndef FPC_SYSTEM_HAS_COMPARECHAR}
{$ifndef FPC_SYSTEM_HAS_COMPAREBYTE}
function CompareByte(var buf1,buf2;len:longint):longint;
var
I,J : longint;
begin
I:=0;
if (Len<>0) and (@Buf1<>@Buf2) then
begin
while (pbyte(@Buf1)[I]=pbyte(@Buf2)[I]) and (I<Len) do
inc(I);
if I=Len then {No difference}
I:=0
else
begin
I:=pbyte(@Buf1)[I]-pbyte(@Buf2)[I];
if I>0 then
I:=1
else
if I<0 then
I:=-1;
end;
end;
CompareByte:=I;
end;
{$endif ndef FPC_SYSTEM_HAS_COMPAREBYTE}
{$ifndef FPC_SYSTEM_HAS_COMPAREWORD}
function CompareWord(var buf1,buf2;len:longint):longint;
var
I,J : longint;
begin
I:=0;
if (Len<>0) and (@Buf1<>@Buf2) then
begin
while (pword(@Buf1)[I]=pword(@Buf2)[I]) and (I<Len) do
inc(I);
if I=Len then {No difference}
I:=0
else
begin
I:=pword(@Buf1)[I]-pword(@Buf2)[I];
if I>0 then
I:=1
else
if I<0 then
I:=-1;
end;
end;
CompareWord:=I;
end;
{$endif ndef FPC_SYSTEM_HAS_COMPAREWORD}
{$ifndef FPC_SYSTEM_HAS_COMPAREDWORD}
function CompareDWord(var buf1,buf2;len:longint):longint;
var
I,J : longint;
begin
I:=0;
if (Len<>0) and (@Buf1<>@Buf2) then
begin
while (PDWord(@Buf1)[I]=PDWord(@Buf2)[I]) and (I<Len) do
inc(I);
if I=Len then {No difference}
I:=0
else
begin
I:=PDWord(@Buf1)[I]-PDWord(@Buf2)[I];
if I>0 then
I:=1
else
if I<0 then
I:=-1;
end;
end;
CompareDWord:=I;
end;
{$endif ndef FPC_SYSTEM_HAS_COMPAREDWORD}
{$ifndef FPC_SYSTEM_HAS_MOVECHAR0}
procedure MoveChar0(var buf1,buf2;len:longint);
var
I : longint;
begin
if Len<> 0 then
begin
I:=IndexByte(Buf1,Len,0);
if I<>0 then
Move(Buf1,Buf2,I);
end;
end;
{$endif ndef FPC_SYSTEM_HAS_MOVECHAR0}
{$ifndef FPC_SYSTEM_HAS_INDEXCHAR0}
function IndexChar0(var buf;len:longint;b:Char):longint;
var
I : longint;
begin
if Len<>0 then
begin
I:=IndexByte(Buf1,Len,0);
IndexChar0:=IndexByte(Buf1,I,0);
end
else
IndexChar0:=0;
end;
{$endif ndef FPC_SYSTEM_HAS_INDEXCHAR0}
{$ifndef FPC_SYSTEM_HAS_COMPARECHAR0}
function CompareChar0(var buf1,buf2;len:longint):longint;
var
I,J,K,bytesTodo : longint;
begin
K:=0;
if Len<>0 then
begin
I:=IndexByte(Buf1,Len,0);
J:=IndexByte(Buf2,Len,0);
if (I<>0) and (J<>0) then
begin
bytesTodo:=I;
if J<bytesTodo then
bytesTodo:=J;
K:=CompareByte(Buf1,Buf2,bytesTodo); // Safe for bytesTodo=0
end;
end;
CompareChar0:=K;
end;
{$endif ndef FPC_SYSTEM_HAS_COMPARECHAR0}
{$endif ndef RTLLITE}
{****************************************************************************
Object Helpers
****************************************************************************}
@ -135,8 +363,8 @@ end;
{$endif ndef FPC_SYSTEM_HAS_FPC_HELP_DESTRUCTOR}
{$ifndef FPC_SYSTEM_HAS_FPC_NEW_CLASS}
{$ifndef FPC_SYSTEM_HAS_FPC_NEW_CLASS}
procedure int_new_class;assembler;[public,alias:'FPC_NEW_CLASS'];
asm
{ to be sure in the future, we save also edit }
@ -494,6 +722,8 @@ end;
{$endif ndef FPC_SYSTEM_HAS_FPC_BOUNDCHECK}
{$ifndef HASSAVEREGISTERS}
{****************************************************************************
IoCheck
****************************************************************************}
@ -514,10 +744,14 @@ end;
{$endif ndef FPC_SYSTEM_HAS_FPC_IOCHECK}
{$endif}
{
$Log$
Revision 1.5 2000-01-07 16:41:34 daniel
Revision 1.6 2000-01-10 09:54:30 peter
* primitives added
Revision 1.5 2000/01/07 16:41:34 daniel
* copyright 2000
Revision 1.4 2000/01/07 16:32:24 daniel

13
rtl/inc/system.inc
View File

@ -32,8 +32,10 @@ Procedure HandleErrorFrame (Errno : longint;frame : longint); forward;
type
FileFunc = Procedure(var t : TextRec);
PByte = ^Byte;
PWord = ^word;
PDWord = ^DWord;
PLongint = ^Longint;
PByte = ^Byte;
const
{ Random / Randomize constants }
@ -97,6 +99,10 @@ Procedure Rewrite(var f : TypedFile); [INTERNPROC: In_Rewrite_TypedFile];
{$ENDIF}
{$ENDIF}
{ Include generic pascal only routines which are not defined in the processor
specific include file }
{$I generic.inc}
{****************************************************************************
Set Handling
@ -593,7 +599,10 @@ end;
{
$Log$
Revision 1.79 2000-01-07 16:41:36 daniel
Revision 1.80 2000-01-10 09:54:30 peter
* primitives added
Revision 1.79 2000/01/07 16:41:36 daniel
* copyright 2000
Revision 1.78 2000/01/07 16:32:25 daniel

21
rtl/inc/systemh.inc
View File

@ -155,8 +155,22 @@ Procedure FillChar(Var x;count:Longint;Value:Boolean);
Procedure FillChar(Var x;count:Longint;Value:Char);
Procedure FillChar(Var x;count:Longint;Value:Byte);
{$ifndef RTLLITE}
procedure FillByte(var x;count:longint;value:byte);
Procedure FillWord(Var x;count:Longint;Value:Word);
{$endif RTLLITE}
procedure FillDWord(var x;count:longint;value:DWord);
function IndexChar(var buf;len:longint;b:char):longint;
function IndexByte(var buf;len:longint;b:byte):longint;
function Indexword(var buf;len:longint;b:word):longint;
function IndexDWord(var buf;len:longint;b:DWord):longint;
function CompareChar(var buf1,buf2;len:longint):longint;
function CompareByte(var buf1,buf2;len:longint):longint;
function CompareWord(var buf1,buf2;len:longint):longint;
function CompareDWord(var buf1,buf2;len:longint):longint;
procedure MoveChar0(var buf1,buf2;len:longint);
function IndexChar0(var buf;len:longint;b:char):longint;
function CompareChar0(var buf1,buf2;len:longint):longint;
{$endif}
{****************************************************************************
Math Routines
@ -410,7 +424,10 @@ const
{
$Log$
Revision 1.74 2000-01-07 16:41:36 daniel
Revision 1.75 2000-01-10 09:54:30 peter
* primitives added
Revision 1.74 2000/01/07 16:41:36 daniel
* copyright 2000
Revision 1.73 2000/01/07 16:32:25 daniel