Browse Source

* fix #39978: ensure that Self is captured when a method of the current class is captured into a function reference
+ added test

Sven/Sarah Barth 2 years ago
parent
commit
b051e7667c
2 changed files with 60 additions and 4 deletions
  1. 17 4
      compiler/procdefutil.pas
  2. 43 0
      tests/webtbs/tw39978.pp

+ 17 - 4
compiler/procdefutil.pas

@@ -1094,10 +1094,23 @@ implementation
       { does this need to capture Self? }
       else if not foreachnodestatic(pm_postprocess,n,@find_self_sym,@selfinfo) then
         begin
-          { does this need some other local variable or parameter? }
-          foreachnodestatic(pm_postprocess,n,@collect_syms_to_capture,@pd)
-        end
-      else if not assigned(fieldsym) then
+          { is this a method of the current class? }
+          if (n.resultdef.typ=procdef) and
+              assigned(tprocdef(n.resultdef).struct) and
+              not (po_staticmethod in tprocdef(n.resultdef).procoptions) and
+              assigned(current_procinfo.procdef.struct) and
+              def_is_related(current_procinfo.procdef.struct,tprocdef(n.resultdef).struct) then
+            begin
+              selfinfo.selfsym:=tsym(current_procinfo.procdef.parast.find('self'));
+              if not assigned(selfinfo.selfsym) then
+                internalerror(2022110601);
+            end
+          else
+            { does this need some other local variable or parameter? }
+            foreachnodestatic(pm_postprocess,n,@collect_syms_to_capture,@pd)
+        end;
+
+      if assigned(selfinfo.selfsym) and not assigned(fieldsym) then
         { this isn't a procdef that was captured into a field, so capture the
           self }
         pd.add_captured_sym(selfinfo.selfsym,n.fileinfo);

+ 43 - 0
tests/webtbs/tw39978.pp

@@ -0,0 +1,43 @@
+program tw39978;
+
+{$IFDEF FPC}
+{$mode delphi}
+{$ModeSwitch functionreferences}
+{$ELSE}
+{$APPTYPE CONSOLE}
+{$ENDIF}
+
+type
+  TRefProc = reference to procedure(Sender: TObject);
+
+procedure Test(P: TRefProc);
+begin
+  P(nil);
+end;
+
+type
+  TMyObj = class(TObject)
+  public
+    procedure MyEvent(Sender: TObject);
+    procedure MyTest;
+  end;
+
+var
+  Obj: TMyObj;
+
+{ TMyObj }
+procedure TMyObj.MyEvent(Sender: TObject);
+begin
+  if (Self<>Obj) then // solved with ObjFpc mode and Test(@MyEvent); using Self.MyEvent doesn't help either
+    Halt(1);
+end;
+procedure TMyObj.MyTest;
+begin
+  Test(MyEvent);
+end;
+
+begin
+  Obj := TMyObj.Create;
+  Obj.MyTest;
+end.
+