{ $Id$ Copyright (c) 1998-2002 by Florian Klaempfl This file implements the node for sub procedure calling. 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 ncal; {$i fpcdefs.inc} interface uses cutils,cclasses, globtype,cpuinfo, node,nbas, {$ifdef state_tracking} nstate, {$endif state_tracking} symbase,symtype,symppu,symsym,symdef,symtable; type pcandidate = ^tcandidate; tcandidate = record next : pcandidate; data : tprocdef; wrongpara, firstpara : tparaitem; exact_count, equal_count, cl1_count, cl2_count, cl3_count, coper_count : integer; { should be signed } ordinal_distance : bestreal; invalid : boolean; wrongparanr : byte; end; tcallnode = class(tbinarynode) private paralength : smallint; function candidates_find:pcandidate; procedure candidates_free(procs:pcandidate); procedure candidates_list(procs:pcandidate;all:boolean); procedure candidates_get_information(procs:pcandidate); function candidates_choose_best(procs:pcandidate;var bestpd:tprocdef):integer; procedure candidates_find_wrong_para(procs:pcandidate); {$ifdef EXTDEBUG} procedure candidates_dump_info(lvl:longint;procs:pcandidate); {$endif EXTDEBUG} procedure bind_paraitem; public { the symbol containing the definition of the procedure } { to call } symtableprocentry : tprocsym; { symtable where the entry was found, needed for with support } symtableproc : tsymtable; { the definition of the procedure to call } procdefinition : tabstractprocdef; { tree that contains the pointer to the object for this method } methodpointer : tnode; { function return node, this is used to pass the data for a ret_in_param return value } funcretnode : tnode; { separately specified resulttype for some compilerprocs (e.g. } { you can't have a function with an "array of char" resulttype } { the RTL) (JM) } restype: ttype; restypeset: boolean; { only the processor specific nodes need to override this } { constructor } constructor create(l:tnode; v : tprocsym;st : tsymtable; mp : tnode);virtual; constructor createintern(const name: string; params: tnode); constructor createinternres(const name: string; params: tnode; const res: ttype); constructor createinternreturn(const name: string; params: tnode; returnnode : tnode); destructor destroy;override; constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override; procedure ppuwrite(ppufile:tcompilerppufile);override; procedure derefimpl;override; function getcopy : tnode;override; { Goes through all symbols in a class and subclasses and calls verify abstract for each . } procedure verifyabstractcalls; { called for each definition in a class and verifies if a method is abstract or not, if it is abstract, give out a warning } procedure verifyabstract(p : tnamedindexitem;arg:pointer); procedure insertintolist(l : tnodelist);override; function pass_1 : tnode;override; function det_resulttype:tnode;override; {$ifdef state_tracking} function track_state_pass(exec_known:boolean):boolean;override; {$endif state_tracking} function docompare(p: tnode): boolean; override; procedure set_procvar(procvar:tnode); procedure printnodedata(var t:text);override; private {$ifdef callparatemp} function extract_functioncall_paras: tblocknode; {$endif callparatemp} AbstractMethodsList : TStringList; end; tcallnodeclass = class of tcallnode; tcallparaflags = ( { flags used by tcallparanode } cpf_exact_match_found, cpf_convlevel1found, cpf_convlevel2found, cpf_is_colon_para ); tcallparanode = class(tbinarynode) callparaflags : set of tcallparaflags; paraitem : tparaitem; used_by_callnode : boolean; { only the processor specific nodes need to override this } { constructor } constructor create(expr,next : tnode);virtual; destructor destroy;override; constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override; procedure ppuwrite(ppufile:tcompilerppufile);override; procedure derefimpl;override; function getcopy : tnode;override; procedure insertintolist(l : tnodelist);override; procedure get_paratype; procedure insert_typeconv(do_count : boolean); procedure det_registers; procedure firstcallparan(do_count : boolean); procedure secondcallparan(push_from_left_to_right:boolean;calloption:tproccalloption; para_alignment,para_offset : longint);virtual;abstract; function docompare(p: tnode): boolean; override; procedure printnodetree(var t:text);override; end; tcallparanodeclass = class of tcallparanode; tprocinlinenode = class(tnode) inlinetree : tnode; inlineprocdef : tprocdef; retoffset,para_offset,para_size : longint; constructor create(p:tprocdef);virtual; destructor destroy;override; constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override; procedure ppuwrite(ppufile:tcompilerppufile);override; procedure derefimpl;override; function getcopy : tnode;override; function det_resulttype : tnode;override; procedure insertintolist(l : tnodelist);override; function pass_1 : tnode;override; function docompare(p: tnode): boolean; override; end; tprocinlinenodeclass = class of tprocinlinenode; function reverseparameters(p: tcallparanode): tcallparanode; var ccallnode : tcallnodeclass; ccallparanode : tcallparanodeclass; cprocinlinenode : tprocinlinenodeclass; implementation uses systems, verbose,globals, symconst,paramgr,defutil,defcmp, htypechk,pass_1,cpubase, ncnv,nld,ninl,nadd,ncon,nmem, nutils, rgobj,cginfo,cgbase ; type tobjectinfoitem = class(tlinkedlistitem) objinfo : tobjectdef; constructor create(def : tobjectdef); end; {**************************************************************************** HELPERS ****************************************************************************} function reverseparameters(p: tcallparanode): tcallparanode; var hp1, hp2: tcallparanode; begin hp1:=nil; while assigned(p) do begin { pull out } hp2:=p; p:=tcallparanode(p.right); { pull in } hp2.right:=hp1; hp1:=hp2; end; reverseparameters:=hp1; end; function gen_high_tree(p:tnode;openstring:boolean):tnode; var temp: tnode; len : integer; loadconst : boolean; hightree : tnode; begin len:=-1; loadconst:=true; hightree:=nil; case p.resulttype.def.deftype of arraydef : begin { handle via a normal inline in_high_x node } loadconst := false; hightree := geninlinenode(in_high_x,false,p.getcopy); { only substract low(array) if it's <> 0 } temp := geninlinenode(in_low_x,false,p.getcopy); resulttypepass(temp); if (temp.nodetype <> ordconstn) or (tordconstnode(temp).value <> 0) then hightree := caddnode.create(subn,hightree,temp) else temp.free; end; stringdef : begin if openstring then begin { handle via a normal inline in_high_x node } loadconst := false; hightree := geninlinenode(in_high_x,false,p.getcopy); end else begin { passing a string to an array of char } if (p.nodetype=stringconstn) then begin len:=str_length(p); if len>0 then dec(len); end else begin hightree:=caddnode.create(subn,geninlinenode(in_length_x,false,p.getcopy), cordconstnode.create(1,s32bittype,false)); loadconst:=false; end; end; end; else len:=0; end; if loadconst then hightree:=cordconstnode.create(len,s32bittype,true) else begin if not assigned(hightree) then internalerror(200304071); hightree:=ctypeconvnode.create(hightree,s32bittype); end; result:=hightree; end; procedure search_class_overloads(aprocsym : tprocsym); { searches n in symtable of pd and all anchestors } var speedvalue : cardinal; srsym : tprocsym; s : string; objdef : tobjectdef; begin if aprocsym.overloadchecked then exit; aprocsym.overloadchecked:=true; if (aprocsym.owner.symtabletype<>objectsymtable) then internalerror(200111021); objdef:=tobjectdef(aprocsym.owner.defowner); { we start in the parent } if not assigned(objdef.childof) then exit; objdef:=objdef.childof; s:=aprocsym.name; speedvalue:=getspeedvalue(s); while assigned(objdef) do begin srsym:=tprocsym(objdef.symtable.speedsearch(s,speedvalue)); if assigned(srsym) then begin if (srsym.typ<>procsym) then internalerror(200111022); if srsym.is_visible_for_proc(current_procdef) then begin srsym.add_para_match_to(Aprocsym); { we can stop if the overloads were already added for the found symbol } if srsym.overloadchecked then break; end; end; { next parent } objdef:=objdef.childof; 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; 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; 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; {**************************************************************************** TOBJECTINFOITEM ****************************************************************************} constructor tobjectinfoitem.create(def : tobjectdef); begin inherited create; objinfo := def; end; {**************************************************************************** TCALLPARANODE ****************************************************************************} constructor tcallparanode.create(expr,next : tnode); begin inherited create(callparan,expr,next); if assigned(expr) then expr.set_file_line(self); callparaflags:=[]; end; destructor tcallparanode.destroy; begin { When the node is used by callnode then we don't destroy left, the callnode takes care of it } if used_by_callnode then left:=nil; inherited destroy; end; constructor tcallparanode.ppuload(t:tnodetype;ppufile:tcompilerppufile); begin inherited ppuload(t,ppufile); ppufile.getsmallset(callparaflags); end; procedure tcallparanode.ppuwrite(ppufile:tcompilerppufile); begin inherited ppuwrite(ppufile); ppufile.putsmallset(callparaflags); end; procedure tcallparanode.derefimpl; begin inherited derefimpl; end; function tcallparanode.getcopy : tnode; var n : tcallparanode; begin n:=tcallparanode(inherited getcopy); n.callparaflags:=callparaflags; n.paraitem:=paraitem; result:=n; end; procedure tcallparanode.insertintolist(l : tnodelist); begin end; procedure tcallparanode.get_paratype; var old_get_para_resulttype : boolean; old_array_constructor : boolean; begin inc(parsing_para_level); if assigned(right) then tcallparanode(right).get_paratype; old_array_constructor:=allow_array_constructor; old_get_para_resulttype:=get_para_resulttype; get_para_resulttype:=true; allow_array_constructor:=true; resulttypepass(left); get_para_resulttype:=old_get_para_resulttype; allow_array_constructor:=old_array_constructor; if codegenerror then resulttype:=generrortype else resulttype:=left.resulttype; dec(parsing_para_level); end; procedure tcallparanode.insert_typeconv(do_count : boolean); var oldtype : ttype; {$ifdef extdebug} store_count_ref : boolean; {$endif def extdebug} begin inc(parsing_para_level); {$ifdef extdebug} if do_count then begin store_count_ref:=count_ref; count_ref:=true; end; {$endif def extdebug} { Be sure to have the resulttype } if not assigned(left.resulttype.def) then resulttypepass(left); { Handle varargs and hidden paras directly, no typeconvs or } { typechecking needed } if (nf_varargs_para in flags) then begin { convert pascal to C types } case left.resulttype.def.deftype of stringdef : inserttypeconv(left,charpointertype); floatdef : inserttypeconv(left,s64floattype); end; set_varstate(left,true); resulttype:=left.resulttype; end else if (paraitem.paratyp = vs_hidden) then begin set_varstate(left,true); resulttype:=left.resulttype; end else begin { Do we need arrayconstructor -> set conversion, then insert it here before the arrayconstructor node breaks the tree with its conversions of enum->ord } if (left.nodetype=arrayconstructorn) and (paraitem.paratype.def.deftype=setdef) then inserttypeconv(left,paraitem.paratype); { set some settings needed for arrayconstructor } if is_array_constructor(left.resulttype.def) then begin if is_array_of_const(paraitem.paratype.def) then begin if assigned(aktcallprocdef) and (aktcallprocdef.proccalloption in [pocall_cppdecl,pocall_cdecl]) then include(left.flags,nf_cargs); { force variant array } include(left.flags,nf_forcevaria); end else begin include(left.flags,nf_novariaallowed); { now that the resultting type is know we can insert the required typeconvs for the array constructor } tarrayconstructornode(left).force_type(tarraydef(paraitem.paratype.def).elementtype); end; end; { check if local proc/func is assigned to procvar } if left.resulttype.def.deftype=procvardef then test_local_to_procvar(tprocvardef(left.resulttype.def),paraitem.paratype.def); { test conversions } if not(is_shortstring(left.resulttype.def) and is_shortstring(paraitem.paratype.def)) and (paraitem.paratype.def.deftype<>formaldef) then begin { Process open parameters } if paramanager.push_high_param(paraitem.paratype.def,aktcallprocdef.proccalloption) then begin { insert type conv but hold the ranges of the array } oldtype:=left.resulttype; inserttypeconv(left,paraitem.paratype); left.resulttype:=oldtype; end else begin { for ordinals, floats and enums, verify if we might cause some range-check errors. } if (left.resulttype.def.deftype in [enumdef,orddef,floatdef]) and (left.nodetype in [vecn,loadn,calln]) then begin if (left.resulttype.def.size>paraitem.paratype.def.size) then begin if (cs_check_range in aktlocalswitches) then Message(type_w_smaller_possible_range_check) else Message(type_h_smaller_possible_range_check); end; end; inserttypeconv(left,paraitem.paratype); end; if codegenerror then begin dec(parsing_para_level); exit; end; end; { check var strings } if (cs_strict_var_strings in aktlocalswitches) and is_shortstring(left.resulttype.def) and is_shortstring(paraitem.paratype.def) and (paraitem.paratyp in [vs_out,vs_var]) and not(is_open_string(paraitem.paratype.def)) and not(equal_defs(left.resulttype.def,paraitem.paratype.def)) then begin aktfilepos:=left.fileinfo; CGMessage(type_e_strict_var_string_violation); end; { File types are only allowed for var parameters } if (paraitem.paratype.def.deftype=filedef) and (paraitem.paratyp<>vs_var) then CGMessage(cg_e_file_must_call_by_reference); { Handle formal parameters separate } if (paraitem.paratype.def.deftype=formaldef) then begin { load procvar if a procedure is passed } if (m_tp_procvar in aktmodeswitches) and (left.nodetype=calln) and (is_void(left.resulttype.def)) then load_procvar_from_calln(left); case paraitem.paratyp of vs_var, vs_out : begin if not valid_for_formal_var(left) then CGMessagePos(left.fileinfo,parser_e_illegal_parameter_list); end; vs_const : begin if not valid_for_formal_const(left) then CGMessagePos(left.fileinfo,parser_e_illegal_parameter_list); end; end; end else begin { check if the argument is allowed } if (paraitem.paratyp in [vs_out,vs_var]) then valid_for_var(left); end; if paraitem.paratyp in [vs_var,vs_const] then begin { Causes problems with const ansistrings if also } { done for vs_const (JM) } if paraitem.paratyp = vs_var then set_unique(left); make_not_regable(left); end; { ansistrings out paramaters doesn't need to be } { unique, they are finalized } if paraitem.paratyp=vs_out then make_not_regable(left); if do_count then begin { not completly proper, but avoids some warnings } {if (paraitem.paratyp in [vs_var,vs_out]) then set_funcret_is_valid(left); } set_varstate(left,not(paraitem.paratyp in [vs_var,vs_out])); end; { must only be done after typeconv PM } resulttype:=paraitem.paratype; end; { process next node } if assigned(right) then tcallparanode(right).insert_typeconv(do_count); dec(parsing_para_level); {$ifdef extdebug} if do_count then count_ref:=store_count_ref; {$endif def extdebug} end; procedure tcallparanode.det_registers; var old_get_para_resulttype : boolean; old_array_constructor : boolean; begin if assigned(right) then begin tcallparanode(right).det_registers; registers32:=right.registers32; registersfpu:=right.registersfpu; {$ifdef SUPPORT_MMX} registersmmx:=right.registersmmx; {$endif} end; old_array_constructor:=allow_array_constructor; old_get_para_resulttype:=get_para_resulttype; get_para_resulttype:=true; allow_array_constructor:=true; firstpass(left); get_para_resulttype:=old_get_para_resulttype; allow_array_constructor:=old_array_constructor; if left.registers32>registers32 then registers32:=left.registers32; if left.registersfpu>registersfpu then registersfpu:=left.registersfpu; {$ifdef SUPPORT_MMX} if left.registersmmx>registersmmx then registersmmx:=left.registersmmx; {$endif SUPPORT_MMX} end; procedure tcallparanode.firstcallparan(do_count : boolean); begin if not assigned(left.resulttype.def) then begin get_paratype; { if assigned(defcoll) then insert_typeconv(defcoll,do_count); } end; det_registers; end; function tcallparanode.docompare(p: tnode): boolean; begin docompare := inherited docompare(p) and (callparaflags = tcallparanode(p).callparaflags) ; end; procedure tcallparanode.printnodetree(var t:text); begin printnodelist(t); end; {**************************************************************************** TCALLNODE ****************************************************************************} constructor tcallnode.create(l:tnode;v : tprocsym;st : tsymtable; mp : tnode); begin inherited create(calln,l,nil); symtableprocentry:=v; symtableproc:=st; include(flags,nf_return_value_used); methodpointer:=mp; procdefinition:=nil; restypeset:=false; funcretnode:=nil; paralength:=-1; end; constructor tcallnode.createintern(const name: string; params: tnode); var srsym: tsym; symowner: tsymtable; begin if not (cs_compilesystem in aktmoduleswitches) then begin srsym := searchsymonlyin(systemunit,name); symowner := systemunit; end else begin searchsym(name,srsym,symowner); if not assigned(srsym) then searchsym(upper(name),srsym,symowner); end; if not assigned(srsym) or (srsym.typ <> procsym) then begin {$ifdef EXTDEBUG} Comment(V_Error,'unknown compilerproc '+name); {$endif EXTDEBUG} internalerror(200107271); end; self.create(params,tprocsym(srsym),symowner,nil); end; constructor tcallnode.createinternres(const name: string; params: tnode; const res: ttype); begin self.createintern(name,params); restype := res; restypeset := true; { both the normal and specified resulttype either have to be returned via a } { parameter or not, but no mixing (JM) } if paramanager.ret_in_param(restype.def,pocall_compilerproc) xor paramanager.ret_in_param(symtableprocentry.first_procdef.rettype.def,symtableprocentry.first_procdef.proccalloption) then internalerror(200108291); end; constructor tcallnode.createinternreturn(const name: string; params: tnode; returnnode : tnode); begin self.createintern(name,params); funcretnode:=returnnode; if not paramanager.ret_in_param(symtableprocentry.first_procdef.rettype.def,symtableprocentry.first_procdef.proccalloption) then internalerror(200204247); end; destructor tcallnode.destroy; begin methodpointer.free; funcretnode.free; inherited destroy; end; constructor tcallnode.ppuload(t:tnodetype;ppufile:tcompilerppufile); begin inherited ppuload(t,ppufile); symtableprocentry:=tprocsym(ppufile.getderef); {$ifdef fpc} {$warning FIXME: No withsymtable support} {$endif} symtableproc:=nil; procdefinition:=tprocdef(ppufile.getderef); restypeset:=boolean(ppufile.getbyte); methodpointer:=ppuloadnode(ppufile); funcretnode:=ppuloadnode(ppufile); end; procedure tcallnode.ppuwrite(ppufile:tcompilerppufile); begin inherited ppuwrite(ppufile); ppufile.putderef(symtableprocentry); ppufile.putderef(procdefinition); ppufile.putbyte(byte(restypeset)); ppuwritenode(ppufile,methodpointer); ppuwritenode(ppufile,funcretnode); end; procedure tcallnode.derefimpl; begin inherited derefimpl; resolvesym(pointer(symtableprocentry)); symtableproc:=symtableprocentry.owner; resolvedef(pointer(procdefinition)); if assigned(methodpointer) then methodpointer.derefimpl; if assigned(funcretnode) then funcretnode.derefimpl; end; procedure tcallnode.set_procvar(procvar:tnode); begin right:=procvar; end; function tcallnode.getcopy : tnode; var n : tcallnode; begin n:=tcallnode(inherited getcopy); n.symtableprocentry:=symtableprocentry; n.symtableproc:=symtableproc; n.procdefinition:=procdefinition; n.restype := restype; n.restypeset := restypeset; if assigned(methodpointer) then n.methodpointer:=methodpointer.getcopy else n.methodpointer:=nil; if assigned(funcretnode) then n.funcretnode:=funcretnode.getcopy else n.funcretnode:=nil; result:=n; end; procedure tcallnode.insertintolist(l : tnodelist); begin end; procedure tcallnode.verifyabstract(p : tnamedindexitem;arg:pointer); var hp : tprocdef; j: integer; begin if (tsym(p).typ=procsym) then begin for j:=1 to tprocsym(p).procdef_count do begin { index starts at 1 } hp:=tprocsym(p).procdef[j]; { If this is an abstract method insert into the list } if (po_abstractmethod in hp.procoptions) then AbstractMethodsList.Insert(hp.procsym.name) else { If this symbol is already in the list, and it is an overriding method or dynamic, then remove it from the list } begin { symbol was found } if AbstractMethodsList.Find(hp.procsym.name) <> nil then begin if po_overridingmethod in hp.procoptions then AbstractMethodsList.Remove(hp.procsym.name); end; end; end; end; end; procedure tcallnode.verifyabstractcalls; var objectdf : tobjectdef; parents : tlinkedlist; objectinfo : tobjectinfoitem; stritem : tstringlistitem; _classname : string; begin objectdf := nil; { verify if trying to create an instance of a class which contains non-implemented abstract methods } { first verify this class type, no class than exit } { also, this checking can only be done if the constructor is directly called, indirect constructor calls cannot be checked. } if assigned(methodpointer) and assigned(methodpointer.resulttype.def) then if (methodpointer.resulttype.def.deftype = classrefdef) and (methodpointer.nodetype in [typen,loadvmtn]) then begin if (tclassrefdef(methodpointer.resulttype.def).pointertype.def.deftype = objectdef) then objectdf := tobjectdef(tclassrefdef(methodpointer.resulttype.def).pointertype.def); end; if not assigned(objectdf) then exit; if assigned(objectdf.symtable.name) then _classname := objectdf.symtable.name^ else _classname := ''; parents := tlinkedlist.create; AbstractMethodsList := tstringlist.create; { insert all parents in this class : the first item in the list will be the base parent of the class . } while assigned(objectdf) do begin objectinfo:=tobjectinfoitem.create(objectdf); parents.insert(objectinfo); objectdf := objectdf.childof; end; { now all parents are in the correct order insert all abstract methods in the list, and remove those which are overriden by parent classes. } objectinfo:=tobjectinfoitem(parents.first); while assigned(objectinfo) do begin objectdf := objectinfo.objinfo; if assigned(objectdf.symtable) then objectdf.symtable.foreach({$ifdef FPCPROCVAR}@{$endif}verifyabstract,nil); objectinfo:=tobjectinfoitem(objectinfo.next); end; if assigned(parents) then parents.free; { Finally give out a warning for each abstract method still in the list } stritem := tstringlistitem(AbstractMethodsList.first); while assigned(stritem) do begin if assigned(stritem.fpstr) then Message2(type_w_instance_with_abstract,lower(_classname),lower(stritem.fpstr^)); stritem := tstringlistitem(stritem.next); end; if assigned(AbstractMethodsList) then AbstractMethodsList.Free; end; function Tcallnode.candidates_find:pcandidate; var j : integer; pd : tprocdef; procs,hp : pcandidate; found, has_overload_directive : boolean; srsymtable : tsymtable; srprocsym : tprocsym; procedure proc_add(pd:tprocdef); var i : integer; begin { generate new candidate entry } new(hp); fillchar(hp^,sizeof(tcandidate),0); hp^.data:=pd; hp^.next:=procs; procs:=hp; { Find last parameter, skip all default parameters that are not passed. Ignore this skipping for varargs } hp^.firstpara:=tparaitem(pd.Para.last); if not(po_varargs in pd.procoptions) then begin for i:=1 to pd.maxparacount-paralength do hp^.firstpara:=tparaitem(hp^.firstPara.previous); end; end; begin procs:=nil; { 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 symtableprocentry.overloadchecked) and (po_overload in symtableprocentry.first_procdef.procoptions) and (symtableprocentry.owner.symtabletype=objectsymtable) then search_class_overloads(symtableprocentry); { link all procedures which have the same # of parameters } for j:=1 to symtableprocentry.procdef_count do begin pd:=symtableprocentry.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 (nf_isproperty in flags) or (pd.owner.symtabletype<>objectsymtable) or pd.is_visible_for_proc(current_procdef) then begin { only when the # of parameter are supported by the procedure } if (paralength>=pd.minparacount) and ((po_varargs in pd.procoptions) or { varargs } (paralength<=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 symtableprocentry.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 (symtableprocentry.owner.symtabletype<>objectsymtable) then begin srsymtable:=symtableprocentry.owner.next; while assigned(srsymtable) do begin if srsymtable.symtabletype in [localsymtable,staticsymtable,globalsymtable] then begin srprocsym:=tprocsym(srsymtable.speedsearch(symtableprocentry.name,symtableprocentry.speedvalue)); { process only visible procsyms } if assigned(srprocsym) and (srprocsym.typ=procsym) and srprocsym.is_visible_for_proc(current_procdef) then begin { if this procedure doesn't have overload we can stop searching } if not(po_overload in srprocsym.first_procdef.procoptions) then break; { 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 (paralength>=pd.minparacount) and ((po_varargs in pd.procoptions) or { varargs } (paralength<=pd.maxparacount)) then begin found:=false; hp:=procs; while assigned(hp) do begin if compare_paras(hp^.data.para,pd.para,cp_value_equal_const,false)>=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; candidates_find:=procs; end; procedure tcallnode.candidates_free(procs:pcandidate); var hpnext, hp : pcandidate; begin hp:=procs; while assigned(hp) do begin hpnext:=hp^.next; dispose(hp); hp:=hpnext; end; end; procedure tcallnode.candidates_list(procs:pcandidate;all:boolean); var hp : pcandidate; begin hp:=procs; 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 Tcallnode.candidates_dump_info(lvl:longint;procs:pcandidate); 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; currpara : tparaitem; begin if not CheckVerbosity(lvl) then exit; Comment(lvl+V_LineInfo,'Overloaded callnode: '+symtableprocentry.name+'('+ParaTreeStr(tcallparanode(left))+')'); hp:=procs; 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 } currpara:=hp^.firstpara; if assigned(currpara) then begin while assigned(currpara.next) do currpara:=tparaitem(currpara.next); end; while assigned(currpara) do begin if (currpara.paratyp<>vs_hidden) then Comment(lvl,' - '+currpara.paratype.def.typename+' : '+EqualTypeName[currpara.eqval]); currpara:=tparaitem(currpara.previous); end; end; hp:=hp^.next; end; end; {$endif EXTDEBUG} procedure Tcallnode.candidates_get_information(procs:pcandidate); var hp : pcandidate; currpara : tparaitem; currparanr : byte; def_from, def_to : tdef; pt : tcallparanode; eq : tequaltype; convtype : tconverttype; pdoper : tprocdef; begin { process all procs } hp:=procs; 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:=paralength; currpara:=hp^.firstpara; while assigned(currpara) and (currpara.paratyp=vs_hidden) do currpara:=tparaitem(currpara.previous); pt:=tcallparanode(left); while assigned(pt) and assigned(currpara) do begin { retrieve current parameter definitions to compares } eq:=te_incompatible; def_from:=pt.resulttype.def; def_to:=currpara.paratype.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); { varargs are always equal, but not exact } if (po_varargs in hp^.data.procoptions) and (currparanr>hp^.data.minparacount) then begin inc(hp^.equal_count); eq:=te_equal; end else { same definition -> exact } if (def_from=def_to) then begin inc(hp^.exact_count); eq:=te_exact; end else { for value and const parameters check if a integer is constant or included in other integer -> equal and calc ordinal_distance } if not(currpara.paratyp 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 inc(hp^.equal_count); 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,pt.left.nodetype, false,true,convtype,pdoper); { when the types are not equal we need to check some special case for parameter passing } if (eqvs_hidden); end; dec(currparanr); end; if not(hp^.invalid) and (assigned(pt) or assigned(currpara) or (currparanr<>0)) then internalerror(200212141); { next candidate } hp:=hp^.next; end; end; function Tcallnode.candidates_choose_best(procs:pcandidate;var bestpd:tprocdef):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:=procs^.data; if procs^.invalid then cntpd:=0 else cntpd:=1; if assigned(procs^.next) then begin besthpstart:=procs; hp:=procs^.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; candidates_choose_best:=cntpd; end; procedure tcallnode.candidates_find_wrong_para(procs:pcandidate); var currparanr : smallint; hp : pcandidate; pt : tcallparanode; begin { Only process the first overloaded procdef } hp:=procs; { Find callparanode corresponding to the argument } pt:=tcallparanode(left); currparanr:=paralength; 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 } if hp^.wrongpara.paratyp in [vs_var,vs_out] then CGMessagePos2(left.fileinfo,parser_e_call_by_ref_without_typeconv, pt.resulttype.def.typename,hp^.wrongpara.paratype.def.typename) else CGMessagePos3(pt.fileinfo,type_e_wrong_parameter_type, tostr(hp^.wrongparanr),pt.resulttype.def.typename,hp^.wrongpara.paratype.def.typename); end; procedure tcallnode.bind_paraitem; var i : integer; pt : tcallparanode; oldppt : ^tcallparanode; currpara : tparaitem; used_by_callnode : boolean; hiddentree : tnode; newstatement : tstatementnode; temp : ttempcreatenode; begin pt:=tcallparanode(left); oldppt:=@left; { flag all callparanodes that belong to the varargs } if (po_varargs in procdefinition.procoptions) then begin i:=paralength; while (i>procdefinition.maxparacount) do begin include(tcallparanode(pt).flags,nf_varargs_para); oldppt:=@pt.right; pt:=tcallparanode(pt.right); dec(i); end; end; { insert hidden parameters } currpara:=tparaitem(procdefinition.Para.last); while assigned(currpara) do begin if (currpara.paratyp=vs_hidden) then begin { generate hidden tree } used_by_callnode:=false; hiddentree:=nil; if (vo_is_funcret in tvarsym(currpara.parasym).varoptions) then begin { Generate funcretnode if not specified } if assigned(funcretnode) then begin hiddentree:=funcretnode; funcretnode:=nil; end else begin hiddentree:=internalstatements(newstatement,false); { need to use resulttype instead of procdefinition.rettype, because they can be different } temp:=ctempcreatenode.create(resulttype,resulttype.def.size,true); addstatement(newstatement,temp); addstatement(newstatement,ctempdeletenode.create_normal_temp(temp)); addstatement(newstatement,ctemprefnode.create(temp)); end; end else if vo_is_high_value in tvarsym(currpara.parasym).varoptions then begin if not assigned(pt) then internalerror(200304082); { we need the information of the next parameter } hiddentree:=gen_high_tree(pt.left,is_open_string(tparaitem(currpara.previous).paratype.def)); end; { add the hidden parameter } if not assigned(hiddentree) then internalerror(200304073); { Already insert para and let the previous node point to this new node } pt:=ccallparanode.create(hiddentree,oldppt^); pt.used_by_callnode:=used_by_callnode; oldppt^:=pt; end; { Bind paraitem to this node } pt.paraitem:=currpara; { Next node and paraitem } oldppt:=@pt.right; pt:=tcallparanode(pt.right); currpara:=tparaitem(currpara.previous); end; end; function tcallnode.det_resulttype:tnode; var procs : pcandidate; oldcallprocdef : tabstractprocdef; hpt : tnode; pt : tcallparanode; lastpara : longint; currpara : tparaitem; cand_cnt : integer; i : longint; method_must_be_valid, is_const : boolean; label errorexit; begin result:=nil; procs:=nil; oldcallprocdef:=aktcallprocdef; aktcallprocdef:=nil; { determine length of parameter list } pt:=tcallparanode(left); paralength:=0; while assigned(pt) do begin inc(paralength); pt:=tcallparanode(pt.right); end; { determine the type of the parameters } if assigned(left) then begin tcallparanode(left).get_paratype; if codegenerror then goto errorexit; end; { procedure variable ? } if assigned(right) then begin set_varstate(right,true); resulttypepass(right); if codegenerror then exit; procdefinition:=tabstractprocdef(right.resulttype.def); { Compare parameters from right to left } currpara:=tparaitem(procdefinition.Para.last); while assigned(currpara) and (currpara.paratyp=vs_hidden) do currpara:=tparaitem(currpara.previous); pt:=tcallparanode(left); lastpara:=paralength; while assigned(currpara) and assigned(pt) do begin { only goto next para if we're out of the varargs } if not(po_varargs in procdefinition.procoptions) or (lastpara<=procdefinition.maxparacount) then begin repeat currpara:=tparaitem(currpara.previous); until (not assigned(currpara)) or (currpara.paratyp<>vs_hidden); end; pt:=tcallparanode(pt.right); dec(lastpara); end; if assigned(pt) or assigned(currpara) then begin if assigned(pt) then aktfilepos:=pt.fileinfo; CGMessage(parser_e_wrong_parameter_size); goto errorexit; end; end else { not a procedure variable } begin { do we know the procedure to call ? } if not(assigned(procdefinition)) then begin procs:=candidates_find; { no procedures found? then there is something wrong with the parameter size } if not assigned(procs) then begin { when it's an auto inherited call and there is no procedure found, but the procedures were defined with overload directive and at least two procedures are defined then we ignore this inherited by inserting a nothingn. Only do this ugly hack in Delphi mode as it looks more like a bug. It's also not documented } if (m_delphi in aktmodeswitches) and (nf_anon_inherited in flags) and (symtableprocentry.owner.symtabletype=objectsymtable) and (po_overload in symtableprocentry.first_procdef.procoptions) and (symtableprocentry.procdef_count>=2) then result:=cnothingnode.create else begin { in tp mode we can try to convert to procvar if there are no parameters specified. Only try it when there is only one proc definition, else the loadnode will give a strange error } if not(assigned(left)) and (m_tp_procvar in aktmodeswitches) and (symtableprocentry.procdef_count=1) then begin hpt:=cloadnode.create(tprocsym(symtableprocentry),symtableproc); if (symtableprocentry.owner.symtabletype=objectsymtable) then begin if assigned(methodpointer) then tloadnode(hpt).set_mp(methodpointer.getcopy) else tloadnode(hpt).set_mp(cselfnode.create(tobjectdef(symtableprocentry.owner.defowner))); end; resulttypepass(hpt); result:=hpt; end else begin if assigned(left) then aktfilepos:=left.fileinfo; CGMessage(parser_e_wrong_parameter_size); symtableprocentry.write_parameter_lists(nil); end; end; goto errorexit; end; { Retrieve information about the candidates } candidates_get_information(procs); {$ifdef EXTDEBUG} { Display info when multiple candidates are found } if assigned(procs^.next) then candidates_dump_info(V_Debug,procs); {$endif EXTDEBUG} { Choose the best candidate and count the number of candidates left } cand_cnt:=candidates_choose_best(procs,tprocdef(procdefinition)); { All parameters are checked, check if there are any procedures left } if cand_cnt>0 then begin { Multiple candidates left? } if cand_cnt>1 then begin CGMessage(cg_e_cant_choose_overload_function); {$ifdef EXTDEBUG} candidates_dump_info(V_Hint,procs); {$else} candidates_list(procs,false); {$endif EXTDEBUG} { we'll just use the first candidate to make the call } end; { assign procdefinition } if symtableproc=nil then symtableproc:=procdefinition.owner; { update browser information } if make_ref then begin tprocdef(procdefinition).lastref:=tref.create(tprocdef(procdefinition).lastref,@fileinfo); inc(tprocdef(procdefinition).refcount); if tprocdef(procdefinition).defref=nil then tprocdef(procdefinition).defref:=tprocdef(procdefinition).lastref; end; end else begin { No candidates left, this must be a type error, because wrong size is already checked. procdefinition is filled with the first (random) definition that is found. We use this definition to display a nice error message that the wrong type is passed } candidates_find_wrong_para(procs); candidates_list(procs,true); {$ifdef EXTDEBUG} candidates_dump_info(V_Hint,procs); {$endif EXTDEBUG} { We can not proceed, release all procs and exit } candidates_free(procs); goto errorexit; end; candidates_free(procs); end; { end of procedure to call determination } { add needed default parameters } if assigned(procdefinition) and (paralength