paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-25 00:29:25 +02:00
Code Issues Packages Projects Releases Wiki Activity

* make sure that anonymous inherited calls only call through to the

Browse Source 
overridden method, rather than to any method that can accept similar
    parameters as the current one (Delphi-compatible, and corresponds to
    what is described in our documentation)
  * do not flag "inherited" call nodes that are not "anonymous inherited"
    calls using the cnf_anon_inherited flag

git-svn-id: trunk@18162 -
This commit is contained in:
Jonas Maebe 2011-08-10 17:26:19 +00:00
parent 4de8f53f03
commit 9195506c56
5 changed files with 91 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -9133,6 +9133,7 @@ tests/tbs/tb0573.pp svneol=native#text/plain
tests/tbs/tb0574.pp svneol=native#text/pascal tests/tbs/tb0574.pp svneol=native#text/pascal
tests/tbs/tb0575.pp svneol=native#text/plain tests/tbs/tb0575.pp svneol=native#text/plain
tests/tbs/tb0576.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/tb205.pp svneol=native#text/plain
tests/tbs/ub0060.pp svneol=native#text/plain tests/tbs/ub0060.pp svneol=native#text/plain
tests/tbs/ub0069.pp svneol=native#text/plain tests/tbs/ub0069.pp svneol=native#text/plain

54
compiler/htypechk.pas
View File

