* implement assignment of procedure and method variables and routines (global, instance and nested) to function references

compiler/defcmp.pas

@@ -109,7 +109,8 @@ interface
           tc_elem_2_openarray,
           tc_arrayconstructor_2_dynarray,
           tc_arrayconstructor_2_array,
-          tc_anonproc_2_funcref
+          tc_anonproc_2_funcref,
+          tc_procvar_2_funcref
        );
 
     function compare_defs_ext(def_from,def_to : tdef;
@@ -1956,6 +1957,19 @@ implementation
                        eq:=te_convert_l1;
                        doconv:=tc_equal;
                      end
+                   else if is_funcref(def_to) and
+                     (def_from.typ in [procdef,procvardef]) then
+                     begin
+                       subeq:=proc_to_funcref_conv(tabstractprocdef(def_from),tobjectdef(def_to));
+                       if subeq>te_incompatible then
+                         begin
+                           doconv:=tc_procvar_2_funcref;
+                           if subeq>te_convert_l5 then
+                             eq:=pred(subeq)
+                           else
+                             eq:=subeq;
+                         end;
+                     end
                    else if (def_from.typ=variantdef) and is_interfacecom_or_dispinterface(def_to) then
                      begin
                      { corbainterfaces not accepted, until we have
@@ -2534,37 +2548,45 @@ implementation
              a) anything but procvars can be assigned to blocks
              b) depending on their captured symbols anonymous functions can be
                 assigned to global, method or nested procvars
-             c) if one is a procedure of object, the other also has to be one
+             c) anything can be assigned to function references
+             d) if one is a procedure of object, the other also has to be one
                 ("object static procedure" is equal to procedure as well)
                 (except for block)
-             d) if one is a pure address, the other also has to be one
+             e) if one is a pure address, the other also has to be one
                 except if def1 is a global proc and def2 is a nested procdef
                 (global procedures can be converted into nested procvars)
-             e) if def1 is a nested procedure, then def2 has to be a nested
+             f) if def1 is a nested procedure, then def2 has to be a nested
                 procvar and def1 has to have the po_delphi_nested_cc option
                 or does not use parentfp
-             f) if def1 is a procvar, def1 and def2 both have to be nested or
+             g) if def1 is a procvar, def1 and def2 both have to be nested or
                 non-nested (we don't allow assignments from non-nested to
                 nested procvars to make sure that we can still implement
                 nested procvars using trampolines -- e.g., this would be
                 necessary for LLVM or CIL as long as they do not have support
                 for Delphi-style frame pointer parameter passing) }
          if is_block(def2) or                                                           { a) }
-            (po_anonymous in def1.procoptions) then                                     { b) }
+            (po_anonymous in def1.procoptions) or                                       { b) }
+            (
+              (po_is_function_ref in def2.procoptions) and
+              (
+                (def1.typ<>procdef) or
+                not (po_delphi_nested_cc in def1.procoptions)
+              )                                                                         { c) }
+            ) then
            { can't explicitly check against procvars here, because
              def1 may already be a procvar due to a proc_to_procvar;
              this is checked in the type conversion node itself -> ok }
          else if
-            ((def1.is_methodpointer and not (po_staticmethod in def1.procoptions))<> { c) }
+            ((def1.is_methodpointer and not (po_staticmethod in def1.procoptions))<> { d) }
              (def2.is_methodpointer and not (po_staticmethod in def2.procoptions))) or
-            ((def1.is_addressonly<>def2.is_addressonly) and         { d) }
+            ((def1.is_addressonly<>def2.is_addressonly) and         { e) }
              (is_nested_pd(def1) or
               not is_nested_pd(def2))) or
-            ((def1.typ=procdef) and                                 { e) }
+            ((def1.typ=procdef) and                                 { f) }
              is_nested_pd(def1) and
              (not(po_delphi_nested_cc in def1.procoptions) or
               not is_nested_pd(def2))) or
-            ((def1.typ=procvardef) and                              { f) }
+            ((def1.typ=procvardef) and                              { g) }
              (is_nested_pd(def1)<>is_nested_pd(def2))) then
            exit;
          pa_comp:=[cpo_ignoreframepointer];

compiler/htypechk.pas

@@ -2134,6 +2134,18 @@ implementation
               if tmpeq<>te_incompatible then
                 eq:=tmpeq;
             end;
