* fix for Mantis #34287: correctly handle "inherited method" calls if "method" is a generic (no matter if it's mode Delphi or not)

+ added test

git-svn-id: trunk@39787 -
This commit is contained in:
svenbarth 2018-09-21 15:16:18 +00:00
parent 06267006f3
commit 9a99ab9dda
5 changed files with 216 additions and 57 deletions

3
.gitattributes vendored
View File

@ -16249,6 +16249,7 @@ tests/webtbs/tw34124.pp svneol=native#text/pascal
tests/webtbs/tw3418.pp svneol=native#text/plain tests/webtbs/tw3418.pp svneol=native#text/plain
tests/webtbs/tw3423.pp svneol=native#text/plain tests/webtbs/tw3423.pp svneol=native#text/plain
tests/webtbs/tw34239.pp svneol=native#text/pascal tests/webtbs/tw34239.pp svneol=native#text/pascal
tests/webtbs/tw34287.pp svneol=native#text/pascal
tests/webtbs/tw3429.pp svneol=native#text/plain tests/webtbs/tw3429.pp svneol=native#text/plain
tests/webtbs/tw3433.pp svneol=native#text/plain tests/webtbs/tw3433.pp svneol=native#text/plain
tests/webtbs/tw3435.pp svneol=native#text/plain tests/webtbs/tw3435.pp svneol=native#text/plain
@ -16859,6 +16860,8 @@ tests/webtbs/uw3340.pp svneol=native#text/plain
tests/webtbs/uw3353.pp svneol=native#text/plain tests/webtbs/uw3353.pp svneol=native#text/plain
tests/webtbs/uw3356.pp svneol=native#text/plain tests/webtbs/uw3356.pp svneol=native#text/plain
tests/webtbs/uw33839.pp -text svneol=native#text/pascal tests/webtbs/uw33839.pp -text svneol=native#text/pascal
tests/webtbs/uw34287a.pp svneol=native#text/pascal
tests/webtbs/uw34287b.pp svneol=native#text/pascal
tests/webtbs/uw3429.pp svneol=native#text/plain tests/webtbs/uw3429.pp svneol=native#text/plain
tests/webtbs/uw3474a.pp svneol=native#text/plain tests/webtbs/uw3474a.pp svneol=native#text/plain
tests/webtbs/uw3474b.pp svneol=native#text/plain tests/webtbs/uw3474b.pp svneol=native#text/plain

View File

