diff options
Diffstat (limited to 'compiler/htypechk.pas')
| -rw-r--r-- | compiler/htypechk.pas | 2150 |
1 files changed, 2150 insertions, 0 deletions
diff --git a/compiler/htypechk.pas b/compiler/htypechk.pas new file mode 100644 index 0000000000..7db14c51e9 --- /dev/null +++ b/compiler/htypechk.pas @@ -0,0 +1,2150 @@ +{ + Copyright (c) 1998-2002 by Florian Klaempfl + + This unit exports some help routines for the type checking + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + **************************************************************************** +} +unit htypechk; + +{$i fpcdefs.inc} + +interface + + uses + tokens,cpuinfo, + node, + symconst,symtype,symdef,symsym,symbase; + + type + Ttok2nodeRec=record + tok : ttoken; + nod : tnodetype; + op_overloading_supported : boolean; + end; + + pcandidate = ^tcandidate; + tcandidate = record + next : pcandidate; + data : tprocdef; + wrongparaidx, + firstparaidx : integer; + exact_count, + equal_count, + cl1_count, + cl2_count, + cl3_count, + coper_count : integer; { should be signed } + ordinal_distance : bestreal; + invalid : boolean; + wrongparanr : byte; + end; + + tcallcandidates = class + private + FProcSym : tprocsym; + FProcs : pcandidate; + FProcVisibleCnt, + FProcCnt : integer; + FParaNode : tnode; + FParaLength : smallint; + FAllowVariant : boolean; + function proc_add(pd:tprocdef):pcandidate; + public + constructor create(sym:tprocsym;st:tsymtable;ppn:tnode;isprop,ignorevis : boolean); + constructor create_operator(op:ttoken;ppn:tnode); + destructor destroy;override; + procedure list(all:boolean); +{$ifdef EXTDEBUG} + procedure dump_info(lvl:longint); +{$endif EXTDEBUG} + procedure get_information; + function choose_best(var bestpd:tabstractprocdef):integer; + procedure find_wrong_para; + property Count:integer read FProcCnt; + property VisibleCount:integer read FProcVisibleCnt; + end; + + const + tok2nodes=25; + tok2node:array[1..tok2nodes] of ttok2noderec=( + (tok:_PLUS ;nod:addn;op_overloading_supported:true), { binary overloading supported } + (tok:_MINUS ;nod:subn;op_overloading_supported:true), { binary and unary overloading supported } + (tok:_STAR ;nod:muln;op_overloading_supported:true), { binary overloading supported } + (tok:_SLASH ;nod:slashn;op_overloading_supported:true), { binary overloading supported } + (tok:_EQUAL ;nod:equaln;op_overloading_supported:true), { binary overloading supported } + (tok:_GT ;nod:gtn;op_overloading_supported:true), { binary overloading supported } + (tok:_LT ;nod:ltn;op_overloading_supported:true), { binary overloading supported } + (tok:_GTE ;nod:gten;op_overloading_supported:true), { binary overloading supported } + (tok:_LTE ;nod:lten;op_overloading_supported:true), { binary overloading supported } + (tok:_SYMDIF ;nod:symdifn;op_overloading_supported:true), { binary overloading supported } + (tok:_STARSTAR;nod:starstarn;op_overloading_supported:true), { binary overloading supported } + (tok:_OP_AS ;nod:asn;op_overloading_supported:false), { binary overloading NOT supported } + (tok:_OP_IN ;nod:inn;op_overloading_supported:false), { binary overloading NOT supported } + (tok:_OP_IS ;nod:isn;op_overloading_supported:false), { binary overloading NOT supported } + (tok:_OP_OR ;nod:orn;op_overloading_supported:true), { binary overloading supported } + (tok:_OP_AND ;nod:andn;op_overloading_supported:true), { binary overloading supported } + (tok:_OP_DIV ;nod:divn;op_overloading_supported:true), { binary overloading supported } + (tok:_OP_NOT ;nod:notn;op_overloading_supported:true), { unary overloading supported } + (tok:_OP_MOD ;nod:modn;op_overloading_supported:true), { binary overloading supported } + (tok:_OP_SHL ;nod:shln;op_overloading_supported:true), { binary overloading supported } + (tok:_OP_SHR ;nod:shrn;op_overloading_supported:true), { binary overloading supported } + (tok:_OP_XOR ;nod:xorn;op_overloading_supported:true), { binary overloading supported } + (tok:_ASSIGNMENT;nod:assignn;op_overloading_supported:true), { unary overloading supported } + (tok:_CARET ;nod:caretn;op_overloading_supported:false), { binary overloading NOT supported } + (tok:_UNEQUAL ;nod:unequaln;op_overloading_supported:false) { binary overloading NOT supported overload = instead } + ); + const + { firstcallparan without varspez we don't count the ref } +{$ifdef extdebug} + count_ref : boolean = true; +{$endif def extdebug} + allow_array_constructor : boolean = false; + + function node2opstr(nt:tnodetype):string; + + { check operator args and result type } + function isbinaryoperatoroverloadable(treetyp:tnodetype;ld:tdef;lt:tnodetype;rd:tdef;rt:tnodetype) : boolean; + function isoperatoracceptable(pf : tprocdef; optoken : ttoken) : boolean; + function isunaryoverloaded(var t : tnode) : boolean; + function isbinaryoverloaded(var t : tnode) : boolean; + + { Register Allocation } + procedure make_not_regable(p : tnode); + procedure calcregisters(p : tbinarynode;r32,fpu,mmx : word); + + { procvar handling } + function is_procvar_load(p:tnode):boolean; + procedure test_local_to_procvar(from_def:tprocvardef;to_def:tdef); + + { sets varsym varstate field correctly } + type + tvarstateflag = (vsf_must_be_valid,vsf_use_hints); + tvarstateflags = set of tvarstateflag; + procedure set_varstate(p:tnode;newstate:tvarstate;varstateflags:tvarstateflags); + + { sets the callunique flag, if the node is a vecn, } + { takes care of type casts etc. } + procedure set_unique(p : tnode); + + function valid_for_formal_var(p : tnode) : boolean; + function valid_for_formal_const(p : tnode) : boolean; + function valid_for_var(p:tnode):boolean; + function valid_for_assignment(p:tnode):boolean; + function valid_for_addr(p : tnode) : boolean; + + function allowenumop(nt:tnodetype):boolean; + +implementation + + uses + globtype,systems, + cutils,verbose,globals, + symtable, + defutil,defcmp, + nbas,ncnv,nld,nmem,ncal,nmat,ninl,nutils, + cgbase,procinfo + ; + + type + TValidAssign=(Valid_Property,Valid_Void,Valid_Const,Valid_Addr); + TValidAssigns=set of TValidAssign; + + + function node2opstr(nt:tnodetype):string; + var + i : integer; + begin + result:='<unknown>'; + for i:=1 to tok2nodes do + if tok2node[i].nod=nt then + begin + result:=tokeninfo^[tok2node[i].tok].str; + break; + end; + end; + + + function isbinaryoperatoroverloadable(treetyp:tnodetype;ld:tdef;lt:tnodetype;rd:tdef;rt:tnodetype) : boolean; + + function internal_check(treetyp:tnodetype;ld:tdef;lt:tnodetype;rd:tdef;rt:tnodetype;var allowed:boolean):boolean; + begin + internal_check:=true; + case ld.deftype of + formaldef, + recorddef, + variantdef : + begin + allowed:=true; + end; + procvardef : + begin + if (rd.deftype in [pointerdef,procdef,procvardef]) then + begin + allowed:=false; + exit; + end; + allowed:=true; + end; + pointerdef : + begin + if ((rd.deftype in [orddef,enumdef,pointerdef,classrefdef,procvardef]) or + is_class_or_interface(rd)) then + begin + allowed:=false; + exit; + end; + + { don't allow pchar+string } + if (is_pchar(ld) or is_pwidechar(ld)) and + ((rd.deftype=stringdef) or + is_pchar(rd) or + is_pwidechar(rd) or + is_chararray(rd) or + is_widechararray(rd)) then + begin + allowed:=false; + exit; + end; + allowed:=true; + end; + arraydef : + begin + { not mmx } + if (cs_mmx in aktlocalswitches) and + is_mmx_able_array(ld) then + begin + allowed:=false; + exit; + end; + { not chararray+[(wide)char,(wide)string,(wide)chararray] } + if (is_chararray(ld) or is_widechararray(ld) or + is_open_chararray(ld) or is_open_widechararray(ld)) + and + ((rd.deftype in [stringdef,orddef,enumdef]) or + is_pchar(rd) or + is_pwidechar(rd) or + is_chararray(rd) or + is_widechararray(rd) or + is_open_chararray(rd) or + is_open_widechararray(rd) or + (rt=niln)) then + begin + allowed:=false; + exit; + end; + { dynamic array compare with niln } + if ((is_dynamic_array(ld) and + (rt=niln)) or + (is_dynamic_array(ld) and is_dynamic_array(rd))) + and + (treetyp in [equaln,unequaln]) then + begin + allowed:=false; + exit; + end; + allowed:=true; + end; + objectdef : + begin + { <> and = are defined for classes } + if (treetyp in [equaln,unequaln]) and + is_class_or_interface(ld) then + begin + allowed:=false; + exit; + end; + allowed:=true; + end; + stringdef : + begin + if (rd.deftype in [orddef,enumdef,stringdef]) or + is_pchar(rd) or + is_pwidechar(rd) or + is_chararray(rd) or + is_widechararray(rd) or + is_open_chararray(rd) or + is_open_widechararray(rd) then + begin + allowed:=false; + exit; + end; + allowed:=true; + end; + else + internal_check:=false; + end; + end; + + var + allowed : boolean; + begin + { power ** is always possible } + if (treetyp=starstarn) then + begin + isbinaryoperatoroverloadable:=true; + exit; + end; + { order of arguments does not matter so we have to check also + the reversed order } + allowed:=false; + if not internal_check(treetyp,ld,lt,rd,rt,allowed) then + internal_check(treetyp,rd,rt,ld,lt,allowed); + isbinaryoperatoroverloadable:=allowed; + end; + + + function isunaryoperatoroverloadable(treetyp : tnodetype;ld : tdef) : boolean; + begin + result:=false; + case treetyp of + subn, + unaryminusn : + begin + if (ld.deftype in [orddef,enumdef,floatdef]) then + exit; + +{$ifdef SUPPORT_MMX} + if (cs_mmx in aktlocalswitches) and + is_mmx_able_array(ld) then + exit; +{$endif SUPPORT_MMX} + + result:=true; + end; + + notn : + begin + if (ld.deftype in [orddef,enumdef,floatdef]) then + exit; + +{$ifdef SUPPORT_MMX} + if (cs_mmx in aktlocalswitches) and + is_mmx_able_array(ld) then + exit; +{$endif SUPPORT_MMX} + + result:=true; + end; + end; + end; + + + function isoperatoracceptable(pf : tprocdef; optoken : ttoken) : boolean; + var + ld,rd : tdef; + i : longint; + eq : tequaltype; + conv : tconverttype; + pd : tprocdef; + begin + result:=false; + case pf.parast.symindex.count of + 1 : begin + ld:=tparavarsym(pf.parast.symindex.first).vartype.def; + { assignment is a special case } + if optoken=_ASSIGNMENT then + begin + eq:=compare_defs_ext(ld,pf.rettype.def,nothingn,conv,pd,[cdo_explicit]); + result:=(eq=te_incompatible); + end + else + begin + for i:=1 to tok2nodes do + if tok2node[i].tok=optoken then + begin + result:= + tok2node[i].op_overloading_supported and + isunaryoperatoroverloadable(tok2node[i].nod,ld); + break; + end; + end; + end; + 2 : begin + for i:=1 to tok2nodes do + if tok2node[i].tok=optoken then + begin + ld:=tparavarsym(pf.parast.symindex.first).vartype.def; + rd:=tparavarsym(pf.parast.symindex.first.indexnext).vartype.def; + result:= + tok2node[i].op_overloading_supported and + isbinaryoperatoroverloadable(tok2node[i].nod,ld,nothingn,rd,nothingn); + break; + end; + end; + end; + end; + + + function isunaryoverloaded(var t : tnode) : boolean; + var + ld : tdef; + optoken : ttoken; + operpd : tprocdef; + ppn : tcallparanode; + candidates : tcallcandidates; + cand_cnt : integer; + begin + result:=false; + operpd:=nil; + + { load easier access variables } + ld:=tunarynode(t).left.resulttype.def; + if not isunaryoperatoroverloadable(t.nodetype,ld) then + exit; + + { operator overload is possible } + result:=true; + + case t.nodetype of + notn: + optoken:=_OP_NOT; + unaryminusn: + optoken:=_MINUS; + else + begin + CGMessage(parser_e_operator_not_overloaded); + t:=cnothingnode.create; + exit; + end; + end; + + { generate parameter nodes } + ppn:=ccallparanode.create(tunarynode(t).left.getcopy,nil); + ppn.get_paratype; + candidates:=tcallcandidates.create_operator(optoken,ppn); + + { stop when there are no operators found } + if candidates.count=0 then + begin + CGMessage(parser_e_operator_not_overloaded); + candidates.free; + ppn.free; + t:=cnothingnode.create; + exit; + end; + + { Retrieve information about the candidates } + candidates.get_information; +{$ifdef EXTDEBUG} + { Display info when multiple candidates are found } + candidates.dump_info(V_Debug); +{$endif EXTDEBUG} + cand_cnt:=candidates.choose_best(operpd); + + { exit when no overloads are found } + if cand_cnt=0 then + begin + CGMessage(parser_e_operator_not_overloaded); + candidates.free; + ppn.free; + t:=cnothingnode.create; + exit; + end; + + { Multiple candidates left? } + if cand_cnt>1 then + begin + CGMessage(type_e_cant_choose_overload_function); +{$ifdef EXTDEBUG} + candidates.dump_info(V_Hint); +{$else EXTDEBUG} + candidates.list(false); +{$endif EXTDEBUG} + { we'll just use the first candidate to make the + call } + end; + candidates.free; + + inc(operpd.procsym.refs); + + { the nil as symtable signs firstcalln that this is + an overloaded operator } + t:=ccallnode.create(ppn,Tprocsym(operpd.procsym),nil,nil,[]); + + { we already know the procdef to use, so it can + skip the overload choosing in callnode.det_resulttype } + tcallnode(t).procdefinition:=operpd; + end; + + + function isbinaryoverloaded(var t : tnode) : boolean; + var + rd,ld : tdef; + optoken : ttoken; + operpd : tprocdef; + ht : tnode; + ppn : tcallparanode; + candidates : tcallcandidates; + cand_cnt : integer; + begin + isbinaryoverloaded:=false; + operpd:=nil; + { load easier access variables } + ld:=tbinarynode(t).left.resulttype.def; + rd:=tbinarynode(t).right.resulttype.def; + if not isbinaryoperatoroverloadable(t.nodetype,ld,tbinarynode(t).left.nodetype,rd,tbinarynode(t).right.nodetype) then + exit; + + { operator overload is possible } + result:=true; + + case t.nodetype of + equaln, + unequaln : + optoken:=_EQUAL; + addn: + optoken:=_PLUS; + subn: + optoken:=_MINUS; + muln: + optoken:=_STAR; + starstarn: + optoken:=_STARSTAR; + slashn: + optoken:=_SLASH; + ltn: + optoken:=_LT; + gtn: + optoken:=_GT; + lten: + optoken:=_LTE; + gten: + optoken:=_GTE; + symdifn : + optoken:=_SYMDIF; + modn : + optoken:=_OP_MOD; + orn : + optoken:=_OP_OR; + xorn : + optoken:=_OP_XOR; + andn : + optoken:=_OP_AND; + divn : + optoken:=_OP_DIV; + shln : + optoken:=_OP_SHL; + shrn : + optoken:=_OP_SHR; + else + begin + CGMessage(parser_e_operator_not_overloaded); + t:=cnothingnode.create; + exit; + end; + end; + + { generate parameter nodes } + ppn:=ccallparanode.create(tbinarynode(t).right.getcopy,ccallparanode.create(tbinarynode(t).left.getcopy,nil)); + ppn.get_paratype; + candidates:=tcallcandidates.create_operator(optoken,ppn); + + { for commutative operators we can swap arguments and try again } + if (candidates.count=0) and + not(optoken in [_OP_SHL,_OP_SHR,_OP_DIV,_OP_MOD,_STARSTAR,_SLASH,_MINUS]) then + begin + candidates.free; + reverseparameters(ppn); + { reverse compare operators } + case optoken of + _LT: + optoken:=_GTE; + _GT: + optoken:=_LTE; + _LTE: + optoken:=_GT; + _GTE: + optoken:=_LT; + end; + candidates:=tcallcandidates.create_operator(optoken,ppn); + end; + + { stop when there are no operators found } + if candidates.count=0 then + begin + CGMessage(parser_e_operator_not_overloaded); + candidates.free; + ppn.free; + t:=cnothingnode.create; + exit; + end; + + { Retrieve information about the candidates } + candidates.get_information; +{$ifdef EXTDEBUG} + { Display info when multiple candidates are found } + candidates.dump_info(V_Debug); +{$endif EXTDEBUG} + cand_cnt:=candidates.choose_best(operpd); + + { exit when no overloads are found } + if cand_cnt=0 then + begin + CGMessage(parser_e_operator_not_overloaded); + candidates.free; + ppn.free; + t:=cnothingnode.create; + exit; + end; + + { Multiple candidates left? } + if cand_cnt>1 then + begin + CGMessage(type_e_cant_choose_overload_function); +{$ifdef EXTDEBUG} + candidates.dump_info(V_Hint); +{$else EXTDEBUG} + candidates.list(false); +{$endif EXTDEBUG} + { we'll just use the first candidate to make the + call } + end; + candidates.free; + + inc(operpd.procsym.refs); + + { the nil as symtable signs firstcalln that this is + an overloaded operator } + ht:=ccallnode.create(ppn,Tprocsym(operpd.procsym),nil,nil,[]); + + { we already know the procdef to use, so it can + skip the overload choosing in callnode.det_resulttype } + tcallnode(ht).procdefinition:=operpd; + + if t.nodetype=unequaln then + ht:=cnotnode.create(ht); + t:=ht; + end; + + +{**************************************************************************** + Register Calculation +****************************************************************************} + + { marks an lvalue as "unregable" } + procedure make_not_regable(p : tnode); + begin + case p.nodetype of + typeconvn : + make_not_regable(ttypeconvnode(p).left); + loadn : + if tloadnode(p).symtableentry.typ in [globalvarsym,localvarsym,paravarsym] then + tabstractvarsym(tloadnode(p).symtableentry).varregable:=vr_none; + end; + end; + + + { calculates the needed registers for a binary operator } + procedure calcregisters(p : tbinarynode;r32,fpu,mmx : word); + + begin + p.left_right_max; + + { Only when the difference between the left and right registers < the + wanted registers allocate the amount of registers } + + if assigned(p.left) then + begin + if assigned(p.right) then + begin + { the location must be already filled in because we need it to } + { calculate the necessary number of registers (JM) } + if p.expectloc = LOC_INVALID then + internalerror(200110101); + + if (abs(p.left.registersint-p.right.registersint)<r32) or + ((p.expectloc = LOC_FPUREGISTER) and + (p.right.registersfpu <= p.left.registersfpu) and + ((p.right.registersfpu <> 0) or (p.left.registersfpu <> 0)) and + (p.left.registersint < p.right.registersint)) then + inc(p.registersint,r32); + if (abs(p.left.registersfpu-p.right.registersfpu)<fpu) then + inc(p.registersfpu,fpu); +{$ifdef SUPPORT_MMX} + if (abs(p.left.registersmmx-p.right.registersmmx)<mmx) then + inc(p.registersmmx,mmx); +{$endif SUPPORT_MMX} + { the following is a little bit guessing but I think } + { it's the only way to solve same internalerrors: } + { if the left and right node both uses registers } + { and return a mem location, but the current node } + { doesn't use an integer register we get probably } + { trouble when restoring a node } + if (p.left.registersint=p.right.registersint) and + (p.registersint=p.left.registersint) and + (p.registersint>0) and + (p.left.expectloc in [LOC_REFERENCE,LOC_CREFERENCE]) and + (p.right.expectloc in [LOC_REFERENCE,LOC_CREFERENCE]) then + inc(p.registersint); + end + else + begin + if (p.left.registersint<r32) then + inc(p.registersint,r32); + if (p.left.registersfpu<fpu) then + inc(p.registersfpu,fpu); +{$ifdef SUPPORT_MMX} + if (p.left.registersmmx<mmx) then + inc(p.registersmmx,mmx); +{$endif SUPPORT_MMX} + end; + end; + end; + + +{**************************************************************************** + Subroutine Handling +****************************************************************************} + + function is_procvar_load(p:tnode):boolean; + begin + result:=false; + { remove voidpointer typecast for tp procvars } + if ((m_tp_procvar in aktmodeswitches) or + (m_mac_procvar in aktmodeswitches)) and + (p.nodetype=typeconvn) and + is_voidpointer(p.resulttype.def) then + p:=tunarynode(p).left; + result:=(p.nodetype=typeconvn) and + (ttypeconvnode(p).convtype=tc_proc_2_procvar); + end; + + + { local routines can't be assigned to procvars } + procedure test_local_to_procvar(from_def:tprocvardef;to_def:tdef); + begin + if (from_def.parast.symtablelevel>normal_function_level) and + (to_def.deftype=procvardef) then + CGMessage(type_e_cannot_local_proc_to_procvar); + end; + + + procedure set_varstate(p:tnode;newstate:tvarstate;varstateflags:tvarstateflags); + var + hsym : tabstractvarsym; + begin + while assigned(p) do + begin + case p.nodetype of + typeconvn : + begin + case ttypeconvnode(p).convtype of + tc_cchar_2_pchar, + tc_cstring_2_pchar, + tc_array_2_pointer : + exclude(varstateflags,vsf_must_be_valid); + tc_pchar_2_string, + tc_pointer_2_array : + include(varstateflags,vsf_must_be_valid); + end; + p:=tunarynode(p).left; + end; + subscriptn : + p:=tunarynode(p).left; + vecn: + begin + set_varstate(tbinarynode(p).right,vs_used,[vsf_must_be_valid]); + if not(tunarynode(p).left.resulttype.def.deftype in [stringdef,arraydef]) then + include(varstateflags,vsf_must_be_valid); + p:=tunarynode(p).left; + end; + { do not parse calln } + calln : + break; + loadn : + begin + if (tloadnode(p).symtableentry.typ in [localvarsym,paravarsym,globalvarsym]) then + begin + hsym:=tabstractvarsym(tloadnode(p).symtableentry); + if (vsf_must_be_valid in varstateflags) and (hsym.varstate=vs_declared) then + begin + { Give warning/note for uninitialized locals } + if assigned(hsym.owner) and + not(vo_is_external in hsym.varoptions) and + (hsym.owner.symtabletype in [localsymtable,staticsymtable]) and + (hsym.owner=current_procinfo.procdef.localst) then + begin + if (vo_is_funcret in hsym.varoptions) then + CGMessage(sym_w_function_result_not_set) + else + begin + if tloadnode(p).symtable.symtabletype=localsymtable then + begin + if (vsf_use_hints in varstateflags) then + CGMessage1(sym_h_uninitialized_local_variable,hsym.realname) + else + CGMessage1(sym_w_uninitialized_local_variable,hsym.realname); + end + else + begin + if (vsf_use_hints in varstateflags) then + CGMessage1(sym_h_uninitialized_variable,hsym.realname) + else + CGMessage1(sym_w_uninitialized_variable,hsym.realname); + end; + end; + end; + end; + { don't override vs_used with vs_assigned } + if hsym.varstate<>vs_used then + hsym.varstate:=newstate; + end; + break; + end; + callparan : + internalerror(200310081); + else + break; + end;{case } + end; + end; + + + procedure set_unique(p : tnode); + begin + while assigned(p) do + begin + case p.nodetype of + vecn: + begin + include(p.flags,nf_callunique); + break; + end; + typeconvn, + subscriptn, + derefn: + p:=tunarynode(p).left; + else + break; + end; + end; + end; + + + function valid_for_assign(p:tnode;opts:TValidAssigns):boolean; + var + hp : tnode; + gotstring, + gotwith, + gotsubscript, + gotrecord, + gotpointer, + gotvec, + gotclass, + gotdynarray, + gotderef : boolean; + fromdef, + todef : tdef; + errmsg : longint; + begin + if valid_const in opts then + errmsg:=type_e_variable_id_expected + else + errmsg:=type_e_argument_cant_be_assigned; + result:=false; + gotsubscript:=false; + gotvec:=false; + gotderef:=false; + gotrecord:=false; + gotclass:=false; + gotpointer:=false; + gotwith:=false; + gotdynarray:=false; + gotstring:=false; + hp:=p; + if not(valid_void in opts) and + is_void(hp.resulttype.def) then + begin + CGMessagePos(hp.fileinfo,errmsg); + exit; + end; + while assigned(hp) do + begin + { property allowed? calln has a property check itself } + if (nf_isproperty in hp.flags) then + begin + if (hp.nodetype=calln) then + begin + { check return type } + case hp.resulttype.def.deftype of + pointerdef : + gotpointer:=true; + objectdef : + gotclass:=is_class_or_interface(hp.resulttype.def); + recorddef : + gotrecord:=true; + classrefdef : + gotclass:=true; + stringdef : + gotstring:=true; + end; + if (valid_property in opts) then + begin + { don't allow writing to calls that will create + temps like calls that return a structure and we + are assigning to a member } + if (valid_const in opts) or + not( + (gotsubscript and gotrecord) or + (gotstring and gotvec) + ) then + result:=true + else + CGMessagePos(hp.fileinfo,errmsg); + end + else + begin + { 1. if it returns a pointer and we've found a deref, + 2. if it returns a class or record and a subscription or with is found + 3. if the address is needed of a field (subscriptn) } + if (gotpointer and gotderef) or + (gotstring and gotvec) or + ( + (gotclass or gotrecord) and + (gotsubscript or gotwith) + ) or + ( + (gotvec and gotdynarray) + ) or + ( + (Valid_Addr in opts) and + (hp.nodetype=subscriptn) + ) then + result:=true + else + CGMessagePos(hp.fileinfo,errmsg); + end; + end + else + result:=true; + exit; + end; + if (Valid_Const in opts) and is_constnode(hp) then + begin + result:=true; + exit; + end; + case hp.nodetype of + temprefn : + begin + valid_for_assign := true; + exit; + end; + derefn : + begin + gotderef:=true; + hp:=tderefnode(hp).left; + end; + typeconvn : + begin + { typecast sizes must match, exceptions: + - implicit typecast made by absolute + - from formaldef + - from void + - from/to open array + - typecast from pointer to array } + fromdef:=ttypeconvnode(hp).left.resulttype.def; + todef:=hp.resulttype.def; + if not((nf_absolute in ttypeconvnode(hp).flags) or + (fromdef.deftype=formaldef) or + is_void(fromdef) or + is_open_array(fromdef) or + is_open_array(todef) or + ((fromdef.deftype=pointerdef) and (todef.deftype=arraydef)) or + ((fromdef.deftype = objectdef) and (todef.deftype = objectdef) and + (tobjectdef(fromdef).is_related(tobjectdef(todef))))) and + (fromdef.size<>todef.size) then + begin + { in TP it is allowed to typecast to smaller types. But the variable can't + be in a register } + if (m_tp7 in aktmodeswitches) or + (todef.size<fromdef.size) then + make_not_regable(hp) + else + CGMessagePos2(hp.fileinfo,type_e_typecast_wrong_size_for_assignment,tostr(fromdef.size),tostr(todef.size)); + end; + { don't allow assignments to typeconvs that need special code } + if not(gotsubscript or gotvec or gotderef) and + not(ttypeconvnode(hp).assign_allowed) then + begin + CGMessagePos(hp.fileinfo,errmsg); + exit; + end; + case hp.resulttype.def.deftype of + pointerdef : + gotpointer:=true; + objectdef : + gotclass:=is_class_or_interface(hp.resulttype.def); + classrefdef : + gotclass:=true; + arraydef : + begin + { pointer -> array conversion is done then we need to see it + as a deref, because a ^ is then not required anymore } + if (ttypeconvnode(hp).left.resulttype.def.deftype=pointerdef) then + gotderef:=true; + end; + end; + hp:=ttypeconvnode(hp).left; + end; + vecn : + begin + gotvec:=true; + { accesses to dyn. arrays override read only access in delphi } + if (m_delphi in aktmodeswitches) and is_dynamic_array(tunarynode(hp).left.resulttype.def) then + gotdynarray:=true; + hp:=tunarynode(hp).left; + end; + asn : + begin + { asn can't be assigned directly, it returns the value in a register instead + of reference. } + if not(gotsubscript or gotderef or gotvec) then + begin + CGMessagePos(hp.fileinfo,errmsg); + exit; + end; + hp:=tunarynode(hp).left; + end; + subscriptn : + begin + gotsubscript:=true; + { loop counter? } + if not(Valid_Const in opts) and + (vo_is_loop_counter in tsubscriptnode(hp).vs.varoptions) then + CGMessage1(parser_e_illegal_assignment_to_count_var,tsubscriptnode(hp).vs.realname); + { a class/interface access is an implicit } + { dereferencing } + hp:=tsubscriptnode(hp).left; + if is_class_or_interface(hp.resulttype.def) then + gotderef:=true; + end; + muln, + divn, + andn, + xorn, + orn, + notn, + subn, + addn : + begin + { Allow operators on a pointer, or an integer + and a pointer typecast and deref has been found } + if ((hp.resulttype.def.deftype=pointerdef) or + (is_integer(hp.resulttype.def) and gotpointer)) and + gotderef then + result:=true + else + { Temp strings are stored in memory, for compatibility with + delphi only } + if (m_delphi in aktmodeswitches) and + ((valid_addr in opts) or + (valid_const in opts)) and + (hp.resulttype.def.deftype=stringdef) then + result:=true + else + CGMessagePos(hp.fileinfo,type_e_variable_id_expected); + exit; + end; + niln, + pointerconstn : + begin + { to support e.g. @tmypointer(0)^.data; see tests/tbs/tb0481 } + if gotderef then + result:=true + else + CGMessagePos(hp.fileinfo,type_e_no_assign_to_addr); + exit; + end; + addrn : + begin + if gotderef then + result:=true + else + CGMessagePos(hp.fileinfo,type_e_no_assign_to_addr); + exit; + end; + calln : + begin + { check return type } + case hp.resulttype.def.deftype of + arraydef : + begin + { dynamic arrays are allowed when there is also a + vec node } + if is_dynamic_array(hp.resulttype.def) and + gotvec then + begin + gotderef:=true; + gotpointer:=true; + end; + end; + pointerdef : + gotpointer:=true; + objectdef : + gotclass:=is_class_or_interface(hp.resulttype.def); + recorddef, { handle record like class it needs a subscription } + classrefdef : + gotclass:=true; + stringdef : + gotstring:=true; + end; + { 1. if it returns a pointer and we've found a deref, + 2. if it returns a class or record and a subscription or with is found + 3. string is returned } + if (gotstring and gotvec) or + (gotpointer and gotderef) or + (gotclass and (gotsubscript or gotwith)) then + result:=true + else + { Temp strings are stored in memory, for compatibility with + delphi only } + if (m_delphi in aktmodeswitches) and + (valid_addr in opts) and + (hp.resulttype.def.deftype=stringdef) then + result:=true + else + if ([valid_const,valid_addr] * opts = [valid_const]) then + result:=true + else + CGMessagePos(hp.fileinfo,errmsg); + exit; + end; + inlinen : + begin + if (valid_const in opts) and + (tinlinenode(hp).inlinenumber in [in_typeof_x]) then + result:=true + else + CGMessagePos(hp.fileinfo,type_e_variable_id_expected); + exit; + end; + loadn : + begin + case tloadnode(hp).symtableentry.typ of + absolutevarsym, + globalvarsym, + localvarsym, + paravarsym : + begin + { loop counter? } + if not(Valid_Const in opts) and + not gotderef and + (vo_is_loop_counter in tabstractvarsym(tloadnode(hp).symtableentry).varoptions) then + CGMessage1(parser_e_illegal_assignment_to_count_var,tloadnode(hp).symtableentry.realname); + { derefed pointer } + if (tabstractvarsym(tloadnode(hp).symtableentry).varspez=vs_const) then + begin + { allow p^:= constructions with p is const parameter } + if gotderef or gotdynarray or (Valid_Const in opts) then + result:=true + else + CGMessagePos(tloadnode(hp).fileinfo,type_e_no_assign_to_const); + exit; + end; + { Are we at a with symtable, then we need to process the + withrefnode also to check for maybe a const load } + if (tloadnode(hp).symtable.symtabletype=withsymtable) then + begin + { continue with processing the withref node } + hp:=tnode(twithsymtable(tloadnode(hp).symtable).withrefnode); + gotwith:=true; + end + else + begin + result:=true; + exit; + end; + end; + typedconstsym : + begin + if ttypedconstsym(tloadnode(hp).symtableentry).is_writable or + (valid_addr in opts) or + (valid_const in opts) then + result:=true + else + CGMessagePos(hp.fileinfo,type_e_no_assign_to_const); + exit; + end; + procsym : + begin + if (Valid_Const in opts) then + result:=true + else + CGMessagePos(hp.fileinfo,type_e_variable_id_expected); + exit; + end; + labelsym : + begin + if (Valid_Addr in opts) then + result:=true + else + CGMessagePos(hp.fileinfo,type_e_variable_id_expected); + exit; + end; + constsym: + begin + if (tconstsym(tloadnode(hp).symtableentry).consttyp=constresourcestring) and + (valid_addr in opts) then + result:=true + else + CGMessagePos(hp.fileinfo,type_e_variable_id_expected); + exit; + end; + else + begin + CGMessagePos(hp.fileinfo,type_e_variable_id_expected); + exit; + end; + end; + end; + else + begin + CGMessagePos(hp.fileinfo,type_e_variable_id_expected); + exit; + end; + end; + end; + end; + + + function valid_for_var(p:tnode):boolean; + begin + valid_for_var:=valid_for_assign(p,[]); + end; + + + function valid_for_formal_var(p : tnode) : boolean; + begin + valid_for_formal_var:=valid_for_assign(p,[valid_void]); + end; + + + function valid_for_formal_const(p : tnode) : boolean; + begin + valid_for_formal_const:=(p.resulttype.def.deftype=formaldef) or + valid_for_assign(p,[valid_void,valid_const]); + end; + + + function valid_for_assignment(p:tnode):boolean; + begin + valid_for_assignment:=valid_for_assign(p,[valid_property]); + end; + + + function valid_for_addr(p : tnode) : boolean; + begin + result:=valid_for_assign(p,[valid_const,valid_addr,valid_void]); + end; + + + procedure var_para_allowed(var eq:tequaltype;def_from,def_to:Tdef); + begin + { Note: eq must be already valid, it will only be updated! } + case def_to.deftype of + formaldef : + begin + { all types can be passed to a formaldef } + eq:=te_equal; + end; + orddef : + begin + { allows conversion from word to integer and + byte to shortint, but only for TP7 compatibility } + if (m_tp7 in aktmodeswitches) and + (def_from.deftype=orddef) and + (def_from.size=def_to.size) then + eq:=te_convert_l1; + end; + arraydef : + begin + if is_open_array(def_to) and + is_dynamic_array(def_from) and + equal_defs(tarraydef(def_from).elementtype.def,tarraydef(def_to).elementtype.def) then + eq:=te_convert_l2; + end; + pointerdef : + begin + { an implicit pointer conversion is allowed } + if (def_from.deftype=pointerdef) then + eq:=te_convert_l1; + end; + stringdef : + begin + { all shortstrings are allowed, size is not important } + if is_shortstring(def_from) and + is_shortstring(def_to) then + eq:=te_equal; + end; + objectdef : + begin + { child objects can be also passed } + { in non-delphi mode, otherwise } + { they must match exactly, except } + { if they are objects } + if (def_from.deftype=objectdef) and + ( + not(m_delphi in aktmodeswitches) or + ( + (tobjectdef(def_from).objecttype=odt_object) and + (tobjectdef(def_to).objecttype=odt_object) + ) + ) and + (tobjectdef(def_from).is_related(tobjectdef(def_to))) then + eq:=te_convert_l1; + end; + filedef : + begin + { an implicit file conversion is also allowed } + { from a typed file to an untyped one } + if (def_from.deftype=filedef) and + (tfiledef(def_from).filetyp = ft_typed) and + (tfiledef(def_to).filetyp = ft_untyped) then + eq:=te_convert_l1; + end; + end; + end; + + + procedure para_allowed(var eq:tequaltype;p:tcallparanode;def_to:tdef); + begin + { Note: eq must be already valid, it will only be updated! } + case def_to.deftype of + formaldef : + begin + { all types can be passed to a formaldef } + eq:=te_equal; + end; + stringdef : + begin + { to support ansi/long/wide strings in a proper way } + { string and string[10] are assumed as equal } + { when searching the correct overloaded procedure } + if (p.resulttype.def.deftype=stringdef) and + (tstringdef(def_to).string_typ=tstringdef(p.resulttype.def).string_typ) then + eq:=te_equal + else + { Passing a constant char to ansistring or shortstring or + a widechar to widestring then handle it as equal. } + if (p.left.nodetype=ordconstn) and + ( + is_char(p.resulttype.def) and + (is_shortstring(def_to) or is_ansistring(def_to)) + ) or + ( + is_widechar(p.resulttype.def) and + is_widestring(def_to) + ) then + eq:=te_equal + end; + setdef : + begin + { set can also be a not yet converted array constructor } + if (p.resulttype.def.deftype=arraydef) and + (tarraydef(p.resulttype.def).IsConstructor) and + not(tarraydef(p.resulttype.def).IsVariant) then + eq:=te_equal; + end; + procvardef : + begin + { in tp7 mode proc -> procvar is allowed } + if ((m_tp_procvar in aktmodeswitches) or + (m_mac_procvar in aktmodeswitches)) and + (p.left.nodetype=calln) and + (proc_to_procvar_equal(tprocdef(tcallnode(p.left).procdefinition),tprocvardef(def_to))>=te_equal) then + eq:=te_equal + else + if (m_mac_procvar in aktmodeswitches) and + is_procvar_load(p.left) then + eq:=te_convert_l2; + end; + end; + end; + + + function allowenumop(nt:tnodetype):boolean; + begin + result:=(nt in [equaln,unequaln,ltn,lten,gtn,gten]) or + ((cs_allow_enum_calc in aktlocalswitches) and + (nt in [addn,subn])); + end; + + +{**************************************************************************** + TCallCandidates +****************************************************************************} + + constructor tcallcandidates.create(sym:tprocsym;st:tsymtable;ppn:tnode;isprop,ignorevis : boolean); + var + j : integer; + pd : tprocdef; + hp : pcandidate; + found, + has_overload_directive : boolean; + topclassh : tobjectdef; + srsymtable : tsymtable; + srprocsym : tprocsym; + pt : tcallparanode; + + begin + if not assigned(sym) then + internalerror(200411015); + + FProcSym:=sym; + FProcs:=nil; + FProccnt:=0; + FProcvisiblecnt:=0; + FParanode:=ppn; + FAllowVariant:=true; + + { determine length of parameter list } + pt:=tcallparanode(ppn); + FParalength:=0; + while assigned(pt) do + begin + inc(FParalength); + pt:=tcallparanode(pt.right); + end; + + { when the definition has overload directive set, we search for + overloaded definitions in the class, this only needs to be done once + for class entries as the tree keeps always the same } + if (not sym.overloadchecked) and + (sym.owner.symtabletype=objectsymtable) and + (po_overload in sym.first_procdef.procoptions) then + search_class_overloads(sym); + + { when the class passed is defined in this unit we + need to use the scope of that class. This is a trick + that can be used to access protected members in other + units. At least kylix supports it this way (PFV) } + if assigned(st) and + ( + (st.symtabletype=objectsymtable) or + ((st.symtabletype=withsymtable) and + (st.defowner.deftype=objectdef)) + ) and + (st.defowner.owner.symtabletype in [globalsymtable,staticsymtable]) and + st.defowner.owner.iscurrentunit then + topclassh:=tobjectdef(st.defowner) + else + begin + if assigned(current_procinfo) then + topclassh:=current_procinfo.procdef._class + else + topclassh:=nil; + end; + + { link all procedures which have the same # of parameters } + for j:=1 to sym.procdef_count do + begin + pd:=sym.procdef[j]; + { Is the procdef visible? This needs to be checked on + procdef level since a symbol can contain both private and + public declarations. But the check should not be done + when the callnode is generated by a property + + inherited overrides invisible anonymous inherited (FK) } + + if isprop or ignorevis or + (pd.owner.symtabletype<>objectsymtable) or + pd.is_visible_for_object(topclassh) then + begin + { we have at least one procedure that is visible } + inc(FProcvisiblecnt); + { only when the # of parameter are supported by the + procedure } + if (FParalength>=pd.minparacount) and + ((po_varargs in pd.procoptions) or { varargs } + (FParalength<=pd.maxparacount)) then + proc_add(pd); + end; + end; + + { remember if the procedure is declared with the overload directive, + it's information is still needed also after all procs are removed } + has_overload_directive:=(po_overload in sym.first_procdef.procoptions); + + { when the definition has overload directive set, we search for + overloaded definitions in the symtablestack. The found + entries are only added to the procs list and not the procsym, because + the list can change in every situation } + if has_overload_directive and + (sym.owner.symtabletype<>objectsymtable) then + begin + srsymtable:=sym.owner.next; + while assigned(srsymtable) do + begin + if srsymtable.symtabletype in [localsymtable,staticsymtable,globalsymtable] then + begin + srprocsym:=tprocsym(srsymtable.speedsearch(sym.name,sym.speedvalue)); + if assigned(srprocsym) and + (srprocsym.typ=procsym) then + begin + { if this visible procedure doesn't have overload we can stop + searching } + if not(po_overload in srprocsym.first_procdef.procoptions) and + srprocsym.first_procdef.is_visible_for_object(topclassh) then + break; + { process all overloaded definitions } + for j:=1 to srprocsym.procdef_count do + begin + pd:=srprocsym.procdef[j]; + { only visible procedures need to be added } + if pd.is_visible_for_object(topclassh) then + begin + { only when the # of parameter are supported by the + procedure } + if (FParalength>=pd.minparacount) and + ((po_varargs in pd.procoptions) or { varargs } + (FParalength<=pd.maxparacount)) then + begin + found:=false; + hp:=FProcs; + while assigned(hp) do + begin + { Only compare visible parameters for the user } + if compare_paras(hp^.data.paras,pd.paras,cp_value_equal_const,[cpo_ignorehidden])>=te_equal then + begin + found:=true; + break; + end; + hp:=hp^.next; + end; + if not found then + proc_add(pd); + end; + end; + end; + end; + end; + srsymtable:=srsymtable.next; + end; + end; + end; + + + constructor tcallcandidates.create_operator(op:ttoken;ppn:tnode); + var + j : integer; + pd : tprocdef; + hp : pcandidate; + found : boolean; + srsymtable : tsymtable; + srprocsym : tprocsym; + pt : tcallparanode; + sv : cardinal; + begin + FProcSym:=nil; + FProcs:=nil; + FProccnt:=0; + FProcvisiblecnt:=0; + FParanode:=ppn; + FAllowVariant:=false; + + { determine length of parameter list } + pt:=tcallparanode(ppn); + FParalength:=0; + while assigned(pt) do + begin + if pt.resulttype.def.deftype=variantdef then + FAllowVariant:=true; + inc(FParalength); + pt:=tcallparanode(pt.right); + end; + + { we search all overloaded operator definitions in the symtablestack. The found + entries are only added to the procs list and not the procsym, because + the list can change in every situation } + sv:=getspeedvalue(overloaded_names[op]); + srsymtable:=symtablestack; + while assigned(srsymtable) do + begin + if srsymtable.symtabletype in [localsymtable,staticsymtable,globalsymtable] then + begin + srprocsym:=tprocsym(srsymtable.speedsearch(overloaded_names[op],sv)); + if assigned(srprocsym) and + (srprocsym.typ=procsym) then + begin + { Store first procsym found } + if not assigned(FProcsym) then + FProcsym:=srprocsym; + + { process all overloaded definitions } + for j:=1 to srprocsym.procdef_count do + begin + pd:=srprocsym.procdef[j]; + { only when the # of parameter are supported by the + procedure } + if (FParalength>=pd.minparacount) and + (FParalength<=pd.maxparacount) then + begin + found:=false; + hp:=FProcs; + while assigned(hp) do + begin + { Only compare visible parameters for the user } + if compare_paras(hp^.data.paras,pd.paras,cp_value_equal_const,[cpo_ignorehidden])>=te_equal then + begin + found:=true; + break; + end; + hp:=hp^.next; + end; + if not found then + proc_add(pd); + end; + end; + end; + end; + srsymtable:=srsymtable.next; + end; + end; + + + destructor tcallcandidates.destroy; + var + hpnext, + hp : pcandidate; + begin + hp:=FProcs; + while assigned(hp) do + begin + hpnext:=hp^.next; + dispose(hp); + hp:=hpnext; + end; + end; + + + function tcallcandidates.proc_add(pd:tprocdef):pcandidate; + var + defaultparacnt : integer; + begin + { generate new candidate entry } + new(result); + fillchar(result^,sizeof(tcandidate),0); + result^.data:=pd; + result^.next:=FProcs; + FProcs:=result; + inc(FProccnt); + { Find last parameter, skip all default parameters + that are not passed. Ignore this skipping for varargs } + result^.firstparaidx:=pd.paras.count-1; + if not(po_varargs in pd.procoptions) then + begin + { ignore hidden parameters } + while (result^.firstparaidx>=0) and (vo_is_hidden_para in tparavarsym(pd.paras[result^.firstparaidx]).varoptions) do + dec(result^.firstparaidx); + defaultparacnt:=pd.maxparacount-FParalength; + if defaultparacnt>0 then + begin + if defaultparacnt>result^.firstparaidx+1 then + internalerror(200401141); + dec(result^.firstparaidx,defaultparacnt); + end; + end; + end; + + + procedure tcallcandidates.list(all:boolean); + var + hp : pcandidate; + begin + hp:=FProcs; + while assigned(hp) do + begin + if all or + (not hp^.invalid) then + MessagePos1(hp^.data.fileinfo,sym_h_param_list,hp^.data.fullprocname(false)); + hp:=hp^.next; + end; + end; + + +{$ifdef EXTDEBUG} + procedure tcallcandidates.dump_info(lvl:longint); + + function ParaTreeStr(p:tcallparanode):string; + begin + result:=''; + while assigned(p) do + begin + if result<>'' then + result:=','+result; + result:=p.resulttype.def.typename+result; + p:=tcallparanode(p.right); + end; + end; + + var + hp : pcandidate; + i : integer; + currpara : tparavarsym; + begin + if not CheckVerbosity(lvl) then + exit; + Comment(lvl+V_LineInfo,'Overloaded callnode: '+FProcSym.name+'('+ParaTreeStr(tcallparanode(FParaNode))+')'); + hp:=FProcs; + while assigned(hp) do + begin + Comment(lvl,' '+hp^.data.fullprocname(false)); + if (hp^.invalid) then + Comment(lvl,' invalid') + else + begin + Comment(lvl,' ex: '+tostr(hp^.exact_count)+ + ' eq: '+tostr(hp^.equal_count)+ + ' l1: '+tostr(hp^.cl1_count)+ + ' l2: '+tostr(hp^.cl2_count)+ + ' l3: '+tostr(hp^.cl3_count)+ + ' oper: '+tostr(hp^.coper_count)+ + ' ord: '+realtostr(hp^.ordinal_distance)); + { Print parameters in left-right order } + for i:=0 to hp^.data.paras.count-1 do + begin + currpara:=tparavarsym(hp^.data.paras[i]); + if (vo_is_hidden_para in currpara.varoptions) then + Comment(lvl,' - '+currpara.vartype.def.typename+' : '+EqualTypeName[currpara.eqval]); + end; + end; + hp:=hp^.next; + end; + end; +{$endif EXTDEBUG} + + + procedure tcallcandidates.get_information; + var + hp : pcandidate; + currpara : tparavarsym; + paraidx : integer; + currparanr : byte; + rfh,rth : bestreal; + objdef : tobjectdef; + def_from, + def_to : tdef; + currpt, + pt : tcallparanode; + eq : tequaltype; + convtype : tconverttype; + pdoper : tprocdef; + releasecurrpt : boolean; + cdoptions : tcompare_defs_options; + begin + cdoptions:=[cdo_check_operator]; + if FAllowVariant then + include(cdoptions,cdo_allow_variant); + { process all procs } + hp:=FProcs; + while assigned(hp) do + begin + { We compare parameters in reverse order (right to left), + the firstpara is already pointing to the last parameter + were we need to start comparing } + currparanr:=FParalength; + paraidx:=hp^.firstparaidx; + while (paraidx>=0) and (vo_is_hidden_para in tparavarsym(hp^.data.paras[paraidx]).varoptions) do + dec(paraidx); + pt:=tcallparanode(FParaNode); + while assigned(pt) and (paraidx>=0) do + begin + currpara:=tparavarsym(hp^.data.paras[paraidx]); + { 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:=currpt.resulttype.def; + def_to:=currpara.vartype.def; + if not(assigned(def_from)) then + internalerror(200212091); + if not( + assigned(def_to) or + ((po_varargs in hp^.data.procoptions) and + (currparanr>hp^.data.minparacount)) + ) 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 + eq:=te_equal; + end + else + { same definition -> exact } + if (def_from=def_to) then + begin + eq:=te_exact; + end + else + { for value and const parameters check if a integer is constant or + included in other integer -> equal and calc ordinal_distance } + if not(currpara.varspez in [vs_var,vs_out]) and + is_integer(def_from) and + is_integer(def_to) and + is_in_limit(def_from,def_to) then + begin + eq:=te_equal; + hp^.ordinal_distance:=hp^.ordinal_distance+ + abs(bestreal(torddef(def_from).low)-bestreal(torddef(def_to).low)); + if (torddef(def_to).typ=u64bit) then + rth:=bestreal(qword(torddef(def_to).high)) + else + rth:=bestreal(torddef(def_to).high); + if (torddef(def_from).typ=u64bit) then + rfh:=bestreal(qword(torddef(def_from).high)) + else + rfh:=bestreal(torddef(def_from).high); + hp^.ordinal_distance:=hp^.ordinal_distance+abs(rth-rfh); + { Give wrong sign a small penalty, this is need to get a diffrence + from word->[longword,longint] } + if is_signed(def_from)<>is_signed(def_to) then + hp^.ordinal_distance:=hp^.ordinal_distance+1.0; + end + else + { for value and const parameters check precision of real, give + penalty for loosing of precision. var and out parameters must match exactly } + if not(currpara.varspez in [vs_var,vs_out]) and + is_real(def_from) and + is_real(def_to) then + begin + eq:=te_equal; + if is_extended(def_to) then + rth:=bestreal(4) + else + if is_double (def_to) then + rth:=bestreal(2) + else + rth:=bestreal(1); + if is_extended(def_from) then + rfh:=bestreal(4) + else + if is_double (def_from) then + rfh:=bestreal(2) + else + rfh:=bestreal(1); + { penalty for shrinking of precision } + if rth<rfh then + rfh:=(rfh-rth)*16 + else + rfh:=rth-rfh; + hp^.ordinal_distance:=hp^.ordinal_distance+rfh; + end + else + { related object parameters also need to determine the distance between the current + object and the object we are comparing with. var and out parameters must match exactly } + if not(currpara.varspez in [vs_var,vs_out]) and + (def_from.deftype=objectdef) and + (def_to.deftype=objectdef) and + (tobjectdef(def_from).objecttype=tobjectdef(def_to).objecttype) and + tobjectdef(def_from).is_related(tobjectdef(def_to)) then + begin + eq:=te_convert_l1; + objdef:=tobjectdef(def_from); + while assigned(objdef) do + begin + if objdef=def_to then + break; + hp^.ordinal_distance:=hp^.ordinal_distance+1; + objdef:=objdef.childof; + end; + end + else + { generic type comparision } + begin + eq:=compare_defs_ext(def_from,def_to,currpt.left.nodetype,convtype,pdoper,cdoptions); + + { when the types are not equal we need to check + some special case for parameter passing } + if (eq<te_equal) then + begin + if currpara.varspez in [vs_var,vs_out] then + begin + { para requires an equal type so the previous found + match was not good enough, reset to incompatible } + 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,currpt.resulttype.def,currpara.vartype.def) + end + else + para_allowed(eq,currpt,def_to); + 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 + { store the current parameter info for + a nice error message when no procedure is found } + hp^.wrongparaidx:=paraidx; + hp^.wrongparanr:=currparanr; + break; + end; + +{$ifdef EXTDEBUG} + { store equal in node tree for dump } + currpara.eqval:=eq; +{$endif EXTDEBUG} + + { maybe release temp currpt } + if releasecurrpt then + currpt.free; + + { next parameter in the call tree } + pt:=tcallparanode(pt.right); + + { next parameter for definition, only goto next para + if we're out of the varargs } + if not(po_varargs in hp^.data.procoptions) or + (currparanr<=hp^.data.maxparacount) then + begin + { Ignore vs_hidden parameters } + repeat + dec(paraidx); + until (paraidx<0) or not(vo_is_hidden_para in tparavarsym(hp^.data.paras[paraidx]).varoptions); + end; + dec(currparanr); + end; + if not(hp^.invalid) and + (assigned(pt) or (paraidx>=0) or (currparanr<>0)) then + internalerror(200212141); + { next candidate } + hp:=hp^.next; + end; + end; + + + function is_better_candidate(currpd,bestpd:pcandidate):integer; + var + res : integer; + begin + { + Return values: + > 0 when currpd is better than bestpd + < 0 when bestpd is better than currpd + = 0 when both are equal + + To choose the best candidate we use the following order: + - Incompatible flag + - (Smaller) Number of convert operator parameters. + - (Smaller) Number of convertlevel 2 parameters. + - (Smaller) Number of convertlevel 1 parameters. + - (Bigger) Number of exact parameters. + - (Smaller) Number of equal parameters. + - (Smaller) Total of ordinal distance. For example, the distance of a word + to a byte is 65535-255=65280. + } + if bestpd^.invalid then + begin + if currpd^.invalid then + res:=0 + else + res:=1; + end + else + if currpd^.invalid then + res:=-1 + else + begin + { less operator parameters? } + res:=(bestpd^.coper_count-currpd^.coper_count); + if (res=0) then + begin + { less cl3 parameters? } + res:=(bestpd^.cl3_count-currpd^.cl3_count); + if (res=0) then + begin + { less cl2 parameters? } + res:=(bestpd^.cl2_count-currpd^.cl2_count); + if (res=0) then + begin + { less cl1 parameters? } + res:=(bestpd^.cl1_count-currpd^.cl1_count); + if (res=0) then + begin + { more exact parameters? } + res:=(currpd^.exact_count-bestpd^.exact_count); + if (res=0) then + begin + { less equal parameters? } + res:=(bestpd^.equal_count-currpd^.equal_count); + if (res=0) then + begin + { smaller ordinal distance? } + if (currpd^.ordinal_distance<bestpd^.ordinal_distance) then + res:=1 + else + if (currpd^.ordinal_distance>bestpd^.ordinal_distance) then + res:=-1 + else + res:=0; + end; + end; + end; + end; + end; + end; + end; + is_better_candidate:=res; + end; + + + function tcallcandidates.choose_best(var bestpd:tabstractprocdef):integer; + var + besthpstart, + hp : pcandidate; + cntpd, + res : integer; + begin + { + Returns the number of candidates left and the + first candidate is returned in pdbest + } + { Setup the first procdef as best, only count it as a result + when it is valid } + bestpd:=FProcs^.data; + if FProcs^.invalid then + cntpd:=0 + else + cntpd:=1; + if assigned(FProcs^.next) then + begin + besthpstart:=FProcs; + hp:=FProcs^.next; + while assigned(hp) do + begin + res:=is_better_candidate(hp,besthpstart); + if (res>0) then + begin + { hp is better, flag all procs to be incompatible } + while (besthpstart<>hp) do + begin + besthpstart^.invalid:=true; + besthpstart:=besthpstart^.next; + end; + { besthpstart is already set to hp } + bestpd:=besthpstart^.data; + cntpd:=1; + end + else + if (res<0) then + begin + { besthpstart is better, flag current hp to be incompatible } + hp^.invalid:=true; + end + else + begin + { res=0, both are valid } + if not hp^.invalid then + inc(cntpd); + end; + hp:=hp^.next; + end; + end; + + result:=cntpd; + end; + + + procedure tcallcandidates.find_wrong_para; + var + currparanr : smallint; + hp : pcandidate; + pt : tcallparanode; + wrongpara : tparavarsym; + begin + { Only process the first overloaded procdef } + hp:=FProcs; + { Find callparanode corresponding to the argument } + pt:=tcallparanode(FParanode); + currparanr:=FParalength; + while assigned(pt) and + (currparanr>hp^.wrongparanr) do + begin + pt:=tcallparanode(pt.right); + dec(currparanr); + end; + if (currparanr<>hp^.wrongparanr) or + not assigned(pt) then + internalerror(200212094); + { Show error message, when it was a var or out parameter + guess that it is a missing typeconv } + wrongpara:=tparavarsym(hp^.data.paras[hp^.wrongparaidx]); + if wrongpara.varspez in [vs_var,vs_out] then + begin + { Maybe passing the correct type but passing a const to var parameter } + if (compare_defs(pt.resulttype.def,wrongpara.vartype.def,pt.nodetype)<>te_incompatible) and + not valid_for_var(pt.left) then + CGMessagePos(pt.left.fileinfo,type_e_variable_id_expected) + else + CGMessagePos2(pt.left.fileinfo,parser_e_call_by_ref_without_typeconv, + FullTypeName(pt.left.resulttype.def,wrongpara.vartype.def), + FullTypeName(wrongpara.vartype.def,pt.left.resulttype.def)) + end + else + CGMessagePos3(pt.left.fileinfo,type_e_wrong_parameter_type,tostr(hp^.wrongparanr), + FullTypeName(pt.left.resulttype.def,wrongpara.vartype.def), + FullTypeName(wrongpara.vartype.def,pt.left.resulttype.def)); + end; + + +end. |