+          objectdef :
+            begin
+              tmpeq:=te_incompatible;
+              { in tp/macpas mode proc -> funcref is allowed }
+              if ((m_tp_procvar in current_settings.modeswitches) or
+                  (m_mac_procvar in current_settings.modeswitches)) and
+                 (p.left.nodetype=calln) and
+                 is_invokable(def_to) then
+                tmpeq:=proc_to_funcref_equal(tprocdef(tcallnode(p.left).procdefinition),tobjectdef(def_to));
+              if tmpeq<>te_incompatible then
+                eq:=tmpeq;
+            end;
           arraydef :
             begin
               { an arrayconstructor of proccalls may have to be converted to

compiler/ncnv.pas

@@ -121,6 +121,7 @@ interface
           function typecheck_arrayconstructor_to_dynarray : tnode; virtual;
           function typecheck_arrayconstructor_to_array : tnode; virtual;
           function typecheck_anonproc_2_funcref : tnode; virtual;
+          function typecheck_procvar_2_funcref : tnode; virtual;
        private
           function _typecheck_int_to_int : tnode;
           function _typecheck_cord_to_pointer : tnode;
@@ -155,6 +156,7 @@ interface
           function _typecheck_arrayconstructor_to_dynarray : tnode;
           function _typecheck_arrayconstructor_to_array : tnode;
           function _typecheck_anonproc_to_funcref : tnode;
+          function _typecheck_procvar_to_funcref : tnode;
        protected
           function first_int_to_int : tnode;virtual;
           function first_cstring_to_pchar : tnode;virtual;
@@ -2346,6 +2348,12 @@ implementation
       end;
 
 
+    function ttypeconvnode._typecheck_procvar_to_funcref : tnode;
+      begin
+        result:=typecheck_procvar_2_funcref;
+      end;
+
+
     function ttypeconvnode._typecheck_anonproc_to_funcref : tnode;
       begin
         result:=typecheck_anonproc_2_funcref;
@@ -2647,6 +2655,62 @@ implementation
       end;
 
 
+    function ttypeconvnode.typecheck_procvar_2_funcref : tnode;
+      var
+        capturer : tsym;
+        intfdef : tdef;
+        ld,blck,hp : tnode;
+        stmt : tstatementnode;
+      begin
+        result:=nil;
+
+        if not(m_tp_procvar in current_settings.modeswitches) and
+           is_invokable(resultdef) and
+           (left.nodetype=typeconvn) and
+           (ttypeconvnode(left).convtype=tc_proc_2_procvar) and
+           is_methodpointer(left.resultdef) and
+           (po_classmethod in tprocvardef(left.resultdef).procoptions) and
+           not(po_staticmethod in tprocvardef(left.resultdef).procoptions) and
+           (proc_to_funcref_equal(tprocdef(ttypeconvnode(left).left.resultdef),tobjectdef(resultdef))>=te_convert_l1) then
+          begin
+            hp:=left;
+            left:=ttypeconvnode(left).left;
+            if (left.nodetype=loadn) and
+               not assigned(tloadnode(left).left) then
+              tloadnode(left).set_mp(cloadvmtaddrnode.create(ctypenode.create(tdef(tloadnode(left).symtable.defowner))));
+            left:=ctypeconvnode.create_proc_to_procvar(left);
+            ttypeconvnode(left).totypedef:=resultdef;
+            typecheckpass(left);
+            ttypeconvnode(hp).left:=nil;
+            hp.free;
+          end;
+
+        intfdef:=capturer_add_procvar_or_proc(current_procinfo,left,capturer,hp);
+        if assigned(intfdef) then
+          begin
+            if assigned(capturer) then
+              ld:=cloadnode.create(capturer,capturer.owner)
+            else
+              ld:=cnilnode.create;
+            result:=ctypeconvnode.create_internal(
+                      ctypeconvnode.create_internal(
+                        ld,
+                        intfdef),
+                      totypedef);
+            if assigned(hp) then
+              begin
+                blck:=internalstatements(stmt);
+                addstatement(stmt,cassignmentnode.create(hp,left));
+                left:=nil;
+                addstatement(stmt,result);
+                result:=blck;
+              end;
+          end;
+        if not assigned(result) then
+          result:=cerrornode.create;
+      end;
+
+
     function ttypeconvnode.typecheck_anonproc_2_funcref : tnode;
       var
         capturer : tsym;
@@ -2717,7 +2781,8 @@ implementation
           { elem_2_openarray } @ttypeconvnode._typecheck_elem_2_openarray,
           { arrayconstructor_2_dynarray } @ttypeconvnode._typecheck_arrayconstructor_to_dynarray,
           { arrayconstructor_2_array } @ttypeconvnode._typecheck_arrayconstructor_to_array,
-          { anonproc_2_funcref } @ttypeconvnode._typecheck_anonproc_to_funcref
+          { anonproc_2_funcref } @ttypeconvnode._typecheck_anonproc_to_funcref,
+          { procvar_2_funcref } @ttypeconvnode._typecheck_procvar_to_funcref
          );
       type
          tprocedureofobject = function : tnode of object;
