Browse Source

* fix #39902: in case of mode ObjFPC function pointers passed to parameters need to be checked for the correct procdef as well
+ added adjusted/extended test

Sven/Sarah Barth 2 years ago
parent
commit
e21186cac0
2 changed files with 68 additions and 0 deletions
  1. 20 0
      compiler/htypechk.pas
  2. 48 0
      tests/webtbs/tw39902b.pp

+ 20 - 0
compiler/htypechk.pas

@@ -2995,6 +2995,26 @@ implementation
                    end;
                    end;
                end;
                end;
 
 
+             { same as above, but for the case that we have a proc-2-procvar
+               conversion together with a load }
+             if (def_to.typ=procvardef) and
+                (currpt.left.nodetype=typeconvn) and
+                (ttypeconvnode(currpt.left).convtype=tc_proc_2_procvar) and
+                (ttypeconvnode(currpt.left).totypedef=voidtype) and
+                not (nf_explicit in currpt.left.flags) and
+                (ttypeconvnode(currpt.left).left.nodetype=loadn) and
+                (ttypeconvnode(currpt.left).left.resultdef.typ=procdef) then
+               begin
+                 pdtemp:=tprocsym(tloadnode(ttypeconvnode(currpt.left).left).symtableentry).Find_procdef_byprocvardef(Tprocvardef(def_to));
+                 if assigned(pdtemp) then
+                   begin
+                     tloadnode(ttypeconvnode(currpt.left).left).setprocdef(pdtemp);
+                     ttypeconvnode(currpt.left).totypedef:=cprocvardef.getreusableprocaddr(pdtemp,pc_normal);
+                     ttypeconvnode(currpt.left).resultdef:=ttypeconvnode(currpt.left).totypedef;
+                     def_from:=ttypeconvnode(currpt.left).resultdef;
+                   end;
+               end;
+
               { varargs are always equal, but not exact }
               { varargs are always equal, but not exact }
               if (po_varargs in hp^.data.procoptions) and
               if (po_varargs in hp^.data.procoptions) and
                  (currparanr>hp^.data.minparacount) and
                  (currparanr>hp^.data.minparacount) and

+ 48 - 0
tests/webtbs/tw39902b.pp

@@ -0,0 +1,48 @@
+{ %NORUN }
+
+program tw39902b;
+
+{$mode objfpc}
+
+uses Classes;
+
+type TTest = class(TObject)
+ FEvent: TNotifyEvent;
+ procedure SetEvent(aValue: TNotifyEvent);
+ procedure SomeEvent (Sender: NativeInt); overload;
+ procedure SomeEvent (Sender: TObject); overload;
+ property Event1: TNotifyEvent read FEvent write FEvent;
+ property Event2: TNotifyEvent read FEvent write SetEvent;
+end;
+
+procedure TTest.SetEvent(aValue: TNotifyEvent);
+begin
+  FEvent:=aValue;
+end;
+
+procedure TTest.SomeEvent (Sender: TObject);
+begin
+end;
+
+procedure TTest.SomeEvent (Sender: NativeInt);
+begin
+end;
+
+procedure Foo(aArg: TNotifyEvent);
+begin
+
+end;
+
+var
+ x: TTest;
+ //y: TStringList;
+ m: TNotifyEvent;
+begin
+ x := TTest.Create;
+ //y := TStringList.Create;
+ //y.OnChange := x.SomeEvent;
+ x.Event1 := @x.SomeEvent;
+ x.Event2 := @x.SomeEvent;
+ m := @x.SomeEvent;
+ Foo(@x.someEvent);
+end.