mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-31 04:50:17 +02:00
* 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:
parent
feb79e0068
commit
981ec64666
@ -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;
|
||||
|
@ -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
43
tests/webtbs/tw40594.pp
Normal 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.
|
||||
|
Loading…
Reference in New Issue
Block a user