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

* create a new vmt entry also if return type differs

Browse Source 
* search all parent classes for matching interface implementations

git-svn-id: trunk@8138 -
This commit is contained in:
peter 2007-07-22 19:47:55 +00:00
parent 98cc116dd2
commit 5e36a73b80
5 changed files with 159 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitattributes vendored
View File

@ -7285,7 +7285,6 @@ tests/webtbf/tw3116.pp svneol=native#text/plain
tests/webtbf/tw3126.pp svneol=native#text/plain
tests/webtbf/tw3145.pp svneol=native#text/plain
tests/webtbf/tw3183.pp svneol=native#text/plain
tests/webtbf/tw3183b.pp svneol=native#text/plain
tests/webtbf/tw3186.pp svneol=native#text/plain
tests/webtbf/tw3218.pp svneol=native#text/plain
tests/webtbf/tw3241.pp svneol=native#text/plain
@ -8353,6 +8352,8 @@ tests/webtbs/tw9209.pp svneol=native#text/plain
tests/webtbs/tw9221.pp svneol=native#text/plain
tests/webtbs/tw9261.pp svneol=native#text/x-pascal
tests/webtbs/tw9278.pp svneol=native#text/plain
tests/webtbs/tw9306a.pp -text
tests/webtbs/tw9306b.pp -text
tests/webtbs/tw9309.pp -text
tests/webtbs/ub1873.pp svneol=native#text/plain
tests/webtbs/ub1883.pp svneol=native#text/plain

78
compiler/nobj.pas
View File

