+ support for (only named, for now) records in the JVM target:

    implemented via classes, all descending from system.FpcBaseRecordType
    (records are also considered to be "related" to system.FpcBaseRecordType
     on the JVM target)
  * several routines are auto-generated for all record-classes: apart
    from a default constructor (if there is none), also clone (which
    returns a new instance containing a deep copy of the current
    instance) and deepCopy (which copies all fields of one instance
    into another one)
   o added new field "synthetickind" to tprocdef that indicates what
     kind of synthetically generated method it is (if any), and
     mark such methods also as "synthetic" in the JVM assembler code
   o split off the JVM-specific parser code (e.g., to add default
     constructors) into pjvm.pas

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

.gitattributes

@@ -402,6 +402,7 @@ compiler/pdecvar.pas svneol=native#text/plain
 compiler/pexports.pas svneol=native#text/plain
 compiler/pexpr.pas svneol=native#text/plain
 compiler/pinline.pas svneol=native#text/plain
+compiler/pjvm.pas svneol=native#text/plain
 compiler/pmodules.pas svneol=native#text/plain
 compiler/powerpc/agppcmpw.pas svneol=native#text/plain
 compiler/powerpc/agppcvasm.pas svneol=native#text/plain
@@ -7352,6 +7353,8 @@ rtl/java/java_sys.inc svneol=native#text/plain
 rtl/java/java_sysh.inc svneol=native#text/plain
 rtl/java/jdynarrh.inc svneol=native#text/plain
 rtl/java/jmathh.inc svneol=native#text/plain
+rtl/java/jrec.inc svneol=native#text/plain
+rtl/java/jrech.inc svneol=native#text/plain
 rtl/java/objpas.pp svneol=native#text/plain
 rtl/java/rtl.cfg svneol=native#text/plain
 rtl/java/rtti.inc svneol=native#text/plain

compiler/agjasmin.pas

@@ -47,9 +47,9 @@ interface
         jasminjar: tcmdstr;
         asmfiles: TCmdStrList;
 
-        procedure WriteExtraHeader(obj: tobjectdef);
+        procedure WriteExtraHeader(obj: tabstractrecorddef);
         procedure WriteInstruction(hp: tai);
-        procedure NewAsmFileForObjectDef(obj: tobjectdef);
+        procedure NewAsmFileForStructDef(obj: tabstractrecorddef);
 
         function VisibilityToStr(vis: tvisibility): string;
         function MethodDefinition(pd: tprocdef): string;
@@ -57,14 +57,14 @@ interface
         function ConstAssignmentValue(csym: tconstsym): ansistring;
         function ConstDefinition(sym: tconstsym): string;
         function FieldDefinition(sym: tabstractvarsym): string;
-        function InnerObjDef(obj: tobjectdef): string;
+        function InnerStructDef(obj: tabstractrecorddef): string;
 
         procedure WriteProcDef(pd: tprocdef);
         procedure WriteFieldSym(sym: tabstractvarsym);
         procedure WriteConstSym(sym: tconstsym);
         procedure WriteSymtableVarSyms(st: TSymtable);
         procedure WriteSymtableProcdefs(st: TSymtable);
-        procedure WriteSymtableObjectDefs(st: TSymtable);
+        procedure WriteSymtableStructDefs(st: TSymtable);
        public
         constructor Create(smart: boolean); override;
         function MakeCmdLine: TCmdStr;override;
@@ -516,7 +516,7 @@ implementation
       end;
 
 
-    procedure TJasminAssembler.WriteExtraHeader(obj: tobjectdef);
+    procedure TJasminAssembler.WriteExtraHeader(obj: tabstractrecorddef);
       var
         superclass,
         intf: tobjectdef;
@@ -551,27 +551,40 @@ implementation
             toplevelowner:=obj.owner;
             while not(toplevelowner.symtabletype in [staticsymtable,globalsymtable]) do
               toplevelowner:=toplevelowner.defowner.owner;
-            case obj.objecttype of
-              odt_javaclass:
+            case obj.typ of
+              recorddef:
                 begin
                   AsmWrite('.class ');
                   if toplevelowner.symtabletype=globalsymtable then
                     AsmWrite('public ');
                   AsmWriteln(obj.jvm_full_typename(true));
-                  superclass:=obj.childof;
+                  superclass:=java_fpcbaserecordtype;
                 end;
-              odt_interfacejava:
+              objectdef:
                 begin
-                  AsmWrite('.interface abstract ');
-                  if toplevelowner.symtabletype=globalsymtable then
-                    AsmWrite('public ');
-                  AsmWriteLn(obj.jvm_full_typename(true));
-                  { interfaces must always specify Java.lang.object as
-                    superclass }
-                  superclass:=java_jlobject;
-                end
-              else
-                internalerror(2011010906);
+                  case tobjectdef(obj).objecttype of
+                    odt_javaclass:
+                      begin
+                        AsmWrite('.class ');
+                        if toplevelowner.symtabletype=globalsymtable then
+                          AsmWrite('public ');
+                        AsmWriteln(obj.jvm_full_typename(true));
+                        superclass:=tobjectdef(obj).childof;
+                      end;
+                    odt_interfacejava:
+                      begin
+                        AsmWrite('.interface abstract ');
+                        if toplevelowner.symtabletype=globalsymtable then
+                          AsmWrite('public ');
+                        AsmWriteLn(obj.jvm_full_typename(true));
+                        { interfaces must always specify Java.lang.object as
+                          superclass }
+                        superclass:=java_jlobject;
+                      end
+                    else
+                      internalerror(2011010906);
+                  end;
+                end;
             end;
             { superclass }
             if assigned(superclass) then
@@ -582,11 +595,12 @@ implementation
                 AsmWriteln(superclass.objextname^);
               end;
             { implemented interfaces }
-            if assigned(obj.ImplementedInterfaces) then
+            if (obj.typ=objectdef) and
+               assigned(tobjectdef(obj).ImplementedInterfaces) then
               begin
-                for i:=0 to obj.ImplementedInterfaces.count-1 do
+                for i:=0 to tobjectdef(obj).ImplementedInterfaces.count-1 do
                   begin
-                    intf:=TImplementedInterface(obj.ImplementedInterfaces[i]).IntfDef;
+                    intf:=TImplementedInterface(tobjectdef(obj).ImplementedInterfaces[i]).IntfDef;
                     AsmWrite('.implements ');
                     if assigned(intf.import_lib) then
                       AsmWrite(intf.import_lib^+'/');
@@ -594,12 +608,13 @@ implementation
                   end;
               end;
             { in case of nested class: relation to parent class }
-            if obj.owner.symtabletype=objectsymtable then
-              AsmWriteln(InnerObjDef(obj));
+            if obj.owner.symtabletype in [objectsymtable,recordsymtable] then
+              AsmWriteln(InnerStructDef(obj));
             { all all nested classes }
             for i:=0 to obj.symtable.deflist.count-1 do
