paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-17 01:39:26 +02:00
Code Issues Packages Projects Releases Wiki Activity

* procvar cleanup

Browse Source
This commit is contained in:
peter 2004-02-20 21:55:59 +00:00
parent a4732d1009
commit c844c5a505
13 changed files with 360 additions and 337 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
compiler/nadd.pas
View File

@ -74,7 +74,7 @@ implementation
symconst,symtype,symdef,symsym,symtable,defutil,defcmp,
cgbase,
htypechk,pass_1,
nbas,nmat,ncnv,ncon,nset,nopt,ncal,ninl,nmem,
nbas,nmat,ncnv,ncon,nset,nopt,ncal,ninl,nmem,nutils,
{$ifdef state_tracking}
nstate,
{$endif}
@ -128,6 +128,10 @@ implementation
if codegenerror then
exit;
{ tp procvar support }
maybe_call_procvar(left,true);
maybe_call_procvar(right,true);
{ convert array constructors to sets, because there is no other operator
possible for array constructors }
if is_array_constructor(left.resulttype.def) then
@ -1910,7 +1914,10 @@ begin
end.
{
$Log$
Revision 1.110 2004-02-05 01:24:08 florian
Revision 1.111 2004-02-20 21:55:59 peter
* procvar cleanup
Revision 1.110 2004/02/05 01:24:08 florian
* several fixes to compile x86-64 system
Revision 1.109 2004/02/03 22:32:54 peter

96
compiler/ncal.pas
View File

@ -194,7 +194,7 @@ implementation
verbose,globals,
symconst,defutil,defcmp,
htypechk,pass_1,
ncnv,nld,ninl,nadd,ncon,nmem,
ncnv,nld,ninl,nadd,ncon,nmem,nutils,
procinfo,
cgbase
;
@ -597,6 +597,16 @@ type
if (left.nodetype<>nothingn) then
begin
{ Convert tp procvars, this is needs to be done
here to make the change permanent. in the overload
choosing the changes are only made temporary }
if (left.resulttype.def.deftype=procvardef) and
(paraitem.paratype.def.deftype<>procvardef) then
begin
if maybe_call_procvar(left,true) then
resulttype:=left.resulttype;
end;
{ Handle varargs and hidden paras directly, no typeconvs or }
{ typechecking needed }
if (nf_varargs_para in flags) then
@ -1468,10 +1478,12 @@ type
currparanr : byte;
def_from,
def_to : tdef;
currpt,
pt : tcallparanode;
eq : tequaltype;
convtype : tconverttype;
pdoper : tprocdef;
releasecurrpt : boolean;
begin
{ process all procs }
hp:=procs;
@ -1487,9 +1499,13 @@ type
pt:=tcallparanode(left);
while assigned(pt) and assigned(currpara) do
begin
{ currpt can be changed from loadn to calln when a procvar
is passed. This is to prevent that the change is permanent }
currpt:=pt;
releasecurrpt:=false;
{ retrieve current parameter definitions to compares }
eq:=te_incompatible;
def_from:=pt.resulttype.def;
def_from:=currpt.resulttype.def;
def_to:=currpara.paratype.def;
if not(assigned(def_from)) then
internalerror(200212091);
@ -1500,18 +1516,29 @@ type
) then
internalerror(200212092);
{ Convert tp procvars when not expecting a procvar }
if (def_to.deftype<>procvardef) and
(currpt.left.resulttype.def.deftype=procvardef) then
begin
releasecurrpt:=true;
currpt:=tcallparanode(pt.getcopy);
if maybe_call_procvar(currpt.left,true) then
begin
currpt.resulttype:=currpt.left.resulttype;
def_from:=currpt.left.resulttype.def;
end;
end;
{ varargs are always equal, but not exact }
if (po_varargs in hp^.data.procoptions) and
(currparanr>hp^.data.minparacount) then
begin
inc(hp^.equal_count);
eq:=te_equal;
end
else
{ same definition -> exact }
if (def_from=def_to) then
begin
inc(hp^.exact_count);
eq:=te_exact;
end
else
@ -1522,7 +1549,6 @@ type
is_integer(def_to) and
is_in_limit(def_from,def_to) then
begin
inc(hp^.equal_count);
eq:=te_equal;
hp^.ordinal_distance:=hp^.ordinal_distance+
abs(bestreal(torddef(def_from).low)-bestreal(torddef(def_to).low));
@ -1536,7 +1562,7 @@ type
else
{ generic type comparision }
begin
eq:=compare_defs_ext(def_from,def_to,pt.left.nodetype,convtype,pdoper,
eq:=compare_defs_ext(def_from,def_to,currpt.left.nodetype,convtype,pdoper,
[cdo_allow_variant,cdo_check_operator]);
{ when the types are not equal we need to check
@ -1550,32 +1576,39 @@ type
eq:=te_incompatible;
{ var_para_allowed will return te_equal and te_convert_l1 to
make a difference for best matching }
var_para_allowed(eq,pt.resulttype.def,currpara.paratype.def)
var_para_allowed(eq,currpt.resulttype.def,currpara.paratype.def)
end
else
para_allowed(eq,pt,def_to);
para_allowed(eq,currpt,def_to);
end;
case eq of
te_exact :
internalerror(200212071); { already checked }
te_equal :
inc(hp^.equal_count);
te_convert_l1 :
inc(hp^.cl1_count);
te_convert_l2 :
inc(hp^.cl2_count);
te_convert_l3 :
inc(hp^.cl3_count);
te_convert_operator :
inc(hp^.coper_count);
te_incompatible :
hp^.invalid:=true;
else
internalerror(200212072);
end;
end;
{ when a procvar was changed to a call an exact much is
downgraded to equal. This way an overload call with the
procvar is choosen. See tb0471 (PFV) }
if (pt<>currpt) and (eq=te_exact) then
eq:=te_equal;
{ increase correct counter }
case eq of
te_exact :
inc(hp^.exact_count);
te_equal :
inc(hp^.equal_count);
te_convert_l1 :
inc(hp^.cl1_count);
te_convert_l2 :
inc(hp^.cl2_count);
te_convert_l3 :
inc(hp^.cl3_count);
te_convert_operator :
inc(hp^.coper_count);
te_incompatible :
hp^.invalid:=true;
else
internalerror(200212072);
end;
{ stop checking when an incompatible parameter is found }
if hp^.invalid then
begin
@ -1591,6 +1624,10 @@ type
currpara.eqval:=eq;
{$endif EXTDEBUG}
{ maybe release temp currpt }
if releasecurrpt then
currpt.free;
{ next parameter in the call tree }
pt:=tcallparanode(pt.right);
@ -2719,7 +2756,10 @@ begin
end.
{
$Log$
Revision 1.226 2004-02-19 17:07:42 florian
Revision 1.227 2004-02-20 21:55:59 peter
* procvar cleanup
Revision 1.226 2004/02/19 17:07:42 florian
* fixed arg. area calculation
Revision 1.225 2004/02/13 15:42:21 peter

7
compiler/ncgcal.pas
View File

@ -88,7 +88,7 @@ implementation
{$endif GDB}
cgbase,pass_2,
cpuinfo,aasmbase,aasmtai,
nbas,nmem,nld,ncnv,
nbas,nmem,nld,ncnv,nutils,
{$ifdef x86}
cga,cgx86,
{$endif x86}
@ -1210,7 +1210,10 @@ begin
end.
{
$Log$
Revision 1.154 2004-02-11 19:59:06 peter
Revision 1.155 2004-02-20 21:55:59 peter
* procvar cleanup
Revision 1.154 2004/02/11 19:59:06 peter
* fix compilation without GDB
Revision 1.153 2004/02/09 22:48:45 florian

7
compiler/ncgmem.pas
View File

@ -93,7 +93,7 @@ implementation
symconst,symdef,symsym,defutil,paramgr,
aasmbase,aasmtai,
procinfo,pass_2,
pass_1,nld,ncon,nadd,
pass_1,nld,ncon,nadd,nutils,
cgobj,tgobj,ncgutil,symbase
;
@ -881,7 +881,10 @@ begin
end.
{
$Log$
Revision 1.86 2004-02-03 22:32:54 peter
Revision 1.87 2004-02-20 21:55:59 peter
* procvar cleanup
Revision 1.86 2004/02/03 22:32:54 peter
* renamed xNNbittype to xNNinttype
* renamed registers32 to registersint
* replace some s32bit,u32bit with torddef([su]inttype).def.typ

50
compiler/ncnv.pas
View File

@ -202,7 +202,7 @@ implementation
globtype,systems,tokens,
cutils,verbose,globals,widestr,
symconst,symdef,symsym,symtable,
ncon,ncal,nset,nadd,ninl,nmem,nmat,
ncon,ncal,nset,nadd,ninl,nmem,nmat,nutils,
cgbase,procinfo,
htypechk,pass_1,cpuinfo;
@ -1141,6 +1141,12 @@ implementation
exit;
end;
{ tp procvar support. Skip typecasts to record or set. Those
convert on the procvar value. This is used to access the
fields of a methodpointer }
if not(resulttype.def.deftype in [recorddef,setdef]) then
maybe_call_procvar(left,true);
cdoptions:=[cdo_check_operator,cdo_allow_variant];
if nf_explicit in flags then
include(cdoptions,cdo_explicit);
@ -1350,43 +1356,6 @@ implementation
{ Constant folding and other node transitions to
remove the typeconv node }
case left.nodetype of
loadn :
begin
{ tp7 procvar support, when right is not a procvardef and we got a
loadn of a procvar (ignore procedures as void can not be converted)
then convert to a calln, the check for the result is already done
in is_convertible, also no conflict with @procvar is here because
that has an extra addrn.
The following deftypes always access the procvar: recorddef,setdef. This
has been tested with Kylix using trial and error }
if (m_tp_procvar in aktmodeswitches) and
(resulttype.def.deftype<>procvardef) and
{ ignore internal typecasts to access methodpointer fields }
not(resulttype.def.deftype in [recorddef,setdef]) and
(left.resulttype.def.deftype=procvardef) and
(not is_void(tprocvardef(left.resulttype.def).rettype.def)) then
begin
hp:=ccallnode.create_procvar(nil,left);
resulttypepass(hp);
left:=hp;
end;
end;
calln :
begin
{ See remark for loadn, this is the reverse }
if (m_tp_procvar in aktmodeswitches) and
(resulttype.def.deftype in [recorddef,setdef]) and
assigned(tcallnode(left).right) and
(tcallnode(left).para_count=0) then
begin
hp:=tcallnode(left).right.getcopy;
resulttypepass(hp);
left.free;
left:=hp;
end;
end;
niln :
begin
{ nil to ordinal node }
@ -2410,7 +2379,10 @@ begin
end.
{
$Log$
Revision 1.139 2004-02-13 15:42:21 peter
Revision 1.140 2004-02-20 21:55:59 peter
* procvar cleanup
Revision 1.139 2004/02/13 15:42:21 peter
* compare_defs_ext has now a options argument
* fixes for variants

7
compiler/ninl.pas
View File

@ -74,7 +74,7 @@ implementation
globtype, cutils,
symbase,symconst,symdef,symsym,symtable,paramgr,defutil,defcmp,
pass_1,
ncal,ncon,ncnv,nadd,nld,nbas,nflw,nmem,nmat,
ncal,ncon,ncnv,nadd,nld,nbas,nflw,nmem,nmat,nutils,
cgbase,procinfo
;
@ -2374,7 +2374,10 @@ begin
end.
{
$Log$
Revision 1.131 2004-02-04 18:45:29 jonas
Revision 1.132 2004-02-20 21:55:59 peter
* procvar cleanup
Revision 1.131 2004/02/04 18:45:29 jonas
+ some more usage of register temps
Revision 1.130 2004/02/03 22:32:54 peter

153
compiler/nld.pas
View File

@ -133,14 +133,6 @@ interface
crttinode : trttinodeclass;
procedure load_procvar_from_calln(var p1:tnode);
function load_high_value_node(vs:tvarsym):tnode;
function load_self_node:tnode;
function load_result_node:tnode;
function load_self_pointer_node:tnode;
function load_vmt_pointer_node:tnode;
function is_self_node(p:tnode):boolean;
implementation
@ -149,141 +141,10 @@ implementation
symtable,symnot,
defutil,defcmp,
htypechk,pass_1,procinfo,paramgr,
ncon,ninl,ncnv,nmem,ncal,cpubase,cgobj,cgbase
ncon,ninl,ncnv,nmem,ncal,nutils,
cpubase,cgobj,cgbase
;
{*****************************************************************************
Helpers
*****************************************************************************}
procedure load_procvar_from_calln(var p1:tnode);
var
p2 : tnode;
begin
if p1.nodetype<>calln then
internalerror(200212251);
{ was it a procvar, then we simply remove the calln and
reuse the right }
if assigned(tcallnode(p1).right) then
begin
p2:=tcallnode(p1).right;
tcallnode(p1).right:=nil;
end
else
begin
p2:=cloadnode.create_procvar(tcallnode(p1).symtableprocentry,
tprocdef(tcallnode(p1).procdefinition),tcallnode(p1).symtableproc);
{ when the methodpointer is typen we've something like:
tobject.create. Then only the address is needed of the
method without a self pointer }
if assigned(tcallnode(p1).methodpointer) and
(tcallnode(p1).methodpointer.nodetype<>typen) then
begin
tloadnode(p2).set_mp(tcallnode(p1).methodpointer);
tcallnode(p1).methodpointer:=nil;
end;
end;
resulttypepass(p2);
p1.free;
p1:=p2;
end;
function load_high_value_node(vs:tvarsym):tnode;
var
srsym : tsym;
srsymtable : tsymtable;
begin
result:=nil;
srsymtable:=vs.owner;
srsym:=searchsymonlyin(srsymtable,'high'+vs.name);
if assigned(srsym) then
begin
result:=cloadnode.create(srsym,srsymtable);
resulttypepass(result);
end
else
CGMessage(cg_e_illegal_expression);
end;
function load_self_node:tnode;
var
srsym : tsym;
srsymtable : tsymtable;
begin
result:=nil;
searchsym('self',srsym,srsymtable);
if assigned(srsym) then
begin
result:=cloadnode.create(srsym,srsymtable);
resulttypepass(result);
end
else
CGMessage(cg_e_illegal_expression);
end;
function load_result_node:tnode;
var
srsym : tsym;
srsymtable : tsymtable;
begin
result:=nil;
searchsym('result',srsym,srsymtable);
if assigned(srsym) then
begin
result:=cloadnode.create(srsym,srsymtable);
resulttypepass(result);
end
else
CGMessage(cg_e_illegal_expression);
end;
function load_self_pointer_node:tnode;
var
srsym : tsym;
srsymtable : tsymtable;
begin
result:=nil;
searchsym('self',srsym,srsymtable);
if assigned(srsym) then
begin
result:=cloadnode.create(srsym,srsymtable);
include(result.flags,nf_load_self_pointer);
resulttypepass(result);
end
else
CGMessage(cg_e_illegal_expression);
end;
function load_vmt_pointer_node:tnode;
var
srsym : tsym;
srsymtable : tsymtable;
begin
result:=nil;
searchsym('vmt',srsym,srsymtable);
if assigned(srsym) then
begin
result:=cloadnode.create(srsym,srsymtable);
resulttypepass(result);
end
else
CGMessage(cg_e_illegal_expression);
end;
function is_self_node(p:tnode):boolean;
begin
is_self_node:=(p.nodetype=loadn) and
(tloadnode(p).symtableentry.typ=varsym) and
(vo_is_self in tvarsym(tloadnode(p).symtableentry).varoptions);
end;
{*****************************************************************************
TLOADNODE
*****************************************************************************}
@ -656,6 +517,11 @@ implementation
if codegenerror then
exit;
{ tp procvar support, when we don't expect a procvar
then we need to call the procvar }
if (left.resulttype.def.deftype<>procvardef) then
maybe_call_procvar(right,true);
{ assignments to formaldefs and open arrays aren't allowed }
if (left.resulttype.def.deftype=formaldef) or
is_open_array(left.resulttype.def) then
@ -1256,7 +1122,10 @@ begin
end.
{
$Log$
Revision 1.122 2004-02-20 20:21:16 daniel
Revision 1.123 2004-02-20 21:55:59 peter
* procvar cleanup
Revision 1.122 2004/02/20 20:21:16 daniel
* Tarrayconstructornode sets pi_do_call if a call is possible
Revision 1.121 2004/02/03 22:32:54 peter

12
compiler/nmem.pas
View File

@ -130,7 +130,7 @@ implementation
globtype,systems,
cutils,verbose,globals,
symconst,symbase,defutil,defcmp,
nbas,
nbas,nutils,
htypechk,pass_1,ncal,nld,ncon,ncnv,cgbase,procinfo
;
@ -516,6 +516,9 @@ implementation
if codegenerror then
exit;
{ tp procvar support }
maybe_call_procvar(left,true);
if left.resulttype.def.deftype=pointerdef then
resulttype:=tpointerdef(left.resulttype.def).pointertype
else
@ -601,6 +604,8 @@ implementation
begin
result:=nil;
resulttypepass(left);
{ tp procvar support }
maybe_call_procvar(left,true);
resulttype:=vs.vartype;
end;
@ -970,7 +975,10 @@ begin
end.
{
$Log$
Revision 1.79 2004-02-03 22:32:54 peter
Revision 1.80 2004-02-20 21:55:59 peter
* procvar cleanup
Revision 1.79 2004/02/03 22:32:54 peter
* renamed xNNbittype to xNNinttype
* renamed registers32 to registersint
* replace some s32bit,u32bit with torddef([su]inttype).def.typ

181
compiler/nutils.pas
View File

@ -27,7 +27,7 @@ unit nutils;
interface
uses
node;
symsym,node;
type
{ resulttype of functions that process on all nodes in a (sub)tree }
@ -50,6 +50,15 @@ interface
function foreachnode(var n: tnode; f: foreachnodefunction): boolean;
function foreachnodestatic(var n: tnode; f: staticforeachnodefunction): boolean;
procedure load_procvar_from_calln(var p1:tnode);
function maybe_call_procvar(var p1:tnode;tponly:boolean):boolean;
function load_high_value_node(vs:tvarsym):tnode;
function load_self_node:tnode;
function load_result_node:tnode;
function load_self_pointer_node:tnode;
function load_vmt_pointer_node:tnode;
function is_self_node(p:tnode):boolean;
function call_fail_node:tnode;
function initialize_data_node(p:tnode):tnode;
function finalize_data_node(p:tnode):tnode;
@ -58,8 +67,8 @@ interface
implementation
uses
verbose,
symconst,symsym,symtype,symdef,symtable,
globtype,globals,verbose,
symconst,symbase,symtype,symdef,symtable,
nbas,ncon,ncnv,nld,nflw,nset,ncal,nadd,nmem,
cgbase,procinfo,
pass_1;
@ -157,6 +166,167 @@ implementation
end;
procedure load_procvar_from_calln(var p1:tnode);
var
p2 : tnode;
begin
if p1.nodetype<>calln then
internalerror(200212251);
{ was it a procvar, then we simply remove the calln and
reuse the right }
if assigned(tcallnode(p1).right) then
begin
p2:=tcallnode(p1).right;
tcallnode(p1).right:=nil;
end
else
begin
p2:=cloadnode.create_procvar(tcallnode(p1).symtableprocentry,
tprocdef(tcallnode(p1).procdefinition),tcallnode(p1).symtableproc);
{ when the methodpointer is typen we've something like:
tobject.create. Then only the address is needed of the
method without a self pointer }
if assigned(tcallnode(p1).methodpointer) and
(tcallnode(p1).methodpointer.nodetype<>typen) then
begin
tloadnode(p2).set_mp(tcallnode(p1).methodpointer);
tcallnode(p1).methodpointer:=nil;
end;
end;
resulttypepass(p2);
p1.free;
p1:=p2;
end;
function maybe_call_procvar(var p1:tnode;tponly:boolean):boolean;
var
hp : tnode;
begin
result:=false;
if (p1.resulttype.def.deftype<>procvardef) or
(tponly and
not(m_tp_procvar in aktmodeswitches)) then
exit;
{ ignore vecn,subscriptn }
hp:=p1;
repeat
case hp.nodetype of
vecn,
derefn,
typeconvn,
subscriptn :
hp:=tunarynode(hp).left;
else
break;
end;
until false;
if (hp.nodetype=loadn) then
begin
hp:=ccallnode.create_procvar(nil,p1);
resulttypepass(hp);
p1:=hp;
result:=true;
end;
end;
function load_high_value_node(vs:tvarsym):tnode;
var
srsym : tsym;
srsymtable : tsymtable;
begin
result:=nil;
srsymtable:=vs.owner;
srsym:=searchsymonlyin(srsymtable,'high'+vs.name);
if assigned(srsym) then
begin
result:=cloadnode.create(srsym,srsymtable);
resulttypepass(result);
end
else
CGMessage(cg_e_illegal_expression);
end;
function load_self_node:tnode;
var
srsym : tsym;
srsymtable : tsymtable;
begin
result:=nil;
searchsym('self',srsym,srsymtable);
if assigned(srsym) then
begin
result:=cloadnode.create(srsym,srsymtable);
resulttypepass(result);
end
else
CGMessage(cg_e_illegal_expression);
end;
function load_result_node:tnode;
var
srsym : tsym;
srsymtable : tsymtable;
begin
result:=nil;
searchsym('result',srsym,srsymtable);
if assigned(srsym) then
begin
result:=cloadnode.create(srsym,srsymtable);
resulttypepass(result);
end
else
CGMessage(cg_e_illegal_expression);
end;
function load_self_pointer_node:tnode;
var
srsym : tsym;
srsymtable : tsymtable;
begin
result:=nil;
searchsym('self',srsym,srsymtable);
if assigned(srsym) then
begin
result:=cloadnode.create(srsym,srsymtable);
include(result.flags,nf_load_self_pointer);
resulttypepass(result);
end
else
CGMessage(cg_e_illegal_expression);
end;
function load_vmt_pointer_node:tnode;
var
srsym : tsym;
srsymtable : tsymtable;
begin
result:=nil;
searchsym('vmt',srsym,srsymtable);
if assigned(srsym) then
begin
result:=cloadnode.create(srsym,srsymtable);
resulttypepass(result);
end
else
CGMessage(cg_e_illegal_expression);
end;
function is_self_node(p:tnode):boolean;
begin
is_self_node:=(p.nodetype=loadn) and
(tloadnode(p).symtableentry.typ=varsym) and
(vo_is_self in tvarsym(tloadnode(p).symtableentry).varoptions);
end;
function call_fail_node:tnode;
var
para : tcallparanode;
@ -254,7 +424,10 @@ end.
{
$Log$
Revision 1.9 2004-02-03 22:32:54 peter
Revision 1.10 2004-02-20 21:55:59 peter
* procvar cleanup
Revision 1.9 2004/02/03 22:32:54 peter
* renamed xNNbittype to xNNinttype
* renamed registers32 to registersint
* replace some s32bit,u32bit with torddef([su]inttype).def.typ

12
compiler/pdecvar.pas
View File

@ -48,7 +48,7 @@ implementation
fmodule,
{ pass 1 }
node,pass_1,
nmat,nadd,ncal,nset,ncnv,ninl,ncon,nld,nflw,nmem,
nmat,nadd,ncal,nset,ncnv,ninl,ncon,nld,nflw,nmem,nutils,
{ codegen }
ncgutil,
{ parser }
@ -725,9 +725,6 @@ implementation
Message(parser_e_absolute_only_one_var);
{ parse the rest }
pt:=expr;
{ transform a procvar calln to loadn }
if pt.nodetype=calln then
load_procvar_from_calln(pt);
{ check allowed absolute types }
if (pt.nodetype=stringconstn) or
(is_constcharnode(pt)) then
@ -1117,7 +1114,7 @@ implementation
{ Align the offset where the union symtable is added }
if (trecordsymtable(symtablestack).usefieldalignment=-1) then
usedalign:=used_align(maxalignment,aktalignment.recordalignmin,aktalignment.maxCrecordalign)
else
else
usedalign:=used_align(maxalignment,aktalignment.recordalignmin,aktalignment.recordalignmax);
offset:=align(trecordsymtable(symtablestack).datasize,usedalign);
trecordsymtable(symtablestack).datasize:=offset+unionsymtable.datasize;
@ -1138,7 +1135,10 @@ implementation
end.
{
$Log$
Revision 1.66 2004-02-17 15:57:49 peter
Revision 1.67 2004-02-20 21:55:59 peter
* procvar cleanup
Revision 1.66 2004/02/17 15:57:49 peter
- fix rtti generation for properties containing sl_vec
- fix crash when overloaded operator is not available
- fix record alignment for C style variant records

117
compiler/pexpr.pas
View File

@ -75,7 +75,7 @@ implementation
symconst,symtable,symsym,defutil,defcmp,
{ pass 1 }
pass_1,htypechk,
nmat,nadd,ncal,nmem,nset,ncnv,ninl,ncon,nld,nflw,nbas,
nmat,nadd,ncal,nmem,nset,ncnv,ninl,ncon,nld,nflw,nbas,nutils,
{ parser }
scanner,
pbase,pinline,
@ -286,50 +286,6 @@ implementation
end;
procedure check_tp_procvar(var p : tnode);
var
hp,
p1 : tnode;
begin
if (m_tp_procvar in aktmodeswitches) and
(token<>_ASSIGNMENT) and
(not got_addrn) and
(block_type=bt_body) then
begin
{ ignore vecn,subscriptn }
hp:=p;
repeat
case hp.nodetype of
vecn :
hp:=tvecnode(hp).left;
subscriptn :
hp:=tsubscriptnode(hp).left;
else
break;
end;
until false;
if (hp.nodetype=loadn) then
begin
{ get the resulttype of p }
do_resulttypepass(p);
{ convert the procvar load to a call:
- not expecting a procvar
- the procvar does not get arguments, when it
requires arguments the callnode will fail
Note: When arguments were passed there was no loadn }
if (getprocvardef=nil) and
(p.resulttype.def.deftype=procvardef) and
(tprocvardef(p.resulttype.def).minparacount=0) then
begin
p1:=ccallnode.create_procvar(nil,p);
resulttypepass(p1);
p:=p1;
end;
end;
end;
end;
function statement_syssym(l : longint) : tnode;
var
p1,p2,paras : tnode;
@ -471,16 +427,6 @@ implementation
p1:=comp_expr(true);
if not codegenerror then
begin
{ With tp procvars we allways need to load a
procvar when it is passed, but not when the
callnode is inserted due a property or has
arguments }
if (m_tp_procvar in aktmodeswitches) and
(p1.nodetype=calln) and
(tcallnode(p1).para_count=0) and
not(nf_isproperty in tcallnode(p1).flags) then
load_procvar_from_calln(p1);
case p1.resulttype.def.deftype of
procdef, { procvar }
pointerdef,
@ -1761,31 +1707,22 @@ implementation
else
begin
{ is this a procedure variable ? }
if assigned(p1.resulttype.def) then
begin
if (p1.resulttype.def.deftype=procvardef) then
begin
if assigned(getprocvardef) and
equal_defs(p1.resulttype.def,getprocvardef) then
again:=false
else
if (token=_LKLAMMER) or
((tprocvardef(p1.resulttype.def).maxparacount=0) and
(not((token in [_ASSIGNMENT,_UNEQUAL,_EQUAL]))) and
(not afterassignment) and
(not in_args)) then
{ is this a procedure variable ? }
if assigned(p1.resulttype.def) and
(p1.resulttype.def.deftype=procvardef) then
begin
if assigned(getprocvardef) and
equal_defs(p1.resulttype.def,getprocvardef) then
again:=false
else
begin
if try_to_consume(_LKLAMMER) then
begin
if try_to_consume(_LKLAMMER) then
begin
p2:=parse_paras(false,false);
consume(_RKLAMMER);
end
else
p2:=nil;
p1:=ccallnode.create_procvar(p2,p1);
{ proc():= is never possible }
if token=_ASSIGNMENT then
p2:=parse_paras(false,false);
consume(_RKLAMMER);
p1:=ccallnode.create_procvar(p2,p1);
{ proc():= is never possible }
if token=_ASSIGNMENT then
begin
Message(cg_e_illegal_expression);
p1.free;
@ -1793,14 +1730,12 @@ implementation
again:=false;
end;
end
else
again:=false;
end
else
again:=false;
end
else
again:=false;
end;
end
else
again:=false;
again:=false;
end;
end;
end; { while again }
@ -2248,10 +2183,6 @@ implementation
if (not assigned(p1.resulttype.def)) then
do_resulttypepass(p1);
{ tp7 procvar handling, but not if the next token
will be a := }
check_tp_procvar(p1);
factor:=p1;
check_tokenpos;
end;
@ -2387,7 +2318,6 @@ implementation
if not assigned(p1.resulttype.def) then
do_resulttypepass(p1);
filepos:=akttokenpos;
check_tp_procvar(p1);
if token in [_ASSIGNMENT,_PLUSASN,_MINUSASN,_STARASN,_SLASHASN] then
afterassignment:=true;
oldp1:=p1;
@ -2489,7 +2419,10 @@ implementation
end.
{
$Log$
Revision 1.149 2004-02-18 21:58:53 peter
Revision 1.150 2004-02-20 21:55:59 peter
* procvar cleanup
Revision 1.149 2004/02/18 21:58:53 peter
* constants are now parsed as 64bit for cpu64bit
Revision 1.148 2004/02/17 23:36:40 daniel

31
compiler/pstatmnt.pas
View File

@ -941,16 +941,22 @@ implementation
end;
if p.nodetype=labeln then
begin
{ the pointer to the following instruction }
{ isn't a very clean way }
if token in endtokens then
tlabelnode(p).left:=cnothingnode.create
else
tlabelnode(p).left:=statement{$ifdef FPCPROCVAR}(){$endif};
{ be sure to have left also resulttypepass }
resulttypepass(tlabelnode(p).left);
end;
begin
{ the pointer to the following instruction }
{ isn't a very clean way }
if token in endtokens then
tlabelnode(p).left:=cnothingnode.create
else
tlabelnode(p).left:=statement{$ifdef FPCPROCVAR}(){$endif};
{ be sure to have left also resulttypepass }
resulttypepass(tlabelnode(p).left);
end
else
begin
{ change a load of a procvar to a call. this is also
supported in fpc mode }
maybe_call_procvar(p,false);
end;
{ blockn support because a read/write is changed into a blocknode }
{ with a separate statement for each read/write operation (JM) }
@ -1092,7 +1098,10 @@ implementation
end.
{
$Log$
Revision 1.129 2004-02-03 22:32:54 peter
Revision 1.130 2004-02-20 21:55:59 peter
* procvar cleanup
Revision 1.129 2004/02/03 22:32:54 peter
* renamed xNNbittype to xNNinttype
* renamed registers32 to registersint
* replace some s32bit,u32bit with torddef([su]inttype).def.typ

13
compiler/symtable.pas
View File

@ -765,7 +765,7 @@ implementation
[objectsymtable,parasymtable,localsymtable,staticsymtable])) then
begin
if (Errorcount<>0) or
(copy(p.name,1,3)='def') then
(sp_internal in tsym(p).symoptions) then
exit;
{ do not claim for inherited private fields !! }
if (Tsym(p).refs=0) and (tsym(p).owner.symtabletype=objectsymtable) then
@ -1090,7 +1090,7 @@ implementation
{ Calc alignment needed for this record }
if (usefieldalignment=-1) then
varalignrecord:=used_align(varalign,aktalignment.recordalignmin,aktalignment.maxCrecordalign)
else
else
varalignrecord:=used_align(varalign,aktalignment.recordalignmin,aktalignment.recordalignmax);
recordalignment:=max(recordalignment,varalignrecord);
end;
@ -1847,10 +1847,10 @@ implementation
end;
if (not assigned(topclass)) or
Tsym(srsym).is_visible_for_object(topclass) then
begin
begin
searchsym:=true;
exit;
end;
end;
end;
srsymtable:=srsymtable.next;
end;
@ -2427,7 +2427,10 @@ implementation
end.
{
$Log$
Revision 1.138 2004-02-17 15:57:49 peter
Revision 1.139 2004-02-20 21:55:59 peter
* procvar cleanup
Revision 1.138 2004/02/17 15:57:49 peter
- fix rtti generation for properties containing sl_vec
- fix crash when overloaded operator is not available
- fix record alignment for C style variant records