@@ -2893,7 +2958,10 @@ implementation
                     use an extra check for them.}
                   if (left.nodetype=calln) and
                      (tcallnode(left).required_para_count=0) and
-                     (resultdef.typ=procvardef) and
+                     (
+                       (resultdef.typ=procvardef) or
+                       is_invokable(resultdef)
+                     ) and
                      (
                       (m_tp_procvar in current_settings.modeswitches) or
                       (m_mac_procvar in current_settings.modeswitches)
@@ -2909,8 +2977,16 @@ implementation
                       end
                      else
                       begin
-                        convtype:=tc_proc_2_procvar;
-                        currprocdef:=Tprocsym(Tcallnode(left).symtableprocentry).Find_procdef_byprocvardef(Tprocvardef(resultdef));
+                        if resultdef.typ=procvardef then
+                          begin
+                            convtype:=tc_proc_2_procvar;
+                            currprocdef:=Tprocsym(Tcallnode(left).symtableprocentry).Find_procdef_byprocvardef(Tprocvardef(resultdef));
+                          end
+                        else
+                          begin
+                            convtype:=tc_procvar_2_funcref;
+                            currprocdef:=tprocsym(tcallnode(left).symtableprocentry).find_procdef_byfuncrefdef(tobjectdef(resultdef));
+                          end;
                         hp:=cloadnode.create_procvar(tprocsym(tcallnode(left).symtableprocentry),
                             tprocdef(currprocdef),tcallnode(left).symtableproc);
                         if (tcallnode(left).symtableprocentry.owner.symtabletype=ObjectSymtable) then
@@ -2933,7 +3009,15 @@ implementation
                      { Now check if the procedure we are going to assign to
                        the procvar, is compatible with the procvar's type }
                      if not(nf_explicit in flags) and
-                        (proc_to_procvar_equal(currprocdef,tprocvardef(resultdef),false)=te_incompatible) then
+                        (
+                          (
+                            (resultdef.typ=procvardef) and
+                            (proc_to_procvar_equal(currprocdef,tprocvardef(resultdef),false)=te_incompatible)
+                          ) or (
+                            is_invokable(resultdef) and
+                            (proc_to_funcref_equal(currprocdef,tobjectdef(resultdef))=te_incompatible)
+                          )
+                        ) then
                        IncompatibleTypes(left.resultdef,resultdef)
                      else
                        result:=typecheck_call_helper(convtype);
@@ -4426,6 +4510,7 @@ implementation
            @ttypeconvnode._first_nothing,
            @ttypeconvnode._first_nothing,
            @ttypeconvnode._first_nothing,
+           nil,
            nil
          );
       type
@@ -4708,7 +4793,8 @@ implementation
            @ttypeconvnode._second_elem_to_openarray,  { elem_2_openarray }
            @ttypeconvnode._second_nothing,  { arrayconstructor_2_dynarray }
            @ttypeconvnode._second_nothing,  { arrayconstructor_2_array }
-           @ttypeconvnode._second_nothing   { anonproc_2_funcref }
+           @ttypeconvnode._second_nothing,  { anonproc_2_funcref }
+           @ttypeconvnode._second_nothing   { procvar_2_funcref }
          );
       type
          tprocedureofobject = procedure of object;

compiler/parser.pas

@@ -341,6 +341,7 @@ implementation
          named_args_allowed:=false;
          got_addrn:=false;
          getprocvardef:=nil;
+         getfuncrefdef:=nil;
 
        { show info }
          Message1(parser_i_compiling,filename);

compiler/pbase.pas

@@ -51,6 +51,9 @@ interface
        { special for handling procedure vars }
        getprocvardef : tprocvardef = nil;
 
+       { special for function reference vars }
+       getfuncrefdef : tobjectdef = nil;
+
     var
        { for operators }
        optoken : ttoken;

compiler/pexpr.pas

@@ -1019,12 +1019,15 @@ implementation
 
          { When we are expecting a procvar we also need
            to get the address in some cases }
-         if assigned(getprocvardef) then
+         if assigned(getprocvardef) or assigned(getfuncrefdef) then
           begin
             if (block_type=bt_const) or
                getaddr then
              begin
