* fix #40594: when assigning a nested function to a function reference don't check for the nested procvars parameter, because nested functions can be treated like anonymous functions here

+ added test
This commit is contained in:
Sven/Sarah Barth 2024-01-22 22:25:18 +01:00
parent feb79e0068
commit 981ec64666
3 changed files with 52 additions and 6 deletions

View File

@ -2997,7 +2997,7 @@ implementation
pdtemp:=tprocsym(tloadnode(currpt.left).symtableentry).find_procdef_byfuncrefdef(tobjectdef(def_to));
if assigned(pdtemp) then
begin
tloadnode(currpt.left).setprocdef(pdtemp);
tloadnode(currpt.left).setprocdef(pdtemp,def_to.typ<>procvardef);
currpt.resultdef:=currpt.left.resultdef;
def_from:=currpt.left.resultdef;
end;
@ -3022,7 +3022,7 @@ implementation
pdtemp:=tprocsym(tloadnode(ttypeconvnode(currpt.left).left).symtableentry).find_procdef_byfuncrefdef(tobjectdef(def_to));
if assigned(pdtemp) then
begin
tloadnode(ttypeconvnode(currpt.left).left).setprocdef(pdtemp);
tloadnode(ttypeconvnode(currpt.left).left).setprocdef(pdtemp,def_to.typ<>procvardef);
ttypeconvnode(currpt.left).totypedef:=cprocvardef.getreusableprocaddr(pdtemp,pc_normal);
ttypeconvnode(currpt.left).resultdef:=ttypeconvnode(currpt.left).totypedef;
def_from:=ttypeconvnode(currpt.left).resultdef;

View File

@ -77,7 +77,7 @@ interface
{$ifdef DEBUG_NODE_XML}
procedure XMLPrintNodeData(var T: Text); override;
{$endif DEBUG_NODE_XML}
procedure setprocdef(p : tprocdef);
procedure setprocdef(p : tprocdef;forfuncref:boolean);
property procdef: tprocdef read fprocdef;
end;
tloadnodeclass = class of tloadnode;
@ -505,9 +505,11 @@ implementation
end;
procsym :
begin
{ initialise left for nested procs if necessary }
{ initialise left for nested procs if necessary (this won't need
to pass true for the forfuncref parameter, cause code that would
need that wouldn't have been reworked before it reaches pass_1) }
if (m_nested_procvars in current_settings.modeswitches) then
setprocdef(fprocdef);
setprocdef(fprocdef,false);
{ method pointer or nested proc ? }
if assigned(left) then
begin
@ -557,13 +559,14 @@ implementation
end;
{$endif DEBUG_NODE_XML}
procedure tloadnode.setprocdef(p : tprocdef);
procedure tloadnode.setprocdef(p : tprocdef;forfuncref:boolean);
begin
fprocdef:=p;
resultdef:=p;
{ nested procedure? }
if assigned(p) and
is_nested_pd(p) and
not forfuncref and
(
not (po_anonymous in p.procoptions) or
(po_delphi_nested_cc in p.procoptions)

43
tests/webtbs/tw40594.pp Normal file
View File

@ -0,0 +1,43 @@
program tw40594;
{$mode objfpc}
{$modeswitch functionreferences}
type
TNotifyProc = reference to procedure(aArg: LongInt{Sender : TObject});
Procedure DoCall(aProc : TNotifyProc; aArg: LongInt);
begin
aProc(aArg);
end;
Procedure DoTest;
var
a: LongInt;
procedure HandleCall(aArg: LongInt{Sender : TObject});
begin
//Writeln('Nil passed: ',Sender=Nil);
a := aArg;
end;
var
p : TNotifyProc;
begin
P:=@HandleCall;
a := 0;
DoCall(P, 42); // OK
if a <> 42 then
Halt(1);
DoCall(@HandleCall, 21); // Not OK
if a <> 21 then
Halt(2);
end;
begin
DoTest;
end.