diff --git a/compiler/nadd.pas b/compiler/nadd.pas index 3493594d7f..d997345d6a 100644 --- a/compiler/nadd.pas +++ b/compiler/nadd.pas @@ -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 diff --git a/compiler/ncal.pas b/compiler/ncal.pas index 7f77410d58..f17a17602a 100644 --- a/compiler/ncal.pas +++ b/compiler/ncal.pas @@ -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 diff --git a/compiler/ncgcal.pas b/compiler/ncgcal.pas index 50fa78c83b..81432d7c2d 100644 --- a/compiler/ncgcal.pas +++ b/compiler/ncgcal.pas @@ -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 diff --git a/compiler/ncgmem.pas b/compiler/ncgmem.pas index ffe02710a4..ee2beda069 100644 --- a/compiler/ncgmem.pas +++ b/compiler/ncgmem.pas @@ -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 diff --git a/compiler/ncnv.pas b/compiler/ncnv.pas index 14bbee9313..c87a6fbe91 100644 --- a/compiler/ncnv.pas +++ b/compiler/ncnv.pas @@ -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 diff --git a/compiler/ninl.pas b/compiler/ninl.pas index 137886d5e8..2772567145 100644 --- a/compiler/ninl.pas +++ b/compiler/ninl.pas @@ -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 diff --git a/compiler/nld.pas b/compiler/nld.pas index 2a02d1d400..9da4b491eb 100644 --- a/compiler/nld.pas +++ b/compiler/nld.pas @@ -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 diff --git a/compiler/nmem.pas b/compiler/nmem.pas index 6a877c65f1..b9cc68a406 100644 --- a/compiler/nmem.pas +++ b/compiler/nmem.pas @@ -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 diff --git a/compiler/nutils.pas b/compiler/nutils.pas index 19f175bf9e..3e79594d0c 100644 --- a/compiler/nutils.pas +++ b/compiler/nutils.pas @@ -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 diff --git a/compiler/pdecvar.pas b/compiler/pdecvar.pas index ffb02aa244..e5bd657c44 100644 --- a/compiler/pdecvar.pas +++ b/compiler/pdecvar.pas @@ -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 diff --git a/compiler/pexpr.pas b/compiler/pexpr.pas index 8802bcf08d..9efd5b0a23 100644 --- a/compiler/pexpr.pas +++ b/compiler/pexpr.pas @@ -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 diff --git a/compiler/pstatmnt.pas b/compiler/pstatmnt.pas index b3d2d8f87f..306805c32e 100644 --- a/compiler/pstatmnt.pas +++ b/compiler/pstatmnt.pas @@ -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 diff --git a/compiler/symtable.pas b/compiler/symtable.pas index a002110fcf..54b6c48167 100644 --- a/compiler/symtable.pas +++ b/compiler/symtable.pas @@ -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