+ add support for parsing function references

compiler/pdecl.pas

@@ -65,6 +65,7 @@ implementation
        { parser }
        scanner,
        pbase,pexpr,ptype,ptconst,pdecsub,pdecvar,pdecobj,pgenutil,pparautl,
+       procdefutil,
 {$ifdef jvm}
        pjvm,
 {$endif}
@@ -687,12 +688,14 @@ implementation
          typename,orgtypename,
          gentypename,genorgtypename : TIDString;
          newtype  : ttypesym;
+         dummysym,
          sym      : tsym;
          hdef,
          hdef2    : tdef;
          defpos,storetokenpos : tfileposinfo;
          old_block_type : tblock_type;
          old_checkforwarddefs: TFPObjectList;
+         setdummysym,
          first,
          isgeneric,
          isunique,
@@ -719,6 +722,7 @@ implementation
          repeat
            defpos:=current_tokenpos;
            istyperenaming:=false;
+           setdummysym:=false;
            generictypelist:=nil;
            localgenerictokenbuf:=nil;
 
@@ -946,13 +950,20 @@ implementation
               if isgeneric and assigned(sym) and
                   not (m_delphi in current_settings.modeswitches) and
                   (ttypesym(sym).typedef.typ=undefineddef) then
-                { don't free the undefineddef as the defids rely on the count
+                begin
-                  of the defs in the def list of the module}
+                  { don't free the undefineddef as the defids rely on the count
-                ttypesym(sym).typedef:=hdef;
+                    of the defs in the def list of the module}
+                  ttypesym(sym).typedef:=hdef;
+                  setdummysym:=true;
+                end;
               newtype.typedef:=hdef;
               { ensure that the type is registered when no specialization is
                 currently done }
-              if current_scanner.replay_stack_depth=0 then
+              if (current_scanner.replay_stack_depth=0) and
+                  (
+                    (hdef.typ<>procvardef) or
+                    not (po_is_function_ref in tprocdef(hdef).procoptions)
+                  ) then
                 hdef.register_def;
               { KAZ: handle TGUID declaration in system unit }
               if (cs_compilesystem in current_settings.moduleswitches) and
@@ -1049,21 +1060,22 @@ implementation
                        parse_proctype_directives(tprocvardef(hdef));
                        if po_is_function_ref in tprocvardef(hdef).procoptions then
                          begin
-                           { these always support everything, no "of object" or
+                           if not (m_function_references in current_settings.modeswitches) and
-                             "is_nested" is allowed }
+                               not (po_is_block in tprocvardef(hdef).procoptions) then
-                           if is_nested_pd(tprocvardef(hdef)) or
+                             messagepos(storetokenpos,sym_e_error_in_type_def)
-                              is_methodpointer(hdef) then
-                             cgmessage(type_e_function_reference_kind)
                            else
                              begin
-                               { this message is only temporary; once Delphi style anonymous functions
+                               if setdummysym then
-                                 are supported, this check is no longer required }
+                                 dummysym:=sym
-                               if not (po_is_block in tprocvardef(hdef).procoptions) then
+                               else
-                                 comment(v_error,'Function references are not yet supported, only C blocks (add "cblock;" at the end)');
+                                 dummysym:=nil;
+                               adjust_funcref(hdef,newtype,dummysym);
                              end;
+                           if current_scanner.replay_stack_depth=0 then
+                             hdef.register_def;
                          end;
-                       handle_calling_convention(tprocvardef(hdef),hcc_default_actions_intf);
+                       handle_calling_convention(hdef,hcc_default_actions_intf);
-                       if po_is_function_ref in tprocvardef(hdef).procoptions then
+                       if (hdef.typ=procvardef) and (po_is_function_ref in tprocvardef(hdef).procoptions) then
                          begin
                            if (po_is_block in tprocvardef(hdef).procoptions) and
                               not (tprocvardef(hdef).proccalloption in [pocall_cdecl,pocall_mwpascal]) then

compiler/pdecvar.pas

@@ -60,7 +60,7 @@ implementation
 {$if defined(i386) or defined(i8086)}
        symcpu,
 {$endif}
-       fmodule,htypechk,
+       fmodule,htypechk,procdefutil,
        { pass 1 }
        node,pass_1,aasmbase,aasmdata,
        ncon,nset,ncnv,nld,nutils,
