+ create an nested interface type called "Callback" inside the classes that

    are used to implement procvar types, and add a constructor to the procvar
    types that accept an instance implementing this interface -> much easier
    and more natural to use procvar types from Java code

git-svn-id: branches/jvmbackend@19216 -

compiler/jvm/pjvm.pas

@@ -452,14 +452,16 @@ implementation
       end;
 
 
-    procedure jvm_create_procvar_class(const name: TIDString; def: tdef);
+    procedure jvm_create_procvar_class_intern(const name: TIDString; def: tdef; force_no_callback_intf: boolean);
       var
         vmtbuilder: tvmtbuilder;
         oldsymtablestack: tsymtablestack;
-        pvclass: tobjectdef;
+        pvclass,
+        pvintf: tobjectdef;
         temptypesym: ttypesym;
         sstate: tscannerstate;
         methoddef: tprocdef;
+        old_current_structdef: tabstractrecorddef;
         islocal: boolean;
       begin
         { inlined definition of procvar -> generate name, derive from
@@ -507,6 +509,47 @@ implementation
         temptypesym.typedef:=def;
         pvclass.symtable.insert(temptypesym);
 
+        { in case of a procedure of object, add a nested interface type that
+          has one method that conforms to the procvartype (with name
+          procvartypename+'Callback') and an extra constructor that takes
+          an instance conforming to this interface and which sets up the
+          procvar by taking the address of its Callback method (convenient to
+          use from Java code) }
+        if (po_methodpointer in tprocvardef(def).procoptions) and
+           not islocal and
+           not force_no_callback_intf then
+          begin
+            pvintf:=tobjectdef.create(odt_interfacejava,'Callback',nil);
+            pvintf.objextname:=stringdup('Callback');
+            if df_generic in def.defoptions then
+              include(pvintf.defoptions,df_generic);
+            { associate typesym }
+            pvclass.symtable.insert(ttypesym.create('Callback',pvintf));
+
+            { add a method prototype matching the procvar (like the invoke
+              in the procvarclass itself) }
+            symtablestack.push(pvintf.symtable);
+            methoddef:=tprocdef(tprocvardef(def).getcopyas(procdef,pc_bareproc));
+            finish_copied_procdef(methoddef,name+'Callback',pvintf.symtable,pvintf);
+            insert_self_and_vmt_para(methoddef);
+            { can't be final/static/private/protected, and must be virtual
+              since it's an interface method }
+            methoddef.procoptions:=methoddef.procoptions-[po_staticmethod,po_finalmethod];
+            include(methoddef.procoptions,po_virtualmethod);
+            methoddef.visibility:=vis_public;
+            symtablestack.pop(pvintf.symtable);
+
+            { add an extra constructor to the procvarclass that takes an
+              instance of this interface as parameter }
+            old_current_structdef:=current_structdef;
+            current_structdef:=pvclass;
+            if not str_parse_method_dec('constructor Create(__intf:'+pvintf.objextname^+');overload;',potype_constructor,false,pvclass,methoddef) then
+              internalerror(2011092401);
+            methoddef.synthetickind:=tsk_jvm_procvar_intconstr;
+            methoddef.skpara:=def;
+            current_structdef:=old_current_structdef;
+          end;
+
         symtablestack.pop(pvclass.symtable);
 
         vmtbuilder:=TVMTBuilder.Create(pvclass);
@@ -517,6 +560,12 @@ implementation
       end;
 
 
+    procedure jvm_create_procvar_class(const name: TIDString; def: tdef);
+      begin
+        jvm_create_procvar_class_intern(name,def,false);
+      end;
+
+
     procedure jvm_wrap_virtual_class_method(pd: tprocdef);
       var
         wrapperpd: tprocdef;
@@ -580,7 +629,9 @@ implementation
         { also create procvar type that we can use in the implementation }
         wrapperpv:=tprocvardef(pd.getcopyas(procvardef,pc_normal));
         wrapperpv.calcparas;
-        jvm_create_procvar_class('__fpc_virtualclassmethod_pv_t'+tostr(wrapperpd.defid),wrapperpv);
+        { no use in creating a callback wrapper here, this procvar type isn't
+          for public consumption }
+        jvm_create_procvar_class_intern('__fpc_virtualclassmethod_pv_t'+tostr(wrapperpd.defid),wrapperpv,true);
         { create alias for the procvar type so we can use it in generated
           Pascal code }
         typ:=ttypesym.create('__fpc_virtualclassmethod_pv_t'+tostr(wrapperpd.defid),wrapperpv);

compiler/symcreat.pas

@@ -771,6 +771,24 @@ implementation
     end;
 
 
+  procedure implement_jvm_procvar_intconstr(pd: tprocdef);
+    var
+      pvdef: tprocvardef;
+    begin
+      { ideal, and most performant, would be to keep the interface instance
+        passed to the constructor around and always call its method directly
+        rather than working via reflection. Unfortunately, the procvar semantics
+        that allow directly modifying the procvar via typecasting it to a
+        tmethod make this very hard.
+
+        So for now we simply take the address of the interface instance's
+        method and assign it to the tmethod of this procvar }
+
+      pvdef:=tprocvardef(pd.skpara);
+      str_parse_method_impl('begin method:=System.TMethod(@__intf.'+pvdef.typesym.RealName+'Callback) end;',pd,false);
+    end;
+
+
   procedure implement_jvm_virtual_clmethod(pd: tprocdef);
     var
       str: ansistring;
@@ -864,6 +882,8 @@ implementation
               implement_jvm_enum_set2set(pd);
             tsk_jvm_procvar_invoke:
               implement_jvm_procvar_invoke(pd);
+            tsk_jvm_procvar_intconstr:
+              implement_jvm_procvar_intconstr(pd);
             tsk_jvm_virtual_clmethod:
               implement_jvm_virtual_clmethod(pd);
 {$endif jvm}

compiler/symdef.pas

@@ -529,6 +529,7 @@ interface
          tsk_jvm_enum_bitset2set,   // Java fpcBitSetToEnumSet function that returns an enumset corresponding to a BitSet
          tsk_jvm_enum_set2Set,      // Java fpcEnumSetToEnumSet function that returns an enumset corresponding to another enumset (different enum kind)
          tsk_jvm_procvar_invoke,    // Java invoke method that calls a wrapped procvar
+         tsk_jvm_procvar_intconstr, // Java procvar class constructor that accepts an interface instance for easy Java interoperation
          tsk_jvm_virtual_clmethod,  // Java wrapper for virtual class method
          tsk_field_getter,          // getter for a field (callthrough property is passed in skpara)
          tsk_field_setter           // Setter for a field (callthrough property is passed in skpara)