+ support for procedural variables for the JVM target

o every porocedural variable type is represented by a class with one
     public "invoke" method whose signature matches the signature of the
     procvar
   o internally, dispatching happens via java.lang.reflect.Method.invoke().
     WARNING: while this allows calling private/protected or other methods
     that are normally not accessible from another context, a security
     manger can override this. If such a security manager is installed,
     most procvars will cause security exceptions
   o such dispatching also requires that all arguments are wrapped, but
     that's done in the compiler-generated body of the invoke method,
     so that procvars can also be called conveniently from Java code
   o typecasting between a procedure of object and tmethod is supported,
     as well as Delphi-style replacing of only the method pointer via
     @procvar1=@procvar2.
   o nested procvars are not yet supported, but most of the basic
     infrastructure for them is already present
  * all units/programs now get an internal __FPC_JVM_Module_Class_Alias$
    type when compiled for the JVM target, which is an "external" class
    that maps to the unit name. This is required to look up the
    JLRMethod instances for regular functions/procedures
  + new tabstractprocdef.copyas() method that allows to create a procvar
    from a procdef and vice versa

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

.gitattributes

@@ -7364,6 +7364,8 @@ rtl/java/jdk15.pas svneol=native#text/plain
 rtl/java/jdynarrh.inc svneol=native#text/plain
 rtl/java/jint64.inc svneol=native#text/plain
 rtl/java/jmathh.inc svneol=native#text/plain
+rtl/java/jpvar.inc svneol=native#text/plain
+rtl/java/jpvarh.inc svneol=native#text/plain
 rtl/java/jrec.inc svneol=native#text/plain
 rtl/java/jrech.inc svneol=native#text/plain
 rtl/java/jset.inc svneol=native#text/plain

compiler/jvm/hlcgcpu.pas

@@ -648,7 +648,9 @@ implementation
       for i:=1 to pred(initdim) do
         elemdef:=tarraydef(elemdef).elementdef;
       if (elemdef.typ in [recorddef,setdef]) or
-         is_shortstring(elemdef) then
+         is_shortstring(elemdef) or
+         ((elemdef.typ=procvardef) and
+          not tprocvardef(elemdef).is_addressonly) then
         begin
           { duplicate array/string/set instance }
           list.concat(taicpu.op_none(a_dup));
@@ -667,7 +669,9 @@ implementation
                       g_call_system_proc(list,'fpc_initialize_array_enumset')
                     else
                       g_call_system_proc(list,'fpc_initialize_array_bitset')
-                  end
+                  end;
+                procvardef:
+                  g_call_system_proc(list,'fpc_initialize_array_procvar');
               end;
               tg.ungettemp(list,recref);
             end
@@ -1170,6 +1174,11 @@ implementation
           end;
         recorddef:
           procname:='FPC_COPY_JRECORD_ARRAY';
+        procvardef:
+          if tprocvardef(eledef).is_addressonly then
+            procname:='FPC_COPY_SHALLOW_ARRAY'
+          else
+            procname:='FPC_COPY_JPROCVAR_ARRAY';
         setdef:
           if tsetdef(eledef).elementdef.typ=enumdef then
             procname:='FPC_COPY_JENUMSET_ARRAY'
@@ -1229,7 +1238,7 @@ implementation
         srsym:=search_struct_member(tabstractrecorddef(size),'FPCDEEPCOPY');
         if not assigned(srsym) or
            (srsym.typ<>procsym) then
-          Message1(cg_f_unknown_compilerproc,'FpcRecordBaseType.fpcDeepCopy');
+          Message1(cg_f_unknown_compilerproc,size.typename+'.fpcDeepCopy');
         pd:=tprocdef(tprocsym(srsym).procdeflist[0]);
         a_call_name(list,pd,pd.mangledname,false);
         { both parameters are removed, no function result }
@@ -1304,6 +1313,14 @@ implementation
                 handled:=true;
               end;
           end;
+        procvardef:
+          begin
+            if not tprocvardef(size).is_addressonly then
+              begin
+                concatcopy_record(list,tprocvardef(size).classdef,source,dest);
+                handled:=true;
+              end;
+          end;
       end;
       if not handled then
         inherited;

compiler/jvm/njvmcal.pas

@@ -28,7 +28,7 @@ interface
     uses
       cgbase,
       symtype,symdef,
-      ncgcal;
+      node,ncgcal;
 
     type
        tjvmcallparanode = class(tcgcallparanode)
@@ -50,6 +50,9 @@ interface
          procedure set_result_location(realresdef: tstoreddef); override;
          procedure do_release_unused_return_value;override;
          procedure extra_post_call_code; override;
+         function dispatch_procvar: tnode;
+        public
+         function pass_1: tnode; override;
        end;
 
 
@@ -61,7 +64,7 @@ implementation
       cgutils,tgobj,procinfo,
       cpubase,aasmdata,aasmcpu,
       hlcgobj,hlcgcpu,
