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

* cleaned up set conversion

Browse Source 
* fixed conversion of var sets

git-svn-id: trunk@6644 -
This commit is contained in:
florian 2007-02-25 16:29:39 +00:00
parent 47d0dd487e
commit 9a0f769b2f
8 changed files with 155 additions and 122 deletions

25
compiler/defcmp.pas
View File

@ -64,13 +64,12 @@ interface
tc_real_2_currency,
tc_proc_2_procvar,
tc_arrayconstructor_2_set,
tc_load_smallset,
tc_set_to_set,
tc_cord_2_pointer,
tc_intf_2_string,
tc_intf_2_guid,
tc_class_2_intf,
tc_char_2_char,
tc_normal_2_smallset,
tc_dynarray_2_openarray,
tc_pwchar_2_string,
tc_variant_2_dynarray,
@ -907,7 +906,7 @@ implementation
{ Don't allow pchar(char) in fpc modes }
is_integer(def_from)
)
) or
) or
(cdo_internal in cdoptions)
) then
begin
@ -1060,13 +1059,23 @@ implementation
if assigned(tsetdef(def_from).elementdef) and
assigned(tsetdef(def_to).elementdef) then
begin
{ sets with the same element base type are equal }
if is_subequal(tsetdef(def_from).elementdef,tsetdef(def_to).elementdef) then
eq:=te_equal;
{ sets with the same element base type and the same range are equal }
if equal_defs(tsetdef(def_from).elementdef,tsetdef(def_to).elementdef) and
(tsetdef(def_from).setbase=tsetdef(def_to).setbase) and
(tsetdef(def_from).setmax=tsetdef(def_to).setmax) then
eq:=te_equal
else if is_subequal(tsetdef(def_from).elementdef,tsetdef(def_to).elementdef) then
begin
eq:=te_convert_l1;
doconv:=tc_set_to_set;
end;
end
else
{ empty set is compatible with everything }
eq:=te_equal;
begin
{ empty set is compatible with everything }
eq:=te_convert_l1;
doconv:=tc_set_to_set;
end;
end;
arraydef :
begin

93
compiler/nadd.pas
View File