@@ -1351,6 +1351,7 @@ implementation
          deprecatedmsg   : pshortstring;
          old_block_type  : tblock_type;
          sectionname : ansistring;
+         typepos,
          tmp_filepos,
          old_current_filepos     : tfileposinfo;
       begin
@@ -1432,6 +1433,7 @@ implementation
              { read variable type def }
              block_type:=bt_var_type;
              consume(_COLON);
+             typepos:=current_tokenpos;
 
 {$ifdef gpc_mode}
              if (m_gpc in current_settings.modeswitches) and
@@ -1488,9 +1490,32 @@ implementation
                 (symtablestack.top.symtabletype<>parasymtable) then
                begin
                  { Add calling convention for procvar }
-                 if (hdef.typ=procvardef) and
+                 if (
+                      (hdef.typ=procvardef) or
+                      is_funcref(hdef)
+                    ) and
                     (hdef.typesym=nil) then
-                   handle_calling_convention(tprocvardef(hdef),hcc_default_actions_intf);
+                   begin
+                     if po_is_function_ref in tprocvardef(hdef).procoptions then
+                       begin
+                         if not (m_function_references in current_settings.modeswitches) and
+                             not (po_is_block in tprocvardef(hdef).procoptions) then
+                           messagepos(typepos,sym_e_error_in_type_def)
+                         else
+                           begin
+                             if adjust_funcref(hdef,nil,nil) then
+                               { the def was changed, so update it }
+                               for i:=0 to sc.count-1 do
+                                 begin
+                                   vs:=tabstractvarsym(sc[i]);
+                                   vs.vardef:=hdef;
+                                 end;
+                             if current_scanner.replay_stack_depth=0 then
+                               hdef.register_def;
+                           end;
+                       end;
+                     handle_calling_convention(hdef,hcc_default_actions_intf);
+                   end;
                  read_default_value(sc);
                  hasdefaultvalue:=true;
                end
@@ -1502,13 +1527,34 @@ implementation
 
              { Support calling convention for procvars after semicolon }
              if not(hasdefaultvalue) and
-                (hdef.typ=procvardef) and
+                (
+                  (hdef.typ=procvardef) or
+                  is_funcref(hdef)
+                ) and
                 (hdef.typesym=nil) then
                begin
                  { Parse procvar directives after ; }
                  maybe_parse_proc_directives(hdef);
+                 if po_is_function_ref in tprocvardef(hdef).procoptions then
+                   begin
+                     if not (m_function_references in current_settings.modeswitches) and
+                         not (po_is_block in tprocvardef(hdef).procoptions) then
+                       messagepos(typepos,sym_e_error_in_type_def)
+                     else
+                       begin
+                         if adjust_funcref(hdef,nil,nil) then
+                           { the def was changed, so update it }
+                           for i:=0 to sc.count-1 do
+                             begin
+                               vs:=tabstractvarsym(sc[i]);
+                               vs.vardef:=hdef;
+                             end;
+                         if current_scanner.replay_stack_depth=0 then
+                           hdef.register_def;
+                       end;
+                   end;
                  { Add calling convention for procvar }
-                 handle_calling_convention(tprocvardef(hdef),hcc_default_actions_intf);
+                 handle_calling_convention(hdef,hcc_default_actions_intf);
                  { Handling of Delphi typed const = initialized vars }
                  if (token=_EQ) and
                     not(m_tp7 in current_settings.modeswitches) and

compiler/pexpr.pas

@@ -2785,7 +2785,14 @@ implementation
           else
             begin
               { is this a procedure variable ? }
-              if assigned(p1.resultdef) and
+              if is_invokable(p1.resultdef) and
+                  (token=_LKLAMMER) then
+                begin
+                  if not searchsym_in_class(tobjectdef(p1.resultdef),tobjectdef(p1.resultdef),method_name_funcref_invoke_find,srsym,srsymtable,[]) then
+                    internalerror(2021040202);
+                  do_proc_call(srsym,srsymtable,tabstractrecorddef(p1.resultdef),false,again,p1,[],nil);
+                end
+              else if assigned(p1.resultdef) and
                  (p1.resultdef.typ=procvardef) then
                 begin
                   { Typenode for typecasting or expecting a procvar }

compiler/procdefutil.pas

