mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-08 01:08:07 +02:00
* make sure that anonymous inherited calls only call through to the
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
parent
4de8f53f03
commit
9195506c56
1
.gitattributes
vendored
1
.gitattributes
vendored
@ -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
|
||||
|
||||
@ -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])<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
|
||||
result:=true;
|
||||
ProcdefOverloadList.Add(srsym.ProcdefList[j]);
|
||||
@ -1819,7 +1827,8 @@ implementation
|
||||
var
|
||||
srsym : tsym;
|
||||
hashedid : THashedIDString;
|
||||
hasoverload : boolean;
|
||||
hasoverload,
|
||||
foundanything : boolean;
|
||||
helperdef : tobjectdef;
|
||||
begin
|
||||
if FOperator=NOTOKEN then
|
||||
@ -1843,9 +1852,10 @@ implementation
|
||||
{ Delphi allows hiding a property by a procedure with the same name }
|
||||
(srsym.typ=procsym) then
|
||||
begin
|
||||
hasoverload := processprocsym(tprocsym(srsym));
|
||||
hasoverload:=processprocsym(tprocsym(srsym),foundanything);
|
||||
{ when there is no explicit overload we stop searching }
|
||||
if not hasoverload then
|
||||
if foundanything and
|
||||
not hasoverload then
|
||||
break;
|
||||
end;
|
||||
helperdef:=helperdef.childof;
|
||||
@ -1860,9 +1870,10 @@ implementation
|
||||
{ Delphi allows hiding a property by a procedure with the same name }
|
||||
(srsym.typ=procsym) then
|
||||
begin
|
||||
hasoverload:=processprocsym(tprocsym(srsym));
|
||||
hasoverload:=processprocsym(tprocsym(srsym),foundanything);
|
||||
{ when there is no explicit overload we stop searching }
|
||||
if not hasoverload then
|
||||
if foundanything and
|
||||
not hasoverload then
|
||||
break;
|
||||
end;
|
||||
if is_objectpascal_helper(structdef) then
|
||||
@ -1875,9 +1886,10 @@ implementation
|
||||
{ Delphi allows hiding a property by a procedure with the same name }
|
||||
(srsym.typ=procsym) then
|
||||
begin
|
||||
hasoverload:=processprocsym(tprocsym(srsym));
|
||||
hasoverload:=processprocsym(tprocsym(srsym),foundanything);
|
||||
{ when there is no explicit overload we stop searching }
|
||||
if not hasoverload then
|
||||
if foundanything and
|
||||
not hasoverload then
|
||||
break;
|
||||
end;
|
||||
end;
|
||||
@ -1961,7 +1973,7 @@ implementation
|
||||
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
|
||||
j : integer;
|
||||
pd : tprocdef;
|
||||
@ -1979,7 +1991,7 @@ implementation
|
||||
if not objcidcall and
|
||||
(FOperator=NOTOKEN) and
|
||||
(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
|
||||
if (FOperator<>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);
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
51
tests/tbs/tb0577.pp
Normal file
51
tests/tbs/tb0577.pp
Normal 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.
|
||||
Loading…
Reference in New Issue
Block a user