+ support for regular arrays and open arrays

   o support for copying value parameters at the callee side if they were
     passed by reference in hlcg
   o JVM g_concatcopy() implementation for arrays
   o moved code to get length of an array from njvminl to hlcgcpu so it can
     be reused elsewhere as well
   o export array copy helpers from system unit for use when assigning one
     array to another
   o some generic support for types that are normally not implicit pointers,
     but which are for the JVM target (such as normal arrays)
  * handle assigning nil to a dynamic array by generating a setlength(x,0)
    node instead of by hardcoding a call to fpc_dynarray_clear, so
    target-specific code can handle it if required
  * hook up gethltemp() for JVM ttgjvm so array temps are properly
    allocated

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

.gitattributes

@@ -225,6 +225,7 @@ compiler/jvm/njvmcnv.pas svneol=native#text/plain
 compiler/jvm/njvmcon.pas svneol=native#text/plain
 compiler/jvm/njvmflw.pas svneol=native#text/plain
 compiler/jvm/njvminl.pas svneol=native#text/plain
+compiler/jvm/njvmld.pas svneol=native#text/plain
 compiler/jvm/njvmmat.pas svneol=native#text/plain
 compiler/jvm/njvmmem.pas svneol=native#text/plain
 compiler/jvm/njvmutil.pas svneol=native#text/plain

compiler/hlcg2ll.pas

@@ -328,8 +328,8 @@ unit hlcg2ll;
              @param(dest Destination reference of copy)
 
           }
-//          procedure g_copyshortstring(list : TAsmList;const source,dest : treference;len:byte);
-//          procedure g_copyvariant(list : TAsmList;const source,dest : treference);
+          procedure g_copyshortstring(list : TAsmList;const source,dest : treference;strdef:tstringdef);override;
+          procedure g_copyvariant(list : TAsmList;const source,dest : treference;vardef:tvariantdef);override;
 
           procedure g_incrrefcount(list : TAsmList;t: tdef; const ref: treference);override;
           procedure g_decrrefcount(list : TAsmList;t: tdef; const ref: treference);override;
@@ -349,8 +349,8 @@ unit hlcg2ll;
           procedure g_overflowcheck(list: TAsmList; const Loc:tlocation; def:tdef); override;
           procedure g_overflowCheck_loc(List:TAsmList;const Loc:TLocation;def:TDef;var ovloc : tlocation);override;
 