@ -3362,6 +3362,9 @@ implementation
filepos : tfileposinfo; filepos : tfileposinfo;
callflags : tcallnodeflags; callflags : tcallnodeflags;
idstr : tidstring; idstr : tidstring;
spezcontext : tspecializationcontext;
isspecialize,
mightbegeneric,
useself, useself,
dopostfix, dopostfix,
again, again,
@ -3483,6 +3486,7 @@ implementation
hclassdef:=java_fpcbaserecordtype hclassdef:=java_fpcbaserecordtype
else else
internalerror(2012012401); internalerror(2012012401);
spezcontext:=nil;
{ if inherited; only then we need the method with { if inherited; only then we need the method with
the same name } the same name }
if token <> _ID then if token <> _ID then
@ -3508,6 +3512,18 @@ implementation
end end
else else
begin begin
if not (m_delphi in current_settings.modeswitches) and
(block_type in inline_specialization_block_types) and
(token=_ID) and
(idtoken=_SPECIALIZE) then
begin
consume(_ID);
if token<>_ID then
message(parser_e_methode_id_expected);
isspecialize:=true;
end
else
isspecialize:=false;
hs:=pattern; hs:=pattern;
hsorg:=orgpattern; hsorg:=orgpattern;
consume(_ID); consume(_ID);
@ -3517,53 +3533,71 @@ implementation
searchsym_in_helper(tobjectdef(current_structdef),tobjectdef(current_structdef),hs,srsym,srsymtable,[ssf_has_inherited]) searchsym_in_helper(tobjectdef(current_structdef),tobjectdef(current_structdef),hs,srsym,srsymtable,[ssf_has_inherited])
else else
searchsym_in_class(hclassdef,current_structdef,hs,srsym,srsymtable,[ssf_search_helper]); searchsym_in_class(hclassdef,current_structdef,hs,srsym,srsymtable,[ssf_search_helper]);
if isspecialize and assigned(srsym) then
begin
if not handle_specialize_inline_specialization(srsym,srsymtable,spezcontext) then
srsym:=nil;
end;
end; end;
if assigned(srsym) then if assigned(srsym) then
begin begin
check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg); mightbegeneric:=(m_delphi in current_settings.modeswitches) and
(token in [_LT,_LSHARPBRACKET]) and
(sp_generic_dummy in srsym.symoptions);
{ load the procdef from the inherited class and { load the procdef from the inherited class and
not from self } not from self }
case srsym.typ of case srsym.typ of
typesym,
procsym: procsym:
begin begin
useself:=false; { typesym is only a valid choice if we're dealing
if is_objectpascal_helper(current_structdef) then with a potential generic }
if (srsym.typ=typesym) and not mightbegeneric then
begin begin
{ for a helper load the procdef either from the Message(parser_e_methode_id_expected);
extended type, from the parent helper or from p1:=cerrornode.create;
the extended type of the parent helper end
depending on the def the found symbol belongs else
to } begin
if (srsym.Owner.defowner.typ=objectdef) and useself:=false;
is_objectpascal_helper(tobjectdef(srsym.Owner.defowner)) then if is_objectpascal_helper(current_structdef) then
if def_is_related(current_structdef,tdef(srsym.Owner.defowner)) and begin
assigned(tobjectdef(current_structdef).childof) then { for a helper load the procdef either from the
hdef:=tobjectdef(current_structdef).childof extended type, from the parent helper or from
else the extended type of the parent helper
begin depending on the def the found symbol belongs
hdef:=tobjectdef(srsym.Owner.defowner).extendeddef; to }
useself:=true; if (srsym.Owner.defowner.typ=objectdef) and
end is_objectpascal_helper(tobjectdef(srsym.Owner.defowner)) then
if def_is_related(current_structdef,tdef(srsym.Owner.defowner)) and
assigned(tobjectdef(current_structdef).childof) then
hdef:=tobjectdef(current_structdef).childof
else
begin
hdef:=tobjectdef(srsym.Owner.defowner).extendeddef;
useself:=true;
end
else
begin
hdef:=tdef(srsym.Owner.defowner);
useself:=true;
end;
end
else
hdef:=hclassdef;
if (po_classmethod in current_procinfo.procdef.procoptions) or
(po_staticmethod in current_procinfo.procdef.procoptions) then
hdef:=cclassrefdef.create(hdef);
if useself then
begin
p1:=ctypeconvnode.create_internal(load_self_node,hdef);
end
else else
begin begin
hdef:=tdef(srsym.Owner.defowner); p1:=ctypenode.create(hdef);
useself:=true; { we need to allow helpers here }
ttypenode(p1).helperallowed:=true;
end; end;
end
else
hdef:=hclassdef;
if (po_classmethod in current_procinfo.procdef.procoptions) or
(po_staticmethod in current_procinfo.procdef.procoptions) then
hdef:=cclassrefdef.create(hdef);
if useself then
begin
p1:=ctypeconvnode.create_internal(load_self_node,hdef);
end
else
begin
p1:=ctypenode.create(hdef);
{ we need to allow helpers here }
ttypenode(p1).helperallowed:=true;
end; end;
end; end;
propertysym: propertysym:
@ -3574,11 +3608,22 @@ implementation
p1:=cerrornode.create; p1:=cerrornode.create;
end; end;
end; end;
callflags:=[cnf_inherited]; if mightbegeneric then
include(current_procinfo.flags,pi_has_inherited); begin
if anon_inherited then p1:=cspecializenode.create_inherited(p1,getaddr,srsym,hclassdef);
include(callflags,cnf_anon_inherited); end
do_member_read(hclassdef,getaddr,srsym,p1,again,callflags,nil); else
begin
if not isspecialize then
check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
callflags:=[cnf_inherited];
include(current_procinfo.flags,pi_has_inherited);
if anon_inherited then
include(callflags,cnf_anon_inherited);
do_member_read(hclassdef,getaddr,srsym,p1,again,callflags,spezcontext);
end;
if p1.nodetype=errorn then
spezcontext.free;
end end
else else
begin begin
@ -3622,7 +3667,8 @@ implementation
again:=false; again:=false;
p1:=cerrornode.create; p1:=cerrornode.create;
end; end;
postfixoperators(p1,again,getaddr); if p1.nodetype<>specializen then
postfixoperators(p1,again,getaddr);
end; end;
_INTCONST : _INTCONST :
@ -4045,18 +4091,22 @@ implementation
getaddr : boolean; getaddr : boolean;
pload : tnode; pload : tnode;
spezcontext : tspecializationcontext; spezcontext : tspecializationcontext;
structdef : tabstractrecorddef; structdef,
inheriteddef : tabstractrecorddef;
callflags : tcallnodeflags;
begin begin
if n.nodetype=specializen then if n.nodetype=specializen then
begin begin
getaddr:=tspecializenode(n).getaddr; getaddr:=tspecializenode(n).getaddr;
pload:=tspecializenode(n).left; pload:=tspecializenode(n).left;
inheriteddef:=tabstractrecorddef(tspecializenode(n).inheriteddef);
tspecializenode(n).left:=nil; tspecializenode(n).left:=nil;
end end
else else
begin begin
getaddr:=false; getaddr:=false;
pload:=nil; pload:=nil;
inheriteddef:=nil;
end; end;
if assigned(parseddef) and assigned(gensym) and assigned(p2) then if assigned(parseddef) and assigned(gensym) and assigned(p2) then
@ -4104,21 +4154,31 @@ implementation
begin begin
result:=pload; result:=pload;
typecheckpass(result); typecheckpass(result);
structdef:=nil; structdef:=inheriteddef;
case result.resultdef.typ of if not assigned(structdef) then
objectdef, case result.resultdef.typ of
recorddef: objectdef,
begin recorddef:
structdef:=tabstractrecorddef(result.resultdef); begin
end; structdef:=tabstractrecorddef(result.resultdef);
classrefdef: end;
begin classrefdef:
structdef:=tabstractrecorddef(tclassrefdef(result.resultdef).pointeddef); begin
end; structdef:=tabstractrecorddef(tclassrefdef(result.resultdef).pointeddef);
else end;
internalerror(2015092703); else
end; internalerror(2015092703);
do_member_read(structdef,getaddr,gensym,result,again,[],spezcontext); end;
if not (structdef.typ in [recorddef,objectdef]) then
internalerror(2018092101);
if assigned(inheriteddef) then
begin
callflags:=[cnf_inherited];
include(current_procinfo.flags,pi_has_inherited);
end
else
callflags:=[];
do_member_read(structdef,getaddr,gensym,result,again,callflags,spezcontext);
spezcontext:=nil; spezcontext:=nil;
end end
else else

