paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-12-08 05:27:28 +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); procedure SetResultLocation(cmpop,unsigned : boolean);
protected protected
function first_addstring : tnode; override; function first_addstring : tnode; override;
function first_addset : tnode; override;
private private
procedure second_addstring; procedure second_addstring;
procedure second_addset; procedure second_addset;
@ -257,9 +258,21 @@ interface
Addset 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; procedure ti386addnode.second_addset;
var var
createset,
cmpop, cmpop,
pushed : boolean; pushed : boolean;
href : treference; href : treference;
@ -272,16 +285,7 @@ interface
if nf_swaped in flags then if nf_swaped in flags then
swapleftright; swapleftright;
{ optimize first loading of a set } secondpass(left);
if (right.nodetype=setelementn) and
not(assigned(tsetelementnode(right).right)) and
is_emptyset(left) then
createset:=true
else
begin
createset:=false;
secondpass(left);
end;
{ are too few registers free? } { are too few registers free? }
pushed:=maybe_push(right.registers32,left,false); pushed:=maybe_push(right.registers32,left,false);
@ -294,151 +298,45 @@ interface
set_location(location,left.location); set_location(location,left.location);
{ handle operations } { handle operations }
{ (the rest is handled by compilerprocs in pass 1) (JM) }
case nodetype of case nodetype of
equaln, equaln,
unequaln unequaln
,lten, gten ,lten, gten :
: begin begin
cmpop:=true; cmpop:=true;
del_location(left.location); del_location(left.location);
del_location(right.location); del_location(right.location);
pushusedregisters(pushedregs,$ff); pushusedregisters(pushedregs,$ff);
If (nodetype in [equaln, unequaln, lten]) Then If (nodetype in [equaln, unequaln, lten]) Then
Begin Begin
emitpushreferenceaddr(right.location.reference); emitpushreferenceaddr(right.location.reference);
emitpushreferenceaddr(left.location.reference); emitpushreferenceaddr(left.location.reference);
End End
Else {gten = lten, if the arguments are reversed} Else {gten = lten, if the arguments are reversed}
Begin Begin
emitpushreferenceaddr(left.location.reference); emitpushreferenceaddr(left.location.reference);
emitpushreferenceaddr(right.location.reference); emitpushreferenceaddr(right.location.reference);
End; End;
saveregvars($ff); saveregvars($ff);
Case nodetype of Case nodetype of
equaln, unequaln: equaln, unequaln:
emitcall('FPC_SET_COMP_SETS'); emitcall('FPC_SET_COMP_SETS');
lten, gten: lten, gten:
Begin Begin
emitcall('FPC_SET_CONTAINS_SETS'); emitcall('FPC_SET_CONTAINS_SETS');
{ we need a jne afterwards, not a jnbe/jnae } { we need a jne afterwards, not a jnbe/jnae }
nodetype := equaln; nodetype := equaln;
End; End;
End; End;
maybe_loadself; maybe_loadself;
popusedregisters(pushedregs); popusedregisters(pushedregs);
ungetiftemp(left.location.reference); ungetiftemp(left.location.reference);
ungetiftemp(right.location.reference); ungetiftemp(right.location.reference);
end; 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;
else else
CGMessage(type_e_mismatch); internalerror(200108314);
end; end;
SetResultLocation(cmpop,true); SetResultLocation(cmpop,true);
end; end;
@ -2082,7 +1980,17 @@ begin
end. end.
{ {
$Log$ $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 * converted adding/comparing of strings to compileproc. Note that due
to the way the shortstring helpers for i386 are written, they are to the way the shortstring helpers for i386 are written, they are
still handled by the old code (reason: fpc_shortstr_compare returns 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 string }
@ti386typeconvnode.second_nothing, { interface 2 guid } @ti386typeconvnode.second_nothing, { interface 2 guid }
@ti386typeconvnode.second_class_to_intf, @ti386typeconvnode.second_class_to_intf,
@ti386typeconvnode.second_char_to_char @ti386typeconvnode.second_char_to_char,
@ti386typeconvnode.second_nothing { normal_2_smallset }
); );
type type
tprocedureofobject = procedure of object; tprocedureofobject = procedure of object;
@ -1000,7 +1001,17 @@ begin
end. end.
{ {
$Log$ $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 * some fixes in compilerprocs for chararray to string conversions
* conversion from string to chararray is now also done via compilerprocs * 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 } { override the following if you want to implement }
{ parts explicitely in the code generator (JM) } { parts explicitely in the code generator (JM) }
function first_addstring: tnode; virtual; function first_addstring: tnode; virtual;
function first_addset: tnode; virtual;
end; end;
taddnodeclass = class of taddnode; taddnodeclass = class of taddnode;
@ -53,7 +54,7 @@ implementation
uses uses
globtype,systems, globtype,systems,
cutils,verbose,globals,widestr, cutils,verbose,globals,widestr,
symconst,symtype,symdef,symsym,types, symconst,symtype,symbase,symdef,symsym,symtable,types,
cpuinfo, cpuinfo,
cgbase, cgbase,
htypechk,pass_1, htypechk,pass_1,
@ -1110,6 +1111,164 @@ implementation
end; 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; function taddnode.pass_1 : tnode;
var var
hp : tnode; hp : tnode;
@ -1203,6 +1362,9 @@ implementation
end end
else else
begin begin
result := first_addset;
if assigned(result) then
exit;
calcregisters(self,0,0,0); calcregisters(self,0,0,0);
{ here we call SET... } { here we call SET... }
procinfo^.flags:=procinfo^.flags or pi_do_call; procinfo^.flags:=procinfo^.flags or pi_do_call;
@ -1369,7 +1531,17 @@ begin
end. end.
{ {
$Log$ $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 * move class of definitions into type section for delphi
Revision 1.35 2001/08/31 15:42:15 jonas Revision 1.35 2001/08/31 15:42:15 jonas

56
compiler/ncnv.pas
View File

@ -126,7 +126,10 @@ implementation
end; end;
{ don't insert obsolete type conversions } { 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 begin
p.resulttype:=t; p.resulttype:=t;
end end
@ -686,7 +689,8 @@ implementation
{ intf_2_string } nil, { intf_2_string } nil,
{ intf_2_guid } nil, { intf_2_guid } nil,
{ class_2_intf } 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 type
tprocedureofobject = function : tnode of object; tprocedureofobject = function : tnode of object;
@ -725,19 +729,24 @@ implementation
check here if we are loading a smallset into a normalset } check here if we are loading a smallset into a normalset }
if (resulttype.def.deftype=setdef) and if (resulttype.def.deftype=setdef) and
(left.resulttype.def.deftype=setdef) and (left.resulttype.def.deftype=setdef) and
(tsetdef(resulttype.def).settype<>smallset) and ((tsetdef(resulttype.def).settype = smallset) xor
(tsetdef(left.resulttype.def).settype=smallset) then (tsetdef(left.resulttype.def).settype = smallset)) then
begin begin
{ try to define the set as a normalset if it's a constant set } { try to define the set as a normalset if it's a constant set }
if left.nodetype=setconstn then if (tsetdef(resulttype.def).settype <> smallset) then
begin begin
resulttype:=left.resulttype; if (left.nodetype=setconstn) then
tsetdef(resulttype.def).settype:=normset begin
end resulttype:=left.resulttype;
else tsetdef(resulttype.def).settype:=normset
convtype:=tc_load_smallset; end
exit; else
end convtype:=tc_load_smallset;
end
else
convtype := tc_normal_2_smallset;
exit;
end
else else
begin begin
left.resulttype:=resulttype; left.resulttype:=resulttype;
@ -1274,7 +1283,8 @@ implementation
@ttypeconvnode.first_nothing, @ttypeconvnode.first_nothing,
@ttypeconvnode.first_nothing, @ttypeconvnode.first_nothing,
@ttypeconvnode.first_class_to_intf, @ttypeconvnode.first_class_to_intf,
@ttypeconvnode.first_char_to_char @ttypeconvnode.first_char_to_char,
@ttypeconvnode.first_nothing
); );
type type
tprocedureofobject = function : tnode of object; tprocedureofobject = function : tnode of object;
@ -1466,7 +1476,17 @@ begin
end. end.
{ {
$Log$ $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 * move class of definitions into type section for delphi
Revision 1.35 2001/08/29 19:49:03 jonas 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 Revision 1.33 2001/08/28 13:24:46 jonas
+ compilerproc implementation of most string-related type conversions + compilerproc implementation of most string-related type conversions
- removed all code from the compiler which has been replaced by - 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) necessary in the compiler)
Revision 1.32 2001/08/26 13:36:40 florian 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_string,
tc_intf_2_guid, tc_intf_2_guid,
tc_class_2_intf, 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; function assignment_overloaded(from_def,to_def : tdef) : tprocdef;
@ -1783,7 +1784,17 @@ implementation
end. end.
{ {
$Log$ $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 * don't allow int64->real for delphi mode
Revision 1.45 2001/08/19 21:11:21 florian 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} {$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 load a normal set p from a smallset l
} }
asm asm
movl p,%edi movl __RESULT,%edi
movl l,%eax movl l,%eax
movl %eax,(%edi)
addl $4,%edi
movl $7,%ecx movl $7,%ecx
movl %eax,4(%edi)
addl $4,%edi
xorl %eax,%eax xorl %eax,%eax
rep rep
stosl stosl
end; end ['EAX','ECX','EDI'];
{$define FPC_SYSTEM_HAS_FPC_SET_CREATE_ELEMENT} {$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 create a new set in p from an element b
} }
asm asm
{$ifndef hascompilerproc}
pushl %eax pushl %eax
pushl %ecx pushl %ecx
movl p,%edi {$endif not hascompilerproc}
movl __RESULT,%edi
xorl %eax,%eax xorl %eax,%eax
movl $8,%ecx movl $8,%ecx
rep rep
stosl stosl
movb b,%al movb b,%al
movl p,%edi movl __RESULT,%edi
movl %eax,%ecx movl %eax,%ecx
shrl $3,%eax shrl $3,%eax
andl $7,%ecx andl $7,%ecx
addl %eax,%edi addl %eax,%edi
btsl %ecx,(%edi) btsl %ecx,(%edi)
{$ifdef hascompilerproc}
movl __RESULT,%edi
{$else hascompilerproc}
popl %ecx popl %ecx
popl %eax popl %eax
end; {$endif hascompilerproc}
end ['EAX','ECX','EDI'];
{$define FPC_SYSTEM_HAS_FPC_SET_SET_BYTE} {$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 add the element b to the set pointed by p
} }
asm asm
pushl %eax pushl %eax
movl p,%edi movl __RESULT,%edi
movb b,%al movb b,%al
andl $0xf8,%eax andl $0xf8,%eax
shrl $3,%eax shrl $3,%eax
@ -72,17 +106,39 @@ asm
btsl %eax,(%edi) btsl %eax,(%edi)
popl %eax popl %eax
end; end;
{$endif hascompilerproc}
{$define FPC_SYSTEM_HAS_FPC_SET_UNSET_BYTE} {$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 suppresses the element b to the set pointed by p
used for exclude(set,element) used for exclude(set,element)
} }
asm asm
pushl %eax pushl %eax
movl p,%edi movl __RESULT,%edi
movb b,%al movb b,%al
andl $0xf8,%eax andl $0xf8,%eax
shrl $3,%eax shrl $3,%eax
@ -92,20 +148,73 @@ asm
btrl %eax,(%edi) btrl %eax,(%edi)
popl %eax popl %eax
end; end;
{$endif hascompilerproc}
{$define FPC_SYSTEM_HAS_FPC_SET_SET_RANGE} {$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 adds the range [l..h] to the set pointed to by p
} }
asm asm
pushl %eax
movzbl l,%eax // lowest bit to be set in eax movzbl l,%eax // lowest bit to be set in eax
movzbl h,%ebx // highest in ebx movzbl h,%ebx // highest in ebx
cmpl %eax,%ebx cmpl %eax,%ebx
jb .Lset_range_done 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 movl %eax,%ecx // lowest also in ecx
shrl $3,%eax // divide by 8 to get starting and ending byte shrl $3,%eax // divide by 8 to get starting and ending byte
shrl $3,%ebx // address shrl $3,%ebx // address
@ -137,12 +246,22 @@ asm
andl %edx,%ebx // combine both bitmasks andl %edx,%ebx // combine both bitmasks
orl %ebx,(%edi) // store to set orl %ebx,(%edi) // store to set
.Lset_range_done: .Lset_range_done:
popl %eax
end; end;
{$endif hascompilerproc}
{$define FPC_SYSTEM_HAS_FPC_SET_IN_BYTE} {$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 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} {$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 adds set1 and set2 into set dest
} }
asm asm
movl set1,%esi movl set1,%esi
movl set2,%ebx movl set2,%ebx
{$ifdef hascompilerproc}
movl __RESULT,%edi
{$else hascompilerproc}
movl dest,%edi movl dest,%edi
{$endif hascompilerproc}
movl $8,%ecx movl $8,%ecx
.LMADDSETS1: .LMADDSETS1:
lodsl lodsl
@ -181,14 +309,23 @@ end;
{$define FPC_SYSTEM_HAS_FPC_SET_MUL_SETS} {$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 multiplies (takes common elements of) set1 and set2 result put in dest
} }
asm asm
movl set1,%esi movl set1,%esi
movl set2,%ebx movl set2,%ebx
{$ifdef hascompilerproc}
movl __RESULT,%edi
{$else hascompilerproc}
movl dest,%edi movl dest,%edi
{$endif hascompilerproc}
movl $8,%ecx movl $8,%ecx
.LMMULSETS1: .LMMULSETS1:
lodsl lodsl
@ -201,14 +338,23 @@ end;
{$define FPC_SYSTEM_HAS_FPC_SET_SUB_SETS} {$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 computes the diff from set1 to set2 result in dest
} }
asm asm
movl set1,%esi movl set1,%esi
movl set2,%ebx movl set2,%ebx
movl dest,%edi {$ifdef hascompilerproc}
movl __RESULT,%edi
{$else hascompilerproc}
movl dest,%edi
{$endif hascompilerproc}
movl $8,%ecx movl $8,%ecx
.LMSUBSETS1: .LMSUBSETS1:
lodsl lodsl
@ -223,14 +369,23 @@ end;
{$define FPC_SYSTEM_HAS_FPC_SET_SYMDIF_SETS} {$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 computes the symetric diff from set1 to set2 result in dest
} }
asm asm
movl set1,%esi movl set1,%esi
movl set2,%ebx movl set2,%ebx
movl dest,%edi {$ifdef hascompilerproc}
movl __RESULT,%edi
{$else hascompilerproc}
movl dest,%edi
{$endif hascompilerproc}
movl $8,%ecx movl $8,%ecx
.LMSYMDIFSETS1: .LMSYMDIFSETS1:
lodsl lodsl
@ -244,7 +399,18 @@ end;
{$define FPC_SYSTEM_HAS_FPC_SET_COMP_SETS} {$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 compares set1 and set2 zeroflag is set if they are equal
} }
@ -269,7 +435,17 @@ end;
{$define FPC_SYSTEM_HAS_FPC_SET_CONTAINS_SET} {$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) on exit, zero flag is set if set1 <= set2 (set2 contains set1)
} }
@ -455,7 +631,17 @@ end;
{ {
$Log$ $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 + "compproc" helpers
* renamed several helpers so that their name is the same as their * renamed several helpers so that their name is the same as their
"public alias", which should facilitate the conversion of processor "public alias", which should facilitate the conversion of processor

39
rtl/inc/compproc.inc
View File

@ -24,8 +24,11 @@
{$ifdef hascompilerproc} {$ifdef hascompilerproc}
{ some dummy types necessary to have generic resulttypes for certain compilerprocs }
type type
fpc_big_chararray = array[0..maxlongint] of char; 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; procedure fpc_Shortstr_SetLength(var s:shortstring;len:StrLenInt); compilerproc;
function fpc_shortstr_to_shortstr(len:longint; const sstr: shortstring): shortstring; 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_DecRef (Data,TypeInfo : Pointer); compilerproc;
procedure fpc_FinalizeArray(data,typeinfo : pointer;count,size : longint); compilerproc; procedure fpc_FinalizeArray(data,typeinfo : pointer;count,size : longint); compilerproc;
procedure fpc_set_load_small(p : pointer;l:longint); compilerproc; function fpc_set_load_small(l: fpc_small_set): fpc_normal_set; compilerproc;
procedure fpc_set_create_element(p : pointer;b : byte); compilerproc; function fpc_set_create_element(b : byte): fpc_normal_set; compilerproc;
procedure fpc_set_set_byte(p : pointer;b : byte); compilerproc; function fpc_set_set_byte(const source: fpc_normal_set; b : byte): fpc_normal_set; compilerproc;
procedure fpc_set_unset_byte(p : pointer;b : byte); compilerproc; function fpc_set_unset_byte(const source: fpc_normal_set; b : byte): fpc_normal_set; compilerproc;
procedure fpc_set_set_range(p : pointer;l,h : byte); compilerproc; function fpc_set_set_range(const orgset: fpc_normal_set; l,h : byte): fpc_normal_set; compilerproc;
procedure fpc_set_in_byte(p : pointer;b : byte); compilerproc; function fpc_set_in_byte(const p: fpc_normal_set; b: byte): boolean; compilerproc;
procedure fpc_set_add_sets(set1,set2,dest : pointer); compilerproc; function fpc_set_add_sets(const set1,set2: fpc_normal_set): fpc_normal_set; compilerproc;
procedure fpc_set_mul_sets(set1,set2,dest:pointer); compilerproc; function fpc_set_mul_sets(const set1,set2: fpc_normal_set): fpc_normal_set; compilerproc;
procedure fpc_set_sub_sets(set1,set2,dest:pointer); compilerproc; function fpc_set_sub_sets(const set1,set2: fpc_normal_set): fpc_normal_set; compilerproc;
procedure fpc_set_symdif_sets(set1,set2,dest:pointer); compilerproc; function fpc_set_symdif_sets(const set1,set2: fpc_normal_set): fpc_normal_set; compilerproc;
procedure fpc_set_comp_sets(set1,set2 : pointer); compilerproc; function fpc_set_comp_sets(const set1,set2: fpc_normal_set): boolean; compilerproc;
procedure fpc_set_contains_sets(set1,set2 : pointer); compilerproc; function fpc_set_contains_sets(const set1,set2: fpc_normal_set): boolean; compilerproc;
{$ifdef LARGESETS} {$ifdef LARGESETS}
procedure fpc_largeset_set_word(p : pointer;b : word); compilerproc; 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$ $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 * converted adding/comparing of strings to compileproc. Note that due
to the way the shortstring helpers for i386 are written, they are to the way the shortstring helpers for i386 are written, they are
still handled by the old code (reason: fpc_shortstr_compare returns still handled by the old code (reason: fpc_shortstr_compare returns

22
rtl/inc/generic.inc
View File

@ -496,12 +496,12 @@ begin
exit; exit;
end; end;
} }
slen:=length(pstring(sstr)^); slen:=length(sstr);
if slen<len then if slen<len then
len:=slen; len:=slen;
{ don't forget the length character } { don't forget the length character }
if len <> 0 then if len <> 0 then
move(sstr[0],result[0],len+1); move(sstr[0],result[0],len+1);
end; end;
procedure fpc_shortstr_copy(len:longint;sstr,dstr:pointer);[public,alias:'FPC_SHORTSTR_COPY']; procedure fpc_shortstr_copy(len:longint;sstr,dstr:pointer);[public,alias:'FPC_SHORTSTR_COPY'];
@ -606,7 +606,7 @@ begin
if l>0 then if l>0 then
move(p^,s[1],l); move(p^,s[1],l);
s[0]:=chr(l); s[0]:=chr(l);
strpas := s; fpc_pchar_to_shortstr := s;
end; end;
{$endif ndef FPC_SYSTEM_HAS_FPC_PCHAR_TO_SHORTSTR} {$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} {$ifndef FPC_SYSTEM_HAS_FPC_CHARARRAY_TO_SHORTSTR}
{$ifdef hascompilerproc} {$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 var
l: longint; l: longint;
{$else hascompilerproc} {$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} {$endif hascompilerproc}
begin begin
{$ifdef hascompilerproc} {$ifdef hascompilerproc}
@ -891,7 +891,17 @@ end;
{ {
$Log$ $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 * converted adding/comparing of strings to compileproc. Note that due
to the way the shortstring helpers for i386 are written, they are to the way the shortstring helpers for i386 are written, they are
still handled by the old code (reason: fpc_shortstr_compare returns 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} {$ifndef FPC_SYSTEM_HAS_FPC_SET_LOAD_SMALL}
{ Error No pascal version of FPC_SET_LOAD_SMALL} { Error No pascal version of FPC_SET_LOAD_SMALL}
{ THIS DEPENDS ON THE ENDIAN OF THE ARCHITECTURE! { THIS DEPENDS ON THE ENDIAN OF THE ARCHITECTURE!
Not anymore PM} 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 load a normal set p from a smallset l
} }
begin begin
Fillchar(p^,SizeOf(TNormalSet),#0); fpc_set_load_small[0] := l;
TNormalSet(p^)[0] := l; FillDWord(fpc_set_load_small[1],7,0);
end; end;
{$endif FPC_SYSTEM_HAS_FPC_SET_LOAD_SMALL} {$endif FPC_SYSTEM_HAS_FPC_SET_LOAD_SMALL}
{$ifndef FPC_SYSTEM_HAS_FPC_SET_CREATE_ELEMENT} {$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 create a new set in p from an element b
} }
begin begin
Fillchar(p^,SizeOf(TNormalSet),#0); FillDWord(fpc_set_create_element,SizeOf(fpc_set_create_element) div 4,0);
TNormalSet(p^)[b div 32] := 1 shl (b mod 32); fpc_set_create_element[b div 32] := 1 shl (b mod 32);
end; end;
{$endif FPC_SYSTEM_HAS_FPC_SET_CREATE_ELEMENT} {$endif FPC_SYSTEM_HAS_FPC_SET_CREATE_ELEMENT}
{$ifndef FPC_SYSTEM_HAS_FPC_SET_SET_BYTE} {$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']; procedure do_set_byte(p : pointer;b : byte);[public,alias:'FPC_SET_SET_BYTE'];
{ {
add the element b to the set pointed by p 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 var
c: longint; c: longint;
begin begin
c := TNormalSet(p^)[b div 32]; c := fpc_normal_set(p^)[b div 32];
c := (1 shl (b mod 32)) or c; c := (1 shl (b mod 32)) or c;
TNormalSet(p^)[b div 32] := c; fpc_normal_set(p^)[b div 32] := c;
end; end;
{$endif hascompilerproc}
{$endif FPC_SYSTEM_HAS_FPC_SET_SET_BYTE} {$endif FPC_SYSTEM_HAS_FPC_SET_SET_BYTE}
{$ifndef FPC_SYSTEM_HAS_FPC_SET_UNSET_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 suppresses the element b to the set pointed by p
used for exclude(set,element) used for exclude(set,element)
@ -69,14 +83,47 @@ procedure do_load_small(p : pointer;l:longint);[public,alias:'FPC_SET_LOAD_SMALL
var var
c: longint; c: longint;
begin 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)); c := c and not (1 shl (b mod 32));
TNormalSet(p^)[b div 32] := c; fpc_set_unset_byte[b div 32] := c;
end; 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} {$endif FPC_SYSTEM_HAS_FPC_SET_UNSET_BYTE}
{$ifndef FPC_SYSTEM_HAS_FPC_SET_SET_RANGE} {$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']; procedure do_set_range(p : pointer;l,h : byte);[public,alias:'FPC_SET_SET_RANGE'];
{ {
bad implementation, but it's very seldom used 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 begin
for i:=l to h do for i:=l to h do
begin begin
c := TNormalSet(p^)[i div 32]; c := fpc_normal_set(p^)[i div 32];
c := (1 shl (i mod 32)) or c; c := (1 shl (i mod 32)) or c;
TNormalSet(p^)[i div 32] := c; fpc_normal_set(p^)[i div 32] := c;
end; end;
end; end;
{$endif} {$endif hascompilerproc}
{$endif ndef FPC_SYSTEM_HAS_FPC_SET_SET_RANGE}
{$ifndef FPC_SYSTEM_HAS_FPC_SET_IN_BYTE} {$ifndef FPC_SYSTEM_HAS_FPC_SET_IN_BYTE}
{ saveregisters is a bit of overkill, but this routine should save all registers } 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}
{ 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;
{ {
tests if the element b is in the set p the carryflag is set if it present tests if the element b is in the set p the carryflag is set if it present
} }
var
c: longint;
begin begin
c := TNormalSet(p^)[b div 32]; fpc_set_in_byte := (p[b div 32] and (1 shl (b mod 32))) <> 0;
if ((1 shl (b mod 32)) and c) <> 0 then
do_in_byte := TRUE
else
do_in_byte := FALSE;
end; end;
{$endif} {$endif}
{$ifndef FPC_SYSTEM_HAS_FPC_SET_ADD_SETS} {$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 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; i: integer;
begin begin
for i:=0 to 7 do for i:=0 to 7 do
TnormalSet(dest^)[i] := TNormalSet(set1^)[i] or TNormalSet(set2^)[i]; dest[i] := set1[i] or set2[i];
end; end;
{$endif hascompilerproc}
{$endif} {$endif}
{$ifndef FPC_SYSTEM_HAS_FPC_SET_MUL_SETS} {$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 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; i: integer;
begin begin
for i:=0 to 7 do for i:=0 to 7 do
TnormalSet(dest^)[i] := TNormalSet(set1^)[i] and TNormalSet(set2^)[i]; dest[i] := set1[i] and set2[i];
end; end;
{$endif} {$endif}
{$ifndef FPC_SYSTEM_HAS_FPC_SET_SUB_SETS} {$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 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; i: integer;
begin begin
for i:=0 to 7 do 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; end;
{$endif} {$endif}
{$ifndef FPC_SYSTEM_HAS_FPC_SET_SYMDIF_SETS} {$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 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; i: integer;
begin begin
for i:=0 to 7 do for i:=0 to 7 do
TnormalSet(dest^)[i] := TNormalSet(set1^)[i] xor TNormalSet(set2^)[i]; dest[i] := set1[i] xor set2[i];
end; end;
{$endif} {$endif}
{$ifndef FPC_SYSTEM_HAS_FPC_SET_COMP_SETS} {$ifndef FPC_SYSTEM_HAS_FPC_SET_COMP_SETS}
{ saveregisters is a bit of overkill, but this routine should save all registers } function fpc_set_comp_sets(const set1,set2 : fpc_normal_set):boolean;[public,alias:'FPC_SET_COMP_SETS'];{$ifdef hascompilerproc} compilerproc; {$else} saveregisters; {$endif}
{ 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;
{ {
compares set1 and set2 zeroflag is set if they are equal compares set1 and set2 zeroflag is set if they are equal
} }
var var
i: integer; i: integer;
begin begin
do_comp_sets := false; fpc_set_comp_sets:= false;
for i:=0 to 7 do for i:=0 to 7 do
if TNormalSet(set1^)[i] <> TNormalSet(set2^)[i] then if set1[i] <> set2[i] then
exit; exit;
do_comp_sets := true; fpc_set_comp_sets:= true;
end; end;
{$endif} {$endif}
{$ifndef FPC_SYSTEM_HAS_FPC_SET_CONTAINS_SET} {$ifndef FPC_SYSTEM_HAS_FPC_SET_CONTAINS_SET}
{ saveregisters is a bit of overkill, but this routine should save all registers } function fpc_set_contains_sets(const set1,set2 : fpc_normal_set):boolean;[public,alias:'FPC_SET_CONTAINS_SETS'];{$ifdef hascompilerproc} compilerproc; {$else} saveregisters; {$endif}
{ 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;
{ {
on exit, zero flag is set if set1 <= set2 (set2 contains set1) on exit, zero flag is set if set1 <= set2 (set2 contains set1)
} }
var var
i : integer; i : integer;
begin begin
do_contains_sets := false; fpc_set_contains_sets:= false;
for i:=0 to 7 do 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; exit;
do_contains_sets := true; fpc_set_contains_sets:= true;
end; end;
{$endif} {$endif}
{ {
$Log$ $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 * v10 merges
Revision 1.3 2001/05/18 22:59:59 peter Revision 1.3 2001/05/18 22:59:59 peter