* merged the jvmbackend branch

   General:
    o support for Java/JVM and Android/JVM targets, with support for most
      common language features (classes, records, all array types,
      enumerations, signed and unsigned integers, currency, threadvar,
      typed constants, generics, exceptions, ansistring, ...) and limited
      support for others (such as pointers and formal var/out parameters).
      See http://wiki.freepascal.org/FPC_JVM/Language for more details
    o fpcjres utility to pack "resource files" (= any file specified via
      {$r xxx}, without any processing) into jar files
    o {$modeswitch unicodestrings} modeswitch that changes "string" into
      "unicodestring", "char" unto "widechar" and "pchar" into "pwidechar".
      Note that the latter two are achieved by automatically adding a unit
      (uuchar) to the uses clause that overrides these types, so it does not
      (yet) work for the system unit. If this modeswitch is enabled, {$H+/-}
      switches between string=unicodestring and string=shortstring, but the
      state of the {$H}-switch has no effect on the definition of char/pchar.
    o {$namespace x.y.z} directive to set the package namespace of a unit
      on the JVM target (does not do anything on other targets). Dotted unit
      names do not yet influence the namespace of generated JVM classes
    o javapp utility to create Pascal headers from Java class files

   Compiler:
    o new high level code generator in the compiler that uses high level type
      information, including a wrapper that passes everything through to the
      existing low level code generators for existing native targets
      (hlcgobj.pas, hlcg2ll.pas, <arch>/hlcgcpu.pas). Several routines have
      also migrated from ncgutil.pas to hlcgobj.pas
    o quite a bit of code in ncg*.pas has been converted to use the new
      high level code generator so that it works for both existing targets
      and the new JVM target (mostly replacing tcgsize parameters with tdef
      parameters, or adding some tdef size parameters) -- this one should
      always be used in common code, tgobj.gettemp() should only be used in
      architecture-specific code from now on
    o new tgobj.gethltemp() routine that also specifies the tdef of the
      requested temp for high level code generator use
    o tcgpara now also contains the def of the parameter for use by the
      high level code generator
    o support for nested routines without making use of a framepointer, by
      grouping variables accessed from nested routines into a record and
      passing a pointer to this record to the nested routines (ncgnstld.pas,
      ncgnstmm.pas)
    o support for internally generating and parsing Pascal code in the
      compiler for routine declarations and implementations (symcreat.pas)
    o parsing a recorddef and an objectdef method declaration has been
      factored out so this code can be reused by symcreat.pas
    o support for duplicating and slightly modifying procdefs
      (symdef.tprocdef.getcopy, symcreat.finish_copied_procdef)
    o cchartype has been renamed into cansichartype
    o new TSymStr type that is used as string type for symbols and mangled
      names. The default is still pshortstring on all platforms, but for the
      JVM targets it's ansistring because it sometimes needs symbols > 255
      characters
    o it is no longer allowed to use sysutils.executeprocess() from the
      compiler, except via the the wrapper cfilutil.RequotedExecuteProcess()
      so that the compiler can correctly deal with the
      sysutils.executeprocess() limitation of only supporting double quotes
    o new getpointerdef(def), getsingletonarraydef(def) and
      getarraydef(def,count) helpers in symdef to create/get reusable pointer/
      arraydefs for another def (mostly used for the JVM target currently)
    o several parameter parsing helpers have been moved from pdecsub.pas to
      pparautl.pas
    o the type checking and firstpass for setlength() and copy() has been
      moved from pinline.pas to ninl.pas so it can be overridden by target-
      specific versions
    o commented the ttempinfoflag values in nbas, and the ttemptype flags
      in globtype
    o new "reference" ttempcreatenode type, which can be used to create a
      reference to (~ hold the address of) another node, even on targets that
      do not support taking the address of an arbitrary memory location and
      store it into a virtual register (such as the JVM target).
    o secondpass no longer takes a var-parameter, since it doesn't change
      the received node
    o many routines from pmodules.pas and some from nutils.pas have been
      moved to ngenutil.pas as virtual class methods so they can be
      overridden with target-specific versions
    o the code of a single JVM routine is limited to 64KB bytecode, which can
      be fairly easily reached when having large array constants because they
      have to be initialized element by element in the unit initialisation
      code -> -CTcompactarrayinit switch to use alternate (slightly slower)
      initialisation of arrays on the JVM targets that uses much less code
      space
    o it is now possible to override the individual typecheck helpers of
      ttypeconvnode
    o most of the code from ptconst.pas has moved to ngtcon.pas, and has been
      turned into a class that splits most of the parsing and data/code
      generation for typed constants into separate routines. Separate
      implementations are now available that either generate initialised data
      (native targets) or assignment nodes for explicit initialisation at
      run time (JVM)

   RTL:
    o many extra ifdefs to common RTL include files to enable overriding
      helpers with JVM-specific helpers
    o some internal move-alternatives for the RTL that also can be overridden
      by the JVM target to enable sharing more code between managed and
      native targets

   Tests:
     o a number of JVM-specific tests have been added to tests/test/jvm.
       They can be executed via the provided testall.sh/.bat scripts.
       Because standard I/O is not yet available in the Java/Android RTL,
       most regular tests can't be compiled yet.

   Note: currently, compiling a JVM compiler requires adding ALLOW_WARNINGS=1
     to the make command line

git-svn-id: trunk@21069 -

.gitattributes

@@ -11,6 +11,7 @@ compiler/aasmdata.pas svneol=native#text/plain
 compiler/aasmsym.pas svneol=native#text/plain
 compiler/aasmtai.pas svneol=native#text/plain
 compiler/aggas.pas svneol=native#text/plain
+compiler/agjasmin.pas svneol=native#text/plain
 compiler/alpha/aasmcpu.pas svneol=native#text/plain
 compiler/alpha/agaxpgas.pas svneol=native#text/plain
 compiler/alpha/aoptcpu.pas svneol=native#text/plain
@@ -53,6 +54,7 @@ compiler/arm/cpunode.pas svneol=native#text/plain
 compiler/arm/cpupara.pas svneol=native#text/plain
 compiler/arm/cpupi.pas svneol=native#text/plain
 compiler/arm/cputarg.pas svneol=native#text/plain
+compiler/arm/hlcgcpu.pas svneol=native#text/plain
 compiler/arm/itcpugas.pas svneol=native#text/plain
 compiler/arm/narmadd.pas svneol=native#text/plain
 compiler/arm/narmcal.pas svneol=native#text/plain
@@ -89,6 +91,7 @@ compiler/avr/cpunode.pas svneol=native#text/plain
 compiler/avr/cpupara.pas svneol=native#text/plain
 compiler/avr/cpupi.pas svneol=native#text/plain
 compiler/avr/cputarg.pas svneol=native#text/plain
+compiler/avr/hlcgcpu.pas svneol=native#text/plain
 compiler/avr/itcpugas.pas svneol=native#text/plain
 compiler/avr/navradd.pas svneol=native#text/plain
 compiler/avr/navrcnv.pas svneol=native#text/plain
@@ -152,6 +155,8 @@ compiler/gendef.pas svneol=native#text/plain
 compiler/generic/cpuinfo.pas svneol=native#text/plain
 compiler/globals.pas svneol=native#text/plain
 compiler/globtype.pas svneol=native#text/plain
+compiler/hlcg2ll.pas svneol=native#text/plain
+compiler/hlcgobj.pas svneol=native#text/plain
 compiler/html/i386/readme.txt svneol=native#text/plain
 compiler/html/powerpc/readme.txt svneol=native#text/plain
 compiler/htypechk.pas svneol=native#text/plain
@@ -165,6 +170,7 @@ compiler/i386/cpupi.pas svneol=native#text/plain
 compiler/i386/cputarg.pas svneol=native#text/plain
 compiler/i386/csopt386.pas svneol=native#text/plain
 compiler/i386/daopt386.pas svneol=native#text/plain
+compiler/i386/hlcgcpu.pas svneol=native#text/plain
 compiler/i386/i386att.inc svneol=native#text/plain
 compiler/i386/i386atts.inc svneol=native#text/plain
 compiler/i386/i386int.inc svneol=native#text/plain
@@ -205,6 +211,41 @@ compiler/ia64/cpuinfo.pas svneol=native#text/plain
 compiler/ia64/ia64reg.dat svneol=native#text/plain
 compiler/impdef.pas svneol=native#text/plain
 compiler/import.pas svneol=native#text/plain
+compiler/jvm/aasmcpu.pas svneol=native#text/plain
+compiler/jvm/cgcpu.pas svneol=native#text/plain
+compiler/jvm/cpubase.pas svneol=native#text/plain
+compiler/jvm/cpuinfo.pas svneol=native#text/plain
+compiler/jvm/cpunode.pas svneol=native#text/plain
+compiler/jvm/cpupara.pas svneol=native#text/plain
+compiler/jvm/cpupi.pas svneol=native#text/plain
+compiler/jvm/cputarg.pas svneol=native#text/plain
+compiler/jvm/dbgjasm.pas svneol=native#text/plain
+compiler/jvm/hlcgcpu.pas svneol=native#text/plain
+compiler/jvm/itcpujas.pas svneol=native#text/plain
+compiler/jvm/jvmdef.pas svneol=native#text/plain
+compiler/jvm/jvmreg.dat svneol=native#text/plain
+compiler/jvm/njvmadd.pas svneol=native#text/plain
+compiler/jvm/njvmcal.pas svneol=native#text/plain
+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/njvmset.pas svneol=native#text/plain
+compiler/jvm/njvmtcon.pas svneol=native#text/plain
+compiler/jvm/njvmutil.pas svneol=native#text/plain
+compiler/jvm/pjvm.pas svneol=native#text/plain
+compiler/jvm/rgcpu.pas svneol=native#text/plain
+compiler/jvm/rjvmcon.inc svneol=native#text/plain
+compiler/jvm/rjvmnor.inc svneol=native#text/plain
+compiler/jvm/rjvmnum.inc svneol=native#text/plain
+compiler/jvm/rjvmrni.inc svneol=native#text/plain
+compiler/jvm/rjvmsri.inc svneol=native#text/plain
+compiler/jvm/rjvmstd.inc svneol=native#text/plain
+compiler/jvm/rjvmsup.inc svneol=native#text/plain
+compiler/jvm/tgcpu.pas svneol=native#text/plain
 compiler/link.pas svneol=native#text/plain
 compiler/m68k/aasmcpu.pas svneol=native#text/plain
 compiler/m68k/ag68kgas.pas svneol=native#text/plain
@@ -219,6 +260,7 @@ compiler/m68k/cpunode.pas svneol=native#text/plain
 compiler/m68k/cpupara.pas svneol=native#text/plain
 compiler/m68k/cpupi.pas svneol=native#text/plain
 compiler/m68k/cputarg.pas svneol=native#text/plain
+compiler/m68k/hlcgcpu.pas svneol=native#text/plain
 compiler/m68k/itcpugas.pas svneol=native#text/plain
 compiler/m68k/m68kreg.dat svneol=native#text/plain
 compiler/m68k/n68kadd.pas svneol=native#text/plain
@@ -252,6 +294,7 @@ compiler/mips/cpunode.pas svneol=native#text/plain
 compiler/mips/cpupara.pas svneol=native#text/plain
 compiler/mips/cpupi.pas svneol=native#text/plain
 compiler/mips/cputarg.pas svneol=native#text/pascal
+compiler/mips/hlcgcpu.pas svneol=native#text/plain
 compiler/mips/itcpugas.pas svneol=native#text/plain
 compiler/mips/mipsreg.dat svneol=native#text/plain
 compiler/mips/ncpuadd.pas svneol=native#text/plain
@@ -311,6 +354,8 @@ compiler/ncginl.pas svneol=native#text/plain
 compiler/ncgld.pas svneol=native#text/plain
 compiler/ncgmat.pas svneol=native#text/plain
 compiler/ncgmem.pas svneol=native#text/plain
+compiler/ncgnstld.pas svneol=native#text/plain
+compiler/ncgnstmm.pas svneol=native#text/plain
 compiler/ncgobjc.pas svneol=native#text/plain
 compiler/ncgopt.pas svneol=native#text/plain
 compiler/ncgrtti.pas svneol=native#text/plain
@@ -319,6 +364,8 @@ compiler/ncgutil.pas svneol=native#text/plain
 compiler/ncnv.pas svneol=native#text/plain
 compiler/ncon.pas svneol=native#text/plain
 compiler/nflw.pas svneol=native#text/plain
+compiler/ngenutil.pas svneol=native#text/plain
+compiler/ngtcon.pas svneol=native#text/plain
 compiler/ninl.pas svneol=native#text/plain
 compiler/nld.pas svneol=native#text/plain
 compiler/nmat.pas svneol=native#text/plain
@@ -379,6 +426,7 @@ compiler/powerpc/cpunode.pas svneol=native#text/plain
 compiler/powerpc/cpupara.pas svneol=native#text/plain
 compiler/powerpc/cpupi.pas svneol=native#text/plain
 compiler/powerpc/cputarg.pas svneol=native#text/plain
+compiler/powerpc/hlcgcpu.pas svneol=native#text/plain
 compiler/powerpc/itcpugas.pas svneol=native#text/plain
 compiler/powerpc/nppcadd.pas svneol=native#text/plain
 compiler/powerpc/nppccal.pas svneol=native#text/plain
@@ -413,6 +461,7 @@ compiler/powerpc64/cpunode.pas svneol=native#text/plain
 compiler/powerpc64/cpupara.pas svneol=native#text/plain
 compiler/powerpc64/cpupi.pas svneol=native#text/plain
 compiler/powerpc64/cputarg.pas svneol=native#text/plain
+compiler/powerpc64/hlcgcpu.pas svneol=native#text/plain
 compiler/powerpc64/itcpugas.pas svneol=native#text/plain
 compiler/powerpc64/nppcadd.pas svneol=native#text/plain
 compiler/powerpc64/nppccal.pas svneol=native#text/plain
@@ -439,6 +488,7 @@ compiler/powerpc64/rppcstd.inc svneol=native#text/plain
 compiler/powerpc64/rppcsup.inc svneol=native#text/plain
 compiler/pp.lpi svneol=native#text/plain
 compiler/pp.pas svneol=native#text/plain
+compiler/pparautl.pas svneol=native#text/plain
 compiler/ppc.cfg -text
 compiler/ppc.conf -text
 compiler/ppc.dof -text
@@ -489,6 +539,7 @@ compiler/sparc/cpunode.pas svneol=native#text/plain
 compiler/sparc/cpupara.pas svneol=native#text/plain
 compiler/sparc/cpupi.pas svneol=native#text/plain
 compiler/sparc/cputarg.pas svneol=native#text/plain
+compiler/sparc/hlcgcpu.pas svneol=native#text/plain
 compiler/sparc/itcpugas.pas svneol=native#text/plain
 compiler/sparc/ncpuadd.pas svneol=native#text/plain
 compiler/sparc/ncpucall.pas svneol=native#text/plain
@@ -514,6 +565,7 @@ compiler/sparc/strinst.inc svneol=native#text/plain
 compiler/switches.pas svneol=native#text/plain
 compiler/symbase.pas svneol=native#text/plain
 compiler/symconst.pas svneol=native#text/plain
+compiler/symcreat.pas svneol=native#text/plain
 compiler/symdef.pas svneol=native#text/plain
 compiler/symnot.pas svneol=native#text/plain
 compiler/symsym.pas svneol=native#text/plain
@@ -532,6 +584,7 @@ compiler/systems/i_emx.pas svneol=native#text/plain
 compiler/systems/i_gba.pas svneol=native#text/plain
 compiler/systems/i_go32v2.pas svneol=native#text/plain
 compiler/systems/i_haiku.pas svneol=native#text/plain
+compiler/systems/i_jvm.pas svneol=native#text/plain
 compiler/systems/i_linux.pas svneol=native#text/plain
 compiler/systems/i_macos.pas svneol=native#text/plain
 compiler/systems/i_morph.pas svneol=native#text/plain
@@ -558,6 +611,7 @@ compiler/systems/t_emx.pas svneol=native#text/plain
 compiler/systems/t_gba.pas svneol=native#text/plain
 compiler/systems/t_go32v2.pas svneol=native#text/plain
 compiler/systems/t_haiku.pas svneol=native#text/plain
+compiler/systems/t_jvm.pas svneol=native#text/plain
 compiler/systems/t_linux.pas svneol=native#text/plain
 compiler/systems/t_macos.pas svneol=native#text/plain
 compiler/systems/t_morph.pas svneol=native#text/plain
@@ -594,6 +648,7 @@ compiler/utils/mkarmins.pp svneol=native#text/plain
 compiler/utils/mkarmreg.pp svneol=native#text/plain
 compiler/utils/mkavrreg.pp svneol=native#text/plain
 compiler/utils/mkia64reg.pp svneol=native#text/pascal
+compiler/utils/mkjvmreg.pp svneol=native#text/plain
 compiler/utils/mkmpsreg.pp svneol=native#text/plain
 compiler/utils/mkppcreg.pp svneol=native#text/plain
 compiler/utils/mkspreg.pp svneol=native#text/plain
@@ -625,9 +680,11 @@ compiler/x86/agx86nsm.pas svneol=native#text/plain
 compiler/x86/cga.pas svneol=native#text/plain
 compiler/x86/cgx86.pas svneol=native#text/plain
 compiler/x86/cpubase.pas svneol=native#text/plain
+compiler/x86/hlcgx86.pas svneol=native#text/plain
 compiler/x86/itcpugas.pas svneol=native#text/plain
 compiler/x86/itx86int.pas svneol=native#text/plain
 compiler/x86/nx86add.pas svneol=native#text/plain
+compiler/x86/nx86cal.pas svneol=native#text/plain
 compiler/x86/nx86cnv.pas svneol=native#text/plain
 compiler/x86/nx86con.pas svneol=native#text/plain
 compiler/x86/nx86inl.pas svneol=native#text/plain
@@ -650,6 +707,7 @@ compiler/x86_64/cpunode.pas svneol=native#text/plain
 compiler/x86_64/cpupara.pas svneol=native#text/plain
 compiler/x86_64/cpupi.pas svneol=native#text/plain
 compiler/x86_64/cputarg.pas svneol=native#text/plain
+compiler/x86_64/hlcgcpu.pas svneol=native#text/plain
 compiler/x86_64/nx64add.pas svneol=native#text/plain
 compiler/x86_64/nx64cal.pas svneol=native#text/plain
 compiler/x86_64/nx64cnv.pas svneol=native#text/plain
@@ -7135,6 +7193,13 @@ rtl/amiga/sysutils.pp svneol=native#text/plain
 rtl/amiga/timerd.inc svneol=native#text/plain
 rtl/amiga/tthread.inc svneol=native#text/plain
 rtl/amiga/varutils.pp svneol=native#text/plain
+rtl/android/jvm/Makefile svneol=native#text/plain
+rtl/android/jvm/Makefile.fpc svneol=native#text/plain
+rtl/android/jvm/androidr14.inc svneol=native#text/plain
+rtl/android/jvm/androidr14.pas svneol=native#text/plain
+rtl/android/jvm/java_sys_android.inc svneol=native#text/plain
+rtl/android/jvm/java_sysh_android.inc svneol=native#text/plain
+rtl/android/jvm/rtl.cfg svneol=native#text/plain
 rtl/arm/arm.inc svneol=native#text/plain
 rtl/arm/divide.inc svneol=native#text/plain
 rtl/arm/int64p.inc svneol=native#text/plain
@@ -7539,6 +7604,7 @@ rtl/inc/ucomplex.pp svneol=native#text/plain
 rtl/inc/ufloat128.pp svneol=native#text/plain
 rtl/inc/ustringh.inc svneol=native#text/plain
 rtl/inc/ustrings.inc svneol=native#text/plain
+rtl/inc/uuchar.pp svneol=native#text/plain
 rtl/inc/varerror.inc svneol=native#text/plain
 rtl/inc/variant.inc svneol=native#text/plain
 rtl/inc/varianth.inc svneol=native#text/plain
@@ -7548,6 +7614,50 @@ rtl/inc/videoh.inc svneol=native#text/plain
 rtl/inc/wstringh.inc svneol=native#text/plain
 rtl/inc/wstrings.inc svneol=native#text/plain
 rtl/inc/wustrings.inc svneol=native#text/plain
+rtl/java/Makefile svneol=native#text/plain
+rtl/java/Makefile.fpc svneol=native#text/plain
+rtl/java/jastringh.inc svneol=native#text/plain
+rtl/java/jastrings.inc svneol=native#text/plain
+rtl/java/java_sys.inc svneol=native#text/plain
+rtl/java/java_sysh.inc svneol=native#text/plain
+rtl/java/jcompproc.inc svneol=native#text/plain
+rtl/java/jdk15.inc svneol=native#text/plain
+rtl/java/jdk15.pas svneol=native#text/plain
+rtl/java/jdynarr.inc svneol=native#text/plain
+rtl/java/jdynarrh.inc svneol=native#text/plain
+rtl/java/jpvar.inc svneol=native#text/plain
+rtl/java/jpvarh.inc svneol=native#text/plain
+rtl/java/jrec.inc svneol=native#text/plain
+rtl/java/jrech.inc svneol=native#text/plain
+rtl/java/jset.inc svneol=native#text/plain
+rtl/java/jseth.inc svneol=native#text/plain
+rtl/java/jsstringh.inc svneol=native#text/plain
+rtl/java/jsstrings.inc svneol=native#text/plain
+rtl/java/jsystem.inc svneol=native#text/plain
+rtl/java/jsystemh.inc svneol=native#text/plain
+rtl/java/jsystemh_types.inc svneol=native#text/plain
+rtl/java/jtcon.inc svneol=native#text/plain
+rtl/java/jtconh.inc svneol=native#text/plain
+rtl/java/jtvar.inc svneol=native#text/plain
+rtl/java/jtvarh.inc svneol=native#text/plain
+rtl/java/justringh.inc svneol=native#text/plain
+rtl/java/justrings.inc svneol=native#text/plain
+rtl/java/jwin2javacharset.inc svneol=native#text/plain
+rtl/java/objpas.inc svneol=native#text/plain
+rtl/java/objpas.pp svneol=native#text/plain
+rtl/java/objpash.inc svneol=native#text/plain
+rtl/java/rtl.cfg svneol=native#text/plain
+rtl/java/rtti.inc svneol=native#text/plain
+rtl/java/sysos.inc svneol=native#text/plain
+rtl/java/sysosh.inc svneol=native#text/plain
+rtl/java/sysres.inc svneol=native#text/plain
+rtl/java/system.pp svneol=native#text/plain
+rtl/jvm/int64p.inc svneol=native#text/plain
+rtl/jvm/jvm.inc svneol=native#text/plain
+rtl/jvm/makefile.cpu svneol=native#text/plain
+rtl/jvm/math.inc svneol=native#text/plain
+rtl/jvm/setjump.inc svneol=native#text/plain
+rtl/jvm/setjumph.inc svneol=native#text/plain
 rtl/linux/Makefile svneol=native#text/plain
 rtl/linux/Makefile.fpc svneol=native#text/plain
 rtl/linux/arm/bsyscall.inc svneol=native#text/plain
@@ -8100,7 +8210,7 @@ rtl/openbsd/i386/prt0.as svneol=native#text/plain
 rtl/openbsd/i386/sighnd.inc svneol=native#text/plain
 rtl/openbsd/osdefs.inc svneol=native#text/plain
 rtl/openbsd/pmutext.inc svneol=native#text/plain
-rtl/openbsd/pthread.inc -text svneol=unset#text/plain
+rtl/openbsd/pthread.inc svneol=native#text/plain
 rtl/openbsd/ptypes.inc svneol=native#text/plain
 rtl/openbsd/signal.inc svneol=native#text/plain
 rtl/openbsd/syscalls.inc svneol=native#text/plain
@@ -10012,6 +10122,78 @@ tests/test/cg/variants/tvarol94.pp svneol=native#text/plain
 tests/test/cg/variants/tvarol96.pp svneol=native#text/plain
 tests/test/dumpclass.pp svneol=native#text/plain
 tests/test/dumpmethods.pp svneol=native#text/plain
+tests/test/jvm/JavaClass.java svneol=native#text/plain
+tests/test/jvm/classlist.pp svneol=native#text/plain
+tests/test/jvm/classmeth.pp svneol=native#text/plain
+tests/test/jvm/forw.pp svneol=native#text/plain
+tests/test/jvm/getbit.pp svneol=native#text/plain
+tests/test/jvm/nested.pp svneol=native#text/plain
+tests/test/jvm/outpara.pp svneol=native#text/plain
+tests/test/jvm/sort.pp svneol=native#text/plain
+tests/test/jvm/tabs.pp svneol=native#text/plain
+tests/test/jvm/taddbool.pp svneol=native#text/plain
+tests/test/jvm/taddset.pp svneol=native#text/plain
+tests/test/jvm/taddsetint.pp svneol=native#text/plain
+tests/test/jvm/tarray2.pp svneol=native#text/plain
+tests/test/jvm/tarray3.pp svneol=native#text/plain
+tests/test/jvm/tassert.pp svneol=native#text/plain
+tests/test/jvm/tbyte.pp svneol=native#text/plain
+tests/test/jvm/tbytearrres.pp svneol=native#text/plain
+tests/test/jvm/tclassproptest.pp svneol=native#text/plain
+tests/test/jvm/tcnvstr1.pp svneol=native#text/plain
+tests/test/jvm/tcnvstr3.pp svneol=native#text/plain
+tests/test/jvm/tconst.pp svneol=native#text/plain
+tests/test/jvm/tdefpara.pp svneol=native#text/plain
+tests/test/jvm/tdynarrec.pp svneol=native#text/plain
+tests/test/jvm/tdynarrnil.pp svneol=native#text/plain
+tests/test/jvm/tenum.pp svneol=native#text/plain
+tests/test/jvm/test.pp svneol=native#text/plain
+tests/test/jvm/testall.bat -text svneol=native#application/x-bat
+tests/test/jvm/testall.sh -text svneol=native#application/x-sh
+tests/test/jvm/testansi.pp svneol=native#text/plain
+tests/test/jvm/testintf.pp svneol=native#text/plain
+tests/test/jvm/testshort.pp svneol=native#text/plain
+tests/test/jvm/tformalpara.pp svneol=native#text/plain
+tests/test/jvm/tint.pp svneol=native#text/plain
+tests/test/jvm/tintstr.pp svneol=native#text/plain
+tests/test/jvm/tnestdynarr.pp svneol=native#text/plain
+tests/test/jvm/tnestedset.pp svneol=native#text/plain
+tests/test/jvm/tnestproc.pp svneol=native#text/plain
+tests/test/jvm/topovl.pp svneol=native#text/plain
+tests/test/jvm/tprop.pp svneol=native#text/plain
+tests/test/jvm/tprop2.pp svneol=native#text/plain
+tests/test/jvm/tpvar.pp svneol=native#text/plain
+tests/test/jvm/tpvardelphi.pp svneol=native#text/plain
+tests/test/jvm/tpvarglobal.pp svneol=native#text/plain
+tests/test/jvm/tpvarglobaldelphi.pp svneol=native#text/plain
+tests/test/jvm/trange1.pp svneol=native#text/plain
+tests/test/jvm/trange2.pp svneol=native#text/plain
+tests/test/jvm/trange3.pp svneol=native#text/plain
+tests/test/jvm/tset1.pp svneol=native#text/plain
+tests/test/jvm/tset3.pp svneol=native#text/plain
+tests/test/jvm/tset7.pp svneol=native#text/plain
+tests/test/jvm/tstr.pp svneol=native#text/plain
+tests/test/jvm/tstring1.pp svneol=native#text/plain
+tests/test/jvm/tstring9.pp svneol=native#text/plain
+tests/test/jvm/tstrreal1.pp svneol=native#text/plain
+tests/test/jvm/tstrreal2.pp svneol=native#text/plain
+tests/test/jvm/tthreadvar.pp svneol=native#text/plain
+tests/test/jvm/ttrig.pp svneol=native#text/plain
+tests/test/jvm/ttrunc.pp svneol=native#text/plain
+tests/test/jvm/tval.inc svneol=native#text/plain
+tests/test/jvm/tval.pp svneol=native#text/plain
+tests/test/jvm/tval1.pp svneol=native#text/plain
+tests/test/jvm/tval2.pp svneol=native#text/plain
+tests/test/jvm/tval3.pp svneol=native#text/plain
+tests/test/jvm/tval4.pp svneol=native#text/plain
+tests/test/jvm/tval5.pp svneol=native#text/plain
+tests/test/jvm/tvalc.pp svneol=native#text/plain
+tests/test/jvm/tvarpara.pp svneol=native#text/plain
+tests/test/jvm/tvirtclmeth.pp svneol=native#text/plain
+tests/test/jvm/tw20212.pp svneol=native#text/plain
+tests/test/jvm/twith.pp svneol=native#text/plain
+tests/test/jvm/uenum.pp svneol=native#text/plain
+tests/test/jvm/unsupported.pp svneol=native#text/plain
 tests/test/lcpref.inc svneol=native#text/plain
 tests/test/library/testdll.pp svneol=native#text/plain
 tests/test/library/testdll2.pp svneol=native#text/plain
@@ -13302,8 +13484,11 @@ utils/fpcmkcfg/fppkg.inc svneol=native#text/plain
 utils/fpcres/Makefile svneol=native#text/plain
 utils/fpcres/Makefile.fpc svneol=native#text/plain
 utils/fpcres/closablefilestream.pas svneol=native#text/plain
+utils/fpcres/fpcjres.pas svneol=native#text/plain
 utils/fpcres/fpcres.pas svneol=native#text/plain
 utils/fpcres/fpmake.pp svneol=native#text/plain
+utils/fpcres/jarparamparser.pas svneol=native#text/plain
+utils/fpcres/jarsourcehandler.pas svneol=native#text/plain
 utils/fpcres/msghandler.pas svneol=native#text/plain
 utils/fpcres/paramparser.pas svneol=native#text/plain
 utils/fpcres/sourcehandler.pas svneol=native#text/plain
@@ -13502,6 +13687,34 @@ utils/instantfpc/fpmake.pp svneol=native#text/plain
 utils/instantfpc/instantfpc.lpi svneol=native#text/plain
 utils/instantfpc/instantfpc.pas svneol=native#text/plain
 utils/instantfpc/instantfptools.pas svneol=native#text/plain
+utils/javapp/src/fpc/tools/javapp/AttrData.java svneol=native#text/plain
+utils/javapp/src/fpc/tools/javapp/CPX.java svneol=native#text/plain
+utils/javapp/src/fpc/tools/javapp/CPX2.java svneol=native#text/plain
+utils/javapp/src/fpc/tools/javapp/ClassData.java svneol=native#text/plain
+utils/javapp/src/fpc/tools/javapp/ClassIdentifierInfo.java svneol=native#text/plain
+utils/javapp/src/fpc/tools/javapp/ClassListBuilder.java svneol=native#text/plain
+utils/javapp/src/fpc/tools/javapp/Constants.java svneol=native#text/plain
+utils/javapp/src/fpc/tools/javapp/FieldData.java svneol=native#text/plain
+utils/javapp/src/fpc/tools/javapp/InnerClassData.java svneol=native#text/plain
+utils/javapp/src/fpc/tools/javapp/JavapEnvironment.java svneol=native#text/plain
+utils/javapp/src/fpc/tools/javapp/JavapPrinter.java svneol=native#text/plain
+utils/javapp/src/fpc/tools/javapp/LineNumData.java svneol=native#text/plain
+utils/javapp/src/fpc/tools/javapp/LocVarData.java svneol=native#text/plain
+utils/javapp/src/fpc/tools/javapp/Main.java svneol=native#text/plain
+utils/javapp/src/fpc/tools/javapp/MethodData.java svneol=native#text/plain
+utils/javapp/src/fpc/tools/javapp/PascalClassData.java svneol=native#text/plain
+utils/javapp/src/fpc/tools/javapp/PascalFieldData.java svneol=native#text/plain
+utils/javapp/src/fpc/tools/javapp/PascalInnerClassData.java svneol=native#text/plain
+utils/javapp/src/fpc/tools/javapp/PascalKeywords.java svneol=native#text/plain
+utils/javapp/src/fpc/tools/javapp/PascalMethodData.java svneol=native#text/plain
+utils/javapp/src/fpc/tools/javapp/PascalTypeSignature.java svneol=native#text/plain
+utils/javapp/src/fpc/tools/javapp/PascalUnit.java svneol=native#text/plain
+utils/javapp/src/fpc/tools/javapp/RuntimeConstants.java svneol=native#text/plain
+utils/javapp/src/fpc/tools/javapp/StackMapData.java svneol=native#text/plain
+utils/javapp/src/fpc/tools/javapp/StackMapTableData.java svneol=native#text/plain
+utils/javapp/src/fpc/tools/javapp/Tables.java svneol=native#text/plain
+utils/javapp/src/fpc/tools/javapp/TrapData.java svneol=native#text/plain
+utils/javapp/src/fpc/tools/javapp/TypeSignature.java svneol=native#text/plain
 utils/mksymbian/Makefile svneol=native#text/plain
 utils/mksymbian/Makefile.fpc svneol=native#text/plain
 utils/mksymbian/cfgfile.pas svneol=native#text/plain

Makefile

@@ -2,7 +2,7 @@
 # Don't edit, this file is generated by FPCMake Version 2.0.0 [2012/04/25]
 #
 default: help
-MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-haiku i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian i386-nativent i386-iphonesim m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos powerpc-embedded powerpc-wii powerpc-aix sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-netbsd x86_64-solaris x86_64-openbsd x86_64-darwin x86_64-win64 x86_64-embedded arm-linux arm-palmos arm-darwin arm-wince arm-gba arm-nds arm-embedded arm-symbian powerpc64-linux powerpc64-darwin powerpc64-embedded powerpc64-aix avr-embedded armeb-linux armeb-embedded mips-linux mipsel-linux
+MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-haiku i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian i386-nativent i386-iphonesim m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos powerpc-embedded powerpc-wii powerpc-aix sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-netbsd x86_64-solaris x86_64-openbsd x86_64-darwin x86_64-win64 x86_64-embedded arm-linux arm-palmos arm-darwin arm-wince arm-gba arm-nds arm-embedded arm-symbian powerpc64-linux powerpc64-darwin powerpc64-embedded powerpc64-aix avr-embedded armeb-linux armeb-embedded mips-linux mipsel-linux jvm-java jvm-android
 BSDs = freebsd netbsd openbsd darwin
 UNIXs = linux $(BSDs) solaris qnx haiku aix
 LIMIT83fs = go32v2 os2 emx watcom
@@ -258,11 +258,13 @@ ifndef BINUTILSPREFIX
 ifndef CROSSBINDIR
 ifdef CROSSCOMPILE
 ifndef DARWIN2DARWIN
+ifneq ($(CPU_TARGET),jvm)
 BINUTILSPREFIX=$(CPU_TARGET)-$(OS_TARGET)-
 endif
 endif
 endif
 endif
+endif
 UNITSDIR:=$(wildcard $(FPCDIR)/units/$(TARGETSUFFIX))
 ifeq ($(UNITSDIR),)
 UNITSDIR:=$(wildcard $(FPCDIR)/units/$(OS_TARGET))
@@ -329,11 +331,18 @@ endif
 ifeq ($(CPU_TARGET),armeb)
 PPSUF=arm
 endif
+ifeq ($(CPU_TARGET),jvm)
+PPSUF=jvm
+endif
 ifdef CROSSCOMPILE
+ifneq ($(CPU_TARGET),jvm)
 PPPRE=ppcross
 else
 PPPRE=ppc
 endif
+else
+PPPRE=ppc
+endif
 PPNEW=$(BASEDIR)/compiler/$(PPPRE)$(PPSUF)$(SRCEXEEXT)
 endif
 ifneq ($(wildcard install),)
@@ -399,8 +408,9 @@ IDE=1
 endif
 endif
 endif
+BuildOnlyBaseCPUs=jvm
 ifneq ($(wildcard utils),)
-NOUTILSTARGETS=embedded gba
+NOUTILSTARGETS=embedded gba $(BuildOnlyBaseCPUs)
 ifeq ($(findstring $(OS_TARGET),$(NOUTILSTARGETS)),)
 UTILS=1
 endif
@@ -609,6 +619,12 @@ endif
 ifeq ($(FULL_TARGET),mipsel-linux)
 override TARGET_DIRS+=compiler rtl utils packages ide installer
 endif
+ifeq ($(FULL_TARGET),jvm-java)
+override TARGET_DIRS+=compiler rtl utils packages ide installer
+endif
+ifeq ($(FULL_TARGET),jvm-android)
+override TARGET_DIRS+=compiler rtl utils packages ide installer
+endif
 override INSTALL_FPCPACKAGE=y
 ifdef REQUIRE_UNITSDIR
 override UNITSDIR+=$(REQUIRE_UNITSDIR)
@@ -967,6 +983,18 @@ BATCHEXT=.sh
 EXEEXT=
 SHORTSUFFIX=aix
 endif
+ifeq ($(OS_TARGET),java)
+OEXT=.class
+ASMEXT=.j
+SHAREDLIBEXT=.jar
+SHORTSUFFIX=java
+endif
+ifeq ($(OS_TARGET),android)
+OEXT=.class
+ASMEXT=.j
+SHAREDLIBEXT=.jar
+SHORTSUFFIX=android
+endif
 ifneq ($(findstring $(OS_SOURCE),$(LIMIT83fs)),)
 FPCMADE=fpcmade.$(SHORTSUFFIX)
 ZIPSUFFIX=$(SHORTSUFFIX)
@@ -2252,6 +2280,22 @@ TARGET_DIRS_PACKAGES=1
 TARGET_DIRS_IDE=1
 TARGET_DIRS_INSTALLER=1
 endif
+ifeq ($(FULL_TARGET),jvm-java)
+TARGET_DIRS_COMPILER=1
+TARGET_DIRS_RTL=1
+TARGET_DIRS_UTILS=1
+TARGET_DIRS_PACKAGES=1
+TARGET_DIRS_IDE=1
+TARGET_DIRS_INSTALLER=1
+endif
+ifeq ($(FULL_TARGET),jvm-android)
+TARGET_DIRS_COMPILER=1
+TARGET_DIRS_RTL=1
+TARGET_DIRS_UTILS=1
+TARGET_DIRS_PACKAGES=1
+TARGET_DIRS_IDE=1
+TARGET_DIRS_INSTALLER=1
+endif
 ifdef TARGET_DIRS_COMPILER
 compiler_all:
 	$(MAKE) -C compiler all
@@ -2560,7 +2604,13 @@ compiler_cycle:
 	$(MAKE) -C compiler cycle
 BUILDSTAMP=build-stamp.$(FULL_TARGET)
 .PHONY: all clean distclean build buildbase install installbase installother zipinstallbase zipinstallotherzipinstall singlezipinstall
+ifeq ($(findstring $(CPU_TARGET),$(BuildOnlyBaseCPUs)),)
 all: build
+install: installall
+else
+all: buildbase
+install: installbase
+endif
 clean: $(addsuffix _distclean,$(TARGET_DIRS))
 	-$(DEL) build-stamp.*
 	-$(DEL) base.build-stamp.*
@@ -2593,7 +2643,7 @@ base.$(BUILDSTAMP):
 	$(MAKE) rtl_clean $(CLEANOPTS)
 	$(MAKE) rtl_$(ALLTARGET) $(BUILDOPTS)
 	$(ECHOREDIR) Build > base.$(BUILDSTAMP)
-installbase:
+installbase: base.$(BUILDSTAMP)
 	$(MKDIR) $(INSTALL_BASEDIR)
 	$(MKDIR) $(INSTALL_BINDIR)
 	$(MAKE) compiler_$(INSTALLTARGET) $(INSTALLOPTS)
@@ -2616,9 +2666,11 @@ endif
 ifdef IDE
 	$(MAKE) ide_zip$(INSTALLTARGET) $(INSTALLOPTS)
 endif
-install: $(BUILDSTAMP)
+installall: $(BUILDSTAMP)
 	$(MAKE) installbase $(INSTALLOPTS)
+ifeq ($(findstring $(CPU_TARGET), $(BuildOnlyBaseCPUs)),)
 	$(MAKE) installother $(INSTALLOPTS)
+endif
 singlezipinstall: zipinstall
 zipinstall: $(BUILDSTAMP)
 	$(MAKE) fpc_zipinstall ZIPTARGET=install FULLZIPNAME=fpc-$(PACKAGE_VERSION).$(TARGETSUFFIX) $(INSTALLOPTS)

Makefile.fpc

@@ -60,13 +60,21 @@ endif
 ifeq ($(CPU_TARGET),armeb)
 PPSUF=arm
 endif
+ifeq ($(CPU_TARGET),jvm)
+PPSUF=jvm
+endif
 
-# cross compilers uses full cpu_target, not just ppc-suffix.
+# cross compilers uses full cpu_target, not just ppc-suffix
+# (except if the target cannot run a native compiler)
 ifdef CROSSCOMPILE
+ifneq ($(CPU_TARGET),jvm)
 PPPRE=ppcross
 else
 PPPRE=ppc
 endif
+else
+PPPRE=ppc
+endif
 
 PPNEW=$(BASEDIR)/compiler/$(PPPRE)$(PPSUF)$(SRCEXEEXT)
 endif
@@ -157,14 +165,16 @@ endif
 endif
 endif
 
+# CPU targets for which we only build the compiler/rtl
+BuildOnlyBaseCPUs=jvm
+
 ifneq ($(wildcard utils),)
-NOUTILSTARGETS=embedded gba
+NOUTILSTARGETS=embedded gba $(BuildOnlyBaseCPUs)
 ifeq ($(findstring $(OS_TARGET),$(NOUTILSTARGETS)),)
 UTILS=1
 endif
 endif
 
-
 [rules]
 .NOTPARALLEL:
 
@@ -214,7 +224,14 @@ BUILDSTAMP=build-stamp.$(FULL_TARGET)
 
 .PHONY: all clean distclean build buildbase install installbase installother zipinstallbase zipinstallotherzipinstall singlezipinstall
 
+
+ifeq ($(findstring $(CPU_TARGET),$(BuildOnlyBaseCPUs)),)
 all: build
+install: installall
+else
+all: buildbase
+install: installbase
+endif
 
 clean: $(addsuffix _distclean,$(TARGET_DIRS))
         -$(DEL) build-stamp.*
@@ -258,7 +275,7 @@ base.$(BUILDSTAMP):
         $(MAKE) rtl_$(ALLTARGET) $(BUILDOPTS)
         $(ECHOREDIR) Build > base.$(BUILDSTAMP)
 
-installbase:
+installbase: base.$(BUILDSTAMP)
 # create dirs
         $(MKDIR) $(INSTALL_BASEDIR)
         $(MKDIR) $(INSTALL_BINDIR)
@@ -288,9 +305,11 @@ ifdef IDE
 endif
 
 
-install: $(BUILDSTAMP)
+installall: $(BUILDSTAMP)
         $(MAKE) installbase $(INSTALLOPTS)
+ifeq ($(findstring $(CPU_TARGET), $(BuildOnlyBaseCPUs)),)
         $(MAKE) installother $(INSTALLOPTS)
+endif
 
 singlezipinstall: zipinstall
 zipinstall: $(BUILDSTAMP)

compiler/Makefile

@@ -2,7 +2,7 @@
 # Don't edit, this file is generated by FPCMake Version 2.0.0 [2012/04/25]
 #
 default: all
-MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-haiku i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian i386-nativent i386-iphonesim m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos powerpc-embedded powerpc-wii powerpc-aix sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-netbsd x86_64-solaris x86_64-openbsd x86_64-darwin x86_64-win64 x86_64-embedded arm-linux arm-palmos arm-darwin arm-wince arm-gba arm-nds arm-embedded arm-symbian powerpc64-linux powerpc64-darwin powerpc64-embedded powerpc64-aix avr-embedded armeb-linux armeb-embedded mips-linux mipsel-linux
+MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-haiku i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian i386-nativent i386-iphonesim m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos powerpc-embedded powerpc-wii powerpc-aix sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-netbsd x86_64-solaris x86_64-openbsd x86_64-darwin x86_64-win64 x86_64-embedded arm-linux arm-palmos arm-darwin arm-wince arm-gba arm-nds arm-embedded arm-symbian powerpc64-linux powerpc64-darwin powerpc64-embedded powerpc64-aix avr-embedded armeb-linux armeb-embedded mips-linux mipsel-linux jvm-java jvm-android
 BSDs = freebsd netbsd openbsd darwin
 UNIXs = linux $(BSDs) solaris qnx haiku aix
 LIMIT83fs = go32v2 os2 emx watcom
@@ -258,11 +258,13 @@ ifndef BINUTILSPREFIX
 ifndef CROSSBINDIR
 ifdef CROSSCOMPILE
 ifndef DARWIN2DARWIN
+ifneq ($(CPU_TARGET),jvm)
 BINUTILSPREFIX=$(CPU_TARGET)-$(OS_TARGET)-
 endif
 endif
 endif
 endif
+endif
 UNITSDIR:=$(wildcard $(FPCDIR)/units/$(TARGETSUFFIX))
 ifeq ($(UNITSDIR),)
 UNITSDIR:=$(wildcard $(FPCDIR)/units/$(OS_TARGET))
@@ -296,7 +298,7 @@ override PACKAGE_NAME=compiler
 override PACKAGE_VERSION=2.7.1
 unexport FPC_VERSION FPC_COMPILERINFO
 CYCLETARGETS=i386 powerpc sparc arm x86_64 powerpc64 m68k armeb mipsel mips avr
-ALLTARGETS=$(CYCLETARGETS)
+ALLTARGETS=$(CYCLETARGETS) jvm
 ifdef ALPHA
 PPC_TARGET=alpha
 endif
@@ -333,6 +335,9 @@ endif
 ifdef AVR
 PPC_TARGET=avr
 endif
+ifdef JVM
+PPC_TARGET=jvm
+endif
 ifndef PPC_TARGET
 PPC_TARGET=$(CPU_TARGET)
 endif
@@ -392,6 +397,9 @@ endif
 ifeq ($(CPC_TARGET),avr)
 CPUSUF=avr
 endif
+ifeq ($(CPC_TARGET),jvm)
+CPUSUF=jvm
+endif
 NOCPUDEF=1
 MSGFILE=msg/error$(FPCLANG).msg
 SVNVERSION:=$(wildcard $(addsuffix /svnversion$(SRCEXEEXT),$(SEARCHPATH)))
@@ -440,6 +448,9 @@ endif
 ifeq ($(PPC_TARGET),mipsel)
 override LOCALOPT+=-Fumips
 endif
+ifeq ($(PPC_TARGET),jvm)
+override LOCALOPT+=-Fujvm -dNOOPT
+endif
 OPTWPOCOLLECT=-OWdevirtcalls,optvmts -FW$(BASEDIR)/pp1.wpo
 OPTWPOPERFORM=-Owdevirtcalls,optvmts -Fw$(BASEDIR)/pp1.wpo
 ifneq ($(findstring $(OS_TARGET),darwin linux freebsd solaris),)
@@ -450,6 +461,15 @@ OPTWPOPERFORM+=-Owsymbolliveness
 endif
 endif
 endif
+ifeq ($(CPU_TARGET),jvm)
+NoNativeBinaries=1
+endif
+ifeq ($(OS_TARGET),embedded)
+NoNativeBinaries=1
+endif
+ifeq ($(OS_TARGET),gba)
+NoNativeBinaries=1
+endif
 ifeq ($(FULL_TARGET),i386-linux)
 override TARGET_DIRS+=utils
 endif
@@ -654,6 +674,12 @@ endif
 ifeq ($(FULL_TARGET),mipsel-linux)
 override TARGET_DIRS+=utils
 endif
+ifeq ($(FULL_TARGET),jvm-java)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),jvm-android)
+override TARGET_DIRS+=utils
+endif
 ifeq ($(FULL_TARGET),i386-linux)
 override TARGET_PROGRAMS+=pp
 endif
@@ -858,6 +884,12 @@ endif
 ifeq ($(FULL_TARGET),mipsel-linux)
 override TARGET_PROGRAMS+=pp
 endif
+ifeq ($(FULL_TARGET),jvm-java)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),jvm-android)
+override TARGET_PROGRAMS+=pp
+endif
 override INSTALL_FPCPACKAGE=y
 ifeq ($(FULL_TARGET),i386-linux)
 override COMPILER_INCLUDEDIR+=$(CPC_TARGET)
@@ -1063,6 +1095,12 @@ endif
 ifeq ($(FULL_TARGET),mipsel-linux)
 override COMPILER_INCLUDEDIR+=$(CPC_TARGET)
 endif
+ifeq ($(FULL_TARGET),jvm-java)
+override COMPILER_INCLUDEDIR+=$(CPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),jvm-android)
+override COMPILER_INCLUDEDIR+=$(CPC_TARGET)
+endif
 ifeq ($(FULL_TARGET),i386-linux)
 override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
 endif
@@ -1267,6 +1305,12 @@ endif
 ifeq ($(FULL_TARGET),mipsel-linux)
 override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
 endif
+ifeq ($(FULL_TARGET),jvm-java)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),jvm-android)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
 ifeq ($(FULL_TARGET),i386-linux)
 override COMPILER_TARGETDIR+=.
 endif
@@ -1471,6 +1515,12 @@ endif
 ifeq ($(FULL_TARGET),mipsel-linux)
 override COMPILER_TARGETDIR+=.
 endif
+ifeq ($(FULL_TARGET),jvm-java)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),jvm-android)
+override COMPILER_TARGETDIR+=.
+endif
 ifeq ($(FULL_TARGET),i386-linux)
 override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
 endif
@@ -1675,6 +1725,12 @@ endif
 ifeq ($(FULL_TARGET),mipsel-linux)
 override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
 endif
+ifeq ($(FULL_TARGET),jvm-java)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),jvm-android)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
 ifdef REQUIRE_UNITSDIR
 override UNITSDIR+=$(REQUIRE_UNITSDIR)
 endif
@@ -2032,6 +2088,18 @@ BATCHEXT=.sh
 EXEEXT=
 SHORTSUFFIX=aix
 endif
+ifeq ($(OS_TARGET),java)
+OEXT=.class
+ASMEXT=.j
+SHAREDLIBEXT=.jar
+SHORTSUFFIX=java
+endif
+ifeq ($(OS_TARGET),android)
+OEXT=.class
+ASMEXT=.j
+SHAREDLIBEXT=.jar
+SHORTSUFFIX=android
+endif
 ifneq ($(findstring $(OS_SOURCE),$(LIMIT83fs)),)
 FPCMADE=fpcmade.$(SHORTSUFFIX)
 ZIPSUFFIX=$(SHORTSUFFIX)
@@ -2478,6 +2546,12 @@ endif
 ifeq ($(FULL_TARGET),mipsel-linux)
 REQUIRE_PACKAGES_RTL=1
 endif
+ifeq ($(FULL_TARGET),jvm-java)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),jvm-android)
+REQUIRE_PACKAGES_RTL=1
+endif
 ifdef REQUIRE_PACKAGES_RTL
 PACKAGEDIR_RTL:=$(firstword $(subst /Makefile.fpc,,$(strip $(wildcard $(addsuffix /rtl/Makefile.fpc,$(PACKAGESDIR))))))
 ifneq ($(PACKAGEDIR_RTL),)
@@ -3313,6 +3387,12 @@ endif
 ifeq ($(FULL_TARGET),mipsel-linux)
 TARGET_DIRS_UTILS=1
 endif
+ifeq ($(FULL_TARGET),jvm-java)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),jvm-android)
+TARGET_DIRS_UTILS=1
+endif
 ifdef TARGET_DIRS_UTILS
 utils_all:
 	$(MAKE) -C utils all
@@ -3424,7 +3504,11 @@ EXENAME=ppc$(CPUSUF)$(EXEEXT)
 endif
 PPEXENAME=pp$(EXEEXT)
 TEMPNAME=ppc$(SRCEXEEXT)
+ifneq ($(CPUSUF),jvm)
 PPCROSSNAME=ppcross$(CPUSUF)$(SRCEXEEXT)
+else
+PPCROSSNAME=ppc$(CPUSUF)$(SRCEXEEXT)
+endif
 TEMPNAME1=ppc1$(EXEEXT)
 TEMPNAME2=ppc2$(EXEEXT)
 TEMPNAME3=ppc3$(EXEEXT)
@@ -3437,7 +3521,7 @@ INSTALLEXEFILE=$(PPCROSSNAME)
 else
 INSTALLEXEFILE=$(EXENAME)
 endif
-PPC_TARGETS=i386 m68k powerpc sparc arm armeb x86_64 powerpc64 alpha vis ia64 mips mipsel avr
+PPC_TARGETS=i386 m68k powerpc sparc arm armeb x86_64 powerpc64 alpha vis ia64 mips mipsel avr jvm
 INSTALL_TARGETS=$(addsuffix _exe_install,$(sort $(CYCLETARGETS) $(PPC_TARGETS)))
 .PHONY: $(PPC_TARGETS) $(INSTALL_TARGETS)
 $(PPC_TARGETS):
@@ -3472,11 +3556,11 @@ ppuclean:
 tempclean:
 	-$(DEL) $(PPCROSSNAME) $(TEMPNAME) $(TEMPNAME1) $(TEMPNAME2) $(TEMPNAME3) $(MSG2INC) pp1.wpo pp2.wpo
 execlean :
-	-$(DEL) ppc386$(EXEEXT) ppc68k$(EXEEXT) ppcx64$(EXEEXT) ppcppc$(EXEEXT) ppcsparc$(EXEEXT) ppcppc64$(EXEEXT) ppcarm$(EXEEXT) ppcmips$(EXEEXT) ppcmipsel$(EXEEXT) $(EXENAME) $(TEMPWPONAME1) $(TEMPWPONAME2)
+	-$(DEL) ppc386$(EXEEXT) ppc68k$(EXEEXT) ppcx64$(EXEEXT) ppcppc$(EXEEXT) ppcsparc$(EXEEXT) ppcppc64$(EXEEXT) ppcarm$(EXEEXT) ppcmips$(EXEEXT) ppcmipsel$(EXEEXT) ppcjvm$(EXEEXT) $(EXENAME) $(TEMPWPONAME1) $(TEMPWPONAME2)
 $(addsuffix _clean,$(ALLTARGETS)):
 	-$(DELTREE) $(addprefix $(subst _clean,,$@),/units)
 	-$(DEL) $(addprefix $(subst _clean,,$@)/,*$(OEXT) *$(PPUEXT) *$(RSTEXT) *$(ASMEXT) *$(STATICLIBEXT) *$(SHAREDLIBEXT) *$(PPLEXT))
-	-$(DEL) $(addprefix $(subst _clean,,$@)/,ppc386$(EXEEXT) ppc68k$(EXEEXT) ppcx64$(EXEEXT) ppcppc$(EXEEXT) ppcsparc$(EXEEXT) ppcppc64$(EXEEXT) ppcarm$(EXEEXT) ppcmips$(EXEEXT) ppcmipsel$(EXEEXT) $(EXENAME))
+	-$(DEL) $(addprefix $(subst _clean,,$@)/,ppc386$(EXEEXT) ppc68k$(EXEEXT) ppcx64$(EXEEXT) ppcppc$(EXEEXT) ppcsparc$(EXEEXT) ppcppc64$(EXEEXT) ppcarm$(EXEEXT) ppcmips$(EXEEXT) ppcmipsel$(EXEEXT) ppcjvm$(EXEEXT)  $(EXENAME))
 cycleclean: cleanall $(addsuffix _clean,$(CPC_TARGET))
 	-$(DEL) $(EXENAME)
 clean: tempclean execlean cleanall $(addsuffix _clean,$(CPC_TARGET)) $(addsuffix _clean,$(TARGET_DIRS))
@@ -3632,13 +3716,11 @@ cycle:
 	$(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME)' OS_TARGET=$(OS_SOURCE) CPU_TARGET=$(CPU_SOURCE) PPC_TARGET=$(CPU_TARGET) EXENAME=$(PPCROSSNAME) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 cycleclean compiler
 ifndef CROSSINSTALL
 	$(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' 'OPT=$(RTLOPT) $(CROSSOPT)' rtlclean rtl
-ifneq ($(OS_TARGET),embedded)
-ifneq ($(OS_TARGET),gba)
+ifndef NoNativeBinaries
 	$(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' 'OPT=$(LOCALOPT) $(CROSSOPT)' cycleclean compiler
 endif
 endif
 endif
-endif
 cycledep:
 	$(MAKE) cycle USEDEPEND=1
 extcycle:
@@ -3660,8 +3742,12 @@ PPCCPULOCATION=$(INSTALL_BASEDIR)
 else
 PPCCPULOCATION=$(INSTALL_BINDIR)
 endif
-quickinstall: $(addsuffix _install,$(TARGET_DIRS))
-	$(MAKE) exeinstall
+ifndef NoNativeBinaries
+quickinstall: quickinstall_withutils
+else
+quickinstall: exeinstall
+endif
+quickinstall_withutils: $(addsuffix _install,$(TARGET_DIRS)) exeinstall
 exeinstall:
 ifneq ($(INSTALLEXEFILE),)
 ifdef UPXPROG

compiler/Makefile.fpc

@@ -35,9 +35,9 @@ unexport FPC_VERSION FPC_COMPILERINFO
 CYCLETARGETS=i386 powerpc sparc arm x86_64 powerpc64 m68k armeb mipsel mips avr
 
 # All supported targets used for clean
-ALLTARGETS=$(CYCLETARGETS)
+ALLTARGETS=$(CYCLETARGETS) jvm
 
-# Allow ALPHA, POWERPC, POWERPC64, M68K, I386 defines for target cpu
+# Allow ALPHA, POWERPC, POWERPC64, M68K, I386, jvm defines for target cpu
 ifdef ALPHA
 PPC_TARGET=alpha
 endif
@@ -74,6 +74,9 @@ endif
 ifdef AVR
 PPC_TARGET=avr
 endif
+ifdef JVM
+PPC_TARGET=jvm
+endif
 
 # Default is to generate a compiler for the same
 # platform as CPU_TARGET (a native compiler)
@@ -160,6 +163,9 @@ endif
 ifeq ($(CPC_TARGET),avr)
 CPUSUF=avr
 endif
+ifeq ($(CPC_TARGET),jvm)
+CPUSUF=jvm
+endif
 
 # Do not define the default -d$(CPU_TARGET) because that
 # will conflict with our -d$(CPC_TARGET)
@@ -241,6 +247,10 @@ ifeq ($(PPC_TARGET),mipsel)
 override LOCALOPT+=-Fumips
 endif
 
+# jvm specific
+ifeq ($(PPC_TARGET),jvm)
+override LOCALOPT+=-Fujvm -dNOOPT
+endif
 
 OPTWPOCOLLECT=-OWdevirtcalls,optvmts -FW$(BASEDIR)/pp1.wpo
 OPTWPOPERFORM=-Owdevirtcalls,optvmts -Fw$(BASEDIR)/pp1.wpo
@@ -255,6 +265,17 @@ endif
 endif
 endif
 
+# Don't compile a native compiler & utilities for JVM and embedded
+# targets
+ifeq ($(CPU_TARGET),jvm)
+NoNativeBinaries=1
+endif
+ifeq ($(OS_TARGET),embedded)
+NoNativeBinaries=1
+endif
+ifeq ($(OS_TARGET),gba)
+NoNativeBinaries=1
+endif
 
 [rules]
 #####################################################################
@@ -307,7 +328,11 @@ EXENAME=ppc$(CPUSUF)$(EXEEXT)
 endif
 PPEXENAME=pp$(EXEEXT)
 TEMPNAME=ppc$(SRCEXEEXT)
+ifneq ($(CPUSUF),jvm)
 PPCROSSNAME=ppcross$(CPUSUF)$(SRCEXEEXT)
+else
+PPCROSSNAME=ppc$(CPUSUF)$(SRCEXEEXT)
+endif
 TEMPNAME1=ppc1$(EXEEXT)
 TEMPNAME2=ppc2$(EXEEXT)
 TEMPNAME3=ppc3$(EXEEXT)
@@ -325,7 +350,7 @@ endif
 # CPU targets
 #####################################################################
 
-PPC_TARGETS=i386 m68k powerpc sparc arm armeb x86_64 powerpc64 alpha vis ia64 mips mipsel avr
+PPC_TARGETS=i386 m68k powerpc sparc arm armeb x86_64 powerpc64 alpha vis ia64 mips mipsel avr jvm
 INSTALL_TARGETS=$(addsuffix _exe_install,$(sort $(CYCLETARGETS) $(PPC_TARGETS)))
 
 .PHONY: $(PPC_TARGETS) $(INSTALL_TARGETS)
@@ -380,12 +405,12 @@ tempclean:
         -$(DEL) $(PPCROSSNAME) $(TEMPNAME) $(TEMPNAME1) $(TEMPNAME2) $(TEMPNAME3) $(MSG2INC) pp1.wpo pp2.wpo
 
 execlean :
-        -$(DEL) ppc386$(EXEEXT) ppc68k$(EXEEXT) ppcx64$(EXEEXT) ppcppc$(EXEEXT) ppcsparc$(EXEEXT) ppcppc64$(EXEEXT) ppcarm$(EXEEXT) ppcmips$(EXEEXT) ppcmipsel$(EXEEXT) $(EXENAME) $(TEMPWPONAME1) $(TEMPWPONAME2)
+        -$(DEL) ppc386$(EXEEXT) ppc68k$(EXEEXT) ppcx64$(EXEEXT) ppcppc$(EXEEXT) ppcsparc$(EXEEXT) ppcppc64$(EXEEXT) ppcarm$(EXEEXT) ppcmips$(EXEEXT) ppcmipsel$(EXEEXT) ppcjvm$(EXEEXT) $(EXENAME) $(TEMPWPONAME1) $(TEMPWPONAME2)
 
 $(addsuffix _clean,$(ALLTARGETS)):
         -$(DELTREE) $(addprefix $(subst _clean,,$@),/units)
         -$(DEL) $(addprefix $(subst _clean,,$@)/,*$(OEXT) *$(PPUEXT) *$(RSTEXT) *$(ASMEXT) *$(STATICLIBEXT) *$(SHAREDLIBEXT) *$(PPLEXT))
-        -$(DEL) $(addprefix $(subst _clean,,$@)/,ppc386$(EXEEXT) ppc68k$(EXEEXT) ppcx64$(EXEEXT) ppcppc$(EXEEXT) ppcsparc$(EXEEXT) ppcppc64$(EXEEXT) ppcarm$(EXEEXT) ppcmips$(EXEEXT) ppcmipsel$(EXEEXT) $(EXENAME))
+        -$(DEL) $(addprefix $(subst _clean,,$@)/,ppc386$(EXEEXT) ppc68k$(EXEEXT) ppcx64$(EXEEXT) ppcppc$(EXEEXT) ppcsparc$(EXEEXT) ppcppc64$(EXEEXT) ppcarm$(EXEEXT) ppcmips$(EXEEXT) ppcmipsel$(EXEEXT) ppcjvm$(EXEEXT)  $(EXENAME))
 
 cycleclean: cleanall $(addsuffix _clean,$(CPC_TARGET))
         -$(DEL) $(EXENAME)
@@ -628,14 +653,11 @@ cycle:
 # ppc<ARCH> (target native)
 ifndef CROSSINSTALL
         $(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' 'OPT=$(RTLOPT) $(CROSSOPT)' rtlclean rtl
-# building a native compiler for embedded targets is not possible
-ifneq ($(OS_TARGET),embedded)
-# building a native compiler for the arm-gba target is not possible
-ifneq ($(OS_TARGET),gba)
+# building a native compiler for JVM and embedded targets is not possible
+ifndef NoNativeBinaries
         $(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' 'OPT=$(LOCALOPT) $(CROSSOPT)' cycleclean compiler
 endif
 endif
-endif
 
 endif
 
@@ -687,9 +709,14 @@ else
 PPCCPULOCATION=$(INSTALL_BINDIR)
 endif
 
+ifndef NoNativeBinaries
+quickinstall: quickinstall_withutils
+else
+quickinstall: exeinstall
+endif
+
 # This will only install the ppcXXX executable, not the message files etc.
-quickinstall: $(addsuffix _install,$(TARGET_DIRS))
-	$(MAKE) exeinstall
+quickinstall_withutils: $(addsuffix _install,$(TARGET_DIRS)) exeinstall
 
 # Install ppcXXX executable, for a cross installation we install
 # the ppcrossXXX as ppcXXX. The target native build ppcXXX is not used

compiler/aasmbase.pas

@@ -159,7 +159,7 @@ interface
          altsymbol  : TAsmSymbol;
          { Cached objsymbol }
          cachedobjsymbol : TObject;
-         constructor Create(AList:TFPHashObjectList;const s:string;_bind:TAsmsymbind;_typ:Tasmsymtype);
+         constructor Create(AList:TFPHashObjectList;const s:TSymStr;_bind:TAsmsymbind;_typ:Tasmsymtype);
          function getaltcopy(AList:TFPHashObjectList;altnr: longint): TAsmSymbol; virtual;
          function  is_used:boolean;
          procedure increfs;
@@ -170,13 +170,13 @@ interface
 
        TAsmLabel = class(TAsmSymbol)
        protected
-         function getname:string;override;
+         function getname:TSymStr;override;
        public
          labelnr   : longint;
          labeltype : TAsmLabelType;
          is_set    : boolean;
          constructor Createlocal(AList:TFPHashObjectList;nr:longint;ltyp:TAsmLabelType);
-         constructor Createglobal(AList:TFPHashObjectList;const modulename:string;nr:longint;ltyp:TAsmLabelType);
+         constructor Createglobal(AList:TFPHashObjectList;const modulename:TSymStr;nr:longint;ltyp:TAsmLabelType);
          function getaltcopy(AList:TFPHashObjectList;altnr: longint): TAsmSymbol; override;
        end;
 
@@ -347,7 +347,7 @@ implementation
                                  TAsmSymbol
 *****************************************************************************}
 
-    constructor TAsmSymbol.Create(AList:TFPHashObjectList;const s:string;_bind:TAsmsymbind;_typ:Tasmsymtype);
+    constructor TAsmSymbol.Create(AList:TFPHashObjectList;const s:TSymStr;_bind:TAsmsymbind;_typ:Tasmsymtype);
       begin;
         inherited Create(AList,s);
         bind:=_bind;
@@ -412,7 +412,7 @@ implementation
       end;
 
 
-    constructor TAsmLabel.Createglobal(AList:TFPHashObjectList;const modulename:string;nr:longint;ltyp:TAsmLabelType);
+    constructor TAsmLabel.Createglobal(AList:TFPHashObjectList;const modulename:TSymStr;nr:longint;ltyp:TAsmLabelType);
       begin
         inherited Create(AList,'_$'+modulename+'$_L'+asmlabeltypeprefix[ltyp]+tostr(nr),AB_GLOBAL,AT_DATA);
         labelnr:=nr;
@@ -441,7 +441,7 @@ implementation
       end;
 
 
-    function TAsmLabel.getname:string;
+    function TAsmLabel.getname:TSymStr;
       begin
         getname:=inherited getname;
         increfs;

compiler/aasmdata.pas

@@ -165,11 +165,11 @@ interface
         constructor create(const n:string);
         destructor  destroy;override;
         { asmsymbol }
-        function  DefineAsmSymbolByClass(symclass: TAsmSymbolClass; const s : string;_bind:TAsmSymBind;_typ:Tasmsymtype) : TAsmSymbol;
-        function  DefineAsmSymbol(const s : string;_bind:TAsmSymBind;_typ:Tasmsymtype) : TAsmSymbol;
-        function  WeakRefAsmSymbol(const s : string) : TAsmSymbol;
-        function  RefAsmSymbol(const s : string) : TAsmSymbol;
-        function  GetAsmSymbol(const s : string) : TAsmSymbol;
+        function  DefineAsmSymbolByClass(symclass: TAsmSymbolClass; const s : TSymStr;_bind:TAsmSymBind;_typ:Tasmsymtype) : TAsmSymbol;
+        function  DefineAsmSymbol(const s : TSymStr;_bind:TAsmSymBind;_typ:Tasmsymtype) : TAsmSymbol;
+        function  WeakRefAsmSymbol(const s : TSymStr) : TAsmSymbol;
+        function  RefAsmSymbol(const s : TSymStr) : TAsmSymbol;
+        function  GetAsmSymbol(const s : TSymStr) : TAsmSymbol;
         { create new assembler label }
         procedure getlabel(out l : TAsmLabel;alt:TAsmLabeltype);
         procedure getjumplabel(out l : TAsmLabel);
@@ -403,7 +403,7 @@ implementation
       end;
 
 
-    function TAsmData.DefineAsmSymbolByClass(symclass: TAsmSymbolClass; const s : string;_bind:TAsmSymBind;_typ:Tasmsymtype) : TAsmSymbol;
+    function TAsmData.DefineAsmSymbolByClass(symclass: TAsmSymbolClass; const s : TSymStr;_bind:TAsmSymBind;_typ:Tasmsymtype) : TAsmSymbol;
       var
         hp : TAsmSymbol;
       begin
@@ -430,13 +430,13 @@ implementation
       end;
 
 
-    function TAsmData.DefineAsmSymbol(const s : string;_bind:TAsmSymBind;_typ:Tasmsymtype) : TAsmSymbol;
+    function TAsmData.DefineAsmSymbol(const s : TSymStr;_bind:TAsmSymBind;_typ:Tasmsymtype) : TAsmSymbol;
       begin
         result:=DefineAsmSymbolByClass(TAsmSymbol,s,_bind,_typ);
       end;
 
 
-    function TAsmData.RefAsmSymbol(const s : string) : TAsmSymbol;
+    function TAsmData.RefAsmSymbol(const s : TSymStr) : TAsmSymbol;
       begin
         result:=TAsmSymbol(FAsmSymbolDict.Find(s));
         if not assigned(result) then
@@ -447,7 +447,7 @@ implementation
       end;
 
 
-    function TAsmData.WeakRefAsmSymbol(const s : string) : TAsmSymbol;
+    function TAsmData.WeakRefAsmSymbol(const s : TSymStr) : TAsmSymbol;
       begin
         result:=TAsmSymbol(FAsmSymbolDict.Find(s));
         if not assigned(result) then
@@ -455,7 +455,7 @@ implementation
       end;
 
 
-    function TAsmData.GetAsmSymbol(const s : string) : TAsmSymbol;
+    function TAsmData.GetAsmSymbol(const s : TSymStr) : TAsmSymbol;
       begin
         result:=TAsmSymbol(FAsmSymbolDict.Find(s));
       end;

compiler/aasmtai.pas

@@ -37,7 +37,11 @@ interface
        cpuinfo,cpubase,
        cgbase,cgutils,
        symtype,
-       aasmbase,aasmdata,ogbase;
+       aasmbase,aasmdata,ogbase
+{$ifdef jvm}
+       ,widestr
+{$endif jvm}
+       ;
 
     type
        { keep the number of elements in this enumeration less or equal than 32 as long
@@ -88,7 +92,10 @@ interface
           { used to describe a new location of a variable }
           ait_varloc,
           { SEH directives used in ARM,MIPS and x86_64 COFF targets }
-          ait_seh_directive
+          ait_seh_directive,
+          { JVM only }
+          ait_jvar,    { debug information for a local variable }
+          ait_jcatch   { exception catch clause }
           );
 
         taiconst_type = (
@@ -176,7 +183,9 @@ interface
           'tempalloc',
           'marker',
           'varloc',
-          'seh_directive'
+          'seh_directive',
+          'jvar',
+          'jcatch'
           );
 
     type
@@ -193,7 +202,14 @@ interface
        { m68k only }
        ,top_regset
 {$endif m68k}
-       { i386 only});
+{$ifdef jvm}
+       { jvm only}
+       ,top_single
+       ,top_double
+       ,top_string
+       ,top_wstring
+{$endif jvm}
+       );
 
       { kinds of operations that an instruction can perform on an operand }
       topertype = (operand_read,operand_write,operand_readwrite);
@@ -229,6 +245,12 @@ interface
       {$ifdef m68k}
           top_regset : (regset:^tcpuregisterset);
       {$endif m68k}
+      {$ifdef jvm}
+          top_single : (sval:single);
+          top_double : (dval:double);
+          top_string : (pcvallen: aint; pcval: pchar);
+          top_wstring : (pwstrval: pcompilerwidestring);
+      {$endif jvm}
       end;
       poper=^toper;
 
@@ -240,7 +262,8 @@ interface
       SkipInstr = [ait_comment, ait_symbol,ait_section
                    ,ait_stab, ait_function_name, ait_force_line
                    ,ait_regalloc, ait_tempalloc, ait_symbol_end, ait_directive
-                   ,ait_varloc,ait_seh_directive];
+                   ,ait_varloc,ait_seh_directive
+                   ,ait_jvar, ait_jcatch];
 
       { ait_* types which do not have line information (and hence which are of type
         tai, otherwise, they are of type tailineinfo }
@@ -248,13 +271,14 @@ interface
                      ait_regalloc,ait_tempalloc,
                      ait_stab,ait_function_name,
                      ait_cutobject,ait_marker,ait_varloc,ait_align,ait_section,ait_comment,
-                     ait_const,
+                     ait_const,ait_directive,
 {$ifdef arm}
                      ait_thumb_func,
 {$endif arm}
                      ait_real_32bit,ait_real_64bit,ait_real_80bit,ait_comp_64bit,ait_real_128bit,
                      ait_symbol,
-                     ait_seh_directive
+                     ait_seh_directive,
+                     ait_jvar,ait_jcatch
                     ];
 
 
@@ -287,7 +311,9 @@ interface
         asd_indirect_symbol,
         asd_extern,asd_nasm_import, asd_toc_entry,
         asd_reference,asd_no_dead_strip,asd_weak_reference,asd_lazy_reference,
-        asd_weak_definition
+        asd_weak_definition,
+        { for Jasmin }
+        asd_jclass,asd_jinterface,asd_jsuper,asd_jfield,asd_jlimit,asd_jline
       );
 
       TAsmSehDirective=(
@@ -312,7 +338,9 @@ interface
       directivestr : array[TAsmDirective] of string[23]=(
         'indirect_symbol',
         'extern','nasm_import', 'tc', 'reference',
-        'no_dead_strip','weak_reference','lazy_reference','weak_definition'
+        'no_dead_strip','weak_reference','lazy_reference','weak_definition',
+        { for Jasmin }
+        'class','interface','super','field','limit','line'
       );
       sehdirectivestr : array[TAsmSehDirective] of string[16]=(
         '.seh_proc','.seh_endproc',
@@ -723,6 +751,31 @@ interface
         end;
         tai_seh_directive_class=class of tai_seh_directive;
 
+        { JVM variable live range description }
+        tai_jvar = class(tai)
+          stackslot: longint;
+          desc: pshortstring;
+          startlab,stoplab: tasmsymbol;
+
+          constructor Create(_stackslot: longint; const _desc: shortstring; _startlab, _stoplab: TAsmSymbol);
+          constructor ppuload(t:taitype;ppufile:tcompilerppufile);override;
+          procedure ppuwrite(ppufile:tcompilerppufile);override;
+          destructor destroy;override;
+        end;
+        tai_jvar_class = class of tai_jvar;
+
+        { JVM exception catch description }
+        tai_jcatch = class(tai)
+          name: pshortstring;
+          startlab,stoplab,handlerlab: tasmsymbol;
+
+          constructor Create(const _name: shortstring; _startlab, _stoplab, _handlerlab: TAsmSymbol);
+          destructor destroy;override;
+          constructor ppuload(t:taitype;ppufile:tcompilerppufile);override;
+          procedure ppuwrite(ppufile:tcompilerppufile);override;
+        end;
+        tai_jcatch_class = class of tai_jcatch;
+
     var
       { array with all class types for tais }
       aiclass : taiclassarray;
@@ -2232,6 +2285,12 @@ implementation
               top_regset:
                 dispose(regset);
 {$endif ARM}
+{$ifdef jvm}
+              top_string:
+                freemem(pcval);
+              top_wstring:
+                donewidestring(pwstrval);
+{$endif jvm}
             end;
             typ:=top_none;
           end;
@@ -2544,6 +2603,7 @@ implementation
         ppufile.putbyte(byte(use_op));
       end;
 
+
 {****************************************************************************
                               tai_seh_directive
  ****************************************************************************}
@@ -2654,6 +2714,97 @@ implementation
       begin
       end;
 
+
+{****************************************************************************
+                              tai_jvar
+ ****************************************************************************}
+
+    constructor tai_jvar.Create(_stackslot: longint; const _desc: shortstring; _startlab, _stoplab: TAsmSymbol);
+      begin
+        Inherited create;
+        typ:=ait_jvar;
+        stackslot:=_stackslot;
+        desc:=stringdup(_desc);
+        startlab:=_startlab;
+        stoplab:=_stoplab;
+      end;
+
+
+    constructor tai_jvar.ppuload(t: taitype; ppufile: tcompilerppufile);
+      begin
+        inherited ppuload(t, ppufile);
+        stackslot:=ppufile.getlongint;
+        desc:=stringdup(ppufile.getstring);
+        startlab:=ppufile.getasmsymbol;
+        stoplab:=ppufile.getasmsymbol;
+      end;
+
+
+    procedure tai_jvar.ppuwrite(ppufile: tcompilerppufile);
+      begin
+        inherited ppuwrite(ppufile);
+        ppufile.putlongint(stackslot);
+        ppufile.putstring(desc^);
+        ppufile.putasmsymbol(startlab);
+        ppufile.putasmsymbol(stoplab);
+      end;
+
+
+    destructor tai_jvar.destroy;
+      begin
+        stringdispose(desc);
+        inherited destroy;
+      end;
+
+
+{****************************************************************************
+                              tai_jcatch
+ ****************************************************************************}
+
+    constructor tai_jcatch.Create(const _name: shortstring; _startlab, _stoplab, _handlerlab: TAsmSymbol);
+      begin
+        Inherited create;
+        typ:=ait_jcatch;
+        name:=stringdup(_name);
+        startlab:=_startlab;
+        startlab.increfs;
+        stoplab:=_stoplab;
+        stoplab.increfs;
+        handlerlab:=_handlerlab;
+        handlerlab.increfs;
+      end;
+
+
+    destructor tai_jcatch.destroy;
+      begin
+        stringdispose(name);
+        inherited destroy;
+      end;
+
+
+    constructor tai_jcatch.ppuload(t: taitype; ppufile: tcompilerppufile);
+      begin
+        inherited ppuload(t, ppufile);
+        name:=stringdup(ppufile.getstring);
+        startlab:=ppufile.getasmsymbol;
+        startlab.increfs;
+        stoplab:=ppufile.getasmsymbol;
+        stoplab.increfs;
+        handlerlab:=ppufile.getasmsymbol;
+        handlerlab.increfs;
+      end;
+
+
+    procedure tai_jcatch.ppuwrite(ppufile: tcompilerppufile);
+      begin
+        inherited ppuwrite(ppufile);
+        ppufile.putstring(name^);
+        ppufile.putasmsymbol(startlab);
+        ppufile.putasmsymbol(stoplab);
+        ppufile.putasmsymbol(handlerlab);
+      end;
+
+
 begin
 {$push}{$warnings off}
   { taitype should fit into a 4 byte set for speed reasons }

compiler/agjasmin.pas

@@ -0,0 +1,1236 @@
+{
+    Copyright (c) 1998-2010 by the Free Pascal team
+
+    This unit implements the Jasmin assembler writer
+
+    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 for writing Jasmin assembler (JVM bytecode) output.
+}
+unit agjasmin;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+      cclasses,
+      globtype,globals,
+      symconst,symbase,symdef,symsym,
+      aasmbase,aasmtai,aasmdata,aasmcpu,
+      assemble;
+
+    type
+      TJasminInstrWriter = class;
+      {# This is a derived class which is used to write
+         Jasmin-styled assembler.
+      }
+
+      { TJasminAssembler }
+
+      TJasminAssembler=class(texternalassembler)
+       protected
+        jasminjar: tcmdstr;
+        asmfiles: TCmdStrList;
+
+        procedure WriteExtraHeader(obj: tabstractrecorddef);
+        procedure WriteInstruction(hp: tai);
+        procedure NewAsmFileForStructDef(obj: tabstractrecorddef);
+
+        function VisibilityToStr(vis: tvisibility): ansistring;
+        function MethodDefinition(pd: tprocdef): ansistring;
+        function ConstValue(csym: tconstsym): ansistring;
+        function ConstAssignmentValue(csym: tconstsym): ansistring;
+        function ConstDefinition(sym: tconstsym): ansistring;
+        function FieldDefinition(sym: tabstractvarsym): ansistring;
+        function InnerStructDef(obj: tabstractrecorddef): ansistring;
+
+        procedure WriteProcDef(pd: tprocdef);
+        procedure WriteFieldSym(sym: tabstractvarsym);
+        procedure WriteConstSym(sym: tconstsym);
+        procedure WriteSymtableVarSyms(st: TSymtable);
+        procedure WriteSymtableProcdefs(st: TSymtable);
+        procedure WriteSymtableStructDefs(st: TSymtable);
+       public
+        constructor Create(smart: boolean); override;
+        function MakeCmdLine: TCmdStr;override;
+        procedure WriteTree(p:TAsmList);override;
+        procedure WriteAsmList;override;
+        procedure RemoveAsm; override;
+        destructor destroy; override;
+       protected
+        InstrWriter: TJasminInstrWriter;
+      end;
+
+
+      {# This is the base class for writing instructions.
+
+         The WriteInstruction() method must be overridden
+         to write a single instruction to the assembler
+         file.
+      }
+
+      { TJasminInstrWriter }
+
+      TJasminInstrWriter = class
+        constructor create(_owner: TJasminAssembler);
+        procedure WriteInstruction(hp : tai); virtual;
+       protected
+        owner: TJasminAssembler;
+      end;
+
+
+implementation
+
+    uses
+      SysUtils,
+      cutils,cfileutl,systems,script,
+      fmodule,finput,verbose,
+      symtype,symtable,jvmdef,
+      itcpujas,cpubase,cpuinfo,cgutils,
+      widestr
+      ;
+
+    const
+      line_length = 70;
+
+    type
+      t64bitarray = array[0..7] of byte;
+      t32bitarray = array[0..3] of byte;
+
+{****************************************************************************}
+{                          Support routines                                  }
+{****************************************************************************}
+
+   function fixline(s:string):string;
+   {
+     return s with all leading and ending spaces and tabs removed
+   }
+     var
+       i,j,k : integer;
+     begin
+       i:=length(s);
+       while (i>0) and (s[i] in [#9,' ']) do
+        dec(i);
+       j:=1;
+       while (j<i) and (s[j] in [#9,' ']) do
+        inc(j);
+       for k:=j to i do
+        if s[k] in [#0..#31,#127..#255] then
+         s[k]:='.';
+       fixline:=Copy(s,j,i-j+1);
+     end;
+
+
+   function constastr(p: pchar; len: longint): ansistring;
+     var
+       i,runstart,runlen: longint;
+
+       procedure flush;
+         begin
+           if runlen>0 then
+             begin
+               setlength(result,length(result)+runlen);
+               move(p[runstart],result[length(result)-runlen+1],runlen);
+               runlen:=0;
+             end;
+         end;
+
+     begin
+       result:='"';
+       runlen:=0;
+       runstart:=0;
+       for i:=0 to len-1 do
+         begin
+           { escape control codes }
+           case p[i] of
+             { LF and CR must be escaped specially, because \uXXXX parsing
+               happens in the pre-processor, so it's the same as actually
+               inserting a newline in the middle of a string constant }
+             #10:
+               begin
+                 flush;
+                 result:=result+'\n';
+               end;
+             #13:
+               begin
+                 flush;
+                 result:=result+'\r';
+               end;
+             '"','\':
+               begin
+                 flush;
+                 result:=result+'\'+p[i];
+               end
+             else if p[i]<#32 then
+               begin
+                 flush;
+                 result:=result+'\u'+hexstr(ord(p[i]),4);
+               end
+             else if p[i]<#127 then
+               begin
+                 if runlen=0 then
+                   runstart:=i;
+                 inc(runlen);
+               end
+             else
+               begin
+                 { see comments in njvmcon }
+                 flush;
+                 result:=result+'\u'+hexstr(ord(p[i]),4)
+               end;
+           end;
+         end;
+       flush;
+       result:=result+'"';
+     end;
+
+
+   function constwstr(w: pcompilerwidechar; len: longint): ansistring;
+     var
+       i: longint;
+     begin
+       result:='"';
+       for i:=0 to len-1 do
+         begin
+           { escape control codes }
+           case w[i] of
+             10:
+               result:=result+'\n';
+             13:
+               result:=result+'\r';
+             ord('"'),ord('\'):
+               result:=result+'\'+chr(w[i]);
+             else if (w[i]<32) or
+                (w[i]>=127) then
+               result:=result+'\u'+hexstr(w[i],4)
+             else
+               result:=result+char(w[i]);
+           end;
+         end;
+       result:=result+'"';
+     end;
+
+
+   function constsingle(s: single): ansistring;
+     begin
+       result:='0fx'+hexstr(longint(t32bitarray(s)),8);
+     end;
+
+
+   function constdouble(d: double): ansistring;
+      begin
+        // force interpretation as double (since we write it out as an
+        // integer, we never have to swap the endianess). We have to
+        // include the sign separately because of the way Java parses
+        // hex numbers (0x8000000000000000 is not a valid long)
+       result:=hexstr(abs(int64(t64bitarray(d))),16);
+       if int64(t64bitarray(d))<0 then
+         result:='-'+result;
+       result:='0dx'+result;
+      end;
+
+{****************************************************************************}
+{                       Jasmin Assembler writer                              }
+{****************************************************************************}
+
+    destructor TJasminAssembler.Destroy;
+      begin
+        InstrWriter.free;
+        asmfiles.free;
+        inherited destroy;
+      end;
+
+
+    procedure TJasminAssembler.WriteTree(p:TAsmList);
+      var
+        ch       : char;
+        hp       : tai;
+        hp1      : tailineinfo;
+        s        : ansistring;
+        i,pos    : longint;
+        InlineLevel : longint;
+        do_line  : boolean;
+      begin
+        if not assigned(p) then
+         exit;
+
+        InlineLevel:=0;
+        { lineinfo is only needed for al_procedures (PFV) }
+        do_line:=(cs_asm_source in current_settings.globalswitches);
+        hp:=tai(p.first);
+        while assigned(hp) do
+         begin
+           prefetch(pointer(hp.next)^);
+           if not(hp.typ in SkipLineInfo) then
+            begin
+              hp1 := hp as tailineinfo;
+              current_filepos:=hp1.fileinfo;
+               { no line info for inlined code }
+               if do_line and (inlinelevel=0) then
+                begin
+                  { load infile }
+                  if lastfileinfo.fileindex<>hp1.fileinfo.fileindex then
+                   begin
+                     infile:=current_module.sourcefiles.get_file(hp1.fileinfo.fileindex);
+                     if assigned(infile) then
+                      begin
+                        { open only if needed !! }
+                        if (cs_asm_source in current_settings.globalswitches) then
+                         infile.open;
+                      end;
+                     { avoid unnecessary reopens of the same file !! }
+                     lastfileinfo.fileindex:=hp1.fileinfo.fileindex;
+                     { be sure to change line !! }
+                     lastfileinfo.line:=-1;
+                   end;
+
+                { write source }
+                  if (cs_asm_source in current_settings.globalswitches) and
+                     assigned(infile) then
+                   begin
+                     if (infile<>lastinfile) then
+                       begin
+                         AsmWriteLn(target_asm.comment+'['+infile.name^+']');
+                         if assigned(lastinfile) then
+                           lastinfile.close;
+                       end;
+                     if (hp1.fileinfo.line<>lastfileinfo.line) and
+                        ((hp1.fileinfo.line<infile.maxlinebuf) or (InlineLevel>0)) then
+                       begin
+                         if (hp1.fileinfo.line<>0) and
+                            ((infile.linebuf^[hp1.fileinfo.line]>=0) or (InlineLevel>0)) then
+                           AsmWriteLn(target_asm.comment+'['+tostr(hp1.fileinfo.line)+'] '+
+                             fixline(infile.GetLineStr(hp1.fileinfo.line)));
+                         { set it to a negative value !
+                         to make that is has been read already !! PM }
+                         if (infile.linebuf^[hp1.fileinfo.line]>=0) then
+                           infile.linebuf^[hp1.fileinfo.line]:=-infile.linebuf^[hp1.fileinfo.line]-1;
+                       end;
+                   end;
+                  lastfileinfo:=hp1.fileinfo;
+                  lastinfile:=infile;
+                end;
+            end;
+
+           case hp.typ of
+
+             ait_comment :
+               Begin
+                 AsmWrite(target_asm.comment);
+                 AsmWritePChar(tai_comment(hp).str);
+                 AsmLn;
+               End;
+
+             ait_regalloc :
+               begin
+                 if (cs_asm_regalloc in current_settings.globalswitches) then
+                   begin
+                     AsmWrite(#9+target_asm.comment+'Register ');
+                     repeat
+                       AsmWrite(std_regname(Tai_regalloc(hp).reg));
+                       if (hp.next=nil) or
+                          (tai(hp.next).typ<>ait_regalloc) or
+                          (tai_regalloc(hp.next).ratype<>tai_regalloc(hp).ratype) then
+                         break;
+                       hp:=tai(hp.next);
+                       AsmWrite(',');
+                     until false;
+                     AsmWrite(' ');
+                     AsmWriteLn(regallocstr[tai_regalloc(hp).ratype]);
+                   end;
+               end;
+
+             ait_tempalloc :
+               begin
+                 if (cs_asm_tempalloc in current_settings.globalswitches) then
+                   begin
+  {$ifdef EXTDEBUG}
+                     if assigned(tai_tempalloc(hp).problem) then
+                       AsmWriteLn(target_asm.comment+'Temp '+tostr(tai_tempalloc(hp).temppos)+','+
+                         tostr(tai_tempalloc(hp).tempsize)+' '+tai_tempalloc(hp).problem^)
+                     else
+  {$endif EXTDEBUG}
+                       AsmWriteLn(target_asm.comment+'Temp '+tostr(tai_tempalloc(hp).temppos)+','+
+                         tostr(tai_tempalloc(hp).tempsize)+' '+tempallocstr[tai_tempalloc(hp).allocation]);
+                   end;
+               end;
+
+             ait_align :
+               begin
+
+               end;
+
+             ait_section :
+               begin
+
+               end;
+
+             ait_datablock :
+               begin
+                 internalerror(2010122701);
+               end;
+
+             ait_const:
+               begin
+                 AsmWriteln('constant');
+//                 internalerror(2010122702);
+               end;
+
+             ait_real_64bit :
+               begin
+                 internalerror(2010122703);
+               end;
+
+             ait_real_32bit :
+               begin
+                 internalerror(2010122703);
+               end;
+
+             ait_comp_64bit :
+               begin
+                 internalerror(2010122704);
+               end;
+
+             ait_string :
+               begin
+                 pos:=0;
+                  for i:=1 to tai_string(hp).len do
+                   begin
+                     if pos=0 then
+                      begin
+                        AsmWrite(#9'strconst: '#9'"');
+                        pos:=20;
+                      end;
+                     ch:=tai_string(hp).str[i-1];
+                     case ch of
+                        #0, {This can't be done by range, because a bug in FPC}
+                   #1..#31,
+                #128..#255 : s:='\'+tostr(ord(ch) shr 6)+tostr((ord(ch) and 63) shr 3)+tostr(ord(ch) and 7);
+                       '"' : s:='\"';
+                       '\' : s:='\\';
+                     else
+                      s:=ch;
+                     end;
+                     AsmWrite(s);
+                     inc(pos,length(s));
+                     if (pos>line_length) or (i=tai_string(hp).len) then
+                      begin
+                        AsmWriteLn('"');
+                        pos:=0;
+                      end;
+                   end;
+               end;
+
+             ait_label :
+               begin
+                 if (tai_label(hp).labsym.is_used) then
+                  begin
+                    AsmWrite(tai_label(hp).labsym.name);
+                    AsmWriteLn(':');
+                  end;
+               end;
+
+             ait_symbol :
+               begin
+                  if (tai_symbol(hp).sym.typ = AT_FUNCTION) then
+                    begin
+                    end
+                  else
+                   begin
+                     AsmWrite('data symbol: ');
+                     AsmWriteln(tai_symbol(hp).sym.name);
+//                     internalerror(2010122706);
+                   end;
+               end;
+             ait_symbol_end :
+               begin
+               end;
+
+             ait_instruction :
+               begin
+                 WriteInstruction(hp);
+               end;
+
+             ait_force_line,
+             ait_function_name : ;
+
+             ait_cutobject :
+               begin
+               end;
+
+             ait_marker :
+               if tai_marker(hp).kind=mark_NoLineInfoStart then
+                 inc(InlineLevel)
+               else if tai_marker(hp).kind=mark_NoLineInfoEnd then
+                 dec(InlineLevel);
+
+             ait_directive :
+               begin
+                 AsmWrite('.'+directivestr[tai_directive(hp).directive]+' ');
+                 if tai_directive(hp).name<>'' then
+                   AsmWrite(tai_directive(hp).name);
+                 AsmLn;
+               end;
+
+             ait_jvar:
+               begin
+                 AsmWrite('.var ');
+                 AsmWrite(tostr(tai_jvar(hp).stackslot));
+                 AsmWrite(' is ');
+                 AsmWrite(tai_jvar(hp).desc^);
+                 AsmWrite(' from ');
+                 AsmWrite(tai_jvar(hp).startlab.name);
+                 AsmWrite(' to ');
+                 AsmWriteLn(tai_jvar(hp).stoplab.name);
+               end;
+
+             ait_jcatch:
+               begin
+                 AsmWrite('.catch ');
+                 AsmWrite(tai_jcatch(hp).name^);
+                 AsmWrite(' from ');
+                 AsmWrite(tai_jcatch(hp).startlab.name);
+                 AsmWrite(' to ');
+                 AsmWrite(tai_jcatch(hp).stoplab.name);
+                 AsmWrite(' using ');
+                 AsmWriteLn(tai_jcatch(hp).handlerlab.name);
+               end;
+             else
+               internalerror(2010122707);
+           end;
+           hp:=tai(hp.next);
+         end;
+      end;
+
+
+    procedure TJasminAssembler.WriteExtraHeader(obj: tabstractrecorddef);
+      var
+        superclass,
+        intf: tobjectdef;
+        n: ansistring;
+        i: longint;
+        toplevelowner: tsymtable;
+      begin
+        { JVM 1.5+ }
+        AsmWriteLn('.bytecode 49.0');
+        // include files are not support by Java, and the directory of the main
+        // source file must not be specified
+        if assigned(current_module.mainsource) then
+          n:=ExtractFileName(current_module.mainsource^)
+        else
+          n:=InputFileName;
+        AsmWriteLn('.source '+ExtractFileName(n));
+
+        { class/interface name }
+        if not assigned(obj) then
+          begin
+            { fake class type for unit -> name=unitname and
+              superclass=java.lang.object, make final so you cannot descend
+              from it }
+            AsmWrite('.class final public ');
+            if assigned(current_module.namespace) then
+              AsmWrite(current_module.namespace^+'.');
+            AsmWriteln(current_module.realmodulename^);
+            AsmWriteLn('.super java/lang/Object');
+          end
+        else
+          begin
+            toplevelowner:=obj.owner;
+            while not(toplevelowner.symtabletype in [staticsymtable,globalsymtable]) do
+              toplevelowner:=toplevelowner.defowner.owner;
+            case obj.typ of
+              recorddef:
+                begin
+                  { can't inherit from records }
+                  AsmWrite('.class final ');
+                  if toplevelowner.symtabletype=globalsymtable then
+                    AsmWrite('public ');
+                  AsmWriteln(obj.jvm_full_typename(true));
+                  superclass:=java_fpcbaserecordtype;
+                end;
+              objectdef:
+                begin
+                  case tobjectdef(obj).objecttype of
+                    odt_javaclass:
+                      begin
+                        AsmWrite('.class ');
+                        if oo_is_sealed in tobjectdef(obj).objectoptions then
+                          AsmWrite('final ');
+                        if (oo_is_abstract in tobjectdef(obj).objectoptions) or
+                           (tobjectdef(obj).abstractcnt<>0) then
+                          AsmWrite('abstract ');
+                        if toplevelowner.symtabletype=globalsymtable then
+                          AsmWrite('public ');
+                        if (oo_is_enum_class in tobjectdef(obj).objectoptions) then
+                          AsmWrite('enum ');
+                        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
+              begin
+                AsmWrite('.super ');
+                if assigned(superclass.import_lib) then
+                  AsmWrite(superclass.import_lib^+'/');
+                AsmWriteln(superclass.objextname^);
+              end;
+            { implemented interfaces }
+            if (obj.typ=objectdef) and
+               assigned(tobjectdef(obj).ImplementedInterfaces) then
+              begin
+                for i:=0 to tobjectdef(obj).ImplementedInterfaces.count-1 do
+                  begin
+                    intf:=TImplementedInterface(tobjectdef(obj).ImplementedInterfaces[i]).IntfDef;
+                    AsmWrite('.implements ');
+                    AsmWriteLn(intf.jvm_full_typename(true));
+                  end;
+              end;
+            { signature for enum classes (must come after superclass and
+              implemented interfaces) }
+            if (obj.typ=objectdef) and
+               (oo_is_enum_class in tobjectdef(obj).objectoptions) then
+              AsmWriteln('.signature "Ljava/lang/Enum<L'+obj.jvm_full_typename(true)+';>;"');
+            { in case of nested class: relation to parent class }
+            if obj.owner.symtabletype in [objectsymtable,recordsymtable] then
+              AsmWriteln(InnerStructDef(obj));
+            { add all nested classes }
+            for i:=0 to obj.symtable.deflist.count-1 do
+              if (is_java_class_or_interface(tdef(obj.symtable.deflist[i])) or
+                  (tdef(obj.symtable.deflist[i]).typ=recorddef)) and
+                 not(df_generic in tdef(obj.symtable.deflist[i]).defoptions) then
+                AsmWriteln(InnerStructDef(tabstractrecorddef(obj.symtable.deflist[i])));
+          end;
+        AsmLn;
+      end;
+
+
+    procedure TJasminAssembler.WriteInstruction(hp: tai);
+      begin
+        InstrWriter.WriteInstruction(hp);
+      end;
+
+
+   function TJasminAssembler.MakeCmdLine: TCmdStr;
+     const
+       jasminjarname = 'jasmin.jar';
+     var
+       filenames: tcmdstr;
+       asmfile: tcmdstrlistitem;
+       jasminjarfound: boolean;
+     begin
+       if jasminjar='' then
+         begin
+           jasminjarfound:=false;
+           if utilsdirectory<>'' then
+             jasminjarfound:=FindFile(jasminjarname,utilsdirectory,false,jasminjar);
+           if not jasminjarfound then
+             jasminjarfound:=FindFileInExeLocations(jasminjarname,false,jasminjar);
+           if (not jasminjarfound) and not(cs_asm_extern in current_settings.globalswitches) then
+             begin
+               Message1(exec_e_assembler_not_found,jasminjarname);
+               current_settings.globalswitches:=current_settings.globalswitches+[cs_asm_extern];
+             end;
+           if jasminjarfound then
+             Message1(exec_t_using_assembler,jasminjar);
+         end;
+       result:=target_asm.asmcmd;
+       filenames:=ScriptFixFileName(AsmFileName);
+       if cs_asm_extern in current_settings.globalswitches then
+         filenames:=maybequoted(filenames);
+       asmfile:=tcmdstrlistitem(asmfiles.First);
+       while assigned(asmfile) do
+         begin
+           if cs_asm_extern in current_settings.globalswitches then
+             filenames:=filenames+' '+maybequoted(ScriptFixFileName(asmfile.str))
+           else
+            filenames:=filenames+' '+ScriptFixFileName(asmfile.str);
+           asmfile:=tcmdstrlistitem(asmfile.next);
+        end;
+       Replace(result,'$ASM',filenames);
+       if (path<>'') then
+         if cs_asm_extern in current_settings.globalswitches then
+           Replace(result,'$OBJDIR',maybequoted(ScriptFixFileName(path)))
+         else
+           Replace(result,'$OBJDIR',ScriptFixFileName(path))
+       else
+         Replace(result,'$OBJDIR','.');
+       if cs_asm_extern in current_settings.globalswitches then
+         Replace(result,'$JASMINJAR',maybequoted(ScriptFixFileName(jasminjar)))
+       else
+         Replace(result,'$JASMINJAR',ScriptFixFileName(jasminjar))
+     end;
+
+
+   procedure TJasminAssembler.NewAsmFileForStructDef(obj: tabstractrecorddef);
+      begin
+        if AsmSize<>AsmStartSize then
+          begin
+            AsmClose;
+            asmfiles.Concat(AsmFileName);
+          end
+        else
+          AsmClear;
+
+        AsmFileName:=obj.jvm_full_typename(false);
+        AsmFileName:=Path+FixFileName(AsmFileName)+target_info.asmext;
+        AsmCreate(cut_normal);
+      end;
+
+
+    function TJasminAssembler.VisibilityToStr(vis: tvisibility): ansistring;
+      begin
+        case vis of
+          vis_hidden,
+          vis_strictprivate:
+            result:='private ';
+          { protected in Java means "accessible by subclasses *and* by classes
+            in the same package" -> similar to regular "protected" in Pascal;
+            "strict protected" is actually more strict in Pascal than in Java,
+            but there's not much we can do about that }
+          vis_protected,
+          vis_strictprotected:
+            result:='protected ';
+          vis_private:
+            { pick default visibility = "package" visibility; required because
+              other classes in the same unit can also access these symbols }
+            result:='';
+          vis_public:
+            result:='public '
+          else
+            internalerror(2010122609);
+        end;
+      end;
+
+
+    function TJasminAssembler.MethodDefinition(pd: tprocdef): ansistring;
+      begin
+        result:=VisibilityToStr(pd.visibility);
+        if (pd.procsym.owner.symtabletype in [globalsymtable,staticsymtable,localsymtable]) or
+           (po_classmethod in pd.procoptions) then
+          result:=result+'static ';
+        if (po_abstractmethod in pd.procoptions) or
+           is_javainterface(tdef(pd.owner.defowner)) then
+          result:=result+'abstract ';
+        if (pd.procsym.owner.symtabletype in [globalsymtable,staticsymtable,localsymtable]) or
+           (po_finalmethod in pd.procoptions) or
+           (not(po_virtualmethod in pd.procoptions) and
+            not(po_classmethod in pd.procoptions) and
+            not(pd.proctypeoption in [potype_constructor,potype_class_constructor])) then
+          result:=result+'final ';
+        result:=result+pd.jvmmangledbasename(false);
+      end;
+
+
+    function TJasminAssembler.ConstValue(csym: tconstsym): ansistring;
+      begin
+        case csym.consttyp of
+          constord:
+            { always interpret as signed value, because the JVM does not
+              support unsigned values }
+            case csym.constdef.size of
+              1:result:=tostr(shortint(csym.value.valueord.svalue));
+              2:result:=tostr(smallint(csym.value.valueord.svalue));
+              4:result:=tostr(longint(csym.value.valueord.svalue));
+              8:result:=tostr(csym.value.valueord.svalue);
+            end;
+          conststring:
+            result:=constastr(pchar(csym.value.valueptr),csym.value.len);
+          constreal:
+            case tfloatdef(csym.constdef).floattype of
+              s32real:
+                result:=constsingle(pbestreal(csym.value.valueptr)^);
+              s64real:
+                result:=constdouble(pbestreal(csym.value.valueptr)^);
+              else
+                internalerror(2011021204);
+              end;
+          constset:
+            result:='TODO: add support for constant sets';
+          constpointer:
+            { can only be null, but that's the default value and should not
+              be written; there's no primitive type that can hold nill }
+            internalerror(2011021201);
+          constnil:
+            internalerror(2011021202);
+          constresourcestring:
+            result:='TODO: add support for constant resource strings';
+          constwstring:
+            result:=constwstr(pcompilerwidestring(csym.value.valueptr)^.data,pcompilerwidestring(csym.value.valueptr)^.len);
+          constguid:
+            result:='TODO: add support for constant guids';
+          else
+            internalerror(2011021205);
+        end;
+      end;
+
+
+    function TJasminAssembler.ConstAssignmentValue(csym: tconstsym): ansistring;
+      begin
+        { nil is the default value -> don't write explicitly }
+        case csym.consttyp of
+          constpointer:
+            begin
+              if csym.value.valueordptr<>0 then
+                internalerror(2011021206);
+              result:='';
+            end;
+          constnil:
+            result:='';
+        else
+          begin
+            { enums and sets are initialized as typed constants }
+            if not assigned(csym.constdef) or
+               not(csym.constdef.typ in [enumdef,setdef]) then
+              result:=' = '+ConstValue(csym)
+          end;
+        end;
+      end;
+
+
+    function TJasminAssembler.ConstDefinition(sym: tconstsym): ansistring;
+      begin
+        result:=VisibilityToStr(sym.visibility);
+        { formal constants are always class-level, not instance-level }
+        result:=result+'static final ';
+        if sp_internal in sym.symoptions then
+          result:=result+'synthetic ';
+        result:=result+jvmmangledbasename(sym,true);
+        result:=result+ConstAssignmentValue(tconstsym(sym));
+      end;
+
+
+    function TJasminAssembler.FieldDefinition(sym: tabstractvarsym): ansistring;
+      begin
+        case sym.typ of
+          staticvarsym:
+            begin
+              if sym.owner.symtabletype=globalsymtable then
+                result:='public '
+              else
+                { package visbility }
+                result:='';
+            end;
+          fieldvarsym,
+          absolutevarsym:
+            result:=VisibilityToStr(tstoredsym(sym).visibility);
+          else
+            internalerror(2011011204);
+        end;
+        if (sym.typ=staticvarsym) or
+           (sp_static in sym.symoptions) then
+          result:=result+'static ';
+        if sym.varspez in [vs_const,vs_final] then
+          result:=result+'final ';
+        if sp_internal in sym.symoptions then
+          result:=result+'synthetic ';
+        { mark the class fields of enum classes that contain the initialised
+          enum instances as "enum" (recognise them by the fact that their type
+          is the same as their parent class, and that this parent class is
+          marked as oo_is_enum_class) }
+        if assigned(sym.owner.defowner) and
+           (tdef(sym.owner.defowner).typ=objectdef) and
+           (oo_is_enum_class in tobjectdef(sym.owner.defowner).objectoptions) and
+           (sym.typ=staticvarsym) and
+           (tstaticvarsym(sym).vardef=tdef(sym.owner.defowner)) then
+          result:=result+'enum ';
+        result:=result+jvmmangledbasename(sym,true);
+      end;
+
+
+    function TJasminAssembler.InnerStructDef(obj: tabstractrecorddef): ansistring;
+      var
+        extname: pshortstring;
+        kindname: ansistring;
+      begin
+        if not(obj.owner.defowner.typ in [objectdef,recorddef]) then
+          internalerror(2011021701);
+        { Nested classes in the Pascal sense are equivalent to "static"
+          inner classes in Java -- will be changed when support for
+          Java-style non-static classes is added }
+        case obj.typ of
+          recorddef:
+            begin
+              kindname:='class static ';
+              extname:=obj.symtable.realname;
+            end;
+          objectdef:
+            begin
+              extname:=tobjectdef(obj).objextname;
+              case tobjectdef(obj).objecttype of
+                odt_javaclass:
+                  kindname:='class static ';
+                odt_interfacejava:
+                  kindname:='interface ';
+                else
+                  internalerror(2011021702);
+              end;
+            end;
+          else
+            internalerror(2011032809);
+        end;
+        result:=
+          '.inner '+
+          kindname+
+          VisibilityToStr(obj.typesym.visibility)+
+         extname^+
+         ' inner '+
+         obj.jvm_full_typename(true)+
+         ' outer '+
+         tabstractrecorddef(obj.owner.defowner).jvm_full_typename(true);
+      end;
+
+
+    procedure TJasminAssembler.WriteProcDef(pd: tprocdef);
+      begin
+        if not assigned(pd.exprasmlist) and
+           not(po_abstractmethod in pd.procoptions) and
+           (not is_javainterface(pd.struct) or
+            (pd.proctypeoption in [potype_unitinit,potype_unitfinalize])) then
+          exit;
+        AsmWrite('.method ');
+        AsmWriteln(MethodDefinition(pd));
+        if jvmtypeneedssignature(pd) then
+          begin
+            AsmWrite('.signature "');
+            AsmWrite(pd.jvmmangledbasename(true));
+            AsmWriteln('"');
+          end;
+        WriteTree(pd.exprasmlist);
+        AsmWriteln('.end method');
+        AsmLn;
+      end;
+
+
+    procedure TJasminAssembler.WriteFieldSym(sym: tabstractvarsym);
+      begin
+        { internal static field definition alias -> skip }
+        if (sym.owner.symtabletype in [recordsymtable,ObjectSymtable]) and
+           (sym.typ=staticvarsym) then
+          exit;
+        { external or threadvar definition -> no definition here }
+        if ([vo_is_external,vo_is_thread_var]*sym.varoptions)<>[] then
+          exit;
+        AsmWrite('.field ');
+        AsmWriteln(FieldDefinition(sym));
+      end;
+
+
+    procedure TJasminAssembler.WriteConstSym(sym: tconstsym);
+      begin
+        AsmWrite('.field ');
+        AsmWriteln(ConstDefinition(sym));
+      end;
+
+
+    procedure TJasminAssembler.WriteSymtableVarSyms(st: TSymtable);
+      var
+        sym : tsym;
+        i,j : longint;
+      begin
+        if not assigned(st) then
+          exit;
+        for i:=0 to st.SymList.Count-1 do
+         begin
+           sym:=tsym(st.SymList[i]);
+           case sym.typ of
+             staticvarsym,
+             fieldvarsym:
+               begin
+                 WriteFieldSym(tabstractvarsym(sym));
+                 if (sym.typ=staticvarsym) and
+                    assigned(tstaticvarsym(sym).defaultconstsym) then
+                   WriteFieldSym(tabstractvarsym(tstaticvarsym(sym).defaultconstsym));
+               end;
+             constsym:
+               begin
+                 { multiple procedures can have constants with the same name }
+                 if not assigned(sym.owner.defowner) or
+                    (tdef(sym.owner.defowner).typ<>procdef) then
+                   WriteConstSym(tconstsym(sym));
+               end;
+             procsym:
+               begin
+                 for j:=0 to tprocsym(sym).procdeflist.count-1 do
+                   if not(df_generic in tprocdef(tprocsym(sym).procdeflist[j]).defoptions) then
+                     WriteSymtableVarSyms(tprocdef(tprocsym(sym).procdeflist[j]).localst);
+               end;
+           end;
+         end;
+      end;
+
+
+    procedure TJasminAssembler.WriteSymtableProcdefs(st: TSymtable);
+      var
+        i   : longint;
+        def : tdef;
+      begin
+        if not assigned(st) then
+          exit;
+        for i:=0 to st.DefList.Count-1 do
+          begin
+            def:=tdef(st.DefList[i]);
+            case def.typ of
+              procdef :
+                begin
+                  { methods are also in the static/globalsymtable of the unit
+                    -> make sure they are only written for the objectdefs that
+                    own them }
+                  if (not(st.symtabletype in [staticsymtable,globalsymtable]) or
+                      (def.owner=st)) and
+                     not(df_generic in def.defoptions) then
+                    begin
+                      WriteProcDef(tprocdef(def));
+                      if assigned(tprocdef(def).localst) then
+                        WriteSymtableProcdefs(tprocdef(def).localst);
+                    end;
+                end;
+            end;
+          end;
+      end;
+
+    procedure TJasminAssembler.WriteSymtableStructDefs(st: TSymtable);
+      var
+        i   : longint;
+        def : tdef;
+        obj : tabstractrecorddef;
+        nestedstructs: tfpobjectlist;
+      begin
+        if not assigned(st) then
+          exit;
+        nestedstructs:=tfpobjectlist.create(false);
+        for i:=0 to st.DefList.Count-1 do
+          begin
+            def:=tdef(st.DefList[i]);
+            if df_generic in def.defoptions then
+              continue;
+            case def.typ of
+              objectdef:
+                if not(oo_is_external in tobjectdef(def).objectoptions) then
+                  nestedstructs.add(def);
+              recorddef:
+                nestedstructs.add(def);
+            end;
+          end;
+        for i:=0 to nestedstructs.count-1 do
+          begin
+            obj:=tabstractrecorddef(nestedstructs[i]);
+            NewAsmFileForStructDef(obj);
+            WriteExtraHeader(obj);
+            WriteSymtableVarSyms(obj.symtable);
+            AsmLn;
+            WriteSymtableProcDefs(obj.symtable);
+            WriteSymtableStructDefs(obj.symtable);
+          end;
+        nestedstructs.free;
+      end;
+
+    constructor TJasminAssembler.Create(smart: boolean);
+      begin
+        inherited create(smart);
+        InstrWriter:=TJasminInstrWriter.Create(self);
+        asmfiles:=TCmdStrList.Create;
+      end;
+
+
+    procedure TJasminAssembler.WriteAsmList;
+    begin
+{$ifdef EXTDEBUG}
+      if assigned(current_module.mainsource) then
+       Comment(V_Debug,'Start writing Jasmin-styled assembler output for '+current_module.mainsource^);
+{$endif}
+
+      AsmStartSize:=AsmSize;
+      WriteExtraHeader(nil);
+(*
+      for hal:=low(TasmlistType) to high(TasmlistType) do
+        begin
+          AsmWriteLn(target_asm.comment+'Begin asmlist '+AsmlistTypeStr[hal]);
+          writetree(current_asmdata.asmlists[hal]);
+          AsmWriteLn(target_asm.comment+'End asmlist '+AsmlistTypeStr[hal]);
+        end;
+*)
+      { print all global variables }
+      WriteSymtableVarSyms(current_module.globalsymtable);
+      WriteSymtableVarSyms(current_module.localsymtable);
+      AsmLn;
+      { print all global procedures/functions }
+      WriteSymtableProcdefs(current_module.globalsymtable);
+      WriteSymtableProcdefs(current_module.localsymtable);
+
+      WriteSymtableStructDefs(current_module.globalsymtable);
+      WriteSymtableStructDefs(current_module.localsymtable);
+
+      AsmLn;
+{$ifdef EXTDEBUG}
+      if assigned(current_module.mainsource) then
+       Comment(V_Debug,'Done writing gas-styled assembler output for '+current_module.mainsource^);
+{$endif EXTDEBUG}
+    end;
+
+
+    procedure TJasminAssembler.RemoveAsm;
+      var
+        g : file;
+      begin
+        inherited;
+        if cs_asm_leave in current_settings.globalswitches then
+         exit;
+        while not asmfiles.empty do
+          begin
+            if cs_asm_extern in current_settings.globalswitches then
+             AsmRes.AddDeleteCommand(asmfiles.GetFirst)
+            else
+             begin
+               assign(g,asmfiles.GetFirst);
+               {$I-}
+                erase(g);
+               {$I+}
+               if ioresult<>0 then;
+             end;
+          end;
+      end;
+
+{****************************************************************************}
+{                         Jasmin Instruction Writer                          }
+{****************************************************************************}
+
+     constructor TJasminInstrWriter.create(_owner: TJasminAssembler);
+       begin
+         inherited create;
+         owner := _owner;
+       end;
+
+    function getreferencestring(var ref : treference) : ansistring;
+      begin
+        if (ref.arrayreftype<>art_none) or
+           (ref.index<>NR_NO) then
+          internalerror(2010122809);
+        if assigned(ref.symbol) then
+          begin
+            // global symbol or field -> full type and name
+            // ref.base can be <> NR_NO in case an instance field is loaded.
+            // This register is not part of this instruction, it will have
+            // been placed on the stack by the previous one.
+            if (ref.offset<>0) then
+              internalerror(2010122811);
+            result:=ref.symbol.name;
+          end
+        else
+          begin
+            // local symbol -> stack slot, stored in offset
+            if ref.base<>NR_STACK_POINTER_REG then
+              internalerror(2010122810);
+            result:=tostr(ref.offset);
+          end;
+      end;
+
+
+    function getopstr(const o:toper) : ansistring;
+      var
+        d: double;
+        s: single;
+      begin
+        case o.typ of
+          top_reg:
+            // should have been translated into a memory location by the
+            // register allocator)
+            if (cs_no_regalloc in current_settings.globalswitches) then
+              getopstr:=std_regname(o.reg)
+            else
+              internalerror(2010122803);
+          top_const:
+            str(o.val,result);
+          top_ref:
+            getopstr:=getreferencestring(o.ref^);
+          top_single:
+            begin
+              result:=constsingle(o.sval);
+            end;
+          top_double:
+            begin
+              result:=constdouble(o.dval);
+            end;
+          top_string:
+            begin
+              result:=constastr(o.pcval,o.pcvallen);
+            end;
+          top_wstring:
+            begin
+              result:=constwstr(o.pwstrval^.data,getlengthwidestring(o.pwstrval));
+            end
+          else
+            internalerror(2010122802);
+        end;
+      end;
+
+
+    procedure TJasminInstrWriter.WriteInstruction(hp: tai);
+      var
+        s: ansistring;
+        i: byte;
+        sep: ansistring;
+      begin
+        s:=#9+jas_op2str[taicpu(hp).opcode];
+        if taicpu(hp).ops<>0 then
+          begin
+            sep:=#9;
+            for i:=0 to taicpu(hp).ops-1 do
+              begin
+                 s:=s+sep+getopstr(taicpu(hp).oper[i]^);
+                 sep:=' ';
+              end;
+          end;
+        owner.AsmWriteLn(s);
+      end;
+
+{****************************************************************************}
+{                         Jasmin Instruction Writer                          }
+{****************************************************************************}
+
+  const
+    as_jvm_jasmin_info : tasminfo =
+       (
+         id     : as_jvm_jasmin;
+         idtxt  : 'Jasmin';
+         asmbin : 'java';
+         asmcmd : '-jar $JASMINJAR $ASM -d $OBJDIR';
+         supported_targets : [system_jvm_java32,system_jvm_android32];
+         flags : [];
+         labelprefix : 'L';
+         comment : ' ; ';
+       );
+
+
+begin
+  RegisterAssembler(as_jvm_jasmin_info,TJasminAssembler);
+end.

compiler/arm/hlcgcpu.pas

@@ -0,0 +1,45 @@
+{
+    Copyright (c) 1998-2010 by Florian Klaempfl and Jonas Maebe
+    Member of the Free Pascal development team
+
+    This unit contains routines to create a pass-through high-level code
+    generator. This is used by most regular code generators.
+
+    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 hlcgcpu;
+
+{$i fpcdefs.inc}
+
+interface
+
+  procedure create_hlcodegen;
+
+implementation
+
+  uses
+    hlcgobj, hlcg2ll,
+    cgcpu;
+
+  procedure create_hlcodegen;
+    begin
+      hlcg:=thlcg2ll.create;
+      create_codegen;
+    end;
+
+end.

compiler/arm/narmset.pas

@@ -1,5 +1,5 @@
 {
-    Copyright (c) 1998-2002 by Florian Klaempfl
+   Copyright (c) 1998-2002 by Florian Klaempfl
 
     Generate arm assembler for in set/case nodes
 
@@ -74,6 +74,7 @@ implementation
         indexreg : tregister;
         href : treference;
         tablelabel: TAsmLabel;
+        opcgsize : tcgsize;
 
         procedure genitem(list:TAsmList;t : pcaselabel);
           var
@@ -108,16 +109,17 @@ implementation
           end;
 
       begin
+        opcgsize:=def_cgsize(opsize);
         if not(jumptable_no_range) then
           begin
              { case expr less than min_ => goto elselabel }
-             cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,opsize,jmp_lt,aint(min_),hregister,elselabel);
+             cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,opcgsize,jmp_lt,aint(min_),hregister,elselabel);
              { case expr greater than max_ => goto elselabel }
-             cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,opsize,jmp_gt,aint(max_),hregister,elselabel);
+             cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,opcgsize,jmp_gt,aint(max_),hregister,elselabel);
           end;
         { make it a 32bit register }
         indexreg:=cg.makeregsize(current_asmdata.CurrAsmList,hregister,OS_INT);
-        cg.a_load_reg_reg(current_asmdata.CurrAsmList,opsize,OS_INT,hregister,indexreg);
+        cg.a_load_reg_reg(current_asmdata.CurrAsmList,opcgsize,OS_INT,hregister,indexreg);
 
         if current_settings.cputype in cpu_thumb2 then
           begin
@@ -160,6 +162,7 @@ implementation
         lastrange : boolean;
         last : TConstExprInt;
         cond_lt,cond_le : tresflags;
+        opcgsize : tcgsize;
 
         procedure genitem(t : pcaselabel);
           begin
@@ -168,16 +171,16 @@ implementation
              { need we to test the first value }
              if first and (t^._low>get_min_value(left.resultdef)) then
                begin
-                 cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,opsize,jmp_lt,aint(t^._low.svalue),hregister,elselabel);
+                 cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,opcgsize,jmp_lt,aint(t^._low.svalue),hregister,elselabel);
                end;
              if t^._low=t^._high then
                begin
                   if t^._low-last=0 then
-                    cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opsize, OC_EQ,0,hregister,blocklabel(t^.blockid))
+                    cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opcgsize, OC_EQ,0,hregister,blocklabel(t^.blockid))
                   else
                     begin
                       tcgarm(cg).cgsetflags:=true;
-                      cg.a_op_const_reg(current_asmdata.CurrAsmList, OP_SUB, opsize, aint(int64(t^._low-last)), hregister);
+                      cg.a_op_const_reg(current_asmdata.CurrAsmList, OP_SUB, opcgsize, aint(int64(t^._low-last)), hregister);
                       tcgarm(cg).cgsetflags:=false;
                       cg.a_jmp_flags(current_asmdata.CurrAsmList,F_EQ,blocklabel(t^.blockid));
                     end;
@@ -195,7 +198,7 @@ implementation
                        if (t^._low>get_min_value(left.resultdef)) or (get_min_value(left.resultdef)<>0) then
                          begin
                            tcgarm(cg).cgsetflags:=true;
-                           cg.a_op_const_reg(current_asmdata.CurrAsmList, OP_SUB, opsize, aint(int64(t^._low)), hregister);
+                           cg.a_op_const_reg(current_asmdata.CurrAsmList, OP_SUB, opcgsize, aint(int64(t^._low)), hregister);
                            tcgarm(cg).cgsetflags:=false;
                          end;
                     end
@@ -206,7 +209,7 @@ implementation
                       { immediately. else check the range in between:       }
 
                       tcgarm(cg).cgsetflags:=true;
-                      cg.a_op_const_reg(current_asmdata.CurrAsmList, OP_SUB, opsize, aint(int64(t^._low-last)), hregister);
+                      cg.a_op_const_reg(current_asmdata.CurrAsmList, OP_SUB, opcgsize, aint(int64(t^._low-last)), hregister);
                       tcgarm(cg).cgsetflags:=false;
                       { no jump necessary here if the new range starts at }
                       { at the value following the previous one           }
@@ -215,7 +218,7 @@ implementation
                         cg.a_jmp_flags(current_asmdata.CurrAsmList,cond_lt,elselabel);
                     end;
                   tcgarm(cg).cgsetflags:=true;
-                  cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_SUB,opsize,aint(int64(t^._high-t^._low)),hregister);
+                  cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_SUB,opcgsize,aint(int64(t^._high-t^._low)),hregister);
                   tcgarm(cg).cgsetflags:=false;
                   cg.a_jmp_flags(current_asmdata.CurrAsmList,cond_le,blocklabel(t^.blockid));
 
@@ -228,6 +231,7 @@ implementation
           end;
 
         begin
+           opcgsize:=def_cgsize(opsize);
            if with_sign then
              begin
                 cond_lt:=F_LT;

compiler/assemble.pas

@@ -98,7 +98,7 @@ interface
         Function  CallAssembler(const command:string; const para:TCmdStr):Boolean;
 
         Function  DoAssemble:boolean;virtual;
-        Procedure RemoveAsm;
+        Procedure RemoveAsm;virtual;
         Procedure AsmFlush;
         Procedure AsmClear;
 
@@ -378,8 +378,8 @@ Implementation
           end;
         try
           FlushOutput;
-          DosExitCode := ExecuteProcess(command,para);
-          if DosExitCode <>0
+          DosExitCode:=RequotedExecuteProcess(command,para);
+          if DosExitCode<>0
           then begin
             Message1(exec_e_error_while_assembling,tostr(dosexitcode));
             result:=false;

compiler/avr/hlcgcpu.pas

@@ -0,0 +1,45 @@
+{
+    Copyright (c) 1998-2010 by Florian Klaempfl and Jonas Maebe
+    Member of the Free Pascal development team
+
+    This unit contains routines to create a pass-through high-level code
+    generator. This is used by most regular code generators.
+
+    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 hlcgcpu;
+
+{$i fpcdefs.inc}
+
+interface
+
+  procedure create_hlcodegen;
+
+implementation
+
+  uses
+    hlcgobj, hlcg2ll,
+    cgcpu;
+
+  procedure create_hlcodegen;
+    begin
+      hlcg:=thlcg2ll.create;
+      create_codegen;
+    end;
+
+end.

compiler/cclasses.pas

@@ -194,17 +194,21 @@ type
     FHashTable    : PHashTable;
     FHashCapacity : Integer;
     { Strings }
+{$ifdef symansistr}
+    FStrs     : PAnsiString;
+{$else symansistr}
     FStrs     : PChar;
+{$endif symansistr}
     FStrCount,
     FStrCapacity : Integer;
-    function InternalFind(AHash:LongWord;const AName:shortstring;out PrevIndex:Integer):Integer;
+    function InternalFind(AHash:LongWord;const AName:TSymStr;out PrevIndex:Integer):Integer;
   protected
     function Get(Index: Integer): Pointer;
     procedure Put(Index: Integer; Item: Pointer);
     procedure SetCapacity(NewCapacity: Integer);
     procedure SetCount(NewCount: Integer);
     Procedure RaiseIndexError(Index : Integer);
-    function  AddStr(const s:shortstring): Integer;
+    function  AddStr(const s:TSymStr): Integer;
     procedure AddToHashTable(Index: Integer);
     procedure StrExpand(MinIncSize:Integer);
     procedure SetStrCapacity(NewCapacity: Integer);
@@ -213,9 +217,9 @@ type
   public
     constructor Create;
     destructor Destroy; override;
-    function Add(const AName:shortstring;Item: Pointer): Integer;
+    function Add(const AName:TSymStr;Item: Pointer): Integer;
     procedure Clear;
-    function NameOfIndex(Index: Integer): ShortString;
+    function NameOfIndex(Index: Integer): TSymStr;
     function HashOfIndex(Index: Integer): LongWord;
     function GetNextCollision(Index: Integer): Integer;
     procedure Delete(Index: Integer);
@@ -223,10 +227,10 @@ type
     function Expand: TFPHashList;
     function Extract(item: Pointer): Pointer;
     function IndexOf(Item: Pointer): Integer;
-    function Find(const AName:shortstring): Pointer;
-    function FindIndexOf(const AName:shortstring): Integer;
-    function FindWithHash(const AName:shortstring;AHash:LongWord): Pointer;
-    function Rename(const AOldName,ANewName:shortstring): Integer;
+    function Find(const AName:TSymStr): Pointer;
+    function FindIndexOf(const AName:TSymStr): Integer;
+    function FindWithHash(const AName:TSymStr;AHash:LongWord): Pointer;
+    function Rename(const AOldName,ANewName:TSymStr): Integer;
     function Remove(Item: Pointer): Integer;
     procedure Pack;
     procedure ShowStatistics;
@@ -236,7 +240,11 @@ type
     property Count: Integer read FCount write SetCount;
     property Items[Index: Integer]: Pointer read Get write Put; default;
     property List: PHashItemList read FHashList;
+{$ifdef symansistr}
+    property Strs: PSymStr read FStrs;
+{$else}
     property Strs: PChar read FStrs;
+{$endif}
   end;
 
 
@@ -251,19 +259,18 @@ type
   TFPHashObject = class
   private
     FOwner     : TFPHashObjectList;
-    FCachedStr : pshortstring;
     FStrIndex  : Integer;
-    procedure InternalChangeOwner(HashObjectList:TFPHashObjectList;const s:shortstring);
+    procedure InternalChangeOwner(HashObjectList:TFPHashObjectList;const s:TSymStr);
   protected
-    function GetName:shortstring;virtual;
+    function GetName:TSymStr;virtual;
     function GetHash:Longword;virtual;
   public
     constructor CreateNotOwned;
-    constructor Create(HashObjectList:TFPHashObjectList;const s:shortstring);
+    constructor Create(HashObjectList:TFPHashObjectList;const s:TSymStr);
     procedure ChangeOwner(HashObjectList:TFPHashObjectList);
-    procedure ChangeOwnerAndName(HashObjectList:TFPHashObjectList;const s:shortstring); {$ifdef CCLASSESINLINE}inline;{$endif}
-    procedure Rename(const ANewName:shortstring);
-    property Name:shortstring read GetName;
+    procedure ChangeOwnerAndName(HashObjectList:TFPHashObjectList;const s:TSymStr); {$ifdef CCLASSESINLINE}inline;{$endif}
+    procedure Rename(const ANewName:TSymStr);
+    property Name:TSymStr read GetName;
     property Hash:Longword read GetHash;
   end;
 
@@ -282,8 +289,8 @@ type
     constructor Create(FreeObjects : boolean = True);
     destructor Destroy; override;
     procedure Clear;
-    function Add(const AName:shortstring;AObject: TObject): Integer; {$ifdef CCLASSESINLINE}inline;{$endif}
-    function NameOfIndex(Index: Integer): ShortString; {$ifdef CCLASSESINLINE}inline;{$endif}
+    function Add(const AName:TSymStr;AObject: TObject): Integer; {$ifdef CCLASSESINLINE}inline;{$endif}
+    function NameOfIndex(Index: Integer): TSymStr; {$ifdef CCLASSESINLINE}inline;{$endif}
     function HashOfIndex(Index: Integer): LongWord; {$ifdef CCLASSESINLINE}inline;{$endif}
     function GetNextCollision(Index: Integer): Integer; {$ifdef CCLASSESINLINE}inline;{$endif}
     procedure Delete(Index: Integer);
@@ -291,10 +298,10 @@ type
     function Extract(Item: TObject): TObject; {$ifdef CCLASSESINLINE}inline;{$endif}
     function Remove(AObject: TObject): Integer;
     function IndexOf(AObject: TObject): Integer; {$ifdef CCLASSESINLINE}inline;{$endif}
-    function Find(const s:shortstring): TObject; {$ifdef CCLASSESINLINE}inline;{$endif}
-    function FindIndexOf(const s:shortstring): Integer; {$ifdef CCLASSESINLINE}inline;{$endif}
-    function FindWithHash(const AName:shortstring;AHash:LongWord): Pointer;
-    function Rename(const AOldName,ANewName:shortstring): Integer; {$ifdef CCLASSESINLINE}inline;{$endif}
+    function Find(const s:TSymStr): TObject; {$ifdef CCLASSESINLINE}inline;{$endif}
+    function FindIndexOf(const s:TSymStr): Integer; {$ifdef CCLASSESINLINE}inline;{$endif}
+    function FindWithHash(const AName:TSymStr;AHash:LongWord): Pointer;
+    function Rename(const AOldName,ANewName:TSymStr): Integer; {$ifdef CCLASSESINLINE}inline;{$endif}
     function FindInstanceOf(AClass: TClass; AExact: Boolean; AStartAt: Integer): Integer;
     procedure Pack; {$ifdef CCLASSESINLINE}inline;{$endif}
     procedure ShowStatistics; {$ifdef CCLASSESINLINE}inline;{$endif}
@@ -574,6 +581,7 @@ type
     function FPHash(const s:shortstring):LongWord;
     function FPHash(P: PChar; Len: Integer): LongWord;
     function FPHash(P: PChar; Len: Integer; Tag: LongWord): LongWord;
+    function FPHash(const a:ansistring):LongWord;
 
 
 implementation
@@ -1172,6 +1180,12 @@ end;
 {$pop}
       end;
 
+    function FPHash(const a: ansistring): LongWord;
+      begin
+         result:=fphash(pchar(a),length(a));
+      end;
+
+
 procedure TFPHashList.RaiseIndexError(Index : Integer);
 begin
   Error(SListIndexError, Index);
@@ -1194,14 +1208,14 @@ begin
 end;
 
 
-function TFPHashList.NameOfIndex(Index: Integer): shortstring;
+function TFPHashList.NameOfIndex(Index: Integer): TSymStr;
 begin
   If (Index < 0) or (Index >= FCount) then
     RaiseIndexError(Index);
   with FHashList^[Index] do
     begin
       if StrIndex>=0 then
-        Result:=PShortString(@FStrs[StrIndex])^
+        Result:=PSymStr(@FStrs[StrIndex])^
       else
         Result:='';
     end;
@@ -1274,6 +1288,10 @@ end;
 
 
 procedure TFPHashList.SetStrCapacity(NewCapacity: Integer);
+{$ifdef symansistr}
+var
+  i: longint;
+{$endif symansistr}
 begin
 {$push}{$warnings off}
   If (NewCapacity < FStrCount) or (NewCapacity > MaxHashStrSize) then
@@ -1281,7 +1299,18 @@ begin
 {$pop}
   if NewCapacity = FStrCapacity then
     exit;
+{$ifdef symansistr}
+{ array of ansistrings -> finalize }
+  if (NewCapacity < FStrCapacity) then
+    for i:=NewCapacity to FStrCapacity-1 do
+      finalize(FStrs[i]);
+  ReallocMem(FStrs, NewCapacity*sizeof(pansistring));
+  { array of ansistrings -> initialize to nil }
+  if (NewCapacity > FStrCapacity) then
+    fillchar(FStrs[FStrCapacity],(NewCapacity-FStrCapacity)*sizeof(pansistring),0);
+{$else symansistr}
   ReallocMem(FStrs, NewCapacity);
+{$endif symansistr}
   FStrCapacity := NewCapacity;
 end;
 
@@ -1329,16 +1358,26 @@ begin
 end;
 
 
-function TFPHashList.AddStr(const s:shortstring): Integer;
+function TFPHashList.AddStr(const s:TSymStr): Integer;
+{$ifndef symansistr}
 var
   Len : Integer;
+{$endif symansistr}
 begin
+{$ifdef symansistr}
+  if FStrCount+1 >= FStrCapacity then
+    StrExpand(FStrCount+1);
+  FStrs[FStrCount]:=s;
+  result:=FStrCount;
+  inc(FStrCount);
+{$else symansistr}
   len:=length(s)+1;
   if FStrCount+Len >= FStrCapacity then
     StrExpand(Len);
   System.Move(s[0],FStrs[FStrCount],Len);
   result:=FStrCount;
   inc(FStrCount,Len);
+{$endif symansistr}
 end;
 
 
@@ -1357,7 +1396,7 @@ begin
 end;
 
 
-function TFPHashList.Add(const AName:shortstring;Item: Pointer): Integer;
+function TFPHashList.Add(const AName:TSymStr;Item: Pointer): Integer;
 begin
   if FCount = FCapacity then
     Expand;
@@ -1460,9 +1499,11 @@ begin
     end;
 end;
 
-function TFPHashList.InternalFind(AHash:LongWord;const AName:shortstring;out PrevIndex:Integer):Integer;
+function TFPHashList.InternalFind(AHash:LongWord;const AName:TSymStr;out PrevIndex:Integer):Integer;
+var
+  HashIndex : Integer;
 begin
-  prefetch(AName);
+  prefetch(AName[1]);
   Result:=FHashTable^[AHash and FCapacityMask];
   PrevIndex:=-1;
   while Result<>-1 do
@@ -1471,7 +1512,7 @@ begin
         begin
           if assigned(Data) and
              (HashValue=AHash) and
-             (AName=PShortString(@FStrs[StrIndex])^) then
+             (AName=PSymStr(@FStrs[StrIndex])^) then
             exit;
           PrevIndex:=Result;
           Result:=NextIndex;
@@ -1480,7 +1521,7 @@ begin
 end;
 
 
-function TFPHashList.Find(const AName:shortstring): Pointer;
+function TFPHashList.Find(const AName:TSymStr): Pointer;
 var
   Index,
   PrevIndex : Integer;
@@ -1493,7 +1534,7 @@ begin
 end;
 
 
-function TFPHashList.FindIndexOf(const AName:shortstring): Integer;
+function TFPHashList.FindIndexOf(const AName:TSymStr): Integer;
 var
   PrevIndex : Integer;
 begin
@@ -1501,7 +1542,7 @@ begin
 end;
 
 
-function TFPHashList.FindWithHash(const AName:shortstring;AHash:LongWord): Pointer;
+function TFPHashList.FindWithHash(const AName:TSymStr;AHash:LongWord): Pointer;
 var
   Index,
   PrevIndex : Integer;
@@ -1514,7 +1555,7 @@ begin
 end;
 
 
-function TFPHashList.Rename(const AOldName,ANewName:shortstring): Integer;
+function TFPHashList.Rename(const AOldName,ANewName:TSymStr): Integer;
 var
   PrevIndex,
   Index : Integer;
@@ -1640,14 +1681,13 @@ end;
                                TFPHashObject
 *****************************************************************************}
 
-procedure TFPHashObject.InternalChangeOwner(HashObjectList:TFPHashObjectList;const s:shortstring);
+procedure TFPHashObject.InternalChangeOwner(HashObjectList:TFPHashObjectList;const s:TSymStr);
 var
   Index : integer;
 begin
   FOwner:=HashObjectList;
   Index:=HashObjectList.Add(s,Self);
   FStrIndex:=HashObjectList.List.List^[Index].StrIndex;
-  FCachedStr:=PShortString(@FOwner.List.Strs[FStrIndex]);
 end;
 
 
@@ -1657,7 +1697,7 @@ begin
 end;
 
 
-constructor TFPHashObject.Create(HashObjectList:TFPHashObjectList;const s:shortstring);
+constructor TFPHashObject.Create(HashObjectList:TFPHashObjectList;const s:TSymStr);
 begin
   InternalChangeOwner(HashObjectList,s);
 end;
@@ -1665,36 +1705,30 @@ end;
 
 procedure TFPHashObject.ChangeOwner(HashObjectList:TFPHashObjectList);
 begin
-  InternalChangeOwner(HashObjectList,PShortString(@FOwner.List.Strs[FStrIndex])^);
+  InternalChangeOwner(HashObjectList,PSymStr(@FOwner.List.Strs[FStrIndex])^);
 end;
 
 
-procedure TFPHashObject.ChangeOwnerAndName(HashObjectList:TFPHashObjectList;const s:shortstring);
+procedure TFPHashObject.ChangeOwnerAndName(HashObjectList:TFPHashObjectList;const s:TSymStr);
 begin
   InternalChangeOwner(HashObjectList,s);
 end;
 
 
-procedure TFPHashObject.Rename(const ANewName:shortstring);
+procedure TFPHashObject.Rename(const ANewName:TSymStr);
 var
   Index : integer;
 begin
-  Index:=FOwner.Rename(PShortString(@FOwner.List.Strs[FStrIndex])^,ANewName);
+  Index:=FOwner.Rename(PSymStr(@FOwner.List.Strs[FStrIndex])^,ANewName);
   if Index<>-1 then
-    begin
-      FStrIndex:=FOwner.List.List^[Index].StrIndex;
-      FCachedStr:=PShortString(@FOwner.List.Strs[FStrIndex]);
-    end;
+    FStrIndex:=FOwner.List.List^[Index].StrIndex;
 end;
 
 
-function TFPHashObject.GetName:shortstring;
+function TFPHashObject.GetName:TSymStr;
 begin
   if FOwner<>nil then
-    begin
-      FCachedStr:=PShortString(@FOwner.List.Strs[FStrIndex]);
-      Result:=FCachedStr^;
-    end
+    Result:=PSymStr(@FOwner.List.Strs[FStrIndex])^
   else
     Result:='';
 end;
@@ -1703,7 +1737,7 @@ end;
 function TFPHashObject.GetHash:Longword;
 begin
   if FOwner<>nil then
-    Result:=FPHash(PShortString(@FOwner.List.Strs[FStrIndex])^)
+    Result:=FPHash(PSymStr(@FOwner.List.Strs[FStrIndex])^)
   else
     Result:=$ffffffff;
 end;
@@ -1773,12 +1807,12 @@ begin
   Result := FHashList.Capacity;
 end;
 
-function TFPHashObjectList.Add(const AName:shortstring;AObject: TObject): Integer;
+function TFPHashObjectList.Add(const AName:TSymStr;AObject: TObject): Integer;
 begin
   Result := FHashList.Add(AName,AObject);
 end;
 
-function TFPHashObjectList.NameOfIndex(Index: Integer): shortstring;
+function TFPHashObjectList.NameOfIndex(Index: Integer): TSymStr;
 begin
   Result := FHashList.NameOfIndex(Index);
 end;
@@ -1828,25 +1862,25 @@ begin
 end;
 
 
-function TFPHashObjectList.Find(const s:shortstring): TObject;
+function TFPHashObjectList.Find(const s:TSymStr): TObject;
 begin
   result:=TObject(FHashList.Find(s));
 end;
 
 
-function TFPHashObjectList.FindIndexOf(const s:shortstring): Integer;
+function TFPHashObjectList.FindIndexOf(const s:TSymStr): Integer;
 begin
   result:=FHashList.FindIndexOf(s);
 end;
 
 
-function TFPHashObjectList.FindWithHash(const AName:shortstring;AHash:LongWord): Pointer;
+function TFPHashObjectList.FindWithHash(const AName:TSymStr;AHash:LongWord): Pointer;
 begin
   Result:=TObject(FHashList.FindWithHash(AName,AHash));
 end;
 
 
-function TFPHashObjectList.Rename(const AOldName,ANewName:shortstring): Integer;
+function TFPHashObjectList.Rename(const AOldName,ANewName:TSymStr): Integer;
 begin
   Result:=FHashList.Rename(AOldName,ANewName);
 end;

compiler/cfileutl.pas

@@ -119,12 +119,22 @@ interface
     procedure SplitBinCmd(const s:TCmdStr;var bstr: TCmdStr;var cstr:TCmdStr);
     function  FindFile(const f : TCmdStr; const path : TCmdStr;allowcache:boolean;var foundfile:TCmdStr):boolean;
 {    function  FindFilePchar(const f : TCmdStr;path : pchar;allowcache:boolean;var foundfile:TCmdStr):boolean;}
+    function  FindFileInExeLocations(const bin:TCmdStr;allowcache:boolean;var foundfile:TCmdStr):boolean;
     function  FindExe(const bin:TCmdStr;allowcache:boolean;var foundfile:TCmdStr):boolean;
     function  GetShortName(const n:TCmdStr):TCmdStr;
+    function maybequoted(const s:string):string;
+    function maybequoted(const s:ansistring):ansistring;
 
     procedure InitFileUtils;
     procedure DoneFileUtils;
 
+    function RequotedExecuteProcess(const Path: AnsiString; const ComLine: AnsiString; Flags: TExecuteFlags = []): Longint;
+    function RequotedExecuteProcess(const Path: AnsiString; const ComLine: array of AnsiString; Flags: TExecuteFlags = []): Longint;
+    function Shell(const command:ansistring): longint;
+
+  { hide Sysutils.ExecuteProcess in units using this one after SysUtils}
+  const
+    ExecuteProcess = 'Do not use' deprecated 'Use cfileutil.RequotedExecuteProcess instead, ExecuteProcess cannot deal with single quotes as used by Unix command lines';
 
 { * Since native Amiga commands can't handle Unix-style relative paths used by the compiler,
     and some GNU tools, Unix2AmigaPath is needed to handle such situations (KB) * }
@@ -1233,22 +1243,28 @@ end;
      end;
 }
 
-   function  FindExe(const bin:TCmdStr;allowcache:boolean;var foundfile:TCmdStr):boolean;
-     var
-       Path : TCmdStr;
-       found : boolean;
-     begin
-       found:=FindFile(FixFileName(ChangeFileExt(bin,source_info.exeext)),exepath,allowcache,foundfile);
-       if not found then
-        begin
+  function  FindFileInExeLocations(const bin:TCmdStr;allowcache:boolean;var foundfile:TCmdStr):boolean;
+    var
+      Path : TCmdStr;
+      found : boolean;
+    begin
+       found:=FindFile(FixFileName(bin),exepath,allowcache,foundfile);
+      if not found then
+       begin
 {$ifdef macos}
-          Path:=GetEnvironmentVariable('Commands');
+         Path:=GetEnvironmentVariable('Commands');
 {$else}
-          Path:=GetEnvironmentVariable('PATH');
+         Path:=GetEnvironmentVariable('PATH');
 {$endif}
-          found:=FindFile(FixFileName(ChangeFileExt(bin,source_info.exeext)),Path,allowcache,foundfile);
-        end;
-       FindExe:=found;
+         found:=FindFile(FixFileName(bin),Path,allowcache,foundfile);
+       end;
+      FindFileInExeLocations:=found;
+    end;
+
+
+   function  FindExe(const bin:TCmdStr;allowcache:boolean;var foundfile:TCmdStr):boolean;
+     begin
+       FindExe:=FindFileInExeLocations(ChangeFileExt(bin,source_info.exeext),allowcache,foundfile);
      end;
 
 
@@ -1283,6 +1299,254 @@ end;
       end;
 
 
+    function maybequoted(const s:string):string;
+    const
+      FORBIDDEN_CHARS_DOS = ['!', '@', '#', '$', '%', '^', '&', '*', '(', ')',
+                         '{', '}', '''', '`', '~'];
+      FORBIDDEN_CHARS_OTHER = ['!', '@', '#', '$', '%', '^', '&', '*', '(', ')',
+                         '{', '}', '''', ':', '\', '`', '~'];
+    var
+      forbidden_chars: set of char;
+      i  : integer;
+      quote_script: tscripttype;
+      quote_char: ansichar;
+      quoted : boolean;
+    begin
+      if not(cs_link_on_target in current_settings.globalswitches) then
+        quote_script:=source_info.script
+      else
+        quote_script:=target_info.script;
+      if quote_script=script_dos then
+        forbidden_chars:=FORBIDDEN_CHARS_DOS
+      else
+        begin
+          forbidden_chars:=FORBIDDEN_CHARS_OTHER;
+          if quote_script=script_unix then
+            include(forbidden_chars,'"');
+        end;
+      if quote_script=script_unix then
+        quote_char:=''''
+      else
+        quote_char:='"';
+
+      quoted:=false;
+      result:=quote_char;
+      for i:=1 to length(s) do
+       begin
+         if s[i]=quote_char then
+           begin
+             quoted:=true;
+             result:=result+'\'+quote_char;
+           end
+         else case s[i] of
+           '\':
+             begin
+               if quote_script=script_unix then
+                 begin
+                   result:=result+'\\';
+                   quoted:=true
+                 end
+               else
+                 result:=result+'\';
+             end;
+           ' ',
+           #128..#255 :
+             begin
+               quoted:=true;
+               result:=result+s[i];
+             end;
+           else begin
+             if s[i] in forbidden_chars then
+               quoted:=True;
+             result:=result+s[i];
+           end;
+         end;
+       end;
+      if quoted then
+        result:=result+quote_char
+      else
+        result:=s;
+    end;
+
+
+    function maybequoted_for_script(const s:ansistring; quote_script: tscripttype):ansistring;
+      const
+        FORBIDDEN_CHARS_DOS = ['!', '@', '#', '$', '%', '^', '&', '*', '(', ')',
+                           '{', '}', '''', '`', '~'];
+        FORBIDDEN_CHARS_OTHER = ['!', '@', '#', '$', '%', '^', '&', '*', '(', ')',
+                           '{', '}', '''', ':', '\', '`', '~'];
+      var
+        forbidden_chars: set of char;
+        i  : integer;
+        quote_char: ansichar;
+        quoted : boolean;
+      begin
+        if quote_script=script_dos then
+          forbidden_chars:=FORBIDDEN_CHARS_DOS
+        else
+          begin
+            forbidden_chars:=FORBIDDEN_CHARS_OTHER;
+            if quote_script=script_unix then
+              include(forbidden_chars,'"');
+          end;
+        if quote_script=script_unix then
+          quote_char:=''''
+        else
+          quote_char:='"';
+
+        quoted:=false;
+        result:=quote_char;
+        for i:=1 to length(s) do
+         begin
+           if s[i]=quote_char then
+             begin
+               quoted:=true;
+               result:=result+'\'+quote_char;
+             end
+           else case s[i] of
+             '\':
+               begin
+                 if quote_script=script_unix then
+                   begin
+                     result:=result+'\\';
+                     quoted:=true
+                   end
+                 else
+                   result:=result+'\';
+               end;
+             ' ',
+             #128..#255 :
+               begin
+                 quoted:=true;
+                 result:=result+s[i];
+               end;
+             else begin
+               if s[i] in forbidden_chars then
+                 quoted:=True;
+               result:=result+s[i];
+             end;
+           end;
+         end;
+        if quoted then
+          result:=result+quote_char
+        else
+          result:=s;
+      end;
+
+
+    function maybequoted(const s:ansistring):ansistring;
+      var
+        quote_script: tscripttype;
+      begin
+        if not(cs_link_on_target in current_settings.globalswitches) then
+          quote_script:=source_info.script
+        else
+          quote_script:=target_info.script;
+        result:=maybequoted_for_script(s,quote_script);
+      end;
+
+
+    { requotes a string that was quoted for Unix for passing to ExecuteProcess,
+      because it only supports Windows-style quoting; this routine assumes that
+      everything that has to be quoted for Windows, was also quoted (but
+      differently for Unix) -- which is the case }
+    function UnixRequoteForExecuteProcess(const QuotedStr: TCmdStr): TCmdStr;
+      var
+        i: longint;
+        temp: TCmdStr;
+        inquotes: boolean;
+      begin
+        if QuotedStr='' then
+          begin
+            result:='';
+            exit;
+          end;
+        inquotes:=false;
+        result:='';
+        i:=1;
+        while i<=length(QuotedStr) do
+          begin
+            case QuotedStr[i] of
+              '''':
+                begin
+                  if not(inquotes) then
+                    begin
+                      inquotes:=true;
+                      temp:=''
+                    end
+                  else
+                    begin
+                      { requote for Windows }
+                      result:=result+maybequoted_for_script(temp,script_dos);
+                      inquotes:=false;
+                    end;
+                end;
+              '\':
+                begin
+                  if inquotes then
+                    temp:=temp+QuotedStr[i+1]
+                  else
+                    result:=result+QuotedStr[i+1];
+                  inc(i);
+                end;
+              else
+                begin
+                  if inquotes then
+                    temp:=temp+QuotedStr[i]
+                  else
+                    result:=result+QuotedStr[i];
+                end;
+            end;
+            inc(i);
+          end;
+      end;
+
+
+    function RequotedExecuteProcess(const Path: AnsiString; const ComLine: AnsiString; Flags: TExecuteFlags): Longint;
+      var
+        quote_script: tscripttype;
+      begin
+        if not(cs_link_on_target in current_settings.globalswitches) then
+          quote_script:=target_info.script
+        else
+          quote_script:=source_info.script;
+        if quote_script=script_unix then
+          result:=sysutils.ExecuteProcess(Path,UnixRequoteForExecuteProcess(ComLine),Flags)
+        else
+          result:=sysutils.ExecuteProcess(Path,ComLine,Flags)
+      end;
+
+
+    function RequotedExecuteProcess(const Path: AnsiString; const ComLine: array of AnsiString; Flags: TExecuteFlags): Longint;
+      begin
+        result:=sysutils.ExecuteProcess(Path,ComLine,Flags);
+      end;
+
+
+    function Shell(const command:ansistring): longint;
+      { This is already defined in the linux.ppu for linux, need for the *
+        expansion under linux }
+{$ifdef hasunix}
+      begin
+        result := Unix.fpsystem(command);
+      end;
+{$else hasunix}
+  {$ifdef amigashell}
+      begin
+        result := RequotedExecuteProcess('',command);
+      end;
+  {$else amigashell}
+      var
+        comspec : string;
+      begin
+        comspec:=GetEnvironmentVariable('COMSPEC');
+        result := RequotedExecuteProcess(comspec,' /C '+command);
+      end;
+   {$endif amigashell}
+{$endif hasunix}
+
+
+
 {****************************************************************************
                            Init / Done
 ****************************************************************************}

compiler/cg64f32.pas

@@ -779,7 +779,7 @@ unit cg64f32;
                  cg.a_cmp_const_reg_label(list,OS_32,OC_EQ,-1,hreg,neglabel);
                end;
              { For all other values we have a range check error }
-             cg.a_call_name(list,'FPC_RANGEERROR',false);
+             cg.a_call_name(list,'fpc_rangeerror',false);
 
              { if the high dword = 0, the low dword can be considered a }
              { simple cardinal                                          }
@@ -819,7 +819,7 @@ unit cg64f32;
                  current_asmdata.getjumplabel(neglabel);
                  cg.a_cmp_const_reg_label(list,OS_32,OC_LT,0,hreg,neglabel);
 
-                 cg.a_call_name(list,'FPC_RANGEERROR',false);
+                 cg.a_call_name(list,'fpc_rangeerror',false);
 
                  { if we get here, the 64bit value lies between }
                  { longint($80000000) and -1 (JM)               }
@@ -870,7 +870,7 @@ unit cg64f32;
                current_asmdata.getjumplabel(poslabel);
                cg.a_cmp_const_reg_label(list,opsize,OC_GTE,0,hreg,poslabel);
 
-               cg.a_call_name(list,'FPC_RANGEERROR',false);
+               cg.a_call_name(list,'fpc_rangeerror',false);
                cg.a_label(list,poslabel);
              end;
       end;

compiler/cgbase.pas

@@ -132,6 +132,10 @@ interface
           OC_A             { greater than (unsigned)          }
         );
 
+       { indirect symbol flags }
+       tindsymflag = (is_data,is_weak);
+       tindsymflags = set of tindsymflag;
+
        { OS_NO is also used memory references with large data that can
          not be loaded in a register directly }
        TCgSize = (OS_NO,

compiler/cgobj.pas

@@ -45,8 +45,6 @@ unit cgobj;
     type
        talignment = (AM_NATURAL,AM_NONE,AM_2BYTE,AM_4BYTE,AM_8BYTE);
        tsubsetloadopt = (SL_REG,SL_REGNOSRCMASK,SL_SETZERO,SL_SETMAX);
-       tindsymflag = (is_data,is_weak);
-       tindsymflags = set of tindsymflag;
 
        {# @abstract(Abstract code generator)
           This class implements an abstract instruction generator. Some of
@@ -460,6 +458,8 @@ unit cgobj;
              @param(p Node which contains the value to check)
              @param(todef Type definition of node to range check)
           }
+          { only left here because used by cg64f32; normally, the code in
+            hlcgobj is used }
           procedure g_rangecheck(list: TAsmList; const l:tlocation; fromdef,todef: tdef); virtual;
 
           {# Generates overflow checking code for a node }

compiler/cgutils.pas

@@ -33,6 +33,9 @@ unit cgutils;
       cpubase,cgbase;
 
     type
+{$ifdef jvm}
+      tarrayreftype = (art_none,art_indexreg,art_indexref,art_indexconst);
+{$endif jvm}
       { reference record, reordered for best alignment }
       preference = ^treference;
       treference = record
@@ -61,6 +64,13 @@ unit cgutils;
          { (An)+ and -(An)                      }
          direction : tdirection;
 {$endif m68k}
+{$ifdef jvm}
+         arrayreftype: tarrayreftype;
+         indexbase: tregister;
+         indexsymbol: tasmsymbol;
+         indexoffset: aint;
+         checkcast: boolean;
+{$endif jvm}
          alignment : byte;
       end;
 

compiler/compinnr.inc

@@ -84,6 +84,8 @@ const
    in_bsf_x             = 74;
    in_bsr_x             = 75;
    in_default_x         = 76;
+   in_box_x             = 77; { managed platforms: wrap in class instance }
+   in_unbox_x_y         = 78; { manage platforms: extract from class instance }
 
 { Internal constant functions }
    in_const_sqr        = 100;

compiler/comprsrc.pas

@@ -63,6 +63,15 @@ type
       procedure EndCollect; override;
    end;
 
+   TJVMRawResourceFile = class(TWinLikeResourceFile)
+   private
+   protected
+   public
+      function Compile(output: tresoutput; const OutName: ansistring) : boolean; override;
+      function IsCompiled(const fn : ansistring) : boolean;override;
+   end;
+
+
 procedure CompileResourceFiles;
 procedure CollectResourceFiles;
 
@@ -189,7 +198,7 @@ begin
      Message2(exec_d_resbin_params,resbin,s);
      FlushOutput;
      try
-       if ExecuteProcess(resbin,s) <> 0 then
+       if RequotedExecuteProcess(resbin,s) <> 0 then
        begin
          if not (cs_link_nolink in current_settings.globalswitches) then
            Message(exec_e_error_while_compiling_resources);
@@ -383,6 +392,25 @@ begin
 end;
 
 
+{****************************************************************************
+                              TJVMRawResourceFile
+****************************************************************************}
+
+function TJVMRawResourceFile.Compile(output: tresoutput; const OutName: ansistring): boolean;
+  begin
+    if output<>roOBJ then
+      internalerror(2011081703);
+    result:=inherited;
+  end;
+
+
+function TJVMRawResourceFile.IsCompiled(const fn: ansistring): boolean;
+  begin
+    internalerror(2011081704);
+    result:=true;
+  end;
+
+
 function CopyResFile(inf,outf : TCmdStr) : boolean;
 var
   src,dst : TCCustomFileStream;
@@ -418,7 +446,8 @@ var
 begin
   { Don't do anything for systems supporting resources without using resource
     file classes (e.g. Mac OS). They process resources elsewhere. }
-  if (target_info.res<>res_none) and (target_res.resourcefileclass=nil) then
+  if ((target_info.res<>res_none) and (target_res.resourcefileclass=nil)) or
+     (res_no_compile in target_res.resflags) then
     exit;
 
   p:=ExtractFilePath(ExpandFileName(current_module.mainsource^));

compiler/cutils.pas

@@ -52,6 +52,8 @@ interface
     {# Return @var(b) with the bit order reversed }
     function reverse_byte(b: byte): byte;
 
+    function next_prime(l: longint): longint;
+
     function used_align(varalign,minalign,maxalign:shortint):shortint;
     function isbetteralignedthan(new, org, limit: cardinal): boolean;
     function size_2_align(len : longint) : shortint;
@@ -59,6 +61,7 @@ interface
     procedure Replace(var s:string;s1:string;const s2:string);
     procedure Replace(var s:AnsiString;s1:string;const s2:AnsiString);
     procedure ReplaceCase(var s:string;const s1,s2:string);
+    procedure ReplaceCase(var s:ansistring;const s1,s2:ansistring);
     Function MatchPattern(const pattern,what:string):boolean;
     function upper(const c : char) : char;
     function upper(const s : string) : string;
@@ -66,6 +69,8 @@ interface
     function lower(const c : char) : char;
     function lower(const s : string) : string;
     function lower(const s : ansistring) : ansistring;
+    function rpos(const needle: char; const haystack: shortstring): longint; overload;
+    function rpos(const needle: shortstring; const haystack: shortstring): longint; overload;
     function trimbspace(const s:string):string;
     function trimspace(const s:string):string;
     function space (b : longint): string;
@@ -87,8 +92,6 @@ interface
     function nextpowerof2(value : int64; out power: longint) : int64;
     function backspace_quote(const s:string;const qchars:Tcharset):string;
     function octal_quote(const s:string;const qchars:Tcharset):string;
-    function maybequoted(const s:string):string;
-    function maybequoted(const s:ansistring):ansistring;
 
     {# If the string is quoted, in accordance with pascal, it is
        dequoted and returned in s, and the function returns true.
@@ -142,6 +145,10 @@ interface
 
     Function nextafter(x,y:double):double;
 
+  { hide Sysutils.ExecuteProcess in units using this one after SysUtils}
+  const
+    ExecuteProcess = 'Do not use' deprecated 'Use cfileutil.RequotedExecuteProcess instead, ExecuteProcess cannot deal with single quotes as used by Unix command lines';
+
 implementation
 
     uses
@@ -305,6 +312,33 @@ implementation
       end;
 
 
+    function next_prime(l: longint): longint;
+      var
+        check, checkbound: longint;
+        ok: boolean;
+      begin
+        result:=l or 1;
+        while l<high(longint) do
+          begin
+            ok:=true;
+            checkbound:=trunc(sqrt(l));
+            check:=3;
+            while check<checkbound do
+              begin
+                if (l mod check) = 0 then
+                  begin
+                    ok:=false;
+                    break;
+                  end;
+                inc(check,2);
+              end;
+            if ok then
+              exit;
+            inc(l);
+          end;
+      end;
+
+
     function used_align(varalign,minalign,maxalign:shortint):shortint;
       begin
         { varalign  : minimum alignment required for the variable
@@ -386,6 +420,26 @@ implementation
       end;
 
 
+    procedure ReplaceCase(var s: ansistring; const s1, s2: ansistring);
+      var
+         last,
+         i  : longint;
+      begin
+        last:=0;
+        repeat
+          i:=pos(s1,s);
+          if i=last then
+           i:=0;
+          if (i>0) then
+           begin
+             Delete(s,i,length(s1));
+             Insert(s2,s,i);
+             last:=i;
+           end;
+        until (i=0);
+      end;
+
+
     Function MatchPattern(const pattern,what:string):boolean;
       var
         found : boolean;
@@ -558,6 +612,34 @@ implementation
       end;
 
 
+    function rpos(const needle: char; const haystack: shortstring): longint;
+      begin
+        result:=length(haystack);
+        while (result>0) do
+          begin
+            if haystack[result]=needle then
+              exit;
+            dec(result);
+          end;
+      end;
+
+
+    function rpos(const needle: shortstring; const haystack: shortstring): longint;
+      begin
+        result:=0;
+        if (length(needle)=0) or
+           (length(needle)>length(haystack)) then
+          exit;
+        result:=length(haystack)-length(needle);
+        repeat
+          if (haystack[result]=needle[1]) and
+             (copy(haystack,result,length(needle))=needle) then
+            exit;
+          dec(result);
+        until result=0;
+      end;
+
+
     function trimbspace(const s:string):string;
     {
       return s with all leading spaces and tabs removed
@@ -822,93 +904,6 @@ implementation
         end;
     end;
 
-    function maybequoted(const s:ansistring):ansistring;
-      const
-        {$IFDEF MSWINDOWS}
-          FORBIDDEN_CHARS = ['!', '@', '#', '$', '%', '^', '&', '*', '(', ')',
-                             '{', '}', '''', '`', '~'];
-        {$ELSE}
-          FORBIDDEN_CHARS = ['!', '@', '#', '$', '%', '^', '&', '*', '(', ')',
-                             '{', '}', '''', ':', '\', '`', '~'];
-        {$ENDIF}
-      var
-        s1 : ansistring;
-        i  : integer;
-        quoted : boolean;
-      begin
-        quoted:=false;
-        s1:='"';
-        for i:=1 to length(s) do
-         begin
-           case s[i] of
-             '"' :
-               begin
-                 quoted:=true;
-                 s1:=s1+'\"';
-               end;
-             ' ',
-             #128..#255 :
-               begin
-                 quoted:=true;
-                 s1:=s1+s[i];
-               end;
-             else begin
-               if s[i] in FORBIDDEN_CHARS then
-                 quoted:=True;
-               s1:=s1+s[i];
-             end;
-           end;
-         end;
-        if quoted then
-          maybequoted:=s1+'"'
-        else
-          maybequoted:=s;
-      end;
-
-
-    function maybequoted(const s:string):string;
-      const
-        {$IFDEF MSWINDOWS}
-          FORBIDDEN_CHARS = ['!', '@', '#', '$', '%', '^', '&', '*', '(', ')',
-                             '{', '}', '''', '`', '~'];
-        {$ELSE}
-          FORBIDDEN_CHARS = ['!', '@', '#', '$', '%', '^', '&', '*', '(', ')',
-                             '{', '}', '''', ':', '\', '`', '~'];
-        {$ENDIF}
-      var
-        s1 : string;
-        i  : integer;
-        quoted : boolean;
-      begin
-        quoted:=false;
-        s1:='"';
-        for i:=1 to length(s) do
-         begin
-           case s[i] of
-             '"' :
-               begin
-                 quoted:=true;
-                 s1:=s1+'\"';
-               end;
-             ' ',
-             #128..#255 :
-               begin
-                 quoted:=true;
-                 s1:=s1+s[i];
-               end;
-             else begin
-               if s[i] in FORBIDDEN_CHARS then
-                 quoted:=True;
-               s1:=s1+s[i];
-             end;
-           end;
-         end;
-        if quoted then
-          maybequoted:=s1+'"'
-        else
-          maybequoted:=s;
-      end;
-
 
     function DePascalQuote(var s: ansistring): Boolean;
       var

compiler/dbgdwarf.pas

@@ -1790,7 +1790,7 @@ implementation
             DW_AT_byte_size,DW_FORM_udata,def.size,
             DW_AT_byte_stride,DW_FORM_udata,1
             ]);
-          append_labelentry_ref(DW_AT_type,def_dwarf_lab(cchartype));
+          append_labelentry_ref(DW_AT_type,def_dwarf_lab(cansichartype));
           finish_entry;
           append_entry(DW_TAG_subrange_type,false,[
             DW_AT_lower_bound,DW_FORM_udata,0,
@@ -1832,7 +1832,7 @@ implementation
            begin
              { looks like a pchar }
              append_entry(DW_TAG_pointer_type,false,[]);
-             append_labelentry_ref(DW_AT_type,def_dwarf_lab(cchartype));
+             append_labelentry_ref(DW_AT_type,def_dwarf_lab(cansichartype));
              finish_entry;
            end;
          st_unicodestring,
@@ -3823,19 +3823,19 @@ implementation
         case def.stringtype of
           st_shortstring:
             begin
-              addstringdef('ShortString',cchartype,false,1);
+              addstringdef('ShortString',cansichartype,false,1);
             end;
           st_longstring:
             begin
 {$ifdef cpu64bitaddr}
-              addstringdef('LongString',cchartype,false,8);
+              addstringdef('LongString',cansichartype,false,8);
 {$else cpu64bitaddr}
-              addstringdef('LongString',cchartype,false,4);
+              addstringdef('LongString',cansichartype,false,4);
 {$endif cpu64bitaddr}
            end;
          st_ansistring:
            begin
-             addstringdef('AnsiString',cchartype,true,-1);
+             addstringdef('AnsiString',cansichartype,true,-1);
            end;
          st_unicodestring:
            begin

compiler/dbgstabs.pas

@@ -573,14 +573,14 @@ implementation
               slen:=def.len;
               if slen=0 then
                 slen:=255;
-              charst:=def_stab_number(cchartype);
+              charst:=def_stab_number(cansichartype);
               bytest:=def_stab_number(u8inttype);
               ss:=def_stabstr_evaluate(def,'s$1length:$2,0,8;st:ar$2;1;$3;$4,8,$5;;',
                           [tostr(slen+1),bytest,tostr(slen),charst,tostr(slen*8)]);
             end;
           st_longstring:
             begin
-              charst:=def_stab_number(cchartype);
+              charst:=def_stab_number(cansichartype);
               bytest:=def_stab_number(u8inttype);
               longst:=def_stab_number(u32inttype);
               ss:=def_stabstr_evaluate(def,'s$1length:$2,0,32;dummy:$6,32,8;st:ar$2;1;$3;$4,40,$5;;',
@@ -589,7 +589,7 @@ implementation
          st_ansistring:
            begin
              { looks like a pchar }
-             ss:='*'+def_stab_number(cchartype);
+             ss:='*'+def_stab_number(cansichartype);
            end;
          st_unicodestring,
          st_widestring:
@@ -738,13 +738,13 @@ implementation
                                  'NAME:ar$1;0;255;$4,512,2048;;',[def_stab_number(s32inttype),
                                  def_stab_number(s64inttype),
                                  def_stab_number(u8inttype),
-                                 def_stab_number(cchartype)]);
+                                 def_stab_number(cansichartype)]);
 {$else cpu64bitaddr}
         ss:=def_stabstr_evaluate(def,'s${savesize}HANDLE:$1,0,32;MODE:$1,32,32;RECSIZE:$1,64,32;'+
                                  '_PRIVATE:ar$1;1;32;$3,96,256;USERDATA:ar$1;1;16;$2,352,128;'+
                                  'NAME:ar$1;0;255;$3,480,2048;;',[def_stab_number(s32inttype),
                                  def_stab_number(u8inttype),
-                                 def_stab_number(cchartype)]);
+                                 def_stab_number(cansichartype)]);
 {$endif cpu64bitaddr}
         write_def_stabstr(list,def,ss);
       end;
@@ -957,7 +957,7 @@ implementation
                 appenddef(list,cwidechartype)
               else
                 begin
-                  appenddef(list,cchartype);
+                  appenddef(list,cansichartype);
                   appenddef(list,u8inttype);
                 end;
             end;
@@ -970,7 +970,7 @@ implementation
               appenddef(list,s64inttype);
 {$endif cpu64bitaddr}
               appenddef(list,u8inttype);
-              appenddef(list,cchartype);
+              appenddef(list,cansichartype);
             end;
           classrefdef :
             appenddef(list,pvmttype);

compiler/defcmp.pas

@@ -100,7 +100,8 @@ interface
           tc_enum_2_variant,
           tc_interface_2_variant,
           tc_variant_2_interface,
-          tc_array_2_dynarray
+          tc_array_2_dynarray,
+          tc_elem_2_openarray
        );
 
     function compare_defs_ext(def_from,def_to : tdef;
@@ -210,6 +211,12 @@ implementation
             exit;
           end;
 
+         { resolve anonymous external definitions }
+         if def_from.typ=objectdef then
+           def_from:=find_real_class_definition(tobjectdef(def_from),false);
+         if def_to.typ=objectdef then
+           def_to:=find_real_class_definition(tobjectdef(def_to),false);
+
          { same def? then we've an exact match }
          if def_from=def_to then
           begin
@@ -506,10 +513,15 @@ implementation
                           begin
                             doconv:=tc_string_2_string;
                             { prefered string type depends on the $H switch }
-                            if not(cs_ansistrings in current_settings.localswitches) and
+                            if (m_default_unicodestring in current_settings.modeswitches) and
+                               (cs_refcountedstrings in current_settings.localswitches) and
+                               is_wide_or_unicode_string(def_to) then
+                              eq:=te_equal
+                            else if not(cs_refcountedstrings in current_settings.localswitches) and
                                (tstringdef(def_to).stringtype=st_shortstring) then
                               eq:=te_equal
-                            else if (cs_ansistrings in current_settings.localswitches) and
+                            else if not(m_default_unicodestring in current_settings.modeswitches) and
+                               (cs_refcountedstrings in current_settings.localswitches) and
                                (tstringdef(def_to).stringtype=st_ansistring) then
                               eq:=te_equal
                             else if tstringdef(def_to).stringtype in [st_widestring,st_unicodestring] then
@@ -579,9 +591,9 @@ implementation
                              { prefer ansistrings because pchars can overflow shortstrings, }
                              { but only if ansistrings are the default (JM)                 }
                              if (is_shortstring(def_to) and
-                                 not(cs_ansistrings in current_settings.localswitches)) or
+                                 not(cs_refcountedstrings in current_settings.localswitches)) or
                                 (is_ansistring(def_to) and
-                                 (cs_ansistrings in current_settings.localswitches)) then
+                                 (cs_refcountedstrings in current_settings.localswitches)) then
                                eq:=te_convert_l1
                              else
                                eq:=te_convert_l2;
@@ -603,6 +615,22 @@ implementation
                       begin
                         doconv:=tc_intf_2_string;
                         eq:=te_convert_l1;
+                      end
+                     else if (def_from=java_jlstring) then
+                       begin
+                         if is_wide_or_unicode_string(def_to) then
+                           begin
+                             doconv:=tc_equal;
+                             eq:=te_equal;
+                           end
+                         else if def_to.typ=stringdef then
+                           begin
+                             doconv:=tc_string_2_string;
+                             if is_ansistring(def_to) then
+                               eq:=te_convert_l2
+                             else
+                               eq:=te_convert_l3
+                           end;
                       end;
                    end;
                end;
@@ -718,22 +746,40 @@ implementation
                  pointerdef :
                    begin
                      { ugly, but delphi allows it }
-                     if (cdo_explicit in cdoptions) and
-                       (m_delphi in current_settings.modeswitches) then
+                     if cdo_explicit in cdoptions then
                        begin
-                         doconv:=tc_int_2_int;
-                         eq:=te_convert_l1;
+                         if target_info.system in systems_jvm then
+                           begin
+                             doconv:=tc_equal;
+                             eq:=te_convert_l1;
+                           end
+                         else if m_delphi in current_settings.modeswitches then
+                           begin
+                             doconv:=tc_int_2_int;
+                             eq:=te_convert_l1;
+                           end
                        end;
                    end;
                  objectdef:
                    begin
                      { ugly, but delphi allows it }
-                     if (m_delphi in current_settings.modeswitches) and
-                        is_class_or_interface_or_dispinterface(def_from) and
-                        (cdo_explicit in cdoptions) then
+                     if (cdo_explicit in cdoptions) and
+                        is_class_or_interface_or_objc_or_java(def_from) then
                        begin
-                         doconv:=tc_int_2_int;
-                         eq:=te_convert_l1;
+                         { in Java enums /are/ class instances, and hence such
+                           typecasts must not be treated as integer-like
+                           conversions
+                         }
+                         if target_info.system in systems_jvm then
+                           begin
+                             doconv:=tc_equal;
+                             eq:=te_convert_l1;
+                           end
+                         else if m_delphi in current_settings.modeswitches then
+                           begin
+                             doconv:=tc_int_2_int;
+                             eq:=te_convert_l1;
+                           end;
                        end;
                    end;
                end;
@@ -748,7 +794,7 @@ implementation
                   (def_from.typ=tarraydef(def_to).elementdef.typ) and
                   equal_defs(def_from,tarraydef(def_to).elementdef) then
                 begin
-                  doconv:=tc_equal;
+                  doconv:=tc_elem_2_openarray;
                   { also update in htypechk.pas/var_para_allowed if changed
                     here }
                   eq:=te_convert_l3;
@@ -1081,14 +1127,31 @@ implementation
                      { allow explicit typecasts from enums to pointer.
                        Support for delphi compatibility
                      }
+                     { in Java enums /are/ class instances, and hence such
+                       typecasts must not be treated as integer-like conversions
+                     }
                      if (((cdo_explicit in cdoptions) and
-                          (m_delphi in current_settings.modeswitches)
-                          ) or
+                          ((m_delphi in current_settings.modeswitches) or
+                           (target_info.system in systems_jvm)
+                          )
+                         ) or
                          (cdo_internal in cdoptions)
                         ) then
                        begin
-                         doconv:=tc_int_2_int;
-                         eq:=te_convert_l1;
+                         { in Java enums /are/ class instances, and hence such
+                           typecasts must not be treated as integer-like
+                           conversions
+                         }
+                         if target_info.system in systems_jvm then
+                           begin
+                             doconv:=tc_equal;
+                             eq:=te_convert_l1;
+                           end
+                         else if m_delphi in current_settings.modeswitches then
+                           begin
+                             doconv:=tc_int_2_int;
+                             eq:=te_convert_l1;
+                           end;
                        end;
                    end;
                  arraydef :
@@ -1347,23 +1410,40 @@ implementation
 
            objectdef :
              begin
-               { Objective-C classes (handle anonymous externals) }
-               if (def_from.typ=objectdef) and
-                  (find_real_objcclass_definition(tobjectdef(def_from),false) =
-                   find_real_objcclass_definition(tobjectdef(def_to),false)) then
-                 begin
-                   doconv:=tc_equal;
-                   { exact, not equal, because can change between interface
-                     and implementation }
-                   eq:=te_exact;
-                 end
                { object pascal objects }
-               else if (def_from.typ=objectdef) and
+               if (def_from.typ=objectdef) and
                   (tobjectdef(def_from).is_related(tobjectdef(def_to))) then
                 begin
                   doconv:=tc_equal;
-                  eq:=te_convert_l1;
+                  { also update in htypechk.pas/var_para_allowed if changed
+                    here }
+                  eq:=te_convert_l3;
                 end
+               { string -> java.lang.string }
+               else if (def_to=java_jlstring) and
+                       ((def_from.typ=stringdef) or
+                        (fromtreetype=stringconstn)) then
+                 begin
+                   if is_wide_or_unicode_string(def_from) or
+                      ((fromtreetype=stringconstn) and
+                       (cs_refcountedstrings in current_settings.localswitches) and
+                       (m_default_unicodestring in current_settings.modeswitches)) then
+                     begin
+                       doconv:=tc_equal;
+                       eq:=te_equal
+                     end
+                   else
+                     begin
+                       doconv:=tc_string_2_string;
+                       eq:=te_convert_l2;
+                     end;
+                 end
+               else if (def_to=java_jlstring) and
+                       is_anychar(def_from) then
+                 begin
+                   doconv:=tc_char_2_string;
+                   eq:=te_convert_l2
+                 end
                else
                { specific to implicit pointer object types }
                 if is_implicit_pointer_object_type(def_to) then
@@ -1395,7 +1475,9 @@ implementation
                    else if ((is_interface(def_to) and
                              is_class(def_from)) or
                             (is_objcprotocol(def_to) and
-                             is_objcclass(def_from))) and
+                             is_objcclass(def_from)) or
+                            (is_javainterface(def_to) and
+                             is_javaclass(def_from))) and
                            assigned(tobjectdef(def_from).ImplementedInterfaces) then
                      begin
                         { we've to search in parent classes as well }
@@ -1433,9 +1515,14 @@ implementation
                        eq:=te_convert_l2;
                      end
                    { ugly, but delphi allows it }
-                   else if (def_from.typ in [orddef,enumdef]) and
-                     (m_delphi in current_settings.modeswitches) and
-                     (cdo_explicit in cdoptions) then
+                   { in Java enums /are/ class instances, and hence such
+                     typecasts must not be treated as integer-like conversions
+                   }
+                   else if ((not(target_info.system in systems_jvm) and
+                        (def_from.typ=enumdef)) or
+                       (def_from.typ=orddef)) and
+                      (m_delphi in current_settings.modeswitches) and
+                      (cdo_explicit in cdoptions) then
                      begin
                        doconv:=tc_int_2_int;
                        eq:=te_convert_l1;
@@ -1975,8 +2062,8 @@ implementation
           (equal_defs(parentretdef,childretdef)) or
           ((parentretdef.typ=objectdef) and
            (childretdef.typ=objectdef) and
-           is_class_or_interface_or_objc(parentretdef) and
-           is_class_or_interface_or_objc(childretdef) and
+           is_class_or_interface_or_objc_or_java(parentretdef) and
+           is_class_or_interface_or_objc_or_java(childretdef) and
            (tobjectdef(childretdef).is_related(tobjectdef(parentretdef))))
       end;
 

compiler/defutil.pas

@@ -101,7 +101,6 @@ interface
     {# Returns whether def is reference counted }
     function is_managed_type(def: tdef) : boolean;{$ifdef USEINLINE}inline;{$endif}
 
-
 {    function is_in_limit_value(val_from:TConstExprInt;def_from,def_to : tdef) : boolean;}
 
 {*****************************************************************************

compiler/expunix.pas

@@ -59,7 +59,7 @@ uses
   aasmdata,aasmtai,aasmcpu,
   fmodule,
   cgbase,cgutils,cpubase,cgobj,
-  cgcpu,
+  cgcpu,hlcgobj,hlcgcpu,
   ncgutil,
   verbose;
 
@@ -136,7 +136,7 @@ var
   r : treference;
 {$endif x86}
 begin
-  create_codegen;
+  create_hlcodegen;
   new_section(current_asmdata.asmlists[al_procedures],sec_code,'',0);
   hp2:=texported_item(current_module._exports.first);
   while assigned(hp2) do
@@ -182,7 +182,7 @@ begin
        end;
      hp2:=texported_item(hp2.next);
    end;
-   destroy_codegen;
+   destroy_hlcodegen;
 end;
 
 

compiler/finput.pas

@@ -284,6 +284,8 @@ uses
               Freemem(buf,maxbufsize);
               buf:=nil;
             end;
+           stringdispose(name);
+           stringdispose(path);
            closed:=true;
            exit;
          end;

compiler/fmodule.pas

@@ -143,6 +143,8 @@ interface
         checkforwarddefs,
         deflist,
         symlist       : TFPObjectList;
+        ptrdefs       : THashSet; { list of pointerdefs created in this module so we can reuse them (not saved/restored) }
+        arraydefs     : THashSet; { list of single-element-arraydefs created in this module so we can reuse them (not saved/restored) }
         ansistrdef    : tobject; { an ansistring def redefined for the current module }
         wpoinfo       : tunitwpoinfobase; { whole program optimization-related information that is generated during the current run for this unit }
         globalsymtable,           { pointer to the global symtable of this unit }
@@ -184,6 +186,15 @@ interface
           tobjectdef instances (the helper defs) }
         extendeddefs: TFPHashObjectList;
 
+        namespace: pshortstring; { for JVM target: corresponds to Java package name }
+
+        { for targets that initialise typed constants via explicit assignments
+          instead of by generating an initialised data section (holds typed
+          constant assignments at the module level; does not have to be saved
+          into the ppu file, because translated into code during compilation)
+           -- actual type: tnode (but fmodule should not depend on node) }
+         tcinitcode     : tobject;
+
         {create creates a new module which name is stored in 's'. LoadedFrom
         points to the module calling it. It is nil for the first compiled
         module. This allow inheritence of all path lists. MUST pay attention
@@ -524,6 +535,8 @@ implementation
         derefdataintflen:=0;
         deflist:=TFPObjectList.Create(false);
         symlist:=TFPObjectList.Create(false);
+        ptrdefs:=THashSet.Create(64,true,false);
+        arraydefs:=THashSet.Create(64,true,false);
         ansistrdef:=nil;
         wpoinfo:=nil;
         checkforwarddefs:=TFPObjectList.Create(false);
@@ -549,6 +562,8 @@ implementation
         mode_switch_allowed:= true;
         moduleoptions:=[];
         deprecatedmsg:=nil;
+        namespace:=nil;
+        tcinitcode:=nil;
         _exports:=TLinkedList.Create;
         dllscannerinputlist:=TFPHashList.Create;
         asmdata:=casmdata.create(realmodulename^);
@@ -626,6 +641,8 @@ implementation
         stringdispose(mainsource);
         stringdispose(asmprefix);
         stringdispose(deprecatedmsg);
+        stringdispose(namespace);
+        tcinitcode.free;
         localunitsearchpath.Free;
         localobjectsearchpath.free;
         localincludesearchpath.free;
@@ -637,6 +654,8 @@ implementation
         derefdata.free;
         deflist.free;
         symlist.free;
+        ptrdefs.free;
+        arraydefs.free;
         ansistrdef:=nil;
         wpoinfo.free;
         checkforwarddefs.free;
@@ -698,6 +717,10 @@ implementation
         deflist:=TFPObjectList.Create(false);
         symlist.free;
         symlist:=TFPObjectList.Create(false);
+        ptrdefs.free;
+        ptrdefs:=THashSet.Create(64,true,false);
+        arraydefs.free;
+        arraydefs:=THashSet.Create(64,true,false);
         wpoinfo.free;
         wpoinfo:=nil;
         checkforwarddefs.free;
@@ -758,6 +781,9 @@ implementation
         in_global:=true;
         mode_switch_allowed:=true;
         stringdispose(deprecatedmsg);
+        stringdispose(namespace);
+        tcinitcode.free;
+        tcinitcode:=nil;
         moduleoptions:=[];
         is_dbginfo_written:=false;
         crc:=0;

compiler/fpcdefs.inc

@@ -183,6 +183,14 @@
   {$define cpurefshaveindexreg}
 {$endif mips}
 
+{$ifdef jvm}
+  {$define cpu32bit}
+  {$define cpu64bitalu}
+  {$define cpu32bitaddr}
+  {$define cpuhighleveltarget}
+  {$define symansistr}
+{$endif}
+
 {$IFDEF MACOS}
 {$DEFINE USE_FAKE_SYSUTILS}
 {$ENDIF MACOS}

compiler/fppu.pas

@@ -107,7 +107,7 @@ interface
 implementation
 
 uses
-  SysUtils,
+  SysUtils,strutils,
   cfileutl,
   systems,version,
   symtable, symsym,
@@ -946,11 +946,16 @@ var
       var
         b : byte;
         newmodulename : string;
+        ns: string;
       begin
        { read interface part }
          repeat
            b:=ppufile.readentry;
            case b of
+             ibjvmnamespace :
+               begin
+                 namespace:=stringdup(ppufile.getstring);
+               end;
              ibmodulename :
                begin
                  newmodulename:=ppufile.getstring;
@@ -1067,7 +1072,13 @@ var
          if not ppufile.createfile then
           Message(unit_f_ppu_cannot_write);
 
-         { first the unitname }
+         { first the (JVM) namespace }
+         if assigned(namespace) then
+           begin
+             ppufile.putstring(namespace^);
+             ppufile.writeentry(ibjvmnamespace);
+           end;
+         { the unitname }
          ppufile.putstring(realmodulename^);
          ppufile.writeentry(ibmodulename);
 
@@ -1219,7 +1230,13 @@ var
          if not ppufile.createfile then
            Message(unit_f_ppu_cannot_write);
 
-         { first the unitname }
+         { first the (JVM) namespace }
+         if assigned(namespace) then
+           begin
+             ppufile.putstring(namespace^);
+             ppufile.writeentry(ibjvmnamespace);
+           end;
+         { the unitname }
          ppufile.putstring(realmodulename^);
          ppufile.writeentry(ibmodulename);
 

compiler/gendef.pas

@@ -25,15 +25,15 @@ unit gendef;
 
 interface
 uses
-  cclasses;
+  globtype,cclasses;
 
 type
   tdeffile=class
     fname : string;
     constructor create(const fn:string);
     destructor  destroy;override;
-    procedure addexport(const s:string);
-    procedure addimport(const s:string);
+    procedure addexport(const s:TSymStr);
+    procedure addimport(const s:TSymStr);
     procedure writefile;
     function empty : boolean;
   private
@@ -51,7 +51,7 @@ implementation
 
 uses
   SysUtils,
-  systems,cutils,globtype,globals;
+  systems,cutils,globals;
 
 {******************************************************************************
                                TDefFile
@@ -78,14 +78,14 @@ end;
 
 
 
-procedure tdeffile.addexport(const s:string);
+procedure tdeffile.addexport(const s:TSymStr);
 begin
   exportlist.insert(s);
   is_empty:=false;
 end;
 
 
-procedure tdeffile.addimport(const s:string);
+procedure tdeffile.addimport(const s:TSymStr);
 begin
   importlist.insert(s);
   is_empty:=false;

compiler/globals.pas

@@ -434,9 +434,18 @@ interface
         optimizecputype : cpu_mips32;
         fputype : fpu_mips2;
   {$endif mips}
+  {$ifdef jvm}
+        cputype : cpu_none;
+        optimizecputype : cpu_none;
+        fputype : fpu_standard;
+  {$endif jvm}
 {$endif not GENERIC_CPU}
         asmmode : asmmode_standard;
+{$ifndef jvm}
         interfacetype : it_interfacecom;
+{$else jvm}
+        interfacetype : it_interfacejava;
+{$endif jvm}
         defproccall : pocall_default;
         sourcecodepage : 28591;
         minfpconstprec : s32real;
@@ -458,7 +467,6 @@ interface
 
     procedure DefaultReplacements(var s:ansistring);
 
-    function Shell(const command:ansistring): longint;
     function  GetEnvPChar(const envname:string):pchar;
     procedure FreeEnvPChar(p:pchar);
 
@@ -500,6 +508,11 @@ interface
 {$endif ARM}
     function floating_point_range_check_error : boolean;
 
+  { hide Sysutils.ExecuteProcess in units using this one after SysUtils}
+  const
+    ExecuteProcess = 'Do not use' deprecated 'Use cfileutil.RequotedExecuteProcess instead, ExecuteProcess cannot deal with single quotes as used by Unix command lines';
+
+
 implementation
 
     uses
@@ -880,28 +893,6 @@ implementation
   {$define AMIGASHELL}
 {$endif}
 
-    function Shell(const command:ansistring): longint;
-      { This is already defined in the linux.ppu for linux, need for the *
-        expansion under linux }
-{$ifdef hasunix}
-      begin
-        result := Unix.fpsystem(command);
-      end;
-{$else hasunix}
-  {$ifdef amigashell}
-      begin
-        result := ExecuteProcess('',command);
-      end;
-  {$else amigashell}
-      var
-        comspec : string;
-      begin
-        comspec:=GetEnvironmentVariable('COMSPEC');
-        result := ExecuteProcess(comspec,' /C '+command);
-      end;
-   {$endif amigashell}
-{$endif hasunix}
-
 {$UNDEF AMIGASHELL}
       function is_number_float(d : double) : boolean;
         var

compiler/globtype.pas

@@ -34,6 +34,13 @@ interface
        TCmdStr = AnsiString;
        TPathStr = AnsiString;
 
+{$ifdef symansistr}
+       TSymStr = AnsiString;
+{$else symansistr}
+       TSymStr = ShortString;
+{$endif symansistr}
+       PSymStr = ^TSymStr;
+
        { Integer type corresponding to pointer size }
 {$ifdef cpu64bitaddr}
        PUint = qword;
@@ -124,10 +131,12 @@ interface
          { mmx }
          cs_mmx,cs_mmx_saturation,
          { parser }
-         cs_typed_addresses,cs_strict_var_strings,cs_ansistrings,cs_bitpacking,
-         cs_varpropsetter,cs_scopedenums,cs_pointermath,
+         cs_typed_addresses,cs_strict_var_strings,cs_refcountedstrings,
+         cs_bitpacking,cs_varpropsetter,cs_scopedenums,cs_pointermath,
          { macpas specific}
-         cs_external_var, cs_externally_visible
+         cs_external_var, cs_externally_visible,
+         { jvm specific }
+         cs_check_var_copyout
        );
        tlocalswitches = set of tlocalswitch;
 
@@ -199,7 +208,11 @@ interface
        { global target-specific switches }
        ttargetswitch = (ts_none,
          { generate code that results in smaller TOCs than normal (AIX) }
-         ts_small_toc
+         ts_small_toc,
+         { for the JVM target: generate integer array initializations via string
+           constants in order to reduce the generated code size (Java routines
+           are limited to 64kb of bytecode) }
+         ts_compact_int_array_init
        );
        ttargetswitches = set of ttargetswitch;
 
@@ -255,7 +268,8 @@ interface
          'DWARFSETS','STABSABSINCLUDES','DWARFMETHODCLASSPREFIX');
 
        TargetSwitchStr : array[ttargetswitch] of string[19] = ('',
-         'SMALLTOC');
+         'SMALLTOC',
+         'COMPACTINTARRAYINIT');
 
        { switches being applied to all CPUs at the given level }
        genericlevel1optimizerswitches = [cs_opt_level1];
@@ -308,7 +322,12 @@ interface
          m_non_local_goto,      { support non local gotos (like iso pascal) }
          m_advanced_records,    { advanced record syntax with visibility sections, methods and properties }
          m_isolike_unary_minus, { unary minus like in iso pascal: same precedence level as binary minus/plus }
-         m_systemcodepage       { use system codepage as compiler codepage by default, emit ansistrings with system codepage }
+         m_systemcodepage,      { use system codepage as compiler codepage by default, emit ansistrings with system codepage }
+         m_final_fields,        { allows declaring fields as "final", which means they must be initialised
+                                  in the (class) constructor and are constant from then on (same as final
+                                  fields in Java) }
+         m_default_unicodestring { makes the default string type in $h+ mode unicodestring rather than
+                                   ansistring; similarly, char becomes unicodechar rather than ansichar }
        );
        tmodeswitches = set of tmodeswitch;
 
@@ -328,7 +347,8 @@ interface
        { interface types }
        tinterfacetypes = (
          it_interfacecom,
-         it_interfacecorba
+         it_interfacecorba,
+         it_interfacejava
        );
 
        { currently parsed block type }
@@ -346,8 +366,27 @@ interface
 
        { Temp types }
        ttemptype = (tt_none,
-                    tt_free,tt_normal,tt_persistent,
-                    tt_noreuse,tt_freenoreuse);
+                    { free temp location, can be reused for something else }
+                    tt_free,
+                    { temp location that will be freed when ttgobj.UnGetTemp/
+                      ttgobj.UnGetIfTemp is called on it }
+                    tt_normal,
+                    { temp location that will not be freed; if it has to be
+                      freed, first ttgobj.changetemptype() it to tt_normal,
+                      or call ttgobj.UnGetLocal() instead (for local variables,
+                      since they are also persistent temps) }
+                    tt_persistent,
+                    { temp location that can never be reused anymore, even
+                      after it has been freed }
+                    tt_noreuse,
+                    { freed version of the above }
+                    tt_freenoreuse,
+                    { temp location that has been allocated by the register
+                      allocator and that can be reallocated only by the
+                      register allocator }
+                    tt_regallocator,
+                    { freed version of the above }
+                    tt_freeregallocator);
        ttemptypeset = set of ttemptype;
 
        { calling convention for tprocdef and tprocvardef }
@@ -441,7 +480,9 @@ interface
          'NONLOCALGOTO',
          'ADVANCEDRECORDS',
          'ISOUNARYMINUS',
-         'SYSTEMCODEPAGE');
+         'SYSTEMCODEPAGE',
+         'FINALFIELDS',
+         'UNICODESTRINGS');
 
 
      type
@@ -569,6 +610,9 @@ interface
       end;
 
 
+  { hide Sysutils.ExecuteProcess in units using this one after SysUtils}
+  const
+    ExecuteProcess = 'Do not use' deprecated 'Use cfileutil.RequotedExecuteProcess instead, ExecuteProcess cannot deal with single quotes as used by Unix command lines';
 
 implementation
 

compiler/hlcg2ll.pas

@@ -0,0 +1,1240 @@
+{
+    Copyright (c) 1998-2010 by Florian Klaempfl and Jonas Maebe
+    Member of the Free Pascal development team
+
+    This unit implements the high level code generator object for targets that
+    only use the low-level code generator
+
+    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.
+
+ ****************************************************************************
+}
+{# @abstract(High level code generator to low level)
+  This class passes the high level code generator methods through to the
+  low level code generator.
+}
+unit hlcg2ll;
+
+{$i fpcdefs.inc}
+
+{ define hlcginline}
+
+  interface
+
+    uses
+       cclasses,globtype,constexp,
+       cpubase,cgbase,cgutils,parabase,
+       aasmbase,aasmtai,aasmdata,aasmcpu,
+       symconst,symtype,symdef,rgobj,
+       node,hlcgobj
+       ;
+
+    type
+       {# @abstract(Abstract high level code generator)
+          This class implements an abstract instruction generator. All
+          methods of this class are generic and are mapped to low level code
+          generator methods by default. They have to be overridden for higher
+          level targets
+       }
+
+       { thlcg2ll }
+
+       thlcg2ll = class(thlcgobj)
+       public
+          {************************************************}
+          {                 basic routines                 }
+          constructor create;
+          procedure init_register_allocators;override;
+          {# Clean up the register allocators needed for the codegenerator.}
+          procedure done_register_allocators;override;
+          {# Set whether live_start or live_end should be updated when allocating registers, needed when e.g. generating initcode after the rest of the code. }
+          procedure set_regalloc_live_range_direction(dir: TRADirection);override;
+
+          {# Gets a register suitable to do integer operations on.}
+          function getintregister(list:TAsmList;size:tdef):Tregister;override;
+          {# Gets a register suitable to do integer operations on.}
+          function getaddressregister(list:TAsmList;size:tdef):Tregister;override;
+          function getfpuregister(list:TAsmList;size:tdef):Tregister;override;
+//        we don't have high level defs yet that translate into all mm cgsizes
+//          function getmmregister(list:TAsmList;size:tdef):Tregister;override;
+          function getflagregister(list:TAsmList;size:tdef):Tregister;override;
+          {Does the generic cg need SIMD registers, like getmmxregister? Or should
+           the cpu specific child cg object have such a method?}
+
+          function  uses_registers(rt:Tregistertype):boolean; inline;
+
+          procedure do_register_allocation(list:TAsmList;headertai:tai); inline;
+          procedure translate_register(var reg : tregister); inline;
+
+          {# Emit a label to the instruction stream. }
+          procedure a_label(list : TAsmList;l : tasmlabel); inline;
+
+          {# Allocates register r by inserting a pai_realloc record }
+          procedure a_reg_alloc(list : TAsmList;r : tregister); inline;
+          {# Deallocates register r by inserting a pa_regdealloc record}
+          procedure a_reg_dealloc(list : TAsmList;r : tregister); inline;
+          { Synchronize register, make sure it is still valid }
+          procedure a_reg_sync(list : TAsmList;r : tregister); inline;
+
+          {# Pass a parameter, which is located in a register, to a routine.
+
+             This routine should push/send the parameter to the routine, as
+             required by the specific processor ABI and routine modifiers.
+             It must generate register allocation information for the cgpara in
+             case it consists of cpuregisters.
+
+             @param(size size of the operand in the register)
+             @param(r register source of the operand)
+             @param(cgpara where the parameter will be stored)
+          }
+          procedure a_load_reg_cgpara(list : TAsmList;size : tdef;r : tregister;const cgpara : TCGPara);override;
+          {# Pass a parameter, which is a constant, to a routine.
+
+             A generic version is provided. This routine should
+             be overridden for optimization purposes if the cpu
+             permits directly sending this type of parameter.
+             It must generate register allocation information for the cgpara in
+             case it consists of cpuregisters.
+
+             @param(size size of the operand in constant)
+             @param(a value of constant to send)
+             @param(cgpara where the parameter will be stored)
+          }
+          procedure a_load_const_cgpara(list : TAsmList;tosize : tdef;a : aint;const cgpara : TCGPara);override;
+          {# Pass the value of a parameter, which is located in memory, to a routine.
+
+             A generic version is provided. This routine should
+             be overridden for optimization purposes if the cpu
+             permits directly sending this type of parameter.
+             It must generate register allocation information for the cgpara in
+             case it consists of cpuregisters.
+
+             @param(size size of the operand in constant)
+             @param(r Memory reference of value to send)
+             @param(cgpara where the parameter will be stored)
+          }
+          procedure a_load_ref_cgpara(list : TAsmList;size : tdef;const r : treference;const cgpara : TCGPara);override;
+          {# Pass the value of a parameter, which can be located either in a register or memory location,
+             to a routine.
+
+             A generic version is provided.
+
+             @param(l location of the operand to send)
+             @param(nr parameter number (starting from one) of routine (from left to right))
+             @param(cgpara where the parameter will be stored)
+          }
+          procedure a_load_loc_cgpara(list : TAsmList;size : tdef; const l : tlocation;const cgpara : TCGPara);override;
+          {# Pass the address of a reference to a routine. This routine
+             will calculate the address of the reference, and pass this
+             calculated address as a parameter.
+             It must generate register allocation information for the cgpara in
+             case it consists of cpuregisters.
+
+             A generic version is provided. This routine should
+             be overridden for optimization purposes if the cpu
+             permits directly sending this type of parameter.
+
+             @param(fromsize type of the reference we are taking the address of)
+             @param(tosize type of the pointer that we get as a result)
+             @param(r reference to get address from)
+          }
+          procedure a_loadaddr_ref_cgpara(list : TAsmList;fromsize, tosize : tdef;const r : treference;const cgpara : TCGPara);override;
+
+          procedure a_call_name(list : TAsmList;pd : tprocdef;const s : TSymStr; weak: boolean);override;
+          procedure a_call_reg(list : TAsmList;pd : tabstractprocdef;reg : tregister);override;
+          procedure a_call_ref(list : TAsmList;pd : tabstractprocdef;ref : treference);override;
+          { same as a_call_name, might be overridden on certain architectures to emit
+            static calls without usage of a got trampoline }
+          procedure a_call_name_static(list : TAsmList;pd : tprocdef;const s : TSymStr);override;
+
+          { move instructions }
+          procedure a_load_const_reg(list : TAsmList;tosize : tdef;a : aint;register : tregister);override;
+          procedure a_load_const_ref(list : TAsmList;tosize : tdef;a : aint;const ref : treference);override;
+          procedure a_load_const_loc(list : TAsmList;tosize : tdef;a : aint;const loc : tlocation);override;
+          procedure a_load_reg_ref(list : TAsmList;fromsize, tosize : tdef;register : tregister;const ref : treference);override;
+          procedure a_load_reg_ref_unaligned(list : TAsmList;fromsize, tosize : tdef;register : tregister;const ref : treference);override;
+          procedure a_load_reg_reg(list : TAsmList;fromsize, tosize : tdef;reg1,reg2 : tregister);override;
+          procedure a_load_reg_loc(list : TAsmList;fromsize, tosize : tdef;reg : tregister;const loc: tlocation);override;
+          procedure a_load_ref_reg(list : TAsmList;fromsize, tosize : tdef;const ref : treference;register : tregister);override;
+          procedure a_load_ref_reg_unaligned(list : TAsmList;fromsize, tosize : tdef;const ref : treference;register : tregister);override;
+          procedure a_load_ref_ref(list : TAsmList;fromsize, tosize : tdef;const sref : treference;const dref : treference);override;
+          procedure a_load_loc_reg(list : TAsmList;fromsize, tosize : tdef; const loc: tlocation; reg : tregister);override;
+          procedure a_load_loc_ref(list : TAsmList;fromsize, tosize: tdef; const loc: tlocation; const ref : treference);override;
+          procedure a_load_loc_subsetreg(list : TAsmList;fromsize, tosize, tosubsetsize: tdef; const loc: tlocation; const sreg : tsubsetregister);override;
+          procedure a_load_loc_subsetref(list : TAsmList;fromsize, tosize, tosubsetsize: tdef; const loc: tlocation; const sref : tsubsetreference);override;
+          procedure a_loadaddr_ref_reg(list : TAsmList;fromsize, tosize : tdef;const ref : treference;r : tregister);override;
+
+          procedure a_load_subsetreg_reg(list : TAsmList; fromsize, fromsubsetsize, tosize: tdef; const sreg: tsubsetregister; destreg: tregister); override;
+          procedure a_load_reg_subsetreg(list : TAsmList; fromsize, tosize, tosubsetsize: tdef; fromreg: tregister; const sreg: tsubsetregister); override;
+          procedure a_load_subsetreg_subsetreg(list: TAsmlist; fromsize, fromsubsetsize, tosize, tosubsetsize : tdef; const fromsreg, tosreg: tsubsetregister); override;
+          procedure a_load_subsetreg_ref(list : TAsmList; fromsize, fromsubsetsize, tosize: tdef; const sreg: tsubsetregister; const destref: treference); override;
+          procedure a_load_ref_subsetreg(list : TAsmList; fromsize, tosize,tosubsetsize: tdef; const fromref: treference; const sreg: tsubsetregister); override;
+          procedure a_load_const_subsetreg(list: TAsmlist; tosize, tosubsetsize: tdef; a: aint; const sreg: tsubsetregister); override;
+          procedure a_load_subsetreg_loc(list: TAsmlist; fromsize, fromsubsetsize, tosize: tdef; const sreg: tsubsetregister; const loc: tlocation); override;
+
+          procedure a_load_subsetref_reg(list : TAsmList; fromsize, fromsubsetsize, tosize: tdef; const sref: tsubsetreference; destreg: tregister); override;
+          procedure a_load_reg_subsetref(list : TAsmList; fromsize, tosubsetsize, tosize: tdef; fromreg: tregister; const sref: tsubsetreference);override;
+          procedure a_load_subsetref_subsetref(list: TAsmlist; fromsize, fromsubsetsize, tosize, tosubsetsize : tdef; const fromsref, tosref: tsubsetreference); override;
+          procedure a_load_subsetref_ref(list : TAsmList; fromsize, fromsubsetsize, tosize: tdef; const sref: tsubsetreference; const destref: treference); override;
+          procedure a_load_ref_subsetref(list : TAsmList; fromsize, tosize, tosubsetsize: tdef; const fromref: treference; const sref: tsubsetreference); override;
+          procedure a_load_const_subsetref(list: TAsmlist; tosize, tosubsetsize: tdef; a: aint; const sref: tsubsetreference); override;
+          procedure a_load_subsetref_loc(list: TAsmlist; fromsize, fromsubsetsize, tosize: tdef; const sref: tsubsetreference; const loc: tlocation); override;
+          procedure a_load_subsetref_subsetreg(list: TAsmlist; fromsize, fromsubsetsize, tosize, tosubsetsize : tdef; const fromsref: tsubsetreference; const tosreg: tsubsetregister); override;
+          procedure a_load_subsetreg_subsetref(list: TAsmlist; fromsize, fromsubsetsize, tosize, tosubsetsize : tdef; const fromsreg: tsubsetregister; const tosref: tsubsetreference); override;
+
+          { bit test instructions }
+          procedure a_bit_test_reg_reg_reg(list : TAsmList; bitnumbersize,valuesize,destsize: tdef;bitnumber,value,destreg: tregister); override;
+          procedure a_bit_test_const_ref_reg(list: TAsmList; fromsize, destsize: tdef; bitnumber: aint; const ref: treference; destreg: tregister); override;
+          procedure a_bit_test_const_reg_reg(list: TAsmList; setregsize, destsize: tdef; bitnumber: aint; setreg, destreg: tregister); override;
+          procedure a_bit_test_const_subsetreg_reg(list: TAsmList; fromsize, fromsubsetsize, destsize: tdef; bitnumber: aint; const setreg: tsubsetregister; destreg: tregister); override;
+          procedure a_bit_test_reg_ref_reg(list: TAsmList; bitnumbersize, refsize, destsize: tdef; bitnumber: tregister; const ref: treference; destreg: tregister); override;
+          procedure a_bit_test_reg_loc_reg(list: TAsmList; bitnumbersize, locsize, destsize: tdef; bitnumber: tregister; const loc: tlocation; destreg: tregister);override;
+          procedure a_bit_test_const_loc_reg(list: TAsmList; locsize, destsize: tdef; bitnumber: aint; const loc: tlocation; destreg: tregister);override;
+
+          { bit set/clear instructions }
+          procedure a_bit_set_reg_reg(list : TAsmList; doset: boolean; bitnumbersize, destsize: tdef; bitnumber,dest: tregister); override;
+          procedure a_bit_set_const_ref(list: TAsmList; doset: boolean;destsize: tdef; bitnumber: aint; const ref: treference); override;
+          procedure a_bit_set_const_reg(list: TAsmList; doset: boolean; destsize: tdef; bitnumber: aint; destreg: tregister); override;
+          procedure a_bit_set_const_subsetreg(list: TAsmList; doset: boolean; destsize, destsubsetsize: tdef; bitnumber: aint; const destreg: tsubsetregister); override;
+          procedure a_bit_set_reg_ref(list: TAsmList; doset: boolean; fromsize, tosize: tdef; bitnumber: tregister; const ref: treference); override;
+          procedure a_bit_set_reg_loc(list: TAsmList; doset: boolean; fromsize, tosize: tdef; bitnumber: tregister; const loc: tlocation);override;
+          procedure a_bit_set_const_loc(list: TAsmList; doset: boolean; tosize: tdef; bitnumber: aint; const loc: tlocation);override;
+
+          { bit scan instructions }
+          procedure a_bit_scan_reg_reg(list: TAsmList; reverse: boolean; size: tdef; src, dst: tregister); override;
+
+          { fpu move instructions }
+          procedure a_loadfpu_reg_reg(list: TAsmList; fromsize, tosize: tdef; reg1, reg2: tregister); 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;
+          procedure a_loadfpu_ref_ref(list: TAsmList; fromsize, tosize: tdef; const ref1,ref2: treference);override;
+          procedure a_loadfpu_loc_reg(list: TAsmList; fromsize, tosize: tdef; const loc: tlocation; const reg: tregister);override;
+          procedure a_loadfpu_reg_loc(list: TAsmList; fromsize, tosize: tdef; const reg: tregister; const loc: tlocation);override;
+          procedure a_loadfpu_reg_cgpara(list : TAsmList;fromsize: tdef;const r : tregister;const cgpara : TCGPara);override;
+          procedure a_loadfpu_ref_cgpara(list : TAsmList;fromsize : tdef;const ref : treference;const cgpara : TCGPara);override;
+
+          { vector register move instructions }
+//        we don't have high level defs yet that translate into all mm cgsizes
+{
+          procedure a_loadmm_reg_reg(list: TAsmList; fromsize, tosize: tdef;reg1, reg2: tregister;shuffle : pmmshuffle); override;
+          procedure a_loadmm_ref_reg(list: TAsmList; fromsize, tosize: tdef;const ref: treference; reg: tregister;shuffle : pmmshuffle); override;
+          procedure a_loadmm_reg_ref(list: TAsmList; fromsize, tosize: tdef;reg: tregister; const ref: treference;shuffle : pmmshuffle); override;
+          procedure a_loadmm_loc_reg(list: TAsmList; fromsize, tosize: tdef; const loc: tlocation; const reg: tregister;shuffle : pmmshuffle);override;
+          procedure a_loadmm_reg_loc(list: TAsmList; fromsize, tosize: tdef; const reg: tregister; const loc: tlocation;shuffle : pmmshuffle);override;
+          procedure a_loadmm_reg_cgpara(list: TAsmList; fromsize: tdef; reg: tregister;const cgpara : TCGPara;shuffle : pmmshuffle); override;
+          procedure a_loadmm_ref_cgpara(list: TAsmList; fromsize: tdef; const ref: treference;const cgpara : TCGPara;shuffle : pmmshuffle); override;
+          procedure a_loadmm_loc_cgpara(list: TAsmList; fromsize: tdef; const loc: tlocation; const cgpara : TCGPara;shuffle : pmmshuffle); override;
+          procedure a_opmm_reg_reg(list: TAsmList; Op: TOpCG; size : tdef;src,dst: tregister;shuffle : pmmshuffle); override;
+          procedure a_opmm_ref_reg(list: TAsmList; Op: TOpCG; size : tdef;const ref: treference; reg: tregister;shuffle : pmmshuffle); override;
+          procedure a_opmm_loc_reg(list: TAsmList; Op: TOpCG; size : tdef;const loc: tlocation; reg: tregister;shuffle : pmmshuffle); override;
+          procedure a_opmm_reg_ref(list: TAsmList; Op: TOpCG; size : tdef;reg: tregister;const ref: treference; shuffle : pmmshuffle); override;
+}
+//        we don't have high level defs yet that translate into all mm cgsizes
+//          procedure a_loadmm_intreg_reg(list: TAsmList; fromsize, tosize : tdef; intreg, mmreg: tregister; shuffle: pmmshuffle); override;
+//          procedure a_loadmm_reg_intreg(list: TAsmList; fromsize, tosize : tdef; mmreg, intreg: tregister; shuffle : pmmshuffle); override;
+
+          { basic arithmetic operations }
+          { note: for operators which require only one argument (not, neg), use }
+          { the op_reg_reg, op_reg_ref or op_reg_loc methods and keep in mind   }
+          { that in this case the *second* operand is used as both source and   }
+          { destination (JM)                                                    }
+          procedure a_op_const_reg(list : TAsmList; Op: TOpCG; size: tdef; a: Aint; reg: TRegister); override;
+          procedure a_op_const_ref(list : TAsmList; Op: TOpCG; size: tdef; a: Aint; const ref: TReference); override;
+          procedure a_op_const_subsetreg(list : TAsmList; Op : TOpCG; size, subsetsize : tdef; a : aint; const sreg: tsubsetregister); override;
+          procedure a_op_const_subsetref(list : TAsmList; Op : TOpCG; size, subsetsize : tdef; a : aint; const sref: tsubsetreference); override;
+          procedure a_op_const_loc(list : TAsmList; Op: TOpCG; size: tdef; a: Aint; const loc: tlocation);override;
+          procedure a_op_reg_reg(list : TAsmList; Op: TOpCG; size: tdef; reg1, reg2: TRegister); override;
+          procedure a_op_reg_ref(list : TAsmList; Op: TOpCG; size: tdef; reg: TRegister; const ref: TReference); override;
+          procedure a_op_ref_reg(list : TAsmList; Op: TOpCG; size: tdef; const ref: TReference; reg: TRegister); override;
+          procedure a_op_reg_subsetreg(list: TAsmList; Op: TOpCG; opsize, destsize, destsubsetsize: tdef; reg: TRegister; const sreg: tsubsetregister); override;
+          procedure a_op_reg_subsetref(list: TAsmList; Op: TOpCG; opsize, destsize, destsubsetsize: tdef; reg: TRegister; const sref: tsubsetreference); override;
+          procedure a_op_reg_loc(list : TAsmList; Op: TOpCG; size: tdef; reg: tregister; const loc: tlocation);override;
+          procedure a_op_ref_loc(list : TAsmList; Op: TOpCG; size: tdef; const ref: TReference; const loc: tlocation);override;
+
+          { trinary operations for processors that support them, 'emulated' }
+          { on others. None with "ref" arguments since I don't think there  }
+          { are any processors that support it (JM)                         }
+          procedure a_op_const_reg_reg(list: TAsmList; op: TOpCg; size: tdef; a: aint; src, dst: tregister); override;
+          procedure a_op_reg_reg_reg(list: TAsmList; op: TOpCg; size: tdef; src1, src2, dst: tregister); override;
+          procedure a_op_const_reg_reg_checkoverflow(list: TAsmList; op: TOpCg; size: tdef; a: aint; src, dst: tregister;setflags : boolean;var ovloc : tlocation); override;
+          procedure a_op_reg_reg_reg_checkoverflow(list: TAsmList; op: TOpCg; size: tdef; src1, src2, dst: tregister;setflags : boolean;var ovloc : tlocation); override;
+
+          {  comparison operations }
+          procedure a_cmp_const_reg_label(list : TAsmList;size : tdef;cmp_op : topcmp;a : aint;reg : tregister;
+            l : tasmlabel);override;
+          procedure a_cmp_const_ref_label(list : TAsmList;size : tdef;cmp_op : topcmp;a : aint;const ref : treference;
+            l : tasmlabel); override;
+          procedure a_cmp_const_loc_label(list: TAsmList; size: tdef;cmp_op: topcmp; a: aint; const loc: tlocation;
+            l : tasmlabel);override;
+          procedure a_cmp_reg_reg_label(list : TAsmList;size : tdef;cmp_op : topcmp;reg1,reg2 : tregister;l : tasmlabel); override;
+          procedure a_cmp_ref_reg_label(list : TAsmList;size : tdef;cmp_op : topcmp; const ref: treference; reg : tregister; l : tasmlabel); override;
+          procedure a_cmp_reg_ref_label(list : TAsmList;size : tdef;cmp_op : topcmp;reg : tregister; const ref: treference; l : tasmlabel); override;
+          procedure a_cmp_subsetreg_reg_label(list: TAsmList; fromsize, fromsubsetsize, cmpsize: tdef; cmp_op: topcmp; const sreg: tsubsetregister; reg: tregister; l: tasmlabel); override;
+          procedure a_cmp_subsetref_reg_label(list: TAsmList; fromsize, fromsubsetsize, cmpsize: tdef; cmp_op: topcmp; const sref: tsubsetreference; reg: tregister; l: tasmlabel); override;
+
+          procedure a_cmp_loc_reg_label(list : TAsmList;size : tdef;cmp_op : topcmp; const loc: tlocation; reg : tregister; l : tasmlabel);override;
+          procedure a_cmp_reg_loc_label(list : TAsmList;size : tdef;cmp_op : topcmp; reg: tregister; const loc: tlocation; l : tasmlabel);override;
+          procedure a_cmp_ref_loc_label(list: TAsmList; size: tdef;cmp_op: topcmp; const ref: treference; const loc: tlocation; l : tasmlabel);override;
+
+          procedure a_jmp_always(list : TAsmList;l: tasmlabel); override;
+{$ifdef cpuflags}
+          procedure a_jmp_flags(list : TAsmList;const f : TResFlags;l: tasmlabel); override;
+
+          {# Depending on the value to check in the flags, either sets the register reg to one (if the flag is set)
+             or zero (if the flag is cleared). The size parameter indicates the destination size register.
+          }
+          procedure g_flags2reg(list: TAsmList; size: tdef; const f: tresflags; reg: TRegister); override;
+          procedure g_flags2ref(list: TAsmList; size: tdef; const f: tresflags; const ref:TReference); override;
+{$endif cpuflags}
+
+//          procedure g_maybe_testself(list : TAsmList;reg:tregister);
+//          procedure g_maybe_testvmt(list : TAsmList;reg:tregister;objdef:tobjectdef);
+          {# This should emit the opcode to copy len bytes from the source
+             to destination.
+
+             It must be overridden for each new target processor.
+
+             @param(source Source reference of copy)
+             @param(dest Destination reference of copy)
+
+          }
+          procedure g_concatcopy(list : TAsmList;size: tdef; const source,dest : treference);override;
+          {# This should emit the opcode to copy len bytes from the an unaligned source
+             to destination.
+
+             It must be overridden for each new target processor.
+
+             @param(source Source reference of copy)
+             @param(dest Destination reference of copy)
+
+          }
+          procedure g_concatcopy_unaligned(list : TAsmList;size: tdef; const source,dest : treference);override;
+          {# This should emit the opcode to a shortrstring from the source
+             to destination.
+
+             @param(source Source reference of copy)
+             @param(dest Destination reference of copy)
+
+          }
+          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_array_rtti_helper(list: TAsmList; t: tdef; const ref: treference; const highloc: tlocation;
+            const name: string);override;
+          procedure g_initialize(list : TAsmList;t : tdef;const ref : treference);override;
+          procedure g_finalize(list : TAsmList;t : tdef;const ref : treference);override;
+
+          {# Generates range checking code. It is to note
+             that this routine does not need to be overridden,
+             as it takes care of everything.
+
+             @param(p Node which contains the value to check)
+             @param(todef Type definition of node to range check)
+          }
+          procedure g_rangecheck(list: TAsmList; const l:tlocation; fromdef,todef: tdef); override;
+
+          {# Generates overflow checking code for a node }
+          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;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
+             behavior does nothing, should be overridden as required.
+          }
+          procedure g_profilecode(list : TAsmList);override;
+          {# Emits instruction for allocating @var(size) bytes at the stackpointer
+
+             @param(size Number of bytes to allocate)
+          }
+          procedure g_stackpointer_alloc(list : TAsmList;size : longint);override;
+          {# Emits instruction for allocating the locals in entry
+             code of a routine. This is one of the first
+             routine called in @var(genentrycode).
+
+             @param(localsize Number of bytes to allocate as locals)
+          }
+          procedure g_proc_entry(list : TAsmList;localsize : longint;nostackframe:boolean);override;
+          {# Emits instructions for returning from a subroutine.
+             Should also restore the framepointer and stack.
+
+             @param(parasize  Number of bytes of parameters to deallocate from stack)
+          }
+          procedure g_proc_exit(list : TAsmList;parasize:longint;nostackframe:boolean);override;
+
+          procedure g_intf_wrapper(list: TAsmList; procdef: tprocdef; const labelname: string; ioffset: longint);override;
+          procedure g_adjust_self_value(list:TAsmList;procdef: tprocdef;ioffset: aint);override;
+
+          function g_indirect_sym_load(list:TAsmList;const symname: string; const flags: tindsymflags): tregister;override;
+          { generate a stub which only purpose is to pass control the given external method,
+          setting up any additional environment before doing so (if required).
+
+          The default implementation issues a jump instruction to the external name. }
+//          procedure g_external_wrapper(list : TAsmList; procdef: tprocdef; const externalname: string); override;
+
+          { Generate code to exit an unwind-protected region. The default implementation
+            produces a simple jump to destination label. }
+          procedure g_local_unwind(list: TAsmList; l: TAsmLabel);override;
+
+          procedure location_force_reg(list:TAsmList;var l:tlocation;src_size,dst_size:tdef;maybeconst:boolean);override;
+          procedure location_force_fpureg(list:TAsmList;var l: tlocation;size: tdef;maybeconst:boolean);override;
+          procedure location_force_mem(list:TAsmList;var l:tlocation;size:tdef);override;
+//          procedure location_force_mmregscalar(list:TAsmList;var l: tlocation;size:tdef;maybeconst:boolean);override;
+//          procedure location_force_mmreg(list:TAsmList;var l: tlocation;size:tdef;maybeconst:boolean);override;
+
+          procedure maketojumpbool(list:TAsmList; p : tnode);override;
+
+          procedure gen_load_para_value(list:TAsmList);override;
+
+          procedure gen_load_loc_cgpara(list: TAsmList; vardef: tdef; const l: tlocation; const cgpara: tcgpara); override;
+          procedure gen_load_cgpara_loc(list: TAsmList; vardef: tdef; const para: TCGPara; var destloc: tlocation; reusepara: boolean); override;
+
+         protected
+          procedure initialize_regvars(p: TObject; arg: pointer); override;
+       end;
+
+
+implementation
+
+    uses
+       globals,options,systems,
+       verbose,defutil,paramgr,symsym,
+       cgobj,tgobj,cutils,procinfo,
+       ncgutil;
+
+  { thlcg2ll }
+
+  constructor thlcg2ll.create;
+    begin
+    end;
+
+  procedure thlcg2ll.init_register_allocators;
+    begin
+      cg.init_register_allocators;
+    end;
+
+  procedure thlcg2ll.done_register_allocators;
+    begin
+      cg.done_register_allocators;
+    end;
+
+  procedure thlcg2ll.set_regalloc_live_range_direction(dir: TRADirection);
+    begin
+      cg.set_regalloc_live_range_direction(dir);
+    end;
+
+  function thlcg2ll.getintregister(list: TAsmList; size: tdef): Tregister;
+    begin
+      result:=cg.getintregister(list,def_cgsize(size));
+    end;
+
+
+  function thlcg2ll.getaddressregister(list: TAsmList; size: tdef): Tregister;
+    begin
+      result:=cg.getaddressregister(list);
+    end;
+
+  function thlcg2ll.getfpuregister(list: TAsmList; size: tdef): Tregister;
+    begin
+      result:=cg.getfpuregister(list,def_cgsize(size));
+    end;
+(*
+  function thlcg2ll.getmmregister(list: TAsmList; size: tdef): Tregister;
+    begin
+      result:=cg.getmmregister(list,def_cgsize(size));
+    end;
+*)
+  function thlcg2ll.getflagregister(list: TAsmList; size: tdef): Tregister;
+    begin
+      result:=cg.getflagregister(list,def_cgsize(size));
+    end;
+
+  function thlcg2ll.uses_registers(rt: Tregistertype): boolean;
+    begin
+       result:=cg.uses_registers(rt);
+    end;
+
+  procedure thlcg2ll.do_register_allocation(list: TAsmList; headertai: tai);
+    begin
+      cg.do_register_allocation(list,headertai);
+    end;
+
+  procedure thlcg2ll.translate_register(var reg: tregister);
+    begin
+      cg.translate_register(reg);
+    end;
+
+  procedure thlcg2ll.a_label(list: TAsmList; l: tasmlabel); inline;
+    begin
+      cg.a_label(list,l);
+    end;
+
+  procedure thlcg2ll.a_reg_alloc(list: TAsmList; r: tregister);
+    begin
+      cg.a_reg_alloc(list,r);
+    end;
+
+  procedure thlcg2ll.a_reg_dealloc(list: TAsmList; r: tregister);
+    begin
+      cg.a_reg_dealloc(list,r);
+    end;
+
+  procedure thlcg2ll.a_reg_sync(list: TAsmList; r: tregister);
+    begin
+      cg.a_reg_sync(list,r);
+    end;
+
+  procedure thlcg2ll.a_load_reg_cgpara(list: TAsmList; size: tdef; r: tregister; const cgpara: TCGPara);
+    begin
+      cg.a_load_reg_cgpara(list,def_cgsize(size),r,cgpara);
+    end;
+
+  procedure thlcg2ll.a_load_const_cgpara(list: TAsmList; tosize: tdef; a: aint; const cgpara: TCGPara);
+    begin
+      cg.a_load_const_cgpara(list,def_cgsize(tosize),a,cgpara);
+    end;
+
+  procedure thlcg2ll.a_load_ref_cgpara(list: TAsmList; size: tdef; const r: treference; const cgpara: TCGPara);
+    begin
+      cg.a_load_ref_cgpara(list,def_cgsize(size),r,cgpara);
+    end;
+
+  procedure thlcg2ll.a_load_loc_cgpara(list: TAsmList; size: tdef; const l: tlocation; const cgpara: TCGPara);
+    begin
+      cg.a_load_loc_cgpara(list,l,cgpara);
+    end;
+
+  procedure thlcg2ll.a_loadaddr_ref_cgpara(list: TAsmList; fromsize, tosize: tdef; const r: treference; const cgpara: TCGPara);
+    begin
+      cg.a_loadaddr_ref_cgpara(list,r,cgpara);
+    end;
+
+  procedure thlcg2ll.a_call_name(list: TAsmList; pd: tprocdef; const s: TSymStr; weak: boolean);
+    begin
+      cg.a_call_name(list,s,weak);
+    end;
+
+  procedure thlcg2ll.a_call_reg(list: TAsmList; pd: tabstractprocdef; reg: tregister);
+    begin
+      cg.a_call_reg(list,reg);
+    end;
+
+  procedure thlcg2ll.a_call_ref(list: TAsmList; pd: tabstractprocdef; ref: treference);
+    begin
+      cg.a_call_ref(list,ref);
+    end;
+
+  procedure thlcg2ll.a_call_name_static(list: TAsmList; pd: tprocdef; const s: TSymStr);
+    begin
+      cg.a_call_name_static(list,s);
+    end;
+
+  procedure thlcg2ll.a_load_const_reg(list: TAsmList; tosize: tdef; a: aint; register: tregister);
+    begin
+      cg.a_load_const_reg(list,def_cgsize(tosize),a,register);
+    end;
+
+  procedure thlcg2ll.a_load_const_ref(list: TAsmList; tosize: tdef; a: aint; const ref: treference);
+    begin
+       cg.a_load_const_ref(list,def_cgsize(tosize),a,ref);
+    end;
+
+  procedure thlcg2ll.a_load_const_loc(list: TAsmList; tosize: tdef; a: aint; const loc: tlocation);
+    begin
+      cg.a_load_const_loc(list,a,loc);
+    end;
+
+  procedure thlcg2ll.a_load_reg_ref(list: TAsmList; fromsize, tosize: tdef; register: tregister; const ref: treference);
+    begin
+      cg.a_load_reg_ref(list,def_cgsize(fromsize),def_cgsize(tosize),register,ref);
+    end;
+
+  procedure thlcg2ll.a_load_reg_ref_unaligned(list: TAsmList; fromsize, tosize: tdef; register: tregister; const ref: treference);
+    begin
+      cg.a_load_reg_ref_unaligned(list,def_cgsize(fromsize),def_cgsize(tosize),register,ref);
+    end;
+
+  procedure thlcg2ll.a_load_reg_reg(list: TAsmList; fromsize, tosize: tdef; reg1, reg2: tregister);
+    begin
+      cg.a_load_reg_reg(list,def_cgsize(fromsize),def_cgsize(tosize),reg1,reg2);
+    end;
+
+  procedure thlcg2ll.a_load_reg_loc(list: TAsmList; fromsize, tosize: tdef; reg: tregister; const loc: tlocation);
+    begin
+      cg.a_load_reg_loc(list,def_cgsize(fromsize),reg,loc);
+    end;
+
+  procedure thlcg2ll.a_load_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; register: tregister);
+    begin
+      cg.a_load_ref_reg(list,def_cgsize(fromsize),def_cgsize(tosize),ref,register);
+    end;
+
+  procedure thlcg2ll.a_load_ref_reg_unaligned(list: TAsmList; fromsize, tosize: tdef; const ref: treference; register: tregister);
+    begin
+      cg.a_load_ref_reg_unaligned(list,def_cgsize(fromsize),def_cgsize(tosize),ref,register);
+    end;
+
+  procedure thlcg2ll.a_load_ref_ref(list: TAsmList; fromsize, tosize: tdef; const sref: treference; const dref: treference);
+    begin
+      cg.a_load_ref_ref(list,def_cgsize(fromsize),def_cgsize(tosize),sref,dref);
+    end;
+
+  procedure thlcg2ll.a_load_loc_reg(list: TAsmList; fromsize, tosize: tdef; const loc: tlocation; reg: tregister);
+    begin
+      cg.a_load_loc_reg(list,def_cgsize(tosize),loc,reg);
+    end;
+
+  procedure thlcg2ll.a_load_loc_ref(list: TAsmList; fromsize, tosize: tdef; const loc: tlocation; const ref: treference);
+    begin
+      cg.a_load_loc_ref(list,def_cgsize(tosize),loc,ref);
+    end;
+
+  procedure thlcg2ll.a_load_loc_subsetreg(list: TAsmList; fromsize, tosize, tosubsetsize: tdef; const loc: tlocation; const sreg: tsubsetregister);
+    begin
+      cg.a_load_loc_subsetreg(list,def_cgsize(tosubsetsize),loc,sreg);
+    end;
+
+  procedure thlcg2ll.a_load_loc_subsetref(list: TAsmList; fromsize, tosize, tosubsetsize: tdef; const loc: tlocation; const sref: tsubsetreference);
+    begin
+      cg.a_load_loc_subsetref(list,def_cgsize(tosubsetsize),loc,sref);
+    end;
+
+procedure thlcg2ll.a_loadaddr_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; r: tregister);
+    begin
+      cg.a_loadaddr_ref_reg(list,ref,r);
+    end;
+
+  procedure thlcg2ll.a_load_subsetreg_reg(list: TAsmList; fromsize, fromsubsetsize, tosize: tdef; const sreg: tsubsetregister; destreg: tregister);
+    begin
+      cg.a_load_subsetreg_reg(list,def_cgsize(fromsubsetsize),def_cgsize(tosize),sreg,destreg);
+    end;
+
+  procedure thlcg2ll.a_load_reg_subsetreg(list: TAsmList; fromsize, tosize, tosubsetsize: tdef; fromreg: tregister; const sreg: tsubsetregister);
+    begin
+      cg.a_load_reg_subsetreg(list,def_cgsize(fromsize),def_cgsize(tosubsetsize),fromreg,sreg);
+    end;
+
+  procedure thlcg2ll.a_load_subsetreg_subsetreg(list: TAsmlist; fromsize, fromsubsetsize, tosize, tosubsetsize: tdef; const fromsreg, tosreg: tsubsetregister);
+    begin
+      cg.a_load_subsetreg_subsetreg(list,def_cgsize(fromsubsetsize),def_cgsize(tosubsetsize),fromsreg,tosreg);
+    end;
+
+  procedure thlcg2ll.a_load_subsetreg_ref(list: TAsmList; fromsize, fromsubsetsize, tosize: tdef; const sreg: tsubsetregister; const destref: treference);
+    begin
+      cg.a_load_subsetreg_ref(list,def_cgsize(fromsubsetsize),def_cgsize(tosize),sreg,destref);
+    end;
+
+  procedure thlcg2ll.a_load_ref_subsetreg(list: TAsmList; fromsize, tosize, tosubsetsize: tdef; const fromref: treference; const sreg: tsubsetregister);
+    begin
+      cg.a_load_ref_subsetreg(list,def_cgsize(fromsize),def_cgsize(tosubsetsize),fromref,sreg);
+    end;
+
+  procedure thlcg2ll.a_load_const_subsetreg(list: TAsmlist; tosize, tosubsetsize: tdef; a: aint; const sreg: tsubsetregister);
+    begin
+      cg.a_load_const_subsetreg(list,def_cgsize(tosubsetsize),a,sreg);
+    end;
+
+  procedure thlcg2ll.a_load_subsetreg_loc(list: TAsmlist; fromsize, fromsubsetsize, tosize: tdef; const sreg: tsubsetregister; const loc: tlocation);
+    begin
+      cg.a_load_subsetreg_loc(list,def_cgsize(fromsubsetsize),sreg,loc);
+    end;
+
+  procedure thlcg2ll.a_load_subsetref_reg(list: TAsmList; fromsize, fromsubsetsize, tosize: tdef; const sref: tsubsetreference; destreg: tregister);
+    begin
+      cg.a_load_subsetref_reg(list,def_cgsize(fromsubsetsize),def_cgsize(tosize),sref,destreg);
+    end;
+
+  procedure thlcg2ll.a_load_reg_subsetref(list: TAsmList; fromsize, tosubsetsize, tosize: tdef; fromreg: tregister; const sref: tsubsetreference);
+    begin
+      cg.a_load_reg_subsetref(list,def_cgsize(fromsize),def_cgsize(tosubsetsize),fromreg,sref);
+    end;
+
+  procedure thlcg2ll.a_load_subsetref_subsetref(list: TAsmlist; fromsize, fromsubsetsize, tosize, tosubsetsize: tdef; const fromsref, tosref: tsubsetreference);
+    begin
+       cg.a_load_subsetref_subsetref(list,def_cgsize(fromsubsetsize),def_cgsize(tosubsetsize),fromsref,tosref);
+    end;
+
+  procedure thlcg2ll.a_load_subsetref_ref(list: TAsmList; fromsize, fromsubsetsize, tosize: tdef; const sref: tsubsetreference; const destref: treference);
+    begin
+      cg.a_load_subsetref_ref(list,def_cgsize(fromsubsetsize),def_cgsize(tosize),sref,destref);
+    end;
+
+  procedure thlcg2ll.a_load_ref_subsetref(list: TAsmList; fromsize, tosize, tosubsetsize: tdef; const fromref: treference; const sref: tsubsetreference);
+    begin
+      cg.a_load_ref_subsetref(list,def_cgsize(fromsize),def_cgsize(tosubsetsize),fromref,sref);
+    end;
+
+  procedure thlcg2ll.a_load_const_subsetref(list: TAsmlist; tosize, tosubsetsize: tdef; a: aint; const sref: tsubsetreference);
+    begin
+      cg.a_load_const_subsetref(list,def_cgsize(tosubsetsize),a,sref);
+    end;
+
+  procedure thlcg2ll.a_load_subsetref_loc(list: TAsmlist; fromsize, fromsubsetsize, tosize: tdef; const sref: tsubsetreference; const loc: tlocation);
+    begin
+      cg.a_load_subsetref_loc(list,def_cgsize(fromsubsetsize),sref,loc);
+    end;
+
+  procedure thlcg2ll.a_load_subsetref_subsetreg(list: TAsmlist; fromsize, fromsubsetsize, tosize, tosubsetsize: tdef; const fromsref: tsubsetreference; const tosreg: tsubsetregister);
+    begin
+      cg.a_load_subsetref_subsetreg(list,def_cgsize(fromsubsetsize),def_cgsize(tosubsetsize),fromsref,tosreg);
+    end;
+
+  procedure thlcg2ll.a_load_subsetreg_subsetref(list: TAsmlist; fromsize, fromsubsetsize, tosize, tosubsetsize: tdef; const fromsreg: tsubsetregister; const tosref: tsubsetreference);
+    begin
+      cg.a_load_subsetreg_subsetref(list,def_cgsize(fromsubsetsize),def_cgsize(tosubsetsize),fromsreg,tosref);
+    end;
+
+  procedure thlcg2ll.a_bit_test_reg_reg_reg(list: TAsmList; bitnumbersize, valuesize, destsize: tdef; bitnumber, value, destreg: tregister);
+    begin
+      cg.a_bit_test_reg_reg_reg(list,def_cgsize(bitnumbersize),def_cgsize(valuesize),def_cgsize(destsize),bitnumber,value,destreg);
+    end;
+
+  procedure thlcg2ll.a_bit_test_const_ref_reg(list: TAsmList; fromsize, destsize: tdef; bitnumber: aint; const ref: treference; destreg: tregister);
+    begin
+      cg.a_bit_test_const_ref_reg(list,def_cgsize(destsize),bitnumber,ref,destreg);
+    end;
+
+  procedure thlcg2ll.a_bit_test_const_reg_reg(list: TAsmList; setregsize, destsize: tdef; bitnumber: aint; setreg, destreg: tregister);
+    begin
+      cg.a_bit_test_const_reg_reg(list,def_cgsize(setregsize),def_cgsize(destsize),bitnumber,setreg,destreg);
+    end;
+
+  procedure thlcg2ll.a_bit_test_const_subsetreg_reg(list: TAsmList; fromsize, fromsubsetsize, destsize: tdef; bitnumber: aint; const setreg: tsubsetregister; destreg: tregister);
+    begin
+      cg.a_bit_test_const_subsetreg_reg(list,def_cgsize(fromsubsetsize),def_cgsize(destsize),bitnumber,setreg,destreg);
+    end;
+
+  procedure thlcg2ll.a_bit_test_reg_ref_reg(list: TAsmList; bitnumbersize, refsize, destsize: tdef; bitnumber: tregister; const ref: treference; destreg: tregister);
+    begin
+      cg.a_bit_test_reg_ref_reg(list,def_cgsize(bitnumbersize),def_cgsize(destsize),bitnumber,ref,destreg);
+    end;
+
+  procedure thlcg2ll.a_bit_test_reg_loc_reg(list: TAsmList; bitnumbersize, locsize, destsize: tdef; bitnumber: tregister; const loc: tlocation; destreg: tregister);
+    begin
+      cg.a_bit_test_reg_loc_reg(list,def_cgsize(bitnumbersize),def_cgsize(destsize),bitnumber,loc,destreg);
+    end;
+
+  procedure thlcg2ll.a_bit_test_const_loc_reg(list: TAsmList; locsize, destsize: tdef; bitnumber: aint; const loc: tlocation; destreg: tregister);
+    begin
+      cg.a_bit_test_const_loc_reg(list,def_cgsize(destsize),bitnumber,loc,destreg);
+    end;
+
+  procedure thlcg2ll.a_bit_set_reg_reg(list: TAsmList; doset: boolean; bitnumbersize, destsize: tdef; bitnumber, dest: tregister);
+    begin
+      cg.a_bit_set_reg_reg(list,doset,def_cgsize(bitnumbersize),def_cgsize(destsize),bitnumber,dest);
+    end;
+
+  procedure thlcg2ll.a_bit_set_const_ref(list: TAsmList; doset: boolean; destsize: tdef; bitnumber: aint; const ref: treference);
+    begin
+      cg.a_bit_set_const_ref(list,doset,def_cgsize(destsize),bitnumber,ref);
+    end;
+
+  procedure thlcg2ll.a_bit_set_const_reg(list: TAsmList; doset: boolean; destsize: tdef; bitnumber: aint; destreg: tregister);
+    begin
+      cg.a_bit_set_const_reg(list,doset,def_cgsize(destsize),bitnumber,destreg);
+    end;
+
+  procedure thlcg2ll.a_bit_set_const_subsetreg(list: TAsmList; doset: boolean; destsize, destsubsetsize: tdef; bitnumber: aint; const destreg: tsubsetregister);
+    begin
+      cg.a_bit_set_const_subsetreg(list,doset,def_cgsize(destsubsetsize),bitnumber,destreg);
+    end;
+
+  procedure thlcg2ll.a_bit_set_reg_ref(list: TAsmList; doset: boolean; fromsize, tosize: tdef; bitnumber: tregister; const ref: treference);
+    begin
+      cg.a_bit_set_reg_ref(list,doset,def_cgsize(fromsize),bitnumber,ref);
+    end;
+
+  procedure thlcg2ll.a_bit_set_reg_loc(list: TAsmList; doset: boolean; fromsize, tosize: tdef; bitnumber: tregister; const loc: tlocation);
+    begin
+      cg.a_bit_set_reg_loc(list,doset,def_cgsize(fromsize),bitnumber,loc);
+    end;
+
+  procedure thlcg2ll.a_bit_set_const_loc(list: TAsmList; doset: boolean; tosize: tdef; bitnumber: aint; const loc: tlocation);
+    begin
+      cg.a_bit_set_const_loc(list,doset,bitnumber,loc);
+    end;
+
+  procedure thlcg2ll.a_bit_scan_reg_reg(list: TAsmList; reverse: boolean; size: tdef; src, dst: tregister);
+    begin
+      cg.a_bit_scan_reg_reg(list,reverse,def_cgsize(size),src,dst);
+    end;
+
+  procedure thlcg2ll.a_loadfpu_reg_reg(list: TAsmList; fromsize, tosize: tdef; reg1, reg2: tregister);
+    begin
+      cg.a_loadfpu_reg_reg(list,def_cgsize(fromsize),def_cgsize(tosize),reg1,reg2);
+    end;
+
+  procedure thlcg2ll.a_loadfpu_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; reg: tregister);
+    begin
+      cg.a_loadfpu_ref_reg(list,def_cgsize(fromsize),def_cgsize(tosize),ref,reg);
+    end;
+
+  procedure thlcg2ll.a_loadfpu_reg_ref(list: TAsmList; fromsize, tosize: tdef; reg: tregister; const ref: treference);
+    begin
+      cg.a_loadfpu_reg_ref(list,def_cgsize(fromsize),def_cgsize(tosize),reg,ref);
+    end;
+
+  procedure thlcg2ll.a_loadfpu_ref_ref(list: TAsmList; fromsize, tosize: tdef; const ref1, ref2: treference);
+    begin
+      cg.a_loadfpu_ref_ref(list,def_cgsize(fromsize),def_cgsize(tosize),ref1,ref2);
+    end;
+
+  procedure thlcg2ll.a_loadfpu_loc_reg(list: TAsmList; fromsize, tosize: tdef; const loc: tlocation; const reg: tregister);
+    begin
+{$ifdef extdebug}
+      if def_cgsize(fromsize)<>loc.size then
+        internalerror(2010112102);
+{$endif}
+      cg.a_loadfpu_loc_reg(list,def_cgsize(tosize),loc,reg);
+    end;
+
+  procedure thlcg2ll.a_loadfpu_reg_loc(list: TAsmList; fromsize, tosize: tdef; const reg: tregister; const loc: tlocation);
+    var
+      usesize: tcgsize;
+    begin
+{$ifdef extdebug}
+      if def_cgsize(tosize)<>loc.size then
+        internalerror(2010112101);
+{$endif}
+      { on some platforms, certain records are passed/returned in floating point
+        registers -> def_cgsize() won't give us the result we need -> translate
+        to corresponding fpu size }
+      usesize:=def_cgsize(fromsize);
+      if not(usesize in [OS_F32..OS_F128]) then
+        usesize:=int_float_cgsize(tcgsize2size[usesize]);
+      cg.a_loadfpu_reg_loc(list,usesize,reg,loc);
+    end;
+
+  procedure thlcg2ll.a_loadfpu_reg_cgpara(list: TAsmList; fromsize: tdef; const r: tregister; const cgpara: TCGPara);
+    begin
+      cg.a_loadfpu_reg_cgpara(list,def_cgsize(fromsize),r,cgpara);
+    end;
+
+  procedure thlcg2ll.a_loadfpu_ref_cgpara(list: TAsmList; fromsize: tdef; const ref: treference; const cgpara: TCGPara);
+    begin
+      cg.a_loadfpu_ref_cgpara(list,def_cgsize(fromsize),ref,cgpara);
+    end;
+
+(*
+  procedure thlcg2ll.a_loadmm_reg_reg(list: TAsmList; fromsize, tosize: tdef; reg1, reg2: tregister; shuffle: pmmshuffle);
+    begin
+      cg.a_loadmm_reg_reg(list,def_cgsize(fromsize),def_cgsize(tosize),reg1,reg2,shuffle);
+    end;
+
+  procedure thlcg2ll.a_loadmm_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; reg: tregister; shuffle: pmmshuffle);
+    begin
+      cg.a_loadmm_ref_reg(list,def_cgsize(fromsize),def_cgsize(tosize),ref,reg,shuffle);
+    end;
+
+  procedure thlcg2ll.a_loadmm_reg_ref(list: TAsmList; fromsize, tosize: tdef; reg: tregister; const ref: treference; shuffle: pmmshuffle);
+    begin
+      cg.a_loadmm_reg_ref(list,def_cgsize(fromsize),def_cgsize(tosize),reg,ref,shuffle);
+    end;
+
+  procedure thlcg2ll.a_loadmm_loc_reg(list: TAsmList; fromsize, tosize: tdef; const loc: tlocation; const reg: tregister; shuffle: pmmshuffle);
+    begin
+{$ifdef extdebug}
+      if def_cgsize(fromsize)<>loc.size then
+        internalerror(2010112103);
+{$endif}
+      cg.a_loadmm_loc_reg(list,def_cgsize(tosize),loc,reg,shuffle);
+    end;
+
+  procedure thlcg2ll.a_loadmm_reg_loc(list: TAsmList; fromsize, tosize: tdef; const reg: tregister; const loc: tlocation; shuffle: pmmshuffle);
+    begin
+{$ifdef extdebug}
+      if def_cgsize(tosize)<>loc.size then
+        internalerror(2010112104);
+{$endif}
+      cg.a_loadmm_reg_loc(list,def_cgsize(fromsize),reg,loc,shuffle);
+    end;
+
+  procedure thlcg2ll.a_loadmm_reg_cgpara(list: TAsmList; fromsize: tdef; reg: tregister; const cgpara: TCGPara; shuffle: pmmshuffle);
+    begin
+      cg.a_loadmm_reg_cgpara(list,def_cgsize(fromsize),reg,cgpara,shuffle);
+    end;
+
+  procedure thlcg2ll.a_loadmm_ref_cgpara(list: TAsmList; fromsize: tdef; const ref: treference; const cgpara: TCGPara; shuffle: pmmshuffle);
+    begin
+      cg.a_loadmm_ref_cgpara(list,def_cgsize(fromsize),ref,cgpara,shuffle);
+    end;
+
+  procedure thlcg2ll.a_loadmm_loc_cgpara(list: TAsmList; fromsize: tdef; const loc: tlocation; const cgpara: TCGPara; shuffle: pmmshuffle);
+    begin
+{$ifdef extdebug}
+      if def_cgsize(fromsize)<>loc.size then
+        internalerror(2010112105);
+{$endif}
+      cg.a_loadmm_loc_cgpara(list,loc,cgpara,shuffle);
+    end;
+
+  procedure thlcg2ll.a_opmm_loc_reg(list: TAsmList; Op: TOpCG; size: tdef; const loc: tlocation; reg: tregister; shuffle: pmmshuffle);
+    begin
+      cg.a_opmm_loc_reg(list,op,def_cgsize(size),loc,reg,shuffle);
+    end;
+*)
+
+(*
+  procedure thlcg2ll.a_loadmm_intreg_reg(list: TAsmList; fromsize, tosize: tdef; intreg, mmreg: tregister; shuffle: pmmshuffle);
+    begin
+      cg.a_loadmm_intreg_reg(list,def_cgsize(fromsize),def_cgsize(tosize),intreg,mmreg,shuffle);
+    end;
+
+  procedure thlcg2ll.a_loadmm_reg_intreg(list: TAsmList; fromsize, tosize: tdef; mmreg, intreg: tregister; shuffle: pmmshuffle);
+    begin
+      cg.a_loadmm_reg_intreg(list,def_cgsize(fromsize),def_cgsize(tosize),mmreg,intreg,shuffle);
+    end;
+*)
+  procedure thlcg2ll.a_op_const_reg(list: TAsmList; Op: TOpCG; size: tdef; a: Aint; reg: TRegister);
+    begin
+      cg.a_op_const_reg(list,op,def_cgsize(size),a,reg);
+    end;
+
+  procedure thlcg2ll.a_op_const_ref(list: TAsmList; Op: TOpCG; size: tdef; a: Aint; const ref: TReference);
+    begin
+      cg.a_op_const_ref(list,op,def_cgsize(size),a,ref);
+    end;
+
+  procedure thlcg2ll.a_op_const_subsetreg(list: TAsmList; Op: TOpCG; size, subsetsize: tdef; a: aint; const sreg: tsubsetregister);
+    begin
+      cg.a_op_const_subsetreg(list,op,def_cgsize(size),def_cgsize(subsetsize),a,sreg);
+    end;
+
+  procedure thlcg2ll.a_op_const_subsetref(list: TAsmList; Op: TOpCG; size, subsetsize: tdef; a: aint; const sref: tsubsetreference);
+    begin
+      cg.a_op_const_subsetref(list,op,def_cgsize(size),def_cgsize(subsetsize),a,sref);
+    end;
+
+  procedure thlcg2ll.a_op_const_loc(list: TAsmList; Op: TOpCG; size: tdef; a: Aint; const loc: tlocation);
+    begin
+{$ifdef extdebug}
+      if def_cgsize(size)<>loc.size then
+        internalerror(2010112106);
+{$endif}
+      cg.a_op_const_loc(list,op,a,loc);
+    end;
+
+  procedure thlcg2ll.a_op_reg_reg(list: TAsmList; Op: TOpCG; size: tdef; reg1, reg2: TRegister);
+    begin
+      cg.a_op_reg_reg(list,op,def_cgsize(size),reg1,reg2);
+    end;
+
+  procedure thlcg2ll.a_op_reg_ref(list: TAsmList; Op: TOpCG; size: tdef; reg: TRegister; const ref: TReference);
+    begin
+      cg.a_op_reg_ref(list,op,def_cgsize(size),reg,ref);
+    end;
+
+  procedure thlcg2ll.a_op_ref_reg(list: TAsmList; Op: TOpCG; size: tdef; const ref: TReference; reg: TRegister);
+    begin
+      cg.a_op_ref_reg(list,op,def_cgsize(size),ref,reg);
+    end;
+
+  procedure thlcg2ll.a_op_reg_subsetreg(list: TAsmList; Op: TOpCG; opsize, destsize, destsubsetsize: tdef; reg: TRegister; const sreg: tsubsetregister);
+    begin
+      cg.a_op_reg_subsetreg(list,op,def_cgsize(opsize),def_cgsize(destsubsetsize),reg,sreg);
+    end;
+
+  procedure thlcg2ll.a_op_reg_subsetref(list: TAsmList; Op: TOpCG; opsize, destsize, destsubsetsize: tdef; reg: TRegister; const sref: tsubsetreference);
+    begin
+      cg.a_op_reg_subsetref(list,op,def_cgsize(opsize),def_cgsize(destsubsetsize),reg,sref);
+    end;
+
+  procedure thlcg2ll.a_op_reg_loc(list: TAsmList; Op: TOpCG; size: tdef; reg: tregister; const loc: tlocation);
+    begin
+{$ifdef extdebug}
+      if def_cgsize(size)<>loc.size then
+        internalerror(2010112107);
+{$endif}
+      cg.a_op_reg_loc(list,op,reg,loc)
+    end;
+
+  procedure thlcg2ll.a_op_ref_loc(list: TAsmList; Op: TOpCG; size: tdef; const ref: TReference; const loc: tlocation);
+    begin
+{$ifdef extdebug}
+      if def_cgsize(size)<>loc.size then
+        internalerror(2010112101);
+{$endif}
+      cg.a_op_ref_loc(list,op,ref,loc);
+    end;
+
+  procedure thlcg2ll.a_op_const_reg_reg(list: TAsmList; op: TOpCg; size: tdef; a: aint; src, dst: tregister);
+    begin
+      cg.a_op_const_reg_reg(list,op,def_cgsize(size),a,src,dst);
+    end;
+
+  procedure thlcg2ll.a_op_reg_reg_reg(list: TAsmList; op: TOpCg; size: tdef; src1, src2, dst: tregister);
+    begin
+      cg.a_op_reg_reg_reg(list,op,def_cgsize(size),src1,src2,dst);
+    end;
+
+  procedure thlcg2ll.a_op_const_reg_reg_checkoverflow(list: TAsmList; op: TOpCg; size: tdef; a: aint; src, dst: tregister; setflags: boolean; var ovloc: tlocation);
+    begin
+      cg.a_op_const_reg_reg_checkoverflow(list,op,def_cgsize(size),a,src,dst,setflags,ovloc);
+    end;
+
+  procedure thlcg2ll.a_op_reg_reg_reg_checkoverflow(list: TAsmList; op: TOpCg; size: tdef; src1, src2, dst: tregister; setflags: boolean; var ovloc: tlocation);
+    begin
+      cg.a_op_reg_reg_reg_checkoverflow(list,op,def_cgsize(size),src1,src2,dst,setflags,ovloc);
+    end;
+
+  procedure thlcg2ll.a_cmp_const_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; a: aint; reg: tregister; l: tasmlabel);
+    begin
+      cg.a_cmp_const_reg_label(list,def_cgsize(size),cmp_op,a,reg,l);
+    end;
+
+  procedure thlcg2ll.a_cmp_const_ref_label(list: TAsmList; size: tdef; cmp_op: topcmp; a: aint; const ref: treference; l: tasmlabel);
+    begin
+      cg.a_cmp_const_ref_label(list,def_cgsize(size),cmp_op,a,ref,l);
+    end;
+
+  procedure thlcg2ll.a_cmp_const_loc_label(list: TAsmList; size: tdef; cmp_op: topcmp; a: aint; const loc: tlocation; l: tasmlabel);
+    begin
+      cg.a_cmp_const_loc_label(list,def_cgsize(size),cmp_op,a,loc,l);
+    end;
+
+  procedure thlcg2ll.a_cmp_reg_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; reg1, reg2: tregister; l: tasmlabel);
+    begin
+       cg.a_cmp_reg_reg_label(list,def_cgsize(size),cmp_op,reg1,reg2,l);
+    end;
+
+  procedure thlcg2ll.a_cmp_ref_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; const ref: treference; reg: tregister; l: tasmlabel);
+    begin
+      cg.a_cmp_ref_reg_label(list,def_cgsize(size),cmp_op,ref,reg,l);
+    end;
+
+  procedure thlcg2ll.a_cmp_reg_ref_label(list: TAsmList; size: tdef; cmp_op: topcmp; reg: tregister; const ref: treference; l: tasmlabel);
+    begin
+      cg.a_cmp_reg_ref_label(list,def_cgsize(size),cmp_op,reg,ref,l);
+    end;
+
+  procedure thlcg2ll.a_cmp_subsetreg_reg_label(list: TAsmList; fromsize, fromsubsetsize, cmpsize: tdef; cmp_op: topcmp; const sreg: tsubsetregister; reg: tregister; l: tasmlabel);
+    begin
+      cg.a_cmp_subsetreg_reg_label(list,def_cgsize(fromsubsetsize),def_cgsize(cmpsize),cmp_op,sreg,reg,l);
+    end;
+
+  procedure thlcg2ll.a_cmp_subsetref_reg_label(list: TAsmList; fromsize, fromsubsetsize, cmpsize: tdef; cmp_op: topcmp; const sref: tsubsetreference; reg: tregister; l: tasmlabel);
+    begin
+      cg.a_cmp_subsetref_reg_label(list,def_cgsize(fromsubsetsize),def_cgsize(cmpsize),cmp_op,sref,reg,l);
+    end;
+
+  procedure thlcg2ll.a_cmp_loc_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; const loc: tlocation; reg: tregister; l: tasmlabel);
+    begin
+      cg.a_cmp_loc_reg_label(list,def_cgsize(size),cmp_op,loc,reg,l);
+    end;
+
+  procedure thlcg2ll.a_cmp_reg_loc_label(list: TAsmList; size: tdef; cmp_op: topcmp; reg: tregister; const loc: tlocation; l: tasmlabel);
+    begin
+      cg.a_cmp_reg_loc_label(list,def_cgsize(size),cmp_op,reg,loc,l);
+    end;
+
+  procedure thlcg2ll.a_cmp_ref_loc_label(list: TAsmList; size: tdef; cmp_op: topcmp; const ref: treference; const loc: tlocation; l: tasmlabel);
+    begin
+      cg.a_cmp_ref_loc_label(list,def_cgsize(size),cmp_op,ref,loc,l);
+    end;
+
+  procedure thlcg2ll.a_jmp_always(list: TAsmList; l: tasmlabel);
+    begin
+      cg.a_jmp_always(list,l);
+    end;
+
+{$ifdef cpuflags}
+  procedure thlcg2ll.a_jmp_flags(list: TAsmList; const f: TResFlags; l: tasmlabel);
+    begin
+      cg.a_jmp_flags(list,f,l);
+    end;
+
+  procedure thlcg2ll.g_flags2reg(list: TAsmList; size: tdef; const f: tresflags; reg: TRegister);
+    begin
+      cg.g_flags2reg(list,def_cgsize(size),f,reg);
+    end;
+
+  procedure thlcg2ll.g_flags2ref(list: TAsmList; size: tdef; const f: tresflags; const ref: TReference);
+    begin
+      cg.g_flags2ref(list,def_cgsize(size),f,ref);
+    end;
+{$endif cpuflags}
+
+  procedure thlcg2ll.g_concatcopy(list: TAsmList; size: tdef; const source, dest: treference);
+    begin
+      cg.g_concatcopy(list,source,dest,size.size);
+    end;
+
+  procedure thlcg2ll.g_concatcopy_unaligned(list: TAsmList; size: tdef; const source, dest: treference);
+    begin
+      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);
+    end;
+
+  procedure thlcg2ll.g_array_rtti_helper(list: TAsmList; t: tdef; const ref: treference; const highloc: tlocation; const name: string);
+    begin
+      cg.g_array_rtti_helper(list, t, ref, highloc, name);
+    end;
+
+  procedure thlcg2ll.g_initialize(list: TAsmList; t: tdef; const ref: treference);
+    begin
+      cg.g_initialize(list,t,ref);
+    end;
+
+  procedure thlcg2ll.g_finalize(list: TAsmList; t: tdef; const ref: treference);
+    begin
+      cg.g_finalize(list,t,ref);
+    end;
+
+  procedure thlcg2ll.g_rangecheck(list: TAsmList; const l: tlocation; fromdef, todef: tdef);
+    begin
+      cg.g_rangecheck(list,l,fromdef,todef);
+    end;
+
+  procedure thlcg2ll.g_overflowcheck(list: TAsmList; const Loc: tlocation; def: tdef);
+    begin
+      cg.g_overflowcheck(list,loc,def);
+    end;
+
+  procedure thlcg2ll.g_overflowCheck_loc(List: TAsmList; const Loc: TLocation; def: TDef; var ovloc: tlocation);
+    begin
+      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);
+    end;
+
+  procedure thlcg2ll.g_stackpointer_alloc(list: TAsmList; size: longint);
+    begin
+      cg.g_stackpointer_alloc(list,size);
+    end;
+
+  procedure thlcg2ll.g_proc_entry(list: TAsmList; localsize: longint; nostackframe: boolean);
+    begin
+      cg.g_proc_entry(list,localsize,nostackframe);
+    end;
+
+  procedure thlcg2ll.g_proc_exit(list: TAsmList; parasize: longint; nostackframe: boolean);
+    begin
+      cg.g_proc_exit(list,parasize,nostackframe);
+    end;
+
+  procedure thlcg2ll.g_intf_wrapper(list: TAsmList; procdef: tprocdef; const labelname: string; ioffset: longint);
+    begin
+      cg.g_intf_wrapper(list,procdef,labelname,ioffset);
+    end;
+
+  procedure thlcg2ll.g_adjust_self_value(list: TAsmList; procdef: tprocdef; ioffset: aint);
+    begin
+      cg.g_adjust_self_value(list,procdef,ioffset);
+    end;
+
+  function thlcg2ll.g_indirect_sym_load(list: TAsmList; const symname: string; const flags: tindsymflags): tregister;
+    begin
+      result:=cg.g_indirect_sym_load(list,symname,flags);
+    end;
+
+  procedure thlcg2ll.g_local_unwind(list: TAsmList; l: TAsmLabel);
+    begin
+      cg.g_local_unwind(list, l);
+    end;
+
+  procedure thlcg2ll.location_force_reg(list: TAsmList; var l: tlocation; src_size, dst_size: tdef; maybeconst: boolean);
+    begin
+      ncgutil.location_force_reg(list,l,def_cgsize(dst_size),maybeconst);
+    end;
+
+  procedure thlcg2ll.location_force_fpureg(list: TAsmList; var l: tlocation; size: tdef; maybeconst: boolean);
+    begin
+      ncgutil.location_force_fpureg(list,l,maybeconst);
+    end;
+
+  procedure thlcg2ll.location_force_mem(list: TAsmList; var l: tlocation; size: tdef);
+    begin
+      ncgutil.location_force_mem(list,l);
+    end;
+(*
+  procedure thlcg2ll.location_force_mmregscalar(list: TAsmList; var l: tlocation; size: tdef; maybeconst: boolean);
+    begin
+       ncgutil.location_force_mmregscalar(list,l,maybeconst);
+    end;
+
+  procedure thlcg2ll.location_force_mmreg(list: TAsmList; var l: tlocation; size: tdef; maybeconst: boolean);
+    begin
+      ncgutil.location_force_mmreg(list,l,maybeconst);
+    end;
+*)
+  procedure thlcg2ll.maketojumpbool(list: TAsmList; p: tnode);
+    begin
+      { loadregvars parameter is no longer used, should be removed from
+         ncgutil version as well }
+      ncgutil.maketojumpbool(list,p,lr_dont_load_regvars);
+    end;
+
+  procedure thlcg2ll.gen_load_para_value(list: TAsmList);
+    begin
+      ncgutil.gen_load_para_value(list);
+    end;
+
+  procedure thlcg2ll.gen_load_loc_cgpara(list: TAsmList; vardef: tdef; const l: tlocation; const cgpara: tcgpara);
+    begin
+      ncgutil.gen_load_loc_cgpara(list,vardef,l,cgpara);
+    end;
+
+  procedure thlcg2ll.gen_load_cgpara_loc(list: TAsmList; vardef: tdef; const para: TCGPara; var destloc: tlocation; reusepara: boolean);
+    begin
+      ncgutil.gen_load_cgpara_loc(list, vardef, para, destloc, reusepara);
+    end;
+
+  procedure thlcg2ll.initialize_regvars(p: TObject; arg: pointer);
+    begin
+      if (tsym(p).typ=staticvarsym) and
+         { not yet handled via tlhcgobj... }
+         (tstaticvarsym(p).initialloc.loc=LOC_CMMREGISTER) then
+        begin
+          { clear the whole register }
+          cg.a_opmm_reg_reg(TAsmList(arg),OP_XOR,reg_cgsize(tstaticvarsym(p).initialloc.register),
+            tstaticvarsym(p).initialloc.register,
+            tstaticvarsym(p).initialloc.register,
+            nil);
+        end
+      else
+        inherited initialize_regvars(p, arg);
+    end;
+
+end.

compiler/hlcgobj.pas

@@ -0,0 +1,3025 @@
+{
+    Copyright (c) 1998-2010 by Florian Klaempfl and Jonas Maebe
+    Member of the Free Pascal development team
+
+    This unit implements the basic high level code generator object
+
+    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.
+
+ ****************************************************************************
+}
+{# @abstract(Abstract code generator unit)
+   Abstract high level code generator unit. This contains the base class
+   that either lowers most code to the regular code generator, or that
+   has to be implemented/overridden for higher level targets (such as LLVM).
+}
+unit hlcgobj;
+
+{$i fpcdefs.inc}
+
+{ define hlcginline}
+
+  interface
+
+    uses
+       cclasses,globtype,constexp,
+       cpubase,cgbase,cgutils,parabase,
+       aasmbase,aasmtai,aasmdata,aasmcpu,
+       symconst,symtype,symdef,rgobj,
+       node
+       ;
+
+    type
+       {# @abstract(Abstract high level code generator)
+          This class implements an abstract instruction generator. All
+          methods of this class are generic and are mapped to low level code
+          generator methods by default. They have to be overridden for higher
+          level targets
+       }
+
+       { thlcgobj }
+
+       thlcgobj = class
+       public
+          {************************************************}
+          {                 basic routines                 }
+          constructor create;
+
+          {# Initialize the register allocators needed for the codegenerator.}
+          procedure init_register_allocators;virtual;
+          {# Clean up the register allocators needed for the codegenerator.}
+          procedure done_register_allocators;virtual;
+          {# Set whether live_start or live_end should be updated when allocating registers, needed when e.g. generating initcode after the rest of the code. }
+          procedure set_regalloc_live_range_direction(dir: TRADirection);virtual;
+          {# Gets a register suitable to do integer operations on.}
+          function getintregister(list:TAsmList;size:tdef):Tregister;virtual;
+          {# Gets a register suitable to do integer operations on.}
+          function getaddressregister(list:TAsmList;size:tdef):Tregister;virtual;
+          function getfpuregister(list:TAsmList;size:tdef):Tregister;virtual;
+//        we don't have high level defs yet that translate into all mm cgsizes
+//          function getmmregister(list:TAsmList;size:tdef):Tregister;virtual;
+          function getflagregister(list:TAsmList;size:tdef):Tregister;virtual;
+          function getregisterfordef(list: TAsmList;size:tdef):Tregister;virtual;
+          {Does the generic cg need SIMD registers, like getmmxregister? Or should
+           the cpu specific child cg object have such a method?}
+
+          function  uses_registers(rt:Tregistertype):boolean; inline;
+
+          procedure do_register_allocation(list:TAsmList;headertai:tai); inline;
+          procedure translate_register(var reg : tregister); inline;
+
+          {# Returns the kind of register this type should be loaded in (it does not
+             check whether this is actually possible, but if it's loaded in a register
+             by the compiler for any purpose other than parameter passing/function
+             result loading, this is the register type used }
+          function def2regtyp(def: tdef): tregistertype; virtual;
+
+          {# Emit a label to the instruction stream. }
+          procedure a_label(list : TAsmList;l : tasmlabel); inline;
+
+          {# Allocates register r by inserting a pai_realloc record }
+          procedure a_reg_alloc(list : TAsmList;r : tregister); inline;
+          {# Deallocates register r by inserting a pa_regdealloc record}
+          procedure a_reg_dealloc(list : TAsmList;r : tregister); inline;
+          { Synchronize register, make sure it is still valid }
+          procedure a_reg_sync(list : TAsmList;r : tregister); inline;
+
+          {# Pass a parameter, which is located in a register, to a routine.
+
+             This routine should push/send the parameter to the routine, as
+             required by the specific processor ABI and routine modifiers.
+             It must generate register allocation information for the cgpara in
+             case it consists of cpuregisters.
+
+             @param(size size of the operand in the register)
+             @param(r register source of the operand)
+             @param(cgpara where the parameter will be stored)
+          }
+          procedure a_load_reg_cgpara(list : TAsmList;size : tdef;r : tregister;const cgpara : TCGPara);virtual;
+          {# Pass a parameter, which is a constant, to a routine.
+
+             A generic version is provided. This routine should
+             be overridden for optimization purposes if the cpu
+             permits directly sending this type of parameter.
+             It must generate register allocation information for the cgpara in
+             case it consists of cpuregisters.
+
+             @param(size size of the operand in constant)
+             @param(a value of constant to send)
+             @param(cgpara where the parameter will be stored)
+          }
+          procedure a_load_const_cgpara(list : TAsmList;tosize : tdef;a : aint;const cgpara : TCGPara);virtual;
+          {# Pass the value of a parameter, which is located in memory, to a routine.
+
+             A generic version is provided. This routine should
+             be overridden for optimization purposes if the cpu
+             permits directly sending this type of parameter.
+             It must generate register allocation information for the cgpara in
+             case it consists of cpuregisters.
+
+             @param(size size of the operand in constant)
+             @param(r Memory reference of value to send)
+             @param(cgpara where the parameter will be stored)
+          }
+          procedure a_load_ref_cgpara(list : TAsmList;size : tdef;const r : treference;const cgpara : TCGPara);virtual;
+          {# Pass the value of a parameter, which can be located either in a register or memory location,
+             to a routine.
+
+             A generic version is provided.
+
+             @param(l location of the operand to send)
+             @param(nr parameter number (starting from one) of routine (from left to right))
+             @param(cgpara where the parameter will be stored)
+          }
+          procedure a_load_loc_cgpara(list : TAsmList;size : tdef; const l : tlocation;const cgpara : TCGPara);virtual;
+          {# Pass the address of a reference to a routine. This routine
+             will calculate the address of the reference, and pass this
+             calculated address as a parameter.
+             It must generate register allocation information for the cgpara in
+             case it consists of cpuregisters.
+
+             A generic version is provided. This routine should
+             be overridden for optimization purposes if the cpu
+             permits directly sending this type of parameter.
+
+             @param(fromsize type of the reference we are taking the address of)
+             @param(tosize type of the pointer that we get as a result)
+             @param(r reference to get address from)
+          }
+          procedure a_loadaddr_ref_cgpara(list : TAsmList;fromsize, tosize : tdef;const r : treference;const cgpara : TCGPara);virtual;
+
+          { Remarks:
+            * If a method specifies a size you have only to take care
+              of that number of bits, i.e. load_const_reg with OP_8 must
+              only load the lower 8 bit of the specified register
+              the rest of the register can be undefined
+              if  necessary the compiler will call a method
+              to zero or sign extend the register
+            * The a_load_XX_XX with OP_64 needn't to be
+              implemented for 32 bit
+              processors, the code generator takes care of that
+            * the addr size is for work with the natural pointer
+              size
+            * the procedures without fpu/mm are only for integer usage
+            * normally the first location is the source and the
+              second the destination
+          }
+
+          {# Emits instruction to call the method specified by symbol name.
+             This routine must be overridden for each new target cpu.
+          }
+          procedure a_call_name(list : TAsmList;pd : tprocdef;const s : TSymStr; weak: boolean);virtual;abstract;
+          procedure a_call_reg(list : TAsmList;pd : tabstractprocdef;reg : tregister);virtual;abstract;
+          procedure a_call_ref(list : TAsmList;pd : tabstractprocdef;ref : treference);virtual;abstract;
+          { same as a_call_name, might be overridden on certain architectures to emit
+            static calls without usage of a got trampoline }
+          procedure a_call_name_static(list : TAsmList;pd : tprocdef;const s : TSymStr);virtual;
+          { same as a_call_name, might be overridden on certain architectures to emit
+            special static calls for inherited methods }
+          procedure a_call_name_inherited(list : TAsmList;pd : tprocdef;const s : TSymStr);virtual;
+
+          { move instructions }
+          procedure a_load_const_reg(list : TAsmList;tosize : tdef;a : aint;register : tregister);virtual;abstract;
+          procedure a_load_const_ref(list : TAsmList;tosize : tdef;a : aint;const ref : treference);virtual;
+          procedure a_load_const_loc(list : TAsmList;tosize : tdef;a : aint;const loc : tlocation);virtual;
+          procedure a_load_reg_ref(list : TAsmList;fromsize, tosize : tdef;register : tregister;const ref : treference);virtual;abstract;
+          procedure a_load_reg_ref_unaligned(list : TAsmList;fromsize, tosize : tdef;register : tregister;const ref : treference);virtual;
+          procedure a_load_reg_reg(list : TAsmList;fromsize, tosize : tdef;reg1,reg2 : tregister);virtual;abstract;
+          procedure a_load_reg_loc(list : TAsmList;fromsize, tosize : tdef;reg : tregister;const loc: tlocation);virtual;
+          procedure a_load_ref_reg(list : TAsmList;fromsize, tosize : tdef;const ref : treference;register : tregister);virtual;abstract;
+          procedure a_load_ref_reg_unaligned(list : TAsmList;fromsize, tosize : tdef;const ref : treference;register : tregister);virtual;
+          procedure a_load_ref_ref(list : TAsmList;fromsize, tosize : tdef;const sref : treference;const dref : treference);virtual;
+          procedure a_load_loc_reg(list : TAsmList;fromsize, tosize : tdef; const loc: tlocation; reg : tregister);virtual;
+          procedure a_load_loc_ref(list : TAsmList;fromsize, tosize: tdef; const loc: tlocation; const ref : treference);virtual;
+          procedure a_load_loc_subsetreg(list : TAsmList;fromsize, tosize, tosubsetsize: tdef; const loc: tlocation; const sreg : tsubsetregister);virtual;
+          procedure a_load_loc_subsetref(list : TAsmList;fromsize, tosize, tosubsetsize: tdef; const loc: tlocation; const sref : tsubsetreference);virtual;
+          procedure a_loadaddr_ref_reg(list : TAsmList;fromsize, tosize : tdef;const ref : treference;r : tregister);virtual;abstract;
+
+          { The subset stuff still need a transformation to thlcgobj }
+          procedure a_load_subsetreg_reg(list : TAsmList; fromsize, fromsubsetsize, tosize: tdef; const sreg: tsubsetregister; destreg: tregister); virtual; abstract;
+          procedure a_load_reg_subsetreg(list : TAsmList; fromsize, tosize, tosubsetsize: tdef; fromreg: tregister; const sreg: tsubsetregister); virtual; abstract;
+          procedure a_load_subsetreg_subsetreg(list: TAsmlist; fromsize, fromsubsetsize, tosize, tosubsetsize : tdef; const fromsreg, tosreg: tsubsetregister); virtual; abstract;
+          procedure a_load_subsetreg_ref(list : TAsmList; fromsize, fromsubsetsize, tosize: tdef; const sreg: tsubsetregister; const destref: treference); virtual; abstract;
+          procedure a_load_ref_subsetreg(list : TAsmList; fromsize, tosize,tosubsetsize: tdef; const fromref: treference; const sreg: tsubsetregister); virtual; abstract;
+          procedure a_load_const_subsetreg(list: TAsmlist; tosize, tosubsetsize: tdef; a: aint; const sreg: tsubsetregister); virtual; abstract;
+          procedure a_load_subsetreg_loc(list: TAsmlist; fromsize, fromsubsetsize, tosize: tdef; const sreg: tsubsetregister; const loc: tlocation); virtual;
+
+          procedure a_load_subsetref_reg(list : TAsmList; fromsize, fromsubsetsize, tosize: tdef; const sref: tsubsetreference; destreg: tregister); virtual; abstract;
+          procedure a_load_reg_subsetref(list : TAsmList; fromsize, tosubsetsize, tosize: tdef; fromreg: tregister; const sref: tsubsetreference); virtual; abstract;
+          procedure a_load_subsetref_subsetref(list: TAsmlist; fromsize, fromsubsetsize, tosize, tosubsetsize : tdef; const fromsref, tosref: tsubsetreference); virtual; abstract;
+          procedure a_load_subsetref_ref(list : TAsmList; fromsize, fromsubsetsize, tosize: tdef; const sref: tsubsetreference; const destref: treference); virtual; abstract;
+          procedure a_load_ref_subsetref(list : TAsmList; fromsize, tosize, tosubsetsize: tdef; const fromref: treference; const sref: tsubsetreference); virtual; abstract;
+          procedure a_load_const_subsetref(list: TAsmlist; tosize, tosubsetsize: tdef; a: aint; const sref: tsubsetreference); virtual; abstract;
+          procedure a_load_subsetref_loc(list: TAsmlist; fromsize, fromsubsetsize, tosize: tdef; const sref: tsubsetreference; const loc: tlocation); virtual;
+          procedure a_load_subsetref_subsetreg(list: TAsmlist; fromsize, fromsubsetsize, tosize, tosubsetsize : tdef; const fromsref: tsubsetreference; const tosreg: tsubsetregister); virtual; abstract;
+          procedure a_load_subsetreg_subsetref(list: TAsmlist; fromsize, fromsubsetsize, tosize, tosubsetsize : tdef; const fromsreg: tsubsetregister; const tosref: tsubsetreference); virtual; abstract;
+
+          { bit test instructions (still need transformation to thlcgobj) }
+          procedure a_bit_test_reg_reg_reg(list : TAsmList; bitnumbersize,valuesize,destsize: tdef;bitnumber,value,destreg: tregister); virtual; abstract;
+          procedure a_bit_test_const_ref_reg(list: TAsmList; fromsize, destsize: tdef; bitnumber: aint; const ref: treference; destreg: tregister); virtual; abstract;
+          procedure a_bit_test_const_reg_reg(list: TAsmList; setregsize, destsize: tdef; bitnumber: aint; setreg, destreg: tregister); virtual; abstract;
+          procedure a_bit_test_const_subsetreg_reg(list: TAsmList; fromsize, fromsubsetsize, destsize: tdef; bitnumber: aint; const setreg: tsubsetregister; destreg: tregister); virtual; abstract;
+          procedure a_bit_test_reg_ref_reg(list: TAsmList; bitnumbersize, refsize, destsize: tdef; bitnumber: tregister; const ref: treference; destreg: tregister); virtual; abstract;
+          procedure a_bit_test_reg_loc_reg(list: TAsmList; bitnumbersize, locsize, destsize: tdef; bitnumber: tregister; const loc: tlocation; destreg: tregister);virtual;
+          procedure a_bit_test_const_loc_reg(list: TAsmList; locsize, destsize: tdef; bitnumber: aint; const loc: tlocation; destreg: tregister);virtual;
+
+          { bit set/clear instructions (still need transformation to thlcgobj) }
+          procedure a_bit_set_reg_reg(list : TAsmList; doset: boolean; bitnumbersize, destsize: tdef; bitnumber,dest: tregister); virtual; abstract;
+          procedure a_bit_set_const_ref(list: TAsmList; doset: boolean;destsize: tdef; bitnumber: aint; const ref: treference); virtual; abstract;
+          procedure a_bit_set_const_reg(list: TAsmList; doset: boolean; destsize: tdef; bitnumber: aint; destreg: tregister); virtual; abstract;
+          procedure a_bit_set_const_subsetreg(list: TAsmList; doset: boolean; destsize, destsubsetsize: tdef; bitnumber: aint; const destreg: tsubsetregister); virtual; abstract;
+          procedure a_bit_set_reg_ref(list: TAsmList; doset: boolean; fromsize, tosize: tdef; bitnumber: tregister; const ref: treference); virtual; abstract;
+          procedure a_bit_set_reg_loc(list: TAsmList; doset: boolean; fromsize, tosize: tdef; bitnumber: tregister; const loc: tlocation);virtual;
+          procedure a_bit_set_const_loc(list: TAsmList; doset: boolean; tosize: tdef; bitnumber: aint; const loc: tlocation);virtual;
+
+          { bit scan instructions (still need transformation to thlcgobj) }
+          procedure a_bit_scan_reg_reg(list: TAsmList; reverse: boolean; size: tdef; src, dst: tregister); virtual; abstract;
+
+          { fpu move instructions }
+          procedure a_loadfpu_reg_reg(list: TAsmList; fromsize, tosize: tdef; reg1, reg2: tregister); virtual; abstract;
+          procedure a_loadfpu_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; reg: tregister); virtual; abstract;
+          procedure a_loadfpu_reg_ref(list: TAsmList; fromsize, tosize: tdef; reg: tregister; const ref: treference); virtual; abstract;
+          procedure a_loadfpu_ref_ref(list: TAsmList; fromsize, tosize: tdef; const ref1,ref2: treference);virtual;
+          procedure a_loadfpu_loc_reg(list: TAsmList; fromsize, tosize: tdef; const loc: tlocation; const reg: tregister);virtual;
+          procedure a_loadfpu_reg_loc(list: TAsmList; fromsize, tosize: tdef; const reg: tregister; const loc: tlocation);virtual;
+          procedure a_loadfpu_reg_cgpara(list : TAsmList;fromsize: tdef;const r : tregister;const cgpara : TCGPara);virtual;
+          procedure a_loadfpu_ref_cgpara(list : TAsmList;fromsize : tdef;const ref : treference;const cgpara : TCGPara);virtual;
+
+          { vector register move instructions }
+//        we don't have high level defs yet that translate into all mm cgsizes
+{
+          procedure a_loadmm_reg_reg(list: TAsmList; fromsize, tosize: tdef;reg1, reg2: tregister;shuffle : pmmshuffle); virtual;
+          procedure a_loadmm_ref_reg(list: TAsmList; fromsize, tosize: tdef;const ref: treference; reg: tregister;shuffle : pmmshuffle); virtual;
+          procedure a_loadmm_reg_ref(list: TAsmList; fromsize, tosize: tdef;reg: tregister; const ref: treference;shuffle : pmmshuffle); virtual;
+          procedure a_loadmm_loc_reg(list: TAsmList; fromsize, tosize: tdef; const loc: tlocation; const reg: tregister;shuffle : pmmshuffle);virtual;
+          procedure a_loadmm_reg_loc(list: TAsmList; fromsize, tosize: tdef; const reg: tregister; const loc: tlocation;shuffle : pmmshuffle);virtual;
+          procedure a_loadmm_reg_cgpara(list: TAsmList; fromsize: tdef; reg: tregister;const cgpara : TCGPara;shuffle : pmmshuffle); virtual;
+          procedure a_loadmm_ref_cgpara(list: TAsmList; fromsize: tdef; const ref: treference;const cgpara : TCGPara;shuffle : pmmshuffle); virtual;
+          procedure a_loadmm_loc_cgpara(list: TAsmList; fromsize: tdef; const loc: tlocation; const cgpara : TCGPara;shuffle : pmmshuffle); virtual;
+          procedure a_opmm_reg_reg(list: TAsmList; Op: TOpCG; size : tdef;src,dst: tregister;shuffle : pmmshuffle); virtual;
+          procedure a_opmm_ref_reg(list: TAsmList; Op: TOpCG; size : tdef;const ref: treference; reg: tregister;shuffle : pmmshuffle); virtual;
+          procedure a_opmm_loc_reg(list: TAsmList; Op: TOpCG; size : tdef;const loc: tlocation; reg: tregister;shuffle : pmmshuffle); virtual;
+          procedure a_opmm_reg_ref(list: TAsmList; Op: TOpCG; size : tdef;reg: tregister;const ref: treference; shuffle : pmmshuffle); virtual;
+}
+//        we don't have high level defs yet that translate into all mm cgsizes
+//          procedure a_loadmm_intreg_reg(list: TAsmList; fromsize, tosize : tdef; intreg, mmreg: tregister; shuffle: pmmshuffle); virtual;
+//          procedure a_loadmm_reg_intreg(list: TAsmList; fromsize, tosize : tdef; mmreg, intreg: tregister; shuffle : pmmshuffle); virtual;
+
+          { basic arithmetic operations }
+          { note: for operators which require only one argument (not, neg), use }
+          { the op_reg_reg, op_reg_ref or op_reg_loc methods and keep in mind   }
+          { that in this case the *second* operand is used as both source and   }
+          { destination (JM)                                                    }
+          procedure a_op_const_reg(list : TAsmList; Op: TOpCG; size: tdef; a: Aint; reg: TRegister); virtual; abstract;
+          procedure a_op_const_ref(list : TAsmList; Op: TOpCG; size: tdef; a: Aint; const ref: TReference); virtual;
+          procedure a_op_const_subsetreg(list : TAsmList; Op : TOpCG; size, subsetsize : tdef; a : aint; const sreg: tsubsetregister); virtual;
+          procedure a_op_const_subsetref(list : TAsmList; Op : TOpCG; size, subsetsize : tdef; a : aint; const sref: tsubsetreference); virtual;
+          procedure a_op_const_loc(list : TAsmList; Op: TOpCG; size: tdef; a: Aint; const loc: tlocation);virtual;
+          procedure a_op_reg_reg(list : TAsmList; Op: TOpCG; size: tdef; reg1, reg2: TRegister); virtual; abstract;
+          procedure a_op_reg_ref(list : TAsmList; Op: TOpCG; size: tdef; reg: TRegister; const ref: TReference); virtual;
+          procedure a_op_ref_reg(list : TAsmList; Op: TOpCG; size: tdef; const ref: TReference; reg: TRegister); virtual;
+          procedure a_op_reg_subsetreg(list: TAsmList; Op: TOpCG; opsize, destsize, destsubsetsize: tdef; reg: TRegister; const sreg: tsubsetregister); virtual;
+          procedure a_op_reg_subsetref(list: TAsmList; Op: TOpCG; opsize, destsize, destsubsetsize: tdef; reg: TRegister; const sref: tsubsetreference); virtual;
+          procedure a_op_reg_loc(list : TAsmList; Op: TOpCG; size: tdef; reg: tregister; const loc: tlocation);virtual;
+          procedure a_op_ref_loc(list : TAsmList; Op: TOpCG; size: tdef; const ref: TReference; const loc: tlocation);virtual;
+
+          { trinary operations for processors that support them, 'emulated' }
+          { on others. None with "ref" arguments since I don't think there  }
+          { are any processors that support it (JM)                         }
+          procedure a_op_const_reg_reg(list: TAsmList; op: TOpCg; size: tdef; a: aint; src, dst: tregister); virtual;
+          procedure a_op_reg_reg_reg(list: TAsmList; op: TOpCg; size: tdef; src1, src2, dst: tregister); virtual;
+          procedure a_op_const_reg_reg_checkoverflow(list: TAsmList; op: TOpCg; size: tdef; a: aint; src, dst: tregister;setflags : boolean;var ovloc : tlocation); virtual;
+          procedure a_op_reg_reg_reg_checkoverflow(list: TAsmList; op: TOpCg; size: tdef; src1, src2, dst: tregister;setflags : boolean;var ovloc : tlocation); virtual;
+
+          {  comparison operations }
+          procedure a_cmp_const_reg_label(list : TAsmList;size : tdef;cmp_op : topcmp;a : aint;reg : tregister;
+            l : tasmlabel);virtual;
+          procedure a_cmp_const_ref_label(list : TAsmList;size : tdef;cmp_op : topcmp;a : aint;const ref : treference;
+            l : tasmlabel); virtual;
+          procedure a_cmp_const_loc_label(list: TAsmList; size: tdef;cmp_op: topcmp; a: aint; const loc: tlocation;
+            l : tasmlabel);virtual;
+          procedure a_cmp_reg_reg_label(list : TAsmList;size : tdef;cmp_op : topcmp;reg1,reg2 : tregister;l : tasmlabel); virtual; abstract;
+          procedure a_cmp_ref_reg_label(list : TAsmList;size : tdef;cmp_op : topcmp; const ref: treference; reg : tregister; l : tasmlabel); virtual;
+          procedure a_cmp_reg_ref_label(list : TAsmList;size : tdef;cmp_op : topcmp;reg : tregister; const ref: treference; l : tasmlabel); virtual;
+          procedure a_cmp_subsetreg_reg_label(list: TAsmList; fromsize, fromsubsetsize, cmpsize: tdef; cmp_op: topcmp; const sreg: tsubsetregister; reg: tregister; l: tasmlabel); virtual;
+          procedure a_cmp_subsetref_reg_label(list: TAsmList; fromsize, fromsubsetsize, cmpsize: tdef; cmp_op: topcmp; const sref: tsubsetreference; reg: tregister; l: tasmlabel); virtual;
+
+          procedure a_cmp_loc_reg_label(list : TAsmList;size : tdef;cmp_op : topcmp; const loc: tlocation; reg : tregister; l : tasmlabel);virtual;
+          procedure a_cmp_reg_loc_label(list : TAsmList;size : tdef;cmp_op : topcmp; reg: tregister; const loc: tlocation; l : tasmlabel);virtual;
+          procedure a_cmp_ref_loc_label(list: TAsmList; size: tdef;cmp_op: topcmp; const ref: treference; const loc: tlocation; l : tasmlabel);virtual;
+
+          procedure a_jmp_always(list : TAsmList;l: tasmlabel); virtual;abstract;
+{$ifdef cpuflags}
+          procedure a_jmp_flags(list : TAsmList;const f : TResFlags;l: tasmlabel); virtual; abstract;
+
+          {# Depending on the value to check in the flags, either sets the register reg to one (if the flag is set)
+             or zero (if the flag is cleared). The size parameter indicates the destination size register.
+          }
+          procedure g_flags2reg(list: TAsmList; size: tdef; const f: tresflags; reg: TRegister); virtual; abstract;
+          procedure g_flags2ref(list: TAsmList; size: tdef; const f: tresflags; const ref:TReference); virtual; abstract;
+{$endif cpuflags}
+
+//          procedure g_maybe_testself(list : TAsmList;reg:tregister);
+//          procedure g_maybe_testvmt(list : TAsmList;reg:tregister;objdef:tobjectdef);
+          {# This should emit the opcode to copy len bytes from the source
+             to destination.
+
+             It must be overridden for each new target processor.
+
+             @param(source Source reference of copy)
+             @param(dest Destination reference of copy)
+
+          }
+          procedure g_concatcopy(list : TAsmList;size: tdef; const source,dest : treference);virtual;
+          {# This should emit the opcode to copy len bytes from the an unaligned source
+             to destination.
+
+             It must be overridden for each new target processor.
+
+             @param(source Source reference of copy)
+             @param(dest Destination reference of copy)
+
+          }
+          procedure g_concatcopy_unaligned(list : TAsmList;size: tdef; const source,dest : treference);virtual;
+          {# This should emit the opcode to a shortrstring from the source
+             to destination.
+
+             @param(source Source reference of copy)
+             @param(dest Destination reference of copy)
+
+          }
+          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_initialize(list : TAsmList;t : tdef;const ref : treference);virtual;abstract;
+          procedure g_finalize(list : TAsmList;t : tdef;const ref : treference);virtual;abstract;
+          procedure g_array_rtti_helper(list: TAsmList; t: tdef; const ref: treference; const highloc: tlocation;
+            const name: string);virtual;abstract;
+
+          {# Generates range checking code. It is to note
+             that this routine does not need to be overridden,
+             as it takes care of everything.
+
+             @param(p Node which contains the value to check)
+             @param(todef Type definition of node to range check)
+          }
+          procedure g_rangecheck(list: TAsmList; const l:tlocation; fromdef,todef: tdef); virtual;
+
+          {# Generates overflow checking code for a node }
+          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;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
+             behavior does nothing, should be overridden as required.
+          }
+          procedure g_profilecode(list : TAsmList);virtual;
+          {# Emits instruction for allocating @var(size) bytes at the stackpointer
+
+             @param(size Number of bytes to allocate)
+          }
+          procedure g_stackpointer_alloc(list : TAsmList;size : longint);virtual; abstract;
+          {# Emits instruction for allocating the locals in entry
+             code of a routine. This is one of the first
+             routine called in @var(genentrycode).
+
+             @param(localsize Number of bytes to allocate as locals)
+          }
+          procedure g_proc_entry(list : TAsmList;localsize : longint;nostackframe:boolean);virtual; abstract;
+          {# Emits instructions for returning from a subroutine.
+             Should also restore the framepointer and stack.
+
+             @param(parasize  Number of bytes of parameters to deallocate from stack)
+          }
+          procedure g_proc_exit(list : TAsmList;parasize:longint;nostackframe:boolean);virtual; abstract;
+
+          procedure g_intf_wrapper(list: TAsmList; procdef: tprocdef; const labelname: string; ioffset: longint);virtual; abstract;
+          procedure g_adjust_self_value(list:TAsmList;procdef: tprocdef;ioffset: aint);virtual; abstract;
+
+          function g_indirect_sym_load(list:TAsmList;const symname: string; const flags: tindsymflags): tregister;virtual; abstract;
+          { generate a stub which only purpose is to pass control the given external method,
+          setting up any additional environment before doing so (if required).
+
+          The default implementation issues a jump instruction to the external name. }
+//          procedure g_external_wrapper(list : TAsmList; procdef: tprocdef; const externalname: string); virtual;
+
+         protected
+          procedure g_allocload_reg_reg(list: TAsmList; regsize: tdef; const fromreg: tregister; out toreg: tregister; regtyp: tregistertype);
+         public
+          { create "safe copy" of a tlocation that can be used later: all
+            registers used in the tlocation are copied to new ones, so that
+            even if the original ones change, things stay the same (except if
+            the original location was already a register, then the register is
+            kept). Must only be used on lvalue locations.
+            It's intended as some kind of replacement for a_loadaddr_ref_reg()
+            for targets without pointers. }
+          procedure g_reference_loc(list: TAsmList; def: tdef; const fromloc: tlocation; out toloc: tlocation); virtual;
+
+
+          { routines migrated from ncgutil }
+
+          procedure location_force_reg(list:TAsmList;var l:tlocation;src_size,dst_size:tdef;maybeconst:boolean);virtual;
+          procedure location_force_fpureg(list:TAsmList;var l: tlocation;size: tdef;maybeconst:boolean);virtual;
+          procedure location_force_mem(list:TAsmList;var l:tlocation;size:tdef);virtual;
+//          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_initialize_code(list:TAsmList);virtual;
+          procedure gen_finalize_code(list:TAsmList);virtual;
+
+          procedure gen_entry_code(list:TAsmList);virtual;
+          procedure gen_exit_code(list:TAsmList);virtual;
+
+         protected
+          { helpers called by gen_initialize_code/gen_finalize_code }
+          procedure inittempvariables(list:TAsmList);virtual;
+          procedure initialize_data(p:TObject;arg:pointer);virtual;
+          procedure finalizetempvariables(list:TAsmList);virtual;
+          procedure initialize_regvars(p:TObject;arg:pointer);virtual;
+          procedure finalize_sym(asmlist:TAsmList;sym:tsym);virtual;
+          { generates the code for finalisation of local variables }
+          procedure finalize_local_vars(p:TObject;arg:pointer);virtual;
+          { generates the code for finalization of static symtable and
+            all local (static) typed consts }
+          procedure finalize_static_data(p:TObject;arg:pointer);virtual;
+          { generates the code for decrementing the reference count of parameters }
+          procedure final_paras(p:TObject;arg:pointer);
+         public
+
+          procedure gen_load_para_value(list:TAsmList);virtual;
+         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.
+            stack-based architectures. By default it does nothing }
+          procedure gen_load_uninitialized_function_result(list: TAsmList; pd: tprocdef; resdef: tdef; const resloc: tcgpara);virtual;
+         public
+          { load a tlocation into a cgpara }
+          procedure gen_load_loc_cgpara(list: TAsmList; vardef: tdef; const l: tlocation; const cgpara: tcgpara);virtual;
+
+          { load a cgpara into a tlocation }
+          procedure gen_load_cgpara_loc(list: TAsmList; vardef: tdef; const para: TCGPara; var destloc: tlocation; reusepara: boolean);virtual;
+
+          { load the function return value into the ABI-defined function return location }
+          procedure gen_load_return_value(list:TAsmList);virtual;
+
+          { extras refactored from other units }
+
+          { queue the code/data generated for a procedure for writing out to
+            the assembler/object file }
+          procedure record_generated_code_for_procdef(pd: tprocdef; code, data: TAsmList); virtual;
+
+          { generate a call to a routine in the system unit }
+          procedure g_call_system_proc(list: TAsmList; const procname: string);
+
+          { Generate code to exit an unwind-protected region. The default implementation
+            produces a simple jump to destination label. }
+          procedure g_local_unwind(list: TAsmList; l: TAsmLabel);virtual;abstract;
+       end;
+
+    var
+       {# Main high level code generator class }
+       hlcg : thlcgobj;
+
+    procedure destroy_hlcodegen;
+
+implementation
+
+    uses
+       globals,options,systems,
+       fmodule,export,
+       verbose,defutil,paramgr,
+       symbase,symsym,symtable,
+       ncon,nld,pass_1,pass_2,
+       cpuinfo,cgobj,tgobj,cutils,procinfo,
+       ncgutil,ngenutil;
+
+
+    procedure destroy_hlcodegen;
+      begin
+        hlcg.free;
+        hlcg:=nil;
+        destroy_codegen;
+      end;
+
+  { thlcgobj }
+
+  constructor thlcgobj.create;
+    begin
+    end;
+
+  procedure thlcgobj.init_register_allocators;
+    begin
+      cg.init_register_allocators;
+    end;
+
+  procedure thlcgobj.done_register_allocators;
+    begin
+      cg.done_register_allocators;
+    end;
+
+  procedure thlcgobj.set_regalloc_live_range_direction(dir: TRADirection);
+    begin
+      cg.set_regalloc_live_range_direction(dir);
+    end;
+
+  function thlcgobj.getintregister(list: TAsmList; size: tdef): Tregister;
+    begin
+      result:=cg.getintregister(list,def_cgsize(size));
+    end;
+
+  function thlcgobj.getaddressregister(list: TAsmList; size: tdef): Tregister;
+    begin
+      result:=cg.getaddressregister(list);
+    end;
+
+  function thlcgobj.getfpuregister(list: TAsmList; size: tdef): Tregister;
+    begin
+      result:=cg.getfpuregister(list,def_cgsize(size));
+    end;
+(*
+  function thlcgobj.getmmregister(list: TAsmList; size: tdef): Tregister;
+    begin
+      result:=cg.getmmregister(list,def_cgsize(size));
+    end;
+*)
+  function thlcgobj.getflagregister(list: TAsmList; size: tdef): Tregister;
+    begin
+      result:=cg.getflagregister(list,def_cgsize(size));
+    end;
+
+    function thlcgobj.getregisterfordef(list: TAsmList; size: tdef): Tregister;
+      begin
+        case def2regtyp(size) of
+          R_INTREGISTER:
+            result:=getintregister(list,size);
+          R_ADDRESSREGISTER:
+            result:=getaddressregister(list,size);
+          R_FPUREGISTER:
+            result:=getfpuregister(list,size);
+(*
+          R_MMREGISTER:
+            result:=getmmregister(list,size);
+*)
+          else
+            internalerror(2010122901);
+        end;
+      end;
+
+  function thlcgobj.uses_registers(rt: Tregistertype): boolean;
+    begin
+       result:=cg.uses_registers(rt);
+    end;
+
+  procedure thlcgobj.do_register_allocation(list: TAsmList; headertai: tai);
+    begin
+      cg.do_register_allocation(list,headertai);
+    end;
+
+  procedure thlcgobj.translate_register(var reg: tregister);
+    begin
+      cg.translate_register(reg);
+    end;
+
+  function thlcgobj.def2regtyp(def: tdef): tregistertype;
+    begin
+        case def.typ of
+          enumdef,
+          orddef,
+          recorddef,
+          setdef:
+            result:=R_INTREGISTER;
+          stringdef,
+          pointerdef,
+          classrefdef,
+          objectdef,
+          procvardef,
+          procdef,
+          arraydef,
+          formaldef:
+            result:=R_ADDRESSREGISTER;
+          floatdef:
+            if use_vectorfpu(def) then
+              result:=R_MMREGISTER
+            else if cs_fp_emulation in current_settings.moduleswitches then
+              result:=R_INTREGISTER
+            else
+              result:=R_FPUREGISTER;
+          filedef,
+          variantdef:
+            internalerror(2010120507);
+        else
+          internalerror(2010120506);
+        end;
+    end;
+
+  procedure thlcgobj.a_label(list: TAsmList; l: tasmlabel); inline;
+    begin
+      cg.a_label(list,l);
+    end;
+
+  procedure thlcgobj.a_reg_alloc(list: TAsmList; r: tregister);
+    begin
+      cg.a_reg_alloc(list,r);
+    end;
+
+  procedure thlcgobj.a_reg_dealloc(list: TAsmList; r: tregister);
+    begin
+      cg.a_reg_dealloc(list,r);
+    end;
+
+  procedure thlcgobj.a_reg_sync(list: TAsmList; r: tregister);
+    begin
+      cg.a_reg_sync(list,r);
+    end;
+
+  procedure thlcgobj.a_load_reg_cgpara(list: TAsmList; size: tdef; r: tregister; const cgpara: TCGPara);
+    var
+      ref: treference;
+    begin
+      cgpara.check_simple_location;
+      paramanager.alloccgpara(list,cgpara);
+      case cgpara.location^.loc of
+         LOC_REGISTER,LOC_CREGISTER:
+           a_load_reg_reg(list,size,cgpara.def,r,cgpara.location^.register);
+         LOC_REFERENCE,LOC_CREFERENCE:
+           begin
+              reference_reset_base(ref,cgpara.location^.reference.index,cgpara.location^.reference.offset,cgpara.alignment);
+              a_load_reg_ref(list,size,cgpara.def,r,ref);
+           end;
+(*
+         LOC_MMREGISTER,LOC_CMMREGISTER:
+           a_loadmm_intreg_reg(list,size,cgpara.def,r,cgpara.location^.register,mms_movescalar);
+*)
+         LOC_FPUREGISTER,LOC_CFPUREGISTER:
+           begin
+             tg.gethltemp(list,size,size.size,tt_normal,ref);
+             a_load_reg_ref(list,size,size,r,ref);
+             a_loadfpu_ref_cgpara(list,size,ref,cgpara);
+             tg.ungettemp(list,ref);
+           end
+         else
+           internalerror(2010120415);
+      end;
+    end;
+
+  procedure thlcgobj.a_load_const_cgpara(list: TAsmList; tosize: tdef; a: aint; const cgpara: TCGPara);
+    var
+       ref : treference;
+    begin
+       cgpara.check_simple_location;
+       paramanager.alloccgpara(list,cgpara);
+       case cgpara.location^.loc of
+          LOC_REGISTER,LOC_CREGISTER:
+            a_load_const_reg(list,cgpara.def,a,cgpara.location^.register);
+          LOC_REFERENCE,LOC_CREFERENCE:
+            begin
+               reference_reset_base(ref,cgpara.location^.reference.index,cgpara.location^.reference.offset,cgpara.alignment);
+               a_load_const_ref(list,cgpara.def,a,ref);
+            end
+          else
+            internalerror(2010120416);
+       end;
+    end;
+
+  procedure thlcgobj.a_load_ref_cgpara(list: TAsmList; size: tdef; const r: treference; const cgpara: TCGPara);
+    var
+      ref: treference;
+    begin
+      cgpara.check_simple_location;
+      paramanager.alloccgpara(list,cgpara);
+      case cgpara.location^.loc of
+         LOC_REGISTER,LOC_CREGISTER:
+           a_load_ref_reg(list,size,cgpara.def,r,cgpara.location^.register);
+         LOC_REFERENCE,LOC_CREFERENCE:
+           begin
+              reference_reset_base(ref,cgpara.location^.reference.index,cgpara.location^.reference.offset,cgpara.alignment);
+              a_load_ref_ref(list,size,cgpara.def,r,ref);
+           end
+(*
+         LOC_MMREGISTER,LOC_CMMREGISTER:
+           begin
+              case location^.size of
+                OS_F32,
+                OS_F64,
+                OS_F128:
+                  a_loadmm_ref_reg(list,cgpara.def,cgpara.def,r,location^.register,mms_movescalar);
+                OS_M8..OS_M128,
+                OS_MS8..OS_MS128:
+                  a_loadmm_ref_reg(list,cgpara.def,cgpara.def,r,location^.register,nil);
+                else
+                  internalerror(2010120417);
+              end;
+           end
+*)
+         else
+           internalerror(2010120418);
+      end;
+    end;
+
+  procedure thlcgobj.a_load_loc_cgpara(list: TAsmList; size: tdef; const l: tlocation; const cgpara: TCGPara);
+    begin
+      case l.loc of
+        LOC_REGISTER,
+        LOC_CREGISTER :
+          a_load_reg_cgpara(list,size,l.register,cgpara);
+        LOC_CONSTANT :
+          a_load_const_cgpara(list,size,l.value,cgpara);
+        LOC_CREFERENCE,
+        LOC_REFERENCE :
+          a_load_ref_cgpara(list,size,l.reference,cgpara);
+        else
+          internalerror(2010120419);
+      end;
+    end;
+
+  procedure thlcgobj.a_loadaddr_ref_cgpara(list: TAsmList; fromsize, tosize: tdef; const r: treference; const cgpara: TCGPara);
+    var
+       hr : tregister;
+    begin
+       cgpara.check_simple_location;
+       if cgpara.location^.loc in [LOC_CREGISTER,LOC_REGISTER] then
+         begin
+           paramanager.allocparaloc(list,cgpara.location);
+           a_loadaddr_ref_reg(list,fromsize,tosize,r,cgpara.location^.register)
+         end
+       else
+         begin
+           hr:=getaddressregister(list,tosize);
+           a_loadaddr_ref_reg(list,fromsize,tosize,r,hr);
+           a_load_reg_cgpara(list,tosize,hr,cgpara);
+         end;
+    end;
+
+  procedure thlcgobj.a_call_name_static(list: TAsmList; pd: tprocdef; const s: TSymStr);
+    begin
+      a_call_name(list,pd,s,false);
+    end;
+
+    procedure thlcgobj.a_call_name_inherited(list: TAsmList; pd: tprocdef; const s: TSymStr);
+      begin
+        a_call_name(list,pd,s,false);
+      end;
+
+  procedure thlcgobj.a_load_const_ref(list: TAsmList; tosize: tdef; a: aint; const ref: treference);
+    var
+      tmpreg: tregister;
+    begin
+      tmpreg:=getintregister(list,tosize);
+      a_load_const_reg(list,tosize,a,tmpreg);
+      a_load_reg_ref(list,tosize,tosize,tmpreg,ref);
+    end;
+
+  procedure thlcgobj.a_load_const_loc(list: TAsmList; tosize: tdef; a: aint; const loc: tlocation);
+    begin
+      case loc.loc of
+        LOC_REFERENCE,LOC_CREFERENCE:
+          a_load_const_ref(list,tosize,a,loc.reference);
+        LOC_REGISTER,LOC_CREGISTER:
+          a_load_const_reg(list,tosize,a,loc.register);
+        { we don't have enough type information to handle these here
+        LOC_SUBSETREG,LOC_CSUBSETREG:
+          a_load_const_subsetreg(list,loc.size,a,loc.sreg);
+        LOC_SUBSETREF,LOC_CSUBSETREF:
+          a_load_const_subsetref(list,loc.size,a,loc.sref);
+        }
+        else
+          internalerror(2010120401);
+      end;
+    end;
+
+  procedure thlcgobj.a_load_reg_ref_unaligned(list: TAsmList; fromsize, tosize: tdef; register: tregister; const ref: treference);
+    begin
+      a_load_reg_ref(list,fromsize,tosize,register,ref);
+    end;
+
+  procedure thlcgobj.a_load_reg_loc(list: TAsmList; fromsize, tosize: tdef; reg: tregister; const loc: tlocation);
+    begin
+      case loc.loc of
+        LOC_REFERENCE,LOC_CREFERENCE:
+          a_load_reg_ref(list,fromsize,tosize,reg,loc.reference);
+        LOC_REGISTER,LOC_CREGISTER:
+          a_load_reg_reg(list,fromsize,tosize,reg,loc.register);
+        { we don't have enough type information to handle these here
+        LOC_SUBSETREG,LOC_CSUBSETREG:
+          a_load_reg_subsetreg(list,fromsize,tosize,reg,loc.sreg);
+        LOC_SUBSETREF,LOC_CSUBSETREF:
+          a_load_reg_subsetref(list,fromsize,loc.size,reg,loc.sref);
+        LOC_MMREGISTER,LOC_CMMREGISTER:
+          a_loadmm_intreg_reg(list,fromsize,loc.size,reg,loc.register,mms_movescalar);
+        }
+        else
+          internalerror(2010120402);
+      end;
+    end;
+
+  procedure thlcgobj.a_load_ref_reg_unaligned(list: TAsmList; fromsize, tosize: tdef; const ref: treference; register: tregister);
+    begin
+      a_load_ref_reg(list,fromsize,tosize,ref,register);
+    end;
+
+  procedure thlcgobj.a_load_ref_ref(list: TAsmList; fromsize, tosize: tdef; const sref: treference; const dref: treference);
+    var
+      tmpreg: tregister;
+    begin
+      { verify if we have the same reference }
+      if references_equal(sref,dref) then
+        exit;
+      tmpreg:=getintregister(list,tosize);
+      a_load_ref_reg(list,fromsize,tosize,sref,tmpreg);
+      a_load_reg_ref(list,tosize,tosize,tmpreg,dref);
+    end;
+
+  procedure thlcgobj.a_load_loc_reg(list: TAsmList; fromsize, tosize: tdef; const loc: tlocation; reg: tregister);
+    begin
+      case loc.loc of
+        LOC_REFERENCE,LOC_CREFERENCE:
+          a_load_ref_reg(list,fromsize,tosize,loc.reference,reg);
+        LOC_REGISTER,LOC_CREGISTER:
+          a_load_reg_reg(list,fromsize,tosize,loc.register,reg);
+        LOC_CONSTANT:
+          a_load_const_reg(list,tosize,loc.value,reg);
+        { we don't have enough type information to handle these here
+        LOC_SUBSETREG,LOC_CSUBSETREG:
+          a_load_subsetreg_reg(list,fromsize,tosize,loc.sreg,reg);
+        LOC_SUBSETREF,LOC_CSUBSETREF:
+          a_load_subsetref_reg(list,fromsize,tosize,loc.sref,reg);
+        }
+        else
+          internalerror(2010120201);
+      end;
+    end;
+
+  procedure thlcgobj.a_load_loc_ref(list: TAsmList; fromsize, tosize: tdef; const loc: tlocation; const ref: treference);
+    begin
+      case loc.loc of
+        LOC_REFERENCE,LOC_CREFERENCE:
+          a_load_ref_ref(list,fromsize,tosize,loc.reference,ref);
+        LOC_REGISTER,LOC_CREGISTER:
+          a_load_reg_ref(list,fromsize,tosize,loc.register,ref);
+        LOC_CONSTANT:
+          a_load_const_ref(list,tosize,loc.value,ref);
+        { we don't have enough type information to handle these here
+        LOC_SUBSETREG,LOC_CSUBSETREG:
+          a_load_subsetreg_ref(list,loc.size,tosize,loc.sreg,ref);
+        LOC_SUBSETREF,LOC_CSUBSETREF:
+          a_load_subsetref_ref(list,loc.size,tosize,loc.sref,ref);
+        }
+        else
+          internalerror(2010120403);
+      end;
+    end;
+
+  procedure thlcgobj.a_load_loc_subsetreg(list: TAsmList; fromsize, tosize, tosubsetsize: tdef; const loc: tlocation; const sreg: tsubsetregister);
+    begin
+      case loc.loc of
+        LOC_REFERENCE,LOC_CREFERENCE:
+          a_load_ref_subsetreg(list,fromsize,tosize,tosubsetsize,loc.reference,sreg);
+        LOC_REGISTER,LOC_CREGISTER:
+          a_load_reg_subsetreg(list,fromsize,tosize,tosubsetsize,loc.register,sreg);
+        LOC_CONSTANT:
+          a_load_const_subsetreg(list,tosize,tosubsetsize,loc.value,sreg);
+        { we don't have enough type information to handle these here
+        LOC_SUBSETREG,LOC_CSUBSETREG:
+          a_load_subsetreg_subsetreg(list,loc.size,subsetsize,loc.sreg,sreg);
+        LOC_SUBSETREF,LOC_CSUBSETREF:
+          a_load_subsetref_subsetreg(list,loc.size,subsetsize,loc.sref,sreg);
+        }
+        else
+          internalerror(2010120404);
+      end;
+    end;
+
+  procedure thlcgobj.a_load_loc_subsetref(list: TAsmList; fromsize, tosize, tosubsetsize: tdef; const loc: tlocation; const sref: tsubsetreference);
+    begin
+      case loc.loc of
+        LOC_REFERENCE,LOC_CREFERENCE:
+          a_load_ref_subsetref(list,fromsize,tosize,tosubsetsize,loc.reference,sref);
+        LOC_REGISTER,LOC_CREGISTER:
+          a_load_reg_subsetref(list,fromsize,tosize,tosubsetsize,loc.register,sref);
+        LOC_CONSTANT:
+          a_load_const_subsetref(list,tosize,tosubsetsize,loc.value,sref);
+        { we don't have enough type information to handle these here
+        LOC_SUBSETREG,LOC_CSUBSETREG:
+          a_load_subsetreg_subsetref(list,loc.size,subsetsize,loc.sreg,sref);
+        LOC_SUBSETREF,LOC_CSUBSETREF:
+          a_load_subsetref_subsetref(list,loc.size,subsetsize,loc.sref,sref);
+        }
+        else
+          internalerror(2010120405);
+      end;
+    end;
+
+  procedure thlcgobj.a_load_subsetreg_loc(list: TAsmlist; fromsize, fromsubsetsize, tosize: tdef; const sreg: tsubsetregister; const loc: tlocation);
+    begin
+      case loc.loc of
+        LOC_REFERENCE,LOC_CREFERENCE:
+          a_load_subsetreg_ref(list,fromsize,fromsubsetsize,tosize,sreg,loc.reference);
+        LOC_REGISTER,LOC_CREGISTER:
+          a_load_subsetreg_reg(list,fromsize,fromsubsetsize,tosize,sreg,loc.register);
+        { we don't have enough type information to handle these here
+        LOC_SUBSETREG,LOC_CSUBSETREG:
+          a_load_subsetreg_subsetreg(list,subsetsize,loc.size,sreg,loc.sreg);
+        LOC_SUBSETREF,LOC_CSUBSETREF:
+          a_load_subsetreg_subsetref(list,subsetsize,loc.size,sreg,loc.sref);
+        }
+        else
+          internalerror(2010120406);
+      end;
+    end;
+
+  procedure thlcgobj.a_load_subsetref_loc(list: TAsmlist; fromsize, fromsubsetsize, tosize: tdef; const sref: tsubsetreference; const loc: tlocation);
+    begin
+      case loc.loc of
+        LOC_REFERENCE,LOC_CREFERENCE:
+          a_load_subsetref_ref(list,fromsize,fromsubsetsize,tosize,sref,loc.reference);
+        LOC_REGISTER,LOC_CREGISTER:
+          a_load_subsetref_reg(list,fromsize,fromsubsetsize,tosize,sref,loc.register);
+        { we don't have enough type information to handle these here
+        LOC_SUBSETREG,LOC_CSUBSETREG:
+          a_load_subsetref_subsetreg(list,subsetsize,loc.size,sref,loc.sreg);
+        LOC_SUBSETREF,LOC_CSUBSETREF:
+          a_load_subsetref_subsetref(list,subsetsize,loc.size,sref,loc.sref);
+        }
+        else
+          internalerror(2010120407);
+      end;
+    end;
+
+  procedure thlcgobj.a_bit_test_reg_loc_reg(list: TAsmList; bitnumbersize, locsize, destsize: tdef; bitnumber: tregister; const loc: tlocation; destreg: tregister);
+    var
+      tmpreg: tregister;
+    begin
+      case loc.loc of
+        LOC_REFERENCE,LOC_CREFERENCE:
+          a_bit_test_reg_ref_reg(list,bitnumbersize,locsize,destsize,bitnumber,loc.reference,destreg);
+        LOC_REGISTER,LOC_CREGISTER,
+        LOC_SUBSETREG,LOC_CSUBSETREG,
+        LOC_CONSTANT:
+          begin
+            case loc.loc of
+              LOC_REGISTER,LOC_CREGISTER:
+                tmpreg:=loc.register;
+              (* we don't have enough type information to handle this here
+              LOC_SUBSETREG,LOC_CSUBSETREG:
+                begin
+                  tmpreg:=getintregister(list,loc.size);
+                  a_load_subsetreg_reg(list,loc.size,loc.size,loc.sreg,tmpreg);
+                end;
+              *)
+              LOC_CONSTANT:
+                begin
+                  tmpreg:=getintregister(list,locsize);
+                  a_load_const_reg(list,locsize,loc.value,tmpreg);
+                end;
+            end;
+            a_bit_test_reg_reg_reg(list,bitnumbersize,locsize,destsize,bitnumber,tmpreg,destreg);
+          end;
+        { LOC_SUBSETREF is not possible, because sets are not (yet) bitpacked }
+        else
+          internalerror(2010120411);
+      end;
+    end;
+
+  procedure thlcgobj.a_bit_test_const_loc_reg(list: TAsmList; locsize, destsize: tdef; bitnumber: aint; const loc: tlocation; destreg: tregister);
+    begin
+      case loc.loc of
+        LOC_REFERENCE,LOC_CREFERENCE:
+          a_bit_test_const_ref_reg(list,locsize,destsize,bitnumber,loc.reference,destreg);
+        LOC_REGISTER,LOC_CREGISTER:
+          a_bit_test_const_reg_reg(list,locsize,destsize,bitnumber,loc.register,destreg);
+        (* we don't have enough type information to handle this here
+        LOC_SUBSETREG,LOC_CSUBSETREG:
+          a_bit_test_const_subsetreg_reg(list,loc.size,destsize,bitnumber,loc.sreg,destreg);
+        *)
+        { LOC_SUBSETREF is not possible, because sets are not (yet) bitpacked }
+        else
+          internalerror(2010120410);
+      end;
+    end;
+
+  procedure thlcgobj.a_bit_set_reg_loc(list: TAsmList; doset: boolean; fromsize, tosize: tdef; bitnumber: tregister; const loc: tlocation);
+    begin
+      case loc.loc of
+        LOC_REFERENCE:
+          a_bit_set_reg_ref(list,doset,fromsize,tosize,bitnumber,loc.reference);
+        LOC_CREGISTER:
+          a_bit_set_reg_reg(list,doset,fromsize,tosize,bitnumber,loc.register);
+        (* we don't have enough type information to handle this here
+        { e.g. a 2-byte set in a record regvar }
+        LOC_CSUBSETREG:
+          begin
+            { hard to do in-place in a generic way, so operate on a copy }
+            tmpreg:=getintregister(list,loc.size);
+            a_load_subsetreg_reg(list,loc.size,loc.size,loc.sreg,tmpreg);
+            a_bit_set_reg_reg(list,doset,bitnumbersize,loc.size,bitnumber,tmpreg);
+            a_load_reg_subsetreg(list,loc.size,loc.size,tmpreg,loc.sreg);
+          end;
+        *)
+        { LOC_SUBSETREF is not possible, because sets are not (yet) bitpacked }
+        else
+          internalerror(2010120408)
+      end;
+    end;
+
+  procedure thlcgobj.a_bit_set_const_loc(list: TAsmList; doset: boolean; tosize: tdef; bitnumber: aint; const loc: tlocation);
+    begin
+      case loc.loc of
+        LOC_REFERENCE:
+          a_bit_set_const_ref(list,doset,tosize,bitnumber,loc.reference);
+        LOC_CREGISTER:
+          a_bit_set_const_reg(list,doset,tosize,bitnumber,loc.register);
+        (* we don't have enough type information to handle this here
+        LOC_CSUBSETREG:
+          a_bit_set_const_subsetreg(list,doset,loc.size,bitnumber,loc.sreg);
+        *)
+        { LOC_SUBSETREF is not possible, because sets are not (yet) bitpacked }
+        else
+          internalerror(2010120409)
+      end;
+    end;
+
+  procedure thlcgobj.a_loadfpu_ref_ref(list: TAsmList; fromsize, tosize: tdef; const ref1, ref2: treference);
+    var
+      reg: tregister;
+      regsize: tdef;
+    begin
+      if (fromsize.size>=tosize.size) then
+        regsize:=fromsize
+      else
+        regsize:=tosize;
+      reg:=getfpuregister(list,regsize);
+      a_loadfpu_ref_reg(list,fromsize,regsize,ref1,reg);
+      a_loadfpu_reg_ref(list,regsize,tosize,reg,ref2);
+    end;
+
+  procedure thlcgobj.a_loadfpu_loc_reg(list: TAsmList; fromsize, tosize: tdef; const loc: tlocation; const reg: tregister);
+    begin
+      case loc.loc of
+        LOC_REFERENCE, LOC_CREFERENCE:
+          a_loadfpu_ref_reg(list,fromsize,tosize,loc.reference,reg);
+        LOC_FPUREGISTER, LOC_CFPUREGISTER:
+          a_loadfpu_reg_reg(list,fromsize,tosize,loc.register,reg);
+        else
+          internalerror(2010120412);
+      end;
+    end;
+
+  procedure thlcgobj.a_loadfpu_reg_loc(list: TAsmList; fromsize, tosize: tdef; const reg: tregister; const loc: tlocation);
+    begin
+      case loc.loc of
+        LOC_REFERENCE, LOC_CREFERENCE:
+          a_loadfpu_reg_ref(list,fromsize,tosize,reg,loc.reference);
+        LOC_FPUREGISTER, LOC_CFPUREGISTER:
+          a_loadfpu_reg_reg(list,fromsize,tosize,reg,loc.register);
+        else
+          internalerror(2010120413);
+       end;
+    end;
+
+  procedure thlcgobj.a_loadfpu_reg_cgpara(list: TAsmList; fromsize: tdef; const r: tregister; const cgpara: TCGPara);
+      var
+         ref : treference;
+      begin
+        paramanager.alloccgpara(list,cgpara);
+        case cgpara.location^.loc of
+          LOC_FPUREGISTER,LOC_CFPUREGISTER:
+            begin
+              cgpara.check_simple_location;
+              a_loadfpu_reg_reg(list,fromsize,cgpara.def,r,cgpara.location^.register);
+            end;
+          LOC_REFERENCE,LOC_CREFERENCE:
+            begin
+              cgpara.check_simple_location;
+              reference_reset_base(ref,cgpara.location^.reference.index,cgpara.location^.reference.offset,cgpara.alignment);
+              a_loadfpu_reg_ref(list,fromsize,cgpara.def,r,ref);
+            end;
+          LOC_REGISTER,LOC_CREGISTER:
+            begin
+              { paramfpu_ref does the check_simpe_location check here if necessary }
+              tg.gethltemp(list,fromsize,fromsize.size,tt_normal,ref);
+              a_loadfpu_reg_ref(list,fromsize,fromsize,r,ref);
+              a_loadfpu_ref_cgpara(list,fromsize,ref,cgpara);
+              tg.Ungettemp(list,ref);
+            end;
+          else
+            internalerror(2010120422);
+        end;
+      end;
+
+  procedure thlcgobj.a_loadfpu_ref_cgpara(list: TAsmList; fromsize: tdef; const ref: treference; const cgpara: TCGPara);
+    var
+       href : treference;
+//       hsize: tcgsize;
+    begin
+       case cgpara.location^.loc of
+        LOC_FPUREGISTER,LOC_CFPUREGISTER:
+          begin
+            cgpara.check_simple_location;
+            paramanager.alloccgpara(list,cgpara);
+            a_loadfpu_ref_reg(list,fromsize,cgpara.def,ref,cgpara.location^.register);
+          end;
+        LOC_REFERENCE,LOC_CREFERENCE:
+          begin
+            cgpara.check_simple_location;
+            reference_reset_base(href,cgpara.location^.reference.index,cgpara.location^.reference.offset,cgpara.alignment);
+            { concatcopy should choose the best way to copy the data }
+            g_concatcopy(list,fromsize,ref,href);
+          end;
+        (* not yet supported
+        LOC_REGISTER,LOC_CREGISTER:
+          begin
+            { force integer size }
+            hsize:=int_cgsize(tcgsize2size[size]);
+{$ifndef cpu64bitalu}
+            if (hsize in [OS_S64,OS_64]) then
+              cg64.a_load64_ref_cgpara(list,ref,cgpara)
+            else
+{$endif not cpu64bitalu}
+              begin
+                cgpara.check_simple_location;
+                a_load_ref_cgpara(list,hsize,ref,cgpara)
+              end;
+          end
+        *)
+        else
+          internalerror(2010120423);
+      end;
+    end;
+(*
+  procedure thlcgobj.a_loadmm_reg_reg(list: TAsmList; fromsize, tosize: tdef; reg1, reg2: tregister; shuffle: pmmshuffle);
+    begin
+      cg.a_loadmm_reg_reg(list,def_cgsize(fromsize),def_cgsize(tosize),reg1,reg2,shuffle);
+    end;
+
+  procedure thlcgobj.a_loadmm_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; reg: tregister; shuffle: pmmshuffle);
+    begin
+      cg.a_loadmm_ref_reg(list,def_cgsize(fromsize),def_cgsize(tosize),ref,reg,shuffle);
+    end;
+
+  procedure thlcgobj.a_loadmm_reg_ref(list: TAsmList; fromsize, tosize: tdef; reg: tregister; const ref: treference; shuffle: pmmshuffle);
+    begin
+      cg.a_loadmm_reg_ref(list,def_cgsize(fromsize),def_cgsize(tosize),reg,ref,shuffle);
+    end;
+
+  procedure thlcgobj.a_loadmm_loc_reg(list: TAsmList; fromsize, tosize: tdef; const loc: tlocation; const reg: tregister; shuffle: pmmshuffle);
+    begin
+      case loc.loc of
+        LOC_MMREGISTER,LOC_CMMREGISTER:
+          a_loadmm_reg_reg(list,fromsize,tosize,loc.register,reg,shuffle);
+        LOC_REFERENCE,LOC_CREFERENCE:
+          a_loadmm_ref_reg(list,fromsize,tosize,loc.reference,reg,shuffle);
+        LOC_REGISTER,LOC_CREGISTER:
+          a_loadmm_intreg_reg(list,fromsize,tosize,loc.register,reg,shuffle);
+        else
+          internalerror(2010120414);
+      end;
+    end;
+
+  procedure thlcgobj.a_loadmm_reg_loc(list: TAsmList; fromsize, tosize: tdef; const reg: tregister; const loc: tlocation; shuffle: pmmshuffle);
+    begin
+      case loc.loc of
+        LOC_MMREGISTER,LOC_CMMREGISTER:
+          a_loadmm_reg_reg(list,fromsize,tosize,reg,loc.register,shuffle);
+        LOC_REFERENCE,LOC_CREFERENCE:
+          a_loadmm_reg_ref(list,fromsize,tosize,reg,loc.reference,shuffle);
+        else
+          internalerror(2010120415);
+      end;
+    end;
+
+  procedure thlcgobj.a_loadmm_reg_cgpara(list: TAsmList; fromsize: tdef; reg: tregister; const cgpara: TCGPara; shuffle: pmmshuffle);
+    var
+      href  : treference;
+    begin
+       cgpara.check_simple_location;
+       paramanager.alloccgpara(list,cgpara);
+       case cgpara.location^.loc of
+        LOC_MMREGISTER,LOC_CMMREGISTER:
+          a_loadmm_reg_reg(list,fromsize,cgpara.def,reg,cgpara.location^.register,shuffle);
+        LOC_REFERENCE,LOC_CREFERENCE:
+          begin
+            reference_reset_base(href,cgpara.location^.reference.index,cgpara.location^.reference.offset,cgpara.alignment);
+            a_loadmm_reg_ref(list,fromsize,cgpara.def,reg,href,shuffle);
+          end;
+        LOC_REGISTER,LOC_CREGISTER:
+          begin
+            if assigned(shuffle) and
+               not shufflescalar(shuffle) then
+              internalerror(2009112510);
+             a_loadmm_reg_intreg(list,deomsize,cgpara.def,reg,cgpara.location^.register,mms_movescalar);
+          end
+        else
+          internalerror(2010120427);
+      end;
+    end;
+
+  procedure thlcgobj.a_loadmm_ref_cgpara(list: TAsmList; fromsize: tdef; const ref: treference; const cgpara: TCGPara; shuffle: pmmshuffle);
+    var
+       hr : tregister;
+       hs : tmmshuffle;
+    begin
+       cgpara.check_simple_location;
+       hr:=cg.getmmregister(list,cgpara.size);
+       a_loadmm_ref_reg(list,deomsize,cgpara.def,ref,hr,shuffle);
+       if realshuffle(shuffle) then
+         begin
+           hs:=shuffle^;
+           removeshuffles(hs);
+           a_loadmm_reg_cgpara(list,cgpara.def,hr,cgpara,@hs);
+         end
+       else
+         a_loadmm_reg_cgpara(list,cgpara.def,hr,cgpara,shuffle);
+    end;
+
+  procedure thlcgobj.a_loadmm_loc_cgpara(list: TAsmList; fromsize: tdef; const loc: tlocation; const cgpara: TCGPara; shuffle: pmmshuffle);
+    begin
+{$ifdef extdebug}
+      if def_cgsize(fromsize)<>loc.size then
+        internalerror(2010112105);
+{$endif}
+      cg.a_loadmm_loc_cgpara(list,loc,cgpara,shuffle);
+    end;
+
+  procedure thlcgobj.a_opmm_reg_reg(list: TAsmList; Op: TOpCG; size: tdef; src, dst: tregister; shuffle: pmmshuffle);
+    begin
+      cg.a_opmm_reg_reg(list,op,def_cgsize(size),src,dst,shuffle);
+    end;
+
+  procedure thlcgobj.a_opmm_ref_reg(list: TAsmList; Op: TOpCG; size: tdef; const ref: treference; reg: tregister; shuffle: pmmshuffle);
+    begin
+      cg.a_opmm_ref_reg(list,op,def_cgsize(size),ref,reg,shuffle)
+    end;
+
+  procedure thlcgobj.a_opmm_loc_reg(list: TAsmList; Op: TOpCG; size: tdef; const loc: tlocation; reg: tregister; shuffle: pmmshuffle);
+    begin
+      cg.a_opmm_loc_reg(list,op,def_cgsize(size),loc,reg,shuffle);
+    end;
+
+  procedure thlcgobj.a_opmm_reg_ref(list: TAsmList; Op: TOpCG; size: tdef; reg: tregister; const ref: treference; shuffle: pmmshuffle);
+    begin
+      cg.a_opmm_reg_ref(list,op,def_cgsize(size),reg,ref,shuffle);
+    end;
+*)
+(*
+  procedure thlcgobj.a_loadmm_intreg_reg(list: TAsmList; fromsize, tosize: tdef; intreg, mmreg: tregister; shuffle: pmmshuffle);
+    begin
+      cg.a_loadmm_intreg_reg(list,def_cgsize(fromsize),def_cgsize(tosize),intreg,mmreg,shuffle);
+    end;
+
+  procedure thlcgobj.a_loadmm_reg_intreg(list: TAsmList; fromsize, tosize: tdef; mmreg, intreg: tregister; shuffle: pmmshuffle);
+    begin
+      cg.a_loadmm_reg_intreg(list,def_cgsize(fromsize),def_cgsize(tosize),mmreg,intreg,shuffle);
+    end;
+*)
+  procedure thlcgobj.a_op_const_ref(list: TAsmList; Op: TOpCG; size: tdef; a: Aint; const ref: TReference);
+    var
+      tmpreg : tregister;
+    begin
+      tmpreg:=getintregister(list,size);
+      a_load_ref_reg(list,size,size,ref,tmpreg);
+      a_op_const_reg(list,op,size,a,tmpreg);
+      a_load_reg_ref(list,size,size,tmpreg,ref);
+    end;
+
+  procedure thlcgobj.a_op_const_subsetreg(list: TAsmList; Op: TOpCG; size, subsetsize: tdef; a: aint; const sreg: tsubsetregister);
+    var
+      tmpreg: tregister;
+    begin
+      tmpreg:=getintregister(list,size);
+      a_load_subsetreg_reg(list,size,subsetsize,size,sreg,tmpreg);
+      a_op_const_reg(list,op,size,a,tmpreg);
+      a_load_reg_subsetreg(list,size,size,subsetsize,tmpreg,sreg);
+    end;
+
+  procedure thlcgobj.a_op_const_subsetref(list: TAsmList; Op: TOpCG; size, subsetsize: tdef; a: aint; const sref: tsubsetreference);
+    var
+      tmpreg: tregister;
+    begin
+      tmpreg:=getintregister(list,size);
+      a_load_subsetref_reg(list,size,subsetsize,size,sref,tmpreg);
+      a_op_const_reg(list,op,size,a,tmpreg);
+      a_load_reg_subsetref(list,size,size,subsetsize,tmpreg,sref);
+    end;
+
+  procedure thlcgobj.a_op_const_loc(list: TAsmList; Op: TOpCG; size: tdef; a: Aint; const loc: tlocation);
+    begin
+      case loc.loc of
+        LOC_REGISTER, LOC_CREGISTER:
+          a_op_const_reg(list,op,size,a,loc.register);
+        LOC_REFERENCE, LOC_CREFERENCE:
+          a_op_const_ref(list,op,size,a,loc.reference);
+        { we don't have enough type information to handle these here
+        LOC_SUBSETREG, LOC_CSUBSETREG:
+          a_op_const_subsetreg(list,op,loc.size,loc.size,a,loc.sreg);
+        LOC_SUBSETREF, LOC_CSUBSETREF:
+          a_op_const_subsetref(list,op,loc.size,loc.size,a,loc.sref);
+        }
+        else
+          internalerror(2010120428);
+      end;
+    end;
+
+  procedure thlcgobj.a_op_reg_ref(list: TAsmList; Op: TOpCG; size: tdef; reg: TRegister; const ref: TReference);
+    var
+      tmpreg: tregister;
+    begin
+      tmpreg:=getintregister(list,size);
+      a_load_ref_reg(list,size,size,ref,tmpreg);
+      case op of
+        OP_NOT,OP_NEG:
+          begin
+            a_op_reg_reg(list,op,size,tmpreg,tmpreg);
+          end;
+        else
+          begin
+            a_op_reg_reg(list,op,size,reg,tmpreg);
+          end;
+      end;
+      a_load_reg_ref(list,size,size,tmpreg,ref);
+    end;
+
+  procedure thlcgobj.a_op_ref_reg(list: TAsmList; Op: TOpCG; size: tdef; const ref: TReference; reg: TRegister);
+      var
+        tmpreg: tregister;
+      begin
+        case op of
+          OP_NOT,OP_NEG:
+            { handle it as "load ref,reg; op reg" }
+            begin
+              a_load_ref_reg(list,size,size,ref,reg);
+              a_op_reg_reg(list,op,size,reg,reg);
+            end;
+          else
+            begin
+              tmpreg:=getintregister(list,size);
+              a_load_ref_reg(list,size,size,ref,tmpreg);
+              a_op_reg_reg(list,op,size,tmpreg,reg);
+            end;
+        end;
+      end;
+
+  procedure thlcgobj.a_op_reg_subsetreg(list: TAsmList; Op: TOpCG; opsize, destsize, destsubsetsize: tdef; reg: TRegister; const sreg: tsubsetregister);
+    var
+      tmpreg: tregister;
+    begin
+      tmpreg:=getintregister(list,opsize);
+      a_load_subsetreg_reg(list,destsize,destsubsetsize,opsize,sreg,tmpreg);
+      a_op_reg_reg(list,op,opsize,reg,tmpreg);
+      a_load_reg_subsetreg(list,opsize,destsize,destsubsetsize,tmpreg,sreg);
+    end;
+
+  procedure thlcgobj.a_op_reg_subsetref(list: TAsmList; Op: TOpCG; opsize, destsize, destsubsetsize: tdef; reg: TRegister; const sref: tsubsetreference);
+    var
+      tmpreg: tregister;
+    begin
+      tmpreg:=getintregister(list,opsize);
+      a_load_subsetref_reg(list,destsize,destsubsetsize,opsize,sref,tmpreg);
+      a_op_reg_reg(list,op,opsize,reg,tmpreg);
+      a_load_reg_subsetref(list,opsize,destsize,destsubsetsize,tmpreg,sref);
+    end;
+
+  procedure thlcgobj.a_op_reg_loc(list: TAsmList; Op: TOpCG; size: tdef; reg: tregister; const loc: tlocation);
+    begin
+      case loc.loc of
+        LOC_REGISTER, LOC_CREGISTER:
+          a_op_reg_reg(list,op,size,reg,loc.register);
+        LOC_REFERENCE, LOC_CREFERENCE:
+          a_op_reg_ref(list,op,size,reg,loc.reference);
+        { we don't have enough type information to handle these here
+        LOC_SUBSETREG, LOC_CSUBSETREG:
+          a_op_reg_subsetreg(list,op,loc.size,loc.size,reg,loc.sreg);
+        LOC_SUBSETREF, LOC_CSUBSETREF:
+          a_op_reg_subsetref(list,op,loc.size,loc.size,reg,loc.sref);
+        }
+        else
+          internalerror(2010120429);
+      end;
+    end;
+
+  procedure thlcgobj.a_op_ref_loc(list: TAsmList; Op: TOpCG; size: tdef; const ref: TReference; const loc: tlocation);
+    var
+      tmpreg: tregister;
+    begin
+      case loc.loc of
+        LOC_REGISTER,LOC_CREGISTER:
+          a_op_ref_reg(list,op,size,ref,loc.register);
+        LOC_REFERENCE,LOC_CREFERENCE:
+          begin
+            tmpreg:=getintregister(list,size);
+            a_load_ref_reg(list,size,size,ref,tmpreg);
+            a_op_reg_ref(list,op,size,tmpreg,loc.reference);
+          end;
+        { we don't have enough type information to handle these here
+        LOC_SUBSETREG, LOC_CSUBSETREG:
+          begin
+            tmpreg:=getintregister(list,loc.size);
+            a_load_subsetreg_reg(list,loc.size,loc.size,loc.sreg,tmpreg);
+            a_op_ref_reg(list,op,loc.size,ref,tmpreg);
+            a_load_reg_subsetreg(list,loc.size,loc.size,tmpreg,loc.sreg);
+          end;
+        LOC_SUBSETREF, LOC_CSUBSETREF:
+          begin
+            tmpreg:=getintregister(list,loc.size);
+            a_load_subsetreF_reg(list,loc.size,loc.size,loc.sref,tmpreg);
+            a_op_ref_reg(list,op,loc.size,ref,tmpreg);
+            a_load_reg_subsetref(list,loc.size,loc.size,tmpreg,loc.sref);
+          end;
+          }
+        else
+          internalerror(2010120429);
+      end;
+    end;
+
+  procedure thlcgobj.a_op_const_reg_reg(list: TAsmList; op: TOpCg; size: tdef; a: aint; src, dst: tregister);
+    begin
+      a_load_reg_reg(list,size,size,src,dst);
+      a_op_const_reg(list,op,size,a,dst);
+    end;
+
+  procedure thlcgobj.a_op_reg_reg_reg(list: TAsmList; op: TOpCg; size: tdef; src1, src2, dst: tregister);
+    var
+      tmpreg: tregister;
+    begin
+      if (dst<>src1) then
+        begin
+          a_load_reg_reg(list,size,size,src2,dst);
+          a_op_reg_reg(list,op,size,src1,dst);
+        end
+      else
+        begin
+          { can we do a direct operation on the target register ? }
+          if op in [OP_ADD,OP_MUL,OP_AND,OP_MOVE,OP_XOR,OP_IMUL,OP_OR] then
+            a_op_reg_reg(list,op,size,src2,dst)
+          else
+            begin
+              tmpreg:=getintregister(list,size);
+              a_load_reg_reg(list,size,size,src2,tmpreg);
+              a_op_reg_reg(list,op,size,src1,tmpreg);
+              a_load_reg_reg(list,size,size,tmpreg,dst);
+            end;
+        end;
+    end;
+
+  procedure thlcgobj.a_op_const_reg_reg_checkoverflow(list: TAsmList; op: TOpCg; size: tdef; a: aint; src, dst: tregister; setflags: boolean; var ovloc: tlocation);
+    begin
+      if not setflags then
+        a_op_const_reg_reg(list,op,size,a,src,dst)
+      else
+        internalerror(2010122910);
+    end;
+
+  procedure thlcgobj.a_op_reg_reg_reg_checkoverflow(list: TAsmList; op: TOpCg; size: tdef; src1, src2, dst: tregister; setflags: boolean; var ovloc: tlocation);
+    begin
+      if not setflags then
+        a_op_reg_reg_reg(list,op,size,src1,src2,dst)
+      else
+        internalerror(2010122911);
+    end;
+
+  procedure thlcgobj.a_cmp_const_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; a: aint; reg: tregister; l: tasmlabel);
+    var
+      tmpreg: tregister;
+    begin
+      tmpreg:=getintregister(list,size);
+      a_load_const_reg(list,size,a,tmpreg);
+      a_cmp_reg_reg_label(list,size,cmp_op,tmpreg,reg,l);
+    end;
+
+  procedure thlcgobj.a_cmp_const_ref_label(list: TAsmList; size: tdef; cmp_op: topcmp; a: aint; const ref: treference; l: tasmlabel);
+    var
+      tmpreg: tregister;
+    begin
+      tmpreg:=getintregister(list,size);
+      a_load_ref_reg(list,size,size,ref,tmpreg);
+      a_cmp_const_reg_label(list,size,cmp_op,a,tmpreg,l);
+    end;
+
+  procedure thlcgobj.a_cmp_const_loc_label(list: TAsmList; size: tdef; cmp_op: topcmp; a: aint; const loc: tlocation; l: tasmlabel);
+    begin
+      case loc.loc of
+        LOC_REGISTER,LOC_CREGISTER:
+          a_cmp_const_reg_label(list,size,cmp_op,a,loc.register,l);
+        LOC_REFERENCE,LOC_CREFERENCE:
+          a_cmp_const_ref_label(list,size,cmp_op,a,loc.reference,l);
+        { we don't have enough type information to handle these here
+        LOC_SUBSETREG, LOC_CSUBSETREG:
+          begin
+            tmpreg:=getintregister(list,size);
+            a_load_subsetreg_reg(list,loc.size,size,loc.sreg,tmpreg);
+            a_cmp_const_reg_label(list,size,cmp_op,a,tmpreg,l);
+          end;
+        LOC_SUBSETREF, LOC_CSUBSETREF:
+          begin
+            tmpreg:=getintregister(list,size);
+            a_load_subsetref_reg(list,loc.size,size,loc.sref,tmpreg);
+            a_cmp_const_reg_label(list,size,cmp_op,a,tmpreg,l);
+          end;
+        }
+        else
+          internalerror(2010120430);
+      end;
+    end;
+
+  procedure thlcgobj.a_cmp_ref_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; const ref: treference; reg: tregister; l: tasmlabel);
+    var
+      tmpreg: tregister;
+    begin
+      tmpreg:=getintregister(list,size);
+      a_load_ref_reg(list,size,size,ref,tmpreg);
+      a_cmp_reg_reg_label(list,size,cmp_op,tmpreg,reg,l);
+    end;
+
+  procedure thlcgobj.a_cmp_reg_ref_label(list: TAsmList; size: tdef; cmp_op: topcmp; reg: tregister; const ref: treference; l: tasmlabel);
+    var
+      tmpreg: tregister;
+    begin
+      tmpreg:=getintregister(list,size);
+      a_load_ref_reg(list,size,size,ref,tmpreg);
+      a_cmp_reg_reg_label(list,size,cmp_op,reg,tmpreg,l);
+    end;
+
+  procedure thlcgobj.a_cmp_subsetreg_reg_label(list: TAsmList; fromsize, fromsubsetsize, cmpsize: tdef; cmp_op: topcmp; const sreg: tsubsetregister; reg: tregister; l: tasmlabel);
+    var
+      tmpreg: tregister;
+    begin
+      tmpreg:=getintregister(list,cmpsize);
+      a_load_subsetreg_reg(list,fromsize,fromsubsetsize,cmpsize,sreg,tmpreg);
+      a_cmp_reg_reg_label(list,cmpsize,cmp_op,tmpreg,reg,l);
+    end;
+
+  procedure thlcgobj.a_cmp_subsetref_reg_label(list: TAsmList; fromsize, fromsubsetsize, cmpsize: tdef; cmp_op: topcmp; const sref: tsubsetreference; reg: tregister; l: tasmlabel);
+    var
+      tmpreg: tregister;
+    begin
+      tmpreg:=getintregister(list,cmpsize);
+      a_load_subsetref_reg(list,fromsize,fromsubsetsize,cmpsize,sref,tmpreg);
+      a_cmp_reg_reg_label(list,cmpsize,cmp_op,tmpreg,reg,l);
+    end;
+
+  procedure thlcgobj.a_cmp_loc_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; const loc: tlocation; reg: tregister; l: tasmlabel);
+    begin
+      case loc.loc of
+        LOC_REGISTER,
+        LOC_CREGISTER:
+          a_cmp_reg_reg_label(list,size,cmp_op,loc.register,reg,l);
+        LOC_REFERENCE,
+        LOC_CREFERENCE :
+          a_cmp_ref_reg_label(list,size,cmp_op,loc.reference,reg,l);
+        LOC_CONSTANT:
+          a_cmp_const_reg_label(list,size,cmp_op,loc.value,reg,l);
+        { we don't have enough type information to handle these here
+        LOC_SUBSETREG,
+        LOC_CSUBSETREG:
+          a_cmp_subsetreg_reg_label(list,loc.size,size,cmp_op,loc.sreg,reg,l);
+        LOC_SUBSETREF,
+        LOC_CSUBSETREF:
+          a_cmp_subsetref_reg_label(list,loc.size,size,cmp_op,loc.sref,reg,l);
+        }
+        else
+          internalerror(2010120431);
+      end;
+    end;
+
+  procedure thlcgobj.a_cmp_reg_loc_label(list: TAsmList; size: tdef; cmp_op: topcmp; reg: tregister; const loc: tlocation; l: tasmlabel);
+    begin
+      a_cmp_loc_reg_label(list,size,swap_opcmp(cmp_op),loc,reg,l);
+    end;
+
+  procedure thlcgobj.a_cmp_ref_loc_label(list: TAsmList; size: tdef; cmp_op: topcmp; const ref: treference; const loc: tlocation; l: tasmlabel);
+    var
+      tmpreg: tregister;
+    begin
+      case loc.loc of
+        LOC_REGISTER,LOC_CREGISTER:
+          a_cmp_ref_reg_label(list,size,cmp_op,ref,loc.register,l);
+        LOC_REFERENCE,LOC_CREFERENCE:
+          begin
+            tmpreg:=getintregister(list,size);
+            a_load_ref_reg(list,size,size,loc.reference,tmpreg);
+            a_cmp_ref_reg_label(list,size,cmp_op,ref,tmpreg,l);
+          end;
+        LOC_CONSTANT:
+          begin
+            a_cmp_const_ref_label(list,size,swap_opcmp(cmp_op),loc.value,ref,l);
+          end
+        { we don't have enough type information to handle these here
+        LOC_SUBSETREG, LOC_CSUBSETREG:
+          begin
+            tmpreg:=getintregister(list, size);
+            a_load_ref_reg(list,size,size,loc.reference,tmpreg);
+            a_cmp_subsetreg_reg_label(list,loc.size,size,swap_opcmp(cmp_op),loc.sreg,tmpreg,l);
+          end;
+        LOC_SUBSETREF, LOC_CSUBSETREF:
+          begin
+            tmpreg:=getintregister(list, size);
+            a_load_ref_reg(list,size,size,loc.reference,tmpreg);
+            a_cmp_subsetref_reg_label(list,loc.size,size,swap_opcmp(cmp_op),loc.sref,tmpreg,l);
+          end;
+        }
+        else
+          internalerror(2010120432);
+      end;
+    end;
+
+  procedure thlcgobj.g_concatcopy(list: TAsmList; size: tdef; const source, dest: treference);
+    begin
+{
+      if use_vectorfpu(size) then
+        a_loadmm_ref_ref()
+      else
+ }
+      if size.typ<>floatdef then
+        a_load_ref_ref(list,size,size,source,dest)
+      else
+        a_loadfpu_ref_ref(list,size,size,source,dest);
+    end;
+
+  procedure thlcgobj.g_concatcopy_unaligned(list: TAsmList; size: tdef; const source, dest: treference);
+    begin
+      g_concatcopy(list,size,source,dest);
+    end;
+
+  procedure thlcgobj.g_rangecheck(list: TAsmList; const l: tlocation; fromdef, todef: tdef);
+    var
+{$if defined(cpu64bitalu) or defined(cpu32bitalu)}
+      aintmax: aint;
+{$else}
+      aintmax: longint;
+{$endif}
+      neglabel : tasmlabel;
+      hreg : tregister;
+      lto,hto,
+      lfrom,hfrom : TConstExprInt;
+      fromsize, tosize: cardinal;
+      maxdef: tdef;
+      from_signed, to_signed: boolean;
+    begin
+      { range checking on and range checkable value? }
+      if not(cs_check_range in current_settings.localswitches) or
+         not(fromdef.typ in [orddef,enumdef]) or
+         { C-style booleans can't really fail range checks, }
+         { all values are always valid                      }
+         is_cbool(todef) then
+        exit;
+      { only check when assigning to scalar, subranges are different, }
+      { when todef=fromdef then the check is always generated         }
+      getrange(fromdef,lfrom,hfrom);
+      getrange(todef,lto,hto);
+      from_signed := is_signed(fromdef);
+      to_signed := is_signed(todef);
+      { check the rangedef of the array, not the array itself }
+      { (only change now, since getrange needs the arraydef)   }
+      if (todef.typ = arraydef) then
+        todef := tarraydef(todef).rangedef;
+      { no range check if from and to are equal and are both longint/dword }
+      { (if we have a 32bit processor) or int64/qword, since such          }
+      { operations can at most cause overflows (JM)                        }
+      { Note that these checks are mostly processor independent, they only }
+      { have to be changed once we introduce 64bit subrange types          }
+      if (fromdef = todef) and
+         (fromdef.typ=orddef) and
+         (((((torddef(fromdef).ordtype = s64bit) and
+             (lfrom = low(int64)) and
+             (hfrom = high(int64))) or
+            ((torddef(fromdef).ordtype = u64bit) and
+             (lfrom = low(qword)) and
+             (hfrom = high(qword))) or
+            ((torddef(fromdef).ordtype = scurrency) and
+             (lfrom = low(int64)) and
+             (hfrom = high(int64)))))) then
+        exit;
+      { 32 bit operations are automatically widened to 64 bit on 64 bit addr
+        targets }
+{$ifdef cpu32bitaddr}
+      if (fromdef = todef) and
+         (fromdef.typ=orddef) and
+         (((((torddef(fromdef).ordtype = s32bit) and
+             (lfrom = int64(low(longint))) and
+             (hfrom = int64(high(longint)))) or
+            ((torddef(fromdef).ordtype = u32bit) and
+             (lfrom = low(cardinal)) and
+             (hfrom = high(cardinal)))))) then
+        exit;
+{$endif cpu32bitaddr}
+
+      { optimize some range checks away in safe cases }
+      fromsize := fromdef.size;
+      tosize := todef.size;
+      if ((from_signed = to_signed) or
+          (not from_signed)) and
+         (lto<=lfrom) and (hto>=hfrom) and
+         (fromsize <= tosize) then
+        begin
+          { if fromsize < tosize, and both have the same signed-ness or }
+          { fromdef is unsigned, then all bit patterns from fromdef are }
+          { valid for todef as well                                     }
+          if (fromsize < tosize) then
+            exit;
+          if (fromsize = tosize) and
+             (from_signed = to_signed) then
+            { only optimize away if all bit patterns which fit in fromsize }
+            { are valid for the todef                                      }
+            begin
+{$ifopt Q+}
+{$define overflowon}
+{$Q-}
+{$endif}
+{$ifopt R+}
+{$define rangeon}
+{$R-}
+{$endif}
+              if to_signed then
+                begin
+                  { calculation of the low/high ranges must not overflow 64 bit
+                   otherwise we end up comparing with zero for 64 bit data types on
+                   64 bit processors }
+                  if (lto = (int64(-1) << (tosize * 8 - 1))) and
+                     (hto = (-((int64(-1) << (tosize * 8 - 1))+1))) then
+                    exit
+                end
+              else
+                begin
+                  { calculation of the low/high ranges must not overflow 64 bit
+                   otherwise we end up having all zeros for 64 bit data types on
+                   64 bit processors }
+                  if (lto = 0) and
+                     (qword(hto) = (qword(-1) >> (64-(tosize * 8))) ) then
+                    exit
+                end;
+{$ifdef overflowon}
+{$Q+}
+{$undef overflowon}
+{$endif}
+{$ifdef rangeon}
+{$R+}
+{$undef rangeon}
+{$endif}
+            end
+        end;
+
+      { depending on the types involved, we perform the range check for 64 or
+        for 32 bit }
+      if fromsize=8 then
+        maxdef:=fromdef
+      else
+        maxdef:=todef;
+{$if sizeof(aintmax) = 8}
+      if maxdef.size=8 then
+        aintmax:=high(int64)
+      else
+{$endif}
+        begin
+          aintmax:=high(longint);
+          maxdef:=u32inttype;
+        end;
+
+      { generate the rangecheck code for the def where we are going to }
+      { store the result                                               }
+
+      { use the trick that                                                 }
+      { a <= x <= b <=> 0 <= x-a <= b-a <=> unsigned(x-a) <= unsigned(b-a) }
+
+      { To be able to do that, we have to make sure however that either    }
+      { fromdef and todef are both signed or unsigned, or that we leave    }
+      { the parts < 0 and > maxlongint out                                 }
+
+      if from_signed xor to_signed then
+        begin
+           if from_signed then
+             { from is signed, to is unsigned }
+             begin
+               { if high(from) < 0 -> always range error }
+               if (hfrom < 0) or
+                  { if low(to) > maxlongint also range error }
+                  (lto > aintmax) then
+                 begin
+                   g_call_system_proc(list,'fpc_rangeerror');
+                   exit
+                 end;
+               { from is signed and to is unsigned -> when looking at to }
+               { as an signed value, it must be < maxaint (otherwise     }
+               { it will become negative, which is invalid since "to" is unsigned) }
+               if hto > aintmax then
+                 hto := aintmax;
+             end
+           else
+             { from is unsigned, to is signed }
+             begin
+               if (lfrom > aintmax) or
+                  (hto < 0) then
+                 begin
+                   g_call_system_proc(list,'fpc_rangeerror');
+                   exit
+                 end;
+               { from is unsigned and to is signed -> when looking at to }
+               { as an unsigned value, it must be >= 0 (since negative   }
+               { values are the same as values > maxlongint)             }
+               if lto < 0 then
+                 lto := 0;
+             end;
+        end;
+      hreg:=getintregister(list,maxdef);
+      a_load_loc_reg(list,fromdef,maxdef,l,hreg);
+      a_op_const_reg(list,OP_SUB,maxdef,tcgint(int64(lto)),hreg);
+      current_asmdata.getjumplabel(neglabel);
+      {
+      if from_signed then
+        a_cmp_const_reg_label(list,OS_INT,OC_GTE,aint(hto-lto),hreg,neglabel)
+      else
+      }
+      if qword(hto-lto)>qword(aintmax) then
+        a_cmp_const_reg_label(list,maxdef,OC_BE,aintmax,hreg,neglabel)
+      else
+        a_cmp_const_reg_label(list,maxdef,OC_BE,tcgint(int64(hto-lto)),hreg,neglabel);
+      g_call_system_proc(list,'fpc_rangeerror');
+      a_label(list,neglabel);
+    end;
+
+  procedure thlcgobj.g_profilecode(list: TAsmList);
+    begin
+    end;
+
+  procedure thlcgobj.g_allocload_reg_reg(list: TAsmList; regsize: tdef; const fromreg: tregister; out toreg: tregister; regtyp: tregistertype);
+    begin
+      case regtyp of
+        R_INTREGISTER:
+          toreg:=getintregister(list,regsize);
+        R_ADDRESSREGISTER:
+          toreg:=getaddressregister(list,regsize);
+        R_FPUREGISTER:
+          toreg:=getfpuregister(list,regsize);
+      end;
+      a_load_reg_reg(list,regsize,regsize,fromreg,toreg);
+    end;
+
+  procedure thlcgobj.g_reference_loc(list: TAsmList; def: tdef; const fromloc: tlocation; out toloc: tlocation);
+
+    procedure handle_reg_move(regsize: tdef; const fromreg: tregister; out toreg: tregister; regtyp: tregistertype);
+      begin
+        case regtyp of
+          R_INTREGISTER:
+            toreg:=getintregister(list,regsize);
+          R_ADDRESSREGISTER:
+            toreg:=getaddressregister(list,regsize);
+          R_FPUREGISTER:
+            toreg:=getfpuregister(list,regsize);
+        end;
+        a_load_reg_reg(list,regsize,regsize,fromreg,toreg);
+      end;
+
+    begin
+      toloc:=fromloc;
+      case fromloc.loc of
+        { volatile location, can't get a permanent reference }
+        LOC_REGISTER,
+        LOC_FPUREGISTER:
+          internalerror(2012012702);
+        LOC_CONSTANT:
+          { finished }
+          ;
+        LOC_CREGISTER:
+          handle_reg_move(def,fromloc.reference.index,toloc.reference.index,R_INTREGISTER);
+        LOC_CFPUREGISTER:
+          handle_reg_move(def,fromloc.reference.index,toloc.reference.index,R_FPUREGISTER);
+        { although LOC_CREFERENCE cannot be an lvalue, we may want to take a
+          reference to such a location for multiple reading }
+        LOC_CREFERENCE,
+        LOC_REFERENCE:
+          begin
+            if (fromloc.reference.base<>NR_NO) and
+               (fromloc.reference.base<>current_procinfo.framepointer) and
+               (fromloc.reference.base<>NR_STACK_POINTER_REG) then
+              handle_reg_move(voidpointertype,fromloc.reference.base,toloc.reference.base,getregtype(fromloc.reference.base));
+            if (fromloc.reference.index<>NR_NO) and
+               (fromloc.reference.index<>current_procinfo.framepointer) and
+               (fromloc.reference.index<>NR_STACK_POINTER_REG) then
+              handle_reg_move(voidpointertype,fromloc.reference.index,toloc.reference.index,getregtype(fromloc.reference.index));
+          end;
+        else
+          internalerror(2012012701);
+      end;
+    end;
+
+  procedure thlcgobj.location_force_reg(list: TAsmList; var l: tlocation; src_size, dst_size: tdef; maybeconst: boolean);
+    var
+      hregister,
+      hregister2: tregister;
+      hl : tasmlabel;
+      oldloc : tlocation;
+    begin
+      oldloc:=l;
+      hregister:=getregisterfordef(list,dst_size);
+      { load value in new register }
+      case l.loc of
+{$ifdef cpuflags}
+        LOC_FLAGS :
+          g_flags2reg(list,dst_size,l.resflags,hregister);
+{$endif cpuflags}
+        LOC_JUMP :
+          begin
+            a_label(list,current_procinfo.CurrTrueLabel);
+            a_load_const_reg(list,dst_size,1,hregister);
+            current_asmdata.getjumplabel(hl);
+            a_jmp_always(list,hl);
+            a_label(list,current_procinfo.CurrFalseLabel);
+            a_load_const_reg(list,dst_size,0,hregister);
+            a_label(list,hl);
+          end;
+        else
+          begin
+            { load_loc_reg can only handle size >= l.size, when the
+              new size is smaller then we need to adjust the size
+              of the orignal and maybe recalculate l.register for i386 }
+            if (dst_size.size<src_size.size) then
+              begin
+                hregister2:=getregisterfordef(list,src_size);
+                { prevent problems with memory locations -- at this high
+                  level we cannot twiddle with the reference offset, since
+                  that may not mean anything (e.g., it refers to fixed-sized
+                  stack slots on Java) }
+                a_load_loc_reg(list,src_size,src_size,l,hregister2);
+                a_load_reg_reg(list,src_size,dst_size,hregister2,hregister);
+              end
+            else
+              a_load_loc_reg(list,src_size,dst_size,l,hregister);
+          end;
+      end;
+      if (l.loc <> LOC_CREGISTER) or
+         not maybeconst then
+        location_reset(l,LOC_REGISTER,def_cgsize(dst_size))
+      else
+        location_reset(l,LOC_CREGISTER,def_cgsize(dst_size));
+      l.register:=hregister;
+      { Release temp if it was a reference }
+      if oldloc.loc=LOC_REFERENCE then
+        location_freetemp(list,oldloc);
+    end;
+
+  procedure thlcgobj.location_force_fpureg(list: TAsmList; var l: tlocation; size: tdef; maybeconst: boolean);
+    var
+      reg : tregister;
+    begin
+      if (l.loc<>LOC_FPUREGISTER)  and
+         ((l.loc<>LOC_CFPUREGISTER) or (not maybeconst)) then
+        begin
+          { if it's in an mm register, store to memory first }
+          if (l.loc in [LOC_MMREGISTER,LOC_CMMREGISTER]) then
+            internalerror(2011012903);
+          reg:=getfpuregister(list,size);
+          a_loadfpu_loc_reg(list,size,size,l,reg);
+          location_freetemp(list,l);
+          location_reset(l,LOC_FPUREGISTER,l.size);
+          l.register:=reg;
+        end;
+    end;
+
+  procedure thlcgobj.location_force_mem(list: TAsmList; var l: tlocation; size: tdef);
+    var
+      r : treference;
+      forcesize: aint;
+    begin
+      case l.loc of
+        LOC_FPUREGISTER,
+        LOC_CFPUREGISTER :
+          begin
+            tg.gethltemp(list,size,size.size,tt_normal,r);
+            a_loadfpu_reg_ref(list,size,size,l.register,r);
+            location_reset_ref(l,LOC_REFERENCE,l.size,0);
+            l.reference:=r;
+          end;
+(*
+        LOC_MMREGISTER,
+        LOC_CMMREGISTER:
+          begin
+            tg.gethltemp(list,size,size.size,tt_normal,r);
+            cg.a_loadmm_reg_ref(list,l.size,l.size,l.register,r,mms_movescalar);
+            location_reset_ref(l,LOC_REFERENCE,l.size,0);
+            l.reference:=r;
+          end;
+*)
+        LOC_CONSTANT,
+        LOC_REGISTER,
+        LOC_CREGISTER :
+          begin
+            if not is_dynamic_array(size) and
+               not is_open_array(size) then
+              forcesize:=size.size
+            else
+              forcesize:=voidpointertype.size;
+            tg.gethltemp(list,size,forcesize,tt_normal,r);
+            a_load_loc_ref(list,size,size,l,r);
+            location_reset_ref(l,LOC_REFERENCE,l.size,0);
+            l.reference:=r;
+          end;
+(*
+        LOC_SUBSETREG,
+        LOC_CSUBSETREG,
+        LOC_SUBSETREF,
+        LOC_CSUBSETREF:
+          begin
+            tg.gethltemp(list,size,size.size,tt_normal,r);
+            cg.a_load_loc_ref(list,l.size,l,r);
+            location_reset_ref(l,LOC_REFERENCE,l.size,0);
+            l.reference:=r;
+          end;
+*)
+        LOC_CREFERENCE,
+        LOC_REFERENCE : ;
+        else
+          internalerror(2011010304);
+      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,getaddressregister(list,voidpointertype),0,alignment);
+                  { it's a pointer to def }
+                  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
+
+    depending on whether the loading of regvars is currently being
+    synchronized manually (such as in an if-node) or automatically (most of
+    the other cases where this procedure is called), loadregvars can be
+    "lr_load_regvars" or "lr_dont_load_regvars"
+  }
+    var
+      storepos : tfileposinfo;
+    begin
+       if nf_error in p.flags then
+         exit;
+       storepos:=current_filepos;
+       current_filepos:=p.fileinfo;
+       if is_boolean(p.resultdef) then
+         begin
+            if is_constboolnode(p) then
+              begin
+                 if Tordconstnode(p).value.uvalue<>0 then
+                   a_jmp_always(list,current_procinfo.CurrTrueLabel)
+                 else
+                   a_jmp_always(list,current_procinfo.CurrFalseLabel)
+              end
+            else
+              begin
+                 case p.location.loc of
+(*
+                   LOC_SUBSETREG,LOC_CSUBSETREG,
+                   LOC_SUBSETREF,LOC_CSUBSETREF:
+                     begin
+                       tmpreg := cg.getintregister(list,OS_INT);
+                       cg.a_load_loc_reg(list,OS_INT,p.location,tmpreg);
+                       cg.a_cmp_const_reg_label(list,OS_INT,OC_NE,0,tmpreg,current_procinfo.CurrTrueLabel);
+                       cg.a_jmp_always(list,current_procinfo.CurrFalseLabel);
+                     end;
+*)
+                   LOC_CREGISTER,LOC_REGISTER,LOC_CREFERENCE,LOC_REFERENCE :
+                     begin
+                       a_cmp_const_loc_label(list,p.resultdef,OC_NE,0,p.location,current_procinfo.CurrTrueLabel);
+                       a_jmp_always(list,current_procinfo.CurrFalseLabel);
+                     end;
+                   LOC_JUMP:
+                     ;
+{$ifdef cpuflags}
+                   LOC_FLAGS :
+                     begin
+                       a_jmp_flags(list,p.location.resflags,current_procinfo.CurrTrueLabel);
+                       a_jmp_always(list,current_procinfo.CurrFalseLabel);
+                     end;
+{$endif cpuflags}
+                   else
+                     begin
+                       printnode(output,p);
+                       internalerror(2011010418);
+                     end;
+                 end;
+              end;
+         end
+       else
+         internalerror(2011010419);
+       current_filepos:=storepos;
+    end;
+
+  procedure thlcgobj.gen_proc_symbol(list: TAsmList);
+    var
+      item,
+      previtem : TCmdStrListItem;
+    begin
+      previtem:=nil;
+      item := TCmdStrListItem(current_procinfo.procdef.aliasnames.first);
+      while assigned(item) do
+        begin
+{$ifdef arm}
+          if current_settings.cputype in cpu_thumb2 then
+            list.concat(tai_thumb_func.create);
+{$endif arm}
+          { "double link" all procedure entry symbols via .reference }
+          { directives on darwin, because otherwise the linker       }
+          { sometimes strips the procedure if only on of the symbols }
+          { is referenced                                            }
+          if assigned(previtem) and
+             (target_info.system in systems_darwin) then
+            list.concat(tai_directive.create(asd_reference,item.str));
+          if (cs_profile in current_settings.moduleswitches) or
+            (po_global in current_procinfo.procdef.procoptions) then
+            list.concat(Tai_symbol.createname_global(item.str,AT_FUNCTION,0))
+          else
+            list.concat(Tai_symbol.createname(item.str,AT_FUNCTION,0));
+          if assigned(previtem) and
+             (target_info.system in systems_darwin) then
+            list.concat(tai_directive.create(asd_reference,previtem.str));
+          if not(af_stabs_use_function_absolute_addresses in target_asm.flags) then
+            list.concat(Tai_function_name.create(item.str));
+          previtem:=item;
+          item := TCmdStrListItem(item.next);
+        end;
+      current_procinfo.procdef.procstarttai:=tai(list.last);
+    end;
+
+  procedure thlcgobj.gen_proc_symbol_end(list: TAsmList);
+    begin
+      list.concat(Tai_symbol_end.Createname(current_procinfo.procdef.mangledname));
+
+      current_procinfo.procdef.procendtai:=tai(list.last);
+
+      if (current_module.islibrary) then
+        if (current_procinfo.procdef.proctypeoption = potype_proginit) then
+          { setinitname may generate a new section -> don't add to the
+            current list, because we assume this remains a text section }
+          exportlib.setinitname(current_asmdata.AsmLists[al_exports],current_procinfo.procdef.mangledname);
+
+      if (current_procinfo.procdef.proctypeoption=potype_proginit) then
+        begin
+         if (target_info.system in (systems_darwin+[system_powerpc_macos])) and
+            not(current_module.islibrary) then
+           begin
+            new_section(list,sec_code,'',4);
+            list.concat(tai_symbol.createname_global(
+              target_info.cprefix+mainaliasname,AT_FUNCTION,0));
+            { keep argc, argv and envp properly on the stack }
+            cg.a_jmp_name(list,target_info.cprefix+'FPC_SYSTEMMAIN');
+           end;
+        end;
+    end;
+
+  procedure thlcgobj.gen_initialize_code(list: TAsmList);
+    begin
+      { initialize local data like ansistrings }
+      case current_procinfo.procdef.proctypeoption of
+         potype_unitinit:
+           begin
+              { this is also used for initialization of variables in a
+                program which does not have a globalsymtable }
+              if assigned(current_module.globalsymtable) then
+                TSymtable(current_module.globalsymtable).SymList.ForEachCall(@initialize_data,list);
+              TSymtable(current_module.localsymtable).SymList.ForEachCall(@initialize_data,list);
+              TSymtable(current_module.localsymtable).SymList.ForEachCall(@initialize_regvars,list);
+           end;
+         { units have seperate code for initilization and finalization }
+         potype_unitfinalize: ;
+         { program init/final is generated in separate procedure }
+         potype_proginit:
+           begin
+             TSymtable(current_module.localsymtable).SymList.ForEachCall(@initialize_regvars,list);
+           end;
+         else
+           current_procinfo.procdef.localst.SymList.ForEachCall(@initialize_data,list);
+      end;
+
+      { initialises temp. ansi/wide string data }
+      if (current_procinfo.procdef.proctypeoption<>potype_exceptfilter) then
+        inittempvariables(list);
+
+{$ifdef OLDREGVARS}
+      load_regvars(list,nil);
+{$endif OLDREGVARS}
+    end;
+
+  procedure thlcgobj.gen_finalize_code(list: TAsmList);
+    var
+      old_current_procinfo: tprocinfo;
+    begin
+      old_current_procinfo:=current_procinfo;
+      if (current_procinfo.procdef.proctypeoption=potype_exceptfilter) then
+        begin
+          if (current_procinfo.parent.finalize_procinfo<>current_procinfo) then
+            exit;
+          current_procinfo:=current_procinfo.parent;
+        end;
+
+{$ifdef OLDREGVARS}
+      cleanup_regvars(list);
+{$endif OLDREGVARS}
+
+      { finalize temporary data }
+      finalizetempvariables(list);
+
+      { finalize local data like ansistrings}
+      case current_procinfo.procdef.proctypeoption of
+         potype_unitfinalize:
+           begin
+              { this is also used for initialization of variables in a
+                program which does not have a globalsymtable }
+              if assigned(current_module.globalsymtable) then
+                TSymtable(current_module.globalsymtable).SymList.ForEachCall(@finalize_static_data,list);
+              TSymtable(current_module.localsymtable).SymList.ForEachCall(@finalize_static_data,list);
+           end;
+         { units/progs have separate code for initialization and finalization }
+         potype_unitinit: ;
+         { program init/final is generated in separate procedure }
+         potype_proginit: ;
+         else
+           current_procinfo.procdef.localst.SymList.ForEachCall(@finalize_local_vars,list);
+      end;
+
+      { finalize paras data }
+      if assigned(current_procinfo.procdef.parast) and
+         not(po_assembler in current_procinfo.procdef.procoptions) then
+        current_procinfo.procdef.parast.SymList.ForEachCall(@final_paras,list);
+      current_procinfo:=old_current_procinfo;
+    end;
+
+  procedure thlcgobj.gen_entry_code(list: TAsmList);
+    begin
+      { the actual profile code can clobber some registers,
+        therefore if the context must be saved, do it before
+        the actual call to the profile code
+      }
+      if (cs_profile in current_settings.moduleswitches) and
+         not(po_assembler in current_procinfo.procdef.procoptions) then
+        begin
+          { non-win32 can call mcout even in main }
+          if not (target_info.system in [system_i386_win32,system_i386_wdosx]) or
+             not (current_procinfo.procdef.proctypeoption=potype_proginit) then
+            begin
+              g_profilecode(list);
+            end;
+        end;
+
+      { TODO: create high level version (create compilerprocs in system unit,
+          look up procdef, use hlcgobj.a_call_name()) }
+
+      { call startup helpers from main program }
+      if (current_procinfo.procdef.proctypeoption=potype_proginit) then
+       begin
+         { initialize units }
+         cg.allocallcpuregisters(list);
+         if not(current_module.islibrary) then
+           cg.a_call_name(list,'FPC_INITIALIZEUNITS',false)
+         else
+           cg.a_call_name(list,'FPC_LIBINITIALIZEUNITS',false);
+         cg.deallocallcpuregisters(list);
+       end;
+
+      list.concat(Tai_force_line.Create);
+
+{$ifdef OLDREGVARS}
+      load_regvars(list,nil);
+{$endif OLDREGVARS}
+    end;
+
+  procedure thlcgobj.gen_exit_code(list: TAsmList);
+    begin
+      { TODO: create high level version (create compilerproc in system unit,
+          look up procdef, use hlcgobj.a_call_name()) }
+
+      { call __EXIT for main program }
+      if (not DLLsource) and
+         (current_procinfo.procdef.proctypeoption=potype_proginit) then
+        cg.a_call_name(list,'FPC_DO_EXIT',false);
+    end;
+
+  procedure thlcgobj.inittempvariables(list: TAsmList);
+    var
+      hp : ptemprecord;
+      href : treference;
+    begin
+      hp:=tg.templist;
+      while assigned(hp) do
+       begin
+         if assigned(hp^.def) and
+            is_managed_type(hp^.def) then
+          begin
+            reference_reset_base(href,current_procinfo.framepointer,hp^.pos,sizeof(pint));
+            g_initialize(list,hp^.def,href);
+          end;
+         hp:=hp^.next;
+       end;
+    end;
+
+  procedure thlcgobj.initialize_data(p: TObject; arg: pointer);
+    var
+      OldAsmList : TAsmList;
+      hp : tnode;
+    begin
+      if (tsym(p).typ = localvarsym) and
+         { local (procedure or unit) variables only need initialization if
+           they are used }
+         ((tabstractvarsym(p).refs>0) or
+          { managed return symbols must be inited }
+          ((tsym(p).typ=localvarsym) and (vo_is_funcret in tlocalvarsym(p).varoptions))
+         ) and
+         not(vo_is_typed_const in tabstractvarsym(p).varoptions) and
+         not(vo_is_external in tabstractvarsym(p).varoptions) and
+         not(vo_is_default_var in tabstractvarsym(p).varoptions) and
+         (is_managed_type(tabstractvarsym(p).vardef) or
+          ((m_iso in current_settings.modeswitches) and (tabstractvarsym(p).vardef.typ=filedef))
+         ) then
+        begin
+          OldAsmList:=current_asmdata.CurrAsmList;
+          current_asmdata.CurrAsmList:=TAsmList(arg);
+          hp:=cnodeutils.initialize_data_node(cloadnode.create(tsym(p),tsym(p).owner),false);
+          firstpass(hp);
+          secondpass(hp);
+          hp.free;
+          current_asmdata.CurrAsmList:=OldAsmList;
+        end;
+    end;
+
+  procedure thlcgobj.finalizetempvariables(list: TAsmList);
+    var
+      hp : ptemprecord;
+      href : treference;
+    begin
+      hp:=tg.templist;
+      while assigned(hp) do
+       begin
+         if assigned(hp^.def) and
+            is_managed_type(hp^.def) then
+          begin
+            include(current_procinfo.flags,pi_needs_implicit_finally);
+            reference_reset_base(href,current_procinfo.framepointer,hp^.pos,sizeof(pint));
+            g_finalize(list,hp^.def,href);
+          end;
+         hp:=hp^.next;
+       end;
+    end;
+
+  procedure thlcgobj.initialize_regvars(p: TObject; arg: pointer);
+    var
+      href : treference;
+    begin
+      if (tsym(p).typ=staticvarsym) then
+       begin
+         { Static variables can have the initialloc only set to LOC_CxREGISTER
+           or LOC_INVALID, for explaination see gen_alloc_symtable (PFV) }
+         case tstaticvarsym(p).initialloc.loc of
+           LOC_CREGISTER :
+             begin
+{$ifndef cpu64bitalu}
+               if (tstaticvarsym(p).initialloc.size in [OS_64,OS_S64]) then
+                 cg64.a_load64_const_reg(TAsmList(arg),0,tstaticvarsym(p).initialloc.register64)
+               else
+{$endif not cpu64bitalu}
+                 a_load_const_reg(TAsmList(arg),tstaticvarsym(p).vardef,0,
+                     tstaticvarsym(p).initialloc.register);
+             end;
+(*
+           LOC_CMMREGISTER :
+             { clear the whole register }
+             cg.a_opmm_reg_reg(TAsmList(arg),OP_XOR,reg_cgsize(tstaticvarsym(p).initialloc.register),
+               tstaticvarsym(p).initialloc.register,
+               tstaticvarsym(p).initialloc.register,
+               nil);
+*)
+           LOC_CFPUREGISTER :
+             begin
+               { initialize fpu regvar by loading from memory }
+               reference_reset_symbol(href,
+                 current_asmdata.RefAsmSymbol(tstaticvarsym(p).mangledname), 0,
+                 var_align(tstaticvarsym(p).vardef.alignment));
+               a_loadfpu_ref_reg(TAsmList(arg), tstaticvarsym(p).vardef,
+                 tstaticvarsym(p).vardef, href, tstaticvarsym(p).initialloc.register);
+             end;
+           LOC_INVALID :
+             ;
+           else
+             internalerror(200410124);
+         end;
+       end;
+    end;
+
+  procedure thlcgobj.finalize_sym(asmlist: TAsmList; sym: tsym);
+    var
+      hp : tnode;
+      OldAsmList : TAsmList;
+    begin
+      include(current_procinfo.flags,pi_needs_implicit_finally);
+      OldAsmList:=current_asmdata.CurrAsmList;
+      current_asmdata.CurrAsmList:=asmlist;
+      hp:=cloadnode.create(sym,sym.owner);
+      if (sym.typ=staticvarsym) and (vo_force_finalize in tstaticvarsym(sym).varoptions) then
+        include(tloadnode(hp).loadnodeflags,loadnf_isinternal_ignoreconst);
+      hp:=cnodeutils.finalize_data_node(hp);
+      firstpass(hp);
+      secondpass(hp);
+      hp.free;
+      current_asmdata.CurrAsmList:=OldAsmList;
+    end;
+
+  procedure thlcgobj.finalize_local_vars(p: TObject; arg: pointer);
+    begin
+      if (tsym(p).typ=localvarsym) and
+         (tlocalvarsym(p).refs>0) and
+         not(vo_is_external in tlocalvarsym(p).varoptions) and
+         not(vo_is_funcret in tlocalvarsym(p).varoptions) and
+         not(vo_is_default_var in tabstractvarsym(p).varoptions) and
+         is_managed_type(tlocalvarsym(p).vardef) then
+        finalize_sym(TAsmList(arg),tsym(p));
+    end;
+
+  procedure thlcgobj.finalize_static_data(p: TObject; arg: pointer);
+    var
+      i : longint;
+      pd : tprocdef;
+    begin
+      case tsym(p).typ of
+        staticvarsym :
+          begin
+                { local (procedure or unit) variables only need finalization
+                  if they are used
+                }
+            if ((tstaticvarsym(p).refs>0) or
+                { global (unit) variables always need finalization, since
+                  they may also be used in another unit
+                }
+                (tstaticvarsym(p).owner.symtabletype=globalsymtable)) and
+                (
+                  (tstaticvarsym(p).varspez<>vs_const) or
+                  (vo_force_finalize in tstaticvarsym(p).varoptions)
+                ) and
+               not(vo_is_funcret in tstaticvarsym(p).varoptions) and
+               not(vo_is_external in tstaticvarsym(p).varoptions) and
+               is_managed_type(tstaticvarsym(p).vardef) then
+              finalize_sym(TAsmList(arg),tsym(p));
+          end;
+        procsym :
+          begin
+            for i:=0 to tprocsym(p).ProcdefList.Count-1 do
+              begin
+                pd:=tprocdef(tprocsym(p).ProcdefList[i]);
+                if assigned(pd.localst) and
+                   (pd.procsym=tprocsym(p)) and
+                   (pd.localst.symtabletype<>staticsymtable) then
+                  pd.localst.SymList.ForEachCall(@finalize_static_data,arg);
+              end;
+          end;
+      end;
+    end;
+
+  procedure thlcgobj.final_paras(p: TObject; arg: pointer);
+    var
+      list : TAsmList;
+      href : treference;
+      hsym : tparavarsym;
+      eldef : tdef;
+      highloc : tlocation;
+    begin
+      if not(tsym(p).typ=paravarsym) then
+        exit;
+      list:=TAsmList(arg);
+      if is_managed_type(tparavarsym(p).vardef) then
+       begin
+         if (tparavarsym(p).varspez=vs_value) then
+          begin
+            include(current_procinfo.flags,pi_needs_implicit_finally);
+            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
+                if paramanager.push_high_param(tparavarsym(p).varspez,tparavarsym(p).vardef,current_procinfo.procdef.proccalloption) then
+                  begin
+                    hsym:=tparavarsym(get_high_value_sym(tparavarsym(p)));
+                    if not assigned(hsym) then
+                      internalerror(201003032);
+                    highloc:=hsym.initialloc
+                  end
+                else
+                  highloc.loc:=LOC_INVALID;
+                eldef:=tarraydef(tparavarsym(p).vardef).elementdef;
+                g_array_rtti_helper(list,eldef,href,highloc,'FPC_FINALIZE_ARRAY');
+              end
+            else
+              g_finalize(list,tparavarsym(p).vardef,href);
+          end;
+       end;
+      { open arrays can contain elements requiring init/final code, so the else has been removed here }
+      if (tparavarsym(p).varspez=vs_value) and
+         (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
+            g_releasevaluepara_openarray(list,tarraydef(tparavarsym(p).vardef),tparavarsym(p).localloc);
+        end;
+    end;
+
+
+
+
+
+{ generates the code for incrementing the reference count of parameters and
+  initialize out parameters }
+  { generates the code for incrementing the reference count of parameters and
+    initialize out parameters }
+  procedure thlcgobj.init_paras(p:TObject;arg:pointer);
+    var
+      href : treference;
+      hsym : tparavarsym;
+      eldef : tdef;
+      list : TAsmList;
+      highloc : tlocation;
+      needs_inittable (*,
+      do_trashing     *)  : boolean;
+    begin
+      list:=TAsmList(arg);
+      if (tsym(p).typ=paravarsym) then
+       begin
+         needs_inittable:=is_managed_type(tparavarsym(p).vardef);
+(*
+         do_trashing:=
+           (localvartrashing <> -1) and
+           (not assigned(tparavarsym(p).defaultconstsym)) and
+           not needs_inittable;
+*)
+         case tparavarsym(p).varspez of
+           vs_value :
+             if needs_inittable then
+               begin
+                 { variants are already handled by the call to fpc_variant_copy_overwrite if
+                   they are passed by reference }
+                 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).vardef,tparavarsym(p).initialloc,href,is_open_array(tparavarsym(p).vardef),sizeof(pint));
+                     if is_open_array(tparavarsym(p).vardef) then
+                       begin
+                         if paramanager.push_high_param(tparavarsym(p).varspez,tparavarsym(p).vardef,current_procinfo.procdef.proccalloption) then
+                           begin
+                             hsym:=tparavarsym(get_high_value_sym(tparavarsym(p)));
+                             if not assigned(hsym) then
+                               internalerror(201003032);
+                             highloc:=hsym.initialloc
+                           end
+                         else
+                           highloc.loc:=LOC_INVALID;
+                         { open arrays do not contain correct element count in their rtti,
+                           the actual count must be passed separately. }
+                         eldef:=tarraydef(tparavarsym(p).vardef).elementdef;
+                         g_array_rtti_helper(list,eldef,href,highloc,'FPC_ADDREF_ARRAY');
+                       end
+                     else
+                      g_incrrefcount(list,tparavarsym(p).vardef,href);
+                   end;
+               end;
+           vs_out :
+             begin
+               if needs_inittable (*or
+                  do_trashing*) then
+                 begin
+                   { we have no idea about the alignment at the callee side,
+                     and the user also cannot specify "unaligned" here, so
+                     assume worst case }
+                   location_get_data_ref(list,tparavarsym(p).vardef,tparavarsym(p).initialloc,href,true,1);
+(*
+                   if do_trashing and
+                      { needs separate implementation to trash open arrays }
+                      { since their size is only known at run time         }
+                      not is_special_array(tparavarsym(p).vardef) then
+                      { may be an open string, even if is_open_string() returns }
+                      { false (for some helpers in the system unit)             }
+                     if not is_shortstring(tparavarsym(p).vardef) then
+                       trash_reference(list,href,tparavarsym(p).vardef.size)
+                     else
+                       trash_reference(list,href,2);
+*)
+                   if needs_inittable then
+                     begin
+                       if is_open_array(tparavarsym(p).vardef) then
+                         begin
+                           if paramanager.push_high_param(tparavarsym(p).varspez,tparavarsym(p).vardef,current_procinfo.procdef.proccalloption) then
+                             begin
+                               hsym:=tparavarsym(get_high_value_sym(tparavarsym(p)));
+                               if not assigned(hsym) then
+                                 internalerror(201003032);
+                               highloc:=hsym.initialloc
+                             end
+                           else
+                             highloc.loc:=LOC_INVALID;
+                           eldef:=tarraydef(tparavarsym(p).vardef).elementdef;
+                           g_array_rtti_helper(list,eldef,href,highloc,'FPC_INITIALIZE_ARRAY');
+                         end
+                       else
+                         g_initialize(list,tparavarsym(p).vardef,href);
+                     end;
+                 end;
+             end;
+(*
+           else if do_trashing and
+                   ([vo_is_funcret,vo_is_hidden_para] * tparavarsym(p).varoptions = [vo_is_funcret,vo_is_hidden_para]) then
+                 begin
+                   { should always have standard alignment. If a function is assigned
+                     to a non-aligned variable, the optimisation to pass this variable
+                     directly as hidden function result must/cannot be performed
+                     (see tcallnode.funcret_can_be_reused)
+                   }
+                   location_get_data_ref(list,tparavarsym(p).vardef,tparavarsym(p).initialloc,href,true,
+                     used_align(tparavarsym(p).vardef.alignment,current_settings.alignment.localalignmin,current_settings.alignment.localalignmax));
+                   { may be an open string, even if is_open_string() returns }
+                   { false (for some helpers in the system unit)             }
+                   if not is_shortstring(tparavarsym(p).vardef) then
+                     trash_reference(list,href,tparavarsym(p).vardef.size)
+                   else
+                     { an open string has at least size 2 }
+                     trash_reference(list,href,2);
+                 end
+*)
+         end;
+       end;
+    end;
+
+  procedure thlcgobj.gen_load_para_value(list: TAsmList);
+    var
+      i: longint;
+      currpara: tparavarsym;
+    begin
+      if (po_assembler in current_procinfo.procdef.procoptions) or
+      { exceptfilters have a single hidden 'parentfp' parameter, which
+        is handled by tcg.g_proc_entry. }
+         (current_procinfo.procdef.proctypeoption=potype_exceptfilter) then
+        exit;
+
+      { Copy parameters to local references/registers }
+      for i:=0 to current_procinfo.procdef.paras.count-1 do
+        begin
+          currpara:=tparavarsym(current_procinfo.procdef.paras[i]);
+          gen_load_cgpara_loc(list,currpara.vardef,currpara.paraloc[calleeside],currpara.initialloc,paramanager.param_use_paraloc(currpara.paraloc[calleeside]));
+        end;
+
+      { 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(@g_copyvalueparas,list);
+
+      if not(po_assembler in current_procinfo.procdef.procoptions) then
+        begin
+          { has to be done here rather than in gen_initialize_code, because
+            the initialisation code is generated a) later and b) with
+            rad_backwards, so the register allocator would generate
+            information as if this code comes before loading the parameters
+            from their original registers to their local location }
+//          if (localvartrashing <> -1) then
+//            current_procinfo.procdef.localst.SymList.ForEachCall(@trash_variable,list);
+          { initialize refcounted paras, and trash others. Needed here
+            instead of in gen_initialize_code, because when a reference is
+            intialised or trashed while the pointer to that reference is kept
+            in a regvar, we add a register move and that one again has to
+            come after the parameter loading code as far as the register
+            allocator is concerned }
+          current_procinfo.procdef.parast.SymList.ForEachCall(@init_paras,list);
+        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(get_high_value_sym(tparavarsym(p)));
+                      if not assigned(hsym) then
+                        internalerror(2011020506);
+                      highloc:=hsym.initialloc
+                    end
+                  else
+                    highloc.loc:=LOC_INVALID;
+                  hreg:=getaddressregister(list,voidpointertype);
+                  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
+(*
+        LOC_MMREGISTER,
+        LOC_CMMREGISTER:
+          case cgpara.location^.loc of
+            LOC_REFERENCE,
+            LOC_CREFERENCE,
+            LOC_MMREGISTER,
+            LOC_CMMREGISTER,
+            LOC_REGISTER,
+            LOC_CREGISTER :
+              cg.a_loadmm_reg_cgpara(list,locsize,l.register,cgpara,mms_movescalar);
+            LOC_FPUREGISTER,
+            LOC_CFPUREGISTER:
+              begin
+                tmploc:=l;
+                location_force_fpureg(list,tmploc,false);
+                cg.a_loadfpu_reg_cgpara(list,tmploc.size,tmploc.register,cgpara);
+              end;
+            else
+              internalerror(200204249);
+          end;
+*)
+        LOC_FPUREGISTER,
+        LOC_CFPUREGISTER:
+          case cgpara.location^.loc of
+(*
+            LOC_MMREGISTER,
+            LOC_CMMREGISTER:
+              begin
+                tmploc:=l;
+                location_force_mmregscalar(list,tmploc,false);
+                cg.a_loadmm_reg_cgpara(list,tmploc.size,tmploc.register,cgpara,mms_movescalar);
+              end;
+*)
+            { Some targets pass floats in normal registers }
+            LOC_REGISTER,
+            LOC_CREGISTER,
+            LOC_REFERENCE,
+            LOC_CREFERENCE,
+            LOC_FPUREGISTER,
+            LOC_CFPUREGISTER:
+              a_loadfpu_reg_cgpara(list,size,l.register,cgpara);
+            else
+              internalerror(2011010210);
+          end;
+        LOC_REFERENCE,
+        LOC_CREFERENCE:
+          case cgpara.location^.loc of
+(*
+            LOC_MMREGISTER,
+            LOC_CMMREGISTER:
+              cg.a_loadmm_ref_cgpara(list,locsize,l.reference,cgpara,mms_movescalar);
+*)
+            { Some targets pass floats in normal registers }
+            LOC_REGISTER,
+            LOC_CREGISTER,
+            LOC_REFERENCE,
+            LOC_CREFERENCE,
+            LOC_FPUREGISTER,
+            LOC_CFPUREGISTER:
+              a_loadfpu_ref_cgpara(list,size,l.reference,cgpara);
+            else
+              internalerror(2011010211);
+          end;
+        LOC_REGISTER,
+        LOC_CREGISTER :
+          a_load_loc_cgpara(list,size,l,cgpara);
+         else
+           internalerror(2011010212);
+      end;
+    end;
+
+  procedure thlcgobj.gen_load_uninitialized_function_result(list: TAsmList; pd: tprocdef; resdef: tdef; const resloc: tcgpara);
+    begin
+      { do nothing by default }
+    end;
+
+  procedure thlcgobj.gen_load_loc_cgpara(list: TAsmList; vardef: tdef; const l: tlocation; const cgpara: tcgpara);
+    begin
+      { Handle Floating point types differently
+
+        This doesn't depend on emulator settings, emulator settings should
+        be handled by cpupara }
+      if (vardef.typ=floatdef) or
+         { some ABIs return certain records in an fpu register }
+         (l.loc in [LOC_FPUREGISTER,LOC_CFPUREGISTER]) or
+         (assigned(cgpara.location) and
+          (cgpara.Location^.loc in [LOC_FPUREGISTER,LOC_CFPUREGISTER])) then
+        begin
+          gen_loadfpu_loc_cgpara(list,vardef,l,cgpara,vardef.size);
+          exit;
+        end;
+
+      case l.loc of
+        LOC_CONSTANT,
+        LOC_REGISTER,
+        LOC_CREGISTER,
+        LOC_REFERENCE,
+        LOC_CREFERENCE :
+          begin
+            a_load_loc_cgpara(list,vardef,l,cgpara);
+          end;
+(*
+        LOC_MMREGISTER,
+        LOC_CMMREGISTER:
+          begin
+            case l.size of
+              OS_F32,
+              OS_F64:
+                cg.a_loadmm_loc_cgpara(list,l,cgpara,mms_movescalar);
+              else
+                cg.a_loadmm_loc_cgpara(list,l,cgpara,nil);
+            end;
+          end;
+*)
+        else
+          internalerror(2011010213);
+      end;
+    end;
+
+  procedure thlcgobj.gen_load_cgpara_loc(list: TAsmList; vardef: tdef; const para: TCGPara; var destloc: tlocation; reusepara: boolean);
+    var
+      href     : treference;
+    begin
+      para.check_simple_location;
+      { skip e.g. empty records }
+      if (para.location^.loc = LOC_VOID) then
+        exit;
+      case destloc.loc of
+        LOC_REFERENCE :
+          begin
+            { If the parameter location is reused we don't need to copy
+              anything }
+            if not reusepara then
+              begin
+                reference_reset_base(href,para.location^.reference.index,para.location^.reference.offset,para.alignment);
+                a_load_ref_ref(list,para.def,para.def,href,destloc.reference);
+              end;
+          end;
+        { TODO other possible locations }
+        else
+          internalerror(2011010308);
+      end;
+    end;
+
+  procedure thlcgobj.gen_load_return_value(list: TAsmList);
+    var
+      ressym : tabstractnormalvarsym;
+      funcretloc : TCGPara;
+    begin
+      { Is the loading needed? }
+      if is_void(current_procinfo.procdef.returndef) or
+         (
+          (po_assembler in current_procinfo.procdef.procoptions) and
+          (not(assigned(current_procinfo.procdef.funcretsym)) or
+           (tabstractvarsym(current_procinfo.procdef.funcretsym).refs=0))
+         ) then
+         exit;
+
+      funcretloc:=current_procinfo.procdef.funcretloc[calleeside];
+
+      { constructors return self }
+      if (current_procinfo.procdef.proctypeoption=potype_constructor) then
+        ressym:=tabstractnormalvarsym(current_procinfo.procdef.parast.Find('self'))
+      else
+        ressym:=tabstractnormalvarsym(current_procinfo.procdef.funcretsym);
+      if (ressym.refs>0) or
+         is_managed_type(ressym.vardef) then
+        begin
+          { was: don't do anything if funcretloc.loc in [LOC_INVALID,LOC_REFERENCE] }
+          if not paramanager.ret_in_param(current_procinfo.procdef.returndef,current_procinfo.procdef.proccalloption) then
+            gen_load_loc_cgpara(list,ressym.vardef,ressym.localloc,funcretloc);
+        end
+      else
+        gen_load_uninitialized_function_result(list,current_procinfo.procdef,ressym.vardef,funcretloc)
+    end;
+
+  procedure thlcgobj.record_generated_code_for_procdef(pd: tprocdef; code, data: TAsmList);
+    begin
+      { add the procedure to the al_procedures }
+      maybe_new_object_file(current_asmdata.asmlists[al_procedures]);
+      new_section(current_asmdata.asmlists[al_procedures],sec_code,lower(pd.mangledname),getprocalign);
+      current_asmdata.asmlists[al_procedures].concatlist(code);
+      { save local data (casetable) also in the same file }
+      if assigned(data) and
+         (not data.empty) then
+        current_asmdata.asmlists[al_procedures].concatlist(data);
+    end;
+
+  procedure thlcgobj.g_call_system_proc(list: TAsmList; const procname: string);
+    var
+      srsym: tsym;
+      pd: tprocdef;
+    begin
+      srsym:=tsym(systemunit.find(procname));
+      if not assigned(srsym) and
+         (cs_compilesystem in current_settings.moduleswitches) then
+        srsym:=tsym(systemunit.Find(upper(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);
+    end;
+
+
+
+end.

compiler/htypechk.pas

@@ -64,6 +64,7 @@ interface
         FProcsymtable : tsymtable;
         FOperator    : ttoken;
         FCandidateProcs    : pcandidate;
+        FIgnoredCandidateProcs: tfpobjectlist;
         FProcCnt    : integer;
         FParaNode   : tnode;
         FParaLength : smallint;
@@ -171,8 +172,6 @@ interface
 
     function allowenumop(nt:tnodetype):boolean;
 
-    procedure check_hints(const srsym: tsym; const symoptions: tsymoptions; const deprecatedmsg : pshortstring);
-
     procedure check_ranges(const location: tfileposinfo; source: tnode; destdef: tdef);
 
     { returns whether the def may be used in the Default() intrinsic; static
@@ -988,6 +987,11 @@ implementation
                  if (tloadnode(p).symtableentry.typ in [localvarsym,paravarsym,staticvarsym]) then
                    begin
                      hsym:=tabstractvarsym(tloadnode(p).symtableentry);
+                     { this check requires proper data flow analysis... }
+(*                     if (hsym.varspez=vs_final) and
+                        (hsym.varstate in [vs_written,vs_readwritten]) and
+                        (newstate in [vs_written,vs_readwritten]) then
+                       CGMessagePos1(p.fileinfo,sym_e_final_write_once); *)
                      if (vsf_must_be_valid in varstateflags) and
                         (hsym.varstate in [vs_declared,vs_read_not_warned,vs_referred_not_inited]) then
                        begin
@@ -1074,6 +1078,7 @@ implementation
 
     function  valid_for_assign(p:tnode;opts:TValidAssigns; report_errors: boolean):boolean;
       var
+        typeconvs: tfpobjectlist;
         hp2,
         hp : tnode;
         gotstring,
@@ -1089,6 +1094,49 @@ implementation
         todef    : tdef;
         errmsg,
         temp     : longint;
+
+        function constaccessok(vs: tabstractvarsym): boolean;
+          begin
+            result:=false;
+            { allow p^:= constructions with p is const parameter }
+            if gotderef or gotdynarray or (Valid_Const in opts) or
+              ((hp.nodetype=loadn) and
+               (loadnf_isinternal_ignoreconst in tloadnode(hp).loadnodeflags)) then
+              result:=true
+            { final (class) fields can only be initialised in the (class) constructors of
+              class in which they have been declared (not in descendent constructors) }
+            else if vs.varspez=vs_final then
+              begin
+                if (current_procinfo.procdef.owner=vs.owner) then
+                  if vs.typ=staticvarsym then
+                    result:=current_procinfo.procdef.proctypeoption=potype_class_constructor
+                  else
+                    result:=current_procinfo.procdef.proctypeoption=potype_constructor;
+                if not result and
+                   report_errors then
+                  CGMessagePos(hp.fileinfo,type_e_invalid_final_assignment);
+              end
+            else
+              if report_errors then
+                CGMessagePos(hp.fileinfo,type_e_no_assign_to_const);
+          end;
+
+
+        procedure mayberesettypeconvs;
+          var
+            i: longint;
+          begin
+            if assigned(typeconvs) then
+              begin
+                if not report_errors and
+                   not result then
+                  for i:=0 to typeconvs.Count-1 do
+                    ttypeconvnode(typeconvs[i]).assignment_side:=false;
+                typeconvs.free;
+              end;
+          end;
+
+
       begin
         if valid_const in opts then
           errmsg:=type_e_variable_id_expected
@@ -1114,6 +1162,7 @@ implementation
              CGMessagePos(hp.fileinfo,errmsg);
            exit;
          end;
+        typeconvs:=nil;
         while assigned(hp) do
          begin
            { property allowed? calln has a property check itself }
@@ -1185,12 +1234,14 @@ implementation
                      if report_errors then
                        CGMessagePos(hp.fileinfo,errmsg);
                  end;
+               mayberesettypeconvs;
                exit;
              end;
            case hp.nodetype of
              temprefn :
                begin
-                 valid_for_assign := true;
+                 valid_for_assign := not(ti_readonly in ttemprefnode(hp).tempinfo^.flags);
+                 mayberesettypeconvs;
                  exit;
                end;
              derefn :
@@ -1209,14 +1260,37 @@ implementation
                    - typecast from pointer to array }
                  fromdef:=ttypeconvnode(hp).left.resultdef;
                  todef:=hp.resultdef;
-                 if not((nf_absolute in ttypeconvnode(hp).flags) or
+                 { typeconversions on the assignment side must keep
+                   left.location the same }
+                 if not(gotderef or
+                        ((target_info.system in systems_jvm) and
+                         (gotsubscript or gotvec))) then
+                   begin
+                     ttypeconvnode(hp).assignment_side:=true;
+                     if not assigned(typeconvs) then
+                       typeconvs:=tfpobjectlist.create(false);
+                     typeconvs.add(hp);
+                   end;
+                 { in managed VMs, you cannot typecast formaldef when assigning
+                   to it, see http://hallvards.blogspot.com/2007/10/dn4dp24-net-vs-win32-untyped-parameters.html }
+                 if (target_info.system in systems_managed_vm) and
+                    (fromdef.typ=formaldef) then
+                   begin
+                     if report_errors then
+                       CGMessagePos(hp.fileinfo,type_e_no_managed_formal_assign_typecast);
+                     mayberesettypeconvs;
+                     exit;
+                   end
+                 else if not((nf_absolute in ttypeconvnode(hp).flags) or
+                        ttypeconvnode(hp).target_specific_general_typeconv or
+                        ((nf_explicit in hp.flags) and
+                         ttypeconvnode(hp).target_specific_explicit_typeconv) or
                         (fromdef.typ=formaldef) or
                         is_void(fromdef) or
                         is_open_array(fromdef) or
                         is_open_array(todef) or
                         ((fromdef.typ=pointerdef) and (todef.typ=arraydef)) or
-                        ((fromdef.typ = objectdef) and (todef.typ = objectdef) and
-                         (tobjectdef(fromdef).is_related(tobjectdef(todef))))) and
+                        (fromdef.is_related(todef))) and
                     (fromdef.size<>todef.size) then
                   begin
                     { in TP it is allowed to typecast to smaller types. But the variable can't
@@ -1235,6 +1309,7 @@ implementation
                    begin
                      if report_errors then
                        CGMessagePos(hp.fileinfo,errmsg);
+                     mayberesettypeconvs;
                      exit;
                    end;
                  case hp.resultdef.typ of
@@ -1270,6 +1345,7 @@ implementation
                          CGMessagePos(hp.fileinfo,parser_e_packed_element_no_loop)
                        else
                          CGMessagePos(hp.fileinfo,parser_e_packed_element_no_var_addr);
+                     mayberesettypeconvs;
                      exit;
                    end;
                  gotvec:=true;
@@ -1297,6 +1373,7 @@ implementation
                    begin
                      if report_errors then
                       CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
+                     mayberesettypeconvs;
                      exit;
                    end;
                end;
@@ -1308,6 +1385,7 @@ implementation
                    begin
                      if report_errors then
                        CGMessagePos(hp.fileinfo,errmsg);
+                     mayberesettypeconvs;
                      exit;
                    end;
                  hp:=tunarynode(hp).left;
@@ -1327,6 +1405,14 @@ implementation
                          CGMessagePos(hp.fileinfo,parser_e_packed_element_no_loop)
                        else
                          CGMessagePos(hp.fileinfo,parser_e_packed_element_no_var_addr);
+                     mayberesettypeconvs;
+                     exit;
+                   end;
+                 { check for final fields }
+                 if (tsubscriptnode(hp).vs.varspez=vs_final) and
+                    not constaccessok(tsubscriptnode(hp).vs) then
+                   begin
+                     mayberesettypeconvs;
                      exit;
                    end;
                  { if we assign something to a field of a record that is not
@@ -1347,6 +1433,7 @@ implementation
                    begin
                      if report_errors then
                        CGMessage1(parser_e_illegal_assignment_to_count_var,tsubscriptnode(hp).vs.realname);
+                     mayberesettypeconvs;
                      exit;
                    end;
                  { implicit pointer object types result in dereferencing }
@@ -1380,6 +1467,7 @@ implementation
                  else
                   if report_errors then
                    CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
+                 mayberesettypeconvs;
                  exit;
                end;
              niln,
@@ -1391,6 +1479,7 @@ implementation
                  else
                   if report_errors then
                    CGMessagePos(hp.fileinfo,type_e_no_assign_to_addr);
+                 mayberesettypeconvs;
                  exit;
                end;
              ordconstn,
@@ -1399,6 +1488,7 @@ implementation
                  { these constants will be passed by value }
                  if report_errors then
                    CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
+                 mayberesettypeconvs;
                  exit;
                end;
              setconstn,
@@ -1411,6 +1501,7 @@ implementation
                  else
                    if report_errors then
                      CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
+                 mayberesettypeconvs;
                  exit;
                end;
              addrn :
@@ -1420,6 +1511,7 @@ implementation
                  else
                   if report_errors then
                    CGMessagePos(hp.fileinfo,type_e_no_assign_to_addr);
+                 mayberesettypeconvs;
                  exit;
                end;
              calln :
@@ -1467,6 +1559,7 @@ implementation
                  else
                   if report_errors then
                    CGMessagePos(hp.fileinfo,errmsg);
+                 mayberesettypeconvs;
                  exit;
                end;
              inlinen :
@@ -1478,12 +1571,14 @@ implementation
                  else
                    if report_errors then
                     CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
+                 mayberesettypeconvs;
                  exit;
                end;
              dataconstn:
                begin
                  { only created internally, so no additional checks necessary }
                  result:=true;
+                 mayberesettypeconvs;
                  exit;
                end;
              loadn :
@@ -1501,21 +1596,18 @@ implementation
                          begin
                            if report_errors then
                              CGMessage1(parser_e_illegal_assignment_to_count_var,tloadnode(hp).symtableentry.realname);
+                           mayberesettypeconvs;
                            exit;
                          end;
                        { read-only variable? }
-                       if (tabstractvarsym(tloadnode(hp).symtableentry).varspez in [vs_const,vs_constref]) then
+                       if (tabstractvarsym(tloadnode(hp).symtableentry).varspez in [vs_const,vs_constref,vs_final]) then
                         begin
-                          { allow p^:= constructions with p is const parameter }
-                          if gotderef or gotdynarray or (Valid_Const in opts) or
-                            (loadnf_isinternal_ignoreconst in tloadnode(hp).loadnodeflags) then
-                            result:=true
-                          else
-                            if report_errors then
-                              CGMessagePos(tloadnode(hp).fileinfo,type_e_no_assign_to_const);
+                          result:=constaccessok(tabstractvarsym(tloadnode(hp).symtableentry));
+                          mayberesettypeconvs;
                           exit;
                         end;
                        result:=true;
+                       mayberesettypeconvs;
                        exit;
                      end;
                    procsym :
@@ -1525,6 +1617,7 @@ implementation
                        else
                          if report_errors then
                           CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
+                       mayberesettypeconvs;
                        exit;
                      end;
                    labelsym :
@@ -1534,6 +1627,7 @@ implementation
                        else
                          if report_errors then
                           CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
+                       mayberesettypeconvs;
                        exit;
                      end;
                    constsym:
@@ -1544,12 +1638,14 @@ implementation
                        else
                          if report_errors then
                           CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
+                       mayberesettypeconvs;
                        exit;
                      end;
                    else
                      begin
                        if report_errors then
                         CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
+                       mayberesettypeconvs;
                        exit;
                      end;
                  end;
@@ -1558,10 +1654,12 @@ implementation
                begin
                  if report_errors then
                   CGMessagePos(hp.fileinfo,type_e_variable_id_expected);
+                 mayberesettypeconvs;
                  exit;
                end;
             end;
          end;
+         mayberesettypeconvs;
       end;
 
 
@@ -1778,6 +1876,7 @@ implementation
         FProcsym:=sym;
         FProcsymtable:=st;
         FParanode:=ppn;
+        FIgnoredCandidateProcs:=tfpobjectlist.create(false);
         create_candidate_list(ignorevisibility,allowdefaultparas,objcidcall,explicitunit,searchhelpers,anoninherited);
       end;
 
@@ -1788,6 +1887,7 @@ implementation
         FProcsym:=nil;
         FProcsymtable:=nil;
         FParanode:=ppn;
+        FIgnoredCandidateProcs:=tfpobjectlist.create(false);
         create_candidate_list(false,false,false,false,false,false);
       end;
 
@@ -1797,6 +1897,7 @@ implementation
         hpnext,
         hp : pcandidate;
       begin
+        FIgnoredCandidateProcs.free;
         hp:=FCandidateProcs;
         while assigned(hp) do
          begin
@@ -1820,6 +1921,11 @@ implementation
           for j:=0 to srsym.ProcdefList.Count-1 do
             begin
               pd:=tprocdef(srsym.ProcdefList[j]);
+              if (po_ignore_for_overload_resolution in pd.procoptions) then
+                begin
+                  FIgnoredCandidateProcs.add(pd);
+                  continue;
+                end;
               { in case of anonymous inherited, only match procdefs identical
                 to the current one (apart from hidden parameters), rather than
                 anything compatible to the parameters -- except in case of
@@ -1974,14 +2080,19 @@ implementation
                 if assigned(srsym) and
                    (srsym.typ=procsym) then
                   begin
-                    { Store first procsym found }
-                    if not assigned(FProcsym) then
-                      FProcsym:=tprocsym(srsym);
                     { add all definitions }
                     hasoverload:=false;
                     for j:=0 to tprocsym(srsym).ProcdefList.Count-1 do
                       begin
                         pd:=tprocdef(tprocsym(srsym).ProcdefList[j]);
+                        if (po_ignore_for_overload_resolution in pd.procoptions) then
+                          begin
+                            FIgnoredCandidateProcs.add(pd);
+                            continue;
+                          end;
+                        { Store first procsym found }
+                        if not assigned(FProcsym) then
+                          FProcsym:=tprocsym(srsym);
                         if po_overload in pd.procoptions then
                           hasoverload:=true;
                         ProcdefOverloadList.Add(tprocsym(srsym).ProcdefList[j]);
@@ -2832,6 +2943,7 @@ implementation
 
     function tcallcandidates.choose_best(var bestpd:tabstractprocdef; singlevariant: boolean):integer;
       var
+        pd: tprocdef;
         besthpstart,
         hp            : pcandidate;
         cntpd,
@@ -2886,6 +2998,32 @@ implementation
             end;
          end;
 
+        { if we've found one, check the procdefs ignored for overload choosing
+          to see whether they contain one from a child class with the same
+          parameters (so the overload choosing was not influenced by their
+          presence, but now that we've decided which overloaded version to call,
+          make sure we call the version closest in terms of visibility }
+        if cntpd=1 then
+          begin
+            for res:=0 to FIgnoredCandidateProcs.count-1 do
+              begin
+                pd:=tprocdef(FIgnoredCandidateProcs[res]);
+                { stop searching when we start comparing methods of parent of
+                  the struct in which the current best method was found }
+                if assigned(pd.struct) and
+                   (pd.struct<>tprocdef(bestpd).struct) and
+                   tprocdef(bestpd).struct.is_related(pd.struct) then
+                  break;
+                if (pd.proctypeoption=bestpd.proctypeoption) and
+                   ((pd.procoptions*[po_classmethod,po_methodpointer])=(bestpd.procoptions*[po_classmethod,po_methodpointer])) and
+                   (compare_paras(pd.paras,bestpd.paras,cp_all,[cpo_ignorehidden,cpo_ignoreuniv,cpo_openequalisexact])=te_exact) then
+                  begin
+                    { first one encountered is closest in terms of visibility }
+                    bestpd:=pd;
+                    break;
+                  end;
+              end;
+          end;
         result:=cntpd;
       end;
 
@@ -2932,26 +3070,6 @@ implementation
       end;
 
 
-    procedure check_hints(const srsym: tsym; const symoptions: tsymoptions; const deprecatedmsg : pshortstring);
-      begin
-        if not assigned(srsym) then
-          internalerror(200602051);
-        if sp_hint_deprecated in symoptions then
-          if (sp_has_deprecated_msg in symoptions) and (deprecatedmsg <> nil) then
-            Message2(sym_w_deprecated_symbol_with_msg,srsym.realname,deprecatedmsg^)
-          else
-            Message1(sym_w_deprecated_symbol,srsym.realname);
-        if sp_hint_experimental in symoptions then
-          Message1(sym_w_experimental_symbol,srsym.realname);
-        if sp_hint_platform in symoptions then
-          Message1(sym_w_non_portable_symbol,srsym.realname);
-        if sp_hint_library in symoptions then
-          Message1(sym_w_library_symbol,srsym.realname);
-        if sp_hint_unimplemented in symoptions then
-          Message1(sym_w_non_implemented_symbol,srsym.realname);
-      end;
-
-
     procedure check_ranges(const location: tfileposinfo; source: tnode; destdef: tdef);
       begin
         if not(cs_check_ordinal_size in current_settings.localswitches) then

compiler/i386/hlcgcpu.pas

@@ -0,0 +1,45 @@
+{
+    Copyright (c) 1998-2010 by Florian Klaempfl and Jonas Maebe
+    Member of the Free Pascal development team
+
+    This unit contains routines to create a pass-through high-level code
+    generator. This is used by most regular code generators.
+
+    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 hlcgcpu;
+
+{$i fpcdefs.inc}
+
+interface
+
+  procedure create_hlcodegen;
+
+implementation
+
+  uses
+    hlcgobj, hlcgx86,
+    cgcpu;
+
+  procedure create_hlcodegen;
+    begin
+      hlcg:=thlcgx86.create;
+      create_codegen;
+    end;
+
+end.

compiler/i386/n386cal.pas

@@ -28,10 +28,10 @@ interface
 { $define AnsiStrRef}
 
     uses
-      ncgcal;
+      nx86cal;
 
     type
-       ti386callnode = class(tcgcallnode)
+       ti386callnode = class(tx86callnode)
        protected
           procedure pop_parasize(pop_size:longint);override;
           procedure extra_interrupt_code;override;

compiler/i386/n386set.pas

@@ -67,7 +67,6 @@ implementation
       end;
 
 
-
 begin
    ccasenode:=ti386casenode;
 end.

compiler/impdef.pas

@@ -46,6 +46,9 @@ interface
 
 implementation
 
+uses
+  cfileutl;
+
 {$IFDEF STANDALONE}
 var
   __textname : string;
@@ -170,7 +173,7 @@ procedure CreateTempDir(const s:string);
 procedure call_as(const name:string);
  begin
   FlushOutput;
-  ExecuteProcess(as_name,'-o '+name+'o '+name);
+  RequotedExecuteProcess(as_name,'-o '+name+'o '+name);
  end;
 procedure call_ar;
  var
@@ -186,7 +189,7 @@ procedure call_ar;
   If DOSError=0 then
    erase(f);
   FlushOutput;
-  ExecuteProcess(ar_name,'rs '+impname+' '+path+dirsep+'*.swo');
+  RequotedExecuteProcess(ar_name,'rs '+impname+' '+path+dirsep+'*.swo');
   cleardir(path,'*.sw');
   cleardir(path,'*.swo');
   {$push} {$I-}

compiler/jvm/aasmcpu.pas

@@ -0,0 +1,300 @@
+{
+    Copyright (c) 1999-2002 by Mazen Neifer
+
+    Contains the assembler object for the JVM
+
+    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 aasmcpu;
+
+{$i fpcdefs.inc}
+
+interface
+
+uses
+  cclasses,
+  globtype,globals,verbose,
+  aasmbase,aasmtai,aasmdata,aasmsym,
+  cgbase,cgutils,cpubase,cpuinfo,
+  widestr;
+
+    { fake, there are no "mov reg,reg" instructions here }
+    const
+      { "mov reg,reg" source operand number }
+      O_MOV_SOURCE = 0;
+      { "mov reg,reg" source operand number }
+      O_MOV_DEST = 0;
+
+    type
+
+      { taicpu }
+
+      taicpu = class(tai_cpu_abstract_sym)
+         constructor op_none(op : tasmop);
+
+         constructor op_reg(op : tasmop;_op1 : tregister);
+         constructor op_const(op : tasmop;_op1 : aint);
+         constructor op_ref(op : tasmop;const _op1 : treference);
+         constructor op_sym(op : tasmop;_op1 : tasmsymbol);
+
+         constructor op_sym_const(op : tasmop;_op1 : tasmsymbol;_op2 : aint);
+
+         constructor op_single(op : tasmop;_op1 : single);
+         constructor op_double(op : tasmop;_op1 : double);
+         constructor op_string(op : tasmop;_op1len : aint;_op1 : pchar);
+         constructor op_wstring(op : tasmop;_op1 : pcompilerwidestring);
+
+         procedure loadsingle(opidx:longint;f:single);
+         procedure loaddouble(opidx:longint;d:double);
+         procedure loadstr(opidx:longint;vallen: aint;pc: pchar);
+         procedure loadpwstr(opidx:longint;pwstr:pcompilerwidestring);
+
+
+         { register allocation }
+         function is_same_reg_move(regtype: Tregistertype):boolean; override;
+
+         { register spilling code }
+         function spilling_get_operation_type(opnr: longint): topertype;override;
+      end;
+
+      tai_align = class(tai_align_abstract)
+        { nothing to add }
+      end;
+
+    procedure InitAsm;
+    procedure DoneAsm;
+
+    function spilling_create_load(const ref:treference;r:tregister):Taicpu;
+    function spilling_create_store(r:tregister; const ref:treference):Taicpu;
+
+implementation
+
+{*****************************************************************************
+                                 taicpu Constructors
+*****************************************************************************}
+
+    constructor taicpu.op_none(op : tasmop);
+      begin
+        inherited create(op);
+      end;
+
+
+    constructor taicpu.op_reg(op : tasmop;_op1 : tregister);
+      begin
+        inherited create(op);
+        ops:=1;
+        loadreg(0,_op1);
+      end;
+
+
+    constructor taicpu.op_ref(op : tasmop;const _op1 : treference);
+      begin
+        inherited create(op);
+        ops:=1;
+        loadref(0,_op1);
+      end;
+
+
+    constructor taicpu.op_const(op : tasmop;_op1 : aint);
+      begin
+        inherited create(op);
+        ops:=1;
+        loadconst(0,_op1);
+      end;
+
+
+    constructor taicpu.op_sym(op : tasmop;_op1 : tasmsymbol);
+      begin
+        inherited create(op);
+        ops:=1;
+        is_jmp:=op in [a_if_acmpeq, a_if_acmpne, a_if_icmpeq, a_if_icmpge, a_if_icmpgt,
+          a_if_icmple, a_if_icmplt, a_if_icmpne,
+          a_ifeq, a_ifge, a_ifgt, a_ifle, a_iflt, a_ifne, a_ifnonnull, a_ifnull];
+        loadsymbol(0,_op1,0);
+      end;
+
+
+    constructor taicpu.op_sym_const(op: tasmop; _op1: tasmsymbol; _op2: aint);
+      begin
+        inherited create(op);
+        ops:=2;
+        loadsymbol(0,_op1,0);
+        loadconst(1,_op2);
+      end;
+
+
+    constructor taicpu.op_single(op: tasmop; _op1: single);
+      begin
+        inherited create(op);
+        ops:=1;
+        loadsingle(0,_op1);
+      end;
+
+
+    constructor taicpu.op_double(op: tasmop; _op1: double);
+      begin
+        inherited create(op);
+        ops:=1;
+        loaddouble(0,_op1);
+      end;
+
+    constructor taicpu.op_string(op: tasmop; _op1len: aint; _op1: pchar);
+      begin
+        inherited create(op);
+        ops:=1;
+        loadstr(0,_op1len,_op1);
+      end;
+
+    constructor taicpu.op_wstring(op: tasmop; _op1: pcompilerwidestring);
+      begin
+        inherited create(op);
+        ops:=1;
+        loadpwstr(0,_op1);
+      end;
+
+
+    procedure taicpu.loadsingle(opidx:longint;f:single);
+      begin
+        allocate_oper(opidx+1);
+        with oper[opidx]^ do
+         begin
+           if typ<>top_single then
+             clearop(opidx);
+           sval:=f;
+           typ:=top_single;
+         end;
+      end;
+
+
+    procedure taicpu.loaddouble(opidx: longint; d: double);
+      begin
+        allocate_oper(opidx+1);
+        with oper[opidx]^ do
+         begin
+           if typ<>top_double then
+             clearop(opidx);
+           dval:=d;
+           typ:=top_double;
+         end;
+      end;
+
+
+    procedure taicpu.loadstr(opidx: longint; vallen: aint; pc: pchar);
+      begin
+        allocate_oper(opidx+1);
+        with oper[opidx]^ do
+         begin
+           clearop(opidx);
+           pcvallen:=vallen;
+           getmem(pcval,vallen);
+           move(pc^,pcval^,vallen);
+           typ:=top_string;
+         end;
+      end;
+
+
+    procedure taicpu.loadpwstr(opidx:longint;pwstr:pcompilerwidestring);
+      begin
+        allocate_oper(opidx+1);
+        with oper[opidx]^ do
+         begin
+           clearop(opidx);
+           initwidestring(pwstrval);
+           copywidestring(pwstr,pwstrval);
+           typ:=top_wstring;
+         end;
+      end;
+
+
+    function taicpu.is_same_reg_move(regtype: Tregistertype):boolean;
+      begin
+        result:=false;
+      end;
+
+
+    function taicpu.spilling_get_operation_type(opnr: longint): topertype;
+      begin
+        case opcode of
+          a_iinc:
+            result:=operand_readwrite;
+          a_aastore,
+          a_astore,
+          a_astore_0,
+          a_astore_1,
+          a_astore_2,
+          a_astore_3,
+          a_bastore,
+          a_castore,
+          a_dastore,
+          a_dstore,
+          a_dstore_0,
+          a_dstore_1,
+          a_dstore_2,
+          a_dstore_3,
+          a_fastore,
+          a_fstore,
+          a_fstore_0,
+          a_fstore_1,
+          a_fstore_2,
+          a_fstore_3,
+          a_iastore,
+          a_istore,
+          a_istore_0,
+          a_istore_1,
+          a_istore_2,
+          a_istore_3,
+          a_lastore,
+          a_lstore,
+          a_lstore_0,
+          a_lstore_1,
+          a_lstore_2,
+          a_lstore_3,
+          a_sastore:
+            result:=operand_write;
+          else
+            result:=operand_read;
+        end;
+      end;
+
+
+    function spilling_create_load(const ref:treference;r:tregister):Taicpu;
+      begin
+       internalerror(2010122614);
+       result:=nil;
+      end;
+
+
+    function spilling_create_store(r:tregister; const ref:treference):Taicpu;
+      begin
+       internalerror(2010122615);
+       result:=nil;
+      end;
+
+
+    procedure InitAsm;
+      begin
+      end;
+
+
+    procedure DoneAsm;
+      begin
+      end;
+
+begin
+  cai_cpu:=taicpu;
+  cai_align:=tai_align;
+end.

compiler/jvm/cgcpu.pas

@@ -0,0 +1,129 @@
+{
+    Copyright (c) 2010 by Jonas Maebe
+
+    This unit implements the code generator for the Java VM
+
+    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 cgcpu;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+       globtype,parabase,
+       cgbase,cgutils,cgobj,
+       aasmbase,aasmtai,aasmdata,aasmcpu,
+       cpubase,cpuinfo,
+       node,symconst,SymType,symdef,
+       rgcpu;
+
+    type
+      TCgJvm=class(tcg)
+     public
+        procedure init_register_allocators;override;
+        procedure done_register_allocators;override;
+        function  getintregister(list:TAsmList;size:Tcgsize):Tregister;override;
+        function  getfpuregister(list:TAsmList;size:Tcgsize):Tregister;override;
+        function  getaddressregister(list:TAsmList):Tregister;override;
+        procedure do_register_allocation(list:TAsmList;headertai:tai);override;
+      end;
+
+    procedure create_codegen;
+
+implementation
+
+  uses
+    globals,verbose,systems,cutils,
+    paramgr,fmodule,
+    tgobj,
+    procinfo,cpupi;
+
+
+{****************************************************************************
+                              Assembler code
+****************************************************************************}
+
+    procedure tcgjvm.init_register_allocators;
+      begin
+        inherited init_register_allocators;
+{$ifndef cpu64bitaddr}
+        rg[R_INTREGISTER]:=Trgcpu.create(R_INTREGISTER,R_SUBD,
+          [RS_R0],first_int_imreg,[]);
+{$else not cpu64bitaddr}
+        rg[R_INTREGISTER]:=Trgcpu.create(R_INTREGISTER,R_SUBQ,
+          [RS_R0],first_int_imreg,[]);
+{$endif not cpu64bitaddr}
+        rg[R_FPUREGISTER]:=trgcpu.create(R_FPUREGISTER,R_SUBFS,
+          [RS_R0],first_fpu_imreg,[]);
+        rg[R_MMREGISTER]:=trgcpu.create(R_MMREGISTER,R_SUBNONE,
+          [RS_R0],first_mm_imreg,[]);
+      end;
+
+
+    procedure tcgjvm.done_register_allocators;
+      begin
+        rg[R_INTREGISTER].free;
+        rg[R_FPUREGISTER].free;
+        rg[R_MMREGISTER].free;
+        inherited done_register_allocators;
+      end;
+
+
+    function tcgjvm.getintregister(list:TAsmList;size:Tcgsize):Tregister;
+      begin
+        if not(size in [OS_64,OS_S64]) then
+          result:=rg[R_INTREGISTER].getregister(list,R_SUBD)
+        else
+          result:=rg[R_INTREGISTER].getregister(list,R_SUBQ);
+      end;
+
+
+    function tcgjvm.getfpuregister(list:TAsmList;size:Tcgsize):Tregister;
+      begin
+        if size=OS_F64 then
+          result:=rg[R_FPUREGISTER].getregister(list,R_SUBFD)
+        else
+          result:=rg[R_FPUREGISTER].getregister(list,R_SUBFS);
+      end;
+
+
+    function tcgjvm.getaddressregister(list:TAsmList):Tregister;
+      begin
+        { avoid problems in the compiler where int and addr registers are
+          mixed for now; we currently don't have to differentiate between the
+          two as far as the jvm backend is concerned }
+        result:=rg[R_INTREGISTER].getregister(list,R_SUBD)
+      end;
+
+
+    procedure tcgjvm.do_register_allocation(list:TAsmList;headertai:tai);
+      begin
+        { We only run the "register allocation" once for an arbitrary allocator,
+          which will perform the register->temp mapping for all register types.
+          This allows us to easily reuse temps. }
+        trgcpu(rg[R_INTREGISTER]).do_all_register_allocation(list,headertai);
+      end;
+
+
+    procedure create_codegen;
+      begin
+        cg:=tcgjvm.Create;
+      end;
+      
+end.

compiler/jvm/cpubase.pas

@@ -0,0 +1,336 @@
+{
+    Copyright (c) 2010 by Jonas Maebe
+
+    Contains the base types for the Java VM
+
+    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.
+
+ ****************************************************************************
+}
+{ This Unit contains the base types for the Java Virtual Machine
+}
+unit cpubase;
+
+{$i fpcdefs.inc}
+
+interface
+
+uses
+  globtype,
+  aasmbase,cpuinfo,cgbase;
+
+
+{*****************************************************************************
+                                Assembler Opcodes
+*****************************************************************************}
+
+    type
+      TAsmOp=(A_None,
+        a_aaload, a_aastore, a_aconst_null,
+        a_aload, a_aload_0, a_aload_1, a_aload_2, a_aload_3,
+        a_anewarray, a_areturn, a_arraylength,
+        a_astore, a_astore_0, a_astore_1, a_astore_2, a_astore_3,
+        a_athrow, a_baload, a_bastore, a_bipush, a_breakpoint,
+        a_caload, a_castore, a_checkcast,
+        a_d2f, a_d2i, a_d2l, a_dadd, a_daload, a_dastore, a_dcmpg, a_dcmpl,
+        a_dconst_0, a_dconst_1, a_ddiv,
+        a_dload, a_dload_0, a_dload_1, a_dload_2, a_dload_3,
+        a_dmul, a_dneg, a_drem, a_dreturn,
+        a_dstore, a_dstore_0, a_dstore_1, a_dstore_2, a_dstore_3,
+        a_dsub,
+        a_dup, a_dup2, a_dup2_x1, a_dup2_x2, a_dup_x1, a_dup_x2,
+        a_f2d, a_f2i, a_f2l, a_fadd, a_faload, a_fastore, a_fcmpg, a_fcmpl,
+        a_fconst_0, a_fconst_1, a_fconst_2, a_fdiv,
+        a_fload, a_fload_0, a_fload_1, a_fload_2, a_fload_3,
+        a_fmul, a_fneg, a_frem, a_freturn,
+        a_fstore, a_fstore_0, a_fstore_1, a_fstore_2, a_fstore_3,
+        a_fsub,
+        a_getfield, a_getstatic,
+        a_goto, a_goto_w,
+        a_i2b, a_i2c, a_i2d, a_i2f, a_i2l, a_i2s,
+        a_iadd, a_iaload, a_iand, a_iastore,
+        a_iconst_m1, a_iconst_0, a_iconst_1, a_iconst_2, a_iconst_3,
+        a_iconst_4, a_iconst_5,
+        a_idiv,
+        a_if_acmpeq, a_if_acmpne, a_if_icmpeq, a_if_icmpge, a_if_icmpgt,
+        a_if_icmple, a_if_icmplt, a_if_icmpne,
+        a_ifeq, a_ifge, a_ifgt, a_ifle, a_iflt, a_ifne, a_ifnonnull, a_ifnull,
+        a_iinc,
+        a_iload, a_iload_0, a_iload_1, a_iload_2, a_iload_3,
+        a_imul, a_ineg,
+        a_instanceof,
+        a_invokeinterface, a_invokespecial, a_invokestatic, a_invokevirtual,
+        a_ior, a_irem, a_ireturn, a_ishl, a_ishr,
+        a_istore, a_istore_0, a_istore_1, a_istore_2, a_istore_3,
+        a_isub, a_iushr, a_ixor,
+        a_jsr, a_jsr_w,
+        a_l2d, a_l2f, a_l2i, a_ladd, a_laload, a_land, a_lastore, a_lcmp,
+        a_lconst_0, a_lconst_1,
+        a_ldc, a_ldc2_w, a_ldc_w, a_ldiv,
+        a_lload, a_lload_0, a_lload_1, a_lload_2, a_lload_3,
+        a_lmul, a_lneg,
+        a_lookupswitch,
+        a_lor, a_lrem,
+        a_lreturn,
+        a_lshl, a_lshr,
+        a_lstore, a_lstore_0, a_lstore_1, a_lstore_2, a_lstore_3,
+        a_lsub, a_lushr, a_lxor,
+        a_monitorenter,
+        a_monitorexit,
+        a_multianewarray,
+        a_new,
+        a_newarray,
+        a_nop,
+        a_pop, a_pop2,
+        a_putfield, a_putstatic,
+        a_ret, a_return,
+        a_saload, a_sastore, a_sipush,
+        a_swap,
+        a_tableswitch,
+        a_wide
+      );
+
+      {# This should define the array of instructions as string }
+      op2strtable=array[tasmop] of string[8];
+
+    Const
+      {# First value of opcode enumeration }
+      firstop = low(tasmop);
+      {# Last value of opcode enumeration  }
+      lastop  = high(tasmop);
+
+
+{*****************************************************************************
+                                  Registers
+*****************************************************************************}
+
+    type
+      { Number of registers used for indexing in tables }
+      tregisterindex=0..{$i rjvmnor.inc}-1;
+      totherregisterset = set of tregisterindex;
+
+    const
+      { Available Superregisters }
+      {$i rjvmsup.inc}
+
+      { No Subregisters }
+      R_SUBWHOLE = R_SUBNONE;
+
+      { Available Registers }
+      {$i rjvmcon.inc}
+
+      { aliases }
+      { used as base register in references for parameters passed to
+        subroutines: these are passed on the evaluation stack, but this way we
+        can use the offset field to indicate the order, which is used by ncal
+        to sort the parameters }
+      NR_EVAL_STACK_BASE = NR_R0;
+
+      maxvarregs = 1;
+      maxfpuvarregs = 1;
+
+      { Integer Super registers first and last }
+      first_int_imreg = 10;
+
+      { Float Super register first and last }
+      first_fpu_imreg     = 10;
+
+      { MM Super register first and last }
+      first_mm_imreg     = 10;
+
+      regnumber_table : array[tregisterindex] of tregister = (
+        {$i rjvmnum.inc}
+      );
+
+     EVALSTACKLOCS = [LOC_REGISTER,LOC_CREGISTER,LOC_FPUREGISTER,LOC_CFPUREGISTER,
+       LOC_MMREGISTER,LOC_CMMREGISTER,LOC_SUBSETREG,LOC_CSUBSETREG];
+
+{*****************************************************************************
+                                Conditions
+*****************************************************************************}
+
+   type
+     // not used by jvm target
+     TAsmCond=(C_None);
+
+{*****************************************************************************
+                                 Constants
+*****************************************************************************}
+
+    const
+      max_operands = 2;
+
+
+{*****************************************************************************
+                          Default generic sizes
+*****************************************************************************}
+
+{$ifdef cpu64bitaddr}
+      {# Defines the default address size for a processor,
+        -- fake for JVM, only influences default width of
+           arithmetic calculations }
+      OS_ADDR = OS_64;
+      {# the natural int size for a processor,             }
+      OS_INT = OS_64;
+      OS_SINT = OS_S64;
+{$else}
+      {# Defines the default address size for a processor,
+        -- fake for JVM, only influences default width of
+           arithmetic calculations }
+      OS_ADDR = OS_32;
+      {# the natural int size for a processor,             }
+      OS_INT = OS_32;
+      OS_SINT = OS_S32;
+{$endif}
+      {# the maximum float size for a processor,           }
+      OS_FLOAT = OS_F64;
+      {# the size of a vector register for a processor     }
+      OS_VECTOR = OS_M128;
+
+{*****************************************************************************
+                          Generic Register names
+*****************************************************************************}
+
+      { dummies, not used for JVM }
+
+      {# Stack pointer register }
+      { used as base register in references to indicate that it's a local }
+      NR_STACK_POINTER_REG = NR_R1;
+      RS_STACK_POINTER_REG = RS_R1;
+      {# Frame pointer register }
+      NR_FRAME_POINTER_REG = NR_STACK_POINTER_REG;
+      RS_FRAME_POINTER_REG = RS_STACK_POINTER_REG;
+
+      { Java results are returned on the evaluation stack, not via a register }
+
+      { Results are returned in this register (32-bit values) }
+      NR_FUNCTION_RETURN_REG = NR_NO;
+      RS_FUNCTION_RETURN_REG = RS_NO;
+      { Low part of 64bit return value }
+      NR_FUNCTION_RETURN64_LOW_REG = NR_NO;
+      RS_FUNCTION_RETURN64_LOW_REG = RS_NO;
+      { High part of 64bit return value }
+      NR_FUNCTION_RETURN64_HIGH_REG = NR_NO;
+      RS_FUNCTION_RETURN64_HIGH_REG = RS_NO;
+      { The value returned from a function is available in this register }
+      NR_FUNCTION_RESULT_REG = NR_FUNCTION_RETURN_REG;
+      RS_FUNCTION_RESULT_REG = RS_FUNCTION_RETURN_REG;
+      { The lowh part of 64bit value returned from a function }
+      NR_FUNCTION_RESULT64_LOW_REG = NR_FUNCTION_RETURN64_LOW_REG;
+      RS_FUNCTION_RESULT64_LOW_REG = RS_FUNCTION_RETURN64_LOW_REG;
+      { The high part of 64bit value returned from a function }
+      NR_FUNCTION_RESULT64_HIGH_REG = NR_FUNCTION_RETURN64_HIGH_REG;
+      RS_FUNCTION_RESULT64_HIGH_REG = RS_FUNCTION_RETURN64_HIGH_REG;
+
+      NR_FPU_RESULT_REG = NR_NO;
+      NR_MM_RESULT_REG = NR_NO;
+
+
+{*****************************************************************************
+                       GCC /ABI linking information
+*****************************************************************************}
+
+      { dummies, not used for JVM }
+
+      {# Registers which must be saved when calling a routine
+
+      }
+      saved_standard_registers : array[0..0] of tsuperregister = (
+        RS_NO
+      );
+
+      { this is only for the generic code which is not used for this architecture }
+      saved_mm_registers : array[0..0] of tsuperregister = (RS_NO);
+
+      {# Required parameter alignment when calling a routine
+      }
+      std_param_align = 1;
+
+
+{*****************************************************************************
+                            CPU Dependent Constants
+*****************************************************************************}
+
+      maxfpuregs = 0;
+
+{*****************************************************************************
+                                  Helpers
+*****************************************************************************}
+
+    function cgsize2subreg(regtype: tregistertype; s:Tcgsize):Tsubregister;
+    function reg_cgsize(const reg: tregister) : tcgsize;
+
+    function std_regnum_search(const s:string):Tregister;
+    function std_regname(r:Tregister):string;
+    function findreg_by_number(r:Tregister):tregisterindex;
+
+implementation
+
+uses
+  rgbase;
+
+{*****************************************************************************
+                                  Helpers
+*****************************************************************************}
+
+    const
+      std_regname_table : array[tregisterindex] of string[15] = (
+        {$i rjvmstd.inc}
+      );
+
+      regnumber_index : array[tregisterindex] of tregisterindex = (
+        {$i rjvmrni.inc}
+      );
+
+      std_regname_index : array[tregisterindex] of tregisterindex = (
+        {$i rjvmsri.inc}
+      );
+
+    function reg_cgsize(const reg: tregister): tcgsize;
+      begin
+        result:=OS_NO;
+      end;
+
+
+    function cgsize2subreg(regtype: tregistertype; s:Tcgsize):Tsubregister;
+      begin
+        cgsize2subreg:=R_SUBNONE;
+      end;
+
+
+    function std_regnum_search(const s:string):Tregister;
+      begin
+        result:=NR_NO;
+      end;
+
+
+    function findreg_by_number(r:Tregister):tregisterindex;
+      begin
+        result:=findreg_by_number_table(r,regnumber_index);
+      end;
+
+    function std_regname(r:Tregister):string;
+      var
+        p : tregisterindex;
+      begin
+        p:=findreg_by_number_table(r,regnumber_index);
+        if p<>0 then
+          result:=std_regname_table[p]
+        else
+          result:=generic_regname(r);
+      end;
+
+
+end.

compiler/jvm/cpuinfo.pas

@@ -0,0 +1,78 @@
+{
+    Copyright (c) 2010 by the Free Pascal development team
+
+    Basic Processor information for the Java VM
+
+    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.
+
+ **********************************************************************}
+
+Unit cpuinfo;
+
+Interface
+
+  uses
+    globtype;
+
+Type
+   bestreal = double;
+   ts32real = single;
+   ts64real = double;
+   ts80real = extended;
+   ts128real = extended;
+   ts64comp = comp;
+
+   pbestreal=^bestreal;
+
+   { possible supported processors for this target }
+   tcputype =
+      (cpu_none,
+       { jvm, same as cpu_none }
+       cpu_jvm,
+       { jvm byte code to be translated into Dalvik bytecode: more type-
+         sensitive }
+       cpu_dalvik
+      );
+
+   tfputype =
+     (fpu_none,
+      fpu_standard
+     );
+
+
+Const
+   { calling conventions supported by the code generator }
+   supported_calling_conventions : tproccalloptions = [
+     pocall_internproc
+   ];
+
+   cputypestr : array[tcputype] of string[9] = ('',
+     'JVM',
+     'JVMDALVIK'
+   );
+
+   fputypestr : array[tfputype] of string[8] = (
+     'NONE',
+     'STANDARD'
+   );
+
+   { Supported optimizations, only used for information }
+   supported_optimizerswitches = genericlevel1optimizerswitches+
+                                 genericlevel2optimizerswitches+
+                                 genericlevel3optimizerswitches-
+                                 { no need to write info about those }
+                                 [cs_opt_level1,cs_opt_level2,cs_opt_level3]+
+                                 [cs_opt_loopunroll,cs_opt_nodecse];
+
+   level1optimizerswitches = genericlevel1optimizerswitches;
+   level2optimizerswitches = genericlevel2optimizerswitches + level1optimizerswitches + [cs_opt_nodecse];
+   level3optimizerswitches = genericlevel3optimizerswitches + level2optimizerswitches + [{,cs_opt_loopunroll}];
+
+Implementation
+
+end.

compiler/jvm/cpunode.pas

@@ -0,0 +1,40 @@
+{******************************************************************************
+    Copyright (c) 2000-2010 by Florian Klaempfl and Jonas Maebe
+
+    Includes the JVM code generator
+
+    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 cpunode;
+
+{$I fpcdefs.inc}
+
+interface
+{ This unit is used to define the specific CPU implementations. All needed
+actions are included in the INITALIZATION part of these units. This explains
+the behaviour of such a unit having just a USES clause! }
+
+implementation
+
+  uses
+    ncgbas,ncgflw,ncgcnv,ncgld,ncgmem,ncgcon,ncgset,
+    ncgadd, ncgcal,ncgmat,ncginl,
+    njvmadd,njvmcal,njvmmat,njvmcnv,njvmcon,njvminl,njvmmem,njvmflw,njvmld,
+    njvmset
+    { these are not really nodes }
+    ,rgcpu,tgcpu,njvmutil,njvmtcon;
+
+end.

compiler/jvm/cpupara.pas

@@ -0,0 +1,263 @@
+{
+    Copyright (c) 1998-2010 by Florian Klaempfl, Jonas Maebe
+
+    Calling conventions for the JVM
+
+    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 cpupara;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+      globtype,
+      cclasses,
+      aasmtai,aasmdata,
+      cpubase,cpuinfo,
+      symconst,symbase,symsym,symtype,symdef,paramgr,parabase,cgbase,cgutils;
+
+    type
+
+      { 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_copyout_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)}
+        procedure getintparaloc(calloption : tproccalloption; nr : longint;var cgpara : TCGPara);override;
+        function  create_paraloc_info(p : TAbstractProcDef; side: tcallercallee):longint;override;
+        function  get_funcretloc(p : tabstractprocdef; side: tcallercallee; def: tdef): tcgpara;override;
+        function param_use_paraloc(const cgpara: tcgpara): boolean; override;
+        function ret_in_param(def: tdef; calloption: tproccalloption): boolean; override;
+        function is_stack_paraloc(paraloc: pcgparalocation): boolean;override;
+      private
+        procedure create_funcretloc_info(p : tabstractprocdef; side: tcallercallee);
+        procedure create_paraloc_info_intern(p : tabstractprocdef; side: tcallercallee; paras: tparalist;
+                                             var parasize:longint);
+      end;
+
+implementation
+
+    uses
+      cutils,verbose,systems,
+      defutil,jvmdef,
+      aasmcpu,
+      hlcgobj;
+
+
+    procedure TJVMParaManager.GetIntParaLoc(calloption : tproccalloption; nr : longint;var cgpara : tcgpara);
+      begin
+        { don't know whether it's an actual integer or a pointer (necessary for cgpara.def) }
+        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
+        result:=
+          jvmimplicitpointertype(def) or
+          ((def.typ=formaldef) and
+           not(varspez in [vs_var,vs_out]));
+      end;
+
+
+    function TJVMParaManager.push_copyout_param(varspez: tvarspez; def: tdef; calloption: tproccalloption): boolean;
+      begin
+        { in principle also for vs_constref, but since we can't have real
+          references, that won't make a difference }
+        result:=
+          (varspez in [vs_var,vs_out,vs_constref]) and
+          not 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;
+
+
+    procedure TJVMParaManager.create_funcretloc_info(p : tabstractprocdef; side: tcallercallee);
+      begin
+        p.funcretloc[side]:=get_funcretloc(p,side,p.returndef);
+      end;
+
+
+    function TJVMParaManager.get_funcretloc(p : tabstractprocdef; side: tcallercallee; def: tdef): tcgpara;
+      var
+        paraloc : pcgparalocation;
+        retcgsize  : tcgsize;
+      begin
+        def:=get_para_push_size(def);
+        result.init;
+        result.alignment:=get_para_align(p.proccalloption);
+        result.def:=def;
+        { void has no location }
+        if is_void(def) then
+          begin
+            paraloc:=result.add_location;
+            result.size:=OS_NO;
+            result.intsize:=0;
+            paraloc^.size:=OS_NO;
+            paraloc^.loc:=LOC_VOID;
+            exit;
+          end;
+        { Constructors return self instead of a boolean }
+        if (p.proctypeoption=potype_constructor) then
+          begin
+            retcgsize:=OS_INT;
+            result.intsize:=sizeof(pint);
+          end
+        else
+          begin
+            retcgsize:=def_cgsize(def);
+            result.intsize:=def.size;
+          end;
+        result.size:=retcgsize;
+
+        paraloc:=result.add_location;
+        { all values are returned on the evaluation stack }
+        paraloc^.loc:=LOC_REFERENCE;
+        paraloc^.reference.index:=NR_EVAL_STACK_BASE;
+        paraloc^.reference.offset:=0;
+      end;
+
+    function TJVMParaManager.param_use_paraloc(const cgpara: tcgpara): boolean;
+      begin
+        { all parameters are copied by the VM to local variable locations }
+        result:=true;
+      end;
+
+    function TJVMParaManager.ret_in_param(def: tdef; calloption: tproccalloption): boolean;
+      begin
+        { not as efficient as returning in param for jvmimplicitpointertypes,
+          but in the latter case the routines are harder to use from Java
+          (especially for arrays), because the caller then manually has to
+          allocate the instance/array of the right size }
+        Result:=false;
+      end;
+
+    function TJVMParaManager.is_stack_paraloc(paraloc: pcgparalocation): boolean;
+      begin
+        { all parameters are passed on the evaluation stack }
+        result:=true;
+      end;
+
+
+    procedure TJVMParaManager.create_paraloc_info_intern(p : tabstractprocdef; side: tcallercallee;paras:tparalist;
+                                                           var parasize:longint);
+      var
+        paraloc      : pcgparalocation;
+        i            : integer;
+        hp           : tparavarsym;
+        paracgsize   : tcgsize;
+        paraofs      : longint;
+        paradef      : tdef;
+      begin
+        paraofs:=0;
+        for i:=0 to paras.count-1 do
+          begin
+            hp:=tparavarsym(paras[i]);
+            if push_copyout_param(hp.varspez,hp.vardef,p.proccalloption) then
+              begin
+                { passed via array reference (instead of creating a new array
+                  type for every single parameter, use java_jlobject) }
+                paracgsize:=OS_ADDR;
+                paradef:=java_jlobject;
+              end
+            else
+              begin
+                paracgsize:=def_cgsize(hp.vardef);
+                if paracgsize=OS_NO then
+                  paracgsize:=OS_ADDR;
+                paradef:=hp.vardef;
+              end;
+            paradef:=get_para_push_size(paradef);
+            hp.paraloc[side].reset;
+            hp.paraloc[side].size:=paracgsize;
+            hp.paraloc[side].def:=paradef;
+            hp.paraloc[side].alignment:=std_param_align;
+            hp.paraloc[side].intsize:=tcgsize2size[paracgsize];
+            paraloc:=hp.paraloc[side].add_location;
+            { All parameters are passed on the evaluation stack, pushed from
+              left to right (including self, if applicable). At the callee side,
+              they're available as local variables 0..n-1 (with 64 bit values
+              taking up two slots) }
+            paraloc^.loc:=LOC_REFERENCE;;
+            paraloc^.reference.offset:=paraofs;
+            case side of
+              callerside:
+                begin
+                  paraloc^.loc:=LOC_REFERENCE;
+                  { we use a fake loc_reference to indicate the stack location;
+                    the offset (set above) will be used by ncal to order the
+                    parameters so they will be pushed in the right order }
+                  paraloc^.reference.index:=NR_EVAL_STACK_BASE;
+                end;
+              calleeside:
+                begin
+                  paraloc^.loc:=LOC_REFERENCE;
+                  paraloc^.reference.index:=NR_STACK_POINTER_REG;
+                end;
+            end;
+            { 2 slots for 64 bit integers and floats, 1 slot for the rest }
+            if not(is_64bit(paradef) or
+                   ((paradef.typ=floatdef) and
+                    (tfloatdef(paradef).floattype=s64real))) then
+              inc(paraofs)
+            else
+              inc(paraofs,2);
+          end;
+        parasize:=paraofs;
+      end;
+
+
+    function TJVMParaManager.create_paraloc_info(p : tabstractprocdef; side: tcallercallee):longint;
+      var
+        parasize : longint;
+      begin
+        parasize:=0;
+        create_paraloc_info_intern(p,side,p.paras,parasize);
+        { Create Function result paraloc }
+        create_funcretloc_info(p,side);
+        { We need to return the size allocated on the stack }
+        result:=parasize;
+      end;
+
+
+begin
+   ParaManager:=TJVMParaManager.create;
+end.

compiler/jvm/cpupi.pas

@@ -0,0 +1,65 @@
+{
+    Copyright (c) 2002-2010 by Florian Klaempfl and Jonas Maebe
+
+    This unit contains the CPU specific part of tprocinfo
+
+    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 cpupi;
+
+{$i fpcdefs.inc}
+
+interface
+
+  uses
+    cutils,
+    procinfo,cpuinfo,
+    psub;
+
+  type
+
+    { TSparcProcInfo }
+
+    TJVMProcInfo=class(tcgprocinfo)
+    public
+      procedure set_first_temp_offset;override;
+    end;
+
+implementation
+
+    uses
+      systems,globals,
+      tgobj,paramgr,symconst;
+
+    procedure TJVMProcInfo.set_first_temp_offset;
+      begin
+        {
+          Stackframe layout:
+          sp:
+            <incoming parameters>
+          sp+first_temp_offset:
+            <locals>
+            <temp>
+        }
+        procdef.init_paraloc_info(calleeside);
+        tg.setfirsttemp(procdef.calleeargareasize);
+      end;
+
+
+begin
+  cprocinfo:=TJVMProcInfo;
+end.

compiler/jvm/cputarg.pas

@@ -0,0 +1,64 @@
+{
+    Copyright (c) 2001-2010 by Peter Vreman and Jonas Maebe
+
+    Includes the JVM dependent target units
+
+    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 cputarg;
+
+{$i fpcdefs.inc}
+
+interface
+
+
+implementation
+
+    uses
+      systems { prevent a syntax error when nothing is included }
+
+{$ifndef NOOPT}
+//      ,aoptcpu
+{$endif NOOPT}
+
+{**************************************
+             Targets
+**************************************}
+
+    {$ifndef NOTARGETSUNOS}
+      ,t_jvm
+    {$endif}
+
+{**************************************
+             Assemblers
+**************************************}
+
+      ,agjasmin
+
+{**************************************
+        Assembler Readers
+**************************************}
+
+{**************************************
+             Debuginfo
+**************************************}
+
+      ,dbgjasm
+
+      ;
+
+end.

compiler/jvm/dbgjasm.pas

@@ -0,0 +1,202 @@
+{
+    Copyright (c) 2003-2006 by Peter Vreman, Florian Klaempfl, and Jonas Maebe
+
+    This units contains support for Jasmin debug info generation
+
+    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 dbgjasm;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+      cclasses,globtype,
+      aasmbase,aasmtai,aasmdata,
+      symbase,symconst,symtype,symdef,symsym,
+      finput,
+      DbgBase;
+
+    type
+      { TDebugInfoJasmin }
+
+      TDebugInfoJasmin=class(TDebugInfo)
+      protected
+        fcurrprocstart,
+        fcurrprocend: tasmsymbol;
+
+        procedure appendsym_localsym(list: TAsmList; sym: tabstractnormalvarsym);
+
+        procedure appendsym_paravar(list:TAsmList;sym:tparavarsym);override;
+        procedure appendsym_localvar(list:TAsmList;sym:tlocalvarsym);override;
+        procedure beforeappenddef(list:TAsmList;def:tdef);override;
+        procedure appendprocdef(list:TAsmList;def:tprocdef);override;
+      public
+        procedure inserttypeinfo;override;
+        procedure insertlineinfo(list:TAsmList);override;
+      end;
+
+implementation
+
+    uses
+      sysutils,cutils,cfileutl,constexp,
+      version,globals,verbose,systems,
+      cpubase,cpuinfo,cgbase,paramgr,
+      fmodule,
+      defutil,symtable,jvmdef,ppu
+      ;
+
+{****************************************************************************
+                              TDebugInfoJasmin
+****************************************************************************}
+
+  procedure TDebugInfoJasmin.appendsym_localsym(list: TAsmList; sym: tabstractnormalvarsym);
+    var
+      jvar: tai_jvar;
+      proc: tprocdef;
+    begin
+      if tdef(sym.owner.defowner).typ<>procdef then
+        exit;
+      if not(sym.localloc.loc in [LOC_REFERENCE,LOC_CREFERENCE]) then
+        exit;
+      proc:=tprocdef(sym.owner.defowner);
+      jvar:=tai_jvar.create(sym.localloc.reference.offset,jvmmangledbasename(sym,true),fcurrprocstart,fcurrprocend);
+      proc.exprasmlist.InsertAfter(jvar,proc.procstarttai);
+    end;
+
+
+  procedure TDebugInfoJasmin.appendsym_paravar(list: TAsmList; sym: tparavarsym);
+    begin
+      appendsym_localsym(list,sym);
+    end;
+
+
+  procedure TDebugInfoJasmin.appendsym_localvar(list: TAsmList; sym: tlocalvarsym);
+    begin
+      appendsym_localsym(list,sym);
+    end;
+
+
+  procedure TDebugInfoJasmin.beforeappenddef(list: TAsmList; def: tdef);
+    begin
+    end;
+
+
+  procedure TDebugInfoJasmin.appendprocdef(list: TAsmList; def: tprocdef);
+    var
+      procstartlabel,
+      procendlabel    : tasmlabel;
+    begin
+      { insert debug information for local variables and parameters, but only
+        for routines implemented in the Pascal code }
+      if not assigned(def.procstarttai) then
+        exit;
+
+      current_asmdata.getlabel(procstartlabel,alt_dbgtype);
+      current_asmdata.getlabel(procendlabel,alt_dbgtype);
+      def.exprasmlist.insertafter(tai_label.create(procstartlabel),def.procstarttai);
+      def.exprasmlist.insertbefore(tai_label.create(procendlabel),def.procendtai);
+
+      fcurrprocstart:=procstartlabel;
+      fcurrprocend:=procendlabel;
+
+      write_symtable_parasyms(list,def.paras);
+      { not assigned for unit init }
+      if assigned(def.localst) then
+        write_symtable_syms(list,def.localst);
+    end;
+
+
+  procedure TDebugInfoJasmin.inserttypeinfo;
+    begin
+      { write all procedures and methods }
+      if assigned(current_module.globalsymtable) then
+        write_symtable_procdefs(nil,current_module.globalsymtable);
+      if assigned(current_module.localsymtable) then
+        write_symtable_procdefs(nil,current_module.localsymtable);
+    end;
+
+  procedure TDebugInfoJasmin.insertlineinfo(list: TAsmList);
+    var
+      currfileinfo,
+      lastfileinfo : tfileposinfo;
+      nolineinfolevel : Integer;
+      currfuncname : pshortstring;
+      hp : tai;
+    begin
+      FillChar(lastfileinfo,sizeof(lastfileinfo),0);
+      hp:=Tai(list.first);
+      nolineinfolevel:=0;
+      while assigned(hp) do
+        begin
+          case hp.typ of
+            ait_function_name :
+              begin
+                currfuncname:=tai_function_name(hp).funcname;
+                list.concat(tai_comment.Create(strpnew('function: '+currfuncname^)));
+              end;
+            ait_force_line :
+              begin
+                lastfileinfo.line:=-1;
+              end;
+            ait_marker :
+              begin
+                case tai_marker(hp).kind of
+                  mark_NoLineInfoStart:
+                    inc(nolineinfolevel);
+                  mark_NoLineInfoEnd:
+                    dec(nolineinfolevel);
+                end;
+              end;
+          end;
+
+          { Java does not support multiple source files }
+          if (hp.typ=ait_instruction) and
+             (nolineinfolevel=0) and
+             (tailineinfo(hp).fileinfo.fileindex=main_module.unit_index) then
+            begin
+              currfileinfo:=tailineinfo(hp).fileinfo;
+
+              { line changed ? }
+              if (lastfileinfo.line<>currfileinfo.line) and (currfileinfo.line<>0) then
+                begin
+                  { line directive }
+                  list.insertbefore(tai_directive.Create(asd_jline,tostr(currfileinfo.line)),hp);
+                end;
+              lastfileinfo:=currfileinfo;
+            end;
+
+          hp:=tai(hp.next);
+        end;
+    end;
+
+
+{****************************************************************************
+****************************************************************************}
+    const
+      dbg_jasmin_info : tdbginfo =
+         (
+           id     : dbg_jasmin;
+           idtxt  : 'JASMIN';
+         );
+
+
+initialization
+  RegisterDebugInfo(dbg_jasmin_info,TDebugInfoJasmin);
+
+end.

compiler/jvm/hlcgcpu.pas

@@ -0,0 +1,2320 @@
+{
+    Copyright (c) 1998-2010 by Florian Klaempfl and Jonas Maebe
+    Member of the Free Pascal development team
+
+    This unit implements the jvm high level code generator
+
+    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 hlcgcpu;
+
+{$i fpcdefs.inc}
+
+interface
+
+uses
+  globtype,
+  aasmbase,aasmdata,
+  symbase,symconst,symtype,symdef,symsym,
+  cpubase, hlcgobj, cgbase, cgutils, parabase;
+
+  type
+
+    { thlcgjvm }
+
+    thlcgjvm = class(thlcgobj)
+     private
+      fevalstackheight,
+      fmaxevalstackheight: longint;
+     public
+      constructor create;
+
+      procedure incstack(list : TAsmList;slots: longint);
+      procedure decstack(list : TAsmList;slots: longint);
+
+      function def2regtyp(def: tdef): tregistertype; override;
+
+      procedure a_load_const_cgpara(list : TAsmList;tosize : tdef;a : aint;const cgpara : TCGPara);override;
+
+      procedure a_call_name(list : TAsmList;pd : tprocdef;const s : TSymStr; weak: boolean);override;
+      procedure a_call_name_inherited(list : TAsmList;pd : tprocdef;const s : TSymStr);override;
+
+      procedure a_load_const_reg(list : TAsmList;tosize : tdef;a : aint;register : tregister);override;
+      procedure a_load_const_ref(list : TAsmList;tosize : tdef;a : aint;const ref : treference);override;
+      procedure a_load_reg_ref(list : TAsmList;fromsize, tosize : tdef;register : tregister;const ref : treference);override;
+      procedure a_load_reg_reg(list : TAsmList;fromsize, tosize : tdef;reg1,reg2 : tregister);override;
+      procedure a_load_ref_reg(list : TAsmList;fromsize, tosize : tdef;const ref : treference;register : tregister);override;
+      procedure a_load_ref_ref(list : TAsmList;fromsize, tosize : tdef;const sref : treference;const dref : treference);override;
+      procedure a_loadaddr_ref_reg(list : TAsmList;fromsize, tosize : tdef;const ref : treference;r : tregister);override;
+
+      procedure a_op_const_reg(list: TAsmList; Op: TOpCG; size: tdef; a: Aint; reg: TRegister); override;
+      procedure a_op_const_reg_reg(list: TAsmList; op: TOpCg; size: tdef; a: aint; src, dst: tregister); override;
+      procedure a_op_const_ref(list: TAsmList; Op: TOpCG; size: tdef; a: Aint; const ref: TReference); override;
+
+      procedure a_op_ref_reg(list: TAsmList; Op: TOpCG; size: tdef; const ref: TReference; reg: TRegister); override;
+      procedure a_op_reg_reg_reg(list: TAsmList; op: TOpCg; size: tdef; src1, src2, dst: tregister); override;
+      procedure a_op_reg_reg(list: TAsmList; Op: TOpCG; size: tdef; reg1, reg2: TRegister); override;
+
+      procedure a_cmp_const_ref_label(list: TAsmList; size: tdef; cmp_op: topcmp; a: aint; const ref: treference; l: tasmlabel); override;
+      procedure a_cmp_const_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; a: aint; reg: tregister; l: tasmlabel); override;
+      procedure a_cmp_ref_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; const ref: treference; reg: tregister; l: tasmlabel); override;
+      procedure a_cmp_reg_ref_label(list: TAsmList; size: tdef; cmp_op: topcmp; reg: tregister; const ref: treference; l: tasmlabel); override;
+      procedure a_cmp_reg_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; reg1, reg2: tregister; l: tasmlabel); override;
+
+      procedure a_jmp_always(list : TAsmList;l: tasmlabel); override;
+
+      procedure g_concatcopy(list : TAsmList;size: tdef; const source,dest : treference);override;
+      procedure g_copyshortstring(list : TAsmList;const source,dest : treference;strdef:tstringdef);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;
+      procedure a_loadfpu_reg_reg(list: TAsmList; fromsize, tosize: tdef; reg1, reg2: tregister); override;
+
+      procedure g_proc_entry(list : TAsmList;localsize : longint;nostackframe:boolean); override;
+      procedure g_proc_exit(list : TAsmList;parasize:longint;nostackframe:boolean); override;
+
+      procedure gen_load_return_value(list:TAsmList);override;
+      procedure record_generated_code_for_procdef(pd: tprocdef; code, data: TAsmList); override;
+
+      procedure g_incrrefcount(list : TAsmList;t: tdef; const ref: treference);override;
+      procedure g_array_rtti_helper(list: TAsmList; t: tdef; const ref: treference; const highloc: tlocation; const name: string); override;
+      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;
+
+      procedure gen_initialize_code(list: TAsmList); override;
+
+      procedure gen_entry_code(list: TAsmList); override;
+      procedure gen_exit_code(list: TAsmList); override;
+
+      { JVM-specific routines }
+
+      procedure a_load_stack_reg(list : TAsmList;size: tdef;reg: tregister);
+      { extra_slots are the slots that are used by the reference, and that
+        will be removed by the store operation }
+      procedure a_load_stack_ref(list : TAsmList;size: tdef;const ref: treference;extra_slots: longint);
+      procedure a_load_reg_stack(list : TAsmList;size: tdef;reg: tregister);
+      { extra_slots are the slots that are used by the reference, and that
+        will be removed by the load operation }
+      procedure a_load_ref_stack(list : TAsmList;size: tdef;const ref: treference;extra_slots: longint);
+      procedure a_load_const_stack(list : TAsmList;size: tdef;a :aint; typ: TRegisterType);
+
+      procedure a_load_stack_loc(list : TAsmList;size: tdef;const loc: tlocation);
+      procedure a_load_loc_stack(list : TAsmList;size: tdef;const loc: tlocation);
+
+      procedure a_loadfpu_const_stack(list : TAsmList;size: tdef;a :double);
+
+      procedure a_op_stack(list : TAsmList;op: topcg; size: tdef; trunc32: boolean);
+      procedure a_op_const_stack(list : TAsmList;op: topcg; size: tdef;a : aint);
+      procedure a_op_reg_stack(list : TAsmList;op: topcg; size: tdef;reg: tregister);
+      procedure a_op_ref_stack(list : TAsmList;op: topcg; size: tdef;const ref: treference);
+      procedure a_op_loc_stack(list : TAsmList;op: topcg; size: tdef;const loc: tlocation);
+
+      procedure g_reference_loc(list: TAsmList; def: tdef; const fromloc: tlocation; out toloc: tlocation); override;
+
+      { assumes that initdim dimensions have already been pushed on the
+        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,
+        see http://stackoverflow.com/questions/4068973/c-performing-signed-comparison-in-unsigned-variables-without-casting ) }
+      procedure a_cmp_stack_label(list : TAsmlist; size: tdef; cmp_op: topcmp; lab: tasmlabel);
+      { these 2 routines perform the massaging expected by the previous one }
+      procedure maybe_adjust_cmp_stackval(list : TAsmlist; size: tdef; cmp_op: topcmp);
+      function maybe_adjust_cmp_constval(size: tdef; cmp_op: topcmp; a: aint): aint;
+      { truncate/sign extend after performing operations on values < 32 bit
+        that may have overflowed outside the range }
+      procedure maybe_adjust_op_result(list: TAsmList; op: TOpCg; size: tdef);
+
+      { performs sign/zero extension as required }
+      procedure resize_stack_int_val(list: TAsmList;fromsize,tosize: tdef; formemstore: boolean);
+
+      { 8/16 bit unsigned parameters and return values must be sign-extended on
+        the producer side, because the JVM does not support unsigned variants;
+        then they have to be zero-extended again on the consumer side }
+      procedure maybe_resize_stack_para_val(list: TAsmList; retdef: tdef; callside: boolean);
+
+
+      property maxevalstackheight: longint read fmaxevalstackheight;
+
+      procedure gen_initialize_fields_code(list:TAsmList);
+
+      procedure gen_typecheck(list: TAsmList; checkop: tasmop; checkdef: tdef);
+     protected
+      procedure a_load_const_stack_intern(list : TAsmList;size : tdef;a : aint; typ: TRegisterType; legalize_const: boolean);
+
+      function get_enum_init_val_ref(def: tdef; out ref: treference): boolean;
+
+      procedure allocate_implicit_structs_for_st_with_base_ref(list: TAsmList; st: tsymtable; const ref: treference; allocvartyp: tsymtyp);
+      procedure allocate_enum_with_base_ref(list: TAsmList; vs: tabstractvarsym; const initref: treference; destbaseref: treference);
+      procedure allocate_implicit_struct_with_base_ref(list: TAsmList; vs: tabstractvarsym; ref: treference);
+      procedure gen_load_uninitialized_function_result(list: TAsmList; pd: tprocdef; resdef: tdef; const resloc: tcgpara); override;
+
+      procedure g_copyvalueparas(p: TObject; arg: pointer); override;
+
+      procedure inittempvariables(list:TAsmList);override;
+
+
+      { in case of an array, the array base address and index have to be
+        put on the evaluation stack before the stored value; similarly, for
+        fields the self pointer has to be loaded first. Also checks whether
+        the reference is valid. If dup is true, the necessary values are stored
+        twice. Returns how many stack slots have been consumed, disregarding
+        the "dup". }
+      function prepare_stack_for_ref(list: TAsmList; const ref: treference; dup: boolean): longint;
+      { return the load/store opcode to load/store from/to ref; if the result
+        has to be and'ed after a load to get the final value, that constant
+        is returned in finishandval (otherwise that value is set to -1) }
+      function loadstoreopcref(def: tdef; isload: boolean; const ref: treference; out finishandval: aint): tasmop;
+      { return the load/store opcode to load/store from/to reg; if the result
+        has to be and'ed after a load to get the final value, that constant
+        is returned in finishandval (otherwise that value is set to -1) }
+      function loadstoreopc(def: tdef; isload, isarray: boolean; out finishandval: aint): tasmop;
+      procedure resizestackfpuval(list: TAsmList; fromsize, tosize: tcgsize);
+      { in case of an OS_32 OP_DIV, we have to use an OS_S64 OP_IDIV because the
+        JVM does not support unsigned divisions }
+      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 : TSymStr; inheritedcall: boolean);
+
+      { 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);
+      procedure concatcopy_set(list: TAsmList; size: tdef; const source, dest: treference);
+      procedure concatcopy_shortstring(list: TAsmList; size: tdef; const source, dest: treference);
+
+    end;
+
+  procedure create_hlcodegen;
+
+
+  const
+    opcmp2if: array[topcmp] of tasmop = (A_None,
+      a_ifeq,a_ifgt,a_iflt,a_ifge,a_ifle,
+      a_ifne,a_ifle,a_iflt,a_ifge,a_ifgt);
+
+implementation
+
+  uses
+    verbose,cutils,globals,fmodule,constexp,
+    defutil,
+    aasmtai,aasmcpu,
+    symtable,jvmdef,
+    procinfo,cpuinfo,cgcpu,tgobj;
+
+  const
+    TOpCG2IAsmOp : array[topcg] of TAsmOp=(                       { not = xor -1 }
+      A_None,A_None,a_iadd,a_iand,A_none,a_idiv,a_imul,a_imul,a_ineg,A_None,a_ior,a_ishr,a_ishl,a_iushr,a_isub,a_ixor,A_None,A_None
+    );
+    TOpCG2LAsmOp : array[topcg] of TAsmOp=(                       { not = xor -1 }
+      A_None,A_None,a_ladd,a_land,A_none,a_ldiv,a_lmul,a_lmul,a_lneg,A_None,a_lor,a_lshr,a_lshl,a_lushr,a_lsub,a_lxor,A_None,A_None
+    );
+
+  constructor thlcgjvm.create;
+    begin
+      fevalstackheight:=0;
+      fmaxevalstackheight:=0;
+    end;
+
+  procedure thlcgjvm.incstack(list: TasmList;slots: longint);
+    begin
+      if slots=0 then
+        exit;
+      inc(fevalstackheight,slots);
+      if (fevalstackheight>fmaxevalstackheight) then
+        fmaxevalstackheight:=fevalstackheight;
+      if cs_asm_regalloc in current_settings.globalswitches then
+        list.concat(tai_comment.Create(strpnew('allocated '+tostr(slots)+', stack height = '+tostr(fevalstackheight))));
+    end;
+
+  procedure thlcgjvm.decstack(list: TAsmList;slots: longint);
+    begin
+      if slots=0 then
+        exit;
+      dec(fevalstackheight,slots);
+      if (fevalstackheight<0) and
+         not(cs_no_regalloc in current_settings.globalswitches) then
+        internalerror(2010120501);
+      if cs_asm_regalloc in current_settings.globalswitches then
+        list.concat(tai_comment.Create(strpnew('    freed '+tostr(slots)+', stack height = '+tostr(fevalstackheight))));
+    end;
+
+  function thlcgjvm.def2regtyp(def: tdef): tregistertype;
+    begin
+      case def.typ of
+        { records and enums are implemented via classes }
+        recorddef,
+        enumdef,
+        setdef:
+          result:=R_ADDRESSREGISTER;
+        { shortstrings are implemented via classes }
+        else if is_shortstring(def) or
+        { voiddef can only be typecasted into (implicit) pointers }
+                is_void(def) then
+          result:=R_ADDRESSREGISTER
+        else
+          result:=inherited;
+      end;
+    end;
+
+  procedure thlcgjvm.a_load_const_cgpara(list: TAsmList; tosize: tdef; a: aint; const cgpara: TCGPara);
+    begin
+      tosize:=get_para_push_size(tosize);
+      if tosize=s8inttype then
+        a:=shortint(a)
+      else if tosize=s16inttype then
+        a:=smallint(a);
+      inherited a_load_const_cgpara(list, tosize, a, cgpara);
+    end;
+
+  procedure thlcgjvm.a_call_name(list: TAsmList; pd: tprocdef; const s: TSymStr; weak: boolean);
+    begin
+      a_call_name_intern(list,pd,s,false);
+    end;
+
+  procedure thlcgjvm.a_call_name_inherited(list: TAsmList; pd: tprocdef; const s: TSymStr);
+    begin
+      a_call_name_intern(list,pd,s,true);
+    end;
+
+
+  procedure thlcgjvm.a_load_const_stack_intern(list : TAsmList;size : tdef;a : aint; typ: TRegisterType; legalize_const: boolean);
+    begin
+      if legalize_const and
+         (typ=R_INTREGISTER) and
+         (size.typ=orddef) then
+        begin
+          { uses specific byte/short array store instructions, and the Dalvik
+            VM does not like it if we store values outside the range }
+          case torddef(size).ordtype of
+            u8bit:
+              a:=shortint(a);
+            u16bit:
+              a:=smallint(a);
+          end;
+        end;
+      a_load_const_stack(list,size,a,typ);
+    end;
+
+
+  procedure thlcgjvm.a_load_const_stack(list : TAsmList;size : tdef;a : aint; typ: TRegisterType);
+    const
+      int2opc: array[-1..5] of tasmop = (a_iconst_m1,a_iconst_0,a_iconst_1,
+        a_iconst_2,a_iconst_3,a_iconst_4,a_iconst_5);
+    begin
+      case typ of
+        R_INTREGISTER:
+          begin
+            case def_cgsize(size) of
+              OS_8,OS_16,OS_32,
+              OS_S8,OS_S16,OS_S32:
+                begin
+                  { convert cardinals to longints }
+                  a:=longint(a);
+                  if (a>=-1) and
+                     (a<=5) then
+                    list.concat(taicpu.op_none(int2opc[a]))
+                  else if (a>=low(shortint)) and
+                          (a<=high(shortint)) then
+                    list.concat(taicpu.op_const(a_bipush,a))
+                  else if (a>=low(smallint)) and
+                          (a<=high(smallint)) then
+                    list.concat(taicpu.op_const(a_sipush,a))
+                  else
+                    list.concat(taicpu.op_const(a_ldc,a));
+                  { for android verifier }
+                  if (size.typ=orddef) and
+                     (torddef(size).ordtype=uwidechar) then
+                    list.concat(taicpu.op_none(a_i2c));
+                end;
+              OS_64,OS_S64:
+                begin
+                  case a of
+                    0:
+                      list.concat(taicpu.op_none(a_lconst_0));
+                    1:
+                      list.concat(taicpu.op_none(a_lconst_1));
+                    else
+                      list.concat(taicpu.op_const(a_ldc2_w,a));
+                  end;
+                  incstack(list,1);
+                end;
+              else
+                internalerror(2010110702);
+            end;
+          end;
+        R_ADDRESSREGISTER:
+          begin
+            if a<>0 then
+              internalerror(2010110701);
+            list.concat(taicpu.op_none(a_aconst_null));
+          end;
+        else
+          internalerror(2010110703);
+      end;
+      incstack(list,1);
+    end;
+
+  procedure thlcgjvm.a_load_stack_loc(list: TAsmList; size: tdef; const loc: tlocation);
+    begin
+      case loc.loc of
+        LOC_REGISTER,LOC_CREGISTER,
+        LOC_FPUREGISTER,LOC_CFPUREGISTER:
+          a_load_stack_reg(list,size,loc.register);
+        LOC_REFERENCE:
+          a_load_stack_ref(list,size,loc.reference,prepare_stack_for_ref(list,loc.reference,false));
+        else
+          internalerror(2011020501);
+      end;
+    end;
+
+  procedure thlcgjvm.a_load_loc_stack(list: TAsmList;size: tdef;const loc: tlocation);
+    begin
+      case loc.loc of
+        LOC_REGISTER,LOC_CREGISTER,
+        LOC_FPUREGISTER,LOC_CFPUREGISTER:
+          a_load_reg_stack(list,size,loc.register);
+        LOC_REFERENCE,LOC_CREFERENCE:
+          a_load_ref_stack(list,size,loc.reference,prepare_stack_for_ref(list,loc.reference,false));
+        LOC_CONSTANT:
+          a_load_const_stack(list,size,loc.value,def2regtyp(size));
+        else
+          internalerror(2011010401);
+      end;
+    end;
+
+  procedure thlcgjvm.a_loadfpu_const_stack(list: TAsmList; size: tdef; a: double);
+    begin
+      case tfloatdef(size).floattype of
+        s32real:
+          begin
+            if a=0.0 then
+              list.concat(taicpu.op_none(a_fconst_0))
+            else if a=1.0 then
+              list.concat(taicpu.op_none(a_fconst_1))
+            else if a=2.0 then
+              list.concat(taicpu.op_none(a_fconst_2))
+            else
+              list.concat(taicpu.op_single(a_ldc,a));
+            incstack(list,1);
+          end;
+        s64real:
+          begin
+            if a=0.0 then
+              list.concat(taicpu.op_none(a_dconst_0))
+            else if a=1.0 then
+              list.concat(taicpu.op_none(a_dconst_1))
+            else
+              list.concat(taicpu.op_double(a_ldc2_w,a));
+            incstack(list,2);
+          end
+        else
+          internalerror(2011010501);
+      end;
+    end;
+
+  procedure thlcgjvm.a_op_stack(list: TAsmList; op: topcg; size: tdef; trunc32: boolean);
+    var
+      cgsize: tcgsize;
+    begin
+      if not trunc32 then
+        cgsize:=def_cgsize(size)
+      else
+        begin
+          resize_stack_int_val(list,u32inttype,s64inttype,false);
+          cgsize:=OS_S64;
+        end;
+      case cgsize of
+        OS_8,OS_S8,
+        OS_16,OS_S16,
+        OS_32,OS_S32:
+          begin
+            { not = xor 1 for boolean, xor -1 for the rest}
+            if op=OP_NOT then
+              begin
+                if not is_pasbool(size) then
+                  a_load_const_stack(list,s32inttype,high(cardinal),R_INTREGISTER)
+                else
+                  a_load_const_stack(list,size,1,R_INTREGISTER);
+                op:=OP_XOR;
+              end;
+            if TOpCG2IAsmOp[op]=A_None then
+              internalerror(2010120532);
+            list.concat(taicpu.op_none(TOpCG2IAsmOp[op]));
+            maybe_adjust_op_result(list,op,size);
+            if op<>OP_NEG then
+              decstack(list,1);
+          end;
+        OS_64,OS_S64:
+          begin
+            { unsigned 64 bit division must be done via a helper }
+            if op=OP_DIV then
+              internalerror(2010120530);
+            { not = xor -1 }
+            if op=OP_NOT then
+              begin
+                a_load_const_stack(list,s64inttype,-1,R_INTREGISTER);
+                op:=OP_XOR;
+              end;
+            if TOpCG2LAsmOp[op]=A_None then
+              internalerror(2010120533);
+            list.concat(taicpu.op_none(TOpCG2LAsmOp[op]));
+            case op of
+              OP_NOT,
+              OP_NEG:
+                ;
+              { the second argument here is an int rather than a long }
+              OP_SHL,OP_SHR,OP_SAR:
+                decstack(list,1);
+              else
+                decstack(list,2);
+            end;
+          end;
+        else
+          internalerror(2010120531);
+      end;
+      if trunc32 then
+        begin
+          list.concat(taicpu.op_none(a_l2i));
+          decstack(list,1);
+        end;
+    end;
+
+  procedure thlcgjvm.a_op_const_stack(list: TAsmList;op: topcg;size: tdef;a: aint);
+    var
+      trunc32: boolean;
+    begin
+      maybepreparedivu32(list,op,size,trunc32);
+      case op of
+        OP_NEG,OP_NOT:
+          internalerror(2011010801);
+        OP_SHL,OP_SHR,OP_SAR:
+          { the second argument here is an int rather than a long }
+          a_load_const_stack(list,s32inttype,a,R_INTREGISTER);
+        else
+          a_load_const_stack(list,size,a,R_INTREGISTER);
+      end;
+      a_op_stack(list,op,size,trunc32);
+    end;
+
+  procedure thlcgjvm.a_op_reg_stack(list: TAsmList; op: topcg; size: tdef; reg: tregister);
+    var
+      trunc32: boolean;
+    begin
+      maybepreparedivu32(list,op,size,trunc32);
+      case op of
+        OP_NEG,OP_NOT:
+          ;
+        OP_SHL,OP_SHR,OP_SAR:
+          if not is_64bitint(size) then
+            a_load_reg_stack(list,size,reg)
+          else
+            begin
+              { the second argument here is an int rather than a long }
+              if getsubreg(reg)=R_SUBQ then
+                internalerror(2011010802);
+              a_load_reg_stack(list,s32inttype,reg)
+            end
+        else
+          a_load_reg_stack(list,size,reg);
+      end;
+      a_op_stack(list,op,size,trunc32);
+    end;
+
+  procedure thlcgjvm.a_op_ref_stack(list: TAsmList; op: topcg; size: tdef; const ref: treference);
+    var
+      trunc32: boolean;
+    begin
+      { ref must not be the stack top, because that may indicate an error
+        (it means that we will perform an operation of the stack top onto
+         itself, so that means the two values have been loaded manually prior
+         to calling this routine, instead of letting this routine load one of
+         them; if something like that is needed, call a_op_stack() directly) }
+      if ref.base=NR_EVAL_STACK_BASE then
+        internalerror(2010121102);
+      maybepreparedivu32(list,op,size,trunc32);
+      case op of
+        OP_NEG,OP_NOT:
+          ;
+        OP_SHL,OP_SHR,OP_SAR:
+          begin
+            if not is_64bitint(size) then
+              a_load_ref_stack(list,size,ref,prepare_stack_for_ref(list,ref,false))
+            else
+              a_load_ref_stack(list,s32inttype,ref,prepare_stack_for_ref(list,ref,false));
+          end;
+        else
+          a_load_ref_stack(list,size,ref,prepare_stack_for_ref(list,ref,false));
+      end;
+      a_op_stack(list,op,size,trunc32);
+    end;
+
+  procedure thlcgjvm.a_op_loc_stack(list: TAsmList; op: topcg; size: tdef; const loc: tlocation);
+    begin
+      case loc.loc of
+        LOC_REGISTER,LOC_CREGISTER:
+          a_op_reg_stack(list,op,size,loc.register);
+        LOC_REFERENCE,LOC_CREFERENCE:
+          a_op_ref_stack(list,op,size,loc.reference);
+        LOC_CONSTANT:
+          a_op_const_stack(list,op,size,loc.value);
+        else
+          internalerror(2011011415)
+      end;
+    end;
+
+  procedure thlcgjvm.g_reference_loc(list: TAsmList; def: tdef; const fromloc: tlocation; out toloc: tlocation);
+    begin
+      case fromloc.loc of
+        LOC_CREFERENCE,
+        LOC_REFERENCE:
+          begin
+            toloc:=fromloc;
+            if (fromloc.reference.base<>NR_NO) and
+               (fromloc.reference.base<>current_procinfo.framepointer) and
+               (fromloc.reference.base<>NR_STACK_POINTER_REG) then
+              g_allocload_reg_reg(list,voidpointertype,fromloc.reference.base,toloc.reference.base,R_ADDRESSREGISTER);
+            case fromloc.reference.arrayreftype of
+              art_indexreg:
+                begin
+                  { all array indices in Java are 32 bit ints }
+                  g_allocload_reg_reg(list,s32inttype,fromloc.reference.index,toloc.reference.index,R_INTREGISTER);
+                end;
+              art_indexref:
+                begin
+                  { base register of the address of the index -> pointer }
+                  if (fromloc.reference.indexbase<>NR_NO) and
+                     (fromloc.reference.indexbase<>NR_STACK_POINTER_REG) then
+                    g_allocload_reg_reg(list,voidpointertype,fromloc.reference.indexbase,toloc.reference.indexbase,R_ADDRESSREGISTER);
+                end;
+            end;
+          end;
+        else
+          inherited;
+      end;
+    end;
+
+  procedure thlcgjvm.g_newarray(list: TAsmList; arrdef: tdef; initdim: longint);
+    var
+      recref,
+      enuminitref: treference;
+      elemdef: tdef;
+      i: longint;
+      mangledname: string;
+      opc: tasmop;
+      parasize: longint;
+      primitivetype: boolean;
+    begin
+      elemdef:=arrdef;
+      if initdim>1 then
+        begin
+          { multianewarray typedesc ndim }
+          list.concat(taicpu.op_sym_const(a_multianewarray,
+            current_asmdata.RefAsmSymbol(jvmarrtype(elemdef,primitivetype)),initdim));
+          { has to be a multi-dimensional array type }
+          if primitivetype then
+            internalerror(2011012207);
+        end
+      else
+        begin
+          { for primitive types:
+              newarray typedesc
+            for reference types:
+              anewarray typedesc
+          }
+          { get the type of the elements of the array we are creating }
+          elemdef:=tarraydef(arrdef).elementdef;
+          mangledname:=jvmarrtype(elemdef,primitivetype);
+          if primitivetype then
+            opc:=a_newarray
+          else
+            opc:=a_anewarray;
+          list.concat(taicpu.op_sym(opc,current_asmdata.RefAsmSymbol(mangledname)));
+        end;
+      { all dimensions are removed from the stack, an array reference is
+        added }
+      decstack(list,initdim-1);
+      { in case of an array of records, sets or shortstrings, initialise }
+      elemdef:=tarraydef(arrdef).elementdef;
+      for i:=1 to pred(initdim) do
+        elemdef:=tarraydef(elemdef).elementdef;
+      if (elemdef.typ in [recorddef,setdef]) or
+         ((elemdef.typ=enumdef) and
+          get_enum_init_val_ref(elemdef,enuminitref)) or
+         is_shortstring(elemdef) or
+         ((elemdef.typ=procvardef) and
+          not tprocvardef(elemdef).is_addressonly) or
+         is_ansistring(elemdef) or
+         is_wide_or_unicode_string(elemdef) or
+         is_dynamic_array(elemdef) then
+        begin
+          { duplicate array instance }
+          list.concat(taicpu.op_none(a_dup));
+          incstack(list,1);
+          a_load_const_stack(list,s32inttype,initdim-1,R_INTREGISTER);
+          parasize:=2;
+          case elemdef.typ of
+            arraydef:
+              g_call_system_proc(list,'fpc_initialize_array_dynarr');
+            recorddef,setdef,procvardef:
+              begin
+                tg.gethltemp(list,elemdef,elemdef.size,tt_persistent,recref);
+                a_load_ref_stack(list,elemdef,recref,prepare_stack_for_ref(list,recref,false));
+                inc(parasize);
+                case elemdef.typ of
+                  recorddef:
+                    g_call_system_proc(list,'fpc_initialize_array_record');
+                  setdef:
+                    begin
+                      if tsetdef(elemdef).elementdef.typ=enumdef then
+                        g_call_system_proc(list,'fpc_initialize_array_enumset')
+                      else
+                        g_call_system_proc(list,'fpc_initialize_array_bitset')
+                    end;
+                  procvardef:
+                    g_call_system_proc(list,'fpc_initialize_array_procvar');
+                end;
+                tg.ungettemp(list,recref);
+              end;
+            enumdef:
+              begin
+                inc(parasize);
+                a_load_ref_stack(list,java_jlobject,enuminitref,prepare_stack_for_ref(list,enuminitref,false));
+                g_call_system_proc(list,'fpc_initialize_array_object');
+              end;
+            stringdef:
+              begin
+                case tstringdef(elemdef).stringtype of
+                  st_shortstring:
+                    begin
+                      inc(parasize);
+                      a_load_const_stack_intern(list,u8inttype,tstringdef(elemdef).len,R_INTREGISTER,true);
+                      g_call_system_proc(list,'fpc_initialize_array_shortstring');
+                    end;
+                  st_ansistring:
+                    g_call_system_proc(list,'fpc_initialize_array_ansistring');
+                  st_unicodestring,
+                  st_widestring:
+                    g_call_system_proc(list,'fpc_initialize_array_unicodestring');
+                  else
+                    internalerror(2011081801);
+                end;
+              end;
+            else
+              internalerror(2011081801);
+          end;
+          decstack(list,parasize);
+        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_sym(a_ifnull,nillab));
+      decstack(list,1);
+
+      { ... 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,
+          a_if_icmpeq,a_if_icmpgt,a_if_icmplt,a_if_icmpge,a_if_icmple,
+          a_if_icmpne,a_if_icmple,a_if_icmplt,a_if_icmpge,a_if_icmpgt);
+      var
+        cgsize: tcgsize;
+      begin
+        case def2regtyp(size) of
+          R_INTREGISTER:
+            begin
+              cgsize:=def_cgsize(size);
+              case cgsize of
+                OS_S8,OS_8,
+                OS_16,OS_S16,
+                OS_S32,OS_32:
+                  begin
+                    list.concat(taicpu.op_sym(opcmp2icmp[cmp_op],lab));
+                    decstack(list,2);
+                  end;
+                OS_64,OS_S64:
+                  begin
+                    list.concat(taicpu.op_none(a_lcmp));
+                    decstack(list,3);
+                    list.concat(taicpu.op_sym(opcmp2if[cmp_op],lab));
+                    decstack(list,1);
+                  end;
+                else
+                  internalerror(2010120538);
+              end;
+            end;
+          R_ADDRESSREGISTER:
+            begin
+              case cmp_op of
+                OC_EQ:
+                  list.concat(taicpu.op_sym(a_if_acmpeq,lab));
+                OC_NE:
+                  list.concat(taicpu.op_sym(a_if_acmpne,lab));
+                else
+                  internalerror(2010120537);
+              end;
+              decstack(list,2);
+            end;
+          else
+            internalerror(2010120538);
+        end;
+      end;
+
+    procedure thlcgjvm.maybe_adjust_cmp_stackval(list: TAsmlist; size: tdef; cmp_op: topcmp);
+      begin
+        { use cmp_op because eventually that's what indicates the
+          signed/unsigned character of the operation, not the size... }
+        if (cmp_op in [OC_EQ,OC_NE,OC_LT,OC_LTE,OC_GT,OC_GTE]) or
+           (def2regtyp(size)<>R_INTREGISTER) then
+          exit;
+        { http://stackoverflow.com/questions/4068973/c-performing-signed-comparison-in-unsigned-variables-without-casting }
+        case def_cgsize(size) of
+          OS_32,OS_S32:
+            a_op_const_stack(list,OP_XOR,size,cardinal($80000000));
+          OS_64,OS_S64:
+            a_op_const_stack(list,OP_XOR,size,aint($8000000000000000));
+        end;
+      end;
+
+    function thlcgjvm.maybe_adjust_cmp_constval(size: tdef; cmp_op: topcmp; a: aint): aint;
+      begin
+        result:=a;
+        { use cmp_op because eventually that's what indicates the
+          signed/unsigned character of the operation, not the size... }
+        if (cmp_op in [OC_EQ,OC_NE,OC_LT,OC_LTE,OC_GT,OC_GTE]) or
+           (def2regtyp(size)<>R_INTREGISTER) then
+          exit;
+        case def_cgsize(size) of
+          OS_32,OS_S32:
+            result:=a xor cardinal($80000000);
+          OS_64,OS_S64:
+            result:=a xor aint($8000000000000000);
+        end;
+      end;
+
+    procedure thlcgjvm.maybe_adjust_op_result(list: TAsmList; op: TOpCg; size: tdef);
+      const
+        overflowops = [OP_MUL,OP_SHL,OP_ADD,OP_SUB,OP_NOT,OP_NEG];
+      begin
+        if ((op in overflowops) or
+            (current_settings.cputype=cpu_dalvik)) and
+           (def_cgsize(size) in [OS_8,OS_S8,OS_16,OS_S16]) then
+          resize_stack_int_val(list,s32inttype,size,false);
+      end;
+
+  procedure thlcgjvm.gen_load_uninitialized_function_result(list: TAsmList; pd: tprocdef; resdef: tdef; const resloc: tcgpara);
+    begin
+      { constructors don't return anything in Java }
+      if pd.proctypeoption=potype_constructor then
+        exit;
+      { must return a value of the correct type on the evaluation stack }
+      case def2regtyp(resdef) of
+        R_INTREGISTER,
+        R_ADDRESSREGISTER:
+          a_load_const_cgpara(list,resdef,0,resloc);
+        R_FPUREGISTER:
+          case tfloatdef(resdef).floattype of
+            s32real:
+              begin
+                list.concat(taicpu.op_none(a_fconst_0));
+                incstack(list,1);
+              end;
+            s64real:
+              begin
+                list.concat(taicpu.op_none(a_dconst_0));
+                incstack(list,2);
+              end;
+            else
+              internalerror(2011010302);
+          end
+        else
+          internalerror(2011010301);
+      end;
+    end;
+
+
+  procedure thlcgjvm.g_copyvalueparas(p: TObject; arg: pointer);
+    var
+      list: tasmlist;
+      tmpref: treference;
+    begin
+      { zero-extend < 32 bit primitive types (FPC can zero-extend when calling,
+        but that doesn't help when we're called from Java code or indirectly
+        as a procvar -- exceptions: widechar (Java-specific type) and ordinal
+        types whose upper bound does not set the sign bit }
+      if (tsym(p).typ=paravarsym) and
+         (tparavarsym(p).varspez in [vs_value,vs_const]) and
+         (tparavarsym(p).vardef.typ=orddef) and
+         not is_pasbool(tparavarsym(p).vardef) and
+         not is_widechar(tparavarsym(p).vardef) and
+         (tparavarsym(p).vardef.size<4) and
+         not is_signed(tparavarsym(p).vardef) and
+         (torddef(tparavarsym(p).vardef).high>=(1 shl (tparavarsym(p).vardef.size*8-1))) then
+        begin
+          list:=TAsmList(arg);
+          { store value in new location to keep Android verifier happy }
+          tg.gethltemp(list,tparavarsym(p).vardef,tparavarsym(p).vardef.size,tt_persistent,tmpref);
+          a_load_loc_stack(list,tparavarsym(p).vardef,tparavarsym(p).initialloc);
+          a_op_const_stack(list,OP_AND,tparavarsym(p).vardef,(1 shl (tparavarsym(p).vardef.size*8))-1);
+          a_load_stack_ref(list,tparavarsym(p).vardef,tmpref,prepare_stack_for_ref(list,tmpref,false));
+          location_reset_ref(tparavarsym(p).localloc,LOC_REFERENCE,def_cgsize(tparavarsym(p).vardef),4);
+          tparavarsym(p).localloc.reference:=tmpref;
+        end;
+
+      inherited g_copyvalueparas(p, arg);
+    end;
+
+
+  procedure thlcgjvm.inittempvariables(list: TAsmList);
+    begin
+      { these are automatically initialised when allocated if necessary }
+    end;
+
+  function thlcgjvm.prepare_stack_for_ref(list: TAsmList; const ref: treference; dup: boolean): longint;
+    var
+      href: treference;
+    begin
+      result:=0;
+      { fake location that indicates the value is already on the stack? }
+      if (ref.base=NR_EVAL_STACK_BASE) then
+        exit;
+      if ref.arrayreftype=art_none then
+        begin
+          { non-array accesses cannot have an index reg }
+          if ref.index<>NR_NO then
+            internalerror(2010120509);
+          if (ref.base<>NR_NO) then
+            begin
+              if (ref.base<>NR_STACK_POINTER_REG) then
+                begin
+                  { regular field -> load self on the stack }
+                  a_load_reg_stack(list,voidpointertype,ref.base);
+                  if dup then
+                    begin
+                      list.concat(taicpu.op_none(a_dup));
+                      incstack(list,1);
+                    end;
+                  { field name/type encoded in symbol, no index/offset }
+                  if not assigned(ref.symbol) or
+                     (ref.offset<>0) then
+                    internalerror(2010120524);
+                  result:=1;
+                end
+              else
+                begin
+                  { local variable -> offset encoded in opcode and nothing to
+                    do here, except for checking that it's a valid reference }
+                  if assigned(ref.symbol) then
+                    internalerror(2010120523);
+                end;
+            end
+          else
+            begin
+              { static field -> nothing to do here, except for validity check }
+              if not assigned(ref.symbol) or
+                 (ref.offset<>0) then
+                internalerror(2010120525);
+            end;
+        end
+      else
+        begin
+          { arrays have implicit dereference -> pointer to array must have been
+            loaded into base reg }
+          if (ref.base=NR_NO) or
+             (ref.base=NR_STACK_POINTER_REG) then
+            internalerror(2010120511);
+          if assigned(ref.symbol) then
+            internalerror(2010120512);
+
+          { stack: ... -> ..., arrayref, index }
+          { load array base address }
+          a_load_reg_stack(list,voidpointertype,ref.base);
+          { index can either be in a register, or located in a simple memory
+            location (since we have to load it anyway) }
+          case ref.arrayreftype of
+            art_indexreg:
+              begin
+                if ref.index=NR_NO then
+                  internalerror(2010120513);
+                { all array indices in Java are 32 bit ints }
+                a_load_reg_stack(list,s32inttype,ref.index);
+              end;
+            art_indexref:
+              begin
+                reference_reset_base(href,ref.indexbase,ref.indexoffset,4);
+                href.symbol:=ref.indexsymbol;
+                a_load_ref_stack(list,s32inttype,href,prepare_stack_for_ref(list,href,false));
+              end;
+            art_indexconst:
+              begin
+                a_load_const_stack(list,s32inttype,ref.indexoffset,R_INTREGISTER);
+              end;
+            else
+              internalerror(2011012001);
+          end;
+          { adjustment of the index }
+          if ref.offset<>0 then
+            a_op_const_stack(list,OP_ADD,s32inttype,ref.offset);
+          if dup then
+            begin
+              list.concat(taicpu.op_none(a_dup2));
+              incstack(list,2);
+            end;
+          result:=2;
+        end;
+    end;
+
+  procedure thlcgjvm.a_load_const_reg(list: TAsmList; tosize: tdef; a: aint; register: tregister);
+    begin
+      a_load_const_stack(list,tosize,a,def2regtyp(tosize));
+      a_load_stack_reg(list,tosize,register);
+    end;
+
+  procedure thlcgjvm.a_load_const_ref(list: TAsmList; tosize: tdef; a: aint; const ref: treference);
+    var
+      extra_slots: longint;
+    begin
+      extra_slots:=prepare_stack_for_ref(list,ref,false);
+      a_load_const_stack_intern(list,tosize,a,def2regtyp(tosize),(ref.arrayreftype<>art_none) or assigned(ref.symbol));
+      a_load_stack_ref(list,tosize,ref,extra_slots);
+    end;
+
+  procedure thlcgjvm.a_load_reg_ref(list: TAsmList; fromsize, tosize: tdef; register: tregister; const ref: treference);
+    var
+      extra_slots: longint;
+    begin
+      extra_slots:=prepare_stack_for_ref(list,ref,false);
+      a_load_reg_stack(list,fromsize,register);
+      if def2regtyp(fromsize)=R_INTREGISTER then
+        resize_stack_int_val(list,fromsize,tosize,(ref.arrayreftype<>art_none) or assigned(ref.symbol));
+      a_load_stack_ref(list,tosize,ref,extra_slots);
+    end;
+
+  procedure thlcgjvm.a_load_reg_reg(list: TAsmList; fromsize, tosize: tdef; reg1, reg2: tregister);
+    begin
+      a_load_reg_stack(list,fromsize,reg1);
+      if def2regtyp(fromsize)=R_INTREGISTER then
+        resize_stack_int_val(list,fromsize,tosize,false);
+      a_load_stack_reg(list,tosize,reg2);
+    end;
+
+  procedure thlcgjvm.a_load_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; register: tregister);
+    var
+      extra_slots: longint;
+    begin
+      extra_slots:=prepare_stack_for_ref(list,ref,false);
+      a_load_ref_stack(list,fromsize,ref,extra_slots);
+
+      if def2regtyp(fromsize)=R_INTREGISTER then
+        resize_stack_int_val(list,fromsize,tosize,false);
+      a_load_stack_reg(list,tosize,register);
+    end;
+
+  procedure thlcgjvm.a_load_ref_ref(list: TAsmList; fromsize, tosize: tdef; const sref: treference; const dref: treference);
+    var
+      extra_sslots,
+      extra_dslots: longint;
+    begin
+      { make sure the destination reference is on top, since in the end the
+        order has to be "destref, value" -> first create "destref, sourceref" }
+      extra_dslots:=prepare_stack_for_ref(list,dref,false);
+      extra_sslots:=prepare_stack_for_ref(list,sref,false);
+      a_load_ref_stack(list,fromsize,sref,extra_sslots);
+      if def2regtyp(fromsize)=R_INTREGISTER then
+        resize_stack_int_val(list,fromsize,tosize,(dref.arrayreftype<>art_none) or assigned(dref.symbol));
+      a_load_stack_ref(list,tosize,dref,extra_dslots);
+    end;
+
+  procedure thlcgjvm.a_loadaddr_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; r: tregister);
+    begin
+      { 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);
+    begin
+      a_op_const_reg_reg(list,op,size,a,reg,reg);
+    end;
+
+  procedure thlcgjvm.a_op_const_reg_reg(list: TAsmList; op: TOpCg; size: tdef; a: aint; src, dst: tregister);
+    begin
+      a_load_reg_stack(list,size,src);
+      a_op_const_stack(list,op,size,a);
+      a_load_stack_reg(list,size,dst);
+    end;
+
+  procedure thlcgjvm.a_op_const_ref(list: TAsmList; Op: TOpCG; size: tdef; a: Aint; const ref: TReference);
+    var
+      extra_slots: longint;
+    begin
+      extra_slots:=prepare_stack_for_ref(list,ref,true);
+      { TODO, here or in peepholeopt: use iinc when possible }
+      a_load_ref_stack(list,size,ref,extra_slots);
+      a_op_const_stack(list,op,size,a);
+      { for android verifier }
+      if (def2regtyp(size)=R_INTREGISTER) and
+         ((ref.arrayreftype<>art_none) or
+          assigned(ref.symbol)) then
+        resize_stack_int_val(list,size,size,true);
+      a_load_stack_ref(list,size,ref,extra_slots);
+    end;
+
+  procedure thlcgjvm.a_op_ref_reg(list: TAsmList; Op: TOpCG; size: tdef; const ref: TReference; reg: TRegister);
+    begin
+      a_load_reg_stack(list,size,reg);
+      a_op_ref_stack(list,op,size,ref);
+      a_load_stack_reg(list,size,reg);
+    end;
+
+  procedure thlcgjvm.a_op_reg_reg_reg(list: TAsmList; op: TOpCg; size: tdef; src1, src2, dst: tregister);
+    begin
+      a_load_reg_stack(list,size,src2);
+      a_op_reg_stack(list,op,size,src1);
+      a_load_stack_reg(list,size,dst);
+    end;
+
+  procedure thlcgjvm.a_op_reg_reg(list: TAsmList; Op: TOpCG; size: tdef; reg1, reg2: TRegister);
+    begin
+      a_op_reg_reg_reg(list,op,size,reg1,reg2,reg2);
+    end;
+
+  procedure thlcgjvm.a_cmp_const_ref_label(list: TAsmList; size: tdef; cmp_op: topcmp; a: aint; const ref: treference; l: tasmlabel);
+    begin
+      if ref.base<>NR_EVAL_STACK_BASE then
+        a_load_ref_stack(list,size,ref,prepare_stack_for_ref(list,ref,false));
+      maybe_adjust_cmp_stackval(list,size,cmp_op);
+      a_load_const_stack(list,size,maybe_adjust_cmp_constval(size,cmp_op,a),def2regtyp(size));
+      a_cmp_stack_label(list,size,cmp_op,l);
+    end;
+
+  procedure thlcgjvm.a_cmp_const_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; a: aint; reg: tregister; l: tasmlabel);
+    begin
+      a_load_reg_stack(list,size,reg);
+      maybe_adjust_cmp_stackval(list,size,cmp_op);
+      a_load_const_stack(list,size,maybe_adjust_cmp_constval(size,cmp_op,a),def2regtyp(size));
+      a_cmp_stack_label(list,size,cmp_op,l);
+    end;
+
+  procedure thlcgjvm.a_cmp_ref_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; const ref: treference; reg: tregister; l: tasmlabel);
+    begin
+      a_load_reg_stack(list,size,reg);
+      maybe_adjust_cmp_stackval(list,size,cmp_op);
+      if ref.base<>NR_EVAL_STACK_BASE then
+        a_load_ref_stack(list,size,ref,prepare_stack_for_ref(list,ref,false))
+      else
+        list.concat(taicpu.op_none(a_swap));
+      maybe_adjust_cmp_stackval(list,size,cmp_op);
+      a_cmp_stack_label(list,size,cmp_op,l);
+    end;
+
+  procedure thlcgjvm.a_cmp_reg_ref_label(list: TAsmList; size: tdef; cmp_op: topcmp; reg: tregister; const ref: treference; l: tasmlabel);
+    begin
+      if ref.base<>NR_EVAL_STACK_BASE then
+        a_load_ref_stack(list,size,ref,prepare_stack_for_ref(list,ref,false));
+      maybe_adjust_cmp_stackval(list,size,cmp_op);
+      a_load_reg_stack(list,size,reg);
+      maybe_adjust_cmp_stackval(list,size,cmp_op);
+      a_cmp_stack_label(list,size,cmp_op,l);
+    end;
+
+  procedure thlcgjvm.a_cmp_reg_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; reg1, reg2: tregister; l: tasmlabel);
+    begin
+      a_load_reg_stack(list,size,reg2);
+      maybe_adjust_cmp_stackval(list,size,cmp_op);
+      a_load_reg_stack(list,size,reg1);
+      maybe_adjust_cmp_stackval(list,size,cmp_op);
+      a_cmp_stack_label(list,size,cmp_op,l);
+    end;
+
+  procedure thlcgjvm.a_jmp_always(list: TAsmList; l: tasmlabel);
+    begin
+      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;
+      ndim: longint;
+      adddefaultlenparas: boolean;
+    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;
+      adddefaultlenparas:=true;
+      case eledef.typ of
+        orddef:
+          begin
+            case torddef(eledef).ordtype of
+              pasbool8,s8bit,u8bit,bool8bit,uchar,
+              s16bit,u16bit,bool16bit,pasbool16,
+              uwidechar,
+              s32bit,u32bit,bool32bit,pasbool32,
+              s64bit,u64bit,bool64bit,pasbool64,scurrency:
+                procname:='FPC_COPY_SHALLOW_ARRAY'
+              else
+                internalerror(2011020504);
+            end;
+          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_SHALLOW_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);
+                adddefaultlenparas:=false;
+                procname:='FPC_SETLENGTH_DYNARR_MULTIDIM';
+              end;
+          end;
+        recorddef:
+          procname:='FPC_COPY_JRECORD_ARRAY';
+        procvardef:
+          if tprocvardef(eledef).is_addressonly then
+            procname:='FPC_COPY_SHALLOW_ARRAY'
+          else
+            procname:='FPC_COPY_JPROCVAR_ARRAY';
+        setdef:
+          if tsetdef(eledef).elementdef.typ=enumdef then
+            procname:='FPC_COPY_JENUMSET_ARRAY'
+          else
+            procname:='FPC_COPY_JBITSET_ARRAY';
+        floatdef:
+          procname:='FPC_COPY_SHALLOW_ARRAY';
+        stringdef:
+          if is_shortstring(eledef) then
+            procname:='FPC_COPY_JSHORTSTRING_ARRAY'
+          else
+            procname:='FPC_COPY_SHALLOW_ARRAY';
+        variantdef:
+          begin
+{$ifndef nounsupported}
+            procname:='FPC_COPY_SHALLOW_ARRAY';
+{$else}
+            { todo: make a deep copy via clone... }
+            internalerror(2011020505);
+{$endif}
+          end;
+        else
+          procname:='FPC_COPY_SHALLOW_ARRAY';
+      end;
+     if adddefaultlenparas then
+       begin
+         { -1, -1 means "copy entire array" }
+         a_load_const_stack(list,s32inttype,-1,R_INTREGISTER);
+         a_load_const_stack(list,s32inttype,-1,R_INTREGISTER);
+       end;
+     g_call_system_proc(list,procname);
+     if ndim=1 then
+       begin
+         decstack(list,2);
+         if adddefaultlenparas then
+           decstack(list,2);
+       end
+     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.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,dest,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,size.typename+'.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.concatcopy_set(list: TAsmList; size: tdef; const source, dest: treference);
+      begin
+        a_load_ref_stack(list,size,source,prepare_stack_for_ref(list,source,false));
+        a_load_ref_stack(list,size,dest,prepare_stack_for_ref(list,dest,false));
+        { call set copy helper }
+        if tsetdef(size).elementdef.typ=enumdef then
+          g_call_system_proc(list,'fpc_enumset_copy')
+        else
+          g_call_system_proc(list,'fpc_bitset_copy');
+        { both parameters are removed, no function result }
+        decstack(list,2);
+      end;
+
+
+    procedure thlcgjvm.concatcopy_shortstring(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,dest,false));
+        { call fpcDeepCopy helper }
+        srsym:=search_struct_member(java_shortstring,'FPCDEEPCOPY');
+        if not assigned(srsym) or
+           (srsym.typ<>procsym) then
+          Message1(cg_f_unknown_compilerproc,'ShortstringClass.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;
+    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;
+        recorddef:
+          begin
+            concatcopy_record(list,size,source,dest);
+            handled:=true;
+          end;
+        setdef:
+          begin
+            concatcopy_set(list,size,source,dest);
+            handled:=true;
+          end;
+        stringdef:
+          begin
+            if is_shortstring(size) then
+              begin
+                concatcopy_shortstring(list,size,source,dest);
+                handled:=true;
+              end;
+          end;
+        procvardef:
+          begin
+            if not tprocvardef(size).is_addressonly then
+              begin
+                concatcopy_record(list,tprocvardef(size).classdef,source,dest);
+                handled:=true;
+              end;
+          end;
+      end;
+      if not handled then
+        inherited;
+    end;
+
+  procedure thlcgjvm.g_copyshortstring(list: TAsmList; const source, dest: treference; strdef: tstringdef);
+    begin
+      concatcopy_shortstring(list,strdef,source,dest);
+    end;
+
+  procedure thlcgjvm.a_loadfpu_ref_ref(list: TAsmList; fromsize, tosize: tdef; const ref1, ref2: treference);
+    var
+      dstack_slots: longint;
+    begin
+      dstack_slots:=prepare_stack_for_ref(list,ref2,false);
+      a_load_ref_stack(list,fromsize,ref1,prepare_stack_for_ref(list,ref1,false));
+      resizestackfpuval(list,def_cgsize(fromsize),def_cgsize(tosize));
+      a_load_stack_ref(list,tosize,ref2,dstack_slots);
+    end;
+
+  procedure thlcgjvm.a_loadfpu_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; reg: tregister);
+    begin
+      a_load_ref_stack(list,fromsize,ref,prepare_stack_for_ref(list,ref,false));
+      resizestackfpuval(list,def_cgsize(fromsize),def_cgsize(tosize));
+      a_load_stack_reg(list,tosize,reg);
+    end;
+
+  procedure thlcgjvm.a_loadfpu_reg_ref(list: TAsmList; fromsize, tosize: tdef; reg: tregister; const ref: treference);
+    var
+      dstack_slots: longint;
+    begin
+      dstack_slots:=prepare_stack_for_ref(list,ref,false);
+      a_load_reg_stack(list,fromsize,reg);
+      resizestackfpuval(list,def_cgsize(fromsize),def_cgsize(tosize));
+      a_load_stack_ref(list,tosize,ref,dstack_slots);
+    end;
+
+  procedure thlcgjvm.a_loadfpu_reg_reg(list: TAsmList; fromsize, tosize: tdef; reg1, reg2: tregister);
+    begin
+      a_load_reg_stack(list,fromsize,reg1);
+      resizestackfpuval(list,def_cgsize(fromsize),def_cgsize(tosize));
+      a_load_stack_reg(list,tosize,reg2);
+    end;
+
+  procedure thlcgjvm.g_proc_entry(list: TAsmList; localsize: longint; nostackframe: boolean);
+    begin
+      { the localsize is based on tg.lasttemp -> already in terms of stack
+        slots rather than bytes }
+      list.concat(tai_directive.Create(asd_jlimit,'locals '+tostr(localsize)));
+      { we insert the unit initialisation code afterwards in the proginit code,
+        and it uses one stack slot }
+      if (current_procinfo.procdef.proctypeoption=potype_proginit) then
+        fmaxevalstackheight:=max(1,fmaxevalstackheight);
+      list.concat(tai_directive.Create(asd_jlimit,'stack '+tostr(fmaxevalstackheight)));
+    end;
+
+  procedure thlcgjvm.g_proc_exit(list: TAsmList; parasize: longint; nostackframe: boolean);
+    var
+      retdef: tdef;
+      cgsize: tcgsize;
+      opc: tasmop;
+    begin
+      if current_procinfo.procdef.proctypeoption in [potype_constructor,potype_class_constructor] then
+        retdef:=voidtype
+      else
+        retdef:=current_procinfo.procdef.returndef;
+      case retdef.typ of
+        orddef:
+          case torddef(retdef).ordtype of
+            uvoid:
+              opc:=a_return;
+            s64bit,
+            u64bit,
+            scurrency:
+              opc:=a_lreturn;
+            else
+              opc:=a_ireturn;
+          end;
+        setdef:
+          opc:=a_areturn;
+        floatdef:
+          case tfloatdef(retdef).floattype of
+            s32real:
+              opc:=a_freturn;
+            s64real:
+              opc:=a_dreturn;
+            else
+              internalerror(2011010213);
+          end;
+        else
+          opc:=a_areturn;
+      end;
+      list.concat(taicpu.op_none(opc));
+    end;
+
+  procedure thlcgjvm.gen_load_return_value(list: TAsmList);
+    begin
+      { constructors don't return anything in the jvm }
+      if current_procinfo.procdef.proctypeoption in [potype_constructor,potype_class_constructor] then
+        exit;
+      inherited gen_load_return_value(list);
+    end;
+
+  procedure thlcgjvm.record_generated_code_for_procdef(pd: tprocdef; code, data: TAsmList);
+    begin
+      { add something to the al_procedures list as well, because if all al_*
+        lists are empty, the assembler writer isn't called }
+      if not code.empty and
+         current_asmdata.asmlists[al_procedures].empty then
+        current_asmdata.asmlists[al_procedures].concat(tai_align.Create(4));
+      pd.exprasmlist:=TAsmList.create;
+      pd.exprasmlist.concatlist(code);
+      if assigned(data) and
+         not data.empty then
+        internalerror(2010122801);
+    end;
+
+  procedure thlcgjvm.g_incrrefcount(list: TAsmList; t: tdef; const ref: treference);
+    begin
+      // do nothing
+    end;
+
+  procedure thlcgjvm.g_array_rtti_helper(list: TAsmList; t: tdef; const ref: treference; const highloc: tlocation; const name: string);
+    var
+      normaldim: longint;
+      eleref: treference;
+    begin
+      { only in case of initialisation, we have to set all elements to "empty" }
+      if name<>'FPC_INITIALIZE_ARRAY' then
+        exit;
+      { put array on the stack }
+      a_load_ref_stack(list,java_jlobject,ref,prepare_stack_for_ref(list,ref,false));
+      { in case it's an open array whose elements are regular arrays, put the
+        dimension of the regular arrays on the stack (otherwise pass 0) }
+      normaldim:=0;
+      while (t.typ=arraydef) and
+            not is_dynamic_array(t) do
+        begin
+          inc(normaldim);
+          t:=tarraydef(t).elementdef;
+        end;
+      a_load_const_stack(list,s32inttype,normaldim,R_INTREGISTER);
+      { highloc is invalid, the length is part of the array in Java }
+      if is_wide_or_unicode_string(t) then
+        g_call_system_proc(list,'fpc_initialize_array_unicodestring')
+      else if is_ansistring(t) then
+        g_call_system_proc(list,'fpc_initialize_array_ansistring')
+      else if is_dynamic_array(t) then
+        g_call_system_proc(list,'fpc_initialize_array_dynarr')
+      else if is_record(t) or
+              (t.typ=setdef) then
+        begin
+          tg.gethltemp(list,t,t.size,tt_persistent,eleref);
+          a_load_ref_stack(list,t,eleref,prepare_stack_for_ref(list,eleref,false));
+          if is_record(t) then
+            g_call_system_proc(list,'fpc_initialize_array_record')
+          else if tsetdef(t).elementdef.typ=enumdef then
+            g_call_system_proc(list,'fpc_initialize_array_enumset')
+          else
+            g_call_system_proc(list,'fpc_initialize_array_bitset');
+          tg.ungettemp(list,eleref);
+        end
+      else if (t.typ=enumdef) then
+        begin
+          if get_enum_init_val_ref(t,eleref) then
+            begin
+              a_load_ref_stack(list,java_jlobject,eleref,prepare_stack_for_ref(list,eleref,false));
+              g_call_system_proc(list,'fpc_initialize_array_object');
+            end;
+        end
+      else
+        internalerror(2011031901);
+    end;
+
+  procedure thlcgjvm.g_initialize(list: TAsmList; t: tdef; const ref: treference);
+    var
+      dummyloc: tlocation;
+      sym: tsym;
+      pd: tprocdef;
+    begin
+      if (t.typ=arraydef) and
+         not is_dynamic_array(t) then
+        begin
+          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
+          { call the fpcInitializeRec method }
+          sym:=tsym(trecorddef(t).symtable.find('FPCINITIALIZEREC'));
+          if assigned(sym) and
+             (sym.typ=procsym) then
+            begin
+              if tprocsym(sym).procdeflist.Count<>1 then
+                internalerror(2011071713);
+              pd:=tprocdef(tprocsym(sym).procdeflist[0]);
+            end;
+          a_load_ref_stack(list,java_jlobject,ref,prepare_stack_for_ref(list,ref,false));
+          a_call_name(list,pd,pd.mangledname,false);
+          { parameter removed, no result }
+          decstack(list,1);
+        end
+      else
+        a_load_const_ref(list,t,0,ref);
+    end;
+
+  procedure thlcgjvm.g_finalize(list: TAsmList; t: tdef; const ref: treference);
+    begin
+      // 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 var/out parameters
+        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 (in case of a var/out parameter, this
+        value is stored inside an array).
+      }
+      if not loadref then
+        begin
+          if not is_managed_type(def) then
+            internalerror(2011020601);
+          tmploc:=l;
+        end
+      else
+        begin
+          if not jvmimplicitpointertype(def) then
+            begin
+              { passed by reference in array of single element; l contains the
+                base address of the array }
+              location_reset_ref(tmploc,LOC_REFERENCE,OS_ADDR,4);
+              reference_reset_base(tmploc.reference,getaddressregister(list,java_jlobject),0,4);
+              tmploc.reference.arrayreftype:=art_indexconst;
+              tmploc.reference.indexoffset:=0;
+              a_load_loc_reg(list,java_jlobject,java_jlobject,l,tmploc.reference.base);
+            end
+          else
+            tmploc:=l;
+        end;
+      case tmploc.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 }
+            location_force_mem(list,tmploc,java_jlobject);
+            ref:=tmploc.reference;
+          end;
+        LOC_REFERENCE,
+        LOC_CREFERENCE :
+          begin
+            ref:=tmploc.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.gen_initialize_code(list: TAsmList);
+    var
+      ref: treference;
+    begin
+      { create globals with wrapped types such as arrays/records  }
+      case current_procinfo.procdef.proctypeoption of
+        potype_unitinit:
+          begin
+            reference_reset_base(ref,NR_NO,0,1);
+            if assigned(current_module.globalsymtable) then
+              allocate_implicit_structs_for_st_with_base_ref(list,current_module.globalsymtable,ref,staticvarsym);
+            allocate_implicit_structs_for_st_with_base_ref(list,current_module.localsymtable,ref,staticvarsym);
+          end;
+        potype_class_constructor:
+          begin
+            { also initialise local variables, if any }
+            inherited;
+            { initialise class fields }
+            reference_reset_base(ref,NR_NO,0,1);
+            allocate_implicit_structs_for_st_with_base_ref(list,tabstractrecorddef(current_procinfo.procdef.owner.defowner).symtable,ref,staticvarsym);
+          end
+        else
+          inherited
+      end;
+    end;
+
+  procedure thlcgjvm.gen_entry_code(list: TAsmList);
+    begin
+      list.concat(Tai_force_line.Create);
+    end;
+
+  procedure thlcgjvm.gen_exit_code(list: TAsmList);
+    begin
+      { nothing }
+    end;
+
+  procedure thlcgjvm.a_load_stack_reg(list: TAsmList; size: tdef; reg: tregister);
+    var
+      opc: tasmop;
+      finishandval: aint;
+    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;
+
+  procedure thlcgjvm.a_load_stack_ref(list: TAsmList; size: tdef; const ref: treference; extra_slots: longint);
+    var
+      opc: tasmop;
+      finishandval: aint;
+    begin
+      { fake location that indicates the value has to remain on the stack }
+      if ref.base=NR_EVAL_STACK_BASE then
+        exit;
+      opc:=loadstoreopcref(size,false,ref,finishandval);
+      if ref.arrayreftype=art_none then
+        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;
+
+  procedure thlcgjvm.a_load_reg_stack(list: TAsmList; size: tdef; reg: tregister);
+    var
+      opc: tasmop;
+      finishandval: aint;
+    begin
+      opc:=loadstoreopc(size,true,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;
+      incstack(list,1+ord(size.size>4));
+      if finishandval<>-1 then
+        a_op_const_stack(list,OP_AND,size,finishandval);
+    end;
+
+  procedure thlcgjvm.a_load_ref_stack(list: TAsmList; size: tdef; const ref: treference; extra_slots: longint);
+    var
+      opc: tasmop;
+      finishandval: aint;
+    begin
+      { fake location that indicates the value is already on the stack? }
+      if (ref.base=NR_EVAL_STACK_BASE) then
+        exit;
+      opc:=loadstoreopcref(size,true,ref,finishandval);
+      if ref.arrayreftype=art_none then
+        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;
+      incstack(list,1+ord(size.size>4)-extra_slots);
+      if finishandval<>-1 then
+        a_op_const_stack(list,OP_AND,size,finishandval);
+      if ref.checkcast then
+        gen_typecheck(list,a_checkcast,size);
+    end;
+
+  function thlcgjvm.loadstoreopcref(def: tdef; isload: boolean; const ref: treference; out finishandval: aint): tasmop;
+    const
+                     { isload  static }
+      getputopc: array[boolean,boolean] of tasmop =
+        ((a_putfield,a_putstatic),
+         (a_getfield,a_getstatic));
+    begin
+      if assigned(ref.symbol) then
+        begin
+          { -> either a global (static) field, or a regular field. If a regular
+            field, then ref.base contains the self pointer, otherwise
+            ref.base=NR_NO. In both cases, the symbol contains all other
+            information (combined field name and type descriptor) }
+          result:=getputopc[isload,ref.base=NR_NO];
+          finishandval:=-1;
+          { erase sign extension for byte/smallint loads }
+          if (def2regtyp(def)=R_INTREGISTER) and
+             not is_signed(def) and
+             (def.typ=orddef) and
+             not is_widechar(def) then
+            case def.size of
+              1: if (torddef(def).high>127) then
+                   finishandval:=255;
+              2: if (torddef(def).high>32767) then
+                   finishandval:=65535;
+            end;
+        end
+      else
+        result:=loadstoreopc(def,isload,ref.arrayreftype<>art_none,finishandval);
+    end;
+
+  function thlcgjvm.loadstoreopc(def: tdef; isload, isarray: boolean; out finishandval: aint): tasmop;
+    var
+      size: longint;
+    begin
+      finishandval:=-1;
+      case def2regtyp(def) of
+        R_INTREGISTER:
+          begin
+            size:=def.size;
+            if not isarray then
+              begin
+                case size of
+                  1,2,3,4:
+                    if isload then
+                      result:=a_iload
+                    else
+                      result:=a_istore;
+                  8:
+                    if isload then
+                      result:=a_lload
+                    else
+                      result:=a_lstore;
+                  else
+                    internalerror(2011032814);
+                end;
+              end
+            { array }
+            else if isload then
+              begin
+                case size of
+                  1:
+                    begin
+                      result:=a_baload;
+                      if not is_signed(def) and
+                         (def.typ=orddef) and
+                         (torddef(def).high>127) then
+                        finishandval:=255;
+                    end;
+                  2:
+                    begin
+                      if is_widechar(def) then
+                        result:=a_caload
+                      else
+                        begin
+                          result:=a_saload;
+                          { if we'd treat arrays of word as "array of widechar" we
+                            could use a_caload, but that would make for even more
+                            awkward interfacing with external Java code }
+                          if not is_signed(def) and
+                         (def.typ=orddef) and
+                         (torddef(def).high>32767) then
+                            finishandval:=65535;
+                        end;
+                    end;
+                  4: result:=a_iaload;
+                  8: result:=a_laload;
+                  else
+                    internalerror(2010120503);
+                end
+              end
+            else
+              begin
+                case size of
+                  1: result:=a_bastore;
+                  2: if not is_widechar(def) then
+                       result:=a_sastore
+                     else
+                       result:=a_castore;
+                  4: result:=a_iastore;
+                  8: result:=a_lastore;
+                  else
+                    internalerror(2010120508);
+                end
+              end
+          end;
+        R_ADDRESSREGISTER:
+          if not isarray then
+            if isload then
+              result:=a_aload
+            else
+              result:=a_astore
+          else if isload then
+            result:=a_aaload
+          else
+            result:=a_aastore;
+        R_FPUREGISTER:
+          begin
+            case tfloatdef(def).floattype of
+              s32real:
+                if not isarray then
+                  if isload then
+                    result:=a_fload
+                  else
+                    result:=a_fstore
+                else if isload then
+                  result:=a_faload
+                else
+                  result:=a_fastore;
+              s64real:
+                if not isarray then
+                  if isload then
+                    result:=a_dload
+                  else
+                    result:=a_dstore
+                else if isload then
+                  result:=a_daload
+                else
+                  result:=a_dastore;
+              else
+                internalerror(2010120504);
+            end
+          end
+        else
+          internalerror(2010120502);
+      end;
+    end;
+
+  procedure thlcgjvm.resize_stack_int_val(list: TAsmList; fromsize, tosize: tdef; formemstore: boolean);
+    var
+      fromcgsize, tocgsize: tcgsize;
+    begin
+      { When storing to an array, field or global variable, make sure the
+        static type verification can determine that the stored value fits
+        within the boundaries of the declared type (to appease the Dalvik VM).
+        Local variables either get their type upgraded in the debug info,
+        or have no type information at all }
+      if formemstore and
+         (tosize.typ=orddef) then
+        if (torddef(tosize).ordtype in [u8bit,uchar]) then
+          tosize:=s8inttype
+        else if torddef(tosize).ordtype=u16bit then
+          tosize:=s16inttype;
+
+      fromcgsize:=def_cgsize(fromsize);
+      tocgsize:=def_cgsize(tosize);
+      if fromcgsize in [OS_S64,OS_64] then
+        begin
+          if not(tocgsize in [OS_S64,OS_64]) then
+            begin
+              { truncate }
+              list.concat(taicpu.op_none(a_l2i));
+              decstack(list,1);
+            end;
+        end
+      else if tocgsize in [OS_S64,OS_64] then
+        begin
+          { extend }
+          list.concat(taicpu.op_none(a_i2l));
+          incstack(list,1);
+          { if it was an unsigned 32 bit value, remove sign extension }
+          if fromcgsize=OS_32 then
+            a_op_const_stack(list,OP_AND,s64inttype,cardinal($ffffffff));
+        end;
+      { Conversions between 32 and 64 bit types have been completely handled
+        above. We still may have to truncare or sign extend in case the
+        destination type is smaller that the source type, or has a different
+        sign. In case the destination is a widechar and the source is not, we
+        also have to insert a conversion to widechar.
+
+        In case of Dalvik, we also have to insert conversions for e.g. byte
+        -> smallint, because truncating a byte happens via "and 255", and the
+        result is a longint in Dalvik's type verification model (so we have
+        to "truncate" it back to smallint) }
+      if (not(fromcgsize in [OS_S64,OS_64,OS_32,OS_S32]) or
+          not(tocgsize in [OS_S64,OS_64,OS_32,OS_S32])) and
+         (((current_settings.cputype=cpu_dalvik) and
+           not(tocgsize in [OS_32,OS_S32]) and
+           not is_signed(fromsize) and
+           is_signed(tosize)) or
+          (tcgsize2size[fromcgsize]>tcgsize2size[tocgsize]) or
+          ((tcgsize2size[fromcgsize]=tcgsize2size[tocgsize]) and
+           (fromcgsize<>tocgsize)) or
+          { needs to mask out the sign in the top 16 bits }
+          ((fromcgsize=OS_S8) and
+           (tocgsize=OS_16)) or
+          ((tosize=cwidechartype) and
+           (fromsize<>cwidechartype))) then
+        case tocgsize of
+          OS_8:
+            a_op_const_stack(list,OP_AND,s32inttype,255);
+          OS_S8:
+            list.concat(taicpu.op_none(a_i2b));
+          OS_16:
+            if (tosize.typ=orddef) and
+               (torddef(tosize).ordtype=uwidechar) then
+              list.concat(taicpu.op_none(a_i2c))
+            else
+              a_op_const_stack(list,OP_AND,s32inttype,65535);
+          OS_S16:
+            list.concat(taicpu.op_none(a_i2s));
+        end;
+    end;
+
+    procedure thlcgjvm.maybe_resize_stack_para_val(list: TAsmList; retdef: tdef; callside: boolean);
+      var
+        convsize: tdef;
+      begin
+        if (retdef.typ=orddef) then
+          begin
+            if (torddef(retdef).ordtype in [u8bit,u16bit,uchar]) and
+               (torddef(retdef).high>=(1 shl (retdef.size*8-1))) then
+              begin
+                convsize:=nil;
+                if callside then
+                  if torddef(retdef).ordtype in [u8bit,uchar] then
+                    convsize:=s8inttype
+                  else
+                    convsize:=s16inttype
+                else if torddef(retdef).ordtype in [u8bit,uchar] then
+                    convsize:=u8inttype
+                  else
+                    convsize:=u16inttype;
+                if assigned(convsize) then
+                  resize_stack_int_val(list,s32inttype,convsize,false);
+              end;
+          end;
+      end;
+
+  procedure thlcgjvm.allocate_implicit_struct_with_base_ref(list: TAsmList; vs: tabstractvarsym; ref: treference);
+    var
+      tmpref: treference;
+    begin
+      ref.symbol:=current_asmdata.RefAsmSymbol(vs.mangledname);
+      tg.gethltemp(list,vs.vardef,vs.vardef.size,tt_persistent,tmpref);
+      { only copy the reference, not the actual data }
+      a_load_ref_ref(list,java_jlobject,java_jlobject,tmpref,ref);
+      { remains live since there's still a reference to the created
+        entity }
+      tg.ungettemp(list,tmpref);
+    end;
+
+
+  procedure thlcgjvm.allocate_enum_with_base_ref(list: TAsmList; vs: tabstractvarsym; const initref: treference; destbaseref: treference);
+    begin
+      destbaseref.symbol:=current_asmdata.RefAsmSymbol(vs.mangledname);
+      { only copy the reference, not the actual data }
+      a_load_ref_ref(list,java_jlobject,java_jlobject,initref,destbaseref);
+    end;
+
+
+  function thlcgjvm.get_enum_init_val_ref(def: tdef; out ref: treference): boolean;
+    var
+      sym: tstaticvarsym;
+    begin
+      result:=false;
+      sym:=tstaticvarsym(tenumdef(def).getbasedef.classdef.symtable.Find('__FPC_ZERO_INITIALIZER'));
+      { no enum with ordinal value 0 -> exit }
+      if not assigned(sym) then
+        exit;
+      reference_reset_symbol(ref,current_asmdata.RefAsmSymbol(sym.mangledname),0,4);
+      result:=true;
+    end;
+
+
+  procedure thlcgjvm.allocate_implicit_structs_for_st_with_base_ref(list: TAsmList; st: tsymtable; const ref: treference; allocvartyp: tsymtyp);
+    var
+      vs: tabstractvarsym;
+      def: tdef;
+      i: longint;
+      initref: treference;
+    begin
+      for i:=0 to st.symlist.count-1 do
+        begin
+          if (tsym(st.symlist[i]).typ<>allocvartyp) then
+            continue;
+          vs:=tabstractvarsym(st.symlist[i]);
+          if sp_static in vs.symoptions then
+            continue;
+          { vo_is_external and vo_has_local_copy means a staticvarsym that is
+            alias for a constsym, whose sole purpose is for allocating and
+            intialising the constant }
+          if [vo_is_external,vo_has_local_copy]*vs.varoptions=[vo_is_external] then
+             continue;
+          { threadvar innitializations are handled at the node tree level }
+          if vo_is_thread_var in vs.varoptions then
+            begin
+              { nothing }
+            end
+          else if jvmimplicitpointertype(vs.vardef) then
+            allocate_implicit_struct_with_base_ref(list,vs,ref)
+          { enums are class instances in Java, while they are ordinals in
+            Pascal. When they are initialized with enum(0), such as in
+            constructors or global variables, initialize them with the
+            enum instance for 0 if it exists (if not, it remains nil since
+            there is no valid enum value in it) }
+          else if (vs.vardef.typ=enumdef) and
+                  get_enum_init_val_ref(vs.vardef,initref) then
+            allocate_enum_with_base_ref(list,vs,initref,ref);
+        end;
+      { process symtables of routines part of this symtable (for local typed
+        constants) }
+      if allocvartyp=staticvarsym then
+        begin
+          for i:=0 to st.deflist.count-1 do
+            begin
+              def:=tdef(st.deflist[i]);
+              { the unit symtable also contains the methods of classes defined
+                in that unit -> skip them when processing the unit itself.
+                Localst is not assigned for the main program code.
+                Localst can be the same as st in case of unit init code. }
+              if (def.typ<>procdef) or
+                 (def.owner<>st) or
+                 not assigned(tprocdef(def).localst) or
+                 (tprocdef(def).localst=st) then
+                continue;
+              allocate_implicit_structs_for_st_with_base_ref(list,tprocdef(def).localst,ref,allocvartyp);
+            end;
+        end;
+    end;
+
+  procedure thlcgjvm.gen_initialize_fields_code(list: TAsmList);
+    var
+      sym: tsym;
+      selfpara: tparavarsym;
+      selfreg: tregister;
+      ref: treference;
+      obj: tabstractrecorddef;
+      i: longint;
+      needinit: boolean;
+    begin
+      obj:=tabstractrecorddef(current_procinfo.procdef.owner.defowner);
+      { check whether there are any fields that need initialisation }
+      needinit:=false;
+      for i:=0 to obj.symtable.symlist.count-1 do
+        begin
+          sym:=tsym(obj.symtable.symlist[i]);
+          if (sym.typ=fieldvarsym) and
+             (jvmimplicitpointertype(tfieldvarsym(sym).vardef) or
+              ((tfieldvarsym(sym).vardef.typ=enumdef) and
+               get_enum_init_val_ref(tfieldvarsym(sym).vardef,ref))) then
+            begin
+              needinit:=true;
+              break;
+            end;
+        end;
+      if not needinit then
+        exit;
+      selfpara:=tparavarsym(current_procinfo.procdef.parast.find('self'));
+      if not assigned(selfpara) then
+        internalerror(2011033001);
+      selfreg:=getaddressregister(list,selfpara.vardef);
+      a_load_loc_reg(list,obj,obj,selfpara.localloc,selfreg);
+      reference_reset_base(ref,selfreg,0,1);
+      allocate_implicit_structs_for_st_with_base_ref(list,obj.symtable,ref,fieldvarsym);
+    end;
+
+  procedure thlcgjvm.gen_typecheck(list: TAsmList; checkop: tasmop; checkdef: tdef);
+    begin
+      { replace special types with their equivalent class type }
+      if (checkdef.typ=pointerdef) and
+         jvmimplicitpointertype(tpointerdef(checkdef).pointeddef) then
+        checkdef:=tpointerdef(checkdef).pointeddef;
+      if (checkdef=voidpointertype) or
+         (checkdef.typ=formaldef) then
+        checkdef:=java_jlobject
+      else if checkdef.typ=enumdef then
+        checkdef:=tenumdef(checkdef).classdef
+      else if checkdef.typ=setdef then
+        begin
+          if tsetdef(checkdef).elementdef.typ=enumdef then
+            checkdef:=java_juenumset
+          else
+            checkdef:=java_jubitset;
+        end
+      else if checkdef.typ=procvardef then
+        checkdef:=tprocvardef(checkdef).classdef
+      else if is_wide_or_unicode_string(checkdef) then
+        checkdef:=java_jlstring
+      else if is_ansistring(checkdef) then
+        checkdef:=java_ansistring
+      else if is_shortstring(checkdef) then
+        checkdef:=java_shortstring;
+      if checkdef.typ in [objectdef,recorddef] then
+        list.concat(taicpu.op_sym(checkop,current_asmdata.RefAsmSymbol(tabstractrecorddef(checkdef).jvm_full_typename(true))))
+      else if checkdef.typ=classrefdef then
+        list.concat(taicpu.op_sym(checkop,current_asmdata.RefAsmSymbol('java/lang/Class')))
+      else
+        list.concat(taicpu.op_sym(checkop,current_asmdata.RefAsmSymbol(jvmencodetype(checkdef,false))));
+    end;
+
+  procedure thlcgjvm.resizestackfpuval(list: TAsmList; fromsize, tosize: tcgsize);
+    begin
+      if (fromsize=OS_F32) and
+         (tosize=OS_F64) then
+        begin
+          list.concat(taicpu.op_none(a_f2d));
+          incstack(list,1);
+        end
+      else if (fromsize=OS_F64) and
+              (tosize=OS_F32) then
+        begin
+          list.concat(taicpu.op_none(a_d2f));
+          decstack(list,1);
+        end;
+    end;
+
+  procedure thlcgjvm.maybepreparedivu32(list: TAsmList; var op: topcg; size: tdef; out isdivu32: boolean);
+    begin
+      if (op=OP_DIV) and
+         (def_cgsize(size)=OS_32) then
+        begin
+          { needs zero-extension to 64 bit, because the JVM only supports
+            signed divisions }
+          resize_stack_int_val(list,u32inttype,s64inttype,false);
+          op:=OP_IDIV;
+          isdivu32:=true;
+        end
+      else
+        isdivu32:=false;
+    end;
+
+  procedure thlcgjvm.a_call_name_intern(list: TAsmList; pd: tprocdef; const s: TSymStr; inheritedcall: boolean);
+    var
+      opc: tasmop;
+    begin
+      {
+        invoke types:
+          * invokeinterface: call method from an interface (must also specify
+              number of parameters in terms of stack slot count!)
+          * invokespecial: invoke a constructor, method in a superclass,
+              or private instance method
+          * invokestatic: invoke a class method (private or not)
+          * invokevirtual: invoke a regular method
+      }
+      case pd.owner.symtabletype of
+        globalsymtable,
+        staticsymtable,
+        localsymtable:
+          { regular and nested procedures are turned into static methods }
+          opc:=a_invokestatic;
+        objectsymtable:
+          begin
+            case tobjectdef(pd.owner.defowner).objecttype of
+              odt_javaclass:
+                begin
+                  if (po_classmethod in pd.procoptions) or
+                     (pd.proctypeoption=potype_operator) then
+                    opc:=a_invokestatic
+                  else if (pd.visibility=vis_strictprivate) or
+                     (pd.proctypeoption=potype_constructor) or
+                     inheritedcall then
+                    opc:=a_invokespecial
+                  else
+                    opc:=a_invokevirtual;
+                end;
+              odt_interfacejava:
+                { static interface methods are not allowed }
+                opc:=a_invokeinterface;
+              else
+                internalerror(2010122601);
+            end;
+          end;
+        recordsymtable:
+          begin
+            if (po_staticmethod in pd.procoptions) or
+               (pd.proctypeoption=potype_operator) then
+              opc:=a_invokestatic
+            else if (pd.visibility=vis_strictprivate) or
+               (pd.proctypeoption=potype_constructor) or
+               inheritedcall then
+              opc:=a_invokespecial
+            else
+              opc:=a_invokevirtual;
+          end
+        else
+          internalerror(2010122602);
+      end;
+      if (opc<>a_invokeinterface) then
+        list.concat(taicpu.op_sym(opc,current_asmdata.RefAsmSymbol(s)))
+      else
+        begin
+          pd.init_paraloc_info(calleeside);
+          list.concat(taicpu.op_sym_const(opc,current_asmdata.RefAsmSymbol(s),pd.calleeargareasize));
+        end;
+    end;
+
+  procedure create_hlcodegen;
+    begin
+      hlcg:=thlcgjvm.create;
+      create_codegen;
+    end;
+
+end.

compiler/jvm/itcpujas.pas

@@ -0,0 +1,99 @@
+{
+    Copyright (c) 1998-2002 by Florian Klaempfl
+
+    This unit contains the JVM Jasmin instruction tables
+
+    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 itcpujas;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+      cpubase,cgbase;
+
+    const
+      jas_op2str : array[tasmop] of string[15] = ('<none>',
+        'aaload', 'aastore', 'aconst_null',
+        'aload', 'aload_0', 'aload_1', 'aload_2', 'aload_3',
+        'anewarray', 'areturn', 'arraylength',
+        'astore', 'astore_0', 'astore_1', 'astore_2', 'astore_3',
+        'athrow', 'baload', 'bastore', 'bipush', 'breakpoint',
+        'caload', 'castore', 'checkcast',
+        'd2f', 'd2i', 'd2l', 'dadd', 'daload', 'dastore', 'dcmpg', 'dcmpl',
+        'dconst_0', 'dconst_1', 'ddiv',
+        'dload', 'dload_0', 'dload_1', 'dload_2', 'dload_3',
+        'dmul', 'dneg', 'drem', 'dreturn',
+        'dstore', 'dstore_0', 'dstore_1', 'dstore_2', 'dstore_3',
+        'dsub',
+        'dup', 'dup2', 'dup2_x1', 'dup2_x2', 'dup_x1', 'dup_x2',
+        'f2d', 'f2i', 'f2l', 'fadd', 'faload', 'fastore', 'fcmpg', 'fcmpl',
+        'fconst_0', 'fconst_1', 'fconst_2', 'fdiv',
+        'fload', 'fload_0', 'fload_1', 'fload_2', 'fload_3',
+        'fmul', 'fneg', 'frem', 'freturn',
+        'fstore', 'fstore_0', 'fstore_1', 'fstore_2', 'fstore_3',
+        'fsub',
+        'getfield', 'getstatic',
+        'goto', 'goto_w',
+        'i2b', 'i2c', 'i2d', 'i2f', 'i2l', 'i2s',
+        'iadd', 'iaload', 'iand', 'iastore',
+        'iconst_m1', 'iconst_0', 'iconst_1', 'iconst_2', 'iconst_3',
+        'iconst_4', 'iconst_5',
+        'idiv',
+        'if_acmpeq', 'if_acmpne', 'if_icmpeq', 'if_icmpge', 'if_icmpgt',
+        'if_icmple', 'if_icmplt', 'if_icmpne',
+        'ifeq', 'ifge', 'ifgt', 'ifle', 'iflt', 'ifne', 'ifnonnull', 'ifnull',
+        'iinc',
+        'iload', 'iload_0', 'iload_1', 'iload_2', 'iload_3',
+        'imul', 'ineg',
+        'instanceof',
+        'invokeinterface', 'invokespecial', 'invokestatic', 'invokevirtual',
+        'ior', 'irem', 'ireturn', 'ishl', 'ishr',
+        'istore', 'istore_0', 'istore_1', 'istore_2', 'istore_3',
+        'isub', 'iushr', 'ixor',
+        'jsr', 'jsr_w',
+        'l2d', 'l2f', 'l2i', 'ladd', 'laload', 'land', 'lastore', 'lcmp',
+        'lconst_0', 'lconst_1',
+        'ldc', 'ldc2_w', 'ldc_w', 'ldiv',
+        'lload', 'lload_0', 'lload_1', 'lload_2', 'lload_3',
+        'lmul', 'lneg',
+        'lookupswitch',
+        'lor', 'lrem',
+        'lreturn',
+        'lshl', 'lshr',
+        'lstore', 'lstore_0', 'lstore_1', 'lstore_2', 'lstore_3',
+        'lsub', 'lushr', 'lxor',
+        'monitorenter',
+        'monitorexit',
+        'multianewarray',
+        'new',
+        'newarray',
+        'nop',
+        'pop', 'pop2',
+        'putfield', 'putstatic',
+        'ret', 'return',
+        'saload', 'sastore', 'sipush',
+        'swap',
+        'tableswitch',
+        'wide'
+      );
+
+implementation
+
+end.

compiler/jvm/jvmdef.pas

@@ -0,0 +1,1009 @@
+{
+    Copyright (c) 2010 by Jonas Maebe
+
+    This unit implements some JVM type helper routines (minimal
+    unit dependencies, usable in symdef).
+
+    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 jvmdef;
+
+interface
+
+    uses
+      globtype,
+      node,
+      symbase,symtype;
+
+    { returns whether a def can make use of an extra type signature (for
+      Java-style generics annotations; not use for FPC-style generics or their
+      translations, but to annotate the kind of classref a java.lang.Class is
+      and things like that) }
+    function jvmtypeneedssignature(def: tdef): boolean;
+    { create a signature encoding of a particular type; requires that
+      jvmtypeneedssignature returned "true" for this type }
+    procedure jvmaddencodedsignature(def: tdef; bpacked: boolean; var encodedstr: TSymStr);
+
+    { Encode a type into the internal format used by the JVM (descriptor).
+      Returns false if a type is not representable by the JVM,
+      and in that case also the failing definition.  }
+    function jvmtryencodetype(def: tdef; out encodedtype: TSymStr; forcesignature: boolean; out founderror: tdef): boolean;
+
+    { same as above, but throws an internal error on failure }
+    function jvmencodetype(def: tdef; withsignature: boolean): TSymStr;
+
+    { Check whether a type can be used in a JVM methom signature or field
+      declaration.  }
+    function jvmchecktype(def: tdef; out founderror: tdef): boolean;
+
+    { incremental version of jvmtryencodetype() }
+    function jvmaddencodedtype(def: tdef; bpacked: boolean; var encodedstr: TSymStr; forcesignature: boolean; out founderror: tdef): boolean;
+
+    { add type prefix (package name) to a type }
+    procedure jvmaddtypeownerprefix(owner: tsymtable; var name: TSymStr);
+
+    { returns type string for a single-dimensional array (different from normal
+      typestring in case of a primitive type) }
+    function jvmarrtype(def: tdef; out primitivetype: boolean): TSymStr;
+    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;
+
+    { returns the mangled base name for a tsym (type + symbol name, no
+      visibility etc); also adds signature attribute if requested and
+      appropriate }
+    function jvmmangledbasename(sym: tsym; withsignature: boolean): TSymStr;
+    function jvmmangledbasename(sym: tsym; const usesymname: TSymStr; withsignature: boolean): TSymStr;
+
+    { sometimes primitive types have to be boxed/unboxed via class types. This
+      routine returns the appropriate box type for the passed primitive type }
+    procedure jvmgetboxtype(def: tdef; out objdef, paradef: tdef; mergeints: boolean);
+    function jvmgetunboxmethod(def: tdef): string;
+
+    function jvmgetcorrespondingclassdef(def: tdef): tdef;
+
+    function get_para_push_size(def: tdef): tdef;
+
+    { threadvars are wrapped via descendents of java.lang.ThreadLocal }
+    function jvmgetthreadvardef(def: tdef): tdef;
+
+    { gets the number of dimensions and the final element type of a normal
+      array }
+    procedure jvmgetarraydimdef(arrdef: tdef; out eledef: tdef; out ndim: longint);
+
+
+implementation
+
+  uses
+    cutils,cclasses,constexp,
+    verbose,systems,
+    fmodule,
+    symtable,symconst,symsym,symdef,symcreat,
+    defutil,paramgr;
+
+{******************************************************************
+                          Type encoding
+*******************************************************************}
+
+    function jvmtypeneedssignature(def: tdef): boolean;
+      var
+        i: longint;
+      begin
+        result:=false;
+        case def.typ of
+          classrefdef,
+          setdef:
+            begin
+              result:=true;
+            end;
+          arraydef :
+            begin
+              result:=jvmtypeneedssignature(tarraydef(def).elementdef);
+            end;
+          procvardef :
+            begin
+              { may change in the future }
+            end;
+          procdef :
+            begin
+              for i:=0 to tprocdef(def).paras.count-1 do
+                begin
+                  result:=jvmtypeneedssignature(tparavarsym(tprocdef(def).paras[i]).vardef);
+                  if result then
+                    exit;
+                end;
+            end
+          else
+            result:=false;
+        end;
+      end;
+
+
+    procedure jvmaddencodedsignature(def: tdef; bpacked: boolean; var encodedstr: TSymStr);
+      var
+        founderror: tdef;
+      begin
+        case def.typ of
+          pointerdef :
+            begin
+              { maybe one day }
+              internalerror(2011051403);
+            end;
+          classrefdef :
+            begin
+              { Ljava/lang/Class<+SomeClassType> means
+                "Ljava/lang/Class<SomeClassType_or_any_of_its_descendents>" }
+              encodedstr:=encodedstr+'Ljava/lang/Class<+';
+              jvmaddencodedtype(tclassrefdef(def).pointeddef,false,encodedstr,true,founderror);
+              encodedstr:=encodedstr+'>;';
+            end;
+          setdef :
+            begin
+              if tsetdef(def).elementdef.typ=enumdef then
+                begin
+                  encodedstr:=encodedstr+'Ljava/util/EnumSet<';
+                  jvmaddencodedtype(tenumdef(tsetdef(def).elementdef).getbasedef,false,encodedstr,true,founderror);
+                  encodedstr:=encodedstr+'>;';
+                end
+              else
+                internalerror(2011051404);
+            end;
+          arraydef :
+            begin
+              if is_array_of_const(def) then
+                begin
+                  internalerror(2011051405);
+                end
+              else if is_packed_array(def) then
+                begin
+                  internalerror(2011051406);
+                end
+              else
+                begin
+                  encodedstr:=encodedstr+'[';
+                  jvmaddencodedsignature(tarraydef(def).elementdef,false,encodedstr);
+                end;
+            end;
+          procvardef :
+            begin
+              { maybe one day }
+              internalerror(2011051407);
+            end;
+          objectdef :
+            begin
+              { maybe one day }
+            end;
+          undefineddef,
+          errordef :
+            begin
+              internalerror(2011051408);
+            end;
+          procdef :
+            { must be done via jvmencodemethod() }
+            internalerror(2011051401);
+        else
+          internalerror(2011051402);
+        end;
+      end;
+
+
+    function jvmaddencodedtype(def: tdef; bpacked: boolean; var encodedstr: TSymStr; forcesignature: boolean; out founderror: tdef): boolean;
+      var
+        c: char;
+      begin
+        result:=true;
+        case def.typ of
+          stringdef :
+            begin
+              case tstringdef(def).stringtype of
+                { translated into java.lang.String }
+                st_widestring,
+                st_unicodestring:
+                  result:=jvmaddencodedtype(java_jlstring,false,encodedstr,forcesignature,founderror);
+                st_ansistring:
+                  result:=jvmaddencodedtype(java_ansistring,false,encodedstr,forcesignature,founderror);
+                st_shortstring:
+                  result:=jvmaddencodedtype(java_shortstring,false,encodedstr,forcesignature,founderror);
+                else
+                  { May be handled via wrapping later  }
+                  result:=false;
+              end;
+            end;
+          enumdef:
+            begin
+              result:=jvmaddencodedtype(tenumdef(def).getbasedef.classdef,false,encodedstr,forcesignature,founderror);
+            end;
+          orddef :
+            begin
+              { for procedure "results" }
+              if is_void(def) then
+                c:='V'
+              { only Pascal-style booleans conform to Java's definition of
+                Boolean }
+              else if is_pasbool(def) and
+                      (def.size=1) then
+                c:='Z'
+              else if is_widechar(def) then
+                c:='C'
+              else
+                begin
+                  case def.size of
+                    1:
+                      c:='B';
+                    2:
+                      c:='S';
+                    4:
+                      c:='I';
+                    8:
+                      c:='J';
+                    else
+                      internalerror(2010121905);
+                  end;
+                end;
+              encodedstr:=encodedstr+c;
+            end;
+          pointerdef :
+            begin
+              if is_voidpointer(def) then
+                result:=jvmaddencodedtype(java_jlobject,false,encodedstr,forcesignature,founderror)
+              else if jvmimplicitpointertype(tpointerdef(def).pointeddef) then
+                result:=jvmaddencodedtype(tpointerdef(def).pointeddef,false,encodedstr,forcesignature,founderror)
+              else
+                begin
+                  { all pointer types are emulated via arrays }
+                  encodedstr:=encodedstr+'[';
+                  result:=jvmaddencodedtype(tpointerdef(def).pointeddef,false,encodedstr,forcesignature,founderror);
+                end
+            end;
+          floatdef :
+            begin
+              case tfloatdef(def).floattype of
+                s32real:
+                  c:='F';
+                s64real:
+                  c:='D';
+                else
+                  result:=false;
+              end;
+              encodedstr:=encodedstr+c;
+            end;
+          filedef :
+            result:=false;
+          recorddef :
+            begin
+              encodedstr:=encodedstr+'L'+trecorddef(def).jvm_full_typename(true)+';'
+            end;
+          variantdef :
+            begin
+              { will be hanlded via wrapping later, although wrapping may
+                happen at higher level }
+              result:=false;
+            end;
+          classrefdef :
+            begin
+              if not forcesignature then
+                { unfortunately, java.lang.Class is final, so we can't create
+                  different versions for difference class reference types }
+                encodedstr:=encodedstr+'Ljava/lang/Class;'
+              { we can however annotate it with extra signature information in
+                using Java's generic annotations }
+              else
+                jvmaddencodedsignature(def,false,encodedstr);
+              result:=true;
+            end;
+          setdef :
+            begin
+              if tsetdef(def).elementdef.typ=enumdef then
+                begin
+                  if forcesignature then
+                    jvmaddencodedsignature(def,false,encodedstr)
+                  else
+                    result:=jvmaddencodedtype(java_juenumset,false,encodedstr,forcesignature,founderror)
+                end
+              else
+                result:=jvmaddencodedtype(java_jubitset,false,encodedstr,forcesignature,founderror)
+            end;
+          formaldef :
+            begin
+              { var/const/out x: JLObject }
+              result:=jvmaddencodedtype(java_jlobject,false,encodedstr,forcesignature,founderror);
+            end;
+          arraydef :
+            begin
+              if is_array_of_const(def) then
+                begin
+                  encodedstr:=encodedstr+'[';
+                  result:=jvmaddencodedtype(search_system_type('TVARREC').typedef,false,encodedstr,forcesignature,founderror);
+                end
+              else if is_packed_array(def) then
+                result:=false
+              else
+                begin
+                  encodedstr:=encodedstr+'[';
+                  if not jvmaddencodedtype(tarraydef(def).elementdef,false,encodedstr,forcesignature,founderror) then
+                    begin
+                      result:=false;
+                      { report the exact (nested) error defintion }
+                      exit;
+                    end;
+                end;
+            end;
+          procvardef :
+            begin
+              result:=jvmaddencodedtype(tprocvardef(def).classdef,false,encodedstr,forcesignature,founderror);
+            end;
+          objectdef :
+            case tobjectdef(def).objecttype of
+              odt_javaclass,
+              odt_interfacejava:
+                begin
+                  def:=maybe_find_real_class_definition(def,false);
+                  encodedstr:=encodedstr+'L'+tobjectdef(def).jvm_full_typename(true)+';'
+                end
+              else
+                result:=false;
+            end;
+          undefineddef,
+          errordef :
+            result:=false;
+          procdef :
+            { must be done via jvmencodemethod() }
+            internalerror(2010121903);
+        else
+          internalerror(2010121904);
+        end;
+        if not result then
+          founderror:=def;
+      end;
+
+
+    function jvmtryencodetype(def: tdef; out encodedtype: TSymStr; forcesignature: boolean; out founderror: tdef): boolean;
+      begin
+        encodedtype:='';
+        result:=jvmaddencodedtype(def,false,encodedtype,forcesignature,founderror);
+      end;
+
+
+    procedure jvmaddtypeownerprefix(owner: tsymtable; var name: TSymStr);
+      var
+        owningcontainer: tsymtable;
+        tmpresult: TSymStr;
+        module: tmodule;
+        nameendpos: longint;
+      begin
+        { see tprocdef.jvmmangledbasename for description of the format }
+        owningcontainer:=owner;
+        while (owningcontainer.symtabletype=localsymtable) do
+          owningcontainer:=owningcontainer.defowner.owner;
+        case owningcontainer.symtabletype of
+          globalsymtable,
+          staticsymtable:
+            begin
+              module:=find_module_from_symtable(owningcontainer);
+              tmpresult:='';
+              if assigned(module.namespace) then
+                tmpresult:=module.namespace^+'/';
+              tmpresult:=tmpresult+module.realmodulename^+'/';
+            end;
+          objectsymtable:
+            case tobjectdef(owningcontainer.defowner).objecttype of
+              odt_javaclass,
+              odt_interfacejava:
+                begin
+                  tmpresult:=tobjectdef(owningcontainer.defowner).jvm_full_typename(true)+'/'
+                end
+              else
+                internalerror(2010122606);
+            end;
+          recordsymtable:
+            tmpresult:=trecorddef(owningcontainer.defowner).jvm_full_typename(true)+'/'
+          else
+            internalerror(2010122605);
+        end;
+        name:=tmpresult+name;
+        nameendpos:=pos(' ',name);
+        if nameendpos=0 then
+          nameendpos:=length(name)+1;
+        insert('''',name,nameendpos);
+        name:=''''+name;
+      end;
+
+
+    function jvmarrtype(def: tdef; out primitivetype: boolean): TSymStr;
+      var
+        errdef: tdef;
+      begin
+        if not jvmtryencodetype(def,result,false,errdef) then
+          internalerror(2011012205);
+        primitivetype:=false;
+        if length(result)=1 then
+          begin
+            case result[1] of
+              'Z': result:='boolean';
+              'C': result:='char';
+              'B': result:='byte';
+              'S': result:='short';
+              'I': result:='int';
+              'J': result:='long';
+              'F': result:='float';
+              'D': result:='double';
+              else
+                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;
+        { for arrays, use the actual reference type }
+      end;
+
+
+    function jvmarrtype_setlength(def: tdef): char;
+      var
+        errdef: tdef;
+        res: TSymStr;
+      begin
+        { keep in sync with rtl/java/jdynarrh.inc and usage in njvminl }
+        if is_record(def) then
+          result:='R'
+        else if is_shortstring(def) then
+          result:='T'
+        else if def.typ=setdef then
+          begin
+            if tsetdef(def).elementdef.typ=enumdef then
+              result:='E'
+            else
+              result:='L'
+          end
+        else if (def.typ=procvardef) and
+                not tprocvardef(def).is_addressonly then
+          result:='P'
+        else
+          begin
+            if not jvmtryencodetype(def,res,false,errdef) then
+              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
+          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,
+          setdef:
+            result:=true;
+          objectdef:
+            result:=is_object(def);
+          stringdef :
+            result:=tstringdef(def).stringtype in [st_shortstring,st_longstring];
+          procvardef:
+            result:=not tprocvardef(def).is_addressonly;
+          else
+            result:=false;
+        end;
+      end;
+
+
+    { mergeints = true means that all integer types are mapped to jllong,
+      otherwise they are mapped to the closest corresponding type }
+    procedure jvmgetboxtype(def: tdef; out objdef, paradef: tdef; mergeints: boolean);
+      begin
+        case def.typ of
+          orddef:
+            begin
+              case torddef(def).ordtype of
+                pasbool8:
+                  begin
+                    objdef:=tobjectdef(search_system_type('JLBOOLEAN').typedef);
+                    paradef:=pasbool8type;
+                  end;
+                uwidechar:
+                  begin
+                    objdef:=tobjectdef(search_system_type('JLCHARACTER').typedef);
+                    paradef:=cwidechartype;
+                  end;
+                else
+                  begin
+                    { wrap all integer types into a JLLONG, so that we don't get
+                      errors after returning a byte assigned to a long etc }
+                    if mergeints or
+                       (torddef(def).ordtype in [s64bit,u64bit,scurrency,bool64bit,pasbool64]) then
+                      begin
+                        objdef:=tobjectdef(search_system_type('JLLONG').typedef);
+                        paradef:=s64inttype;
+                      end
+                    else
+                      begin
+                        case torddef(def).ordtype of
+                          s8bit,
+                          u8bit,
+                          uchar,
+                          bool8bit:
+                            begin
+                              objdef:=tobjectdef(search_system_type('JLBYTE').typedef);
+                              paradef:=s8inttype;
+                            end;
+                          s16bit,
+                          u16bit,
+                          bool16bit,
+                          pasbool16:
+                            begin
+                              objdef:=tobjectdef(search_system_type('JLSHORT').typedef);
+                              paradef:=s16inttype;
+                            end;
+                          s32bit,
+                          u32bit,
+                          bool32bit,
+                          pasbool32:
+                            begin
+                              objdef:=tobjectdef(search_system_type('JLINTEGER').typedef);
+                              paradef:=s32inttype;
+                            end;
+                          else
+                            internalerror(2011052101);
+                        end;
+                      end;
+                  end;
+              end;
+            end;
+          floatdef:
+            begin
+              case tfloatdef(def).floattype of
+                s32real:
+                  begin
+                    objdef:=tobjectdef(search_system_type('JLFLOAT').typedef);
+                    paradef:=s32floattype;
+                  end;
+                s64real:
+                  begin
+                    objdef:=tobjectdef(search_system_type('JLDOUBLE').typedef);
+                    paradef:=s64floattype;
+                  end;
+                else
+                  internalerror(2011052102);
+              end;
+            end;
+          else
+            internalerror(2011052103);
+        end;
+      end;
+
+
+    function jvmgetunboxmethod(def: tdef): string;
+      begin
+        case def.typ of
+          orddef:
+            begin
+              case torddef(def).ordtype of
+                pasbool8:
+                  result:='BOOLEANVALUE';
+                s8bit,
+                u8bit,
+                uchar,
+                bool8bit:
+                  result:='BYTEVALUE';
+                s16bit,
+                u16bit,
+                bool16bit,
+                pasbool16:
+                  result:='SHORTVALUE';
+                s32bit,
+                u32bit,
+                bool32bit,
+                pasbool32:
+                  result:='INTVALUE';
+                s64bit,
+                u64bit,
+                scurrency,
+                bool64bit,
+                pasbool64:
+                  result:='LONGVALUE';
+                uwidechar:
+                  result:='CHARVALUE';
+                else
+                  internalerror(2011071702);
+              end;
+            end;
+          floatdef:
+            begin
+              case tfloatdef(def).floattype of
+                s32real:
+                  result:='FLOATVALUE';
+                s64real:
+                  result:='DOUBLEVALUE';
+                else
+                  internalerror(2011071703);
+              end;
+            end;
+          else
+            internalerror(2011071704);
+        end;
+      end;
+
+
+    function jvmgetcorrespondingclassdef(def: tdef): tdef;
+      var
+        paradef: tdef;
+      begin
+        if def.typ in [orddef,floatdef] then
+          jvmgetboxtype(def,result,paradef,false)
+        else
+          begin
+            case def.typ of
+              stringdef :
+                begin
+                  case tstringdef(def).stringtype of
+                    { translated into java.lang.String }
+                    st_widestring,
+                    st_unicodestring:
+                      result:=java_jlstring;
+                    st_ansistring:
+                      result:=java_ansistring;
+                    st_shortstring:
+                      result:=java_shortstring;
+                    else
+                      internalerror(2011072409);
+                  end;
+                end;
+              enumdef:
+                begin
+                  result:=tenumdef(def).getbasedef.classdef;
+                end;
+              pointerdef :
+                begin
+                  if def=voidpointertype then
+                    result:=java_jlobject
+                  else if jvmimplicitpointertype(tpointerdef(def).pointeddef) then
+                    result:=tpointerdef(def).pointeddef
+                  else
+                    internalerror(2011072410);
+                end;
+              recorddef :
+                begin
+                  result:=def;
+                end;
+              variantdef :
+                begin
+                  result:=cvarianttype;
+                end;
+              classrefdef :
+                begin
+                  result:=search_system_type('JLCLASS').typedef;
+                end;
+              setdef :
+                begin
+                  if tsetdef(def).elementdef.typ=enumdef then
+                    result:=java_juenumset
+                  else
+                    result:=java_jubitset;
+                end;
+              formaldef :
+                begin
+                  result:=java_jlobject;
+                end;
+              arraydef :
+                begin
+                  { cannot represent statically }
+                  internalerror(2011072411);
+                end;
+              procvardef :
+                begin
+                  result:=tprocvardef(def).classdef;
+                end;
+              objectdef :
+                case tobjectdef(def).objecttype of
+                  odt_javaclass,
+                  odt_interfacejava:
+                    result:=def
+                  else
+                    internalerror(2011072412);
+                end;
+              else
+                internalerror(2011072413);
+            end;
+          end;
+      end;
+
+
+  function get_para_push_size(def: tdef): tdef;
+    begin
+      result:=def;
+      if def.typ=orddef then
+        case torddef(def).ordtype of
+          u8bit,uchar:
+            if torddef(def).high>127 then
+              result:=s8inttype;
+          u16bit:
+            if torddef(def).high>32767 then
+              result:=s16inttype;
+        end;
+    end;
+
+
+    function jvmgetthreadvardef(def: tdef): tdef;
+      begin
+        if (def.typ=arraydef) and
+           not is_dynamic_array(def) then
+          begin
+            result:=search_system_type('FPCNORMALARRAYTHREADVAR').typedef;
+            exit;
+          end;
+        if jvmimplicitpointertype(def) then
+          begin
+            result:=search_system_type('FPCIMPLICITPTRTHREADVAR').typedef;
+            exit;
+          end;
+        case def.typ of
+          orddef:
+            begin
+              case torddef(def).ordtype of
+                pasbool8:
+                  begin
+                    result:=tobjectdef(search_system_type('FPCBOOLEANTHREADVAR').typedef);
+                  end;
+                uwidechar:
+                  begin
+                    result:=tobjectdef(search_system_type('FPCCHARTHREADVAR').typedef);
+                  end;
+                s8bit,
+                u8bit,
+                uchar,
+                bool8bit:
+                  begin
+                    result:=tobjectdef(search_system_type('FPCBYTETHREADVAR').typedef);
+                  end;
+                s16bit,
+                u16bit,
+                bool16bit,
+                pasbool16:
+                  begin
+                    result:=tobjectdef(search_system_type('FPCSHORTTHREADVAR').typedef);
+                  end;
+                s32bit,
+                u32bit,
+                bool32bit,
+                pasbool32:
+                  begin
+                    result:=tobjectdef(search_system_type('FPCINTTHREADVAR').typedef);
+                  end;
+                s64bit,
+                u64bit,
+                scurrency,
+                bool64bit,
+                pasbool64:
+                  begin
+                    result:=tobjectdef(search_system_type('FPCLONGTHREADVAR').typedef);
+                  end
+                else
+                  internalerror(2011082101);
+              end;
+            end;
+          floatdef:
+            begin
+              case tfloatdef(def).floattype of
+                s32real:
+                  begin
+                    result:=tobjectdef(search_system_type('FPCFLOATTHREADVAR').typedef);
+                  end;
+                s64real:
+                  begin
+                    result:=tobjectdef(search_system_type('FPCDOUBLETHREADVAR').typedef);
+                  end;
+                else
+                  internalerror(2011082102);
+              end;
+            end
+          else
+            begin
+              result:=search_system_type('FPCPOINTERTHREADVAR').typedef
+            end;
+        end;
+      end;
+
+
+    procedure jvmgetarraydimdef(arrdef: tdef; out eledef: tdef; out ndim: longint);
+      begin
+        eledef:=arrdef;
+        ndim:=0;
+        repeat
+          eledef:=tarraydef(eledef).elementdef;
+          inc(ndim);
+        until (eledef.typ<>arraydef) or
+              is_dynamic_array(eledef);
+      end;
+
+
+
+    function jvmmangledbasename(sym: tsym; const usesymname: TSymStr; withsignature: boolean): TSymStr;
+      var
+        container: tsymtable;
+        vsym: tabstractvarsym;
+        csym: tconstsym;
+        usedef: tdef;
+      begin
+        case sym.typ of
+          staticvarsym,
+          paravarsym,
+          localvarsym,
+          fieldvarsym:
+            begin
+              vsym:=tabstractvarsym(sym);
+              { for local and paravarsyms that are unsigned 8/16 bit, change the
+                outputted type to signed 16/32 bit:
+                  a) the stack slots are all 32 bit anyway, so the storage allocation
+                     is still correct
+                  b) since at the JVM level all types are signed, this makes sure
+                     that the values in the stack slots are valid for the specified
+                     types
+              }
+              usedef:=vsym.vardef;
+              if vsym.typ in [localvarsym,paravarsym] then
+                begin
+                  if (usedef.typ=orddef) then
+                    case torddef(usedef).ordtype of
+                      u8bit,uchar:
+                        usedef:=s16inttype;
+                      u16bit:
+                        usedef:=s32inttype;
+                    end;
+                end;
+              result:=jvmencodetype(usedef,false);
+              if withsignature and
+                 jvmtypeneedssignature(usedef) then
+                begin
+                  result:=result+' signature "';
+                  result:=result+jvmencodetype(usedef,true)+'"';
+                end;
+              if (vsym.typ=paravarsym) and
+                 (vo_is_self in tparavarsym(vsym).varoptions) then
+                result:='''this'' ' +result
+              else if (vsym.typ in [paravarsym,localvarsym]) and
+                      ([vo_is_funcret,vo_is_result] * tabstractnormalvarsym(vsym).varoptions <> []) then
+                result:='''result'' '+result
+              else
+                begin
+                  { add array indirection if required }
+                  if (vsym.typ=paravarsym) and
+                     ((usedef.typ=formaldef) or
+                      ((vsym.varspez in [vs_var,vs_out,vs_constref]) and
+                       not jvmimplicitpointertype(usedef))) then
+                    result:='['+result;
+                  { single quotes for definitions to prevent clashes with Java
+                    opcodes }
+                  if withsignature then
+                    result:=usesymname+''' '+result
+                  else
+                    result:=usesymname+' '+result;
+                  { we have to mangle staticvarsyms in localsymtables to
+                    prevent name clashes... }
+                  if (vsym.typ=staticvarsym) then
+                    begin
+                      container:=sym.Owner;
+                      while (container.symtabletype=localsymtable) do
+                        begin
+                          if tdef(container.defowner).typ<>procdef then
+                            internalerror(2011040303);
+                          { defid is added to prevent problem with overloads }
+                          result:=tprocdef(container.defowner).procsym.realname+'$$'+tostr(tprocdef(container.defowner).defid)+'$'+result;
+                          container:=container.defowner.owner;
+                        end;
+                    end;
+                  if withsignature then
+                    result:=''''+result
+                end;
+            end;
+          constsym:
+            begin
+              csym:=tconstsym(sym);
+              { some constants can be untyped }
+              if assigned (csym.constdef) then
+                begin
+                  result:=jvmencodetype(csym.constdef,false);
+                  if withsignature and
+                     jvmtypeneedssignature(csym.constdef) then
+                    begin
+                      result:=result+' signature "';
+                      result:=result+jvmencodetype(csym.constdef,true)+'"';
+                    end;
+                end
+              else
+                begin
+                  case csym.consttyp of
+                    constord:
+                      result:=jvmencodetype(s32inttype,withsignature);
+                    constreal:
+                      result:=jvmencodetype(s64floattype,withsignature);
+                    constset:
+                      internalerror(2011040701);
+                    constpointer,
+                    constnil:
+                      result:=jvmencodetype(java_jlobject,withsignature);
+                    constwstring,
+                    conststring:
+                      result:=jvmencodetype(java_jlstring,withsignature);
+                    constresourcestring:
+                      internalerror(2011040702);
+                    else
+                      internalerror(2011040703);
+                  end;
+                end;
+              if withsignature then
+                result:=''''+usesymname+''' '+result
+              else
+                result:=usesymname+' '+result
+            end;
+          else
+            internalerror(2011021703);
+        end;
+      end;
+
+
+    function jvmmangledbasename(sym: tsym; withsignature: boolean): TSymStr;
+      begin
+        if (sym.typ=fieldvarsym) and
+           assigned(tfieldvarsym(sym).externalname) then
+          result:=jvmmangledbasename(sym,tfieldvarsym(sym).externalname^,withsignature)
+        else if (sym.typ=staticvarsym) and
+           (tstaticvarsym(sym).mangledbasename<>'') then
+          result:=jvmmangledbasename(sym,tstaticvarsym(sym).mangledbasename,withsignature)
+        else
+          result:=jvmmangledbasename(sym,sym.RealName,withsignature);
+      end;
+
+{******************************************************************
+                    jvm type validity checking
+*******************************************************************}
+
+   function jvmencodetype(def: tdef; withsignature: boolean): TSymStr;
+     var
+       errordef: tdef;
+     begin
+       if not jvmtryencodetype(def,result,withsignature,errordef) then
+         internalerror(2011012305);
+     end;
+
+
+   function jvmchecktype(def: tdef; out founderror: tdef): boolean;
+      var
+        encodedtype: TSymStr;
+      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,false,founderror);
+      end;
+
+
+end.

compiler/jvm/jvmreg.dat

@@ -0,0 +1,20 @@
+;
+; JVM registers
+;
+; layout
+; <name>,<type>,<subtype>,<value>,<stdname>
+;
+; The JVM does not have any registers, since it is stack-based.
+; We do define a few artificial registers to make integration
+; with the rest of the compiler easier though.
+
+; general/int registers
+NO,$00,$00,$00,INVALID
+; used as base register in reference when referring to the top
+; of the evaluation stack (offset = offset on the evaluation
+; stack)
+R0,$01,$00,$00,evalstacktopptr
+; for addressing locals ("stack pointer")
+R1,$01,$00,$01,localsstackptr
+; generic fake evaluation stack register for use by the register allocator
+R2,$01,$00,$02,evalstacktop

compiler/jvm/njvmadd.pas

@@ -0,0 +1,534 @@
+{
+    Copyright (c) 2000-2011 by Florian Klaempfl and Jonas Maebe
+
+    Code generation for add nodes on the JVM
+
+    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 njvmadd;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+       cgbase,
+       node,ncgadd,cpubase;
+
+    type
+
+       { tjvmaddnode }
+
+       tjvmaddnode = class(tcgaddnode)
+          function pass_1: tnode;override;
+       protected
+          function jvm_first_addset: tnode;
+
+          function cmpnode2topcmp(unsigned: boolean): TOpCmp;
+
+          procedure second_generic_compare(unsigned: boolean);
+
+          procedure pass_left_right;override;
+          procedure second_addfloat;override;
+          procedure second_cmpfloat;override;
+          procedure second_cmpboolean;override;
+          procedure second_cmp64bit;override;
+          procedure second_add64bit; override;
+          procedure second_cmpordinal;override;
+       end;
+
+  implementation
+
+    uses
+      systems,
+      cutils,verbose,constexp,globtype,
+      symconst,symtable,symdef,
+      paramgr,procinfo,pass_1,
+      aasmtai,aasmdata,aasmcpu,defutil,
+      hlcgobj,hlcgcpu,cgutils,
+      cpupara,
+      nbas,ncon,nset,nadd,ncal,ncnv,ninl,nld,nmat,nmem,
+      njvmcon,
+      cgobj;
+
+{*****************************************************************************
+                               tjvmaddnode
+*****************************************************************************}
+
+    function tjvmaddnode.pass_1: tnode;
+      begin
+        { special handling for enums: they're classes in the JVM -> get their
+          ordinal value to compare them (do before calling inherited pass_1,
+          because pass_1 will convert enum constants from ordinals into class
+          instances) }
+        if (left.resultdef.typ=enumdef) and
+           (right.resultdef.typ=enumdef) then
+          begin
+            { enums can only be compared at this stage (add/sub is only allowed
+              in constant expressions) }
+            if not is_boolean(resultdef) then
+              internalerror(2011062603);
+            inserttypeconv_explicit(left,s32inttype);
+            inserttypeconv_explicit(right,s32inttype);
+          end;
+        { special handling for sets: all sets are JUBitSet/JUEnumSet on the JVM
+          target to ease interoperability with Java code }
+        if left.resultdef.typ=setdef then
+          begin
+            result:=jvm_first_addset;
+            exit;
+          end;
+        { special handling for comparing a dynamic array to nil: dynamic arrays
+          can be empty on the jvm target and not be different from nil at the
+          same time (array of 0 elements) -> change into length check }
+        if is_dynamic_array(left.resultdef) and
+           (right.nodetype=niln) then
+          begin
+           result:=caddnode.create(nodetype,cinlinenode.create(in_length_x,false,left),genintconstnode(0));
+           left:=nil;
+           exit;
+          end;
+        if is_dynamic_array(right.resultdef) and
+           (left.nodetype=niln) then
+          begin
+            result:=caddnode.create(nodetype,cinlinenode.create(in_length_x,false,right),genintconstnode(0));
+            right:=nil;
+            exit;
+          end;
+        result:=inherited pass_1;
+        if expectloc=LOC_FLAGS then
+          expectloc:=LOC_JUMP;
+      end;
+
+
+    function tjvmaddnode.jvm_first_addset: tnode;
+
+      procedure call_set_helper_paras(const n : string; isenum: boolean; paras: tcallparanode);
+        var
+          block: tblocknode;
+          stat: tstatementnode;
+          temp: ttempcreatenode;
+        begin
+          result:=ccallnode.createinternmethod(left,'CLONE',nil);
+          if isenum then
+            inserttypeconv_explicit(result,java_juenumset)
+          else
+            inserttypeconv_explicit(result,java_jubitset);
+          if isenum then
+            begin
+              { all enum instance methods return a boolean, while we are
+                interested in the resulting set }
+              block:=internalstatements(stat);
+              temp:=ctempcreatenode.create(java_juenumset,4,tt_persistent,true);
+              addstatement(stat,temp);
+              addstatement(stat,cassignmentnode.create(
+                ctemprefnode.create(temp),result));
+              addstatement(stat,ccallnode.createinternmethod(
+                ctemprefnode.create(temp),n,paras));
+              addstatement(stat,ctempdeletenode.create_normal_temp(temp));
+              addstatement(stat,ctemprefnode.create(temp));
+              result:=block;
+            end
+          else
+            result:=ccallnode.createinternmethod(result,n,paras);
+        end;
+
+      procedure call_set_helper(const n: string; isenum: boolean);
+        begin
+          call_set_helper_paras(n,isenum,ccallparanode.create(right,nil));
+        end;
+
+      var
+        procname: string;
+        tmpn: tnode;
+        paras: tcallparanode;
+        isenum: boolean;
+      begin
+        isenum:=
+          (assigned(tsetdef(left.resultdef).elementdef) and
+           (tsetdef(left.resultdef).elementdef.typ=enumdef)) or
+          ((right.nodetype=setelementn) and
+           (tsetelementnode(right).left.resultdef.typ=enumdef)) or
+          ((right.resultdef.typ=setdef) and
+           assigned(tsetdef(right.resultdef).elementdef) and
+           (tsetdef(right.resultdef).elementdef.typ=enumdef));
+        { don't destroy optimization opportunity }
+        if not((nodetype=addn) and
+               (right.nodetype=setelementn) and
+               is_emptyset(left)) then
+          begin
+            left:=caddrnode.create_internal(left);
+            include(left.flags,nf_typedaddr);
+            if isenum then
+              begin
+                inserttypeconv_explicit(left,java_juenumset);
+                if right.resultdef.typ=setdef then
+                  begin
+                    right:=caddrnode.create_internal(right);
+                    include(right.flags,nf_typedaddr);
+                    inserttypeconv_explicit(right,java_juenumset);
+                  end;
+              end
+            else
+              begin
+                inserttypeconv_explicit(left,java_jubitset);
+                if right.resultdef.typ=setdef then
+                  begin
+                    right:=caddrnode.create_internal(right);
+                    include(right.flags,nf_typedaddr);
+                    inserttypeconv_explicit(right,java_jubitset);
+                  end;
+              end;
+          end
+        else
+          tjvmsetconstnode(left).setconsttype:=sct_notransform;
+        firstpass(left);
+        firstpass(right);
+        case nodetype of
+          equaln,unequaln,lten,gten:
+            begin
+              case nodetype of
+                equaln,unequaln:
+                  procname:='EQUALS';
+                lten,gten:
+                  begin
+                    { (left <= right) = (right >= left) }
+                    if nodetype=lten then
+                      begin
+                        tmpn:=left;
+                        left:=right;
+                        right:=tmpn;
+                      end;
+                      procname:='CONTAINSALL'
+                    end;
+                end;
+              result:=ccallnode.createinternmethod(left,procname,ccallparanode.create(right,nil));
+              { for an unequaln, we have to negate the result of equals }
+              if nodetype=unequaln then
+                result:=cnotnode.create(result);
+            end;
+          addn:
+            begin
+              { optimize first loading of a set }
+              if (right.nodetype=setelementn) and
+                  is_emptyset(left) then
+                begin
+                  paras:=nil;
+                  procname:='OF';
+                  if isenum then
+                    begin
+                      inserttypeconv_explicit(tsetelementnode(right).left,tenumdef(tsetelementnode(right).left.resultdef).getbasedef.classdef);
+                      result:=cloadvmtaddrnode.create(ctypenode.create(java_juenumset));
+                    end
+                  else
+                    begin
+                      { for boolean, char, etc }
+                      inserttypeconv_explicit(tsetelementnode(right).left,s32inttype);
+                      result:=cloadvmtaddrnode.create(ctypenode.create(java_jubitset));
+                    end;
+                  paras:=ccallparanode.create(tsetelementnode(right).left,nil);
+                  tsetelementnode(right).left:=nil;
+                  if assigned(tsetelementnode(right).right) then
+                    begin
+                      procname:='RANGE';
+                      if isenum then
+                        begin
+                          inserttypeconv_explicit(tsetelementnode(right).right,tenumdef(tsetelementnode(right).right.resultdef).getbasedef.classdef);
+                        end
+                      else
+                        begin
+                          inserttypeconv_explicit(tsetelementnode(right).right,s32inttype);
+                        end;
+                      paras:=ccallparanode.create(tsetelementnode(right).right,paras);
+                      tsetelementnode(right).right:=nil;
+                    end;
+                  right.free;
+                  result:=ccallnode.createinternmethod(result,procname,paras)
+                end
+              else
+                begin
+                  if right.nodetype=setelementn then
+                    begin
+                      paras:=nil;
+                      { get a copy of left to add to }
+                      procname:='ADD';
+                      if isenum then
+                        begin
+                          inserttypeconv_explicit(tsetelementnode(right).left,tenumdef(tsetelementnode(right).left.resultdef).getbasedef.classdef);
+                        end
+                      else
+                        begin
+                          { for boolean, char, etc }
+                          inserttypeconv_explicit(tsetelementnode(right).left,s32inttype);
+                        end;
+                      paras:=ccallparanode.create(tsetelementnode(right).left,paras);
+                      tsetelementnode(right).left:=nil;
+                      if assigned(tsetelementnode(right).right) then
+                        begin
+                          procname:='ADDALL';
+                          { create a set containing the range via the class
+                            factory method, then add all of its elements }
+                          if isenum then
+                            begin
+                              inserttypeconv_explicit(tsetelementnode(right).right,tenumdef(tsetelementnode(right).right.resultdef).getbasedef.classdef);
+                              tmpn:=cloadvmtaddrnode.create(ctypenode.create(java_juenumset));
+                            end
+                          else
+                            begin
+                              inserttypeconv_explicit(tsetelementnode(right).right,s32inttype);
+                              tmpn:=cloadvmtaddrnode.create(ctypenode.create(java_jubitset));
+                            end;
+                          paras:=ccallparanode.create(ccallnode.createinternmethod(tmpn,'RANGE',ccallparanode.create(tsetelementnode(right).right,paras)),nil);
+                          tsetelementnode(right).right:=nil;
+                        end;
+                      call_set_helper_paras(procname,isenum,paras);
+                    end
+                  else
+                    call_set_helper('ADDALL',isenum)
+                end
+            end;
+          subn:
+            call_set_helper('REMOVEALL',isenum);
+          symdifn:
+            if isenum then
+              begin
+                { "s1 xor s2" is the same as "(s1 + s2) - (s1 * s2)"
+                  -> call helper to prevent double evaluations }
+                result:=ccallnode.createintern('fpc_enumset_symdif',
+                  ccallparanode.create(right,ccallparanode.create(left,nil)));
+                left:=nil;
+                right:=nil;
+              end
+            else
+              call_set_helper('SYMDIF',isenum);
+          muln:
+            call_set_helper('RETAINALL',isenum)
+          else
+            internalerror(2011062807);
+        end;
+        { convert helper result back to original set type for further expression
+          evaluation }
+        if not is_boolean(resultdef) then
+          begin
+            inserttypeconv_explicit(result,getpointerdef(resultdef));
+            result:=cderefnode.create(result);
+          end;
+        { left and right are reused as parameters }
+        left:=nil;
+        right:=nil;
+      end;
+
+
+    function tjvmaddnode.cmpnode2topcmp(unsigned: boolean): TOpCmp;
+      begin
+        if not unsigned then
+          case nodetype of
+            gtn: result:=OC_GT;
+            gten: result:=OC_GTE;
+            ltn: result:=OC_LT;
+            lten: result:=OC_LTE;
+            equaln: result:=OC_EQ;
+            unequaln: result:=OC_NE;
+            else
+              internalerror(2011010412);
+          end
+        else
+        case nodetype of
+          gtn: result:=OC_A;
+          gten: result:=OC_AE;
+          ltn: result:=OC_B;
+          lten: result:=OC_BE;
+          equaln: result:=OC_EQ;
+          unequaln: result:=OC_NE;
+          else
+            internalerror(2011010412);
+        end;
+      end;
+
+
+    procedure tjvmaddnode.second_generic_compare(unsigned: boolean);
+      var
+        cmpop: TOpCmp;
+      begin
+        pass_left_right;
+        { swap the operands to make it easier for the optimizer to optimize
+          the operand stack slot reloading in case both are in a register }
+        if (left.location.loc in [LOC_REGISTER,LOC_CREGISTER]) and
+           (right.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
+          swapleftright;
+        cmpop:=cmpnode2topcmp(unsigned);
+        if (nf_swapped in flags) then
+          cmpop:=swap_opcmp(cmpop);
+        location_reset(location,LOC_JUMP,OS_NO);
+
+        if left.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
+          hlcg.a_cmp_loc_reg_label(current_asmdata.CurrAsmList,left.resultdef,cmpop,right.location,left.location.register,current_procinfo.CurrTrueLabel)
+        else case right.location.loc of
+          LOC_REGISTER,LOC_CREGISTER:
+            hlcg.a_cmp_reg_loc_label(current_asmdata.CurrAsmList,left.resultdef,cmpop,right.location.register,left.location,current_procinfo.CurrTrueLabel);
+          LOC_REFERENCE,LOC_CREFERENCE:
+            hlcg.a_cmp_ref_loc_label(current_asmdata.CurrAsmList,left.resultdef,cmpop,right.location.reference,left.location,current_procinfo.CurrTrueLabel);
+          LOC_CONSTANT:
+            hlcg.a_cmp_const_loc_label(current_asmdata.CurrAsmList,left.resultdef,cmpop,right.location.value,left.location,current_procinfo.CurrTrueLabel);
+          else
+            internalerror(2011010413);
+        end;
+        hlcg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+      end;
+
+    procedure tjvmaddnode.pass_left_right;
+      begin
+        swapleftright;
+        inherited pass_left_right;
+      end;
+
+
+    procedure tjvmaddnode.second_addfloat;
+      var
+        op : TAsmOp;
+        commutative : boolean;
+      begin
+        pass_left_right;
+
+        location_reset(location,LOC_FPUREGISTER,def_cgsize(resultdef));
+        location.register:=hlcg.getfpuregister(current_asmdata.CurrAsmList,resultdef);
+
+        commutative:=false;
+        case nodetype of
+          addn :
+            begin
+              if location.size=OS_F64 then
+                op:=a_dadd
+              else
+                op:=a_fadd;
+              commutative:=true;
+            end;
+          muln :
+            begin
+              if location.size=OS_F64 then
+                op:=a_dmul
+              else
+                op:=a_fmul;
+              commutative:=true;
+            end;
+          subn :
+            begin
+              if location.size=OS_F64 then
+                op:=a_dsub
+              else
+                op:=a_fsub;
+            end;
+          slashn :
+            begin
+              if location.size=OS_F64 then
+                op:=a_ddiv
+              else
+                op:=a_fdiv;
+            end;
+          else
+            internalerror(2011010402);
+        end;
+
+        { swap the operands to make it easier for the optimizer to optimize
+          the operand stack slot reloading (non-commutative operations must
+          always be in the correct order though) }
+        if (commutative and
+            (left.location.loc in [LOC_FPUREGISTER,LOC_CFPUREGISTER]) and
+            (right.location.loc in [LOC_FPUREGISTER,LOC_CFPUREGISTER])) or
+           (not commutative and
+            (nf_swapped in flags)) then
+          swapleftright;
+
+        thlcgjvm(hlcg).a_load_loc_stack(current_asmdata.CurrAsmList,left.resultdef,left.location);
+        thlcgjvm(hlcg).a_load_loc_stack(current_asmdata.CurrAsmList,right.resultdef,right.location);
+
+        current_asmdata.CurrAsmList.concat(taicpu.op_none(op));
+        thlcgjvm(hlcg).decstack(current_asmdata.CurrAsmList,1+ord(location.size=OS_F64));
+        { could be optimized in the future by keeping the results on the stack,
+          if we add code to swap the operands when necessary (a_swap for
+          singles, store/load/load for doubles since there is no swap for
+          2-slot elements -- also adjust expectloc in that case! }
+        thlcgjvm(hlcg).a_load_stack_reg(current_asmdata.CurrAsmList,resultdef,location.register);
+      end;
+
+
+    procedure tjvmaddnode.second_cmpfloat;
+      var
+        op : tasmop;
+        cmpop: TOpCmp;
+      begin
+        pass_left_right;
+        { swap the operands to make it easier for the optimizer to optimize
+          the operand stack slot reloading in case both are in a register }
+        if (left.location.loc in [LOC_FPUREGISTER,LOC_CFPUREGISTER]) and
+           (right.location.loc in [LOC_FPUREGISTER,LOC_CFPUREGISTER]) then
+          swapleftright;
+        cmpop:=cmpnode2topcmp(false);
+        if (nf_swapped in flags) then
+          cmpop:=swap_opcmp(cmpop);
+        location_reset(location,LOC_JUMP,OS_NO);
+
+        thlcgjvm(hlcg).a_load_loc_stack(current_asmdata.CurrAsmList,left.resultdef,left.location);
+        thlcgjvm(hlcg).a_load_loc_stack(current_asmdata.CurrAsmList,right.resultdef,right.location);
+
+        { compares two floating point values and puts 1/0/-1 on stack depending
+          on whether value1 >/=/< value2 }
+        if left.location.size=OS_F64 then
+          { make sure that comparisons with NaNs always return false for </> }
+          if nodetype in [ltn,lten] then
+            op:=a_dcmpg
+          else
+            op:=a_dcmpl
+        else if nodetype in [ltn,lten] then
+          op:=a_fcmpg
+        else
+          op:=a_fcmpl;
+        current_asmdata.CurrAsmList.concat(taicpu.op_none(op));
+        thlcgjvm(hlcg).decstack(current_asmdata.CurrAsmList,(1+ord(left.location.size=OS_F64))*2-1);
+
+        current_asmdata.CurrAsmList.concat(taicpu.op_sym(opcmp2if[cmpop],current_procinfo.CurrTrueLabel));
+        thlcgjvm(hlcg).decstack(current_asmdata.CurrAsmList,1);
+        hlcg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+      end;
+
+
+    procedure tjvmaddnode.second_cmpboolean;
+      begin
+        second_generic_compare(true);
+      end;
+
+
+    procedure tjvmaddnode.second_cmp64bit;
+      begin
+        second_generic_compare(not is_signed(left.resultdef));
+      end;
+
+
+    procedure tjvmaddnode.second_add64bit;
+      begin
+        second_opordinal;
+      end;
+
+
+    procedure tjvmaddnode.second_cmpordinal;
+      begin
+        second_generic_compare(not is_signed(left.resultdef));
+      end;
+
+begin
+  caddnode:=tjvmaddnode;
+end.

compiler/jvm/njvmcal.pas

@@ -0,0 +1,608 @@
+{
+    Copyright (c) 2011 by Jonas Maebe
+
+    JVM-specific code for call nodes
+
+    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 njvmcal;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+      cgbase,
+      symtype,symdef,
+      node,ncal,ncgcal;
+
+    type
+       tjvmcallparanode = class(tcgcallparanode)
+        protected
+         procedure push_formal_para; override;
+         procedure push_copyout_para; override;
+
+         procedure handlemanagedbyrefpara(orgparadef: tdef); override;
+       end;
+
+       { tjvmcallnode }
+
+       tjvmcallnode = class(tcgcallnode)
+        protected
+         procedure wrapcomplexinlinepara(para: tcallparanode); override;
+         procedure extra_pre_call_code; override;
+         procedure set_result_location(realresdef: tstoreddef); override;
+         procedure do_release_unused_return_value;override;
+         procedure extra_post_call_code; override;
+         function dispatch_procvar: tnode;
+         procedure remove_hidden_paras;
+        public
+         function pass_typecheck: tnode; override;
+         function pass_1: tnode; override;
+       end;
+
+
+implementation
+
+    uses
+      verbose,globals,globtype,constexp,cutils,
+      symconst,symtable,symsym,defutil,
+      cgutils,tgobj,procinfo,htypechk,
+      cpubase,aasmdata,aasmcpu,
+      hlcgobj,hlcgcpu,
+      pass_1,nutils,nadd,nbas,ncnv,ncon,nflw,ninl,nld,nmem,
+      jvmdef;
+
+{*****************************************************************************
+                           TJVMCALLPARANODE
+*****************************************************************************}
+
+    procedure tjvmcallparanode.push_formal_para;
+      begin
+        { primitive values are boxed, so in all cases this is a pointer to
+          something and since it cannot be changed (or is not supposed to be
+          changed anyway), we don't have to create a temporary array to hold a
+          pointer to this value and can just pass the pointer to this value
+          directly.
+
+          In case the value can be changed (formal var/out), then we have
+          already created a temporary array of one element that holds the boxed
+          (or in case of a non-primitive type: original) value. The reason is
+          that copying it back out may be a complex operation which we don't
+          want to handle at the code generator level.
+
+          -> always push a value parameter (which is either an array of one
+          element, or an object) }
+        push_value_para
+      end;
+
+
+    procedure tjvmcallparanode.push_copyout_para;
+      begin
+        { everything is wrapped and replaced by handlemanagedbyrefpara() in
+          pass_1 }
+        push_value_para;
+      end;
+
+
+    procedure getparabasenodes(p: tnode; out basenode: tnode; out parent: tunarynode);
+      begin
+        parent:=nil;
+        while assigned(p) do
+          begin
+            case p.nodetype of
+              inlinen:
+                begin
+                  if tinlinenode(p).inlinenumber=in_box_x then
+                    begin
+                      parent:=tunarynode(p);
+                      p:=parent.left;
+                    end
+                  else
+                    break;
+                end;
+              subscriptn,
+              vecn:
+                begin
+                  break;
+                end;
+              typeconvn:
+                begin
+                  parent:=tunarynode(p);
+                  { skip typeconversions that don't change the node type }
+                  p:=p.actualtargetnode;
+                end;
+              derefn:
+                begin
+                  parent:=tunarynode(p);
+                  p:=tunarynode(p).left;
+                end
+              else
+                break;
+            end;
+          end;
+        basenode:=p;
+      end;
+
+
+    function replacewithtemp(var orgnode:tnode): ttempcreatenode;
+      begin
+        if valid_for_var(orgnode,false) then
+          result:=ctempcreatenode.create_reference(
+            orgnode.resultdef,orgnode.resultdef.size,
+            tt_persistent,true,orgnode,true)
+        else
+          result:=ctempcreatenode.create_value(
+            orgnode.resultdef,orgnode.resultdef.size,
+            tt_persistent,true,orgnode);
+        { this node is reused while constructing the temp }
+        orgnode:=ctemprefnode.create(result);
+        typecheckpass(orgnode);
+      end;
+
+
+    procedure tjvmcallparanode.handlemanagedbyrefpara(orgparadef: tdef);
+      var
+        arrdef: tarraydef;
+        arreledef: tdef;
+        initstat,
+        copybackstat,
+        finistat: tstatementnode;
+        finiblock: tblocknode;
+        realpara, tempn, unwrappedele0, unwrappedele1: tnode;
+        realparaparent: tunarynode;
+        realparatemp, arraytemp: ttempcreatenode;
+        leftcopy: tnode;
+        implicitptrpara,
+        verifyout: boolean;
+      begin
+        { implicit pointer types are already pointers -> no need to stuff them
+          in an array to pass them by reference (except in case of a formal
+          parameter, in which case everything is passed in an array since the
+          callee can't know what was passed in) }
+        if jvmimplicitpointertype(orgparadef) and
+           (parasym.vardef.typ<>formaldef) then
+           exit;
+
+        fparainit:=internalstatements(initstat);
+        fparacopyback:=internalstatements(copybackstat);
+        finiblock:=internalstatements(finistat);
+        getparabasenodes(left,realpara,realparaparent);
+        { make sure we can get a copy of left safely, so we can use it both
+          to load the original parameter value and to assign the result again
+          afterwards (if required) }
+
+        { special case for access to string character, because those are
+          translated into function calls that differ depending on which side of
+          an assignment they are on }
+        if (realpara.nodetype=vecn) and
+           (tvecnode(realpara).left.resultdef.typ=stringdef) then
+          begin
+            if node_complexity(tvecnode(realpara).left)>1 then
+              begin
+                realparatemp:=replacewithtemp(tvecnode(realpara).left);
+                addstatement(initstat,realparatemp);
+                addstatement(finistat,ctempdeletenode.create(realparatemp));
+              end;
+            if node_complexity(tvecnode(realpara).right)>1 then
+              begin
+                realparatemp:=replacewithtemp(tvecnode(realpara).right);
+                addstatement(initstat,realparatemp);
+                addstatement(finistat,ctempdeletenode.create(realparatemp));
+              end;
+          end
+        else
+          begin
+            { general case: if it's possible that there's a function call
+              involved, use a temp to prevent double evaluations }
+            if assigned(realparaparent) then
+              begin
+                realparatemp:=replacewithtemp(realparaparent.left);
+                addstatement(initstat,realparatemp);
+                addstatement(finistat,ctempdeletenode.create(realparatemp));
+              end;
+          end;
+        { create a copy of the original left (with temps already substituted),
+          so we can use it if required to handle copying the return value back }
+        leftcopy:=left.getcopy;
+        implicitptrpara:=jvmimplicitpointertype(orgparadef);
+        { create the array temp that that will serve as the paramter }
+        if parasym.vardef.typ=formaldef then
+          arreledef:=java_jlobject
+        else if implicitptrpara then
+          arreledef:=getpointerdef(orgparadef)
+        else
+          arreledef:=parasym.vardef;
+        arrdef:=getarraydef(arreledef,1+ord(cs_check_var_copyout in current_settings.localswitches));
+        { the -1 means "use the array's element count to determine the number
+          of elements" in the JVM temp generator }
+        arraytemp:=ctempcreatenode.create(arrdef,-1,tt_persistent,true);
+        addstatement(initstat,arraytemp);
+        addstatement(finistat,ctempdeletenode.create(arraytemp));
+
+        { we can also check out-parameters if we are certain that they'll be
+          valid according to the JVM. That's basically everything except for
+          local variables (fields, arrays etc are all initialized on creation) }
+        verifyout:=
+          (cs_check_var_copyout in current_settings.localswitches) and
+          ((left.actualtargetnode.nodetype<>loadn) or
+           (tloadnode(left.actualtargetnode).symtableentry.typ<>localvarsym));
+
+        { in case of a non-out parameter, pass in the original value (also
+          always in case of implicitpointer type, since that pointer points to
+          the data that will be changed by the callee) }
+        if (parasym.varspez<>vs_out) or
+           verifyout or
+           ((parasym.vardef.typ<>formaldef) and
+            implicitptrpara) then
+          begin
+            if implicitptrpara then
+              begin
+                { pass pointer to the struct }
+                left:=caddrnode.create_internal(left);
+                include(left.flags,nf_typedaddr);
+                typecheckpass(left);
+              end;
+            { wrap the primitive type in an object container
+              if required }
+            if parasym.vardef.typ=formaldef then
+              begin
+                if (left.resultdef.typ in [orddef,floatdef]) then
+                  begin
+                    left:=cinlinenode.create(in_box_x,false,ccallparanode.create(left,nil));
+                    typecheckpass(left);
+                  end;
+                left:=ctypeconvnode.create_explicit(left,java_jlobject);
+              end;
+            { put the parameter value in the array }
+            addstatement(initstat,cassignmentnode.create(
+              cvecnode.create(ctemprefnode.create(arraytemp),genintconstnode(0)),
+              left));
+            { and the copy for checking }
+            if (cs_check_var_copyout in current_settings.localswitches) then
+              addstatement(initstat,cassignmentnode.create(
+                cvecnode.create(ctemprefnode.create(arraytemp),genintconstnode(1)),
+                cvecnode.create(ctemprefnode.create(arraytemp),genintconstnode(0))));
+          end
+        else
+          left.free;
+        { replace the parameter with the temp array }
+        left:=ctemprefnode.create(arraytemp);
+        { generate the code to copy back the changed value into the original
+          parameter in case of var/out.
+
+          In case of a formaldef, changes to the parameter in the callee change
+          the pointer inside the array -> we have to copy back the changes in
+          all cases.
+
+          In case of a regular parameter, we only have to copy things back in
+          case it's not an implicit pointer type. The reason is that for
+          implicit pointer types, any changes will have been directly applied
+          to the original parameter via the implicit pointer that we passed in }
+        if (parasym.varspez in [vs_var,vs_out]) and
+           ((parasym.vardef.typ=formaldef) or
+            not implicitptrpara) then
+          begin
+            { add the extraction of the parameter and assign it back to the
+              original location }
+            tempn:=ctemprefnode.create(arraytemp);
+            tempn:=cvecnode.create(tempn,genintconstnode(0));
+            { unbox if necessary }
+            if parasym.vardef.typ=formaldef then
+              begin
+                if orgparadef.typ in [orddef,floatdef] then
+                  tempn:=cinlinenode.create(in_unbox_x_y,false,ccallparanode.create(
+                    ctypenode.create(orgparadef),ccallparanode.create(tempn,nil)))
+                else if implicitptrpara then
+                  tempn:=ctypeconvnode.create_explicit(tempn,getpointerdef(orgparadef))
+              end;
+            if implicitptrpara then
+              tempn:=cderefnode.create(tempn)
+            else
+              begin
+                { add check to determine whether the location passed as
+                  var-parameter hasn't been modified directly to a different
+                  value than the returned var-parameter in the mean time }
+                if ((parasym.varspez=vs_var) or
+                    verifyout) and
+                   (cs_check_var_copyout in current_settings.localswitches) then
+                  begin
+                    unwrappedele0:=cvecnode.create(ctemprefnode.create(arraytemp),genintconstnode(0));
+                    unwrappedele1:=cvecnode.create(ctemprefnode.create(arraytemp),genintconstnode(1));
+                    if (parasym.vardef.typ=formaldef) and
+                       (orgparadef.typ in [orddef,floatdef]) then
+                      begin
+                        unwrappedele0:=cinlinenode.create(in_unbox_x_y,false,ccallparanode.create(
+                          ctypenode.create(orgparadef),ccallparanode.create(unwrappedele0,nil)));
+                        unwrappedele1:=cinlinenode.create(in_unbox_x_y,false,ccallparanode.create(
+                          ctypenode.create(orgparadef),ccallparanode.create(unwrappedele1,nil)))
+                      end;
+                    addstatement(copybackstat,cifnode.create(
+                      caddnode.create(andn,
+                        caddnode.create(unequaln,leftcopy.getcopy,ctypeconvnode.create_explicit(unwrappedele0,orgparadef)),
+                        caddnode.create(unequaln,leftcopy.getcopy,ctypeconvnode.create_explicit(unwrappedele1,orgparadef))),
+                      ccallnode.createintern('fpc_var_copyout_mismatch',
+                        ccallparanode.create(genintconstnode(fileinfo.column),
+                          ccallparanode.create(genintconstnode(fileinfo.line),nil))
+                      ),nil
+                    ));
+                  end;
+              end;
+            addstatement(copybackstat,cassignmentnode.create(leftcopy,
+              ctypeconvnode.create_explicit(tempn,orgparadef)));
+          end
+        else
+          leftcopy.free;
+        addstatement(copybackstat,finiblock);
+        firstpass(fparainit);
+        firstpass(left);
+        firstpass(fparacopyback);
+      end;
+
+
+{*****************************************************************************
+                             TJVMCALLNODE
+*****************************************************************************}
+
+    procedure tjvmcallnode.wrapcomplexinlinepara(para: tcallparanode);
+      var
+        tempnode: ttempcreatenode;
+      begin
+        { don't use caddrnodes for the JVM target, because we can't take the
+          address of every kind of type (e.g., of ansistrings). A temp-reference
+          node does work for any kind of memory reference (and the expectloc
+          is LOC_(C)REFERENCE when this routine is called), but is not (yet)
+          supported for other targets }
+        tempnode:=ctempcreatenode.create_reference(para.parasym.vardef,para.parasym.vardef.size,
+          tt_persistent,tparavarsym(para.parasym).is_regvar(false),para.left,false);
+        addstatement(inlineinitstatement,tempnode);
+        addstatement(inlinecleanupstatement,ctempdeletenode.create(tempnode));
+        para.left:=ctemprefnode.create(tempnode);
+        { inherit addr_taken flag }
+        if (tabstractvarsym(para.parasym).addr_taken) then
+          include(tempnode.tempinfo^.flags,ti_addr_taken);
+      end;
+
+
+    procedure tjvmcallnode.extra_pre_call_code;
+      begin
+        { when calling a constructor, first create a new instance, except
+          when calling it from another constructor (because then this has
+          already been done before calling the current constructor) }
+        if procdefinition.typ<>procdef then
+          exit;
+        if tabstractprocdef(procdefinition).proctypeoption<>potype_constructor then
+          exit;
+        if not(methodpointer.resultdef.typ in [classrefdef,recorddef]) then
+          exit;
+        current_asmdata.CurrAsmList.concat(taicpu.op_sym(a_new,current_asmdata.RefAsmSymbol(tabstractrecorddef(tabstractprocdef(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 }
+        current_asmdata.CurrAsmList.concat(taicpu.op_none(a_dup));
+        thlcgjvm(hlcg).incstack(current_asmdata.CurrAsmList,2);
+      end;
+
+
+    procedure tjvmcallnode.set_result_location(realresdef: tstoreddef);
+      begin
+        location_reset_ref(location,LOC_REFERENCE,def_cgsize(realresdef),1);
+        { in case of jvmimplicitpointertype(), the function will have allocated
+          it already and we don't have to allocate it again here }
+        if not jvmimplicitpointertype(realresdef) then
+          tg.gethltemp(current_asmdata.CurrAsmList,realresdef,realresdef.size,tt_normal,location.reference)
+        else
+          tg.gethltemp(current_asmdata.CurrAsmList,java_jlobject,java_jlobject.size,tt_normal,location.reference);
+      end;
+
+
+    procedure tjvmcallnode.do_release_unused_return_value;
+      begin
+        if (tabstractprocdef(procdefinition).proctypeoption=potype_constructor) and
+           (current_procinfo.procdef.proctypeoption=potype_constructor) then
+          exit;
+        if is_void(resultdef) then
+          exit;
+        if (location.loc=LOC_REFERENCE) then
+          tg.ungetiftemp(current_asmdata.CurrAsmList,location.reference);
+        if assigned(funcretnode) then
+          exit;
+        if jvmimplicitpointertype(resultdef) or
+           (resultdef.size in [1..4]) then
+          begin
+            current_asmdata.CurrAsmList.concat(taicpu.op_none(a_pop));
+            thlcgjvm(hlcg).decstack(current_asmdata.CurrAsmList,1);
+          end
+        else if resultdef.size=8 then
+          begin
+            current_asmdata.CurrAsmList.concat(taicpu.op_none(a_pop2));
+            thlcgjvm(hlcg).decstack(current_asmdata.CurrAsmList,2);
+          end
+        else
+          internalerror(2011010305);
+      end;
+
+
+    procedure tjvmcallnode.extra_post_call_code;
+      var
+        totalremovesize: longint;
+        realresdef: tdef;
+      begin
+        if not assigned(typedef) then
+          realresdef:=tstoreddef(resultdef)
+        else
+          realresdef:=tstoreddef(typedef);
+        { a constructor doesn't actually return a value in the jvm }
+        if (tabstractprocdef(procdefinition).proctypeoption=potype_constructor) then
+          totalremovesize:=pushedparasize
+        else
+          begin
+            { zero-extend unsigned 8/16 bit returns (we have to return them
+              sign-extended to keep the Android verifier happy, and even if that
+              one did not exist a plain Java routine could return a
+              sign-extended value) }
+            if cnf_return_value_used in callnodeflags then
+              thlcgjvm(hlcg).maybe_resize_stack_para_val(current_asmdata.CurrAsmList,realresdef,false);
+            { even a byte takes up a full stackslot -> align size to multiple of 4 }
+            totalremovesize:=pushedparasize-(align(realresdef.size,4) shr 2);
+          end;
+        { remove parameters from internal evaluation stack counter (in case of
+          e.g. no parameters and a result, it can also increase) }
+        if totalremovesize>0 then
+          thlcgjvm(hlcg).decstack(current_asmdata.CurrAsmList,totalremovesize)
+        else if totalremovesize<0 then
+          thlcgjvm(hlcg).incstack(current_asmdata.CurrAsmList,-totalremovesize);
+
+        { if this was an inherited constructor call, initialise all fields that
+          are wrapped types following it }
+        if (tabstractprocdef(procdefinition).proctypeoption=potype_constructor) and
+           (cnf_inherited in callnodeflags) then
+          thlcgjvm(hlcg).gen_initialize_fields_code(current_asmdata.CurrAsmList);
+      end;
+
+
+  procedure tjvmcallnode.remove_hidden_paras;
+    var
+      prevpara, para, nextpara: tcallparanode;
+    begin
+      prevpara:=nil;
+      para:=tcallparanode(left);
+      while assigned(para) do
+        begin
+          nextpara:=tcallparanode(para.right);
+          if vo_is_hidden_para in para.parasym.varoptions then
+            begin
+              if assigned(prevpara) then
+                prevpara.right:=nextpara
+              else
+                left:=nextpara;
+              para.right:=nil;
+              para.free;
+            end
+          else
+            prevpara:=para;
+          para:=nextpara;
+        end;
+    end;
+
+
+  function tjvmcallnode.pass_typecheck: tnode;
+    begin
+      result:=inherited pass_typecheck;
+      if assigned(result) or
+         codegenerror then
+        exit;
+      { unfortunately, we cannot handle a call to a virtual constructor for
+        the current instance from inside another constructor. The reason is
+        that these must be called via reflection, but before an instance has
+        been fully initialized (which can only be done by calling either an
+        inherited constructor or another constructor of this class) you can't
+        perform reflection.
+
+        Replacing virtual constructors with plain virtual methods that are
+        called after the instance has been initialized causes problems if they
+        in turn call plain constructors from inside the JDK (you cannot call
+        constructors anymore once the instance has been constructed). It also
+        causes problems regarding which other constructor to call then instead
+        before to initialize the instance (we could add dummy constructors for
+        that purpose to Pascal classes, but that scheme breaks when a class
+        inherits from a JDK class other than JLObject).
+      }
+      if (current_procinfo.procdef.proctypeoption=potype_constructor) and
+         not(cnf_inherited in callnodeflags) and
+         (procdefinition.proctypeoption=potype_constructor) and
+         (po_virtualmethod in procdefinition.procoptions) and
+         (cnf_member_call in callnodeflags) then
+        CGMessage(parser_e_jvm_invalid_virtual_constructor_call);
+    end;
+
+
+  function tjvmcallnode.dispatch_procvar: tnode;
+    var
+      pdclass: tobjectdef;
+    begin
+      pdclass:=tprocvardef(right.resultdef).classdef;
+      { convert procvar type into corresponding class }
+      if not tprocvardef(right.resultdef).is_addressonly then
+        begin
+          right:=caddrnode.create_internal(right);
+          include(right.flags,nf_typedaddr);
+        end;
+      right:=ctypeconvnode.create_explicit(right,pdclass);
+      include(right.flags,nf_load_procvar);
+      typecheckpass(right);
+
+      { call the invoke method with these parameters. It will take care of the
+        wrapping and typeconversions; first filter out the automatically added
+        hidden parameters though }
+      remove_hidden_paras;
+      result:=ccallnode.createinternmethod(right,'INVOKE',left);
+      { reused }
+      left:=nil;
+      right:=nil;
+    end;
+
+
+  function tjvmcallnode.pass_1: tnode;
+    var
+      sym: tsym;
+      wrappername: shortstring;
+    begin
+      { transform procvar calls }
+      if assigned(right) then
+        result:=dispatch_procvar
+      else
+        begin
+          { replace virtual class method and constructor calls in case they may
+            be indirect; make sure we don't replace the callthrough to the
+            original constructor with another call to the wrapper }
+          if (procdefinition.typ=procdef) and
+             not(current_procinfo.procdef.synthetickind in [tsk_callthrough,tsk_callthrough_nonabstract]) and
+             not(cnf_inherited in callnodeflags) and
+             ((procdefinition.proctypeoption=potype_constructor) or
+              (po_classmethod in procdefinition.procoptions)) and
+             (po_virtualmethod in procdefinition.procoptions) and
+             (methodpointer.nodetype<>loadvmtaddrn) then
+            begin
+              wrappername:=symtableprocentry.name+'__FPCVIRTUALCLASSMETHOD__';
+              sym:=
+                search_struct_member(tobjectdef(procdefinition.owner.defowner),
+                  wrappername);
+              if not assigned(sym) or
+                 (sym.typ<>procsym) then
+                internalerror(2011072801);
+                { do not simply replace the procsym/procdef in case we could
+                  in theory do that, because the parameter nodes have already
+                  been bound to the current procdef's parasyms }
+                remove_hidden_paras;
+                result:=ccallnode.create(left,tprocsym(sym),symtableproc,methodpointer,callnodeflags);
+                result.flags:=flags;
+                left:=nil;
+                methodpointer:=nil;
+                exit;
+            end;
+          result:=inherited pass_1;
+          if assigned(result) then
+            exit;
+        end;
+    end;
+
+
+begin
+  ccallnode:=tjvmcallnode;
+  ccallparanode:=tjvmcallparanode;
+end.

compiler/jvm/njvmcnv.pas

@@ -0,0 +1,1613 @@
+{
+    Copyright (c) 1998-2011 by Florian Klaempfl and Jonas Maebe
+
+    Generate JVM code for type converting nodes
+
+    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 njvmcnv;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+      node,ncnv,ncgcnv,
+      symtype;
+
+    type
+       tjvmtypeconvnode = class(tcgtypeconvnode)
+          function typecheck_dynarray_to_openarray: tnode; override;
+          function typecheck_string_to_chararray: tnode; override;
+          function typecheck_string_to_string: tnode;override;
+          function typecheck_char_to_string: tnode; override;
+          function typecheck_proc_to_procvar: tnode; override;
+          function pass_1: tnode; override;
+          function simplify(forinline: boolean): tnode; override;
+          function first_set_to_set : tnode;override;
+          function first_nil_to_methodprocvar: tnode; override;
+          function first_proc_to_procvar: tnode; override;
+          function first_ansistring_to_pchar: tnode; override;
+
+          procedure second_int_to_int;override;
+          procedure second_cstring_to_pchar;override;
+         { procedure second_string_to_chararray;override; }
+         { procedure second_array_to_pointer;override; }
+          function first_int_to_real: tnode; override;
+          procedure second_pointer_to_array;override;
+         { procedure second_chararray_to_string;override; }
+         { procedure second_char_to_string;override; }
+          procedure second_int_to_real;override;
+         { procedure second_real_to_real;override; }
+         { procedure second_cord_to_pointer;override; }
+          procedure second_proc_to_procvar;override;
+          procedure second_bool_to_int;override;
+          procedure second_int_to_bool;override;
+         { procedure second_load_smallset;override;  }
+         { procedure second_ansistring_to_pchar;override; }
+         { procedure second_pchar_to_string;override; }
+         { procedure second_class_to_intf;override; }
+         { procedure second_char_to_char;override; }
+          procedure second_elem_to_openarray; override;
+          function target_specific_explicit_typeconv: boolean; override;
+          function target_specific_general_typeconv: boolean; override;
+         protected
+          function do_target_specific_explicit_typeconv(check_only: boolean; out resnode: tnode): boolean;
+       end;
+
+       tjvmasnode = class(tcgasnode)
+        protected
+         { to discern beween "obj as tclassref" and "tclassref(obj)" }
+         classreftypecast: boolean;
+         function target_specific_typecheck: boolean;override;
+        public
+         function pass_1 : tnode;override;
+         procedure pass_generate_code; override;
+         function dogetcopy: tnode; override;
+         function docompare(p: tnode): boolean; override;
+         constructor ppuload(t: tnodetype; ppufile: tcompilerppufile); override;
+         procedure ppuwrite(ppufile: tcompilerppufile); override;
+       end;
+
+       tjvmisnode = class(tisnode)
+        protected
+         function target_specific_typecheck: boolean;override;
+        public
+         function pass_1 : tnode;override;
+         procedure pass_generate_code; override;
+       end;
+
+implementation
+
+   uses
+      verbose,globals,globtype,constexp,cutils,
+      symbase,symconst,symdef,symsym,symtable,aasmbase,aasmdata,
+      defutil,defcmp,jvmdef,
+      cgbase,cgutils,pass_1,pass_2,
+      nbas,ncon,ncal,ninl,nld,nmem,procinfo,
+      nutils,paramgr,
+      cpubase,cpuinfo,aasmcpu,
+      tgobj,hlcgobj,hlcgcpu;
+
+
+{*****************************************************************************
+                            TypeCheckTypeConv
+*****************************************************************************}
+
+    function isvalidprocvartypeconv(fromdef, todef: tdef): boolean;
+
+      var
+        tmethoddef: tdef;
+
+      function docheck(def1,def2: tdef): boolean;
+        begin
+          result:=false;
+          if def1.typ<>procvardef then
+            exit;
+          { is_addressonly procvars are treated like regular pointer-sized data,
+            po_methodpointer procvars like implicit pointers to a struct }
+          if tprocvardef(def1).is_addressonly then
+            result:=
+              ((def2.typ=procvardef) and
+               tprocvardef(def2).is_addressonly) or
+              (def2=java_jlobject) or
+              (def2=voidpointertype)
+          else if po_methodpointer in tprocvardef(def1).procoptions then
+            begin
+              if not assigned(tmethoddef) then
+                tmethoddef:=search_system_type('TMETHOD').typedef;
+              result:=
+                (def2=methodpointertype) or
+                (def2=tmethoddef) or
+                ((def2.typ=procvardef) and
+                 (po_methodpointer in tprocvardef(def2).procoptions));
+            end;
+          { can't typecast nested procvars, they need 3 data pointers }
+        end;
+
+      begin
+        tmethoddef:=nil;
+        result:=
+          docheck(fromdef,todef) or
+          docheck(todef,fromdef);
+      end;
+
+
+   function tjvmtypeconvnode.typecheck_dynarray_to_openarray: tnode;
+     begin
+       { all arrays are equal in Java }
+       result:=nil;
+       convtype:=tc_equal;
+     end;
+
+
+   function tjvmtypeconvnode.typecheck_string_to_chararray: tnode;
+     var
+       newblock: tblocknode;
+       newstat: tstatementnode;
+       restemp: ttempcreatenode;
+       chartype: string;
+     begin
+       if (left.nodetype = stringconstn) and
+          (tstringconstnode(left).cst_type=cst_conststring) then
+         inserttypeconv(left,cunicodestringtype);
+       { even constant strings have to be handled via a helper }
+       if is_widechar(tarraydef(resultdef).elementdef) then
+         chartype:='widechar'
+       else
+         chartype:='char';
+       newblock:=internalstatements(newstat);
+       restemp:=ctempcreatenode.create(resultdef,resultdef.size,tt_persistent,false);
+       addstatement(newstat,restemp);
+       addstatement(newstat,ccallnode.createintern('fpc_'+tstringdef(left.resultdef).stringtypname+
+         '_to_'+chartype+'array',ccallparanode.create(left,ccallparanode.create(
+         ctemprefnode.create(restemp),nil))));
+       addstatement(newstat,ctempdeletenode.create_normal_temp(restemp));
+       addstatement(newstat,ctemprefnode.create(restemp));
+       result:=newblock;
+       left:=nil;
+     end;
+
+
+   function tjvmtypeconvnode.typecheck_string_to_string: tnode;
+     begin
+       { make sure the generic code gets a stringdef }
+       if (maybe_find_real_class_definition(resultdef,false)=java_jlstring) or
+          (maybe_find_real_class_definition(left.resultdef,false)=java_jlstring) then
+         begin
+           left:=ctypeconvnode.create(left,cunicodestringtype);
+           left.flags:=flags;
+           result:=ctypeconvnode.create(left,resultdef);
+           result.flags:=flags;
+           left:=nil;
+         end
+       else
+         result:=inherited;
+     end;
+
+
+   function tjvmtypeconvnode.typecheck_char_to_string: tnode;
+    begin
+      { make sure the generic code gets a stringdef }
+      if self.totypedef=java_jlstring then
+        begin
+          inserttypeconv(left,cunicodestringtype);
+          inserttypeconv(left,totypedef);
+          result:=left;
+          left:=nil;
+          exit;
+        end;
+      result:=inherited;
+    end;
+
+
+   function tjvmtypeconvnode.typecheck_proc_to_procvar: tnode;
+    begin
+      result:=inherited typecheck_proc_to_procvar;
+      if not assigned(totypedef) or
+         (totypedef.typ<>procvardef) then
+        begin
+          if assigned(tprocvardef(resultdef).classdef) then
+            internalerror(2011072405);
+          { associate generic classdef; this is the result of an @proc
+            expression, and such expressions can never result in a direct call
+            -> no invoke() method required (which only exists in custom
+            constructed descendents created for defined procvar types) }
+          if is_nested_pd(tabstractprocdef(resultdef)) then
+            { todo }
+            internalerror(2011072406)
+          else
+            tprocvardef(resultdef).classdef:=java_procvarbase;
+        end;
+    end;
+
+
+{*****************************************************************************
+                             FirstTypeConv
+*****************************************************************************}
+
+    function tjvmtypeconvnode.first_int_to_real: tnode;
+      begin
+        if not is_64bitint(left.resultdef) and
+           not is_currency(left.resultdef) then
+          if is_signed(left.resultdef) or
+             (left.resultdef.size<4) then
+            inserttypeconv(left,s32inttype)
+          else
+            inserttypeconv(left,u32inttype);
+        firstpass(left);
+        result := nil;
+        expectloc:=LOC_FPUREGISTER;
+      end;
+
+
+    function tjvmtypeconvnode.pass_1: tnode;
+      begin
+        if (nf_explicit in flags) then
+          begin
+            do_target_specific_explicit_typeconv(false,result);
+            if assigned(result) then
+              exit;
+          end;
+        result:=inherited pass_1;
+      end;
+
+    function tjvmtypeconvnode.simplify(forinline: boolean): tnode;
+      begin
+        result:=inherited simplify(forinline);
+        if assigned(result) then
+          exit;
+        { string constants passed to java.lang.String must be converted to
+          widestring }
+        if ((is_conststringnode(left) and
+             not(tstringconstnode(left).cst_type in [cst_unicodestring,cst_widestring])) or
+            is_constcharnode(left)) and
+           (maybe_find_real_class_definition(resultdef,false)=java_jlstring) then
+          inserttypeconv(left,cunicodestringtype);
+      end;
+
+
+    function tjvmtypeconvnode.first_set_to_set: tnode;
+      var
+        setclassdef: tdef;
+        helpername: string;
+      begin
+        result:=nil;
+        if (left.nodetype=setconstn) then
+          result:=inherited
+        { on native targets, only the binary layout has to match. Here, both
+          sets also have to be either of enums or ordinals, and in case of
+          enums they have to be of the same base type }
+        else if (tsetdef(left.resultdef).elementdef.typ=enumdef)=(tsetdef(resultdef).elementdef.typ=enumdef) and
+            ((tsetdef(left.resultdef).elementdef.typ<>enumdef) or
+             (tenumdef(tsetdef(left.resultdef).elementdef).getbasedef=tenumdef(tsetdef(resultdef).elementdef).getbasedef)) and
+            (tsetdef(left.resultdef).setbase=tsetdef(resultdef).setbase) and
+            (left.resultdef.size=resultdef.size) then
+          begin
+            result:=left;
+            left:=nil;
+          end
+        else
+          begin
+            { 'deep' conversion }
+            if tsetdef(resultdef).elementdef.typ<>enumdef then
+              begin
+                if tsetdef(left.resultdef).elementdef.typ<>enumdef then
+                  helpername:='fpc_bitset_to_bitset'
+                else
+                  helpername:='fpc_enumset_to_bitset';
+                result:=ccallnode.createintern(helpername,ccallparanode.create(
+                  genintconstnode(tsetdef(resultdef).setbase), ccallparanode.create(
+                    genintconstnode(tsetdef(left.resultdef).setbase),
+                      ccallparanode.create(left,nil))));
+              end
+            else
+              begin
+                if tsetdef(left.resultdef).elementdef.typ<>enumdef then
+                  begin
+                    helpername:='fpcBitSetToEnumSet';
+                    setclassdef:=java_jubitset;
+                  end
+                else
+                  begin
+                    helpername:='fpcEnumSetToEnumSet';
+                    setclassdef:=java_juenumset;
+                  end;
+                left:=caddrnode.create_internal(left);
+                include(left.flags,nf_typedaddr);
+                inserttypeconv_explicit(left,setclassdef);
+                result:=ccallnode.createinternmethod(
+                  cloadvmtaddrnode.create(ctypenode.create(setclassdef)),
+                  helpername,ccallparanode.create(
+                    genintconstnode(tsetdef(resultdef).setbase), ccallparanode.create(
+                      genintconstnode(tsetdef(left.resultdef).setbase),
+                        ccallparanode.create(left,nil))));
+              end;
+            inserttypeconv_explicit(result,getpointerdef(resultdef));
+            result:=cderefnode.create(result);
+            { reused }
+            left:=nil;
+          end;
+
+      end;
+
+
+    function tjvmtypeconvnode.first_nil_to_methodprocvar: tnode;
+      begin
+        result:=inherited first_nil_to_methodprocvar;
+        if assigned(result) then
+          exit;
+        if not assigned(tprocvardef(resultdef).classdef) then
+          tprocvardef(resultdef).classdef:=java_procvarbase;
+        result:=ccallnode.createinternmethod(
+          cloadvmtaddrnode.create(ctypenode.create(tprocvardef(resultdef).classdef)),'CREATE',nil);
+        { method pointer is an implicit pointer type }
+        result:=ctypeconvnode.create_explicit(result,getpointerdef(resultdef));
+        result:=cderefnode.create(result);
+      end;
+
+
+    function tjvmtypeconvnode.first_proc_to_procvar: tnode;
+      var
+        constrparas: tcallparanode;
+        newpara: tnode;
+        procdefparas: tarrayconstructornode;
+        pvs: tparavarsym;
+        fvs: tsym;
+        i: longint;
+        corrclass: tdef;
+        jlclass: tobjectdef;
+        encodedtype: tsymstr;
+        procload: tnode;
+        procdef: tprocdef;
+        st: tsymtable;
+        pushaddr: boolean;
+      begin
+        result:=inherited first_proc_to_procvar;
+        if assigned(result) then
+          exit;
+        procdef:=tloadnode(left).procdef;
+        procload:=tloadnode(left).left;
+        if not assigned(procload) then
+          begin
+            { nested or regular routine -> figure out whether unit-level or
+              nested, and if nested whether it's nested in a method or in a
+              regular routine }
+            st:=procdef.owner;
+            while st.symtabletype=localsymtable do
+              st:=st.defowner.owner;
+            if st.symtabletype in [objectsymtable,recordsymtable] then
+              { nested routine in method -> part of encloding class }
+              procload:=cloadvmtaddrnode.create(ctypenode.create(tdef(st.defowner)))
+            else
+              begin
+                { regular procedure/function -> get type representing unit
+                  class }
+                while not(st.symtabletype in [staticsymtable,globalsymtable]) do
+                  st:=st.defowner.owner;
+                corrclass:=search_named_unit_globaltype(st.realname^,'__FPC_JVM_MODULE_CLASS_ALIAS$',true).typedef;
+                procload:=cloadvmtaddrnode.create(ctypenode.create(tdef(corrclass)));
+              end;
+          end;
+        { todo: support nested procvars }
+        if is_nested_pd(procdef) then
+          internalerror(2011072607);
+        { constructor FpcBaseProcVarType.create(inst: jlobject; const method: unicodestring; const argTypes: array of JLClass); }
+        constrparas:=ccallparanode.create(ctypeconvnode.create_explicit(procload,java_jlobject),nil);
+        if not assigned(procdef.import_name) then
+          constrparas:=ccallparanode.create(cstringconstnode.createstr(procdef.procsym.realname),constrparas)
+        else
+          constrparas:=ccallparanode.create(cstringconstnode.createstr(procdef.import_name^),constrparas);
+        procdefparas:=nil;
+        jlclass:=tobjectdef(search_system_type('JLCLASS').typedef);
+        { in reverse to make it easier to build the arrayconstructorn }
+        for i:=procdef.paras.count-1 downto 0 do
+          begin
+            pvs:=tparavarsym(procdef.paras[i]);
+            { self is is an implicit parameter for normal methods }
+            if (vo_is_self in pvs.varoptions) and
+               not(po_classmethod in procdef.procoptions) then
+              continue;
+            { in case of an arraydef, pass by jlclass.forName() to get the classdef
+              (could be optimized by adding support to loadvmtaddrnode to also deal
+               with arrays, although we'd have to create specific arraydefs for var/
+               out/constref parameters }
+             pushaddr:=paramanager.push_copyout_param(pvs.varspez,pvs.vardef,procdef.proccalloption);
+             if pushaddr or
+                (pvs.vardef.typ=arraydef) then
+               begin
+                 encodedtype:=jvmencodetype(pvs.vardef,false);
+                 if pushaddr then
+                   encodedtype:='['+encodedtype;
+                 replace(encodedtype,'/','.');
+                 newpara:=ccallnode.createinternmethod(cloadvmtaddrnode.create(ctypenode.create(jlclass)),'FORNAME',
+                   ccallparanode.create(cstringconstnode.createstr(encodedtype),nil));
+               end
+             else
+               begin
+                 corrclass:=jvmgetcorrespondingclassdef(pvs.vardef);
+                 if pvs.vardef.typ in [orddef,floatdef] then
+                   begin
+                     { get the class representing the primitive type }
+                     fvs:=search_struct_member(tobjectdef(corrclass),'FTYPE');
+                     newpara:=nil;
+                     if not handle_staticfield_access(fvs,false,newpara) then
+                       internalerror(2011072417);
+                   end
+                 else
+                   newpara:=cloadvmtaddrnode.create(ctypenode.create(corrclass));
+                 newpara:=ctypeconvnode.create_explicit(newpara,jlclass);
+               end;
+            procdefparas:=carrayconstructornode.create(newpara,procdefparas);
+          end;
+        if not assigned(procdefparas) then
+          procdefparas:=carrayconstructornode.create(nil,nil);
+        constrparas:=ccallparanode.create(procdefparas,constrparas);
+        result:=ccallnode.createinternmethod(cloadvmtaddrnode.create(ctypenode.create(tprocvardef(resultdef).classdef)),'CREATE',constrparas);
+        { typecast to the procvar type }
+        if tprocvardef(resultdef).is_addressonly then
+          result:=ctypeconvnode.create_explicit(result,resultdef)
+        else
+          begin
+            result:=ctypeconvnode.create_explicit(result,getpointerdef(resultdef));
+            result:=cderefnode.create(result)
+          end;
+        { reused }
+        tloadnode(left).left:=nil;
+      end;
+
+
+    function tjvmtypeconvnode.first_ansistring_to_pchar: tnode;
+      var
+        ps: tsym;
+      begin
+        { also called for unicodestring->pwidechar, not supported since we can't
+          directly access the characters in java.lang.String }
+        if not is_ansistring(left.resultdef) or
+           not is_pchar(resultdef) then
+          begin
+            CGMessage2(type_e_illegal_type_conversion,left.resultdef.typename,resultdef.typename);
+            result:=nil;
+            exit;
+          end;
+        ps:=search_struct_member(java_ansistring,'INTERNCHARS');
+        if not assigned(ps) or
+           (ps.typ<>procsym) then
+          internalerror(2011081401);
+        { AnsistringClass.internChars is a static class method that will either
+          return the internal fdata ansichar array of the string, or an array
+          with a single #0 }
+        result:=ccallnode.create(ccallparanode.create(left,nil),tprocsym(ps),
+          ps.owner,
+          cloadvmtaddrnode.create(ctypenode.create(java_ansistring)),[]);
+        include(result.flags,nf_isproperty);
+        result:=ctypeconvnode.create_explicit(result,resultdef);
+        { reused }
+        left:=nil;
+      end;
+
+
+{*****************************************************************************
+                             SecondTypeConv
+*****************************************************************************}
+
+    procedure tjvmtypeconvnode.second_int_to_int;
+      var
+        ressize,
+        leftsize : longint;
+      begin
+        { insert range check if not explicit conversion }
+        if not(nf_explicit in flags) then
+          hlcg.g_rangecheck(current_asmdata.CurrAsmList,left.location,left.resultdef,resultdef);
+
+        { is the result size smaller? when typecasting from void
+          we always reuse the current location, because there is
+          nothing that we can load in a register }
+        ressize:=resultdef.size;
+        leftsize :=left.resultdef.size;
+        if ((ressize<>leftsize) or
+            ((left.location.loc in [LOC_REFERENCE,LOC_CREFERENCE]) and
+             (left.location.reference.arrayreftype<>art_none) and
+             (is_widechar(left.resultdef)<>is_widechar(resultdef))) or
+            is_bitpacked_access(left)) and
+           not is_void(left.resultdef) then
+          begin
+            location_copy(location,left.location);
+            { reuse a loc_reference when the newsize is larger than
+              than the original and 4 bytes, because all <= 4 byte loads will
+              result in a stack slot that occupies 4 bytes.
+
+              Except
+                a) for arrays (they use different load instructions for
+                   differently sized data types) or symbols (idem)
+                b) when going from 4 to 8 bytes, because these are different
+                   data types
+            }
+            if (location.loc in [LOC_REFERENCE,LOC_CREFERENCE]) and
+               not assigned(location.reference.symbol) and
+               (location.reference.arrayreftype=art_none) and
+               (ressize>leftsize) and
+               (ressize=4) then
+              begin
+                location.size:=def_cgsize(resultdef);
+                { no adjustment of the offset even though Java is big endian,
+                  because the load instruction will remain the same }
+              end
+            else
+              hlcg.location_force_reg(current_asmdata.CurrAsmList,location,left.resultdef,resultdef,false);
+          end
+        else
+          begin
+            if ((ressize < sizeof(aint)) and
+                (def_cgsize(left.resultdef)<>def_cgsize(resultdef))) or
+               (is_widechar(left.resultdef)<>is_widechar(resultdef)) then
+              begin
+                location_reset(location,LOC_REGISTER,def_cgsize(resultdef));
+                location.register:=hlcg.getintregister(current_asmdata.CurrAsmList,resultdef);
+                hlcg.a_load_loc_reg(current_asmdata.CurrAsmList,left.resultdef,resultdef,left.location,location.register);
+              end
+            else
+              location_copy(location,left.location);
+          end;
+      end;
+
+
+    procedure tjvmtypeconvnode.second_cstring_to_pchar;
+      var
+        hr: treference;
+        vs: tstaticvarsym;
+      begin
+        { don't use is_chararray because it doesn't support special arrays }
+        if (left.resultdef.typ<>arraydef) or
+           (tarraydef(left.resultdef).elementdef.typ<>orddef) or
+           (torddef(tarraydef(left.resultdef).elementdef).ordtype<>uchar) then
+          internalerror(2011081304);
+        if (tstringconstnode(left).cst_type in [cst_widestring,cst_unicodestring,cst_ansistring]) and
+           (tstringconstnode(left).len=0) then
+          begin
+            if tstringconstnode(left).cst_type=cst_ansistring then
+              vs:=tstaticvarsym(systemunit.Find('EMPTYPANSICHAR'))
+            else
+              vs:=tstaticvarsym(systemunit.Find('EMPTYPWIDECHAR'));
+            reference_reset(hr,4);
+            hr.symbol:=current_asmdata.RefAsmSymbol(vs.mangledname);
+            location_reset(location,LOC_REGISTER,OS_ADDR);
+            location.register:=hlcg.getaddressregister(current_asmdata.CurrAsmList,resultdef);
+            hlcg.a_loadaddr_ref_reg(current_asmdata.CurrAsmList,vs.vardef,resultdef,hr,location.register);
+          end
+        else
+          location_copy(location,left.location);
+      end;
+
+
+    procedure tjvmtypeconvnode.second_pointer_to_array;
+      begin
+        { arrays are implicit pointers in Java -> same location }
+        location_copy(location,left.location);
+      end;
+
+
+    procedure tjvmtypeconvnode.second_int_to_real;
+      var
+        srcsize, ressize: longint;
+
+      procedure convertsignedstackloc;
+        begin
+          case srcsize of
+            4:
+              case ressize of
+                4:
+                  current_asmdata.CurrAsmList.concat(taicpu.op_none(a_i2f));
+                8:
+                  begin
+                    current_asmdata.CurrAsmList.concat(taicpu.op_none(a_i2d));
+                    thlcgjvm(hlcg).incstack(current_asmdata.CurrAsmList,1);
+                  end;
+                else
+                  internalerror(2011010601);
+              end;
+            8:
+              case ressize of
+                4:
+                  begin
+                    current_asmdata.CurrAsmList.concat(taicpu.op_none(a_l2f));
+                    thlcgjvm(hlcg).decstack(current_asmdata.CurrAsmList,1);
+                  end;
+                8:
+                  current_asmdata.CurrAsmList.concat(taicpu.op_none(a_l2d));
+                else
+                  internalerror(2011010602);
+              end;
+            else
+              internalerror(2011010603);
+          end;
+        end;
+
+      var
+        signeddef : tdef;
+        l1 : tasmlabel;
+
+      begin
+        srcsize:=left.resultdef.size;
+        ressize:=resultdef.size;
+
+        location_reset(location,LOC_FPUREGISTER,def_cgsize(resultdef));
+        location.register:=hlcg.getfpuregister(current_asmdata.CurrAsmList,resultdef);
+
+        { first always convert as if it's a signed number }
+        thlcgjvm(hlcg).a_load_loc_stack(current_asmdata.CurrAsmList,left.resultdef,left.location);
+        convertsignedstackloc;
+        if not is_signed(left.resultdef) then
+          begin
+            { if it was unsigned, add high(cardinal)+1/high(qword)+1 in case
+              the signed interpretation is < 0 }
+            current_asmdata.getjumplabel(l1);
+            if srcsize=4 then
+              signeddef:=s32inttype
+            else
+              signeddef:=s64inttype;
+            hlcg.a_cmp_const_loc_label(current_asmdata.CurrAsmList,signeddef,OC_GTE,0,left.location,l1);
+            if srcsize=4 then
+              thlcgjvm(hlcg).a_loadfpu_const_stack(current_asmdata.CurrAsmList,resultdef,4294967296.0)
+            else
+              thlcgjvm(hlcg).a_loadfpu_const_stack(current_asmdata.CurrAsmList,resultdef,18446744073709551616.0);
+            if ressize=4 then
+              current_asmdata.CurrAsmList.concat(taicpu.op_none(a_fadd))
+            else
+              current_asmdata.CurrAsmList.concat(taicpu.op_none(a_dadd));
+            hlcg.a_label(current_asmdata.CurrAsmList,l1);
+          end;
+        thlcgjvm(hlcg).a_load_stack_reg(current_asmdata.CurrAsmList,resultdef,location.register);
+      end;
+
+
+    procedure tjvmtypeconvnode.second_proc_to_procvar;
+      begin
+        internalerror(2011072506);
+      end;
+
+
+    procedure tjvmtypeconvnode.second_bool_to_int;
+      var
+         newsize: tcgsize;
+         oldTrueLabel,oldFalseLabel : tasmlabel;
+      begin
+         oldTrueLabel:=current_procinfo.CurrTrueLabel;
+         oldFalseLabel:=current_procinfo.CurrFalseLabel;
+         current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
+         current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
+         secondpass(left);
+         location_copy(location,left.location);
+         newsize:=def_cgsize(resultdef);
+         { byte(bytebool) or word(wordbool) or longint(longbool) must be }
+         { accepted for var parameters and assignments, and must not     }
+         { change the ordinal value or value location.                   }
+         { htypechk.valid_for_assign ensures that such locations with a  }
+         { size<sizeof(register) cannot be LOC_CREGISTER (they otherwise }
+         { could be in case of a plain assignment), and LOC_REGISTER can }
+         { never be an assignment target. The remaining LOC_REGISTER/    }
+         { LOC_CREGISTER locations do have to be sign/zero-extended.     }
+
+         {   -- Note: this does not work for Java and 2/4 byte sized
+                      values, because bytebool/wordbool are signed and
+                      are stored in 4 byte locations -> will result in
+                      "byte" with the value high(cardinal); see remark
+                      in second_int_to_int above regarding consequences }
+         if not(nf_explicit in flags) or
+            (location.loc in [LOC_FLAGS,LOC_JUMP]) or
+            ((newsize<>left.location.size) and
+             ((left.resultdef.size<>resultdef.size) or
+              not(left.resultdef.size in [4,8]))
+            ) then
+           hlcg.location_force_reg(current_asmdata.CurrAsmList,location,left.resultdef,resultdef,true)
+         else
+           { may differ in sign, e.g. bytebool -> byte   }
+           location.size:=newsize;
+         current_procinfo.CurrTrueLabel:=oldTrueLabel;
+         current_procinfo.CurrFalseLabel:=oldFalseLabel;
+      end;
+
+
+    procedure tjvmtypeconvnode.second_int_to_bool;
+      var
+        hlabel1,hlabel2,oldTrueLabel,oldFalseLabel : tasmlabel;
+        newsize  : tcgsize;
+      begin
+        oldTrueLabel:=current_procinfo.CurrTrueLabel;
+        oldFalseLabel:=current_procinfo.CurrFalseLabel;
+        current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
+        current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
+        secondpass(left);
+        if codegenerror then
+          exit;
+
+        { Explicit typecasts from any ordinal type to a boolean type }
+        { must not change the ordinal value                          }
+        { Exception: Android verifier... }
+        if (nf_explicit in flags) and
+           not(left.location.loc in [LOC_FLAGS,LOC_JUMP]) and
+           not(current_settings.cputype=cpu_dalvik) then
+          begin
+             location_copy(location,left.location);
+             newsize:=def_cgsize(resultdef);
+             { change of size? change sign only if location is LOC_(C)REGISTER? Then we have to sign/zero-extend }
+             if (tcgsize2size[newsize]<>tcgsize2size[left.location.size]) or
+                ((newsize<>left.location.size) and (location.loc in [LOC_REGISTER,LOC_CREGISTER])) then
+               hlcg.location_force_reg(current_asmdata.CurrAsmList,location,left.resultdef,resultdef,true)
+             else
+               location.size:=newsize;
+             current_procinfo.CurrTrueLabel:=oldTrueLabel;
+             current_procinfo.CurrFalseLabel:=oldFalseLabel;
+             exit;
+          end;
+
+       location_reset(location,LOC_REGISTER,def_cgsize(resultdef));
+       location.register:=hlcg.getintregister(current_asmdata.CurrAsmList,resultdef);
+       current_asmdata.getjumplabel(hlabel2);
+       case left.location.loc of
+         LOC_CREFERENCE,LOC_REFERENCE,LOC_REGISTER,LOC_CREGISTER:
+           begin
+             current_asmdata.getjumplabel(hlabel1);
+             hlcg.a_cmp_const_loc_label(current_asmdata.CurrAsmList,left.resultdef,OC_EQ,0,left.location,hlabel1);
+           end;
+         LOC_JUMP :
+           begin
+             hlabel1:=current_procinfo.CurrFalseLabel;
+             hlcg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
+           end;
+         else
+           internalerror(10062);
+       end;
+
+       if not(is_cbool(resultdef)) then
+         thlcgjvm(hlcg).a_load_const_stack(current_asmdata.CurrAsmList,resultdef,1,R_INTREGISTER)
+       else
+         thlcgjvm(hlcg).a_load_const_stack(current_asmdata.CurrAsmList,resultdef,-1,R_INTREGISTER);
+       { we jump over the next constant load -> they don't appear on the
+         stack simulataneously }
+       thlcgjvm(hlcg).decstack(current_asmdata.CurrAsmList,1);
+       hlcg.a_jmp_always(current_asmdata.CurrAsmList,hlabel2);
+       hlcg.a_label(current_asmdata.CurrAsmList,hlabel1);
+       thlcgjvm(hlcg).a_load_const_stack(current_asmdata.CurrAsmList,resultdef,0,R_INTREGISTER);
+       hlcg.a_label(current_asmdata.CurrAsmList,hlabel2);
+       thlcgjvm(hlcg).a_load_stack_reg(current_asmdata.CurrAsmList,resultdef,location.register);
+
+       current_procinfo.CurrTrueLabel:=oldTrueLabel;
+       current_procinfo.CurrFalseLabel:=oldFalseLabel;
+     end;
+
+
+    procedure tjvmtypeconvnode.second_elem_to_openarray;
+      var
+        primitivetype: boolean;
+        opc: tasmop;
+        mangledname: string;
+        basereg: tregister;
+        arrayref: treference;
+      begin
+        { create an array with one element of the required type }
+        thlcgjvm(hlcg).a_load_const_stack(current_asmdata.CurrAsmList,s32inttype,1,R_INTREGISTER);
+        mangledname:=jvmarrtype(left.resultdef,primitivetype);
+        if primitivetype then
+          opc:=a_newarray
+        else
+          opc:=a_anewarray;
+        { doesn't change stack height: one int replaced by one reference }
+        current_asmdata.CurrAsmList.concat(taicpu.op_sym(opc,current_asmdata.RefAsmSymbol(mangledname)));
+        { store the data in the newly created array }
+        basereg:=hlcg.getaddressregister(current_asmdata.CurrAsmList,java_jlobject);
+        thlcgjvm(hlcg).a_load_stack_reg(current_asmdata.CurrAsmList,java_jlobject,basereg);
+        reference_reset_base(arrayref,basereg,0,4);
+        arrayref.arrayreftype:=art_indexconst;
+        arrayref.indexoffset:=0;
+        hlcg.a_load_loc_ref(current_asmdata.CurrAsmList,left.resultdef,left.resultdef,left.location,arrayref);
+        location_reset_ref(location,LOC_REFERENCE,OS_ADDR,4);
+        tg.gethltemp(current_asmdata.CurrAsmList,java_jlobject,4,tt_normal,location.reference);
+        hlcg.a_load_reg_ref(current_asmdata.CurrAsmList,java_jlobject,java_jlobject,basereg,location.reference);
+      end;
+
+
+    procedure get_most_nested_types(var fromdef, todef: tdef);
+      begin
+       while is_dynamic_array(fromdef) and
+             is_dynamic_array(todef) do
+         begin
+           fromdef:=tarraydef(fromdef).elementdef;
+           todef:=tarraydef(todef).elementdef;
+         end;
+       fromdef:=maybe_find_real_class_definition(fromdef,false);
+       todef:=maybe_find_real_class_definition(todef,false);
+      end;
+
+
+    function tjvmtypeconvnode.do_target_specific_explicit_typeconv(check_only: boolean; out resnode: tnode): boolean;
+
+      { handle explicit typecast from int to to real or vice versa }
+      function int_real_explicit_typecast(fdef: tfloatdef; const singlemethod, doublemethod: string): tnode;
+        var
+          csym: ttypesym;
+          psym: tsym;
+        begin
+         { use the float/double to raw bits methods to get the bit pattern }
+          if fdef.floattype=s32real then
+            begin
+              csym:=search_system_type('JLFLOAT');
+              psym:=search_struct_member(tobjectdef(csym.typedef),singlemethod);
+            end
+          else
+            begin
+              csym:=search_system_type('JLDOUBLE');
+              psym:=search_struct_member(tobjectdef(csym.typedef),doublemethod);
+            end;
+          if not assigned(psym) or
+             (psym.typ<>procsym) then
+            internalerror(2011012901);
+          { call the (static class) method to get the raw bits }
+          result:=ccallnode.create(ccallparanode.create(left,nil),
+            tprocsym(psym),psym.owner,
+            cloadvmtaddrnode.create(ctypenode.create(csym.typedef)),[]);
+          { convert the result to the result type of this type conversion node }
+          inserttypeconv_explicit(result,resultdef);
+          { left is reused }
+          left:=nil;
+        end;
+
+      function ord_enum_explicit_typecast(fdef: torddef; todef: tenumdef): tnode;
+        var
+          psym: tsym;
+        begin
+          { we only create a class for the basedefs }
+          todef:=todef.getbasedef;
+          psym:=search_struct_member(todef.classdef,'FPCVALUEOF');
+          if not assigned(psym) or
+             (psym.typ<>procsym) then
+            internalerror(2011062601);
+          result:=ccallnode.create(ccallparanode.create(left,nil),
+            tprocsym(psym),psym.owner,
+            cloadvmtaddrnode.create(ctypenode.create(todef.classdef)),[]);
+          { convert the result to the result type of this type conversion node }
+          inserttypeconv_explicit(result,resultdef);
+          { left is reused }
+          left:=nil;
+        end;
+
+      function enum_ord_explicit_typecast(fdef: tenumdef; todef: torddef): tnode;
+        var
+          psym: tsym;
+        begin
+          { we only create a class for the basedef }
+          fdef:=fdef.getbasedef;
+          psym:=search_struct_member(fdef.classdef,'FPCORDINAL');
+          if not assigned(psym) or
+             (psym.typ<>procsym) then
+            internalerror(2011062602);
+          result:=ccallnode.create(nil,tprocsym(psym),psym.owner,left,[]);
+          { convert the result to the result type of this type conversion node }
+          inserttypeconv_explicit(result,resultdef);
+          { left is reused }
+          left:=nil;
+        end;
+
+      function from_set_explicit_typecast: tnode;
+        var
+          helpername: string;
+          setconvdef: tdef;
+        begin
+         if tsetdef(left.resultdef).elementdef.typ=enumdef then
+           begin
+             setconvdef:=java_juenumset;
+             helpername:='fpc_enumset_to_'
+           end
+         else
+           begin
+             setconvdef:=java_jubitset;
+             helpername:='fpc_bitset_to_'
+           end;
+         if left.resultdef.size<=4 then
+           helpername:=helpername+'int'
+         else
+           helpername:=helpername+'long';
+          result:=ccallnode.createintern(helpername,ccallparanode.create(
+            genintconstnode(left.resultdef.size),ccallparanode.create(genintconstnode(tsetdef(left.resultdef).setbase),
+            ccallparanode.create(ctypeconvnode.create_explicit(left,setconvdef),nil))));
+          left:=nil;
+        end;
+
+      function to_set_explicit_typecast: tnode;
+        var
+          enumclassdef: tobjectdef;
+          mp: tnode;
+          helpername: string;
+        begin
+          if tsetdef(resultdef).elementdef.typ=enumdef then
+            begin
+              inserttypeconv_explicit(left,s64inttype);
+              enumclassdef:=tenumdef(tsetdef(resultdef).elementdef).getbasedef.classdef;
+              mp:=cloadvmtaddrnode.create(ctypenode.create(enumclassdef));
+              helpername:='fpcLongToEnumSet';
+              { enumclass.fpcLongToEnumSet(left,setbase,setsize) }
+              result:=ccallnode.createinternmethod(mp,helpername,
+                ccallparanode.create(genintconstnode(resultdef.size),
+                  ccallparanode.create(genintconstnode(tsetdef(resultdef).setbase),
+                    ccallparanode.create(left,nil))));
+            end
+          else
+            begin
+              if left.resultdef.size<=4 then
+                begin
+                  helpername:='fpc_int_to_bitset';
+                  inserttypeconv_explicit(left,s32inttype);
+                end
+              else
+                begin
+                  helpername:='fpc_long_to_bitset';
+                  inserttypeconv_explicit(left,s64inttype);
+                end;
+              result:=ccallnode.createintern(helpername,
+                ccallparanode.create(genintconstnode(resultdef.size),
+                  ccallparanode.create(genintconstnode(tsetdef(resultdef).setbase),
+                    ccallparanode.create(left,nil))));
+            end;
+        end;
+
+      function procvar_to_procvar(fromdef, todef: tdef): tnode;
+        var
+          fsym: tsym;
+        begin
+          result:=nil;
+          if fromdef=todef then
+            exit;
+          fsym:=tfieldvarsym(search_struct_member(tprocvardef(fromdef).classdef,'METHOD'));
+          if not assigned(fsym) or
+             (fsym.typ<>fieldvarsym) then
+            internalerror(2011072414);
+          { can either be a procvar or a procvarclass }
+          if fromdef.typ=procvardef then
+            begin
+              left:=ctypeconvnode.create_explicit(left,tprocvardef(fromdef).classdef);
+              include(left.flags,nf_load_procvar);
+              typecheckpass(left);
+            end;
+          result:=csubscriptnode.create(fsym,left);
+          { create destination procvartype with info from source }
+          result:=ccallnode.createinternmethod(
+            cloadvmtaddrnode.create(ctypenode.create(tprocvardef(todef).classdef)),
+            'CREATE',ccallparanode.create(result,nil));
+          left:=nil;
+        end;
+
+      function procvar_to_tmethod(fromdef, todef: tdef): tnode;
+        var
+          fsym: tsym;
+        begin
+          { must be procedure-of-object -> implicit pointer type -> get address
+            before typecasting to corresponding classdef }
+          left:=caddrnode.create_internal(left);
+          inserttypeconv_explicit(left,tprocvardef(fromdef).classdef);
+          fsym:=tfieldvarsym(search_struct_member(tprocvardef(fromdef).classdef,'METHOD'));
+          if not assigned(fsym) or
+             (fsym.typ<>fieldvarsym) then
+            internalerror(2011072414);
+          result:=csubscriptnode.create(fsym,left);
+          left:=nil;
+        end;
+
+      function tmethod_to_procvar(fromdef, todef: tdef): tnode;
+        var
+          fsym: tsym;
+        begin
+          fsym:=tfieldvarsym(search_struct_member(tprocvardef(todef).classdef,'METHOD'));
+          if not assigned(fsym) or
+             (fsym.typ<>fieldvarsym) then
+            internalerror(2011072415);
+          result:=ccallnode.createinternmethod(cloadvmtaddrnode.create(ctypenode.create(tprocvardef(todef).classdef)),
+            'CREATE',ccallparanode.create(left,nil));
+          left:=nil;
+        end;
+
+      function ptr_no_typecheck_required(fromdef, todef: tdef): boolean;
+
+        function check_type_equality(def1,def2: tdef): boolean;
+          begin
+            result:=true;
+            if is_ansistring(def1) and
+               (def2=java_ansistring) then
+              exit;
+            if is_wide_or_unicode_string(def1) and
+               (def2=java_jlstring) then
+              exit;
+            if def1.typ=pointerdef then
+              begin
+                if is_shortstring(tpointerdef(def1).pointeddef) and
+                   (def2=java_shortstring) then
+                  exit;
+                { pointer-to-set to JUEnumSet/JUBitSet }
+                if (tpointerdef(def1).pointeddef.typ=setdef) then
+                  begin
+                    if not assigned(tsetdef(tpointerdef(def1).pointeddef).elementdef) then
+                      begin
+                        if (def2=java_jubitset) or
+                           (def2=java_juenumset) then
+                          exit;
+                      end
+                    else if tsetdef(tpointerdef(def1).pointeddef).elementdef.typ=enumdef then
+                      begin
+                        if def2=java_juenumset then
+                          exit;
+                      end
+                    else if def2=java_jubitset then
+                      exit;
+                  end;
+              end;
+            result:=false;
+          end;
+
+        function check_array_type_equality(def1,def2: tdef): boolean;
+          begin
+            result:=true;
+            if is_shortstring(def1) and
+               (def2=java_shortstring) then
+              exit;
+            result:=false;
+          end;
+
+        begin
+          result:=true;
+          { check procvar conversion compatibility via their classes }
+          if fromdef.typ=procvardef then
+            fromdef:=tprocvardef(fromdef).classdef;
+          if todef.typ=procvardef then
+            todef:=tprocvardef(todef).classdef;
+          if (todef=java_jlobject) or
+             (todef=voidpointertype) then
+            exit;
+          if compare_defs(fromdef,todef,nothingn)>=te_equal then
+            exit;
+          { trecorddef.is_related() must work for inheritance/method checking,
+            but do not allow records to be directly typecasted into class/
+            pointer types (you have to use FpcBaseRecordType(@rec) instead) }
+          if not is_record(fromdef) and
+             fromdef.is_related(todef) then
+            exit;
+          if check_type_equality(fromdef,todef) then
+            exit;
+          if check_type_equality(todef,fromdef) then
+            exit;
+          if (fromdef.typ=pointerdef) and
+             (tpointerdef(fromdef).pointeddef.typ=recorddef) and
+             (todef=java_fpcbaserecordtype) then
+            exit;
+          { all classrefs are currently java.lang.Class at the bytecode level }
+          if (fromdef.typ=classrefdef) and
+             (todef.typ=objectdef) and
+             (todef=search_system_type('JLCLASS').typedef) then
+            exit;
+          if (fromdef.typ=classrefdef) and
+             (todef.typ=classrefdef) and
+             tclassrefdef(fromdef).pointeddef.is_related(tclassrefdef(todef).pointeddef) then
+            exit;
+          { special case: "array of shortstring" to "array of ShortstringClass"
+            and "array of <record>" to "array of FpcRecordBaseType" (normally
+            you have to use ShortstringClass(@shortstrvar) etc, but that's not
+            possible in case of passing arrays to e.g. setlength) }
+          if is_dynamic_array(left.resultdef) and
+             is_dynamic_array(resultdef) then
+            begin
+             if check_array_type_equality(fromdef,todef) or
+                check_array_type_equality(todef,fromdef) then
+               exit;
+             if is_record(fromdef) and
+                (todef=java_fpcbaserecordtype) then
+               exit;
+            end;
+          result:=false;
+        end;
+
+      var
+        fromclasscompatible,
+        toclasscompatible: boolean;
+        fromdef,
+        todef: tdef;
+        fromarrtype,
+        toarrtype: char;
+      begin
+        resnode:=nil;
+        if not(convtype in [tc_equal,tc_int_2_int,tc_int_2_bool,tc_bool_2_int,tc_class_2_intf]) or
+           ((convtype in [tc_equal,tc_int_2_int,tc_bool_2_int,tc_int_2_bool]) and
+            ((left.resultdef.typ=orddef) and
+             (resultdef.typ=orddef))) then
+          begin
+            result:=false;
+            exit
+          end;
+        { This routine is only called for explicit typeconversions of same-sized
+          entities that aren't handled by normal type conversions -> bit pattern
+          reinterpretations. In the JVM, many of these also need special
+          handling because of the type safety. }
+
+        { don't allow conversions between object-based and non-object-based
+          types }
+        fromclasscompatible:=
+          (left.resultdef.typ=formaldef) or
+          (left.resultdef.typ=pointerdef) or
+          is_java_class_or_interface(left.resultdef) or
+          is_dynamic_array(left.resultdef) or
+          ((left.resultdef.typ in [stringdef,classrefdef]) and
+           not is_shortstring(left.resultdef)) or
+          (left.resultdef.typ=enumdef) or
+          { procvar2procvar needs special handling }
+          ((left.resultdef.typ=procvardef) and
+           tprocvardef(left.resultdef).is_addressonly and
+           (resultdef.typ<>procvardef));
+        toclasscompatible:=
+          (resultdef.typ=pointerdef) or
+          is_java_class_or_interface(resultdef) or
+          is_dynamic_array(resultdef) or
+          ((resultdef.typ in [stringdef,classrefdef]) and
+           not is_shortstring(resultdef)) or
+          (resultdef.typ=enumdef) or
+          ((resultdef.typ=procvardef) and
+           tprocvardef(resultdef).is_addressonly);
+        { typescasts from void (the result of untyped_ptr^) to an implicit
+          pointertype (record, array, ...) also needs a typecheck }
+        if is_void(left.resultdef) and
+           jvmimplicitpointertype(resultdef) then
+          begin
+            fromclasscompatible:=true;
+            toclasscompatible:=true;
+          end;
+
+        if fromclasscompatible and toclasscompatible then
+          begin
+            { we need an as-node to check the validity of the conversion (since
+              it wasn't handled by another type conversion, we know it can't
+              have been valid normally)
+
+              Exceptions: (most nested) destination is
+                * java.lang.Object, since everything is compatible with that type
+                * related to source
+                * a primitive that are represented by the same type in Java
+                  (e.g., byte and shortint) }
+
+            { in case of arrays, check the compatibility of the innermost types }
+            fromdef:=left.resultdef;
+            todef:=resultdef;
+            get_most_nested_types(fromdef,todef);
+            { in case of enums, get the equivalent class definitions }
+            if (fromdef.typ=enumdef) then
+              fromdef:=tenumdef(fromdef).getbasedef;
+            if (todef.typ=enumdef) then
+              todef:=tenumdef(todef).getbasedef;
+            fromarrtype:=jvmarrtype_setlength(fromdef);
+            toarrtype:=jvmarrtype_setlength(todef);
+            if not ptr_no_typecheck_required(fromdef,todef) then
+              begin
+                if (fromarrtype in ['A','R','T','E','L','P']) or
+                   (fromarrtype<>toarrtype) then
+                  begin
+                    if not check_only and
+                       not assignment_side then
+                      begin
+                        resnode:=ctypenode.create(resultdef);
+                        if resultdef.typ=objectdef then
+                          resnode:=cloadvmtaddrnode.create(resnode);
+                        resnode:=casnode.create_internal(left,resnode);
+                        if resultdef.typ=classrefdef then
+                          tjvmasnode(resnode).classreftypecast:=true;
+                        left:=nil;
+                      end
+                  end
+                { typecasting from a child to a parent type on the assignment side
+                  will (rightly) mess up the type safety verification of the JVM }
+                else if assignment_side then
+                  CGMessage(type_e_no_managed_assign_generic_typecast);
+              end;
+            result:=true;
+            exit;
+          end;
+
+        { a formaldef can be converted to anything, but not on the assignment
+          side }
+        if (left.resultdef.typ=formaldef) and
+           not assignment_side then
+          begin
+            if resultdef.typ in [orddef,floatdef] then
+              begin
+                if not check_only then
+                  begin
+                    resnode:=cinlinenode.create(in_unbox_x_y,false,
+                      ccallparanode.create(ctypenode.create(resultdef),
+                        ccallparanode.create(left,nil)));
+                    left:=nil;
+                  end;
+                result:=true;
+                exit;
+              end
+            else if jvmimplicitpointertype(resultdef) then
+              begin
+                { typecast formaldef to pointer to the type, then deref, so that
+                  a proper checkcast is inserted }
+                if not check_only then
+                  begin
+                    resnode:=ctypeconvnode.create_explicit(left,getpointerdef(resultdef));
+                    resnode:=cderefnode.create(resnode);
+                    left:=nil;
+                  end;
+                result:=true;
+                exit;
+              end;
+            result:=false;
+            exit;
+          end;
+
+        { procvar to tmethod and vice versa, and procvar to procvar }
+        if isvalidprocvartypeconv(left.resultdef,resultdef) then
+          begin
+            if not check_only then
+              begin
+                if (left.resultdef.typ=procvardef) and
+                   (resultdef.typ=procvardef) then
+                  resnode:=procvar_to_procvar(left.resultdef,resultdef)
+                else if left.resultdef.typ=procvardef then
+                  resnode:=procvar_to_tmethod(left.resultdef,resultdef)
+                else
+                  resnode:=tmethod_to_procvar(left.resultdef,resultdef);
+              end;
+            result:=true;
+            exit;
+          end;
+
+        { don't allow conversions between different classes of primitive types,
+          except for a few special cases }
+
+        { float to int/enum explicit type conversion: get the bits }
+        if (left.resultdef.typ=floatdef) and
+           (is_integer(resultdef) or
+            (resultdef.typ=enumdef)) then
+          begin
+            if not check_only then
+              resnode:=int_real_explicit_typecast(tfloatdef(left.resultdef),'FLOATTORAWINTBITS','DOUBLETORAWLONGBITS');
+            result:=true;
+            exit;
+          end;
+        { int to float explicit type conversion: also use the bits }
+        if (is_integer(left.resultdef) or
+            (left.resultdef.typ=enumdef)) and
+           (resultdef.typ=floatdef) then
+          begin
+            if not check_only then
+              begin
+                if (left.resultdef.typ=enumdef) then
+                  inserttypeconv_explicit(left,s32inttype);
+                resnode:=int_real_explicit_typecast(tfloatdef(resultdef),'INTBITSTOFLOAT','LONGBITSTODOUBLE');
+              end;
+            result:=true;
+            exit;
+          end;
+
+        { enums }
+        if (left.resultdef.typ=enumdef) or
+           (resultdef.typ=enumdef) then
+          begin
+            { both enum? }
+           if (resultdef.typ=left.resultdef.typ) then
+             begin
+               { same base type -> nothing special }
+               fromdef:=tenumdef(left.resultdef).getbasedef;
+               todef:=tenumdef(resultdef).getbasedef;
+               if fromdef=todef then
+                 begin
+                   result:=false;
+                   exit;
+                 end;
+               { convert via ordinal intermediate }
+               if not check_only then
+                 begin;
+                   inserttypeconv_explicit(left,s32inttype);
+                   inserttypeconv_explicit(left,resultdef);
+                   resnode:=left;
+                   left:=nil
+                 end;
+               result:=true;
+               exit;
+             end;
+           { enum to orddef & vice versa }
+           if left.resultdef.typ=orddef then
+             begin
+               if not check_only then
+                 resnode:=ord_enum_explicit_typecast(torddef(left.resultdef),tenumdef(resultdef));
+               result:=true;
+               exit;
+             end
+           else if resultdef.typ=orddef then
+             begin
+               if not check_only then
+                 resnode:=enum_ord_explicit_typecast(tenumdef(left.resultdef),torddef(resultdef));
+               result:=true;
+               exit;
+             end
+          end;
+
+        { sets }
+        if (left.resultdef.typ=setdef) or
+           (resultdef.typ=setdef) then
+          begin
+            { set -> ord/enum/other-set-type }
+            if (resultdef.typ in [orddef,enumdef]) then
+              begin
+                if not check_only then
+                  begin
+                    resnode:=from_set_explicit_typecast;
+                    { convert to desired result }
+                    inserttypeconv_explicit(resnode,resultdef);
+                  end;
+                result:=true;
+                exit;
+              end
+            { ord/enum -> set }
+            else if (left.resultdef.typ in [orddef,enumdef]) then
+              begin
+                if not check_only then
+                  begin
+                    resnode:=to_set_explicit_typecast;
+                    { convert to desired result }
+                    inserttypeconv_explicit(resnode,getpointerdef(resultdef));
+                    resnode:=cderefnode.create(resnode);
+                  end;
+                result:=true;
+                exit;
+              end;
+            { if someone needs it, float->set and set->float explicit typecasts
+              could also be added (cannot be handled by the above, because
+              float(intvalue) will convert rather than re-interpret the value) }
+          end;
+
+        { anything not explicitly handled is a problem }
+        result:=true;
+        CGMessage2(type_e_illegal_type_conversion,left.resultdef.typename,resultdef.typename);
+      end;
+
+
+    function tjvmtypeconvnode.target_specific_explicit_typeconv: boolean;
+      var
+        dummyres: tnode;
+      begin
+        result:=do_target_specific_explicit_typeconv(true,dummyres);
+      end;
+
+
+
+    function tjvmtypeconvnode.target_specific_general_typeconv: boolean;
+      begin
+        result:=false;
+        { on the JVM platform, enums can always be converted to class instances,
+          because enums /are/ class instances there. To prevent the
+          typechecking/conversion code from assuming it can treat it like any
+          ordinal constant, firstpass() it so that the ordinal constant gets
+          replaced with a load of a staticvarsym. This is not done in
+          pass_typecheck, because that would prevent many optimizations }
+        if (left.nodetype=ordconstn) and
+           (left.resultdef.typ=enumdef) and
+           (resultdef.typ=objectdef) then
+          firstpass(left);
+      end;
+
+
+    {*****************************************************************************
+                         AsNode and IsNode common helpers
+    *****************************************************************************}
+
+  function asis_target_specific_typecheck(node: tasisnode): boolean;
+    var
+      realtodef: tdef;
+      temp: tnode;
+    begin
+      { the JVM supports loadvmtaddrnodes for interface types, but the generic
+        as/is code doesn't -> convert such loadvmtaddrnodes back to plain
+        type nodes here (they only make sense in the context of treating them
+        as entities loaded to store into e.g. a JLClass) }
+      if (node.right.resultdef.typ=classrefdef) and
+         is_javainterface(tclassrefdef(node.right.resultdef).pointeddef) and
+         (node.right.nodetype=loadvmtaddrn) and
+         (tloadvmtaddrnode(node.right).left.nodetype=typen) then
+        begin
+          temp:=tloadvmtaddrnode(node.right).left;
+          tloadvmtaddrnode(node.right).left:=nil;
+          node.right.free;
+          node.right:=temp;
+        end;
+
+      if not(nf_internal in node.flags) then
+        begin
+          { handle using normal code }
+          result:=false;
+          exit;
+        end;
+      result:=true;
+      { these are converted type conversion nodes, to insert the checkcast
+        operations }
+      realtodef:=node.right.resultdef;
+      if (realtodef.typ=classrefdef) and
+         ((node.nodetype<>asn) or
+          not tjvmasnode(node).classreftypecast) then
+        realtodef:=tclassrefdef(realtodef).pointeddef;
+      realtodef:=maybe_find_real_class_definition(realtodef,false);
+      if result then
+        if node.nodetype=asn then
+          node.resultdef:=realtodef
+        else
+          node.resultdef:=pasbool8type;
+    end;
+
+
+  function asis_pass_1(node: tasisnode; const methodname: string): tnode;
+    var
+      ps: tsym;
+      call: tnode;
+      jlclass: tobjectdef;
+    begin
+      result:=nil;
+      firstpass(node.left);
+      if not(node.right.nodetype in [typen,loadvmtaddrn]) then
+        begin
+          if (node.nodetype=isn) or
+             not assigned(tasnode(node).call) then
+            begin
+              if not is_javaclassref(node.right.resultdef) then
+                internalerror(2011041920);
+              firstpass(node.right);
+              jlclass:=tobjectdef(search_system_type('JLCLASS').typedef);
+              ps:=search_struct_member(jlclass,methodname);
+              if not assigned(ps) or
+                 (ps.typ<>procsym) then
+                internalerror(2011041910);
+              call:=ccallnode.create(ccallparanode.create(node.left,nil),tprocsym(ps),ps.owner,ctypeconvnode.create_explicit(node.right,jlclass),[]);
+              node.left:=nil;
+              node.right:=nil;
+              firstpass(call);
+              if codegenerror then
+                exit;
+              if node.nodetype=isn then
+                result:=call
+              else
+                begin
+                  tasnode(node).call:=call;
+                  node.expectloc:=call.expectloc;
+                end;
+            end;
+        end
+      else
+        begin
+          node.expectloc:=LOC_REGISTER;
+          result:=nil;
+        end;
+    end;
+
+
+  function asis_generate_code(node: tasisnode; opcode: tasmop): boolean;
+    var
+      checkdef: tdef;
+    begin
+      if (node.nodetype=asn) and
+         assigned(tasnode(node).call) then
+        begin
+          result:=false;
+          exit;
+        end;
+      result:=true;
+      secondpass(node.left);
+      thlcgjvm(hlcg).a_load_loc_stack(current_asmdata.CurrAsmList,node.left.resultdef,node.left.location);
+      location_freetemp(current_asmdata.CurrAsmList,node.left.location);
+      { Perform a checkcast instruction, which will raise an exception in case
+        the actual type does not match/inherit from the expected type.
+
+        Object types need the full type name (package+class name), arrays only
+        the array definition }
+      if node.nodetype=asn then
+        checkdef:=node.resultdef
+      else if node.right.resultdef.typ=classrefdef then
+        checkdef:=tclassrefdef(node.right.resultdef).pointeddef
+      else
+        checkdef:=node.right.resultdef;
+      thlcgjvm(hlcg).gen_typecheck(current_asmdata.CurrAsmList,opcode,checkdef);
+      location_reset(node.location,LOC_REGISTER,OS_ADDR);
+      node.location.register:=hlcg.getaddressregister(current_asmdata.CurrAsmList,node.resultdef);
+      thlcgjvm(hlcg).a_load_stack_reg(current_asmdata.CurrAsmList,node.resultdef,node.location.register);
+    end;
+
+    {*****************************************************************************
+                                 TJVMAsNode
+    *****************************************************************************}
+
+  function tjvmasnode.target_specific_typecheck: boolean;
+    begin
+      result:=asis_target_specific_typecheck(self);
+    end;
+
+
+  function tjvmasnode.pass_1: tnode;
+    begin
+      result:=asis_pass_1(self,'CAST');
+    end;
+
+
+  procedure tjvmasnode.pass_generate_code;
+    begin
+      if not asis_generate_code(self,a_checkcast) then
+        inherited;
+    end;
+
+
+  function tjvmasnode.dogetcopy: tnode;
+    begin
+      result:=inherited dogetcopy;
+      tjvmasnode(result).classreftypecast:=classreftypecast;
+    end;
+
+
+  function tjvmasnode.docompare(p: tnode): boolean;
+    begin
+      result:=
+        inherited docompare(p) and
+        (tjvmasnode(p).classreftypecast=classreftypecast);
+    end;
+
+
+  constructor tjvmasnode.ppuload(t: tnodetype; ppufile: tcompilerppufile);
+    begin
+      inherited;
+      classreftypecast:=boolean(ppufile.getbyte);
+    end;
+
+
+  procedure tjvmasnode.ppuwrite(ppufile: tcompilerppufile);
+    begin
+      inherited ppuwrite(ppufile);
+      ppufile.putbyte(byte(classreftypecast));
+    end;
+
+
+  {*****************************************************************************
+                               TJVMIsNode
+  *****************************************************************************}
+
+
+  function tjvmisnode.target_specific_typecheck: boolean;
+    begin
+      result:=asis_target_specific_typecheck(self);
+    end;
+
+
+  function tjvmisnode.pass_1: tnode;
+    begin
+      result:=asis_pass_1(self,'ISINSTANCE');
+    end;
+
+
+  procedure tjvmisnode.pass_generate_code;
+    begin
+      if not asis_generate_code(self,a_instanceof) then
+        inherited;
+    end;
+
+
+
+
+begin
+  ctypeconvnode:=tjvmtypeconvnode;
+  casnode:=tjvmasnode;
+  cisnode:=tjvmisnode;
+end.

compiler/jvm/njvmcon.pas

@@ -0,0 +1,485 @@
+{
+    Copyright (c) 1998-2011 by Florian Klaempfl and Jonas Maebe
+
+    Generate assembler for constant nodes for the JVM
+
+    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 njvmcon;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+       globtype,aasmbase,
+       symtype,
+       node,ncal,ncon,ncgcon;
+
+    type
+       tjvmordconstnode = class(tcgordconstnode)
+          { normally, we convert the enum constant into a load of the
+            appropriate enum class field in pass_1. In some cases (array index),
+            we want to keep it as an enum constant however }
+          enumconstok: boolean;
+          function pass_1: tnode; override;
+          function docompare(p: tnode): boolean; override;
+          function dogetcopy: tnode; override;
+       end;
+
+       tjvmrealconstnode = class(tcgrealconstnode)
+          procedure pass_generate_code;override;
+       end;
+
+       tjvmstringconstnode = class(tstringconstnode)
+          function pass_1: tnode; override;
+          procedure pass_generate_code;override;
+       end;
+
+       tjvmsetconsttype = (
+         { create symbol for the set constant; the symbol will be initialized
+           in the class constructor/unit init code (default) }
+         sct_constsymbol,
+         { normally, we convert the set constant into a constructor/factory
+           method to create a set instance. In some cases (simple "in"
+           expressions, adding an element to an empty set, ...) we want to
+           keep the set constant instead }
+         sct_notransform,
+         { actually construct a JUBitSet/JUEnumSet that contains the set value
+           (for initializing the sets contstants) }
+         sct_construct
+         );
+       tjvmsetconstnode = class(tcgsetconstnode)
+          setconsttype: tjvmsetconsttype;
+          function pass_1: tnode; override;
+          procedure pass_generate_code; override;
+          constructor create(s : pconstset;def:tdef);override;
+          function docompare(p: tnode): boolean; override;
+          function dogetcopy: tnode; override;
+         protected
+          function emitvarsetconst: tasmsymbol; override;
+          { in case the set has only a single run of consecutive elements,
+            this function will return its starting index and length }
+          function find_single_elements_run(from: longint; out start, len: longint): boolean;
+          function buildbitset: tnode;
+          function buildenumset(const eledef: tdef): tnode;
+          function buildsetfromstring(const helpername: string; otherparas: tcallparanode): tnode;
+       end;
+
+
+implementation
+
+    uses
+      globals,cutils,widestr,verbose,constexp,fmodule,
+      symdef,symsym,symtable,symconst,
+      aasmdata,aasmcpu,defutil,
+      nutils,ncnv,nld,nmem,pjvm,pass_1,
+      cgbase,hlcgobj,hlcgcpu,cgutils,cpubase
+      ;
+
+
+{*****************************************************************************
+                           TJVMORDCONSTNODE
+*****************************************************************************}
+
+    function tjvmordconstnode.pass_1: tnode;
+      var
+        basedef: tenumdef;
+        sym: tenumsym;
+        classfield: tsym;
+      begin
+        if (resultdef.typ<>enumdef) or
+           enumconstok then
+          begin
+            result:=inherited pass_1;
+            exit;
+          end;
+        { convert into JVM class instance }
+        { a) find the enumsym corresponding to the value (may not exist in case
+             of an explicit typecast of an integer -> error) }
+        sym:=nil;
+        sym:=tenumsym(tenumdef(resultdef).int2enumsym(int64(value)));
+        if not assigned(sym) then
+          begin
+            Message(parser_e_range_check_error);
+            result:=nil;
+            exit;
+          end;
+        { b) find the corresponding class field }
+        basedef:=tenumdef(resultdef).getbasedef;
+        classfield:=search_struct_member(basedef.classdef,sym.name);
+
+        { c) create loadnode of the field }
+        result:=nil;
+        if not handle_staticfield_access(classfield,false,result) then
+          internalerror(2011062606);
+      end;
+
+
+    function tjvmordconstnode.docompare(p: tnode): boolean;
+      begin
+        result:=inherited docompare(p);
+        if result then
+          result:=(enumconstok=tjvmordconstnode(p).enumconstok);
+      end;
+
+
+    function tjvmordconstnode.dogetcopy: tnode;
+      begin
+        result:=inherited dogetcopy;
+        tjvmordconstnode(result).enumconstok:=enumconstok;
+      end;
+
+
+{*****************************************************************************
+                           TJVMREALCONSTNODE
+*****************************************************************************}
+
+    procedure tjvmrealconstnode.pass_generate_code;
+      begin
+        location_reset(location,LOC_FPUREGISTER,def_cgsize(resultdef));
+        location.register:=hlcg.getfpuregister(current_asmdata.CurrAsmList,resultdef);
+        thlcgjvm(hlcg).a_loadfpu_const_stack(current_asmdata.CurrAsmList,resultdef,value_real);
+        thlcgjvm(hlcg).a_load_stack_reg(current_asmdata.CurrAsmList,resultdef,location.register);
+      end;
+
+
+    { tcgstringconstnode }
+
+    function tjvmstringconstnode.pass_1: tnode;
+      var
+        strclass: tobjectdef;
+        pw: pcompilerwidestring;
+        paras: tcallparanode;
+        wasansi: boolean;
+      begin
+        { all Java strings are utf-16. However, there is no way to
+          declare a constant array of bytes (or any other type), those
+          have to be constructed by declaring a final field and then
+          initialising them in the class constructor element per
+          element. We therefore put the straight ASCII values into
+          the UTF-16 string, and then at run time extract those and
+          store them in an Ansistring/AnsiChar array }
+        result:=inherited pass_1;
+        if assigned(result) or
+           (cst_type in [cst_unicodestring,cst_widestring]) then
+          exit;
+        { convert the constant into a widestring representation without any
+          code page conversion }
+        initwidestring(pw);
+        ascii2unicode(value_str,len,current_settings.sourcecodepage,pw,false);
+        ansistringdispose(value_str,len);
+        pcompilerwidestring(value_str):=pw;
+        { and now add a node to convert the data into ansistring format at
+          run time }
+        wasansi:=false;
+        case cst_type of
+          cst_ansistring:
+            begin
+              if len=0 then
+                begin
+                  { we have to use nil rather than an empty string, because an
+                    empty string has a code page and this messes up the code
+                    page selection logic in the RTL }
+                  result:=cnilnode.create;
+                  inserttypeconv_internal(result,resultdef);
+                  exit;
+                end;
+              strclass:=tobjectdef(search_system_type('ANSISTRINGCLASS').typedef);
+              wasansi:=true;
+            end;
+          cst_shortstring:
+            strclass:=tobjectdef(search_system_type('SHORTSTRINGCLASS').typedef);
+          cst_conststring:
+            { used for array of char }
+            strclass:=tobjectdef(search_system_type('ANSICHARARRAYCLASS').typedef);
+          else
+           internalerror(2011052401);
+        end;
+        cst_type:=cst_unicodestring;
+        paras:=ccallparanode.create(self.getcopy,nil);
+        if wasansi then
+          paras:=ccallparanode.create(
+            genintconstnode(tstringdef(resultdef).encoding),paras);
+        { since self will be freed, have to make a copy }
+        result:=ccallnode.createinternmethodres(
+          cloadvmtaddrnode.create(ctypenode.create(strclass)),
+          'CREATEFROMLITERALSTRINGBYTES',paras,resultdef);
+      end;
+
+
+    procedure tjvmstringconstnode.pass_generate_code;
+      begin
+        location_reset(location,LOC_REGISTER,def_cgsize(resultdef));
+        location.register:=hlcg.getaddressregister(current_asmdata.CurrAsmList,resultdef);
+        case cst_type of
+          cst_ansistring:
+            begin
+              current_asmdata.CurrAsmList.concat(taicpu.op_string(a_ldc,len,value_str));
+            end;
+          cst_shortstring,
+          cst_conststring:
+            current_asmdata.CurrAsmList.concat(taicpu.op_string(a_ldc,len,value_str));
+          cst_unicodestring,
+          cst_widestring:
+            current_asmdata.CurrAsmList.concat(taicpu.op_wstring(a_ldc,pcompilerwidestring(value_str)));
+        end;
+        thlcgjvm(hlcg).incstack(current_asmdata.CurrAsmList,1);
+        thlcgjvm(hlcg).a_load_stack_reg(current_asmdata.CurrAsmList,resultdef,location.register);
+      end;
+
+
+    {*****************************************************************************
+                               TJVMSETCONSTNODE
+    *****************************************************************************}
+
+    function tjvmsetconstnode.buildsetfromstring(const helpername: string; otherparas: tcallparanode): tnode;
+      var
+        pw: pcompilerwidestring;
+        wc: tcompilerwidechar;
+        i, j, bit, nulls: longint;
+      begin
+        initwidestring(pw);
+        nulls:=0;
+        for i:=0 to 15 do
+          begin
+            wc:=0;
+            for bit:=0 to 15 do
+              if (i*16+bit) in value_set^ then
+                wc:=wc or (1 shl (15-bit));
+            { don't add trailing zeroes }
+            if wc=0 then
+              inc(nulls)
+            else
+              begin
+                for j:=1 to nulls do
+                  concatwidestringchar(pw,0);
+                nulls:=0;
+                concatwidestringchar(pw,wc);
+              end;
+          end;
+        result:=ccallnode.createintern(helpername,
+          ccallparanode.create(cstringconstnode.createunistr(pw),otherparas));
+        donewidestring(pw);
+      end;
+
+
+    function tjvmsetconstnode.buildbitset: tnode;
+      var
+        mp: tnode;
+      begin
+        if value_set^=[] then
+          begin
+            mp:=cloadvmtaddrnode.create(ctypenode.create(java_jubitset));
+            result:=ccallnode.createinternmethod(mp,'CREATE',nil);
+            exit;
+          end;
+        result:=buildsetfromstring('fpc_bitset_from_string',nil);
+      end;
+
+
+    function tjvmsetconstnode.buildenumset(const eledef: tdef): tnode;
+      var
+        stopnode: tnode;
+        startnode: tnode;
+        mp: tnode;
+        len: longint;
+        start: longint;
+        enumele: tnode;
+        paras: tcallparanode;
+        hassinglerun: boolean;
+      begin
+        hassinglerun:=find_single_elements_run(0, start, len);
+        if hassinglerun then
+          begin
+            mp:=cloadvmtaddrnode.create(ctypenode.create(java_juenumset));
+            if len=0 then
+              begin
+                enumele:=cloadvmtaddrnode.create(ctypenode.create(tenumdef(eledef).getbasedef.classdef));
+                inserttypeconv_explicit(enumele,search_system_type('JLCLASS').typedef);
+                paras:=ccallparanode.create(enumele,nil);
+                result:=ccallnode.createinternmethod(mp,'NONEOF',paras)
+              end
+            else
+              begin
+                startnode:=cordconstnode.create(start,eledef,false);
+                { immediately firstpass so the enum gets translated into a JLEnum
+                  instance }
+                firstpass(startnode);
+                if len=1 then
+                  result:=ccallnode.createinternmethod(mp,'OF',ccallparanode.create(startnode,nil))
+                else
+                  begin
+                    stopnode:=cordconstnode.create(start+len-1,eledef,false);
+                    firstpass(stopnode);
+                    result:=ccallnode.createinternmethod(mp,'RANGE',ccallparanode.create(stopnode,ccallparanode.create(startnode,nil)));
+                  end
+              end
+          end
+        else
+          begin
+            enumele:=cordconstnode.create(tenumsym(tenumdef(eledef).symtable.symlist[0]).value,eledef,false);
+            firstpass(enumele);
+            paras:=ccallparanode.create(enumele,nil);
+            result:=buildsetfromstring('fpc_enumset_from_string',paras);
+          end;
+      end;
+
+
+    function tjvmsetconstnode.pass_1: tnode;
+      var
+        eledef: tdef;
+      begin
+        { we want set constants to be global, so we can reuse them. However,
+          if the set's elementdef is local, we can't do that since a global
+          symbol cannot have a local definition (the compiler will crash when
+          loading the ppu file afterwards) }
+        if tsetdef(resultdef).elementdef.owner.symtabletype=localsymtable then
+          setconsttype:=sct_construct;
+        result:=nil;
+        case setconsttype of
+(*
+          sct_constsymbol:
+            begin
+              { normally a codegen pass routine, but we have to insert a typed
+                const in case the set constant does not exist yet, and that
+                should happen in pass_1 (especially since it involves creating
+                new nodes, which may even have to be tacked on to this code in
+                case it's the unit initialization code) }
+              handlevarsetconst;
+              { no smallsets }
+              expectloc:=LOC_CREFERENCE;
+            end;
+*)
+          sct_notransform:
+            begin
+              result:=inherited pass_1;
+              { no smallsets }
+              expectloc:=LOC_CREFERENCE;
+            end;
+          sct_constsymbol,
+          sct_construct:
+            begin
+              eledef:=tsetdef(resultdef).elementdef;
+              { empty sets don't have an element type, so we don't know whether we
+                have to constructor a bitset or enumset (and of which type) }
+              if not assigned(eledef) then
+                internalerror(2011070202);
+              if eledef.typ=enumdef then
+                begin
+                  result:=buildenumset(eledef);
+                end
+              else
+                begin
+                  result:=buildbitset;
+                end;
+              inserttypeconv_explicit(result,getpointerdef(resultdef));
+              result:=cderefnode.create(result);
+            end;
+          else
+            internalerror(2011060301);
+        end;
+      end;
+
+
+    procedure tjvmsetconstnode.pass_generate_code;
+      begin
+        case setconsttype of
+          sct_constsymbol:
+            begin
+              { all sets are varsets for the JVM target, no setbase differences }
+              handlevarsetconst;
+            end;
+          else
+            { must be handled in pass_1 or otherwise transformed }
+            internalerror(2011070201)
+        end;
+      end;
+
+    constructor tjvmsetconstnode.create(s: pconstset; def: tdef);
+      begin
+        inherited create(s, def);
+        setconsttype:=sct_constsymbol;
+      end;
+
+
+    function tjvmsetconstnode.docompare(p: tnode): boolean;
+      begin
+        result:=
+          inherited docompare(p) and
+          (setconsttype=tjvmsetconstnode(p).setconsttype);
+      end;
+
+
+    function tjvmsetconstnode.dogetcopy: tnode;
+      begin
+        result:=inherited dogetcopy;
+        tjvmsetconstnode(result).setconsttype:=setconsttype;
+      end;
+
+
+    function tjvmsetconstnode.emitvarsetconst: tasmsymbol;
+      var
+        csym: tconstsym;
+        ssym: tstaticvarsym;
+        ps: pnormalset;
+      begin
+        { add a read-only typed constant }
+        new(ps);
+        ps^:=value_set^;
+        csym:=tconstsym.create_ptr('_$setconst'+tostr(current_module.symlist.count),constset,ps,resultdef);
+        csym.visibility:=vis_private;
+        include(csym.symoptions,sp_internal);
+        current_module.localsymtable.insert(csym);
+        { generate assignment of the constant to the typed constant symbol }
+        ssym:=jvm_add_typed_const_initializer(csym);
+        result:=current_asmdata.RefAsmSymbol(ssym.mangledname);
+      end;
+
+
+    function tjvmsetconstnode.find_single_elements_run(from: longint; out start, len: longint): boolean;
+      var
+        i: longint;
+      begin
+        i:=from;
+        result:=true;
+        { find first element in set }
+        while (i<=255) and
+              not(i in value_set^) do
+          inc(i);
+        start:=i;
+        { go to end of the run }
+        while (i<=255) and
+              (i in value_set^) do
+          inc(i);
+        len:=i-start;
+        { rest must be unset }
+        while (i<=255) and
+              not(i in value_set^) do
+          inc(i);
+        if i<>256 then
+          result:=false;
+      end;
+
+
+
+begin
+   cordconstnode:=tjvmordconstnode;
+   crealconstnode:=tjvmrealconstnode;
+   cstringconstnode:=tjvmstringconstnode;
+   csetconstnode:=tjvmsetconstnode;
+end.

compiler/jvm/njvmflw.pas

@@ -0,0 +1,492 @@
+{
+    Copyright (c) 1998-2011 by Florian Klaempfl and Jonas Maebe
+
+    Generate assembler for nodes that influence the flow for the JVM
+
+    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 njvmflw;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+      aasmbase,node,nflw,ncgflw;
+
+    type
+       tjvmfornode = class(tcgfornode)
+          function pass_1: tnode; override;
+       end;
+
+       tjvmraisenode = class(traisenode)
+          function pass_typecheck: tnode; override;
+          procedure pass_generate_code;override;
+       end;
+
+       tjvmtryexceptnode = class(ttryexceptnode)
+          procedure pass_generate_code;override;
+       end;
+
+       tjvmtryfinallynode = class(ttryfinallynode)
+          procedure pass_generate_code;override;
+       end;
+
+       tjvmonnode = class(tonnode)
+          procedure pass_generate_code;override;
+       end;
+
+implementation
+
+    uses
+      verbose,globals,systems,globtype,constexp,
+      symconst,symdef,symsym,aasmtai,aasmdata,aasmcpu,defutil,jvmdef,
+      procinfo,cgbase,pass_2,parabase,
+      cpubase,cpuinfo,
+      nbas,nld,ncon,ncnv,
+      tgobj,paramgr,
+      cgutils,hlcgobj,hlcgcpu
+      ;
+
+{*****************************************************************************
+                             TFJVMFORNODE
+*****************************************************************************}
+
+    function tjvmfornode.pass_1: tnode;
+      var
+        iteratortmp: ttempcreatenode;
+        olditerator: tnode;
+        block,
+        newbody: tblocknode;
+        stat,
+        newbodystat: tstatementnode;
+      begin
+        { transform for-loops with enums to:
+            for tempint:=ord(lowval) to ord(upperval) do
+              begin
+                originalctr:=tenum(tempint);
+                <original loop body>
+              end;
+
+          enums are class instances in Java and hence can't be increased or so.
+          The type conversion consists of an array lookup in a final method,
+          so it shouldn't be too expensive.
+        }
+        if left.resultdef.typ=enumdef then
+          begin
+            block:=internalstatements(stat);
+            iteratortmp:=ctempcreatenode.create(s32inttype,left.resultdef.size,tt_persistent,true);
+            addstatement(stat,iteratortmp);
+            olditerator:=left;
+            left:=ctemprefnode.create(iteratortmp);
+            inserttypeconv_explicit(right,s32inttype);
+            inserttypeconv_explicit(t1,s32inttype);
+            newbody:=internalstatements(newbodystat);
+            addstatement(newbodystat,cassignmentnode.create(olditerator,
+              ctypeconvnode.create_explicit(ctemprefnode.create(iteratortmp),
+                olditerator.resultdef)));
+            addstatement(newbodystat,t2);
+            addstatement(stat,cfornode.create(left,right,t1,newbody,lnf_backward in loopflags));
+            addstatement(stat,ctempdeletenode.create(iteratortmp));
+            left:=nil;
+            right:=nil;
+            t1:=nil;
+            t2:=nil;
+            result:=block
+          end
+        else
+          result:=inherited pass_1;
+      end;
+
+{*****************************************************************************
+                             SecondRaise
+*****************************************************************************}
+
+    var
+      current_except_loc: tlocation;
+
+    function tjvmraisenode.pass_typecheck: tnode;
+      begin
+         Result:=inherited pass_typecheck;
+         if codegenerror then
+           exit;
+         { Java exceptions must descend from java.lang.Throwable }
+         if assigned(left) and
+            not(left.resultdef).is_related(java_jlthrowable) then
+           MessagePos2(left.fileinfo,type_e_incompatible_types,left.resultdef.typename,'class(JLThrowable)');
+         { Java exceptions cannot be raised "at" a specific location }
+         if assigned(right) then
+           MessagePos(right.fileinfo,parser_e_illegal_expression);
+      end;
+
+
+    procedure tjvmraisenode.pass_generate_code;
+      begin
+        if assigned(left) then
+          begin
+            secondpass(left);
+            thlcgjvm(hlcg).a_load_loc_stack(current_asmdata.CurrAsmList,left.resultdef,left.location);
+          end
+        else
+          thlcgjvm(hlcg).a_load_loc_stack(current_asmdata.CurrAsmList,java_jlthrowable,current_except_loc);
+        current_asmdata.CurrAsmList.Concat(taicpu.op_none(a_athrow));
+        thlcgjvm(hlcg).decstack(current_asmdata.CurrAsmList,1);
+      end;
+
+
+{*****************************************************************************
+                             SecondTryExcept
+*****************************************************************************}
+
+    var
+       begintrylabel,
+       endtrylabel: tasmlabel;
+       endexceptlabel : tasmlabel;
+
+
+    procedure tjvmtryexceptnode.pass_generate_code;
+
+      var
+         oldendexceptlabel,
+         oldbegintrylabel,
+         oldendtrylabel,
+         defaultcatchlabel: tasmlabel;
+         oldflowcontrol,tryflowcontrol,
+         exceptflowcontrol : tflowcontrol;
+         prev_except_loc: tlocation;
+      begin
+         location_reset(location,LOC_VOID,OS_NO);
+
+         oldflowcontrol:=flowcontrol;
+         flowcontrol:=[fc_inflowcontrol];
+         { this can be called recursivly }
+         oldbegintrylabel:=begintrylabel;
+         oldendtrylabel:=endtrylabel;
+         oldendexceptlabel:=endexceptlabel;
+
+         { get new labels for the control flow statements }
+         current_asmdata.getaddrlabel(begintrylabel);
+         current_asmdata.getaddrlabel(endtrylabel);
+         current_asmdata.getjumplabel(endexceptlabel);
+
+         { try block }
+         { set control flow labels for the try block }
+
+         hlcg.a_label(current_asmdata.CurrAsmList,begintrylabel);
+         secondpass(left);
+         hlcg.a_label(current_asmdata.CurrAsmList,endtrylabel);
+         tryflowcontrol:=flowcontrol;
+
+         { jump over exception handling blocks }
+         current_asmdata.CurrAsmList.concat(tai_marker.create(mark_NoLineInfoStart));
+         hlcg.a_jmp_always(current_asmdata.CurrAsmList,endexceptlabel);
+         current_asmdata.CurrAsmList.concat(tai_marker.create(mark_NoLineInfoEnd));
+
+         { set control flow labels for the except block }
+         { and the on statements                        }
+
+         flowcontrol:=[fc_inflowcontrol];
+         { on-statements }
+         if assigned(right) then
+           secondpass(right);
+
+         { default handling except handling }
+         if assigned(t1) then
+           begin
+             current_asmdata.getaddrlabel(defaultcatchlabel);
+             current_asmdata.CurrAsmList.concat(tai_jcatch.create(
+               'all',begintrylabel,endtrylabel,defaultcatchlabel));
+             hlcg.a_label(current_asmdata.CurrAsmList,defaultcatchlabel);
+             { here we don't have to reset flowcontrol           }
+             { the default and on flowcontrols are handled equal }
+
+             { get the exception object from the stack and store it for use by
+               the exception code (in case of an anonymous "raise") }
+             current_asmdata.CurrAsmList.concat(tai_marker.create(mark_NoLineInfoStart));
+             prev_except_loc:=current_except_loc;
+             location_reset_ref(current_except_loc,LOC_REFERENCE,OS_ADDR,4);
+             tg.GetLocal(current_asmdata.CurrAsmList,sizeof(pint),java_jlthrowable,current_except_loc.reference);
+             thlcgjvm(hlcg).incstack(current_asmdata.CurrAsmList,1);
+             thlcgjvm(hlcg).a_load_stack_loc(current_asmdata.CurrAsmList,java_jlthrowable,current_except_loc);
+             current_asmdata.CurrAsmList.concat(tai_marker.create(mark_NoLineInfoEnd));
+
+             { and generate the exception handling code }
+             secondpass(t1);
+
+             { free the temp containing the exception and invalidate }
+             tg.UngetLocal(current_asmdata.CurrAsmList,current_except_loc.reference);
+             current_except_loc:=prev_except_loc;
+
+             exceptflowcontrol:=flowcontrol;
+           end
+         else
+           exceptflowcontrol:=flowcontrol;
+         hlcg.a_label(current_asmdata.CurrAsmList,endexceptlabel);
+
+         { restore all saved labels }
+         begintrylabel:=oldbegintrylabel;
+         endtrylabel:=oldendtrylabel;
+         endexceptlabel:=oldendexceptlabel;
+
+         { return all used control flow statements }
+         flowcontrol:=oldflowcontrol+(exceptflowcontrol +
+           tryflowcontrol - [fc_inflowcontrol]);
+      end;
+
+
+    {*****************************************************************************
+                                   SecondOn
+    *****************************************************************************}
+
+    procedure tjvmonnode.pass_generate_code;
+      var
+         thisonlabel : tasmlabel;
+         oldflowcontrol : tflowcontrol;
+         exceptvarsym : tlocalvarsym;
+         prev_except_loc : tlocation;
+      begin
+         location_reset(location,LOC_VOID,OS_NO);
+
+         oldflowcontrol:=flowcontrol;
+         flowcontrol:=[fc_inflowcontrol];
+         current_asmdata.getjumplabel(thisonlabel);
+
+         hlcg.a_label(current_asmdata.CurrAsmList,thisonlabel);
+
+         if assigned(excepTSymtable) then
+           exceptvarsym:=tlocalvarsym(excepTSymtable.SymList[0])
+         else
+           internalerror(2011020402);
+
+         { add exception catching information for the JVM: exception type
+           (will have to be adjusted if/when support for catching class
+            reference types is added), begin/end of code in which the exception
+            can be raised, and start of this exception handling code }
+         current_asmdata.CurrAsmList.concat(tai_jcatch.create(
+           tobjectdef(exceptvarsym.vardef).jvm_full_typename(true),
+           begintrylabel,endtrylabel,thisonlabel));
+
+         { Retrieve exception variable }
+         { 1) prepare the location where we'll store it }
+         location_reset_ref(exceptvarsym.localloc,LOC_REFERENCE,OS_ADDR,sizeof(pint));
+         tg.GetLocal(current_asmdata.CurrAsmList,sizeof(pint),exceptvarsym.vardef,exceptvarsym.localloc.reference);
+         prev_except_loc:=current_except_loc;
+         current_except_loc:=exceptvarsym.localloc;
+         { 2) the exception variable is at the top of the evaluation stack
+           (placed there by the JVM) -> adjust stack count, then store it }
+         thlcgjvm(hlcg).incstack(current_asmdata.CurrAsmList,1);
+         thlcgjvm(hlcg).a_load_stack_loc(current_asmdata.CurrAsmList,exceptvarsym.vardef,current_except_loc);
+
+         if assigned(right) then
+           secondpass(right);
+
+         { clear some stuff }
+         tg.UngetLocal(current_asmdata.CurrAsmList,exceptvarsym.localloc.reference);
+         exceptvarsym.localloc.loc:=LOC_INVALID;
+         current_except_loc:=prev_except_loc;
+         hlcg.a_jmp_always(current_asmdata.CurrAsmList,endexceptlabel);
+
+         flowcontrol:=oldflowcontrol+(flowcontrol-[fc_inflowcontrol]);
+
+         { next on node }
+         if assigned(left) then
+           secondpass(left);
+      end;
+
+{*****************************************************************************
+                             SecondTryFinally
+*****************************************************************************}
+
+    procedure tjvmtryfinallynode.pass_generate_code;
+      var
+         begintrylabel,
+         endtrylabel,
+         reraiselabel,
+         finallylabel,
+         finallyexceptlabel,
+         endfinallylabel,
+         exitfinallylabel,
+         continuefinallylabel,
+         breakfinallylabel,
+         oldCurrExitLabel,
+         oldContinueLabel,
+         oldBreakLabel : tasmlabel;
+         oldflowcontrol,tryflowcontrol : tflowcontrol;
+         finallycodecopy: tnode;
+         reasonbuf,
+         exceptreg: tregister;
+      begin
+         { not necessary on a garbage-collected platform }
+         if implicitframe then
+           internalerror(2011031803);
+         location_reset(location,LOC_VOID,OS_NO);
+
+         { check if child nodes do a break/continue/exit }
+         oldflowcontrol:=flowcontrol;
+         flowcontrol:=[fc_inflowcontrol];
+         current_asmdata.getjumplabel(finallylabel);
+         current_asmdata.getjumplabel(endfinallylabel);
+         current_asmdata.getjumplabel(reraiselabel);
+
+         { the finally block must catch break, continue and exit }
+         { statements                                            }
+         oldCurrExitLabel:=current_procinfo.CurrExitLabel;
+         current_asmdata.getjumplabel(exitfinallylabel);
+         current_procinfo.CurrExitLabel:=exitfinallylabel;
+         if assigned(current_procinfo.CurrBreakLabel) then
+          begin
+            oldContinueLabel:=current_procinfo.CurrContinueLabel;
+            oldBreakLabel:=current_procinfo.CurrBreakLabel;
+            current_asmdata.getjumplabel(breakfinallylabel);
+            current_asmdata.getjumplabel(continuefinallylabel);
+            current_procinfo.CurrContinueLabel:=continuefinallylabel;
+            current_procinfo.CurrBreakLabel:=breakfinallylabel;
+          end;
+
+         { allocate reg to store the reason why the finally block was entered
+           (no exception, break, continue, exit), so we can continue to the
+           right label afterwards. In case of an exception, we use a separate
+           (duplicate) finally block because otherwise the JVM's bytecode
+           verification cannot statically prove that the exception reraise code
+           will only execute in case an exception actually happened }
+         reasonbuf:=hlcg.getaddressregister(current_asmdata.CurrAsmList,s32inttype);
+
+         { try code }
+         begintrylabel:=nil;
+         endtrylabel:=nil;
+         if assigned(left) then
+           begin
+              current_asmdata.getaddrlabel(begintrylabel);
+              current_asmdata.getaddrlabel(endtrylabel);
+              hlcg.a_label(current_asmdata.CurrAsmList,begintrylabel);
+              secondpass(left);
+              hlcg.a_label(current_asmdata.CurrAsmList,endtrylabel);
+              tryflowcontrol:=flowcontrol;
+              if codegenerror then
+                exit;
+              { reason: no exception occurred }
+              hlcg.a_load_const_reg(current_asmdata.CurrAsmList,s32inttype,0,reasonbuf);
+           end
+         else
+           tryflowcontrol:=[fc_inflowcontrol];
+
+         { begin of the finally code }
+         hlcg.a_label(current_asmdata.CurrAsmList,finallylabel);
+         { finally code }
+         flowcontrol:=[fc_inflowcontrol];
+         { duplicate finally code for case when exception happened }
+         if assigned(begintrylabel) then
+           finallycodecopy:=right.getcopy;
+         secondpass(right);
+         { goto is allowed if it stays inside the finally block,
+           this is checked using the exception block number }
+         if (flowcontrol-[fc_gotolabel])<>[fc_inflowcontrol] then
+           CGMessage(cg_e_control_flow_outside_finally);
+         if codegenerror then
+           begin
+             if assigned(begintrylabel) then
+               finallycodecopy.free;
+             exit;
+           end;
+
+         { don't generate line info for internal cleanup }
+         current_asmdata.CurrAsmList.concat(tai_marker.create(mark_NoLineInfoStart));
+
+         { the reasonbuf holds the reason why this (non-exception) finally code
+           was executed:
+             0 = try code simply finished
+             1 = (unused) exception raised
+             2 = exit called
+             3 = break called
+             4 = continue called }
+         hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,s32inttype,OC_EQ,0,reasonbuf,endfinallylabel);
+         if fc_exit in tryflowcontrol then
+           if ([fc_break,fc_continue]*tryflowcontrol)<>[] then
+             hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,s32inttype,OC_EQ,2,reasonbuf,oldCurrExitLabel)
+           else
+             hlcg.a_jmp_always(current_asmdata.CurrAsmList,oldCurrExitLabel);
+         if fc_break in tryflowcontrol then
+           if fc_continue in tryflowcontrol then
+             hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,s32inttype,OC_EQ,3,reasonbuf,oldBreakLabel)
+           else
+             hlcg.a_jmp_always(current_asmdata.CurrAsmList,oldBreakLabel);
+         if fc_continue in tryflowcontrol then
+           hlcg.a_jmp_always(current_asmdata.CurrAsmList,oldContinueLabel);
+         { now generate the trampolines for exit/break/continue to load the reasonbuf }
+         if fc_exit in tryflowcontrol then
+           begin
+              hlcg.a_label(current_asmdata.CurrAsmList,exitfinallylabel);
+              hlcg.a_load_const_reg(current_asmdata.CurrAsmList,s32inttype,2,reasonbuf);
+              hlcg.a_jmp_always(current_asmdata.CurrAsmList,finallylabel);
+           end;
+         if fc_break in tryflowcontrol then
+          begin
+              hlcg.a_label(current_asmdata.CurrAsmList,breakfinallylabel);
+              hlcg.a_load_const_reg(current_asmdata.CurrAsmList,s32inttype,3,reasonbuf);
+              hlcg.a_jmp_always(current_asmdata.CurrAsmList,finallylabel);
+           end;
+         if fc_continue in tryflowcontrol then
+           begin
+              hlcg.a_label(current_asmdata.CurrAsmList,continuefinallylabel);
+              hlcg.a_load_const_reg(current_asmdata.CurrAsmList,s32inttype,4,reasonbuf);
+              hlcg.a_jmp_always(current_asmdata.CurrAsmList,finallylabel);
+           end;
+         { jump over finally-code-in-case-an-exception-happened }
+         hlcg.a_jmp_always(current_asmdata.CurrAsmList,endfinallylabel);
+
+         { generate finally code in case an exception occurred }
+         if assigned(begintrylabel) then
+           begin
+             current_asmdata.getaddrlabel(finallyexceptlabel);
+             hlcg.a_label(current_asmdata.CurrAsmList,finallyexceptlabel);
+             { catch the exceptions }
+             current_asmdata.CurrAsmList.concat(tai_jcatch.create(
+               'all',begintrylabel,endtrylabel,finallyexceptlabel));
+             { store the generated exception object to a temp }
+             exceptreg:=hlcg.getaddressregister(current_asmdata.CurrAsmList,java_jlthrowable);
+             thlcgjvm(hlcg).incstack(current_asmdata.CurrAsmList,1);
+             thlcgjvm(hlcg).a_load_stack_reg(current_asmdata.CurrAsmList,java_jlthrowable,exceptreg);
+             { generate the finally code again }
+             secondpass(finallycodecopy);
+             finallycodecopy.free;
+             { reraise the exception }
+             thlcgjvm(hlcg).a_load_reg_stack(current_asmdata.CurrAsmList,java_jlthrowable,exceptreg);
+             current_asmdata.CurrAsmList.Concat(taicpu.op_none(a_athrow));
+             thlcgjvm(hlcg).decstack(current_asmdata.CurrAsmList,1);
+           end;
+         hlcg.a_label(current_asmdata.CurrAsmList,endfinallylabel);
+
+         { end cleanup }
+         current_asmdata.CurrAsmList.concat(tai_marker.create(mark_NoLineInfoEnd));
+
+         current_procinfo.CurrExitLabel:=oldCurrExitLabel;
+         if assigned(current_procinfo.CurrBreakLabel) then
+          begin
+            current_procinfo.CurrContinueLabel:=oldContinueLabel;
+            current_procinfo.CurrBreakLabel:=oldBreakLabel;
+          end;
+         flowcontrol:=oldflowcontrol+(tryflowcontrol-[fc_inflowcontrol]);
+      end;
+
+begin
+   cfornode:=tjvmfornode;
+   craisenode:=tjvmraisenode;
+   ctryexceptnode:=tjvmtryexceptnode;
+   ctryfinallynode:=tjvmtryfinallynode;
+   connode:=tjvmonnode;
+end.
+

compiler/jvm/njvminl.pas

@@ -0,0 +1,814 @@
+{
+    Copyright (c) 1998-2011 by Florian Klaempfl and Jonas Maebe
+
+    Generate JVM inline nodes
+
+    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 njvminl;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+       cpubase,
+       node,ninl,ncginl;
+
+    type
+       tjvminlinenode = class(tcginlinenode)
+         protected
+          function typecheck_length(var handled: boolean): tnode;
+          function typecheck_high(var handled: boolean): tnode;
+          function typecheck_new(var handled: boolean): tnode;
+
+          function first_copy: tnode; override;
+          function first_assigned: tnode; override;
+
+          function first_assert: tnode; override;
+
+          function first_box: tnode; override;
+          function first_unbox: tnode; override;
+
+          function first_setlength_array: tnode;
+         public
+          { typecheck override to intercept handling }
+          function pass_typecheck: tnode; override;
+
+          { first pass override
+            so that the code generator will actually generate
+            these nodes.
+          }
+          function first_sqr_real: tnode; override;
+          function first_trunc_real: tnode; override;
+          function first_new: tnode; override;
+          function first_IncludeExclude: tnode; override;
+          function first_setlength: tnode; override;
+          function first_length: tnode; override;
+
+          procedure second_length; override;
+          procedure second_sqr_real; override;
+          procedure second_trunc_real; override;
+          procedure second_new; override;
+          procedure second_setlength; override;
+       protected
+          procedure load_fpu_location;
+       end;
+
+implementation
+
+    uses
+      cutils,globals,verbose,globtype,constexp,fmodule,
+      aasmbase,aasmtai,aasmdata,aasmcpu,
+      symtype,symconst,symdef,symsym,symtable,jvmdef,
+      defutil,
+      nadd,nbas,ncon,ncnv,nmat,nmem,ncal,nld,nflw,nutils,
+      cgbase,pass_1,pass_2,
+      cpuinfo,ncgutil,
+      cgutils,hlcgobj,hlcgcpu;
+
+
+{*****************************************************************************
+                              tjvminlinenode
+*****************************************************************************}
+
+    function tjvminlinenode.typecheck_length(var handled: boolean): tnode;
+      begin
+        typecheckpass(left);
+        if is_open_array(left.resultdef) or
+           is_dynamic_array(left.resultdef) then
+          begin
+            resultdef:=s32inttype;
+            result:=nil;
+            handled:=true;
+          end;
+      end;
+
+
+    function tjvminlinenode.typecheck_high(var handled: boolean): tnode;
+      begin
+        typecheckpass(left);
+        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,
+              cinlinenode.create(in_length_x,false,left));
+            left:=nil;
+            handled:=true;
+          end;
+      end;
+
+
+    function tjvminlinenode.typecheck_new(var handled: boolean): tnode;
+      var
+        para: tcallparanode;
+        elemdef: tdef;
+      begin
+        { normally never exists; used by the JVM backend to create new
+          arrays because it requires special opcodes }
+        tcallparanode(left).get_paratype;
+        if is_dynamic_array(left.resultdef) then
+          begin
+            para:=tcallparanode(left);
+            { need at least one extra parameter in addition to the
+              array }
+            if not assigned(para.right) then
+              internalerror(2011012206);
+            elemdef:=tarraydef(left.resultdef).elementdef;
+            while elemdef.typ=arraydef do
+              begin
+                { if we have less length specifiers than dimensions, make
+                  the last array an array of length 0 }
+                if not assigned(para.right) then
+                  begin
+                    para.right:=ccallparanode.create(
+                      cordconstnode.create(0,s32inttype,false),nil);
+                    tcallparanode(para.right).get_paratype;
+                    break;
+                  end
+                else
+                  begin
+                    inserttypeconv(tcallparanode(para.right).left,s32inttype);
+                    tcallparanode(para.right).get_paratype;
+                  end;
+                para:=tcallparanode(para.right);
+                elemdef:=tarraydef(elemdef).elementdef;
+              end;
+            result:=nil;
+            resultdef:=left.resultdef;
+            handled:=true;
+          end;
+      end;
+
+
+    function tjvminlinenode.first_copy: tnode;
+      var
+        ppn: tcallparanode;
+        arr, len, start, kind: tnode;
+        eledef: tdef;
+        counter, ndims: longint;
+        finaltype: char;
+      begin
+        if is_dynamic_array(resultdef) then
+          begin
+            ppn:=tcallparanode(left);
+            counter:=1;
+            while assigned(ppn.right) do
+              begin
+                inc(counter);
+                ppn:=tcallparanode(ppn.right);
+              end;
+            if (counter=3) then
+              begin
+                len:=tcallparanode(left).left;
+                tcallparanode(left).left:=nil;
+                start:=tcallparanode(tcallparanode(left).right).left;
+                tcallparanode(tcallparanode(left).right).left:=nil;
+                { free the original start/len paras and remove them }
+                ppn:=tcallparanode(left);
+                left:=tcallparanode(tcallparanode(left).right).right;
+                tcallparanode(ppn.right).right:=nil;
+                ppn.free;
+              end
+            else
+              begin
+                { use special -1,-1 argument to copy the whole array }
+                len:=genintconstnode(-1);
+                start:=genintconstnode(-1);
+              end;
+            { currently there is one parameter left: the array itself }
+            arr:=tcallparanode(left).left;
+            tcallparanode(left).left:=nil;
+            { in case it's a dynamic array of static arrays, get the dimensions
+              of the static array components }
+            eledef:=tarraydef(resultdef).elementdef;
+            ndims:=1;
+            while (eledef.typ=arraydef) and
+                  not is_dynamic_array(eledef) do
+              begin
+                inc(ndims);
+                eledef:=tarraydef(eledef).elementdef;
+              end;
+            { get the final element kind }
+            finaltype:=jvmarrtype_setlength(eledef);
+            { construct the call to
+                fpc_dynarray_copy(src: JLObject; start, len: longint; ndim: longint; eletype: jchar) }
+            result:=ccallnode.createintern('FPC_DYNARRAY_COPY',
+              ccallparanode.create(cordconstnode.create(ord(finaltype),cwidechartype,false),
+                ccallparanode.create(genintconstnode(ndims),
+                  ccallparanode.create(len,
+                    ccallparanode.create(start,
+                      ccallparanode.create(ctypeconvnode.create_explicit(arr,java_jlobject),nil)
+                    )
+                  )
+                )
+              )
+            );
+            inserttypeconv_explicit(result,resultdef);
+          end
+        else
+          result:=inherited first_copy;
+      end;
+
+
+    function tjvminlinenode.first_assigned: tnode;
+      begin
+        { on the JVM target, empty arrays can also be <> nil but have length 0
+          instead. Since assigned(dynarray) is only used to determine whether
+          the length is <> 0 on other targets, replace this expression here }
+        if is_dynamic_array(tcallparanode(left).left.resultdef) then
+          begin
+            result:=caddnode.create(unequaln,cinlinenode.create(
+              in_length_x,false,tcallparanode(left).left),genintconstnode(0));
+            tcallparanode(left).left:=nil;
+          end
+        else
+          result:=inherited;
+      end;
+
+
+    function tjvminlinenode.first_assert: tnode;
+      var
+        paras: tcallparanode;
+      begin
+        paras:=tcallparanode(tcallparanode(left).right);
+        paras:=ccallparanode.create(cstringconstnode.createstr(current_module.sourcefiles.get_file_name(current_filepos.fileindex)),paras);
+        paras:=ccallparanode.create(genintconstnode(fileinfo.line),paras);
+        result:=cifnode.create(cnotnode.create(tcallparanode(left).left),
+           ccallnode.createintern('fpc_assert',paras),nil);
+        tcallparanode(left).left:=nil;
+        tcallparanode(left).right:=nil;
+      end;
+
+
+    function tjvminlinenode.first_box: tnode;
+      var
+        boxdef,
+        boxparadef: tdef;
+      begin
+        { get class wrapper type }
+        jvmgetboxtype(left.resultdef,boxdef,boxparadef,true);
+        { created wrapped instance }
+        inserttypeconv_explicit(tcallparanode(left).left,boxparadef);
+        result:=ccallnode.createinternmethod(
+          cloadvmtaddrnode.create(ctypenode.create(tobjectdef(boxdef))),'CREATE',left);
+        { reused }
+        left:=nil;
+      end;
+
+
+    function tjvminlinenode.first_unbox: tnode;
+      var
+        val: tnode;
+        boxdef,
+        boxparadef: tdef;
+      begin
+        jvmgetboxtype(resultdef,boxdef,boxparadef,true);
+        val:=tcallparanode(tcallparanode(left).right).left;
+        tcallparanode(tcallparanode(left).right).left:=nil;
+        { typecast to the boxing type }
+        val:=ctypeconvnode.create_explicit(val,boxdef);
+        { call the unboxing method }
+        val:=ccallnode.createinternmethod(val,jvmgetunboxmethod(resultdef),nil);
+        { add type conversion for shortint -> byte etc }
+        inserttypeconv_explicit(val,resultdef);
+        result:=val;
+      end;
+
+
+    function tjvminlinenode.pass_typecheck: tnode;
+      var
+        handled: boolean;
+      begin
+         handled:=false;
+         case inlinenumber of
+           in_length_x:
+             begin
+               result:=typecheck_length(handled);
+             end;
+           in_high_x:
+             begin
+               result:=typecheck_high(handled);
+             end;
+           in_new_x:
+             begin
+               result:=typecheck_new(handled);
+             end;
+         end;
+        if not handled then
+          result:=inherited pass_typecheck;
+      end;
+
+
+(*
+    function tjvminlinenode.first_sqrt_real : tnode;
+      begin
+        if (current_settings.cputype >= cpu_PPC970) then
+          begin
+            expectloc:=LOC_FPUREGISTER;
+            first_sqrt_real := nil;
+          end
+        else
+          result:=inherited first_sqrt_real;
+      end;
+*)
+
+     function tjvminlinenode.first_sqr_real : tnode;
+      begin
+        expectloc:=LOC_FPUREGISTER;
+        first_sqr_real:=nil;
+      end;
+
+
+     function tjvminlinenode.first_trunc_real : tnode;
+      begin
+        expectloc:=LOC_REGISTER;
+        first_trunc_real:=nil;
+      end;
+
+
+    function tjvminlinenode.first_new: tnode;
+      begin
+        { skip the array; it's a type node }
+        tcallparanode(tcallparanode(left).right).firstcallparan;
+        expectloc:=LOC_REGISTER;
+        result:=nil;
+      end;
+
+
+    function tjvminlinenode.first_IncludeExclude: tnode;
+      var
+        setpara: tnode;
+        valuepara: tcallparanode;
+        seteledef: tdef;
+        procname: string[6];
+      begin
+        setpara:=tcallparanode(left).left;
+        tcallparanode(left).left:=nil;
+        valuepara:=tcallparanode(tcallparanode(left).right);
+        tcallparanode(left).right:=nil;
+        seteledef:=tsetdef(setpara.resultdef).elementdef;
+        setpara:=caddrnode.create_internal(setpara);
+        include(setpara.flags,nf_typedaddr);
+        if seteledef.typ=enumdef then
+          begin
+            inserttypeconv_explicit(setpara,java_juenumset);
+            inserttypeconv_explicit(valuepara.left,tenumdef(seteledef).getbasedef.classdef);
+          end
+        else
+          begin
+            inserttypeconv_explicit(setpara,java_jubitset);
+            inserttypeconv_explicit(valuepara.left,s32inttype);
+          end;
+        if inlinenumber=in_include_x_y then
+          procname:='ADD'
+        else
+          procname:='REMOVE';
+        result:=ccallnode.createinternmethod(setpara,procname,valuepara);
+      end;
+
+
+    function tjvminlinenode.first_setlength_array: tnode;
+      var
+        assignmenttarget,
+        ppn,
+        newparas: tnode;
+        newnode: tnode;
+        eledef,
+        objarraydef: tdef;
+        ndims: longint;
+        finaltype: char;
+        setlenroutine: string;
+        lefttemp: ttempcreatenode;
+        newblock: tblocknode;
+        newstatement: tstatementnode;
+        primitive: boolean;
+      begin
+        { first parameter is the array, the rest are the dimensions }
+        newparas:=tcallparanode(left).right;
+        tcallparanode(left).right:=nil;
+        { count the number of specified dimensions, and determine the type of
+          the final one }
+        ppn:=newparas;
+        eledef:=tarraydef(left.resultdef).elementdef;
+        { ppn already points to the first dimension }
+        ndims:=1;
+        while assigned(tcallparanode(ppn).right) do
+          begin
+            inc(ndims);
+            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;
+        { node to create the new array }
+        newnode:=cinlinenode.create(in_new_x,false,newparas);
+        { Common parameters for setlength helper }
+        { start with org (save assignmenttarget itself to assign the result back to) }
+        { store left into a temp in case it may contain a function call
+          (which must not be evaluated twice) }
+        newblock:=nil;
+        newstatement:=nil;
+        lefttemp:=maybereplacewithtempref(tcallparanode(left).left,newblock,newstatement,tcallparanode(left).left.resultdef.size,false);
+        if assigned(lefttemp) then
+          begin
+            assignmenttarget:=ctemprefnode.create(lefttemp);
+            typecheckpass(tnode(assignmenttarget));
+          end
+        else
+          assignmenttarget:=tcallparanode(left).left.getcopy;
+        newparas:=left;
+        left:=nil;
+        finaltype:=jvmarrtype_setlength(eledef);
+        { since the setlength prototypes require certain types, insert
+          explicit type conversions where necessary }
+        objarraydef:=nil;
+        if (ndims>1) then
+          begin
+            { expects array of JLObject }
+            setlenroutine:='FPC_SETLENGTH_DYNARR_MULTIDIM';
+            objarraydef:=search_system_type('TJOBJECTARRAY').typedef
+          end
+        else
+          begin
+            case finaltype of
+              'R':
+                begin
+                  { expects array of FpcBaseRecord}
+                  setlenroutine:='FPC_SETLENGTH_DYNARR_JRECORD';
+                  objarraydef:=search_system_type('TJRECORDARRAY').typedef;
+                end;
+              'T':
+                begin
+                  { expects array of ShortstringClass}
+                  setlenroutine:='FPC_SETLENGTH_DYNARR_JSHORTSTRING';
+                  objarraydef:=search_system_type('TSHORTSTRINGARRAY').typedef;
+                end;
+              else
+                begin
+                  { expects JLObject }
+                  setlenroutine:='FPC_SETLENGTH_DYNARR_GENERIC';
+                  objarraydef:=java_jlobject;
+                end
+              end;
+          end;
+        tcallparanode(newparas).left:=ctypeconvnode.create_explicit(tcallparanode(newparas).left,objarraydef);
+        newnode:=ctypeconvnode.create_explicit(newnode,objarraydef);
+        { prepend new }
+        newparas:=ccallparanode.create(newnode,newparas);
+        { prepend deepcopy }
+        newparas:=ccallparanode.create(cordconstnode.create(0,pasbool8type,false),newparas);
+        { call the right setlenght helper }
+        if ndims>1 then
+          begin
+            { create proper parameters, from right to left:
+               eletype=finaltype, ndim=ndims, deepcopy=false, new=newnode,
+               assignmenttarget=tcallparanode(left).left }
+            { prepend ndim }
+            newparas:=ccallparanode.create(cordconstnode.create(ndims,s32inttype,false),newparas);
+            { prepend eletype }
+            newparas:=ccallparanode.create(cordconstnode.create(ord(finaltype),cwidechartype,false),newparas);
+          end
+        else
+          begin
+            { create proper parameters, from right to left:
+               deepcopy=false, new=newnode, assignmenttarget=tcallparnode(left).left
+              -> already done in common part above }
+          end;
+        result:=ccallnode.createintern(setlenroutine,newparas);
+        { assign result back to org (no call-by-reference for Java) }
+        result:=cassignmentnode.create(assignmenttarget,
+          ctypeconvnode.create_explicit(result,assignmenttarget.resultdef));
+        if assigned(lefttemp) then
+          begin
+            addstatement(newstatement,result);
+            addstatement(newstatement,ctempdeletenode.create(lefttemp));
+            result:=newblock;
+          end;
+      end;
+
+
+    function tjvminlinenode.first_setlength: tnode;
+      begin
+        { reverse the parameter order so we can process them more easily }
+        left:=reverseparameters(tcallparanode(left));
+        { treat setlength(x,0) specially: used to init uninitialised locations }
+        if not is_shortstring(left.resultdef) and
+           not assigned(tcallparanode(tcallparanode(left).right).right) and
+           is_constintnode(tcallparanode(tcallparanode(left).right).left) and
+           (tordconstnode(tcallparanode(tcallparanode(left).right).left).value=0) then
+          begin
+            result:=nil;
+            expectloc:=LOC_VOID;
+            exit;
+          end;
+        { strings are handled the same as on other platforms }
+        if left.resultdef.typ=stringdef then
+          begin
+            left:=reverseparameters(tcallparanode(left));
+            result:=inherited first_setlength;
+            exit;
+          end;
+        case left.resultdef.typ of
+          arraydef:
+            result:=first_setlength_array;
+          else
+            internalerror(2011031204);
+        end;
+      end;
+
+
+    function tjvminlinenode.first_length: tnode;
+      var
+        newblock: tblocknode;
+        newstatement: tstatementnode;
+        lefttemp,
+        lentemp: ttempcreatenode;
+        ifcond,
+        stringtemp,
+        stringnonnull,
+        stringnull: tnode;
+        psym: tsym;
+        stringclass: tdef;
+      begin
+        if is_wide_or_unicode_string(left.resultdef) or
+           is_ansistring(left.resultdef) then
+          begin
+            { if assigned(stringclass(left)) then
+                lentemp:=stringclass(left).length()
+              else
+                lentemp:=0;
+              --> return lentemp
+            }
+            if is_ansistring(left.resultdef) then
+              stringclass:=java_ansistring
+            else
+              stringclass:=java_jlstring;
+            newblock:=internalstatements(newstatement);
+            { store left into a temp since it may contain a function call
+              (which must not be evaluated twice) }
+            if node_complexity(left)>4 then
+              begin
+                lefttemp:=ctempcreatenode.create_value(stringclass,stringclass.size,tt_persistent,true,ctypeconvnode.create_explicit(left,stringclass));
+                addstatement(newstatement,lefttemp);
+                stringtemp:=ctemprefnode.create(lefttemp)
+              end
+            else
+              begin
+                lefttemp:=nil;
+                stringtemp:=left;
+              end;
+            left:=nil;
+            lentemp:=ctempcreatenode.create(s32inttype,s32inttype.size,tt_persistent,true);
+            addstatement(newstatement,lentemp);
+            { if-condition: assigned(stringclass(stringvar))? }
+            ifcond:=cinlinenode.create(in_assigned_x,false,
+              ccallparanode.create(stringtemp.getcopy,nil));
+            { then-path: call length() method }
+            psym:=search_struct_member(tabstractrecorddef(stringclass),'LENGTH');
+            if not assigned(psym) or
+               (psym.typ<>procsym) then
+              internalerror(2011031403);
+            stringnonnull:=cassignmentnode.create(
+              ctemprefnode.create(lentemp),
+              ccallnode.create(nil,tprocsym(psym),psym.owner,stringtemp,[]));
+            { else-path: length is 0 }
+            stringnull:=cassignmentnode.create(
+              ctemprefnode.create(lentemp),
+              genintconstnode(0));
+            { complete if-statement }
+            addstatement(newstatement,cifnode.create(ifcond,stringnonnull,stringnull));
+            { free lefttemp }
+            if assigned(lefttemp) then
+              addstatement(newstatement,ctempdeletenode.create(lefttemp));
+            { return len temp }
+            addstatement(newstatement,ctempdeletenode.create_normal_temp(lentemp));
+            addstatement(newstatement,ctemprefnode.create(lentemp));
+            result:=newblock;
+          end
+        else if is_shortstring(left.resultdef) then
+          begin
+            psym:=search_struct_member(tabstractrecorddef(java_shortstring),'LENGTH');
+            if not assigned(psym) or
+               (psym.typ<>procsym) then
+              internalerror(2011052402);
+            result:=
+              ccallnode.create(nil,tprocsym(psym),psym.owner,
+                ctypeconvnode.create_explicit(caddrnode.create_internal(left),java_shortstring),[]);
+            { reused }
+            left:=nil;
+          end
+        { should be no other string types }
+        else if left.resultdef.typ=stringdef then
+          internalerror(2011052403)
+       else
+         result:=inherited first_length;
+      end;
+
+
+    procedure tjvminlinenode.second_length;
+      begin
+        if is_dynamic_array(left.resultdef) or
+           is_open_array(left.resultdef) then
+          begin
+            location_reset(location,LOC_REGISTER,OS_S32);
+            location.register:=hlcg.getintregister(current_asmdata.CurrAsmList,s32inttype);
+            secondpass(left);
+            thlcgjvm(hlcg).g_getarraylen(current_asmdata.CurrAsmList,left.location);
+            thlcgjvm(hlcg).a_load_stack_reg(current_asmdata.CurrAsmList,resultdef,location.register);
+          end
+        else
+          internalerror(2011012004);
+      end;
+
+(*
+     function tjvminlinenode.first_round_real : tnode;
+      begin
+       if (current_settings.cputype >= cpu_PPC970) then
+          begin
+            expectloc:=LOC_REFERENCE;
+            first_round_real := nil;
+          end
+        else
+          result:=inherited first_round_real;
+      end;
+*)
+
+     { load the FPU value on the evaluation stack }
+     procedure tjvminlinenode.load_fpu_location;
+       begin
+         secondpass(left);
+         thlcgjvm(hlcg).a_load_loc_stack(current_asmdata.CurrAsmList,left.resultdef,left.location);
+       end;
+
+(*
+    procedure tjvminlinenode.second_sqrt_real;
+      begin
+        if (current_settings.cputype < cpu_PPC970) then
+          internalerror(2007020910);
+        location.loc:=LOC_FPUREGISTER;
+        load_fpu_location;
+        case left.location.size of
+          OS_F32:
+            current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg(A_FSQRTS,location.register,
+              left.location.register));
+          OS_F64:
+            current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg(A_FSQRT,location.register,
+              left.location.register));
+          else
+            inherited;
+        end;
+      end;
+*)
+
+     procedure tjvminlinenode.second_sqr_real;
+       begin
+         load_fpu_location;
+         location_reset(location,LOC_FPUREGISTER,location.size);
+         location.register:=hlcg.getfpuregister(current_asmdata.CurrAsmList,resultdef);
+         case left.location.size of
+           OS_F32:
+             begin
+               current_asmdata.CurrAsmList.concat(taicpu.op_none(a_dup));
+               thlcgjvm(hlcg).incstack(current_asmdata.CurrAsmList,1);
+               current_asmdata.CurrAsmList.concat(taicpu.op_none(a_fmul));
+               thlcgjvm(hlcg).decstack(current_asmdata.CurrAsmList,1);
+             end;
+           OS_F64:
+             begin
+               current_asmdata.CurrAsmList.concat(taicpu.op_none(a_dup2));
+               thlcgjvm(hlcg).incstack(current_asmdata.CurrAsmList,2);
+               current_asmdata.CurrAsmList.concat(taicpu.op_none(a_dmul));
+               thlcgjvm(hlcg).decstack(current_asmdata.CurrAsmList,2);
+             end;
+           else
+             internalerror(2011010804);
+         end;
+         thlcgjvm(hlcg).a_load_stack_reg(current_asmdata.CurrAsmList,resultdef,location.register);
+       end;
+
+
+    procedure tjvminlinenode.second_trunc_real;
+      begin
+         load_fpu_location;
+         location_reset(location,LOC_REGISTER,left.location.size);
+         location.register:=hlcg.getintregister(current_asmdata.CurrAsmList,resultdef);
+         case left.location.size of
+           OS_F32:
+             begin
+               current_asmdata.CurrAsmList.concat(taicpu.op_none(a_f2l));
+               { 32 bit float -> 64 bit int: +1 stack slot }
+               thlcgjvm(hlcg).incstack(current_asmdata.CurrAsmList,1);
+             end;
+           OS_F64:
+             begin
+               { 64 bit float -> 64 bit int: same number of stack slots }
+               current_asmdata.CurrAsmList.concat(taicpu.op_none(a_d2l));
+             end;
+           else
+             internalerror(2011010805);
+         end;
+         thlcgjvm(hlcg).a_load_stack_reg(current_asmdata.CurrAsmList,resultdef,location.register);
+      end;
+
+
+    procedure tjvminlinenode.second_new;
+      var
+        arr: tnode;
+        hp: tcallparanode;
+        paracount: longint;
+      begin
+        hp:=tcallparanode(left);
+        { we don't second pass this one, it's only a type node }
+        arr:=hp.left;
+        if not is_dynamic_array(arr.resultdef) then
+          internalerror(2011012204);
+        hp:=tcallparanode(hp.right);
+        if not assigned(hp) then
+          internalerror(2011012205);
+        paracount:=0;
+        { put all the dimensions on the stack }
+        repeat
+          inc(paracount);
+          secondpass(hp.left);
+          thlcgjvm(hlcg).a_load_loc_stack(current_asmdata.CurrAsmList,hp.left.resultdef,hp.left.location);
+          hp:=tcallparanode(hp.right);
+        until not assigned(hp);
+        { create the array }
+        thlcgjvm(hlcg).g_newarray(current_asmdata.CurrAsmList,arr.resultdef,paracount);
+        location_reset(location,LOC_REGISTER,OS_ADDR);
+        location.register:=hlcg.getaddressregister(current_asmdata.CurrAsmList,resultdef);
+        thlcgjvm(hlcg).a_load_stack_reg(current_asmdata.CurrAsmList,arr.resultdef,location.register);
+      end;
+
+
+    procedure tjvminlinenode.second_setlength;
+      var
+        target: tnode;
+        lenpara: tnode;
+        emptystr: ansichar;
+        tmpreg: tregister;
+      begin
+        target:=tcallparanode(left).left;
+        lenpara:=tcallparanode(tcallparanode(left).right).left;
+        if assigned(tcallparanode(tcallparanode(left).right).right) or
+           not is_constintnode(lenpara) or
+           (tordconstnode(lenpara).value<>0) then
+          internalerror(2011031801);
+
+        secondpass(target);
+        { can't directly load from stack to destination, because if target is
+          a reference then its address must be placed on the stack before the
+          value }
+        tmpreg:=hlcg.getaddressregister(current_asmdata.CurrAsmList,target.resultdef);
+        if is_wide_or_unicode_string(target.resultdef) then
+          begin
+            emptystr:=#0;
+            current_asmdata.CurrAsmList.concat(taicpu.op_string(a_ldc,0,@emptystr));
+            thlcgjvm(hlcg).incstack(current_asmdata.CurrAsmList,1);
+          end
+        else if is_ansistring(target.resultdef) then
+          thlcgjvm(hlcg).a_load_const_stack(current_asmdata.CurrAsmList,java_jlobject,0,R_ADDRESSREGISTER)
+        else if is_dynamic_array(target.resultdef) then
+          begin
+            thlcgjvm(hlcg).a_load_const_stack(current_asmdata.CurrAsmList,s32inttype,0,R_INTREGISTER);
+            thlcgjvm(hlcg).g_newarray(current_asmdata.CurrAsmList,target.resultdef,1);
+          end
+        else
+          internalerror(2011031401);
+        thlcgjvm(hlcg).a_load_stack_reg(current_asmdata.CurrAsmList,target.resultdef,tmpreg);
+        thlcgjvm(hlcg).a_load_reg_loc(current_asmdata.CurrAsmList,target.resultdef,target.resultdef,tmpreg,target.location);
+      end;
+
+
+begin
+   cinlinenode:=tjvminlinenode;
+end.

compiler/jvm/njvmld.pas

@@ -0,0 +1,329 @@
+{
+    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
+  globtype,
+  aasmdata,
+  symtype,
+  cgutils,
+  node, ncgld, ncgnstld;
+
+type
+  tjvmloadnode = class(tcgnestloadnode)
+   protected
+    function is_copyout_addr_param_load: boolean;
+    function handle_threadvar_access: tnode; override;
+    function keep_param_address_in_nested_struct: boolean; override;
+   public
+    function is_addr_param_load: boolean; override;
+    procedure pass_generate_code; override;
+  end;
+
+  tjvmassignmentnode  = class(tcgassignmentnode)
+   protected
+    function direct_shortstring_assignment: boolean; override;
+    function maybechangetemp(list: TAsmList; var n: tnode; const newref: treference): boolean;override;
+   public
+    function pass_1: tnode; override;
+  end;
+
+  tjvmarrayconstructornode = class(tcgarrayconstructornode)
+   protected
+    procedure makearrayref(var ref: treference; eledef: tdef); override;
+    procedure advancearrayoffset(var ref: treference; elesize: asizeint); override;
+    procedure wrapmanagedvarrec(var n: tnode);override;
+  end;
+
+implementation
+
+uses
+  verbose,globals,
+  nbas,nld,ncal,ncon,ninl,nmem,ncnv,
+  symconst,symsym,symdef,symtable,defutil,jvmdef,
+  paramgr,
+  pass_1,
+  cgbase,hlcgobj,cpuinfo;
+
+{ tjvmassignmentnode }
+
+function tjvmassignmentnode.direct_shortstring_assignment: boolean;
+  begin
+    if maybe_find_real_class_definition(right.resultdef,false)=java_jlstring then
+      inserttypeconv_explicit(right,cunicodestringtype);
+    result:=right.resultdef.typ=stringdef;
+  end;
+
+
+function tjvmassignmentnode.maybechangetemp(list: TAsmList; var n: tnode; const newref: treference): boolean;
+  begin
+    { don't do this when compiling for Dalvik, because it can invalidate the
+      debug information (which Dalvik uses as extra type information) }
+    if current_settings.cputype<>cpu_dalvik then
+      result:=inherited
+    else
+      result:=false;
+  end;
+
+
+function tjvmassignmentnode.pass_1: tnode;
+  var
+    block: tblocknode;
+    tempn: ttempcreatenode;
+    stat: tstatementnode;
+    target: tnode;
+    psym: tsym;
+  begin
+    { intercept writes to string elements, because Java strings are immutable
+      -> detour via StringBuilder
+    }
+    target:=left.actualtargetnode;
+    if (target.nodetype=vecn) and
+       (is_wide_or_unicode_string(tvecnode(target).left.resultdef) or
+        is_ansistring(tvecnode(target).left.resultdef)) then
+      begin
+        { prevent errors in case of an expression such as
+            word(str[x]):=1234;
+        }
+        inserttypeconv_explicit(right,cwidechartype);
+        result:=ccallnode.createintern('fpc_'+tstringdef(tvecnode(target).left.resultdef).stringtypname+'_setchar',
+          ccallparanode.create(right,
+            ccallparanode.create(tvecnode(target).right,
+              ccallparanode.create(tvecnode(target).left.getcopy,nil))));
+        result:=cassignmentnode.create(tvecnode(target).left,result);
+        right:=nil;
+        tvecnode(target).left:=nil;
+        tvecnode(target).right:=nil;
+        exit;
+      end
+    else if (target.nodetype=vecn) and
+       is_shortstring(tvecnode(target).left.resultdef) then
+      begin
+        { prevent errors in case of an expression such as
+            byte(str[x]):=12;
+        }
+        inserttypeconv_explicit(right,cansichartype);
+        { call ShortstringClass(@shortstring).setChar(index,char) }
+        tvecnode(target).left:=caddrnode.create_internal(tvecnode(target).left);
+        { avoid useless typecheck when casting to shortstringclass }
+        include(tvecnode(target).left.flags,nf_typedaddr);
+        inserttypeconv_explicit(tvecnode(target).left,java_shortstring);
+        psym:=search_struct_member(tabstractrecorddef(java_shortstring),'SETCHAR');
+        if not assigned(psym) or
+           (psym.typ<>procsym) then
+          internalerror(2011052408);
+        result:=
+          ccallnode.create(
+            ccallparanode.create(right,
+              ccallparanode.create(tvecnode(target).right,nil)),
+            tprocsym(psym),psym.owner,tvecnode(target).left,[]);
+        right:=nil;
+        tvecnode(target).left:=nil;
+        tvecnode(target).right:=nil;
+        exit;
+      end
+    else if target.resultdef.typ=formaldef then
+      begin
+        if right.resultdef.typ in [orddef,floatdef] then
+          right:=cinlinenode.create(in_box_x,false,right)
+        else if jvmimplicitpointertype(right.resultdef) then
+          begin
+            { we have to assign the address of a deep copy of the type to the
+              object in the formalpara -> create a temp, assign the value to
+              the temp, then assign the address in the temp to the para }
+            block:=internalstatements(stat);
+            tempn:=ctempcreatenode.create_value(right.resultdef,right.resultdef.size,
+              tt_persistent,false,right);
+            addstatement(stat,tempn);
+            right:=caddrnode.create(ctemprefnode.create(tempn));
+            inserttypeconv_explicit(right,java_jlobject);
+            addstatement(stat,ctempdeletenode.create_normal_temp(tempn));
+            addstatement(stat,ctypeconvnode.create_explicit(
+              caddrnode.create(ctemprefnode.create(tempn)),java_jlobject));
+            right:=block;
+          end;
+        typecheckpass(right);
+        result:=inherited;
+        exit;
+      end
+    else
+      result:=inherited;
+  end;
+
+
+function tjvmloadnode.is_copyout_addr_param_load: boolean;
+  begin
+    result:=
+      { passed via array of one element }
+      ((symtable.symtabletype=parasymtable) and
+       (symtableentry.typ=paravarsym) and
+       paramanager.push_copyout_param(tparavarsym(symtableentry).varspez,resultdef,tprocdef(symtable.defowner).proccalloption));
+  end;
+
+
+function tjvmloadnode.handle_threadvar_access: tnode;
+  var
+    vs: tsym;
+  begin
+    { get the variable wrapping the threadvar }
+    vs:=tsym(symtable.find(symtableentry.name+'$THREADVAR'));
+    if not assigned(vs) or
+       (vs.typ<>staticvarsym) then
+      internalerror(2011082201);
+    { get a read/write reference to the threadvar value }
+    result:=cloadnode.create(vs,vs.owner);
+    typecheckpass(result);
+    result:=ccallnode.createinternmethod(result,'GETREADWRITEREFERENCE',nil);
+    if not(tstaticvarsym(symtableentry).vardef.typ in [orddef,floatdef]) and
+       not jvmimplicitpointertype(tstaticvarsym(symtableentry).vardef) then
+      begin
+        { in these cases, the threadvar was internally constructed as an
+          "array of jlobject", while the variable itself is a different kind of
+          pointer (dynarmic array, class, interface, pointer type). We cannot
+          typecast an "array of jlobject" to e.g. an "array of array of byte",
+          even if all elements inside the array are "array of byte" (since the
+          outer array type is simply different) -> first dereference (= select
+          the array element) and then typecast to the result type. This works
+          even on the left-hand side because then we get e.g.
+            jlobject(threavarinstance.getreadwritereference^):=value;
+
+          threavarinstance.getreadwritereference returns a ppointer in these
+          cases.
+        }
+        result:=cderefnode.create(result);
+        result:=ctypeconvnode.create_explicit(result,resultdef);
+      end
+    else
+      begin
+        result:=ctypeconvnode.create_explicit(result,getpointerdef(resultdef));
+        result:=cderefnode.create(result);
+      end;
+  end;
+
+
+function tjvmloadnode.keep_param_address_in_nested_struct: boolean;
+  begin
+    { we don't need an extra load when implicit pointer types  are passed as
+      var/out/constref parameter (since they are already pointers). However,
+      when transfering them into a nestedfp struct, we do want to transfer the
+      pointer and not make a deep copy in case they are var/out/constref (since
+      changes made to the var/out parameter should propagate up) }
+    result:=
+     is_addr_param_load or
+     ((symtableentry.typ=paravarsym) and
+      jvmimplicitpointertype(tparavarsym(symtableentry).vardef) and
+      (tparavarsym(symtableentry).varspez in [vs_var,vs_constref,vs_out]));
+  end;
+
+
+function tjvmloadnode.is_addr_param_load: boolean;
+  begin
+    result:=
+      (inherited is_addr_param_load and
+       not jvmimplicitpointertype(tparavarsym(symtableentry).vardef) and
+       (tparavarsym(symtableentry).vardef.typ<>formaldef)) or
+      is_copyout_addr_param_load;
+  end;
+
+
+procedure tjvmloadnode.pass_generate_code;
+  begin
+    if is_copyout_addr_param_load then
+      begin
+        { in case of nested access, load address of field in nestedfpstruct }
+        if assigned(left) then
+          generate_nested_access(tabstractnormalvarsym(symtableentry));
+        location_reset_ref(location,LOC_REFERENCE,def_cgsize(resultdef),4);
+        location.reference.arrayreftype:=art_indexconst;
+        location.reference.base:=hlcg.getaddressregister(current_asmdata.CurrAsmList,java_jlobject);
+        location.reference.indexoffset:=0;
+        { load the field from the nestedfpstruct, or the parameter location.
+          In both cases, the result is an array of one element containing the
+          parameter value }
+        if assigned(left) then
+          hlcg.a_load_loc_reg(current_asmdata.CurrAsmList,java_jlobject,java_jlobject,left.location,location.reference.base)
+        else
+          hlcg.a_load_loc_reg(current_asmdata.CurrAsmList,java_jlobject,java_jlobject,tparavarsym(symtableentry).localloc,location.reference.base);
+      end
+    else if symtableentry.typ=procsym then
+      { handled in tjvmcnvnode.first_proc_to_procvar }
+      internalerror(2011072408)
+    else
+      inherited pass_generate_code;
+  end;
+
+
+{ tjvmarrayconstructornode }
+
+procedure tjvmarrayconstructornode.makearrayref(var ref: treference; eledef: tdef);
+  var
+    basereg: tregister;
+  begin
+    { arrays are implicitly dereferenced }
+    basereg:=hlcg.getaddressregister(current_asmdata.CurrAsmList,java_jlobject);
+    hlcg.a_load_ref_reg(current_asmdata.CurrAsmList,java_jlobject,java_jlobject,ref,basereg);
+    reference_reset_base(ref,basereg,0,1);
+    ref.arrayreftype:=art_indexconst;
+    ref.indexoffset:=0;
+  end;
+
+
+procedure tjvmarrayconstructornode.advancearrayoffset(var ref: treference; elesize: asizeint);
+  begin
+    inc(ref.indexoffset);
+  end;
+
+
+procedure tjvmarrayconstructornode.wrapmanagedvarrec(var n: tnode);
+  var
+    varrecdef: trecorddef;
+    block: tblocknode;
+    stat: tstatementnode;
+    temp: ttempcreatenode;
+  begin
+    varrecdef:=trecorddef(search_system_type('TVARREC').typedef);
+    block:=internalstatements(stat);
+    temp:=ctempcreatenode.create(varrecdef,varrecdef.size,tt_persistent,false);
+    addstatement(stat,temp);
+    addstatement(stat,
+      ccallnode.createinternmethod(
+        ctemprefnode.create(temp),'INIT',ccallparanode.create(n,nil)));
+    { note: this will not free the record contents, but just let its reference
+      on the stack be reused -- which is ok, because the reference will be
+      stored into the open array parameter }
+    addstatement(stat,ctempdeletenode.create_normal_temp(temp));
+    addstatement(stat,ctemprefnode.create(temp));
+    n:=block;
+    firstpass(n);
+  end;
+
+
+begin
+  cloadnode:=tjvmloadnode;
+  cassignmentnode:=tjvmassignmentnode;
+  carrayconstructornode:=tjvmarrayconstructornode;
+end.
+

compiler/jvm/njvmmat.pas

@@ -0,0 +1,225 @@
+{
+    Copyright (c) 1998-2011 by Florian Klaempfl and Jonas Maebe
+
+    Generate JVM code for math nodes
+
+    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 njvmmat;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+      node,nmat,ncgmat;
+
+    type
+      tjvmmoddivnode = class(tmoddivnode)
+        protected
+          function use_moddiv64bitint_helper: boolean; override;
+        public
+         procedure pass_generate_code;override;
+      end;
+
+      tjvmshlshrnode = class(tshlshrnode)
+         procedure pass_generate_code;override;
+      end;
+
+      tjvmnotnode = class(tcgnotnode)
+         function pass_1: tnode; override;
+         procedure second_boolean;override;
+      end;
+
+      tjvmunaryminusnode = class(tcgunaryminusnode)
+        procedure second_float;override;
+      end;
+
+implementation
+
+    uses
+      globtype,systems,constexp,
+      cutils,verbose,globals,
+      symconst,symdef,
+      aasmbase,aasmcpu,aasmtai,aasmdata,
+      defutil,
+      cgbase,cgobj,pass_2,procinfo,
+      ncon,
+      cpubase,
+      hlcgobj,hlcgcpu,cgutils;
+
+{*****************************************************************************
+                             tjvmmoddivnode
+*****************************************************************************}
+
+    function tjvmmoddivnode.use_moddiv64bitint_helper: boolean;
+      begin
+        result:=
+          (left.resultdef.typ=orddef) and
+          (right.resultdef.typ=orddef) and
+          ((torddef(left.resultdef).ordtype=u64bit) or
+           (torddef(right.resultdef).ordtype=u64bit));
+      end;
+
+
+    procedure tjvmmoddivnode.pass_generate_code;
+      var
+        op: topcg;
+        isu32int: boolean;
+      begin
+         secondpass(left);
+         secondpass(right);
+         location_reset(location,LOC_REGISTER,left.location.size);
+         location.register:=hlcg.getintregister(current_asmdata.CurrAsmList,resultdef);
+
+
+        if nodetype=divn then
+          begin
+            { TODO: overflow checking in case of high(longint) or high(int64) div -1 }
+            thlcgjvm(hlcg).a_load_loc_stack(current_asmdata.CurrAsmList,left.resultdef,left.location);
+            if is_signed(resultdef) then
+              op:=OP_IDIV
+            else
+              op:=OP_DIV;
+            thlcgjvm(hlcg).a_op_loc_stack(current_asmdata.CurrAsmList,op,right.resultdef,right.location)
+          end
+        else
+          begin
+            { must be handled via a helper }
+            if torddef(resultdef).ordtype=u64bit then
+              internalerror(2011010416);
+            if (torddef(resultdef).ordtype<>u32bit) then
+              begin
+                isu32int:=false;
+                thlcgjvm(hlcg).a_load_loc_stack(current_asmdata.CurrAsmList,left.resultdef,left.location);
+                thlcgjvm(hlcg).a_load_loc_stack(current_asmdata.CurrAsmList,right.resultdef,right.location);
+              end
+            else
+              begin
+                isu32int:=true;
+                if left.location.loc=LOC_CONSTANT then
+                  thlcgjvm(hlcg).a_load_const_stack(current_asmdata.CurrAsmList,s64inttype,left.location.value,R_INTREGISTER)
+                else
+                  begin
+                    thlcgjvm(hlcg).a_load_loc_stack(current_asmdata.CurrAsmList,left.resultdef,left.location);
+                    thlcgjvm(hlcg).resize_stack_int_val(current_asmdata.CurrAsmList,u32inttype,s64inttype,false);
+                  end;
+                if right.location.loc=LOC_CONSTANT then
+                  thlcgjvm(hlcg).a_load_const_stack(current_asmdata.CurrAsmList,s64inttype,right.location.value,R_INTREGISTER)
+                else
+                  begin
+                    thlcgjvm(hlcg).a_load_loc_stack(current_asmdata.CurrAsmList,right.resultdef,right.location);
+                    thlcgjvm(hlcg).resize_stack_int_val(current_asmdata.CurrAsmList,u32inttype,s64inttype,false);
+                  end;
+              end;
+            if isu32int or
+               (torddef(resultdef).ordtype=s64bit) then
+              begin
+                current_asmdata.CurrAsmList.concat(taicpu.op_none(a_lrem));
+                thlcgjvm(hlcg).decstack(current_asmdata.CurrAsmList,2);
+              end
+            else
+              begin
+                current_asmdata.CurrAsmList.concat(taicpu.op_none(a_irem));
+                thlcgjvm(hlcg).decstack(current_asmdata.CurrAsmList,1);
+              end;
+            if isu32int then
+              thlcgjvm(hlcg).resize_stack_int_val(current_asmdata.CurrAsmList,s64inttype,u32inttype,false);
+          end;
+         thlcgjvm(hlcg).a_load_stack_reg(current_asmdata.CurrAsmList,resultdef,location.register);
+      end;
+
+
+{*****************************************************************************
+                             tjvmshlshrnode
+*****************************************************************************}
+
+    procedure tjvmshlshrnode.pass_generate_code;
+      var
+        op : topcg;
+      begin
+        secondpass(left);
+        secondpass(right);
+        location_reset(location,LOC_REGISTER,left.location.size);
+        location.register:=hlcg.getintregister(current_asmdata.CurrAsmList,resultdef);
+
+        thlcgjvm(hlcg).a_load_loc_stack(current_asmdata.CurrAsmList,left.resultdef,left.location);
+        if nodetype=shln then
+          op:=OP_SHL
+        else
+          op:=OP_SHR;
+        thlcgjvm(hlcg).a_op_loc_stack(current_asmdata.CurrAsmList,op,resultdef,right.location);
+        thlcgjvm(hlcg).a_load_stack_reg(current_asmdata.CurrAsmList,resultdef,location.register);
+      end;
+
+
+{*****************************************************************************
+                               tjvmnotnode
+*****************************************************************************}
+
+    function tjvmnotnode.pass_1: tnode;
+      begin
+        result:=inherited;
+        if not assigned(result) and
+           is_boolean(resultdef) then
+          expectloc:=LOC_JUMP;
+      end;
+
+
+    procedure tjvmnotnode.second_boolean;
+      var
+        hl : tasmlabel;
+      begin
+        hl:=current_procinfo.CurrTrueLabel;
+        current_procinfo.CurrTrueLabel:=current_procinfo.CurrFalseLabel;
+        current_procinfo.CurrFalseLabel:=hl;
+        secondpass(left);
+        hlcg.maketojumpbool(current_asmdata.CurrAsmList,left);
+        hl:=current_procinfo.CurrTrueLabel;
+        current_procinfo.CurrTrueLabel:=current_procinfo.CurrFalseLabel;
+        current_procinfo.CurrFalseLabel:=hl;
+        location.loc:=LOC_JUMP;
+      end;
+
+
+{*****************************************************************************
+                            tjvmunaryminustnode
+*****************************************************************************}
+
+    procedure tjvmunaryminusnode.second_float;
+      var
+        opc: tasmop;
+      begin
+        secondpass(left);
+        location_reset(location,LOC_FPUREGISTER,def_cgsize(resultdef));
+        location.register:=hlcg.getfpuregister(current_asmdata.CurrAsmList,resultdef);
+        thlcgjvm(hlcg).a_load_loc_stack(current_asmdata.CurrAsmList,left.resultdef,left.location);
+        if (tfloatdef(left.resultdef).floattype=s32real) then
+          opc:=a_fneg
+        else
+          opc:=a_dneg;
+        current_asmdata.CurrAsmList.concat(taicpu.op_none(opc));
+        thlcgjvm(hlcg).a_load_stack_reg(current_asmdata.CurrAsmList,resultdef,location.register);
+      end;
+
+
+begin
+   cmoddivnode:=tjvmmoddivnode;
+   cshlshrnode:=tjvmshlshrnode;
+   cnotnode:=tjvmnotnode;
+   cunaryminusnode:=tjvmunaryminusnode;
+end.

compiler/jvm/njvmmem.pas

@@ -0,0 +1,476 @@
+{
+    Copyright (c) 2011 by Jonas Maebe
+
+    Generate JVM byetcode for in memory related nodes
+
+    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 njvmmem;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+      globtype,
+      cgbase,cpubase,
+      node,nmem,ncgmem,ncgnstmm;
+
+    type
+       tjvmaddrnode = class(tcgaddrnode)
+        protected
+         function isrefparaload: boolean;
+         function isarrayele0load: boolean;
+         function isdererence: boolean;
+        public
+         function pass_typecheck: tnode; override;
+         procedure pass_generate_code; override;
+       end;
+
+       tjvmderefnode = class(tcgderefnode)
+          function pass_typecheck: tnode; override;
+          procedure pass_generate_code; override;
+       end;
+
+       tjvmloadvmtaddrnode = class(tcgloadvmtaddrnode)
+         procedure pass_generate_code; override;
+       end;
+
+       tjvmvecnode = class(tcgvecnode)
+         function pass_1: tnode; override;
+         procedure pass_generate_code;override;
+       end;
+
+implementation
+
+    uses
+      systems,globals,procinfo,
+      cutils,verbose,constexp,
+      aasmbase,
+      symconst,symtype,symtable,symsym,symdef,defutil,jvmdef,
+      htypechk,paramgr,
+      nadd,ncal,ncnv,ncon,nld,pass_1,njvmcon,
+      aasmdata,aasmcpu,pass_2,
+      cgutils,hlcgobj,hlcgcpu;
+
+{*****************************************************************************
+                              TJVMDEREFNODE
+*****************************************************************************}
+
+    function tjvmderefnode.pass_typecheck: tnode;
+      begin
+        result:=inherited pass_typecheck;
+        if assigned(result) then
+          exit;
+        { don't allow dereferencing untyped pointers, because how this has to
+          be done depends on whether it's a pointer to an implicit pointer type
+          or not }
+        if is_voidpointer(left.resultdef) then
+          CGMessage(parser_e_illegal_expression);
+      end;
+
+
+    procedure tjvmderefnode.pass_generate_code;
+      var
+        implicitptr: boolean;
+      begin
+        secondpass(left);
+        implicitptr:=jvmimplicitpointertype(resultdef);
+        if implicitptr then
+          begin
+            { this is basically a typecast: the left node is a regular
+              'pointer', and we typecast it to an implicit pointer }
+            location_copy(location,left.location);
+            { these implicit pointer types (records, sets, shortstrings, ...)
+              cannot be located in registers on native targets (since
+              they're not pointers there) -> force into memory to avoid
+              confusing the compiler; this can happen when typecasting a
+              Java class type into a pshortstring and then dereferencing etc
+            }
+            if location.loc in [LOC_REGISTER,LOC_CREGISTER] then
+              hlcg.location_force_mem(current_asmdata.CurrAsmList,location,left.resultdef);
+          end
+        else
+          begin
+            { these are always arrays (used internally for pointers to var
+              parameters stored in nestedfpstructs, and by programmers for any
+              kind of pointers) }
+            hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,left.resultdef,true);
+            location_reset_ref(location,LOC_REFERENCE,def_cgsize(resultdef),4);
+            reference_reset_base(location.reference,left.location.register,0,4);
+            location.reference.arrayreftype:=art_indexconst;
+            if (left.nodetype<>addrn) and
+               not(resultdef.typ in [orddef,floatdef]) and
+               not is_voidpointer(resultdef) and
+               ((resultdef.typ<>objectdef) or
+                (find_real_class_definition(tobjectdef(resultdef),false)<>java_jlobject)) then
+              location.reference.checkcast:=true;
+          end
+      end;
+
+{*****************************************************************************
+                              TJVMADDRNODE
+*****************************************************************************}
+
+    function tjvmaddrnode.isrefparaload: boolean;
+      begin
+        result:=
+         (left.nodetype=loadn) and
+         (tloadnode(left).symtableentry.typ=paravarsym) and
+         paramanager.push_copyout_param(tparavarsym(tloadnode(left).symtableentry).varspez,
+           left.resultdef,
+           tabstractprocdef(tloadnode(left).symtableentry.owner.defowner).proccalloption);
+      end;
+
+
+    function tjvmaddrnode.isarrayele0load: boolean;
+      begin
+        result:=
+          (left.nodetype=vecn) and
+          (tvecnode(left).left.resultdef.typ=arraydef) and
+          (tvecnode(left).right.nodetype=ordconstn) and
+          (tordconstnode(tvecnode(left).right).value=tarraydef(tvecnode(left).left.resultdef).lowrange);
+      end;
+
+
+    function tjvmaddrnode.isdererence: boolean;
+      var
+        target: tnode;
+      begin
+        target:=left.actualtargetnode;
+        result:=
+          (left.nodetype=derefn);
+      end;
+
+
+    function tjvmaddrnode.pass_typecheck: tnode;
+      var
+        fsym: tsym;
+      begin
+        result:=nil;
+        typecheckpass(left);
+        if codegenerror then
+         exit;
+
+        make_not_regable(left,[ra_addr_regable,ra_addr_taken]);
+
+        { in TP/Delphi, @procvar = contents of procvar and @@procvar =
+          address of procvar. In case of a procedure of object, this works
+          by letting the first addrnode typecast the procvar into a tmethod
+          record followed by subscripting its "code" field (= first field),
+          and if there's a second addrnode then it takes the address of
+          this code field (which is hence also the address of the procvar).
+
+          In Java, such ugly hacks don't work -> replace first addrnode
+          with getting procvar.method.code, and second addrnode with
+          the class for procedure of object}
+        if not(nf_internal in flags) and
+           ((m_tp_procvar in current_settings.modeswitches) or
+            (m_mac_procvar in current_settings.modeswitches)) and
+           (((left.nodetype=addrn) and
+             (taddrnode(left).left.resultdef.typ=procvardef)) or
+            (left.resultdef.typ=procvardef)) then
+          begin
+            if (left.nodetype=addrn) and
+               (taddrnode(left).left.resultdef.typ=procvardef) then
+              begin
+                { double address -> pointer that is the address of the
+                  procvardef (don't allow for non-object procvars, as they
+                  aren't implicitpointerdefs) }
+                if not jvmimplicitpointertype(taddrnode(left).left.resultdef) then
+                  CGMessage(parser_e_illegal_expression)
+                else
+                  begin
+                    { an internal address node will observe "normal" address
+                      operator semantics (= take the actual address!) }
+                    result:=caddrnode.create_internal(taddrnode(left).left);
+                    result:=ctypeconvnode.create_explicit(result,tprocvardef(taddrnode(left).left.resultdef).classdef);
+                    taddrnode(left).left:=nil;
+                 end;
+              end
+            else if left.resultdef.typ=procvardef then
+              begin
+                if not tprocvardef(left.resultdef).is_addressonly then
+                  begin
+                    { the "code" field from the procvar }
+                    result:=caddrnode.create_internal(left);
+                    result:=ctypeconvnode.create_explicit(result,tprocvardef(left.resultdef).classdef);
+                    { procvarclass.method }
+                    fsym:=search_struct_member(tprocvardef(left.resultdef).classdef,'METHOD');
+                    if not assigned(fsym) or
+                       (fsym.typ<>fieldvarsym) then
+                      internalerror(2011072501);
+                    result:=csubscriptnode.create(fsym,result);
+                    { procvarclass.method.code }
+                    fsym:=search_struct_member(trecorddef(tfieldvarsym(fsym).vardef),'CODE');
+                    if not assigned(fsym) or
+                       (fsym.typ<>fieldvarsym) then
+                      internalerror(2011072502);
+                    result:=csubscriptnode.create(fsym,result);
+                    left:=nil
+                  end
+                else
+                  { convert contents to plain pointer }
+                  begin
+                    result:=ctypeconvnode.create_explicit(left,java_jlobject);
+                    include(result.flags,nf_load_procvar);
+                    left:=nil;
+                  end;
+              end
+            else
+              internalerror(2011072506);
+          end
+        else if (left.resultdef.typ=procdef) then
+          begin
+            result:=inherited;
+            exit;
+          end
+        else
+          begin
+            if not jvmimplicitpointertype(left.resultdef) then
+              begin
+                { allow taking the address of a copy-out parameter (it's an
+                  array reference), of the first element of an array and of a
+                  pointer derefence }
+                if not isrefparaload and
+                   not isarrayele0load and
+                   not isdererence then
+                  begin
+                    CGMessage(parser_e_illegal_expression);
+                    exit
+                  end;
+              end;
+            result:=inherited;
+          end;
+      end;
+
+
+    procedure tjvmaddrnode.pass_generate_code;
+      var
+        implicitptr: boolean;
+      begin
+        secondpass(left);
+        implicitptr:=jvmimplicitpointertype(left.resultdef);
+        if implicitptr then
+          { this is basically a typecast: the left node is an implicit
+            pointer, and we typecast it to a regular 'pointer'
+            (java.lang.Object) }
+          location_copy(location,left.location)
+        else
+          begin
+            { these are always arrays (used internally for pointers to var
+              parameters stored in nestedfpstructs) -> get base pointer to
+              array }
+            if (left.location.loc<>LOC_REFERENCE) or
+               (left.location.reference.arrayreftype<>art_indexconst) or
+               (left.location.reference.base=NR_NO) or
+               (left.location.reference.indexoffset<>0) or
+               assigned(left.location.reference.symbol) then
+              internalerror(2011060701);
+            location_reset(location,LOC_REGISTER,OS_ADDR);
+            location.register:=left.location.reference.base;
+          end;
+      end;
+
+{*****************************************************************************
+                         TJVMLOADVMTADDRNODE
+*****************************************************************************}
+
+    procedure tjvmloadvmtaddrnode.pass_generate_code;
+      begin
+        current_asmdata.CurrAsmList.concat(taicpu.op_sym(a_ldc,current_asmdata.RefAsmSymbol(
+          tabstractrecorddef(tclassrefdef(resultdef).pointeddef).jvm_full_typename(true))));
+        thlcgjvm(hlcg).incstack(current_asmdata.CurrAsmList,1);
+        location_reset(location,LOC_REGISTER,OS_ADDR);
+        location.register:=hlcg.getaddressregister(current_asmdata.CurrAsmList,resultdef);
+        thlcgjvm(hlcg).a_load_stack_reg(current_asmdata.CurrAsmList,resultdef,location.register);
+      end;
+
+
+{*****************************************************************************
+                             TJVMVECNODE
+*****************************************************************************}
+
+    function tjvmvecnode.pass_1: tnode;
+      var
+        psym: tsym;
+        stringclass: tdef;
+      begin
+        if (left.resultdef.typ=stringdef) then
+          begin
+            case tstringdef(left.resultdef).stringtype of
+              st_ansistring:
+                stringclass:=java_ansistring;
+              st_unicodestring,
+              st_widestring:
+                stringclass:=java_jlstring;
+              st_shortstring:
+                begin
+                  stringclass:=java_shortstring;
+                  left:=caddrnode.create_internal(left);
+                  { avoid useless typecheck when casting to shortstringclass }
+                  include(left.flags,nf_typedaddr);
+                end
+              else
+                internalerror(2011052407);
+            end;
+            psym:=search_struct_member(tabstractrecorddef(stringclass),'CHARAT');
+            if not assigned(psym) or
+               (psym.typ<>procsym) then
+              internalerror(2011031501);
+            { Pascal strings are 1-based, Java strings 0-based }
+            result:=ccallnode.create(ccallparanode.create(
+              caddnode.create(subn,right,genintconstnode(1)),nil),tprocsym(psym),
+              psym.owner,ctypeconvnode.create_explicit(left,stringclass),[]);
+            left:=nil;
+            right:=nil;
+            exit;
+          end
+        else
+          begin
+            { keep indices that are enum constants that way, rather than
+              transforming them into a load of the class instance that
+              represents this constant (since we then would have to extract
+              the int constant value again at run time anyway) }
+            if right.nodetype=ordconstn then
+              tjvmordconstnode(right).enumconstok:=true;
+            result:=inherited;
+          end;
+      end;
+
+
+    procedure tjvmvecnode.pass_generate_code;
+      var
+        otl,ofl: tasmlabel;
+        psym: tsym;
+        newsize: tcgsize;
+        isjump: boolean;
+      begin
+        if left.resultdef.typ=stringdef then
+          internalerror(2011052702);
+
+        { This routine is not used for Strings, as they are a class type and
+          you have to use charAt() there to load a character (and you cannot
+          change characters; you have to create a new string in that case)
+
+          As far as arrays are concerned: we have to create a trefererence
+          with arrayreftype in [art_indexreg,art_indexref], and ref.base =
+          pointer to the array (i.e., left.location.register) }
+        secondpass(left);
+        newsize:=def_cgsize(resultdef);
+        if left.location.loc=LOC_CREFERENCE then
+          location_reset_ref(location,LOC_CREFERENCE,newsize,left.location.reference.alignment)
+        else
+          location_reset_ref(location,LOC_REFERENCE,newsize,left.location.reference.alignment);
+        { 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;
+        isjump:=(right.expectloc=LOC_JUMP);
+        if isjump then
+         begin
+           otl:=current_procinfo.CurrTrueLabel;
+           current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
+           ofl:=current_procinfo.CurrFalseLabel;
+           current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
+         end;
+        secondpass(right);
+
+        { simplify index location if necessary, since array references support
+          an index in memory, but not an another array index }
+        if isjump or
+           ((right.location.loc in [LOC_REFERENCE,LOC_CREFERENCE]) and
+            (right.location.reference.arrayreftype<>art_none)) then
+          hlcg.location_force_reg(current_asmdata.CurrAsmList,right.location,right.resultdef,right.resultdef,true);
+
+        if isjump then
+         begin
+           current_procinfo.CurrTrueLabel:=otl;
+           current_procinfo.CurrFalseLabel:=ofl;
+         end
+        else if (right.location.loc = LOC_JUMP) then
+          internalerror(2011090501);
+        { replace enum class instance with the corresponding integer value }
+        if (right.resultdef.typ=enumdef) then
+          begin
+           if (right.location.loc<>LOC_CONSTANT) then
+             begin
+               psym:=search_struct_member(tenumdef(right.resultdef).getbasedef.classdef,'FPCORDINAL');
+               if not assigned(psym) or
+                  (psym.typ<>procsym) or
+                  (tprocsym(psym).ProcdefList.count<>1) then
+                 internalerror(2011062607);
+               thlcgjvm(hlcg).a_load_loc_stack(current_asmdata.CurrAsmList,right.resultdef,right.location);
+               hlcg.a_call_name(current_asmdata.CurrAsmList,tprocdef(tprocsym(psym).procdeflist[0]),tprocdef(tprocsym(psym).procdeflist[0]).mangledname,false);
+               { call replaces self parameter with longint result -> no stack
+                 height change }
+               location_reset(right.location,LOC_REGISTER,OS_S32);
+               right.location.register:=hlcg.getintregister(current_asmdata.CurrAsmList,s32inttype);
+               thlcgjvm(hlcg).a_load_stack_reg(current_asmdata.CurrAsmList,s32inttype,right.location.register);
+             end;
+           { always force to integer location, because enums are handled as
+             object instances (since that's what they are in Java) }
+           right.resultdef:=s32inttype;
+           right.location.size:=OS_S32;
+          end;
+
+        { 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
+              location.reference.arrayreftype:=art_indexreg;
+              location.reference.index:=right.location.register;
+            end;
+          LOC_REFERENCE,LOC_CREFERENCE:
+            begin
+              location.reference.arrayreftype:=art_indexref;
+              location.reference.indexbase:=right.location.reference.base;
+              location.reference.indexsymbol:=right.location.reference.symbol;
+              location.reference.indexoffset:=right.location.reference.offset;
+            end;
+          LOC_CONSTANT:
+            begin
+              location.reference.arrayreftype:=art_indexconst;
+              location.reference.indexoffset:=right.location.value-tarraydef(left.resultdef).lowrange;
+            end
+          else
+            internalerror(2011012002);
+        end;
+      end;
+
+
+begin
+   cderefnode:=tjvmderefnode;
+   caddrnode:=tjvmaddrnode;
+   cvecnode:=tjvmvecnode;
+   cloadvmtaddrnode:=tjvmloadvmtaddrnode;
+end.

compiler/jvm/njvmset.pas

@@ -0,0 +1,123 @@
+{
+    Copyright (c) 2011 by Jonas Maebe
+
+    Generate JVM bytecode for in set/case nodes
+
+    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 njvmset;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+      globtype,
+      node,nset,ncgset;
+
+    type
+      tjvminnode = class(tcginnode)
+         function pass_1: tnode; override;
+      end;
+
+      tjvmcasenode = class(tcgcasenode)
+         function pass_1: tnode; override;
+      end;
+
+
+implementation
+
+    uses
+      symconst,symdef,
+      pass_1,
+      ncal,ncnv,ncon,nmem,
+      njvmcon,
+      cgbase;
+
+{*****************************************************************************
+                             TJVMINNODE
+*****************************************************************************}
+
+    function tjvminnode.pass_1: tnode;
+      var
+        setparts: Tsetparts;
+        numparts: byte;
+        use_small: boolean;
+        isenum: boolean;
+      begin
+        { before calling "inherited pass_1", so that in case left is an enum
+          constant it's not yet translated into a class instance }
+        isenum:=left.resultdef.typ=enumdef;
+        { if we can use jumps, don't transform the set constant and (if
+          applicable) the value to be tested }
+        if checkgenjumps(setparts,numparts,use_small) then
+          begin
+            if right.nodetype=setconstn then
+              tjvmsetconstnode(right).setconsttype:=sct_notransform;
+            if isenum then
+              if (left.nodetype=ordconstn) then
+                tjvmordconstnode(left).enumconstok:=true
+              else
+                { not very clean, since we now have "longint in enumset", but
+                  the code generator doesn't really mind }
+                inserttypeconv_explicit(left,s32inttype);
+          end;
+        result:=inherited pass_1;
+        if assigned(result) then
+          exit;
+        { in case of jumps let the regular code handle it }
+        if expectloc=LOC_JUMP then
+          exit;
+        { otherwise call set helper }
+        right:=caddrnode.create_internal(right);
+        include(right.flags,nf_typedaddr);
+        if isenum then
+          begin
+            inserttypeconv_explicit(left,java_jlenum);
+            inserttypeconv_explicit(right,java_juenumset);
+          end
+        else
+          begin
+            inserttypeconv_explicit(left,s32inttype);
+            inserttypeconv_explicit(right,java_jubitset);
+          end;
+        result:=ccallnode.createinternmethod(right,'CONTAINS',ccallparanode.create(left,nil));
+        right:=nil;
+        left:=nil;
+      end;
+
+
+{*****************************************************************************
+                            TJVMCASENODE
+*****************************************************************************}
+
+    function tjvmcasenode.pass_1: tnode;
+      begin
+        { convert case expression to an integer in case it's an enum, since
+          enums are class instances in the JVM. All labels are stored as
+          ordinal values, so it doesn't matter that we change the type }
+        if left.resultdef.typ=enumdef then
+          inserttypeconv_explicit(left,s32inttype);
+        result:=inherited pass_1;
+      end;
+
+
+
+begin
+   cinnode:=tjvminnode;
+   ccasenode:=tjvmcasenode;
+end.

compiler/jvm/njvmtcon.pas

@@ -0,0 +1,207 @@
+{
+    Copyright (c) 2011 by Jonas Maebe
+
+    Generates nodes for typed constant declarations
+
+    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 njvmtcon;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+      globtype,
+      node,
+      symtype,symdef,
+      ngtcon;
+
+
+    type
+      tarrstringdata = record
+        arrstring: ansistring;
+        arrdatastart, arrdatalen: asizeint;
+        arraybase: tnode;
+      end;
+
+      tjvmtypedconstbuilder = class(tnodetreetypedconstbuilder)
+       private
+        procedure tc_flush_arr_strconst(def: tdef);
+       protected
+        arrstringdata: tarrstringdata;
+        parsingordarray: boolean;
+
+        procedure parse_arraydef(def: tarraydef); override;
+        procedure tc_emit_setdef(def: tsetdef; var node: tnode);override;
+        procedure tc_emit_orddef(def: torddef; var node: tnode); override;
+      end;
+
+implementation
+
+    uses
+      globals,widestr,verbose,constexp,
+      defutil,
+      nbas,ncal,ncon,njvmcon;
+
+
+    procedure init_arrstringdata(out data: tarrstringdata);
+      begin
+        data.arrstring:='';
+        data.arrdatastart:=0;
+        data.arrdatalen:=0;
+        data.arraybase:=nil;
+      end;
+
+
+    procedure tjvmtypedconstbuilder.tc_flush_arr_strconst(def: tdef);
+      var
+        wstr: pcompilerwidestring;
+        wc: tcompilerwidechar;
+        i: longint;
+        procvariant: string[8];
+      begin
+        // convert ansistring to packed unicodestring
+        initwidestring(wstr);
+        for i:=1 to length(arrstringdata.arrstring) div 2 do
+          begin
+            wc:=tcompilerwidechar(ord(arrstringdata.arrstring[i*2-1]) shl 8 or
+                                  ord(arrstringdata.arrstring[i*2]));
+            concatwidestringchar(wstr,wc);
+          end;
+        if odd(length(arrstringdata.arrstring)) then
+          concatwidestringchar(wstr,
+            tcompilerwidechar(ord(arrstringdata.arrstring[length(arrstringdata.arrstring)]) shl 8));
+
+
+        if is_signed(def) then
+          case def.size of
+            1: procvariant:='shortint';
+            2: procvariant:='smallint';
+            4: procvariant:='longint';
+            8: procvariant:='int64';
+            else
+              internalerror(2011111301);
+          end
+        else
+          case def.size of
+            1: procvariant:='byte';
+            2: procvariant:='word';
+            4: procvariant:='cardinal';
+            8: procvariant:='qword';
+            else
+              internalerror(2011111302);
+          end;
+        // (const s: unicodestring; var arr: array of shortint; startintdex, len: longint);
+        addstatement(statmnt,ccallnode.createintern('fpc_tcon_'+procvariant+'_array_from_string',
+          ccallparanode.create(genintconstnode(arrstringdata.arrdatalen),
+            ccallparanode.create(genintconstnode(arrstringdata.arrdatastart),
+              ccallparanode.create(arrstringdata.arraybase.getcopy,
+                ccallparanode.create(cstringconstnode.createunistr(wstr),nil))))));
+
+        inc(arrstringdata.arrdatastart,arrstringdata.arrdatalen);
+        arrstringdata.arrstring:='';
+        arrstringdata.arrdatalen:=0;
+
+        donewidestring(wstr);
+      end;
+
+
+    procedure tjvmtypedconstbuilder.parse_arraydef(def: tarraydef);
+      var
+        old_arrstringdata: tarrstringdata;
+        old_parsingordarray: boolean;
+      begin
+        if is_dynamic_array(def) or
+           not is_integer(def.elementdef) or
+           not(ts_compact_int_array_init in current_settings.targetswitches) then
+          begin
+            inherited;
+            exit;
+          end;
+        old_arrstringdata:=arrstringdata;
+        init_arrstringdata(arrstringdata);
+        arrstringdata.arraybase:=basenode.getcopy;
+        old_parsingordarray:=parsingordarray;
+        parsingordarray:=true;
+        inherited;
+        if length(arrstringdata.arrstring)<>0 then
+          tc_flush_arr_strconst(def.elementdef);
+        arrstringdata.arraybase.free;
+        parsingordarray:=old_parsingordarray;
+        arrstringdata:=old_arrstringdata;
+      end;
+
+
+    procedure tjvmtypedconstbuilder.tc_emit_setdef(def: tsetdef; var node: tnode);
+      begin
+        { indicate that set constant nodes have to be transformed into
+          constructors here }
+        if node.nodetype=setconstn then
+          tjvmsetconstnode(node).setconsttype:=sct_construct;
+        inherited tc_emit_setdef(def,node);
+      end;
+
+
+    procedure tjvmtypedconstbuilder.tc_emit_orddef(def: torddef; var node: tnode);
+      var
+        elesize: longint;
+      begin
+        if not parsingordarray then
+          begin
+            inherited;
+            exit;
+          end;
+        if node.nodetype<>ordconstn then
+          internalerror(2011111101);
+        elesize:=def.size;
+        inc(arrstringdata.arrdatalen);
+        case elesize of
+          1:
+            arrstringdata.arrstring:=arrstringdata.arrstring+char(tordconstnode(node).value.svalue);
+          2:
+            arrstringdata.arrstring:=arrstringdata.arrstring+char(tordconstnode(node).value.svalue shr 8)+char(tordconstnode(node).value.svalue and $ff);
+          4:
+            arrstringdata.arrstring:=arrstringdata.arrstring+char((tordconstnode(node).value.svalue shr 24))+
+              char((tordconstnode(node).value.svalue shr 16) and $ff)+
+              char((tordconstnode(node).value.svalue shr 8) and $ff)+
+              char(tordconstnode(node).value.svalue and $ff);
+          8:
+            arrstringdata.arrstring:=arrstringdata.arrstring+char((tordconstnode(node).value.svalue shr 56))+
+              char((tordconstnode(node).value.svalue shr 48) and $ff)+
+              char((tordconstnode(node).value.svalue shr 40) and $ff)+
+              char((tordconstnode(node).value.svalue shr 32) and $ff)+
+              char((tordconstnode(node).value.svalue shr 24) and $ff)+
+              char((tordconstnode(node).value.svalue shr 16) and $ff)+
+              char((tordconstnode(node).value.svalue shr 8) and $ff)+
+              char(tordconstnode(node).value.svalue and $ff);
+        end;
+        { we can't use the full 64kb, because inside the Java class file the
+          string constant is actually encoded using UTF-8 and it's this UTF-8
+          encoding that has to fit inside 64kb (and utf-8 encoding of random
+          data can easily blow up its size by about a third) }
+        if length(arrstringdata.arrstring)>40000 then
+          tc_flush_arr_strconst(def);
+        basenode.free;
+        basenode:=nil;
+        node.free;
+        node:=nil;
+      end;
+
+begin
+  ctypedconstbuilder:=tjvmtypedconstbuilder;
+end.

compiler/jvm/njvmutil.pas

@@ -0,0 +1,408 @@
+{
+    Copyright (c) 20011 by Jonas Maebe
+
+    JVM version of some node tree 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.
+
+ ****************************************************************************
+}
+unit njvmutil;
+
+{$i fpcdefs.inc}
+
+interface
+
+  uses
+    node,
+    ngenutil,
+    symtype,symconst,symsym;
+
+
+  type
+    tjvmnodeutils = class(tnodeutils)
+      class function initialize_data_node(p:tnode; force: boolean):tnode; override;
+      class function finalize_data_node(p:tnode):tnode; override;
+      class function force_init: boolean; override;
+      class procedure insertbssdata(sym: tstaticvarsym); override;
+      class function create_main_procdef(const name: string; potype: tproctypeoption; ps: tprocsym): tdef; override;
+      class procedure InsertInitFinalTable; override;
+      class procedure InsertThreadvarTablesTable; override;
+      class procedure InsertThreadvars; override;
+      class procedure InsertWideInitsTablesTable; override;
+      class procedure InsertWideInits; override;
+      class procedure InsertResourceTablesTable; override;
+      class procedure InsertResourceInfo(ResourcesUsed : boolean); override;
+      class procedure InsertMemorySizes; override;
+     strict protected
+       class procedure add_main_procdef_paras(pd: tdef); override;
+    end;
+
+
+implementation
+
+    uses
+      verbose,cutils,globtype,globals,constexp,fmodule,
+      aasmdata,aasmtai,cpubase,aasmcpu,
+      symdef,symbase,symtable,defutil,jvmdef,
+      nbas,ncnv,ncon,ninl,ncal,nld,nmem,
+      ppu,
+      pass_1;
+
+  class function tjvmnodeutils.initialize_data_node(p:tnode; force: boolean):tnode;
+    var
+      normaldim: longint;
+      temp: ttempcreatenode;
+      stat: tstatementnode;
+      def: tdef;
+      paras: tcallparanode;
+      proc: string;
+    begin
+      if not assigned(p.resultdef) then
+        typecheckpass(p);
+      if ((p.resultdef.typ=stringdef) and
+          not is_shortstring(p.resultdef) and
+          not is_longstring(p.resultdef)) or
+         is_dynamic_array(p.resultdef) then
+        begin
+          { Always initialise with empty string/array rather than nil. Java
+            makes a distinction between an empty string/array and a null
+            string/array,  but we don't. We therefore have to pick which one we
+            use to represent empty strings/arrays. I've chosen empty rather than
+            null structures, because otherwise it becomes impossible to return
+            an empty string to Java code (it would return null).
+
+            On the consumer side, we do interpret both null and empty as the same
+            thing, so Java code can pass in null strings/arrays and we'll
+            interpret them correctly.
+          }
+          result:=cinlinenode.create(in_setlength_x,false,
+            ccallparanode.create(genintconstnode(0),
+              ccallparanode.create(p,nil)));
+        end
+      else if force then
+        begin
+          { an explicit call to initialize() }
+          if p.resultdef.typ=recorddef then
+            result:=ccallnode.createinternmethod(p,'FPCINITIALIZEREC',nil)
+          else if p.resultdef.typ=arraydef then
+            begin
+              stat:=nil;
+              { in case it's an open array whose elements are regular arrays, put the
+                dimension of the regular arrays on the stack (otherwise pass 0) }
+              normaldim:=0;
+              def:=tarraydef(p.resultdef).elementdef;
+              while (def.typ=arraydef) and
+                    not is_dynamic_array(def) do
+                begin
+                  inc(normaldim);
+                  def:=tarraydef(def).elementdef;
+                end;
+              if jvmimplicitpointertype(p.resultdef) then
+                begin
+                  p:=caddrnode.create(p);
+                  include(p.flags,nf_typedaddr);
+                end;
+              paras:=ccallparanode.create(ctypeconvnode.create_explicit(p,
+                search_system_type('TJOBJECTARRAY').typedef),nil);
+              paras:=ccallparanode.create(genintconstnode(normaldim),paras);
+              if is_wide_or_unicode_string(def) then
+                proc:='fpc_initialize_array_unicodestring'
+              else if is_ansistring(def) then
+                proc:='fpc_initialize_array_ansistring'
+              else if is_dynamic_array(def) then
+                proc:='fpc_initialize_array_dynarr'
+              else if is_record(def) then
+                begin
+                  result:=internalstatements(stat);
+                  temp:=ctempcreatenode.create(def,def.size,tt_persistent,true);
+                  addstatement(stat,temp);
+                  paras:=ccallparanode.create(ctemprefnode.create(temp),paras);
+                  proc:='fpc_initialize_array_record'
+                end;
+              if assigned(stat) then
+                begin
+                  addstatement(stat,ccallnode.createintern(proc,paras));
+                  addstatement(stat,ctempdeletenode.create(temp));
+                end
+              else
+                result:=ccallnode.createintern(proc,paras);
+            end
+          else
+            result:=cassignmentnode.create(p,cnilnode.create);
+        end
+      else
+        begin
+          p.free;
+          { records/arrays/... are automatically initialised }
+          result:=cnothingnode.create;
+        end;
+    end;
+
+
+  class function tjvmnodeutils.finalize_data_node(p:tnode):tnode;
+    begin
+      // do nothing
+      p.free;
+      result:=cnothingnode.create;
+    end;
+
+
+  class function tjvmnodeutils.force_init: boolean;
+    begin
+      { we need an initialisation in case the al_globals list is not empty
+        (that's where the initialisation for global records etc is added) }
+      { problem: some bss symbols are only registered while processing the main
+        program (e.g. constant sets) -> cannot predict whether or not we'll
+        need it in advance }
+      result:=true;
+    end;
+
+  class procedure tjvmnodeutils.insertbssdata(sym: tstaticvarsym);
+    var
+      enuminitsym,
+      vs: tstaticvarsym;
+      block: tblocknode;
+      stat: tstatementnode;
+      temp: ttempcreatenode;
+      initnode: tnode;
+      eledef: tdef;
+      ndim: longint;
+      initnodefinished: boolean;
+    begin
+      { handled while generating the unit/program init code, or class
+        constructor; add something to al_globals to indicate that we need to
+        insert an init section though }
+      if current_asmdata.asmlists[al_globals].empty and
+         jvmimplicitpointertype(sym.vardef) then
+        current_asmdata.asmlists[al_globals].concat(cai_align.Create(1));
+      { in case of a threadvar, allocate a separate sym that's a subtype of the
+        java.lang.ThreadLocal class which will wrap the actual variable value }
+      if vo_is_thread_var in sym.varoptions then
+        begin
+          vs:=tstaticvarsym.create(sym.realname+'$threadvar',sym.varspez,
+            jvmgetthreadvardef(sym.vardef),
+            sym.varoptions - [vo_is_thread_var]);
+          sym.owner.insert(vs);
+          { make sure that the new sym does not get allocated (we will allocate
+            it when encountering the original sym, because only then we know
+            that it's a threadvar) }
+          include(vs.symoptions,sp_static);
+          { switch around the mangled names of sym and vs, since the wrapper
+            should map to the declared name }
+          sym.set_mangledbasename(vs.realname);
+          vs.set_mangledbasename(sym.realname);
+
+          { add initialization code for the wrapper }
+          block:=internalstatements(stat);
+          if assigned(current_module.tcinitcode) then
+            addstatement(stat,tnode(current_module.tcinitcode));
+          current_module.tcinitcode:=block;
+
+          { create initialization value if necessary }
+          initnode:=nil;
+          initnodefinished:=false;
+          temp:=nil;
+          { in case of enum type, initialize with enum(0) if it exists }
+          if sym.vardef.typ=enumdef then
+            begin
+              enuminitsym:=tstaticvarsym(tenumdef(sym.vardef).getbasedef.classdef.symtable.Find('__FPC_ZERO_INITIALIZER'));
+              if assigned(enuminitsym) then
+                initnode:=cloadnode.create(enuminitsym,enuminitsym.owner);
+            end
+          { normal array -> include dimensions and element type so we can
+            create a deep copy }
+          else if (sym.vardef.typ=arraydef) and
+             not is_dynamic_array(sym.vardef) then
+            begin
+              temp:=ctempcreatenode.create(sym.vardef,sym.vardef.size,tt_persistent,true);
+              addstatement(stat,temp);
+              initnode:=ccallparanode.create(
+                ctypeconvnode.create_explicit(
+                  caddrnode.create_internal(ctemprefnode.create(temp)),
+                  java_jlobject),
+                nil);
+              jvmgetarraydimdef(sym.vardef,eledef,ndim);
+              initnode:=ccallparanode.create(genintconstnode(ndim),initnode);
+              initnode:=ccallparanode.create(
+                cordconstnode.create(ord(jvmarrtype_setlength(eledef)),
+                  cwidechartype,false),
+                initnode);
+              initnodefinished:=true;
+            end
+          { implicitpointertype -> allocate (get temp and assign address) }
+          else if jvmimplicitpointertype(sym.vardef) then
+            begin
+              temp:=ctempcreatenode.create(sym.vardef,sym.vardef.size,tt_persistent,true);
+              addstatement(stat,temp);
+              initnode:=caddrnode.create_internal(ctemprefnode.create(temp));
+            end
+          { unicodestring/ansistring -> empty string }
+          else if is_wide_or_unicode_string(sym.vardef) or
+             is_ansistring(sym.vardef) then
+            begin
+              temp:=ctempcreatenode.create(sym.vardef,sym.vardef.size,tt_persistent,true);
+              addstatement(stat,temp);
+              addstatement(stat,cassignmentnode.create(
+                ctemprefnode.create(temp),
+                cstringconstnode.createstr('')));
+              initnode:=ctemprefnode.create(temp);
+            end
+          { dynamic array -> empty array }
+          else if is_dynamic_array(sym.vardef) then
+            begin
+              temp:=ctempcreatenode.create(sym.vardef,sym.vardef.size,tt_persistent,true);
+              addstatement(stat,temp);
+              addstatement(stat,cinlinenode.create(in_setlength_x,false,
+                ccallparanode.create(genintconstnode(0),
+                  ccallparanode.create(ctemprefnode.create(temp),nil))
+                )
+              );
+              initnode:=ctemprefnode.create(temp);
+            end;
+
+          if assigned(initnode) and
+             not initnodefinished then
+            initnode:=ccallparanode.create(ctypeconvnode.create_explicit(initnode,java_jlobject),nil);
+          addstatement(stat,cassignmentnode.create(
+            cloadnode.create(vs,vs.owner),
+            ccallnode.createinternmethod(
+              cloadvmtaddrnode.create(ctypenode.create(vs.vardef)),
+              'CREATE',initnode)));
+          { deallocate the temp if we allocated one }
+          if assigned(temp) then
+            addstatement(stat,ctempdeletenode.create(temp));
+        end;
+    end;
+
+
+  class function tjvmnodeutils.create_main_procdef(const name: string; potype: tproctypeoption; ps: tprocsym): tdef;
+    begin
+      if (potype=potype_proginit) then
+        begin
+          result:=inherited create_main_procdef('main', potype, ps);
+          include(tprocdef(result).procoptions,po_global);
+          tprocdef(result).visibility:=vis_public;
+        end
+      else
+        result:=inherited create_main_procdef(name, potype, ps);
+    end;
+
+
+  class procedure tjvmnodeutils.InsertInitFinalTable;
+    var
+      hp : tused_unit;
+      unitinits : TAsmList;
+      unitclassname: string;
+      mainpsym: tsym;
+      mainpd: tprocdef;
+    begin
+      unitinits:=TAsmList.Create;
+      hp:=tused_unit(usedunits.first);
+      while assigned(hp) do
+        begin
+          { class constructors are automatically handled by the JVM }
+
+          { call the unit init code and make it external }
+          if (hp.u.flags and (uf_init or uf_finalize))<>0 then
+            begin
+              { trigger init code by referencing the class representing the
+                unit; if necessary, it will register the fini code to run on
+                exit}
+              unitclassname:='';
+              if assigned(hp.u.namespace) then
+                begin
+                  unitclassname:=hp.u.namespace^+'/';
+                  replace(unitclassname,'.','/');
+                end;
+              unitclassname:=unitclassname+hp.u.realmodulename^;
+              unitinits.concat(taicpu.op_sym(a_new,current_asmdata.RefAsmSymbol(unitclassname)));
+              unitinits.concat(taicpu.op_none(a_pop));
+            end;
+          hp:=tused_unit(hp.next);
+        end;
+      { insert in main program routine }
+      mainpsym:=tsym(current_module.localsymtable.find(mainaliasname));
+      if not assigned(mainpsym) or
+         (mainpsym.typ<>procsym) then
+        internalerror(2011041901);
+      mainpd:=tprocsym(mainpsym).find_procdef_bytype(potype_proginit);
+      if not assigned(mainpd) then
+        internalerror(2011041902);
+      mainpd.exprasmlist.insertList(unitinits);
+      unitinits.free;
+    end;
+
+
+  class procedure tjvmnodeutils.InsertThreadvarTablesTable;
+    begin
+      { not yet supported }
+    end;
+
+
+  class procedure tjvmnodeutils.InsertThreadvars;
+    begin
+      { not yet supported }
+    end;
+
+
+  class procedure tjvmnodeutils.InsertWideInitsTablesTable;
+    begin
+      { not required }
+    end;
+
+
+  class procedure tjvmnodeutils.InsertWideInits;
+    begin
+      { not required }
+    end;
+
+
+  class procedure tjvmnodeutils.InsertResourceTablesTable;
+    begin
+      { not supported }
+    end;
+
+
+  class procedure tjvmnodeutils.InsertResourceInfo(ResourcesUsed: boolean);
+    begin
+      { not supported }
+    end;
+
+
+  class procedure tjvmnodeutils.InsertMemorySizes;
+    begin
+      { not required }
+    end;
+
+
+  class procedure tjvmnodeutils.add_main_procdef_paras(pd: tdef);
+    var
+      pvs: tparavarsym;
+    begin
+      if (tprocdef(pd).proctypeoption=potype_proginit) then
+        begin
+          { add the args parameter }
+          pvs:=tparavarsym.create('$args',1,vs_const,search_system_type('TJSTRINGARRAY').typedef,[]);
+          tprocdef(pd).parast.insert(pvs);
+          tprocdef(pd).calcparas;
+        end;
+    end;
+
+
+begin
+  cnodeutils:=tjvmnodeutils;
+end.
+

compiler/jvm/pjvm.pas

@@ -0,0 +1,977 @@
+{
+    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
+      globtype,
+      symconst,symtype,symbase,symdef,symsym;
+
+    { 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);
+
+    procedure jvm_maybe_create_enum_class(const name: TIDString; def: tdef);
+    procedure jvm_create_procvar_class(const name: TIDString; def: tdef);
+
+    procedure jvm_wrap_virtual_class_methods(obj: tobjectdef);
+
+    function jvm_add_typed_const_initializer(csym: tconstsym): tstaticvarsym;
+
+    function jvm_wrap_method_with_vis(pd: tprocdef; vis: tvisibility): tprocdef;
+
+    { when a private/protected field is exposed via a property with a higher
+      visibility, then we have to create a getter and/or setter with that same
+      higher visibility to make sure that using the property does not result
+      in JVM verification errors }
+    procedure jvm_create_getter_for_property(p: tpropertysym);
+    procedure jvm_create_setter_for_property(p: tpropertysym);
+
+
+implementation
+
+  uses
+    cutils,cclasses,
+    verbose,systems,
+    fmodule,
+    parabase,aasmdata,
+    pdecsub,ngenutil,pparautl,
+    symtable,symcreat,defcmp,jvmdef,nobj,
+    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);
+      var
+        sym: tsym;
+        ps: tprocsym;
+        pd: tprocdef;
+        topowner: tdefentry;
+        i: longint;
+        sstate: tscannerstate;
+        needclassconstructor: boolean;
+      begin
+        { if there is at least one constructor for a class, do nothing (for
+           records, we'll always also need a parameterless constructor) }
+        if not is_javaclass(obj) or
+           not (oo_has_constructor in obj.objectoptions) then
+          begin
+            { 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;
+                { childof may not be assigned in case of a parser error }
+                if not assigned(tobjectdef(obj).childof) then
+                  exit;
+                sym:=tsym(tobjectdef(obj).childof.symtable.find('CREATE'));
+                if assigned(sym) and
+                   (sym.typ=procsym) then
+                  pd:=tprocsym(sym).find_bytype_parameterless(potype_constructor);
+                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:=ps.find_bytype_parameterless(potype_function);
+                if not assigned(pd) then
+                  pd:=ps.find_bytype_parameterless(potype_procedure);
+                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]) do
+              topowner:=topowner.owner.defowner;
+            { create procdef }
+            pd:=tprocdef.create(topowner.owner.symtablelevel+1);
+            if df_generic in obj.defoptions then
+              include(pd.defoptions,df_generic);
+            { 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);
+            { by default do not include this routine when looking for overloads }
+            include(pd.procoptions,po_ignore_for_overload_resolution);
+            { 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, ... (not for advanced records, for those
+              this is handled later) }
+            if obj.typ=recorddef then
+              handle_calling_convention(pd,[hcc_check])
+            else
+              handle_calling_convention(pd,hcc_all);
+            { register forward declaration with procsym }
+            proc_add_definition(pd);
+          end;
+
+        { also add class constructor if class fields that need wrapping, and
+          if none was defined }
+        if obj.find_procdef_bytype(potype_class_constructor)=nil then
+          begin
+            needclassconstructor:=false;
+            for i:=0 to obj.symtable.symlist.count-1 do
+              begin
+                if (tsym(obj.symtable.symlist[i]).typ=staticvarsym) and
+                   jvmimplicitpointertype(tstaticvarsym(obj.symtable.symlist[i]).vardef) then
+                  begin
+                    needclassconstructor:=true;
+                    break;
+                  end;
+              end;
+            if needclassconstructor then
+              begin
+                replace_scanner('custom_class_constructor',sstate);
+                if str_parse_method_dec('constructor fpc_jvm_class_constructor;',potype_class_constructor,true,obj,pd) then
+                  pd.synthetickind:=tsk_empty
+                else
+                  internalerror(2011040501);
+                restore_scanner(sstate);
+              end;
+          end;
+      end;
+
+
+    procedure add_java_default_record_methods_intf(def: trecorddef);
+      var
+        sstate: tscannerstate;
+        pd: tprocdef;
+        sym: tsym;
+        i: longint;
+      begin
+        maybe_add_public_default_java_constructor(def);
+        replace_scanner('record_jvm_helpers',sstate);
+        { no override, because not supported in records. Only required in case
+          some of the fields require deep copies (otherwise the default
+          shallow clone is fine) }
+        for i:=0 to def.symtable.symlist.count-1 do
+          begin
+            sym:=tsym(def.symtable.symlist[i]);
+            if (sym.typ=fieldvarsym) and
+               jvmimplicitpointertype(tfieldvarsym(sym).vardef) then
+              begin
+                if str_parse_method_dec('function clone: JLObject;',potype_function,false,def,pd) then
+                  pd.synthetickind:=tsk_jvm_clone
+                else
+                  internalerror(2011032806);
+                break;
+              end;
+          end;
+        { can't use def.typesym, not yet set at this point }
+        if not assigned(def.symtable.realname) then
+          internalerror(2011032803);
+        if str_parse_method_dec('procedure fpcDeepCopy(result: FpcBaseRecordType);',potype_procedure,false,def,pd) then
+          begin
+            pd.synthetickind:=tsk_record_deepcopy;
+            { can't add to the declaration since record methods can't override;
+              it is in fact an overriding method, because all records inherit
+              from a Java base class }
+            include(pd.procoptions,po_overridingmethod);
+          end
+        else
+          internalerror(2011032807);
+        if def.needs_inittable then
+          begin
+            { 'var' instead of 'out' parameter, because 'out' would trigger
+               calling the initialize method recursively }
+            if str_parse_method_dec('procedure fpcInitializeRec;',potype_procedure,false,def,pd) then
+              pd.synthetickind:=tsk_record_initialize
+            else
+              internalerror(2011071711);
+          end;
+        restore_scanner(sstate);
+      end;
+
+
+    procedure setup_for_new_class(const scannername: string; out sstate: tscannerstate; out islocal: boolean; out oldsymtablestack: TSymtablestack);
+      begin
+        replace_scanner(scannername,sstate);
+        oldsymtablestack:=symtablestack;
+        islocal:=symtablestack.top.symtablelevel>=normal_function_level;
+        if islocal then
+          begin
+            { we cannot add a class local to a procedure -> insert it in the
+              static symtable. This is not ideal because this means that it will
+              be saved to the ppu file for no good reason, and loaded again
+              even though it contains a reference to a type that was never
+              saved to the ppu file (the locally defined enum type). Since this
+              alias for the locally defined enumtype is only used while
+              implementing the class' methods, this is however no problem. }
+            symtablestack:=symtablestack.getcopyuntil(current_module.localsymtable);
+          end;
+      end;
+
+
+    procedure restore_after_new_class(const sstate: tscannerstate; const islocal: boolean; const oldsymtablestack: TSymtablestack);
+      begin
+        if islocal then
+          begin
+            symtablestack.free;
+            symtablestack:=oldsymtablestack;
+          end;
+        restore_scanner(sstate);
+      end;
+
+
+    procedure jvm_maybe_create_enum_class(const name: TIDString; def: tdef);
+      var
+        vmtbuilder: tvmtbuilder;
+        arrdef: tarraydef;
+        arrsym: ttypesym;
+        juhashmap: tdef;
+        enumclass: tobjectdef;
+        pd: tprocdef;
+        old_current_structdef: tabstractrecorddef;
+        i: longint;
+        sym,
+        aliassym: tstaticvarsym;
+        fsym: tfieldvarsym;
+        sstate: tscannerstate;
+        sl: tpropaccesslist;
+        temptypesym: ttypesym;
+        oldsymtablestack: tsymtablestack;
+        islocal: boolean;
+      begin
+        { if it's a subrange type, don't create a new class }
+        if assigned(tenumdef(def).basedef) then
+          exit;
+
+        setup_for_new_class('jvm_enum_class',sstate,islocal,oldsymtablestack);
+
+        { create new class (different internal name than enum to prevent name
+          clash; at unit level because we don't want its methods to be nested
+          inside a function in case its a local type) }
+        enumclass:=tobjectdef.create(odt_javaclass,'$'+current_module.realmodulename^+'$'+name+'$InternEnum$'+tostr(def.defid),java_jlenum);
+        tenumdef(def).classdef:=enumclass;
+        include(enumclass.objectoptions,oo_is_enum_class);
+        include(enumclass.objectoptions,oo_is_sealed);
+        { implement FpcEnumValueObtainable interface }
+        enumclass.ImplementedInterfaces.add(TImplementedInterface.Create(tobjectdef(search_system_type('FPCENUMVALUEOBTAINABLE').typedef)));
+        { create an alias for this type inside itself: this way we can choose a
+          name that can be used in generated Pascal code without risking an
+          identifier conflict (since it is local to this class; the global name
+          is unique because it's an identifier that contains $-signs) }
+        enumclass.symtable.insert(ttypesym.create('__FPC_TEnumClassAlias',enumclass));
+
+        { also create an alias for the enum type so that we can iterate over
+          all enum values when creating the body of the class constructor }
+        temptypesym:=ttypesym.create('__FPC_TEnumAlias',nil);
+        { don't pass def to the ttypesym constructor, because then it
+          will replace the current (real) typesym of that def with the alias }
+        temptypesym.typedef:=def;
+        enumclass.symtable.insert(temptypesym);
+        { but the name of the class as far as the JVM is concerned will match
+          the enum's original name (the enum type itself won't be output in
+          any class file, so no conflict there)
+
+          name can be empty in case of declaration such as "set of (ea,eb)"  }
+        if not islocal and
+           (name <> '')  then
+          enumclass.objextname:=stringdup(name)
+        else
+          { for local types, use a unique name to prevent conflicts (since such
+            types are not visible outside the routine anyway, it doesn't matter
+          }
+          begin
+            enumclass.objextname:=stringdup(enumclass.objrealname^);
+            { also mark it as private (not strict private, because the class
+              is not a subclass of the unit in which it is declared, so then
+              the unit's procedures would not be able to use it) }
+            enumclass.typesym.visibility:=vis_private;
+          end;
+        { now add a bunch of extra things to the enum class }
+        old_current_structdef:=current_structdef;
+        current_structdef:=enumclass;
+
+        symtablestack.push(enumclass.symtable);
+        { create static fields representing all enums }
+        for i:=0 to tenumdef(def).symtable.symlist.count-1 do
+          begin
+            fsym:=tfieldvarsym.create(tenumsym(tenumdef(def).symtable.symlist[i]).realname,vs_final,enumclass,[]);
+            enumclass.symtable.insert(fsym);
+            sym:=make_field_static(enumclass.symtable,fsym);
+            { add alias for the field representing ordinal(0), for use in
+              initialization code }
+            if tenumsym(tenumdef(def).symtable.symlist[i]).value=0 then
+              begin
+                aliassym:=tstaticvarsym.create('__FPC_Zero_Initializer',vs_final,enumclass,[vo_is_external]);
+                enumclass.symtable.insert(aliassym);
+                aliassym.set_raw_mangledname(sym.mangledname);
+              end;
+          end;
+        { create local "array of enumtype" type for the "values" functionality
+          (used internally by the JDK) }
+        arrdef:=tarraydef.create(0,tenumdef(def).symtable.symlist.count-1,s32inttype);
+        arrdef.elementdef:=enumclass;
+        arrsym:=ttypesym.create('__FPC_TEnumValues',arrdef);
+        enumclass.symtable.insert(arrsym);
+        { insert "public static values: array of enumclass" that returns $VALUES.clone()
+          (rather than a dynamic array and using clone --which we don't support yet for arrays--
+           simply use a fixed length array and copy it) }
+        if not str_parse_method_dec('function values: __FPC_TEnumValues;static;',potype_function,true,enumclass,pd) then
+          internalerror(2011062301);
+        include(pd.procoptions,po_staticmethod);
+        pd.synthetickind:=tsk_jvm_enum_values;
+        { do we have to store the ordinal value separately? (if no jumps, we can
+          just call the default ordinal() java.lang.Enum function) }
+        if tenumdef(def).has_jumps then
+          begin
+            { add field for the value }
+            fsym:=tfieldvarsym.create('__fpc_fenumval',vs_final,s32inttype,[]);
+            enumclass.symtable.insert(fsym);
+            tobjectsymtable(enumclass.symtable).addfield(fsym,vis_strictprivate);
+            { add class field with hash table that maps from FPC-declared ordinal value -> enum instance }
+            juhashmap:=search_system_type('JUHASHMAP').typedef;
+            fsym:=tfieldvarsym.create('__fpc_ord2enum',vs_final,juhashmap,[]);
+            enumclass.symtable.insert(fsym);
+            make_field_static(enumclass.symtable,fsym);
+            { add custom constructor }
+            if not str_parse_method_dec('constructor Create(const __fpc_name: JLString; const __fpc_ord, __fpc_initenumval: longint);',potype_constructor,false,enumclass,pd) then
+              internalerror(2011062401);
+            pd.synthetickind:=tsk_jvm_enum_jumps_constr;
+            pd.visibility:=vis_strictprivate;
+          end
+        else
+          begin
+            { insert "private constructor(string,int,int)" that calls inherited and
+              initialises the FPC value field }
+            add_missing_parent_constructors_intf(enumclass,false,vis_strictprivate);
+          end;
+        { add instance method to get the enum's value as declared in FPC }
+        if not str_parse_method_dec('function FPCOrdinal: longint;',potype_function,false,enumclass,pd) then
+          internalerror(2011062402);
+        pd.synthetickind:=tsk_jvm_enum_fpcordinal;
+        { add static class method to convert an ordinal to the corresponding enum }
+        if not str_parse_method_dec('function FPCValueOf(__fpc_int: longint): __FPC_TEnumClassAlias; static;',potype_function,true,enumclass,pd) then
+          internalerror(2011062402);
+        pd.synthetickind:=tsk_jvm_enum_fpcvalueof;
+        { similar (instance) function for use in set factories; implements FpcEnumValueObtainable interface }
+        if not str_parse_method_dec('function fpcGenericValueOf(__fpc_int: longint): JLEnum;',potype_function,false,enumclass,pd) then
+          internalerror(2011062402);
+        pd.synthetickind:=tsk_jvm_enum_fpcvalueof;
+
+        { insert "public static valueOf(string): tenumclass" that returns tenumclass(inherited valueOf(tenumclass,string)) }
+        if not str_parse_method_dec('function valueOf(const __fpc_str: JLString): __FPC_TEnumClassAlias; static;',potype_function,true,enumclass,pd) then
+          internalerror(2011062302);
+        include(pd.procoptions,po_staticmethod);
+        pd.synthetickind:=tsk_jvm_enum_valueof;
+
+        { add instance method to convert an ordinal and an array into a set of
+          (we always need/can use both in case of subrange types and/or array
+           -> set type casts) }
+        if not str_parse_method_dec('function fpcLongToEnumSet(__val: jlong; __setbase, __setsize: jint): JUEnumSet;',potype_function,true,enumclass,pd) then
+          internalerror(2011070501);
+        pd.synthetickind:=tsk_jvm_enum_long2set;
+
+        if not str_parse_method_dec('function fpcBitSetToEnumSet(const __val: FpcBitSet; __fromsetbase, __tosetbase: jint): JUEnumSet; static;',potype_function,true,enumclass,pd) then
+          internalerror(2011071004);
+        pd.synthetickind:=tsk_jvm_enum_bitset2set;
+
+        if not str_parse_method_dec('function fpcEnumSetToEnumSet(const __val: JUEnumSet; __fromsetbase, __tosetbase: jint): JUEnumSet; static;',potype_function,true,enumclass,pd) then
+          internalerror(2011071005);
+        pd.synthetickind:=tsk_jvm_enum_set2set;
+
+        { create array called "$VALUES" that will contain a reference to all
+          enum instances (JDK convention)
+          Disable duplicate identifier checking when inserting, because it will
+          check for a conflict with "VALUES" ($<id> normally means "check for
+          <id> without uppercasing first"), which will conflict with the
+          "Values" instance method -- that's also the reason why we insert the
+          field only now, because we cannot disable duplicate identifier
+          checking when creating the "Values" method }
+        fsym:=tfieldvarsym.create('$VALUES',vs_final,arrdef,[]);
+        fsym.visibility:=vis_strictprivate;
+        enumclass.symtable.insert(fsym,false);
+        sym:=make_field_static(enumclass.symtable,fsym);
+        { alias for accessing the field in generated Pascal code }
+        sl:=tpropaccesslist.create;
+        sl.addsym(sl_load,sym);
+        enumclass.symtable.insert(tabsolutevarsym.create_ref('__fpc_FVALUES',arrdef,sl));
+        { add initialization of the static class fields created above }
+        if not str_parse_method_dec('constructor fpc_enum_class_constructor;',potype_class_constructor,true,enumclass,pd) then
+          internalerror(2011062303);
+        pd.synthetickind:=tsk_jvm_enum_classconstr;
+
+        symtablestack.pop(enumclass.symtable);
+
+        vmtbuilder:=TVMTBuilder.Create(enumclass);
+        vmtbuilder.generate_vmt;
+        vmtbuilder.free;
+
+        restore_after_new_class(sstate,islocal,oldsymtablestack);
+        current_structdef:=old_current_structdef;
+      end;
+
+
+    procedure jvm_create_procvar_class_intern(const name: TIDString; def: tdef; force_no_callback_intf: boolean);
+      var
+        vmtbuilder: tvmtbuilder;
+        oldsymtablestack: tsymtablestack;
+        pvclass,
+        pvintf: tobjectdef;
+        temptypesym: ttypesym;
+        sstate: tscannerstate;
+        methoddef: tprocdef;
+        old_current_structdef: tabstractrecorddef;
+        islocal: boolean;
+      begin
+        { inlined definition of procvar -> generate name, derive from
+          FpcBaseNestedProcVarType, pass nestedfpstruct to constructor and
+          copy it }
+        if name='' then
+          internalerror(2011071901);
+
+        setup_for_new_class('jvm_pvar_class',sstate,islocal,oldsymtablestack);
+
+        { create new class (different internal name than pvar to prevent name
+          clash; at unit level because we don't want its methods to be nested
+          inside a function in case its a local type) }
+        pvclass:=tobjectdef.create(odt_javaclass,'$'+current_module.realmodulename^+'$'+name+'$InternProcvar$'+tostr(def.defid),java_procvarbase);
+        tprocvardef(def).classdef:=pvclass;
+        include(pvclass.objectoptions,oo_is_sealed);
+        if df_generic in def.defoptions then
+          include(pvclass.defoptions,df_generic);
+        { associate typesym }
+        pvclass.symtable.insert(ttypesym.create('__FPC_TProcVarClassAlias',pvclass));
+        { set external name to match procvar type name }
+        if not islocal then
+          pvclass.objextname:=stringdup(name)
+        else
+          pvclass.objextname:=stringdup(pvclass.objrealname^);
+
+        symtablestack.push(pvclass.symtable);
+
+        { inherit constructor and keep public }
+        add_missing_parent_constructors_intf(pvclass,true,vis_public);
+
+        { add a method to call the procvar using unwrapped arguments, which
+          then wraps them and calls through to JLRMethod.invoke }
+        methoddef:=tprocdef(tprocvardef(def).getcopyas(procdef,pc_bareproc));
+        finish_copied_procdef(methoddef,'invoke',pvclass.symtable,pvclass);
+        insert_self_and_vmt_para(methoddef);
+        methoddef.synthetickind:=tsk_jvm_procvar_invoke;
+        methoddef.calcparas;
+
+        { add local alias for the procvartype that we can use when implementing
+          the invoke method }
+        temptypesym:=ttypesym.create('__FPC_ProcVarAlias',nil);
+        { don't pass def to the ttypesym constructor, because then it
+          will replace the current (real) typesym of that def with the alias }
+        temptypesym.typedef:=def;
+        pvclass.symtable.insert(temptypesym);
+
+        { in case of a procedure of object, add a nested interface type that
+          has one method that conforms to the procvartype (with name
+          procvartypename+'Callback') and an extra constructor that takes
+          an instance conforming to this interface and which sets up the
+          procvar by taking the address of its Callback method (convenient to
+          use from Java code) }
+        if (po_methodpointer in tprocvardef(def).procoptions) and
+           not islocal and
+           not force_no_callback_intf then
+          begin
+            pvintf:=tobjectdef.create(odt_interfacejava,'Callback',nil);
+            pvintf.objextname:=stringdup('Callback');
+            if df_generic in def.defoptions then
+              include(pvintf.defoptions,df_generic);
+            { associate typesym }
+            pvclass.symtable.insert(ttypesym.create('Callback',pvintf));
+
+            { add a method prototype matching the procvar (like the invoke
+              in the procvarclass itself) }
+            symtablestack.push(pvintf.symtable);
+            methoddef:=tprocdef(tprocvardef(def).getcopyas(procdef,pc_bareproc));
+            finish_copied_procdef(methoddef,name+'Callback',pvintf.symtable,pvintf);
+            insert_self_and_vmt_para(methoddef);
+            { can't be final/static/private/protected, and must be virtual
+              since it's an interface method }
+            methoddef.procoptions:=methoddef.procoptions-[po_staticmethod,po_finalmethod];
+            include(methoddef.procoptions,po_virtualmethod);
+            methoddef.visibility:=vis_public;
+            symtablestack.pop(pvintf.symtable);
+
+            { add an extra constructor to the procvarclass that takes an
+              instance of this interface as parameter }
+            old_current_structdef:=current_structdef;
+            current_structdef:=pvclass;
+            if not str_parse_method_dec('constructor Create(__intf:'+pvintf.objextname^+');overload;',potype_constructor,false,pvclass,methoddef) then
+              internalerror(2011092401);
+            methoddef.synthetickind:=tsk_jvm_procvar_intconstr;
+            methoddef.skpara:=def;
+            current_structdef:=old_current_structdef;
+          end;
+
+        symtablestack.pop(pvclass.symtable);
+
+        vmtbuilder:=TVMTBuilder.Create(pvclass);
+        vmtbuilder.generate_vmt;
+        vmtbuilder.free;
+
+        restore_after_new_class(sstate,islocal,oldsymtablestack);
+      end;
+
+
+    procedure jvm_create_procvar_class(const name: TIDString; def: tdef);
+      begin
+        jvm_create_procvar_class_intern(name,def,false);
+      end;
+
+
+    procedure jvm_wrap_virtual_class_method(pd: tprocdef);
+      var
+        wrapperpd: tprocdef;
+        wrapperpv: tprocvardef;
+        typ: ttypesym;
+        wrappername: shortstring;
+      begin
+        if (po_external in pd.procoptions) or
+           (oo_is_external in pd.struct.objectoptions) then
+          exit;
+        { the JVM does not support virtual class methods -> we generate
+          wrappers with the original name so they can be called normally,
+          and these wrappers will then perform a dynamic lookup. To enable
+          calling the class method by its intended name from external Java code,
+          we have to change its external name so that we give that original
+          name to the wrapper function -> "switch" the external names around for
+          the original and wrapper methods }
+
+        { replace importname of original procdef }
+        include(pd.procoptions,po_has_importname);
+        if not assigned(pd.import_name) then
+          wrappername:=pd.procsym.realname
+        else
+          wrappername:=pd.import_name^;
+        stringdispose(pd.import_name);
+        pd.import_name:=stringdup(wrappername+'__fpcvirtualclassmethod__');
+
+        { wrapper is part of the same symtable as the original procdef }
+        symtablestack.push(pd.owner);
+        { get a copy of the virtual class method }
+        wrapperpd:=tprocdef(pd.getcopy);
+        { this one is not virtual nor override }
+        exclude(wrapperpd.procoptions,po_virtualmethod);
+        exclude(wrapperpd.procoptions,po_overridingmethod);
+        { import/external name = name of original class method }
+        stringdispose(wrapperpd.import_name);
+        wrapperpd.import_name:=stringdup(wrappername);
+        include(wrapperpd.procoptions,po_has_importname);
+        { associate with wrapper procsym (Pascal-level name = wrapper name ->
+          in callnodes, we will have to replace the calls to virtual class
+          methods with calls to the wrappers) }
+        finish_copied_procdef(wrapperpd,pd.import_name^,pd.owner,tabstractrecorddef(pd.owner.defowner));
+
+        { we only have to generate the dispatching routine for non-overriding
+          methods; the overriding ones can use the original one, but generate
+          a skeleton for that anyway because the overriding one may still
+          change the visibility (but we can just call the inherited routine
+          in that case) }
+        if po_overridingmethod in pd.procoptions then
+          begin
+            { by default do not include this routine when looking for overloads }
+            include(wrapperpd.procoptions,po_ignore_for_overload_resolution);
+            wrapperpd.synthetickind:=tsk_anon_inherited;
+            symtablestack.pop(pd.owner);
+            exit;
+          end;
+
+        { implementation }
+        wrapperpd.synthetickind:=tsk_jvm_virtual_clmethod;
+        wrapperpd.skpara:=pd;
+        { also create procvar type that we can use in the implementation }
+        wrapperpv:=tprocvardef(pd.getcopyas(procvardef,pc_normal));
+        wrapperpv.calcparas;
+        { no use in creating a callback wrapper here, this procvar type isn't
+          for public consumption }
+        jvm_create_procvar_class_intern('__fpc_virtualclassmethod_pv_t'+tostr(wrapperpd.defid),wrapperpv,true);
+        { create alias for the procvar type so we can use it in generated
+          Pascal code }
+        typ:=ttypesym.create('__fpc_virtualclassmethod_pv_t'+tostr(wrapperpd.defid),wrapperpv);
+        wrapperpv.classdef.typesym.visibility:=vis_strictprivate;
+        symtablestack.top.insert(typ);
+        symtablestack.pop(pd.owner);
+      end;
+
+
+    procedure jvm_wrap_virtual_constructor(pd: tprocdef);
+      var
+        wrapperpd: tprocdef;
+      begin
+        { to avoid having to implement procvar-like support for dynamically
+          invoking constructors, call the constructors from virtual class
+          methods and replace calls to the constructors with calls to the
+          virtual class methods -> we can reuse lots of infrastructure }
+        if (po_external in pd.procoptions) or
+           (oo_is_external in pd.struct.objectoptions) then
+          exit;
+        { wrapper is part of the same symtable as the original procdef }
+        symtablestack.push(pd.owner);
+        { get a copy of the constructor }
+        wrapperpd:=tprocdef(pd.getcopyas(procdef,pc_bareproc));
+        { this one is a class method rather than a constructor }
+        include(wrapperpd.procoptions,po_classmethod);
+        wrapperpd.proctypeoption:=potype_function;
+        wrapperpd.returndef:=tobjectdef(pd.owner.defowner);
+
+        { import/external name = name of original constructor (since
+          constructors don't have names in Java, this won't conflict with the
+          original constructor definition) }
+        stringdispose(wrapperpd.import_name);
+        wrapperpd.import_name:=stringdup(pd.procsym.realname);
+        { associate with wrapper procsym (Pascal-level name = wrapper name ->
+          in callnodes, we will have to replace the calls to virtual
+          constructors with calls to the wrappers) }
+        finish_copied_procdef(wrapperpd,pd.procsym.realname+'__fpcvirtconstrwrapper__',pd.owner,tabstractrecorddef(pd.owner.defowner));
+        { since it was a bare copy, insert the self parameter (we can't just
+          copy the vmt parameter from the constructor, that's different) }
+        insert_self_and_vmt_para(wrapperpd);
+        wrapperpd.calcparas;
+        { implementation: call through to the constructor
+          Exception: if the current class is abstract, do not call the
+            constructor, since abstract class cannot be constructed (and the
+            Android verifier does not accept such code, even if it is
+            unreachable) }
+        wrapperpd.synthetickind:=tsk_callthrough_nonabstract;
+        wrapperpd.skpara:=pd;
+        symtablestack.pop(pd.owner);
+        { and now wrap this generated virtual static method itself as well }
+        jvm_wrap_virtual_class_method(wrapperpd);
+      end;
+
+
+    procedure jvm_wrap_virtual_class_methods(obj: tobjectdef);
+      var
+        i: longint;
+        def: tdef;
+      begin
+        { new methods will be inserted while we do this, but since
+          symtable.deflist.count is evaluated at the start of the loop that
+          doesn't matter }
+        for i:=0 to obj.symtable.deflist.count-1 do
+          begin
+            def:=tdef(obj.symtable.deflist[i]);
+            if def.typ<>procdef then
+              continue;
+            if [po_classmethod,po_virtualmethod]<=tprocdef(def).procoptions then
+              jvm_wrap_virtual_class_method(tprocdef(def))
+            else if (tprocdef(def).proctypeoption=potype_constructor) and
+               (po_virtualmethod in tprocdef(def).procoptions) then
+              jvm_wrap_virtual_constructor(tprocdef(def));
+          end;
+      end;
+
+
+    function jvm_add_typed_const_initializer(csym: tconstsym): tstaticvarsym;
+      var
+        ssym: tstaticvarsym;
+        esym: tenumsym;
+        i: longint;
+        sstate: tscannerstate;
+        elemdef: tdef;
+        elemdefname,
+        conststr: ansistring;
+        first: boolean;
+      begin
+        case csym.constdef.typ of
+          enumdef:
+            begin
+              { make sure we don't emit a definition for this field (we'll do
+                that for the constsym already) -> mark as external }
+              ssym:=tstaticvarsym.create(internal_static_field_name(csym.realname),vs_final,csym.constdef,[vo_is_external]);
+              csym.owner.insert(ssym);
+              { alias storage to the constsym }
+              ssym.set_mangledname(csym.realname);
+              for i:=0 to tenumdef(csym.constdef).symtable.symlist.count-1 do
+                begin
+                  esym:=tenumsym(tenumdef(csym.constdef).symtable.symlist[i]);
+                  if esym.value=csym.value.valueord.svalue then
+                    break;
+                  esym:=nil;
+                end;
+              { can happen in case of explicit typecast from integer constant
+                to enum type }
+              if not assigned(esym) then
+                begin
+                  MessagePos(csym.fileinfo,parser_e_range_check_error);
+                  exit;
+                end;
+              replace_scanner('jvm_enum_const',sstate);
+              str_parse_typedconst(current_asmdata.asmlists[al_typedconsts],esym.name+';',ssym);
+              restore_scanner(sstate);
+              result:=ssym;
+            end;
+          setdef:
+            begin
+              replace_scanner('jvm_set_const',sstate);
+              { make sure we don't emit a definition for this field (we'll do
+                that for the constsym already) -> mark as external;
+                on the other hand, we don't create instances for constsyms in
+                (or external syms) the program/unit initialization code -> add
+                vo_has_local_copy to indicate that this should be done after all
+                (in thlcgjvm.allocate_implicit_structs_for_st_with_base_ref) }
+
+              { the constant can be defined in the body of a function and its
+                def can also belong to that -> will be freed when the function
+                has been compiler -> insert a copy in the unit's staticsymtable
+              }
+              symtablestack.push(current_module.localsymtable);
+              ssym:=tstaticvarsym.create(internal_static_field_name(csym.realname),vs_final,tsetdef(csym.constdef).getcopy,[vo_is_external,vo_has_local_copy]);
+              symtablestack.top.insert(ssym);
+              symtablestack.pop(current_module.localsymtable);
+              { alias storage to the constsym }
+              ssym.set_mangledname(csym.realname);
+              { ensure that we allocate space for global symbols (won't actually
+                allocate space for this one, since it's external, but for the
+                constsym) }
+              cnodeutils.insertbssdata(ssym);
+              elemdef:=tsetdef(csym.constdef).elementdef;
+              if not assigned(elemdef) then
+                begin
+                  internalerror(2011070502);
+                end
+              else
+                begin
+                  elemdefname:=elemdef.typename;
+                  conststr:='[';
+                  first:=true;
+                  for i:=0 to 255 do
+                    if i in pnormalset(csym.value.valueptr)^ then
+                      begin
+                        if not first then
+                          conststr:=conststr+',';
+                        first:=false;
+                        { instead of looking up all enum value names/boolean
+                           names, type cast integers to the required type }
+                        conststr:=conststr+elemdefname+'('+tostr(i)+')';
+                      end;
+                  conststr:=conststr+'];';
+                end;
+              str_parse_typedconst(current_asmdata.asmlists[al_typedconsts],conststr,ssym);
+              restore_scanner(sstate);
+              result:=ssym;
+            end;
+          else
+            internalerror(2011062701);
+        end;
+      end;
+
+
+    function jvm_wrap_method_with_vis(pd: tprocdef; vis: tvisibility): tprocdef;
+      var
+        obj: tabstractrecorddef;
+        visname: string;
+      begin
+        obj:=current_structdef;
+        { if someone gets the idea to add a property to an external class
+          definition, don't try to wrap it since we cannot add methods to
+          external classes }
+        if oo_is_external in obj.objectoptions then
+          begin
+            result:=pd;
+            exit
+          end;
+        symtablestack.push(obj.symtable);
+        result:=tprocdef(pd.getcopy);
+        result.visibility:=vis;
+        visname:=visibilityName[vis];
+        replace(visname,' ','_');
+        { create a name that is unique amongst all units (start with '$unitname$$') and
+          unique in this unit (result.defid) }
+        finish_copied_procdef(result,'$'+current_module.realmodulename^+'$$'+tostr(result.defid)+pd.procsym.realname+'$'+visname,obj.symtable,obj);
+        { in case the referred method is from an external class }
+        exclude(result.procoptions,po_external);
+        { not virtual/override/abstract/... }
+        result.procoptions:=result.procoptions*[po_classmethod,po_staticmethod,po_varargs,po_public];
+        result.synthetickind:=tsk_callthrough;
+        { so we know the name of the routine to call through to }
+        result.skpara:=pd;
+        symtablestack.pop(obj.symtable);
+      end;
+
+
+    procedure jvm_create_getter_or_setter_for_property(p: tpropertysym; getter: boolean);
+      var
+        obj: tabstractrecorddef;
+        ps: tprocsym;
+        pvs: tparavarsym;
+        pd: tprocdef;
+        tmpaccesslist: tpropaccesslist;
+        callthroughpropname,
+        name: string;
+        callthroughprop: tpropertysym;
+        accesstyp: tpropaccesslisttypes;
+      begin
+        obj:=current_structdef;
+        { if someone gets the idea to add a property to an external class
+          definition, don't try to wrap it since we cannot add methods to
+          external classes }
+        if oo_is_external in obj.objectoptions then
+          exit;
+        symtablestack.push(obj.symtable);
+
+        if getter then
+          accesstyp:=palt_read
+        else
+          accesstyp:=palt_write;
+
+        { create a property for the old symaccesslist with a new name, so that
+          we can reuse it in the implementation (rather than having to
+          translate the symaccesslist back to Pascal code) }
+        callthroughpropname:='__fpc__'+p.realname;
+        if getter then
+          callthroughpropname:=callthroughpropname+'__getter_wrapper'
+        else
+          callthroughpropname:=callthroughpropname+'__setter_wrapper';
+        callthroughprop:=tpropertysym.create(callthroughpropname);
+        callthroughprop.visibility:=p.visibility;
+        callthroughprop.default:=longint($80000000);
+        if sp_static in p.symoptions then
+          include(callthroughprop.symoptions, sp_static);
+        { copy original property target to callthrough property (and replace
+          original one with the new empty list; will be filled in later) }
+        tmpaccesslist:=callthroughprop.propaccesslist[accesstyp];
+        callthroughprop.propaccesslist[accesstyp]:=p.propaccesslist[accesstyp];
+        p.propaccesslist[accesstyp]:=tmpaccesslist;
+        p.owner.insert(callthroughprop);
+
+        { we can't use str_parse_method_dec here because the type of the field
+          may not be visible at the Pascal level }
+
+        { create procdef }
+        pd:=tprocdef.create(normal_function_level);
+        if df_generic in obj.defoptions then
+          include(pd.defoptions,df_generic);
+
+        { construct procsym name (unique for this access; reusing the same
+          helper for multiple accesses to the same field is hard because the
+          propacesslist can contain subscript nodes etc) }
+        name:=visibilityName[p.visibility];
+        replace(name,' ','_');
+        if getter then
+          name:=name+'$getter'
+        else
+          name:=name+'$setter';
+        name:='$'+obj.symtable.realname^+'$'+p.realname+'$'+name+'$'+tostr(pd.defid);
+
+        { new procsym }
+        ps:=tprocsym.create(name);
+        obj.symtable.insert(ps);
+        { associate procsym with procdef}
+        pd.procsym:=ps;
+
+        { method of this objectdef }
+        pd.struct:=obj;
+        { visibility }
+        pd.visibility:=p.visibility;
+        { function/procedure }
+        if getter then
+          begin
+            pd.proctypeoption:=potype_function;
+            pd.synthetickind:=tsk_field_getter;
+            { result type }
+            pd.returndef:=p.propdef;
+          end
+        else
+          begin
+            pd.proctypeoption:=potype_procedure;
+            pd.synthetickind:=tsk_field_setter;
+            pd.returndef:=voidtype;
+            { parameter with value to set }
+            pvs:=tparavarsym.create('__fpc_newval__',10,vs_const,p.propdef,[]);
+            pd.parast.insert(pvs);
+          end;
+        pd.skpara:=callthroughprop;
+        { needs to be exported }
+        include(pd.procoptions,po_global);
+        { class property -> static class method }
+        if sp_static in p.symoptions then
+          pd.procoptions:=pd.procoptions+[po_classmethod,po_staticmethod];
+        { calling convention, self, ... }
+        if obj.typ=recorddef then
+          handle_calling_convention(pd,[hcc_check])
+        else
+          handle_calling_convention(pd,hcc_all);
+        { register forward declaration with procsym }
+        proc_add_definition(pd);
+
+        { make the property call this new function }
+        p.propaccesslist[accesstyp].addsym(sl_call,ps);
+        p.propaccesslist[accesstyp].procdef:=pd;
+
+        symtablestack.pop(obj.symtable);
+      end;
+
+
+    procedure jvm_create_getter_for_property(p: tpropertysym);
+      begin
+        jvm_create_getter_or_setter_for_property(p,true);
+      end;
+
+
+    procedure jvm_create_setter_for_property(p: tpropertysym);
+      begin
+        jvm_create_getter_or_setter_for_property(p,false);
+      end;
+
+end.

compiler/jvm/rgcpu.pas

@@ -0,0 +1,358 @@
+{
+    Copyright (c) 2010 by Jonas Maebe
+
+    This unit implements the JVM specific class for the register
+    allocator
+
+    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 rgcpu;
+
+{$i fpcdefs.inc}
+
+  interface
+
+    uses
+      aasmbase,aasmcpu,aasmtai,aasmdata,
+      cgbase,cgutils,
+      cpubase,
+      rgobj;
+
+    type
+      tspilltemps = array[tregistertype] of ^Tspill_temp_list;
+
+      { trgcpu }
+
+      trgcpu=class(trgobj)
+       protected
+        class procedure do_spill_replace_all(list:TAsmList;instr:taicpu;const spilltemps: tspilltemps);
+        class procedure remove_dummy_load_stores(list: TAsmList; headertai: tai);
+       public
+        { performs the register allocation for *all* register types }
+        class procedure do_all_register_allocation(list: TAsmList; headertai: tai);
+      end;
+
+
+implementation
+
+    uses
+      verbose,cutils,
+      globtype,globals,
+      cgobj,
+      tgobj;
+
+    { trgcpu }
+
+    class procedure trgcpu.do_spill_replace_all(list:TAsmList;instr:taicpu;const spilltemps: tspilltemps);
+      var
+        l: longint;
+        reg: tregister;
+      begin
+        { jvm instructions never have more than one memory (virtual register)
+          operand, so there is no danger of superregister conflicts }
+        for l:=0 to instr.ops-1 do
+          if instr.oper[l]^.typ=top_reg then
+            begin
+              reg:=instr.oper[l]^.reg;
+              instr.loadref(l,spilltemps[getregtype(reg)]^[getsupreg(reg)]);
+            end;
+      end;
+
+
+    class procedure trgcpu.remove_dummy_load_stores(list: TAsmList; headertai: tai);
+
+      type
+        taitypeset =  set of taitype;
+
+      function nextskipping(p: tai; const skip: taitypeset): tai;
+        begin
+          result:=p;
+          if not assigned(result) then
+            exit;
+          repeat
+            result:=tai(result.next);
+          until not assigned(result) or
+                not(result.typ in skip);
+        end;
+
+      function issimpleregstore(p: tai; var reg: tregister; doubleprecisionok: boolean): boolean;
+        const
+          simplestoressp = [a_astore,a_fstore,a_istore];
+          simplestoresdp = [a_dstore,a_lstore];
+        begin
+          result:=
+            assigned(p) and
+            (p.typ=ait_instruction) and
+            ((taicpu(p).opcode in simplestoressp) or
+             (doubleprecisionok and
+              (taicpu(p).opcode in simplestoresdp))) and
+            ((reg=NR_NO) or
+             (taicpu(p).oper[0]^.typ=top_reg) and
+             (taicpu(p).oper[0]^.reg=reg));
+          if result and
+             (reg=NR_NO) then
+            reg:=taicpu(p).oper[0]^.reg;
+        end;
+
+      function issimpleregload(p: tai; var reg: tregister; doubleprecisionok: boolean): boolean;
+        const
+          simpleloadssp = [a_aload,a_fload,a_iload];
+          simpleloadsdp = [a_dload,a_lload];
+        begin
+          result:=
+            assigned(p) and
+            (p.typ=ait_instruction) and
+            ((taicpu(p).opcode in simpleloadssp) or
+             (doubleprecisionok and
+              (taicpu(p).opcode in simpleloadsdp))) and
+            ((reg=NR_NO) or
+             (taicpu(p).oper[0]^.typ=top_reg) and
+             (taicpu(p).oper[0]^.reg=reg));
+          if result and
+             (reg=NR_NO) then
+            reg:=taicpu(p).oper[0]^.reg;
+        end;
+
+      function isregallocoftyp(p: tai; typ: TRegAllocType;var reg: tregister): boolean;
+        begin
+          result:=
+            assigned(p) and
+            (p.typ=ait_regalloc) and
+            (tai_regalloc(p).ratype=typ);
+          if result then
+            if reg=NR_NO then
+              reg:=tai_regalloc(p).reg
+            else
+              result:=tai_regalloc(p).reg=reg;
+        end;
+
+      function regininstruction(p: tai; reg: tregister): boolean;
+        var
+          sr: tsuperregister;
+          i: longint;
+        begin
+          result:=false;
+          if p.typ<>ait_instruction then
+            exit;
+          sr:=getsupreg(reg);
+          for i:=0 to taicpu(p).ops-1 do
+            case taicpu(p).oper[0]^.typ of
+              top_reg:
+                if (getsupreg(taicpu(p).oper[0]^.reg)=sr) then
+                  exit(true);
+              top_ref:
+                begin
+                  if (getsupreg(taicpu(p).oper[0]^.ref^.base)=sr) then
+                    exit(true);
+                  if (getsupreg(taicpu(p).oper[0]^.ref^.index)=sr) then
+                    exit(true);
+                  if (getsupreg(taicpu(p).oper[0]^.ref^.indexbase)=sr) then
+                    exit(true);
+                  if (getsupreg(taicpu(p).oper[0]^.ref^.indexbase)=sr) then
+                    exit(true);
+                end;
+            end;
+        end;
+
+      function try_remove_store_dealloc_load(var p: tai): boolean;
+        var
+          dealloc,
+          load: tai;
+          reg: tregister;
+        begin
+          result:=false;
+          { check for:
+              store regx
+              dealloc regx
+              load regx
+            and remove. We don't have to check that the load/store
+            types match, because they have to for this to be
+            valid JVM code }
+          dealloc:=nextskipping(p,[ait_comment]);
+          load:=nextskipping(dealloc,[ait_comment]);
+          reg:=NR_NO;
+          if issimpleregstore(p,reg,true) and
+             isregallocoftyp(dealloc,ra_dealloc,reg) and
+             issimpleregload(load,reg,true) then
+            begin
+              { remove the whole sequence: the store }
+              list.remove(p);
+              p.free;
+              p:=Tai(load.next);
+              { the load }
+              list.remove(load);
+              load.free;
+
+              result:=true;
+            end;
+        end;
+
+
+      var
+        p,next,nextnext: tai;
+        reg: tregister;
+        removedsomething: boolean;
+      begin
+        repeat
+          removedsomething:=false;
+          p:=headertai;
+          while assigned(p) do
+            begin
+              case p.typ of
+                ait_regalloc:
+                  begin
+                    reg:=NR_NO;
+                    next:=nextskipping(p,[ait_comment]);
+                    nextnext:=nextskipping(next,[ait_comment,ait_regalloc]);
+                    if assigned(nextnext) then
+                      begin
+                        { remove
+                            alloc reg
+                            dealloc reg
+
+                          (can appear after optimisations, necessary to prevent
+                           useless stack slot allocations) }
+                        if isregallocoftyp(p,ra_alloc,reg) and
+                           isregallocoftyp(next,ra_dealloc,reg) and
+                           not regininstruction(nextnext,reg) then
+                          begin
+                            list.remove(p);
+                            p.free;
+                            p:=tai(next.next);
+                            list.remove(next);
+                            next.free;
+                            removedsomething:=true;
+                            continue;
+                          end;
+                      end;
+                  end;
+                ait_instruction:
+                  begin
+                    if try_remove_store_dealloc_load(p) then
+                      begin
+                        removedsomething:=true;
+                        continue;
+                      end;
+                    { todo in peephole optimizer:
+                        alloc regx // not double precision
+                        store regx // not double precision
+                        load  regy or memy
+                        dealloc regx
+                        load regx
+                      -> change into
+                        load regy or memy
+                        swap       // can only handle single precision
+
+                      and then
+                        swap
+                        <commutative op>
+                       -> remove swap
+                    }
+                  end;
+              end;
+              p:=tai(p.next);
+            end;
+        until not removedsomething;
+      end;
+
+
+    class procedure trgcpu.do_all_register_allocation(list: TAsmList; headertai: tai);
+      var
+        spill_temps : tspilltemps;
+        templist : TAsmList;
+        intrg,
+        fprg     : trgcpu;
+        p,q      : tai;
+        size     : longint;
+      begin
+        { Since there are no actual registers, we simply spill everything. We
+          use tt_regallocator temps, which are not used by the temp allocator
+          during code generation, so that we cannot accidentally overwrite
+          any temporary values }
+
+        { get references to all register allocators }
+        intrg:=trgcpu(cg.rg[R_INTREGISTER]);
+        fprg:=trgcpu(cg.rg[R_FPUREGISTER]);
+        { determine the live ranges of all registers }
+        intrg.insert_regalloc_info_all(list);
+        fprg.insert_regalloc_info_all(list);
+        { Don't do the actual allocation when -sr is passed }
+        if (cs_no_regalloc in current_settings.globalswitches) then
+          exit;
+        { remove some simple useless store/load sequences }
+        remove_dummy_load_stores(list,headertai);
+        { allocate room to store the virtual register -> temp mapping }
+        spill_temps[R_INTREGISTER]:=allocmem(sizeof(treference)*intrg.maxreg);
+        spill_temps[R_FPUREGISTER]:=allocmem(sizeof(treference)*fprg.maxreg);
+        { List to insert temp allocations into }
+        templist:=TAsmList.create;
+        { allocate/replace all registers }
+        p:=headertai;
+        while assigned(p) do
+          begin
+            case p.typ of
+              ait_regalloc:
+                with Tai_regalloc(p) do
+                  begin
+                    case getregtype(reg) of
+                      R_INTREGISTER:
+                        if getsubreg(reg)=R_SUBD then
+                          size:=4
+                        else
+                          size:=8;
+                      R_ADDRESSREGISTER:
+                        size:=4;
+                      R_FPUREGISTER:
+                        if getsubreg(reg)=R_SUBFS then
+                          size:=4
+                        else
+                          size:=8;
+                      else
+                        internalerror(2010122912);
+                    end;
+                    case ratype of
+                      ra_alloc :
+                        tg.gettemp(templist,
+                                   size,1,
+                                   tt_regallocator,spill_temps[getregtype(reg)]^[getsupreg(reg)]);
+                      ra_dealloc :
+                        begin
+                          tg.ungettemp(templist,spill_temps[getregtype(reg)]^[getsupreg(reg)]);
+                          { don't invalidate the temp reference, may still be used one instruction
+                            later }
+                        end;
+                    end;
+                    { insert the tempallocation/free at the right place }
+                    list.insertlistbefore(p,templist);
+                    { remove the register allocation info for the register
+                      (p.previous is valid because we just inserted the temp
+                       allocation/free before p) }
+                    q:=Tai(p.previous);
+                    list.remove(p);
+                    p.free;
+                    p:=q;
+                  end;
+              ait_instruction:
+                do_spill_replace_all(list,taicpu(p),spill_temps);
+            end;
+            p:=Tai(p.next);
+          end;
+        freemem(spill_temps[R_INTREGISTER]);
+        freemem(spill_temps[R_FPUREGISTER]);
+        templist.free;
+      end;
+
+end.

compiler/jvm/rjvmcon.inc

@@ -0,0 +1,4 @@
+{ don't edit, this file is generated from jvmreg.dat }
+NR_NO = tregister($00000000);
+NR_R0 = tregister($01000000);
+NR_R1 = tregister($01000001);

compiler/jvm/rjvmnor.inc

@@ -0,0 +1,2 @@
+{ don't edit, this file is generated from jvmreg.dat }
+3

compiler/jvm/rjvmnum.inc

@@ -0,0 +1,4 @@
+{ don't edit, this file is generated from jvmreg.dat }
+tregister($00000000),
+tregister($01000000),
+tregister($01000001)

compiler/jvm/rjvmrni.inc

@@ -0,0 +1,4 @@
+{ don't edit, this file is generated from jvmreg.dat }
+0,
+1,
+2

compiler/jvm/rjvmsri.inc

@@ -0,0 +1,4 @@
+{ don't edit, this file is generated from jvmreg.dat }
+0,
+2,
+1

compiler/jvm/rjvmstd.inc

@@ -0,0 +1,4 @@
+{ don't edit, this file is generated from jvmreg.dat }
+'INVALID',
+'stacktopptr',
+'stackptr'

compiler/jvm/rjvmsup.inc

@@ -0,0 +1,4 @@
+{ don't edit, this file is generated from jvmreg.dat }
+RS_NO = $00;
+RS_R0 = $00;
+RS_R1 = $01;

compiler/jvm/tgcpu.pas

@@ -0,0 +1,262 @@
+{
+    Copyright (C) 2010 by Jonas Maebe
+
+    This unit handles the temporary variables for the JVM
+
+    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.
+
+ ****************************************************************************
+}
+{
+  This unit handles the temporary variables for the JVM.
+}
+unit tgcpu;
+
+{$i fpcdefs.inc}
+
+  interface
+
+    uses
+       globtype,
+       aasmdata,
+       cgutils,
+       symtype,tgobj;
+
+    type
+
+       { ttgjvm }
+
+       ttgjvm = class(ttgobj)
+        protected
+         procedure getimplicitobjtemp(list: TAsmList; def: tdef; temptype: ttemptype; out ref: treference);
+         function getifspecialtemp(list: TAsmList; def: tdef; forcesize: aint; temptype: ttemptype; out ref: treference): boolean;
+         function alloctemp(list: TAsmList; size, alignment: longint; temptype: ttemptype; def: tdef): longint; override;
+        public
+         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;
+         procedure gethltemptyped(list: TAsmList; def: tdef; temptype: ttemptype; out ref: treference); override;
+       end;
+
+  implementation
+
+    uses
+       verbose,
+       cgbase,
+       symconst,symdef,symsym,defutil,
+       cpubase,aasmcpu,
+       hlcgobj,hlcgcpu;
+
+
+    { ttgjvm }
+
+    procedure ttgjvm.getimplicitobjtemp(list: TAsmList; def: tdef; temptype: ttemptype; out ref: treference);
+      var
+        sym: tsym;
+        pd: tprocdef;
+      begin
+        gettemp(list,java_jlobject.size,java_jlobject.alignment,temptype,ref);
+        list.concat(taicpu.op_sym(a_new,current_asmdata.RefAsmSymbol(tabstractrecorddef(def).jvm_full_typename(true))));
+        { the constructor doesn't return anything, so put a duplicate of the
+          self pointer on the evaluation stack for use as function result
+          after the constructor has run }
+        list.concat(taicpu.op_none(a_dup));
+        thlcgjvm(hlcg).incstack(list,2);
+        { call the constructor }
+        sym:=tsym(tabstractrecorddef(def).symtable.find('CREATE'));
+        if assigned(sym) and
+           (sym.typ=procsym) then
+          begin
+            pd:=tprocsym(sym).find_bytype_parameterless(potype_constructor);
+            if not assigned(pd) then
+              internalerror(2011032701);
+          end
+        else
+          internalerror(2011060301);
+        hlcg.a_call_name(list,pd,pd.mangledname,false);
+        thlcgjvm(hlcg).decstack(list,1);
+        { store reference to instance }
+        thlcgjvm(hlcg).a_load_stack_ref(list,java_jlobject,ref,0);
+      end;
+
+
+    function ttgjvm.getifspecialtemp(list: TAsmList; def: tdef; forcesize: aint; temptype: ttemptype; out ref: treference): boolean;
+      var
+        eledef: tdef;
+        ndim: longint;
+        sym: tsym;
+        pd: tprocdef;
+      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
+                    if forcesize<>-1 then
+                      thlcgjvm(hlcg).a_load_const_stack(list,s32inttype,forcesize div tarraydef(eledef).elesize,R_INTREGISTER)
+                    else
+                      thlcgjvm(hlcg).a_load_const_stack(list,s32inttype,tarraydef(eledef).elecount,R_INTREGISTER);
+                    eledef:=tarraydef(eledef).elementdef;
+                    inc(ndim);
+                    forcesize:=-1;
+                  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;
+          recorddef:
+            begin
+              getimplicitobjtemp(list,def,temptype,ref);
+              result:=true;
+            end;
+          setdef:
+            begin
+              if tsetdef(def).elementdef.typ=enumdef then
+                begin
+                  { load enum class type }
+                  list.concat(taicpu.op_sym(a_ldc,current_asmdata.RefAsmSymbol(tenumdef(tsetdef(def).elementdef).getbasedef.classdef.jvm_full_typename(true))));
+                  thlcgjvm(hlcg).incstack(current_asmdata.CurrAsmList,1);
+                  { call tenumset.noneOf() class method }
+                  sym:=tsym(tobjectdef(java_juenumset).symtable.find('NONEOF'));
+                  if assigned(sym) and
+                     (sym.typ=procsym) then
+                    begin
+                      if tprocsym(sym).procdeflist.Count<>1 then
+                        internalerror(2011062801);
+                      pd:=tprocdef(tprocsym(sym).procdeflist[0]);
+                    end;
+                  hlcg.a_call_name(list,pd,pd.mangledname,false);
+                  { static calls method replaces parameter with set instance
+                    -> no change in stack height }
+                end
+              else
+                begin
+                  list.concat(taicpu.op_sym(a_new,current_asmdata.RefAsmSymbol(java_jubitset.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(java_jubitset.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(2011062802);
+                    end
+                  else
+                    internalerror(2011062803);
+                  hlcg.a_call_name(list,pd,pd.mangledname,false);
+                  { duplicate self pointer is removed }
+                  thlcgjvm(hlcg).decstack(list,1);
+                end;
+              { store reference to instance }
+              gettemp(list,java_jlobject.size,java_jlobject.alignment,temptype,ref);
+              thlcgjvm(hlcg).a_load_stack_ref(list,java_jlobject,ref,0);
+              result:=true;
+            end;
+          procvardef:
+            begin
+              if not tprocvardef(def).is_addressonly then
+                begin
+                  getimplicitobjtemp(list,tprocvardef(def).classdef,temptype,ref);
+                  result:=true;
+                end;
+            end;
+          stringdef:
+            begin
+              if is_shortstring(def) then
+                begin
+                  gettemp(list,java_jlobject.size,java_jlobject.alignment,temptype,ref);
+                  { add the maxlen parameter (s8inttype because parameters must
+                    be sign extended) }
+                  thlcgjvm(hlcg).a_load_const_stack(list,s8inttype,shortint(tstringdef(def).len),R_INTREGISTER);
+                  { call the constructor }
+                  sym:=tsym(tobjectdef(java_shortstring).symtable.find('CREATEEMPTY'));
+                  if assigned(sym) and
+                     (sym.typ=procsym) then
+                    begin
+                      if tprocsym(sym).procdeflist.Count<>1 then
+                        internalerror(2011052404);
+                      pd:=tprocdef(tprocsym(sym).procdeflist[0]);
+                    end;
+                  hlcg.a_call_name(list,pd,pd.mangledname,false);
+                  { static calls method replaces parameter with string instance
+                    -> no change in stack height }
+                  { store reference to instance }
+                  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
+          FPC) temps on the stack. double and int64 are 2 slots, the rest is one slot.
+          There are no problems with reusing the same slot for a value of a different
+          type. There are no alignment requirements either. }
+        if size<4 then
+          size:=4;
+        if not(size in [4,8]) then
+          internalerror(2010121401);
+        { don't pass on "def", since we don't care if a slot is used again for a
+          different type }
+        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;
+
+    procedure ttgjvm.gethltemptyped(list: TAsmList; def: tdef; temptype: ttemptype; out ref: treference);
+      begin
+        gethltemp(list,def,def.size,temptype,ref);
+      end;
+
+
+begin
+  tgobjclass:=ttgjvm;
+end.

compiler/link.pas

@@ -718,7 +718,7 @@ Implementation
              exitcode:=shell(maybequoted(command)+' '+para)
            else
              try
-               exitcode:=ExecuteProcess(command,para);
+               exitcode:=RequotedExecuteProcess(command,para);
              except on E:EOSError do
                begin
                  Message(exec_e_cant_call_linker);

compiler/m68k/hlcgcpu.pas

@@ -0,0 +1,45 @@
+{
+    Copyright (c) 1998-2010 by Florian Klaempfl and Jonas Maebe
+    Member of the Free Pascal development team
+
+    This unit contains routines to create a pass-through high-level code
+    generator. This is used by most regular code generators.
+
+    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 hlcgcpu;
+
+{$i fpcdefs.inc}
+
+interface
+
+  procedure create_hlcodegen;
+
+implementation
+
+  uses
+    hlcgobj, hlcg2ll,
+    cgcpu;
+
+  procedure create_hlcodegen;
+    begin
+      hlcg:=thlcg2ll.create;
+      create_codegen;
+    end;
+
+end.

compiler/mips/hlcgcpu.pas

@@ -0,0 +1,45 @@
+{
+    Copyright (c) 1998-2010 by Florian Klaempfl and Jonas Maebe
+    Member of the Free Pascal development team
+
+    This unit contains routines to create a pass-through high-level code
+    generator. This is used by most regular code generators.
+
+    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 hlcgcpu;
+
+{$i fpcdefs.inc}
+
+interface
+
+  procedure create_hlcodegen;
+
+implementation
+
+  uses
+    hlcgobj, hlcg2ll,
+    cgcpu;
+
+  procedure create_hlcodegen;
+    begin
+      hlcg:=thlcg2ll.create;
+      create_codegen;
+    end;
+
+end.

compiler/mips/ncpuset.pas

@@ -48,7 +48,7 @@ uses
   cpubase,
   aasmbase, aasmtai, aasmcpu, aasmdata,
   cgbase, cgutils, cgobj,
-  procinfo;
+  defutil,procinfo;
 
 procedure tcpucasenode.optimizevalues(var max_linear_list: aint; var max_dist: aword);
 begin
@@ -70,6 +70,7 @@ var
   indexreg, jmpreg, basereg: tregister;
   href:  treference;
   jumpsegment: TAsmlist;
+  opcgsize: tcgsize;
 
   procedure genitem(t: pcaselabel);
   var
@@ -88,13 +89,14 @@ var
   end;
 
 begin
+  opcgsize:=def_cgsize(opsize);
   jumpsegment := current_procinfo.aktlocaldata;
   if not (jumptable_no_range) then
     begin
       { case expr less than min_ => goto elselabel }
-      cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opsize, jmp_lt, aint(min_), hregister, elselabel);
+      cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opcgsize, jmp_lt, aint(min_), hregister, elselabel);
       { case expr greater than max_ => goto elselabel }
-      cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opsize, jmp_gt, aint(max_), hregister, elselabel);
+      cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opcgsize, jmp_gt, aint(max_), hregister, elselabel);
     end;
   current_asmdata.getjumplabel(table);
   indexreg := cg.getaddressregister(current_asmdata.CurrAsmList);

compiler/msg/errore.msg

@@ -136,7 +136,7 @@ general_f_oserror=01025_F_Operating system error: $1
 #
 # Scanner
 #
-# 02089 is the last used one
+# 02090 is the last used one
 #
 % \section{Scanner messages.}
 % This section lists the messages that the scanner emits. The scanner takes
@@ -378,11 +378,14 @@ scanner_e_illegal_alignment_directive=02088_E_Illegal alignment directive
 scanner_f_illegal_utf8_bom=02089_F_It is not possible to include a file that starts with an UTF-8 BOM in a module that uses a different code page
 % All source code that is part of a single compilation entity (program, library, unit) must be encoded
 % in the same code page
+scanner_w_directive_ignored_on_target=02090_W_Directive "$1" is ignored for the the current target platform
+% Some directives are ignored for certain targets, such as changing the
+% packrecords and packenum settings on managed platforms.
 % \end{description}
 #
 # Parser
 #
-# 03314 is the last used one
+# 03321 is the last used one
 #
 % \section{Parser messages}
 % This section lists all parser messages. The parser takes care of the
@@ -682,9 +685,10 @@ parser_e_mix_of_classes_and_objects=03093_E_The mix of different kind of objects
 % a class cannot have an object as parent and vice versa.
 parser_w_unknown_proc_directive_ignored=03094_W_Unknown procedure directive had to be ignored: "$1"
 % The procedure directive you specified is unknown.
-parser_e_absolute_only_one_var=03095_E_absolute can only be associated to one variable
-% You cannot specify more than one variable before the \var{absolute} directive.
-% Thus, the following construct will provide this error:
+parser_e_directive_only_one_var=03095_E_$1 can be associated with only one variable
+% You cannot specify more than one variable before the \var{absolute}, \var{export}, \var{external},
+% \var{weakexternal}, \var{public} and \var{cvar} directives.
+% As a result, for example the following construct will provide this error:
 % \begin{verbatim}
 % Var Z : Longint;
 %     X,Y : Longint absolute Z;
@@ -1261,23 +1265,23 @@ parser_e_no_objc_published=03271_E_Objective-C classes cannot have published sec
 parser_f_need_objc=03272_F_This module requires an Objective-C mode switch to be compiled
 % This error indicates the use of Objective-C language features without an Objective-C mode switch
 % active. Enable one via the -M command line switch, or the {\$modeswitch x} directive.
-parser_e_must_use_override_objc=03273_E_Inherited methods can only be overridden in Objective-C, add "override" (inherited method defined in $1)
-parser_h_should_use_override_objc=03274_H_Inherited methods can only be overridden in Objective-C, add "override" (inherited method defined in $1).
-% It is not possible to \var{reintroduce} methods in Objective-C like in Object Pascal. Methods with the same
+parser_e_must_use_override=03273_E_Inherited methods can only be overridden in Objective-C and Java, add "override" (inherited method defined in $1)
+parser_h_should_use_override=03274_H_Inherited methods can only be overridden in Objective-C and Java, add "override" (inherited method defined in $1).
+% It is not possible to \var{reintroduce} methods in Objective-C or Java like in Object Pascal. Methods with the same
 % name always map to the same virtual method entry. In order to make this clear in the source code,
 % the compiler always requires the \var{override} directive to be specified when implementing overriding
-% Objective-C methods in Pascal. If the implementation is external, this rule is relaxed because Objective-C
-% does not have any \var{override}-style keyword (since it's the default and only behaviour in that language),
+% Objective-C or Java methods in Pascal. If the implementation is external, this rule is relaxed because Objective-C and Java
+% do not have any \var{override}-style keyword (since it's the default and only behaviour in these languages),
 % which makes it hard for automated header conversion tools to include it everywhere.
 % The type in which the inherited method is defined is explicitly mentioned, because this may either
-% be an objcclass or an objccategory.
+% be an objcclass or an objccategory in case of Objective-C.
 parser_e_objc_message_name_changed=03275_E_Message name "$1" in inherited class is different from message name "$2" in current class.
 % An overriding Objective-C method cannot have a different message name than an inherited method. The reason
 % is that these message names uniquely define the message to the Objective-C runtime, which means that
 % giving them a different message name breaks the ``override'' semantics.
-parser_e_no_objc_unique=03276_E_It is not yet possible to make unique copies of Objective-C types
-% Duplicating an Objective-C type using \var{type x = type y;} is not yet supported. You may be able to
-% obtain the desired effect using \var{type x = objcclass(y) end;} instead.
+parser_e_unique_unsupported=03276_E_It is not yet possible to make unique copies of Objective-C or Java types
+% Duplicating an Objective-C or Java type using \var{type x = type y;} is not yet supported. You may be able to
+% obtain the desired effect using \var{type x = objcclass(y) end;} resp.{} \var{type x = class(y) end;} instead.
 parser_e_no_category_as_types=03277_E_Objective-C categories and Object Pascal class helpers cannot be used as types
 % It is not possible to declare a variable as an instance of an Objective-C
 % category or an Object Pascal class helper. A category/class helper adds
@@ -1357,9 +1361,9 @@ parser_f_no_generic_inside_generic=03297_F_Declaration of generic class inside a
 % (guarded by internal error 200511173 in tscannerfile.startrecordtokens).
 % Since generics are implemented by recording tokens, it is not possible to
 % have declaration of generic class inside another generic class.
-parser_e_forward_protocol_declaration_must_be_resolved=03298_E_Forward declaration of objcprotocol "$1" must be resolved before an objcclass can conform to it
-% An objcprotocol must be fully defined before classes can conform to it.
-% This error occurs in the following situation:
+parser_e_forward_intf_declaration_must_be_resolved=03298_E_Forward declaration "$1" must be resolved before a class can conform to or implement it
+% An Objective-C protocol or Java Interface must be fully defined before classes can conform to it.
+% This error occurs in the following situation (example for Objective-C, but the same goes for Java interfaces):
 % \begin{verbatim}
 %  Type MyProtocol = objcprotoocl;
 %       ChildClass = Class(NSObject,MyProtocol)
@@ -1410,10 +1414,35 @@ parser_e_implements_no_mapping=03313_E_Interface "$1" can't have method resoluti
 parser_e_invalid_codepage=03314_E_Invalid codepage
 % When declaring a string with a given codepage, the range of valid codepages values is limited
 % to 0 to 65535.
+parser_e_final_only_const_var=03315_E_Only fields (var-sections) and constants can be final in object types
+% A final (class) field must be assigned a single value in the (class) constructor, and cannot
+% be overwritten afterwards. A final (typed) constant is read-only.
+parser_e_final_only_external=03316_E_Final fields are currently only supported for external classes
+% Support for final fields in non-external classes requires a full data flow
+% analysis implementation in FPC, which it currently still lacks.
+parser_e_no_typed_const=03317_E_Typed constants are not allowed here, only formal constants are
+% Java interfaces define a namespace in which formal constant can be defined,
+% but since they define no storage it is not possible to define typed constants
+% in them (those are more or less the same as initialised class fields).
+parser_e_java_no_inherited_constructor=03318_E_Constructors are not automatically inherited in the JVM; explicitly add a constructor that calls the inherited one if you need it
+% Java does not automatically add inherited constructors to child classes, so that they can be hidden.
+% For compatibility with external Java code, FPC does the same. If you require access to the same
+% constructors in a child class, define them in the child class and call the inherited one from
+% there.
+parser_d_internal_parser_string=03319_D_Parsing internally generated code: $1
+% The compiler sometimes internally constructs Pascal code that is subsequently
+% injected into the program. These messages display such code, in order to help
+% with debugging errors in them.
+parser_e_feature_unsupported_for_vm=03320_E_This language feature is not supported on managed VM targets
+% Certain language features are not supported on targets that are managed virtual machines.
+parser_e_jvm_invalid_virtual_constructor_call=03321_E_Calling a virtual constructor for the current instance inside another constructor is not possible on the JVM target
+% The JVM does not natively support virtual constructor. Unforunately, we are not aware of a way to
+% emulate them in a way that makes it possible to support calling virtual constructors
+% for the current instance inside another constructor.
 % \end{description}
 # Type Checking
 #
-# 04111 is the last used one
+# 04117 is the last used one
 #
 % \section{Type checking errors}
 % This section lists all errors that can occur when type checking is
@@ -1801,11 +1830,37 @@ type_w_range_check_error_bounds=04110_W_range check error while evaluating const
 % The constants are outside their allowed range.
 type_e_type_not_allowed_for_default=04111_E_This type is not supported for the Default() intrinsic
 % Some types like for example Text and File Of X are not supported by the Default intrinsic.
+type_e_java_class_method_not_static_virtual=04112_E_JVM virtual class methods cannot be static
+% Virtual class methods cannot be static when targetting the JVM platform, because
+% the self pointer is required for correct dispatching.
+type_e_invalid_final_assignment=04113_E_Final (class) fields can only be assigned in their class' (class) constructor
+% It is only possible to assign a value to a final (class) field inside a (class) constructor of its owning class.
+type_e_no_managed_formal_assign_typecast=04114_E_It is not possible to typecast untyped parameters on managed platforms, simply assign a value to them instead.
+% On managed platforms, untyped parameters are translated by the compiler into
+% the equivalent of \var{var x: BaseClassType}. Non-class-based types passed to
+% such parameters are automatically wrapped (or boxed) in a class, and after the
+% call the potentially modified value is assigned back to the original variable.
+% On the caller side, changing untyped var/out parameters happens by simply assigning
+% values to them (either class-based or primitive ones). On the caller side,
+% they will be extracted and if their type does not match the original variable's,
+% an exception will be raised.
+type_e_no_managed_assign_generic_typecast=04115_E_The assignment side of an expression cannot be typecasted to a supertype on managed platforms
+% Managed platforms guarantee type safety at the bytecode level. This means that the virtual machine must be able
+% to statically determine that no type-unsafe assignments or operations occur. By assigning a parent class type to a
+% variable of a child type by typecasting the assignment side to the parent class type, the type safety would no
+% longer be guaranteed and the generated code would fail verification at run time time.
+type_w_interface_lower_visibility=04116_W_The interface method "$1" raises the visibility of "$2" to public when accessed via an interface instance
+type_e_interface_lower_visibility=04117_E_The interface method "$1" has a higher visibility (public) than "$2"
+% All methods in an interface have always public visibility. That means that if
+% an interface method is implemented using a (strict) protected or private method,
+% this method is actually publicly accessible via the interface. On the JVM
+% target this situation results in an error because the JVM rejects such
+% attempts to circumvent the visibility rules.
 % \end{description}
 #
 # Symtable
 #
-# 05084 is the last used one
+# 05086 is the last used one
 #
 % \section{Symbol handling}
 % This section lists all the messages that concern the handling of symbols.
@@ -2036,8 +2091,8 @@ sym_w_experimental_unit=05079_W_Unit "$1" is experimental
 % declared as \var{experimental} is used. Experimental units
 % might disappear or change semantics in future versions. Usage of this unit
 % should be avoided as much as possible.
-sym_e_objc_formal_class_not_resolved=05080_E_No complete definition of the formally declared objcclass "$1" is in scope
-% Objecive-C classes can be imported formally, without using the the unit in which it is fully declared.
+sym_e_formal_class_not_resolved=05080_E_No complete definition of the formally declared class "$1" is in scope
+% Objecive-C and Java classes can be imported formally, without using the the unit in which it is fully declared.
 % This enables making forward references to such classes and breaking circular dependencies amongst units.
 % However, as soon as you wish to actually do something with an entity of this class type (such as
 % access one of its fields, send a message to it, or use it to inherit from), the compiler requires the full definition
@@ -2055,7 +2110,20 @@ sym_w_library_overload=05084_W_Possible library conflict: symbol "$1" from libra
 % the 'libname' part is only a hint, funcname might also be loaded
 % by another library. This warning appears if 'funcname' is used twice
 % with two different library names.
-%
+sym_e_duplicate_id_create_java_constructor=05085_E_Cannot add implicit constructor 'Create' because identifier already used by "$1"
+% Java does not automatically add inherited constructors to child classes, so that they can be hidden.
+% However, if a class does not explicitly declare at least one constructor, the compiler is
+% required to add a public, parameterless constructor. In Java, constructors are nameless,
+% but in FPC they are all called ``Create''. Therefore, if you do not add a constructor to
+% a Java class and furthermore use the ``Create'' identifier for another entity (e.g., a field,
+% or a parameterless method), the compiler cannot satisfy this requirement.
+sym_e_no_matching_inherited_parameterless_constructor=05086_E_Cannot generate default constructor for class, because parent has no parameterless constructor
+% Java does not automatically add inherited constructors to child classes, so that they can be hidden.
+% However, if a class does not explicitly declare at least one constructor, the compiler is
+% required to add a public, parameterless constructor. This compiler must then call
+% the parameterless constructor from the parent class inside this added constructor.
+% This is however impossible if the parent class does not declare such a constructor.
+% In this case you must add a valid constructor yourself.
 % \end{description}
 #
 # Codegenerator
@@ -3163,6 +3231,7 @@ new features, etc.):
 #    P = PowerPC targets
 #    S = Sparc targets
 #    V = Virtual machine targets
+#    J = JVM
 # The second character also indicates who will display this line,
 # (if the above character was TRUE) the current possibilities are :
 #    * = everyone
@@ -3232,11 +3301,14 @@ P*2CN_Generate nil-pointer checks (AIX-only)
 **2Cr_Range checking
 **2CR_Verify object method call validity
 **2Cs<n>_Set stack checking size to <n>
-**2Ct_Stack checking (for testing only, see manual)
+**2Ct_Stack checking (for testing only, see manual)<<<<<<< HEAD
 p*2CT<x>_Target-specific code generation options
 P*2CT<x>_Target-specific code generation options
+J*2CT<x>_Target-specific code generation options
 p*3CTsmalltoc_ Generate smaller TOCs at the expense of execution speed (AIX)
 P*3CTsmalltoc_ Generate smaller TOCs at the expense of execution speed (AIX)
+J*3CTcompactintarrayinit_ Generate smaller (but potentially slower) code for initializing integer array constants
+J*2Cv_Var/out parameter copy-out checking
 **2CX_Create also smartlinked library
 **1d<x>_Defines the symbol <x>
 **1D_Generate a DEF file
@@ -3335,7 +3407,7 @@ F*2P<x>_Set target CPU (arm,i386,m68k,mips,mipsel,powerpc,powerpc64,sparc,x86_64
 **3*_n : Compiler also halts after notes
 **3*_h : Compiler also halts after hints
 **2Sg_Enable LABEL and GOTO (default in -Mtp and -Mdelphi)
-**2Sh_Use ansistrings by default instead of shortstrings
+**2Sh_Use reference counted strings (ansistring by default) instead of shortstrings
 **2Si_Turn on inlining of procedures/functions declared as "inline"
 **2Sk_Load fpcylix unit
 **2SI<x>_Set interface style to <x>

compiler/msgidx.inc

@@ -111,6 +111,7 @@ const
   scanner_w_illegal_warn_identifier=02087;
   scanner_e_illegal_alignment_directive=02088;
   scanner_f_illegal_utf8_bom=02089;
+  scanner_w_directive_ignored_on_target=02090;
   parser_e_syntax_error=03000;
   parser_e_dont_nest_interrupt=03004;
   parser_w_proc_directive_ignored=03005;
@@ -195,7 +196,7 @@ const
   parser_f_unsupported_feature=03092;
   parser_e_mix_of_classes_and_objects=03093;
   parser_w_unknown_proc_directive_ignored=03094;
-  parser_e_absolute_only_one_var=03095;
+  parser_e_directive_only_one_var=03095;
   parser_e_absolute_only_to_var_or_const=03096;
   parser_e_initialized_only_one_var=03097;
   parser_e_abstract_no_definition=03098;
@@ -365,10 +366,10 @@ const
   parser_h_no_objc_parent=03270;
   parser_e_no_objc_published=03271;
   parser_f_need_objc=03272;
-  parser_e_must_use_override_objc=03273;
-  parser_h_should_use_override_objc=03274;
+  parser_e_must_use_override=03273;
+  parser_h_should_use_override=03274;
   parser_e_objc_message_name_changed=03275;
-  parser_e_no_objc_unique=03276;
+  parser_e_unique_unsupported=03276;
   parser_e_no_category_as_types=03277;
   parser_e_no_category_override=03278;
   parser_e_must_use_reintroduce_objc=03279;
@@ -390,7 +391,7 @@ const
   parser_e_objc_missing_enumeration_defs=03295;
   parser_e_no_procvarnested_const=03296;
   parser_f_no_generic_inside_generic=03297;
-  parser_e_forward_protocol_declaration_must_be_resolved=03298;
+  parser_e_forward_intf_declaration_must_be_resolved=03298;
   parser_e_no_record_published=03299;
   parser_e_no_destructor_in_records=03300;
   parser_e_class_methods_only_static_in_records=03301;
@@ -407,6 +408,13 @@ const
   parser_e_mapping_no_implements=03312;
   parser_e_implements_no_mapping=03313;
   parser_e_invalid_codepage=03314;
+  parser_e_final_only_const_var=03315;
+  parser_e_final_only_external=03316;
+  parser_e_no_typed_const=03317;
+  parser_e_java_no_inherited_constructor=03318;
+  parser_d_internal_parser_string=03319;
+  parser_e_feature_unsupported_for_vm=03320;
+  parser_e_jvm_invalid_virtual_constructor_call=03321;
   type_e_mismatch=04000;
   type_e_incompatible_types=04001;
   type_e_not_equal_types=04002;
@@ -509,6 +517,12 @@ const
   type_e_range_check_error_bounds=04109;
   type_w_range_check_error_bounds=04110;
   type_e_type_not_allowed_for_default=04111;
+  type_e_java_class_method_not_static_virtual=04112;
+  type_e_invalid_final_assignment=04113;
+  type_e_no_managed_formal_assign_typecast=04114;
+  type_e_no_managed_assign_generic_typecast=04115;
+  type_w_interface_lower_visibility=04116;
+  type_e_interface_lower_visibility=04117;
   sym_e_id_not_found=05000;
   sym_f_internal_error_in_symtablestack=05001;
   sym_e_duplicate_id=05002;
@@ -575,11 +589,13 @@ const
   sym_w_library_unit=05077;
   sym_w_non_implemented_unit=05078;
   sym_w_experimental_unit=05079;
-  sym_e_objc_formal_class_not_resolved=05080;
+  sym_e_formal_class_not_resolved=05080;
   sym_e_interprocgoto_into_init_final_code_not_allowed=05081;
   sym_e_external_class_name_mismatch1=05082;
   sym_e_external_class_name_mismatch2=05083;
   sym_w_library_overload=05084;
+  sym_e_duplicate_id_create_java_constructor=05085;
+  sym_e_no_matching_inherited_parameterless_constructor=05086;
   cg_e_parasize_too_big=06009;
   cg_e_file_must_call_by_reference=06012;
   cg_e_cant_use_far_pointer_there=06013;
@@ -925,9 +941,9 @@ const
   option_info=11024;
   option_help_pages=11025;
 
-  MsgTxtSize = 63964;
+  MsgTxtSize = 65627;
 
   MsgIdxMax : array[1..20] of longint=(
-    26,90,315,112,85,55,116,26,202,63,
+    26,91,322,118,87,55,116,26,202,63,
     53,20,1,1,1,1,1,1,1,1
   );

compiler/nadd.pas

@@ -1610,8 +1610,13 @@ implementation
                     { a voidpointer of 8 bytes). A conversion to voidpointer would be  }
                     { optimized away, since the result already was a voidpointer, so   }
                     { use a charpointer instead (JM)                                   }
+{$ifndef jvm}
                     inserttypeconv_internal(left,charpointertype);
                     inserttypeconv_internal(right,charpointertype);
+{$else jvm}
+                    inserttypeconv_internal(left,java_jlobject);
+                    inserttypeconv_internal(right,java_jlobject);
+{$endif jvm}
                  end;
                ltn,lten,gtn,gten:
                  begin
@@ -1678,7 +1683,14 @@ implementation
             if (nodetype in [addn,equaln,unequaln,lten,gten,ltn,gtn]) then
               begin
                 { Is there a unicodestring? }
-                if is_unicodestring(rd) or is_unicodestring(ld) then
+                if is_unicodestring(rd) or is_unicodestring(ld) or
+                   ((m_default_unicodestring in current_settings.modeswitches) and
+                    (cs_refcountedstrings in current_settings.localswitches) and
+                    (
+                     is_pwidechar(rd) or is_widechararray(rd) or is_open_widechararray(rd) or (lt = stringconstn) or
+                     is_pwidechar(ld) or is_widechararray(ld) or is_open_widechararray(ld) or (rt = stringconstn)
+                    )
+                   ) then
                   strtype:=st_unicodestring
                 else
                 { Is there a widestring? }
@@ -1688,7 +1700,7 @@ implementation
                     strtype:=st_widestring
                 else
                   if is_ansistring(rd) or is_ansistring(ld) or
-                     ((cs_ansistrings in current_settings.localswitches) and
+                     ((cs_refcountedstrings in current_settings.localswitches) and
                      //todo: Move some of this to longstring's then they are implemented?
                       (
                        is_pchar(rd) or (is_chararray(rd) and (rd.size > 255)) or is_open_chararray(rd) or (lt = stringconstn) or
@@ -1907,7 +1919,7 @@ implementation
           begin
             if is_zero_based_array(rd) then
               begin
-                resultdef:=tpointerdef.create(tarraydef(rd).elementdef);
+                resultdef:=getpointerdef(tarraydef(rd).elementdef);
                 inserttypeconv(right,resultdef);
               end
             else
@@ -1937,7 +1949,7 @@ implementation
            begin
              if is_zero_based_array(ld) then
                begin
-                  resultdef:=tpointerdef.create(tarraydef(ld).elementdef);
+                  resultdef:=getpointerdef(tarraydef(ld).elementdef);
                   inserttypeconv(left,resultdef);
                end
              else
@@ -2158,6 +2170,16 @@ implementation
                   result:=internalstatements(newstatement);
                   tempnode:=ctempcreatenode.create(resultdef,resultdef.size,tt_persistent,true);
                   addstatement(newstatement,tempnode);
+                  { initialize the temp, since it will be passed to a
+                    var-parameter (and finalization, which is performed by the
+                    ttempcreate node and which takes care of the initialization
+                    on native targets, is a noop on managed VM targets) }
+                  if (target_info.system in systems_managed_vm) and
+                     is_managed_type(resultdef) then
+                    addstatement(newstatement,cinlinenode.create(in_setlength_x,
+                      false,
+                      ccallparanode.create(genintconstnode(0),
+                        ccallparanode.create(ctemprefnode.create(tempnode),nil))));
                   para:=ccallparanode.create(
                           right,
                           ccallparanode.create(
@@ -2207,7 +2229,8 @@ implementation
                       nodetype:=swap_relation[nodetype];
                     end;
                   if is_shortstring(left.resultdef) or
-                     (nodetype in [gtn,gten,ltn,lten]) then
+                     (nodetype in [gtn,gten,ltn,lten]) or
+                     (target_info.system in systems_managed_vm) then
                     { compare the length with 0 }
                     result := caddnode.create(nodetype,
                       cinlinenode.create(in_length_x,false,left),
@@ -2710,16 +2733,14 @@ implementation
 {$endif cpuneedsmulhelper}
       begin
          result:=nil;
-
          { Can we optimize multiple string additions into a single call?
            This need to be done on a complete tree to detect the multiple
            add nodes and is therefor done before the subtrees are processed }
          if canbemultistringadd(self) then
            begin
-             result := genmultistringadd(self);
+             result:=genmultistringadd(self);
              exit;
            end;
-
          { first do the two subtrees }
          firstpass(left);
          firstpass(right);
@@ -2796,7 +2817,7 @@ implementation
                   internalerror(200103291);
                  expectloc:=LOC_FLAGS;
                end
-{$ifndef cpu64bitaddr}
+{$ifndef cpu64bitalu}
               { is there a 64 bit type ? }
              else if (torddef(ld).ordtype in [s64bit,u64bit,scurrency]) then
                begin
@@ -2808,7 +2829,7 @@ implementation
                   else
                     expectloc:=LOC_JUMP;
                end
-{$endif cpu64bitaddr}
+{$endif cpu64bitalu}
 {$ifndef cpuneedsmulhelper}
              { is there a cardinal? }
              else if (torddef(ld).ordtype=u32bit) then

compiler/nbas.pas

@@ -94,12 +94,57 @@ interface
 
        ttempcreatenode = class;
 
-       ttempinfoflag = (ti_may_be_in_reg,ti_valid,ti_nextref_set_hookoncopy_nil,
-                        ti_addr_taken,ti_executeinitialisation);
+       ttempinfoflag = (
+         { temp can be kept in a register as far as the original creator is
+          concerned }
+         ti_may_be_in_reg,
+         { the ttempcreatenode has been process and the temp's location is
+           valid (-> the ttempdeletenode has not yet been processed, or
+           in case it's a "create_to_normal()" one, the final ttemprefnode
+           has not yet been processed) }
+         ti_valid,
+         { when performing a getcopy of a nodetree, we have to hook up the
+           copies of ttemprefnodes and ttempdestroynode to the copied
+           ttempinfo. this is done by setting hookoncopy in the original
+           ttempinfo to point to the new one. if the temp is deleted via a
+           regular ttempdeletenode, the hookoncopy is simply set to nil once
+           it's processed. otherwise, it sets the ti_nextref_set_hookoncopy_nil
+           and after processing the final ttemprefnode, hookoncopy is set to nil
+         }
+         ti_nextref_set_hookoncopy_nil,
+         { the address of this temp is taken (-> cannot be kept in a register,
+           even if the creator didn't mind)
+         }
+         ti_addr_taken,
+         { temps can get an extra node tree that contains the value to which
+           they should be initialised when they are created. this initialisation
+           has to be performed right before the first reference to the temp.
+           this flag indicates that the ttempcreatenode has been
+           processed by pass_generate_code, but that the first ttemprefnode
+           hasn't yet and hence will have to perform the initialisation
+         }
+         ti_executeinitialisation,
+         { in case an expression like "inc(x[func()],1)" is translated into
+           a regular addition, you have to create a temp to hold the address
+           representing x[func()], since otherwise func() will be called twice
+           and that can spell trouble in case it has side effects. on platforms
+           without pointers, we cannot just take the address though. this flag
+           has to be combined with ti_executeinitialisation above and will,
+           rather than loading the value at the calculated location and store
+           it in the temp, keep a copy of the calculated location if possible
+           and required (not possible for regvars, because SSA may change their
+           register, but not required for them either since calculating their
+           location has no side-effects
+         }
+         ti_reference,
+         { this temp only allows reading (makes it possible to safely use as
+           reference under more circumstances)
+         }
+         ti_readonly);
        ttempinfoflags = set of ttempinfoflag;
 
      const
-       tempinfostoreflags = [ti_may_be_in_reg,ti_addr_taken];
+       tempinfostoreflags = [ti_may_be_in_reg,ti_addr_taken,ti_reference,ti_readonly];
 
      type
        { to allow access to the location by temp references even after the temp has }
@@ -136,6 +181,7 @@ interface
           constructor create(_typedef: tdef; _size: tcgint; _temptype: ttemptype;allowreg:boolean); virtual;
           constructor create_withnode(_typedef: tdef; _size: tcgint; _temptype: ttemptype; allowreg:boolean; withnode: tnode); virtual;
           constructor create_value(_typedef:tdef; _size: tcgint; _temptype: ttemptype;allowreg:boolean; templvalue: tnode);
+          constructor create_reference(_typedef:tdef; _size: tcgint; _temptype: ttemptype;allowreg:boolean; templvalue: tnode; readonly: boolean);
           constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
           procedure ppuwrite(ppufile:tcompilerppufile);override;
           procedure buildderefimpl;override;
@@ -209,6 +255,9 @@ interface
        function  laststatement(block:tblocknode):tstatementnode;
        procedure addstatement(var laststatement:tstatementnode;n:tnode);
 
+       { if the complexity of n is "high", creates a reference temp to n's
+         location and replace n with a ttemprefnode referring to that location }
+       function maybereplacewithtempref(var n: tnode; var block: tblocknode; var stat: tstatementnode; size: ASizeInt; readonly: boolean): ttempcreatenode;
 
 implementation
 
@@ -251,6 +300,23 @@ implementation
       end;
 
 
+    function maybereplacewithtempref(var n: tnode; var block: tblocknode; var stat: tstatementnode; size: ASizeInt; readonly: boolean): ttempcreatenode;
+      begin
+        result:=nil;
+        if node_complexity(n) > 4 then
+          begin
+            result:=ctempcreatenode.create_reference(n.resultdef,size,tt_persistent,true,n,readonly);
+            typecheckpass(tnode(result));
+            n:=ctemprefnode.create(result);
+            typecheckpass(n);
+            if not assigned(stat) then
+              block:=internalstatements(stat);
+            addstatement(stat,result)
+          end;
+      end;
+
+
+
 {*****************************************************************************
                              TFIRSTNOTHING
 *****************************************************************************}
@@ -734,6 +800,19 @@ implementation
       end;
 
 
+     constructor ttempcreatenode.create_reference(_typedef: tdef; _size: tcgint; _temptype: ttemptype; allowreg: boolean; templvalue: tnode; readonly: boolean);
+      begin
+        // store in ppuwrite
+        self.create(_typedef,_size,_temptype,allowreg);
+        ftemplvalue:=templvalue;
+        // no assignment node, just the tempvalue
+        tempinfo^.tempinitcode:=ftemplvalue;
+        include(tempinfo^.flags,ti_reference);
+        if readonly then
+          include(tempinfo^.flags,ti_readonly);
+      end;
+
+
     function ttempcreatenode.dogetcopy: tnode;
       var
         n: ttempcreatenode;
@@ -1113,10 +1192,8 @@ implementation
 
     destructor ttempdeletenode.destroy;
       begin
-        if assigned(tempinfo^.withnode) then
-          begin
-            tempinfo^.withnode.free;
-          end;
+        tempinfo^.withnode.free;
+        tempinfo^.tempinitcode.free;
         dispose(tempinfo);
       end;
 

compiler/ncal.pas

@@ -80,12 +80,13 @@ interface
        protected
           procedure objc_convert_to_message_send;virtual;
 
-       private
+       protected
           { inlining support }
           inlinelocals            : TFPObjectList;
           inlineinitstatement,
           inlinecleanupstatement  : tstatementnode;
           procedure createinlineparas;
+          procedure wrapcomplexinlinepara(para: tcallparanode); virtual;
           function  replaceparaload(var n: tnode; arg: pointer): foreachnoderesult;
           procedure createlocaltemps(p:TObject;arg:pointer);
           function  optimize_funcret_assignment(inlineblock: tblocknode): tnode;
@@ -132,6 +133,8 @@ interface
           constructor createinternres(const name: string; params: tnode; res:tdef);
           constructor createinternresfromunit(const fromunit, procname: string; params: tnode; res:tdef);
           constructor createinternreturn(const name: string; params: tnode; returnnode : tnode);
+          constructor createinternmethod(mp: tnode; const name: string; params: tnode);
+          constructor createinternmethodres(mp: tnode; const name: string; params: tnode; res:tdef);
           destructor destroy;override;
           constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
           procedure ppuwrite(ppufile:tcompilerppufile);override;
@@ -178,6 +181,13 @@ interface
        private
           fcontains_stack_tainting_call_cached,
           ffollowed_by_stack_tainting_call_cached : boolean;
+       protected
+          { in case of copy-out parameters: initialization code, and the code to
+            copy back the parameter value after the call (including any required
+            finalization code }
+          fparainit,
+          fparacopyback: tnode;
+          procedure handlemanagedbyrefpara(orgparadef: tdef);virtual;abstract;
        public
           callparaflags : tcallparaflags;
           parasym       : tparavarsym;
@@ -187,6 +197,8 @@ interface
           destructor destroy;override;
           constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
           procedure ppuwrite(ppufile:tcompilerppufile);override;
+          procedure buildderefimpl; override;
+          procedure derefimpl; override;
           function dogetcopy : tnode;override;
           procedure insertintolist(l : tnodelist);override;
           function pass_typecheck : tnode;override;
@@ -221,6 +233,7 @@ interface
             parameter whose evaluation involves a stack tainting parameter
             (result is only valid after order_parameters has been called) }
           property followed_by_stack_tainting_call_cached: boolean read ffollowed_by_stack_tainting_call_cached;
+          property paracopyback: tnode read fparacopyback;
        end;
        tcallparanodeclass = class of tcallparanode;
 
@@ -559,6 +572,8 @@ implementation
     destructor tcallparanode.destroy;
 
       begin
+         fparainit.free;
+         fparacopyback.free;
          inherited destroy;
       end;
 
@@ -567,6 +582,8 @@ implementation
       begin
         inherited ppuload(t,ppufile);
         ppufile.getsmallset(callparaflags);
+        fparainit:=ppuloadnode(ppufile);
+        fparacopyback:=ppuloadnode(ppufile);
       end;
 
 
@@ -574,6 +591,28 @@ implementation
       begin
         inherited ppuwrite(ppufile);
         ppufile.putsmallset(callparaflags);
+        ppuwritenode(ppufile,fparainit);
+        ppuwritenode(ppufile,fparacopyback);
+      end;
+
+
+    procedure tcallparanode.buildderefimpl;
+      begin
+        inherited buildderefimpl;
+        if assigned(fparainit) then
+          fparainit.buildderefimpl;
+        if assigned(fparacopyback) then
+          fparacopyback.buildderefimpl;
+      end;
+
+
+    procedure tcallparanode.derefimpl;
+      begin
+        inherited derefimpl;
+        if assigned(fparainit) then
+          fparainit.derefimpl;
+        if assigned(fparacopyback) then
+          fparacopyback.derefimpl;
       end;
 
 
@@ -581,11 +620,19 @@ implementation
 
       var
          n : tcallparanode;
-
+         initcopy: tnode;
       begin
+         initcopy:=nil;
+         { must be done before calling inherited getcopy, because can create
+           tempcreatenodes for values used in left }
+         if assigned(fparainit) then
+           initcopy:=fparainit.getcopy;
          n:=tcallparanode(inherited dogetcopy);
          n.callparaflags:=callparaflags;
          n.parasym:=parasym;
+         n.fparainit:=initcopy;
+         if assigned(fparacopyback) then
+           n.fparacopyback:=fparacopyback.getcopy;
          result:=n;
       end;
 
@@ -619,9 +666,13 @@ implementation
           tcallparanode(right).get_paratype;
          old_array_constructor:=allow_array_constructor;
          allow_array_constructor:=true;
+         if assigned(fparainit) then
+          typecheckpass(fparainit);
          typecheckpass(left);
          if assigned(third) then
            typecheckpass(third);
+         if assigned(fparacopyback) then
+           typecheckpass(fparacopyback);
          allow_array_constructor:=old_array_constructor;
          if codegenerror then
           resultdef:=generrordef
@@ -636,7 +687,17 @@ implementation
           tcallparanode(right).firstcallparan;
         if not assigned(left.resultdef) then
           get_paratype;
+        if assigned(parasym) and
+           (target_info.system in systems_managed_vm) and
+           (parasym.varspez in [vs_var,vs_out,vs_constref]) and
+           (parasym.vardef.typ<>formaldef) then
+          handlemanagedbyrefpara(left.resultdef);
+
+        if assigned(fparainit) then
+          firstpass(fparainit);
         firstpass(left);
+        if assigned(fparacopyback) then
+          firstpass(fparacopyback);
         if assigned(third) then
           firstpass(third);
         expectloc:=left.expectloc;
@@ -864,12 +925,20 @@ implementation
                        vs_out :
                          begin
                            if not valid_for_formal_var(left,true) then
-                            CGMessagePos(left.fileinfo,parser_e_illegal_parameter_list);
+                            CGMessagePos(left.fileinfo,parser_e_illegal_parameter_list)
+                           else if (target_info.system in systems_managed_vm) then
+                             handlemanagedbyrefpara(left.resultdef);
                          end;
                        vs_const :
                          begin
                            if not valid_for_formal_const(left,true) then
-                            CGMessagePos(left.fileinfo,parser_e_illegal_parameter_list);
+                            CGMessagePos(left.fileinfo,parser_e_illegal_parameter_list)
+                           else if (target_info.system in systems_managed_vm) and
+                              (left.resultdef.typ in [orddef,floatdef]) then
+                             begin
+                               left:=cinlinenode.create(in_box_x,false,ccallparanode.create(left,nil));
+                               typecheckpass(left);
+                             end;
                          end;
                      end;
                    end
@@ -990,6 +1059,8 @@ implementation
       begin
         docompare :=
           inherited docompare(p) and
+          fparainit.isequal(tcallparanode(p).fparainit) and
+          fparacopyback.isequal(tcallparanode(p).fparacopyback) and
           (callparaflags = tcallparanode(p).callparaflags)
           ;
       end;
@@ -1103,6 +1174,32 @@ implementation
       end;
 
 
+    constructor tcallnode.createinternmethod(mp: tnode; const name: string; params: tnode);
+      var
+        ps: tsym;
+        recdef: tabstractrecorddef;
+      begin
+        typecheckpass(mp);
+        if mp.resultdef.typ=classrefdef then
+          recdef:=tabstractrecorddef(tclassrefdef(mp.resultdef).pointeddef)
+        else
+          recdef:=tabstractrecorddef(mp.resultdef);
+        ps:=search_struct_member(recdef,name);
+        if not assigned(ps) or
+           (ps.typ<>procsym) then
+          internalerror(2011062806);
+        create(params,tprocsym(ps),ps.owner,mp,[]);
+      end;
+
+
+    constructor tcallnode.createinternmethodres(mp: tnode; const name: string; params: tnode; res: tdef);
+      begin
+        createinternmethod(mp,name,params);
+        typedef:=res;
+        include(callnodeflags,cnf_typedefset)
+      end;
+
+
     destructor tcallnode.destroy;
       begin
          methodpointer.free;
@@ -1232,14 +1329,18 @@ implementation
           n.methodpointer:=methodpointer.dogetcopy
         else
           n.methodpointer:=nil;
-        if assigned(funcretnode) then
-          n.funcretnode:=funcretnode.dogetcopy
-        else
-          n.funcretnode:=nil;
+        { must be copied before the funcretnode, because the callcleanup block
+          may contain a ttempdeletenode that sets the tempinfo of the
+          corresponding temp to ti_nextref_set_hookoncopy_nil, and this nextref
+          itself may be the funcretnode }
         if assigned(callcleanupblock) then
           n.callcleanupblock:=tblocknode(callcleanupblock.dogetcopy)
         else
           n.callcleanupblock:=nil;
+        if assigned(funcretnode) then
+          n.funcretnode:=funcretnode.dogetcopy
+        else
+          n.funcretnode:=nil;
         if assigned(varargsparas) then
          begin
            n.varargsparas:=tvarargsparalist.create(true);
@@ -1436,7 +1537,7 @@ implementation
                       is_object(p.resultdef);
 
             if usederef then
-              hdef:=tpointerdef.create(p.resultdef)
+              hdef:=getpointerdef(p.resultdef)
             else
               hdef:=p.resultdef;
 
@@ -1665,7 +1766,12 @@ implementation
               { push 0 as self when allocation is needed }
               if (methodpointer.resultdef.typ=classrefdef) or
                  (cnf_new_call in callnodeflags) then
-                selftree:=cpointerconstnode.create(0,voidpointertype)
+                if not is_javaclass(tdef(procdefinition.owner.defowner)) then
+                  selftree:=cpointerconstnode.create(0,voidpointertype)
+                else
+                 { special handling for Java constructors, handled in
+                   tjvmcallnode.extra_pre_call_code }
+                  selftree:=cnothingnode.create
               else
                 begin
                   if methodpointer.nodetype=typen then
@@ -1687,8 +1793,10 @@ implementation
                 selfdef:=tobjectdef(tprocdef(procdefinition).struct).extendeddef
               else
                 selfdef:=tprocdef(procdefinition).struct;
-              if (selfdef.typ in [recorddef,objectdef]) and
-                  (oo_has_vmt in tabstractrecorddef(selfdef).objectoptions) then
+              if ((selfdef.typ in [recorddef,objectdef]) and
+                  (oo_has_vmt in tabstractrecorddef(selfdef).objectoptions)) or
+                 { all Java classes have a "VMT" }
+                 (target_info.system in systems_jvm) then
                 begin
                   { we only need the vmt, loading self is not required and there is no
                     need to check for typen, because that will always get the
@@ -2402,7 +2510,7 @@ implementation
         for i:=0 to tprocsym(sym).ProcdefList.Count-1 do
           begin
             pd:=tprocdef(tprocsym(sym).ProcdefList[i]);
-            hs:=pd.procsym.name+pd.typename_paras(false);
+            hs:=pd.procsym.name+pd.typename_paras([]);
             j:=AbstractMethodsList.FindIndexOf(hs);
             if j<>-1 then
               AbstractMethodsList[j]:=pd
@@ -2442,6 +2550,9 @@ implementation
           end;
         if not assigned(objectdf) then
           exit;
+        { quick exit if nothing to check }
+        if objectdf.abstractcnt = 0 then
+          exit;
 
         parents := tlinkedlist.create;
         AbstractMethodsList := TFPHashList.create;
@@ -3173,18 +3284,20 @@ implementation
                               That means the for pushes the para with the
                               highest offset (see para3) needs to be pushed first
                             }
-{$ifdef i386}
-                            { the i386 code generator expects all reference }
-                            { parameter to be in this order so it can use   }
-                            { pushes in case of no fixed stack              }
+{$if defined(i386)}
+                            { the i386 and jvm code generators expect all reference }
+                            { parameters to be in this order so they can use   }
+                            { pushes in case of no fixed stack                 }
                             if (not paramanager.use_fixed_stack and
                                 (hpcurr.parasym.paraloc[callerside].location^.reference.offset>
                                  hp.parasym.paraloc[callerside].location^.reference.offset)) or
                                (paramanager.use_fixed_stack and
                                 (node_complexity(hpcurr)<node_complexity(hp))) then
-{$else i386}
+{$elseif defined(jvm)}
+                            if (hpcurr.parasym.paraloc[callerside].location^.reference.offset<hp.parasym.paraloc[callerside].location^.reference.offset) then
+{$else jvm}
                             if (node_complexity(hpcurr)<node_complexity(hp)) then
-{$endif i386}
+{$endif jvm}
                               break;
                           end;
                         LOC_MMREGISTER,
@@ -3356,6 +3469,15 @@ implementation
              doinlinesimplify(tnode(callcleanupblock));
            end;
 
+         { If a constructor calls another constructor of the same or of an
+           inherited class, some targets (jvm) have to generate different
+           entry code for the constructor. }
+         if (current_procinfo.procdef.proctypeoption=potype_constructor) and
+            (procdefinition.typ=procdef) and
+            (tprocdef(procdefinition).proctypeoption=potype_constructor) and
+            ([cnf_member_call,cnf_inherited] * callnodeflags <> []) then
+           current_procinfo.ConstructorCallingConstructor:=true;
+
          { Continue with checking a normal call or generate the inlined code }
          if cnf_do_inline in callnodeflags then
            result:=pass1_inline
@@ -3570,9 +3692,8 @@ implementation
         para: tcallparanode;
         tempnode: ttempcreatenode;
         n: tnode;
-        paraaddr: taddrnode;
-        ptrtype: tpointerdef;
         paracomplexity: longint;
+        pushconstaddr: boolean;
       begin
         { parameters }
         para := tcallparanode(left);
@@ -3595,6 +3716,8 @@ implementation
                 { we need to take care that we use the type of the defined parameter and not of the
                   passed parameter, because these can be different in case of a formaldef (PFV) }
                 paracomplexity := node_complexity(para.left);
+                if para.parasym.varspez=vs_const then
+                  pushconstaddr:=paramanager.push_addr_param(vs_const,para.parasym.vardef,procdefinition.proccalloption);
                 { check if we have to create a temp, assign the parameter's }
                 { contents to that temp and then substitute the paramter    }
                 { with the temp everywhere in the function                  }
@@ -3624,7 +3747,7 @@ implementation
                       { variable would be passed by value normally, or if   }
                       { there is such a variable somewhere in an expression }
                        ((para.parasym.varspez = vs_const) and
-                        (not paramanager.push_addr_param(vs_const,para.parasym.vardef,procdefinition.proccalloption) or
+                        (not pushconstaddr or
                          (paracomplexity > 1)))) and
                      { however, if we pass a global variable, an object field or}
                      { an expression containing a pointer dereference as        }
@@ -3660,14 +3783,20 @@ implementation
                       is still folded. (FK)
                       }
                     ((para.parasym.varspez = vs_const) and
-                     { const para's can get vs_readwritten if their address }
-                     { is taken                                             }
-                     ((para.parasym.varstate = vs_readwritten) or
+                     { const para's can get vs_readwritten if their address   }
+                     { is taken -> in case they are not passed by reference,  }
+                     { to keep the same behaviour as without inlining we have }
+                     { to make a copy in case the originally passed parameter }
+                     { value gets changed inside the callee                   }
+                     ((not pushconstaddr and
+                       (para.parasym.varstate = vs_readwritten)
+                      ) or
                       { call-by-reference const's may need to be passed by }
                       { reference to function called in the inlined code   }
-                      (paramanager.push_addr_param(vs_const,para.parasym.vardef,procdefinition.proccalloption) and
-                       not valid_for_addr(para.left,false))
-                     ))
+                       (pushconstaddr and
+                        not valid_for_addr(para.left,false))
+                     )
+                    )
                    )
                   ) then
                   begin
@@ -3699,18 +3828,7 @@ implementation
                   if (paracomplexity>2) or
                     ((paracomplexity>1) and not((para.left.nodetype=derefn) and (para.parasym.varspez = vs_var))) then
                   begin
-                    ptrtype:=tpointerdef.create(para.left.resultdef);
-                    tempnode := ctempcreatenode.create(ptrtype,ptrtype.size,tt_persistent,tparavarsym(para.parasym).is_regvar(true));
-                    addstatement(inlineinitstatement,tempnode);
-                    addstatement(inlinecleanupstatement,ctempdeletenode.create(tempnode));
-                    { inherit addr_taken flag }
-                    if (tabstractvarsym(para.parasym).addr_taken) then
-                      include(tempnode.tempinfo^.flags,ti_addr_taken);
-                    paraaddr:=caddrnode.create_internal(para.left);
-                    include(paraaddr.flags,nf_typedaddr);
-                    addstatement(inlineinitstatement,cassignmentnode.create(ctemprefnode.create(tempnode),
-                      paraaddr));
-                    para.left:=cderefnode.create(ctemprefnode.create(tempnode));
+                    wrapcomplexinlinepara(para);
                   end;
               end;
             para := tcallparanode(para.right);
@@ -3724,6 +3842,27 @@ implementation
       end;
 
 
+    procedure tcallnode.wrapcomplexinlinepara(para: tcallparanode);
+      var
+        ptrtype: tdef;
+        tempnode: ttempcreatenode;
+        paraaddr: taddrnode;
+      begin
+        ptrtype:=getpointerdef(para.left.resultdef);
+        tempnode := ctempcreatenode.create(ptrtype,ptrtype.size,tt_persistent,tparavarsym(para.parasym).is_regvar(true));
+        addstatement(inlineinitstatement,tempnode);
+        addstatement(inlinecleanupstatement,ctempdeletenode.create(tempnode));
+        { inherit addr_taken flag }
+        if (tabstractvarsym(para.parasym).addr_taken) then
+          include(tempnode.tempinfo^.flags,ti_addr_taken);
+        paraaddr:=caddrnode.create_internal(para.left);
+        include(paraaddr.flags,nf_typedaddr);
+        addstatement(inlineinitstatement,cassignmentnode.create(ctemprefnode.create(tempnode),
+          paraaddr));
+        para.left:=cderefnode.create(ctemprefnode.create(tempnode));
+      end;
+
+
     function tcallnode.optimize_funcret_assignment(inlineblock: tblocknode): tnode;
       var
         hp  : tstatementnode;

compiler/ncgadd.pas

@@ -34,7 +34,7 @@ interface
           procedure pass_generate_code;override;
          protected
           { call secondpass for both left and right }
-          procedure pass_left_right;
+          procedure pass_left_right; virtual;
           { set the register of the result location }
           procedure set_result_location_reg;
           { load left and right nodes into registers }
@@ -74,7 +74,8 @@ interface
       symconst,symdef,paramgr,
       aasmbase,aasmtai,aasmdata,defutil,
       cgbase,procinfo,pass_2,tgobj,
-      nutils,ncon,nset,ncgutil,cgobj,cgutils
+      nutils,ncon,nset,ncgutil,cgobj,cgutils,
+      hlcgobj
       ;
 
 
@@ -108,7 +109,7 @@ interface
           end;
         secondpass(left);
         if left.location.loc in [LOC_FLAGS,LOC_JUMP] then
-          location_force_reg(current_asmdata.CurrAsmList,left.location,def_cgsize(resultdef),false);
+          hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,resultdef,false);
         if isjump then
           begin
             current_procinfo.CurrTrueLabel:=otl;
@@ -136,7 +137,7 @@ interface
           end;
         secondpass(right);
         if right.location.loc in [LOC_FLAGS,LOC_JUMP] then
-          location_force_reg(current_asmdata.CurrAsmList,right.location,def_cgsize(resultdef),false);
+          hlcg.location_force_reg(current_asmdata.CurrAsmList,right.location,right.resultdef,resultdef,false);
         if isjump then
           begin
             current_procinfo.CurrTrueLabel:=otl;
@@ -213,7 +214,7 @@ interface
               end
             else
 {$endif}
-            location.register := cg.getintregister(current_asmdata.CurrAsmList,location.size);
+            location.register := hlcg.getintregister(current_asmdata.CurrAsmList,resultdef);
           end;
       end;
 
@@ -225,14 +226,14 @@ interface
                allow_constant and
                (left.location.loc in [LOC_CONSTANT,LOC_CREGISTER])
               ) then
-          location_force_reg(current_asmdata.CurrAsmList,left.location,left.location.size,false);
+          hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,left.resultdef,false);
         if (right.location.loc<>LOC_REGISTER) and
            not(
                allow_constant and
                (right.location.loc in [LOC_CONSTANT,LOC_CREGISTER]) and
                (left.location.loc<>LOC_CONSTANT)
               ) then
-          location_force_reg(current_asmdata.CurrAsmList,right.location,right.location.size,false);
+          hlcg.location_force_reg(current_asmdata.CurrAsmList,right.location,right.resultdef,right.resultdef,false);
 
         { Left is always a register, right can be register or constant }
         if left.location.loc=LOC_CONSTANT then
@@ -312,11 +313,11 @@ interface
                     location.register:=cg.getintregister(current_asmdata.CurrAsmList,location.size);
                   { make sure we don't modify left/right.location, because we told
                     force_reg_left_right above that they can be constant }
-                  cg.a_op_reg_reg(current_asmdata.CurrAsmList,OP_NOT,location.size,right.location.register,location.register);
+                  hlcg.a_op_reg_reg(current_asmdata.CurrAsmList,OP_NOT,resultdef,right.location.register,location.register);
                   if left.location.loc = LOC_CONSTANT then
-                    cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_AND,location.size,left.location.value,location.register)
+                    hlcg.a_op_const_reg(current_asmdata.CurrAsmList,OP_AND,resultdef,left.location.value,location.register)
                   else
-                    cg.a_op_reg_reg(current_asmdata.CurrAsmList,OP_AND,location.size,left.location.register,location.register);
+                    hlcg.a_op_reg_reg(current_asmdata.CurrAsmList,OP_AND,resultdef,left.location.register,location.register);
                 end;
             end;
           else
@@ -329,11 +330,11 @@ interface
             if (left.location.loc = LOC_CONSTANT) then
               swapleftright;
             if (right.location.loc = LOC_CONSTANT) then
-              cg.a_op_const_reg_reg(current_asmdata.CurrAsmList,cgop,location.size,
+              hlcg.a_op_const_reg_reg(current_asmdata.CurrAsmList,cgop,resultdef,
                 right.location.value,left.location.register,
                 location.register)
             else
-              cg.a_op_reg_reg_reg(current_asmdata.CurrAsmList,cgop,location.size,
+              hlcg.a_op_reg_reg_reg(current_asmdata.CurrAsmList,cgop,resultdef,
                 right.location.register,left.location.register,
                 location.register);
           end;
@@ -366,7 +367,7 @@ interface
               mask:=aint((aword(1) shl (resultdef.size*8-1)) shr aword(right.location.value-setbase))
             else
               mask:=aint(1 shl (right.location.value-setbase));
-            cg.a_op_const_reg_reg(current_asmdata.CurrAsmList,OP_OR,location.size,
+            hlcg.a_op_const_reg_reg(current_asmdata.CurrAsmList,OP_OR,resultdef,
               mask,left.location.register,location.register);
           end
         else
@@ -381,17 +382,17 @@ interface
                 mask:=1;
                 cgop:=OP_SHL
               end;
-            tmpreg := cg.getintregister(current_asmdata.CurrAsmList,location.size);
-            cg.a_load_const_reg(current_asmdata.CurrAsmList,location.size,mask,tmpreg);
-            location_force_reg(current_asmdata.CurrAsmList,right.location,location.size,true);
+            tmpreg:=hlcg.getintregister(current_asmdata.CurrAsmList,resultdef);
+            hlcg.a_load_const_reg(current_asmdata.CurrAsmList,resultdef,mask,tmpreg);
+            hlcg.location_force_reg(current_asmdata.CurrAsmList,right.location,right.resultdef,resultdef,true);
             register_maybe_adjust_setbase(current_asmdata.CurrAsmList,right.location,setbase);
-            cg.a_op_reg_reg(current_asmdata.CurrAsmList,cgop,location.size,
+            hlcg.a_op_reg_reg(current_asmdata.CurrAsmList,cgop,resultdef,
               right.location.register,tmpreg);
             if left.location.loc <> LOC_CONSTANT then
-              cg.a_op_reg_reg_reg(current_asmdata.CurrAsmList,OP_OR,location.size,tmpreg,
+              hlcg.a_op_reg_reg_reg(current_asmdata.CurrAsmList,OP_OR,resultdef,tmpreg,
                   left.location.register,location.register)
             else
-              cg.a_op_const_reg_reg(current_asmdata.CurrAsmList,OP_OR,location.size,
+              hlcg.a_op_const_reg_reg(current_asmdata.CurrAsmList,OP_OR,resultdef,
                   left.location.value,tmpreg,location.register);
           end;
       end;
@@ -429,8 +430,8 @@ interface
                    otl:=current_procinfo.CurrTrueLabel;
                    current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
                    secondpass(left);
-                   maketojumpbool(current_asmdata.CurrAsmList,left,lr_load_regvars);
-                   cg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
+                   hlcg.maketojumpbool(current_asmdata.CurrAsmList,left);
+                   hlcg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
                    current_procinfo.CurrTrueLabel:=otl;
                 end;
               orn :
@@ -438,8 +439,8 @@ interface
                    ofl:=current_procinfo.CurrFalseLabel;
                    current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
                    secondpass(left);
-                   maketojumpbool(current_asmdata.CurrAsmList,left,lr_load_regvars);
-                   cg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+                   hlcg.maketojumpbool(current_asmdata.CurrAsmList,left);
+                   hlcg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
                    current_procinfo.CurrFalseLabel:=ofl;
                 end;
               else
@@ -450,7 +451,7 @@ interface
             include(flowcontrol,fc_inflowcontrol);
 
             secondpass(right);
-            maketojumpbool(current_asmdata.CurrAsmList,right,lr_load_regvars);
+            hlcg.maketojumpbool(current_asmdata.CurrAsmList,right);
 
             flowcontrol:=oldflowcontrol+(flowcontrol-[fc_inflowcontrol]);
           end
@@ -486,11 +487,11 @@ interface
 {$endif cpu64bitalu}
               begin
                 if right.location.loc <> LOC_CONSTANT then
-                  cg.a_op_reg_reg_reg(current_asmdata.CurrAsmList,cgop,location.size,
+                  hlcg.a_op_reg_reg_reg(current_asmdata.CurrAsmList,cgop,resultdef,
                      left.location.register,right.location.register,
                      location.register)
                 else
-                  cg.a_op_const_reg_reg(current_asmdata.CurrAsmList,cgop,location.size,
+                  hlcg.a_op_const_reg_reg(current_asmdata.CurrAsmList,cgop,resultdef,
                      right.location.value,left.location.register,
                      location.register);
               end;
@@ -554,17 +555,18 @@ interface
         checkoverflow:=
           checkoverflow and
           (left.resultdef.typ<>pointerdef) and
-          (right.resultdef.typ<>pointerdef);
+          (right.resultdef.typ<>pointerdef) and
+          (cs_check_overflow in current_settings.localswitches);
 
 {$ifdef cpu64bitalu}
         case nodetype of
           xorn,orn,andn,addn:
             begin
               if (right.location.loc = LOC_CONSTANT) then
-                cg.a_op_const_reg_reg(current_asmdata.CurrAsmList,op,location.size,right.location.value,
+                hlcg.a_op_const_reg_reg(current_asmdata.CurrAsmList,op,resultdef,right.location.value,
                   left.location.register,location.register)
               else
-                cg.a_op_reg_reg_reg(current_asmdata.CurrAsmList,op,location.size,right.location.register,
+                hlcg.a_op_reg_reg_reg(current_asmdata.CurrAsmList,op,resultdef,right.location.register,
                   left.location.register,location.register);
             end;
           subn:
@@ -576,22 +578,22 @@ interface
                 begin
                   if right.location.loc <> LOC_CONSTANT then
                     // reg64 - reg64
-                    cg.a_op_reg_reg_reg_checkoverflow(current_asmdata.CurrAsmList,OP_SUB,location.size,
+                    hlcg.a_op_reg_reg_reg_checkoverflow(current_asmdata.CurrAsmList,OP_SUB,resultdef,
                       right.location.register,left.location.register,location.register,
-                      checkoverflow and (cs_check_overflow in current_settings.localswitches),ovloc)
+                      checkoverflow,ovloc)
                   else
                     // reg64 - const64
-                    cg.a_op_const_reg_reg_checkoverflow(current_asmdata.CurrAsmList,OP_SUB,location.size,
+                    hlcg.a_op_const_reg_reg_checkoverflow(current_asmdata.CurrAsmList,OP_SUB,resultdef,
                       right.location.value,left.location.register,location.register,
-                      checkoverflow and (cs_check_overflow in current_settings.localswitches),ovloc);
+                      checkoverflow,ovloc);
                 end
               else
                 begin
                   // const64 - reg64
-                  location_force_reg(current_asmdata.CurrAsmList,left.location,left.location.size,true);
-                  cg.a_op_reg_reg_reg_checkoverflow(current_asmdata.CurrAsmList,OP_SUB,location.size,
+                  hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,left.resultdef,true);
+                  hlcg.a_op_reg_reg_reg_checkoverflow(current_asmdata.CurrAsmList,OP_SUB,resultdef,
                     right.location.register,left.location.register,location.register,
-                    checkoverflow and (cs_check_overflow in current_settings.localswitches),ovloc);
+                    checkoverflow,ovloc);
                 end;
             end;
           else
@@ -604,11 +606,11 @@ interface
               if (right.location.loc = LOC_CONSTANT) then
                 cg64.a_op64_const_reg_reg_checkoverflow(current_asmdata.CurrAsmList,op,location.size,right.location.value64,
                   left.location.register64,location.register64,
-                  checkoverflow and (cs_check_overflow in current_settings.localswitches),ovloc)
+                  checkoverflow,ovloc)
               else
                 cg64.a_op64_reg_reg_reg_checkoverflow(current_asmdata.CurrAsmList,op,location.size,right.location.register64,
                   left.location.register64,location.register64,
-                  checkoverflow and (cs_check_overflow in current_settings.localswitches),ovloc);
+                  checkoverflow,ovloc);
             end;
           subn:
             begin
@@ -622,13 +624,13 @@ interface
                     cg64.a_op64_reg_reg_reg_checkoverflow(current_asmdata.CurrAsmList,OP_SUB,location.size,
                       right.location.register64,left.location.register64,
                       location.register64,
-                      checkoverflow and (cs_check_overflow in current_settings.localswitches),ovloc)
+                      checkoverflow,ovloc)
                   else
                     // reg64 - const64
                     cg64.a_op64_const_reg_reg_checkoverflow(current_asmdata.CurrAsmList,OP_SUB,location.size,
                       right.location.value64,left.location.register64,
                       location.register64,
-                      checkoverflow and (cs_check_overflow in current_settings.localswitches),ovloc)
+                      checkoverflow,ovloc)
                 end
               else
                 begin
@@ -637,7 +639,7 @@ interface
                   cg64.a_op64_reg_reg_reg_checkoverflow(current_asmdata.CurrAsmList,OP_SUB,location.size,
                     right.location.register64,left.location.register64,
                     location.register64,
-                    checkoverflow and (cs_check_overflow in current_settings.localswitches),ovloc);
+                    checkoverflow,ovloc);
                 end;
             end;
           else
@@ -647,7 +649,7 @@ interface
 
         { emit overflow check if enabled }
         if checkoverflow then
-           cg.g_overflowcheck_loc(current_asmdata.CurrAsmList,Location,resultdef,ovloc);
+           hlcg.g_overflowcheck_loc(current_asmdata.CurrAsmList,Location,resultdef,ovloc);
       end;
 
 
@@ -745,18 +747,19 @@ interface
        checkoverflow:=
          checkoverflow and
           (left.resultdef.typ<>pointerdef) and
-          (right.resultdef.typ<>pointerdef);
+          (right.resultdef.typ<>pointerdef) and
+          (cs_check_overflow in current_settings.localswitches);
 
        if nodetype<>subn then
         begin
           if (right.location.loc<>LOC_CONSTANT) then
-            cg.a_op_reg_reg_reg_checkoverflow(current_asmdata.CurrAsmList,cgop,location.size,
+            hlcg.a_op_reg_reg_reg_checkoverflow(current_asmdata.CurrAsmList,cgop,resultdef,
                left.location.register,right.location.register,
-               location.register,checkoverflow and (cs_check_overflow in current_settings.localswitches),ovloc)
+               location.register,checkoverflow,ovloc)
           else
-            cg.a_op_const_reg_reg_checkoverflow(current_asmdata.CurrAsmList,cgop,location.size,
+            hlcg.a_op_const_reg_reg_checkoverflow(current_asmdata.CurrAsmList,cgop,resultdef,
                right.location.value,left.location.register,
-               location.register,checkoverflow and (cs_check_overflow in current_settings.localswitches),ovloc);
+               location.register,checkoverflow,ovloc);
         end
       else  { subtract is a special case since its not commutative }
         begin
@@ -765,27 +768,27 @@ interface
           if left.location.loc<>LOC_CONSTANT then
             begin
               if right.location.loc<>LOC_CONSTANT then
-                cg.a_op_reg_reg_reg_checkoverflow(current_asmdata.CurrAsmList,OP_SUB,location.size,
+                hlcg.a_op_reg_reg_reg_checkoverflow(current_asmdata.CurrAsmList,OP_SUB,resultdef,
                     right.location.register,left.location.register,
-                    location.register,checkoverflow and (cs_check_overflow in current_settings.localswitches),ovloc)
+                    location.register,checkoverflow,ovloc)
               else
-                cg.a_op_const_reg_reg_checkoverflow(current_asmdata.CurrAsmList,OP_SUB,location.size,
+                hlcg.a_op_const_reg_reg_checkoverflow(current_asmdata.CurrAsmList,OP_SUB,resultdef,
                   right.location.value,left.location.register,
-                  location.register,checkoverflow and (cs_check_overflow in current_settings.localswitches),ovloc);
+                  location.register,checkoverflow,ovloc);
             end
           else
             begin
-              tmpreg:=cg.getintregister(current_asmdata.CurrAsmList,location.size);
-              cg.a_load_const_reg(current_asmdata.CurrAsmList,location.size,
+              tmpreg:=hlcg.getintregister(current_asmdata.CurrAsmList,resultdef);
+              hlcg.a_load_const_reg(current_asmdata.CurrAsmList,resultdef,
                 left.location.value,tmpreg);
-              cg.a_op_reg_reg_reg_checkoverflow(current_asmdata.CurrAsmList,OP_SUB,location.size,
-                right.location.register,tmpreg,location.register,checkoverflow and (cs_check_overflow in current_settings.localswitches),ovloc);
+              hlcg.a_op_reg_reg_reg_checkoverflow(current_asmdata.CurrAsmList,OP_SUB,resultdef,
+                right.location.register,tmpreg,location.register,checkoverflow,ovloc);
             end;
         end;
 
         { emit overflow check if required }
         if checkoverflow then
-          cg.g_overflowcheck_loc(current_asmdata.CurrAsmList,Location,resultdef,ovloc);
+          hlcg.g_overflowcheck_loc(current_asmdata.CurrAsmList,Location,resultdef,ovloc);
       end;
 
 

compiler/ncgbas.pas

@@ -71,7 +71,7 @@ interface
       aasmbase,aasmtai,aasmdata,aasmcpu,
       symsym,symconst,symdef,defutil,
       nflw,pass_2,ncgutil,
-      cgbase,cgobj,
+      cgbase,cgobj,hlcgobj,
       procinfo,
       tgobj
       ;
@@ -395,23 +395,28 @@ interface
         if (ti_valid in tempinfo^.flags) then
           internalerror(200108222);
 
-        { get a (persistent) temp }
-        if is_managed_type(tempinfo^.typedef) then
+        { in case of ti_reference, the location will be initialised using the
+          location of the tempinitnode once the first temprefnode is processed }
+        if not(ti_reference in tempinfo^.flags) then
           begin
-            location_reset_ref(tempinfo^.location,LOC_REFERENCE,def_cgsize(tempinfo^.typedef),0);
-            tg.GetTempTyped(current_asmdata.CurrAsmList,tempinfo^.typedef,tempinfo^.temptype,tempinfo^.location.reference);
-            { the temp could have been used previously either because the memory location was reused or
-              because we're in a loop }
-            cg.g_finalize(current_asmdata.CurrAsmList,tempinfo^.typedef,tempinfo^.location.reference);
-          end
-        else if (ti_may_be_in_reg in tempinfo^.flags) then
-          begin
-            location_allocate_register(current_asmdata.CurrAsmList,tempinfo^.location,tempinfo^.typedef,tempinfo^.temptype = tt_persistent);
-          end
-        else
-          begin
-            location_reset_ref(tempinfo^.location,LOC_REFERENCE,def_cgsize(tempinfo^.typedef),0);
-            tg.GetTemp(current_asmdata.CurrAsmList,size,tempinfo^.typedef.alignment,tempinfo^.temptype,tempinfo^.location.reference);
+            { get a (persistent) temp }
+            if is_managed_type(tempinfo^.typedef) then
+              begin
+                location_reset_ref(tempinfo^.location,LOC_REFERENCE,def_cgsize(tempinfo^.typedef),0);
+                tg.gethltemptyped(current_asmdata.CurrAsmList,tempinfo^.typedef,tempinfo^.temptype,tempinfo^.location.reference);
+                { the temp could have been used previously either because the memory location was reused or
+                  because we're in a loop }
+                hlcg.g_finalize(current_asmdata.CurrAsmList,tempinfo^.typedef,tempinfo^.location.reference);
+              end
+            else if (ti_may_be_in_reg in tempinfo^.flags) then
+              begin
+                location_allocate_register(current_asmdata.CurrAsmList,tempinfo^.location,tempinfo^.typedef,tempinfo^.temptype = tt_persistent);
+              end
+            else
+              begin
+                location_reset_ref(tempinfo^.location,LOC_REFERENCE,def_cgsize(tempinfo^.typedef),0);
+                tg.gethltemp(current_asmdata.CurrAsmList,tempinfo^.typedef,size,tempinfo^.temptype,tempinfo^.location.reference);
+              end;
           end;
         include(tempinfo^.flags,ti_valid);
         if assigned(tempinfo^.tempinitcode) then
@@ -430,6 +435,27 @@ interface
             { avoid recursion }
             exclude(tempinfo^.flags, ti_executeinitialisation);
             secondpass(tempinfo^.tempinitcode);
+            if (ti_reference in tempinfo^.flags) then
+              begin
+                case tempinfo^.tempinitcode.location.loc of
+                  LOC_CREGISTER,
+                  LOC_CFPUREGISTER,
+                  LOC_CMMREGISTER,
+                  LOC_CSUBSETREG:
+                    begin
+                      { although it's ok if we need this value multiple times
+                        for reading, it's not in case of writing (because the
+                        register could change due to SSA -> storing to the saved
+                        register afterwards would be wrong). }
+                      if not(ti_readonly in tempinfo^.flags) then
+                        internalerror(2011031407);
+                    end;
+                  { in case reference contains CREGISTERS, that doesn't matter:
+                    we want to write to the location indicated by the current
+                    value of those registers, and we can save those values }
+                end;
+                hlcg.g_reference_loc(current_asmdata.CurrAsmList,tempinfo^.typedef,tempinfo^.tempinitcode.location,tempinfo^.location);
+              end;
           end;
         { check if the temp is valid }
         if not(ti_valid in tempinfo^.flags) then
@@ -475,6 +501,21 @@ interface
 
     procedure tcgtempdeletenode.pass_generate_code;
       begin
+        if ti_reference in tempinfo^.flags then
+          begin
+            { release_to_normal means that the temp will be freed the next
+              time it's used. However, reference temps reference some other
+              location that is not managed by this temp and hence cannot be
+              freed }
+            if release_to_normal then
+              internalerror(2011052205);
+            { so we only mark this temp location as "no longer valid" when
+              it's deleted (ttempdeletenodes are also used during getcopy, so
+              we really do need one) }
+            exclude(tempinfo^.flags,ti_valid);
+            exit;
+          end;
+
         location_reset(location,LOC_VOID,OS_NO);
 
         case tempinfo^.location.loc of

compiler/ncgcal.pas

@@ -33,21 +33,26 @@ interface
 
     type
        tcgcallparanode = class(tcallparanode)
-       private
+       protected
           tempcgpara : tcgpara;
           procedure push_addr_para;
-          procedure push_value_para;
+          procedure push_value_para;virtual;
+          procedure push_formal_para;virtual;
+          procedure push_copyout_para;virtual;abstract;
        public
           constructor create(expr,next : tnode);override;
           destructor destroy;override;
           procedure secondcallparan;override;
        end;
 
+       { tcgcallnode }
+
        tcgcallnode = class(tcallnode)
        private
 
           procedure handle_return_value;
           procedure release_unused_return_value;
+          procedure copy_back_paras;
           procedure release_para_temps;
           procedure pushparas;
           procedure freeparas;
@@ -66,6 +71,7 @@ interface
           }
           procedure pop_parasize(pop_size:longint);virtual;
           procedure extra_interrupt_code;virtual;
+          procedure extra_pre_call_code;virtual;
           procedure extra_call_code;virtual;
           procedure extra_post_call_code;virtual;
           procedure do_syscall;virtual;abstract;
@@ -75,6 +81,11 @@ interface
             can work with it. This routine decides what the most appropriate
             tlocation is and sets self.location based on that. }
           procedure set_result_location(realresdef: tstoreddef);virtual;
+
+          { if an unused return value is in another location than a
+            LOC_REFERENCE, this method will be called to perform the necessary
+            cleanups. By default it does not do anything }
+          procedure do_release_unused_return_value;virtual;
        public
           procedure pass_generate_code;override;
           destructor destroy;override;
@@ -95,7 +106,7 @@ implementation
       cga,cgx86,aasmcpu,
 {$endif x86}
       ncgutil,
-      cgobj,tgobj,
+      cgobj,tgobj,hlcgobj,
       procinfo,
       wpobase;
 
@@ -122,22 +133,35 @@ 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;
 
 
     procedure tcgcallparanode.push_value_para;
       begin
-        { we've nothing to push when the size of the parameter is 0 }
-        if left.resultdef.size=0 then
+        { we've nothing to push when the size of the parameter is 0
+          -- except in case of the self parameter of an emptry record on e.g.
+             the JVM target }
+        if (left.resultdef.size=0) and
+           not(vo_is_self in parasym.varoptions) then
           exit;
 
         { Move flags and jump in register to make it less complex }
         if left.location.loc in [LOC_FLAGS,LOC_JUMP,LOC_SUBSETREG,LOC_CSUBSETREG,LOC_SUBSETREF,LOC_CSUBSETREF] then
-          location_force_reg(current_asmdata.CurrAsmList,left.location,def_cgsize(left.resultdef),false);
+          hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,left.resultdef,false);
 
         { load the parameter's tlocation into its cgpara }
-        gen_load_loc_cgpara(current_asmdata.CurrAsmList,left.resultdef,left.location,tempcgpara)
+        hlcg.gen_load_loc_cgpara(current_asmdata.CurrAsmList,left.resultdef,left.location,tempcgpara)
+      end;
+
+
+    procedure tcgcallparanode.push_formal_para;
+      begin
+        { allow passing of a constant to a const formaldef }
+        if (parasym.varspez=vs_const) and
+           (left.location.loc in [LOC_CONSTANT,LOC_REGISTER]) then
+          hlcg.location_force_mem(current_asmdata.CurrAsmList,left.location,left.resultdef);
+        push_addr_para;
       end;
 
 
@@ -158,15 +182,18 @@ implementation
              oflabel:=current_procinfo.CurrFalseLabel;
              current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
              current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
+             if assigned(fparainit) then
+               secondpass(fparainit);
              secondpass(left);
 
              maybechangeloadnodereg(current_asmdata.CurrAsmList,left,true);
 
              { release memory for refcnt out parameters }
              if (parasym.varspez=vs_out) and
-                is_managed_type(left.resultdef) then
+                is_managed_type(left.resultdef) and
+                not(target_info.system in systems_garbage_collected_managed_types) 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 elementdef is not managed, omit fpc_decref_array
@@ -181,7 +208,7 @@ implementation
                        end;
                    end
                  else
-                   cg.g_finalize(current_asmdata.CurrAsmList,left.resultdef,href)
+                   hlcg.g_finalize(current_asmdata.CurrAsmList,left.resultdef,href)
                end;
 
              paramanager.createtempparaloc(current_asmdata.CurrAsmList,aktcallnode.procdefinition.proccalloption,parasym,not followed_by_stack_tainting_call_cached,tempcgpara);
@@ -213,14 +240,11 @@ implementation
                end
              { formal def }
              else if (parasym.vardef.typ=formaldef) then
-               begin
-                  { allow passing of a constant to a const formaldef }
-                  if (parasym.varspez=vs_const) and
-                     (left.location.loc in [LOC_CONSTANT,LOC_REGISTER]) then
-                    location_force_mem(current_asmdata.CurrAsmList,left.location);
-                  push_addr_para;
-               end
+               push_formal_para
              { Normal parameter }
+             else if paramanager.push_copyout_param(parasym.varspez,parasym.vardef,
+                         aktcallnode.procdefinition.proccalloption) then
+               push_copyout_para
              else
                begin
                  { don't push a node that already generated a pointer type
@@ -245,13 +269,13 @@ implementation
                           if (left.location.reference.index<>NR_NO) or
                              (left.location.reference.offset<>0) then
                             internalerror(200410107);
-                          cg.a_load_reg_cgpara(current_asmdata.CurrAsmList,OS_ADDR,left.location.reference.base,tempcgpara)
+                          hlcg.a_load_reg_cgpara(current_asmdata.CurrAsmList,voidpointertype,left.location.reference.base,tempcgpara)
                         end
                       else
                         begin
                           { Force to be in memory }
                           if not(left.location.loc in [LOC_CREFERENCE,LOC_REFERENCE]) then
-                            location_force_mem(current_asmdata.CurrAsmList,left.location);
+                            hlcg.location_force_mem(current_asmdata.CurrAsmList,left.location,left.resultdef);
                           push_addr_para;
                         end;
                    end
@@ -287,6 +311,11 @@ implementation
       end;
 
 
+    procedure tcgcallnode.extra_pre_call_code;
+      begin
+      end;
+
+
     procedure tcgcallnode.extra_call_code;
       begin
       end;
@@ -313,11 +342,24 @@ implementation
         else
           begin
             location_reset_ref(location,LOC_REFERENCE,def_cgsize(realresdef),0);
-            tg.GetTemp(current_asmdata.CurrAsmList,retloc.intsize,retloc.Alignment,tt_normal,location.reference);
+            tg.gethltemp(current_asmdata.CurrAsmList,realresdef,retloc.intsize,tt_normal,location.reference);
           end;
       end;
 
 
+    procedure tcgcallnode.do_release_unused_return_value;
+      begin
+        case location.loc of
+          LOC_REFERENCE :
+            begin
+              if is_managed_type(resultdef) then
+                 hlcg.g_finalize(current_asmdata.CurrAsmList,resultdef,location.reference);
+               tg.ungetiftemp(current_asmdata.CurrAsmList,location.reference);
+            end;
+        end;
+      end;
+
+
     procedure tcgcallnode.pop_parasize(pop_size:longint);
       begin
       end;
@@ -369,7 +411,7 @@ implementation
             if (cnf_return_value_used in callnodeflags) or
                assigned(funcretnode) then
               begin
-                gen_load_cgpara_loc(current_asmdata.CurrAsmList,realresdef,retloc,location,false);
+                hlcg.gen_load_cgpara_loc(current_asmdata.CurrAsmList,realresdef,retloc,location,false);
 {$ifdef arm}
                 if (resultdef.typ=floatdef) and
                    (location.loc=LOC_REGISTER) and
@@ -393,7 +435,7 @@ implementation
               function since this is code is only executed after the function call has returned }
             if is_managed_type(funcretnode.resultdef) and
                (funcretnode.nodetype<>temprefn) then
-              cg.g_finalize(current_asmdata.CurrAsmList,funcretnode.resultdef,funcretnode.location.reference);
+              hlcg.g_finalize(current_asmdata.CurrAsmList,funcretnode.resultdef,funcretnode.location.reference);
 
             case location.loc of
               LOC_REGISTER :
@@ -410,9 +452,9 @@ implementation
                 begin
                   case funcretnode.location.loc of
                     LOC_REGISTER:
-                      cg.a_load_ref_reg(current_asmdata.CurrAsmList,location.size,location.size,location.reference,funcretnode.location.register);
+                      hlcg.a_load_ref_reg(current_asmdata.CurrAsmList,resultdef,resultdef,location.reference,funcretnode.location.register);
                     LOC_REFERENCE:
-                      cg.g_concatcopy(current_asmdata.CurrAsmList,location.reference,funcretnode.location.reference,resultdef.size);
+                      hlcg.g_concatcopy(current_asmdata.CurrAsmList,resultdef,location.reference,funcretnode.location.reference);
                     else
                       internalerror(200802121);
                   end;
@@ -433,25 +475,26 @@ implementation
           tree is generated, because that converts the temp from persistent to normal }
         if not(cnf_return_value_used in callnodeflags) then
           begin
-            case location.loc of
-              LOC_REFERENCE :
-                begin
-                  if is_managed_type(resultdef) then
-                     cg.g_finalize(current_asmdata.CurrAsmList,resultdef,location.reference);
-                   tg.ungetiftemp(current_asmdata.CurrAsmList,location.reference);
-                end;
-{$ifdef x86}
-              LOC_FPUREGISTER :
-                 begin
-                   { release FPU stack }
-                   emit_reg(A_FSTP,S_NO,NR_FPU_RESULT_REG);
-                   tcgx86(cg).dec_fpu_stack;
-                 end;
-{$endif x86}
-            end;
+            do_release_unused_return_value;
             if (retloc.intsize<>0) then
               paramanager.freecgpara(current_asmdata.CurrAsmList,retloc);
             location_reset(location,LOC_VOID,OS_NO);
+         end;
+      end;
+
+
+    procedure tcgcallnode.copy_back_paras;
+      var
+        hp,
+        hp2 : tnode;
+        ppn : tcallparanode;
+      begin
+        ppn:=tcallparanode(left);
+        while assigned(ppn) do
+          begin
+             if assigned(ppn.paracopyback) then
+               secondpass(ppn.paracopyback);
+             ppn:=tcallparanode(ppn.right);
           end;
       end;
 
@@ -654,6 +697,8 @@ implementation
             not(procdefinition.has_paraloc_info in [callerside,callbothsides]) then
            internalerror(200305264);
 
+         extra_pre_call_code;
+
          if assigned(callinitblock) then
            secondpass(tnode(callinitblock));
 
@@ -723,6 +768,8 @@ implementation
              name_to_call:='';
              if assigned(fobjcforcedprocname) then
                name_to_call:=fobjcforcedprocname^;
+             { in the JVM, virtual method calls are also name-based }
+{$ifndef jvm}
              { When methodpointer is typen we don't need (and can't) load
                a pointer. We can directly call the correct procdef (PFV) }
              if (name_to_call='') and
@@ -792,6 +839,7 @@ implementation
                  extra_post_call_code;
                end
              else
+{$endif jvm}
                begin
                   { Load parameters that are in temporary registers in the
                     correct parameter register }
@@ -818,9 +866,12 @@ implementation
                         extra_interrupt_code;
                       extra_call_code;
                       if (name_to_call='') then
-                        cg.a_call_name(current_asmdata.CurrAsmList,tprocdef(procdefinition).mangledname,po_weakexternal in procdefinition.procoptions)
+                        if cnf_inherited in callnodeflags then
+                          hlcg.a_call_name_inherited(current_asmdata.CurrAsmList,tprocdef(procdefinition),tprocdef(procdefinition).mangledname)
+                        else
+                          hlcg.a_call_name(current_asmdata.CurrAsmList,tprocdef(procdefinition),tprocdef(procdefinition).mangledname,po_weakexternal in procdefinition.procoptions)
                       else
-                        cg.a_call_name(current_asmdata.CurrAsmList,name_to_call,po_weakexternal in procdefinition.procoptions);
+                        hlcg.a_call_name(current_asmdata.CurrAsmList,tprocdef(procdefinition),name_to_call,po_weakexternal in procdefinition.procoptions);
                       extra_post_call_code;
                     end;
                end;
@@ -936,6 +987,9 @@ implementation
          if assigned(callcleanupblock) then
            secondpass(tnode(callcleanupblock));
 
+         { copy back copy-out parameters if any }
+         copy_back_paras;
+
          { release temps and finalize unused return values, must be
            after the callcleanupblock because that converts temps
            from persistent to normal }

compiler/ncgcnv.pas

@@ -55,6 +55,7 @@ interface
          procedure second_ansistring_to_pchar;override;
          procedure second_class_to_intf;override;
          procedure second_char_to_char;override;
+         procedure second_elem_to_openarray;override;
          procedure second_nothing;override;
        public
          procedure pass_generate_code;override;
@@ -73,7 +74,7 @@ interface
       cpubase,systems,
       procinfo,pass_2,
       cgbase,
-      cgutils,cgobj,
+      cgutils,cgobj,hlcgobj,
       ncgutil,
       tgobj
       ;
@@ -90,7 +91,7 @@ interface
 
         { insert range check if not explicit conversion }
         if not(nf_explicit in flags) then
-          cg.g_rangecheck(current_asmdata.CurrAsmList,left.location,left.resultdef,resultdef);
+          hlcg.g_rangecheck(current_asmdata.CurrAsmList,left.location,left.resultdef,resultdef);
 
         { is the result size smaller? when typecasting from void
           we always reuse the current location, because there is
@@ -322,7 +323,7 @@ interface
       begin
          location_reset(location,LOC_REGISTER,OS_ADDR);
          location.register:=cg.getaddressregister(current_asmdata.CurrAsmList);
-         cg.a_loadaddr_ref_reg(current_asmdata.CurrAsmList,left.location.reference,location.register);
+         hlcg.a_loadaddr_ref_reg(current_asmdata.CurrAsmList,left.resultdef,resultdef,left.location.reference,location.register);
       end;
 
 
@@ -366,7 +367,7 @@ interface
          case tstringdef(resultdef).stringtype of
            st_shortstring :
              begin
-               tg.GetTemp(current_asmdata.CurrAsmList,256,2,tt_normal,location.reference);
+               tg.gethltemp(current_asmdata.CurrAsmList,cshortstringtype,256,tt_normal,location.reference);
                cg.a_load_loc_ref(current_asmdata.CurrAsmList,left.location.size,left.location,
                  location.reference);
                location_freetemp(current_asmdata.CurrAsmList,left.location);
@@ -395,7 +396,7 @@ interface
              if (left.location.loc in [LOC_CREFERENCE,LOC_REFERENCE]) then
                location_force_fpureg(current_asmdata.CurrAsmList,left.location,false);
              { round them down to the proper precision }
-             tg.gettemp(current_asmdata.currasmlist,resultdef.size,resultdef.alignment,tt_normal,tr);
+             tg.gethltemp(current_asmdata.currasmlist,resultdef,resultdef.size,tt_normal,tr);
              cg.a_loadfpu_reg_ref(current_asmdata.CurrAsmList,left.location.size,location.size,left.location.register,tr);
              location_reset_ref(left.location,LOC_REFERENCE,location.size,tr.alignment);
              left.location.reference:=tr;
@@ -414,8 +415,8 @@ interface
                       { on sparc a move from double -> single means from two to one register. }
                       { On all other platforms it also needs rounding to avoid that           }
                       { single(double_regvar) = double_regvar is true in all cases            }
-                      location.register:=cg.getfpuregister(current_asmdata.CurrAsmList,location.size);
-                      cg.a_loadfpu_reg_reg(current_asmdata.CurrAsmList,left.location.size,location.size,left.location.register,location.register);
+                      location.register:=hlcg.getfpuregister(current_asmdata.CurrAsmList,resultdef);
+                      hlcg.a_loadfpu_reg_reg(current_asmdata.CurrAsmList,left.resultdef,resultdef,left.location.register,location.register);
                     end;
                   LOC_MMREGISTER:
                     begin
@@ -438,9 +439,9 @@ interface
                    end
                   else
                     begin
-                      location_force_fpureg(current_asmdata.CurrAsmList,left.location,false);
+                      hlcg.location_force_fpureg(current_asmdata.CurrAsmList,left.location,left.resultdef,false);
                       location.register:=cg.getfpuregister(current_asmdata.CurrAsmList,location.size);
-                      cg.a_loadfpu_reg_reg(current_asmdata.CurrAsmList,left.location.size,location.size,left.location.register,location.register);
+                      hlcg.a_loadfpu_reg_reg(current_asmdata.CurrAsmList,left.resultdef,resultdef,left.location.register,location.register);
                     end;
                  location_freetemp(current_asmdata.CurrAsmList,left.location);
               end;
@@ -496,7 +497,7 @@ interface
                 { assigning a global function to a nested procvar -> create
                   tmethodpointer record and set the "frame pointer" to nil }
                 location_reset_ref(location,LOC_REFERENCE,int_cgsize(sizeof(pint)*2),sizeof(pint));
-                tg.gettemp(current_asmdata.CurrAsmList,resultdef.size,sizeof(pint),tt_normal,location.reference);
+                tg.gethltemp(current_asmdata.CurrAsmList,resultdef,resultdef.size,tt_normal,location.reference);
                 tmpreg:=cg.getaddressregister(current_asmdata.CurrAsmList);
                 cg.a_loadaddr_ref_reg(current_asmdata.CurrAsmList,left.location.reference,tmpreg);
                 cg.a_load_reg_ref(current_asmdata.CurrAsmList,OS_ADDR,OS_ADDR,tmpreg,location.reference);
@@ -515,7 +516,16 @@ interface
     var r:Treference;
 
     begin
-      tg.gettemp(current_asmdata.currasmlist,2*sizeof(puint),sizeof(puint),tt_normal,r);
+{$ifdef jvm}
+{$ifndef nounsupported}
+      tg.gethltemp(current_asmdata.currasmlist,java_jlobject,java_jlobject.size,tt_normal,r);
+      hlcg.a_load_const_ref(current_asmdata.CurrAsmList,java_jlobject,0,r);
+      location_reset_ref(location,LOC_REFERENCE,def_cgsize(resultdef),1);
+      location.reference:=r;
+      exit;
+{$endif}
+{$endif}
+      tg.gethltemp(current_asmdata.currasmlist,methodpointertype,methodpointertype.size,tt_normal,r);
       location_reset_ref(location,LOC_REFERENCE,def_cgsize(resultdef),0);
       location.reference:=r;
       cg.a_load_const_ref(current_asmdata.currasmlist,OS_ADDR,0,r);
@@ -684,6 +694,12 @@ interface
         internalerror(2007081202);
       end;
 
+    procedure tcgtypeconvnode.second_elem_to_openarray;
+      begin
+        { nothing special to do by default }
+        second_nothing;
+      end;
+
 
     procedure tcgtypeconvnode.second_nothing;
       var

compiler/ncgcon.pas

@@ -27,6 +27,7 @@ unit ncgcon;
 interface
 
     uses
+       aasmbase,
        node,ncon;
 
     type
@@ -51,6 +52,10 @@ interface
        end;
 
        tcgsetconstnode = class(tsetconstnode)
+         protected
+          function emitvarsetconst: tasmsymbol; virtual;
+          procedure handlevarsetconst;
+         public
           procedure pass_generate_code;override;
        end;
 
@@ -68,10 +73,10 @@ implementation
     uses
       globtype,widestr,systems,
       verbose,globals,cutils,
-      symconst,symdef,aasmbase,aasmtai,aasmdata,aasmcpu,defutil,
+      symconst,symdef,aasmtai,aasmdata,aasmcpu,defutil,
       cpuinfo,cpubase,
       cgbase,cgobj,cgutils,
-      ncgutil, cclasses,asmutils
+      ncgutil, cclasses,asmutils,tgobj
       ;
 
 
@@ -369,71 +374,112 @@ implementation
                            TCGSETCONSTNODE
 *****************************************************************************}
 
-    procedure tcgsetconstnode.pass_generate_code;
-
+    function tcgsetconstnode.emitvarsetconst: tasmsymbol;
       type
+        setbytes=array[0..31] of byte;
+        Psetbytes=^setbytes;
+      var
+        lab: tasmlabel;
+        i: longint;
+      begin
+        current_asmdata.getdatalabel(lab);
+        result:=lab;
+        lab_set:=lab;
+        maybe_new_object_file(current_asmdata.asmlists[al_typedconsts]);
+        new_section(current_asmdata.asmlists[al_typedconsts],sec_rodata_norel,result.name,const_align(8));
+        current_asmdata.asmlists[al_typedconsts].concat(Tai_label.Create(lab));
+        if (source_info.endian=target_info.endian) then
+          for i:=0 to 31 do
+            current_asmdata.asmlists[al_typedconsts].concat(Tai_const.Create_8bit(Psetbytes(value_set)^[i]))
+        else
+          for i:=0 to 31 do
+            current_asmdata.asmlists[al_typedconsts].concat(Tai_const.Create_8bit(reverse_byte(Psetbytes(value_set)^[i])));
+      end;
+
+
+    procedure tcgsetconstnode.handlevarsetconst;
+      var
+         entry       : PHashSetItem;
+      begin
+        location_reset_ref(location,LOC_CREFERENCE,OS_NO,const_align(8));
+        { const already used ? }
+        if not assigned(lab_set) then
+          begin
+            entry := current_asmdata.ConstPools[sp_varsets].FindOrAdd(value_set, 32);
+
+             { :-(, we must generate a new entry }
+             if not assigned(entry^.Data) then
+               entry^.Data:=emitvarsetconst;
+             lab_set := TAsmSymbol(entry^.Data);
+          end;
+        location.reference.symbol:=lab_set;
+      end;
+
+
+    procedure tcgsetconstnode.pass_generate_code;
+       type
          setbytes=array[0..31] of byte;
          Psetbytes=^setbytes;
 
         procedure smallsetconst;
-        begin
-          location_reset(location,LOC_CONSTANT,int_cgsize(resultdef.size));
-          if (source_info.endian=target_info.endian) then
-            begin
-              { not plongint, because that will "sign extend" the set on 64 bit platforms }
-              { if changed to "paword", please also modify "32-resultdef.size*8" and      }
-              { cross-endian code below                                                   }
-              { Extra aint type cast to avoid range errors                                }
-              location.value:=aint(pCardinal(value_set)^)
-            end
-          else
-            begin
-              location.value:=swapendian(Pcardinal(value_set)^);
-              location.value:=aint(
-                                 reverse_byte (location.value         and $ff)         or
-                                (reverse_byte((location.value shr  8) and $ff) shl  8) or
-                                (reverse_byte((location.value shr 16) and $ff) shl 16) or
-                                (reverse_byte((location.value shr 24) and $ff) shl 24)
-                              );
-            end;
-          if (target_info.endian=endian_big) then
-            location.value:=location.value shr (32-resultdef.size*8);
-        end;
+          begin
+            location_reset(location,LOC_CONSTANT,int_cgsize(resultdef.size));
+            if (source_info.endian=target_info.endian) then
+              begin
+                { not plongint, because that will "sign extend" the set on 64 bit platforms }
+                { if changed to "paword", please also modify "32-resultdef.size*8" and      }
+                { cross-endian code below                                                   }
+                { Extra aint type cast to avoid range errors                                }
+                location.value:=aint(pCardinal(value_set)^)
+              end
+            else
+              begin
+                location.value:=swapendian(Pcardinal(value_set)^);
+                location.value:=aint(
+                                   reverse_byte (location.value         and $ff)         or
+                                  (reverse_byte((location.value shr  8) and $ff) shl  8) or
+                                  (reverse_byte((location.value shr 16) and $ff) shl 16) or
+                                  (reverse_byte((location.value shr 24) and $ff) shl 24)
+                                );
+              end;
+            if (target_info.endian=endian_big) then
+              location.value:=location.value shr (32-resultdef.size*8);
+          end;
 
         procedure varsetconst;
-        var
-           lastlabel   : tasmlabel;
-           i           : longint;
-           entry       : PHashSetItem;
-        begin
-          location_reset_ref(location,LOC_CREFERENCE,OS_NO,const_align(8));
-          lastlabel:=nil;
-          { const already used ? }
-          if not assigned(lab_set) then
-            begin
-              entry := current_asmdata.ConstPools[sp_varsets].FindOrAdd(value_set, 32);
-
-              lab_set := TAsmLabel(entry^.Data);  // is it needed anymore?
-
-               { :-(, we must generate a new entry }
-               if not assigned(entry^.Data) then
-                 begin
-                   current_asmdata.getdatalabel(lastlabel);
-                   lab_set:=lastlabel;
-                   entry^.Data:=lastlabel;
-                   maybe_new_object_file(current_asmdata.asmlists[al_typedconsts]);
-                   new_section(current_asmdata.asmlists[al_typedconsts],sec_rodata_norel,lastlabel.name,const_align(8));
-                   current_asmdata.asmlists[al_typedconsts].concat(Tai_label.Create(lastlabel));
-                   if (source_info.endian=target_info.endian) then
-                     for i:=0 to 31 do
-                       current_asmdata.asmlists[al_typedconsts].concat(Tai_const.Create_8bit(Psetbytes(value_set)^[i]))
-                   else
-                     for i:=0 to 31 do
-                       current_asmdata.asmlists[al_typedconsts].concat(Tai_const.Create_8bit(reverse_byte(Psetbytes(value_set)^[i])));
-                 end;
-            end;
-          location.reference.symbol:=lab_set;
-        end;
+          var
+             lastlabel   : tasmlabel;
+             i           : longint;
+             entry       : PHashSetItem;
+          begin
+            location_reset_ref(location,LOC_CREFERENCE,OS_NO,const_align(8));
+            lastlabel:=nil;
+            { const already used ? }
+            if not assigned(lab_set) then
+              begin
+                entry := current_asmdata.ConstPools[sp_varsets].FindOrAdd(value_set, 32);
+
+                lab_set := TAsmLabel(entry^.Data);  // is it needed anymore?
+
+                 { :-(, we must generate a new entry }
+                 if not assigned(entry^.Data) then
+                   begin
+                     current_asmdata.getdatalabel(lastlabel);
+                     lab_set:=lastlabel;
+                     entry^.Data:=lastlabel;
+                     maybe_new_object_file(current_asmdata.asmlists[al_typedconsts]);
+                     new_section(current_asmdata.asmlists[al_typedconsts],sec_rodata_norel,lastlabel.name,const_align(8));
+                     current_asmdata.asmlists[al_typedconsts].concat(Tai_label.Create(lastlabel));
+                     if (source_info.endian=target_info.endian) then
+                       for i:=0 to 31 do
+                         current_asmdata.asmlists[al_typedconsts].concat(Tai_const.Create_8bit(Psetbytes(value_set)^[i]))
+                     else
+                       for i:=0 to 31 do
+                         current_asmdata.asmlists[al_typedconsts].concat(Tai_const.Create_8bit(reverse_byte(Psetbytes(value_set)^[i])));
+                   end;
+              end;
+            location.reference.symbol:=lab_set;
+          end;
 
       begin
         adjustforsetbase;
@@ -442,7 +488,7 @@ implementation
         if is_smallset(resultdef) then
           smallsetconst
         else
-          varsetconst;
+          handlevarsetconst;
       end;
 
 

compiler/ncgflw.pas

@@ -99,7 +99,7 @@ implementation
       nld,ncon,
       tgobj,paramgr,
       regvars,
-      cgutils,cgobj,nutils
+      cgutils,cgobj,hlcgobj,nutils
       ;
 
 {*****************************************************************************
@@ -159,13 +159,13 @@ implementation
          { handling code at the end as it is much more efficient, and makes
            while equal to repeat loop, only the end true/false is swapped (PFV) }
          if lnf_testatbegin in loopflags then
-           cg.a_jmp_always(current_asmdata.CurrAsmList,lcont);
+           hlcg.a_jmp_always(current_asmdata.CurrAsmList,lcont);
 
          if not(cs_opt_size in current_settings.optimizerswitches) then
             { align loop target }
             current_asmdata.CurrAsmList.concat(Tai_align.Create(current_settings.alignment.loopalign));
 
-         cg.a_label(current_asmdata.CurrAsmList,lloop);
+         hlcg.a_label(current_asmdata.CurrAsmList,lloop);
 
          current_procinfo.CurrContinueLabel:=lcont;
          current_procinfo.CurrBreakLabel:=lbreak;
@@ -183,7 +183,7 @@ implementation
          load_all_regvars(current_asmdata.CurrAsmList);
 {$endif OLDREGVARS}
 
-         cg.a_label(current_asmdata.CurrAsmList,lcont);
+         hlcg.a_label(current_asmdata.CurrAsmList,lcont);
          otlabel:=current_procinfo.CurrTrueLabel;
          oflabel:=current_procinfo.CurrFalseLabel;
          if lnf_checknegate in loopflags then
@@ -198,8 +198,8 @@ implementation
           end;
          secondpass(left);
 
-         maketojumpbool(current_asmdata.CurrAsmList,left,lr_load_regvars);
-         cg.a_label(current_asmdata.CurrAsmList,lbreak);
+         hlcg.maketojumpbool(current_asmdata.CurrAsmList,left);
+         hlcg.a_label(current_asmdata.CurrAsmList,lbreak);
 
          sync_regvars(false);
 
@@ -255,7 +255,7 @@ implementation
              current_asmdata.CurrAsmList := TAsmList.create;
            end;
 *)
-         maketojumpbool(current_asmdata.CurrAsmList,left,lr_dont_load_regvars);
+         hlcg.maketojumpbool(current_asmdata.CurrAsmList,left);
 
 (*
          if cs_opt_regvar in current_settings.optimizerswitches then
@@ -272,7 +272,7 @@ implementation
 
          if assigned(right) then
            begin
-              cg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
+              hlcg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
               secondpass(right);
            end;
 
@@ -305,9 +305,9 @@ implementation
                      current_filepos:=then_list.getlasttaifilepos^
 *)
                    ;
-                   cg.a_jmp_always(current_asmdata.CurrAsmList,hl);
+                   hlcg.a_jmp_always(current_asmdata.CurrAsmList,hl);
                 end;
-              cg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+              hlcg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
               secondpass(t1);
 (*
               { save current asmlist (previous instructions + else-block) }
@@ -321,7 +321,7 @@ implementation
                 end;
 *)
               if assigned(right) then
-                cg.a_label(current_asmdata.CurrAsmList,hl);
+                hlcg.a_label(current_asmdata.CurrAsmList,hl);
            end
          else
            begin
@@ -334,11 +334,11 @@ implementation
                   current_asmdata.CurrAsmList := TAsmList.create;
                 end;
 *)
-              cg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+              hlcg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
            end;
          if not(assigned(right)) then
            begin
-              cg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
+              hlcg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
            end;
 
 (*
@@ -467,7 +467,7 @@ implementation
           end;
         secondpass(t1);
         if t1.location.loc in [LOC_FLAGS,LOC_JUMP] then
-          location_force_reg(current_asmdata.CurrAsmList,t1.location,def_cgsize(t1.resultdef),false);
+          hlcg.location_force_reg(current_asmdata.CurrAsmList,t1.location,t1.resultdef,t1.resultdef,false);
         if isjump then
           begin
             current_procinfo.CurrTrueLabel:=otl;
@@ -478,7 +478,7 @@ implementation
          if t1.nodetype<>ordconstn then
            begin
               do_loopvar_at_end:=false;
-              location_force_reg(current_asmdata.CurrAsmList,t1.location,t1.location.size,false);
+              hlcg.location_force_reg(current_asmdata.CurrAsmList,t1.location,t1.resultdef,t1.resultdef,false);
               temptovalue:=true;
            end
          else
@@ -501,7 +501,7 @@ implementation
            end;
          secondpass(right);
          if right.location.loc in [LOC_FLAGS,LOC_JUMP] then
-           location_force_reg(current_asmdata.CurrAsmList,right.location,def_cgsize(right.resultdef),false);
+           hlcg.location_force_reg(current_asmdata.CurrAsmList,right.location,right.resultdef,right.resultdef,false);
          if isjump then
            begin
              current_procinfo.CurrTrueLabel:=otl;
@@ -515,13 +515,16 @@ implementation
          case left.location.loc of
            LOC_REFERENCE,
            LOC_CREFERENCE :
-             cg.a_load_loc_ref(current_asmdata.CurrAsmList,left.location.size,right.location,left.location.reference);
+             hlcg.a_load_loc_ref(current_asmdata.CurrAsmList,right.resultdef,left.resultdef,right.location,left.location.reference);
            LOC_REGISTER,
            LOC_CREGISTER:
-             cg.a_load_loc_reg(current_asmdata.CurrAsmList,left.location.size,right.location,left.location.register);
+             hlcg.a_load_loc_reg(current_asmdata.CurrAsmList,right.resultdef,left.resultdef,right.location,left.location.register);
+{$ifndef cpuhighleveltarget}
+           { still have to figure out how to handle the subset sizes }
            LOC_SUBSETREG,
            LOC_CSUBSETREG :
              cg.a_load_loc_subsetreg(current_asmdata.CurrAsmList,left.location.size,right.location,left.location.sreg);
+{$endif}
            else
              internalerror(200501311);
          end;
@@ -544,14 +547,14 @@ implementation
 
          if temptovalue then
            begin
-             cg.a_cmp_reg_loc_label(current_asmdata.CurrAsmList,opsize,hcond,
+             hlcg.a_cmp_reg_loc_label(current_asmdata.CurrAsmList,left.resultdef,hcond,
                t1.location.register,left.location,current_procinfo.CurrBreakLabel);
            end
          else
            begin
              if lnf_testatbegin in loopflags then
                begin
-                 cg.a_cmp_const_loc_label(current_asmdata.CurrAsmList,opsize,hcond,
+                 hlcg.a_cmp_const_loc_label(current_asmdata.CurrAsmList,left.resultdef,hcond,
                    tordconstnode(t1).value.svalue,
                    left.location,current_procinfo.CurrBreakLabel);
                end;
@@ -566,16 +569,16 @@ implementation
                 hop:=OP_ADD
               else
                 hop:=OP_SUB;
-              cg.a_op_const_loc(current_asmdata.CurrAsmList,hop,1,left.location);
+              hlcg.a_op_const_loc(current_asmdata.CurrAsmList,hop,left.resultdef,1,left.location);
             end;
 
          if assigned(entrylabel) then
-           cg.a_jmp_always(current_asmdata.CurrAsmList,tcglabelnode(entrylabel).getasmlabel);
+           hlcg.a_jmp_always(current_asmdata.CurrAsmList,tcglabelnode(entrylabel).getasmlabel);
 
          { align loop target }
          if not(cs_opt_size in current_settings.optimizerswitches) then
             current_asmdata.CurrAsmList.concat(Tai_align.Create(current_settings.alignment.loopalign));
-         cg.a_label(current_asmdata.CurrAsmList,l3);
+         hlcg.a_label(current_asmdata.CurrAsmList,l3);
 
          {If the loopvar doesn't mind on exit, we avoid the loopvar inc/dec
           after the loop body instead of here.}
@@ -586,7 +589,7 @@ implementation
                 hop:=OP_SUB
               else
                 hop:=OP_ADD;
-              cg.a_op_const_loc(current_asmdata.CurrAsmList,hop,1,left.location);
+              hlcg.a_op_const_loc(current_asmdata.CurrAsmList,hop,left.resultdef,1,left.location);
             end;
 
          if assigned(t2) then
@@ -610,10 +613,10 @@ implementation
                 hop:=OP_SUB
               else
                 hop:=OP_ADD;
-              cg.a_op_const_loc(current_asmdata.CurrAsmList,hop,1,left.location);
+              hlcg.a_op_const_loc(current_asmdata.CurrAsmList,hop,left.resultdef,1,left.location);
             end;
 
-         cg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrContinueLabel);
+         hlcg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrContinueLabel);
 
          if do_loopvar_at_end then
            if lnf_backward in loopflags then
@@ -645,7 +648,7 @@ implementation
          { jump                                     }
          if temptovalue then
            begin
-             cg.a_cmp_reg_loc_label(current_asmdata.CurrAsmList,opsize,hcond,t1.location.register,
+             hlcg.a_cmp_reg_loc_label(current_asmdata.CurrAsmList,left.resultdef,hcond,t1.location.register,
                left.location,l3);
            end
          else
@@ -813,12 +816,12 @@ implementation
                  end;
                end;
 
-             cg.a_cmp_const_loc_label(current_asmdata.CurrAsmList,opsize,hcond,
+             hlcg.a_cmp_const_loc_label(current_asmdata.CurrAsmList,left.resultdef,hcond,
                aint(cmp_const.svalue),left.location,l3);
            end;
 
          { this is the break label: }
-         cg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrBreakLabel);
+         hlcg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrBreakLabel);
 
          sync_regvars(false);
 
@@ -840,10 +843,11 @@ implementation
          include(flowcontrol,fc_exit);
          if assigned(left) then
            secondpass(left);
+
          if (fc_unwind in flowcontrol) then
-           cg.g_local_unwind(current_asmdata.CurrAsmList,current_procinfo.CurrExitLabel)
+           hlcg.g_local_unwind(current_asmdata.CurrAsmList,current_procinfo.CurrExitLabel)
          else
-           cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrExitLabel);
+           hlcg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrExitLabel);
        end;
 
 
@@ -862,9 +866,9 @@ implementation
              load_all_regvars(current_asmdata.CurrAsmList);
 {$endif OLDREGVARS}
              if (fc_unwind in flowcontrol) then
-               cg.g_local_unwind(current_asmdata.CurrAsmList,current_procinfo.CurrBreakLabel)
+               hlcg.g_local_unwind(current_asmdata.CurrAsmList,current_procinfo.CurrBreakLabel)
              else
-               cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrBreakLabel)
+               hlcg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrBreakLabel)
            end
          else
            CGMessage(cg_e_break_not_allowed);
@@ -886,9 +890,9 @@ implementation
              load_all_regvars(current_asmdata.CurrAsmList);
 {$endif OLDREGVARS}
              if (fc_unwind in flowcontrol) then
-               cg.g_local_unwind(current_asmdata.CurrAsmList,current_procinfo.CurrContinueLabel)
+               hlcg.g_local_unwind(current_asmdata.CurrAsmList,current_procinfo.CurrContinueLabel)
              else
-               cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrContinueLabel)
+               hlcg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrContinueLabel)
            end
          else
            CGMessage(cg_e_continue_not_allowed);
@@ -908,7 +912,7 @@ implementation
 {$ifdef OLDREGVARS}
          load_all_regvars(current_asmdata.CurrAsmList);
 {$endif OLDREGVARS}
-         cg.a_jmp_always(current_asmdata.CurrAsmList,tcglabelnode(labelnode).getasmlabel)
+         hlcg.a_jmp_always(current_asmdata.CurrAsmList,tcglabelnode(labelnode).getasmlabel)
        end;
 
 
@@ -938,13 +942,13 @@ implementation
 {$ifdef OLDREGVARS}
          load_all_regvars(current_asmdata.CurrAsmList);
 {$endif OLDREGVARS}
-         cg.a_label(current_asmdata.CurrAsmList,getasmlabel);
+         hlcg.a_label(current_asmdata.CurrAsmList,getasmlabel);
 
          { Write also extra label if this label was referenced from
            assembler block }
          if assigned(labsym) and
             assigned(labsym.asmblocklabel) then
-           cg.a_label(current_asmdata.CurrAsmList,labsym.asmblocklabel);
+           hlcg.a_label(current_asmdata.CurrAsmList,labsym.asmblocklabel);
 
          secondpass(left);
       end;
@@ -1342,12 +1346,11 @@ implementation
          if assigned(excepTSymtable) then
            exceptvarsym:=tlocalvarsym(excepTSymtable.SymList[0])
          else
-           exceptvarsym:=nil;
+           internalerror(2011020401);
 
          if assigned(exceptvarsym) then
            begin
-             exceptvarsym.localloc.loc:=LOC_REFERENCE;
-             exceptvarsym.localloc.size:=OS_ADDR;
+             location_reset_ref(exceptvarsym.localloc,LOC_REFERENCE,OS_ADDR,sizeof(pint));
              tg.GetLocal(current_asmdata.CurrAsmList,sizeof(pint),voidpointertype,exceptvarsym.localloc.reference);
              cg.a_load_reg_ref(current_asmdata.CurrAsmList,OS_ADDR,OS_ADDR,NR_FUNCTION_RESULT_REG,exceptvarsym.localloc.reference);
            end;

compiler/ncginl.pas

@@ -57,6 +57,9 @@ interface
           procedure second_rox; virtual;
           procedure second_sar; virtual;
           procedure second_bsfbsr; virtual;
+          procedure second_new; virtual;
+          procedure second_setlength; virtual; abstract;
+          procedure second_box; virtual; abstract;
        end;
 
 implementation
@@ -70,7 +73,7 @@ implementation
       cpuinfo,cpubase,paramgr,procinfo,
       nbas,ncon,ncal,ncnv,nld,ncgrtti,
       tgobj,ncgutil,
-      cgutils,cgobj
+      cgutils,cgobj,hlcgobj
 {$ifndef cpu64bitalu}
       ,cg64f32
 {$endif not cpu64bitalu}
@@ -173,6 +176,12 @@ implementation
             in_bsf_x,
             in_bsr_x:
                second_BsfBsr;
+            in_new_x:
+               second_new;
+            in_setlength_x:
+               second_setlength;
+            in_box_x:
+               second_box;
             else internalerror(9);
          end;
       end;
@@ -377,7 +386,6 @@ implementation
 
     procedure tcginlinenode.second_PredSucc;
       var
-         cgsize : TCGSize;
          cgop : topcg;
       begin
         secondpass(left);
@@ -385,18 +393,17 @@ implementation
            cgop:=OP_SUB
         else
            cgop:=OP_ADD;
-        cgsize:=def_cgsize(resultdef);
 
         { we need a value in a register }
         location_copy(location,left.location);
-        location_force_reg(current_asmdata.CurrAsmList,location,cgsize,false);
+        hlcg.location_force_reg(current_asmdata.CurrAsmList,location,resultdef,resultdef,false);
 
 {$ifndef cpu64bitalu}
-        if cgsize in [OS_64,OS_S64] then
-          cg64.a_op64_const_reg(current_asmdata.CurrAsmList,cgop,cgsize,1,location.register64)
+        if def_cgsize(resultdef) in [OS_64,OS_S64] then
+          cg64.a_op64_const_reg(current_asmdata.CurrAsmList,cgop,def_cgsize(resultdef),1,location.register64)
         else
 {$endif not cpu64bitalu}
-          cg.a_op_const_reg(current_asmdata.CurrAsmList,cgop,location.size,1,location.register);
+          hlcg.a_op_const_reg(current_asmdata.CurrAsmList,cgop,resultdef,1,location.register);
       end;
 
 
@@ -413,7 +420,6 @@ implementation
          hregisterhi,
 {$endif not cpu64bitalu}
          hregister : tregister;
-         cgsize : tcgsize;
         begin
           { set defaults }
           addconstant:=true;
@@ -424,7 +430,6 @@ implementation
             secondpass(tcallparanode(tcallparanode(left).right).left);
           { load first parameter, must be a reference }
           secondpass(tcallparanode(left).left);
-          cgsize:=def_cgsize(tcallparanode(left).left.resultdef);
           { get addvalue }
           case tcallparanode(left).left.resultdef.typ of
             orddef,
@@ -450,14 +455,14 @@ implementation
                  addvalue:=addvalue*tpointerconstnode(tcallparanode(tcallparanode(left).right).left).value
               else
                 begin
-                  location_force_reg(current_asmdata.CurrAsmList,tcallparanode(tcallparanode(left).right).left.location,cgsize,addvalue<=1);
+                  hlcg.location_force_reg(current_asmdata.CurrAsmList,tcallparanode(tcallparanode(left).right).left.location,left.resultdef,left.resultdef,addvalue<=1);
                   hregister:=tcallparanode(tcallparanode(left).right).left.location.register;
 {$ifndef cpu64bitalu}
                   hregisterhi:=tcallparanode(tcallparanode(left).right).left.location.register64.reghi;
 {$endif not cpu64bitalu}
                   { insert multiply with addvalue if its >1 }
                   if addvalue>1 then
-                    cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_IMUL,cgsize,addvalue.svalue,hregister);
+                    hlcg.a_op_const_reg(current_asmdata.CurrAsmList,OP_IMUL,left.resultdef,addvalue.svalue,hregister);
                   addconstant:=false;
                 end;
             end;
@@ -465,22 +470,22 @@ implementation
           if addconstant then
             begin
 {$ifndef cpu64bitalu}
-              if cgsize in [OS_64,OS_S64] then
-                cg64.a_op64_const_loc(current_asmdata.CurrAsmList,addsubop[inlinenumber],cgsize,addvalue,tcallparanode(left).left.location)
+              if def_cgsize(left.resultdef) in [OS_64,OS_S64] then
+                cg64.a_op64_const_loc(current_asmdata.CurrAsmList,addsubop[inlinenumber],def_cgsize(left.resultdef),addvalue,tcallparanode(left).left.location)
               else
 {$endif not cpu64bitalu}
-                cg.a_op_const_loc(current_asmdata.CurrAsmList,addsubop[inlinenumber],
+                hlcg.a_op_const_loc(current_asmdata.CurrAsmList,addsubop[inlinenumber],left.resultdef,
                   aint(addvalue.svalue),tcallparanode(left).left.location);
             end
            else
              begin
 {$ifndef cpu64bitalu}
-               if cgsize in [OS_64,OS_S64] then
-                 cg64.a_op64_reg_loc(current_asmdata.CurrAsmList,addsubop[inlinenumber],cgsize,
+               if def_cgsize(left.resultdef) in [OS_64,OS_S64] then
+                 cg64.a_op64_reg_loc(current_asmdata.CurrAsmList,addsubop[inlinenumber],def_cgsize(left.resultdef),
                    joinreg64(hregister,hregisterhi),tcallparanode(left).left.location)
                else
 {$endif not cpu64bitalu}
-                 cg.a_op_reg_loc(current_asmdata.CurrAsmList,addsubop[inlinenumber],
+                 hlcg.a_op_reg_loc(current_asmdata.CurrAsmList,addsubop[inlinenumber],left.resultdef,
                    hregister,tcallparanode(left).left.location);
              end;
           { no overflow checking for pointers (see ninl), and range checking }
@@ -613,22 +618,19 @@ implementation
 
     procedure tcginlinenode.second_abs_long;
       var
-        opsize : tcgsize;
-        tempreg1, tempreg2 : tregister;
+        tempreg1, tempreg2: tregister;
       begin
-        opsize := def_cgsize(left.resultdef);
-
         secondpass(left);
-        location_force_reg(current_asmdata.CurrAsmList, left.location, opsize, false);
-        location := left.location;
-        location.register := cg.getintregister(current_asmdata.CurrAsmList, opsize);
+        hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,left.resultdef,true);
+        location:=left.location;
+        location.register:=hlcg.getintregister(current_asmdata.CurrAsmList,left.resultdef);
 
-        tempreg1 := cg.getintregister(current_asmdata.CurrAsmList, opsize);
-        tempreg2 := cg.getintregister(current_asmdata.CurrAsmList, opsize);
+        tempreg1:=hlcg.getintregister(current_asmdata.CurrAsmList,left.resultdef);
+        tempreg2:=hlcg.getintregister(current_asmdata.CurrAsmList,left.resultdef);
 	
-        cg.a_op_const_reg_reg(current_asmdata.CurrAsmList, OP_SAR, OS_INT, tcgsize2size[opsize]*8-1, left.location.register, tempreg1);
-        cg.a_op_reg_reg_reg(current_asmdata.CurrAsmList, OP_XOR, OS_INT, left.location.register, tempreg1, tempreg2);
-        cg.a_op_reg_reg_reg(current_asmdata.CurrAsmlist, OP_SUB, OS_INT, tempreg1, tempreg2, location.register);
+        hlcg.a_op_const_reg_reg(current_asmdata.CurrAsmList,OP_SAR,left.resultdef,left.resultdef.size*8-1,left.location.register,tempreg1);
+        hlcg.a_op_reg_reg_reg(current_asmdata.CurrAsmList,OP_XOR,left.resultdef,left.location.register,tempreg1,tempreg2);
+        hlcg.a_op_reg_reg_reg(current_asmdata.CurrAsmlist,OP_SUB,left.resultdef,tempreg1,tempreg2,location.register);
       end;
 
 
@@ -639,8 +641,8 @@ implementation
     procedure tcginlinenode.second_assigned;
       begin
         secondpass(tcallparanode(left).left);
-        cg.a_cmp_const_loc_label(current_asmdata.CurrAsmList,def_cgsize(left.resultdef),OC_NE,0,tcallparanode(left).left.location,current_procinfo.CurrTrueLabel);
-        cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+        hlcg.a_cmp_const_loc_label(current_asmdata.CurrAsmList,left.resultdef,OC_NE,0,tcallparanode(left).left.location,current_procinfo.CurrTrueLabel);
+        hlcg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
         location_reset(location,LOC_JUMP,OS_NO);
       end;
 
@@ -788,21 +790,21 @@ implementation
         { load left operator in a register }
         location_copy(location,op1.location);
 
-        location_force_reg(current_asmdata.CurrAsmList,location,location.size,false);
+        hlcg.location_force_reg(current_asmdata.CurrAsmList,location,op1.resultdef,resultdef,false);
 
         if not(assigned(op2)) then
-          cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_SAR,location.size,1,location.register)
+          hlcg.a_op_const_reg(current_asmdata.CurrAsmList,OP_SAR,resultdef,1,location.register)
         else
           begin
             secondpass(op2);
             { shifting by a constant directly coded: }
             if op2.nodetype=ordconstn then
-              cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_SAR,location.size,
+              hlcg.a_op_const_reg(current_asmdata.CurrAsmList,OP_SAR,resultdef,
                                   tordconstnode(op2).value.uvalue and (resultdef.size*8-1),location.register)
             else
               begin
-                location_force_reg(current_asmdata.CurrAsmList,op2.location,location.size,false);
-                cg.a_op_reg_reg(current_asmdata.CurrAsmList,OP_SAR,location.size,op2.location.register,location.register);
+                hlcg.location_force_reg(current_asmdata.CurrAsmList,op2.location,op2.resultdef,resultdef,false);
+                hlcg.a_op_reg_reg(current_asmdata.CurrAsmList,OP_SAR,resultdef,op2.location.register,location.register);
              end;
           end;
       end;
@@ -830,6 +832,12 @@ implementation
     end;
 
 
+    procedure tcginlinenode.second_new;
+      begin
+        internalerror(2011012202);
+      end;
+
+
 begin
    cinlinenode:=tcginlinenode;
 end.

compiler/ncgld.pas

@@ -27,20 +27,33 @@ unit ncgld;
 interface
 
     uses
+      globtype,
+      symtype,
+      aasmdata,
       node,nld,cgutils;
 
     type
        tcgloadnode = class(tloadnode)
+         protected
+          procedure generate_nested_access(vs: tsym);virtual;
+         public
           procedure pass_generate_code;override;
           procedure generate_picvaraccess;virtual;
           procedure changereflocation(const ref: treference);
        end;
 
        tcgassignmentnode = class(tassignmentnode)
+        protected
+          function maybechangetemp(list: TAsmList; var n: tnode; const newref: treference): boolean;virtual;
+        public
           procedure pass_generate_code;override;
        end;
 
        tcgarrayconstructornode = class(tarrayconstructornode)
+         protected
+          procedure makearrayref(var ref: treference; eledef: tdef);virtual;
+          procedure advancearrayoffset(var ref: treference; elesize: asizeint);virtual;
+         public
           procedure pass_generate_code;override;
        end;
 
@@ -54,16 +67,16 @@ implementation
     uses
       cutils,
       systems,
-      verbose,globtype,globals,constexp,
+      verbose,globals,constexp,
       nutils,
-      symtable,symconst,symtype,symdef,symsym,defutil,paramgr,
+      symtable,symconst,symdef,symsym,defutil,paramgr,
       ncnv,ncon,nmem,nbas,ncgrtti,
-      aasmbase,aasmtai,aasmdata,aasmcpu,
+      aasmbase,aasmtai,aasmcpu,
       cgbase,pass_2,
       procinfo,
       cpubase,parabase,
       tgobj,ncgutil,
-      cgobj,
+      cgobj,hlcgobj,
       ncgbas,ncgflw,
       wpobase;
 
@@ -149,7 +162,7 @@ implementation
       end;
 
 
-    function maybechangetemp(list: TAsmList; var n: tnode; const newref: treference): boolean;
+    function tcgassignmentnode.maybechangetemp(list: TAsmList; var n: tnode; const newref: treference): boolean;
       var
         rr: treplacerefrec;
       begin
@@ -229,6 +242,20 @@ implementation
       end;
 
 
+    procedure tcgloadnode.generate_nested_access(vs: tsym);
+      var
+        { paramter declared as tsym to reduce interface unit dependencies }
+        lvs: tabstractnormalvarsym absolute vs;
+      begin
+        secondpass(left);
+        if not(left.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
+          internalerror(200309286);
+        if lvs.localloc.loc<>LOC_REFERENCE then
+          internalerror(200409241);
+        reference_reset_base(location.reference,left.location.register,lvs.localloc.reference.offset,lvs.localloc.reference.alignment);
+      end;
+
+
     procedure tcgloadnode.pass_generate_code;
       var
         hregister : tregister;
@@ -286,7 +313,6 @@ implementation
            staticvarsym :
              begin
                gvs:=tstaticvarsym(symtableentry);
-               location.reference.alignment:=var_align(gvs.vardef.alignment);
 
                if (vo_is_dll_var in gvs.varoptions) then
                { DLL variable }
@@ -395,14 +421,7 @@ implementation
                 vs:=tabstractnormalvarsym(symtableentry);
                 { Nested variable }
                 if assigned(left) then
-                  begin
-                    secondpass(left);
-                    if not(left.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
-                      internalerror(200309286);
-                    if vs.localloc.loc<>LOC_REFERENCE then
-                      internalerror(200409241);
-                    reference_reset_base(location.reference,left.location.register,vs.localloc.reference.offset,vs.localloc.reference.alignment);
-                  end
+                  generate_nested_access(vs)
                 else
                   location:=vs.localloc;
 
@@ -415,10 +434,10 @@ implementation
                       hregister:=location.register
                     else
                       begin
-                        hregister:=cg.getaddressregister(current_asmdata.CurrAsmList);
+                        hregister:=hlcg.getaddressregister(current_asmdata.CurrAsmList,voidpointertype);
                         { we need to load only an address }
                         location.size:=OS_ADDR;
-                        cg.a_load_loc_reg(current_asmdata.CurrAsmList,location.size,location,hregister);
+                        hlcg.a_load_loc_reg(current_asmdata.CurrAsmList,voidpointertype,voidpointertype,location,hregister);
                       end;
                     { assume packed records may always be unaligned }
                     if not(resultdef.typ in [recorddef,objectdef]) or
@@ -447,7 +466,7 @@ implementation
                      {$else}
                         internalerror(20020520);
                      {$endif} {$endif}
-                     tg.GetTemp(current_asmdata.CurrAsmList,2*sizeof(pint),sizeof(pint),tt_normal,location.reference);
+                     tg.gethltemp(current_asmdata.CurrAsmList,methodpointertype,methodpointertype.size,tt_normal,location.reference);
                      secondpass(left);
 
                      { load class instance/classrefdef address }
@@ -556,7 +575,9 @@ implementation
       begin
         location_reset(location,LOC_VOID,OS_NO);
         { managed types should be handled in firstpass }
-        if is_managed_type(left.resultdef) or is_managed_type(right.resultdef) then
+        if not(target_info.system in systems_garbage_collected_managed_types) and
+           (is_managed_type(left.resultdef) or
+            is_managed_type(right.resultdef)) then
           InternalError(2012011901);
 
         otlabel:=current_procinfo.CurrTrueLabel;
@@ -631,7 +652,7 @@ implementation
             else if (right.nodetype=stringconstn) and
                (tstringconstnode(right).len=0) then
               begin
-                cg.a_load_const_ref(current_asmdata.CurrAsmList,OS_8,0,left.location.reference);
+                hlcg.a_load_const_ref(current_asmdata.CurrAsmList,u8inttype,0,left.location.reference);
               end
             { char loading }
             else if is_char(right.resultdef) then
@@ -639,27 +660,32 @@ implementation
                 if right.nodetype=ordconstn then
                   begin
                     if (target_info.endian = endian_little) then
-                      cg.a_load_const_ref(current_asmdata.CurrAsmList,OS_16,(tordconstnode(right).value.svalue shl 8) or 1,
+                      hlcg.a_load_const_ref(current_asmdata.CurrAsmList,u16inttype,(tordconstnode(right).value.svalue shl 8) or 1,
                           setalignment(left.location.reference,1))
                     else
-                      cg.a_load_const_ref(current_asmdata.CurrAsmList,OS_16,tordconstnode(right).value.svalue or (1 shl 8),
+                      hlcg.a_load_const_ref(current_asmdata.CurrAsmList,u16inttype,tordconstnode(right).value.svalue or (1 shl 8),
                           setalignment(left.location.reference,1));
                   end
                 else
                   begin
                     href:=left.location.reference;
-                    cg.a_load_const_ref(current_asmdata.CurrAsmList,OS_8,1,href);
+                    hlcg.a_load_const_ref(current_asmdata.CurrAsmList,u8inttype,1,href);
                     inc(href.offset,1);
                     case right.location.loc of
                       LOC_REGISTER,
                       LOC_CREGISTER :
                         begin
+{$ifndef cpuhighleveltarget}
                           r:=cg.makeregsize(current_asmdata.CurrAsmList,right.location.register,OS_8);
-                          cg.a_load_reg_ref(current_asmdata.CurrAsmList,OS_8,OS_8,r,href);
+{$else not cpuhighleveltarget}
+                          r:=hlcg.getintregister(current_asmdata.CurrAsmList,u8inttype);
+                          hlcg.a_load_reg_reg(current_asmdata.CurrAsmList,u8inttype,u8inttype,right.location.register,r);
+{$endif cpuhighleveltarget}
+                          hlcg.a_load_reg_ref(current_asmdata.CurrAsmList,u8inttype,u8inttype,r,href);
                         end;
                       LOC_REFERENCE,
                       LOC_CREFERENCE :
-                        cg.a_load_ref_ref(current_asmdata.CurrAsmList,OS_8,OS_8,right.location.reference,href);
+                        hlcg.a_load_ref_ref(current_asmdata.CurrAsmList,u8inttype,u8inttype,right.location.reference,href);
                       else
                         internalerror(200205111);
                     end;
@@ -688,7 +714,7 @@ implementation
                     cg64.a_load64_const_loc(current_asmdata.CurrAsmList,right.location.value64,left.location)
                   else
 {$endif not cpu64bitalu}
-                    cg.a_load_const_loc(current_asmdata.CurrAsmList,right.location.value,left.location);
+                    hlcg.a_load_const_loc(current_asmdata.CurrAsmList,left.resultdef,right.location.value,left.location);
                 end;
               LOC_REFERENCE,
               LOC_CREFERENCE :
@@ -702,13 +728,13 @@ implementation
                           cg64.a_load64_ref_reg(current_asmdata.CurrAsmList,right.location.reference,left.location.register64)
                         else
 {$endif not cpu64bitalu}
-                          cg.a_load_ref_reg(current_asmdata.CurrAsmList,right.location.size,left.location.size,right.location.reference,left.location.register);
+                          hlcg.a_load_ref_reg(current_asmdata.CurrAsmList,right.resultdef,left.resultdef,right.location.reference,left.location.register);
                       end;
                     LOC_FPUREGISTER,
                     LOC_CFPUREGISTER :
                       begin
-                        cg.a_loadfpu_ref_reg(current_asmdata.CurrAsmList,
-                            right.location.size,left.location.size,
+                        hlcg.a_loadfpu_ref_reg(current_asmdata.CurrAsmList,
+                            right.resultdef,left.resultdef,
                             right.location.reference,
                             left.location.register);
                       end;
@@ -719,8 +745,8 @@ implementation
                            (right.resultdef.typ=floatdef) and
                            (left.location.size<>right.location.size) then
                           begin
-                            cg.a_loadfpu_ref_ref(current_asmdata.CurrAsmList,
-                              right.location.size,left.location.size,
+                            hlcg.a_loadfpu_ref_ref(current_asmdata.CurrAsmList,
+                              right.resultdef,left.resultdef,
                               right.location.reference,left.location.reference)
                           end
                         else
@@ -728,6 +754,9 @@ implementation
 { TODO: HACK: unaligned test, maybe remove all unaligned locations (array of char) from the compiler}
                             { Use unaligned copy when the offset is not aligned }
                             len:=left.resultdef.size;
+                            { can be 0 in case of formaldef on JVM target }
+                            if len=0 then
+                              len:=sizeof(pint);
 
                             { data smaller than an aint has less alignment requirements }
                             { max(1,...) avoids div by zero in case of an empty record  }
@@ -740,9 +769,9 @@ implementation
                                (right.location.reference.alignment<alignmentrequirement)) or
                               ((left.location.reference.alignment<>0) and
                                (left.location.reference.alignment<alignmentrequirement)) then
-                              cg.g_concatcopy_unaligned(current_asmdata.CurrAsmList,right.location.reference,left.location.reference,len)
+                              hlcg.g_concatcopy_unaligned(current_asmdata.CurrAsmList,left.resultdef,right.location.reference,left.location.reference)
                             else
-                              cg.g_concatcopy(current_asmdata.CurrAsmList,right.location.reference,left.location.reference,len);
+                              hlcg.g_concatcopy(current_asmdata.CurrAsmList,left.resultdef,right.location.reference,left.location.reference);
                           end;
                       end;
                     LOC_MMREGISTER,
@@ -756,7 +785,7 @@ implementation
                             { convert an extended into a double/single, since sse   }
                             { doesn't support extended)                             }
                             r:=cg.getfpuregister(current_asmdata.CurrAsmList,right.location.size);
-                            tg.gettemp(current_asmdata.CurrAsmList,left.resultdef.size,left.resultdef.alignment,tt_normal,href);
+                            tg.gethltemp(current_asmdata.CurrAsmList,left.resultdef,left.resultdef.size,tt_normal,href);
                             cg.a_loadfpu_ref_reg(current_asmdata.CurrAsmList,right.location.size,right.location.size,right.location.reference,r);
                             cg.a_loadfpu_reg_ref(current_asmdata.CurrAsmList,right.location.size,left.location.size,r,href);
                             if releaseright then
@@ -827,7 +856,7 @@ implementation
                       right.location.register64,left.location)
                   else
 {$endif not cpu64bitalu}
-                    cg.a_load_reg_loc(current_asmdata.CurrAsmList,right.location.size,right.location.register,left.location);
+                    hlcg.a_load_reg_loc(current_asmdata.CurrAsmList,right.resultdef,left.resultdef,right.location.register,left.location);
                 end;
               LOC_FPUREGISTER,
               LOC_CFPUREGISTER :
@@ -840,7 +869,7 @@ implementation
                         begin
                           { perform size conversion if needed (the mm-code cannot convert an   }
                           { extended into a double/single, since sse doesn't support extended) }
-                          tg.gettemp(current_asmdata.CurrAsmList,left.resultdef.size,left.resultdef.alignment,tt_normal,href);
+                          tg.gethltemp(current_asmdata.CurrAsmList,left.resultdef, left.resultdef.size,tt_normal,href);
                           cg.a_loadfpu_reg_ref(current_asmdata.CurrAsmList,right.location.size,left.location.size,right.location.register,href);
                           location_reset_ref(right.location,LOC_REFERENCE,left.location.size,0);
                           right.location.reference:=href;
@@ -852,8 +881,8 @@ implementation
                           right.location.register,left.location.register,mms_movescalar);
                     end
                   else
-                    cg.a_loadfpu_reg_loc(current_asmdata.CurrAsmList,
-                        right.location.size,
+                    hlcg.a_loadfpu_reg_loc(current_asmdata.CurrAsmList,
+                        right.resultdef,left.resultdef,
                         right.location.register,left.location);
                 end;
               LOC_SUBSETREG,
@@ -876,7 +905,7 @@ implementation
               LOC_JUMP :
                 begin
                   current_asmdata.getjumplabel(hlabel);
-                  cg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
+                  hlcg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
                   if is_pasbool(left.resultdef) then
                     begin
 {$ifndef cpu64bitalu}
@@ -884,7 +913,7 @@ implementation
                         cg64.a_load64_const_loc(current_asmdata.CurrAsmList,1,left.location)
                       else
 {$endif not cpu64bitalu}
-                        cg.a_load_const_loc(current_asmdata.CurrAsmList,1,left.location)
+                        hlcg.a_load_const_loc(current_asmdata.CurrAsmList,left.resultdef,1,left.location)
                     end
                   else
                     begin
@@ -893,18 +922,18 @@ implementation
                         cg64.a_load64_const_loc(current_asmdata.CurrAsmList,-1,left.location)
                       else
 {$endif not cpu64bitalu}
-                        cg.a_load_const_loc(current_asmdata.CurrAsmList,-1,left.location);
+                        hlcg.a_load_const_loc(current_asmdata.CurrAsmList,left.resultdef,-1,left.location);
                     end;
 
-                  cg.a_jmp_always(current_asmdata.CurrAsmList,hlabel);
-                  cg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+                  hlcg.a_jmp_always(current_asmdata.CurrAsmList,hlabel);
+                  hlcg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
 {$ifndef cpu64bitalu}
                   if left.location.size in [OS_64,OS_S64] then
                     cg64.a_load64_const_loc(current_asmdata.CurrAsmList,0,left.location)
                   else
 {$endif not cpu64bitalu}
-                    cg.a_load_const_loc(current_asmdata.CurrAsmList,0,left.location);
-                  cg.a_label(current_asmdata.CurrAsmList,hlabel);
+                    hlcg.a_load_const_loc(current_asmdata.CurrAsmList,left.resultdef,0,left.location);
+                  hlcg.a_label(current_asmdata.CurrAsmList,hlabel);
                 end;
 {$ifdef cpuflags}
               LOC_FLAGS :
@@ -1009,6 +1038,19 @@ implementation
         vtAnsiString16  = 19;
         vtAnsiString64  = 20;
 
+
+    procedure tcgarrayconstructornode.makearrayref(var ref: treference; eledef: tdef);
+      begin
+        { do nothing by default }
+      end;
+
+
+    procedure tcgarrayconstructornode.advancearrayoffset(var ref: treference; elesize: asizeint);
+      begin
+        inc(ref.offset,elesize);
+      end;
+
+
     procedure tcgarrayconstructornode.pass_generate_code;
       var
         hp    : tarrayconstructornode;
@@ -1018,36 +1060,42 @@ implementation
         otlabel,
         oflabel : tasmlabel;
         vtype : longint;
-        elesize,
-        elealign : longint;
+        eledef: tdef;
+        elesize : longint;
         tmpreg  : tregister;
         vaddr : boolean;
         freetemp,
-        dovariant : boolean;
+        dovariant: boolean;
       begin
         if is_packed_array(resultdef) then
           internalerror(200608042);
-        dovariant:=(nf_forcevaria in flags) or is_variant_array(resultdef);
+        dovariant:=
+          ((nf_forcevaria in flags) or is_variant_array(resultdef)) and
+          not(target_info.system in systems_managed_vm);
         if dovariant then
           begin
-            elesize:=sizeof(pint)+sizeof(pint);
-            elealign:=sizeof(pint);
+            eledef:=search_system_type('TVARREC').typedef;
+            elesize:=eledef.size;
           end
         else
           begin
+            eledef:=tarraydef(resultdef).elementdef;
             elesize:=tarraydef(resultdef).elesize;
-            elealign:=tarraydef(resultdef).elementdef.alignment;
           end;
-        { alignment is filled in by tg.gettemp below }
+        { alignment is filled in by tg.gethltemp below }
         location_reset_ref(location,LOC_CREFERENCE,OS_NO,0);
         fillchar(paraloc,sizeof(paraloc),0);
         { Allocate always a temp, also if no elements are required, to
           be sure that location is valid (PFV) }
+        { on the JVM platform, an array can have 0 elements; since the length
+          of the array is part of the array itself, make sure we allocate one
+          of the proper length to avoid getting unexpected results later }
          if tarraydef(resultdef).highrange=-1 then
-           tg.GetTemp(current_asmdata.CurrAsmList,elesize,elealign,tt_normal,location.reference)
+           tg.gethltemp(current_asmdata.CurrAsmList,resultdef,{$ifdef jvm}0{$else}elesize{$endif},tt_normal,location.reference)
          else
-           tg.GetTemp(current_asmdata.CurrAsmList,(tarraydef(resultdef).highrange+1)*elesize,resultdef.alignment,tt_normal,location.reference);
+           tg.gethltemp(current_asmdata.CurrAsmList,resultdef,(tarraydef(resultdef).highrange+1)*elesize,tt_normal,location.reference);
          href:=location.reference;
+         makearrayref(href,eledef);
         { Process nodes in array constructor }
         hp:=self;
         while assigned(hp) do
@@ -1065,7 +1113,7 @@ implementation
               secondpass(hp.left);
               { Move flags and jump in register }
               if hp.left.location.loc in [LOC_FLAGS,LOC_JUMP] then
-                location_force_reg(current_asmdata.CurrAsmList,hp.left.location,def_cgsize(hp.left.resultdef),false);
+                hlcg.location_force_reg(current_asmdata.CurrAsmList,hp.left.location,hp.left.resultdef,hp.left.resultdef,false);
 
               if (hp.left.location.loc=LOC_JUMP) then
                 begin
@@ -1195,7 +1243,7 @@ implementation
                  dec(href.offset,sizeof(pint));
                  cg.a_load_const_ref(current_asmdata.CurrAsmList, OS_INT,vtype,href);
                  { goto next array element }
-                 inc(href.offset,sizeof(pint)*2);
+                 advancearrayoffset(href,sizeof(pint)*2);
                end
               else
               { normal array constructor of the same type }
@@ -1209,15 +1257,15 @@ implementation
                        hp.left.location.register,href,mms_movescalar);
                    LOC_FPUREGISTER,
                    LOC_CFPUREGISTER :
-                     cg.a_loadfpu_reg_ref(current_asmdata.CurrAsmList,hp.left.location.size,hp.left.location.size,hp.left.location.register,href);
+                     hlcg.a_loadfpu_reg_ref(current_asmdata.CurrAsmList,hp.left.resultdef,hp.left.resultdef,hp.left.location.register,href);
                    LOC_REFERENCE,
                    LOC_CREFERENCE :
                      begin
                        if is_shortstring(hp.left.resultdef) then
-                         cg.g_copyshortstring(current_asmdata.CurrAsmList,hp.left.location.reference,href,
-                             Tstringdef(hp.left.resultdef).len)
+                         hlcg.g_copyshortstring(current_asmdata.CurrAsmList,hp.left.location.reference,href,
+                             Tstringdef(hp.left.resultdef))
                        else
-                         cg.g_concatcopy(current_asmdata.CurrAsmList,hp.left.location.reference,href,elesize);
+                         hlcg.g_concatcopy(current_asmdata.CurrAsmList,eledef,hp.left.location.reference,href);
                      end;
                    else
                      begin
@@ -1226,10 +1274,10 @@ implementation
                          cg64.a_load64_loc_ref(current_asmdata.CurrAsmList,hp.left.location,href)
                        else
 {$endif not cpu64bitalu}
-                         cg.a_load_loc_ref(current_asmdata.CurrAsmList,hp.left.location.size,hp.left.location,href);
+                         hlcg.a_load_loc_ref(current_asmdata.CurrAsmList,eledef,eledef,hp.left.location,href);
                      end;
                  end;
-                 inc(href.offset,elesize);
+                 advancearrayoffset(href,elesize);
                end;
               if freetemp then
                 location_freetemp(current_asmdata.CurrAsmList,hp.left.location);

compiler/ncgmat.pas

@@ -127,11 +127,11 @@ implementation
     uses
       globtype,systems,
       cutils,verbose,globals,
-      symconst,aasmbase,aasmtai,aasmdata,aasmcpu,defutil,
+      symconst,symtype,symdef,aasmbase,aasmtai,aasmdata,aasmcpu,defutil,
       parabase,
       pass_2,
       ncon,
-      tgobj,ncgutil,cgobj,cgutils,paramgr
+      tgobj,ncgutil,cgobj,cgutils,paramgr,hlcgobj
 {$ifndef cpu64bitalu}
       ,cg64f32
 {$endif not cpu64bitalu}
@@ -233,19 +233,25 @@ implementation
     procedure tcgunaryminusnode.second_integer;
       var
         hl: tasmlabel;
+        opsize: tdef;
       begin
         secondpass(left);
         { load left operator in a register }
         location_copy(location,left.location);
-        location_force_reg(current_asmdata.CurrAsmList,location,OS_SINT,false);
-        cg.a_op_reg_reg(current_asmdata.CurrAsmList,OP_NEG,OS_SINT,location.register,location.register);
+        { in case of a 32 bit system that can natively execute 64 bit operations }
+        if (left.resultdef.size<=sinttype.size) then
+          opsize:=sinttype
+        else
+          opsize:=s64inttype;
+        hlcg.location_force_reg(current_asmdata.CurrAsmList,location,left.resultdef,opsize,false);
+        hlcg.a_op_reg_reg(current_asmdata.CurrAsmList,OP_NEG,opsize,location.register,location.register);
 
         if (cs_check_overflow in current_settings.localswitches) then
           begin
             current_asmdata.getjumplabel(hl);
-            cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,OS_SINT,OC_NE,low(aint),location.register,hl);
+            hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,opsize,OC_NE,low(aint),location.register,hl);
             cg.a_call_name(current_asmdata.CurrAsmList,'FPC_OVERFLOW',false);
-            cg.a_label(current_asmdata.CurrAsmList,hl);
+            hlcg.a_label(current_asmdata.CurrAsmList,hl);
           end;
       end;
 
@@ -488,10 +494,10 @@ implementation
     procedure tcgnotnode.second_integer;
       begin
         secondpass(left);
-        location_force_reg(current_asmdata.CurrAsmList,left.location,def_cgsize(left.resultdef),false);
+        hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,left.resultdef,false);
         location_copy(location,left.location);
         { perform the NOT operation }
-        cg.a_op_reg_reg(current_asmdata.CurrAsmList,OP_NOT,location.size,location.register,location.register);
+        hlcg.a_op_reg_reg(current_asmdata.CurrAsmList,OP_NOT,left.resultdef,location.register,location.register);
       end;
 
 

compiler/ncgmem.pas

@@ -85,7 +85,7 @@ implementation
       aasmbase,aasmtai,aasmdata,
       procinfo,pass_2,parabase,
       pass_1,nld,ncon,nadd,nutils,
-      cgutils,cgobj,
+      cgutils,cgobj,hlcgobj,
       tgobj,ncgutil,objcgutl
       ;
 
@@ -293,7 +293,8 @@ implementation
          { several object types must be dereferenced implicitly }
          if is_implicit_pointer_object_type(left.resultdef) then
            begin
-             if not is_managed_type(left.resultdef) then
+             if (not is_managed_type(left.resultdef)) or
+                (target_info.system in systems_garbage_collected_managed_types) then
                begin
                  { the contents of a class are aligned to a sizeof(pointer) }
                  location_reset_ref(location,LOC_REFERENCE,def_cgsize(resultdef),sizeof(pint));
@@ -305,7 +306,7 @@ implementation
                         if getregtype(left.location.register)<>R_ADDRESSREGISTER then
                           begin
                             location.reference.base:=rg.getaddressregister(current_asmdata.CurrAsmList);
-                            cg.a_load_reg_reg(current_asmdata.CurrAsmList,OS_ADDR,OS_ADDR,
+                            hlcg.a_load_reg_reg(current_asmdata.CurrAsmList,left.resultdef,left.resultdef,
                               left.location.register,location.reference.base);
                           end
                         else
@@ -316,7 +317,7 @@ implementation
                     LOC_REFERENCE:
                       begin
                          location.reference.base:=cg.getaddressregister(current_asmdata.CurrAsmList);
-                         cg.a_load_loc_reg(current_asmdata.CurrAsmList,OS_ADDR,left.location,location.reference.base);
+                         hlcg.a_load_loc_reg(current_asmdata.CurrAsmList,left.resultdef,left.resultdef,left.location,location.reference.base);
                       end;
                     LOC_CONSTANT:
                       begin
@@ -439,6 +440,16 @@ implementation
              { always packrecords C -> natural alignment }
              location.reference.alignment:=vs.vardef.alignment;
            end
+         else if is_java_class_or_interface(left.resultdef) or
+                 ((target_info.system in systems_jvm) and
+                  (left.resultdef.typ=recorddef)) then
+           begin
+             if (location.loc<>LOC_REFERENCE) or
+                (location.reference.index<>NR_NO) or
+                assigned(location.reference.symbol) then
+               internalerror(2011011301);
+             location.reference.symbol:=current_asmdata.RefAsmSymbol(vs.mangledname);
+           end
          else if (location.loc in [LOC_REFERENCE,LOC_CREFERENCE]) then
            begin
              if not is_packed_record_or_object(left.resultdef) then

compiler/ncgnstld.pas

@@ -0,0 +1,237 @@
+{
+    Copyright (c) 2011 by Jonas Maebe
+
+    Support for load nodes on targets that have to group all local variables
+    and parameters accessed by nested routines into structs (and then pass the
+    address of these structs to nested routines rather than the frame pointer,
+    and access the local variables as fields thereof)
+
+    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 ncgnstld;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+       node,
+       symtype,
+       nld,
+       ncgld;
+
+    type
+       tcgnestloadnode = class(tcgloadnode)
+        protected
+         nestsym: tsym;
+         nestsymderef: tderef;
+         procedure generate_nested_access(vs: tsym);override;
+         function  keep_param_address_in_nested_struct: boolean; virtual;
+        public
+         function  pass_typecheck: tnode; override;
+         function  pass_1:tnode;override;
+         function  dogetcopy: tnode; override;
+         function  docompare(p: tnode): boolean; override;
+         constructor ppuload(t: tnodetype; ppufile: tcompilerppufile); override;
+         procedure ppuwrite(ppufile: tcompilerppufile); override;
+         procedure buildderefimpl; override;
+         procedure derefimpl; override;
+       end;
+
+implementation
+
+    uses
+      cutils,verbose,globtype,globals,systems,constexp,
+      symnot,
+      defutil,defcmp,
+      htypechk,pass_1,procinfo,paramgr,
+      cpuinfo,
+      symconst,symbase,symsym,symdef,symtable,symcreat,
+      ncon,ninl,ncnv,nmem,ncal,nutils,nbas,
+      pass_2,cgbase
+      ;
+
+{*****************************************************************************
+                          TCGNESTLOADNODE
+*****************************************************************************}
+
+    procedure tcgnestloadnode.generate_nested_access(vs: tsym);
+      begin
+        { left has been transformed into a string of accesses that result in
+          the location of the original variable's copy in the appropriate
+          parentfpstruct (via tcgnestloadparentfpnode.pass_1). In case it is a
+          var/out/constref parameter, that "copy" will have been a copy of the
+          address so the normal handling of such parameters in ncgld is ok) }
+        secondpass(left);
+        location:=left.location;
+      end;
+
+
+    function tcgnestloadnode.keep_param_address_in_nested_struct: boolean;
+      begin
+        result:=is_addr_param_load;
+      end;
+
+
+    function tcgnestloadnode.pass_typecheck: tnode;
+      var
+        nestedvars: tsym;
+      begin
+        result:=inherited pass_typecheck;
+        if assigned(result) then
+          exit;
+        case symtableentry.typ of
+          paravarsym,
+          localvarsym :
+            begin
+              { Nested variable? Then we have to move it to a structure that
+                can be passed by reference to nested routines }
+              if assigned(current_procinfo) and
+                 (symtable.symtabletype in [localsymtable,parasymtable]) and
+                 ((symtable.symtablelevel<>current_procinfo.procdef.parast.symtablelevel) or
+                  { also redirect loads of locals/paras that have been moved to
+                     the parentfpstruct inside the routine in which they were
+                     originally declared, except in the initialisation code for
+                     the parentfpstruct (nf_internal flag) }
+                  (tabstractnormalvarsym(symtableentry).inparentfpstruct and
+                   not(nf_internal in flags))) then
+                begin
+                  { get struct holding all locals accessed by nested routines }
+                  nestedvars:=tprocdef(symtable.defowner).parentfpstruct;
+                  { don't add the parentfpstruct to itself! }
+                  if nestedvars=symtableentry then
+                    exit;
+                  if not assigned(nestedvars) then
+                    begin
+                      { create this struct }
+                      build_parentfpstruct(tprocdef(symtable.defowner));
+                      nestedvars:=tprocdef(symtable.defowner).parentfpstruct;
+                    end;
+                  {  store result for use in pass_1 }
+                  nestsym:=maybe_add_sym_to_parentfpstruct(tprocdef(symtableentry.owner.defowner),symtableentry,resultdef,keep_param_address_in_nested_struct);
+                  { left normally holds the parentfp node. If it's not assigned,
+                    this is an access to a local variable/para from the routine
+                    in which it was actually declared -> redirect to its
+                    equivalent in the parentfp struct }
+                  if not assigned(left) then
+                    begin
+                      left:=caddrnode.create_internal(cloadnode.create(tprocdef(symtableentry.owner.defowner).parentfpstruct,tprocdef(symtableentry.owner.defowner).parentfpstruct.owner));
+                      include(left.flags,nf_typedaddr);
+                    end;
+                  typecheckpass(left);
+                end;
+            end;
+        end;
+      end;
+
+
+    function tcgnestloadnode.pass_1:tnode;
+      var
+        thissym,
+        nestedvars: tsym;
+        nestedvarsdef: tdef;
+      begin
+        result:=inherited;
+        if assigned(result) then
+          exit;
+        case symtableentry.typ of
+          paravarsym,
+          localvarsym :
+            begin
+              { Nested variable? Then we have to move it to a structure that
+                can be passed by reference to nested routines }
+              if assigned(current_procinfo) and
+                 (symtable.symtabletype in [localsymtable,parasymtable]) and
+                 ((symtable.symtablelevel<>current_procinfo.procdef.parast.symtablelevel) or
+                  (tabstractnormalvarsym(symtableentry).inparentfpstruct and
+                   not(nf_internal in flags))) then
+                begin
+                  { get struct holding all locals accessed by nested routines }
+                  nestedvars:=tprocdef(symtable.defowner).parentfpstruct;
+                  if not assigned(nestedvars) then
+                    begin
+                      { create this struct }
+                      build_parentfpstruct(tprocdef(symtable.defowner));
+                      nestedvars:=tprocdef(symtable.defowner).parentfpstruct;
+                    end;
+                  nestedvarsdef:=tlocalvarsym(nestedvars).vardef;
+                  if nestedvars<>symtableentry then
+                    thissym:=nestsym
+                  else
+                    thissym:=find_sym_in_parentfpstruct(tprocdef(symtableentry.owner.defowner),symtableentry);
+                  if not assigned(thissym) then
+                    internalerror(2011060406);
+                  { firstpass the parentfpnode. This will transform it into
+                    a load of the appropriate parentfpstruct }
+                  if not assigned(left) then
+                    internalerror(2011060104);
+                  firstpass(left);
+                  { subscript it to get the variable }
+                  left:=csubscriptnode.create(thissym,cderefnode.create(left));
+                  firstpass(left);
+                 end;
+            end;
+        end;
+      end;
+
+
+    function tcgnestloadnode.dogetcopy: tnode;
+      begin
+        result:=inherited dogetcopy;
+        tcgnestloadnode(result).nestsym:=nestsym;
+      end;
+
+
+    function tcgnestloadnode.docompare(p: tnode): boolean;
+      begin
+        result:=
+          inherited docompare(p) and
+          (tcgnestloadnode(p).nestsym=nestsym);
+      end;
+
+
+    constructor tcgnestloadnode.ppuload(t: tnodetype; ppufile: tcompilerppufile);
+      begin
+        inherited ppuload(t, ppufile);
+        ppufile.getderef(nestsymderef);
+      end;
+
+
+    procedure tcgnestloadnode.ppuwrite(ppufile: tcompilerppufile);
+      begin
+        inherited ppuwrite(ppufile);
+        ppufile.putderef(nestsymderef);
+      end;
+
+
+    procedure tcgnestloadnode.buildderefimpl;
+      begin
+        inherited buildderefimpl;
+        nestsymderef.build(nestsym);
+      end;
+
+
+    procedure tcgnestloadnode.derefimpl;
+      begin
+        inherited derefimpl;
+        nestsym:=tsym(nestsymderef.resolve);
+      end;
+
+
+begin
+  cloadnode:=tcgnestloadnode;
+end.

compiler/ncgnstmm.pas

@@ -0,0 +1,138 @@
+{
+    Copyright (c) 1998-2002 by Florian Klaempfl
+
+
+    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 ncgnstmm;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+      globtype,cgbase,cpuinfo,cpubase,
+      node,ncgmem;
+
+    type
+       tcgnestloadparentfpnode = class(tcgloadparentfpnode)
+          function pass_typecheck: tnode; override;
+          function pass_1: tnode; override;
+          procedure pass_generate_code;override;
+       end;
+
+implementation
+
+    uses
+      systems,
+      cutils,cclasses,verbose,globals,constexp,
+      symconst,symdef,symsym,symtable,symcreat,defutil,paramgr,
+      aasmbase,aasmtai,aasmdata,
+      procinfo,pass_2,parabase,
+      pass_1,ncnv,nmem,nld,ncon,nadd,nutils,
+      cgutils,cgobj,hlcgobj,
+      tgobj,ncgutil,objcgutl
+      ;
+
+
+{*****************************************************************************
+                        TCGLOADPARENTFPNODE
+*****************************************************************************}
+
+    function tcgnestloadparentfpnode.pass_typecheck: tnode;
+      var
+        hsym        : tparavarsym;
+        currpi,
+        nextpi      : tprocinfo;
+      begin
+        result:=inherited;
+        if assigned(result) then
+          exit;
+        currpi:=current_procinfo.parent;
+        while (currpi.procdef.parast.symtablelevel>=parentpd.parast.symtablelevel) do
+          begin
+            if not assigned(currpi.procdef.parentfpstruct) then
+              build_parentfpstruct(currpi.procdef);
+            currpi:=currpi.parent;
+          end;
+        { mark all parent parentfp parameters for inclusion in the struct that
+          holds all locals accessed from nested routines }
+        currpi:=current_procinfo.parent;
+        nextpi:=currpi.parent;
+        while (currpi.procdef.parast.symtablelevel>parentpd.parast.symtablelevel) do
+          begin
+            hsym:=tparavarsym(currpi.procdef.parast.Find('parentfp'));
+            maybe_add_sym_to_parentfpstruct(currpi.procdef,hsym,nextpi.procdef.parentfpstructptrtype,false);
+            currpi:=nextpi;
+            nextpi:=nextpi.parent;
+          end;
+      end;
+
+
+    function tcgnestloadparentfpnode.pass_1: tnode;
+      var
+        fsym        : tfieldvarsym;
+        hsym        : tparavarsym;
+        currpi      : tprocinfo;
+        useparentfppara :  boolean;
+      begin
+        result:=nil;
+        { if the current routine does not call a nested routine, or if that
+          nested routine does nothing for which it needs the nestedfp pointer
+          of the current routine (and hence it has not been moved into the
+          nestedfp struct), get the original nestedfp parameter }
+        useparentfppara:=not assigned(current_procinfo.procdef.parentfpstruct);
+        hsym:=tparavarsym(current_procinfo.procdef.parast.Find('parentfp'));
+        if current_procinfo.procdef.parast.symtablelevel>parentpd.parast.symtablelevel then
+          useparentfppara:=
+            useparentfppara or
+            (find_sym_in_parentfpstruct(current_procinfo.procdef,hsym)=nil);
+        if useparentfppara then
+          begin
+            result:=cloadnode.create(hsym,hsym.owner);
+            currpi:=current_procinfo.parent;
+          end
+        else
+          begin
+            result:=caddrnode.create_internal(cloadnode.create(current_procinfo.procdef.parentfpstruct,current_procinfo.procdef.parentfpstruct.owner));
+            include(result.flags,nf_typedaddr);
+            currpi:=current_procinfo;
+          end;
+        { follow the chain of parentfpstructs until we arrive at the one we
+          need }
+        while (currpi.procdef.parast.symtablelevel>parentpd.parast.symtablelevel) do
+          begin
+            hsym:=tparavarsym(currpi.procdef.parast.Find('parentfp'));
+            fsym:=tfieldvarsym(find_sym_in_parentfpstruct(currpi.procdef,hsym));
+            if not assigned(fsym) then
+              internalerror(2011060405);
+            result:=csubscriptnode.create(fsym,cderefnode.create(result));
+            currpi:=currpi.parent;
+          end;
+      end;
+
+
+    procedure tcgnestloadparentfpnode.pass_generate_code;
+      begin
+        { should be handled in pass 1 }
+        internalerror(2011060202);
+      end;
+
+
+begin
+   cloadparentfpnode:=tcgnestloadparentfpnode;
+end.

compiler/ncgopt.pas

@@ -90,7 +90,7 @@ begin
   if not(tg.istemp(left.location.reference) and
          (tg.sizeoftemp(current_asmdata.CurrAsmList,left.location.reference) = 256)) then
     begin
-       tg.Gettemp(current_asmdata.CurrAsmList,256,1,tt_normal,href);
+       tg.gethltemp(current_asmdata.CurrAsmList,cshortstringtype,256,tt_normal,href);
        cg.g_copyshortstring(current_asmdata.CurrAsmList,left.location.reference,href,255);
        location_freetemp(current_asmdata.CurrAsmList,left.location);
        { return temp reference }

compiler/ncgset.pas

@@ -26,7 +26,7 @@ unit ncgset;
 interface
 
     uses
-       globtype,globals,constexp,
+       globtype,globals,constexp,symtype,
        node,nset,cpubase,cgbase,cgutils,cgobj,aasmbase,aasmtai,aasmdata;
 
     type
@@ -59,7 +59,7 @@ interface
 
         protected
           with_sign : boolean;
-          opsize : tcgsize;
+          opsize : tdef;
           jmp_gt,jmp_lt,jmp_le : topcmp;
           { register with case expression }
           hregister,hregister2 : tregister;
@@ -88,7 +88,7 @@ implementation
       paramgr,
       procinfo,pass_2,tgobj,
       nbas,ncon,nflw,
-      ncgutil;
+      ncgutil,hlcgobj;
 
 
 {*****************************************************************************
@@ -215,8 +215,11 @@ implementation
          pleftreg   : tregister;
          setparts   : Tsetparts;
          opsize     : tcgsize;
+         opdef      : tdef;
          uopsize    : tcgsize;
+         uopdef     : tdef;
          orgopsize  : tcgsize;
+         orgopdef   : tdef;
          genjumps,
          use_small,
          isjump     : boolean;
@@ -228,12 +231,21 @@ implementation
 
          genjumps := checkgenjumps(setparts,numparts,use_small);
 
+
          orgopsize := def_cgsize(left.resultdef);
+         orgopdef := left.resultdef;
          uopsize := OS_32;
+         uopdef := u32inttype;
          if is_signed(left.resultdef) then
-           opsize := tcgsize(ord(uopsize)+(ord(OS_S8)-ord(OS_8)))
+           begin
+             opsize := OS_S32;
+             opdef := s32inttype;
+           end
          else
-           opsize := uopsize;
+           begin
+             opsize := uopsize;
+             opdef := uopdef;
+           end;
          needslabel := false;
 
          isjump:=false;
@@ -259,7 +271,8 @@ implementation
          secondpass(left);
          if isjump then
            begin
-             location_force_reg(current_asmdata.CurrAsmList,left.location,opsize,true);
+             hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,orgopdef,opdef,true);
+             left.resultdef:=opdef;
              current_procinfo.CurrTrueLabel:=otl;
              current_procinfo.CurrFalseLabel:=ofl;
            end
@@ -283,7 +296,7 @@ implementation
             location_reset(location,LOC_JUMP,OS_NO);
 
             { If register is used, use only lower 8 bits }
-            location_force_reg(current_asmdata.CurrAsmList,left.location,opsize,false);
+            hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,opdef,false);
             pleftreg := left.location.register;
 
             { how much have we already substracted from the x in the }
@@ -308,15 +321,15 @@ implementation
                          (hr<>pleftreg) then
                         begin
                           { don't change this back to a_op_const_reg/a_load_reg_reg, since pleftreg must not be modified }
-                          hr:=cg.getintregister(current_asmdata.CurrAsmList,opsize);
-                          cg.a_op_const_reg_reg(current_asmdata.CurrAsmList,OP_SUB,opsize,setparts[i].start,pleftreg,hr);
+                          hr:=hlcg.getintregister(current_asmdata.CurrAsmList,opdef);
+                          hlcg.a_op_const_reg_reg(current_asmdata.CurrAsmList,OP_SUB,opdef,setparts[i].start,pleftreg,hr);
                           pleftreg:=hr;
                         end
                       else
                         begin
                           { otherwise, the value is already in a register   }
                           { that can be modified                            }
-                          cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_SUB,opsize,
+                          hlcg.a_op_const_reg(current_asmdata.CurrAsmList,OP_SUB,opdef,
                              setparts[i].start-adjustment,pleftreg)
                         end;
                     { new total value substracted from x:           }
@@ -327,25 +340,25 @@ implementation
                     { we need a carry in case the element is in the range }
                     { (this will never overflow since we check at the     }
                     { beginning whether stop-start <> 255)                }
-                    cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opsize, OC_B,
+                    hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, uopdef, OC_B,
                       setparts[i].stop-setparts[i].start+1,pleftreg,current_procinfo.CurrTrueLabel);
                   end
                 else
                   { if setparts[i].start = 0 and setparts[i].stop = 255,  }
                   { it's always true since "in" is only allowed for bytes }
                   begin
-                    cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
+                    hlcg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
                   end;
               end
              else
               begin
                 { Emit code to check if left is an element }
-                cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opsize, OC_EQ,
+                hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opdef, OC_EQ,
                       setparts[i].stop-adjustment,pleftreg,current_procinfo.CurrTrueLabel);
               end;
              { To compensate for not doing a second pass }
              right.location.reference.symbol:=nil;
-             cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+             hlcg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
           end
          else
          {*****************************************************************}
@@ -511,8 +524,8 @@ implementation
                 to move the result before subtract to help
                 the register allocator
               }
-              cg.a_load_reg_reg(current_asmdata.CurrAsmList, opsize, opsize, hregister, scratch_reg);
-              cg.a_op_const_reg(current_asmdata.CurrAsmList, OP_SUB, opsize, value, hregister);
+              hlcg.a_load_reg_reg(current_asmdata.CurrAsmList, opsize, opsize, hregister, scratch_reg);
+              hlcg.a_op_const_reg(current_asmdata.CurrAsmList, OP_SUB, opsize, value, hregister);
             end;
 
         begin
@@ -520,15 +533,15 @@ implementation
              genitem(t^.less);
            { do we need to test the first value? }
            if first and (t^._low>get_min_value(left.resultdef)) then
-             cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,opsize,jmp_lt,aint(t^._low.svalue),hregister,elselabel);
+             hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,opsize,jmp_lt,aint(t^._low.svalue),hregister,elselabel);
            if t^._low=t^._high then
              begin
                if t^._low-last=0 then
-                 cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,opsize,OC_EQ,0,hregister,blocklabel(t^.blockid))
+                 hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,opsize,OC_EQ,0,hregister,blocklabel(t^.blockid))
                else
                  begin
                    gensub(aint(t^._low.svalue-last.svalue));
-                   cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,opsize,
+                   hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,opsize,
                                             OC_EQ,aint(t^._low.svalue-last.svalue),scratch_reg,blocklabel(t^.blockid));
                  end;
                last:=t^._low;
@@ -550,10 +563,10 @@ implementation
                     { present label then the lower limit can be checked    }
                     { immediately. else check the range in between:       }
                     gensub(aint(t^._low.svalue-last.svalue));
-                    cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opsize,jmp_lt,aint(t^._low.svalue-last.svalue),scratch_reg,elselabel);
+                    hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opsize,jmp_lt,aint(t^._low.svalue-last.svalue),scratch_reg,elselabel);
                   end;
                 gensub(aint(t^._high.svalue-t^._low.svalue));
-                cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,opsize,jmp_le,aint(t^._high.svalue-t^._low.svalue),scratch_reg,blocklabel(t^.blockid));
+                hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,opsize,jmp_le,aint(t^._high.svalue-t^._low.svalue),scratch_reg,blocklabel(t^.blockid));
                 last:=t^._high;
              end;
            first:=false;
@@ -569,9 +582,9 @@ implementation
            begin
               last:=0;
               first:=true;
-              scratch_reg:=cg.getintregister(current_asmdata.CurrAsmList,opsize);
+              scratch_reg:=hlcg.getintregister(current_asmdata.CurrAsmList,opsize);
               genitem(hp);
-              cg.a_jmp_always(current_asmdata.CurrAsmList,elselabel);
+              hlcg.a_jmp_always(current_asmdata.CurrAsmList,elselabel);
            end;
       end;
 
@@ -595,7 +608,7 @@ implementation
            if t^._low=t^._high then
              begin
 {$ifndef cpu64bitalu}
-                if opsize in [OS_S64,OS_64] then
+                if def_cgsize(opsize) in [OS_S64,OS_64] then
                   begin
                      current_asmdata.getjumplabel(l1);
                      cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, OS_32, OC_NE, aint(hi(int64(t^._low.svalue))),hregister2,l1);
@@ -605,7 +618,7 @@ implementation
                 else
 {$endif not cpu64bitalu}
                   begin
-                     cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opsize, OC_EQ, aint(t^._low.svalue),hregister, blocklabel(t^.blockid));
+                     hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opsize, OC_EQ, aint(t^._low.svalue),hregister, blocklabel(t^.blockid));
                   end;
                 { Reset last here, because we've only checked for one value and need to compare
                   for the next range both the lower and upper bound }
@@ -619,7 +632,7 @@ implementation
                 if not lastwasrange or (t^._low-last>1) then
                   begin
 {$ifndef cpu64bitalu}
-                     if opsize in [OS_64,OS_S64] then
+                     if def_cgsize(opsize) in [OS_64,OS_S64] then
                        begin
                           current_asmdata.getjumplabel(l1);
                           cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, OS_32, jmp_lt, aint(hi(int64(t^._low.svalue))),
@@ -633,12 +646,12 @@ implementation
                      else
 {$endif not cpu64bitalu}
                        begin
-                        cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opsize, jmp_lt, aint(t^._low.svalue), hregister,
+                        hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opsize, jmp_lt, aint(t^._low.svalue), hregister,
                            elselabel);
                        end;
                   end;
 {$ifndef cpu64bitalu}
-                if opsize in [OS_S64,OS_64] then
+                if def_cgsize(opsize) in [OS_S64,OS_64] then
                   begin
                      current_asmdata.getjumplabel(l1);
                      cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, OS_32, jmp_lt, aint(hi(int64(t^._high.svalue))), hregister2,
@@ -651,7 +664,7 @@ implementation
                 else
 {$endif not cpu64bitalu}
                   begin
-                     cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opsize, jmp_le, aint(t^._high.svalue), hregister, blocklabel(t^.blockid));
+                     hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opsize, jmp_le, aint(t^._high.svalue), hregister, blocklabel(t^.blockid));
                   end;
 
                 last:=t^._high;
@@ -665,7 +678,7 @@ implementation
          last:=0;
          lastwasrange:=false;
          genitem(hp);
-         cg.a_jmp_always(current_asmdata.CurrAsmList,elselabel);
+         hlcg.a_jmp_always(current_asmdata.CurrAsmList,elselabel);
       end;
 
 
@@ -720,11 +733,11 @@ implementation
           end;
          secondpass(left);
          { determines the size of the operand }
-         opsize:=def_cgsize(left.resultdef);
+         opsize:=left.resultdef;
          { copy the case expression to a register }
-         location_force_reg(current_asmdata.CurrAsmList,left.location,opsize,false);
+         hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,opsize,false);
 {$ifndef cpu64bitalu}
-         if opsize in [OS_S64,OS_64] then
+         if def_cgsize(opsize) in [OS_S64,OS_64] then
            begin
              hregister:=left.location.register64.reglo;
              hregister2:=left.location.register64.reghi;
@@ -750,7 +763,7 @@ implementation
          load_all_regvars(current_asmdata.CurrAsmList);
 {$endif OLDREGVARS}
 {$ifndef cpu64bitalu}
-         if opsize in [OS_64,OS_S64] then
+         if def_cgsize(opsize) in [OS_64,OS_S64] then
            genlinearcmplist(labels)
          else
 {$endif not cpu64bitalu}
@@ -847,11 +860,11 @@ implementation
 {$ifdef OLDREGVARS}
               load_all_regvars(current_asmdata.CurrAsmList);
 {$endif OLDREGVARS}
-              cg.a_jmp_always(current_asmdata.CurrAsmList,endlabel);
+              hlcg.a_jmp_always(current_asmdata.CurrAsmList,endlabel);
            end;
          current_asmdata.CurrAsmList.concat(cai_align.create(current_settings.alignment.jumpalign));
          { ...and the else block }
-         cg.a_label(current_asmdata.CurrAsmList,elselabel);
+         hlcg.a_label(current_asmdata.CurrAsmList,elselabel);
          if assigned(elseblock) then
            begin
               secondpass(elseblock);
@@ -863,7 +876,7 @@ implementation
          cg.executionweight:=oldexecutionweight;
 
          current_asmdata.CurrAsmList.concat(cai_align.create(current_settings.alignment.jumpalign));
-         cg.a_label(current_asmdata.CurrAsmList,endlabel);
+         hlcg.a_label(current_asmdata.CurrAsmList,endlabel);
 
          { Reset labels }
          for i:=0 to blocks.count-1 do