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

+ some stuff for the new hidden parameter handling added

Browse Source
This commit is contained in:
florian 2002-12-15 22:50:00 +00:00
parent ad7e970e39
commit c7ca2ff901
2 changed files with 128 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

153
compiler/ncal.pas
View File

@ -262,7 +262,7 @@ type
< 0 when bestpd is better than currpd < 0 when bestpd is better than currpd
= 0 when both are equal = 0 when both are equal
Too choose the best candidate we use the following order: To choose the best candidate we use the following order:
- Incompatible flag - Incompatible flag
- (Smaller) Number of convertlevel 2 parameters (needs less). - (Smaller) Number of convertlevel 2 parameters (needs less).
- (Smaller) Number of convertlevel 1 parameters. - (Smaller) Number of convertlevel 1 parameters.
@ -447,7 +447,9 @@ type
begin begin
inherited create(callparan,expr,next); inherited create(callparan,expr,next);
{$ifndef VS_HIDDEN}
hightree:=nil; hightree:=nil;
{$endif VS_HIDDEN}
if assigned(expr) then if assigned(expr) then
expr.set_file_line(self); expr.set_file_line(self);
callparaflags:=[]; callparaflags:=[];
@ -456,7 +458,9 @@ type
destructor tcallparanode.destroy; destructor tcallparanode.destroy;
begin begin
{$ifndef VS_HIDDEN}
hightree.free; hightree.free;
{$endif VS_HIDDEN}
inherited destroy; inherited destroy;
end; end;
@ -465,7 +469,9 @@ type
begin begin
inherited ppuload(t,ppufile); inherited ppuload(t,ppufile);
ppufile.getsmallset(callparaflags); ppufile.getsmallset(callparaflags);
{$ifndef VS_HIDDEN}
hightree:=ppuloadnode(ppufile); hightree:=ppuloadnode(ppufile);
{$endif VS_HIDDEN}
end; end;
@ -473,15 +479,19 @@ type
begin begin
inherited ppuwrite(ppufile); inherited ppuwrite(ppufile);
ppufile.putsmallset(callparaflags); ppufile.putsmallset(callparaflags);
{$ifndef VS_HIDDEN}
ppuwritenode(ppufile,hightree); ppuwritenode(ppufile,hightree);
{$endif VS_HIDDEN}
end; end;
procedure tcallparanode.derefimpl; procedure tcallparanode.derefimpl;
begin begin
inherited derefimpl; inherited derefimpl;
{$ifndef VS_HIDDEN}
if assigned(hightree) then if assigned(hightree) then
hightree.derefimpl; hightree.derefimpl;
{$endif VS_HIDDEN}
end; end;
@ -493,10 +503,12 @@ type
begin begin
n:=tcallparanode(inherited getcopy); n:=tcallparanode(inherited getcopy);
n.callparaflags:=callparaflags; n.callparaflags:=callparaflags;
{$ifndef VS_HIDDEN}
if assigned(hightree) then if assigned(hightree) then
n.hightree:=hightree.getcopy n.hightree:=hightree.getcopy
else else
n.hightree:=nil; n.hightree:=nil;
{$endif VS_HIDDEN}
n.paraitem:=paraitem; n.paraitem:=paraitem;
result:=n; result:=n;
end; end;
@ -541,7 +553,7 @@ type
paraitem:=defcoll; paraitem:=defcoll;
if not assigned(defcoll) then if not assigned(paraitem) then
internalerror(200104261); internalerror(200104261);
{$ifdef extdebug} {$ifdef extdebug}
@ -554,13 +566,12 @@ type
if assigned(right) then if assigned(right) then
begin begin
{ if we are a para that belongs to varargs then keep { if we are a para that belongs to varargs then keep
the current defcoll } the current paraitem }
if (nf_varargs_para in flags) then if (nf_varargs_para in flags) then
tcallparanode(right).insert_typeconv(defcoll,do_count) tcallparanode(right).insert_typeconv(paraitem,do_count)
else else
tcallparanode(right).insert_typeconv(tparaitem(defcoll.next),do_count); tcallparanode(right).insert_typeconv(tparaitem(paraitem.next),do_count)
end; end;
{ Be sure to have the resulttype } { Be sure to have the resulttype }
if not assigned(left.resulttype.def) then if not assigned(left.resulttype.def) then
resulttypepass(left); resulttypepass(left);
@ -585,13 +596,13 @@ type
it here before the arrayconstructor node breaks the tree it here before the arrayconstructor node breaks the tree
with its conversions of enum->ord } with its conversions of enum->ord }
if (left.nodetype=arrayconstructorn) and if (left.nodetype=arrayconstructorn) and
(defcoll.paratype.def.deftype=setdef) then (paraitem.paratype.def.deftype=setdef) then
inserttypeconv(left,defcoll.paratype); inserttypeconv(left,paraitem.paratype);
{ set some settings needed for arrayconstructor } { set some settings needed for arrayconstructor }
if is_array_constructor(left.resulttype.def) then if is_array_constructor(left.resulttype.def) then
begin begin
if is_array_of_const(defcoll.paratype.def) then if is_array_of_const(paraitem.paratype.def) then
begin begin
if assigned(aktcallprocdef) and if assigned(aktcallprocdef) and
(aktcallprocdef.proccalloption in [pocall_cppdecl,pocall_cdecl]) then (aktcallprocdef.proccalloption in [pocall_cppdecl,pocall_cdecl]) then
@ -604,29 +615,29 @@ type
include(left.flags,nf_novariaallowed); include(left.flags,nf_novariaallowed);
{ now that the resultting type is know we can insert the required { now that the resultting type is know we can insert the required
typeconvs for the array constructor } typeconvs for the array constructor }
tarrayconstructornode(left).force_type(tarraydef(defcoll.paratype.def).elementtype); tarrayconstructornode(left).force_type(tarraydef(paraitem.paratype.def).elementtype);
end; end;
end; end;
{ check if local proc/func is assigned to procvar } { check if local proc/func is assigned to procvar }
if left.resulttype.def.deftype=procvardef then if left.resulttype.def.deftype=procvardef then
test_local_to_procvar(tprocvardef(left.resulttype.def),defcoll.paratype.def); test_local_to_procvar(tprocvardef(left.resulttype.def),paraitem.paratype.def);
{ generate the high() value tree } { generate the high() value tree }
if paramanager.push_high_param(defcoll.paratype.def,aktcallprocdef.proccalloption) then if paramanager.push_high_param(paraitem.paratype.def,aktcallprocdef.proccalloption) then
gen_high_tree(is_open_string(defcoll.paratype.def)); gen_high_tree(is_open_string(paraitem.paratype.def));
{ test conversions } { test conversions }
if not(is_shortstring(left.resulttype.def) and if not(is_shortstring(left.resulttype.def) and
is_shortstring(defcoll.paratype.def)) and is_shortstring(paraitem.paratype.def)) and
(defcoll.paratype.def.deftype<>formaldef) then (paraitem.paratype.def.deftype<>formaldef) then
begin begin
{ Process open parameters } { Process open parameters }
if paramanager.push_high_param(defcoll.paratype.def,aktcallprocdef.proccalloption) then if paramanager.push_high_param(paraitem.paratype.def,aktcallprocdef.proccalloption) then
begin begin
{ insert type conv but hold the ranges of the array } { insert type conv but hold the ranges of the array }
oldtype:=left.resulttype; oldtype:=left.resulttype;
inserttypeconv(left,defcoll.paratype); inserttypeconv(left,paraitem.paratype);
left.resulttype:=oldtype; left.resulttype:=oldtype;
end end
else else
@ -636,7 +647,7 @@ type
if (left.resulttype.def.deftype in [enumdef,orddef,floatdef]) and if (left.resulttype.def.deftype in [enumdef,orddef,floatdef]) and
(left.nodetype in [vecn,loadn,calln]) then (left.nodetype in [vecn,loadn,calln]) then
begin begin
if (left.resulttype.def.size>defcoll.paratype.def.size) then if (left.resulttype.def.size>paraitem.paratype.def.size) then
begin begin
if (cs_check_range in aktlocalswitches) then if (cs_check_range in aktlocalswitches) then
Message(type_w_smaller_possible_range_check) Message(type_w_smaller_possible_range_check)
@ -644,7 +655,7 @@ type
Message(type_h_smaller_possible_range_check); Message(type_h_smaller_possible_range_check);
end; end;
end; end;
inserttypeconv(left,defcoll.paratype); inserttypeconv(left,paraitem.paratype);
end; end;
if codegenerror then if codegenerror then
begin begin
@ -656,17 +667,17 @@ type
{ check var strings } { check var strings }
if (cs_strict_var_strings in aktlocalswitches) and if (cs_strict_var_strings in aktlocalswitches) and
is_shortstring(left.resulttype.def) and is_shortstring(left.resulttype.def) and
is_shortstring(defcoll.paratype.def) and is_shortstring(paraitem.paratype.def) and
(defcoll.paratyp in [vs_out,vs_var]) and (paraitem.paratyp in [vs_out,vs_var]) and
not(is_open_string(defcoll.paratype.def)) and not(is_open_string(paraitem.paratype.def)) and
not(equal_defs(left.resulttype.def,defcoll.paratype.def)) then not(equal_defs(left.resulttype.def,paraitem.paratype.def)) then
begin begin
aktfilepos:=left.fileinfo; aktfilepos:=left.fileinfo;
CGMessage(type_e_strict_var_string_violation); CGMessage(type_e_strict_var_string_violation);
end; end;
{ Handle formal parameters separate } { Handle formal parameters separate }
if (defcoll.paratype.def.deftype=formaldef) then if (paraitem.paratype.def.deftype=formaldef) then
begin begin
{ load procvar if a procedure is passed } { load procvar if a procedure is passed }
if (m_tp_procvar in aktmodeswitches) and if (m_tp_procvar in aktmodeswitches) and
@ -674,7 +685,7 @@ type
(is_void(left.resulttype.def)) then (is_void(left.resulttype.def)) then
load_procvar_from_calln(left); load_procvar_from_calln(left);
case defcoll.paratyp of case paraitem.paratyp of
vs_var, vs_var,
vs_out : vs_out :
begin begin
@ -691,33 +702,33 @@ type
else else
begin begin
{ check if the argument is allowed } { check if the argument is allowed }
if (defcoll.paratyp in [vs_out,vs_var]) then if (paraitem.paratyp in [vs_out,vs_var]) then
valid_for_var(left); valid_for_var(left);
end; end;
if defcoll.paratyp in [vs_var,vs_const] then if paraitem.paratyp in [vs_var,vs_const] then
begin begin
{ Causes problems with const ansistrings if also } { Causes problems with const ansistrings if also }
{ done for vs_const (JM) } { done for vs_const (JM) }
if defcoll.paratyp = vs_var then if paraitem.paratyp = vs_var then
set_unique(left); set_unique(left);
make_not_regable(left); make_not_regable(left);
end; end;
{ ansistrings out paramaters doesn't need to be } { ansistrings out paramaters doesn't need to be }
{ unique, they are finalized } { unique, they are finalized }
if defcoll.paratyp=vs_out then if paraitem.paratyp=vs_out then
make_not_regable(left); make_not_regable(left);
if do_count then if do_count then
begin begin
{ not completly proper, but avoids some warnings } { not completly proper, but avoids some warnings }
if (defcoll.paratyp in [vs_var,vs_out]) then if (paraitem.paratyp in [vs_var,vs_out]) then
set_funcret_is_valid(left); set_funcret_is_valid(left);
set_varstate(left,not(defcoll.paratyp in [vs_var,vs_out])); set_varstate(left,not(paraitem.paratyp in [vs_var,vs_out]));
end; end;
{ must only be done after typeconv PM } { must only be done after typeconv PM }
resulttype:=defcoll.paratype; resulttype:=paraitem.paratype;
dec(parsing_para_level); dec(parsing_para_level);
{$ifdef extdebug} {$ifdef extdebug}
if do_count then if do_count then
@ -774,7 +785,71 @@ type
det_registers; det_registers;
end; end;
{$ifdef VS_HIDDEN}
procedure tcallparanode.gen_high_tree(openstring:boolean);
var
temp: tnode;
len : integer;
loadconst : boolean;
hightree : tnode;
begin
if assigned(hightree) then
exit;
len:=-1;
loadconst:=true;
case left.resulttype.def.deftype of
arraydef :
begin
{ handle via a normal inline in_high_x node }
loadconst := false;
hightree := geninlinenode(in_high_x,false,left.getcopy);
{ only substract low(array) if it's <> 0 }
temp := geninlinenode(in_low_x,false,left.getcopy);
firstpass(temp);
if (temp.nodetype <> ordconstn) or
(tordconstnode(temp).value <> 0) then
hightree := caddnode.create(subn,hightree,temp)
else
temp.free;
end;
stringdef :
begin
if openstring then
begin
{ handle via a normal inline in_high_x node }
loadconst := false;
hightree := geninlinenode(in_high_x,false,left.getcopy);
end
else
{ passing a string to an array of char }
begin
if (left.nodetype=stringconstn) then
begin
len:=str_length(left);
if len>0 then
dec(len);
end
else
begin
hightree:=caddnode.create(subn,geninlinenode(in_length_x,false,left.getcopy),
cordconstnode.create(1,s32bittype,false));
loadconst:=false;
end;
end;
end;
else
len:=0;
end;
if loadconst then
hightree:=cordconstnode.create(len,s32bittype,true)
else
hightree:=ctypeconvnode.create(hightree,s32bittype);
firstpass(hightree);
temp:=ccallparanode.create(hightree,right);
right:=temp;
end;
{$else VS_HIDDEN}
procedure tcallparanode.gen_high_tree(openstring:boolean); procedure tcallparanode.gen_high_tree(openstring:boolean);
var var
temp: tnode; temp: tnode;
@ -834,14 +909,17 @@ type
hightree:=ctypeconvnode.create(hightree,s32bittype); hightree:=ctypeconvnode.create(hightree,s32bittype);
firstpass(hightree); firstpass(hightree);
end; end;
{$endif VS_HIDDEN}
function tcallparanode.docompare(p: tnode): boolean; function tcallparanode.docompare(p: tnode): boolean;
begin begin
docompare := docompare :=
inherited docompare(p) and inherited docompare(p) and
(callparaflags = tcallparanode(p).callparaflags) and (callparaflags = tcallparanode(p).callparaflags)
hightree.isequal(tcallparanode(p).hightree); {$ifndef VS_HIDDEN}
and hightree.isequal(tcallparanode(p).hightree)
{$endif VS_HIDDEN}
;
end; end;
{**************************************************************************** {****************************************************************************
@ -2198,7 +2276,10 @@ begin
end. end.
{ {
$Log$ $Log$
Revision 1.121 2002-12-15 21:34:15 peter Revision 1.122 2002-12-15 22:50:00 florian
+ some stuff for the new hidden parameter handling added
Revision 1.121 2002/12/15 21:34:15 peter
* give sign difference between ordinals a small penalty. This is * give sign difference between ordinals a small penalty. This is
needed to get word->[longword|longint] working needed to get word->[longword|longint] working

13
compiler/ncgcal.pas
View File

@ -83,6 +83,8 @@ implementation
procedure tcgcallparanode.secondcallparan(push_from_left_to_right:boolean;calloption:tproccalloption;para_alignment,para_offset : longint); procedure tcgcallparanode.secondcallparan(push_from_left_to_right:boolean;calloption:tproccalloption;para_alignment,para_offset : longint);
{$ifndef VS_HIDDEN}
{ goes to pass 1 } { goes to pass 1 }
procedure maybe_push_high; procedure maybe_push_high;
begin begin
@ -96,7 +98,7 @@ implementation
push_value_para(hightree,calloption,para_offset,4,paraitem.paraloc); push_value_para(hightree,calloption,para_offset,4,paraitem.paraloc);
end; end;
end; end;
{$endif VS_HIDDEN}
var var
otlabel,oflabel : tasmlabel; otlabel,oflabel : tasmlabel;
@ -198,7 +200,9 @@ implementation
{$ifdef unused} {$ifdef unused}
if not push_from_left_to_right then if not push_from_left_to_right then
{$endif unused} {$endif unused}
{$ifndef VS_HIDDEN}
maybe_push_high; maybe_push_high;
{$endif VS_HIDDEN}
if (paraitem.paratyp=vs_out) and if (paraitem.paratyp=vs_out) and
assigned(paraitem.paratype.def) and assigned(paraitem.paratype.def) and
not is_class(paraitem.paratype.def) and not is_class(paraitem.paratype.def) and
@ -261,7 +265,9 @@ implementation
{$ifdef unused} {$ifdef unused}
if not push_from_left_to_right then if not push_from_left_to_right then
{$endif unused} {$endif unused}
{$ifndef VS_HIDDEN}
maybe_push_high; maybe_push_high;
{$endif VS_HIDDEN}
inc(pushedparasize,4); inc(pushedparasize,4);
if calloption=pocall_inline then if calloption=pocall_inline then
begin begin
@ -1549,7 +1555,10 @@ begin
end. end.
{ {
$Log$ $Log$
Revision 1.31 2002-12-15 21:30:12 florian Revision 1.32 2002-12-15 22:50:00 florian
+ some stuff for the new hidden parameter handling added
Revision 1.31 2002/12/15 21:30:12 florian
* tcallnode.paraitem introduced, all references to defcoll removed * tcallnode.paraitem introduced, all references to defcoll removed
Revision 1.30 2002/11/27 20:04:39 peter Revision 1.30 2002/11/27 20:04:39 peter