paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-17 13:59:29 +02:00
Code Issues Packages Projects Releases Wiki Activity

*** empty log message ***

Browse Source
This commit is contained in:
peter 2001-05-09 19:57:07 +00:00
parent 2019918dc9
commit 8bf13fd185
6 changed files with 251 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
rtl/i386/set.inc
View File

@ -14,6 +14,7 @@
**********************************************************************}
{$define FPC_SYSTEM_HAS_FPC_SET_LOAD_SMALL}
procedure do_load_small(p : pointer;l:longint);assembler;[public,alias:'FPC_SET_LOAD_SMALL'];
{
load a normal set p from a smallset l
@ -29,7 +30,7 @@ asm
stosl
end;
{$define FPC_SYSTEM_HAS_FPC_SET_CREATE_ELEMENT}
procedure do_create_element(p : pointer;b : byte);assembler;[public,alias:'FPC_SET_CREATE_ELEMENT'];
{
create a new set in p from an element b
@ -53,6 +54,8 @@ asm
popl %eax
end;
{$define FPC_SYSTEM_HAS_FPC_SET_SET_BYTE}
procedure do_set_byte(p : pointer;b : byte);assembler;[public,alias:'FPC_SET_SET_BYTE'];
{
add the element b to the set pointed by p
@ -71,6 +74,7 @@ asm
end;
{$define FPC_SYSTEM_HAS_FPC_SET_UNSET_BYTE}
procedure do_unset_byte(p : pointer;b : byte);assembler;[public,alias:'FPC_SET_UNSET_BYTE'];
{
suppresses the element b to the set pointed by p
@ -90,6 +94,7 @@ asm
end;
{$define FPC_SYSTEM_HAS_FPC_SET_SET_RANGE}
procedure do_set_range(p : pointer;l,h : byte);assembler;[public,alias:'FPC_SET_SET_RANGE'];
{
adds the range [l..h] to the set pointed to by p
@ -123,7 +128,7 @@ asm
subl $4,%ebx
jnz .Lset_range_loop
.Lset_range_hi:
movb h,%cl
movb h,%cl
movl %edx,%ebx // save current bitmask
andb $31,%cl
subb $31,%cl // cl := (31 - (hi and 31)) = shift count to
@ -136,6 +141,7 @@ asm
end;
{$define FPC_SYSTEM_HAS_FPC_SET_IN_BYTE}
procedure do_in_byte(p : pointer;b : byte);assembler;[public,alias:'FPC_SET_IN_BYTE'];
{
tests if the element b is in the set p the carryflag is set if it present
@ -154,7 +160,7 @@ asm
end;
{$define FPC_SYSTEM_HAS_FPC_SET_ADD_SETS}
procedure do_add_sets(set1,set2,dest : pointer);assembler;[public,alias:'FPC_SET_ADD_SETS'];
{
adds set1 and set2 into set dest
@ -174,7 +180,7 @@ asm
end;
{$define FPC_SYSTEM_HAS_FPC_SET_MUL_SETS}
procedure do_mul_sets(set1,set2,dest:pointer);assembler;[public,alias:'FPC_SET_MUL_SETS'];
{
multiplies (takes common elements of) set1 and set2 result put in dest
@ -194,6 +200,7 @@ asm
end;
{$define FPC_SYSTEM_HAS_FPC_SET_SUB_SETS}
procedure do_sub_sets(set1,set2,dest:pointer);assembler;[public,alias:'FPC_SET_SUB_SETS'];
{
computes the diff from set1 to set2 result in dest
@ -215,6 +222,7 @@ asm
end;
{$define FPC_SYSTEM_HAS_FPC_SET_SYMDIF_SETS}
procedure do_symdif_sets(set1,set2,dest:pointer);assembler;[public,alias:'FPC_SET_SYMDIF_SETS'];
{
computes the symetric diff from set1 to set2 result in dest
@ -235,6 +243,7 @@ asm
end;
{$define FPC_SYSTEM_HAS_FPC_SET_COMP_SETS}
procedure do_comp_sets(set1,set2 : pointer);assembler;[public,alias:'FPC_SET_COMP_SETS'];
{
compares set1 and set2 zeroflag is set if they are equal
@ -257,7 +266,10 @@ asm
.LMCOMPSETEND:
end;
{$IfNDef NoSetInclusion}
{$define FPC_SYSTEM_HAS_FPC_SET_CONTAINS_SET}
procedure do_contains_sets(set1,set2 : pointer);assembler;[public,alias:'FPC_SET_CONTAINS_SETS'];
{
on exit, zero flag is set if set1 <= set2 (set2 contains set1)
@ -447,11 +459,14 @@ end;
{
$Log$
Revision 1.3 2000-09-21 16:09:19 jonas
Revision 1.4 2001-05-09 19:57:07 peter
*** empty log message ***
Revision 1.3 2000/09/21 16:09:19 jonas
+ new, much faster do_set_range based on the PowerPC version (which
will be committed tomorrow)
Revision 1.2 2000/07/13 11:33:41 michael
+ removed logs
}

7
rtl/inc/generic.inc
View File

@ -756,7 +756,7 @@ end;
procedure int_boundcheck(l : longint; range : pointer);[public,alias: 'FPC_BOUNDCHECK'];
type
prange = ^trange;
trange = record
trange = packed record
min,max : longint;
end;
begin
@ -771,7 +771,10 @@ end;
{
$Log$
Revision 1.9 2001-04-21 12:16:28 peter
Revision 1.10 2001-05-09 19:57:07 peter
*** empty log message ***
Revision 1.9 2001/04/21 12:16:28 peter
* int_str cardinal fix (merged)
Revision 1.8 2001/04/13 18:06:28 peter

209
rtl/inc/genset.inc Normal file
View File

@ -0,0 +1,209 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2001 by the Free Pascal development team
Include file with set operations called by the compiler
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.
**********************************************************************}
TYPE
TNormalSet = array[0..31] of byte;
{$ifndef FPC_SYSTEM_HAS_FPC_SET_LOAD_SMALL}
{$Error No pascal version of FPC_SET_LOAD_SMALL}
{ THIS DEPENDS ON THE ENDIAN OF THE ARCHITECTURE! }
{ procedure do_load_small(p : pointer;l:longint);[public,alias:'FPC_SET_LOAD_SMALL'];}
{
load a normal set p from a smallset l
}
{ begin
for i:=0 to 3 do
TNormalSet(p^)[i] := l shr (8*i);
RunError(255);
end;}
{$endif FPC_SYSTEM_HAS_FPC_SET_LOAD_SMALL}
{$ifndef FPC_SYSTEM_HAS_FPC_SET_CREATE_ELEMENT}
procedure do_create_element(p : pointer;b : byte);[public,alias:'FPC_SET_CREATE_ELEMENT'];
{
create a new set in p from an element b
}
begin
Fillchar(p^,32,#0);
TNormalSet(p^)[b div 8] := 1 shl (b mod 8);
end;
{$endif FPC_SYSTEM_HAS_FPC_SET_CREATE_ELEMENT}
{$ifndef FPC_SYSTEM_HAS_FPC_SET_SET_BYTE}
procedure do_set_byte(p : pointer;b : byte);[public,alias:'FPC_SET_SET_BYTE'];
{
add the element b to the set pointed by p
}
var
c: byte;
begin
c := TNormalSet(p^)[b div 8];
c := (1 shl (b mod 8)) or c;
TNormalSet(p^)[b div 8] := c;
end;
{$endif FPC_SYSTEM_HAS_FPC_SET_SET_BYTE}
{$ifndef FPC_SYSTEM_HAS_FPC_SET_UNSET_BYTE}
procedure do_unset_byte(p : pointer;b : byte);[public,alias:'FPC_SET_UNSET_BYTE'];
{
suppresses the element b to the set pointed by p
used for exclude(set,element)
}
var
c: byte;
begin
c := TNormalSet(p^)[b div 8];
c := c and not (1 shl (b mod 8));
TNormalSet(p^)[b div 8] := c;
end;
{$endif FPC_SYSTEM_HAS_FPC_SET_UNSET_BYTE}
{$ifndef FPC_SYSTEM_HAS_FPC_SET_SET_RANGE}
procedure do_set_range(p : pointer;l,h : byte);[public,alias:'FPC_SET_SET_RANGE'];
{
bad implementation, but it's very seldom used
}
var
i: integer;
c: byte;
begin
for i:=l to h do
begin
c := TNormalSet(p^)[i div 8];
c := (1 shl (i mod 8)) or c;
TNormalSet(p^)[i div 8] := c;
end;
end;
{$endif}
{$ifndef FPC_SYSTEM_HAS_FPC_SET_IN_BYTE}
function do_in_byte(p : pointer;b : byte):boolean;[public,alias:'FPC_SET_IN_BYTE'];
{
tests if the element b is in the set p the carryflag is set if it present
}
var
c: byte;
begin
c := TNormalSet(p^)[b div 8];
if ((1 shl (b mod 8)) and c) <> 0 then
do_in_byte := TRUE
else
do_in_byte := FALSE;
end;
{$endif}
{$ifndef FPC_SYSTEM_HAS_FPC_SET_ADD_SETS}
procedure do_add_sets(set1,set2,dest : pointer);[public,alias:'FPC_SET_ADD_SETS'];
{
adds set1 and set2 into set dest
}
var
i: integer;
begin
for i:=0 to 31 do
TnormalSet(dest^)[i] := TNormalSet(set1^)[i] or TNormalSet(set2^)[i];
end;
{$endif}
{$ifndef FPC_SYSTEM_HAS_FPC_SET_MUL_SETS}
procedure do_mul_sets(set1,set2,dest:pointer);[public,alias:'FPC_SET_MUL_SETS'];
{
multiplies (takes common elements of) set1 and set2 result put in dest
}
var
i: integer;
begin
for i:=0 to 31 do
TnormalSet(dest^)[i] := TNormalSet(set1^)[i] and TNormalSet(set2^)[i];
end;
{$endif}
{$ifndef FPC_SYSTEM_HAS_FPC_SET_SUB_SETS}
procedure do_sub_sets(set1,set2,dest:pointer);[public,alias:'FPC_SET_SUB_SETS'];
{
computes the diff from set1 to set2 result in dest
}
var
i: integer;
begin
for i:=0 to 31 do
TnormalSet(dest^)[i] := TNormalSet(set1^)[i] and not TNormalSet(set2^)[i];
end;
{$endif}
{$ifndef FPC_SYSTEM_HAS_FPC_SET_SYMDIF_SETS}
procedure do_symdif_sets(set1,set2,dest:pointer);[public,alias:'FPC_SET_SYMDIF_SETS'];
{
computes the symetric diff from set1 to set2 result in dest
}
var
i: integer;
begin
for i:=0 to 31 do
TnormalSet(dest^)[i] := TNormalSet(set1^)[i] xor TNormalSet(set2^)[i];
end;
{$endif}
{$ifndef FPC_SYSTEM_HAS_FPC_SET_COMP_SETS}
function do_comp_sets(set1,set2 : pointer):boolean;[public,alias:'FPC_SET_COMP_SETS'];
{
compares set1 and set2 zeroflag is set if they are equal
}
var
i: integer;
begin
do_comp_sets := false;
for i:=0 to 31 do
if TNormalSet(set1^)[i] <> TNormalSet(set2^)[i] then
exit;
do_comp_sets := true;
end;
{$endif}
{$ifndef FPC_SYSTEM_HAS_FPC_SET_CONTAINS_SET}
function do_contains_sets(set1,set2 : pointer):boolean;[public,alias:'FPC_SET_CONTAINS_SETS'];
{
on exit, zero flag is set if set1 <= set2 (set2 contains set1)
}
var
i : integer;
begin
do_contains_sets := false;
for i:=0 to 31 do
if (TNormalSet(set1^)[i] and TNormalSet(set2^)[i]) <> TNormalSet(set1^)[i] then
exit;
do_contains_sets := true;
end;
{$endif}
{
$Log$
Revision 1.2 2001-05-09 19:57:07 peter
*** empty log message ***
}

8
rtl/inc/system.inc
View File

@ -104,6 +104,9 @@ Procedure Rewrite(var f : TypedFile); [INTERNPROC: In_Rewrite_TypedFile];
{ Include set support which is processor specific}
{$I set.inc}
{ Include generic pascal routines for sets if the processor }
{ specific routines are not available. }
{$I genset.inc}
{****************************************************************************
@ -636,7 +639,10 @@ end;
{
$Log$
Revision 1.12 2001-04-13 18:06:28 peter
Revision 1.13 2001-05-09 19:57:07 peter
*** empty log message ***
Revision 1.12 2001/04/13 18:06:28 peter
* removed rtllite define
Revision 1.11 2000/12/16 15:56:19 jonas

6
rtl/inc/systemh.inc
View File

@ -76,7 +76,6 @@ Type
ValReal = Real;
{$define SUPPORT_SINGLE}
{$define SUPPORT_DOUBLE}
{$endif}
{ Zero - terminated strings }
@ -492,7 +491,10 @@ const
{
$Log$
Revision 1.20 2001-04-23 18:25:45 peter
Revision 1.21 2001-05-09 19:57:07 peter
*** empty log message ***
Revision 1.20 2001/04/23 18:25:45 peter
* m68k updates
Revision 1.19 2001/04/13 18:06:07 peter

7
rtl/linux/i386/prt0_10.as
View File

@ -63,7 +63,10 @@ ___fpc_brk_addr:
#
# $Log$
# Revision 1.1 2000-10-15 09:09:24 peter
# Revision 1.2 2001-05-09 19:57:07 peter
# *** empty log message ***
#
# Revision 1.1 2000/10/15 09:09:24 peter
# * startup code also needed syslinux->system updates
#
#
#