-               aprocdef:=Tprocsym(sym).Find_procdef_byprocvardef(getprocvardef);
+               if assigned(getfuncrefdef) then
+                 aprocdef:=Tprocsym(sym).Find_procdef_byfuncrefdef(getfuncrefdef)
+               else
+                 aprocdef:=Tprocsym(sym).Find_procdef_byprocvardef(getprocvardef);
                getaddr:=true;
              end
             else
@@ -1032,7 +1035,10 @@ implementation
                  (m_mac_procvar in current_settings.modeswitches)) and
                 not(token in [_CARET,_POINT,_LKLAMMER]) then
               begin
-                aprocdef:=Tprocsym(sym).Find_procdef_byprocvardef(getprocvardef);
+                if assigned(getfuncrefdef) then
+                  aprocdef:=Tprocsym(sym).Find_procdef_byfuncrefdef(getfuncrefdef)
+                else
+                  aprocdef:=Tprocsym(sym).Find_procdef_byprocvardef(getprocvardef);
                 if assigned(aprocdef) then
                  getaddr:=true;
               end;
@@ -1059,6 +1065,9 @@ implementation
              if not assigned(aprocdef) and
                 assigned(getprocvardef) then
                aprocdef:=Tprocsym(sym).Find_procdef_byprocvardef(getprocvardef);