@ -128,7 +128,7 @@ implementation
uses
SysUtils,
globals,verbose,systems,
symtable,symconst,symtype,defcmp,
symbase,symtable,symconst,symtype,defcmp,
dbgbase,
ncgrtti
;
@ -308,8 +308,9 @@ implementation
MessagePos1(pd.fileinfo,parser_w_should_use_override,pd.fullprocname(false));
end;
end
{ same parameters }
else if (compare_paras(procdefcoll^.data.paras,pd.paras,cp_all,[])>=te_equal) then
{ same parameter and return types (parameter specifiers will be checked below) }
else if (compare_paras(procdefcoll^.data.paras,pd.paras,cp_none,[])>=te_equal) and
compatible_childmethod_resultdef(procdefcoll^.data.returndef,pd.returndef) then
begin
{ overload is inherited }
if (po_overload in procdefcoll^.data.procoptions) then
@ -324,9 +325,10 @@ implementation
include(pd.procoptions,po_hascallingconvention);
end;
{ the flags have to match except abstract and override }
{ only if both are virtual !! }
if (procdefcoll^.data.proccalloption<>pd.proccalloption) or
{ All parameter specifiers and some procedure the flags have to match
except abstract and override }
if (compare_paras(procdefcoll^.data.paras,pd.paras,cp_all,[])<te_equal) or
(procdefcoll^.data.proccalloption<>pd.proccalloption) or
(procdefcoll^.data.proctypeoption<>pd.proctypeoption) or
((procdefcoll^.data.procoptions*po_comp)<>(pd.procoptions*po_comp)) then
begin
@ -334,19 +336,6 @@ implementation
tprocsym(procdefcoll^.data.procsym).write_parameter_lists(pd);
end;
{ error, if the return types aren't equal }
if not compatible_childmethod_resultdef(procdefcoll^.data.returndef,pd.returndef) then
begin
if not((m_delphi in current_settings.modeswitches) and
is_interface(_class)) then
Message2(parser_e_overridden_methods_not_same_ret,pd.fullprocname(false),
procdefcoll^.data.fullprocname(false))
else
{ Delphi allows changing the result type of interface methods from anything to
anything (JM) }
Message2(parser_w_overridden_methods_not_same_ret,pd.fullprocname(false),
procdefcoll^.data.fullprocname(false));
end;
{ check if the method to override is visible, check is only needed
for the current parsed class. Parent classes are already validated and
need to include all virtual methods including the ones not visible in the
@ -451,36 +440,37 @@ implementation
po_comp = [po_classmethod,po_staticmethod,po_interrupt,po_iocheck,po_msgstr,po_msgint,
po_exports,po_varargs,po_explicitparaloc,po_nostackframe];
var
sym: tsym;
implprocdef : Tprocdef;
i: cardinal;
hclass : tobjectdef;
hashedid : THashedIDString;
srsym : tsym;
begin
result:=nil;
sym:=tsym(search_class_member(_class,name));
if assigned(sym) and
(sym.typ=procsym) then
hashedid.id:=name;
hclass:=_class;
while assigned(hclass) do
begin
{ 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 tprocsym(sym).overloadchecked) and
(po_overload in tprocdef(tprocsym(sym).ProcdefList[0]).procoptions) and
(tprocsym(sym).owner.symtabletype=ObjectSymtable) then
search_class_overloads(tprocsym(sym));
for i:=0 to Tprocsym(sym).ProcdefList.Count-1 do
srsym:=tsym(hclass.symtable.FindWithHash(hashedid));
if assigned(srsym) and
(srsym.typ=procsym) then
begin
implprocdef:=tprocdef(Tprocsym(sym).ProcdefList[i]);
if (compare_paras(proc.paras,implprocdef.paras,cp_none,[])>=te_equal) and
(proc.proccalloption=implprocdef.proccalloption) and
(proc.proctypeoption=implprocdef.proctypeoption) and
((proc.procoptions*po_comp)=((implprocdef.procoptions+[po_virtualmethod])*po_comp)) then
for i:=0 to Tprocsym(srsym).ProcdefList.Count-1 do
begin
result:=implprocdef;
exit;
implprocdef:=tprocdef(tprocsym(srsym).ProcdefList[i]);
if (implprocdef.procsym=tprocsym(srsym)) and
(compare_paras(proc.paras,implprocdef.paras,cp_all,[cpo_ignorehidden,cpo_comparedefaultvalue])>=te_equal) and
compatible_childmethod_resultdef(proc.returndef,implprocdef.returndef) and
(proc.proccalloption=implprocdef.proccalloption) and
(proc.proctypeoption=implprocdef.proctypeoption) and
((proc.procoptions*po_comp)=((implprocdef.procoptions+[po_virtualmethod])*po_comp)) then
begin
result:=implprocdef;
exit;
end;
end;
end;
hclass:=hclass.childof;
end;
end;
@ -513,13 +503,7 @@ implementation
implprocdef:=intf_search_procdef_by_name(tprocdef(def),tprocdef(def).procsym.name);
{ Add procdef to the implemented interface }
if assigned(implprocdef) then
begin
if (compare_paras(tprocdef(def).paras,implprocdef.paras,cp_all,[cpo_ignorehidden,cpo_comparedefaultvalue])<te_equal) or
not compatible_childmethod_resultdef(tprocdef(def).returndef,implprocdef.returndef) then
MessagePos1(tprocdef(implprocdef).fileinfo,parser_e_header_dont_match_forward,
tprocdef(def).fullprocname(false));
ImplIntf.AddImplProc(implprocdef)
end
ImplIntf.AddImplProc(implprocdef)
else
if ImplIntf.IType = etStandard then
Message1(sym_e_no_matching_implementation_found,tprocdef(def).fullprocname(false));

14
tests/webtbf/tw3183b.pp
View File

@ -1,14 +0,0 @@
{ %fail }
{$mode objfpc}
type
ta = interface
function a: longint;
end;
tb = interface(ta)
function a: ansistring;
end;
begin
end.

63
tests/webtbs/tw9306a.pp Normal file
View File

@ -0,0 +1,63 @@
{$mode objfpc}
type
IIntf = interface
function Foo(const S: string): string;
end;
IIntf2 = interface(IIntf)
function Foo(const S: string): Integer;
end;
TIntf = class(TInterfacedObject, IIntf)
protected
{ IIntf }
function Foo(const S: string): string;
end;
TIntf2 = class(TIntf, IIntf2)
public
{ IIntf2 }
function Foo(const S: string): Integer; overload;
end;
var
erridx : longint;
{ TIntf }
function TIntf.Foo(const S: string): string;
begin
writeln('TIntf.Foo: ',S);
if erridx=0 then
erridx:=1;
result:=S;
end;
{ TIntf2 }
function TIntf2.Foo(const S: string): Integer;
begin
writeln('TIntf2.Foo: ',S);
if erridx=1 then
erridx:=2;
result:=0;
end;
var
i1 : IIntf;
i2 : IIntf2;
begin
erridx:=0;
i1:=TIntf2.Create;
i1.Foo('1234');
i2:=TIntf2.Create;
i2.Foo('1234');
if erridx<>2 then
begin
writeln('Error');
halt(1);
end;
end.

63
tests/webtbs/tw9306b.pp Normal file
View File

@ -0,0 +1,63 @@
{$mode delphi}
type
IIntf = interface
function Foo(const S: string): string;
end;
IIntf2 = interface(IIntf)
function Foo(const S: string): Integer;
end;
TIntf = class(TInterfacedObject, IIntf)
protected
{ IIntf }
function Foo(const S: string): string;
end;
TIntf2 = class(TIntf, IIntf2)
public
{ IIntf2 }
function Foo(const S: string): Integer; overload;
end;
var
erridx : longint;
{ TIntf }
function TIntf.Foo(const S: string): string;
begin
writeln('TIntf.Foo: ',S);
if erridx=0 then
erridx:=1;
result:=S;
end;
{ TIntf2 }
function TIntf2.Foo(const S: string): Integer;
begin
writeln('TIntf2.Foo: ',S);
if erridx=1 then
erridx:=2;
result:=0;
end;
var
i1 : IIntf;
i2 : IIntf2;
begin
erridx:=0;
i1:=TIntf2.Create;
i1.Foo('1234');
i2:=TIntf2.Create;
i2.Foo('1234');
if erridx<>2 then
begin
writeln('Error');
halt(1);
end;
end.