Rebase with r21814

git-svn-id: branches/targetandroid@21815 -

.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
@@ -60,6 +62,7 @@ compiler/arm/narmcnv.pas svneol=native#text/plain
 compiler/arm/narmcon.pas svneol=native#text/plain
 compiler/arm/narminl.pas svneol=native#text/plain
 compiler/arm/narmmat.pas svneol=native#text/plain
+compiler/arm/narmmem.pas svneol=native#text/plain
 compiler/arm/narmset.pas svneol=native#text/plain
 compiler/arm/pp.lpi.template svneol=native#text/plain
 compiler/arm/raarm.pas svneol=native#text/plain
@@ -89,6 +92,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
@@ -114,6 +118,7 @@ compiler/cfidwarf.pas svneol=native#text/plain
 compiler/cfileutl.pas svneol=native#text/plain
 compiler/cg64f32.pas svneol=native#text/plain
 compiler/cgbase.pas svneol=native#text/plain
+compiler/cghlcpu.pas svneol=native#text/plain
 compiler/cgobj.pas svneol=native#text/plain
 compiler/cgutils.pas svneol=native#text/plain
 compiler/cmsgs.pas svneol=native#text/plain
@@ -152,6 +157,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 +172,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 +213,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 +262,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,12 +296,14 @@ 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
 compiler/mips/ncpucall.pas svneol=native#text/pascal
 compiler/mips/ncpucnv.pas svneol=native#text/pascal
 compiler/mips/ncpuinln.pas svneol=native#text/pascal
+compiler/mips/ncpuld.pas svneol=native#text/plain
 compiler/mips/ncpumat.pas svneol=native#text/pascal
 compiler/mips/ncpuset.pas svneol=native#text/pascal
 compiler/mips/opcode.inc svneol=native#text/plain
@@ -311,6 +357,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 +367,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 +429,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 +464,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 +491,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
@@ -448,6 +501,7 @@ compiler/ppcavr.lpi svneol=native#text/plain
 compiler/ppcgen/aasmcpu.pas svneol=native#text/plain
 compiler/ppcgen/agppcgas.pas svneol=native#text/plain
 compiler/ppcgen/cgppc.pas svneol=native#text/plain
+compiler/ppcgen/hlcgppc.pas svneol=native#text/plain
 compiler/ppcgen/ngppcadd.pas svneol=native#text/plain
 compiler/ppcgen/ngppccnv.pas svneol=native#text/plain
 compiler/ppcgen/ngppcinl.pas svneol=native#text/plain
@@ -489,6 +543,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 +569,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
@@ -533,6 +589,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
@@ -560,6 +617,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
@@ -596,6 +654,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
@@ -627,9 +686,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
@@ -652,6 +713,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
@@ -971,6 +1033,7 @@ packages/bzip2/LICENSE svneol=native#text/plain
 packages/bzip2/Makefile svneol=native#text/plain
 packages/bzip2/Makefile.fpc svneol=native#text/plain
 packages/bzip2/Makefile.fpc.fpcmake svneol=native#text/plain
+packages/bzip2/examples/pasbunzip2.pas svneol=native#text/plain
 packages/bzip2/examples/pasbzip.pas svneol=native#text/plain
 packages/bzip2/fpmake.pp svneol=native#text/plain
 packages/bzip2/src/bzip2.pas svneol=native#text/plain
@@ -1820,6 +1883,9 @@ packages/fcl-base/texts/fptemplate.txt svneol=native#text/plain
 packages/fcl-db/Makefile svneol=native#text/plain
 packages/fcl-db/Makefile.fpc svneol=native#text/plain
 packages/fcl-db/Makefile.fpc.fpcmake svneol=native#text/plain
+packages/fcl-db/examples/fbadmindemo.pp svneol=native#text/plain
+packages/fcl-db/examples/fbeventstest.pp svneol=native#text/plain
+packages/fcl-db/examples/pqeventstest.pp svneol=native#text/plain
 packages/fcl-db/fpmake.pp svneol=native#text/plain
 packages/fcl-db/src/Dataset.txt svneol=native#text/plain
 packages/fcl-db/src/README.txt svneol=native#text/plain
@@ -1966,6 +2032,8 @@ packages/fcl-db/src/sqldb/fpmake.inc svneol=native#text/plain
 packages/fcl-db/src/sqldb/fpmake.pp svneol=native#text/plain
 packages/fcl-db/src/sqldb/interbase/Makefile svneol=native#text/plain
 packages/fcl-db/src/sqldb/interbase/Makefile.fpc svneol=native#text/plain
+packages/fcl-db/src/sqldb/interbase/fbadmin.pp svneol=native#text/plain
+packages/fcl-db/src/sqldb/interbase/fbeventmonitor.pp svneol=native#text/plain
 packages/fcl-db/src/sqldb/interbase/fpmake.inc svneol=native#text/plain
 packages/fcl-db/src/sqldb/interbase/fpmake.pp svneol=native#text/plain
 packages/fcl-db/src/sqldb/interbase/ibconnection.pp svneol=native#text/plain
@@ -1997,6 +2065,7 @@ packages/fcl-db/src/sqldb/postgres/Makefile.fpc svneol=native#text/plain
 packages/fcl-db/src/sqldb/postgres/fpmake.inc svneol=native#text/plain
 packages/fcl-db/src/sqldb/postgres/fpmake.pp svneol=native#text/plain
 packages/fcl-db/src/sqldb/postgres/pqconnection.pp svneol=native#text/plain
+packages/fcl-db/src/sqldb/postgres/pqeventmonitor.pp svneol=native#text/plain
 packages/fcl-db/src/sqldb/sqldb.pp svneol=native#text/plain
 packages/fcl-db/src/sqldb/sqlite/Makefile svneol=native#text/plain
 packages/fcl-db/src/sqldb/sqlite/Makefile.fpc svneol=native#text/plain
@@ -2026,6 +2095,8 @@ packages/fcl-db/tests/dbfexporttest.lpr svneol=native#text/plain
 packages/fcl-db/tests/dbfexporttestcase1.pas svneol=native#text/plain
 packages/fcl-db/tests/dbftoolsunit.pas svneol=native#text/plain
 packages/fcl-db/tests/dbtestframework.pas svneol=native#text/plain
+packages/fcl-db/tests/dbtestframework_gui.lpi svneol=native#text/plain
+packages/fcl-db/tests/dbtestframework_gui.lpr svneol=native#text/plain
 packages/fcl-db/tests/memdstoolsunit.pas svneol=native#text/plain
 packages/fcl-db/tests/sdfdstoolsunit.pas svneol=native#text/plain
 packages/fcl-db/tests/sqldbtoolsunit.pas svneol=native#text/plain
@@ -2114,6 +2185,7 @@ packages/fcl-image/examples/Makefile svneol=native#text/plain
 packages/fcl-image/examples/Makefile.fpc svneol=native#text/plain
 packages/fcl-image/examples/drawing.pp svneol=native#text/plain
 packages/fcl-image/examples/imgconv.pp svneol=native#text/plain
+packages/fcl-image/examples/interpoldemo.pp svneol=native#text/plain
 packages/fcl-image/examples/xwdtobmp.pas svneol=native#text/plain
 packages/fcl-image/fpmake.pp svneol=native#text/plain
 packages/fcl-image/src/bmpcomn.pp svneol=native#text/plain
@@ -2127,6 +2199,7 @@ packages/fcl-image/src/fpcdrawh.inc svneol=native#text/plain
 packages/fcl-image/src/fpcolcnv.inc svneol=native#text/plain
 packages/fcl-image/src/fpcolhash.pas svneol=native#text/plain
 packages/fcl-image/src/fpcolors.inc svneol=native#text/plain
+packages/fcl-image/src/fpcompactimg.inc svneol=native#text/plain
 packages/fcl-image/src/fpditherer.pas svneol=native#text/plain
 packages/fcl-image/src/fpfont.inc svneol=native#text/plain
 packages/fcl-image/src/fphandler.inc svneol=native#text/plain
@@ -2135,6 +2208,7 @@ packages/fcl-image/src/fpimage.inc svneol=native#text/plain
 packages/fcl-image/src/fpimage.pp svneol=native#text/plain
 packages/fcl-image/src/fpimgcanv.pp svneol=native#text/plain
 packages/fcl-image/src/fpimgcmn.pp svneol=native#text/plain
+packages/fcl-image/src/fpimggauss.pp svneol=native#text/plain
 packages/fcl-image/src/fpinterpolation.inc svneol=native#text/plain
 packages/fcl-image/src/fppalette.inc svneol=native#text/plain
 packages/fcl-image/src/fppen.inc svneol=native#text/plain
@@ -7142,6 +7216,13 @@ rtl/android/Makefile.fpc svneol=native#text/plain
 rtl/android/arm/cprt0.as svneol=native#text/plain
 rtl/android/arm/dllprt0.as svneol=native#text/plain
 rtl/android/arm/prt0.as 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
@@ -7546,6 +7627,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
@@ -7555,6 +7637,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
@@ -7829,6 +7955,7 @@ rtl/nativent/ndk/ketypes.inc svneol=native#text/plain
 rtl/nativent/ndk/ntdef.inc svneol=native#text/plain
 rtl/nativent/ndk/ntstatus.inc svneol=native#text/plain
 rtl/nativent/ndk/obfuncs.inc svneol=native#text/plain
+rtl/nativent/ndk/obtypes.inc svneol=native#text/plain
 rtl/nativent/ndk/peb_teb.inc svneol=native#text/plain
 rtl/nativent/ndk/pstypes.inc svneol=native#text/plain
 rtl/nativent/ndk/rtlfuncs.inc svneol=native#text/plain
@@ -7901,6 +8028,11 @@ rtl/netbsd/unxconst.inc svneol=native#text/plain
 rtl/netbsd/unxfunc.inc svneol=native#text/plain
 rtl/netbsd/unxsockh.inc svneol=native#text/plain
 rtl/netbsd/unxsysc.inc svneol=native#text/plain
+rtl/netbsd/x86_64/bsyscall.inc svneol=native#text/plain
+rtl/netbsd/x86_64/cprt0.as svneol=native#text/plain
+rtl/netbsd/x86_64/gprt0.as svneol=native#text/plain
+rtl/netbsd/x86_64/prt0.as svneol=native#text/plain
+rtl/netbsd/x86_64/sighnd.inc svneol=native#text/plain
 rtl/netware/Makefile svneol=native#text/plain
 rtl/netware/Makefile.fpc svneol=native#text/plain
 rtl/netware/README.txt svneol=native#text/plain
@@ -8107,7 +8239,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
@@ -9458,6 +9590,7 @@ tests/tbs/tb0577a.pp svneol=native#text/plain
 tests/tbs/tb0578.pp svneol=native#text/pascal
 tests/tbs/tb0579.pp svneol=native#text/pascal
 tests/tbs/tb0580.pp svneol=native#text/pascal
+tests/tbs/tb0581.pp svneol=native#text/plain
 tests/tbs/tb205.pp svneol=native#text/plain
 tests/tbs/ub0060.pp svneol=native#text/plain
 tests/tbs/ub0069.pp svneol=native#text/plain
@@ -9523,6 +9656,13 @@ tests/test/cg/obj/aix/powerpc/tcext3.o -text
 tests/test/cg/obj/aix/powerpc/tcext4.o -text
 tests/test/cg/obj/aix/powerpc/tcext5.o -text
 tests/test/cg/obj/aix/powerpc/tcext6.o -text
+tests/test/cg/obj/aix/powerpc64/cpptcl1.o -text
+tests/test/cg/obj/aix/powerpc64/cpptcl2.o -text
+tests/test/cg/obj/aix/powerpc64/ctest.o -text
+tests/test/cg/obj/aix/powerpc64/tcext3.o -text
+tests/test/cg/obj/aix/powerpc64/tcext4.o -text
+tests/test/cg/obj/aix/powerpc64/tcext5.o -text
+tests/test/cg/obj/aix/powerpc64/tcext6.o -text
 tests/test/cg/obj/amiga/m68k/ctest.o -text
 tests/test/cg/obj/beos/i386/ctest.o -text
 tests/test/cg/obj/beos/i386/tcext3.o -text
@@ -9728,7 +9868,6 @@ tests/test/cg/tcalcst5.pp svneol=native#text/plain
 tests/test/cg/tcalcst6.pp svneol=native#text/plain
 tests/test/cg/tcalcst7.pp svneol=native#text/plain
 tests/test/cg/tcalcst8.pp svneol=native#text/plain
-tests/test/cg/tcalcst9.pp svneol=native#text/plain
 tests/test/cg/tcalext.pp svneol=native#text/plain
 tests/test/cg/tcalext3.pp svneol=native#text/plain
 tests/test/cg/tcalext4.pp svneol=native#text/plain
@@ -9741,7 +9880,6 @@ tests/test/cg/tcalfun4.pp svneol=native#text/plain
 tests/test/cg/tcalfun6.pp svneol=native#text/plain
 tests/test/cg/tcalfun7.pp svneol=native#text/plain
 tests/test/cg/tcalfun8.pp svneol=native#text/plain
-tests/test/cg/tcalfun9.pp svneol=native#text/plain
 tests/test/cg/tcall1.pp svneol=native#text/plain
 tests/test/cg/tcalobj1.pp svneol=native#text/plain
 tests/test/cg/tcalobj2.pp svneol=native#text/plain
@@ -9749,7 +9887,6 @@ tests/test/cg/tcalobj3.pp svneol=native#text/plain
 tests/test/cg/tcalobj4.pp svneol=native#text/plain
 tests/test/cg/tcalobj6.pp svneol=native#text/plain
 tests/test/cg/tcalobj7.pp svneol=native#text/plain
-tests/test/cg/tcalobj8.pp svneol=native#text/plain
 tests/test/cg/tcalpext.pp svneol=native#text/plain
 tests/test/cg/tcalpvr1.pp svneol=native#text/plain
 tests/test/cg/tcalpvr2.pp svneol=native#text/plain
@@ -9757,7 +9894,6 @@ tests/test/cg/tcalpvr3.pp svneol=native#text/plain
 tests/test/cg/tcalpvr4.pp svneol=native#text/plain
 tests/test/cg/tcalpvr6.pp svneol=native#text/plain
 tests/test/cg/tcalpvr7.pp svneol=native#text/plain
-tests/test/cg/tcalpvr8.pp svneol=native#text/plain
 tests/test/cg/tcalval1.pp svneol=native#text/plain
 tests/test/cg/tcalval10.pp svneol=native#text/plain
 tests/test/cg/tcalval2.pp svneol=native#text/plain
@@ -9766,7 +9902,6 @@ tests/test/cg/tcalval4.pp svneol=native#text/plain
 tests/test/cg/tcalval5.pp svneol=native#text/plain
 tests/test/cg/tcalval7.pp svneol=native#text/plain
 tests/test/cg/tcalval8.pp svneol=native#text/plain
-tests/test/cg/tcalval9.pp svneol=native#text/plain
 tests/test/cg/tcalvar1.pp svneol=native#text/plain
 tests/test/cg/tcalvar2.pp svneol=native#text/plain
 tests/test/cg/tcalvar3.pp svneol=native#text/plain
@@ -9775,7 +9910,6 @@ tests/test/cg/tcalvar5.pp svneol=native#text/plain
 tests/test/cg/tcalvar6.pp svneol=native#text/plain
 tests/test/cg/tcalvar7.pp svneol=native#text/plain
 tests/test/cg/tcalvar8.pp svneol=native#text/plain
-tests/test/cg/tcalvar9.pp svneol=native#text/plain
 tests/test/cg/tcase.pp svneol=native#text/plain
 tests/test/cg/tcase2.pp svneol=native#text/plain
 tests/test/cg/tclacla1.pp svneol=native#text/plain
@@ -10019,6 +10153,80 @@ 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/tenum2.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/tsetansistr.pp -text 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
@@ -10265,6 +10473,8 @@ tests/test/tclass12d.pp svneol=native#text/plain
 tests/test/tclass13.pp svneol=native#text/pascal
 tests/test/tclass13a.pp svneol=native#text/plain
 tests/test/tclass13b.pp svneol=native#text/plain
+tests/test/tclass13c.pp svneol=native#text/pascal
+tests/test/tclass13d.pp svneol=native#text/pascal
 tests/test/tclass14a.pp svneol=native#text/pascal
 tests/test/tclass14b.pp svneol=native#text/pascal
 tests/test/tclass15.pp svneol=native#text/pascal
@@ -10298,6 +10508,10 @@ tests/test/tcpstr18.pp svneol=native#text/pascal
 tests/test/tcpstr19.pp svneol=native#text/pascal
 tests/test/tcpstr2.pp svneol=native#text/plain
 tests/test/tcpstr20.pp svneol=native#text/pascal
+tests/test/tcpstr21.pp svneol=native#text/pascal
+tests/test/tcpstr21a.pp svneol=native#text/pascal
+tests/test/tcpstr22.pp svneol=native#text/pascal
+tests/test/tcpstr23.pp svneol=native#text/pascal
 tests/test/tcpstr2a.pp svneol=native#text/plain
 tests/test/tcpstr3.pp svneol=native#text/plain
 tests/test/tcpstr4.pp svneol=native#text/plain
@@ -10334,7 +10548,6 @@ tests/test/tdefault12.pp svneol=native#text/pascal
 tests/test/tdefault13.pp svneol=native#text/pascal
 tests/test/tdefault14.pp svneol=native#text/pascal
 tests/test/tdefault15.pp svneol=native#text/pascal
-tests/test/tdefault16.pp svneol=native#text/pascal
 tests/test/tdefault2.pp svneol=native#text/pascal
 tests/test/tdefault3.pp svneol=native#text/pascal
 tests/test/tdefault4.pp svneol=native#text/pascal
@@ -10365,6 +10578,7 @@ tests/test/terecs10.pp svneol=native#text/pascal
 tests/test/terecs11.pp svneol=native#text/pascal
 tests/test/terecs12.pp svneol=native#text/pascal
 tests/test/terecs13.pp svneol=native#text/pascal
+tests/test/terecs14.pp svneol=native#text/pascal
 tests/test/terecs2.pp svneol=native#text/pascal
 tests/test/terecs3.pp svneol=native#text/pascal
 tests/test/terecs4.pp svneol=native#text/pascal
@@ -10511,8 +10725,23 @@ tests/test/tgeneric72.pp svneol=native#text/pascal
 tests/test/tgeneric73.pp svneol=native#text/pascal
 tests/test/tgeneric74.pp svneol=native#text/pascal
 tests/test/tgeneric75.pp svneol=native#text/pascal
+tests/test/tgeneric76.pp svneol=native#text/pascal
+tests/test/tgeneric77.pp svneol=native#text/pascal
+tests/test/tgeneric78.pp svneol=native#text/pascal
+tests/test/tgeneric79.pp svneol=native#text/pascal
 tests/test/tgeneric8.pp svneol=native#text/plain
+tests/test/tgeneric80.pp svneol=native#text/pascal
+tests/test/tgeneric81.pp svneol=native#text/pascal
+tests/test/tgeneric82.pp svneol=native#text/pascal
+tests/test/tgeneric83.pp svneol=native#text/pascal
+tests/test/tgeneric84.pp svneol=native#text/pascal
+tests/test/tgeneric85.pp svneol=native#text/pascal
+tests/test/tgeneric86.pp svneol=native#text/pascal
+tests/test/tgeneric87.pp svneol=native#text/pascal
+tests/test/tgeneric88.pp svneol=native#text/pascal
+tests/test/tgeneric89.pp svneol=native#text/pascal
 tests/test/tgeneric9.pp svneol=native#text/plain
+tests/test/tgeneric90.pp svneol=native#text/pascal
 tests/test/tgoto.pp svneol=native#text/plain
 tests/test/theap.pp svneol=native#text/plain
 tests/test/theapthread.pp svneol=native#text/plain
@@ -10605,6 +10834,7 @@ tests/test/tisogoto1.pp svneol=native#text/pascal
 tests/test/tisogoto2.pp svneol=native#text/pascal
 tests/test/tisogoto3.pp svneol=native#text/pascal
 tests/test/tisogoto4.pp svneol=native#text/pascal
+tests/test/tisogoto5.pp svneol=native#text/pascal
 tests/test/tlib1a.pp svneol=native#text/plain
 tests/test/tlib1b.pp svneol=native#text/plain
 tests/test/tlib2a.pp svneol=native#text/plain
@@ -10871,6 +11101,7 @@ tests/test/trhlp40.pp svneol=native#text/pascal
 tests/test/trhlp41.pp svneol=native#text/pascal
 tests/test/trhlp42.pp svneol=native#text/pascal
 tests/test/trhlp43.pp svneol=native#text/pascal
+tests/test/trhlp44.pp svneol=native#text/pascal
 tests/test/trhlp5.pp svneol=native#text/pascal
 tests/test/trhlp6.pp svneol=native#text/pascal
 tests/test/trhlp7.pp svneol=native#text/pascal
@@ -11147,6 +11378,7 @@ tests/test/units/system/testmac.txt svneol=native#text/plain
 tests/test/units/system/testpc.txt svneol=native#text/plain
 tests/test/units/system/teststk.pp svneol=native#text/plain
 tests/test/units/system/testux.txt svneol=native#text/plain
+tests/test/units/system/tgenstr.pp svneol=native#text/pascal
 tests/test/units/system/tincdec.pp svneol=native#text/plain
 tests/test/units/system/tint.pp svneol=native#text/plain
 tests/test/units/system/tintstr.pp svneol=native#text/plain
@@ -11183,6 +11415,7 @@ tests/test/units/system/tsetstr.pp svneol=native#text/plain
 tests/test/units/system/tsetstr2.pp svneol=native#text/plain
 tests/test/units/system/tslice1.pp svneol=native#text/plain
 tests/test/units/system/tslice2.pp svneol=native#text/plain
+tests/test/units/system/tstr1.pp svneol=native#text/pascal
 tests/test/units/system/tstring.pp svneol=native#text/plain
 tests/test/units/system/ttrig.pas svneol=native#text/plain
 tests/test/units/system/ttrunc.pp svneol=native#text/plain
@@ -11203,6 +11436,7 @@ tests/test/units/sysutils/tencodingerrors.pp svneol=native#text/pascal
 tests/test/units/sysutils/tencodingtest.pp svneol=native#text/pascal
 tests/test/units/sysutils/texec1.pp svneol=native#text/plain
 tests/test/units/sysutils/texec2.pp svneol=native#text/plain
+tests/test/units/sysutils/texpfncase.pp svneol=native#text/plain
 tests/test/units/sysutils/textractquote.pp svneol=native#text/plain
 tests/test/units/sysutils/tfile1.pp svneol=native#text/plain
 tests/test/units/sysutils/tfile2.pp svneol=native#text/plain
@@ -11240,21 +11474,23 @@ tests/test/uunit2b.pp svneol=native#text/plain
 tests/test/uunit3a.pp svneol=native#text/plain
 tests/test/uunit3b.pp svneol=native#text/plain
 tests/test/uunit3c.pp svneol=native#text/plain
-tests/units/MPWMake -text
-tests/units/Makefile svneol=native#text/plain
-tests/units/Makefile.fpc svneol=native#text/plain
-tests/units/erroru.pp svneol=native#text/plain
-tests/units/popuperr.pp svneol=native#text/plain
-tests/units/win32err.pp svneol=native#text/plain
+tests/tstunits/MPWMake svneol=native#text/plain
+tests/tstunits/Makefile svneol=native#text/plain
+tests/tstunits/Makefile.fpc svneol=native#text/plain
+tests/tstunits/erroru.pp svneol=native#text/plain
+tests/tstunits/popuperr.pp svneol=native#text/plain
+tests/tstunits/win32err.pp svneol=native#text/plain
 tests/utils/Makefile svneol=native#text/plain
 tests/utils/Makefile.fpc svneol=native#text/plain
 tests/utils/bench.pp svneol=native#text/plain
+tests/utils/concat.pp svneol=native#text/plain
 tests/utils/dbdigest.pp svneol=native#text/plain
 tests/utils/dbtests.pp svneol=native#text/plain
 tests/utils/digest.pp svneol=native#text/plain
 tests/utils/dotest.pp svneol=native#text/plain
 tests/utils/fail.pp svneol=native#text/plain
 tests/utils/fptime.pp svneol=native#text/plain
+tests/utils/gparmake.pp svneol=native#text/plain
 tests/utils/libtar.pas svneol=native#text/plain
 tests/utils/macos/LinkRunDir -text
 tests/utils/macos/LinkRunTests -text
@@ -11290,6 +11526,10 @@ tests/webtbf/tw0896.pp svneol=native#text/plain
 tests/webtbf/tw0896a.pp svneol=native#text/plain
 tests/webtbf/tw10081.pp svneol=native#text/plain
 tests/webtbf/tw10425a.pp svneol=native#text/plain
+tests/webtbf/tw10425b.pp svneol=native#text/plain
+tests/webtbf/tw10425c.pp svneol=native#text/plain
+tests/webtbf/tw10425d.pp svneol=native#text/plain
+tests/webtbf/tw10425e.pp svneol=native#text/plain
 tests/webtbf/tw10457.pp svneol=native#text/plain
 tests/webtbf/tw10833a.pp svneol=native#text/plain
 tests/webtbf/tw10849.pp svneol=native#text/plain
@@ -11405,6 +11645,7 @@ tests/webtbf/tw19213.pp svneol=native#text/plain
 tests/webtbf/tw1927.pp svneol=native#text/plain
 tests/webtbf/tw1928.pp svneol=native#text/plain
 tests/webtbf/tw1939.pp svneol=native#text/plain
+tests/webtbf/tw19434.pp svneol=native#text/plain
 tests/webtbf/tw19463.pp svneol=native#text/pascal
 tests/webtbf/tw1949.pp svneol=native#text/plain
 tests/webtbf/tw19591.pp svneol=native#text/plain
@@ -11430,11 +11671,14 @@ tests/webtbf/tw21087.pp svneol=native#text/plain
 tests/webtbf/tw21238.pp svneol=native#text/pascal
 tests/webtbf/tw2128.pp svneol=native#text/plain
 tests/webtbf/tw2129.pp svneol=native#text/plain
+tests/webtbf/tw21363.pp svneol=native#text/pascal
 tests/webtbf/tw21466.pas svneol=native#text/pascal
 tests/webtbf/tw2154.pp svneol=native#text/plain
 tests/webtbf/tw21566.pp svneol=native#text/pascal
 tests/webtbf/tw2174.pp svneol=native#text/plain
+tests/webtbf/tw21873.pp svneol=native#text/plain
 tests/webtbf/tw2209.pp svneol=native#text/plain
+tests/webtbf/tw22219.pp svneol=native#text/pascal
 tests/webtbf/tw2242.pp svneol=native#text/plain
 tests/webtbf/tw2273.pp svneol=native#text/plain
 tests/webtbf/tw2281.pp svneol=native#text/plain
@@ -12073,6 +12317,7 @@ tests/webtbs/tw15610.pp svneol=native#text/plain
 tests/webtbs/tw15619.pp svneol=native#text/plain
 tests/webtbs/tw15668.pp svneol=native#text/pascal
 tests/webtbs/tw1567.pp svneol=native#text/plain
+tests/webtbs/tw15683.pp svneol=native#text/pascal
 tests/webtbs/tw15690.pp svneol=native#text/plain
 tests/webtbs/tw15693.pp svneol=native#text/plain
 tests/webtbs/tw15694.pp svneol=native#text/plain
@@ -12091,6 +12336,7 @@ tests/webtbs/tw15843.pp svneol=native#text/plain
 tests/webtbs/tw15909.pp svneol=native#text/plain
 tests/webtbs/tw1592.pp svneol=native#text/plain
 tests/webtbs/tw15930.pp svneol=native#text/plain
+tests/webtbs/tw15966.pp svneol=native#text/plain
 tests/webtbs/tw16004.pp svneol=native#text/plain
 tests/webtbs/tw16018.pp svneol=native#text/plain
 tests/webtbs/tw16034.pp svneol=native#text/plain
@@ -12148,6 +12394,7 @@ tests/webtbs/tw16980.pp svneol=native#text/plain
 tests/webtbs/tw1699.pp svneol=native#text/plain
 tests/webtbs/tw1709.pp svneol=native#text/plain
 tests/webtbs/tw17118.pp svneol=native#text/plain
+tests/webtbs/tw17136.pp svneol=native#text/plain
 tests/webtbs/tw17164.pp svneol=native#text/plain
 tests/webtbs/tw17180.pp svneol=native#text/plain
 tests/webtbs/tw17181.pp svneol=native#text/plain
@@ -12242,8 +12489,10 @@ tests/webtbs/tw1862.pp svneol=native#text/plain
 tests/webtbs/tw18620.pp svneol=native#text/pascal
 tests/webtbs/tw1863.pp svneol=native#text/plain
 tests/webtbs/tw1867.pp svneol=native#text/plain
+tests/webtbs/tw18688.pp svneol=native#text/pascal
 tests/webtbs/tw18690.pp svneol=native#text/plain
 tests/webtbs/tw18702.pp svneol=native#text/pascal
+tests/webtbs/tw18704.pp svneol=native#text/pascal
 tests/webtbs/tw18706.pp svneol=native#text/plain
 tests/webtbs/tw1873.pp svneol=native#text/plain
 tests/webtbs/tw18767a.pp svneol=native#text/pascal
@@ -12278,12 +12527,18 @@ tests/webtbs/tw1935.pp svneol=native#text/plain
 tests/webtbs/tw1936.pp svneol=native#text/plain
 tests/webtbs/tw19368.pp svneol=native#text/pascal
 tests/webtbs/tw1938.pp svneol=native#text/plain
+tests/webtbs/tw19434a.pp svneol=native#text/plain
+tests/webtbs/tw19434b.pp svneol=native#text/plain
 tests/webtbs/tw1948.pp svneol=native#text/plain
 tests/webtbs/tw19498.pp svneol=native#text/pascal
+tests/webtbs/tw19499.pp svneol=native#text/pascal
 tests/webtbs/tw1950.pp svneol=native#text/plain
 tests/webtbs/tw19500.pp svneol=native#text/pascal
+tests/webtbs/tw19511.pp svneol=native#text/pascal
 tests/webtbs/tw19548.pp svneol=native#text/pascal
 tests/webtbs/tw19555.pp svneol=native#text/pascal
+tests/webtbs/tw19581.pp svneol=native#text/plain
+tests/webtbs/tw19622.pp -text svneol=native#text/plain
 tests/webtbs/tw1964.pp svneol=native#text/plain
 tests/webtbs/tw19651.pp svneol=native#text/plain
 tests/webtbs/tw19700.pp svneol=native#text/plain
@@ -12354,12 +12609,15 @@ tests/webtbs/tw20874b.pp svneol=native#text/pascal
 tests/webtbs/tw20889.pp svneol=native#text/pascal
 tests/webtbs/tw20909.pp svneol=native#text/pascal
 tests/webtbs/tw20940.pp svneol=native#text/pascal
+tests/webtbs/tw20947.pp svneol=native#text/pascal
 tests/webtbs/tw20962.pp svneol=native#text/plain
 tests/webtbs/tw20995a.pp svneol=native#text/pascal
 tests/webtbs/tw20995b.pp svneol=native#text/pascal
 tests/webtbs/tw20998.pp svneol=native#text/pascal
 tests/webtbs/tw21029.pp svneol=native#text/plain
 tests/webtbs/tw21044.pp svneol=native#text/pascal
+tests/webtbs/tw21064a.pp svneol=native#text/pascal
+tests/webtbs/tw21064b.pp svneol=native#text/pascal
 tests/webtbs/tw21073.pp svneol=native#text/plain
 tests/webtbs/tw2109.pp svneol=native#text/plain
 tests/webtbs/tw21091.pp svneol=native#text/pascal
@@ -12369,36 +12627,58 @@ tests/webtbs/tw21151.pp svneol=native#text/plain
 tests/webtbs/tw21177.pp svneol=native#text/plain
 tests/webtbs/tw21179.pp svneol=native#text/pascal
 tests/webtbs/tw21255.pp svneol=native#text/plain
+tests/webtbs/tw21267.pp svneol=native#text/plain
 tests/webtbs/tw2128.pp svneol=native#text/plain
 tests/webtbs/tw2129.pp svneol=native#text/plain
 tests/webtbs/tw2129b.pp svneol=native#text/plain
 tests/webtbs/tw2131.pp svneol=native#text/plain
+tests/webtbs/tw21350a.pp svneol=native#text/pascal
+tests/webtbs/tw21350b.pp svneol=native#text/pascal
 tests/webtbs/tw21443.pp svneol=native#text/plain
 tests/webtbs/tw2145.pp svneol=native#text/plain
+tests/webtbs/tw21457.pp svneol=native#text/pascal
 tests/webtbs/tw21472.pp svneol=native#text/pascal
+tests/webtbs/tw21550.pp svneol=native#text/pascal
 tests/webtbs/tw21551.pp svneol=native#text/plain
 tests/webtbs/tw2158.pp svneol=native#text/plain
 tests/webtbs/tw2159.pp svneol=native#text/plain
 tests/webtbs/tw21592.pp svneol=native#text/pascal
+tests/webtbs/tw21592b.pp svneol=native#text/pascal
 tests/webtbs/tw21593.pp svneol=native#text/pascal
+tests/webtbs/tw21593a.pp svneol=native#text/pascal
+tests/webtbs/tw21593b.pp svneol=native#text/pascal
+tests/webtbs/tw21593c.pp svneol=native#text/pascal
 tests/webtbs/tw2163.pp svneol=native#text/plain
+tests/webtbs/tw21654.pp svneol=native#text/pascal
 tests/webtbs/tw21674.pp svneol=native#text/pascal
 tests/webtbs/tw21684.pp svneol=native#text/pascal
 tests/webtbs/tw2176.pp svneol=native#text/plain
 tests/webtbs/tw2177.pp svneol=native#text/plain
 tests/webtbs/tw2178.pp svneol=native#text/plain
+tests/webtbs/tw21808.pp svneol=native#text/plain
 tests/webtbs/tw2185.pp svneol=native#text/plain
 tests/webtbs/tw2186.pp svneol=native#text/plain
 tests/webtbs/tw2187.pp svneol=native#text/plain
+tests/webtbs/tw21878.pp svneol=native#text/plain
+tests/webtbs/tw21914.pp svneol=native#text/pascal
+tests/webtbs/tw21921.pp svneol=native#text/pascal
+tests/webtbs/tw21941.pp svneol=native#text/pascal
+tests/webtbs/tw21951.pp svneol=native#text/plain
 tests/webtbs/tw2196.pp svneol=native#text/plain
 tests/webtbs/tw2197.pp svneol=native#text/plain
 tests/webtbs/tw2198.pp svneol=native#text/plain
 tests/webtbs/tw2210.pp svneol=native#text/plain
+tests/webtbs/tw22133.pp svneol=native#text/plain
 tests/webtbs/tw2214.pp svneol=native#text/plain
+tests/webtbs/tw22154.pp svneol=native#text/pascal
 tests/webtbs/tw2220.pp svneol=native#text/plain
 tests/webtbs/tw2226.pp svneol=native#text/plain
 tests/webtbs/tw2229.pp svneol=native#text/plain
+tests/webtbs/tw22320.pp svneol=native#text/plain
+tests/webtbs/tw22326.pp svneol=native#text/plain
+tests/webtbs/tw22329.pp svneol=native#text/pascal
 tests/webtbs/tw2233.pp svneol=native#text/plain
+tests/webtbs/tw22331.pp svneol=native#text/plain
 tests/webtbs/tw2242.pp svneol=native#text/plain
 tests/webtbs/tw2250.pp svneol=native#text/plain
 tests/webtbs/tw2259.pp svneol=native#text/plain
@@ -13177,6 +13457,7 @@ tests/webtbs/uw14124.pp svneol=native#text/plain
 tests/webtbs/uw14958.pp svneol=native#text/plain
 tests/webtbs/uw15591.pp svneol=native#text/pascal
 tests/webtbs/uw15909.pp svneol=native#text/plain
+tests/webtbs/uw15966.pp svneol=native#text/plain
 tests/webtbs/uw17220.pp svneol=native#text/plain
 tests/webtbs/uw17220a.pp svneol=native#text/plain
 tests/webtbs/uw17493.pp svneol=native#text/plain
@@ -13193,6 +13474,8 @@ tests/webtbs/uw2040.pp svneol=native#text/plain
 tests/webtbs/uw20909a.pas svneol=native#text/pascal
 tests/webtbs/uw20909b.pas svneol=native#text/pascal
 tests/webtbs/uw20940.pp svneol=native#text/pascal
+tests/webtbs/uw21808a.pp svneol=native#text/plain
+tests/webtbs/uw21808b.pp svneol=native#text/plain
 tests/webtbs/uw2266a.inc svneol=native#text/plain
 tests/webtbs/uw2266b.pas svneol=native#text/plain
 tests/webtbs/uw2269.inc svneol=native#text/plain
@@ -13241,7 +13524,6 @@ utils/Makefile svneol=native#text/plain
 utils/Makefile.fpc svneol=native#text/plain
 utils/README.txt svneol=native#text/plain
 utils/bin2obj.pp svneol=native#text/plain
-utils/checkcvs.pp svneol=native#text/plain
 utils/creumap.pp svneol=native#text/plain
 utils/data2inc.exm -text
 utils/data2inc.pp svneol=native#text/plain
@@ -13309,8 +13591,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
@@ -13509,6 +13794,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

.gitignore

@@ -7594,14 +7594,14 @@ tests/test/units/variants/*.ppu
 tests/test/units/variants/*.s
 tests/test/units/variants/fpcmade.*
 tests/test/units/variants/units
-tests/units/*-stamp.*
-tests/units/*.bak
-tests/units/*.exe
-tests/units/*.o
-tests/units/*.ppu
-tests/units/*.s
-tests/units/fpcmade.*
-tests/units/units
+tests/tstunits/*-stamp.*
+tests/tstunits/*.bak
+tests/tstunits/*.exe
+tests/tstunits/*.o
+tests/tstunits/*.ppu
+tests/tstunits/*.s
+tests/tstunits/fpcmade.*
+tests/tstunits/units
 tests/utils/*.bak
 tests/utils/*.exe
 tests/utils/*.o

Makefile

@@ -1,8 +1,8 @@
 #
-# Don't edit, this file is generated by FPCMake Version 2.0.0 [2012/05/07]
+# Don't edit, this file is generated by FPCMake Version 2.0.0 [2012/07/07]
 #
 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 i386-android 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 powerpc-android 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 arm-android powerpc64-linux powerpc64-darwin powerpc64-embedded powerpc64-aix avr-embedded armeb-linux armeb-embedded armel-android 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 i386-android 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 arm-android 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 android
 LIMIT83fs = go32v2 os2 emx watcom
@@ -329,11 +329,24 @@ endif
 ifeq ($(CPU_TARGET),armeb)
 PPSUF=arm
 endif
+ifeq ($(CPU_TARGET),jvm)
+PPSUF=jvm
+endif
+ifeq ($(CPU_TARGET),mips)
+PPSUF=mips
+endif
+ifeq ($(CPU_TARGET),mipsel)
+PPSUF=mipsel
+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 +412,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
@@ -525,9 +539,6 @@ endif
 ifeq ($(FULL_TARGET),powerpc-aix)
 override TARGET_DIRS+=compiler rtl utils packages ide installer
 endif
-ifeq ($(FULL_TARGET),powerpc-android)
-override TARGET_DIRS+=compiler rtl utils packages ide installer
-endif
 ifeq ($(FULL_TARGET),sparc-linux)
 override TARGET_DIRS+=compiler rtl utils packages ide installer
 endif
@@ -612,15 +623,18 @@ endif
 ifeq ($(FULL_TARGET),armeb-embedded)
 override TARGET_DIRS+=compiler rtl utils packages ide installer
 endif
-ifeq ($(FULL_TARGET),armel-android)
-override TARGET_DIRS+=compiler rtl utils packages ide installer
-endif
 ifeq ($(FULL_TARGET),mips-linux)
 override TARGET_DIRS+=compiler rtl utils packages ide installer
 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)
@@ -2046,14 +2060,6 @@ TARGET_DIRS_PACKAGES=1
 TARGET_DIRS_IDE=1
 TARGET_DIRS_INSTALLER=1
 endif
-ifeq ($(FULL_TARGET),powerpc-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
 ifeq ($(FULL_TARGET),sparc-linux)
 TARGET_DIRS_COMPILER=1
 TARGET_DIRS_RTL=1
@@ -2278,7 +2284,7 @@ TARGET_DIRS_PACKAGES=1
 TARGET_DIRS_IDE=1
 TARGET_DIRS_INSTALLER=1
 endif
-ifeq ($(FULL_TARGET),armel-android)
+ifeq ($(FULL_TARGET),mips-linux)
 TARGET_DIRS_COMPILER=1
 TARGET_DIRS_RTL=1
 TARGET_DIRS_UTILS=1
@@ -2286,7 +2292,7 @@ TARGET_DIRS_PACKAGES=1
 TARGET_DIRS_IDE=1
 TARGET_DIRS_INSTALLER=1
 endif
-ifeq ($(FULL_TARGET),mips-linux)
+ifeq ($(FULL_TARGET),mipsel-linux)
 TARGET_DIRS_COMPILER=1
 TARGET_DIRS_RTL=1
 TARGET_DIRS_UTILS=1
@@ -2294,7 +2300,15 @@ TARGET_DIRS_PACKAGES=1
 TARGET_DIRS_IDE=1
 TARGET_DIRS_INSTALLER=1
 endif
-ifeq ($(FULL_TARGET),mipsel-linux)
+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
@@ -2610,7 +2624,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.*
@@ -2637,13 +2657,14 @@ ifdef IDE
 	$(MAKE) installer_all $(BUILDOPTS)
 endif
 	$(ECHOREDIR) Build > $(BUILDSTAMP)
+	$(ECHOREDIR) Build > base.$(BUILDSTAMP)
 buildbase: base.$(BUILDSTAMP)
 base.$(BUILDSTAMP):
 	$(MAKE) compiler_cycle RELEASE=1
 	$(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)
@@ -2666,9 +2687,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,27 @@ endif
 ifeq ($(CPU_TARGET),armeb)
 PPSUF=arm
 endif
+ifeq ($(CPU_TARGET),jvm)
+PPSUF=jvm
+endif
+ifeq ($(CPU_TARGET),mips)
+PPSUF=mips
+endif
+ifeq ($(CPU_TARGET),mipsel)
+PPSUF=mipsel
+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 +171,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 +230,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.*
@@ -247,6 +270,7 @@ ifdef IDE
         $(MAKE) installer_all $(BUILDOPTS)
 endif
         $(ECHOREDIR) Build > $(BUILDSTAMP)
+        $(ECHOREDIR) Build > base.$(BUILDSTAMP)
 
 buildbase: base.$(BUILDSTAMP)
 base.$(BUILDSTAMP):
@@ -258,7 +282,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 +312,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.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)
@@ -120,6 +123,33 @@ ifndef RTLOPT
 RTLOPT:=$(OPT)
 endif
 
+ifdef CYCLELEVEL
+ifeq ($(CYCLELEVEL),1)
+LOCALOOPT+=$(OPTLEVEL1)
+RTLOPT+=$(OPTLEVEL1)
+LOCALOPT+=$(LOCALOPTLEVEL1)
+RTLOPT+=$(RTLOPTLEVEL1)
+endif
+ifeq ($(CYCLELEVEL),2)
+LOCALOOPT+=$(OPTLEVEL2)
+RTLOPT+=$(OPTLEVEL2)
+LOCALOPT+=$(LOCALOPTLEVEL2)
+RTLOPT+=$(RTLOPTLEVEL2)
+endif
+ifeq ($(CYCLELEVEL),3)
+LOCALOOPT+=$(OPTLEVEL3)
+RTLOPT+=$(OPTLEVEL3)
+LOCALOPT+=$(LOCALOPTLEVEL3)
+RTLOPT+=$(RTLOPTLEVEL3)
+endif
+ifeq ($(CYCLELEVEL),4)
+LOCALOOPT+=$(OPTLEVEL4)
+RTLOPT+=$(OPTLEVEL4)
+LOCALOPT+=$(LOCALOPTLEVEL4)
+RTLOPT+=$(RTLOPTLEVEL4)
+endif
+endif
+
 # Make OPT empty. It is copied to LOCALOPT and RTLOPT
 override OPT=
 
@@ -160,6 +190,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 +274,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 +292,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 +355,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 +377,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 +432,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)
@@ -557,23 +609,23 @@ next :
 endif
 
 $(TEMPNAME1) :
-        $(MAKE) 'OLDFPC=' next
+        $(MAKE) 'OLDFPC=' next CYCLELEVEL=1
         -$(DEL) $(TEMPNAME1)
         $(MOVE) $(EXENAME) $(TEMPNAME1)
 
 $(TEMPNAME2) : $(TEMPNAME1)
-        $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME1)' 'OLDFPC=' next
+        $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME1)' 'OLDFPC=' next CYCLELEVEL=2
         -$(DEL) $(TEMPNAME2)
         $(MOVE) $(EXENAME) $(TEMPNAME2)
 
 $(TEMPNAME3) : $(TEMPNAME2)
-        $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME2)' 'OLDFPC=$(BASEDIR)/$(TEMPNAME1)' next
+        $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME2)' 'OLDFPC=$(BASEDIR)/$(TEMPNAME1)' next CYCLELEVEL=3
         -$(DEL) $(TEMPNAME3)
         $(MOVE) $(EXENAME) $(TEMPNAME3)
 
 cycle:
         $(MAKE) tempclean $(TEMPNAME3)
-        $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME3)' 'OLDFPC=$(BASEDIR)/$(TEMPNAME2)' next
+        $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME3)' 'OLDFPC=$(BASEDIR)/$(TEMPNAME2)' next CYCLELEVEL=4
         $(DIFF) $(TEMPNAME3) $(EXENAME)
         $(MAKE) $(addsuffix _all,$(TARGET_DIRS)) 'FPC=$(BASEDIR)/$(EXENAME)'
         $(MAKE) wpocycle
@@ -588,10 +640,10 @@ else
 cycle:
 # ppc (source native)
         $(MAKE) OS_TARGET=$(OS_SOURCE) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 rtlclean rtl
-        $(MAKE) OS_TARGET=$(OS_SOURCE) EXENAME=$(TEMPNAME) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 cycleclean compiler
+        $(MAKE) OS_TARGET=$(OS_SOURCE) EXENAME=$(TEMPNAME) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 cycleclean compiler CYCLELEVEL=1
 # ppcross<ARCH> (source native)
         $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME)' OS_TARGET=$(OS_SOURCE) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 rtlclean rtl
-        $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME)' OS_TARGET=$(OS_SOURCE) EXENAME=$(PPCROSSNAME) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 cycleclean compiler
+        $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME)' OS_TARGET=$(OS_SOURCE) EXENAME=$(PPCROSSNAME) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 cycleclean compiler CYCLELEVEL=2
 # ppc<ARCH> (target native)
 ifndef CROSSINSTALL
         $(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' rtlclean rtl
@@ -599,7 +651,7 @@ ifndef CROSSINSTALL
 ifneq ($(OS_TARGET),embedded)
 # building a native compiler for the arm-gba target is not possible
 ifneq ($(OS_TARGET),gba)
-        $(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' cycleclean compiler
+        $(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' cycleclean compiler CYCLELEVEL=3
 endif
 endif
 endif
@@ -621,19 +673,16 @@ cycle:
 # ppc (source native)
 # Clear detected compiler binary, because it can be existing crosscompiler binary, but we need native compiler here
         $(MAKE) OS_TARGET=$(OS_SOURCE) CPU_TARGET=$(CPU_SOURCE) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 rtlclean rtl
-        $(MAKE) OS_TARGET=$(OS_SOURCE) CPU_TARGET=$(CPU_SOURCE) EXENAME=$(TEMPNAME) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 cycleclean compiler
+        $(MAKE) OS_TARGET=$(OS_SOURCE) CPU_TARGET=$(CPU_SOURCE) EXENAME=$(TEMPNAME) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 cycleclean compiler CYCLELEVEL=1
 # ppcross<ARCH> (source native)
         $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME)' OS_TARGET=$(OS_SOURCE) CPU_TARGET=$(CPU_SOURCE) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 rtlclean rtl
-        $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME)' OS_TARGET=$(OS_SOURCE) CPU_TARGET=$(CPU_SOURCE) PPC_TARGET=$(CPU_TARGET) EXENAME=$(PPCROSSNAME) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 cycleclean compiler
+        $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME)' OS_TARGET=$(OS_SOURCE) CPU_TARGET=$(CPU_SOURCE) PPC_TARGET=$(CPU_TARGET) EXENAME=$(PPCROSSNAME) CROSSBINDIR= BINUTILSPREFIX= CROSSCYCLEBOOTSTRAP=1 cycleclean compiler CYCLELEVEL=2
 # 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)
-        $(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' 'OPT=$(LOCALOPT) $(CROSSOPT)' cycleclean compiler
-endif
+# building a native compiler for JVM and embedded targets is not possible
+ifndef NoNativeBinaries
+        $(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' 'OPT=$(LOCALOPT) $(CROSSOPT)' cycleclean compiler CYCLELEVEL=3
 endif
 endif
 
@@ -643,7 +692,7 @@ cycledep:
         $(MAKE) cycle USEDEPEND=1
 
 extcycle:
-        $(MAKE) cycle OPT='-n -OG2p3 -glttt -CRriot -dEXTDEBUG'
+        $(MAKE) cycle OPT="$(OPT) -n -OG2p3 -glttt -CRriot -dEXTDEBUG"
 
 cvstest:
         $(MAKE) cycle 'LOCALOPT=-n -Se' 'RTLOPT=-n -Se'
@@ -663,7 +712,11 @@ full: fullcycle
 fullcycle:
         $(MAKE) cycle
         $(MAKE) ppuclean
+ifneq ($(CPU_SOURCE),x86_64)
         $(MAKE) $(filter-out $(PPC_TARGET),$(CYCLETARGETS)) 'FPC=$(BASEDIR)/$(EXENAME)'
+else
+        $(MAKE) $(filter-out i386,$(filter-out $(PPC_TARGET),$(CYCLETARGETS))) 'FPC=$(BASEDIR)/$(EXENAME)'
+endif
 
 #####################################################################
 # Docs
@@ -687,9 +740,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;
 
@@ -191,6 +191,15 @@ interface
 
     function ReplaceForbiddenAsmSymbolChars(const s: string): string;
 
+	{ dummy default noop callback }
+	procedure default_global_used; 
+  type
+	TGlobalUsedProcedure = procedure;
+	{ Procedure variable to allow for special handling of 
+	  the occurence of use of a global variable,
+	  used by PIC code generation to request GOT loading }
+  const
+    global_used : TGlobalUsedProcedure = @default_global_used;
 
 implementation
 
@@ -347,7 +356,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 +421,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;
@@ -420,6 +429,7 @@ implementation
         is_set:=false;
         { write it always }
         increfs;
+		global_used;
       end;
 
 
@@ -441,10 +451,14 @@ implementation
       end;
 
 
-    function TAsmLabel.getname:string;
+    function TAsmLabel.getname:TSymStr;
       begin
         getname:=inherited getname;
         increfs;
       end;
 
+	procedure default_global_used;
+	  begin
+	  end;
+
 end.

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
@@ -64,10 +68,13 @@ interface
           ait_stab,
           ait_force_line,
           ait_function_name,
+		  { Used for .ent .end pair used for .dpr section in MIPS
+		    and probably also for Alpha }
+          ait_ent,
+		  ait_ent_end,
 {$ifdef alpha}
           { the follow is for the DEC Alpha }
           ait_frame,
-          ait_ent,
 {$endif alpha}
 {$ifdef ia64}
           ait_bundle,
@@ -88,7 +95,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 = (
@@ -156,10 +166,11 @@ interface
           'stab',
           'force_line',
           'function_name',
+          'ent',
+          'ent_end',
 {$ifdef alpha}
           { the follow is for the DEC Alpha }
           'frame',
-          'ent',
 {$endif alpha}
 {$ifdef ia64}
           'bundle',
@@ -176,7 +187,9 @@ interface
           'tempalloc',
           'marker',
           'varloc',
-          'seh_directive'
+          'seh_directive',
+          'jvar',
+          'jcatch'
           );
 
     type
@@ -193,7 +206,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 +249,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;
 
@@ -239,8 +265,10 @@ interface
         a new ait type!                                                              }
       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_regalloc, ait_tempalloc, ait_symbol_end 
+				   ,ait_ent, ait_ent_end, ait_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 +276,15 @@ 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,
+					 ait_ent, ait_ent_end,
 {$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 +317,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 +344,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',
@@ -392,6 +426,16 @@ interface
           procedure derefimpl;override;
        end;
 
+	   tai_ent = class(tai)
+	      Name : string;
+          Constructor Create (const ProcName : String);
+       end;
+
+       tai_ent_end = class(tai)
+	      Name : string;
+          Constructor Create (const ProcName : String);
+       end;
+
        tai_directive = class(tailineinfo)
           name : ansistring;
           directive : TAsmDirective;
@@ -723,6 +767,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;
@@ -1193,6 +1262,26 @@ implementation
         ppufile.putbyte(byte(directive));
       end;
 
+{****************************************************************************
+                               TAI_ENT / TAI_ENT_END
+ ****************************************************************************}
+
+    Constructor tai_ent.Create (const ProcName : String);
+
+    begin
+      Inherited Create;
+	  Name:=ProcName;
+      typ:=ait_ent;
+    end;
+
+    Constructor tai_ent_end.Create (const ProcName : String);
+
+    begin
+      Inherited Create;
+	  Name:=ProcName;
+      typ:=ait_ent_end;
+    end;
+
 
 {****************************************************************************
                                TAI_CONST
@@ -2036,8 +2125,6 @@ implementation
          is_jmp:=false;
          opcode:=op;
          ops:=0;
-         fillchar(condition,sizeof(condition),0);
-         fillchar(oper,sizeof(oper),0);
       end;
 
 
@@ -2232,6 +2319,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 +2637,7 @@ implementation
         ppufile.putbyte(byte(use_op));
       end;
 
+
 {****************************************************************************
                               tai_seh_directive
  ****************************************************************************}
@@ -2654,6 +2748,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/aggas.pas

@@ -644,7 +644,7 @@ implementation
       constdef : taiconst_type;
       s,t      : string;
       i,pos,l  : longint;
-      InlineLevel : longint;
+      InlineLevel : cardinal;
       last_align : longint;
       co       : comp;
       sin      : single;
@@ -1247,8 +1247,23 @@ implementation
                AsmWriteLn(#9'.thumb_func');
              end;
 {$endif arm}
-
-           ait_symbol_end :
+           ait_ent:
+             begin
+               AsmWrite(#9'.ent'#9);
+			   if replaceforbidden then
+                 AsmWriteLn(ReplaceForbiddenAsmSymbolChars(tai_ent(hp).Name))
+               else
+                 AsmWriteLn(tai_ent(hp).Name);
+             end;
+           ait_ent_end:
+             begin
+               AsmWrite(#9'.end'#9);
+			   if replaceforbidden then
+                 AsmWriteLn(ReplaceForbiddenAsmSymbolChars(tai_ent_end(hp).Name))
+               else
+  			     AsmWriteLn(tai_ent_end(hp).Name);
+             end;
+            ait_symbol_end :
              begin
                if tf_needs_symbol_size in target_info.flags then
                 begin
@@ -1516,12 +1531,12 @@ implementation
       i: longint;
     begin
 {$ifdef EXTDEBUG}
-      if assigned(current_module.mainsource) then
-       Comment(V_Debug,'Start writing gas-styled assembler output for '+current_module.mainsource^);
+      if current_module.mainsource<>'' then
+       Comment(V_Debug,'Start writing gas-styled assembler output for '+current_module.mainsource);
 {$endif}
 
-      if assigned(current_module.mainsource) then
-        n:=ExtractFileName(current_module.mainsource^)
+      if current_module.mainsource<>'' then
+        n:=ExtractFileName(current_module.mainsource)
       else
         n:=InputFileName;
 
@@ -1560,8 +1575,8 @@ implementation
 
       AsmLn;
 {$ifdef EXTDEBUG}
-      if assigned(current_module.mainsource) then
-       Comment(V_Debug,'Done writing gas-styled assembler output for '+current_module.mainsource^);
+      if current_module.mainsource<>'' then
+       Comment(V_Debug,'Done writing gas-styled assembler output for '+current_module.mainsource);
 {$endif EXTDEBUG}
     end;
 

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 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/alpha/aasmcpu.pas

@@ -39,11 +39,6 @@ unit aasmcpu;
         Constructor Create (GP : Tregister; Localsize : Longint; RA : TRegister; L : longint);
         end;
 
-      tai_ent = class(tai)
-        Name : string;
-        Constructor Create (const ProcName : String);
-        end;
-
 
       taicpu = class(tai_cpu_abstract_sym)
          constructor op_none(op : tasmop);
@@ -260,14 +255,6 @@ implementation
       LU:=L;
     end;
 
-    Constructor tai_ent.Create (const ProcName : String);
-
-    begin
-      Inherited Create;
-      typ:=ait_ent;
-      Name:=ProcName;
-    end;
-
     procedure InitAsm;
       begin
       end;

compiler/alpha/cpubase.pas

@@ -120,7 +120,8 @@ unit cpubase;
 
        { Defines the default address size for a processor, }
        OS_ADDR = OS_64;
-       { the natural int size for a processor,             }
+       { the natural int size for a processor,
+         has to match osuinttype/ossinttype as initialized in psystem }
        OS_INT = OS_64;
        { the maximum float size for a processor,           }
        OS_FLOAT = OS_F80;

compiler/aopt.pas

@@ -59,8 +59,11 @@ Unit aopt;
   Implementation
 
     uses
+      cutils,
       globtype, globals,
       verbose,
+      cpubase,
+      cgbase,
       aoptda,aoptcpu,aoptcpud;
 
     Constructor TAsmOptimizer.create(_AsmL: TAsmList);
@@ -110,79 +113,108 @@ Unit aopt;
     Procedure TAsmOptimizer.BuildLabelTableAndFixRegAlloc;
     { Builds a table with the locations of the labels in the TAsmList.       }
     { Also fixes some RegDeallocs like "# %eax released; push (%eax)"           }
-    Var p{, hp1, hp2}: tai;
-        {UsedRegs: TRegSet;}
+    Var p,hp1, hp2: tai;
+        Regs: TAllUsedRegs;
         LabelIdx : longint;
     Begin
-      {UsedRegs := [];}
+      CreateUsedRegs(Regs);
       With LabelInfo^ Do
-        If (LabelDif <> 0) Then
-          Begin
-            GetMem(LabelTable, LabelDif*SizeOf(TLabelTableItem));
-            FillChar(LabelTable^, LabelDif*SizeOf(TLabelTableItem), 0);
-            p := BlockStart;
-            While (P <> BlockEnd) Do
-              Begin
-                Case p.typ Of
-                  ait_Label:
-                    begin
-                      If tai_label(p).labsym.is_used and
-                         (tai_Label(p).labsym.labeltype=alt_jump) then
-                        begin
-                          LabelIdx:=tai_label(p).labsym.labelnr-LowLabel;
-                          if LabelIdx>int64(LabelDif) then
-                            internalerror(200604202);
-                          LabelTable^[LabelIdx].PaiObj := p;
-                        end;
-                    end;
-                  ait_regAlloc:
-                    begin
-                    {!!!!!!!!!
-                      if tai_regalloc(p).ratype=ra_alloc then
-                        Begin
-                          If Not(tai_regalloc(p).Reg in UsedRegs) Then
-                            UsedRegs := UsedRegs + [tai_regalloc(p).Reg]
-                          Else
-                            Begin
-                              hp1 := p;
-                              hp2 := nil;
-                              While GetLastInstruction(hp1, hp1) And
-                                    Not(RegInInstruction(tai_regalloc(p).Reg, hp1)) Do
-                                hp2:=hp1;
-                              If hp2<>nil Then
-                                Begin
-                                  hp1:=tai_regalloc.DeAlloc(tai_regalloc(p).Reg,hp2);
-                                  InsertLLItem(tai(hp2.previous), hp2, hp1);
-                                End;
-                            End;
-                        End
-                      else
-                        Begin
-                          UsedRegs := UsedRegs - [tai_regalloc(p).Reg];
-                          hp1 := p;
-                          hp2 := nil;
-                          While Not(FindRegAlloc(tai_regalloc(p).Reg, tai(hp1.Next))) And
-                                GetNextInstruction(hp1, hp1) And
-                                RegInInstruction(tai_regalloc(p).Reg, hp1) Do
-                            hp2 := hp1;
-                          If hp2 <> nil Then
-                            Begin
-                              hp1 := tai(p.previous);
-                              AsmL.Remove(p);
-                              InsertLLItem(hp2, tai(hp2.Next), p);
-                              p := hp1;
-                            End
-                        End
-                    };
-                    End
-                End;
-                P := tai(p.Next);
-                While Assigned(p) and
-                      (p <> blockend) and
-                      (p.typ in (SkipInstr - [ait_regalloc])) Do
-                  P := tai(P.Next)
+        begin
+          If (LabelDif <> 0) Then
+            Begin
+              GetMem(LabelTable, LabelDif*SizeOf(TLabelTableItem));
+              FillChar(LabelTable^, LabelDif*SizeOf(TLabelTableItem), 0);
+            end;
+          p := BlockStart;
+          While (P <> BlockEnd) Do
+            Begin
+              Case p.typ Of
+                ait_Label:
+                  begin
+                    If tai_label(p).labsym.is_used and
+                       (tai_Label(p).labsym.labeltype=alt_jump) then
+                      begin
+                        LabelIdx:=tai_label(p).labsym.labelnr-LowLabel;
+                        if LabelIdx>int64(LabelDif) then
+                          internalerror(200604202);
+                        LabelTable^[LabelIdx].PaiObj := p;
+                      end;
+                  end;
+                ait_regAlloc:
+                  begin
+                    if tai_regalloc(p).ratype=ra_alloc then
+                      Begin
+                        If Not(RegInUsedRegs(tai_regalloc(p).Reg,Regs)) Then
+                          IncludeRegInUsedRegs(tai_regalloc(p).Reg,Regs)
+                        Else
+                          Begin
+                            hp1 := tai(p.previous);
+{$ifdef DEBUG_OPTALLOC}
+                            AsmL.InsertAfter(tai_comment.Create(strpnew('Removed allocation of '+std_regname(tai_regalloc(p).Reg))),p);
+{$endif DEBUG_OPTALLOC}
+                            AsmL.remove(p);
+                            p.free;
+                            p := hp1;
+                            { not sure if this is useful, it even skips previous deallocs of the register (FK)
+                            hp1 := p;
+                            hp2 := nil;
+                            While GetLastInstruction(hp1, hp1) And
+                                  Not(RegInInstruction(tai_regalloc(p).Reg, hp1)) Do
+                              hp2:=hp1;
+                            If hp2<>nil Then
+                              Begin
+                                hp1:=tai_regalloc.DeAlloc(tai_regalloc(p).Reg,hp2);
+                                InsertLLItem(tai(hp2.previous), hp2, hp1);
+                              End;
+                            }
+                          End;
+                      End
+                    else if tai_regalloc(p).ratype=ra_dealloc then
+                      Begin
+                        ExcludeRegFromUsedRegs(tai_regalloc(p).Reg,Regs);
+                        hp1 := p;
+                        hp2 := nil;
+                        While Not(FindRegAlloc(tai_regalloc(p).Reg, tai(hp1.Next))) And
+                              GetNextInstruction(hp1, hp1) And
+                              RegInInstruction(tai_regalloc(p).Reg, hp1) Do
+                          hp2 := hp1;
+                        If hp2 <> nil Then
+                          Begin
+                            hp1 := tai(p.previous);
+{$ifdef DEBUG_OPTALLOC}
+                            AsmL.InsertAfter(tai_comment.Create(strpnew('Moved deallocation of '+std_regname(tai_regalloc(p).Reg))),p);
+{$endif DEBUG_OPTALLOC}
+                            AsmL.Remove(p);
+                            InsertLLItem(hp2, tai(hp2.Next), p);
+{$ifdef DEBUG_OPTALLOC}
+                            AsmL.InsertAfter(tai_comment.Create(strpnew('Moved deallocation of '+std_regname(tai_regalloc(p).Reg)+' here')),hp2);
+{$endif DEBUG_OPTALLOC}
+                            p := hp1;
+                          End
+                        else if findregalloc(tai_regalloc(p).reg, tai(p.next))
+                          and getnextinstruction(p,hp1) then
+                          begin
+                            hp1 := tai(p.previous);
+{$ifdef DEBUG_OPTALLOC}
+                            AsmL.InsertAfter(tai_comment.Create(strpnew('Removed deallocation of '+std_regname(tai_regalloc(p).Reg))),p);
+{$endif DEBUG_OPTALLOC}
+                            AsmL.remove(p);
+                            p.free;
+                            p := hp1;
+      //                      don't include here, since then the allocation will be removed when it's processed
+      //                      include(usedregs,supreg);
+                          end;
+                      End
+                  End
               End;
-          End
+              P := tai(p.Next);
+              While Assigned(p) and
+                    (p <> blockend) and
+                    (p.typ in (SkipInstr - [ait_regalloc])) Do
+                P := tai(P.Next)
+            End;
+        end;
+      ReleaseUsedRegs(Regs);
     End;
 
     procedure tasmoptimizer.clear;
@@ -197,6 +229,7 @@ Unit aopt;
         LabelInfo^.highlabel:=0;
       end;
 
+
     procedure tasmoptimizer.pass_1;
       begin
         findlohilabels;
@@ -260,9 +293,13 @@ Unit aopt;
           End;
       End;
 
+
     Destructor TAsmOptimizer.Destroy;
       Begin
-        Dispose(LabelInfo)
+        if assigned(LabelInfo^.LabelTable) then
+          Freemem(LabelInfo^.LabelTable);
+        Dispose(LabelInfo);
+        inherited Destroy;
       End;
 
 

compiler/aoptbase.pas

@@ -47,7 +47,7 @@ unit aoptbase;
         constructor create; virtual;
         destructor destroy;override;
         { returns true if register Reg is used by instruction p1 }
-        Function RegInInstruction(Reg: TRegister; p1: tai): Boolean;
+        Function RegInInstruction(Reg: TRegister; p1: tai): Boolean;virtual;
         { returns true if register Reg occurs in operand op }
         Function RegInOp(Reg: TRegister; const op: toper): Boolean;
         { returns true if register Reg is used in the reference Ref }
@@ -82,8 +82,8 @@ unit aoptbase;
         { returns whether P is a load constant instruction (load a constant }
         { into a register)                                                  }
         Function IsLoadConstReg(p: tai): Boolean; Virtual; Abstract;
-        { returns whether P is a store instruction (store contents from a }
-        { register to a memory location or to a (register) variable)      }
+        { returns whether P is a store instruction (store contents from a
+          register to a memory location or to a (register) variable)      }
         Function IsStoreRegMem(p: tai): Boolean; Virtual; Abstract;
 
         { create a paicpu Object that loads the contents of reg1 into reg2 }
@@ -129,7 +129,11 @@ unit aoptbase;
     Begin
       Case op.typ Of
         Top_Reg: RegInOp := Reg = op.reg;
-        Top_Ref: RegInOp := RegInRef(Reg, op.ref^)
+        Top_Ref: RegInOp := RegInRef(Reg, op.ref^);
+        {$ifdef arm}
+        Top_Shifterop: RegInOp := op.shifterop^.rs = Reg;
+        Top_RegSet: RegInOp := getsupreg(Reg) in op.regset^;
+        {$endif arm}
         Else RegInOp := False
       End
     End;
@@ -201,12 +205,12 @@ unit aoptbase;
       Current := Tai(Current.previous);
       While Assigned(Current) And
             (((Current.typ = ait_Marker) And
-              Not(Tai_Marker(Current).Kind in [mark_AsmBlockEnd,mark_NoPropInfoEnd])) or
+              Not(Tai_Marker(Current).Kind in [mark_AsmBlockEnd{,mark_NoPropInfoEnd}])) or
              (Current.typ In SkipInstr) or
              ((Current.typ = ait_label) And
               labelCanBeSkipped(Tai_Label(Current)))) Do
         Current := Tai(Current.previous);
-      If Assigned(Current) And
+{      If Assigned(Current) And
          (Current.typ = ait_Marker) And
          (Tai_Marker(Current).Kind = mark_NoPropInfoEnd) Then
         Begin
@@ -214,10 +218,10 @@ unit aoptbase;
                 ((Current.typ <> ait_Marker) Or
                  (Tai_Marker(Current).Kind <> mark_NoPropInfoStart)) Do
             Current := Tai(Current.previous);
-        End;
+        End; }
     Until Not(Assigned(Current)) Or
           (Current.typ <> ait_Marker) Or
-          (Tai_Marker(Current).Kind <> mark_NoPropInfoStart);
+          not(tai_Marker(current).Kind in [mark_NoPropInfoStart,mark_NoPropInfoEnd]);
     If Not(Assigned(Current)) or
        (Current.typ In SkipInstr) or
        ((Current.typ = ait_label) And

compiler/aoptobj.pas

@@ -61,7 +61,7 @@ Unit AoptObj;
       TRegArray = Array[byte] of tsuperregister;
 
 
-      TRegSet = Set of byte;
+      TRegSet = tcpuregisterset;
       { possible actions on an operand: read, write or modify (= read & write) }
       TOpAction = (OpAct_Read, OpAct_Write, OpAct_Modify, OpAct_Unknown);
 
@@ -164,17 +164,17 @@ Unit AoptObj;
           TInstrSinceLastMod);
         { destroy the contents of all registers }
         Procedure DestroyAllRegs(var InstrSinceLastMod: TInstrSinceLastMod);
-        { a register's contents are modified, but not destroyed (the new value }
-        { depends on the old one)                                              }
+        { a register's contents are modified, but not destroyed (the new value
+          depends on the old one)                                              }
         Procedure ModifyReg(reg: TRegister; var InstrSinceLastMod:
           TInstrSinceLastMod);
-        { an operand's contents are modified, but not destroyed (the new value }
-        { depends on the old one)                                              }
+        { an operand's contents are modified, but not destroyed (the new value
+          depends on the old one)                                              }
         Procedure ModifyOp(const oper: TOper; var InstrSinceLastMod:
           TInstrSinceLastMod);
 
-        { increase the write state of a register (call every time a register is }
-        { written to)                                                           }
+        { increase the write state of a register (call every time a register is
+          written to)                                                           }
         Procedure IncWState(Reg: TRegister);
         { increase the read state of a register (call every time a register is }
         { read from)                                                           }
@@ -262,11 +262,17 @@ Unit AoptObj;
 
         { processor independent methods }
 
+        Procedure CreateUsedRegs(var regs: TAllUsedRegs);
         Procedure ClearUsedRegs;
         Procedure UpdateUsedRegs(p : Tai);
         procedure UpdateUsedRegs(var Regs: TAllUsedRegs; p: Tai);
         Function CopyUsedRegs(var dest : TAllUsedRegs) : boolean;
         Procedure ReleaseUsedRegs(const regs : TAllUsedRegs);
+        Function RegInUsedRegs(reg : TRegister;regs : TAllUsedRegs) : boolean;
+        Procedure IncludeRegInUsedRegs(reg : TRegister;var regs : TAllUsedRegs);
+        Procedure ExcludeRegFromUsedRegs(reg: TRegister;var regs : TAllUsedRegs);
+
+        Function GetAllocationString(const regs : TAllUsedRegs) : string;
 
         { returns true if the label L is found between hp and the next }
         { instruction                                                  }
@@ -325,6 +331,7 @@ Unit AoptObj;
   Implementation
 
     uses
+      cutils,
       globals,
       verbose,
       procinfo;
@@ -352,6 +359,8 @@ Unit AoptObj;
     }
     Procedure TUsedRegs.Update(p: Tai);
       Begin
+        { this code is normally not used because updating the register allocation information is done in
+          TAOptObj.UpdateUsedRegs for speed reasons }
         repeat
           while assigned(p) and
                 ((p.typ in (SkipInstr - [ait_RegAlloc])) or
@@ -778,15 +787,12 @@ Unit AoptObj;
 
       Constructor TAoptObj.create(_AsmL: TAsmList; _BlockStart, _BlockEnd: Tai;
                                   _LabelInfo: PLabelInfo);
-      var
-        i : TRegisterType;
       Begin
         AsmL := _AsmL;
         BlockStart := _BlockStart;
         BlockEnd := _BlockEnd;
         LabelInfo := _LabelInfo;
-        for i:=low(TRegisterType) to high(TRegisterType) do
-          UsedRegs[i]:=TUsedRegs.Create(i);
+        CreateUsedRegs(UsedRegs);
       End;
 
       destructor TAOptObj.Destroy;
@@ -799,6 +805,15 @@ Unit AoptObj;
         end;
 
 
+      procedure TAOptObj.CreateUsedRegs(var regs: TAllUsedRegs);
+        var
+          i : TRegisterType;
+        begin
+          for i:=low(TRegisterType) to high(TRegisterType) do
+            Regs[i]:=TUsedRegs.Create(i);
+        end;
+
+
       procedure TAOptObj.ClearUsedRegs;
         var
           i : TRegisterType;
@@ -812,8 +827,31 @@ Unit AoptObj;
         var
           i : TRegisterType;
         begin
-          for i:=low(TRegisterType) to high(TRegisterType) do
-            UsedRegs[i].Update(p);
+          { this code is based on TUsedRegs.Update to avoid multiple passes through the asmlist,
+            the code is duplicated here }
+          repeat
+            while assigned(p) and
+                  ((p.typ in (SkipInstr - [ait_RegAlloc])) or
+                   ((p.typ = ait_label) and
+                    labelCanBeSkipped(tai_label(p))) or
+                   ((p.typ = ait_marker) and
+                    (tai_Marker(p).Kind in [mark_AsmBlockEnd,mark_NoLineInfoStart,mark_NoLineInfoEnd]))) do
+                 p := tai(p.next);
+            while assigned(p) and
+                  (p.typ=ait_RegAlloc) Do
+              begin
+                case tai_regalloc(p).ratype of
+                  ra_alloc :
+                    Include(UsedRegs[getregtype(tai_regalloc(p).reg)].UsedRegs, getsupreg(tai_regalloc(p).reg));
+                  ra_dealloc :
+                    Exclude(UsedRegs[getregtype(tai_regalloc(p).reg)].UsedRegs, getsupreg(tai_regalloc(p).reg));
+                end;
+                p := tai(p.next);
+              end;
+          until not(assigned(p)) or
+                (not(p.typ in SkipInstr) and
+                 not((p.typ = ait_label) and
+                     labelCanBeSkipped(tai_label(p))));
         end;
 
 
@@ -835,6 +873,7 @@ Unit AoptObj;
           dest[i]:=TUsedRegs.Create_Regset(i,UsedRegs[i].GetUsedRegs);
       end;
 
+
       procedure TAOptObj.ReleaseUsedRegs(const regs: TAllUsedRegs);
         var
           i : TRegisterType;
@@ -844,6 +883,38 @@ Unit AoptObj;
       end;
 
 
+      Function TAOptObj.RegInUsedRegs(reg : TRegister;regs : TAllUsedRegs) : boolean;
+      begin
+        result:=regs[getregtype(reg)].IsUsed(reg);
+      end;
+
+
+      procedure TAOptObj.IncludeRegInUsedRegs(reg: TRegister;
+       var regs: TAllUsedRegs);
+      begin
+        include(regs[getregtype(reg)].UsedRegs,getsupreg(Reg));
+      end;
+
+
+      procedure TAOptObj.ExcludeRegFromUsedRegs(reg: TRegister;
+       var regs: TAllUsedRegs);
+      begin
+        exclude(regs[getregtype(reg)].UsedRegs,getsupreg(Reg));
+      end;
+
+
+      function TAOptObj.GetAllocationString(const regs: TAllUsedRegs): string;
+      var
+        i : TRegisterType;
+        j : TSuperRegister;
+      begin
+        Result:='';
+        for i:=low(TRegisterType) to high(TRegisterType) do
+          for j in regs[i].UsedRegs do
+            Result:=Result+std_regname(newreg(i,j,R_SUBWHOLE))+' ';
+      end;
+
+
       Function TAOptObj.FindLabel(L: TasmLabel; Var hp: Tai): Boolean;
       Var TempP: Tai;
       Begin
@@ -938,9 +1009,9 @@ Unit AoptObj;
                   Not(Tai_Label(StartPai).labsym.Is_Used))) Do
             StartPai := Tai(StartPai.Next);
           If Assigned(StartPai) And
-             (StartPai.typ = ait_regAlloc) and (tai_regalloc(StartPai).ratype=ra_alloc) Then
+             (StartPai.typ = ait_regAlloc) Then
             Begin
-              if tai_regalloc(StartPai).Reg = Reg then
+              if (tai_regalloc(StartPai).ratype=ra_alloc) and (getsupreg(tai_regalloc(StartPai).Reg) = getsupreg(Reg)) then
                begin
                  FindRegAlloc:=true;
                  exit;
@@ -1046,11 +1117,11 @@ Unit AoptObj;
                    (assigned(taicpu(p1).oper[0]^.ref^.symbol)) and
                    (taicpu(p1).oper[0]^.ref^.symbol is TAsmLabel)) or
                   conditions_equal(taicpu(p1).condition,hp.condition)) or
-                 { the next instruction after the label where the jump hp arrives}
-                 { is the opposite of hp (so this one is never taken), but after }
-                 { that one there is a branch that will be taken, so perform a   }
-                 { little hack: set p1 equal to this instruction (that's what the}
-                 { last SkipLabels is for, only works with short bool evaluation)}
+                 { the next instruction after the label where the jump hp arrives
+                   is the opposite of hp (so this one is never taken), but after
+                   that one there is a branch that will be taken, so perform a
+                   little hack: set p1 equal to this instruction (that's what the
+                   last SkipLabels is for, only works with short bool evaluation)}
                  (conditions_equal(taicpu(p1).condition,inverse_cond(hp.condition)) and
                   SkipLabels(p1,p2) and
                   (p2.typ = ait_instruction) and
@@ -1123,7 +1194,14 @@ Unit AoptObj;
         ClearUsedRegs;
         while (p <> BlockEnd) Do
           begin
+            { I'am not sure why this is done, UsedRegs should reflect the register usage before the instruction
+              If an instruction needs the information of this, it can easily create a TempUsedRegs (FK)
             UpdateUsedRegs(tai(p.next));
+            }
+{$ifdef DEBUG_OPTALLOC}
+            if p.Typ=ait_instruction then
+              InsertLLItem(tai(p.Previous),p,tai_comment.create(strpnew(GetAllocationString(UsedRegs))));
+{$endif DEBUG_OPTALLOC}
             if PeepHoleOptPass1Cpu(p) then
               continue;
             case p.Typ Of
@@ -1143,7 +1221,8 @@ Unit AoptObj;
                          (assigned(taicpu(p).oper[0]^.ref^.symbol)) and
                          (taicpu(p).oper[0]^.ref^.symbol is TAsmLabel) then
                         begin
-                          while GetNextInstruction(p, hp1) and
+                          hp2:=p;
+                          while GetNextInstruction(hp2, hp1) and
                                 (hp1.typ <> ait_label) do
                             if not(hp1.typ in ([ait_label,ait_align]+skipinstr)) then
                               begin
@@ -1153,8 +1232,15 @@ Unit AoptObj;
                                    assigned(taicpu(hp1).oper[0]^.ref^.symbol) and
                                    (taicpu(hp1).oper[0]^.ref^.symbol is TAsmLabel) then
                                    TAsmLabel(taicpu(hp1).oper[0]^.ref^.symbol).decrefs;
-                                asml.remove(hp1);
-                                hp1.free;
+                                { don't kill start/end of assembler block,
+                                  no-line-info-start/end etc }
+                                if hp1.typ<>ait_marker then
+                                  begin
+                                    asml.remove(hp1);
+                                    hp1.free;
+                                  end
+                                else
+                                  hp2:=hp1;
                               end
                             else break;
                           end;

compiler/arm/aasmcpu.pas

@@ -567,10 +567,12 @@ implementation
     function taicpu.is_same_reg_move(regtype: Tregistertype):boolean;
       begin
         { allow the register allocator to remove unnecessary moves }
-        result:=(((opcode=A_MOV) and (regtype = R_INTREGISTER)) or
-                 ((opcode=A_MVF) and (regtype = R_FPUREGISTER) and (oppostfix in [PF_None,PF_D])) or
-                 (((opcode=A_FCPYS) or (opcode=A_FCPYD)) and (regtype = R_MMREGISTER))
+        result:=(
+                  ((opcode=A_MOV) and (regtype = R_INTREGISTER)) or
+                  ((opcode=A_MVF) and (regtype = R_FPUREGISTER)) or
+                  ((opcode in [A_FCPYS, A_FCPYD]) and (regtype = R_MMREGISTER))
                 ) and
+                (oppostfix in [PF_None,PF_D]) and
                 (condition=C_None) and
                 (ops=2) and
                 (oper[0]^.typ=top_reg) and
@@ -642,7 +644,7 @@ implementation
     function taicpu.spilling_get_operation_type(opnr: longint): topertype;
       begin
         case opcode of
-          A_ADC,A_ADD,A_AND,
+          A_ADC,A_ADD,A_AND,A_BIC,
           A_EOR,A_CLZ,
           A_LDR,A_LDRB,A_LDRBT,A_LDRH,A_LDRSB,
           A_LDRSH,A_LDRT,
@@ -671,7 +673,7 @@ implementation
               result:=operand_write
             else
               result:=operand_read;
-          A_BIC,A_BKPT,A_B,A_BL,A_BLX,A_BX,
+          A_BKPT,A_B,A_BL,A_BLX,A_BX,
           A_CMN,A_CMP,A_TEQ,A_TST,
           A_CMF,A_CMFE,A_WFS,A_CNF,
           A_FCMPS,A_FCMPD,A_FCMPES,A_FCMPED,A_FCMPEZS,A_FCMPEZD,
@@ -910,6 +912,12 @@ implementation
                     end;
                   inc(curinspos);
                 end;
+              ait_align:
+                begin
+                  { code is always 4 byte aligned, so we don't have to take care of .align 2 which would
+                    requires also incrementing curinspos by 1 }
+                  inc(curinspos,(tai_align(curtai).aligntype div 4));
+                end;
               ait_const:
                 begin
                   inc(curinspos);
@@ -939,6 +947,9 @@ implementation
               begin
                 penalty:=1;
                 hp:=tai(hp.next);
+                { skip register allocations and comments inserted by the optimizer }
+                while assigned(hp) and (hp.typ in [ait_comment,ait_regalloc]) do
+                  hp:=tai(hp.next);
                 while assigned(hp) and (hp.typ=ait_const) do
                   begin
                     inc(penalty);

compiler/arm/agarmgas.pas

@@ -153,7 +153,10 @@ unit agarmgas;
 
                      s:=s+gas_regname(index);
 
-                     if shiftmode<>SM_None then
+                     {RRX always rotates by 1 bit and does not take an imm}
+                     if shiftmode = SM_RRX then
+                       s:=s+', rrx'
+                     else if shiftmode <> SM_None then
                        s:=s+', '+gas_shiftmode2str[shiftmode]+' #'+tostr(shiftimm);
                   end
                 else if offset<>0 then
@@ -171,10 +174,6 @@ unit agarmgas;
         getreferencestring:=s;
       end;
 
-
-    const
-      shiftmode2str: array[tshiftmode] of string[3] = ('','lsl','lsr','asr','ror','rrx');
-
     function getopstr(const o:toper) : string;
       var
         hs : string;
@@ -186,10 +185,13 @@ unit agarmgas;
             getopstr:=gas_regname(o.reg);
           top_shifterop:
             begin
-              if (o.shifterop^.rs<>NR_NO) and (o.shifterop^.shiftimm=0) then
-                getopstr:=shiftmode2str[o.shifterop^.shiftmode]+' '+gas_regname(o.shifterop^.rs)
+              {RRX is special, it only rotates by 1 and does not take any shiftervalue}
+              if o.shifterop^.shiftmode=SM_RRX then
+                getopstr:='rrx'
+              else if (o.shifterop^.rs<>NR_NO) and (o.shifterop^.shiftimm=0) then
+                getopstr:=gas_shiftmode2str[o.shifterop^.shiftmode]+' '+gas_regname(o.shifterop^.rs)
               else if (o.shifterop^.rs=NR_NO) then
-                getopstr:=shiftmode2str[o.shifterop^.shiftmode]+' #'+tostr(o.shifterop^.shiftimm)
+                getopstr:=gas_shiftmode2str[o.shifterop^.shiftmode]+' #'+tostr(o.shifterop^.shiftimm)
               else internalerror(200308282);
             end;
           top_const:

compiler/arm/aoptcpu.pas

@@ -28,13 +28,20 @@ Unit aoptcpu;
 
 Interface
 
-uses cpubase, aasmtai, aopt, aoptcpub;
+uses cgbase, cpubase, aasmtai, aopt, aoptcpub, aoptobj;
 
 Type
+
+  { TCpuAsmOptimizer }
+
   TCpuAsmOptimizer = class(TAsmOptimizer)
     { uses the same constructor as TAopObj }
     function PeepHoleOptPass1Cpu(var p: tai): boolean; override;
     procedure PeepHoleOptPass2;override;
+    Function RegInInstruction(Reg: TRegister; p1: tai): Boolean;override;
+    procedure RemoveSuperfluousMove(const p: tai; movp: tai; const optimizer: string);
+    function RegUsedAfterInstruction(reg: Tregister; p: tai;
+                                     var AllUsedRegs: TAllUsedRegs): Boolean;
   End;
 
   TCpuPreRegallocScheduler = class(TAsmOptimizer)
@@ -51,7 +58,7 @@ Implementation
   uses
     cutils,
     verbose,
-    cgbase,cgutils,
+    cgutils,
     aasmbase,aasmdata,aasmcpu;
 
   function CanBeCond(p : tai) : boolean;
@@ -59,6 +66,7 @@ Implementation
       result:=
         (p.typ=ait_instruction) and
         (taicpu(p).condition=C_None) and
+        (taicpu(p).opcode<>A_PLD) and
         ((taicpu(p).opcode<>A_BLX) or
          (taicpu(p).oper[0]^.typ=top_reg));
     end;
@@ -87,12 +95,30 @@ Implementation
       ((postfix = []) or (taicpu(instr).oppostfix in postfix));
   end;
 
+  function MatchOperand(const oper1: TOper; const oper2: TOper): boolean; inline;
+    begin
+      result := oper1.typ = oper2.typ;
+
+      if result then
+        case oper1.typ of
+          top_const:
+            Result:=oper1.val = oper2.val;
+          top_reg:
+            Result:=oper1.reg = oper2.reg;
+          top_conditioncode:
+            Result:=oper1.cc = oper2.cc;
+          top_ref:
+            Result:=RefsEqual(oper1.ref^, oper2.ref^);
+          else Result:=false;
+        end
+    end;
+
   function MatchOperand(const oper: TOper; const reg: TRegister): boolean; inline;
     begin
       result := (oper.typ = top_reg) and (oper.reg = reg);
     end;
 
-  procedure RemoveRedundantMove(const cmpp: tai; movp: tai; asml: TAsmList) ;
+  procedure RemoveRedundantMove(const cmpp: tai; movp: tai; asml: TAsmList);
     begin
       if (taicpu(movp).condition = C_EQ) and
          (taicpu(cmpp).oper[0]^.reg = taicpu(movp).oper[0]^.reg) and
@@ -104,10 +130,146 @@ Implementation
       end;
     end;
 
+  function regLoadedWithNewValue(reg: tregister; hp: tai): boolean;
+  var
+    p: taicpu;
+  begin
+    p := taicpu(hp);
+    regLoadedWithNewValue := false;
+    if not ((assigned(hp)) and (hp.typ = ait_instruction)) then
+      exit;
+
+    case p.opcode of
+      { These operands do not write into a register at all }
+      A_CMP, A_CMN, A_TST, A_TEQ, A_B, A_BL, A_BX, A_BLX, A_SWI, A_MSR, A_PLD:
+        exit;
+      {Take care of post/preincremented store and loads, they will change their base register}
+      A_STR, A_LDR:
+        regLoadedWithNewValue :=
+          (taicpu(p).oper[1]^.typ=top_ref) and
+          (taicpu(p).oper[1]^.ref^.addressmode in [AM_PREINDEXED,AM_POSTINDEXED]) and
+          (taicpu(p).oper[1]^.ref^.base = reg);
+      { These four are writing into the first 2 register, UMLAL and SMLAL will also read from them }
+      A_UMLAL, A_UMULL, A_SMLAL, A_SMULL:
+        regLoadedWithNewValue :=
+          (p.oper[1]^.typ = top_reg) and
+          (p.oper[1]^.reg = reg);
+      {Loads to oper2 from coprocessor}
+      {
+      MCR/MRC is currently not supported in FPC
+      A_MRC:
+        regLoadedWithNewValue :=
+          (p.oper[2]^.typ = top_reg) and
+          (p.oper[2]^.reg = reg);
+      }
+      {Loads to all register in the registerset}
+      A_LDM:
+        regLoadedWithNewValue := (getsupreg(reg) in p.oper[1]^.regset^);
+    end;
+
+    if regLoadedWithNewValue then
+      exit;
+
+    case p.oper[0]^.typ of
+      {This is the case}
+      top_reg:
+        regLoadedWithNewValue := (p.oper[0]^.reg = reg);
+      {LDM/STM might write a new value to their index register}
+      top_ref:
+        regLoadedWithNewValue :=
+          (taicpu(p).oper[0]^.ref^.addressmode in [AM_PREINDEXED,AM_POSTINDEXED]) and
+          (taicpu(p).oper[0]^.ref^.base = reg);
+    end;
+  end;
+
+  function instructionLoadsFromReg(const reg: TRegister; const hp: tai): boolean;
+  var
+    p: taicpu;
+    i: longint;
+  begin
+    instructionLoadsFromReg := false;
+    if not (assigned(hp) and (hp.typ = ait_instruction)) then
+      exit;
+    p:=taicpu(hp);
+
+    i:=1;
+    {For these instructions we have to start on oper[0]}
+    if (p.opcode in [A_STR, A_LDM, A_STM, A_PLD,
+                        A_CMP, A_CMN, A_TST, A_TEQ,
+                        A_B, A_BL, A_BX, A_BLX,
+                        A_SMLAL, A_UMLAL]) then i:=0;
+
+    while(i<p.ops) do
+      begin
+        case p.oper[I]^.typ of
+          top_reg:
+            instructionLoadsFromReg := p.oper[I]^.reg = reg;
+          top_regset:
+            instructionLoadsFromReg := (getsupreg(reg) in p.oper[I]^.regset^);
+          top_shifterop:
+            instructionLoadsFromReg := p.oper[I]^.shifterop^.rs = reg;
+          top_ref:
+            instructionLoadsFromReg :=
+              (p.oper[I]^.ref^.base = reg) or
+              (p.oper[I]^.ref^.index = reg);
+        end;
+        if instructionLoadsFromReg then exit; {Bailout if we found something}
+        Inc(I);
+      end;
+  end;
+
+  function TCpuAsmOptimizer.RegUsedAfterInstruction(reg: Tregister; p: tai;
+    var AllUsedRegs: TAllUsedRegs): Boolean;
+    begin
+      AllUsedRegs[getregtype(reg)].Update(tai(p.Next));
+      RegUsedAfterInstruction :=
+        AllUsedRegs[getregtype(reg)].IsUsed(reg) and
+        not(regLoadedWithNewValue(reg,p)) and
+        (
+          not(GetNextInstruction(p,p)) or
+          instructionLoadsFromReg(reg,p) or
+          not(regLoadedWithNewValue(reg,p))
+        );
+    end;
+
+  procedure TCpuAsmOptimizer.RemoveSuperfluousMove(const p: tai; movp: tai; const optimizer: string);
+    var
+      TmpUsedRegs: TAllUsedRegs;
+    begin
+      if MatchInstruction(movp, A_MOV, [taicpu(p).condition], [PF_None]) and
+         (taicpu(movp).ops=2) and {We can't optimize if there is a shiftop}
+         MatchOperand(taicpu(movp).oper[1]^, taicpu(p).oper[0]^.reg) and
+         {There is a special requirement for MUL and MLA, oper[0] and oper[1] are not allowed to be the same}
+         not (
+           (taicpu(p).opcode in [A_MLA, A_MUL]) and
+           (taicpu(p).oper[1]^.reg = taicpu(movp).oper[0]^.reg)
+         ) then
+        begin
+          CopyUsedRegs(TmpUsedRegs);
+          UpdateUsedRegs(TmpUsedRegs, tai(p.next));
+          if not(RegUsedAfterInstruction(taicpu(p).oper[0]^.reg,movp,TmpUsedRegs)) then
+            begin
+              asml.insertbefore(tai_comment.Create(strpnew('Peephole '+optimizer+' removed superfluous mov')), movp);
+              taicpu(p).loadreg(0,taicpu(movp).oper[0]^.reg);
+              asml.remove(movp);
+              movp.free;
+            end;
+          ReleaseUsedRegs(TmpUsedRegs);
+        end;
+    end;
+
   function TCpuAsmOptimizer.PeepHoleOptPass1Cpu(var p: tai): boolean;
     var
       hp1,hp2: tai;
       i: longint;
+      TmpUsedRegs: TAllUsedRegs;
+      tempop: tasmop;
+
+    function IsPowerOf2(const value: DWord): boolean; inline;
+      begin
+        Result:=(value and (value - 1)) = 0;
+      end;
+
     begin
       result := false;
       case p.typ of
@@ -155,6 +317,7 @@ Implementation
                       mov reg2,reg1
                     }
                     if (taicpu(p).oper[1]^.ref^.addressmode=AM_OFFSET) and
+                       (taicpu(p).oppostfix=PF_None) and
                        GetNextInstruction(p,hp1) and
                        MatchInstruction(hp1, A_LDR, [taicpu(p).condition, C_None], [PF_None]) and
                        RefsEqual(taicpu(p).oper[1]^.ref^,taicpu(hp1).oper[1]^.ref^) and
@@ -162,15 +325,16 @@ Implementation
                       begin
                         if taicpu(hp1).oper[0]^.reg=taicpu(p).oper[0]^.reg then
                           begin
+                            asml.insertbefore(tai_comment.Create(strpnew('Peephole StrLdr2StrMov 1 done')), hp1);
                             asml.remove(hp1);
-                            hp1.free;
+                            hp1.free;                            
                           end
                         else
                           begin
-                            asml.insertbefore(tai_comment.Create(strpnew('Peephole StrLdr2StrMov done')), hp1);
                             taicpu(hp1).opcode:=A_MOV;
                             taicpu(hp1).oppostfix:=PF_None;
                             taicpu(hp1).loadreg(1,taicpu(p).oper[0]^.reg);
+                            asml.insertbefore(tai_comment.Create(strpnew('Peephole StrLdr2StrMov 2 done')), hp1);
                           end;
                         result := true;
                       end;
@@ -186,7 +350,7 @@ Implementation
                     }
                     if (taicpu(p).oper[1]^.ref^.addressmode=AM_OFFSET) and
                        GetNextInstruction(p,hp1) and
-                       MatchInstruction(hp1, A_LDR, [taicpu(p).condition, C_None], [PF_None]) and
+                       MatchInstruction(hp1, A_LDR, [taicpu(p).condition, C_None], [taicpu(p).oppostfix]) and
                        RefsEqual(taicpu(p).oper[1]^.ref^,taicpu(hp1).oper[1]^.ref^) and
                        (taicpu(p).oper[0]^.reg<>taicpu(hp1).oper[1]^.ref^.index) and
                        (taicpu(p).oper[0]^.reg<>taicpu(hp1).oper[1]^.ref^.base) and
@@ -207,6 +371,21 @@ Implementation
                           end;
                         result := true;
                       end;
+                    { Remove superfluous mov after ldr
+                      changes
+                      ldr reg1, ref
+                      mov reg2, reg1
+                      to
+                      ldr reg2, ref
+
+                      conditions are:
+                        * reg1 must be released after mov
+                        * mov can not contain shifterops
+                        * ldr+mov have the same conditions
+                        * mov does not set flags
+                    }
+                    if GetNextInstruction(p, hp1) then
+                      RemoveSuperfluousMove(p, hp1, 'LdrMov2Ldr');
                   end;
                 A_MOV:
                   begin
@@ -225,40 +404,145 @@ Implementation
                        MatchOperand(taicpu(hp1).oper[0]^, taicpu(p).oper[0]^.reg) and
                        MatchOperand(taicpu(hp1).oper[1]^, taicpu(p).oper[0]^.reg) and
                        (taicpu(hp1).oper[2]^.typ = top_shifterop) and
-                       (taicpu(hp1).oper[2]^.shifterop^.rs = NR_NO) and
-                       (taicpu(p).oper[2]^.shifterop^.shiftmode=taicpu(hp1).oper[2]^.shifterop^.shiftmode) then
+                       (taicpu(hp1).oper[2]^.shifterop^.rs = NR_NO) then
                       begin
-                        inc(taicpu(p).oper[2]^.shifterop^.shiftimm,taicpu(hp1).oper[2]^.shifterop^.shiftimm);
-                        { avoid overflows }
-                        if taicpu(p).oper[2]^.shifterop^.shiftimm>31 then
-                          case taicpu(p).oper[2]^.shifterop^.shiftmode of
-                            SM_ROR:
-                              taicpu(p).oper[2]^.shifterop^.shiftimm:=taicpu(p).oper[2]^.shifterop^.shiftimm and 31;
-                            SM_ASR:
-                              taicpu(p).oper[2]^.shifterop^.shiftimm:=31;
-                            SM_LSR,
-                            SM_LSL:
+                        { fold
+                          mov reg1,reg0, lsl 16
+                          mov reg1,reg1, lsr 16
+                          strh reg1, ...
+                          dealloc reg1
+                          to
+                          strh reg1, ...
+                          dealloc reg1
+                        }
+                        if (taicpu(p).oper[2]^.shifterop^.shiftmode=SM_LSL) and
+                          (taicpu(p).oper[2]^.shifterop^.shiftimm=16) and
+                          (taicpu(hp1).oper[2]^.shifterop^.shiftmode in [SM_LSR,SM_ASR]) and
+                          (taicpu(hp1).oper[2]^.shifterop^.shiftimm=16) and
+                          getnextinstruction(hp1,hp2) and
+                          MatchInstruction(hp2, A_STR, [taicpu(p).condition], [PF_H]) and
+                          MatchOperand(taicpu(hp2).oper[0]^, taicpu(p).oper[0]^.reg) then
+                          begin
+                            CopyUsedRegs(TmpUsedRegs);
+                            UpdateUsedRegs(TmpUsedRegs, tai(p.next));
+                            UpdateUsedRegs(TmpUsedRegs, tai(hp1.next));
+                            if not(RegUsedAfterInstruction(taicpu(p).oper[0]^.reg,hp2,TmpUsedRegs)) then
                               begin
-                                hp1:=taicpu.op_reg_const(A_MOV,taicpu(p).oper[0]^.reg,0);
-                                InsertLLItem(p.previous, p.next, hp1);
+                                asml.insertbefore(tai_comment.Create(strpnew('Peephole optimizer removed superfluous 16 Bit zero extension')), hp1);
+                                taicpu(hp2).loadreg(0,taicpu(p).oper[1]^.reg);
+                                asml.remove(p);
+                                asml.remove(hp1);
                                 p.free;
-                                p:=hp1;
+                                hp1.free;
+                                p:=hp2;
+                              end;
+                            ReleaseUsedRegs(TmpUsedRegs);
+                          end
+                        { fold
+                          mov reg1,reg0, shift imm1
+                          mov reg1,reg1, shift imm2
+                          to
+                          mov reg1,reg0, shift imm1+imm2
+                        }
+                        else if (taicpu(p).oper[2]^.shifterop^.shiftmode=taicpu(hp1).oper[2]^.shifterop^.shiftmode) then
+                          begin
+                            inc(taicpu(p).oper[2]^.shifterop^.shiftimm,taicpu(hp1).oper[2]^.shifterop^.shiftimm);
+                            { avoid overflows }
+                            if taicpu(p).oper[2]^.shifterop^.shiftimm>31 then
+                              case taicpu(p).oper[2]^.shifterop^.shiftmode of
+                                SM_ROR:
+                                  taicpu(p).oper[2]^.shifterop^.shiftimm:=taicpu(p).oper[2]^.shifterop^.shiftimm and 31;
+                                SM_ASR:
+                                  taicpu(p).oper[2]^.shifterop^.shiftimm:=31;
+                                SM_LSR,
+                                SM_LSL:
+                                  begin
+                                    hp1:=taicpu.op_reg_const(A_MOV,taicpu(p).oper[0]^.reg,0);
+                                    InsertLLItem(p.previous, p.next, hp1);
+                                    p.free;
+                                    p:=hp1;
+                                  end;
+                                else
+                                  internalerror(2008072803);
                               end;
-                            else
-                              internalerror(2008072803);
+                            asml.insertbefore(tai_comment.Create(strpnew('Peephole ShiftShift2Shift done')), p);
+                            asml.remove(hp1);
+                            hp1.free;
+                            result := true;
                           end;
-                        asml.insertbefore(tai_comment.Create(strpnew('Peephole ShiftShift2Shift done')), p);
+                      end;
+                    { Change the common
+                      mov r0, r0, lsr #24
+                      and r0, r0, #255
+
+                      and remove the superfluous and
+
+                      This could be extended to handle more cases.
+                    }
+                    if (taicpu(p).ops=3) and
+                       (taicpu(p).oper[2]^.typ = top_shifterop) and
+                       (taicpu(p).oper[2]^.shifterop^.rs = NR_NO) and
+                       (taicpu(p).oper[2]^.shifterop^.shiftmode = SM_LSR) and
+                       (taicpu(p).oper[2]^.shifterop^.shiftimm >= 24 ) and
+                       getnextinstruction(p,hp1) and
+                       MatchInstruction(hp1, A_AND, [taicpu(p).condition], [taicpu(p).oppostfix]) and
+                       (taicpu(hp1).ops=3) and
+                       MatchOperand(taicpu(p).oper[0]^, taicpu(hp1).oper[0]^) and
+                       MatchOperand(taicpu(p).oper[0]^, taicpu(hp1).oper[1]^) and
+                       (taicpu(hp1).oper[2]^.typ = top_const) and
+                       { Check if the AND actually would only mask out bits beeing already zero because of the shift
+                         For LSR #25 and an AndConst of 255 that whould go like this:
+                         255 and ((2 shl (32-25))-1)
+                         which results in 127, which is one less a power-of-2, meaning all lower bits are set.
+
+                         LSR #25 and AndConst of 254:
+                         254 and ((2 shl (32-25))-1) = 126 -> lowest bit is clear, so we can't remove it.
+                       }
+                       ispowerof2((taicpu(hp1).oper[2]^.val and ((2 shl (32-taicpu(p).oper[2]^.shifterop^.shiftimm))-1))+1) then
+                      begin
+                        asml.insertbefore(tai_comment.Create(strpnew('Peephole LsrAnd2Lsr done')), hp1);
                         asml.remove(hp1);
                         hp1.free;
-                        result := true;
                       end;
 
+                    { 
+                      This changes the very common 
+                      mov r0, #0
+                      str r0, [...]
+                      mov r0, #0
+                      str r0, [...]
+
+                      and removes all superfluous mov instructions
+                    }
+                    if (taicpu(p).ops = 2) and
+                       (taicpu(p).oper[1]^.typ = top_const) and
+                       GetNextInstruction(p,hp1) then
+                      begin
+                        while MatchInstruction(hp1, A_STR, [taicpu(p).condition], []) and
+                              MatchOperand(taicpu(p).oper[0]^, taicpu(hp1).oper[0]^) and
+                              GetNextInstruction(hp1, hp2) and
+                              MatchInstruction(hp2, A_MOV, [taicpu(p).condition], [PF_None]) and
+                              (taicpu(hp2).ops = 2) and
+                              MatchOperand(taicpu(hp2).oper[0]^, taicpu(p).oper[0]^) and
+                              MatchOperand(taicpu(hp2).oper[1]^, taicpu(p).oper[1]^) do
+                          begin
+                            asml.insertbefore(tai_comment.Create(strpnew('Peephole MovStrMov done')), hp2);
+                            GetNextInstruction(hp2,hp1);
+                            asml.remove(hp2);
+                            hp2.free;
+                            if not assigned(hp1) then break;
+                          end;
+                      end;
                     {
                       change
                       mov r1, r0
                       add r1, r1, #1
                       to
                       add r1, r0, #1
+
+                      Todo: Make it work for mov+cmp too
+
+                      CAUTION! If this one is successful p might not be a mov instruction anymore!
                     }
                     if (taicpu(p).ops = 2) and
                        (taicpu(p).oper[1]^.typ = top_reg) and
@@ -266,11 +550,13 @@ Implementation
                        GetNextInstruction(p, hp1) and
                        (tai(hp1).typ = ait_instruction) and
                        (taicpu(hp1).opcode in [A_ADD, A_ADC, A_RSB, A_RSC, A_SUB, A_SBC,
-                                               A_AND, A_BIC, A_EOR, A_ORR]) and
+                                               A_AND, A_BIC, A_EOR, A_ORR, A_MOV, A_MVN]) and
+                       {MOV and MVN might only have 2 ops}
+                       (taicpu(hp1).ops = 3) and
                        (taicpu(hp1).condition in [C_NONE, taicpu(hp1).condition]) and
                        MatchOperand(taicpu(p).oper[0]^, taicpu(hp1).oper[0]^.reg) and
                        (taicpu(hp1).oper[1]^.typ = top_reg) and
-                       (taicpu(hp1).oper[2]^.typ in [top_reg, top_const]) then
+                       (taicpu(hp1).oper[2]^.typ in [top_reg, top_const, top_shifterop]) then
                       begin
                       { When we get here we still don't know if the registers match}
                         for I:=1 to 2 do
@@ -281,7 +567,7 @@ Implementation
                           }
                           if MatchOperand(taicpu(p).oper[0]^, taicpu(hp1).oper[I]^.reg) then
                             begin
-                              asml.insertbefore(tai_comment.Create(strpnew('Peephole RedundantMovProcess done ')), hp1);
+                              asml.insertbefore(tai_comment.Create(strpnew('Peephole RedundantMovProcess done')), hp1);
                               taicpu(hp1).oper[I]^.reg := taicpu(p).oper[1]^.reg;
                               if p<>hp1 then
                               begin
@@ -291,8 +577,91 @@ Implementation
                               end;
                             end;
                       end;
+                    { This folds shifterops into following instructions
+                      mov r0, r1, lsl #8
+                      add r2, r3, r0
+
+                      to
+
+                      add r2, r3, r1, lsl #8
+                      CAUTION! If this one is successful p might not be a mov instruction anymore!
+                    }
+                    if (taicpu(p).opcode = A_MOV) and
+                       (taicpu(p).ops = 3) and
+                       (taicpu(p).oper[1]^.typ = top_reg) and
+                       (taicpu(p).oper[2]^.typ = top_shifterop) and
+                       (taicpu(p).oppostfix = PF_NONE) and
+                       GetNextInstruction(p, hp1) and
+                       (tai(hp1).typ = ait_instruction) and
+                       (taicpu(hp1).ops = 3) and {Currently we can't fold into another shifterop}
+                       (taicpu(hp1).oper[2]^.typ = top_reg) and
+                       (taicpu(hp1).oppostfix = PF_NONE) and
+                       (taicpu(hp1).condition = taicpu(p).condition) and
+                       (taicpu(hp1).opcode in [A_ADD, A_ADC, A_RSB, A_RSC, A_SUB, A_SBC,
+                                               A_AND, A_BIC, A_EOR, A_ORR, A_TEQ, A_TST]) and
+                       (
+                         {Only ONE of the two src operands is allowed to match}
+                         MatchOperand(taicpu(p).oper[0]^, taicpu(hp1).oper[1]^) xor
+                         MatchOperand(taicpu(p).oper[0]^, taicpu(hp1).oper[2]^)
+                       ) then
+                      begin
+                        CopyUsedRegs(TmpUsedRegs);
+                        UpdateUsedRegs(TmpUsedRegs, tai(p.next));
+                        if not(RegUsedAfterInstruction(taicpu(p).oper[0]^.reg,hp1,TmpUsedRegs)) then
+                          for I:=1 to 2 do
+                            if MatchOperand(taicpu(p).oper[0]^, taicpu(hp1).oper[I]^.reg) then
+                              begin
+                                if I = 1 then
+                                  begin
+                                    {The SUB operators need to be changed when we swap parameters}
+                                    case taicpu(hp1).opcode of
+                                      A_SUB: tempop:=A_RSB;
+                                      A_SBC: tempop:=A_RSC;
+                                      A_RSB: tempop:=A_SUB;
+                                      A_RSC: tempop:=A_SBC;
+                                      else tempop:=taicpu(hp1).opcode;
+                                    end;
+                                    hp2:=taicpu.op_reg_reg_reg_shifterop(tempop,
+                                         taicpu(hp1).oper[0]^.reg, taicpu(hp1).oper[2]^.reg,
+                                         taicpu(p).oper[1]^.reg, taicpu(p).oper[2]^.shifterop^);
+                                  end
+                                else
+                                  hp2:=taicpu.op_reg_reg_reg_shifterop(taicpu(hp1).opcode,
+                                       taicpu(hp1).oper[0]^.reg, taicpu(hp1).oper[1]^.reg,
+                                       taicpu(p).oper[1]^.reg, taicpu(p).oper[2]^.shifterop^);
+                                asml.insertbefore(hp2, p);
+                                asml.remove(p);
+                                asml.remove(hp1);
+                                p.free;
+                                hp1.free;
+                                p:=hp2;
+                                GetNextInstruction(p,hp1);
+                                asml.insertbefore(tai_comment.Create(strpnew('Peephole FoldShiftProcess done')), p);
+                                break;
+                              end;
+                        ReleaseUsedRegs(TmpUsedRegs);
+                      end;
+
+                    {
+                      Often we see shifts and then a superfluous mov to another register
+                      In the future this might be handled in RedundantMovProcess when it uses RegisterTracking
+                    }
+                    if (taicpu(p).opcode = A_MOV) and 
+                        GetNextInstruction(p, hp1) then
+                      RemoveSuperfluousMove(p, hp1, 'MovMov2Mov');
                   end;
-                A_AND:
+                A_ADD,
+                A_ADC,
+                A_RSB,
+                A_RSC,
+                A_SUB,
+                A_SBC,
+                A_AND,
+                A_BIC,
+                A_EOR,
+                A_ORR,
+                A_MLA,
+                A_MUL:
                   begin
                     {
                       change
@@ -301,7 +670,8 @@ Implementation
                       to
                       and reg2,reg1,(const1 and const2)
                     }
-                    if (taicpu(p).oper[1]^.typ = top_reg) and
+                    if (taicpu(p).opcode = A_AND) and
+                       (taicpu(p).oper[1]^.typ = top_reg) and
                        (taicpu(p).oper[2]^.typ = top_const) and
                        GetNextInstruction(p, hp1) and
                        MatchInstruction(hp1, A_AND, [taicpu(p).condition], [PF_None]) and
@@ -315,6 +685,15 @@ Implementation
                         asml.remove(hp1);
                         hp1.free;
                       end;
+                    {
+                      change
+                      add reg1, ...
+                      mov reg2, reg1
+                      to
+                      add reg2, ...
+                    }
+                    if GetNextInstruction(p, hp1) then
+                      RemoveSuperfluousMove(p, hp1, 'DataMov2Data');
                   end;
                 A_CMP:
                   begin
@@ -524,6 +903,14 @@ Implementation
         end;
     end;
 
+  function TCpuAsmOptimizer.RegInInstruction(Reg: TRegister; p1: tai): Boolean;
+    begin
+      If (p1.typ = ait_instruction) and (taicpu(p1).opcode=A_BL) then
+        Result:=true
+      else
+        Result:=inherited RegInInstruction(Reg, p1);
+    end;
+
   const
     { set of opcode which might or do write to memory }
     { TODO : extend armins.dat to contain r/w info }

compiler/arm/armatt.inc

@@ -179,15 +179,106 @@
 'fuitos',
 'fmdrr',
 'fmrrd',
+'bfc',
+'bfi',
+'clrex',
+'ldrex',
+'ldrexb',
+'ldrexd',
+'ldrexh',
+'mls',
+'pkh',
+'pli',
+'qadd16',
+'qadd8',
+'qasx',
+'qsax',
+'qsub16',
+'qsub8',
+'rbit',
+'rev',
+'rev16',
+'revsh',
+'sadd16',
+'sadd8',
+'sasx',
+'sbfx',
+'sel',
+'setend',
+'sev',
+'shadd16',
+'shadd8',
+'shasx',
+'shsax',
+'shsub16',
+'shsub8',
+'smlad',
+'smlald',
+'smlsd',
+'smlsld',
+'smmla',
+'smmls',
+'smmul',
+'smuad',
+'smusd',
+'srs',
+'ssat',
+'ssat16',
+'ssax',
+'ssub16',
+'ssub8',
+'strex',
+'strexb',
+'strexd',
+'strexh',
+'sxtab',
+'sxtab16',
+'sxtah',
+'sxtb',
+'sxtb16',
+'sxth',
+'uadd16',
+'uadd8',
+'uasx',
+'ubfx',
+'uhadd16',
+'uhadd8',
+'uhasx',
+'uhsax',
+'uhsub16',
+'uhsub8',
+'umaal',
+'uqadd16',
+'uqadd8',
+'uqasx',
+'uqsax',
+'uqsub16',
+'uqsub8',
+'uqsad8',
+'uqsada8',
+'usat',
+'usat16',
+'usax',
+'usub16',
+'usub8',
+'uxtab',
+'uxtab16',
+'uxtah',
+'uxtb',
+'uxtb16',
+'uxth',
+'wfe',
+'wfi',
+'yield',
 'asr',
 'lsr',
 'lsl',
+'pop',
+'push',
 'ror',
 'sdiv',
 'udiv',
 'movt',
-'ldrex',
-'strex',
 'it',
 'ite',
 'itt',

compiler/arm/armatts.inc

@@ -204,5 +204,96 @@ attsufNONE,
 attsufNONE,
 attsufNONE,
 attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
+attsufNONE,
 attsufNONE
 );

compiler/arm/armins.dat

@@ -574,6 +574,132 @@ reg32,reg32,reg32,reg32  \x16\x00\x80\x90		 ARM7
 
 [FMRRDcc]
 
+; ARMv6
+
+[BFCcc]
+
+[BFIcc]
+
+[CLREX]
+
+[LDREXcc]
+[LDREXBcc]
+[LDREXDcc]
+[LDREXHcc]
+
+[MLScc]
+
+[PKHcc]
+
+[PLI]
+
+[QADD16cc]
+[QADD8cc]
+[QASXcc]
+[QSAXcc]
+[QSUB16cc]
+[QSUB8cc]
+
+[RBITcc]
+
+[REVcc]
+[REV16cc]
+[REVSHcc]
+
+[SADD16cc]
+[SADD8cc]
+[SASXcc]
+
+[SBFXcc]
+
+[SELcc]
+
+[SETEND]
+
+[SEVcc]
+
+[SHADD16cc]
+[SHADD8cc]
+[SHASXcc]
+[SHSAXcc]
+[SHSUB16cc]
+[SHSUB8cc]
+
+[SMLADcc]
+[SMLALDcc]
+[SMLSDcc]
+[SMLSLDcc]
+[SMMLAcc]
+[SMMLScc]
+[SMMULcc]
+[SMUADcc]
+[SMUSDcc]
+
+[SRScc]
+
+[SSATcc]
+[SSAT16cc]
+[SSAXcc]
+
+[SSUB16cc]
+[SSUB8cc]
+
+[STREXcc]
+[STREXBcc]
+[STREXDcc]
+[STREXHcc]
+
+[SXTABcc]
+[SXTAB16cc]
+[SXTAHcc]
+[SXTBcc]
+[SXTB16cc]
+[SXTHcc]
+
+[UADD16cc]
+[UADD8cc]
+[UASXcc]
+
+[UBFXcc]
+
+[UHADD16cc]
+[UHADD8cc]
+[UHASXcc]
+[UHSAXcc]
+[UHSUB16cc]
+[UHSUB8cc]
+
+[UMAALcc]
+
+[UQADD16cc]
+[UQADD8]
+[UQASXcc]
+[UQSAXcc]
+
+[UQSUB16cc]
+[UQSUB8cc]
+[UQSAD8cc]
+[UQSADA8cc]
+
+[USATcc]
+[USAT16cc]
+[USAXcc]
+
+[USUB16cc]
+[USUB8cc]
+
+[UXTABcc]
+[UXTAB16cc]
+[UXTAHcc]
+
+[UXTBcc]
+[UXTB16cc]
+[UXTHcc]
+
+[WFEcc]
+[WFIcc]
+[YIELDcc]
+
 ; Thumb-2
 
 [ASRcc]
@@ -582,6 +708,10 @@ reg32,reg32,reg32,reg32  \x16\x00\x80\x90		 ARM7
 
 [LSLcc]
 
+[POP]
+
+[PUSH]
+
 [RORcc]
 
 [SDIVcc]
@@ -590,10 +720,6 @@ reg32,reg32,reg32,reg32  \x16\x00\x80\x90		 ARM7
 
 [MOVTcc]
 
-[LDREXcc]
-
-[STREXcc]
-
 [IT]
 
 [ITE]

compiler/arm/armop.inc

@@ -179,15 +179,106 @@ A_FUITOD,
 A_FUITOS,
 A_FMDRR,
 A_FMRRD,
+A_BFC,
+A_BFI,
+A_CLREX,
+A_LDREX,
+A_LDREXB,
+A_LDREXD,
+A_LDREXH,
+A_MLS,
+A_PKH,
+A_PLI,
+A_QADD16,
+A_QADD8,
+A_QASX,
+A_QSAX,
+A_QSUB16,
+A_QSUB8,
+A_RBIT,
+A_REV,
+A_REV16,
+A_REVSH,
+A_SADD16,
+A_SADD8,
+A_SASX,
+A_SBFX,
+A_SEL,
+A_SETEND,
+A_SEV,
+A_SHADD16,
+A_SHADD8,
+A_SHASX,
+A_SHSAX,
+A_SHSUB16,
+A_SHSUB8,
+A_SMLAD,
+A_SMLALD,
+A_SMLSD,
+A_SMLSLD,
+A_SMMLA,
+A_SMMLS,
+A_SMMUL,
+A_SMUAD,
+A_SMUSD,
+A_SRS,
+A_SSAT,
+A_SSAT16,
+A_SSAX,
+A_SSUB16,
+A_SSUB8,
+A_STREX,
+A_STREXB,
+A_STREXD,
+A_STREXH,
+A_SXTAB,
+A_SXTAB16,
+A_SXTAH,
+A_SXTB,
+A_SXTB16,
+A_SXTH,
+A_UADD16,
+A_UADD8,
+A_UASX,
+A_UBFX,
+A_UHADD16,
+A_UHADD8,
+A_UHASX,
+A_UHSAX,
+A_UHSUB16,
+A_UHSUB8,
+A_UMAAL,
+A_UQADD16,
+A_UQADD8,
+A_UQASX,
+A_UQSAX,
+A_UQSUB16,
+A_UQSUB8,
+A_UQSAD8,
+A_UQSADA8,
+A_USAT,
+A_USAT16,
+A_USAX,
+A_USUB16,
+A_USUB8,
+A_UXTAB,
+A_UXTAB16,
+A_UXTAH,
+A_UXTB,
+A_UXTB16,
+A_UXTH,
+A_WFE,
+A_WFI,
+A_YIELD,
 A_ASR,
 A_LSR,
 A_LSL,
+A_POP,
+A_PUSH,
 A_ROR,
 A_SDIV,
 A_UDIV,
 A_MOVT,
-A_LDREX,
-A_STREX,
 A_IT,
 A_ITE,
 A_ITT,

compiler/arm/cgcpu.pas

@@ -177,7 +177,7 @@ unit cgcpu;
 
 
     uses
-       globals,verbose,systems,cutils,
+       globals,verbose,systems,cutils,sysutils,
        aopt,aoptcpu,
        fmodule,
        symconst,symsym,
@@ -253,6 +253,7 @@ unit cgcpu;
           imm_shift : byte;
           l : tasmlabel;
           hr : treference;
+          imm1, imm2: DWord;
        begin
           if not(size in [OS_8,OS_S8,OS_16,OS_S16,OS_32,OS_S32]) then
             internalerror(2002090902);
@@ -261,20 +262,16 @@ unit cgcpu;
           else if is_shifter_const(not(a),imm_shift) then
             list.concat(taicpu.op_reg_const(A_MVN,reg,not(a)))
           { loading of constants with mov and orr }
-          else if (is_shifter_const(a-byte(a),imm_shift)) then
-            begin
-              list.concat(taicpu.op_reg_const(A_MOV,reg,a-byte(a)));
-              list.concat(taicpu.op_reg_reg_const(A_ORR,reg,reg,byte(a)));
-            end
-          else if (is_shifter_const(a-word(a),imm_shift)) and (is_shifter_const(word(a),imm_shift)) then
+          else if (split_into_shifter_const(a,imm1, imm2)) then
             begin
-              list.concat(taicpu.op_reg_const(A_MOV,reg,a-word(a)));
-              list.concat(taicpu.op_reg_reg_const(A_ORR,reg,reg,word(a)));
+              list.concat(taicpu.op_reg_const(A_MOV,reg, imm1));
+              list.concat(taicpu.op_reg_reg_const(A_ORR,reg,reg, imm2));
             end
-          else if (is_shifter_const(a-(dword(a) shl 8) shr 8,imm_shift)) and (is_shifter_const((dword(a) shl 8) shr 8,imm_shift)) then
+          { loading of constants with mvn and bic }
+          else if (split_into_shifter_const(not(a), imm1, imm2)) then
             begin
-              list.concat(taicpu.op_reg_const(A_MOV,reg,a-(dword(a) shl 8) shr 8));
-              list.concat(taicpu.op_reg_reg_const(A_ORR,reg,reg,(dword(a) shl 8) shr 8));
+              list.concat(taicpu.op_reg_const(A_MVN,reg, imm1));
+              list.concat(taicpu.op_reg_reg_const(A_BIC,reg,reg, imm2));
             end
           else
             begin
@@ -388,19 +385,26 @@ unit cgcpu;
                      end
                    else
                      begin
+                       tmpreg2:=getintregister(list,OS_INT);
                        if target_info.endian=endian_big then
                          inc(usedtmpref.offset,3);
                        a_internal_load_ref_reg(list,OS_8,OS_8,usedtmpref,reg);
+
                        inc(usedtmpref.offset,dir);
                        a_internal_load_ref_reg(list,OS_8,OS_8,usedtmpref,tmpreg);
+
+                       inc(usedtmpref.offset,dir);
+                       a_internal_load_ref_reg(list,OS_8,OS_8,usedtmpref,tmpreg2);
+
                        so.shiftimm:=8;
                        list.concat(taicpu.op_reg_reg_reg_shifterop(A_ORR,reg,reg,tmpreg,so));
+
                        inc(usedtmpref.offset,dir);
                        a_internal_load_ref_reg(list,OS_8,OS_8,usedtmpref,tmpreg);
+
                        so.shiftimm:=16;
-                       list.concat(taicpu.op_reg_reg_reg_shifterop(A_ORR,reg,reg,tmpreg,so));
-                       inc(usedtmpref.offset,dir);
-                       a_internal_load_ref_reg(list,OS_8,OS_8,usedtmpref,tmpreg);
+                       list.concat(taicpu.op_reg_reg_reg_shifterop(A_ORR,reg,reg,tmpreg2,so));
+
                        so.shiftimm:=24;
                        list.concat(taicpu.op_reg_reg_reg_shifterop(A_ORR,reg,reg,tmpreg,so));
                      end;
@@ -577,23 +581,34 @@ unit cgcpu;
 
 
      procedure tcgarm.a_op_reg_reg(list : TAsmList; Op: TOpCG; size: TCGSize; src, dst: TRegister);
+       var
+         so : tshifterop;
        begin
-         case op of
-           OP_NEG:
-             list.concat(taicpu.op_reg_reg_const(A_RSB,dst,src,0));
-           OP_NOT:
-             begin
+         if op = OP_NEG then
+             list.concat(taicpu.op_reg_reg_const(A_RSB,dst,src,0))
+         else if op = OP_NOT then
+           begin
+             if size in [OS_8, OS_16, OS_S8, OS_S16] then
+               begin
+                 shifterop_reset(so);
+                 so.shiftmode:=SM_LSL;
+                 if size in [OS_8, OS_S8] then
+                   so.shiftimm:=24
+                 else
+                   so.shiftimm:=16;
+                 list.concat(taicpu.op_reg_reg_shifterop(A_MVN,dst,src,so));
+                 {Using a shift here allows this to be folded into another instruction}
+                 if size in [OS_S8, OS_S16] then
+                   so.shiftmode:=SM_ASR
+                 else
+                   so.shiftmode:=SM_LSR;
+                 list.concat(taicpu.op_reg_reg_shifterop(A_MOV,dst,dst,so));
+               end
+             else
                list.concat(taicpu.op_reg_reg(A_MVN,dst,src));
-               case size of
-                 OS_8 :
-                   a_op_const_reg_reg(list,OP_AND,OS_INT,$ff,dst,dst);
-                 OS_16 :
-                   a_op_const_reg_reg(list,OP_AND,OS_INT,$ffff,dst,dst);
-               end;
-             end
-           else
+           end
+         else
              a_op_reg_reg_reg(list,op,OS_32,src,dst,dst);
-         end;
        end;
 
 
@@ -620,6 +635,17 @@ unit cgcpu;
         a_op_reg_reg_reg_checkoverflow(list,op,size,src1,src2,dst,false,ovloc);
       end;
 
+    function opshift2shiftmode(op: TOpCg): tshiftmode;
+      begin
+        case op of
+          OP_SHL: Result:=SM_LSL;
+          OP_SHR: Result:=SM_LSR;
+          OP_ROR: Result:=SM_ROR;
+          OP_ROL: Result:=SM_ROR;
+          OP_SAR: Result:=SM_ASR;
+          else internalerror(2012070501);
+        end
+      end;
 
     procedure tcgarm.a_op_const_reg_reg_checkoverflow(list: TAsmList; op: TOpCg; size: tcgsize; a: tcgint; src, dst: tregister;setflags : boolean;var ovloc : tlocation);
       var
@@ -627,6 +653,9 @@ unit cgcpu;
         tmpreg : tregister;
         so : tshifterop;
         l1 : longint;
+        imm1, imm2: DWord;
+
+
       begin
         ovloc.loc:=LOC_VOID;
         if {$ifopt R+}(a<>-2147483648) and{$endif} is_shifter_const(-a,shift) then
@@ -647,71 +676,22 @@ unit cgcpu;
           case op of
             OP_NEG,OP_NOT:
               internalerror(200308281);
-            OP_SHL:
-              begin
-                if a>32 then
-                  internalerror(200308294);
-                if a<>0 then
-                  begin
-                    shifterop_reset(so);
-                    so.shiftmode:=SM_LSL;
-                    so.shiftimm:=a;
-                    list.concat(taicpu.op_reg_reg_shifterop(A_MOV,dst,src,so));
-                  end
-                else
-                 list.concat(taicpu.op_reg_reg(A_MOV,dst,src));
-              end;
-            OP_ROL:
-              begin
-                if a>32 then
-                  internalerror(200308294);
-                if a<>0 then
-                  begin
-                    shifterop_reset(so);
-                    so.shiftmode:=SM_ROR;
-                    so.shiftimm:=32-a;
-                    list.concat(taicpu.op_reg_reg_shifterop(A_MOV,dst,src,so));
-                  end
-                else
-                 list.concat(taicpu.op_reg_reg(A_MOV,dst,src));
-              end;
-            OP_ROR:
-              begin
-                if a>32 then
-                  internalerror(200308294);
-                if a<>0 then
-                  begin
-                    shifterop_reset(so);
-                    so.shiftmode:=SM_ROR;
-                    so.shiftimm:=a;
-                    list.concat(taicpu.op_reg_reg_shifterop(A_MOV,dst,src,so));
-                  end
-                else
-                 list.concat(taicpu.op_reg_reg(A_MOV,dst,src));
-              end;
-            OP_SHR:
-              begin
-                if a>32 then
-                  internalerror(200308292);
-                shifterop_reset(so);
-                if a<>0 then
-                  begin
-                    so.shiftmode:=SM_LSR;
-                    so.shiftimm:=a;
-                    list.concat(taicpu.op_reg_reg_shifterop(A_MOV,dst,src,so));
-                  end
-                else
-                 list.concat(taicpu.op_reg_reg(A_MOV,dst,src));
-              end;
+            OP_SHL,
+            OP_SHR,
+            OP_ROL,
+            OP_ROR,
             OP_SAR:
               begin
                 if a>32 then
-                  internalerror(200308295);
+                  internalerror(200308294);
                 if a<>0 then
                   begin
                     shifterop_reset(so);
-                    so.shiftmode:=SM_ASR;
-                    so.shiftimm:=a;
+                    so.shiftmode:=opshift2shiftmode(op);
+                    if op = OP_ROL then
+                      so.shiftimm:=32-a
+                    else
+                      so.shiftimm:=a;
                     list.concat(taicpu.op_reg_reg_shifterop(A_MOV,dst,src,so));
                   end
                 else
@@ -766,6 +746,32 @@ unit cgcpu;
                 so.shiftimm:=l1;
                 list.concat(taicpu.op_reg_reg_reg_shifterop(A_ADD,dst,src,src,so));
               end
+            { for example : b=a*7 -> b=a*8-a with rsb instruction and shl }
+            else if (op in [OP_MUL,OP_IMUL]) and ispowerof2(a+1,l1) and not(cgsetflags or setflags) then
+              begin
+                if l1>32 then{does this ever happen?}
+                  internalerror(201205181);
+                shifterop_reset(so);
+                so.shiftmode:=SM_LSL;
+                so.shiftimm:=l1;
+                list.concat(taicpu.op_reg_reg_reg_shifterop(A_RSB,dst,src,src,so));
+              end
+            { BIC clears the specified bits, while AND keeps them, using BIC allows to use a
+              broader range of shifterconstants.}
+            else if (op = OP_AND) and is_shifter_const(not(dword(a)),shift) then
+              list.concat(taicpu.op_reg_reg_const(A_BIC,dst,src,not(dword(a))))
+            else if (op = OP_AND) and split_into_shifter_const(not(dword(a)), imm1, imm2) then
+              begin
+                list.concat(taicpu.op_reg_reg_const(A_BIC,dst,src,imm1));
+                list.concat(taicpu.op_reg_reg_const(A_BIC,dst,dst,imm2));
+              end
+            else if (op in [OP_ADD, OP_SUB, OP_OR]) and
+                    not(cgsetflags or setflags) and
+                    split_into_shifter_const(a, imm1, imm2) then
+              begin
+                list.concat(taicpu.op_reg_reg_const(op_reg_reg_opcg2asmop[op],dst,src,imm1));
+                list.concat(taicpu.op_reg_reg_const(op_reg_reg_opcg2asmop[op],dst,dst,imm2));
+              end
             else
               begin
                 tmpreg:=getintregister(list,size);
@@ -788,25 +794,16 @@ unit cgcpu;
           OP_NEG,OP_NOT,
           OP_DIV,OP_IDIV:
             internalerror(200308281);
-          OP_SHL:
-            begin
-              shifterop_reset(so);
-              so.rs:=src1;
-              so.shiftmode:=SM_LSL;
-              list.concat(taicpu.op_reg_reg_shifterop(A_MOV,dst,src2,so));
-            end;
-          OP_SHR:
-            begin
-              shifterop_reset(so);
-              so.rs:=src1;
-              so.shiftmode:=SM_LSR;
-              list.concat(taicpu.op_reg_reg_shifterop(A_MOV,dst,src2,so));
-            end;
-          OP_SAR:
+          OP_SHL,
+          OP_SHR,
+          OP_SAR,
+          OP_ROR:
             begin
+              if (op = OP_ROR) and not(size in [OS_32,OS_S32]) then
+                internalerror(2008072801);
               shifterop_reset(so);
               so.rs:=src1;
-              so.shiftmode:=SM_ASR;
+              so.shiftmode:=opshift2shiftmode(op);
               list.concat(taicpu.op_reg_reg_shifterop(A_MOV,dst,src2,so));
             end;
           OP_ROL:
@@ -815,19 +812,9 @@ unit cgcpu;
                 internalerror(2008072801);
               { simulate ROL by ror'ing 32-value }
               tmpreg:=getintregister(list,OS_32);
-              list.concat(taicpu.op_reg_const(A_MOV,tmpreg,32));
-              list.concat(taicpu.op_reg_reg_reg(A_SUB,src1,tmpreg,src1));
-              shifterop_reset(so);
-              so.rs:=src1;
-              so.shiftmode:=SM_ROR;
-              list.concat(taicpu.op_reg_reg_shifterop(A_MOV,dst,src2,so));
-            end;
-          OP_ROR:
-            begin
-              if not(size in [OS_32,OS_S32]) then
-                internalerror(2008072802);
+              list.concat(taicpu.op_reg_reg_const(A_RSB,tmpreg,src1, 32));
               shifterop_reset(so);
-              so.rs:=src1;
+              so.rs:=tmpreg;
               so.shiftmode:=SM_ROR;
               list.concat(taicpu.op_reg_reg_shifterop(A_MOV,dst,src2,so));
             end;
@@ -1070,7 +1057,7 @@ unit cgcpu;
            OS_F32:
              oppostfix:=PF_None;
            else
-             InternalError(200308295);
+             InternalError(200308299);
          end;
          if (ref.alignment in [1,2]) and (ref.alignment<tcgsize2size[tosize]) then
            begin
@@ -1770,7 +1757,7 @@ unit cgcpu;
 
                 if regs=[] then
                   begin
-                    if (current_settings.cputype<cpu_armv6) then
+                    if (current_settings.cputype<cpu_armv5) then
                       list.concat(taicpu.op_reg_reg(A_MOV,NR_PC,NR_R14))
                     else
                       list.concat(taicpu.op_reg(A_BX,NR_R14))
@@ -1791,7 +1778,7 @@ unit cgcpu;
                 list.concat(setoppostfix(taicpu.op_ref_regset(A_LDM,ref,R_INTREGISTER,R_SUBWHOLE,regs),PF_EA));
               end;
           end
-        else if (current_settings.cputype<cpu_armv6) then
+        else if (current_settings.cputype<cpu_armv5) then
           list.concat(taicpu.op_reg_reg(A_MOV,NR_PC,NR_R14))
         else
           list.concat(taicpu.op_reg(A_BX,NR_R14))
@@ -1921,10 +1908,10 @@ unit cgcpu;
         paraloc1.init;
         paraloc2.init;
         paraloc3.init;
-        paramanager.getintparaloc(pocall_default,1,paraloc1);
-        paramanager.getintparaloc(pocall_default,2,paraloc2);
-        paramanager.getintparaloc(pocall_default,3,paraloc3);
-        a_load_const_cgpara(list,OS_INT,len,paraloc3);
+        paramanager.getintparaloc(pocall_default,1,voidpointertype,paraloc1);
+        paramanager.getintparaloc(pocall_default,2,voidpointertype,paraloc2);
+        paramanager.getintparaloc(pocall_default,3,ptrsinttype,paraloc3);
+        a_load_const_cgpara(list,OS_SINT,len,paraloc3);
         a_loadaddr_ref_cgpara(list,dest,paraloc2);
         a_loadaddr_ref_cgpara(list,source,paraloc1);
         paramanager.freecgpara(list,paraloc3);
@@ -2618,7 +2605,7 @@ unit cgcpu;
 
     procedure tcgarm.maybeadjustresult(list: TAsmList; op: TOpCg; size: tcgsize; dst: tregister);
       const
-        overflowops = [OP_MUL,OP_SHL,OP_ADD,OP_SUB,OP_NOT,OP_NEG];
+        overflowops = [OP_MUL,OP_SHL,OP_ADD,OP_SUB,OP_NEG];
       begin
         if (op in overflowops) and
            (size in [OS_8,OS_S8,OS_16,OS_S16]) then

compiler/arm/cpubase.pas

@@ -251,7 +251,8 @@ unit cpubase;
 
       { Defines the default address size for a processor, }
       OS_ADDR = OS_32;
-      { the natural int size for a processor,             }
+      { the natural int size for a processor,
+        has to match osuinttype/ossinttype as initialized in psystem }
       OS_INT = OS_32;
       OS_SINT = OS_S32;
       { the maximum float size for a processor,           }
@@ -291,11 +292,11 @@ unit cpubase;
       PARENT_FRAMEPOINTER_OFFSET = 0;
 
       { Low part of 64bit return value }
-      function NR_FUNCTION_RESULT64_LOW_REG: tregister;
-      function RS_FUNCTION_RESULT64_LOW_REG: shortint;
+      function NR_FUNCTION_RESULT64_LOW_REG: tregister;{$ifdef USEINLINE}inline;{$endif USEINLINE}
+      function RS_FUNCTION_RESULT64_LOW_REG: shortint;{$ifdef USEINLINE}inline;{$endif USEINLINE}
       { High part of 64bit return value }
-      function NR_FUNCTION_RESULT64_HIGH_REG: tregister;
-      function RS_FUNCTION_RESULT64_HIGH_REG: shortint;
+      function NR_FUNCTION_RESULT64_HIGH_REG: tregister;{$ifdef USEINLINE}inline;{$endif USEINLINE}
+      function RS_FUNCTION_RESULT64_HIGH_REG: shortint;{$ifdef USEINLINE}inline;{$endif USEINLINE}
 
 {*****************************************************************************
                        GCC /ABI linking information
@@ -313,7 +314,7 @@ unit cpubase;
         (RS_R4,RS_R5,RS_R6,RS_R7,RS_R8,RS_R9,RS_R10);
 
       { this is only for the generic code which is not used for this architecture }
-      saved_mm_registers : array[0..0] of tsuperregister = (RS_NO);
+      saved_mm_registers : array[0..0] of tsuperregister = (RS_INVALID);
 
       { Required parameter alignment when calling a routine declared as
         stdcall and cdecl. The alignment value should be the one defined
@@ -332,7 +333,7 @@ unit cpubase;
     { Returns the tcgsize corresponding with the size of reg.}
     function reg_cgsize(const reg: tregister) : tcgsize;
     function cgsize2subreg(regtype: tregistertype; s:Tcgsize):Tsubregister;
-    function is_calljmp(o:tasmop):boolean;
+    function is_calljmp(o:tasmop):boolean;{$ifdef USEINLINE}inline;{$endif USEINLINE}
     procedure inverse_flags(var f: TResFlags);
     function flags_to_cond(const f: TResFlags) : TAsmCond;
     function findreg_by_number(r:Tregister):tregisterindex;
@@ -342,10 +343,11 @@ unit cpubase;
     function inverse_cond(const c: TAsmCond): TAsmCond; {$ifdef USEINLINE}inline;{$endif USEINLINE}
     function conditions_equal(const c1, c2: TAsmCond): boolean; {$ifdef USEINLINE}inline;{$endif USEINLINE}
 
-    procedure shifterop_reset(var so : tshifterop);
-    function is_pc(const r : tregister) : boolean;
+    procedure shifterop_reset(var so : tshifterop); {$ifdef USEINLINE}inline;{$endif USEINLINE}
+    function is_pc(const r : tregister) : boolean; {$ifdef USEINLINE}inline;{$endif USEINLINE}
 
     function is_shifter_const(d : aint;var imm_shift : byte) : boolean;
+    function split_into_shifter_const(value : aint;var imm1: dword; var imm2: dword):boolean;
     function dwarf_reg(r:tregister):shortint;
 
   implementation
@@ -413,7 +415,7 @@ unit cpubase;
         end;
 
 
-    function is_calljmp(o:tasmop):boolean;
+    function is_calljmp(o:tasmop):boolean;{$ifdef USEINLINE}inline;{$endif USEINLINE}
       begin
         { This isn't 100% perfect because the arm allows jumps also by writing to PC=R15.
           To overcome this problem we simply forbid that FPC generates jumps by loading R15 }
@@ -467,13 +469,13 @@ unit cpubase;
       end;
 
 
-    procedure shifterop_reset(var so : tshifterop);
+    procedure shifterop_reset(var so : tshifterop);{$ifdef USEINLINE}inline;{$endif USEINLINE}
       begin
         FillChar(so,sizeof(so),0);
       end;
 
 
-    function is_pc(const r : tregister) : boolean;
+    function is_pc(const r : tregister) : boolean; {$ifdef USEINLINE}inline;{$endif USEINLINE}
       begin
         is_pc:=(r=NR_R15);
       end;
@@ -496,12 +498,6 @@ unit cpubase;
       end;
 
 
-    function rotl(d : dword;b : byte) : dword;
-      begin
-         result:=(d shr (32-b)) or (d shl b);
-      end;
-
-
     function is_shifter_const(d : aint;var imm_shift : byte) : boolean;
       var
          i : longint;
@@ -522,7 +518,7 @@ unit cpubase;
           begin
             for i:=0 to 15 do
               begin
-                 if (dword(d) and not(rotl($ff,i*2)))=0 then
+                 if (dword(d) and not(roldword($ff,i*2)))=0 then
                    begin
                       imm_shift:=i*2;
                       result:=true;
@@ -533,6 +529,30 @@ unit cpubase;
         result:=false;
       end;
 
+    function split_into_shifter_const(value : aint;var imm1: dword; var imm2: dword) : boolean;
+      var
+        d, i, i2: Dword;
+      begin
+        Result:=false;
+        {Thumb2 is not supported (YET?)}
+        if current_settings.cputype in cpu_thumb2 then exit;
+        d:=DWord(value);
+        for i:=0 to 15 do
+          begin
+            imm1:=d and rordword($FF, I*2);
+            imm2:=d and not (imm1); {remove already found bits}
+            {is the remainder a shifterconst? YAY! we've done it!}
+            {Could we start from i instead of 0?}
+            for i2:=0 to 15 do
+              begin
+                 if (imm2 and not(rordword($FF,i2*2)))=0 then
+                   begin
+                      result:=true;
+                      exit;
+                   end;
+              end;
+          end;
+      end;
 
     function dwarf_reg(r:tregister):shortint;
       begin
@@ -542,7 +562,7 @@ unit cpubase;
       end;
 
       { Low part of 64bit return value }
-    function NR_FUNCTION_RESULT64_LOW_REG: tregister;
+    function NR_FUNCTION_RESULT64_LOW_REG: tregister; {$ifdef USEINLINE}inline;{$endif USEINLINE}
     begin
       if target_info.endian=endian_little then
         result:=NR_R0
@@ -550,7 +570,7 @@ unit cpubase;
         result:=NR_R1;
     end;
 
-    function RS_FUNCTION_RESULT64_LOW_REG: shortint;
+    function RS_FUNCTION_RESULT64_LOW_REG: shortint; {$ifdef USEINLINE}inline;{$endif USEINLINE}
     begin
       if target_info.endian=endian_little then
         result:=RS_R0
@@ -559,7 +579,7 @@ unit cpubase;
     end;
 
       { High part of 64bit return value }
-    function NR_FUNCTION_RESULT64_HIGH_REG: tregister;
+    function NR_FUNCTION_RESULT64_HIGH_REG: tregister; {$ifdef USEINLINE}inline;{$endif USEINLINE}
     begin
       if target_info.endian=endian_little then
         result:=NR_R1
@@ -567,7 +587,7 @@ unit cpubase;
         result:=NR_R0;
     end;
 
-    function RS_FUNCTION_RESULT64_HIGH_REG: shortint;
+    function RS_FUNCTION_RESULT64_HIGH_REG: shortint; {$ifdef USEINLINE}inline;{$endif USEINLINE}
     begin
       if target_info.endian=endian_little then
         result:=RS_R1

compiler/arm/cpunode.pas

@@ -40,7 +40,8 @@ unit cpunode;
        narminl,
        narmcnv,
        narmcon,
-       narmset
+       narmset,
+       narmmem
        ;
 
 

compiler/arm/cpupara.pas

@@ -39,7 +39,7 @@ unit cpupara;
           function get_volatile_registers_mm(calloption : tproccalloption):tcpuregisterset;override;
           function push_addr_param(varspez:tvarspez;def : tdef;calloption : tproccalloption) : boolean;override;
           function ret_in_param(def : tdef;calloption : tproccalloption) : boolean;override;
-          procedure getintparaloc(calloption : tproccalloption; nr : longint;var cgpara:TCGPara);override;
+          procedure getintparaloc(calloption : tproccalloption; nr : longint; def : tdef; var cgpara : tcgpara);override;
           function create_paraloc_info(p : tabstractprocdef; side: tcallercallee):longint;override;
           function create_varargs_paraloc_info(p : tabstractprocdef; varargspara:tvarargsparalist):longint;override;
           function get_funcretloc(p : tabstractprocdef; side: tcallercallee; def: tdef): tcgpara;override;
@@ -79,16 +79,17 @@ unit cpupara;
       end;
 
 
-    procedure tarmparamanager.getintparaloc(calloption : tproccalloption; nr : longint;var cgpara:TCGPara);
+    procedure tarmparamanager.getintparaloc(calloption : tproccalloption; nr : longint; def : tdef; var cgpara : tcgpara);
       var
         paraloc : pcgparalocation;
       begin
         if nr<1 then
           internalerror(2002070801);
         cgpara.reset;
-        cgpara.size:=OS_ADDR;
-        cgpara.intsize:=sizeof(pint);
+        cgpara.size:=def_cgsize(def);
+        cgpara.intsize:=tcgsize2size[cgpara.size];
         cgpara.alignment:=std_param_align;
+        cgpara.def:=def;
         paraloc:=cgpara.add_location;
         with paraloc^ do
           begin
@@ -356,12 +357,9 @@ unit cpupara;
                 break;
               end;
 
-            if (hp.varspez in [vs_var,vs_out]) or
-               push_addr_param(hp.varspez,paradef,p.proccalloption) or
-               is_open_array(paradef) or
-               is_array_of_const(paradef) then
+            if push_addr_param(hp.varspez,paradef,p.proccalloption) then
               begin
-                paradef:=voidpointertype;
+                paradef:=getpointerdef(paradef);
                 loc:=LOC_REGISTER;
                 paracgsize := OS_ADDR;
                 paralen := tcgsize2size[OS_ADDR];
@@ -384,7 +382,8 @@ unit cpupara;
                     if (paracgsize=OS_NO) then
                       begin
                         paracgsize:=OS_ADDR;
-                        paralen := tcgsize2size[OS_ADDR];
+                        paralen:=tcgsize2size[OS_ADDR];
+                        paradef:=voidpointertype;
                       end;
                   end
               end;
@@ -392,6 +391,7 @@ unit cpupara;
              hp.paraloc[side].size:=paracgsize;
              hp.paraloc[side].Alignment:=std_param_align;
              hp.paraloc[side].intsize:=paralen;
+             hp.paraloc[side].def:=paradef;
              firstparaloc:=true;
 
 {$ifdef EXTDEBUG}
@@ -587,38 +587,8 @@ unit cpupara;
         paraloc : pcgparalocation;
         retcgsize  : tcgsize;
       begin
-        result.init;
-        result.alignment:=get_para_align(p.proccalloption);
-        { 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_ADDR;
-            result.intsize:=sizeof(pint);
-          end
-        else
-          begin
-            retcgsize:=def_cgsize(def);
-            result.intsize:=def.size;
-          end;
-        result.size:=retcgsize;
-        { Return is passed as var parameter }
-        if ret_in_param(def,p.proccalloption) then
-          begin
-            paraloc:=result.add_location;
-            paraloc^.loc:=LOC_REFERENCE;
-            paraloc^.size:=retcgsize;
-            exit;
-          end;
+         if set_common_funcretloc_info(p,def,retcgsize,result) then
+           exit;
 
         paraloc:=result.add_location;
         { Return in FPU register? }

compiler/arm/cpupi.pas

@@ -50,7 +50,7 @@ unit cpupi;
        aasmtai,aasmdata,
        tgobj,
        symconst,symsym,paramgr,
-       cgbase,
+       cgbase,cgutils,
        cgobj;
 
     procedure tarmprocinfo.set_first_temp_offset;

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/narmcnv.pas

@@ -65,7 +65,7 @@ implementation
       ncon,ncal,
       ncgutil,
       cpubase,cpuinfo,aasmcpu,
-      rgobj,tgobj,cgobj,cgcpu;
+      rgobj,tgobj,cgobj,hlcgobj,cgcpu;
 
 
 {*****************************************************************************
@@ -145,7 +145,7 @@ implementation
             begin
               { convert first to double to avoid precision loss }
               location_reset(location,LOC_FPUREGISTER,def_cgsize(resultdef));
-              location_force_reg(current_asmdata.CurrAsmList,left.location,OS_32,true);
+              hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,u32inttype,true);
               location.register:=cg.getfpuregister(current_asmdata.CurrAsmList,location.size);
               instr:=taicpu.op_reg_reg(A_FLT,location.register,left.location.register);
               if is_signed(left.resultdef) then
@@ -242,7 +242,7 @@ implementation
               { 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
-                location_force_reg(current_asmdata.CurrAsmList,location,newsize,true)
+                hlcg.location_force_reg(current_asmdata.CurrAsmList,location,left.resultdef,resultdef,true)
               else
                 location.size:=newsize;
               current_procinfo.CurrTrueLabel:=oldTrueLabel;
@@ -268,7 +268,7 @@ implementation
                  end
                 else
                  begin
-                   location_force_reg(current_asmdata.CurrAsmList,left.location,left.location.size,true);
+                   hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,left.resultdef,true);
                    tcgarm(cg).cgsetflags:=true;
                    cg.a_op_reg_reg(current_asmdata.CurrAsmList,OP_OR,left.location.size,left.location.register,left.location.register);
                    tcgarm(cg).cgsetflags:=false;

compiler/arm/narminl.pas

@@ -49,6 +49,7 @@ interface
         procedure second_sin_real; override;
         }
         procedure second_prefetch; override;
+        procedure second_abs_long; override;
       private
         procedure load_fpu_location(out singleprec: boolean);
       end;
@@ -59,14 +60,14 @@ implementation
     uses
       globtype,systems,
       cutils,verbose,globals,fmodule,
-      cpuinfo,
+      cpuinfo, defutil,
       symconst,symdef,
       aasmbase,aasmtai,aasmdata,aasmcpu,
       cgbase,cgutils,
       pass_1,pass_2,
       cpubase,paramgr,
       nbas,ncon,ncal,ncnv,nld,
-      tgobj,ncgutil,cgobj,cg64f32,rgobj,rgcpu,cgcpu;
+      tgobj,ncgutil,cgobj,cg64f32,rgobj,rgcpu,cgcpu, hlcgobj;
 
 {*****************************************************************************
                               tarminlinenode
@@ -338,6 +339,21 @@ implementation
           end;
       end;
 
+    procedure tarminlinenode.second_abs_long;
+      var
+        hregister : tregister;
+        opsize : tcgsize;
+        hp : taicpu;
+      begin
+        secondpass(left);
+        opsize:=def_cgsize(left.resultdef);
+        hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,left.resultdef,true);
+        hregister:=cg.getintregister(current_asmdata.CurrAsmList,opsize);
+        location:=left.location;
+        location.register:=cg.getintregister(current_asmdata.CurrAsmList,opsize);
+        current_asmdata.CurrAsmList.concat(setoppostfix(taicpu.op_reg_reg(A_MOV,location.register,left.location.register), PF_S));
+        current_asmdata.CurrAsmList.concat(setcondition(taicpu.op_reg_reg_const(A_RSB,location.register,location.register, 0), C_MI));
+      end;
 
 begin
   cinlinenode:=tarminlinenode;

compiler/arm/narmmat.pas

@@ -42,6 +42,10 @@ interface
         procedure second_float;override;
       end;
 
+      tarmshlshrnode = class(tcgshlshrnode)
+         procedure second_64bit;override;
+         function first_shlshr64bitint: tnode; override;
+      end;
 
 implementation
 
@@ -50,7 +54,7 @@ implementation
       cutils,verbose,globals,constexp,
       aasmbase,aasmcpu,aasmtai,aasmdata,
       defutil,
-      cgbase,cgobj,cgutils,
+      cgbase,cgobj,hlcgobj,cgutils,
       pass_2,procinfo,
       ncon,
       cpubase,cpuinfo,
@@ -194,7 +198,7 @@ implementation
            not(is_64bitint(resultdef)) then
           begin
             size:=def_cgsize(left.resultdef);
-            location_force_reg(current_asmdata.CurrAsmList,left.location,size,true);
+            hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,left.resultdef,true);
 
             location_copy(location,left.location);
             location.loc := LOC_REGISTER;
@@ -213,7 +217,7 @@ implementation
               end
             else
               begin
-                location_force_reg(current_asmdata.CurrAsmList,right.location,size,true);
+                hlcg.location_force_reg(current_asmdata.CurrAsmList,right.location,right.resultdef,left.resultdef,true);
 
                 if is_signed(left.resultdef) or
                    is_signed(right.resultdef) then
@@ -228,8 +232,8 @@ implementation
 
             { put numerator in register }
             size:=def_cgsize(left.resultdef);
-            location_force_reg(current_asmdata.CurrAsmList,left.location,
-              size,true);
+            hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,
+              left.resultdef,left.resultdef,true);
             location_copy(location,left.location);
             numerator:=location.register;
             resultreg:=location.register;
@@ -299,7 +303,7 @@ implementation
               LOC_REGISTER,LOC_CREGISTER,LOC_REFERENCE,LOC_CREFERENCE,
               LOC_SUBSETREG,LOC_CSUBSETREG,LOC_SUBSETREF,LOC_CSUBSETREF :
                 begin
-                  location_force_reg(current_asmdata.CurrAsmList,left.location,def_cgsize(left.resultdef),true);
+                  hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,left.resultdef,true);
                   current_asmdata.CurrAsmList.concat(taicpu.op_reg_const(A_CMP,left.location.register,0));
                   location_reset(location,LOC_FLAGS,OS_NO);
                   location.resflags:=F_EQ;
@@ -350,9 +354,142 @@ implementation
         end;
       end;
 
+    function tarmshlshrnode.first_shlshr64bitint: tnode;
+      begin
+        result := nil;
+      end;
+
+    procedure tarmshlshrnode.second_64bit;
+      var
+        hreg64hi,hreg64lo,shiftreg:Tregister;
+        v : TConstExprInt;
+        l1,l2,l3:Tasmlabel;
+        so: tshifterop;
+
+      procedure emit_instr(p: tai);
+        begin
+          current_asmdata.CurrAsmList.concat(p);
+        end;
+
+      {Reg1 gets shifted and moved into reg2, and is set to zero afterwards}
+      procedure shift_more_than_32(reg1, reg2: TRegister; shiftval: Byte ; sm: TShiftMode);
+        begin
+          shifterop_reset(so); so.shiftimm:=shiftval - 32; so.shiftmode:=sm;
+          emit_instr(taicpu.op_reg_reg_shifterop(A_MOV, reg2, reg1, so));
+          emit_instr(taicpu.op_reg_const(A_MOV, reg1, 0));
+        end;
+
+      procedure shift_less_than_32(reg1, reg2: TRegister; shiftval: Byte; shiftright: boolean);
+        begin
+          shifterop_reset(so); so.shiftimm:=shiftval;
+          if shiftright then so.shiftmode:=SM_LSR else so.shiftmode:=SM_LSL;
+          emit_instr(taicpu.op_reg_reg_shifterop(A_MOV, reg1, reg1, so));
+
+          if shiftright then so.shiftmode:=SM_LSL else so.shiftmode:=SM_LSR;
+          so.shiftimm:=32-shiftval;
+          emit_instr(taicpu.op_reg_reg_reg_shifterop(A_ORR, reg1, reg1, reg2, so));
+
+          if shiftright then so.shiftmode:=SM_LSR else so.shiftmode:=SM_LSL;
+          so.shiftimm:=shiftval;
+          emit_instr(taicpu.op_reg_reg_shifterop(A_MOV, reg2, reg2, so));
+        end;
+
+      procedure shift_by_variable(reg1, reg2, shiftval: TRegister; shiftright: boolean);
+        var
+          shiftval2:TRegister;
+        begin
+          shifterop_reset(so);
+          shiftval2:=cg.getintregister(current_asmdata.CurrAsmList,OS_INT);
+          {Do we shift more than 32 bits?}
+          emit_instr(setoppostfix(taicpu.op_reg_reg_const(A_RSB, shiftval2, shiftval, 32), PF_S));
+
+          {This part cares for 32 bits and more}
+          emit_instr(setcondition(taicpu.op_reg_reg_const(A_SUB, shiftval2, shiftval, 32), C_MI));
+          if shiftright then so.shiftmode:=SM_LSR else so.shiftmode:=SM_LSL;
+          so.rs:=shiftval2;
+          emit_instr(setcondition(taicpu.op_reg_reg_shifterop(A_MOV, reg2, reg1, so), C_MI));
+
+          {Less than 32 bits}
+          so.rs:=shiftval;
+          emit_instr(setcondition(taicpu.op_reg_reg_shifterop(A_MOV, reg2, reg2, so), C_PL));
+          if shiftright then so.shiftmode:=SM_LSL else so.shiftmode:=SM_LSR;
+          so.rs:=shiftval2;
+          emit_instr(setcondition(taicpu.op_reg_reg_reg_shifterop(A_ORR, reg2, reg2, reg1, so), C_PL));
+
+          {Final adjustments}
+          if shiftright then so.shiftmode:=SM_LSR else so.shiftmode:=SM_LSL;
+          so.rs:=shiftval;
+          emit_instr(taicpu.op_reg_reg_shifterop(A_MOV, reg1, reg1, so));
+        end;
+
+      begin
+        location_reset(location,LOC_REGISTER,def_cgsize(resultdef));
+
+        { load left operator in a register }
+        hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,resultdef,false);
+        hreg64hi:=left.location.register64.reghi;
+        hreg64lo:=left.location.register64.reglo;
+        location.register64.reghi:=hreg64hi;
+        location.register64.reglo:=hreg64lo;
+
+        { shifting by a constant directly coded: }
+        if (right.nodetype=ordconstn) then
+          begin
+            v:=Tordconstnode(right).value and 63;
+            {Single bit shift}
+            if v = 1 then
+              if nodetype=shln then
+                begin
+                  {Shift left by one by 2 simple 32bit additions}
+                  emit_instr(setoppostfix(taicpu.op_reg_reg_reg(A_ADD, hreg64lo, hreg64lo, hreg64lo), PF_S));
+                  emit_instr(taicpu.op_reg_reg_reg(A_ADC, hreg64hi, hreg64hi, hreg64hi));
+                end
+              else
+                begin
+                  {Shift right by first shifting hi by one and then using RRX (rotate right extended), which rotates through the carry}
+                  shifterop_reset(so); so.shiftmode:=SM_LSR; so.shiftimm:=1;
+                  emit_instr(setoppostfix(taicpu.op_reg_reg_shifterop(A_MOV, hreg64hi, hreg64hi, so), PF_S));
+                  so.shiftmode:=SM_RRX; so.shiftimm:=0; {RRX does NOT have a shift amount}
+                  emit_instr(taicpu.op_reg_reg_shifterop(A_MOV, hreg64lo, hreg64lo, so));
+                end
+            {A 32bit shift just replaces a register and clears the other}
+            else if v = 32 then
+              begin
+                if nodetype=shln then
+                  emit_instr(taicpu.op_reg_const(A_MOV, hreg64hi, 0))
+                else
+                  emit_instr(taicpu.op_reg_const(A_MOV, hreg64lo, 0));
+                location.register64.reghi:=hreg64lo;
+                location.register64.reglo:=hreg64hi;
+              end
+            {Shift LESS than 32}
+            else if (v < 32) and (v > 1) then
+              if nodetype=shln then
+                shift_less_than_32(hreg64hi, hreg64lo, v.uvalue, false)
+              else
+                shift_less_than_32(hreg64lo, hreg64hi, v.uvalue, true)
+            {More than 32}
+            else if v > 32 then
+              if nodetype=shln then
+                shift_more_than_32(hreg64lo, hreg64hi, v.uvalue, SM_LSL)
+              else
+                shift_more_than_32(hreg64hi, hreg64lo, v.uvalue, SM_LSR);
+          end
+        else
+          begin
+            { force right operators in a register }
+            hlcg.location_force_reg(current_asmdata.CurrAsmList,right.location,right.resultdef,resultdef,false);
+            if nodetype = shln then
+              shift_by_variable(hreg64lo,hreg64hi,right.location.register, false)
+            else
+              shift_by_variable(hreg64hi,hreg64lo,right.location.register, true);
+          end;
+      end;
+
 
 begin
   cmoddivnode:=tarmmoddivnode;
   cnotnode:=tarmnotnode;
   cunaryminusnode:=tarmunaryminusnode;
+  cshlshrnode:=tarmshlshrnode;
 end.

compiler/arm/narmmem.pas

@@ -0,0 +1,91 @@
+{
+    Copyright (c) 2012 by Florian Klaempfl
+
+    Generate arm assembler 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 narmmem;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+      globtype,
+      cgbase,cpuinfo,cpubase,
+      node,nmem,ncgmem;
+
+    type
+      tarmvecnode = class(tcgvecnode)
+        procedure update_reference_reg_mul(maybe_const_reg: tregister; l: aint);override;
+      end;
+
+implementation
+
+    uses
+      systems,
+      cutils,verbose,
+      symdef,paramgr,
+      aasmtai,aasmdata,aasmcpu,
+      nld,ncon,nadd,
+      cgutils,cgobj;
+
+{*****************************************************************************
+                             TARMVECNODE
+*****************************************************************************}
+
+     procedure tarmvecnode.update_reference_reg_mul(maybe_const_reg:tregister;l:aint);
+       var
+         hreg: tregister;
+         hl : longint;
+       begin
+         if ((location.reference.base=NR_NO) and (location.reference.index=NR_NO)) or
+            { simple constant? }
+            (l=1) or ispowerof2(l,hl) or ispowerof2(l+1,hl) or ispowerof2(l-1,hl) then
+           inherited update_reference_reg_mul(maybe_const_reg,l)
+         else if (location.reference.base<>NR_NO) then
+           begin
+             hreg:=cg.getaddressregister(current_asmdata.CurrAsmList);
+             cg.a_load_const_reg(current_asmdata.CurrAsmList,OS_ADDR,l,hreg);
+             current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg_reg_reg(A_MLA,hreg,maybe_const_reg,hreg,location.reference.base));
+             location.reference.base:=hreg;
+             { update alignment }
+             if (location.reference.alignment=0) then
+               internalerror(2012052202);
+             location.reference.alignment:=newalignment(location.reference.alignment,l);
+           end
+         else if (location.reference.index<>NR_NO) then
+           begin
+             hreg:=cg.getaddressregister(current_asmdata.CurrAsmList);
+             cg.a_load_const_reg(current_asmdata.CurrAsmList,OS_ADDR,l,hreg);
+             current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg_reg_reg(A_MLA,hreg,maybe_const_reg,hreg,location.reference.index));
+             location.reference.base:=hreg;
+             location.reference.index:=NR_NO;
+             { update alignment }
+             if (location.reference.alignment=0) then
+               internalerror(2012052203);
+             location.reference.alignment:=newalignment(location.reference.alignment,l);
+           end
+         else
+           internalerror(2012052201);
+       end;
+
+
+begin
+  cvecnode:=tarmvecnode;
+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/arm/raarmgas.pas

@@ -62,7 +62,7 @@ Unit raarmgas;
       procinfo,
       itcpugas,
       rabase,rautils,
-      cgbase,cgobj
+      cgbase,cgutils,cgobj
       ;
 
 
@@ -656,25 +656,27 @@ Unit raarmgas;
           begin
             is_ConditionCode := false;
 
-            if actopcode in [A_IT,A_ITE,A_ITT,
-                             A_ITEE,A_ITTE,A_ITET,A_ITTT,
-                             A_ITEEE,A_ITTEE,A_ITETE,A_ITTTE,A_ITEET,A_ITTET,A_ITETT,A_ITTTT] then
-              begin
-                { search for condition, conditions are always 2 chars }
-                if length(hs)>1 then
-                  begin
-                    for icond:=low(tasmcond) to high(tasmcond) do
-                      begin
-                        if copy(hs,1,2)=uppercond2str[icond] then
-                          begin
-                            //actcondition:=icond;
-                            oper.opr.typ := OPR_COND;
-                            oper.opr.cc := icond;
-                            exit(true);
-                          end;
-                      end;
-                  end;
-              end;
+            case actopcode of
+              A_IT,A_ITE,A_ITT,
+              A_ITEE,A_ITTE,A_ITET,A_ITTT,
+              A_ITEEE,A_ITTEE,A_ITETE,A_ITTTE,A_ITEET,A_ITTET,A_ITETT,A_ITTTT:
+                begin
+                  { search for condition, conditions are always 2 chars }
+                  if length(hs)>1 then
+                    begin
+                      for icond:=low(tasmcond) to high(tasmcond) do
+                        begin
+                          if copy(hs,1,2)=uppercond2str[icond] then
+                            begin
+                              //actcondition:=icond;
+                              oper.opr.typ := OPR_COND;
+                              oper.opr.cc := icond;
+                              exit(true);
+                            end;
+                        end;
+                    end;
+                end;
+            end;
           end;
 
 

compiler/arm/rgcpu.pas

@@ -57,7 +57,7 @@ unit rgcpu;
   implementation
 
     uses
-      verbose, cutils,globtype,
+      verbose, cutils,globtype,globals,cpuinfo,
       cgobj,
       procinfo;
 
@@ -368,8 +368,10 @@ unit rgcpu;
         if p.typ=ait_instruction then
           begin
             case taicpu(p).opcode of
+              A_MLA,
               A_MUL:
-                add_edge(getsupreg(taicpu(p).oper[0]^.reg),getsupreg(taicpu(p).oper[1]^.reg));
+                if current_settings.cputype<cpu_armv6 then
+                  add_edge(getsupreg(taicpu(p).oper[0]^.reg),getsupreg(taicpu(p).oper[1]^.reg));
               A_UMULL,
               A_UMLAL,
               A_SMULL,

compiler/asmutils.pas

@@ -28,11 +28,19 @@ interface
 uses
   globtype,
   aasmbase,
-  aasmdata;
+  aasmdata,
+  symconst;
 
+    type
+      tasmlabofs = record
+        lab: tasmlabel;
+        ofs: pint;
+      end;
+
+    function emit_ansistring_const(list:TAsmList;data:PChar;len:LongInt;encoding:tstringencoding;NewSection:Boolean=True):tasmlabofs;
+    function emit_unicodestring_const(list:TAsmList;data:Pointer;encoding:tstringencoding;Winlike:Boolean):tasmlabofs;
 
-    function emit_ansistring_const(list:TAsmList;data:PChar;len:LongInt;encoding:tstringencoding;NewSection:Boolean=True):TAsmLabel;
-    function emit_unicodestring_const(list:TAsmList;data:Pointer;encoding:tstringencoding;Winlike:Boolean):TAsmLabel;
+    function get_string_symofs(typ: tstringtype; winlikewidestring: boolean): pint;
 
 
 implementation
@@ -45,35 +53,40 @@ uses
   widestr,
   symdef;
 
-    function emit_ansistring_const(list:TAsmList;data:PChar;len:LongInt;encoding:tstringencoding;NewSection:Boolean): TAsmLabel;
+    function emit_ansistring_const(list:TAsmList;data:PChar;len:LongInt;encoding:tstringencoding;NewSection:Boolean): tasmlabofs;
       var
-        referencelab: TAsmLabel;
         s: PChar;
       begin
-        current_asmdata.getdatalabel(result);
+        current_asmdata.getdatalabel(result.lab);
+        result.ofs:=0;
         if NewSection then
-          new_section(list,sec_rodata,result.name,const_align(sizeof(pint)));
-        referencelab := nil;
+          new_section(list,sec_rodata,result.lab.name,const_align(sizeof(pint)));
+        { put label before header on Darwin, because there the linker considers
+          a global symbol to be the start of a new subsection }
         if target_info.system in systems_darwin then
-          begin
-            current_asmdata.getdatalabel(referencelab);
-            list.concat(tai_label.create(referencelab));
-          end;
+          list.concat(tai_label.create(result.lab));
         list.concat(tai_const.create_16bit(encoding));
+        inc(result.ofs,2);
         list.concat(tai_const.create_16bit(1));
+        inc(result.ofs,2);
 {$ifdef cpu64bitaddr}
         { dummy for alignment }
         list.concat(tai_const.create_32bit(0));
+        inc(result.ofs,4);
 {$endif cpu64bitaddr}
         list.concat(tai_const.create_pint(-1));
+        inc(result.ofs,sizeof(pint));
         list.concat(tai_const.create_pint(len));
-        { make sure the string doesn't get dead stripped if the header is referenced }
-        if target_info.system in systems_darwin then
-          list.concat(tai_directive.create(asd_reference,result.name));
-        list.concat(tai_label.create(result));
-        { and vice versa }
-        if target_info.system in systems_darwin then
-          list.concat(tai_directive.create(asd_reference,referencelab.name));
+        inc(result.ofs,sizeof(pint));
+        if not(target_info.system in systems_darwin) then
+          begin
+            { results in slightly more efficient code }
+            list.concat(tai_label.create(result.lab));
+            result.ofs:=0;
+          end;
+        { sanity check }
+        if result.ofs<>get_string_symofs(st_ansistring,false) then
+          internalerror(2012051701);
 
         getmem(s,len+1);
         move(data^,s^,len);
@@ -82,40 +95,51 @@ uses
       end;
 
 
-    function emit_unicodestring_const(list:TAsmList;data:Pointer;encoding:tstringencoding;Winlike:Boolean):TAsmLabel;
+    function emit_unicodestring_const(list:TAsmList;data:Pointer;encoding:tstringencoding;Winlike:Boolean):tasmlabofs;
       var
-        referencelab: TAsmLabel;
         i, strlength: SizeInt;
       begin
-        current_asmdata.getdatalabel(result);
-        new_section(list,sec_rodata,result.name,const_align(sizeof(pint)));
-        referencelab := nil;
-        if target_info.system in systems_darwin then
-          begin
-            current_asmdata.getdatalabel(referencelab);
-            list.concat(tai_label.create(referencelab));
-          end;
+        current_asmdata.getdatalabel(result.lab);
+        result.ofs:=0;
+        new_section(list,sec_rodata,result.lab.name,const_align(sizeof(pint)));
         strlength := getlengthwidestring(pcompilerwidestring(data));
         if Winlike then
-          list.concat(Tai_const.Create_32bit(strlength*cwidechartype.size))
+          begin
+            list.concat(Tai_const.Create_32bit(strlength*cwidechartype.size));
+            { don't increase result.ofs, this is how Windows widestrings are
+              defined by the OS: a pointer 4 bytes past the length of the
+              string }
+            list.concat(Tai_label.Create(result.lab));
+          end
         else
           begin
+            { put label before header on Darwin, because there the linker considers
+              a global symbol to be the start of a new subsection }
+            if target_info.system in systems_darwin then
+              list.concat(Tai_label.Create(result.lab));
             list.concat(tai_const.create_16bit(encoding));
+            inc(result.ofs,2);
             list.concat(tai_const.create_16bit(2));
+            inc(result.ofs,2);
     {$ifdef cpu64bitaddr}
             { dummy for alignment }
             list.concat(Tai_const.Create_32bit(0));
+            inc(result.ofs,4);
     {$endif cpu64bitaddr}
             list.concat(Tai_const.Create_pint(-1));
+            inc(result.ofs,sizeof(pint));
             list.concat(Tai_const.Create_pint(strlength));
+            inc(result.ofs,sizeof(pint));
+            if not(target_info.system in systems_darwin) then
+              begin
+                { results in slightly more efficient code }
+                list.concat(tai_label.create(result.lab));
+                result.ofs:=0;
+              end;
+            { sanity check }
+            if result.ofs<>get_string_symofs(st_unicodestring,false) then
+              internalerror(2012051702);
           end;
-        { make sure the string doesn't get dead stripped if the header is referenced }
-        if (target_info.system in systems_darwin) then
-          list.concat(tai_directive.create(asd_reference,result.name));
-        list.concat(Tai_label.Create(result));
-        { ... and vice versa }
-        if (target_info.system in systems_darwin) then
-          list.concat(tai_directive.create(asd_reference,referencelab.name));
         if cwidechartype.size = 2 then
           begin
             for i:=0 to strlength-1 do
@@ -128,4 +152,39 @@ uses
       end;
 
 
+    function get_string_symofs(typ: tstringtype; winlikewidestring: boolean): pint;
+      const
+        ansistring_header_size =
+          { encoding }
+          2 +
+          { elesize }
+          2 +
+{$ifdef cpu64bitaddr}
+          { alignment }
+          4 +
+{$endif cpu64bitaddr}
+          { reference count }
+          sizeof(pint) +
+          { length }
+          sizeof(pint);
+        unicodestring_header_size = ansistring_header_size;
+      begin
+        if not(target_info.system in systems_darwin) then
+          result:=0
+        else case typ of
+          st_ansistring:
+            result:=ansistring_header_size;
+          st_unicodestring:
+            result:=unicodestring_header_size;
+          st_widestring:
+            if winlikewidestring then
+              result:=0
+            else
+              result:=unicodestring_header_size;
+          else
+            result:=0;
+        end;
+      end;
+
+
 end.

compiler/assemble.pas

@@ -45,11 +45,11 @@ interface
       TAssembler=class(TAbstractAssembler)
       public
       {filenames}
-        path        : string;
+        path        : TPathStr;
         name        : string;
         AsmFileName,         { current .s and .o file }
         ObjFileName,
-        ppufilename  : string;
+        ppufilename  : TPathStr;
         asmprefix    : string;
         SmartAsm     : boolean;
         SmartFilesCount,
@@ -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;
 
@@ -221,15 +221,15 @@ Implementation
     Constructor TAssembler.Create(smart:boolean);
       begin
       { load start values }
-        AsmFileName:=current_module.AsmFilename^;
-        ObjFileName:=current_module.ObjFileName^;
+        AsmFileName:=current_module.AsmFilename;
+        ObjFileName:=current_module.ObjFileName;
         name:=Lower(current_module.modulename^);
-        path:=current_module.outputpath^;
+        path:=current_module.outputpath;
         asmprefix := current_module.asmprefix^;
-        if not assigned(current_module.outputpath) then
+        if current_module.outputpath = '' then
           ppufilename := ''
         else
-          ppufilename := current_module.ppufilename^;
+          ppufilename := current_module.ppufilename;
         SmartAsm:=smart;
         SmartFilesCount:=0;
         SmartHeaderCount:=0;
@@ -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;
@@ -604,6 +604,14 @@ Implementation
              Replace(result,'$ASM',maybequoted(AsmFileName));
            Replace(result,'$OBJ',maybequoted(ObjFileName));
          end;
+         if (cs_create_pic in current_settings.moduleswitches) then
+		   Replace(result,'$PIC','-KPIC')
+         else
+		   Replace(result,'$PIC','');
+         if (cs_asm_source in current_settings.globalswitches) then
+		   Replace(result,'$NOWARN','')
+		 else
+		   Replace(result,'$NOWARN','-W');
       end;
 
 
@@ -699,7 +707,7 @@ Implementation
           begin
             if (infile<>lastinfile) then
               begin
-                AsmWriteLn(target_asm.comment+'['+infile.name^+']');
+                AsmWriteLn(target_asm.comment+'['+infile.name+']');
                 if assigned(lastinfile) then
                   lastinfile.close;
               end;
@@ -1140,8 +1148,15 @@ Implementation
                          if assigned(objsymend.objsection) then
                            begin
                              if objsymend.objsection<>objsym.objsection then
-                               internalerror(200404124);
-                             Tai_const(hp).value:=objsymend.address-objsym.address+Tai_const(hp).symofs;
+                               begin
+                                 { leb128 relative constants are not relocatable, but other types are,
+                                   given that objsym belongs to the current section. }
+                                 if (Tai_const(hp).consttype in [aitconst_uleb128bit,aitconst_sleb128bit]) or
+                                    (objsym.objsection<>ObjData.CurrObjSec) then
+                                   InternalError(200404124);
+                               end
+                             else
+                               Tai_const(hp).value:=objsymend.address-objsym.address+Tai_const(hp).symofs;
                            end;
                        end;
                    end;
@@ -1257,8 +1272,13 @@ Implementation
                      objsym:=Objdata.SymbolRef(tai_const(hp).sym);
                      objsymend:=Objdata.SymbolRef(tai_const(hp).endsym);
                      if objsymend.objsection<>objsym.objsection then
-                       internalerror(200905042);
-                     Tai_const(hp).value:=objsymend.address-objsym.address+Tai_const(hp).symofs;
+                       begin
+                         if (Tai_const(hp).consttype in [aitconst_uleb128bit,aitconst_sleb128bit]) or
+                            (objsym.objsection<>ObjData.CurrObjSec) then
+                           internalerror(200905042);
+                       end
+                     else
+                       Tai_const(hp).value:=objsymend.address-objsym.address+Tai_const(hp).symofs;
                    end;
                  ObjData.alloc(tai_const(hp).size);
                end;
@@ -1324,6 +1344,7 @@ Implementation
         objsym,
         objsymend : TObjSymbol;
         zerobuf : array[0..63] of byte;
+        relative_reloc: boolean;
       begin
         fillchar(zerobuf,sizeof(zerobuf),0);
         { main loop }
@@ -1388,11 +1409,13 @@ Implementation
                begin
                  { Recalculate relative symbols, addresses of forward references
                    can be changed in treepass1 }
+                 relative_reloc:=false;
                  if assigned(tai_const(hp).sym) and
                     assigned(tai_const(hp).endsym) then
                    begin
                      objsym:=Objdata.SymbolRef(tai_const(hp).sym);
                      objsymend:=Objdata.SymbolRef(tai_const(hp).endsym);
+                     relative_reloc:=(objsym.objsection<>objsymend.objsection);
                      Tai_const(hp).value:=objsymend.address-objsym.address+Tai_const(hp).symofs;
                    end;
                  case tai_const(hp).consttype of
@@ -1404,6 +1427,8 @@ Implementation
                        if assigned(tai_const(hp).sym) and
                           not assigned(tai_const(hp).endsym) then
                          ObjData.writereloc(Tai_const(hp).symofs,tai_const(hp).size,Objdata.SymbolRef(tai_const(hp).sym),RELOC_ABSOLUTE)
+                       else if relative_reloc then
+                         ObjData.writereloc(ObjData.CurrObjSec.size+tai_const(hp).size-objsym.address+tai_const(hp).symofs,tai_const(hp).size,objsymend,RELOC_RELATIVE)
                        else
                          ObjData.writebytes(Tai_const(hp).value,tai_const(hp).size);
                      end;
@@ -1555,7 +1580,7 @@ Implementation
         ObjWriter : TObjectWriter;
       begin
         if not(cs_asm_leave in current_settings.globalswitches) then
-          ObjWriter:=TARObjectWriter.create(current_module.staticlibfilename^)
+          ObjWriter:=TARObjectWriter.create(current_module.staticlibfilename)
         else
           ObjWriter:=TObjectwriter.create;
 

compiler/avr/cgcpu.pas

@@ -470,9 +470,9 @@ unit cgcpu;
                    paraloc1.init;
                    paraloc2.init;
                    paraloc3.init;
-                   paramanager.getintparaloc(pocall_default,1,paraloc1);
-                   paramanager.getintparaloc(pocall_default,2,paraloc2);
-                   paramanager.getintparaloc(pocall_default,3,paraloc3);
+                   paramanager.getintparaloc(pocall_default,1,u16inttype,paraloc1);
+                   paramanager.getintparaloc(pocall_default,2,u16inttype,paraloc2);
+                   paramanager.getintparaloc(pocall_default,3,pasbool8type,paraloc3);
                    a_load_const_cgpara(list,OS_8,0,paraloc3);
                    a_load_reg_cgpara(list,OS_16,src,paraloc2);
                    a_load_reg_cgpara(list,OS_16,dst,paraloc1);
@@ -1451,10 +1451,10 @@ unit cgcpu;
         paraloc1.init;
         paraloc2.init;
         paraloc3.init;
-        paramanager.getintparaloc(pocall_default,1,paraloc1);
-        paramanager.getintparaloc(pocall_default,2,paraloc2);
-        paramanager.getintparaloc(pocall_default,3,paraloc3);
-        a_load_const_cgpara(list,OS_INT,len,paraloc3);
+        paramanager.getintparaloc(pocall_default,1,voidpointertype,paraloc1);
+        paramanager.getintparaloc(pocall_default,2,voidpointertype,paraloc2);
+        paramanager.getintparaloc(pocall_default,3,ptrsinttype,paraloc3);
+        a_load_const_cgpara(list,OS_SINT,len,paraloc3);
         a_loadaddr_ref_cgpara(list,dest,paraloc2);
         a_loadaddr_ref_cgpara(list,source,paraloc1);
         paramanager.freecgpara(list,paraloc3);

compiler/avr/cpubase.pas

@@ -101,11 +101,11 @@ unit cpubase;
 
       { Float Super register first and last }
       first_fpu_supreg    = RS_INVALID;
-      first_fpu_imreg     = RS_INVALID;
+      first_fpu_imreg     = 0;
 
       { MM Super register first and last }
       first_mm_supreg    = RS_INVALID;
-      first_mm_imreg     = RS_INVALID;
+      first_mm_imreg     = 0;
 
       regnumber_count_bsstart = 32;
 
@@ -210,7 +210,8 @@ unit cpubase;
 
       { Defines the default address size for a processor, }
       OS_ADDR = OS_16;
-      { the natural int size for a processor,             }
+      { the natural int size for a processor,
+        has to match osuinttype/ossinttype as initialized in psystem }
       OS_INT = OS_16;
       OS_SINT = OS_S16;
       { the maximum float size for a processor,           }

compiler/avr/cpupara.pas

@@ -38,7 +38,7 @@ unit cpupara;
           function get_volatile_registers_fpu(calloption : tproccalloption):tcpuregisterset;override;
           function push_addr_param(varspez:tvarspez;def : tdef;calloption : tproccalloption) : boolean;override;
           function ret_in_param(def : tdef;calloption : tproccalloption) : boolean;override;
-          procedure getintparaloc(calloption : tproccalloption; nr : longint;var cgpara:TCGPara);override;
+          procedure getintparaloc(calloption : tproccalloption; nr : longint; def : tdef; var cgpara : tcgpara);override;
           function create_paraloc_info(p : tabstractprocdef; side: tcallercallee):longint;override;
           function create_varargs_paraloc_info(p : tabstractprocdef; varargspara:tvarargsparalist):longint;override;
           function  get_funcretloc(p : tabstractprocdef; side: tcallercallee; def: tdef): tcgpara;override;
@@ -69,16 +69,17 @@ unit cpupara;
       end;
 
 
-    procedure tavrparamanager.getintparaloc(calloption : tproccalloption; nr : longint;var cgpara:TCGPara);
+    procedure tavrparamanager.getintparaloc(calloption : tproccalloption; nr : longint; def : tdef; var cgpara : tcgpara);
       var
         paraloc : pcgparalocation;
       begin
         if nr<1 then
           internalerror(2002070801);
         cgpara.reset;
-        cgpara.size:=OS_INT;
-        cgpara.intsize:=tcgsize2size[OS_INT];
+        cgpara.size:=def_cgsize(def);
+        cgpara.intsize:=tcgsize2size[cgpara.size];
         cgpara.alignment:=std_param_align;
+        cgpara.def:=def;
         paraloc:=cgpara.add_location;
         with paraloc^ do
           begin
@@ -271,12 +272,9 @@ unit cpupara;
                 break;
               end;
 
-            if (hp.varspez in [vs_var,vs_out]) or
-               push_addr_param(hp.varspez,paradef,p.proccalloption) or
-               is_open_array(paradef) or
-               is_array_of_const(paradef) then
+            if push_addr_param(hp.varspez,paradef,p.proccalloption) then
               begin
-                paradef:=voidpointertype;
+                paradef:=getpointerdef(paradef);
                 loc:=LOC_REGISTER;
                 paracgsize := OS_ADDR;
                 paralen := tcgsize2size[OS_ADDR];
@@ -299,7 +297,8 @@ unit cpupara;
                     if (paracgsize=OS_NO) then
                       begin
                         paracgsize:=OS_ADDR;
-                        paralen := tcgsize2size[OS_ADDR];
+                        paralen:=tcgsize2size[OS_ADDR];
+                        paradef:=voidpointertype;
                       end;
                   end
               end;
@@ -307,6 +306,7 @@ unit cpupara;
              hp.paraloc[side].size:=paracgsize;
              hp.paraloc[side].Alignment:=std_param_align;
              hp.paraloc[side].intsize:=paralen;
+             hp.paraloc[side].def:=paradef;
 
 {$ifdef EXTDEBUG}
              if paralen=0 then
@@ -415,38 +415,8 @@ unit cpupara;
         retcgsize : tcgsize;
         paraloc : pcgparalocation;
       begin
-        result.init;
-        result.alignment:=get_para_align(p.proccalloption);
-        { 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_ADDR;
-            result.intsize:=sizeof(pint);
-          end
-        else
-          begin
-            retcgsize:=def_cgsize(def);
-            result.intsize:=def.size;
-          end;
-        result.size:=retcgsize;
-        { Return is passed as var parameter }
-        if ret_in_param(def,p.proccalloption) then
-          begin
-            paraloc:=result.add_location;
-            paraloc^.loc:=LOC_REFERENCE;
-            paraloc^.size:=retcgsize;
-            exit;
-          end;
+         if set_common_funcretloc_info(p,def,retcgsize,result) then
+           exit;
 
         paraloc:=result.add_location;
         { Return in FPU register? }

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/avr/navrmat.pas

@@ -45,7 +45,7 @@ implementation
       cutils,verbose,globals,constexp,
       aasmbase,aasmcpu,aasmtai,aasmdata,
       defutil,
-      cgbase,cgobj,cgutils,
+      cgbase,cgobj,hlcgobj,cgutils,
       pass_2,procinfo,
       ncon,
       cpubase,
@@ -168,8 +168,8 @@ implementation
 {
         { put numerator in register }
         size:=def_cgsize(left.resultdef);
-        location_force_reg(current_asmdata.CurrAsmList,left.location,
-          size,true);
+        hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,
+          left.resultdef,left.resultdef,true);
         location_copy(location,left.location);
         numerator:=location.register;
         resultreg:=location.register;
@@ -241,7 +241,7 @@ implementation
               LOC_REGISTER,LOC_CREGISTER,LOC_REFERENCE,LOC_CREFERENCE,
               LOC_SUBSETREG,LOC_CSUBSETREG,LOC_SUBSETREF,LOC_CSUBSETREF :
                 begin
-                  location_force_reg(current_asmdata.CurrAsmList,left.location,def_cgsize(left.resultdef),true);
+                  hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,left.resultdef,true);
                   current_asmdata.CurrAsmList.concat(taicpu.op_reg_const(A_CPI,left.location.register,0));
                   tmpreg:=left.location.register;
 

compiler/avr/raavrgas.pas

@@ -59,7 +59,7 @@ Unit raavrgas;
       procinfo,
       itcpugas,
       rabase,rautils,
-      cgbase,cgobj
+      cgbase,cgutils,cgobj
       ;
 
 

compiler/browcol.pas

@@ -1699,9 +1699,9 @@ end;
           begin
             DefPos:=tstoredsym(sym).FileInfo;
             inputfile:=get_source_file(defpos.moduleindex,defpos.fileindex);
-            if Assigned(inputfile) and Assigned(inputfile.name) then
+            if Assigned(inputfile) and (inputfile.name<>'') then
               begin
-                New(Reference, Init(ModuleNames^.Add(inputfile.name^),
+                New(Reference, Init(ModuleNames^.Add(inputfile.name),
                   DefPos.line,DefPos.column));
                 Symbol^.References^.Insert(Reference);
               end;
@@ -1712,9 +1712,9 @@ end;
             while assigned(Ref) do
               begin
                 inputfile:=get_source_file(ref.refinfo.moduleindex,ref.refinfo.fileindex);
-                if Assigned(inputfile) and Assigned(inputfile.name) then
+                if Assigned(inputfile) and (inputfile.name<>'') then
                   begin
-                    New(Reference, Init(ModuleNames^.Add(inputfile.name^),
+                    New(Reference, Init(ModuleNames^.Add(inputfile.name),
                       ref.refinfo.line,ref.refinfo.column));
                     Symbol^.References^.Insert(Reference);
                   end;
@@ -1773,7 +1773,7 @@ begin
        if assigned(t) then
          begin
            name:=GetStr(T.Name);
-           msource:=GetStr(hp.mainsource);
+           msource:=hp.mainsource;
            New(UnitS, Init(Name,msource));
            if Assigned(hp.loaded_from) then
              if assigned(hp.loaded_from.globalsymtable) then
@@ -1785,8 +1785,8 @@ begin
              pif:=hp.sourcefiles.files;
              while (pif<>nil) do
              begin
-               path:=GetStr(pif.path);
-               name:=GetStr(pif.name);
+               path:=pif.path;
+               name:=pif.name;
                UnitS^.AddSourceFile(path+name);
                pif:=pif.next;
              end;
@@ -1994,7 +1994,6 @@ end;
 procedure BuildSourceList;
 var m: tmodule;
     s: tinputfile;
-    p: pstring;
     ppu,obj: string;
     source: string;
 begin
@@ -2009,24 +2008,18 @@ begin
     m:=tmodule(loaded_units.first);
     while assigned(m) do
     begin
-      obj:=ExpandFileName(m.objfilename^);
+      obj:=ExpandFileName(m.objfilename);
       ppu:=''; source:='';
       if m.is_unit then
-        ppu:=ExpandFileName(m.ppufilename^);
+        ppu:=ExpandFileName(m.ppufilename);
       if (m.is_unit=false) and (m.islibrary=false) then
-        ppu:=ExpandFileName(m.exefilename^);
+        ppu:=ExpandFileName(m.exefilename);
       if assigned(m.sourcefiles) then
         begin
           s:=m.sourcefiles.files;
           while assigned(s) do
           begin
-            source:='';
-            p:=s.path;
-            if assigned(p) then
-              source:=source+p^;
-            p:=s.name;
-            if assigned(p) then
-              source:=source+p^;
+            source:=s.path+s.name;
             source:=ExpandFileName(source);
 
             sourcefiles^.Insert(New(PSourceFile, Init(source,obj,ppu)));

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,23 @@ 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 UnixRequoteWithDoubleQuotes(const QuotedStr: TCmdStr): TCmdStr;
+    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 +1244,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 +1300,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 UnixRequoteWithDoubleQuotes(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 (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,UnixRequoteWithDoubleQuotes(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

@@ -102,7 +102,7 @@ unit cg64f32;
        globtype,systems,constexp,
        verbose,cutils,
        symbase,symconst,symdef,symtable,defutil,paramgr,
-       tgobj;
+       tgobj,hlcgobj;
 
 {****************************************************************************
                                      Helpers
@@ -313,9 +313,9 @@ unit cg64f32;
             tmpsref.ref.index:=tmpreg;
           end;
         tmpsref.bitlen:=32;
-        cg.a_load_subsetref_reg(list,OS_32,OS_32,tmpsref,destreg.reglo);
+        hlcg.a_load_subsetref_reg(list,u32inttype,u32inttype,tmpsref,destreg.reglo);
         inc(tmpsref.ref.offset,4);
-        cg.a_load_subsetref_reg(list,OS_32,OS_32,tmpsref,destreg.reghi);
+        hlcg.a_load_subsetref_reg(list,u32inttype,u32inttype,tmpsref,destreg.reghi);
       end;
 
 
@@ -342,9 +342,9 @@ unit cg64f32;
           end;
         tmpsref:=sref;
         tmpsref.bitlen:=32;
-        cg.a_load_reg_subsetref(list,OS_32,OS_32,fromreg.reglo,tmpsref);
+        hlcg.a_load_reg_subsetref(list,u32inttype,u32inttype,fromreg.reglo,tmpsref);
         inc(tmpsref.ref.offset,4);
-        cg.a_load_reg_subsetref(list,OS_32,OS_32,fromreg.reghi,tmpsref);
+        hlcg.a_load_reg_subsetref(list,u32inttype,u32inttype,fromreg.reghi,tmpsref);
       end;
 
 
@@ -360,9 +360,9 @@ unit cg64f32;
           swap64(a);
         tmpsref := sref;
         tmpsref.bitlen := 32;
-        cg.a_load_const_subsetref(list,OS_32,aint(lo(a)),tmpsref);
+        hlcg.a_load_const_subsetref(list,u32inttype,aint(lo(a)),tmpsref);
         inc(tmpsref.ref.offset,4);
-        cg.a_load_const_subsetref(list,OS_32,aint(hi(a)),tmpsref);
+        hlcg.a_load_const_subsetref(list,u32inttype,aint(hi(a)),tmpsref);
       end;
 
 
@@ -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                                          }
@@ -796,7 +796,7 @@ unit cg64f32;
                  temploc.reference.alignment:=newalignment(temploc.reference.alignment,4);
                end;
 
-             cg.g_rangecheck(list,temploc,hdef,todef);
+             hlcg.g_rangecheck(list,temploc,hdef,todef);
              hdef.owner.deletedef(hdef);
 
              if from_signed and to_signed then
@@ -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)               }
@@ -827,7 +827,7 @@ unit cg64f32;
                  hdef:=torddef.create(s32bit,int64(longint($80000000)),int64(-1));
                  location_copy(temploc,l);
                  temploc.size:=OS_32;
-                 cg.g_rangecheck(list,temploc,hdef,todef);
+                 hlcg.g_rangecheck(list,temploc,hdef,todef);
                  hdef.owner.deletedef(hdef);
                  cg.a_label(list,endlabel);
                end;
@@ -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,
@@ -216,7 +220,6 @@ interface
       end;
 
       { Set type definition for registers }
-      tcpuregisterset = set of byte;
       tsuperregisterset = array[byte] of set of byte;
 
       pmmshuffle = ^tmmshuffle;
@@ -260,10 +263,6 @@ interface
        { Invalid register number }
        RS_INVALID    = high(tsuperregister);
 
-       { Maximum number of cpu registers per register type,
-         this must fit in tcpuregisterset }
-       maxcpuregister = 32;
-
        tcgsize2size : Array[tcgsize] of integer =
          { integer values }
         (0,1,2,4,8,16,1,2,4,8,16,

compiler/cghlcpu.pas

@@ -0,0 +1,217 @@
+{
+    Copyright (c) 2012 by Jonas Maebe
+    Member of the Free Pascal development team
+
+    This unit replaces all abstract methods of cgobj that are unused for
+    targets that are based on the high level code generator with stubs that
+    result in an internalerror
+
+    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 cghlcpu;
+
+{$mode objfpc}
+
+interface
+
+uses
+  globtype,verbose,
+  aasmbase,aasmdata,
+  symtype,symdef,
+  cpubase,cgbase,cgutils,cgobj;
+
+  type
+    thlbasecgcpu = class(tcg)
+     public
+      procedure g_stackpointer_alloc(list: TAsmList; size: longint); override;
+      procedure g_proc_exit(list: TAsmList; parasize: longint; nostackframe: boolean); override;
+      procedure g_proc_entry(list: TAsmList; localsize: longint; nostackframe: boolean); override;
+      procedure g_overflowcheck(list: TAsmList; const Loc: tlocation; def: tdef); override;
+      procedure g_intf_wrapper(list: TAsmList; procdef: tprocdef; const labelname: string; ioffset: longint); override;
+{$ifdef cpuflags}
+      procedure g_flags2reg(list: TAsmList; size: TCgSize; const f: tresflags; reg: TRegister); override;
+      procedure a_jmp_flags(list: TAsmList; const f: TResFlags; l: tasmlabel); override;
+{$endif}
+      procedure g_concatcopy(list: TAsmList; const source, dest: treference; len: tcgint); override;
+      procedure a_op_reg_reg(list: TAsmList; Op: TOpCG; size: TCGSize; reg1, reg2: TRegister); override;
+      procedure a_op_const_reg(list: TAsmList; Op: TOpCG; size: TCGSize; a: tcgint; reg: TRegister); override;
+      procedure a_load_reg_reg(list: TAsmList; fromsize, tosize: tcgsize; reg1, reg2: tregister); override;
+      procedure a_load_reg_ref(list: TAsmList; fromsize, tosize: tcgsize; register: tregister; const ref: treference); override;
+      procedure a_load_ref_reg(list: TAsmList; fromsize, tosize: tcgsize; const ref: treference; register: tregister); override;
+      procedure a_load_const_reg(list: TAsmList; size: tcgsize; a: tcgint; register: tregister); override;
+      procedure a_loadfpu_reg_reg(list: TAsmList; fromsize, tosize: tcgsize; reg1, reg2: tregister); override;
+      procedure a_loadfpu_reg_ref(list: TAsmList; fromsize, tosize: tcgsize; reg: tregister; const ref: treference); override;
+      procedure a_loadfpu_ref_reg(list: TAsmList; fromsize, tosize: tcgsize; const ref: treference; reg: tregister); override;
+      procedure a_loadaddr_ref_reg(list: TAsmList; const ref: treference; r: tregister); override;
+      procedure a_jmp_name(list: TAsmList; const s: string); override;
+      procedure a_jmp_always(list: TAsmList; l: tasmlabel); override;
+      procedure a_cmp_reg_reg_label(list: TAsmList; size: tcgsize; cmp_op: topcmp; reg1, reg2: tregister; l: tasmlabel); override;
+      procedure a_call_reg(list: TAsmList; reg: tregister); override;
+      procedure a_call_name(list: TAsmList; const s: string; weak: boolean); override;
+      procedure a_bit_scan_reg_reg(list: TAsmList; reverse: boolean; size: tcgsize; src, dst: TRegister); override;
+    end;
+
+implementation
+
+   { thlbasecgcpu }
+
+    procedure thlbasecgcpu.a_bit_scan_reg_reg(list: TAsmList; reverse: boolean; size: tcgsize; src, dst: TRegister);
+      begin
+        internalerror(2012042801);
+      end;
+
+
+    procedure thlbasecgcpu.a_call_name(list: TAsmList; const s: string; weak: boolean);
+      begin
+        internalerror(2012042802);
+      end;
+
+
+    procedure thlbasecgcpu.a_call_reg(list: TAsmList; reg: tregister);
+      begin
+        internalerror(2012042803);
+      end;
+
+
+    procedure thlbasecgcpu.a_cmp_reg_reg_label(list: TAsmList; size: tcgsize; cmp_op: topcmp; reg1, reg2: tregister; l: tasmlabel);
+      begin
+        internalerror(2012042804);
+      end;
+
+
+    procedure thlbasecgcpu.a_jmp_always(list: TAsmList; l: tasmlabel);
+      begin
+        internalerror(2012042805);
+      end;
+
+{$ifdef cpuflags}
+    procedure thlbasecgcpu.a_jmp_flags(list: TAsmList; const f: TResFlags; l: tasmlabel);
+      begin
+        internalerror(2012042806);
+      end;
+{$endif}
+
+    procedure thlbasecgcpu.a_jmp_name(list: TAsmList; const s: string);
+      begin
+        internalerror(2012042807);
+      end;
+
+
+    procedure thlbasecgcpu.a_loadaddr_ref_reg(list: TAsmList; const ref: treference; r: tregister);
+      begin
+        internalerror(2012042808);
+      end;
+
+    procedure thlbasecgcpu.a_loadfpu_ref_reg(list: TAsmList; fromsize, tosize: tcgsize; const ref: treference; reg: tregister);
+      begin
+        internalerror(2012042809);
+      end;
+
+
+    procedure thlbasecgcpu.a_loadfpu_reg_ref(list: TAsmList; fromsize, tosize: tcgsize; reg: tregister; const ref: treference);
+      begin
+        internalerror(2012042810);
+      end;
+
+
+    procedure thlbasecgcpu.a_loadfpu_reg_reg(list: TAsmList; fromsize, tosize: tcgsize; reg1, reg2: tregister);
+      begin
+        internalerror(2012042811);
+      end;
+
+
+    procedure thlbasecgcpu.a_load_const_reg(list: TAsmList; size: tcgsize; a: tcgint; register: tregister);
+      begin
+        internalerror(2012042812);
+      end;
+
+
+    procedure thlbasecgcpu.a_load_ref_reg(list: TAsmList; fromsize, tosize: tcgsize; const ref: treference; register: tregister);
+      begin
+        internalerror(2012042813);
+      end;
+
+
+    procedure thlbasecgcpu.a_load_reg_ref(list: TAsmList; fromsize, tosize: tcgsize; register: tregister; const ref: treference);
+      begin
+        internalerror(2012042814);
+      end;
+
+
+    procedure thlbasecgcpu.a_load_reg_reg(list: TAsmList; fromsize, tosize: tcgsize; reg1, reg2: tregister);
+      begin
+        internalerror(2012042815);
+      end;
+
+
+    procedure thlbasecgcpu.a_op_const_reg(list: TAsmList; Op: TOpCG; size: TCGSize; a: tcgint; reg: TRegister);
+      begin
+        internalerror(2012042816);
+      end;
+
+
+    procedure thlbasecgcpu.a_op_reg_reg(list: TAsmList; Op: TOpCG; size: TCGSize; reg1, reg2: TRegister);
+      begin
+        internalerror(2012042817);
+      end;
+
+
+    procedure thlbasecgcpu.g_concatcopy(list: TAsmList; const source, dest: treference; len: tcgint);
+      begin
+        internalerror(2012042818);
+      end;
+
+{$ifdef cpuflags}
+    procedure thlbasecgcpu.g_flags2reg(list: TAsmList; size: TCgSize; const f: tresflags; reg: TRegister);
+      begin
+        internalerror(2012042819);
+      end;
+{$endif}
+
+    procedure thlbasecgcpu.g_intf_wrapper(list: TAsmList; procdef: tprocdef; const labelname: string; ioffset: longint);
+      begin
+        internalerror(2012042820);
+      end;
+
+
+    procedure thlbasecgcpu.g_overflowcheck(list: TAsmList; const Loc: tlocation; def: tdef);
+      begin
+        internalerror(2012042820);
+      end;
+
+
+    procedure thlbasecgcpu.g_proc_entry(list: TAsmList; localsize: longint; nostackframe: boolean);
+      begin
+        internalerror(2012042821);
+      end;
+
+
+    procedure thlbasecgcpu.g_proc_exit(list: TAsmList; parasize: longint; nostackframe: boolean);
+      begin
+        internalerror(2012042822);
+      end;
+
+
+    procedure thlbasecgcpu.g_stackpointer_alloc(list: TAsmList; size: longint);
+      begin
+        internalerror(2012042823);
+      end;
+
+
+end.
+

compiler/cgutils.pas

@@ -32,7 +32,20 @@ unit cgutils;
       aasmbase,
       cpubase,cgbase;
 
+    const
+      { implementation of max function using only functionality that can be
+        evaluated as a constant expression by the compiler -- this is
+        basically maxcpureg = max(max(first_int_imreg,first_fpu_imreg),first_mm_imreg)-1 }
+      tmpmaxcpufpuintreg = first_int_imreg + ((first_fpu_imreg - first_int_imreg) * ord(first_int_imreg < first_fpu_imreg));
+      maxcpuregister = (tmpmaxcpufpuintreg + ((first_mm_imreg - tmpmaxcpufpuintreg) * ord(tmpmaxcpufpuintreg < first_mm_imreg)))-1;
+
     type
+      { Set type definition for cpuregisters }
+      tcpuregisterset = set of 0..maxcpuregister;
+
+{$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 +74,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/comphook.pas

@@ -130,8 +130,8 @@ function  def_CheckVerbosity(v:longint):boolean;
 procedure def_initsymbolinfo;
 procedure def_donesymbolinfo;
 procedure def_extractsymbolinfo;
-function  def_openinputfile(const filename: string): tinputfile;
-Function  def_getnamedfiletime(Const F : String) : Longint;
+function  def_openinputfile(const filename: TPathStr): tinputfile;
+Function  def_getnamedfiletime(Const F : TPathStr) : Longint;
 { Function redirecting for IDE support }
 type
   tstopprocedure         = procedure(err:longint);
@@ -143,8 +143,8 @@ type
   tinitsymbolinfoproc = procedure;
   tdonesymbolinfoproc = procedure;
   textractsymbolinfoproc = procedure;
-  topeninputfilefunc = function(const filename: string): tinputfile;
-  tgetnamedfiletimefunc = function(const filename: string): longint;
+  topeninputfilefunc = function(const filename: TPathStr): tinputfile;
+  tgetnamedfiletimefunc = function(const filename: TPathStr): longint;
 
 const
   do_status        : tstatusfunction  = @def_status;
@@ -394,13 +394,13 @@ procedure def_extractsymbolinfo;
 begin
 end;
 
-function  def_openinputfile(const filename: string): tinputfile;
+function  def_openinputfile(const filename: TPathStr): tinputfile;
 begin
   def_openinputfile:=tdosinputfile.create(filename);
 end;
 
 
-Function def_GetNamedFileTime (Const F : String) : Longint;
+Function def_GetNamedFileTime (Const F : TPathStr) : Longint;
 begin
   Result:=FileAge(F);
 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);
@@ -253,7 +262,7 @@ var
   end;
 
 begin
-  srcfilepath:=ExtractFilePath(current_module.mainsource^);
+  srcfilepath:=ExtractFilePath(current_module.mainsource);
   if output=roRES then
     begin
       s:=target_res.rccmd;
@@ -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;
@@ -396,7 +424,7 @@ begin
       Include(current_settings.globalswitches, cs_link_nolink);
       exit;
     end;
-  dst:=CFileStreamClass.Create(current_module.outputpath^+outf,fmCreate);
+  dst:=CFileStreamClass.Create(current_module.outputpath+outf,fmCreate);
   if CStreamError<>0 then
     begin
       Message1(exec_e_cant_write_resource_file, dst.FileName);
@@ -418,10 +446,11 @@ 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^));
+  p:=ExtractFilePath(ExpandFileName(current_module.mainsource));
   res:=TCmdStrListItem(current_module.ResourceFiles.First);
   while res<>nil do
     begin
@@ -440,7 +469,7 @@ begin
       if resourcefile.IsCompiled(s) then
         begin
           resourcefile.free;
-          if AnsiCompareFileName(IncludeTrailingPathDelimiter(ExpandFileName(current_module.outputpath^)), p) <> 0 then
+          if AnsiCompareFileName(IncludeTrailingPathDelimiter(ExpandFileName(current_module.outputpath)), p) <> 0 then
             begin
               { Copy .res file to units output dir. Otherwise .res file will not be found
                 when only compiled units path is available }
@@ -462,7 +491,7 @@ begin
               outfmt:=roRES;
               res.FPStr:=ChangeFileExt(res.FPStr,target_info.resext);
             end;
-          resourcefile.compile(outfmt, current_module.outputpath^+res.FPStr);
+          resourcefile.compile(outfmt, current_module.outputpath+res.FPStr);
           resourcefile.free;
         end;
       res:=TCmdStrListItem(res.Next);
@@ -486,9 +515,9 @@ var
           s:=res.FPStr
         else
           begin
-            s:=u.path^+res.FPStr;
+            s:=u.path+res.FPStr;
             if not FileExists(s,True) then
-              s:=u.outputpath^+res.FPStr;
+              s:=u.outputpath+res.FPStr;
           end;
         resourcefile.Collect(s);
         res:=TCmdStrListItem(res.Next);
@@ -504,7 +533,7 @@ begin
       exit;
 //  if cs_link_nolink in current_settings.globalswitches then
 //    exit;
-  s:=ChangeFileExt(current_module.ppufilename^,target_info.resobjext);
+  s:=ChangeFileExt(current_module.ppufilename,target_info.resobjext);
   if (res_arch_in_file_name in target_res.resflags) then
     s:=ChangeFileExt(s,'.'+cpu2str[target_cpu]+target_info.resobjext);
   resourcefile:=TResourceFile(resinfos[target_info.res]^.resourcefileclass.create(s));

compiler/cresstr.pas

@@ -133,7 +133,7 @@ uses
     procedure Tresourcestrings.CreateResourceStringData;
       Var
         namelab,
-        valuelab : tasmlabel;
+        valuelab : tasmlabofs;
         resstrlab : tasmsymbol;
         endsymlab : tasmsymbol;
         R : TResourceStringItem;
@@ -151,7 +151,7 @@ uses
 
         { Write unitname entry }
         namelab:=emit_ansistring_const(current_asmdata.asmlists[al_const],@current_module.localsymtable.name^[1],length(current_module.localsymtable.name^),getansistringcodepage,False);
-        current_asmdata.asmlists[al_resourcestrings].concat(tai_const.create_sym(namelab));
+        current_asmdata.asmlists[al_resourcestrings].concat(tai_const.Create_sym_offset(namelab.lab,namelab.ofs));
         current_asmdata.asmlists[al_resourcestrings].concat(tai_const.create_sym(nil));
         current_asmdata.asmlists[al_resourcestrings].concat(tai_const.create_sym(nil));
         current_asmdata.asmlists[al_resourcestrings].concat(tai_const.create_32bit(0));
@@ -168,7 +168,10 @@ uses
             if assigned(R.value) and (R.len<>0) then
               valuelab:=emit_ansistring_const(current_asmdata.asmlists[al_const],R.Value,R.Len,getansistringcodepage,False)
             else
-              valuelab:=nil;
+              begin
+                valuelab.lab:=nil;
+                valuelab.ofs:=0;
+              end;
             { Append the name as a ansistring. }
             current_asmdata.asmlists[al_const].concat(cai_align.Create(const_align(sizeof(pint))));
             namelab:=emit_ansistring_const(current_asmdata.asmlists[al_const],@R.Name[1],length(R.name),getansistringcodepage,False);
@@ -185,9 +188,9 @@ uses
             new_section(current_asmdata.asmlists[al_resourcestrings],sec_data,make_mangledname('RESSTR',current_module.localsymtable,'2_'+r.name),sizeof(pint));
             resstrlab:=current_asmdata.DefineAsmSymbol(make_mangledname('RESSTR',R.Sym.owner,R.Sym.name),AB_GLOBAL,AT_DATA);
             current_asmdata.asmlists[al_resourcestrings].concat(tai_symbol.Create_global(resstrlab,0));
-            current_asmdata.asmlists[al_resourcestrings].concat(tai_const.create_sym(namelab));
-            current_asmdata.asmlists[al_resourcestrings].concat(tai_const.create_sym(valuelab));
-            current_asmdata.asmlists[al_resourcestrings].concat(tai_const.create_sym(valuelab));
+            current_asmdata.asmlists[al_resourcestrings].concat(tai_const.Create_sym_offset(namelab.lab,namelab.ofs));
+            current_asmdata.asmlists[al_resourcestrings].concat(tai_const.Create_sym_offset(valuelab.lab,valuelab.ofs));
+            current_asmdata.asmlists[al_resourcestrings].concat(tai_const.Create_sym_offset(valuelab.lab,valuelab.ofs));
             current_asmdata.asmlists[al_resourcestrings].concat(tai_const.create_32bit(longint(R.Hash)));
 {$ifdef cpu64bitaddr}
             current_asmdata.asmlists[al_resourcestrings].concat(tai_const.create_32bit(0));
@@ -230,7 +233,7 @@ uses
         end;
 
       begin
-        ResFileName:=ChangeFileExt(current_module.ppufilename^,'.rst');
+        ResFileName:=ChangeFileExt(current_module.ppufilename,'.rst');
         message1 (general_i_writingresourcefile,ExtractFileName(ResFileName));
         Assign(F,ResFileName);
         {$push}{$i-}

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
@@ -731,27 +813,11 @@ implementation
     {
       return if value is a power of 2. And if correct return the power
     }
-      var
-         hl : int64;
-         i : longint;
       begin
-         if value and (value - 1) <> 0 then
-           begin
-             ispowerof2 := false;
-             exit
-           end;
-         hl:=1;
-         ispowerof2:=true;
-         for i:=0 to 63 do
-           begin
-              if hl=value then
-                begin
-                   power:=i;
-                   exit;
-                end;
-              hl:=hl shl 1;
-           end;
-         ispowerof2:=false;
+        if (value = 0) or (value and (value - 1) <> 0) then
+          exit(false);
+        power:=BsfQWord(value);
+        result:=true;
       end;
 
 
@@ -822,93 +888,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

@@ -1040,13 +1040,13 @@ implementation
         diridx: Integer;
         fileitem: TFileIndexItem;
       begin
-        if afile.path^ = '' then
+        if afile.path = '' then
           dirname := '.'
         else
           begin
             { add the canonical form here already to avoid problems with }
             { paths such as './' etc                                     }
-            dirname := relative_dwarf_path(afile.path^);
+            dirname := relative_dwarf_path(afile.path);
             if dirname = '' then
               dirname := '.';
           end;
@@ -1055,11 +1055,11 @@ implementation
           diritem := TDirIndexItem.Create(dirlist,dirname, dirlist.Count);
         diridx := diritem.IndexNr;
 
-        fileitem := TFileIndexItem(diritem.files.Find(afile.name^));
+        fileitem := TFileIndexItem(diritem.files.Find(afile.name));
         if fileitem = nil then
           begin
             Inc(filesequence);
-            fileitem := TFileIndexItem.Create(diritem.files,afile.name^, diridx, filesequence);
+            fileitem := TFileIndexItem.Create(diritem.files,afile.name, diridx, filesequence);
           end;
         Result := fileitem.IndexNr;
       end;
@@ -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,
@@ -3090,7 +3090,7 @@ implementation
 
         { first manadatory compilation unit TAG }
         append_entry(DW_TAG_compile_unit,true,[
-          DW_AT_name,DW_FORM_string,relative_dwarf_path(current_module.sourcefiles.get_file(1).path^+current_module.sourcefiles.get_file(1).name^)+#0,
+          DW_AT_name,DW_FORM_string,relative_dwarf_path(current_module.sourcefiles.get_file(1).path+current_module.sourcefiles.get_file(1).name)+#0,
           DW_AT_producer,DW_FORM_string,'Free Pascal '+full_version_string+' '+date_string+#0,
           DW_AT_comp_dir,DW_FORM_string,BSToSlash(FixPath(GetCurrentDir,false))+#0,
           DW_AT_language,DW_FORM_data1,DW_LANG_Pascal83,
@@ -3308,13 +3308,13 @@ implementation
                         currfileidx := get_file_index(infile);
                         if prevfileidx <> currfileidx then
                           begin
-                            list.insertbefore(tai_comment.Create(strpnew('path: '+infile.path^)), hp);
-                            list.insertbefore(tai_comment.Create(strpnew('file: '+infile.name^)), hp);
+                            list.insertbefore(tai_comment.Create(strpnew('path: '+infile.path)), hp);
+                            list.insertbefore(tai_comment.Create(strpnew('file: '+infile.name)), hp);
                             list.insertbefore(tai_comment.Create(strpnew('indx: '+tostr(currfileidx))), hp);
 
                             { set file }
-                            asmline.concat(tai_comment.Create(strpnew('path: '+infile.path^)));
-                            asmline.concat(tai_comment.Create(strpnew('file: '+infile.name^)));
+                            asmline.concat(tai_comment.Create(strpnew('path: '+infile.path)));
+                            asmline.concat(tai_comment.Create(strpnew('file: '+infile.name)));
                             asmline.concat(tai_const.create_8bit(DW_LNS_set_file));
                             asmline.concat(tai_const.create_uleb128bit(currfileidx));
 
@@ -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

@@ -149,11 +149,38 @@ implementation
     uses
       SysUtils,cutils,cfileutl,
       globals,globtype,verbose,constexp,
-      defutil,
-      cpuinfo,cpubase,paramgr,
+      defutil, cgutils, parabase,
+      cpuinfo,cpubase,cpupi,paramgr,
       aasmbase,procinfo,
       finput,fmodule,ppu;
 
+
+    const
+      current_procdef : tprocdef = nil;
+
+    function GetOffsetStr(reference : TReference) : string;
+    begin
+{$ifdef MIPS}
+      if (reference.index=NR_STACK_POINTER_REG) or
+         (reference.base=NR_STACK_POINTER_REG)  then
+        GetOffsetStr:=tostr(reference.offset
+          - mips_extra_offset(current_procdef))
+      else
+{$endif MIPS}
+      GetOffsetStr:=tostr(reference.offset);
+    end;
+
+    function GetParaOffsetStr(reference : TCGParaReference) : string;
+    begin
+{$ifdef MIPS}
+      if reference.index=NR_STACK_POINTER_REG then
+        GetParaOffsetStr:=tostr(reference.offset
+          - mips_extra_offset(current_procdef))
+      else
+{$endif MIPS}
+      GetParaOffsetStr:=tostr(reference.offset);
+    end;
+
     function GetSymName(Sym : TSymEntry) : string;
     begin
       if Not (cs_stabs_preservecase in current_settings.globalswitches) then
@@ -573,14 +600,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 +616,7 @@ implementation
          st_ansistring:
            begin
              { looks like a pchar }
-             ss:='*'+def_stab_number(cchartype);
+             ss:='*'+def_stab_number(cansichartype);
            end;
          st_unicodestring,
          st_widestring:
@@ -734,17 +761,17 @@ implementation
       begin
 {$ifdef cpu64bitaddr}
         ss:=def_stabstr_evaluate(def,'s${savesize}HANDLE:$1,0,32;MODE:$1,32,32;RECSIZE:$2,64,64;'+
-                                 '_PRIVATE:ar$1;1;64;$3,128,256;USERDATA:ar$1;1;16;$3,384,128;'+
-                                 'NAME:ar$1;0;255;$4,512,2048;;',[def_stab_number(s32inttype),
+                                 '_PRIVATE:ar$1;1;64;$3,128,256;USERDATA:ar$1;1;32;$3,384,256;'+
+                                 'NAME:ar$1;0;255;$4,640,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),
+                                 '_PRIVATE:ar$1;1;32;$3,96,256;USERDATA:ar$1;1;32;$2,352,256;'+
+                                 'NAME:ar$1;0;255;$3,608,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 +984,7 @@ implementation
                 appenddef(list,cwidechartype)
               else
                 begin
-                  appenddef(list,cchartype);
+                  appenddef(list,cansichartype);
                   appenddef(list,u8inttype);
                 end;
             end;
@@ -970,7 +997,7 @@ implementation
               appenddef(list,s64inttype);
 {$endif cpu64bitaddr}
               appenddef(list,u8inttype);
-              appenddef(list,cchartype);
+              appenddef(list,cansichartype);
             end;
           classrefdef :
             appenddef(list,pvmttype);
@@ -1052,6 +1079,7 @@ implementation
       var
         hs : ansistring;
         templist : TAsmList;
+        prev_procdef : tprocdef;
       begin
         if not(def.in_currentunit) or
            { happens for init procdef of units without init section }
@@ -1060,6 +1088,8 @@ implementation
 
         { mark as used so the local type defs also be written }
         def.dbg_state:=dbg_state_used;
+        prev_procdef:=current_procdef;
+        current_procdef:=def;
 
         templist:=gen_procdef_endsym_stabs(def);
         current_asmdata.asmlists[al_procedures].insertlistafter(def.procendtai,templist);
@@ -1090,11 +1120,11 @@ implementation
                   hs:='X';
                 templist.concat(Tai_stab.create(stabsdir,strpnew(
                    '"'+GetSymName(def.procsym)+':'+hs+def_stab_number(def.returndef)+'",'+
-                   base_stabs_str(localvarsymref_stab,'0','0',tostr(tabstractnormalvarsym(def.funcretsym).localloc.reference.offset)))));
+                   base_stabs_str(localvarsymref_stab,'0','0',getoffsetstr(tabstractnormalvarsym(def.funcretsym).localloc.reference)))));
                 if (m_result in current_settings.modeswitches) then
                   templist.concat(Tai_stab.create(stabsdir,strpnew(
                      '"RESULT:'+hs+def_stab_number(def.returndef)+'",'+
-                     base_stabs_str(localvarsymref_stab,'0','0',tostr(tabstractnormalvarsym(def.funcretsym).localloc.reference.offset)))));
+                     base_stabs_str(localvarsymref_stab,'0','0',getoffsetstr(tabstractnormalvarsym(def.funcretsym).localloc.reference)))));
               end;
           end;
 
@@ -1102,6 +1132,7 @@ implementation
         current_asmdata.asmlists[al_procedures].insertlistbefore(def.procstarttai,templist);
 
         templist.free;
+        current_procdef:=prev_procdef;
       end;
 
 
@@ -1256,7 +1287,7 @@ implementation
           LOC_REFERENCE :
             { offset to ebp => will not work if the framepointer is esp
               so some optimizing will make things harder to debug }
-            ss:=sym_stabstr_evaluate(sym,'"${name}:$1",'+base_stabs_str(localvarsymref_stab,'0','${line}','$2'),[st,tostr(sym.localloc.reference.offset)])
+            ss:=sym_stabstr_evaluate(sym,'"${name}:$1",'+base_stabs_str(localvarsymref_stab,'0','${line}','$2'),[st,getoffsetstr(sym.localloc.reference)])
           else
             internalerror(2003091814);
         end;
@@ -1411,7 +1442,7 @@ implementation
               begin
                 if (sym.localloc.loc=LOC_REFERENCE) then
                   ss:=sym_stabstr_evaluate(sym,'"pvmt:p$1",'+base_stabs_str(localvarsymref_stab,'0','0','$2'),
-                    [def_stab_number(pvmttype),tostr(sym.localloc.reference.offset)])
+                    [def_stab_number(pvmttype),getoffsetstr(sym.localloc.reference)])
                 else
                   begin
                     regidx:=findreg_by_number(sym.localloc.register);
@@ -1427,7 +1458,7 @@ implementation
                   c:='p';
                 if (sym.localloc.loc=LOC_REFERENCE) then
                   ss:=sym_stabstr_evaluate(sym,'"$$t:$1",'+base_stabs_str(localvarsymref_stab,'0','0','$2'),
-                        [c+def_stab_number(tprocdef(sym.owner.defowner).struct),tostr(sym.localloc.reference.offset)])
+                        [c+def_stab_number(tprocdef(sym.owner.defowner).struct),getoffsetstr(sym.localloc.reference)])
                 else
                   begin
                     if (c='p') then
@@ -1481,14 +1512,15 @@ implementation
                       if not(sym.paraloc[calleeside].location^.loc in [LOC_REFERENCE,LOC_CREFERENCE]) then
                         ss:=get_appendsym_paravar_reg(sym,c,st,sym.paraloc[calleeside].location^.register)
                       else
-                        ss:=sym_stabstr_evaluate(sym,'"${name}:$1",'+base_stabs_str(localvarsymref_stab,'0','${line}','$2'),[c+st,tostr(sym.paraloc[calleeside].location^.reference.offset)]);
+                        ss:=sym_stabstr_evaluate(sym,'"${name}:$1",'+base_stabs_str(localvarsymref_stab,'0','${line}','$2'),
+                              [c+st,getparaoffsetstr(sym.paraloc[calleeside].location^.reference)]);
                       write_sym_stabstr(list,sym,ss);
                       { second stab has no parameter specifier }
                       c:='';
                     end;
                   { offset to ebp => will not work if the framepointer is esp
                     so some optimizing will make things harder to debug }
-                  ss:=sym_stabstr_evaluate(sym,'"${name}:$1",'+base_stabs_str(paravarsymref_stab,'0','${line}','$2'),[c+st,tostr(sym.localloc.reference.offset)])
+                  ss:=sym_stabstr_evaluate(sym,'"${name}:$1",'+base_stabs_str(paravarsymref_stab,'0','${line}','$2'),[c+st,getoffsetstr(sym.localloc.reference)])
                 end;
               else
                 internalerror(2003091814);
@@ -1714,11 +1746,11 @@ implementation
                         current_asmdata.getlabel(hlabel,alt_dbgfile);
                         { emit stabs }
                         if not(ds_stabs_abs_include_files in current_settings.debugswitches) or
-                           path_absolute(infile.path^) then
-                          list.insertbefore(Tai_stab.Create_str(stabsdir,'"'+BsToSlash(FixPath(infile.path^,false))+FixFileName(infile.name^)+'",'+tostr(stabs_n_includefile)+
+                           path_absolute(infile.path) then
+                          list.insertbefore(Tai_stab.Create_str(stabsdir,'"'+BsToSlash(FixPath(infile.path,false))+FixFileName(infile.name)+'",'+tostr(stabs_n_includefile)+
                                             ',0,0,'+hlabel.name),hp)
                         else
-                          list.insertbefore(Tai_stab.Create_str(stabsdir,'"'+BsToSlash(FixPath(getcurrentdir,false)+FixPath(infile.path^,false))+FixFileName(infile.name^)+'",'+tostr(stabs_n_includefile)+
+                          list.insertbefore(Tai_stab.Create_str(stabsdir,'"'+BsToSlash(FixPath(getcurrentdir,false)+FixPath(infile.path,false))+FixFileName(infile.name)+'",'+tostr(stabs_n_includefile)+
                                             ',0,0,'+hlabel.name),hp);
                         list.insertbefore(tai_label.create(hlabel),hp);
                         { force new line info }
@@ -1761,7 +1793,7 @@ implementation
           current_asmdata.asmlists[al_start].concat(tai_symbol.Createname_global(make_mangledname('DEBUGSTART',current_module.localsymtable,''),AT_DATA,0));
         current_asmdata.asmlists[al_start].concat(Tai_stab.Create_str(stabsdir,'"'+BsToSlash(FixPath(getcurrentdir,false))+'",'+
           base_stabs_str(stabs_n_sourcefile,'0','0',hlabel.name)));
-        current_asmdata.asmlists[al_start].concat(Tai_stab.Create_str(stabsdir,'"'+BsToSlash(FixPath(infile.path^,false))+FixFileName(infile.name^)+'",'+
+        current_asmdata.asmlists[al_start].concat(Tai_stab.Create_str(stabsdir,'"'+BsToSlash(FixPath(infile.path,false))+FixFileName(infile.name)+'",'+
           base_stabs_str(stabs_n_sourcefile,'0','0',hlabel.name)));
         current_asmdata.asmlists[al_start].concat(tai_label.create(hlabel));
         { for darwin, you need a "module marker" too to work around      }

compiler/dbgstabx.pas

@@ -357,7 +357,7 @@ implementation
                   if curincludefileinfo.fileindex<>0 then
                     begin
                       infile:=get_module(curincludefileinfo.moduleindex).sourcefiles.get_file(curincludefileinfo.fileindex);
-                      list.insertbefore(Tai_stab.Create_str(stabx_ei,'"'+FixFileName(infile.name^)+'"'),inclinsertpos);
+                      list.insertbefore(Tai_stab.Create_str(stabx_ei,'"'+FixFileName(infile.name)+'"'),inclinsertpos);
                       curincludefileinfo.fileindex:=0;
                     end;
                   if currfileinfo.fileindex<>1 then
@@ -365,7 +365,7 @@ implementation
                       infile:=get_module(currfileinfo.moduleindex).sourcefiles.get_file(currfileinfo.fileindex);
                       if assigned(infile) then
                         begin
-                          list.insertbefore(Tai_stab.Create_str(stabx_bi,'"'+FixFileName(infile.name^)+'"'),inclinsertpos);
+                          list.insertbefore(Tai_stab.Create_str(stabx_bi,'"'+FixFileName(infile.name)+'"'),inclinsertpos);
                           curincludefileinfo:=currfileinfo;
                           { force new line info }
                           lastfileinfo.line:=-1;
@@ -421,7 +421,7 @@ implementation
       if curincludefileinfo.fileindex<>0 then
         begin
           infile:=get_module(curincludefileinfo.moduleindex).sourcefiles.get_file(curincludefileinfo.fileindex);
-          list.insertbefore(Tai_stab.Create_str(stabx_ei,'"'+FixFileName(infile.name^)+'"'),last);
+          list.insertbefore(Tai_stab.Create_str(stabx_ei,'"'+FixFileName(infile.name)+'"'),last);
           curincludefileinfo.fileindex:=0;
         end;
     end;

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;
@@ -132,6 +133,10 @@ interface
       are allowed (in this case, the search order will first
       search for a routine with default parameters, before
       searching for the same definition with no parameters)
+
+      para1 is expected to be parameter list of the first encountered
+      declaration (interface, forward), and para2 that of the second one
+      (important in case of cpo_comparedefaultvalue)
     }
     function compare_paras(para1,para2 : TFPObjectList; acp : tcompare_paras_type; cpoptions: tcompare_paras_options):tequaltype;
 
@@ -210,6 +215,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
@@ -283,7 +294,10 @@ implementation
                             internalerror(200210061);
                         end;
                       end
-                     else
+                     { currency cannot be implicitly converted to an ordinal
+                       type }
+                     else if not is_currency(def_from) or
+                             (cdo_explicit in cdoptions) then
                       begin
                         if cdo_explicit in cdoptions then
                           doconv:=basedefconvertsexplicit[basedeftbl[torddef(def_from).ordtype],basedeftbl[torddef(def_to).ordtype]]
@@ -506,10 +520,23 @@ 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) then
+                              case tstringdef(def_to).stringtype of
+                                st_unicodestring: eq:=te_equal;
+                                st_widestring: eq:=te_convert_l1;
+                                // widechar: eq:=te_convert_l2;
+                                // ansichar: eq:=te_convert_l3;
+                                st_ansistring: eq:=te_convert_l4;
+                                st_shortstring: eq:=te_convert_l5;
+                              else
+                                eq:=te_convert_l6;
+                              end
+                            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
@@ -524,7 +551,7 @@ implementation
                             begin
                               if is_ansistring(def_to) then
                                 eq:=te_convert_l1
-                              else if is_widestring(def_to) or is_unicodestring(def_to) then
+                              else if is_wide_or_unicode_string(def_to) then
                                 eq:=te_convert_l3
                               else
                                 eq:=te_convert_l2;
@@ -545,7 +572,7 @@ implementation
                                   else
                                     eq:=te_convert_l2;
                                 end
-                              else if is_widestring(def_to) or is_unicodestring(def_to) then
+                              else if is_wide_or_unicode_string(def_to) then
                                 eq:=te_convert_l3
                               else
                                 eq:=te_convert_l2;
@@ -557,7 +584,7 @@ implementation
                       if is_widechararray(def_from) or is_open_widechararray(def_from) then
                        begin
                          doconv:=tc_chararray_2_string;
-                         if is_widestring(def_to) or is_unicodestring(def_to) then
+                         if is_wide_or_unicode_string(def_to) then
                            eq:=te_convert_l1
                          else
                            { size of widechar array is double due the sizeof a widechar }
@@ -579,9 +606,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;
@@ -589,7 +616,7 @@ implementation
                           else if is_pwidechar(def_from) then
                            begin
                              doconv:=tc_pwchar_2_string;
-                             if is_widestring(def_to) or is_unicodestring(def_to)  then
+                             if is_wide_or_unicode_string(def_to) then
                                eq:=te_convert_l1
                              else
                                eq:=te_convert_l3;
@@ -603,6 +630,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 +761,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_dispinterface_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 +809,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 +1142,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 :
@@ -1103,7 +1181,11 @@ implementation
                         (is_pchar(def_to) or is_pwidechar(def_to)) then
                       begin
                         doconv:=tc_cstring_2_pchar;
-                        eq:=te_convert_l2;
+                        if ((m_default_unicodestring in current_settings.modeswitches) xor
+                           is_pchar(def_to)) then
+                          eq:=te_convert_l2
+                        else
+                          eq:=te_convert_l3;
                       end
                      else
                       { chararray to pointer }
@@ -1347,23 +1429,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 +1494,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 +1534,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;
@@ -1571,7 +1677,12 @@ implementation
            { and e.g. fromdef=stringdef and todef=variantdef, then }
            { the test will still succeed                           }
            ((cdo_allow_variant in cdoptions) or
-            ((def_from.typ<>variantdef) and (def_to.typ<>variantdef))
+            ((def_from.typ<>variantdef) and
+             (def_to.typ<>variantdef) and
+             { internal typeconversions always have to be bitcasts (except for
+               variants) }
+             not(cdo_internal in cdoptions)
+            )
            ) and
            (
             { Check for variants? }
@@ -1857,13 +1968,19 @@ implementation
               if eq<lowesteq then
                 lowesteq:=eq;
               { also check default value if both have it declared }
-              if (cpo_comparedefaultvalue in cpoptions) and
-                 assigned(currpara1.defaultconstsym) and
-                 assigned(currpara2.defaultconstsym) then
-               begin
-                 if not equal_constsym(tconstsym(currpara1.defaultconstsym),tconstsym(currpara2.defaultconstsym)) then
-                   exit;
-               end;
+              if (cpo_comparedefaultvalue in cpoptions) then
+                begin
+                  if assigned(currpara1.defaultconstsym) and
+                     assigned(currpara2.defaultconstsym) then
+                    begin
+                      if not equal_constsym(tconstsym(currpara1.defaultconstsym),tconstsym(currpara2.defaultconstsym)) then
+                        exit;
+                    end
+                  { cannot have that the second (= implementation) has a default value declared and the
+                    other (interface) doesn't }
+                  else if not assigned(currpara1.defaultconstsym) and assigned(currpara2.defaultconstsym) then
+                    exit;
+                end;
               if not(cpo_compilerproc in cpoptions) and
                  not(cpo_rtlproc in cpoptions) and
                  is_ansistring(currpara1.vardef) and
@@ -1975,8 +2092,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

@@ -26,7 +26,7 @@ unit finput;
 interface
 
     uses
-      cutils,cclasses,cstreams;
+      cutils,globtype,cclasses,cstreams;
 
     const
        InputFileBufSize=32*1024+1;
@@ -37,7 +37,7 @@ interface
        plongintarr = ^tlongintarr;
 
        tinputfile = class
-         path,name : pshortstring;       { path and filename }
+         path,name : TPathStr;       { path and filename }
          next      : tinputfile;    { next file for reading }
 
          is_macro,
@@ -59,7 +59,7 @@ interface
          ref_index  : longint;
          ref_next   : tinputfile;
 
-         constructor create(const fn:string);
+         constructor create(const fn:TPathStr);
          destructor  destroy;override;
          procedure setpos(l:longint);
          procedure seekbuf(fpos:longint);
@@ -74,7 +74,7 @@ interface
          function  getfiletime:longint;
        protected
          filetime  : longint;
-         function fileopen(const filename: string): boolean; virtual; abstract;
+         function fileopen(const filename: TPathStr): boolean; virtual; abstract;
          function fileseek(pos: longint): boolean; virtual; abstract;
          function fileread(var databuf; maxsize: longint): longint; virtual; abstract;
          function fileeof: boolean; virtual; abstract;
@@ -84,7 +84,7 @@ interface
 
        tdosinputfile = class(tinputfile)
        protected
-         function fileopen(const filename: string): boolean; override;
+         function fileopen(const filename: TPathStr): boolean; override;
          function fileseek(pos: longint): boolean; override;
          function fileread(var databuf; maxsize: longint): longint; override;
          function fileeof: boolean; override;
@@ -103,8 +103,8 @@ interface
           destructor destroy;override;
           procedure register_file(f : tinputfile);
           function  get_file(l:longint) : tinputfile;
-          function  get_file_name(l :longint):string;
-          function  get_file_path(l :longint):string;
+          function  get_file_name(l :longint):TPathStr;
+          function  get_file_path(l :longint):TPathStr;
        end;
 
 {****************************************************************************
@@ -137,11 +137,10 @@ interface
           sourcefiles      : tinputfilemanager;
           { paths and filenames }
           paramallowoutput : boolean;  { original allowoutput parameter }
-          paramfn,                  { original filename }
-          path,                     { path where the module is find/created }
-          outputpath,               { path where the .s / .o / exe are created }
           modulename,               { name of the module in uppercase }
-          realmodulename,           { name of the module in the orignal case }
+          realmodulename: pshortstring; { name of the module in the orignal case }
+          paramfn,                  { original filename }
+          mainsource,               { name of the main sourcefile }
           objfilename,              { fullname of the objectfile }
           asmfilename,              { fullname of the assemblerfile }
           ppufilename,              { fullname of the ppufile }
@@ -151,21 +150,22 @@ interface
           mapfilename,              { fullname of the mapfile }
           exefilename,              { fullname of the exefile }
           dbgfilename,              { fullname of the debug info file }
-          mainsource   : pshortstring;   { name of the main sourcefile }
+          path,                     { path where the module is find/created }
+          outputpath   : TPathStr;  { path where the .s / .o / exe are created }
           constructor create(const s:string);
           destructor destroy;override;
-          procedure setfilename(const fn:string;allowoutput:boolean);
+          procedure setfilename(const fn:TPathStr;allowoutput:boolean);
        end;
 
 
-     Function GetNamedFileTime (Const F : String) : Longint;
+     Function GetNamedFileTime (Const F : TPathStr) : Longint;
 
 
 implementation
 
 uses
   SysUtils,
-  GlobType,Comphook,
+  Comphook,
 {$ifdef heaptrc}
   fmodule,
   ppheap,
@@ -179,7 +179,7 @@ uses
                                   Utils
  ****************************************************************************}
 
-   Function GetNamedFileTime (Const F : String) : Longint;
+   Function GetNamedFileTime (Const F : TPathStr) : Longint;
      begin
        GetNamedFileTime:=do_getnamedfiletime(F);
      end;
@@ -189,10 +189,10 @@ uses
                                   TINPUTFILE
  ****************************************************************************}
 
-    constructor tinputfile.create(const fn:string);
+    constructor tinputfile.create(const fn:TPathStr);
       begin
-        name:=stringdup(ExtractFileName(fn));
-        path:=stringdup(ExtractFilePath(fn));
+        name:=ExtractFileName(fn);
+        path:=ExtractFilePath(fn);
         next:=nil;
         filetime:=-1;
       { file info }
@@ -220,8 +220,6 @@ uses
       begin
         if not closed then
          close;
-        stringdispose(path);
-        stringdispose(name);
       { free memory }
         if assigned(linebuf) then
          freemem(linebuf,maxlinebuf shl 2);
@@ -262,7 +260,7 @@ uses
         open:=false;
         if not closed then
          Close;
-        if not fileopen(path^+name^) then
+        if not fileopen(path+name) then
          exit;
       { file }
         endoffile:=false;
@@ -284,6 +282,8 @@ uses
               Freemem(buf,maxbufsize);
               buf:=nil;
             end;
+           name:='';
+           path:='';
            closed:=true;
            exit;
          end;
@@ -334,7 +334,7 @@ uses
          end;
         if not closed then
          exit;
-        if not fileopen(path^+name^) then
+        if not fileopen(path+name) then
          exit;
         closed:=false;
       { get new mem }
@@ -445,7 +445,7 @@ uses
                                 TDOSINPUTFILE
  ****************************************************************************}
 
-    function tdosinputfile.fileopen(const filename: string): boolean;
+    function tdosinputfile.fileopen(const filename: TPathStr): boolean;
       begin
         { Check if file exists, this will also check if it is
           a real file and not a directory }
@@ -500,7 +500,7 @@ uses
 
     procedure tdosinputfile.filegettime;
       begin
-        filetime:=getnamedfiletime(path^+name^);
+        filetime:=getnamedfiletime(path+name);
       end;
 
 
@@ -572,25 +572,25 @@ uses
      end;
 
 
-   function tinputfilemanager.get_file_name(l :longint):string;
+   function tinputfilemanager.get_file_name(l :longint):TPathStr;
      var
        hp : tinputfile;
      begin
        hp:=get_file(l);
        if assigned(hp) then
-        get_file_name:=hp.name^
+        get_file_name:=hp.name
        else
         get_file_name:='';
      end;
 
 
-   function tinputfilemanager.get_file_path(l :longint):string;
+   function tinputfilemanager.get_file_path(l :longint):TPathStr;
      var
        hp : tinputfile;
      begin
        hp:=get_file(l);
        if assigned(hp) then
-        get_file_path:=hp.path^
+        get_file_path:=hp.path
        else
         get_file_path:='';
      end;
@@ -600,31 +600,19 @@ uses
                                 TModuleBase
  ****************************************************************************}
 
-    procedure tmodulebase.setfilename(const fn:string;allowoutput:boolean);
+    procedure tmodulebase.setfilename(const fn:TPathStr;allowoutput:boolean);
       var
-        p,n,
+        p, n,
         prefix,
-        suffix : string;
+        suffix : TPathStr;
       begin
-         stringdispose(objfilename);
-         stringdispose(asmfilename);
-         stringdispose(ppufilename);
-         stringdispose(importlibfilename);
-         stringdispose(staticlibfilename);
-         stringdispose(sharedlibfilename);
-         stringdispose(mapfilename);
-         stringdispose(exefilename);
-         stringdispose(dbgfilename);
-         stringdispose(outputpath);
-         stringdispose(path);
-         stringdispose(paramfn);
          { Create names }
-         paramfn := stringdup(fn);
+         paramfn := fn;
          paramallowoutput := allowoutput;
          p := FixPath(ExtractFilePath(fn),false);
          n := FixFileName(ChangeFileExt(ExtractFileName(fn),''));
          { set path }
-         path:=stringdup(p);
+         path:=p;
          { obj,asm,ppu names }
          if AllowOutput then
            begin
@@ -634,31 +622,31 @@ uses
                if (OutputExeDir<>'') then
                  p:=OutputExeDir;
            end;
-         outputpath:=stringdup(p);
-         asmfilename:=stringdup(p+n+target_info.asmext);
-         objfilename:=stringdup(p+n+target_info.objext);
-         ppufilename:=stringdup(p+n+target_info.unitext);
-         importlibfilename:=stringdup(p+target_info.importlibprefix+n+target_info.importlibext);
-         staticlibfilename:=stringdup(p+target_info.staticlibprefix+n+target_info.staticlibext);
+         outputpath:=p;
+         asmfilename:=p+n+target_info.asmext;
+         objfilename:=p+n+target_info.objext;
+         ppufilename:=p+n+target_info.unitext;
+         importlibfilename:=p+target_info.importlibprefix+n+target_info.importlibext;
+         staticlibfilename:=p+target_info.staticlibprefix+n+target_info.staticlibext;
 
          { output dir of exe can be specified separatly }
          if AllowOutput and (OutputExeDir<>'') then
            p:=OutputExeDir
          else
-           p:=path^;
+           p:=path;
 
          { lib and exe could be loaded with a file specified with -o }
          if AllowOutput and
             (compile_level=1) and
             (OutputFileName<>'')then
            begin
-             exefilename:=stringdup(p+OutputFileName);
-             sharedlibfilename:=stringdup(p+OutputFileName);
+             exefilename:=p+OutputFileName;
+             sharedlibfilename:=p+OutputFileName;
              n:=ChangeFileExt(OutputFileName,''); { for mapfilename and dbgfilename } 
            end
          else
            begin
-             exefilename:=stringdup(p+n+target_info.exeext);
+             exefilename:=p+n+target_info.exeext;
              if Assigned(OutputPrefix) then
                prefix := OutputPrefix^
              else
@@ -667,10 +655,10 @@ uses
                suffix := OutputSuffix^
              else
                suffix := '';
-             sharedlibfilename:=stringdup(p+prefix+n+suffix+target_info.sharedlibext);
+             sharedlibfilename:=p+prefix+n+suffix+target_info.sharedlibext;
            end;
-         mapfilename:=stringdup(p+n+'.map');
-         dbgfilename:=stringdup(p+n+'.dbg');
+         mapfilename:=p+n+'.map';
+         dbgfilename:=p+n+'.dbg';
       end;
 
 
@@ -678,19 +666,19 @@ uses
       begin
         modulename:=stringdup(Upper(s));
         realmodulename:=stringdup(s);
-        mainsource:=nil;
-        ppufilename:=nil;
-        objfilename:=nil;
-        asmfilename:=nil;
-        importlibfilename:=nil;
-        staticlibfilename:=nil;
-        sharedlibfilename:=nil;
-        exefilename:=nil;
-        dbgfilename:=nil;
-        mapfilename:=nil;
-        outputpath:=nil;
-        paramfn:=nil;
-        path:=nil;
+        mainsource:='';
+        ppufilename:='';
+        objfilename:='';
+        asmfilename:='';
+        importlibfilename:='';
+        staticlibfilename:='';
+        sharedlibfilename:='';
+        exefilename:='';
+        dbgfilename:='';
+        mapfilename:='';
+        outputpath:='';
+        paramfn:='';
+        path:='';
         { status }
         state:=ms_registered;
         { unit index }
@@ -706,21 +694,8 @@ uses
         if assigned(sourcefiles) then
          sourcefiles.free;
         sourcefiles:=nil;
-        stringdispose(objfilename);
-        stringdispose(asmfilename);
-        stringdispose(ppufilename);
-        stringdispose(importlibfilename);
-        stringdispose(staticlibfilename);
-        stringdispose(sharedlibfilename);
-        stringdispose(exefilename);
-        stringdispose(dbgfilename);
-        stringdispose(mapfilename);
-        stringdispose(outputpath);
-        stringdispose(path);
         stringdispose(modulename);
         stringdispose(realmodulename);
-        stringdispose(mainsource);
-        stringdispose(paramfn);
         inherited destroy;
       end;
 

compiler/fmodule.pas

@@ -70,17 +70,16 @@ interface
 
       tlinkcontaineritem=class(tlinkedlistitem)
       public
-         data : pshortstring;
+         data : TPathStr;
          needlink : cardinal;
-         constructor Create(const s:string;m:cardinal);
-         destructor Destroy;override;
+         constructor Create(const s:TPathStr;m:cardinal);
       end;
 
       tlinkcontainer=class(tlinkedlist)
-         procedure add(const s : string;m:cardinal);
-         function get(var m:cardinal) : string;
-         function getusemask(mask:cardinal) : string;
-         function find(const s:string):boolean;
+         procedure add(const s : TPathStr;m:cardinal);
+         function get(var m:cardinal) : TPathStr;
+         function getusemask(mask:cardinal) : TPathStr;
+         function find(const s:TPathStr):boolean;
       end;
 
       tmodule = class;
@@ -143,6 +142,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,11 +185,20 @@ 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
         to that when creating link.res!!!!(mazen)}
-        constructor create(LoadedFrom:TModule;const amodulename,afilename:string;_is_unit:boolean);
+        constructor create(LoadedFrom:TModule;const amodulename: string; const afilename:TPathStr;_is_unit:boolean);
         destructor destroy;override;
         procedure reset;virtual;
         procedure adddependency(callermodule:tmodule);
@@ -291,7 +301,7 @@ implementation
               begin
                 current_scanner.tempopeninputfile;
                 current_scanner.gettokenpos;
-                parser_current_file:=current_scanner.inputfile.name^;
+                parser_current_file:=current_scanner.inputfile.name;
               end
             else
               begin
@@ -348,31 +358,25 @@ implementation
                              TLinkContainerItem
  ****************************************************************************}
 
-    constructor TLinkContainerItem.Create(const s:string;m:cardinal);
+    constructor TLinkContainerItem.Create(const s:TPathStr;m:cardinal);
       begin
         inherited Create;
-        data:=stringdup(s);
+        data:=s;
         needlink:=m;
       end;
 
 
-    destructor TLinkContainerItem.Destroy;
-      begin
-        stringdispose(data);
-      end;
-
-
 {****************************************************************************
                            TLinkContainer
  ****************************************************************************}
 
-    procedure TLinkContainer.add(const s : string;m:cardinal);
+    procedure TLinkContainer.add(const s : TPathStr;m:cardinal);
       begin
         inherited concat(TLinkContainerItem.Create(s,m));
       end;
 
 
-    function TLinkContainer.get(var m:cardinal) : string;
+    function TLinkContainer.get(var m:cardinal) : TPathStr;
       var
         p : tlinkcontaineritem;
       begin
@@ -384,14 +388,14 @@ implementation
          end
         else
          begin
-           get:=p.data^;
+           get:=p.data;
            m:=p.needlink;
            p.free;
          end;
       end;
 
 
-    function TLinkContainer.getusemask(mask:cardinal) : string;
+    function TLinkContainer.getusemask(mask:cardinal) : TPathStr;
       var
          p : tlinkcontaineritem;
          found : boolean;
@@ -404,14 +408,14 @@ implementation
              getusemask:='';
              exit;
            end;
-          getusemask:=p.data^;
+          getusemask:=p.data;
           found:=(p.needlink and mask)<>0;
           p.free;
         until found;
       end;
 
 
-    function TLinkContainer.find(const s:string):boolean;
+    function TLinkContainer.find(const s:TPathStr):boolean;
       var
         newnode : tlinkcontaineritem;
       begin
@@ -419,7 +423,7 @@ implementation
         newnode:=tlinkcontaineritem(First);
         while assigned(newnode) do
          begin
-           if newnode.data^=s then
+           if newnode.data=s then
             begin
               find:=true;
               exit;
@@ -468,9 +472,10 @@ implementation
                                   TMODULE
  ****************************************************************************}
 
-    constructor tmodule.create(LoadedFrom:TModule;const amodulename,afilename:string;_is_unit:boolean);
+    constructor tmodule.create(LoadedFrom:TModule;const amodulename: string; const afilename:TPathStr;_is_unit:boolean);
       var
-        n,fn:string;
+        n:string;
+        fn:TPathStr;
       begin
         if amodulename='' then
           n:=ChangeFileExt(ExtractFileName(afilename),'')
@@ -485,7 +490,7 @@ implementation
          inherited create(amodulename)
         else
          inherited create('Program');
-        mainsource:=stringdup(fn);
+        mainsource:=fn;
         { Dos has the famous 8.3 limit :( }
 {$ifdef shortasmprefix}
         asmprefix:=stringdup(FixFileName('as'));
@@ -524,6 +529,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 +556,8 @@ implementation
         mode_switch_allowed:= true;
         moduleoptions:=[];
         deprecatedmsg:=nil;
+        namespace:=nil;
+        tcinitcode:=nil;
         _exports:=TLinkedList.Create;
         dllscannerinputlist:=TFPHashList.Create;
         asmdata:=casmdata.create(realmodulename^);
@@ -613,19 +622,10 @@ implementation
         stringdispose(mainname);
         FImportLibraryList.Free;
         extendeddefs.Free;
-        stringdispose(objfilename);
-        stringdispose(asmfilename);
-        stringdispose(ppufilename);
-        stringdispose(importlibfilename);
-        stringdispose(staticlibfilename);
-        stringdispose(sharedlibfilename);
-        stringdispose(exefilename);
-        stringdispose(outputpath);
-        stringdispose(path);
-        stringdispose(realmodulename);
-        stringdispose(mainsource);
         stringdispose(asmprefix);
         stringdispose(deprecatedmsg);
+        stringdispose(namespace);
+        tcinitcode.free;
         localunitsearchpath.Free;
         localobjectsearchpath.free;
         localincludesearchpath.free;
@@ -637,6 +637,8 @@ implementation
         derefdata.free;
         deflist.free;
         symlist.free;
+        ptrdefs.free;
+        arraydefs.free;
         ansistrdef:=nil;
         wpoinfo.free;
         checkforwarddefs.free;
@@ -647,7 +649,6 @@ implementation
 {$ifdef MEMDEBUG}
         memsymtable.stop;
 {$endif}
-        stringdispose(modulename);
         inherited Destroy;
       end;
 
@@ -698,6 +699,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 +763,9 @@ implementation
         in_global:=true;
         mode_switch_allowed:=true;
         stringdispose(deprecatedmsg);
+        stringdispose(namespace);
+        tcinitcode.free;
+        tcinitcode:=nil;
         moduleoptions:=[];
         is_dbginfo_written:=false;
         crc:=0;
@@ -957,8 +965,6 @@ implementation
 
     procedure tmodule.setmodulename(const s:string);
       begin
-        stringdispose(modulename);
-        stringdispose(realmodulename);
         modulename:=stringdup(upper(s));
         realmodulename:=stringdup(s);
         { also update asmlibrary names }

compiler/fpcdefs.inc

@@ -170,19 +170,41 @@
 
 {$ifdef mipsel}
   {$define mips}
+{$else not mipsel}
+  { Define both mips and mipseb if mipsel is not defined
+    but mips cpu is wanted. }
+  {$ifdef mipseb}
+    {$define mips}
+  {$endif mipseb}
+  {$ifdef mips}
+    {$define mipseb}
+  {$endif mips}
 {$endif mipsel}
 
+
 {$ifdef mips}
-  {$define cpu32bit}
-  {$define cpu32bitalu}
-  {$define cpu32bitaddr}
-  { $define cpuflags}
+  {$ifndef mips64}
+    {$define cpu32bit}
+    {$define cpu32bitalu}
+    {$define cpu32bitaddr}
+  {$else}
+    {$error mips64 not yet supported}
+  {$endif}
+  { define cpuflags}
   {$define cputargethasfixedstack}
   {$define cpurequiresproperalignment}
   { define cpumm}
   {$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

@@ -46,7 +46,7 @@ interface
 
        tppumodule = class(tmodule)
           ppufile    : tcompilerppufile; { the PPU file }
-          sourcefn   : pshortstring; { Source specified with "uses .. in '..'" }
+          sourcefn   : TPathStr; { Source specified with "uses .. in '..'" }
           comments   : TCmdStrList;
 {$ifdef Test_Double_checksum}
           crc_array  : pointer;
@@ -54,7 +54,7 @@ interface
           crc_array2 : pointer;
           crc_size2  : longint;
 {$endif def Test_Double_checksum}
-          constructor create(LoadedFrom:TModule;const amodulename,afilename:string;_is_unit:boolean);
+          constructor create(LoadedFrom:TModule;const amodulename: string; const afilename:TPathStr;_is_unit:boolean);
           destructor destroy;override;
           procedure reset;override;
           function  openppu:boolean;
@@ -107,7 +107,7 @@ interface
 implementation
 
 uses
-  SysUtils,
+  SysUtils,strutils,
   cfileutl,
   systems,version,
   symtable, symsym,
@@ -125,11 +125,11 @@ var
                                 TPPUMODULE
  ****************************************************************************}
 
-    constructor tppumodule.create(LoadedFrom:TModule;const amodulename,afilename:string;_is_unit:boolean);
+    constructor tppumodule.create(LoadedFrom:TModule;const amodulename: string; const afilename:TPathStr;_is_unit:boolean);
       begin
         inherited create(LoadedFrom,amodulename,afilename,_is_unit);
         ppufile:=nil;
-        sourcefn:=stringdup(afilename);
+        sourcefn:=afilename;
       end;
 
 
@@ -140,7 +140,6 @@ var
         ppufile:=nil;
         comments.free;
         comments:=nil;
-        stringdispose(sourcefn);
         inherited Destroy;
       end;
 
@@ -183,14 +182,14 @@ var
         ppufiletime : longint;
       begin
         openppu:=false;
-        Message1(unit_t_ppu_loading,ppufilename^,@queuecomment);
+        Message1(unit_t_ppu_loading,ppufilename,@queuecomment);
       { Get ppufile time (also check if the file exists) }
-        ppufiletime:=getnamedfiletime(ppufilename^);
+        ppufiletime:=getnamedfiletime(ppufilename);
         if ppufiletime=-1 then
          exit;
       { Open the ppufile }
-        Message1(unit_u_ppu_name,ppufilename^);
-        ppufile:=tcompilerppufile.create(ppufilename^);
+        Message1(unit_u_ppu_name,ppufilename);
+        ppufile:=tcompilerppufile.create(ppufilename);
         if not ppufile.openfile then
          begin
            ppufile.free;
@@ -330,12 +329,12 @@ var
               { Check for .p, if mode is macpas}
               Found:=UnitExists(pext,hs);
             end;
-           stringdispose(mainsource);
+           mainsource:='';
            if Found then
             begin
               sources_avail:=true;
               { Load Filenames when found }
-              mainsource:=StringDup(hs);
+              mainsource:=hs;
               SetFileName(hs,false);
             end
            else
@@ -375,7 +374,7 @@ var
 
        var
          fnd : boolean;
-         hs  : TCmdStr;
+         hs  : TPathStr;
        begin
          if shortname then
           filename:=FixFileName(Copy(realmodulename^,1,8))
@@ -394,46 +393,45 @@ var
          if not onlysource then
           begin
             fnd:=PPUSearchPath('.');
-            if (not fnd) and (outputpath^<>'') then
-             fnd:=PPUSearchPath(outputpath^);
-            if (not fnd) and Assigned(main_module) and (main_module.Path^<>'')  then
-             fnd:=PPUSearchPath(main_module.Path^);
+            if (not fnd) and (outputpath<>'') then
+             fnd:=PPUSearchPath(outputpath);
+            if (not fnd) and Assigned(main_module) and (main_module.Path<>'')  then
+             fnd:=PPUSearchPath(main_module.Path);
           end;
-         if (not fnd) and (sourcefn^<>'') then
+         if (not fnd) and (sourcefn<>'') then
           begin
             { the full filename is specified so we can't use here the
               searchpath (PFV) }
             if CheckVerbosity(V_Tried) then
-              Message1(unit_t_unitsearch,ChangeFileExt(sourcefn^,sourceext));
-            fnd:=FindFile(ChangeFileExt(sourcefn^,sourceext),'',true,hs);
+              Message1(unit_t_unitsearch,ChangeFileExt(sourcefn,sourceext));
+            fnd:=FindFile(ChangeFileExt(sourcefn,sourceext),'',true,hs);
             if not fnd then
              begin
                if CheckVerbosity(V_Tried) then
-                 Message1(unit_t_unitsearch,ChangeFileExt(sourcefn^,pasext));
-               fnd:=FindFile(ChangeFileExt(sourcefn^,pasext),'',true,hs);
+                 Message1(unit_t_unitsearch,ChangeFileExt(sourcefn,pasext));
+               fnd:=FindFile(ChangeFileExt(sourcefn,pasext),'',true,hs);
              end;
             if not fnd and
                ((m_mac in current_settings.modeswitches) or
                 (tf_p_ext_support in target_info.flags)) then
              begin
                if CheckVerbosity(V_Tried) then
-                 Message1(unit_t_unitsearch,ChangeFileExt(sourcefn^,pext));
-               fnd:=FindFile(ChangeFileExt(sourcefn^,pext),'',true,hs);
+                 Message1(unit_t_unitsearch,ChangeFileExt(sourcefn,pext));
+               fnd:=FindFile(ChangeFileExt(sourcefn,pext),'',true,hs);
              end;
             if fnd then
              begin
                sources_avail:=true;
                do_compile:=true;
                recompile_reason:=rr_noppu;
-               stringdispose(mainsource);
-               mainsource:=StringDup(hs);
+               mainsource:=hs;
                SetFileName(hs,false);
              end;
           end;
          if not fnd then
            fnd:=SourceSearchPath('.');
-         if (not fnd) and Assigned(main_module) and (main_module.Path^<>'') then
-           fnd:=SourceSearchPath(main_module.Path^);
+         if (not fnd) and Assigned(main_module) and (main_module.Path<>'') then
+           fnd:=SourceSearchPath(main_module.Path);
          if (not fnd) and Assigned(loaded_from) then
            fnd:=SearchPathList(loaded_from.LocalUnitSearchPath);
          if not fnd then
@@ -494,7 +492,7 @@ var
             hp:=sourcefiles.files;
             for i:=1 to j-1 do
               hp:=hp.ref_next;
-            ppufile.putstring(hp.name^);
+            ppufile.putstring(hp.name);
             ppufile.putlongint(hp.getfiletime);
             dec(j);
          end;
@@ -536,7 +534,7 @@ var
     procedure tppumodule.writelinkcontainer(var p:tlinkcontainer;id:byte;strippath:boolean);
       var
         hcontainer : tlinkcontainer;
-        s : string;
+        s : TPathStr;
         mask : cardinal;
       begin
         hcontainer:=TLinkContainer.Create;
@@ -721,8 +719,6 @@ var
         hp            : tinputfile;
       begin
         sources_avail:=(flags and uf_release) = 0;
-        if not sources_avail then
-          exit;
         is_main:=true;
         main_dir:='';
         while not ppufile.endofentry do
@@ -730,77 +726,81 @@ var
            hs:=ppufile.getstring;
            orgfiletime:=ppufile.getlongint;
            temp_dir:='';
-           if (flags and uf_in_library)<>0 then
-            begin
-              sources_avail:=false;
-              temp:=' library';
-            end
-           else if pos('Macro ',hs)=1 then
-            begin
-              { we don't want to find this file }
-              { but there is a problem with file indexing !! }
-              temp:='';
-            end
-           else
-            begin
-              { check the date of the source files:
-                 1 path of ppu
-                 2 path of main source
-                 3 current dir
-                 4 include/unit path }
-              Source_Time:=GetNamedFileTime(path^+hs);
-              found:=false;
-              if Source_Time<>-1 then
-                hs:=path^+hs
-              else
-               if not(is_main) then
+           if sources_avail then
+             begin
+               if (flags and uf_in_library)<>0 then
                 begin
-                  Source_Time:=GetNamedFileTime(main_dir+hs);
-                  if Source_Time<>-1 then
-                    hs:=main_dir+hs;
-                end;
-              if Source_Time=-1 then
-                Source_Time:=GetNamedFileTime(hs);
-              if (Source_Time=-1) then
+                  sources_avail:=false;
+                  temp:=' library';
+                end
+               else if pos('Macro ',hs)=1 then
                 begin
-                  if is_main then
-                    found:=unitsearchpath.FindFile(hs,true,temp_dir)
-                  else
-                    found:=includesearchpath.FindFile(hs,true,temp_dir);
-                  if found then
-                   begin
-                     Source_Time:=GetNamedFileTime(temp_dir);
-                     if Source_Time<>-1 then
-                      hs:=temp_dir;
-                   end;
-                end;
-              if Source_Time<>-1 then
+                  { we don't want to find this file }
+                  { but there is a problem with file indexing !! }
+                  temp:='';
+                end
+               else
                 begin
-                  if is_main then
-                    main_dir:=ExtractFilePath(hs);
-                  temp:=' time '+filetimestring(source_time);
-                  if (orgfiletime<>-1) and
-                     (source_time<>orgfiletime) then
+                  { check the date of the source files:
+                     1 path of ppu
+                     2 path of main source
+                     3 current dir
+                     4 include/unit path }
+                  Source_Time:=GetNamedFileTime(path+hs);
+                  found:=false;
+                  if Source_Time<>-1 then
+                    hs:=path+hs
+                  else
+                   if not(is_main) then
                     begin
-                      do_compile:=true;
-                      recompile_reason:=rr_sourcenewer;
-                      Message2(unit_u_source_modified,hs,ppufilename^,@queuecomment);
-                      temp:=temp+' *';
+                      Source_Time:=GetNamedFileTime(main_dir+hs);
+                      if Source_Time<>-1 then
+                        hs:=main_dir+hs;
                     end;
-                end
-              else
-                begin
-                  sources_avail:=false;
-                  temp:=' not found';
+                  if Source_Time=-1 then
+                    Source_Time:=GetNamedFileTime(hs);
+                  if (Source_Time=-1) then
+                    begin
+                      if is_main then
+                        found:=unitsearchpath.FindFile(hs,true,temp_dir)
+                      else
+                        found:=includesearchpath.FindFile(hs,true,temp_dir);
+                      if found then
+                       begin
+                         Source_Time:=GetNamedFileTime(temp_dir);
+                         if Source_Time<>-1 then
+                          hs:=temp_dir;
+                       end;
+                    end;
+                  if Source_Time<>-1 then
+                    begin
+                      if is_main then
+                        main_dir:=ExtractFilePath(hs);
+                      temp:=' time '+filetimestring(source_time);
+                      if (orgfiletime<>-1) and
+                         (source_time<>orgfiletime) then
+                        begin
+                          do_compile:=true;
+                          recompile_reason:=rr_sourcenewer;
+                          Message2(unit_u_source_modified,hs,ppufilename,@queuecomment);
+                          temp:=temp+' *';
+                        end;
+                    end
+                  else
+                    begin
+                      sources_avail:=false;
+                      temp:=' not found';
+                    end;
+                  hp:=tdosinputfile.create(hs);
+                  { the indexing is wrong here PM }
+                  sourcefiles.register_file(hp);
                 end;
-              hp:=tdosinputfile.create(hs);
-              { the indexing is wrong here PM }
-              sourcefiles.register_file(hp);
-            end;
+             end
+           else
+             temp:=' not available';
            if is_main then
              begin
-               stringdispose(mainsource);
-               mainsource:=stringdup(hs);
+               mainsource:=hs;
              end;
            Message1(unit_u_ppu_source,hs+temp,@queuecomment);
            is_main:=false;
@@ -938,7 +938,7 @@ var
           { make sure we don't throw away a precompiled unit if the user simply
             forgot to specify the right wpo feedback file
           }
-          message3(unit_e_different_wpo_file,ppufilename^,orgwpofilename,filetimestring(orgwpofiletime));
+          message3(unit_e_different_wpo_file,ppufilename,orgwpofilename,filetimestring(orgwpofiletime));
       end;
 
 
@@ -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;
@@ -1063,11 +1068,17 @@ var
 {$endif def Test_Double_checksum_write}
 
          { create new ppufile }
-         ppufile:=tcompilerppufile.create(ppufilename^);
+         ppufile:=tcompilerppufile.create(ppufilename);
          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);
 
@@ -1214,12 +1225,18 @@ var
 {$endif def Test_Double_checksum_write}
 
          { create new ppufile }
-         ppufile:=tcompilerppufile.create(ppufilename^);
+         ppufile:=tcompilerppufile.create(ppufilename);
          ppufile.crc_only:=true;
          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);
 
@@ -1651,7 +1668,7 @@ var
               { compile this module }
               if not(state in [ms_compile,ms_second_compile]) then
                 state:=ms_compile;
-              compile(mainsource^);
+              compile(mainsource);
               setdefgeneration;
             end
            else

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

@@ -53,7 +53,7 @@ interface
           m_pointer_2_procedure,m_autoderef,m_tp_procvar,m_initfinal,m_default_ansistring,
           m_out,m_default_para,m_duplicate_names,m_hintdirective,
           m_property,m_default_inline,m_except,m_advanced_records];
-       delphiunicodemodeswitches = delphimodeswitches + [m_systemcodepage];
+       delphiunicodemodeswitches = delphimodeswitches + [m_systemcodepage,m_default_unicodestring];
        fpcmodeswitches =
          [m_fpc,m_all,m_string_pchar,m_nested_comment,m_repeat_forward,
           m_cvar_support,m_initfinal,m_hintdirective,
@@ -103,14 +103,25 @@ interface
        MathPiExtended : textendedrec = (bytes : (64,0,201,15,218,162,33,104,194,53));
 {$endif FPC_LITTLE_ENDIAN}
 {$endif}
+
        CP_UTF8 = 65001;
-       CP_UTF16 = 1200;
+       CP_UTF16LE = 1200;
+       CP_UTF16BE = 1201;
        CP_NONE  = 65535;
 
+       { by default no local variable trashing }
+       localvartrashing: longint = -1;
+
+       nroftrashvalues = 4;
+       trashintvalues: array[0..nroftrashvalues-1] of int64 = ($5555555555555555,$AAAAAAAAAAAAAAAA,$EFEFEFEFEFEFEFEF,0);
+
 
     type
-       { this is written to ppus during token recording for generics so it must be packed }
-       tsettings = packed record
+       { this is written to ppus during token recording for generics,
+         it used to required to be packed,
+         but this requirement is now obsolete,
+         as the fields are written one by one. PM 2012-06-13 }
+       tsettings = record
          alignment       : talignmentinfo;
          globalswitches  : tglobalswitches;
          targetswitches  : ttargetswitches;
@@ -339,11 +350,6 @@ interface
        defaultmainaliasname = 'main';
        mainaliasname : string = defaultmainaliasname;
 
-       { by default no local variable trashing }
-       localvartrashing: longint = -1;
-       { actual values are defined in ncgutil.pas }
-       nroftrashvalues = 4;
-
     const
       default_settings : TSettings = (
         alignment : (
@@ -434,9 +440,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 +473,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 +514,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 +899,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,20 @@ 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,
+         { for the JVM target: intialize enum fields in constructors with the
+           enum class instance corresponding to ordinal value 0 (not done by
+           default because this initialization can only be performed after the
+           inherited constructors have run, and if they call a virtual method
+           of the current class, then this virtual method may already have
+           initialized that field with another value and the constructor
+           initialization will result in data loss }
+         ts_jvm_enum_field_init
+
        );
        ttargetswitches = set of ttargetswitch;
 
@@ -221,7 +243,7 @@ interface
          cs_opt_level1,cs_opt_level2,cs_opt_level3,
          cs_opt_regvar,cs_opt_uncertain,cs_opt_size,cs_opt_stackframe,
          cs_opt_peephole,cs_opt_asmcse,cs_opt_loopunroll,cs_opt_tailrecursion,cs_opt_nodecse,
-         cs_opt_nodedfa,cs_opt_loopstrength,cs_opt_scheduler
+         cs_opt_nodedfa,cs_opt_loopstrength,cs_opt_scheduler,cs_opt_autoinline
        );
        toptimizerswitches = set of toptimizerswitch;
 
@@ -245,7 +267,7 @@ interface
          'LEVEL1','LEVEL2','LEVEL3',
          'REGVAR','UNCERTAIN','SIZE','STACKFRAME',
          'PEEPHOLE','ASMCSE','LOOPUNROLL','TAILREC','CSE',
-         'DFA','STRENGTH','SCHEDULE'
+         'DFA','STRENGTH','SCHEDULE','AUTOINLINE'
        );
        WPOptimizerSwitchStr : array [twpoptimizerswitch] of string[14] = (
          'DEVIRTCALLS','OPTVMTS','SYMBOLLIVENESS'
@@ -255,7 +277,9 @@ interface
          'DWARFSETS','STABSABSINCLUDES','DWARFMETHODCLASSPREFIX');
 
        TargetSwitchStr : array[ttargetswitch] of string[19] = ('',
-         'SMALLTOC');
+         'SMALLTOC',
+         'COMPACTINTARRAYINIT',
+         'ENUMFIELDINIT');
 
        { switches being applied to all CPUs at the given level }
        genericlevel1optimizerswitches = [cs_opt_level1];
@@ -308,7 +332,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;
 
@@ -316,7 +345,7 @@ interface
        tapptype = (
          app_none,
          app_native,
-         app_gui,               { graphic user-interface application}
+         app_gui,       { graphic user-interface application}
          app_cui,       { console application}
          app_fs,        { full-screen type application (OS/2 and EMX only) }
          app_tool,      { tool application, (MPW tool for MacOS, MacOS only)}
@@ -328,7 +357,8 @@ interface
        { interface types }
        tinterfacetypes = (
          it_interfacecom,
-         it_interfacecorba
+         it_interfacecorba,
+         it_interfacejava
        );
 
        { currently parsed block type }
@@ -346,8 +376,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 +490,9 @@ interface
          'NONLOCALGOTO',
          'ADVANCEDRECORDS',
          'ISOUNARYMINUS',
-         'SYSTEMCODEPAGE');
+         'SYSTEMCODEPAGE',
+         'FINALFIELDS',
+         'UNICODESTRINGS');
 
 
      type
@@ -480,7 +531,11 @@ interface
          { subroutine contains interprocedural used labels }
          pi_has_interproclabel,
          { subroutine has unwind info (win64) }
-         pi_has_unwind_info
+         pi_has_unwind_info,
+         { subroutine contains interprocedural gotos }
+         pi_has_global_goto,
+         { subroutine contains inherited call }
+         pi_has_inherited
        );
        tprocinfoflags=set of tprocinfoflag;
 
@@ -569,6 +624,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,1434 @@
+{
+    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 : 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;const 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_loadaddr_ref_reg(list : TAsmList;fromsize, tosize : tdef;const ref : treference;r : tregister);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: tcgsize; 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_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_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_loc_reg_label(list : TAsmList;size : tdef;cmp_op : topcmp; const loc: tlocation; reg : tregister; 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;
+
+          {# 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;
+
+          { 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;
+         protected
+          procedure gen_loadfpu_loc_cgpara(list: TAsmList; size: tdef; const l: tlocation;const cgpara: tcgpara;locintsize: longint);override;
+         public
+
+
+          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: 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; const 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
+      case loc.loc of
+        LOC_SUBSETREG,LOC_CSUBSETREG,
+        LOC_SUBSETREF,LOC_CSUBSETREF:
+          inherited
+        else
+          cg.a_load_const_loc(list,a,loc);
+      end;
+    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);
+    var
+      fromcgsize: tcgsize;
+    begin
+      case loc.loc of
+        LOC_SUBSETREG,LOC_CSUBSETREG,
+        LOC_SUBSETREF,LOC_CSUBSETREF:
+          inherited;
+        else
+          begin
+            { avoid problems with 3-byte records and the like }
+            if (fromsize.typ<>floatdef) and
+               (fromsize=tosize) then
+              fromcgsize:=loc.size
+            else
+              { fromsize can be a floatdef (in case the destination is an
+                MMREGISTER) -> use int_cgsize rather than def_cgsize to get the
+                corresponding integer cgsize of the def }
+              fromcgsize:=int_cgsize(fromsize.size);
+            cg.a_load_reg_loc(list,fromcgsize,reg,loc);
+          end;
+      end;
+    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);
+    var
+      tocgsize: tcgsize;
+    begin
+      case loc.loc of
+        LOC_SUBSETREG,LOC_CSUBSETREG,
+        LOC_SUBSETREF,LOC_CSUBSETREF:
+          inherited
+        else
+          begin
+            { avoid problems with 3-byte records and the like }
+            if fromsize=tosize then
+              tocgsize:=loc.size
+            else
+              tocgsize:=def_cgsize(tosize);
+            cg.a_load_loc_reg(list,tocgsize,loc,reg);
+          end;
+      end;
+    end;
+
+  procedure thlcg2ll.a_load_loc_ref(list: TAsmList; fromsize, tosize: tdef; const loc: tlocation; const ref: treference);
+    var
+      tocgsize: tcgsize;
+    begin
+      case loc.loc of
+        LOC_SUBSETREG,LOC_CSUBSETREG,
+        LOC_SUBSETREF,LOC_CSUBSETREF:
+          inherited
+        else
+          begin
+            { avoid problems with 3-byte records and the like }
+            if fromsize=tosize then
+              tocgsize:=loc.size
+            else
+              tocgsize:=def_cgsize(tosize);
+            cg.a_load_loc_ref(list,tocgsize,loc,ref);
+          end;
+      end;
+    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_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_loc_reg(list: TAsmList; fromsize, tosize: tcgsize; const loc: tlocation; const reg: tregister; shuffle: pmmshuffle);
+    var
+      tmpreg: tregister;
+    begin
+      case loc.loc of
+        LOC_SUBSETREG,LOC_CSUBSETREG,
+        LOC_SUBSETREF,LOC_CSUBSETREF:
+          begin
+            tmpreg:=cg.getintregister(list,loc.size);
+            a_load_loc_reg(list,tcgsize2orddef(fromsize),tcgsize2orddef(fromsize),loc,tmpreg);
+            cg.a_loadmm_intreg_reg(list,loc.size,tosize,tmpreg,reg,shuffle);
+          end
+        else
+          cg.a_loadmm_loc_reg(list,tosize,loc,reg,shuffle);
+      end;
+    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_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}
+      case loc.loc of
+        LOC_SUBSETREG,LOC_CSUBSETREG,
+        LOC_SUBSETREF,LOC_CSUBSETREF:
+          inherited
+        else
+          cg.a_op_const_loc(list,op,a,loc);
+      end;
+    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_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}
+      case loc.loc of
+        LOC_SUBSETREG,LOC_CSUBSETREG,
+        LOC_SUBSETREF,LOC_CSUBSETREF:
+          inherited
+        else
+          cg.a_op_reg_loc(list,op,reg,loc)
+      end;
+    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}
+      case loc.loc of
+        LOC_SUBSETREG,LOC_CSUBSETREG,
+        LOC_SUBSETREF,LOC_CSUBSETREF:
+          inherited
+        else
+          cg.a_op_ref_loc(list,op,ref,loc);
+      end;
+    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
+      case loc.loc of
+        LOC_SUBSETREG,LOC_CSUBSETREG,
+        LOC_SUBSETREF,LOC_CSUBSETREF:
+          inherited
+        else
+          cg.a_cmp_const_loc_label(list,def_cgsize(size),cmp_op,a,loc,l);
+      end;
+    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_loc_reg_label(list: TAsmList; size: tdef; cmp_op: topcmp; const loc: tlocation; reg: tregister; l: tasmlabel);
+    begin
+      case loc.loc of
+        LOC_SUBSETREG,LOC_CSUBSETREG,
+        LOC_SUBSETREF,LOC_CSUBSETREF:
+          inherited
+        else
+          cg.a_cmp_loc_reg_label(list,def_cgsize(size),cmp_op,loc,reg,l);
+      end;
+    end;
+
+  procedure thlcg2ll.a_cmp_ref_loc_label(list: TAsmList; size: tdef; cmp_op: topcmp; const ref: treference; const loc: tlocation; l: tasmlabel);
+    begin
+      case loc.loc of
+        LOC_SUBSETREG,LOC_CSUBSETREG,
+        LOC_SUBSETREF,LOC_CSUBSETREF:
+          inherited
+        else
+          cg.a_cmp_ref_loc_label(list,def_cgsize(size),cmp_op,ref,loc,l);
+      end;
+    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_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;
+
+  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);
+    var
+{$ifndef cpu64bitalu}
+      hregisterhi,
+{$endif}
+      hregister : tregister;
+{$ifndef cpu64bitalu}
+      hreg64 : tregister64;
+{$endif}
+      hl: tasmlabel;
+      oldloc : tlocation;
+      const_location: boolean;
+      dst_cgsize: tcgsize;
+    begin
+      oldloc:=l;
+      dst_cgsize:=def_cgsize(dst_size);
+{$ifndef cpu64bitalu}
+      { handle transformations to 64bit separate }
+      if dst_cgsize in [OS_64,OS_S64] then
+       begin
+         if not (l.size in [OS_64,OS_S64]) then
+          begin
+            { load a smaller size to OS_64 }
+            if l.loc=LOC_REGISTER then
+             begin
+{$ifdef AVR}
+               { on avr, we cannot change the size of a register
+                 due to the nature how register with size > OS8 are handled
+               }
+               hregister:=cg.getintregister(list,OS_32);
+{$else AVR}
+               hregister:=cg.makeregsize(list,l.register64.reglo,OS_32);
+{$endif AVR}
+               cg.a_load_reg_reg(list,l.size,OS_32,l.register64.reglo,hregister);
+             end
+            else
+             hregister:=cg.getintregister(list,OS_32);
+            { load value in low register }
+            case l.loc of
+{$ifdef cpuflags}
+              LOC_FLAGS :
+                cg.g_flags2reg(list,OS_INT,l.resflags,hregister);
+{$endif cpuflags}
+              LOC_JUMP :
+                begin
+                  cg.a_label(list,current_procinfo.CurrTrueLabel);
+                  cg.a_load_const_reg(list,OS_INT,1,hregister);
+                  current_asmdata.getjumplabel(hl);
+                  cg.a_jmp_always(list,hl);
+                  cg.a_label(list,current_procinfo.CurrFalseLabel);
+                  cg.a_load_const_reg(list,OS_INT,0,hregister);
+                  cg.a_label(list,hl);
+                end;
+              else
+                a_load_loc_reg(list,src_size,osuinttype,l,hregister);
+            end;
+            { reset hi part, take care of the signed bit of the current value }
+            hregisterhi:=cg.getintregister(list,OS_32);
+            if (l.size in [OS_S8,OS_S16,OS_S32]) then
+             begin
+               if l.loc=LOC_CONSTANT then
+                begin
+                  if (longint(l.value)<0) then
+                   cg.a_load_const_reg(list,OS_32,aint($ffffffff),hregisterhi)
+                  else
+                   cg.a_load_const_reg(list,OS_32,0,hregisterhi);
+                end
+               else
+                begin
+                  cg.a_op_const_reg_reg(list,OP_SAR,OS_32,31,hregister,
+                    hregisterhi);
+                end;
+             end
+            else
+             cg.a_load_const_reg(list,OS_32,0,hregisterhi);
+            location_reset(l,LOC_REGISTER,dst_cgsize);
+            l.register64.reglo:=hregister;
+            l.register64.reghi:=hregisterhi;
+          end
+         else
+          begin
+            { 64bit to 64bit }
+            if ((l.loc=LOC_CREGISTER) and maybeconst) then
+             begin
+               hregister:=l.register64.reglo;
+               hregisterhi:=l.register64.reghi;
+               const_location := true;
+             end
+            else
+             begin
+               hregister:=cg.getintregister(list,OS_32);
+               hregisterhi:=cg.getintregister(list,OS_32);
+               const_location := false;
+             end;
+            hreg64.reglo:=hregister;
+            hreg64.reghi:=hregisterhi;
+            { load value in new register }
+            cg64.a_load64_loc_reg(list,l,hreg64);
+            if not const_location then
+              location_reset(l,LOC_REGISTER,dst_cgsize)
+            else
+              location_reset(l,LOC_CREGISTER,dst_cgsize);
+            l.register64.reglo:=hregister;
+            l.register64.reghi:=hregisterhi;
+          end;
+       end
+      else
+{$endif cpu64bitalu}
+        begin
+          {Do not bother to recycle the existing register. The register
+           allocator eliminates unnecessary moves, so it's not needed
+           and trying to recycle registers can cause problems because
+           the registers changes size and may need aditional constraints.
+
+           Not if it's about LOC_CREGISTER's (JM)
+           }
+          const_location :=
+             (maybeconst) and
+             (l.loc = LOC_CREGISTER) and
+             (TCGSize2Size[l.size] = TCGSize2Size[dst_cgsize]) and
+             ((l.size = dst_cgsize) or
+              (TCGSize2Size[l.size] = sizeof(aint)));
+          if not const_location then
+            hregister:=cg.getintregister(list,dst_cgsize)
+          else
+            hregister := l.register;
+          { load value in new register }
+          case l.loc of
+{$ifdef cpuflags}
+            LOC_FLAGS :
+              cg.g_flags2reg(list,dst_cgsize,l.resflags,hregister);
+{$endif cpuflags}
+            LOC_JUMP :
+              begin
+                cg.a_label(list,current_procinfo.CurrTrueLabel);
+                cg.a_load_const_reg(list,dst_cgsize,1,hregister);
+                current_asmdata.getjumplabel(hl);
+                cg.a_jmp_always(list,hl);
+                cg.a_label(list,current_procinfo.CurrFalseLabel);
+                cg.a_load_const_reg(list,dst_cgsize,0,hregister);
+                cg.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 (TCGSize2Size[dst_cgsize]<TCGSize2Size[l.size]) then
+                 begin
+                   if (l.loc in [LOC_REGISTER,LOC_CREGISTER]) then
+                     l.register:=cg.makeregsize(list,l.register,dst_cgsize);
+                   { for big endian systems, the reference's offset must }
+                   { be increased in this case, since they have the      }
+                   { MSB first in memory and e.g. byte(word_var) should  }
+                   { return  the second byte in this case (JM)           }
+                   if (target_info.endian = ENDIAN_BIG) and
+                      (l.loc in [LOC_REFERENCE,LOC_CREFERENCE]) then
+                     begin
+                       inc(l.reference.offset,TCGSize2Size[l.size]-TCGSize2Size[dst_cgsize]);
+                       l.reference.alignment:=newalignment(l.reference.alignment,TCGSize2Size[l.size]-TCGSize2Size[dst_cgsize]);
+                     end;
+{$ifdef x86}
+                   if not (l.loc in [LOC_SUBSETREG,LOC_CSUBSETREG]) then
+                     begin
+                       l.size:=dst_cgsize;
+                       src_size:=dst_size;
+                     end;
+{$endif x86}
+                 end;
+                a_load_loc_reg(list,src_size,dst_size,l,hregister);
+                if (TCGSize2Size[dst_cgsize]<TCGSize2Size[l.size])
+{$ifdef x86}
+                   and (l.loc in [LOC_SUBSETREG,LOC_CSUBSETREG])
+{$endif x86}
+                  then
+                    l.size:=dst_cgsize;
+              end;
+          end;
+          if not const_location then
+            location_reset(l,LOC_REGISTER,dst_cgsize)
+          else
+            location_reset(l,LOC_CREGISTER,dst_cgsize);
+          l.register:=hregister;
+        end;
+      { Release temp when it was a reference }
+      if oldloc.loc=LOC_REFERENCE then
+          location_freetemp(list,oldloc);
+    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);
+    var
+      r: treference;
+    begin
+      case l.loc of
+        LOC_FPUREGISTER,
+        LOC_CFPUREGISTER :
+          begin
+            { implement here using tcg because some platforms store records
+              in fpu registers in some cases, and a_loadfpu* can't deal with
+              record "size" parameters }
+            tg.gethltemp(list,size,size.size,tt_normal,r);
+            cg.a_loadfpu_reg_ref(list,l.size,l.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
+            tg.gethltemp(list,size,size.size,tt_normal,r);
+{$ifndef cpu64bitalu}
+            if l.size in [OS_64,OS_S64] then
+              cg64.a_load64_loc_ref(list,l,r)
+            else
+{$endif not cpu64bitalu}
+              a_load_loc_ref(list,size,size,l,r);
+            location_reset_ref(l,LOC_REFERENCE,l.size,0);
+            l.reference:=r;
+          end;
+        else
+          inherited;
+      end;
+    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_loadfpu_loc_cgpara(list: TAsmList; size: tdef; const l: tlocation; const cgpara: tcgpara; locintsize: longint);
+    var
+      locsize : tcgsize;
+      tmploc : tlocation;
+    begin
+      if not(l.size in [OS_32,OS_S32,OS_64,OS_S64,OS_128,OS_S128]) then
+        locsize:=l.size
+      else
+        locsize:=int_float_cgsize(tcgsize2size[l.size]);
+      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,size,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:
+              cg.a_loadfpu_reg_cgpara(list,locsize,l.register,cgpara);
+            else
+              internalerror(2002042433);
+          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:
+              cg.a_loadfpu_ref_cgpara(list,locsize,l.reference,cgpara);
+            else
+              internalerror(2002042431);
+          end;
+        LOC_REGISTER,
+        LOC_CREGISTER :
+          begin
+{$ifndef cpu64bitalu}
+             { Only a_load_ref_cgpara supports multiple locations, when the
+               value is still a const or in a register then write it
+               to a reference first. This situation can be triggered
+               by typecasting an int64 constant to a record of 8 bytes }
+             if locsize = OS_F64 then
+               begin
+                 tmploc:=l;
+                 location_force_mem(list,tmploc,size);
+                 cg.a_load_loc_cgpara(list,tmploc,cgpara);
+                 location_freetemp(list,tmploc);
+               end
+             else
+{$endif not cpu64bitalu}
+               cg.a_load_loc_cgpara(list,l,cgpara);
+          end;
+        else
+          internalerror(2002042432);
+      end;
+    end;
+
+  procedure thlcg2ll.gen_load_loc_cgpara(list: TAsmList; vardef: tdef; const l: tlocation; const cgpara: tcgpara);
+{$ifndef cpu64bitalu}
+    var
+      tmploc: tlocation;
+{$endif not cpu64bitalu}
+    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
+{$ifndef cpu64bitalu}
+            { use cg64 only for int64, not for 8 byte records }
+            if is_64bit(vardef) then
+              cg64.a_load64_loc_cgpara(list,l,cgpara)
+            else
+{$endif not cpu64bitalu}
+              begin
+{$ifndef cpu64bitalu}
+                { Only a_load_ref_cgpara supports multiple locations, when the
+                  value is still a const or in a register then write it
+                  to a reference first. This situation can be triggered
+                  by typecasting an int64 constant to a record of 8 bytes }
+                if l.size in [OS_64,OS_S64] then
+                  begin
+                    tmploc:=l;
+                    location_force_mem(list,tmploc,vardef);
+                    a_load_loc_cgpara(list,vardef,tmploc,cgpara);
+                    { do not free the tmploc in case the original value was
+                      already in memory, because the caller (ncgcal) will then
+                      free it again later }
+                    if not(l.loc in [LOC_REFERENCE,LOC_CREFERENCE]) then
+                      location_freetemp(list,tmploc);
+                  end
+                else
+{$endif not cpu64bitalu}
+                  a_load_loc_cgpara(list,vardef,l,cgpara);
+              end;
+          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;
+{$ifdef SUPPORT_MMX}
+        LOC_MMXREGISTER,
+        LOC_CMMXREGISTER:
+          cg.a_loadmm_reg_cgpara(list,OS_M64,l.register,cgpara,nil);
+{$endif SUPPORT_MMX}
+        else
+          internalerror(200204241);
+      end;
+    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,4322 @@
+{
+    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
+       tsubsetloadopt = (SL_REG,SL_REGNOSRCMASK,SL_SETZERO,SL_SETMAX);
+       {# @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;
+          {# Get a specific register.}
+          procedure getcpuregister(list:TAsmList;r:Tregister);virtual;
+          procedure ungetcpuregister(list:TAsmList;r:Tregister);virtual;
+          {# Get multiple registers specified.}
+          procedure alloccpuregisters(list:TAsmList;rt:Tregistertype;const r:Tcpuregisterset);virtual;
+          {# Free multiple registers specified.}
+          procedure dealloccpuregisters(list:TAsmList;rt:Tregistertype;const r:Tcpuregisterset);virtual;
+
+          procedure allocallcpuregisters(list:TAsmList);virtual;
+          procedure deallocallcpuregisters(list:TAsmList);virtual;
+
+          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;
+          { # Returns orddef corresponding to size }
+          class function tcgsize2orddef(size: tcgsize): torddef; static;
+
+          {# 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 : 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;const ref : treference);virtual;
+          { 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, tosubsetsize: tdef; const loc: tlocation; const sreg : tsubsetregister);virtual;
+          procedure a_load_loc_subsetref(list : TAsmList;fromsize, 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;
+
+          { For subsetreg/ref, the def is the size of the packed element. The
+            size of the register that holds the data is a tcgsize, and hence
+            always must be an orddef of the corresponding size in practice }
+          procedure a_load_subsetreg_reg(list : TAsmList; subsetsize, tosize: tdef; const sreg: tsubsetregister; destreg: tregister); virtual;
+          procedure a_load_reg_subsetreg(list : TAsmList; fromsize, tosubsetsize: tdef; fromreg: tregister; const sreg: tsubsetregister); virtual;
+          procedure a_load_subsetreg_subsetreg(list: TAsmlist; fromsubsetsize, tosubsetsize : tdef; const fromsreg, tosreg: tsubsetregister); virtual;
+          procedure a_load_subsetreg_ref(list : TAsmList; fromsubsetsize, tosize: tdef; const sreg: tsubsetregister; const destref: treference); virtual;
+          procedure a_load_ref_subsetreg(list : TAsmList; fromsize, tosubsetsize: tdef; const fromref: treference; const sreg: tsubsetregister); virtual;
+          procedure a_load_const_subsetreg(list: TAsmlist; tosubsetsize: tdef; a: aint; const sreg: tsubsetregister); virtual;
+          procedure a_load_subsetreg_loc(list: TAsmlist; fromsubsetsize, tosize: tdef; const sreg: tsubsetregister; const loc: tlocation); virtual;
+
+          procedure a_load_subsetref_reg(list : TAsmList; fromsubsetsize, tosize: tdef; const sref: tsubsetreference; destreg: tregister); virtual;
+          procedure a_load_reg_subsetref(list : TAsmList; fromsize, tosubsetsize: tdef; fromreg: tregister; const sref: tsubsetreference); virtual;
+          procedure a_load_subsetref_subsetref(list: TAsmlist; fromsubsetsize, tosubsetsize : tdef; const fromsref, tosref: tsubsetreference); virtual;
+          procedure a_load_subsetref_ref(list : TAsmList; fromsubsetsize, tosize: tdef; const sref: tsubsetreference; const destref: treference); virtual;
+          procedure a_load_ref_subsetref(list : TAsmList; fromsize, tosubsetsize: tdef; const fromref: treference; const sref: tsubsetreference); virtual;
+          procedure a_load_const_subsetref(list: TAsmlist; tosubsetsize: tdef; a: tcgint; const sref: tsubsetreference); virtual;
+          procedure a_load_subsetref_loc(list: TAsmlist; fromsubsetsize, tosize: tdef; const sref: tsubsetreference; const loc: tlocation); virtual;
+          procedure a_load_subsetref_subsetreg(list: TAsmlist; fromsubsetsize, tosubsetsize : tdef; const fromsref: tsubsetreference; const tosreg: tsubsetregister); virtual;
+          procedure a_load_subsetreg_subsetref(list: TAsmlist; fromsubsetsize, tosubsetsize : tdef; const fromsreg: tsubsetregister; const tosref: tsubsetreference); virtual;
+
+          { bit test instructions }
+          procedure a_bit_test_reg_reg_reg(list : TAsmList; bitnumbersize,valuesize,destsize: tdef;bitnumber,value,destreg: tregister); virtual;
+          procedure a_bit_test_const_ref_reg(list: TAsmList; fromsize, destsize: tdef; bitnumber: aint; const ref: treference; destreg: tregister); virtual;
+          procedure a_bit_test_const_reg_reg(list: TAsmList; setregsize, destsize: tdef; bitnumber: aint; setreg, destreg: tregister); virtual;
+          procedure a_bit_test_const_subsetreg_reg(list: TAsmList; fromsubsetsize, destsize: tdef; bitnumber: aint; const setreg: tsubsetregister; destreg: tregister); virtual;
+          procedure a_bit_test_reg_ref_reg(list: TAsmList; bitnumbersize, refsize, destsize: tdef; bitnumber: tregister; const ref: treference; destreg: tregister); virtual;
+          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 }
+          procedure a_bit_set_reg_reg(list : TAsmList; doset: boolean; bitnumbersize, destsize: tdef; bitnumber,dest: tregister); virtual;
+          procedure a_bit_set_const_ref(list: TAsmList; doset: boolean;destsize: tdef; bitnumber: aint; const ref: treference); virtual;
+          procedure a_bit_set_const_reg(list: TAsmList; doset: boolean; destsize: tdef; bitnumber: aint; destreg: tregister); virtual;
+          procedure a_bit_set_const_subsetreg(list: TAsmList; doset: boolean; destsize: tdef; bitnumber: aint; const destreg: tsubsetregister); virtual;
+          procedure a_bit_set_reg_ref(list: TAsmList; doset: boolean; fromsize, tosize: tdef; bitnumber: tregister; const ref: treference); virtual;
+          procedure a_bit_set_reg_loc(list: TAsmList; doset: boolean; regsize, 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;
+
+         protected
+           procedure get_subsetref_load_info(const sref: tsubsetreference; out loadsize: torddef; out extra_load: boolean);
+           procedure a_load_subsetref_regs_noindex(list: TAsmList; subsetsize: tdef; loadbitsize: byte; const sref: tsubsetreference; valuereg, extra_value_reg: tregister); virtual;
+           procedure a_load_subsetref_regs_index(list: TAsmList; subsetsize: tdef; loadbitsize: byte; const sref: tsubsetreference; valuereg: tregister); virtual;
+
+           procedure a_load_regconst_subsetref_intern(list : TAsmList; fromsize, subsetsize: tdef; fromreg: tregister; const sref: tsubsetreference; slopt: tsubsetloadopt); virtual;
+           procedure a_load_regconst_subsetreg_intern(list : TAsmList; fromsize, subsetsize: tdef; fromreg: tregister; const sreg: tsubsetregister; slopt: tsubsetloadopt); virtual;
+
+           { return a subsetref that represents bit "bitnumber" in ref, if ref
+             has the type "refdef". The subsetref must be addressable via
+             (unsigned) 8 bit access, unless all the *_bit_* methods are
+             overloaded and use something else. }
+           function get_bit_const_ref_sref(bitnumber: tcgint; refdef: tdef; const ref: treference): tsubsetreference;
+           function get_bit_const_reg_sreg(setregsize: tdef; bitnumber: tcgint; setreg: tregister): tsubsetregister;
+           function get_bit_reg_ref_sref(list: TAsmList; bitnumbersize, refsize: tdef; bitnumber: tregister; const ref: treference): tsubsetreference;
+         public
+
+          { 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;
+}
+          { required for subsetreg/ref; still tcgsize rather than tdef because of reason mentioned above }
+          procedure a_loadmm_loc_reg(list: TAsmList; fromsize, tosize: tcgsize; const loc: tlocation; const reg: tregister;shuffle : pmmshuffle);virtual; abstract;
+{
+          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, destsubsetsize: tdef; reg: TRegister; const sreg: tsubsetregister); virtual;
+          procedure a_op_reg_subsetref(list: TAsmList; Op: TOpCG; opsize, 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; fromsubsetsize, cmpsize: tdef; cmp_op: topcmp; const sreg: tsubsetregister; reg: tregister; l: tasmlabel); virtual;
+          procedure a_cmp_subsetref_reg_label(list: TAsmList; 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);
+          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;
+          procedure g_copyvariant(list : TAsmList;const source,dest : treference;vardef:tvariantdef);virtual;
+
+          procedure g_incrrefcount(list : TAsmList;t: tdef; const ref: treference);virtual;
+          procedure g_initialize(list : TAsmList;t : tdef;const ref : treference);virtual;
+          procedure g_finalize(list : TAsmList;t : tdef;const ref : treference);virtual;
+          procedure g_array_rtti_helper(list: TAsmList; t: tdef; const ref: treference; const highloc: tlocation;
+            const name: string);virtual;
+
+          {# 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;
+
+          { 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,ncgrtti,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.getcpuregister(list: TAsmList; r: Tregister);
+    begin
+      cg.getcpuregister(list,r);
+    end;
+
+  procedure thlcgobj.ungetcpuregister(list: TAsmList; r: Tregister);
+    begin
+      cg.ungetcpuregister(list,r);
+    end;
+
+  procedure thlcgobj.alloccpuregisters(list: TAsmList; rt: Tregistertype; const r: Tcpuregisterset);
+    begin
+      cg.alloccpuregisters(list,rt,r);
+    end;
+
+  procedure thlcgobj.dealloccpuregisters(list: TAsmList; rt: Tregistertype; const r: Tcpuregisterset);
+    begin
+      cg.dealloccpuregisters(list,rt,r);
+    end;
+
+  procedure thlcgobj.allocallcpuregisters(list: TAsmList);
+    begin
+      cg.allocallcpuregisters(list);
+    end;
+
+  procedure thlcgobj.deallocallcpuregisters(list: TAsmList);
+    begin
+      cg.deallocallcpuregisters(list);
+    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;
+
+  class function thlcgobj.tcgsize2orddef(size: tcgsize): torddef;
+    begin
+      case size of
+        OS_8:
+          result:=torddef(u8inttype);
+        OS_S8:
+          result:=torddef(s8inttype);
+        OS_16:
+          result:=torddef(u16inttype);
+        OS_S16:
+          result:=torddef(s16inttype);
+        OS_32:
+          result:=torddef(u32inttype);
+        OS_S32:
+          result:=torddef(s32inttype);
+        OS_64:
+          result:=torddef(u64inttype);
+        OS_S64:
+          result:=torddef(s64inttype);
+        else
+          internalerror(2012050401);
+      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,cgpara.def,r,ref);
+             a_loadfpu_ref_cgpara(list,cgpara.def,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: 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,cgpara.def,r,cgpara.location^.register)
+         end
+       else
+         begin
+           hr:=getaddressregister(list,cgpara.def);
+           a_loadaddr_ref_reg(list,fromsize,cgpara.def,r,hr);
+           a_load_reg_cgpara(list,cgpara.def,hr,cgpara);
+         end;
+    end;
+
+  procedure thlcgobj.a_call_ref(list: TAsmList; pd: tabstractprocdef; const ref: treference);
+    var
+      reg: tregister;
+      size: tdef;
+    begin
+      { the loaded data is always a pointer to a procdef. A procvardef is
+        implicitly a pointer already, but a procdef isn't -> create one }
+      if pd.typ=procvardef then
+        size:=pd
+      else
+        size:=getpointerdef(pd);
+      reg:=getaddressregister(list,size);
+      a_load_ref_reg(list,size,size,ref,reg);
+      a_call_reg(list,pd,reg);
+    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);
+        LOC_SUBSETREG,LOC_CSUBSETREG:
+          a_load_const_subsetreg(list,tosize,a,loc.sreg);
+        LOC_SUBSETREF,LOC_CSUBSETREF:
+          a_load_const_subsetref(list,tosize,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);
+        LOC_SUBSETREG,LOC_CSUBSETREG:
+          a_load_reg_subsetreg(list,fromsize,tosize,reg,loc.sreg);
+        LOC_SUBSETREF,LOC_CSUBSETREF:
+          a_load_reg_subsetref(list,fromsize,tosize,reg,loc.sref);
+        { we don't have enough type information to handle these here
+        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);
+        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);
+        LOC_SUBSETREG,LOC_CSUBSETREG:
+          a_load_subsetreg_ref(list,fromsize,tosize,loc.sreg,ref);
+        LOC_SUBSETREF,LOC_CSUBSETREF:
+          a_load_subsetref_ref(list,fromsize,tosize,loc.sref,ref);
+        else
+          internalerror(2010120403);
+      end;
+    end;
+
+  procedure thlcgobj.a_load_loc_subsetreg(list: TAsmList; fromsize, tosubsetsize: tdef; const loc: tlocation; const sreg: tsubsetregister);
+    begin
+      case loc.loc of
+        LOC_REFERENCE,LOC_CREFERENCE:
+          a_load_ref_subsetreg(list,fromsize,tosubsetsize,loc.reference,sreg);
+        LOC_REGISTER,LOC_CREGISTER:
+          a_load_reg_subsetreg(list,fromsize,tosubsetsize,loc.register,sreg);
+        LOC_CONSTANT:
+          a_load_const_subsetreg(list,tosubsetsize,loc.value,sreg);
+        LOC_SUBSETREG,LOC_CSUBSETREG:
+          a_load_subsetreg_subsetreg(list,fromsize,tosubsetsize,loc.sreg,sreg);
+        LOC_SUBSETREF,LOC_CSUBSETREF:
+          a_load_subsetref_subsetreg(list,fromsize,tosubsetsize,loc.sref,sreg);
+        else
+          internalerror(2010120404);
+      end;
+    end;
+
+  procedure thlcgobj.a_load_loc_subsetref(list: TAsmList; fromsize, tosubsetsize: tdef; const loc: tlocation; const sref: tsubsetreference);
+    begin
+      case loc.loc of
+        LOC_REFERENCE,LOC_CREFERENCE:
+          a_load_ref_subsetref(list,fromsize,tosubsetsize,loc.reference,sref);
+        LOC_REGISTER,LOC_CREGISTER:
+          a_load_reg_subsetref(list,fromsize,tosubsetsize,loc.register,sref);
+        LOC_CONSTANT:
+          a_load_const_subsetref(list,tosubsetsize,loc.value,sref);
+        LOC_SUBSETREG,LOC_CSUBSETREG:
+          a_load_subsetreg_subsetref(list,fromsize,tosubsetsize,loc.sreg,sref);
+        LOC_SUBSETREF,LOC_CSUBSETREF:
+          a_load_subsetref_subsetref(list,fromsize,tosubsetsize,loc.sref,sref);
+        else
+          internalerror(2010120405);
+      end;
+    end;
+
+{$push}
+{$r-,q-}
+
+  procedure thlcgobj.a_load_subsetreg_reg(list: TAsmList; subsetsize, tosize: tdef; const sreg: tsubsetregister; destreg: tregister);
+    var
+      subsetregdef: torddef;
+      bitmask: aword;
+      tmpreg,
+      subsetsizereg: tregister;
+      stopbit: byte;
+    begin
+      subsetregdef:=tcgsize2orddef(sreg.subsetregsize);
+      tmpreg:=getintregister(list,subsetregdef);
+      if is_signed(subsetsize) then
+        begin
+          { sign extend in case the value has a bitsize mod 8 <> 0 }
+          { both instructions will be optimized away if not        }
+          a_op_const_reg_reg(list,OP_SHL,subsetregdef,(tcgsize2size[sreg.subsetregsize]*8)-sreg.startbit-sreg.bitlen,sreg.subsetreg,tmpreg);
+          a_op_const_reg(list,OP_SAR,subsetregdef,(tcgsize2size[sreg.subsetregsize]*8)-sreg.bitlen,tmpreg);
+        end
+      else
+        begin
+          a_op_const_reg_reg(list,OP_SHR,subsetregdef,sreg.startbit,sreg.subsetreg,tmpreg);
+          stopbit:=sreg.startbit+sreg.bitlen;
+          // on x86(64), 1 shl 32(64) = 1 instead of 0
+          // use aword to prevent overflow with 1 shl 31
+          if (stopbit-sreg.startbit<>AIntBits) then
+            bitmask:=(aword(1) shl (stopbit-sreg.startbit))-1
+          else
+            bitmask:=high(aword);
+          a_op_const_reg(list,OP_AND,subsetregdef,tcgint(bitmask),tmpreg);
+        end;
+      subsetsizereg:=getintregister(list,subsetsize);
+      a_load_reg_reg(list,subsetregdef,subsetsize,tmpreg,subsetsizereg);
+      a_load_reg_reg(list,subsetsize,tosize,subsetsizereg,destreg);
+    end;
+
+  procedure thlcgobj.a_load_reg_subsetreg(list: TAsmList; fromsize, tosubsetsize: tdef; fromreg: tregister; const sreg: tsubsetregister);
+    begin
+      a_load_regconst_subsetreg_intern(list,fromsize,tosubsetsize,fromreg,sreg,SL_REG);
+    end;
+
+  procedure thlcgobj.a_load_subsetreg_subsetreg(list: TAsmlist; fromsubsetsize, tosubsetsize: tdef; const fromsreg, tosreg: tsubsetregister);
+    var
+      fromsubsetregdef,
+      tosubsetregdef: torddef;
+      tmpreg, tmpreg2: tregister;
+      bitmask: aword;
+      stopbit: byte;
+    begin
+      if (fromsreg.bitlen>=tosreg.bitlen) then
+        begin
+          fromsubsetregdef:=tcgsize2orddef(fromsreg.subsetregsize);
+          tosubsetregdef:=tcgsize2orddef(tosreg.subsetregsize);
+          if (fromsreg.startbit<=tosreg.startbit) then
+            begin
+              { tosreg may be larger -> use its size to perform the shift }
+              tmpreg:=getintregister(list,tosubsetregdef);
+              a_load_reg_reg(list,fromsubsetregdef,tosubsetregdef,fromsreg.subsetreg,tmpreg);
+              a_op_const_reg(list,OP_SHL,tosubsetregdef,tosreg.startbit-fromsreg.startbit,tmpreg)
+            end
+          else
+            begin
+              { fromsreg may be larger -> use its size to perform the shift }
+              tmpreg:=getintregister(list,fromsubsetregdef);
+              a_op_const_reg_reg(list,OP_SHR,fromsubsetregdef,fromsreg.startbit-tosreg.startbit,fromsreg.subsetreg,tmpreg);
+              tmpreg2:=getintregister(list,tosubsetregdef);
+              a_load_reg_reg(list,fromsubsetregdef,tosubsetregdef,tmpreg,tmpreg2);
+              tmpreg:=tmpreg2;
+            end;
+          stopbit:=tosreg.startbit + tosreg.bitlen;
+          // on x86(64), 1 shl 32(64) = 1 instead of 0
+          if (stopbit<>AIntBits) then
+            bitmask:=not(((aword(1) shl stopbit)-1) xor ((aword(1) shl tosreg.startbit)-1))
+           else
+             bitmask:=(aword(1) shl tosreg.startbit) - 1;
+          a_op_const_reg(list,OP_AND,tosubsetregdef,tcgint(bitmask),tosreg.subsetreg);
+          a_op_const_reg(list,OP_AND,tosubsetregdef,tcgint(not(bitmask)),tmpreg);
+          a_op_reg_reg(list,OP_OR,tosubsetregdef,tmpreg,tosreg.subsetreg);
+        end
+      else
+        begin
+          tmpreg:=getintregister(list,tosubsetsize);
+          a_load_subsetreg_reg(list,fromsubsetsize,tosubsetsize,fromsreg,tmpreg);
+          a_load_reg_subsetreg(list,tosubsetsize,tosubsetsize,tmpreg,tosreg);
+        end;
+    end;
+
+  procedure thlcgobj.a_load_subsetreg_ref(list: TAsmList; fromsubsetsize, tosize: tdef; const sreg: tsubsetregister; const destref: treference);
+    var
+      tmpreg: tregister;
+    begin
+      tmpreg:=getintregister(list,tosize);
+      a_load_subsetreg_reg(list,fromsubsetsize,tosize,sreg,tmpreg);
+      a_load_reg_ref(list,tosize,tosize,tmpreg,destref);
+    end;
+
+  procedure thlcgobj.a_load_ref_subsetreg(list: TAsmList; fromsize, tosubsetsize: tdef; const fromref: treference; const sreg: tsubsetregister);
+    var
+      tmpreg: tregister;
+    begin
+      tmpreg := getintregister(list,tosubsetsize);
+      a_load_ref_reg(list,fromsize,tosubsetsize,fromref,tmpreg);
+      a_load_reg_subsetreg(list,tosubsetsize,tosubsetsize,tmpreg,sreg);
+    end;
+
+  procedure thlcgobj.a_load_const_subsetreg(list: TAsmlist; tosubsetsize: tdef; a: aint; const sreg: tsubsetregister);
+    var
+      subsetregdef: torddef;
+      bitmask: aword;
+      stopbit: byte;
+    begin
+       subsetregdef:=tcgsize2orddef(sreg.subsetregsize);
+       stopbit:=sreg.startbit+sreg.bitlen;
+       // on x86(64), 1 shl 32(64) = 1 instead of 0
+       if (stopbit<>AIntBits) then
+         bitmask:=not(((aword(1) shl stopbit)-1) xor ((aword(1) shl sreg.startbit)-1))
+       else
+         bitmask:=(aword(1) shl sreg.startbit)-1;
+       if (((aword(a) shl sreg.startbit) and not bitmask)<>not bitmask) then
+         a_op_const_reg(list,OP_AND,subsetregdef,tcgint(bitmask),sreg.subsetreg);
+       a_op_const_reg(list,OP_OR,subsetregdef,tcgint((aword(a) shl sreg.startbit) and not(bitmask)),sreg.subsetreg);
+    end;
+
+  procedure thlcgobj.a_load_subsetreg_loc(list: TAsmlist; fromsubsetsize, tosize: tdef; const sreg: tsubsetregister; const loc: tlocation);
+    begin
+      case loc.loc of
+        LOC_REFERENCE,LOC_CREFERENCE:
+          a_load_subsetreg_ref(list,fromsubsetsize,tosize,sreg,loc.reference);
+        LOC_REGISTER,LOC_CREGISTER:
+          a_load_subsetreg_reg(list,fromsubsetsize,tosize,sreg,loc.register);
+        LOC_SUBSETREG,LOC_CSUBSETREG:
+          a_load_subsetreg_subsetreg(list,fromsubsetsize,tosize,sreg,loc.sreg);
+        LOC_SUBSETREF,LOC_CSUBSETREF:
+          a_load_subsetreg_subsetref(list,fromsubsetsize,tosize,sreg,loc.sref);
+        else
+          internalerror(2010120406);
+      end;
+    end;
+
+  procedure thlcgobj.a_load_subsetref_reg(list: TAsmList; fromsubsetsize, tosize: tdef; const sref: tsubsetreference; destreg: tregister);
+    var
+      tmpref: treference;
+      valuereg,extra_value_reg: tregister;
+      tosreg: tsubsetregister;
+      loadsize: torddef;
+      loadbitsize: byte;
+      extra_load: boolean;
+    begin
+      get_subsetref_load_info(sref,loadsize,extra_load);
+      loadbitsize:=loadsize.size*8;
+
+      { load the (first part) of the bit sequence }
+      valuereg:=getintregister(list,osuinttype);
+      a_load_ref_reg(list,loadsize,osuinttype,sref.ref,valuereg);
+
+      if not extra_load then
+        begin
+          { everything is guaranteed to be in a single register of loadsize }
+          if (sref.bitindexreg=NR_NO) then
+            begin
+              { use subsetreg routine, it may have been overridden with an optimized version }
+              tosreg.subsetreg:=valuereg;
+              tosreg.subsetregsize:=def_cgsize(osuinttype);
+              { subsetregs always count bits from right to left }
+              if (target_info.endian=endian_big) then
+                tosreg.startbit:=loadbitsize-(sref.startbit+sref.bitlen)
+              else
+                tosreg.startbit:=sref.startbit;
+              tosreg.bitlen:=sref.bitlen;
+              a_load_subsetreg_reg(list,fromsubsetsize,tosize,tosreg,destreg);
+              exit;
+            end
+          else
+            begin
+              if (sref.startbit<>0) then
+                internalerror(2006081510);
+              if (target_info.endian=endian_big) then
+                begin
+                  a_op_reg_reg(list,OP_SHL,osuinttype,sref.bitindexreg,valuereg);
+                  if is_signed(fromsubsetsize) then
+                    begin
+                      { sign extend to entire register }
+                      a_op_const_reg(list,OP_SHL,osuinttype,AIntBits-loadbitsize,valuereg);
+                      a_op_const_reg(list,OP_SAR,osuinttype,AIntBits-sref.bitlen,valuereg);
+                    end
+                  else
+                    a_op_const_reg(list,OP_SHR,osuinttype,loadbitsize-sref.bitlen,valuereg);
+                end
+              else
+                begin
+                  a_op_reg_reg(list,OP_SHR,osuinttype,sref.bitindexreg,valuereg);
+                  if is_signed(fromsubsetsize) then
+                    begin
+                      a_op_const_reg(list,OP_SHL,osuinttype,AIntBits-sref.bitlen,valuereg);
+                      a_op_const_reg(list,OP_SAR,osuinttype,AIntBits-sref.bitlen,valuereg);
+                    end
+                end;
+              { mask other bits/sign extend }
+              if not is_signed(fromsubsetsize) then
+                a_op_const_reg(list,OP_AND,osuinttype,tcgint((aword(1) shl sref.bitlen)-1),valuereg);
+            end
+        end
+      else
+        begin
+          { load next value as well }
+          extra_value_reg:=getintregister(list,osuinttype);
+
+          if (sref.bitindexreg=NR_NO) then
+            begin
+              tmpref:=sref.ref;
+              inc(tmpref.offset,loadbitsize div 8);
+              a_load_ref_reg(list,loadsize,osuinttype,tmpref,extra_value_reg);
+              { can be overridden to optimize }
+              a_load_subsetref_regs_noindex(list,fromsubsetsize,loadbitsize,sref,valuereg,extra_value_reg)
+            end
+          else
+            begin
+              if (sref.startbit<>0) then
+                internalerror(2006080610);
+              a_load_subsetref_regs_index(list,fromsubsetsize,loadbitsize,sref,valuereg);
+            end;
+        end;
+
+      { store in destination }
+{$ifndef cpuhighleveltarget}
+      { avoid unnecessary sign extension and zeroing }
+      valuereg:=cg.makeregsize(list,valuereg,OS_INT);
+      destreg:=cg.makeregsize(list,destreg,OS_INT);
+      cg.a_load_reg_reg(list,OS_INT,OS_INT,valuereg,destreg);
+      destreg:=cg.makeregsize(list,destreg,def_cgsize(tosize));
+{$else}
+      { can't juggle with register sizes, they are actually typed entities
+        here }
+      a_load_reg_reg(list,osuinttype,tosize,valuereg,destreg);
+{$endif}
+    end;
+
+  procedure thlcgobj.a_load_reg_subsetref(list: TAsmList; fromsize, tosubsetsize: tdef; fromreg: tregister; const sref: tsubsetreference);
+    begin
+      a_load_regconst_subsetref_intern(list,fromsize,tosubsetsize,fromreg,sref,SL_REG);
+    end;
+
+  procedure thlcgobj.a_load_subsetref_subsetref(list: TAsmlist; fromsubsetsize, tosubsetsize: tdef; const fromsref, tosref: tsubsetreference);
+    var
+      tmpreg: tregister;
+    begin
+      tmpreg:=getintregister(list,tosubsetsize);
+      a_load_subsetref_reg(list,fromsubsetsize,tosubsetsize,fromsref,tmpreg);
+      a_load_reg_subsetref(list,tosubsetsize,tosubsetsize,tmpreg,tosref);
+    end;
+
+  procedure thlcgobj.a_load_subsetref_ref(list: TAsmList; fromsubsetsize, tosize: tdef; const sref: tsubsetreference; const destref: treference);
+    var
+      tmpreg: tregister;
+    begin
+      tmpreg:=getintregister(list,tosize);
+      a_load_subsetref_reg(list,fromsubsetsize,tosize,sref,tmpreg);
+      a_load_reg_ref(list,tosize,tosize,tmpreg,destref);
+    end;
+
+  procedure thlcgobj.a_load_ref_subsetref(list: TAsmList; fromsize, tosubsetsize: tdef; const fromref: treference; const sref: tsubsetreference);
+    var
+      tmpreg: tregister;
+    begin
+      tmpreg := getintregister(list,tosubsetsize);
+      a_load_ref_reg(list,fromsize,tosubsetsize,fromref,tmpreg);
+      a_load_reg_subsetref(list,tosubsetsize,tosubsetsize,tmpreg,sref);
+    end;
+
+  procedure thlcgobj.a_load_const_subsetref(list: TAsmlist; tosubsetsize: tdef; a: tcgint; const sref: tsubsetreference);
+    var
+      tmpreg: tregister;
+      slopt: tsubsetloadopt;
+    begin
+      { perform masking of the source value in advance }
+      slopt:=SL_REGNOSRCMASK;
+      if (sref.bitlen<>AIntBits) then
+        a:=tcgint(aword(a) and ((aword(1) shl sref.bitlen) -1));
+      if (
+          { broken x86 "x shl regbitsize = x" }
+          ((sref.bitlen<>AIntBits) and
+           ((aword(a) and ((aword(1) shl sref.bitlen)-1))=(aword(1) shl sref.bitlen)-1)) or
+          ((sref.bitlen=AIntBits) and
+           (a=-1))
+         ) then
+        slopt:=SL_SETMAX
+      else if (a=0) then
+        slopt:=SL_SETZERO;
+      if not(slopt in [SL_SETZERO,SL_SETMAX]) then
+        begin
+          tmpreg:=getintregister(list,tosubsetsize);
+          a_load_const_reg(list,tosubsetsize,a,tmpreg);
+        end
+      else
+        tmpreg:=NR_NO;
+      a_load_regconst_subsetref_intern(list,tosubsetsize,tosubsetsize,tmpreg,sref,slopt);
+    end;
+
+  procedure thlcgobj.a_load_subsetref_loc(list: TAsmlist; fromsubsetsize, tosize: tdef; const sref: tsubsetreference; const loc: tlocation);
+    begin
+      case loc.loc of
+        LOC_REFERENCE,LOC_CREFERENCE:
+          a_load_subsetref_ref(list,fromsubsetsize,tosize,sref,loc.reference);
+        LOC_REGISTER,LOC_CREGISTER:
+          a_load_subsetref_reg(list,fromsubsetsize,tosize,sref,loc.register);
+        LOC_SUBSETREG,LOC_CSUBSETREG:
+          a_load_subsetref_subsetreg(list,fromsubsetsize,tosize,sref,loc.sreg);
+        LOC_SUBSETREF,LOC_CSUBSETREF:
+          a_load_subsetref_subsetref(list,fromsubsetsize,tosize,sref,loc.sref);
+        else
+          internalerror(2010120407);
+      end;
+    end;
+
+  procedure thlcgobj.a_load_subsetref_subsetreg(list: TAsmlist; fromsubsetsize, tosubsetsize: tdef; const fromsref: tsubsetreference; const tosreg: tsubsetregister);
+    var
+      tmpreg: tregister;
+    begin
+      tmpreg:=getintregister(list,tosubsetsize);
+      a_load_subsetref_reg(list,fromsubsetsize,tosubsetsize,fromsref,tmpreg);
+      a_load_reg_subsetreg(list,tosubsetsize,tosubsetsize,tmpreg,tosreg);
+    end;
+
+  procedure thlcgobj.a_load_subsetreg_subsetref(list: TAsmlist; fromsubsetsize, tosubsetsize: tdef; const fromsreg: tsubsetregister; const tosref: tsubsetreference);
+    var
+      tmpreg: tregister;
+    begin
+      tmpreg := getintregister(list,tosubsetsize);
+      a_load_subsetreg_reg(list,fromsubsetsize,tosubsetsize,fromsreg,tmpreg);
+      a_load_reg_subsetref(list,tosubsetsize,tosubsetsize,tmpreg,tosref);
+    end;
+
+  procedure thlcgobj.a_bit_test_reg_reg_reg(list: TAsmList; bitnumbersize, valuesize, destsize: tdef; bitnumber, value, destreg: tregister);
+    var
+      tmpvalue: tregister;
+    begin
+      tmpvalue:=getintregister(list,valuesize);
+
+      if (target_info.endian=endian_little) then
+        begin
+          { rotate value register "bitnumber" bits to the right }
+          a_op_reg_reg_reg(list,OP_SHR,valuesize,bitnumber,value,tmpvalue);
+          { extract the bit we want }
+          a_op_const_reg(list,OP_AND,valuesize,1,tmpvalue);
+        end
+      else
+        begin
+          { highest (leftmost) bit = bit 0 -> shl bitnumber results in wanted }
+          { bit in uppermost position, then move it to the lowest position    }
+          { "and" is not necessary since combination of shl/shr will clear    }
+          { all other bits                                                    }
+          a_op_reg_reg_reg(list,OP_SHL,valuesize,bitnumber,value,tmpvalue);
+          a_op_const_reg(list,OP_SHR,valuesize,valuesize.size*8-1,tmpvalue);
+        end;
+      a_load_reg_reg(list,valuesize,destsize,tmpvalue,destreg);
+    end;
+
+  procedure thlcgobj.a_bit_test_const_ref_reg(list: TAsmList; fromsize, destsize: tdef; bitnumber: aint; const ref: treference; destreg: tregister);
+    begin
+      a_load_subsetref_reg(list,u8inttype,destsize,get_bit_const_ref_sref(bitnumber,fromsize,ref),destreg);
+    end;
+
+  procedure thlcgobj.a_bit_test_const_reg_reg(list: TAsmList; setregsize, destsize: tdef; bitnumber: aint; setreg, destreg: tregister);
+    begin
+      a_load_subsetreg_reg(list,setregsize,destsize,get_bit_const_reg_sreg(setregsize,bitnumber,setreg),destreg);
+    end;
+
+  procedure thlcgobj.a_bit_test_const_subsetreg_reg(list: TAsmList; fromsubsetsize, destsize: tdef; bitnumber: aint; const setreg: tsubsetregister; destreg: tregister);
+    var
+      tmpsreg: tsubsetregister;
+    begin
+      { the first parameter is used to calculate the bit offset in }
+      { case of big endian, and therefore must be the size of the  }
+      { set and not of the whole subsetreg                         }
+      tmpsreg:=get_bit_const_reg_sreg(fromsubsetsize,bitnumber,setreg.subsetreg);
+      { now fix the size of the subsetreg }
+      tmpsreg.subsetregsize:=setreg.subsetregsize;
+      { correct offset of the set in the subsetreg }
+      inc(tmpsreg.startbit,setreg.startbit);
+      a_load_subsetreg_reg(list,fromsubsetsize,destsize,tmpsreg,destreg);
+    end;
+
+  procedure thlcgobj.a_bit_test_reg_ref_reg(list: TAsmList; bitnumbersize, refsize, destsize: tdef; bitnumber: tregister; const ref: treference; destreg: tregister);
+    begin
+      a_load_subsetref_reg(list,u8inttype,destsize,get_bit_reg_ref_sref(list,bitnumbersize,refsize,bitnumber,ref),destreg);
+    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;
+              LOC_SUBSETREG,LOC_CSUBSETREG:
+                begin
+                  tmpreg:=getintregister(list,locsize);
+                  a_load_subsetreg_reg(list,locsize,locsize,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);
+        LOC_SUBSETREG,LOC_CSUBSETREG:
+          a_bit_test_const_subsetreg_reg(list,locsize,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_reg(list: TAsmList; doset: boolean; bitnumbersize, destsize: tdef; bitnumber, dest: tregister);
+    var
+      tmpvalue: tregister;
+    begin
+      tmpvalue:=getintregister(list,destsize);
+
+      if (target_info.endian=endian_little) then
+        begin
+          a_load_const_reg(list,destsize,1,tmpvalue);
+          { rotate bit "bitnumber" bits to the left }
+          a_op_reg_reg(list,OP_SHL,destsize,bitnumber,tmpvalue);
+        end
+      else
+        begin
+          { highest (leftmost) bit = bit 0 -> "$80/$8000/$80000000/ ... }
+          { shr bitnumber" results in correct mask                      }
+          a_load_const_reg(list,destsize,1 shl (destsize.size*8-1),tmpvalue);
+          a_op_reg_reg(list,OP_SHR,destsize,bitnumber,tmpvalue);
+        end;
+      { set/clear the bit we want }
+      if doset then
+        a_op_reg_reg(list,OP_OR,destsize,tmpvalue,dest)
+      else
+        begin
+          a_op_reg_reg(list,OP_NOT,destsize,tmpvalue,tmpvalue);
+          a_op_reg_reg(list,OP_AND,destsize,tmpvalue,dest)
+        end;
+    end;
+
+  procedure thlcgobj.a_bit_set_const_ref(list: TAsmList; doset: boolean; destsize: tdef; bitnumber: aint; const ref: treference);
+    begin
+      a_load_const_subsetref(list,u8inttype,ord(doset),get_bit_const_ref_sref(bitnumber,destsize,ref));
+    end;
+
+  procedure thlcgobj.a_bit_set_const_reg(list: TAsmList; doset: boolean; destsize: tdef; bitnumber: aint; destreg: tregister);
+    begin
+      a_load_const_subsetreg(list,u8inttype,ord(doset),get_bit_const_reg_sreg(destsize,bitnumber,destreg));
+    end;
+
+  procedure thlcgobj.a_bit_set_const_subsetreg(list: TAsmList; doset: boolean; destsize: tdef; bitnumber: aint; const destreg: tsubsetregister);
+    var
+      tmpsreg: tsubsetregister;
+    begin
+      { the first parameter is used to calculate the bit offset in }
+      { case of big endian, and therefore must be the size of the  }
+      { set and not of the whole subsetreg                         }
+      tmpsreg:=get_bit_const_reg_sreg(destsize,bitnumber,destreg.subsetreg);
+      { now fix the size of the subsetreg }
+      tmpsreg.subsetregsize:=destreg.subsetregsize;
+      { correct offset of the set in the subsetreg }
+      inc(tmpsreg.startbit,destreg.startbit);
+      a_load_const_subsetreg(list,u8inttype,ord(doset),tmpsreg);
+    end;
+
+  procedure thlcgobj.a_bit_set_reg_ref(list: TAsmList; doset: boolean; fromsize, tosize: tdef; bitnumber: tregister; const ref: treference);
+    begin
+      a_load_const_subsetref(list,u8inttype,ord(doset),get_bit_reg_ref_sref(list,fromsize,tosize,bitnumber,ref));
+    end;
+
+  procedure thlcgobj.a_bit_set_reg_loc(list: TAsmList; doset: boolean; regsize, tosize: tdef; bitnumber: tregister; const loc: tlocation);
+    var
+      tmpreg: tregister;
+    begin
+      case loc.loc of
+        LOC_REFERENCE:
+          a_bit_set_reg_ref(list,doset,regsize,tosize,bitnumber,loc.reference);
+        LOC_CREGISTER:
+          a_bit_set_reg_reg(list,doset,regsize,tosize,bitnumber,loc.register);
+        { 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,tosize);
+            a_load_subsetreg_reg(list,tosize,tosize,loc.sreg,tmpreg);
+            a_bit_set_reg_reg(list,doset,regsize,tosize,bitnumber,tmpreg);
+            a_load_reg_subsetreg(list,tosize,tosize,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);
+        LOC_CSUBSETREG:
+          a_bit_set_const_subsetreg(list,doset,tosize,bitnumber,loc.sreg);
+        { LOC_SUBSETREF is not possible, because sets are not (yet) bitpacked }
+        else
+          internalerror(2010120409)
+      end;
+    end;
+
+
+  (*
+    Subsetrefs are used for (bit)packed arrays and (bit)packed records stored
+    in memory. They are like a regular reference, but contain an extra bit
+    offset (either constant -startbit- or variable -bitindexreg-, always OS_INT)
+    and a bit length (always constant).
+
+    Bit packed values are stored differently in memory depending on whether we
+    are on a big or a little endian system (compatible with at least GPC). The
+    size of the basic working unit is always the smallest power-of-2 byte size
+    which can contain the bit value (so 1..8 bits -> 1 byte, 9..16 bits -> 2
+    bytes, 17..32 bits -> 4 bytes etc).
+
+    On a big endian, 5-bit: values are stored like this:
+      11111222 22333334 44445555 56666677 77788888
+    The leftmost bit of each 5-bit value corresponds to the most significant
+    bit.
+
+    On little endian, it goes like this:
+      22211111 43333322 55554444 77666665 88888777
+    In this case, per byte the left-most bit is more significant than those on
+    the right, but the bits in the next byte are all more significant than
+    those in the previous byte (e.g., the 222 in the first byte are the low
+    three bits of that value, while the 22 in the second byte are the upper
+    two bits.
+
+    Big endian, 9 bit values:
+      11111111 12222222 22333333 33344444 ...
+
+    Little endian, 9 bit values:
+      11111111 22222221 33333322 44444333 ...
+    This is memory representation and the 16 bit values are byteswapped.
+    Similarly as in the previous case, the 2222222 string contains the lower
+    bits of value 2 and the 22 string contains the upper bits. Once loaded into
+    registers (two 16 bit registers in the current implementation, although a
+    single 32 bit register would be possible too, in particular if 32 bit
+    alignment can be guaranteed), this becomes:
+      22222221 11111111 44444333 33333322 ...
+      (l)ow  u     l     l    u     l   u
+
+    The startbit/bitindex in a subsetreference always refers to
+    a) on big endian: the most significant bit of the value
+       (bits counted from left to right, both memory an registers)
+    b) on little endian: the least significant bit when the value
+       is loaded in a register (bit counted from right to left)
+
+    Although a) results in more complex code for big endian systems, it's
+    needed for compatibility both with GPC and with e.g. bitpacked arrays in
+    Apple's universal interfaces which depend on these layout differences).
+
+    Note: when changing the loadsize calculated in get_subsetref_load_info,
+    make sure the appropriate alignment is guaranteed, at least in case of
+    {$defined cpurequiresproperalignment}.
+  *)
+
+  procedure thlcgobj.get_subsetref_load_info(const sref: tsubsetreference; out loadsize: torddef; out extra_load: boolean);
+    var
+      intloadsize: tcgint;
+    begin
+      intloadsize:=packedbitsloadsize(sref.bitlen);
+
+      if (intloadsize=0) then
+        internalerror(2006081310);
+
+      if (intloadsize>sizeof(aint)) then
+        intloadsize:=sizeof(aint);
+      loadsize:=tcgsize2orddef(int_cgsize(intloadsize));
+
+      if (sref.bitlen>sizeof(aint)*8) then
+        internalerror(2006081312);
+
+      extra_load:=
+        (sref.bitlen<>1) and
+        ((sref.bitindexreg<>NR_NO) or
+         (byte(sref.startbit+sref.bitlen)>byte(intloadsize*8)));
+    end;
+
+  procedure thlcgobj.a_load_subsetref_regs_noindex(list: TAsmList; subsetsize: tdef; loadbitsize: byte; const sref: tsubsetreference; valuereg, extra_value_reg: tregister);
+    var
+      restbits: byte;
+    begin
+      if (target_info.endian=endian_big) then
+        begin
+          { valuereg contains the upper bits, extra_value_reg the lower }
+          restbits:=(sref.bitlen-(loadbitsize-sref.startbit));
+          if is_signed(subsetsize) then
+            begin
+              { sign extend }
+              a_op_const_reg(list,OP_SHL,osuinttype,AIntBits-loadbitsize+sref.startbit,valuereg);
+              a_op_const_reg(list,OP_SAR,osuinttype,AIntBits-sref.bitlen,valuereg);
+            end
+          else
+            begin
+              a_op_const_reg(list,OP_SHL,osuinttype,restbits,valuereg);
+              { mask other bits }
+              if (sref.bitlen<>AIntBits) then
+                a_op_const_reg(list,OP_AND,osuinttype,tcgint((aword(1) shl sref.bitlen)-1),valuereg);
+            end;
+          a_op_const_reg(list,OP_SHR,osuinttype,loadbitsize-restbits,extra_value_reg)
+        end
+      else
+        begin
+          { valuereg contains the lower bits, extra_value_reg the upper }
+          a_op_const_reg(list,OP_SHR,osuinttype,sref.startbit,valuereg);
+          if is_signed(subsetsize) then
+            begin
+              a_op_const_reg(list,OP_SHL,osuinttype,AIntBits-sref.bitlen+loadbitsize-sref.startbit,extra_value_reg);
+              a_op_const_reg(list,OP_SAR,osuinttype,AIntBits-sref.bitlen,extra_value_reg);
+            end
+          else
+            begin
+              a_op_const_reg(list,OP_SHL,osuinttype,loadbitsize-sref.startbit,extra_value_reg);
+              { mask other bits }
+              if (sref.bitlen <> AIntBits) then
+                a_op_const_reg(list,OP_AND,osuinttype,tcgint((aword(1) shl sref.bitlen)-1),extra_value_reg);
+            end;
+        end;
+      { merge }
+      a_op_reg_reg(list,OP_OR,osuinttype,extra_value_reg,valuereg);
+    end;
+
+  procedure thlcgobj.a_load_subsetref_regs_index(list: TAsmList; subsetsize: tdef; loadbitsize: byte; const sref: tsubsetreference; valuereg: tregister);
+    var
+      hl: tasmlabel;
+      tmpref: treference;
+      extra_value_reg,
+      tmpreg: tregister;
+    begin
+      tmpreg:=getintregister(list,osuinttype);
+      tmpref:=sref.ref;
+      inc(tmpref.offset,loadbitsize div 8);
+      extra_value_reg:=getintregister(list,osuinttype);
+
+      if (target_info.endian=endian_big) then
+        begin
+          { since this is a dynamic index, it's possible that the value   }
+          { is entirely in valuereg.                                      }
+
+          { get the data in valuereg in the right place }
+          a_op_reg_reg(list,OP_SHL,osuinttype,sref.bitindexreg,valuereg);
+          if is_signed(subsetsize) then
+            begin
+              a_op_const_reg(list,OP_SHL,osuinttype,AIntBits-loadbitsize,valuereg);
+              a_op_const_reg(list,OP_SAR,osuinttype,AIntBits-sref.bitlen,valuereg)
+            end
+          else
+            begin
+              a_op_const_reg(list,OP_SHR,osuinttype,loadbitsize-sref.bitlen,valuereg);
+              if (loadbitsize<>AIntBits) then
+                { mask left over bits }
+                a_op_const_reg(list,OP_AND,osuinttype,tcgint((aword(1) shl sref.bitlen)-1),valuereg);
+            end;
+          tmpreg := getintregister(list,osuinttype);
+
+          { ensure we don't load anything past the end of the array }
+          current_asmdata.getjumplabel(hl);
+          a_cmp_const_reg_label(list,osuinttype,OC_BE,loadbitsize-sref.bitlen,sref.bitindexreg,hl);
+
+          { the bits in extra_value_reg (if any) start at the most significant bit =>         }
+          { extra_value_reg must be shr by (loadbitsize-sref.bitlen)+(loadsize-sref.bitindex) }
+          { => = -(sref.bitindex+(sref.bitlen-2*loadbitsize))                                 }
+          a_op_const_reg_reg(list,OP_ADD,osuinttype,sref.bitlen-2*loadbitsize,sref.bitindexreg,tmpreg);
+          a_op_reg_reg(list,OP_NEG,osuinttype,tmpreg,tmpreg);
+
+          { load next "loadbitsize" bits of the array }
+          a_load_ref_reg(list,tcgsize2orddef(int_cgsize(loadbitsize div 8)),osuinttype,tmpref,extra_value_reg);
+
+          a_op_reg_reg(list,OP_SHR,osuinttype,tmpreg,extra_value_reg);
+          { if there are no bits in extra_value_reg, then sref.bitindex was      }
+          { < loadsize-sref.bitlen, and therefore tmpreg will now be >= loadsize }
+          { => extra_value_reg is now 0                                          }
+          { merge }
+          a_op_reg_reg(list,OP_OR,osuinttype,extra_value_reg,valuereg);
+          { no need to mask, necessary masking happened earlier on }
+          a_label(list,hl);
+        end
+      else
+        begin
+          a_op_reg_reg(list,OP_SHR,osuinttype,sref.bitindexreg,valuereg);
+
+          { ensure we don't load anything past the end of the array }
+          current_asmdata.getjumplabel(hl);
+          a_cmp_const_reg_label(list,osuinttype,OC_BE,loadbitsize-sref.bitlen,sref.bitindexreg,hl);
+
+          { Y-x = -(Y-x) }
+          a_op_const_reg_reg(list,OP_SUB,osuinttype,loadbitsize,sref.bitindexreg,tmpreg);
+          a_op_reg_reg(list,OP_NEG,osuinttype,tmpreg,tmpreg);
+
+          { load next "loadbitsize" bits of the array }
+          a_load_ref_reg(list,tcgsize2orddef(int_cgsize(loadbitsize div 8)),osuinttype,tmpref,extra_value_reg);
+
+          { tmpreg is in the range 1..<cpu_bitsize>-1 -> always ok }
+          a_op_reg_reg(list,OP_SHL,osuinttype,tmpreg,extra_value_reg);
+          { merge }
+          a_op_reg_reg(list,OP_OR,osuinttype,extra_value_reg,valuereg);
+          a_label(list,hl);
+          { sign extend or mask other bits }
+          if is_signed(subsetsize) then
+            begin
+              a_op_const_reg(list,OP_SHL,osuinttype,AIntBits-sref.bitlen,valuereg);
+              a_op_const_reg(list,OP_SAR,osuinttype,AIntBits-sref.bitlen,valuereg);
+            end
+          else
+            a_op_const_reg(list,OP_AND,osuinttype,tcgint((aword(1) shl sref.bitlen)-1),valuereg);
+        end;
+    end;
+
+  procedure thlcgobj.a_load_regconst_subsetref_intern(list: TAsmList; fromsize, subsetsize: tdef; fromreg: tregister; const sref: tsubsetreference; slopt: tsubsetloadopt);
+    var
+      hl: tasmlabel;
+      tmpreg, tmpindexreg, valuereg, extra_value_reg, maskreg: tregister;
+      tosreg, fromsreg: tsubsetregister;
+      tmpref: treference;
+      bitmask: aword;
+      loadsize: torddef;
+      loadbitsize: byte;
+      extra_load: boolean;
+    begin
+      { the register must be able to contain the requested value }
+      if (fromsize.size*8<sref.bitlen) then
+        internalerror(2006081613);
+
+      get_subsetref_load_info(sref,loadsize,extra_load);
+      loadbitsize:=loadsize.size*8;
+
+      { load the (first part) of the bit sequence }
+      valuereg:=getintregister(list,osuinttype);
+      a_load_ref_reg(list,loadsize,osuinttype,sref.ref,valuereg);
+
+      { constant offset of bit sequence? }
+      if not extra_load then
+        begin
+          if (sref.bitindexreg=NR_NO) then
+            begin
+              { use subsetreg routine, it may have been overridden with an optimized version }
+              tosreg.subsetreg:=valuereg;
+              tosreg.subsetregsize:=def_cgsize(osuinttype);
+              { subsetregs always count bits from right to left }
+              if (target_info.endian=endian_big) then
+                tosreg.startbit:=loadbitsize-(sref.startbit+sref.bitlen)
+              else
+                tosreg.startbit:=sref.startbit;
+              tosreg.bitlen:=sref.bitlen;
+              a_load_regconst_subsetreg_intern(list,fromsize,subsetsize,fromreg,tosreg,slopt);
+            end
+          else
+            begin
+              if (sref.startbit<>0) then
+                internalerror(2006081710);
+              { should be handled by normal code and will give wrong result }
+              { on x86 for the '1 shl bitlen' below                         }
+              if (sref.bitlen=AIntBits) then
+                internalerror(2006081711);
+
+              { zero the bits we have to insert }
+              if (slopt<>SL_SETMAX) then
+                begin
+                  maskreg:=getintregister(list,osuinttype);
+                  if (target_info.endian = endian_big) then
+                    begin
+                      a_load_const_reg(list,osuinttype,tcgint((aword(1) shl sref.bitlen)-1) shl (loadbitsize-sref.bitlen),maskreg);
+                      a_op_reg_reg(list,OP_SHR,osuinttype,sref.bitindexreg,maskreg);
+                    end
+                  else
+                    begin
+                      a_load_const_reg(list,osuinttype,tcgint((aword(1) shl sref.bitlen)-1),maskreg);
+                      a_op_reg_reg(list,OP_SHL,osuinttype,sref.bitindexreg,maskreg);
+                    end;
+                  a_op_reg_reg(list,OP_NOT,osuinttype,maskreg,maskreg);
+                  a_op_reg_reg(list,OP_AND,osuinttype,maskreg,valuereg);
+                end;
+
+              { insert the value }
+              if (slopt<>SL_SETZERO) then
+                begin
+                  tmpreg:=getintregister(list,osuinttype);
+                  if (slopt<>SL_SETMAX) then
+                    a_load_reg_reg(list,fromsize,osuinttype,fromreg,tmpreg)
+                  else if (sref.bitlen<>AIntBits) then
+                    a_load_const_reg(list,osuinttype,tcgint((aword(1) shl sref.bitlen)-1), tmpreg)
+                  else
+                    a_load_const_reg(list,osuinttype,-1,tmpreg);
+                  if (target_info.endian=endian_big) then
+                    begin
+                      a_op_const_reg(list,OP_SHL,osuinttype,loadbitsize-sref.bitlen,tmpreg);
+                      if not(slopt in [SL_REGNOSRCMASK,SL_SETMAX]) then
+                        begin
+                          if (loadbitsize<>AIntBits) then
+                            bitmask:=(((aword(1) shl loadbitsize)-1) xor ((aword(1) shl (loadbitsize-sref.bitlen))-1))
+                          else
+                            bitmask:=(high(aword) xor ((aword(1) shl (loadbitsize-sref.bitlen))-1));
+                          a_op_const_reg(list,OP_AND,osuinttype,bitmask,tmpreg);
+                        end;
+                      a_op_reg_reg(list,OP_SHR,osuinttype,sref.bitindexreg,tmpreg);
+                    end
+                  else
+                    begin
+                      if not(slopt in [SL_REGNOSRCMASK,SL_SETMAX]) then
+                        a_op_const_reg(list,OP_AND,osuinttype,tcgint((aword(1) shl sref.bitlen)-1),tmpreg);
+                      a_op_reg_reg(list,OP_SHL,osuinttype,sref.bitindexreg,tmpreg);
+                    end;
+                  a_op_reg_reg(list,OP_OR,osuinttype,tmpreg,valuereg);
+                end;
+            end;
+          { store back to memory }
+          tmpreg:=getintregister(list,loadsize);
+          a_load_reg_reg(list,osuinttype,loadsize,valuereg,tmpreg);
+          a_load_reg_ref(list,loadsize,loadsize,tmpreg,sref.ref);
+          exit;
+        end
+      else
+        begin
+          { load next value }
+          extra_value_reg:=getintregister(list,osuinttype);
+          tmpref:=sref.ref;
+          inc(tmpref.offset,loadbitsize div 8);
+
+          { should maybe be taken out too, can be done more efficiently }
+          { on e.g. i386 with shld/shrd                                 }
+          if (sref.bitindexreg = NR_NO) then
+            begin
+              a_load_ref_reg(list,loadsize,osuinttype,tmpref,extra_value_reg);
+
+              fromsreg.subsetreg:=fromreg;
+              fromsreg.subsetregsize:=def_cgsize(fromsize);
+              tosreg.subsetreg:=valuereg;
+              tosreg.subsetregsize:=def_cgsize(osuinttype);
+
+              { transfer first part }
+              fromsreg.bitlen:=loadbitsize-sref.startbit;
+              tosreg.bitlen:=fromsreg.bitlen;
+              if (target_info.endian=endian_big) then
+                begin
+                  { valuereg must contain the upper bits of the value at bits [0..loadbitsize-startbit] }
+
+                  { upper bits of the value ... }
+                  fromsreg.startbit:=sref.bitlen-(loadbitsize-sref.startbit);
+                  { ... to bit 0 }
+                  tosreg.startbit:=0
+                end
+              else
+                begin
+                  { valuereg must contain the lower bits of the value at bits [startbit..loadbitsize] }
+
+                  { lower bits of the value ... }
+                  fromsreg.startbit:=0;
+                  { ... to startbit }
+                  tosreg.startbit:=sref.startbit;
+                end;
+              case slopt of
+                SL_SETZERO,
+                SL_SETMAX:
+                  a_load_regconst_subsetreg_intern(list,fromsize,subsetsize,fromreg,tosreg,slopt);
+                else
+                  a_load_subsetreg_subsetreg(list,subsetsize,subsetsize,fromsreg,tosreg);
+              end;
+{$ifndef cpuhighleveltarget}
+              valuereg:=cg.makeregsize(list,valuereg,def_cgsize(loadsize));
+              a_load_reg_ref(list,loadsize,loadsize,valuereg,sref.ref);
+{$else}
+              tmpreg:=getintregister(list,loadsize);
+              a_load_reg_reg(list,osuinttype,loadsize,valuereg,tmpreg);
+              a_load_reg_ref(list,loadsize,loadsize,tmpreg,sref.ref);
+{$endif}
+
+              { transfer second part }
+              if (target_info.endian = endian_big) then
+                begin
+                  { extra_value_reg must contain the lower bits of the value at bits  }
+                  { [(loadbitsize-(bitlen-(loadbitsize-startbit)))..loadbitsize]  }
+                  { (loadbitsize-(bitlen-(loadbitsize-startbit))) = 2*loadbitsize }
+                  { - bitlen - startbit }
+
+                  fromsreg.startbit:=0;
+                  tosreg.startbit:=2*loadbitsize-sref.bitlen-sref.startbit
+                end
+              else
+                begin
+                  { extra_value_reg must contain the upper bits of the value at bits [0..bitlen-(loadbitsize-startbit)] }
+
+                  fromsreg.startbit:=fromsreg.bitlen;
+                  tosreg.startbit:=0;
+                end;
+              tosreg.subsetreg:=extra_value_reg;
+              fromsreg.bitlen:=sref.bitlen-fromsreg.bitlen;
+              tosreg.bitlen:=fromsreg.bitlen;
+
+              case slopt of
+                SL_SETZERO,
+                SL_SETMAX:
+                  a_load_regconst_subsetreg_intern(list,fromsize,subsetsize,fromreg,tosreg,slopt);
+                else
+                  a_load_subsetreg_subsetreg(list,subsetsize,subsetsize,fromsreg,tosreg);
+              end;
+              tmpreg:=getintregister(list,loadsize);
+              a_load_reg_reg(list,osuinttype,loadsize,extra_value_reg,tmpreg);
+              a_load_reg_ref(list,loadsize,loadsize,tmpreg,tmpref);
+              exit;
+            end
+          else
+            begin
+              if (sref.startbit <> 0) then
+                internalerror(2006081812);
+              { should be handled by normal code and will give wrong result }
+              { on x86 for the '1 shl bitlen' below                         }
+              if (sref.bitlen = AIntBits) then
+                internalerror(2006081713);
+
+              { generate mask to zero the bits we have to insert }
+              if (slopt <> SL_SETMAX) then
+                begin
+                  maskreg := getintregister(list,osuinttype);
+                  if (target_info.endian = endian_big) then
+                    begin
+                      a_load_const_reg(list,osuinttype,tcgint(((aword(1) shl sref.bitlen)-1) shl (loadbitsize-sref.bitlen)),maskreg);
+                      a_op_reg_reg(list,OP_SHR,osuinttype,sref.bitindexreg,maskreg);
+                    end
+                  else
+                    begin
+                      a_load_const_reg(list,osuinttype,tcgint((aword(1) shl sref.bitlen)-1),maskreg);
+                      a_op_reg_reg(list,OP_SHL,osuinttype,sref.bitindexreg,maskreg);
+                    end;
+
+                  a_op_reg_reg(list,OP_NOT,osuinttype,maskreg,maskreg);
+                  a_op_reg_reg(list,OP_AND,osuinttype,maskreg,valuereg);
+                end;
+
+              { insert the value }
+              if (slopt <> SL_SETZERO) then
+                begin
+                  tmpreg := getintregister(list,osuinttype);
+                  if (slopt <> SL_SETMAX) then
+                    a_load_reg_reg(list,fromsize,osuinttype,fromreg,tmpreg)
+                  else if (sref.bitlen <> AIntBits) then
+                    a_load_const_reg(list,osuinttype,tcgint((aword(1) shl sref.bitlen) - 1), tmpreg)
+                  else
+                    a_load_const_reg(list,osuinttype,-1,tmpreg);
+                  if (target_info.endian = endian_big) then
+                    begin
+                      a_op_const_reg(list,OP_SHL,osuinttype,loadbitsize-sref.bitlen,tmpreg);
+                      if not(slopt in [SL_REGNOSRCMASK,SL_SETMAX]) then
+                        { mask left over bits }
+                        a_op_const_reg(list,OP_AND,osuinttype,tcgint(((aword(1) shl sref.bitlen)-1) shl (loadbitsize-sref.bitlen)),tmpreg);
+                      a_op_reg_reg(list,OP_SHR,osuinttype,sref.bitindexreg,tmpreg);
+                    end
+                  else
+                    begin
+                      if not(slopt in [SL_REGNOSRCMASK,SL_SETMAX]) then
+                        { mask left over bits }
+                        a_op_const_reg(list,OP_AND,osuinttype,tcgint((aword(1) shl sref.bitlen)-1),tmpreg);
+                      a_op_reg_reg(list,OP_SHL,osuinttype,sref.bitindexreg,tmpreg);
+                    end;
+                  a_op_reg_reg(list,OP_OR,osuinttype,tmpreg,valuereg);
+                end;
+              tmpreg:=getintregister(list,loadsize);
+              a_load_reg_reg(list,osuinttype,loadsize,valuereg,tmpreg);
+              a_load_reg_ref(list,loadsize,loadsize,tmpreg,sref.ref);
+
+              { make sure we do not read/write past the end of the array }
+              current_asmdata.getjumplabel(hl);
+              a_cmp_const_reg_label(list,osuinttype,OC_BE,loadbitsize-sref.bitlen,sref.bitindexreg,hl);
+
+              a_load_ref_reg(list,loadsize,osuinttype,tmpref,extra_value_reg);
+              tmpindexreg:=getintregister(list,osuinttype);
+
+              { load current array value }
+              if (slopt<>SL_SETZERO) then
+                begin
+                  tmpreg:=getintregister(list,osuinttype);
+                  if (slopt<>SL_SETMAX) then
+                     a_load_reg_reg(list,fromsize,osuinttype,fromreg,tmpreg)
+                  else if (sref.bitlen<>AIntBits) then
+                    a_load_const_reg(list,osuinttype,tcgint((aword(1) shl sref.bitlen) - 1), tmpreg)
+                  else
+                    a_load_const_reg(list,osuinttype,-1,tmpreg);
+                end;
+
+              { generate mask to zero the bits we have to insert }
+              if (slopt<>SL_SETMAX) then
+                begin
+                  maskreg:=getintregister(list,osuinttype);
+                  if (target_info.endian=endian_big) then
+                    begin
+                      a_op_const_reg_reg(list,OP_ADD,osuinttype,sref.bitlen-2*loadbitsize,sref.bitindexreg,tmpindexreg);
+                      a_op_reg_reg(list,OP_NEG,osuinttype,tmpindexreg,tmpindexreg);
+                      a_load_const_reg(list,osuinttype,tcgint((aword(1) shl sref.bitlen)-1),maskreg);
+                      a_op_reg_reg(list,OP_SHL,osuinttype,tmpindexreg,maskreg);
+                    end
+                  else
+                    begin
+                      { Y-x = -(x-Y) }
+                      a_op_const_reg_reg(list,OP_SUB,osuinttype,loadbitsize,sref.bitindexreg,tmpindexreg);
+                      a_op_reg_reg(list,OP_NEG,osuinttype,tmpindexreg,tmpindexreg);
+                      a_load_const_reg(list,osuinttype,tcgint((aword(1) shl sref.bitlen)-1),maskreg);
+                      a_op_reg_reg(list,OP_SHR,osuinttype,tmpindexreg,maskreg);
+                    end;
+
+                  a_op_reg_reg(list,OP_NOT,osuinttype,maskreg,maskreg);
+                  a_op_reg_reg(list,OP_AND,osuinttype,maskreg,extra_value_reg);
+                end;
+
+              if (slopt<>SL_SETZERO) then
+                begin
+                  if (target_info.endian=endian_big) then
+                    a_op_reg_reg(list,OP_SHL,osuinttype,tmpindexreg,tmpreg)
+                  else
+                    begin
+                      if not(slopt in [SL_REGNOSRCMASK,SL_SETMAX]) then
+                        a_op_const_reg(list,OP_AND,osuinttype,tcgint((aword(1) shl sref.bitlen)-1),tmpreg);
+                      a_op_reg_reg(list,OP_SHR,osuinttype,tmpindexreg,tmpreg);
+                    end;
+                  a_op_reg_reg(list,OP_OR,osuinttype,tmpreg,extra_value_reg);
+                end;
+{$ifndef cpuhighleveltarget}
+              extra_value_reg:=cg.makeregsize(list,extra_value_reg,def_cgsize(loadsize));
+              a_load_reg_ref(list,loadsize,loadsize,extra_value_reg,tmpref);
+{$else}
+              tmpreg:=getintregister(list,loadsize);
+              a_load_reg_reg(list,osuinttype,loadsize,extra_value_reg,tmpreg);
+              a_load_reg_ref(list,loadsize,loadsize,tmpreg,tmpref);
+{$endif}
+
+              a_label(list,hl);
+            end;
+        end;
+    end;
+
+  procedure thlcgobj.a_load_regconst_subsetreg_intern(list: TAsmList; fromsize, subsetsize: tdef; fromreg: tregister; const sreg: tsubsetregister; slopt: tsubsetloadopt);
+    var
+      bitmask: aword;
+      tmpreg: tregister;
+      subsetregdef: torddef;
+      stopbit: byte;
+    begin
+      subsetregdef:=tcgsize2orddef(sreg.subsetregsize);
+      stopbit:=sreg.startbit+sreg.bitlen;
+      // on x86(64), 1 shl 32(64) = 1 instead of 0
+      if (stopbit<>AIntBits) then
+        bitmask:=not(((aword(1) shl stopbit)-1) xor ((aword(1) shl sreg.startbit)-1))
+      else
+        bitmask:=not(high(aword) xor ((aword(1) shl sreg.startbit)-1));
+      if not(slopt in [SL_SETZERO,SL_SETMAX]) then
+        begin
+          tmpreg:=getintregister(list,subsetregdef);
+          a_load_reg_reg(list,fromsize,subsetregdef,fromreg,tmpreg);
+          a_op_const_reg(list,OP_SHL,subsetregdef,sreg.startbit,tmpreg);
+           if (slopt<>SL_REGNOSRCMASK) then
+            a_op_const_reg(list,OP_AND,subsetregdef,tcgint(not(bitmask)),tmpreg);
+        end;
+      if (slopt<>SL_SETMAX) then
+        a_op_const_reg(list,OP_AND,subsetregdef,tcgint(bitmask),sreg.subsetreg);
+
+      case slopt of
+        SL_SETZERO : ;
+        SL_SETMAX :
+          if (sreg.bitlen<>AIntBits) then
+            a_op_const_reg(list,OP_OR,subsetregdef,
+              tcgint(((aword(1) shl sreg.bitlen)-1) shl sreg.startbit),
+              sreg.subsetreg)
+          else
+            a_load_const_reg(list,subsetregdef,-1,sreg.subsetreg);
+        else
+          a_op_reg_reg(list,OP_OR,subsetregdef,tmpreg,sreg.subsetreg);
+       end;
+    end;
+
+  {$pop}
+
+  function thlcgobj.get_bit_const_ref_sref(bitnumber: tcgint; refdef: tdef; const ref: treference): tsubsetreference;
+    begin
+      result.ref:=ref;
+      inc(result.ref.offset,bitnumber div 8);
+      result.bitindexreg:=NR_NO;
+      result.startbit:=bitnumber mod 8;
+      result.bitlen:=1;
+    end;
+
+  function thlcgobj.get_bit_const_reg_sreg(setregsize: tdef; bitnumber: tcgint; setreg: tregister): tsubsetregister;
+    begin
+      result.subsetreg:=setreg;
+      result.subsetregsize:=def_cgsize(setregsize);
+      { subsetregs always count from the least significant to the most significant bit }
+      if (target_info.endian=endian_big) then
+        result.startbit:=(setregsize.size*8)-bitnumber-1
+      else
+        result.startbit:=bitnumber;
+      result.bitlen:=1;
+    end;
+
+  function thlcgobj.get_bit_reg_ref_sref(list: TAsmList; bitnumbersize, refsize: tdef; bitnumber: tregister; const ref: treference): tsubsetreference;
+    var
+      tmpreg: tregister;
+    begin
+      result.ref:=ref;
+      result.startbit:=0;
+      result.bitlen:=1;
+
+      tmpreg:=getintregister(list,ptruinttype);
+      a_load_reg_reg(list,bitnumbersize,ptruinttype,bitnumber,tmpreg);
+      a_op_const_reg(list,OP_SHR,ptruinttype,3,tmpreg);
+
+      { don't assign to ref.base, that one is for pointers and this is an index
+        (important for platforms like LLVM) }
+      if (result.ref.index=NR_NO) then
+        result.ref.index:=tmpreg
+      else
+        begin
+          a_op_reg_reg(list,OP_ADD,ptruinttype,result.ref.index,tmpreg);
+          result.ref.index:=tmpreg;
+        end;
+      tmpreg:=getintregister(list,ptruinttype);
+      a_load_reg_reg(list,bitnumbersize,ptruinttype,bitnumber,tmpreg);
+      a_op_const_reg(list,OP_AND,ptruinttype,7,tmpreg);
+      result.bitindexreg:=tmpreg;
+    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,subsetsize,size,sreg,tmpreg);
+      a_op_const_reg(list,op,size,a,tmpreg);
+      a_load_reg_subsetreg(list,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,subsetsize,size,sref,tmpreg);
+      a_op_const_reg(list,op,size,a,tmpreg);
+      a_load_reg_subsetref(list,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);
+        LOC_SUBSETREG, LOC_CSUBSETREG:
+          a_op_const_subsetreg(list,op,size,size,a,loc.sreg);
+        LOC_SUBSETREF, LOC_CSUBSETREF:
+          a_op_const_subsetref(list,op,size,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, destsubsetsize: tdef; reg: TRegister; const sreg: tsubsetregister);
+    var
+      tmpreg: tregister;
+    begin
+      tmpreg:=getintregister(list,opsize);
+      a_load_subsetreg_reg(list,destsubsetsize,opsize,sreg,tmpreg);
+      a_op_reg_reg(list,op,opsize,reg,tmpreg);
+      a_load_reg_subsetreg(list,opsize,destsubsetsize,tmpreg,sreg);
+    end;
+
+  procedure thlcgobj.a_op_reg_subsetref(list: TAsmList; Op: TOpCG; opsize, destsubsetsize: tdef; reg: TRegister; const sref: tsubsetreference);
+    var
+      tmpreg: tregister;
+    begin
+      tmpreg:=getintregister(list,opsize);
+      a_load_subsetref_reg(list,destsubsetsize,opsize,sref,tmpreg);
+      a_op_reg_reg(list,op,opsize,reg,tmpreg);
+      a_load_reg_subsetref(list,opsize,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);
+        LOC_SUBSETREG, LOC_CSUBSETREG:
+          a_op_reg_subsetreg(list,op,size,size,reg,loc.sreg);
+        LOC_SUBSETREF, LOC_CSUBSETREF:
+          a_op_reg_subsetref(list,op,size,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;
+        LOC_SUBSETREG, LOC_CSUBSETREG:
+          begin
+            tmpreg:=getintregister(list,size);
+            a_load_subsetreg_reg(list,size,size,loc.sreg,tmpreg);
+            a_op_ref_reg(list,op,size,ref,tmpreg);
+            a_load_reg_subsetreg(list,size,size,tmpreg,loc.sreg);
+          end;
+        LOC_SUBSETREF, LOC_CSUBSETREF:
+          begin
+            tmpreg:=getintregister(list,size);
+            a_load_subsetref_reg(list,size,size,loc.sref,tmpreg);
+            a_op_ref_reg(list,op,size,ref,tmpreg);
+            a_load_reg_subsetref(list,size,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);
+    var
+      tmpreg: tregister;
+    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);
+        LOC_SUBSETREG, LOC_CSUBSETREG:
+          begin
+            tmpreg:=getintregister(list,size);
+            a_load_subsetreg_reg(list,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,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; 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,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; 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,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);
+        LOC_SUBSETREG,
+        LOC_CSUBSETREG:
+          a_cmp_subsetreg_reg_label(list,size,size,cmp_op,loc.sreg,reg,l);
+        LOC_SUBSETREF,
+        LOC_CSUBSETREF:
+          a_cmp_subsetref_reg_label(list,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;
+        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,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,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_copyshortstring(list: TAsmList; const source, dest: treference; strdef: tstringdef);
+    var
+      cgpara1,cgpara2,cgpara3 : TCGPara;
+    begin
+      cgpara1.init;
+      cgpara2.init;
+      cgpara3.init;
+      paramanager.getintparaloc(pocall_default,1,voidpointertype,cgpara1);
+      paramanager.getintparaloc(pocall_default,2,voidpointertype,cgpara2);
+      paramanager.getintparaloc(pocall_default,3,s32inttype,cgpara3);
+      a_loadaddr_ref_cgpara(list,strdef,dest,cgpara3);
+      a_loadaddr_ref_cgpara(list,strdef,source,cgpara2);
+      a_load_const_cgpara(list,s32inttype,strdef.len,cgpara1);
+      paramanager.freecgpara(list,cgpara3);
+      paramanager.freecgpara(list,cgpara2);
+      paramanager.freecgpara(list,cgpara1);
+      g_call_system_proc(list,'fpc_shortstr_assign');
+      cgpara3.done;
+      cgpara2.done;
+      cgpara1.done;
+    end;
+
+  procedure thlcgobj.g_copyvariant(list: TAsmList; const source, dest: treference; vardef: tvariantdef);
+    var
+      cgpara1,cgpara2 : TCGPara;
+      pvardata : tdef;
+    begin
+      cgpara1.init;
+      cgpara2.init;
+      pvardata:=getpointerdef(search_system_type('TVARDATA').typedef);
+      paramanager.getintparaloc(pocall_default,1,pvardata,cgpara1);
+      paramanager.getintparaloc(pocall_default,2,pvardata,cgpara2);
+      a_loadaddr_ref_cgpara(list,vardef,dest,cgpara2);
+      a_loadaddr_ref_cgpara(list,vardef,source,cgpara1);
+      paramanager.freecgpara(list,cgpara2);
+      paramanager.freecgpara(list,cgpara1);
+      g_call_system_proc(list,'fpc_variant_copy_overwrite');
+      cgpara2.done;
+      cgpara1.done;
+    end;
+
+  procedure thlcgobj.g_incrrefcount(list: TAsmList; t: tdef; const ref: treference);
+    var
+      href : treference;
+      incrfunc : string;
+      cgpara1,cgpara2 : TCGPara;
+    begin
+       cgpara1.init;
+       cgpara2.init;
+       paramanager.getintparaloc(pocall_default,1,voidpointertype,cgpara1);
+       paramanager.getintparaloc(pocall_default,2,voidpointertype,cgpara2);
+       if is_interfacecom_or_dispinterface(t) then
+         incrfunc:='fpc_intf_incr_ref'
+       else if is_ansistring(t) then
+         incrfunc:='fpc_ansistr_incr_ref'
+       else if is_widestring(t) then
+         incrfunc:='fpc_widestr_incr_ref'
+       else if is_unicodestring(t) then
+         incrfunc:='fpc_unicodestr_incr_ref'
+       else if is_dynamic_array(t) then
+         incrfunc:='fpc_dynarray_incr_ref'
+       else
+        incrfunc:='';
+       { call the special incr function or the generic addref }
+       if incrfunc<>'' then
+        begin
+          { widestrings aren't ref. counted on all platforms so we need the address
+            to create a real copy }
+          if is_widestring(t) then
+            a_loadaddr_ref_cgpara(list,t,ref,cgpara1)
+          else
+            { these functions get the pointer by value }
+            a_load_ref_cgpara(list,t,ref,cgpara1);
+          paramanager.freecgpara(list,cgpara1);
+          g_call_system_proc(list,incrfunc);
+        end
+       else
+        begin
+          if is_open_array(t) then
+            InternalError(201103054);
+          reference_reset_symbol(href,RTTIWriter.get_rtti_label(t,initrtti),0,sizeof(pint));
+          a_loadaddr_ref_cgpara(list,voidpointertype,href,cgpara2);
+          a_loadaddr_ref_cgpara(list,t,ref,cgpara1);
+          paramanager.freecgpara(list,cgpara1);
+          paramanager.freecgpara(list,cgpara2);
+          g_call_system_proc(list,'fpc_addref');
+        end;
+       cgpara2.done;
+       cgpara1.done;
+    end;
+
+  procedure thlcgobj.g_initialize(list: TAsmList; t: tdef; const ref: treference);
+    var
+       href : treference;
+       cgpara1,cgpara2 : TCGPara;
+       pvardata : tdef;
+    begin
+      cgpara1.init;
+      cgpara2.init;
+       if is_ansistring(t) or
+          is_widestring(t) or
+          is_unicodestring(t) or
+          is_interfacecom_or_dispinterface(t) or
+          is_dynamic_array(t) then
+         a_load_const_ref(list,t,0,ref)
+       else if t.typ=variantdef then
+         begin
+           pvardata:=getpointerdef(search_system_type('TVARDATA').typedef);
+           paramanager.getintparaloc(pocall_default,1,pvardata,cgpara1);
+           a_loadaddr_ref_cgpara(list,t,ref,cgpara1);
+           paramanager.freecgpara(list,cgpara1);
+           g_call_system_proc(list,'fpc_variant_init');
+         end
+       else
+         begin
+            if is_open_array(t) then
+              InternalError(201103052);
+            paramanager.getintparaloc(pocall_default,1,voidpointertype,cgpara1);
+            paramanager.getintparaloc(pocall_default,2,voidpointertype,cgpara2);
+            reference_reset_symbol(href,RTTIWriter.get_rtti_label(t,initrtti),0,sizeof(pint));
+            a_loadaddr_ref_cgpara(list,voidpointertype,href,cgpara2);
+            a_loadaddr_ref_cgpara(list,t,ref,cgpara1);
+            paramanager.freecgpara(list,cgpara1);
+            paramanager.freecgpara(list,cgpara2);
+            g_call_system_proc(list,'fpc_initialize');
+         end;
+      cgpara1.done;
+      cgpara2.done;
+    end;
+
+  procedure thlcgobj.g_finalize(list: TAsmList; t: tdef; const ref: treference);
+    var
+       href : treference;
+       cgpara1,cgpara2 : TCGPara;
+       paratype : tdef;
+       decrfunc : string;
+       dynarr: boolean;
+    begin
+      paratype:=getpointerdef(voidpointertype);
+      if is_interfacecom_or_dispinterface(t) then
+        decrfunc:='fpc_intf_decr_ref'
+      else if is_ansistring(t) then
+        decrfunc:='fpc_ansistr_decr_ref'
+      else if is_widestring(t) then
+        decrfunc:='fpc_widestr_decr_ref'
+      else if is_unicodestring(t) then
+        decrfunc:='fpc_unicodestr_decr_ref'
+      else if t.typ=variantdef then
+        begin
+          paratype:=getpointerdef(search_system_type('TVARDATA').typedef);
+          decrfunc:='fpc_variant_clear'
+        end
+      else
+        begin
+          cgpara1.init;
+          cgpara2.init;
+          if is_open_array(t) then
+            InternalError(201103051);
+          dynarr:=is_dynamic_array(t);
+          { fpc_finalize takes a pointer value parameter, fpc_dynarray_clear a
+            pointer var parameter }
+          if not dynarr then
+            paratype:=voidpointertype;
+          paramanager.getintparaloc(pocall_default,1,paratype,cgpara1);
+          paramanager.getintparaloc(pocall_default,2,voidpointertype,cgpara2);
+          reference_reset_symbol(href,RTTIWriter.get_rtti_label(t,initrtti),0,sizeof(pint));
+          a_loadaddr_ref_cgpara(list,voidpointertype,href,cgpara2);
+          a_loadaddr_ref_cgpara(list,t,ref,cgpara1);
+          paramanager.freecgpara(list,cgpara1);
+          paramanager.freecgpara(list,cgpara2);
+          if dynarr then
+            g_call_system_proc(list,'fpc_dynarray_clear')
+          else
+            g_call_system_proc(list,'fpc_finalize');
+          cgpara1.done;
+          cgpara2.done;
+          exit;
+        end;
+      cgpara1.init;
+      paramanager.getintparaloc(pocall_default,1,paratype,cgpara1);
+      a_loadaddr_ref_cgpara(list,t,ref,cgpara1);
+      paramanager.freecgpara(list,cgpara1);
+      g_call_system_proc(list,decrfunc);
+      cgpara1.done;
+    end;
+
+  procedure thlcgobj.g_array_rtti_helper(list: TAsmList; t: tdef; const ref: treference; const highloc: tlocation; const name: string);
+    var
+      cgpara1,cgpara2,cgpara3: TCGPara;
+      href: TReference;
+      hreg, lenreg: TRegister;
+    begin
+      cgpara1.init;
+      cgpara2.init;
+      cgpara3.init;
+      paramanager.getintparaloc(pocall_default,1,voidpointertype,cgpara1);
+      paramanager.getintparaloc(pocall_default,2,voidpointertype,cgpara2);
+      paramanager.getintparaloc(pocall_default,3,ptrsinttype,cgpara3);
+
+      reference_reset_symbol(href,RTTIWriter.get_rtti_label(t,initrtti),0,sizeof(pint));
+      if highloc.loc=LOC_CONSTANT then
+        a_load_const_cgpara(list,ptrsinttype,highloc.value+1,cgpara3)
+      else
+        begin
+          if highloc.loc in [LOC_REGISTER,LOC_CREGISTER] then
+            hreg:=highloc.register
+          else
+            begin
+              hreg:=getintregister(list,ptrsinttype);
+              a_load_loc_reg(list,ptrsinttype,ptrsinttype,highloc,hreg);
+            end;
+          { increment, converts high(x) to length(x) }
+          lenreg:=getintregister(list,ptrsinttype);
+          a_op_const_reg_reg(list,OP_ADD,ptrsinttype,1,hreg,lenreg);
+          a_load_reg_cgpara(list,ptrsinttype,lenreg,cgpara3);
+        end;
+
+      a_loadaddr_ref_cgpara(list,voidpointertype,href,cgpara2);
+      a_loadaddr_ref_cgpara(list,t,ref,cgpara1);
+      paramanager.freecgpara(list,cgpara1);
+      paramanager.freecgpara(list,cgpara2);
+      paramanager.freecgpara(list,cgpara3);
+      g_call_system_proc(list,name);
+
+      cgpara3.done;
+      cgpara2.done;
+      cgpara1.done;
+    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;
+{$if not defined(cpuhighleveltarget) and not defined(cpu64bitalu)}
+        { handle 64bit rangechecks separate for 32bit processors }
+        if is_64bit(fromdef) or is_64bit(todef) then
+          begin
+             cg64.g_rangecheck64(list,l,fromdef,todef);
+             exit;
+          end;
+{$endif ndef cpuhighleveltarget and ndef cpu64bitalu}
+      { 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 defined(cpuhighleveltarget) or defined(cpu64bitalu)}
+      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;
+{$endif cpuhighleveltarget or cpu64bitalu}
+      { 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,
+        LOC_SUBSETREG,
+        LOC_CSUBSETREG,
+        LOC_SUBSETREF,
+        LOC_CSUBSETREF:
+          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_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,
+                   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;
+
+
+  function use_ent : boolean;
+    begin
+	  use_ent := (target_info.system in [system_mipsel_linux,system_mipseb_linux])
+	             or (target_info.cpu=cpu_alpha);
+    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;
+	  if (use_ent) then
+	    list.concat(Tai_ent.create(current_procinfo.procdef.mangledname));
+      current_procinfo.procdef.procstarttai:=tai(list.last);
+    end;
+
+  procedure thlcgobj.gen_proc_symbol_end(list: TAsmList);
+    begin
+	  if (use_ent) then
+	    list.concat(Tai_ent_end.create(current_procinfo.procdef.mangledname));
+      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]+systems_aix)) 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 }
+            if not(target_info.system in systems_aix) then
+              cg.a_jmp_name(list,target_info.cprefix+'FPC_SYSTEMMAIN')
+            else
+              cg.a_call_name(list,target_info.cprefix+'FPC_SYSTEMMAIN',false)
+           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  : boolean;
+    begin
+      list:=TAsmList(arg);
+      if (tsym(p).typ=paravarsym) then
+       begin
+         needs_inittable:=is_managed_type(tparavarsym(p).vardef);
+         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 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 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;
+         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
+          { 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]);
+      allocallcpuregisters(list);
+      a_call_name(list,pd,pd.mangledname,false);
+      deallocallcpuregisters(list);
+    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
@@ -1891,7 +1997,7 @@ implementation
                  end;
              end;
            { now search in the type itself }
-           srsym:=tprocsym(structdef.symtable.FindWithHash(hashedid));
+           srsym:=tsym(structdef.symtable.FindWithHash(hashedid));
            if assigned(srsym) and
               { Delphi allows hiding a property by a procedure with the same name }
               (srsym.typ=procsym) then
@@ -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]);
@@ -2306,7 +2417,9 @@ implementation
                  (
                   (count=1) or
                   equal_defs(tprocvardef(currpt.left.resultdef).returndef,def_to)
-                 ) then
+                 ) and
+                 { and if it doesn't require any parameters }
+                 (tprocvardef(currpt.left.resultdef).minparacount=0)  then
                 begin
                   releasecurrpt:=true;
                   currpt:=tcallparanode(pt.getcopy);
@@ -2832,6 +2945,7 @@ implementation
 
     function tcallcandidates.choose_best(var bestpd:tabstractprocdef; singlevariant: boolean):integer;
       var
+        pd: tprocdef;
         besthpstart,
         hp            : pcandidate;
         cntpd,
@@ -2886,6 +3000,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 +3072,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
@@ -2965,7 +3085,9 @@ implementation
           assigned(source.resultdef) and
           (source.resultdef.typ in [enumdef,orddef,floatdef]) and
           not is_boolean(source.resultdef) and
-          not is_constrealnode(source) then
+          not is_constrealnode(source) and
+          { constants are handled via regular range checking }
+          (source.nodetype<>ordconstn) then
          begin
            if ((destdef.size < source.resultdef.size) and
                { s80real and sc80real have a different size but the same precision }

compiler/i386/cgcpu.pas

@@ -148,6 +148,7 @@ unit cgcpu;
         procedure pushdata(paraloc:pcgparalocation;ofs:tcgint);
         var
           pushsize : tcgsize;
+          opsize : topsize;
           tmpreg   : tregister;
           href     : treference;
         begin
@@ -170,16 +171,21 @@ unit cgcpu;
             pushsize:=paraloc^.size
           else
             pushsize:=int_cgsize(cgpara.alignment);
+          opsize:=TCgsize2opsize[pushsize];
+          { for go32v2 we obtain OS_F32,
+            but pushs is not valid, we need pushl }
+          if opsize=S_FS then
+            opsize:=S_L;
           if tcgsize2size[paraloc^.size]<cgpara.alignment then
             begin
               tmpreg:=getintregister(list,pushsize);
               a_load_ref_reg(list,paraloc^.size,pushsize,href,tmpreg);
-              list.concat(taicpu.op_reg(A_PUSH,TCgsize2opsize[pushsize],tmpreg));
+              list.concat(taicpu.op_reg(A_PUSH,opsize,tmpreg));
             end
           else
             begin
               make_simple_ref(list,href);
-              list.concat(taicpu.op_ref(A_PUSH,TCgsize2opsize[pushsize],href));
+              list.concat(taicpu.op_ref(A_PUSH,opsize,href));
             end;
         end;
 
@@ -221,8 +227,6 @@ unit cgcpu;
       begin
         with r do
           begin
-            if (segment<>NR_NO) then
-              cgmessage(cg_e_cant_use_far_pointer_there);
             if use_push(cgpara) then
               begin
                 cgpara.check_simple_location;

compiler/i386/cpubase.inc

@@ -70,7 +70,8 @@
 
       {# Defines the default address size for a processor, }
       OS_ADDR = OS_32;
-      {# the natural int size for a processor,             }
+      {# the natural int size for a processor,
+         has to match osuinttype/ossinttype as initialized in psystem }
       OS_INT = OS_32;
       OS_SINT = OS_S32;
       {# the maximum float size for a processor,           }

compiler/i386/cpupara.pas

@@ -45,7 +45,7 @@ unit cpupara;
             and if the calling conventions for the helper routines of the
             rtl are used.
           }
-          procedure getintparaloc(calloption : tproccalloption; nr : longint;var cgpara:TCGPara);override;
+          procedure getintparaloc(calloption : tproccalloption; nr : longint; def : tdef; var cgpara : tcgpara);override;
           function create_paraloc_info(p : tabstractprocdef; side: tcallercallee):longint;override;
           function create_varargs_paraloc_info(p : tabstractprocdef; varargspara:tvarargsparalist):longint;override;
           procedure createtempparaloc(list: TAsmList;calloption : tproccalloption;parasym : tparavarsym;can_use_final_stack_loc : boolean;var cgpara:TCGPara);override;
@@ -270,14 +270,15 @@ unit cpupara;
       end;
 
 
-    procedure ti386paramanager.getintparaloc(calloption : tproccalloption; nr : longint;var cgpara:TCGPara);
+    procedure ti386paramanager.getintparaloc(calloption : tproccalloption; nr : longint; def : tdef; var cgpara : tcgpara);
       var
         paraloc : pcgparalocation;
       begin
         cgpara.reset;
-        cgpara.size:=OS_ADDR;
-        cgpara.intsize:=sizeof(pint);
+        cgpara.size:=def_cgsize(def);
+        cgpara.intsize:=tcgsize2size[cgpara.size];
         cgpara.alignment:=get_para_align(calloption);
+        cgpara.def:=def;
         paraloc:=cgpara.add_location;
         with paraloc^ do
          begin
@@ -321,18 +322,6 @@ unit cpupara;
         paraloc : pcgparalocation;
         sym: tfieldvarsym;
       begin
-        result.init;
-        result.alignment:=get_para_align(p.proccalloption);
-        { 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;
         { on darwin/i386, if a record has only one field and that field is a
           single or double, it has to be returned like a single/double }
         if (target_info.system in [system_i386_darwin,system_i386_iphonesim]) and
@@ -342,37 +331,23 @@ unit cpupara;
            (sym.vardef.typ=floatdef) and
            (tfloatdef(sym.vardef).floattype in [s32real,s64real]) then
           def:=sym.vardef;
-        { Constructors return self instead of a boolean }
-        if (p.proctypeoption=potype_constructor) then
-          begin
-            retcgsize:=OS_ADDR;
-            result.intsize:=sizeof(pint);
-          end
-        else
-          begin
-            retcgsize:=def_cgsize(def);
-            { darwin/x86 requires that results < sizeof(aint) are sign/ }
-            { zero extended to sizeof(aint)                             }
-            if (target_info.system in [system_i386_darwin,system_i386_iphonesim]) and
-               (side=calleeside) and
-               (result.intsize>0) and
-               (result.intsize<sizeof(aint)) then
-              begin
-                result.intsize:=sizeof(aint);
-                retcgsize:=OS_SINT;
-              end
-            else
-              result.intsize:=def.size;
-          end;
-        result.size:=retcgsize;
-        { Return is passed as var parameter }
-        if ret_in_param(def,p.proccalloption) then
+
+        if set_common_funcretloc_info(p,def,retcgsize,result) then
+          exit;
+
+        { darwin/x86 requires that results < sizeof(aint) are sign/zero
+          extended to sizeof(aint) }
+        if (target_info.system in [system_i386_darwin,system_i386_iphonesim]) and
+           (side=calleeside) and
+           (result.intsize>0) and
+           (result.intsize<sizeof(aint)) then
           begin
-            paraloc:=result.add_location;
-            paraloc^.loc:=LOC_REFERENCE;
-            paraloc^.size:=retcgsize;
-            exit;
+            result.def:=sinttype;
+            result.intsize:=sizeof(aint);
+            retcgsize:=OS_SINT;
+            result.size:=retcgsize;
           end;
+
         { Return in FPU register? }
         if def.typ=floatdef then
           begin
@@ -420,6 +395,7 @@ unit cpupara;
       var
         i  : integer;
         hp : tparavarsym;
+        paradef : tdef;
         paraloc : pcgparalocation;
         l,
         paralen,
@@ -451,15 +427,17 @@ unit cpupara;
               (not(p.proccalloption in pushleftright_pocalls) and (i<=paras.count-1)) do
           begin
             hp:=tparavarsym(paras[i]);
-            pushaddr:=push_addr_param(hp.varspez,hp.vardef,p.proccalloption);
+            paradef:=hp.vardef;
+            pushaddr:=push_addr_param(hp.varspez,paradef,p.proccalloption);
             if pushaddr then
               begin
                 paralen:=sizeof(aint);
                 paracgsize:=OS_ADDR;
+                paradef:=getpointerdef(paradef);
               end
             else
               begin
-                paralen:=push_size(hp.varspez,hp.vardef,p.proccalloption);
+                paralen:=push_size(hp.varspez,paradef,p.proccalloption);
                 { darwin/x86 requires that parameters < sizeof(aint) are sign/ }
                 { zero extended to sizeof(aint)                                }
                 if (target_info.system in [system_i386_darwin,system_i386_iphonesim]) and
@@ -467,15 +445,17 @@ unit cpupara;
                    (paralen > 0) and
                    (paralen < sizeof(aint)) then
                   begin
-                    paralen := sizeof(aint);
+                    paralen:=sizeof(aint);
                     paracgsize:=OS_SINT;
+                    paradef:=sinttype;
                   end
                 else
-                  paracgsize:=def_cgsize(hp.vardef);
+                  paracgsize:=def_cgsize(paradef);
               end;
             hp.paraloc[side].reset;
             hp.paraloc[side].size:=paracgsize;
             hp.paraloc[side].intsize:=paralen;
+            hp.paraloc[side].def:=paradef;
             hp.paraloc[side].Alignment:=paraalign;
             { Copy to stack? }
             if (paracgsize=OS_NO) or
@@ -553,6 +533,7 @@ unit cpupara;
                                                             var parareg,parasize:longint);
       var
         hp : tparavarsym;
+        paradef : tdef;
         paraloc : pcgparalocation;
         paracgsize : tcgsize;
         i : integer;
@@ -585,14 +566,15 @@ unit cpupara;
             while true do
               begin
                 hp:=tparavarsym(paras[i]);
+                paradef:=hp.vardef;
                 if not(assigned(hp.paraloc[side].location)) then
                   begin
-
                     pushaddr:=push_addr_param(hp.varspez,hp.vardef,p.proccalloption);
                     if pushaddr then
                       begin
                         paralen:=sizeof(aint);
                         paracgsize:=OS_ADDR;
+                        paradef:=getpointerdef(paradef);
                       end
                     else
                       begin
@@ -602,6 +584,7 @@ unit cpupara;
                     hp.paraloc[side].size:=paracgsize;
                     hp.paraloc[side].intsize:=paralen;
                     hp.paraloc[side].Alignment:=paraalign;
+                    hp.paraloc[side].def:=paradef;
                     {
                       EAX
                       EDX

compiler/i386/hlcgcpu.pas

@@ -0,0 +1,180 @@
+{
+    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
+
+  uses
+    aasmdata,
+    symtype,parabase,
+    cgutils,
+    hlcgobj, hlcgx86;
+
+
+  type
+    thlcgcpu = class(thlcgx86)
+     protected
+      procedure gen_loadfpu_loc_cgpara(list: TAsmList; size: tdef; const l: tlocation; const cgpara: tcgpara; locintsize: longint); override;
+    end;
+
+  procedure create_hlcodegen;
+
+implementation
+
+  uses
+    globtype,verbose,
+    paramgr,
+    cgbase,
+    cpubase,tgobj,cgobj,cgcpu;
+
+  { thlcgcpu }
+
+  procedure thlcgcpu.gen_loadfpu_loc_cgpara(list: TAsmList; size: tdef; const l: tlocation; const cgpara: tcgpara; locintsize: longint);
+    var
+      locsize : tcgsize;
+      locdef : tdef;
+      tmploc : tlocation;
+      href   : treference;
+      stacksize   : longint;
+    begin
+      if not(l.size in [OS_32,OS_S32,OS_64,OS_S64,OS_128,OS_S128]) then
+        locsize:=l.size
+      else
+        locsize:=int_float_cgsize(tcgsize2size[l.size]);
+      case l.loc of
+        LOC_FPUREGISTER,
+        LOC_CFPUREGISTER:
+          begin
+            case cgpara.location^.loc of
+              LOC_REFERENCE:
+                begin
+                  stacksize:=align(locintsize,cgpara.alignment);
+                  if (not paramanager.use_fixed_stack) and
+                     (cgpara.location^.reference.index=NR_STACK_POINTER_REG) then
+                    begin
+                      cg.g_stackpointer_alloc(list,stacksize);
+                      reference_reset_base(href,NR_STACK_POINTER_REG,0,sizeof(pint));
+                    end
+                  else
+                    reference_reset_base(href,cgpara.location^.reference.index,cgpara.location^.reference.offset,cgpara.alignment);
+                  cg.a_loadfpu_reg_ref(list,locsize,locsize,l.register,href);
+                end;
+              LOC_FPUREGISTER:
+                begin
+                  cg.a_loadfpu_reg_reg(list,locsize,cgpara.location^.size,l.register,cgpara.location^.register);
+                end;
+              { can happen if a record with only 1 "single field" is
+                returned in a floating point register and then is directly
+                passed to a regcall parameter }
+              LOC_REGISTER:
+                begin
+                  tmploc:=l;
+                  location_force_mem(list,tmploc,size);
+                  case locsize of
+                    OS_F32:
+                      tmploc.size:=OS_32;
+                    OS_F64:
+                      tmploc.size:=OS_64;
+                    else
+                      internalerror(2010053116);
+                  end;
+                  cg.a_load_loc_cgpara(list,tmploc,cgpara);
+                  location_freetemp(list,tmploc);
+                end
+              else
+                internalerror(2010053003);
+            end;
+          end;
+        LOC_MMREGISTER,
+        LOC_CMMREGISTER:
+          begin
+            case cgpara.location^.loc of
+              LOC_REFERENCE:
+                begin
+                  { can't use TCGSize2Size[l.size], because the size of an
+                    80 bit extended parameter can be either 10 or 12 bytes }
+                  stacksize:=align(locintsize,cgpara.alignment);
+                  if (not paramanager.use_fixed_stack) and
+                     (cgpara.location^.reference.index=NR_STACK_POINTER_REG) then
+                    begin
+                      cg.g_stackpointer_alloc(list,stacksize);
+                      reference_reset_base(href,NR_STACK_POINTER_REG,0,sizeof(pint));
+                    end
+                  else
+                    reference_reset_base(href,cgpara.location^.reference.index,cgpara.location^.reference.offset,cgpara.alignment);
+                  cg.a_loadmm_reg_ref(list,locsize,locsize,l.register,href,mms_movescalar);
+                end;
+              LOC_FPUREGISTER:
+                begin
+                  tmploc:=l;
+                  location_force_mem(list,tmploc,size);
+                  cg.a_loadfpu_ref_cgpara(list,tmploc.size,tmploc.reference,cgpara);
+                  location_freetemp(list,tmploc);
+                end;
+              else
+                internalerror(2010053004);
+            end;
+          end;
+        LOC_REFERENCE,
+        LOC_CREFERENCE :
+          begin
+            case cgpara.location^.loc of
+              LOC_REFERENCE:
+                begin
+                  stacksize:=align(locintsize,cgpara.alignment);
+                  if (not paramanager.use_fixed_stack) and
+                     (cgpara.location^.reference.index=NR_STACK_POINTER_REG) then
+                    cg.a_load_ref_cgpara(list,locsize,l.reference,cgpara)
+                  else
+                    begin
+                      reference_reset_base(href,cgpara.location^.reference.index,cgpara.location^.reference.offset,cgpara.alignment);
+                      cg.g_concatcopy(list,l.reference,href,stacksize);
+                    end;
+                end;
+              LOC_FPUREGISTER:
+                begin
+                  cg.a_loadfpu_ref_cgpara(list,locsize,l.reference,cgpara);
+                end;
+              else
+                internalerror(2010053005);
+            end;
+          end;
+        else
+          internalerror(2002042430);
+      end;
+    end;
+
+
+  procedure create_hlcodegen;
+    begin
+      hlcg:=thlcgcpu.create;
+      create_codegen;
+    end;
+
+
+
+end.

compiler/i386/n386add.pas

@@ -46,7 +46,8 @@ interface
       aasmbase,aasmtai,aasmdata,aasmcpu,
       cgbase,procinfo,
       ncon,nset,cgutils,tgobj,
-      cga,ncgutil,cgobj,cg64f32,cgx86;
+      cga,ncgutil,cgobj,cg64f32,cgx86,
+      hlcgobj;
 
 {*****************************************************************************
                                 use_generic_mul32to64
@@ -399,12 +400,12 @@ interface
         begin
           {LOC_CONSTANT for example.}
           reg:=cg.getintregister(current_asmdata.CurrAsmList,OS_INT);
-          cg.a_load_loc_reg(current_asmdata.CurrAsmList,OS_INT,left.location,reg);
+          hlcg.a_load_loc_reg(current_asmdata.CurrAsmList,left.resultdef,osuinttype,left.location,reg);
         end;
       {Allocate EAX.}
       cg.getcpuregister(current_asmdata.CurrAsmList,NR_EAX);
       {Load the right value.}
-      cg.a_load_loc_reg(current_asmdata.CurrAsmList,OS_INT,right.location,NR_EAX);
+      hlcg.a_load_loc_reg(current_asmdata.CurrAsmList,right.resultdef,osuinttype,right.location,NR_EAX);
       {Also allocate EDX, since it is also modified by a mul (JM).}
       cg.getcpuregister(current_asmdata.CurrAsmList,NR_EDX);
       if use_ref then

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/n386mat.pas

@@ -54,7 +54,8 @@ implementation
       cgbase,pass_2,
       ncon,
       cpubase,cpuinfo,
-      cga,ncgutil,cgobj,cgutils;
+      cga,ncgutil,cgobj,cgutils,
+      hlcgobj;
 
 {*****************************************************************************
                              TI386MODDIVNODE
@@ -94,7 +95,7 @@ implementation
           internalerror(200109052);
         { put numerator in register }
         location_reset(location,LOC_REGISTER,def_cgsize(resultdef));
-        location_force_reg(current_asmdata.CurrAsmList,left.location,location.size,false);
+        hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,resultdef,false);
         hreg1:=left.location.register;
 
         if (nodetype=divn) and (right.nodetype=ordconstn) then
@@ -336,7 +337,7 @@ implementation
             else
               begin
                 hreg1:=cg.getintregister(current_asmdata.CurrAsmList,right.location.size);
-                cg.a_load_loc_reg(current_asmdata.CurrAsmList,OS_32,right.location,hreg1);
+                hlcg.a_load_loc_reg(current_asmdata.CurrAsmList,right.resultdef,u32inttype,right.location,hreg1);
                 emit_reg(op,S_L,hreg1);
               end;
 
@@ -371,7 +372,7 @@ implementation
         location_reset(location,LOC_REGISTER,def_cgsize(resultdef));
 
         { load left operator in a register }
-        location_force_reg(current_asmdata.CurrAsmList,left.location,location.size,false);
+        hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,resultdef,false);
         hreg64hi:=left.location.register64.reghi;
         hreg64lo:=left.location.register64.reglo;
 
@@ -416,7 +417,7 @@ implementation
           begin
             { load right operators in a register }
             cg.getcpuregister(current_asmdata.CurrAsmList,NR_ECX);
-            cg.a_load_loc_reg(current_asmdata.CurrAsmList,OS_32,right.location,NR_ECX);
+            hlcg.a_load_loc_reg(current_asmdata.CurrAsmList,right.resultdef,u32inttype,right.location,NR_ECX);
 
             { left operator is already in a register }
             { hence are both in a register }

compiler/i386/n386set.pas

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

compiler/i386/popt386.pas

@@ -637,12 +637,20 @@ begin
         because it can never be executed}
                 if (taicpu(p).opcode = A_JMP) then
                   begin
-                    while GetNextInstruction(p, hp1) and
+                    hp2:=p;
+                    while GetNextInstruction(hp2, hp1) and
                           (hp1.typ <> ait_label) do
                       if not(hp1.typ in ([ait_label,ait_align]+skipinstr)) then
                         begin
-                          asml.remove(hp1);
-                          hp1.free;
+                          { don't kill start/end of assembler block,
+                            no-line-info-start/end etc }
+                          if hp1.typ<>ait_marker then
+                            begin
+                              asml.remove(hp1);
+                              hp1.free;
+                            end
+                          else
+                            hp2:=hp1;
                         end
                       else break;
                     end;

compiler/ia64/cpubase.pas

@@ -111,7 +111,8 @@ Const
 
       { Defines the default address size for a processor, }
       OS_ADDR = OS_64;
-      { the natural int size for a processor,             }
+      { the natural int size for a processor,
+        has to match osuinttype/ossinttype as initialized in psystem }
       OS_INT = OS_64;
       OS_SINT = OS_S64;
       { the maximum float size for a processor,           }

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,cghlcpu,
+       aasmbase,aasmtai,aasmdata,aasmcpu,
+       cpubase,cpuinfo,
+       node,symconst,SymType,symdef,
+       rgcpu;
+
+    type
+      TCgJvm=class(thlbasecgcpu)
+     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,338 @@
+{
+    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,
+         has to match osuinttype/ossinttype as initialized in psystem }
+      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,
+         has to match osuinttype/ossinttype as initialized in psystem }
+      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_INVALID);
+
+      {# 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,277 @@
+{
+    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; def : tdef; var cgpara : tcgpara);override;
+        function  create_paraloc_info(p : TAbstractProcDef; side: tcallercallee):longint;override;
+        function  create_varargs_paraloc_info(p : tabstractprocdef; varargspara:tvarargsparalist):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; def : tdef; var cgpara : tcgpara);
+      begin
+        { not yet implemented/used }
+        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;
+
+
+    function TJVMParaManager.create_varargs_paraloc_info(p : tabstractprocdef; varargspara:tvarargsparalist):longint;
+      var
+        parasize : longint;
+      begin
+        parasize:=0;
+        { calculate the registers for the normal parameters }
+        create_paraloc_info_intern(p,callerside,p.paras,parasize);
+        { append the varargs }
+        create_paraloc_info_intern(p,callerside,varargspara,parasize);
+        result:=parasize;
+      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,2330 @@
+{
+    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_call_reg(list: TAsmList; pd: tabstractprocdef; reg: tregister); 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_call_reg(list: TAsmList; pd: tabstractprocdef; reg: tregister);
+    begin
+      internalerror(2012042824);
+    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
+                  ((vs.typ<>fieldvarsym) or
+                   (tdef(vs.owner.defowner).typ<>objectdef) or
+                   (ts_jvm_enum_field_init in current_settings.targetswitches)) 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,1616 @@
+{
+    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_cstring_to_pchar: 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_cstring_to_pchar: tnode;
+      var
+        vs: tstaticvarsym;
+      begin
+        result:=inherited;
+        if assigned(result) then
+          exit;
+        { nil pointer -> valid address }
+        if (left.nodetype=stringconstn) and
+           (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('FPC_EMPTYANSICHAR'))
+            else
+              vs:=tstaticvarsym(systemunit.Find('FPC_EMPTYWIDECHAR'));
+            if not assigned(vs) then
+              internalerror(2012052605);
+            result:=caddrnode.create(cloadnode.create(vs,vs.owner));
+            result:=ctypeconvnode.create_explicit(result,resultdef);
+          end;
+      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;
+      begin
+        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,489 @@
+{
+    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 }
+                  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
+              if len<>0 then
+                internalerror(2012052604);
+              hlcg.a_load_const_reg(current_asmdata.CurrAsmList,resultdef,0,location.register);
+              { done }
+              exit;
+            end;
+          cst_shortstring,
+          cst_conststring:
+            internalerror(2012052601);
+          cst_unicodestring,
+          cst_widestring:
+            current_asmdata.CurrAsmList.concat(taicpu.op_wstring(a_ldc,pcompilerwidestring(value_str)));
+          else
+            internalerror(2012052602);
+        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.