+             if not assigned(aprocdef) and
+                assigned(getfuncrefdef) then
+               aprocdef:=Tprocsym(sym).Find_procdef_byfuncrefdef(getfuncrefdef);
 
              { generate a methodcallnode or proccallnode }
              { we shouldn't convert things like @tcollection.load }
@@ -1079,7 +1088,11 @@ implementation
                 else
                   begin
                     typecheckpass(p1);
-                    if (p1.resultdef.typ=classrefdef) and assigned(getprocvardef) then
+                    if (p1.resultdef.typ=classrefdef) and
+                       (
+                         assigned(getprocvardef) or
+                         assigned(getfuncrefdef)
+                       ) then
                       begin
                         p1:=cloadvmtaddrnode.create(p1);
                         tloadnode(p2).set_mp(p1);
@@ -1186,6 +1199,45 @@ implementation
       end;
 
 
+    procedure handle_funcref(fr:tobjectdef;var p2:tnode);
+      var
+        hp,hp2 : tnode;
+        hpp    : ^tnode;
+        currprocdef : tprocdef;
+      begin
+        if not assigned(fr) then
+          internalerror(2022032401);
+        if not is_invokable(fr) then
+          internalerror(2022032402);
+        if (m_tp_procvar in current_settings.modeswitches) or
+           (m_mac_procvar in current_settings.modeswitches) then
+         begin
+           hp:=p2;
+           hpp:=@p2;
+           while assigned(hp) and
+                 (hp.nodetype=typeconvn) do
+            begin
+              hp:=ttypeconvnode(hp).left;
+              { save orignal address of the old tree so we can replace the node }
+              hpp:=@hp;
+            end;
+           if (hp.nodetype=calln) and
+              { a procvar can't have parameters! }
+              not assigned(tcallnode(hp).left) then
+            begin
+              currprocdef:=tcallnode(hp).symtableprocentry.Find_procdef_byfuncrefdef(fr);
+              if assigned(currprocdef) then
+               begin
+                 hp2:=cloadnode.create_procvar(tprocsym(tcallnode(hp).symtableprocentry),currprocdef,tcallnode(hp).symtableproc);
+                 hp.free;
+                 { replace the old callnode with the new loadnode }
+                 hpp^:=hp2;
+               end;
+            end;
+         end;
+      end;
+
+
     { the following procedure handles the access to a property symbol }
     procedure handle_propertysym(propsym : tpropertysym;st : TSymtable;var p1 : tnode);
       var
@@ -1234,14 +1286,19 @@ implementation
                          consume(_ASSIGNMENT);
                          { read the expression }
                          if propsym.propdef.typ=procvardef then
-                           getprocvardef:=tprocvardef(propsym.propdef);
+                           getprocvardef:=tprocvardef(propsym.propdef)
+                         else if is_invokable(propsym.propdef) then
+                           getfuncrefdef:=tobjectdef(propsym.propdef);
                          p2:=comp_expr([ef_accept_equal]);
                          if assigned(getprocvardef) then
-                           handle_procvar(getprocvardef,p2);
+                           handle_procvar(getprocvardef,p2)
+                         else if assigned(getfuncrefdef) then
+                           handle_funcref(getfuncrefdef,p2);
                          tcallnode(p1).left:=ccallparanode.create(p2,tcallnode(p1).left);
                          { mark as property, both the tcallnode and the real call block }
                          include(p1.flags,nf_isproperty);
                          getprocvardef:=nil;
+                         getfuncrefdef:=nil;
                        end;
                      fieldvarsym :
                        begin
@@ -2804,6 +2861,10 @@ implementation
                      (
                       assigned(getprocvardef) and
                       equal_defs(p1.resultdef,getprocvardef)
+                     ) or
+                     (
+                      assigned(getfuncrefdef) and
+                      equal_defs(p1.resultdef,getfuncrefdef)
                      ) then
                     begin
                       if try_to_consume(_LKLAMMER) then
@@ -3583,7 +3644,8 @@ implementation
          again,
          updatefpos,
          nodechanged  : boolean;
-         oldprocvardef: tprocvardef;
+         oldprocvardef : tprocvardef;
+         oldfuncrefdef : tobjectdef;
       begin
         { can't keep a copy of p1 and compare pointers afterwards, because
           p1 may be freed and reallocated in the same place!  }
@@ -4195,9 +4257,12 @@ implementation
                      (m_anonymous_functions in current_settings.modeswitches) then
                    begin
                      oldprocvardef:=getprocvardef;
+                     oldfuncrefdef:=getfuncrefdef;
                      getprocvardef:=nil;
+                     getfuncrefdef:=nil;
                      pd:=read_proc([rpf_anonymous],nil);
                      getprocvardef:=oldprocvardef;
+                     getfuncrefdef:=oldfuncrefdef;
                      { assume that we try to get the address except if certain
                        tokens follow that indicate a call }
                      do_proc_call(pd.procsym,pd.owner,nil,not (token in [_POINT,_CARET,_LECKKLAMMER]),
@@ -4793,12 +4858,18 @@ implementation
            _ASSIGNMENT :
              begin
                 consume(_ASSIGNMENT);
-                if assigned(p1.resultdef) and (p1.resultdef.typ=procvardef) then
-                  getprocvardef:=tprocvardef(p1.resultdef);
+                if assigned(p1.resultdef) then
+                  if (p1.resultdef.typ=procvardef) then
+                    getprocvardef:=tprocvardef(p1.resultdef)
+                  else if is_invokable(p1.resultdef) then
+                    getfuncrefdef:=tobjectdef(p1.resultdef);
                 p2:=sub_expr(opcompare,[ef_accept_equal],nil);
                 if assigned(getprocvardef) then
-                  handle_procvar(getprocvardef,p2);
+                  handle_procvar(getprocvardef,p2)
+                else if assigned(getfuncrefdef) then
+                  handle_funcref(getfuncrefdef,p2);
                 getprocvardef:=nil;
+                getfuncrefdef:=nil;
                 p1:=cassignmentnode.create(p1,p2);
              end;
            _PLUSASN :

compiler/procdefutil.pas

@@ -42,6 +42,7 @@ function adjust_funcref(var def:tdef;sym,dummysym:tsym):boolean;
 
 function get_or_create_capturer(pd:tprocdef):tsym;
 function capturer_add_anonymous_proc(owner:tprocinfo;pd:tprocdef;out capturer:tsym):tobjectdef;
+function capturer_add_procvar_or_proc(owner:tprocinfo;n:tnode;out capturer:tsym;out capturen:tnode):tobjectdef;
 procedure initialize_capturer(ctx:tprocinfo;var stmt:tstatementnode);
 procedure postprocess_capturer(ctx:tprocinfo);
 procedure convert_captured_syms(pd:tprocdef;tree:tnode);
@@ -656,6 +657,417 @@ implementation
     end;
 
 
+  function retrieve_sym_for_filepos(var n:tnode;arg:pointer):foreachnoderesult;
+    var
+      sym : ^tsym absolute arg;
+    begin
+      if assigned(sym^) then
+        exit(fen_norecurse_true);
+      result:=fen_false;
+      if not (n.resultdef.typ in [procdef,procvardef]) then
+        exit;
+      if n.nodetype=loadn then
+        begin
+          sym^:=tloadnode(n).symtableentry;
+          result:=fen_norecurse_true;
+        end
+      else if n.nodetype=subscriptn then
+        begin
+          sym^:=tsubscriptnode(n).vs;
+          result:=fen_norecurse_true;
+        end;
+    end;
+
+
+  function collect_syms_to_capture(var n:tnode;arg:pointer):foreachnoderesult;
+    var
+      pd : tprocdef absolute arg;
+      sym : tsym;
+    begin
+      result:=fen_false;
+      if n.nodetype<>loadn then
+        exit;
+      sym:=tsym(tloadnode(n).symtableentry);
+      if not (sym.owner.symtabletype in [parasymtable,localsymtable]) then
+        exit;
+      if sym.owner.symtablelevel>normal_function_level then begin
+        pd.add_captured_sym(sym,n.fileinfo);
+        result:=fen_true;
+      end;
+    end;
+
+
+  type
+    tselfinfo=record
+      selfsym:tsym;
+      ignore:tsym;
+    end;
+    pselfinfo=^tselfinfo;
+
+
+  function find_self_sym(var n:tnode;arg:pointer):foreachnoderesult;
+    var
+      info : pselfinfo absolute arg;
+    begin
+      result:=fen_false;
+      if assigned(info^.selfsym) then
+        exit(fen_norecurse_true);
+      if n.nodetype<>loadn then
+        exit;
+      if tloadnode(n).symtableentry.typ<>paravarsym then
+        exit;
+      if tloadnode(n).symtableentry=info^.ignore then
+        exit;
+      if vo_is_self in tparavarsym(tloadnode(n).symtableentry).varoptions then
+        begin
+          info^.selfsym:=tparavarsym(tloadnode(n).symtableentry);
+          result:=fen_norecurse_true;
+        end;
+    end;
+
+
+  function find_outermost_loaded_sym(var n:tnode;arg:pointer):foreachnoderesult;
+    var
+      sym : ^tsym absolute arg;
+    begin
+      if assigned(sym^) then
+        exit(fen_norecurse_true);
+      result:=fen_false;
+      if n.nodetype<>loadn then
+        exit;
+      sym^:=tloadnode(n).symtableentry;
+      result:=fen_norecurse_true;
+    end;
+
+
+  function find_procdef(var n:tnode;arg:pointer):foreachnoderesult;
+    var
+      pd : ^tprocdef absolute arg;
+    begin
+      if assigned(pd^) then
+        exit(fen_norecurse_true);
+      result:=fen_false;
+      if n.resultdef.typ<>procdef then
+        exit;
+      pd^:=tprocdef(n.resultdef);
+      result:=fen_norecurse_true;
+    end;
+
+
+  function capturer_add_procvar_or_proc(owner:tprocinfo;n:tnode;out capturer:tsym;out capturen:tnode):tobjectdef;
+
+    function create_paras(pd:tprocdef):tcallparanode;
+      var
+        para : tparavarsym;
+        i : longint;
+      begin
+        result:=nil;
+        for i:=0 to pd.paras.count-1 do
+          begin
+            para:=tparavarsym(pd.paras[i]);
+            if vo_is_hidden_para in para.varoptions then
+              continue;
+            result:=ccallparanode.create(cloadnode.create(para,pd.parast),result);
+          end;
+      end;
+
+      function find_nested_procinfo(pd:tprocdef):tcgprocinfo;
+        var
+          tmp,
+          res : tprocinfo;
+        begin
+          tmp:=owner;
+          while assigned(tmp) and (tmp.procdef.parast.symtablelevel>=normal_function_level) do
+            begin
+              res:=tmp.find_nestedproc_by_pd(pd);
+              if assigned(res) then
+                exit(tcgprocinfo(res));
+              tmp:=tmp.parent;
+            end;
+          result:=nil;
+        end;
+
+      procedure swap_symtable(var st1,st2:tsymtable);
+        var
+          st : tsymtable;
+          owner : tdefentry;
+          level : byte;
+        begin
+          { first swap the symtables themselves }
+          st:=st1;
+          st1:=st2;
+          st2:=st;
+          { then swap the symtables' owners }
+          owner:=st1.defowner;
+          st1.defowner:=st2.defowner;
+          st2.defowner:=owner;
+          { and finally the symtable level }
+          level:=st1.symtablelevel;
+          st1.symtablelevel:=st2.symtablelevel;
+          st2.symtablelevel:=level;
+        end;
+
+      procedure print_procinfo(pi:tcgprocinfo);
+        begin
+          { Print the node to tree.log }
+          if paraprintnodetree <> 0 then
+            pi.printproc('after parsing');
+
+{$ifdef DEBUG_NODE_XML}
+          { Methods of generic classes don't get any code generated, so output
+            the node tree here }
+          if (df_generic in procdef.defoptions) then
+            pi.XMLPrintProc(True);
+{$endif DEBUG_NODE_XML}
+        end;
+
+    var
+      ps : tprocsym;
+      pd : tprocdef;
+      pinested,
+      pi : tcgprocinfo;
+      sym,
+      fpsym,
+      selfsym : tsym;
+      invokename : tsymstr;
+      capturedef : tobjectdef;
+      capturesyms : tfplist;
+      captured : pcapturedsyminfo;
+      implintf : TImplementedInterface;
+      i : longint;
+      stmt : tstatementnode;
+      n1 : tnode;
+      fieldsym : tfieldvarsym;
+      selfinfo : tselfinfo;
+    begin
+      if not (n.resultdef.typ in [procdef,procvardef]) then
+        internalerror(2022022101);
+
+      capturer:=nil;
+      capturen:=nil;
+
+      { determine a unique name for the variable, field for function of the
+        node we're trying to load }
+
+      sym:=nil;
+      if not foreachnodestatic(pm_preprocess,n,@find_outermost_loaded_sym,@sym) then
+        internalerror(2022022102);
+
+      result:=funcref_intf_for_proc(tabstractprocdef(n.resultdef),fileinfo_to_suffix(sym.fileinfo));
+
+      if df_generic in owner.procdef.defoptions then
+        begin
+          { only check whether we can capture the symbol }
+          if not can_be_captured(sym) then
+            MessagePos1(n.fileinfo,sym_e_symbol_no_capture,sym.realname);
+          exit;
+        end;
+
+      if (sym.typ=procsym) and (sym.owner.symtabletype=localsymtable) then
+        begin
+          { this is assigning a nested function, so retrieve the correct procdef
+            so that we can then retrieve the procinfo for it }
+          if n.resultdef.typ=procdef then
+            pd:=tprocdef(n.resultdef)
+          else
+            begin
+              pd:=nil;
+              if not foreachnodestatic(pm_preprocess,n,@find_procdef,@pd) then
+                internalerror(2022041801);
+              if not assigned(pd) then
+                internalerror(2022041802);
+            end;
+          pinested:=find_nested_procinfo(pd);
+          if not assigned(pinested) then
+            internalerror(2022041803);
+          if pinested.parent<>owner then
+            begin
+              { we need to capture this into the owner of the nested function
+                instead }
+              owner:=pinested;
+              capturer:=get_or_create_capturer(pinested.procdef);
+              if not assigned(capturer) then
+                internalerror(2022041804);
+            end;
+        end
+      else
+        pinested:=nil;
+
+      if not assigned(capturer) then
+        capturer:=get_or_create_capturer(owner.procdef);
+
+      if not (capturer.typ in [localvarsym,staticvarsym]) then
+        internalerror(2022022103);
+      capturedef:=tobjectdef(tabstractvarsym(capturer).vardef);
+      if not is_class(capturedef) then
+        internalerror(2022022104);
+      implintf:=find_implemented_interface(capturedef,result);
+      if assigned(implintf) then
+        begin
+          { this is already captured into a method of the capturer, so nothing
+            further to do }
+          exit;
+        end;
+      implintf:=capturedef.register_implemented_interface(result,true);
+
+      invokename:=method_name_funcref_invoke_decl+'$'+fileinfo_to_suffix(sym.fileinfo);
+
+      ps:=cprocsym.create(invokename);
+      pd:=tprocdef(tabstractprocdef(n.resultdef).getcopyas(procdef,pc_normal,'',false));
+      pd.aliasnames.clear;
+
+      pd.procsym:=ps;
+      pd.struct:=capturedef;
+      pd.changeowner(capturedef.symtable);
+      pd.parast.symtablelevel:=normal_function_level;
+      pd.localst.symtablelevel:=normal_function_level;
+      { reset procoptions }
+      pd.procoptions:=[];
+      { to simplify some checks }
+      pd.was_anonymous:=true;
+      ps.ProcdefList.Add(pd);
+      pd.forwarddef:=false;
+      { set procinfo and current_procinfo.procdef }
+      pi:=tcgprocinfo(cprocinfo.create(nil));
+      pi.procdef:=pd;
+      if not assigned(pinested) then
+        begin
+          insert_funcret_local(pd);
+          { we always do a call, namely to the provided function }
+          include(pi.flags,pi_do_call);
+        end
+      else
+        begin
+          { the original nested function now calls the method }
+          include(pinested.flags,pi_do_call);
+          { swap the para and local symtables of the nested and new routine }
+          swap_symtable(pinested.procdef.parast,pd.parast);
+          swap_symtable(pinested.procdef.localst,pd.localst);
+          { fix function return symbol }
+          pd.funcretsym:=pinested.procdef.funcretsym;
+          pinested.procdef.funcretsym:=nil;
+          insert_funcret_local(pinested.procdef);
+        end;
+      capturedef.symtable.insertsym(ps);
+      owner.addnestedproc(pi);
+
+      { remove self and parentfp parameter if any as that will be replaced by
+        the capturer }
+      selfsym:=nil;
+      fpsym:=nil;
+      for i:=0 to pd.parast.symlist.count-1 do
+        begin
+          sym:=tsym(pd.parast.symlist[i]);
+          if sym.typ<>paravarsym then
+            continue;
+          if vo_is_self in tparavarsym(sym).varoptions then
+            selfsym:=sym
+          else if vo_is_parentfp in tparavarsym(sym).varoptions then
+            fpsym:=sym;
+          if assigned(selfsym) and assigned(fpsym) then
+            break;
+        end;
+      if assigned(selfsym) then
+        pd.parast.deletesym(selfsym);
+      if assigned(fpsym) then
+        pd.parast.deletesym(fpsym);
+      pd.calcparas;
+      if assigned(pinested) then
+        pinested.procdef.calcparas;
+
+      insert_self_and_vmt_para(pd);
+
+      if assigned(pinested) then
+        begin
+          { when we're assigning a nested function to a function reference we
+            move the code of the nested function to the newly created capturer
+            method (including the captured symbols) and have the original nested
+            function simply call that function-turned-method }
+          pi.code:=pinested.code;
+          pinested.code:=internalstatements(stmt);
+        end
+      else
+        pi.code:=internalstatements(stmt);
+
+      selfinfo.selfsym:=nil;
+      selfinfo.ignore:=nil;
+
+      fieldsym:=nil;
+      if assigned(pinested) then
+        begin
+          n1:=ccallnode.create(create_paras(pd),ps,capturedef.symtable,cloadnode.create(capturer,capturer.owner),[],nil);
+        end
+      else if n.resultdef.typ=procvardef then
+        begin
+          { store the procvar in a field so that it won't be changed if the
+            procvar itself is changed }
+          fieldsym:=cfieldvarsym.create('$'+fileinfo_to_suffix(n.fileinfo),vs_value,n.resultdef,[]);
+          fieldsym.fileinfo:=n.fileinfo;
+          capturedef.symtable.insertsym(fieldsym);
+          tabstractrecordsymtable(capturedef.symtable).addfield(fieldsym,vis_public);
+
+          capturen:=csubscriptnode.create(fieldsym,cloadnode.create(capturer,capturer.owner));
+
+          selfsym:=tsym(pd.parast.find('self'));
+          if not assigned(selfsym) then
+            internalerror(2022052301);
+          selfinfo.ignore:=selfsym;
+          n1:=ccallnode.create_procvar(create_paras(pd),csubscriptnode.create(fieldsym,cloadnode.create(selfsym,selfsym.owner)));
+        end
+      else
+        begin
+          if n.nodetype<>loadn then
+            internalerror(2022032401);
+          if tloadnode(n).symtableentry.typ<>procsym then
+            internalerror(2022032402);
+          n1:=ccallnode.create(create_paras(pd),tprocsym(tloadnode(n).symtableentry),tloadnode(n).symtable,tloadnode(n).left,[],nil);
+          tloadnode(n).left:=nil;
+        end;
+      if assigned(pd.returndef) and not is_void(pd.returndef) then
+        n1:=cassignmentnode.create(
+                    cloadnode.create(pd.funcretsym,pd.localst),
+                    n1
+                  );
+      addstatement(stmt,n1);
+      pd.aliasnames.insert(pd.mangledname);
+
+      if assigned(pinested) then
+        begin
+          { transfer all captured syms }
+          capturesyms:=pinested.procdef.capturedsyms;
+          if assigned(capturesyms) then
+            begin
+              for i:=0 to capturesyms.count-1 do
+                begin
+                  captured:=pcapturedsyminfo(capturesyms[i]);
+                  pi.add_captured_sym(captured^.sym,captured^.fileinfo);
+                end;
+              capturesyms.clear;
+            end;
+          { the original nested function now needs to capture only the capturer }
+          pinested.procdef.add_captured_sym(capturer,n.fileinfo);
+        end
+      { 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
+        { this isn't a procdef that was captured into a field, so capture the
+          self }
+        pd.add_captured_sym(selfinfo.selfsym,n.fileinfo);
+
+      print_procinfo(pi);
+      if assigned(pinested) then
+        print_procinfo(pinested);
+
+      implintf.AddMapping(upcase(result.objrealname^+'.')+method_name_funcref_invoke_find,upcase(invokename));
+
+      capture_captured_syms(pd,owner,capturedef);
+    end;
+
+
   function capturer_add_anonymous_proc(owner:tprocinfo;pd:tprocdef;out capturer:tsym):tobjectdef;
     var
       capturedef : tobjectdef;