* implement assignment of anonymous functions to procedure or method variables if they either capture nothing or (in case of method variables) at most the Self variable

compiler/defcmp.pas

@@ -1766,7 +1766,8 @@ implementation
                    begin
                      { proc -> procvar }
                      if (m_tp_procvar in current_settings.modeswitches) or
-                        (m_mac_procvar in current_settings.modeswitches) then
+                        (m_mac_procvar in current_settings.modeswitches) or
+                        (po_anonymous in tprocdef(def_from).procoptions) then
                       begin
                         subeq:=proc_to_procvar_equal(tprocdef(def_from),tprocvardef(def_to),cdo_warn_incompatible_univ in cdoptions);
                         if subeq>te_incompatible then
@@ -2536,6 +2537,8 @@ implementation
          pa_comp:=[cpo_ignoreframepointer];
          if is_block(def2) then
            include(pa_comp,cpo_ignorehidden);
+         if po_anonymous in def1.procoptions then
+           include(pa_comp,cpo_ignoreself);
          if checkincompatibleuniv then
            include(pa_comp,cpo_warn_incompatible_univ);
          { check return value and options, methodpointer is already checked }

compiler/htypechk.pas

@@ -1195,6 +1195,7 @@ implementation
       begin
          if not(m_nested_procvars in current_settings.modeswitches) and
             (from_def.parast.symtablelevel>normal_function_level) and
+            not (po_anonymous in from_def.procoptions) and
             (to_def.typ=procvardef) then
            CGMessage(type_e_cannot_local_proc_to_procvar);
       end;

compiler/ncnv.pas

@@ -323,8 +323,9 @@ implementation
       cutils,verbose,globals,widestr,ppu,
       symconst,symdef,symsym,symcpu,symtable,
       ncon,ncal,nset,nadd,nmem,nmat,nbas,nutils,ninl,nflw,
+      psub,
       cgbase,procinfo,