-//          procedure g_copyvaluepara_openarray(list : TAsmList;const ref:treference;const lenloc:tlocation;elesize:aint;destreg:tregister);override;
-//          procedure g_releasevaluepara_openarray(list : TAsmList;const l:tlocation);override;
+          procedure g_copyvaluepara_openarray(list : TAsmList;const ref:treference;const lenloc:tlocation;arrdef: tarraydef;destreg:tregister);override;
+          procedure g_releasevaluepara_openarray(list : TAsmList;arrdef: tarraydef;const l:tlocation);override;
 
           {# Emits instructions when compilation is done in profile
              mode (this is set as a command line option). The default
@@ -1063,6 +1063,16 @@ procedure thlcg2ll.a_loadaddr_ref_reg(list: TAsmList; fromsize, tosize: tdef; co
       cg.g_concatcopy_unaligned(list,source,dest,size.size);
     end;
 
+  procedure thlcg2ll.g_copyshortstring(list: TAsmList; const source, dest: treference; strdef: tstringdef);
+    begin
+      cg.g_copyshortstring(list,source,dest,strdef.len);
+    end;
+
+  procedure thlcg2ll.g_copyvariant(list: TAsmList; const source, dest: treference; vardef: tvariantdef);
+    begin
+      cg.g_copyvariant(list,source,dest);
+    end;
+
   procedure thlcg2ll.g_incrrefcount(list: TAsmList; t: tdef; const ref: treference);
     begin
       cg.g_incrrefcount(list,t,ref);
@@ -1098,6 +1108,16 @@ procedure thlcg2ll.a_loadaddr_ref_reg(list: TAsmList; fromsize, tosize: tdef; co
       cg.g_overflowCheck_loc(list,loc,def,ovloc);
     end;
 
+  procedure thlcg2ll.g_copyvaluepara_openarray(list: TAsmList; const ref: treference; const lenloc: tlocation; arrdef: tarraydef; destreg: tregister);
+    begin
+      cg.g_copyvaluepara_openarray(list,ref,lenloc,arrdef.elesize,destreg);
+    end;
+
+  procedure thlcg2ll.g_releasevaluepara_openarray(list: TAsmList; arrdef: tarraydef; const l: tlocation);
+    begin
+      cg.g_releasevaluepara_openarray(list,l);
+    end;
+
   procedure thlcg2ll.g_profilecode(list: TAsmList);
     begin
       cg.g_profilecode(list);

compiler/hlcgobj.pas

@@ -354,8 +354,8 @@ unit hlcgobj;
              @param(dest Destination reference of copy)
 
           }
-//          procedure g_copyshortstring(list : TAsmList;const source,dest : treference;len:byte);
-//          procedure g_copyvariant(list : TAsmList;const source,dest : treference);
+          procedure g_copyshortstring(list : TAsmList;const source,dest : treference;strdef:tstringdef);virtual;abstract;
+          procedure g_copyvariant(list : TAsmList;const source,dest : treference;vardef:tvariantdef);virtual;abstract;
 
           procedure g_incrrefcount(list : TAsmList;t: tdef; const ref: treference);virtual;abstract;
           procedure g_decrrefcount(list : TAsmList;t: tdef; const ref: treference);virtual;abstract;
@@ -375,8 +375,8 @@ unit hlcgobj;
           procedure g_overflowcheck(list: TAsmList; const Loc:tlocation; def:tdef); virtual; abstract;
           procedure g_overflowCheck_loc(List:TAsmList;const Loc:TLocation;def:TDef;var ovloc : tlocation);virtual; abstract;
 
-//          procedure g_copyvaluepara_openarray(list : TAsmList;const ref:treference;const lenloc:tlocation;elesize:aint;destreg:tregister);virtual;
-//          procedure g_releasevaluepara_openarray(list : TAsmList;const l:tlocation);virtual;
+          procedure g_copyvaluepara_openarray(list : TAsmList;const ref:treference;const lenloc:tlocation;arrdef: tarraydef;destreg:tregister);virtual;abstract;
+          procedure g_releasevaluepara_openarray(list : TAsmList;arrdef: tarraydef;const l:tlocation);virtual;abstract;
 
           {# Emits instructions when compilation is done in profile
              mode (this is set as a command line option). The default
@@ -430,15 +430,21 @@ unit hlcgobj;
 //          procedure location_force_mmregscalar(list:TAsmList;var l: tlocation;size:tdef;maybeconst:boolean);virtual;abstract;
 //          procedure location_force_mmreg(list:TAsmList;var l: tlocation;size:tdef;maybeconst:boolean);virtual;abstract;
 
+          { Retrieve the location of the data pointed to in location l, when the location is
+            a register it is expected to contain the address of the data }
+          procedure location_get_data_ref(list:TAsmList;def: tdef; const l:tlocation;var ref:treference;loadref:boolean; alignment: longint);virtual;
+
           procedure maketojumpbool(list:TAsmList; p : tnode);virtual;
 
           procedure gen_proc_symbol(list:TAsmList);virtual;
           procedure gen_proc_symbol_end(list:TAsmList);virtual;
 
           procedure gen_load_para_value(list:TAsmList);virtual;
-
-         private
+         protected
+          { helpers called by gen_load_para_value }
+          procedure g_copyvalueparas(p:TObject;arg:pointer);virtual;
           procedure gen_loadfpu_loc_cgpara(list: TAsmList; size: tdef; const l: tlocation;const cgpara: tcgpara;locintsize: longint);virtual;
+          procedure init_paras(p:TObject;arg:pointer);
          protected
           { Some targets have to put "something" in the function result
             location if it's not initialised by the Pascal code, e.g.
@@ -1727,6 +1733,33 @@ implementation
       end;
     end;
 
+    procedure thlcgobj.location_get_data_ref(list: TAsmList; def: tdef; const l: tlocation; var ref: treference; loadref: boolean; alignment: longint);
+      begin
+        case l.loc of
+          LOC_REGISTER,
+          LOC_CREGISTER :
+            begin
+              if not loadref then
+                internalerror(200410231);
+              reference_reset_base(ref,l.register,0,alignment);
+            end;
+          LOC_REFERENCE,
+          LOC_CREFERENCE :
+            begin
+              if loadref then
+                begin
+                  reference_reset_base(ref,cg.getaddressregister(list),0,alignment);
+                  { it's a pointer to def }
+                  hlcg.a_load_ref_reg(list,voidpointertype,voidpointertype,l.reference,ref.base);
+                end
+              else
+                ref:=l.reference;
+            end;
+          else
+            internalerror(200309181);
+        end;
+      end;
+
   procedure thlcgobj.maketojumpbool(list: TAsmList; p: tnode);
   {
     produces jumps to true respectively false labels using boolean expressions
@@ -1856,7 +1889,7 @@ implementation
 
   { generates the code for incrementing the reference count of parameters and
     initialize out parameters }
-  procedure init_paras(p:TObject;arg:pointer);
+  procedure thlcgobj.init_paras(p:TObject;arg:pointer);
     var
       href : treference;
       tmpreg : tregister;
@@ -1883,7 +1916,7 @@ implementation
                  if not((tparavarsym(p).vardef.typ=variantdef) and
                    paramanager.push_addr_param(tparavarsym(p).varspez,tparavarsym(p).vardef,current_procinfo.procdef.proccalloption)) then
                    begin
-                     location_get_data_ref(list,tparavarsym(p).initialloc,href,is_open_array(tparavarsym(p).vardef),sizeof(pint));
+                     location_get_data_ref(list,tparavarsym(p).vardef,tparavarsym(p).initialloc,href,is_open_array(tparavarsym(p).vardef),sizeof(pint));
                      hlcg.g_incrrefcount(list,tparavarsym(p).vardef,href);
                    end;
                end;
@@ -1958,7 +1991,7 @@ implementation
       { generate copies of call by value parameters, must be done before
         the initialization and body is parsed because the refcounts are
         incremented using the local copies }
-//      current_procinfo.procdef.parast.SymList.ForEachCall(@copyvalueparas,list);
+      current_procinfo.procdef.parast.SymList.ForEachCall(@g_copyvalueparas,list);
 
       if not(po_assembler in current_procinfo.procdef.procoptions) then
         begin
@@ -1979,6 +2012,86 @@ implementation
         end;
     end;
 
+  procedure thlcgobj.g_copyvalueparas(p: TObject; arg: pointer);
+    var
+      href : treference;
+      hreg : tregister;
+      list : TAsmList;
+      hsym : tparavarsym;
+      l    : longint;
+      highloc,
+      localcopyloc : tlocation;
+    begin
+      list:=TAsmList(arg);
+      if (tsym(p).typ=paravarsym) and
+         (tparavarsym(p).varspez=vs_value) and
+        (paramanager.push_addr_param(tparavarsym(p).varspez,tparavarsym(p).vardef,current_procinfo.procdef.proccalloption)) then
+        begin
+          { we have no idea about the alignment at the caller side }
+          location_get_data_ref(list,tparavarsym(p).vardef,tparavarsym(p).initialloc,href,true,1);
+          if is_open_array(tparavarsym(p).vardef) or
+             is_array_of_const(tparavarsym(p).vardef) then
+            begin
+              { cdecl functions don't have a high pointer so it is not possible to generate
+                a local copy }
+              if not(current_procinfo.procdef.proccalloption in cdecl_pocalls) then
+                begin
+                  if paramanager.push_high_param(tparavarsym(p).varspez,tparavarsym(p).vardef,current_procinfo.procdef.proccalloption) then
+                    begin
+                      hsym:=tparavarsym(tsym(p).owner.Find('high'+tsym(p).name));
+                      if not assigned(hsym) then
+                        internalerror(2011020506);
+                      highloc:=hsym.initialloc
+                    end
+                  else
+                    highloc.loc:=LOC_INVALID;
+                  hreg:=cg.getaddressregister(list);
+                  if not is_packed_array(tparavarsym(p).vardef) then
+                    g_copyvaluepara_openarray(list,href,highloc,tarraydef(tparavarsym(p).vardef),hreg)
+                  else
+                    internalerror(2011020507);
+//                      cg.g_copyvaluepara_packedopenarray(list,href,hsym.intialloc,tarraydef(tparavarsym(p).vardef).elepackedbitsize,hreg);
+                  a_load_reg_loc(list,tparavarsym(p).vardef,tparavarsym(p).vardef,hreg,tparavarsym(p).initialloc);
+                end;
+            end
+          else
+            begin
+              { Allocate space for the local copy }
+              l:=tparavarsym(p).getsize;
+              localcopyloc.loc:=LOC_REFERENCE;
+              localcopyloc.size:=int_cgsize(l);
+              tg.GetLocal(list,l,tparavarsym(p).vardef,localcopyloc.reference);
+              { Copy data }
+              if is_shortstring(tparavarsym(p).vardef) then
+                begin
+                  { this code is only executed before the code for the body and the entry/exit code is generated
+                    so we're allowed to include pi_do_call here; after pass1 is run, this isn't allowed anymore
+                  }
+                  include(current_procinfo.flags,pi_do_call);
+                  g_copyshortstring(list,href,localcopyloc.reference,tstringdef(tparavarsym(p).vardef))
+                end
+              else if tparavarsym(p).vardef.typ=variantdef then
+                begin
+                  { this code is only executed before the code for the body and the entry/exit code is generated
+                    so we're allowed to include pi_do_call here; after pass1 is run, this isn't allowed anymore
+                  }
+                  include(current_procinfo.flags,pi_do_call);
+                  g_copyvariant(list,href,localcopyloc.reference,tvariantdef(tparavarsym(p).vardef))
+                end
+              else
+                begin
+                  { pass proper alignment info }
+                  localcopyloc.reference.alignment:=tparavarsym(p).vardef.alignment;
+                  g_concatcopy(list,tparavarsym(p).vardef,href,localcopyloc.reference);
+                end;
+              { update localloc of varsym }
+              tg.Ungetlocal(list,tparavarsym(p).localloc.reference);
+              tparavarsym(p).localloc:=localcopyloc;
+              tparavarsym(p).initialloc:=localcopyloc;
+            end;
+        end;
+    end;
+
   procedure thlcgobj.gen_loadfpu_loc_cgpara(list: TAsmList; size: tdef; const l: tlocation; const cgpara: tcgpara; locintsize: longint);
     begin
       case l.loc of

compiler/jvm/cpunode.pas

@@ -32,9 +32,8 @@ implementation
   uses
     ncgbas,ncgflw,ncgcnv,ncgld,ncgmem,ncgcon,ncgset,
     ncgadd, ncgcal,ncgmat,ncginl,
-    njvmadd,njvmcal,njvmmat,njvmcnv,njvmcon,njvminl,njvmmem,njvmflw
-{    ncpuadd,ncpucall,ncpumat,ncpuinln,ncpucnv,ncpuset, }
-    { this not really a node }
-{    rgcpu},tgcpu,njvmutil;
+    njvmadd,njvmcal,njvmmat,njvmcnv,njvmcon,njvminl,njvmmem,njvmflw,njvmld
+    { these are not really nodes }
+    ,rgcpu,tgcpu,njvmutil;
 
 end.

compiler/jvm/cpupara.pas

@@ -35,7 +35,9 @@ interface
       { TJVMParaManager }
 
       TJVMParaManager=class(TParaManager)
+        function  push_high_param(varspez:tvarspez;def : tdef;calloption : tproccalloption) : boolean;override;
         function  push_addr_param(varspez:tvarspez;def : tdef;calloption : tproccalloption) : boolean;override;
+        function  push_size(varspez: tvarspez; def: tdef; calloption: tproccalloption): longint;override;
         {Returns a structure giving the information on the storage of the parameter
         (which must be an integer parameter)
         @param(nr Parameter number of routine, starting from 1)}
@@ -55,7 +57,7 @@ implementation
 
     uses
       cutils,verbose,systems,
-      defutil,
+      defutil,jvmdef,
       cgobj;
 
 
@@ -65,12 +67,31 @@ implementation
         internalerror(2010121001);
       end;
 
+    function TJVMParaManager.push_high_param(varspez: tvarspez; def: tdef; calloption: tproccalloption): boolean;
+      begin
+        { we don't need a separate high parameter, since all arrays in Java
+          have an implicit associated length }
+        if not is_open_array(def) then
+          result:=inherited
+        else
+          result:=false;
+      end;
+
 
     { true if a parameter is too large to copy and only the address is pushed }
     function TJVMParaManager.push_addr_param(varspez:tvarspez;def : tdef;calloption : tproccalloption) : boolean;
       begin
-        { call by reference does not exist in Java bytecode }
-        result:=false;
+        result:=jvmimplicitpointertype(def);
+      end;
+
+
+    function TJVMParaManager.push_size(varspez: tvarspez; def: tdef; calloption: tproccalloption): longint;
+      begin
+        { all aggregate types are emulated using indirect pointer types }
+        if def.typ in [arraydef,recorddef,setdef,stringdef] then
+          result:=4
+        else
+          result:=inherited;
       end;
 
 

compiler/jvm/hlcgcpu.pas

@@ -73,6 +73,8 @@ uses
 
       procedure a_jmp_always(list : TAsmList;l: tasmlabel); override;
 
+      procedure g_concatcopy(list : TAsmList;size: tdef; const source,dest : treference);override;
+
       procedure a_loadfpu_ref_ref(list: TAsmList; fromsize, tosize: tdef; const ref1, ref2: treference); override;
       procedure a_loadfpu_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; reg: tregister); override;
       procedure a_loadfpu_reg_ref(list: TAsmList; fromsize, tosize: tdef; reg: tregister; const ref: treference); override;
@@ -89,6 +91,10 @@ uses
       procedure g_initialize(list : TAsmList;t : tdef;const ref : treference);override;
       procedure g_finalize(list : TAsmList;t : tdef;const ref : treference);override;
 
+      procedure location_get_data_ref(list:TAsmList;def: tdef; const l:tlocation;var ref:treference;loadref:boolean; alignment: longint);override;
+      procedure g_copyvaluepara_openarray(list: TAsmList; const ref: treference; const lenloc: tlocation; arrdef: tarraydef; destreg: tregister); override;
+      procedure g_releasevaluepara_openarray(list: TAsmList; arrdef: tarraydef; const l: tlocation); override;
+
       { JVM-specific routines }
 
       procedure a_load_stack_reg(list : TAsmList;size: tdef;reg: tregister);
@@ -118,6 +124,9 @@ uses
         evaluation stack, and creates a new array of type arrdef with these
         dimensions }
       procedure g_newarray(list : TAsmList; arrdef: tdef; initdim: longint);
+      { gets the length of the array whose reference is stored in arrloc,
+        and puts it on the evaluation stack }
+      procedure g_getarraylen(list : TAsmList; const arrloc: tlocation);
 
       { this routine expects that all values are already massaged into the
         required form (sign bits xor'ed for gt/lt comparisons for OS_32/OS_64,
@@ -159,6 +168,10 @@ uses
       procedure maybepreparedivu32(list: TAsmList; var op: topcg; size: tdef; out isdivu32: boolean);
       { common implementation of a_call_* }
       procedure a_call_name_intern(list : TAsmList;pd : tprocdef;const s : string; inheritedcall: boolean);
+
+      { concatcopy helpers }
+      procedure concatcopy_normal_array(list: TAsmList; size: tdef; const source, dest: treference);
+
     end;
 
   procedure create_hlcodegen;
@@ -175,8 +188,8 @@ implementation
     verbose,cutils,globals,
     defutil,
     aasmtai,aasmcpu,
-    symconst,jvmdef,
-    procinfo,cgcpu;
+    symconst,symtable,symsym,jvmdef,
+    procinfo,cgcpu,tgobj;
 
   const
     TOpCG2IAsmOp : array[topcg] of TAsmOp=(                       { not = xor -1 }
@@ -595,6 +608,46 @@ implementation
         end;
     end;
 
+  procedure thlcgjvm.g_getarraylen(list: TAsmList; const arrloc: tlocation);
+    var
+      nillab,endlab: tasmlabel;
+    begin
+      { inline because we have to use the arraylength opcode, which
+        cannot be represented directly in Pascal. Even though the JVM
+        supports allocated arrays with length=0, we still also have to
+        check for nil pointers because even if FPC always generates
+        allocated empty arrays under all circumstances, external Java
+        code could pass in nil pointers.
+
+        Note that this means that assigned(arr) can be different from
+        length(arr)<>0 for dynamic arrays when targeting the JVM.
+      }
+      current_asmdata.getjumplabel(nillab);
+      current_asmdata.getjumplabel(endlab);
+
+      { if assigned(arr) ... }
+      a_load_loc_stack(list,java_jlobject,arrloc);
+      list.concat(taicpu.op_none(a_dup));
+      incstack(list,1);
+      list.concat(taicpu.op_none(a_aconst_null));
+      incstack(list,1);
+      list.concat(taicpu.op_sym(a_if_acmpeq,nillab));
+      decstack(list,2);
+
+      { ... then result:=arraylength(arr) ... }
+      list.concat(taicpu.op_none(a_arraylength));
+      a_jmp_always(list,endlab);
+
+      { ... else result:=0 }
+      a_label(list,nillab);
+      list.concat(taicpu.op_none(a_pop));
+      decstack(list,1);
+      list.concat(taicpu.op_none(a_iconst_0));
+      incstack(list,1);
+
+      a_label(list,endlab);
+    end;
+
     procedure thlcgjvm.a_cmp_stack_label(list: TAsmlist; size: tdef; cmp_op: topcmp; lab: tasmlabel);
       const
         opcmp2icmp: array[topcmp] of tasmop = (A_None,
@@ -859,7 +912,12 @@ implementation
 
   procedure thlcgjvm.a_loadaddr_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; r: tregister);
     begin
-      internalerror(2010120534);
+      { only allowed for types that are not implicit pointers in Pascal (in
+        that case, ref contains a pointer to the actual data and we simply
+        return that pointer) }
+      if not jvmimplicitpointertype(fromsize) then
+        internalerror(2010120534);
+      a_load_ref_reg(list,java_jlobject,java_jlobject,ref,r);
     end;
 
   procedure thlcgjvm.a_op_const_reg(list: TAsmList; Op: TOpCG; size: tdef; a: Aint; reg: TRegister);
@@ -957,6 +1015,115 @@ implementation
       list.concat(taicpu.op_sym(a_goto,current_asmdata.RefAsmSymbol(l.name)));
     end;
 
+  procedure thlcgjvm.concatcopy_normal_array(list: TAsmList; size: tdef; const source, dest: treference);
+    var
+      procname: string;
+      eledef: tdef;
+      pd: tprocdef;
+      srsym: tsym;
+      ndim: longint;
+    begin
+      { load copy helper parameters on the stack }
+      a_load_ref_stack(list,java_jlobject,source,prepare_stack_for_ref(list,source,false));
+      a_load_ref_stack(list,java_jlobject,dest,prepare_stack_for_ref(list,dest,false));
+      { call copy helper }
+      eledef:=tarraydef(size).elementdef;
+      ndim:=1;
+      case eledef.typ of
+        orddef:
+          begin
+            case torddef(eledef).ordtype of
+              pasbool8,s8bit,u8bit,bool8bit,uchar:
+                procname:='FPC_COPY_JBYTE_ARRAY';
+              s16bit,u16bit,bool16bit,pasbool16:
+                procname:='FPC_COPY_JSHORT_ARRAY';
+              uwidechar:
+                procname:='FPC_COPY_JCHAR_ARRAY';
+              s32bit,u32bit,bool32bit,pasbool32:
+                procname:='FPC_COPY_JINT_ARRAY';
+              s64bit,u64bit,bool64bit,pasbool64,scurrency:
+                procname:='FPC_COPY_JLONG_ARRAY';
+              else
+                internalerror(2011020504);
+            end;
+          end;
+        floatdef:
+          case tfloatdef(eledef).floattype of
+            s32real:
+              procname:='FPC_COPY_JFLOAT_ARRAY';
+            s64real:
+              procname:='FPC_COPY_JDOUBLE_ARRAY';
+          end;
+        arraydef:
+          begin
+            { call fpc_setlength_dynarr_multidim with deepcopy=true, and extra
+              parameters }
+            while (eledef.typ=arraydef) and
+                  not is_dynamic_array(eledef) do
+              begin
+                eledef:=tarraydef(eledef).elementdef;
+                inc(ndim)
+              end;
+            if (ndim=1) then
+              procname:='FPC_COPY_JOBJECT_ARRAY'
+            else
+              begin
+                { deepcopy=true }
+                a_load_const_stack(list,pasbool8type,1,R_INTREGISTER);
+                { ndim }
+                a_load_const_stack(list,s32inttype,ndim,R_INTREGISTER);
+                { eletype }
+                a_load_const_stack(list,cwidechartype,ord(jvmarrtype_setlength(eledef)),R_INTREGISTER);
+                procname:='FPC_SETLENGTH_DYNARR_MULTIDIM';
+              end;
+          end;
+        setdef,
+        recorddef,
+        stringdef,
+        variantdef:
+          begin
+            { todo: make a (recursive for records) deep copy, not sure yet how... }
+            internalerror(2011020505);
+          end;
+        else
+          procname:='FPC_COPY_JOBJECT_ARRAY';
+      end;
+     srsym:=tsym(systemunit.find(procname));
+     if not assigned(srsym) or
+        (srsym.typ<>procsym) then
+       Message1(cg_f_unknown_compilerproc,procname);
+     pd:=tprocdef(tprocsym(srsym).procdeflist[0]);
+     a_call_name(list,pd,pd.mangledname,false);
+     if ndim=1 then
+       decstack(list,2)
+     else
+       begin
+         decstack(list,4);
+         { pop return value, must be the same as dest }
+         list.concat(taicpu.op_none(a_pop));
+         decstack(list,1);
+       end;
+    end;
+
+  procedure thlcgjvm.g_concatcopy(list: TAsmList; size: tdef; const source, dest: treference);
+    var
+      handled: boolean;
+    begin
+      handled:=false;
+      case size.typ of
+        arraydef:
+          begin
+            if not is_dynamic_array(size) then
+              begin
+                concatcopy_normal_array(list,size,source,dest);
+                handled:=true;
+              end;
+          end;
+      end;
+      if not handled then
+        inherited;
+    end;
+
   procedure thlcgjvm.a_loadfpu_ref_ref(list: TAsmList; fromsize, tosize: tdef; const ref1, ref2: treference);
     var
       dstack_slots: longint;
@@ -1077,6 +1244,90 @@ implementation
       // do nothing
     end;
 
+  procedure thlcgjvm.location_get_data_ref(list: TAsmList; def: tdef; const l: tlocation; var ref: treference; loadref: boolean; alignment: longint);
+    var
+      tmploc: tlocation;
+    begin
+      { This routine is a combination of a generalised a_loadaddr_ref_reg()
+        that also works for addresses in registers (in case loadref is false)
+        and of a_load_ref_reg (in case loadref is true). It is used for
+        a) getting the address of managed types
+        b) getting to the actual data of value types that are passed by
+           reference by the compiler (and then get a local copy at the caller
+           side). Normally, depending on whether this reference is passed in a
+           register or reference, we either need a reference with that register
+           as base or load the address in that reference and use that as a new
+           base.
+
+        Since the JVM cannot take the address of anything, all
+        "pass-by-reference" value parameters (which are always aggregate types)
+        are already simply the implicit pointer to the data (since arrays,
+        records, etc are already internally implicit pointers). This means
+        that if "loadref" is true, we must simply return this implicit pointer.
+        If it is false, we are supposed the take the address of this implicit
+        pointer, which is not possible.
+
+        However, managed types are also implicit pointers in Pascal, so in that
+        case "taking the address" again consists of simply returning the
+        implicit pointer/current value.
+      }
+      if not loadref then
+        begin
+          if not is_managed_type(def) then
+            internalerror(2011020601);
+        end
+      else
+        begin
+          if not jvmimplicitpointertype(def) then
+            internalerror(2011020602);
+        end;
+      case l.loc of
+        LOC_REGISTER,
+        LOC_CREGISTER :
+          begin
+            { the implicit pointer is in a register and has to be in a
+              reference -> create a reference and put it there }
+            tmploc:=l;
+            location_force_mem(list,tmploc,java_jlobject);
+            ref:=tmploc.reference;
+          end;
+        LOC_REFERENCE,
+        LOC_CREFERENCE :
+          begin
+            ref:=l.reference;
+          end;
+        else
+          internalerror(2011020603);
+      end;
+    end;
+
+  procedure thlcgjvm.g_copyvaluepara_openarray(list: TAsmList; const ref: treference; const lenloc: tlocation; arrdef: tarraydef; destreg: tregister);
+    var
+      localref: treference;
+      arrloc: tlocation;
+      stackslots: longint;
+    begin
+      { temporary reference for passing to concatcopy }
+      tg.gethltemp(list,java_jlobject,java_jlobject.size,tt_persistent,localref);
+      stackslots:=prepare_stack_for_ref(list,localref,false);
+      { create the local copy of the array (lenloc is invalid, get length
+        directly from the array) }
+      location_reset_ref(arrloc,LOC_REFERENCE,OS_ADDR,sizeof(pint));
+      arrloc.reference:=ref;
+      g_getarraylen(list,arrloc);
+      g_newarray(list,arrdef,1);
+      a_load_stack_ref(list,java_jlobject,localref,stackslots);
+      { copy the source array to the destination }
+      g_concatcopy(list,arrdef,ref,localref);
+      { and put the array pointer in the register as expected by the caller }
+      a_load_ref_reg(list,java_jlobject,java_jlobject,localref,destreg);
+    end;
+
+  procedure thlcgjvm.g_releasevaluepara_openarray(list: TAsmList; arrdef: tarraydef; const l: tlocation);
+    begin
+      // do nothing, long live garbage collection!
+    end;
+
   procedure thlcgjvm.a_load_stack_reg(list: TAsmList; size: tdef; reg: tregister);
     var
       opc: tasmop;
@@ -1084,6 +1335,9 @@ implementation
     begin
       opc:=loadstoreopc(size,false,false,finishandval);
       list.concat(taicpu.op_reg(opc,reg));
+      { avoid problems with getting the size of an open array etc }
+      if jvmimplicitpointertype(size) then
+        size:=java_jlobject;
       decstack(list,1+ord(size.size>4));
     end;
 
@@ -1100,6 +1354,9 @@ implementation
         list.concat(taicpu.op_ref(opc,ref))
       else
         list.concat(taicpu.op_none(opc));
+      { avoid problems with getting the size of an open array etc }
+      if jvmimplicitpointertype(size) then
+        size:=java_jlobject;
       decstack(list,1+ord(size.size>4)+extra_slots);
     end;
 
@@ -1112,6 +1369,9 @@ implementation
       list.concat(taicpu.op_reg(opc,reg));
       if finishandval<>-1 then
         a_op_const_stack(list,OP_AND,size,finishandval);
+      { avoid problems with getting the size of an open array etc }
+      if jvmimplicitpointertype(size) then
+        size:=java_jlobject;
       incstack(list,1+ord(size.size>4));
     end;
 
@@ -1130,6 +1390,9 @@ implementation
         list.concat(taicpu.op_none(opc));
       if finishandval<>-1 then
         a_op_const_stack(list,OP_AND,size,finishandval);
+      { avoid problems with getting the size of an open array etc }
+      if jvmimplicitpointertype(size) then
+        size:=java_jlobject;
       incstack(list,1+ord(size.size>4)-extra_slots);
     end;
 

compiler/jvm/njvminl.pas

@@ -89,7 +89,8 @@ implementation
     function tjvminlinenode.typecheck_length(var handled: boolean): tnode;
       begin
         typecheckpass(left);
-        if is_dynamic_array(left.resultdef) then
+        if is_dynamic_array(left.resultdef) or
+           is_open_array(left.resultdef) then
           begin
             resultdef:=s32inttype;
             result:=nil;
@@ -101,7 +102,8 @@ implementation
     function tjvminlinenode.typecheck_high(var handled: boolean): tnode;
       begin
         typecheckpass(left);
-        if is_dynamic_array(left.resultdef) then
+        if is_dynamic_array(left.resultdef) or
+           is_open_array(left.resultdef) then
           begin
             { replace with pred(length(arr)) }
             result:=cinlinenode.create(in_pred_x,false,
@@ -247,6 +249,18 @@ implementation
             eledef:=tarraydef(eledef).elementdef;
             ppn:=tcallparanode(ppn).right;
           end;
+        { in case it's a dynamic array of static arrays, we must also allocate
+          the static arrays! }
+        while (eledef.typ=arraydef) and
+              not is_dynamic_array(eledef) do
+          begin
+            inc(ndims);
+            tcallparanode(ppn).right:=
+              ccallparanode.create(
+                genintconstnode(tarraydef(eledef).elecount),nil);
+            ppn:=tcallparanode(ppn).right;
+            eledef:=tarraydef(eledef).elementdef;
+          end;
         { prepend type parameter for the array }
         newparas:=ccallparanode.create(ctypenode.create(left.resultdef),newparas);
         ttypenode(tcallparanode(newparas).left).allowed:=true;
@@ -268,8 +282,11 @@ implementation
           assignmenttarget:=tcallparanode(left).left.getcopy;
         newparas:=left;
         left:=nil;
-        { if more than 1 dimension, typecast to generic array of tobject }
-        if ndims>1 then
+        { if more than 1 dimension, or if 1 dimention of a non-primitive type,
+          typecast to generic array of tobject }
+        setlenroutine:=jvmarrtype(eledef,primitive);
+        if (ndims>1) or
+           not primitive then
           begin
             objarraydef:=search_system_type('TJOBJECTARRAY').typedef;
             tcallparanode(newparas).left:=ctypeconvnode.create_explicit(tcallparanode(newparas).left,objarraydef);
@@ -294,7 +311,6 @@ implementation
           end
         else
           begin
-            setlenroutine:=jvmarrtype(eledef,primitive);
             if not primitive then
               setlenroutine:='OBJECT'
             else
@@ -318,43 +334,14 @@ implementation
 
 
     procedure tjvminlinenode.second_length;
-      var
-        nillab,endlab: tasmlabel;
       begin
-        if is_dynamic_array(left.resultdef) then
+        if is_dynamic_array(left.resultdef) or
+           is_open_array(left.resultdef) then
           begin
-            { inline because we have to use the arraylength opcode, which
-              cannot be represented directly in Pascal. Even though the JVM
-              supports allocated arrays with length=0, we still also have to
-              check for nil pointers because even if FPC always generates
-              allocated empty arrays under all circumstances, external Java
-              code could pass in nil pointers.
-
-              Note that this means that assigned(arr) can be different from
-              length(arr)<>0 when targeting the JVM.
-            }
-
-            { if assigned(arr) then result:=arraylength(arr) else result:=0 }
             location_reset(location,LOC_REGISTER,OS_S32);
             location.register:=hlcg.getintregister(current_asmdata.CurrAsmList,s32inttype);
             secondpass(left);
-            current_asmdata.getjumplabel(nillab);
-            current_asmdata.getjumplabel(endlab);
-            thlcgjvm(hlcg).a_load_loc_stack(current_asmdata.CurrAsmList,left.resultdef,left.location);
-            current_asmdata.CurrAsmList.concat(taicpu.op_none(a_dup));
-            thlcgjvm(hlcg).incstack(current_asmdata.CurrAsmList,1);
-            current_asmdata.CurrAsmList.concat(taicpu.op_none(a_aconst_null));
-            thlcgjvm(hlcg).incstack(current_asmdata.CurrAsmList,1);
-            current_asmdata.CurrAsmList.concat(taicpu.op_sym(a_if_acmpeq,nillab));
-            thlcgjvm(hlcg).decstack(current_asmdata.CurrAsmList,2);
-            current_asmdata.CurrAsmList.concat(taicpu.op_none(a_arraylength));
-            hlcg.a_jmp_always(current_asmdata.CurrAsmList,endlab);
-            hlcg.a_label(current_asmdata.CurrAsmList,nillab);
-            current_asmdata.CurrAsmList.concat(taicpu.op_none(a_pop));
-            thlcgjvm(hlcg).decstack(current_asmdata.CurrAsmList,1);
-            current_asmdata.CurrAsmList.concat(taicpu.op_none(a_iconst_0));
-            thlcgjvm(hlcg).incstack(current_asmdata.CurrAsmList,1);
-            hlcg.a_label(current_asmdata.CurrAsmList,endlab);
+            thlcgjvm(hlcg).g_getarraylen(current_asmdata.CurrAsmList,left.location);
             thlcgjvm(hlcg).a_load_stack_reg(current_asmdata.CurrAsmList,resultdef,location.register);
           end
         else

compiler/jvm/njvmld.pas

@@ -0,0 +1,54 @@
+{
+    Copyright (c) 2011 by Jonas Maebe
+
+    Generate JVM assembler for nodes that handle loads and assignments
+
+    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.
+
+ ****************************************************************************
+}
+unit njvmld;
+
+{$I fpcdefs.inc}
+
+interface
+
+uses
+  node, ncgld;
+
+type
+  tjvmloadnode = class(tcgloadnode)
+    function is_addr_param_load: boolean; override;
+  end;
+
+implementation
+
+uses
+  nld,
+  symsym,
+  jvmdef;
+
+function tjvmloadnode.is_addr_param_load: boolean;
+  begin
+    result:=
+      inherited and
+      not jvmimplicitpointertype(tparavarsym(symtableentry).vardef);
+  end;
+
+
+begin
+  cloadnode:=tjvmloadnode;
+end.
+

compiler/jvm/njvmmem.pas

@@ -42,7 +42,7 @@ implementation
       cutils,verbose,
       symdef,defutil,
       aasmdata,pass_2,
-      cgutils,hlcgobj;
+      cgutils,hlcgobj,hlcgcpu;
 
 {*****************************************************************************
                              TJVMVECNODE
@@ -65,7 +65,9 @@ implementation
           location_reset_ref(location,LOC_CREFERENCE,newsize,left.location.reference.alignment)
         else
           location_reset_ref(location,LOC_REFERENCE,newsize,left.location.reference.alignment);
-        hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,left.resultdef,true);
+        { don't use left.resultdef, because it may be an open or regular array,
+          and then asking for the size doesn't make any sense }
+        hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,java_jlobject,java_jlobject,true);
         location.reference.base:=left.location.register;
         secondpass(right);
         { simplify index location if necessary, since array references support
@@ -74,6 +76,22 @@ implementation
            (right.location.reference.arrayreftype<>art_none) then
           hlcg.location_force_reg(current_asmdata.CurrAsmList,right.location,right.resultdef,right.resultdef,true);
 
+        { adjust index if necessary }
+        if not is_special_array(left.resultdef) and
+           (tarraydef(left.resultdef).lowrange<>0) and
+           (right.location.loc<>LOC_CONSTANT) then
+          begin
+            thlcgjvm(hlcg).a_load_loc_stack(current_asmdata.CurrAsmList,right.resultdef,right.location);
+            thlcgjvm(hlcg).a_op_const_stack(current_asmdata.CurrAsmList,OP_SUB,right.resultdef,tarraydef(left.resultdef).lowrange);
+            if right.location.loc<>LOC_REGISTER then
+              begin
+                location_reset(right.location,LOC_REGISTER,def_cgsize(right.resultdef));
+                right.location.register:=hlcg.getintregister(current_asmdata.CurrAsmList,right.resultdef);
+              end;
+            thlcgjvm(hlcg).a_load_stack_reg(current_asmdata.CurrAsmList,right.resultdef,right.location.register);
+          end;
+
+        { create array reference }
         case right.location.loc of
           LOC_REGISTER,LOC_CREGISTER:
             begin
@@ -90,7 +108,7 @@ implementation
           LOC_CONSTANT:
             begin
               location.reference.arrayreftype:=art_indexconst;
-              location.reference.indexoffset:=right.location.value;
+              location.reference.indexoffset:=right.location.value-tarraydef(left.resultdef).lowrange;
             end
           else
             internalerror(2011012002);

compiler/jvm/tgcpu.pas

@@ -31,6 +31,7 @@ unit tgcpu;
     uses
        globtype,
        aasmdata,
+       cgutils,
        symtype,tgobj;
 
     type
@@ -39,19 +40,57 @@ unit tgcpu;
 
        ttgjvm = class(ttgobj)
         protected
+         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
          procedure setfirsttemp(l : longint); override;
+         procedure getlocal(list: TAsmList; size: longint; alignment: shortint; def: tdef; var ref: treference); override;
+         procedure gethltemp(list: TAsmList; def: tdef; forcesize: aint; temptype: ttemptype; out ref: treference); override;
        end;
 
   implementation
 
     uses
-       verbose;
+       verbose,
+       cgbase,
+       symconst,defutil,
+       hlcgobj,hlcgcpu,
+       symdef;
 
 
     { ttgjvm }
 
+    function ttgjvm.getifspecialtemp(list: TAsmList; def: tdef; forcesize: aint; temptype: ttemptype; out ref: treference): boolean;
+      var
+        eledef: tdef;
+        ndim: longint;
+      begin
+        result:=false;
+        case def.typ of
+          arraydef:
+            begin
+              if not is_dynamic_array(def) then
+                begin
+                  { allocate an array of the right size }
+                  gettemp(list,java_jlobject.size,java_jlobject.alignment,temptype,ref);
+                  ndim:=0;
+                  eledef:=def;
+                  repeat
+                    thlcgjvm(hlcg).a_load_const_stack(list,s32inttype,tarraydef(eledef).elecount,R_INTREGISTER);
+                    eledef:=tarraydef(eledef).elementdef;
+                    inc(ndim);
+                  until (eledef.typ<>arraydef) or
+                        is_dynamic_array(eledef);
+                  eledef:=tarraydef(def).elementdef;
+                  thlcgjvm(hlcg).g_newarray(list,def,ndim);
+                  thlcgjvm(hlcg).a_load_stack_ref(list,java_jlobject,ref,0);
+                  result:=true;
+                end;
+            end;
+        end;
+      end;
+
+
     function ttgjvm.alloctemp(list: TAsmList; size, alignment: longint; temptype: ttemptype; def: tdef): longint;
       begin
         { the JVM only supports 1 slot (= 4 bytes in FPC) and 2 slot (= 8 bytes in
@@ -67,12 +106,28 @@ unit tgcpu;
         result:=inherited alloctemp(list, size shr 2, 1, temptype, nil);
       end;
 
+
     procedure ttgjvm.setfirsttemp(l: longint);
       begin
         firsttemp:=l;
         lasttemp:=l;
       end;
 
+
+    procedure ttgjvm.getlocal(list: TAsmList; size: longint; alignment: shortint; def: tdef; var ref: treference);
+      begin
+        if not getifspecialtemp(list,def,size,tt_persistent,ref) then
+          inherited;
+      end;
+
+
+    procedure ttgjvm.gethltemp(list: TAsmList; def: tdef; forcesize: aint; temptype: ttemptype; out ref: treference);
+      begin
+        if not getifspecialtemp(list,def,forcesize,temptype,ref) then
+          inherited;
+      end;
+
+
 begin
   tgobjclass:=ttgjvm;
 end.

compiler/jvmdef.pas

@@ -57,6 +57,10 @@ interface
     function jvmarrtype(def: tdef; out primitivetype: boolean): string;
     function jvmarrtype_setlength(def: tdef): char;
 
+    { returns whether a def is emulated using an implicit pointer type on the
+      JVM target (e.g., records, regular arrays, ...) }
+    function jvmimplicitpointertype(def: tdef): boolean;
+
 implementation
 
   uses
@@ -171,7 +175,6 @@ implementation
           arraydef :
             begin
               if is_array_of_const(def) or
-                 is_open_array(def) or
                  is_packed_array(def) then
                 result:=false
               else
@@ -281,8 +284,15 @@ implementation
                 internalerror(2011012206);
               end;
             primitivetype:=true;
+          end
+        else if (result[1]='L') then
+          begin
+            { in case of a class reference, strip the leading 'L' and the
+              trailing ';' }
+            setlength(result,length(result)-1);
+            delete(result,1,1);
           end;
-        { in other cases, use the actual reference type }
+        { for arrays, use the actual reference type }
       end;
 
 
@@ -299,6 +309,27 @@ implementation
           result:='A';
       end;
 
+    function jvmimplicitpointertype(def: tdef): boolean;
+      begin
+        case def.typ of
+          arraydef:
+            result:=(tarraydef(def).highrange>=tarraydef(def).lowrange) or
+                is_open_array(def) or
+                is_array_of_const(def) or
+                is_array_constructor(def);
+          recorddef:
+            result:=true;
+          objectdef:
+            result:=is_object(def);
+          setdef:
+            result:=not is_smallset(def);
+          stringdef :
+            result:=tstringdef(def).stringtype in [st_shortstring,st_longstring];
+          else
+            result:=false;
+        end;
+      end;
+
 
 {******************************************************************
                     jvm type validity checking

compiler/ncgcal.pas

@@ -130,7 +130,7 @@ implementation
       begin
         if not(left.location.loc in [LOC_CREFERENCE,LOC_REFERENCE]) then
           internalerror(200304235);
-        cg.a_loadaddr_ref_cgpara(current_asmdata.CurrAsmList,left.location.reference,tempcgpara);
+        hlcg.a_loadaddr_ref_cgpara(current_asmdata.CurrAsmList,left.resultdef,tempcgpara.def,left.location.reference,tempcgpara);
       end;
 
 
@@ -174,7 +174,7 @@ implementation
              if (parasym.varspez=vs_out) and
                 is_managed_type(left.resultdef) then
                begin
-                 location_get_data_ref(current_asmdata.CurrAsmList,left.location,href,false,sizeof(pint));
+                 hlcg.location_get_data_ref(current_asmdata.CurrAsmList,left.resultdef,left.location,href,false,sizeof(pint));
                  if is_open_array(resultdef) then
                    begin
                      if third=nil then

compiler/ncgld.pas

@@ -603,7 +603,7 @@ implementation
               not is_constnode(right) then
             begin
               hlcg.location_force_mem(current_asmdata.CurrAsmList,right.location,right.resultdef);
-              location_get_data_ref(current_asmdata.CurrAsmList,right.location,href,false,sizeof(pint));
+              hlcg.location_get_data_ref(current_asmdata.CurrAsmList,right.resultdef,right.location,href,false,sizeof(pint));
               hlcg.g_incrrefcount(current_asmdata.CurrAsmList,right.resultdef,href);
             end;
            if codegenerror then
@@ -615,7 +615,7 @@ implementation
            { decrement destination reference counter }
            if is_managed_type(left.resultdef) then
              begin
-               location_get_data_ref(current_asmdata.CurrAsmList,left.location,href,false,sizeof(pint));
+               hlcg.location_get_data_ref(current_asmdata.CurrAsmList,left.resultdef,left.location,href,false,sizeof(pint));
                hlcg.g_decrrefcount(current_asmdata.CurrAsmList,left.resultdef,href);
              end;
            if codegenerror then
@@ -628,7 +628,7 @@ implementation
            { decrement destination reference counter }
            if is_managed_type(left.resultdef) then
              begin
-               location_get_data_ref(current_asmdata.CurrAsmList,left.location,href,false,sizeof(pint));
+               hlcg.location_get_data_ref(current_asmdata.CurrAsmList,left.resultdef,left.location,href,false,sizeof(pint));
                hlcg.g_decrrefcount(current_asmdata.CurrAsmList,left.resultdef,href);
              end;
            if codegenerror then
@@ -650,7 +650,7 @@ implementation
               (right.nodetype<>stringconstn) then
              begin
                hlcg.location_force_mem(current_asmdata.CurrAsmList,right.location,right.resultdef);
-               location_get_data_ref(current_asmdata.CurrAsmList,right.location,href,false,sizeof(pint));
+               hlcg.location_get_data_ref(current_asmdata.CurrAsmList,left.resultdef,right.location,href,false,sizeof(pint));
                hlcg.g_incrrefcount(current_asmdata.CurrAsmList,right.resultdef,href);
              end;
 

compiler/ncgutil.pas

@@ -79,9 +79,6 @@ interface
 
     procedure register_maybe_adjust_setbase(list: TAsmList; var l: tlocation; setbase: aint);
 
-    { Retrieve the location of the data pointed to in location l, when the location is
-      a register it is expected to contain the address of the data }
-    procedure location_get_data_ref(list:TAsmList;const l:tlocation;var ref:treference;loadref:boolean; alignment: longint);
 
     function  has_alias_name(pd:tprocdef;const s:string):boolean;
     procedure alloc_proc_symbol(pd: tprocdef);
@@ -1208,33 +1205,6 @@ implementation
       end;
 
 
-    procedure location_get_data_ref(list:TAsmList;const l:tlocation;var ref:treference;loadref:boolean; alignment: longint);
-      begin
-        case l.loc of
-          LOC_REGISTER,
-          LOC_CREGISTER :
-            begin
-              if not loadref then
-                internalerror(200410231);
-              reference_reset_base(ref,l.register,0,alignment);
-            end;
-          LOC_REFERENCE,
-          LOC_CREFERENCE :
-            begin
-              if loadref then
-                begin
-                  reference_reset_base(ref,cg.getaddressregister(list),0,alignment);
-                  cg.a_load_ref_reg(list,OS_ADDR,OS_ADDR,l.reference,ref.base);
-                end
-              else
-                ref:=l.reference;
-            end;
-          else
-            internalerror(200309181);
-        end;
-      end;
-
-
 {****************************************************************************
                             Init/Finalize Code
 ****************************************************************************}
@@ -1254,7 +1224,7 @@ implementation
           (paramanager.push_addr_param(tparavarsym(p).varspez,tparavarsym(p).vardef,current_procinfo.procdef.proccalloption)) then
           begin
             { we have no idea about the alignment at the caller side }
-            location_get_data_ref(list,tparavarsym(p).initialloc,href,true,1);
+            hlcg.location_get_data_ref(list,tparavarsym(p).vardef,tparavarsym(p).initialloc,href,true,1);
             if is_open_array(tparavarsym(p).vardef) or
                is_array_of_const(tparavarsym(p).vardef) then
               begin
@@ -1605,7 +1575,7 @@ implementation
                    if not((tparavarsym(p).vardef.typ=variantdef) and
                      paramanager.push_addr_param(tparavarsym(p).varspez,tparavarsym(p).vardef,current_procinfo.procdef.proccalloption)) then
                      begin
-                       location_get_data_ref(list,tparavarsym(p).initialloc,href,is_open_array(tparavarsym(p).vardef),sizeof(pint));
+                       hlcg.location_get_data_ref(list,tparavarsym(p).vardef,tparavarsym(p).initialloc,href,is_open_array(tparavarsym(p).vardef),sizeof(pint));
                        if is_open_array(tparavarsym(p).vardef) then
                          begin
                            { open arrays do not contain correct element count in their rtti,
@@ -1617,7 +1587,7 @@ implementation
                            cg.g_array_rtti_helper(list,eldef,href,hsym.initialloc,'FPC_ADDREF_ARRAY');
                          end
                        else
-                         cg.g_incrrefcount(list,tparavarsym(p).vardef,href);
+                        cg.g_incrrefcount(list,tparavarsym(p).vardef,href);
                      end;
                  end;
              vs_out :
@@ -1697,7 +1667,7 @@ implementation
            if (tparavarsym(p).varspez=vs_value) then
             begin
               include(current_procinfo.flags,pi_needs_implicit_finally);
-              location_get_data_ref(list,tparavarsym(p).localloc,href,is_open_array(tparavarsym(p).vardef),sizeof(pint));
+              hlcg.location_get_data_ref(list,tparavarsym(p).vardef,tparavarsym(p).localloc,href,is_open_array(tparavarsym(p).vardef),sizeof(pint));
               if is_open_array(tparavarsym(p).vardef) then
                 begin
                   hsym:=tparavarsym(tsym(p).owner.Find('high'+tsym(p).name));
@@ -1718,7 +1688,7 @@ implementation
             { cdecl functions don't have a high pointer so it is not possible to generate
               a local copy }
             if not(current_procinfo.procdef.proccalloption in cdecl_pocalls) then
-              cg.g_releasevaluepara_openarray(list,tparavarsym(p).localloc);
+              hlcg.g_releasevaluepara_openarray(list,tarraydef(tparavarsym(p).vardef),tparavarsym(p).localloc);
           end;
       end;
 

compiler/nld.pas

@@ -50,7 +50,7 @@ interface
           procedure buildderefimpl;override;
           procedure derefimpl;override;
           procedure set_mp(p:tnode);
-          function  is_addr_param_load:boolean;
+          function  is_addr_param_load:boolean;virtual;
           function  dogetcopy : tnode;override;
           function  pass_1 : tnode;override;
           function  pass_typecheck:tnode;override;
@@ -149,7 +149,7 @@ interface
 implementation
 
     uses
-      cutils,verbose,globtype,globals,systems,
+      cutils,verbose,globtype,globals,systems,constexp,
       symnot,
       defutil,defcmp,
       htypechk,pass_1,procinfo,paramgr,
@@ -550,10 +550,11 @@ implementation
            { remove property flag to avoid errors, see comments for }
            { tf_winlikewidestring assignments below                 }
            exclude(left.flags,nf_isproperty);
-           hp:=ccallparanode.create(caddrnode.create_internal
-                   (crttinode.create(tstoreddef(left.resultdef),initrtti,rdt_normal)),
-               ccallparanode.create(ctypeconvnode.create_internal(left,voidpointertype),nil));
-           result := ccallnode.createintern('fpc_dynarray_clear',hp);
+           { generate a setlength node so it can be intercepted by
+             target-specific code }
+           result:=cinlinenode.create(in_setlength_x,false,
+             ccallparanode.create(genintconstnode(0),
+               ccallparanode.create(left,nil)));
            left:=nil;
            exit;
          end;

compiler/paramgr.pas

@@ -56,7 +56,7 @@ unit paramgr;
           }
           function push_addr_param(varspez:tvarspez;def : tdef;calloption : tproccalloption) : boolean;virtual;abstract;
           { return the size of a push }
-          function push_size(varspez:tvarspez;def : tdef;calloption : tproccalloption) : longint;
+          function push_size(varspez:tvarspez;def : tdef;calloption : tproccalloption) : longint;virtual;
           {# Returns a structure giving the information on
             the storage of the parameter (which must be
             an integer parameter). This is only used when calling

compiler/tgobj.pas

@@ -86,7 +86,7 @@ unit tgobj;
 
             the forcesize parameter is so that it can be used for defs that
             don't have an inherent size (e.g., array of const) }
-          procedure gethltemp(list: TAsmList; def: tdef; forcesize: aint; temptype: ttemptype; out ref: treference);
+          procedure gethltemp(list: TAsmList; def: tdef; forcesize: aint; temptype: ttemptype; out ref: treference); virtual;
           procedure gettemp(list: TAsmList; size, alignment : longint;temptype:ttemptype;out ref : treference);
           procedure gettemptyped(list: TAsmList; def:tdef;temptype:ttemptype;out ref : treference);
           procedure ungettemp(list: TAsmList; const ref : treference);
@@ -109,7 +109,7 @@ unit tgobj;
 
           { Allocate space for a local }
           procedure getlocal(list: TAsmList; size : longint;def:tdef;var ref : treference);
-          procedure getlocal(list: TAsmList; size : longint; alignment : shortint; def:tdef;var ref : treference);
+          procedure getlocal(list: TAsmList; size : longint; alignment : shortint; def:tdef;var ref : treference); virtual;
           procedure UnGetLocal(list: TAsmList; const ref : treference);
        end;
        ttgobjclass = class of ttgobj;

rtl/java/jdynarrh.inc

@@ -50,6 +50,17 @@ function fpc_setlength_dynarr_jfloat(aorg, anew: TJFloatArray; deepcopy: boolean
 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;
 
+{ array copying helpers }
+
+procedure fpc_copy_jbyte_array(src, dst: TJByteArray);
+procedure fpc_copy_jshort_array(src, dst: TJShortArray);
+procedure fpc_copy_jint_array(src, dst: TJIntArray);
+procedure fpc_copy_jlong_array(src, dst: TJLongArray);
+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);
+
 { 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
   dimension matters.

rtl/java/system.pp

@@ -128,7 +128,7 @@ function min(a,b : longint) : longint;
 { copying helpers }
 
 { also for booleans }
-procedure copy_jbyte_array(src, dst: TJByteArray);
+procedure fpc_copy_jbyte_array(src, dst: TJByteArray);
   var
     i: longint;
   begin
@@ -137,7 +137,7 @@ procedure copy_jbyte_array(src, dst: TJByteArray);
   end;
 
 
-procedure copy_jshort_array(src, dst: TJShortArray);
+procedure fpc_copy_jshort_array(src, dst: TJShortArray);
   var
     i: longint;
   begin
@@ -146,7 +146,7 @@ procedure copy_jshort_array(src, dst: TJShortArray);
   end;
 
 
-procedure copy_jint_array(src, dst: TJIntArray);
+procedure fpc_copy_jint_array(src, dst: TJIntArray);
   var
     i: longint;
   begin
@@ -155,7 +155,7 @@ procedure copy_jint_array(src, dst: TJIntArray);
   end;
 
 
-procedure copy_jlong_array(src, dst: TJLongArray);
+procedure fpc_copy_jlong_array(src, dst: TJLongArray);
   var
     i: longint;
   begin
@@ -164,7 +164,7 @@ procedure copy_jlong_array(src, dst: TJLongArray);
   end;
 
 
-procedure copy_jchar_array(src, dst: TJCharArray);
+procedure fpc_copy_jchar_array(src, dst: TJCharArray);
   var
     i: longint;
   begin
@@ -173,7 +173,7 @@ procedure copy_jchar_array(src, dst: TJCharArray);
   end;
 
 
-procedure copy_jfloat_array(src, dst: TJFloatArray);
+procedure fpc_copy_jfloat_array(src, dst: TJFloatArray);
   var
     i: longint;
   begin
@@ -182,7 +182,7 @@ procedure copy_jfloat_array(src, dst: TJFloatArray);
   end;
 
 
-procedure copy_jdouble_array(src, dst: TJDoubleArray);
+procedure fpc_copy_jdouble_array(src, dst: TJDoubleArray);
   var
     i: longint;
   begin
@@ -191,7 +191,7 @@ procedure copy_jdouble_array(src, dst: TJDoubleArray);
   end;
 
 
-procedure copy_jobject_array(src, dst: TJObjectArray);
+procedure fpc_copy_jobject_array(src, dst: TJObjectArray);
   var
     i: longint;
   begin
@@ -207,7 +207,7 @@ function fpc_setlength_dynarr_jbyte(aorg, anew: TJByteArray; deepcopy: boolean):
     if deepcopy or
        (length(aorg)<>length(anew)) then
       begin
-        copy_jbyte_array(aorg,anew);
+        fpc_copy_jbyte_array(aorg,anew);
         result:=anew
       end
     else
@@ -220,7 +220,7 @@ function fpc_setlength_dynarr_jshort(aorg, anew: TJShortArray; deepcopy: boolean
     if deepcopy or
        (length(aorg)<>length(anew)) then
       begin
-        copy_jshort_array(aorg,anew);
+        fpc_copy_jshort_array(aorg,anew);
         result:=anew
       end
     else
@@ -233,7 +233,7 @@ function fpc_setlength_dynarr_jint(aorg, anew: TJIntArray; deepcopy: boolean): T
     if deepcopy or
        (length(aorg)<>length(anew)) then
       begin
-        copy_jint_array(aorg,anew);
+        fpc_copy_jint_array(aorg,anew);
         result:=anew
       end
     else
@@ -246,7 +246,7 @@ function fpc_setlength_dynarr_jlong(aorg, anew: TJLongArray; deepcopy: boolean):
     if deepcopy or
        (length(aorg)<>length(anew)) then
       begin
-        copy_jlong_array(aorg,anew);
+        fpc_copy_jlong_array(aorg,anew);
         result:=anew
       end
     else
@@ -259,7 +259,7 @@ function fpc_setlength_dynarr_jchar(aorg, anew: TJCharArray; deepcopy: boolean):
     if deepcopy or
        (length(aorg)<>length(anew)) then
       begin
-        copy_jchar_array(aorg,anew);
+        fpc_copy_jchar_array(aorg,anew);
         result:=anew
       end
     else
@@ -272,7 +272,7 @@ function fpc_setlength_dynarr_jfloat(aorg, anew: TJFloatArray; deepcopy: boolean
     if deepcopy or
        (length(aorg)<>length(anew)) then
       begin
-        copy_jfloat_array(aorg,anew);
+        fpc_copy_jfloat_array(aorg,anew);
         result:=anew
       end
     else
@@ -285,7 +285,7 @@ function fpc_setlength_dynarr_jdouble(aorg, anew: TJDoubleArray; deepcopy: boole
     if deepcopy or
        (length(aorg)<>length(anew)) then
       begin
-        copy_jdouble_array(aorg,anew);
+        fpc_copy_jdouble_array(aorg,anew);
         result:=anew
       end
     else
@@ -299,7 +299,7 @@ function fpc_setlength_dynarr_jobject(aorg, anew: TJObjectArray; deepcopy: boole
        (length(aorg)<>length(anew)) then
       begin
         if docopy then
-          copy_jobject_array(aorg,anew);
+          fpc_copy_jobject_array(aorg,anew);
         result:=anew
       end
     else