22
tests/webtbs/tw34287.pp Normal file
View File

@ -0,0 +1,22 @@
{ %NORUN }
program tw34287;
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
uses
Classes,
uw34287a,
uw34287b;
var
fooa: uw34287a.TFoo;
foob: uw34287b.TFoo;
begin
fooa := uw34287a.TFoo.Create(nil);
fooa.Bar('');
foob := uw34287b.TFoo.Create(nil);
foob.Bar('');
end.

37
tests/webtbs/uw34287a.pp Normal file
View File

@ -0,0 +1,37 @@
unit uw34287a;
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
interface
uses
Classes;
type
TBase = class(TComponent)
public
function Bar<T: TComponent>(const P1: string; out P2: T): Boolean;
end;
TFoo = class(TBase)
public
function Bar(const P1: string): Boolean;
end;
implementation
function TBase.Bar<T>(const P1: string; out P2: T): Boolean;
begin
Result := False;
end;
function TFoo.Bar(const P1: string): Boolean;
var
C: TComponent;
begin
Result := inherited Bar<TComponent>(P1, C);
end;
end.

37
tests/webtbs/uw34287b.pp Normal file
View File

@ -0,0 +1,37 @@
unit uw34287b;
{$IFDEF FPC}
{$MODE OBJFPC}{$H+}
{$ENDIF}
interface
uses
Classes;
type
TBase = class(TComponent)
public
generic function Bar<T: TComponent>(const P1: string; out P2: T): Boolean;
end;
TFoo = class(TBase)
public
function Bar(const P1: string): Boolean;
end;
implementation
generic function TBase.Bar<T>(const P1: string; out P2: T): Boolean;
begin
Result := False;
end;
function TFoo.Bar(const P1: string): Boolean;
var
C: TComponent;
begin
Result := inherited specialize Bar<TComponent>(P1, C);
end;
end.