ソースを参照

* 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

Sven/Sarah Barth 1 年間 前
コミット
981ec64666
3 ファイル変更52 行追加6 行削除
  1. 2 2
      compiler/htypechk.pas
  2. 7 4
      compiler/nld.pas
  3. 43 0
      tests/webtbs/tw40594.pp

+ 2 - 2
compiler/htypechk.pas

@@ -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;

+ 7 - 4
compiler/nld.pas

@@ -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 - 0
tests/webtbs/tw40594.pp

@@ -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.
+