-      htypechk,blockutl,pass_1,cpuinfo;
+      htypechk,blockutl,pparautl,pass_1,cpuinfo;
 
 
 {*****************************************************************************
@@ -2361,11 +2362,58 @@ implementation
       end;
 
 
+    type
+      tsym_mapping = record
+        oldsym:tsym;
+        newsym:tsym;
+      end;
+      psym_mapping = ^tsym_mapping;
+
+
+    function replace_self_sym(var n:tnode;arg:pointer):foreachnoderesult;
+      var
+        mapping : psym_mapping absolute arg;
+        ld : tloadnode;
+      begin
+        if n.nodetype=loadn then
+          begin
+            ld:=tloadnode(n);
+            if ld.symtableentry=mapping^.oldsym then
+              begin
+                ld.symtableentry:=mapping^.newsym;
+                { make sure that the node is processed again }
+                ld.resultdef:=nil;
+                if assigned(ld.left) then
+                  begin
+                    { no longer loaded through the frame pointer }
+                    ld.left.free;
+                    ld.left:=nil;
+                  end;
+                typecheckpass(n);
+              end;
+          end;
+        result:=fen_true;
+      end;
+
+
     function ttypeconvnode.typecheck_proc_to_procvar : tnode;
+
+      function is_self_sym(sym:tsym):boolean;
+        begin
+          result:=(sym.typ in [localvarsym,paravarsym]) and
+                    (vo_is_self in tabstractvarsym(sym).varoptions);
+        end;
+
       var
         pd : tabstractprocdef;
         copytype : tproccopytyp;
         source: pnode;
+        fpsym,
+        selfsym,
+        sym : tsym;
+        mapping : tsym_mapping;
+        pi : tprocinfo;
+        i : longint;
       begin
         result:=nil;
         pd:=tabstractprocdef(left.resultdef);
@@ -2403,6 +2451,174 @@ implementation
                   end
                 else
                   CGMessage2(type_e_illegal_type_conversion,left.resultdef.typename,resultdef.typename);
+              end
+            else if (pd.typ=procdef) and
+               (po_anonymous in pd.procoptions) then
+              begin
+                if left.nodetype<>loadn then
+                  internalerror(2021062402);
+                { get rid of any potential framepointer loading; if it's necessary
+                  (for a nested procvar for example) it will be added again }
+                if assigned(tloadnode(left).left) and (tloadnode(left).left.nodetype=loadparentfpn) then
+                  begin
+                    tloadnode(left).left.free;
+                    tloadnode(left).left:=nil;
+                    tloadnode(left).resultdef:=nil;
+                  end;
+                if tprocvardef(totypedef).is_methodpointer then
+                  begin
+                    if assigned(tprocdef(pd).capturedsyms) and
+                        (
+                          (tprocdef(pd).capturedsyms.count>1) or
+                          (
+                            (tprocdef(pd).capturedsyms.count=1) and
+                            not is_self_sym(tsym(pcapturedsyminfo(tprocdef(pd).capturedsyms[0])^.sym))
+                          )
+                        ) then
+                      internalerror(2021060801);
+
+                    selfsym:=nil;
+                    fpsym:=nil;
+                    { find the framepointer parameter and an eventual self }
+                    for i:=0 to tprocdef(pd).parast.symlist.count-1 do
+                      begin
+                        sym:=tsym(tprocdef(pd).parast.symlist[i]);
+                        if sym.typ<>paravarsym then
+                          continue;
+                        if vo_is_parentfp in tparavarsym(sym).varoptions then
+                          fpsym:=sym;
+                        if vo_is_self in tparavarsym(sym).varoptions then
+                          selfsym:=sym;
+                        if assigned(fpsym) and assigned(selfsym) then
+                          break;
+                      end;
+
+                    if assigned(fpsym) then
+                      tprocdef(pd).parast.symlist.remove(fpsym);
+
+                    { if we don't have a self parameter already we need to
+                      insert a suitable one }
+
+                    if not assigned(selfsym) then
+                      begin
+                        { replace the self symbol by the new parameter if it was
+                          captured }
+                        if assigned(tprocdef(pd).capturedsyms) and
+                            (tprocdef(pd).capturedsyms.count>0) then
+                          begin
+                            if not assigned(tprocdef(pd).struct) then
+                              { we can't use the captured symbol for the struct as that
+                                might be the self of a type helper, thus we need to find
+                                the parent procinfo that provides the Self }
+                              tprocdef(pd).struct:=current_procinfo.get_normal_proc.procdef.struct;
+                            if not assigned(tprocdef(pd).struct) then
+                              internalerror(2021062204);
+
+                            insert_self_and_vmt_para(pd);
+
+                            mapping.oldsym:=tsym(pcapturedsyminfo(tprocdef(pd).capturedsyms[0])^.sym);
+                            mapping.newsym:=nil;
+
+                            { find the new self parameter }
+                            for i:=0 to tprocdef(pd).parast.symlist.count-1 do
+                              begin
+                                sym:=tsym(tprocdef(pd).parast.symlist[i]);
+                                if (sym.typ=paravarsym) and (vo_is_self in tparavarsym(sym).varoptions) then
+                                  begin
+                                    mapping.newsym:=sym;
+
+                                    break;
+                                  end;
+                              end;
+
+                            if not assigned(mapping.newsym) then
+                              internalerror(2021062202);
+
+                            { the anonymous function can only be a direct child of the
+                              current_procinfo }
+                            pi:=current_procinfo.get_first_nestedproc;
+                            while assigned(pi) do
+                              begin
+                                if pi.procdef=pd then
+                                  break;
+                                pi:=tprocinfo(pi.next);
+                              end;
+
+                            if not assigned(pi) then
+                              internalerror(2021062203);
+
+                            { replace all uses of the captured Self by the new Self
+                              parameter }
+                            foreachnodestatic(pm_preprocess,tcgprocinfo(pi).code,@replace_self_sym,@mapping);
+
+                            mapping.oldsym.free;
+                          end
+                        else
+                          begin
+                            { for a nested function of a method struct is already
+                              set }
+                            if not assigned(tprocdef(pd).struct) then
+                              { simply add a TObject as Self parameter }
+                              tprocdef(pd).struct:=class_tobject;
+
+                            insert_self_and_vmt_para(pd);
+
+                            { there is no self, so load a nil value }
+                            tloadnode(left).set_mp(cnilnode.create);
+                          end;
+                      end;
+
+                    { the anonymous function no longer adheres to the nested
+                      calling convention }
+                    exclude(pd.procoptions,po_delphi_nested_cc);
+
+                    tprocdef(pd).calcparas;
+
+                    if not assigned(tloadnode(left).left) then
+                      tloadnode(left).set_mp(load_self_node);
+                  end
+                else if tprocvardef(totypedef).is_addressonly then
+                  begin
+                    if assigned(tprocdef(pd).capturedsyms) and (tprocdef(pd).capturedsyms.count>0) then
+                      internalerror(2021060802);
+
+                    { remove framepointer and Self parameters }
+                    for i:=tprocdef(pd).parast.symlist.count-1 downto 0 do
+                      begin
+                        sym:=tsym(tprocdef(pd).parast.symlist[i]);
+                        if (sym.typ=paravarsym) and (tparavarsym(sym).varoptions*[vo_is_parentfp,vo_is_self]<>[]) then
+                          tprocdef(pd).parast.symlist.delete(i);
+                      end;
+
+                    { the anonymous function no longer adheres to the nested
+                      calling convention }
+                    exclude(pd.procoptions,po_delphi_nested_cc);
+
+                    { we don't need to look through the existing nodes, cause
+                      the parameter was never used anyway }
+                    tprocdef(pd).calcparas;
+                  end
+                else
+                  begin
+                    { this is a nested function pointer, so ensure that the
+                      anonymous function is handled as such }
+                    if assigned(tprocdef(pd).capturedsyms) and
+                        (tprocdef(pd).capturedsyms.count>0) and
+                        (left.nodetype=loadn) then
+                      begin
+                        tloadnode(left).left:=cloadparentfpnode.create(tprocdef(tloadnode(left).symtable.defowner),lpf_forload);
+
+                        pi:=current_procinfo.get_first_nestedproc;
+                        while assigned(pi) do
+                          begin
+                            if pi.procdef=pd then
+                              break;
+                            pi:=tprocinfo(pi.next);
+                          end;
+
+                        pi.set_needs_parentfp(tprocdef(tloadnode(left).symtable.defowner).parast.symtablelevel);
+                      end;
+                  end;
               end;
             resultdef:=totypedef;
           end
@@ -3804,7 +4020,11 @@ implementation
          { if we take the address of a nested function, the current function/
            procedure needs a stack frame since it's required to construct
            the nested procvar }
-         if is_nested_pd(tprocvardef(resultdef)) then
+         if is_nested_pd(tprocvardef(resultdef)) and
+            (
+              not (po_anonymous in tprocdef(left.resultdef).procoptions) or
+              (po_delphi_nested_cc in tprocvardef(resultdef).procoptions)
+            ) then
            include(current_procinfo.flags,pi_needs_stackframe);
          if tabstractprocdef(resultdef).is_addressonly then
            expectloc:=LOC_REGISTER

compiler/nld.pas

@@ -549,7 +549,11 @@ implementation
         resultdef:=p;
         { nested procedure? }
         if assigned(p) and
-           is_nested_pd(p) then
+           is_nested_pd(p) and
+           (
+             not (po_anonymous in p.procoptions) or
+             (po_delphi_nested_cc in p.procoptions)
+           ) then
           begin
             if not(m_nested_procvars in current_settings.modeswitches) then
               CGMessage(type_e_cant_take_address_of_local_subroutine)
@@ -560,10 +564,20 @@ implementation
                 left:=cloadparentfpnode.create(tprocdef(p.owner.defowner),lpf_forpara);
               end;
           end
-        { we should never go from nested to non-nested }
+        { we should never go from nested to non-nested (except for an anonymous
+          function which might have been changed to a global function or a
+          method) }
         else if assigned(left) and
                 (left.nodetype=loadparentfpn) then
-          internalerror(2010072201);
+          begin
+            if po_anonymous in p.procoptions then
+              begin
+                left.free;
+                left:=nil;
+              end
+            else
+              internalerror(2010072201);
+          end;
       end;
 
 {*****************************************************************************

compiler/pparautl.pas

@@ -241,7 +241,10 @@ implementation
           begin
              if (pd.typ=procdef) and
                 assigned(tprocdef(pd).struct) and
-                (pd.parast.symtablelevel=normal_function_level) then
+                (
+                  (pd.parast.symtablelevel=normal_function_level) or
+                  (po_anonymous in pd.procoptions)
+                ) then
               begin
                 { static class methods have no hidden self/vmt pointer }
                 if pd.no_self_node then

compiler/symdef.pas

@@ -6754,7 +6754,12 @@ implementation
         result:=assigned(owner) and
                 not is_methodpointer and
                 (not(m_nested_procvars in current_settings.modeswitches) or
-                 not is_nested_pd(self));
+                 not is_nested_pd(self)) and
+                 (
+                   not (po_anonymous in procoptions) or
+                   not assigned(capturedsyms) or
+                   (capturedsyms.count=0)
+                 );
       end;