@ -67,12 +67,12 @@ interface
FParaNode : tnode; FParaNode : tnode;
FParaLength : smallint; FParaLength : smallint;
FAllowVariant : boolean; 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 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; function proc_add(st:tsymtable;pd:tprocdef;objcidcall: boolean):pcandidate;
public 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); constructor create_operator(op:ttoken;ppn:tnode);
destructor destroy;override; destructor destroy;override;
procedure list(all:boolean); procedure list(all:boolean);
@ -1758,7 +1758,7 @@ implementation
TCallCandidates 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 begin
if not assigned(sym) then if not assigned(sym) then
internalerror(200411015); internalerror(200411015);
@ -1766,7 +1766,7 @@ implementation
FProcsym:=sym; FProcsym:=sym;
FProcsymtable:=st; FProcsymtable:=st;
FParanode:=ppn; FParanode:=ppn;
create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers); create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers,anoninherited);
end; end;
@ -1776,7 +1776,7 @@ implementation
FProcsym:=nil; FProcsym:=nil;
FProcsymtable:=nil; FProcsymtable:=nil;
FParanode:=ppn; FParanode:=ppn;
create_candidate_list(false,false,false,false,false); create_candidate_list(false,false,false,false,false,false);
end; end;
@ -1795,21 +1795,29 @@ implementation
end; 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 var
j : integer; j : integer;
pd : tprocdef; pd : tprocdef;
begin begin
{ Store first procsym found }
if not assigned(FProcsym) then
FProcsym:=srsym;
{ add all definitions } { add all definitions }
result:=false; result:=false;
foundanything:=false;
for j:=0 to srsym.ProcdefList.Count-1 do for j:=0 to srsym.ProcdefList.Count-1 do
begin begin
pd:=tprocdef(srsym.ProcdefList[j]); 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])<te_equal) then
continue;
foundanything:=true;
{ Store first procsym found }
if not assigned(FProcsym) then
FProcsym:=tprocsym(srsym);
if po_overload in pd.procoptions then if po_overload in pd.procoptions then
result:=true; result:=true;
ProcdefOverloadList.Add(srsym.ProcdefList[j]); ProcdefOverloadList.Add(srsym.ProcdefList[j]);
@ -1819,7 +1827,8 @@ implementation
var var
srsym : tsym; srsym : tsym;
hashedid : THashedIDString; hashedid : THashedIDString;
hasoverload : boolean; hasoverload,
foundanything : boolean;
helperdef : tobjectdef; helperdef : tobjectdef;
begin begin
if FOperator=NOTOKEN then if FOperator=NOTOKEN then
@ -1843,9 +1852,10 @@ implementation
{ Delphi allows hiding a property by a procedure with the same name } { Delphi allows hiding a property by a procedure with the same name }
(srsym.typ=procsym) then (srsym.typ=procsym) then
begin begin
hasoverload := processprocsym(tprocsym(srsym)); hasoverload:=processprocsym(tprocsym(srsym),foundanything);
{ when there is no explicit overload we stop searching } { when there is no explicit overload we stop searching }
if not hasoverload then if foundanything and
not hasoverload then
break; break;
end; end;
helperdef:=helperdef.childof; helperdef:=helperdef.childof;
@ -1860,9 +1870,10 @@ implementation
{ Delphi allows hiding a property by a procedure with the same name } { Delphi allows hiding a property by a procedure with the same name }
(srsym.typ=procsym) then (srsym.typ=procsym) then
begin begin
hasoverload:=processprocsym(tprocsym(srsym)); hasoverload:=processprocsym(tprocsym(srsym),foundanything);
{ when there is no explicit overload we stop searching } { when there is no explicit overload we stop searching }
if not hasoverload then if foundanything and
not hasoverload then
break; break;
end; end;
if is_objectpascal_helper(structdef) then if is_objectpascal_helper(structdef) then
@ -1875,9 +1886,10 @@ implementation
{ Delphi allows hiding a property by a procedure with the same name } { Delphi allows hiding a property by a procedure with the same name }
(srsym.typ=procsym) then (srsym.typ=procsym) then
begin begin
hasoverload:=processprocsym(tprocsym(srsym)); hasoverload:=processprocsym(tprocsym(srsym),foundanything);
{ when there is no explicit overload we stop searching } { when there is no explicit overload we stop searching }
if not hasoverload then if foundanything and
not hasoverload then
break; break;
end; end;
end; end;
@ -1961,7 +1973,7 @@ implementation
end; end;
procedure tcallcandidates.create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers:boolean); procedure tcallcandidates.create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers,anoninherited:boolean);
var var
j : integer; j : integer;
pd : tprocdef; pd : tprocdef;
@ -1979,7 +1991,7 @@ implementation
if not objcidcall and if not objcidcall and
(FOperator=NOTOKEN) and (FOperator=NOTOKEN) and
(FProcsym.owner.symtabletype in [objectsymtable,recordsymtable]) then (FProcsym.owner.symtabletype in [objectsymtable,recordsymtable]) then
collect_overloads_in_struct(tabstractrecorddef(FProcsym.owner.defowner),ProcdefOverloadList,searchhelpers) collect_overloads_in_struct(tabstractrecorddef(FProcsym.owner.defowner),ProcdefOverloadList,searchhelpers,anoninherited)
else else
if (FOperator<>NOTOKEN) then if (FOperator<>NOTOKEN) then
begin begin
@ -1989,7 +2001,7 @@ implementation
while assigned(pt) do while assigned(pt) do
begin begin
if (pt.resultdef.typ=recorddef) then 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); pt:=tcallparanode(pt.right);
end; end;
collect_overloads_in_units(ProcdefOverloadList,objcidcall,explicitunit); collect_overloads_in_units(ProcdefOverloadList,objcidcall,explicitunit);

2
compiler/ncal.pas
View File

@ -2738,7 +2738,7 @@ implementation
((m_delphi in current_settings.modeswitches) and (cnf_anon_inherited in callnodeflags)); ((m_delphi in current_settings.modeswitches) and (cnf_anon_inherited in callnodeflags));
candidates:=tcallcandidates.create(symtableprocentry,symtableproc,left,ignorevisibility, candidates:=tcallcandidates.create(symtableprocentry,symtableproc,left,ignorevisibility,
not(nf_isproperty in flags),cnf_objc_id_call in callnodeflags,cnf_unit_specified in callnodeflags, 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 { no procedures found? then there is something wrong
with the parameter size or the procedures are with the parameter size or the procedures are

6
compiler/pexpr.pas
View File

@ -2306,6 +2306,7 @@ implementation
hs,hsorg : string; hs,hsorg : string;
hdef : tdef; hdef : tdef;
filepos : tfileposinfo; filepos : tfileposinfo;
callflags : tcallnodeflags;
again, again,
updatefpos, updatefpos,
nodechanged : boolean; nodechanged : boolean;
@ -2452,7 +2453,10 @@ implementation
p1:=cerrornode.create; p1:=cerrornode.create;
end; end;
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 end
else else
begin begin

51
tests/tbs/tb0577.pp Normal file
View File

@ -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.