@@ -25,18 +25,22 @@ unit procdefutil;
 interface
 
 uses
-  symconst,symtype,symdef;
+  symconst,symtype,symdef,globtype;
 
 { create a nested procdef that will be used to outline code from a procedure;
   astruct should usually be nil, except in special cases like the Windows SEH
   exception handling funclets }
 function create_outline_procdef(const basesymname: string; astruct: tabstractrecorddef; potype: tproctypeoption; resultdef: tdef): tprocdef;
 
+procedure convert_to_funcref_intf(const n:tidstring;var def:tdef);
+function adjust_funcref(var def:tdef;sym,dummysym:tsym):boolean;
+
 implementation
 
   uses
-    cutils,
+    cutils,cclasses,verbose,globals,
-    symbase,symsym,symtable,pparautl,globtype;
+    nobj,
+    symbase,symsym,symtable,defutil,pparautl;
 
 
   function create_outline_procdef(const basesymname: string; astruct: tabstractrecorddef; potype: tproctypeoption; resultdef: tdef): tprocdef;
@@ -91,5 +95,164 @@ implementation
     end;
 
 
+  function fileinfo_to_suffix(const fileinfo:tfileposinfo):tsymstr;inline;
+    begin
+      result:=tostr(fileinfo.moduleindex)+'_'+
+              tostr(fileinfo.fileindex)+'_'+
+              tostr(fileinfo.line)+'_'+
+              tostr(fileinfo.column);
+    end;
+
+
+  const
+    anon_funcref_prefix='$FuncRef_';
+
+
+  procedure convert_to_funcref_intf(const n:tidstring;var def:tdef);
+    var
+      oldsymtablestack : tsymtablestack;
+      pvdef : tprocvardef absolute def;
+      intfdef : tobjectdef;
+      invokedef : tprocdef;
+      psym : tprocsym;
+      sym : tsym;
+      st : tsymtable;
+      i : longint;
+      name : tidstring;
+    begin
+      if def.typ<>procvardef then
+        internalerror(2021040201);
+      if not (po_is_function_ref in tprocvardef(pvdef).procoptions) then
+        internalerror(2021022101);
+      if n='' then
+        name:=anon_funcref_prefix+fileinfo_to_suffix(current_filepos)
+      else
+        name:=n;
+      intfdef:=cobjectdef.create(odt_interfacecom,name,interface_iunknown,true);
+      include(intfdef.objectoptions,oo_is_funcref);
+      include(intfdef.objectoptions,oo_is_invokable);
+      include(intfdef.objectoptions,oo_has_virtual);
+      intfdef.typesym:=pvdef.typesym;
+      pvdef.typesym:=nil;
+
+      if cs_generate_rtti in current_settings.localswitches then
+        include(intfdef.objectoptions,oo_can_have_published);
+
+      oldsymtablestack:=symtablestack;
+      symtablestack:=nil;
+
+      invokedef:=tprocdef(pvdef.getcopyas(procdef,pc_normal_no_paras,'',false));
+      invokedef.struct:=intfdef;
+      invokedef.forwarddef:=false;
+
+      include(invokedef.procoptions,po_overload);
+      include(invokedef.procoptions,po_virtualmethod);
+
+      invokedef.procsym:=cprocsym.create(method_name_funcref_invoke_decl);
+      if cs_generate_rtti in current_settings.localswitches then
+        invokedef.visibility:=vis_published
+      else
+        invokedef.visibility:=vis_public;
+
+      intfdef.symtable.insertsym(invokedef.procsym);
+      intfdef.symtable.insertdef(invokedef);
+
+      if pvdef.is_generic or pvdef.is_specialization then
+        begin
+          if assigned(pvdef.genericdef) and (pvdef.genericdef.typ<>objectdef) then
+            internalerror(2021040501);
+          intfdef.genericdef:=pvdef.genericdef;
+          intfdef.defoptions:=intfdef.defoptions+(pvdef.defoptions*[df_generic,df_specialization]);
+          { in case of a generic we move all involved syms/defs to the interface }
+          intfdef.genericparas:=pvdef.genericparas;
+          pvdef.genericparas:=nil;
+          for i:=0 to intfdef.genericparas.count-1 do
+            begin
+              sym:=tsym(intfdef.genericparas[i]);
+              if sym.owner<>pvdef.parast then
+                continue;
+              sym.changeowner(intfdef.symtable);
+              if (sym.typ=typesym) and (ttypesym(sym).typedef.owner=pvdef.parast) then
+                ttypesym(sym).typedef.changeowner(intfdef.symtable);
+            end;
+        end;
+
+      { now move the symtable over }
+      invokedef.parast.free;
+      invokedef.parast:=pvdef.parast;
+      invokedef.parast.defowner:=invokedef;
+      pvdef.parast:=nil;
+
+      for i:=0 to invokedef.parast.symlist.count-1 do
+        begin
+          sym:=tsym(invokedef.parast.symlist[i]);
+          if sym.typ<>paravarsym then
+            continue;
+          if tparavarsym(sym).vardef=pvdef then
+            tparavarsym(sym).vardef:=intfdef;
+        end;
+
+      symtablestack:=oldsymtablestack;
+
+      if invokedef.returndef=pvdef then
+        invokedef.returndef:=intfdef;
+
+      handle_calling_convention(invokedef,hcc_default_actions_intf_struct);
+      proc_add_definition(invokedef);
+      invokedef.calcparas;
+      { def is not owned, so it can be simply freed }
+      def.free;
+      def:=intfdef;
+    end;
+
+
+  function adjust_funcref(var def:tdef;sym,dummysym:tsym):boolean;
+    var
+      sympos : tfileposinfo;
+      name : string;
+    begin
+      result:=false;
+      if (def.typ<>procvardef) and not is_funcref(def) then
+        internalerror(2022020401);
+      if assigned(sym) and not (sym.typ=typesym) then
+        internalerror(2022020402);
+      { these always support everything, no "of object" or
+        "is_nested" is allowed }
+      if is_nested_pd(tprocvardef(def)) or
+         is_methodpointer(def) then
+        cgmessage(type_e_function_reference_kind);
+      if not (po_is_block in tprocvardef(def).procoptions) then
+        begin
+          if assigned(dummysym) then
+            ttypesym(dummysym).typedef:=nil;
+          if assigned(sym) then
+            begin
+              ttypesym(sym).typedef:=nil;
+              name:=sym.name;
+            end
+          else
+            name:='';
+          convert_to_funcref_intf(name,def);
+          if assigned(sym) then
+            ttypesym(sym).typedef:=def;
+          if assigned(dummysym) then
+            ttypesym(dummysym).typedef:=def;
+          build_vmt(tobjectdef(def));
+          result:=true;
+        end
+      else
+        begin
+          if assigned(sym) and (sym.refs>0) then
+            begin
+              { find where the symbol was used and trigger
+                a "symbol not completely defined" error }
+              if not fileinfo_of_typesym_in_def(def,sym,sympos) then
+                sympos:=sym.fileinfo;
+              messagepos1(sympos,type_e_type_is_not_completly_defined,sym.realname);
+            end;
+        end;
+    end;
+
+
 end.
 

