diff --git a/compiler/browlog.pas b/compiler/browlog.pas index 06bf2ff77e..f6ab2e1f5d 100644 --- a/compiler/browlog.pas +++ b/compiler/browlog.pas @@ -409,6 +409,25 @@ implementation dec(identidx,2); end; + procedure writesymtable(p:Tsymtable);forward; + + procedure writelocalsymtables(p:Tprocdef;arg:pointer); + + begin + if assigned(p.defref) then + begin + browserlog.AddLog('***'+p.mangledname); + browserlog.AddLogRefs(p.defref); + if (current_module.flags and uf_local_browser)<>0 then + begin + if assigned(p.parast) then + writesymtable(p.parast); + if assigned(p.localst) then + writesymtable(p.localst); + end; + end; + end; + procedure writesymtable(p:tsymtable); var @@ -445,25 +464,7 @@ implementation writesymtable(tobjectdef(ttypesym(hp).restype.def).symtable); end; procsym : - begin - prdef:=tprocsym(hp).defs; - while assigned(prdef) do - begin - if assigned(prdef^.def.defref) then - begin - browserlog.AddLog('***'+prdef^.def.mangledname); - browserlog.AddLogRefs(prdef^.def.defref); - if (current_module.flags and uf_local_browser)<>0 then - begin - if assigned(prdef^.def.parast) then - writesymtable(prdef^.def.parast); - if assigned(prdef^.def.localst) then - writesymtable(prdef^.def.localst); - end; - end; - prdef:=prdef^.next; - end; - end; + Tprocsym(hp).foreach_procdef_static({$IFDEF FPCPROCVAR}@{$ENDIF}writelocalsymtables,nil); end; hp:=tstoredsym(hp.indexnext); end; @@ -514,7 +515,10 @@ implementation end. { $Log$ - Revision 1.14 2002-07-23 09:51:22 daniel + Revision 1.15 2002-08-20 10:31:26 daniel + * Tcallnode.det_resulttype rewritten + + Revision 1.14 2002/07/23 09:51:22 daniel * Tried to make Tprocsym.defs protected. I didn't succeed but the cleanups are worth comitting. diff --git a/compiler/defbase.pas b/compiler/defbase.pas index 82b1009a65..e2f4c81ab5 100644 --- a/compiler/defbase.pas +++ b/compiler/defbase.pas @@ -1863,6 +1863,10 @@ implementation b:=2; end; end; + formaldef: + {Just about everything can be converted to a formaldef...} + if not (def_from.deftype in [abstractdef,errordef]) then + b:=1; else begin { assignment overwritten ?? } @@ -1903,7 +1907,10 @@ implementation end. { $Log$ - Revision 1.5 2002-08-12 20:39:17 florian + Revision 1.6 2002-08-20 10:31:26 daniel + * Tcallnode.det_resulttype rewritten + + Revision 1.5 2002/08/12 20:39:17 florian * casting of classes to interface fixed when the interface was implemented by a parent class diff --git a/compiler/ncal.pas b/compiler/ncal.pas index 7095afc91e..7ab29ac267 100644 --- a/compiler/ncal.pas +++ b/compiler/ncal.pas @@ -68,6 +68,9 @@ interface function getcopy : tnode;override; procedure insertintolist(l : tnodelist);override; function pass_1 : tnode;override; + {$ifdef nice_ncal} + function choose_definition_to_call(paralength:byte;var errorexit:boolean):Tnode; + {$endif} function det_resulttype:tnode;override; {$ifdef state_tracking} function track_state_pass(exec_known:boolean):boolean;override; @@ -83,6 +86,9 @@ interface cpf_convlevel1found, cpf_convlevel2found, cpf_is_colon_para +{$ifdef nice_ncal} + ,cpf_nomatchfound +{$endif} ); tcallparanode = class(tbinarynode) @@ -174,8 +180,7 @@ implementation speedvalue : cardinal; srsym : tprocsym; s : string; - found : boolean; - srpdl,pdl : pprocdeflist; + srpdl : pprocdeflist; objdef : tobjectdef; begin if aprocsym.overloadchecked then @@ -199,24 +204,7 @@ implementation internalerror(200111022); if srsym.is_visible_for_proc(aktprocdef) then begin - srpdl:=srsym.defs; - while assigned(srpdl) do - begin - found:=false; - pdl:=aprocsym.defs; - while assigned(pdl) do - begin - if equal_paras(pdl^.def.para,srpdl^.def.para,cp_value_equal_const) then - begin - found:=true; - break; - end; - pdl:=pdl^.next; - end; - if not found then - aprocsym.addprocdef(srpdl^.def); - srpdl:=srpdl^.next; - end; + srsym.add_para_match_to(Aprocsym); { we can stop if the overloads were already added for the found symbol } if srsym.overloadchecked then @@ -319,6 +307,48 @@ implementation end; + function is_var_para_incompatible(from_def,to_def:Tdef):boolean; + + {Might be an idea to move this to defbase...} + + begin + is_var_para_incompatible:= + { allows conversion from word to integer and + byte to shortint, but only for TP7 compatibility } + (not( + (m_tp7 in aktmodeswitches) and + (from_def.deftype=orddef) and + (to_def.deftype=orddef) and + (from_def.size=to_def.size) + ) and + { an implicit pointer conversion is allowed } + not( + (from_def.deftype=pointerdef) and + (to_def.deftype=pointerdef) + ) and + { child classes can be also passed } + not( + (from_def.deftype=objectdef) and + (to_def.deftype=objectdef) and + tobjectdef(from_def).is_related(tobjectdef(to_def)) + ) and + { passing a single element to a openarray of the same type } + not( + (is_open_array(to_def) and + is_equal(tarraydef(to_def).elementtype.def,from_def)) + ) and + { an implicit file conversion is also allowed } + { from a typed file to an untyped one } + not( + (from_def.deftype=filedef) and + (to_def.deftype=filedef) and + (tfiledef(to_def).filetyp = ft_untyped) and + (tfiledef(from_def).filetyp = ft_typed) + ) and + not(is_equal(from_def,to_def))); + + end; + procedure tcallparanode.insert_typeconv(defcoll : tparaitem;do_count : boolean); var oldtype : ttype; @@ -414,39 +444,7 @@ implementation (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, but only for TP7 compatibility } - (not( - (m_tp7 in aktmodeswitches) and - (left.resulttype.def.deftype=orddef) and - (defcoll.paratype.def.deftype=orddef) and - (left.resulttype.def.size=defcoll.paratype.def.size) - ) and - { an implicit pointer conversion is allowed } - not( - (left.resulttype.def.deftype=pointerdef) and - (defcoll.paratype.def.deftype=pointerdef) - ) and - { child classes can be also passed } - not( - (left.resulttype.def.deftype=objectdef) and - (defcoll.paratype.def.deftype=objectdef) and - tobjectdef(left.resulttype.def).is_related(tobjectdef(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(tarraydef(defcoll.paratype.def).elementtype.def,left.resulttype.def)) - ) and - { an implicit file conversion is also allowed } - { from a typed file to an untyped one } - not( - (left.resulttype.def.deftype=filedef) and - (defcoll.paratype.def.deftype=filedef) and - (tfiledef(defcoll.paratype.def).filetyp = ft_untyped) and - (tfiledef(left.resulttype.def).filetyp = ft_typed) - ) and - not(is_equal(left.resulttype.def,defcoll.paratype.def))) then + is_var_para_incompatible(left.resulttype.def,defcoll.paratype.def) then begin CGMessagePos2(left.fileinfo,parser_e_call_by_ref_without_typeconv, left.resulttype.def.typename,defcoll.paratype.def.typename); @@ -717,7 +715,7 @@ implementation 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) xor paramanager.ret_in_param(symtableprocentry.defs^.def.rettype.def) then + if paramanager.ret_in_param(restype.def) xor paramanager.ret_in_param(symtableprocentry.first_procdef.rettype.def) then internalerror(200108291); end; @@ -726,7 +724,7 @@ implementation begin self.createintern(name,params); funcretrefnode:=returnnode; - if not paramanager.ret_in_param(symtableprocentry.defs^.def.rettype.def) then + if not paramanager.ret_in_param(symtableprocentry.first_procdef.rettype.def) then internalerror(200204247); end; @@ -807,7 +805,573 @@ implementation begin end; +{$ifdef nice_ncal} + function Tcallnode.choose_definition_to_call(paralength:byte;var errorexit:boolean):Tnode; + + { check if the resulttype.def from tree p is equal with def, needed + for stringconstn and formaldef } + function is_equal(p:tcallparanode;def:tdef) : boolean; + + begin + { safety check } + if not (assigned(def) or assigned(p.resulttype.def)) then + begin + is_equal:=false; + exit; + end; + { all types can be passed to a formaldef } + is_equal:=(def.deftype=formaldef) or + (defbase.is_equal(p.resulttype.def,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.def) and + is_integer(def) and + (tordconstnode(p.left).value>=torddef(def).low) and + (tordconstnode(p.left).value<=torddef(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.def.deftype=stringdef) and + (tstringdef(def).string_typ=tstringdef(p.resulttype.def).string_typ) + ) + or + ( + (p.left.nodetype=stringconstn) and + (is_ansistring(p.resulttype.def) and is_pchar(def)) + ) + or + ( + (p.left.nodetype=ordconstn) and + (is_char(p.resulttype.def) 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.def.deftype=arraydef) and + (tarraydef(p.resulttype.def).IsConstructor) and not(tarraydef(p.resulttype.def).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(tprocdef(tcallnode(p.left).procdefinition),tprocvardef(def),false)) + ) + ; + end; + + procedure get_candidate_information(var cl2_count,cl1_count,equal_count,exact_count:byte; + var ordspace:double; + treeparas:Tcallparanode;candparas:Tparaitem); + + {Gets information how the parameters would be converted to the candidate.} + + var hcvt:Tconverttype; + from_def,to_def:Tdef; + + begin + cl2_count:=0; + cl1_count:=0; + equal_count:=0; + exact_count:=0; + ordspace:=0; + while candparas<>nil do + begin + from_def:=treeparas.resulttype.def; + to_def:=candparas.paratype.def; + if to_def=from_def then + inc(exact_count) + { if a type is totally included in the other } + { we don't fear an overflow , } + { so we can do as if it is an equal match } + else if (treeparas.left.nodetype=ordconstn) and is_integer(to_def) then + begin + inc(equal_count); + {To do: What to do with overflow??} + ordspace:=ordspace+(double(Torddef(from_def).low)-Torddef(to_def).low)+ + (double(Torddef(to_def).high)-Torddef(from_def).high); + end + else if ((from_def.deftype=orddef) and (to_def.deftype=orddef)) and + (is_in_limit(from_def,to_def) or + ((candparas.paratyp in [vs_var,vs_out]) and (from_def.size=to_def.size)) + ) then + begin + ordspace:=ordspace+Torddef(to_def).high; + ordspace:=ordspace-Torddef(to_def).low; + inc(equal_count); + end + else if is_equal(treeparas,to_def) then + inc(equal_count) + else + case isconvertable(from_def,to_def, + hcvt,treeparas.left.nodetype,false) of + 0: + internalerror(200208021); + 1: + inc(cl1_count); + 2: + inc(cl2_count); + end; + treeparas:=Tcallparanode(treeparas.right); + candparas:=Tparaitem(candparas.next); + end; + end; + + var candidates_left,candidate_count,c1,c2:byte; + cl2_count1,cl1_count1,equal_count1,exact_count1:byte; + ordspace1:double; + cl2_count2,cl1_count2,equal_count2,exact_count2:byte; + ordspace2:double; + i,n:byte; + cont:boolean; + pt:Tcallparanode; + def:Tprocdef; + hcvt:Tconverttype; + pdc:Tparaitem; + hpt:Tnode; + srprocsym:Tprocsym; + srsymtable:Tsymtable; + candidates:set of 0..255; + candidates_exactmatch:set of 0..255; + delete_mask:set of 0..255; + candidate_defs:array[0..255] of Tprocdef; + + begin + choose_definition_to_call:=nil; + errorexit:=true; + + { 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); + + candidates:=[]; + candidates_exactmatch:=[]; + + {Collect all procedures which have the same # of parameters } + candidate_count:=0; + srprocsym:=symtableprocentry; + srsymtable:=symtableprocentry.owner; + repeat + for i:=1 to srprocsym.procdef_count do + begin + def:=srprocsym.procdef(i); + candidate_defs[i-1]:=def; + { only when the # of parameter are supported by the + procedure } + if (paralength>=def.minparacount) and + ((po_varargs in def.procoptions) or { varargs } + (paralength<=def.maxparacount)) then + include(candidates,i-1); + inc(candidate_count); + end; + if po_overload in srprocsym.first_procdef.procoptions then + begin + repeat + repeat + srsymtable:=srsymtable.next; + until (srsymtable=nil) or (srsymtable.symtabletype in [localsymtable,staticsymtable,globalsymtable]); + if assigned(srsymtable) then + srprocsym:=Tprocsym(srsymtable.speedsearch(symtableprocentry.name,symtableprocentry.speedvalue)); + until (srsymtable=nil) or (srprocsym<>nil); + cont:=assigned(srprocsym); + end + else + cont:=false; + until not cont; + + { no procedures found? then there is something wrong + with the parameter size } + if candidates=[] 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 + hpt:=cloadnode.create(tprocsym(symtableprocentry),symtableproc); + if (symtableprocentry.owner.symtabletype=objectsymtable) and + assigned(methodpointer) then + tloadnode(hpt).set_mp(methodpointer.getcopy); + resulttypepass(hpt); + choose_definition_to_call:=hpt; + end + else + begin + if assigned(left) then + aktfilepos:=left.fileinfo; + CGMessage(parser_e_wrong_parameter_size); + symtableprocentry.write_parameter_lists(nil); + end; + exit; + end; + {Walk through all candidates and remove the ones + that have incompatible parameters.} + for i:=1 to candidate_count do + if (i-1) in candidates then + begin + def:=candidate_defs[i-1]; + {Walk through all parameters.} + pdc:=Tparaitem(def.para.first); + pt:=Tcallparanode(left); + while assigned(pdc) do + begin + if pdc.paratyp in [vs_var,vs_out] then + if is_var_para_incompatible(pt.resulttype.def,pdc.paratype.def) and + not(is_shortstring(pt.resulttype.def) and is_shortstring(pdc.paratype.def)) and + (pdc.paratype.def.deftype<>formaldef) then + {Not convertable, def is no longer a candidate.} + exclude(candidates,i-1) + else + exclude(pt.callparaflags,cpf_nomatchfound) + else + if (pt.resulttype.def<>pdc.paratype.def) and + ((isconvertable(pt.resulttype.def,pdc.paratype.def, + hcvt,pt.left.nodetype,false)=0) and + not is_equal(pt,pdc.paratype.def)) then + {Not convertable, def is no longer a candidate.} + exclude(candidates,i-1) + else + exclude(pt.callparaflags,cpf_nomatchfound); + pdc:=Tparaitem(pdc.next); + pt:=Tcallparanode(pt.right); + end; + end; + {Count the candidates that are left.} + candidates_left:=0; + for i:=1 to candidate_count do + if (i-1) in candidates then + inc(candidates_left); + {Are there any candidates left?} + if candidates_left=0 then + begin + {There is an error, must be wrong type, because + wrong size is already checked (PFV) } + pt:=Tcallparanode(left); + n:=0; + while assigned(pt) do + if cpf_nomatchfound in pt.callparaflags then + break + else + begin + pt:=tcallparanode(pt.right); + inc(n); + end; + if not(assigned(pt) and assigned(pt.resulttype.def)) then + internalerror(39393); + {Def contains the last candidate tested.} + pdc:=Tparaitem(def.para.first); + for i:=1 to n do + pdc:=Tparaitem(pdc.next); + aktfilepos:=pt.fileinfo; + cgmessage3(type_e_wrong_parameter_type,tostr(n+1), + pt.resulttype.def.typename,pdc.paratype.def.typename); + symtableprocentry.write_parameter_lists(nil); + exit; + end; + {If there is more candidate that can be called, we have to + find the most suitable one. We collect the following + information: + - Amount of convertlevel 2 parameters. + - Amount of convertlevel 1 parameters. + - Amount of equal parameters. + - Amount of exact parameters. + - Amount of ordinal space the destination parameters + provide. For exampe, a word provides 65535-255=65280 + of ordinal space above a byte. + + The first criterium is the candidate that has the least + convertlevel 2 parameters. The next criterium is + the candidate that has the most exact parameters, next + criterium is the least ordinal space and + the last criterium is the most equal parameters. (DM)} + if candidates_left>1 then + begin + {Find the first candidate.} + c1:=1; + while c1<=candidate_count do + if (c1-1) in candidates then + break + else + inc(c1); + delete_mask:=[c1-1]; + {Get information about candidate c1.} + get_candidate_information(cl2_count1,cl1_count1,equal_count1, + exact_count1,ordspace1,Tcallparanode(left), + Tparaitem(candidate_defs[c1-1].para.first)); + {Find the other candidates and eliminate the lesser ones.} + c2:=c1+1; + while c2<=candidate_count do + if (c2-1) in candidates then + begin + {Candidate found, get information on it.} + get_candidate_information(cl2_count2,cl1_count2,equal_count2, + exact_count2,ordspace2,Tcallparanode(left), + Tparaitem(candidate_defs[c2-1].para.first)); + {Is c1 the better candidate?} + if (cl2_count1exact_count2)) or + ((cl2_count1=cl2_count2) and (exact_count1=exact_count2) and (equal_count1>equal_count2)) or + ((cl2_count1=cl2_count2) and (exact_count1=exact_count2) and (equal_count1=equal_count2) and (ordspace1exact_count1)) or + ((cl2_count2=cl2_count1) and (exact_count2=exact_count1) and (equal_count2>equal_count1)) or + ((cl2_count2=cl2_count1) and (exact_count2=exact_count1) and (equal_count2=equal_count1) and (ordspace21 then + begin + cgmessage(cg_e_cant_choose_overload_function); + symtableprocentry.write_parameter_lists(nil); + exit; + end; + for i:=1 to candidate_count do + if (i-1) in candidates then + begin + procdefinition:=candidate_defs[i-1]; + break; + end; + 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; + { big error for with statements + symtableproc:=procdefinition.owner; + but neede for overloaded operators !! } + if symtableproc=nil then + symtableproc:=procdefinition.owner; + errorexit:=false; + end; + + function tcallnode.det_resulttype:tnode; + + + var lastpara,paralength:byte; + oldcallprocdef:Tabstractprocdef; + pt:Tcallparanode; + i,n:byte; + e,is_const:boolean; + pdc:Tparaitem; + hpt:Tnode; + + label errorexit; + + begin + result:=nil; + + oldcallprocdef:=aktcallprocdef; + aktcallprocdef:=nil; + + { determine length of parameter list } + pt:=tcallparanode(left); + paralength:=0; + while assigned(pt) do + begin + include(pt.callparaflags,cpf_nomatchfound); + 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); + + { check the amount of parameters } + pdc:=tparaitem(procdefinition.Para.first); + pt:=tcallparanode(left); + lastpara:=paralength; + while assigned(pdc) 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 + pdc:=tparaitem(pdc.next); + pt:=tcallparanode(pt.right); + dec(lastpara); + end; + if assigned(pt) or assigned(pdc) then + begin + if assigned(pt) then + aktfilepos:=pt.fileinfo; + CGMessage(parser_e_wrong_parameter_size); + end; + end + else + { not a procedure variable } + begin + { do we know the procedure to call ? } + if not(assigned(procdefinition)) then + begin + result:=choose_definition_to_call(paralength,e); + if e then + goto errorexit; + end; +(* To do!!! + { add needed default parameters } + if assigned(procdefinition) and + (paralengthprocdefinition.maxparacount) do + begin + include(tcallparanode(pt).flags,nf_varargs_para); + pt:=tcallparanode(pt.right); + dec(i); + end; + end; + + { insert type conversions } + if assigned(left) then + begin + aktcallprocdef:=procdefinition; + tcallparanode(left).insert_typeconv(tparaitem(procdefinition.Para.first),true); + end; + errorexit: + { Reset some settings back } + aktcallprocdef:=oldcallprocdef; + end; + +{$else} function tcallnode.det_resulttype:tnode; type pprocdefcoll = ^tprocdefcoll; @@ -899,6 +1463,8 @@ implementation srprocsym : tprocsym; srsymtable : tsymtable; begin + if fileinfo.line=300 then + result:=nil; result:=nil; procs:=nil; @@ -963,7 +1529,7 @@ implementation 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.defs^.def.procoptions) and + (po_overload in symtableprocentry.first_procdef.procoptions) and (symtableprocentry.owner.symtabletype=objectsymtable) then search_class_overloads(symtableprocentry); @@ -998,7 +1564,7 @@ implementation 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 (po_overload in symtableprocentry.defs^.def.procoptions) and + if (po_overload in symtableprocentry.first_procdef.procoptions) and (symtableprocentry.owner.symtabletype<>objectsymtable) then begin srsymtable:=symtableprocentry.owner.next; @@ -1014,7 +1580,7 @@ implementation begin { if this procedure doesn't have overload we can stop searching } - if not(po_overload in srprocsym.defs^.def.procoptions) then + if not(po_overload in srprocsym.first_procdef.procoptions) then break; { process all overloaded definitions } pd:=srprocsym.defs; @@ -1631,7 +2197,7 @@ implementation dispose(procs); aktcallprocdef:=oldcallprocdef; end; - +{$endif} function tcallnode.pass_1 : tnode; var @@ -1860,28 +2426,28 @@ implementation function Tcallnode.track_state_pass(exec_known:boolean):boolean; var hp:Tcallparanode; - value:Tnode; + value:Tnode; begin - track_state_pass:=false; - hp:=Tcallparanode(left); - while assigned(hp) do - begin - if left.track_state_pass(exec_known) then - begin - left.resulttype.def:=nil; - do_resulttypepass(left); - end; - value:=aktstate.find_fact(hp.left); - if value<>nil then - begin - track_state_pass:=true; - hp.left.destroy; - hp.left:=value.getcopy; - do_resulttypepass(hp.left); - end; - hp:=Tcallparanode(hp.right); - end; + track_state_pass:=false; + hp:=Tcallparanode(left); + while assigned(hp) do + begin + if left.track_state_pass(exec_known) then + begin + left.resulttype.def:=nil; + do_resulttypepass(left); + end; + value:=aktstate.find_fact(hp.left); + if value<>nil then + begin + track_state_pass:=true; + hp.left.destroy; + hp.left:=value.getcopy; + do_resulttypepass(hp.left); + end; + hp:=Tcallparanode(hp.right); + end; end; {$endif} @@ -2017,7 +2583,10 @@ begin end. { $Log$ - Revision 1.87 2002-08-19 19:36:42 peter + Revision 1.88 2002-08-20 10:31:26 daniel + * Tcallnode.det_resulttype rewritten + + Revision 1.87 2002/08/19 19:36:42 peter * More fixes for cross unit inlining, all tnodes are now implemented * Moved pocall_internconst to po_internconst because it is not a calling type at all and it conflicted when inlining of these small diff --git a/compiler/symsym.pas b/compiler/symsym.pas index abb37f734c..88b1a21a16 100644 --- a/compiler/symsym.pas +++ b/compiler/symsym.pas @@ -105,6 +105,8 @@ interface constructor create; end; + Tprocdefcallback = procedure(p:Tprocdef;arg:pointer); + tprocsym = class(tstoredsym) { protected} defs : pprocdeflist; { linked list of overloaded procdefs } @@ -124,13 +126,18 @@ interface procedure ppuwrite(ppufile:tcompilerppufile);override; procedure deref;override; procedure addprocdef(p:tprocdef); + function procdef_count:byte; + function procdef(nr:byte):Tprocdef; + procedure add_para_match_to(Aprocsym:Tprocsym); procedure concat_procdefs_to(s:Tprocsym); + procedure foreach_procdef_static(proc2call:Tprocdefcallback;arg:pointer); function first_procdef:Tprocdef; function last_procdef:Tprocdef; function search_procdef_bytype(pt:Tproctypeoption):Tprocdef; + function search_procdef_bypara(params:Tparalinkedlist):Tprocdef; function search_procdef_byprocvardef(d:Tprocvardef):Tprocdef; function search_procdef_byretdef_by1paradef(retdef,firstpara:Tdef; - matchtype:Tdefmatch):Tprocdef; + matchtype:Tdefmatch):Tprocdef; function write_references(ppufile:tcompilerppufile;locals:boolean):boolean;override; {$ifdef GDB} function stabstring : pchar;override; @@ -873,10 +880,50 @@ implementation defs:=pd; end; - procedure Tprocsym.concat_procdefs_to(s:Tprocsym); + function Tprocsym.procdef_count:byte; var pd:Pprocdeflist; + begin + procdef_count:=0; + pd:=defs; + while assigned(pd) do + begin + inc(procdef_count); + pd:=pd^.next; + end; + end; + + function Tprocsym.procdef(nr:byte):Tprocdef; + + var i:byte; + pd:Pprocdeflist; + + begin + pd:=defs; + for i:=2 to nr do + pd:=pd^.next; + procdef:=pd^.def; + end; + + procedure Tprocsym.add_para_match_to(Aprocsym:Tprocsym); + + var pd:Pprocdeflist; + + begin + pd:=defs; + while assigned(pd) do + begin + if Aprocsym.search_procdef_bypara(pd^.def.para)=nil then + Aprocsym.addprocdef(pd^.def); + pd:=pd^.next; + end; + end; + + procedure Tprocsym.concat_procdefs_to(s:Tprocsym); + + var pd:Pprocdeflist; + begin pd:=defs; while assigned(defs) do @@ -905,10 +952,23 @@ implementation end; end; - function Tprocsym.search_procdef_bytype(pt:Tproctypeoption):Tprocdef; + procedure Tprocsym.foreach_procdef_static(proc2call:Tprocdefcallback;arg:pointer); var p:Pprocdeflist; + begin + p:=defs; + while assigned(p) do + begin + proc2call(p^.def,arg); + p:=p^.next; + end; + end; + + function Tprocsym.search_procdef_bytype(pt:Tproctypeoption):Tprocdef; + + var p:Pprocdeflist; + begin search_procdef_bytype:=nil; p:=defs; @@ -923,6 +983,24 @@ implementation end; end; + function Tprocsym.search_procdef_bypara(params:Tparalinkedlist):Tprocdef; + + var pd:Pprocdeflist; + + begin + search_procdef_bypara:=nil; + pd:=defs; + while assigned(pd) do + begin + if equal_paras(pd^.def.para,params,cp_value_equal_const) then + begin + search_procdef_bypara:=pd^.def; + break; + end; + pd:=pd^.next; + end; + end; + function Tprocsym.search_procdef_byprocvardef(d:Tprocvardef):Tprocdef; var pd:Pprocdeflist; @@ -2608,7 +2686,10 @@ implementation end. { $Log$ - Revision 1.53 2002-08-18 20:06:27 peter + Revision 1.54 2002-08-20 10:31:26 daniel + * Tcallnode.det_resulttype rewritten + + Revision 1.53 2002/08/18 20:06:27 peter * inlining is now also allowed in interface * renamed write/load to ppuwrite/ppuload * tnode storing in ppu