{ $Id$ Copyright (c) 1998-2000 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 defines.inc} interface uses node, symbase,symsym,symdef,symtable; type tcallnode = class(tbinarynode) { the symbol containing the definition of the procedure } { to call } symtableprocentry : pprocsym; { the symtable containing symtableprocentry } symtableproc : psymtable; { the definition of the procedure to call } procdefinition : pabstractprocdef; methodpointer : tnode; { only the processor specific nodes need to override this } { constructor } constructor create(v : pprocsym;st : psymtable; mp : tnode);virtual; destructor destroy;override; function getcopy : tnode;override; procedure insertintolist(l : tnodelist);override; function pass_1 : tnode;override; function docompare(p: tnode): boolean; override; end; tcallparaflags = ( { flags used by tcallparanode } cpf_exact_match_found, cpf_convlevel1found, cpf_convlevel2found, cpf_is_colon_para ); tcallparanode = class(tbinarynode) callparaflags : set of tcallparaflags; hightree : tnode; { only the processor specific nodes need to override this } { constructor } constructor create(expr,next : tnode);virtual; destructor destroy;override; function getcopy : tnode;override; procedure insertintolist(l : tnodelist);override; procedure gen_high_tree(openstring:boolean); { tcallparanode doesn't use pass_1 } { tcallnode takes care of this } procedure firstcallparan(defcoll : tparaitem;do_count : boolean);virtual; procedure secondcallparan(defcoll : tparaitem; push_from_left_to_right,inlined,is_cdecl : boolean; para_alignment,para_offset : longint);virtual;abstract; function docompare(p: tnode): boolean; override; end; tprocinlinenode = class(tnode) inlinetree : tnode; inlineprocsym : pprocsym; retoffset,para_offset,para_size : longint; constructor create(callp,code : tnode);virtual; destructor destroy;override; function getcopy : tnode;override; procedure insertintolist(l : tnodelist);override; function pass_1 : tnode;override; function docompare(p: tnode): boolean; override; end; function gencallparanode(expr,next : tnode) : tnode; function gencallnode(v : pprocsym;st : psymtable) : tnode; { uses the callnode to create the new procinline node } function genprocinlinenode(callp,code : tnode) : tnode; var ccallnode : class of tcallnode; ccallparanode : class of tcallparanode; cprocinlinenode : class of tprocinlinenode; implementation uses cutils,globtype,systems, verbose,globals, symconst,symtype,types, htypechk,pass_1,cpubase, ncnv,nld,ninl,nadd,ncon,hcodegen, tgcpu {$ifdef newcg} ,cgbase {$endif newcg} ; function gencallnode(v : pprocsym;st : psymtable) : tnode; begin gencallnode:=ccallnode.create(v,st,nil); end; function gencallparanode(expr,next : tnode) : tnode; begin gencallparanode:=ccallparanode.create(expr,next); end; function genprocinlinenode(callp,code : tnode) : tnode; var p : tnode; begin p:=cprocinlinenode.create(callp,code); genprocinlinenode:=p; end; {**************************************************************************** TCALLPARANODE ****************************************************************************} constructor tcallparanode.create(expr,next : tnode); begin inherited create(callparan,expr,next); hightree:=nil; if assigned(expr) then expr.set_file_line(self); callparaflags:=[]; end; destructor tcallparanode.destroy; begin hightree.free; inherited destroy; end; function tcallparanode.getcopy : tnode; var n : tcallparanode; begin n:=tcallparanode(inherited getcopy); n.callparaflags:=callparaflags; if assigned(hightree) then n.hightree:=hightree.getcopy else n.hightree:=nil; result:=n; end; procedure tcallparanode.insertintolist(l : tnodelist); begin end; procedure tcallparanode.firstcallparan(defcoll : tparaitem;do_count : boolean); var old_get_para_resulttype : boolean; old_array_constructor : boolean; oldtype : pdef; {$ifdef extdebug} store_count_ref : boolean; {$endif def extdebug} {convtyp : tconverttype;} begin inc(parsing_para_level); {$ifdef extdebug} if do_count then begin store_count_ref:=count_ref; count_ref:=true; end; {$endif def extdebug} if assigned(right) then begin if defcoll=nil then tcallparanode(right).firstcallparan(nil,do_count) else tcallparanode(right).firstcallparan(tparaitem(defcoll.next),do_count); registers32:=right.registers32; registersfpu:=right.registersfpu; {$ifdef SUPPORT_MMX} registersmmx:=right.registersmmx; {$endif} end; if defcoll=nil then begin 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 codegenerror then begin dec(parsing_para_level); exit; end; resulttype:=left.resulttype; end { if we know the routine which is called, then the type } { conversions are inserted } 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 (defcoll.paratype.def^.deftype=setdef) then left:=gentypeconvnode(left,defcoll.paratype.def); { set some settings needed for arrayconstructor } if is_array_constructor(left.resulttype) then begin if is_array_of_const(defcoll.paratype.def) then begin if assigned(aktcallprocsym) and (([pocall_cppdecl,pocall_cdecl]*aktcallprocsym^.definition^.proccalloptions)<>[]) and (po_external in aktcallprocsym^.definition^.procoptions) then include(left.flags,nf_cargs); { force variant array } include(left.flags,nf_forcevaria); end else begin include(left.flags,nf_novariaallowed); tarrayconstructornode(left).constructordef:=parraydef(defcoll.paratype.def)^.elementtype.def; end; end; if do_count then begin { not completly proper, but avoids some warnings } if (defcoll.paratyp in [vs_var,vs_out]) then set_funcret_is_valid(left); { protected has nothing to do with read/write if (defcoll.paratyp in [vs_var,vs_out]) then test_protected(left); } { set_varstate(left,defcoll.paratyp<>vs_var); must only be done after typeconv PM } { only process typeconvn and arrayconstructn, else it will break other trees } { But this is need to get correct varstate !! PM } old_array_constructor:=allow_array_constructor; old_get_para_resulttype:=get_para_resulttype; allow_array_constructor:=true; get_para_resulttype:=false; if (left.nodetype in [arrayconstructorn,typeconvn]) then firstpass(left); if not assigned(resulttype) then resulttype:=left.resulttype; get_para_resulttype:=old_get_para_resulttype; allow_array_constructor:=old_array_constructor; end; { check if local proc/func is assigned to procvar } if left.resulttype^.deftype=procvardef then test_local_to_procvar(pprocvardef(left.resulttype),defcoll.paratype.def); { property is not allowed as var parameter } if (defcoll.paratyp in [vs_out,vs_var]) and (nf_isproperty in left.flags) then CGMessagePos(left.fileinfo,type_e_argument_cant_be_assigned); { generate the high() value tree } if not(assigned(aktcallprocsym) and (([pocall_cppdecl,pocall_cdecl]*aktcallprocsym^.definition^.proccalloptions)<>[]) and (po_external in aktcallprocsym^.definition^.procoptions)) and push_high_param(defcoll.paratype.def) then gen_high_tree(is_open_string(defcoll.paratype.def)); if not(is_shortstring(left.resulttype) and is_shortstring(defcoll.paratype.def)) and (defcoll.paratype.def^.deftype<>formaldef) then begin if (defcoll.paratyp in [vs_var,vs_out]) and { allows conversion from word to integer and byte to shortint } (not( (left.resulttype^.deftype=orddef) and (defcoll.paratype.def^.deftype=orddef) and (left.resulttype^.size=defcoll.paratype.def^.size) ) and { an implicit pointer conversion is allowed } not( (left.resulttype^.deftype=pointerdef) and (defcoll.paratype.def^.deftype=pointerdef) ) and { child classes can be also passed } not( (left.resulttype^.deftype=objectdef) and (defcoll.paratype.def^.deftype=objectdef) and pobjectdef(left.resulttype)^.is_related(pobjectdef(defcoll.paratype.def)) ) and { passing a single element to a openarray of the same type } not( (is_open_array(defcoll.paratype.def) and is_equal(parraydef(defcoll.paratype.def)^.elementtype.def,left.resulttype)) ) and { an implicit file conversion is also allowed } { from a typed file to an untyped one } not( (left.resulttype^.deftype=filedef) and (defcoll.paratype.def^.deftype=filedef) and (pfiledef(defcoll.paratype.def)^.filetyp = ft_untyped) and (pfiledef(left.resulttype)^.filetyp = ft_typed) ) and not(is_equal(left.resulttype,defcoll.paratype.def))) then begin CGMessagePos2(left.fileinfo,parser_e_call_by_ref_without_typeconv, left.resulttype^.typename,defcoll.paratype.def^.typename); end; { Process open parameters } if push_high_param(defcoll.paratype.def) then begin { insert type conv but hold the ranges of the array } oldtype:=left.resulttype; left:=gentypeconvnode(left,defcoll.paratype.def); firstpass(left); left.resulttype:=oldtype; end else begin left:=gentypeconvnode(left,defcoll.paratype.def); firstpass(left); 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) and is_shortstring(defcoll.paratype.def) and (defcoll.paratyp in [vs_out,vs_var]) and not(is_open_string(defcoll.paratype.def)) and not(is_equal(left.resulttype,defcoll.paratype.def)) then begin aktfilepos:=left.fileinfo; CGMessage(type_e_strict_var_string_violation); end; { variabls for call by reference may not be copied } { into a register } { is this usefull here ? } { this was missing in formal parameter list } if (defcoll.paratype.def=pdef(cformaldef)) then begin if defcoll.paratyp in [vs_var,vs_out] then begin if not valid_for_formal_var(left) then begin aktfilepos:=left.fileinfo; CGMessage(parser_e_illegal_parameter_list); end; end; if defcoll.paratyp=vs_const then begin if not valid_for_formal_const(left) then begin aktfilepos:=left.fileinfo; CGMessage(parser_e_illegal_parameter_list); end; end; end; if defcoll.paratyp in [vs_var,vs_const] then begin { Causes problems with const ansistrings if also } { done for vs_const (JM) } if defcoll.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 defcoll.paratyp=vs_out then make_not_regable(left); if do_count then set_varstate(left,not(defcoll.paratyp in [vs_var,vs_out])); { must only be done after typeconv PM } resulttype:=defcoll.paratype.def; end; 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} dec(parsing_para_level); {$ifdef extdebug} if do_count then count_ref:=store_count_ref; {$endif def extdebug} end; procedure tcallparanode.gen_high_tree(openstring:boolean); var len : longint; st : psymtable; loadconst : boolean; begin if assigned(hightree) then exit; len:=-1; loadconst:=true; case left.resulttype^.deftype of arraydef : begin if is_open_array(left.resulttype) or is_array_of_const(left.resulttype) then begin st:=tloadnode(left).symtable; getsymonlyin(st,'high'+pvarsym(tloadnode(left).symtableentry)^.name); hightree:=genloadnode(pvarsym(srsym),st); loadconst:=false; end else begin { this is an empty constructor } len:=parraydef(left.resulttype)^.highrange- parraydef(left.resulttype)^.lowrange; end; end; stringdef : begin if openstring then begin if is_open_string(left.resulttype) then begin st:=tloadnode(left).symtable; getsymonlyin(st,'high'+pvarsym(tloadnode(left).symtableentry)^.name); hightree:=genloadnode(pvarsym(srsym),st); loadconst:=false; end else len:=pstringdef(left.resulttype)^.len; end else { passing a string to an array of char } begin if (left.nodetype=stringconstn) then begin len:=str_length(left); if len>0 then dec(len); end else begin hightree:=caddnode.create(subn,geninlinenode(in_length_string,false,left.getcopy), genordinalconstnode(1,s32bitdef)); firstpass(hightree); hightree:=gentypeconvnode(hightree,s32bitdef); loadconst:=false; end; end; end; else len:=0; end; if loadconst then hightree:=genordinalconstnode(len,s32bitdef); firstpass(hightree); end; function tcallparanode.docompare(p: tnode): boolean; begin docompare := inherited docompare(p) and (callparaflags = tcallparanode(p).callparaflags) and hightree.isequal(tcallparanode(p).hightree); end; {**************************************************************************** TCALLNODE ****************************************************************************} constructor tcallnode.create(v : pprocsym;st : psymtable; mp : tnode); begin inherited create(calln,nil,nil); symtableprocentry:=v; symtableproc:=st; include(flags,nf_return_value_used); methodpointer:=mp; procdefinition:=nil; end; destructor tcallnode.destroy; begin methodpointer.free; inherited destroy; end; function tcallnode.getcopy : tnode; var n : tcallnode; begin n:=tcallnode(inherited getcopy); n.symtableprocentry:=symtableprocentry; n.symtableproc:=symtableproc; n.procdefinition:=procdefinition; if assigned(methodpointer) then n.methodpointer:=methodpointer.getcopy else n.methodpointer:=nil; result:=n; end; procedure tcallnode.insertintolist(l : tnodelist); begin end; function tcallnode.pass_1 : tnode; type pprocdefcoll = ^tprocdefcoll; tprocdefcoll = record data : pprocdef; nextpara : tparaitem; firstpara : tparaitem; next : pprocdefcoll; end; var hp,procs,hp2 : pprocdefcoll; pd : pprocdef; oldcallprocsym : pprocsym; def_from,def_to,conv_to : pdef; hpt,hpt2,inlinecode : tnode; pt : tcallparanode; exactmatch,inlined : boolean; paralength,lastpara : longint; lastparatype : pdef; pdc : tparaitem; {$ifdef TEST_PROCSYMS} nextprocsym : pprocsym; symt : psymtable; {$endif TEST_PROCSYMS} { only Dummy } hcvt : tconverttype; {$ifdef m68k} regi : tregister; {$endif} method_must_be_valid : boolean; label errorexit; { check if the resulttype from tree p is equal with def, needed for stringconstn and formaldef } function is_equal(p:tcallparanode;def:pdef) : boolean; begin { safety check } if not (assigned(def) or assigned(p.resulttype)) then begin is_equal:=false; exit; end; { all types can be passed to a formaldef } is_equal:=(def^.deftype=formaldef) or (types.is_equal(p.resulttype,def)) { integer constants are compatible with all integer parameters if the specified value matches the range } or ( (tbinarynode(p).left.nodetype=ordconstn) and is_integer(p.resulttype) and is_integer(def) and (tordconstnode(p.left).value>=porddef(def)^.low) and (tordconstnode(p.left).value<=porddef(def)^.high) ) { to support ansi/long/wide strings in a proper way } { string and string[10] are assumed as equal } { when searching the correct overloaded procedure } or ( (def^.deftype=stringdef) and (p.resulttype^.deftype=stringdef) and (pstringdef(def)^.string_typ=pstringdef(p.resulttype)^.string_typ) ) or ( (p.left.nodetype=stringconstn) and (is_ansistring(p.resulttype) and is_pchar(def)) ) or ( (p.left.nodetype=ordconstn) and (is_char(p.resulttype) and (is_shortstring(def) or is_ansistring(def))) ) { set can also be a not yet converted array constructor } or ( (def^.deftype=setdef) and (p.resulttype^.deftype=arraydef) and (parraydef(p.resulttype)^.IsConstructor) and not(parraydef(p.resulttype)^.IsVariant) ) { in tp7 mode proc -> procvar is allowed } or ( (m_tp_procvar in aktmodeswitches) and (def^.deftype=procvardef) and (p.left.nodetype=calln) and (proc_to_procvar_equal(pprocdef(tcallnode(p.left).procdefinition),pprocvardef(def))) ) ; end; function is_in_limit(def_from,def_to : pdef) : boolean; begin is_in_limit:=(def_from^.deftype = orddef) and (def_to^.deftype = orddef) and (porddef(def_from)^.low>porddef(def_to)^.low) and (porddef(def_from)^.highnil then we called firstpass already } { it seems to be bad because of the registers } { at least we can avoid the overloaded search !! } procs:=nil; { made this global for disposing !! } oldcallprocsym:=aktcallprocsym; aktcallprocsym:=nil; inlined:=false; if assigned(procdefinition) and (pocall_inline in procdefinition^.proccalloptions) then begin inlinecode:=right; if assigned(inlinecode) then begin inlined:=true; exclude(procdefinition^.proccalloptions,pocall_inline); end; right:=nil; end; if assigned(procdefinition) and (po_containsself in procdefinition^.procoptions) then message(cg_e_cannot_call_message_direct); { procedure variable ? } if assigned(right) then begin { procedure does a call } if not (block_type in [bt_const,bt_type]) then procinfo^.flags:=procinfo^.flags or pi_do_call; {$ifndef newcg} { calc the correture value for the register } {$ifdef i386} incrementregisterpushed($ff); {$endif} {$ifdef m68k} for regi:=R_D0 to R_A6 do inc(reg_pushes[regi],t_times*2); {$endif} {$endif newcg} { calculate the type of the parameters } if assigned(left) then begin tcallparanode(left).firstcallparan(nil,false); if codegenerror then goto errorexit; end; firstpass(right); set_varstate(right,true); { check the parameters } pdc:=tparaitem(pprocvardef(right.resulttype)^.Para.first); pt:=tcallparanode(left); while assigned(pdc) and assigned(pt) do begin pt:=tcallparanode(pt.right); pdc:=tparaitem(pdc.next); end; if assigned(pt) or assigned(pdc) then begin if assigned(pt) then aktfilepos:=pt.fileinfo; CGMessage(parser_e_illegal_parameter_list); end; { insert type conversions } if assigned(left) then begin tcallparanode(left).firstcallparan(tparaitem(pprocvardef(right.resulttype)^.Para.first),true); if codegenerror then goto errorexit; end; resulttype:=pprocvardef(right.resulttype)^.rettype.def; { this was missing, leads to a bug below if the procvar is a function } procdefinition:=pabstractprocdef(right.resulttype); end else { not a procedure variable } begin { determine the type of the parameters } if assigned(left) then begin tcallparanode(left).firstcallparan(nil,false); if codegenerror then goto errorexit; end; aktcallprocsym:=pprocsym(symtableprocentry); { do we know the procedure to call ? } if not(assigned(procdefinition)) then begin {$ifdef TEST_PROCSYMS} if (unit_specific) or assigned(methodpointer) then nextprocsym:=nil else while not assigned(procs) do begin symt:=symtableproc; srsym:=nil; while assigned(symt^.next) and not assigned(srsym) do begin symt:=symt^.next; getsymonlyin(symt,actprocsym^.name); if assigned(srsym) then if srsym^.typ<>procsym then begin { reject all that is not a procedure } srsym:=nil; { don't search elsewhere } while assigned(symt^.next) do symt:=symt^.next; end; end; nextprocsym:=srsym; end; {$endif TEST_PROCSYMS} { determine length of parameter list } pt:=tcallparanode(left); paralength:=0; while assigned(pt) do begin inc(paralength); pt:=tcallparanode(pt.right); end; { link all procedures which have the same # of parameters } pd:=aktcallprocsym^.definition; while assigned(pd) do begin { only when the # of parameter are supported by the procedure } if (paralength>=pd^.minparacount) and (paralength<=pd^.maxparacount) then begin new(hp); hp^.data:=pd; hp^.next:=procs; hp^.firstpara:=tparaitem(pd^.Para.first); { if not all parameters are given, then skip the default parameters } for i:=1 to pd^.maxparacount-paralength do hp^.firstpara:=tparaitem(hp^.firstPara.next); hp^.nextpara:=hp^.firstpara; procs:=hp; end; pd:=pd^.nextoverloaded; end; { no procedures found? then there is something wrong with the parameter size } if not assigned(procs) then begin { in tp mode we can try to convert to procvar if there are no parameters specified } if not(assigned(left)) and (m_tp_procvar in aktmodeswitches) then begin if (symtableprocentry^.owner^.symtabletype=objectsymtable) and assigned(methodpointer) { and is_class(pdef(symtableprocentry^.owner^.defowner))} then hpt:=genloadmethodcallnode(pprocsym(symtableprocentry),symtableproc, methodpointer.getcopy) else hpt:=genloadcallnode(pprocsym(symtableprocentry),symtableproc); firstpass(hpt); pass_1:=hpt; end else begin if assigned(left) then aktfilepos:=left.fileinfo; CGMessage(parser_e_wrong_parameter_size); aktcallprocsym^.write_parameter_lists(nil); end; goto errorexit; end; { now we can compare parameter after parameter } pt:=tcallparanode(left); { we start with the last parameter } lastpara:=paralength+1; lastparatype:=nil; while assigned(pt) do begin dec(lastpara); { walk all procedures and determine how this parameter matches and set: 1. pt.exact_match_found if one parameter has an exact match 2. exactmatch if an equal or exact match is found 3. Para.argconvtyp to exact,equal or convertable (when convertable then also convertlevel is set) 4. pt.convlevel1found if there is a convertlevel=1 5. pt.convlevel2found if there is a convertlevel=2 } exactmatch:=false; hp:=procs; while assigned(hp) do begin if is_equal(pt,hp^.nextPara.paratype.def) then begin if hp^.nextPara.paratype.def=pt.resulttype then begin include(pt.callparaflags,cpf_exact_match_found); hp^.nextPara.argconvtyp:=act_exact; end else hp^.nextPara.argconvtyp:=act_equal; exactmatch:=true; end else begin hp^.nextPara.argconvtyp:=act_convertable; hp^.nextPara.convertlevel:=isconvertable(pt.resulttype,hp^.nextPara.paratype.def, hcvt,pt.left,pt.left.nodetype,false); case hp^.nextPara.convertlevel of 1 : include(pt.callparaflags,cpf_convlevel1found); 2 : include(pt.callparaflags,cpf_convlevel2found); end; end; hp:=hp^.next; end; { If there was an exactmatch then delete all convertables } if exactmatch then begin hp:=procs; procs:=nil; while assigned(hp) do begin hp2:=hp^.next; { keep if not convertable } if (hp^.nextPara.argconvtyp<>act_convertable) then begin hp^.next:=procs; procs:=hp; end else dispose(hp); hp:=hp2; end; end else { No exact match was found, remove all procedures that are not convertable (convertlevel=0) } begin hp:=procs; procs:=nil; while assigned(hp) do begin hp2:=hp^.next; { keep if not convertable } if (hp^.nextPara.convertlevel<>0) then begin hp^.next:=procs; procs:=hp; end else begin { save the type for nice error message } lastparatype:=hp^.nextPara.paratype.def; dispose(hp); end; hp:=hp2; end; end; { update nextpara for all procedures } hp:=procs; while assigned(hp) do begin hp^.nextpara:=tparaitem(hp^.nextPara.next); hp:=hp^.next; end; { load next parameter or quit loop if no procs left } if assigned(procs) then pt:=tcallparanode(pt.right) else break; end; { All parameters are checked, check if there are any procedures left } if not assigned(procs) then begin { there is an error, must be wrong type, because wrong size is already checked (PFV) } if (not assigned(lastparatype)) or (not assigned(pt)) or (not assigned(pt.resulttype)) then internalerror(39393) else begin aktfilepos:=pt.fileinfo; CGMessage3(type_e_wrong_parameter_type,tostr(lastpara), pt.resulttype^.typename,lastparatype^.typename); end; aktcallprocsym^.write_parameter_lists(nil); goto errorexit; end; { if there are several choices left then for orddef } { if a type is totally included in the other } { we don't fear an overflow , } { so we can do as if it is an exact match } { this will convert integer to longint } { rather than to words } { conversion of byte to integer or longint } {would still not be solved } if assigned(procs) and assigned(procs^.next) then begin hp:=procs; while assigned(hp) do begin hp^.nextpara:=hp^.firstpara; hp:=hp^.next; end; pt:=tcallparanode(left); while assigned(pt) do begin { matches a parameter of one procedure exact ? } exactmatch:=false; def_from:=pt.resulttype; hp:=procs; while assigned(hp) do begin if not is_equal(pt,hp^.nextPara.paratype.def) then begin def_to:=hp^.nextPara.paratype.def; if ((def_from^.deftype=orddef) and (def_to^.deftype=orddef)) and (is_in_limit(def_from,def_to) or ((hp^.nextPara.paratyp in [vs_var,vs_out]) and (def_from^.size=def_to^.size))) then begin exactmatch:=true; conv_to:=def_to; end; end; hp:=hp^.next; end; { .... if yes, del all the other procedures } if exactmatch then begin { the first .... } while (assigned(procs)) and not(is_in_limit(def_from,procs^.nextPara.paratype.def)) do begin hp:=procs^.next; dispose(procs); procs:=hp; end; { and the others } hp:=procs; while (assigned(hp)) and assigned(hp^.next) do begin if not(is_in_limit(def_from,hp^.next^.nextPara.paratype.def)) then begin hp2:=hp^.next^.next; dispose(hp^.next); hp^.next:=hp2; end else begin def_to:=hp^.next^.nextPara.paratype.def; if (conv_to^.size>def_to^.size) or ((porddef(conv_to)^.lowporddef(def_to)^.high)) then begin hp2:=procs; procs:=hp; conv_to:=def_to; dispose(hp2); end else hp:=hp^.next; end; end; end; { update nextpara for all procedures } hp:=procs; while assigned(hp) do begin hp^.nextpara:=tparaitem(hp^.nextPara.next); hp:=hp^.next; end; pt:=tcallparanode(pt.right); end; end; { let's try to eliminate equal if there is an exact match is there } if assigned(procs) and assigned(procs^.next) then begin { reset nextpara for all procs left } hp:=procs; while assigned(hp) do begin hp^.nextpara:=hp^.firstpara; hp:=hp^.next; end; pt:=tcallparanode(left); while assigned(pt) do begin if cpf_exact_match_found in pt.callparaflags then begin hp:=procs; procs:=nil; while assigned(hp) do begin hp2:=hp^.next; { keep the exact matches, dispose the others } if (hp^.nextPara.argconvtyp=act_exact) then begin hp^.next:=procs; procs:=hp; end else dispose(hp); hp:=hp2; end; end; { update nextpara for all procedures } hp:=procs; while assigned(hp) do begin hp^.nextpara:=tparaitem(hp^.nextPara.next); hp:=hp^.next; end; pt:=tcallparanode(pt.right); end; end; { Check if there are integer constant to integer parameters then choose the best matching integer parameter and remove the others, this is Delphi compatible. 1 = byte, 256 = word, etc. } if assigned(procs) and assigned(procs^.next) then begin { reset nextpara for all procs left } hp:=procs; while assigned(hp) do begin hp^.nextpara:=hp^.firstpara; hp:=hp^.next; end; pt:=tcallparanode(left); while assigned(pt) do begin bestord:=nil; if (pt.left.nodetype=ordconstn) and is_integer(pt.resulttype) then begin hp:=procs; while assigned(hp) do begin def_to:=hp^.nextPara.paratype.def; { to be sure, it couldn't be something else, also the defs here are all in the range so now find the closest range } if not is_integer(def_to) then internalerror(43297815); if (not assigned(bestord)) or ((porddef(def_to)^.low>bestord^.low) or (porddef(def_to)^.highact_convertable) or (hp^.nextPara.convertlevel=1) then begin hp^.next:=procs; procs:=hp; end else dispose(hp); hp:=hp2; end; end; { update nextpara for all procedures } hp:=procs; while assigned(hp) do begin hp^.nextpara:=tparaitem(hp^.nextPara.next); hp:=hp^.next; end; pt:=tcallparanode(pt.right); end; end; if not(assigned(procs)) or assigned(procs^.next) then begin CGMessage(cg_e_cant_choose_overload_function); aktcallprocsym^.write_parameter_lists(nil); goto errorexit; end; {$ifdef TEST_PROCSYMS} if (procs=nil) and assigned(nextprocsym) then begin symtableprocentry:=nextprocsym; symtableproc:=symt; end; end ; { of while assigned(symtableprocentry) do } {$endif TEST_PROCSYMS} if make_ref then begin procs^.data^.lastref:=new(pref,init(procs^.data^.lastref,@fileinfo)); inc(procs^.data^.refcount); if procs^.data^.defref=nil then procs^.data^.defref:=procs^.data^.lastref; end; procdefinition:=procs^.data; resulttype:=procs^.data^.rettype.def; { big error for with statements symtableproc:=procdefinition^.owner; but neede for overloaded operators !! } if symtableproc=nil then symtableproc:=procdefinition^.owner; location.loc:=LOC_MEM; {$ifdef CHAINPROCSYMS} { object with method read; call to read(x) will be a usual procedure call } if assigned(methodpointer) and (procdefinition^._class=nil) then begin { not ok for extended } case methodpointer^.nodetype of typen,hnewn : fatalerror(no_para_match); end; methodpointer.free; methodpointer:=nil; end; {$endif CHAINPROCSYMS} end; { end of procedure to call determination } is_const:=(pocall_internconst in procdefinition^.proccalloptions) and ((block_type in [bt_const,bt_type]) or (assigned(left) and (tcallparanode(left).left.nodetype in [realconstn,ordconstn]))); { handle predefined procedures } if (pocall_internproc in procdefinition^.proccalloptions) or is_const then begin if assigned(left) then begin hpt2:=left; left:=nil; { ptr and settextbuf needs two args } if assigned(tcallparanode(hpt2).right) then hpt:=geninlinenode(pprocdef(procdefinition)^.extnumber,is_const,hpt2) else hpt:=geninlinenode(pprocdef(procdefinition)^.extnumber,is_const,tcallparanode(hpt2).left); end else hpt:=geninlinenode(pprocdef(procdefinition)^.extnumber,is_const,nil); firstpass(hpt); pass_1:=hpt; goto errorexit; end else { no intern procedure => we do a call } { calc the correture value for the register } { handle predefined procedures } if (pocall_inline in procdefinition^.proccalloptions) then begin if assigned(methodpointer) then CGMessage(cg_e_unable_inline_object_methods); if assigned(right) and (right.nodetype<>procinlinen) then CGMessage(cg_e_unable_inline_procvar); { nodetype:=procinlinen; } if not assigned(right) then begin if assigned(pprocdef(procdefinition)^.code) then inlinecode:=genprocinlinenode(self,tnode(pprocdef(procdefinition)^.code)) else CGMessage(cg_e_no_code_for_inline_stored); if assigned(inlinecode) then begin { consider it has not inlined if called again inside the args } exclude(procdefinition^.proccalloptions,pocall_inline); firstpass(inlinecode); inlined:=true; end; end; end else begin if not (block_type in [bt_const,bt_type]) then procinfo^.flags:=procinfo^.flags or pi_do_call; end; { add needed default parameters } if assigned(procs) and (paralength0 then inc(reg_pushes[regi],t_times*2); end; {$endif} {$endif newcg} end; { ensure that the result type is set } resulttype:=procdefinition^.rettype.def; { get a register for the return value } if (resulttype<>pdef(voiddef)) then begin if (procdefinition^.proctypeoption=potype_constructor) then begin { extra handling of classes } { methodpointer should be assigned! } if assigned(methodpointer) and assigned(methodpointer.resulttype) and (methodpointer.resulttype^.deftype=classrefdef) then begin location.loc:=LOC_REGISTER; registers32:=1; { the result type depends on the classref } resulttype:=pclassrefdef(methodpointer.resulttype)^.pointertype.def; end { a object constructor returns the result with the flags } else location.loc:=LOC_FLAGS; end else begin {$ifdef SUPPORT_MMX} if (cs_mmx in aktlocalswitches) and is_mmx_able_array(resulttype) then begin location.loc:=LOC_MMXREGISTER; registersmmx:=1; end else {$endif SUPPORT_MMX} if ret_in_acc(resulttype) then begin location.loc:=LOC_REGISTER; if is_64bitint(resulttype) then registers32:=2 else registers32:=1; { wide- and ansistrings are returned in EAX } { but they are imm. moved to a memory location } if is_widestring(resulttype) or is_ansistring(resulttype) then begin location.loc:=LOC_MEM; { this is wrong we still need one register PM registers32:=0; } { we use ansistrings so no fast exit here } procinfo^.no_fast_exit:=true; registers32:=1; end; end else if (resulttype^.deftype=floatdef) then begin location.loc:=LOC_FPU; registersfpu:=1; end else location.loc:=LOC_MEM; end; end; { a fpu can be used in any procedure !! } registersfpu:=procdefinition^.fpu_used; { if this is a call to a method calc the registers } if (methodpointer<>nil) then begin case methodpointer.nodetype of { but only, if this is not a supporting node } typen: ; { we need one register for new return value PM } hnewn : if registers32=0 then registers32:=1; else begin if (procdefinition^.proctypeoption in [potype_constructor,potype_destructor]) and assigned(symtableproc) and (symtableproc^.symtabletype=withsymtable) and not pwithsymtable(symtableproc)^.direct_with then begin CGmessage(cg_e_cannot_call_cons_dest_inside_with); end; { Is accepted by Delphi !! } { this is not a good reason to accept it in FPC if we produce wrong code for it !!! (PM) } { R.Assign is not a constructor !!! } { but for R^.Assign, R must be valid !! } if (procdefinition^.proctypeoption=potype_constructor) or ((methodpointer.nodetype=loadn) and (not(oo_has_virtual in pobjectdef(methodpointer.resulttype)^.objectoptions))) then method_must_be_valid:=false else method_must_be_valid:=true; firstpass(methodpointer); set_varstate(methodpointer,method_must_be_valid); { The object is already used ven if it is called once } if (methodpointer.nodetype=loadn) and (tloadnode(methodpointer).symtableentry^.typ=varsym) then pvarsym(tloadnode(methodpointer).symtableentry)^.varstate:=vs_used; registersfpu:=max(methodpointer.registersfpu,registersfpu); registers32:=max(methodpointer.registers32,registers32); {$ifdef SUPPORT_MMX} registersmmx:=max(methodpointer.registersmmx,registersmmx); {$endif SUPPORT_MMX} end; end; end; if inlined then right:=inlinecode; { determine the registers of the procedure variable } { is this OK for inlined procs also ?? (PM) } if assigned(right) then begin registersfpu:=max(right.registersfpu,registersfpu); registers32:=max(right.registers32,registers32); {$ifdef SUPPORT_MMX} registersmmx:=max(right.registersmmx,registersmmx); {$endif SUPPORT_MMX} end; { determine the registers of the procedure } if assigned(left) then begin registersfpu:=max(left.registersfpu,registersfpu); registers32:=max(left.registers32,registers32); {$ifdef SUPPORT_MMX} registersmmx:=max(left.registersmmx,registersmmx); {$endif SUPPORT_MMX} end; errorexit: { Reset some settings back } if assigned(procs) then dispose(procs); if inlined then include(procdefinition^.proccalloptions,pocall_inline); aktcallprocsym:=oldcallprocsym; end; function tcallnode.docompare(p: tnode): boolean; begin docompare := inherited docompare(p) and (symtableprocentry = tcallnode(p).symtableprocentry) and (symtableproc = tcallnode(p).symtableproc) and (procdefinition = tcallnode(p).procdefinition) and (methodpointer = tcallnode(p).methodpointer); end; {**************************************************************************** TPROCINLINENODE ****************************************************************************} constructor tprocinlinenode.create(callp,code : tnode); begin inherited create(procinlinen); inlineprocsym:=tcallnode(callp).symtableprocentry; retoffset:=-4; { less dangerous as zero (PM) } para_offset:=0; para_size:=inlineprocsym^.definition^.para_size(target_os.stackalignment); if ret_in_param(inlineprocsym^.definition^.rettype.def) then para_size:=para_size+target_os.size_of_pointer; { copy args } if assigned(code) then inlinetree:=code.getcopy else inlinetree := nil; registers32:=code.registers32; registersfpu:=code.registersfpu; {$ifdef SUPPORT_MMX} registersmmx:=code.registersmmx; {$endif SUPPORT_MMX} resulttype:=inlineprocsym^.definition^.rettype.def; end; destructor tprocinlinenode.destroy; begin if assigned(inlinetree) then inlinetree.free; inherited destroy; end; function tprocinlinenode.getcopy : tnode; var n : tprocinlinenode; begin n:=tprocinlinenode(inherited getcopy); if assigned(inlinetree) then n.inlinetree:=inlinetree.getcopy else n.inlinetree:=nil; n.inlineprocsym:=inlineprocsym; n.retoffset:=retoffset; n.para_offset:=para_offset; n.para_size:=para_size; getcopy:=n; end; procedure tprocinlinenode.insertintolist(l : tnodelist); begin end; function tprocinlinenode.pass_1 : tnode; begin pass_1:=nil; { left contains the code in tree form } { but it has already been firstpassed } { so firstpass(left); does not seem required } { might be required later if we change the arg handling !! } end; function tprocinlinenode.docompare(p: tnode): boolean; begin docompare := inherited docompare(p) and inlinetree.isequal(tprocinlinenode(p).inlinetree) and (inlineprocsym = tprocinlinenode(p).inlineprocsym); end; begin ccallnode:=tcallnode; ccallparanode:=tcallparanode; cprocinlinenode:=tprocinlinenode; end. { $Log$ Revision 1.22 2001-01-08 21:46:46 peter * don't push high value for open array with cdecl;external; Revision 1.21 2000/12/31 11:14:10 jonas + implemented/fixed docompare() mathods for all nodes (not tested) + nopt.pas, nadd.pas, i386/n386opt.pas: optimized nodes for adding strings and constant strings/chars together * n386add.pas: don't copy temp strings (of size 256) to another temp string when adding Revision 1.20 2000/12/25 00:07:26 peter + new tlinkedlist class (merge of old tstringqueue,tcontainer and tlinkedlist objects) Revision 1.19 2000/12/17 14:35:12 peter * fixed crash with procvar load in tp mode Revision 1.18 2000/11/29 00:30:32 florian * unused units removed from uses clause * some changes for widestrings Revision 1.17 2000/11/22 15:12:06 jonas * fixed inline-related problems (partially "merges") Revision 1.16 2000/11/11 16:14:52 peter * fixed crash with settextbuf,ptr Revision 1.15 2000/11/06 21:36:25 peter * fixed var parameter varstate bug Revision 1.14 2000/11/04 14:25:20 florian + merged Attila's changes for interfaces, not tested yet Revision 1.13 2000/10/31 22:02:47 peter * symtable splitted, no real code changes Revision 1.12 2000/10/21 18:16:11 florian * a lot of changes: - basic dyn. array support - basic C++ support - some work for interfaces done .... Revision 1.11 2000/10/21 14:35:27 peter * readd to many remove p. for tcallnode.is_equal() Revision 1.10 2000/10/14 21:52:55 peter * fixed memory leaks Revision 1.9 2000/10/14 10:14:50 peter * moehrendorf oct 2000 rewrite Revision 1.8 2000/10/01 19:48:24 peter * lot of compile updates for cg11 Revision 1.7 2000/09/28 19:49:52 florian *** empty log message *** Revision 1.6 2000/09/27 18:14:31 florian * fixed a lot of syntax errors in the n*.pas stuff Revision 1.5 2000/09/24 21:15:34 florian * some errors fix to get more stuff compilable Revision 1.4 2000/09/24 20:17:44 florian * more conversion work done Revision 1.3 2000/09/24 15:06:19 peter * use defines.inc Revision 1.2 2000/09/20 21:52:38 florian * removed a lot of errors Revision 1.1 2000/09/20 20:52:16 florian * initial revision }