paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-31 11:50:51 +02:00
Code Issues Packages Projects Releases Wiki Activity

* 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

Browse Source 
+ 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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
compiler/htypechk.pas
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;

11
compiler/nld.pas
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.