-      pass_1,node,nutils,nbas,ncnv,ncon,ninl,nld,nmem,
+      pass_1,nutils,nbas,ncnv,ncon,ninl,nld,nmem,
       jvmdef;
 
 {*****************************************************************************
@@ -418,36 +421,11 @@ implementation
         realresdef: tdef;
         ppn: tjvmcallparanode;
         pararef: treference;
-{$ifndef nounsupported}
-        i: longint;
-{$endif}
       begin
         if not assigned(typedef) then
           realresdef:=tstoreddef(resultdef)
         else
           realresdef:=tstoreddef(typedef);
-{$ifndef nounsupported}
-        if assigned(right) then
-          begin
-            for i:=1 to pushedparasize do
-              current_asmdata.CurrAsmList.concat(taicpu.op_none(a_pop));
-            if (tabstractprocdef(procdefinition).proctypeoption<>potype_constructor) and
-               (realresdef<>voidtype) then
-              begin
-                case hlcg.def2regtyp(realresdef) of
-                  R_INTREGISTER,
-                  R_ADDRESSREGISTER:
-                    begin
-                      thlcgjvm(hlcg).a_load_const_stack(current_asmdata.CurrAsmList,realresdef,0,hlcg.def2regtyp(realresdef));
-                    end;
-                  R_FPUREGISTER:
-                    thlcgjvm(hlcg).a_loadfpu_const_stack(current_asmdata.CurrAsmList,realresdef,0.0);
-                end;
-                { calling code assumes this result was already put on the stack by the callee }
-                thlcgjvm(hlcg).decstack(current_asmdata.CurrAsmList,align(realresdef.size,4) shr 2);
-              end;
-          end;
-{$endif}
         { a constructor doesn't actually return a value in the jvm }
         if (tabstractprocdef(procdefinition).proctypeoption=potype_constructor) then
           totalremovesize:=pushedparasize
@@ -504,6 +482,64 @@ implementation
       end;
 
 
+  function tjvmcallnode.dispatch_procvar: tnode;
+    var
+      pdclass: tobjectdef;
+      prevpara, para, nextpara: tcallparanode;
+    begin
+      pdclass:=tprocvardef(right.resultdef).classdef;
+      { convert procvar type into corresponding class }
+      if not tprocvardef(right.resultdef).is_addressonly then
+        begin
+          right:=caddrnode.create_internal(right);
+          include(right.flags,nf_typedaddr);
+        end;
+      right:=ctypeconvnode.create_explicit(right,pdclass);
+      include(right.flags,nf_load_procvar);
+      typecheckpass(right);
+
+      { call the invoke method with these parameters. It will take care of the
+        wrapping and typeconversions; first filter out the automatically added
+        hidden parameters though }
+      prevpara:=nil;
+      para:=tcallparanode(left);
+      while assigned(para) do
+        begin
+          nextpara:=tcallparanode(para.right);
+          if vo_is_hidden_para in para.parasym.varoptions then
+            begin
+              if assigned(prevpara) then
+                prevpara.right:=nextpara
+              else
+                left:=nextpara;
+              para.right:=nil;
+              para.free;
+            end
+          else
+            prevpara:=para;
+          para:=nextpara;
+        end;
+      result:=ccallnode.createinternmethod(right,'INVOKE',left);
+      { reused }
+      left:=nil;
+      right:=nil;
+    end;
+
+
+  function tjvmcallnode.pass_1: tnode;
+    begin
+      { transform procvar calls }
+      if assigned(right) then
+        result:=dispatch_procvar
+      else
+        begin
+          result:=inherited pass_1;
+          if assigned(result) then
+            exit;
+        end;
+    end;
+
+
 begin
   ccallnode:=tjvmcallnode;
   ccallparanode:=tjvmcallparanode;

compiler/jvm/njvmcnv.pas

@@ -33,9 +33,12 @@ interface
           function typecheck_dynarray_to_openarray: tnode; override;
           function typecheck_string_to_chararray: tnode; override;
           function typecheck_char_to_string: tnode; override;
+          function typecheck_proc_to_procvar: tnode; override;
           function pass_1: tnode; override;
           function simplify(forinline: boolean): tnode; override;
           function first_set_to_set : tnode;override;
+          function first_nil_to_methodprocvar: tnode; override;
+          function first_proc_to_procvar: tnode; override;
 
           procedure second_int_to_int;override;
          { procedure second_string_to_string;override; }
@@ -49,7 +52,7 @@ interface
           procedure second_int_to_real;override;
          { procedure second_real_to_real;override; }
          { procedure second_cord_to_pointer;override; }
-         { procedure second_proc_to_procvar;override; }
+          procedure second_proc_to_procvar;override;
           procedure second_bool_to_int;override;
           procedure second_int_to_bool;override;
          { procedure second_load_smallset;override;  }
@@ -90,11 +93,11 @@ implementation
 
    uses
       verbose,globals,globtype,constexp,
-      symconst,symdef,symsym,symtable,aasmbase,aasmdata,
+      symbase,symconst,symdef,symsym,symtable,aasmbase,aasmdata,
       defutil,defcmp,jvmdef,
       cgbase,cgutils,pass_1,pass_2,
       nbas,ncon,ncal,ninl,nld,nmem,procinfo,
-      nutils,
+      nutils,paramgr,
       cpubase,aasmcpu,
       tgobj,hlcgobj,hlcgcpu;
 
@@ -113,18 +116,25 @@ implementation
           result:=false;
           if def1.typ<>procvardef then
             exit;
+          { is_addressonly procvars are treated like regular pointer-sized data,
+            po_methodpointer procvars like implicit pointers to a struct }
           if tprocvardef(def1).is_addressonly then
             result:=
+              ((def2.typ=procvardef) and
+               tprocvardef(def2).is_addressonly) or
               (def2=java_jlobject) or
               (def2=voidpointertype)
-          else
+          else if po_methodpointer in tprocvardef(def1).procoptions then
             begin
               if not assigned(tmethoddef) then
                 tmethoddef:=search_system_type('TMETHOD').typedef;
               result:=
                 (def2=methodpointertype) or
-                (def2=tmethoddef);
+                (def2=tmethoddef) or
+                ((def2.typ=procvardef) and
+                 (po_methodpointer in tprocvardef(def2).procoptions));
             end;
+          { can't typecast nested procvars, they need 3 data pointers }
         end;
 
       begin
@@ -186,6 +196,26 @@ implementation
     end;
 
 
+   function tjvmtypeconvnode.typecheck_proc_to_procvar: tnode;
+    begin
+      result:=inherited typecheck_proc_to_procvar;
+      if not assigned(totypedef) then
+        begin
+          if assigned(tprocvardef(resultdef).classdef) then
+            internalerror(2011072405);
+          { associate generic classdef; this is the result of an @proc
+            expression, and such expressions can never result in a direct call
+            -> no invoke() method required (which only exists in custom
+            constructed descendents created for defined procvar types) }
+          if is_nested_pd(tabstractprocdef(resultdef)) then
+            { todo }
+            internalerror(2011072406)
+          else
+            tprocvardef(resultdef).classdef:=java_procvarbase;
+        end;
+    end;
+
+
 {*****************************************************************************
                              FirstTypeConv
 *****************************************************************************}
@@ -295,6 +325,127 @@ implementation
       end;
 
 
+    function tjvmtypeconvnode.first_nil_to_methodprocvar: tnode;
+      begin
+        result:=inherited first_nil_to_methodprocvar;
+        if assigned(result) then
+          exit;
+        if not assigned(tprocvardef(resultdef).classdef) then
+          tprocvardef(resultdef).classdef:=java_procvarbase;
+        result:=ccallnode.createinternmethod(
+          cloadvmtaddrnode.create(ctypenode.create(tprocvardef(resultdef).classdef)),'CREATE',nil);
+        { method pointer is an implicit pointer type }
+        result:=ctypeconvnode.create_explicit(result,getpointerdef(resultdef));
+        result:=cderefnode.create(result);
+      end;
+
+
+    function tjvmtypeconvnode.first_proc_to_procvar: tnode;
+      var
+        constrparas: tcallparanode;
+        newpara: tnode;
+        procdefparas: tarrayconstructornode;
+        pvs: tparavarsym;
+        fvs: tsym;
+        i: longint;
+        corrclass: tdef;
+        jlclass: tobjectdef;
+        encodedtype: tsymstr;
+        procload: tnode;
+        procdef: tprocdef;
+        st: tsymtable;
+        pushaddr: boolean;
+      begin
+        result:=inherited first_proc_to_procvar;
+        if assigned(result) then
+          exit;
+        procdef:=tloadnode(left).procdef;
+        procload:=tloadnode(left).left;
+        if not assigned(procload) then
+          begin
+            { nested or regular routine -> figure out whether unit-level or
+              nested, and if nested whether it's nested in a method or in a
+              regular routine }
+            st:=procdef.owner;
+            while st.symtabletype=localsymtable do
+              st:=st.defowner.owner;
+            if st.symtabletype in [objectsymtable,recordsymtable] then
+              { nested routine in method -> part of encloding class }
+              procload:=cloadvmtaddrnode.create(ctypenode.create(tdef(st.defowner)))
+            else
+              begin
+                { regular procedure/function -> get type representing unit
+                  class }
+                while not(st.symtabletype in [staticsymtable,globalsymtable]) do
+                  st:=st.defowner.owner;
+                corrclass:=search_named_unit_globaltype(st.realname^,'__FPC_JVM_MODULE_CLASS_ALIAS$',true).typedef;
+                procload:=cloadvmtaddrnode.create(ctypenode.create(tdef(corrclass)));
+              end;
+          end;
+        { todo: support nested procvars }
+        if is_nested_pd(procdef) then
+          internalerror(2011072607);
+        { constructor FpcBaseProcVarType.create(inst: jlobject; const method: unicodestring; const argTypes: array of JLClass); }
+        constrparas:=ccallparanode.create(ctypeconvnode.create_explicit(procload,java_jlobject),nil);
+        constrparas:=ccallparanode.create(cstringconstnode.createstr(procdef.procsym.realname),constrparas);
+        procdefparas:=nil;
+        jlclass:=tobjectdef(search_system_type('JLCLASS').typedef);
+        { in reverse to make it easier to build the arrayconstructorn }
+        for i:=procdef.paras.count-1 downto 0 do
+          begin
+            pvs:=tparavarsym(procdef.paras[i]);
+            { self is deal with via the "inst" parameter }
+            if vo_is_self in pvs.varoptions then
+              continue;
+            { in case of an arraydef, pass by jlclass.forName() to get the classdef
+              (could be optimized by adding support to loadvmtaddrnode to also deal
+               with arrays, although we'd have to create specific arraydefs for var/
+               out/constref parameters }
+             pushaddr:=paramanager.push_copyout_param(pvs.varspez,pvs.vardef,procdef.proccalloption);
+             if pushaddr or
+                (pvs.vardef.typ=arraydef) then
+               begin
+                 encodedtype:=jvmencodetype(pvs.vardef,false);
+                 if pushaddr then
+                   encodedtype:='['+encodedtype;
+                 newpara:=ccallnode.createinternmethod(cloadvmtaddrnode.create(ctypenode.create(jlclass)),'FORNAME',
+                   ccallparanode.create(cstringconstnode.createstr(encodedtype),nil));
+               end
+             else
+               begin
+                 corrclass:=jvmgetcorrespondingclassdef(pvs.vardef);
+                 if pvs.vardef.typ in [orddef,floatdef] then
+                   begin
+                     { get the class representing the primitive type }
+                     fvs:=search_struct_member(tobjectdef(corrclass),'FTYPE');
+                     if not assigned(fvs) or
+                        (fvs.typ<>staticvarsym) then
+                       internalerror(2011072417);
+                     newpara:=cloadnode.create(fvs,fvs.owner);
+                   end
+                 else
+                   newpara:=cloadvmtaddrnode.create(ctypenode.create(corrclass));
+                 newpara:=ctypeconvnode.create_explicit(newpara,jlclass);
+               end;
+            procdefparas:=carrayconstructornode.create(newpara,procdefparas);
+          end;
+        if not assigned(procdefparas) then
+          procdefparas:=carrayconstructornode.create(nil,nil);
+        constrparas:=ccallparanode.create(procdefparas,constrparas);
+        result:=ccallnode.createinternmethod(cloadvmtaddrnode.create(ctypenode.create(tprocvardef(resultdef).classdef)),'CREATE',constrparas);
+        { typecast to the procvar type }
+        if tprocvardef(resultdef).is_addressonly then
+          result:=ctypeconvnode.create_explicit(result,resultdef)
+        else
+          begin
+            result:=ctypeconvnode.create_explicit(result,getpointerdef(resultdef));
+            result:=cderefnode.create(result)
+          end;
+        { reused }
+        tloadnode(left).left:=nil;
+      end;
+
+
 {*****************************************************************************
                              SecondTypeConv
 *****************************************************************************}
@@ -433,6 +584,12 @@ implementation
       end;
 
 
+    procedure tjvmtypeconvnode.second_proc_to_procvar;
+      begin
+        internalerror(2011072506);
+      end;
+
+
     procedure tjvmtypeconvnode.second_bool_to_int;
       var
          newsize: tcgsize;
@@ -714,6 +871,61 @@ implementation
             end;
         end;
 
+      function procvar_to_procvar(fromdef, todef: tdef): tnode;
+        var
+          fsym: tsym;
+        begin
+          result:=nil;
+          if fromdef=todef then
+            exit;
+          fsym:=tfieldvarsym(search_struct_member(tprocvardef(fromdef).classdef,'METHOD'));
+          if not assigned(fsym) or
+             (fsym.typ<>fieldvarsym) then
+            internalerror(2011072414);
+          { can either be a procvar or a procvarclass }
+          if fromdef.typ=procvardef then
+            begin
+              left:=ctypeconvnode.create_explicit(left,tprocvardef(fromdef).classdef);
+              include(left.flags,nf_load_procvar);
+              typecheckpass(left);
+            end;
+          result:=csubscriptnode.create(fsym,left);
+          { create destination procvartype with info from source }
+          result:=ccallnode.createinternmethod(
+            cloadvmtaddrnode.create(ctypenode.create(tprocvardef(todef).classdef)),
+            'CREATE',ccallparanode.create(result,nil));
+          left:=nil;
+        end;
+
+      function procvar_to_tmethod(fromdef, todef: tdef): tnode;
+        var
+          fsym: tsym;
+        begin
+          { must be procedure-of-object -> implicit pointer type -> get address
+            before typecasting to corresponding classdef }
+          left:=caddrnode.create_internal(left);
+          inserttypeconv_explicit(left,tprocvardef(fromdef).classdef);
+          fsym:=tfieldvarsym(search_struct_member(tprocvardef(fromdef).classdef,'METHOD'));
+          if not assigned(fsym) or
+             (fsym.typ<>fieldvarsym) then
+            internalerror(2011072414);
+          result:=csubscriptnode.create(fsym,left);
+          left:=nil;
+        end;
+
+      function tmethod_to_procvar(fromdef, todef: tdef): tnode;
+        var
+          fsym: tsym;
+        begin
+          fsym:=tfieldvarsym(search_struct_member(tprocvardef(todef).classdef,'METHOD'));
+          if not assigned(fsym) or
+             (fsym.typ<>fieldvarsym) then
+            internalerror(2011072415);
+          result:=ccallnode.createinternmethod(cloadvmtaddrnode.create(ctypenode.create(tprocvardef(todef).classdef)),
+            'CREATE',ccallparanode.create(left,nil));
+          left:=nil;
+        end;
+
       function ptr_no_typecheck_required(fromdef, todef: tdef): boolean;
 
         function check_type_equality(def1,def2: tdef): boolean;
@@ -762,6 +974,11 @@ implementation
 
         begin
           result:=true;
+          { check procvar conversion compatibility via their classes }
+          if fromdef.typ=procvardef then
+            fromdef:=tprocvardef(fromdef).classdef;
+          if todef.typ=procvardef then
+            todef:=tprocvardef(todef).classdef;
           if (todef=java_jlobject) or
              (todef=voidpointertype) then
             exit;
@@ -809,8 +1026,7 @@ implementation
 
       var
         fromclasscompatible,
-        toclasscompatible,
-        procvarconv: boolean;
+        toclasscompatible: boolean;
         fromdef,
         todef: tdef;
         fromarrtype,
@@ -832,7 +1048,6 @@ implementation
 
         { don't allow conversions between object-based and non-object-based
           types }
-        procvarconv:=isvalidprocvartypeconv(left.resultdef,resultdef);
         fromclasscompatible:=
           (left.resultdef.typ=formaldef) or
           (left.resultdef.typ=pointerdef) or
@@ -841,7 +1056,10 @@ implementation
           ((left.resultdef.typ in [stringdef,classrefdef]) and
            not is_shortstring(left.resultdef)) or
           (left.resultdef.typ=enumdef) or
-          procvarconv;
+          { procvar2procvar needs special handling }
+          ((left.resultdef.typ=procvardef) and
+           tprocvardef(left.resultdef).is_addressonly and
+           (resultdef.typ<>procvardef));
         toclasscompatible:=
           (resultdef.typ=pointerdef) or
           is_java_class_or_interface(resultdef) or
@@ -849,7 +1067,8 @@ implementation
           ((resultdef.typ in [stringdef,classrefdef]) and
            not is_shortstring(resultdef)) or
           (resultdef.typ=enumdef) or
-          procvarconv;
+          ((resultdef.typ=procvardef) and
+           tprocvardef(resultdef).is_addressonly);
         { typescasts from void (the result of untyped_ptr^) to an implicit
           pointertype (record, array, ...) also needs a typecheck }
         if is_void(left.resultdef) and
@@ -884,7 +1103,7 @@ implementation
             toarrtype:=jvmarrtype_setlength(todef);
             if not ptr_no_typecheck_required(fromdef,todef) then
               begin
-                if (fromarrtype in ['A','R','T','E','L']) or
+                if (fromarrtype in ['A','R','T','E','L','P']) or
                    (fromarrtype<>toarrtype) then
                   begin
                     if not check_only and
@@ -942,6 +1161,23 @@ implementation
             exit;
           end;
 
+        { procvar to tmethod and vice versa, and procvar to procvar }
+        if isvalidprocvartypeconv(left.resultdef,resultdef) then
+          begin
+            if not check_only then
+              begin
+                if (left.resultdef.typ=procvardef) and
+                   (resultdef.typ=procvardef) then
+                  resnode:=procvar_to_procvar(left.resultdef,resultdef)
+                else if left.resultdef.typ=procvardef then
+                  resnode:=procvar_to_tmethod(left.resultdef,resultdef)
+                else
+                  resnode:=tmethod_to_procvar(left.resultdef,resultdef);
+              end;
+            result:=true;
+            exit;
+          end;
+
         { don't allow conversions between different classes of primitive types,
           except for a few special cases }
 
@@ -1102,20 +1338,6 @@ implementation
            (left.resultdef.typ=enumdef) and
            (resultdef.typ=objectdef) then
           firstpass(left);
-{$ifndef nounsupported}
-        { generated in nmem; replace voidpointertype with java_jlobject }
-        if nf_load_procvar in flags then
-          begin
-            self.totypedef:=java_jlobject;
-            resultdef:=java_jlobject;
-          end;
-        if isvalidprocvartypeconv(left.resultdef,resultdef) then
-          begin
-            convtype:=tc_equal;
-            result:=true;
-            exit;
-          end;
-{$endif}
       end;
 
 
@@ -1234,13 +1456,10 @@ implementation
             checkdef:=java_juenumset
           else
             checkdef:=java_jubitset;
-        end;
-{$ifndef nounsupported}
-      if checkdef.typ=procvardef then
-        checkdef:=java_jlobject
-      else
-{$endif}
-      if is_wide_or_unicode_string(checkdef) then
+        end
+      else if checkdef.typ=procvardef then
+        checkdef:=tprocvardef(checkdef).classdef
+      else if is_wide_or_unicode_string(checkdef) then
         checkdef:=java_jlstring
       else if is_ansistring(checkdef) then
         checkdef:=java_ansistring

compiler/jvm/njvmld.pas

@@ -55,7 +55,7 @@ implementation
 uses
   verbose,
   aasmdata,
-  nbas,nld,ncal,ninl,nmem,ncnv,
+  nbas,nld,ncal,ncon,ninl,nmem,ncnv,
   symconst,symsym,symdef,symtable,defutil,jvmdef,
   paramgr,
   pass_1,
@@ -187,6 +187,9 @@ procedure tjvmloadnode.pass_generate_code;
         else
           hlcg.a_load_loc_reg(current_asmdata.CurrAsmList,java_jlobject,java_jlobject,tparavarsym(symtableentry).localloc,location.reference.base);
       end
+    else if symtableentry.typ=procsym then
+      { handled in tjvmcnvnode.first_proc_to_procvar }
+      internalerror(2011072408)
     else
       inherited pass_generate_code;
   end;

compiler/jvm/njvmmem.pas

@@ -120,6 +120,8 @@ implementation
 *****************************************************************************}
 
     function tjvmaddrnode.pass_typecheck: tnode;
+      var
+        fsym: tsym;
       begin
         result:=nil;
         typecheckpass(left);
@@ -128,12 +130,73 @@ implementation
 
         make_not_regable(left,[ra_addr_regable,ra_addr_taken]);
 
-        if (left.resultdef.typ=procdef) or
-           (
-            (left.resultdef.typ=procvardef) and
-            ((m_tp_procvar in current_settings.modeswitches) or
-             (m_mac_procvar in current_settings.modeswitches))
-           ) then
+        { in TP/Delphi, @procvar = contents of procvar and @@procvar =
+          address of procvar. In case of a procedure of object, this works
+          by letting the first addrnode typecast the procvar into a tmethod
+          record followed by subscripting its "code" field (= first field),
+          and if there's a second addrnode then it takes the address of
+          this code field (which is hence also the address of the procvar).
+
+          In Java, such ugly hacks don't work -> replace first addrnode
+          with getting procvar.method.code, and second addrnode with
+          the class for procedure of object}
+        if not(nf_internal in flags) and
+           ((m_tp_procvar in current_settings.modeswitches) or
+            (m_mac_procvar in current_settings.modeswitches)) and
+           (((left.nodetype=addrn) and
+             (taddrnode(left).left.resultdef.typ=procvardef)) or
+            (left.resultdef.typ=procvardef)) then
+          begin
+            if (left.nodetype=addrn) and
+               (taddrnode(left).left.resultdef.typ=procvardef) then
+              begin
+                { double address -> pointer that is the address of the
+                  procvardef (don't allow for non-object procvars, as they
+                  aren't implicitpointerdefs) }
+                if not jvmimplicitpointertype(taddrnode(left).left.resultdef) then
+                  CGMessage(parser_e_illegal_expression)
+                else
+                  begin
+                    { an internal address node will observe "normal" address
+                      operator semantics (= take the actual address!) }
+                    result:=caddrnode.create_internal(taddrnode(left).left);
+                    result:=ctypeconvnode.create_explicit(result,tprocvardef(taddrnode(left).left.resultdef).classdef);
+                    taddrnode(left).left:=nil;
+                 end;
+              end
+            else if left.resultdef.typ=procvardef then
+              begin
+                if not tprocvardef(left.resultdef).is_addressonly then
+                  begin
+                    { the "code" field from the procvar }
+                    result:=caddrnode.create_internal(left);
+                    result:=ctypeconvnode.create_explicit(result,tprocvardef(left.resultdef).classdef);
+                    { procvarclass.method }
+                    fsym:=search_struct_member(tprocvardef(left.resultdef).classdef,'METHOD');
+                    if not assigned(fsym) or
+                       (fsym.typ<>fieldvarsym) then
+                      internalerror(2011072501);
+                    result:=csubscriptnode.create(fsym,result);
+                    { procvarclass.method.code }
+                    fsym:=search_struct_member(trecorddef(tfieldvarsym(fsym).vardef),'CODE');
+                    if not assigned(fsym) or
+                       (fsym.typ<>fieldvarsym) then
+                      internalerror(2011072502);
+                    result:=csubscriptnode.create(fsym,result);
+                    left:=nil
+                  end
+                else
+                  { convert contents to plain pointer }
+                  begin
+                    result:=ctypeconvnode.create_explicit(left,java_jlobject);
+                    include(result.flags,nf_load_procvar);
+                    left:=nil;
+                  end;
+              end
+            else
+              internalerror(2011072506);
+          end
+        else if (left.resultdef.typ=procdef) then
           begin
             result:=inherited;
             exit;
@@ -181,14 +244,7 @@ implementation
           end
         else
           begin
-            { procvar }
-{$ifndef nounsupported}
-            location_reset(location,LOC_REGISTER,OS_ADDR);
-            location.register:=hlcg.getaddressregister(current_asmdata.CurrAsmList,java_jlobject);
-            hlcg.a_load_const_reg(current_asmdata.CurrAsmList,java_jlobject,0,location.register);
-{$else}
             internalerror(2011051601);
-{$endif}
           end;
       end;
 
@@ -199,7 +255,7 @@ implementation
     procedure tjvmloadvmtaddrnode.pass_generate_code;
       begin
         current_asmdata.CurrAsmList.concat(taicpu.op_sym(a_ldc,current_asmdata.RefAsmSymbol(
-          tobjectdef(tclassrefdef(resultdef).pointeddef).jvm_full_typename(true))));
+          tabstractrecorddef(tclassrefdef(resultdef).pointeddef).jvm_full_typename(true))));
         thlcgjvm(hlcg).incstack(current_asmdata.CurrAsmList,1);
         location_reset(location,LOC_REGISTER,OS_ADDR);
         location.register:=hlcg.getaddressregister(current_asmdata.CurrAsmList,resultdef);

compiler/jvm/tgcpu.pas

@@ -40,6 +40,7 @@ unit tgcpu;
 
        ttgjvm = class(ttgobj)
         protected
+         procedure getimplicitobjtemp(list: TAsmList; def: tdef; temptype: ttemptype; out ref: treference);
          function getifspecialtemp(list: TAsmList; def: tdef; forcesize: aint; temptype: ttemptype; out ref: treference): boolean;
          function alloctemp(list: TAsmList; size, alignment: longint; temptype: ttemptype; def: tdef): longint; override;
         public
@@ -61,6 +62,36 @@ unit tgcpu;
 
     { ttgjvm }
 
+    procedure ttgjvm.getimplicitobjtemp(list: TAsmList; def: tdef; temptype: ttemptype; out ref: treference);
+      var
+        sym: tsym;
+        pd: tprocdef;
+      begin
+        gettemp(list,java_jlobject.size,java_jlobject.alignment,temptype,ref);
+        list.concat(taicpu.op_sym(a_new,current_asmdata.RefAsmSymbol(tabstractrecorddef(def).jvm_full_typename(true))));
+        { the constructor doesn't return anything, so put a duplicate of the
+          self pointer on the evaluation stack for use as function result
+          after the constructor has run }
+        list.concat(taicpu.op_none(a_dup));
+        thlcgjvm(hlcg).incstack(list,2);
+        { call the constructor }
+        sym:=tsym(tabstractrecorddef(def).symtable.find('CREATE'));
+        if assigned(sym) and
+           (sym.typ=procsym) then
+          begin
+            pd:=tprocsym(sym).find_bytype_parameterless(potype_constructor);
+            if not assigned(pd) then
+              internalerror(2011032701);
+          end
+        else
+          internalerror(2011060301);
+        hlcg.a_call_name(list,pd,pd.mangledname,false);
+        thlcgjvm(hlcg).decstack(list,1);
+        { store reference to instance }
+        thlcgjvm(hlcg).a_load_stack_ref(list,java_jlobject,ref,0);
+      end;
+
+
     function ttgjvm.getifspecialtemp(list: TAsmList; def: tdef; forcesize: aint; temptype: ttemptype; out ref: treference): boolean;
       var
         eledef: tdef;
@@ -99,28 +130,7 @@ unit tgcpu;
             end;
           recorddef:
             begin
-              gettemp(list,java_jlobject.size,java_jlobject.alignment,temptype,ref);
-              list.concat(taicpu.op_sym(a_new,current_asmdata.RefAsmSymbol(trecorddef(def).jvm_full_typename(true))));
-              { the constructor doesn't return anything, so put a duplicate of the
-                self pointer on the evaluation stack for use as function result
-                after the constructor has run }
-              list.concat(taicpu.op_none(a_dup));
-              thlcgjvm(hlcg).incstack(list,2);
-              { call the constructor }
-              sym:=tsym(trecorddef(def).symtable.find('CREATE'));
-              if assigned(sym) and
-                 (sym.typ=procsym) then
-                begin
-                  pd:=tprocsym(sym).find_bytype_parameterless(potype_constructor);
-                  if not assigned(pd) then
-                    internalerror(2011032701);
-                end
-              else
-                internalerror(2011060301);
-              hlcg.a_call_name(list,pd,pd.mangledname,false);
-              thlcgjvm(hlcg).decstack(list,1);
-              { store reference to instance }
-              thlcgjvm(hlcg).a_load_stack_ref(list,java_jlobject,ref,0);
+              getimplicitobjtemp(list,def,temptype,ref);
               result:=true;
             end;
           setdef:
@@ -171,6 +181,14 @@ unit tgcpu;
               thlcgjvm(hlcg).a_load_stack_ref(list,java_jlobject,ref,0);
               result:=true;
             end;
+          procvardef:
+            begin
+              if not tprocvardef(def).is_addressonly then
+                begin
+                  getimplicitobjtemp(list,tprocvardef(def).classdef,temptype,ref);
+                  result:=true;
+                end;
+            end;
           stringdef:
             begin
               if is_shortstring(def) then

compiler/jvmdef.pas

@@ -79,6 +79,8 @@ interface
     procedure jvmgetboxtype(def: tdef; out objdef, paradef: tdef; mergeints: boolean);
     function jvmgetunboxmethod(def: tdef): string;
 
+    function jvmgetcorrespondingclassdef(def: tdef): tdef;
+
 implementation
 
   uses
@@ -338,13 +340,7 @@ implementation
             end;
           procvardef :
             begin
-{$ifndef nounsupported}
-              result:=jvmaddencodedtype(java_jlobject,false,encodedstr,forcesignature,founderror);
-{$else}
-              { will be hanlded via wrapping later, although wrapping may
-                happen at higher level }
-              result:=false;
-{$endif}
+              result:=jvmaddencodedtype(tprocvardef(def).classdef,false,encodedstr,forcesignature,founderror);
             end;
           objectdef :
             case tobjectdef(def).objecttype of
@@ -471,6 +467,9 @@ implementation
             else
               result:='L'
           end
+        else if (def.typ=procvardef) and
+                not tprocvardef(def).is_addressonly then
+          result:='P'
         else
           begin
             if not jvmtryencodetype(def,res,false,errdef) then
@@ -643,6 +642,90 @@ implementation
       end;
 
 
+    function jvmgetcorrespondingclassdef(def: tdef): tdef;
+      var
+        paradef: tdef;
+      begin
+        if def.typ in [orddef,floatdef] then
+          jvmgetboxtype(def,result,paradef,false)
+        else
+          begin
+            case def.typ of
+              stringdef :
+                begin
+                  case tstringdef(def).stringtype of
+                    { translated into java.lang.String }
+                    st_widestring,
+                    st_unicodestring:
+                      result:=java_jlstring;
+                    st_ansistring:
+                      result:=java_ansistring;
+                    st_shortstring:
+                      result:=java_shortstring;
+                    else
+                      internalerror(2011072409);
+                  end;
+                end;
+              enumdef:
+                begin
+                  result:=tenumdef(def).classdef;
+                end;
+              pointerdef :
+                begin
+                  if def=voidpointertype then
+                    result:=java_jlobject
+                  else if jvmimplicitpointertype(tpointerdef(def).pointeddef) then
+                    result:=tpointerdef(def).pointeddef
+                  else
+                    internalerror(2011072410);
+                end;
+              recorddef :
+                begin
+                  result:=def;
+                end;
+              variantdef :
+                begin
+                  result:=cvarianttype;
+                end;
+              classrefdef :
+                begin
+                  result:=search_system_type('JLCLASS').typedef;
+                end;
+              setdef :
+                begin
+                  if tsetdef(def).elementdef.typ=enumdef then
+                    result:=java_juenumset
+                  else
+                    result:=java_jubitset;
+                end;
+              formaldef :
+                begin
+                  result:=java_jlobject;
+                end;
+              arraydef :
+                begin
+                  { cannot represent statically }
+                  internalerror(2011072411);
+                end;
+              procvardef :
+                begin
+                  result:=tprocvardef(def).classdef;
+                end;
+              objectdef :
+                case tobjectdef(def).objecttype of
+                  odt_javaclass,
+                  odt_interfacejava:
+                    result:=def
+                  else
+                    internalerror(2011072412);
+                end;
+              else
+                internalerror(2011072413);
+            end;
+          end;
+      end;
+
+
     function jvmmangledbasename(sym: tsym; const usesymname: TSymStr; withsignature: boolean): TSymStr;
       var
         container: tsymtable;

compiler/ncgcnv.pas

@@ -480,14 +480,6 @@ interface
       var
         tmpreg: tregister;
       begin
-{$ifdef jvm}
-{$ifndef nounsupported}
-         location_reset(location,LOC_REGISTER,OS_ADDR);
-         location.register:=hlcg.getaddressregister(current_asmdata.CurrAsmList,java_jlobject);
-         hlcg.a_load_const_reg(current_asmdata.CurrAsmList,java_jlobject,0,location.register);
-         exit;
-{$endif nounsupported}
-{$endif jvm}
         if tabstractprocdef(resultdef).is_addressonly then
           begin
             location_reset(location,LOC_REGISTER,OS_ADDR);

compiler/ncgld.pas

@@ -467,14 +467,6 @@ implementation
              end;
            procsym:
               begin
-{$ifdef jvm}
-{$ifndef nounsupported}
-                 location_reset(location,LOC_REGISTER,OS_ADDR);
-                 location.register:=hlcg.getaddressregister(current_asmdata.CurrAsmList,java_jlobject);
-                 hlcg.a_load_const_reg(current_asmdata.CurrAsmList,java_jlobject,0,location.register);
-                 exit;
-{$endif nounsupported}
-{$endif jvm}
                  if not assigned(procdef) then
                    internalerror(200312011);
                  if assigned(left) then
@@ -1083,8 +1075,11 @@ implementation
         fillchar(paraloc,sizeof(paraloc),0);
         { Allocate always a temp, also if no elements are required, to
           be sure that location is valid (PFV) }
+        { on the JVM platform, an array can have 0 elements; since the length
+          of the array is part of the array itself, make sure we allocate one
+          of the proper length to avoid getting unexpected results later }
          if tarraydef(resultdef).highrange=-1 then
-           tg.gethltemp(current_asmdata.CurrAsmList,resultdef,elesize,tt_normal,location.reference)
+           tg.gethltemp(current_asmdata.CurrAsmList,resultdef,{$ifdef jvm}0{$else}elesize{$endif},tt_normal,location.reference)
          else
            tg.gethltemp(current_asmdata.CurrAsmList,resultdef,(tarraydef(resultdef).highrange+1)*elesize,tt_normal,location.reference);
          href:=location.reference;

compiler/ncnv.pas

@@ -1823,22 +1823,6 @@ implementation
       end;
 
 
-    procedure copyparasym(p:TObject;arg:pointer);
-      var
-        newparast : TSymtable absolute arg;
-        vs : tparavarsym;
-      begin
-        if tsym(p).typ<>paravarsym then
-          exit;
-        with tparavarsym(p) do
-          begin
-            vs:=tparavarsym.create(realname,paranr,varspez,vardef,varoptions);
-            vs.defaultconstsym:=defaultconstsym;
-            newparast.insert(vs);
-          end;
-      end;
-
-
     function ttypeconvnode.typecheck_proc_to_procvar : tnode;
       var
         pd : tabstractprocdef;
@@ -1856,15 +1840,7 @@ implementation
           resultdef:=totypedef
         else
          begin
-           nestinglevel:=pd.parast.symtablelevel;
-           resultdef:=tprocvardef.create(nestinglevel);
-           tprocvardef(resultdef).proctypeoption:=pd.proctypeoption;
-           tprocvardef(resultdef).proccalloption:=pd.proccalloption;
-           tprocvardef(resultdef).procoptions:=pd.procoptions;
-           tprocvardef(resultdef).returndef:=pd.returndef;
-           { method ? then set the methodpointer flag }
-           if (pd.owner.symtabletype=ObjectSymtable) then
-             include(tprocvardef(resultdef).procoptions,po_methodpointer);
+           resultdef:=pd.getcopyas(procvardef,pc_normal);
            { only need the address of the method? this is needed
              for @tobject.create. In this case there will be a loadn without
              a methodpointer. }
@@ -1873,11 +1849,7 @@ implementation
               (not(m_nested_procvars in current_settings.modeswitches) or
                not is_nested_pd(tprocvardef(resultdef))) then
              include(tprocvardef(resultdef).procoptions,po_addressonly);
-
-           { Add parameters use only references, we don't need to keep the
-             parast. We use the parast from the original function to calculate
-             our parameter data and reset it afterwards }
-           pd.parast.SymList.ForEachCall(@copyparasym,tprocvardef(resultdef).parast);
+           { calculate parameter list & order }
            tprocvardef(resultdef).calcparas;
          end;
       end;

compiler/nmem.pas

@@ -491,6 +491,9 @@ implementation
           special handling }
         if (left.resultdef.typ=procdef) or
            (
+            { in case of nf_internal, follow the normal FPC semantics so that
+              we can easily get the actual address of a procvar }
+            not(nf_internal in flags) and
             (left.resultdef.typ=procvardef) and
             ((m_tp_procvar in current_settings.modeswitches) or
              (m_mac_procvar in current_settings.modeswitches))

compiler/pdecobj.pas

@@ -1288,6 +1288,9 @@ implementation
                           fsym:=tfieldvarsym.create('$proc',vs_value,java_jlobject,[]);
                           hrecst.insert(fsym);
                           hrecst.addfield(fsym,vis_hidden);
+                          fsym:=tfieldvarsym.create('$data',vs_value,java_jlobject,[]);
+                          hrecst.insert(fsym);
+                          hrecst.addfield(fsym,vis_hidden);
                           methodpointertype:=trecorddef.create('',hrecst);
                           systemunit.insert(ttypesym.create('$methodpointer',methodpointertype));
                         end
@@ -1307,6 +1310,8 @@ implementation
                         java_juenumset:=current_objectdef
                       else if (current_objectdef.objname^='FPCBITSET') then
                         java_jubitset:=current_objectdef
+                      else if (current_objectdef.objname^='FPCBASEPROCVARTYPE') then
+                        java_procvarbase:=current_objectdef;
                     end;
                 end;
               end;

compiler/pdecsub.pas

@@ -93,6 +93,9 @@ implementation
        { parser }
        scanner,
        pbase,pexpr,ptype,pdecl,pparautl
+{$ifdef jvm}
+       ,pjvm
+{$endif}
        ;
 
     const
@@ -311,6 +314,10 @@ implementation
                end;
              { Add implicit hidden parameters and function result }
              handle_calling_convention(pv);
+{$ifdef jvm}
+             { anonymous -> no name }
+             jvm_create_procvar_class('',pv);
+{$endif}
            end
           else
           { read type declaration, force reading for value paras }

compiler/pjvm.pas

@@ -40,6 +40,7 @@ interface
     procedure add_java_default_record_methods_intf(def: trecorddef);
 
     procedure jvm_maybe_create_enum_class(const name: TIDString; def: tdef);
+    procedure jvm_create_procvar_class(const name: TIDString; def: tdef);
 
     function jvm_add_typed_const_initializer(csym: tconstsym): tstaticvarsym;
 
@@ -53,7 +54,7 @@ implementation
     verbose,systems,
     fmodule,
     parabase,aasmdata,
-    pdecsub,ngenutil,
+    pdecsub,ngenutil,pparautl,
     symtable,symcreat,defcmp,jvmdef,
     defutil,paramgr;
 
@@ -208,6 +209,36 @@ implementation
       end;
 
 
+    procedure setup_for_new_class(const scannername: string; out sstate: tscannerstate; out islocal: boolean; out oldsymtablestack: TSymtablestack);
+      begin
+        replace_scanner(scannername,sstate);
+        oldsymtablestack:=symtablestack;
+        islocal:=symtablestack.top.symtablelevel>=normal_function_level;
+        if islocal then
+          begin
+            { we cannot add a class local to a procedure -> insert it in the
+              static symtable. This is not ideal because this means that it will
+              be saved to the ppu file for no good reason, and loaded again
+              even though it contains a reference to a type that was never
+              saved to the ppu file (the locally defined enum type). Since this
+              alias for the locally defined enumtype is only used while
+              implementing the class' methods, this is however no problem. }
+            symtablestack:=symtablestack.getcopyuntil(current_module.localsymtable);
+          end;
+      end;
+
+
+    procedure restore_after_new_class(const sstate: tscannerstate; const islocal: boolean; const oldsymtablestack: TSymtablestack);
+      begin
+        if islocal then
+          begin
+            symtablestack.free;
+            symtablestack:=oldsymtablestack;
+          end;
+        restore_scanner(sstate);
+      end;
+
+
     procedure jvm_maybe_create_enum_class(const name: TIDString; def: tdef);
       var
         arrdef: tarraydef;
@@ -228,20 +259,8 @@ implementation
         { if it's a subrange type, don't create a new class }
         if assigned(tenumdef(def).basedef) then
           exit;
-        replace_scanner('jvm_enum_class',sstate);
-        oldsymtablestack:=symtablestack;
-        islocal:=symtablestack.top.symtablelevel>=normal_function_level;
-        if islocal then
-          begin
-            { we cannot add a class local to a procedure -> insert it in the
-              static symtable. This is not ideal because this means that it will
-              be saved to the ppu file for no good reason, and loaded again
-              even though it contains a reference to a type that was never
-              saved to the ppu file (the locally defined enum type). Since this
-              alias for the locally defined enumtype is only used while
-              implementing the class' methods, this is however no problem. }
-            symtablestack:=symtablestack.getcopyuntil(current_module.localsymtable);
-          end;
+
+        setup_for_new_class('jvm_enum_class',sstate,islocal,oldsymtablestack);
 
         { create new class (different internal name than enum to prevent name
           clash; at unit level because we don't want its methods to be nested
@@ -396,13 +415,65 @@ implementation
         pd.synthetickind:=tsk_jvm_enum_classconstr;
 
         symtablestack.pop(enumclass.symtable);
-        if islocal then
-          begin
-            symtablestack.free;
-            symtablestack:=oldsymtablestack;
-          end;
+        restore_after_new_class(sstate,islocal,oldsymtablestack);
         current_structdef:=old_current_structdef;
-        restore_scanner(sstate);
+      end;
+
+
+    procedure jvm_create_procvar_class(const name: TIDString; def: tdef);
+      var
+        oldsymtablestack: tsymtablestack;
+        pvclass: tobjectdef;
+        temptypesym: ttypesym;
+        sstate: tscannerstate;
+        methoddef: tprocdef;
+        islocal: boolean;
+      begin
+        { inlined definition of procvar -> generate name, derive from
+          FpcBaseNestedProcVarType, pass nestedfpstruct to constructor and
+          copy it }
+        if name='' then
+          internalerror(2011071901);
+
+        setup_for_new_class('jvm_pvar_class',sstate,islocal,oldsymtablestack);
+
+        { create new class (different internal name than pvar to prevent name
+          clash; at unit level because we don't want its methods to be nested
+          inside a function in case its a local type) }
+        pvclass:=tobjectdef.create(odt_javaclass,'$'+current_module.realmodulename^+'$'+name+'$InternProcvar$'+tostr(def.defid),java_procvarbase);
+        tprocvardef(def).classdef:=pvclass;
+        include(pvclass.objectoptions,oo_is_sealed);
+        { associate typesym }
+        pvclass.symtable.insert(ttypesym.create('__FPC_TProcVarClassAlias',pvclass));
+        { set external name to match procvar type name }
+        if not islocal then
+          pvclass.objextname:=stringdup(name)
+        else
+          pvclass.objextname:=stringdup(pvclass.objrealname^);
+
+        symtablestack.push(pvclass.symtable);
+
+        { inherit constructor and keep public }
+        add_missing_parent_constructors_intf(pvclass,vis_public);
+
+        { add a method to call the procvar using unwrapped arguments, which
+          then wraps them and calls through to JLRMethod.invoke }
+        methoddef:=tprocdef(tprocvardef(def).getcopyas(procdef,pc_procvar2bareproc));
+        finish_copied_procdef(methoddef,'invoke',pvclass.symtable,pvclass);
+        insert_self_and_vmt_para(methoddef);
+        methoddef.synthetickind:=tsk_jvm_procvar_invoke;
+        methoddef.calcparas;
+
+        { add local alias for the procvartype that we can use when implementing
+          the invoke method }
+        temptypesym:=ttypesym.create('__FPC_ProcVarAlias',nil);
+        { don't pass def to the ttypesym constructor, because then it
+          will replace the current (real) typesym of that def with the alias }
+        temptypesym.typedef:=def;
+        pvclass.symtable.insert(temptypesym);
+
+        symtablestack.pop(pvclass.symtable);
+        restore_after_new_class(sstate,islocal,oldsymtablestack);
       end;
 
 

compiler/pmodules.pas

@@ -684,6 +684,24 @@ implementation
       end;
 
 
+{$ifdef jvm}
+      procedure addmoduleclass;
+        var
+          def: tobjectdef;
+          typesym: ttypesym;
+        begin
+          { java_jlobject may not have been parsed yet (system unit); in any
+            case, we only use this to refer to the class type, so inheritance
+            does not matter }
+          def:=tobjectdef.create(odt_javaclass,'__FPC_JVM_Module_Class_Alias$',nil);
+          include(def.objectoptions,oo_is_external);
+          include(def.objectoptions,oo_is_sealed);
+          def.objextname:=stringdup(current_module.realmodulename^);
+          typesym:=ttypesym.create('__FPC_JVM_Module_Class_Alias$',def);
+          symtablestack.top.insert(typesym);
+        end;
+{$endif jvm}
+
     procedure proc_unit;
 
       function is_assembler_generated:boolean;
@@ -835,6 +853,10 @@ implementation
          { ... parse the declarations }
          Message1(parser_u_parsing_interface,current_module.realmodulename^);
          symtablestack.push(current_module.globalsymtable);
+{$ifdef jvm}
+         { fake classdef to represent the class corresponding to the unit }
+         addmoduleclass;
+{$endif}
          read_interface_declarations;
          symtablestack.pop(current_module.globalsymtable);
 
@@ -1813,6 +1835,11 @@ implementation
 
          symtablestack.push(current_module.localsymtable);
 
+{$ifdef jvm}
+         { fake classdef to represent the class corresponding to the unit }
+         addmoduleclass;
+{$endif}
+
          { Insert _GLOBAL_OFFSET_TABLE_ symbol if system uses it }
          maybe_load_got;
 

compiler/ptype.pas

@@ -1724,6 +1724,9 @@ implementation
             _FUNCTION:
               begin
                 def:=procvar_dec(genericdef,genericlist);
+{$ifdef jvm}
+                jvm_create_procvar_class(name,def);
+{$endif}
               end;
             else
               if (token=_KLAMMERAFFE) and (m_iso in current_settings.modeswitches) then

compiler/symcreat.pas

@@ -113,7 +113,7 @@ implementation
     symtable,defutil,
     pbase,pdecobj,pdecsub,psub,ptconst,
 {$ifdef jvm}
-    pjvm,
+    pjvm,jvmdef,
 {$endif jvm}
     node,nbas,nld,nmem,
     defcmp,
@@ -623,12 +623,114 @@ implementation
               'ele:=FpcEnumValueObtainable(it.next);'+
               'i:=ele.fpcOrdinal-__fromsetbase;'+
               'result.add(fpcValueOf(i+__tosetbase));'+
-             'end '+
+            'end '+
           'end;',
         pd,true);
     end;
 
 
+  procedure implement_jvm_procvar_invoke(pd: tprocdef);
+{$ifdef jvm}
+    var
+      pvclass: tobjectdef;
+      procvar: tprocvardef;
+      paraname,str,endstr: ansistring;
+      pvs: tparavarsym;
+      paradef,boxdef,boxargdef: tdef;
+      i: longint;
+      firstpara: boolean;
+{$endif jvm}
+    begin
+{$ifndef jvm}
+      internalerror(2011072401);
+{$else not jvm}
+      pvclass:=tobjectdef(pd.owner.defowner);
+      procvar:=tprocvardef(ttypesym(search_struct_member(pvclass,'__FPC_PROCVARALIAS')).typedef);
+      { the procvar wrapper class has a tmethod member called "method", whose
+        "code" field is a JLRMethod, and whose "data" field is the self pointer
+        if any (if none is required, it's ignored by the JVM, so there's no
+        problem with always passing it) }
+
+      { force extended syntax to allow calling invokeObjectFunc() without using
+        its result }
+      str:='';
+      endstr:='';
+      { create local pointer to result type for typecasting in case of an
+        implicit pointer type }
+      if jvmimplicitpointertype(procvar.returndef) then
+         str:=str+'type __FPC_returnptrtype = ^'+procvar.returndef.typename+';';
+      str:=str+'begin ';
+      { result handling }
+      if not is_void(procvar.returndef) then
+        begin
+          str:=str+'invoke:=';
+          if procvar.returndef.typ in [orddef,floatdef] then
+            begin
+              { primitivetype(boxtype(..).unboxmethod) }
+              jvmgetboxtype(procvar.returndef,boxdef,boxargdef,false);
+              str:=str+procvar.returndef.typename+'('+boxdef.typename+'(';
+              endstr:=').'+jvmgetunboxmethod(procvar.returndef)+')';
+            end
+          else if jvmimplicitpointertype(procvar.returndef) then
+            begin
+              str:=str+'__FPC_returnptrtype(';
+              { dereference }
+              endstr:=')^';
+            end
+          else
+            begin
+              str:=str+procvar.returndef.typename+'(';
+              endstr:=')';
+            end;
+        end;
+      str:=str+'invokeObjectFunc([';
+      { parameters are a constant array of jlobject }
+      firstpara:=true;
+      for i:=0 to procvar.paras.count-1 do
+        begin
+          { skip self/vmt/parentfp, passed separately }
+          pvs:=tparavarsym(procvar.paras[i]);
+          if ([vo_is_self,vo_is_vmt,vo_is_parentfp]*pvs.varoptions)<>[] then
+            continue;
+          if not firstpara then
+            str:=str+',';
+          firstpara:=false;
+          paraname:=pvs.realname;
+          paradef:=pvs.vardef;
+          { Pascalize hidden high parameter }
+          if vo_is_high_para in pvs.varoptions then
+            paraname:='high('+tparavarsym(procvar.paras[i-1]).realname+')'
+          else if vo_is_hidden_para in pvs.varoptions then
+            begin
+              if ([vo_is_range_check,vo_is_overflow_check]*pvs.varoptions)<>[] then
+                { ok, simple boolean parameters }
+              else
+                internalerror(2011072403);
+            end;
+          { var/out/constref parameters -> pass address through (same for
+            implicit pointer types) }
+          if paramanager.push_addr_param(pvs.varspez,paradef,procvar.proccalloption) or
+             jvmimplicitpointertype(paradef) then
+            begin
+              paraname:='@'+paraname;
+              paradef:=java_jlobject;
+            end;
+          if paradef.typ in [orddef,floatdef] then
+            begin
+              { box primitive types; use valueOf() rather than create because it
+                can give better performance }
+              jvmgetboxtype(paradef,boxdef,boxargdef,false);
+              str:=str+boxdef.typename+'.valueOf('+boxargdef.typename+'('+paraname+'))'
+            end
+          else
+            str:=str+'JLObject('+paraname+')';
+        end;
+      str:=str+'])'+endstr+' end;';
+      str_parse_method_impl(str,pd,false)
+{$endif not jvm}
+    end;
+
+
   procedure add_synthetic_method_implementations_for_struct(struct: tabstractrecorddef);
     var
       i   : longint;
@@ -676,6 +778,8 @@ implementation
               implement_jvm_enum_bitset2set(pd);
             tsk_jvm_enum_set2set:
               implement_jvm_enum_set2set(pd);
+            tsk_jvm_procvar_invoke:
+              implement_jvm_procvar_invoke(pd);
             else
               internalerror(2011032801);
           end;
@@ -747,22 +851,27 @@ implementation
       if assigned(newstruct) then
         begin
           symtablestack.push(pd.parast);
-          for i:=0 to pd.paras.count-1 do
+          { may not be assigned in case we converted a procvar into a procdef }
+          if assigned(pd.paras) then
             begin
-              parasym:=tparavarsym(pd.paras[i]);
-              if vo_is_self in parasym.varoptions then
+              for i:=0 to pd.paras.count-1 do
                 begin
-                  if parasym.vardef.typ=classrefdef then
-                    parasym.vardef:=tclassrefdef.create(newstruct)
-                  else
-                    parasym.vardef:=newstruct;
-                end
+                  parasym:=tparavarsym(pd.paras[i]);
+                  if vo_is_self in parasym.varoptions then
+                    begin
+                      if parasym.vardef.typ=classrefdef then
+                        parasym.vardef:=tclassrefdef.create(newstruct)
+                      else
+                        parasym.vardef:=newstruct;
+                    end
+                end;
             end;
           { also fix returndef in case of a constructor }
           if pd.proctypeoption=potype_constructor then
             pd.returndef:=newstruct;
           symtablestack.pop(pd.parast);
         end;
+      pd.calcparas;
       proc_add_definition(pd);
     end;
 

compiler/symdef.pas

@@ -427,6 +427,10 @@ interface
        tprocnameoption = (pno_showhidden, pno_proctypeoption, pno_paranames,
          pno_ownername, pno_noclassmarker, pno_noleadingdollar);
        tprocnameoptions = set of tprocnameoption;
+       tproccopytyp = (pc_normal,
+                       { always creates a top-level function, removes all
+                         special parameters (self, vmt, parentfp, ...) }
+                       pc_procvar2bareproc);
 
        tabstractprocdef = class(tstoreddef)
           { saves a definition to the return type }
@@ -458,6 +462,8 @@ interface
           function  is_methodpointer:boolean;virtual;
           function  is_addressonly:boolean;virtual;
           function  no_self_node:boolean;
+          { get either a copy as a procdef or procvardef }
+          function  getcopyas(newtyp:tdeftyp;copytyp:tproccopytyp): tstoreddef;
           procedure check_mark_as_nested;
           procedure init_paraloc_info(side: tcallercallee);
           function stack_tainting_parameter(side: tcallercallee): boolean;
@@ -467,10 +473,19 @@ interface
        end;
 
        tprocvardef = class(tabstractprocdef)
+{$ifdef jvm}
+          { class representing this procvar on the Java side }
+          classdef  : tobjectdef;
+          classdefderef : tderef;
+{$endif}
           constructor create(level:byte);
           constructor ppuload(ppufile:tcompilerppufile);
           function getcopy : tstoreddef;override;
           procedure ppuwrite(ppufile:tcompilerppufile);override;
+{$ifdef jvm}
+          procedure buildderef;override;
+          procedure deref;override;
+{$endif}
           function  GetSymtable(t:tGetSymtable):TSymtable;override;
           function  size : asizeint;override;
           function  GetTypeName:string;override;
@@ -511,7 +526,8 @@ interface
          tsk_jvm_enum_fpcvalueof,   // Java FPCValueOf function that returns the enum instance corresponding to an ordinal from an FPC POV
          tsk_jvm_enum_long2set,     // Java fpcLongToEnumSet function that returns an enumset corresponding to a bit pattern in a jlong
          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_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
        );
 
 {$ifdef oldregvars}
@@ -853,6 +869,8 @@ interface
        java_ansistring           : tobjectdef;
        { FPC java implementation of shortstrings }
        java_shortstring          : tobjectdef;
+       { FPC java procvar base class }
+       java_procvarbase          : tobjectdef;
 
     const
 {$ifdef i386}
@@ -3663,6 +3681,81 @@ implementation
       end;
 
 
+    function tabstractprocdef.getcopyas(newtyp:tdeftyp;copytyp:tproccopytyp): tstoreddef;
+      var
+        j, nestinglevel: longint;
+        pvs, npvs: tparavarsym;
+        csym, ncsym: tconstsym;
+      begin
+        nestinglevel:=parast.symtablelevel;
+        if newtyp=procdef then
+          begin
+            if (typ=procdef) or
+               (copytyp<>pc_procvar2bareproc) then
+              result:=tprocdef.create(nestinglevel)
+            else
+              result:=tprocdef.create(normal_function_level);
+            tprocdef(result).visibility:=vis_public;
+          end
+        else
+          begin
+            result:=tprocvardef.create(nestinglevel);
+          end;
+        tabstractprocdef(result).returndef:=returndef;
+        tabstractprocdef(result).returndefderef:=returndefderef;
+        tabstractprocdef(result).parast:=tparasymtable.create(tabstractprocdef(result),parast.symtablelevel);
+        pvs:=nil;
+        npvs:=nil;
+        for j:=0 to parast.symlist.count-1 do
+          begin
+            case tsym(parast.symlist[j]).typ of
+              paravarsym:
+                begin
+                  pvs:=tparavarsym(parast.symlist[j]);
+                  { in case of bare proc, don't copy self, vmt or framepointer
+                    parameters }
+                  if (copytyp=pc_procvar2bareproc) and
+                     (([vo_is_self,vo_is_vmt,vo_is_parentfp,vo_is_result]*pvs.varoptions)<>[]) then
+                    continue;
+                  npvs:=tparavarsym.create(pvs.realname,pvs.paranr,pvs.varspez,
+                    pvs.vardef,pvs.varoptions);
+                  npvs.defaultconstsym:=pvs.defaultconstsym;
+                  tabstractprocdef(result).parast.insert(npvs);
+                end;
+              constsym:
+                begin
+                  // ignore, reuse original constym. Should also be duplicated
+                  // be safe though
+                end
+              else
+                internalerror(201160604);
+              end;
+          end;
+        tabstractprocdef(result).savesize:=savesize;
+
+        tabstractprocdef(result).proctypeoption:=proctypeoption;
+        tabstractprocdef(result).proccalloption:=proccalloption;
+        tabstractprocdef(result).procoptions:=procoptions;
+        if (copytyp=pc_procvar2bareproc) then
+          tabstractprocdef(result).procoptions:=tabstractprocdef(result).procoptions*[po_explicitparaloc,po_hascallingconvention,po_varargs,po_iocheck];
+        tabstractprocdef(result).callerargareasize:=callerargareasize;
+        tabstractprocdef(result).calleeargareasize:=calleeargareasize;
+        tabstractprocdef(result).maxparacount:=maxparacount;
+        tabstractprocdef(result).minparacount:=minparacount;
+        if po_explicitparaloc in procoptions then
+          tabstractprocdef(result).funcretloc[callerside]:=funcretloc[callerside].getcopy;
+        { recalculate parameter info }
+        tabstractprocdef(result).has_paraloc_info:=callnoside;
+{$ifdef m68k}
+        tabstractprocdef(result).exp_funcretloc:=exp_funcretloc;
+{$endif}
+        if (typ=procdef) and
+           (newtyp=procvardef) and
+           (owner.symtabletype=ObjectSymtable) then
+          include(tprocvardef(result).procoptions,po_methodpointer);
+      end;
+
+
     procedure tabstractprocdef.check_mark_as_nested;
       begin
          { nested procvars require that nested functions use the Delphi-style
@@ -4143,42 +4236,10 @@ implementation
         j : longint;
         pvs : tparavarsym;
       begin
-        result:=tprocdef.create(parast.symtablelevel);
-        tprocdef(result).dispid:=dispid;
-        tprocdef(result).returndef:=returndef;
-        tprocdef(result).returndefderef:=returndefderef;
-        tprocdef(result).parast:=tparasymtable.create(tprocdef(result),parast.symtablelevel);
-        for j:=0 to parast.symlist.count-1 do
-          begin
-            case tsym(parast.symlist[j]).typ of
-              paravarsym:
-                begin
-                  pvs:=tparavarsym(parast.symlist[j]);
-                  tprocdef(result).parast.insert(tparavarsym.create(
-                    pvs.realname,pvs.paranr,pvs.varspez,pvs.vardef,pvs.varoptions));
-                end;
-              else
-                internalerror(201160604);
-              end;
-          end;
-        tprocdef(result).savesize:=savesize;
-
-        tprocdef(result).proctypeoption:=proctypeoption;
-        tprocdef(result).proccalloption:=proccalloption;
-        tprocdef(result).procoptions:=procoptions;
-        tprocdef(result).callerargareasize:=callerargareasize;
-        tprocdef(result).calleeargareasize:=calleeargareasize;
-        tprocdef(result).maxparacount:=maxparacount;
-        tprocdef(result).minparacount:=minparacount;
-        if po_explicitparaloc in procoptions then
-          tprocdef(result).funcretloc[callerside]:=funcretloc[callerside].getcopy;
-        { recalculate parameter info }
-        tprocdef(result).has_paraloc_info:=callnoside;
-{$ifdef m68k}
-        tprocdef(result).exp_funcretloc:=exp_funcretloc;
-{$endif}
+        result:=inherited getcopyas(procdef,pc_normal);
         { don't copy mangled name, can be different }
         tprocdef(result).messageinf:=messageinf;
+        tprocdef(result).dispid:=dispid;
         if po_msgstr in procoptions then
           tprocdef(result).messageinf.str:=stringdup(messageinf.str^);
         tprocdef(result).symoptions:=symoptions;
@@ -4741,6 +4802,9 @@ implementation
          inherited ppuload(procvardef,ppufile);
          { load para symtable }
          parast:=tparasymtable.create(self,ppufile.getbyte);
+{$ifdef jvm}
+        ppufile.getderef(classdefderef);
+{$endif}
          tparasymtable(parast).ppuload(ppufile);
       end;
 
@@ -4774,6 +4838,9 @@ implementation
         tprocvardef(result).has_paraloc_info:=has_paraloc_info;
 {$ifdef m68k}
         tprocvardef(result).exp_funcretloc:=exp_funcretloc;
+{$endif}
+{$ifdef jvm}
+        tprocvardef(result).classdef:=classdef;
 {$endif}
       end;
 
@@ -4786,6 +4853,9 @@ implementation
           procvars) }
         ppufile.putbyte(parast.symtablelevel);
 
+{$ifdef jvm}
+        ppufile.putderef(classdefderef);
+{$endif}
         { Write this entry }
         ppufile.writeentry(ibprocvardef);
 
@@ -4793,6 +4863,20 @@ implementation
         tparasymtable(parast).ppuwrite(ppufile);
       end;
 
+{$ifdef jvm}
+    procedure tprocvardef.buildderef;
+      begin
+        inherited buildderef;
+        classdefderef.build(classdef);
+      end;
+
+    procedure tprocvardef.deref;
+      begin
+        inherited deref;
+        classdef:=tobjectdef(classdefderef.resolve);
+      end;
+{$endif}
+
 
     function tprocvardef.GetSymtable(t:tGetSymtable):TSymtable;
       begin
@@ -5014,6 +5098,8 @@ implementation
                java_juenumset:=self
              else if (objname^='FPCBITSET') then
                java_jubitset:=self
+             else if (objname^='FPCBASEPROCVARTYPE') then
+               java_procvarbase:=self;
            end;
          writing_class_record_dbginfo:=false;
        end;

rtl/java/compproc.inc

@@ -628,6 +628,7 @@ procedure fpc_initialize_array_ansistring(arr: TJObjectArray; normalarrdim: long
   level elements types of the array) }
 procedure fpc_initialize_array_dynarr(arr: TJObjectArray; normalarrdim: longint);compilerproc;
 procedure fpc_initialize_array_record(arr: TJObjectArray; normalarrdim: longint; inst: FpcBaseRecordType);compilerproc;
+procedure fpc_initialize_array_procvar(arr: TJObjectArray; normalarrdim: longint; inst: FpcBaseProcVarType);compilerproc;
 procedure fpc_initialize_array_bitset(arr: TJObjectArray; normalarrdim: longint; inst: FpcBitSet);compilerproc;
 procedure fpc_initialize_array_enumset(arr: TJObjectArray; normalarrdim: longint; inst: JUEnumSet);compilerproc;
 procedure fpc_initialize_array_shortstring(arr: TJObjectArray; normalarrdim: longint; maxlen: byte);compilerproc;

rtl/java/java_sys.inc

@@ -116,6 +116,16 @@
     function getTypeParameters(): Arr1JLRTypeVariable; overload;
   end;
 
+  JLRMember = interface external 'java.lang.reflect' name 'Member' 
+    const
+      &PUBLIC = 0;
+      DECLARED = 1;
+    function getDeclaringClass(): JLClass; overload;
+    function getName(): JLString; overload;
+    function getModifiers(): jint; overload;
+    function isSynthetic(): jboolean; overload;
+  end;
+
   JLRType = interface external 'java.lang.reflect' name 'Type' 
   end;
 
@@ -1011,6 +1021,21 @@
     function hashCode(): jint; overload;
   end;
 
+  JLRAccessibleObject = class external 'java.lang.reflect' name 'AccessibleObject' (JLObject, JLRAnnotatedElement)
+  public
+    class procedure setAccessible(para1: Arr1JLRAccessibleObject; para2: jboolean); static; overload;  // throws java.lang.SecurityException
+    class procedure setAccessible(var para1: array of JLRAccessibleObject; para2: jboolean); static; overload;  // throws java.lang.SecurityException
+    procedure setAccessible(para1: jboolean); overload; virtual;  // throws java.lang.SecurityException
+    function isAccessible(): jboolean; overload; virtual;
+  strict protected
+    constructor create(); overload;
+  public
+    function getAnnotation(para1: JLClass): JLAAnnotation; overload; virtual;
+    function isAnnotationPresent(para1: JLClass): jboolean; overload; virtual;
+    function getAnnotations(): Arr1JLAAnnotation; overload; virtual;
+    function getDeclaredAnnotations(): Arr1JLAAnnotation; overload; virtual;
+  end;
+
   JLClass = class sealed external 'java.lang' name 'Class' (JLObject, JISerializable, JLRGenericDeclaration, JLRType, JLRAnnotatedElement)
   public
     type
@@ -1739,6 +1764,33 @@
     function hashCode(): jint; overload;
   end;
 
+  JLRMethod = class sealed external 'java.lang.reflect' name 'Method' (JLRAccessibleObject, JLRGenericDeclaration, JLRMember)
+  public
+    function getDeclaringClass(): JLClass; overload; virtual;
+    function getName(): JLString; overload; virtual;
+    function getModifiers(): jint; overload; virtual;
+    function getTypeParameters(): Arr1JLRTypeVariable; overload; virtual;
+    function getReturnType(): JLClass; overload; virtual;
+    function getGenericReturnType(): JLRType; overload; virtual;
+    function getParameterTypes(): Arr1JLClass; overload; virtual;
+    function getGenericParameterTypes(): Arr1JLRType; overload; virtual;
+    function getExceptionTypes(): Arr1JLClass; overload; virtual;
+    function getGenericExceptionTypes(): Arr1JLRType; overload; virtual;
+    function equals(para1: JLObject): jboolean; overload; virtual;
+    function hashCode(): jint; overload; virtual;
+    function toString(): JLString; overload; virtual;
+    function toGenericString(): JLString; overload; virtual;
+    function invoke(para1: JLObject; para2: Arr1JLObject): JLObject; overload; virtual;  // throws java.lang.IllegalAccessException, java.lang.IllegalArgumentException, java.lang.reflect.InvocationTargetException
+    function invoke(para1: JLObject; const para2: array of JLObject): JLObject; overload; virtual;  // throws java.lang.IllegalAccessException, java.lang.IllegalArgumentException, java.lang.reflect.InvocationTargetException
+    function isBridge(): jboolean; overload; virtual;
+    function isVarArgs(): jboolean; overload; virtual;
+    function isSynthetic(): jboolean; overload; virtual;
+    function getAnnotation(para1: JLClass): JLAAnnotation; overload; virtual;
+    function getDeclaredAnnotations(): Arr1JLAAnnotation; overload; virtual;
+    function getDefaultValue(): JLObject; overload; virtual;
+    function getParameterAnnotations(): Arr2JLAAnnotation; overload; virtual;
+  end;
+
   JUHashMap = class external 'java.util' name 'HashMap' (JUAbstractMap, JUMap, JLCloneable, JISerializable)
   public
     type

rtl/java/java_sysh.inc

@@ -1,4 +1,4 @@
-{ Imports for Java packages/classes: java.io.Serializable, java.lang.AbstractStringBuilder, java.lang.Appendable, java.lang.Boolean, java.lang.Byte, java.lang.CharSequence, java.lang.Character, java.lang.Class, java.lang.Cloneable, java.lang.Comparable, java.lang.Double, java.lang.Enum, java.lang.Error, java.lang.Exception, java.lang.Float, java.lang.IllegalArgumentException, java.lang.IndexOutOfBoundsException, java.lang.Integer, java.lang.Iterable, java.lang.LinkageError, java.lang.Long, java.lang.Number, java.lang.Object, java.lang.RuntimeException, java.lang.Short, java.lang.String, java.lang.StringBuffer, java.lang.StringBuilder, java.lang.System, java.lang.Throwable, java.lang.reflect.AnnotatedElement, java.lang.reflect.Array, java.lang.reflect.GenericDeclaration, java.lang.reflect.Type, java.text.Collator, java.util.AbstractCollection, java.util.AbstractMap, java.util.AbstractSet, java.util.Arrays, java.util.BitSet, java.util.Collection, java.util.Comparator, java.util.EnumSet, java.util.HashMap, java.util.Iterator, java.util.Map, java.util.Set }
+{ Imports for Java packages/classes: java.io.Serializable, java.lang.AbstractStringBuilder, java.lang.Appendable, java.lang.Boolean, java.lang.Byte, java.lang.CharSequence, java.lang.Character, java.lang.Class, java.lang.Cloneable, java.lang.Comparable, java.lang.Double, java.lang.Enum, java.lang.Error, java.lang.Exception, java.lang.Float, java.lang.IllegalArgumentException, java.lang.IndexOutOfBoundsException, java.lang.Integer, java.lang.Iterable, java.lang.LinkageError, java.lang.Long, java.lang.Number, java.lang.Object, java.lang.RuntimeException, java.lang.Short, java.lang.String, java.lang.StringBuffer, java.lang.StringBuilder, java.lang.System, java.lang.Throwable, java.lang.reflect.AccessibleObject, java.lang.reflect.AnnotatedElement, java.lang.reflect.Array, java.lang.reflect.GenericDeclaration, java.lang.reflect.Member, java.lang.reflect.Method, java.lang.reflect.Type, java.text.Collator, java.util.AbstractCollection, java.util.AbstractMap, java.util.AbstractSet, java.util.Arrays, java.util.BitSet, java.util.Collection, java.util.Comparator, java.util.EnumSet, java.util.HashMap, java.util.Iterator, java.util.Map, java.util.Set }
 type
   JLStringBuffer = class;
   Arr1JLStringBuffer = array of JLStringBuffer;
@@ -35,6 +35,11 @@ type
   Arr2JLNumber = array of Arr1JLNumber;
   Arr3JLNumber = array of Arr2JLNumber;
 
+  JLRMethod = class;
+  Arr1JLRMethod = array of JLRMethod;
+  Arr2JLRMethod = array of Arr1JLRMethod;
+  Arr3JLRMethod = array of Arr2JLRMethod;
+
   JLCharacter = class;
   Arr1JLCharacter = array of JLCharacter;
   Arr2JLCharacter = array of Arr1JLCharacter;
@@ -165,6 +170,11 @@ type
   Arr2JLRuntimeException = array of Arr1JLRuntimeException;
   Arr3JLRuntimeException = array of Arr2JLRuntimeException;
 
+  JLRAccessibleObject = class;
+  Arr1JLRAccessibleObject = array of JLRAccessibleObject;
+  Arr2JLRAccessibleObject = array of Arr1JLRAccessibleObject;
+  Arr3JLRAccessibleObject = array of Arr2JLRAccessibleObject;
+
   JLIterable = interface;
   Arr1JLIterable = array of JLIterable;
   Arr2JLIterable = array of Arr1JLIterable;
@@ -210,6 +220,11 @@ type
   Arr2JLComparable = array of Arr1JLComparable;
   Arr3JLComparable = array of Arr2JLComparable;
 
+  JLRMember = interface;
+  Arr1JLRMember = array of JLRMember;
+  Arr2JLRMember = array of Arr1JLRMember;
+  Arr3JLRMember = array of Arr2JLRMember;
+
   JLCharSequence = interface;
   Arr1JLCharSequence = array of JLCharSequence;
   Arr2JLCharSequence = array of Arr1JLCharSequence;
@@ -265,20 +280,15 @@ type
   Arr2JSProtectionDomain = array of Arr1JSProtectionDomain;
   Arr3JSProtectionDomain = array of Arr2JSProtectionDomain;
 
-  JLRField = class external 'java.lang.reflect' name 'Field';
-  Arr1JLRField = array of JLRField;
-  Arr2JLRField = array of Arr1JLRField;
-  Arr3JLRField = array of Arr2JLRField;
-
   JIPrintStream = class external 'java.io' name 'PrintStream';
   Arr1JIPrintStream = array of JIPrintStream;
   Arr2JIPrintStream = array of Arr1JIPrintStream;
   Arr3JIPrintStream = array of Arr2JIPrintStream;
 
-  JLRMethod = class external 'java.lang.reflect' name 'Method';
-  Arr1JLRMethod = array of JLRMethod;
-  Arr2JLRMethod = array of Arr1JLRMethod;
-  Arr3JLRMethod = array of Arr2JLRMethod;
+  JLRField = class external 'java.lang.reflect' name 'Field';
+  Arr1JLRField = array of JLRField;
+  Arr2JLRField = array of Arr1JLRField;
+  Arr3JLRField = array of Arr2JLRField;
 
   JTCollationKey = class external 'java.text' name 'CollationKey';
   Arr1JTCollationKey = array of JTCollationKey;

rtl/java/jdynarrh.inc

@@ -27,6 +27,7 @@ type
   TJRecordArray = array of FpcBaseRecordType;
   TJEnumSetArray = array of JUEnumSet;
   TJBitSetArray = array of JUBitSet;
+  TJProcVarArray = array of FpcBaseProcVarType;
   TShortstringArray = array of ShortstringClass;
   TJStringArray = array of unicodestring;
 
@@ -42,6 +43,7 @@ const
   FPCJDynArrTypeRecord  = 'R';
   FPCJDynArrTypeEnumSet = 'E';
   FPCJDynArrTypeBitSet  = 'L';
+  FPCJDynArrTypeProcVar = 'P';
   FPCJDynArrTypeShortstring  = 'T';
 
 { 1-dimensional setlength routines
@@ -60,6 +62,7 @@ procedure fpc_copy_shallow_array(src, dst: JLObject; srcstart: jint = -1; srccop
 procedure fpc_copy_jrecord_array(src, dst: TJRecordArray; srcstart: jint = -1; srccopylen: jint = -1);
 procedure fpc_copy_jenumset_array(src, dst: TJEnumSetArray; srcstart: jint = -1; srccopylen: jint = -1);
 procedure fpc_copy_jbitset_array(src, dst: TJBitSetArray; srcstart: jint = -1; srccopylen: jint = -1);
+procedure fpc_copy_jprocvar_array(src, dst: TJProcVarArray; srcstart: jint = -1; srccopylen: jint = -1);
 procedure fpc_copy_jshortstring_array(src, dst: TShortstringArray; srcstart: jint = -1; srccopylen: jint = -1);
 
 { multi-dimendional setlength routine: all intermediate dimensions are arrays

rtl/java/jpvar.inc

@@ -0,0 +1,218 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2011 by Jonas Maebe,
+    members of the Free Pascal development team.
+
+    This file implements support infrastructure for procvars under the JVM
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+
+  constructor FpcBaseProcVarType.create(inst: jlobject; const methodName: unicodestring; const argTypes: array of JLClass);
+    begin
+      method.data:=inst;
+      setFpcBaseProcVarTypeBySignature(methodName,argtypes);
+    end;
+
+
+  constructor FpcBaseProcVarType.create(const meth: tmethod);
+    begin
+      method:=meth;
+    end;
+
+
+  procedure FpcBaseProcVarType.setFpcBaseProcVarTypeBySignature(const methodName: unicodestring; const argTypes: array of JLClass);
+    var
+      owningClass: JLClass;
+    begin
+      { class method or instance method }
+      if method.data is JLClass then
+        owningClass:=JLClass(method.data)
+      else
+        owningClass:=method.data.getClass;
+      method.code:=owningClass.getDeclaredMethod(methodName,argTypes);
+      { required to enable calling private methods in one class from another
+        class -- can cause security exceptions if the security manager doesn't
+        allow this though... }
+      if not method.code.isAccessible then
+        method.code.setAccessible(true);
+    end;
+
+
+  procedure FpcBaseProcVarType.fpcDeepCopy(result: FpcBaseProcVarType);
+    begin
+      result.method:=method;
+    end;
+
+
+  function FpcBaseProcVarType.clone: JLObject;
+    begin
+      result:=inherited;
+      FpcBaseProcVarType(result).method:=method;
+    end;
+
+
+  procedure FpcBaseProcVarType.invokeProc(const args: array of jlobject);
+    begin
+      method.code.invoke(method.data,args);
+    end;
+
+
+  function FpcBaseProcVarType.invokeBooleanFunc(const args: array of jlobject): jboolean;
+    begin
+      result:=JLBoolean(method.code.invoke(method.data,args)).booleanValue;
+    end;
+
+
+  function FpcBaseProcVarType.invokeCharFunc(const args: array of jlobject): jchar;
+    begin
+      result:=JLCharacter(method.code.invoke(method.data,args)).charValue;
+    end;
+
+
+  function FpcBaseProcVarType.invokeByteFunc(const args: array of jlobject): jbyte;
+    begin
+      result:=JLByte(method.code.invoke(method.data,args)).byteValue;
+    end;
+
+
+  function FpcBaseProcVarType.invokeShortFunc(const args: array of jlobject): jshort;
+    begin
+      result:=JLShort(method.code.invoke(method.data,args)).shortValue;
+    end;
+
+
+  function FpcBaseProcVarType.invokeIntFunc(const args: array of jlobject): jint;
+    begin
+      result:=JLInteger(method.code.invoke(method.data,args)).intValue;
+    end;
+
+
+  function FpcBaseProcVarType.invokeLongFunc(const args: array of jlobject): jlong;
+    begin
+      result:=JLLong(method.code.invoke(method.data,args)).longValue;
+    end;
+
+
+  function FpcBaseProcVarType.invokeSingleFunc(const args: array of jlobject): jfloat;
+    begin
+      result:=JLFloat(method.code.invoke(method.data,args)).floatValue;
+    end;
+
+
+  function FpcBaseProcVarType.invokeDoubleFunc(const args: array of jlobject): jdouble;
+    begin
+      result:=JLDouble(method.code.invoke(method.data,args)).doubleValue;
+    end;
+
+
+  function FpcBaseProcVarType.invokeObjectFunc(const args: array of jlobject): jlobject;
+    begin
+      result:=method.code.invoke(method.data,args);
+    end;
+
+
+
+
+  function FpcBaseNestedProcVarType.getNestedArgs(const args: array of jlobject): TJLObjectDynArray;
+    var
+      arglen: longint;
+    begin
+      { add the parentfp struct pointer as last argument (delphi nested cc
+        "calling convention") }
+      arglen:=length(args);
+      setlength(result,arglen+1);
+      JLSystem.ArrayCopy(JLObject(@args),0,JLObject(result),0,arglen);
+      result[arglen]:=nestedfpstruct;
+    end;
+
+
+  constructor FpcBaseNestedProcVarType.create(inst, context: jlobject; const methodName: unicodestring; const argTypes: array of JLClass);
+    begin
+      inherited create(inst,methodName,argTypes);
+      nestedfpstruct:=context;
+    end;
+
+
+  procedure FpcBaseNestedProcVarType.fpcDeepCopy(result: FpcBaseProcVarType);
+    begin
+      inherited fpcDeepCopy(result);
+      FpcBaseNestedProcVarType(result).nestedfpstruct:=nestedfpstruct;
+    end;
+
+
+  function FpcBaseNestedProcVarType.clone: JLObject;
+    begin
+      result:=inherited;
+      FpcBaseNestedProcVarType(result).nestedfpstruct:=nestedfpstruct;
+    end;
+
+
+  procedure FpcBaseNestedProcVarType.invokeProc(const args: array of jlobject);
+    begin
+      inherited invokeProc(getNestedArgs(args));
+    end;
+
+
+  function FpcBaseNestedProcVarType.invokeBooleanFunc(const args: array of jlobject): jboolean;
+    begin
+      result:=inherited invokeBooleanFunc(getNestedArgs(args));
+    end;
+
+
+  function FpcBaseNestedProcVarType.invokeCharFunc(const args: array of jlobject): jchar;
+    begin
+      result:=inherited invokeCharFunc(getNestedArgs(args));
+    end;
+
+
+  function FpcBaseNestedProcVarType.invokeByteFunc(const args: array of jlobject): jbyte;
+    begin
+      result:=inherited invokeByteFunc(getNestedArgs(args));
+    end;
+
+
+  function FpcBaseNestedProcVarType.invokeShortFunc(const args: array of jlobject): jshort;
+    begin
+      result:=inherited invokeShortFunc(getNestedArgs(args));
+    end;
+
+
+  function FpcBaseNestedProcVarType.invokeIntFunc(const args: array of jlobject): jint;
+    begin
+      result:=inherited invokeIntFunc(getNestedArgs(args));
+    end;
+
+
+  function FpcBaseNestedProcVarType.invokeLongFunc(const args: array of jlobject): jlong;
+    begin
+      result:=inherited invokeLongFunc(getNestedArgs(args));
+    end;
+
+
+  function FpcBaseNestedProcVarType.invokeSingleFunc(const args: array of jlobject): jfloat;
+    begin
+      result:=inherited invokeSingleFunc(getNestedArgs(args));
+    end;
+
+
+  function FpcBaseNestedProcVarType.invokeDoubleFunc(const args: array of jlobject): jdouble;
+    begin
+      result:=inherited invokeDoubleFunc(getNestedArgs(args));
+    end;
+
+
+  function FpcBaseNestedProcVarType.invokeObjectFunc(const args: array of jlobject): jlobject;
+    begin
+      result:=inherited invokeObjectFunc(getNestedArgs(args));
+    end;
+
+
+

rtl/java/jpvarh.inc

@@ -0,0 +1,75 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2011 by Jonas Maebe,
+    members of the Free Pascal development team.
+
+    This file declares support infrastructure for procvars under the JVM
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+type
+  { tmethod record }
+  TMethod = record
+    code: JLRMethod;
+    data: jlobject;
+  end;
+
+
+  { base type for procedure variables }
+  FpcBaseProcVarType = class(jlobject,jlcloneable)
+    method: TMethod;
+
+    constructor create(inst: jlobject; const methodName: unicodestring; const argTypes: array of JLClass);
+    constructor create(const meth: tmethod);
+
+    procedure setFpcBaseProcVarTypeBySignature(const methodName: unicodestring; const argTypes: array of JLClass); virtual;
+    procedure fpcDeepCopy(result: FpcBaseProcVarType); virtual;
+    function clone: JLObject; override;
+
+   strict protected
+    procedure invokeProc(const args: array of jlobject); virtual;
+    function invokeBooleanFunc(const args: array of jlobject): jboolean; virtual;
+    function invokeCharFunc(const args: array of jlobject): jchar; virtual;
+    function invokeByteFunc(const args: array of jlobject): jbyte; virtual;
+    function invokeShortFunc(const args: array of jlobject): jshort; virtual;
+    function invokeIntFunc(const args: array of jlobject): jint; virtual;
+    function invokeLongFunc(const args: array of jlobject): jlong; virtual;
+    function invokeSingleFunc(const args: array of jlobject): jfloat; virtual;
+    function invokeDoubleFunc(const args: array of jlobject): jdouble; virtual;
+    function invokeObjectFunc(const args: array of jlobject): jlobject; virtual;
+  end;
+
+  FpcBaseNestedProcVarType = class(FpcBaseProcVarType)
+   strict protected
+    type
+      { TJObjectArray isn't declared here yet }
+      TJLObjectDynArray = array of JLObject;
+    { add the nestedfpstruct to the list of parameters }
+    function getNestedArgs(const args: array of jlobject): TJLObjectDynArray; virtual;
+   public
+    nestedfpstruct: jlobject;
+
+    constructor create(inst, context: jlobject; const methodName: unicodestring; const argTypes: array of JLClass);
+    procedure fpcDeepCopy(result: FpcBaseProcVarType); override;
+    function clone: JLObject; override;
+
+   strict protected
+    procedure invokeProc(const args: array of jlobject); override;
+    function invokeBooleanFunc(const args: array of jlobject): jboolean; override;
+    function invokeCharFunc(const args: array of jlobject): jchar; override;
+    function invokeByteFunc(const args: array of jlobject): jbyte; override;
+    function invokeShortFunc(const args: array of jlobject): jshort; override;
+    function invokeIntFunc(const args: array of jlobject): jint; override;
+    function invokeLongFunc(const args: array of jlobject): jlong; override;
+    function invokeSingleFunc(const args: array of jlobject): jfloat; override;
+    function invokeDoubleFunc(const args: array of jlobject): jdouble; override;
+    function invokeObjectFunc(const args: array of jlobject): jlobject; override;
+  end;
+

rtl/java/rtti.inc

@@ -87,6 +87,25 @@ procedure fpc_initialize_array_record(arr: TJObjectArray; normalarrdim: longint;
   end;
 
 
+procedure fpc_initialize_array_procvar_intern(arr: TJObjectArray; normalarrdim: longint; inst: FpcBaseProcVarType); external name 'fpc_initialize_array_procvar';
+
+procedure fpc_initialize_array_procvar(arr: TJObjectArray; normalarrdim: longint; inst: FpcBaseProcVarType);compilerproc;
+  var
+    i: longint;
+  begin
+    if normalarrdim > 0 then
+      begin
+        for i:=low(arr) to high(arr) do
+          fpc_initialize_array_procvar_intern(TJObjectArray(arr[i]),normalarrdim-1,inst);
+      end
+    else
+      begin
+        for i:=low(arr) to high(arr) do
+          arr[i]:=inst.clone;
+      end;
+  end;
+
+
 { exactly the same as fpc_initialize_array_record, but can't use generic
   routine because of Java clonable design :( (except by rtti/invoke, but that's
   not particularly fast either) }

rtl/java/system.pp

@@ -131,15 +131,12 @@ type
 {$i jrech.inc}
 {$i jseth.inc}
 {$i sstringh.inc}
+{$i jpvarh.inc}
 {$i jdynarrh.inc}
 {$i astringh.inc}
 
-{$ifndef nounsupported}
-type
-  tmethod = record
-    code: jlobject;
-  end;
 
+{$ifndef nounsupported}
 const
    vtInteger       = 0;
    vtBoolean       = 1;
@@ -290,6 +287,7 @@ function min(a,b : longint) : longint;
 {$i jrec.inc}
 {$i jset.inc}
 {$i jint64.inc}
+{$i jpvar.inc}
 
 { copying helpers }
 
@@ -384,6 +382,27 @@ procedure fpc_copy_jbitset_array(src, dst: TJBitSetArray; srcstart: jint = -1; s
   end;
 
 
+procedure fpc_copy_jprocvar_array(src, dst: TJProcVarArray; srcstart: jint = -1; srccopylen: jint = -1);
+  var
+    i: longint;
+    srclen, dstlen: jint;
+  begin
+    srclen:=length(src);
+    dstlen:=length(dst);
+    if srcstart=-1 then
+      srcstart:=0
+    else if srcstart>=srclen then
+      exit;
+    if srccopylen=-1 then
+      srccopylen:=srclen
+    else if srcstart+srccopylen>srclen then
+      srccopylen:=srclen-srcstart;
+    { no arraycopy, have to clone each element }
+    for i:=0 to min(srccopylen,dstlen)-1 do
+      dst[i]:=FpcBaseProcVarType(src[srcstart+i].clone);
+  end;
+
+
 procedure fpc_copy_jshortstring_array(src, dst: TShortstringArray; srcstart: jint = -1; srccopylen: jint = -1);
   var
     i: longint;
@@ -475,6 +494,18 @@ function fpc_setlength_dynarr_jbitset(aorg, anew: TJBitSetArray; deepcopy: boole
   end;
 
 
+function fpc_setlength_dynarr_jprocvar(aorg, anew: TJProcVarArray; deepcopy: boolean): TJProcVarArray;
+  begin
+    if deepcopy or
+       (length(aorg)<>length(anew)) then
+      begin
+        fpc_copy_jprocvar_array(aorg,anew);
+        result:=anew
+      end
+    else
+      result:=aorg;
+  end;
+
 
 function fpc_setlength_dynarr_jshortstring(aorg, anew: TShortstringArray; deepcopy: boolean): TShortstringArray;
   begin
@@ -536,6 +567,13 @@ function fpc_setlength_dynarr_multidim(aorg, anew: TJObjectArray; deepcopy: bool
               for i:=succ(partdone) to high(result) do
                 result[i]:=JLObject(fpc_setlength_dynarr_jbitset(nil,TJBitSetArray(anew[i]),deepcopy));
             end;
+          FPCJDynArrTypeProcVar:
+            begin
+              for i:=low(result) to partdone do
+                result[i]:=JLObject(fpc_setlength_dynarr_jprocvar(TJProcVarArray(aorg[i]),TJProcVarArray(anew[i]),deepcopy));
+              for i:=succ(partdone) to high(result) do
+                result[i]:=JLObject(fpc_setlength_dynarr_jprocvar(nil,TJProcVarArray(anew[i]),deepcopy));
+            end;
           FPCJDynArrTypeShortstring:
             begin
               for i:=low(result) to partdone do
@@ -592,6 +630,8 @@ function fpc_dynarray_copy(src: JLObject; start, len: longint; ndim: longint; el
             fpc_copy_jenumset_array(TJEnumSetArray(src),TJEnumSetArray(result),start,len);
           FPCJDynArrTypeBitSet:
             fpc_copy_jbitset_array(TJBitSetArray(src),TJBitSetArray(result),start,len);
+          FPCJDynArrTypeProcvar:
+            fpc_copy_jprocvar_array(TJProcVarArray(src),TJProcVarArray(result),start,len);
           FPCJDynArrTypeShortstring:
             fpc_copy_jshortstring_array(TShortstringArray(src),TShortstringArray(result),start,len);
           else