paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-12-07 05:27:13 +01:00
Code Issues Packages Projects Releases Wiki Activity

* compilerproc implementation of set addition/substraction/...

Browse Source 
* changed the declaration of some set helpers somewhat to accomodate the
    above change
  * i386 still uses the old code for comparisons of sets, because its
    helpers return the results in the flags
  * dummy tc_normal_2_small_set type conversion because I need the original
    resulttype of the set add nodes
  NOTE: you have to start a cycle with 1.0.5!
This commit is contained in:
Jonas Maebe 2001-09-03 13:27:41 +00:00
parent f98641013f
commit f256a47f04
9 changed files with 673 additions and 275 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

212
compiler/i386/n386add.pas
View File

@ -36,6 +36,7 @@ interface
procedure SetResultLocation(cmpop,unsigned : boolean);
protected
function first_addstring : tnode; override;
function first_addset : tnode; override;
private
procedure second_addstring;
procedure second_addset;
@ -257,9 +258,21 @@ interface
Addset
*****************************************************************************}
{ we have to disable the compilerproc handling for all set helpers that }
{ return booleans, because they return their results in the flags }
function ti386addnode.first_addset : tnode;
begin
if is_boolean(resulttype.def) then
begin
result := nil;
exit;
end;
result := inherited first_addset;
end;
procedure ti386addnode.second_addset;
var
createset,
cmpop,
pushed : boolean;
href : treference;
@ -272,16 +285,7 @@ interface
if nf_swaped in flags then
swapleftright;
{ optimize first loading of a set }
if (right.nodetype=setelementn) and
not(assigned(tsetelementnode(right).right)) and
is_emptyset(left) then
createset:=true
else
begin
createset:=false;
secondpass(left);
end;
secondpass(left);
{ are too few registers free? }
pushed:=maybe_push(right.registers32,left,false);
@ -294,151 +298,45 @@ interface
set_location(location,left.location);
{ handle operations }
{ (the rest is handled by compilerprocs in pass 1) (JM) }
case nodetype of
equaln,
unequaln
,lten, gten
: begin
cmpop:=true;
del_location(left.location);
del_location(right.location);
pushusedregisters(pushedregs,$ff);
If (nodetype in [equaln, unequaln, lten]) Then
Begin
emitpushreferenceaddr(right.location.reference);
emitpushreferenceaddr(left.location.reference);
End
Else {gten = lten, if the arguments are reversed}
Begin
emitpushreferenceaddr(left.location.reference);
emitpushreferenceaddr(right.location.reference);
End;
saveregvars($ff);
Case nodetype of
equaln, unequaln:
emitcall('FPC_SET_COMP_SETS');
lten, gten:
Begin
emitcall('FPC_SET_CONTAINS_SETS');
{ we need a jne afterwards, not a jnbe/jnae }
nodetype := equaln;
End;
End;
maybe_loadself;
popusedregisters(pushedregs);
ungetiftemp(left.location.reference);
ungetiftemp(right.location.reference);
end;
addn : begin
{ add can be an other SET or Range or Element ! }
{ del_location(right.location);
done in pushsetelement below PM
And someone added it again because those registers must
not be pushed by the pushusedregisters, however this
breaks the optimizer (JM)
del_location(right.location);
pushusedregisters(pushedregs,$ff);}
regstopush := $ff;
remove_non_regvars_from_loc(right.location,regstopush);
if (right.nodetype = setelementn) and
assigned(tsetelementnode(right).right) then
remove_non_regvars_from_loc(tsetelementnode(right).right.location,regstopush);
remove_non_regvars_from_loc(left.location,regstopush);
pushusedregisters(pushedregs,regstopush);
{ this is still right before the instruction that uses }
{ left.location, but that can be fixed by the }
{ optimizer. There must never be an additional }
{ between the release and the use, because that is not }
{ detected/fixed. As Pierre said above, right.loc }
{ will be released in pushsetelement (JM) }
del_location(left.location);
href.symbol:=nil;
gettempofsizereference(32,href);
if createset then
begin
pushsetelement(tunarynode(right).left);
emitpushreferenceaddr(href);
saveregvars(regstopush);
emitcall('FPC_SET_CREATE_ELEMENT');
end
else
begin
{ add a range or a single element? }
if right.nodetype=setelementn then
begin
concatcopy(left.location.reference,href,32,false,false);
if assigned(tbinarynode(right).right) then
begin
pushsetelement(tbinarynode(right).right);
pushsetelement(tunarynode(right).left);
emitpushreferenceaddr(href);
saveregvars(regstopush);
emitcall('FPC_SET_SET_RANGE');
end
else
begin
pushsetelement(tunarynode(right).left);
emitpushreferenceaddr(href);
saveregvars(regstopush);
emitcall('FPC_SET_SET_BYTE');
end;
end
else
begin
{ must be an other set }
emitpushreferenceaddr(href);
emitpushreferenceaddr(right.location.reference);
emitpushreferenceaddr(left.location.reference);
saveregvars(regstopush);
emitcall('FPC_SET_ADD_SETS');
end;
end;
maybe_loadself;
popusedregisters(pushedregs);
ungetiftemp(left.location.reference);
ungetiftemp(right.location.reference);
location.loc:=LOC_MEM;
location.reference:=href;
end;
subn,
symdifn,
muln : begin
{ Find out which registers have to pushed (JM) }
regstopush := $ff;
remove_non_regvars_from_loc(left.location,regstopush);
remove_non_regvars_from_loc(right.location,regstopush);
{ Push them (JM) }
pushusedregisters(pushedregs,regstopush);
href.symbol:=nil;
gettempofsizereference(32,href);
emitpushreferenceaddr(href);
{ Release the registers right before they're used, }
{ see explanation in cgai386.pas:loadansistring for }
{ info why this is done right before the push (JM) }
del_location(right.location);
emitpushreferenceaddr(right.location.reference);
{ The same here }
del_location(left.location);
emitpushreferenceaddr(left.location.reference);
saveregvars(regstopush);
case nodetype of
subn : emitcall('FPC_SET_SUB_SETS');
symdifn : emitcall('FPC_SET_SYMDIF_SETS');
muln : emitcall('FPC_SET_MUL_SETS');
end;
maybe_loadself;
popusedregisters(pushedregs);
ungetiftemp(left.location.reference);
ungetiftemp(right.location.reference);
location.loc:=LOC_MEM;
location.reference:=href;
end;
,lten, gten :
begin
cmpop:=true;
del_location(left.location);
del_location(right.location);
pushusedregisters(pushedregs,$ff);
If (nodetype in [equaln, unequaln, lten]) Then
Begin
emitpushreferenceaddr(right.location.reference);
emitpushreferenceaddr(left.location.reference);
End
Else {gten = lten, if the arguments are reversed}
Begin
emitpushreferenceaddr(left.location.reference);
emitpushreferenceaddr(right.location.reference);
End;
saveregvars($ff);
Case nodetype of
equaln, unequaln:
emitcall('FPC_SET_COMP_SETS');
lten, gten:
Begin
emitcall('FPC_SET_CONTAINS_SETS');
{ we need a jne afterwards, not a jnbe/jnae }
nodetype := equaln;
End;
End;
maybe_loadself;
popusedregisters(pushedregs);
ungetiftemp(left.location.reference);
ungetiftemp(right.location.reference);
end;
else
CGMessage(type_e_mismatch);
internalerror(200108314);
end;
SetResultLocation(cmpop,true);
end;
@ -2082,7 +1980,17 @@ begin
end.
{
$Log$
Revision 1.20 2001-08-30 15:43:14 jonas
Revision 1.21 2001-09-03 13:27:42 jonas
* compilerproc implementation of set addition/substraction/...
* changed the declaration of some set helpers somewhat to accomodate the
above change
* i386 still uses the old code for comparisons of sets, because its
helpers return the results in the flags
* dummy tc_normal_2_small_set type conversion because I need the original
resulttype of the set add nodes
NOTE: you have to start a cycle with 1.0.5!
Revision 1.20 2001/08/30 15:43:14 jonas
* converted adding/comparing of strings to compileproc. Note that due
to the way the shortstring helpers for i386 are written, they are
still handled by the old code (reason: fpc_shortstr_compare returns

15
compiler/i386/n386cnv.pas
View File

@ -806,7 +806,8 @@ implementation
@ti386typeconvnode.second_nothing, { interface 2 string }
@ti386typeconvnode.second_nothing, { interface 2 guid }
@ti386typeconvnode.second_class_to_intf,
@ti386typeconvnode.second_char_to_char
@ti386typeconvnode.second_char_to_char,
@ti386typeconvnode.second_nothing { normal_2_smallset }
);
type
tprocedureofobject = procedure of object;
@ -1000,7 +1001,17 @@ begin
end.
{
$Log$
Revision 1.22 2001-08-29 19:49:03 jonas
Revision 1.23 2001-09-03 13:27:42 jonas
* compilerproc implementation of set addition/substraction/...
* changed the declaration of some set helpers somewhat to accomodate the
above change
* i386 still uses the old code for comparisons of sets, because its
helpers return the results in the flags
* dummy tc_normal_2_small_set type conversion because I need the original
resulttype of the set add nodes
NOTE: you have to start a cycle with 1.0.5!
Revision 1.22 2001/08/29 19:49:03 jonas
* some fixes in compilerprocs for chararray to string conversions
* conversion from string to chararray is now also done via compilerprocs

176
compiler/nadd.pas
View File

@ -38,6 +38,7 @@ interface
{ override the following if you want to implement }
{ parts explicitely in the code generator (JM) }
function first_addstring: tnode; virtual;
function first_addset: tnode; virtual;
end;
taddnodeclass = class of taddnode;
@ -53,7 +54,7 @@ implementation
uses
globtype,systems,
cutils,verbose,globals,widestr,
symconst,symtype,symdef,symsym,types,
symconst,symtype,symbase,symdef,symsym,symtable,types,
cpuinfo,
cgbase,
htypechk,pass_1,
@ -1110,6 +1111,164 @@ implementation
end;
function taddnode.first_addset: tnode;
var
procname: string[31];
tempn: tnode;
paras: tcallparanode;
srsym: ttypesym;
symowner: tsymtable;
createset: boolean;
begin
{ get the sym that represents the fpc_normal_set type }
if not(cs_compilesystem in aktmoduleswitches) then
srsym := ttypesym(searchsymonlyin(systemunit,'FPC_NORMAL_SET'))
else
searchsym('FPC_NORMAL_SET',tsym(srsym),symowner);
if not assigned(srsym) or
(srsym.typ <> typesym) then
internalerror(200108313);
case nodetype of
equaln,unequaln,lten,gten:
begin
case nodetype of
equaln,unequaln:
procname := 'fpc_set_comp_sets';
lten,gten:
begin
procname := 'fpc_set_contains_set';
{ (left >= right) = (right <= left) }
if nodetype = gten then
begin
tempn := left;
left := right;
right := tempn;
end;
end;
end;
{ convert the arguments (explicitely) to fpc_normal_set's }
left := ctypeconvnode.create(left,srsym.restype);
right := ctypeconvnode.create(right,srsym.restype);
result := ccallnode.createintern(procname,ccallparanode.create(right,
ccallparanode.create(left,nil)));
{ left and right are reused as parameters }
left := nil;
right := nil;
{ for an unequaln, we have to negate the result of comp_sets }
if nodetype = unequaln then
result := cnotnode.create(result);
end;
addn:
begin
{ optimize first loading of a set }
if (right.nodetype=setelementn) and
not(assigned(tsetelementnode(right).right)) and
is_emptyset(left) then
begin
{ type cast the value to pass as argument to a byte, }
{ since that's what the helper expects }
tsetelementnode(right).left :=
ctypeconvnode.create(tsetelementnode(right).left,u8bittype);
tsetelementnode(right).left.toggleflag(nf_explizit);
{ set the resulttype to the actual one (otherwise it's }
{ "fpc_normal_set") }
result := ccallnode.createinternres('fpc_set_create_element',
ccallparanode.create(tsetelementnode(right).left,nil),
resulttype);
{ reused }
tsetelementnode(right).left := nil;
end
else
begin
if right.nodetype=setelementn then
begin
{ convert the arguments to bytes, since that's what }
{ the helper expects }
tsetelementnode(right).left :=
ctypeconvnode.create(tsetelementnode(right).left,
u8bittype);
tsetelementnode(right).left.toggleflag(nf_explizit);
{ convert the original set (explicitely) to an }
{ fpc_normal_set so we can pass it to the helper }
left := ctypeconvnode.create(left,srsym.restype);
left.toggleflag(nf_explizit);
{ add a range or a single element? }
if assigned(tsetelementnode(right).right) then
begin
tsetelementnode(right).right :=
ctypeconvnode.create(tsetelementnode(right).right,
u8bittype);
tsetelementnode(right).right.toggleflag(nf_explizit);
{ create the call }
result := ccallnode.createinternres('fpc_set_set_range',
ccallparanode.create(tsetelementnode(right).right,
ccallparanode.create(tsetelementnode(right).left,
ccallparanode.create(left,nil))),resulttype);
end
else
begin
result := ccallnode.createinternres('fpc_set_set_byte',
ccallparanode.create(tsetelementnode(right).left,
ccallparanode.create(left,nil)),resulttype);
end;
{ remove reused parts from original node }
tsetelementnode(right).right := nil;
tsetelementnode(right).left := nil;
left := nil;
end
else
begin
{ add two sets }
{ convert the sets to fpc_normal_set's }
left := ctypeconvnode.create(left,srsym.restype);
left.toggleflag(nf_explizit);
right := ctypeconvnode.create(right,srsym.restype);
right.toggleflag(nf_explizit);
result := ccallnode.createinternres('fpc_set_add_sets',
ccallparanode.create(right,
ccallparanode.create(left,nil)),resulttype);
{ remove reused parts from original node }
left := nil;
right := nil;
end;
end
end;
subn,symdifn,muln:
begin
{ convert the sets to fpc_normal_set's }
left := ctypeconvnode.create(left,srsym.restype);
left.toggleflag(nf_explizit);
right := ctypeconvnode.create(right,srsym.restype);
right.toggleflag(nf_explizit);
paras := ccallparanode.create(right,
ccallparanode.create(left,nil));
case nodetype of
subn:
result := ccallnode.createinternres('fpc_set_sub_sets',
paras,resulttype);
symdifn:
result := ccallnode.createinternres('fpc_set_symdif_sets',
paras,resulttype);
muln:
result := ccallnode.createinternres('fpc_set_mul_sets',
paras,resulttype);
end;
{ remove reused parts from original node }
left := nil;
right := nil;
end;
else
internalerror(200108311);
end;
firstpass(result);
end;
function taddnode.pass_1 : tnode;
var
hp : tnode;
@ -1203,6 +1362,9 @@ implementation
end
else
begin
result := first_addset;
if assigned(result) then
exit;
calcregisters(self,0,0,0);
{ here we call SET... }
procinfo^.flags:=procinfo^.flags or pi_do_call;
@ -1369,7 +1531,17 @@ begin
end.
{
$Log$
Revision 1.36 2001-09-02 21:12:06 peter
Revision 1.37 2001-09-03 13:27:42 jonas
* compilerproc implementation of set addition/substraction/...
* changed the declaration of some set helpers somewhat to accomodate the
above change
* i386 still uses the old code for comparisons of sets, because its
helpers return the results in the flags
* dummy tc_normal_2_small_set type conversion because I need the original
resulttype of the set add nodes
NOTE: you have to start a cycle with 1.0.5!
Revision 1.36 2001/09/02 21:12:06 peter
* move class of definitions into type section for delphi
Revision 1.35 2001/08/31 15:42:15 jonas

56
compiler/ncnv.pas
View File

@ -126,7 +126,10 @@ implementation
end;
{ don't insert obsolete type conversions }
if is_equal(p.resulttype.def,t.def) then
if is_equal(p.resulttype.def,t.def) and
not ((p.resulttype.def.deftype=setdef) and
(tsetdef(p.resulttype.def).settype <>
tsetdef(t.def).settype)) then
begin
p.resulttype:=t;
end
@ -686,7 +689,8 @@ implementation
{ intf_2_string } nil,
{ intf_2_guid } nil,
{ class_2_intf } nil,
{ char_2_char } @ttypeconvnode.resulttype_char_to_char
{ char_2_char } @ttypeconvnode.resulttype_char_to_char,
{ nomal_2_smallset} nil
);
type
tprocedureofobject = function : tnode of object;
@ -725,19 +729,24 @@ implementation
check here if we are loading a smallset into a normalset }
if (resulttype.def.deftype=setdef) and
(left.resulttype.def.deftype=setdef) and
(tsetdef(resulttype.def).settype<>smallset) and
(tsetdef(left.resulttype.def).settype=smallset) then
begin
{ try to define the set as a normalset if it's a constant set }
if left.nodetype=setconstn then
begin
resulttype:=left.resulttype;
tsetdef(resulttype.def).settype:=normset
end
else
convtype:=tc_load_smallset;
exit;
end
((tsetdef(resulttype.def).settype = smallset) xor
(tsetdef(left.resulttype.def).settype = smallset)) then
begin
{ try to define the set as a normalset if it's a constant set }
if (tsetdef(resulttype.def).settype <> smallset) then
begin
if (left.nodetype=setconstn) then
begin
resulttype:=left.resulttype;
tsetdef(resulttype.def).settype:=normset
end
else
convtype:=tc_load_smallset;
end
else
convtype := tc_normal_2_smallset;
exit;
end
else
begin
left.resulttype:=resulttype;
@ -1274,7 +1283,8 @@ implementation
@ttypeconvnode.first_nothing,
@ttypeconvnode.first_nothing,
@ttypeconvnode.first_class_to_intf,
@ttypeconvnode.first_char_to_char
@ttypeconvnode.first_char_to_char,
@ttypeconvnode.first_nothing
);
type
tprocedureofobject = function : tnode of object;
@ -1466,7 +1476,17 @@ begin
end.
{
$Log$
Revision 1.36 2001-09-02 21:12:06 peter
Revision 1.37 2001-09-03 13:27:42 jonas
* compilerproc implementation of set addition/substraction/...
* changed the declaration of some set helpers somewhat to accomodate the
above change
* i386 still uses the old code for comparisons of sets, because its
helpers return the results in the flags
* dummy tc_normal_2_small_set type conversion because I need the original
resulttype of the set add nodes
NOTE: you have to start a cycle with 1.0.5!
Revision 1.36 2001/09/02 21:12:06 peter
* move class of definitions into type section for delphi
Revision 1.35 2001/08/29 19:49:03 jonas
@ -1489,7 +1509,7 @@ end.
Revision 1.33 2001/08/28 13:24:46 jonas
+ compilerproc implementation of most string-related type conversions
- removed all code from the compiler which has been replaced by
compilerproc implementations (using {$ifdef hascompilerproc} is not
compilerproc implementations (using (ifdef hascompilerproc) is not
necessary in the compiler)
Revision 1.32 2001/08/26 13:36:40 florian

15
compiler/types.pas
View File

@ -184,7 +184,8 @@ interface
tc_intf_2_string,
tc_intf_2_guid,
tc_class_2_intf,
tc_char_2_char
tc_char_2_char,
tc_normal_2_smallset
);
function assignment_overloaded(from_def,to_def : tdef) : tprocdef;
@ -1783,7 +1784,17 @@ implementation
end.
{
$Log$
Revision 1.46 2001-09-02 21:15:34 peter
Revision 1.47 2001-09-03 13:27:41 jonas
* compilerproc implementation of set addition/substraction/...
* changed the declaration of some set helpers somewhat to accomodate the
above change
* i386 still uses the old code for comparisons of sets, because its
helpers return the results in the flags
* dummy tc_normal_2_small_set type conversion because I need the original
resulttype of the set add nodes
NOTE: you have to start a cycle with 1.0.5!
Revision 1.46 2001/09/02 21:15:34 peter
* don't allow int64->real for delphi mode
Revision 1.45 2001/08/19 21:11:21 florian

242
rtl/i386/set.inc
View File

@ -14,55 +14,89 @@
**********************************************************************}
{$ifndef hascompilerproc}
type
fpc_small_set = set of 0..31;
fpc_normal_set = set of byte;
{$endif hascompilerproc}
{$define FPC_SYSTEM_HAS_FPC_SET_LOAD_SMALL}
procedure fpc_set_load_small(p : pointer;l:longint);assembler;[public,alias:'FPC_SET_LOAD_SMALL']; {$ifdef hascompilerproc} compilerproc; {$endif}
function fpc_set_load_small(l: fpc_small_set): fpc_normal_set;assembler;[public,alias:'FPC_SET_LOAD_SMALL']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
load a normal set p from a smallset l
}
asm
movl p,%edi
movl __RESULT,%edi
movl l,%eax
movl %eax,(%edi)
addl $4,%edi
movl $7,%ecx
movl %eax,4(%edi)
addl $4,%edi
xorl %eax,%eax
rep
stosl
end;
end ['EAX','ECX','EDI'];
{$define FPC_SYSTEM_HAS_FPC_SET_CREATE_ELEMENT}
procedure fpc_set_create_element(p : pointer;b : byte);assembler;[public,alias:'FPC_SET_CREATE_ELEMENT']; {$ifdef hascompilerproc} compilerproc; {$endif}
function fpc_set_create_element(b : byte): fpc_normal_set;assembler;[public,alias:'FPC_SET_CREATE_ELEMENT']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
create a new set in p from an element b
}
asm
{$ifndef hascompilerproc}
pushl %eax
pushl %ecx
movl p,%edi
{$endif not hascompilerproc}
movl __RESULT,%edi
xorl %eax,%eax
movl $8,%ecx
rep
stosl
movb b,%al
movl p,%edi
movl __RESULT,%edi
movl %eax,%ecx
shrl $3,%eax
andl $7,%ecx
addl %eax,%edi
btsl %ecx,(%edi)
{$ifdef hascompilerproc}
movl __RESULT,%edi
{$else hascompilerproc}
popl %ecx
popl %eax
end;
{$endif hascompilerproc}
end ['EAX','ECX','EDI'];
{$define FPC_SYSTEM_HAS_FPC_SET_SET_BYTE}
procedure fpc_set_set_byte(p : pointer;b : byte);assembler;[public,alias:'FPC_SET_SET_BYTE']; {$ifdef hascompilerproc} compilerproc; {$endif}
{$ifdef hascompilerproc}
function fpc_set_set_byte(const source: fpc_normal_set; b : byte): fpc_normal_set;assembler; compilerproc;
{
add the element b to the set pointed by source
}
asm
movl $8,%ecx
movl source,%esi
movl __RESULT,%edi
movb b,%al
rep
movsl
andl $0xf8,%eax
subl $32,%edi
shrl $3,%eax
addl %eax,%edi
movb b,%al
andl $7,%eax
btsl %eax,(%edi)
end ['EAX','ECX','EDI'];
{$else hascompilerproc}
function fpc_set_set_byte(b : byte): fpc_normal_set;assembler;[public,alias:'FPC_SET_SET_BYTE'];
{
add the element b to the set pointed by p
}
asm
pushl %eax
movl p,%edi
movl __RESULT,%edi
movb b,%al
andl $0xf8,%eax
shrl $3,%eax
@ -72,17 +106,39 @@ asm
btsl %eax,(%edi)
popl %eax
end;
{$endif hascompilerproc}
{$define FPC_SYSTEM_HAS_FPC_SET_UNSET_BYTE}
procedure fpc_set_unset_byte(p : pointer;b : byte);assembler;[public,alias:'FPC_SET_UNSET_BYTE']; {$ifdef hascompilerproc} compilerproc; {$endif}
{$ifdef hascompilerproc}
function fpc_set_unset_byte(const source: fpc_normal_set; b : byte): fpc_normal_set;assembler; compilerproc;
{
add the element b to the set pointed by source
}
asm
movl $8,%ecx
movl source,%esi
movl __RESULT,%edi
movb b,%al
rep
movsl
andl $0xf8,%eax
subl $32,%edi
shrl $3,%eax
addl %eax,%edi
movb b,%al
andl $7,%eax
btrl %eax,(%edi)
end ['EAX','ECX','EDI'];
{$else hascompilerproc}
function fpc_set_unset_byte(b : byte): fpc_normal_set;assembler;[public,alias:'FPC_SET_UNSET_BYTE']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
suppresses the element b to the set pointed by p
used for exclude(set,element)
}
asm
pushl %eax
movl p,%edi
movl __RESULT,%edi
movb b,%al
andl $0xf8,%eax
shrl $3,%eax
@ -92,20 +148,73 @@ asm
btrl %eax,(%edi)
popl %eax
end;
{$endif hascompilerproc}
{$define FPC_SYSTEM_HAS_FPC_SET_SET_RANGE}
procedure fpc_set_set_range(p : pointer;l,h : byte);assembler;[public,alias:'FPC_SET_SET_RANGE']; {$ifdef hascompilerproc} compilerproc; {$endif}
{$ifdef hascompilerproc}
function fpc_set_set_range(const orgset: fpc_normal_set; l,h : byte): fpc_normal_set;assembler; compilerproc;
{
adds the range [l..h] to the set pointed to by p
}
asm
movzbl l,%eax // lowest bit to be set in eax
movzbl h,%ebx // highest in ebx
movl $8,%ecx // we have to copy 32 bytes
movl __RESULT,%edi // target set address in edi
movl orgset, %esi // source set address in esi
cmpl %eax,%ebx // high < low?
rep // copy source to dest (it's possible to do the range
movsl // setting and copying simultanuously of course, but
// that would result in many more jumps and code)
movl %eax,%ecx // lowest also in ecx
jb .Lset_range_done // if high > low, then dest := source
shrl $3,%eax // divide by 8 to get starting and ending byte
shrl $3,%ebx // address
andb $31,%cl // low five bits of lo determine start of bit mask
andl $0x0fffffffc,%eax // clear two lowest bits to get start/end longint
subl $32,%edi // get back to start of dest
andl $0x0fffffffc,%ebx // address * 4
movl $0x0ffffffff,%edx // edx = bitmask to be inserted
shll %cl,%edx // shift bitmask to clear bits below lo
addl %eax,%edi // go to starting pos in set
subl %eax,%ebx // are bit lo and hi in the same longint?
jz .Lset_range_hi // yes, keep current mask and adjust for hi bit
orl %edx,(%edi) // no, store current mask
movl $0x0ffffffff,%edx // new mask
addl $4,%edi // next longint of set
subl $4,%ebx // bit hi in this longint?
jz .Lset_range_hi // yes, keep full mask and adjust for hi bit
.Lset_range_loop:
movl %edx,(%edi) // no, fill longints in between with full mask
addl $4,%edi
subl $4,%ebx
jnz .Lset_range_loop
.Lset_range_hi:
movb h,%cl
movl %edx,%ebx // save current bitmask
andb $31,%cl
subb $31,%cl // cl := (31 - (hi and 31)) = shift count to
negb %cl // adjust bitmask for hi bit
shrl %cl,%edx // shift bitmask to clear bits higher than hi
andl %edx,%ebx // combine both bitmasks
orl %ebx,(%edi) // store to set
.Lset_range_done:
end;
{$else hascompilerproc}
function fpc_set_set_range(l,h : byte): fpc_normal_set;assembler;[public,alias:'FPC_SET_SET_RANGE'];
{
adds the range [l..h] to the set pointed to by p
}
asm
pushl %eax
movzbl l,%eax // lowest bit to be set in eax
movzbl h,%ebx // highest in ebx
cmpl %eax,%ebx
jb .Lset_range_done
movl p,%edi // set address in edi
movl __RESULT,%edi // set address in edi
movl %eax,%ecx // lowest also in ecx
shrl $3,%eax // divide by 8 to get starting and ending byte
shrl $3,%ebx // address
@ -137,12 +246,22 @@ asm
andl %edx,%ebx // combine both bitmasks
orl %ebx,(%edi) // store to set
.Lset_range_done:
popl %eax
end;
{$endif hascompilerproc}
{$define FPC_SYSTEM_HAS_FPC_SET_IN_BYTE}
procedure fpc_set_in_byte(p : pointer;b : byte);assembler;[public,alias:'FPC_SET_IN_BYTE']; {$ifdef hascompilerproc} compilerproc; {$endif}
{$ifdef hascompilerproc}
{ can't use as compilerproc, it returns its results in the flags :/ }
function fpc_set_in_byte(const p: fpc_normal_set; b: byte): boolean; compilerproc;
begin
fpc_set_in_byte := false;
{ make sure we won't accidentally call it }
runerror(216);
end;
{$endif hascompilerproc}
function fpc_set_in_byte_i386(p: pointer; b : byte): boolean;assembler;[public,alias:'FPC_SET_IN_BYTE'];
{
tests if the element b is in the set p the carryflag is set if it present
}
@ -161,14 +280,23 @@ end;
{$define FPC_SYSTEM_HAS_FPC_SET_ADD_SETS}
procedure fpc_set_add_sets(set1,set2,dest : pointer);assembler;[public,alias:'FPC_SET_ADD_SETS']; {$ifdef hascompilerproc} compilerproc; {$endif}
{$ifdef hascompilerproc}
function fpc_set_add_sets(const set1,set2: fpc_normal_set): fpc_normal_set;assembler;[public,alias:'FPC_SET_ADD_SETS']; compilerproc;
{$else hascompilerproc}
procedure fpc_set_add_sets(set1,set2,dest : pointer);assembler;[public,alias:'FPC_SET_ADD_SETS'];
{$endif hascompilerproc}
{
adds set1 and set2 into set dest
}
asm
movl set1,%esi
movl set2,%ebx
{$ifdef hascompilerproc}
movl __RESULT,%edi
{$else hascompilerproc}
movl dest,%edi
{$endif hascompilerproc}
movl $8,%ecx
.LMADDSETS1:
lodsl
@ -181,14 +309,23 @@ end;
{$define FPC_SYSTEM_HAS_FPC_SET_MUL_SETS}
procedure fpc_set_mul_sets(set1,set2,dest:pointer);assembler;[public,alias:'FPC_SET_MUL_SETS']; {$ifdef hascompilerproc} compilerproc; {$endif}
{$ifdef hascompilerproc}
function fpc_set_mul_sets(const set1,set2: fpc_normal_set): fpc_normal_set;assembler;[public,alias:'FPC_SET_MUL_SETS']; compilerproc;
{$else hascompilerproc}
procedure fpc_set_mul_sets(set1,set2,dest:pointer);assembler;[public,alias:'FPC_SET_MUL_SETS'];
{$endif hascompilerproc}
{
multiplies (takes common elements of) set1 and set2 result put in dest
}
asm
movl set1,%esi
movl set2,%ebx
{$ifdef hascompilerproc}
movl __RESULT,%edi
{$else hascompilerproc}
movl dest,%edi
{$endif hascompilerproc}
movl $8,%ecx
.LMMULSETS1:
lodsl
@ -201,14 +338,23 @@ end;
{$define FPC_SYSTEM_HAS_FPC_SET_SUB_SETS}
procedure fpc_set_sub_sets(set1,set2,dest:pointer);assembler;[public,alias:'FPC_SET_SUB_SETS']; {$ifdef hascompilerproc} compilerproc; {$endif}
{$ifdef hascompilerproc}
function fpc_set_sub_sets(const set1,set2: fpc_normal_set): fpc_normal_set;assembler;[public,alias:'FPC_SET_SUB_SETS']; compilerproc;
{$else hascompilerproc}
procedure fpc_set_sub_sets(set1,set2,dest:pointer);assembler;[public,alias:'FPC_SET_SUB_SETS'];
{$endif hascompilerproc}
{
computes the diff from set1 to set2 result in dest
}
asm
movl set1,%esi
movl set2,%ebx
movl dest,%edi
{$ifdef hascompilerproc}
movl __RESULT,%edi
{$else hascompilerproc}
movl dest,%edi
{$endif hascompilerproc}
movl $8,%ecx
.LMSUBSETS1:
lodsl
@ -223,14 +369,23 @@ end;
{$define FPC_SYSTEM_HAS_FPC_SET_SYMDIF_SETS}
procedure fpc_set_symdif_sets(set1,set2,dest:pointer);assembler;[public,alias:'FPC_SET_SYMDIF_SETS']; {$ifdef hascompilerproc} compilerproc; {$endif}
{$ifdef hascompilerproc}
function fpc_set_symdif_sets(const set1,set2: fpc_normal_set): fpc_normal_set;assembler;[public,alias:'FPC_SET_SYMDIF_SETS']; compilerproc;
{$else hascompilerproc}
procedure fpc_set_symdif_sets(set1,set2,dest:pointer);assembler;[public,alias:'FPC_SET_SYMDIF_SETS'];
{$endif hascompilerproc}
{
computes the symetric diff from set1 to set2 result in dest
}
asm
movl set1,%esi
movl set2,%ebx
movl dest,%edi
{$ifdef hascompilerproc}
movl __RESULT,%edi
{$else hascompilerproc}
movl dest,%edi
{$endif hascompilerproc}
movl $8,%ecx
.LMSYMDIFSETS1:
lodsl
@ -244,7 +399,18 @@ end;
{$define FPC_SYSTEM_HAS_FPC_SET_COMP_SETS}
procedure fpc_set_comp_sets(set1,set2 : pointer);assembler;[public,alias:'FPC_SET_COMP_SETS']; {$ifdef hascompilerproc} compilerproc; {$endif}
{$ifdef hascompilerproc}
{ can't use as compilerproc, it returns its results in the flags :/ }
function fpc_set_comp_sets(const set1,set2: fpc_normal_set): boolean; compilerproc;
begin
fpc_set_comp_sets := false;
{ make sure we won't accidentally call it }
runerror(216);
end;
{$endif hascompilerproc}
procedure fpc_set_comp_sets_i386(set1,set2 : pointer);assembler;[public,alias:'FPC_SET_COMP_SETS'];
{
compares set1 and set2 zeroflag is set if they are equal
}
@ -269,7 +435,17 @@ end;
{$define FPC_SYSTEM_HAS_FPC_SET_CONTAINS_SET}
procedure fpc_set_contains_sets(set1,set2 : pointer);assembler;[public,alias:'FPC_SET_CONTAINS_SETS']; {$ifdef hascompilerproc} compilerproc; {$endif}
{$ifdef hascompilerproc}
{ can't use as compilerproc, it returns its results in the flags :/ }
function fpc_set_contains_sets(const set1,set2: fpc_normal_set): boolean; compilerproc;
begin
fpc_set_contains_sets := false;
{ make sure we won't accidentally call it }
runerror(216);
end;
{$endif hascompilerproc}
procedure fpc_set_contains_sets_i386(set1,set2 : pointer);assembler;[public,alias:'FPC_SET_CONTAINS_SETS'];
{
on exit, zero flag is set if set1 <= set2 (set2 contains set1)
}
@ -455,7 +631,17 @@ end;
{
$Log$
Revision 1.5 2001-08-01 15:00:10 jonas
Revision 1.6 2001-09-03 13:27:43 jonas
* compilerproc implementation of set addition/substraction/...
* changed the declaration of some set helpers somewhat to accomodate the
above change
* i386 still uses the old code for comparisons of sets, because its
helpers return the results in the flags
* dummy tc_normal_2_small_set type conversion because I need the original
resulttype of the set add nodes
NOTE: you have to start a cycle with 1.0.5!
Revision 1.5 2001/08/01 15:00:10 jonas
+ "compproc" helpers
* renamed several helpers so that their name is the same as their
"public alias", which should facilitate the conversion of processor

39
rtl/inc/compproc.inc
View File

@ -24,8 +24,11 @@
{$ifdef hascompilerproc}
{ some dummy types necessary to have generic resulttypes for certain compilerprocs }
type
fpc_big_chararray = array[0..maxlongint] of char;
fpc_small_set = set of 0..31;
fpc_normal_set = set of byte;
procedure fpc_Shortstr_SetLength(var s:shortstring;len:StrLenInt); compilerproc;
function fpc_shortstr_to_shortstr(len:longint; const sstr: shortstring): shortstring; compilerproc;
@ -186,18 +189,18 @@ Procedure fpc_Addref (Data,TypeInfo : Pointer); compilerproc;
Procedure fpc_DecRef (Data,TypeInfo : Pointer); compilerproc;
procedure fpc_FinalizeArray(data,typeinfo : pointer;count,size : longint); compilerproc;
procedure fpc_set_load_small(p : pointer;l:longint); compilerproc;
procedure fpc_set_create_element(p : pointer;b : byte); compilerproc;
procedure fpc_set_set_byte(p : pointer;b : byte); compilerproc;
procedure fpc_set_unset_byte(p : pointer;b : byte); compilerproc;
procedure fpc_set_set_range(p : pointer;l,h : byte); compilerproc;
procedure fpc_set_in_byte(p : pointer;b : byte); compilerproc;
procedure fpc_set_add_sets(set1,set2,dest : pointer); compilerproc;
procedure fpc_set_mul_sets(set1,set2,dest:pointer); compilerproc;
procedure fpc_set_sub_sets(set1,set2,dest:pointer); compilerproc;
procedure fpc_set_symdif_sets(set1,set2,dest:pointer); compilerproc;
procedure fpc_set_comp_sets(set1,set2 : pointer); compilerproc;
procedure fpc_set_contains_sets(set1,set2 : pointer); compilerproc;
function fpc_set_load_small(l: fpc_small_set): fpc_normal_set; compilerproc;
function fpc_set_create_element(b : byte): fpc_normal_set; compilerproc;
function fpc_set_set_byte(const source: fpc_normal_set; b : byte): fpc_normal_set; compilerproc;
function fpc_set_unset_byte(const source: fpc_normal_set; b : byte): fpc_normal_set; compilerproc;
function fpc_set_set_range(const orgset: fpc_normal_set; l,h : byte): fpc_normal_set; compilerproc;
function fpc_set_in_byte(const p: fpc_normal_set; b: byte): boolean; compilerproc;
function fpc_set_add_sets(const set1,set2: fpc_normal_set): fpc_normal_set; compilerproc;
function fpc_set_mul_sets(const set1,set2: fpc_normal_set): fpc_normal_set; compilerproc;
function fpc_set_sub_sets(const set1,set2: fpc_normal_set): fpc_normal_set; compilerproc;
function fpc_set_symdif_sets(const set1,set2: fpc_normal_set): fpc_normal_set; compilerproc;
function fpc_set_comp_sets(const set1,set2: fpc_normal_set): boolean; compilerproc;
function fpc_set_contains_sets(const set1,set2: fpc_normal_set): boolean; compilerproc;
{$ifdef LARGESETS}
procedure fpc_largeset_set_word(p : pointer;b : word); compilerproc;
@ -237,7 +240,17 @@ Procedure fpc_typed_read(TypeSize : Longint;var f : TypedFile;var Buf); compiler
{
$Log$
Revision 1.7 2001-08-30 15:43:15 jonas
Revision 1.8 2001-09-03 13:27:43 jonas
* compilerproc implementation of set addition/substraction/...
* changed the declaration of some set helpers somewhat to accomodate the
above change
* i386 still uses the old code for comparisons of sets, because its
helpers return the results in the flags
* dummy tc_normal_2_small_set type conversion because I need the original
resulttype of the set add nodes
NOTE: you have to start a cycle with 1.0.5!
Revision 1.7 2001/08/30 15:43:15 jonas
* converted adding/comparing of strings to compileproc. Note that due
to the way the shortstring helpers for i386 are written, they are
still handled by the old code (reason: fpc_shortstr_compare returns

22
rtl/inc/generic.inc
View File

@ -496,12 +496,12 @@ begin
exit;
end;
}
slen:=length(pstring(sstr)^);
slen:=length(sstr);
if slen<len then
len:=slen;
{ don't forget the length character }
if len <> 0 then
move(sstr[0],result[0],len+1);
move(sstr[0],result[0],len+1);
end;
procedure fpc_shortstr_copy(len:longint;sstr,dstr:pointer);[public,alias:'FPC_SHORTSTR_COPY'];
@ -606,7 +606,7 @@ begin
if l>0 then
move(p^,s[1],l);
s[0]:=chr(l);
strpas := s;
fpc_pchar_to_shortstr := s;
end;
{$endif ndef FPC_SYSTEM_HAS_FPC_PCHAR_TO_SHORTSTR}
@ -617,11 +617,11 @@ function strpas(p:pchar):shortstring; [external name 'FPC_PCHAR_TO_SHORTSTR'];
{$ifndef FPC_SYSTEM_HAS_FPC_CHARARRAY_TO_SHORTSTR}
{$ifdef hascompilerproc}
function fpc_chararray_to_shortstr(p:pchar; l : longint):shortstring;[public,alias:'FPC_CHARARRAY_TO_SHORTSTR'];
function fpc_chararray_to_shortstr(const arr: array of char):shortstring;[public,alias:'FPC_CHARARRAY_TO_SHORTSTR']; compilerproc;
var
l: longint;
{$else hascompilerproc}
function fpc_chararray_to_shortstr(const arr: array of char):shortstring;[public,alias:'FPC_CHARARRAY_TO_SHORTSTR']; compilerproc;
function fpc_chararray_to_shortstr(p:pchar; l : longint):shortstring;[public,alias:'FPC_CHARARRAY_TO_SHORTSTR'];
{$endif hascompilerproc}
begin
{$ifdef hascompilerproc}
@ -891,7 +891,17 @@ end;
{
$Log$
Revision 1.20 2001-08-30 15:43:15 jonas
Revision 1.21 2001-09-03 13:27:43 jonas
* compilerproc implementation of set addition/substraction/...
* changed the declaration of some set helpers somewhat to accomodate the
above change
* i386 still uses the old code for comparisons of sets, because its
helpers return the results in the flags
* dummy tc_normal_2_small_set type conversion because I need the original
resulttype of the set add nodes
NOTE: you have to start a cycle with 1.0.5!
Revision 1.20 2001/08/30 15:43:15 jonas
* converted adding/comparing of strings to compileproc. Note that due
to the way the shortstring helpers for i386 are written, they are
still handled by the old code (reason: fpc_shortstr_compare returns

171
rtl/inc/genset.inc
View File

@ -14,38 +14,49 @@
**********************************************************************}
TYPE
{ TNormalSet = array[0..31] of byte;}
TNormalSet = array[0..7] of longint;
{$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!
Not anymore PM}
procedure do_load_small(p : pointer;l:longint);[public,alias:'FPC_SET_LOAD_SMALL'];
function fpc_set_load_small(l: fpc_small_set): fpc_normal_set; [public,alias:'FPC_SET_LOAD_SMALL']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
load a normal set p from a smallset l
}
begin
Fillchar(p^,SizeOf(TNormalSet),#0);
TNormalSet(p^)[0] := l;
fpc_set_load_small[0] := l;
FillDWord(fpc_set_load_small[1],7,0);
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'];
function fpc_set_create_element(b : byte): fpc_normal_set;[public,alias:'FPC_SET_CREATE_ELEMENT']; {$ifdef hascompilerproc} compilerproc; {$endif}
{
create a new set in p from an element b
}
begin
Fillchar(p^,SizeOf(TNormalSet),#0);
TNormalSet(p^)[b div 32] := 1 shl (b mod 32);
FillDWord(fpc_set_create_element,SizeOf(fpc_set_create_element) div 4,0);
fpc_set_create_element[b div 32] := 1 shl (b mod 32);
end;
{$endif FPC_SYSTEM_HAS_FPC_SET_CREATE_ELEMENT}
{$ifndef FPC_SYSTEM_HAS_FPC_SET_SET_BYTE}
{$ifdef hascompilerproc}
function fpc_set_set_byte(const source: fpc_normal_set; b : byte): fpc_normal_set; compilerproc;
{
add the element b to the set "source"
}
var
c: longint;
begin
move(source,fpc_set_set_byte,sizeof(source));
c := fpc_set_set_byte[b div 32];
c := (1 shl (b mod 32)) or c;
fpc_set_set_byte[b div 32] := c;
end;
{$else hascompilerproc}
procedure do_set_byte(p : pointer;b : byte);[public,alias:'FPC_SET_SET_BYTE'];
{
add the element b to the set pointed by p
@ -53,15 +64,18 @@ procedure do_load_small(p : pointer;l:longint);[public,alias:'FPC_SET_LOAD_SMALL
var
c: longint;
begin
c := TNormalSet(p^)[b div 32];
c := fpc_normal_set(p^)[b div 32];
c := (1 shl (b mod 32)) or c;
TNormalSet(p^)[b div 32] := c;
fpc_normal_set(p^)[b div 32] := c;
end;
{$endif hascompilerproc}
{$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'];
{$ifdef hascompilerproc}
function fpc_set_unset_byte(const source: fpc_normal_set; b : byte): fpc_normal_set; compilerproc;
{
suppresses the element b to the set pointed by p
used for exclude(set,element)
@ -69,14 +83,47 @@ procedure do_load_small(p : pointer;l:longint);[public,alias:'FPC_SET_LOAD_SMALL
var
c: longint;
begin
c := TNormalSet(p^)[b div 32];
move(source,fpc_set_unset_byte,sizeof(source));
c := fpc_set_unset_byte[b div 32];
c := c and not (1 shl (b mod 32));
TNormalSet(p^)[b div 32] := c;
fpc_set_unset_byte[b div 32] := c;
end;
{$else hascompilerproc}
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: longint;
begin
c := fpc_normal_set(p^)[b div 32];
c := c and not (1 shl (b mod 32));
fpc_normal_set(p^)[b div 32] := c;
end;
{$endif hascompilerproc}
{$endif FPC_SYSTEM_HAS_FPC_SET_UNSET_BYTE}
{$ifndef FPC_SYSTEM_HAS_FPC_SET_SET_RANGE}
{$ifdef hascompilerproc}
function fpc_set_set_range(const orgset: fpc_normal_set; l,h : byte): fpc_normal_set; compilerproc;
{
adds the range [l..h] to the set orgset
}
var
i: integer;
c: longint;
begin
move(orgset,fpc_set_set_range,sizeof(orgset));
for i:=l to h do
begin
c := fpc_set_set_range[i div 32];
c := (1 shl (i mod 32)) or c;
fpc_set_set_range[i div 32] := c;
end;
end;
{$else hascompilerproc}
procedure do_set_range(p : pointer;l,h : byte);[public,alias:'FPC_SET_SET_RANGE'];
{
bad implementation, but it's very seldom used
@ -87,37 +134,34 @@ procedure do_load_small(p : pointer;l:longint);[public,alias:'FPC_SET_LOAD_SMALL
begin
for i:=l to h do
begin
c := TNormalSet(p^)[i div 32];
c := fpc_normal_set(p^)[i div 32];
c := (1 shl (i mod 32)) or c;
TNormalSet(p^)[i div 32] := c;
fpc_normal_set(p^)[i div 32] := c;
end;
end;
{$endif}
{$endif hascompilerproc}
{$endif ndef FPC_SYSTEM_HAS_FPC_SET_SET_RANGE}
{$ifndef FPC_SYSTEM_HAS_FPC_SET_IN_BYTE}
{ saveregisters is a bit of overkill, but this routine should save all registers }
{ and it should be overriden for each platform and be written in assembler }
{ by saving all required registers. }
function do_in_byte(p : pointer;b : byte):boolean;[public,alias:'FPC_SET_IN_BYTE'];saveregisters;
function fpc_set_in_byte(const p: fpc_normal_set; b: byte): boolean; [public,alias:'FPC_SET_IN_BYTE']; {$ifdef hascompilerproc} compilerproc; {$else} saveregisters; {$endif}
{
tests if the element b is in the set p the carryflag is set if it present
}
var
c: longint;
begin
c := TNormalSet(p^)[b div 32];
if ((1 shl (b mod 32)) and c) <> 0 then
do_in_byte := TRUE
else
do_in_byte := FALSE;
fpc_set_in_byte := (p[b div 32] and (1 shl (b mod 32))) <> 0;
end;
{$endif}
{$ifndef FPC_SYSTEM_HAS_FPC_SET_ADD_SETS}
procedure do_add_sets(set1,set2,dest : pointer);[public,alias:'FPC_SET_ADD_SETS'];
{$ifdef hascompilerproc}
function fpc_set_add_sets(const set1,set2: fpc_normal_set): fpc_normal_set;[public,alias:'FPC_SET_ADD_SETS']; compilerproc;
var
dest: fpc_normal_set absolute fpc_set_add_sets;
{$else hascompilerproc}
procedure do_add_sets(const set1,set2: fpc_normal_Set; var dest : fpc_normal_set);[public,alias:'FPC_SET_ADD_SETS'];
{
adds set1 and set2 into set dest
}
@ -125,13 +169,20 @@ procedure do_load_small(p : pointer;l:longint);[public,alias:'FPC_SET_LOAD_SMALL
i: integer;
begin
for i:=0 to 7 do
TnormalSet(dest^)[i] := TNormalSet(set1^)[i] or TNormalSet(set2^)[i];
dest[i] := set1[i] or set2[i];
end;
{$endif hascompilerproc}
{$endif}
{$ifndef FPC_SYSTEM_HAS_FPC_SET_MUL_SETS}
procedure do_mul_sets(set1,set2,dest:pointer);[public,alias:'FPC_SET_MUL_SETS'];
{$ifdef hascompilerproc}
function fpc_set_mul_sets(const set1,set2: fpc_normal_set): fpc_normal_set;[public,alias:'FPC_SET_MUL_SETS']; compilerproc;
var
dest: fpc_normal_set absolute fpc_set_mul_sets;
{$else hascompilerproc}
procedure do_mul_sets(const set1,set2: fpc_normal_set; var dest: fpc_normal_set);[public,alias:'FPC_SET_MUL_SETS'];
{$endif hascompilerproc}
{
multiplies (takes common elements of) set1 and set2 result put in dest
}
@ -139,13 +190,19 @@ procedure do_load_small(p : pointer;l:longint);[public,alias:'FPC_SET_LOAD_SMALL
i: integer;
begin
for i:=0 to 7 do
TnormalSet(dest^)[i] := TNormalSet(set1^)[i] and TNormalSet(set2^)[i];
dest[i] := set1[i] and 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'];
{$ifdef hascompilerproc}
function fpc_set_sub_sets(const set1,set2: fpc_normal_set): fpc_normal_set;[public,alias:'FPC_SET_SUB_SETS']; compilerproc;
var
dest: fpc_normal_set absolute fpc_set_sub_sets;
{$else hascompilerproc}
procedure do_sub_sets(const set1,set2: fpc_normal_set; var dest: fpc_normal_set);[public,alias:'FPC_SET_SUB_SETS'];
{$endif hascompilerproc}
{
computes the diff from set1 to set2 result in dest
}
@ -153,13 +210,19 @@ procedure do_load_small(p : pointer;l:longint);[public,alias:'FPC_SET_LOAD_SMALL
i: integer;
begin
for i:=0 to 7 do
TnormalSet(dest^)[i] := TNormalSet(set1^)[i] and not TNormalSet(set2^)[i];
dest[i] := set1[i] and not 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'];
{$ifdef hascompilerproc}
function fpc_set_symdif_sets(const set1,set2: fpc_normal_set): fpc_normal_set;[public,alias:'FPC_SET_SYMDIF_SETS']; compilerproc;
var
dest: fpc_normal_set absolute fpc_set_symdif_sets;
{$else hascompilerproc}
procedure do_symdif_sets(const set1,set2: fpc_normal_set; var dest: fpc_normal_set);[public,alias:'FPC_SET_SYMDIF_SETS'];
{$endif hascompilerproc}
{
computes the symetric diff from set1 to set2 result in dest
}
@ -167,53 +230,57 @@ procedure do_load_small(p : pointer;l:longint);[public,alias:'FPC_SET_LOAD_SMALL
i: integer;
begin
for i:=0 to 7 do
TnormalSet(dest^)[i] := TNormalSet(set1^)[i] xor TNormalSet(set2^)[i];
dest[i] := set1[i] xor set2[i];
end;
{$endif}
{$ifndef FPC_SYSTEM_HAS_FPC_SET_COMP_SETS}
{ saveregisters is a bit of overkill, but this routine should save all registers }
{ and it should be overriden for each platform and be written in assembler }
{ by saving all required registers. }
function do_comp_sets(set1,set2 : pointer):boolean;[public,alias:'FPC_SET_COMP_SETS'];saveregisters;
function fpc_set_comp_sets(const set1,set2 : fpc_normal_set):boolean;[public,alias:'FPC_SET_COMP_SETS'];{$ifdef hascompilerproc} compilerproc; {$else} saveregisters; {$endif}
{
compares set1 and set2 zeroflag is set if they are equal
}
var
i: integer;
begin
do_comp_sets := false;
fpc_set_comp_sets:= false;
for i:=0 to 7 do
if TNormalSet(set1^)[i] <> TNormalSet(set2^)[i] then
if set1[i] <> set2[i] then
exit;
do_comp_sets := true;
fpc_set_comp_sets:= true;
end;
{$endif}
{$ifndef FPC_SYSTEM_HAS_FPC_SET_CONTAINS_SET}
{ saveregisters is a bit of overkill, but this routine should save all registers }
{ and it should be overriden for each platform and be written in assembler }
{ by saving all required registers. }
function do_contains_sets(set1,set2 : pointer):boolean;[public,alias:'FPC_SET_CONTAINS_SETS'];saveregisters;
function fpc_set_contains_sets(const set1,set2 : fpc_normal_set):boolean;[public,alias:'FPC_SET_CONTAINS_SETS'];{$ifdef hascompilerproc} compilerproc; {$else} saveregisters; {$endif}
{
on exit, zero flag is set if set1 <= set2 (set2 contains set1)
}
var
i : integer;
begin
do_contains_sets := false;
fpc_set_contains_sets:= false;
for i:=0 to 7 do
if (TNormalSet(set1^)[i] and TNormalSet(set2^)[i]) <> TNormalSet(set1^)[i] then
if (set2[i] and not set1[i]) <> 0 then
exit;
do_contains_sets := true;
fpc_set_contains_sets:= true;
end;
{$endif}
{
$Log$
Revision 1.4 2001-06-27 21:37:38 peter
Revision 1.5 2001-09-03 13:27:43 jonas
* compilerproc implementation of set addition/substraction/...
* changed the declaration of some set helpers somewhat to accomodate the
above change
* i386 still uses the old code for comparisons of sets, because its
helpers return the results in the flags
* dummy tc_normal_2_small_set type conversion because I need the original
resulttype of the set add nodes
NOTE: you have to start a cycle with 1.0.5!
Revision 1.4 2001/06/27 21:37:38 peter
* v10 merges
Revision 1.3 2001/05/18 22:59:59 peter