-              if is_java_class_or_interface(tdef(obj.symtable.deflist[i])) then
-                AsmWriteln(InnerObjDef(tobjectdef(obj.symtable.deflist[i])));
+              if is_java_class_or_interface(tdef(obj.symtable.deflist[i])) or
+                 (tdef(obj.symtable.deflist[i]).typ=recorddef) then
+                AsmWriteln(InnerStructDef(tabstractrecorddef(obj.symtable.deflist[i])));
           end;
         AsmLn;
       end;
@@ -646,7 +661,7 @@ implementation
      end;
 
 
-   procedure TJasminAssembler.NewAsmFileForObjectDef(obj: tobjectdef);
+   procedure TJasminAssembler.NewAsmFileForStructDef(obj: tabstractrecorddef);
       begin
         if AsmSize<>AsmStartSize then
           begin
@@ -696,6 +711,8 @@ implementation
            (not(po_virtualmethod in pd.procoptions) and
             not(pd.proctypeoption in [potype_constructor,potype_class_constructor])) then
           result:=result+'final ';
+        if (pd.synthetickind<>tsk_none) then
+          result:=result+'synthetic ';
         result:=result+pd.jvmmangledbasename;
       end;
 
@@ -777,7 +794,7 @@ implementation
            (vissym.owner.symtabletype=objectsymtable) then
           begin
             vissym:=tabstractvarsym(search_struct_member(
-              tobjectdef(vissym.owner.defowner),
+              tabstractrecorddef(vissym.owner.defowner),
               internal_static_field_name(vissym.name)));
             if not assigned(vissym) or
                (vissym.typ<>fieldvarsym) then
@@ -804,19 +821,33 @@ implementation
       end;
 
 
-    function TJasminAssembler.InnerObjDef(obj: tobjectdef): string;
+    function TJasminAssembler.InnerStructDef(obj: tabstractrecorddef): string;
       var
+        extname: pshortstring;
         kindname: string;
       begin
-        if obj.owner.defowner.typ<>objectdef then
+        if not(obj.owner.defowner.typ in [objectdef,recorddef]) then
           internalerror(2011021701);
-        case obj.objecttype of
-          odt_javaclass:
-            kindname:='class ';
-          odt_interfacejava:
-            kindname:='interface ';
+        case obj.typ of
+          recorddef:
+            begin
+              kindname:='class ';
+              extname:=obj.symtable.realname;
+            end;
+          objectdef:
+            begin
+              extname:=tobjectdef(obj).objextname;
+              case tobjectdef(obj).objecttype of
+                odt_javaclass:
+                  kindname:='class ';
+                odt_interfacejava:
+                  kindname:='interface ';
+                else
+                  internalerror(2011021702);
+              end;
+            end;
           else
-            internalerror(2011021702);
+            internalerror(2011032809);
         end;
         result:=
           '.inner '+
@@ -826,11 +857,11 @@ implementation
             inner classes in Java -- will be changed when support for
             Java-style non-static classes is added }
          ' static '+
-         obj.objextname^+
+         extname^+
          ' inner '+
          obj.jvm_full_typename(true)+
          ' outer '+
-         tobjectdef(obj.owner.defowner).jvm_full_typename(true);
+         tabstractrecorddef(obj.owner.defowner).jvm_full_typename(true);
       end;
 
 
@@ -918,36 +949,38 @@ implementation
           end;
       end;
 
-    procedure TJasminAssembler.WriteSymtableObjectDefs(st: TSymtable);
+    procedure TJasminAssembler.WriteSymtableStructDefs(st: TSymtable);
       var
         i   : longint;
         def : tdef;
-        obj : tobjectdef;
-        nestedclasses: tfpobjectlist;
+        obj : tabstractrecorddef;
+        nestedstructs: tfpobjectlist;
       begin
         if not assigned(st) then
           exit;
-        nestedclasses:=tfpobjectlist.create(false);
+        nestedstructs:=tfpobjectlist.create(false);
         for i:=0 to st.DefList.Count-1 do
           begin
             def:=tdef(st.DefList[i]);
             case def.typ of
               objectdef:
                 if not(oo_is_external in tobjectdef(def).objectoptions) then
-                  nestedclasses.add(def);
+                  nestedstructs.add(def);
+              recorddef:
+                nestedstructs.add(def);
             end;
           end;
-        for i:=0 to nestedclasses.count-1 do
+        for i:=0 to nestedstructs.count-1 do
           begin
-            obj:=tobjectdef(nestedclasses[i]);
-            NewAsmFileForObjectDef(obj);
+            obj:=tabstractrecorddef(nestedstructs[i]);
+            NewAsmFileForStructDef(obj);
             WriteExtraHeader(obj);
             WriteSymtableVarSyms(obj.symtable);
             AsmLn;
             WriteSymtableProcDefs(obj.symtable);
-            WriteSymtableObjectDefs(obj.symtable);
+            WriteSymtableStructDefs(obj.symtable);
           end;
-        nestedclasses.free;
+        nestedstructs.free;
       end;
 
     constructor TJasminAssembler.Create(smart: boolean);
@@ -983,8 +1016,8 @@ implementation
       WriteSymtableProcdefs(current_module.globalsymtable);
       WriteSymtableProcdefs(current_module.localsymtable);
 
-      WriteSymtableObjectDefs(current_module.globalsymtable);
-      WriteSymtableObjectDefs(current_module.localsymtable);
+      WriteSymtableStructDefs(current_module.globalsymtable);
+      WriteSymtableStructDefs(current_module.localsymtable);
 
       AsmLn;
 {$ifdef EXTDEBUG}

compiler/jvm/hlcgcpu.pas

@@ -174,6 +174,7 @@ uses
 
       { concatcopy helpers }
       procedure concatcopy_normal_array(list: TAsmList; size: tdef; const source, dest: treference);
+      procedure concatcopy_record(list: TAsmList; size: tdef; const source, dest: treference);
 
       { generate a call to a routine in the system unit }
       procedure g_call_system_proc(list: TAsmList; const procname: string);
@@ -1092,12 +1093,13 @@ implementation
                 procname:='FPC_SETLENGTH_DYNARR_MULTIDIM';
               end;
           end;
+        recorddef:
+          procname:='FPC_COPY_JRECORD_ARRAY';
         setdef,
-        recorddef,
         stringdef,
         variantdef:
           begin
-            { todo: make a (recursive for records) deep copy, not sure yet how... }
+            { todo: make a deep copy via clone... }
             internalerror(2011020505);
           end;
         else
@@ -1115,6 +1117,27 @@ implementation
        end;
     end;
 
+    procedure thlcgjvm.concatcopy_record(list: TAsmList; size: tdef; const source, dest: treference);
+      var
+        srsym: tsym;
+        pd: tprocdef;
+      begin
+        { self }
+        a_load_ref_stack(list,size,source,prepare_stack_for_ref(list,source,false));
+        { result }
+        a_load_ref_stack(list,size,dest,prepare_stack_for_ref(list,source,false));
+        { call fpcDeepCopy helper }
+        srsym:=search_struct_member(tabstractrecorddef(size),'FPCDEEPCOPY');
+        if not assigned(srsym) or
+           (srsym.typ<>procsym) then
+          Message1(cg_f_unknown_compilerproc,'FpcRecordBaseType.fpcDeepCopy');
+        pd:=tprocdef(tprocsym(srsym).procdeflist[0]);
+        a_call_name(list,pd,pd.mangledname,false);
+        { both parameters are removed, no function result }
+        decstack(list,2);
+      end;
+
+
   procedure thlcgjvm.g_concatcopy(list: TAsmList; size: tdef; const source, dest: treference);
     var
       handled: boolean;
