{ $Id$ 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: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 } procedure set_varstate(p:tnode;newstate:tvarstate;must_be_valid:boolean); { 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; 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:=''; 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)) and ((rd.deftype in [stringdef,orddef,enumdef]) or is_pchar(rd) or is_pwidechar(rd) or is_chararray(rd) or is_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)) 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 is_integer(ld) or (ld.deftype=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 is_integer(ld) or is_boolean(ld) 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) 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)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.registersintnormal_function_level) and (to_def.deftype=procvardef) then CGMessage(type_e_cannot_local_proc_to_procvar); end; procedure set_varstate(p:tnode;newstate:tvarstate;must_be_valid:boolean); 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 : must_be_valid:=false; tc_pchar_2_string, tc_pointer_2_array : must_be_valid:=true; end; p:=tunarynode(p).left; end; subscriptn : p:=tunarynode(p).left; vecn: begin set_varstate(tbinarynode(p).right,vs_used,true); if not(tunarynode(p).left.resulttype.def.deftype in [stringdef,arraydef]) then must_be_valid:=true; 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 must_be_valid 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 if tloadnode(p).symtable.symtabletype=localsymtable then CGMessage1(sym_n_uninitialized_local_variable,hsym.realname) else CGMessage1(sym_n_uninitialized_variable,hsym.realname); 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; gotwith, gotsubscript, gotpointer, gotvec, gotclass, 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; gotclass:=false; gotpointer:=false; gotwith:=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 (valid_property in opts) then result:=true else begin { check return type } case hp.resulttype.def.deftype of pointerdef : gotpointer:=true; objectdef : gotclass:=is_class_or_interface(hp.resulttype.def); recorddef, { handle record like class it needs a subscription } classrefdef : gotclass:=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. if the address is needed of a field (subscriptn) } if (gotpointer and gotderef) or ( gotclass and (gotsubscript or gotwith) ) or ( (Valid_Addr in opts) and (hp.nodetype=subscriptn) ) then result:=true else CGMessagePos(hp.fileinfo,errmsg); end; 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 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; 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; subn, addn : begin { Allow add/sub 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 CGMessagePos(hp.fileinfo,type_e_variable_id_expected); 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; 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 } if (gotpointer and gotderef) or (gotclass and (gotsubscript or gotwith)) 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 (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 (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 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; 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,valid_property]); 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) and (p.left.nodetype=calln) and (proc_to_procvar_equal(tprocdef(tcallnode(p.left).procdefinition),tprocvardef(def_to),true)>=te_equal) then eq:=te_equal; end; end; end; {**************************************************************************** TCallCandidates ****************************************************************************} constructor tcallcandidates.create(sym:tprocsym;st:tsymtable;ppn:tnode;isprop: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) and (st.defowner.owner.symtabletype in [globalsymtable,staticsymtable]) and (st.defowner.owner.unitid=0) 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 } if isprop 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:=result+p.resulttype.def.typename; 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^.exact_count)); { 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; 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)); hp^.ordinal_distance:=hp^.ordinal_distance+ abs(bestreal(torddef(def_to).high)-bestreal(torddef(def_from).high)); { 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 { 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 (eqcurrpt) 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_distancebestpd^.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. { $Log$ Revision 1.106 2004-12-05 12:28:10 peter * procvar handling for tp procvar mode fixed * proc to procvar moved from addrnode to typeconvnode * inlininginfo is now allocated only for inline routines that can be inlined, introduced a new flag po_has_inlining_info Revision 1.105 2004/11/29 21:40:54 peter * fixed wrong calculation for checking default parameters Revision 1.104 2004/11/15 23:35:31 peter * tparaitem removed, use tparavarsym instead * parameter order is now calculated from paranr value in tparavarsym Revision 1.103 2004/11/08 22:09:58 peter * tvarsym splitted Revision 1.102 2004/11/01 16:58:57 peter * give IE instead of crash when no procsym is passed for calln Revision 1.101 2004/10/24 11:44:28 peter * small regvar fixes * loadref parameter removed from concatcopy,incrrefcount,etc Revision 1.100 2004/10/12 14:34:49 peter * fixed visibility for procsyms * fixed override check when there was no entry yet Revision 1.99 2004/10/08 17:09:43 peter * tvarsym.varregable added, split vo_regable from varoptions Revision 1.98 2004/09/27 15:15:52 peter * register loopvarsym for fields instead of record variable * don't allow class fields as loop var Revision 1.97 2004/09/13 20:28:27 peter * for loop variable assignment is not allowed anymore Revision 1.96 2004/08/22 11:24:09 peter * fix error when passing constant to var parameter Revision 1.95 2004/06/23 16:22:45 peter * include unit name in error messages when types are the same Revision 1.94 2004/06/20 08:55:29 florian * logs truncated Revision 1.93 2004/06/16 20:07:07 florian * dwarf branch merged Revision 1.92 2004/05/25 21:27:35 florian * fixed another formal const problem caused by yesterday's changes Revision 1.91 2004/05/24 21:24:40 florian * properties are allowed as formal const parameters as well Revision 1.90 2004/05/24 21:04:31 florian * fixed more formal const problems Revision 1.89 2004/05/24 20:39:41 florian * stricter handling of formal const parameters and IE fixed }