diff --git a/.gitattributes b/.gitattributes index 7f7f55a8ee..630b8eebba 100644 --- a/.gitattributes +++ b/.gitattributes @@ -9133,6 +9133,7 @@ tests/tbs/tb0573.pp svneol=native#text/plain tests/tbs/tb0574.pp svneol=native#text/pascal tests/tbs/tb0575.pp svneol=native#text/plain tests/tbs/tb0576.pp svneol=native#text/plain +tests/tbs/tb0577.pp svneol=native#text/plain tests/tbs/tb205.pp svneol=native#text/plain tests/tbs/ub0060.pp svneol=native#text/plain tests/tbs/ub0069.pp svneol=native#text/plain diff --git a/compiler/htypechk.pas b/compiler/htypechk.pas index 08d6abfce4..669c958643 100644 --- a/compiler/htypechk.pas +++ b/compiler/htypechk.pas @@ -67,12 +67,12 @@ interface FParaNode : tnode; FParaLength : smallint; FAllowVariant : boolean; - procedure collect_overloads_in_struct(structdef:tabstractrecorddef;ProcdefOverloadList:TFPObjectList;searchhelpers:boolean); + procedure collect_overloads_in_struct(structdef:tabstractrecorddef;ProcdefOverloadList:TFPObjectList;searchhelpers,anoninherited:boolean); procedure collect_overloads_in_units(ProcdefOverloadList:TFPObjectList; objcidcall,explicitunit: boolean); - procedure create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers:boolean); + procedure create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers,anoninherited:boolean); function proc_add(st:tsymtable;pd:tprocdef;objcidcall: boolean):pcandidate; public - constructor create(sym:tprocsym;st:TSymtable;ppn:tnode;ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers:boolean); + constructor create(sym:tprocsym;st:TSymtable;ppn:tnode;ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers,anoninherited:boolean); constructor create_operator(op:ttoken;ppn:tnode); destructor destroy;override; procedure list(all:boolean); @@ -1758,7 +1758,7 @@ implementation TCallCandidates ****************************************************************************} - constructor tcallcandidates.create(sym:tprocsym;st:TSymtable;ppn:tnode;ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers:boolean); + constructor tcallcandidates.create(sym:tprocsym;st:TSymtable;ppn:tnode;ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers,anoninherited:boolean); begin if not assigned(sym) then internalerror(200411015); @@ -1766,7 +1766,7 @@ implementation FProcsym:=sym; FProcsymtable:=st; FParanode:=ppn; - create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers); + create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers,anoninherited); end; @@ -1776,7 +1776,7 @@ implementation FProcsym:=nil; FProcsymtable:=nil; FParanode:=ppn; - create_candidate_list(false,false,false,false,false); + create_candidate_list(false,false,false,false,false,false); end; @@ -1795,21 +1795,29 @@ implementation end; - procedure tcallcandidates.collect_overloads_in_struct(structdef:tabstractrecorddef;ProcdefOverloadList:TFPObjectList;searchhelpers:boolean); + procedure tcallcandidates.collect_overloads_in_struct(structdef:tabstractrecorddef;ProcdefOverloadList:TFPObjectList;searchhelpers,anoninherited:boolean); - function processprocsym(srsym:tprocsym):boolean; + function processprocsym(srsym:tprocsym; out foundanything: boolean):boolean; var j : integer; pd : tprocdef; begin - { Store first procsym found } - if not assigned(FProcsym) then - FProcsym:=srsym; { add all definitions } result:=false; + foundanything:=false; for j:=0 to srsym.ProcdefList.Count-1 do begin pd:=tprocdef(srsym.ProcdefList[j]); + { in case of anonymous inherited, only match procdefs identical + to the current one (apart from hidden parameters), rather than + anything compatible to the parameters } + if anoninherited and + (compare_paras(current_procinfo.procdef.paras,pd.paras,cp_all,[cpo_ignorehidden])NOTOKEN) then begin @@ -1989,7 +2001,7 @@ implementation while assigned(pt) do begin if (pt.resultdef.typ=recorddef) then - collect_overloads_in_struct(tabstractrecorddef(pt.resultdef),ProcdefOverloadList,searchhelpers); + collect_overloads_in_struct(tabstractrecorddef(pt.resultdef),ProcdefOverloadList,searchhelpers,anoninherited); pt:=tcallparanode(pt.right); end; collect_overloads_in_units(ProcdefOverloadList,objcidcall,explicitunit); diff --git a/compiler/ncal.pas b/compiler/ncal.pas index 17a3be3150..c5bb0c5a08 100644 --- a/compiler/ncal.pas +++ b/compiler/ncal.pas @@ -2738,7 +2738,7 @@ implementation ((m_delphi in current_settings.modeswitches) and (cnf_anon_inherited in callnodeflags)); candidates:=tcallcandidates.create(symtableprocentry,symtableproc,left,ignorevisibility, not(nf_isproperty in flags),cnf_objc_id_call in callnodeflags,cnf_unit_specified in callnodeflags, - callnodeflags*[cnf_anon_inherited,cnf_inherited]=[]); + callnodeflags*[cnf_anon_inherited,cnf_inherited]=[],cnf_anon_inherited in callnodeflags); { no procedures found? then there is something wrong with the parameter size or the procedures are diff --git a/compiler/pexpr.pas b/compiler/pexpr.pas index a00c5b352e..48adca71c3 100644 --- a/compiler/pexpr.pas +++ b/compiler/pexpr.pas @@ -2306,6 +2306,7 @@ implementation hs,hsorg : string; hdef : tdef; filepos : tfileposinfo; + callflags : tcallnodeflags; again, updatefpos, nodechanged : boolean; @@ -2452,7 +2453,10 @@ implementation p1:=cerrornode.create; end; end; - do_member_read(hclassdef,getaddr,srsym,p1,again,[cnf_inherited,cnf_anon_inherited]); + callflags:=[cnf_inherited]; + if anon_inherited then + include(callflags,cnf_anon_inherited); + do_member_read(hclassdef,getaddr,srsym,p1,again,callflags); end else begin diff --git a/tests/tbs/tb0577.pp b/tests/tbs/tb0577.pp new file mode 100644 index 0000000000..14df4c075a --- /dev/null +++ b/tests/tbs/tb0577.pp @@ -0,0 +1,51 @@ +program tb0577; + +{$mode delphi} + +type + tc = class + procedure test(b: byte);virtual;overload; + end; + + tc2 = class(tc) + strict protected + procedure test(b: byte; l: longint = 1234);virtual;overload; + public + procedure test(l: longint);virtual;overload; + end; + + tc3 = class(tc2) + procedure test(b: byte);override;overload; + end; + +var + glob: longint; + + procedure tc.test(b: byte); + begin + glob:=2; + end; + + procedure tc2.test(l: longint); + begin + glob:=1; + end; + + procedure tc2.test(b: byte; l: longint = 1234); + begin + glob:=3; + end; + + procedure tc3.test(b: byte); + begin + inherited; + end; + +var + c: tc; +begin + c:=tc3.create; + c.test(byte(4)); + if glob<>2 then + halt(1); +end.