@ -995,7 +995,7 @@ implementation
could be already typeconvs inserted.
This is compatible with the code below for other unsigned types (PFV) }
if is_signed(left.resultdef) or
is_signed(right.resultdef) or
is_signed(right.resultdef) or
(nodetype=subn) then
begin
if nodetype<>subn then
@ -1081,44 +1081,29 @@ implementation
if (nodetype=addn) and (rd.typ<>setdef) then
begin
if (rt=setelementn) then
begin
if not(equal_defs(tsetdef(ld).elementdef,rd)) then
CGMessage(type_e_set_element_are_not_comp);
end
begin
if not(equal_defs(tsetdef(ld).elementdef,rd)) then
inserttypeconv(right,tsetdef(ld).elementdef);
end
else
CGMessage(type_e_mismatch)
CGMessage(type_e_mismatch)
end
else
begin
if not(nodetype in [addn,subn,symdifn,muln,equaln,unequaln,lten,gten]) then
CGMessage(type_e_set_operation_unknown);
{ right def must be a also be set }
if (rd.typ<>setdef) or not(equal_defs(rd,ld)) then
CGMessage(type_e_set_element_are_not_comp);
{ if the right side is also a setdef then the settype must
be the same as the left setdef }
if (rd.typ=setdef) and
not(equal_defs(ld,rd)) then
begin
if is_varset(rd) then
inserttypeconv(left,right.resultdef)
else
inserttypeconv(right,left.resultdef);
end;
end;
{ ranges require normsets }
if (tsetdef(ld).settype=smallset) and
(rt=setelementn) and
assigned(tsetelementnode(right).right) then
begin
{ generate a temporary normset def, it'll be destroyed
when the symtable is unloaded }
inserttypeconv(left,tsetdef.create(tsetdef(ld).elementdef,255));
end;
{ if the right side is also a setdef then the settype must
be the same as the left setdef }
if (rd.typ=setdef) and
(tsetdef(ld).settype<>tsetdef(rd).settype) then
begin
{ when right is a normset we need to typecast both
to normsets }
if (tsetdef(rd).settype=normset) then
inserttypeconv(left,right.resultdef)
else
inserttypeconv(right,left.resultdef);
end;
end
{ pointer comparision and subtraction }
else if (
@ -2286,6 +2271,8 @@ implementation
{$endif addstringopt}
lt,rt : tnodetype;
rd,ld : tdef;
newstatement : tstatementnode;
temp : ttempcreatenode;
begin
result:=nil;
@ -2423,7 +2410,7 @@ implementation
else array constructor can be seen as array of char (PFV) }
else if (ld.typ=setdef) then
begin
if tsetdef(ld).settype=smallset then
if not(is_varset(ld)) then
begin
if nodetype in [ltn,lten,gtn,gten,equaln,unequaln] then
expectloc:=LOC_FLAGS
@ -2431,7 +2418,47 @@ implementation
expectloc:=LOC_REGISTER;
{ are we adding set elements ? }
if right.nodetype=setelementn then
calcregisters(self,2,0,0)
begin
{ add range?
the smallset code can't handle set ranges }
if assigned(tsetelementnode(right).right) then
begin
result:=internalstatements(newstatement);
{ create temp for result }
temp:=ctempcreatenode.create(resultdef,resultdef.size,tt_persistent,true);
addstatement(newstatement,temp);
{ add a range or a single element? }
if assigned(tsetelementnode(right).right) then
addstatement(newstatement,ccallnode.createintern('fpc_varset_set_range',
ccallparanode.create(cordconstnode.create(resultdef.size,sinttype,false),
ccallparanode.create(ctypeconvnode.create_internal(tsetelementnode(right).right,sinttype),
ccallparanode.create(ctypeconvnode.create_internal(tsetelementnode(right).left,sinttype),
ccallparanode.create(ctemprefnode.create(temp),
ccallparanode.create(left,nil))))))
)
else
addstatement(newstatement,ccallnode.createintern('fpc_varset_set',
ccallparanode.create(cordconstnode.create(resultdef.size,sinttype,false),
ccallparanode.create(ctypeconvnode.create_internal(tsetelementnode(right).left,sinttype),
ccallparanode.create(ctemprefnode.create(temp),
ccallparanode.create(left,nil)))))
);
{ remove reused parts from original node }
tsetelementnode(right).right:=nil;
tsetelementnode(right).left:=nil;
left:=nil;
{ the last statement should return the value as
location and type, this is done be referencing the
temp and converting it first from a persistent temp to
normal temp }
addstatement(newstatement,ctempdeletenode.create_normal_temp(temp));
addstatement(newstatement,ctemprefnode.create(temp));
end
else
calcregisters(self,2,0,0)
end
else
calcregisters(self,1,0,0);
end

4
compiler/ncgcon.pas
View File

@ -524,9 +524,9 @@ implementation
else
indexadjust := 3;
{ small sets are loaded as constants }
if tsetdef(resultdef).settype=smallset then
if not(is_varset(resultdef)) then
begin
location_reset(location,LOC_CONSTANT,OS_32);
location_reset(location,LOC_CONSTANT,int_cgsize(resultdef.size));
location.value:=pLongint(value_set)^;
exit;
end;

145
compiler/ncnv.pas
View File

@ -70,6 +70,7 @@ interface
function typecheck_cstring_to_int : tnode;
function typecheck_char_to_char : tnode;
function typecheck_arrayconstructor_to_set : tnode;
function typecheck_set_to_set : tnode;
function typecheck_pchar_to_string : tnode;
function typecheck_interface_to_guid : tnode;
function typecheck_dynarray_to_openarray : tnode;
@ -99,7 +100,7 @@ interface
function first_int_to_bool : tnode;virtual;
function first_bool_to_bool : tnode;virtual;
function first_proc_to_procvar : tnode;virtual;
function first_load_smallset : tnode;virtual;
function first_set_to_set : tnode;virtual;
function first_cord_to_pointer : tnode;virtual;
function first_ansistring_to_pchar : tnode;virtual;
function first_arrayconstructor_to_set : tnode;virtual;
@ -125,12 +126,12 @@ interface
function _first_int_to_bool : tnode;
function _first_bool_to_bool : tnode;
function _first_proc_to_procvar : tnode;
function _first_load_smallset : tnode;
function _first_cord_to_pointer : tnode;
function _first_ansistring_to_pchar : tnode;
function _first_arrayconstructor_to_set : tnode;
function _first_class_to_intf : tnode;
function _first_char_to_char : tnode;
function _first_set_to_set : tnode;
procedure _second_int_to_int;virtual;
procedure _second_string_to_string;virtual;
@ -148,7 +149,7 @@ interface
procedure _second_bool_to_int;virtual;
procedure _second_int_to_bool;virtual;
procedure _second_bool_to_bool;virtual;
procedure _second_load_smallset;virtual;
procedure _second_set_to_set;virtual;
procedure _second_ansistring_to_pchar;virtual;
procedure _second_class_to_intf;virtual;
procedure _second_char_to_char;virtual;
@ -170,7 +171,7 @@ interface
procedure second_bool_to_int;virtual;abstract;
procedure second_int_to_bool;virtual;abstract;
procedure second_bool_to_bool;virtual;abstract;
procedure second_load_smallset;virtual;abstract;
procedure second_set_to_set;virtual;abstract;
procedure second_ansistring_to_pchar;virtual;abstract;
procedure second_class_to_intf;virtual;abstract;
procedure second_char_to_char;virtual;abstract;
@ -703,13 +704,12 @@ implementation
'tc_real_2_currency',
'tc_proc_2_procvar',
'tc_arrayconstructor_2_set',
'tc_load_smallset',
'tc_set_2_set',
'tc_cord_2_pointer',
'tc_intf_2_string',
'tc_intf_2_guid',
'tc_class_2_intf',
'tc_char_2_char',
'tc_normal_2_smallset',
'tc_dynarray_2_openarray',
'tc_pwchar_2_string',
'tc_variant_2_dynarray',
@ -1135,10 +1135,8 @@ implementation
function ttypeconvnode.typecheck_arrayconstructor_to_set : tnode;
var
hp : tnode;
begin
result:=nil;
if left.nodetype<>arrayconstructorn then
@ -1152,8 +1150,29 @@ implementation
end;
function ttypeconvnode.typecheck_pchar_to_string : tnode;
function ttypeconvnode.typecheck_set_to_set : tnode;
begin
result:=nil;
{ because is_equal only checks the basetype for sets we need to
check here if we are loading a smallset into a normalset }
if (resultdef.typ=setdef) and
(left.resultdef.typ=setdef) and
((tsetdef(resultdef).setmax<>tsetdef(left.resultdef).setmax) or
(tsetdef(resultdef).setbase<>tsetdef(left.resultdef).setbase)) then
begin
{ constant sets can be converted by changing the type only }
if (left.nodetype=setconstn) then
begin
left.resultdef:=resultdef;
result:=left;
left:=nil;
exit;
end;
end;
end;
function ttypeconvnode.typecheck_pchar_to_string : tnode;
begin
result := ccallnode.createinternres(
'fpc_pchar_to_'+tstringdef(resultdef).stringtypname,
@ -1163,7 +1182,6 @@ implementation
function ttypeconvnode.typecheck_interface_to_guid : tnode;
begin
if assigned(tobjectdef(left.resultdef).iidguid) then
result:=cguidconstnode.create(tobjectdef(left.resultdef).iidguid^);
@ -1171,7 +1189,6 @@ implementation
function ttypeconvnode.typecheck_dynarray_to_openarray : tnode;
begin
{ a dynamic array is a pointer to an array, so to convert it to }
{ an open array, we have to dereference it (JM) }
@ -1186,7 +1203,6 @@ implementation
function ttypeconvnode.typecheck_pwchar_to_string : tnode;
begin
result := ccallnode.createinternres(
'fpc_pwidechar_to_'+tstringdef(resultdef).stringtypname,
@ -1196,7 +1212,6 @@ implementation
function ttypeconvnode.typecheck_variant_to_dynarray : tnode;
begin
result := ccallnode.createinternres(
'fpc_variant_to_dynarray',
@ -1209,7 +1224,6 @@ implementation
function ttypeconvnode.typecheck_dynarray_to_variant : tnode;
begin
result := ccallnode.createinternres(
'fpc_dynarray_to_variant',
@ -1411,13 +1425,12 @@ implementation
{ real_2_currency } @ttypeconvnode.typecheck_real_to_currency,
{ proc_2_procvar } @ttypeconvnode.typecheck_proc_to_procvar,
{ arrayconstructor_2_set } @ttypeconvnode.typecheck_arrayconstructor_to_set,
{ load_smallset } nil,
{ set_to_set } @ttypeconvnode.typecheck_set_to_set,
{ cord_2_pointer } @ttypeconvnode.typecheck_cord_to_pointer,
{ intf_2_string } nil,
{ intf_2_guid } @ttypeconvnode.typecheck_interface_to_guid,
{ class_2_intf } nil,
{ char_2_char } @ttypeconvnode.typecheck_char_to_char,
{ normal_2_smallset} nil,
{ dynarray_2_openarray} @ttypeconvnode.typecheck_dynarray_to_openarray,
{ pwchar_2_string} @ttypeconvnode.typecheck_pwchar_to_string,
{ variant_2_dynarray} @ttypeconvnode.typecheck_variant_to_dynarray,
@ -1508,42 +1521,17 @@ implementation
if assigned(result) then
exit;
{ because is_equal only checks the basetype for sets we need to
check here if we are loading a smallset into a normalset }
if (resultdef.typ=setdef) and
(left.resultdef.typ=setdef) and
((tsetdef(resultdef).settype = smallset) xor
(tsetdef(left.resultdef).settype = smallset)) then
begin
{ constant sets can be converted by changing the type only }
if (left.nodetype=setconstn) then
begin
left.resultdef:=resultdef;
result:=left;
left:=nil;
exit;
end;
if (tsetdef(resultdef).settype <> smallset) then
convtype:=tc_load_smallset
else
convtype := tc_normal_2_smallset;
exit;
end
else
{ Only leave when there is no conversion to do.
We can still need to call a conversion routine,
like the routine to convert a stringconstnode }
if convtype in [tc_equal,tc_not_possible] then
begin
{ Only leave when there is no conversion to do.
We can still need to call a conversion routine,
like the routine to convert a stringconstnode }
if convtype in [tc_equal,tc_not_possible] then
begin
left.resultdef:=resultdef;
if (nf_explicit in flags) and (left.nodetype = addrn) then
include(left.flags, nf_typedaddr);
result:=left;
left:=nil;
exit;
end;
left.resultdef:=resultdef;
if (nf_explicit in flags) and (left.nodetype = addrn) then
include(left.flags, nf_typedaddr);
result:=left;
left:=nil;
exit;
end;
end;
@ -1887,8 +1875,7 @@ implementation
end;
procedure Ttypeconvnode.mark_write;
procedure Ttypeconvnode.mark_write;
begin
left.mark_write;
end;
@ -2245,21 +2232,26 @@ implementation
end;
function ttypeconvnode.first_load_smallset : tnode;
function ttypeconvnode.first_set_to_set : tnode;
var
srsym: ttypesym;
newstatement : tstatementnode;
temp : ttempcreatenode;
begin
{ old small set code }
if left.resultdef.size=4 then
{ in theory, we should do range checking here,
but Delphi doesn't do it either (FK) }
if left.nodetype=setconstn then
begin
srsym:=search_system_type('FPC_SMALL_SET');
result :=
ccallnode.createinternres('fpc_set_load_small',
ccallparanode.create(ctypeconvnode.create_internal(left,srsym.typedef),nil),resultdef);
left.resultdef:=resultdef;
result:=left;
end
{ equal sets for the code generator? }
else if (left.resultdef.size=resultdef.size) and
(tsetdef(left.resultdef).setbase=tsetdef(resultdef).setbase) then
result:=left
else
// if is_varset(resultdef) then
begin
result:=internalstatements(newstatement);
@ -2276,13 +2268,21 @@ implementation
addstatement(newstatement,ctempdeletenode.create_normal_temp(temp));
addstatement(newstatement,ctemprefnode.create(temp));
end;
{
else
begin
srsym:=search_system_type('FPC_SMALL_SET');
result :=
ccallnode.createinternres('fpc_set_load_small',
ccallparanode.create(ctypeconvnode.create_internal(left,srsym.typedef),nil),resultdef);
end;
}
{ reused }
left := nil;
left:=nil;
end;
function ttypeconvnode.first_ansistring_to_pchar : tnode;
begin
first_ansistring_to_pchar:=nil;
expectloc:=LOC_REGISTER;
@ -2297,8 +2297,8 @@ implementation
internalerror(200104022);
end;
function ttypeconvnode.first_class_to_intf : tnode;
function ttypeconvnode.first_class_to_intf : tnode;
begin
first_class_to_intf:=nil;
expectloc:=LOC_REGISTER;
@ -2381,9 +2381,9 @@ implementation
result:=first_proc_to_procvar;
end;
function ttypeconvnode._first_load_smallset : tnode;
function ttypeconvnode._first_set_to_set : tnode;
begin
result:=first_load_smallset;
result:=first_set_to_set;
end;
function ttypeconvnode._first_cord_to_pointer : tnode;
@ -2439,7 +2439,7 @@ implementation
nil, { removed in typecheck_real_to_currency }
@ttypeconvnode._first_proc_to_procvar,
@ttypeconvnode._first_arrayconstructor_to_set,
@ttypeconvnode._first_load_smallset,
@ttypeconvnode._first_set_to_set,
@ttypeconvnode._first_cord_to_pointer,
@ttypeconvnode._first_nothing,
@ttypeconvnode._first_nothing,
@ -2453,18 +2453,15 @@ implementation
nil,
nil,
nil,
nil,
nil
);
type
tprocedureofobject = function : tnode of object;
var
r : packed record
proc : pointer;
obj : pointer;
end;
begin
{ this is a little bit dirty but it works }
{ and should be quite portable too }
@ -2626,9 +2623,10 @@ implementation
second_bool_to_bool;
end;
procedure ttypeconvnode._second_load_smallset;
procedure ttypeconvnode._second_set_to_set;
begin
second_load_smallset;
second_set_to_set;
end;
@ -2683,13 +2681,12 @@ implementation
@ttypeconvnode._second_nothing, { real_to_currency, handled in resultdef pass }
@ttypeconvnode._second_proc_to_procvar,
@ttypeconvnode._second_nothing, { arrayconstructor_to_set }
@ttypeconvnode._second_nothing, { second_load_smallset, handled in first pass }
@ttypeconvnode._second_nothing, { second_set_to_set, handled in first pass }
@ttypeconvnode._second_cord_to_pointer,
@ttypeconvnode._second_nothing, { interface 2 string }
@ttypeconvnode._second_nothing, { interface 2 guid }
@ttypeconvnode._second_class_to_intf,
@ttypeconvnode._second_char_to_char,
@ttypeconvnode._second_nothing, { normal_2_smallset }
@ttypeconvnode._second_nothing, { dynarray_2_openarray }
@ttypeconvnode._second_nothing, { pwchar_2_string }
@ttypeconvnode._second_nothing, { variant_2_dynarray }
@ -2901,7 +2898,6 @@ implementation
function tasnode.dogetcopy: tnode;
begin
result := inherited dogetcopy;
if assigned(call) then
@ -2912,7 +2908,6 @@ implementation
function tasnode.pass_1 : tnode;
var
procname: string;
begin

2
compiler/powerpc/nppccnv.pas
View File

@ -46,7 +46,7 @@ interface
{ procedure second_proc_to_procvar;override; }
{ procedure second_bool_to_int;override; }
{ procedure second_int_to_bool;override; }
{ procedure second_load_smallset;override; }
{ procedure second_set_to_set;override; }
{ procedure second_ansistring_to_pchar;override; }
{ procedure second_pchar_to_string;override; }
{ procedure second_class_to_intf;override; }

2
compiler/symdef.pas
View File

@ -2006,7 +2006,7 @@ implementation
begin
inherited create(setdef);
elementdef:=def;
// setbase:=low;
setbase:=0;
setmax:=high;
if high<32 then
begin

2
compiler/x86/nx86cnv.pas
View File

@ -47,7 +47,7 @@ interface
{ procedure second_proc_to_procvar;override; }
{ procedure second_bool_to_int;override; }
procedure second_int_to_bool;override;
{ procedure second_load_smallset;override; }
{ procedure second_set_to_set;override; }
{ procedure second_ansistring_to_pchar;override; }
{ procedure second_pchar_to_string;override; }
{ procedure second_class_to_intf;override; }

4
rtl/inc/genset.inc
View File

@ -211,10 +211,12 @@ function fpc_set_unset_byte(const source: fpc_normal_set; b : byte): fpc_normal_
{$ifndef FPC_SYSTEM_HAS_FPC_VARSET_LOAD_SMALL}
{
load a normal set p from a smallset l
convert sets
}
procedure fpc_varset_load(const l;sourcesize : longint;var dest;size : ptrint); compilerproc;
begin
if sourcesize>size then
sourcesize:=size;
move(l,plongint(@dest)^,sourcesize);
FillChar((@dest+sourcesize)^,size-sourcesize,0);
end;