@@ -1129,6 +1152,11 @@ implementation
                 handled:=true;
               end;
           end;
+        recorddef:
+          begin
+            concatcopy_record(list,size,source,dest);
+            handled:=true;
+          end;
       end;
       if not handled then
         inherited;
@@ -1247,6 +1275,7 @@ implementation
   procedure thlcgjvm.g_array_rtti_helper(list: TAsmList; t: tdef; const ref: treference; const highloc: tlocation; const name: string);
     var
       normaldim: longint;
+      recref: treference;
     begin
       { only in case of initialisation, we have to set all elements to "empty" }
       if name<>'FPC_INITIALIZE_ARRAY' then
@@ -1268,6 +1297,13 @@ implementation
         g_call_system_proc(list,'fpc_initialize_array_unicodestring')
       else if is_dynamic_array(t) then
         g_call_system_proc(list,'fpc_initialize_array_dynarr')
+      else if is_record(t) then
+        begin
+          tg.gethltemp(list,t,t.size,tt_persistent,recref);
+          a_load_ref_stack(list,t,recref,prepare_stack_for_ref(list,recref,false));
+          g_call_system_proc(list,'fpc_initialize_array_record');
+          tg.ungettemp(list,recref);
+        end
       else
         internalerror(2011031901);
     end;
@@ -1275,6 +1311,7 @@ implementation
   procedure thlcgjvm.g_initialize(list: TAsmList; t: tdef; const ref: treference);
     var
       dummyloc: tlocation;
+      recref: treference;
     begin
       if (t.typ=arraydef) and
          not is_dynamic_array(t) then
@@ -1282,6 +1319,15 @@ implementation
           dummyloc.loc:=LOC_INVALID;
           g_array_rtti_helper(list,tarraydef(t).elementdef,ref,dummyloc,'FPC_INITIALIZE_ARRAY')
         end
+      else if is_record(t) then
+        begin
+          { create a new, empty record and replace the contents of the old one
+            with those of the new one (in the future we can generate a dedicate
+            initialization helper) }
+          tg.gethltemp(list,t,t.size,tt_persistent,recref);
+          g_concatcopy(list,t,recref,ref);
+          tg.ungettemp(list,recref);
+        end
       else
         a_load_const_ref(list,t,0,ref);
     end;
@@ -1691,6 +1737,17 @@ implementation
                 internalerror(2010122601);
             end;
           end;
+        recordsymtable:
+          begin
+            if (po_staticmethod in pd.procoptions) then
+              opc:=a_invokestatic
+            else if (pd.visibility=vis_private) or
+               (pd.proctypeoption=potype_constructor) or
+               inheritedcall then
+              opc:=a_invokespecial
+            else
+              opc:=a_invokevirtual;
+          end
         else
           internalerror(2010122602);
       end;

compiler/jvm/njvmcal.pas

@@ -66,9 +66,9 @@ implementation
           exit;
         if tprocdef(procdefinition).proctypeoption<>potype_constructor then
           exit;
-        if (methodpointer.resultdef.typ<>classrefdef) then
+        if not(methodpointer.resultdef.typ in [classrefdef,recorddef]) then
           exit;