compiler/ptype.pas

@@ -84,7 +84,7 @@ implementation
        nset,ncnv,ncon,nld,
        { parser }
        scanner,
-       pbase,pexpr,pdecsub,pdecvar,pdecobj,pdecl,pgenutil,pparautl
+       pbase,pexpr,pdecsub,pdecvar,pdecobj,pdecl,pgenutil,pparautl,procdefutil
 {$ifdef jvm}
        ,pjvm
 {$endif}
@@ -1976,15 +1976,19 @@ implementation
                     end;
                   _REFERENCE:
                     begin
-                      if m_blocks in current_settings.modeswitches then
+                      if current_settings.modeswitches*[m_blocks,m_function_references]<>[] then
                         begin
                           consume(_REFERENCE);
                           consume(_TO);
-                          def:=procvar_dec(genericdef,genericlist,true);
+                          { don't register the def as a non-cblock function
+                            reference will be converted to an interface }
+                          def:=procvar_dec(genericdef,genericlist,false);
                           { could be errordef in case of a syntax error }
                           if assigned(def) and
                              (def.typ=procvardef) then
-                            include(tprocvardef(def).procoptions,po_is_function_ref);
+                            begin
+                              include(tprocvardef(def).procoptions,po_is_function_ref);
+                            end;
                         end
                       else
                         expr_type;