paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-06 15:47:52 +02:00
Code Issues Packages Projects Releases Wiki Activity

WPO: also consider NewInstance to detect class instancing

Browse Source 
Resolves #40200
This commit is contained in:
Jonas Maebe 2023-03-18 15:07:24 +01:00
parent 71863e1b2c
commit 0e46041717
3 changed files with 76 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
compiler/ncal.pas
View File

@ -57,7 +57,8 @@ interface
cnf_call_self_node_done,{ the call_self_node has been generated if necessary
(to prevent it from potentially happening again in a wrong context in case of constant propagation or so) }
cnf_ignore_visibility, { internally generated call that should ignore visibility checks }
cnf_check_fpu_exceptions { after the call fpu exceptions shall be checked }
cnf_check_fpu_exceptions, { after the call fpu exceptions shall be checked }
cnf_ignore_devirt_wpo { ignore this call for devirtualisatio info tracking: calls to newinstance generated by the compiler do not result in extra class types being instanced }
);
tcallnodeflags = set of tcallnodeflag;
@ -2560,10 +2561,22 @@ implementation
{ only makes sense for methods }
if not assigned(methodpointer) then
exit;
{ inherited calls don't create an instance of the inherited type, but of
the current type }
if ([cnf_inherited,cnf_anon_inherited,cnf_ignore_devirt_wpo]*callnodeflags)<>[] then
exit;
if (methodpointer.resultdef.typ=classrefdef) then
begin
{ constructor call via classreference => allocate memory }
if (procdefinition.proctypeoption=potype_constructor) then
{ constructor call via classreference => instance can be created
same with calling newinstance without a instance-self (don't
consider self-based newinstance calls, because then everything
will be assumed to be just a TObject since TObject.Create calls
NewInstance) }
if (procdefinition.proctypeoption=potype_constructor) or
((procdefinition.typ=procdef) and
((methodpointer.resultdef.typ=classrefdef) or
(methodpointer.nodetype=typen)) and
(tprocdef(procdefinition).procsym.Name='NEWINSTANCE')) then
begin
{ Only a typenode can be passed when it is called with <class of xx>.create }
if (methodpointer.nodetype=typen) then

9
compiler/psub.pas
View File

@ -512,6 +512,11 @@ implementation
(srsym.typ=procsym) then
begin
{ if vmt=1 then newinstance }
call:=
ccallnode.create(nil,tprocsym(srsym),srsym.owner,
ctypeconvnode.create_internal(load_self_pointer_node,cclassrefdef.create(current_structdef)),
[],nil);
include(call.callnodeflags,cnf_ignore_devirt_wpo);
addstatement(newstatement,cifnode.create(
caddnode.create_internal(equaln,
ctypeconvnode.create_internal(
@ -522,9 +527,7 @@ implementation
ctypeconvnode.create_internal(
load_self_pointer_node,
voidpointertype),
ccallnode.create(nil,tprocsym(srsym),srsym.owner,
ctypeconvnode.create_internal(load_self_pointer_node,cclassrefdef.create(current_structdef)),
[],nil)),
call),
nil));
end
else

54
tests/webtbs/tw40200.pp Normal file
View File

@ -0,0 +1,54 @@
{ %wpoparas=devirtcalls }
{ %wpopasses=1 }
{$mode objfpc}
type
tderived = class;
tbase = class
procedure test; virtual;
end;
tbaseclass = class of tbase;
tbasetop = class(tbase)
function alloc(c: tbaseclass): tbase;
function getderived: tderived;
end;
tderived = class(tbase)
procedure test; override;
end;
procedure tbase.test;
begin
writeln('error');
halt(1);
end;
function tbasetop.alloc(c: tbaseclass): tbase;
begin
result:=tbase(c.newinstance);
end;
function tbasetop.getderived: tderived;
begin
result:=tderived(alloc(tderived));
result.create;
end;
procedure tderived.test;
begin
writeln('ok');
end;
var
t: tbasetop;
b: tbase;
begin
t:=tbasetop.create;
b:=tbase(t.getderived);
b.test;
b.free;
t.free;
end.