-        current_asmdata.CurrAsmList.concat(taicpu.op_sym(a_new,current_asmdata.RefAsmSymbol(tobjectdef(tprocdef(procdefinition).owner.defowner).jvm_full_typename(true))));
+        current_asmdata.CurrAsmList.concat(taicpu.op_sym(a_new,current_asmdata.RefAsmSymbol(tabstractrecorddef(tprocdef(procdefinition).owner.defowner).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 }

compiler/jvm/tgcpu.pas

@@ -53,9 +53,9 @@ unit tgcpu;
     uses
        verbose,
        cgbase,
-       symconst,defutil,
-       hlcgobj,hlcgcpu,
-       symdef;
+       symconst,symdef,symsym,defutil,
+       cpubase,aasmcpu,
+       hlcgobj,hlcgcpu;
 
 
     { ttgjvm }
@@ -64,6 +64,8 @@ unit tgcpu;
       var
         eledef: tdef;
         ndim: longint;
+        sym: tsym;
+        pd: tprocdef;
       begin
         result:=false;
         case def.typ of
@@ -84,9 +86,36 @@ unit tgcpu;
                   eledef:=tarraydef(def).elementdef;
                   thlcgjvm(hlcg).g_newarray(list,def,ndim);
                   thlcgjvm(hlcg).a_load_stack_ref(list,java_jlobject,ref,0);
+                  { allocate the records }
+                  if is_record(eledef) then
+                    hlcg.g_initialize(list,def,ref);
                   result:=true;
                 end;
             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;
+              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);
+              result:=true;
+            end;
         end;
       end;
 

compiler/jvmdef.pas

@@ -70,7 +70,7 @@ implementation
     cutils,cclasses,
     verbose,systems,
     fmodule,
-    symtable,symconst,symsym,symdef,
+    symtable,symconst,symsym,symdef,symcreat,
     defutil,paramgr;
 
 {******************************************************************
@@ -145,9 +145,7 @@ implementation
             result:=false;
           recorddef :
             begin
-              { will be hanlded via wrapping later, although wrapping may
-                happen at higher level }
-              result:=false;
+              encodedstr:=encodedstr+'L'+trecorddef(def).jvm_full_typename(true)+';'
             end;
           variantdef :
             begin
@@ -255,7 +253,9 @@ implementation
                 end
               else
                 internalerror(2010122606);
-            end
+            end;
+          recordsymtable:
+            tmpresult:=trecorddef(owner.defowner).jvm_full_typename(true)+'/'
           else
             internalerror(2010122605);
         end;
@@ -302,14 +302,20 @@ implementation
         errdef: tdef;
         res: string;
       begin
-        if not jvmtryencodetype(def,res,errdef) then
-          internalerror(2011012209);
-        if length(res)=1 then
-          result:=res[1]
+        if is_record(def) then
+          result:='R'
         else
-          result:='A';
+          begin
+            if not jvmtryencodetype(def,res,errdef) then
+              internalerror(2011012209);
+            if length(res)=1 then
+              result:=res[1]
+            else
+              result:='A';
+          end;
       end;
 
+
     function jvmimplicitpointertype(def: tdef): boolean;
       begin
         case def.typ of

compiler/ncgmem.pas

@@ -454,7 +454,9 @@ implementation
              { always packrecords C -> natural alignment }
              location.reference.alignment:=vs.vardef.alignment;
            end
-         else if is_java_class_or_interface(left.resultdef) then
+         else if is_java_class_or_interface(left.resultdef) or
+                 ((target_info.system=system_jvm_java32) and
+                  (left.resultdef.typ=recorddef)) then
            begin
              if (location.loc<>LOC_REFERENCE) or
                 (location.reference.index<>NR_NO) or

compiler/pdecobj.pas

@@ -50,6 +50,7 @@ implementation
       node,nld,nmem,ncon,ncnv,ncal,
       fmodule,scanner,
       pbase,pexpr,pdecsub,pdecvar,ptype,pdecl,ppu,
+      pjvm,
       parabase
       ;
 
@@ -734,110 +735,6 @@ implementation
       end;
 
 
-    { the JVM specs require that you add a default parameterless
-      constructor in case the programmer hasn't specified any }
-    procedure maybe_add_public_default_java_constructor(obj: tabstractrecorddef);
-
-      function find_parameterless_def(psym: tprocsym): tprocdef;
-        var
-          paras: tparalist;
-        begin
-          paras:=tparalist.create;
-          result:=psym.find_procdef_bypara_no_rettype(paras,[cpo_ignorehidden,cpo_openequalisexact]);
-          paras.free;
-        end;
-
-      var
-        sym: tsym;
-        ps: tprocsym;
-        pd: tprocdef;
-        topowner: tdefentry;
-        i: longint;
-      begin
-        { if there is at least one constructor for a class, do nothing (for
-           records, we'll always also need a parameterless constructor) }
-        if is_javaclass(obj) and
-           (oo_has_constructor in obj.objectoptions) then
-          exit;
-        { check whether the parent has a parameterless constructor that we can
-          call (in case of a class; all records will derive from
-          java.lang.Object or a shim on top of that with a parameterless
-          constructor) }
-        if is_javaclass(obj) then
-          begin
-            pd:=nil;
-            sym:=tsym(tobjectdef(obj).childof.symtable.find('CREATE'));
-            if assigned(sym) and
-               (sym.typ=procsym) then
-              begin
-                pd:=find_parameterless_def(tprocsym(sym));
-                { make sure it's a constructor }
-                if assigned(pd) and
-                   (pd.proctypeoption<>potype_constructor) then
-                  pd:=nil;
-              end;
-            if not assigned(pd) then
-              begin
-                Message(sym_e_no_matching_inherited_parameterless_constructor);
-                exit
-              end;
-          end;
-        { we call all constructors CREATE, because they don't have a name in
-          Java and otherwise we can't determine whether multiple overloads
-          are created with the same parameters }
-        sym:=tsym(obj.symtable.find('CREATE'));
-        if assigned(sym) then
-          begin
-            { does another, non-procsym, symbol already exist with that name? }
-            if (sym.typ<>procsym) then
-              begin
-                Message1(sym_e_duplicate_id_create_java_constructor,sym.realname);
-                exit;
-              end;
-            ps:=tprocsym(sym);
-            { is there already a parameterless function/procedure create? }
-            pd:=find_parameterless_def(ps);
-            if assigned(pd) then
-              begin
-                Message1(sym_e_duplicate_id_create_java_constructor,pd.fullprocname(false));
-                exit;
-              end;
-          end;
-        if not assigned(sym) then
-          begin
-            ps:=tprocsym.create('Create');
-            obj.symtable.insert(ps);
-          end;
-        { determine symtable level }
-        topowner:=obj;
-        while not(topowner.owner.symtabletype in [staticsymtable,globalsymtable,localsymtable]) do
-          topowner:=topowner.owner.defowner;
-        { create procdef }
-        pd:=tprocdef.create(topowner.owner.symtablelevel+1);
-        { method of this objectdef }
-        pd.struct:=obj;
-        { associated procsym }
-        pd.procsym:=ps;
-        { constructor }
-        pd.proctypeoption:=potype_constructor;
-        { needs to be exported }
-        include(pd.procoptions,po_global);
-        { for Delphi mode }
-        include(pd.procoptions,po_overload);
-        { synthetic, compiler-generated }
-        include(pd.procoptions,po_synthetic);
-        { public }
-        pd.visibility:=vis_public;
-        { result type }
-        pd.returndef:=obj;
-        { calling convention, self, ... }
-        handle_calling_convention(pd);
-        { register forward declaration with procsym }
-        proc_add_definition(pd);
-      end;
-
-
-
     function method_dec(astruct: tabstractrecorddef; is_classdef: boolean): tprocdef;
 
       procedure chkobjc(pd: tprocdef);

compiler/pexpr.pas

@@ -2377,7 +2377,9 @@ implementation
                  consume(_INHERITED);
                  if assigned(current_procinfo) and
                     assigned(current_structdef) and
-                    (current_structdef.typ=objectdef) then
+                    ((current_structdef.typ=objectdef) or
+                     ((target_info.system=system_jvm_java32) and
+                      (current_structdef.typ=recorddef)))then
                   begin
                     { for record helpers in mode Delphi "inherited" is not
                       allowed }
@@ -2385,13 +2387,18 @@ implementation
                         (m_delphi in current_settings.modeswitches) and
                         is_record(tobjectdef(current_structdef).extendeddef) then
                       Message(parser_e_inherited_not_in_record);
-                    hclassdef:=tobjectdef(current_structdef).childof;
-                    { Objective-C categories *replace* methods in the class
-                      they extend, or add methods to it. So calling an
-                      inherited method always calls the method inherited from
-                      the parent of the extended class }
-                    if is_objccategory(current_structdef) then
-                      hclassdef:=hclassdef.childof;
+                    if (current_structdef.typ=objectdef) then
+                      begin
+                        hclassdef:=tobjectdef(current_structdef).childof;
+                        { Objective-C categories *replace* methods in the class
+                          they extend, or add methods to it. So calling an
+                          inherited method always calls the method inherited from
+                          the parent of the extended class }
+                        if is_objccategory(current_structdef) then
+                          hclassdef:=hclassdef.childof;
+                      end
+                    else
+                      hclassdef:=java_fpcbaserecordtype;
                     { if inherited; only then we need the method with
                       the same name }
                     if token <> _ID then
@@ -2413,7 +2420,7 @@ implementation
                        if is_objectpascal_helper(current_structdef) then
                          searchsym_in_helper(tobjectdef(current_structdef),tobjectdef(current_structdef),hs,srsym,srsymtable,true)
                        else
-                         searchsym_in_class(hclassdef,tobjectdef(current_structdef),hs,srsym,srsymtable,true);
+                         searchsym_in_class(hclassdef,current_structdef,hs,srsym,srsymtable,true);
                      end
                     else
                      begin
@@ -2425,7 +2432,7 @@ implementation
                        if is_objectpascal_helper(current_structdef) then
                          searchsym_in_helper(tobjectdef(current_structdef),tobjectdef(current_structdef),hs,srsym,srsymtable,true)
                        else
-                         searchsym_in_class(hclassdef,tobjectdef(current_structdef),hs,srsym,srsymtable,true);
+                         searchsym_in_class(hclassdef,current_structdef,hs,srsym,srsymtable,true);
                      end;
                     if assigned(srsym) then
                      begin

compiler/pjvm.pas

@@ -0,0 +1,203 @@
+{
+    Copyright (c) 2011 by Jonas Maebe
+
+    This unit implements some JVM parser helper routines.
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    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.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+}
+
+{$i fpcdefs.inc}
+
+unit pjvm;
+
+interface
+
+    uses
+     symdef;
+
+    { the JVM specs require that you add a default parameterless
+      constructor in case the programmer hasn't specified any }
+    procedure maybe_add_public_default_java_constructor(obj: tabstractrecorddef);
+
+    { records are emulated via Java classes. They require a default constructor
+      to initialise temps, a deep copy helper for assignments, and clone()
+      to initialse dynamic arrays }
+    procedure add_java_default_record_methods_intf(def: trecorddef);
+
+implementation
+
+  uses
+    globtype,
+    cutils,cclasses,
+    verbose,systems,
+    fmodule,
+    parabase,
+    pdecsub,
+    symbase,symtype,symtable,symconst,symsym,symcreat,defcmp,jvmdef,
+    defutil,paramgr;
+
+
+    { the JVM specs require that you add a default parameterless
+      constructor in case the programmer hasn't specified any }
+    procedure maybe_add_public_default_java_constructor(obj: tabstractrecorddef);
+
+      function find_parameterless_def(psym: tprocsym): tprocdef;
+        var
+          paras: tparalist;
+        begin
+          paras:=tparalist.create;
+          result:=psym.find_procdef_bypara_no_rettype(paras,[cpo_ignorehidden,cpo_openequalisexact]);
+          paras.free;
+        end;
+
+      var
+        sym: tsym;
+        ps: tprocsym;
+        pd: tprocdef;
+        topowner: tdefentry;
+      begin
+        { if there is at least one constructor for a class, do nothing (for
+           records, we'll always also need a parameterless constructor) }
+        if is_javaclass(obj) and
+           (oo_has_constructor in obj.objectoptions) then
+          exit;
+        { check whether the parent has a parameterless constructor that we can
+          call (in case of a class; all records will derive from
+          java.lang.Object or a shim on top of that with a parameterless
+          constructor) }
+        if is_javaclass(obj) then
+          begin
+            pd:=nil;
+            sym:=tsym(tobjectdef(obj).childof.symtable.find('CREATE'));
+            if assigned(sym) and
+               (sym.typ=procsym) then
+              begin
+                pd:=find_parameterless_def(tprocsym(sym));
+                { make sure it's a constructor }
+                if assigned(pd) and
+                   (pd.proctypeoption<>potype_constructor) then
+                  pd:=nil;
+              end;
+            if not assigned(pd) then
+              begin
+                Message(sym_e_no_matching_inherited_parameterless_constructor);
+                exit
+              end;
+          end;
+        { we call all constructors CREATE, because they don't have a name in
+          Java and otherwise we can't determine whether multiple overloads
+          are created with the same parameters }
+        sym:=tsym(obj.symtable.find('CREATE'));
+        if assigned(sym) then
+          begin
+            { does another, non-procsym, symbol already exist with that name? }
+            if (sym.typ<>procsym) then
+              begin
+                Message1(sym_e_duplicate_id_create_java_constructor,sym.realname);
+                exit;
+              end;
+            ps:=tprocsym(sym);
+            { is there already a parameterless function/procedure create? }
+            pd:=find_parameterless_def(ps);
+            if assigned(pd) then
+              begin
+                Message1(sym_e_duplicate_id_create_java_constructor,pd.fullprocname(false));
+                exit;
+              end;
+          end;
+        if not assigned(sym) then
+          begin
+            ps:=tprocsym.create('Create');
+            obj.symtable.insert(ps);
+          end;
+        { determine symtable level }
+        topowner:=obj;
+        while not(topowner.owner.symtabletype in [staticsymtable,globalsymtable,localsymtable]) do
+          topowner:=topowner.owner.defowner;
+        { create procdef }
+        pd:=tprocdef.create(topowner.owner.symtablelevel+1);
+        { method of this objectdef }
+        pd.struct:=obj;
+        { associated procsym }
+        pd.procsym:=ps;
+        { constructor }
+        pd.proctypeoption:=potype_constructor;
+        { needs to be exported }
+        include(pd.procoptions,po_global);
+        { for Delphi mode }
+        include(pd.procoptions,po_overload);
+        { generate anonymous inherited call in the implementation }
+        pd.synthetickind:=tsk_anon_inherited;
+        { public }
+        pd.visibility:=vis_public;
+        { result type }
+        pd.returndef:=obj;
+        { calling convention, self, ... }
+        handle_calling_convention(pd);
+        { register forward declaration with procsym }
+        proc_add_definition(pd);
+      end;
+
+
+    procedure add_java_default_record_methods_intf(def: trecorddef);
+      var
+        sstate: tscannerstate;
+        pd: tprocdef;
+      begin
+        maybe_add_public_default_java_constructor(def);
+        replace_scanner('record_jvm_helpers',sstate);
+        { no override, because not supported in records; the parser will still
+          accept "inherited" though }
+        if str_parse_method_dec('function clone: JLObject;',false,def,pd) then
+          pd.synthetickind:=tsk_jvm_clone
+        else
+          internalerror(2011032806);
+        { can't use def.typesym, not yet set at this point }
+        if def.symtable.realname^='' then
+          internalerror(2011032803);
+        if str_parse_method_dec('procedure fpcDeepCopy(out result:'+def.symtable.realname^+');',false,def,pd) then
+          pd.synthetickind:=tsk_record_deepcopy
+        else
+          internalerror(2011032807);
+        restore_scanner(sstate);
+      end;
+
+
+{******************************************************************
+                    jvm type validity checking
+*******************************************************************}
+
+   function jvmencodetype(def: tdef): string;
+     var
+       errordef: tdef;
+     begin
+       if not jvmtryencodetype(def,result,errordef) then
+         internalerror(2011012305);
+     end;
+
+
+   function jvmchecktype(def: tdef; out founderror: tdef): boolean;
+      var
+        encodedtype: string;
+      begin
+        { don't duplicate the code like in objcdef, since the resulting strings
+          are much shorter here so it's not worth it }
+        result:=jvmtryencodetype(def,encodedtype,founderror);
+      end;
+
+
+end.

compiler/ptype.pas

@@ -66,7 +66,7 @@ implementation
        paramgr,procinfo,
        { symtable }
        symconst,symsym,symtable,
-       defutil,defcmp,
+       defutil,defcmp,jvmdef,
        { modules }
        fmodule,
        { pass 1 }
@@ -74,7 +74,8 @@ implementation
        nmat,nadd,ncal,nset,ncnv,ninl,ncon,nld,nflw,
        { parser }
        scanner,
-       pbase,pexpr,pdecsub,pdecvar,pdecobj,pdecl;
+       pbase,pexpr,pdecsub,pdecvar,pdecobj,pdecl,
+       pjvm;
 
 
     procedure resolve_forward_types;
@@ -944,6 +945,8 @@ implementation
               end;
             _END :
               begin
+                if (target_info.system=system_jvm_java32) then
+                  add_java_default_record_methods_intf(trecorddef(current_structdef));
                 consume(_END);
                 break;
               end;
@@ -990,6 +993,9 @@ implementation
          else
            begin
              read_record_fields([vd_record]);
+             { we need a constructor to create temps, a deep copy helper, ... }
+             if (target_info.system=system_jvm_java32) then
+               add_java_default_record_methods_intf(trecorddef(current_structdef));
              consume(_END);
             end;
          { make the record size aligned }

compiler/symconst.pas

@@ -316,9 +316,7 @@ type
        up the stack will also remain balanced) }
     po_delphi_nested_cc,
     { Java method }
-    po_java,
-    { synthetic method, not parsed from source but inserted by compiler }
-    po_synthetic
+    po_java
   );
   tprocoptions=set of tprocoption;
 

compiler/symcreat.pas

@@ -116,10 +116,7 @@ implementation
       { and parse it... }
       pd:=method_dec(astruct,is_classdef);
       if assigned(pd) then
-        begin
-          include(pd.procoptions,po_synthetic);
-          result:=true;
-        end;
+        result:=true;
       parse_only:=oldparse_only;
     end;
 
@@ -196,31 +193,122 @@ implementation
           str:=tprocdef(pd).customprocname([pno_proctypeoption,pno_paranames,pno_noclassmarker])+'overload;';
           if not str_parse_method_dec(str,isclassmethod,obj,newpd) then
             internalerror(2011032001);
-          include(newpd.procoptions,po_synthetic);
+          newpd.synthetickind:=tsk_anon_inherited;
         end;
       restore_scanner(sstate);
     end;
 
 
-  procedure add_missing_parent_constructors_impl(obj: tobjectdef);
+  procedure implement_anon_inherited(pd: tprocdef);
     var
-      i: longint;
-      def: tdef;
       str: ansistring;
       isclassmethod: boolean;
     begin
-      for i:=0 to tobjectsymtable(obj.symtable).deflist.count-1 do
+      isclassmethod:=
+        (po_classmethod in pd.procoptions) and
+        not(pd.proctypeoption in [potype_constructor,potype_destructor]);
+      str:=pd.customprocname([pno_proctypeoption,pno_paranames,pno_ownername,pno_noclassmarker]);
+      str:=str+'begin inherited end;';
+      str_parse_method_impl(str,isclassmethod);
+    end;
+
+
+  procedure implement_jvm_clone(pd: tprocdef);
+    var
+      struct: tabstractrecorddef;
+      str: ansistring;
+      i: longint;
+      sym: tsym;
+      fsym: tfieldvarsym;
+    begin
+      if not(pd.owner.defowner.typ in [recorddef,objectdef]) then
+        internalerror(2011032802);
+      struct:=tabstractrecorddef(pd.owner.defowner);
+      { anonymous record types must get an artificial name, so we can generate
+        a typecast at the scanner level }
+      if (struct.typ=recorddef) and
+         not assigned(struct.typesym) then
+        internalerror(2011032812);
+      str:=pd.customprocname([pno_proctypeoption,pno_paranames,pno_ownername,pno_noclassmarker]);
+      { the inherited clone will already copy all fields in a shallow way ->
+        copy records/regular arrays in a regular way }
+      str:=str+'begin result:=inherited;';
+      for i:=0 to struct.symtable.symlist.count-1 do
         begin
-          def:=tdef(tobjectsymtable(obj.symtable).deflist[i]);
-          if (def.typ<>procdef) or
-             not(po_synthetic in tprocdef(def).procoptions) then
+          sym:=tsym(struct.symtable.symlist[i]);
+          if (sym.typ=fieldvarsym) then
+            begin
+              fsym:=tfieldvarsym(sym);
+              if (fsym.vardef.typ=recorddef) or
+                 ((fsym.vardef.typ=arraydef) and
+                  not is_dynamic_array(fsym.vardef)) or
+                 ((fsym.vardef.typ=setdef) and
+                  not is_smallset(fsym.vardef)) then
+                str:=str+struct.typesym.realname+'(result).'+fsym.realname+':='+fsym.realname+';';
+            end;
+        end;
+      str:=str+'end;';
+      str_parse_method_impl(str,false);
+    end;
+
+
+  procedure implement_record_deepcopy(pd: tprocdef);
+    var
+      struct: tabstractrecorddef;
+      str: ansistring;
+      i: longint;
+      sym: tsym;
+      fsym: tfieldvarsym;
+    begin
+      if not(pd.owner.defowner.typ in [recorddef,objectdef]) then
+        internalerror(2011032810);
+      struct:=tabstractrecorddef(pd.owner.defowner);
+      { anonymous record types must get an artificial name, so we can generate
+        a typecast at the scanner level }
+      if (struct.typ=recorddef) and
+         not assigned(struct.typesym) then
+        internalerror(2011032811);
+      str:=pd.customprocname([pno_proctypeoption,pno_paranames,pno_ownername,pno_noclassmarker]);
+      { copy all fields }
+      str:=str+'begin ';
+      for i:=0 to struct.symtable.symlist.count-1 do
+        begin
+          sym:=tsym(struct.symtable.symlist[i]);
+          if (sym.typ=fieldvarsym) then
+            begin
+              fsym:=tfieldvarsym(sym);
+              str:=str+'result.'+fsym.realname+':='+fsym.realname+';';
+            end;
+        end;
+      str:=str+'end;';
+      str_parse_method_impl(str,false);
+    end;
+
+
+  procedure add_synthetic_method_implementations_for_struct(struct: tabstractrecorddef);
+    var
+      i   : longint;
+      def : tdef;
+      pd  : tprocdef;
+    begin
+      for i:=0 to struct.symtable.deflist.count-1 do
+        begin
+          def:=tdef(struct.symtable.deflist[i]);
+          if (def.typ<>procdef) then
             continue;
-          isclassmethod:=
-            (po_classmethod in tprocdef(def).procoptions) and
-            not(tprocdef(def).proctypeoption in [potype_constructor,potype_destructor]);
-          str:=tprocdef(def).customprocname([pno_proctypeoption,pno_paranames,pno_ownername,pno_noclassmarker]);
-          str:=str+'overload; begin inherited end;';
-          str_parse_method_impl(str,isclassmethod);
+          pd:=tprocdef(def);
+          case pd.synthetickind of
+            tsk_none:
+              ;
+            tsk_anon_inherited:
+              implement_anon_inherited(pd);
+            tsk_jvm_clone:
+              implement_jvm_clone(pd);
+            tsk_record_deepcopy:
+              implement_record_deepcopy(pd);
+            else
+              internalerror(2011032801);
+          end;
         end;
     end;
 
@@ -238,12 +326,13 @@ implementation
       for i:=0 to st.deflist.count-1 do
         begin
           def:=tdef(st.deflist[i]);
-          if is_javaclass(def) and
-             not(oo_is_external in tobjectdef(def).objectoptions) then
+          if (is_javaclass(def) and
+              not(oo_is_external in tobjectdef(def).objectoptions)) or
+              (def.typ=recorddef) then
            begin
              if not sstate.valid then
                replace_scanner('synthetic_impl',sstate);
-            add_missing_parent_constructors_impl(tobjectdef(def));
+            add_synthetic_method_implementations_for_struct(tabstractrecorddef(def));
            end;
         end;
       restore_scanner(sstate);

compiler/symdef.pas

@@ -217,6 +217,8 @@ interface
           function  GetTypeName:string;override;
           { debug }
           function  needs_inittable : boolean;override;
+          { jvm }
+          function  is_related(d : tdef) : boolean;override;
        end;
 
        tobjectdef = class;
@@ -484,6 +486,13 @@ interface
        end;
        pinlininginfo = ^tinlininginfo;
 
+       { kinds of synthetic procdefs that can be generated }
+       tsynthetickind = (
+         tsk_none,
+         tsk_anon_inherited,        // anonymous inherited call
+         tsk_jvm_clone,             // Java-style clone method
+         tsk_record_deepcopy        // deepcopy for records field by field
+       );
 
 {$ifdef oldregvars}
        { register variables }
@@ -561,6 +570,7 @@ interface
           fpu_used     : byte;
 {$endif i386}
           visibility   : tvisibility;
+          synthetickind : tsynthetickind;
           { true, if the procedure is only declared
             (forward procedure) }
           forwarddef,
@@ -770,6 +780,8 @@ interface
        java_jlobject             : tobjectdef;
        { java.lang.Throwable }
        java_jlthrowable          : tobjectdef;
+       { FPC base type for records }
+       java_fpcbaserecordtype    : tobjectdef;
 
     const
 {$ifdef i386}
@@ -3109,6 +3121,19 @@ implementation
       end;
 
 
+    function trecorddef.is_related(d: tdef): boolean;
+      begin
+        { records are implemented via classes in the JVM target, and are
+          all descendents of the java_fpcbaserecordtype class }
+        if (target_info.system=system_jvm_java32) and
+           ((d=java_jlobject) or
+            (d=java_fpcbaserecordtype)) then
+          is_related:=true
+        else
+          is_related:=false;
+      end;
+
+
     procedure trecorddef.buildderef;
       begin
          inherited buildderef;
@@ -4667,6 +4692,8 @@ implementation
                java_jlobject:=self;
              if (objname^='JLTHROWABLE') then
                java_jlthrowable:=self;
+             if (objname^='FPCBASERECORDTYPE') then
+               java_fpcbaserecordtype:=self;
            end;
          writing_class_record_dbginfo:=false;
        end;
@@ -6034,8 +6061,10 @@ implementation
       begin
         result:=
           assigned(def) and
-          (def.typ=objectdef) and
-          (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_helper,odt_javaclass,odt_interfacejava]);
+          (((def.typ=objectdef) and
+            (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_helper,odt_javaclass,odt_interfacejava])) or
+           ((target_info.system=system_jvm_java32) and
+            (def.typ=recorddef)));
       end;
 
     function is_class_or_object(def: tdef): boolean;

compiler/symsym.pas

@@ -101,6 +101,7 @@ interface
           procedure buildderef;override;
           procedure deref;override;
           function find_procdef_bytype(pt:Tproctypeoption):Tprocdef;
+          function find_bytype_parameterless(pt:Tproctypeoption):Tprocdef;
           function find_procdef_bypara_no_rettype(para:TFPObjectList;cpoptions:tcompare_paras_options):Tprocdef;
           function find_procdef_bypara(para:TFPObjectList;retdef:tdef;cpoptions:tcompare_paras_options):Tprocdef;
           function find_procdef_bytype_and_para(pt:Tproctypeoption;para:TFPObjectList;retdef:tdef;cpoptions:tcompare_paras_options):Tprocdef;
@@ -654,6 +655,37 @@ implementation
       end;
 
 
+    function tprocsym.find_bytype_parameterless(pt: Tproctypeoption): Tprocdef;
+      var
+        i,j : longint;
+        pd  : tprocdef;
+        found : boolean;
+      begin
+        result:=nil;
+        for i:=0 to ProcdefList.Count-1 do
+          begin
+            pd:=tprocdef(ProcdefList[i]);
+            if (pd.proctypeoption=pt) then
+              begin
+                found:=true;
+                for j:=0 to pd.paras.count-1 do
+                  begin
+                    if not(vo_is_hidden_para in tparavarsym(pd.paras[j]).varoptions) then
+                      begin
+                        found:=false;
+                        break;
+                      end;
+                  end;
+                if found then
+                  begin
+                    result:=pd;
+                    exit;
+                  end;
+              end;
+          end;
+      end;
+
+
     function check_procdef_paras(pd:tprocdef;para:TFPObjectList;retdef:tdef;
                                             cpoptions:tcompare_paras_options; checkrettype: boolean): tprocdef;
       var
@@ -1299,7 +1331,8 @@ implementation
         srsymtable : tsymtable;
       begin
 {$ifdef jvm}
-        if is_java_class_or_interface(tdef(owner.defowner)) then
+        if is_java_class_or_interface(tdef(owner.defowner)) or
+           (tdef(owner.defowner).typ=recorddef) then
           begin
             if assigned(cachedmangledname) then
               result:=cachedmangledname^

compiler/symtable.pas

@@ -224,7 +224,7 @@ interface
     function  searchsym_type(const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
     function  searchsym_in_module(pm:pointer;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
     function  searchsym_in_named_module(const unitname, symname: TIDString; out srsym: tsym; out srsymtable: tsymtable): boolean;
-    function  searchsym_in_class(classh,contextclassh:tobjectdef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;searchhelper:boolean):boolean;
+    function  searchsym_in_class(classh: tobjectdef; contextclassh:tabstractrecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;searchhelper:boolean):boolean;
     function  searchsym_in_record(recordh:tabstractrecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable):boolean;
     function  searchsym_in_class_by_msgint(classh:tobjectdef;msgid:longint;out srdef : tdef;out srsym:tsym;out srsymtable:TSymtable):boolean;
     function  searchsym_in_class_by_msgstr(classh:tobjectdef;const s:string;out srsym:tsym;out srsymtable:TSymtable):boolean;
@@ -2215,7 +2215,7 @@ implementation
       end;
 
 
-    function searchsym_in_class(classh,contextclassh:tobjectdef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;searchhelper:boolean):boolean;
+    function searchsym_in_class(classh: tobjectdef;contextclassh:tabstractrecorddef;const s : TIDString;out srsym:tsym;out srsymtable:TSymtable;searchhelper:boolean):boolean;
       var
         hashedid : THashedIDString;
         orgclass : tobjectdef;
@@ -2231,9 +2231,10 @@ implementation
               or be a parent of contextclassh. E.g. for inherited searches the classh is the
               parent or a class helper. }
             if not (contextclassh.is_related(classh) or
-                (assigned(contextclassh.extendeddef) and
-                (contextclassh.extendeddef.typ=objectdef) and
-                contextclassh.extendeddef.is_related(classh))) then
+                (is_classhelper(contextclassh) and
+                 assigned(tobjectdef(contextclassh).extendeddef) and
+                (tobjectdef(contextclassh).extendeddef.typ=objectdef) and
+                tobjectdef(contextclassh).extendeddef.is_related(classh))) then
               internalerror(200811161);
           end;
         result:=false;
@@ -2265,7 +2266,7 @@ implementation
         if is_objectpascal_helper(classh) then
           begin
             { helpers have their own obscure search logic... }
-            result:=searchsym_in_helper(classh,contextclassh,s,srsym,srsymtable,false);
+            result:=searchsym_in_helper(classh,tobjectdef(contextclassh),s,srsym,srsymtable,false);
             if result then
               exit;
           end

rtl/java/compproc.inc

@@ -52,4 +52,5 @@ Procedure fpc_Copy_proc (Src, Dest, TypeInfo : Pointer); compilerproc; inline;
   dynamic array types, and add an extra parameter to determine the first
   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;
 

rtl/java/jdynarrh.inc

@@ -24,6 +24,7 @@ type
   TJFloatArray = array of jfloat;
   TJDoubleArray = array of jdouble;
   TJObjectArray = array of JLObject;
+  TJRecordArray = array of FpcBaseRecordType;
 
 const
   FPCJDynArrTypeJByte   = 'B';
@@ -34,6 +35,7 @@ const
   FPCJDynArrTypeJFloat  = 'F';
   FPCJDynArrTypeJDouble = 'D';
   FPCJDynArrTypeJObject = 'A';
+  FPCJDynArrTypeRecord  = 'R';
 
 { 1-dimensional setlength routines
 
@@ -49,6 +51,7 @@ function fpc_setlength_dynarr_jchar(aorg, anew: TJCharArray; deepcopy: boolean):
 function fpc_setlength_dynarr_jfloat(aorg, anew: TJFloatArray; deepcopy: boolean): TJFloatArray;
 function fpc_setlength_dynarr_jdouble(aorg, anew: TJDoubleArray; deepcopy: boolean): TJDoubleArray;
 function fpc_setlength_dynarr_jobject(aorg, anew: TJObjectArray; deepcopy: boolean; docopy : boolean = true): TJObjectArray;
+function fpc_setlength_dynarr_jrecord(aorg, anew: TJRecordArray; deepcopy: boolean): TJRecordArray;
 
 { array copying helpers }
 
@@ -60,6 +63,7 @@ procedure fpc_copy_jchar_array(src, dst: TJCharArray);
 procedure fpc_copy_jfloat_array(src, dst: TJFloatArray);
 procedure fpc_copy_jdouble_array(src, dst: TJDoubleArray);
 procedure fpc_copy_jobject_array(src, dst: TJObjectArray);
+procedure fpc_copy_jrecord_array(src, dst: TJRecordArray);
 
 { multi-dimendional setlength routine: all intermediate dimensions are arrays
   of arrays, so that's the same for all array kinds. Only the type of the final

rtl/java/jrec.inc

@@ -0,0 +1,32 @@
+{
+    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 records 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 FpcBaseRecordType.create;
+    begin
+    end;
+
+
+  function FpcBaseRecordType.clone: JLObject;
+    begin
+      result:=inherited;
+    end;
+
+
+  function FpcBaseRecordType.newEmpty: FpcBaseRecordType;
+    begin
+      result:=FpcBaseRecordType(inherited clone);
+    end;
+

rtl/java/jrech.inc

@@ -0,0 +1,28 @@
+{
+    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 records 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
+  { the JLCloneable interface does not declare any methods, but JLObject.clone()
+    throws an exception if you try to clone a class that does not implement this
+    interface }
+  FpcBaseRecordType = class abstract (JLObject, JLCloneable)
+    constructor create;
+    { create a deep copy, overridden by actual record types }
+    function clone: JLObject;override;
+    { create an empty instance of the current type }
+    function newEmpty: FpcBaseRecordType;
+  end;
+

rtl/java/rtti.inc

@@ -30,3 +30,21 @@ procedure fpc_initialize_array_dynarr(arr: TJObjectArray; normalarrdim: longint)
       end;
   end;
 
+procedure fpc_initialize_array_record_intern(arr: TJObjectArray; normalarrdim: longint; inst: FpcBaseRecordType); external name 'fpc_initialize_array_record';
+
+procedure fpc_initialize_array_record(arr: TJObjectArray; normalarrdim: longint; inst: FpcBaseRecordType);compilerproc;
+  var
+    i: longint;
+  begin
+    if normalarrdim > 0 then
+      begin
+        for i:=low(arr) to high(arr) do
+          fpc_initialize_array_record_intern(TJObjectArray(arr[i]),normalarrdim-1,inst);
+      end
+    else
+      begin
+        for i:=low(arr) to high(arr) do
+          arr[i]:=inst.clone;
+      end;
+  end;
+

rtl/java/system.pp

@@ -97,6 +97,7 @@ type
 
 {$i innr.inc}
 {$i jmathh.inc}
+{$i jrech.inc}
 {$i jdynarrh.inc}
 
 {$i compproc.inc}
@@ -124,6 +125,7 @@ type
 }
 
 {$i rtti.inc}
+{$i jrec.inc}
 
 function min(a,b : longint) : longint;
   begin
@@ -208,6 +210,15 @@ procedure fpc_copy_jobject_array(src, dst: TJObjectArray);
   end;
 
 
+procedure fpc_copy_jrecord_array(src, dst: TJRecordArray);
+  var
+    i: longint;
+  begin
+    for i:=0 to min(high(src),high(dst)) do
+      dst[i]:=FpcBaseRecordType(src[i].clone);
+  end;
+
+
 { 1-dimensional setlength routines }
 
 function fpc_setlength_dynarr_jbyte(aorg, anew: TJByteArray; deepcopy: boolean): TJByteArray;
@@ -315,6 +326,19 @@ function fpc_setlength_dynarr_jobject(aorg, anew: TJObjectArray; deepcopy: boole
   end;
 
 
+function fpc_setlength_dynarr_jrecord(aorg, anew: TJRecordArray; deepcopy: boolean): TJRecordArray;
+  begin
+    if deepcopy or
+       (length(aorg)<>length(anew)) then
+      begin
+        fpc_copy_jrecord_array(aorg,anew);
+        result:=anew
+      end
+    else
+      result:=aorg;
+  end;
+
+
 { multi-dimensional setlength routine }
 function fpc_setlength_dynarr_multidim(aorg, anew: TJObjectArray; deepcopy: boolean; ndim: longint; eletype: jchar): TJObjectArray;
   var
@@ -395,6 +419,13 @@ function fpc_setlength_dynarr_multidim(aorg, anew: TJObjectArray; deepcopy: bool
               for i:=succ(partdone) to high(result) do
                 result[i]:=TObject(fpc_setlength_dynarr_jobject(nil,TJObjectArray(anew[i]),deepcopy,true));
             end;
+          FPCJDynArrTypeRecord:
+            begin
+              for i:=low(result) to partdone do
+                result[i]:=TObject(fpc_setlength_dynarr_jrecord(TJRecordArray(aorg[i]),TJRecordArray(anew[i]),deepcopy));
+              for i:=succ(partdone) to high(result) do
+                result[i]:=TObject(fpc_setlength_dynarr_jrecord(nil,TJRecordArray(anew[i]),deepcopy));
+          end;
         end;
       end
     else