Bläddra i källkod

* retag for unitrw

git-svn-id: branches/unitrw@1551 -
peter 20 år sedan
förälder
incheckning
61745c2e37
100 ändrade filer med 42311 tillägg och 0 borttagningar
  1. 570 0
      .gitattributes
  2. 126 0
      .gitignore
  3. 340 0
      compiler/COPYING
  4. 0 0
      compiler/MPWMake
  5. 2785 0
      compiler/Makefile
  6. 563 0
      compiler/Makefile.fpc
  7. 58 0
      compiler/README
  8. 952 0
      compiler/aasmbase.pas
  9. 2349 0
      compiler/aasmtai.pas
  10. 870 0
      compiler/aggas.pas
  11. 281 0
      compiler/alpha/aasmcpu.pas
  12. 126 0
      compiler/alpha/agaxpgas.pas
  13. 38 0
      compiler/alpha/aoptcpu.pas
  14. 115 0
      compiler/alpha/aoptcpub.pas
  15. 38 0
      compiler/alpha/aoptcpuc.pas
  16. 39 0
      compiler/alpha/aoptcpud.pas
  17. 160 0
      compiler/alpha/cgcpu.pas
  18. 457 0
      compiler/alpha/cpubase.pas
  19. 68 0
      compiler/alpha/cpuinfo.pas
  20. 54 0
      compiler/alpha/cpunode.pas
  21. 290 0
      compiler/alpha/cpupara.pas
  22. 43 0
      compiler/alpha/cpupi.pas
  23. 121 0
      compiler/alpha/cpuswtch.pas
  24. 51 0
      compiler/alpha/cputarg.pas
  25. 313 0
      compiler/alpha/radirect.pas
  26. 65 0
      compiler/alpha/rasm.pas
  27. 69 0
      compiler/alpha/rgcpu.pas
  28. 42 0
      compiler/alpha/tgcpu.pas
  29. 267 0
      compiler/aopt.pas
  30. 257 0
      compiler/aoptbase.pas
  31. 848 0
      compiler/aoptcs.pas
  32. 183 0
      compiler/aoptda.pas
  33. 1125 0
      compiler/aoptobj.pas
  34. 2399 0
      compiler/arm/aasmcpu.pas
  35. 237 0
      compiler/arm/agarmgas.pas
  36. 42 0
      compiler/arm/aoptcpu.pas
  37. 120 0
      compiler/arm/aoptcpub.pas
  38. 38 0
      compiler/arm/aoptcpuc.pas
  39. 40 0
      compiler/arm/aoptcpud.pas
  40. 90 0
      compiler/arm/armatt.inc
  41. 90 0
      compiler/arm/armatts.inc
  42. 394 0
      compiler/arm/armins.dat
  43. 2 0
      compiler/arm/armnop.inc
  44. 90 0
      compiler/arm/armop.inc
  45. 84 0
      compiler/arm/armreg.dat
  46. 759 0
      compiler/arm/armtab.inc
  47. 1712 0
      compiler/arm/cgcpu.pas
  48. 520 0
      compiler/arm/cpubase.pas
  49. 88 0
      compiler/arm/cpuinfo.pas
  50. 46 0
      compiler/arm/cpunode.pas
  51. 496 0
      compiler/arm/cpupara.pas
  52. 105 0
      compiler/arm/cpupi.pas
  53. 118 0
      compiler/arm/cpuswtch.pas
  54. 78 0
      compiler/arm/cputarg.pas
  55. 93 0
      compiler/arm/itcpugas.pas
  56. 336 0
      compiler/arm/narmadd.pas
  57. 50 0
      compiler/arm/narmcal.pas
  58. 265 0
      compiler/arm/narmcnv.pas
  59. 141 0
      compiler/arm/narmcon.pas
  60. 216 0
      compiler/arm/narminl.pas
  61. 121 0
      compiler/arm/narmmat.pas
  62. 54 0
      compiler/arm/raarm.pas
  63. 797 0
      compiler/arm/raarmgas.pas
  64. 74 0
      compiler/arm/rarmcon.inc
  65. 74 0
      compiler/arm/rarmdwa.inc
  66. 2 0
      compiler/arm/rarmnor.inc
  67. 74 0
      compiler/arm/rarmnum.inc
  68. 74 0
      compiler/arm/rarmrni.inc
  69. 74 0
      compiler/arm/rarmsri.inc
  70. 74 0
      compiler/arm/rarmsta.inc
  71. 74 0
      compiler/arm/rarmstd.inc
  72. 74 0
      compiler/arm/rarmsup.inc
  73. 168 0
      compiler/arm/rgcpu.pas
  74. 1482 0
      compiler/assemble.pas
  75. 2143 0
      compiler/browcol.pas
  76. 515 0
      compiler/browlog.pas
  77. 3 0
      compiler/bsdcompile
  78. 92 0
      compiler/catch.pas
  79. 2352 0
      compiler/cclasses.pas
  80. 791 0
      compiler/cg64f32.pas
  81. 605 0
      compiler/cgbase.pas
  82. 2090 0
      compiler/cgobj.pas
  83. 186 0
      compiler/cgutils.pas
  84. 252 0
      compiler/charset.pas
  85. 413 0
      compiler/cmsgs.pas
  86. 413 0
      compiler/comphook.pas
  87. 450 0
      compiler/compiler.pas
  88. 107 0
      compiler/compinnr.inc
  89. 185 0
      compiler/comprsrc.pas
  90. 281 0
      compiler/cp437.pas
  91. 281 0
      compiler/cp850.pas
  92. 281 0
      compiler/cp8859_1.pas
  93. 100 0
      compiler/crc.pas
  94. 294 0
      compiler/cresstr.pas
  95. 613 0
      compiler/cstreams.pas
  96. 1081 0
      compiler/cutils.pas
  97. 128 0
      compiler/dbgbase.pas
  98. 49 0
      compiler/dbgdwarf.pas
  99. 1589 0
      compiler/dbgstabs.pas
  100. 1489 0
      compiler/defcmp.pas

+ 570 - 0
.gitattributes

@@ -1 +1,571 @@
 * text=auto !eol
 * text=auto !eol
+compiler/COPYING -text
+compiler/MPWMake -text
+compiler/Makefile svneol=native#text/plain
+compiler/Makefile.fpc svneol=native#text/plain
+compiler/README -text
+compiler/aasmbase.pas svneol=native#text/plain
+compiler/aasmtai.pas svneol=native#text/plain
+compiler/aggas.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
+compiler/alpha/aoptcpub.pas svneol=native#text/plain
+compiler/alpha/aoptcpuc.pas svneol=native#text/plain
+compiler/alpha/aoptcpud.pas svneol=native#text/plain
+compiler/alpha/cgcpu.pas svneol=native#text/plain
+compiler/alpha/cpubase.pas svneol=native#text/plain
+compiler/alpha/cpuinfo.pas svneol=native#text/plain
+compiler/alpha/cpunode.pas svneol=native#text/plain
+compiler/alpha/cpupara.pas svneol=native#text/plain
+compiler/alpha/cpupi.pas svneol=native#text/plain
+compiler/alpha/cpuswtch.pas svneol=native#text/plain
+compiler/alpha/cputarg.pas svneol=native#text/plain
+compiler/alpha/radirect.pas svneol=native#text/plain
+compiler/alpha/rasm.pas svneol=native#text/plain
+compiler/alpha/rgcpu.pas svneol=native#text/plain
+compiler/alpha/tgcpu.pas svneol=native#text/plain
+compiler/aopt.pas svneol=native#text/plain
+compiler/aoptbase.pas svneol=native#text/plain
+compiler/aoptcs.pas svneol=native#text/plain
+compiler/aoptda.pas svneol=native#text/plain
+compiler/aoptobj.pas svneol=native#text/plain
+compiler/arm/aasmcpu.pas svneol=native#text/plain
+compiler/arm/agarmgas.pas svneol=native#text/plain
+compiler/arm/aoptcpu.pas svneol=native#text/plain
+compiler/arm/aoptcpub.pas svneol=native#text/plain
+compiler/arm/aoptcpuc.pas svneol=native#text/plain
+compiler/arm/aoptcpud.pas svneol=native#text/plain
+compiler/arm/armatt.inc svneol=native#text/plain
+compiler/arm/armatts.inc svneol=native#text/plain
+compiler/arm/armins.dat -text
+compiler/arm/armnop.inc svneol=native#text/plain
+compiler/arm/armop.inc svneol=native#text/plain
+compiler/arm/armtab.inc svneol=native#text/plain
+compiler/arm/cgcpu.pas svneol=native#text/plain
+compiler/arm/cpubase.pas svneol=native#text/plain
+compiler/arm/cpuinfo.pas svneol=native#text/plain
+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/cpuswtch.pas svneol=native#text/plain
+compiler/arm/cputarg.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
+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/raarm.pas svneol=native#text/plain
+compiler/arm/raarmgas.pas svneol=native#text/plain
+compiler/arm/rarmcon.inc svneol=native#text/plain
+compiler/arm/rarmdwa.inc svneol=native#text/plain
+compiler/arm/rarmnor.inc svneol=native#text/plain
+compiler/arm/rarmnum.inc svneol=native#text/plain
+compiler/arm/rarmrni.inc svneol=native#text/plain
+compiler/arm/rarmsri.inc svneol=native#text/plain
+compiler/arm/rarmsta.inc svneol=native#text/plain
+compiler/arm/rarmstd.inc svneol=native#text/plain
+compiler/arm/rarmsup.inc svneol=native#text/plain
+compiler/arm/rgcpu.pas svneol=native#text/plain
+compiler/assemble.pas svneol=native#text/plain
+compiler/browcol.pas svneol=native#text/plain
+compiler/browlog.pas svneol=native#text/plain
+compiler/bsdcompile -text
+compiler/catch.pas svneol=native#text/plain
+compiler/cclasses.pas svneol=native#text/plain
+compiler/cg64f32.pas svneol=native#text/plain
+compiler/cgbase.pas svneol=native#text/plain
+compiler/cgobj.pas svneol=native#text/plain
+compiler/cgutils.pas svneol=native#text/plain
+compiler/charset.pas svneol=native#text/plain
+compiler/cmsgs.pas svneol=native#text/plain
+compiler/comphook.pas svneol=native#text/plain
+compiler/compiler.pas svneol=native#text/plain
+compiler/compinnr.inc svneol=native#text/plain
+compiler/comprsrc.pas svneol=native#text/plain
+compiler/cp437.pas svneol=native#text/plain
+compiler/cp850.pas svneol=native#text/plain
+compiler/cp8859_1.pas svneol=native#text/plain
+compiler/crc.pas svneol=native#text/plain
+compiler/cresstr.pas svneol=native#text/plain
+compiler/cstreams.pas svneol=native#text/plain
+compiler/cutils.pas svneol=native#text/plain
+compiler/dbgbase.pas svneol=native#text/plain
+compiler/dbgdwarf.pas svneol=native#text/plain
+compiler/dbgstabs.pas svneol=native#text/plain
+compiler/defcmp.pas svneol=native#text/plain
+compiler/defutil.pas svneol=native#text/plain
+compiler/dwarf.pas svneol=native#text/plain
+compiler/export.pas svneol=native#text/plain
+compiler/finput.pas svneol=native#text/plain
+compiler/fmodule.pas svneol=native#text/plain
+compiler/fpcdefs.inc svneol=native#text/plain
+compiler/fppu.pas svneol=native#text/plain
+compiler/gendef.pas svneol=native#text/plain
+compiler/globals.pas svneol=native#text/plain
+compiler/globtype.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
+compiler/i386/ag386nsm.pas svneol=native#text/plain
+compiler/i386/aopt386.pas svneol=native#text/plain
+compiler/i386/cgcpu.pas svneol=native#text/plain
+compiler/i386/cpubase.inc svneol=native#text/plain
+compiler/i386/cpuinfo.pas svneol=native#text/plain
+compiler/i386/cpunode.pas svneol=native#text/plain
+compiler/i386/cpupara.pas svneol=native#text/plain
+compiler/i386/cpupi.pas svneol=native#text/plain
+compiler/i386/cpuswtch.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/i386att.inc svneol=native#text/plain
+compiler/i386/i386atts.inc svneol=native#text/plain
+compiler/i386/i386int.inc svneol=native#text/plain
+compiler/i386/i386nop.inc svneol=native#text/plain
+compiler/i386/i386op.inc svneol=native#text/plain
+compiler/i386/i386prop.inc svneol=native#text/plain
+compiler/i386/i386tab.inc svneol=native#text/plain
+compiler/i386/n386add.pas svneol=native#text/plain
+compiler/i386/n386cal.pas svneol=native#text/plain
+compiler/i386/n386inl.pas svneol=native#text/plain
+compiler/i386/n386mat.pas svneol=native#text/plain
+compiler/i386/n386mem.pas svneol=native#text/plain
+compiler/i386/n386set.pas svneol=native#text/plain
+compiler/i386/optbase.pas svneol=native#text/plain
+compiler/i386/popt386.pas svneol=native#text/plain
+compiler/i386/r386ari.inc svneol=native#text/plain
+compiler/i386/r386att.inc svneol=native#text/plain
+compiler/i386/r386con.inc svneol=native#text/plain
+compiler/i386/r386dwrf.inc svneol=native#text/plain
+compiler/i386/r386int.inc svneol=native#text/plain
+compiler/i386/r386iri.inc svneol=native#text/plain
+compiler/i386/r386nasm.inc svneol=native#text/plain
+compiler/i386/r386nor.inc svneol=native#text/plain
+compiler/i386/r386nri.inc svneol=native#text/plain
+compiler/i386/r386num.inc svneol=native#text/plain
+compiler/i386/r386op.inc svneol=native#text/plain
+compiler/i386/r386ot.inc svneol=native#text/plain
+compiler/i386/r386rni.inc svneol=native#text/plain
+compiler/i386/r386sri.inc svneol=native#text/plain
+compiler/i386/r386stab.inc svneol=native#text/plain
+compiler/i386/r386std.inc svneol=native#text/plain
+compiler/i386/ra386att.pas svneol=native#text/plain
+compiler/i386/ra386int.pas svneol=native#text/plain
+compiler/i386/rgcpu.pas svneol=native#text/plain
+compiler/i386/rropt386.pas svneol=native#text/plain
+compiler/ia64/cpuasm.pas svneol=native#text/plain
+compiler/ia64/cpubase.pas svneol=native#text/plain
+compiler/ia64/cpuinfo.pas svneol=native#text/plain
+compiler/impdef.pas svneol=native#text/plain
+compiler/import.pas svneol=native#text/plain
+compiler/link.pas svneol=native#text/plain
+compiler/m68k/aasmcpu.pas svneol=native#text/plain
+compiler/m68k/agcpugas.pas svneol=native#text/plain
+compiler/m68k/aoptcpu.pas svneol=native#text/plain
+compiler/m68k/aoptcpub.pas svneol=native#text/plain
+compiler/m68k/aoptcpud.pas svneol=native#text/plain
+compiler/m68k/cgcpu.pas svneol=native#text/plain
+compiler/m68k/cpuasm.pas svneol=native#text/plain
+compiler/m68k/cpubase.pas svneol=native#text/plain
+compiler/m68k/cpuinfo.pas svneol=native#text/plain
+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/cpuswtch.pas svneol=native#text/plain
+compiler/m68k/cputarg.pas svneol=native#text/plain
+compiler/m68k/itcpugas.pas svneol=native#text/plain
+compiler/m68k/n68kcnv.pas svneol=native#text/plain
+compiler/m68k/n68kmat.pas svneol=native#text/plain
+compiler/m68k/ncpuadd.pas svneol=native#text/plain
+compiler/m68k/r68kcon.inc svneol=native#text/plain
+compiler/m68k/r68kgas.inc svneol=native#text/plain
+compiler/m68k/r68kgri.inc svneol=native#text/plain
+compiler/m68k/r68knor.inc svneol=native#text/plain
+compiler/m68k/r68knum.inc svneol=native#text/plain
+compiler/m68k/r68krni.inc svneol=native#text/plain
+compiler/m68k/r68ksri.inc svneol=native#text/plain
+compiler/m68k/r68ksta.inc svneol=native#text/plain
+compiler/m68k/r68kstd.inc svneol=native#text/plain
+compiler/m68k/r68ksup.inc svneol=native#text/plain
+compiler/m68k/ra68k.pas svneol=native#text/plain
+compiler/m68k/ra68kmot.pas svneol=native#text/plain
+compiler/m68k/rgcpu.pas svneol=native#text/plain
+compiler/make_old.cmd -text
+compiler/mdppc386.bat -text
+compiler/mips/aasmcpu.pas svneol=native#text/plain
+compiler/mips/cpubase.pas svneol=native#text/plain
+compiler/mips/cpuinfo.pas svneol=native#text/plain
+compiler/mips/itcpugas.pas svneol=native#text/plain
+compiler/mips/rmipscon.inc svneol=native#text/plain
+compiler/mips/rmipsdwf.inc svneol=native#text/plain
+compiler/mips/rmipsgas.inc svneol=native#text/plain
+compiler/mips/rmipsgri.inc svneol=native#text/plain
+compiler/mips/rmipsgss.inc svneol=native#text/plain
+compiler/mips/rmipsmot.inc svneol=native#text/plain
+compiler/mips/rmipsmri.inc svneol=native#text/plain
+compiler/mips/rmipsnor.inc svneol=native#text/plain
+compiler/mips/rmipsnum.inc svneol=native#text/plain
+compiler/mips/rmipsrni.inc svneol=native#text/plain
+compiler/mips/rmipssri.inc svneol=native#text/plain
+compiler/mips/rmipssta.inc svneol=native#text/plain
+compiler/mips/rmipsstd.inc svneol=native#text/plain
+compiler/mips/rmipssup.inc svneol=native#text/plain
+compiler/mppc386.bat -text
+compiler/mppc68k.bat -text
+compiler/mppcsparc -text
+compiler/msg/errorct.msg svneol=native#text/plain
+compiler/msg/errord.msg svneol=native#text/plain
+compiler/msg/errore.msg svneol=native#text/plain
+compiler/msg/errores.msg svneol=native#text/plain
+compiler/msg/errorf.msg svneol=native#text/plain
+compiler/msg/errorhe.msg svneol=native#text/plain
+compiler/msg/errorn.msg svneol=native#text/plain
+compiler/msg/errorpl.msg svneol=native#text/plain
+compiler/msg/errorpli.msg svneol=native#text/plain
+compiler/msg/errorptd.msg -text
+compiler/msg/errorptw.msg -text
+compiler/msg/errorr.msg svneol=native#text/plain
+compiler/msg/errorrw.msg svneol=native#text/plain
+compiler/msg/errorues.msg svneol=native#text/plain
+compiler/msgidx.inc svneol=native#text/plain
+compiler/msgtxt.inc svneol=native#text/plain
+compiler/nadd.pas svneol=native#text/plain
+compiler/nbas.pas svneol=native#text/plain
+compiler/ncal.pas svneol=native#text/plain
+compiler/ncgadd.pas svneol=native#text/plain
+compiler/ncgbas.pas svneol=native#text/plain
+compiler/ncgcal.pas svneol=native#text/plain
+compiler/ncgcnv.pas svneol=native#text/plain
+compiler/ncgcon.pas svneol=native#text/plain
+compiler/ncgflw.pas svneol=native#text/plain
+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/ncgopt.pas svneol=native#text/plain
+compiler/ncgset.pas svneol=native#text/plain
+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/ninl.pas svneol=native#text/plain
+compiler/nld.pas svneol=native#text/plain
+compiler/nmat.pas svneol=native#text/plain
+compiler/nmem.pas svneol=native#text/plain
+compiler/nobj.pas svneol=native#text/plain
+compiler/node.pas svneol=native#text/plain
+compiler/nopt.pas svneol=native#text/plain
+compiler/nset.pas svneol=native#text/plain
+compiler/nstate.pas svneol=native#text/plain
+compiler/nutils.pas svneol=native#text/plain
+compiler/ogbase.pas svneol=native#text/plain
+compiler/ogcoff.pas svneol=native#text/plain
+compiler/ogelf.pas svneol=native#text/plain
+compiler/oglx.pas svneol=native#text/plain
+compiler/ogmap.pas svneol=native#text/plain
+compiler/optcse.pas svneol=native#text/plain
+compiler/options.pas svneol=native#text/plain
+compiler/optunrol.pas svneol=native#text/plain
+compiler/owar.pas svneol=native#text/plain
+compiler/owbase.pas svneol=native#text/plain
+compiler/parabase.pas svneol=native#text/plain
+compiler/paramgr.pas svneol=native#text/plain
+compiler/parser.pas svneol=native#text/plain
+compiler/pass_1.pas svneol=native#text/plain
+compiler/pass_2.pas svneol=native#text/plain
+compiler/pbase.pas svneol=native#text/plain
+compiler/pdecl.pas svneol=native#text/plain
+compiler/pdecobj.pas svneol=native#text/plain
+compiler/pdecsub.pas svneol=native#text/plain
+compiler/pdecvar.pas svneol=native#text/plain
+compiler/pexports.pas svneol=native#text/plain
+compiler/pexpr.pas svneol=native#text/plain
+compiler/pinline.pas svneol=native#text/plain
+compiler/pmodules.pas svneol=native#text/plain
+compiler/powerpc/aasmcpu.pas svneol=native#text/plain
+compiler/powerpc/agppcgas.pas svneol=native#text/plain
+compiler/powerpc/agppcmpw.pas svneol=native#text/plain
+compiler/powerpc/aoptcpu.pas svneol=native#text/plain
+compiler/powerpc/aoptcpub.pas svneol=native#text/plain
+compiler/powerpc/aoptcpuc.pas svneol=native#text/plain
+compiler/powerpc/aoptcpud.pas svneol=native#text/plain
+compiler/powerpc/cgcpu.pas svneol=native#text/plain
+compiler/powerpc/cpubase.pas svneol=native#text/plain
+compiler/powerpc/cpuinfo.pas svneol=native#text/plain
+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/cpuswtch.pas svneol=native#text/plain
+compiler/powerpc/cputarg.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
+compiler/powerpc/nppccnv.pas svneol=native#text/plain
+compiler/powerpc/nppcinl.pas svneol=native#text/plain
+compiler/powerpc/nppcld.pas svneol=native#text/plain
+compiler/powerpc/nppcmat.pas svneol=native#text/plain
+compiler/powerpc/nppcset.pas svneol=native#text/plain
+compiler/powerpc/rappc.pas svneol=native#text/plain
+compiler/powerpc/rappcgas.pas svneol=native#text/plain
+compiler/powerpc/rgcpu.pas svneol=native#text/plain
+compiler/powerpc/rppccon.inc svneol=native#text/plain
+compiler/powerpc/rppcdwrf.inc svneol=native#text/plain
+compiler/powerpc/rppcgas.inc svneol=native#text/plain
+compiler/powerpc/rppcgri.inc svneol=native#text/plain
+compiler/powerpc/rppcgss.inc svneol=native#text/plain
+compiler/powerpc/rppcmot.inc svneol=native#text/plain
+compiler/powerpc/rppcmri.inc svneol=native#text/plain
+compiler/powerpc/rppcnor.inc svneol=native#text/plain
+compiler/powerpc/rppcnum.inc svneol=native#text/plain
+compiler/powerpc/rppcrni.inc svneol=native#text/plain
+compiler/powerpc/rppcsri.inc svneol=native#text/plain
+compiler/powerpc/rppcstab.inc svneol=native#text/plain
+compiler/powerpc/rppcstd.inc svneol=native#text/plain
+compiler/powerpc/rppcsup.inc svneol=native#text/plain
+compiler/powerpc64/aasmcpu.pas svneol=native#text/plain
+compiler/powerpc64/agppcgas.pas svneol=native#text/plain
+compiler/powerpc64/aoptcpu.pas svneol=native#text/plain
+compiler/powerpc64/aoptcpub.pas svneol=native#text/plain
+compiler/powerpc64/aoptcpuc.pas svneol=native#text/plain
+compiler/powerpc64/aoptcpud.pas svneol=native#text/plain
+compiler/powerpc64/cgcpu.pas svneol=native#text/plain
+compiler/powerpc64/cpubase.pas svneol=native#text/plain
+compiler/powerpc64/cpuinfo.pas svneol=native#text/plain
+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/cpuswtch.pas svneol=native#text/plain
+compiler/powerpc64/cputarg.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
+compiler/powerpc64/nppccnv.pas svneol=native#text/plain
+compiler/powerpc64/nppcinl.pas svneol=native#text/plain
+compiler/powerpc64/nppcld.pas svneol=native#text/plain
+compiler/powerpc64/nppcmat.pas svneol=native#text/plain
+compiler/powerpc64/nppcset.pas svneol=native#text/plain
+compiler/powerpc64/ppcins.dat -text
+compiler/powerpc64/ppcreg.dat -text
+compiler/powerpc64/rappc.pas svneol=native#text/plain
+compiler/powerpc64/rappcgas.pas svneol=native#text/plain
+compiler/powerpc64/rgcpu.pas svneol=native#text/plain
+compiler/powerpc64/rppccon.inc svneol=native#text/plain
+compiler/powerpc64/rppcdwrf.inc svneol=native#text/plain
+compiler/powerpc64/rppcgas.inc svneol=native#text/plain
+compiler/powerpc64/rppcgri.inc svneol=native#text/plain
+compiler/powerpc64/rppcgss.inc svneol=native#text/plain
+compiler/powerpc64/rppcmot.inc svneol=native#text/plain
+compiler/powerpc64/rppcmri.inc svneol=native#text/plain
+compiler/powerpc64/rppcnor.inc svneol=native#text/plain
+compiler/powerpc64/rppcnum.inc svneol=native#text/plain
+compiler/powerpc64/rppcrni.inc svneol=native#text/plain
+compiler/powerpc64/rppcsri.inc svneol=native#text/plain
+compiler/powerpc64/rppcstab.inc svneol=native#text/plain
+compiler/powerpc64/rppcstd.inc svneol=native#text/plain
+compiler/powerpc64/rppcsup.inc svneol=native#text/plain
+compiler/pp.lpi -text
+compiler/pp.pas svneol=native#text/plain
+compiler/ppc.cfg -text
+compiler/ppc.conf -text
+compiler/ppc.dof -text
+compiler/ppc.dpr -text
+compiler/ppheap.pas svneol=native#text/plain
+compiler/ppu.pas svneol=native#text/plain
+compiler/procinfo.pas svneol=native#text/plain
+compiler/pstatmnt.pas svneol=native#text/plain
+compiler/psub.pas svneol=native#text/plain
+compiler/psystem.pas svneol=native#text/plain
+compiler/ptconst.pas svneol=native#text/plain
+compiler/ptype.pas svneol=native#text/plain
+compiler/raatt.pas svneol=native#text/plain
+compiler/rabase.pas svneol=native#text/plain
+compiler/rasm.pas svneol=native#text/plain
+compiler/rautils.pas svneol=native#text/plain
+compiler/regvars.pas svneol=native#text/plain
+compiler/rgbase.pas svneol=native#text/plain
+compiler/rgobj.pas svneol=native#text/plain
+compiler/scandir.pas svneol=native#text/plain
+compiler/scanner.pas svneol=native#text/plain
+compiler/script.pas svneol=native#text/plain
+compiler/sparc/aasmcpu.pas svneol=native#text/plain
+compiler/sparc/aoptcpu.pas svneol=native#text/plain
+compiler/sparc/aoptcpub.pas svneol=native#text/plain
+compiler/sparc/aoptcpud.pas svneol=native#text/plain
+compiler/sparc/cgcpu.pas svneol=native#text/plain
+compiler/sparc/cpubase.pas svneol=native#text/plain
+compiler/sparc/cpugas.pas svneol=native#text/plain
+compiler/sparc/cpuinfo.pas svneol=native#text/plain
+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/cpuswtch.pas svneol=native#text/plain
+compiler/sparc/cputarg.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
+compiler/sparc/ncpucnv.pas svneol=native#text/plain
+compiler/sparc/ncpuinln.pas svneol=native#text/plain
+compiler/sparc/ncpumat.pas svneol=native#text/plain
+compiler/sparc/ncpuset.pas svneol=native#text/plain
+compiler/sparc/opcode.inc svneol=native#text/plain
+compiler/sparc/racpu.pas svneol=native#text/plain
+compiler/sparc/racpugas.pas svneol=native#text/plain
+compiler/sparc/rgcpu.pas svneol=native#text/plain
+compiler/sparc/rspcon.inc svneol=native#text/plain
+compiler/sparc/rspdwrf.inc svneol=native#text/plain
+compiler/sparc/rspnor.inc svneol=native#text/plain
+compiler/sparc/rspnum.inc svneol=native#text/plain
+compiler/sparc/rsprni.inc svneol=native#text/plain
+compiler/sparc/rspsri.inc svneol=native#text/plain
+compiler/sparc/rspstab.inc svneol=native#text/plain
+compiler/sparc/rspstd.inc svneol=native#text/plain
+compiler/sparc/rspsup.inc svneol=native#text/plain
+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/symdef.pas svneol=native#text/plain
+compiler/symnot.pas svneol=native#text/plain
+compiler/symsym.pas svneol=native#text/plain
+compiler/symtable.pas svneol=native#text/plain
+compiler/symtype.pas svneol=native#text/plain
+compiler/symutil.pas svneol=native#text/plain
+compiler/systems.pas svneol=native#text/plain
+compiler/systems/i_amiga.pas svneol=native#text/plain
+compiler/systems/i_atari.pas svneol=native#text/plain
+compiler/systems/i_beos.pas svneol=native#text/plain
+compiler/systems/i_bsd.pas svneol=native#text/plain
+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_linux.pas svneol=native#text/plain
+compiler/systems/i_macos.pas svneol=native#text/plain
+compiler/systems/i_morph.pas svneol=native#text/plain
+compiler/systems/i_nwl.pas svneol=native#text/plain
+compiler/systems/i_nwm.pas svneol=native#text/plain
+compiler/systems/i_os2.pas svneol=native#text/plain
+compiler/systems/i_palmos.pas svneol=native#text/plain
+compiler/systems/i_sunos.pas svneol=native#text/plain
+compiler/systems/i_watcom.pas svneol=native#text/plain
+compiler/systems/i_wdosx.pas svneol=native#text/plain
+compiler/systems/i_win.pas svneol=native#text/plain
+compiler/systems/mac_crea.txt svneol=native#text/plain
+compiler/systems/t_amiga.pas svneol=native#text/plain
+compiler/systems/t_atari.pas svneol=native#text/plain
+compiler/systems/t_beos.pas svneol=native#text/plain
+compiler/systems/t_bsd.pas svneol=native#text/plain
+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_linux.pas svneol=native#text/plain
+compiler/systems/t_macos.pas svneol=native#text/plain
+compiler/systems/t_morph.pas svneol=native#text/plain
+compiler/systems/t_nwl.pas svneol=native#text/plain
+compiler/systems/t_nwm.pas svneol=native#text/plain
+compiler/systems/t_os2.pas svneol=native#text/plain
+compiler/systems/t_palmos.pas svneol=native#text/plain
+compiler/systems/t_sunos.pas svneol=native#text/plain
+compiler/systems/t_watcom.pas svneol=native#text/plain
+compiler/systems/t_wdosx.pas svneol=native#text/plain
+compiler/systems/t_win.pas svneol=native#text/plain
+compiler/tgobj.pas svneol=native#text/plain
+compiler/tokens.pas svneol=native#text/plain
+compiler/utils/Makefile svneol=native#text/plain
+compiler/utils/Makefile.fpc svneol=native#text/plain
+compiler/utils/README -text
+compiler/utils/fixlog.pp svneol=native#text/plain
+compiler/utils/fixmsg.pp svneol=native#text/plain
+compiler/utils/fixnasm.pp svneol=native#text/plain
+compiler/utils/fixtab.pp svneol=native#text/plain
+compiler/utils/fpc.cft svneol=native#text/plain
+compiler/utils/fpc.mpw -text
+compiler/utils/fpc.pp svneol=native#text/plain
+compiler/utils/fpccfg.inc svneol=native#text/plain
+compiler/utils/fpcmkcfg.pp svneol=native#text/plain
+compiler/utils/fpcsubst.pp svneol=native#text/plain
+compiler/utils/fpimpdef.pp svneol=native#text/plain
+compiler/utils/fppkg.pp svneol=native#text/plain
+compiler/utils/gppc386.pp svneol=native#text/plain
+compiler/utils/mk68kreg.pp svneol=native#text/plain
+compiler/utils/mkarmins.pp svneol=native#text/plain
+compiler/utils/mkarmreg.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
+compiler/utils/mkx86ins.pp svneol=native#text/plain
+compiler/utils/mkx86reg.pp svneol=native#text/plain
+compiler/utils/msg2inc.pp svneol=native#text/plain
+compiler/utils/msgdif.pp svneol=native#text/plain
+compiler/utils/msgused.pl -text
+compiler/utils/ppudump.pp svneol=native#text/plain
+compiler/utils/ppufiles.pp svneol=native#text/plain
+compiler/utils/ppumove.pp svneol=native#text/plain
+compiler/utils/samplecfg -text
+compiler/utils/usubst.pp svneol=native#text/plain
+compiler/verbose.pas svneol=native#text/plain
+compiler/version.pas svneol=native#text/plain
+compiler/vis/aasmcpu.pas svneol=native#text/plain
+compiler/vis/cpubase.pas svneol=native#text/plain
+compiler/vis/cpuinfo.pas svneol=native#text/plain
+compiler/vis/cpunode.pas svneol=native#text/plain
+compiler/vis/cpupara.pas svneol=native#text/plain
+compiler/widestr.pas svneol=native#text/plain
+compiler/x86/aasmcpu.pas svneol=native#text/plain
+compiler/x86/agx86att.pas svneol=native#text/plain
+compiler/x86/agx86int.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/itcpugas.pas svneol=native#text/plain
+compiler/x86/itx86int.pas svneol=native#text/plain
+compiler/x86/nx86add.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
+compiler/x86/nx86mat.pas svneol=native#text/plain
+compiler/x86/nx86set.pas svneol=native#text/plain
+compiler/x86/rax86.pas svneol=native#text/plain
+compiler/x86/rax86att.pas svneol=native#text/plain
+compiler/x86/rgx86.pas svneol=native#text/plain
+compiler/x86_64/aoptcpu.pas svneol=native#text/plain
+compiler/x86_64/aoptcpub.pas svneol=native#text/plain
+compiler/x86_64/aoptcpud.pas svneol=native#text/plain
+compiler/x86_64/cgcpu.pas svneol=native#text/plain
+compiler/x86_64/cpubase.inc svneol=native#text/plain
+compiler/x86_64/cpuinfo.pas svneol=native#text/plain
+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/cpuswtch.pas svneol=native#text/plain
+compiler/x86_64/cputarg.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
+compiler/x86_64/nx64inl.pas svneol=native#text/plain
+compiler/x86_64/nx64mat.pas svneol=native#text/plain
+compiler/x86_64/r8664ari.inc svneol=native#text/plain
+compiler/x86_64/r8664att.inc svneol=native#text/plain
+compiler/x86_64/r8664con.inc svneol=native#text/plain
+compiler/x86_64/r8664dwrf.inc svneol=native#text/plain
+compiler/x86_64/r8664int.inc svneol=native#text/plain
+compiler/x86_64/r8664iri.inc svneol=native#text/plain
+compiler/x86_64/r8664nor.inc svneol=native#text/plain
+compiler/x86_64/r8664num.inc svneol=native#text/plain
+compiler/x86_64/r8664op.inc svneol=native#text/plain
+compiler/x86_64/r8664ot.inc svneol=native#text/plain
+compiler/x86_64/r8664rni.inc svneol=native#text/plain
+compiler/x86_64/r8664sri.inc svneol=native#text/plain
+compiler/x86_64/r8664stab.inc svneol=native#text/plain
+compiler/x86_64/r8664std.inc svneol=native#text/plain
+compiler/x86_64/rax64att.pas svneol=native#text/plain
+compiler/x86_64/rgcpu.pas svneol=native#text/plain
+compiler/x86_64/x8664ats.inc svneol=native#text/plain
+compiler/x86_64/x8664att.inc svneol=native#text/plain
+compiler/x86_64/x8664int.inc svneol=native#text/plain
+compiler/x86_64/x8664nop.inc svneol=native#text/plain
+compiler/x86_64/x8664op.inc svneol=native#text/plain
+compiler/x86_64/x8664pro.inc svneol=native#text/plain
+compiler/x86_64/x8664tab.inc svneol=native#text/plain

+ 126 - 0
.gitignore

@@ -0,0 +1,126 @@
+compiler/*.bak
+compiler/*.exe
+compiler/*.o
+compiler/*.ppu
+compiler/*.s
+compiler/alpha/*.bak
+compiler/alpha/*.exe
+compiler/alpha/*.o
+compiler/alpha/*.ppu
+compiler/alpha/*.s
+compiler/alpha/fpcmade.*
+compiler/alpha/units
+compiler/arm/*.bak
+compiler/arm/*.exe
+compiler/arm/*.o
+compiler/arm/*.ppu
+compiler/arm/*.s
+compiler/arm/fpcmade.*
+compiler/arm/units
+compiler/fpcmade.*
+compiler/html/*.bak
+compiler/html/*.exe
+compiler/html/*.o
+compiler/html/*.ppu
+compiler/html/*.s
+compiler/html/fpcmade.*
+compiler/html/i386/*.bak
+compiler/html/i386/*.exe
+compiler/html/i386/*.o
+compiler/html/i386/*.ppu
+compiler/html/i386/*.s
+compiler/html/i386/fpcmade.*
+compiler/html/i386/units
+compiler/html/powerpc/*.bak
+compiler/html/powerpc/*.exe
+compiler/html/powerpc/*.o
+compiler/html/powerpc/*.ppu
+compiler/html/powerpc/*.s
+compiler/html/powerpc/fpcmade.*
+compiler/html/powerpc/units
+compiler/html/units
+compiler/i386/*.bak
+compiler/i386/*.exe
+compiler/i386/*.o
+compiler/i386/*.ppu
+compiler/i386/*.s
+compiler/i386/fpcmade.*
+compiler/i386/units
+compiler/ia64/*.bak
+compiler/ia64/*.exe
+compiler/ia64/*.o
+compiler/ia64/*.ppu
+compiler/ia64/*.s
+compiler/ia64/fpcmade.*
+compiler/ia64/units
+compiler/m68k/*.bak
+compiler/m68k/*.exe
+compiler/m68k/*.o
+compiler/m68k/*.ppu
+compiler/m68k/*.s
+compiler/m68k/fpcmade.*
+compiler/m68k/units
+compiler/mips/*.bak
+compiler/mips/*.exe
+compiler/mips/*.o
+compiler/mips/*.ppu
+compiler/mips/*.s
+compiler/mips/fpcmade.*
+compiler/mips/units
+compiler/msg/*.bak
+compiler/msg/*.exe
+compiler/msg/*.o
+compiler/msg/*.ppu
+compiler/msg/*.s
+compiler/msg/fpcmade.*
+compiler/msg/units
+compiler/powerpc/*.bak
+compiler/powerpc/*.exe
+compiler/powerpc/*.o
+compiler/powerpc/*.ppu
+compiler/powerpc/*.s
+compiler/powerpc/fpcmade.*
+compiler/powerpc/units
+compiler/sparc/*.bak
+compiler/sparc/*.exe
+compiler/sparc/*.o
+compiler/sparc/*.ppu
+compiler/sparc/*.s
+compiler/sparc/fpcmade.*
+compiler/sparc/units
+compiler/systems/*.bak
+compiler/systems/*.exe
+compiler/systems/*.o
+compiler/systems/*.ppu
+compiler/systems/*.s
+compiler/systems/fpcmade.*
+compiler/systems/units
+compiler/units
+compiler/utils/*.bak
+compiler/utils/*.exe
+compiler/utils/*.o
+compiler/utils/*.ppu
+compiler/utils/*.s
+compiler/utils/fpcmade.*
+compiler/utils/units
+compiler/vis/*.bak
+compiler/vis/*.exe
+compiler/vis/*.o
+compiler/vis/*.ppu
+compiler/vis/*.s
+compiler/vis/fpcmade.*
+compiler/vis/units
+compiler/x86/*.bak
+compiler/x86/*.exe
+compiler/x86/*.o
+compiler/x86/*.ppu
+compiler/x86/*.s
+compiler/x86/fpcmade.*
+compiler/x86/units
+compiler/x86_64/*.bak
+compiler/x86_64/*.exe
+compiler/x86_64/*.o
+compiler/x86_64/*.ppu
+compiler/x86_64/*.s
+compiler/x86_64/fpcmade.*
+compiler/x86_64/units

+ 340 - 0
compiler/COPYING

@@ -0,0 +1,340 @@
+		    GNU GENERAL PUBLIC LICENSE
+		       Version 2, June 1991
+
+ Copyright (C) 1989, 1991 Free Software Foundation, Inc.
+                       59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+			    Preamble
+
+  The licenses for most software are designed to take away your
+freedom to share and change it.  By contrast, the GNU General Public
+License is intended to guarantee your freedom to share and change free
+software--to make sure the software is free for all its users.  This
+General Public License applies to most of the Free Software
+Foundation's software and to any other program whose authors commit to
+using it.  (Some other Free Software Foundation software is covered by
+the GNU Library General Public License instead.)  You can apply it to
+your programs, too.
+
+  When we speak of free software, we are referring to freedom, not
+price.  Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+this service if you wish), that you receive source code or can get it
+if you want it, that you can change the software or use pieces of it
+in new free programs; and that you know you can do these things.
+
+  To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if you
+distribute copies of the software, or if you modify it.
+
+  For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must give the recipients all the rights that
+you have.  You must make sure that they, too, receive or can get the
+source code.  And you must show them these terms so they know their
+rights.
+
+  We protect your rights with two steps: (1) copyright the software, and
+(2) offer you this license which gives you legal permission to copy,
+distribute and/or modify the software.
+
+  Also, for each author's protection and ours, we want to make certain
+that everyone understands that there is no warranty for this free
+software.  If the software is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original, so
+that any problems introduced by others will not reflect on the original
+authors' reputations.
+
+  Finally, any free program is threatened constantly by software
+patents.  We wish to avoid the danger that redistributors of a free
+program will individually obtain patent licenses, in effect making the
+program proprietary.  To prevent this, we have made it clear that any
+patent must be licensed for everyone's free use or not licensed at all.
+
+  The precise terms and conditions for copying, distribution and
+modification follow.
+
+		    GNU GENERAL PUBLIC LICENSE
+   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+  0. This License applies to any program or other work which contains
+a notice placed by the copyright holder saying it may be distributed
+under the terms of this General Public License.  The "Program", below,
+refers to any such program or work, and a "work based on the Program"
+means either the Program or any derivative work under copyright law:
+that is to say, a work containing the Program or a portion of it,
+either verbatim or with modifications and/or translated into another
+language.  (Hereinafter, translation is included without limitation in
+the term "modification".)  Each licensee is addressed as "you".
+
+Activities other than copying, distribution and modification are not
+covered by this License; they are outside its scope.  The act of
+running the Program is not restricted, and the output from the Program
+is covered only if its contents constitute a work based on the
+Program (independent of having been made by running the Program).
+Whether that is true depends on what the Program does.
+
+  1. You may copy and distribute verbatim copies of the Program's
+source code as you receive it, in any medium, provided that you
+conspicuously and appropriately publish on each copy an appropriate
+copyright notice and disclaimer of warranty; keep intact all the
+notices that refer to this License and to the absence of any warranty;
+and give any other recipients of the Program a copy of this License
+along with the Program.
+
+You may charge a fee for the physical act of transferring a copy, and
+you may at your option offer warranty protection in exchange for a fee.
+
+  2. You may modify your copy or copies of the Program or any portion
+of it, thus forming a work based on the Program, and copy and
+distribute such modifications or work under the terms of Section 1
+above, provided that you also meet all of these conditions:
+
+    a) You must cause the modified files to carry prominent notices
+    stating that you changed the files and the date of any change.
+
+    b) You must cause any work that you distribute or publish, that in
+    whole or in part contains or is derived from the Program or any
+    part thereof, to be licensed as a whole at no charge to all third
+    parties under the terms of this License.
+
+    c) If the modified program normally reads commands interactively
+    when run, you must cause it, when started running for such
+    interactive use in the most ordinary way, to print or display an
+    announcement including an appropriate copyright notice and a
+    notice that there is no warranty (or else, saying that you provide
+    a warranty) and that users may redistribute the program under
+    these conditions, and telling the user how to view a copy of this
+    License.  (Exception: if the Program itself is interactive but
+    does not normally print such an announcement, your work based on
+    the Program is not required to print an announcement.)
+
+These requirements apply to the modified work as a whole.  If
+identifiable sections of that work are not derived from the Program,
+and can be reasonably considered independent and separate works in
+themselves, then this License, and its terms, do not apply to those
+sections when you distribute them as separate works.  But when you
+distribute the same sections as part of a whole which is a work based
+on the Program, the distribution of the whole must be on the terms of
+this License, whose permissions for other licensees extend to the
+entire whole, and thus to each and every part regardless of who wrote it.
+
+Thus, it is not the intent of this section to claim rights or contest
+your rights to work written entirely by you; rather, the intent is to
+exercise the right to control the distribution of derivative or
+collective works based on the Program.
+
+In addition, mere aggregation of another work not based on the Program
+with the Program (or with a work based on the Program) on a volume of
+a storage or distribution medium does not bring the other work under
+the scope of this License.
+
+  3. You may copy and distribute the Program (or a work based on it,
+under Section 2) in object code or executable form under the terms of
+Sections 1 and 2 above provided that you also do one of the following:
+
+    a) Accompany it with the complete corresponding machine-readable
+    source code, which must be distributed under the terms of Sections
+    1 and 2 above on a medium customarily used for software interchange; or,
+
+    b) Accompany it with a written offer, valid for at least three
+    years, to give any third party, for a charge no more than your
+    cost of physically performing source distribution, a complete
+    machine-readable copy of the corresponding source code, to be
+    distributed under the terms of Sections 1 and 2 above on a medium
+    customarily used for software interchange; or,
+
+    c) Accompany it with the information you received as to the offer
+    to distribute corresponding source code.  (This alternative is
+    allowed only for noncommercial distribution and only if you
+    received the program in object code or executable form with such
+    an offer, in accord with Subsection b above.)
+
+The source code for a work means the preferred form of the work for
+making modifications to it.  For an executable work, complete source
+code means all the source code for all modules it contains, plus any
+associated interface definition files, plus the scripts used to
+control compilation and installation of the executable.  However, as a
+special exception, the source code distributed need not include
+anything that is normally distributed (in either source or binary
+form) with the major components (compiler, kernel, and so on) of the
+operating system on which the executable runs, unless that component
+itself accompanies the executable.
+
+If distribution of executable or object code is made by offering
+access to copy from a designated place, then offering equivalent
+access to copy the source code from the same place counts as
+distribution of the source code, even though third parties are not
+compelled to copy the source along with the object code.
+
+  4. You may not copy, modify, sublicense, or distribute the Program
+except as expressly provided under this License.  Any attempt
+otherwise to copy, modify, sublicense or distribute the Program is
+void, and will automatically terminate your rights under this License.
+However, parties who have received copies, or rights, from you under
+this License will not have their licenses terminated so long as such
+parties remain in full compliance.
+
+  5. You are not required to accept this License, since you have not
+signed it.  However, nothing else grants you permission to modify or
+distribute the Program or its derivative works.  These actions are
+prohibited by law if you do not accept this License.  Therefore, by
+modifying or distributing the Program (or any work based on the
+Program), you indicate your acceptance of this License to do so, and
+all its terms and conditions for copying, distributing or modifying
+the Program or works based on it.
+
+  6. Each time you redistribute the Program (or any work based on the
+Program), the recipient automatically receives a license from the
+original licensor to copy, distribute or modify the Program subject to
+these terms and conditions.  You may not impose any further
+restrictions on the recipients' exercise of the rights granted herein.
+You are not responsible for enforcing compliance by third parties to
+this License.
+
+  7. If, as a consequence of a court judgment or allegation of patent
+infringement or for any other reason (not limited to patent issues),
+conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License.  If you cannot
+distribute so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you
+may not distribute the Program at all.  For example, if a patent
+license would not permit royalty-free redistribution of the Program by
+all those who receive copies directly or indirectly through you, then
+the only way you could satisfy both it and this License would be to
+refrain entirely from distribution of the Program.
+
+If any portion of this section is held invalid or unenforceable under
+any particular circumstance, the balance of the section is intended to
+apply and the section as a whole is intended to apply in other
+circumstances.
+
+It is not the purpose of this section to induce you to infringe any
+patents or other property right claims or to contest validity of any
+such claims; this section has the sole purpose of protecting the
+integrity of the free software distribution system, which is
+implemented by public license practices.  Many people have made
+generous contributions to the wide range of software distributed
+through that system in reliance on consistent application of that
+system; it is up to the author/donor to decide if he or she is willing
+to distribute software through any other system and a licensee cannot
+impose that choice.
+
+This section is intended to make thoroughly clear what is believed to
+be a consequence of the rest of this License.
+
+  8. If the distribution and/or use of the Program is restricted in
+certain countries either by patents or by copyrighted interfaces, the
+original copyright holder who places the Program under this License
+may add an explicit geographical distribution limitation excluding
+those countries, so that distribution is permitted only in or among
+countries not thus excluded.  In such case, this License incorporates
+the limitation as if written in the body of this License.
+
+  9. The Free Software Foundation may publish revised and/or new versions
+of the General Public License from time to time.  Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+Each version is given a distinguishing version number.  If the Program
+specifies a version number of this License which applies to it and "any
+later version", you have the option of following the terms and conditions
+either of that version or of any later version published by the Free
+Software Foundation.  If the Program does not specify a version number of
+this License, you may choose any version ever published by the Free Software
+Foundation.
+
+  10. If you wish to incorporate parts of the Program into other free
+programs whose distribution conditions are different, write to the author
+to ask for permission.  For software which is copyrighted by the Free
+Software Foundation, write to the Free Software Foundation; we sometimes
+make exceptions for this.  Our decision will be guided by the two goals
+of preserving the free status of all derivatives of our free software and
+of promoting the sharing and reuse of software generally.
+
+			    NO WARRANTY
+
+  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS
+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE
+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
+REPAIR OR CORRECTION.
+
+  12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGES.
+
+		     END OF TERMS AND CONDITIONS
+
+	    How to Apply These Terms to Your New Programs
+
+  If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+  To do so, attach the following notices to the program.  It is safest
+to attach them to the start of each source file to most effectively
+convey the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+    <one line to give the program's name and a brief idea of what it does.>
+    Copyright (C) <year>  <name of author>
+
+    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., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+    Gnomovision version 69, Copyright (C) year name of author
+    Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+    This is free software, and you are welcome to redistribute it
+    under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License.  Of course, the commands you use may
+be called something other than `show w' and `show c'; they could even be
+mouse-clicks or menu items--whatever suits your program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary.  Here is a sample; alter the names:
+
+  Yoyodyne, Inc., hereby disclaims all copyright interest in the program
+  `Gnomovision' (which makes passes at compilers) written by James Hacker.
+
+  <signature of Ty Coon>, 1 April 1989
+  Ty Coon, President of Vice
+
+This General Public License does not permit incorporating your program into
+proprietary programs.  If your program is a subroutine library, you may
+consider it more useful to permit linking proprietary applications with the
+library.  If this is what you want to do, use the GNU Library General
+Public License instead of this License.

Filskillnaden har hållts tillbaka eftersom den är för stor
+ 0 - 0
compiler/MPWMake


+ 2785 - 0
compiler/Makefile

@@ -0,0 +1,2785 @@
+#
+# Don't edit, this file is generated by FPCMake Version 2.0.0 [2005/10/20]
+#
+default: all
+MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-emx i386-watcom i386-netwlibc i386-wince m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos powerpc-linux powerpc-netbsd powerpc-macos powerpc-darwin powerpc-morphos sparc-linux sparc-netbsd sparc-solaris x86_64-linux x86_64-freebsd x86_64-win64 arm-linux arm-wince powerpc64-linux
+BSDs = freebsd netbsd openbsd darwin
+UNIXs = linux $(BSDs) solaris qnx
+LIMIT83fs = go32v2 os2 emx watcom
+FORCE:
+.PHONY: FORCE
+override PATH:=$(patsubst %/,%,$(subst \,/,$(PATH)))
+ifneq ($(findstring darwin,$(OSTYPE)),)
+inUnix=1 #darwin
+SEARCHPATH:=$(filter-out .,$(subst :, ,$(PATH)))
+else
+ifeq ($(findstring ;,$(PATH)),)
+inUnix=1
+SEARCHPATH:=$(filter-out .,$(subst :, ,$(PATH)))
+else
+SEARCHPATH:=$(subst ;, ,$(PATH))
+endif
+endif
+SEARCHPATH+=$(patsubst %/,%,$(subst \,/,$(dir $(MAKE))))
+PWD:=$(strip $(wildcard $(addsuffix /pwd.exe,$(SEARCHPATH))))
+ifeq ($(PWD),)
+PWD:=$(strip $(wildcard $(addsuffix /pwd,$(SEARCHPATH))))
+ifeq ($(PWD),)
+$(error You need the GNU utils package to use this Makefile)
+else
+PWD:=$(firstword $(PWD))
+SRCEXEEXT=
+endif
+else
+PWD:=$(firstword $(PWD))
+SRCEXEEXT=.exe
+endif
+ifndef inUnix
+ifeq ($(OS),Windows_NT)
+inWinNT=1
+else
+ifdef OS2_SHELL
+inOS2=1
+endif
+endif
+else
+ifneq ($(findstring cygdrive,$(PATH)),)
+inCygWin=1
+endif
+endif
+ifdef inUnix
+SRCBATCHEXT=.sh
+else
+ifdef inOS2
+SRCBATCHEXT=.cmd
+else
+SRCBATCHEXT=.bat
+endif
+endif
+ifdef inUnix
+PATHSEP=/
+else
+PATHSEP:=$(subst /,\,/)
+ifdef inCygWin
+PATHSEP=/
+endif
+endif
+ifdef PWD
+BASEDIR:=$(subst \,/,$(shell $(PWD)))
+ifdef inCygWin
+ifneq ($(findstring /cygdrive/,$(BASEDIR)),)
+BASENODIR:=$(patsubst /cygdrive%,%,$(BASEDIR))
+BASEDRIVE:=$(firstword $(subst /, ,$(BASENODIR)))
+BASEDIR:=$(subst /cygdrive/$(BASEDRIVE)/,$(BASEDRIVE):/,$(BASEDIR))
+endif
+endif
+else
+BASEDIR=.
+endif
+ifdef inOS2
+ifndef ECHO
+ECHO:=$(strip $(wildcard $(addsuffix /gecho$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(ECHO),)
+ECHO:=$(strip $(wildcard $(addsuffix /echo$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(ECHO),)
+ECHO=echo
+else
+ECHO:=$(firstword $(ECHO))
+endif
+else
+ECHO:=$(firstword $(ECHO))
+endif
+endif
+export ECHO
+endif
+override DEFAULT_FPCDIR=..
+ifndef FPC
+ifdef PP
+FPC=$(PP)
+endif
+endif
+ifndef FPC
+FPCPROG:=$(strip $(wildcard $(addsuffix /fpc$(SRCEXEEXT),$(SEARCHPATH))))
+ifneq ($(FPCPROG),)
+FPCPROG:=$(firstword $(FPCPROG))
+FPC:=$(shell $(FPCPROG) -PB)
+ifneq ($(findstring Error,$(FPC)),)
+override FPC=$(firstword $(strip $(wildcard $(addsuffix /ppc386$(SRCEXEEXT),$(SEARCHPATH)))))
+endif
+else
+override FPC=$(firstword $(strip $(wildcard $(addsuffix /ppc386$(SRCEXEEXT),$(SEARCHPATH)))))
+endif
+endif
+override FPC:=$(subst $(SRCEXEEXT),,$(FPC))
+override FPC:=$(subst \,/,$(FPC))$(SRCEXEEXT)
+FOUNDFPC:=$(strip $(wildcard $(FPC)))
+ifeq ($(FOUNDFPC),)
+FOUNDFPC=$(strip $(wildcard $(addsuffix /$(FPC),$(SEARCHPATH))))
+ifeq ($(FOUNDFPC),)
+$(error Compiler $(FPC) not found)
+endif
+endif
+ifndef FPC_COMPILERINFO
+FPC_COMPILERINFO:=$(shell $(FPC) -iVSPTPSOTO)
+endif
+ifndef FPC_VERSION
+FPC_VERSION:=$(word 1,$(FPC_COMPILERINFO))
+endif
+export FPC FPC_VERSION FPC_COMPILERINFO
+unexport CHECKDEPEND ALLDEPENDENCIES
+ifndef CPU_TARGET
+ifdef CPU_TARGET_DEFAULT
+CPU_TARGET=$(CPU_TARGET_DEFAULT)
+endif
+endif
+ifndef OS_TARGET
+ifdef OS_TARGET_DEFAULT
+OS_TARGET=$(OS_TARGET_DEFAULT)
+endif
+endif
+ifneq ($(words $(FPC_COMPILERINFO)),5)
+FPC_COMPILERINFO+=$(shell $(FPC) -iSP)
+FPC_COMPILERINFO+=$(shell $(FPC) -iTP)
+FPC_COMPILERINFO+=$(shell $(FPC) -iSO)
+FPC_COMPILERINFO+=$(shell $(FPC) -iTO)
+endif
+ifndef CPU_SOURCE
+CPU_SOURCE:=$(word 2,$(FPC_COMPILERINFO))
+endif
+ifndef CPU_TARGET
+CPU_TARGET:=$(word 3,$(FPC_COMPILERINFO))
+endif
+ifndef OS_SOURCE
+OS_SOURCE:=$(word 4,$(FPC_COMPILERINFO))
+endif
+ifndef OS_TARGET
+OS_TARGET:=$(word 5,$(FPC_COMPILERINFO))
+endif
+FULL_TARGET=$(CPU_TARGET)-$(OS_TARGET)
+FULL_SOURCE=$(CPU_SOURCE)-$(OS_SOURCE)
+ifneq ($(findstring $(OS_SOURCE),$(LIMIT83fs)),)
+TARGETSUFFIX=$(OS_TARGET)
+SOURCESUFFIX=$(OS_SOURCE)
+else
+TARGETSUFFIX=$(FULL_TARGET)
+SOURCESUFFIX=$(FULL_SOURCE)
+endif
+ifneq ($(FULL_TARGET),$(FULL_SOURCE))
+CROSSCOMPILE=1
+endif
+ifeq ($(findstring makefile,$(MAKECMDGOALS)),)
+ifeq ($(findstring $(FULL_TARGET),$(MAKEFILETARGETS)),)
+$(error The Makefile doesn't support target $(FULL_TARGET), please run fpcmake first)
+endif
+endif
+ifneq ($(findstring $(OS_TARGET),$(BSDs)),)
+BSDhier=1
+endif
+ifeq ($(OS_TARGET),linux)
+linuxHier=1
+endif
+export OS_TARGET OS_SOURCE CPU_TARGET CPU_SOURCE FULL_TARGET FULL_SOURCE TARGETSUFFIX SOURCESUFFIX CROSSCOMPILE
+ifdef FPCDIR
+override FPCDIR:=$(subst \,/,$(FPCDIR))
+ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),)
+override FPCDIR=wrong
+endif
+else
+override FPCDIR=wrong
+endif
+ifdef DEFAULT_FPCDIR
+ifeq ($(FPCDIR),wrong)
+override FPCDIR:=$(subst \,/,$(DEFAULT_FPCDIR))
+ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),)
+override FPCDIR=wrong
+endif
+endif
+endif
+ifeq ($(FPCDIR),wrong)
+ifdef inUnix
+override FPCDIR=/usr/local/lib/fpc/$(FPC_VERSION)
+ifeq ($(wildcard $(FPCDIR)/units),)
+override FPCDIR=/usr/lib/fpc/$(FPC_VERSION)
+endif
+else
+override FPCDIR:=$(subst /$(FPC),,$(firstword $(strip $(wildcard $(addsuffix /$(FPC),$(SEARCHPATH))))))
+override FPCDIR:=$(FPCDIR)/..
+ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),)
+override FPCDIR:=$(FPCDIR)/..
+ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),)
+override FPCDIR:=$(BASEDIR)
+ifeq ($(wildcard $(addprefix $(FPCDIR)/,rtl units)),)
+override FPCDIR=c:/pp
+endif
+endif
+endif
+endif
+endif
+ifndef CROSSBINDIR
+CROSSBINDIR:=$(wildcard $(FPCDIR)/bin/$(TARGETSUFFIX))
+endif
+ifndef BINUTILSPREFIX
+ifndef CROSSBINDIR
+ifdef CROSSCOMPILE
+BINUTILSPREFIX=$(CPU_TARGET)-$(OS_TARGET)-
+endif
+endif
+endif
+UNITSDIR:=$(wildcard $(FPCDIR)/units/$(TARGETSUFFIX))
+ifeq ($(UNITSDIR),)
+UNITSDIR:=$(wildcard $(FPCDIR)/units/$(OS_TARGET))
+endif
+PACKAGESDIR:=$(wildcard $(FPCDIR) $(FPCDIR)/packages/base $(FPCDIR)/packages/extra)
+override PACKAGE_NAME=compiler
+override PACKAGE_VERSION=2.0.0
+unexport FPC_VERSION FPC_COMPILERINFO
+CYCLETARGETS=i386 powerpc sparc arm x86_64 powerpc64
+ALLTARGETS=$(CYCLETARGETS) m68k
+ifdef ALPHA
+PPC_TARGET=alpha
+endif
+ifdef POWERPC
+PPC_TARGET=powerpc
+endif
+ifdef POWERPC64
+PPC_TARGET=powerpc64
+endif
+ifdef SPARC
+PPC_TARGET=sparc
+endif
+ifdef M68K
+PPC_TARGET=m68k
+endif
+ifdef I386
+PPC_TARGET=i386
+endif
+ifdef X86_64
+PPC_TARGET=x86_64
+endif
+ifdef ARM
+PPC_TARGET=arm
+endif
+ifndef PPC_TARGET
+PPC_TARGET=$(CPU_TARGET)
+endif
+ifndef PPC_OS
+PPC_OS=$(OS_TARGET)
+endif
+CPU_UNITDIR=$(PPC_TARGET)
+UTILSDIR=../utils
+COMPILERSOURCEDIR=$(PPC_TARGET) systems
+COMPILERUTILSDIR=utils
+ifndef FPCLANG
+FPCLANG=e
+endif
+ifndef LOCALOPT
+LOCALOPT:=$(OPT)
+endif
+ifndef RTLOPT
+RTLOPT:=$(OPT)
+endif
+override OPT=
+MSGFILES=$(wildcard msg/error*.msg)
+ifeq ($(PPC_TARGET),i386)
+CPUSUF=386
+endif
+ifeq ($(PPC_TARGET),alpha)
+CPUSUF=axp
+endif
+ifeq ($(PPC_TARGET),m68k)
+CPUSUF=68k
+endif
+ifeq ($(PPC_TARGET),powerpc)
+CPUSUF=ppc
+endif
+ifeq ($(PPC_TARGET),powerpc64)
+CPUSUF=ppc64
+endif
+ifeq ($(PPC_TARGET),sparc)
+CPUSUF=sparc
+endif
+ifeq ($(PPC_TARGET),x86_64)
+CPUSUF=x64
+endif
+ifeq ($(PPC_TARGET),arm)
+CPUSUF=arm
+endif
+NOCPUDEF=1
+MSGFILE=msg/error$(FPCLANG).msg
+ifeq ($(OS_TARGET),linux)
+ifneq ($(findstring 1.0.,$(FPC_VERSION)),)
+override LOCALOPT+=-dUNIX
+endif
+endif
+ifeq ($(OS_TARGET),freebsd)
+ifneq ($(findstring 1.0.,$(FPC_VERSION)),)
+override LOCALOPT+=-dUNIX
+endif
+endif
+override LOCALOPT+=-d$(PPC_TARGET) -dGDB -dBROWSERLOG
+ifeq ($(PPC_TARGET),i386)
+override LOCALOPT+=-Fux86
+endif
+ifeq ($(PPC_TARGET),x86_64)
+override LOCALOPT+=-Fux86
+endif
+ifeq ($(PPC_TARGET),powerpc)
+override LOCALOPT+=
+endif
+ifeq ($(PPC_TARGET),m68k)
+override LOCALOPT+=-dNOOPT
+endif
+ifeq ($(PPC_TARGET),sparc)
+override LOCALOPT+=
+endif
+ifeq ($(PPC_TARGET),m68k)
+ifeq ($(OS_TARGET),amiga)
+override LOCALOPT+=-Ct
+endif
+endif
+ifeq ($(PPC_TARGET),arm)
+override LOCALOPT+=-dNOOPT
+endif
+ifeq ($(FULL_TARGET),i386-linux)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),i386-go32v2)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),i386-win32)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),i386-os2)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),i386-freebsd)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),i386-beos)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),i386-netbsd)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),i386-solaris)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),i386-qnx)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),i386-netware)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),i386-openbsd)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),i386-wdosx)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),i386-emx)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),i386-watcom)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),i386-netwlibc)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),i386-wince)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),m68k-linux)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),m68k-freebsd)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),m68k-netbsd)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),m68k-amiga)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),m68k-atari)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),m68k-openbsd)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),m68k-palmos)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),powerpc-linux)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),powerpc-netbsd)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),powerpc-macos)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),powerpc-darwin)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),powerpc-morphos)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),sparc-linux)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),sparc-netbsd)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),sparc-solaris)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),x86_64-linux)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),x86_64-freebsd)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),x86_64-win64)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),arm-linux)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),arm-wince)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),powerpc64-linux)
+override TARGET_DIRS+=utils
+endif
+ifeq ($(FULL_TARGET),i386-linux)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),i386-go32v2)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),i386-win32)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),i386-os2)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),i386-freebsd)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),i386-beos)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),i386-netbsd)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),i386-solaris)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),i386-qnx)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),i386-netware)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),i386-openbsd)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),i386-wdosx)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),i386-emx)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),i386-watcom)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),i386-netwlibc)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),i386-wince)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),m68k-linux)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),m68k-freebsd)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),m68k-netbsd)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),m68k-amiga)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),m68k-atari)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),m68k-openbsd)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),m68k-palmos)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),powerpc-linux)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),powerpc-netbsd)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),powerpc-macos)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),powerpc-darwin)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),powerpc-morphos)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),sparc-linux)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),sparc-netbsd)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),sparc-solaris)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),x86_64-linux)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),x86_64-freebsd)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),x86_64-win64)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),arm-linux)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),arm-wince)
+override TARGET_PROGRAMS+=pp
+endif
+ifeq ($(FULL_TARGET),powerpc64-linux)
+override TARGET_PROGRAMS+=pp
+endif
+override INSTALL_FPCPACKAGE=y
+ifeq ($(FULL_TARGET),i386-linux)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),i386-go32v2)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),i386-win32)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),i386-os2)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),i386-freebsd)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),i386-beos)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),i386-netbsd)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),i386-solaris)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),i386-qnx)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),i386-netware)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),i386-openbsd)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),i386-wdosx)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),i386-emx)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),i386-watcom)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),i386-netwlibc)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),i386-wince)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),m68k-linux)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),m68k-freebsd)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),m68k-netbsd)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),m68k-amiga)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),m68k-atari)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),m68k-openbsd)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),m68k-palmos)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),powerpc-linux)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),powerpc-netbsd)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),powerpc-macos)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),powerpc-darwin)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),powerpc-morphos)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),sparc-linux)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),sparc-netbsd)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),sparc-solaris)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),x86_64-linux)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),x86_64-freebsd)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),x86_64-win64)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),arm-linux)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),arm-wince)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),powerpc64-linux)
+override COMPILER_INCLUDEDIR+=$(PPC_TARGET)
+endif
+ifeq ($(FULL_TARGET),i386-linux)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),i386-go32v2)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),i386-win32)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),i386-os2)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),i386-freebsd)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),i386-beos)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),i386-netbsd)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),i386-solaris)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),i386-qnx)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),i386-netware)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),i386-openbsd)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),i386-wdosx)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),i386-emx)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),i386-watcom)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),i386-netwlibc)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),i386-wince)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),m68k-linux)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),m68k-freebsd)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),m68k-netbsd)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),m68k-amiga)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),m68k-atari)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),m68k-openbsd)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),m68k-palmos)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),powerpc-linux)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),powerpc-netbsd)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),powerpc-macos)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),powerpc-darwin)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),powerpc-morphos)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),sparc-linux)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),sparc-netbsd)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),sparc-solaris)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),x86_64-linux)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),x86_64-freebsd)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),x86_64-win64)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),arm-linux)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),arm-wince)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),powerpc64-linux)
+override COMPILER_UNITDIR+=$(COMPILERSOURCEDIR)
+endif
+ifeq ($(FULL_TARGET),i386-linux)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),i386-go32v2)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),i386-win32)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),i386-os2)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),i386-freebsd)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),i386-beos)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),i386-netbsd)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),i386-solaris)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),i386-qnx)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),i386-netware)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),i386-openbsd)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),i386-wdosx)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),i386-emx)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),i386-watcom)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),i386-netwlibc)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),i386-wince)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),m68k-linux)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),m68k-freebsd)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),m68k-netbsd)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),m68k-amiga)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),m68k-atari)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),m68k-openbsd)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),m68k-palmos)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),powerpc-linux)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),powerpc-netbsd)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),powerpc-macos)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),powerpc-darwin)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),powerpc-morphos)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),sparc-linux)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),sparc-netbsd)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),sparc-solaris)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),x86_64-linux)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),x86_64-freebsd)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),x86_64-win64)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),arm-linux)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),arm-wince)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),powerpc64-linux)
+override COMPILER_TARGETDIR+=.
+endif
+ifeq ($(FULL_TARGET),i386-linux)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),i386-go32v2)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),i386-win32)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),i386-os2)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),i386-freebsd)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),i386-beos)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),i386-netbsd)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),i386-solaris)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),i386-qnx)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),i386-netware)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),i386-openbsd)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),i386-wdosx)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),i386-emx)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),i386-watcom)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),i386-netwlibc)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),i386-wince)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),m68k-linux)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),m68k-freebsd)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),m68k-netbsd)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),m68k-amiga)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),m68k-atari)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),m68k-openbsd)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),m68k-palmos)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),powerpc-linux)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),powerpc-netbsd)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),powerpc-macos)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),powerpc-darwin)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),powerpc-morphos)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),sparc-linux)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),sparc-netbsd)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),sparc-solaris)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),x86_64-linux)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),x86_64-freebsd)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),x86_64-win64)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),arm-linux)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),arm-wince)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifeq ($(FULL_TARGET),powerpc64-linux)
+override COMPILER_UNITTARGETDIR+=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+endif
+ifdef REQUIRE_UNITSDIR
+override UNITSDIR+=$(REQUIRE_UNITSDIR)
+endif
+ifdef REQUIRE_PACKAGESDIR
+override PACKAGESDIR+=$(REQUIRE_PACKAGESDIR)
+endif
+ifdef ZIPINSTALL
+ifneq ($(findstring $(OS_TARGET),$(UNIXs)),)
+UNIXHier=1
+endif
+else
+ifneq ($(findstring $(OS_SOURCE),$(UNIXs)),)
+UNIXHier=1
+endif
+endif
+ifndef INSTALL_PREFIX
+ifdef PREFIX
+INSTALL_PREFIX=$(PREFIX)
+endif
+endif
+ifndef INSTALL_PREFIX
+ifdef UNIXHier
+INSTALL_PREFIX=/usr/local
+else
+ifdef INSTALL_FPCPACKAGE
+INSTALL_BASEDIR:=/pp
+else
+INSTALL_BASEDIR:=/$(PACKAGE_NAME)
+endif
+endif
+endif
+export INSTALL_PREFIX
+ifdef INSTALL_FPCSUBDIR
+export INSTALL_FPCSUBDIR
+endif
+ifndef DIST_DESTDIR
+DIST_DESTDIR:=$(BASEDIR)
+endif
+export DIST_DESTDIR
+ifndef COMPILER_UNITTARGETDIR
+ifdef PACKAGEDIR_MAIN
+COMPILER_UNITTARGETDIR=$(PACKAGEDIR_MAIN)/units/$(TARGETSUFFIX)
+else
+COMPILER_UNITTARGETDIR=units/$(TARGETSUFFIX)
+endif
+endif
+ifndef COMPILER_TARGETDIR
+COMPILER_TARGETDIR=.
+endif
+ifndef INSTALL_BASEDIR
+ifdef UNIXHier
+ifdef INSTALL_FPCPACKAGE
+INSTALL_BASEDIR:=$(INSTALL_PREFIX)/lib/fpc/$(FPC_VERSION)
+else
+INSTALL_BASEDIR:=$(INSTALL_PREFIX)/lib/$(PACKAGE_NAME)
+endif
+else
+INSTALL_BASEDIR:=$(INSTALL_PREFIX)
+endif
+endif
+ifndef INSTALL_BINDIR
+ifdef UNIXHier
+INSTALL_BINDIR:=$(INSTALL_PREFIX)/bin
+else
+INSTALL_BINDIR:=$(INSTALL_BASEDIR)/bin
+ifdef INSTALL_FPCPACKAGE
+ifdef CROSSCOMPILE
+ifdef CROSSINSTALL
+INSTALL_BINDIR:=$(INSTALL_BINDIR)/$(SOURCESUFFIX)
+else
+INSTALL_BINDIR:=$(INSTALL_BINDIR)/$(TARGETSUFFIX)
+endif
+else
+INSTALL_BINDIR:=$(INSTALL_BINDIR)/$(TARGETSUFFIX)
+endif
+endif
+endif
+endif
+ifndef INSTALL_UNITDIR
+INSTALL_UNITDIR:=$(INSTALL_BASEDIR)/units/$(TARGETSUFFIX)
+ifdef INSTALL_FPCPACKAGE
+ifdef PACKAGE_NAME
+INSTALL_UNITDIR:=$(INSTALL_UNITDIR)/$(PACKAGE_NAME)
+endif
+endif
+endif
+ifndef INSTALL_LIBDIR
+ifdef UNIXHier
+INSTALL_LIBDIR:=$(INSTALL_PREFIX)/lib
+else
+INSTALL_LIBDIR:=$(INSTALL_UNITDIR)
+endif
+endif
+ifndef INSTALL_SOURCEDIR
+ifdef UNIXHier
+ifdef BSDhier
+SRCPREFIXDIR=share/src
+else
+ifdef linuxHier
+SRCPREFIXDIR=share/src
+else
+SRCPREFIXDIR=src
+endif
+endif
+ifdef INSTALL_FPCPACKAGE
+ifdef INSTALL_FPCSUBDIR
+INSTALL_SOURCEDIR:=$(INSTALL_PREFIX)/$(SRCPREFIXDIR)/fpc-$(FPC_VERSION)/$(INSTALL_FPCSUBDIR)/$(PACKAGE_NAME)
+else
+INSTALL_SOURCEDIR:=$(INSTALL_PREFIX)/$(SRCPREFIXDIR)/fpc-$(FPC_VERSION)/$(PACKAGE_NAME)
+endif
+else
+INSTALL_SOURCEDIR:=$(INSTALL_PREFIX)/$(SRCPREFIXDIR)/$(PACKAGE_NAME)-$(PACKAGE_VERSION)
+endif
+else
+ifdef INSTALL_FPCPACKAGE
+ifdef INSTALL_FPCSUBDIR
+INSTALL_SOURCEDIR:=$(INSTALL_BASEDIR)/source/$(INSTALL_FPCSUBDIR)/$(PACKAGE_NAME)
+else
+INSTALL_SOURCEDIR:=$(INSTALL_BASEDIR)/source/$(PACKAGE_NAME)
+endif
+else
+INSTALL_SOURCEDIR:=$(INSTALL_BASEDIR)/source
+endif
+endif
+endif
+ifndef INSTALL_DOCDIR
+ifdef UNIXHier
+ifdef BSDhier
+DOCPREFIXDIR=share/doc
+else
+ifdef linuxHier
+DOCPREFIXDIR=share/doc
+else
+DOCPREFIXDIR=doc
+endif
+endif
+ifdef INSTALL_FPCPACKAGE
+INSTALL_DOCDIR:=$(INSTALL_PREFIX)/$(DOCPREFIXDIR)/fpc-$(FPC_VERSION)/$(PACKAGE_NAME)
+else
+INSTALL_DOCDIR:=$(INSTALL_PREFIX)/$(DOCPREFIXDIR)/$(PACKAGE_NAME)-$(PACKAGE_VERSION)
+endif
+else
+ifdef INSTALL_FPCPACKAGE
+INSTALL_DOCDIR:=$(INSTALL_BASEDIR)/doc/$(PACKAGE_NAME)
+else
+INSTALL_DOCDIR:=$(INSTALL_BASEDIR)/doc
+endif
+endif
+endif
+ifndef INSTALL_EXAMPLEDIR
+ifdef UNIXHier
+ifdef INSTALL_FPCPACKAGE
+ifdef BSDhier
+INSTALL_EXAMPLEDIR:=$(INSTALL_PREFIX)/share/examples/fpc-$(FPC_VERSION)/$(PACKAGE_NAME)
+else
+ifdef linuxHier
+INSTALL_EXAMPLEDIR:=$(INSTALL_DOCDIR)/examples
+else
+INSTALL_EXAMPLEDIR:=$(INSTALL_PREFIX)/doc/fpc-$(FPC_VERSION)/examples/$(PACKAGE_NAME)
+endif
+endif
+else
+ifdef BSDhier
+INSTALL_EXAMPLEDIR:=$(INSTALL_PREFIX)/share/examples/$(PACKAGE_NAME)-$(PACKAGE_VERSION)
+else
+ifdef linuxHier
+INSTALL_EXAMPLEDIR:=$(INSTALL_DOCDIR)/examples/$(PACKAGE_NAME)-$(PACKAGE_VERSION)
+else
+INSTALL_EXAMPLEDIR:=$(INSTALL_PREFIX)/doc/$(PACKAGE_NAME)-$(PACKAGE_VERSION)
+endif
+endif
+endif
+else
+ifdef INSTALL_FPCPACKAGE
+INSTALL_EXAMPLEDIR:=$(INSTALL_BASEDIR)/examples/$(PACKAGE_NAME)
+else
+INSTALL_EXAMPLEDIR:=$(INSTALL_BASEDIR)/examples
+endif
+endif
+endif
+ifndef INSTALL_DATADIR
+INSTALL_DATADIR=$(INSTALL_BASEDIR)
+endif
+ifdef CROSSCOMPILE
+ifndef CROSSBINDIR
+CROSSBINDIR:=$(wildcard $(CROSSTARGETDIR)/bin/$(SOURCESUFFIX))
+ifeq ($(CROSSBINDIR),)
+CROSSBINDIR:=$(wildcard $(INSTALL_BASEDIR)/cross/$(TARGETSUFFIX)/bin/$(FULL_SOURCE))
+endif
+endif
+else
+CROSSBINDIR=
+endif
+BATCHEXT=.bat
+LOADEREXT=.as
+EXEEXT=.exe
+PPLEXT=.ppl
+PPUEXT=.ppu
+OEXT=.o
+ASMEXT=.s
+SMARTEXT=.sl
+STATICLIBEXT=.a
+SHAREDLIBEXT=.so
+STATICLIBPREFIX=libp
+RSTEXT=.rst
+ifeq ($(findstring 1.0.,$(FPC_VERSION)),)
+ifeq ($(OS_TARGET),go32v1)
+STATICLIBPREFIX=
+SHORTSUFFIX=v1
+endif
+ifeq ($(OS_TARGET),go32v2)
+STATICLIBPREFIX=
+SHORTSUFFIX=dos
+endif
+ifeq ($(OS_TARGET),watcom)
+STATICLIBPREFIX=
+OEXT=.obj
+ASMEXT=.asm
+SHAREDLIBEXT=.dll
+SHORTSUFFIX=wat
+endif
+ifeq ($(OS_TARGET),linux)
+BATCHEXT=.sh
+EXEEXT=
+HASSHAREDLIB=1
+SHORTSUFFIX=lnx
+endif
+ifeq ($(OS_TARGET),freebsd)
+BATCHEXT=.sh
+EXEEXT=
+HASSHAREDLIB=1
+SHORTSUFFIX=fbs
+endif
+ifeq ($(OS_TARGET),netbsd)
+BATCHEXT=.sh
+EXEEXT=
+HASSHAREDLIB=1
+SHORTSUFFIX=nbs
+endif
+ifeq ($(OS_TARGET),openbsd)
+BATCHEXT=.sh
+EXEEXT=
+HASSHAREDLIB=1
+SHORTSUFFIX=obs
+endif
+ifeq ($(OS_TARGET),win32)
+SHAREDLIBEXT=.dll
+SHORTSUFFIX=w32
+endif
+ifeq ($(OS_TARGET),os2)
+BATCHEXT=.cmd
+AOUTEXT=.out
+STATICLIBPREFIX=
+SHAREDLIBEXT=.dll
+SHORTSUFFIX=os2
+ECHO=echo
+endif
+ifeq ($(OS_TARGET),emx)
+BATCHEXT=.cmd
+AOUTEXT=.out
+STATICLIBPREFIX=
+SHAREDLIBEXT=.dll
+SHORTSUFFIX=emx
+ECHO=echo
+endif
+ifeq ($(OS_TARGET),amiga)
+EXEEXT=
+SHAREDLIBEXT=.library
+SHORTSUFFIX=amg
+endif
+ifeq ($(OS_TARGET),morphos)
+EXEEXT=
+SHAREDLIBEXT=.library
+SHORTSUFFIX=mos
+endif
+ifeq ($(OS_TARGET),atari)
+EXEEXT=.ttp
+SHORTSUFFIX=ata
+endif
+ifeq ($(OS_TARGET),beos)
+BATCHEXT=.sh
+EXEEXT=
+SHORTSUFFIX=be
+endif
+ifeq ($(OS_TARGET),solaris)
+BATCHEXT=.sh
+EXEEXT=
+SHORTSUFFIX=sun
+endif
+ifeq ($(OS_TARGET),qnx)
+BATCHEXT=.sh
+EXEEXT=
+SHORTSUFFIX=qnx
+endif
+ifeq ($(OS_TARGET),netware)
+EXEEXT=.nlm
+STATICLIBPREFIX=
+SHORTSUFFIX=nw
+endif
+ifeq ($(OS_TARGET),netwlibc)
+EXEEXT=.nlm
+STATICLIBPREFIX=
+SHORTSUFFIX=nwl
+endif
+ifeq ($(OS_TARGET),macos)
+BATCHEXT=
+EXEEXT=
+DEBUGSYMEXT=.xcoff
+SHORTSUFFIX=mac
+endif
+ifeq ($(OS_TARGET),darwin)
+BATCHEXT=.sh
+EXEEXT=
+HASSHAREDLIB=1
+SHORTSUFFIX=dwn
+endif
+else
+ifeq ($(OS_TARGET),go32v1)
+PPUEXT=.pp1
+OEXT=.o1
+ASMEXT=.s1
+SMARTEXT=.sl1
+STATICLIBEXT=.a1
+SHAREDLIBEXT=.so1
+STATICLIBPREFIX=
+SHORTSUFFIX=v1
+endif
+ifeq ($(OS_TARGET),go32v2)
+STATICLIBPREFIX=
+SHORTSUFFIX=dos
+endif
+ifeq ($(OS_TARGET),watcom)
+STATICLIBPREFIX=
+SHORTSUFFIX=wat
+endif
+ifeq ($(OS_TARGET),linux)
+BATCHEXT=.sh
+EXEEXT=
+HASSHAREDLIB=1
+SHORTSUFFIX=lnx
+endif
+ifeq ($(OS_TARGET),freebsd)
+BATCHEXT=.sh
+EXEEXT=
+HASSHAREDLIB=1
+SHORTSUFFIX=fbs
+endif
+ifeq ($(OS_TARGET),netbsd)
+BATCHEXT=.sh
+EXEEXT=
+HASSHAREDLIB=1
+SHORTSUFFIX=nbs
+endif
+ifeq ($(OS_TARGET),openbsd)
+BATCHEXT=.sh
+EXEEXT=
+HASSHAREDLIB=1
+SHORTSUFFIX=obs
+endif
+ifeq ($(OS_TARGET),win32)
+PPUEXT=.ppw
+OEXT=.ow
+ASMEXT=.sw
+SMARTEXT=.slw
+STATICLIBEXT=.aw
+SHAREDLIBEXT=.dll
+SHORTSUFFIX=w32
+endif
+ifeq ($(OS_TARGET),os2)
+BATCHEXT=.cmd
+PPUEXT=.ppo
+ASMEXT=.so2
+OEXT=.oo2
+AOUTEXT=.out
+SMARTEXT=.sl2
+STATICLIBPREFIX=
+STATICLIBEXT=.ao2
+SHAREDLIBEXT=.dll
+SHORTSUFFIX=os2
+ECHO=echo
+endif
+ifeq ($(OS_TARGET),amiga)
+EXEEXT=
+PPUEXT=.ppu
+ASMEXT=.asm
+OEXT=.o
+SMARTEXT=.sl
+STATICLIBEXT=.a
+SHAREDLIBEXT=.library
+SHORTSUFFIX=amg
+endif
+ifeq ($(OS_TARGET),atari)
+PPUEXT=.ppu
+ASMEXT=.s
+OEXT=.o
+SMARTEXT=.sl
+STATICLIBEXT=.a
+EXEEXT=.ttp
+SHORTSUFFIX=ata
+endif
+ifeq ($(OS_TARGET),beos)
+BATCHEXT=.sh
+PPUEXT=.ppu
+ASMEXT=.s
+OEXT=.o
+SMARTEXT=.sl
+STATICLIBEXT=.a
+EXEEXT=
+SHORTSUFFIX=be
+endif
+ifeq ($(OS_TARGET),solaris)
+BATCHEXT=.sh
+PPUEXT=.ppu
+ASMEXT=.s
+OEXT=.o
+SMARTEXT=.sl
+STATICLIBEXT=.a
+EXEEXT=
+SHORTSUFFIX=sun
+endif
+ifeq ($(OS_TARGET),qnx)
+BATCHEXT=.sh
+PPUEXT=.ppu
+ASMEXT=.s
+OEXT=.o
+SMARTEXT=.sl
+STATICLIBEXT=.a
+EXEEXT=
+SHORTSUFFIX=qnx
+endif
+ifeq ($(OS_TARGET),netware)
+STATICLIBPREFIX=
+PPUEXT=.ppu
+OEXT=.o
+ASMEXT=.s
+SMARTEXT=.sl
+STATICLIBEXT=.a
+SHAREDLIBEXT=.nlm
+EXEEXT=.nlm
+SHORTSUFFIX=nw
+endif
+ifeq ($(OS_TARGET),netwlibc)
+STATICLIBPREFIX=
+PPUEXT=.ppu
+OEXT=.o
+ASMEXT=.s
+SMARTEXT=.sl
+STATICLIBEXT=.a
+SHAREDLIBEXT=.nlm
+EXEEXT=.nlm
+SHORTSUFFIX=nwl
+endif
+ifeq ($(OS_TARGET),macos)
+BATCHEXT=
+PPUEXT=.ppu
+ASMEXT=.s
+OEXT=.o
+SMARTEXT=.sl
+STATICLIBEXT=.a
+EXEEXT=
+DEBUGSYMEXT=.xcoff
+SHORTSUFFIX=mac
+endif
+endif
+ifneq ($(findstring $(OS_SOURCE),$(LIMIT83fs)),)
+FPCMADE=fpcmade.$(SHORTSUFFIX)
+ZIPSUFFIX=$(SHORTSUFFIX)
+ZIPCROSSPREFIX=
+ZIPSOURCESUFFIX=src
+ZIPEXAMPLESUFFIX=exm
+else
+FPCMADE=fpcmade.$(TARGETSUFFIX)
+ZIPSOURCESUFFIX=.source
+ZIPEXAMPLESUFFIX=.examples
+ifdef CROSSCOMPILE
+ZIPSUFFIX=.$(SOURCESUFFIX)
+ZIPCROSSPREFIX=$(TARGETSUFFIX)-
+else
+ZIPSUFFIX=.$(TARGETSUFFIX)
+ZIPCROSSPREFIX=
+endif
+endif
+ifndef ECHO
+ECHO:=$(strip $(wildcard $(addsuffix /gecho$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(ECHO),)
+ECHO:=$(strip $(wildcard $(addsuffix /echo$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(ECHO),)
+ECHO= __missing_command_ECHO
+else
+ECHO:=$(firstword $(ECHO))
+endif
+else
+ECHO:=$(firstword $(ECHO))
+endif
+endif
+export ECHO
+ifndef DATE
+DATE:=$(strip $(wildcard $(addsuffix /gdate$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(DATE),)
+DATE:=$(strip $(wildcard $(addsuffix /date$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(DATE),)
+DATE= __missing_command_DATE
+else
+DATE:=$(firstword $(DATE))
+endif
+else
+DATE:=$(firstword $(DATE))
+endif
+endif
+export DATE
+ifndef GINSTALL
+GINSTALL:=$(strip $(wildcard $(addsuffix /ginstall$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(GINSTALL),)
+GINSTALL:=$(strip $(wildcard $(addsuffix /install$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(GINSTALL),)
+GINSTALL= __missing_command_GINSTALL
+else
+GINSTALL:=$(firstword $(GINSTALL))
+endif
+else
+GINSTALL:=$(firstword $(GINSTALL))
+endif
+endif
+export GINSTALL
+ifndef CPPROG
+CPPROG:=$(strip $(wildcard $(addsuffix /cp$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(CPPROG),)
+CPPROG= __missing_command_CPPROG
+else
+CPPROG:=$(firstword $(CPPROG))
+endif
+endif
+export CPPROG
+ifndef RMPROG
+RMPROG:=$(strip $(wildcard $(addsuffix /rm$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(RMPROG),)
+RMPROG= __missing_command_RMPROG
+else
+RMPROG:=$(firstword $(RMPROG))
+endif
+endif
+export RMPROG
+ifndef MVPROG
+MVPROG:=$(strip $(wildcard $(addsuffix /mv$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(MVPROG),)
+MVPROG= __missing_command_MVPROG
+else
+MVPROG:=$(firstword $(MVPROG))
+endif
+endif
+export MVPROG
+ifndef MKDIRPROG
+MKDIRPROG:=$(strip $(wildcard $(addsuffix /gmkdir$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(MKDIRPROG),)
+MKDIRPROG:=$(strip $(wildcard $(addsuffix /mkdir$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(MKDIRPROG),)
+MKDIRPROG= __missing_command_MKDIRPROG
+else
+MKDIRPROG:=$(firstword $(MKDIRPROG))
+endif
+else
+MKDIRPROG:=$(firstword $(MKDIRPROG))
+endif
+endif
+export MKDIRPROG
+ifndef ECHOREDIR
+ifndef inUnix
+ECHOREDIR=echo
+else
+ECHOREDIR=$(ECHO)
+endif
+endif
+ifndef COPY
+COPY:=$(CPPROG) -fp
+endif
+ifndef COPYTREE
+COPYTREE:=$(CPPROG) -Rfp
+endif
+ifndef MKDIRTREE
+MKDIRTREE:=$(MKDIRPROG) -p
+endif
+ifndef MOVE
+MOVE:=$(MVPROG) -f
+endif
+ifndef DEL
+DEL:=$(RMPROG) -f
+endif
+ifndef DELTREE
+DELTREE:=$(RMPROG) -rf
+endif
+ifndef INSTALL
+ifdef inUnix
+INSTALL:=$(GINSTALL) -c -m 644
+else
+INSTALL:=$(COPY)
+endif
+endif
+ifndef INSTALLEXE
+ifdef inUnix
+INSTALLEXE:=$(GINSTALL) -c -m 755
+else
+INSTALLEXE:=$(COPY)
+endif
+endif
+ifndef MKDIR
+MKDIR:=$(GINSTALL) -m 755 -d
+endif
+export ECHOREDIR COPY COPYTREE MOVE DEL DELTREE INSTALL INSTALLEXE MKDIR
+ifndef PPUMOVE
+PPUMOVE:=$(strip $(wildcard $(addsuffix /ppumove$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(PPUMOVE),)
+PPUMOVE= __missing_command_PPUMOVE
+else
+PPUMOVE:=$(firstword $(PPUMOVE))
+endif
+endif
+export PPUMOVE
+ifndef FPCMAKE
+FPCMAKE:=$(strip $(wildcard $(addsuffix /fpcmake$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(FPCMAKE),)
+FPCMAKE= __missing_command_FPCMAKE
+else
+FPCMAKE:=$(firstword $(FPCMAKE))
+endif
+endif
+export FPCMAKE
+ifndef ZIPPROG
+ZIPPROG:=$(strip $(wildcard $(addsuffix /zip$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(ZIPPROG),)
+ZIPPROG= __missing_command_ZIPPROG
+else
+ZIPPROG:=$(firstword $(ZIPPROG))
+endif
+endif
+export ZIPPROG
+ifndef TARPROG
+TARPROG:=$(strip $(wildcard $(addsuffix /tar$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(TARPROG),)
+TARPROG= __missing_command_TARPROG
+else
+TARPROG:=$(firstword $(TARPROG))
+endif
+endif
+export TARPROG
+ASNAME=$(BINUTILSPREFIX)as
+LDNAME=$(BINUTILSPREFIX)ld
+ARNAME=$(BINUTILSPREFIX)ar
+RCNAME=$(BINUTILSPREFIX)rc
+ifneq ($(findstring 1.0.,$(FPC_VERSION)),)
+ifeq ($(OS_TARGET),win32)
+ifeq ($(CROSSBINDIR),)
+ASNAME=asw
+LDNAME=ldw
+ARNAME=arw
+endif
+endif
+endif
+ifndef ASPROG
+ifdef CROSSBINDIR
+ASPROG=$(CROSSBINDIR)/$(ASNAME)$(SRCEXEEXT)
+else
+ASPROG=$(ASNAME)
+endif
+endif
+ifndef LDPROG
+ifdef CROSSBINDIR
+LDPROG=$(CROSSBINDIR)/$(LDNAME)$(SRCEXEEXT)
+else
+LDPROG=$(LDNAME)
+endif
+endif
+ifndef RCPROG
+ifdef CROSSBINDIR
+RCPROG=$(CROSSBINDIR)/$(RCNAME)$(SRCEXEEXT)
+else
+RCPROG=$(RCNAME)
+endif
+endif
+ifndef ARPROG
+ifdef CROSSBINDIR
+ARPROG=$(CROSSBINDIR)/$(ARNAME)$(SRCEXEEXT)
+else
+ARPROG=$(ARNAME)
+endif
+endif
+AS=$(ASPROG)
+LD=$(LDPROG)
+RC=$(RCPROG)
+AR=$(ARPROG)
+PPAS=ppas$(SRCBATCHEXT)
+ifdef inUnix
+LDCONFIG=ldconfig
+else
+LDCONFIG=
+endif
+ifdef DATE
+DATESTR:=$(shell $(DATE) +%Y%m%d)
+else
+DATESTR=
+endif
+ifndef UPXPROG
+ifeq ($(OS_TARGET),go32v2)
+UPXPROG:=1
+endif
+ifeq ($(OS_TARGET),win32)
+UPXPROG:=1
+endif
+ifdef UPXPROG
+UPXPROG:=$(strip $(wildcard $(addsuffix /upx$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(UPXPROG),)
+UPXPROG=
+else
+UPXPROG:=$(firstword $(UPXPROG))
+endif
+else
+UPXPROG=
+endif
+endif
+export UPXPROG
+ZIPOPT=-9
+ZIPEXT=.zip
+ifeq ($(USETAR),bz2)
+TAROPT=vj
+TAREXT=.tar.bz2
+else
+TAROPT=vz
+TAREXT=.tar.gz
+endif
+override REQUIRE_PACKAGES=rtl rtl
+ifeq ($(FULL_TARGET),i386-linux)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),i386-go32v2)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),i386-win32)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),i386-os2)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),i386-freebsd)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),i386-beos)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),i386-netbsd)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),i386-solaris)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),i386-qnx)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),i386-netware)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),i386-openbsd)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),i386-wdosx)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),i386-emx)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),i386-watcom)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),i386-netwlibc)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),i386-wince)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),m68k-linux)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),m68k-freebsd)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),m68k-netbsd)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),m68k-amiga)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),m68k-atari)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),m68k-openbsd)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),m68k-palmos)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),powerpc-linux)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),powerpc-netbsd)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),powerpc-macos)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),powerpc-darwin)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),powerpc-morphos)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),sparc-linux)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),sparc-netbsd)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),sparc-solaris)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),x86_64-linux)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),x86_64-freebsd)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),x86_64-win64)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),arm-linux)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),arm-wince)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifeq ($(FULL_TARGET),powerpc64-linux)
+REQUIRE_PACKAGES_RTL=1
+endif
+ifdef REQUIRE_PACKAGES_RTL
+PACKAGEDIR_RTL:=$(firstword $(subst /Makefile.fpc,,$(strip $(wildcard $(addsuffix /rtl/Makefile.fpc,$(PACKAGESDIR))))))
+ifneq ($(PACKAGEDIR_RTL),)
+ifneq ($(wildcard $(PACKAGEDIR_RTL)/units/$(TARGETSUFFIX)),)
+UNITDIR_RTL=$(PACKAGEDIR_RTL)/units/$(TARGETSUFFIX)
+else
+UNITDIR_RTL=$(PACKAGEDIR_RTL)
+endif
+ifdef CHECKDEPEND
+$(PACKAGEDIR_RTL)/$(FPCMADE):
+	$(MAKE) -C $(PACKAGEDIR_RTL) $(FPCMADE)
+override ALLDEPENDENCIES+=$(PACKAGEDIR_RTL)/$(FPCMADE)
+endif
+else
+PACKAGEDIR_RTL=
+UNITDIR_RTL:=$(subst /Package.fpc,,$(strip $(wildcard $(addsuffix /rtl/Package.fpc,$(UNITSDIR)))))
+ifneq ($(UNITDIR_RTL),)
+UNITDIR_RTL:=$(firstword $(UNITDIR_RTL))
+else
+UNITDIR_RTL=
+endif
+endif
+ifdef UNITDIR_RTL
+override COMPILER_UNITDIR+=$(UNITDIR_RTL)
+endif
+endif
+ifndef NOCPUDEF
+override FPCOPTDEF=$(CPU_TARGET)
+endif
+ifneq ($(OS_TARGET),$(OS_SOURCE))
+override FPCOPT+=-T$(OS_TARGET)
+endif
+ifeq ($(OS_SOURCE),openbsd)
+override FPCOPT+=-FD$(NEW_BINUTILS_PATH)
+endif
+ifndef CROSSBOOTSTRAP
+ifneq ($(BINUTILSPREFIX),)
+override FPCOPT+=-XP$(BINUTILSPREFIX) -Xc
+endif
+ifneq ($(BINUTILSPREFIX),)
+override FPCOPT+=-Xr$(RLINKPATH)
+endif
+endif
+ifdef UNITDIR
+override FPCOPT+=$(addprefix -Fu,$(UNITDIR))
+endif
+ifdef LIBDIR
+override FPCOPT+=$(addprefix -Fl,$(LIBDIR))
+endif
+ifdef OBJDIR
+override FPCOPT+=$(addprefix -Fo,$(OBJDIR))
+endif
+ifdef INCDIR
+override FPCOPT+=$(addprefix -Fi,$(INCDIR))
+endif
+ifdef LINKSMART
+override FPCOPT+=-XX
+endif
+ifdef CREATESMART
+override FPCOPT+=-CX
+endif
+ifdef DEBUG
+override FPCOPT+=-gl
+override FPCOPTDEF+=DEBUG
+endif
+ifdef RELEASE
+ifeq ($(CPU_TARGET),i386)
+FPCCPUOPT:=-OG2p3
+else
+ifeq ($(CPU_TARGET),powerpc)
+FPCCPUOPT:=-O1r
+else
+FPCCPUOPT:=
+endif
+endif
+override FPCOPT+=-Ur -Xs $(FPCCPUOPT) -n
+override FPCOPTDEF+=RELEASE
+endif
+ifdef STRIP
+override FPCOPT+=-Xs
+endif
+ifdef OPTIMIZE
+ifeq ($(CPU_TARGET),i386)
+override FPCOPT+=-OG2p3
+endif
+endif
+ifdef VERBOSE
+override FPCOPT+=-vwni
+endif
+ifdef COMPILER_OPTIONS
+override FPCOPT+=$(COMPILER_OPTIONS)
+endif
+ifdef COMPILER_UNITDIR
+override FPCOPT+=$(addprefix -Fu,$(COMPILER_UNITDIR))
+endif
+ifdef COMPILER_LIBRARYDIR
+override FPCOPT+=$(addprefix -Fl,$(COMPILER_LIBRARYDIR))
+endif
+ifdef COMPILER_OBJECTDIR
+override FPCOPT+=$(addprefix -Fo,$(COMPILER_OBJECTDIR))
+endif
+ifdef COMPILER_INCLUDEDIR
+override FPCOPT+=$(addprefix -Fi,$(COMPILER_INCLUDEDIR))
+endif
+ifdef CROSSBINDIR
+override FPCOPT+=-FD$(CROSSBINDIR)
+endif
+ifdef COMPILER_TARGETDIR
+override FPCOPT+=-FE$(COMPILER_TARGETDIR)
+ifeq ($(COMPILER_TARGETDIR),.)
+override TARGETDIRPREFIX=
+else
+override TARGETDIRPREFIX=$(COMPILER_TARGETDIR)/
+endif
+endif
+ifdef COMPILER_UNITTARGETDIR
+override FPCOPT+=-FU$(COMPILER_UNITTARGETDIR)
+ifeq ($(COMPILER_UNITTARGETDIR),.)
+override UNITTARGETDIRPREFIX=
+else
+override UNITTARGETDIRPREFIX=$(COMPILER_UNITTARGETDIR)/
+endif
+else
+ifdef COMPILER_TARGETDIR
+override COMPILER_UNITTARGETDIR=$(COMPILER_TARGETDIR)
+override UNITTARGETDIRPREFIX=$(TARGETDIRPREFIX)
+endif
+endif
+ifeq ($(OS_TARGET),linux)
+ifeq ($(FPC_VERSION),1.0.6)
+override FPCOPTDEF+=HASUNIX
+endif
+endif
+ifdef OPT
+override FPCOPT+=$(OPT)
+endif
+ifdef FPCOPTDEF
+override FPCOPT+=$(addprefix -d,$(FPCOPTDEF))
+endif
+ifdef CFGFILE
+override FPCOPT+=@$(CFGFILE)
+endif
+ifdef USEENV
+override FPCEXTCMD:=$(FPCOPT)
+override FPCOPT:=!FPCEXTCMD
+export FPCEXTCMD
+endif
+override COMPILER:=$(FPC) $(FPCOPT)
+ifeq (,$(findstring -s ,$(COMPILER)))
+EXECPPAS=
+else
+ifeq ($(FULL_SOURCE),$(FULL_TARGET))
+EXECPPAS:=@$(PPAS)
+endif
+endif
+.PHONY: fpc_exes
+ifndef CROSSINSTALL
+ifneq ($(TARGET_PROGRAMS),)
+override EXEFILES=$(addsuffix $(EXEEXT),$(TARGET_PROGRAMS))
+override EXEOFILES:=$(addsuffix $(OEXT),$(TARGET_PROGRAMS)) $(addprefix $(STATICLIBPREFIX),$(addsuffix $(STATICLIBEXT),$(TARGET_PROGRAMS)))
+override ALLTARGET+=fpc_exes
+override INSTALLEXEFILES+=$(EXEFILES)
+override CLEANEXEFILES+=$(EXEFILES) $(EXEOFILES)
+ifeq ($(OS_TARGET),os2)
+override CLEANEXEFILES+=$(addsuffix $(AOUTEXT),$(TARGET_PROGRAMS))
+endif
+ifeq ($(OS_TARGET),emx)
+override CLEANEXEFILES+=$(addsuffix $(AOUTEXT),$(TARGET_PROGRAMS))
+endif
+endif
+endif
+fpc_exes: $(COMPILER_TARGETDIR) $(COMPILER_UNITTARGETDIR) $(EXEFILES)
+ifdef TARGET_RSTS
+override RSTFILES=$(addsuffix $(RSTEXT),$(TARGET_RSTS))
+override CLEANRSTFILES+=$(RSTFILES)
+endif
+.PHONY: fpc_all fpc_smart fpc_debug fpc_release
+$(FPCMADE): $(ALLDEPENDENCIES) $(ALLTARGET)
+	@$(ECHOREDIR) Compiled > $(FPCMADE)
+fpc_all: $(FPCMADE)
+fpc_smart:
+	$(MAKE) all LINKSMART=1 CREATESMART=1
+fpc_debug:
+	$(MAKE) all DEBUG=1
+fpc_release:
+	$(MAKE) all RELEASE=1
+.SUFFIXES: $(EXEEXT) $(PPUEXT) $(OEXT) .pas .lpr .dpr .pp .rc .res
+$(COMPILER_UNITTARGETDIR):
+	$(MKDIRTREE) $(COMPILER_UNITTARGETDIR)
+$(COMPILER_TARGETDIR):
+	$(MKDIRTREE) $(COMPILER_TARGETDIR)
+%$(PPUEXT): %.pp
+	$(COMPILER) $<
+	$(EXECPPAS)
+%$(PPUEXT): %.pas
+	$(COMPILER) $<
+	$(EXECPPAS)
+%$(EXEEXT): %.pp
+	$(COMPILER) $<
+	$(EXECPPAS)
+%$(EXEEXT): %.pas
+	$(COMPILER) $<
+	$(EXECPPAS)
+%$(EXEEXT): %.lpr
+	$(COMPILER) $<
+	$(EXECPPAS)
+%$(EXEEXT): %.dpr
+	$(COMPILER) $<
+	$(EXECPPAS)
+%.res: %.rc
+	windres -i $< -o $@
+vpath %.pp $(COMPILER_SOURCEDIR) $(COMPILER_INCLUDEDIR)
+vpath %.pas $(COMPILER_SOURCEDIR) $(COMPILER_INCLUDEDIR)
+vpath %.lpr $(COMPILER_SOURCEDIR) $(COMPILER_INCLUDEDIR)
+vpath %.dpr $(COMPILER_SOURCEDIR) $(COMPILER_INCLUDEDIR)
+vpath %$(OEXT) $(COMPILER_UNITTARGETDIR)
+vpath %$(PPUEXT) $(COMPILER_UNITTARGETDIR)
+.PHONY: fpc_install fpc_sourceinstall fpc_exampleinstall
+ifdef INSTALL_UNITS
+override INSTALLPPUFILES+=$(addsuffix $(PPUEXT),$(INSTALL_UNITS))
+endif
+ifdef INSTALL_BUILDUNIT
+override INSTALLPPUFILES:=$(filter-out $(INSTALL_BUILDUNIT)$(PPUEXT),$(INSTALLPPUFILES))
+endif
+ifdef INSTALLPPUFILES
+override INSTALLPPULINKFILES:=$(subst $(PPUEXT),$(OEXT),$(INSTALLPPUFILES)) $(addprefix $(STATICLIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(INSTALLPPUFILES)))
+ifneq ($(UNITTARGETDIRPREFIX),)
+override INSTALLPPUFILES:=$(addprefix $(UNITTARGETDIRPREFIX),$(notdir $(INSTALLPPUFILES)))
+override INSTALLPPULINKFILES:=$(wildcard $(addprefix $(UNITTARGETDIRPREFIX),$(notdir $(INSTALLPPULINKFILES))))
+endif
+override INSTALL_CREATEPACKAGEFPC=1
+endif
+ifdef INSTALLEXEFILES
+ifneq ($(TARGETDIRPREFIX),)
+override INSTALLEXEFILES:=$(addprefix $(TARGETDIRPREFIX),$(notdir $(INSTALLEXEFILES)))
+endif
+endif
+fpc_install: all $(INSTALLTARGET)
+ifdef INSTALLEXEFILES
+	$(MKDIR) $(INSTALL_BINDIR)
+ifdef UPXPROG
+	-$(UPXPROG) $(INSTALLEXEFILES)
+endif
+	$(INSTALLEXE) $(INSTALLEXEFILES) $(INSTALL_BINDIR)
+endif
+ifdef INSTALL_CREATEPACKAGEFPC
+ifdef FPCMAKE
+ifdef PACKAGE_VERSION
+ifneq ($(wildcard Makefile.fpc),)
+	$(FPCMAKE) -p -T$(CPU_TARGET)-$(OS_TARGET) Makefile.fpc
+	$(MKDIR) $(INSTALL_UNITDIR)
+	$(INSTALL) Package.fpc $(INSTALL_UNITDIR)
+endif
+endif
+endif
+endif
+ifdef INSTALLPPUFILES
+	$(MKDIR) $(INSTALL_UNITDIR)
+	$(INSTALL) $(INSTALLPPUFILES) $(INSTALL_UNITDIR)
+ifneq ($(INSTALLPPULINKFILES),)
+	$(INSTALL) $(INSTALLPPULINKFILES) $(INSTALL_UNITDIR)
+endif
+ifneq ($(wildcard $(LIB_FULLNAME)),)
+	$(MKDIR) $(INSTALL_LIBDIR)
+	$(INSTALL) $(LIB_FULLNAME) $(INSTALL_LIBDIR)
+ifdef inUnix
+	ln -sf $(LIB_FULLNAME) $(INSTALL_LIBDIR)/$(LIB_NAME)
+endif
+endif
+endif
+ifdef INSTALL_FILES
+	$(MKDIR) $(INSTALL_DATADIR)
+	$(INSTALL) $(INSTALL_FILES) $(INSTALL_DATADIR)
+endif
+fpc_sourceinstall: distclean
+	$(MKDIR) $(INSTALL_SOURCEDIR)
+	$(COPYTREE) $(BASEDIR)/* $(INSTALL_SOURCEDIR)
+fpc_exampleinstall: $(addsuffix _distclean,$(TARGET_EXAMPLEDIRS))
+ifdef HASEXAMPLES
+	$(MKDIR) $(INSTALL_EXAMPLEDIR)
+endif
+ifdef EXAMPLESOURCEFILES
+	$(COPY) $(EXAMPLESOURCEFILES) $(INSTALL_EXAMPLEDIR)
+endif
+ifdef TARGET_EXAMPLEDIRS
+	$(COPYTREE) $(addsuffix /*,$(TARGET_EXAMPLEDIRS)) $(INSTALL_EXAMPLEDIR)
+endif
+.PHONY: fpc_distinstall
+fpc_distinstall: install exampleinstall
+.PHONY: fpc_zipinstall fpc_zipsourceinstall fpc_zipexampleinstall
+ifndef PACKDIR
+ifndef inUnix
+PACKDIR=$(BASEDIR)/../fpc-pack
+else
+PACKDIR=/tmp/fpc-pack
+endif
+endif
+ifndef ZIPNAME
+ifdef DIST_ZIPNAME
+ZIPNAME=$(DIST_ZIPNAME)
+else
+ZIPNAME=$(PACKAGE_NAME)
+endif
+endif
+ifndef FULLZIPNAME
+FULLZIPNAME=$(ZIPCROSSPREFIX)$(ZIPPREFIX)$(ZIPNAME)$(ZIPSUFFIX)
+endif
+ifndef ZIPTARGET
+ifdef DIST_ZIPTARGET
+ZIPTARGET=DIST_ZIPTARGET
+else
+ZIPTARGET=install
+endif
+endif
+ifndef USEZIP
+ifdef inUnix
+USETAR=1
+endif
+endif
+ifndef inUnix
+USEZIPWRAPPER=1
+endif
+ifdef USEZIPWRAPPER
+ZIPPATHSEP=$(PATHSEP)
+ZIPWRAPPER=$(subst /,$(PATHSEP),$(DIST_DESTDIR)/fpczip$(SRCBATCHEXT))
+else
+ZIPPATHSEP=/
+endif
+ZIPCMD_CDPACK:=cd $(subst /,$(ZIPPATHSEP),$(PACKDIR))
+ZIPCMD_CDBASE:=cd $(subst /,$(ZIPPATHSEP),$(BASEDIR))
+ifdef USETAR
+ZIPDESTFILE:=$(DIST_DESTDIR)/$(FULLZIPNAME)$(TAREXT)
+ZIPCMD_ZIP:=$(TARPROG) cf$(TAROPT) $(ZIPDESTFILE) *
+else
+ZIPDESTFILE:=$(DIST_DESTDIR)/$(FULLZIPNAME)$(ZIPEXT)
+ZIPCMD_ZIP:=$(subst /,$(ZIPPATHSEP),$(ZIPPROG)) -Dr $(ZIPOPT) $(ZIPDESTFILE) *
+endif
+fpc_zipinstall:
+	$(MAKE) $(ZIPTARGET) INSTALL_PREFIX=$(PACKDIR) ZIPINSTALL=1
+	$(MKDIR) $(DIST_DESTDIR)
+	$(DEL) $(ZIPDESTFILE)
+ifdef USEZIPWRAPPER
+ifneq ($(ECHOREDIR),echo)
+	$(ECHOREDIR) -e "$(subst \,\\,$(ZIPCMD_CDPACK))" > $(ZIPWRAPPER)
+	$(ECHOREDIR) -e "$(subst \,\\,$(ZIPCMD_ZIP))" >> $(ZIPWRAPPER)
+	$(ECHOREDIR) -e "$(subst \,\\,$(ZIPCMD_CDBASE))" >> $(ZIPWRAPPER)
+else
+	echo $(ZIPCMD_CDPACK) > $(ZIPWRAPPER)
+	echo $(ZIPCMD_ZIP) >> $(ZIPWRAPPER)
+	echo $(ZIPCMD_CDBASE) >> $(ZIPWRAPPER)
+endif
+ifdef inUnix
+	/bin/sh $(ZIPWRAPPER)
+else
+	$(ZIPWRAPPER)
+endif
+	$(DEL) $(ZIPWRAPPER)
+else
+	$(ZIPCMD_CDPACK) ; $(ZIPCMD_ZIP) ; $(ZIPCMD_CDBASE)
+endif
+	$(DELTREE) $(PACKDIR)
+fpc_zipsourceinstall:
+	$(MAKE) fpc_zipinstall ZIPTARGET=sourceinstall ZIPSUFFIX=$(ZIPSOURCESUFFIX)
+fpc_zipexampleinstall:
+ifdef HASEXAMPLES
+	$(MAKE) fpc_zipinstall ZIPTARGET=exampleinstall ZIPSUFFIX=$(ZIPEXAMPLESUFFIX)
+endif
+fpc_zipdistinstall:
+	$(MAKE) fpc_zipinstall ZIPTARGET=distinstall
+.PHONY: fpc_clean fpc_cleanall fpc_distclean
+ifdef EXEFILES
+override CLEANEXEFILES:=$(addprefix $(TARGETDIRPREFIX),$(CLEANEXEFILES))
+endif
+ifdef CLEAN_UNITS
+override CLEANPPUFILES+=$(addsuffix $(PPUEXT),$(CLEAN_UNITS))
+endif
+ifdef CLEANPPUFILES
+override CLEANPPULINKFILES:=$(subst $(PPUEXT),$(OEXT),$(CLEANPPUFILES)) $(addprefix $(STATICLIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(CLEANPPUFILES)))
+ifdef DEBUGSYMEXT
+override CLEANPPULINKFILES+=$(subst $(PPUEXT),$(DEBUGSYMEXT),$(CLEANPPUFILES))
+endif
+override CLEANPPUFILES:=$(addprefix $(UNITTARGETDIRPREFIX),$(CLEANPPUFILES))
+override CLEANPPULINKFILES:=$(wildcard $(addprefix $(UNITTARGETDIRPREFIX),$(CLEANPPULINKFILES)))
+endif
+fpc_clean: $(CLEANTARGET)
+ifdef CLEANEXEFILES
+	-$(DEL) $(CLEANEXEFILES)
+endif
+ifdef CLEANPPUFILES
+	-$(DEL) $(CLEANPPUFILES)
+endif
+ifneq ($(CLEANPPULINKFILES),)
+	-$(DEL) $(CLEANPPULINKFILES)
+endif
+ifdef CLEANRSTFILES
+	-$(DEL) $(addprefix $(UNITTARGETDIRPREFIX),$(CLEANRSTFILES))
+endif
+ifdef CLEAN_FILES
+	-$(DEL) $(CLEAN_FILES)
+endif
+ifdef LIB_NAME
+	-$(DEL) $(LIB_NAME) $(LIB_FULLNAME)
+endif
+	-$(DEL) $(FPCMADE) Package.fpc $(PPAS) script.res link.res $(FPCEXTFILE) $(REDIRFILE)
+	-$(DEL) *$(ASMEXT) *_ppas$(BATCHEXT)
+fpc_cleanall: $(CLEANTARGET)
+ifdef CLEANEXEFILES
+	-$(DEL) $(CLEANEXEFILES)
+endif
+ifdef COMPILER_UNITTARGETDIR
+ifdef CLEANPPUFILES
+	-$(DEL) $(CLEANPPUFILES)
+endif
+ifneq ($(CLEANPPULINKFILES),)
+	-$(DEL) $(CLEANPPULINKFILES)
+endif
+ifdef CLEANRSTFILES
+	-$(DEL) $(addprefix $(UNITTARGETDIRPREFIX),$(CLEANRSTFILES))
+endif
+endif
+	-$(DELTREE) units
+	-$(DEL) *$(OEXT) *$(PPUEXT) *$(RSTEXT) *$(ASMEXT) *$(STATICLIBEXT) *$(SHAREDLIBEXT) *$(PPLEXT)
+ifneq ($(PPUEXT),.ppu)
+	-$(DEL) *.o *.ppu *.a
+endif
+	-$(DELTREE) *$(SMARTEXT)
+	-$(DEL) fpcmade.* Package.fpc $(PPAS) script.res link.res $(FPCEXTFILE) $(REDIRFILE)
+	-$(DEL) *_ppas$(BATCHEXT)
+ifdef AOUTEXT
+	-$(DEL) *$(AOUTEXT)
+endif
+ifdef DEBUGSYMEXT
+	-$(DEL) *$(DEBUGSYMEXT)
+endif
+fpc_distclean: cleanall
+.PHONY: fpc_baseinfo
+override INFORULES+=fpc_baseinfo
+fpc_baseinfo:
+	@$(ECHO)
+	@$(ECHO)  == Package info ==
+	@$(ECHO)  Package Name..... $(PACKAGE_NAME)
+	@$(ECHO)  Package Version.. $(PACKAGE_VERSION)
+	@$(ECHO)
+	@$(ECHO)  == Configuration info ==
+	@$(ECHO)
+	@$(ECHO)  FPC.......... $(FPC)
+	@$(ECHO)  FPC Version.. $(FPC_VERSION)
+	@$(ECHO)  Source CPU... $(CPU_SOURCE)
+	@$(ECHO)  Target CPU... $(CPU_TARGET)
+	@$(ECHO)  Source OS.... $(OS_SOURCE)
+	@$(ECHO)  Target OS.... $(OS_TARGET)
+	@$(ECHO)  Full Source.. $(FULL_SOURCE)
+	@$(ECHO)  Full Target.. $(FULL_TARGET)
+	@$(ECHO)  SourceSuffix. $(SOURCESUFFIX)
+	@$(ECHO)  TargetSuffix. $(TARGETSUFFIX)
+	@$(ECHO)
+	@$(ECHO)  == Directory info ==
+	@$(ECHO)
+	@$(ECHO)  Required pkgs... $(REQUIRE_PACKAGES)
+	@$(ECHO)
+	@$(ECHO)  Basedir......... $(BASEDIR)
+	@$(ECHO)  FPCDir.......... $(FPCDIR)
+	@$(ECHO)  CrossBinDir..... $(CROSSBINDIR)
+	@$(ECHO)  UnitsDir........ $(UNITSDIR)
+	@$(ECHO)  PackagesDir..... $(PACKAGESDIR)
+	@$(ECHO)
+	@$(ECHO)  GCC library..... $(GCCLIBDIR)
+	@$(ECHO)  Other library... $(OTHERLIBDIR)
+	@$(ECHO)
+	@$(ECHO)  == Tools info ==
+	@$(ECHO)
+	@$(ECHO)  As........ $(AS)
+	@$(ECHO)  Ld........ $(LD)
+	@$(ECHO)  Ar........ $(AR)
+	@$(ECHO)  Rc........ $(RC)
+	@$(ECHO)
+	@$(ECHO)  Mv........ $(MVPROG)
+	@$(ECHO)  Cp........ $(CPPROG)
+	@$(ECHO)  Rm........ $(RMPROG)
+	@$(ECHO)  GInstall.. $(GINSTALL)
+	@$(ECHO)  Echo...... $(ECHO)
+	@$(ECHO)  Shell..... $(SHELL)
+	@$(ECHO)  Date...... $(DATE)
+	@$(ECHO)  FPCMake... $(FPCMAKE)
+	@$(ECHO)  PPUMove... $(PPUMOVE)
+	@$(ECHO)  Upx....... $(UPXPROG)
+	@$(ECHO)  Zip....... $(ZIPPROG)
+	@$(ECHO)
+	@$(ECHO)  == Object info ==
+	@$(ECHO)
+	@$(ECHO)  Target Loaders........ $(TARGET_LOADERS)
+	@$(ECHO)  Target Units.......... $(TARGET_UNITS)
+	@$(ECHO)  Target Implicit Units. $(TARGET_IMPLICITUNITS)
+	@$(ECHO)  Target Programs....... $(TARGET_PROGRAMS)
+	@$(ECHO)  Target Dirs........... $(TARGET_DIRS)
+	@$(ECHO)  Target Examples....... $(TARGET_EXAMPLES)
+	@$(ECHO)  Target ExampleDirs.... $(TARGET_EXAMPLEDIRS)
+	@$(ECHO)
+	@$(ECHO)  Clean Units......... $(CLEAN_UNITS)
+	@$(ECHO)  Clean Files......... $(CLEAN_FILES)
+	@$(ECHO)
+	@$(ECHO)  Install Units....... $(INSTALL_UNITS)
+	@$(ECHO)  Install Files....... $(INSTALL_FILES)
+	@$(ECHO)
+	@$(ECHO)  == Install info ==
+	@$(ECHO)
+	@$(ECHO)  DateStr.............. $(DATESTR)
+	@$(ECHO)  ZipName.............. $(ZIPNAME)
+	@$(ECHO)  ZipPrefix............ $(ZIPPREFIX)
+	@$(ECHO)  ZipCrossPrefix....... $(ZIPCROSSPREFIX)
+	@$(ECHO)  ZipSuffix............ $(ZIPSUFFIX)
+	@$(ECHO)  FullZipName.......... $(FULLZIPNAME)
+	@$(ECHO)  Install FPC Package.. $(INSTALL_FPCPACKAGE)
+	@$(ECHO)
+	@$(ECHO)  Install base dir..... $(INSTALL_BASEDIR)
+	@$(ECHO)  Install binary dir... $(INSTALL_BINDIR)
+	@$(ECHO)  Install library dir.. $(INSTALL_LIBDIR)
+	@$(ECHO)  Install units dir.... $(INSTALL_UNITDIR)
+	@$(ECHO)  Install source dir... $(INSTALL_SOURCEDIR)
+	@$(ECHO)  Install doc dir...... $(INSTALL_DOCDIR)
+	@$(ECHO)  Install example dir.. $(INSTALL_EXAMPLEDIR)
+	@$(ECHO)  Install data dir..... $(INSTALL_DATADIR)
+	@$(ECHO)
+	@$(ECHO)  Dist destination dir. $(DIST_DESTDIR)
+	@$(ECHO)  Dist zip name........ $(DIST_ZIPNAME)
+	@$(ECHO)
+.PHONY: fpc_info
+fpc_info: $(INFORULES)
+.PHONY: fpc_makefile fpc_makefiles fpc_makefile_sub1 fpc_makefile_sub2 \
+	fpc_makefile_dirs
+fpc_makefile:
+	$(FPCMAKE) -w -T$(OS_TARGET) Makefile.fpc
+fpc_makefile_sub1:
+ifdef TARGET_DIRS
+	$(FPCMAKE) -w -T$(OS_TARGET) $(addsuffix /Makefile.fpc,$(TARGET_DIRS))
+endif
+ifdef TARGET_EXAMPLEDIRS
+	$(FPCMAKE) -w -T$(OS_TARGET) $(addsuffix /Makefile.fpc,$(TARGET_EXAMPLEDIRS))
+endif
+fpc_makefile_sub2: $(addsuffix _makefile_dirs,$(TARGET_DIRS) $(TARGET_EXAMPLEDIRS))
+fpc_makefile_dirs: fpc_makefile_sub1 fpc_makefile_sub2
+fpc_makefiles: fpc_makefile fpc_makefile_dirs
+ifeq ($(FULL_TARGET),i386-linux)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),i386-go32v2)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),i386-win32)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),i386-os2)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),i386-freebsd)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),i386-beos)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),i386-netbsd)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),i386-solaris)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),i386-qnx)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),i386-netware)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),i386-openbsd)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),i386-wdosx)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),i386-emx)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),i386-watcom)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),i386-netwlibc)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),i386-wince)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),m68k-linux)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),m68k-freebsd)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),m68k-netbsd)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),m68k-amiga)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),m68k-atari)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),m68k-openbsd)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),m68k-palmos)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),powerpc-linux)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),powerpc-netbsd)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),powerpc-macos)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),powerpc-darwin)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),powerpc-morphos)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),sparc-linux)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),sparc-netbsd)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),sparc-solaris)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),x86_64-linux)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),x86_64-freebsd)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),x86_64-win64)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),arm-linux)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),arm-wince)
+TARGET_DIRS_UTILS=1
+endif
+ifeq ($(FULL_TARGET),powerpc64-linux)
+TARGET_DIRS_UTILS=1
+endif
+ifdef TARGET_DIRS_UTILS
+utils_all:
+	$(MAKE) -C utils all
+utils_debug:
+	$(MAKE) -C utils debug
+utils_smart:
+	$(MAKE) -C utils smart
+utils_release:
+	$(MAKE) -C utils release
+utils_units:
+	$(MAKE) -C utils units
+utils_examples:
+	$(MAKE) -C utils examples
+utils_shared:
+	$(MAKE) -C utils shared
+utils_install:
+	$(MAKE) -C utils install
+utils_sourceinstall:
+	$(MAKE) -C utils sourceinstall
+utils_exampleinstall:
+	$(MAKE) -C utils exampleinstall
+utils_distinstall:
+	$(MAKE) -C utils distinstall
+utils_zipinstall:
+	$(MAKE) -C utils zipinstall
+utils_zipsourceinstall:
+	$(MAKE) -C utils zipsourceinstall
+utils_zipexampleinstall:
+	$(MAKE) -C utils zipexampleinstall
+utils_zipdistinstall:
+	$(MAKE) -C utils zipdistinstall
+utils_clean:
+	$(MAKE) -C utils clean
+utils_distclean:
+	$(MAKE) -C utils distclean
+utils_cleanall:
+	$(MAKE) -C utils cleanall
+utils_info:
+	$(MAKE) -C utils info
+utils_makefiles:
+	$(MAKE) -C utils makefiles
+utils:
+	$(MAKE) -C utils all
+.PHONY: utils_all utils_debug utils_smart utils_release utils_units utils_examples utils_shared utils_install utils_sourceinstall utils_exampleinstall utils_distinstall utils_zipinstall utils_zipsourceinstall utils_zipexampleinstall utils_zipdistinstall utils_clean utils_distclean utils_cleanall utils_info utils_makefiles utils
+endif
+ifndef DIFF
+DIFF:=$(strip $(wildcard $(addsuffix /diff$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(DIFF),)
+DIFF= __missing_command_DIFF
+else
+DIFF:=$(firstword $(DIFF))
+endif
+endif
+export DIFF
+ifndef CMP
+CMP:=$(strip $(wildcard $(addsuffix /cmp$(SRCEXEEXT),$(SEARCHPATH))))
+ifeq ($(CMP),)
+CMP= __missing_command_CMP
+else
+CMP:=$(firstword $(CMP))
+endif
+endif
+export CMP
+debug: fpc_debug
+smart: fpc_smart
+release: fpc_release
+units: fpc_units $(addsuffix _units,$(TARGET_DIRS))
+examples: $(addsuffix _examples,$(TARGET_DIRS))
+shared: $(addsuffix _shared,$(TARGET_DIRS))
+sourceinstall: fpc_sourceinstall
+exampleinstall: fpc_exampleinstall $(addsuffix _exampleinstall,$(TARGET_DIRS))
+distinstall: fpc_distinstall
+zipinstall: fpc_zipinstall
+zipsourceinstall: fpc_zipsourceinstall
+zipexampleinstall: fpc_zipexampleinstall $(addsuffix _zipexampleinstall,$(TARGET_DIRS))
+zipdistinstall: fpc_zipdistinstall
+cleanall: fpc_cleanall $(addsuffix _cleanall,$(TARGET_DIRS))
+info: fpc_info
+makefiles: fpc_makefiles
+.PHONY: debug smart release units examples shared sourceinstall exampleinstall distinstall zipinstall zipsourceinstall zipexampleinstall zipdistinstall cleanall info makefiles
+ifneq ($(wildcard fpcmake.loc),)
+include fpcmake.loc
+endif
+ifeq ($(OS_TARGET),win32)
+ifdef CMP
+override DIFF:=$(CMP) -i218
+endif
+endif
+override COMPILER+=$(LOCALOPT)
+ifneq ($(findstring 1.0.,$(FPC_VERSION)),)
+override COMPILER:=$(patsubst -O%,,$(COMPILER))
+endif
+PASDOC:=$(strip $(wildcard $(addsuffix /pasdoc.exe,$(SEARCHPATH))))
+ifeq ($(PASDOC),)
+PASDOC:=$(strip $(wildcard $(addsuffix /pasdoc,$(SEARCHPATH))))
+endif
+ifeq ($(PASDOC),)
+PASDOC:=../projects/pasdoc/bin/pasdoc
+else
+PASDOC:=$(firstword $(PASDOC))
+endif
+ifndef EXENAME
+EXENAME=ppc$(CPUSUF)$(EXEEXT)
+endif
+PPEXENAME=pp$(EXEEXT)
+TEMPNAME=ppc$(SRCEXEEXT)
+PPCROSSNAME=ppcross$(CPUSUF)$(SRCEXEEXT)
+TEMPNAME1=ppc1$(EXEEXT)
+TEMPNAME2=ppc2$(EXEEXT)
+TEMPNAME3=ppc3$(EXEEXT)
+MAKEDEP=ppdep$(EXEEXT)
+MSG2INC=./msg2inc$(EXEEXT)
+ifdef CROSSINSTALL
+INSTALLEXEFILE=$(PPCROSSNAME)
+else
+INSTALLEXEFILE=$(EXENAME)
+endif
+PPC_TARGETS=alpha i386 m68k powerpc sparc arm x86_64
+.PHONY: $(PPC_TARGETS)
+$(PPC_TARGETS):
+	$(MAKE) PPC_TARGET=$@ CPU_UNITDIR=$@ all
+.PHONY: all compiler echotime ppuclean execlean clean distclean
+all: compiler $(addsuffix _all,$(TARGET_DIRS))
+compiler: $(COMPILER_UNITTARGETDIR) $(COMPILER_TARGETDIR) $(EXENAME)
+ifeq ($(MAKELEVEL),0)
+ifndef STARTTIME
+ifdef DATE
+STARTTIME:=$(shell $(DATE) +%T)
+else
+STARTTIME:=unknown
+endif
+endif
+endif
+export STARTTIME
+ifdef DATE
+ENDTIME=$(shell $(DATE) +%T)
+else
+ENDTIME:=unknown
+endif
+echotime:
+	@echo Start $(STARTTIME) now $(ENDTIME)
+ppuclean:
+	-$(DEL) *$(OEXT) *$(PPUEXT) *$(RSTEXT) *$(ASMEXT) *$(STATICLIBEXT) *$(SHAREDLIBEXT) *$(PPLEXT)
+	-$(DEL) $(addsuffix /*$(PPUEXT),$(COMPILERSOURCEDIR))
+tempclean:
+	-$(DEL) $(PPCROSSNAME) $(TEMPNAME) $(TEMPNAME1) $(TEMPNAME2) $(TEMPNAME3) $(MSG2INC)
+execlean :
+	-$(DEL) ppc386$(EXEEXT) ppcaxp$(EXEEXT) ppc68k$(EXEEXT) ppcx64$(EXEEXT) ppcppc$(EXEEXT) ppcsparc$(EXEEXT) $(EXENAME)
+$(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) ppcaxp$(EXEEXT) ppc68k$(EXEEXT) ppcx64$(EXEEXT) ppcppc$(EXEEXT) ppcppc$(EXEEXT) $(EXENAME))
+cycleclean: cleanall $(addsuffix _clean,$(PPC_TARGET))
+	-$(DEL) $(EXENAME)
+clean: tempclean execlean cleanall $(addsuffix _clean,$(PPC_TARGET)) $(addsuffix _clean,$(TARGET_DIRS))
+distclean: tempclean execlean cleanall $(addsuffix _clean,$(ALLTARGETS)) $(addsuffix _distclean,$(TARGET_DIRS))
+$(MSG2INC): $(COMPILER_TARGETDIR) $(COMPILER_UNITTARGETDIR) $(COMPILERUTILSDIR)/msg2inc.pp
+	$(COMPILER) -FE. $(COMPILERUTILSDIR)/msg2inc.pp
+msgtxt.inc: $(MSGFILE)
+	$(MAKE) $(MSG2INC)
+	$(MSG2INC) $(MSGFILE) msg msg
+msg: msgtxt.inc
+$(EXENAME) : $(wildcard *.pas) $(wildcard *.inc) msg \
+	     $(wildcard systems/*.pas) $(wilcard systems/*.inc) \
+	     $(wildcard $(PPC_TARGET)/*.pas) $(wildcard $(PPC_TARGET)/*.inc)
+	$(COMPILER) pp.pas
+	$(EXECPPAS)
+	$(MOVE) $(COMPILER_TARGETDIR)/$(PPEXENAME) $(EXENAME)
+ifeq ($(CPU_SOURCE),$(PPC_TARGET))
+ifeq ($(OS_SOURCE),$(OS_TARGET))
+ifdef DIFF
+ifdef OLDFPC
+DIFFRESULT:=$(shell $(DIFF) $(OLDFPC) $(FPC))
+else
+DIFFRESULT=Not equal
+endif
+else
+DIFFRESULT=No diff program
+endif
+ifndef DIFFRESULT
+next :
+	@echo $(OLDFPC) and $(FPC) are equal
+	$(COPY) $(FPC) $(EXENAME)
+else
+next :
+	$(MAKE) rtlclean rtl
+	$(MAKE) cycleclean compiler
+	$(MAKE) echotime
+endif
+$(TEMPNAME1) :
+	$(MAKE) 'OLDFPC=' next
+	-$(DEL) $(TEMPNAME1)
+	$(MOVE) $(EXENAME) $(TEMPNAME1)
+$(TEMPNAME2) : $(TEMPNAME1)
+	$(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME1)' 'OLDFPC=' next
+	-$(DEL) $(TEMPNAME2)
+	$(MOVE) $(EXENAME) $(TEMPNAME2)
+$(TEMPNAME3) : $(TEMPNAME2)
+	$(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME2)' 'OLDFPC=$(BASEDIR)/$(TEMPNAME1)' next
+	-$(DEL) $(TEMPNAME3)
+	$(MOVE) $(EXENAME) $(TEMPNAME3)
+cycle:
+	$(MAKE) tempclean $(TEMPNAME3)
+	$(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME3)' 'OLDFPC=$(BASEDIR)/$(TEMPNAME2)' next
+	$(DIFF) $(TEMPNAME3) $(EXENAME)
+	$(MAKE) $(addsuffix _all,$(TARGET_DIRS)) 'FPC=$(BASEDIR)/$(EXENAME)'
+	$(MAKE) echotime
+else
+cycle:
+	$(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) '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
+ifndef CROSSINSTALL
+	$(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' rtlclean rtl
+	$(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' cycleclean compiler
+endif
+endif
+else
+cycle:
+	$(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) '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
+ifndef CROSSINSTALL
+	$(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' rtlclean rtl
+	$(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' cycleclean compiler
+endif
+endif
+cycledep:
+	$(MAKE) cycle USEDEPEND=1
+extcycle:
+	$(MAKE) cycle OPT='-n -OG2p3 -gl -CRriot -dEXTDEBUG'
+cvstest:
+	$(MAKE) cycle 'LOCALOPT=-n -Se' 'RTLOPT=-n -Se'
+full: fullcycle
+fullcycle:
+	$(MAKE) cycle
+	$(MAKE) ppuclean
+	$(MAKE) $(filter-out $(PPC_TARGET),$(CYCLETARGETS)) 'FPC=$(BASEDIR)/$(EXENAME)'
+htmldocs:
+	$(PASDOC) -p -h -o html$(PATHSEP)$(PPC_TARGET) -d fpc -d gdb -d $(PPC_TARGET) -u $(PPC_TARGET) $(PPC_TARGET)$(PATHSEP)*.pas systems$(PATHSEP)*.pas *.pas
+.PHONY: quickinstall install installsym
+MSGINSTALLDIR=$(INSTALL_BASEDIR)/msg
+override PPEXEFILE:=$(wildcard $(EXENAME))
+ifdef UNIXHier
+PPCCPULOCATION=$(INSTALL_BASEDIR)
+else
+PPCCPULOCATION=$(INSTALL_BINDIR)
+endif
+quickinstall: $(addsuffix _install,$(TARGET_DIRS))
+ifneq ($(INSTALLEXEFILE),)
+ifdef UPXPROG
+	-$(UPXPROG) $(INSTALLEXEFILE)
+endif
+	$(MKDIR) $(PPCCPULOCATION)
+	$(INSTALLEXE) $(INSTALLEXEFILE) $(PPCCPULOCATION)/$(EXENAME)
+endif
+install: quickinstall
+ifndef CROSSINSTALL
+ifdef UNIXHier
+	$(MKDIR) $(INSTALL_BASEDIR)
+	$(INSTALLEXE) $(COMPILERUTILSDIR)/samplecfg $(INSTALL_BASEDIR)/samplecfg
+endif
+	$(MKDIR) $(MSGINSTALLDIR)
+	$(INSTALL) $(MSGFILES) $(MSGINSTALLDIR)
+endif
+installsymlink: install
+ifneq ($(PPCCPULOCATION),$(INSTALL_BINDIR))
+	$(MKDIR) $(INSTALL_BINDIR)
+	ln -sf $(INSTALL_BASEDIR)/$(EXENAME) $(INSTALL_BINDIR)/$(EXENAME)
+endif
+.PHONY: rtl rtlclean rtlinstall
+rtl:
+	$(MAKE) -C $(PACKAGEDIR_RTL) 'OPT=$(RTLOPT)' all
+rtlclean:
+	$(MAKE) -C $(PACKAGEDIR_RTL) clean
+rtlinstall:
+	$(MAKE) -C $(PACKAGEDIR_RTL) install
+localmake:=$(strip $(wildcard makefile.loc))
+ifdef localmake
+include ./$(localmake)
+endif

+ 563 - 0
compiler/Makefile.fpc

@@ -0,0 +1,563 @@
+#
+#   Makefile.fpc for Free Pascal Compiler
+#
+
+[package]
+name=compiler
+version=2.0.0
+
+[target]
+programs=pp
+dirs=utils
+
+[compiler]
+targetdir=.
+unittargetdir=$(CPU_UNITDIR)/units/$(FULL_TARGET)
+unitdir=$(COMPILERSOURCEDIR)
+includedir=$(PPC_TARGET)
+
+[require]
+packages=rtl
+tools=diff cmp
+
+[install]
+fpcpackage=y
+
+[default]
+fpcdir=..
+
+
+[prerules]
+# Don't export version it can change after the first compile
+unexport FPC_VERSION FPC_COMPILERINFO
+
+# Which platforms are ready for inclusion in the cycle
+CYCLETARGETS=i386 powerpc sparc arm x86_64 powerpc64
+
+# All supported targets used for clean
+ALLTARGETS=$(CYCLETARGETS) m68k
+
+# Allow ALPHA, POWERPC, POWERPC64, M68K, I386 defines for target cpu
+ifdef ALPHA
+PPC_TARGET=alpha
+endif
+ifdef POWERPC
+PPC_TARGET=powerpc
+endif
+ifdef POWERPC64
+PPC_TARGET=powerpc64
+endif
+ifdef SPARC
+PPC_TARGET=sparc
+endif
+ifdef M68K
+PPC_TARGET=m68k
+endif
+ifdef I386
+PPC_TARGET=i386
+endif
+ifdef X86_64
+PPC_TARGET=x86_64
+endif
+ifdef ARM
+PPC_TARGET=arm
+endif
+
+# Default is to generate a compiler for the same
+# platform as CPU_TARGET (a native compiler)
+ifndef PPC_TARGET
+PPC_TARGET=$(CPU_TARGET)
+endif
+
+# Default is to generate a compiler for the same
+# target as OS_TARGET (a native compiler)
+ifndef PPC_OS
+PPC_OS=$(OS_TARGET)
+endif
+
+# Where to place the unit files.
+CPU_UNITDIR=$(PPC_TARGET)
+
+# RTL
+UTILSDIR=../utils
+
+# Directories containing compiler sources
+COMPILERSOURCEDIR=$(PPC_TARGET) systems
+
+# Utils used by compiler development/installation
+COMPILERUTILSDIR=utils
+
+# Default language for the compiler
+ifndef FPCLANG
+FPCLANG=e
+endif
+
+# Local options for the compiler only
+ifndef LOCALOPT
+LOCALOPT:=$(OPT)
+endif
+
+# Options for the RTL only when cycling
+ifndef RTLOPT
+RTLOPT:=$(OPT)
+endif
+
+# Make OPT empty. It is copied to LOCALOPT and RTLOPT
+override OPT=
+
+# Message files
+MSGFILES=$(wildcard msg/error*.msg)
+
+# ppcSUFFIX
+ifeq ($(PPC_TARGET),i386)
+CPUSUF=386
+endif
+ifeq ($(PPC_TARGET),alpha)
+CPUSUF=axp
+endif
+ifeq ($(PPC_TARGET),m68k)
+CPUSUF=68k
+endif
+ifeq ($(PPC_TARGET),powerpc)
+CPUSUF=ppc
+endif
+ifeq ($(PPC_TARGET),powerpc64)
+CPUSUF=ppc64
+endif
+ifeq ($(PPC_TARGET),sparc)
+CPUSUF=sparc
+endif
+ifeq ($(PPC_TARGET),x86_64)
+CPUSUF=x64
+endif
+ifeq ($(PPC_TARGET),arm)
+CPUSUF=arm
+endif
+
+# Do not define the default -d$(CPU_TARGET) because that
+# will conflict with our -d$(PPC_TARGET)
+NOCPUDEF=1
+
+# Default message file
+MSGFILE=msg/error$(FPCLANG).msg
+
+# Define Unix also for Linux
+ifeq ($(OS_TARGET),linux)
+ifneq ($(findstring 1.0.,$(FPC_VERSION)),)
+override LOCALOPT+=-dUNIX
+endif
+endif
+
+ifeq ($(OS_TARGET),freebsd)
+ifneq ($(findstring 1.0.,$(FPC_VERSION)),)
+override LOCALOPT+=-dUNIX
+endif
+endif
+
+# set correct defines (-d$(CPU_TARGET) is automaticly added in makefile.fpc)
+override LOCALOPT+=-d$(PPC_TARGET) -dGDB -dBROWSERLOG
+
+# i386 specific
+ifeq ($(PPC_TARGET),i386)
+override LOCALOPT+=-Fux86
+endif
+
+# x86_64 specific
+ifeq ($(PPC_TARGET),x86_64)
+override LOCALOPT+=-Fux86
+endif
+
+# PowerPC specific
+ifeq ($(PPC_TARGET),powerpc)
+override LOCALOPT+=
+endif
+
+# m68k specific
+ifeq ($(PPC_TARGET),m68k)
+override LOCALOPT+=-dNOOPT
+endif
+
+# Sparc specific
+ifeq ($(PPC_TARGET),sparc)
+override LOCALOPT+=
+endif
+
+# m68k specific with low stack
+ifeq ($(PPC_TARGET),m68k)
+ifeq ($(OS_TARGET),amiga)
+override LOCALOPT+=-Ct
+endif
+endif
+
+# ARM specific
+ifeq ($(PPC_TARGET),arm)
+override LOCALOPT+=-dNOOPT
+endif
+
+[rules]
+#####################################################################
+# Setup Targets
+#####################################################################
+
+ifeq ($(OS_TARGET),win32)
+ifdef CMP
+override DIFF:=$(CMP) -i218
+endif
+endif
+
+# Add Local options
+override COMPILER+=$(LOCALOPT)
+
+# Disable optimizer when compiled with 1.0.x
+ifneq ($(findstring 1.0.,$(FPC_VERSION)),)
+override COMPILER:=$(patsubst -O%,,$(COMPILER))
+endif
+
+
+#####################################################################
+# PASDoc
+#####################################################################
+
+PASDOC:=$(strip $(wildcard $(addsuffix /pasdoc.exe,$(SEARCHPATH))))
+ifeq ($(PASDOC),)
+PASDOC:=$(strip $(wildcard $(addsuffix /pasdoc,$(SEARCHPATH))))
+endif
+ifeq ($(PASDOC),)
+PASDOC:=../projects/pasdoc/bin/pasdoc
+else
+PASDOC:=$(firstword $(PASDOC))
+endif
+
+
+#####################################################################
+# Setup os-independent filenames
+#####################################################################
+
+ifndef EXENAME
+EXENAME=ppc$(CPUSUF)$(EXEEXT)
+endif
+PPEXENAME=pp$(EXEEXT)
+TEMPNAME=ppc$(SRCEXEEXT)
+PPCROSSNAME=ppcross$(CPUSUF)$(SRCEXEEXT)
+TEMPNAME1=ppc1$(EXEEXT)
+TEMPNAME2=ppc2$(EXEEXT)
+TEMPNAME3=ppc3$(EXEEXT)
+MAKEDEP=ppdep$(EXEEXT)
+MSG2INC=./msg2inc$(EXEEXT)
+ifdef CROSSINSTALL
+INSTALLEXEFILE=$(PPCROSSNAME)
+else
+INSTALLEXEFILE=$(EXENAME)
+endif
+
+#####################################################################
+# CPU targets
+#####################################################################
+
+PPC_TARGETS=alpha i386 m68k powerpc sparc arm x86_64
+
+.PHONY: $(PPC_TARGETS)
+
+$(PPC_TARGETS):
+        $(MAKE) PPC_TARGET=$@ CPU_UNITDIR=$@ all
+
+
+#####################################################################
+# Default makefile
+#####################################################################
+
+.PHONY: all compiler echotime ppuclean execlean clean distclean
+
+all: compiler $(addsuffix _all,$(TARGET_DIRS))
+
+compiler: $(COMPILER_UNITTARGETDIR) $(COMPILER_TARGETDIR) $(EXENAME)
+
+ifeq ($(MAKELEVEL),0)
+ifndef STARTTIME
+ifdef DATE
+STARTTIME:=$(shell $(DATE) +%T)
+else
+STARTTIME:=unknown
+endif
+endif
+endif
+
+export STARTTIME
+
+ifdef DATE
+ENDTIME=$(shell $(DATE) +%T)
+else
+ENDTIME:=unknown
+endif
+
+echotime:
+        @echo Start $(STARTTIME) now $(ENDTIME)
+
+ppuclean:
+        -$(DEL) *$(OEXT) *$(PPUEXT) *$(RSTEXT) *$(ASMEXT) *$(STATICLIBEXT) *$(SHAREDLIBEXT) *$(PPLEXT)
+        -$(DEL) $(addsuffix /*$(PPUEXT),$(COMPILERSOURCEDIR))
+
+tempclean:
+        -$(DEL) $(PPCROSSNAME) $(TEMPNAME) $(TEMPNAME1) $(TEMPNAME2) $(TEMPNAME3) $(MSG2INC)
+
+execlean :
+        -$(DEL) ppc386$(EXEEXT) ppcaxp$(EXEEXT) ppc68k$(EXEEXT) ppcx64$(EXEEXT) ppcppc$(EXEEXT) ppcsparc$(EXEEXT) $(EXENAME)
+
+$(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) ppcaxp$(EXEEXT) ppc68k$(EXEEXT) ppcx64$(EXEEXT) ppcppc$(EXEEXT) ppcppc$(EXEEXT) $(EXENAME))
+
+cycleclean: cleanall $(addsuffix _clean,$(PPC_TARGET))
+        -$(DEL) $(EXENAME)
+
+clean: tempclean execlean cleanall $(addsuffix _clean,$(PPC_TARGET)) $(addsuffix _clean,$(TARGET_DIRS))
+
+distclean: tempclean execlean cleanall $(addsuffix _clean,$(ALLTARGETS)) $(addsuffix _distclean,$(TARGET_DIRS))
+
+
+#####################################################################
+# Make targets
+#####################################################################
+
+$(MSG2INC): $(COMPILER_TARGETDIR) $(COMPILER_UNITTARGETDIR) $(COMPILERUTILSDIR)/msg2inc.pp
+        $(COMPILER) -FE. $(COMPILERUTILSDIR)/msg2inc.pp
+
+# The msgtxt.inc only depends on the error?.msg file, not on msg2inc,
+# because that one will be new almost everytime
+msgtxt.inc: $(MSGFILE)
+        $(MAKE) $(MSG2INC)
+        $(MSG2INC) $(MSGFILE) msg msg
+
+msg: msgtxt.inc
+
+# Make only the compiler
+$(EXENAME) : $(wildcard *.pas) $(wildcard *.inc) msg \
+             $(wildcard systems/*.pas) $(wilcard systems/*.inc) \
+             $(wildcard $(PPC_TARGET)/*.pas) $(wildcard $(PPC_TARGET)/*.inc)
+        $(COMPILER) pp.pas
+        $(EXECPPAS)
+        $(MOVE) $(COMPILER_TARGETDIR)/$(PPEXENAME) $(EXENAME)
+
+
+#####################################################################
+# Cycle targets
+#
+# 1. Source CPU = Target CPU  and  Source OS = Target OS
+#    Normal cycle
+#
+# 2. Source CPU = Target CPU  and  Source OS <> Target OS
+#    First source native compiler
+#    Second target native compiler  (skipped for cross installation)
+#
+# 3. Source CPU <> Target CPU
+#    First source native compiler
+#    Second cross compiler
+#    Third target native compiler (skipped for cross installation)
+#
+#####################################################################
+
+ifeq ($(CPU_SOURCE),$(PPC_TARGET))
+
+ifeq ($(OS_SOURCE),$(OS_TARGET))
+
+##########################
+# Normal cycle
+#
+
+# Used to avoid unnecessary steps
+ifdef DIFF
+ifdef OLDFPC
+DIFFRESULT:=$(shell $(DIFF) $(OLDFPC) $(FPC))
+else
+DIFFRESULT=Not equal
+endif
+else
+DIFFRESULT=No diff program
+endif
+
+ifndef DIFFRESULT
+next :
+        @echo $(OLDFPC) and $(FPC) are equal
+        $(COPY) $(FPC) $(EXENAME)
+else
+next :
+        $(MAKE) rtlclean rtl
+        $(MAKE) cycleclean compiler
+        $(MAKE) echotime
+endif
+
+$(TEMPNAME1) :
+        $(MAKE) 'OLDFPC=' next
+        -$(DEL) $(TEMPNAME1)
+        $(MOVE) $(EXENAME) $(TEMPNAME1)
+
+$(TEMPNAME2) : $(TEMPNAME1)
+        $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME1)' 'OLDFPC=' next
+        -$(DEL) $(TEMPNAME2)
+        $(MOVE) $(EXENAME) $(TEMPNAME2)
+
+$(TEMPNAME3) : $(TEMPNAME2)
+        $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME2)' 'OLDFPC=$(BASEDIR)/$(TEMPNAME1)' next
+        -$(DEL) $(TEMPNAME3)
+        $(MOVE) $(EXENAME) $(TEMPNAME3)
+
+cycle:
+        $(MAKE) tempclean $(TEMPNAME3)
+        $(MAKE) 'FPC=$(BASEDIR)/$(TEMPNAME3)' 'OLDFPC=$(BASEDIR)/$(TEMPNAME2)' next
+        $(DIFF) $(TEMPNAME3) $(EXENAME)
+        $(MAKE) $(addsuffix _all,$(TARGET_DIRS)) 'FPC=$(BASEDIR)/$(EXENAME)'
+        $(MAKE) echotime
+
+else
+
+##########################
+# Cross Target cycle
+#
+
+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
+# 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
+# ppc<ARCH> (target native)
+ifndef CROSSINSTALL
+        $(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' rtlclean rtl
+        $(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' cycleclean compiler
+endif
+
+endif
+
+else
+
+##########################
+# Cross CPU cycle
+#
+# ppc1 = native
+# ppc2 = cross running on this platform
+# ppc3/ppcXXX = native (skipped for cross installation)
+#
+
+cycle:
+# ppc (source native)
+        $(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
+# 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
+# ppc<ARCH> (target native)
+ifndef CROSSINSTALL
+        $(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' rtlclean rtl
+        $(MAKE) 'FPC=$(BASEDIR)/$(PPCROSSNAME)' cycleclean compiler
+endif
+
+endif
+
+cycledep:
+        $(MAKE) cycle USEDEPEND=1
+
+extcycle:
+        $(MAKE) cycle OPT='-n -OG2p3 -gl -CRriot -dEXTDEBUG'
+
+cvstest:
+        $(MAKE) cycle 'LOCALOPT=-n -Se' 'RTLOPT=-n -Se'
+
+
+##########################
+# Full cycle
+#
+# 1. build a compiler using cycle
+# 2. remove all .ppufiles
+# 3. build all supported cross compilers except the
+#    current PPC_TARGET which was already build
+#
+
+full: fullcycle
+
+fullcycle:
+        $(MAKE) cycle
+        $(MAKE) ppuclean
+        $(MAKE) $(filter-out $(PPC_TARGET),$(CYCLETARGETS)) 'FPC=$(BASEDIR)/$(EXENAME)'
+
+#####################################################################
+# Docs
+#####################################################################
+
+htmldocs:
+        $(PASDOC) -p -h -o html$(PATHSEP)$(PPC_TARGET) -d fpc -d gdb -d $(PPC_TARGET) -u $(PPC_TARGET) $(PPC_TARGET)$(PATHSEP)*.pas systems$(PATHSEP)*.pas *.pas
+
+#####################################################################
+# Installation
+#####################################################################
+
+.PHONY: quickinstall install installsym
+
+MSGINSTALLDIR=$(INSTALL_BASEDIR)/msg
+override PPEXEFILE:=$(wildcard $(EXENAME))
+
+ifdef UNIXHier
+PPCCPULOCATION=$(INSTALL_BASEDIR)
+else
+PPCCPULOCATION=$(INSTALL_BINDIR)
+endif
+
+# This will only install the ppcXXX executable, not the message files etc.
+quickinstall: $(addsuffix _install,$(TARGET_DIRS))
+# Install ppcXXX executable, for a cross installation we install
+# the ppcrossXXX as ppcXXX. The target native build ppcXXX is not used
+# for this installation type
+ifneq ($(INSTALLEXEFILE),)
+ifdef UPXPROG
+        -$(UPXPROG) $(INSTALLEXEFILE)
+endif
+        $(MKDIR) $(PPCCPULOCATION)
+        $(INSTALLEXE) $(INSTALLEXEFILE) $(PPCCPULOCATION)/$(EXENAME)
+endif
+
+install: quickinstall
+ifndef CROSSINSTALL
+ifdef UNIXHier
+        $(MKDIR) $(INSTALL_BASEDIR)
+        $(INSTALLEXE) $(COMPILERUTILSDIR)/samplecfg $(INSTALL_BASEDIR)/samplecfg
+endif
+        $(MKDIR) $(MSGINSTALLDIR)
+        $(INSTALL) $(MSGFILES) $(MSGINSTALLDIR)
+endif
+
+# This also installs a link from bin to the actual executable.
+# The .deb does that later.
+installsymlink: install
+ifneq ($(PPCCPULOCATION),$(INSTALL_BINDIR))
+        $(MKDIR) $(INSTALL_BINDIR)
+        ln -sf $(INSTALL_BASEDIR)/$(EXENAME) $(INSTALL_BINDIR)/$(EXENAME)
+endif
+
+
+#####################################################################
+# RTL
+#####################################################################
+
+.PHONY: rtl rtlclean rtlinstall
+
+rtl:
+        $(MAKE) -C $(PACKAGEDIR_RTL) 'OPT=$(RTLOPT)' all
+
+rtlclean:
+        $(MAKE) -C $(PACKAGEDIR_RTL) clean
+
+rtlinstall:
+        $(MAKE) -C $(PACKAGEDIR_RTL) install
+
+
+#####################################################################
+# local user configurable file
+# in makefile.loc you can add any desired target
+#####################################################################
+
+localmake:=$(strip $(wildcard makefile.loc))
+
+ifdef localmake
+include ./$(localmake)
+endif

+ 58 - 0
compiler/README

@@ -0,0 +1,58 @@
+This directory contains the sources of the Free Pascal Compiler
+
+If you want to compile/modify the compiler, please read first the
+programmers manual.
+
+To recompile the compiler, you can use the batch files :
+ + mppc386.bat    if you want to build a cross compiler from i386 to m68k
+ + mppcsparc      if you want to build a cross compiler from i386 to SPARC
+ 
+ or
+Use the make utility as following
+  
+      make OS_TARGET="compiler OS target" \
+      CPU_TARGET="compiler CPU target" \
+      FPCCPUOPT="Optimization level" \
+      PP="compiler used to compile FPC" \
+      COMPILER_OPTIONS="Options passed to compiler" \
+      
+      
+If an option is omitted, then target CPU/OS will be same as current CPU/OS
+ 
+Possibles targets are : linux go32v2 win32 os2 freebsd beos netbsd amiga
+atari sunos qnx netware openbsd wdosx palmos macos macosx emx
+   
+Possible compiler switches (* marks a currently required switch):
+  -----------------------------------------------------------------
+  GDB*                support of the GNU Debugger
+  I386                generate a compiler for the Intel i386+
+  x86_64              generate a compiler for the AMD x86-64 architecture
+  M68K                generate a compiler for the M68000
+  SPARC               generate a compiler for SPARC
+  POWERPC             generate a compiler for the PowerPC
+  VIS                 generate a compile for the VIS
+  DEBUG               version with debug code is generated
+  EXTDEBUG            some extra debug code is executed
+  SUPPORT_MMX         only i386: releases the compiler switch
+                      MMX which allows the compiler to generate
+                      MMX instructions
+  EXTERN_MSG          Don't compile the msgfiles in the compiler, always
+                      use external messagefiles, default for TP
+  NOAG386INT          no Intel Assembler output
+  NOAG386NSM          no NASM output
+  NOAG386BIN          leaves out the binary writer, default for TP
+  NORA386DIR          No direct i386 assembler reader
+  TEST_GENERIC        Test Generic version of code generator
+                      (uses generic RTL calls)
+  -----------------------------------------------------------------
+  cpuflags            The target processor has status flags (on by default)
+  cpufpemu            The target compiler will also support emitting software
+                       floating point operations
+  cpu64bit            The target is a 64-bit processor
+  -----------------------------------------------------------------
+
+  Required switches for a i386 compiler be compiled by Free Pascal Compiler:
+  GDB;I386
+
+to build a compiler to SPARC target using a Win32/i386 you just use :
+      make CPU_TARGET=SPARC

+ 952 - 0
compiler/aasmbase.pas

@@ -0,0 +1,952 @@
+{
+    Copyright (c) 1998-2002 by Florian Klaempfl
+
+    This unit implements an abstract asmoutput class for all processor types
+
+    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(This unit implements an abstract asm output class for all processor types)
+  This unit implements an abstract assembler output class for all processors, these
+  are then overriden for each assembler writer to actually write the data in these
+  classes to an assembler file.
+}
+
+unit aasmbase;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+       cutils,cclasses,
+       globtype,globals,systems
+       ;
+
+    type
+       TAsmSection = class;
+       TAsmObjectData = class;
+
+       TAsmsymbind=(AB_NONE,AB_EXTERNAL,AB_COMMON,AB_LOCAL,AB_GLOBAL);
+
+       TAsmsymtype=(AT_NONE,AT_FUNCTION,AT_DATA,AT_SECTION,AT_LABEL);
+
+       TAsmRelocationType = (RELOC_ABSOLUTE,RELOC_RELATIVE,RELOC_RVA);
+
+       TAsmSectionType=(sec_none,
+         sec_code,sec_data,sec_rodata,sec_bss,sec_threadvar,
+         sec_common, { used for executable creation }
+         sec_custom, { custom section, no prefix }
+         sec_stub,   { used for darwin import stubs }
+         { stabs }
+         sec_stab,sec_stabstr,
+         { win32 }
+         sec_idata2,sec_idata4,sec_idata5,sec_idata6,sec_idata7,sec_edata,
+         { C++ exception handling unwinding (uses dwarf) }
+         sec_eh_frame,
+         { dwarf }
+         sec_debug_frame,
+         { ELF resources }
+         sec_fpc
+       );
+
+       TAsmSectionOption = (aso_alloconly,aso_executable);
+       TAsmSectionOptions = set of TAsmSectionOption;
+
+       TAsmSymbol = class(TNamedIndexItem)
+       private
+         { this need to be incremented with every symbol loading into the
+           paasmoutput, thus in loadsym/loadref/const_symbol (PFV) }
+         refs       : longint;
+       public
+         defbind,
+         currbind   : TAsmsymbind;
+         typ        : TAsmsymtype;
+         { the next fields are filled in the binary writer }
+         section    : TAsmSection;
+         address,
+         size       : aint;
+         { Alternate symbol which can be used for 'renaming' needed for
+           inlining }
+         altsymbol  : tasmsymbol;
+         { pointer to objectdata that is the owner of this symbol }
+         owner      : tasmobjectdata;
+         { Is the symbol in the used list }
+         inusedlist : boolean;
+         { assembler pass label is set, used for detecting multiple labels }
+         pass       : byte;
+         ppuidx     : longint;
+         constructor create(const s:string;_bind:TAsmsymbind;_typ:Tasmsymtype);
+         procedure reset;
+         function  is_used:boolean;
+         procedure increfs;
+         procedure decrefs;
+         function getrefs: longint;
+         procedure setaddress(_pass:byte;sec:TAsmSection;offset,len:aint);
+       end;
+
+       { is the label only there for getting an address (e.g. for i/o
+         checks -> alt_addr) or is it a jump target (alt_jump), for debug
+         info alt_dbgline and alt_dbgfile }
+       TAsmLabelType = (alt_jump,alt_addr,alt_data,alt_dbgline,alt_dbgfile,alt_dbgtype);
+
+       TAsmLabel = class(TAsmSymbol)
+         labelnr   : longint;
+         labeltype : TAsmLabelType;
+         is_set    : boolean;
+         constructor createlocal(nr:longint;ltyp:TAsmLabelType);
+         constructor createglobal(const modulename:string;nr:longint;ltyp:TAsmLabelType);
+         function getname:string;override;
+       end;
+
+       TAsmRelocation = class(TLinkedListItem)
+          address,
+          orgsize  : aint;  { original size of the symbol to relocate, required for COFF }
+          symbol   : TAsmSymbol;
+          section  : TAsmSection; { only used if symbol=nil }
+          typ      : TAsmRelocationType;
+          constructor CreateSymbol(Aaddress:aint;s:Tasmsymbol;Atyp:TAsmRelocationType);
+          constructor CreateSymbolSize(Aaddress:aint;s:Tasmsymbol;Aorgsize:aint;Atyp:TAsmRelocationType);
+          constructor CreateSection(Aaddress:aint;sec:TAsmSection;Atyp:TAsmRelocationType);
+       end;
+
+       TAsmSection = class(TNamedIndexItem)
+         owner      : TAsmObjectData;
+         secoptions : TAsmSectionOptions;
+         sectype    : TAsmSectionType;
+         secsymidx  : longint;   { index for the section in symtab }
+         addralign  : longint;   { alignment of the section }
+         { size of the data and in the file }
+         dataalignbytes : longint;
+         data      : TDynamicArray;
+         datasize,
+         datapos   : aint;
+         { size and position in memory }
+         memsize,
+         mempos    : aint;
+         { relocation }
+         relocations : TLinkedList;
+         constructor create(const Aname:string;Atype:TAsmSectionType;Aalign:longint;Aoptions:TAsmSectionOptions);virtual;
+         destructor  destroy;override;
+         function  write(const d;l:aint):aint;
+         function  writestr(const s:string):aint;
+         procedure writealign(l:longint);
+         function  aligneddatasize:aint;
+         procedure setdatapos(var dpos:aint);
+         procedure alignsection;
+         procedure alloc(l:aint);
+         procedure addsymreloc(ofs:aint;p:tasmsymbol;relative:TAsmRelocationType);
+         procedure addsectionreloc(ofs:aint;sec:TAsmSection;relative:TAsmRelocationType);
+         procedure fixuprelocs;virtual;
+       end;
+       TAsmSectionClass = class of TAsmSection;
+
+       TAsmObjectData = class(TLinkedListItem)
+       private
+         FName      : string[80];
+         FCurrSec   : TAsmSection;
+         { Sections will be stored in order in SectsIndex, this is at least
+           required for stabs debuginfo. The SectsDict is only used for lookups (PFV) }
+         FSectsDict   : TDictionary;
+         FSectsIndex  : TIndexArray;
+         FCAsmSection : TAsmSectionClass;
+         { Symbols that will be defined in this object file }
+         FSymbols   : TIndexArray;
+         { Special info sections that are written to during object generation }
+         FStabsRecSize : longint;
+         FStabsSec,
+         FStabStrSec : TAsmSection;
+         procedure section_reset(p:tnamedindexitem;arg:pointer);
+         procedure section_fixuprelocs(p:tnamedindexitem;arg:pointer);
+       protected
+         property StabsRecSize:longint read FStabsRecSize write FStabsRecSize;
+         property StabsSec:TAsmSection read FStabsSec write FStabsSec;
+         property StabStrSec:TAsmSection read FStabStrSec write FStabStrSec;
+         property CAsmSection:TAsmSectionClass read FCAsmSection write FCAsmSection;
+       public
+         constructor create(const n:string);virtual;
+         destructor  destroy;override;
+         function  sectionname(atype:tasmsectiontype;const aname:string):string;virtual;
+         function  createsection(atype:tasmsectiontype;const aname:string;aalign:longint;aoptions:TAsmSectionOptions):tasmsection;virtual;
+         procedure setsection(asec:tasmsection);
+         procedure alloc(len:aint);
+         procedure allocalign(len:longint);
+         procedure allocstab(p:pchar);
+         procedure allocsymbol(currpass:byte;p:tasmsymbol;len:aint);
+         procedure writebytes(var data;len:aint);
+         procedure writereloc(data,len:aint;p:tasmsymbol;relative:TAsmRelocationType);virtual;abstract;
+         procedure writesymbol(p:tasmsymbol);virtual;abstract;
+         procedure writestab(offset:aint;ps:tasmsymbol;nidx,nother,line:longint;p:pchar);virtual;abstract;
+         procedure beforealloc;virtual;
+         procedure beforewrite;virtual;
+         procedure afteralloc;virtual;
+         procedure afterwrite;virtual;
+         procedure resetsections;
+         procedure fixuprelocs;
+         property Name:string[80] read FName;
+         property CurrSec:TAsmSection read FCurrSec;
+         property Symbols:TindexArray read FSymbols;
+         property Sects:TIndexArray read FSectsIndex;
+       end;
+       TAsmObjectDataClass = class of TAsmObjectData;
+
+       tasmsymbolidxarr = array[0..($7fffffff div sizeof(pointer))-1] of tasmsymbol;
+       pasmsymbolidxarr = ^tasmsymbolidxarr;
+
+       TAsmLibraryData = class(TLinkedListItem)
+       private
+         nextaltnr   : longint;
+         nextlabelnr : array[Tasmlabeltype] of longint;
+       public
+         name,
+         realname     : string[80];
+         symbolsearch : tdictionary; { contains ALL assembler symbols }
+         usedasmsymbollist : tsinglelist;
+         { ppu }
+         asmsymbolppuidx : longint;
+         asmsymbolidx : pasmsymbolidxarr; { used for translating ppu index->asmsymbol }
+         constructor create(const n:string);
+         destructor  destroy;override;
+         procedure Freeasmsymbolidx;
+         procedure DerefAsmsymbol(var s:tasmsymbol);
+         { asmsymbol }
+         function  newasmsymbol(const s : string;_bind:TAsmSymBind;_typ:TAsmsymtype) : tasmsymbol;
+         function  getasmsymbol(const s : string) : tasmsymbol;
+         function  renameasmsymbol(const sold, snew : string):tasmsymbol;
+         function  newasmlabel(nr:longint;alt:tasmlabeltype;is_global:boolean) : tasmlabel;
+         {# create a new assembler label }
+         procedure getlabel(var l : tasmlabel;alt:tasmlabeltype);
+         {# create a new assembler label for jumps }
+         procedure getjumplabel(var l : tasmlabel);
+         { make l as a new label and flag is_addr }
+         procedure getaddrlabel(var l : tasmlabel);
+         { make l as a new label and flag is_data }
+         procedure getdatalabel(var l : tasmlabel);
+         {# return a label number }
+         procedure CreateUsedAsmSymbolList;
+         procedure DestroyUsedAsmSymbolList;
+         procedure UsedAsmSymbolListInsert(p:tasmsymbol);
+         { generate an alternative (duplicate) symbol }
+         procedure GenerateAltSymbol(p:tasmsymbol);
+         { reset alternative symbol information }
+         procedure UsedAsmSymbolListResetAltSym;
+         procedure UsedAsmSymbolListReset;
+         procedure UsedAsmSymbolListCheckUndefined;
+       end;
+
+    const
+      { alt_jump,alt_addr,alt_data,alt_dbgline,alt_dbgfile }
+      asmlabeltypeprefix : array[tasmlabeltype] of char = ('j','a','d','l','f','t');
+
+    var
+      objectlibrary : tasmlibrarydata;
+
+
+implementation
+
+    uses
+      strings,
+      verbose;
+
+    const
+      sectsgrow   = 100;
+      symbolsgrow = 100;
+
+
+{*****************************************************************************
+                                 TAsmSymbol
+*****************************************************************************}
+
+    constructor tasmsymbol.create(const s:string;_bind:TAsmsymbind;_typ:Tasmsymtype);
+      begin;
+        inherited createname(s);
+        reset;
+        defbind:=_bind;
+        typ:=_typ;
+        inusedlist:=false;
+        pass:=255;
+        ppuidx:=-1;
+        { mainly used to remove unused labels from the al_procedures }
+        refs:=0;
+      end;
+
+
+    procedure tasmsymbol.reset;
+      begin
+        { reset section info }
+        section:=nil;
+        address:=0;
+        size:=0;
+        indexnr:=-1;
+        pass:=255;
+        currbind:=AB_EXTERNAL;
+        altsymbol:=nil;
+{        taiowner:=nil;}
+      end;
+
+
+    function tasmsymbol.is_used:boolean;
+      begin
+        is_used:=(refs>0);
+      end;
+
+
+    procedure tasmsymbol.increfs;
+      begin
+        inc(refs);
+      end;
+
+
+    procedure tasmsymbol.decrefs;
+      begin
+        dec(refs);
+        if refs<0 then
+          internalerror(200211121);
+      end;
+
+
+    function tasmsymbol.getrefs: longint;
+      begin
+        getrefs := refs;
+      end;
+
+
+    procedure tasmsymbol.setaddress(_pass:byte;sec:TAsmSection;offset,len:aint);
+      begin
+        if (_pass=pass) then
+         begin
+           Message1(asmw_e_duplicate_label,name);
+           exit;
+         end;
+        pass:=_pass;
+        section:=sec;
+        address:=offset;
+        size:=len;
+        { when the bind was reset to External, set it back to the default
+          bind it got when defined }
+        if (currbind=AB_EXTERNAL) and (defbind<>AB_NONE) then
+         currbind:=defbind;
+      end;
+
+
+{*****************************************************************************
+                                 TAsmLabel
+*****************************************************************************}
+
+    constructor tasmlabel.createlocal(nr:longint;ltyp:TAsmLabelType);
+      begin;
+        inherited create(target_asm.labelprefix+asmlabeltypeprefix[ltyp]+tostr(nr),AB_LOCAL,AT_LABEL);
+        labelnr:=nr;
+        labeltype:=ltyp;
+        is_set:=false;
+      end;
+
+
+    constructor tasmlabel.createglobal(const modulename:string;nr:longint;ltyp:TAsmLabelType);
+      begin;
+        inherited create('_$'+modulename+'$_L'+asmlabeltypeprefix[ltyp]+tostr(nr),AB_GLOBAL,AT_DATA);
+        labelnr:=nr;
+        labeltype:=ltyp;
+        is_set:=false;
+        { write it always }
+        increfs;
+      end;
+
+
+    function tasmlabel.getname:string;
+      begin
+        getname:=inherited getname;
+        increfs;
+      end;
+
+
+{****************************************************************************
+                              TAsmRelocation
+****************************************************************************}
+
+    constructor TAsmRelocation.CreateSymbol(Aaddress:aint;s:Tasmsymbol;Atyp:TAsmRelocationType);
+      begin
+        Address:=Aaddress;
+        Symbol:=s;
+        OrgSize:=0;
+        Section:=nil;
+        Typ:=Atyp;
+      end;
+
+
+    constructor TAsmRelocation.CreateSymbolSize(Aaddress:aint;s:Tasmsymbol;Aorgsize:aint;Atyp:TAsmRelocationType);
+      begin
+        Address:=Aaddress;
+        Symbol:=s;
+        OrgSize:=Aorgsize;
+        Section:=nil;
+        Typ:=Atyp;
+      end;
+
+
+    constructor TAsmRelocation.CreateSection(Aaddress:aint;sec:TAsmSection;Atyp:TAsmRelocationType);
+      begin
+        Address:=Aaddress;
+        Symbol:=nil;
+        OrgSize:=0;
+        Section:=sec;
+        Typ:=Atyp;
+      end;
+
+
+{****************************************************************************
+                              TAsmSection
+****************************************************************************}
+
+    constructor TAsmSection.create(const Aname:string;Atype:TAsmSectionType;Aalign:longint;Aoptions:TAsmSectionOptions);
+      begin
+        inherited createname(Aname);
+        sectype:=Atype;
+        name:=Aname;
+        secoptions:=Aoptions;
+        secsymidx:=0;
+        addralign:=Aalign;
+        { data }
+        datasize:=0;
+        datapos:=0;
+        if (aso_alloconly in aoptions) then
+         data:=nil
+        else
+         Data:=TDynamicArray.Create(8192);
+        { memory }
+        mempos:=0;
+        memsize:=0;
+        { relocation }
+        relocations:=TLinkedList.Create;
+      end;
+
+
+    destructor TAsmSection.destroy;
+      begin
+        if assigned(Data) then
+          Data.Free;
+        relocations.free;
+      end;
+
+
+    function TAsmSection.write(const d;l:aint):aint;
+      begin
+        write:=datasize;
+        if assigned(Data) then
+          Data.write(d,l);
+        inc(datasize,l);
+      end;
+
+
+    function TAsmSection.writestr(const s:string):aint;
+      begin
+        writestr:=datasize;
+        if assigned(Data) then
+          Data.write(s[1],length(s));
+        inc(datasize,length(s));
+      end;
+
+
+    procedure TAsmSection.writealign(l:longint);
+      var
+        i : longint;
+        empty : array[0..63] of char;
+      begin
+        { no alignment needed for 0 or 1 }
+        if l<=1 then
+         exit;
+        i:=datasize mod l;
+        if i>0 then
+         begin
+           if assigned(data) then
+            begin
+              fillchar(empty,sizeof(empty),0);
+              Data.write(empty,l-i);
+            end;
+           inc(datasize,l-i);
+         end;
+      end;
+
+
+    function TAsmSection.aligneddatasize:aint;
+      begin
+        aligneddatasize:=align(datasize,addralign);
+      end;
+
+
+    procedure TAsmSection.setdatapos(var dpos:aint);
+      var
+        alignedpos : aint;
+      begin
+        { get aligned datapos }
+        alignedpos:=align(dpos,addralign);
+        dataalignbytes:=alignedpos-dpos;
+        datapos:=alignedpos;
+        { update datapos }
+        dpos:=datapos+aligneddatasize;
+      end;
+
+
+    procedure TAsmSection.alignsection;
+      begin
+        writealign(addralign);
+      end;
+
+
+    procedure TAsmSection.alloc(l:aint);
+      begin
+        inc(datasize,l);
+      end;
+
+
+    procedure TAsmSection.addsymreloc(ofs:aint;p:tasmsymbol;relative:TAsmRelocationType);
+      var
+        r : TAsmRelocation;
+      begin
+        r:=TAsmRelocation.Create;
+        r.address:=ofs;
+        r.orgsize:=0;
+        r.symbol:=p;
+        r.section:=nil;
+        r.typ:=relative;
+        relocations.concat(r);
+      end;
+
+
+    procedure TAsmSection.addsectionreloc(ofs:aint;sec:TAsmSection;relative:TAsmRelocationType);
+      var
+        r : TAsmRelocation;
+      begin
+        r:=TAsmRelocation.Create;
+        r.address:=ofs;
+        r.symbol:=nil;
+        r.orgsize:=0;
+        r.section:=sec;
+        r.typ:=relative;
+        relocations.concat(r);
+      end;
+
+
+    procedure TAsmSection.fixuprelocs;
+      begin
+      end;
+
+
+{****************************************************************************
+                                TAsmObjectData
+****************************************************************************}
+
+    constructor TAsmObjectData.create(const n:string);
+      begin
+        inherited create;
+        FName:=n;
+        { sections, the SectsIndex owns the items, the FSectsDict
+          is only used for lookups }
+        FSectsDict:=tdictionary.create;
+        FSectsDict.noclear:=true;
+        FSectsIndex:=tindexarray.create(sectsgrow);
+        FStabsRecSize:=1;
+        FStabsSec:=nil;
+        FStabStrSec:=nil;
+        { symbols }
+        FSymbols:=tindexarray.create(symbolsgrow);
+        FSymbols.noclear:=true;
+        { section class type for creating of new sections }
+        FCAsmSection:=TAsmSection;
+      end;
+
+
+    destructor TAsmObjectData.destroy;
+      begin
+        FSectsDict.free;
+        FSectsIndex.free;
+        FSymbols.free;
+      end;
+
+
+    function TAsmObjectData.sectionname(atype:tasmsectiontype;const aname:string):string;
+      const
+        secnames : array[tasmsectiontype] of string[12] = ('',
+          'code','data','rodata','bss','threadvar',
+          'common',
+          'note',
+          'text',
+          'stab','stabstr',
+          'idata2','idata4','idata5','idata6','idata7','edata',
+          'eh_frame',
+          'debug_frame',
+          'fpc'
+        );
+      begin
+        if aname<>'' then
+          result:=secnames[atype]+'.'+aname
+        else
+          result:=secnames[atype];
+      end;
+
+
+    function TAsmObjectData.createsection(atype:tasmsectiontype;const aname:string;aalign:longint;aoptions:TAsmSectionOptions):TAsmSection;
+      var
+        secname : string;
+      begin
+        secname:=sectionname(atype,aname);
+        result:=TasmSection(FSectsDict.search(secname));
+        if not assigned(result) then
+          begin
+{$warning TODO make alloconly configurable}
+            if atype=sec_bss then
+              include(aoptions,aso_alloconly);
+            result:=CAsmSection.create(secname,atype,aalign,aoptions);
+            FSectsDict.Insert(result);
+            FSectsIndex.Insert(result);
+            result.owner:=self;
+          end;
+        FCurrSec:=result;
+      end;
+
+
+    procedure TAsmObjectData.setsection(asec:tasmsection);
+      begin
+        if asec.owner<>self then
+          internalerror(200403041);
+        FCurrSec:=asec;
+      end;
+
+
+    procedure TAsmObjectData.writebytes(var data;len:aint);
+      begin
+        if not assigned(currsec) then
+          internalerror(200402251);
+        currsec.write(data,len);
+      end;
+
+
+    procedure TAsmObjectData.alloc(len:aint);
+      begin
+        if not assigned(currsec) then
+          internalerror(200402252);
+        currsec.alloc(len);
+      end;
+
+
+    procedure TAsmObjectData.allocalign(len:longint);
+      var
+        modulo : aint;
+      begin
+        if not assigned(currsec) then
+          internalerror(200402253);
+        modulo:=currsec.datasize mod len;
+        if modulo > 0 then
+          currsec.alloc(len-modulo);
+      end;
+
+
+    procedure TAsmObjectData.allocsymbol(currpass:byte;p:tasmsymbol;len:aint);
+      begin
+        p.setaddress(currpass,currsec,currsec.datasize,len);
+      end;
+
+
+    procedure TAsmObjectData.allocstab(p:pchar);
+      begin
+        if not(assigned(FStabsSec) and assigned(FStabStrSec)) then
+          internalerror(200402254);
+        FStabsSec.alloc(FStabsRecSize);
+        if assigned(p) and (p[0]<>#0) then
+          FStabStrSec.alloc(strlen(p)+1);
+      end;
+
+
+    procedure TAsmObjectData.section_reset(p:tnamedindexitem;arg:pointer);
+      begin
+        with tasmsection(p) do
+          begin
+            datasize:=0;
+            datapos:=0;
+          end;
+      end;
+
+
+    procedure TAsmObjectData.section_fixuprelocs(p:tnamedindexitem;arg:pointer);
+      begin
+        tasmsection(p).fixuprelocs;
+      end;
+
+
+    procedure TAsmObjectData.beforealloc;
+      begin
+      end;
+
+
+    procedure TAsmObjectData.beforewrite;
+      begin
+      end;
+
+
+    procedure TAsmObjectData.afteralloc;
+      begin
+      end;
+
+
+    procedure TAsmObjectData.afterwrite;
+      begin
+      end;
+
+
+    procedure TAsmObjectData.resetsections;
+      begin
+        FSectsDict.foreach(@section_reset,nil);
+      end;
+
+
+    procedure TAsmObjectData.fixuprelocs;
+      begin
+        FSectsDict.foreach(@section_fixuprelocs,nil);
+      end;
+
+
+{****************************************************************************
+                                TAsmLibraryData
+****************************************************************************}
+
+    constructor TAsmLibraryData.create(const n:string);
+      var
+        alt : TAsmLabelType;
+      begin
+        inherited create;
+        realname:=n;
+        name:=upper(n);
+        { symbols }
+        symbolsearch:=tdictionary.create;
+        symbolsearch.usehash;
+        { labels }
+        nextaltnr:=1;
+        for alt:=low(TAsmLabelType) to high(TAsmLabelType) do
+          nextlabelnr[alt]:=1;
+        { ppu }
+        asmsymbolppuidx:=0;
+        asmsymbolidx:=nil;
+      end;
+
+
+    destructor TAsmLibraryData.destroy;
+      begin
+        symbolsearch.free;
+        Freeasmsymbolidx;
+      end;
+
+
+    procedure TAsmLibraryData.Freeasmsymbolidx;
+      begin
+        if assigned(asmsymbolidx) then
+         begin
+           Freemem(asmsymbolidx);
+           asmsymbolidx:=nil;
+         end;
+      end;
+
+
+    procedure TAsmLibraryData.DerefAsmsymbol(var s:tasmsymbol);
+      begin
+        if assigned(s) then
+         begin
+           if not assigned(asmsymbolidx) then
+             internalerror(200208072);
+           if (ptrint(pointer(s))<1) or (ptrint(pointer(s))>asmsymbolppuidx) then
+             internalerror(200208073);
+           s:=asmsymbolidx^[ptrint(pointer(s))-1];
+         end;
+      end;
+
+
+    function TAsmLibraryData.newasmsymbol(const s : string;_bind:TAsmSymBind;_typ:Tasmsymtype) : tasmsymbol;
+      var
+        hp : tasmsymbol;
+      begin
+        hp:=tasmsymbol(symbolsearch.search(s));
+        if assigned(hp) then
+         begin
+           {$IFDEF EXTDEBUG}
+           if (_typ <> AT_NONE) and
+              (hp.typ <> _typ) and
+              not(cs_compilesystem in aktmoduleswitches) then
+             begin
+               //Writeln('Error symbol '+hp.name+' type is ',Ord(_typ),', should be ',Ord(hp.typ));
+               InternalError(2004031501);
+             end;
+           {$ENDIF}
+           if (_bind<>AB_EXTERNAL) then
+             hp.defbind:=_bind
+         end
+        else
+         begin
+           { Not found, insert it. }
+           hp:=tasmsymbol.create(s,_bind,_typ);
+           symbolsearch.insert(hp);
+         end;
+        newasmsymbol:=hp;
+      end;
+
+
+    function TAsmLibraryData.getasmsymbol(const s : string) : tasmsymbol;
+      begin
+        getasmsymbol:=tasmsymbol(symbolsearch.search(s));
+      end;
+
+
+    function TAsmLibraryData.renameasmsymbol(const sold, snew : string):tasmsymbol;
+      begin
+        renameasmsymbol:=tasmsymbol(symbolsearch.rename(sold,snew));
+      end;
+
+
+    procedure TAsmLibraryData.CreateUsedAsmSymbolList;
+      begin
+        if assigned(usedasmsymbollist) then
+         internalerror(78455782);
+        usedasmsymbollist:=TSingleList.create;
+      end;
+
+
+    procedure TAsmLibraryData.DestroyUsedAsmSymbolList;
+      begin
+        usedasmsymbollist.destroy;
+        usedasmsymbollist:=nil;
+      end;
+
+
+    procedure TAsmLibraryData.UsedAsmSymbolListInsert(p:tasmsymbol);
+      begin
+        if not p.inusedlist then
+         usedasmsymbollist.insert(p);
+        p.inusedlist:=true;
+      end;
+
+
+    procedure TAsmLibraryData.GenerateAltSymbol(p:tasmsymbol);
+      begin
+        if not assigned(p.altsymbol) then
+         begin
+           p.altsymbol:=tasmsymbol.create(p.name+'_'+tostr(nextaltnr),p.defbind,p.typ);
+           symbolsearch.insert(p.altsymbol);
+           { add also the original sym to the usedasmsymbollist,
+             that list is used to reset the altsymbol }
+           if not p.inusedlist then
+            usedasmsymbollist.insert(p);
+           p.inusedlist:=true;
+         end;
+      end;
+
+
+    procedure TAsmLibraryData.UsedAsmSymbolListReset;
+      var
+        hp : tasmsymbol;
+      begin
+        hp:=tasmsymbol(usedasmsymbollist.first);
+        while assigned(hp) do
+         begin
+           with hp do
+            begin
+              reset;
+              inusedlist:=false;
+            end;
+           hp:=tasmsymbol(hp.listnext);
+         end;
+      end;
+
+
+    procedure TAsmLibraryData.UsedAsmSymbolListResetAltSym;
+      var
+        hp : tasmsymbol;
+      begin
+        hp:=tasmsymbol(usedasmsymbollist.first);
+        inc(nextaltnr);
+        while assigned(hp) do
+         begin
+           with hp do
+            begin
+              altsymbol:=nil;
+              inusedlist:=false;
+            end;
+           hp:=tasmsymbol(hp.listnext);
+         end;
+      end;
+
+
+    procedure TAsmLibraryData.UsedAsmSymbolListCheckUndefined;
+      var
+        hp : tasmsymbol;
+      begin
+        hp:=tasmsymbol(usedasmsymbollist.first);
+        while assigned(hp) do
+         begin
+           with hp do
+            begin
+              if is_used and
+                 (section=nil) and
+                 not(currbind in [AB_EXTERNAL,AB_COMMON]) then
+               Message1(asmw_e_undefined_label,name);
+            end;
+           hp:=tasmsymbol(hp.listnext);
+         end;
+      end;
+
+
+    function  TAsmLibraryData.newasmlabel(nr:longint;alt:tasmlabeltype;is_global:boolean) : tasmlabel;
+      var
+        hp : tasmlabel;
+      begin
+        if is_global then
+         hp:=tasmlabel.createglobal(name,nr,alt)
+       else
+         hp:=tasmlabel.createlocal(nr,alt);
+        symbolsearch.insert(hp);
+        newasmlabel:=hp;
+      end;
+
+
+    procedure TAsmLibraryData.getlabel(var l : tasmlabel;alt:tasmlabeltype);
+      begin
+        l:=tasmlabel.createlocal(nextlabelnr[alt],alt);
+        inc(nextlabelnr[alt]);
+        symbolsearch.insert(l);
+      end;
+
+    procedure TAsmLibraryData.getjumplabel(var l : tasmlabel);
+      begin
+        l:=tasmlabel.createlocal(nextlabelnr[alt_jump],alt_jump);
+        inc(nextlabelnr[alt_jump]);
+        symbolsearch.insert(l);
+      end;
+
+
+    procedure TAsmLibraryData.getdatalabel(var l : tasmlabel);
+      begin
+        l:=tasmlabel.createglobal(name,nextlabelnr[alt_data],alt_data);
+        inc(nextlabelnr[alt_data]);
+        symbolsearch.insert(l);
+      end;
+
+
+    procedure TAsmLibraryData.getaddrlabel(var l : tasmlabel);
+      begin
+        l:=tasmlabel.createlocal(nextlabelnr[alt_addr],alt_addr);
+        inc(nextlabelnr[alt_addr]);
+        symbolsearch.insert(l);
+      end;
+
+
+end.

+ 2349 - 0
compiler/aasmtai.pas

@@ -0,0 +1,2349 @@
+{
+    Copyright (c) 1998-2002 by Florian Klaempfl
+
+    This unit implements an abstract asmoutput class for all processor types
+
+    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(This unit implements an abstract asm output class for all processor types)
+  This unit implements an abstract assembler output class for all processors, these
+  are then overriden for each assembler writer to actually write the data in these
+  classes to an assembler file.
+}
+
+unit aasmtai;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+       cutils,cclasses,
+       globtype,globals,systems,
+       cpuinfo,cpubase,
+       cgbase,cgutils,
+       symtype,
+       aasmbase;
+
+    type
+       taitype = (
+          ait_none,
+          ait_align,
+          ait_section,
+          ait_comment,
+          ait_string,
+          ait_instruction,
+          ait_datablock,
+          ait_symbol,
+          ait_symbol_end, { needed to calc the size of a symbol }
+          ait_directive,
+          ait_label,
+          { the const_xx must be below each other so it can be used as
+            array index }
+          ait_const_128bit,
+          ait_const_64bit,
+          ait_const_32bit,
+          ait_const_16bit,
+          ait_const_8bit,
+          ait_const_sleb128bit,
+          ait_const_uleb128bit,
+          ait_const_rva_symbol, { win32 only }
+          ait_const_indirect_symbol, { darwin only }
+          ait_real_32bit,
+          ait_real_64bit,
+          ait_real_80bit,
+          ait_comp_64bit,
+          ait_real_128bit,
+          ait_stab,
+          ait_force_line,
+          ait_function_name,
+{$ifdef alpha}
+          { the follow is for the DEC Alpha }
+          ait_frame,
+          ait_ent,
+{$endif alpha}
+{$ifdef ia64}
+          ait_bundle,
+          ait_stop,
+{$endif ia64}
+{$ifdef m68k}
+          ait_labeled_instruction,
+{$endif m68k}
+          { used to split into tiny assembler files }
+          ait_cutobject,
+          ait_regalloc,
+          ait_tempalloc,
+          { used to mark assembler blocks and inlined functions }
+          ait_marker
+          );
+
+    const
+{$ifdef cpu64bit}
+       ait_const_aint = ait_const_64bit;
+       ait_const_ptr  = ait_const_64bit;
+{$else cpu64bit}
+       ait_const_aint = ait_const_32bit;
+       ait_const_ptr  = ait_const_32bit;
+{$endif cpu64bit}
+
+       taitypestr : array[taitype] of string[24] = (
+          '<none>',
+          'align',
+          'section',
+          'comment',
+          'string',
+          'instruction',
+          'datablock',
+          'symbol',
+          'symbol_end',
+          'symbol_directive',
+          'label',
+          'const_128bit',
+          'const_64bit',
+          'const_32bit',
+          'const_16bit',
+          'const_8bit',
+          'const_sleb128bit',
+          'const_uleb128bit',
+          'const_rva_symbol',
+          'const_indirect_symbol',
+          'real_32bit',
+          'real_64bit',
+          'real_80bit',
+          'comp_64bit',
+          'real_128bit',
+          'stab',
+          'force_line',
+          'function_name',
+{$ifdef alpha}
+          { the follow is for the DEC Alpha }
+          'frame',
+          'ent',
+{$endif alpha}
+{$ifdef ia64}
+          'bundle',
+          'stop',
+{$endif ia64}
+{$ifdef m68k}
+          'labeled_instr',
+{$endif m68k}
+          'cut',
+          'regalloc',
+          'tempalloc',
+          'marker'
+          );
+
+    type
+      { Types of operand }
+      toptype=(top_none,top_reg,top_ref,top_const,top_bool,top_local
+{$ifdef arm}
+       { ARM only }
+       ,top_regset
+       ,top_shifterop
+{$endif arm}
+{$ifdef m68k}
+       { m68k only }
+       ,top_regset
+{$endif m68k}
+       { i386 only});
+
+      { kinds of operations that an instruction can perform on an operand }
+      topertype = (operand_read,operand_write,operand_readwrite);
+
+      tlocaloper = record
+        localsym : pointer;
+        localsymderef : tderef;
+        localsymofs : longint;
+        localindexreg : tregister;
+        localscale : byte;
+        localgetoffset,
+        localforceref : boolean
+      end;
+      plocaloper = ^tlocaloper;
+
+      { please keep the size of this record <=12 bytes and keep it properly aligned }
+      toper = record
+        ot : longint;
+        case typ : toptype of
+          top_none   : ();
+          top_reg    : (reg:tregister);
+          top_ref    : (ref:preference);
+          top_const  : (val:aint);
+          top_bool   : (b:boolean);
+          { local varsym that will be inserted in pass_2 }
+          top_local  : (localoper:plocaloper);
+      {$ifdef arm}
+          top_regset : (regset:^tcpuregisterset);
+          top_shifterop : (shifterop : pshifterop);
+      {$endif arm}
+      {$ifdef m68k}
+          top_regset : (regset:^tcpuregisterset);
+      {$endif m68k}
+      end;
+      poper=^toper;
+
+{ ait_* types which don't result in executable code or which don't influence   }
+{ the way the program runs/behaves, but which may be encountered by the        }
+{ optimizer (= if it's sometimes added to the exprasm list). Update if you add }
+{ a new ait type!                                                              }
+    const
+      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_* types which do not have line information (and hence which are of type
+  tai, otherwise, they are of type tailineinfo }
+      SkipLineInfo =[ait_label,
+                     ait_regalloc,ait_tempalloc,
+                     ait_stab,ait_function_name,
+                     ait_cutobject,ait_marker,ait_align,ait_section,ait_comment,
+                     ait_const_8bit,ait_const_16bit,ait_const_32bit,ait_const_64bit,ait_const_128bit,
+                     ait_const_sleb128bit,ait_const_uleb128bit,
+                     ait_const_rva_symbol,ait_const_indirect_symbol,
+                     ait_real_32bit,ait_real_64bit,ait_real_80bit,ait_comp_64bit,ait_real_128bit
+                    ];
+
+
+    type
+       { cut type, required for alphanumeric ordering of the assembler filenames }
+       TCutPlace=(cut_normal,cut_begin,cut_end);
+
+       TRegAllocType = (ra_alloc,ra_dealloc,ra_sync,ra_resize);
+
+       TMarker = (NoPropInfoStart,NoPropInfoEnd,
+                  AsmBlockStart,AsmBlockEnd,
+                  InlineStart,InlineEnd,marker_blockstart,
+                  marker_position);
+
+       { Buffer type used for alignment }
+       tfillbuffer = array[0..63] of char;
+
+       Tspill_temp_list=array[tsuperregister] of Treference;
+
+       { abstract assembler item }
+       tai = class(TLinkedListItem)
+{$ifndef NOOPT}
+          { pointer to record with optimizer info about this tai object }
+          optinfo  : pointer;
+{$endif NOOPT}
+          typ      : taitype;
+          constructor Create;
+          constructor ppuload(t:taitype;ppufile:tcompilerppufile);virtual;
+          procedure ppuwrite(ppufile:tcompilerppufile);virtual;
+          procedure buildderefimpl;virtual;
+          procedure derefimpl;virtual;
+       end;
+
+       { abstract assembler item with line information }
+       tailineinfo = class(tai)
+        fileinfo : tfileposinfo;
+        constructor Create;
+        constructor ppuload(t:taitype;ppufile:tcompilerppufile);override;
+        procedure ppuwrite(ppufile:tcompilerppufile);override;
+       end;
+
+       tai_simple = class(tai)
+         constructor create(_typ : taitype);
+       end;
+
+       taiclass = class of tai;
+
+       taiclassarray = array[taitype] of taiclass;
+
+       { Generates an assembler string }
+       tai_string = class(tailineinfo)
+          str : pchar;
+          { extra len so the string can contain an \0 }
+          len : longint;
+          constructor Create(const _str : string);
+          constructor Create_pchar(_str : pchar;length : longint);
+          destructor Destroy;override;
+          constructor ppuload(t:taitype;ppufile:tcompilerppufile);override;
+          procedure ppuwrite(ppufile:tcompilerppufile);override;
+          function getcopy:tlinkedlistitem;override;
+       end;
+
+       { Generates a common label }
+       tai_symbol = class(tailineinfo)
+          is_global : boolean;
+          sym       : tasmsymbol;
+          size      : longint;
+          constructor Create(_sym:tasmsymbol;siz:longint);
+          constructor Create_Global(_sym:tasmsymbol;siz:longint);
+          constructor Createname(const _name : string;_symtyp:Tasmsymtype;siz:longint);
+          constructor Createname_global(const _name : string;_symtyp:Tasmsymtype;siz:longint);
+          constructor ppuload(t:taitype;ppufile:tcompilerppufile);override;
+          procedure ppuwrite(ppufile:tcompilerppufile);override;
+          procedure derefimpl;override;
+       end;
+
+       tai_symbol_end = class(tailineinfo)
+          sym : tasmsymbol;
+          constructor Create(_sym:tasmsymbol);
+          constructor Createname(const _name : string);
+          constructor ppuload(t:taitype;ppufile:tcompilerppufile);override;
+          procedure ppuwrite(ppufile:tcompilerppufile);override;
+          procedure derefimpl;override;
+       end;
+
+       tasmdirective=(asd_non_lazy_symbol_pointer,asd_indirect_symbol,asd_lazy_symbol_pointer,
+                      asd_extern,asd_nasm_import);
+
+       tai_directive = class(tailineinfo)
+          name : pstring;
+          directive : tasmdirective;
+          constructor Create(_directive:tasmdirective;const _name:string);
+          destructor Destroy;override;
+          constructor ppuload(t:taitype;ppufile:tcompilerppufile);override;
+          procedure ppuwrite(ppufile:tcompilerppufile);override;
+       end;
+
+       { Generates an assembler label }
+       tai_label = class(tai)
+          is_global : boolean;
+          l         : tasmlabel;
+          constructor Create(_l : tasmlabel);
+          constructor ppuload(t:taitype;ppufile:tcompilerppufile);override;
+          procedure ppuwrite(ppufile:tcompilerppufile);override;
+          procedure derefimpl;override;
+       end;
+
+       { Generates an assembler comment }
+       tai_comment = class(tai)
+          str : pchar;
+          constructor Create(_str : pchar);
+          destructor Destroy; override;
+          constructor ppuload(t:taitype;ppufile:tcompilerppufile);override;
+          procedure ppuwrite(ppufile:tcompilerppufile);override;
+          function getcopy:tlinkedlistitem;override;
+       end;
+
+
+       { Generates a section / segment directive }
+       tai_section = class(tai)
+          sectype : TAsmSectionType;
+          secalign : byte;
+          name    : pstring;
+          sec     : TAsmSection; { used in binary writer }
+          constructor Create(Asectype:TAsmSectionType;Aname:string;Aalign:byte);
+          destructor Destroy;override;
+          constructor ppuload(t:taitype;ppufile:tcompilerppufile);override;
+          procedure ppuwrite(ppufile:tcompilerppufile);override;
+       end;
+
+
+       { Generates an uninitializised data block }
+       tai_datablock = class(tailineinfo)
+          is_global : boolean;
+          sym       : tasmsymbol;
+          size      : longint;
+          constructor Create(const _name : string;_size : longint);
+          constructor Create_global(const _name : string;_size : longint);
+          constructor ppuload(t:taitype;ppufile:tcompilerppufile);override;
+          procedure ppuwrite(ppufile:tcompilerppufile);override;
+          procedure derefimpl;override;
+       end;
+
+
+       { Generates an integer const }
+       tai_const = class(tai)
+          sym,
+          endsym  : tasmsymbol;
+          value   : int64;
+          { we use for the 128bit int64/qword for now because I can't imagine a
+            case where we need 128 bit now (FK) }
+          constructor Create(_typ:taitype;_value : int64);
+          constructor Create_128bit(_value : int64);
+          constructor Create_64bit(_value : int64);
+          constructor Create_32bit(_value : longint);
+          constructor Create_16bit(_value : word);
+          constructor Create_8bit(_value : byte);
+          constructor Create_sleb128bit(_value : int64);
+          constructor Create_uleb128bit(_value : qword);
+          constructor Create_aint(_value : aint);
+          constructor Create_sym(_sym:tasmsymbol);
+          constructor Create_sym_offset(_sym:tasmsymbol;ofs:aint);
+          constructor Create_rel_sym(_typ:taitype;_sym,_endsym:tasmsymbol);
+          constructor Create_rva_sym(_sym:tasmsymbol);
+          constructor Create_indirect_sym(_sym:tasmsymbol);
+          constructor Createname(const name:string;_symtyp:Tasmsymtype;ofs:aint);
+          constructor Createname_rva(const name:string);
+          constructor ppuload(t:taitype;ppufile:tcompilerppufile);override;
+          procedure ppuwrite(ppufile:tcompilerppufile);override;
+          procedure derefimpl;override;
+          function getcopy:tlinkedlistitem;override;
+          function size:longint;
+       end;
+
+       { Generates a single float (32 bit real) }
+       tai_real_32bit = class(tai)
+          value : ts32real;
+          constructor Create(_value : ts32real);
+          constructor ppuload(t:taitype;ppufile:tcompilerppufile);override;
+          procedure ppuwrite(ppufile:tcompilerppufile);override;
+       end;
+
+       tformatoptions = (fo_none,fo_hiloswapped);
+
+       { Generates a double float (64 bit real) }
+       tai_real_64bit = class(tai)
+          value : ts64real;
+{$ifdef ARM}
+          formatoptions : tformatoptions;
+          constructor Create_hiloswapped(_value : ts64real);
+{$endif ARM}
+          constructor Create(_value : ts64real);
+          constructor ppuload(t:taitype;ppufile:tcompilerppufile);override;
+          procedure ppuwrite(ppufile:tcompilerppufile);override;
+       end;
+
+
+       { Generates an extended float (80 bit real) }
+       tai_real_80bit = class(tai)
+          value : ts80real;
+          constructor Create(_value : ts80real);
+          constructor ppuload(t:taitype;ppufile:tcompilerppufile);override;
+          procedure ppuwrite(ppufile:tcompilerppufile);override;
+       end;
+
+
+       { Generates an float128 (128 bit real) }
+       tai_real_128bit = class(tai)
+          value : ts128real;
+          constructor Create(_value : ts128real);
+          constructor ppuload(t:taitype;ppufile:tcompilerppufile);override;
+          procedure ppuwrite(ppufile:tcompilerppufile);override;
+       end;
+
+       { Generates a comp int (integer over 64 bits)
+
+          This is Intel 80x86 specific, and is not
+          really supported on other processors.
+       }
+       tai_comp_64bit = class(tai)
+          value : ts64comp;
+          constructor Create(_value : ts64comp);
+          constructor ppuload(t:taitype;ppufile:tcompilerppufile);override;
+          procedure ppuwrite(ppufile:tcompilerppufile);override;
+       end;
+
+       tstabtype = (stab_stabs,stab_stabn,stab_stabd);
+
+       tai_stab = class(tai)
+          str : pchar;
+          stabtype : tstabtype;
+          constructor Create(_stabtype:tstabtype;_str : pchar);
+          constructor Create_str(_stabtype:tstabtype;const s:string);
+          destructor Destroy;override;
+       end;
+
+       tai_force_line = class(tailineinfo)
+          constructor Create;
+       end;
+
+       tai_function_name = class(tai)
+          funcname : pstring;
+          constructor create(const s:string);
+          destructor destroy;override;
+       end;
+
+       { Insert a cut to split assembler into several smaller files }
+       tai_cutobject = class(tai)
+          place : tcutplace;
+          constructor Create;
+          constructor Create_begin;
+          constructor Create_end;
+          constructor ppuload(t:taitype;ppufile:tcompilerppufile);override;
+          procedure ppuwrite(ppufile:tcompilerppufile);override;
+       end;
+
+       { Insert a marker for assembler and inline blocks }
+       tai_marker = class(tai)
+          Kind: TMarker;
+          Constructor Create(_Kind: TMarker);
+          constructor ppuload(t:taitype;ppufile:tcompilerppufile);override;
+          procedure ppuwrite(ppufile:tcompilerppufile);override;
+       end;
+
+       tai_tempalloc = class(tai)
+          allocation : boolean;
+{$ifdef EXTDEBUG}
+          problem : pstring;
+{$endif EXTDEBUG}
+          temppos,
+          tempsize   : longint;
+          constructor alloc(pos,size:longint);
+          constructor dealloc(pos,size:longint);
+{$ifdef EXTDEBUG}
+          constructor allocinfo(pos,size:longint;const st:string);
+{$endif EXTDEBUG}
+          constructor ppuload(t:taitype;ppufile:tcompilerppufile);override;
+          destructor destroy;override;
+          procedure ppuwrite(ppufile:tcompilerppufile);override;
+       end;
+
+       tai_regalloc = class(tai)
+          reg     : tregister;
+          ratype  : TRegAllocType;
+          { reg(de)alloc belongs to this instruction, this
+            is only used for automatic inserted (de)alloc for
+            imaginary register and required for spilling code }
+          instr   : tai;
+          constructor alloc(r : tregister;ainstr:tai);
+          constructor dealloc(r : tregister;ainstr:tai);
+          constructor sync(r : tregister);
+          constructor resize(r : tregister);
+          constructor ppuload(t:taitype;ppufile:tcompilerppufile);override;
+          procedure ppuwrite(ppufile:tcompilerppufile);override;
+       end;
+
+      Taasmoutput=class;
+
+      tadd_reg_instruction_proc=procedure(instr:Tai;r:tregister) of object;
+      Trggetproc=procedure(list:Taasmoutput;position:Tai;subreg:Tsubregister;var result:Tregister) of object;
+      Trgungetproc=procedure(list:Taasmoutput;position:Tai;r:Tregister) of object;
+
+       { Class template for assembler instructions
+       }
+       tai_cpu_abstract = class(tailineinfo)
+       protected
+          procedure ppuloadoper(ppufile:tcompilerppufile;var o:toper);virtual;abstract;
+          procedure ppuwriteoper(ppufile:tcompilerppufile;const o:toper);virtual;abstract;
+          procedure ppubuildderefimploper(var o:toper);virtual;abstract;
+          procedure ppuderefoper(var o:toper);virtual;abstract;
+       public
+          { Condition flags for instruction }
+          condition : TAsmCond;
+          { Number of operands to instruction }
+          ops       : byte;
+          { Number of allocate oper structures }
+          opercnt   : byte;
+          { Operands of instruction }
+          oper      : array[0..max_operands-1] of poper;
+          { Actual opcode of instruction }
+          opcode    : tasmop;
+{$ifdef x86}
+          segprefix : tregister;
+{$endif x86}
+          { true if instruction is a jmp }
+          is_jmp    : boolean; { is this instruction a jump? (needed for optimizer) }
+          Constructor Create(op : tasmop);virtual;
+          Destructor Destroy;override;
+          function getcopy:TLinkedListItem;override;
+          constructor ppuload(t:taitype;ppufile:tcompilerppufile);override;
+          procedure ppuwrite(ppufile:tcompilerppufile);override;
+          procedure buildderefimpl;override;
+          procedure derefimpl;override;
+          procedure SetCondition(const c:TAsmCond);
+          procedure allocate_oper(opers:longint);
+          procedure loadconst(opidx:longint;l:aint);
+          procedure loadsymbol(opidx:longint;s:tasmsymbol;sofs:longint);
+          procedure loadlocal(opidx:longint;s:pointer;sofs:longint;indexreg:tregister;scale:byte;getoffset,forceref:boolean);
+          procedure loadref(opidx:longint;const r:treference);
+          procedure loadreg(opidx:longint;r:tregister);
+          procedure loadoper(opidx:longint;o:toper);
+          procedure clearop(opidx:longint);
+          { register allocator }
+          function is_same_reg_move(regtype: Tregistertype):boolean;virtual;
+          function spilling_get_operation_type(opnr: longint): topertype;virtual;
+          function spilling_get_operation_type_ref(opnr: longint; reg: tregister): topertype;virtual;
+
+          function  Pass1(offset:longint):longint;virtual;abstract;
+          procedure Pass2(objdata:TAsmObjectdata);virtual;abstract;
+       end;
+       tai_cpu_class = class of tai_cpu_abstract;
+
+       { alignment for operator }
+       tai_align_abstract = class(tai)
+          aligntype : byte;   { 1 = no align, 2 = word align, 4 = dword align }
+          fillsize  : byte;   { real size to fill }
+          fillop    : byte;   { value to fill with - optional }
+          use_op    : boolean;
+          constructor Create(b:byte);virtual;
+          constructor Create_op(b: byte; _op: byte);virtual;
+          constructor Create_zeros(b:byte);
+          constructor ppuload(t:taitype;ppufile:tcompilerppufile);override;
+          procedure ppuwrite(ppufile:tcompilerppufile);override;
+          function calculatefillbuf(var buf : tfillbuffer):pchar;virtual;
+       end;
+       tai_align_class = class of tai_align_abstract;
+
+       taasmoutput = class(tlinkedlist)
+          constructor create;
+          function  empty : boolean;
+          function  getlasttaifilepos : pfileposinfo;
+          procedure InsertAfter(Item,Loc : TLinkedListItem);override;
+       end;
+
+       { Type of asmlists. The order is important for the layout of the
+         information in the .o file. The stabs for the types must be defined
+         before they can be referenced and therefor they need to be written
+         first (PFV) }
+       Tasmlist=(al_stabsstart,
+                 al_stabs,
+                 al_procedures,
+                 al_globals,
+                 al_const,
+                 al_typedconsts,
+                 al_rotypedconsts,
+                 al_threadvars,
+                 al_imports,
+                 al_exports,
+                 al_resources,
+                 al_rtti,
+                 al_dwarf,
+                 al_picdata,
+                 al_resourcestrings,
+                 al_stabsend);
+    const
+       TasmlistStr : array[tasmlist] of string[24] =(
+           'al_stabsstart',
+           'al_stabs',
+           'al_procedures',
+           'al_globals',
+           'al_const',
+           'al_typedconsts',
+           'al_rotypedconsts',
+           'al_threadvars',
+           'al_imports',
+           'al_exports',
+           'al_resources',
+           'al_rtti',
+           'al_dwarf',
+           'al_picdata',
+           'al_resourcestrings',
+           'al_stabsend');
+
+      regallocstr : array[tregalloctype] of string[10]=('allocated','released','sync','resized');
+      tempallocstr : array[boolean] of string[10]=('released','allocated');
+      stabtypestr : array[tstabtype] of string[5]=('stabs','stabn','stabd');
+      directivestr : array[tasmdirective] of string[24]=(
+        'non_lazy_symbol_pointer','indirect_symbol','lazy_symbol_pointer',
+        'extern','nasm_import'
+      );
+
+    var
+      { array with all class types for tais }
+      aiclass : taiclassarray;
+
+      { Current expression list }
+      exprasmlist : taasmoutput;
+
+      { labels for BREAK and CONTINUE }
+      aktbreaklabel,aktcontinuelabel : tasmlabel;
+
+      { label when the result is true or false }
+      truelabel,falselabel : tasmlabel;
+
+      { hook to notify uses of registers }
+      add_reg_instruction_hook : tadd_reg_instruction_proc;
+
+      asmlist:array[Tasmlist] of Taasmoutput;
+
+      cai_align : tai_align_class;
+      cai_cpu   : tai_cpu_class;
+
+    function  use_smartlink_section:boolean;
+    function  maybe_smartlink_symbol:boolean;
+
+    procedure maybe_new_object_file(list:taasmoutput);
+    procedure new_section(list:taasmoutput;Asectype:TAsmSectionType;Aname:string;Aalign:byte);
+    procedure section_symbol_start(list:taasmoutput;const Aname:string;Asymtyp:Tasmsymtype;
+                                   Aglobal:boolean;Asectype:TAsmSectionType;Aalign:byte);
+    procedure section_symbol_end(list:taasmoutput;const Aname:string);
+
+    function ppuloadai(ppufile:tcompilerppufile):tai;
+    procedure ppuwriteai(ppufile:tcompilerppufile;n:tai);
+
+
+implementation
+
+    uses
+      strings,
+      verbose;
+
+    const
+      pputaimarker = 254;
+
+
+{****************************************************************************
+                                 Helpers
+ ****************************************************************************}
+
+    function ppuloadai(ppufile:tcompilerppufile):tai;
+      var
+        b : byte;
+        t : taitype;
+      begin
+        { marker }
+        b:=ppufile.getbyte;
+        if b<>pputaimarker then
+          internalerror(200208181);
+        { load nodetype }
+        t:=taitype(ppufile.getbyte);
+        if t<>ait_none then
+         begin
+           if t>high(taitype) then
+             internalerror(200208182);
+           if not assigned(aiclass[t]) then
+             internalerror(200208183);
+           {writeln('taiload: ',taitypestr[t]);}
+           { generate tai of the correct class }
+           ppuloadai:=aiclass[t].ppuload(t,ppufile);
+         end
+        else
+         ppuloadai:=nil;
+      end;
+
+
+    procedure ppuwriteai(ppufile:tcompilerppufile;n:tai);
+      begin
+        { marker, read by ppuloadnode }
+        ppufile.putbyte(pputaimarker);
+        if assigned(n) then
+         begin
+           { type, read by ppuloadnode }
+           ppufile.putbyte(byte(n.typ));
+           {writeln('taiwrite: ',taitypestr[n.typ]);}
+           n.ppuwrite(ppufile);
+         end
+        else
+         ppufile.putbyte(byte(ait_none));
+      end;
+
+
+    function use_smartlink_section:boolean;
+      begin
+        result:=(af_smartlink_sections in target_asm.flags) and
+                (tf_smartlink_sections in target_info.flags);
+      end;
+
+
+    function maybe_smartlink_symbol:boolean;
+      begin
+        result:=(cs_create_smart in aktmoduleswitches) or
+                use_smartlink_section;
+      end;
+
+
+    procedure maybe_new_object_file(list:taasmoutput);
+      begin
+        if (cs_create_smart in aktmoduleswitches) and
+           (not use_smartlink_section) then
+          list.concat(tai_cutobject.create);
+      end;
+
+
+    procedure new_section(list:taasmoutput;Asectype:TAsmSectionType;Aname:string;Aalign:byte);
+      begin
+        list.concat(tai_section.create(Asectype,Aname,Aalign));
+        list.concat(cai_align.create(Aalign));
+      end;
+
+
+    procedure section_symbol_start(list:taasmoutput;const Aname:string;Asymtyp:Tasmsymtype;
+                                   Aglobal:boolean;Asectype:TAsmSectionType;Aalign:byte);
+      begin
+        maybe_new_object_file(list);
+        list.concat(tai_section.create(Asectype,Aname,Aalign));
+        list.concat(cai_align.create(Aalign));
+        if Aglobal or
+           maybe_smartlink_symbol then
+          list.concat(tai_symbol.createname_global(Aname,Asymtyp,0))
+        else
+          list.concat(tai_symbol.createname(Aname,Asymtyp,0));
+      end;
+
+
+    procedure section_symbol_end(list:taasmoutput;const Aname:string);
+      begin
+        list.concat(tai_symbol_end.createname(Aname));
+      end;
+
+
+{****************************************************************************
+                             TAI
+ ****************************************************************************}
+
+    constructor tai.Create;
+      begin
+{$ifndef NOOPT}
+        optinfo:=nil;
+{$endif NOOPT}
+      end;
+
+
+    constructor tai.ppuload(t:taitype;ppufile:tcompilerppufile);
+      begin
+        typ:=t;
+{$ifndef NOOPT}
+        optinfo:=nil;
+{$endif}
+      end;
+
+
+    procedure tai.ppuwrite(ppufile:tcompilerppufile);
+      begin
+      end;
+
+
+    procedure tai.buildderefimpl;
+      begin
+      end;
+
+
+    procedure tai.derefimpl;
+      begin
+      end;
+
+
+{****************************************************************************
+                              TAILINEINFO
+ ****************************************************************************}
+
+    constructor tailineinfo.create;
+     begin
+       inherited create;
+       if not(inlining_procedure and
+              (cs_gdb_valgrind in aktglobalswitches)) then
+         fileinfo:=aktfilepos;
+     end;
+
+
+    constructor tailineinfo.ppuload(t:taitype;ppufile:tcompilerppufile);
+      begin
+        inherited ppuload(t,ppufile);
+        ppufile.getposinfo(fileinfo);
+      end;
+
+
+    procedure tailineinfo.ppuwrite(ppufile:tcompilerppufile);
+      begin
+        inherited ppuwrite(ppufile);
+        ppufile.putposinfo(fileinfo);
+      end;
+
+
+{****************************************************************************
+                              TAI_SIMPLE
+ ****************************************************************************}
+
+    constructor tai_simple.create(_typ : taitype);
+      begin
+        inherited create;
+        typ:=_typ;
+      end;
+
+
+{****************************************************************************
+                             TAI_SECTION
+ ****************************************************************************}
+
+    constructor tai_section.Create(Asectype:TAsmSectionType;Aname:string;Aalign:byte);
+      begin
+        inherited Create;
+        typ:=ait_section;
+        sectype:=asectype;
+        secalign:=Aalign;
+        name:=stringdup(Aname);
+        sec:=nil;
+      end;
+
+
+    constructor tai_section.ppuload(t:taitype;ppufile:tcompilerppufile);
+      begin
+        inherited ppuload(t,ppufile);
+        sectype:=tasmsectiontype(ppufile.getbyte);
+        secalign:=ppufile.getbyte;
+        name:=stringdup(ppufile.getstring);
+        sec:=nil;
+      end;
+
+
+    destructor tai_section.Destroy;
+      begin
+        stringdispose(name);
+      end;
+
+
+    procedure tai_section.ppuwrite(ppufile:tcompilerppufile);
+      begin
+        inherited ppuwrite(ppufile);
+        ppufile.putbyte(byte(sectype));
+        ppufile.putbyte(secalign);
+        ppufile.putstring(name^);
+      end;
+
+
+{****************************************************************************
+                             TAI_DATABLOCK
+ ****************************************************************************}
+
+    constructor tai_datablock.Create(const _name : string;_size : longint);
+
+      begin
+         inherited Create;
+         typ:=ait_datablock;
+         sym:=objectlibrary.newasmsymbol(_name,AB_LOCAL,AT_DATA);
+         { keep things aligned }
+         if _size<=0 then
+           _size:=4;
+         size:=_size;
+         is_global:=false;
+      end;
+
+
+    constructor tai_datablock.Create_global(const _name : string;_size : longint);
+      begin
+         inherited Create;
+         typ:=ait_datablock;
+         sym:=objectlibrary.newasmsymbol(_name,AB_GLOBAL,AT_DATA);
+         { keep things aligned }
+         if _size<=0 then
+           _size:=4;
+         size:=_size;
+         is_global:=true;
+      end;
+
+
+    constructor tai_datablock.ppuload(t:taitype;ppufile:tcompilerppufile);
+      begin
+        inherited Create;
+        sym:=ppufile.getasmsymbol;
+        size:=ppufile.getlongint;
+        is_global:=boolean(ppufile.getbyte);
+      end;
+
+
+    procedure tai_datablock.ppuwrite(ppufile:tcompilerppufile);
+      begin
+        inherited ppuwrite(ppufile);
+        ppufile.putasmsymbol(sym);
+        ppufile.putlongint(size);
+        ppufile.putbyte(byte(is_global));
+      end;
+
+
+    procedure tai_datablock.derefimpl;
+      begin
+        objectlibrary.DerefAsmsymbol(sym);
+      end;
+
+
+{****************************************************************************
+                               TAI_SYMBOL
+ ****************************************************************************}
+
+    constructor tai_symbol.Create(_sym:tasmsymbol;siz:longint);
+      begin
+         inherited Create;
+         typ:=ait_symbol;
+         sym:=_sym;
+         size:=siz;
+         sym.defbind:=AB_LOCAL;
+         is_global:=false;
+      end;
+
+    constructor tai_symbol.Create_global(_sym:tasmsymbol;siz:longint);
+      begin
+         inherited Create;
+         typ:=ait_symbol;
+         sym:=_sym;
+         size:=siz;
+         sym.defbind:=AB_GLOBAL;
+         is_global:=true;
+      end;
+
+    constructor tai_symbol.Createname(const _name : string;_symtyp:Tasmsymtype;siz:longint);
+      begin
+         inherited Create;
+         typ:=ait_symbol;
+         sym:=objectlibrary.newasmsymbol(_name,AB_LOCAL,_symtyp);
+         size:=siz;
+         is_global:=false;
+      end;
+
+    constructor tai_symbol.Createname_global(const _name : string;_symtyp:Tasmsymtype;siz:longint);
+      begin
+         inherited Create;
+         typ:=ait_symbol;
+         sym:=objectlibrary.newasmsymbol(_name,AB_GLOBAL,_symtyp);
+         size:=siz;
+         is_global:=true;
+      end;
+
+    constructor tai_symbol.ppuload(t:taitype;ppufile:tcompilerppufile);
+      begin
+        inherited ppuload(t,ppufile);
+        sym:=ppufile.getasmsymbol;
+        size:=ppufile.getlongint;
+        is_global:=boolean(ppufile.getbyte);
+      end;
+
+
+    procedure tai_symbol.ppuwrite(ppufile:tcompilerppufile);
+      begin
+        inherited ppuwrite(ppufile);
+        ppufile.putasmsymbol(sym);
+        ppufile.putlongint(size);
+        ppufile.putbyte(byte(is_global));
+      end;
+
+
+    procedure tai_symbol.derefimpl;
+      begin
+        objectlibrary.DerefAsmsymbol(sym);
+      end;
+
+
+{****************************************************************************
+                               TAI_SYMBOL_END
+ ****************************************************************************}
+
+    constructor tai_symbol_end.Create(_sym:tasmsymbol);
+      begin
+         inherited Create;
+         typ:=ait_symbol_end;
+         sym:=_sym;
+      end;
+
+    constructor tai_symbol_end.Createname(const _name : string);
+      begin
+         inherited Create;
+         typ:=ait_symbol_end;
+         sym:=objectlibrary.newasmsymbol(_name,AB_GLOBAL,AT_NONE);
+      end;
+
+    constructor tai_symbol_end.ppuload(t:taitype;ppufile:tcompilerppufile);
+      begin
+        inherited ppuload(t,ppufile);
+        sym:=ppufile.getasmsymbol;
+      end;
+
+
+    procedure tai_symbol_end.ppuwrite(ppufile:tcompilerppufile);
+      begin
+        inherited ppuwrite(ppufile);
+        ppufile.putasmsymbol(sym);
+      end;
+
+
+    procedure tai_symbol_end.derefimpl;
+      begin
+        objectlibrary.DerefAsmsymbol(sym);
+      end;
+
+
+{****************************************************************************
+                               TAI_SYMBOL_END
+ ****************************************************************************}
+
+    constructor tai_directive.Create(_directive:tasmdirective;const _name:string);
+      begin
+         inherited Create;
+         typ:=ait_directive;
+         name:=stringdup(_name);
+         directive:=_directive;
+      end;
+
+
+    destructor tai_directive.Destroy;
+      begin
+        stringdispose(name);
+      end;
+
+
+    constructor tai_directive.ppuload(t:taitype;ppufile:tcompilerppufile);
+      begin
+        inherited ppuload(t,ppufile);
+        name:=stringdup(ppufile.getstring);
+        directive:=tasmdirective(ppufile.getbyte);
+      end;
+
+
+    procedure tai_directive.ppuwrite(ppufile:tcompilerppufile);
+      begin
+        inherited ppuwrite(ppufile);
+        ppufile.putstring(name^);
+        ppufile.putbyte(byte(directive));
+      end;
+
+
+{****************************************************************************
+                               TAI_CONST
+ ****************************************************************************}
+
+    constructor tai_const.Create(_typ:taitype;_value : int64);
+      begin
+         inherited Create;
+         typ:=_typ;
+         value:=_value;
+         sym:=nil;
+         endsym:=nil;
+      end;
+
+
+    constructor tai_const.Create_128bit(_value : int64);
+      begin
+         inherited Create;
+         typ:=ait_const_128bit;
+         value:=_value;
+         sym:=nil;
+         endsym:=nil;
+      end;
+
+
+    constructor tai_const.Create_64bit(_value : int64);
+      begin
+         inherited Create;
+         typ:=ait_const_64bit;
+         value:=_value;
+         sym:=nil;
+         endsym:=nil;
+      end;
+
+
+    constructor tai_const.Create_32bit(_value : longint);
+      begin
+         inherited Create;
+         typ:=ait_const_32bit;
+         value:=_value;
+         sym:=nil;
+         endsym:=nil;
+      end;
+
+
+    constructor tai_const.Create_16bit(_value : word);
+      begin
+         inherited Create;
+         typ:=ait_const_16bit;
+         value:=_value;
+         sym:=nil;
+         endsym:=nil;
+      end;
+
+
+    constructor tai_const.Create_8bit(_value : byte);
+      begin
+         inherited Create;
+         typ:=ait_const_8bit;
+         value:=_value;
+         sym:=nil;
+         endsym:=nil;
+      end;
+
+
+    constructor tai_const.Create_sleb128bit(_value : int64);
+      begin
+         inherited Create;
+         typ:=ait_const_sleb128bit;
+         value:=_value;
+         sym:=nil;
+         endsym:=nil;
+      end;
+
+
+    constructor tai_const.Create_uleb128bit(_value : qword);
+      begin
+         inherited Create;
+         typ:=ait_const_uleb128bit;
+         value:=int64(_value);
+         sym:=nil;
+         endsym:=nil;
+      end;
+
+
+    constructor tai_const.Create_aint(_value : aint);
+      begin
+         inherited Create;
+         typ:=ait_const_aint;
+         value:=_value;
+         sym:=nil;
+         endsym:=nil;
+      end;
+
+
+    constructor tai_const.Create_sym(_sym:tasmsymbol);
+      begin
+         inherited Create;
+         typ:=ait_const_ptr;
+         { sym is allowed to be nil, this is used to write nil pointers }
+         sym:=_sym;
+         endsym:=nil;
+         value:=0;
+         { update sym info }
+         if assigned(sym) then
+           sym.increfs;
+      end;
+
+
+    constructor tai_const.Create_sym_offset(_sym:tasmsymbol;ofs:aint);
+      begin
+         inherited Create;
+         typ:=ait_const_ptr;
+         if not assigned(_sym) then
+           internalerror(200404121);
+         sym:=_sym;
+         endsym:=nil;
+         value:=ofs;
+         { update sym info }
+         sym.increfs;
+      end;
+
+
+    constructor tai_const.Create_rel_sym(_typ:taitype;_sym,_endsym:tasmsymbol);
+      begin
+         inherited Create;
+         typ:=_typ;
+         sym:=_sym;
+         endsym:=_endsym;
+         value:=0;
+         { update sym info }
+         sym.increfs;
+         endsym.increfs;
+      end;
+
+
+    constructor tai_const.Create_rva_sym(_sym:tasmsymbol);
+      begin
+         inherited Create;
+         typ:=ait_const_rva_symbol;
+         sym:=_sym;
+         endsym:=nil;
+         value:=0;
+         { update sym info }
+         sym.increfs;
+      end;
+
+
+    constructor tai_const.Create_indirect_sym(_sym:tasmsymbol);
+      begin
+         inherited Create;
+         typ:=ait_const_indirect_symbol;
+         sym:=_sym;
+         endsym:=nil;
+         value:=0;
+         { update sym info }
+         sym.increfs;
+      end;
+
+
+    constructor tai_const.Createname(const name:string;_symtyp:Tasmsymtype;ofs:aint);
+      begin
+         inherited Create;
+         typ:=ait_const_ptr;
+         sym:=objectlibrary.newasmsymbol(name,AB_EXTERNAL,_symtyp);
+         endsym:=nil;
+         value:=ofs;
+         { update sym info }
+         sym.increfs;
+      end;
+
+
+    constructor tai_const.Createname_rva(const name:string);
+      begin
+         inherited Create;
+         typ:=ait_const_rva_symbol;
+         sym:=objectlibrary.newasmsymbol(name,AB_EXTERNAL,AT_FUNCTION);
+         endsym:=nil;
+         value:=0;
+         { update sym info }
+         sym.increfs;
+      end;
+
+
+    constructor tai_const.ppuload(t:taitype;ppufile:tcompilerppufile);
+      begin
+        inherited ppuload(t,ppufile);
+        sym:=ppufile.getasmsymbol;
+        endsym:=ppufile.getasmsymbol;
+        value:=ppufile.getint64;
+      end;
+
+
+    procedure tai_const.ppuwrite(ppufile:tcompilerppufile);
+      begin
+        inherited ppuwrite(ppufile);
+        ppufile.putasmsymbol(sym);
+        ppufile.putasmsymbol(endsym);
+        ppufile.putint64(value);
+      end;
+
+
+    procedure tai_const.derefimpl;
+      begin
+        objectlibrary.DerefAsmsymbol(sym);
+        objectlibrary.DerefAsmsymbol(endsym);
+      end;
+
+
+    function tai_const.getcopy:tlinkedlistitem;
+      begin
+        getcopy:=inherited getcopy;
+        { we need to increase the reference number }
+        sym.increfs;
+        if assigned(endsym) then
+          endsym.increfs;
+      end;
+
+
+    function tai_const.size:longint;
+      begin
+        case typ of
+          ait_const_8bit :
+            result:=1;
+          ait_const_16bit :
+            result:=2;
+          ait_const_32bit :
+            result:=4;
+          ait_const_64bit :
+            result:=8;
+          ait_const_indirect_symbol,
+          ait_const_rva_symbol :
+            result:=sizeof(aint);
+        end;
+      end;
+
+
+{****************************************************************************
+                               TAI_real_32bit
+ ****************************************************************************}
+
+    constructor tai_real_32bit.Create(_value : ts32real);
+
+      begin
+         inherited Create;
+         typ:=ait_real_32bit;
+         value:=_value;
+      end;
+
+    constructor tai_real_32bit.ppuload(t:taitype;ppufile:tcompilerppufile);
+      begin
+        inherited ppuload(t,ppufile);
+        value:=ppufile.getreal;
+      end;
+
+
+    procedure tai_real_32bit.ppuwrite(ppufile:tcompilerppufile);
+      begin
+        inherited ppuwrite(ppufile);
+        ppufile.putreal(value);
+      end;
+
+
+{****************************************************************************
+                               TAI_real_64bit
+ ****************************************************************************}
+
+    constructor tai_real_64bit.Create(_value : ts64real);
+
+      begin
+         inherited Create;
+         typ:=ait_real_64bit;
+         value:=_value;
+      end;
+
+
+{$ifdef ARM}
+    constructor tai_real_64bit.Create_hiloswapped(_value : ts64real);
+
+      begin
+         inherited Create;
+         typ:=ait_real_64bit;
+         value:=_value;
+         formatoptions:=fo_hiloswapped;
+      end;
+{$endif ARM}
+
+    constructor tai_real_64bit.ppuload(t:taitype;ppufile:tcompilerppufile);
+      begin
+        inherited ppuload(t,ppufile);
+        value:=ppufile.getreal;
+{$ifdef ARM}
+        formatoptions:=tformatoptions(ppufile.getbyte);
+{$endif ARM}
+      end;
+
+
+    procedure tai_real_64bit.ppuwrite(ppufile:tcompilerppufile);
+      begin
+        inherited ppuwrite(ppufile);
+        ppufile.putreal(value);
+{$ifdef ARM}
+        ppufile.putbyte(byte(formatoptions));
+{$endif ARM}
+      end;
+
+
+{****************************************************************************
+                               TAI_real_80bit
+ ****************************************************************************}
+
+    constructor tai_real_80bit.Create(_value : ts80real);
+
+      begin
+         inherited Create;
+         typ:=ait_real_80bit;
+         value:=_value;
+      end;
+
+
+    constructor tai_real_80bit.ppuload(t:taitype;ppufile:tcompilerppufile);
+      begin
+        inherited ppuload(t,ppufile);
+        value:=ppufile.getreal;
+      end;
+
+
+    procedure tai_real_80bit.ppuwrite(ppufile:tcompilerppufile);
+      begin
+        inherited ppuwrite(ppufile);
+        ppufile.putreal(value);
+      end;
+
+
+{****************************************************************************
+                               TAI_real_80bit
+ ****************************************************************************}
+
+    constructor tai_real_128bit.Create(_value : ts128real);
+
+      begin
+         inherited Create;
+         typ:=ait_real_128bit;
+         value:=_value;
+      end;
+
+
+    constructor tai_real_128bit.ppuload(t:taitype;ppufile:tcompilerppufile);
+      begin
+        inherited ppuload(t,ppufile);
+        value:=ppufile.getreal;
+      end;
+
+
+    procedure tai_real_128bit.ppuwrite(ppufile:tcompilerppufile);
+      begin
+        inherited ppuwrite(ppufile);
+        ppufile.putreal(value);
+      end;
+
+
+{****************************************************************************
+                               Tai_comp_64bit
+ ****************************************************************************}
+
+    constructor tai_comp_64bit.Create(_value : ts64comp);
+
+      begin
+         inherited Create;
+         typ:=ait_comp_64bit;
+         value:=_value;
+      end;
+
+
+    constructor tai_comp_64bit.ppuload(t:taitype;ppufile:tcompilerppufile);
+      begin
+        inherited ppuload(t,ppufile);
+        ppufile.putdata(value,sizeof(value));
+      end;
+
+
+    procedure tai_comp_64bit.ppuwrite(ppufile:tcompilerppufile);
+      begin
+        inherited ppuwrite(ppufile);
+        ppufile.getdata(value,sizeof(value));
+      end;
+
+
+{****************************************************************************
+                               TAI_STRING
+ ****************************************************************************}
+
+     constructor tai_string.Create(const _str : string);
+       begin
+          inherited Create;
+          typ:=ait_string;
+          len:=length(_str);
+          getmem(str,len+1);
+          strpcopy(str,_str);
+       end;
+
+
+    constructor tai_string.Create_pchar(_str : pchar;length : longint);
+       begin
+          inherited Create;
+          typ:=ait_string;
+          str:=_str;
+          len:=length;
+       end;
+
+
+    destructor tai_string.destroy;
+      begin
+         if str<>nil then
+           freemem(str);
+         inherited Destroy;
+      end;
+
+
+    constructor tai_string.ppuload(t:taitype;ppufile:tcompilerppufile);
+      begin
+        inherited ppuload(t,ppufile);
+        len:=ppufile.getlongint;
+        getmem(str,len);
+        ppufile.getdata(str^,len);
+      end;
+
+
+    procedure tai_string.ppuwrite(ppufile:tcompilerppufile);
+      begin
+        inherited ppuwrite(ppufile);
+        ppufile.putlongint(len);
+        ppufile.putdata(str^,len);
+      end;
+
+
+    function tai_string.getcopy : tlinkedlistitem;
+      var
+        p : tlinkedlistitem;
+      begin
+        p:=inherited getcopy;
+        getmem(tai_string(p).str,len);
+        move(str^,tai_string(p).str^,len);
+        getcopy:=p;
+      end;
+
+
+{****************************************************************************
+                               TAI_LABEL
+ ****************************************************************************}
+
+    constructor tai_label.create(_l : tasmlabel);
+      begin
+        inherited Create;
+        typ:=ait_label;
+        l:=_l;
+        l.is_set:=true;
+        is_global:=(l.defbind=AB_GLOBAL);
+      end;
+
+
+    constructor tai_label.ppuload(t:taitype;ppufile:tcompilerppufile);
+      begin
+        inherited ppuload(t,ppufile);
+        l:=tasmlabel(ppufile.getasmsymbol);
+        is_global:=boolean(ppufile.getbyte);
+      end;
+
+
+    procedure tai_label.ppuwrite(ppufile:tcompilerppufile);
+      begin
+        inherited ppuwrite(ppufile);
+        ppufile.putasmsymbol(l);
+        ppufile.putbyte(byte(is_global));
+      end;
+
+
+    procedure tai_label.derefimpl;
+      begin
+        objectlibrary.DerefAsmsymbol(tasmsymbol(l));
+        l.is_set:=true;
+      end;
+
+
+{****************************************************************************
+          tai_comment  comment to be inserted in the assembler file
+ ****************************************************************************}
+
+     constructor tai_comment.Create(_str : pchar);
+
+       begin
+          inherited Create;
+          typ:=ait_comment;
+          str:=_str;
+       end;
+
+    destructor tai_comment.destroy;
+
+      begin
+         strdispose(str);
+         inherited Destroy;
+      end;
+
+    constructor tai_comment.ppuload(t:taitype;ppufile:tcompilerppufile);
+      var
+        len : longint;
+      begin
+        inherited ppuload(t,ppufile);
+        len:=ppufile.getlongint;
+        getmem(str,len+1);
+        ppufile.getdata(str^,len);
+        str[len]:=#0;
+      end;
+
+
+    procedure tai_comment.ppuwrite(ppufile:tcompilerppufile);
+      var
+        len : longint;
+      begin
+        inherited ppuwrite(ppufile);
+        len:=strlen(str);
+        ppufile.putlongint(len);
+        ppufile.putdata(str^,len);
+      end;
+
+
+    function tai_comment.getcopy : tlinkedlistitem;
+      var
+        p : tlinkedlistitem;
+      begin
+        p:=inherited getcopy;
+        getmem(tai_comment(p).str,strlen(str)+1);
+        move(str^,tai_comment(p).str^,strlen(str)+1);
+        getcopy:=p;
+      end;
+
+
+{****************************************************************************
+                              TAI_STABS
+ ****************************************************************************}
+
+    constructor tai_stab.create(_stabtype:tstabtype;_str : pchar);
+      begin
+         inherited create;
+         typ:=ait_stab;
+         str:=_str;
+         stabtype:=_stabtype;
+      end;
+
+    constructor tai_stab.create_str(_stabtype:tstabtype;const s:string);
+      begin
+         self.create(_stabtype,strpnew(s));
+      end;
+
+    destructor tai_stab.destroy;
+      begin
+         strdispose(str);
+         inherited destroy;
+      end;
+
+
+{****************************************************************************
+                            TAI_FORCE_LINE
+ ****************************************************************************}
+
+    constructor tai_force_line.create;
+      begin
+         inherited create;
+         typ:=ait_force_line;
+      end;
+
+
+{****************************************************************************
+                              TAI_FUNCTION_NAME
+ ****************************************************************************}
+
+    constructor tai_function_name.create(const s:string);
+      begin
+         inherited create;
+         typ:=ait_function_name;
+         funcname:=stringdup(s);
+      end;
+
+    destructor tai_function_name.destroy;
+      begin
+         stringdispose(funcname);
+         inherited destroy;
+      end;
+
+
+{****************************************************************************
+                              TAI_CUTOBJECT
+ ****************************************************************************}
+
+     constructor tai_cutobject.Create;
+       begin
+          inherited Create;
+          typ:=ait_cutobject;
+          place:=cut_normal;
+       end;
+
+
+     constructor tai_cutobject.Create_begin;
+       begin
+          inherited Create;
+          typ:=ait_cutobject;
+          place:=cut_begin;
+       end;
+
+
+     constructor tai_cutobject.Create_end;
+       begin
+          inherited Create;
+          typ:=ait_cutobject;
+          place:=cut_end;
+       end;
+
+
+    constructor tai_cutobject.ppuload(t:taitype;ppufile:tcompilerppufile);
+      begin
+        inherited ppuload(t,ppufile);
+        place:=TCutPlace(ppufile.getbyte);
+      end;
+
+
+    procedure tai_cutobject.ppuwrite(ppufile:tcompilerppufile);
+      begin
+        inherited ppuwrite(ppufile);
+        ppufile.putbyte(byte(place));
+      end;
+
+
+{****************************************************************************
+                             Tai_Marker
+ ****************************************************************************}
+
+    constructor Tai_Marker.Create(_Kind: TMarker);
+      begin
+        Inherited Create;
+        typ := ait_marker;
+        Kind := _Kind;
+      end;
+
+
+    constructor Tai_Marker.ppuload(t:taitype;ppufile:tcompilerppufile);
+      begin
+        inherited ppuload(t,ppufile);
+        kind:=TMarker(ppufile.getbyte);
+      end;
+
+
+    procedure Tai_Marker.ppuwrite(ppufile:tcompilerppufile);
+      begin
+        inherited ppuwrite(ppufile);
+        ppufile.putbyte(byte(kind));
+      end;
+
+
+{*****************************************************************************
+                                tai_tempalloc
+*****************************************************************************}
+
+    constructor tai_tempalloc.alloc(pos,size:longint);
+      begin
+        inherited Create;
+        typ:=ait_tempalloc;
+        allocation:=true;
+        temppos:=pos;
+        tempsize:=size;
+{$ifdef EXTDEBUG}
+        problem:=nil;
+{$endif EXTDEBUG}
+      end;
+
+
+    destructor tai_tempalloc.destroy;
+      begin
+{$ifdef EXTDEBUG}
+        stringdispose(problem);
+{$endif EXTDEBUG}
+        inherited destroy;
+      end;
+
+
+    constructor tai_tempalloc.dealloc(pos,size:longint);
+      begin
+        inherited Create;
+        typ:=ait_tempalloc;
+        allocation:=false;
+        temppos:=pos;
+        tempsize:=size;
+{$ifdef EXTDEBUG}
+        problem:=nil;
+{$endif EXTDEBUG}
+      end;
+
+
+{$ifdef EXTDEBUG}
+    constructor tai_tempalloc.allocinfo(pos,size:longint;const st:string);
+      begin
+        inherited Create;
+        typ:=ait_tempalloc;
+        allocation:=false;
+        temppos:=pos;
+        tempsize:=size;
+        problem:=stringdup(st);
+      end;
+{$endif EXTDEBUG}
+
+
+    constructor tai_tempalloc.ppuload(t:taitype;ppufile:tcompilerppufile);
+      begin
+        inherited ppuload(t,ppufile);
+        temppos:=ppufile.getlongint;
+        tempsize:=ppufile.getlongint;
+        allocation:=boolean(ppufile.getbyte);
+{$ifdef EXTDEBUG}
+        problem:=nil;
+{$endif EXTDEBUG}
+      end;
+
+
+    procedure tai_tempalloc.ppuwrite(ppufile:tcompilerppufile);
+      begin
+        inherited ppuwrite(ppufile);
+        ppufile.putlongint(temppos);
+        ppufile.putlongint(tempsize);
+        ppufile.putbyte(byte(allocation));
+      end;
+
+
+{*****************************************************************************
+                                 tai_regalloc
+*****************************************************************************}
+
+    constructor tai_regalloc.alloc(r : tregister;ainstr:tai);
+      begin
+        inherited create;
+        typ:=ait_regalloc;
+        ratype:=ra_alloc;
+        reg:=r;
+        { ainstr must be an instruction }
+        if assigned(ainstr) and
+           (ainstr.typ<>ait_instruction) then
+          internalerror(200411011);
+        instr:=ainstr;
+      end;
+
+
+    constructor tai_regalloc.dealloc(r : tregister;ainstr:tai);
+      begin
+        inherited create;
+        typ:=ait_regalloc;
+        ratype:=ra_dealloc;
+        reg:=r;
+        { ainstr must be an instruction }
+        if assigned(ainstr) and
+           (ainstr.typ<>ait_instruction) then
+          internalerror(200411012);
+        instr:=ainstr;
+      end;
+
+
+    constructor tai_regalloc.sync(r : tregister);
+      begin
+        inherited create;
+        typ:=ait_regalloc;
+        ratype:=ra_sync;
+        reg:=r;
+      end;
+
+
+    constructor tai_regalloc.resize(r : tregister);
+      begin
+        inherited create;
+        typ:=ait_regalloc;
+        ratype:=ra_resize;
+        reg:=r;
+      end;
+
+
+    constructor tai_regalloc.ppuload(t:taitype;ppufile:tcompilerppufile);
+      begin
+        inherited ppuload(t,ppufile);
+        ppufile.getdata(reg,sizeof(Tregister));
+        ratype:=tregalloctype(ppufile.getbyte);
+      end;
+
+
+    procedure tai_regalloc.ppuwrite(ppufile:tcompilerppufile);
+      begin
+        inherited ppuwrite(ppufile);
+        ppufile.putdata(reg,sizeof(Tregister));
+        ppufile.putbyte(byte(ratype));
+      end;
+
+
+{*****************************************************************************
+                               TaiInstruction
+*****************************************************************************}
+
+    constructor tai_cpu_abstract.Create(op : tasmop);
+
+      begin
+         inherited create;
+         typ:=ait_instruction;
+         is_jmp:=false;
+         opcode:=op;
+         ops:=0;
+         fillchar(condition,sizeof(condition),0);
+         fillchar(oper,sizeof(oper),0);
+      end;
+
+
+    destructor tai_cpu_abstract.Destroy;
+      var
+        i : integer;
+      begin
+        for i:=0 to opercnt-1 do
+          begin
+            clearop(i);
+            dispose(oper[i]);
+          end;
+        inherited destroy;
+      end;
+
+
+{ ---------------------------------------------------------------------
+    Loading of operands.
+  ---------------------------------------------------------------------}
+
+    procedure tai_cpu_abstract.allocate_oper(opers:longint);
+      begin
+        while (opers>opercnt) do
+          begin
+            new(oper[opercnt]);
+            fillchar(oper[opercnt]^,sizeof(toper),0);
+            inc(opercnt);
+          end;
+      end;
+
+
+    procedure tai_cpu_abstract.loadconst(opidx:longint;l:aint);
+      begin
+        allocate_oper(opidx+1);
+        with oper[opidx]^ do
+         begin
+           if typ<>top_const then
+             clearop(opidx);
+           val:=l;
+           typ:=top_const;
+         end;
+      end;
+
+
+    procedure tai_cpu_abstract.loadsymbol(opidx:longint;s:tasmsymbol;sofs:longint);
+      var
+        r : treference;
+      begin
+        reference_reset_symbol(r,s,sofs);
+        r.refaddr:=addr_full;
+        loadref(opidx,r);
+      end;
+
+
+    procedure tai_cpu_abstract.loadlocal(opidx:longint;s:pointer;sofs:longint;indexreg:tregister;scale:byte;getoffset,forceref:boolean);
+      begin
+        if not assigned(s) then
+         internalerror(200204251);
+        allocate_oper(opidx+1);
+        with oper[opidx]^ do
+         begin
+           if typ<>top_local then
+             begin
+               clearop(opidx);
+               new(localoper);
+             end;
+           with oper[opidx]^.localoper^ do
+             begin
+               localsym:=s;
+               localsymofs:=sofs;
+               localindexreg:=indexreg;
+               localscale:=scale;
+               localgetoffset:=getoffset;
+               localforceref:=forceref;
+             end;
+           typ:=top_local;
+         end;
+      end;
+
+
+
+    procedure tai_cpu_abstract.loadref(opidx:longint;const r:treference);
+      begin
+        allocate_oper(opidx+1);
+        with oper[opidx]^ do
+          begin
+            if typ<>top_ref then
+              begin
+                clearop(opidx);
+                new(ref);
+              end;
+
+            ref^:=r;
+{$ifdef x86}
+            { We allow this exception for x86, since overloading this would be
+              too much of a a speed penalty}
+            if (ref^.segment<>NR_NO) and (ref^.segment<>NR_DS) then
+              segprefix:=ref^.segment;
+{$endif}
+{$ifdef extdebug}
+            if (cs_create_pic in aktmoduleswitches) and
+              assigned(r.symbol) and
+              (r.refaddr=addr_no) then
+              internalerror(200502052);
+{$endif}
+            typ:=top_ref;
+            if assigned(add_reg_instruction_hook) then
+              begin
+                add_reg_instruction_hook(self,ref^.base);
+                add_reg_instruction_hook(self,ref^.index);
+              end;
+            { mark symbol as used }
+            if assigned(ref^.symbol) then
+              ref^.symbol.increfs;
+          end;
+      end;
+
+
+    procedure tai_cpu_abstract.loadreg(opidx:longint;r:tregister);
+      begin
+        allocate_oper(opidx+1);
+        with oper[opidx]^ do
+         begin
+           if typ<>top_reg then
+             clearop(opidx);
+           reg:=r;
+           typ:=top_reg;
+         end;
+        if assigned(add_reg_instruction_hook) then
+          add_reg_instruction_hook(self,r);
+{$ifdef ARM}
+        { R15 is the PC on the ARM thus moves to R15 are jumps.
+          Due to speed considerations we don't use a virtual overridden method here.
+          Because the pc/r15 isn't handled by the reg. allocator this should never cause
+          problems with iregs getting r15.
+        }
+        is_jmp:=(opcode=A_MOV) and (opidx=0) and (r=NR_R15);
+{$endif ARM}
+      end;
+
+
+    procedure tai_cpu_abstract.loadoper(opidx:longint;o:toper);
+      begin
+        allocate_oper(opidx+1);
+        clearop(opidx);
+        oper[opidx]^:=o;
+        { copy also the reference }
+        with oper[opidx]^ do
+          begin
+            case typ of
+              top_reg:
+                begin
+                  if assigned(add_reg_instruction_hook) then
+                    add_reg_instruction_hook(self,reg);
+                end;
+              top_ref:
+                begin
+                  new(ref);
+                  ref^:=o.ref^;
+                  if assigned(add_reg_instruction_hook) then
+                    begin
+                      add_reg_instruction_hook(self,ref^.base);
+                      add_reg_instruction_hook(self,ref^.index);
+                    end;
+                end;
+{$ifdef ARM}
+              top_shifterop:
+                begin
+                  new(shifterop);
+                  shifterop^:=o.shifterop^;
+                  if assigned(add_reg_instruction_hook) then
+                    add_reg_instruction_hook(self,shifterop^.rs);
+                end;
+{$endif ARM}
+             end;
+          end;
+      end;
+
+    procedure tai_cpu_abstract.clearop(opidx:longint);
+      begin
+        with oper[opidx]^ do
+          begin
+            case typ of
+              top_ref:
+                dispose(ref);
+              top_local:
+                dispose(localoper);
+{$ifdef ARM}
+              top_shifterop:
+                dispose(shifterop);
+              top_regset:
+                dispose(regset);
+{$endif ARM}
+            end;
+            typ:=top_none;
+          end;
+      end;
+
+
+{ ---------------------------------------------------------------------
+    Miscellaneous methods.
+  ---------------------------------------------------------------------}
+
+    procedure tai_cpu_abstract.SetCondition(const c:TAsmCond);
+      begin
+         condition:=c;
+      end;
+
+
+    Function tai_cpu_abstract.getcopy:TLinkedListItem;
+      var
+        i : longint;
+        p : tai_cpu_abstract;
+      begin
+        p:=tai_cpu_abstract(inherited getcopy);
+        { make a copy of the references }
+        p.opercnt:=0;
+        p.allocate_oper(ops);
+        for i:=0 to ops-1 do
+          begin
+            p.oper[i]^:=oper[i]^;
+            case oper[i]^.typ of
+              top_local :
+                begin
+                  new(p.oper[i]^.localoper);
+                  p.oper[i]^.localoper^:=oper[i]^.localoper^;
+                end;
+              top_ref :
+                begin
+                  new(p.oper[i]^.ref);
+                  p.oper[i]^.ref^:=oper[i]^.ref^;
+                end;
+{$ifdef ARM}
+              top_shifterop:
+                begin
+                  new(p.oper[i]^.shifterop);
+                  p.oper[i]^.shifterop^:=oper[i]^.shifterop^;
+                end;
+{$endif ARM}
+            end;
+          end;
+        getcopy:=p;
+      end;
+
+
+    function tai_cpu_abstract.is_same_reg_move(regtype: Tregistertype):boolean;
+      begin
+        { When the generic RA is used this needs to be overriden, we don't use
+          virtual;abstract; to prevent a lot of warnings of unimplemented abstract methods
+          when tai_cpu is created (PFV) }
+        internalerror(200404091);
+        result:=false;
+      end;
+
+
+    function tai_cpu_abstract.spilling_get_operation_type(opnr: longint): topertype;
+      begin
+        internalerror(200404091);
+        result:=operand_readwrite;
+      end;
+
+
+    function tai_cpu_abstract.spilling_get_operation_type_ref(opnr: longint; reg: tregister): topertype;
+      begin
+        result := operand_read;
+      end;
+
+
+    constructor tai_cpu_abstract.ppuload(t:taitype;ppufile:tcompilerppufile);
+      var
+        i : integer;
+      begin
+        inherited ppuload(t,ppufile);
+        { hopefully, we don't get problems with big/litte endian here when cross compiling :/ }
+        ppufile.getdata(condition,sizeof(tasmcond));
+        allocate_oper(ppufile.getbyte);
+        for i:=0 to ops-1 do
+          ppuloadoper(ppufile,oper[i]^);
+        opcode:=tasmop(ppufile.getword);
+{$ifdef x86}
+        ppufile.getdata(segprefix,sizeof(Tregister));
+{$endif x86}
+        is_jmp:=boolean(ppufile.getbyte);
+      end;
+
+
+    procedure tai_cpu_abstract.ppuwrite(ppufile:tcompilerppufile);
+      var
+        i : integer;
+      begin
+        inherited ppuwrite(ppufile);
+        ppufile.putdata(condition,sizeof(tasmcond));
+        ppufile.putbyte(ops);
+        for i:=0 to ops-1 do
+          ppuwriteoper(ppufile,oper[i]^);
+        ppufile.putword(word(opcode));
+{$ifdef x86}
+        ppufile.putdata(segprefix,sizeof(Tregister));
+{$endif x86}
+        ppufile.putbyte(byte(is_jmp));
+      end;
+
+
+    procedure tai_cpu_abstract.buildderefimpl;
+      var
+        i : integer;
+      begin
+        for i:=0 to ops-1 do
+          ppubuildderefimploper(oper[i]^);
+      end;
+
+
+    procedure tai_cpu_abstract.derefimpl;
+      var
+        i : integer;
+      begin
+        for i:=0 to ops-1 do
+          ppuderefoper(oper[i]^);
+      end;
+
+
+{****************************************************************************
+                              tai_align_abstract
+ ****************************************************************************}
+
+     constructor tai_align_abstract.Create(b: byte);
+       begin
+          inherited Create;
+          typ:=ait_align;
+          if b in [1,2,4,8,16,32] then
+            aligntype := b
+          else
+            aligntype := 1;
+          fillsize:=0;
+          fillop:=0;
+          use_op:=false;
+       end;
+
+
+     constructor tai_align_abstract.Create_op(b: byte; _op: byte);
+       begin
+          inherited Create;
+          typ:=ait_align;
+          if b in [1,2,4,8,16,32] then
+            aligntype := b
+          else
+            aligntype := 1;
+          fillsize:=0;
+          fillop:=_op;
+          use_op:=true;
+       end;
+
+
+     constructor tai_align_abstract.Create_zeros(b: byte);
+       begin
+          inherited Create;
+          typ:=ait_align;
+          if b in [1,2,4,8,16,32] then
+            aligntype := b
+          else
+            aligntype := 1;
+         use_op:=true;
+         fillsize:=0;
+         fillop:=0;
+       end;
+
+
+     function tai_align_abstract.calculatefillbuf(var buf : tfillbuffer):pchar;
+       begin
+         if fillsize>sizeof(buf) then
+           internalerror(200404293);
+         fillchar(buf,high(buf),fillop);
+         calculatefillbuf:=pchar(@buf);
+       end;
+
+
+    constructor tai_align_abstract.ppuload(t:taitype;ppufile:tcompilerppufile);
+      begin
+        inherited ppuload(t,ppufile);
+        aligntype:=ppufile.getbyte;
+        fillsize:=0;
+        fillop:=ppufile.getbyte;
+        use_op:=boolean(ppufile.getbyte);
+      end;
+
+
+    procedure tai_align_abstract.ppuwrite(ppufile:tcompilerppufile);
+      begin
+        inherited ppuwrite(ppufile);
+        ppufile.putbyte(aligntype);
+        ppufile.putbyte(fillop);
+        ppufile.putbyte(byte(use_op));
+      end;
+
+
+{*****************************************************************************
+                                 TAAsmOutput
+*****************************************************************************}
+
+    constructor taasmoutput.create;
+      begin
+        inherited create;
+        { make sure the optimizer won't remove the first tai of this list}
+        insert(tai_marker.create(marker_blockstart));
+      end;
+
+
+    function taasmoutput.empty : boolean;
+      begin
+        { there is always a marker_blockstart available,
+          see taasmoutput.create }
+        result:=(count<=1);
+      end;
+
+
+    function taasmoutput.getlasttaifilepos : pfileposinfo;
+      var
+       hp : tlinkedlistitem;
+      begin
+         getlasttaifilepos := nil;
+         if assigned(last) then
+           begin
+              { find the last file information record }
+              if not (tai(last).typ in SkipLineInfo) then
+                getlasttaifilepos:=@tailineinfo(last).fileinfo
+              else
+               { go through list backwards to find the first entry
+                 with line information
+               }
+               begin
+                 hp:=tai(last);
+                 while assigned(hp) and (tai(hp).typ in SkipLineInfo) do
+                    hp:=hp.Previous;
+                 { found entry }
+                 if assigned(hp) then
+                   getlasttaifilepos:=@tailineinfo(hp).fileinfo
+               end;
+           end;
+      end;
+
+    procedure Taasmoutput.InsertAfter(Item,Loc : TLinkedListItem);
+
+      begin
+        { This is not possible because it is not sure that the
+          tai at Loc has taifileinfo as parent }
+        {if assigned(Loc) then
+          tailineinfo(Item).fileinfo:=tailineinfo(Loc).fileinfo;}
+        inherited InsertAfter(Item,Loc);
+      end;
+
+begin
+  cai_cpu:=tai_cpu_abstract;
+  cai_align:=tai_align_abstract;
+end.

+ 870 - 0
compiler/aggas.pas

@@ -0,0 +1,870 @@
+{
+    Copyright (c) 1998-2004 by the Free Pascal team
+
+    This unit implements generic GNU assembler (v2.8 or later)
+
+    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.
+
+ ****************************************************************************
+}
+{ Base unit for writing GNU assembler output.
+}
+unit aggas;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+{$IFDEF USE_SYSUTILS}
+      SysUtils,
+{$ELSE USE_SYSUTILS}
+      dos,
+{$ENDIF USE_SYSUTILS}
+      cclasses,
+      globals,
+      aasmbase,aasmtai,aasmcpu,
+      assemble;
+
+
+    type
+      {# This is a derived class which is used to write
+         GAS styled assembler.
+
+         The WriteInstruction() method must be overriden
+         to write a single instruction to the assembler
+         file.
+      }
+      TGNUAssembler=class(texternalassembler)
+      protected
+        function sectionname(atype:tasmsectiontype;const aname:string):string;virtual;
+        procedure WriteSection(atype:tasmsectiontype;const aname:string);
+        procedure WriteExtraHeader;virtual;
+        procedure WriteInstruction(hp: tai);  virtual; abstract;
+      public
+        procedure WriteTree(p:TAAsmoutput);override;
+        procedure WriteAsmList;override;
+      end;
+
+
+implementation
+
+    uses
+      cutils,globtype,systems,
+      fmodule,finput,verbose,
+      itcpugas
+      ;
+
+    const
+      line_length = 70;
+
+    var
+      CurrSecType  : TAsmSectionType; { last section type written }
+      lastfileinfo : tfileposinfo;
+      infile,
+      lastinfile   : tinputfile;
+      symendcount  : longint;
+
+    type
+{$ifdef cpuextended}
+      t80bitarray = array[0..9] of byte;
+{$endif cpuextended}
+      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 single2str(d : single) : string;
+      var
+         hs : string;
+      begin
+         str(d,hs);
+      { replace space with + }
+         if hs[1]=' ' then
+          hs[1]:='+';
+         single2str:='0d'+hs
+      end;
+
+    function double2str(d : double) : string;
+      var
+         hs : string;
+      begin
+         str(d,hs);
+      { replace space with + }
+         if hs[1]=' ' then
+          hs[1]:='+';
+         double2str:='0d'+hs
+      end;
+
+    function extended2str(e : extended) : string;
+      var
+         hs : string;
+      begin
+         str(e,hs);
+      { replace space with + }
+         if hs[1]=' ' then
+          hs[1]:='+';
+         extended2str:='0d'+hs
+      end;
+
+
+  { convert floating point values }
+  { to correct endian             }
+  procedure swap64bitarray(var t: t64bitarray);
+    var
+     b: byte;
+    begin
+      b:= t[7];
+      t[7] := t[0];
+      t[0] := b;
+
+      b := t[6];
+      t[6] := t[1];
+      t[1] := b;
+
+      b:= t[5];
+      t[5] := t[2];
+      t[2] := b;
+
+      b:= t[4];
+      t[4] := t[3];
+      t[3] := b;
+   end;
+
+
+   procedure swap32bitarray(var t: t32bitarray);
+    var
+     b: byte;
+    begin
+      b:= t[1];
+      t[1]:= t[2];
+      t[2]:= b;
+
+      b:= t[0];
+      t[0]:= t[3];
+      t[3]:= b;
+    end;
+
+
+    const
+      ait_const2str : array[ait_const_128bit..ait_const_indirect_symbol] of string[20]=(
+        #9'.fixme128'#9,#9'.quad'#9,#9'.long'#9,#9'.short'#9,#9'.byte'#9,
+        #9'.sleb128'#9,#9'.uleb128'#9,
+        #9'.rva'#9,#9'.indirect_symbol'#9
+      );
+
+{****************************************************************************}
+{                          GNU Assembler writer                              }
+{****************************************************************************}
+
+    function TGNUAssembler.sectionname(atype:tasmsectiontype;const aname:string):string;
+      const
+        secnames : array[tasmsectiontype] of string[12] = ('',
+{$warning TODO .rodata not yet working}
+          '.text','.data','.data','.bss','.threadvar',
+          'common',
+          '.note',
+          '__TEXT', { stubs }
+          '.stab','.stabstr',
+          '.idata$2','.idata$4','.idata$5','.idata$6','.idata$7','.edata',
+          '.eh_frame',
+          '.debug_frame',
+          'fpc.resptrs'
+        );
+      begin
+        if use_smartlink_section and
+           (aname<>'') then
+          result:=secnames[atype]+'.'+aname
+        else
+          result:=secnames[atype];
+      end;
+
+
+    procedure TGNUAssembler.WriteSection(atype:tasmsectiontype;const aname:string);
+      var
+        s : string;
+      begin
+        AsmLn;
+        case target_info.system of
+         system_i386_OS2,
+         system_i386_EMX : ;
+         system_powerpc_darwin :
+           begin
+             if atype=sec_stub then
+               AsmWrite('.section ');
+           end;
+         else
+          AsmWrite('.section ');
+        end;
+        s:=sectionname(atype,aname);
+        AsmWrite(s);
+        case atype of
+          sec_fpc :
+            AsmWrite(', "a", @progbits');
+          sec_stub :
+            begin
+              if target_info.system=system_powerpc_darwin then
+                AsmWrite(',__symbol_stub1,symbol_stubs,pure_instructions,16');
+            end;
+        end;
+        AsmLn;
+        CurrSecType:=atype;
+      end;
+
+
+    procedure TGNUAssembler.WriteTree(p:TAAsmoutput);
+
+    function needsObject(hp : tai_symbol) : boolean;
+    begin
+      needsObject :=
+          assigned(hp.next) and
+          (tai_symbol(hp.next).typ in [ait_const_rva_symbol,
+             ait_const_32bit,ait_const_16bit,ait_const_8bit,ait_datablock,
+             ait_real_32bit,ait_real_64bit,ait_real_80bit,ait_comp_64bit]);
+    end;
+
+    var
+      ch       : char;
+      hp       : tai;
+      hp1      : tailineinfo;
+      consttyp : taitype;
+      s        : string;
+      i,pos,l  : longint;
+      InlineLevel : longint;
+      last_align : longint;
+      co       : comp;
+      sin      : single;
+      d        : double;
+{$ifdef cpuextended}
+      e        : extended;
+{$endif cpuextended}
+      do_line  : boolean;
+
+      sepChar : char;
+    begin
+      if not assigned(p) then
+       exit;
+
+      last_align := 2;
+      InlineLevel:=0;
+      { lineinfo is only needed for al_procedures (PFV) }
+      do_line:=(cs_asm_source in aktglobalswitches) or
+               ((cs_lineinfo in aktmoduleswitches)
+                 and (p=asmlist[al_procedures]));
+      hp:=tai(p.first);
+      while assigned(hp) do
+       begin
+         if not(hp.typ in SkipLineInfo) then
+          begin
+            hp1 := hp as tailineinfo;
+            aktfilepos:=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 aktglobalswitches) 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 aktglobalswitches) 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 aktglobalswitches) then
+                 begin
+                   AsmWrite(#9+target_asm.comment+'Register ');
+                   repeat
+                     AsmWrite(gas_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 aktglobalswitches) 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
+               if tai_align(hp).aligntype>1 then
+                 begin
+                   if target_info.system <> system_powerpc_darwin then
+                     begin
+                       AsmWrite(#9'.balign '+tostr(tai_align(hp).aligntype));
+                       if tai_align(hp).use_op then
+                        AsmWrite(','+tostr(tai_align(hp).fillop))
+                     end
+                   else
+                     begin
+                       { darwin as only supports .align }
+                       if not ispowerof2(tai_align(hp).aligntype,i) then
+                         internalerror(2003010305);
+                       AsmWrite(#9'.align '+tostr(i));
+                       last_align := i;
+                     end;
+                   AsmLn;
+                 end;
+             end;
+
+           ait_section :
+             begin
+               if tai_section(hp).sectype<>sec_none then
+                 WriteSection(tai_section(hp).sectype,tai_section(hp).name^)
+               else
+                 begin
+{$ifdef EXTDEBUG}
+                   AsmWrite(target_asm.comment);
+                   AsmWriteln(' sec_none');
+{$endif EXTDEBUG}
+                end;
+             end;
+
+           ait_datablock :
+             begin
+               if target_info.system=system_powerpc_darwin then
+                 begin
+                   {On Mac OS X you can't have common symbols in a shared
+                    library, since those are in the TEXT section and the text section is
+                    read-only in shared libraries (so it can be shared among different
+                    processes). The alternate code creates some kind of common symbols in
+                    the data segment. The generic code no longer uses common symbols, but
+                    this doesn't work on Mac OS X as well.}
+                   if tai_datablock(hp).is_global then
+                     begin
+                       asmwrite('.globl ');
+                       asmwriteln(tai_datablock(hp).sym.name);
+                       asmwriteln('.data');
+                       asmwrite('.zerofill __DATA, __common, ');
+                       asmwrite(tai_datablock(hp).sym.name);
+                       asmwriteln(', '+tostr(tai_datablock(hp).size)+','+tostr(last_align));
+                       if not(CurrSecType in [sec_data,sec_none]) then
+                         writesection(CurrSecType,'');
+                     end
+                   else
+                     begin
+                       asmwrite(#9'.lcomm'#9);
+                       asmwrite(tai_datablock(hp).sym.name);
+                       asmwrite(','+tostr(tai_datablock(hp).size));
+                       asmwrite(','+tostr(last_align));
+                       asmwriteln('');
+                     end
+                 end
+               else
+                 begin
+                   if Tai_datablock(hp).is_global then
+                     begin
+                       asmwrite(#9'.globl ');
+                       asmwriteln(Tai_datablock(hp).sym.name);
+                     end;
+                   asmwrite(Tai_datablock(hp).sym.name);
+                   asmwriteln(':');
+                   asmwriteln(#9'.space '+tostr(Tai_datablock(hp).size));
+                 end;
+             end;
+
+{$ifndef cpu64bit}
+           ait_const_128bit :
+              begin
+                internalerror(200404291);
+              end;
+
+           ait_const_64bit :
+              begin
+                if assigned(tai_const(hp).sym) then
+                  internalerror(200404292);
+                AsmWrite(ait_const2str[ait_const_32bit]);
+                if target_info.endian = endian_little then
+                  begin
+                    AsmWrite(tostr(longint(lo(tai_const(hp).value))));
+                    AsmWrite(',');
+                    AsmWrite(tostr(longint(hi(tai_const(hp).value))));
+                  end
+                else
+                  begin
+                    AsmWrite(tostr(longint(hi(tai_const(hp).value))));
+                    AsmWrite(',');
+                    AsmWrite(tostr(longint(lo(tai_const(hp).value))));
+                  end;
+                AsmLn;
+              end;
+{$endif cpu64bit}
+
+           ait_const_uleb128bit,
+           ait_const_sleb128bit,
+{$ifdef cpu64bit}
+           ait_const_128bit,
+           ait_const_64bit,
+{$endif cpu64bit}
+           ait_const_32bit,
+           ait_const_16bit,
+           ait_const_8bit,
+           ait_const_rva_symbol,
+           ait_const_indirect_symbol :
+             begin
+               AsmWrite(ait_const2str[hp.typ]);
+               consttyp:=hp.typ;
+               l:=0;
+               repeat
+                 if assigned(tai_const(hp).sym) then
+                   begin
+                     if assigned(tai_const(hp).endsym) then
+                       s:=tai_const(hp).endsym.name+'-'+tai_const(hp).sym.name
+                     else
+                       s:=tai_const(hp).sym.name;
+                     if tai_const(hp).value<>0 then
+                       s:=s+tostr_with_plus(tai_const(hp).value);
+                   end
+                 else
+                   s:=tostr(tai_const(hp).value);
+                 AsmWrite(s);
+                 inc(l,length(s));
+                 { Values with symbols are written on a single line to improve
+                   reading of the .s file (PFV) }
+                 if assigned(tai_const(hp).sym) or
+                    not(CurrSecType in [sec_data,sec_rodata]) or
+                    (l>line_length) or
+                    (hp.next=nil) or
+                    (tai(hp.next).typ<>consttyp) or
+                    assigned(tai_const(hp.next).sym) then
+                   break;
+                 hp:=tai(hp.next);
+                 AsmWrite(',');
+               until false;
+               AsmLn;
+             end;
+
+{$ifdef cpuextended}
+           ait_real_80bit :
+             begin
+               if do_line then
+                AsmWriteLn(target_asm.comment+'value: '+extended2str(tai_real_80bit(hp).value));
+             { Make sure e is a extended type, bestreal could be
+               a different type (bestreal) !! (PFV) }
+               e:=tai_real_80bit(hp).value;
+               AsmWrite(#9'.byte'#9);
+               for i:=0 to 9 do
+                begin
+                  if i<>0 then
+                   AsmWrite(',');
+                  AsmWrite(tostr(t80bitarray(e)[i]));
+                end;
+               AsmLn;
+             end;
+{$endif cpuextended}
+
+           ait_real_64bit :
+             begin
+               if do_line then
+                AsmWriteLn(target_asm.comment+'value: '+double2str(tai_real_64bit(hp).value));
+               d:=tai_real_64bit(hp).value;
+               { swap the values to correct endian if required }
+               if source_info.endian <> target_info.endian then
+                 swap64bitarray(t64bitarray(d));
+               AsmWrite(#9'.byte'#9);
+{$ifdef arm}
+{ on a real arm cpu, it's already hi/lo swapped }
+{$ifndef cpuarm}
+               if tai_real_64bit(hp).formatoptions=fo_hiloswapped then
+                 begin
+                   for i:=4 to 7 do
+                     begin
+                       if i<>4 then
+                         AsmWrite(',');
+                       AsmWrite(tostr(t64bitarray(d)[i]));
+                     end;
+                   for i:=0 to 3 do
+                     begin
+                       AsmWrite(',');
+                       AsmWrite(tostr(t64bitarray(d)[i]));
+                     end;
+                 end
+               else
+{$endif cpuarm}
+{$endif arm}
+                 begin
+                   for i:=0 to 7 do
+                     begin
+                       if i<>0 then
+                         AsmWrite(',');
+                       AsmWrite(tostr(t64bitarray(d)[i]));
+                     end;
+                 end;
+               AsmLn;
+             end;
+
+           ait_real_32bit :
+             begin
+               if do_line then
+                AsmWriteLn(target_asm.comment+'value: '+single2str(tai_real_32bit(hp).value));
+               sin:=tai_real_32bit(hp).value;
+               { swap the values to correct endian if required }
+               if source_info.endian <> target_info.endian then
+                 swap32bitarray(t32bitarray(sin));
+               AsmWrite(#9'.byte'#9);
+               for i:=0 to 3 do
+                begin
+                  if i<>0 then
+                   AsmWrite(',');
+                  AsmWrite(tostr(t32bitarray(sin)[i]));
+                end;
+               AsmLn;
+             end;
+
+           ait_comp_64bit :
+             begin
+               if do_line then
+                AsmWriteLn(target_asm.comment+'value: '+extended2str(tai_comp_64bit(hp).value));
+               AsmWrite(#9'.byte'#9);
+{$ifdef FPC}
+               co:=comp(tai_comp_64bit(hp).value);
+{$else}
+               co:=tai_comp_64bit(hp).value;
+{$endif}
+               { swap the values to correct endian if required }
+               if source_info.endian <> target_info.endian then
+                 swap64bitarray(t64bitarray(co));
+               for i:=0 to 7 do
+                begin
+                  if i<>0 then
+                   AsmWrite(',');
+                  AsmWrite(tostr(t64bitarray(co)[i]));
+                end;
+               AsmLn;
+             end;
+
+           ait_string :
+             begin
+               pos:=0;
+               for i:=1 to tai_string(hp).len do
+                begin
+                  if pos=0 then
+                   begin
+                     AsmWrite(#9'.ascii'#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).l.is_used) then
+                begin
+                  if tai_label(hp).l.defbind=AB_GLOBAL then
+                   begin
+                     AsmWrite('.globl'#9);
+                     AsmWriteLn(tai_label(hp).l.name);
+                   end;
+                  AsmWrite(tai_label(hp).l.name);
+                  AsmWriteLn(':');
+                end;
+             end;
+           ait_symbol :
+             begin
+               if tai_symbol(hp).is_global then
+                begin
+                  AsmWrite('.globl'#9);
+                  AsmWriteLn(tai_symbol(hp).sym.name);
+                end;
+               if (target_info.system = system_powerpc64_linux) and
+                 (tai_symbol(hp).sym.typ = AT_FUNCTION) then
+                 begin
+                   AsmWriteLn('.section "opd", "aw"');
+                   AsmWriteLn('.align 3');
+                   AsmWriteLn(tai_symbol(hp).sym.name + ':');
+                   AsmWriteLn('.quad .' + tai_symbol(hp).sym.name + ', .TOC.@tocbase, 0');
+                   AsmWriteLn('.previous');
+                   AsmWriteLn('.size ' + tai_symbol(hp).sym.name + ', 24');
+                   AsmWriteLn('.globl .' + tai_symbol(hp).sym.name);
+                   AsmWriteLn('.type .' + tai_symbol(hp).sym.name + ', @function');
+                   { the dotted name is the name of the actual function }
+                   AsmWrite('.');
+                 end
+               else
+                 begin
+                   if (target_info.system <> system_arm_linux) then
+                     begin
+                       sepChar := '@';
+                     end
+                   else
+                     begin
+                       sepChar := '#';
+                     end;
+
+                   if (tf_needs_symbol_type in target_info.flags) then
+                     begin
+                       AsmWrite(#9'.type'#9 + tai_symbol(hp).sym.name);
+                       if (needsObject(tai_symbol(hp))) then
+                         begin
+                           AsmWriteLn(',' + sepChar + 'object');
+                         end
+                       else
+                         begin
+                           AsmWriteLn(',' + sepChar + 'function');
+                         end;
+                     end;
+                   if (tf_needs_symbol_size in target_info.flags) and (tai_symbol(hp).sym.size > 0) then begin
+                     AsmWriteLn(#9'.size'#9 + tai_symbol(hp).sym.name + ', ' + tostr(tai_symbol(hp).sym.size));
+                   end;
+                 end;
+               AsmWriteLn(tai_symbol(hp).sym.name + ':');
+             end;
+
+           ait_symbol_end :
+             begin
+               if tf_needs_symbol_size in target_info.flags then
+                begin
+                  s:=target_asm.labelprefix+'e'+tostr(symendcount);
+                  inc(symendcount);
+                  AsmWriteLn(s+':');
+                  AsmWrite(#9'.size'#9);
+                  if (target_info.system = system_powerpc64_linux) and (tai_symbol_end(hp).sym.typ = AT_FUNCTION) then
+                    begin
+                      AsmWrite('.');
+                    end;
+                  AsmWrite(tai_symbol_end(hp).sym.name);
+                  AsmWrite(', '+s+' - ');
+                  if (target_info.system = system_powerpc64_linux) and (tai_symbol_end(hp).sym.typ = AT_FUNCTION) then
+                    begin
+                      AsmWrite('.');
+                    end;
+                  AsmWriteLn(tai_symbol_end(hp).sym.name);
+                end;
+             end;
+
+           ait_instruction :
+             begin
+               WriteInstruction(hp);
+             end;
+
+           ait_stab :
+             begin
+               if assigned(tai_stab(hp).str) then
+                 begin
+                   AsmWrite(#9'.'+stabtypestr[tai_stab(hp).stabtype]+' ');
+                   AsmWritePChar(tai_stab(hp).str);
+                   AsmLn;
+                 end;
+             end;
+
+           ait_force_line,
+           ait_function_name : ;
+
+           ait_cutobject :
+             begin
+               if SmartAsm then
+                begin
+                { only reset buffer if nothing has changed }
+                  if AsmSize=AsmStartSize then
+                   AsmClear
+                  else
+                   begin
+                     AsmClose;
+                     DoAssemble;
+                     AsmCreate(tai_cutobject(hp).place);
+                   end;
+                { avoid empty files }
+                  while assigned(hp.next) and (tai(hp.next).typ in [ait_cutobject,ait_section,ait_comment]) do
+                   begin
+                     if tai(hp.next).typ=ait_section then
+                       CurrSecType:=tai_section(hp.next).sectype;
+                     hp:=tai(hp.next);
+                   end;
+                  if CurrSecType<>sec_none then
+                    WriteSection(CurrSecType,'');
+                  AsmStartSize:=AsmSize;
+                end;
+             end;
+
+           ait_marker :
+             if tai_marker(hp).kind=InlineStart then
+               inc(InlineLevel)
+             else if tai_marker(hp).kind=InlineEnd then
+               dec(InlineLevel);
+
+           ait_directive :
+             begin
+               AsmWrite('.'+directivestr[tai_directive(hp).directive]+' ');
+               if assigned(tai_directive(hp).name) then
+                 AsmWrite(tai_directive(hp).name^);
+               AsmLn;
+             end;
+
+           else
+             internalerror(10000);
+         end;
+         hp:=tai(hp.next);
+       end;
+    end;
+
+
+    procedure TGNUAssembler.WriteExtraHeader;
+
+      begin
+      end;
+
+    procedure TGNUAssembler.WriteAsmList;
+    var
+      p:dirstr;
+      n:namestr;
+      e:extstr;
+      hal : tasmlist;
+    begin
+{$ifdef EXTDEBUG}
+      if assigned(current_module.mainsource) then
+       Comment(V_Debug,'Start writing gas-styled assembler output for '+current_module.mainsource^);
+{$endif}
+
+      CurrSecType:=sec_none;
+      FillChar(lastfileinfo,sizeof(lastfileinfo),0);
+      LastInfile:=nil;
+
+      if assigned(current_module.mainsource) then
+{$IFDEF USE_SYSUTILS}
+      begin
+       p := SplitPath(current_module.mainsource^);
+       n := SplitName(current_module.mainsource^);
+       e := SplitExtension(current_module.mainsource^);
+      end
+{$ELSE USE_SYSUTILS}
+       fsplit(current_module.mainsource^,p,n,e)
+{$ENDIF USE_SYSUTILS}
+      else
+       begin
+         p:=inputdir;
+         n:=inputfile;
+         e:=inputextension;
+       end;
+    { to get symify to work }
+      AsmWriteLn(#9'.file "'+FixFileName(n+e)+'"');
+      WriteExtraHeader;
+      AsmStartSize:=AsmSize;
+      symendcount:=0;
+
+      for hal:=low(Tasmlist) to high(Tasmlist) do
+        begin
+          AsmWriteLn(target_asm.comment+'Begin asmlist '+TasmlistStr[hal]);
+          writetree(asmlist[hal]);
+          AsmWriteLn(target_asm.comment+'End asmlist '+TasmlistStr[hal]);
+        end;
+
+      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;
+
+end.

+ 281 - 0
compiler/alpha/aasmcpu.pas

@@ -0,0 +1,281 @@
+{
+    Copyright (c) 1998-2000 by Florian Klaempfl
+
+    Implements the assembler classes specific for the Alpha
+
+    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.
+
+ ****************************************************************************
+}
+{
+  Implements the assembler classes specific for the Alpha.
+}
+unit aasmcpu;
+
+{$i fpcdefs.inc}
+
+  interface
+
+    uses
+       aasmbase,globals,verbose,
+       cpubase,aasmtai;
+
+    type
+      tai_frame = class(tai)
+         G,R : TRegister;
+         LS,LU : longint;
+        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(taicpu_abstract)
+         constructor op_none(op : tasmop);
+
+         constructor op_reg(op : tasmop;_op1 : tregister);
+         constructor op_const(op : tasmop;_op1 : longint);
+         constructor op_ref(op : tasmop;_op1 : preference);
+
+         constructor op_reg_reg(op : tasmop;_op1,_op2 : tregister);
+         constructor op_reg_ref(op : tasmop;_op1 : tregister;_op2 : preference);
+         constructor op_reg_const(op:tasmop; _op1: tregister; _op2: longint);
+
+         constructor op_const_reg(op : tasmop;_op1 : longint;_op2 : tregister);
+         constructor op_const_const(op : tasmop;_op1,_op2 : longint);
+         constructor op_const_ref(op : tasmop;_op1 : longint;_op2 : preference);
+
+         constructor op_ref_reg(op : tasmop;_op1 : preference;_op2 : tregister);
+         { this is only allowed if _op1 is an int value (_op1^.isintvalue=true) }
+         constructor op_ref_ref(op : tasmop;_op1,_op2 : preference);
+
+         constructor op_reg_reg_reg(op : tasmop;_op1,_op2,_op3 : tregister);
+         constructor op_reg_const_reg(op : tasmop;_op1 : tregister;_op2 : longint;_op3 : tregister);
+         constructor op_const_ref_reg(op : tasmop;_op1 : longint;_op2 : preference;_op3 : tregister);
+         constructor op_reg_reg_ref(op : tasmop;_op1,_op2 : tregister; _op3 : preference);
+         constructor op_const_reg_ref(op : tasmop;_op1 : longint;_op2 : tregister;_op3 : preference);
+         constructor op_reg_ref_const(op : tasmop;_op1 : tregister;_op2 : preference;_op3 : longint);
+
+         { this is for Jmp instructions }
+         constructor op_cond_sym(op : tasmop;cond:TAsmCond;_op1 : tasmsymbol);
+
+         constructor op_sym(op : tasmop;_op1 : tasmsymbol);
+         constructor op_sym_ofs(op : tasmop;_op1 : tasmsymbol;_op1ofs:longint);
+         constructor op_sym_ofs_reg(op : tasmop;_op1 : tasmsymbol;_op1ofs:longint;_op2 : tregister);
+         constructor op_sym_ofs_ref(op : tasmop;_op1 : tasmsymbol;_op1ofs:longint;_op2 : preference);
+      end;
+
+      tai_align = class(tai_align_abstract)
+        { nothing to add }
+      end;
+
+    procedure InitAsm;
+    procedure DoneAsm;
+
+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;
+      end;
+
+
+    constructor taicpu.op_const(op : tasmop;_op1 : longint);
+      begin
+         inherited create(op);
+         ops:=1;
+      end;
+
+
+    constructor taicpu.op_ref(op : tasmop;_op1 : preference);
+      begin
+         inherited create(op);
+         ops:=1;
+      end;
+
+
+    constructor taicpu.op_reg_reg(op : tasmop;_op1,_op2 : tregister);
+      begin
+         inherited create(op);
+         ops:=2;
+      end;
+
+
+    constructor taicpu.op_reg_const(op:tasmop; _op1: tregister; _op2: longint);
+      begin
+         inherited create(op);
+         ops:=2;
+      end;
+
+
+    constructor taicpu.op_reg_ref(op : tasmop;_op1 : tregister;_op2 : preference);
+      begin
+         inherited create(op);
+         ops:=2;
+      end;
+
+
+    constructor taicpu.op_const_reg(op : tasmop;_op1 : longint;_op2 : tregister);
+      begin
+         inherited create(op);
+         ops:=2;
+      end;
+
+
+    constructor taicpu.op_const_const(op : tasmop;_op1,_op2 : longint);
+      begin
+         inherited create(op);
+         ops:=2;
+      end;
+
+
+    constructor taicpu.op_const_ref(op : tasmop;_op1 : longint;_op2 : preference);
+      begin
+         inherited create(op);
+         ops:=2;
+      end;
+
+    constructor taicpu.op_ref_reg(op : tasmop;_op1 : preference;_op2 : tregister);
+      begin
+         inherited create(op);
+         ops:=2;
+      end;
+
+
+    constructor taicpu.op_ref_ref(op : tasmop;_op1,_op2 : preference);
+      begin
+         inherited create(op);
+         ops:=2;
+      end;
+
+
+    constructor taicpu.op_reg_reg_reg(op : tasmop;_op1,_op2,_op3 : tregister);
+      begin
+         inherited create(op);
+         ops:=3;
+      end;
+
+    constructor taicpu.op_reg_const_reg(op : tasmop;_op1 : tregister;_op2 : longint;_op3 : tregister);
+      begin
+         inherited create(op);
+         ops:=3;
+      end;
+
+     constructor taicpu.op_reg_reg_ref(op : tasmop;_op1,_op2 : tregister;_op3 : preference);
+      begin
+         inherited create(op);
+         ops:=3;
+      end;
+
+     constructor taicpu.op_const_ref_reg(op : tasmop;_op1 : longint;_op2 : preference;_op3 : tregister);
+      begin
+         inherited create(op);
+         ops:=3;
+      end;
+
+     constructor taicpu.op_const_reg_ref(op : tasmop;_op1 : longint;_op2 : tregister;_op3 : preference);
+      begin
+         inherited create(op);
+         ops:=3;
+      end;
+
+     constructor taicpu.op_reg_ref_const(op : tasmop;_op1 : tregister;_op2 : preference;_op3 : longint);
+      begin
+         inherited create(op);
+         ops:=3;
+      end;
+
+
+    constructor taicpu.op_cond_sym(op : tasmop;cond:TAsmCond;_op1 : tasmsymbol);
+      begin
+         inherited create(op);
+         condition:=cond;
+         ops:=1;
+      end;
+
+
+    constructor taicpu.op_sym(op : tasmop;_op1 : tasmsymbol);
+      begin
+         inherited create(op);
+         ops:=1;
+      end;
+
+
+    constructor taicpu.op_sym_ofs(op : tasmop;_op1 : tasmsymbol;_op1ofs:longint);
+      begin
+         inherited create(op);
+         ops:=1;
+      end;
+
+
+    constructor taicpu.op_sym_ofs_reg(op : tasmop;_op1 : tasmsymbol;_op1ofs:longint;_op2 : tregister);
+      begin
+         inherited create(op);
+         ops:=2;
+      end;
+
+
+    constructor taicpu.op_sym_ofs_ref(op : tasmop;_op1 : tasmsymbol;_op1ofs:longint;_op2 : preference);
+      begin
+         inherited create(op);
+         ops:=2;
+      end;
+
+    Constructor tai_frame.create (GP : Tregister; Localsize : Longint; RA : TRegister; L : longint);
+
+    begin
+      Inherited Create;
+      typ:=ait_frame;
+      G:=GP;
+      R:=RA;
+      LS:=LocalSize;
+      LU:=L;
+    end;
+
+    Constructor tai_ent.Create (const ProcName : String);
+
+    begin
+      Inherited Create;
+      typ:=ait_ent;
+      Name:=ProcName;
+    end;
+
+    procedure InitAsm;
+      begin
+      end;
+
+
+    procedure DoneAsm;
+      begin
+      end;
+
+
+    end.

+ 126 - 0
compiler/alpha/agaxpgas.pas

@@ -0,0 +1,126 @@
+{
+    Copyright (c) 1998-2000 by Florian Klaempfl
+
+    This unit implements an asm for the DEC Alpha
+
+    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 agaxpgas;
+
+  {$i fpcdefs.inc}
+
+  interface
+
+    uses
+       globals,systems,aasmbase,aasmtai,
+       aggas,cpubase;
+
+    type
+      TAXPGNUAssembler=class(TGNUAssembler)
+        procedure WriteInstruction(hp : tai);override;
+      end;
+
+    const
+       gas_reg2str : array[tregister] of string[4] = (
+         '',
+         '','','','','','','','','','',
+         '','','','','','','','','','',
+         '','','','','','','','','','',
+         '','',
+         '','','','','','','','','','',
+         '','','','','','','','','','',
+         '','','','','','','','','','',
+         '',''
+       );
+
+  implementation
+
+    const
+       op2str : array[tasmop] of string[14] = (
+          'addf','addg','addl','addq',
+          'adds','addt','amask','and','beq','bge',
+          'bgt','bic','bis','blbc','blbs','ble',
+          'blt','bne','br','bsr','call_pal','cmoveq',
+          'cmovge','cmovgt','cmovlbc','cmovlbs','cmovle','cmovlt',
+          'cmovne','cmpbge','cmpeq','cmpgeq','cmpgle','cmpglt',
+          'cmple','cmplt','cmpteq','cmptle','cmptlt','cmptun',
+          'cmpule','cmpult','cpys','cpyse','cpysn','ctlz',
+          'ctpop','cttz','cvtdg','cvtgd','cvtgf','cvtgq',
+          'cvtlq','cvtqf','cvtqg','cvtql','cvtqs','cvtqt',
+          'cvtst','cvttq','cvtts','divf','divg','divs',
+          'divt','ecb','eqv','excb','extbl','extlh',
+          'extll','extqh','extql','extwh','extwl','fbeq',
+          'fbge','fbgt','fble','fblt','fbne','fcmoveq',
+          'fcmovge','fcmovgt','fcmovle','fcmovlt','fcmovne','fetch',
+          'fetch_m','ftois','ftoit','implver','insbl','inslh',
+          'insll','insqh','insql','inswh','inswl','itoff',
+          'itofs','itoft','jmp','jsr','jsr_coroutine','lda',
+          'ldah','ldbu','ldwu','ldf','ldg','ldl',
+          'ldl_l','ldq','ldq_l','ldq_u','lds','ldt',
+          'maxsb8','maxsw4','maxub8','maxuw4','mb','mf_fpcr',
+          'minsb8','minsw4','minub8','minuw4','mskbl','msklh',
+          'mskll','mskqh','mskql','mskwh','mskwl','mt_fpcr',
+          'mulf','mulg','mull','mulq',
+          'muls','mult','ornot','perr','pklb','pkwb',
+          'rc','ret','rpcc','rs','s4addl','s4addq',
+          's4subl','s4subq','s8addl','s8addq','s8subl','s8subq',
+          'sextb','sextw','sll','sqrtf','sqrtg','sqrts',
+          'sqrtt','sra','srl','stb','stf','stg',
+          'sts','stl','stl_c','stq','stq_c','stq_u',
+          'stt','stw','subf','subg','subl',
+          'subq','subs','subt','trapb','umulh','unpkbl',
+          'unpkbw','wh64','wmb','xor','zap','zapnot',
+          'ldgp');
+
+      procedure TAXPGNUAssembler.WriteInstruction (hp : tai);
+        begin
+(*
+               op:=paicpu(hp)^.opcode;
+               calljmp:=is_calljmp(op);
+             { call maybe not translated to calll }
+               s:=#9+att_op2str[op]+cond2str[paicpu(hp)^.condition];
+               if (not calljmp) and
+                  (not att_nosuffix[op]) and
+                  not(
+                   (paicpu(hp)^.oper[0].typ=top_reg) and
+                   (paicpu(hp)^.oper[0].reg in [R_ST..R_ST7])
+                  ) then
+                s:=s+att_opsize2str[paicpu(hp)^.opsize];
+             { process operands }
+               if paicpu(hp)^.ops<>0 then
+                begin
+                { call and jmp need an extra handling                          }
+                { this code is only called if jmp isn't a labeled instruction }
+                  if calljmp then
+                   s:=s+#9+getopstr_jmp(paicpu(hp)^.oper[0])
+                  else
+                   begin
+                     for i:=0to paicpu(hp)^.ops-1 do
+                      begin
+                        if i=0 then
+                         sep:=#9
+                        else
+                         sep:=',';
+                        s:=s+sep+getopstr(paicpu(hp)^.oper[i])
+                      end;
+                   end;
+                end;
+               AsmWriteLn(s);
+*)
+             end;
+
+end.

+ 38 - 0
compiler/alpha/aoptcpu.pas

@@ -0,0 +1,38 @@
+{
+    Copyright (c) 1998-2000 by Jonas Maebe, member of the Free Pascal
+    Development Team
+
+    This unit implements the Alpha optimizer 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.
+
+ ****************************************************************************
+}
+
+
+Unit aoptcpu;
+
+Interface
+
+uses cpubase, aoptobj, aoptcpub;
+
+Type
+  TAOptCpu = Object(TAoptObj)
+    { uses the same constructor as TAopObj }
+  End;
+
+Implementation
+
+End.

+ 115 - 0
compiler/alpha/aoptcpub.pas

@@ -0,0 +1,115 @@
+ {
+    Copyright (c) 1998-2000 by Jonas Maebe, member of the Free Pascal
+    Development Team
+
+    This unit contains several types and constants necessary for the
+    optimizer to work on the 80x86 architecture
+
+    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 aoptcpub; { Assembler OPTimizer CPU specific Base }
+
+{ enable the following define if memory references can have both a base and }
+{ index register in 1 operand                                               }
+
+{$define RefsHaveIndexReg}
+
+{ enable the following define if memory references can have a scaled index }
+
+{$define RefsHaveScale}
+
+{ enable the following define if memory references can have a segment }
+{ override                                                            }
+
+{ define RefsHaveSegment}
+
+Interface
+
+Uses
+  CPUAsm,AOptBase;
+
+Type
+
+{ type of a normal instruction }
+  TInstr = Taicpu;
+  PInstr = ^TInstr;
+
+{ ************************************************************************* }
+{ **************************** TCondRegs ********************************** }
+{ ************************************************************************* }
+{ Info about the conditional registers                                      }
+  TCondRegs = Object
+    Constructor Init;
+    Destructor Done;
+  End;
+
+{ ************************************************************************* }
+{ **************************** TAoptBaseCpu ******************************* }
+{ ************************************************************************* }
+
+  TAoptBaseCpu = Object(TAoptBase)
+  End;
+
+
+{ ************************************************************************* }
+{ ******************************* Constants ******************************* }
+{ ************************************************************************* }
+Const
+
+{ the maximum number of things (registers, memory, ...) a single instruction }
+{ changes                                                                    }
+
+  MaxCh = 3;
+
+{ the maximum number of operands an instruction has }
+
+  MaxOps = 3;
+
+{Oper index of operand that contains the source (reference) with a load }
+{instruction                                                            }
+
+  LoadSrc = 0;
+
+{Oper index of operand that contains the destination (register) with a load }
+{instruction                                                                }
+
+  LoadDst = 1;
+
+{Oper index of operand that contains the source (register) with a store }
+{instruction                                                            }
+
+  StoreSrc = 0;
+
+{Oper index of operand that contains the destination (reference) with a load }
+{instruction                                                                 }
+
+  StoreDst = 1;
+
+Implementation
+
+{ ************************************************************************* }
+{ **************************** TCondRegs ********************************** }
+{ ************************************************************************* }
+Constructor TCondRegs.init;
+Begin
+End;
+
+Destructor TCondRegs.Done; {$ifdef inl} inline; {$endif inl}
+Begin
+End;
+
+End.

+ 38 - 0
compiler/alpha/aoptcpuc.pas

@@ -0,0 +1,38 @@
+ {
+    Copyright (c) 1998-2000 by Jonas Maebe, member of the Free Pascal
+    Development Team
+
+    This unit contains the processor specific implementation of the
+    assembler optimizer common subexpression elimination 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.
+
+ ****************************************************************************
+}
+unit aoptcpuc;
+
+Interface
+
+Uses
+  AOptCs;
+
+Type
+  TRegInfoCpu = Object(TRegInfo)
+  End;
+
+
+Implementation
+
+End.

+ 39 - 0
compiler/alpha/aoptcpud.pas

@@ -0,0 +1,39 @@
+{
+    Copyright (c) 1998-2000 by Jonas Maebe, member of the Free Pascal
+    Development Team
+
+    This unit contains the processor specific implementation of the
+    assembler optimizer data flow analyzer.
+
+    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 aoptcpud;
+
+Interface
+
+uses
+  AOptDA;
+
+Type
+  PAOptDFACpu = ^TAOptDFACpu;
+  TAOptDFACpu = Object(TAOptDFA)
+  End;
+
+Implementation
+
+
+End.

+ 160 - 0
compiler/alpha/cgcpu.pas

@@ -0,0 +1,160 @@
+{
+    Copyright (c) 1998-2000 by Florian Klaempfl
+
+    This unit implements the code generator for the Alpha
+
+    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 implements the code generator for the Alpha.
+}
+unit cgcpu;
+
+{$i fpcdefs.inc}
+
+interface
+
+uses
+   cgbase,cgobj,aasmbase,aasmtai,aasmcpu,cginfo,cpubase,cpuinfo;
+
+type
+pcgalpha = ^tcgalpha;
+tcgalpha = class(tcg)
+  procedure a_call_name(list : taasmoutput;const s : string);override;
+  procedure a_load_const_reg(list : taasmoutput;size : tcgsize;a : aword;register : tregister);override;
+  procedure a_load_reg_ref(list : taasmoutput;size : tcgsize;register : tregister;const ref : treference);override;
+  procedure a_load_ref_reg(list : taasmoutput;size : tcgsize;const ref : treference;register : tregister);override;
+  procedure a_load_reg_reg(list : taasmoutput;fromsize, tosize : tcgsize;reg1,reg2 : tregister);override;
+  procedure a_cmp_const_reg_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp;a : aword;
+    reg : tregister;  l : tasmlabel);override;
+  procedure a_cmp_reg_reg_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp;reg1,reg2 : tregister;l : tasmlabel);
+  procedure a_cmp_reg_ref_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp;reg : tregister;l : tasmlabel);
+  procedure a_cmp_ref_const_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp;a : aword;
+    reg : tregister; l : tasmlabel);
+  procedure a_loadaddr_ref_reg(list : taasmoutput;const ref : treference;r : tregister);override;
+  procedure g_stackframe_entry(list : taasmoutput;localsize : longint);override;
+  procedure g_maybe_loadself(list : taasmoutput);override;
+  procedure g_restore_frame_pointer(list : taasmoutput);override;
+end;
+
+implementation
+
+uses
+   globtype,globals;
+
+procedure tcgalpha.g_stackframe_entry(list : taasmoutput;localsize : longint);
+
+begin
+   list.concat(taicpu.op_reg_ref(A_LDGP,Global_pointer,new_reference(R_27,0)));
+   list.concat(taicpu.op_reg_ref(A_LDA,stack_pointer_reg,new_reference(stack_pointer_reg,-LocalSize)));
+   If LocalSize<>0 then
+     list.concat(tai_frame.create(Global_pointer,LocalSize,R_27,0));
+   { Always generate a frame pointer. }
+   list.concat(taicpu.op_reg_reg_reg(A_BIS,stack_pointer_reg,stack_pointer_reg,frame_pointer_reg));
+end;
+
+procedure g_exitcode(list : taasmoutput;parasize : longint; nostackframe,inlined : boolean);
+
+begin
+   { Restore stack pointer from frame pointer }
+   list.Concat (taicpu.op_reg_reg_reg(A_BIS,frame_pointer_reg,frame_pointer_reg,stack_pointer_reg));
+   { Restore previous stack position}
+   list.Concat (taicpu.op_reg_const_reg(A_ADDQ,stack_pointer_reg,Parasize,stack_pointer_reg));
+   { return... }
+   list.Concat(taicpu.op_reg_ref_const(A_RET,stack_pointer_reg,new_reference(Return_pointer,0),1));
+    { end directive
+    Concat (paiend,init(''));
+    }
+end;
+
+procedure tcgalpha.a_call_name(list : taasmoutput;const s : string);
+
+  begin
+     { list^.concat(taicpu,op_sym(A_CALL,S_NO,newasmsymbol(s,AB_EXTERNAL,AT_FUNCTION)))); }
+     {!!!!!!!!!1 offset is ignored }
+     abstract;
+  end;
+
+procedure tcgalpha.a_load_const_reg(list : taasmoutput;size : tcgsize;a : aword;register : tregister);
+
+begin
+end;
+
+
+procedure tcgalpha.a_load_reg_ref(list : taasmoutput;size : tcgsize;register : tregister;const ref : treference);
+
+begin
+end;
+
+
+procedure tcgalpha.a_load_ref_reg(list : taasmoutput;size : tcgsize;const ref : treference;register : tregister);
+
+begin
+end;
+
+
+procedure tcgalpha.a_load_reg_reg(list : taasmoutput;fromsize, tosize : tcgsize;reg1,reg2 : tregister);
+
+begin
+end;
+
+
+procedure tcgalpha.a_cmp_const_reg_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp;a : aword;reg : tregister;
+  l : tasmlabel);
+
+begin
+end;
+
+
+procedure tcgalpha.a_cmp_reg_reg_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp;reg1,reg2 : tregister;l : tasmlabel);
+
+begin
+end;
+
+
+procedure tcgalpha.a_cmp_reg_ref_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp;reg : tregister;l : tasmlabel);
+
+begin
+end;
+
+
+procedure tcgalpha.a_cmp_ref_const_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp;a : aword;
+  reg : tregister; l : tasmlabel);
+
+begin
+end;
+
+
+procedure tcgalpha.a_loadaddr_ref_reg(list : taasmoutput;const ref : treference;r : tregister);
+
+begin
+end;
+
+
+procedure tcgalpha.g_maybe_loadself(list : taasmoutput);
+
+begin
+end;
+
+
+procedure tcgalpha.g_restore_frame_pointer(list : taasmoutput);
+
+begin
+end;
+
+
+end.

+ 457 - 0
compiler/alpha/cpubase.pas

@@ -0,0 +1,457 @@
+{
+    Copyright (C) 1998-2000 by Florian Klaempfl
+
+    This unit implements an asmlistitem class for the Alpha architecture.
+
+    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 implements an asmlistitem class for the Alpha architecture.
+}
+unit cpubase;
+
+{$i fpcdefs.inc}
+
+  interface
+
+    uses
+       cutils,cclasses,globals,aasmbase,cpuinfo,cginfo;
+
+    type
+       { all registers }
+       TRegister = (R_NO,  { R_NO is Mandatory, signifies no register }
+                    R_0,R_1,R_2,R_3,R_4,R_5,R_6,R_7,R_8,R_9,
+                    R_10,R_11,R_12,R_13,R_14,R_15,R_16,R_17,R_18,R_19,
+                    R_20,R_21,R_22,R_23,R_24,R_25,R_26,R_27,R_28,R_29,
+                    R_30,R_31,
+                    R_F0,R_F1,R_F2,R_F3,R_F4,R_F5,R_F6,R_F7,R_F8,R_F9,
+                    R_F10,R_F11,R_F12,R_F13,R_F14,R_F15,R_F16,R_F17,R_F18,R_F19,
+                    R_F20,R_F21,R_F22,R_F23,R_F24,R_F25,R_F26,R_F27,R_F28,R_F29,
+                    R_F30,R_F31);
+
+       tasmop = (A_ADDF,A_ADDG,A_ADDL,A_ADDQ,
+                 A_ADDS,A_ADDT,A_AMASK,A_AND,A_BEQ,A_BGE,
+                 A_BGT,A_BIC,A_BIS,A_BLBC,A_BLBS,A_BLE,
+                 A_BLT,A_BNE,A_BR,A_BSR,A_CALL_PAL,A_CMOVEQ,
+                 A_CMOVGE,A_CMOVGT,A_CMOVLBC,A_CMOVLBS,A_CMOVLE,A_CMOVLT,
+                 A_CMOVNE,A_CMPBGE,A_CMPEQ,A_CMPGEQ,A_CMPGLE,A_CMPGLT,
+                 A_CMPLE,A_CMPLT,A_CMPTEQ,A_CMPTLE,A_CMPTLT,A_CMPTUN,
+                 A_CMPULE,A_CMPULT,A_CPYS,A_CPYSE,A_CPYSN,A_CTLZ,
+                 A_CTPOP,A_CTTZ,A_CVTDG,A_CVTGD,A_CVTGF,A_CVTGQ,
+                 A_CVTLQ,A_CVTQF,A_CVTQG,A_CVTQL,A_CVTQS,A_CVTQT,
+                 A_CVTST,A_CVTTQ,A_CVTTS,A_DIVF,A_DIVG,A_DIVS,
+                 A_DIVT,A_ECB,A_EQV,A_EXCB,A_EXTBL,A_EXTLH,
+                 A_EXTLL,A_EXTQH,A_EXTQL,A_EXTWH,A_EXTWL,A_FBEQ,
+                 A_FBGE,A_FBGT,A_FBLE,A_FBLT,A_FBNE,A_FCMOVEQ,
+                 A_FCMOVGE,A_FCMOVGT,A_FCMOVLE,A_FCMOVLT,A_FCMOVNE,A_FETCH,
+                 A_FETCH_M,A_FTOIS,A_FTOIT,A_IMPLVER,A_INSBL,A_INSLH,
+                 A_INSLL,A_INSQH,A_INSQL,A_INSWH,A_INSWL,A_ITOFF,
+                 A_ITOFS,A_ITOFT,A_JMP,A_JSR,A_JSR_COROUTINE,A_LDA,
+                 A_LDAH,A_LDBU,A_LDWU,A_LDF,A_LDG,A_LDL,
+                 A_LDL_L,A_LDQ,A_LDQ_L,A_LDQ_U,A_LDS,A_LDT,
+                 A_MAXSB8,A_MAXSW4,A_MAXUB8,A_MAXUW4,A_MB,A_MF_FPCR,
+                 A_MINSB8,A_MINSW4,A_MINUB8,A_MINUW4,A_MSKBL,A_MSKLH,
+                 A_MSKLL,A_MSKQH,A_MSKQL,A_MSKWH,A_MSKWL,A_MT_FPCR,
+                 A_MULF,A_MULG,A_MULL,A_MULQ,
+                 A_MULS,A_MULT,A_ORNOT,A_PERR,A_PKLB,A_PKWB,
+                 A_RC,A_RET,A_RPCC,A_RS,A_S4ADDL,A_S4ADDQ,
+                 A_S4SUBL,A_S4SUBQ,A_S8ADDL,A_S8ADDQ,A_S8SUBL,A_S8SUBQ,
+                 A_SEXTB,A_SEXTW,A_SLL,A_SQRTF,A_SQRTG,A_SQRTS,
+                 A_SQRTT,A_SRA,A_SRL,A_STB,A_STF,A_STG,
+                 A_STS,A_STL,A_STL_C,A_STQ,A_STQ_C,A_STQ_U,
+                 A_STT,A_STW,A_SUBF,A_SUBG,A_SUBL,
+                 A_SUBQ,A_SUBS,A_SUBT,A_TRAPB,A_UMULH,
+                 A_UNPKBL,A_UNPKBW,A_WH64,A_WMB,A_XOR,A_ZAP,
+                 A_ZAPNOT
+                 { Psuedo code understood by the gnu assembler }
+                 ,A_LDGP);
+
+    const
+       firstop = low(tasmop);
+       lastop  = high(tasmop);
+
+       std_reg2str : array[tregister] of string[4] = (
+         '',
+         '','','','','','','','','','',
+         '','','','','','','','','','',
+         '','','','','','','','','','',
+         '','',
+         '','','','','','','','','','',
+         '','','','','','','','','','',
+         '','','','','','','','','','',
+         '',''
+       );
+
+
+    type
+       TAsmCond =
+        (
+         C_None,C_A,C_AE,C_B,C_BE,C_C,C_E,C_G,C_GE,C_L,C_LE,C_NA,C_NAE,
+         C_NB,C_NBE,C_NC,C_NE,C_NG,C_NGE,C_NL,C_NLE,C_NO,C_NP,C_NS,C_NZ,C_O,C_P,
+         C_PE,C_PO,C_S,C_Z
+        );
+
+        TRegisterset = Set of TRegister;
+
+        tregister64 = tregister;
+
+    Const
+       Firstreg = R_0;
+       LastReg = R_F31;
+
+
+{*****************************************************************************
+                          Default generic sizes
+*****************************************************************************}
+
+       { Defines the default address size for a processor, }
+       OS_ADDR = OS_64;
+       { the natural int size for a processor,             }
+       OS_INT = OS_64;
+       { the maximum float size for a processor,           }
+       OS_FLOAT = OS_F80;
+       { the size of a vector register for a processor     }
+       OS_VECTOR = OS_M64;
+
+       stack_pointer_reg = R_30;
+       frame_pointer_reg = R_15;
+       self_pointer_reg = R_16;
+       accumulator   = R_0;
+  {the return_result_reg, is used inside the called function to store its return
+  value when that is a scalar value otherwise a pointer to the address of the
+  result is placed inside it}
+        return_result_reg               =       accumulator;
+
+  {the function_result_reg contains the function result after a call to a scalar
+  function othewise it contains a pointer to the returned result}
+        function_result_reg     =       accumulator;
+       fpu_result_reg = R_F0;
+       global_pointer = R_29;
+       return_pointer = R_26;
+       { it is used to pass the offset to the destructor helper routine }
+       vmt_offset_reg = R_1;
+
+     { low and high of the available maximum width integer general purpose }
+     { registers                                                           }
+       LoGPReg = R_0;
+       HiGPReg = R_31;
+
+       { low and high of every possible width general purpose register (same as
+         above on most architctures apart from the 80x86)                       }
+       LoReg = R_0;
+       HiReg = R_31;
+
+       { Constant defining possibly all registers which might require saving }
+       ALL_REGISTERS = [firstreg..lastreg];
+
+       general_registers = [R_0..R_31];
+
+       availabletempregsint = [R_0..R_14,R_16..R_25,R_28];
+       availabletempregsfpu = [R_F0..R_F30];
+       availabletempregsmm  = [];
+
+       intregs = [R_0..R_31];
+       usableregsint = [];
+       c_countusableregsint = 26;
+
+       maxfpuregs = 32;
+       fpuregs = [R_F0..R_F31];
+       usableregsfpu = [];
+       c_countusableregsfpu = 31;
+
+       mmregs = [];
+       usableregsmm = [];
+       c_countusableregsmm  = 0;
+
+       max_operands = 4;
+
+       registers_saved_on_cdecl = [R_9..R_14,R_F2..R_F9];
+
+       firstsaveintreg = R_NO;
+       lastsaveintreg  = R_NO;
+       firstsavefpureg = R_NO;
+       lastsavefpureg  = R_NO;
+       firstsavemmreg  = R_NO;
+       lastsavemmreg   = R_NO;
+       maxvarregs = 6;
+
+       varregs : Array [1..maxvarregs] of Tregister =
+                 (R_9,R_10,R_11,R_12,R_13,R_14);
+
+       maxfpuvarregs = 8;
+
+       { Registers which are defined as scratch and no need to save across
+         routine calls or in assembler blocks.
+       }
+       max_scratch_regs = 2;
+       scratch_regs : array[1..max_scratch_regs] of tregister = (R_1,R_2);
+
+{*****************************************************************************
+                               GDB Information
+*****************************************************************************}
+
+       {  Register indexes for stabs information, when some
+         parameters or variables are stored in registers.
+       }
+       stab_regindex : array[tregister] of shortint =
+          (0,
+           0,0,0,0,0,0,0,0,0,0,
+           0,0,0,0,0,0,0,0,0,0,
+           0,0,0,0,0,0,0,0,0,0,
+           0,0,
+           0,0,0,0,0,0,0,0,0,0,
+           0,0,0,0,0,0,0,0,0,0,
+           0,0,0,0,0,0,0,0,0,0,
+           0,0
+          );
+
+{*****************************************************************************
+                                   Flags
+*****************************************************************************}
+       type
+       { The Alpha doesn't have flags but some generic code depends on this type. }
+       TResFlags = (F_NO);
+
+
+       { reference record }
+       pparareference = ^tparareference;
+       tparareference = packed record
+          index       : tregister;
+          offset      : longint;
+       end;
+
+       trefoptions=(ref_none,ref_parafixup,ref_localfixup,ref_selffixup);
+
+       TReference = record
+         offset : aword;
+         symbol : tasmsymbol;
+         base : tregister;
+         { The index isn't used by the alpha port, but some generic code depends on it }
+         index : tregister;
+         is_immediate : boolean;
+         offsetfixup : word; {needed for inline}
+         options     : trefoptions;
+         { the boundary to which the reference is surely aligned }
+         alignment : byte;
+       end;
+       PReference = ^TReference;
+
+       TLoc=(
+              LOC_INVALID,      { added for tracking problems}
+              LOC_CONSTANT,     { constant value }
+              LOC_JUMP,         { boolean results only, jump to false or true label }
+              LOC_FLAGS,        { boolean results only, flags are set }
+              LOC_CREFERENCE,   { in memory constant value reference (cannot change) }
+              LOC_REFERENCE,    { in memory value }
+              LOC_REGISTER,     { in a processor register }
+              LOC_CREGISTER,    { Constant register which shouldn't be modified }
+              LOC_FPUREGISTER,  { FPU stack }
+              LOC_CFPUREGISTER, { if it is a FPU register variable on the fpu stack }
+              LOC_SSEREGISTER,
+              LOC_CSSEREGISTER,
+              LOC_CMMREGISTER,
+              LOC_MMREGISTER
+            );
+
+      { tparamlocation describes where a parameter for a procedure is stored.
+        References are given from the caller's point of view. The usual
+        TLocation isn't used, because contains a lot of unnessary fields.
+      }
+      tparalocation = packed record
+         size : TCGSize;
+         loc  : TLoc;
+         sp_fixup : longint;
+         case TLoc of
+            LOC_REFERENCE : (reference : tparareference);
+            { segment in reference at the same place as in loc_register }
+            LOC_REGISTER,LOC_CREGISTER : (
+              case longint of
+                1 : (register,register64.reghi : tregister);
+                { overlay a register64.reglo }
+                2 : (register64.reglo : tregister);
+                { overlay a 64 Bit register type }
+                3 : (reg64 : tregister64);
+                4 : (register64 : tregister64);
+              );
+      end;
+
+      tlocation = packed record
+         loc  : TLoc;
+         size : TCGSize;
+         case TLoc of
+            LOC_CONSTANT : (
+              case longint of
+                1 : (value : AWord);
+                { can't do this, this layout depends on the host cpu. Use }
+                { lo(valueqword)/hi(valueqword) instead (JM)              }
+                { 2 : (valuelow, valuehigh:AWord);                        }
+                { overlay a complete 64 Bit value }
+                3 : (valueqword : qword);
+              );
+            LOC_CREFERENCE,
+            LOC_REFERENCE : (reference : treference);
+            { segment in reference at the same place as in loc_register }
+            LOC_REGISTER,LOC_CREGISTER : (
+              case longint of
+                1 : (register,register64.reghi,segment : tregister);
+                { overlay a register64.reglo }
+                2 : (register64.reglo : tregister);
+                { overlay a 64 Bit register type }
+                3 : (reg64 : tregister64);
+                4 : (register64 : tregister64);
+              );
+      end;
+
+{*****************************************************************************
+                                Operands
+*****************************************************************************}
+
+
+        { Types of operand }
+        toptype=(top_none,top_reg,top_ref,top_const,top_symbol);
+
+        toper=record
+          ot  : longint;
+          case typ : toptype of
+           top_none   : ();
+           top_reg    : (reg:tregister);
+           top_ref    : (ref:preference);
+           top_const  : (val:longint);
+           top_symbol : (sym:tasmsymbol;symofs:longint);
+        end;
+
+   const
+      { Registers which must be saved when calling a routine declared as
+        cppdecl, cdecl, stdcall, safecall, palmossyscall. The registers
+        saved should be the ones as defined in the target ABI and / or GCC.
+
+        This value can be deduced from the CALLED_USED_REGISTERS array in the
+        GCC source.
+      }
+      std_saved_registers = [];
+      { Required parameter alignment when calling a routine declared as
+        stdcall and cdecl. The alignment value should be the one defined
+        by GCC or the target ABI.
+
+        The value of this constant is equal to the constant
+        PARM_BOUNDARY / BITS_PER_UNIT in the GCC source.
+      }
+      std_param_align = 8;
+
+      { offsets for the integer and floating point registers }
+      INT_REG = 0;
+      FLOAT_REG = 32;
+
+      { operator qualifiers }
+      OQ_CHOPPED_ROUNDING            = $01;  { /C }
+      OQ_ROUNDING_MODE_DYNAMIC       = $02;  { /D }
+      OQ_ROUND_TOWARD_MINUS_INFINITY = $04;  { /M }
+      OQ_INEXACT_RESULT_ENABLE        = $08; { /I }
+      OQ_SOFTWARE_COMPLETION_ENABLE  = $10;  { /S }
+      OQ_FLOATING_UNDERFLOW_ENABLE   = $20;  { /U }
+      OQ_INTEGER_OVERFLOW_ENABLE     = $40;  { /V }
+
+
+{*****************************************************************************
+                   Opcode propeties (needed for optimizer)
+*****************************************************************************}
+
+{$ifndef NOOPT}
+Type
+{What an instruction can change}
+  TInsChange = (Ch_None);
+{$endif}
+
+
+{ resets all values of ref to defaults }
+procedure reset_reference(var ref : treference);
+{ set mostly used values of a new reference }
+function new_reference(base : tregister;offset : longint) : preference;
+function newreference(const r : treference) : preference;
+procedure disposereference(var r : preference);
+
+function reg2str(r : tregister) : string;
+
+{*****************************************************************************
+                                  Init/Done
+*****************************************************************************}
+
+  procedure InitCpu;
+  procedure DoneCpu;
+
+implementation
+
+uses
+   verbose;
+
+function reg2str(r : tregister) : string;
+
+  begin
+     if r in [R_0..R_31] then
+       reg2str:='R'+tostr(longint(r)-longint(R_0))
+     else if r in [R_F0..R_F31] then
+       reg2str:='F'+tostr(longint(r)-longint(R_F0))
+     else internalerror(38991);
+  end;
+
+procedure reset_reference(var ref : treference);
+begin
+  FillChar(ref,sizeof(treference),0);
+end;
+
+
+function new_reference(base : tregister;offset : longint) : preference;
+var
+  r : preference;
+begin
+  new(r);
+  FillChar(r^,sizeof(treference),0);
+  r^.offset:=offset;
+  r^.alignment:=8;
+  new_reference:=r;
+end;
+
+function newreference(const r : treference) : preference;
+
+var
+   p : preference;
+begin
+   new(p);
+   p^:=r;
+   newreference:=p;
+end;
+
+procedure disposereference(var r : preference);
+
+begin
+  dispose(r);
+  r:=Nil;
+end;
+
+{*****************************************************************************
+                                  Init/Done
+*****************************************************************************}
+
+  procedure InitCpu;
+    begin
+    end;
+
+  procedure DoneCpu;
+    begin
+    end;
+
+end.

+ 68 - 0
compiler/alpha/cpuinfo.pas

@@ -0,0 +1,68 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1998-2000 by the Free Pascal development team
+
+    Basic Processor information about the Alpha
+
+    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.
+
+ **********************************************************************}
+{
+  Basic Processor information about the Alpha
+}
+Unit CPUInfo;
+
+{$i fpcdefs.inc}
+
+Interface
+
+Type
+   { Natural integer register type and size for the target machine }
+{$ifdef FPC}
+   AWord = Qword;
+{$else FPC}
+   AWord = Longint;
+{$endif FPC}
+   PAWord = ^AWord;
+
+   { This must be an ordinal type with the same size as a pointer
+     Note: Must be unsigned! Otherwise, ugly code like
+     pointer(-1) will result in a pointer with the value
+     $fffffffffffffff on a 32bit machine if the compiler uses
+     int64 constants internally (JM)                              }
+   TConstPtrUInt = qword;
+
+   bestreal = extended;
+   ts32real = single;
+   ts64real = double;
+   ts80real = extended;
+   ts64comp = extended;
+
+   pbestreal=^bestreal;
+
+   { possible supported processors for this target }
+   tprocessors =
+      (no_processor,
+       ClassEV7,
+       ClassEV8
+      );
+
+Const
+   { Size of native extended type }
+   extended_size = 16;
+   {# Size of a pointer                           }
+   sizeof(aint)  = 8;
+   {# Size of a multimedia register               }
+   mmreg_size = 8;
+
+   { target cpu string (used by compiler options) }
+   target_cpu_string = 'alpha';
+
+Implementation
+
+end.

+ 54 - 0
compiler/alpha/cpunode.pas

@@ -0,0 +1,54 @@
+{
+    Copyright (c) 2000-2002 by Florian Klaempfl
+
+    Imports the Alpha 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.
+
+ ****************************************************************************
+}
+{
+  This unit imports the Alpha code generator.
+}
+unit cpunode;
+
+{$i fpcdefs.inc}
+
+  interface
+
+  implementation
+
+    uses
+       { generic nodes }
+       ncgbas,ncgld,ncgflw,ncgcnv,ncgmem,ncgcon,ncgcal,ncgset,ncginl
+       { to be able to only parts of the generic code,
+         the processor specific nodes must be included
+         after the generic one (FK)
+       }
+//       naxpadd,
+//       naxpcal,
+//       naxpcon,
+//       naxpflw,
+//       naxpmem,
+//       naxpset,
+//       naxpinl,
+//       nppcopt,
+       { this not really a node }
+//       naxpobj,
+//       naxpmat,
+//       naxpcnv
+       ;
+
+end.

+ 290 - 0
compiler/alpha/cpupara.pas

@@ -0,0 +1,290 @@
+{
+    Copyright (c) 2002 by Florian Klaempfl
+
+    Alpha specific calling conventions
+
+    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.
+ ****************************************************************************
+}
+{ Alpha specific calling conventions are handled by this unit
+}
+unit cpupara;
+
+{$i fpcdefs.inc}
+
+  interface
+
+    uses
+       cpubase,
+       symconst,symbase,symtype,symdef,paramgr;
+
+    type
+       talphaparamanager = class(tparamanager)
+          function getintparaloc(nr : longint) : tparalocation;override;
+          procedure create_param_loc_info(p : tabstractprocdef);override;
+          function getfuncretparaloc(p : tabstractprocdef) : tparalocation;override;
+       end;
+
+  implementation
+
+    uses
+       verbose,
+       globtype,
+       cpuinfo,cginfo,cgbase,
+       defbase;
+
+    function talphaparamanager.getintparaloc(nr : longint) : tparalocation;
+
+      begin
+         fillchar(result,sizeof(tparalocation),0);
+         if nr<1 then
+           internalerror(2002070801)
+         else if nr<=8 then
+           begin
+              result.loc:=LOC_REGISTER;
+              result.register:=tregister(longint(R_2)+nr);
+           end
+         else
+           begin
+              result.loc:=LOC_REFERENCE;
+              result.reference.index:=stack_pointer_reg;
+              result.reference.offset:=(nr-8)*4;
+           end;
+      end;
+
+    function getparaloc(p : tdef) : tloc;
+
+      begin
+         { Later, the LOC_REFERENCE is in most cases changed into LOC_REGISTER
+           if push_addr_param for the def is true
+         }
+         case p.deftype of
+            orddef:
+              getparaloc:=LOC_REGISTER;
+            floatdef:
+              getparaloc:=LOC_FPUREGISTER;
+            enumdef:
+              getparaloc:=LOC_REGISTER;
+            pointerdef:
+              getparaloc:=LOC_REGISTER;
+            formaldef:
+              getparaloc:=LOC_REGISTER;
+            classrefdef:
+              getparaloc:=LOC_REGISTER;
+            recorddef:
+              getparaloc:=LOC_REFERENCE;
+            objectdef:
+              if is_object(p) then
+                getparaloc:=LOC_REFERENCE
+              else
+                getparaloc:=LOC_REGISTER;
+            stringdef:
+              if is_shortstring(p) or is_longstring(p) then
+                getparaloc:=LOC_REFERENCE
+              else
+                getparaloc:=LOC_REGISTER;
+            procvardef:
+              if (po_methodpointer in tprocvardef(p).procoptions) then
+                getparaloc:=LOC_REFERENCE
+              else
+                getparaloc:=LOC_REGISTER;
+            filedef:
+              getparaloc:=LOC_REGISTER;
+            arraydef:
+              getparaloc:=LOC_REFERENCE;
+            setdef:
+              if is_smallset(p) then
+                getparaloc:=LOC_REGISTER
+              else
+                getparaloc:=LOC_REFERENCE;
+            variantdef:
+              getparaloc:=LOC_REFERENCE;
+            { avoid problems with errornous definitions }
+            errordef:
+              getparaloc:=LOC_REGISTER;
+            else
+              internalerror(2002071001);
+         end;
+      end;
+
+    procedure talphaparamanager.create_param_loc_info(p : tabstractprocdef);
+
+      var
+         nextintreg,nextfloatreg,nextmmreg : tregister;
+         stack_offset : aword;
+         hp : tparaitem;
+         loc : tloc;
+         is_64bit: boolean;
+
+      begin
+         nextintreg:=R_3;
+         nextfloatreg:=R_F1;
+         // nextmmreg:=R_M1;
+         stack_offset:=0;
+         { pointer for structured results ? }
+         if not is_void(p.rettype.def) then
+           begin
+              if not(ret_in_reg(p.rettype.def)) then
+                inc(nextintreg);
+           end;
+
+         { frame pointer for nested procedures? }
+         { inc(nextintreg);                     }
+         { constructor? }
+         { destructor? }
+         hp:=tparaitem(p.para.last);
+         while assigned(hp) do
+           begin
+              loc:=getparaloc(hp.paratype.def);
+              hp.paraloc.sp_fixup:=0;
+              case loc of
+                 LOC_REGISTER:
+                   begin
+                      hp.paraloc.size := def_cgsize(hp.paratype.def);
+                      { for things like formaldef }
+                      if hp.paraloc.size = OS_NO then
+                        hp.paraloc.size := OS_ADDR;
+                      is_64bit := hp.paraloc.size in [OS_64,OS_S64];
+                      if nextintreg<=tregister(ord(R_10)-ord(is_64bit))  then
+                        begin
+                           hp.paraloc.loc:=LOC_REGISTER;
+                           hp.paraloc.register64.reglo:=nextintreg;
+                           inc(nextintreg);
+                           if is_64bit then
+                             begin
+                               hp.paraloc.register64.reghi:=nextintreg;
+                               inc(nextintreg);
+                             end;
+                        end
+                      else
+                         begin
+                            nextintreg := R_11;
+                            hp.paraloc.loc:=LOC_REFERENCE;
+                            hp.paraloc.reference.index:=stack_pointer_reg;
+                            hp.paraloc.reference.offset:=stack_offset;
+                            if not is_64bit then
+                              inc(stack_offset,4)
+                            else
+                              inc(stack_offset,8);
+                        end;
+                   end;
+                 LOC_FPUREGISTER:
+                   begin
+                      if hp.paratyp in [vs_var,vs_out] then
+                        begin
+                            if nextintreg<=R_10 then
+                             begin
+                                hp.paraloc.size:=OS_ADDR;
+                                hp.paraloc.loc:=LOC_REGISTER;
+                                hp.paraloc.register:=nextintreg;
+                                inc(nextintreg);
+                             end
+                           else
+                              begin
+                                 {!!!!!!!}
+                                 hp.paraloc.size:=def_cgsize(hp.paratype.def);
+                                 internalerror(2002071006);
+                             end;
+                        end
+                      else if nextfloatreg<=R_F10 then
+                        begin
+                           hp.paraloc.size:=def_cgsize(hp.paratype.def);
+                           hp.paraloc.loc:=LOC_FPUREGISTER;
+                           hp.paraloc.register:=nextfloatreg;
+                           inc(nextfloatreg);
+                        end
+                      else
+                         begin
+                            {!!!!!!!}
+                             hp.paraloc.size:=def_cgsize(hp.paratype.def);
+                            internalerror(2002071004);
+                        end;
+                   end;
+                 LOC_REFERENCE:
+                   begin
+                      hp.paraloc.size:=OS_ADDR;
+                      if push_addr_param(hp.paratype.def,p.proccalloption in [pocall_cdecl,pocall_cppdecl]) or (hp.paratyp in [vs_var,vs_out]) then
+                        begin
+                           if nextintreg<=R_10 then
+                             begin
+                                hp.paraloc.loc:=LOC_REGISTER;
+                                hp.paraloc.register:=nextintreg;
+                                inc(nextintreg);
+                             end
+                           else
+                              begin
+                                 hp.paraloc.loc:=LOC_REFERENCE;
+                                 hp.paraloc.reference.index:=stack_pointer_reg;
+                                 hp.paraloc.reference.offset:=stack_offset;
+                                 inc(stack_offset,4);
+                             end;
+                        end
+                      else
+                        begin
+                           hp.paraloc.loc:=LOC_REFERENCE;
+                           hp.paraloc.reference.index:=stack_pointer_reg;
+                           hp.paraloc.reference.offset:=stack_offset;
+                           inc(stack_offset,hp.paratype.def.size);
+                        end;
+                   end;
+                 else
+                   internalerror(2002071002);
+              end;
+              hp:=tparaitem(hp.previous);
+           end;
+      end;
+
+    function talphaparamanager.getfuncretparaloc(p : tabstractprocdef) : tparalocation;
+      begin
+         case p.rettype.def.deftype of
+            orddef,
+            enumdef:
+              begin
+                getfuncretparaloc.loc:=LOC_REGISTER;
+                getfuncretparaloc.register:=R_3;
+                getfuncretparaloc.size:=def_cgsize(p.rettype.def);
+                if getfuncretparaloc.size in [OS_S64,OS_64] then
+                  getfuncretparaloc.register64.reghi:=R_4;
+              end;
+            floatdef:
+              begin
+                getfuncretparaloc.loc:=LOC_FPUREGISTER;
+                getfuncretparaloc.register:=R_F1;
+                getfuncretparaloc.size:=def_cgsize(p.rettype.def);
+              end;
+            pointerdef,
+            formaldef,
+            classrefdef,
+            recorddef,
+            objectdef,
+            stringdef,
+            procvardef,
+            filedef,
+            arraydef,
+            errordef:
+              begin
+                getfuncretparaloc.loc:=LOC_REGISTER;
+                getfuncretparaloc.register:=R_3;
+                getfuncretparaloc.size:=OS_ADDR;
+              end;
+            else
+              internalerror(2002090903);
+        end;
+      end;
+
+
+begin
+   paramanager:=talphaparamanager.create;
+end.

+ 43 - 0
compiler/alpha/cpupi.pas

@@ -0,0 +1,43 @@
+{
+    Copyright (c) 2002 by Florian Klaempfl
+
+    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.
+
+ ****************************************************************************
+}
+{
+  This unit contains the CPU specific part of tprocinfo.
+}
+unit cpupi;
+
+{$i fpcdefs.inc}
+
+  interface
+
+    uses
+       cgbase;
+
+    type
+       talphaprocinfo = class(tprocinfo)
+       end;
+
+
+  implementation
+
+begin
+   cprocinfo:=talphaprocinfo;
+end.

+ 121 - 0
compiler/alpha/cpuswtch.pas

@@ -0,0 +1,121 @@
+{
+    Copyright (c) 1998-2002 by Florian Klaempfl, Pierre Muller
+
+    This units interprets the commandline options which are Alpha specific.
+
+    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 units interprets the commandline options which are Alpha specific.
+}
+unit cpuswtch;
+
+{$i fpcdefs.inc}
+
+interface
+
+uses
+  options;
+
+type
+  toptionalpha = class(toption)
+    procedure interpret_proc_specific_options(const opt:string);override;
+  end;
+
+implementation
+
+uses
+  cutils,globtype,systems,globals;
+
+procedure toptionalpha.interpret_proc_specific_options(const opt:string);
+var
+  more: string;
+  j: longint;
+begin
+  More:=Upper(copy(opt,3,length(opt)-2));
+  case opt[2] of
+   'O' : Begin
+           j := 3;
+           While (j <= Length(Opt)) Do
+             Begin
+               case opt[j] of
+                 '-' :
+                   begin
+                     initglobalswitches:=initglobalswitches-[cs_optimize,cs_fastoptimize,cs_slowoptimize,cs_littlesize,
+                       cs_regalloc,cs_uncertainopts];
+                     FillChar(ParaAlignment,sizeof(ParaAlignment),0);
+                   end;
+                 'a' :
+                   begin
+                     UpdateAlignmentStr(Copy(Opt,j+1,255),ParaAlignment);
+                     j:=length(Opt);
+                   end;
+                 'g' : initglobalswitches:=initglobalswitches+[cs_littlesize];
+                 'G' : initglobalswitches:=initglobalswitches-[cs_littlesize];
+                 'r' :
+                   begin
+                     initglobalswitches:=initglobalswitches+[cs_regalloc];
+                     Simplify_ppu:=false;
+                   end;
+                 'u' : initglobalswitches:=initglobalswitches+[cs_uncertainopts];
+                 '1' : initglobalswitches:=initglobalswitches-[cs_fastoptimize,cs_slowoptimize]+[cs_optimize];
+                 '2' : initglobalswitches:=initglobalswitches-[cs_slowoptimize]+[cs_optimize,cs_fastoptimize];
+                 '3' : initglobalswitches:=initglobalswitches+[cs_optimize,cs_fastoptimize,cs_slowoptimize];
+{$ifdef dummy}
+                 'p' :
+                   Begin
+                     If j < Length(Opt) Then
+                       Begin
+                         Case opt[j+1] Of
+                           '1': initoptprocessor := Class386;
+                           '2': initoptprocessor := ClassP5;
+                           '3': initoptprocessor := ClassP6
+                           Else IllegalPara(Opt)
+                         End;
+                         Inc(j);
+                       End
+                     Else IllegalPara(opt)
+                   End;
+{$endif dummy}
+                 else IllegalPara(opt);
+               End;
+               Inc(j)
+             end;
+         end;
+{$ifdef dummy}
+   'R' : begin
+           if More='GAS' then
+            initasmmode:=asmmode_ppc_gas
+           else
+            if More='MOTOROLA' then
+             initasmmode:=asmmode_ppc_motorola
+           else
+            if More='DIRECT' then
+             initasmmode:=asmmode_direct
+           else
+            IllegalPara(opt);
+         end;
+{$endif dummy}
+  else
+   IllegalPara(opt);
+  end;
+end;
+
+
+initialization
+  coption:=toptionalpha;
+end.

+ 51 - 0
compiler/alpha/cputarg.pas

@@ -0,0 +1,51 @@
+{
+    Copyright (c) 2001-2002 by Peter Vreman
+
+    Includes the powerpc 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 }
+
+{**************************************
+             Targets
+**************************************}
+
+    {$ifndef NOTARGETLINUX}
+      ,t_linux
+    {$endif}
+
+{**************************************
+             Assemblers
+**************************************}
+
+    {$ifndef NOAGAXPGAS}
+      ,agaxpgas
+    {$endif}
+      ;
+
+end.

+ 313 - 0
compiler/alpha/radirect.pas

@@ -0,0 +1,313 @@
+{
+    Copyright (c) 1998-2002 by Florian Klaempfl
+
+    Reads inline Alpha assembler and writes the lines direct to the output
+
+    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 reads Alpha inline assembler and writes the lines direct to the output file.
+}
+unit radirect;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+      node;
+
+     function assemble : tnode;
+
+  implementation
+
+    uses
+       { common }
+       cutils,
+       { global }
+       globals,verbose,
+       systems,
+       { aasm }
+       aasmbase,aasmtai,aasmcpu,
+       { symtable }
+       symconst,symbase,symtype,symsym,symtable,defbase,
+       { pass 1 }
+       nbas,
+       { parser }
+       scanner,
+       { codegen }
+       cgbase,
+       { constants }
+       agaxpgas,
+       cpubase
+       ;
+
+    function assemble : tnode;
+
+      var
+         retstr,s,hs : string;
+         c : char;
+         ende : boolean;
+         srsym,sym : tsym;
+         srsymtable : tsymtable;
+         code : TAAsmoutput;
+         i,l : longint;
+
+       procedure writeasmline;
+         var
+           i : longint;
+         begin
+           i:=length(s);
+           while (i>0) and (s[i] in [' ',#9]) do
+            dec(i);
+           s[0]:=chr(i);
+           if s<>'' then
+            code.concat(Tai_direct.Create(strpnew(s)));
+            { consider it set function set if the offset was loaded }
+           if assigned(aktprocdef.funcretsym) and
+              (pos(retstr,upper(s))>0) then
+             tfuncretsym(aktprocdef.funcretsym).funcretstate:=vs_assigned;
+           s:='';
+         end;
+
+     begin
+       ende:=false;
+       s:='';
+       if assigned(aktprocdef.funcretsym) and
+          is_fpu(aktprocdef.rettype.def) then
+         tfuncretsym(aktprocdef.funcretsym).funcretstate:=vs_assigned;
+       { !!!!!
+       if (not is_void(aktprocdef.rettype.def)) then
+         retstr:=upper(tostr(procinfo^.return_offset)+'('+gas_reg2str[procinfo^.framepointer]+')')
+       else
+       }
+         retstr:='';
+
+       c:=current_scanner.asmgetchar;
+       code:=TAAsmoutput.Create;
+       while not(ende) do
+         begin
+            { wrong placement
+            current_scanner.gettokenpos; }
+            case c of
+              'A'..'Z','a'..'z','_':
+                begin
+                   current_scanner.gettokenpos;
+                   i:=0;
+                   hs:='';
+                   while ((ord(c)>=ord('A')) and (ord(c)<=ord('Z')))
+                      or ((ord(c)>=ord('a')) and (ord(c)<=ord('z')))
+                      or ((ord(c)>=ord('0')) and (ord(c)<=ord('9')))
+                      or (c='_') do
+                     begin
+                        inc(i);
+                        hs[i]:=c;
+                        c:=current_scanner.asmgetchar;
+                     end;
+                   hs[0]:=chr(i);
+                   if upper(hs)='END' then
+                      ende:=true
+                   else
+                      begin
+                         if c=':' then
+                           begin
+                             searchsym(upper(hs),srsym,srsymtable);
+                             if srsym<>nil then
+                               if (srsym.typ = labelsym) then
+                                 Begin
+                                    hs:=tlabelsym(srsym).lab.name;
+                                    tlabelsym(srsym).lab.is_set:=true;
+                                 end
+                               else
+                                 Message(asmr_w_using_defined_as_local);
+                           end
+                         else
+                           { access to local variables }
+                           if assigned(aktprocdef) then
+                             begin
+                                { I don't know yet, what the ppc port requires }
+                                { we'll see how things settle down             }
+
+                                { is the last written character an special }
+                                { char ?                                   }
+                                { !!!
+                                if (s[length(s)]='%') and
+                                   ret_in_acc(aktprocdef.rettype.def) and
+                                   ((pos('AX',upper(hs))>0) or
+                                   (pos('AL',upper(hs))>0)) then
+                                  tfuncretsym(aktprocdef.funcretsym).funcretstate:=vs_assigned;
+                                }
+                                if ((s[length(s)]<>'0') or (hs[1]<>'x')) then
+                                  begin
+                                     if assigned(aktprocdef.localst) and
+                                        (lexlevel >= normal_function_level) then
+                                       sym:=tsym(aktprocdef.localst.search(upper(hs)))
+                                     else
+                                       sym:=nil;
+                                     if assigned(sym) then
+                                       begin
+                                          if (sym.typ=labelsym) then
+                                            Begin
+                                               hs:=tlabelsym(sym).lab.name;
+                                            end
+                                          else if sym.typ=varsym then
+                                            begin
+                                               if (vo_is_external in tvarsym(sym).varoptions) then
+                                                 hs:=tvarsym(sym).mangledname
+                                               else
+                                                 begin
+                                                    if (tvarsym(sym).reg<>R_NO) then
+                                                      hs:=gas_reg2str[procinfo.framepointer]
+                                                    else
+                                                      hs:=tostr(tvarsym(sym).address)+
+                                                        '('+gas_reg2str[procinfo.framepointer]+')';
+                                                 end;
+                                            end
+                                          else
+                                          { call to local function }
+                                          if (sym.typ=procsym) and (pos('BL',upper(s))>0) then
+                                            hs:=tprocsym(sym).first_procdef.mangledname;
+                                       end
+                                     else
+                                       begin
+                                          if assigned(aktprocdef.parast) then
+                                            sym:=tsym(aktprocdef.parast.search(upper(hs)))
+                                          else
+                                            sym:=nil;
+                                          if assigned(sym) then
+                                            begin
+                                               if sym.typ=varsym then
+                                                 begin
+                                                    l:=tvarsym(sym).address;
+                                                    { set offset }
+                                                    inc(l,aktprocdef.parast.address_fixup);
+                                                    hs:=tostr(l)+'('+gas_reg2str[procinfo.framepointer]+')';
+                                                    if pos(',',s) > 0 then
+                                                      tvarsym(sym).varstate:=vs_used;
+                                                 end;
+                                            end
+                                          { I added that but it creates a problem in line.ppi
+                                          because there is a local label wbuffer and
+                                          a static variable WBUFFER ...
+                                          what would you decide, florian ?}
+                                          else
+                                            begin
+                                               searchsym(upper(hs),sym,srsymtable);
+                                               if assigned(sym) and (sym.owner.symtabletype in [globalsymtable,staticsymtable]) then
+                                                 begin
+                                                   case sym.typ of
+                                                     varsym :
+                                                       begin
+                                                         Message2(asmr_h_direct_global_to_mangled,hs,tvarsym(sym).mangledname);
+                                                         hs:=tvarsym(sym).mangledname;
+                                                         inc(tvarsym(sym).refs);
+                                                       end;
+                                                     typedconstsym :
+                                                       begin
+                                                         Message2(asmr_h_direct_global_to_mangled,hs,ttypedconstsym(sym).mangledname);
+                                                         hs:=ttypedconstsym(sym).mangledname;
+                                                       end;
+                                                     procsym :
+                                                       begin
+                                                         { procs can be called or the address can be loaded }
+                                                         if (pos('BL',upper(s))>0) {or (pos('LEA',upper(s))>0))}  then
+                                                          begin
+                                                            if Tprocsym(sym).procdef_count>1 then
+                                                              Message1(asmr_w_direct_global_is_overloaded_func,hs);
+                                                            Message2(asmr_h_direct_global_to_mangled,hs,tprocsym(sym).first_procdef.mangledname);
+                                                            hs:=tprocsym(sym).first_procdef.mangledname;
+                                                          end;
+                                                       end;
+                                                     else
+                                                       Message(asmr_e_wrong_sym_type);
+                                                   end;
+                                                 end
+{$ifdef dummy}
+                                               else if upper(hs)='__SELF' then
+                                                 begin
+                                                    if assigned(procinfo^._class) then
+                                                      hs:=tostr(procinfo^.selfpointer_offset)+
+                                                          '('+gas_reg2str[procinfo^.framepointer]+')'
+                                                    else
+                                                     Message(asmr_e_cannot_use_SELF_outside_a_method);
+                                                 end
+                                               else if upper(hs)='__RESULT' then
+                                                 begin
+                                                    if (not is_void(aktprocdef.rettype.def)) then
+                                                      hs:=retstr
+                                                    else
+                                                      Message(asmr_e_void_function);
+                                                 end
+                                               { implement old stack/frame pointer access for nested procedures }
+                                               {!!!!
+                                               else if upper(hs)='__OLDSP' then
+                                                 begin
+                                                    { complicate to check there }
+                                                    { we do it: }
+                                                    if lexlevel>normal_function_level then
+                                                      hs:=tostr(procinfo^.framepointer_offset)+
+                                                        '('+gas_reg2str[procinfo^.framepointer]+')'
+                                                    else
+                                                      Message(asmr_e_cannot_use_OLDEBP_outside_nested_procedure);
+                                                 end;
+                                               }
+                                               end;
+{$endif dummy}
+                                            end;
+                                       end;
+                                  end;
+                             end;
+                         s:=s+hs;
+                      end;
+                end;
+              '{',';',#10,#13:
+                begin
+                   if pos(retstr,s) > 0 then
+                     tfuncretsym(aktprocdef.funcretsym).funcretstate:=vs_assigned;
+                   writeasmline;
+                   c:=current_scanner.asmgetchar;
+                end;
+              #26:
+                Message(scan_f_end_of_file);
+              else
+                begin
+                  current_scanner.gettokenpos;
+                  inc(byte(s[0]));
+                  s[length(s)]:=c;
+                  c:=current_scanner.asmgetchar;
+                end;
+            end;
+         end;
+       writeasmline;
+       assemble:=casmnode.create(code);
+     end;
+
+{*****************************************************************************
+                                     Initialize
+*****************************************************************************}
+
+const
+  asmmode_ppc_direct_info : tasmmodeinfo =
+          (
+            id    : asmmode_direct;
+            idtxt : 'DIRECT'
+          );
+
+initialization
+  RegisterAsmMode(asmmode_ppc_direct_info);
+
+end.

+ 65 - 0
compiler/alpha/rasm.pas

@@ -0,0 +1,65 @@
+{
+    Copyright (c) 1998-2002 by The Free Pascal Team
+
+    This unit does the parsing process for the inline assembler
+
+    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 does the parsing process for the inline assembler.
+}
+Unit Rasm;
+
+{$i fpcdefs.inc}
+
+Interface
+
+uses
+  node;
+
+   {
+     This routine is called to parse the instructions in assembler
+     blocks. It returns a complete list of directive and instructions
+   }
+   function assemble: tnode;
+
+
+Implementation
+
+    uses
+       { common }
+       cutils,cclasses,
+       { global }
+       globtype,globals,verbose,
+       systems,
+       { aasm }
+       cpubase,aasmbase,aasmtai,aasmcpu,
+       { symtable }
+       symconst,symbase,symtype,symsym,symtable,
+       { pass 1 }
+       nbas,
+       { parser }
+       scanner
+       // ,rautils
+       ;
+
+    function assemble : tnode;
+     begin
+     end;
+
+Begin
+end.

+ 69 - 0
compiler/alpha/rgcpu.pas

@@ -0,0 +1,69 @@
+{
+    Copyright (c) 1998-2002 by Florian Klaempfl
+
+    This unit implements the powerpc specific class for the register
+    allocator
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+}
+
+unit rgcpu;
+
+{$i fpcdefs.inc}
+
+  interface
+
+     uses
+       aasmbase,aasmtai,
+       cpubase,
+       rgobj;
+
+     type
+       trgcpu = class(trgobj)
+         function getcpuregisterint(list: taasmoutput; reg: tregister): tregister; override;
+         procedure ungetregisterint(list: taasmoutput; reg: tregister); override;
+       end;
+
+  implementation
+
+    uses
+      cgobj;
+
+    function trgcpu.getcpuregisterint(list: taasmoutput; reg: tregister): tregister;
+
+      begin
+        if reg = R_0 then
+          begin
+            cg.a_reg_alloc(list,reg);
+            result := reg;
+          end
+        else result := inherited getcpuregisterint(list,reg);
+      end;
+
+
+    procedure trgcpu.ungetregisterint(list: taasmoutput; reg: tregister);
+
+      begin
+        if reg = R_0 then
+          cg.a_reg_dealloc(list,reg)
+        else
+          inherited ungetregisterint(list,reg);
+      end;
+
+initialization
+  rg := trgcpu.create;
+end.

+ 42 - 0
compiler/alpha/tgcpu.pas

@@ -0,0 +1,42 @@
+{
+    Copyright (C) 1998-2000 by Florian Klaempfl
+
+    This unit handles the temporary variables stuff for Alpha
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+}
+{
+  This unit handles the temporary variables stuff for Alpha.
+}
+unit tgcpu;
+
+{$i fpcdefs.inc}
+
+  interface
+
+    uses
+       tgobj;
+
+    type
+       ttgalpha = class(ttgobj)
+       end;
+
+implementation
+
+begin
+  tg:=ttgalpha.create;
+end.

+ 267 - 0
compiler/aopt.pas

@@ -0,0 +1,267 @@
+{
+    Copyright (c) 1998-2004 by Jonas Maebe, member of the Free Pascal
+    Development Team
+
+    This unit contains the interface routines between the code generator
+    and the optimizer.
+
+    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 aopt;
+
+{$i fpcdefs.inc}
+
+  Interface
+
+    Uses
+      aasmbase,aasmtai,aasmcpu,
+      aoptobj;
+
+    Type
+      TAsmOptimizer = class(TAoptObj)
+
+        { _AsmL is the PAasmOutpout list that has to be optimized }
+        Constructor create(_AsmL: taasmoutput); virtual;
+
+        { call the necessary optimizer procedures }
+        Procedure Optimize;
+        Destructor destroy;override;
+
+      private
+        procedure FindLoHiLabels;
+        Procedure BuildLabelTableAndFixRegAlloc;
+        procedure clear;
+        procedure pass_1;
+      End;
+
+    var
+      casmoptimizer : class of tasmoptimizer;
+
+    procedure Optimize(AsmL:taasmoutput);
+
+  Implementation
+
+    uses
+      globtype, globals,
+      aoptda,aoptcpu,aoptcpud;
+
+    Constructor TAsmOptimizer.create(_AsmL: taasmoutput);
+      Begin
+        inherited create(_asml,nil,nil,nil);
+      {setup labeltable, always necessary}
+        New(LabelInfo);
+      End;
+
+    procedure TAsmOptimizer.FindLoHiLabels;
+      { Walks through the paasmlist to find the lowest and highest label number.  }
+      { Returns the last Pai object of the current block                          }
+      Var LabelFound: Boolean;
+          p, prev: tai;
+      Begin
+        LabelInfo^.LowLabel := High(AWord);
+        LabelInfo^.HighLabel := 0;
+        LabelInfo^.LabelDif := 0;
+        LabelInfo^.LabelTable:=nil;
+        LabelFound := False;
+        P := BlockStart;
+        prev := p;
+        With LabelInfo^ Do
+          Begin
+            While Assigned(P) And
+                  ((P.typ <> Ait_Marker) Or
+                   (tai_Marker(P).Kind <> AsmBlockStart)) Do
+              Begin
+                If (p.typ = ait_label) Then
+                  If (tai_Label(p).l.is_used) Then
+                    Begin
+                      LabelFound := True;
+                      If (tai_Label(p).l.labelnr < LowLabel) Then
+                        LowLabel := tai_Label(p).l.labelnr;
+                      If (tai_Label(p).l.labelnr > HighLabel) Then
+                        HighLabel := tai_Label(p).l.labelnr
+                    End;
+                prev := p;
+                GetNextInstruction(p, p)
+              End;
+            if (prev.typ = ait_marker) and
+               (tai_marker(prev).kind = asmblockstart) then
+              blockend := prev
+            else blockend := nil;
+            If LabelFound
+              Then LabelDif := HighLabel-LowLabel+1
+              Else LabelDif := 0
+          End
+      End;
+
+    Procedure TAsmOptimizer.BuildLabelTableAndFixRegAlloc;
+    { Builds a table with the locations of the labels in the taasmoutput.       }
+    { Also fixes some RegDeallocs like "# %eax released; push (%eax)"           }
+    Var p, hp1, hp2: tai;
+        UsedRegs: TRegSet;
+    Begin
+      UsedRegs := [];
+      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:
+                    If tai_label(p).l.is_used Then
+                      LabelTable^[tai_label(p).l.labelnr-LowLabel].PaiObj := p;
+                  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)
+              End;
+          End
+    End;
+
+    procedure tasmoptimizer.clear;
+      begin
+        if LabelInfo^.labeldif <> 0 then
+          begin
+            freemem(LabelInfo^.labeltable);
+            LabelInfo^.labeltable := nil;
+          end;
+      end;
+
+    procedure tasmoptimizer.pass_1;
+      begin
+        findlohilabels;
+        BuildLabelTableAndFixRegAlloc;
+      end;
+
+
+    Procedure TAsmOptimizer.Optimize;
+      Var
+        HP: tai;
+        pass: longint;
+      Begin
+        pass:=0;
+        BlockStart := tai(AsmL.First);
+        pass_1;
+        While Assigned(BlockStart) Do
+          Begin
+             if pass = 0 then
+               PrePeepHoleOpts;
+            { Peephole optimizations }
+             PeepHoleOptPass1;
+            { Only perform them twice in the first pass }
+             if pass = 0 then
+               PeepHoleOptPass1;
+            If (cs_slowoptimize in aktglobalswitches) Then
+              Begin
+//                DFA:=TAOptDFACpu.Create(AsmL,BlockStart,BlockEnd,LabelInfo);
+                { data flow analyzer }
+//                DFA.DoDFA;
+                { common subexpression elimination }
+      {          CSE;}
+              End;
+            { more peephole optimizations }
+      {      PeepHoleOptPass2;}
+            { if pass = last_pass then }
+            PostPeepHoleOpts;
+            { free memory }
+            clear;
+            { continue where we left off, BlockEnd is either the start of an }
+            { assembler block or nil}
+            BlockStart := BlockEnd;
+            While Assigned(BlockStart) And
+                  (BlockStart.typ = ait_Marker) And
+                  (tai_Marker(BlockStart).Kind = AsmBlockStart) Do
+              Begin
+               { we stopped at an assembler block, so skip it    }
+               While GetNextInstruction(BlockStart, BlockStart) And
+                     ((BlockStart.Typ <> Ait_Marker) Or
+                      (tai_Marker(Blockstart).Kind <> AsmBlockEnd)) Do;
+               { blockstart now contains a tai_marker(asmblockend) }
+               If GetNextInstruction(BlockStart, HP) And
+                  ((HP.typ <> ait_Marker) Or
+                   (Tai_Marker(HP).Kind <> AsmBlockStart)) Then
+               { There is no assembler block anymore after the current one, so }
+               { optimize the next block of "normal" instructions              }
+                 pass_1
+               { Otherwise, skip the next assembler block }
+               else
+                 blockStart := hp;
+              End
+          End;
+      End;
+
+    Destructor TAsmOptimizer.Destroy;
+      Begin
+        Dispose(LabelInfo)
+      End;
+
+
+    procedure Optimize(AsmL:taasmoutput);
+      var
+        p : TAsmOptimizer;
+      begin
+        p:=casmoptimizer.Create(AsmL);
+        p.Optimize;
+        p.free
+      end;
+
+
+end.

+ 257 - 0
compiler/aoptbase.pas

@@ -0,0 +1,257 @@
+{
+    Copyright (c) 1998-2002 by Jonas Maebe, member of the Free Pascal
+    Development Team
+
+    This unit contains the base of all optimizer related objects
+
+    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 aoptbase;
+
+{$i fpcdefs.inc}
+
+  interface
+
+    uses
+      aasmbase,aasmcpu,aasmtai,
+      cpubase,
+      cgbase,
+      cgutils;
+
+    Type
+      { the number of tai objects processed by an optimizer object since the last
+        time a register was modified                                              }
+      { size at each dimension depends on the registers of this type }
+      TInstrSinceLastMod = Array[tregistertype] of pbyte;
+
+    { the TAopBase object implements the basic methods that most other }
+    { assembler optimizer objects require                              }
+    Type
+      TAoptBase = class
+        { processor independent methods }
+
+        constructor create; virtual;
+        destructor destroy;override;
+        { returns true if register Reg is used by instruction p1 }
+        Function RegInInstruction(Reg: TRegister; p1: tai): Boolean;
+        { 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 }
+        Function RegInRef(Reg: TRegister; Const Ref: TReference): Boolean;
+
+        { returns true if the references are completely equal }
+        {Function RefsEqual(Const R1, R2: TReference): Boolean;}
+
+        { gets the next tai object after current that contains info relevant }
+        { to the optimizer in p1. If there is none, it returns false and     }
+        { sets p1 to nil                                                     }
+        Function GetNextInstruction(Current: tai; Var Next: tai): Boolean;
+        { gets the previous tai object after current that contains info  }
+        { relevant to the optimizer in last. If there is none, it retuns }
+        { false and sets last to nil                                     }
+        Function GetLastInstruction(Current: tai; Var Last: tai): Boolean;
+
+
+        { processor dependent methods }
+
+        { returns the maximum width component of Reg. Only has to be }
+        { overridden for the 80x86 (afaik)                           }
+        Function RegMaxSize(Reg: TRegister): TRegister; Virtual;
+        { returns true if Reg1 and Reg2 are of the samae width. Only has to }
+        { overridden for the 80x86 (afaik)                                  }
+        Function RegsSameSize(Reg1, Reg2: TRegister): Boolean; Virtual;
+        { returns whether P is a load instruction (load contents from a }
+        { memory location or (register) variable into a register)       }
+        Function IsLoadMemReg(p: tai): Boolean; Virtual;
+        { returns whether P is a load constant instruction (load a constant }
+        { into a register)                                                  }
+        Function IsLoadConstReg(p: tai): Boolean; Virtual;
+        { 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;
+
+        { create a paicpu Object that loads the contents of reg1 into reg2 }
+        Function a_load_reg_reg(reg1, reg2: TRegister): taicpu; Virtual;
+
+    end;
+
+
+  implementation
+
+    uses
+      globtype,globals, aoptcpub;
+
+  constructor taoptbase.create;
+    begin
+      inherited create;
+    end;
+
+
+  destructor taoptbase.destroy;
+    begin
+      inherited destroy;
+    end;
+
+
+  Function TAOptBase.RegInInstruction(Reg: TRegister; p1: tai): Boolean;
+    Var Count: AWord;
+        TmpResult: Boolean;
+    Begin
+      TmpResult := False;
+      Count := 0;
+      If (p1.typ = ait_instruction) Then
+        Repeat
+          TmpResult := RegInOp(Reg, PInstr(p1)^.oper[Count]^);
+          Inc(Count)
+        Until (Count = MaxOps) or TmpResult;
+      RegInInstruction := TmpResult
+    End;
+
+
+  Function TAOptBase.RegInOp(Reg: TRegister; const op: toper): Boolean;
+    Begin
+      Case op.typ Of
+        Top_Reg: RegInOp := Reg = op.reg;
+        Top_Ref: RegInOp := RegInRef(Reg, op.ref^)
+        Else RegInOp := False
+      End
+    End;
+
+
+  Function TAOptBase.RegInRef(Reg: TRegister; Const Ref: TReference): Boolean;
+  Begin
+    Reg := RegMaxSize(Reg);
+    RegInRef := (Ref.Base = Reg)
+  {$ifdef RefsHaveIndexReg}
+    Or (Ref.Index = Reg)
+  {$endif RefsHaveIndexReg}
+  End;
+
+  Function TAOptBase.GetNextInstruction(Current: tai; Var Next: tai): Boolean;
+  Begin
+    Repeat
+      Current := tai(Current.Next);
+      While Assigned(Current) And
+            ((Current.typ In SkipInstr) or
+{$ifdef SPARC}
+             ((Current.typ=ait_instruction) and
+              (taicpu(Current).opcode=A_NOP)
+             ) or
+{$endif SPARC}
+             ((Current.typ = ait_label) And
+              Not(Tai_Label(Current).l.is_used))) Do
+        Current := tai(Current.Next);
+      If Assigned(Current) And
+         (Current.typ = ait_Marker) And
+         (Tai_Marker(Current).Kind = NoPropInfoStart) Then
+        Begin
+          While Assigned(Current) And
+                ((Current.typ <> ait_Marker) Or
+                 (Tai_Marker(Current).Kind <> NoPropInfoEnd)) Do
+            Current := Tai(Current.Next);
+        End;
+    Until Not(Assigned(Current)) Or
+          (Current.typ <> ait_Marker) Or
+          (Tai_Marker(Current).Kind <> NoPropInfoEnd);
+    Next := Current;
+    If Assigned(Current) And
+       Not((Current.typ In SkipInstr) or
+           ((Current.typ = ait_label) And
+            Not(Tai_Label(Current).l.is_used)))
+      Then GetNextInstruction := True
+      Else
+        Begin
+          Next := Nil;
+          GetNextInstruction := False;
+        End;
+  End;
+
+  Function TAOptBase.GetLastInstruction(Current: tai; Var Last: tai): Boolean;
+  Begin
+    Repeat
+      Current := Tai(Current.previous);
+      While Assigned(Current) And
+            (((Current.typ = ait_Marker) And
+              Not(Tai_Marker(Current).Kind in [AsmBlockEnd,NoPropInfoEnd])) or
+             (Current.typ In SkipInstr) or
+             ((Current.typ = ait_label) And
+               Not(Tai_Label(Current).l.is_used))) Do
+        Current := Tai(Current.previous);
+      If Assigned(Current) And
+         (Current.typ = ait_Marker) And
+         (Tai_Marker(Current).Kind = NoPropInfoEnd) Then
+        Begin
+          While Assigned(Current) And
+                ((Current.typ <> ait_Marker) Or
+                 (Tai_Marker(Current).Kind <> NoPropInfoStart)) Do
+            Current := Tai(Current.previous);
+        End;
+    Until Not(Assigned(Current)) Or
+          (Current.typ <> ait_Marker) Or
+          (Tai_Marker(Current).Kind <> NoPropInfoStart);
+    If Not(Assigned(Current)) or
+       (Current.typ In SkipInstr) or
+       ((Current.typ = ait_label) And
+        Not(Tai_Label(Current).l.is_used)) or
+       ((Current.typ = ait_Marker) And
+        (Tai_Marker(Current).Kind = AsmBlockEnd))
+      Then
+        Begin
+          Last := Nil;
+          GetLastInstruction := False
+        End
+      Else
+        Begin
+          Last := Current;
+          GetLastInstruction := True;
+        End;
+  End;
+
+
+  { ******************* Processor dependent stuff *************************** }
+
+  Function TAOptBase.RegMaxSize(Reg: TRegister): TRegister;
+  Begin
+    RegMaxSize := Reg
+  End;
+
+  Function TAOptBase.RegsSameSize(Reg1, Reg2: TRegister): Boolean;
+  Begin
+    RegsSameSize := True
+  End;
+
+  Function TAOptBase.IsLoadMemReg(p: tai): Boolean;
+  Begin
+    Abstract
+  End;
+
+  Function TAOptBase.IsLoadConstReg(p: tai): Boolean;
+  Begin
+    Abstract
+  End;
+
+  Function TAOptBase.IsStoreRegMem(p: tai): Boolean;
+  Begin
+    Abstract
+  End;
+
+  Function TAoptBase.a_load_reg_reg(reg1, reg2: TRegister): taicpu;
+  Begin
+    Abstract
+  End;
+
+end.

+ 848 - 0
compiler/aoptcs.pas

@@ -0,0 +1,848 @@
+{
+    Copyright (c) 1998-2002 by Jonas Maebe, member of the Free Pascal
+    Development Team
+
+    This unit contains the common subexpression elimination object of the
+    assembler optimizer.
+
+    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 aoptcs;
+
+interface
+
+uses aasm, aoptcpu, aoptobj;
+
+{ ************************************************************************* }
+{ info about the equivalence of registers when comparing two code sequences }
+{ ************************************************************************* }
+
+  TRegInfo = Object(TAoptBaseCpu)
+    { registers encountered in the new and old sequence }
+    NewRegsEncountered, OldRegsEncountered,
+    { registers which only have been loaded for use as base or index in a }
+    { reference later on                                                  }
+    RegsLoadedForRef: TRegSet;
+    { to which register in the old sequence corresponds every register in }
+    { the new sequence                                                    }
+    New2OldReg: TRegArray;
+
+    Constructor init;
+    { clear all information store in the object }
+    Procedure Clear;
+    { the contents of OldReg in the old sequence are now being loaded into }
+    { NewReg in the new sequence                                           }
+    Procedure AddReg(OldReg, NewReg: TRegister); Virtual;
+    { the contents of OldOp in the old sequence are now being loaded into }
+    { NewOp in the new sequence. It is assumed that OldOp and NewOp are   }
+    { equivalent                                                          }
+    Procedure AddOp(const OldOp, NewOp:Toper);
+    { check if a register in the old sequence (OldReg) can be equivalent to }
+    { a register in the new sequence (NewReg) if the operation OpAct is     }
+    { performed on it. The RegInfo is updated (not necessary to call AddReg }
+    { afterwards)                                                           }
+    Function RegsEquivalent(OldReg, NewReg: TRegister; OpAct: TopAction):
+      Boolean;
+    { check if a reference in the old sequence (OldRef) can be equivalent   }
+    { to a reference in the new sequence (NewRef) if the operation OpAct is }
+    { performed on it. The RegInfo is updated (not necessary to call AddOp  }
+    { afterwards)                                                           }
+    Function RefsEquivalent(Const OldRef, NewRef: TReference; OpAct:
+      TOpAction): Boolean;
+    { check if an operand in the old sequence (OldOp) can be equivalent to }
+    { an operand in the new sequence (NewOp) if the operation OpAct is     }
+    { performed on it. The RegInfo is updated (not necessary to call AddOp }
+    { afterwards)                                                          }
+    Function OpsEquivalent(const OldOp, NewOp: toper; OpAct: TopAction):
+      Boolean;
+    { check if an instruction in the old sequence (OldP) can be equivalent  }
+    { to an instruction in the new sequence (Newp). The RegInfo is updated  }
+    Function InstructionsEquivalent(OldP, NewP: Pai): Boolean;
+  End;
+
+
+{ ************************************************************************* }
+{ *************** The common subexpression elimination object ************* }
+{ ************************************************************************* }
+
+Type TAoptCSE = Object(TAoptObj)
+       { returns true if the instruction p1 modifies the register Reg }
+       Function RegModifiedByInstruction(Reg: TRegister; p1: Pai): Boolean;
+     End;
+
+Implementation
+
+{ ************************************************************************* }
+{ ******************************* TReginfo ******************************** }
+{ ************************************************************************* }
+
+Constructor TRegInfo.Init;
+Begin
+  Clear;
+End;
+
+Procedure TRegInfo.Clear;
+Begin
+  RegsLoadedForRef   := [];
+  NewRegsEncountered := [FRAME_POINTER_REG, STACK_POINTER_REG];
+  OldRegsEncountered := [FRAME_POINTER_REG, STACK_POINTER_REG];
+  New2OldReg[FRAME_POINTER_REG] := FRAME_POINTER_REG;
+  New2OldReg[STACK_POINTER_REG] := STACK_POINTER_REG;
+End;
+
+Procedure TRegInfo.AddReg(OldReg, NewReg: TRegister);
+{ updates the ???RegsEncountered and ???2???Reg fields of RegInfo. Assumes  }
+{ that OldReg and NewReg have the same size (has to be chcked in advance    }
+{ with RegsSameSize) and that neither equals R_NO                           }
+{ has to be overridden for architectures like the 80x86 when not all GP     }
+{ regs are of the same size                                                 }
+Begin
+  NewRegsEncountered := NewRegsEncountered + [NewReg];
+  OldRegsEncountered := OldRegsEncountered + [OldReg];
+  New2OldReg[NewReg] := OldReg;
+End;
+
+Procedure TRegInfo.AddOp(const OldOp, NewOp:Toper);
+Begin
+  Case OldOp.typ Of
+    Top_Reg:
+      If (OldOp.reg <> R_NO) Then
+        AddReg(OldOp.reg, NewOp.reg);
+    Top_Ref:
+      Begin
+        If OldOp.ref^.base <> R_NO Then
+          AddReg(OldOp.ref^.base, NewOp.ref^.base);
+{$ifdef RefsHaveIndexReg}
+        If OldOp.ref^.index <> R_NO Then
+          AddReg(OldOp.ref^.index, NewOp.ref^.index);
+{$endif RefsHaveIndexReg}
+      End;
+  End;
+End;
+
+Function TRegInfo.RegsEquivalent(OldReg, NewReg: TRegister;
+           OPAct: TOpAction): Boolean;
+Begin
+  If Not((OldReg = R_NO) Or (NewReg = R_NO)) Then
+    If RegsSameSize(OldReg, NewReg) Then
+{ here we always check for the 32 bit component, because it is possible    }
+{ that the 8 bit component has not been set, event though NewReg already   }
+{ has been processed. This happens if it has been compared with a register }
+{ that doesn't have an 8 bit component (such as EDI). In that case the 8   }
+{ bit component is still set to R_NO and the comparison in the Else-part   }
+{ will fail                                                                }
+      If (RegMaxSize(OldReg) in OldRegsEncountered) Then
+        If (RegMaxSize(NewReg) in NewRegsEncountered) Then
+          RegsEquivalent := (OldReg = New2OldReg[NewReg])
+{ If we haven't encountered the new register yet, but we have encountered }
+{ the old one already, the new one can only be correct if it's being      }
+{ written to (and consequently the old one is also being written to),     }
+{ otherwise                                                               }
+{                                                                         }
+{  movl -8(%ebp), %eax        and         movl -8(%ebp), %eax             }
+{  movl (%eax), %eax                      movl (%edx), %edx               }
+{                                                                         }
+{  are considered equivalent                                              }
+        Else
+          If (OpAct = OpAct_Write) Then
+            Begin
+              AddReg(OldReg, NewReg);
+              RegsEquivalent := True
+            End
+          Else Regsequivalent := False
+      Else
+        If Not(RegMaxSize(NewReg) in NewRegsEncountered) Then
+          Begin
+            AddReg(OldReg, NewReg);
+            RegsEquivalent := True
+          End
+        Else RegsEquivalent := False
+    Else RegsEquivalent := False
+  Else RegsEquivalent := OldReg = NewReg
+End;
+
+Function TRegInfo.RefsEquivalent(Const OldRef, NewRef: TReference;
+           OpAct: TOpAction): Boolean;
+Begin
+  If OldRef.is_immediate Then
+    RefsEquivalent := NewRef.is_immediate and (OldRef.Offset = NewRef.Offset)
+  Else
+    RefsEquivalent := (OldRef.Offset+OldRef.OffsetFixup =
+                         NewRef.Offset+NewRef.OffsetFixup) And
+                      RegsEquivalent(OldRef.Base, NewRef.Base, OpAct)
+{$ifdef RefsHaveindexReg}
+                      And RegsEquivalent(OldRef.Index, NewRef.Index, OpAct)
+{$endif RefsHaveIndexReg}
+{$ifdef RefsHaveScale}
+                      And (OldRef.ScaleFactor = NewRef.ScaleFactor)
+{$endif RefsHaveScale}
+                      And (OldRef.Symbol = NewRef.Symbol)
+{$ifdef RefsHaveSegment}
+                      And (OldRef.Segment = NewRef.Segment)
+{$endif RefsHaveSegment}
+                      ;
+End;
+
+Function TRegInfo.OpsEquivalent(const OldOp, NewOp: toper; OpAct: TopAction):
+           Boolean;
+Begin
+  OpsEquivalent := False;
+  if OldOp.typ=NewOp.typ then
+    Case OldOp.typ Of
+      Top_Const: OpsEquivalent := OldOp.val = NewOp.val;
+      Top_Reg: OpsEquivalent := RegsEquivalent(OldOp.reg,NewOp.reg, OpAct);
+      Top_Ref: OpsEquivalent := RefsEquivalent(OldOp.ref^, NewOp.ref^, OpAct);
+      Top_None: OpsEquivalent := True
+    End;
+End;
+
+Function TRegInfo.InstructionsEquivalent(OldP, NewP: Pai): Boolean;
+
+  Function OperandTypesEqual: Boolean;
+  Var Count: AWord;
+  Begin
+    OperandTypesEqual := False;
+    For Count := 0 to max_operands-1 Do
+      If (PInstr(OldP)^.oper[Count].typ <> PInstr(NewP)^.oper[Count].typ) Then
+        Exit;
+    OperandTypesEqual := True
+  End;
+
+Var Count: AWord;
+    TmpResult: Boolean;
+Begin
+  If Assigned(OldP) And Assigned(NewP) And
+     (Pai(OldP)^.typ = ait_instruction) And
+     (Pai(NewP)^.typ = ait_instruction) And
+     (PInstr(OldP)^.opcode = PInstr(NewP)^.opcode) And
+     OperandTypesEqual
+    Then
+{ both instructions have the same structure:                }
+{ "<operator> <operand of type1>, <operand of type 2>, ..." }
+      If IsLoadMemReg(OldP) Then
+{ then also NewP = loadmemreg because of the previous check }
+        If Not(RegInRef(PInstr(OldP)^.oper[LoadDst].reg,
+                 PInstr(OldP)^.oper[LoadSrc].ref^)) Then
+{ the "old" instruction is a load of a register with a new value, not with }
+{ a value based on the contents of this register (so no "mov (reg), reg")  }
+          If Not(RegInRef(PInstr(NewP)^.oper[LoadDst].reg,
+                          PInstr(NewP)^.oper[LoadSrc].ref^)) And
+             RefsEqual(PInstr(OldP)^.oper[LoadSrc].ref^,
+                       PInstr(NewP)^.oper[LoadSrc].ref^)
+            Then
+{ the "new" instruction is also a load of a register with a new value, and }
+{ this value is fetched from the same memory location                      }
+              Begin
+                With PInstr(NewP)^.oper[LoadSrc].ref^ Do
+                  Begin
+                    If Not(Base in [ProcInfo.FramePointer, R_NO, STACK_POINTER_REG])
+{ it won't do any harm if the register is already in RegsLoadedForRef }
+                      Then RegsLoadedForRef := RegsLoadedForRef + [Base];
+{$ifdef RefsHaveIndexReg}
+                    If Not(Index in [ProcInfo.FramePointer, R_NO, STACK_POINTER_REG])
+                      Then RegsLoadedForRef := RegsLoadedForRef + [Index];
+{$endif RefsHaveIndexReg}
+                  End;
+{ add the registers from the reference (.oper[Src]) to the RegInfo, all }
+{ registers from the reference are the same in the old and in the new   }
+{ instruction sequence (refsequal returned true)                        }
+                AddOp(PInstr(OldP)^.oper[LoadSrc], PInstr(OldP)^.oper[LoadSrc]);
+{ the registers from .oper[Dest] have to be equivalent, but not necessarily }
+{ equal                                                                     }
+                InstructionsEquivalent :=
+                  RegsEquivalent(PInstr(OldP)^.oper[LoadDst].reg,
+                                 PInstr(NewP)^.oper[LoadDst].reg, OpAct_Write);
+              End
+{ the registers are loaded with values from different memory locations. If }
+{ this were allowed, the instructions "mov -4(%esi),%eax" and              }
+{  "mov -4(%ebp),%eax" would be considered equivalent                      }
+            Else InstructionsEquivalent := False
+        Else
+{ load register with a value based on the current value of this register }
+          Begin
+            With PInstr(NewP)^.oper[0].ref^ Do
+{ Assume the registers occurring in the reference have only been loaded with }
+{ the value they contain now to calculate an address (so the value they have }
+{ now, won't be stored to memory later on)                                   }
+              Begin
+                If Not(Base in [ProcInfo.FramePointer,
+                                RegMaxSize(PInstr(NewP)^.oper[LoadDst].reg),
+                                R_NO,STACK_POINTER_REG])
+{ It won't do any harm if the register is already in RegsLoadedForRef }
+                  Then
+                    Begin
+                      RegsLoadedForRef := RegsLoadedForRef + [Base];
+{$ifdef csdebug}
+                      Writeln(std_reg2str[base], ' added');
+{$endif csdebug}
+                    end;
+{$Ifdef RefsHaveIndexReg}
+                If Not(Index in [ProcInfo.FramePointer,
+                                 RegMaxSize(PInstr(NewP)^.oper[LoadDst].reg),
+                                 R_NO,StackPtr])
+                  Then
+                    Begin
+                      RegsLoadedForRef := RegsLoadedForRef + [Index];
+{$ifdef csdebug}
+                      Writeln(std_reg2str[index], ' added');
+{$endif csdebug}
+                    end;
+{$endif RefsHaveIndexReg}
+              End;
+
+{ now, remove the destination register of the load from the                 }
+{ RegsLoadedForReg, since if it's loaded with a new value, it certainly     }
+{ will still be used later on                                               }
+            If Not(RegMaxSize(PInstr(NewP)^.oper[LoadDst].reg) In
+                [ProcInfo.FramePointer,R_NO,STACK_POINTER_REG])
+              Then
+                Begin
+                  RegsLoadedForRef := RegsLoadedForRef -
+                    [RegMaxSize(PInstr(NewP)^.oper[LoadDst].reg)];
+{$ifdef csdebug}
+                  Writeln(std_reg2str[RegMaxSize(PInstr(NewP)^.oper[1].reg)], ' removed');
+{$endif csdebug}
+                end;
+            InstructionsEquivalent :=
+               OpsEquivalent(PInstr(OldP)^.oper[LoadSrc],
+                             PInstr(NewP)^.oper[LoadSrc], OpAct_Read) And
+               OpsEquivalent(PInstr(OldP)^.oper[LoadDst],
+                             PInstr(NewP)^.oper[LoadDst], OpAct_Write)
+          End
+      Else
+{ OldP and NewP are not a load instruction, but have the same structure }
+{ (opcode, operand types), so they're equivalent if all operands are    }
+{ equivalent                                                            }
+       Begin
+         Count := 0;
+         TmpResult := true;
+         Repeat
+           TmpResult :=
+             OpsEquivalent(PInstr(OldP)^.oper[Count], PInstr(NewP)^.oper[Count],
+                           OpAct_Unknown);
+           Inc(Count)
+         Until (Count = MaxOps) or not(TmpResult);
+         InstructionsEquivalent := TmpResult
+       End
+{ the instructions haven't even got the same structure, so they're certainly }
+{ not equivalent                                                             }
+    Else InstructionsEquivalent := False;
+End;
+
+
+Function TRegInfo.CheckSequence(p: Pai; Reg: TRegister; Var Found: Longint):
+           Boolean;
+{checks whether the current instruction sequence (starting with p) and the
+ one between StartMod and EndMod of Reg are the same. If so, the number of
+ instructions that match is stored in Found and true is returned, otherwise
+ Found holds the number of instructions between StartMod and EndMod and false
+ is returned}
+
+{ note: the NrOfMods field can hold two deifferent values depending on      }
+{ which instruction it belongs to:                                          }
+{   * if it is the first instruction of a sequence that describes the       }
+{     contents of a register, NrOfMods contains how many instructions are   }
+{      in the sequence                                                      }
+{   * otherwise, NrOfMods contains how many instructions are in the         }
+{     describing the contents of the register after the current instruction }
+{     has been executed                                                     }
+
+Var oldp, newp: Pai;
+    PrevNonRemovablePai: Pai;
+    OrgRegInfo, HighRegInfo: PRegInfo;
+    HighFound, OrgRegFound: Byte;
+    RegCounter: TRegister;
+    OrgRegResult: Boolean;
+    TmpResult: Boolean;
+    OldNrOfMods: Byte;
+Begin {CheckSequence}
+  Reg := RegMaxSize(Reg);
+{ have we found a sequence of instructions equivalent to the new one? }
+  TmpResult := False;
+{ HighRegInfo will contain the RegInfo for the longest sequence of matching }
+{ instructions found                                                        }
+  New(HighRegInfo, Init);
+{ how many instructions are in the sequence describing the content of Reg }
+{ (the parameter) in the old sequence                                     }
+  OrgRegFound := 0;
+{ how many instructions are in the longest sequence of matching }
+{ instructions found until now?                                 }
+  HighFound := 0;
+{ does the content of Reg in the old equence match the content of Reg in }
+{ the new sequence                                                       }
+  OrgRegResult := False;
+  RegCounter := LoGPReg;
+{ PrevNonRemovablePai's OptInfo contains the contents of the registers   }
+{ before the current instruction is executed. It will be used to compare }
+{ the new contents with and to see whether the new instructions can be   }
+{ removed                                                                }
+  GetLastInstruction(p, PrevNonRemovablePai);
+{ don't check registers that only contain a constant or something unknown }
+  While (RegCounter <= HiGPReg And
+        (PPaiProp(PrevNonRemovablePai^.OptInfo)^.Regs[RegCounter].Typ <> Con_Ref) Do
+    Inc(RegCounter);
+  While (RegCounter <= HiGPReg) Do
+    Begin
+      { reinitialize the reginfo fields }
+      Init;
+      { no matching instructions found yet }
+      Found := 0;
+      With PPaiProp(PrevNonRemovablePai^.OptInfo)^.Regs[RegCounter] Do
+        Begin
+          { get the first instruction that describes the content of the }
+          { the register we're going to check the way it was before the }
+          { current instruction got executed                            }
+          oldp := StartMod;
+          { how many instructions describe the content of the register }
+          { before the current instructions got executed?              }
+          OldNrOfMods := NrOfMods
+        End;
+      { p is the first instruction that describes the content of Reg }
+      { after p (= the current instruction) got executed             }
+      newp := p;
+      { it's possible that the old contents of the current register are   }
+      { described by a sequence of instructions that also contains the    }
+      { one in parameter p. In that case, we have to compare until we     }
+      { encounter p. Otherwise, compare as much instructions as there are }
+      { in the old sequence or until there's a mismatch                   }
+      While  (p <> oldp) And
+             (Found < OldNrOfMods) And
+                                  { old  new }
+             InstructionsEquivalent(oldp, newp, RegInfo) Do
+        Begin
+          GetNextInstruction(oldp, oldp);
+          GetNextInstruction(newp, newp);
+          Inc(Found)
+        End;
+      If (Found < OldNrOfMods) Then
+        Begin
+          { the old sequence was longer than than the new one, so no match }
+          TmpResult := False;
+          { If there is no match, we have to set the CanBeRemoved flag of   }
+          { all pai objects part of the new sequence to false, because it's }
+          { possible that some of them have already been scheduled for      }
+          { removal after checking another sequence (an instruction can be  }
+          { of more than one sequence). If we return false, the number      }
+          { returned in found denotes how many instructions have to have    }
+          { their CanBeRemoved flag set to false                            }
+          { We only have to set those flags to false if their was a partial }
+          { match of instructions (found > 0), because otherwise they can't }
+          { have been set to true in a previous comparison                  }
+          If (found > 0) Then
+            Found := PPaiProp(Pai(p)^.OptInfo)^.Regs[Reg].NrOfMods
+        End
+      Else TmpResult := True;
+      If (RegCounter = Reg) Then
+        Begin
+          OrgRegFound := Found;
+          OrgRegResult := TmpResult;
+          New(OrgRegInfo, InitWithValue(RegInfo));
+        End
+      Else
+        If TmpResult And
+           (Found > HighFound) Then
+          Begin
+            HighFound := Found;
+            HighRegInfo^.InitWithValue(RegInfo);
+          End;
+      RegInfo.Done;
+      Repeat
+        Inc(RegCounter);
+      Until (RegCounter > HiGPReg) or
+            (PPaiProp(PrevNonRemovablePai^.OptInfo)^.Regs[RegCounter].Typ =
+              Con_Ref);
+    End;
+  If (HighFound > 0) And
+     (Not(OrgRegResult) Or
+      (HighFound > OrgRegFound)) Then
+    Begin
+      CheckSequence := True;
+      Found := HighFound
+      InitWithValue(HighRegInfo);
+    End
+  Else
+    Begin
+      CheckSequence := OrgRegResult;
+      Found := OrgRegFound;
+      InitWithValue(OrgRegInfo);
+    End;
+    Dispose(HighRegInfo, Done);
+    Dispose(OrgRegInfo, Done)
+End; {CheckSequence}
+
+
+{ ************************************************************************* }
+{ ******************************* TAOptCSE ******************************** }
+{ ************************************************************************* }
+
+
+Function TAOptCSE.RegModifiedByInstruction(Reg: TRegister; p1: Pai): Boolean;
+Var hp: Pai;
+Begin
+  If GetLastInstruction(p1, hp)
+    Then
+      RegModifiedByInstruction :=
+        PPAiProp(p1^.OptInfo)^.GetWState <>
+          PPAiProp(hp^.OptInfo)^.GetWState
+    Else RegModifiedByInstruction := True;
+End;
+
+Procedure TAoptCSE.RestoreContents(Current: Pai; Reg: TRegister);
+Var Prev, hp3, hp5: Pai;
+    TmpState: TStateInt;
+    Cnt, Cnt2: Byte;
+Begin
+{ load Cnt2 with the total number of instructions of this sequence }
+  Cnt2 := PPaiProp(Prev^.OptInfo)^.Regs[RegInfo.New2OldReg[reg]].
+    NrOfMods;
+{ sometimes, a register can not be removed from a sequence, because it's }
+{ still used afterwards:                                                 }
+{                                                                        }
+{ movl    -8(%ebp), %eax                        movl    -8(%ebp), %eax   }
+{ movl    70(%eax), %eax                        movl    70(%eax), %eax   }
+{ cmpl    74(%eax), %eax                        cmpl    74(%eax), %eax   }
+{ jne     l1               can't be changed to  jne     l1               }
+{ movl    -8(%ebp), %eax                                                 }
+{ movl    70(%eax), %edi                        movl    %eax, %edi       }
+{ boundl  R_282, %edi                           boundl  R_282, %edi      }
+{ pushl   70(%eax)                              pushl   70(%eax)         }
+{                                                                        }
+{ because eax now contains the wrong value when 70(%eax) is pushed       }
+
+{ start at the first instruction of the sequence }
+  hp3 := Current;
+  For Cnt := 1 to Pred(Cnt2) Do
+    GetNextInstruction(hp3, hp3);
+{ hp3 now containts the last instruction of the sequence }
+{ get the writestate at this point of the register in TmpState }
+  TmpState := PPaiProp(hp3^.OptInfo)^.GetWState(reg);
+{ hp3 := first instruction after the sequence }
+  GetNextInstruction(hp3, hp3);
+
+{ now, even though reg is in RegsLoadedForRef, sometimes it's still used  }
+{ afterwards. It is not if either it is not in usedregs anymore after the }
+{ sequence, or if it is loaded with a new value right after the sequence  }
+  If (TmpState <> PPaiProp(hp3^.OptInfo)^.Regs[reg].WState) Or
+     Not(reg in PPaiProp(hp3^.OptInfo)^.UsedRegs) Then
+{ the register is not used anymore after the sequence! }
+    Begin
+{$ifdef csdebug}
+      Writeln('Cnt2: ',Cnt2);
+      hp5 := new(pai_asm_comment,init(strpnew('starting here...')));
+      InsertLLItem(Pai(Current^.previous), Current, hp5);
+{$endif csdebug}
+      hp3 := Current;
+{ first change the contents of the register inside the sequence }
+      For Cnt := 1 to Cnt2 Do
+        Begin
+ {save the WState of the last pai object of the sequence for later use}
+          TmpState := PPaiProp(hp3^.OptInfo)^.Regs[reg].WState;
+{$ifdef csdebug}
+          hp5 := new(pai_asm_comment,init(strpnew('WState for '+
+            std_reg2str[reg]+': '+tostr(tmpstate))));
+          InsertLLItem(hp3, pai(hp3^.next), hp5);
+{$endif csdebug}
+          PPaiProp(hp3^.OptInfo)^.Regs[reg] :=
+            PPaiProp(Prev^.OptInfo)^.Regs[reg];
+          GetNextInstruction(hp3, hp3);
+        End;
+{ here, hp3 = p = Pai object right after the sequence, TmpState = WState of }
+{ reg at the last Pai object of the sequence                                }
+      GetLastInstruction(hp3, hp3);
+{ now, as long as the register isn't modified after the sequence, set its }
+{ contents to what they were before the sequence                          }
+      While GetNextInstruction(hp3, hp3) And
+            (PPaiProp(hp3^.OptInfo)^.GetWState(Reg) = TmpState) Do
+{$ifdef csdebug}
+        begin
+          hp5 := new(pai_asm_comment,init(strpnew('WState for '+std_reg2str[reg]+': '+
+                 tostr(PPaiProp(hp3^.OptInfo)^.GetWState(reg)))));
+             InsertLLItem(hp3, pai(hp3^.next), hp5);
+{$endif csdebug}
+          PPaiProp(hp3^.OptInfo)^.Regs[reg] :=
+            PPaiProp(Prev^.OptInfo)^.Regs[reg];
+{$ifdef csdebug}
+        end;
+{$endif csdebug}
+    End
+  Else
+{ the register is still used after the sequence, so undelete all }
+{ instructions in the sequence that modify reg                   }
+    Begin
+{$ifdef csdebug}
+      Writeln('Got there for ',std_reg2str[reg]);
+{$endif csdebug}
+      hp3 := Current;
+      For Cnt := 1 to Cnt2 Do
+        Begin
+          If RegModifiedByInstruction(reg, hp3) Then
+            PPaiProp(hp3^.OptInfo)^.CanBeRemoved := False;
+          GetNextInstruction(hp3, hp3);
+        End;
+    End;
+{$ifdef csdebug}
+  hp5 := new(pai_asm_comment,init(strpnew('stopping here...')));
+  InsertLLItem(AsmL, hp3, pai(hp3^.next), hp5);
+{$endif csdebug}
+End;
+
+Procedure TAoptCSE.DoCSE;
+{marks the instructions that can be removed by RemoveInstructs. They're not
+ removed immediately because sometimes an instruction needs to be checked in
+ two different sequences}
+Var Cnt, Cnt2: Longint;
+    p, hp1, Current: Pai;
+    hp3, Prev: Pai;
+{$ifdef csdebug}
+    hp5: pai;
+{$endif csdebug}
+    RegInfo: TRegInfo;
+    RegCounter: TRegister;
+    TmpState: Byte;
+Begin
+  p := SkipHead(BlockStart);
+  While (p <> BlockEnd) Do
+    Begin
+      Case p^.typ Of
+        ait_instruction:
+          Begin
+{            Case PInstr(p)^.opcode Of
+              A_CLD: If GetLastInstruction(p, hp1) And
+                        (PPaiProp(hp1^.OptInfo)^.DirFlag = F_NotSet) Then
+                       PPaiProp(Pai(p)^.OptInfo)^.CanBeRemoved := True;}
+              If IsLoadMemReg(p) Then
+                Begin
+                  If (p = PPaiProp(p^.OptInfo)^.Regs[RegMaxSize(
+                       PInstr(p)^.oper[LoadDst].reg)].StartMod) And
+                     GetLastInstruction (p, hp1) And
+                     (hp1^.typ <> ait_marker) Then
+{so we don't try to check a sequence when p is the first instruction of the block}
+                    If CheckSequence(p, PInstr(p)^.oper[LoadDst].reg, Cnt) And
+                       (Cnt > 0) Then
+                      Begin
+                        hp1 := nil;
+{ although it's perfectly ok to remove an instruction which doesn't contain }
+{ the register that we've just checked (CheckSequence takes care of that),  }
+{   the sequence containing this other register should also be completely   }
+{   checked (and either removed or marked as non-removable), otherwise we   }
+{ may get situations like this:                                             }
+{                                                                           }
+{     movl 12(%ebp), %edx                       movl 12(%ebp), %edx         }
+{     movl 16(%ebp), %eax                       movl 16(%ebp), %eax         }
+{     movl 8(%edx), %edx                        movl 8(%edx), %edx          }
+{     movl (%eax), eax                          movl (%eax), eax            }
+{     cmpl %eax, %edx                           cmpl %eax, %edx             }
+{     jnz  l123           getting converted to  jnz  l123                   }
+{     movl 12(%ebp), %edx                       movl 4(%eax), eax           }
+{     movl 16(%ebp), %eax                                                   }
+{     movl 8(%edx), %edx                                                    }
+{     movl 4(%eax), eax                                                     }
+                        Current := p;
+                        Cnt2 := 1;
+{ after this while loop, if hp1 <> nil it will contain the pai object }
+{ that's the start of a sequence that's not completely checked yet    }
+                        While Cnt2 <= Cnt Do
+                          Begin
+                            If (hp1 = nil) And
+                               Not(RegInInstruction(
+                                     PInstr(Current)^.oper[LoadDst].reg,p) Or
+                                   RegInInstruction(RegMaxSize(PInstr(
+                                     Current)^.oper[LoadDst].reg), p)) And
+{ do not recheck a sequence if it's completely part of the one we just }
+{ checked                                                              }
+                               Not(IsLoadMemReg(p) And
+                                   (PPaiProp(p^.OptInfo)^.Regs[RegMaxSize(
+                                      PInstr(p)^.Oper[LoadDst].reg)]
+                                      .NrOfMods <= (Cnt - Cnt2 + 1))) Then
+                              hp1 := p;
+{$ifndef noremove}
+                            PPaiProp(p^.OptInfo)^.CanBeRemoved := True;
+{$endif noremove}
+                            Inc(Cnt2);
+                            GetNextInstruction(p, p);
+                          End;
+{ insert a marker noting that for the following instructions no PPaiProp's }
+{ (containing optimizer info) have been generated, so GetNext/             }
+{ LastInstruction will ignore them (it will use the original instructions) }
+                        hp3 := New(Pai_Marker,Init(NoPropInfoStart));
+                        InsertLLItem(Pai(Current^.Previous), Current, hp3);
+{ Prev is used to get the contents of the registers before the sequence }
+                        GetLastInstruction(Current, Prev);
+{ If some registers were different in the old and the new sequence, move }
+{  the contents of those old registers to the new ones, e.g.             }
+{                                                                        }
+{   mov mem1, reg1                        mov mem1, reg1                 }
+{   ...               can be changed to   ...                            }
+{   mov mem1, reg2                        mov reg1, reg2                 }
+
+{$IfDef CSDebug}
+                        For RegCounter := LoGPReg To HiGPReg Do
+                          If (RegCounter in RegInfo.RegsLoadedForRef) Then
+                            Begin
+                              hp5 := new(pai_asm_comment,init(strpnew(
+                                'New: '+std_reg2str[RegCounter]+', Old: '+
+                                std_reg2str[RegInfo.New2OldReg[RegCounter]])));
+                              InsertLLItem(AsmL, Pai(Current^.previous), Current, hp5);
+                            End;
+{$EndIf CSDebug}
+                        For RegCounter := LoGPReg to HiGPReg Do
+                          Begin
+{ if New2OldReg[RegCounter] = R_NO, it means this register doesn't appear }
+{ the new nor the old sequence                                            }
+                            If (RegInfo.New2OldReg[RegCounter] <> R_NO) Then
+{ if a register is in RegsLoadedForRef, it means this register was loaded }
+{ with a value only to function as a base or index in a reference. The    }
+{ practical upshot of this is that this value won't be used anymore later }
+{ on, so even if another register was used in the new sequence for this,  }
+{ we don't have to load it. E.g.                                          }
+{                                                                         }
+{ movl 8(%ebp), %eax                        "                             }
+{ movl 4(%eax), %eax                        "                             }
+{ movl (%eax), %edi                         "                             }
+{ movl %edi, 12(%ebp)                       "                             }
+{ ...                   can be changed to   "                             }
+{ movl 8(%ebp), %edx                                                      }
+{ movl 4(%edx), %edx                                                      }
+{ movl (%edx), %ebx                         movl %edi, %ebx               }
+{                                                                         }
+{ There is no need to also add a "movl %eax, %edx"                        }
+                              If Not(RegCounter In RegInfo.RegsLoadedForRef) And
+                                             {old reg              new reg}
+{ no need to reload the register if it's the same in the old and new }
+{ sequence                                                           }
+                                 (RegInfo.New2OldReg[RegCounter] <> RegCounter) Then
+
+                                Begin
+                                  hp3 := a_load_reg_reg(
+                                                 {old reg          new reg}
+                                    RegInfo.New2OldReg[RegCounter], RegCounter));
+                                  InsertLLItem(Pai(Current^.previous), Current, hp3);
+                                End
+                              Else
+{ As noted before, if a register is in RegsLoadedForRef, it doesn't have  }
+{ to be loaded. However, when data flow analyzer processed this code, the }
+{ was loaded, so we need to change that. This is done by setting the      }
+{ contents of the register to its contents before the new sequence, for   }
+{ every instruction until the first load of the register with a new value }
+                                If (RegCounter In RegInfo.RegsLoadedForRef) Then
+                                  RestoreOrigContents(Current, RegCounter);
+
+                          End;
+{ the end of the area where instructions without optimizer info can occur }
+                        hp3 := New(Pai_Marker,Init(NoPropInfoEnd));
+                        InsertLLItem(AsmL, Pai(Current^.Previous), Current, hp3);
+{ if we found an instruction sequence that needs complete re-evaluation, }
+{ process it                                                             }
+                        If hp1 <> nil Then p := hp1;
+                        Continue;
+                      End
+                    Else
+{ checksequence returned false. In that case, if the current instruction }
+{ was already deleted (as part of another sequence), we have to undelete }
+{ all instructions pertaining to the register whose sequence we just     }
+{ checked                                                                }
+                      If (Cnt > 0) And
+                         (PPaiProp(p^.OptInfo)^. Regs[RegMaxSize(PInstr(p)^.
+                            oper[LoadDst].reg)].Typ = Con_Ref) And
+                         (PPaiProp(p^.OptInfo)^.CanBeRemoved) Then
+                        Begin
+                          Current := p;
+                          Cnt2 := 1;
+                          While Cnt2 <= Cnt Do
+                            Begin
+                              If RegInInstruction(PInstr(Current)^.
+                                   oper[LoadDst].reg, p) Or
+                                 RegInInstruction(RegMaxSize(PInstr(Current)^.
+                                   oper[LoadDst].reg), p) Then
+                                PPaiProp(p^.OptInfo)^.CanBeRemoved := False;
+                              Inc(Cnt2);
+                              GetNextInstruction(p, p);
+                            End;
+                          Continue;
+                        End;
+                End
+              Else if IsLoadConstReg(p) Then
+                Begin
+                  If GetLastInstruction(p, hp1) Then
+                    With PPaiProp(hp1^.OptInfo)^.Regs[
+                           RegMaxSize(PInstr(p)^.oper[LoadDst].reg)] Do
+                      If (Typ = Con_Const) And
+                         (StartMod = p) Then
+                        PPaiProp(p^.OptInfo)^.CanBeRemoved := True;
+                End
+              Else
+                CpuCSE(p);
+{              A_STD: If GetLastInstruction(p, hp1) And
+                        (PPaiProp(hp1^.OptInfo)^.DirFlag = F_Set) Then
+                        PPaiProp(Pai(p)^.OptInfo)^.CanBeRemoved := True;
+              A_XOR:
+                Begin
+                  If (Paicpu(p)^.oper[0].typ = top_reg) And
+                     (Paicpu(p)^.oper[0].typ = top_reg) And
+                     (Paicpu(p)^.oper[1].reg = Paicpu(p)^.oper[1].reg) And
+                     GetLastInstruction(p, hp1) And
+                     (PPaiProp(hp1^.OptInfo)^.Regs[Reg32(Paicpu(p)^.oper[1].reg)].typ = con_const) And
+                     (PPaiProp(hp1^.OptInfo)^.Regs[Reg32(Paicpu(p)^.oper[1].reg)].StartMod = nil)
+                    Then PPaiProp(p^.OptInfo)^.CanBeRemoved := True
+                End
+          End;
+      End;
+      GetNextInstruction(p, p);
+    End;
+End;
+
+Procedure RemoveInstructs;
+{Removes the marked instructions and disposes the PPaiProps of the other
+ instructions, restoring their line number}
+Var p, hp1: Pai;
+    InstrCnt: Longint;
+Begin
+ p := SkipHead(BlockStart);
+  InstrCnt := 1;
+  While (p <> BlockEnd) Do
+    Begin
+{$ifndef noinstremove}
+      If PPaiProp(p^.OptInfo)^.CanBeRemoved
+        Then
+          Begin
+            Dispose(PPaiProp(p^.OptInfo));
+            GetNextInstruction(p, hp1);
+            AsmL^.Remove(p);
+            Dispose(p, Done);
+            p := hp1;
+            Inc(InstrCnt);
+          End
+        Else
+{$endif noinstremove}
+          Begin
+            Dispose(PPaiProp(p^.OptInfo));
+            p^.OptInfo := nil;
+            GetNextInstruction(p, p);
+            Inc(InstrCnt);
+          End;
+    End;
+End;
+
+Procedure TAoptCSE.CSE;
+Begin
+  DoCSE;
+  RemoveInstructs;
+End;
+
+
+
+End.

+ 183 - 0
compiler/aoptda.pas

@@ -0,0 +1,183 @@
+{
+    Copyright (c) 1998-2002 by Jonas Maebe, member of the Free Pascal
+    Development Team
+
+    This unit contains the data flow analyzer object of the assembler
+    optimizer.
+
+    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 aoptda;
+
+{$i fpcdefs.inc}
+
+  Interface
+
+    uses
+      cpubase,cgbase,
+      aasmbase,aasmtai,aasmcpu,
+      aoptcpub, aoptbase;
+
+    Type
+      TAOptDFA = class
+        { uses the same constructor as TAoptCpu = constructor from TAoptObj }
+
+        { gathers the information regarding the contents of every register }
+        { at the end of every instruction                                  }
+        Procedure DoDFA;
+
+        { handles the processor dependent dataflow analizing               }
+        Procedure CpuDFA(p: PInstr); Virtual;
+
+        { How many instructions are between the current instruction and the }
+        { last one that modified the register                               }
+        InstrSinceLastMod: TInstrSinceLastMod;
+
+        { convert a TInsChange value into the corresponding register }
+        //!!!!!!!!!! Function TCh2Reg(Ch: TInsChange): TRegister; Virtual;
+        { returns whether the instruction P reads from register Reg }
+        Function RegReadByInstr(Reg: TRegister; p: tai): Boolean; Virtual;
+      End;
+
+  Implementation
+
+    uses
+      globals, aoptobj;
+
+    Procedure TAOptDFA.DoDFA;
+    { Analyzes the Data Flow of an assembler list. Analyses the reg contents     }
+    { for the instructions between blockstart and blockend. Returns the last pai }
+    { which has been processed                                                   }
+    Var
+        CurProp: TPaiProp;
+        UsedRegs: TUsedRegs;
+        p, hp, NewBlockStart : tai;
+        TmpReg: TRegister;
+    Begin
+    {!!!!!!!!!!
+      p := BlockStart;
+      UsedRegs.Create;
+      UsedRegs.Update(p);
+      NewBlockStart := SkipHead(p);
+      { done implicitely by the constructor
+      FillChar(InstrSinceLastMod, SizeOf(InstrSinceLastMod), 0); }
+      While (P <> BlockEnd) Do
+        Begin
+          CurProp:=TPaiProp.Create;
+          If (p <> NewBlockStart) Then
+            Begin
+              GetLastInstruction(p, hp);
+              CurProp.Regs := TPaiProp(hp.OptInfo).Regs;
+    { !!!!!!!!!!!! }
+    {$ifdef x86}
+              CurProp.CondRegs.Flags :=
+                TPaiProp(hp.OptInfo).CondRegs.Flags;
+    {$endif}
+            End;
+          CurProp.UsedRegs.InitWithValue(UsedRegs.GetUsedRegs);
+          UsedRegs.Update(tai(p.Next));
+          TPaiProp(p.OptInfo) := CurProp;
+          For TmpReg := LoGPReg To HiGPReg Do
+            Inc(InstrSinceLastMod[TmpReg]);
+          Case p^.typ Of
+            ait_label:
+              If (Pai_label(p)^.l^.is_used) Then
+                CurProp^.DestroyAllRegs(InstrSinceLastMod);
+            ait_stab, ait_force_line, ait_function_name:;
+            ait_instruction:
+              if not(PInstr(p)^.is_jmp) then
+                begin
+                  If IsLoadMemReg(p) Then
+                    Begin
+                      CurProp^.ReadRef(PInstr(p)^.oper[LoadSrc].ref);
+                      TmpReg := RegMaxSize(PInstr(p)^.oper[LoadDst].reg);
+                      If RegInRef(TmpReg, PInstr(p)^.oper[LoadSrc].ref^) And
+                         (CurProp^.GetRegContentType(TmpReg) = Con_Ref) Then
+                        Begin
+                          { a load based on the value this register already }
+                          { contained                                       }
+                          With CurProp^.Regs[TmpReg] Do
+                            Begin
+                              CurProp^.IncWState(TmpReg);
+                               {also store how many instructions are part of the  }
+                               { sequence in the first instruction's PPaiProp, so }
+                               { it can be easily accessed from within            }
+                               { CheckSequence                                    }
+                              Inc(NrOfMods, InstrSinceLastMod[TmpReg]);
+                              PPaiProp(Pai(StartMod)^.OptInfo)^.Regs[TmpReg].NrOfMods := NrOfMods;
+                              InstrSinceLastMod[TmpReg] := 0
+                            End
+                        End
+                      Else
+                        Begin
+                          { load of a register with a completely new value }
+                          CurProp^.DestroyReg(TmpReg, InstrSinceLastMod);
+                          If Not(RegInRef(TmpReg, PInstr(p)^.oper[LoadSrc].ref^)) Then
+                            With CurProp^.Regs[TmpReg] Do
+                              Begin
+                                Typ := Con_Ref;
+                                StartMod := p;
+                                NrOfMods := 1;
+                              End
+                        End;
+      {$ifdef StateDebug}
+                        hp := new(pai_asm_comment,init(strpnew(std_reg2str[TmpReg]+': '+tostr(CurProp^.Regs[TmpReg].WState))));
+                        InsertLLItem(AsmL, p, p^.next, hp);
+      {$endif StateDebug}
+
+                    End
+                  Else if IsLoadConstReg(p) Then
+                    Begin
+                      TmpReg := RegMaxSize(PInstr(p)^.oper[LoadDst].reg);
+                      With CurProp^.Regs[TmpReg] Do
+                        Begin
+                          CurProp^.DestroyReg(TmpReg, InstrSinceLastMod);
+                          typ := Con_Const;
+                          StartMod := Pointer(PInstr(p)^.oper[LoadSrc].val);
+                        End
+                    End
+                  Else CpuDFA(Pinstr(p));
+                End;
+            Else CurProp^.DestroyAllRegs(InstrSinceLastMod);
+          End;
+    {      Inc(InstrCnt);}
+          GetNextInstruction(p, p);
+        End;
+    }
+    End;
+
+    Procedure TAoptDFA.CpuDFA(p: PInstr);
+    Begin
+      Abstract;
+    End;
+
+  {!!!!!!!
+    Function TAOptDFA.TCh2Reg(Ch: TInsChange): TRegister;
+    Begin
+      TCh2Reg:=R_NO;
+      Abstract;
+    End;
+  }
+
+    Function TAOptDFA.RegReadByInstr(Reg: TRegister; p: tai): Boolean;
+    Begin
+      RegReadByInstr:=false;
+      Abstract;
+    End;
+
+
+End.

+ 1125 - 0
compiler/aoptobj.pas

@@ -0,0 +1,1125 @@
+{
+    Copyright (c) 1998-2004 by Jonas Maebe, member of the Free Pascal
+    Development Team
+
+    This unit contains the processor independent assembler optimizer
+    object, base for the dataflow analyzer, peepholeoptimizer and
+    common subexpression elimination objects.
+
+    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 AoptObj;
+
+  {$i fpcdefs.inc}
+
+  { general, processor independent objects for use by the assembler optimizer }
+
+  Interface
+
+    uses
+      globtype,
+      aasmbase,aasmcpu,aasmtai,
+      cclasses,
+      cgbase,cgutils,
+      cpubase,
+      aoptbase,aoptcpub,aoptda;
+
+    { ************************************************************************* }
+    { ********************************* Constants ***************************** }
+    { ************************************************************************* }
+
+    Const
+
+    {Possible register content types}
+      con_Unknown = 0;
+      con_ref = 1;
+      con_const = 2;
+
+    {***************** Types ****************}
+
+    Type
+
+    { ************************************************************************* }
+    { ************************* Some general type definitions ***************** }
+    { ************************************************************************* }
+      TRefCompare = Function(r1, r2: TReference): Boolean;
+      //!!! FIXME
+      TRegArray = Array[byte] of tsuperregister;
+      TRegSet = Set of byte;
+    { possible actions on an operand: read, write or modify (= read & write) }
+      TOpAction = (OpAct_Read, OpAct_Write, OpAct_Modify, OpAct_Unknown);
+
+    { ************************************************************************* }
+    { * Object to hold information on which regiters are in use and which not * }
+    { ************************************************************************* }
+      TUsedRegs = class
+        Constructor create;
+        Constructor create_regset(Const _RegSet: TRegSet);
+
+        Destructor Destroy;override;
+        { update the info with the pairegalloc objects coming after }
+        { p                                                         }
+        Procedure Update(p: Tai);
+        { is Reg currently in use }
+        Function IsUsed(Reg: TRegister): Boolean;
+        { get all the currently used registers }
+        Function GetUsedRegs: TRegSet;
+
+      Private
+
+        UsedRegs: TRegSet;
+      End;
+
+    { ************************************************************************* }
+    { ******************* Contents of the integer registers ******************* }
+    { ************************************************************************* }
+
+     { size of the integer that holds the state number of a register. Can be any }
+     { integer type, so it can be changed to reduce the size of the TContent     }
+     { structure or to improve alignment                                         }
+      TStateInt = Byte;
+
+      TContent = Record
+        { start and end of block instructions that defines the }
+        { content of this register. If Typ = con_const, then   }
+        { Longint(StartMod) = value of the constant)           }
+        StartMod: Tai;
+        { starts at 0, gets increased everytime the register is }
+        { written to                                            }
+        WState: TStateInt;
+        { starts at 0, gets increased everytime the register is read }
+        { from                                                       }
+        RState: TStateInt;
+        { how many instructions starting with StarMod does the block }
+        { consist of                                                 }
+        NrOfMods: Byte;
+        { the type of the content of the register: unknown, memory   }
+        { (variable) or constant                                     }
+        Typ: Byte;
+      End;
+
+      //!!! FIXME
+      TRegContent = Array[byte] Of TContent;
+
+    { ************************************************************************** }
+    { information object with the contents of every register. Every Tai object   }
+    { gets one of these assigned: a pointer to it is stored in the OptInfo field }
+    { ************************************************************************** }
+
+      TPaiProp = class(TAoptBaseCpu)
+        Regs: TRegContent;
+        { info about allocation of general purpose integer registers }
+        UsedRegs: TUsedRegs;
+        { can this instruction be removed? }
+        CanBeRemoved: Boolean;
+
+        Constructor create;
+
+        { checks the whole sequence of which (so regs[which].StartMod and and  }
+        { the next NrOfMods Tai objects) to see whether Reg is used somewhere, }
+        { without it being loaded with something else first                    }
+        Function RegInSequence(Reg, which: TRegister): Boolean;
+        { destroy the contents of a register, as well as those whose contents }
+        { are based on those of that register                                 }
+        Procedure DestroyReg(Reg: TRegister; var InstrSinceLastMod:
+          TInstrSinceLastMod);
+        { if the contents of WhichReg (can be R_NO in case of a constant) are  }
+        { written to memory at the location Ref, the contents of the registers }
+        { that depend on Ref have to be  destroyed                             }
+        Procedure DestroyRefs(Const Ref: TReference; WhichReg: TRegister; var
+          InstrSinceLastMod: TInstrSinceLastMod);
+
+        { an instruction reads from operand o }
+        Procedure ReadOp(const o:toper);
+        { an instruction reads from reference Ref }
+        Procedure ReadRef(Ref: PReference);
+        { an instruction reads from register Reg }
+        Procedure ReadReg(Reg: TRegister);
+
+        { an instruction writes/modifies operand o and this has special     }
+        { side-effects or modifies the contents in such a way that we can't }
+        { simply add this instruction to the sequence of instructions that  }
+        { describe the contents of the operand, so destroy it               }
+        Procedure DestroyOp(const o:Toper; var InstrSinceLastMod:
+          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)                                              }
+        Procedure ModifyReg(reg: TRegister; var InstrSinceLastMod:
+          TInstrSinceLastMod);
+        { 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)                                                           }
+        Procedure IncWState(Reg: TRegister);
+        { increase the read state of a register (call every time a register is }
+        { read from)                                                           }
+        Procedure IncRState(Reg: TRegister);
+        { get the write state of a register }
+        Function GetWState(Reg: TRegister): TStateInt;
+        { get the read state of a register }
+        Function GetRState(Reg: TRegister): TStateInt;
+
+        { get the type of contents of a register }
+        Function GetRegContentType(Reg: TRegister): Byte;
+
+        Destructor Done;
+
+        Private
+
+        Procedure IncState(var s: TStateInt);
+
+        { returns whether the reference Ref is used somewhere in the loading }
+        { sequence Content                                                   }
+        Function RefInSequence(Const Ref: TReference; Content: TContent;
+          RefsEq: TRefCompare): Boolean;
+
+        { returns whether the instruction P reads from and/or writes }
+        { to Reg                                                     }
+        Function RefInInstruction(Const Ref: TReference; p: Tai;
+          RefsEq: TRefCompare): Boolean;
+
+        { returns whether two references with at least one pointing to an array }
+        { may point to the same memory location                                 }
+
+      End;
+
+
+    { ************************************************************************* }
+    { ************************ Label information ****************************** }
+    { ************************************************************************* }
+      TLabelTableItem = Record
+        PaiObj: Tai;
+      End;
+
+    {$ifndef TP}
+      TLabelTable = Array[0..2500000] Of TLabelTableItem;
+    {$else TP}
+      TLabelTable = Array[0..(65520 div sizeof(TLabelTableItem))] Of TLabelTableItem;
+    {$endif TP}
+      PLabelTable = ^TLabelTable;
+      PLabelInfo = ^TLabelInfo;
+      TLabelInfo = Record
+        { the highest and lowest label number occurring in the current code }
+        { fragment                                                          }
+        LowLabel, HighLabel: AWord;
+        LabelDif: AWord;
+        { table that contains the addresses of the Pai_Label objects associated
+          with each label number                                                }
+        LabelTable: PLabelTable;
+      End;
+
+    { ************************************************************************* }
+    { ********** General optimizer object, used to derive others from ********* }
+    { ************************************************************************* }
+
+      TAOptObj = class(TAoptBaseCpu)
+        { the PAasmOutput list this optimizer instance works on }
+        AsmL: TAasmOutput;
+
+        { The labelinfo record contains the addresses of the Tai objects }
+        { that are labels, how many labels there are and the min and max }
+        { label numbers                                                  }
+        LabelInfo: PLabelInfo;
+
+        { Start and end of the block that is currently being optimized }
+        BlockStart, BlockEnd: Tai;
+
+        DFA: TAOptDFA;
+        { _AsmL is the PAasmOutpout list that has to be optimized,     }
+        { _BlockStart and _BlockEnd the start and the end of the block }
+        { that has to be optimized and _LabelInfo a pointer to a       }
+        { TLabelInfo record                                            }
+        Constructor create(_AsmL: TAasmOutput; _BlockStart, _BlockEnd: Tai;
+                           _LabelInfo: PLabelInfo); virtual;
+
+        { processor independent methods }
+
+        { returns true if the label L is found between hp and the next }
+        { instruction                                                  }
+        Function FindLabel(L: TasmLabel; Var hp: Tai): Boolean;
+
+        { inserts new_one between prev and foll in AsmL }
+        Procedure InsertLLItem(prev, foll, new_one: TLinkedListItem);
+
+
+        { If P is a Tai object releveant to the optimizer, P is returned
+          If it is not relevant tot he optimizer, the first object after P
+          that is relevant is returned                                     }
+        Function SkipHead(P: Tai): Tai;
+
+        { returns true if the operands o1 and o2 are completely equal }
+        Function OpsEqual(const o1,o2:toper): Boolean;
+
+        { Returns true if a ait_alloc object for Reg is found in the block
+          of Tai's starting with StartPai and ending with the next "real"
+          instruction                                                      }
+        Function FindRegAlloc(Reg: TRegister; StartPai: Tai): Boolean;
+
+       { traces sucessive jumps to their final destination and sets it, e.g.
+         je l1                je l3
+         <code>               <code>
+         l1:       becomes    l1:
+         je l2                je l3
+         <code>               <code>
+         l2:                  l2:
+         jmp l3               jmp l3
+
+         the level parameter denotes how deeep we have already followed the jump,
+         to avoid endless loops with constructs such as "l5: ; jmp l5"           }
+        function GetFinalDestination(hp: taicpu; level: longint): boolean;
+
+        function getlabelwithsym(sym: tasmlabel): tai;
+
+        { peephole optimizer }
+        procedure PrePeepHoleOpts;
+        procedure PeepHoleOptPass1;
+        procedure PeepHoleOptPass2;
+        procedure PostPeepHoleOpts;
+
+        { processor dependent methods }
+        // if it returns true, perform a "continue"
+        function PeepHoleOptPass1Cpu(var p: tai): boolean; virtual;
+        function PostPeepHoleOptsCpu(var p: tai): boolean; virtual;
+      End;
+
+       Function ArrayRefsEq(const r1, r2: TReference): Boolean;
+
+    { ***************************** Implementation **************************** }
+
+  Implementation
+
+    uses
+      globals,
+      verbose,
+      procinfo;
+
+      { ************************************************************************* }
+      { ******************************** TUsedRegs ****************************** }
+      { ************************************************************************* }
+
+      Constructor TUsedRegs.create;
+      Begin
+        UsedRegs := [];
+      End;
+
+      Constructor TUsedRegs.create_regset(Const _RegSet: TRegSet);
+      Begin
+        UsedRegs := _RegSet;
+      End;
+
+      Procedure TUsedRegs.Update(p: Tai);
+      {updates UsedRegs with the RegAlloc Information coming after P}
+      Begin
+        Repeat
+          While Assigned(p) And
+                ((p.typ in (SkipInstr - [ait_RegAlloc])) or
+                 ((p.typ = ait_label) And
+                  Not(Tai_Label(p).l.is_used))) Do
+               p := Tai(p.next);
+          While Assigned(p) And
+                (p.typ=ait_RegAlloc) Do
+            Begin
+          {!!!!!!!! FIXME
+              if tai_regalloc(p).ratype=ra_alloc then
+                UsedRegs := UsedRegs + [tai_regalloc(p).Reg]
+              else
+                UsedRegs := UsedRegs - [tai_regalloc(p).Reg];
+              p := Tai(p.next);
+          }
+            End;
+        Until Not(Assigned(p)) Or
+              (Not(p.typ in SkipInstr) And
+               Not((p.typ = ait_label) And
+                  Not(Tai_Label(p).l.is_used)));
+      End;
+
+      Function TUsedRegs.IsUsed(Reg: TRegister): Boolean;
+      Begin
+        //!!!!!!!!!!! IsUsed := Reg in UsedRegs
+      End;
+
+      Function TUsedRegs.GetUsedRegs: TRegSet;
+      Begin
+        GetUsedRegs := UsedRegs;
+      End;
+
+      Destructor TUsedRegs.Destroy;
+        Begin
+          inherited destroy;
+        end;
+
+      { ************************************************************************* }
+      { **************************** TPaiProp *********************************** }
+      { ************************************************************************* }
+
+      Constructor TPaiProp.Create;
+        Begin
+        {!!!!!!
+          UsedRegs.Init;
+          CondRegs.init;
+        }
+        {  DirFlag: TFlagContents; I386 specific}
+        End;
+
+      Function TPaiProp.RegInSequence(Reg, which: TRegister): Boolean;
+      Var p: Tai;
+          RegsChecked: TRegSet;
+          content: TContent;
+          Counter: Byte;
+          TmpResult: Boolean;
+      Begin
+      {!!!!!!!!!!1
+        RegsChecked := [];
+        content := regs[which];
+        p := content.StartMod;
+        TmpResult := False;
+        Counter := 1;
+        While Not(TmpResult) And
+              (Counter <= Content.NrOfMods) Do
+          Begin
+            If IsLoadMemReg(p) Then
+              With PInstr(p)^.oper[LoadSrc]^.ref^ Do
+                If (Base = ProcInfo.FramePointer)
+      {$ifdef RefsHaveIndexReg}
+                   And (Index = R_NO)
+      {$endif RefsHaveIndexReg} Then
+                  Begin
+                    RegsChecked := RegsChecked +
+                      [RegMaxSize(PInstr(p)^.oper[LoadDst]^.reg)];
+                    If Reg = RegMaxSize(PInstr(p)^.oper[LoadDst]^.reg) Then
+                      Break;
+                  End
+                Else
+                  Begin
+                    If (Base = Reg) And
+                       Not(Base In RegsChecked)
+                      Then TmpResult := True;
+      {$ifdef RefsHaveIndexReg}
+                    If Not(TmpResult) And
+                       (Index = Reg) And
+                         Not(Index In RegsChecked)
+                      Then TmpResult := True;
+      {$Endif RefsHaveIndexReg}
+                  End
+            Else TmpResult := RegInInstruction(Reg, p);
+            Inc(Counter);
+            GetNextInstruction(p,p)
+          End;
+        RegInSequence := TmpResult
+      }
+      End;
+
+
+      Procedure TPaiProp.DestroyReg(Reg: TRegister; var InstrSinceLastMod:
+                  TInstrSinceLastMod);
+      { Destroys the contents of the register Reg in the PPaiProp p1, as well as }
+      { the contents of registers are loaded with a memory location based on Reg }
+      Var TmpWState, TmpRState: Byte;
+          Counter: TRegister;
+      Begin
+      {!!!!!!!
+        Reg := RegMaxSize(Reg);
+        If (Reg in [LoGPReg..HiGPReg]) Then
+          For Counter := LoGPReg to HiGPReg Do
+            With Regs[Counter] Do
+              If (Counter = reg) Or
+                 ((Typ = Con_Ref) And
+                  RegInSequence(Reg, Counter)) Then
+                Begin
+                  InstrSinceLastMod[Counter] := 0;
+                  IncWState(Counter);
+                  TmpWState := GetWState(Counter);
+                  TmpRState := GetRState(Counter);
+                  FillChar(Regs[Counter], SizeOf(TContent), 0);
+                  WState := TmpWState;
+                  RState := TmpRState
+                End
+      }
+      End;
+
+      Function ArrayRefsEq(const r1, r2: TReference): Boolean;
+      Begin
+      {!!!!!!!!!!
+        ArrayRefsEq := (R1.Offset+R1.OffsetFixup = R2.Offset+R2.OffsetFixup) And
+      {$ifdef refsHaveSegmentReg}
+                       (R1.Segment = R2.Segment) And
+      {$endif}
+                       (R1.Base = R2.Base) And
+                       (R1.Symbol=R2.Symbol);
+      }
+      End;
+
+      Procedure TPaiProp.DestroyRefs(Const Ref: TReference; WhichReg: TRegister;
+                  var InstrSinceLastMod: TInstrSinceLastMod);
+      { destroys all registers which possibly contain a reference to Ref, WhichReg }
+      { is the register whose contents are being written to memory (if this proc   }
+      { is called because of a "mov?? %reg, (mem)" instruction)                    }
+      Var RefsEq: TRefCompare;
+          Counter: TRegister;
+      Begin
+      {!!!!!!!!!!!
+        WhichReg := RegMaxSize(WhichReg);
+        If (Ref.base = procinfo.FramePointer) or
+            Assigned(Ref.Symbol) Then
+          Begin
+            If
+      {$ifdef refsHaveIndexReg}
+               (Ref.Index = R_NO) And
+      {$endif refsHaveIndexReg}
+               (Not(Assigned(Ref.Symbol)) or
+                (Ref.base = R_NO)) Then
+        { local variable which is not an array }
+              RefsEq := {$ifdef fpc}@{$endif}RefsEqual
+            Else
+        { local variable which is an array }
+              RefsEq := {$ifdef fpc}@{$endif}ArrayRefsEq;
+      {write something to a parameter, a local or global variable, so
+         * with uncertain optimizations on:
+            - destroy the contents of registers whose contents have somewhere a
+              "mov?? (Ref), %reg". WhichReg (this is the register whose contents
+              are being written to memory) is not destroyed if it's StartMod is
+              of that form and NrOfMods = 1 (so if it holds ref, but is not a
+              pointer or value based on Ref)
+          * with uncertain optimizations off:
+             - also destroy registers that contain any pointer}
+            For Counter := LoGPReg to HiGPReg Do
+              With Regs[Counter] Do
+                Begin
+                  If (typ = Con_Ref) And
+                     ((Not(cs_UncertainOpts in aktglobalswitches) And
+                       (NrOfMods <> 1)
+                      ) Or
+                      (RefInSequence(Ref,Regs[Counter], RefsEq) And
+                       ((Counter <> WhichReg) Or
+                        ((NrOfMods <> 1) And
+       {StarMod is always of the type ait_instruction}
+                         (PInstr(StartMod)^.oper[0].typ = top_ref) And
+                         RefsEq(PInstr(StartMod)^.oper[0].ref^, Ref)
+                        )
+                       )
+                      )
+                     )
+                    Then
+                      DestroyReg(Counter, InstrSinceLastMod)
+                End
+          End
+        Else
+      {write something to a pointer location, so
+         * with uncertain optimzations on:
+            - do not destroy registers which contain a local/global variable or a
+              parameter, except if DestroyRefs is called because of a "movsl"
+         * with uncertain optimzations off:
+            - destroy every register which contains a memory location
+            }
+            For Counter := LoGPReg to HiGPReg Do
+              With Regs[Counter] Do
+                If (typ = Con_Ref) And
+                   (Not(cs_UncertainOpts in aktglobalswitches) Or
+      {$ifdef x86}
+              {for movsl}
+                    (Ref.Base = R_EDI) Or
+      {$endif}
+              {don't destroy if reg contains a parameter, local or global variable}
+                    Not((NrOfMods = 1) And
+                        (PInstr(StartMod)^.oper[0].typ = top_ref) And
+                        ((PInstr(StartMod)^.oper[0].ref^.base = ProcInfo.FramePointer) Or
+                          Assigned(PInstr(StartMod)^.oper[0].ref^.Symbol)
+                        )
+                       )
+                   )
+                Then DestroyReg(Counter, InstrSinceLastMod)
+      }
+      End;
+
+      Procedure TPaiProp.DestroyAllRegs(var InstrSinceLastMod: TInstrSinceLastMod);
+      Var Counter: TRegister;
+      Begin {initializes/desrtoys all registers}
+      {!!!!!!!!!
+        For Counter := LoGPReg To HiGPReg Do
+          Begin
+            ReadReg(Counter);
+            DestroyReg(Counter, InstrSinceLastMod);
+          End;
+        CondRegs.Init;
+      { FPURegs.Init; }
+      }
+      End;
+
+      Procedure TPaiProp.DestroyOp(const o:Toper; var InstrSinceLastMod:
+                  TInstrSinceLastMod);
+      Begin
+      {!!!!!!!
+        Case o.typ Of
+          top_reg: DestroyReg(o.reg, InstrSinceLastMod);
+          top_ref:
+            Begin
+              ReadRef(o.ref);
+              DestroyRefs(o.ref^, R_NO, InstrSinceLastMod);
+            End;
+          top_symbol:;
+        End;
+      }
+      End;
+
+      Procedure TPaiProp.ReadReg(Reg: TRegister);
+      Begin
+      {!!!!!!!
+        Reg := RegMaxSize(Reg);
+        If Reg in General_Registers Then
+          IncRState(RegMaxSize(Reg))
+      }
+      End;
+
+      Procedure TPaiProp.ReadRef(Ref: PReference);
+      Begin
+      {!!!!!!!
+        If Ref^.Base <> R_NO Then
+          ReadReg(Ref^.Base);
+      {$ifdef refsHaveIndexReg}
+        If Ref^.Index <> R_NO Then
+          ReadReg(Ref^.Index);
+      {$endif}
+      }
+      End;
+
+      Procedure TPaiProp.ReadOp(const o:toper);
+      Begin
+        Case o.typ Of
+          top_reg: ReadReg(o.reg);
+          top_ref: ReadRef(o.ref);
+        else
+          internalerror(200410241);
+        End;
+      End;
+
+      Procedure TPaiProp.ModifyReg(reg: TRegister; Var InstrSinceLastMod:
+                                     TInstrSinceLastMod);
+      Begin
+      {!!!!!!!
+        With Regs[reg] Do
+          If (Typ = Con_Ref)
+            Then
+              Begin
+                IncState(WState);
+       {also store how many instructions are part of the sequence in the first
+        instructions PPaiProp, so it can be easily accessed from within
+        CheckSequence}
+                Inc(NrOfMods, InstrSinceLastMod[Reg]);
+                PPaiProp(StartMod.OptInfo)^.Regs[Reg].NrOfMods := NrOfMods;
+                InstrSinceLastMod[Reg] := 0;
+              End
+            Else
+              DestroyReg(Reg, InstrSinceLastMod);
+      }
+      End;
+
+      Procedure TPaiProp.ModifyOp(const oper: TOper; var InstrSinceLastMod:
+                  TInstrSinceLastMod);
+      Begin
+        If oper.typ = top_reg Then
+          ModifyReg(RegMaxSize(oper.reg),InstrSinceLastMod)
+        Else
+          Begin
+            ReadOp(oper);
+            DestroyOp(oper, InstrSinceLastMod);
+          End
+      End;
+
+      Procedure TPaiProp.IncWState(Reg: TRegister);{$ifdef inl} inline;{$endif inl}
+      Begin
+        //!!!! IncState(Regs[Reg].WState);
+      End;
+
+      Procedure TPaiProp.IncRState(Reg: TRegister);{$ifdef inl} inline;{$endif inl}
+      Begin
+        //!!!! IncState(Regs[Reg].RState);
+      End;
+
+      Function TPaiProp.GetWState(Reg: TRegister): TStateInt; {$ifdef inl} inline;{$endif inl}
+      Begin
+        //!!!! GetWState := Regs[Reg].WState
+      End;
+
+      Function TPaiProp.GetRState(Reg: TRegister): TStateInt; {$ifdef inl} inline;{$endif inl}
+      Begin
+        //!!!! GetRState := Regs[Reg].RState
+      End;
+
+      Function TPaiProp.GetRegContentType(Reg: TRegister): Byte; {$ifdef inl} inline;{$endif inl}
+      Begin
+        //!!!! GetRegContentType := Regs[Reg].typ
+      End;
+
+      Destructor TPaiProp.Done;
+      Begin
+        //!!!! UsedRegs.Done;
+        //!!!! CondRegs.Done;
+      {  DirFlag: TFlagContents; I386 specific}
+      End;
+      { ************************ private TPaiProp stuff ************************* }
+
+      Procedure TPaiProp.IncState(Var s: TStateInt); {$ifdef inl} inline;{$endif inl}
+      Begin
+        If s <> High(TStateInt) Then Inc(s)
+        Else s := 0
+      End;
+
+      Function TPaiProp.RefInInstruction(Const Ref: TReference; p: Tai;
+        RefsEq: TRefCompare): Boolean;
+      Var Count: AWord;
+          TmpResult: Boolean;
+      Begin
+        TmpResult := False;
+        If (p.typ = ait_instruction) Then
+          Begin
+            Count := 0;
+            Repeat
+              If (TInstr(p).oper[Count]^.typ = Top_Ref) Then
+                TmpResult := RefsEq(Ref, PInstr(p)^.oper[Count]^.ref^);
+              Inc(Count);
+            Until (Count = MaxOps) or TmpResult;
+          End;
+        RefInInstruction := TmpResult;
+      End;
+
+      Function TPaiProp.RefInSequence(Const Ref: TReference; Content: TContent;
+        RefsEq: TRefCompare): Boolean;
+      Var p: Tai;
+          Counter: Byte;
+          TmpResult: Boolean;
+      Begin
+        p := Content.StartMod;
+        TmpResult := False;
+        Counter := 1;
+        While Not(TmpResult) And
+              (Counter <= Content.NrOfMods) Do
+          Begin
+            If (p.typ = ait_instruction) And
+               RefInInstruction(Ref, p, {$ifdef fpc}@{$endif}references_equal)
+              Then TmpResult := True;
+            Inc(Counter);
+            GetNextInstruction(p,p)
+          End;
+        RefInSequence := TmpResult
+      End;
+
+      { ************************************************************************* }
+      { ***************************** TAoptObj ********************************** }
+      { ************************************************************************* }
+
+      Constructor TAoptObj.create(_AsmL: TAasmOutput; _BlockStart, _BlockEnd: Tai;
+                                  _LabelInfo: PLabelInfo);
+      Begin
+        AsmL := _AsmL;
+        BlockStart := _BlockStart;
+        BlockEnd := _BlockEnd;
+        LabelInfo := _LabelInfo
+      End;
+
+      Function TAOptObj.FindLabel(L: TasmLabel; Var hp: Tai): Boolean;
+      Var TempP: Tai;
+      Begin
+        TempP := hp;
+        While Assigned(TempP) and
+             (TempP.typ In SkipInstr + [ait_label]) Do
+          If (TempP.typ <> ait_Label) Or
+             (Tai_label(TempP).l <> L)
+            Then GetNextInstruction(TempP, TempP)
+            Else
+              Begin
+                hp := TempP;
+                FindLabel := True;
+                exit
+              End;
+        FindLabel := False;
+      End;
+
+      Procedure TAOptObj.InsertLLItem(prev, foll, new_one : TLinkedListItem);
+      Begin
+        If Assigned(prev) Then
+          If Assigned(foll) Then
+            Begin
+              If Assigned(new_one) Then
+                Begin
+                  new_one.previous := prev;
+                  new_one.next := foll;
+                  prev.next := new_one;
+                  foll.previous := new_one;
+                  { should we update line information? }
+                  if (not (tai(new_one).typ in SkipLineInfo)) and
+                     (not (tai(foll).typ in SkipLineInfo)) then
+                    Tailineinfo(new_one).fileinfo := Tailineinfo(foll).fileinfo
+                End
+            End
+          Else AsmL.Concat(new_one)
+        Else If Assigned(Foll) Then AsmL.Insert(new_one)
+      End;
+
+
+      Function TAOptObj.SkipHead(P: Tai): Tai;
+      Var OldP: Tai;
+      Begin
+        Repeat
+          OldP := P;
+          If (P.typ in SkipInstr) Or
+             ((P.typ = ait_marker) And
+              (Tai_Marker(P).Kind = AsmBlockEnd)) Then
+            GetNextInstruction(P, P)
+          Else If ((P.Typ = Ait_Marker) And
+              (Tai_Marker(P).Kind = NoPropInfoStart)) Then
+       { a marker of the type NoPropInfoStart can't be the first instruction of a }
+       { paasmoutput list                                                         }
+            GetNextInstruction(Tai(P.Previous),P);
+          If (P.Typ = Ait_Marker) And
+             (Tai_Marker(P).Kind = AsmBlockStart) Then
+            Begin
+              P := Tai(P.Next);
+              While (P.typ <> Ait_Marker) Or
+                    (Tai_Marker(P).Kind <> AsmBlockEnd) Do
+                P := Tai(P.Next)
+            End;
+          Until P = OldP;
+        SkipHead := P;
+      End;
+
+      Function TAOptObj.OpsEqual(const o1,o2:toper): Boolean;
+      Begin
+        if o1.typ=o2.typ then
+          Case o1.typ Of
+            Top_Reg :
+              OpsEqual:=o1.reg=o2.reg;
+            Top_Ref :
+              OpsEqual := references_equal(o1.ref^, o2.ref^);
+            Top_Const :
+              OpsEqual:=o1.val=o2.val;
+            Top_None :
+              OpsEqual := True
+            else OpsEqual := False
+          End;
+      End;
+
+      Function TAOptObj.FindRegAlloc(Reg: TRegister; StartPai: Tai): Boolean;
+      Begin
+        FindRegAlloc:=False;
+        Repeat
+          While Assigned(StartPai) And
+                ((StartPai.typ in (SkipInstr - [ait_regAlloc])) Or
+                 ((StartPai.typ = ait_label) and
+                  Not(Tai_Label(StartPai).l.Is_Used))) Do
+            StartPai := Tai(StartPai.Next);
+          If Assigned(StartPai) And
+             (StartPai.typ = ait_regAlloc) and (tai_regalloc(StartPai).ratype=ra_alloc) Then
+            Begin
+              if tai_regalloc(StartPai).Reg = Reg then
+               begin
+                 FindRegAlloc:=true;
+                 exit;
+               end;
+              StartPai := Tai(StartPai.Next);
+            End
+          else
+            exit;
+        Until false;
+      End;
+
+
+    function SkipLabels(hp: tai; var hp2: tai): boolean;
+      {skips all labels and returns the next "real" instruction}
+      begin
+        while assigned(hp.next) and
+              (tai(hp.next).typ in SkipInstr + [ait_label,ait_align]) Do
+          hp := tai(hp.next);
+        if assigned(hp.next) then
+          begin
+            SkipLabels := True;
+            hp2 := tai(hp.next)
+          end
+        else
+          begin
+            hp2 := hp;
+            SkipLabels := False
+          end;
+      end;
+
+
+    function FindAnyLabel(hp: tai; var l: tasmlabel): Boolean;
+      begin
+        FindAnyLabel := false;
+        while assigned(hp.next) and
+              (tai(hp.next).typ in (SkipInstr+[ait_align])) Do
+          hp := tai(hp.next);
+        if assigned(hp.next) and
+           (tai(hp.next).typ = ait_label) then
+          begin
+            FindAnyLabel := true;
+            l := tai_label(hp.next).l;
+          end
+      end;
+
+
+{$ifopt r+}
+{$define rangewason}
+{$r-}
+{$endif}
+    function tAOptObj.getlabelwithsym(sym: tasmlabel): tai;
+      begin
+        if (sym.labelnr >= labelinfo^.lowlabel) and
+           (sym.labelnr <= labelinfo^.highlabel) then   { range check, a jump can go past an assembler block! }
+          getlabelwithsym := labelinfo^.labeltable^[sym.labelnr-labelinfo^.lowlabel].paiobj
+        else
+          getlabelwithsym := nil;
+      end;
+{$ifdef rangewason}
+{$r+}
+{$undef rangewason}
+{$endif}
+
+    function TAOptObj.GetFinalDestination(hp: taicpu; level: longint): boolean;
+      {traces sucessive jumps to their final destination and sets it, e.g.
+       je l1                je l3
+       <code>               <code>
+       l1:       becomes    l1:
+       je l2                je l3
+       <code>               <code>
+       l2:                  l2:
+       jmp l3               jmp l3
+
+       the level parameter denotes how deeep we have already followed the jump,
+       to avoid endless loops with constructs such as "l5: ; jmp l5"           }
+
+      var p1, p2: tai;
+          l: tasmlabel;
+
+      begin
+        GetfinalDestination := false;
+        if level > 20 then
+          exit;
+        p1 := getlabelwithsym(tasmlabel(hp.oper[0]^.ref^.symbol));
+        if assigned(p1) then
+          begin
+            SkipLabels(p1,p1);
+            if (tai(p1).typ = ait_instruction) and
+               (taicpu(p1).is_jmp) then
+              if { the next instruction after the label where the jump hp arrives}
+                 { is unconditional or of the same type as hp, so continue       }
+                 (((taicpu(p1).opcode = aopt_uncondjmp) and
+                   (taicpu(p1).oper[0]^.typ = top_ref) and
+                   (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)}
+                 (conditions_equal(taicpu(p1).condition,inverse_cond(hp.condition)) and
+                  SkipLabels(p1,p2) and
+                  (p2.typ = ait_instruction) and
+                  (taicpu(p2).is_jmp) and
+                  (((taicpu(p2).opcode = aopt_uncondjmp) and
+                    (taicpu(p2).oper[0]^.typ = top_ref) and
+                    (assigned(taicpu(p2).oper[0]^.ref^.symbol)) and
+                    (taicpu(p2).oper[0]^.ref^.symbol is TAsmLabel)) or
+                   (conditions_equal(taicpu(p2).condition,hp.condition))) and
+                  SkipLabels(p1,p1)) then
+                begin
+                  { quick check for loops of the form "l5: ; jmp l5 }
+                  if (tasmlabel(taicpu(p1).oper[0]^.ref^.symbol).labelnr =
+                       tasmlabel(hp.oper[0]^.ref^.symbol).labelnr) then
+                    exit;
+                  if not GetFinalDestination(taicpu(p1),succ(level)) then
+                    exit;
+                  tasmlabel(hp.oper[0]^.ref^.symbol).decrefs;
+                  hp.oper[0]^.ref^.symbol:=taicpu(p1).oper[0]^.ref^.symbol;
+                  tasmlabel(hp.oper[0]^.ref^.symbol).increfs;
+                end
+              else
+                if conditions_equal(taicpu(p1).condition,inverse_cond(hp.condition)) then
+                  if not FindAnyLabel(p1,l) then
+                    begin
+      {$ifdef finaldestdebug}
+                      insertllitem(asml,p1,p1.next,tai_comment.Create(
+                        strpnew('previous label inserted'))));
+      {$endif finaldestdebug}
+                      objectlibrary.getjumplabel(l);
+                      insertllitem(p1,p1.next,tai_label.Create(l));
+                      tasmlabel(taicpu(hp).oper[0]^.ref^.symbol).decrefs;
+                      hp.oper[0]^.ref^.symbol := l;
+                      l.increfs;
+      {               this won't work, since the new label isn't in the labeltable }
+      {               so it will fail the rangecheck. Labeltable should become a   }
+      {               hashtable to support this:                                   }
+      {               GetFinalDestination(asml, hp);                               }
+                    end
+                  else
+                    begin
+      {$ifdef finaldestdebug}
+                      insertllitem(asml,p1,p1.next,tai_comment.Create(
+                        strpnew('next label reused'))));
+      {$endif finaldestdebug}
+                      l.increfs;
+                      hp.oper[0]^.ref^.symbol := l;
+                      if not GetFinalDestination(hp,succ(level)) then
+                        exit;
+                    end;
+          end;
+        GetFinalDestination := true;
+      end;
+
+
+    procedure TAOptObj.PrePeepHoleOpts;
+      begin
+      end;
+
+
+    procedure TAOptObj.PeepHoleOptPass1;
+      var
+        p,hp1,hp2 : tai;
+      begin
+        p := BlockStart;
+        //!!!! UsedRegs := [];
+        while (p <> BlockEnd) Do
+          begin
+            //!!!! UpDateUsedRegs(UsedRegs, tai(p.next));
+            if PeepHoleOptPass1Cpu(p) then
+              continue;
+            case p.Typ Of
+              ait_instruction:
+                begin
+                  { Handle Jmp Optimizations }
+                  if taicpu(p).is_jmp then
+                    begin
+                      { the following if-block removes all code between a jmp and the next label,
+                        because it can never be executed
+                      }
+                      if (taicpu(p).opcode = aopt_uncondjmp) and
+                         (taicpu(p).oper[0]^.typ = top_ref) and
+                         (assigned(taicpu(p).oper[0]^.ref^.symbol)) and
+                         (taicpu(p).oper[0]^.ref^.symbol is TAsmLabel) then
+                        begin
+                          while GetNextInstruction(p, hp1) and
+                                (hp1.typ <> ait_label) do
+                            if not(hp1.typ in ([ait_label,ait_align]+skipinstr)) then
+                              begin
+                                asml.remove(hp1);
+                                hp1.free;
+                              end
+                            else break;
+                          end;
+                      { remove jumps to a label coming right after them }
+                      if GetNextInstruction(p, hp1) then
+                        begin
+                          if FindLabel(tasmlabel(taicpu(p).oper[0]^.ref^.symbol), hp1) and
+        {$warning FIXME removing the first instruction fails}
+                              (p<>blockstart) then
+                            begin
+                              hp2:=tai(hp1.next);
+                              asml.remove(p);
+                              p.free;
+                              p:=hp2;
+                              continue;
+                            end
+                          else
+                            begin
+                              if hp1.typ = ait_label then
+                                SkipLabels(hp1,hp1);
+                              if (tai(hp1).typ=ait_instruction) and
+                                  (taicpu(hp1).opcode=aopt_uncondjmp) and
+                                  (taicpu(hp1).oper[0]^.typ = top_ref) and
+                                  (assigned(taicpu(hp1).oper[0]^.ref^.symbol)) and
+                                  (taicpu(hp1).oper[0]^.ref^.symbol is TAsmLabel) and
+                                  GetNextInstruction(hp1, hp2) and
+                                  FindLabel(tasmlabel(taicpu(p).oper[0]^.ref^.symbol), hp2) then
+                                begin
+                                  if taicpu(p).opcode=aopt_condjmp then
+                                    begin
+                                      taicpu(p).condition:=inverse_cond(taicpu(p).condition);
+                                      tai_label(hp2).l.decrefs;
+                                      taicpu(p).oper[0]^.ref^.symbol:=taicpu(hp1).oper[0]^.ref^.symbol;
+                                      taicpu(p).oper[0]^.ref^.symbol.increfs;
+{$ifdef SPARC}
+                                      hp2:=tai(hp1.next);
+                                      asml.remove(hp2);
+                                      hp2.free;
+{$endif SPARC}
+                                      asml.remove(hp1);
+                                      hp1.free;
+                                      GetFinalDestination(taicpu(p),0);
+                                    end
+                                  else
+                                    begin
+                                      GetFinalDestination(taicpu(p),0);
+                                      p:=tai(p.next);
+                                      continue;
+                                    end;
+                                end
+                              else
+                                GetFinalDestination(taicpu(p),0);
+                            end;
+                        end;
+                    end
+                  else
+                  { All other optimizes }
+                    begin
+                    end; { if is_jmp }
+                end;
+            end;
+            //!!!!!!!! updateUsedRegs(UsedRegs,p);
+            p:=tai(p.next);
+          end;
+      end;
+
+
+    procedure TAOptObj.PeepHoleOptPass2;
+      begin
+      end;
+
+
+    procedure TAOptObj.PostPeepHoleOpts;
+      var
+        p: tai;
+      begin
+        p := BlockStart;
+        //!!!! UsedRegs := [];
+        while (p <> BlockEnd) Do
+          begin
+            //!!!! UpDateUsedRegs(UsedRegs, tai(p.next));
+            if PostPeepHoleOptsCpu(p) then
+              continue;
+            //!!!!!!!! updateUsedRegs(UsedRegs,p);
+            p:=tai(p.next);
+          end;
+      end;
+
+
+    function TAOptObj.PeepHoleOptPass1Cpu(var p: tai): boolean;
+      begin
+        result := false;
+      end;
+
+
+    function TAOptObj.PostPeepHoleOptsCpu(var p: tai): boolean;
+      begin
+        result := false;
+      end;
+
+End.

+ 2399 - 0
compiler/arm/aasmcpu.pas

@@ -0,0 +1,2399 @@
+{
+    Copyright (c) 2003 by Florian Klaempfl
+
+    Contains the assembler object for the ARM
+
+    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,
+  symtype,
+  cpubase,cpuinfo,cgbase,cgutils;
+
+    const
+      { "mov reg,reg" source operand number }
+      O_MOV_SOURCE = 1;
+      { "mov reg,reg" source operand number }
+      O_MOV_DEST = 0;
+
+      { Operand types }
+      OT_NONE      = $00000000;
+
+      OT_BITS8     = $00000001;  { size, and other attributes, of the operand  }
+      OT_BITS16    = $00000002;
+      OT_BITS32    = $00000004;
+      OT_BITS64    = $00000008;  { FPU only  }
+      OT_BITS80    = $00000010;
+      OT_FAR       = $00000020;  { this means 16:16 or 16:32, like in CALL/JMP }
+      OT_NEAR      = $00000040;
+      OT_SHORT     = $00000080;
+      OT_BITSTINY  = $00000100;  { fpu constant }
+      OT_BITSSHIFTER =
+                     $00000200;
+
+      OT_SIZE_MASK = $000003FF;  { all the size attributes  }
+      OT_NON_SIZE  = longint(not OT_SIZE_MASK);
+
+      OT_SIGNED    = $00000100;  { the operand need to be signed -128-127 }
+
+      OT_TO        = $00000200;  { operand is followed by a colon  }
+                                 { reverse effect in FADD, FSUB &c  }
+      OT_COLON     = $00000400;
+
+      OT_SHIFTEROP = $00000800;
+      OT_REGISTER  = $00001000;
+      OT_IMMEDIATE = $00002000;
+      OT_REGLIST   = $00008000;
+      OT_IMM8      = $00002001;
+      OT_IMM24     = $00002002;
+      OT_IMM32     = $00002004;
+      OT_IMM64     = $00002008;
+      OT_IMM80     = $00002010;
+      OT_IMMTINY   = $00002100;
+      OT_IMMSHIFTER= $00002200;
+      OT_IMMEDIATE24 = OT_IMM24;
+      OT_SHIFTIMM  = OT_SHIFTEROP or OT_IMMSHIFTER;
+      OT_SHIFTIMMEDIATE = OT_SHIFTIMM;
+      OT_IMMEDIATESHIFTER = OT_IMMSHIFTER;
+
+      OT_IMMEDIATEFPU = OT_IMMTINY;
+
+      OT_REGMEM    = $00200000;  { for r/m, ie EA, operands  }
+      OT_REGNORM   = $00201000;  { 'normal' reg, qualifies as EA  }
+      OT_REG8      = $00201001;
+      OT_REG16     = $00201002;
+      OT_REG32     = $00201004;
+      OT_REG64     = $00201008;
+      OT_VREG      = $00201010;  { vector register }
+      OT_MEMORY    = $00204000;  { register number in 'basereg'  }
+      OT_MEM8      = $00204001;
+      OT_MEM16     = $00204002;
+      OT_MEM32     = $00204004;
+      OT_MEM64     = $00204008;
+      OT_MEM80     = $00204010;
+      { word/byte load/store }
+      OT_AM2       = $00010000;
+      { misc ld/st operations }
+      OT_AM3       = $00020000;
+      { multiple ld/st operations }
+      OT_AM4       = $00040000;
+      { co proc. ld/st operations }
+      OT_AM5       = $00080000;
+      OT_AMMASK    = $000f0000;
+
+      OT_MEMORYAM2 = OT_MEMORY or OT_AM2;
+      OT_MEMORYAM3 = OT_MEMORY or OT_AM3;
+      OT_MEMORYAM4 = OT_MEMORY or OT_AM4;
+      OT_MEMORYAM5 = OT_MEMORY or OT_AM5;
+
+      OT_FPUREG    = $01000000;  { floating point stack registers  }
+      OT_REG_SMASK = $00070000;  { special register operands: these may be treated differently  }
+                                 { a mask for the following  }
+
+      OT_MEM_OFFS  = $00604000;  { special type of EA  }
+                                 { simple [address] offset  }
+      OT_ONENESS   = $00800000;  { special type of immediate operand  }
+                                 { so UNITY == IMMEDIATE | ONENESS  }
+      OT_UNITY     = $00802000;  { for shift/rotate instructions  }
+
+      instabentries = {$i armnop.inc}
+
+      maxinfolen = 5;
+
+      IF_NONE   = $00000000;
+
+      IF_ARMMASK    = $000F0000;
+      IF_ARM7       = $00070000;
+      IF_FPMASK     = $00F00000;
+      IF_FPA        = $00100000;
+
+      { if the instruction can change in a second pass }
+      IF_PASS2  = longint($80000000);
+
+    type
+      TInsTabCache=array[TasmOp] of longint;
+      PInsTabCache=^TInsTabCache;
+
+      tinsentry = record
+        opcode  : tasmop;
+        ops     : byte;
+        optypes : array[0..3] of longint;
+        code    : array[0..maxinfolen] of char;
+        flags   : longint;
+      end;
+
+      pinsentry=^tinsentry;
+
+    const
+      InsTab : array[0..instabentries-1] of TInsEntry={$i armtab.inc}
+
+    var
+      InsTabCache : PInsTabCache;
+
+    type
+      taicpu = class(tai_cpu_abstract)
+         oppostfix : TOpPostfix;
+         roundingmode : troundingmode;
+         procedure loadshifterop(opidx:longint;const so:tshifterop);
+         procedure loadregset(opidx:longint;const s:tcpuregisterset);
+         constructor op_none(op : tasmop);
+
+         constructor op_reg(op : tasmop;_op1 : tregister);
+         constructor op_const(op : tasmop;_op1 : longint);
+
+         constructor op_reg_reg(op : tasmop;_op1,_op2 : tregister);
+         constructor op_reg_ref(op : tasmop;_op1 : tregister;const _op2 : treference);
+         constructor op_reg_const(op:tasmop; _op1: tregister; _op2: aint);
+
+         constructor op_ref_regset(op:tasmop; _op1: treference; _op2: tcpuregisterset);
+
+         constructor op_reg_reg_reg(op : tasmop;_op1,_op2,_op3 : tregister);
+         constructor op_reg_reg_const(op : tasmop;_op1,_op2 : tregister; _op3: aint);
+         constructor op_reg_reg_sym_ofs(op : tasmop;_op1,_op2 : tregister; _op3: tasmsymbol;_op3ofs: longint);
+         constructor op_reg_reg_ref(op : tasmop;_op1,_op2 : tregister; const _op3: treference);
+         constructor op_reg_reg_shifterop(op : tasmop;_op1,_op2 : tregister;_op3 : tshifterop);
+         { SFM/LFM }
+         constructor op_reg_const_ref(op : tasmop;_op1 : tregister;_op2 : aint;_op3 : treference);
+
+         { *M*LL }
+         constructor op_reg_reg_reg_reg(op : tasmop;_op1,_op2,_op3,_op4 : tregister);
+
+         { this is for Jmp instructions }
+         constructor op_cond_sym(op : tasmop;cond:TAsmCond;_op1 : tasmsymbol);
+
+         constructor op_sym(op : tasmop;_op1 : tasmsymbol);
+         constructor op_sym_ofs(op : tasmop;_op1 : tasmsymbol;_op1ofs:longint);
+         constructor op_reg_sym_ofs(op : tasmop;_op1 : tregister;_op2:tasmsymbol;_op2ofs : longint);
+         constructor op_sym_ofs_ref(op : tasmop;_op1 : tasmsymbol;_op1ofs:longint;const _op2 : treference);
+
+         function is_same_reg_move(regtype: Tregistertype):boolean; override;
+
+         function spilling_get_operation_type(opnr: longint): topertype;override;
+
+         { assembler }
+      public
+         { the next will reset all instructions that can change in pass 2 }
+         procedure ResetPass1;
+         procedure ResetPass2;
+         function  CheckIfValid:boolean;
+         function GetString:string;
+         function Pass1(offset:longint):longint;override;
+         procedure Pass2(objdata:TAsmObjectdata);override;
+      protected
+         procedure ppuloadoper(ppufile:tcompilerppufile;var o:toper);override;
+         procedure ppuwriteoper(ppufile:tcompilerppufile;const o:toper);override;
+         procedure ppubuildderefimploper(var o:toper);override;
+         procedure ppuderefoper(var o:toper);override;
+      private
+         { next fields are filled in pass1, so pass2 is faster }
+         inssize   : shortint;
+         insoffset : longint;
+         LastInsOffset : longint; { need to be public to be reset }
+         insentry  : PInsEntry;
+         function  InsEnd:longint;
+         procedure create_ot;
+         function  Matches(p:PInsEntry):longint;
+         function  calcsize(p:PInsEntry):shortint;
+         procedure gencode(objdata:TAsmObjectData);
+         function  NeedAddrPrefix(opidx:byte):boolean;
+         procedure Swapoperands;
+         function  FindInsentry:boolean;
+      end;
+
+      tai_align = class(tai_align_abstract)
+        { nothing to add }
+      end;
+
+    function spilling_create_load(const ref:treference;r:tregister): tai;
+    function spilling_create_store(r:tregister; const ref:treference): tai;
+
+    function setoppostfix(i : taicpu;pf : toppostfix) : taicpu;
+    function setroundingmode(i : taicpu;rm : troundingmode) : taicpu;
+    function setcondition(i : taicpu;c : tasmcond) : taicpu;
+
+    { inserts pc relative symbols at places where they are reachable }
+    procedure insertpcrelativedata(list,listtoinsert : taasmoutput);
+
+    procedure InitAsm;
+    procedure DoneAsm;
+
+
+implementation
+
+  uses
+    cutils,rgobj,itcpugas;
+
+
+    procedure taicpu.loadshifterop(opidx:longint;const so:tshifterop);
+      begin
+        allocate_oper(opidx+1);
+        with oper[opidx]^ do
+          begin
+            if typ<>top_shifterop then
+              begin
+                clearop(opidx);
+                new(shifterop);
+              end;
+            shifterop^:=so;
+            typ:=top_shifterop;
+            if assigned(add_reg_instruction_hook) then
+              add_reg_instruction_hook(self,shifterop^.rs);
+          end;
+      end;
+
+
+    procedure taicpu.loadregset(opidx:longint;const s:tcpuregisterset);
+      var
+        i : byte;
+      begin
+        allocate_oper(opidx+1);
+        with oper[opidx]^ do
+         begin
+           if typ<>top_regset then
+             clearop(opidx);
+           new(regset);
+           regset^:=s;
+           typ:=top_regset;
+           for i:=RS_R0 to RS_R15 do
+             begin
+               if assigned(add_reg_instruction_hook) and (i in regset^) then
+                 add_reg_instruction_hook(self,newreg(R_INTREGISTER,i,R_SUBWHOLE));
+             end;
+         end;
+      end;
+
+
+{*****************************************************************************
+                                 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_const(op : tasmop;_op1 : longint);
+      begin
+         inherited create(op);
+         ops:=1;
+         loadconst(0,aint(_op1));
+      end;
+
+
+    constructor taicpu.op_reg_reg(op : tasmop;_op1,_op2 : tregister);
+      begin
+         inherited create(op);
+         ops:=2;
+         loadreg(0,_op1);
+         loadreg(1,_op2);
+      end;
+
+
+    constructor taicpu.op_reg_const(op:tasmop; _op1: tregister; _op2: aint);
+      begin
+         inherited create(op);
+         ops:=2;
+         loadreg(0,_op1);
+         loadconst(1,aint(_op2));
+      end;
+
+
+    constructor taicpu.op_ref_regset(op:tasmop; _op1: treference; _op2: tcpuregisterset);
+      begin
+         inherited create(op);
+         ops:=2;
+         loadref(0,_op1);
+         loadregset(1,_op2);
+      end;
+
+
+    constructor taicpu.op_reg_ref(op : tasmop;_op1 : tregister;const _op2 : treference);
+      begin
+         inherited create(op);
+         ops:=2;
+         loadreg(0,_op1);
+         loadref(1,_op2);
+      end;
+
+
+    constructor taicpu.op_reg_reg_reg(op : tasmop;_op1,_op2,_op3 : tregister);
+      begin
+         inherited create(op);
+         ops:=3;
+         loadreg(0,_op1);
+         loadreg(1,_op2);
+         loadreg(2,_op3);
+      end;
+
+
+    constructor taicpu.op_reg_reg_reg_reg(op : tasmop;_op1,_op2,_op3,_op4 : tregister);
+      begin
+         inherited create(op);
+         ops:=4;
+         loadreg(0,_op1);
+         loadreg(1,_op2);
+         loadreg(2,_op3);
+         loadreg(3,_op4);
+      end;
+
+
+     constructor taicpu.op_reg_reg_const(op : tasmop;_op1,_op2 : tregister; _op3: aint);
+       begin
+         inherited create(op);
+         ops:=3;
+         loadreg(0,_op1);
+         loadreg(1,_op2);
+         loadconst(2,aint(_op3));
+      end;
+
+
+    constructor taicpu.op_reg_const_ref(op : tasmop;_op1 : tregister;_op2 : aint;_op3 : treference);
+      begin
+         inherited create(op);
+         ops:=3;
+         loadreg(0,_op1);
+         loadconst(1,_op2);
+         loadref(2,_op3);
+      end;
+
+
+     constructor taicpu.op_reg_reg_sym_ofs(op : tasmop;_op1,_op2 : tregister; _op3: tasmsymbol;_op3ofs: longint);
+       begin
+         inherited create(op);
+         ops:=3;
+         loadreg(0,_op1);
+         loadreg(1,_op2);
+         loadsymbol(0,_op3,_op3ofs);
+      end;
+
+
+     constructor taicpu.op_reg_reg_ref(op : tasmop;_op1,_op2 : tregister; const _op3: treference);
+       begin
+         inherited create(op);
+         ops:=3;
+         loadreg(0,_op1);
+         loadreg(1,_op2);
+         loadref(2,_op3);
+      end;
+
+
+     constructor taicpu.op_reg_reg_shifterop(op : tasmop;_op1,_op2 : tregister;_op3 : tshifterop);
+      begin
+         inherited create(op);
+         ops:=3;
+         loadreg(0,_op1);
+         loadreg(1,_op2);
+         loadshifterop(2,_op3);
+      end;
+
+
+    constructor taicpu.op_cond_sym(op : tasmop;cond:TAsmCond;_op1 : tasmsymbol);
+      begin
+         inherited create(op);
+         condition:=cond;
+         ops:=1;
+         loadsymbol(0,_op1,0);
+      end;
+
+
+    constructor taicpu.op_sym(op : tasmop;_op1 : tasmsymbol);
+      begin
+         inherited create(op);
+         ops:=1;
+         loadsymbol(0,_op1,0);
+      end;
+
+
+    constructor taicpu.op_sym_ofs(op : tasmop;_op1 : tasmsymbol;_op1ofs:longint);
+      begin
+         inherited create(op);
+         ops:=1;
+         loadsymbol(0,_op1,_op1ofs);
+      end;
+
+
+     constructor taicpu.op_reg_sym_ofs(op : tasmop;_op1 : tregister;_op2:tasmsymbol;_op2ofs : longint);
+      begin
+         inherited create(op);
+         ops:=2;
+         loadreg(0,_op1);
+         loadsymbol(1,_op2,_op2ofs);
+      end;
+
+
+    constructor taicpu.op_sym_ofs_ref(op : tasmop;_op1 : tasmsymbol;_op1ofs:longint;const _op2 : treference);
+      begin
+         inherited create(op);
+         ops:=2;
+         loadsymbol(0,_op1,_op1ofs);
+         loadref(1,_op2);
+      end;
+
+
+    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
+                (condition=C_None) and
+                (ops=2) and
+                (oper[0]^.typ=top_reg) and
+                (oper[1]^.typ=top_reg) and
+                (oper[0]^.reg=oper[1]^.reg);
+      end;
+
+
+    function spilling_create_load(const ref:treference;r:tregister): tai;
+      begin
+        case getregtype(r) of
+          R_INTREGISTER :
+            result:=taicpu.op_reg_ref(A_LDR,r,ref);
+          R_FPUREGISTER :
+            { use lfm because we don't know the current internal format
+              and avoid exceptions
+            }
+            result:=taicpu.op_reg_const_ref(A_LFM,r,1,ref);
+          else
+            internalerror(200401041);
+        end;
+      end;
+
+
+    function spilling_create_store(r:tregister; const ref:treference): tai;
+      begin
+        case getregtype(r) of
+          R_INTREGISTER :
+            result:=taicpu.op_reg_ref(A_STR,r,ref);
+          R_FPUREGISTER :
+            { use sfm because we don't know the current internal format
+              and avoid exceptions
+            }
+            result:=taicpu.op_reg_const_ref(A_SFM,r,1,ref);
+          else
+            internalerror(200401041);
+        end;
+      end;
+
+
+    function taicpu.spilling_get_operation_type(opnr: longint): topertype;
+      begin
+        case opcode of
+          A_ADC,A_ADD,A_AND,
+          A_EOR,A_CLZ,
+          A_LDR,A_LDRB,A_LDRBT,A_LDRH,A_LDRSB,
+          A_LDRSH,A_LDRT,
+          A_MOV,A_MVN,A_MLA,A_MUL,
+          A_ORR,A_RSB,A_RSC,A_SBC,A_SUB,
+          A_SWP,A_SWPB,
+          A_LDF,A_FLT,A_FIX,
+          A_ADF,A_DVF,A_FDV,A_FML,
+          A_RFS,A_RFC,A_RDF,
+          A_RMF,A_RPW,A_RSF,A_SUF,A_ABS,A_ACS,A_ASN,A_ATN,A_COS,
+          A_EXP,A_LOG,A_LGN,A_MVF,A_MNF,A_FRD,A_MUF,A_POL,A_RND,A_SIN,A_SQT,A_TAN,
+          A_LFM:
+            if opnr=0 then
+              result:=operand_write
+            else
+              result:=operand_read;
+          A_BIC,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:
+            result:=operand_read;
+          A_SMLAL,A_UMLAL:
+            if opnr in [0,1] then
+              result:=operand_readwrite
+            else
+              result:=operand_read;
+           A_SMULL,A_UMULL:
+            if opnr in [0,1] then
+              result:=operand_write
+            else
+              result:=operand_read;
+          A_STR,A_STRB,A_STRBT,
+          A_STRH,A_STRT,A_STF,A_SFM:
+            { important is what happens with the involved registers }
+            if opnr=0 then
+              result := operand_read
+            else
+              { check for pre/post indexed }
+              result := operand_read;
+          else
+            internalerror(200403151);
+        end;
+      end;
+
+
+    procedure BuildInsTabCache;
+      var
+        i : longint;
+      begin
+        new(instabcache);
+        FillChar(instabcache^,sizeof(tinstabcache),$ff);
+        i:=0;
+        while (i<InsTabEntries) do
+          begin
+            if InsTabCache^[InsTab[i].Opcode]=-1 then
+              InsTabCache^[InsTab[i].Opcode]:=i;
+            inc(i);
+          end;
+      end;
+
+
+    procedure InitAsm;
+      begin
+        if not assigned(instabcache) then
+          BuildInsTabCache;
+      end;
+
+
+    procedure DoneAsm;
+      begin
+        if assigned(instabcache) then
+          begin
+            dispose(instabcache);
+            instabcache:=nil;
+          end;
+      end;
+
+
+    function setoppostfix(i : taicpu;pf : toppostfix) : taicpu;
+      begin
+        i.oppostfix:=pf;
+        result:=i;
+      end;
+
+
+    function setroundingmode(i : taicpu;rm : troundingmode) : taicpu;
+      begin
+        i.roundingmode:=rm;
+        result:=i;
+      end;
+
+
+    function setcondition(i : taicpu;c : tasmcond) : taicpu;
+      begin
+        i.condition:=c;
+        result:=i;
+      end;
+
+
+    procedure insertpcrelativedata(list,listtoinsert : taasmoutput);
+      var
+        curpos : longint;
+        lastpos : longint;
+        curop : longint;
+        curtai : tai;
+        curdatatai,hp : tai;
+        curdata : taasmoutput;
+        l : tasmlabel;
+      begin
+        curdata:=taasmoutput.create;
+        lastpos:=-1;
+        curpos:=0;
+        curtai:=tai(list.first);
+        while assigned(curtai) do
+          begin
+            { instruction? }
+            if curtai.typ=ait_instruction then
+              begin
+                { walk through all operand of the instruction }
+                for curop:=0 to taicpu(curtai).ops-1 do
+                  begin
+                    { reference? }
+                    if (taicpu(curtai).oper[curop]^.typ=top_ref) then
+                      begin
+                        { pc relative symbol? }
+                        curdatatai:=tai(taicpu(curtai).oper[curop]^.ref^.symboldata);
+                        if assigned(curdatatai) then
+                          begin
+                            { if yes, insert till next symbol }
+                            repeat
+                              hp:=tai(curdatatai.next);
+                              listtoinsert.remove(curdatatai);
+                              curdata.concat(curdatatai);
+                              curdatatai:=hp;
+                            until (curdatatai=nil) or (curdatatai.typ=ait_label);
+                            if lastpos=-1 then
+                              lastpos:=curpos;
+                          end;
+                      end;
+                  end;
+                inc(curpos);
+              end;
+
+            { split only at real instructions else the test below fails }
+            if ((curpos-lastpos)>1016) and (curtai.typ=ait_instruction) and
+              (
+                { don't split loads of pc to lr and the following move }
+                not(
+                    (taicpu(curtai).opcode=A_MOV) and
+                    (taicpu(curtai).oper[0]^.typ=top_reg) and
+                    (taicpu(curtai).oper[0]^.reg=NR_R14) and
+                    (taicpu(curtai).oper[1]^.typ=top_reg) and
+                    (taicpu(curtai).oper[1]^.reg=NR_PC)
+                   )
+              ) then
+              begin
+                lastpos:=curpos;
+                hp:=tai(curtai.next);
+                objectlibrary.getjumplabel(l);
+                curdata.insert(taicpu.op_sym(A_B,l));
+                curdata.concat(tai_label.create(l));
+                list.insertlistafter(curtai,curdata);
+                curtai:=hp;
+              end
+            else
+              curtai:=tai(curtai.next);
+          end;
+        list.concatlist(curdata);
+        curdata.free;
+      end;
+
+
+(*
+      Floating point instruction format information, taken from the linux kernel
+      ARM Floating Point Instruction Classes
+      | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | |
+      |c o n d|1 1 0 P|U|u|W|L|   Rn  |v|  Fd |0|0|0|1|  o f f s e t  | CPDT
+      |c o n d|1 1 0 P|U|w|W|L|   Rn  |x|  Fd |0|0|1|0|  o f f s e t  | CPDT (copro 2)
+      | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | |
+      |c o n d|1 1 1 0|a|b|c|d|e|  Fn |j|  Fd |0|0|0|1|f|g|h|0|i|  Fm | CPDO
+      |c o n d|1 1 1 0|a|b|c|L|e|  Fn |   Rd  |0|0|0|1|f|g|h|1|i|  Fm | CPRT
+      |c o n d|1 1 1 0|a|b|c|1|e|  Fn |1|1|1|1|0|0|0|1|f|g|h|1|i|  Fm | comparisons
+      | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | |
+
+      CPDT            data transfer instructions
+                      LDF, STF, LFM (copro 2), SFM (copro 2)
+
+      CPDO            dyadic arithmetic instructions
+                      ADF, MUF, SUF, RSF, DVF, RDF,
+                      POW, RPW, RMF, FML, FDV, FRD, POL
+
+      CPDO            monadic arithmetic instructions
+                      MVF, MNF, ABS, RND, SQT, LOG, LGN, EXP,
+                      SIN, COS, TAN, ASN, ACS, ATN, URD, NRM
+
+      CPRT            joint arithmetic/data transfer instructions
+                      FIX (arithmetic followed by load/store)
+                      FLT (load/store followed by arithmetic)
+                      CMF, CNF CMFE, CNFE (comparisons)
+                      WFS, RFS (write/read floating point status register)
+                      WFC, RFC (write/read floating point control register)
+
+      cond            condition codes
+      P               pre/post index bit: 0 = postindex, 1 = preindex
+      U               up/down bit: 0 = stack grows down, 1 = stack grows up
+      W               write back bit: 1 = update base register (Rn)
+      L               load/store bit: 0 = store, 1 = load
+      Rn              base register
+      Rd              destination/source register
+      Fd              floating point destination register
+      Fn              floating point source register
+      Fm              floating point source register or floating point constant
+
+      uv              transfer length (TABLE 1)
+      wx              register count (TABLE 2)
+      abcd            arithmetic opcode (TABLES 3 & 4)
+      ef              destination size (rounding precision) (TABLE 5)
+      gh              rounding mode (TABLE 6)
+      j               dyadic/monadic bit: 0 = dyadic, 1 = monadic
+      i               constant bit: 1 = constant (TABLE 6)
+      */
+
+      /*
+      TABLE 1
+      +-------------------------+---+---+---------+---------+
+      |  Precision              | u | v | FPSR.EP | length  |
+      +-------------------------+---+---+---------+---------+
+      | Single                  | 0 | 0 |    x    | 1 words |
+      | Double                  | 1 | 1 |    x    | 2 words |
+      | Extended                | 1 | 1 |    x    | 3 words |
+      | Packed decimal          | 1 | 1 |    0    | 3 words |
+      | Expanded packed decimal | 1 | 1 |    1    | 4 words |
+      +-------------------------+---+---+---------+---------+
+      Note: x = don't care
+      */
+
+      /*
+      TABLE 2
+      +---+---+---------------------------------+
+      | w | x | Number of registers to transfer |
+      +---+---+---------------------------------+
+      | 0 | 1 |  1                              |
+      | 1 | 0 |  2                              |
+      | 1 | 1 |  3                              |
+      | 0 | 0 |  4                              |
+      +---+---+---------------------------------+
+      */
+
+      /*
+      TABLE 3: Dyadic Floating Point Opcodes
+      +---+---+---+---+----------+-----------------------+-----------------------+
+      | a | b | c | d | Mnemonic | Description           | Operation             |
+      +---+---+---+---+----------+-----------------------+-----------------------+
+      | 0 | 0 | 0 | 0 | ADF      | Add                   | Fd := Fn + Fm         |
+      | 0 | 0 | 0 | 1 | MUF      | Multiply              | Fd := Fn * Fm         |
+      | 0 | 0 | 1 | 0 | SUF      | Subtract              | Fd := Fn - Fm         |
+      | 0 | 0 | 1 | 1 | RSF      | Reverse subtract      | Fd := Fm - Fn         |
+      | 0 | 1 | 0 | 0 | DVF      | Divide                | Fd := Fn / Fm         |
+      | 0 | 1 | 0 | 1 | RDF      | Reverse divide        | Fd := Fm / Fn         |
+      | 0 | 1 | 1 | 0 | POW      | Power                 | Fd := Fn ^ Fm         |
+      | 0 | 1 | 1 | 1 | RPW      | Reverse power         | Fd := Fm ^ Fn         |
+      | 1 | 0 | 0 | 0 | RMF      | Remainder             | Fd := IEEE rem(Fn/Fm) |
+      | 1 | 0 | 0 | 1 | FML      | Fast Multiply         | Fd := Fn * Fm         |
+      | 1 | 0 | 1 | 0 | FDV      | Fast Divide           | Fd := Fn / Fm         |
+      | 1 | 0 | 1 | 1 | FRD      | Fast reverse divide   | Fd := Fm / Fn         |
+      | 1 | 1 | 0 | 0 | POL      | Polar angle (ArcTan2) | Fd := arctan2(Fn,Fm)  |
+      | 1 | 1 | 0 | 1 |          | undefined instruction | trap                  |
+      | 1 | 1 | 1 | 0 |          | undefined instruction | trap                  |
+      | 1 | 1 | 1 | 1 |          | undefined instruction | trap                  |
+      +---+---+---+---+----------+-----------------------+-----------------------+
+      Note: POW, RPW, POL are deprecated, and are available for backwards
+            compatibility only.
+      */
+
+      /*
+      TABLE 4: Monadic Floating Point Opcodes
+      +---+---+---+---+----------+-----------------------+-----------------------+
+      | a | b | c | d | Mnemonic | Description           | Operation             |
+      +---+---+---+---+----------+-----------------------+-----------------------+
+      | 0 | 0 | 0 | 0 | MVF      | Move                  | Fd := Fm              |
+      | 0 | 0 | 0 | 1 | MNF      | Move negated          | Fd := - Fm            |
+      | 0 | 0 | 1 | 0 | ABS      | Absolute value        | Fd := abs(Fm)         |
+      | 0 | 0 | 1 | 1 | RND      | Round to integer      | Fd := int(Fm)         |
+      | 0 | 1 | 0 | 0 | SQT      | Square root           | Fd := sqrt(Fm)        |
+      | 0 | 1 | 0 | 1 | LOG      | Log base 10           | Fd := log10(Fm)       |
+      | 0 | 1 | 1 | 0 | LGN      | Log base e            | Fd := ln(Fm)          |
+      | 0 | 1 | 1 | 1 | EXP      | Exponent              | Fd := e ^ Fm          |
+      | 1 | 0 | 0 | 0 | SIN      | Sine                  | Fd := sin(Fm)         |
+      | 1 | 0 | 0 | 1 | COS      | Cosine                | Fd := cos(Fm)         |
+      | 1 | 0 | 1 | 0 | TAN      | Tangent               | Fd := tan(Fm)         |
+      | 1 | 0 | 1 | 1 | ASN      | Arc Sine              | Fd := arcsin(Fm)      |
+      | 1 | 1 | 0 | 0 | ACS      | Arc Cosine            | Fd := arccos(Fm)      |
+      | 1 | 1 | 0 | 1 | ATN      | Arc Tangent           | Fd := arctan(Fm)      |
+      | 1 | 1 | 1 | 0 | URD      | Unnormalized round    | Fd := int(Fm)         |
+      | 1 | 1 | 1 | 1 | NRM      | Normalize             | Fd := norm(Fm)        |
+      +---+---+---+---+----------+-----------------------+-----------------------+
+      Note: LOG, LGN, EXP, SIN, COS, TAN, ASN, ACS, ATN are deprecated, and are
+            available for backwards compatibility only.
+      */
+
+      /*
+      TABLE 5
+      +-------------------------+---+---+
+      |  Rounding Precision     | e | f |
+      +-------------------------+---+---+
+      | IEEE Single precision   | 0 | 0 |
+      | IEEE Double precision   | 0 | 1 |
+      | IEEE Extended precision | 1 | 0 |
+      | undefined (trap)        | 1 | 1 |
+      +-------------------------+---+---+
+      */
+
+      /*
+      TABLE 5
+      +---------------------------------+---+---+
+      |  Rounding Mode                  | g | h |
+      +---------------------------------+---+---+
+      | Round to nearest (default)      | 0 | 0 |
+      | Round toward plus infinity      | 0 | 1 |
+      | Round toward negative infinity  | 1 | 0 |
+      | Round toward zero               | 1 | 1 |
+      +---------------------------------+---+---+
+*)
+    function taicpu.GetString:string;
+      var
+        i : longint;
+        s : string;
+        addsize : boolean;
+      begin
+        s:='['+gas_op2str[opcode];
+        for i:=0 to ops-1 do
+         begin
+           with oper[i]^ do
+             begin
+               if i=0 then
+                s:=s+' '
+               else
+                s:=s+',';
+               { type }
+               addsize:=false;
+               if (ot and OT_VREG)=OT_VREG then
+                s:=s+'vreg'
+               else
+                 if (ot and OT_FPUREG)=OT_FPUREG then
+                  s:=s+'fpureg'
+               else
+                if (ot and OT_REGISTER)=OT_REGISTER then
+                 begin
+                   s:=s+'reg';
+                   addsize:=true;
+                 end
+               else
+                if (ot and OT_REGLIST)=OT_REGLIST then
+                 begin
+                   s:=s+'reglist';
+                   addsize:=false;
+                 end
+               else
+                if (ot and OT_IMMEDIATE)=OT_IMMEDIATE then
+                 begin
+                   s:=s+'imm';
+                   addsize:=true;
+                 end
+               else
+                if (ot and OT_MEMORY)=OT_MEMORY then
+                 begin
+                   s:=s+'mem';
+                   addsize:=true;
+                   if (ot and OT_AM2)<>0 then
+                     s:=s+' am2 ';
+                 end
+               else
+                 s:=s+'???';
+               { size }
+               if addsize then
+                begin
+                  if (ot and OT_BITS8)<>0 then
+                    s:=s+'8'
+                  else
+                   if (ot and OT_BITS16)<>0 then
+                    s:=s+'24'
+                  else
+                   if (ot and OT_BITS32)<>0 then
+                    s:=s+'32'
+                  else
+                   if (ot and OT_BITSSHIFTER)<>0 then
+                    s:=s+'shifter'
+                  else
+                    s:=s+'??';
+                  { signed }
+                  if (ot and OT_SIGNED)<>0 then
+                   s:=s+'s';
+                end;
+             end;
+         end;
+        GetString:=s+']';
+      end;
+
+
+    procedure taicpu.ResetPass1;
+      begin
+        { we need to reset everything here, because the choosen insentry
+          can be invalid for a new situation where the previously optimized
+          insentry is not correct }
+        InsEntry:=nil;
+        InsSize:=0;
+        LastInsOffset:=-1;
+      end;
+
+
+    procedure taicpu.ResetPass2;
+      begin
+        { we are here in a second pass, check if the instruction can be optimized }
+        if assigned(InsEntry) and
+           ((InsEntry^.flags and IF_PASS2)<>0) then
+         begin
+           InsEntry:=nil;
+           InsSize:=0;
+         end;
+        LastInsOffset:=-1;
+      end;
+
+
+    function taicpu.CheckIfValid:boolean;
+      begin
+      end;
+
+
+    function taicpu.Pass1(offset:longint):longint;
+      var
+        ldr2op : array[PF_B..PF_T] of tasmop = (
+          A_LDRB,A_LDRSB,A_LDRBT,A_LDRH,A_LDRSH,A_LDRT);
+        str2op : array[PF_B..PF_T] of tasmop = (
+          A_STRB,A_None,A_STRBT,A_STRH,A_None,A_STRT);
+      begin
+        Pass1:=0;
+        { Save the old offset and set the new offset }
+        InsOffset:=Offset;
+        { Error? }
+        if (Insentry=nil) and (InsSize=-1) then
+          exit;
+        { set the file postion }
+        aktfilepos:=fileinfo;
+
+        { tranlate LDR+postfix to complete opcode }
+        if (opcode=A_LDR) and (oppostfix<>PF_None) then
+          begin
+            if (oppostfix in [low(ldr2op)..high(ldr2op)]) then
+              opcode:=ldr2op[oppostfix]
+            else
+              internalerror(2005091001);
+            if opcode=A_None then
+              internalerror(2005091004);
+            { postfix has been added to opcode }
+            oppostfix:=PF_None;
+          end
+        else if (opcode=A_STR) and (oppostfix<>PF_None) then
+          begin
+            if (oppostfix in [low(str2op)..high(str2op)]) then
+              opcode:=str2op[oppostfix]
+            else
+              internalerror(2005091002);
+            if opcode=A_None then
+              internalerror(2005091003);
+            { postfix has been added to opcode }
+            oppostfix:=PF_None;
+          end;
+
+        { Get InsEntry }
+        if FindInsEntry then
+         begin
+           InsSize:=4;
+           LastInsOffset:=InsOffset;
+           Pass1:=InsSize;
+           exit;
+         end;
+        LastInsOffset:=-1;
+      end;
+
+
+    procedure taicpu.Pass2(objdata:TAsmObjectdata);
+      begin
+        { error in pass1 ? }
+        if insentry=nil then
+         exit;
+        aktfilepos:=fileinfo;
+        { Generate the instruction }
+        GenCode(objdata);
+      end;
+
+
+    procedure taicpu.ppuloadoper(ppufile:tcompilerppufile;var o:toper);
+      begin
+      end;
+
+
+    procedure taicpu.ppuwriteoper(ppufile:tcompilerppufile;const o:toper);
+      begin
+      end;
+
+
+    procedure taicpu.ppubuildderefimploper(var o:toper);
+      begin
+      end;
+
+
+    procedure taicpu.ppuderefoper(var o:toper);
+      begin
+      end;
+
+
+    function  taicpu.InsEnd:longint;
+      begin
+      end;
+
+
+    procedure taicpu.create_ot;
+      var
+        i,l,relsize : longint;
+        dummy : byte;
+      begin
+        if ops=0 then
+         exit;
+        { update oper[].ot field }
+        for i:=0 to ops-1 do
+         with oper[i]^ do
+          begin
+            case typ of
+              top_regset:
+                begin
+                  ot:=OT_REGLIST;
+                end;
+              top_reg :
+                begin
+                  case getregtype(reg) of
+                    R_INTREGISTER:
+                      ot:=OT_REG32 or OT_SHIFTEROP;
+                    R_FPUREGISTER:
+                      ot:=OT_FPUREG;
+                    else
+                      internalerror(2005090901);
+                  end;
+                end;
+              top_ref :
+                begin
+                  if ref^.refaddr=addr_no then
+                    begin
+                      { create ot field }
+                      { we should get the size here dependend on the
+                        instruction }
+                      if (ot and OT_SIZE_MASK)=0 then
+                        ot:=OT_MEMORY or OT_BITS32
+                      else
+                        ot:=OT_MEMORY or (ot and OT_SIZE_MASK);
+                      if (ref^.base=NR_NO) and (ref^.index=NR_NO) then
+                        ot:=ot or OT_MEM_OFFS;
+                      { if we need to fix a reference, we do it here }
+
+                      { pc relative addressing }
+                      if (ref^.base=NR_NO) and
+                        (ref^.index=NR_NO) and
+                        (ref^.shiftmode=SM_None)
+                        { at least we should check if the destination symbol
+                          is in a text section }
+                        { and
+                        (ref^.symbol^.owner="text") } then
+                        ref^.base:=NR_PC;
+
+                      { determine possible address modes }
+                      if (ref^.base<>NR_NO) and
+                        (
+                          (
+                            (ref^.index=NR_NO) and
+                            (ref^.shiftmode=SM_None) and
+                            (ref^.offset>=-4097) and
+                            (ref^.offset<=4097)
+                          ) or
+                          (
+                            (ref^.shiftmode=SM_None) and
+                            (ref^.offset=0)
+                          ) or
+                          (
+                            (ref^.index<>NR_NO) and
+                            (ref^.shiftmode<>SM_None) and
+                            (ref^.shiftimm<=31) and
+                            (ref^.offset=0)
+                          )
+                        ) then
+                        ot:=ot or OT_AM2;
+
+                      if (ref^.index<>NR_NO) and
+                        (oppostfix in [PF_IA,PF_IB,PF_DA,PF_DB,PF_FD,PF_FA,PF_ED,PF_EA]) and
+                        (
+                          (ref^.base=NR_NO) and
+                          (ref^.shiftmode=SM_None) and
+                          (ref^.offset=0)
+                        ) then
+                        ot:=ot or OT_AM4;
+
+                    end
+                  else
+                    begin
+                      l:=ref^.offset;
+                      if assigned(ref^.symbol) then
+                        inc(l,ref^.symbol.address);
+                      relsize:=(InsOffset+2)-l;
+                      if (relsize<-33554428) or (relsize>33554428) then
+                       ot:=OT_IMM32
+                      else
+                       ot:=OT_IMM24;
+                    end;
+                end;
+              top_local :
+                begin
+                  { we should get the size here dependend on the
+                    instruction }
+                  if (ot and OT_SIZE_MASK)=0 then
+                    ot:=OT_MEMORY or OT_BITS32
+                  else
+                    ot:=OT_MEMORY or (ot and OT_SIZE_MASK);
+                end;
+              top_const :
+                begin
+                  ot:=OT_IMMEDIATE;
+                  if is_shifter_const(val,dummy) then
+                    ot:=OT_IMMSHIFTER
+                  else
+                    ot:=OT_IMM32
+                end;
+              top_none :
+                begin
+                  { generated when there was an error in the
+                    assembler reader. It never happends when generating
+                    assembler }
+                end;
+              top_shifterop:
+                begin
+                  ot:=OT_SHIFTEROP;
+                end;
+              else
+                internalerror(200402261);
+            end;
+          end;
+      end;
+
+
+    function taicpu.Matches(p:PInsEntry):longint;
+      { * IF_SM stands for Size Match: any operand whose size is not
+       * explicitly specified by the template is `really' intended to be
+       * the same size as the first size-specified operand.
+       * Non-specification is tolerated in the input instruction, but
+       * _wrong_ specification is not.
+       *
+       * IF_SM2 invokes Size Match on only the first _two_ operands, for
+       * three-operand instructions such as SHLD: it implies that the
+       * first two operands must match in size, but that the third is
+       * required to be _unspecified_.
+       *
+       * IF_SB invokes Size Byte: operands with unspecified size in the
+       * template are really bytes, and so no non-byte specification in
+       * the input instruction will be tolerated. IF_SW similarly invokes
+       * Size Word, and IF_SD invokes Size Doubleword.
+       *
+       * (The default state if neither IF_SM nor IF_SM2 is specified is
+       * that any operand with unspecified size in the template is
+       * required to have unspecified size in the instruction too...)
+      }
+      var
+        i,j,asize,oprs : longint;
+        siz : array[0..3] of longint;
+      begin
+        Matches:=100;
+        writeln(getstring,'---');
+
+        { Check the opcode and operands }
+        if (p^.opcode<>opcode) or (p^.ops<>ops) then
+         begin
+           Matches:=0;
+           exit;
+         end;
+
+        { Check that no spurious colons or TOs are present }
+        for i:=0 to p^.ops-1 do
+         if (oper[i]^.ot and (not p^.optypes[i]) and (OT_COLON or OT_TO))<>0 then
+          begin
+            Matches:=0;
+            exit;
+          end;
+
+        { Check that the operand flags all match up }
+        for i:=0 to p^.ops-1 do
+         begin
+           if ((p^.optypes[i] and (not oper[i]^.ot)) or
+               ((p^.optypes[i] and OT_SIZE_MASK) and
+                ((p^.optypes[i] xor oper[i]^.ot) and OT_SIZE_MASK)))<>0 then
+            begin
+              if ((p^.optypes[i] and (not oper[i]^.ot) and OT_NON_SIZE) or
+                  (oper[i]^.ot and OT_SIZE_MASK))<>0 then
+               begin
+                 Matches:=0;
+                 exit;
+               end
+              else
+               Matches:=1;
+            end;
+         end;
+
+      { check postfixes:
+        the existance of a certain postfix requires a
+        particular code }
+
+        { update condition flags
+          or floating point single }
+      if (oppostfix=PF_S) and
+        not(p^.code[0] in [#$04]) then
+        begin
+          Matches:=0;
+          exit;
+        end;
+
+      { floating point size }
+      if (oppostfix in [PF_D,PF_E,PF_P,PF_EP]) and
+        not(p^.code[0] in []) then
+        begin
+          Matches:=0;
+          exit;
+        end;
+
+      { multiple load/store address modes }
+      if (oppostfix in [PF_IA,PF_IB,PF_DA,PF_DB,PF_FD,PF_FA,PF_ED,PF_EA]) and
+        not(p^.code[0] in [
+          // ldr,str,ldrb,strb
+          #$17,
+          // stm,ldm
+          #$26
+        ]) then
+        begin
+          Matches:=0;
+          exit;
+        end;
+
+      { we shouldn't see any opsize prefixes here }
+      if (oppostfix in [PF_B,PF_SB,PF_BT,PF_H,PF_SH,PF_T]) then
+        begin
+          Matches:=0;
+          exit;
+        end;
+
+      if (roundingmode<>RM_None) and not(p^.code[0] in []) then
+        begin
+          Matches:=0;
+          exit;
+        end;
+
+      { Check operand sizes }
+        { as default an untyped size can get all the sizes, this is different
+          from nasm, but else we need to do a lot checking which opcodes want
+          size or not with the automatic size generation }
+        asize:=longint($ffffffff);
+        (*
+        if (p^.flags and IF_SB)<>0 then
+          asize:=OT_BITS8
+        else if (p^.flags and IF_SW)<>0 then
+          asize:=OT_BITS16
+        else if (p^.flags and IF_SD)<>0 then
+          asize:=OT_BITS32;
+        if (p^.flags and IF_ARMASK)<>0 then
+         begin
+           siz[0]:=0;
+           siz[1]:=0;
+           siz[2]:=0;
+           if (p^.flags and IF_AR0)<>0 then
+            siz[0]:=asize
+           else if (p^.flags and IF_AR1)<>0 then
+            siz[1]:=asize
+           else if (p^.flags and IF_AR2)<>0 then
+            siz[2]:=asize;
+         end
+        else
+         begin
+         { we can leave because the size for all operands is forced to be
+           the same
+           but not if IF_SB IF_SW or IF_SD is set PM }
+           if asize=-1 then
+             exit;
+           siz[0]:=asize;
+           siz[1]:=asize;
+           siz[2]:=asize;
+         end;
+
+        if (p^.flags and (IF_SM or IF_SM2))<>0 then
+         begin
+           if (p^.flags and IF_SM2)<>0 then
+            oprs:=2
+           else
+            oprs:=p^.ops;
+           for i:=0 to oprs-1 do
+            if ((p^.optypes[i] and OT_SIZE_MASK) <> 0) then
+             begin
+               for j:=0 to oprs-1 do
+                siz[j]:=p^.optypes[i] and OT_SIZE_MASK;
+               break;
+             end;
+          end
+         else
+          oprs:=2;
+
+        { Check operand sizes }
+        for i:=0 to p^.ops-1 do
+         begin
+           if ((p^.optypes[i] and OT_SIZE_MASK)=0) and
+              ((oper[i]^.ot and OT_SIZE_MASK and (not siz[i]))<>0) and
+              { Immediates can always include smaller size }
+              ((oper[i]^.ot and OT_IMMEDIATE)=0) and
+               (((p^.optypes[i] and OT_SIZE_MASK) or siz[i])<(oper[i]^.ot and OT_SIZE_MASK)) then
+            Matches:=2;
+         end;
+        *)
+      end;
+
+
+    function  taicpu.calcsize(p:PInsEntry):shortint;
+      begin
+        result:=4;
+      end;
+
+
+    function  taicpu.NeedAddrPrefix(opidx:byte):boolean;
+      begin
+      end;
+
+
+    procedure taicpu.Swapoperands;
+      begin
+      end;
+
+
+    function taicpu.FindInsentry:boolean;
+      var
+        i : longint;
+      begin
+        result:=false;
+      { Things which may only be done once, not when a second pass is done to
+        optimize }
+        if (Insentry=nil) or ((InsEntry^.flags and IF_PASS2)<>0) then
+         begin
+           { create the .ot fields }
+           create_ot;
+           { set the file postion }
+           aktfilepos:=fileinfo;
+         end
+        else
+         begin
+           { we've already an insentry so it's valid }
+           result:=true;
+           exit;
+         end;
+        { Lookup opcode in the table }
+        InsSize:=-1;
+        i:=instabcache^[opcode];
+        if i=-1 then
+         begin
+           Message1(asmw_e_opcode_not_in_table,gas_op2str[opcode]);
+           exit;
+         end;
+        insentry:=@instab[i];
+        while (insentry^.opcode=opcode) do
+         begin
+           if matches(insentry)=100 then
+             begin
+               result:=true;
+               exit;
+             end;
+           inc(i);
+           insentry:=@instab[i];
+         end;
+        Message1(asmw_e_invalid_opcode_and_operands,GetString);
+        { No instruction found, set insentry to nil and inssize to -1 }
+        insentry:=nil;
+        inssize:=-1;
+      end;
+
+
+    procedure taicpu.gencode(objdata:TAsmObjectData);
+      var
+        bytes : dword;
+        i_field : byte;
+
+      procedure setshifterop(op : byte);
+        begin
+          case oper[op]^.typ of
+            top_const:
+              begin
+                i_field:=1;
+                bytes:=bytes or (oper[op]^.val and $fff);
+              end;
+            top_reg:
+              begin
+                i_field:=0;
+                bytes:=bytes or (getsupreg(oper[op]^.reg) shl 16);
+
+                { does a real shifter op follow? }
+                if (op+1<=op) and (oper[op+1]^.typ=top_shifterop) then
+                  begin
+                  end;
+              end;
+          else
+            internalerror(2005091103);
+          end;
+        end;
+
+      begin
+        bytes:=$0;
+        { evaluate and set condition code }
+
+        { condition code allowed? }
+
+        { setup rest of the instruction }
+        case insentry^.code[0] of
+          #$08:
+            begin
+              { set instruction code }
+              bytes:=bytes or (ord(insentry^.code[1]) shl 26);
+              bytes:=bytes or (ord(insentry^.code[2]) shl 21);
+
+              { set destination }
+              bytes:=bytes or (getsupreg(oper[0]^.reg) shl 12);
+
+              { create shifter op }
+              setshifterop(1);
+
+              { set i field }
+              bytes:=bytes or (i_field shl 25);
+
+              { set s if necessary }
+              if oppostfix=PF_S then
+                bytes:=bytes or (1 shl 20);
+            end;
+          #$ff:
+            internalerror(2005091101);
+          else
+            internalerror(2005091102);
+        end;
+        { we're finished, write code }
+        objdata.writebytes(bytes,sizeof(bytes));
+      end;
+
+
+end.
+
+{$ifdef dummy}
+      (*
+static void gencode (long segment, long offset, int bits,
+		     insn *ins, char *codes, long insn_end)
+{
+    int has_S_code;		/* S - setflag */
+    int has_B_code;		/* B - setflag */
+    int has_T_code;		/* T - setflag */
+    int has_W_code;		/* ! => W flag */
+    int has_F_code;		/* ^ => S flag */
+    int keep;
+    unsigned char c;
+    unsigned char bytes[4];
+    long          data, size;
+    static int cc_code[] =	/* bit pattern of cc */
+  {				/* order as enum in  */
+    0x0E, 0x03, 0x02, 0x00,	/* nasm.h	     */
+    0x0A, 0x0C, 0x08, 0x0D,
+    0x09, 0x0B, 0x04, 0x01,
+    0x05, 0x07, 0x06,
+  };
+
+(*
+#ifdef DEBUG
+static char *CC[] =
+  {				       /* condition code names */
+    "AL", "CC", "CS", "EQ",
+    "GE", "GT", "HI", "LE",
+    "LS", "LT", "MI", "NE",
+    "PL", "VC", "VS", "",
+    "S"
+};
+*)
+
+    has_S_code = (ins->condition & C_SSETFLAG);
+    has_B_code = (ins->condition & C_BSETFLAG);
+    has_T_code = (ins->condition & C_TSETFLAG);
+    has_W_code = (ins->condition & C_EXSETFLAG);
+    has_F_code = (ins->condition & C_FSETFLAG);
+    ins->condition = (ins->condition & 0x0F);
+
+(*
+    if (rt_debug)
+      {
+    printf ("gencode: instruction: %s%s", insn_names[ins->opcode],
+	    CC[ins->condition & 0x0F]);
+    if (has_S_code)
+      printf ("S");
+    if (has_B_code)
+      printf ("B");
+    if (has_T_code)
+      printf ("T");
+    if (has_W_code)
+      printf ("!");
+    if (has_F_code)
+      printf ("^");
+
+    printf ("\n");
+
+    c = *codes;
+
+    printf ("   (%d)  decode - '0x%02X'\n", ins->operands, c);
+
+
+    bytes[0] = 0xB;
+    bytes[1] = 0xE;
+    bytes[2] = 0xE;
+    bytes[3] = 0xF;
+      }
+*)
+    // First condition code in upper nibble
+    if (ins->condition < C_NONE)
+      {
+	c = cc_code[ins->condition] << 4;
+      }
+    else
+      {
+	c = cc_code[C_AL] << 4;	// is often ALWAYS but not always
+      }
+
+
+    switch (keep = *codes)
+      {
+	case 1:
+	  // B, BL
+	  ++codes;
+	  c |= *codes++;
+	  bytes[0] = c;
+
+	  if (ins->oprs[0].segment != segment)
+	    {
+	      // fais une relocation
+	      c = 1;
+	      data = 0;	// Let the linker locate ??
+	    }
+	  else
+	    {
+	      c = 0;
+	      data = ins->oprs[0].offset - (offset + 8);
+	
+	      if (data % 4)
+		{
+		  errfunc (ERR_NONFATAL, "offset not aligned on 4 bytes");
+		}
+	    }
+	
+	  if (data >= 0x1000)
+	    {
+	      errfunc (ERR_NONFATAL, "too long offset");
+	    }
+
+	  data = data >> 2;
+	  bytes[1] = (data >> 16) & 0xFF;
+	  bytes[2] = (data >> 8)  & 0xFF;
+	  bytes[3] = (data )      & 0xFF;
+
+	  if (c == 1)
+	    {
+//	      out (offset, segment, &bytes[0], OUT_RAWDATA+1, NO_SEG, NO_SEG);
+	      out (offset, segment, &bytes[0], OUT_REL3ADR+4, ins->oprs[0].segment, NO_SEG);
+	    }
+	  else
+	    {
+	      out (offset, segment, &bytes[0], OUT_RAWDATA+4, NO_SEG, NO_SEG);
+	    }
+	  return;
+
+	case 2:
+	  // SWI
+	  ++codes;
+	  c |= *codes++;
+	  bytes[0] = c;
+	  data = ins->oprs[0].offset;
+	  bytes[1] = (data >> 16) & 0xFF;
+	  bytes[2] = (data >> 8) & 0xFF;
+	  bytes[3] = (data) & 0xFF;
+	  out (offset, segment, &bytes, OUT_RAWDATA+4, NO_SEG, NO_SEG);
+	  return;
+        case 3:
+	  // BX
+	  ++codes;
+	  c |= *codes++;
+	  bytes[0] = c;
+	  bytes[1] = *codes++;
+	  bytes[2] = *codes++;
+	  bytes[3] = *codes++;
+	  c = regval (&ins->oprs[0],1);
+	  if (c == 15)	// PC
+	    {
+	      errfunc (ERR_WARNING, "'BX' with R15 has undefined behaviour");
+	    }
+	  else if (c > 15)
+	    {
+	      errfunc (ERR_NONFATAL, "Illegal register specified for 'BX'");
+	    }
+
+	  bytes[3] |= (c & 0x0F);
+	  out (offset, segment, bytes, OUT_RAWDATA+4, NO_SEG, NO_SEG);
+	  return;
+
+        case 4:		// AND Rd,Rn,Rm
+        case 5:		// AND Rd,Rn,Rm,<shift>Rs
+        case 6:		// AND Rd,Rn,Rm,<shift>imm
+        case 7:		// AND Rd,Rn,<shift>imm
+	  ++codes;
+#ifdef DEBUG
+	  if (rt_debug)
+	    {
+	      printf ("         decode - '0x%02X'\n", keep);
+	      printf ("           code - '0x%02X'\n", (unsigned char) ( *codes));
+	    }
+#endif
+	  bytes[0] = c | *codes;
+	  ++codes;
+	
+	  bytes[1] = *codes;
+	  if (has_S_code)
+	    bytes[1] |= 0x10;
+	  c = regval (&ins->oprs[1],1);
+	  // Rn in low nibble
+	  bytes[1] |= c;
+
+	  // Rd in high nibble
+	  bytes[2] = regval (&ins->oprs[0],1) << 4;
+
+	  if (keep != 7)
+	    {
+	      // Rm in low nibble
+	      bytes[3] = regval (&ins->oprs[2],1);
+	    }
+
+	  // Shifts if any
+	  if (keep == 5 || keep == 6)
+	    {
+	      // Shift in bytes 2 and 3
+	      if (keep == 5)
+		{
+		  // Rs
+		  c = regval (&ins->oprs[3],1);
+		  bytes[2] |= c;
+
+		  c = 0x10;		// Set bit 4 in byte[3]
+		}
+	      if (keep == 6)
+		{
+		  c = (ins->oprs[3].offset) & 0x1F;
+
+		  // #imm
+		  bytes[2] |= c >> 1;
+		  if (c & 0x01)
+		    {
+		      bytes[3] |= 0x80;
+		    }
+		  c = 0;		// Clr bit 4 in byte[3]
+		}
+	      // <shift>
+	      c |= shiftval (&ins->oprs[3]) << 5;
+
+	      bytes[3] |= c;
+	    }
+	
+	  // reg,reg,imm
+	  if (keep == 7)
+	    {
+	      int shimm;
+	
+	      shimm = imm_shift (ins->oprs[2].offset);
+
+	      if (shimm == -1)
+		{
+		  errfunc (ERR_NONFATAL, "cannot create that constant");
+		}
+	      bytes[3] = shimm & 0xFF;
+	      bytes[2] |= (shimm & 0xF00) >> 8;
+	    }
+	
+	  out (offset, segment, bytes, OUT_RAWDATA+4, NO_SEG, NO_SEG);
+	  return;
+
+        case 8:		// MOV Rd,Rm
+        case 9:		// MOV Rd,Rm,<shift>Rs
+        case 0xA:	// MOV Rd,Rm,<shift>imm
+        case 0xB:	// MOV Rd,<shift>imm
+	  ++codes;
+#ifdef DEBUG
+	  if (rt_debug)
+	    {
+	      printf ("         decode - '0x%02X'\n", keep);
+	      printf ("           code - '0x%02X'\n", (unsigned char) ( *codes));
+	    }
+#endif
+	  bytes[0] = c | *codes;
+	  ++codes;
+	
+	  bytes[1] = *codes;
+	  if (has_S_code)
+	    bytes[1] |= 0x10;
+
+	  // Rd in high nibble
+	  bytes[2] = regval (&ins->oprs[0],1) << 4;
+
+	  if (keep != 0x0B)
+	    {
+	      // Rm in low nibble
+	      bytes[3] = regval (&ins->oprs[1],1);
+	    }
+
+	  // Shifts if any
+	  if (keep == 0x09 || keep == 0x0A)
+	    {
+	      // Shift in bytes 2 and 3
+	      if (keep == 0x09)
+		{
+		  // Rs
+		  c = regval (&ins->oprs[2],1);
+		  bytes[2] |= c;
+
+		  c = 0x10;		// Set bit 4 in byte[3]
+		}
+	      if (keep == 0x0A)
+		{
+		  c = (ins->oprs[2].offset) & 0x1F;
+		
+		  // #imm
+		  bytes[2] |= c >> 1;
+		  if (c & 0x01)
+		    {
+		      bytes[3] |= 0x80;
+		    }
+		  c = 0;		// Clr bit 4 in byte[3]
+		}
+	      // <shift>
+	      c |= shiftval (&ins->oprs[2]) << 5;
+
+	      bytes[3] |= c;
+	    }
+	
+	  // reg,imm
+	  if (keep == 0x0B)
+	    {
+	      int shimm;
+	
+	      shimm = imm_shift (ins->oprs[1].offset);
+
+	      if (shimm == -1)
+		{
+		  errfunc (ERR_NONFATAL, "cannot create that constant");
+		}
+	      bytes[3] = shimm & 0xFF;
+	      bytes[2] |= (shimm & 0xF00) >> 8;
+	    }
+	
+	  out (offset, segment, bytes, OUT_RAWDATA+4, NO_SEG, NO_SEG);
+	  return;
+
+
+        case 0xC:	// CMP Rn,Rm
+        case 0xD:	// CMP Rn,Rm,<shift>Rs
+        case 0xE:	// CMP Rn,Rm,<shift>imm
+        case 0xF:	// CMP Rn,<shift>imm
+	  ++codes;
+
+	  bytes[0] = c | *codes++;
+	
+	  bytes[1] = *codes;
+
+	  // Implicit S code
+	  bytes[1] |= 0x10;
+
+	  c = regval (&ins->oprs[0],1);
+	  // Rn in low nibble
+	  bytes[1] |= c;
+
+	  // No destination
+	  bytes[2] = 0;
+
+	  if (keep != 0x0B)
+	    {
+	      // Rm in low nibble
+	      bytes[3] = regval (&ins->oprs[1],1);
+	    }
+
+	  // Shifts if any
+	  if (keep == 0x0D || keep == 0x0E)
+	    {
+	      // Shift in bytes 2 and 3
+	      if (keep == 0x0D)
+		{
+		  // Rs
+		  c = regval (&ins->oprs[2],1);
+		  bytes[2] |= c;
+
+		  c = 0x10;		// Set bit 4 in byte[3]
+		}
+	      if (keep == 0x0E)
+		{
+		  c = (ins->oprs[2].offset) & 0x1F;
+		
+		  // #imm
+		  bytes[2] |= c >> 1;
+		  if (c & 0x01)
+		    {
+		      bytes[3] |= 0x80;
+		    }
+		  c = 0;		// Clr bit 4 in byte[3]
+		}
+	      // <shift>
+	      c |= shiftval (&ins->oprs[2]) << 5;
+
+	      bytes[3] |= c;
+	    }
+	
+	  // reg,imm
+	  if (keep == 0x0F)
+	    {
+	      int shimm;
+	
+	      shimm = imm_shift (ins->oprs[1].offset);
+
+	      if (shimm == -1)
+		{
+		  errfunc (ERR_NONFATAL, "cannot create that constant");
+		}
+	      bytes[3] = shimm & 0xFF;
+	      bytes[2] |= (shimm & 0xF00) >> 8;
+	    }
+	
+	  out (offset, segment, bytes, OUT_RAWDATA+4, NO_SEG, NO_SEG);
+	  return;
+	
+        case 0x10:	// MRS Rd,<psr>
+	  ++codes;
+
+	  bytes[0] = c | *codes++;
+	
+	  bytes[1] = *codes++;
+
+	  // Rd
+	  c = regval (&ins->oprs[0],1);
+
+	  bytes[2] = c << 4;
+
+	  bytes[3] = 0;
+
+	  c = ins->oprs[1].basereg;
+
+	  if (c == R_CPSR || c == R_SPSR)
+	    {
+	      if (c == R_SPSR)
+		{
+		  bytes[1] |= 0x40;
+		}
+	    }
+	  else
+	    {
+	      errfunc (ERR_NONFATAL, "CPSR or SPSR expected");
+	    }
+
+	  out (offset, segment, bytes, OUT_RAWDATA+4, NO_SEG, NO_SEG);
+
+	  return;
+	
+        case 0x11:	// MSR <psr>,Rm
+	case 0x12:	// MSR <psrf>,Rm
+        case 0x13:	// MSR <psrf>,#expression
+	  ++codes;
+
+	  bytes[0] = c | *codes++;
+	
+	  bytes[1] = *codes++;
+
+	  bytes[2] = *codes;
+
+
+	  if (keep == 0x11 || keep == 0x12)
+	    {
+	      // Rm
+	      c = regval (&ins->oprs[1],1);
+
+	      bytes[3] = c;
+	    }
+	  else
+	    {
+	      int shimm;
+	
+	      shimm = imm_shift (ins->oprs[1].offset);
+
+	      if (shimm == -1)
+		{
+		  errfunc (ERR_NONFATAL, "cannot create that constant");
+		}
+	      bytes[3] = shimm & 0xFF;
+	      bytes[2] |= (shimm & 0xF00) >> 8;
+	    }
+	
+	  c = ins->oprs[0].basereg;
+
+	  if ( keep == 0x11)
+	    {
+	      if ( c == R_CPSR || c == R_SPSR)
+		{
+		if ( c== R_SPSR)
+		  {
+		    bytes[1] |= 0x40;
+		  }
+		}
+	    else
+	      {
+		errfunc (ERR_NONFATAL, "CPSR or SPSR expected");
+	      }
+	    }
+	  else
+	    {
+	      if ( c == R_CPSR_FLG || c == R_SPSR_FLG)
+		{
+		  if ( c== R_SPSR_FLG)
+		    {
+		      bytes[1] |= 0x40;
+		    }
+		}
+	      else
+		{
+		  errfunc (ERR_NONFATAL, "CPSR_flg or SPSR_flg expected");
+		}
+	    }
+	  break;
+
+        case 0x14:	// MUL  Rd,Rm,Rs
+        case 0x15:	// MULA Rd,Rm,Rs,Rn
+	  ++codes;
+
+	  bytes[0] = c | *codes++;
+	
+	  bytes[1] = *codes++;
+
+	  bytes[3] = *codes;
+
+	  // Rd
+	  bytes[1] |= regval (&ins->oprs[0],1);
+	  if (has_S_code)
+	    bytes[1] |= 0x10;
+
+	  // Rm
+	  bytes[3] |= regval (&ins->oprs[1],1);
+
+	  // Rs
+	  bytes[2] = regval (&ins->oprs[2],1);
+
+	  if (keep == 0x15)
+	    {
+	      bytes[2] |= regval (&ins->oprs[3],1) << 4;
+	    }
+	  break;
+
+        case 0x16:	// SMLAL RdHi,RdLo,Rm,Rs
+	  ++codes;
+	
+	  bytes[0] = c | *codes++;
+
+	  bytes[1] = *codes++;
+
+	  bytes[3] = *codes;
+
+	  // RdHi
+	  bytes[1] |= regval (&ins->oprs[1],1);
+	  if (has_S_code)
+	    bytes[1] |= 0x10;
+
+	  // RdLo
+	  bytes[2] = regval (&ins->oprs[0],1) << 4;
+	  // Rm
+	  bytes[3] |= regval (&ins->oprs[2],1);
+
+	  // Rs
+	  bytes[2] |= regval (&ins->oprs[3],1);
+
+	  break;
+	
+        case 0x17:	// LDR Rd, expression
+	  ++codes;
+
+	  bytes[0] = c | *codes++;
+
+	  bytes[1] = *codes++;
+
+	  // Rd
+	  bytes[2] = regval (&ins->oprs[0],1) << 4;
+	  if (has_B_code)
+	    bytes[1] |= 0x40;
+	  if (has_T_code)
+	    {
+	      errfunc (ERR_NONFATAL, "'T' not allowed in pre-index mode");
+	    }
+	  if (has_W_code)
+	    {
+	      errfunc (ERR_NONFATAL, "'!' not allowed");
+	    }
+
+	  // Rn - implicit R15
+	  bytes[1] |= 0xF;
+
+	  if (ins->oprs[1].segment != segment)
+	    {
+	      errfunc (ERR_NONFATAL, "label not in same segment");
+	    }
+	
+	  data = ins->oprs[1].offset - (offset + 8);
+
+	  if (data < 0)
+	    {
+	      data = -data;
+	    }
+	  else
+	    {
+	      bytes[1] |= 0x80;
+	    }
+
+	  if (data >= 0x1000)
+	    {
+	      errfunc (ERR_NONFATAL, "too long offset");
+	    }
+
+	  bytes[2] |= ((data & 0xF00) >> 8);
+	  bytes[3] = data & 0xFF;
+	  break;
+	
+        case 0x18:	// LDR Rd, [Rn]
+	  ++codes;
+	
+	  bytes[0] = c | *codes++;
+	
+	  bytes[1] = *codes++;
+
+	  // Rd
+	  bytes[2] = regval (&ins->oprs[0],1) << 4;
+	  if (has_B_code)
+	    bytes[1] |= 0x40;
+	  if (has_T_code)
+	    {
+	      bytes[1] |= 0x20;		// write-back
+	    }
+	  else
+	    {
+	      bytes[0] |= 0x01;		// implicit pre-index mode
+	    }
+
+	  if (has_W_code)
+	    {
+	      bytes[1] |= 0x20;		// write-back
+	    }
+
+	  // Rn
+	  c = regval (&ins->oprs[1],1);
+	  bytes[1] |= c;
+
+	  if (c == 0x15)		// R15
+	    data = -8;
+	  else
+	    data = 0;
+
+	  if (data < 0)
+	    {
+	      data = -data;
+	    }
+	  else
+	    {
+	      bytes[1] |= 0x80;
+	    }
+
+	  bytes[2] |= ((data & 0xF00) >> 8);
+	  bytes[3] = data & 0xFF;
+	  break;
+	
+        case 0x19:	// LDR Rd, [Rn,#expression]
+	case 0x20:	// LDR Rd, [Rn,Rm]
+	case 0x21:	// LDR Rd, [Rn,Rm,shift]
+	  ++codes;
+	
+	  bytes[0] = c | *codes++;
+	
+	  bytes[1] = *codes++;
+
+	  // Rd
+	  bytes[2] = regval (&ins->oprs[0],1) << 4;
+	  if (has_B_code)
+	    bytes[1] |= 0x40;
+
+	  // Rn
+	  c = regval (&ins->oprs[1],1);
+	  bytes[1] |= c;
+
+	  if (ins->oprs[ins->operands-1].bracket)	// FIXME: Bracket on last operand -> pre-index  <--
+	    {
+	      bytes[0] |= 0x01;		// pre-index mode
+	      if (has_W_code)
+		{
+		  bytes[1] |= 0x20;
+		}
+	      if (has_T_code)
+		{
+		  errfunc (ERR_NONFATAL, "'T' not allowed in pre-index mode");
+		}
+	    }
+	  else
+	    {
+	      if (has_T_code)		// Forced write-back in post-index mode
+		{
+		  bytes[1] |= 0x20;
+		}
+	      if (has_W_code)
+		{
+		  errfunc (ERR_NONFATAL, "'!' not allowed in post-index mode");
+		}
+	    }
+
+	  if (keep == 0x19)
+	    {
+	      data = ins->oprs[2].offset;
+
+	      if (data < 0)
+		{
+		  data = -data;
+		}
+	      else
+		{
+		  bytes[1] |= 0x80;
+		}
+
+	      if (data >= 0x1000)
+		{
+		  errfunc (ERR_NONFATAL, "too long offset");
+		}
+	
+	      bytes[2] |= ((data & 0xF00) >> 8);
+	      bytes[3] = data & 0xFF;
+	    }
+	  else
+	    {
+	      if (ins->oprs[2].minus == 0)
+		{
+		  bytes[1] |= 0x80;
+		}
+	      c = regval (&ins->oprs[2],1);
+	      bytes[3] = c;
+
+	      if (keep == 0x21)
+		{
+		  c = ins->oprs[3].offset;
+		  if (c > 0x1F)
+		    {
+		      errfunc (ERR_NONFATAL, "too large shiftvalue");
+		      c = c & 0x1F;
+		    }
+		
+		  bytes[2] |= c >> 1;
+		  if (c & 0x01)
+		    {
+		      bytes[3] |= 0x80;
+		    }
+		  bytes[3] |= shiftval (&ins->oprs[3]) << 5;
+		}
+	    }
+	
+	  break;
+	
+        case 0x22:	// LDRH Rd, expression
+	  ++codes;
+	
+	  bytes[0] = c | 0x01;		// Implicit pre-index
+
+	  bytes[1] = *codes++;
+
+	  // Rd
+	  bytes[2] = regval (&ins->oprs[0],1) << 4;
+	
+	  // Rn - implicit R15
+	  bytes[1] |= 0xF;
+
+	  if (ins->oprs[1].segment != segment)
+	    {
+	      errfunc (ERR_NONFATAL, "label not in same segment");
+	    }
+	
+	  data = ins->oprs[1].offset - (offset + 8);
+
+	  if (data < 0)
+	    {
+	      data = -data;
+	    }
+	  else
+	    {
+	      bytes[1] |= 0x80;
+	    }
+
+	  if (data >= 0x100)
+	    {
+	      errfunc (ERR_NONFATAL, "too long offset");
+	    }
+	  bytes[3] = *codes++;
+
+	  bytes[2] |= ((data & 0xF0) >> 4);
+	  bytes[3] |= data & 0xF;
+	  break;
+	
+        case 0x23:	// LDRH Rd, Rn
+	  ++codes;
+	
+	  bytes[0] = c | 0x01;		// Implicit pre-index
+	
+	  bytes[1] = *codes++;
+
+	  // Rd
+	  bytes[2] = regval (&ins->oprs[0],1) << 4;
+	
+	  // Rn
+	  c = regval (&ins->oprs[1],1);
+	  bytes[1] |= c;
+
+	  if (c == 0x15)		// R15
+	    data = -8;
+	  else
+	    data = 0;
+
+	  if (data < 0)
+	    {
+	      data = -data;
+	    }
+	  else
+	    {
+	      bytes[1] |= 0x80;
+	    }
+
+	  if (data >= 0x100)
+	    {
+	      errfunc (ERR_NONFATAL, "too long offset");
+	    }
+	  bytes[3] = *codes++;
+
+	  bytes[2] |= ((data & 0xF0) >> 4);
+	  bytes[3] |= data & 0xF;
+	  break;
+	
+        case 0x24:	// LDRH Rd, Rn, expression
+        case 0x25:	// LDRH Rd, Rn, Rm
+	  ++codes;
+
+	  bytes[0] = c;
+	
+	  bytes[1] = *codes++;
+
+	  // Rd
+	  bytes[2] = regval (&ins->oprs[0],1) << 4;
+
+	  // Rn
+	  c = regval (&ins->oprs[1],1);
+	  bytes[1] |= c;
+
+	  if (ins->oprs[ins->operands-1].bracket)	// FIXME: Bracket on last operand -> pre-index  <--
+	    {
+	      bytes[0] |= 0x01;		// pre-index mode
+	      if (has_W_code)
+		{
+		  bytes[1] |= 0x20;
+		}
+	    }
+	  else
+	    {
+	      if (has_W_code)
+		{
+		  errfunc (ERR_NONFATAL, "'!' not allowed in post-index mode");
+		}
+	    }
+
+	  bytes[3] = *codes++;
+
+	  if (keep == 0x24)
+	    {
+	      data = ins->oprs[2].offset;
+
+	      if (data < 0)
+		{
+		  data = -data;
+		}
+	      else
+		{
+		  bytes[1] |= 0x80;
+		}
+	
+	      if (data >= 0x100)
+		{
+		  errfunc (ERR_NONFATAL, "too long offset");
+		}
+
+	      bytes[2] |= ((data & 0xF0) >> 4);
+	      bytes[3] |= data & 0xF;
+	    }
+	  else
+	    {
+	      if (ins->oprs[2].minus == 0)
+		{
+		  bytes[1] |= 0x80;
+		}
+	      c = regval (&ins->oprs[2],1);
+	      bytes[3] |= c;
+
+	    }
+	  break;
+	
+        case 0x26:	// LDM/STM Rn, {reg-list}
+	  ++codes;
+
+	  bytes[0] = c;
+
+	  bytes[0] |= ( *codes >> 4) & 0xF;
+	  bytes[1] = ( *codes << 4) & 0xF0;
+	  ++codes;
+
+	  if (has_W_code)
+	    {
+	      bytes[1] |= 0x20;
+	    }
+	  if (has_F_code)
+	    {
+	      bytes[1] |= 0x40;
+	    }
+	
+	  // Rn
+	  bytes[1] |= regval (&ins->oprs[0],1);
+
+	  data = ins->oprs[1].basereg;
+
+	  bytes[2] = ((data >> 8) & 0xFF);
+	  bytes[3] = (data & 0xFF);
+	
+	  break;
+	
+        case 0x27:	// SWP Rd, Rm, [Rn]
+	  ++codes;
+	
+	  bytes[0] = c;
+
+	  bytes[0] |= *codes++;
+	
+	  bytes[1] = regval (&ins->oprs[2],1);
+	  if (has_B_code)
+	    {
+	      bytes[1] |= 0x40;
+	    }
+	  bytes[2] = regval (&ins->oprs[0],1) << 4;
+	  bytes[3] = *codes++;
+	  bytes[3] |= regval (&ins->oprs[1],1);
+	  break;
+	
+        default:
+	  errfunc (ERR_FATAL, "unknown decoding of instruction");
+
+	  bytes[0] = c;
+	  // And a fix nibble
+	  ++codes;
+	  bytes[0] |= *codes++;
+
+	 if ( *codes == 0x01)		// An I bit
+	   {
+
+	   }
+	 if ( *codes == 0x02)		// An I bit
+	   {
+
+	   }
+	 ++codes;
+      }
+    out (offset, segment, bytes, OUT_RAWDATA+4, NO_SEG, NO_SEG);
+}
+
+
+*)
+{$endif dummy
+}

+ 237 - 0
compiler/arm/agarmgas.pas

@@ -0,0 +1,237 @@
+{
+    Copyright (c) 2003 by Florian Klaempfl
+
+    This unit implements an asm for the ARM
+
+    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 implements the GNU Assembler writer for the ARM
+}
+
+unit agarmgas;
+
+{$i fpcdefs.inc}
+
+  interface
+
+    uses
+       aasmtai,
+       aggas,
+       cpubase;
+
+    type
+      PARMGNUAssembler=^TARMGNUAssembler;
+      TARMGNUAssembler=class(TGNUassembler)
+        procedure WriteInstruction(hp : tai);override;
+      end;
+
+    const
+      gas_shiftmode2str : array[tshiftmode] of string[3] = (
+        '','lsl','lsr','asr','ror','rrx');
+
+  implementation
+
+    uses
+       cutils,globals,verbose,
+       systems,
+       assemble,
+       aasmcpu,
+       itcpugas,
+       cgbase,cgutils;
+
+    const
+       as_arm_gas_info : tasminfo =
+          (
+            id     : as_gas;
+
+            idtxt  : 'AS';
+            asmbin : 'as';
+            asmcmd : '-o $OBJ $ASM';
+            supported_target : system_any;
+            flags : [af_allowdirect,af_needar,af_smartlink_sections];
+            labelprefix : '.L';
+            comment : '# ';
+          );
+
+    function getreferencestring(var ref : treference) : string;
+      var
+        s : string;
+      begin
+         with ref do
+          begin
+{$ifdef extdebug}
+            // if base=NR_NO then
+            //   internalerror(200308292);
+
+            // if ((index<>NR_NO) or (shiftmode<>SM_None)) and ((offset<>0) or (symbol<>nil)) then
+            //   internalerror(200308293);
+{$endif extdebug}
+
+            if assigned(symbol) then
+              begin
+                if (base<>NR_NO) and not(is_pc(base)) then
+                  internalerror(200309011);
+                s:=symbol.name;
+                if offset<0 then
+                  s:=s+tostr(offset)
+                else if offset>0 then
+                  s:=s+'+'+tostr(offset);
+              end
+            else
+              begin
+                s:='['+gas_regname(base);
+                if addressmode=AM_POSTINDEXED then
+                  s:=s+']';
+                if index<>NR_NO then
+                  begin
+                     if signindex<0 then
+                       s:=s+', -'
+                     else
+                       s:=s+', ';
+
+                     s:=s+gas_regname(index);
+
+                     if shiftmode<>SM_None then
+                       s:=s+' ,'+gas_shiftmode2str[shiftmode]+' #'+tostr(shiftimm);
+                  end
+                else if offset<>0 then
+                  s:=s+', #'+tostr(offset);
+
+                case addressmode of
+                  AM_OFFSET:
+                    s:=s+']';
+                  AM_PREINDEXED:
+                    s:=s+']!';
+                end;
+              end;
+
+          end;
+        getreferencestring:=s;
+      end;
+
+
+    const
+      shiftmode2str: array[tshiftmode] of string[3] = ('','lsl','lsr','asr','ror','rrx');
+
+    function getopstr(const o:toper) : string;
+      var
+        hs : string;
+        first : boolean;
+        r : tsuperregister;
+      begin
+        case o.typ of
+          top_reg:
+            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)
+              else if (o.shifterop^.rs=NR_NO) then
+                getopstr:=shiftmode2str[o.shifterop^.shiftmode]+' #'+tostr(o.shifterop^.shiftimm)
+              else internalerror(200308282);
+            end;
+          top_const:
+            getopstr:='#'+tostr(longint(o.val));
+          top_regset:
+            begin
+              getopstr:='{';
+              first:=true;
+              for r:=RS_R0 to RS_R15 do
+                if r in o.regset^ then
+                  begin
+                    if not(first) then
+                      getopstr:=getopstr+',';
+                    getopstr:=getopstr+gas_regname(newreg(R_INTREGISTER,r,R_SUBWHOLE));
+                    first:=false;
+                  end;
+              getopstr:=getopstr+'}';
+            end;
+          top_ref:
+            if o.ref^.refaddr=addr_full then
+              begin
+                hs:=o.ref^.symbol.name;
+                if o.ref^.offset>0 then
+                 hs:=hs+'+'+tostr(o.ref^.offset)
+                else
+                 if o.ref^.offset<0 then
+                  hs:=hs+tostr(o.ref^.offset);
+                getopstr:=hs;
+              end
+            else
+              getopstr:=getreferencestring(o.ref^);
+          else
+            internalerror(2002070604);
+        end;
+      end;
+
+
+    Procedure TARMGNUAssembler.WriteInstruction(hp : tai);
+    var op: TAsmOp;
+        s: string;
+        i: byte;
+        sep: string[3];
+    begin
+      op:=taicpu(hp).opcode;
+      s:=#9+gas_op2str[op]+cond2str[taicpu(hp).condition]+oppostfix2str[taicpu(hp).oppostfix];
+      if taicpu(hp).ops<>0 then
+        begin
+          sep:=#9;
+          for i:=0 to taicpu(hp).ops-1 do
+            begin
+               // debug code
+               // writeln(s);
+               // writeln(taicpu(hp).fileinfo.line);
+
+               { LDM and STM use references as first operand but they are written like a register }
+               if (i=0) and (op in [A_LDM,A_STM]) then
+                 begin
+                   case taicpu(hp).oper[0]^.typ of
+                     top_ref:
+                       begin
+                         s:=s+sep+gas_regname(taicpu(hp).oper[0]^.ref^.index);
+                         if taicpu(hp).oper[0]^.ref^.addressmode=AM_PREINDEXED then
+                           s:=s+'!';
+                       end;
+                     top_reg:
+                       s:=s+sep+gas_regname(taicpu(hp).oper[0]^.reg);
+                     else
+                       internalerror(200311292);
+                   end;
+                 end
+               { register count of SFM and LFM is written without # }
+               else if (i=1) and (op in [A_SFM,A_LFM]) then
+                 begin
+                   case taicpu(hp).oper[1]^.typ of
+                     top_const:
+                       s:=s+sep+tostr(taicpu(hp).oper[1]^.val);
+                     else
+                       internalerror(200311292);
+                   end;
+                 end
+               else
+                 s:=s+sep+getopstr(taicpu(hp).oper[i]^);
+
+               sep:=',';
+            end;
+        end;
+      AsmWriteLn(s);
+    end;
+
+
+begin
+  RegisterAssembler(as_arm_gas_info,TARMGNUAssembler);
+end.

+ 42 - 0
compiler/arm/aoptcpu.pas

@@ -0,0 +1,42 @@
+{
+    Copyright (c) 1998-2002 by Jonas Maebe, member of the Free Pascal
+    Development Team
+
+    This unit implements the ARM optimizer 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.
+
+ ****************************************************************************
+}
+
+
+Unit aoptcpu;
+
+{$i fpcdefs.inc}
+
+Interface
+
+uses cpubase, aopt, aoptcpub;
+
+Type
+  TCpuAsmOptimizer = class(TAsmOptimizer)
+    { uses the same constructor as TAopObj }
+  End;
+
+Implementation
+
+begin
+  casmoptimizer:=TCpuAsmOptimizer;
+End.

+ 120 - 0
compiler/arm/aoptcpub.pas

@@ -0,0 +1,120 @@
+ {
+    Copyright (c) 1998-2002 by Jonas Maebe, member of the Free Pascal
+    Development Team
+
+    This unit contains several types and constants necessary for the
+    optimizer to work on the ARM architecture
+
+    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 aoptcpub; { Assembler OPTimizer CPU specific Base }
+
+{$i fpcdefs.inc}
+
+{ enable the following define if memory references can have both a base and }
+{ index register in 1 operand                                               }
+
+{$define RefsHaveIndexReg}
+
+{ enable the following define if memory references can have a scaled index }
+
+{ define RefsHaveScale}
+
+{ enable the following define if memory references can have a segment }
+{ override                                                            }
+
+{ define RefsHaveSegment}
+
+Interface
+
+Uses
+  cpubase,aasmcpu,AOptBase;
+
+Type
+
+{ type of a normal instruction }
+  TInstr = Taicpu;
+  PInstr = ^TInstr;
+
+{ ************************************************************************* }
+{ **************************** TCondRegs ********************************** }
+{ ************************************************************************* }
+{ Info about the conditional registers                                      }
+  TCondRegs = Object
+    Constructor Init;
+    Destructor Done;
+  End;
+
+{ ************************************************************************* }
+{ **************************** TAoptBaseCpu ******************************* }
+{ ************************************************************************* }
+
+  TAoptBaseCpu = class(TAoptBase)
+  End;
+
+
+{ ************************************************************************* }
+{ ******************************* Constants ******************************* }
+{ ************************************************************************* }
+Const
+
+{ the maximum number of things (registers, memory, ...) a single instruction }
+{ changes                                                                    }
+
+  MaxCh = 3;
+
+{ the maximum number of operands an instruction has }
+
+  MaxOps = 3;
+
+{Oper index of operand that contains the source (reference) with a load }
+{instruction                                                            }
+
+  LoadSrc = 0;
+
+{Oper index of operand that contains the destination (register) with a load }
+{instruction                                                                }
+
+  LoadDst = 1;
+
+{Oper index of operand that contains the source (register) with a store }
+{instruction                                                            }
+
+  StoreSrc = 0;
+
+{Oper index of operand that contains the destination (reference) with a load }
+{instruction                                                                 }
+
+  StoreDst = 1;
+
+  aopt_uncondjmp = A_B;
+  aopt_condjmp = A_B;
+    
+Implementation
+
+{ ************************************************************************* }
+{ **************************** TCondRegs ********************************** }
+{ ************************************************************************* }
+Constructor TCondRegs.init;
+Begin
+End;
+
+Destructor TCondRegs.Done; {$ifdef inl} inline; {$endif inl}
+Begin
+End;
+
+End.

+ 38 - 0
compiler/arm/aoptcpuc.pas

@@ -0,0 +1,38 @@
+ {
+    Copyright (c) 1998-2002 by Jonas Maebe, member of the Free Pascal
+    Development Team
+
+    This unit contains the processor specific implementation of the
+    assembler optimizer common subexpression elimination 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.
+
+ ****************************************************************************
+}
+unit aoptcpuc;
+
+Interface
+
+Uses
+  AOptCs;
+
+Type
+  TRegInfoCpu = Object(TRegInfo)
+  End;
+
+
+Implementation
+
+End.

+ 40 - 0
compiler/arm/aoptcpud.pas

@@ -0,0 +1,40 @@
+{
+    Copyright (c) 1998-2002 by Jonas Maebe, member of the Free Pascal
+    Development Team
+
+    This unit contains the processor specific implementation of the
+    assembler optimizer data flow analyzer.
+
+    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 aoptcpud;
+
+{$i fpcdefs.inc}
+
+Interface
+
+uses
+  AOptDA;
+
+Type
+  TAOptDFACpu = class(TAOptDFA)
+  End;
+
+Implementation
+
+
+End.

+ 90 - 0
compiler/arm/armatt.inc

@@ -0,0 +1,90 @@
+{ don't edit, this file is generated from armins.dat }
+(
+'none',
+'abs',
+'acs',
+'asn',
+'atn',
+'adc',
+'add',
+'adf',
+'and',
+'b',
+'bic',
+'bl',
+'blx',
+'bkpt',
+'bx',
+'cdp',
+'cmf',
+'cmfe',
+'cmn',
+'cmp',
+'clz',
+'cnf',
+'cos',
+'dvf',
+'eor',
+'exp',
+'fdv',
+'flt',
+'fix',
+'fml',
+'frd',
+'ldc',
+'ldm',
+'ldrbt',
+'ldrb',
+'ldr',
+'ldrh',
+'ldrsb',
+'ldrsh',
+'ldrt',
+'ldf',
+'lfm',
+'lgn',
+'log',
+'mcr',
+'mla',
+'mov',
+'mnf',
+'muf',
+'mul',
+'mvf',
+'mvn',
+'orr',
+'rdf',
+'rfs',
+'rfc',
+'rmf',
+'rpw',
+'rsb',
+'rsc',
+'rsf',
+'rnd',
+'pol',
+'sbc',
+'sfm',
+'sin',
+'smlal',
+'smull',
+'sqt',
+'suf',
+'stf',
+'stm',
+'str',
+'strb',
+'strbt',
+'strh',
+'strt',
+'sub',
+'swi',
+'swp',
+'swpb',
+'tan',
+'teq',
+'tst',
+'umlal',
+'umull',
+'wfs'
+);

+ 90 - 0
compiler/arm/armatts.inc

@@ -0,0 +1,90 @@
+{ don't edit, this file is generated from armins.dat }
+(
+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
+);

+ 394 - 0
compiler/arm/armins.dat

@@ -0,0 +1,394 @@
+;
+; Table of assembler instructions for Free Pascal
+; adapted from Netwide Assembler by Florian Klaempfl
+;
+;
+; The Netwide Assembler is copyright (C) 1996 Simon Tatham and
+; Julian Hall. All rights reserved. The software is
+; redistributable under the licence given in the file "Licence"
+; distributed in the NASM archive.
+;
+; Format of file: all four fields must be present on every functional
+; line. Hence `void' for no-operand instructions, and `\0' for such
+; as EQU. If the last three fields are all `ignore', no action is
+; taken except to register the opcode as being present.
+;
+;
+; 'ignore' means no instruc
+; 'void'   means instruc with zero operands
+;
+; Third field has a first byte indicating how to
+; put together the bits, and then some codes
+; that may be used at will (see assemble.c)
+;
+; \1   - 24 bit pc-rel offset		[B, BL]
+; \2   - 24 bit imm value		[SWI]
+; \3   -  3 byte code			[BX]
+;
+; \4   - reg,reg,reg			[AND,EOR,SUB,RSB,ADD,ADC,SBC,RSC,ORR,BIC]
+; \5   - reg,reg,reg,<shift>reg		[-"-]
+; \6   - reg,reg,reg,<shift>#imm	[-"-]
+; \7   - reg,reg,#imm			[-"-]
+;
+; \x8  - reg,reg			[MOV,MVN]
+; \x9  - reg,reg,<shift>reg		[-"-]
+; \xA  - reg,reg,<shift>#imm		[-"-]
+; \xB  - reg,#imm			[-"-]
+;
+; \xC  - reg,reg			[CMP,CMN,TEQ,TST]
+; \xD  - reg,reg,<shift>reg		[-"-]
+; \xE  - reg,reg,<shift>#imm		[-"-]
+; \xF  - reg,#imm			[-"-]
+;
+; \xFx - floating point instructions
+;        Floating point instruction format information, taken from the linux kernel,
+;        for detailed tables, see aasmcpu.pas
+;
+;        ARM Floating Point Instruction Classes
+;        | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | |
+;        |c o n d|1 1 0 P|U|u|W|L|   Rn  |v|  Fd |0|0|0|1|  o f f s e t  | CPDT
+;        |c o n d|1 1 0 P|U|w|W|L|   Rn  |x|  Fd |0|0|1|0|  o f f s e t  | CPDT (copro 2)
+;        | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | |
+;        |c o n d|1 1 1 0|a|b|c|d|e|  Fn |j|  Fd |0|0|0|1|f|g|h|0|i|  Fm | CPDO
+;        |c o n d|1 1 1 0|a|b|c|L|e|  Fn |   Rd  |0|0|0|1|f|g|h|1|i|  Fm | CPRT
+;        |c o n d|1 1 1 0|a|b|c|1|e|  Fn |1|1|1|1|0|0|0|1|f|g|h|1|i|  Fm | comparisons
+;        | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | |
+;
+;        CPDT            data transfer instructions
+;                        LDF, STF, LFM (copro 2), SFM (copro 2)
+;
+;        CPDO            dyadic arithmetic instructions
+;                        ADF, MUF, SUF, RSF, DVF, RDF,
+;                        POW, RPW, RMF, FML, FDV, FRD, POL
+;
+;        CPDO            monadic arithmetic instructions
+;                        MVF, MNF, ABS, RND, SQT, LOG, LGN, EXP,
+;                        SIN, COS, TAN, ASN, ACS, ATN, URD, NRM
+;
+;        CPRT            joint arithmetic/data transfer instructions
+;                        FIX (arithmetic followed by load/store)
+;                        FLT (load/store followed by arithmetic)
+;                        CMF, CNF CMFE, CNFE (comparisons)
+;                        WFS, RFS (write/read floating point status register)
+;                        WFC, RFC (write/read floating point control register)
+; \xF0 - CPDT
+;        code 1: copro (1/2)
+;        code 2: load/store bit
+; \xF1 - CPDO
+; \xF2 - CPDO monadic
+; \xF3 - CPRT
+; \xF4 - CPRT comparison
+;
+; \xFF - fix me
+;
+
+[NONE]
+void                  void                            none
+
+[ABScc]
+
+[ACScc]
+
+[ASNcc]
+
+[ATNcc]
+
+[ADCcc]
+reg32,reg32,reg32        \4\x0\xA0                     ARM7
+reg32,reg32,reg32,reg32  \5\x0\xA0                     ARM7
+reg32,reg32,reg32,imm    \6\x0\xA0                     ARM7
+reg32,reg32,imm          \7\x2\xA0                     ARM7
+
+[ADDcc]
+reg32,reg32,reg32        \4\x0\x80                     ARM7
+reg32,reg32,reg32,reg32  \5\x0\x80                     ARM7
+reg32,reg32,reg32,imm    \6\x0\x80                     ARM7
+reg32,reg32,imm          \7\x2\x80                     ARM7
+
+[ADFcc]
+
+[ANDcc]
+reg32,reg32,reg32        \4\x0\x00                     ARM7
+reg32,reg32,reg32,reg32  \5\x0\x00                     ARM7
+reg32,reg32,reg32,imm    \6\x0\x00                     ARM7
+reg32,reg32,imm          \7\x2\x00                     ARM7
+
+[Bcc]
+mem32                    \1\x0A                        ARM7
+imm24                    \1\x0A                        ARM7
+
+[BICcc]
+reg32,reg32,reg32        \4\x1\xC0                     ARM7
+reg32,reg32,reg32,reg32  \5\x1\xC0                     ARM7
+reg32,reg32,reg32,imm    \6\x1\xC0                     ARM7
+reg32,reg32,imm          \7\x3\xC0                     ARM7
+
+[BLcc]
+mem32                    \1\x0B                        ARM7
+imm24                    \1\x0B                        ARM7
+
+[BLX]
+mem32                    \xff                        ARM7
+imm24                    \xff                        ARM7
+
+[BKPTcc]
+
+[BXcc]
+reg32                    \3\x01\x2F\xFF\x10            ARM7
+
+[CDP]
+reg8,reg8           \300\1\x10\101                ARM7
+
+[CMFcc]
+
+[CMFEcc]
+
+[CMNcc]
+reg32,reg32              \xC\x1\x60                     ARM7
+reg32,reg32,reg32        \xD\x1\x60                     ARM7
+reg32,reg32,imm          \xE\x1\x60                     ARM7
+reg32,imm                \xF\x3\x60                     ARM7
+
+[CMPcc]
+reg32,reg32              \xC\x1\x40                     ARM7
+reg32,reg32,reg32        \xD\x1\x40                     ARM7
+reg32,reg32,imm          \xE\x1\x40                     ARM7
+reg32,imm                \xF\x3\x40                     ARM7
+
+[CLZcc]
+reg32,reg32              \x27\x01\x01                   ARM7
+
+[CNFcc]
+
+[COScc]
+
+[DVFcc]
+
+[EORcc]
+reg32,reg32,reg32        \4\x0\x20                     ARM7
+reg32,reg32,reg32,reg32  \5\x0\x20                     ARM7
+reg32,reg32,reg32,imm    \6\x0\x20                     ARM7
+reg32,reg32,imm          \7\x2\x20                     ARM7
+
+[EXPcc]
+
+[FDVcc]
+
+[FLTcc]
+
+[FIXcc]
+
+[FMLcc]
+
+[FRDcc]
+
+[LDC]
+reg32,reg32         \321\300\1\x11\101            ARM7
+
+[LDMcc]
+memam4,reglist		   \x26\x81			ARM7
+
+[LDRBTcc]
+
+[LDRBcc]
+reg32,memam2              \x17\x07\x10                            ARM7
+
+[LDRcc]
+reg32,memam2              \x17\x05\x10                   ARM7
+; reg32,imm32              \x17\x05\x10                   ARM7
+; reg32,reg32              \x18\x04\x10                   ARM7
+; reg32,reg32,imm32        \x19\x04\x10                   ARM7
+; reg32,reg32,reg32        \x20\x06\x10                   ARM7
+; reg32,reg32,reg32,imm32  \x21\x06\x10                   ARM7
+
+[LDRHcc]
+reg32,imm32              \x22\x50\xB0               ARM7
+reg32,reg32              \x23\x50\xB0               ARM7
+reg32,reg32,imm32        \x24\x50\xB0                   ARM7
+reg32,reg32,reg32        \x25\x10\xB0                   ARM7
+
+[LDRSBcc]
+reg32,imm32              \x22\x50\xD0               ARM7
+reg32,reg32              \x23\x50\xD0               ARM7
+reg32,reg32,imm32        \x24\x50\xD0                   ARM7
+reg32,reg32,reg32        \x25\x10\xD0                   ARM7
+
+[LDRSHcc]
+reg32,imm32              \x22\x50\xF0               ARM7
+reg32,reg32              \x23\x50\xF0               ARM7
+reg32,reg32,imm32        \x24\x50\xF0                   ARM7
+reg32,reg32,reg32        \x25\x10\xF0                   ARM7
+
+[LDRTcc]
+
+[LDFcc]
+
+[LFMcc]
+reg32,imm8,fpureg        \xF0\x02\x01                   FPA
+
+[LGNcc]
+
+[LOGcc]
+
+[MCR]
+reg32,mem32         \320\301\1\x13\110            ARM7
+
+[MLAcc]
+reg32,reg32,reg32,reg32  \x15\x00\x20\x90               ARM7
+
+[MOVcc]
+reg32,shifterop              \x8\x0\0xd                   ARM7
+reg32,immshifter             \x8\x0\0xd                  ARM7
+; reg32,reg32,reg32        \x9\x1\xA0                     ARM7
+; reg32,reg32,imm          \xA\x1\xA0                     ARM7
+; reg32,imm                \xB\x3\xA0                     ARM7
+
+; [MRC]
+; reg32,reg32         \321\301\1\x13\110                  ARM7
+
+; [MRScc]
+; reg32,reg32         \x10\x01\x0F                        ARM7
+
+; [MSRcc]
+; reg32,reg32         \x11\x01\x29\xF0                    ARM7
+; regf,reg32          \x12\x01\x28\xF0                    ARM7
+; regf,imm            \x13\x03\x28\xF0                    ARM7
+
+[MNFcc]
+
+[MUFcc]
+
+[MULcc]
+reg32,reg32,reg32        \x14\x00\x00\x90          ARM7
+
+[MVFcc]
+fpureg,fpureg              \xF2                      FPA
+fpureg,immfpu              \xF2                      FPA
+
+[MVNcc]
+reg32,reg32         \x8\x0\0xf                     ARM7
+reg32,reg32,reg32   \x9\x1\xE0                     ARM7
+reg32,reg32,imm     \xA\x1\xE0                     ARM7
+reg32,imm           \xB\x3\xE0                     ARM7
+
+[ORRcc]
+reg32,reg32,reg32        \4\x1\x80                     ARM7
+reg32,reg32,reg32,reg32  \5\x1\x80                     ARM7
+reg32,reg32,reg32,imm    \6\x1\x80                     ARM7
+reg32,reg32,imm          \7\x3\x80                     ARM7
+
+[RDFcc]
+
+[RFScc]
+
+[RFCcc]
+
+[RMFcc]
+
+[RPWcc]
+
+[RSBcc]
+reg32,reg32,reg32        \4\x0\x60                     ARM7
+reg32,reg32,reg32,reg32  \5\x0\x60                     ARM7
+reg32,reg32,reg32,imm    \6\x0\x60                     ARM7
+reg32,reg32,imm          \7\x2\x60                     ARM7
+
+[RSCcc]
+reg32,reg32,reg32        \4\x0\xE0                     ARM7
+reg32,reg32,reg32,reg32  \5\x0\xE0                     ARM7
+reg32,reg32,reg32,imm    \6\x0\xE0                     ARM7
+reg32,reg32,imm          \7\x2\xE0                     ARM7
+
+[RSFcc]
+
+[RNDcc]
+
+[POLcc]
+
+[SBCcc]
+reg32,reg32,reg32        \4\x0\xC0                     ARM7
+reg32,reg32,reg32,reg32  \5\x0\xC0                     ARM7
+reg32,reg32,reg32,imm    \6\x0\xC0                     ARM7
+reg32,reg32,imm          \7\x2\xC0                     ARM7
+
+[SFMcc]
+reg32,imm8,fpureg        \xF0\x02\x00                   FPA
+
+[SINcc]
+
+[SMLALcc]
+reg32,reg32,reg32,reg32  \x16\x00\xE0\x90		 ARM7
+
+[SMULLcc]
+reg32,reg32,reg32,reg32  \x16\x00\xC0\x90		 ARM7
+
+[SQTcc]
+
+[SUFcc]
+
+[STFcc]
+
+[STMcc]
+memam4,reglist		   \x26\x80			ARM7
+
+[STRcc]
+reg32,memam2              \x17\x04\x00                   ARM7
+; reg32,imm32              \x17\x05\x00                   ARM7
+; reg32,reg32              \x18\x04\x00                   ARM7
+; reg32,reg32,imm32        \x19\x04\x00                   ARM7
+; reg32,reg32,reg32        \x20\x06\x00                   ARM7
+; reg32,reg32,reg32,imm32  \x21\x06\x00                   ARM7
+
+[STRBcc]
+reg32,memam2              \x17\x06\x00                           ARM7
+
+[STRBTcc]
+
+; A dummy since it is parsed as STR{cond}H
+[STRHcc]
+reg32,imm32              \x22\x40\xB0              ARM7
+reg32,reg32              \x23\x40\xB0               ARM7
+reg32,reg32,imm32        \x24\x40\xB0                   ARM7
+reg32,reg32,reg32        \x25\x00\xB0                   ARM7
+
+[STRTcc]
+
+[SUBcc]
+reg32,reg32,shifterop     \4\x0\x40                     ARM7
+reg32,reg32,immshifter    \4\x0\x40                     ARM7
+reg32,reg32,reg32        \4\x0\x40                     ARM7
+; reg32,reg32,reg32,reg32  \5\x0\x40                     ARM7
+; reg32,reg32,reg32,imm    \6\x0\x40                     ARM7
+; reg32,reg32,imm          \7\x2\x40                     ARM7
+
+[SWIcc]
+imm                 \2\x0F                        ARM7
+
+[SWPcc]
+reg32,reg32,reg32   \x27\x01\x90                   ARM7
+
+[SWPBcc]
+reg32,reg32,reg32   \x27\x01\x90                   ARM7
+
+[TANcc]
+
+[TEQcc]
+reg32,reg32         \xC\x1\x20                     ARM7
+reg32,reg32,reg32   \xD\x1\x20                     ARM7
+reg32,reg32,imm     \xE\x1\x20                     ARM7
+reg32,imm           \xF\x3\x20                     ARM7
+
+[TSTcc]
+reg32,reg32         \xC\x1\x00                     ARM7
+reg32,reg32,reg32   \xD\x1\x00                     ARM7
+reg32,reg32,imm     \xE\x1\x00                     ARM7
+reg32,imm           \xF\x3\x00                     ARM7
+
+[UMLALcc]
+reg32,reg32,reg32,reg32  \x16\x00\xA0\x90		 ARM7
+
+[UMULLcc]
+reg32,reg32,reg32,reg32  \x16\x00\x80\x90		 ARM7
+
+[WFScc]
+

+ 2 - 0
compiler/arm/armnop.inc

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

+ 90 - 0
compiler/arm/armop.inc

@@ -0,0 +1,90 @@
+{ don't edit, this file is generated from armins.dat }
+(
+A_NONE,
+A_ABS,
+A_ACS,
+A_ASN,
+A_ATN,
+A_ADC,
+A_ADD,
+A_ADF,
+A_AND,
+A_B,
+A_BIC,
+A_BL,
+A_BLX,
+A_BKPT,
+A_BX,
+A_CDP,
+A_CMF,
+A_CMFE,
+A_CMN,
+A_CMP,
+A_CLZ,
+A_CNF,
+A_COS,
+A_DVF,
+A_EOR,
+A_EXP,
+A_FDV,
+A_FLT,
+A_FIX,
+A_FML,
+A_FRD,
+A_LDC,
+A_LDM,
+A_LDRBT,
+A_LDRB,
+A_LDR,
+A_LDRH,
+A_LDRSB,
+A_LDRSH,
+A_LDRT,
+A_LDF,
+A_LFM,
+A_LGN,
+A_LOG,
+A_MCR,
+A_MLA,
+A_MOV,
+A_MNF,
+A_MUF,
+A_MUL,
+A_MVF,
+A_MVN,
+A_ORR,
+A_RDF,
+A_RFS,
+A_RFC,
+A_RMF,
+A_RPW,
+A_RSB,
+A_RSC,
+A_RSF,
+A_RND,
+A_POL,
+A_SBC,
+A_SFM,
+A_SIN,
+A_SMLAL,
+A_SMULL,
+A_SQT,
+A_SUF,
+A_STF,
+A_STM,
+A_STR,
+A_STRB,
+A_STRBT,
+A_STRH,
+A_STRT,
+A_SUB,
+A_SWI,
+A_SWP,
+A_SWPB,
+A_TAN,
+A_TEQ,
+A_TST,
+A_UMLAL,
+A_UMULL,
+A_WFS
+);

+ 84 - 0
compiler/arm/armreg.dat

@@ -0,0 +1,84 @@
+;
+; ARM registers
+;
+; layout
+; <name>,<type>,<value>,<stdname>,<stab idx>,<dwarf idx>
+;
+NO,$00,$00,INVALID,-1,-1
+; Integer registers
+R0,$01,$00,r0,0,0
+R1,$01,$01,r1,1,1
+R2,$01,$02,r2,2,2
+R3,$01,$03,r3,3,3
+R4,$01,$04,r4,4,4
+R5,$01,$05,r5,5,5
+R6,$01,$06,r6,6,6
+R7,$01,$07,r7,7,7
+R8,$01,$08,r8,8,8
+R9,$01,$09,r9,9,9
+R10,$01,$0a,r10,10,10
+R11,$01,$0b,r11,11,11
+R12,$01,$0c,r12,12,12
+R13,$01,$0d,r13,13,13
+R14,$01,$0e,r14,14,14
+R15,$01,$0f,r15,15,15
+
+; Float registers
+F0,$02,$00,f0,32,16
+F1,$02,$01,f1,32,17
+F2,$02,$02,f2,32,18
+F3,$02,$03,f3,32,19
+F4,$02,$04,f4,32,20
+F5,$02,$05,f5,32,21
+F6,$02,$06,f6,32,22
+F7,$02,$07,f7,32,23
+
+; MM registers
+S0,$03,$00,s0,0,0
+S1,$03,$00,s1,0,0
+D0,$03,$00,d0,0,0
+S2,$03,$00,s2,0,0
+S3,$03,$00,s3,0,0
+D1,$03,$00,d1,0,0
+S4,$03,$00,s4,0,0
+S5,$03,$00,s5,0,0
+D2,$03,$00,d2,0,0
+S6,$03,$00,s6,0,0
+S7,$03,$00,s7,0,0
+D3,$03,$00,d3,0,0
+S8,$03,$00,s8,0,0
+S9,$03,$00,s9,0,0
+D4,$03,$00,d4,0,0
+S10,$03,$00,s10,0,0
+S11,$03,$00,s11,0,0
+D5,$03,$00,d5,0,0
+S12,$03,$00,s12,0,0
+S13,$03,$00,s13,0,0
+D6,$03,$00,d6,0,0
+S14,$03,$00,s14,0,0
+S15,$03,$00,s15,0,0
+D7,$03,$00,d7,0,0
+S16,$03,$00,s16,0,0
+S17,$03,$00,s17,0,0
+D8,$03,$00,d8,0,0
+S18,$03,$00,s18,0,0
+S19,$03,$00,s19,0,0
+D9,$03,$00,d9,0,0
+S20,$03,$00,s20,0,0
+S21,$03,$00,s21,0,0
+D10,$03,$00,d10,0,0
+S22,$03,$00,s22,0,0
+S23,$03,$00,s23,0,0
+D11,$03,$00,d11,0,0
+S24,$03,$00,s24,0,0
+S25,$03,$00,s25,0,0
+D12,$03,$00,d12,0,0
+S26,$03,$00,s26,0,0
+S27,$03,$00,s27,0,0
+D13,$03,$00,d13,0,0
+S28,$03,$00,s28,0,0
+S29,$03,$00,s29,0,0
+D14,$03,$00,d14,0,0
+S30,$03,$00,s20,0,0
+S31,$03,$00,s21,0,0
+D15,$03,$00,d15,0,0

+ 759 - 0
compiler/arm/armtab.inc

@@ -0,0 +1,759 @@
+{ don't edit, this file is generated from armins.dat }
+(
+  (
+    opcode  : A_NONE;
+    ops     : 0;
+    optypes : (ot_none,ot_none,ot_none,ot_none);
+    code    : #0;
+    flags   : if_none
+  ),
+  (
+    opcode  : A_ADC;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_none);
+    code    : #4#0#160;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_ADC;
+    ops     : 4;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_reg32);
+    code    : #5#0#160;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_ADC;
+    ops     : 4;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_immediate);
+    code    : #6#0#160;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_ADC;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_immediate,ot_none);
+    code    : #7#2#160;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_ADD;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_none);
+    code    : #4#0#128;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_ADD;
+    ops     : 4;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_reg32);
+    code    : #5#0#128;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_ADD;
+    ops     : 4;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_immediate);
+    code    : #6#0#128;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_ADD;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_immediate,ot_none);
+    code    : #7#2#128;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_AND;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_none);
+    code    : #4#0#0;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_AND;
+    ops     : 4;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_reg32);
+    code    : #5#0#0;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_AND;
+    ops     : 4;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_immediate);
+    code    : #6#0#0;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_AND;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_immediate,ot_none);
+    code    : #7#2#0;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_B;
+    ops     : 1;
+    optypes : (ot_memory or ot_bits32,ot_none,ot_none,ot_none);
+    code    : #1#10;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_B;
+    ops     : 1;
+    optypes : (ot_immediate24,ot_none,ot_none,ot_none);
+    code    : #1#10;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_BIC;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_none);
+    code    : #4#1#192;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_BIC;
+    ops     : 4;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_reg32);
+    code    : #5#1#192;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_BIC;
+    ops     : 4;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_immediate);
+    code    : #6#1#192;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_BIC;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_immediate,ot_none);
+    code    : #7#3#192;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_BL;
+    ops     : 1;
+    optypes : (ot_memory or ot_bits32,ot_none,ot_none,ot_none);
+    code    : #1#11;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_BL;
+    ops     : 1;
+    optypes : (ot_immediate24,ot_none,ot_none,ot_none);
+    code    : #1#11;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_BLX;
+    ops     : 1;
+    optypes : (ot_memory or ot_bits32,ot_none,ot_none,ot_none);
+    code    : #15#15;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_BLX;
+    ops     : 1;
+    optypes : (ot_immediate24,ot_none,ot_none,ot_none);
+    code    : #15#15;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_BX;
+    ops     : 1;
+    optypes : (ot_reg32,ot_none,ot_none,ot_none);
+    code    : #3#1#47#255#16;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_CDP;
+    ops     : 2;
+    optypes : (ot_reg8,ot_reg8,ot_none,ot_none);
+    code    : #192#1#16#65;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_CMN;
+    ops     : 2;
+    optypes : (ot_reg32,ot_reg32,ot_none,ot_none);
+    code    : #12#1#96;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_CMN;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_none);
+    code    : #13#1#96;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_CMN;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_immediate,ot_none);
+    code    : #14#1#96;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_CMN;
+    ops     : 2;
+    optypes : (ot_reg32,ot_immediate,ot_none,ot_none);
+    code    : #15#3#96;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_CMP;
+    ops     : 2;
+    optypes : (ot_reg32,ot_reg32,ot_none,ot_none);
+    code    : #12#1#64;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_CMP;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_none);
+    code    : #13#1#64;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_CMP;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_immediate,ot_none);
+    code    : #14#1#64;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_CMP;
+    ops     : 2;
+    optypes : (ot_reg32,ot_immediate,ot_none,ot_none);
+    code    : #15#3#64;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_CLZ;
+    ops     : 2;
+    optypes : (ot_reg32,ot_reg32,ot_none,ot_none);
+    code    : #39#1#1;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_EOR;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_none);
+    code    : #4#0#32;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_EOR;
+    ops     : 4;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_reg32);
+    code    : #5#0#32;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_EOR;
+    ops     : 4;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_immediate);
+    code    : #6#0#32;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_EOR;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_immediate,ot_none);
+    code    : #7#2#32;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_LDC;
+    ops     : 2;
+    optypes : (ot_reg32,ot_reg32,ot_none,ot_none);
+    code    : #209#192#1#17#65;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_LDM;
+    ops     : 2;
+    optypes : (ot_memoryam4,ot_reglist,ot_none,ot_none);
+    code    : #38#129;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_LDRB;
+    ops     : 2;
+    optypes : (ot_reg32,ot_memoryam2,ot_none,ot_none);
+    code    : #23#7#16;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_LDR;
+    ops     : 2;
+    optypes : (ot_reg32,ot_memoryam2,ot_none,ot_none);
+    code    : #23#5#16;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_LDRH;
+    ops     : 2;
+    optypes : (ot_reg32,ot_immediate or ot_bits32,ot_none,ot_none);
+    code    : #34#80#176;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_LDRH;
+    ops     : 2;
+    optypes : (ot_reg32,ot_reg32,ot_none,ot_none);
+    code    : #35#80#176;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_LDRH;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_immediate or ot_bits32,ot_none);
+    code    : #36#80#176;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_LDRH;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_none);
+    code    : #37#16#176;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_LDRSB;
+    ops     : 2;
+    optypes : (ot_reg32,ot_immediate or ot_bits32,ot_none,ot_none);
+    code    : #34#80#208;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_LDRSB;
+    ops     : 2;
+    optypes : (ot_reg32,ot_reg32,ot_none,ot_none);
+    code    : #35#80#208;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_LDRSB;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_immediate or ot_bits32,ot_none);
+    code    : #36#80#208;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_LDRSB;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_none);
+    code    : #37#16#208;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_LDRSH;
+    ops     : 2;
+    optypes : (ot_reg32,ot_immediate or ot_bits32,ot_none,ot_none);
+    code    : #34#80#240;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_LDRSH;
+    ops     : 2;
+    optypes : (ot_reg32,ot_reg32,ot_none,ot_none);
+    code    : #35#80#240;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_LDRSH;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_immediate or ot_bits32,ot_none);
+    code    : #36#80#240;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_LDRSH;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_none);
+    code    : #37#16#240;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_LFM;
+    ops     : 3;
+    optypes : (ot_reg32,ot_immediate or ot_bits8,ot_fpureg,ot_none);
+    code    : #240#2#1;
+    flags   : if_fpa
+  ),
+  (
+    opcode  : A_MCR;
+    ops     : 2;
+    optypes : (ot_reg32,ot_memory or ot_bits32,ot_none,ot_none);
+    code    : #208#193#1#19#72;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_MLA;
+    ops     : 4;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_reg32);
+    code    : #21#0#32#144;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_MOV;
+    ops     : 2;
+    optypes : (ot_reg32,ot_shifterop,ot_none,ot_none);
+    code    : #8#1#160;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_MOV;
+    ops     : 2;
+    optypes : (ot_reg32,ot_immediateshifter,ot_none,ot_none);
+    code    : #8#1#160;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_MUL;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_none);
+    code    : #20#0#0#144;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_MVF;
+    ops     : 2;
+    optypes : (ot_fpureg,ot_fpureg,ot_none,ot_none);
+    code    : #242;
+    flags   : if_fpa
+  ),
+  (
+    opcode  : A_MVF;
+    ops     : 2;
+    optypes : (ot_fpureg,ot_immediatefpu,ot_none,ot_none);
+    code    : #242;
+    flags   : if_fpa
+  ),
+  (
+    opcode  : A_MVN;
+    ops     : 2;
+    optypes : (ot_reg32,ot_reg32,ot_none,ot_none);
+    code    : #8#1#224;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_MVN;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_none);
+    code    : #9#1#224;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_MVN;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_immediate,ot_none);
+    code    : #10#1#224;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_MVN;
+    ops     : 2;
+    optypes : (ot_reg32,ot_immediate,ot_none,ot_none);
+    code    : #11#3#224;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_ORR;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_none);
+    code    : #4#1#128;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_ORR;
+    ops     : 4;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_reg32);
+    code    : #5#1#128;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_ORR;
+    ops     : 4;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_immediate);
+    code    : #6#1#128;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_ORR;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_immediate,ot_none);
+    code    : #7#3#128;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_RSB;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_none);
+    code    : #4#0#96;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_RSB;
+    ops     : 4;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_reg32);
+    code    : #5#0#96;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_RSB;
+    ops     : 4;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_immediate);
+    code    : #6#0#96;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_RSB;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_immediate,ot_none);
+    code    : #7#2#96;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_RSC;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_none);
+    code    : #4#0#224;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_RSC;
+    ops     : 4;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_reg32);
+    code    : #5#0#224;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_RSC;
+    ops     : 4;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_immediate);
+    code    : #6#0#224;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_RSC;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_immediate,ot_none);
+    code    : #7#2#224;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_SBC;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_none);
+    code    : #4#0#192;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_SBC;
+    ops     : 4;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_reg32);
+    code    : #5#0#192;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_SBC;
+    ops     : 4;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_immediate);
+    code    : #6#0#192;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_SBC;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_immediate,ot_none);
+    code    : #7#2#192;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_SFM;
+    ops     : 3;
+    optypes : (ot_reg32,ot_immediate or ot_bits8,ot_fpureg,ot_none);
+    code    : #240#2#0;
+    flags   : if_fpa
+  ),
+  (
+    opcode  : A_SMLAL;
+    ops     : 4;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_reg32);
+    code    : #22#0#224#144;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_SMULL;
+    ops     : 4;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_reg32);
+    code    : #22#0#192#144;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_STM;
+    ops     : 2;
+    optypes : (ot_memoryam4,ot_reglist,ot_none,ot_none);
+    code    : #38#128;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_STR;
+    ops     : 2;
+    optypes : (ot_reg32,ot_memoryam2,ot_none,ot_none);
+    code    : #23#4#0;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_STRB;
+    ops     : 2;
+    optypes : (ot_reg32,ot_memoryam2,ot_none,ot_none);
+    code    : #23#6#0;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_STRH;
+    ops     : 2;
+    optypes : (ot_reg32,ot_immediate or ot_bits32,ot_none,ot_none);
+    code    : #34#64#176;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_STRH;
+    ops     : 2;
+    optypes : (ot_reg32,ot_reg32,ot_none,ot_none);
+    code    : #35#64#176;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_STRH;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_immediate or ot_bits32,ot_none);
+    code    : #36#64#176;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_STRH;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_none);
+    code    : #37#0#176;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_SUB;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_shifterop,ot_none);
+    code    : #4#0#64;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_SUB;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_immediateshifter,ot_none);
+    code    : #4#0#64;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_SUB;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_none);
+    code    : #4#0#64;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_SWI;
+    ops     : 1;
+    optypes : (ot_immediate,ot_none,ot_none,ot_none);
+    code    : #2#15;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_SWP;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_none);
+    code    : #39#1#144;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_SWPB;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_none);
+    code    : #39#1#144;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_TEQ;
+    ops     : 2;
+    optypes : (ot_reg32,ot_reg32,ot_none,ot_none);
+    code    : #12#1#32;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_TEQ;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_none);
+    code    : #13#1#32;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_TEQ;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_immediate,ot_none);
+    code    : #14#1#32;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_TEQ;
+    ops     : 2;
+    optypes : (ot_reg32,ot_immediate,ot_none,ot_none);
+    code    : #15#3#32;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_TST;
+    ops     : 2;
+    optypes : (ot_reg32,ot_reg32,ot_none,ot_none);
+    code    : #12#1#0;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_TST;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_none);
+    code    : #13#1#0;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_TST;
+    ops     : 3;
+    optypes : (ot_reg32,ot_reg32,ot_immediate,ot_none);
+    code    : #14#1#0;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_TST;
+    ops     : 2;
+    optypes : (ot_reg32,ot_immediate,ot_none,ot_none);
+    code    : #15#3#0;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_UMLAL;
+    ops     : 4;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_reg32);
+    code    : #22#0#160#144;
+    flags   : if_arm7
+  ),
+  (
+    opcode  : A_UMULL;
+    ops     : 4;
+    optypes : (ot_reg32,ot_reg32,ot_reg32,ot_reg32);
+    code    : #22#0#128#144;
+    flags   : if_arm7
+  )
+);

+ 1712 - 0
compiler/arm/cgcpu.pas

@@ -0,0 +1,1712 @@
+{
+
+    Copyright (c) 2003 by Florian Klaempfl
+    Member of the Free Pascal development team
+
+    This unit implements the code generator for the ARM
+
+    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,symtype,symdef,
+       cgbase,cgutils,cgobj,
+       aasmbase,aasmcpu,aasmtai,
+       parabase,
+       cpubase,cpuinfo,node,cg64f32,rgcpu;
+
+
+    type
+      tcgarm = class(tcg)
+        { true, if the next arithmetic operation should modify the flags }
+        cgsetflags : boolean;
+        procedure init_register_allocators;override;
+        procedure done_register_allocators;override;
+
+        procedure a_param_const(list : taasmoutput;size : tcgsize;a : aint;const paraloc : TCGPara);override;
+        procedure a_param_ref(list : taasmoutput;size : tcgsize;const r : treference;const paraloc : TCGPara);override;
+        procedure a_paramaddr_ref(list : taasmoutput;const r : treference;const paraloc : TCGPara);override;
+
+        procedure a_call_name(list : taasmoutput;const s : string);override;
+        procedure a_call_reg(list : taasmoutput;reg: tregister); override;
+
+        procedure a_op_const_reg(list : taasmoutput; Op: TOpCG; size: TCGSize; a: aint; reg: TRegister); override;
+        procedure a_op_reg_reg(list : taasmoutput; Op: TOpCG; size: TCGSize; src, dst: TRegister); override;
+
+        procedure a_op_const_reg_reg(list: taasmoutput; op: TOpCg;
+          size: tcgsize; a: aint; src, dst: tregister); override;
+        procedure a_op_reg_reg_reg(list: taasmoutput; op: TOpCg;
+          size: tcgsize; src1, src2, dst: tregister); override;
+        procedure a_op_const_reg_reg_checkoverflow(list: taasmoutput; op: TOpCg; size: tcgsize; a: aint; src, dst: tregister;setflags : boolean;var ovloc : tlocation);override;
+        procedure a_op_reg_reg_reg_checkoverflow(list: taasmoutput; op: TOpCg; size: tcgsize; src1, src2, dst: tregister;setflags : boolean;var ovloc : tlocation);override;
+
+        { move instructions }
+        procedure a_load_const_reg(list : taasmoutput; size: tcgsize; a : aint;reg : tregister);override;
+        procedure a_load_reg_ref(list : taasmoutput; fromsize, tosize: tcgsize; reg : tregister;const ref : treference);override;
+        procedure a_load_ref_reg(list : taasmoutput; fromsize, tosize : tcgsize;const Ref : treference;reg : tregister);override;
+        procedure a_load_reg_reg(list : taasmoutput; fromsize, tosize : tcgsize;reg1,reg2 : tregister);override;
+
+        { fpu move instructions }
+        procedure a_loadfpu_reg_reg(list: taasmoutput; size: tcgsize; reg1, reg2: tregister); override;
+        procedure a_loadfpu_ref_reg(list: taasmoutput; size: tcgsize; const ref: treference; reg: tregister); override;
+        procedure a_loadfpu_reg_ref(list: taasmoutput; size: tcgsize; reg: tregister; const ref: treference); override;
+
+        procedure a_paramfpu_ref(list : taasmoutput;size : tcgsize;const ref : treference;const paraloc : TCGPara);override;
+        {  comparison operations }
+        procedure a_cmp_const_reg_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp;a : aint;reg : tregister;
+          l : tasmlabel);override;
+        procedure a_cmp_reg_reg_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp;reg1,reg2 : tregister;l : tasmlabel); override;
+
+        procedure a_jmp_name(list : taasmoutput;const s : string); override;
+        procedure a_jmp_always(list : taasmoutput;l: tasmlabel); override;
+        procedure a_jmp_flags(list : taasmoutput;const f : TResFlags;l: tasmlabel); override;
+
+        procedure g_flags2reg(list: taasmoutput; size: TCgSize; const f: TResFlags; reg: TRegister); override;
+
+        procedure g_proc_entry(list : taasmoutput;localsize : longint;nostackframe:boolean);override;
+        procedure g_proc_exit(list : taasmoutput;parasize : longint;nostackframe:boolean); override;
+
+        procedure a_loadaddr_ref_reg(list : taasmoutput;const ref : treference;r : tregister);override;
+
+        procedure g_concatcopy(list : taasmoutput;const source,dest : treference;len : aint);override;
+        procedure g_concatcopy_unaligned(list : taasmoutput;const source,dest : treference;len : aint);override;
+        procedure g_concatcopy_move(list : taasmoutput;const source,dest : treference;len : aint);
+        procedure g_concatcopy_internal(list : taasmoutput;const source,dest : treference;len : aint;aligned : boolean);
+
+        procedure g_overflowcheck(list: taasmoutput; const l: tlocation; def: tdef); override;
+        procedure g_overflowCheck_loc(List:TAasmOutput;const Loc:TLocation;def:TDef;ovloc : tlocation);override;
+
+        procedure g_save_standard_registers(list : taasmoutput);override;
+        procedure g_restore_standard_registers(list : taasmoutput);override;
+
+        procedure a_jmp_cond(list : taasmoutput;cond : TOpCmp;l: tasmlabel);
+        procedure fixref(list : taasmoutput;var ref : treference);
+        procedure handle_load_store(list:taasmoutput;op: tasmop;oppostfix : toppostfix;reg:tregister;ref: treference);
+
+        procedure g_intf_wrapper(list: taasmoutput; procdef: tprocdef; const labelname: string; ioffset: longint);override;
+      end;
+
+      tcg64farm = class(tcg64f32)
+        procedure a_op64_reg_reg(list : taasmoutput;op:TOpCG;size : tcgsize;regsrc,regdst : tregister64);override;
+        procedure a_op64_const_reg(list : taasmoutput;op:TOpCG;size : tcgsize;value : int64;reg : tregister64);override;
+        procedure a_op64_const_reg_reg(list: taasmoutput;op:TOpCG;size : tcgsize;value : int64;regsrc,regdst : tregister64);override;
+        procedure a_op64_reg_reg_reg(list: taasmoutput;op:TOpCG;size : tcgsize;regsrc1,regsrc2,regdst : tregister64);override;
+        procedure a_op64_const_reg_reg_checkoverflow(list: taasmoutput;op:TOpCG;size : tcgsize;value : int64;regsrc,regdst : tregister64;setflags : boolean;var ovloc : tlocation);override;
+        procedure a_op64_reg_reg_reg_checkoverflow(list: taasmoutput;op:TOpCG;size : tcgsize;regsrc1,regsrc2,regdst : tregister64;setflags : boolean;var ovloc : tlocation);override;
+      end;
+
+    const
+      OpCmp2AsmCond : Array[topcmp] of TAsmCond = (C_NONE,C_EQ,C_GT,
+                           C_LT,C_GE,C_LE,C_NE,C_LS,C_CC,C_CS,C_HI);
+
+    function get_fpu_postfix(def : tdef) : toppostfix;
+
+  implementation
+
+
+    uses
+       globals,verbose,systems,cutils,
+       fmodule,
+       symconst,symsym,
+       tgobj,
+       procinfo,cpupi,
+       paramgr;
+
+
+    function get_fpu_postfix(def : tdef) : toppostfix;
+      begin
+        if def.deftype=floatdef then
+          begin
+            case tfloatdef(def).typ of
+              s32real:
+                result:=PF_S;
+              s64real:
+                result:=PF_D;
+              s80real:
+                result:=PF_E;
+              else
+                internalerror(200401272);
+            end;
+          end
+        else
+          internalerror(200401271);
+      end;
+
+
+    procedure tcgarm.init_register_allocators;
+      begin
+        inherited init_register_allocators;
+        { currently, we save R14 always, so we can use it }
+        rg[R_INTREGISTER]:=trgintcpu.create(R_INTREGISTER,R_SUBWHOLE,
+            [RS_R0,RS_R1,RS_R2,RS_R3,RS_R4,RS_R5,RS_R6,RS_R7,RS_R8,
+             RS_R9,RS_R10,RS_R12,RS_R14],first_int_imreg,[]);
+        rg[R_FPUREGISTER]:=trgcpu.create(R_FPUREGISTER,R_SUBNONE,
+            [RS_F0,RS_F1,RS_F2,RS_F3,RS_F4,RS_F5,RS_F6,RS_F7],first_fpu_imreg,[]);
+        rg[R_MMREGISTER]:=trgcpu.create(R_MMREGISTER,R_SUBNONE,
+            [RS_S0,RS_S1,RS_R2,RS_R3,RS_R4,RS_S31],first_mm_imreg,[]);
+      end;
+
+
+    procedure tcgarm.done_register_allocators;
+      begin
+        rg[R_INTREGISTER].free;
+        rg[R_FPUREGISTER].free;
+        rg[R_MMREGISTER].free;
+        inherited done_register_allocators;
+      end;
+
+
+    procedure tcgarm.a_param_const(list : taasmoutput;size : tcgsize;a : aint;const paraloc : TCGPara);
+      var
+        ref: treference;
+      begin
+        paraloc.check_simple_location;
+        case paraloc.location^.loc of
+          LOC_REGISTER,LOC_CREGISTER:
+            a_load_const_reg(list,size,a,paraloc.location^.register);
+          LOC_REFERENCE:
+            begin
+               reference_reset(ref);
+               ref.base:=paraloc.location^.reference.index;
+               ref.offset:=paraloc.location^.reference.offset;
+               a_load_const_ref(list,size,a,ref);
+            end;
+          else
+            internalerror(2002081101);
+        end;
+      end;
+
+
+    procedure tcgarm.a_param_ref(list : taasmoutput;size : tcgsize;const r : treference;const paraloc : TCGPara);
+      var
+        tmpref, ref: treference;
+        location: pcgparalocation;
+        sizeleft: aint;
+      begin
+        location := paraloc.location;
+        tmpref := r;
+        sizeleft := paraloc.intsize;
+        while assigned(location) do
+          begin
+            case location^.loc of
+              LOC_REGISTER,LOC_CREGISTER:
+                a_load_ref_reg(list,location^.size,location^.size,tmpref,location^.register);
+              LOC_REFERENCE:
+                begin
+                   reference_reset_base(ref,location^.reference.index,location^.reference.offset);
+                   g_concatcopy(list,tmpref,ref,sizeleft);
+                   if assigned(location^.next) then
+                     internalerror(2005010710);
+                end;
+              LOC_FPUREGISTER,LOC_CFPUREGISTER:
+                case location^.size of
+                   OS_F32, OS_F64:
+                     a_loadfpu_ref_reg(list,location^.size,tmpref,location^.register);
+                   else
+                     internalerror(2002072801);
+                end;
+              LOC_VOID:
+                begin
+                  // nothing to do
+                end;
+              else
+                internalerror(2002081103);
+            end;
+            inc(tmpref.offset,tcgsize2size[location^.size]);
+            dec(sizeleft,tcgsize2size[location^.size]);
+            location := location^.next;
+          end;
+      end;
+
+
+    procedure tcgarm.a_paramaddr_ref(list : taasmoutput;const r : treference;const paraloc : TCGPara);
+      var
+        ref: treference;
+        tmpreg: tregister;
+      begin
+        paraloc.check_simple_location;
+        case paraloc.location^.loc of
+          LOC_REGISTER,LOC_CREGISTER:
+            a_loadaddr_ref_reg(list,r,paraloc.location^.register);
+          LOC_REFERENCE:
+            begin
+              reference_reset(ref);
+              ref.base := paraloc.location^.reference.index;
+              ref.offset := paraloc.location^.reference.offset;
+              tmpreg := getintregister(list,OS_ADDR);
+              a_loadaddr_ref_reg(list,r,tmpreg);
+              a_load_reg_ref(list,OS_ADDR,OS_ADDR,tmpreg,ref);
+            end;
+          else
+            internalerror(2002080701);
+        end;
+      end;
+
+
+    procedure tcgarm.a_call_name(list : taasmoutput;const s : string);
+      begin
+        list.concat(taicpu.op_sym(A_BL,objectlibrary.newasmsymbol(s,AB_EXTERNAL,AT_FUNCTION)));
+{
+        the compiler does not properly set this flag anymore in pass 1, and
+        for now we only need it after pass 2 (I hope) (JM)
+          if not(pi_do_call in current_procinfo.flags) then
+            internalerror(2003060703);
+}
+        include(current_procinfo.flags,pi_do_call);
+      end;
+
+
+    procedure tcgarm.a_call_reg(list : taasmoutput;reg: tregister);
+      var
+         r : tregister;
+      begin
+        list.concat(taicpu.op_reg_reg(A_MOV,NR_R14,NR_PC));
+        list.concat(taicpu.op_reg_reg(A_MOV,NR_PC,reg));
+{
+        the compiler does not properly set this flag anymore in pass 1, and
+        for now we only need it after pass 2 (I hope) (JM)
+          if not(pi_do_call in current_procinfo.flags) then
+            internalerror(2003060703);
+}
+        include(current_procinfo.flags,pi_do_call);
+      end;
+
+
+     procedure tcgarm.a_op_const_reg(list : taasmoutput; Op: TOpCG; size: TCGSize; a: aint; reg: TRegister);
+       begin
+          a_op_const_reg_reg(list,op,size,a,reg,reg);
+       end;
+
+
+     procedure tcgarm.a_op_reg_reg(list : taasmoutput; Op: TOpCG; size: TCGSize; src, dst: TRegister);
+       begin
+         case op of
+           OP_NEG:
+             list.concat(taicpu.op_reg_reg_const(A_RSB,dst,src,0));
+           OP_NOT:
+             begin
+               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
+             a_op_reg_reg_reg(list,op,OS_32,src,dst,dst);
+         end;
+       end;
+
+
+    const
+      op_reg_reg_opcg2asmop: array[TOpCG] of tasmop =
+        (A_NONE,A_ADD,A_AND,A_NONE,A_NONE,A_MUL,A_MUL,A_NONE,A_NONE,A_ORR,
+         A_NONE,A_NONE,A_NONE,A_SUB,A_EOR);
+
+
+    procedure tcgarm.a_op_const_reg_reg(list: taasmoutput; op: TOpCg;
+      size: tcgsize; a: aint; src, dst: tregister);
+      var
+        ovloc : tlocation;
+      begin
+        a_op_const_reg_reg_checkoverflow(list,op,size,a,src,dst,false,ovloc);
+      end;
+
+
+    procedure tcgarm.a_op_reg_reg_reg(list: taasmoutput; op: TOpCg;
+      size: tcgsize; src1, src2, dst: tregister);
+      var
+        ovloc : tlocation;
+      begin
+        a_op_reg_reg_reg_checkoverflow(list,op,size,src1,src2,dst,false,ovloc);
+      end;
+
+
+    procedure tcgarm.a_op_const_reg_reg_checkoverflow(list: taasmoutput; op: TOpCg; size: tcgsize; a: aint; src, dst: tregister;setflags : boolean;var ovloc : tlocation);
+      var
+        shift : byte;
+        tmpreg : tregister;
+        so : tshifterop;
+        l1 : longint;
+      begin
+        ovloc.loc:=LOC_VOID;
+        if is_shifter_const(-a,shift) then
+          case op of
+            OP_ADD:
+              begin
+                op:=OP_SUB;
+                a:=dword(-a);
+              end;
+            OP_SUB:
+              begin
+                op:=OP_ADD;
+                a:=dword(-a);
+              end
+          end;
+
+        if is_shifter_const(a,shift) and not(op in [OP_IMUL,OP_MUL]) then
+          case op of
+            OP_NEG,OP_NOT,
+            OP_DIV,OP_IDIV:
+              internalerror(200308281);
+            OP_SHL:
+              begin
+                if a>32 then
+                  internalerror(200308291);
+                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_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_SAR:
+              begin
+                if a>32 then
+                  internalerror(200308291);
+                if a<>0 then
+                  begin
+                    shifterop_reset(so);
+                    so.shiftmode:=SM_ASR;
+                    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;
+            else
+              list.concat(setoppostfix(
+                  taicpu.op_reg_reg_const(op_reg_reg_opcg2asmop[op],dst,src,a),toppostfix(ord(cgsetflags or setflags)*ord(PF_S))
+              ));
+              if (cgsetflags or setflags) and (size in [OS_8,OS_16,OS_32]) then
+                begin
+                  ovloc.loc:=LOC_FLAGS;
+                  case op of
+                    OP_ADD:
+                      ovloc.resflags:=F_CS;
+                    OP_SUB:
+                      ovloc.resflags:=F_CC;
+                  end;
+                end;
+          end
+        else
+          begin
+            { there could be added some more sophisticated optimizations }
+            if (op in [OP_MUL,OP_IMUL]) and (a=1) then
+              a_load_reg_reg(list,size,size,src,dst)
+            else if (op in [OP_MUL,OP_IMUL]) and (a=0) then
+              a_load_const_reg(list,size,0,dst)
+            else if (op in [OP_IMUL]) and (a=-1) then
+              a_op_reg_reg(list,OP_NEG,size,src,dst)
+            { we do this here instead in the peephole optimizer because
+              it saves us a register }
+            else if (op in [OP_MUL,OP_IMUL]) and ispowerof2(a,l1) and not(cgsetflags or setflags) then
+              a_op_const_reg_reg(list,OP_SHL,size,l1,src,dst)
+            else
+              begin
+                tmpreg:=getintregister(list,size);
+                a_load_const_reg(list,size,a,tmpreg);
+                a_op_reg_reg_reg_checkoverflow(list,op,size,tmpreg,src,dst,setflags,ovloc);
+              end;
+          end;
+      end;
+
+
+    procedure tcgarm.a_op_reg_reg_reg_checkoverflow(list: taasmoutput; op: TOpCg; size: tcgsize; src1, src2, dst: tregister;setflags : boolean;var ovloc : tlocation);
+      var
+        so : tshifterop;
+        tmpreg,overflowreg : tregister;
+        asmop : tasmop;
+      begin
+        ovloc.loc:=LOC_VOID;
+        case op of
+          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:
+            begin
+              shifterop_reset(so);
+              so.rs:=src1;
+              so.shiftmode:=SM_ASR;
+              list.concat(taicpu.op_reg_reg_shifterop(A_MOV,dst,src2,so));
+            end;
+          OP_IMUL,
+          OP_MUL:
+            begin
+              if cgsetflags or setflags then
+                begin
+                  overflowreg:=getintregister(list,size);
+                  if op=OP_IMUL then
+                    asmop:=A_SMULL
+                  else
+                    asmop:=A_UMULL;
+                  { the arm doesn't allow that rd and rm are the same }
+                  if dst=src2 then
+                    begin
+                      if dst<>src1 then
+                        list.concat(taicpu.op_reg_reg_reg_reg(asmop,dst,overflowreg,src1,src2))
+                      else
+                        begin
+                          tmpreg:=getintregister(list,size);
+                          a_load_reg_reg(list,size,size,src2,dst);
+                          list.concat(taicpu.op_reg_reg_reg_reg(asmop,dst,overflowreg,tmpreg,src1));
+                        end;
+                    end
+                  else
+                    list.concat(taicpu.op_reg_reg_reg_reg(asmop,dst,overflowreg,src2,src1));
+                  if op=OP_IMUL then
+                    begin
+                      shifterop_reset(so);
+                      so.shiftmode:=SM_ASR;
+                      so.shiftimm:=31;
+                      list.concat(taicpu.op_reg_reg_shifterop(A_CMP,overflowreg,dst,so));
+                    end
+                  else
+                    list.concat(taicpu.op_reg_const(A_CMP,overflowreg,0));
+
+                   ovloc.loc:=LOC_FLAGS;
+                   ovloc.resflags:=F_NE;
+                end
+              else
+                begin
+                  { the arm doesn't allow that rd and rm are the same }
+                  if dst=src2 then
+                    begin
+                      if dst<>src1 then
+                        list.concat(taicpu.op_reg_reg_reg(A_MUL,dst,src1,src2))
+                      else
+                        begin
+                          tmpreg:=getintregister(list,size);
+                          a_load_reg_reg(list,size,size,src2,dst);
+                          list.concat(taicpu.op_reg_reg_reg(A_MUL,dst,tmpreg,src1));
+                        end;
+                    end
+                  else
+                    list.concat(taicpu.op_reg_reg_reg(A_MUL,dst,src2,src1));
+                end;
+            end;
+          else
+            list.concat(setoppostfix(
+                taicpu.op_reg_reg_reg(op_reg_reg_opcg2asmop[op],dst,src2,src1),toppostfix(ord(cgsetflags or setflags)*ord(PF_S))
+              ));
+        end;
+      end;
+
+
+     procedure tcgarm.a_load_const_reg(list : taasmoutput; size: tcgsize; a : aint;reg : tregister);
+       var
+          imm_shift : byte;
+          l : tasmlabel;
+          hr : treference;
+       begin
+          if not(size in [OS_8,OS_S8,OS_16,OS_S16,OS_32,OS_S32]) then
+            internalerror(2002090902);
+          if is_shifter_const(a,imm_shift) then
+            list.concat(taicpu.op_reg_const(A_MOV,reg,a))
+          else if is_shifter_const(not(a),imm_shift) then
+            list.concat(taicpu.op_reg_const(A_MVN,reg,not(a)))
+          else
+            begin
+               reference_reset(hr);
+
+               objectlibrary.getjumplabel(l);
+               cg.a_label(current_procinfo.aktlocaldata,l);
+               hr.symboldata:=current_procinfo.aktlocaldata.last;
+               current_procinfo.aktlocaldata.concat(tai_const.Create_32bit(longint(a)));
+
+               hr.symbol:=l;
+               list.concat(taicpu.op_reg_ref(A_LDR,reg,hr));
+            end;
+       end;
+
+
+    procedure tcgarm.handle_load_store(list:taasmoutput;op: tasmop;oppostfix : toppostfix;reg:tregister;ref: treference);
+      var
+        tmpreg : tregister;
+        tmpref : treference;
+        l : tasmlabel;
+      begin
+        tmpreg:=NR_NO;
+
+        { Be sure to have a base register }
+        if (ref.base=NR_NO) then
+          begin
+            if ref.shiftmode<>SM_None then
+              internalerror(200308294);
+            ref.base:=ref.index;
+            ref.index:=NR_NO;
+          end;
+
+        { absolute symbols can't be handled directly, we've to store the symbol reference
+          in the text segment and access it pc relative
+
+          For now, we assume that references where base or index equals to PC are already
+          relative, all other references are assumed to be absolute and thus they need
+          to be handled extra.
+
+          A proper solution would be to change refoptions to a set and store the information
+          if the symbol is absolute or relative there.
+        }
+
+        if (assigned(ref.symbol) and
+            not(is_pc(ref.base)) and
+            not(is_pc(ref.index))
+           ) or
+           { [#xxx] isn't a valid address operand }
+           ((ref.base=NR_NO) and (ref.index=NR_NO)) or
+           (ref.offset<-4095) or
+           (ref.offset>4095) or
+           ((oppostfix in [PF_SB,PF_H,PF_SH]) and
+            ((ref.offset<-255) or
+             (ref.offset>255)
+            )
+           ) or
+           ((op in [A_LDF,A_STF]) and
+            ((ref.offset<-1020) or
+             (ref.offset>1020)
+            )
+           ) then
+          begin
+            reference_reset(tmpref);
+
+            { load symbol }
+            tmpreg:=getintregister(list,OS_INT);
+            if assigned(ref.symbol) then
+              begin
+                objectlibrary.getjumplabel(l);
+                cg.a_label(current_procinfo.aktlocaldata,l);
+                tmpref.symboldata:=current_procinfo.aktlocaldata.last;
+
+                current_procinfo.aktlocaldata.concat(tai_const.create_sym_offset(ref.symbol,ref.offset));
+
+                { load consts entry }
+                tmpref.symbol:=l;
+                tmpref.base:=NR_R15;
+                list.concat(taicpu.op_reg_ref(A_LDR,tmpreg,tmpref));
+              end
+            else
+              a_load_const_reg(list,OS_ADDR,ref.offset,tmpreg);
+
+            if (ref.base<>NR_NO) then
+              begin
+                if ref.index<>NR_NO then
+                  begin
+                    list.concat(taicpu.op_reg_reg_reg(A_ADD,tmpreg,ref.base,tmpreg));
+                    ref.base:=tmpreg;
+                  end
+                else
+                  begin
+                    ref.index:=tmpreg;
+                    ref.shiftimm:=0;
+                    ref.signindex:=1;
+                    ref.shiftmode:=SM_None;
+                  end;
+              end
+            else
+              ref.base:=tmpreg;
+            ref.offset:=0;
+            ref.symbol:=nil;
+          end;
+
+        if (ref.base<>NR_NO) and (ref.index<>NR_NO) and (ref.offset<>0) then
+          begin
+            if tmpreg<>NR_NO then
+              a_op_const_reg_reg(list,OP_ADD,OS_ADDR,ref.offset,tmpreg,tmpreg)
+            else
+              begin
+                tmpreg:=getintregister(list,OS_ADDR);
+                a_op_const_reg_reg(list,OP_ADD,OS_ADDR,ref.offset,ref.base,tmpreg);
+                ref.base:=tmpreg;
+              end;
+            ref.offset:=0;
+          end;
+
+        { floating point operations have only limited references
+          we expect here, that a base is already set }
+        if (op in [A_LDF,A_STF]) and (ref.index<>NR_NO) then
+          begin
+            if ref.shiftmode<>SM_none then
+              internalerror(200309121);
+            if tmpreg<>NR_NO then
+              begin
+                if ref.base=tmpreg then
+                  begin
+                    if ref.signindex<0 then
+                      list.concat(taicpu.op_reg_reg_reg(A_SUB,tmpreg,tmpreg,ref.index))
+                    else
+                      list.concat(taicpu.op_reg_reg_reg(A_ADD,tmpreg,tmpreg,ref.index));
+                    ref.index:=NR_NO;
+                  end
+                else
+                  begin
+                    if ref.index<>tmpreg then
+                      internalerror(200403161);
+                    if ref.signindex<0 then
+                      list.concat(taicpu.op_reg_reg_reg(A_SUB,tmpreg,ref.base,tmpreg))
+                    else
+                      list.concat(taicpu.op_reg_reg_reg(A_ADD,tmpreg,ref.base,tmpreg));
+                    ref.base:=tmpreg;
+                    ref.index:=NR_NO;
+                  end;
+              end
+            else
+              begin
+                tmpreg:=getintregister(list,OS_ADDR);
+                list.concat(taicpu.op_reg_reg_reg(A_ADD,tmpreg,ref.base,ref.index));
+                ref.base:=tmpreg;
+                ref.index:=NR_NO;
+              end;
+          end;
+        list.concat(setoppostfix(taicpu.op_reg_ref(op,reg,ref),oppostfix));
+      end;
+
+
+     procedure tcgarm.a_load_reg_ref(list : taasmoutput; fromsize, tosize: tcgsize; reg : tregister;const ref : treference);
+       var
+         oppostfix:toppostfix;
+       begin
+         case ToSize of
+           { signed integer registers }
+           OS_8,
+           OS_S8:
+             oppostfix:=PF_B;
+           OS_16,
+           OS_S16:
+             oppostfix:=PF_H;
+           OS_32,
+           OS_S32:
+             oppostfix:=PF_None;
+           else
+             InternalError(200308295);
+         end;
+         handle_load_store(list,A_STR,oppostfix,reg,ref);
+       end;
+
+
+     procedure tcgarm.a_load_ref_reg(list : taasmoutput; fromsize, tosize : tcgsize;const Ref : treference;reg : tregister);
+       var
+         oppostfix:toppostfix;
+       begin
+         case FromSize of
+           { signed integer registers }
+           OS_8:
+             oppostfix:=PF_B;
+           OS_S8:
+             oppostfix:=PF_SB;
+           OS_16:
+             oppostfix:=PF_H;
+           OS_S16:
+             oppostfix:=PF_SH;
+           OS_32,
+           OS_S32:
+             oppostfix:=PF_None;
+           else
+             InternalError(200308291);
+         end;
+         handle_load_store(list,A_LDR,oppostfix,reg,ref);
+       end;
+
+
+     procedure tcgarm.a_load_reg_reg(list : taasmoutput; fromsize, tosize : tcgsize;reg1,reg2 : tregister);
+       var
+         instr: taicpu;
+         so : tshifterop;
+       begin
+         shifterop_reset(so);
+         if (tcgsize2size[tosize] < tcgsize2size[fromsize]) or
+            (
+              (tcgsize2size[tosize] = tcgsize2size[fromsize]) and
+             (tosize <> fromsize) and
+             not(fromsize in [OS_32,OS_S32])
+            ) then
+           begin
+             case tosize of
+               OS_8:
+                 list.concat(taicpu.op_reg_reg_const(A_AND,
+                   reg2,reg1,$ff));
+               OS_S8:
+                 begin
+                   so.shiftmode:=SM_LSL;
+                   so.shiftimm:=24;
+                   list.concat(taicpu.op_reg_reg_shifterop(A_MOV,reg2,reg1,so));
+                   so.shiftmode:=SM_ASR;
+                   so.shiftimm:=24;
+                   list.concat(taicpu.op_reg_reg_shifterop(A_MOV,reg2,reg2,so));
+                 end;
+               OS_16:
+                 begin
+                   so.shiftmode:=SM_LSL;
+                   so.shiftimm:=16;
+                   list.concat(taicpu.op_reg_reg_shifterop(A_MOV,reg2,reg1,so));
+                   so.shiftmode:=SM_LSR;
+                   so.shiftimm:=16;
+                   list.concat(taicpu.op_reg_reg_shifterop(A_MOV,reg2,reg2,so));
+                 end;
+               OS_S16:
+                 begin
+                   so.shiftmode:=SM_LSL;
+                   so.shiftimm:=16;
+                   list.concat(taicpu.op_reg_reg_shifterop(A_MOV,reg2,reg1,so));
+                   so.shiftmode:=SM_ASR;
+                   so.shiftimm:=16;
+                   list.concat(taicpu.op_reg_reg_shifterop(A_MOV,reg2,reg2,so));
+                 end;
+               OS_32,OS_S32:
+                 begin
+                   instr:=taicpu.op_reg_reg(A_MOV,reg2,reg1);
+                   list.concat(instr);
+                   add_move_instruction(instr);
+                 end;
+               else internalerror(2002090901);
+             end;
+           end
+         else
+           begin
+             if reg1<>reg2 then
+               begin
+                 { same size, only a register mov required }
+                 instr:=taicpu.op_reg_reg(A_MOV,reg2,reg1);
+                 list.Concat(instr);
+                 { Notify the register allocator that we have written a move instruction so
+                   it can try to eliminate it. }
+                 add_move_instruction(instr);
+               end;
+           end;
+       end;
+
+
+    procedure tcgarm.a_paramfpu_ref(list : taasmoutput;size : tcgsize;const ref : treference;const paraloc : TCGPara);
+      var
+         href,href2 : treference;
+         hloc : pcgparalocation;
+      begin
+        href:=ref;
+        hloc:=paraloc.location;
+        while assigned(hloc) do
+          begin
+            case hloc^.loc of
+              LOC_FPUREGISTER,LOC_CFPUREGISTER:
+                a_loadfpu_ref_reg(list,size,ref,hloc^.register);
+              LOC_REGISTER :
+                a_load_ref_reg(list,hloc^.size,hloc^.size,href,hloc^.register);
+              LOC_REFERENCE :
+                begin
+                  reference_reset_base(href2,hloc^.reference.index,hloc^.reference.offset);
+                  a_load_ref_ref(list,hloc^.size,hloc^.size,href,href2);
+                end;
+              else
+                internalerror(200408241);
+           end;
+           inc(href.offset,tcgsize2size[hloc^.size]);
+           hloc:=hloc^.next;
+         end;
+      end;
+
+
+     procedure tcgarm.a_loadfpu_reg_reg(list: taasmoutput; size: tcgsize; reg1, reg2: tregister);
+       begin
+         list.concat(setoppostfix(taicpu.op_reg_reg(A_MVF,reg2,reg1),cgsize2fpuoppostfix[size]));
+       end;
+
+
+     procedure tcgarm.a_loadfpu_ref_reg(list: taasmoutput; size: tcgsize; const ref: treference; reg: tregister);
+       var
+         oppostfix:toppostfix;
+       begin
+         case size of
+           OS_F32:
+             oppostfix:=PF_S;
+           OS_F64:
+             oppostfix:=PF_D;
+           OS_F80:
+             oppostfix:=PF_E;
+           else
+             InternalError(200309021);
+         end;
+         handle_load_store(list,A_LDF,oppostfix,reg,ref);
+       end;
+
+
+     procedure tcgarm.a_loadfpu_reg_ref(list: taasmoutput; size: tcgsize; reg: tregister; const ref: treference);
+       var
+         oppostfix:toppostfix;
+       begin
+         case size of
+           OS_F32:
+             oppostfix:=PF_S;
+           OS_F64:
+             oppostfix:=PF_D;
+           OS_F80:
+             oppostfix:=PF_E;
+           else
+             InternalError(200309022);
+         end;
+         handle_load_store(list,A_STF,oppostfix,reg,ref);
+       end;
+
+
+    {  comparison operations }
+    procedure tcgarm.a_cmp_const_reg_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp;a : aint;reg : tregister;
+      l : tasmlabel);
+      var
+        tmpreg : tregister;
+        b : byte;
+      begin
+        if is_shifter_const(a,b) then
+          list.concat(taicpu.op_reg_const(A_CMP,reg,a))
+        { CMN reg,0 and CMN reg,$80000000 are different from CMP reg,$ffffffff
+          and CMP reg,$7fffffff regarding the flags according to the ARM manual }
+        else if (a<>$7fffffff) and (a<>-1) and is_shifter_const(-a,b) then
+          list.concat(taicpu.op_reg_const(A_CMN,reg,-a))
+        else
+          begin
+            tmpreg:=getintregister(list,size);
+            a_load_const_reg(list,size,a,tmpreg);
+            list.concat(taicpu.op_reg_reg(A_CMP,reg,tmpreg));
+          end;
+        a_jmp_cond(list,cmp_op,l);
+      end;
+
+
+    procedure tcgarm.a_cmp_reg_reg_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp;reg1,reg2 : tregister;l : tasmlabel);
+      begin
+        list.concat(taicpu.op_reg_reg(A_CMP,reg2,reg1));
+        a_jmp_cond(list,cmp_op,l);
+      end;
+
+
+    procedure tcgarm.a_jmp_name(list : taasmoutput;const s : string);
+      begin
+        list.concat(taicpu.op_sym(A_B,objectlibrary.newasmsymbol(s,AB_EXTERNAL,AT_FUNCTION)));
+      end;
+
+
+    procedure tcgarm.a_jmp_always(list : taasmoutput;l: tasmlabel);
+      begin
+        list.concat(taicpu.op_sym(A_B,l));
+      end;
+
+
+    procedure tcgarm.a_jmp_flags(list : taasmoutput;const f : TResFlags;l: tasmlabel);
+      var
+        ai : taicpu;
+      begin
+        ai:=setcondition(taicpu.op_sym(A_B,l),flags_to_cond(f));
+        ai.is_jmp:=true;
+        list.concat(ai);
+      end;
+
+
+    procedure tcgarm.g_flags2reg(list: taasmoutput; size: TCgSize; const f: TResFlags; reg: TRegister);
+      var
+        ai : taicpu;
+      begin
+        list.concat(setcondition(taicpu.op_reg_const(A_MOV,reg,1),flags_to_cond(f)));
+        list.concat(setcondition(taicpu.op_reg_const(A_MOV,reg,0),inverse_cond(flags_to_cond(f))));
+      end;
+
+
+    procedure tcgarm.g_proc_entry(list : taasmoutput;localsize : longint;nostackframe:boolean);
+      var
+         ref : treference;
+         shift : byte;
+         firstfloatreg,lastfloatreg,
+         r : byte;
+      begin
+        LocalSize:=align(LocalSize,4);
+        if not(nostackframe) then
+          begin
+            firstfloatreg:=RS_NO;
+            { save floating point registers? }
+            for r:=RS_F0 to RS_F7 do
+              if r in rg[R_FPUREGISTER].used_in_proc-paramanager.get_volatile_registers_fpu(pocall_stdcall) then
+                begin
+                  if firstfloatreg=RS_NO then
+                    firstfloatreg:=r;
+                  lastfloatreg:=r;
+                end;
+            a_reg_alloc(list,NR_STACK_POINTER_REG);
+            a_reg_alloc(list,NR_FRAME_POINTER_REG);
+            a_reg_alloc(list,NR_R12);
+
+            list.concat(taicpu.op_reg_reg(A_MOV,NR_R12,NR_STACK_POINTER_REG));
+            { save int registers }
+            reference_reset(ref);
+            ref.index:=NR_STACK_POINTER_REG;
+            ref.addressmode:=AM_PREINDEXED;
+            list.concat(setoppostfix(taicpu.op_ref_regset(A_STM,ref,
+              rg[R_INTREGISTER].used_in_proc-paramanager.get_volatile_registers_int(pocall_stdcall)+[RS_R11,RS_R12,RS_R14,RS_R15]),
+              PF_FD));
+
+            list.concat(taicpu.op_reg_reg_const(A_SUB,NR_FRAME_POINTER_REG,NR_R12,4));
+
+            { allocate necessary stack size }
+            { don't use  a_op_const_reg_reg here because we don't allow register allocations
+              in the entry/exit code }
+            if not(is_shifter_const(localsize,shift)) then
+              begin
+                a_load_const_reg(list,OS_ADDR,LocalSize,NR_R12);
+                list.concat(taicpu.op_reg_reg_reg(A_SUB,NR_STACK_POINTER_REG,NR_STACK_POINTER_REG,NR_R12));
+                a_reg_dealloc(list,NR_R12);
+              end
+            else
+              begin
+                a_reg_dealloc(list,NR_R12);
+                list.concat(taicpu.op_reg_reg_const(A_SUB,NR_STACK_POINTER_REG,NR_STACK_POINTER_REG,LocalSize));
+              end;
+            if firstfloatreg<>RS_NO then
+              begin
+                reference_reset(ref);
+                if not(is_shifter_const(-tarmprocinfo(current_procinfo).floatregstart,shift)) then
+                  begin
+                    a_load_const_reg(list,OS_ADDR,-tarmprocinfo(current_procinfo).floatregstart,NR_R12);
+                    list.concat(taicpu.op_reg_reg_reg(A_SUB,NR_R12,NR_FRAME_POINTER_REG,NR_R12));
+                    ref.base:=NR_R12;
+                  end
+                else
+                  begin
+                    ref.base:=NR_FRAME_POINTER_REG;
+                    ref.offset:=tarmprocinfo(current_procinfo).floatregstart;
+                  end;
+                list.concat(taicpu.op_reg_const_ref(A_SFM,newreg(R_FPUREGISTER,firstfloatreg,R_SUBWHOLE),
+                  lastfloatreg-firstfloatreg+1,ref));
+              end;
+          end;
+      end;
+
+
+    procedure tcgarm.g_proc_exit(list : taasmoutput;parasize : longint;nostackframe:boolean);
+      var
+         ref : treference;
+         firstfloatreg,lastfloatreg,
+         r : byte;
+         shift : byte;
+      begin
+        if not(nostackframe) then
+          begin
+            { restore floating point register }
+            firstfloatreg:=RS_NO;
+            { save floating point registers? }
+            for r:=RS_F0 to RS_F7 do
+              if r in rg[R_FPUREGISTER].used_in_proc-paramanager.get_volatile_registers_fpu(pocall_stdcall) then
+                begin
+                  if firstfloatreg=RS_NO then
+                    firstfloatreg:=r;
+                  lastfloatreg:=r;
+                end;
+
+            if firstfloatreg<>RS_NO then
+              begin
+                reference_reset(ref);
+                if not(is_shifter_const(-tarmprocinfo(current_procinfo).floatregstart,shift)) then
+                  begin
+                    a_load_const_reg(list,OS_ADDR,-tarmprocinfo(current_procinfo).floatregstart,NR_R12);
+                    list.concat(taicpu.op_reg_reg_reg(A_SUB,NR_R12,NR_FRAME_POINTER_REG,NR_R12));
+                    ref.base:=NR_R12;
+                  end
+                else
+                  begin
+                    ref.base:=NR_FRAME_POINTER_REG;
+                    ref.offset:=tarmprocinfo(current_procinfo).floatregstart;
+                  end;
+                list.concat(taicpu.op_reg_const_ref(A_LFM,newreg(R_FPUREGISTER,firstfloatreg,R_SUBWHOLE),
+                  lastfloatreg-firstfloatreg+1,ref));
+              end;
+
+            if (current_procinfo.framepointer=NR_STACK_POINTER_REG) then
+              list.concat(taicpu.op_reg_reg(A_MOV,NR_R15,NR_R14))
+            else
+              begin
+                { restore int registers and return }
+                reference_reset(ref);
+                ref.index:=NR_FRAME_POINTER_REG;
+                list.concat(setoppostfix(taicpu.op_ref_regset(A_LDM,ref,rg[R_INTREGISTER].used_in_proc-paramanager.get_volatile_registers_int(pocall_stdcall)+[RS_R11,RS_R13,RS_R15]),PF_EA));
+              end;
+          end
+        else
+          list.concat(taicpu.op_reg_reg(A_MOV,NR_PC,NR_R14));
+      end;
+
+
+    procedure tcgarm.a_loadaddr_ref_reg(list : taasmoutput;const ref : treference;r : tregister);
+      var
+        b : byte;
+        tmpref : treference;
+        instr : taicpu;
+      begin
+        if ref.addressmode<>AM_OFFSET then
+          internalerror(200309071);
+        tmpref:=ref;
+        { Be sure to have a base register }
+        if (tmpref.base=NR_NO) then
+          begin
+            if tmpref.shiftmode<>SM_None then
+              internalerror(200308294);
+            if tmpref.signindex<0 then
+              internalerror(200312023);
+            tmpref.base:=tmpref.index;
+            tmpref.index:=NR_NO;
+          end;
+
+        if assigned(tmpref.symbol) or
+           not((is_shifter_const(tmpref.offset,b)) or
+               (is_shifter_const(-tmpref.offset,b))
+              ) then
+          fixref(list,tmpref);
+
+        { expect a base here if there is an index }
+        if (tmpref.base=NR_NO) and (tmpref.index<>NR_NO) then
+          internalerror(200312022);
+
+        if tmpref.index<>NR_NO then
+          begin
+            if tmpref.shiftmode<>SM_None then
+              internalerror(200312021);
+            if tmpref.signindex<0 then
+              a_op_reg_reg_reg(list,OP_SUB,OS_ADDR,tmpref.base,tmpref.index,r)
+            else
+              a_op_reg_reg_reg(list,OP_ADD,OS_ADDR,tmpref.base,tmpref.index,r);
+            if tmpref.offset<>0 then
+              a_op_const_reg_reg(list,OP_ADD,OS_ADDR,tmpref.offset,r,r);
+          end
+        else
+          begin
+            if tmpref.offset<>0 then
+              begin
+                if tmpref.base<>NR_NO then
+                  a_op_const_reg_reg(list,OP_ADD,OS_ADDR,tmpref.offset,tmpref.base,r)
+                else
+                  a_load_const_reg(list,OS_ADDR,tmpref.offset,r);
+              end
+            else
+              begin
+                instr:=taicpu.op_reg_reg(A_MOV,r,tmpref.base);
+                list.concat(instr);
+                add_move_instruction(instr);
+              end;
+          end;
+      end;
+
+
+    procedure tcgarm.fixref(list : taasmoutput;var ref : treference);
+      var
+        tmpreg : tregister;
+        tmpref : treference;
+        l : tasmlabel;
+      begin
+        { absolute symbols can't be handled directly, we've to store the symbol reference
+          in the text segment and access it pc relative
+
+          For now, we assume that references where base or index equals to PC are already
+          relative, all other references are assumed to be absolute and thus they need
+          to be handled extra.
+
+          A proper solution would be to change refoptions to a set and store the information
+          if the symbol is absolute or relative there.
+        }
+        { create consts entry }
+        reference_reset(tmpref);
+        objectlibrary.getjumplabel(l);
+        cg.a_label(current_procinfo.aktlocaldata,l);
+        tmpref.symboldata:=current_procinfo.aktlocaldata.last;
+
+        if assigned(ref.symbol) then
+          current_procinfo.aktlocaldata.concat(tai_const.create_sym_offset(ref.symbol,ref.offset))
+        else
+          current_procinfo.aktlocaldata.concat(tai_const.Create_32bit(ref.offset));
+
+        { load consts entry }
+        tmpreg:=getintregister(list,OS_INT);
+        tmpref.symbol:=l;
+        tmpref.base:=NR_PC;
+        list.concat(taicpu.op_reg_ref(A_LDR,tmpreg,tmpref));
+
+        if (ref.base<>NR_NO) then
+          begin
+            if ref.index<>NR_NO then
+              begin
+                list.concat(taicpu.op_reg_reg_reg(A_ADD,tmpreg,ref.base,tmpreg));
+                ref.base:=tmpreg;
+              end
+            else
+              begin
+                ref.index:=tmpreg;
+                ref.shiftimm:=0;
+                ref.signindex:=1;
+                ref.shiftmode:=SM_None;
+              end;
+          end
+        else
+          ref.base:=tmpreg;
+
+        ref.offset:=0;
+        ref.symbol:=nil;
+      end;
+
+
+    procedure tcgarm.g_concatcopy_move(list : taasmoutput;const source,dest : treference;len : aint);
+      var
+        paraloc1,paraloc2,paraloc3 : TCGPara;
+      begin
+        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.allocparaloc(list,paraloc3);
+        a_param_const(list,OS_INT,len,paraloc3);
+        paramanager.allocparaloc(list,paraloc2);
+        a_paramaddr_ref(list,dest,paraloc2);
+        paramanager.allocparaloc(list,paraloc2);
+        a_paramaddr_ref(list,source,paraloc1);
+        paramanager.freeparaloc(list,paraloc3);
+        paramanager.freeparaloc(list,paraloc2);
+        paramanager.freeparaloc(list,paraloc1);
+        alloccpuregisters(list,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default));
+        alloccpuregisters(list,R_FPUREGISTER,paramanager.get_volatile_registers_fpu(pocall_default));
+        a_call_name(list,'FPC_MOVE');
+        dealloccpuregisters(list,R_FPUREGISTER,paramanager.get_volatile_registers_fpu(pocall_default));
+        dealloccpuregisters(list,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default));
+        paraloc3.done;
+        paraloc2.done;
+        paraloc1.done;
+      end;
+
+
+    procedure tcgarm.g_concatcopy_internal(list : taasmoutput;const source,dest : treference;len : aint;aligned : boolean);
+      var
+        srcref,dstref:treference;
+        srcreg,destreg,countreg,r:tregister;
+        helpsize:aword;
+        copysize:byte;
+        cgsize:Tcgsize;
+
+      procedure genloop(count : aword;size : byte);
+        const
+          size2opsize : array[1..4] of tcgsize = (OS_8,OS_16,OS_NO,OS_32);
+        var
+          l : tasmlabel;
+        begin
+          objectlibrary.getjumplabel(l);
+          a_load_const_reg(list,OS_INT,count,countreg);
+          cg.a_label(list,l);
+          srcref.addressmode:=AM_POSTINDEXED;
+          dstref.addressmode:=AM_POSTINDEXED;
+          srcref.offset:=size;
+          dstref.offset:=size;
+          r:=getintregister(list,size2opsize[size]);
+          a_load_ref_reg(list,size2opsize[size],size2opsize[size],srcref,r);
+          list.concat(setoppostfix(taicpu.op_reg_reg_const(A_SUB,countreg,countreg,1),PF_S));
+          a_load_reg_ref(list,size2opsize[size],size2opsize[size],r,dstref);
+          list.concat(setcondition(taicpu.op_sym(A_B,l),C_NE));
+          { keep the registers alive }
+          list.concat(taicpu.op_reg_reg(A_MOV,countreg,countreg));
+          list.concat(taicpu.op_reg_reg(A_MOV,srcreg,srcreg));
+          list.concat(taicpu.op_reg_reg(A_MOV,destreg,destreg));
+        end;
+
+      begin
+        if len=0 then
+          exit;
+        helpsize:=12;
+        dstref:=dest;
+        srcref:=source;
+        if cs_littlesize in aktglobalswitches then
+          helpsize:=8;
+        if (len<=helpsize) and aligned then
+          begin
+            copysize:=4;
+            cgsize:=OS_32;
+            while len<>0 do
+              begin
+                if len<2 then
+                  begin
+                    copysize:=1;
+                    cgsize:=OS_8;
+                  end
+                else if len<4 then
+                  begin
+                    copysize:=2;
+                    cgsize:=OS_16;
+                  end;
+                dec(len,copysize);
+                r:=getintregister(list,cgsize);
+                a_load_ref_reg(list,cgsize,cgsize,srcref,r);
+                a_load_reg_ref(list,cgsize,cgsize,r,dstref);
+                inc(srcref.offset,copysize);
+                inc(dstref.offset,copysize);
+              end;
+          end
+        else
+          begin
+            destreg:=getintregister(list,OS_ADDR);
+            a_loadaddr_ref_reg(list,dest,destreg);
+            reference_reset_base(dstref,destreg,0);
+
+            srcreg:=getintregister(list,OS_ADDR);
+            a_loadaddr_ref_reg(list,source,srcreg);
+            reference_reset_base(srcref,srcreg,0);
+
+            countreg:=getintregister(list,OS_32);
+
+//            if cs_littlesize in aktglobalswitches  then
+              genloop(len,1);
+{
+            else
+              begin
+                helpsize:=len shr 2;
+                len:=len and 3;
+                if helpsize>1 then
+                  begin
+                    a_load_const_reg(list,OS_INT,helpsize,countreg);
+                    list.concat(Taicpu.op_none(A_REP,S_NO));
+                  end;
+                if helpsize>0 then
+                  list.concat(Taicpu.op_none(A_MOVSD,S_NO));
+                if len>1 then
+                  begin
+                    dec(len,2);
+                    list.concat(Taicpu.op_none(A_MOVSW,S_NO));
+                  end;
+                if len=1 then
+                  list.concat(Taicpu.op_none(A_MOVSB,S_NO));
+                end;
+}
+          end;
+      end;
+
+
+    procedure tcgarm.g_concatcopy_unaligned(list : taasmoutput;const source,dest : treference;len : aint);
+      begin
+        g_concatcopy_internal(list,source,dest,len,false);
+      end;
+
+
+    procedure tcgarm.g_concatcopy(list : taasmoutput;const source,dest : treference;len : aint);
+      begin
+        g_concatcopy_internal(list,source,dest,len,true);
+      end;
+
+
+    procedure tcgarm.g_overflowCheck(list : taasmoutput;const l : tlocation;def : tdef);
+      var
+        ovloc : tlocation;
+      begin
+        ovloc.loc:=LOC_VOID;
+        g_overflowCheck_loc(list,l,def,ovloc);
+      end;
+
+
+    procedure tcgarm.g_overflowCheck_loc(List:TAasmOutput;const Loc:TLocation;def:TDef;ovloc : tlocation);
+      var
+        hl : tasmlabel;
+        ai:TAiCpu;
+        hflags : tresflags;
+      begin
+        if not(cs_check_overflow in aktlocalswitches) then
+          exit;
+        objectlibrary.getjumplabel(hl);
+        case ovloc.loc of
+          LOC_VOID:
+            begin
+              ai:=taicpu.op_sym(A_B,hl);
+              ai.is_jmp:=true;
+
+              if not((def.deftype=pointerdef) or
+                    ((def.deftype=orddef) and
+                     (torddef(def).typ in [u64bit,u16bit,u32bit,u8bit,uchar,bool8bit,bool16bit,bool32bit]))) then
+                 ai.SetCondition(C_VC)
+              else
+                 ai.SetCondition(C_CC);
+
+              list.concat(ai);
+            end;
+          LOC_FLAGS:
+            begin
+              hflags:=ovloc.resflags;
+              inverse_flags(hflags);
+              cg.a_jmp_flags(list,hflags,hl);
+            end;
+          else
+            internalerror(200409281);
+        end;
+
+        a_call_name(list,'FPC_OVERFLOW');
+        a_label(list,hl);
+      end;
+
+
+    procedure tcgarm.g_save_standard_registers(list : taasmoutput);
+      begin
+        { this work is done in g_proc_entry }
+      end;
+
+
+    procedure tcgarm.g_restore_standard_registers(list : taasmoutput);
+      begin
+        { this work is done in g_proc_exit }
+      end;
+
+
+    procedure tcgarm.a_jmp_cond(list : taasmoutput;cond : TOpCmp;l: tasmlabel);
+      var
+        ai : taicpu;
+      begin
+        ai:=Taicpu.Op_sym(A_B,l);
+        ai.SetCondition(OpCmp2AsmCond[cond]);
+        ai.is_jmp:=true;
+        list.concat(ai);
+      end;
+
+
+    procedure tcgarm.g_intf_wrapper(list: taasmoutput; procdef: tprocdef; const labelname: string; ioffset: longint);
+
+      procedure loadvmttor12;
+        var
+          href : treference;
+        begin
+          reference_reset_base(href,NR_R0,0);
+          cg.a_load_ref_reg(list,OS_ADDR,OS_ADDR,href,NR_R12);
+        end;
+
+
+      procedure op_onr12methodaddr;
+        var
+          href : treference;
+        begin
+          if (procdef.extnumber=$ffff) then
+            Internalerror(200006139);
+          { call/jmp  vmtoffs(%eax) ; method offs }
+          reference_reset_base(href,NR_R12,procdef._class.vmtmethodoffset(procdef.extnumber));
+          cg.a_load_ref_reg(list,OS_ADDR,OS_ADDR,href,NR_R12);
+          list.concat(taicpu.op_reg_reg(A_MOV,NR_PC,NR_R12));
+        end;
+
+      var
+        lab : tasmsymbol;
+        make_global : boolean;
+        href : treference;
+      begin
+        if not(procdef.proctypeoption in [potype_function,potype_procedure]) then
+          Internalerror(200006137);
+        if not assigned(procdef._class) or
+           (procdef.procoptions*[po_classmethod, po_staticmethod,
+             po_methodpointer, po_interrupt, po_iocheck]<>[]) then
+          Internalerror(200006138);
+        if procdef.owner.symtabletype<>objectsymtable then
+          Internalerror(200109191);
+
+        make_global:=false;
+        if (not current_module.is_unit) or
+           (cs_create_smart in aktmoduleswitches) or
+           (procdef.owner.defowner.owner.symtabletype=globalsymtable) then
+          make_global:=true;
+
+        if make_global then
+          list.concat(Tai_symbol.Createname_global(labelname,AT_FUNCTION,0))
+        else
+          list.concat(Tai_symbol.Createname(labelname,AT_FUNCTION,0));
+
+        { set param1 interface to self  }
+        g_adjust_self_value(list,procdef,ioffset);
+
+        { case 4 }
+        if po_virtualmethod in procdef.procoptions then
+          begin
+            loadvmttor12;
+            op_onr12methodaddr;
+          end
+        { case 0 }
+        else
+          list.concat(taicpu.op_sym(A_B,objectlibrary.newasmsymbol(procdef.mangledname,AB_EXTERNAL,AT_FUNCTION)));
+
+        list.concat(Tai_symbol_end.Createname(labelname));
+      end;
+
+
+    procedure tcg64farm.a_op64_reg_reg(list : taasmoutput;op:TOpCG;size : tcgsize;regsrc,regdst : tregister64);
+      var
+        tmpreg : tregister;
+      begin
+        case op of
+          OP_NEG:
+            begin
+              list.concat(setoppostfix(taicpu.op_reg_reg_const(A_RSB,regdst.reglo,regsrc.reglo,0),PF_S));
+              list.concat(taicpu.op_reg_reg_const(A_RSC,regdst.reghi,regsrc.reghi,0));
+            end;
+          OP_NOT:
+            begin
+              cg.a_op_reg_reg(list,OP_NOT,OS_INT,regsrc.reglo,regdst.reglo);
+              cg.a_op_reg_reg(list,OP_NOT,OS_INT,regsrc.reghi,regdst.reghi);
+            end;
+          else
+            a_op64_reg_reg_reg(list,op,size,regsrc,regdst,regdst);
+        end;
+      end;
+
+
+    procedure tcg64farm.a_op64_const_reg(list : taasmoutput;op:TOpCG;size : tcgsize;value : int64;reg : tregister64);
+      begin
+        a_op64_const_reg_reg(list,op,size,value,reg,reg);
+      end;
+
+
+    procedure tcg64farm.a_op64_const_reg_reg(list: taasmoutput;op:TOpCG;size : tcgsize;value : int64;regsrc,regdst : tregister64);
+      var
+        ovloc : tlocation;
+      begin
+        a_op64_const_reg_reg_checkoverflow(list,op,size,value,regsrc,regdst,false,ovloc);
+      end;
+
+
+    procedure tcg64farm.a_op64_reg_reg_reg(list: taasmoutput;op:TOpCG;size : tcgsize;regsrc1,regsrc2,regdst : tregister64);
+      var
+        ovloc : tlocation;
+      begin
+        a_op64_reg_reg_reg_checkoverflow(list,op,size,regsrc1,regsrc2,regdst,false,ovloc);
+      end;
+
+
+    procedure tcg64farm.a_op64_const_reg_reg_checkoverflow(list: taasmoutput;op:TOpCG;size : tcgsize;value : int64;regsrc,regdst : tregister64;setflags : boolean;var ovloc : tlocation);
+      var
+        tmpreg : tregister;
+        b : byte;
+      begin
+        ovloc.loc:=LOC_VOID;
+        case op of
+          OP_NEG,
+          OP_NOT :
+            internalerror(200306017);
+        end;
+        if (setflags or tcgarm(cg).cgsetflags) and (op in [OP_ADD,OP_SUB]) then
+          begin
+            case op of
+              OP_ADD:
+                begin
+                  if is_shifter_const(lo(value),b) then
+                    list.concat(setoppostfix(taicpu.op_reg_reg_const(A_ADD,regdst.reglo,regsrc.reglo,lo(value)),PF_S))
+                  else
+                    begin
+                      tmpreg:=cg.getintregister(list,OS_32);
+                      cg.a_load_const_reg(list,OS_32,lo(value),tmpreg);
+                      list.concat(setoppostfix(taicpu.op_reg_reg_reg(A_ADD,regdst.reglo,regsrc.reglo,tmpreg),PF_S));
+                    end;
+
+                  if is_shifter_const(hi(value),b) then
+                    list.concat(setoppostfix(taicpu.op_reg_reg_const(A_ADC,regdst.reghi,regsrc.reghi,hi(value)),PF_S))
+                  else
+                    begin
+                      tmpreg:=cg.getintregister(list,OS_32);
+                      cg.a_load_const_reg(list,OS_32,hi(value),tmpreg);
+                      list.concat(setoppostfix(taicpu.op_reg_reg_reg(A_ADC,regdst.reghi,regsrc.reghi,tmpreg),PF_S));
+                    end;
+                end;
+              OP_SUB:
+                begin
+                  if is_shifter_const(lo(value),b) then
+                    list.concat(setoppostfix(taicpu.op_reg_reg_const(A_SUB,regdst.reglo,regsrc.reglo,lo(value)),PF_S))
+                  else
+                    begin
+                      tmpreg:=cg.getintregister(list,OS_32);
+                      cg.a_load_const_reg(list,OS_32,lo(value),tmpreg);
+                      list.concat(setoppostfix(taicpu.op_reg_reg_reg(A_SUB,regdst.reglo,regsrc.reglo,tmpreg),PF_S));
+                    end;
+
+                  if is_shifter_const(hi(value),b) then
+                    list.concat(setoppostfix(taicpu.op_reg_reg_const(A_SBC,regdst.reghi,regsrc.reghi,hi(value)),PF_S))
+                  else
+                    begin
+                      tmpreg:=cg.getintregister(list,OS_32);
+                      cg.a_load_const_reg(list,OS_32,hi(value),tmpreg);
+                      list.concat(setoppostfix(taicpu.op_reg_reg_reg(A_SBC,regdst.reghi,regsrc.reghi,tmpreg),PF_S));
+                    end;
+                end;
+              else
+                internalerror(200502131);
+            end;
+            if size=OS_64 then
+              begin
+                { the arm has an weired opinion how flags for SUB/ADD are handled }
+                ovloc.loc:=LOC_FLAGS;
+                case op of
+                  OP_ADD:
+                    ovloc.resflags:=F_CS;
+                  OP_SUB:
+                    ovloc.resflags:=F_CC;
+                end;
+              end;
+          end
+        else
+          begin
+            case op of
+              OP_AND,OP_OR,OP_XOR:
+                begin
+                  cg.a_op_const_reg_reg(list,op,OS_32,lo(value),regsrc.reglo,regdst.reglo);
+                  cg.a_op_const_reg_reg(list,op,OS_32,hi(value),regsrc.reghi,regdst.reghi);
+                end;
+              OP_ADD:
+                begin
+                  if is_shifter_const(lo(value),b) then
+                    list.concat(setoppostfix(taicpu.op_reg_reg_const(A_ADD,regdst.reglo,regsrc.reglo,lo(value)),PF_S))
+                  else
+                    begin
+                      tmpreg:=cg.getintregister(list,OS_32);
+                      cg.a_load_const_reg(list,OS_32,lo(value),tmpreg);
+                      list.concat(setoppostfix(taicpu.op_reg_reg_reg(A_ADD,regdst.reglo,regsrc.reglo,tmpreg),PF_S));
+                    end;
+
+                  if is_shifter_const(hi(value),b) then
+                    list.concat(taicpu.op_reg_reg_const(A_ADC,regdst.reghi,regsrc.reghi,hi(value)))
+                  else
+                    begin
+                      tmpreg:=cg.getintregister(list,OS_32);
+                      cg.a_load_const_reg(list,OS_32,hi(value),tmpreg);
+                      list.concat(taicpu.op_reg_reg_reg(A_ADC,regdst.reghi,regsrc.reghi,tmpreg));
+                    end;
+                end;
+              OP_SUB:
+                begin
+                  if is_shifter_const(lo(value),b) then
+                    list.concat(setoppostfix(taicpu.op_reg_reg_const(A_SUB,regdst.reglo,regsrc.reglo,lo(value)),PF_S))
+                  else
+                    begin
+                      tmpreg:=cg.getintregister(list,OS_32);
+                      cg.a_load_const_reg(list,OS_32,lo(value),tmpreg);
+                      list.concat(setoppostfix(taicpu.op_reg_reg_reg(A_SUB,regdst.reglo,regsrc.reglo,tmpreg),PF_S));
+                    end;
+
+                  if is_shifter_const(hi(value),b) then
+                    list.concat(taicpu.op_reg_reg_const(A_SBC,regdst.reghi,regsrc.reghi,hi(value)))
+                  else
+                    begin
+                      tmpreg:=cg.getintregister(list,OS_32);
+                      cg.a_load_const_reg(list,OS_32,hi(value),tmpreg);
+                      list.concat(taicpu.op_reg_reg_reg(A_SBC,regdst.reghi,regsrc.reghi,tmpreg));
+                    end;
+                end;
+            else
+              internalerror(2003083101);
+          end;
+        end;
+      end;
+
+
+    procedure tcg64farm.a_op64_reg_reg_reg_checkoverflow(list: taasmoutput;op:TOpCG;size : tcgsize;regsrc1,regsrc2,regdst : tregister64;setflags : boolean;var ovloc : tlocation);
+      var
+        op1,op2:TAsmOp;
+      begin
+        ovloc.loc:=LOC_VOID;
+        case op of
+          OP_NEG,
+          OP_NOT :
+            internalerror(200306017);
+        end;
+        if (setflags or tcgarm(cg).cgsetflags) and (op in [OP_ADD,OP_SUB]) then
+          begin
+            case op of
+              OP_ADD:
+                begin
+                  list.concat(setoppostfix(taicpu.op_reg_reg_reg(A_ADD,regdst.reglo,regsrc1.reglo,regsrc2.reglo),PF_S));
+                  list.concat(setoppostfix(taicpu.op_reg_reg_reg(A_ADC,regdst.reghi,regsrc1.reghi,regsrc2.reghi),PF_S));
+                end;
+              OP_SUB:
+                begin
+                  list.concat(setoppostfix(taicpu.op_reg_reg_reg(A_SUB,regdst.reglo,regsrc2.reglo,regsrc1.reglo),PF_S));
+                  list.concat(setoppostfix(taicpu.op_reg_reg_reg(A_SBC,regdst.reghi,regsrc2.reghi,regsrc1.reghi),PF_S));
+                end;
+              else
+                internalerror(2003083101);
+            end;
+            if size=OS_64 then
+              begin
+                { the arm has an weired opinion how flags for SUB/ADD are handled }
+                ovloc.loc:=LOC_FLAGS;
+                case op of
+                  OP_ADD:
+                    ovloc.resflags:=F_CC;
+                  OP_SUB:
+                    ovloc.resflags:=F_CS;
+                end;
+              end;
+          end
+        else
+          begin
+            case op of
+              OP_AND,OP_OR,OP_XOR:
+                begin
+                  cg.a_op_reg_reg_reg(list,op,OS_32,regsrc1.reglo,regsrc2.reglo,regdst.reglo);
+                  cg.a_op_reg_reg_reg(list,op,OS_32,regsrc1.reghi,regsrc2.reghi,regdst.reghi);
+                end;
+              OP_ADD:
+                begin
+                  list.concat(setoppostfix(taicpu.op_reg_reg_reg(A_ADD,regdst.reglo,regsrc1.reglo,regsrc2.reglo),PF_S));
+                  list.concat(taicpu.op_reg_reg_reg(A_ADC,regdst.reghi,regsrc1.reghi,regsrc2.reghi));
+                end;
+              OP_SUB:
+                begin
+                  list.concat(setoppostfix(taicpu.op_reg_reg_reg(A_SUB,regdst.reglo,regsrc2.reglo,regsrc1.reglo),PF_S));
+                  list.concat(taicpu.op_reg_reg_reg(A_SBC,regdst.reghi,regsrc2.reghi,regsrc1.reghi));
+                end;
+              else
+                internalerror(2003083101);
+            end;
+          end;
+      end;
+
+
+begin
+  cg:=tcgarm.create;
+  cg64:=tcg64farm.create;
+end.

+ 520 - 0
compiler/arm/cpubase.pas

@@ -0,0 +1,520 @@
+{
+    Copyright (c) 1998-2002 by Florian Klaempfl and Peter Vreman
+
+    Contains the base types for the ARM
+
+    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.
+
+ ****************************************************************************
+}
+{# Base unit for processor information. This unit contains
+   enumerations of registers, opcodes, sizes, and other
+   such things which are processor specific.
+}
+unit cpubase;
+
+{$i fpcdefs.inc}
+
+  interface
+
+    uses
+      cutils,cclasses,
+      globtype,globals,
+      cpuinfo,
+      aasmbase,
+      cgbase
+      ;
+
+
+{*****************************************************************************
+                                Assembler Opcodes
+*****************************************************************************}
+
+    type
+      TAsmOp= {$i armop.inc}
+
+      { This should define the array of instructions as string }
+      op2strtable=array[tasmop] of string[11];
+
+    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 rarmnor.inc}-1;
+
+    const
+      { Available Superregisters }
+      {$i rarmsup.inc}
+
+      RS_PC = RS_R15;
+
+      { No Subregisters }
+      R_SUBWHOLE = R_SUBNONE;
+
+      { Available Registers }
+      {$i rarmcon.inc}
+
+      { aliases }
+      NR_PC = NR_R15;
+
+      { Integer Super registers first and last }
+      first_int_supreg = RS_R0;
+      first_int_imreg = $10;
+
+      { Float Super register first and last }
+      first_fpu_supreg    = RS_F0;
+      first_fpu_imreg     = $08;
+
+      { MM Super register first and last }
+      first_mm_supreg    = RS_S0;
+      first_mm_imreg     = $20;
+
+{$warning TODO Calculate bsstart}
+      regnumber_count_bsstart = 64;
+
+      regnumber_table : array[tregisterindex] of tregister = (
+        {$i rarmnum.inc}
+      );
+
+      regstabs_table : array[tregisterindex] of shortint = (
+        {$i rarmsta.inc}
+      );
+
+      regdwarf_table : array[tregisterindex] of shortint = (
+        {$i rarmdwa.inc}
+      );
+      { registers which may be destroyed by calls }
+      VOLATILE_INTREGISTERS = [RS_R0..RS_R3,RS_R12..RS_R15];
+      VOLATILE_FPUREGISTERS = [RS_F0..RS_F3];
+
+    type
+      totherregisterset = set of tregisterindex;
+
+{*****************************************************************************
+                          Instruction post fixes
+*****************************************************************************}
+    type
+      { ARM instructions load/store and arithmetic instructions
+        can have several instruction post fixes which are collected
+        in this enumeration
+      }
+      TOpPostfix = (PF_None,
+        { update condition flags
+          or floating point single }
+        PF_S,
+        { floating point size }
+        PF_D,PF_E,PF_P,PF_EP,
+        { load/store }
+        PF_B,PF_SB,PF_BT,PF_H,PF_SH,PF_T,
+        { multiple load/store address modes }
+        PF_IA,PF_IB,PF_DA,PF_DB,PF_FD,PF_FA,PF_ED,PF_EA
+      );
+
+      TRoundingMode = (RM_None,RM_P,RM_M,RM_Z);
+
+    const
+      cgsize2fpuoppostfix : array[OS_NO..OS_F128] of toppostfix = (
+        PF_E,
+        PF_None,PF_None,PF_None,PF_None,PF_None,PF_None,PF_None,PF_None,PF_None,PF_None,
+        PF_S,PF_D,PF_E,PF_None,PF_None);
+
+      oppostfix2str : array[TOpPostfix] of string[2] = ('',
+        's',
+        'd','e','p','ep',
+        'b','sb','bt','h','sh','t',
+        'ia','ib','da','db','fd','fa','ed','ea');
+
+      roundingmode2str : array[TRoundingMode] of string[1] = ('',
+        'p','m','z');
+
+{*****************************************************************************
+                                Conditions
+*****************************************************************************}
+
+    type
+      TAsmCond=(C_None,
+        C_EQ,C_NE,C_CS,C_CC,C_MI,C_PL,C_VS,C_VC,C_HI,C_LS,
+        C_GE,C_LT,C_GT,C_LE,C_AL,C_NV
+      );
+
+    const
+      cond2str : array[TAsmCond] of string[2]=('',
+        'eq','ne','cs','cc','mi','pl','vs','vc','hi','ls',
+        'ge','lt','gt','le','al','nv'
+      );
+
+      uppercond2str : array[TAsmCond] of string[2]=('',
+        'EQ','NE','CS','CC','MI','PL','VS','VC','HI','LS',
+        'GE','LT','GT','LE','AL','NV'
+      );
+
+{*****************************************************************************
+                                   Flags
+*****************************************************************************}
+
+    type
+      TResFlags = (F_EQ,F_NE,F_CS,F_CC,F_MI,F_PL,F_VS,F_VC,F_HI,F_LS,
+        F_GE,F_LT,F_GT,F_LE);
+
+{*****************************************************************************
+                                Operands
+*****************************************************************************}
+
+      taddressmode = (AM_OFFSET,AM_PREINDEXED,AM_POSTINDEXED);
+      tshiftmode = (SM_None,SM_LSL,SM_LSR,SM_ASR,SM_ROR,SM_RRX);
+
+      tupdatereg = (UR_None,UR_Update);
+
+      pshifterop = ^tshifterop;
+
+      tshifterop = record
+        shiftmode : tshiftmode;
+        rs : tregister;
+        shiftimm : byte;
+      end;
+
+{*****************************************************************************
+                                 Constants
+*****************************************************************************}
+
+    const
+      max_operands = 4;
+
+      {# Constant defining possibly all registers which might require saving }
+      ALL_OTHERREGISTERS = [];
+
+      general_superregisters = [RS_R0..RS_PC];
+
+      {# Table of registers which can be allocated by the code generator
+         internally, when generating the code.
+      }
+      { legend:                                                                }
+      { xxxregs = set of all possibly used registers of that type in the code  }
+      {           generator                                                    }
+      { usableregsxxx = set of all 32bit components of registers that can be   }
+      {           possible allocated to a regvar or using getregisterxxx (this }
+      {           excludes registers which can be only used for parameter      }
+      {           passing on ABI's that define this)                           }
+      { c_countusableregsxxx = amount of registers in the usableregsxxx set    }
+
+      maxintregs = 15;
+      { to determine how many registers to use for regvars }
+      maxintscratchregs = 3;
+      usableregsint = [RS_R4..RS_R10];
+      c_countusableregsint = 7;
+
+      maxfpuregs = 8;
+      fpuregs = [RS_F0..RS_F7];
+      usableregsfpu = [RS_F4..RS_F7];
+      c_countusableregsfpu = 4;
+
+      mmregs = [RS_D0..RS_D15];
+      usableregsmm = [RS_D8..RS_D15];
+      c_countusableregsmm  = 8;
+
+      maxaddrregs = 0;
+      addrregs    = [];
+      usableregsaddr = [];
+      c_countusableregsaddr = 0;
+
+{*****************************************************************************
+                                Operand Sizes
+*****************************************************************************}
+
+    type
+      topsize = (S_NO,
+        S_B,S_W,S_L,S_BW,S_BL,S_WL,
+        S_IS,S_IL,S_IQ,
+        S_FS,S_FL,S_FX,S_D,S_Q,S_FV,S_FXX
+      );
+
+{*****************************************************************************
+                                 Constants
+*****************************************************************************}
+
+    const
+      firstsaveintreg = RS_R4;
+      lastsaveintreg  = RS_R10;
+      firstsavefpureg = RS_F4;
+      lastsavefpureg  = RS_F7;
+      firstsavemmreg  = RS_D8;
+      lastsavemmreg   = RS_D15;
+
+      maxvarregs = 7;
+      varregs : Array [1..maxvarregs] of tsuperregister =
+                (RS_R4,RS_R5,RS_R6,RS_R7,RS_R8,RS_R9,RS_R10);
+
+      maxfpuvarregs = 4;
+      fpuvarregs : Array [1..maxfpuvarregs] of tsuperregister =
+                (RS_F4,RS_F5,RS_F6,RS_F7);
+
+{*****************************************************************************
+                          Default generic sizes
+*****************************************************************************}
+
+      { Defines the default address size for a processor, }
+      OS_ADDR = OS_32;
+      { the natural int size for a processor,             }
+      OS_INT = OS_32;
+      OS_SINT = OS_S32;
+      { the maximum float size for a processor,           }
+      OS_FLOAT = OS_F64;
+      { the size of a vector register for a processor     }
+      OS_VECTOR = OS_M32;
+
+{*****************************************************************************
+                          Generic Register names
+*****************************************************************************}
+
+      { Stack pointer register }
+      NR_STACK_POINTER_REG = NR_R13;
+      RS_STACK_POINTER_REG = RS_R13;
+      { Frame pointer register }
+      RS_FRAME_POINTER_REG = RS_R11;
+      NR_FRAME_POINTER_REG = NR_R11;
+      { Register for addressing absolute data in a position independant way,
+        such as in PIC code. The exact meaning is ABI specific. For
+        further information look at GCC source : PIC_OFFSET_TABLE_REGNUM
+      }
+      NR_PIC_OFFSET_REG = NR_R9;
+      { Results are returned in this register (32-bit values) }
+      NR_FUNCTION_RETURN_REG = NR_R0;
+      RS_FUNCTION_RETURN_REG = RS_R0;
+      { Low part of 64bit return value }
+      NR_FUNCTION_RETURN64_LOW_REG = NR_R0;
+      RS_FUNCTION_RETURN64_LOW_REG = RS_R0;
+      { High part of 64bit return value }
+      NR_FUNCTION_RETURN64_HIGH_REG = NR_R1;
+      RS_FUNCTION_RETURN64_HIGH_REG = RS_R1;
+      { 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_F0;
+
+      NR_MM_RESULT_REG  = NR_NO;
+
+      NR_RETURN_ADDRESS_REG = NR_FUNCTION_RETURN_REG;
+
+      { Offset where the parent framepointer is pushed }
+      PARENT_FRAMEPOINTER_OFFSET = 0;
+
+{*****************************************************************************
+                       GCC /ABI linking information
+*****************************************************************************}
+
+    const
+      { Registers which must be saved when calling a routine declared as
+        cppdecl, cdecl, stdcall, safecall, palmossyscall. The registers
+        saved should be the ones as defined in the target ABI and / or GCC.
+
+        This value can be deduced from the CALLED_USED_REGISTERS array in the
+        GCC source.
+      }
+      saved_standard_registers : array[0..6] of tsuperregister =
+        (RS_R4,RS_R5,RS_R6,RS_R7,RS_R8,RS_R9,RS_R10);
+      { Required parameter alignment when calling a routine declared as
+        stdcall and cdecl. The alignment value should be the one defined
+        by GCC or the target ABI.
+
+        The value of this constant is equal to the constant
+        PARM_BOUNDARY / BITS_PER_UNIT in the GCC source.
+      }
+      std_param_align = 4;
+
+
+{*****************************************************************************
+                                  Helpers
+*****************************************************************************}
+
+    { Returns the tcgsize corresponding with the size of reg.}
+    function reg_cgsize(const reg: tregister) : tcgsize;
+    function cgsize2subreg(s:Tcgsize):Tsubregister;
+    function is_calljmp(o:tasmop):boolean;
+    procedure inverse_flags(var f: TResFlags);
+    function flags_to_cond(const f: TResFlags) : TAsmCond;
+    function findreg_by_number(r:Tregister):tregisterindex;
+    function std_regnum_search(const s:string):Tregister;
+    function std_regname(r:Tregister):string;
+
+    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;
+
+    function is_shifter_const(d : aint;var imm_shift : byte) : boolean;
+
+  implementation
+
+    uses
+      rgBase,verbose;
+
+
+    const
+      std_regname_table : array[tregisterindex] of string[7] = (
+        {$i rarmstd.inc}
+      );
+
+      regnumber_index : array[tregisterindex] of tregisterindex = (
+        {$i rarmrni.inc}
+      );
+
+      std_regname_index : array[tregisterindex] of tregisterindex = (
+        {$i rarmsri.inc}
+      );
+
+
+    function cgsize2subreg(s:Tcgsize):Tsubregister;
+      begin
+        cgsize2subreg:=R_SUBWHOLE;
+      end;
+
+
+    function reg_cgsize(const reg: tregister): tcgsize;
+      const subreg2cgsize:array[Tsubregister] of Tcgsize =
+            (OS_NO,OS_8,OS_8,OS_16,OS_32,OS_64,OS_NO,OS_NO,OS_NO,OS_NO,OS_NO);
+      begin
+        case getregtype(reg) of
+          R_INTREGISTER :
+            reg_cgsize:=OS_32;
+          R_FPUREGISTER :
+            reg_cgsize:=OS_F80;
+          else
+            internalerror(200303181);
+          end;
+        end;
+
+
+    function is_calljmp(o:tasmop):boolean;
+      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 }
+        is_calljmp:= o in [A_B,A_BL,A_BX,A_BLX];
+      end;
+
+
+    procedure inverse_flags(var f: TResFlags);
+      const
+        inv_flags: array[TResFlags] of TResFlags =
+          (F_NE,F_EQ,F_CC,F_CS,F_PL,F_MI,F_VC,F_VS,F_LS,F_HI,
+          F_LT,F_GE,F_LE,F_GT);
+      begin
+        f:=inv_flags[f];
+      end;
+
+
+    function flags_to_cond(const f: TResFlags) : TAsmCond;
+      const
+        flag_2_cond: array[F_EQ..F_LE] of TAsmCond =
+          (C_EQ,C_NE,C_CS,C_CC,C_MI,C_PL,C_VS,C_VC,C_HI,C_LS,
+           C_GE,C_LT,C_GT,C_LE);
+      begin
+        if f>high(flag_2_cond) then
+          internalerror(200112301);
+        result:=flag_2_cond[f];
+      end;
+
+
+    function findreg_by_number(r:Tregister):tregisterindex;
+      begin
+        result:=rgBase.findreg_by_number_table(r,regnumber_index);
+      end;
+
+
+    function std_regnum_search(const s:string):Tregister;
+      begin
+        result:=regnumber_table[findreg_by_name_table(s,std_regname_table,std_regname_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;
+
+
+    procedure shifterop_reset(var so : tshifterop);
+      begin
+        FillChar(so,sizeof(so),0);
+      end;
+
+
+    function is_pc(const r : tregister) : boolean;
+      begin
+        is_pc:=(r=NR_R15);
+      end;
+
+
+    function inverse_cond(const c: TAsmCond): TAsmCond; {$ifdef USEINLINE}inline;{$endif USEINLINE}
+      const
+        inverse: array[TAsmCond] of TAsmCond=(C_None,
+          C_NE,C_EQ,C_CC,C_CS,C_PL,C_MI,C_VC,C_VS,C_LS,C_HI,
+          C_LT,C_GE,C_LE,C_GT,C_None,C_None
+        );
+      begin
+        result := inverse[c];
+      end;
+
+
+    function conditions_equal(const c1, c2: TAsmCond): boolean; {$ifdef USEINLINE}inline;{$endif USEINLINE}
+      begin
+        result := c1 = c2;
+      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;
+      begin
+         for i:=0 to 15 do
+           begin
+              if (dword(d) and not(rotl($ff,i*2)))=0 then
+                begin
+                   imm_shift:=i*2;
+                   result:=true;
+                   exit;
+                end;
+           end;
+         result:=false;
+      end;
+
+end.

+ 88 - 0
compiler/arm/cpuinfo.pas

@@ -0,0 +1,88 @@
+{
+    Copyright (c) 1998-2002 by the Free Pascal development team
+
+    Basic Processor information for the ARM
+
+    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 = type extended;
+   ts128real = type extended;
+   ts64comp = comp;
+
+   pbestreal=^bestreal;
+
+   { possible supported processors for this target }
+   tprocessors =
+      (no_processor,
+       armv3,
+       armv4,
+       armv5
+      );
+
+   tfputype =
+     (no_fpuprocessor,
+      fpu_soft,
+      fpu_libgcc,
+      fpu_fpa,
+      fpu_fpa10,
+      fpu_fpa11,
+      fpu_vfp
+     );
+
+Const
+   {# Size of native extended floating point type }
+   extended_size = 12;
+   {# Size of a multimedia register               }
+   mmreg_size = 16;
+   { target cpu string (used by compiler options) }
+   target_cpu_string = 'arm';
+
+   { calling conventions supported by the code generator }
+   supported_calling_conventions : tproccalloptions = [
+     pocall_internproc,
+     pocall_stdcall,
+     { same as stdcall only different name mangling }
+     pocall_cdecl,
+     { same as stdcall only different name mangling }
+     pocall_cppdecl,
+     { same as stdcall but floating point numbers are handled like equal sized integers }
+     pocall_softfloat
+   ];
+
+   processorsstr : array[tprocessors] of string[5] = ('',
+     'ARMV3',
+     'ARMV4',
+     'ARMV5'
+   );
+
+   fputypestr : array[tfputype] of string[6] = ('',
+     'SOFT',
+     'LIBGCC',
+     'FPA',
+     'FPA10',
+     'FPA11',
+     'VFP'
+   );
+
+
+Implementation
+
+end.

+ 46 - 0
compiler/arm/cpunode.pas

@@ -0,0 +1,46 @@
+{
+    Copyright (c) 2000-2003 by Florian Klaempfl
+
+    This unit includes the ARM code generator into the compiler
+
+    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
+
+  implementation
+
+    uses
+       { generic nodes }
+       ncgbas,ncgld,ncgflw,ncgcnv,ncgmem,ncgcon,ncgcal,ncgset,ncginl,ncgopt,ncgmat,
+       { to be able to only parts of the generic code,
+         the processor specific nodes must be included
+         after the generic one (FK)
+       }
+       narmadd,
+       narmcal,
+       narmmat,
+       narminl,
+       narmcnv,
+       narmcon
+       ;
+
+
+end.

+ 496 - 0
compiler/arm/cpupara.pas

@@ -0,0 +1,496 @@
+{
+    Copyright (c) 2003 by Florian Klaempfl
+
+    ARM specific calling conventions
+
+    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.
+ ****************************************************************************
+}
+{ ARM specific calling conventions are handled by this unit
+}
+unit cpupara;
+
+{$i fpcdefs.inc}
+
+  interface
+
+    uses
+       globtype,globals,
+       aasmtai,
+       cpuinfo,cpubase,cgbase,
+       symconst,symbase,symtype,symdef,parabase,paramgr;
+
+    type
+       tarmparamanager = class(tparamanager)
+          function get_volatile_registers_int(calloption : tproccalloption):tcpuregisterset;override;
+          function get_volatile_registers_fpu(calloption : tproccalloption):tcpuregisterset;override;
+          function push_addr_param(varspez:tvarspez;def : tdef;calloption : tproccalloption) : boolean;override;
+          procedure getintparaloc(calloption : tproccalloption; nr : longint;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;
+         private
+          procedure init_values(var curintreg, curfloatreg, curmmreg: tsuperregister; var cur_stack_offset: aword);
+          function create_paraloc_info_intern(p : tabstractprocdef; side: tcallercallee; paras: tparalist;
+            var curintreg, curfloatreg, curmmreg: tsuperregister; var cur_stack_offset: aword):longint;
+       end;
+
+  implementation
+
+    uses
+       verbose,systems,
+       rgobj,
+       defutil,symsym,
+       cgutils;
+
+
+    function tarmparamanager.get_volatile_registers_int(calloption : tproccalloption):tcpuregisterset;
+      begin
+        result:=VOLATILE_INTREGISTERS;
+      end;
+
+
+    function tarmparamanager.get_volatile_registers_fpu(calloption : tproccalloption):tcpuregisterset;
+      begin
+        result:=VOLATILE_FPUREGISTERS;
+      end;
+
+
+    procedure tarmparamanager.getintparaloc(calloption : tproccalloption; nr : longint;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.alignment:=std_param_align;
+        paraloc:=cgpara.add_location;
+        with paraloc^ do
+          begin
+            size:=OS_INT;
+            { the four first parameters are passed into registers }
+            if nr<=4 then
+              begin
+                loc:=LOC_REGISTER;
+                register:=newreg(R_INTREGISTER,RS_R0+nr-1,R_SUBWHOLE);
+              end
+            else
+              begin
+                { the other parameters are passed on the stack }
+                loc:=LOC_REFERENCE;
+                reference.index:=NR_STACK_POINTER_REG;
+                reference.offset:=(nr-5)*4;
+              end;
+          end;
+      end;
+
+
+    function getparaloc(calloption : tproccalloption; p : tdef) : tcgloc;
+      begin
+         { Later, the LOC_REFERENCE is in most cases changed into LOC_REGISTER
+           if push_addr_param for the def is true
+         }
+         case p.deftype of
+            orddef:
+              getparaloc:=LOC_REGISTER;
+            floatdef:
+              if (calloption in [pocall_cdecl,pocall_cppdecl,pocall_softfloat]) or (cs_fp_emulation in aktmoduleswitches) then
+                getparaloc:=LOC_REGISTER
+              else
+                getparaloc:=LOC_FPUREGISTER;
+            enumdef:
+              getparaloc:=LOC_REGISTER;
+            pointerdef:
+              getparaloc:=LOC_REGISTER;
+            formaldef:
+              getparaloc:=LOC_REGISTER;
+            classrefdef:
+              getparaloc:=LOC_REGISTER;
+            recorddef:
+              getparaloc:=LOC_REFERENCE;
+            objectdef:
+              if is_object(p) then
+                getparaloc:=LOC_REFERENCE
+              else
+                getparaloc:=LOC_REGISTER;
+            stringdef:
+              if is_shortstring(p) or is_longstring(p) then
+                getparaloc:=LOC_REFERENCE
+              else
+                getparaloc:=LOC_REGISTER;
+            procvardef:
+              if (po_methodpointer in tprocvardef(p).procoptions) then
+                getparaloc:=LOC_REFERENCE
+              else
+                getparaloc:=LOC_REGISTER;
+            filedef:
+              getparaloc:=LOC_REGISTER;
+            arraydef:
+              getparaloc:=LOC_REFERENCE;
+            setdef:
+              if is_smallset(p) then
+                getparaloc:=LOC_REGISTER
+              else
+                getparaloc:=LOC_REFERENCE;
+            variantdef:
+              getparaloc:=LOC_REFERENCE;
+            { avoid problems with errornous definitions }
+            errordef:
+              getparaloc:=LOC_REGISTER;
+            else
+              internalerror(2002071001);
+         end;
+      end;
+
+
+    function tarmparamanager.push_addr_param(varspez:tvarspez;def : tdef;calloption : tproccalloption) : boolean;
+      begin
+        result:=false;
+        if varspez in [vs_var,vs_out] then
+          begin
+            result:=true;
+            exit;
+          end;
+        case def.deftype of
+          variantdef,
+          formaldef,
+          recorddef:
+            result:=true;
+          arraydef:
+            result:=(tarraydef(def).highrange>=tarraydef(def).lowrange) or
+                             is_open_array(def) or
+                             is_array_of_const(def) or
+                             is_array_constructor(def);
+          objectdef :
+            result:=is_object(def);
+          setdef :
+            result:=(tsetdef(def).settype<>smallset);
+          stringdef :
+            result:=tstringdef(def).string_typ in [st_shortstring,st_longstring];
+          procvardef :
+            result:=po_methodpointer in tprocvardef(def).procoptions;
+        end;
+      end;
+
+
+    procedure tarmparamanager.init_values(var curintreg, curfloatreg, curmmreg: tsuperregister; var cur_stack_offset: aword);
+      begin
+        curintreg:=RS_R0;
+        curfloatreg:=RS_F0;
+        curmmreg:=RS_D0;
+        cur_stack_offset:=0;
+      end;
+
+
+    function tarmparamanager.create_paraloc_info_intern(p : tabstractprocdef; side: tcallercallee; paras: tparalist;
+        var curintreg, curfloatreg, curmmreg: tsuperregister; var cur_stack_offset: aword):longint;
+
+      var
+        nextintreg,nextfloatreg,nextmmreg : tsuperregister;
+        paradef : tdef;
+        paraloc : pcgparalocation;
+        stack_offset : aword;
+        hp : tparavarsym;
+        loc : tcgloc;
+        paracgsize   : tcgsize;
+        paralen : longint;
+        i : integer;
+
+      procedure assignintreg;
+        begin
+           if nextintreg<=RS_R3 then
+             begin
+               paraloc^.loc:=LOC_REGISTER;
+               paraloc^.register:=newreg(R_INTREGISTER,nextintreg,R_SUBWHOLE);
+               inc(nextintreg);
+             end
+           else
+             begin
+               paraloc^.loc:=LOC_REFERENCE;
+               paraloc^.reference.index:=NR_STACK_POINTER_REG;
+               paraloc^.reference.offset:=stack_offset;
+               inc(stack_offset,4);
+            end;
+        end;
+
+
+      begin
+        result:=0;
+        nextintreg:=curintreg;
+        nextfloatreg:=curfloatreg;
+        nextmmreg:=curmmreg;
+        stack_offset:=cur_stack_offset;
+
+        for i:=0 to paras.count-1 do
+          begin
+            hp:=tparavarsym(paras[i]);
+            { currently only support C-style array of const,
+              there should be no location assigned to the vararg array itself }
+            if (p.proccalloption in [pocall_cdecl,pocall_cppdecl]) and
+               is_array_of_const(hp.vartype.def) then
+              begin
+                paraloc:=hp.paraloc[side].add_location;
+                { hack: the paraloc must be valid, but is not actually used }
+                paraloc^.loc:=LOC_REGISTER;
+                paraloc^.register:=NR_R0;
+                paraloc^.size:=OS_ADDR;
+                break;
+              end;
+
+            if push_addr_param(hp.varspez,hp.vartype.def,p.proccalloption) then
+              paracgsize:=OS_ADDR
+            else
+              begin
+                paracgsize:=def_cgSize(hp.vartype.def);
+                if paracgsize=OS_NO then
+                  paracgsize:=OS_ADDR;
+              end;
+
+             hp.paraloc[side].reset;
+             hp.paraloc[side].size:=paracgsize;
+             hp.paraloc[side].Alignment:=std_param_align;
+
+             if (hp.varspez in [vs_var,vs_out]) then
+               begin
+                 paradef:=voidpointertype.def;
+                 loc:=LOC_REGISTER;
+               end
+             else
+               begin
+                 paradef:=hp.vartype.def;
+                 loc:=getparaloc(p.proccalloption,paradef);
+               end;
+
+             paralen:=tcgsize2size[paracgsize];
+             hp.paraloc[side].intsize:=paralen;
+{$ifdef EXTDEBUG}
+             if paralen=0 then
+               internalerror(200410311);
+{$endif EXTDEBUG}
+             while paralen>0 do
+               begin
+                 paraloc:=hp.paraloc[side].add_location;
+                 { for things like formaldef }
+                 if paracgsize=OS_NO then
+                   paraloc^.size:=OS_ADDR
+                 else if paracgsize in [OS_64,OS_S64] then
+                   paraloc^.size:=OS_32
+                 else if (loc=LOC_REGISTER) and (paracgsize in [OS_F32,OS_F64,OS_F80]) then
+                   case paracgsize of
+                     OS_F32:
+                       paraloc^.size:=OS_32;
+                     OS_F64:
+                       paraloc^.size:=OS_64;
+                     else
+                       internalerror(2005082901);
+                   end
+                 else
+                   paraloc^.size:=paracgsize;
+                 case loc of
+                    LOC_REGISTER:
+                      begin
+                        { this is not abi compliant }
+                        if nextintreg<=RS_R3 then
+                          begin
+                            paraloc^.loc:=LOC_REGISTER;
+                            paraloc^.register:=newreg(R_INTREGISTER,nextintreg,R_SUBWHOLE);
+                            inc(nextintreg);
+                          end
+                        else
+                          begin
+                            { LOC_REFERENCE covers always the overleft }
+                            paraloc^.loc:=LOC_REFERENCE;
+                            paraloc^.size:=int_cgsize(paralen);
+                            if (side=callerside) then
+                              paraloc^.reference.index:=NR_STACK_POINTER_REG;
+                            paraloc^.reference.offset:=stack_offset;
+                            inc(stack_offset,align(paralen,4));
+                            paralen:=0;
+                         end;
+                      end;
+                    LOC_FPUREGISTER:
+                      begin
+                        if nextfloatreg<=RS_F3 then
+                          begin
+                            paraloc^.loc:=LOC_FPUREGISTER;
+                            paraloc^.register:=newreg(R_FPUREGISTER,nextfloatreg,R_SUBWHOLE);
+                            inc(nextfloatreg);
+                          end
+                        else
+                          begin
+                            paraloc^.loc:=LOC_REFERENCE;
+                            paraloc^.reference.index:=NR_STACK_POINTER_REG;
+                            paraloc^.reference.offset:=stack_offset;
+                            case paraloc^.size of
+                              OS_F32:
+                                inc(stack_offset,4);
+                              OS_F64:
+                                inc(stack_offset,8);
+                              OS_F80:
+                                inc(stack_offset,10);
+                              OS_F128:
+                                inc(stack_offset,16);
+                              else
+                                internalerror(200403201);
+                            end;
+                          end;
+                      end;
+                    LOC_REFERENCE:
+                      begin
+                        paraloc^.size:=OS_ADDR;
+                        if push_addr_param(hp.varspez,paradef,p.proccalloption) or
+                          is_open_array(paradef) or
+                          is_array_of_const(paradef) then
+                          assignintreg
+                        else
+                          begin
+                             paraloc^.loc:=LOC_REFERENCE;
+                             paraloc^.reference.index:=NR_STACK_POINTER_REG;
+                             paraloc^.reference.offset:=stack_offset;
+                             inc(stack_offset,hp.vartype.def.size);
+                          end;
+                      end;
+                    else
+                      internalerror(2002071002);
+                 end;
+                 if side=calleeside then
+                   begin
+                     if paraloc^.loc=LOC_REFERENCE then
+                       begin
+                         paraloc^.reference.index:=NR_FRAME_POINTER_REG;
+                         inc(paraloc^.reference.offset,4);
+                       end;
+                   end;
+                 dec(paralen,tcgsize2size[paraloc^.size]);
+               end;
+             { hack to swap doubles in int registers }
+             if is_double(hp.vartype.def) and (paracgsize=OS_64) and
+               (hp.paraloc[side].location^.loc=LOC_REGISTER) then
+               begin
+                 paraloc:=hp.paraloc[side].location;
+                 hp.paraloc[side].location:=hp.paraloc[side].location^.next;
+                 hp.paraloc[side].location^.next:=paraloc;
+                 paraloc^.next:=nil;
+               end;
+          end;
+        curintreg:=nextintreg;
+        curfloatreg:=nextfloatreg;
+        curmmreg:=nextmmreg;
+        cur_stack_offset:=stack_offset;
+        result:=cur_stack_offset;
+      end;
+
+
+    function tarmparamanager.create_paraloc_info(p : tabstractprocdef; side: tcallercallee):longint;
+      var
+        cur_stack_offset: aword;
+        curintreg, curfloatreg, curmmreg: tsuperregister;
+        retcgsize  : tcgsize;
+      begin
+        init_values(curintreg,curfloatreg,curmmreg,cur_stack_offset);
+
+        result:=create_paraloc_info_intern(p,side,p.paras,curintreg,curfloatreg,curmmreg,cur_stack_offset);
+
+        { Constructors return self instead of a boolean }
+        if (p.proctypeoption=potype_constructor) then
+          retcgsize:=OS_ADDR
+        else
+          retcgsize:=def_cgsize(p.rettype.def);
+
+        location_reset(p.funcretloc[side],LOC_INVALID,OS_NO);
+        p.funcretloc[side].size:=retcgsize;
+
+        { void has no location }
+        if is_void(p.rettype.def) then
+          begin
+            location_reset(p.funcretloc[side],LOC_VOID,OS_NO);
+            exit;
+          end;
+
+        { Return in FPU register? }
+        if p.rettype.def.deftype=floatdef then
+          begin
+            if (p.proccalloption in [pocall_cdecl,pocall_cppdecl,pocall_softfloat]) or (cs_fp_emulation in aktmoduleswitches) then
+              begin
+                case retcgsize of
+                  OS_64,
+                  OS_F64:
+                    begin
+                      { low }
+                      p.funcretloc[side].loc:=LOC_REGISTER;
+                      p.funcretloc[side].register64.reglo:=NR_FUNCTION_RESULT64_HIGH_REG;
+                      p.funcretloc[side].register64.reghi:=NR_FUNCTION_RESULT64_LOW_REG;
+                      p.funcretloc[side].size:=OS_64;
+                    end;
+                  OS_32,
+                  OS_F32:
+                    begin
+                      p.funcretloc[side].loc:=LOC_REGISTER;
+                      p.funcretloc[side].register:=NR_FUNCTION_RETURN_REG;
+                      p.funcretloc[side].size:=OS_32;
+                    end;
+                  else
+                    internalerror(2005082603);
+                end;
+              end
+            else
+              begin
+                p.funcretloc[side].loc:=LOC_FPUREGISTER;
+                p.funcretloc[side].register:=NR_FPU_RESULT_REG;
+              end;
+          end
+          { Return in register? }
+        else if not ret_in_param(p.rettype.def,p.proccalloption) then
+          begin
+            if retcgsize in [OS_64,OS_S64] then
+              begin
+                { low }
+                p.funcretloc[side].loc:=LOC_REGISTER;
+                p.funcretloc[side].register64.reglo:=NR_FUNCTION_RESULT64_LOW_REG;
+                p.funcretloc[side].register64.reghi:=NR_FUNCTION_RESULT64_HIGH_REG;
+              end
+            else
+              begin
+                p.funcretloc[side].loc:=LOC_REGISTER;
+                p.funcretloc[side].register:=NR_FUNCTION_RETURN_REG;
+              end;
+          end
+        else
+          begin
+            p.funcretloc[side].loc:=LOC_REFERENCE;
+            p.funcretloc[side].size:=retcgsize;
+          end;
+     end;
+
+
+    function tarmparamanager.create_varargs_paraloc_info(p : tabstractprocdef; varargspara:tvarargsparalist):longint;
+      var
+        cur_stack_offset: aword;
+        curintreg, curfloatreg, curmmreg: tsuperregister;
+      begin
+        init_values(curintreg,curfloatreg,curmmreg,cur_stack_offset);
+
+        result:=create_paraloc_info_intern(p,callerside,p.paras,curintreg,curfloatreg,curmmreg,cur_stack_offset);
+        if (p.proccalloption in [pocall_cdecl,pocall_cppdecl]) then
+          { just continue loading the parameters in the registers }
+          result:=create_paraloc_info_intern(p,callerside,varargspara,curintreg,curfloatreg,curmmreg,cur_stack_offset)
+        else
+          internalerror(200410231);
+      end;
+
+begin
+   paramanager:=tarmparamanager.create;
+end.

+ 105 - 0
compiler/arm/cpupi.pas

@@ -0,0 +1,105 @@
+{
+    Copyright (c) 2002 by Florian Klaempfl
+
+    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.
+
+ ****************************************************************************
+}
+
+{ This unit contains the CPU specific part of tprocinfo. }
+unit cpupi;
+
+{$i fpcdefs.inc}
+
+  interface
+
+    uses
+       globtype,cutils,
+       procinfo,cpuinfo,psub;
+
+    type
+       tarmprocinfo = class(tcgprocinfo)
+          floatregstart : aint;
+          // procedure handle_body_start;override;
+          // procedure after_pass1;override;
+          procedure set_first_temp_offset;override;
+          procedure allocate_push_parasize(size: longint);override;
+          function calc_stackframe_size:longint;override;
+       end;
+
+
+  implementation
+
+    uses
+       globals,systems,
+       cpubase,
+       aasmtai,
+       tgobj,
+       symconst,symsym,paramgr,
+       cgbase,
+       cgobj;
+
+    procedure tarmprocinfo.set_first_temp_offset;
+      begin
+        { We allocate enough space to save all registers because we can't determine
+          the necessary space because the used registers aren't known before
+          secondpass is run. Even worse, patching
+          the local offsets after generating the code could cause trouble because
+          "shifter" constants could change to non-"shifter" constants. This
+          is especially a problem when taking the address of a local. For now,
+          this extra memory should hurt less than generating all local contants with offsets
+          >256 as non shifter constants }
+        tg.setfirsttemp(-12-28);
+      end;
+
+
+    procedure tarmprocinfo.allocate_push_parasize(size:longint);
+      begin
+        if size>maxpushedparasize then
+          maxpushedparasize:=size;
+      end;
+
+
+    function tarmprocinfo.calc_stackframe_size:longint;
+      var
+         firstfloatreg,lastfloatreg,
+         r : byte;
+         floatsavesize : aword;
+      begin
+        maxpushedparasize:=align(maxpushedparasize,max(aktalignment.localalignmin,4));
+        firstfloatreg:=RS_NO;
+        { save floating point registers? }
+        for r:=RS_F0 to RS_F7 do
+          if r in cg.rg[R_FPUREGISTER].used_in_proc-paramanager.get_volatile_registers_fpu(pocall_stdcall) then
+            begin
+              if firstfloatreg=RS_NO then
+                firstfloatreg:=r;
+              lastfloatreg:=r;
+            end;
+        if firstfloatreg<>RS_NO then
+          floatsavesize:=(lastfloatreg-firstfloatreg+1)*12
+        else
+          floatsavesize:=0;
+        floatsavesize:=align(floatsavesize,max(aktalignment.localalignmin,4));
+        result:=Align(tg.direction*tg.lasttemp,max(aktalignment.localalignmin,4))+maxpushedparasize+floatsavesize;
+        floatregstart:=-result+maxpushedparasize;
+      end;
+
+
+begin
+   cprocinfo:=tarmprocinfo;
+end.

+ 118 - 0
compiler/arm/cpuswtch.pas

@@ -0,0 +1,118 @@
+{
+    Copyright (c) 1998-2002 by Florian Klaempfl, Pierre Muller
+
+    interprets the commandline options which are arm specific
+
+    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 cpuswtch;
+
+{$i fpcdefs.inc}
+
+interface
+
+uses
+  options;
+
+type
+  toptionarm=class(toption)
+    procedure interpret_proc_specific_options(const opt:string);override;
+  end;
+
+implementation
+
+uses
+  cutils,globtype,systems,globals;
+
+procedure toptionarm.interpret_proc_specific_options(const opt:string);
+var
+  more: string;
+  j: longint;
+begin
+  More:=Upper(copy(opt,3,length(opt)-2));
+  case opt[2] of
+   'O' : Begin
+           j := 3;
+           While (j <= Length(Opt)) Do
+             Begin
+               case opt[j] of
+                 '-' :
+                   begin
+                     initglobalswitches:=initglobalswitches-[cs_optimize,cs_fastoptimize,cs_slowoptimize,cs_littlesize,
+                       cs_regvars,cs_uncertainopts];
+                     FillChar(ParaAlignment,sizeof(ParaAlignment),0);
+                   end;
+                 'a' :
+                   begin
+                     UpdateAlignmentStr(Copy(Opt,j+1,255),ParaAlignment);
+                     j:=length(Opt);
+                   end;
+                 'g' : initglobalswitches:=initglobalswitches+[cs_littlesize];
+                 'G' : initglobalswitches:=initglobalswitches-[cs_littlesize];
+                 'r' :
+                   begin
+                     initglobalswitches:=initglobalswitches+[cs_regvars];
+                     Simplify_ppu:=false;
+                   end;
+                 'u' : initglobalswitches:=initglobalswitches+[cs_uncertainopts];
+                 '1' : initglobalswitches:=initglobalswitches-[cs_fastoptimize,cs_slowoptimize]+[cs_optimize];
+                 '2' : initglobalswitches:=initglobalswitches-[cs_slowoptimize]+[cs_optimize,cs_fastoptimize];
+                 '3' : initglobalswitches:=initglobalswitches+[cs_optimize,cs_fastoptimize,cs_slowoptimize];
+{$ifdef dummy}
+                 'p' :
+                   Begin
+                     If j < Length(Opt) Then
+                       Begin
+                         Case opt[j+1] Of
+                           '1': initoptprocessor := Class386;
+                           '2': initoptprocessor := ClassP5;
+                           '3': initoptprocessor := ClassP6
+                           Else IllegalPara(Opt)
+                         End;
+                         Inc(j);
+                       End
+                     Else IllegalPara(opt)
+                   End;
+{$endif dummy}
+                 else IllegalPara(opt);
+               End;
+               Inc(j)
+             end;
+         end;
+{$ifdef dummy}
+   'R' : begin
+           if More='GAS' then
+            initasmmode:=asmmode_ppc_gas
+           else
+            if More='MOTOROLA' then
+             initasmmode:=asmmode_ppc_motorola
+           else
+            if More='DIRECT' then
+             initasmmode:=asmmode_direct
+           else
+            IllegalPara(opt);
+         end;
+{$endif dummy}
+  else
+   IllegalPara(opt);
+  end;
+end;
+
+
+initialization
+  coption:=toptionarm;
+end.

+ 78 - 0
compiler/arm/cputarg.pas

@@ -0,0 +1,78 @@
+{
+    Copyright (c) 2001-2002 by Peter Vreman
+
+    Includes the arm 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 }
+
+{**************************************
+             Targets
+**************************************}
+
+    {$ifndef NOTARGETLINUX}
+      ,t_linux
+    {$endif}
+    {$ifndef NOTARGETWINCE}
+      ,t_win
+    {$endif}
+    {$ifndef NOTARGETGBA}
+      ,t_gba
+    {$endif}
+
+{**************************************
+             Assemblers
+**************************************}
+
+    {$ifndef NOAGARMGAS}
+      ,agarmgas
+    {$endif}
+
+      ,ogcoff
+
+{**************************************
+        Assembler Readers
+**************************************}
+
+  {$ifndef NoRaarmgas}
+       ,raarmgas
+  {$endif NoRaarmgas}
+
+{**************************************
+             Debuginfo
+**************************************}
+
+  {$ifndef NoDbgStabs}
+      ,dbgstabs
+  {$endif NoDbgStabs}
+  {$ifndef NoDbgDwarf}
+      ,dbgdwarf
+  {$endif NoDbgDwarf}
+      ;
+
+end.

+ 93 - 0
compiler/arm/itcpugas.pas

@@ -0,0 +1,93 @@
+{
+    Copyright (c) 1998-2002 by Florian Klaempfl
+
+    This unit contains the ARM GAS 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 itcpugas;
+
+{$i fpcdefs.inc}
+
+interface
+
+  uses
+    cpubase,cgbase;
+
+
+  const
+    { Standard opcode string table (for each tasmop enumeration). The
+      opcode strings should conform to the names as defined by the
+      processor manufacturer.
+    }
+    gas_op2str : op2strtable = {$i armatt.inc}
+
+    function gas_regnum_search(const s:string):Tregister;
+    function gas_regname(r:Tregister):string;
+
+
+implementation
+
+    uses
+      cutils,verbose;
+
+    const
+      gas_regname_table : array[tregisterindex] of string[7] = (
+        {$i rarmstd.inc}
+      );
+
+      gas_regname_index : array[tregisterindex] of tregisterindex = (
+        {$i rarmsri.inc}
+      );
+
+    function findreg_by_gasname(const s:string):tregisterindex;
+      var
+        i,p : tregisterindex;
+      begin
+        {Binary search.}
+        p:=0;
+        i:=regnumber_count_bsstart;
+        repeat
+          if (p+i<=high(tregisterindex)) and (gas_regname_table[gas_regname_index[p+i]]<=s) then
+            p:=p+i;
+          i:=i shr 1;
+        until i=0;
+        if gas_regname_table[gas_regname_index[p]]=s then
+          findreg_by_gasname:=gas_regname_index[p]
+        else
+          findreg_by_gasname:=0;
+      end;
+
+
+    function gas_regnum_search(const s:string):Tregister;
+      begin
+        result:=regnumber_table[findreg_by_gasname(s)];
+      end;
+
+
+    function gas_regname(r:Tregister):string;
+      var
+        p : tregisterindex;
+      begin
+        p:=findreg_by_number(r);
+        if p<>0 then
+          result:=gas_regname_table[p]
+        else
+          result:=generic_regname(r);
+      end;
+
+end.

+ 336 - 0
compiler/arm/narmadd.pas

@@ -0,0 +1,336 @@
+{
+    Copyright (c) 2000-2002 by Florian Klaempfl
+
+    Code generation for add nodes on the ARM
+
+    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 narmadd;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+       node,ncgadd,cpubase;
+
+    type
+       tarmaddnode = class(tcgaddnode)
+       private
+          function  GetResFlags(unsigned:Boolean):TResFlags;
+       protected
+          procedure second_addfloat;override;
+          procedure second_cmpfloat;override;
+          procedure second_cmpordinal;override;
+          procedure second_cmpsmallset;override;
+          procedure second_cmp64bit;override;
+       end;
+
+  implementation
+
+    uses
+      globtype,systems,
+      cutils,verbose,globals,
+      symconst,symdef,paramgr,
+      aasmbase,aasmtai,aasmcpu,defutil,htypechk,
+      cgbase,cgutils,cgcpu,
+      cpuinfo,pass_1,pass_2,regvars,
+      cpupara,
+      ncon,nset,nadd,
+      ncgutil,tgobj,rgobj,rgcpu,cgobj,cg64f32;
+
+{*****************************************************************************
+                               TSparcAddNode
+*****************************************************************************}
+
+    function tarmaddnode.GetResFlags(unsigned:Boolean):TResFlags;
+      begin
+        case NodeType of
+          equaln:
+            GetResFlags:=F_EQ;
+          unequaln:
+            GetResFlags:=F_NE;
+          else
+            if not(unsigned) then
+              begin
+                if nf_swaped in flags then
+                  case NodeType of
+                    ltn:
+                      GetResFlags:=F_GT;
+                    lten:
+                      GetResFlags:=F_GE;
+                    gtn:
+                      GetResFlags:=F_LT;
+                    gten:
+                      GetResFlags:=F_LE;
+                  end
+                else
+                  case NodeType of
+                    ltn:
+                      GetResFlags:=F_LT;
+                    lten:
+                      GetResFlags:=F_LE;
+                    gtn:
+                      GetResFlags:=F_GT;
+                    gten:
+                      GetResFlags:=F_GE;
+                  end;
+              end
+            else
+              begin
+                if nf_swaped in Flags then
+                  case NodeType of
+                    ltn:
+                      GetResFlags:=F_HI;
+                    lten:
+                      GetResFlags:=F_CS;
+                    gtn:
+                      GetResFlags:=F_CC;
+                    gten:
+                      GetResFlags:=F_LS;
+                  end
+                else
+                  case NodeType of
+                    ltn:
+                      GetResFlags:=F_CC;
+                    lten:
+                      GetResFlags:=F_LS;
+                    gtn:
+                      GetResFlags:=F_HI;
+                    gten:
+                      GetResFlags:=F_CS;
+                  end;
+              end;
+        end;
+      end;
+
+
+    procedure tarmaddnode.second_addfloat;
+      var
+        op : TAsmOp;
+      begin
+        case aktfputype of
+          fpu_fpa,
+          fpu_fpa10,
+          fpu_fpa11:
+            begin
+              pass_left_right;
+              if (nf_swaped in flags) then
+                swapleftright;
+
+              case nodetype of
+                addn :
+                  op:=A_ADF;
+                muln :
+                  op:=A_MUF;
+                subn :
+                  op:=A_SUF;
+                slashn :
+                  op:=A_DVF;
+                else
+                  internalerror(200308313);
+              end;
+
+              { force fpureg as location, left right doesn't matter
+                as both will be in a fpureg }
+              location_force_fpureg(exprasmlist,left.location,true);
+              location_force_fpureg(exprasmlist,right.location,(left.location.loc<>LOC_CFPUREGISTER));
+
+              location_reset(location,LOC_FPUREGISTER,def_cgsize(resulttype.def));
+              if left.location.loc<>LOC_CFPUREGISTER then
+                location.register:=left.location.register
+              else
+                location.register:=right.location.register;
+
+              exprasmlist.concat(setoppostfix(taicpu.op_reg_reg_reg(op,
+                 location.register,left.location.register,right.location.register),
+                 cgsize2fpuoppostfix[def_cgsize(resulttype.def)]));
+
+              location.loc:=LOC_FPUREGISTER;
+            end;
+          fpu_soft:
+            { this case should be handled already by pass1 }
+            internalerror(200308252);
+          else
+            internalerror(200308251);
+        end;
+      end;
+
+
+    procedure tarmaddnode.second_cmpfloat;
+      begin
+        pass_left_right;
+        if (nf_swaped in flags) then
+          swapleftright;
+
+        { force fpureg as location, left right doesn't matter
+          as both will be in a fpureg }
+        location_force_fpureg(exprasmlist,left.location,true);
+        location_force_fpureg(exprasmlist,right.location,true);
+
+        location_reset(location,LOC_FLAGS,OS_NO);
+        location.resflags:=getresflags(true);
+
+        if nodetype in [equaln,unequaln] then
+          exprasmlist.concat(setoppostfix(taicpu.op_reg_reg(A_CMF,
+             left.location.register,right.location.register),
+             cgsize2fpuoppostfix[def_cgsize(resulttype.def)]))
+        else
+          exprasmlist.concat(setoppostfix(taicpu.op_reg_reg(A_CMFE,
+             left.location.register,right.location.register),
+             cgsize2fpuoppostfix[def_cgsize(resulttype.def)]));
+
+        location_reset(location,LOC_FLAGS,OS_NO);
+        location.resflags:=getresflags(false);
+      end;
+
+
+    procedure tarmaddnode.second_cmpsmallset;
+      var
+        tmpreg : tregister;
+      begin
+        pass_left_right;
+
+        location_reset(location,LOC_FLAGS,OS_NO);
+
+        force_reg_left_right(false,false);
+
+        case nodetype of
+          equaln:
+            begin
+              exprasmlist.concat(taicpu.op_reg_reg(A_CMP,left.location.register,right.location.register));
+              location.resflags:=F_EQ;
+            end;
+          unequaln:
+            begin
+              exprasmlist.concat(taicpu.op_reg_reg(A_CMP,left.location.register,right.location.register));
+              location.resflags:=F_NE;
+            end;
+          lten,
+          gten:
+            begin
+              if (not(nf_swaped in flags) and
+                  (nodetype = lten)) or
+                 ((nf_swaped in flags) and
+                  (nodetype = gten)) then
+                swapleftright;
+              tmpreg:=cg.getintregister(exprasmlist,location.size);
+              exprasmlist.concat(taicpu.op_reg_reg_reg(A_AND,tmpreg,left.location.register,right.location.register));
+              exprasmlist.concat(taicpu.op_reg_reg(A_CMP,tmpreg,right.location.register));
+              location.resflags:=F_EQ;
+            end;
+          else
+            internalerror(2004012401);
+        end;
+      end;
+
+
+    procedure tarmaddnode.second_cmp64bit;
+      var
+        unsigned : boolean;
+        tmpreg : tregister;
+        oldnodetype : tnodetype;
+      begin
+        pass_left_right;
+        force_reg_left_right(false,false);
+
+        unsigned:=not(is_signed(left.resulttype.def)) or
+                  not(is_signed(right.resulttype.def));
+
+        { operation requiring proper N, Z and C flags ? }
+        if unsigned or (nodetype in [equaln,unequaln]) then
+          begin
+            location_reset(location,LOC_FLAGS,OS_NO);
+            location.resflags:=getresflags(unsigned);
+            exprasmlist.concat(taicpu.op_reg_reg(A_CMP,left.location.register64.reghi,right.location.register64.reghi));
+            exprasmlist.concat(setcondition(taicpu.op_reg_reg(A_CMP,left.location.register64.reglo,right.location.register64.reglo),C_EQ));
+          end
+        else
+        { operation requiring proper N, Z and V flags ? }
+          begin
+            location_reset(location,LOC_JUMP,OS_NO);
+            exprasmlist.concat(taicpu.op_reg_reg(A_CMP,left.location.register64.reghi,right.location.register64.reghi));
+            { the jump the sequence is a little bit hairy }
+            case nodetype of
+               ltn,gtn:
+                 begin
+                    cg.a_jmp_flags(exprasmlist,getresflags(false),truelabel);
+                    { cheat a little bit for the negative test }
+                    toggleflag(nf_swaped);
+                    cg.a_jmp_flags(exprasmlist,getresflags(false),falselabel);
+                    toggleflag(nf_swaped);
+                 end;
+               lten,gten:
+                 begin
+                    oldnodetype:=nodetype;
+                    if nodetype=lten then
+                      nodetype:=ltn
+                    else
+                      nodetype:=gtn;
+                    cg.a_jmp_flags(exprasmlist,getresflags(unsigned),truelabel);
+                    { cheat for the negative test }
+                    if nodetype=ltn then
+                      nodetype:=gtn
+                    else
+                      nodetype:=ltn;
+                    cg.a_jmp_flags(exprasmlist,getresflags(unsigned),falselabel);
+                    nodetype:=oldnodetype;
+                 end;
+            end;
+            exprasmlist.concat(taicpu.op_reg_reg(A_CMP,left.location.register64.reglo,right.location.register64.reglo));
+            { the comparisaion of the low dword have to be
+               always unsigned!                            }
+            cg.a_jmp_flags(exprasmlist,getresflags(true),truelabel);
+            cg.a_jmp_always(exprasmlist,falselabel);
+          end;
+      end;
+
+
+    procedure tarmaddnode.second_cmpordinal;
+      var
+        unsigned : boolean;
+        tmpreg : tregister;
+        b : byte;
+      begin
+        pass_left_right;
+        force_reg_left_right(true,true);
+
+        unsigned:=not(is_signed(left.resulttype.def)) or
+                  not(is_signed(right.resulttype.def));
+
+        if right.location.loc = LOC_CONSTANT then
+          begin
+             if is_shifter_const(right.location.value,b) then
+               exprasmlist.concat(taicpu.op_reg_const(A_CMP,left.location.register,right.location.value))
+             else
+               begin
+                 tmpreg:=cg.getintregister(exprasmlist,location.size);
+                 cg.a_load_const_reg(exprasmlist,OS_INT,
+                   right.location.value,tmpreg);
+                 exprasmlist.concat(taicpu.op_reg_reg(A_CMP,left.location.register,tmpreg));
+               end;
+          end
+        else
+          exprasmlist.concat(taicpu.op_reg_reg(A_CMP,left.location.register,right.location.register));
+
+        location_reset(location,LOC_FLAGS,OS_NO);
+        location.resflags:=getresflags(unsigned);
+      end;
+
+begin
+  caddnode:=tarmaddnode;
+end.

+ 50 - 0
compiler/arm/narmcal.pas

@@ -0,0 +1,50 @@
+{
+    Copyright (c) 2002 by Florian Klaempfl
+
+    Implements the ARM specific part of 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 bymethodpointer
+    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 narmcal;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+      symdef,node,ncal,ncgcal;
+
+    type
+       tarmcallnode = class(tcgcallnode)
+          // procedure push_framepointer;override;
+       end;
+
+implementation
+
+  uses
+    paramgr;
+
+(*
+  procedure tarmcallnode.push_framepointer;
+    begin
+      framepointer_paraloc:=paramanager.getintparaloc(procdefinition.proccalloption,1);
+    end;
+*)
+
+begin
+   ccallnode:=tarmcallnode;
+end.

+ 265 - 0
compiler/arm/narmcnv.pas

@@ -0,0 +1,265 @@
+{
+    Copyright (c) 1998-2002 by Florian Klaempfl
+
+    Generate ARM assembler 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 narmcnv;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+      node,ncnv,ncgcnv,defcmp;
+
+    type
+       tarmtypeconvnode = class(tcgtypeconvnode)
+         protected
+           function first_int_to_real: tnode;override;
+         { procedure second_int_to_int;override; }
+         { procedure second_string_to_string;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; }
+       end;
+
+implementation
+
+   uses
+      verbose,globtype,globals,systems,
+      symconst,symdef,aasmbase,aasmtai,
+      defutil,
+      cgbase,cgutils,
+      pass_1,pass_2,
+      ncon,ncal,
+      ncgutil,
+      cpubase,aasmcpu,
+      rgobj,tgobj,cgobj,cgcpu;
+
+
+{*****************************************************************************
+                             FirstTypeConv
+*****************************************************************************}
+
+    function tarmtypeconvnode.first_int_to_real: tnode;
+      var
+        fname: string[19];
+      begin
+        if cs_fp_emulation in aktmoduleswitches then
+          begin
+            if target_info.system in system_wince then
+              begin
+                { converting a 64bit integer to a float requires a helper }
+                if is_64bitint(left.resulttype.def) or
+                  is_currency(left.resulttype.def) then
+                  begin
+                    { hack to avoid double division by 10000, as it's
+                      already done by resulttypepass.resulttype_int_to_real }
+                    if is_currency(left.resulttype.def) then
+                      left.resulttype := s64inttype;
+                    if is_signed(left.resulttype.def) then
+                      fname:='I64TOD'
+                    else
+                      fname:='UI64TOD';
+                  end
+                else
+                  { other integers are supposed to be 32 bit }
+                  begin
+                    if is_signed(left.resulttype.def) then
+                      fname:='ITOD'
+                    else
+                      fname:='UTOD';
+                    firstpass(left);
+                  end;
+                result:=ccallnode.createintern(fname,ccallparanode.create(
+                  left,nil));
+                left:=nil;
+                firstpass(result);
+                exit;
+              end
+            else
+              begin
+                internalerror(2005082803);
+              end;
+          end
+        else
+          begin
+            { converting a 64bit integer to a float requires a helper }
+            if is_64bitint(left.resulttype.def) or
+              is_currency(left.resulttype.def) then
+              begin
+                { hack to avoid double division by 10000, as it's
+                  already done by resulttypepass.resulttype_int_to_real }
+                if is_currency(left.resulttype.def) then
+                  left.resulttype := s64inttype;
+                if is_signed(left.resulttype.def) then
+                  fname := 'fpc_int64_to_double'
+                else
+                  fname := 'fpc_qword_to_double';
+                result := ccallnode.createintern(fname,ccallparanode.create(
+                  left,nil));
+                left:=nil;
+                firstpass(result);
+                exit;
+              end
+            else
+              { other integers are supposed to be 32 bit }
+              begin
+                if is_signed(left.resulttype.def) then
+                  inserttypeconv(left,s32inttype)
+                else
+                  inserttypeconv(left,u32inttype);
+                firstpass(left);
+              end;
+            result := nil;
+            if registersfpu<1 then
+              registersfpu:=1;
+            expectloc:=LOC_FPUREGISTER;
+          end;
+      end;
+
+
+    procedure tarmtypeconvnode.second_int_to_real;
+      var
+        instr : taicpu;
+      begin
+        location_reset(location,LOC_FPUREGISTER,def_cgsize(resulttype.def));
+        location_force_reg(exprasmlist,left.location,OS_32,true);
+        location.register:=cg.getfpuregister(exprasmlist,location.size);
+        instr:=taicpu.op_reg_reg(A_FLT,location.register,left.location.register);
+        instr.oppostfix:=cgsize2fpuoppostfix[def_cgsize(resulttype.def)];
+        exprasmlist.concat(instr);
+      end;
+
+
+    procedure tarmtypeconvnode.second_int_to_bool;
+      var
+        hregister : tregister;
+        href      : treference;
+        resflags  : tresflags;
+        hlabel,oldtruelabel,oldfalselabel : tasmlabel;
+      begin
+         oldtruelabel:=truelabel;
+         oldfalselabel:=falselabel;
+         objectlibrary.getjumplabel(truelabel);
+         objectlibrary.getjumplabel(falselabel);
+         secondpass(left);
+         if codegenerror then
+          exit;
+         { byte(boolean) or word(wordbool) or longint(longbool) must
+           be accepted for var parameters                            }
+         if (nf_explicit in flags) and
+            (left.resulttype.def.size=resulttype.def.size) and
+            (left.location.loc in [LOC_REFERENCE,LOC_CREFERENCE,LOC_CREGISTER]) then
+           begin
+              location_copy(location,left.location);
+              truelabel:=oldtruelabel;
+              falselabel:=oldfalselabel;
+              exit;
+           end;
+
+         { Load left node into flag F_NE/F_E }
+         resflags:=F_NE;
+         case left.location.loc of
+            LOC_CREFERENCE,
+            LOC_REFERENCE :
+              begin
+                if left.location.size in [OS_64,OS_S64] then
+                 begin
+                   hregister:=cg.getintregister(exprasmlist,OS_INT);
+                   cg.a_load_ref_reg(exprasmlist,OS_32,OS_32,left.location.reference,hregister);
+                   href:=left.location.reference;
+                   inc(href.offset,4);
+                   tcgarm(cg).cgsetflags:=true;
+                   cg.a_op_ref_reg(exprasmlist,OP_OR,OS_32,href,hregister);
+                   tcgarm(cg).cgsetflags:=false;
+                 end
+                else
+                 begin
+                   location_force_reg(exprasmlist,left.location,left.location.size,true);
+                   tcgarm(cg).cgsetflags:=true;
+                   cg.a_op_reg_reg(exprasmlist,OP_OR,left.location.size,left.location.register,left.location.register);
+                   tcgarm(cg).cgsetflags:=false;
+                 end;
+              end;
+            LOC_FLAGS :
+              begin
+                resflags:=left.location.resflags;
+              end;
+            LOC_REGISTER,LOC_CREGISTER :
+              begin
+                if left.location.size in [OS_64,OS_S64] then
+                 begin
+                   hregister:=cg.getintregister(exprasmlist,OS_32);
+                   cg.a_load_reg_reg(exprasmlist,OS_32,OS_32,left.location.register64.reglo,hregister);
+                   tcgarm(cg).cgsetflags:=true;
+                   cg.a_op_reg_reg(exprasmlist,OP_OR,OS_32,left.location.register64.reghi,hregister);
+                   tcgarm(cg).cgsetflags:=false;
+                 end
+                else
+                 begin
+                   tcgarm(cg).cgsetflags:=true;
+                   cg.a_op_reg_reg(exprasmlist,OP_OR,left.location.size,left.location.register,left.location.register);
+                   tcgarm(cg).cgsetflags:=false;
+                 end;
+              end;
+            LOC_JUMP :
+              begin
+                hregister:=cg.getintregister(exprasmlist,OS_INT);
+                objectlibrary.getjumplabel(hlabel);
+                cg.a_label(exprasmlist,truelabel);
+                cg.a_load_const_reg(exprasmlist,OS_INT,1,hregister);
+                cg.a_jmp_always(exprasmlist,hlabel);
+                cg.a_label(exprasmlist,falselabel);
+                cg.a_load_const_reg(exprasmlist,OS_INT,0,hregister);
+                cg.a_label(exprasmlist,hlabel);
+                tcgarm(cg).cgsetflags:=true;
+                cg.a_op_reg_reg(exprasmlist,OP_OR,OS_INT,hregister,hregister);
+                tcgarm(cg).cgsetflags:=false;
+              end;
+            else
+              internalerror(200311301);
+         end;
+         { load flags to register }
+         location_reset(location,LOC_REGISTER,def_cgsize(resulttype.def));
+         location.register:=cg.getintregister(exprasmlist,location.size);
+         cg.g_flags2reg(exprasmlist,location.size,resflags,location.register);
+         truelabel:=oldtruelabel;
+         falselabel:=oldfalselabel;
+      end;
+
+
+begin
+  ctypeconvnode:=tarmtypeconvnode;
+end.

+ 141 - 0
compiler/arm/narmcon.pas

@@ -0,0 +1,141 @@
+{
+    Copyright (c) 2005 by Florian Klaempfl
+
+    Code generation for const nodes on the ARM
+
+    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 narmcon;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+      node,ncgcon,cpubase;
+
+    type
+      tarmrealconstnode = class(tcgrealconstnode)
+        procedure pass_2;override;
+      end;
+
+  implementation
+
+    uses
+      verbose,
+      globtype,globals,
+      cpuinfo,
+      aasmbase,aasmtai,
+      symconst,symdef,
+      defutil,
+      cgbase,cgutils,
+      procinfo,
+      ncon;
+
+{*****************************************************************************
+                           TARMREALCONSTNODE
+*****************************************************************************}
+
+    procedure tarmrealconstnode.pass_2;
+      { I suppose the parser/pass_1 must make sure the generated real  }
+      { constants are actually supported by the target processor? (JM) }
+      const
+        floattype2ait:array[tfloattype] of taitype=
+          (ait_real_32bit,ait_real_64bit,ait_real_80bit,ait_comp_64bit,ait_comp_64bit,ait_real_128bit);
+      var
+         hp1 : tai;
+         lastlabel : tasmlabel;
+         realait : taitype;
+         hiloswapped : boolean;
+
+      begin
+        location_reset(location,LOC_CREFERENCE,def_cgsize(resulttype.def));
+        lastlabel:=nil;
+        realait:=floattype2ait[tfloatdef(resulttype.def).typ];
+        hiloswapped:=aktfputype in [fpu_fpa,fpu_fpa10,fpu_fpa11];
+        { const already used ? }
+        if not assigned(lab_real) then
+          begin
+            objectlibrary.getjumplabel(lastlabel);
+            lab_real:=lastlabel;
+            current_procinfo.aktlocaldata.concat(Tai_label.Create(lastlabel));
+            location.reference.symboldata:=current_procinfo.aktlocaldata.last;
+            case realait of
+              ait_real_32bit :
+                begin
+                  current_procinfo.aktlocaldata.concat(Tai_real_32bit.Create(ts32real(value_real)));
+                  { range checking? }
+                  if ((cs_check_range in aktlocalswitches) or
+                    (cs_check_overflow in aktlocalswitches)) and
+                    (tai_real_32bit(asmlist[al_typedconsts].last).value=double(MathInf)) then
+                    Message(parser_e_range_check_error);
+                end;
+
+              ait_real_64bit :
+                begin
+                  if hiloswapped then
+                    current_procinfo.aktlocaldata.concat(Tai_real_64bit.Create_hiloswapped(ts64real(value_real)))
+                  else
+                    current_procinfo.aktlocaldata.concat(Tai_real_64bit.Create(ts64real(value_real)));
+
+                  { range checking? }
+                  if ((cs_check_range in aktlocalswitches) or
+                    (cs_check_overflow in aktlocalswitches)) and
+                    (tai_real_64bit(asmlist[al_typedconsts].last).value=double(MathInf)) then
+                    Message(parser_e_range_check_error);
+               end;
+
+              ait_real_80bit :
+                begin
+                  current_procinfo.aktlocaldata.concat(Tai_real_80bit.Create(value_real));
+
+                  { range checking? }
+                  if ((cs_check_range in aktlocalswitches) or
+                    (cs_check_overflow in aktlocalswitches)) and
+                    (tai_real_80bit(asmlist[al_typedconsts].last).value=double(MathInf)) then
+                    Message(parser_e_range_check_error);
+                end;
+{$ifdef cpufloat128}
+              ait_real_128bit :
+                begin
+                  current_procinfo.aktlocaldata.concat(Tai_real_128bit.Create(value_real));
+
+                  { range checking? }
+                  if ((cs_check_range in aktlocalswitches) or
+                    (cs_check_overflow in aktlocalswitches)) and
+                    (tai_real_128bit(asmlist[al_typedconsts].last).value=double(MathInf)) then
+                    Message(parser_e_range_check_error);
+                end;
+{$endif cpufloat128}
+
+              { the round is necessary for native compilers where comp isn't a float }
+              ait_comp_64bit :
+                if (value_real>9223372036854775807.0) or (value_real<-9223372036854775808.0) then
+                  message(parser_e_range_check_error)
+                else
+                  current_procinfo.aktlocaldata.concat(Tai_comp_64bit.Create(round(value_real)));
+            else
+              internalerror(2005092401);
+            end;
+          end;
+        location.reference.symbol:=lab_real;
+        location.reference.base:=NR_R15;
+      end;
+
+begin
+  crealconstnode:=tarmrealconstnode;
+end.

+ 216 - 0
compiler/arm/narminl.pas

@@ -0,0 +1,216 @@
+{
+    Copyright (c) 1998-2002 by Florian Klaempfl
+
+    Generates ARM inline nodes
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+}
+unit narminl;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+      node,ninl,ncginl;
+
+    type
+      tarminlinenode = class(tcgInlineNode)
+        function first_abs_real: tnode; override;
+        function first_sqr_real: tnode; override;
+        function first_sqrt_real: tnode; override;
+        { atn,sin,cos,lgn isn't supported by the linux fpe
+        function first_arctan_real: tnode; override;
+        function first_ln_real: tnode; override;
+        function first_cos_real: tnode; override;
+        function first_sin_real: tnode; override;
+        }
+        procedure second_abs_real; override;
+        procedure second_sqr_real; override;
+        procedure second_sqrt_real; override;
+        { atn,sin,cos,lgn isn't supported by the linux fpe
+        procedure second_arctan_real; override;
+        procedure second_ln_real; override;
+        procedure second_cos_real; override;
+        procedure second_sin_real; override;
+        }
+      private
+        procedure load_fpu_location;
+      end;
+
+
+implementation
+
+    uses
+      globtype,systems,
+      cutils,verbose,globals,fmodule,
+      symconst,symdef,
+      aasmbase,aasmtai,aasmcpu,
+      cgbase,cgutils,
+      pass_1,pass_2,
+      cpubase,paramgr,
+      nbas,ncon,ncal,ncnv,nld,
+      tgobj,ncgutil,cgobj,cg64f32,rgobj,rgcpu,cgcpu;
+
+{*****************************************************************************
+                              tarminlinenode
+*****************************************************************************}
+
+    procedure tarminlinenode.load_fpu_location;
+      begin
+        secondpass(left);
+        location_force_fpureg(exprasmlist,left.location,true);
+        location_copy(location,left.location);
+        if left.location.loc=LOC_CFPUREGISTER then
+          begin
+           location.register:=cg.getfpuregister(exprasmlist,location.size);
+           location.loc := LOC_FPUREGISTER;
+         end;
+      end;
+
+
+    function tarminlinenode.first_abs_real : tnode;
+      begin
+        if cs_fp_emulation in aktmoduleswitches then
+          result:=inherited first_abs_real
+        else
+          begin
+            expectloc:=LOC_FPUREGISTER;
+            registersint:=left.registersint;
+            registersfpu:=max(left.registersfpu,1);
+            first_abs_real:=nil;
+          end;
+      end;
+
+
+    function tarminlinenode.first_sqr_real : tnode;
+      begin
+        if cs_fp_emulation in aktmoduleswitches then
+          result:=inherited first_sqr_real
+        else
+          begin
+            expectloc:=LOC_FPUREGISTER;
+            registersint:=left.registersint;
+            registersfpu:=max(left.registersfpu,1);
+            first_sqr_real:=nil;
+          end;
+      end;
+
+
+    function tarminlinenode.first_sqrt_real : tnode;
+      begin
+        if cs_fp_emulation in aktmoduleswitches then
+          result:=inherited first_sqrt_real
+        else
+          begin
+            expectloc:=LOC_FPUREGISTER;
+            registersint:=left.registersint;
+                    registersfpu:=max(left.registersfpu,1);
+            first_sqrt_real := nil;
+          end;
+      end;
+
+
+    { atn,sin,cos,lgn isn't supported by the linux fpe
+    function tarminlinenode.first_arctan_real: tnode;
+      begin
+        expectloc:=LOC_FPUREGISTER;
+        registersint:=left.registersint;
+        registersfpu:=max(left.registersfpu,1);
+        result:=nil;
+      end;
+
+
+    function tarminlinenode.first_ln_real: tnode;
+      begin
+        expectloc:=LOC_FPUREGISTER;
+        registersint:=left.registersint;
+        registersfpu:=max(left.registersfpu,1);
+        result:=nil;
+      end;
+
+    function tarminlinenode.first_cos_real: tnode;
+      begin
+        expectloc:=LOC_FPUREGISTER;
+        registersint:=left.registersint;
+        registersfpu:=max(left.registersfpu,1);
+        result:=nil;
+      end;
+
+
+    function tarminlinenode.first_sin_real: tnode;
+      begin
+        expectloc:=LOC_FPUREGISTER;
+        registersint:=left.registersint;
+        registersfpu:=max(left.registersfpu,1);
+        result:=nil;
+      end;
+    }
+
+
+    procedure tarminlinenode.second_abs_real;
+      begin
+        load_fpu_location;
+        exprasmlist.concat(setoppostfix(taicpu.op_reg_reg(A_ABS,location.register,location.register),get_fpu_postfix(resulttype.def)));
+      end;
+
+
+    procedure tarminlinenode.second_sqr_real;
+      begin
+        load_fpu_location;
+        exprasmlist.concat(setoppostfix(taicpu.op_reg_reg_reg(A_MUF,location.register,left.location.register,left.location.register),get_fpu_postfix(resulttype.def)));
+      end;
+
+
+    procedure tarminlinenode.second_sqrt_real;
+      begin
+        load_fpu_location;
+        exprasmlist.concat(setoppostfix(taicpu.op_reg_reg(A_SQT,location.register,location.register),get_fpu_postfix(resulttype.def)));
+      end;
+
+
+    { atn, sin, cos, lgn isn't supported by the linux fpe
+    procedure tarminlinenode.second_arctan_real;
+      begin
+        load_fpu_location;
+        exprasmlist.concat(setoppostfix(taicpu.op_reg_reg(A_ATN,location.register,location.register),get_fpu_postfix(resulttype.def)));
+      end;
+
+
+    procedure tarminlinenode.second_ln_real;
+      begin
+        load_fpu_location;
+        exprasmlist.concat(setoppostfix(taicpu.op_reg_reg(A_LGN,location.register,location.register),get_fpu_postfix(resulttype.def)));
+      end;
+
+    procedure tarminlinenode.second_cos_real;
+      begin
+        load_fpu_location;
+        exprasmlist.concat(setoppostfix(taicpu.op_reg_reg(A_COS,location.register,location.register),get_fpu_postfix(resulttype.def)));
+      end;
+
+
+    procedure tarminlinenode.second_sin_real;
+      begin
+        load_fpu_location;
+        exprasmlist.concat(setoppostfix(taicpu.op_reg_reg(A_SIN,location.register,location.register),get_fpu_postfix(resulttype.def)));
+      end;
+    }
+
+begin
+  cinlinenode:=tarminlinenode;
+end.

+ 121 - 0
compiler/arm/narmmat.pas

@@ -0,0 +1,121 @@
+{
+    Copyright (c) 1998-2002 by Florian Klaempfl
+
+    Generate ARM assembler for math nodes
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+}
+unit narmmat;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+      node,nmat,ncgmat;
+
+    type
+      tarmnotnode = class(tcgnotnode)
+        procedure second_boolean;override;
+      end;
+
+
+      tarmunaryminusnode = class(tcgunaryminusnode)
+        procedure second_float;override;
+      end;
+
+
+implementation
+
+    uses
+      globtype,systems,
+      cutils,verbose,globals,
+      symconst,symdef,
+      aasmbase,aasmcpu,aasmtai,
+      defutil,
+      cgbase,cgobj,cgutils,
+      pass_1,pass_2,
+      ncon,
+      cpubase,cpuinfo,
+      ncgutil,cgcpu,cg64f32,rgobj;
+
+{*****************************************************************************
+                               TARMNOTNODE
+*****************************************************************************}
+
+    procedure tarmnotnode.second_boolean;
+      var
+        hl : tasmlabel;
+        ins : taicpu;
+      begin
+        { if the location is LOC_JUMP, we do the secondpass after the
+          labels are allocated
+        }
+        if left.expectloc=LOC_JUMP then
+          begin
+            hl:=truelabel;
+            truelabel:=falselabel;
+            falselabel:=hl;
+            secondpass(left);
+            maketojumpbool(exprasmlist,left,lr_load_regvars);
+            hl:=truelabel;
+            truelabel:=falselabel;
+            falselabel:=hl;
+            location.loc:=LOC_JUMP;
+          end
+        else
+          begin
+            secondpass(left);
+            case left.location.loc of
+              LOC_FLAGS :
+                begin
+                  location_copy(location,left.location);
+                  inverse_flags(location.resflags);
+                end;
+              LOC_REGISTER,LOC_CREGISTER,LOC_REFERENCE,LOC_CREFERENCE :
+                begin
+                  location_force_reg(exprasmlist,left.location,def_cgsize(left.resulttype.def),true);
+                  exprasmlist.concat(taicpu.op_reg_const(A_CMP,left.location.register,0));
+                  location_reset(location,LOC_FLAGS,OS_NO);
+                  location.resflags:=F_EQ;
+               end;
+              else
+                internalerror(2003042401);
+            end;
+          end;
+      end;
+
+{*****************************************************************************
+                               TARMUNARYMINUSNODE
+*****************************************************************************}
+
+    procedure tarmunaryminusnode.second_float;
+      begin
+        secondpass(left);
+        location_reset(location,LOC_FPUREGISTER,def_cgsize(resulttype.def));
+        location_force_fpureg(exprasmlist,left.location,false);
+        location:=left.location;
+        exprasmlist.concat(setoppostfix(taicpu.op_reg_reg_const(A_RSF,
+          location.register,left.location.register,0),
+          cgsize2fpuoppostfix[def_cgsize(resulttype.def)]));
+      end;
+
+
+begin
+   cnotnode:=tarmnotnode;
+   cunaryminusnode:=tarmunaryminusnode;
+end.

+ 54 - 0
compiler/arm/raarm.pas

@@ -0,0 +1,54 @@
+{
+    Copyright (c) 1998-2003 by Carl Eric Codere and Peter Vreman
+
+    Handles the common arm assembler reader routines
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+}
+unit raarm;
+
+{$i fpcdefs.inc}
+
+  interface
+
+    uses
+      cpubase,
+      aasmtai,
+      rautils;
+
+    type
+      TARMOperand=class(TOperand)
+      end;
+
+      TARMInstruction=class(TInstruction)
+        oppostfix : toppostfix;
+        function ConcatInstruction(p:TAAsmoutput) : tai;override;
+      end;
+
+  implementation
+
+    uses
+      aasmcpu;
+
+    function TARMInstruction.ConcatInstruction(p:TAAsmoutput) : tai;
+      begin
+        result:=inherited ConcatInstruction(p);
+        (result as taicpu).oppostfix:=oppostfix;
+      end;
+
+
+end.

+ 797 - 0
compiler/arm/raarmgas.pas

@@ -0,0 +1,797 @@
+{
+    Copyright (c) 1998-2002 by Carl Eric Codere and Peter Vreman
+
+    Does the parsing for the ARM GNU AS styled inline assembler.
+
+    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 raarmgas;
+
+{$i fpcdefs.inc}
+
+  Interface
+
+    uses
+      raatt,raarm,
+      cpubase;
+
+    type
+      tarmattreader = class(tattreader)
+        actoppostfix : TOpPostfix;
+        function is_asmopcode(const s: string):boolean;override;
+        function is_register(const s:string):boolean;override;
+        procedure handleopcode;override;
+        procedure BuildReference(oper : tarmoperand);
+        procedure BuildOperand(oper : tarmoperand);
+        function TryBuildShifterOp(oper : tarmoperand) : boolean;
+        procedure BuildOpCode(instr : tarminstruction);
+        procedure ReadSym(oper : tarmoperand);
+        procedure ConvertCalljmp(instr : tarminstruction);
+      end;
+
+
+  Implementation
+
+    uses
+      { helpers }
+      cutils,
+      { global }
+      globtype,globals,verbose,
+      systems,
+      { aasm }
+      cpuinfo,aasmbase,aasmtai,aasmcpu,
+      { symtable }
+      symconst,symbase,symtype,symsym,symtable,
+      { parser }
+      scanner,
+      procinfo,
+      itcpugas,
+      rabase,rautils,
+      cgbase,cgobj
+      ;
+
+
+    function tarmattreader.is_register(const s:string):boolean;
+      type
+        treg2str = record
+          name : string[2];
+          reg : tregister;
+        end;
+
+      const
+        extraregs : array[0..19] of treg2str = (
+          (name: 'A1'; reg : NR_R0),
+          (name: 'A2'; reg : NR_R1),
+          (name: 'A3'; reg : NR_R2),
+          (name: 'A4'; reg : NR_R3),
+          (name: 'V1'; reg : NR_R4),
+          (name: 'V2'; reg : NR_R5),
+          (name: 'V3'; reg : NR_R6),
+          (name: 'V4'; reg : NR_R7),
+          (name: 'V5'; reg : NR_R8),
+          (name: 'V6'; reg : NR_R9),
+          (name: 'V7'; reg : NR_R10),
+          (name: 'V8'; reg : NR_R11),
+          (name: 'WR'; reg : NR_R7),
+          (name: 'SB'; reg : NR_R9),
+          (name: 'SL'; reg : NR_R10),
+          (name: 'FP'; reg : NR_R11),
+          (name: 'IP'; reg : NR_R12),
+          (name: 'SP'; reg : NR_R13),
+          (name: 'LR'; reg : NR_R14),
+          (name: 'PC'; reg : NR_R15));
+
+      var
+        i : longint;
+
+      begin
+        result:=inherited is_register(s);
+        { reg found?
+          possible aliases are always 2 char
+        }
+        if result or (length(s)<>2) then
+          exit;
+        for i:=low(extraregs) to high(extraregs) do
+          begin
+            if s=extraregs[i].name then
+              begin
+                actasmregister:=extraregs[i].reg;
+                result:=true;
+                actasmtoken:=AS_REGISTER;
+                exit;
+              end;
+          end;
+      end;
+
+
+    procedure tarmattreader.ReadSym(oper : tarmoperand);
+      var
+         tempstr : string;
+         typesize,l,k : longint;
+      begin
+        tempstr:=actasmpattern;
+        Consume(AS_ID);
+        { typecasting? }
+        if (actasmtoken=AS_LPAREN) and
+           SearchType(tempstr,typesize) then
+         begin
+           oper.hastype:=true;
+           Consume(AS_LPAREN);
+           BuildOperand(oper);
+           Consume(AS_RPAREN);
+           if oper.opr.typ in [OPR_REFERENCE,OPR_LOCAL] then
+             oper.SetSize(typesize,true);
+         end
+        else
+         if not oper.SetupVar(tempstr,false) then
+          Message1(sym_e_unknown_id,tempstr);
+        { record.field ? }
+        if actasmtoken=AS_DOT then
+         begin
+           BuildRecordOffsetSize(tempstr,l,k);
+           inc(oper.opr.ref.offset,l);
+         end;
+      end;
+
+
+    Procedure tarmattreader.BuildReference(oper : tarmoperand);
+
+      procedure Consume_RBracket;
+        begin
+          if actasmtoken<>AS_RBRACKET then
+           Begin
+             Message(asmr_e_invalid_reference_syntax);
+             RecoverConsume(true);
+           end
+          else
+           begin
+             Consume(AS_RBRACKET);
+             if not (actasmtoken in [AS_COMMA,AS_SEPARATOR,AS_END]) then
+              Begin
+                Message(asmr_e_invalid_reference_syntax);
+                RecoverConsume(true);
+              end;
+           end;
+        end;
+
+
+      procedure read_index;
+        begin
+          Consume(AS_COMMA);
+          if actasmtoken=AS_REGISTER then
+            Begin
+              oper.opr.ref.index:=actasmregister;
+              Consume(AS_REGISTER);
+            end
+          else if actasmtoken=AS_HASH then
+            begin
+              Consume(AS_HASH);
+              inc(oper.opr.ref.offset,BuildConstExpression(false,true));
+            end;
+        end;
+
+
+      begin
+        Consume(AS_LBRACKET);
+        if actasmtoken=AS_REGISTER then
+          begin
+            oper.opr.ref.base:=actasmregister;
+            Consume(AS_REGISTER);
+            { can either be a register or a right parenthesis }
+            { (reg)        }
+            if actasmtoken=AS_RBRACKET then
+             Begin
+               Consume_RBracket;
+               oper.opr.ref.addressmode:=AM_POSTINDEXED;
+               if actasmtoken=AS_COMMA then
+                 read_index;
+               exit;
+             end;
+            if actasmtoken=AS_COMMA then
+              begin
+                read_index;
+                Consume_RBracket;
+              end;
+            if actasmtoken=AS_NOT then
+              begin
+                consume(AS_NOT);
+                oper.opr.ref.addressmode:=AM_PREINDEXED;
+              end;
+          end {end case }
+        else
+          Begin
+            Message(asmr_e_invalid_reference_syntax);
+            RecoverConsume(false);
+          end;
+      end;
+
+
+    function tarmattreader.TryBuildShifterOp(oper : tarmoperand) : boolean;
+
+      procedure handlepara(sm : tshiftmode);
+        begin
+          consume(AS_ID);
+          fillchar(oper.opr,sizeof(oper.opr),0);
+          oper.opr.typ:=OPR_SHIFTEROP;
+          oper.opr.shifterop.shiftmode:=sm;
+          if sm<>SM_RRX then
+            begin
+              case actasmtoken of
+                AS_REGISTER:
+                  begin
+                    oper.opr.shifterop.rs:=actasmregister;
+                    consume(AS_REGISTER);
+                  end;
+                AS_HASH:
+                  begin
+                    consume(AS_HASH);
+                    oper.opr.shifterop.shiftimm:=BuildConstExpression(false,false);
+                  end;
+                else
+                  Message(asmr_e_illegal_shifterop_syntax);
+              end;
+            end;
+        end;
+
+      begin
+        result:=true;
+        if (actasmtoken=AS_ID) then
+          begin
+            if (actasmpattern='LSL') then
+              handlepara(SM_LSL)
+            else if (actasmpattern='LSR') then
+              handlepara(SM_LSR)
+            else if (actasmpattern='ASR') then
+              handlepara(SM_ASR)
+            else if (actasmpattern='ROR') then
+              handlepara(SM_ROR)
+            else if (actasmpattern='RRX') then
+              handlepara(SM_ROR)
+            else
+              result:=false;
+          end
+        else
+          result:=false;
+      end;
+
+
+    Procedure tarmattreader.BuildOperand(oper : tarmoperand);
+      var
+        expr : string;
+        typesize,l : longint;
+
+
+        procedure AddLabelOperand(hl:tasmlabel);
+          begin
+            if not(actasmtoken in [AS_PLUS,AS_MINUS,AS_LPAREN]) and
+               is_calljmp(actopcode) then
+             begin
+               oper.opr.typ:=OPR_SYMBOL;
+               oper.opr.symbol:=hl;
+             end
+            else
+             begin
+               oper.InitRef;
+               oper.opr.ref.symbol:=hl;
+             end;
+          end;
+
+
+        procedure MaybeRecordOffset;
+          var
+            hasdot  : boolean;
+            l,
+            toffset,
+            tsize   : longint;
+          begin
+            if not(actasmtoken in [AS_DOT,AS_PLUS,AS_MINUS]) then
+             exit;
+            l:=0;
+            hasdot:=(actasmtoken=AS_DOT);
+            if hasdot then
+              begin
+                if expr<>'' then
+                  begin
+                    BuildRecordOffsetSize(expr,toffset,tsize);
+                    inc(l,toffset);
+                    oper.SetSize(tsize,true);
+                  end;
+              end;
+            if actasmtoken in [AS_PLUS,AS_MINUS] then
+              inc(l,BuildConstExpression(true,false));
+            case oper.opr.typ of
+              OPR_LOCAL :
+                begin
+                  { don't allow direct access to fields of parameters, because that
+                    will generate buggy code. Allow it only for explicit typecasting }
+                  if hasdot and
+                     (not oper.hastype) and
+                     (tabstractnormalvarsym(oper.opr.localsym).owner.symtabletype=parasymtable) and
+                     (current_procinfo.procdef.proccalloption<>pocall_register) then
+                    Message(asmr_e_cannot_access_field_directly_for_parameters);
+                  inc(oper.opr.localsymofs,l)
+                end;
+              OPR_CONSTANT :
+                inc(oper.opr.val,l);
+              OPR_REFERENCE :
+                inc(oper.opr.ref.offset,l);
+              else
+                internalerror(200309221);
+            end;
+          end;
+
+
+        function MaybeBuildReference:boolean;
+          { Try to create a reference, if not a reference is found then false
+            is returned }
+          begin
+            MaybeBuildReference:=true;
+            case actasmtoken of
+              AS_INTNUM,
+              AS_MINUS,
+              AS_PLUS:
+                Begin
+                  oper.opr.ref.offset:=BuildConstExpression(True,False);
+                  if actasmtoken<>AS_LPAREN then
+                    Message(asmr_e_invalid_reference_syntax)
+                  else
+                    BuildReference(oper);
+                end;
+              AS_LPAREN:
+                BuildReference(oper);
+              AS_ID: { only a variable is allowed ... }
+                Begin
+                  ReadSym(oper);
+                  case actasmtoken of
+                    AS_END,
+                    AS_SEPARATOR,
+                    AS_COMMA: ;
+                    AS_LPAREN:
+                      BuildReference(oper);
+                  else
+                    Begin
+                      Message(asmr_e_invalid_reference_syntax);
+                      Consume(actasmtoken);
+                    end;
+                  end; {end case }
+                end;
+              else
+               MaybeBuildReference:=false;
+            end; { end case }
+          end;
+
+
+      var
+        tempreg : tregister;
+        ireg : tsuperregister;
+        hl : tasmlabel;
+        ofs : longint;
+        registerset : tcpuregisterset;
+      Begin
+        expr:='';
+        case actasmtoken of
+          AS_LBRACKET: { Memory reference or constant expression }
+            Begin
+              oper.InitRef;
+              BuildReference(oper);
+            end;
+
+          AS_HASH: { Constant expression  }
+            Begin
+              Consume(AS_HASH);
+              BuildConstantOperand(oper);
+            end;
+
+          (*
+          AS_INTNUM,
+          AS_MINUS,
+          AS_PLUS:
+            Begin
+              { Constant memory offset }
+              { This must absolutely be followed by (  }
+              oper.InitRef;
+              oper.opr.ref.offset:=BuildConstExpression(True,False);
+              if actasmtoken<>AS_LPAREN then
+                begin
+                  ofs:=oper.opr.ref.offset;
+                  BuildConstantOperand(oper);
+                  inc(oper.opr.val,ofs);
+                end
+              else
+                BuildReference(oper);
+            end;
+          *)
+          AS_ID: { A constant expression, or a Variable ref.  }
+            Begin
+              { Local Label ? }
+              if is_locallabel(actasmpattern) then
+               begin
+                 CreateLocalLabel(actasmpattern,hl,false);
+                 Consume(AS_ID);
+                 AddLabelOperand(hl);
+               end
+              else
+               { Check for label }
+               if SearchLabel(actasmpattern,hl,false) then
+                begin
+                  Consume(AS_ID);
+                  AddLabelOperand(hl);
+                end
+              else
+               { probably a variable or normal expression }
+               { or a procedure (such as in CALL ID)      }
+               Begin
+                 { is it a constant ? }
+                 if SearchIConstant(actasmpattern,l) then
+                  Begin
+                    if not (oper.opr.typ in [OPR_NONE,OPR_CONSTANT]) then
+                     Message(asmr_e_invalid_operand_type);
+                    BuildConstantOperand(oper);
+                  end
+                 else
+                  begin
+                    expr:=actasmpattern;
+                    Consume(AS_ID);
+                    { typecasting? }
+                    if (actasmtoken=AS_LPAREN) and
+                       SearchType(expr,typesize) then
+                     begin
+                       oper.hastype:=true;
+                       Consume(AS_LPAREN);
+                       BuildOperand(oper);
+                       Consume(AS_RPAREN);
+                       if oper.opr.typ in [OPR_REFERENCE,OPR_LOCAL] then
+                         oper.SetSize(typesize,true);
+                     end
+                    else
+                     begin
+                       if not(oper.SetupVar(expr,false)) then
+                        Begin
+                          { look for special symbols ... }
+                          if expr= '__HIGH' then
+                            begin
+                              consume(AS_LPAREN);
+                              if not oper.setupvar('high'+actasmpattern,false) then
+                                Message1(sym_e_unknown_id,'high'+actasmpattern);
+                              consume(AS_ID);
+                              consume(AS_RPAREN);
+                            end
+                          else
+                           if expr = '__RESULT' then
+                            oper.SetUpResult
+                          else
+                           if expr = '__SELF' then
+                            oper.SetupSelf
+                          else
+                           if expr = '__OLDEBP' then
+                            oper.SetupOldEBP
+                          else
+                            Message1(sym_e_unknown_id,expr);
+                        end;
+                     end;
+                  end;
+                  if actasmtoken=AS_DOT then
+                    MaybeRecordOffset;
+                  { add a constant expression? }
+                  if (actasmtoken=AS_PLUS) then
+                   begin
+                     l:=BuildConstExpression(true,false);
+                     case oper.opr.typ of
+                       OPR_CONSTANT :
+                         inc(oper.opr.val,l);
+                       OPR_LOCAL :
+                         inc(oper.opr.localsymofs,l);
+                       OPR_REFERENCE :
+                         inc(oper.opr.ref.offset,l);
+                       else
+                         internalerror(200309202);
+                     end;
+                   end
+               end;
+              { Do we have a indexing reference, then parse it also }
+              if actasmtoken=AS_LPAREN then
+                BuildReference(oper);
+            end;
+
+          { Register, a variable reference or a constant reference  }
+          AS_REGISTER:
+            Begin
+              { save the type of register used. }
+              tempreg:=actasmregister;
+              Consume(AS_REGISTER);
+              if (actasmtoken in [AS_END,AS_SEPARATOR,AS_COMMA]) then
+                Begin
+                  if not (oper.opr.typ in [OPR_NONE,OPR_REGISTER]) then
+                    Message(asmr_e_invalid_operand_type);
+                  oper.opr.typ:=OPR_REGISTER;
+                  oper.opr.reg:=tempreg;
+                end
+              else if (actasmtoken=AS_NOT) and (actopcode in [A_LDM,A_STM]) then
+                begin
+                  consume(AS_NOT);
+                  oper.opr.typ:=OPR_REFERENCE;
+                  oper.opr.ref.addressmode:=AM_PREINDEXED;
+                  oper.opr.ref.index:=tempreg;
+                end
+              else
+                Message(asmr_e_syn_operand);
+            end;
+
+          { Registerset }
+          AS_LSBRACKET:
+            begin
+              consume(AS_LSBRACKET);
+              registerset:=[];
+              while true do
+                begin
+                  if actasmtoken=AS_REGISTER then
+                    begin
+                      include(registerset,getsupreg(actasmregister));
+                      tempreg:=actasmregister;
+                      consume(AS_REGISTER);
+                      if actasmtoken=AS_MINUS then
+                        begin
+                          consume(AS_MINUS);
+                          for ireg:=getsupreg(tempreg) to getsupreg(actasmregister) do
+                            include(registerset,ireg);
+                          consume(AS_REGISTER);
+                        end;
+                    end
+                  else
+                    consume(AS_REGISTER);
+                  if actasmtoken=AS_COMMA then
+                    consume(AS_COMMA)
+                  else
+                    break;
+                end;
+              consume(AS_RSBRACKET);
+              oper.opr.typ:=OPR_REGSET;
+              oper.opr.regset:=registerset;
+            end;
+          AS_END,
+          AS_SEPARATOR,
+          AS_COMMA: ;
+        else
+          Begin
+            Message(asmr_e_syn_operand);
+            Consume(actasmtoken);
+          end;
+        end; { end case }
+      end;
+
+
+{*****************************************************************************
+                                tarmattreader
+*****************************************************************************}
+
+    procedure tarmattreader.BuildOpCode(instr : tarminstruction);
+      var
+        operandnum : longint;
+      Begin
+        { opcode }
+        if (actasmtoken<>AS_OPCODE) then
+         Begin
+           Message(asmr_e_invalid_or_missing_opcode);
+           RecoverConsume(true);
+           exit;
+         end;
+        { Fill the instr object with the current state }
+        with instr do
+          begin
+            Opcode:=ActOpcode;
+            condition:=ActCondition;
+            oppostfix:=actoppostfix;
+          end;
+
+        { We are reading operands, so opcode will be an AS_ID }
+        operandnum:=1;
+        Consume(AS_OPCODE);
+        { Zero operand opcode ?  }
+        if actasmtoken in [AS_SEPARATOR,AS_END] then
+         begin
+           operandnum:=0;
+           exit;
+         end;
+        { Read the operands }
+        repeat
+          case actasmtoken of
+            AS_COMMA: { Operand delimiter }
+              Begin
+                if ((instr.opcode=A_MOV) and (operandnum=2)) or
+                  ((operandnum=3) and not(instr.opcode in [A_UMLAL,A_UMULL,A_SMLAL,A_SMULL])) then
+                  begin
+                    Consume(AS_COMMA);
+                    if not(TryBuildShifterOp(instr.Operands[4] as tarmoperand)) then
+                      Message(asmr_e_illegal_shifterop_syntax);
+                    Inc(operandnum);
+                  end
+                else
+                  begin
+                    if operandnum>Max_Operands then
+                      Message(asmr_e_too_many_operands)
+                    else
+                      Inc(operandnum);
+                    Consume(AS_COMMA);
+                  end;
+              end;
+            AS_SEPARATOR,
+            AS_END : { End of asm operands for this opcode  }
+              begin
+                break;
+              end;
+          else
+            BuildOperand(instr.Operands[operandnum] as tarmoperand);
+          end; { end case }
+        until false;
+        instr.Ops:=operandnum;
+      end;
+
+
+    function tarmattreader.is_asmopcode(const s: string):boolean;
+
+      const
+        { sorted by length so longer postfixes will match first }
+        postfix2strsorted : array[1..19] of string[2] = (
+          'EP','SB','BT','SH',
+          'IA','IB','DA','DB','FD','FA','ED','EA',
+          'B','D','E','P','T','H','S');
+
+        postfixsorted : array[1..19] of TOpPostfix = (
+          PF_EP,PF_SB,PF_BT,PF_SH,
+          PF_IA,PF_IB,PF_DA,PF_DB,PF_FD,PF_FA,PF_ED,PF_EA,
+          PF_B,PF_D,PF_E,PF_P,PF_T,PF_H,PF_S);
+
+      var
+        str2opentry: tstr2opentry;
+        len,
+        j,
+        sufidx : longint;
+        hs : string;
+        maxlen : longint;
+        icond : tasmcond;
+      Begin
+        { making s a value parameter would break other assembler readers }
+        hs:=s;
+        is_asmopcode:=false;
+
+        { clear op code }
+        actopcode:=A_None;
+
+        actcondition:=C_None;
+
+        { first, handle B else BLS is read wrong }
+        if ((hs[1]='B') and (length(hs)=3)) then
+          begin
+            for icond:=low(tasmcond) to high(tasmcond) do
+              begin
+                if copy(hs,2,3)=uppercond2str[icond] then
+                  begin
+                    actopcode:=A_B;
+                    actasmtoken:=AS_OPCODE;
+                    actcondition:=icond;
+                    is_asmopcode:=true;
+                    exit;
+                  end;
+              end;
+          end;
+        maxlen:=max(length(hs),5);
+        for j:=maxlen downto 1 do
+          begin
+            str2opentry:=tstr2opentry(iasmops.search(copy(hs,1,j)));
+            if assigned(str2opentry) then
+              begin
+                actopcode:=str2opentry.op;
+                actasmtoken:=AS_OPCODE;
+                { strip op code }
+                delete(hs,1,j);
+                break;
+             end;
+          end;
+        if not(assigned(str2opentry)) then
+          exit;
+        { 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;
+                    { strip condition }
+                    delete(hs,1,2);
+                    break;
+                  end;
+              end;
+          end;
+        { check for postfix }
+        if length(hs)>0 then
+          begin
+            for j:=low(postfixsorted) to high(postfixsorted) do
+              begin
+                if copy(hs,1,length(postfix2strsorted[j]))=postfix2strsorted[j] then
+                  begin
+                    actoppostfix:=postfixsorted[j];
+                    { strip postfix }
+                    delete(hs,1,length(postfix2strsorted[j]));
+                    break;
+                  end;
+              end;
+          end;
+        { if we stripped all postfixes, it's a valid opcode }
+        is_asmopcode:=length(hs)=0;
+      end;
+
+
+    procedure tarmattreader.ConvertCalljmp(instr : tarminstruction);
+      var
+        newopr : toprrec;
+      begin
+        if instr.Operands[1].opr.typ=OPR_REFERENCE then
+          begin
+            newopr.typ:=OPR_SYMBOL;
+            newopr.symbol:=instr.Operands[1].opr.ref.symbol;
+            newopr.symofs:=instr.Operands[1].opr.ref.offset;
+            if (instr.Operands[1].opr.ref.base<>NR_NO) or
+              (instr.Operands[1].opr.ref.index<>NR_NO) then
+              Message(asmr_e_syn_operand);
+            instr.Operands[1].opr:=newopr;
+          end;
+      end;
+
+
+    procedure tarmattreader.handleopcode;
+      var
+        instr : tarminstruction;
+      begin
+        instr:=TarmInstruction.Create(TarmOperand);
+        BuildOpcode(instr);
+        if is_calljmp(instr.opcode) then
+          ConvertCalljmp(instr);
+        {
+        instr.AddReferenceSizes;
+        instr.SetInstructionOpsize;
+        instr.CheckOperandSizes;
+        }
+        instr.ConcatInstruction(curlist);
+        instr.Free;
+        actoppostfix:=PF_None;
+      end;
+
+
+{*****************************************************************************
+                                     Initialize
+*****************************************************************************}
+
+const
+  asmmode_arm_att_info : tasmmodeinfo =
+          (
+            id    : asmmode_arm_gas;
+            idtxt : 'GAS';
+            casmreader : tarmattreader;
+          );
+
+  asmmode_arm_standard_info : tasmmodeinfo =
+          (
+            id    : asmmode_standard;
+            idtxt : 'STANDARD';
+            casmreader : tarmattreader;
+          );
+
+initialization
+  RegisterAsmMode(asmmode_arm_att_info);
+  RegisterAsmMode(asmmode_arm_standard_info);
+end.

+ 74 - 0
compiler/arm/rarmcon.inc

@@ -0,0 +1,74 @@
+{ don't edit, this file is generated from armreg.dat }
+NR_NO = tregister($00000000);
+NR_R0 = tregister($01000000);
+NR_R1 = tregister($01000001);
+NR_R2 = tregister($01000002);
+NR_R3 = tregister($01000003);
+NR_R4 = tregister($01000004);
+NR_R5 = tregister($01000005);
+NR_R6 = tregister($01000006);
+NR_R7 = tregister($01000007);
+NR_R8 = tregister($01000008);
+NR_R9 = tregister($01000009);
+NR_R10 = tregister($0100000a);
+NR_R11 = tregister($0100000b);
+NR_R12 = tregister($0100000c);
+NR_R13 = tregister($0100000d);
+NR_R14 = tregister($0100000e);
+NR_R15 = tregister($0100000f);
+NR_F0 = tregister($02000000);
+NR_F1 = tregister($02000001);
+NR_F2 = tregister($02000002);
+NR_F3 = tregister($02000003);
+NR_F4 = tregister($02000004);
+NR_F5 = tregister($02000005);
+NR_F6 = tregister($02000006);
+NR_F7 = tregister($02000007);
+NR_S0 = tregister($03000000);
+NR_S1 = tregister($03000000);
+NR_D0 = tregister($03000000);
+NR_S2 = tregister($03000000);
+NR_S3 = tregister($03000000);
+NR_D1 = tregister($03000000);
+NR_S4 = tregister($03000000);
+NR_S5 = tregister($03000000);
+NR_D2 = tregister($03000000);
+NR_S6 = tregister($03000000);
+NR_S7 = tregister($03000000);
+NR_D3 = tregister($03000000);
+NR_S8 = tregister($03000000);
+NR_S9 = tregister($03000000);
+NR_D4 = tregister($03000000);
+NR_S10 = tregister($03000000);
+NR_S11 = tregister($03000000);
+NR_D5 = tregister($03000000);
+NR_S12 = tregister($03000000);
+NR_S13 = tregister($03000000);
+NR_D6 = tregister($03000000);
+NR_S14 = tregister($03000000);
+NR_S15 = tregister($03000000);
+NR_D7 = tregister($03000000);
+NR_S16 = tregister($03000000);
+NR_S17 = tregister($03000000);
+NR_D8 = tregister($03000000);
+NR_S18 = tregister($03000000);
+NR_S19 = tregister($03000000);
+NR_D9 = tregister($03000000);
+NR_S20 = tregister($03000000);
+NR_S21 = tregister($03000000);
+NR_D10 = tregister($03000000);
+NR_S22 = tregister($03000000);
+NR_S23 = tregister($03000000);
+NR_D11 = tregister($03000000);
+NR_S24 = tregister($03000000);
+NR_S25 = tregister($03000000);
+NR_D12 = tregister($03000000);
+NR_S26 = tregister($03000000);
+NR_S27 = tregister($03000000);
+NR_D13 = tregister($03000000);
+NR_S28 = tregister($03000000);
+NR_S29 = tregister($03000000);
+NR_D14 = tregister($03000000);
+NR_S30 = tregister($03000000);
+NR_S31 = tregister($03000000);
+NR_D15 = tregister($03000000);

+ 74 - 0
compiler/arm/rarmdwa.inc

@@ -0,0 +1,74 @@
+{ don't edit, this file is generated from armreg.dat }
+-1,
+0,
+1,
+2,
+3,
+4,
+5,
+6,
+7,
+8,
+9,
+10,
+11,
+12,
+13,
+14,
+15,
+16,
+17,
+18,
+19,
+20,
+21,
+22,
+23,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0

+ 2 - 0
compiler/arm/rarmnor.inc

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

+ 74 - 0
compiler/arm/rarmnum.inc

@@ -0,0 +1,74 @@
+{ don't edit, this file is generated from armreg.dat }
+tregister($00000000),
+tregister($01000000),
+tregister($01000001),
+tregister($01000002),
+tregister($01000003),
+tregister($01000004),
+tregister($01000005),
+tregister($01000006),
+tregister($01000007),
+tregister($01000008),
+tregister($01000009),
+tregister($0100000a),
+tregister($0100000b),
+tregister($0100000c),
+tregister($0100000d),
+tregister($0100000e),
+tregister($0100000f),
+tregister($02000000),
+tregister($02000001),
+tregister($02000002),
+tregister($02000003),
+tregister($02000004),
+tregister($02000005),
+tregister($02000006),
+tregister($02000007),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000),
+tregister($03000000)

+ 74 - 0
compiler/arm/rarmrni.inc

@@ -0,0 +1,74 @@
+{ don't edit, this file is generated from armreg.dat }
+0,
+1,
+2,
+3,
+4,
+5,
+6,
+7,
+8,
+9,
+10,
+11,
+12,
+13,
+14,
+15,
+16,
+17,
+18,
+19,
+20,
+21,
+22,
+23,
+24,
+25,
+26,
+27,
+28,
+29,
+30,
+31,
+32,
+33,
+34,
+35,
+36,
+37,
+38,
+39,
+40,
+41,
+42,
+43,
+44,
+45,
+46,
+47,
+48,
+49,
+50,
+51,
+52,
+53,
+54,
+55,
+56,
+57,
+58,
+59,
+60,
+61,
+62,
+63,
+64,
+65,
+66,
+67,
+68,
+69,
+70,
+71,
+72

+ 74 - 0
compiler/arm/rarmsri.inc

@@ -0,0 +1,74 @@
+{ don't edit, this file is generated from armreg.dat }
+0,
+27,
+30,
+57,
+60,
+63,
+66,
+69,
+72,
+33,
+36,
+39,
+42,
+45,
+48,
+51,
+54,
+17,
+18,
+19,
+20,
+21,
+22,
+23,
+24,
+1,
+2,
+11,
+12,
+13,
+14,
+15,
+16,
+3,
+4,
+5,
+6,
+7,
+8,
+9,
+10,
+25,
+26,
+40,
+41,
+43,
+44,
+46,
+47,
+49,
+50,
+52,
+53,
+28,
+55,
+70,
+71,
+56,
+58,
+59,
+61,
+62,
+64,
+65,
+67,
+68,
+29,
+31,
+32,
+34,
+35,
+37,
+38

+ 74 - 0
compiler/arm/rarmsta.inc

@@ -0,0 +1,74 @@
+{ don't edit, this file is generated from armreg.dat }
+-1,
+0,
+1,
+2,
+3,
+4,
+5,
+6,
+7,
+8,
+9,
+10,
+11,
+12,
+13,
+14,
+15,
+32,
+32,
+32,
+32,
+32,
+32,
+32,
+32,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0,
+0

+ 74 - 0
compiler/arm/rarmstd.inc

@@ -0,0 +1,74 @@
+{ don't edit, this file is generated from armreg.dat }
+'INVALID',
+'r0',
+'r1',
+'r2',
+'r3',
+'r4',
+'r5',
+'r6',
+'r7',
+'r8',
+'r9',
+'r10',
+'r11',
+'r12',
+'r13',
+'r14',
+'r15',
+'f0',
+'f1',
+'f2',
+'f3',
+'f4',
+'f5',
+'f6',
+'f7',
+'s0',
+'s1',
+'d0',
+'s2',
+'s3',
+'d1',
+'s4',
+'s5',
+'d2',
+'s6',
+'s7',
+'d3',
+'s8',
+'s9',
+'d4',
+'s10',
+'s11',
+'d5',
+'s12',
+'s13',
+'d6',
+'s14',
+'s15',
+'d7',
+'s16',
+'s17',
+'d8',
+'s18',
+'s19',
+'d9',
+'s20',
+'s21',
+'d10',
+'s22',
+'s23',
+'d11',
+'s24',
+'s25',
+'d12',
+'s26',
+'s27',
+'d13',
+'s28',
+'s29',
+'d14',
+'s20',
+'s21',
+'d15'

+ 74 - 0
compiler/arm/rarmsup.inc

@@ -0,0 +1,74 @@
+{ don't edit, this file is generated from armreg.dat }
+RS_NO = $00;
+RS_R0 = $00;
+RS_R1 = $01;
+RS_R2 = $02;
+RS_R3 = $03;
+RS_R4 = $04;
+RS_R5 = $05;
+RS_R6 = $06;
+RS_R7 = $07;
+RS_R8 = $08;
+RS_R9 = $09;
+RS_R10 = $0a;
+RS_R11 = $0b;
+RS_R12 = $0c;
+RS_R13 = $0d;
+RS_R14 = $0e;
+RS_R15 = $0f;
+RS_F0 = $00;
+RS_F1 = $01;
+RS_F2 = $02;
+RS_F3 = $03;
+RS_F4 = $04;
+RS_F5 = $05;
+RS_F6 = $06;
+RS_F7 = $07;
+RS_S0 = $00;
+RS_S1 = $00;
+RS_D0 = $00;
+RS_S2 = $00;
+RS_S3 = $00;
+RS_D1 = $00;
+RS_S4 = $00;
+RS_S5 = $00;
+RS_D2 = $00;
+RS_S6 = $00;
+RS_S7 = $00;
+RS_D3 = $00;
+RS_S8 = $00;
+RS_S9 = $00;
+RS_D4 = $00;
+RS_S10 = $00;
+RS_S11 = $00;
+RS_D5 = $00;
+RS_S12 = $00;
+RS_S13 = $00;
+RS_D6 = $00;
+RS_S14 = $00;
+RS_S15 = $00;
+RS_D7 = $00;
+RS_S16 = $00;
+RS_S17 = $00;
+RS_D8 = $00;
+RS_S18 = $00;
+RS_S19 = $00;
+RS_D9 = $00;
+RS_S20 = $00;
+RS_S21 = $00;
+RS_D10 = $00;
+RS_S22 = $00;
+RS_S23 = $00;
+RS_D11 = $00;
+RS_S24 = $00;
+RS_S25 = $00;
+RS_D12 = $00;
+RS_S26 = $00;
+RS_S27 = $00;
+RS_D13 = $00;
+RS_S28 = $00;
+RS_S29 = $00;
+RS_D14 = $00;
+RS_S30 = $00;
+RS_S31 = $00;
+RS_D15 = $00;

+ 168 - 0
compiler/arm/rgcpu.pas

@@ -0,0 +1,168 @@
+{
+    Copyright (c) 1998-2003 by Florian Klaempfl
+
+    This unit implements the arm specific class for the register
+    allocator
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+}
+
+unit rgcpu;
+
+{$i fpcdefs.inc}
+
+  interface
+
+     uses
+       aasmbase,aasmtai,aasmcpu,
+       cgbase,cgutils,
+       cpubase,
+       rgobj;
+
+     type
+       trgcpu = class(trgobj)
+         procedure do_spill_read(list:Taasmoutput;pos:tai;const spilltemp:treference;tempreg:tregister);override;
+         procedure do_spill_written(list:Taasmoutput;pos:tai;const spilltemp:treference;tempreg:tregister);override;
+       end;
+
+       trgintcpu = class(trgcpu)
+         procedure add_cpu_interferences(p : tai);override;
+       end;
+
+  implementation
+
+    uses
+      verbose, cutils,
+      cgobj,
+      procinfo;
+
+
+    procedure trgcpu.do_spill_read(list:Taasmoutput;pos:tai;const spilltemp:treference;tempreg:tregister);
+      var
+        helpins: tai;
+        tmpref : treference;
+        helplist : taasmoutput;
+        l : tasmlabel;
+        hreg : tregister;
+      begin
+        if abs(spilltemp.offset)>4095 then
+          begin
+            helplist:=taasmoutput.create;
+            reference_reset(tmpref);
+            { create consts entry }
+            objectlibrary.getjumplabel(l);
+            cg.a_label(current_procinfo.aktlocaldata,l);
+            tmpref.symboldata:=current_procinfo.aktlocaldata.last;
+
+            current_procinfo.aktlocaldata.concat(tai_const.Create_32bit(spilltemp.offset));
+
+            { load consts entry }
+            if getregtype(tempreg)=R_INTREGISTER then
+              hreg:=getregisterinline(helplist,R_SUBWHOLE)
+            else
+              hreg:=cg.getintregister(helplist,OS_ADDR);
+
+            tmpref.symbol:=l;
+            tmpref.base:=NR_R15;
+            helplist.concat(taicpu.op_reg_ref(A_LDR,hreg,tmpref));
+
+            reference_reset_base(tmpref,hreg,0);
+
+            if spilltemp.index<>NR_NO then
+              internalerror(200401263);
+
+            helpins:=spilling_create_load(tmpref,tempreg);
+            helplist.concat(helpins);
+            if pos=nil then
+              list.insertlistafter(list.first,helplist)
+            else
+              list.insertlistafter(pos.next,helplist);
+
+            helplist.free;
+          end
+        else
+          inherited do_spill_read(list,pos,spilltemp,tempreg);
+      end;
+
+
+    procedure trgcpu.do_spill_written(list:Taasmoutput;pos:tai;const spilltemp:treference;tempreg:tregister);
+      var
+        helpins: tai;
+        tmpref : treference;
+        helplist : taasmoutput;
+        l : tasmlabel;
+        hreg : tregister;
+      begin
+        if abs(spilltemp.offset)>4095 then
+          begin
+            helplist:=taasmoutput.create;
+            reference_reset(tmpref);
+            { create consts entry }
+            objectlibrary.getjumplabel(l);
+            cg.a_label(current_procinfo.aktlocaldata,l);
+            tmpref.symboldata:=current_procinfo.aktlocaldata.last;
+
+            current_procinfo.aktlocaldata.concat(tai_const.Create_32bit(spilltemp.offset));
+
+            { load consts entry }
+            if getregtype(tempreg)=R_INTREGISTER then
+              hreg:=getregisterinline(helplist,R_SUBWHOLE)
+            else
+              hreg:=cg.getintregister(helplist,OS_ADDR);
+            tmpref.symbol:=l;
+            tmpref.base:=NR_R15;
+            helplist.concat(taicpu.op_reg_ref(A_LDR,hreg,tmpref));
+
+            if spilltemp.index<>NR_NO then
+              internalerror(200401263);
+
+            reference_reset_base(tmpref,hreg,0);
+
+            helplist.concat(spilling_create_store(tempreg,tmpref));
+
+            if getregtype(tempreg)=R_INTREGISTER then
+              ungetregisterinline(helplist,hreg);
+
+            list.insertlistafter(pos,helplist)
+          end
+        else
+          inherited do_spill_written(list,pos,spilltemp,tempreg);
+      end;
+
+
+    procedure trgintcpu.add_cpu_interferences(p : tai);
+      begin
+        if p.typ=ait_instruction then
+          begin
+            case taicpu(p).opcode of
+              A_MUL:
+                add_edge(getsupreg(taicpu(p).oper[0]^.reg),getsupreg(taicpu(p).oper[1]^.reg));
+              A_UMULL,
+              A_UMLAL,
+              A_SMULL,
+              A_SMLAL:
+                begin
+                  add_edge(getsupreg(taicpu(p).oper[0]^.reg),getsupreg(taicpu(p).oper[1]^.reg));
+                  add_edge(getsupreg(taicpu(p).oper[1]^.reg),getsupreg(taicpu(p).oper[2]^.reg));
+                  add_edge(getsupreg(taicpu(p).oper[0]^.reg),getsupreg(taicpu(p).oper[2]^.reg));
+                end;
+            end;
+          end;
+      end;
+
+
+end.

+ 1482 - 0
compiler/assemble.pas

@@ -0,0 +1,1482 @@
+{
+    Copyright (c) 1998-2004 by Peter Vreman
+
+    This unit handles the assemblerfile write and assembler calls of FPC
+
+    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(This unit handles the assembler file write and assembler calls of FPC)
+   Handles the calls to the actual external assemblers, as well as the generation
+   of object files for smart linking. Also contains the base class for writing
+   the assembler statements to file.
+}
+unit assemble;
+
+{$i fpcdefs.inc}
+
+interface
+
+
+    uses
+{$IFDEF USE_SYSUTILS}
+      sysutils,
+{$ELSE USE_SYSUTILS}
+      strings,
+      dos,
+{$ENDIF USE_SYSUTILS}
+      systems,globtype,globals,aasmbase,aasmtai,ogbase;
+
+    const
+       { maximum of aasmoutput lists there will be }
+       maxoutputlists = 20;
+       { buffer size for writing the .s file }
+       AsmOutSize=32768;
+
+    type
+      TAssembler=class(TAbstractAssembler)
+      public
+      {filenames}
+        path     : pathstr;
+        name     : namestr;
+        asmfile,         { current .s and .o file }
+        objfile  : string;
+        ppufilename : string;
+        asmprefix : string;
+        SmartAsm : boolean;
+        SmartFilesCount,
+        SmartHeaderCount : longint;
+        Constructor Create(smart:boolean);virtual;
+        Destructor Destroy;override;
+        procedure NextSmartName(place:tcutplace);
+        procedure MakeObject;virtual;abstract;
+      end;
+
+      {# This is the base class which should be overriden for each each
+         assembler writer. It is used to actually assembler a file,
+         and write the output to the assembler file.
+      }
+      TExternalAssembler=class(TAssembler)
+      private
+        procedure CreateSmartLinkPath(const s:string);
+      protected
+      {outfile}
+        AsmSize,
+        AsmStartSize,
+        outcnt   : longint;
+        outbuf   : array[0..AsmOutSize-1] of char;
+        outfile  : file;
+        ioerror : boolean;
+      public
+        {# Returns the complete path and executable name of the assembler
+           program.
+
+           It first tries looking in the UTIL directory if specified,
+           otherwise it searches in the free pascal binary directory, in
+           the current working directory and then in the  directories
+           in the $PATH environment.}
+        Function  FindAssembler:string;
+
+        {# Actually does the call to the assembler file. Returns false
+           if the assembling of the file failed.}
+        Function  CallAssembler(const command:string; const para:TCmdStr):Boolean;
+
+        Function  DoAssemble:boolean;virtual;
+        Procedure RemoveAsm;
+        Procedure AsmFlush;
+        Procedure AsmClear;
+
+        {# Write a string to the assembler file }
+        Procedure AsmWrite(const s:string);
+
+        {# Write a string to the assembler file }
+        Procedure AsmWritePChar(p:pchar);
+
+        {# Write a string to the assembler file followed by a new line }
+        Procedure AsmWriteLn(const s:string);
+
+        {# Write a new line to the assembler file }
+        Procedure AsmLn;
+
+        procedure AsmCreate(Aplace:tcutplace);
+        procedure AsmClose;
+
+        {# This routine should be overriden for each assembler, it is used
+           to actually write the abstract assembler stream to file.}
+        procedure WriteTree(p:TAAsmoutput);virtual;
+
+        {# This routine should be overriden for each assembler, it is used
+           to actually write all the different abstract assembler streams
+           by calling for each stream type, the @var(WriteTree) method.}
+        procedure WriteAsmList;virtual;
+      public
+        Constructor Create(smart:boolean);override;
+        procedure MakeObject;override;
+      end;
+
+      TInternalAssembler=class(TAssembler)
+      public
+        constructor create(smart:boolean);override;
+        destructor  destroy;override;
+        procedure MakeObject;override;
+      protected
+        objectdata   : TAsmObjectData;
+        objectoutput : tobjectoutput;
+      private
+        { the aasmoutput lists that need to be processed }
+        lists        : byte;
+        list         : array[1..maxoutputlists] of TAAsmoutput;
+        { current processing }
+        currlistidx  : byte;
+        currlist     : TAAsmoutput;
+        currpass     : byte;
+        procedure convertstab(p:pchar);
+        function  MaybeNextList(var hp:Tai):boolean;
+        function  TreePass0(hp:Tai):Tai;
+        function  TreePass1(hp:Tai):Tai;
+        function  TreePass2(hp:Tai):Tai;
+        procedure writetree;
+        procedure writetreesmart;
+      end;
+
+    TAssemblerClass = class of TAssembler;
+
+    Procedure GenerateAsm(smart:boolean);
+    Procedure OnlyAsm;
+
+    procedure RegisterAssembler(const r:tasminfo;c:TAssemblerClass);
+    procedure InitAssembler;
+    procedure DoneAssembler;
+
+
+Implementation
+
+    uses
+{$ifdef hasunix}
+  {$ifdef havelinuxrtl10}
+      linux,
+  {$else}
+      unix,
+  {$endif}
+{$endif}
+      cutils,script,fmodule,verbose,
+{$ifdef memdebug}
+      cclasses,
+{$endif memdebug}
+{$ifdef m68k}
+      cpuinfo,
+{$endif m68k}
+      aasmcpu
+      ;
+
+    var
+      CAssembler : array[tasm] of TAssemblerClass;
+
+
+{*****************************************************************************
+                                   TAssembler
+*****************************************************************************}
+
+    Constructor TAssembler.Create(smart:boolean);
+      begin
+      { load start values }
+        asmfile:=current_module.get_asmfilename;
+        objfile:=current_module.objfilename^;
+        name:=Lower(current_module.modulename^);
+        path:=current_module.outputpath^;
+        asmprefix := current_module.asmprefix^;
+        if not assigned(current_module.outputpath) then
+          ppufilename := ''
+        else
+          ppufilename := current_module.ppufilename^;
+        SmartAsm:=smart;
+        SmartFilesCount:=0;
+        SmartHeaderCount:=0;
+        SmartLinkOFiles.Clear;
+      end;
+
+
+    Destructor TAssembler.Destroy;
+      begin
+      end;
+
+
+    procedure TAssembler.NextSmartName(place:tcutplace);
+      var
+        s : string;
+      begin
+        inc(SmartFilesCount);
+        if SmartFilesCount>999999 then
+         Message(asmw_f_too_many_asm_files);
+        case place of
+          cut_begin :
+            begin
+              inc(SmartHeaderCount);
+              s:=asmprefix+tostr(SmartHeaderCount)+'h';
+            end;
+          cut_normal :
+            s:=asmprefix+tostr(SmartHeaderCount)+'s';
+          cut_end :
+            s:=asmprefix+tostr(SmartHeaderCount)+'t';
+        end;
+        AsmFile:=Path+FixFileName(s+tostr(SmartFilesCount)+target_info.asmext);
+        ObjFile:=Path+FixFileName(s+tostr(SmartFilesCount)+target_info.objext);
+        { insert in container so it can be cleared after the linking }
+        SmartLinkOFiles.Insert(Objfile);
+      end;
+
+
+{*****************************************************************************
+                                 TExternalAssembler
+*****************************************************************************}
+
+    Function DoPipe:boolean;
+      begin
+        DoPipe:=(cs_asm_pipe in aktglobalswitches) and
+                not(cs_asm_leave in aktglobalswitches)
+                and ((target_asm.id in [as_gas,as_darwin]));
+      end;
+
+
+    Constructor TExternalAssembler.Create(smart:boolean);
+      begin
+        inherited Create(smart);
+        if SmartAsm then
+         begin
+           path:=FixPath(path+FixFileName(name)+target_info.smartext,false);
+           CreateSmartLinkPath(path);
+         end;
+        Outcnt:=0;
+      end;
+
+
+    procedure TExternalAssembler.CreateSmartLinkPath(const s:string);
+      var
+{$IFDEF USE_SYSUTILS}
+        dir : TSearchRec;
+{$ELSE USE_SYSUTILS}
+        dir : searchrec;
+{$ENDIF USE_SYSUTILS}
+        hs  : string;
+      begin
+        if PathExists(s) then
+         begin
+           { the path exists, now we clean only all the .o and .s files }
+           { .o files }
+{$IFDEF USE_SYSUTILS}
+           if findfirst(s+source_info.dirsep+'*'+target_info.objext,faAnyFile,dir) = 0
+           then repeat
+              RemoveFile(s+source_info.dirsep+dir.name);
+           until findnext(dir) <> 0;
+{$ELSE USE_SYSUTILS}
+           findfirst(s+source_info.dirsep+'*'+target_info.objext,anyfile,dir);
+           while (doserror=0) do
+            begin
+              RemoveFile(s+source_info.dirsep+dir.name);
+              findnext(dir);
+            end;
+{$ENDIF USE_SYSUTILS}
+           findclose(dir);
+           { .s files }
+{$IFDEF USE_SYSUTILS}
+           if findfirst(s+source_info.dirsep+'*'+target_info.asmext,faAnyFile,dir) = 0
+           then repeat
+             RemoveFile(s+source_info.dirsep+dir.name);
+           until findnext(dir) <> 0;
+{$ELSE USE_SYSUTILS}
+           findfirst(s+source_info.dirsep+'*'+target_info.asmext,anyfile,dir);
+           while (doserror=0) do
+            begin
+              RemoveFile(s+source_info.dirsep+dir.name);
+              findnext(dir);
+            end;
+{$ENDIF USE_SYSUTILS}
+           findclose(dir);
+         end
+        else
+         begin
+           hs:=s;
+           if hs[length(hs)] in ['/','\'] then
+            delete(hs,length(hs),1);
+           {$I-}
+            mkdir(hs);
+           {$I+}
+           if ioresult<>0 then;
+         end;
+      end;
+
+
+    const
+      lastas  : byte=255;
+    var
+      LastASBin : pathstr;
+    Function TExternalAssembler.FindAssembler:string;
+      var
+        asfound : boolean;
+        UtilExe  : string;
+      begin
+        asfound:=false;
+        if cs_link_on_target in aktglobalswitches then
+         begin
+           { If linking on target, don't add any path PM }
+           FindAssembler:=utilsprefix+AddExtension(target_asm.asmbin,target_info.exeext);
+           exit;
+         end
+        else
+         UtilExe:=utilsprefix+AddExtension(target_asm.asmbin,source_info.exeext);
+        if lastas<>ord(target_asm.id) then
+         begin
+           lastas:=ord(target_asm.id);
+           { is an assembler passed ? }
+           if utilsdirectory<>'' then
+             asfound:=FindFile(UtilExe,utilsdirectory,LastASBin);
+           if not AsFound then
+             asfound:=FindExe(UtilExe,LastASBin);
+           if (not asfound) and not(cs_asm_extern in aktglobalswitches) then
+            begin
+              Message1(exec_e_assembler_not_found,LastASBin);
+              aktglobalswitches:=aktglobalswitches+[cs_asm_extern];
+            end;
+           if asfound then
+            Message1(exec_t_using_assembler,LastASBin);
+         end;
+        FindAssembler:=LastASBin;
+      end;
+
+
+    Function TExternalAssembler.CallAssembler(const command:string; const para:TCmdStr):Boolean;
+{$IFDEF USE_SYSUTILS}
+      var
+        DosExitCode:Integer;
+{$ENDIF USE_SYSUTILS}
+      begin
+        callassembler:=true;
+        if not(cs_asm_extern in aktglobalswitches) then
+{$IFDEF USE_SYSUTILS}
+        try
+          DosExitCode := ExecuteProcess(command,para);
+          if DosExitCode <>0
+          then begin
+            Message1(exec_e_error_while_assembling,tostr(dosexitcode));
+            callassembler:=false;
+          end;
+        except on E:EOSError do
+          begin
+            Message1(exec_e_cant_call_assembler,tostr(E.ErrorCode));
+            aktglobalswitches:=aktglobalswitches+[cs_asm_extern];
+            callassembler:=false;
+          end
+        end
+{$ELSE USE_SYSUTILS}
+         begin
+           swapvectors;
+           exec(maybequoted(command),para);
+           swapvectors;
+           if (doserror<>0) then
+            begin
+              Message1(exec_e_cant_call_assembler,tostr(doserror));
+              aktglobalswitches:=aktglobalswitches+[cs_asm_extern];
+              callassembler:=false;
+            end
+           else
+            if (dosexitcode<>0) then
+             begin
+              Message1(exec_e_error_while_assembling,tostr(dosexitcode));
+              callassembler:=false;
+             end;
+         end
+{$ENDIF USE_SYSUTILS}
+        else
+         AsmRes.AddAsmCommand(command,para,name);
+      end;
+
+
+    procedure TExternalAssembler.RemoveAsm;
+      var
+        g : file;
+      begin
+        if cs_asm_leave in aktglobalswitches then
+         exit;
+        if cs_asm_extern in aktglobalswitches then
+         AsmRes.AddDeleteCommand(AsmFile)
+        else
+         begin
+           assign(g,AsmFile);
+           {$I-}
+            erase(g);
+           {$I+}
+           if ioresult<>0 then;
+         end;
+      end;
+
+
+    Function TExternalAssembler.DoAssemble:boolean;
+      var
+        s : TCmdStr;
+      begin
+        DoAssemble:=true;
+        if DoPipe then
+         exit;
+        if not(cs_asm_extern in aktglobalswitches) then
+         begin
+           if SmartAsm then
+            begin
+              if (SmartFilesCount<=1) then
+               Message1(exec_i_assembling_smart,name);
+            end
+           else
+           Message1(exec_i_assembling,name);
+         end;
+        s:=target_asm.asmcmd;
+{$ifdef m68k}
+        if aktoptprocessor = MC68020 then
+          s:='-m68020 '+s
+        else
+          s:='-m68000 '+s;
+{$endif}
+        if (cs_link_on_target in aktglobalswitches) then
+         begin
+           Replace(s,'$ASM',maybequoted(ScriptFixFileName(AsmFile)));
+           Replace(s,'$OBJ',maybequoted(ScriptFixFileName(ObjFile)));
+         end
+        else
+         begin
+           Replace(s,'$ASM',maybequoted(AsmFile));
+           Replace(s,'$OBJ',maybequoted(ObjFile));
+         end;
+        if CallAssembler(FindAssembler,s) then
+         RemoveAsm
+        else
+         begin
+            DoAssemble:=false;
+            GenerateError;
+         end;
+      end;
+
+
+    Procedure TExternalAssembler.AsmFlush;
+      begin
+        if outcnt>0 then
+         begin
+           { suppress i/o error }
+           {$i-}
+           BlockWrite(outfile,outbuf,outcnt);
+           {$i+}
+           ioerror:=ioerror or (ioresult<>0);
+           outcnt:=0;
+         end;
+      end;
+
+
+    Procedure TExternalAssembler.AsmClear;
+      begin
+        outcnt:=0;
+      end;
+
+
+    Procedure TExternalAssembler.AsmWrite(const s:string);
+      begin
+        if OutCnt+length(s)>=AsmOutSize then
+         AsmFlush;
+        Move(s[1],OutBuf[OutCnt],length(s));
+        inc(OutCnt,length(s));
+        inc(AsmSize,length(s));
+      end;
+
+
+    Procedure TExternalAssembler.AsmWriteLn(const s:string);
+      begin
+        AsmWrite(s);
+        AsmLn;
+      end;
+
+
+    Procedure TExternalAssembler.AsmWritePChar(p:pchar);
+      var
+        i,j : longint;
+      begin
+        i:=StrLen(p);
+        j:=i;
+        while j>0 do
+         begin
+           i:=min(j,AsmOutSize);
+           if OutCnt+i>=AsmOutSize then
+            AsmFlush;
+           Move(p[0],OutBuf[OutCnt],i);
+           inc(OutCnt,i);
+           inc(AsmSize,i);
+           dec(j,i);
+           p:=pchar(@p[i]);
+         end;
+      end;
+
+
+    Procedure TExternalAssembler.AsmLn;
+      begin
+        if OutCnt>=AsmOutSize-2 then
+         AsmFlush;
+        if (cs_link_on_target in aktglobalswitches) then
+          begin
+            OutBuf[OutCnt]:=target_info.newline[1];
+            inc(OutCnt);
+            inc(AsmSize);
+            if length(target_info.newline)>1 then
+             begin
+               OutBuf[OutCnt]:=target_info.newline[2];
+               inc(OutCnt);
+               inc(AsmSize);
+             end;
+          end
+        else
+          begin
+            OutBuf[OutCnt]:=source_info.newline[1];
+            inc(OutCnt);
+            inc(AsmSize);
+            if length(source_info.newline)>1 then
+             begin
+               OutBuf[OutCnt]:=source_info.newline[2];
+               inc(OutCnt);
+               inc(AsmSize);
+             end;
+          end;
+      end;
+
+
+    procedure TExternalAssembler.AsmCreate(Aplace:tcutplace);
+      begin
+        if SmartAsm then
+         NextSmartName(Aplace);
+{$ifdef hasunix}
+        if DoPipe then
+         begin
+           Message1(exec_i_assembling_pipe,asmfile);
+           POpen(outfile,'as -o '+objfile,'W');
+         end
+        else
+{$endif}
+         begin
+           Assign(outfile,asmfile);
+           {$I-}
+           Rewrite(outfile,1);
+           {$I+}
+           if ioresult<>0 then
+             begin
+               ioerror:=true;
+               Message1(exec_d_cant_create_asmfile,asmfile);
+             end;
+         end;
+        outcnt:=0;
+        AsmSize:=0;
+        AsmStartSize:=0;
+      end;
+
+
+    procedure TExternalAssembler.AsmClose;
+      var
+        f : file;
+        FileAge : longint;
+      begin
+        AsmFlush;
+{$ifdef hasunix}
+        if DoPipe then
+          begin
+            if PClose(outfile) <> 0 then
+              GenerateError;
+          end
+        else
+{$endif}
+         begin
+         {Touch Assembler time to ppu time is there is a ppufilename}
+           if ppufilename<>'' then
+            begin
+              Assign(f,ppufilename);
+              {$I-}
+              reset(f,1);
+              {$I+}
+              if ioresult=0 then
+               begin
+{$IFDEF USE_SYSUTILS}
+                 FileAge := FileGetDate(GetFileHandle(f));
+{$ELSE USE_SYSUTILS}
+                 GetFTime(f, FileAge);
+{$ENDIF USE_SYSUTILS}
+                 close(f);
+                 reset(outfile,1);
+{$IFDEF USE_SYSUTILS}
+                 FileSetDate(GetFileHandle(outFile),FileAge);
+{$ELSE USE_SYSUTILS}
+                 SetFTime(f, FileAge);
+{$ENDIF USE_SYSUTILS}
+               end;
+            end;
+           close(outfile);
+         end;
+      end;
+
+
+    procedure TExternalAssembler.WriteTree(p:TAAsmoutput);
+      begin
+      end;
+
+
+    procedure TExternalAssembler.WriteAsmList;
+      begin
+      end;
+
+
+    procedure TExternalAssembler.MakeObject;
+      begin
+        AsmCreate(cut_normal);
+        WriteAsmList;
+        AsmClose;
+        if not(ioerror) then
+          DoAssemble;
+      end;
+
+
+{*****************************************************************************
+                                  TInternalAssembler
+*****************************************************************************}
+
+    constructor TInternalAssembler.create(smart:boolean);
+      begin
+        inherited create(smart);
+        objectoutput:=nil;
+        objectdata:=nil;
+        SmartAsm:=smart;
+        currpass:=0;
+      end;
+
+
+   destructor TInternalAssembler.destroy;
+{$ifdef MEMDEBUG}
+      var
+        d : tmemdebug;
+{$endif}
+      begin
+{$ifdef MEMDEBUG}
+        d := tmemdebug.create(name+' - agbin');
+{$endif}
+        objectdata.free;
+        objectoutput.free;
+{$ifdef MEMDEBUG}
+        d.free;
+{$endif}
+      end;
+
+
+    procedure TInternalAssembler.convertstab(p:pchar);
+
+        function consumecomma(var p:pchar):boolean;
+        begin
+          while (p^=' ') do
+            inc(p);
+          result:=(p^=',');
+          inc(p);
+        end;
+
+        function consumenumber(var p:pchar;out value:longint):boolean;
+        var
+          hs : string;
+          len,
+          code : integer;
+        begin
+          value:=0;
+          while (p^=' ') do
+            inc(p);
+          len:=0;
+          while (p^ in ['0'..'9']) do
+            begin
+              inc(len);
+              hs[len]:=p^;
+              inc(p);
+            end;
+          if len>0 then
+            begin
+              hs[0]:=chr(len);
+              val(hs,value,code);
+            end
+          else
+            code:=-1;
+          result:=(code=0);
+        end;
+
+        function consumeoffset(var p:pchar;out relocsym:tasmsymbol;out value:longint):boolean;
+        var
+          hs        : string;
+          len,
+          code      : integer;
+          pstart    : pchar;
+          sym       : tasmsymbol;
+          exprvalue : longint;
+          gotmin,
+          dosub     : boolean;
+        begin
+          result:=false;
+          value:=0;
+          relocsym:=nil;
+          gotmin:=false;
+          repeat
+            dosub:=false;
+            exprvalue:=0;
+            if gotmin then
+              begin
+                dosub:=true;
+                gotmin:=false;
+              end;
+            while (p^=' ') do
+              inc(p);
+            case p^ of
+              #0 :
+                break;
+              ' ' :
+                inc(p);
+              '0'..'9' :
+                begin
+                  len:=0;
+                  while (p^ in ['0'..'9']) do
+                    begin
+                      inc(len);
+                      hs[len]:=p^;
+                      inc(p);
+                    end;
+                  hs[0]:=chr(len);
+                  val(hs,exprvalue,code);
+                end;
+              '.','_',
+              'A'..'Z',
+              'a'..'z' :
+                begin
+                  pstart:=p;
+                  while not(p^ in [#0,' ','-','+']) do
+                    inc(p);
+                  len:=p-pstart;
+                  if len>255 then
+                    internalerror(200509187);
+                  move(pstart^,hs[1],len);
+                  hs[0]:=chr(len);
+                  sym:=objectlibrary.newasmsymbol(hs,AB_EXTERNAL,AT_NONE);
+                  if not assigned(sym) then
+                    internalerror(200509188);
+                  objectlibrary.UsedAsmSymbolListInsert(sym);
+                  { Second symbol? }
+                  if assigned(relocsym) then
+                    begin
+                      if (relocsym.section<>sym.section) then
+                        internalerror(2005091810);
+                      relocsym:=nil;
+                    end
+                  else
+                    begin
+                      relocsym:=sym;
+                    end;
+                  exprvalue:=sym.address;
+                end;
+              '+' :
+                begin
+                  { nothing, by default addition is done }
+                  inc(p);
+                end;
+              '-' :
+                begin
+                  gotmin:=true;
+                  inc(p);
+                end;
+              else
+                internalerror(200509189);
+            end;
+            if dosub then
+              dec(value,exprvalue)
+            else
+              inc(value,exprvalue);
+          until false;
+          result:=true;
+        end;
+
+      const
+        N_Function = $24; { function or const }
+      var
+        ofs,
+        nline,
+        nidx,
+        nother,
+        i         : longint;
+        relocsym  : tasmsymbol;
+        pstr,
+        pcurr,
+        pendquote : pchar;
+      begin
+        pcurr:=nil;
+        pstr:=nil;
+        pendquote:=nil;
+
+        { Parse string part }
+        if p[0]='"' then
+          begin
+            pstr:=@p[1];
+            { Ignore \" inside the string }
+            i:=1;
+            while not((p[i]='"') and (p[i-1]<>'\')) and
+                  (p[i]<>#0) do
+              inc(i);
+            pendquote:=@p[i];
+            pendquote^:=#0;
+            pcurr:=@p[i+1];
+            if not consumecomma(pcurr) then
+              internalerror(200509181);
+          end
+        else
+          pcurr:=p;
+
+        { When in pass 1 then only alloc and leave }
+        if currpass=1 then
+          objectdata.allocstab(pstr)
+        else
+          begin
+            { Stabs format: nidx,nother,nline[,offset] }
+            if not consumenumber(pcurr,nidx) then
+              internalerror(200509182);
+            if not consumecomma(pcurr) then
+              internalerror(200509183);
+            if not consumenumber(pcurr,nother) then
+              internalerror(200509184);
+            if not consumecomma(pcurr) then
+              internalerror(200509185);
+            if not consumenumber(pcurr,nline) then
+              internalerror(200509186);
+            if consumecomma(pcurr) then
+              consumeoffset(pcurr,relocsym,ofs)
+            else
+              begin
+                ofs:=0;
+                relocsym:=nil;
+              end;
+            if (nidx=N_Function) and
+               target_info.use_function_relative_addresses then
+              ofs:=0;
+            objectdata.writestab(ofs,relocsym,nidx,nother,nline,pstr);
+          end;
+        if assigned(pendquote) then
+          pendquote^:='"';
+      end;
+
+
+    function TInternalAssembler.MaybeNextList(var hp:Tai):boolean;
+      begin
+        { maybe end of list }
+        while not assigned(hp) do
+         begin
+           if currlistidx<lists then
+            begin
+              inc(currlistidx);
+              currlist:=list[currlistidx];
+              hp:=Tai(currList.first);
+            end
+           else
+            begin
+              MaybeNextList:=false;
+              exit;
+            end;
+         end;
+        MaybeNextList:=true;
+      end;
+
+
+    function TInternalAssembler.TreePass0(hp:Tai):Tai;
+      var
+        l : longint;
+      begin
+        while assigned(hp) do
+         begin
+           case hp.typ of
+             ait_align :
+               begin
+                 { always use the maximum fillsize in this pass to avoid possible
+                   short jumps to become out of range }
+                 Tai_align(hp).fillsize:=Tai_align(hp).aligntype;
+                 objectdata.alloc(Tai_align(hp).fillsize);
+               end;
+             ait_datablock :
+               begin
+                 l:=used_align(size_2_align(Tai_datablock(hp).size),0,objectdata.currsec.addralign);
+                 if SmartAsm or (not Tai_datablock(hp).is_global) then
+                   begin
+                     objectdata.allocalign(l);
+                     objectdata.alloc(Tai_datablock(hp).size);
+                   end;
+               end;
+             ait_real_80bit :
+               objectdata.alloc(10);
+             ait_real_64bit :
+               objectdata.alloc(8);
+             ait_real_32bit :
+               objectdata.alloc(4);
+             ait_comp_64bit :
+               objectdata.alloc(8);
+             ait_const_64bit,
+             ait_const_32bit,
+             ait_const_16bit,
+             ait_const_8bit,
+             ait_const_rva_symbol,
+             ait_const_indirect_symbol :
+               objectdata.alloc(tai_const(hp).size);
+             ait_section:
+               begin
+                 objectdata.CreateSection(Tai_section(hp).sectype,Tai_section(hp).name^,Tai_section(hp).secalign,[]);
+                 Tai_section(hp).sec:=objectdata.CurrSec;
+               end;
+             ait_symbol :
+               objectdata.allocsymbol(currpass,Tai_symbol(hp).sym,0);
+             ait_label :
+               objectdata.allocsymbol(currpass,Tai_label(hp).l,0);
+             ait_string :
+               objectdata.alloc(Tai_string(hp).len);
+             ait_instruction :
+               begin
+{$ifdef i386}
+{$ifndef NOAG386BIN}
+                 { reset instructions which could change in pass 2 }
+                 Taicpu(hp).resetpass2;
+                 objectdata.alloc(Taicpu(hp).Pass1(objectdata.currsec.datasize));
+{$endif NOAG386BIN}
+{$endif i386}
+{$ifdef arm}
+                 { reset instructions which could change in pass 2 }
+                 Taicpu(hp).resetpass2;
+                 objectdata.alloc(Taicpu(hp).Pass1(objectdata.currsec.datasize));
+{$endif arm}
+               end;
+             ait_cutobject :
+               if SmartAsm then
+                break;
+           end;
+           hp:=Tai(hp.next);
+         end;
+        TreePass0:=hp;
+      end;
+
+
+    function TInternalAssembler.TreePass1(hp:Tai):Tai;
+      var
+        InlineLevel,
+        l,
+        i : longint;
+      begin
+        inlinelevel:=0;
+        while assigned(hp) do
+         begin
+           case hp.typ of
+             ait_align :
+               begin
+                 { here we must determine the fillsize which is used in pass2 }
+                 Tai_align(hp).fillsize:=align(objectdata.currsec.datasize,Tai_align(hp).aligntype)-
+                   objectdata.currsec.datasize;
+                 objectdata.alloc(Tai_align(hp).fillsize);
+               end;
+             ait_datablock :
+               begin
+                 if not (objectdata.currsec.sectype in [sec_bss,sec_threadvar]) then
+                   Message(asmw_e_alloc_data_only_in_bss);
+                 l:=used_align(size_2_align(Tai_datablock(hp).size),0,objectdata.currsec.addralign);
+{                 if Tai_datablock(hp).is_global and
+                    not SmartAsm then
+                  begin}
+{                    objectdata.allocsymbol(currpass,Tai_datablock(hp).sym,Tai_datablock(hp).size);}
+                    { force to be common/external, must be after setaddress as that would
+                      set it to AB_GLOBAL }
+{                    Tai_datablock(hp).sym.currbind:=AB_COMMON;
+                  end
+                 else
+                  begin}
+                    objectdata.allocalign(l);
+                    objectdata.allocsymbol(currpass,Tai_datablock(hp).sym,Tai_datablock(hp).size);
+                    objectdata.alloc(Tai_datablock(hp).size);
+{                  end;}
+                 objectlibrary.UsedAsmSymbolListInsert(Tai_datablock(hp).sym);
+               end;
+             ait_real_80bit :
+               objectdata.alloc(10);
+             ait_real_64bit :
+               objectdata.alloc(8);
+             ait_real_32bit :
+               objectdata.alloc(4);
+             ait_comp_64bit :
+               objectdata.alloc(8);
+             ait_const_64bit,
+             ait_const_32bit,
+             ait_const_16bit,
+             ait_const_8bit,
+             ait_const_rva_symbol,
+             ait_const_indirect_symbol :
+               begin
+                 objectdata.alloc(tai_const(hp).size);
+                 if assigned(Tai_const(hp).sym) then
+                   objectlibrary.UsedAsmSymbolListInsert(Tai_const(hp).sym);
+                 if assigned(Tai_const(hp).endsym) then
+                   objectlibrary.UsedAsmSymbolListInsert(Tai_const(hp).endsym);
+               end;
+             ait_section:
+               begin
+                 { use cached value }
+                 objectdata.setsection(Tai_section(hp).sec);
+               end;
+             ait_stab :
+               begin
+                 if assigned(Tai_stab(hp).str) then
+                   convertstab(Tai_stab(hp).str);
+               end;
+             ait_function_name,
+             ait_force_line : ;
+             ait_symbol :
+               begin
+                 objectdata.allocsymbol(currpass,Tai_symbol(hp).sym,0);
+                 objectlibrary.UsedAsmSymbolListInsert(Tai_symbol(hp).sym);
+               end;
+             ait_symbol_end :
+               begin
+                 if target_info.system in [system_i386_linux,system_i386_beos] then
+                  begin
+                    Tai_symbol_end(hp).sym.size:=objectdata.currsec.datasize-Tai_symbol_end(hp).sym.address;
+                    objectlibrary.UsedAsmSymbolListInsert(Tai_symbol_end(hp).sym);
+                  end;
+                end;
+             ait_label :
+               begin
+                 objectdata.allocsymbol(currpass,Tai_label(hp).l,0);
+                 objectlibrary.UsedAsmSymbolListInsert(Tai_label(hp).l);
+               end;
+             ait_string :
+               objectdata.alloc(Tai_string(hp).len);
+             ait_instruction :
+               begin
+                 objectdata.alloc(Taicpu(hp).Pass1(objectdata.currsec.datasize));
+                 { fixup the references }
+                 for i:=1 to Taicpu(hp).ops do
+                  begin
+                    with Taicpu(hp).oper[i-1]^ do
+                     begin
+                       case typ of
+                         top_ref :
+                           begin
+                             if assigned(ref^.symbol) then
+                              objectlibrary.UsedAsmSymbolListInsert(ref^.symbol);
+                             if assigned(ref^.relsymbol) then
+                              objectlibrary.UsedAsmSymbolListInsert(ref^.symbol);
+                           end;
+                       end;
+                     end;
+                  end;
+               end;
+             ait_cutobject :
+               if SmartAsm then
+                break;
+             ait_marker :
+               if tai_marker(hp).kind=InlineStart then
+                 inc(InlineLevel)
+               else if tai_marker(hp).kind=InlineEnd then
+                 dec(InlineLevel);
+           end;
+           hp:=Tai(hp.next);
+         end;
+        TreePass1:=hp;
+      end;
+
+
+    function TInternalAssembler.TreePass2(hp:Tai):Tai;
+      var
+        fillbuffer : tfillbuffer;
+        InlineLevel,
+        l  : longint;
+        v  : int64;
+{$ifdef x86}
+        co : comp;
+{$endif x86}
+      begin
+        inlinelevel:=0;
+        { main loop }
+        while assigned(hp) do
+         begin
+           case hp.typ of
+             ait_align :
+               begin
+                 if objectdata.currsec.sectype in [sec_bss,sec_threadvar] then
+                   objectdata.alloc(Tai_align(hp).fillsize)
+                 else
+                   objectdata.writebytes(Tai_align(hp).calculatefillbuf(fillbuffer)^,Tai_align(hp).fillsize);
+               end;
+             ait_section :
+               begin
+                 { use cached value }
+                 objectdata.setsection(Tai_section(hp).sec);
+               end;
+             ait_symbol :
+               begin
+                 objectdata.writesymbol(Tai_symbol(hp).sym);
+                 objectoutput.exportsymbol(Tai_symbol(hp).sym);
+               end;
+             ait_datablock :
+               begin
+                 l:=used_align(size_2_align(Tai_datablock(hp).size),0,objectdata.currsec.addralign);
+                 objectdata.writesymbol(Tai_datablock(hp).sym);
+                 objectoutput.exportsymbol(Tai_datablock(hp).sym);
+{                 if SmartAsm or (not Tai_datablock(hp).is_global) then
+                   begin}
+                     objectdata.allocalign(l);
+                     objectdata.alloc(Tai_datablock(hp).size);
+{                   end;}
+               end;
+             ait_real_80bit :
+               objectdata.writebytes(Tai_real_80bit(hp).value,10);
+             ait_real_64bit :
+               objectdata.writebytes(Tai_real_64bit(hp).value,8);
+             ait_real_32bit :
+               objectdata.writebytes(Tai_real_32bit(hp).value,4);
+             ait_comp_64bit :
+               begin
+{$ifdef x86}
+                 co:=comp(Tai_comp_64bit(hp).value);
+                 objectdata.writebytes(co,8);
+{$endif x86}
+               end;
+             ait_string :
+               objectdata.writebytes(Tai_string(hp).str^,Tai_string(hp).len);
+             ait_const_64bit,
+             ait_const_32bit,
+             ait_const_16bit,
+             ait_const_8bit :
+               begin
+                 if assigned(tai_const(hp).sym) then
+                   begin
+                     if assigned(tai_const(hp).endsym) then
+                       begin
+                         if tai_const(hp).endsym.section<>tai_const(hp).sym.section then
+                           internalerror(200404124);
+                         v:=tai_const(hp).endsym.address-tai_const(hp).sym.address+Tai_const(hp).value;
+                         objectdata.writebytes(v,tai_const(hp).size);
+                       end
+                     else
+                       objectdata.writereloc(Tai_const(hp).value,Tai_const(hp).size,
+                                             Tai_const(hp).sym,RELOC_ABSOLUTE);
+                   end
+                 else
+                   objectdata.writebytes(Tai_const(hp).value,tai_const(hp).size);
+               end;
+             ait_const_rva_symbol :
+               objectdata.writereloc(Tai_const(hp).value,sizeof(aint),Tai_const(hp).sym,RELOC_RVA);
+             ait_label :
+               begin
+                 objectdata.writesymbol(Tai_label(hp).l);
+                 { exporting shouldn't be necessary as labels are local,
+                   but it's better to be on the safe side (PFV) }
+                 objectoutput.exportsymbol(Tai_label(hp).l);
+               end;
+             ait_instruction :
+               Taicpu(hp).Pass2(objectdata);
+             ait_stab :
+               convertstab(Tai_stab(hp).str);
+             ait_function_name,
+             ait_force_line : ;
+             ait_cutobject :
+               if SmartAsm then
+                break;
+             ait_marker :
+               if tai_marker(hp).kind=InlineStart then
+                 inc(InlineLevel)
+               else if tai_marker(hp).kind=InlineEnd then
+                 dec(InlineLevel);
+           end;
+           hp:=Tai(hp.next);
+         end;
+        TreePass2:=hp;
+      end;
+
+
+    procedure TInternalAssembler.writetree;
+      var
+        hp : Tai;
+      label
+        doexit;
+      begin
+        objectdata:=objectoutput.newobjectdata(Objfile);
+        { reset the asmsymbol list }
+        objectlibrary.CreateUsedAsmsymbolList;
+
+      { Pass 0 }
+        currpass:=0;
+        objectdata.createsection(sec_code,'',0,[]);
+        objectdata.beforealloc;
+        { start with list 1 }
+        currlistidx:=1;
+        currlist:=list[currlistidx];
+        hp:=Tai(currList.first);
+        while assigned(hp) do
+         begin
+           hp:=TreePass0(hp);
+           MaybeNextList(hp);
+         end;
+        objectdata.afteralloc;
+        { leave if errors have occured }
+        if errorcount>0 then
+         goto doexit;
+
+      { Pass 1 }
+        currpass:=1;
+        objectdata.resetsections;
+        objectdata.beforealloc;
+        objectdata.createsection(sec_code,'',0,[]);
+        { start with list 1 }
+        currlistidx:=1;
+        currlist:=list[currlistidx];
+        hp:=Tai(currList.first);
+        while assigned(hp) do
+         begin
+           hp:=TreePass1(hp);
+           MaybeNextList(hp);
+         end;
+        objectdata.createsection(sec_code,'',0,[]);
+        objectdata.afteralloc;
+        { check for undefined labels and reset }
+        objectlibrary.UsedAsmSymbolListCheckUndefined;
+
+        { leave if errors have occured }
+        if errorcount>0 then
+         goto doexit;
+
+      { Pass 2 }
+        currpass:=2;
+        objectdata.resetsections;
+        objectdata.beforewrite;
+        objectdata.createsection(sec_code,'',0,[]);
+        { start with list 1 }
+        currlistidx:=1;
+        currlist:=list[currlistidx];
+        hp:=Tai(currList.first);
+        while assigned(hp) do
+         begin
+           hp:=TreePass2(hp);
+           MaybeNextList(hp);
+         end;
+        objectdata.createsection(sec_code,'',0,[]);
+        objectdata.afterwrite;
+
+        { don't write the .o file if errors have occured }
+        if errorcount=0 then
+         begin
+           { write objectfile }
+           objectoutput.startobjectfile(ObjFile);
+           objectoutput.writeobjectfile(objectdata);
+           objectdata.free;
+           objectdata:=nil;
+         end;
+
+      doexit:
+        { reset the used symbols back, must be after the .o has been
+          written }
+        objectlibrary.UsedAsmsymbolListReset;
+        objectlibrary.DestroyUsedAsmsymbolList;
+      end;
+
+
+    procedure TInternalAssembler.writetreesmart;
+      var
+        hp : Tai;
+        startsectype : TAsmSectionType;
+        place: tcutplace;
+      begin
+        NextSmartName(cut_normal);
+        objectdata:=objectoutput.newobjectdata(Objfile);
+        startsectype:=sec_code;
+
+        { start with list 1 }
+        currlistidx:=1;
+        currlist:=list[currlistidx];
+        hp:=Tai(currList.first);
+        while assigned(hp) do
+         begin
+         { reset the asmsymbol list }
+           objectlibrary.CreateUsedAsmSymbolList;
+
+         { Pass 0 }
+           currpass:=0;
+           objectdata.resetsections;
+           objectdata.beforealloc;
+           objectdata.createsection(startsectype,'',0,[]);
+           TreePass0(hp);
+           objectdata.afteralloc;
+           { leave if errors have occured }
+           if errorcount>0 then
+            exit;
+
+         { Pass 1 }
+           currpass:=1;
+           objectdata.resetsections;
+           objectdata.beforealloc;
+           objectdata.createsection(startsectype,'',0,[]);
+           TreePass1(hp);
+           objectdata.afteralloc;
+           { check for undefined labels }
+           objectlibrary.UsedAsmSymbolListCheckUndefined;
+
+           { leave if errors have occured }
+           if errorcount>0 then
+            exit;
+
+         { Pass 2 }
+           currpass:=2;
+           objectoutput.startobjectfile(Objfile);
+           objectdata.resetsections;
+           objectdata.beforewrite;
+           objectdata.createsection(startsectype,'',0,[]);
+           hp:=TreePass2(hp);
+           { save section type for next loop, must be done before EndFileLineInfo
+             because that changes the section to sec_code }
+           startsectype:=objectdata.currsec.sectype;
+           objectdata.afterwrite;
+           { leave if errors have occured }
+           if errorcount>0 then
+            exit;
+
+           { write the current objectfile }
+           objectoutput.writeobjectfile(objectdata);
+           objectdata.free;
+           objectdata:=nil;
+
+           { reset the used symbols back, must be after the .o has been
+             written }
+           objectlibrary.UsedAsmsymbolListReset;
+           objectlibrary.DestroyUsedAsmsymbolList;
+
+           { end of lists? }
+           if not MaybeNextList(hp) then
+            break;
+
+           { we will start a new objectfile so reset everything }
+           { The place can still change in the next while loop, so don't init }
+           { the writer yet (JM)                                              }
+           if (hp.typ=ait_cutobject) then
+            place := Tai_cutobject(hp).place
+           else
+            place := cut_normal;
+
+           { avoid empty files }
+           while assigned(hp) and
+                 (Tai(hp).typ in [ait_marker,ait_comment,ait_section,ait_cutobject]) do
+            begin
+              if Tai(hp).typ=ait_section then
+               startsectype:=Tai_section(hp).sectype
+              else if (Tai(hp).typ=ait_cutobject) then
+               place:=Tai_cutobject(hp).place;
+              hp:=Tai(hp.next);
+            end;
+           { there is a problem if startsectype is sec_none !! PM }
+           if startsectype=sec_none then
+             startsectype:=sec_code;
+
+           if not MaybeNextList(hp) then
+             break;
+
+           { start next objectfile }
+           NextSmartName(place);
+           objectdata:=objectoutput.newobjectdata(Objfile);
+         end;
+      end;
+
+
+    procedure TInternalAssembler.MakeObject;
+
+    var to_do:set of Tasmlist;
+        i:Tasmlist;
+
+        procedure addlist(p:TAAsmoutput);
+        begin
+          inc(lists);
+          list[lists]:=p;
+        end;
+
+      begin
+        to_do:=[low(Tasmlist)..high(Tasmlist)];
+        if usedeffileforexports then
+          exclude(to_do,al_exports);
+        {$warning TODO internal writer support for dwarf}
+        exclude(to_do,al_dwarf);
+{$ifndef segment_threadvars}
+        exclude(to_do,al_threadvars);
+{$endif}
+        for i:=low(Tasmlist) to high(Tasmlist) do
+          if (i in to_do) and (asmlist[i]<>nil) then
+            addlist(asmlist[i]);
+
+        if SmartAsm then
+          writetreesmart
+        else
+          writetree;
+      end;
+
+
+{*****************************************************************************
+                     Generate Assembler Files Main Procedure
+*****************************************************************************}
+
+    Procedure GenerateAsm(smart:boolean);
+      var
+        a : TAssembler;
+      begin
+        if not assigned(CAssembler[target_asm.id]) then
+          Message(asmw_f_assembler_output_not_supported);
+        a:=CAssembler[target_asm.id].Create(smart);
+        a.MakeObject;
+        a.Free;
+      end;
+
+
+    Procedure OnlyAsm;
+      var
+        a : TExternalAssembler;
+      begin
+        a:=TExternalAssembler.Create(false);
+        a.DoAssemble;
+        a.Free;
+      end;
+
+
+{*****************************************************************************
+                                 Init/Done
+*****************************************************************************}
+
+    procedure RegisterAssembler(const r:tasminfo;c:TAssemblerClass);
+      var
+        t : tasm;
+      begin
+        t:=r.id;
+        if assigned(asminfos[t]) then
+          writeln('Warning: Assembler is already registered!')
+        else
+          Getmem(asminfos[t],sizeof(tasminfo));
+        asminfos[t]^:=r;
+        CAssembler[t]:=c;
+      end;
+
+
+    procedure InitAssembler;
+      begin
+      end;
+
+
+    procedure DoneAssembler;
+      begin
+      end;
+
+end.

+ 2143 - 0
compiler/browcol.pas

@@ -0,0 +1,2143 @@
+{
+    Copyright (c) 1998-2002 by Berczi Gabor
+    Modifications Copyright (c) 1999-2002 Florian Klaempfl and Pierre Muller
+
+    Support routines for getting browser info in collections
+
+    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.
+
+ ****************************************************************************
+}
+{$ifdef TP}
+  {$N+,E+}
+{$endif}
+unit browcol;
+interface
+uses
+  objects,
+  cclasses,
+  symconst,symtable;
+
+{$ifndef FPC}
+  type
+    sw_integer = integer;
+{$endif FPC}
+
+const
+  SymbolTypLen : integer = 6;
+
+  RecordTypes : set of tsymtyp =
+    ([typesym,unitsym]);
+
+    sfRecord        = $00000001;
+    sfObject        = $00000002;
+    sfClass         = $00000004;
+    sfPointer       = $00000008;
+    sfHasMemInfo    = $80000000;
+
+type
+    TStoreCollection = object(TStringCollection)
+      function Add(const S: string): PString;
+    end;
+
+    PModuleNameCollection = ^TModuleNameCollection;
+    TModuleNameCollection = object(TStoreCollection)
+    end;
+
+    PTypeNameCollection = ^TTypeNameCollection;
+    TTypeNameCollection = object(TStoreCollection)
+    end;
+
+    PSymbolCollection       = ^TSymbolCollection;
+    PSortedSymbolCollection = ^TSortedSymbolCollection;
+    PReferenceCollection    = ^TReferenceCollection;
+
+    PReference = ^TReference;
+    TReference = object(TObject)
+      FileName  : PString;
+      Position  : TPoint;
+      constructor Init(AFileName: PString; ALine, AColumn: Sw_integer);
+      function    GetFileName: string;
+      destructor  Done; virtual;
+      constructor Load(var S: TStream);
+      procedure   Store(var S: TStream);
+    end;
+
+    PSymbolMemInfo = ^TSymbolMemInfo;
+    TSymbolMemInfo = record
+      Addr      : longint;
+      Size      : longint;
+      PushSize  : longint;
+    end;
+
+    PSymbol = ^TSymbol;
+    TSymbol = object(TObject)
+      Name       : PString;
+      Typ        : tsymtyp;
+      Params     : PString;
+      References : PReferenceCollection;
+      Items      : PSymbolCollection;
+      DType      : PString;
+      VType      : PString;
+      TypeID     : Ptrint;
+      RelatedTypeID : Ptrint;
+      DebuggerCount : longint;
+      Ancestor   : PSymbol;
+      Flags      : longint;
+      MemInfo    : PSymbolMemInfo;
+      constructor Init(const AName: string; ATyp: tsymtyp; AParams: string; AMemInfo: PSymbolMemInfo);
+      procedure   SetMemInfo(const AMemInfo: TSymbolMemInfo);
+      function    GetReferenceCount: Sw_integer;
+      function    GetReference(Index: Sw_integer): PReference;
+      function    GetItemCount: Sw_integer;
+      function    GetItem(Index: Sw_integer): PSymbol;
+      function    GetName: string;
+      function    GetText: string;
+      function    GetTypeName: string;
+      destructor  Done; virtual;
+      constructor Load(var S: TStream);
+      procedure   Store(var S: TStream);
+    end;
+
+    PExport = ^TExport;
+    TExport = object(TObject)
+      constructor Init(const AName: string; AIndex: longint; ASymbol: PSymbol);
+      function    GetDisplayText: string;
+      destructor  Done; virtual;
+    private
+      Name: PString;
+      Index: longint;
+      Symbol: PSymbol;
+    end;
+
+    PExportCollection = ^TExportCollection;
+    TExportCollection = object(TSortedCollection)
+      function At(Index: sw_Integer): PExport;
+      function Compare(Key1, Key2: Pointer): sw_Integer; virtual;
+    end;
+
+    PImport = ^TImport;
+    TImport = object(TObject)
+      constructor Init(const ALibName, AFuncName,ARealName: string; AIndex: longint);
+      function    GetDisplayText: string;
+      destructor  Done; virtual;
+    private
+      LibName: PString;
+      FuncName: PString;
+      RealName: PString;
+      Index: longint;
+    end;
+
+    PImportCollection = ^TImportCollection;
+    TImportCollection = object(TSortedCollection)
+      function At(Index: sw_Integer): PImport;
+      function Compare(Key1, Key2: Pointer): sw_Integer; virtual;
+    end;
+
+    PObjectSymbolCollection = ^TObjectSymbolCollection;
+
+    PObjectSymbol = ^TObjectSymbol;
+    TObjectSymbol = object(TObject)
+      Parent     : PObjectSymbol;
+      Symbol     : PSymbol;
+      Expanded   : boolean;
+      constructor Init(AParent: PObjectSymbol; ASymbol: PSymbol);
+      constructor InitName(const AName: string);
+      function    GetName: string;
+      function    GetDescendantCount: sw_integer;
+      function    GetDescendant(Index: sw_integer): PObjectSymbol;
+      procedure   AddDescendant(P: PObjectSymbol);
+      destructor  Done; virtual;
+      constructor Load(var S: TStream);
+      procedure   Store(S: TStream);
+    private
+      Name: PString;
+      Descendants: PObjectSymbolCollection;
+    end;
+
+    TSymbolCollection = object(TSortedCollection)
+       constructor Init(ALimit, ADelta: Integer);
+       function  At(Index: Sw_Integer): PSymbol;
+       procedure Insert(Item: Pointer); virtual;
+       function  LookUp(const S: string; var Idx: sw_integer): string; virtual;
+    end;
+
+    TSortedSymbolCollection = object(TSymbolCollection)
+      function  Compare(Key1, Key2: Pointer): Sw_Integer; virtual;
+      procedure Insert(Item: Pointer); virtual;
+      function  LookUp(const S: string; var Idx: sw_integer): string; virtual;
+    end;
+
+    PIDSortedSymbolCollection = ^TIDSortedSymbolCollection;
+    TIDSortedSymbolCollection = object(TSymbolCollection)
+      function  Compare(Key1, Key2: Pointer): Sw_Integer; virtual;
+      procedure Insert(Item: Pointer); virtual;
+      function  SearchSymbolByID(AID: longint): PSymbol;
+    end;
+
+    TObjectSymbolCollection = object(TSortedCollection)
+      constructor Init(ALimit, ADelta: Integer);
+      function  Compare(Key1, Key2: Pointer): Sw_Integer; virtual;
+      function  LookUp(const S: string; var Idx: sw_integer): string; virtual;
+       function At(Index: Sw_Integer): PObjectSymbol;
+    end;
+
+    TReferenceCollection = object(TCollection)
+       function At(Index: Sw_Integer): PReference;
+    end;
+
+    PSourceFile = ^TSourceFile;
+    TSourceFile = object(TObject)
+      SourceFileName: PString;
+      ObjFileName: PString;
+      PPUFileName: PString;
+      constructor Init(ASourceFileName, AObjFileName, APPUFileName: string);
+      destructor  Done; virtual;
+      function    GetSourceFilename: string;
+      function    GetObjFileName: string;
+      function    GetPPUFileName: string;
+    end;
+
+    PSourceFileCollection = ^TSourceFileCollection;
+    TSourceFileCollection = object(TCollection)
+      function At(Index: sw_Integer): PSourceFile;
+    end;
+
+    PModuleSymbol = ^TModuleSymbol;
+    TModuleSymbol = object(TSymbol)
+      Exports_   : PExportCollection;
+      Imports    : PImportCollection;
+      LoadedFrom : PString;
+      UsedUnits  : PSymbolCollection;
+      DependentUnits: PSymbolCollection;
+      MainSource: PString;
+      SourceFiles: PStringCollection;
+      constructor Init(const AName, AMainSource: string);
+      procedure   SetLoadedFrom(const AModuleName: string);
+      procedure   AddUsedUnit(P: PSymbol);
+      procedure   AddDependentUnit(P: PSymbol);
+      procedure   AddSourceFile(const Path: string);
+      destructor  Done; virtual;
+    end;
+
+const
+  Modules     : PSymbolCollection = nil;
+  ModuleNames : PModuleNameCollection = nil;
+  TypeNames   : PTypeNameCollection = nil;
+  ObjectTree  : PObjectSymbol = nil;
+  SourceFiles : PSourceFileCollection = nil;
+
+procedure DisposeBrowserCol;
+procedure NewBrowserCol;
+procedure CreateBrowserCol;
+procedure InitBrowserCol;
+procedure DoneBrowserCol;
+
+function  LoadBrowserCol(S: PStream): boolean;
+function  StoreBrowserCol(S: PStream) : boolean;
+
+procedure BuildObjectInfo;
+
+procedure BuildSourceList;
+
+function SearchObjectForSymbol(O: PSymbol): PObjectSymbol;
+
+procedure RegisterSymbols;
+
+implementation
+
+uses
+{$IFDEF USE_SYSUTILS}
+  SysUtils,
+{$ELSE USE_SYSUTILS}
+  Dos,{$ifndef FPC}strings,{$endif}
+{$ENDIF USE_SYSUTILS}
+{$ifdef DEBUG}
+  verbose,
+{$endif DEBUG}
+  CUtils,
+  globtype,globals,comphook,
+  finput,fmodule,
+  cpuinfo,cgbase,aasmbase,aasmtai,paramgr,
+  symsym,symdef,symtype,symbase,defutil;
+
+const
+  RModuleNameCollection: TStreamRec = (
+     ObjType: 3001;
+     VmtLink: Ofs(TypeOf(TModuleNameCollection)^);
+     Load:    @TModuleNameCollection.Load;
+     Store:   @TModuleNameCollection.Store
+  );
+  RTypeNameCollection: TStreamRec = (
+     ObjType: 3002;
+     VmtLink: Ofs(TypeOf(TTypeNameCollection)^);
+     Load:    @TTypeNameCollection.Load;
+     Store:   @TTypeNameCollection.Store
+  );
+  RReference: TStreamRec = (
+     ObjType: 3003;
+     VmtLink: Ofs(TypeOf(TReference)^);
+     Load:    @TReference.Load;
+     Store:   @TReference.Store
+  );
+  RSymbol: TStreamRec = (
+     ObjType: 3004;
+     VmtLink: Ofs(TypeOf(TSymbol)^);
+     Load:    @TSymbol.Load;
+     Store:   @TSymbol.Store
+  );
+  RObjectSymbol: TStreamRec = (
+     ObjType: 3005;
+     VmtLink: Ofs(TypeOf(TObjectSymbol)^);
+     Load:    @TObjectSymbol.Load;
+     Store:   @TObjectSymbol.Store
+  );
+  RSymbolCollection: TStreamRec = (
+     ObjType: 3006;
+     VmtLink: Ofs(TypeOf(TSymbolCollection)^);
+     Load:    @TSymbolCollection.Load;
+     Store:   @TSymbolCollection.Store
+  );
+  RSortedSymbolCollection: TStreamRec = (
+     ObjType: 3007;
+     VmtLink: Ofs(TypeOf(TSortedSymbolCollection)^);
+     Load:    @TSortedSymbolCollection.Load;
+     Store:   @TSortedSymbolCollection.Store
+  );
+  RIDSortedSymbolCollection: TStreamRec = (
+     ObjType: 3008;
+     VmtLink: Ofs(TypeOf(TIDSortedSymbolCollection)^);
+     Load:    @TIDSortedSymbolCollection.Load;
+     Store:   @TIDSortedSymbolCollection.Store
+  );
+  RObjectSymbolCollection: TStreamRec = (
+     ObjType: 3009;
+     VmtLink: Ofs(TypeOf(TObjectSymbolCollection)^);
+     Load:    @TObjectSymbolCollection.Load;
+     Store:   @TObjectSymbolCollection.Store
+  );
+  RReferenceCollection: TStreamRec = (
+     ObjType: 3010;
+     VmtLink: Ofs(TypeOf(TReferenceCollection)^);
+     Load:    @TReferenceCollection.Load;
+     Store:   @TReferenceCollection.Store
+  );
+  RModuleSymbol: TStreamRec = (
+     ObjType: 3011;
+     VmtLink: Ofs(TypeOf(TModuleSymbol)^);
+     Load:    @TModuleSymbol.Load;
+     Store:   @TModuleSymbol.Store
+  );
+
+{****************************************************************************
+                                   Helpers
+****************************************************************************}
+
+function GetStr(P: PString): string;
+begin
+  if P=nil then
+    GetStr:=''
+  else
+    GetStr:=P^;
+end;
+
+function IntToStr(L: longint): string;
+var S: string;
+begin
+  Str(L,S);
+  IntToStr:=S;
+end;
+
+function UpcaseStr(S: string): string;
+var I: integer;
+begin
+  for I:=1 to length(S) do
+      S[I]:=Upcase(S[I]);
+  UpcaseStr:=S;
+end;
+
+function FloatToStr(E: extended): string;
+var S: string;
+begin
+  Str(E:0:24,S);
+  if Pos('.',S)>0 then
+    begin
+      while (length(S)>0) and (S[length(S)]='0') do
+        Delete(S,length(S),1);
+      if (length(S)>0) and (S[length(S)]='.') then
+        Delete(S,length(S),1);
+    end;
+  if S='' then S:='0';
+  FloatToStr:=S;
+end;
+
+{****************************************************************************
+                                TStoreCollection
+****************************************************************************}
+
+function TStoreCollection.Add(const S: string): PString;
+var P: PString;
+    Index: Sw_integer;
+begin
+  if S='' then P:=nil else
+  if Search(@S,Index) then P:=At(Index) else
+    begin
+      P:=NewStr(S);
+      Insert(P);
+    end;
+  Add:=P;
+end;
+
+
+{****************************************************************************
+                                TSymbolCollection
+****************************************************************************}
+
+constructor TSymbolCollection.Init(ALimit, ADelta: Integer);
+begin
+  inherited Init(ALimit,ADelta);
+{  Duplicates:=true;}
+end;
+
+function TSymbolCollection.At(Index: Sw_Integer): PSymbol;
+begin
+  At:=inherited At(Index);
+end;
+
+procedure TSymbolCollection.Insert(Item: Pointer);
+begin
+
+  TCollection.Insert(Item);
+end;
+
+function TSymbolCollection.LookUp(const S: string; var Idx: sw_integer): string;
+begin
+  Idx:=-1;
+  LookUp:='';
+end;
+
+{****************************************************************************
+                               TReferenceCollection
+****************************************************************************}
+
+function TReferenceCollection.At(Index: Sw_Integer): PReference;
+begin
+  At:=inherited At(Index);
+end;
+
+
+{****************************************************************************
+                            TSortedSymbolCollection
+****************************************************************************}
+
+function TSortedSymbolCollection.Compare(Key1, Key2: Pointer): Sw_Integer;
+var K1: PSymbol absolute Key1;
+    K2: PSymbol absolute Key2;
+    R: Sw_integer;
+    S1,S2: string;
+begin
+  S1:=Upper(K1^.GetName);
+  S2:=Upper(K2^.GetName);
+  if S1<S2 then R:=-1 else
+  if S1>S2 then R:=1 else
+   if K1^.TypeID=K2^.TypeID then R:=0 else
+    begin
+      S1:=K1^.GetName;
+      S2:=K2^.GetName;
+      if S1<S2 then R:=-1 else
+      if S1>S2 then R:=1 else
+       if K1^.TypeID<K2^.TypeID then R:=-1 else
+       if K1^.TypeID>K2^.TypeID then R:= 1 else
+        R:=0;
+    end;
+  Compare:=R;
+end;
+
+procedure TSortedSymbolCollection.Insert(Item: Pointer);
+begin
+  TSortedCollection.Insert(Item);
+end;
+
+function TSortedSymbolCollection.LookUp(const S: string; var Idx: sw_integer): string;
+var OLI,ORI,Left,Right,Mid: integer;
+    LeftP,RightP,MidP: PSymbol;
+    LeftS,MidS,RightS: string;
+    FoundS: string;
+    UpS : string;
+begin
+  Idx:=-1; FoundS:='';
+  Left:=0; Right:=Count-1;
+  UpS:=Upper(S);
+  if Left<Right then
+  begin
+    while (Left<Right) do
+    begin
+      OLI:=Left; ORI:=Right;
+      Mid:=Left+(Right-Left) div 2;
+      MidP:=At(Mid);
+{$ifdef DEBUG}
+      LeftP:=At(Left); RightP:=At(Right);
+      LeftS:=Upper(LeftP^.GetName);
+      RightS:=Upper(RightP^.GetName);
+{$endif DEBUG}
+      MidS:=Upper(MidP^.GetName);
+      if copy(MidS,1,length(UpS))=UpS then
+        begin
+          Idx:=Mid;
+          FoundS:=MidS;
+        end;
+{      else}
+        if UpS<MidS then
+          Right:=Mid
+        else
+          Left:=Mid;
+      if (OLI=Left) and (ORI=Right) then
+        begin
+          if idX<>-1 then
+            break;
+          if Mid=Left then
+            begin
+              RightP:=At(Right);
+              RightS:=Upper(RightP^.GetName);
+              if copy(RightS,1,length(UpS))=UpS then
+                begin
+                  Idx:=Right;
+                  FoundS:=RightS;
+                end;
+            end;
+          if Mid=Right then
+            begin
+              LeftP:=At(Left);
+              LeftS:=Upper(LeftP^.GetName);
+              if copy(LeftS,1,length(UpS))=UpS then
+                begin
+                  Idx:=Left;
+                  FoundS:=LeftS;
+                end;
+            end;
+          Break;
+        end;
+    end;
+  end;
+  LookUp:=FoundS;
+end;
+
+{****************************************************************************
+                           TIDSortedSymbolCollection
+****************************************************************************}
+
+function TIDSortedSymbolCollection.Compare(Key1, Key2: Pointer): Sw_Integer;
+var K1: PSymbol absolute Key1;
+    K2: PSymbol absolute Key2;
+    R: Sw_integer;
+begin
+  if K1^.TypeID<K2^.TypeID then R:=-1 else
+  if K1^.TypeID>K2^.TypeID then R:= 1 else
+  R:=0;
+  Compare:=R;
+end;
+
+procedure TIDSortedSymbolCollection.Insert(Item: Pointer);
+begin
+  TSortedCollection.Insert(Item);
+end;
+
+function TIDSortedSymbolCollection.SearchSymbolByID(AID: longint): PSymbol;
+var S: TSymbol;
+    Index: sw_integer;
+    P: PSymbol;
+begin
+  S.TypeID:=AID;
+  if Search(@S,Index)=false then P:=nil else
+    P:=At(Index);
+  SearchSymbolByID:=P;
+end;
+
+{****************************************************************************
+                           TObjectSymbolCollection
+****************************************************************************}
+
+function TObjectSymbolCollection.At(Index: Sw_Integer): PObjectSymbol;
+begin
+  At:=inherited At(Index);
+end;
+
+constructor TObjectSymbolCollection.Init(ALimit, ADelta: Integer);
+begin
+  inherited Init(ALimit,ADelta);
+end;
+
+function TObjectSymbolCollection.Compare(Key1, Key2: Pointer): Sw_Integer;
+var K1: PObjectSymbol absolute Key1;
+    K2: PObjectSymbol absolute Key2;
+    R: Sw_integer;
+    S1,S2: string;
+begin
+  S1:=Upper(K1^.GetName);
+  S2:=Upper(K2^.GetName);
+  if S1<S2 then R:=-1 else
+  if S1>S2 then R:=1 else
+  { make sure that we distinguish between different objects with the same name }
+  if Ptrint(K1^.Symbol)<Ptrint(K2^.Symbol) then R:=-1 else
+  if Ptrint(K1^.Symbol)>Ptrint(K2^.Symbol) then R:= 1 else
+  R:=0;
+  Compare:=R;
+end;
+
+function TObjectSymbolCollection.LookUp(const S: string; var Idx: sw_integer): string;
+var OLI,ORI,Left,Right,Mid: integer;
+    {LeftP,RightP,}MidP: PObjectSymbol;
+    {LeftS,RightS,}MidS: string;
+    FoundS: string;
+    UpS : string;
+begin
+  Idx:=-1; FoundS:='';
+  Left:=0; Right:=Count-1;
+  UpS:=Upper(S);
+  if Left<Right then
+  begin
+    while (Left<Right) do
+    begin
+      OLI:=Left; ORI:=Right;
+      Mid:=Left+(Right-Left) div 2;
+      {LeftP:=At(Left);
+       LeftS:=Upper(LeftP^.GetName);}
+      MidP:=At(Mid);
+      MidS:=Upper(MidP^.GetName);
+      {RightP:=At(Right);
+       RightS:=Upper(RightP^.GetName);}
+      if copy(MidS,1,length(UpS))=UpS then
+        begin
+          Idx:=Mid;
+          FoundS:=MidS;
+        end;
+{      else}
+        if UpS<MidS then
+          Right:=Mid
+        else
+          Left:=Mid;
+      if (OLI=Left) and (ORI=Right) then
+        Break;
+    end;
+  end;
+  LookUp:=FoundS;
+end;
+
+{****************************************************************************
+                                TReference
+****************************************************************************}
+
+constructor TReference.Init(AFileName: PString; ALine, AColumn: Sw_integer);
+begin
+  inherited Init;
+  FileName:=AFileName;
+  Position.X:=AColumn;
+  Position.Y:=ALine;
+end;
+
+function TReference.GetFileName: string;
+begin
+  GetFileName:=GetStr(FileName);
+end;
+
+destructor TReference.Done;
+begin
+  inherited Done;
+end;
+
+constructor TReference.Load(var S: TStream);
+begin
+  S.Read(Position, SizeOf(Position));
+
+  { --- items needing fixup --- }
+  S.Read(FileName, SizeOf(FileName)); { ->ModulesNames^.Item }
+end;
+
+procedure TReference.Store(var S: TStream);
+begin
+  S.Write(Position, SizeOf(Position));
+
+  { --- items needing fixup --- }
+  S.Write(FileName, SizeOf(FileName));
+end;
+
+{****************************************************************************
+                                   TSymbol
+****************************************************************************}
+
+constructor TSymbol.Init(const AName: string; ATyp: tsymtyp; AParams: string; AMemInfo: PSymbolMemInfo);
+begin
+  inherited Init;
+  Name:=NewStr(AName); Typ:=ATyp;
+  if AMemInfo<>nil then
+    SetMemInfo(AMemInfo^);
+  New(References, Init(20,50));
+  if ATyp in RecordTypes then
+    begin
+      Items:=New(PSortedSymbolCollection, Init(50,100));
+    end;
+end;
+
+procedure TSymbol.SetMemInfo(const AMemInfo: TSymbolMemInfo);
+begin
+  if MemInfo=nil then New(MemInfo);
+  Move(AMemInfo,MemInfo^,SizeOf(MemInfo^));
+  Flags:=Flags or sfHasMemInfo;
+end;
+
+function TSymbol.GetReferenceCount: Sw_integer;
+var Count: Sw_integer;
+begin
+  if References=nil then Count:=0 else
+    Count:=References^.Count;
+  GetReferenceCount:=Count;
+end;
+
+function TSymbol.GetReference(Index: Sw_integer): PReference;
+begin
+  GetReference:=References^.At(Index);
+end;
+
+function TSymbol.GetItemCount: Sw_integer;
+var Count: Sw_integer;
+begin
+  if Items=nil then Count:=0 else
+    Count:=Items^.Count;
+  GetItemCount:=Count;
+end;
+
+function TSymbol.GetItem(Index: Sw_integer): PSymbol;
+begin
+  GetItem:=Items^.At(Index);
+end;
+
+function TSymbol.GetName: string;
+begin
+  GetName:=GetStr(Name);
+end;
+
+function TSymbol.GetText: string;
+var S: string;
+begin
+  S:=GetTypeName;
+  if length(S)>SymbolTypLen then
+   S:=Copy(S,1,SymbolTypLen)
+  else
+   begin
+     while length(S)<SymbolTypLen do
+      S:=S+' ';
+   end;
+  S:=S+' '+GetName;
+  if (Flags and sfRecord)<>0 then
+    S:=S+' = record'
+  else
+  if (Flags and sfObject)<>0 then
+    begin
+      S:=S+' = ';
+      if (Flags and sfClass)<>0 then
+        S:=S+'class'
+      else
+        S:=S+'object';
+      if Ancestor<>nil then
+        S:=S+'('+Ancestor^.GetName+')';
+    end
+  else
+    begin
+      if Assigned(DType) then
+        S:=S+' = '+DType^;
+      if Assigned(Params) then
+        S:=S+'('+Params^+')';
+      if Assigned(VType) then
+        S:=S+': '+VType^;
+    end;
+  GetText:=S;
+end;
+
+function TSymbol.GetTypeName: string;
+var S: string;
+begin
+  case Typ of
+    abstractsym  : S:='abst';
+    fieldvarsym  : S:='member';
+    globalvarsym,
+    localvarsym,
+    paravarsym   : S:='var';
+    typesym      : S:='type';
+    procsym      : if VType=nil then
+                     S:='proc'
+                   else
+                     S:='func';
+    unitsym      : S:='unit';
+    constsym     : S:='const';
+    enumsym      : S:='enum';
+    typedconstsym: S:='const';
+    errorsym     : S:='error';
+    syssym       : S:='sys';
+    labelsym     : S:='label';
+    absolutevarsym : S:='abs';
+    propertysym  : S:='prop';
+    macrosym     : S:='macro';
+  else S:='';
+  end;
+  GetTypeName:=S;
+end;
+
+destructor TSymbol.Done;
+begin
+  inherited Done;
+  if assigned(MemInfo) then
+    Dispose(MemInfo);
+  if assigned(References) then
+    Dispose(References, Done);
+  if assigned(Items) then
+    Dispose(Items, Done);
+  if assigned(Name) then
+    DisposeStr(Name);
+{  if assigned(Params) then
+    DisposeStr(Params); in TypeNames
+  if assigned(VType) then
+    DisposeStr(VType);
+  if assigned(DType) then
+    DisposeStr(DType);
+  if assigned(Ancestor) then
+    DisposeStr(Ancestor);}
+end;
+
+constructor TSymbol.Load(var S: TStream);
+var MI: TSymbolMemInfo;
+    W: word;
+begin
+  TObject.Init;
+
+  S.Read(Typ,SizeOf(Typ));
+  S.Read(TypeID, SizeOf(TypeID));
+  S.Read(RelatedTypeID, SizeOf(RelatedTypeID));
+  S.Read(Flags, SizeOf(Flags));
+  Name:=S.ReadStr;
+  if (Flags and sfHasMemInfo)<>0 then
+    begin
+      S.Read(MI,SizeOf(MI));
+      SetMemInfo(MI);
+    end;
+
+  W:=0;
+  S.Read(W,SizeOf(W));
+  if (W and 1)<>0 then
+    New(References, Load(S));
+  if (W and 2)<>0 then
+    New(Items, Load(S));
+
+  { --- items needing fixup --- }
+  S.Read(DType, SizeOf(DType));
+  S.Read(VType, SizeOf(VType));
+  S.Read(Params, SizeOf(Params));
+end;
+
+procedure TSymbol.Store(var S: TStream);
+var W: word;
+begin
+  S.Write(Typ,SizeOf(Typ));
+  S.Write(TypeID, SizeOf(TypeID));
+  S.Write(RelatedTypeID, SizeOf(RelatedTypeID));
+  S.Write(Flags, SizeOf(Flags));
+  S.WriteStr(Name);
+
+  if (Flags and sfHasMemInfo)<>0 then
+    S.Write(MemInfo^,SizeOf(MemInfo^));
+
+  W:=0;
+  if Assigned(References) then W:=W or 1;
+  if Assigned(Items) then W:=W or 2;
+  S.Write(W,SizeOf(W));
+  if Assigned(References) then References^.Store(S);
+  if Assigned(Items) then Items^.Store(S);
+
+  { --- items needing fixup --- }
+  S.Write(DType, SizeOf(DType));
+  S.Write(VType, SizeOf(VType));
+  S.Write(Params, SizeOf(Params));
+end;
+
+constructor TExport.Init(const AName: string; AIndex: longint; ASymbol: PSymbol);
+begin
+  inherited Init;
+  Name:=NewStr(AName); Index:=AIndex;
+  Symbol:=ASymbol;
+end;
+
+function TExport.GetDisplayText: string;
+var S: string;
+begin
+  S:=GetStr(Name)+' '+IntToStr(Index);
+  if Assigned(Symbol) and (UpcaseStr(Symbol^.GetName)<>UpcaseStr(GetStr(Name))) then
+    S:=S+' ('+Symbol^.GetName+')';
+  GetDisplayText:=S;
+end;
+
+destructor TExport.Done;
+begin
+  if Assigned(Name) then DisposeStr(Name);
+  inherited Done;
+end;
+
+constructor TImport.Init(const ALibName, AFuncName,ARealName: string; AIndex: longint);
+begin
+  inherited Init;
+  LibName:=NewStr(ALibName);
+  FuncName:=NewStr(AFuncName); RealName:=NewStr(ARealName);
+  Index:=AIndex;
+end;
+
+function TImport.GetDisplayText: string;
+var S: string;
+begin
+  S:=GetStr(RealName);
+  if Assigned(FuncName) then S:=GetStr(FuncName)+' ('+S+')';
+  if S='' then S:=IntToStr(Index);
+  S:=GetStr(LibName)+' '+S;
+  GetDisplayText:=S;
+end;
+
+destructor TImport.Done;
+begin
+  if Assigned(LibName) then DisposeStr(LibName);
+  if Assigned(FuncName) then DisposeStr(FuncName);
+  if Assigned(RealName) then DisposeStr(RealName);
+  inherited Done;
+end;
+
+function TImportCollection.At(Index: sw_Integer): PImport;
+begin
+  At:=inherited At(Index);
+end;
+
+function TImportCollection.Compare(Key1, Key2: Pointer): sw_Integer;
+var K1: PImport absolute Key1;
+    K2: PImport absolute Key2;
+    S1: string;
+    S2: string;
+    R: sw_integer;
+begin
+  if (K1^.RealName=nil) and (K2^.RealName<>nil) then R:= 1 else
+  if (K1^.RealName<>nil) and (K2^.RealName=nil) then R:=-1 else
+  if (K1^.RealName=nil) and (K2^.RealName=nil) then
+    begin
+      if K1^.Index<K2^.Index then R:=-1 else
+      if K1^.Index>K2^.Index then R:= 1 else
+      R:=0;
+    end
+  else
+    begin
+      if K1^.FuncName=nil then S1:=GetStr(K1^.RealName) else S1:=GetStr(K1^.FuncName);
+      if K2^.FuncName=nil then S2:=GetStr(K2^.RealName) else S2:=GetStr(K2^.FuncName);
+      S1:=UpcaseStr(S1); S2:=UpcaseStr(S2);
+      if S1<S2 then R:=-1 else
+      if S1>S2 then R:= 1 else
+      R:=0;
+    end;
+  Compare:=R;
+end;
+
+function TExportCollection.At(Index: sw_Integer): PExport;
+begin
+  At:=inherited At(Index);
+end;
+
+function TExportCollection.Compare(Key1, Key2: Pointer): sw_Integer;
+var K1: PExport absolute Key1;
+    K2: PExport absolute Key2;
+    S1: string;
+    S2: string;
+    R: sw_integer;
+begin
+  S1:=UpcaseStr(GetStr(K1^.Name)); S2:=UpcaseStr(GetStr(K2^.Name));
+  if S1<S2 then R:=-1 else
+  if S1>S2 then R:= 1 else
+  R:=0;
+  Compare:=R;
+end;
+
+constructor TModuleSymbol.Init(const AName, AMainSource: string);
+begin
+  inherited Init(AName,unitsym,'',nil);
+  MainSource:=NewStr(AMainSource);
+end;
+
+procedure TModuleSymbol.SetLoadedFrom(const AModuleName: string);
+begin
+  SetStr(LoadedFrom,AModuleName);
+end;
+
+procedure TModuleSymbol.AddUsedUnit(P: PSymbol);
+begin
+  if Assigned(UsedUnits)=false then
+    New(UsedUnits, Init(10,10));
+  UsedUnits^.Insert(P);
+end;
+
+procedure TModuleSymbol.AddDependentUnit(P: PSymbol);
+begin
+  if Assigned(DependentUnits)=false then
+    New(DependentUnits, Init(10,10));
+  DependentUnits^.Insert(P);
+end;
+
+procedure TModuleSymbol.AddSourceFile(const Path: string);
+begin
+  if Assigned(SourceFiles)=false then
+    New(SourceFiles, Init(10,10));
+  sourcefiles^.Insert(NewStr(Path));
+end;
+
+destructor TModuleSymbol.Done;
+begin
+  inherited Done;
+  if Assigned(MainSource) then DisposeStr(MainSource);
+  if assigned(Exports_) then
+    Dispose(Exports_, Done);
+  if Assigned(Imports) then
+    Dispose(Imports, Done);
+  if Assigned(LoadedFrom) then
+    DisposeStr(LoadedFrom);
+  if Assigned(UsedUnits) then
+  begin
+    UsedUnits^.DeleteAll;
+    Dispose(UsedUnits, Done);
+  end;
+  if Assigned(DependentUnits) then
+  begin
+    DependentUnits^.DeleteAll;
+    Dispose(DependentUnits, Done);
+  end;
+  if Assigned(SourceFiles) then Dispose(SourceFiles, Done);
+end;
+
+
+constructor TObjectSymbol.Init(AParent: PObjectSymbol; ASymbol: PSymbol);
+begin
+  inherited Init;
+  Parent:=AParent;
+  Symbol:=ASymbol;
+end;
+
+constructor TObjectSymbol.InitName(const AName: string);
+begin
+  inherited Init;
+  Name:=NewStr(AName);
+end;
+
+function TObjectSymbol.GetName: string;
+begin
+  if Name<>nil then
+    GetName:=Name^
+  else
+    GetName:=Symbol^.GetName;
+end;
+
+function TObjectSymbol.GetDescendantCount: sw_integer;
+var Count: sw_integer;
+begin
+  if Descendants=nil then Count:=0 else
+    Count:=Descendants^.Count;
+  GetDescendantCount:=Count;
+end;
+
+function TObjectSymbol.GetDescendant(Index: sw_integer): PObjectSymbol;
+begin
+  GetDescendant:=Descendants^.At(Index);
+end;
+
+procedure TObjectSymbol.AddDescendant(P: PObjectSymbol);
+begin
+  if Descendants=nil then
+    New(Descendants, Init(50,10));
+  Descendants^.Insert(P);
+end;
+
+destructor TObjectSymbol.Done;
+begin
+  if Assigned(Name) then DisposeStr(Name); Name:=nil;
+  if Assigned(Descendants) then Dispose(Descendants, Done); Descendants:=nil;
+  inherited Done;
+end;
+
+constructor TObjectSymbol.Load(var S: TStream);
+begin
+end;
+
+procedure TObjectSymbol.Store(S: TStream);
+begin
+end;
+
+{****************************************************************************
+                                TSourceFile
+****************************************************************************}
+
+constructor TSourceFile.Init(ASourceFileName, AObjFileName, APPUFileName: string);
+begin
+  inherited Init;
+  SourceFileName:=NewStr(ASourceFileName);
+  ObjFileName:=NewStr(AObjFileName);
+  PPUFileName:=NewStr(APPUFileName);
+end;
+
+destructor TSourceFile.Done;
+begin
+  if assigned(SourceFileName) then DisposeStr(SourceFileName);
+  if assigned(ObjFileName) then DisposeStr(ObjFileName);
+  if assigned(PPUFileName) then DisposeStr(PPUFileName);
+  inherited Done;
+end;
+
+function TSourceFile.GetSourceFilename: string;
+begin
+  GetSourceFilename:=GetStr(SourceFileName);
+end;
+
+function TSourceFile.GetObjFileName: string;
+begin
+  GetObjFilename:=GetStr(ObjFileName);
+end;
+
+function TSourceFile.GetPPUFileName: string;
+begin
+  GetPPUFilename:=GetStr(PPUFileName);
+end;
+
+function TSourceFileCollection.At(Index: sw_Integer): PSourceFile;
+begin
+  At:=inherited At(Index);
+end;
+
+{*****************************************************************************
+                              Main Routines
+*****************************************************************************}
+
+procedure DisposeBrowserCol;
+begin
+  if assigned(Modules) then
+   begin
+     dispose(Modules,Done);
+     Modules:=nil;
+   end;
+  if assigned(ModuleNames) then
+   begin
+     dispose(ModuleNames,Done);
+     ModuleNames:=nil;
+   end;
+  if assigned(TypeNames) then
+   begin
+     dispose(TypeNames,Done);
+     TypeNames:=nil;
+   end;
+  if assigned(ObjectTree) then
+    begin
+      Dispose(ObjectTree, Done);
+      ObjectTree:=nil;
+    end;
+end;
+
+
+procedure NewBrowserCol;
+begin
+  New(Modules, Init(50,50));
+  New(ModuleNames, Init(50,50));
+  New(TypeNames, Init(1000,5000));
+end;
+
+
+  procedure ProcessSymTable(OwnerSym: PSymbol; var Owner: PSymbolCollection; Table: TSymTable);
+  var J: longint;
+      Ref: TRef;
+      Sym: TSym;
+      Symbol: PSymbol;
+      Reference: PReference;
+      inputfile : Tinputfile;
+  procedure SetVType(Symbol: PSymbol; VType: string);
+  begin
+    Symbol^.VType:=TypeNames^.Add(VType);
+  end;
+  procedure SetDType(Symbol: PSymbol; DType: string);
+  begin
+    Symbol^.DType:=TypeNames^.Add(DType);
+  end;
+  function GetDefinitionStr(def: tdef): string; forward;
+  function GetEnumDefStr(def: tenumdef): string;
+  var Name: string;
+      esym: tenumsym;
+      Count: integer;
+  begin
+    Name:='(';
+    esym:=tenumsym(def.Firstenum); Count:=0;
+    while (esym<>nil) do
+      begin
+        if Count>0 then
+          Name:=Name+', ';
+        Name:=Name+esym.name;
+        esym:=esym.nextenum;
+        Inc(Count);
+      end;
+    Name:=Name+')';
+    GetEnumDefStr:=Name;
+  end;
+  function GetArrayDefStr(def: tarraydef): string;
+  var Name: string;
+  begin
+    Name:='array ['+IntToStr(def.lowrange)+'..'+IntToStr(def.highrange)+'] of ';
+    if assigned(def.elementtype.def) then
+      Name:=Name+GetDefinitionStr(def.elementtype.def);
+    GetArrayDefStr:=Name;
+  end;
+  function GetFileDefStr(def: tfiledef): string;
+  var Name: string;
+  begin
+    Name:='';
+    case def.filetyp of
+      ft_text    : Name:='text';
+      ft_untyped : Name:='file';
+      ft_typed   : Name:='file of '+GetDefinitionStr(def.typedfiletype.def);
+    end;
+    GetFileDefStr:=Name;
+  end;
+  function GetStringDefStr(def: tstringdef): string;
+  var Name: string;
+  begin
+    Name:='';
+    case def.string_typ of
+      st_shortstring :
+        if def.len=255 then
+          Name:='shortstring'
+        else
+          Name:='string['+IntToStr(def.len)+']';
+      st_longstring :
+        Name:='longstring';
+      st_ansistring :
+        Name:='ansistring';
+      st_widestring :
+        Name:='widestring';
+    else ;
+    end;
+    GetStringDefStr:=Name;
+  end;
+  function retdefassigned(def: tabstractprocdef): boolean;
+  var OK: boolean;
+  begin
+    OK:=false;
+    if assigned(def.rettype.def) then
+      if UpcaseStr(GetDefinitionStr(def.rettype.def))<>'VOID' then
+        OK:=true;
+    retdefassigned:=OK;
+  end;
+  function GetAbsProcParmDefStr(def: tabstractprocdef): string;
+  var Name: string;
+      dc: tparavarsym;
+      i,
+      Count: integer;
+      CurName: string;
+  begin
+    Name:='';
+    Count:=0;
+    for i:=0 to def.paras.count-1 do
+     begin
+       dc:=tparavarsym(def.paras[i]);
+       if i=0 then
+         CurName:=''
+       else
+         CurName:=', '+CurName;
+       case dc.varspez of
+         vs_Value : ;
+         vs_Const : CurName:=CurName+'const ';
+         vs_Var   : CurName:=CurName+'var ';
+       end;
+       if assigned(dc.vartype.def) then
+         CurName:=CurName+GetDefinitionStr(dc.vartype.def);
+       Name:=CurName+Name;
+       Inc(Count);
+     end;
+    GetAbsProcParmDefStr:=Name;
+  end;
+  function GetAbsProcDefStr(def: tabstractprocdef): string;
+  var Name: string;
+  begin
+    Name:=GetAbsProcParmDefStr(def);
+    if Name<>'' then Name:='('+Name+')';
+    if retdefassigned(def) then
+      Name:='function'+Name+': '+GetDefinitionStr(def.rettype.def)
+    else
+      Name:='procedure'+Name;
+    GetAbsProcDefStr:=Name;
+  end;
+  function GetProcDefStr(def: tprocdef): string;
+  var DName: string;
+      {J: integer;}
+  begin
+{    DName:='';
+    if assigned(def) then
+    begin
+      if assigned(def.parast) then
+        begin
+          with def.parast^ do
+          for J:=1 to number_symbols do
+            begin
+              if J<>1 then DName:=DName+', ';
+              ParSym:=GetsymNr(J);
+              if ParSym=nil then Break;
+              DName:=DName+ParSym^.Name;
+            end;
+        end
+    end;}
+    DName:=GetAbsProcDefStr(def);
+    GetProcDefStr:=DName;
+  end;
+  function GetProcVarDefStr(def: tprocvardef): string;
+  begin
+    GetProcVarDefStr:=GetAbsProcDefStr(def);
+  end;
+  function GetSetDefStr(def: tsetdef): string;
+  var Name: string;
+  begin
+    Name:='';
+    case def.settype of
+      normset  : Name:='set';
+      smallset : Name:='set';
+      varset   : Name:='varset';
+    end;
+    Name:=Name+' of ';
+    Name:=Name+GetDefinitionStr(def.elementtype.def);
+    GetSetDefStr:=Name;
+  end;
+  function GetPointerDefStr(def: tpointerdef): string;
+  begin
+    GetPointerDefStr:='^'+GetDefinitionStr(def.pointertype.def);
+  end;
+  function GetDefinitionStr(def: tdef): string;
+  var Name: string;
+  begin
+    Name:='';
+    if def<>nil then
+    begin
+      if assigned(def.typesym) then
+        Name:=def.typesym.name;
+      if Name='' then
+      case def.deftype of
+        arraydef :
+          Name:=GetArrayDefStr(tarraydef(def));
+        stringdef :
+          Name:=GetStringDefStr(tstringdef(def));
+        enumdef :
+          Name:=GetEnumDefStr(tenumdef(def));
+        procdef :
+          Name:=GetProcDefStr(tprocdef(def));
+        procvardef :
+          Name:=GetProcVarDefStr(tprocvardef(def));
+        filedef :
+          Name:=GetFileDefStr(tfiledef(def));
+        setdef :
+          Name:=GetSetDefStr(tsetdef(def));
+      end;
+    end;
+    GetDefinitionStr:=Name;
+  end;
+  function GetEnumItemName(Sym: tenumsym): string;
+  var Name: string;
+      {ES: tenumsym;}
+  begin
+    Name:='';
+    if assigned(sym) and assigned(sym.definition) then
+      if assigned(sym.definition.typesym) then
+      begin
+{        ES:=sym.definition.First;
+        while (ES<>nil) and (ES^.Value<>sym.value) do
+          ES:=ES^.next;
+        if assigned(es) and (es^.value=sym.value) then
+          Name:=}
+        Name:=sym.definition.typesym.name;
+        if Name<>'' then
+          Name:=Name+'('+IntToStr(sym.value)+')';
+      end;
+    GetEnumItemName:=Name;
+  end;
+  function GetConstValueName(sym: tconstsym): string;
+  var Name: string;
+  begin
+    Name:='';
+    if Name='' then
+    case sym.consttyp of
+      constord :
+        begin
+          if sym.consttype.def.deftype=enumdef then
+            Name:=sym.consttype.def.typesym.name+'('+IntToStr(sym.value.valueord)+')'
+          else
+            if is_boolean(sym.consttype.def) then
+              Name:='Longbool('+IntToStr(sym.value.valueord)+')'
+          else
+            if is_char(sym.consttype.def) or
+               is_widechar(sym.consttype.def) then
+              Name:=''''+chr(sym.value.valueord)+''''
+          else
+            Name:=IntToStr(sym.value.valueord);
+        end;
+      constresourcestring,
+      conststring :
+        Name:=''''+StrPas(pchar(sym.value.valueptr))+'''';
+      constreal:
+        Name:=FloatToStr(PBestReal(sym.value.valueptr)^);
+      constset:
+{        Name:=SetToStr(pnormalset(sym.value.valueptr)) };
+      constnil: ;
+    end;
+    GetConstValueName:=Name;
+  end;
+  procedure ProcessDefIfStruct(definition: tdef);
+  begin
+    { still led to infinite recursions
+      only usefull for unamed types PM }
+    if assigned(definition) and not assigned(definition.typesym) then
+    begin
+      case definition.deftype of
+        recorddef :
+          if trecorddef(definition).symtable<>Table then
+            ProcessSymTable(Symbol,Symbol^.Items,trecorddef(definition).symtable);
+        objectdef :
+          if tobjectdef(definition).symtable<>Table then
+            ProcessSymTable(Symbol,Symbol^.Items,tobjectdef(definition).symtable);
+        { leads to infinite loops !!
+        pointerdef :
+          with tpointerdef(definition)^ do
+            if assigned(definition) then
+              if assigned(definition.sym) then
+                ProcessDefIfStruct(definition.sym.definition);}
+      end;
+    end;
+  end;
+  var MemInfo: TSymbolMemInfo;
+      ObjDef: tobjectdef;
+  begin
+    if not Assigned(Table) then
+     Exit;
+    if Owner=nil then
+     Owner:=New(PSortedSymbolCollection, Init(10,50));
+    sym:=tsym(Table.symindex.first);
+    while assigned(sym) do
+      begin
+        New(Symbol, Init(Sym.Name,Sym.Typ,'',nil));
+        case Sym.Typ of
+          globalvarsym,
+          localvarsym,
+          paravarsym :
+             with tabstractvarsym(sym) do
+             begin
+               if assigned(vartype.def) then
+                 if assigned(vartype.def.typesym) then
+                   SetVType(Symbol,vartype.def.typesym.name)
+                 else
+                   SetVType(Symbol,GetDefinitionStr(vartype.def));
+               ProcessDefIfStruct(vartype.def);
+               if assigned(vartype.def) then
+                 if (vartype.def.deftype=pointerdef) and
+                    assigned(tpointerdef(vartype.def).pointertype.def) then
+                 begin
+                   Symbol^.Flags:=(Symbol^.Flags or sfPointer);
+                   Symbol^.RelatedTypeID:=Ptrint(tpointerdef(vartype.def).pointertype.def);
+                 end;
+               if typ=fieldvarsym then
+                 MemInfo.Addr:=tfieldvarsym(sym).fieldoffset
+               else
+                 begin
+                   if tabstractnormalvarsym(sym).localloc.loc=LOC_REFERENCE then
+                     MemInfo.Addr:=tabstractnormalvarsym(sym).localloc.reference.offset
+                   else
+                     MemInfo.Addr:=0;
+                 end;
+               if assigned(vartype.def) and (vartype.def.deftype=arraydef) then
+                 begin
+                   if tarraydef(vartype.def).highrange<tarraydef(vartype.def).lowrange then
+                     MemInfo.Size:=-1
+                   else
+                     MemInfo.Size:=getsize;
+                 end
+               else
+                 MemInfo.Size:=getsize;
+               { this is not completely correct... }
+               MemInfo.PushSize:=paramanager.push_size(varspez,vartype.def,pocall_default);
+               Symbol^.SetMemInfo(MemInfo);
+             end;
+          fieldvarsym :
+             with tfieldvarsym(sym) do
+             begin
+               if assigned(vartype.def) and (vartype.def.deftype=arraydef) then
+                 begin
+                   if tarraydef(vartype.def).highrange<tarraydef(vartype.def).lowrange then
+                     MemInfo.Size:=-1
+                   else
+                     MemInfo.Size:=getsize;
+                 end
+               else
+                 MemInfo.Size:=getsize;
+               Symbol^.SetMemInfo(MemInfo);
+             end;
+          constsym :
+             SetDType(Symbol,GetConstValueName(tconstsym(sym)));
+          enumsym :
+            if assigned(tenumsym(sym).definition) then
+             SetDType(Symbol,GetEnumItemName(tenumsym(sym)));
+          unitsym :
+            begin
+  {            ProcessSymTable(Symbol^.Items,tunitsym(sym).unitsymtable);}
+            end;
+          syssym :
+{            if assigned(Table.Name) then
+            if Table.Name^='SYSTEM' then}
+              begin
+                Symbol^.Params:=TypeNames^.Add('...');
+              end;
+          procsym :
+            begin
+              with tprocsym(sym) do
+              if assigned(first_procdef) then
+              begin
+                if cs_local_browser in aktmoduleswitches then
+                  ProcessSymTable(Symbol,Symbol^.Items,first_procdef.parast);
+                if assigned(first_procdef.parast) then
+                  begin
+                    Symbol^.Params:=TypeNames^.Add(GetAbsProcParmDefStr(first_procdef));
+                  end
+                else { param-definition is NOT assigned }
+                  if assigned(Table.Name) then
+                  if Table.Name^='SYSTEM' then
+                  begin
+                    Symbol^.Params:=TypeNames^.Add('...');
+                  end;
+                if cs_local_browser in aktmoduleswitches then
+                 begin
+                   if assigned(first_procdef.localst) and
+                     (first_procdef.localst.symtabletype<>staticsymtable) then
+                    ProcessSymTable(Symbol,Symbol^.Items,first_procdef.localst);
+                 end;
+              end;
+            end;
+          typesym :
+            begin
+            with ttypesym(sym) do
+              if assigned(restype.def) then
+               begin
+                Symbol^.TypeID:=Ptrint(restype.def);
+                case restype.def.deftype of
+                  arraydef :
+                    SetDType(Symbol,GetArrayDefStr(tarraydef(restype.def)));
+                  enumdef :
+                    SetDType(Symbol,GetEnumDefStr(tenumdef(restype.def)));
+                  procdef :
+                    SetDType(Symbol,GetProcDefStr(tprocdef(restype.def)));
+                  procvardef :
+                    SetDType(Symbol,GetProcVarDefStr(tprocvardef(restype.def)));
+                  objectdef :
+                    with tobjectdef(restype.def) do
+                    begin
+                      ObjDef:=childof;
+                      if ObjDef<>nil then
+                        Symbol^.RelatedTypeID:=Ptrint(ObjDef);{TypeNames^.Add(S);}
+                      Symbol^.Flags:=(Symbol^.Flags or sfObject);
+                      if tobjectdef(restype.def).objecttype=odt_class then
+                        Symbol^.Flags:=(Symbol^.Flags or sfClass);
+                      ProcessSymTable(Symbol,Symbol^.Items,tobjectdef(restype.def).symtable);
+                    end;
+                  recorddef :
+                    begin
+                      Symbol^.Flags:=(Symbol^.Flags or sfRecord);
+                      ProcessSymTable(Symbol,Symbol^.Items,trecorddef(restype.def).symtable);
+                    end;
+                  pointerdef :
+                    begin
+                      Symbol^.Flags:=(Symbol^.Flags or sfPointer);
+                      Symbol^.RelatedTypeID:=Ptrint(tpointerdef(restype.def).pointertype.def);{TypeNames^.Add(S);}
+                      SetDType(Symbol,GetPointerDefStr(tpointerdef(restype.def)));
+                    end;
+
+                  filedef :
+                    SetDType(Symbol,GetFileDefStr(tfiledef(restype.def)));
+                  setdef :
+                    SetDType(Symbol,GetSetDefStr(tsetdef(restype.def)));
+                end;
+               end;
+            end;
+        end;
+        Ref:=tstoredsym(sym).defref;
+        while Assigned(Symbol) and assigned(Ref) do
+          begin
+            inputfile:=get_source_file(ref.moduleindex,ref.posinfo.fileindex);
+            if Assigned(inputfile) and Assigned(inputfile.name) then
+              begin
+                New(Reference, Init(ModuleNames^.Add(inputfile.name^),
+                  ref.posinfo.line,ref.posinfo.column));
+                Symbol^.References^.Insert(Reference);
+              end;
+            Ref:=Ref.nextref;
+          end;
+        if Assigned(Symbol) then
+          begin
+            if not Owner^.Search(Symbol,J) then
+              Owner^.Insert(Symbol)
+            else
+              begin
+                Dispose(Symbol,done);
+                Symbol:=nil;
+              end;
+          end;
+        sym:=tsym(sym.indexnext);
+      end;
+  end;
+
+function SearchModule(const Name: string): PModuleSymbol;
+function Match(P: PModuleSymbol): boolean; {$ifndef FPC}far;{$endif}
+begin
+  Match:=CompareText(P^.GetName,Name)=0;
+end;
+var P: PModuleSymbol;
+begin
+  P:=nil;
+  if Assigned(Modules) then
+    P:=Modules^.FirstThat(@Match);
+  SearchModule:=P;
+end;
+
+procedure CreateBrowserCol;
+var
+  T: TSymTable;
+  UnitS,PM: PModuleSymbol;
+  hp : tmodule;
+  puu: tused_unit;
+  pdu: tdependent_unit;
+  pif: tinputfile;
+begin
+  DisposeBrowserCol;
+  if (cs_browser in aktmoduleswitches) then
+    NewBrowserCol;
+  hp:=tmodule(loaded_units.first);
+  if (cs_browser in aktmoduleswitches) then
+   while assigned(hp) do
+    begin
+       t:=tsymtable(hp.globalsymtable);
+       if assigned(t) then
+         begin
+           New(UnitS, Init(T.Name^,hp.mainsource^));
+           if Assigned(hp.loaded_from) then
+             if assigned(hp.loaded_from.globalsymtable) then
+               UnitS^.SetLoadedFrom(tsymtable(hp.loaded_from.globalsymtable).name^);
+{           pimportlist(current_module^.imports^.first);}
+
+           if assigned(hp.sourcefiles) then
+           begin
+             pif:=hp.sourcefiles.files;
+             while (pif<>nil) do
+             begin
+               UnitS^.AddSourceFile(pif.path^+pif.name^);
+               pif:=pif.next;
+             end;
+           end;
+
+           Modules^.Insert(UnitS);
+           ProcessSymTable(UnitS,UnitS^.Items,T);
+           if cs_local_browser in aktmoduleswitches then
+             begin
+                t:=tsymtable(hp.localsymtable);
+                if assigned(t) then
+                  ProcessSymTable(UnitS,UnitS^.Items,T);
+             end;
+         end;
+       hp:=tmodule(hp.next);
+    end;
+
+  hp:=tmodule(loaded_units.first);
+  if (cs_browser in aktmoduleswitches) then
+   while assigned(hp) do
+    begin
+       t:=tsymtable(hp.globalsymtable);
+       if assigned(t) then
+         begin
+           UnitS:=SearchModule(T.Name^);
+           puu:=tused_unit(hp.used_units.first);
+           while (puu<>nil) do
+           begin
+             PM:=SearchModule(puu.u.modulename^);
+             if Assigned(PM) then
+               UnitS^.AddUsedUnit(PM);
+             puu:=tused_unit(puu.next);
+           end;
+           pdu:=tdependent_unit(hp.dependent_units.first);
+           while (pdu<>nil) do
+           begin
+             PM:=SearchModule(tsymtable(pdu.u.globalsymtable).name^);
+             if Assigned(PM) then
+               UnitS^.AddDependentUnit(PM);
+             pdu:=tdependent_unit(pdu.next);
+           end;
+         end;
+       hp:=tmodule(hp.next);
+    end;
+
+  if (cs_browser in aktmoduleswitches) then
+    BuildObjectInfo;
+  { can allways be done
+    needed to know when recompilation of sources is necessary }
+  BuildSourceList;
+end;
+
+procedure BuildObjectInfo;
+var C,D: PIDSortedSymbolCollection;
+    E : PCollection;
+    ObjectC: PObjectSymbolCollection;
+    ObjectsSymbol: PObjectSymbol;
+procedure InsertSymbolCollection(Symbols: PSymbolCollection);
+var I: sw_integer;
+    P: PSymbol;
+begin
+  for I:=0 to Symbols^.Count-1 do
+    begin
+      P:=Symbols^.At(I);
+      if (P^.Flags and sfObject)<>0 then
+        C^.Insert(P);
+      if (P^.typ=typesym) then
+        D^.Insert(P);
+      if (P^.typ in [globalvarsym,localvarsym,paravarsym]) and ((P^.flags and sfPointer)<>0) then
+        E^.Insert(P);
+      if P^.Items<>nil then
+        InsertSymbolCollection(P^.Items);
+    end;
+end;
+function SearchObjectForSym(O: PSymbol): PObjectSymbol;
+var I: sw_integer;
+    OS,P: PObjectSymbol;
+begin
+  P:=nil;
+  for I:=0 to ObjectC^.Count-1 do
+    begin
+      OS:=ObjectC^.At(I);
+      if OS^.Symbol=O then
+        begin P:=OS; Break; end;
+    end;
+  SearchObjectForSym:=P;
+end;
+procedure BuildTree;
+var I: sw_integer;
+    Symbol: PSymbol;
+    Parent,OS: PObjectSymbol;
+begin
+  I:=0;
+  while (I<C^.Count) do
+    begin
+      Symbol:=C^.At(I);
+      if Symbol^.Ancestor=nil then
+        Parent:=ObjectsSymbol
+      else
+        Parent:=SearchObjectForSym(Symbol^.Ancestor);
+      if Parent<>nil then
+        begin
+          New(OS, Init(Parent, Symbol));
+          Parent^.AddDescendant(OS);
+          ObjectC^.Insert(OS);
+          C^.AtDelete(I);
+        end
+      else
+        Inc(I);
+    end;
+end;
+var Pass: integer;
+    I: sw_integer;
+    P: PSymbol;
+begin
+  New(C, Init(1000,5000));
+  New(D, Init(1000,5000));
+  New(E, Init(1000,5000));
+  InsertSymbolCollection(Modules);
+
+  { --- Resolve ancestor<->descendant references --- }
+  for I:=0 to C^.Count-1 do
+    begin
+      P:=C^.At(I);
+      if P^.RelatedTypeID<>0 then
+        P^.Ancestor:=C^.SearchSymbolByID(P^.RelatedTypeID);
+    end;
+
+  { --- Resolve pointer definition references --- }
+  for I:=0 to D^.Count-1 do
+    begin
+      P:=D^.At(I);
+      if P^.RelatedTypeID<>0 then
+        P^.Ancestor:=D^.SearchSymbolByID(P^.RelatedTypeID);
+    end;
+
+  { --- Resolve  pointer var definition references --- }
+  for I:=0 to E^.Count-1 do
+    begin
+      P:=PSymbol(E^.At(I));
+      if P^.RelatedTypeID<>0 then
+        P^.Ancestor:=D^.SearchSymbolByID(P^.RelatedTypeID);
+    end;
+
+  { E is not needed anymore }
+  E^.DeleteAll;
+  Dispose(E,Done);
+
+  { D is not needed anymore }
+  D^.DeleteAll;
+  Dispose(D,Done);
+
+  { --- Build object tree --- }
+  if assigned(ObjectTree) then
+    Dispose(ObjectTree, Done);
+  New(ObjectsSymbol, InitName('Objects'));
+  ObjectTree:=ObjectsSymbol;
+
+  New(ObjectC, Init(C^.Count,100));
+
+  Pass:=0;
+  if C^.Count>0 then
+  repeat
+    BuildTree;
+    Inc(Pass);
+  until (C^.Count=0) or (Pass>20); { more than 20 levels ? - then there must be a bug }
+
+  ObjectC^.DeleteAll; Dispose(ObjectC, Done);
+  C^.DeleteAll; Dispose(C, Done);
+end;
+
+function SearchObjectForSymbol(O: PSymbol): PObjectSymbol;
+function ScanObjectCollection(Parent: PObjectSymbol): PObjectSymbol;
+var I: sw_integer;
+    OS,P: PObjectSymbol;
+    ObjectC: PObjectSymbolCollection;
+begin
+  P:=nil;
+  if Parent<>nil then
+  if Parent^.Descendants<>nil then
+  begin
+    ObjectC:=Parent^.Descendants;
+    for I:=0 to ObjectC^.Count-1 do
+      begin
+        OS:=ObjectC^.At(I);
+        if OS^.Symbol=O then
+          begin P:=OS; Break; end;
+        if OS^.Descendants<>nil then
+          begin
+            P:=ScanObjectCollection(OS);
+            if P<>nil then Break;
+          end;
+      end;
+  end;
+  ScanObjectCollection:=P;
+end;
+begin
+  SearchObjectForSymbol:=ScanObjectCollection(ObjectTree);
+end;
+
+procedure BuildSourceList;
+var m: tmodule;
+    s: tinputfile;
+    p: cutils.pstring;
+    ppu,obj: string;
+    source: string;
+begin
+  if Assigned(SourceFiles) then
+    begin
+      Dispose(SourceFiles, Done);
+      SourceFiles:=nil;
+    end;
+  if assigned(loaded_units.first) then
+  begin
+    New(SourceFiles, Init(50,10));
+    m:=tmodule(loaded_units.first);
+    while assigned(m) do
+    begin
+      obj:=fexpand(m.objfilename^);
+      ppu:=''; source:='';
+      if m.is_unit then
+        ppu:=fexpand(m.ppufilename^);
+      if (m.is_unit=false) and (m.islibrary=false) then
+        ppu:=fexpand(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:=fexpand(source);
+
+            sourcefiles^.Insert(New(PSourceFile, Init(source,obj,ppu)));
+            s:=s.ref_next;
+          end;
+        end;
+      m:=tmodule(m.next);
+    end;
+  end;
+end;
+
+{*****************************************************************************
+                                 Initialize
+*****************************************************************************}
+
+
+
+var
+  oldexit : pointer;
+
+procedure browcol_exit;{$ifndef FPC}far;{$endif}
+begin
+  exitproc:=oldexit;
+  DisposeBrowserCol;
+  if Assigned(SourceFiles) then
+    begin
+      Dispose(SourceFiles, Done);
+      SourceFiles:=nil;
+    end;
+  if assigned(ObjectTree) then
+    begin
+      Dispose(ObjectTree, Done);
+      ObjectTree:=nil;
+    end;
+end;
+
+
+procedure InitBrowserCol;
+begin
+end;
+
+
+procedure DoneBrowserCol;
+begin
+  { nothing, the collections are freed in the exitproc - ??? }
+  { nothing? then why do we've this routine for ? IMHO, either we should
+    remove this, or it should destroy the browser info when it's called. - BG }
+end;
+
+type
+     PPointerXRef = ^TPointerXRef;
+     TPointerXRef = record
+       PtrValue : pointer;
+       DataPtr  : pointer;
+     end;
+
+     PPointerDictionary = ^TPointerDictionary;
+     TPointerDictionary = object(TSortedCollection)
+       function  At(Index: sw_Integer): PPointerXRef;
+       function  Compare(Key1, Key2: Pointer): sw_Integer; virtual;
+       procedure FreeItem(Item: Pointer); virtual;
+       function  SearchXRef(PtrValue: pointer): PPointerXRef;
+       function  AddPtr(PtrValue, DataPtr: pointer): PPointerXRef;
+       procedure Resolve(var P);
+     end;
+
+function NewPointerXRef(APtrValue, ADataPtr: pointer): PPointerXRef;
+var P: PPointerXRef;
+begin
+  New(P); FillChar(P^,SizeOf(P^),0);
+  with P^ do begin PtrValue:=APtrValue; DataPtr:=ADataPtr; end;
+  NewPointerXRef:=P;
+end;
+
+procedure DisposePointerXRef(P: PPointerXRef);
+begin
+  if Assigned(P) then Dispose(P);
+end;
+
+function TPointerDictionary.At(Index: sw_Integer): PPointerXRef;
+begin
+  At:=inherited At(Index);
+end;
+
+function TPointerDictionary.Compare(Key1, Key2: Pointer): sw_Integer;
+var K1: PPointerXRef absolute Key1;
+    K2: PPointerXRef absolute Key2;
+    R: integer;
+begin
+  if Ptrint(K1^.PtrValue)<Ptrint(K2^.PtrValue) then R:=-1 else
+  if Ptrint(K1^.PtrValue)>Ptrint(K2^.PtrValue) then R:= 1 else
+  R:=0;
+  Compare:=R;
+end;
+
+procedure TPointerDictionary.FreeItem(Item: Pointer);
+begin
+  if Assigned(Item) then DisposePointerXRef(Item);
+end;
+
+function TPointerDictionary.SearchXRef(PtrValue: pointer): PPointerXRef;
+var P: PPointerXRef;
+    T: TPointerXRef;
+    Index: sw_integer;
+begin
+  T.PtrValue:=PtrValue;
+  if Search(@T,Index)=false then P:=nil else
+    P:=At(Index);
+  SearchXRef:=P;
+end;
+
+function TPointerDictionary.AddPtr(PtrValue, DataPtr: pointer): PPointerXRef;
+var P: PPointerXRef;
+begin
+  P:=SearchXRef(PtrValue);
+  if P=nil then
+    begin
+      P:=NewPointerXRef(PtrValue,DataPtr);
+      Insert(P);
+{$ifdef DEBUG}
+    end
+  else
+    begin
+      if P^.DataPtr<>DataPtr then
+        InternalError(987654);
+{$endif DEBUG}
+    end;
+  AddPtr:=P;
+end;
+
+procedure TPointerDictionary.Resolve(var P);
+var X: PPointerXRef;
+    V: pointer;
+begin
+  Move(P,V,SizeOf(V));
+  X:=SearchXRef(V);
+  if X=nil then V:=nil else
+    V:=X^.DataPtr;
+  Move(V,P,SizeOf(V));
+end;
+
+procedure ReadPointers(S: PStream; C: PCollection; D: PPointerDictionary);
+var W,I: sw_integer;
+    P: pointer;
+begin
+  S^.Read(W,SizeOf(W));
+  for I:=0 to W-1 do
+  begin
+    S^.Read(P,SizeOf(P));
+    D^.AddPtr(P,C^.At(I));
+  end;
+end;
+
+function LoadBrowserCol(S: PStream): boolean;
+var PD: PPointerDictionary;
+procedure FixupPointers;
+procedure FixupReference(P: PReference); {$ifndef FPC}far;{$endif}
+begin
+  PD^.Resolve(P^.FileName);
+end;
+procedure FixupSymbol(P: PSymbol); {$ifndef FPC}far;{$endif}
+var I: sw_integer;
+begin
+  PD^.Resolve(P^.DType);
+  PD^.Resolve(P^.VType);
+  PD^.Resolve(P^.Params);
+  if Assigned(P^.References) then
+    with P^.References^ do
+     for I:=0 to Count-1 do
+       FixupReference(At(I));
+  if Assigned(P^.Items) then
+    with P^.Items^ do
+     for I:=0 to Count-1 do
+       FixupSymbol(At(I));
+end;
+begin
+  Modules^.ForEach(@FixupSymbol);
+end;
+procedure ReadSymbolPointers(P: PSymbol); {$ifndef FPC}far;{$endif}
+var I: sw_integer;
+    PV: pointer;
+begin
+  S^.Read(PV, SizeOf(PV));
+  PD^.AddPtr(PV,P);
+  if Assigned(P^.Items) then
+    with P^.Items^ do
+     for I:=0 to Count-1 do
+       ReadSymbolPointers(At(I));
+end;
+begin
+  DisposeBrowserCol;
+
+  New(ModuleNames, Load(S^));
+  New(TypeNames, Load(S^));
+  New(Modules, Load(S^));
+
+  New(PD, Init(4000,1000));
+  ReadPointers(S,ModuleNames,PD);
+  ReadPointers(S,TypeNames,PD);
+  ReadPointers(S,Modules,PD);
+  Modules^.ForEach(@ReadSymbolPointers);
+  FixupPointers;
+  Dispose(PD, Done);
+
+  BuildObjectInfo;
+  LoadBrowserCol:=(S^.Status=stOK);
+end;
+
+procedure StorePointers(S: PStream; C: PCollection);
+var W,I: sw_integer;
+    P: pointer;
+begin
+  W:=C^.Count;
+  S^.Write(W,SizeOf(W));
+  for I:=0 to W-1 do
+  begin
+    P:=C^.At(I);
+    S^.Write(P,SizeOf(P));
+  end;
+end;
+
+function StoreBrowserCol(S: PStream) : boolean;
+procedure WriteSymbolPointers(P: PSymbol); {$ifndef FPC}far;{$endif}
+var I: sw_integer;
+begin
+  S^.Write(P, SizeOf(P));
+  if Assigned(P^.Items) then
+    with P^.Items^ do
+     for I:=0 to Count-1 do
+       WriteSymbolPointers(At(I));
+end;
+begin
+  ModuleNames^.Store(S^);
+  TypeNames^.Store(S^);
+  Modules^.Store(S^);
+
+  StorePointers(S,ModuleNames);
+  StorePointers(S,TypeNames);
+  StorePointers(S,Modules);
+  Modules^.ForEach(@WriteSymbolPointers);
+  StoreBrowserCol:=(S^.Status=stOK);
+end;
+
+procedure RegisterSymbols;
+begin
+  RegisterType(RModuleNameCollection);
+  RegisterType(RTypeNameCollection);
+  RegisterType(RReference);
+  RegisterType(RSymbol);
+  RegisterType(RObjectSymbol);
+  RegisterType(RSymbolCollection);
+  RegisterType(RSortedSymbolCollection);
+  RegisterType(RIDSortedSymbolCollection);
+  RegisterType(RObjectSymbolCollection);
+  RegisterType(RReferenceCollection);
+  RegisterType(RModuleSymbol);
+end;
+
+begin
+  oldexit:=exitproc;
+  exitproc:=@browcol_exit;
+end.

+ 515 - 0
compiler/browlog.pas

@@ -0,0 +1,515 @@
+{
+    Copyright (c) 1998-2002 by Florian Klaempfl and Pierre Muller
+
+    Support routines for creating the browser log
+
+    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 browlog;
+
+{$i fpcdefs.inc}
+
+interface
+uses
+  cclasses,
+  globtype,
+  fmodule,finput,
+  symbase,symconst,symtype,symsym,symdef,symtable;
+
+const
+  logbufsize   = 16384;
+
+type
+  pbrowserlog=^tbrowserlog;
+  tbrowserlog=object
+    fname    : string;
+    logopen  : boolean;
+    stderrlog : boolean;
+    f        : file;
+    elements_to_list : tstringlist;
+    buf      : pchar;
+    bufidx   : longint;
+    identidx : longint;
+    constructor init;
+    destructor done;
+    procedure setfilename(const fn:string);
+    procedure createlog;
+    procedure flushlog;
+    procedure addlog(const s:string);
+    procedure addlogrefs(p:tref);
+    procedure closelog;
+    procedure ident;
+    procedure unident;
+    procedure browse_symbol(const sr : string);
+    procedure list_elements;
+    procedure list_debug_infos;
+  end;
+
+var
+  browserlog : tbrowserlog;
+
+  procedure WriteBrowserLog;
+
+  procedure InitBrowserLog;
+  procedure DoneBrowserLog;
+
+
+implementation
+
+  uses
+    cutils,comphook,
+    globals,systems,
+    ppu;
+
+    function get_file_line(ref:tref): string;
+      var
+         inputfile : tinputfile;
+      begin
+        get_file_line:='';
+        with ref do
+         begin
+           inputfile:=get_source_file(moduleindex,posinfo.fileindex);
+           if assigned(inputfile) then
+             if status.use_gccoutput then
+             { for use with rhide
+               add warning so that it does not interpret
+               this as an error !! }
+               get_file_line:=lower(inputfile.name^)
+                 +':'+tostr(posinfo.line)+': warning: '+tostr(posinfo.column)+':'
+             else
+               get_file_line:=inputfile.name^
+                 +'('+tostr(posinfo.line)+','+tostr(posinfo.column)+')'
+           else
+             if status.use_gccoutput then
+               get_file_line:='file_unknown:'
+                 +tostr(posinfo.line)+': warning: '+tostr(posinfo.column)+':'
+             else
+               get_file_line:='file_unknown('
+                 +tostr(posinfo.line)+','+tostr(posinfo.column)+')'
+         end;
+      end;
+
+{****************************************************************************
+                              TBrowser
+****************************************************************************}
+
+    constructor tbrowserlog.init;
+      begin
+        fname:=FixFileName('browser.log');
+        logopen:=false;
+        elements_to_list:=TStringList.Create;
+      end;
+
+
+    destructor tbrowserlog.done;
+      begin
+        if logopen then
+         closelog;
+        elements_to_list.free;
+      end;
+
+
+    procedure tbrowserlog.setfilename(const fn:string);
+      begin
+        fname:=FixFileName(fn);
+      end;
+
+
+    procedure tbrowserlog.createlog;
+      begin
+        if logopen then
+         closelog;
+        assign(f,fname);
+        {$I-}
+         rewrite(f,1);
+        {$I+}
+        if ioresult<>0 then
+         exit;
+        logopen:=true;
+        getmem(buf,logbufsize);
+        bufidx:=0;
+        identidx:=0;
+      end;
+
+
+    procedure tbrowserlog.flushlog;
+      begin
+        if logopen then
+         if not stderrlog then
+           blockwrite(f,buf^,bufidx)
+         else
+           begin
+             buf[bufidx]:=#0;
+{$ifdef FPC}
+             write(stderr,buf);
+{$else FPC}
+             write(buf);
+{$endif FPC}
+           end;
+        bufidx:=0;
+      end;
+
+
+    procedure tbrowserlog.closelog;
+      begin
+        if logopen then
+         begin
+           flushlog;
+           close(f);
+           freemem(buf,logbufsize);
+           logopen:=false;
+         end;
+      end;
+
+    procedure tbrowserlog.list_elements;
+
+      begin
+
+         stderrlog:=true;
+         getmem(buf,logbufsize);
+         logopen:=true;
+         while not elements_to_list.empty do
+           browse_symbol(elements_to_list.getfirst);
+         flushlog;
+         logopen:=false;
+         freemem(buf,logbufsize);
+         stderrlog:=false;
+      end;
+
+    procedure tbrowserlog.list_debug_infos;
+{$ifndef debug}
+      begin
+      end;
+{$else debug}
+      var
+         hp : tmodule;
+         ff : tinputfile;
+      begin
+         hp:=tmodule(loaded_units.first);
+         while assigned(hp) do
+           begin
+              addlog('Unit '+hp.modulename^+' has index '+tostr(hp.unit_index));
+              ff:=hp.sourcefiles.files;
+              while assigned(ff) do
+                begin
+                   addlog('File '+ff.name^+' index '+tostr(ff.ref_index));
+                   ff:=ff.ref_next;
+                end;
+              hp:=tmodule(hp.next);
+           end;
+      end;
+{$endif debug}
+
+    procedure tbrowserlog.addlog(const s:string);
+      begin
+        if not logopen then
+         exit;
+      { add ident }
+        if (identidx>0) and not stderrlog then
+         begin
+           if bufidx+identidx>logbufsize then
+            flushlog;
+           fillchar(buf[bufidx],identidx,' ');
+           inc(bufidx,identidx);
+         end;
+      { add text }
+        if bufidx+length(s)>logbufsize-2 then
+         flushlog;
+        move(s[1],buf[bufidx],length(s));
+        inc(bufidx,length(s));
+      { add crlf }
+        buf[bufidx]:=target_info.newline[1];
+        inc(bufidx);
+        if length(target_info.newline)=2 then
+         begin
+           buf[bufidx]:=target_info.newline[2];
+           inc(bufidx);
+         end;
+      end;
+
+
+    procedure tbrowserlog.addlogrefs(p:tref);
+      var
+        ref : tref;
+      begin
+        ref:=p;
+        Ident;
+        while assigned(ref) do
+         begin
+           Browserlog.AddLog(get_file_line(ref));
+           ref:=ref.nextref;
+         end;
+        Unident;
+      end;
+
+
+    procedure tbrowserlog.browse_symbol(const sr : string);
+      var
+         sym  : tsym;
+         symb : tstoredsym;
+         symt : tsymtable;
+         hp : tmodule;
+         s,ss : string;
+         p : byte;
+
+         procedure next_substring;
+           begin
+              p:=pos('.',s);
+              if p>0 then
+                begin
+                   ss:=copy(s,1,p-1);
+                   s:=copy(s,p+1,255);
+                end
+              else
+                begin
+                  ss:=s;
+                  s:='';
+                end;
+              addlog('substring : '+ss);
+          end;
+      begin
+         { don't create a new reference when
+          looking for the symbol !! }
+         make_ref:=false;
+         s:=sr;
+         symt:=symtablestack;
+         next_substring;
+         if assigned(symt) then
+           begin
+              sym:=tstoredsym(symt.search(ss));
+              if sym=nil then
+                sym:=tstoredsym(symt.search(upper(ss)));
+           end
+         else
+           sym:=nil;
+         if assigned(sym) and (sym.typ=unitsym) and (s<>'') then
+           begin
+              addlog('Unitsym found !');
+              symt:=tunitsym(sym).unitsymtable;
+              if assigned(symt) then
+                begin
+                   next_substring;
+                   sym:=tstoredsym(symt.search(ss));
+                end
+              else
+                sym:=nil;
+           end;
+         if not assigned(sym) then
+           begin
+              symt:=nil;
+              { try all loaded_units }
+              hp:=tmodule(loaded_units.first);
+              while assigned(hp) do
+                begin
+                   if hp.modulename^=upper(ss) then
+                     begin
+                        symt:=hp.globalsymtable;
+                        break;
+                     end;
+                   hp:=tmodule(hp.next);
+                end;
+              if not assigned(symt) then
+                begin
+                   addlog('!!!Symbol '+ss+' not found !!!');
+                   make_ref:=true;
+                   exit;
+                end
+              else
+                begin
+                   next_substring;
+                   sym:=tstoredsym(symt.search(ss));
+                   if sym=nil then
+                     sym:=tstoredsym(symt.search(upper(ss)));
+                end;
+           end;
+
+         while assigned(sym) and (s<>'') do
+           begin
+              next_substring;
+              case sym.typ of
+                typesym :
+                  begin
+                     if ttypesym(sym).restype.def.deftype in [recorddef,objectdef] then
+                       begin
+                          if ttypesym(sym).restype.def.deftype=recorddef then
+                            symt:=trecorddef(ttypesym(sym).restype.def).symtable
+                          else
+                            symt:=tobjectdef(ttypesym(sym).restype.def).symtable;
+                          sym:=tstoredsym(symt.search(ss));
+                          if sym=nil then
+                            sym:=tstoredsym(symt.search(upper(ss)));
+                       end;
+                  end;
+                globalvarsym,
+                localvarsym,
+                paravarsym,
+                fieldvarsym :
+                  begin
+                     if tabstractvarsym(sym).vartype.def.deftype in [recorddef,objectdef] then
+                       begin
+                          symt:=tabstractvarsym(sym).vartype.def.getsymtable(gs_record);
+                          sym:=tstoredsym(symt.search(ss));
+                          if sym=nil then
+                            sym:=tstoredsym(symt.search(upper(ss)));
+                       end;
+                  end;
+                procsym :
+                  begin
+                     symt:=tprocsym(sym).first_procdef.parast;
+                     symb:=tstoredsym(symt.search(ss));
+                     if symb=nil then
+                       symb:=tstoredsym(symt.search(upper(ss)));
+                     if not assigned(symb) then
+                       begin
+                          symt:=tprocsym(sym).first_procdef.localst;
+                          sym:=tstoredsym(symt.search(ss));
+                          if symb=nil then
+                            symb:=tstoredsym(symt.search(upper(ss)));
+                       end
+                     else
+                       sym:=symb;
+                  end;
+                end;
+           end;
+           if assigned(sym) then
+            begin
+              if assigned(sym.defref) then
+               begin
+                 browserlog.AddLog('***'+sym.name+'***');
+                 browserlog.AddLogRefs(sym.defref);
+               end;
+            end
+           else
+             addlog('!!!Symbol '+ss+' not found !!!');
+           make_ref:=true;
+      end;
+
+    procedure tbrowserlog.ident;
+      begin
+        inc(identidx,2);
+      end;
+
+
+    procedure tbrowserlog.unident;
+      begin
+        dec(identidx,2);
+      end;
+
+    procedure writesymtable(p:Tsymtable);forward;
+
+    procedure writelocalsymtables(p:Tprocdef;arg:pointer);
+
+    begin
+        if assigned(p.defref) then
+            begin
+                browserlog.AddLog('***'+p.mangledname);
+                browserlog.AddLogRefs(p.defref);
+                if (current_module.flags and uf_local_browser)<>0 then
+                    begin
+                        if assigned(p.parast) then
+                            writesymtable(p.parast);
+                        if assigned(p.localst) then
+                            writesymtable(p.localst);
+                    end;
+             end;
+    end;
+
+
+    procedure writesymtable(p:tsymtable);
+      var
+        hp : tsym;
+        prdef : pprocdeflist;
+      begin
+        if cs_browser in aktmoduleswitches then
+         begin
+           if assigned(p.name) then
+             Browserlog.AddLog('---Symtable '+p.name^)
+           else
+             begin
+                if (p.symtabletype=recordsymtable) and
+                   assigned(tdef(p.defowner).typesym) then
+                  Browserlog.AddLog('---Symtable '+tdef(p.defowner).typesym.name)
+                else
+                  Browserlog.AddLog('---Symtable with no name');
+             end;
+           Browserlog.Ident;
+           hp:=tstoredsym(p.symindex.first);
+           while assigned(hp) do
+            begin
+              if assigned(hp.defref) then
+               begin
+                 browserlog.AddLog('***'+hp.name+'***');
+                 browserlog.AddLogRefs(hp.defref);
+               end;
+              case hp.typ of
+                typesym :
+                  begin
+                    if (ttypesym(hp).restype.def.deftype=recorddef) then
+                      writesymtable(trecorddef(ttypesym(hp).restype.def).symtable);
+                    if (ttypesym(hp).restype.def.deftype=objectdef) then
+                      writesymtable(tobjectdef(ttypesym(hp).restype.def).symtable);
+                  end;
+                procsym :
+                    Tprocsym(hp).foreach_procdef_static(@writelocalsymtables,nil);
+              end;
+              hp:=tstoredsym(hp.indexnext);
+            end;
+           browserlog.Unident;
+         end;
+      end;
+
+
+{****************************************************************************
+                             Helpers
+****************************************************************************}
+
+   procedure WriteBrowserLog;
+     var
+       p : tstoredsymtable;
+       hp : tmodule;
+     begin
+       browserlog.CreateLog;
+       browserlog.list_debug_infos;
+       hp:=tmodule(loaded_units.first);
+       while assigned(hp) do
+         begin
+            p:=tstoredsymtable(hp.globalsymtable);
+            if assigned(p) then
+              writesymtable(p);
+            if cs_local_browser in aktmoduleswitches then
+              begin
+                 p:=tstoredsymtable(hp.localsymtable);
+                 if assigned(p) then
+                   writesymtable(p);
+              end;
+            hp:=tmodule(hp.next);
+         end;
+       browserlog.CloseLog;
+     end;
+
+
+  procedure InitBrowserLog;
+    begin
+       browserlog.init;
+    end;
+
+  procedure DoneBrowserLog;
+    begin
+       browserlog.done;
+    end;
+
+end.

+ 3 - 0
compiler/bsdcompile

@@ -0,0 +1,3 @@
+#!/bin/sh
+ppc386 -OG3p3 -Ch8000000 -dI386 -dGDB -dBROWSERLOG -Sg pp.pas -a -s -g %1 %2 %3 %4 %5 %6 %7 %8 %9
+

+ 92 - 0
compiler/catch.pas

@@ -0,0 +1,92 @@
+{
+    Copyright (c) 1998-2002 by Michael Van Canneyt
+
+    Unit to catch segmentation faults and Ctrl-C and exit gracefully
+    under linux and go32v2
+
+    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 catch;
+
+{$i fpcdefs.inc}
+
+{$ifdef DEBUG}
+  {$define NOCATCH}
+{$endif DEBUG}
+
+interface
+uses
+{$ifdef unix}
+ {$ifndef beos}
+  {$define has_signal}
+  {$ifdef havelinuxrtl10}
+    Linux,
+  {$else}
+    BaseUnix,Unix,
+  {$endif}
+ {$endif}
+{$endif}
+{$ifdef go32v2}
+{$define has_signal}
+  dpmiexcp,
+{$endif}
+{$ifdef watcom}
+  {$define has_signal}
+  dpmiexcp,
+{$endif}
+  verbose;
+
+{$ifdef has_signal}
+Var
+  NewSignal,
+  OldSigInt : SignalHandler;
+{$endif}
+
+Const in_const_evaluation : boolean = false;
+
+Implementation
+
+{$IFNDEF MACOS_USE_FAKE_SYSUTILS}
+uses
+  comphook;
+{$ENDIF MACOS_USE_FAKE_SYSUTILS}
+
+{$ifdef has_signal}
+{$ifdef unix}
+Procedure CatchSignal(Sig : Longint);cdecl;
+{$else}
+Function CatchSignal(Sig : longint):longint;
+{$endif}
+begin
+  case Sig of
+    SIGINT :
+      raise EControlCAbort.Create;
+  end;
+{$ifndef unix}
+  CatchSignal:=0;
+{$endif}
+end;
+{$endif def has_signal}
+
+begin
+{$ifndef nocatch}
+  {$ifdef has_signal}
+    NewSignal:=SignalHandler(@CatchSignal);
+    OldSigInt:={$ifdef havelinuxrtl10}Signal{$else}{$ifdef Unix}fpSignal{$else}Signal{$endif}{$endif}  (SIGINT,NewSignal);
+  {$endif}
+{$endif nocatch}
+end.

+ 2352 - 0
compiler/cclasses.pas

@@ -0,0 +1,2352 @@
+{
+    Copyright (c) 1998-2002 by Florian Klaempfl and Peter Vreman
+
+    This module provides some basic classes
+
+    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 cclasses;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+      cutils,cstreams;
+
+{********************************************
+                TMemDebug
+********************************************}
+
+    type
+       tmemdebug = class
+       private
+          totalmem,
+          startmem : integer;
+          infostr  : string[40];
+       public
+          constructor Create(const s:string);
+          destructor  Destroy;override;
+          procedure show;
+          procedure start;
+          procedure stop;
+       end;
+
+{*******************************************************
+   TList (Copied from FCL, exception handling stripped)
+********************************************************}
+
+const
+   MaxListSize = Maxint div 16;
+   SListIndexError = 'List index exceeds bounds (%d)';
+   SListCapacityError = 'The maximum list capacity is reached (%d)';
+   SListCountError = 'List count too large (%d)';
+type
+{ TList class }
+
+   PPointerList = ^TPointerList;
+   TPointerList = array[0..MaxListSize - 1] of Pointer;
+   TListSortCompare = function (Item1, Item2: Pointer): Integer;
+
+   TList = class(TObject)
+   private
+     FList: PPointerList;
+     FCount: Integer;
+     FCapacity: Integer;
+   protected
+     function Get(Index: Integer): Pointer;
+     procedure Grow; virtual;
+     procedure Put(Index: Integer; Item: Pointer);
+     procedure SetCapacity(NewCapacity: Integer);
+     procedure SetCount(NewCount: Integer);
+   public
+     destructor Destroy; override;
+     function Add(Item: Pointer): Integer;
+     procedure Clear; dynamic;
+     procedure Delete(Index: Integer);
+     class procedure Error(const Msg: string; Data: Integer); virtual;
+     procedure Exchange(Index1, Index2: Integer);
+     function Expand: TList;
+     function Extract(item: Pointer): Pointer;
+     function First: Pointer;
+     procedure Assign(Obj:TList);
+     function IndexOf(Item: Pointer): Integer;
+     procedure Insert(Index: Integer; Item: Pointer);
+     function Last: Pointer;
+     procedure Move(CurIndex, NewIndex: Integer);
+     function Remove(Item: Pointer): Integer;
+     procedure Pack;
+     procedure Sort(Compare: TListSortCompare);
+     property Capacity: Integer read FCapacity write SetCapacity;
+     property Count: Integer read FCount write SetCount;
+     property Items[Index: Integer]: Pointer read Get write Put; default;
+     property List: PPointerList read FList;
+   end;
+
+{********************************************
+                TLinkedList
+********************************************}
+
+    type
+       TLinkedListItem = class
+       public
+          Previous,
+          Next : TLinkedListItem;
+          Constructor Create;
+          Destructor Destroy;override;
+          Function GetCopy:TLinkedListItem;virtual;
+       end;
+
+       TLinkedListItemClass = class of TLinkedListItem;
+
+       TLinkedList = class
+       private
+          FCount : integer;
+          FFirst,
+          FLast  : TLinkedListItem;
+          FNoClear : boolean;
+       public
+          constructor Create;
+          destructor  Destroy;override;
+          { true when the List is empty }
+          function  Empty:boolean;
+          { deletes all Items }
+          procedure Clear;
+          { inserts an Item }
+          procedure Insert(Item:TLinkedListItem);
+          { inserts an Item before Loc }
+          procedure InsertBefore(Item,Loc : TLinkedListItem);
+          { inserts an Item after Loc }
+          procedure InsertAfter(Item,Loc : TLinkedListItem);virtual;
+          { concats an Item }
+          procedure Concat(Item:TLinkedListItem);
+          { deletes an Item }
+          procedure Remove(Item:TLinkedListItem);
+          { Gets First Item }
+          function  GetFirst:TLinkedListItem;
+          { Gets last Item }
+          function  GetLast:TLinkedListItem;
+          { inserts another List at the begin and make this List empty }
+          procedure insertList(p : TLinkedList);
+          { inserts another List before the provided item and make this List empty }
+          procedure insertListBefore(Item:TLinkedListItem;p : TLinkedList);
+          { inserts another List after the provided item and make this List empty }
+          procedure insertListAfter(Item:TLinkedListItem;p : TLinkedList);
+          { concats another List at the end and make this List empty }
+          procedure concatList(p : TLinkedList);
+          { concats another List at the start and makes a copy
+            the list is ordered in reverse.
+          }
+          procedure insertListcopy(p : TLinkedList);
+          { concats another List at the end and makes a copy }
+          procedure concatListcopy(p : TLinkedList);
+          property First:TLinkedListItem read FFirst;
+          property Last:TLinkedListItem read FLast;
+          property Count:Integer read FCount;
+          property NoClear:boolean write FNoClear;
+       end;
+
+{********************************************
+                TStringList
+********************************************}
+
+       { string containerItem }
+       TStringListItem = class(TLinkedListItem)
+          FPStr : PString;
+       public
+          constructor Create(const s:string);
+          destructor  Destroy;override;
+          function GetCopy:TLinkedListItem;override;
+          function Str:string;
+       end;
+
+       { string container }
+       TStringList = class(TLinkedList)
+       private
+          FDoubles : boolean;  { if this is set to true, doubles are allowed }
+       public
+          constructor Create;
+          constructor Create_No_Double;
+          { inserts an Item }
+          procedure Insert(const s:string);
+          { concats an Item }
+          procedure Concat(const s:string);
+          { deletes an Item }
+          procedure Remove(const s:string);
+          { Gets First Item }
+          function  GetFirst:string;
+          { Gets last Item }
+          function  GetLast:string;
+          { true if string is in the container, compare case sensitive }
+          function FindCase(const s:string):TStringListItem;
+          { true if string is in the container }
+          function Find(const s:string):TStringListItem;
+          { inserts an item }
+          procedure InsertItem(item:TStringListItem);
+          { concats an item }
+          procedure ConcatItem(item:TStringListItem);
+          property Doubles:boolean read FDoubles write FDoubles;
+       end;
+
+
+{********************************************
+                Dictionary
+********************************************}
+
+    const
+       { the real size will be [0..hasharray-1] ! }
+       hasharraysize = 512;
+
+    type
+       { namedindexobect for use with dictionary and indexarray }
+       TNamedIndexItem=class
+       private
+       { indexarray }
+         FIndexNr    : integer;
+         FIndexNext  : TNamedIndexItem;
+       { dictionary }
+         FLeft,
+         FRight      : TNamedIndexItem;
+         FSpeedValue : cardinal;
+       { singleList }
+         FListNext   : TNamedIndexItem;
+         FName       : Pstring;
+       protected
+         function  GetName:string;virtual;
+         procedure SetName(const n:string);virtual;
+       public
+         constructor Create;
+         constructor CreateName(const n:string);
+         destructor  Destroy;override;
+         property IndexNr:integer read FIndexNr write FIndexNr;
+         property IndexNext:TNamedIndexItem read FIndexNext write FIndexNext;
+         property Name:string read GetName write SetName;
+         property SpeedValue:cardinal read FSpeedValue;
+         property ListNext:TNamedIndexItem read FListNext;
+         property Left:TNamedIndexItem read FLeft write FLeft;
+         property Right:TNamedIndexItem read FRight write FRight;
+       end;
+
+       Pdictionaryhasharray=^Tdictionaryhasharray;
+       Tdictionaryhasharray=array[0..hasharraysize-1] of TNamedIndexItem;
+
+       TnamedIndexCallback = procedure(p:TNamedIndexItem;arg:pointer) of object;
+       TnamedIndexStaticCallback = procedure(p:TNamedIndexItem;arg:pointer);
+
+       Tdictionary=class
+       private
+         FRoot      : TNamedIndexItem;
+         FCount     : longint;
+         FHashArray : Pdictionaryhasharray;
+         procedure cleartree(var obj:TNamedIndexItem);
+         function  insertNode(NewNode:TNamedIndexItem;var currNode:TNamedIndexItem):TNamedIndexItem;
+         procedure inserttree(currtree,currroot:TNamedIndexItem);
+       public
+         noclear   : boolean;
+         delete_doubles : boolean;
+         constructor Create;
+         destructor  Destroy;override;
+         procedure usehash;
+         procedure clear;
+         function  delete(const s:string):TNamedIndexItem;
+         function  empty:boolean;
+         procedure foreach(proc2call:TNamedIndexcallback;arg:pointer);
+         procedure foreach_static(proc2call:TNamedIndexStaticCallback;arg:pointer);
+         function  insert(obj:TNamedIndexItem):TNamedIndexItem;
+         function  replace(oldobj,newobj:TNamedIndexItem):boolean;
+         function  rename(const olds,News : string):TNamedIndexItem;
+         function  search(const s:string):TNamedIndexItem;
+         function  speedsearch(const s:string;SpeedValue:cardinal):TNamedIndexItem;
+         property  Items[const s:string]:TNamedIndexItem read Search;default;
+         property  Count:longint read FCount;
+       end;
+
+       tsingleList=class
+         First,
+         last    : TNamedIndexItem;
+         constructor Create;
+         procedure reset;
+         procedure clear;
+         procedure insert(p:TNamedIndexItem);
+       end;
+
+      tindexobjectarray=array[1..16000] of TNamedIndexItem;
+      pnamedindexobjectarray=^tindexobjectarray;
+
+      tindexarray=class
+        noclear : boolean;
+        First   : TNamedIndexItem;
+        count   : integer;
+        constructor Create(Agrowsize:integer);
+        destructor  destroy;override;
+        procedure clear;
+        procedure foreach(proc2call : Tnamedindexcallback;arg:pointer);
+        procedure foreach_static(proc2call : Tnamedindexstaticcallback;arg:pointer);
+        procedure deleteindex(p:TNamedIndexItem);
+        procedure delete(var p:TNamedIndexItem);
+        procedure insert(p:TNamedIndexItem);
+        procedure replace(oldp,newp:TNamedIndexItem);
+        function  search(nr:integer):TNamedIndexItem;
+      private
+        growsize,
+        size  : integer;
+        data  : pnamedindexobjectarray;
+        procedure grow(gsize:integer);
+      end;
+
+
+{********************************************
+              DynamicArray
+********************************************}
+
+     const
+       dynamicblockbasesize = 12;
+
+     type
+       pdynamicblock = ^tdynamicblock;
+       tdynamicblock = record
+         pos,
+         used : integer;
+         Next : pdynamicblock;
+         { can't use sizeof(integer) because it crashes gdb }
+         data : array[0..1024*1024] of byte;
+       end;
+
+       tdynamicarray = class
+       private
+         FPosn       : integer;
+         FPosnblock  : pdynamicblock;
+         FBlocksize  : integer;
+         FFirstblock,
+         FLastblock  : pdynamicblock;
+         procedure grow;
+       public
+         constructor Create(Ablocksize:integer);
+         destructor  Destroy;override;
+         procedure reset;
+         function  size:integer;
+         procedure align(i:integer);
+         procedure seek(i:integer);
+         function  read(var d;len:integer):integer;
+         procedure write(const d;len:integer);
+         procedure writestr(const s:string);
+         procedure readstream(f:TCStream;maxlen:longint);
+         procedure writestream(f:TCStream);
+         property  BlockSize : integer read FBlocksize;
+         property  FirstBlock : PDynamicBlock read FFirstBlock;
+         property  Pos : integer read FPosn;
+       end;
+
+
+implementation
+
+{*****************************************************************************
+                                    Memory debug
+*****************************************************************************}
+
+    constructor tmemdebug.create(const s:string);
+      begin
+        infostr:=s;
+        totalmem:=0;
+        Start;
+      end;
+
+
+    procedure tmemdebug.start;
+
+      var
+        status : TFPCHeapStatus;
+
+      begin
+        status:=GetFPCHeapStatus;
+        startmem:=status.CurrHeapUsed;
+      end;
+
+
+    procedure tmemdebug.stop;
+      var
+        status : TFPCHeapStatus;
+      begin
+        if startmem<>0 then
+         begin
+           status:=GetFPCHeapStatus;
+           inc(TotalMem,startmem-status.CurrHeapUsed);
+           startmem:=0;
+         end;
+      end;
+
+
+    destructor tmemdebug.destroy;
+      begin
+        Stop;
+        show;
+      end;
+
+
+    procedure tmemdebug.show;
+      begin
+        write('memory [',infostr,'] ');
+        if TotalMem>0 then
+         writeln(DStr(TotalMem shr 10),' Kb released')
+        else
+         writeln(DStr((-TotalMem) shr 10),' Kb allocated');
+      end;
+
+
+{*****************************************************************************
+                                 TList
+*****************************************************************************}
+
+Const
+   // Ratio of Pointer and Word Size.
+   WordRatio = SizeOf(Pointer) Div SizeOf(Word);
+
+function TList.Get(Index: Integer): Pointer;
+
+begin
+   If (Index<0) or (Index>=FCount) then
+     Error(SListIndexError,Index);
+   Result:=FList^[Index];
+end;
+
+
+
+procedure TList.Grow;
+
+begin
+   // Only for compatibility with Delphi. Not needed.
+end;
+
+
+
+procedure TList.Put(Index: Integer; Item: Pointer);
+
+begin
+   if (Index<0) or (Index>=FCount) then
+     Error(SListIndexError,Index);
+   Flist^[Index]:=Item;
+end;
+
+
+function TList.Extract(item: Pointer): Pointer;
+var
+   i : Integer;
+begin
+   result:=nil;
+   i:=IndexOf(item);
+   if i>=0 then
+    begin
+      Result:=item;
+      FList^[i]:=nil;
+      Delete(i);
+    end;
+end;
+
+
+procedure TList.SetCapacity(NewCapacity: Integer);
+begin
+   If (NewCapacity<0) or (NewCapacity>MaxListSize) then
+      Error (SListCapacityError,NewCapacity);
+   if NewCapacity=FCapacity then
+     exit;
+   ReallocMem(FList,SizeOf(Pointer)*NewCapacity);
+   if NewCapacity > FCapacity then
+     FillChar (FList^ [FCapacity],
+                              (NewCapacity - FCapacity) * SizeOf (pointer), 0);
+   FCapacity:=NewCapacity;
+end;
+
+
+
+procedure TList.SetCount(NewCount: Integer);
+
+begin
+   If (NewCount<0) or (NewCount>MaxListSize)then
+     Error(SListCountError,NewCount);
+   If NewCount<FCount then
+     FCount:=NewCount
+   else If NewCount>FCount then
+     begin
+     If NewCount>FCapacity then
+       SetCapacity (NewCount);
+     If FCount<NewCount then
+       FillWord (Flist^[FCount],(NewCount-FCount)* WordRatio ,0);
+     FCount:=Newcount;
+     end;
+end;
+
+
+
+destructor TList.Destroy;
+
+begin
+   Self.Clear;
+   inherited Destroy;
+end;
+
+
+Function TList.Add(Item: Pointer): Integer;
+
+begin
+   Self.Insert (Count,Item);
+   Result:=Count-1;
+end;
+
+
+
+Procedure TList.Clear;
+
+begin
+   If Assigned(FList) then
+     begin
+     FreeMem (Flist,FCapacity*SizeOf(Pointer));
+     FList:=Nil;
+     FCapacity:=0;
+     FCount:=0;
+     end;
+end;
+
+
+Procedure TList.Delete(Index: Integer);
+begin
+   If (Index<0) or (Index>=FCount) then
+     Error (SListIndexError,Index);
+   FCount:=FCount-1;
+   System.Move (FList^[Index+1],FList^[Index],(FCount-Index)*SizeOf(Pointer));
+   // Shrink the list if appropiate
+   if (FCapacity > 256) and (FCount < FCapacity shr 2) then
+   begin
+     FCapacity := FCapacity shr 1;
+     ReallocMem(FList, SizeOf(Pointer) * FCapacity);
+   end;
+end;
+
+
+class procedure TList.Error(const Msg: string; Data: Integer);
+{$ifdef EXTDEBUG}
+var
+  s : string;
+{$endif EXTDEBUG}
+begin
+{$ifdef EXTDEBUG}
+  s:=Msg;
+  Replace(s,'%d',ToStr(Data));
+  writeln(s);
+{$endif EXTDEBUG}
+  internalerrorproc(200411151);
+end;
+
+procedure TList.Exchange(Index1, Index2: Integer);
+
+var Temp : Pointer;
+
+begin
+   If ((Index1>=FCount) or (Index1<0)) then
+     Error(SListIndexError,Index1);
+   If ((Index2>=FCount) or (Index2<0)) then
+     Error(SListIndexError,Index2);
+   Temp:=FList^[Index1];
+   FList^[Index1]:=FList^[Index2];
+   FList^[Index2]:=Temp;
+end;
+
+
+
+function TList.Expand: TList;
+
+Var IncSize : Longint;
+
+begin
+   if FCount<FCapacity then exit;
+   IncSize:=4;
+   if FCapacity>3 then IncSize:=IncSize+4;
+   if FCapacity>8 then IncSize:=IncSize+8;
+   if FCapacity>127 then Inc(IncSize, FCapacity shr 2);
+   SetCapacity(FCapacity+IncSize);
+   Result:=Self;
+end;
+
+
+function TList.First: Pointer;
+
+begin
+   If FCount=0 then
+     Result:=Nil
+   else
+     Result:=Items[0];
+end;
+
+
+
+function TList.IndexOf(Item: Pointer): Integer;
+
+begin
+   Result:=0;
+   While (Result<FCount) and (Flist^[Result]<>Item) do Result:=Result+1;
+   If Result=FCount  then Result:=-1;
+end;
+
+
+
+procedure TList.Insert(Index: Integer; Item: Pointer);
+
+begin
+   If (Index<0) or (Index>FCount )then
+     Error(SlistIndexError,Index);
+   IF FCount=FCapacity Then Self.Expand;
+   If Index<FCount then
+     System.Move(Flist^[Index],Flist^[Index+1],(FCount-Index)*SizeOf(Pointer));
+   FList^[Index]:=Item;
+   FCount:=FCount+1;
+end;
+
+
+
+function TList.Last: Pointer;
+
+begin
+   // Wouldn't it be better to return nil if the count is zero ?
+   If FCount=0 then
+     Result:=Nil
+   else
+     Result:=Items[FCount-1];
+end;
+
+
+procedure TList.Move(CurIndex, NewIndex: Integer);
+
+Var Temp : Pointer;
+
+begin
+   If ((CurIndex<0) or (CurIndex>Count-1)) then
+     Error(SListIndexError,CurIndex);
+   If (NewINdex<0) then
+     Error(SlistIndexError,NewIndex);
+   Temp:=FList^[CurIndex];
+   FList^[CurIndex]:=Nil;
+   Self.Delete(CurIndex);
+   // ?? If NewIndex>CurIndex then NewIndex:=NewIndex-1;
+   // Newindex changes when deleting ??
+   Self.Insert (NewIndex,Nil);
+   FList^[NewIndex]:=Temp;
+end;
+
+
+function TList.Remove(Item: Pointer): Integer;
+
+begin
+   Result:=IndexOf(Item);
+   If Result<>-1 then
+     Self.Delete (Result);
+end;
+
+
+
+Procedure TList.Pack;
+
+Var  {Last,I,J,}Runner : Longint;
+
+begin
+   // Not the fastest; but surely correct
+   For Runner:=Fcount-1 downto 0 do
+     if Items[Runner]=Nil then Self.Delete(Runner);
+{ The following may be faster in case of large and defragmented lists
+   If count=0 then exit;
+   Runner:=0;I:=0;
+   TheLast:=Count;
+   while runner<count do
+     begin
+     // Find first Nil
+     While (FList^[Runner]<>Nil) and (Runner<Count) do Runner:=Runner+1;
+     if Runner<Count do
+       begin
+       // Start searching for non-nil from last known nil+1
+       if i<Runner then I:=Runner+1;
+       While (Flist[I]^=Nil) and (I<Count) do I:=I+1;
+       // Start looking for last non-nil of block.
+       J:=I+1;
+       While (Flist^[J]<>Nil) and (J<Count) do J:=J+1;
+       // Move block and zero out
+       Move (Flist^[I],Flist^[Runner],J*SizeOf(Pointer));
+       FillWord (Flist^[I],(J-I)*WordRatio,0);
+       // Update Runner and Last to point behind last block
+       TheLast:=Runner+(J-I);
+       If J=Count then
+          begin
+          // Shortcut, when J=Count we checked all pointers
+          Runner:=Count
+       else
+          begin
+          Runner:=TheLast;
+          I:=j;
+       end;
+     end;
+   Count:=TheLast;
+}
+end;
+
+// Needed by Sort method.
+
+Procedure QuickSort (Flist : PPointerList; L,R : Longint;
+                      Compare : TListSortCompare);
+
+Var I,J : Longint;
+     P,Q : Pointer;
+
+begin
+  Repeat
+    I:=L;
+    J:=R;
+    P:=FList^[ (L+R) div 2 ];
+    repeat
+      While Compare(P,FList^[i])>0 Do I:=I+1;
+      While Compare(P,FList^[J])<0 Do J:=J-1;
+      If I<=J then
+        begin
+        Q:=Flist^[I];
+        Flist^[I]:=FList^[J];
+        FList^[J]:=Q;
+        I:=I+1;
+        J:=j-1;
+        end;
+    Until I>J;
+    If L<J then QuickSort (FList,L,J,Compare);
+    L:=I;
+  Until I>=R;
+end;
+
+procedure TList.Sort(Compare: TListSortCompare);
+
+begin
+   If Not Assigned(FList) or (FCount<2) then exit;
+   QuickSort (Flist, 0, FCount-1,Compare);
+end;
+
+procedure TList.Assign(Obj:TList);
+// Principle copied from TCollection
+
+var i : Integer;
+begin
+   Clear;
+   For I:=0 To Obj.Count-1 Do
+     Add(Obj[i]);
+end;
+
+
+{****************************************************************************
+                             TLinkedListItem
+ ****************************************************************************}
+
+    constructor TLinkedListItem.Create;
+      begin
+        Previous:=nil;
+        Next:=nil;
+      end;
+
+
+    destructor TLinkedListItem.Destroy;
+      begin
+      end;
+
+
+    function TLinkedListItem.GetCopy:TLinkedListItem;
+      var
+        p : TLinkedListItem;
+        l : integer;
+      begin
+        p:=TLinkedListItemClass(ClassType).Create;
+        l:=InstanceSize;
+        Move(pointer(self)^,pointer(p)^,l);
+        Result:=p;
+      end;
+
+
+{****************************************************************************
+                                   TLinkedList
+ ****************************************************************************}
+
+    constructor TLinkedList.Create;
+      begin
+        FFirst:=nil;
+        Flast:=nil;
+        FCount:=0;
+        FNoClear:=False;
+      end;
+
+
+    destructor TLinkedList.destroy;
+      begin
+        if not FNoClear then
+         Clear;
+      end;
+
+
+    function TLinkedList.empty:boolean;
+      begin
+        Empty:=(FFirst=nil);
+      end;
+
+
+    procedure TLinkedList.Insert(Item:TLinkedListItem);
+      begin
+        if FFirst=nil then
+         begin
+           FLast:=Item;
+           Item.Previous:=nil;
+           Item.Next:=nil;
+         end
+        else
+         begin
+           FFirst.Previous:=Item;
+           Item.Previous:=nil;
+           Item.Next:=FFirst;
+         end;
+        FFirst:=Item;
+        inc(FCount);
+      end;
+
+
+    procedure TLinkedList.InsertBefore(Item,Loc : TLinkedListItem);
+      begin
+         Item.Previous:=Loc.Previous;
+         Item.Next:=Loc;
+         Loc.Previous:=Item;
+         if assigned(Item.Previous) then
+           Item.Previous.Next:=Item
+         else
+           { if we've no next item, we've to adjust FFist }
+           FFirst:=Item;
+         inc(FCount);
+      end;
+
+
+    procedure TLinkedList.InsertAfter(Item,Loc : TLinkedListItem);
+      begin
+         Item.Next:=Loc.Next;
+         Loc.Next:=Item;
+         Item.Previous:=Loc;
+         if assigned(Item.Next) then
+           Item.Next.Previous:=Item
+         else
+           { if we've no next item, we've to adjust FLast }
+           FLast:=Item;
+         inc(FCount);
+      end;
+
+
+    procedure TLinkedList.Concat(Item:TLinkedListItem);
+      begin
+        if FFirst=nil then
+         begin
+           FFirst:=Item;
+           Item.Previous:=nil;
+           Item.Next:=nil;
+         end
+        else
+         begin
+           Flast.Next:=Item;
+           Item.Previous:=Flast;
+           Item.Next:=nil;
+         end;
+        Flast:=Item;
+        inc(FCount);
+      end;
+
+
+    procedure TLinkedList.remove(Item:TLinkedListItem);
+      begin
+         if Item=nil then
+           exit;
+         if (FFirst=Item) and (Flast=Item) then
+           begin
+              FFirst:=nil;
+              Flast:=nil;
+           end
+         else if FFirst=Item then
+           begin
+              FFirst:=Item.Next;
+              if assigned(FFirst) then
+                FFirst.Previous:=nil;
+           end
+         else if Flast=Item then
+           begin
+              Flast:=Flast.Previous;
+              if assigned(Flast) then
+                Flast.Next:=nil;
+           end
+         else
+           begin
+              Item.Previous.Next:=Item.Next;
+              Item.Next.Previous:=Item.Previous;
+           end;
+         Item.Next:=nil;
+         Item.Previous:=nil;
+         dec(FCount);
+      end;
+
+
+    procedure TLinkedList.clear;
+      var
+        NewNode : TLinkedListItem;
+      begin
+        NewNode:=FFirst;
+        while assigned(NewNode) do
+         begin
+           FFirst:=NewNode.Next;
+           NewNode.Free;
+           NewNode:=FFirst;
+          end;
+        FLast:=nil;
+        FFirst:=nil;
+        FCount:=0;
+      end;
+
+
+    function TLinkedList.GetFirst:TLinkedListItem;
+      begin
+         if FFirst=nil then
+          GetFirst:=nil
+         else
+          begin
+            GetFirst:=FFirst;
+            if FFirst=FLast then
+             FLast:=nil;
+            FFirst:=FFirst.Next;
+            dec(FCount);
+          end;
+      end;
+
+
+    function TLinkedList.GetLast:TLinkedListItem;
+      begin
+         if FLast=nil then
+          Getlast:=nil
+         else
+          begin
+            Getlast:=FLast;
+            if FLast=FFirst then
+             FFirst:=nil;
+            FLast:=FLast.Previous;
+            dec(FCount);
+          end;
+      end;
+
+
+    procedure TLinkedList.insertList(p : TLinkedList);
+      begin
+         { empty List ? }
+         if (p.FFirst=nil) then
+           exit;
+         p.Flast.Next:=FFirst;
+         { we have a double Linked List }
+         if assigned(FFirst) then
+           FFirst.Previous:=p.Flast;
+         FFirst:=p.FFirst;
+         if (FLast=nil) then
+           Flast:=p.Flast;
+         inc(FCount,p.FCount);
+         { p becomes empty }
+         p.FFirst:=nil;
+         p.Flast:=nil;
+         p.FCount:=0;
+      end;
+
+
+    procedure TLinkedList.insertListBefore(Item:TLinkedListItem;p : TLinkedList);
+      begin
+         { empty List ? }
+         if (p.FFirst=nil) then
+           exit;
+         if (Item=nil) then
+           begin
+             { Insert at begin }
+             InsertList(p);
+             exit;
+           end
+         else
+           begin
+             p.FLast.Next:=Item;
+             p.FFirst.Previous:=Item.Previous;
+             if assigned(Item.Previous) then
+               Item.Previous.Next:=p.FFirst
+             else
+               FFirst:=p.FFirst;
+             Item.Previous:=p.FLast;
+             inc(FCount,p.FCount);
+           end;
+         { p becomes empty }
+         p.FFirst:=nil;
+         p.Flast:=nil;
+         p.FCount:=0;
+      end;
+
+
+    procedure TLinkedList.insertListAfter(Item:TLinkedListItem;p : TLinkedList);
+      begin
+         { empty List ? }
+         if (p.FFirst=nil) then
+           exit;
+         if (Item=nil) then
+           begin
+             { Insert at begin }
+             InsertList(p);
+             exit;
+           end
+         else
+           begin
+             p.FFirst.Previous:=Item;
+             p.FLast.Next:=Item.Next;
+             if assigned(Item.Next) then
+               Item.Next.Previous:=p.FLast
+             else
+               FLast:=p.FLast;
+             Item.Next:=p.FFirst;
+             inc(FCount,p.FCount);
+           end;
+         { p becomes empty }
+         p.FFirst:=nil;
+         p.Flast:=nil;
+         p.FCount:=0;
+      end;
+
+
+    procedure TLinkedList.concatList(p : TLinkedList);
+      begin
+        if (p.FFirst=nil) then
+         exit;
+        if FFirst=nil then
+         FFirst:=p.FFirst
+        else
+         begin
+           FLast.Next:=p.FFirst;
+           p.FFirst.Previous:=Flast;
+         end;
+        Flast:=p.Flast;
+        inc(FCount,p.FCount);
+        { make p empty }
+        p.Flast:=nil;
+        p.FFirst:=nil;
+        p.FCount:=0;
+      end;
+
+
+    procedure TLinkedList.insertListcopy(p : TLinkedList);
+      var
+        NewNode,NewNode2 : TLinkedListItem;
+      begin
+        NewNode:=p.First;
+        while assigned(NewNode) do
+         begin
+           NewNode2:=NewNode.Getcopy;
+           if assigned(NewNode2) then
+            Insert(NewNode2);
+           NewNode:=NewNode.Next;
+         end;
+      end;
+
+
+    procedure TLinkedList.concatListcopy(p : TLinkedList);
+      var
+        NewNode,NewNode2 : TLinkedListItem;
+      begin
+        NewNode:=p.First;
+        while assigned(NewNode) do
+         begin
+           NewNode2:=NewNode.Getcopy;
+           if assigned(NewNode2) then
+            Concat(NewNode2);
+           NewNode:=NewNode.Next;
+         end;
+      end;
+
+
+{****************************************************************************
+                             TStringListItem
+ ****************************************************************************}
+
+    constructor TStringListItem.Create(const s:string);
+      begin
+        inherited Create;
+        FPStr:=stringdup(s);
+      end;
+
+
+    destructor TStringListItem.Destroy;
+      begin
+        stringdispose(FPStr);
+      end;
+
+
+    function TStringListItem.Str:string;
+      begin
+        Str:=FPStr^;
+      end;
+
+
+    function TStringListItem.GetCopy:TLinkedListItem;
+      begin
+        Result:=(inherited GetCopy);
+        TStringListItem(Result).FPStr:=stringdup(FPstr^);
+      end;
+
+
+{****************************************************************************
+                           TSTRINGList
+ ****************************************************************************}
+
+    constructor tstringList.Create;
+      begin
+         inherited Create;
+         FDoubles:=true;
+      end;
+
+
+    constructor tstringList.Create_no_double;
+      begin
+         inherited Create;
+         FDoubles:=false;
+      end;
+
+
+    procedure tstringList.insert(const s : string);
+      begin
+         if (s='') or
+            ((not FDoubles) and (find(s)<>nil)) then
+          exit;
+         inherited insert(tstringListItem.create(s));
+      end;
+
+
+    procedure tstringList.concat(const s : string);
+      begin
+         if (s='') or
+            ((not FDoubles) and (find(s)<>nil)) then
+          exit;
+         inherited concat(tstringListItem.create(s));
+      end;
+
+
+    procedure tstringList.remove(const s : string);
+      var
+        p : tstringListItem;
+      begin
+        if s='' then
+         exit;
+        p:=find(s);
+        if assigned(p) then
+         begin
+           inherited Remove(p);
+           p.Free;
+         end;
+      end;
+
+
+    function tstringList.GetFirst : string;
+      var
+         p : tstringListItem;
+      begin
+         p:=tstringListItem(inherited GetFirst);
+         if p=nil then
+          GetFirst:=''
+         else
+          begin
+            GetFirst:=p.FPStr^;
+            p.free;
+          end;
+      end;
+
+
+    function tstringList.Getlast : string;
+      var
+         p : tstringListItem;
+      begin
+         p:=tstringListItem(inherited Getlast);
+         if p=nil then
+          Getlast:=''
+         else
+          begin
+            Getlast:=p.FPStr^;
+            p.free;
+          end;
+      end;
+
+
+    function tstringList.FindCase(const s:string):TstringListItem;
+      var
+        NewNode : tstringListItem;
+      begin
+        result:=nil;
+        if s='' then
+         exit;
+        NewNode:=tstringListItem(FFirst);
+        while assigned(NewNode) do
+         begin
+           if NewNode.FPStr^=s then
+            begin
+              result:=NewNode;
+              exit;
+            end;
+           NewNode:=tstringListItem(NewNode.Next);
+         end;
+      end;
+
+
+    function tstringList.Find(const s:string):TstringListItem;
+      var
+        NewNode : tstringListItem;
+        ups     : string;
+      begin
+        result:=nil;
+        if s='' then
+         exit;
+        ups:=upper(s);
+        NewNode:=tstringListItem(FFirst);
+        while assigned(NewNode) do
+         begin
+           if upper(NewNode.FPStr^)=ups then
+            begin
+              result:=NewNode;
+              exit;
+            end;
+           NewNode:=tstringListItem(NewNode.Next);
+         end;
+      end;
+
+
+    procedure TStringList.InsertItem(item:TStringListItem);
+      begin
+        inherited Insert(item);
+      end;
+
+
+    procedure TStringList.ConcatItem(item:TStringListItem);
+      begin
+        inherited Concat(item);
+      end;
+
+
+{****************************************************************************
+                               TNamedIndexItem
+ ****************************************************************************}
+
+    constructor TNamedIndexItem.Create;
+      begin
+        { index }
+        Findexnr:=-1;
+        FindexNext:=nil;
+        { dictionary }
+        Fleft:=nil;
+        Fright:=nil;
+        FName:=nil;
+        Fspeedvalue:=cardinal($ffffffff);
+        { List }
+        FListNext:=nil;
+      end;
+
+    constructor TNamedIndexItem.Createname(const n:string);
+      begin
+        { index }
+        Findexnr:=-1;
+        FindexNext:=nil;
+        { dictionary }
+        Fleft:=nil;
+        Fright:=nil;
+        fspeedvalue:=getspeedvalue(n);
+      {$ifdef compress}
+        FName:=stringdup(minilzw_encode(n));
+      {$else}
+        FName:=stringdup(n);
+      {$endif}
+        { List }
+        FListNext:=nil;
+      end;
+
+
+    destructor TNamedIndexItem.destroy;
+      begin
+        stringdispose(FName);
+      end;
+
+
+    procedure TNamedIndexItem.setname(const n:string);
+      begin
+        if assigned(FName) then
+          stringdispose(FName);
+        fspeedvalue:=getspeedvalue(n);
+      {$ifdef compress}
+        FName:=stringdup(minilzw_encode(n));
+      {$else}
+        FName:=stringdup(n);
+      {$endif}
+      end;
+
+
+    function TNamedIndexItem.GetName:string;
+      begin
+        if assigned(FName) then
+        {$ifdef compress}
+         Getname:=minilzw_decode(FName^)
+        {$else}
+         Getname:=FName^
+        {$endif}
+        else
+         Getname:='';
+      end;
+
+
+{****************************************************************************
+                               TDICTIONARY
+****************************************************************************}
+
+    constructor Tdictionary.Create;
+      begin
+        FRoot:=nil;
+        FHashArray:=nil;
+        noclear:=false;
+        delete_doubles:=false;
+      end;
+
+
+    procedure Tdictionary.usehash;
+      begin
+        if not(assigned(FRoot)) and
+           not(assigned(FHashArray)) then
+         begin
+           New(FHashArray);
+           fillchar(FHashArray^,sizeof(FHashArray^),0);
+         end;
+      end;
+
+
+    function counttree(p: tnamedindexitem): longint;
+      begin
+        counttree:=0;
+        if not assigned(p) then
+          exit;
+        result := 1;
+        inc(result,counttree(p.fleft));
+        inc(result,counttree(p.fright));
+      end;
+
+    destructor Tdictionary.destroy;
+      begin
+        if not noclear then
+         clear;
+        if assigned(FHashArray) then
+         begin
+           dispose(FHashArray);
+         end;
+      end;
+
+
+    procedure Tdictionary.cleartree(var obj:TNamedIndexItem);
+      begin
+        if assigned(obj.Fleft) then
+          cleartree(obj.FLeft);
+        if assigned(obj.FRight) then
+          cleartree(obj.FRight);
+        obj.free;
+        obj:=nil;
+      end;
+
+
+    procedure Tdictionary.clear;
+      var
+        w : integer;
+      begin
+        if assigned(FRoot) then
+          cleartree(FRoot);
+        if assigned(FHashArray) then
+         for w:= low(FHashArray^) to high(FHashArray^) do
+          if assigned(FHashArray^[w]) then
+           cleartree(FHashArray^[w]);
+      end;
+
+
+    function Tdictionary.delete(const s:string):TNamedIndexItem;
+      var
+        p,SpeedValue : cardinal;
+        n : TNamedIndexItem;
+      {$ifdef compress}
+        senc:string;
+      {$else}
+        senc:string absolute s;
+      {$endif}
+
+        procedure insert_right_bottom(var root,Atree:TNamedIndexItem);
+          begin
+            while root.FRight<>nil do
+             root:=root.FRight;
+            root.FRight:=Atree;
+          end;
+
+        function delete_from_tree(root:TNamedIndexItem):TNamedIndexItem;
+          type
+            leftright=(left,right);
+          var
+            lr : leftright;
+            oldroot : TNamedIndexItem;
+          begin
+            oldroot:=nil;
+            while (root<>nil) and (root.SpeedValue<>SpeedValue) do
+             begin
+               oldroot:=root;
+               if SpeedValue<root.SpeedValue then
+                begin
+                  root:=root.FRight;
+                  lr:=right;
+                end
+               else
+                begin
+                  root:=root.FLeft;
+                  lr:=left;
+                end;
+             end;
+            while (root<>nil) and (root.FName^<>senc) do
+             begin
+               oldroot:=root;
+               if senc<root.FName^ then
+                begin
+                  root:=root.FRight;
+                  lr:=right;
+                end
+               else
+                begin
+                  root:=root.FLeft;
+                  lr:=left;
+                end;
+             end;
+            if root<>nil then
+              begin
+                dec(FCount);
+                if root.FLeft<>nil then
+                 begin
+                   { Now the Node pointing to root must point to the left
+                     subtree of root. The right subtree of root must be
+                     connected to the right bottom of the left subtree.}
+                   if lr=left then
+                    oldroot.FLeft:=root.FLeft
+                   else
+                    oldroot.FRight:=root.FLeft;
+                   if root.FRight<>nil then
+                    insert_right_bottom(root.FLeft,root.FRight);
+                 end
+                else
+                 begin
+                   { There is no left subtree. So we can just replace the Node to
+                     delete with the right subtree.}
+                   if lr=left then
+                    oldroot.FLeft:=root.FRight
+                   else
+                    oldroot.FRight:=root.FRight;
+                 end;
+              end;
+            delete_from_tree:=root;
+          end;
+
+      begin
+      {$ifdef compress}
+        senc:=minilzw_encode(s);
+      {$endif}
+        SpeedValue:=GetSpeedValue(s);
+        n:=FRoot;
+        if assigned(FHashArray) then
+         begin
+           { First, check if the Node to delete directly located under
+             the hasharray.}
+           p:=SpeedValue mod hasharraysize;
+           n:=FHashArray^[p];
+           if (n<>nil) and (n.SpeedValue=SpeedValue) and
+              (n.FName^=senc) then
+            begin
+              { The Node to delete is directly located under the
+                hasharray. Make the hasharray point to the left
+                subtree of the Node and place the right subtree on
+                the right-bottom of the left subtree.}
+              if n.FLeft<>nil then
+               begin
+                 FHashArray^[p]:=n.FLeft;
+                 if n.FRight<>nil then
+                  insert_right_bottom(n.FLeft,n.FRight);
+               end
+              else
+               FHashArray^[p]:=n.FRight;
+              delete:=n;
+              dec(FCount);
+              exit;
+            end;
+         end
+        else
+         begin
+           { First check if the Node to delete is the root.}
+           if (FRoot<>nil) and (n.SpeedValue=SpeedValue) and
+              (n.FName^=senc) then
+            begin
+              if n.FLeft<>nil then
+               begin
+                 FRoot:=n.FLeft;
+                 if n.FRight<>nil then
+                  insert_right_bottom(n.FLeft,n.FRight);
+               end
+              else
+               FRoot:=n.FRight;
+              delete:=n;
+              dec(FCount);
+              exit;
+            end;
+         end;
+        delete:=delete_from_tree(n);
+      end;
+
+    function Tdictionary.empty:boolean;
+      var
+        w : integer;
+      begin
+        if assigned(FHashArray) then
+         begin
+           empty:=false;
+           for w:=low(FHashArray^) to high(FHashArray^) do
+            if assigned(FHashArray^[w]) then
+             exit;
+           empty:=true;
+         end
+        else
+         empty:=(FRoot=nil);
+      end;
+
+
+    procedure Tdictionary.foreach(proc2call:TNamedIndexcallback;arg:pointer);
+
+        procedure a(p:TNamedIndexItem;arg:pointer);
+        begin
+          proc2call(p,arg);
+          if assigned(p.FLeft) then
+           a(p.FLeft,arg);
+          if assigned(p.FRight) then
+           a(p.FRight,arg);
+        end;
+
+      var
+        i : integer;
+      begin
+        if assigned(FHashArray) then
+         begin
+           for i:=low(FHashArray^) to high(FHashArray^) do
+            if assigned(FHashArray^[i]) then
+             a(FHashArray^[i],arg);
+         end
+        else
+         if assigned(FRoot) then
+          a(FRoot,arg);
+      end;
+
+
+    procedure Tdictionary.foreach_static(proc2call:TNamedIndexStaticCallback;arg:pointer);
+
+        procedure a(p:TNamedIndexItem;arg:pointer);
+        begin
+          proc2call(p,arg);
+          if assigned(p.FLeft) then
+           a(p.FLeft,arg);
+          if assigned(p.FRight) then
+           a(p.FRight,arg);
+        end;
+
+      var
+        i : integer;
+      begin
+        if assigned(FHashArray) then
+         begin
+           for i:=low(FHashArray^) to high(FHashArray^) do
+            if assigned(FHashArray^[i]) then
+             a(FHashArray^[i],arg);
+         end
+        else
+         if assigned(FRoot) then
+          a(FRoot,arg);
+      end;
+
+
+    function Tdictionary.replace(oldobj,newobj:TNamedIndexItem):boolean;
+      var
+        hp : TNamedIndexItem;
+      begin
+        hp:=nil;
+        Replace:=false;
+        { must be the same name and hash }
+        if (oldobj.FSpeedValue<>newobj.FSpeedValue) or
+           (oldobj.FName^<>newobj.FName^) then
+         exit;
+        { copy tree info }
+        newobj.FLeft:=oldobj.FLeft;
+        newobj.FRight:=oldobj.FRight;
+        { update treeroot }
+        if assigned(FHashArray) then
+         begin
+           hp:=FHashArray^[newobj.FSpeedValue mod hasharraysize];
+           if hp=oldobj then
+            begin
+              FHashArray^[newobj.FSpeedValue mod hasharraysize]:=newobj;
+              hp:=nil;
+            end;
+         end
+        else
+         begin
+           hp:=FRoot;
+           if hp=oldobj then
+            begin
+              FRoot:=newobj;
+              hp:=nil;
+            end;
+         end;
+        { update parent entry }
+        while assigned(hp) do
+         begin
+           { is the node to replace the left or right, then
+             update this node and stop }
+           if hp.FLeft=oldobj then
+            begin
+              hp.FLeft:=newobj;
+              break;
+            end;
+           if hp.FRight=oldobj then
+            begin
+              hp.FRight:=newobj;
+              break;
+            end;
+           { First check SpeedValue, to allow a fast insert }
+           if hp.SpeedValue>oldobj.SpeedValue then
+            hp:=hp.FRight
+           else
+            if hp.SpeedValue<oldobj.SpeedValue then
+             hp:=hp.FLeft
+           else
+            begin
+              if (hp.FName^=oldobj.FName^) then
+               begin
+                 { this can never happend, return error }
+                 exit;
+               end
+              else
+               if oldobj.FName^>hp.FName^ then
+                hp:=hp.FLeft
+              else
+               hp:=hp.FRight;
+            end;
+         end;
+        Replace:=true;
+      end;
+
+
+    function Tdictionary.insert(obj:TNamedIndexItem):TNamedIndexItem;
+      begin
+        inc(FCount);
+        if assigned(FHashArray) then
+          insert:=insertNode(obj,FHashArray^[obj.SpeedValue mod hasharraysize])
+        else
+          insert:=insertNode(obj,FRoot);
+      end;
+
+
+    function tdictionary.insertNode(NewNode:TNamedIndexItem;var currNode:TNamedIndexItem):TNamedIndexItem;
+      begin
+        if currNode=nil then
+         begin
+           currNode:=NewNode;
+           insertNode:=NewNode;
+         end
+        { First check SpeedValue, to allow a fast insert }
+        else
+         if currNode.SpeedValue>NewNode.SpeedValue then
+          insertNode:=insertNode(NewNode,currNode.FRight)
+        else
+         if currNode.SpeedValue<NewNode.SpeedValue then
+          insertNode:=insertNode(NewNode,currNode.FLeft)
+        else
+         begin
+           if currNode.FName^>NewNode.FName^ then
+            insertNode:=insertNode(NewNode,currNode.FRight)
+           else
+            if currNode.FName^<NewNode.FName^ then
+             insertNode:=insertNode(NewNode,currNode.FLeft)
+           else
+            begin
+              if (delete_doubles) and
+                 assigned(currNode) then
+                begin
+                  NewNode.FLeft:=currNode.FLeft;
+                  NewNode.FRight:=currNode.FRight;
+                  if delete_doubles then
+                    begin
+                      currnode.FLeft:=nil;
+                      currnode.FRight:=nil;
+                      currnode.free;
+                    end;
+                  currNode:=NewNode;
+                  insertNode:=NewNode;
+                end
+              else
+               insertNode:=currNode;
+             end;
+         end;
+      end;
+
+
+    procedure tdictionary.inserttree(currtree,currroot:TNamedIndexItem);
+      begin
+        if assigned(currtree) then
+         begin
+           inserttree(currtree.FLeft,currroot);
+           inserttree(currtree.FRight,currroot);
+           currtree.FRight:=nil;
+           currtree.FLeft:=nil;
+           insertNode(currtree,currroot);
+         end;
+      end;
+
+
+    function tdictionary.rename(const olds,News : string):TNamedIndexItem;
+      var
+        spdval : cardinal;
+        lasthp,
+        hp,hp2,hp3 : TNamedIndexItem;
+      {$ifdef compress}
+        oldsenc,newsenc:string;
+      {$else}
+        oldsenc:string absolute olds;
+        newsenc:string absolute news;
+      {$endif}
+      begin
+      {$ifdef compress}
+        oldsenc:=minilzw_encode(olds);
+        newsenc:=minilzw_encode(news);
+      {$endif}
+        spdval:=GetSpeedValue(olds);
+        if assigned(FHashArray) then
+         hp:=FHashArray^[spdval mod hasharraysize]
+        else
+         hp:=FRoot;
+        lasthp:=nil;
+        while assigned(hp) do
+          begin
+            if spdval>hp.SpeedValue then
+             begin
+               lasthp:=hp;
+               hp:=hp.FLeft
+             end
+            else
+             if spdval<hp.SpeedValue then
+              begin
+                lasthp:=hp;
+                hp:=hp.FRight
+              end
+            else
+             begin
+               if (hp.FName^=oldsenc) then
+                begin
+                  { Get in hp2 the replacer for the root or hasharr }
+                  hp2:=hp.FLeft;
+                  hp3:=hp.FRight;
+                  if not assigned(hp2) then
+                   begin
+                     hp2:=hp.FRight;
+                     hp3:=hp.FLeft;
+                   end;
+                  { remove entry from the tree }
+                  if assigned(lasthp) then
+                   begin
+                     if lasthp.FLeft=hp then
+                      lasthp.FLeft:=hp2
+                     else
+                      lasthp.FRight:=hp2;
+                   end
+                  else
+                   begin
+                     if assigned(FHashArray) then
+                      FHashArray^[spdval mod hasharraysize]:=hp2
+                     else
+                      FRoot:=hp2;
+                   end;
+                  { reinsert the hp3 in the tree from hp2 }
+                  inserttree(hp3,hp2);
+                  { reset Node with New values }
+                  hp.FLeft:=nil;
+                  hp.FRight:=nil;
+                  stringdispose(hp.FName);
+                  hp.FName:=stringdup(newsenc);
+                  hp.FSpeedValue:=GetSpeedValue(news);
+                  { reinsert }
+                  if assigned(FHashArray) then
+                   rename:=insertNode(hp,FHashArray^[hp.SpeedValue mod hasharraysize])
+                  else
+                   rename:=insertNode(hp,FRoot);
+                  exit;
+                end
+               else
+                if oldsenc>hp.FName^ then
+                 begin
+                   lasthp:=hp;
+                   hp:=hp.FLeft
+                 end
+                else
+                 begin
+                   lasthp:=hp;
+                   hp:=hp.FRight;
+                 end;
+             end;
+          end;
+        result := nil;
+      end;
+
+
+    function Tdictionary.search(const s:string):TNamedIndexItem;
+
+    begin
+      search:=speedsearch(s,getspeedvalue(s));
+    end;
+
+
+    function Tdictionary.speedsearch(const s:string;SpeedValue:cardinal):TNamedIndexItem;
+      var
+        NewNode:TNamedIndexItem;
+      {$ifdef compress}
+        decn:string;
+      {$endif}
+      begin
+        if assigned(FHashArray) then
+         NewNode:=FHashArray^[SpeedValue mod hasharraysize]
+        else
+         NewNode:=FRoot;
+        while assigned(NewNode) do
+         begin
+           if SpeedValue>NewNode.SpeedValue then
+            NewNode:=NewNode.FLeft
+           else
+            if SpeedValue<NewNode.SpeedValue then
+             NewNode:=NewNode.FRight
+           else
+            begin
+            {$ifdef compress}
+              decn:=minilzw_decode(newnode.fname^);
+              if (decn=s) then
+               begin
+                 speedsearch:=NewNode;
+                 exit;
+               end
+              else
+               if s>decn then
+                NewNode:=NewNode.FLeft
+              else
+               NewNode:=NewNode.FRight;
+            {$else}
+              if (NewNode.FName^=s) then
+               begin
+                 speedsearch:=NewNode;
+                 exit;
+               end
+              else
+               if s>NewNode.FName^ then
+                NewNode:=NewNode.FLeft
+              else
+               NewNode:=NewNode.FRight;
+            {$endif}
+            end;
+         end;
+        speedsearch:=nil;
+      end;
+
+{****************************************************************************
+                               tsingleList
+ ****************************************************************************}
+
+    constructor tsingleList.create;
+      begin
+        First:=nil;
+        last:=nil;
+      end;
+
+
+    procedure tsingleList.reset;
+      begin
+        First:=nil;
+        last:=nil;
+      end;
+
+
+    procedure tsingleList.clear;
+      var
+        hp,hp2 : TNamedIndexItem;
+      begin
+        hp:=First;
+        while assigned(hp) do
+         begin
+           hp2:=hp;
+           hp:=hp.FListNext;
+           hp2.free;
+         end;
+        First:=nil;
+        last:=nil;
+      end;
+
+
+    procedure tsingleList.insert(p:TNamedIndexItem);
+      begin
+        if not assigned(First) then
+         First:=p
+        else
+         last.FListNext:=p;
+        last:=p;
+        p.FListNext:=nil;
+      end;
+
+
+{****************************************************************************
+                               tindexarray
+ ****************************************************************************}
+
+    constructor tindexarray.create(Agrowsize:integer);
+      begin
+        growsize:=Agrowsize;
+        size:=0;
+        count:=0;
+        data:=nil;
+        First:=nil;
+        noclear:=false;
+      end;
+
+
+    destructor tindexarray.destroy;
+      begin
+        if assigned(data) then
+          begin
+             if not noclear then
+              clear;
+             freemem(data);
+             data:=nil;
+          end;
+      end;
+
+
+    function tindexarray.search(nr:integer):TNamedIndexItem;
+      begin
+        if nr<=count then
+         search:=data^[nr]
+        else
+         search:=nil;
+      end;
+
+
+    procedure tindexarray.clear;
+      var
+        i : integer;
+      begin
+        for i:=1 to count do
+         if assigned(data^[i]) then
+          begin
+            data^[i].free;
+            data^[i]:=nil;
+          end;
+        count:=0;
+        First:=nil;
+      end;
+
+
+    procedure tindexarray.foreach(proc2call : Tnamedindexcallback;arg:pointer);
+      var
+        i : integer;
+      begin
+        for i:=1 to count do
+         if assigned(data^[i]) then
+          proc2call(data^[i],arg);
+      end;
+
+
+    procedure tindexarray.foreach_static(proc2call : Tnamedindexstaticcallback;arg:pointer);
+      var
+        i : integer;
+      begin
+        for i:=1 to count do
+         if assigned(data^[i]) then
+          proc2call(data^[i],arg);
+      end;
+
+
+    procedure tindexarray.grow(gsize:integer);
+      var
+        osize : integer;
+      begin
+        osize:=size;
+        inc(size,gsize);
+        reallocmem(data,size*sizeof(pointer));
+        fillchar(data^[osize+1],gsize*sizeof(pointer),0);
+      end;
+
+
+    procedure tindexarray.deleteindex(p:TNamedIndexItem);
+      var
+        i : integer;
+      begin
+        i:=p.Findexnr;
+        { update counter }
+        if i=count then
+         dec(count);
+        { update Linked List }
+        while (i>0) do
+         begin
+           dec(i);
+           if (i>0) and assigned(data^[i]) then
+            begin
+              data^[i].FindexNext:=data^[p.Findexnr].FindexNext;
+              break;
+            end;
+         end;
+        if i=0 then
+         First:=p.FindexNext;
+        data^[p.FIndexnr]:=nil;
+        { clear entry }
+        p.FIndexnr:=-1;
+        p.FIndexNext:=nil;
+      end;
+
+
+    procedure tindexarray.delete(var p:TNamedIndexItem);
+      begin
+        deleteindex(p);
+        p.free;
+        p:=nil;
+      end;
+
+
+    procedure tindexarray.insert(p:TNamedIndexItem);
+      var
+        i  : integer;
+      begin
+        if p.FIndexnr=-1 then
+         begin
+           inc(count);
+           p.FIndexnr:=count;
+         end;
+        if p.FIndexnr>count then
+         count:=p.FIndexnr;
+        if count>size then
+         grow(((count div growsize)+1)*growsize);
+        Assert(not assigned(data^[p.FIndexnr]) or (p=data^[p.FIndexnr]));
+        data^[p.FIndexnr]:=p;
+        { update Linked List backward }
+        i:=p.FIndexnr;
+        while (i>0) do
+         begin
+           dec(i);
+           if (i>0) and assigned(data^[i]) then
+            begin
+              data^[i].FIndexNext:=p;
+              break;
+            end;
+         end;
+        if i=0 then
+         First:=p;
+        { update Linked List forward }
+        i:=p.FIndexnr;
+        while (i<=count) do
+         begin
+           inc(i);
+           if (i<=count) and assigned(data^[i]) then
+            begin
+              p.FIndexNext:=data^[i];
+              exit;
+            end;
+         end;
+        if i>count then
+         p.FIndexNext:=nil;
+      end;
+
+
+    procedure tindexarray.replace(oldp,newp:TNamedIndexItem);
+      var
+        i : integer;
+      begin
+        newp.FIndexnr:=oldp.FIndexnr;
+        newp.FIndexNext:=oldp.FIndexNext;
+        data^[newp.FIndexnr]:=newp;
+        if First=oldp then
+          First:=newp;
+        { update Linked List backward }
+        i:=newp.FIndexnr;
+        while (i>0) do
+         begin
+           dec(i);
+           if (i>0) and assigned(data^[i]) then
+            begin
+              data^[i].FIndexNext:=newp;
+              break;
+            end;
+         end;
+      end;
+
+
+{****************************************************************************
+                                tdynamicarray
+****************************************************************************}
+
+    constructor tdynamicarray.create(Ablocksize:integer);
+      begin
+        FPosn:=0;
+        FPosnblock:=nil;
+        FFirstblock:=nil;
+        FLastblock:=nil;
+        Fblocksize:=Ablocksize;
+        grow;
+      end;
+
+
+    destructor tdynamicarray.destroy;
+      var
+        hp : pdynamicblock;
+      begin
+        while assigned(FFirstblock) do
+         begin
+           hp:=FFirstblock;
+           FFirstblock:=FFirstblock^.Next;
+           Freemem(hp);
+         end;
+      end;
+
+
+    function  tdynamicarray.size:integer;
+      begin
+        if assigned(FLastblock) then
+         size:=FLastblock^.pos+FLastblock^.used
+        else
+         size:=0;
+      end;
+
+
+    procedure tdynamicarray.reset;
+      var
+        hp : pdynamicblock;
+      begin
+        while assigned(FFirstblock) do
+         begin
+           hp:=FFirstblock;
+           FFirstblock:=FFirstblock^.Next;
+           Freemem(hp);
+         end;
+        FPosn:=0;
+        FPosnblock:=nil;
+        FFirstblock:=nil;
+        FLastblock:=nil;
+        grow;
+      end;
+
+
+    procedure tdynamicarray.grow;
+      var
+        nblock : pdynamicblock;
+      begin
+        Getmem(nblock,blocksize+dynamicblockbasesize);
+        if not assigned(FFirstblock) then
+         begin
+           FFirstblock:=nblock;
+           FPosnblock:=nblock;
+           nblock^.pos:=0;
+         end
+        else
+         begin
+           FLastblock^.Next:=nblock;
+           nblock^.pos:=FLastblock^.pos+FLastblock^.used;
+         end;
+        nblock^.used:=0;
+        nblock^.Next:=nil;
+        fillchar(nblock^.data,blocksize,0);
+        FLastblock:=nblock;
+      end;
+
+
+    procedure tdynamicarray.align(i:integer);
+      var
+        j : integer;
+      begin
+        j:=(FPosn mod i);
+        if j<>0 then
+         begin
+           j:=i-j;
+           if FPosnblock^.used+j>blocksize then
+            begin
+              dec(j,blocksize-FPosnblock^.used);
+              FPosnblock^.used:=blocksize;
+              grow;
+              FPosnblock:=FLastblock;
+            end;
+           inc(FPosnblock^.used,j);
+           inc(FPosn,j);
+         end;
+      end;
+
+
+    procedure tdynamicarray.seek(i:integer);
+      begin
+        if (i<FPosnblock^.pos) or (i>=FPosnblock^.pos+blocksize) then
+         begin
+           { set FPosnblock correct if the size is bigger then
+             the current block }
+           if FPosnblock^.pos>i then
+            FPosnblock:=FFirstblock;
+           while assigned(FPosnblock) do
+            begin
+              if FPosnblock^.pos+blocksize>i then
+               break;
+              FPosnblock:=FPosnblock^.Next;
+            end;
+           { not found ? then increase blocks }
+           if not assigned(FPosnblock) then
+            begin
+              repeat
+                { the current FLastblock is now also fully used }
+                FLastblock^.used:=blocksize;
+                grow;
+                FPosnblock:=FLastblock;
+              until FPosnblock^.pos+blocksize>=i;
+            end;
+         end;
+        FPosn:=i;
+        if FPosn mod blocksize>FPosnblock^.used then
+         FPosnblock^.used:=FPosn mod blocksize;
+      end;
+
+
+    procedure tdynamicarray.write(const d;len:integer);
+      var
+        p : pchar;
+        i,j : integer;
+      begin
+        p:=pchar(@d);
+        while (len>0) do
+         begin
+           i:=FPosn mod blocksize;
+           if i+len>=blocksize then
+            begin
+              j:=blocksize-i;
+              move(p^,FPosnblock^.data[i],j);
+              inc(p,j);
+              inc(FPosn,j);
+              dec(len,j);
+              FPosnblock^.used:=blocksize;
+              if assigned(FPosnblock^.Next) then
+               FPosnblock:=FPosnblock^.Next
+              else
+               begin
+                 grow;
+                 FPosnblock:=FLastblock;
+               end;
+            end
+           else
+            begin
+              move(p^,FPosnblock^.data[i],len);
+              inc(p,len);
+              inc(FPosn,len);
+              i:=FPosn mod blocksize;
+              if i>FPosnblock^.used then
+               FPosnblock^.used:=i;
+              len:=0;
+            end;
+         end;
+      end;
+
+
+    procedure tdynamicarray.writestr(const s:string);
+      begin
+        write(s[1],length(s));
+      end;
+
+
+    function tdynamicarray.read(var d;len:integer):integer;
+      var
+        p : pchar;
+        i,j,res : integer;
+      begin
+        res:=0;
+        p:=pchar(@d);
+        while (len>0) do
+         begin
+           i:=FPosn mod blocksize;
+           if i+len>=FPosnblock^.used then
+            begin
+              j:=FPosnblock^.used-i;
+              move(FPosnblock^.data[i],p^,j);
+              inc(p,j);
+              inc(FPosn,j);
+              inc(res,j);
+              dec(len,j);
+              if assigned(FPosnblock^.Next) then
+               FPosnblock:=FPosnblock^.Next
+              else
+               break;
+            end
+           else
+            begin
+              move(FPosnblock^.data[i],p^,len);
+              inc(p,len);
+              inc(FPosn,len);
+              inc(res,len);
+              len:=0;
+            end;
+         end;
+        read:=res;
+      end;
+
+
+    procedure tdynamicarray.readstream(f:TCStream;maxlen:longint);
+      var
+        i,left : integer;
+      begin
+        if maxlen=-1 then
+         maxlen:=maxlongint;
+        repeat
+          left:=blocksize-FPosnblock^.used;
+          if left>maxlen then
+           left:=maxlen;
+          i:=f.Read(FPosnblock^.data[FPosnblock^.used],left);
+          dec(maxlen,i);
+          inc(FPosnblock^.used,i);
+          if FPosnblock^.used=blocksize then
+           begin
+             if assigned(FPosnblock^.Next) then
+              FPosnblock:=FPosnblock^.Next
+             else
+              begin
+                grow;
+                FPosnblock:=FLastblock;
+              end;
+           end;
+        until (i<left) or (maxlen=0);
+      end;
+
+
+    procedure tdynamicarray.writestream(f:TCStream);
+      var
+        hp : pdynamicblock;
+      begin
+        hp:=FFirstblock;
+        while assigned(hp) do
+         begin
+           f.Write(hp^.data,hp^.used);
+           hp:=hp^.Next;
+         end;
+      end;
+
+
+end.

+ 791 - 0
compiler/cg64f32.pas

@@ -0,0 +1,791 @@
+{
+    Copyright (c) 1998-2002 by Florian Klaempfl
+    Member of the Free Pascal development team
+
+    This unit implements the code generation for 64 bit int
+    arithmethics on 32 bit processors
+
+    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 implements the code generation for 64 bit int arithmethics on
+   32 bit processors.
+}
+unit cg64f32;
+
+  {$i fpcdefs.inc}
+
+  interface
+
+    uses
+       aasmbase,aasmtai,aasmcpu,
+       cpubase,cpupara,
+       cgbase,cgobj,parabase,cgutils,
+       symtype
+       ;
+
+    type
+      {# Defines all the methods required on 32-bit processors
+         to handle 64-bit integers.
+      }
+      tcg64f32 = class(tcg64)
+        procedure a_load64_const_ref(list : taasmoutput;value : int64;const ref : treference);override;
+        procedure a_load64_reg_ref(list : taasmoutput;reg : tregister64;const ref : treference);override;
+        procedure a_load64_ref_reg(list : taasmoutput;const ref : treference;reg : tregister64);override;
+        procedure a_load64_reg_reg(list : taasmoutput;regsrc,regdst : tregister64);override;
+        procedure a_load64_const_reg(list : taasmoutput;value: int64;reg : tregister64);override;
+        procedure a_load64_loc_reg(list : taasmoutput;const l : tlocation;reg : tregister64);override;
+        procedure a_load64_loc_ref(list : taasmoutput;const l : tlocation;const ref : treference);override;
+        procedure a_load64_const_loc(list : taasmoutput;value : int64;const l : tlocation);override;
+        procedure a_load64_reg_loc(list : taasmoutput;reg : tregister64;const l : tlocation);override;
+
+        procedure a_load64high_reg_ref(list : taasmoutput;reg : tregister;const ref : treference);override;
+        procedure a_load64low_reg_ref(list : taasmoutput;reg : tregister;const ref : treference);override;
+        procedure a_load64high_ref_reg(list : taasmoutput;const ref : treference;reg : tregister);override;
+        procedure a_load64low_ref_reg(list : taasmoutput;const ref : treference;reg : tregister);override;
+        procedure a_load64high_loc_reg(list : taasmoutput;const l : tlocation;reg : tregister);override;
+        procedure a_load64low_loc_reg(list : taasmoutput;const l : tlocation;reg : tregister);override;
+
+        procedure a_op64_ref_reg(list : taasmoutput;op:TOpCG;size : tcgsize;const ref : treference;reg : tregister64);override;
+        procedure a_op64_reg_ref(list : taasmoutput;op:TOpCG;size : tcgsize;reg : tregister64; const ref: treference);override;
+        procedure a_op64_const_loc(list : taasmoutput;op:TOpCG;size : tcgsize;value : int64;const l: tlocation);override;
+        procedure a_op64_reg_loc(list : taasmoutput;op:TOpCG;size : tcgsize;reg : tregister64;const l : tlocation);override;
+        procedure a_op64_loc_reg(list : taasmoutput;op:TOpCG;size : tcgsize;const l : tlocation;reg : tregister64);override;
+        procedure a_op64_const_ref(list : taasmoutput;op:TOpCG;size : tcgsize;value : int64;const ref : treference);override;
+
+        procedure a_param64_reg(list : taasmoutput;reg : tregister64;const paraloc : tcgpara);override;
+        procedure a_param64_const(list : taasmoutput;value : int64;const paraloc : tcgpara);override;
+        procedure a_param64_ref(list : taasmoutput;const r : treference;const paraloc : tcgpara);override;
+        procedure a_param64_loc(list : taasmoutput;const l : tlocation;const paraloc : tcgpara);override;
+
+        {# This routine tries to optimize the a_op64_const_reg operation, by
+           removing superfluous opcodes. Returns TRUE if normal processing
+           must continue in op64_const_reg, otherwise, everything is processed
+           entirely in this routine, by emitting the appropriate 32-bit opcodes.
+        }
+        function optimize64_op_const_reg(list: taasmoutput; var op: topcg; var a : int64; var reg: tregister64): boolean;override;
+
+        procedure g_rangecheck64(list: taasmoutput; const l:tlocation;fromdef,todef: tdef); override;
+      end;
+
+    {# Creates a tregister64 record from 2 32 Bit registers. }
+    function joinreg64(reglo,reghi : tregister) : tregister64;
+
+  implementation
+
+    uses
+       globtype,systems,
+       verbose,
+       symbase,symconst,symdef,defutil,paramgr;
+
+{****************************************************************************
+                                     Helpers
+****************************************************************************}
+
+    function joinreg64(reglo,reghi : tregister) : tregister64;
+      begin
+         result.reglo:=reglo;
+         result.reghi:=reghi;
+      end;
+
+
+    procedure swap64(var q : int64);
+      begin
+         q:=(int64(lo(q)) shl 32) or hi(q);
+      end;
+
+
+    procedure splitparaloc64(const cgpara:tcgpara;var cgparalo,cgparahi:tcgpara);
+      var
+        paraloclo,
+        paralochi : pcgparalocation;
+      begin
+        if not(cgpara.size in [OS_64,OS_S64]) then
+          internalerror(200408231);
+        if not assigned(cgpara.location) then
+          internalerror(200408201);
+        { init lo/hi para }
+        cgparahi.reset;
+        if cgpara.size=OS_S64 then
+          cgparahi.size:=OS_S32
+        else
+          cgparahi.size:=OS_32;
+        cgparahi.intsize:=4;
+        cgparahi.alignment:=cgpara.alignment;
+        paralochi:=cgparahi.add_location;
+        cgparalo.reset;
+        cgparalo.size:=OS_32;
+        cgparalo.intsize:=4;
+        cgparalo.alignment:=cgpara.alignment;
+        paraloclo:=cgparalo.add_location;
+        { 2 parameter fields? }
+        if assigned(cgpara.location^.next) then
+          begin
+            { Order for multiple locations is always
+                paraloc^ -> high
+                paraloc^.next -> low }
+            if (target_info.endian=ENDIAN_BIG) then
+              begin
+                { paraloc^ -> high
+                  paraloc^.next -> low }
+                move(cgpara.location^,paralochi^,sizeof(paralochi^));
+                move(cgpara.location^.next^,paraloclo^,sizeof(paraloclo^));
+              end
+            else
+              begin
+                { paraloc^ -> low
+                  paraloc^.next -> high }
+                move(cgpara.location^,paraloclo^,sizeof(paraloclo^));
+                move(cgpara.location^.next^,paralochi^,sizeof(paralochi^));
+              end;
+          end
+        else
+          begin
+            { single parameter, this can only be in memory }
+            if cgpara.location^.loc<>LOC_REFERENCE then
+              internalerror(200408282);
+            move(cgpara.location^,paraloclo^,sizeof(paraloclo^));
+            move(cgpara.location^,paralochi^,sizeof(paralochi^));
+            { for big endian low is at +4, for little endian high }
+            if target_info.endian = endian_big then
+              inc(cgparalo.location^.reference.offset,4)
+            else
+              inc(cgparahi.location^.reference.offset,4);
+          end;
+        { fix size }
+        paraloclo^.size:=cgparalo.size;
+        paraloclo^.next:=nil;
+        paralochi^.size:=cgparahi.size;
+        paralochi^.next:=nil;
+      end;
+
+
+{****************************************************************************
+                                   TCG64F32
+****************************************************************************}
+
+    procedure tcg64f32.a_load64_reg_ref(list : taasmoutput;reg : tregister64;const ref : treference);
+      var
+        tmpreg: tregister;
+        tmpref: treference;
+      begin
+        if target_info.endian = endian_big then
+          begin
+            tmpreg:=reg.reglo;
+            reg.reglo:=reg.reghi;
+            reg.reghi:=tmpreg;
+          end;
+        cg.a_load_reg_ref(list,OS_32,OS_32,reg.reglo,ref);
+        tmpref := ref;
+        inc(tmpref.offset,4);
+        cg.a_load_reg_ref(list,OS_32,OS_32,reg.reghi,tmpref);
+      end;
+
+
+    procedure tcg64f32.a_load64_const_ref(list : taasmoutput;value : int64;const ref : treference);
+      var
+        tmpref: treference;
+      begin
+        if target_info.endian = endian_big then
+          swap64(value);
+        cg.a_load_const_ref(list,OS_32,aint(lo(value)),ref);
+        tmpref := ref;
+        inc(tmpref.offset,4);
+        cg.a_load_const_ref(list,OS_32,aint(hi(value)),tmpref);
+      end;
+
+
+    procedure tcg64f32.a_load64_ref_reg(list : taasmoutput;const ref : treference;reg : tregister64);
+      var
+        tmpreg: tregister;
+        tmpref: treference;
+      begin
+        if target_info.endian = endian_big then
+          begin
+            tmpreg := reg.reglo;
+            reg.reglo := reg.reghi;
+            reg.reghi := tmpreg;
+          end;
+        tmpref := ref;
+        if (tmpref.base=reg.reglo) then
+         begin
+           tmpreg:=cg.getaddressregister(list);
+           cg.a_load_reg_reg(list,OS_ADDR,OS_ADDR,tmpref.base,tmpreg);
+           tmpref.base:=tmpreg;
+         end
+        else
+         { this works only for the i386, thus the i386 needs to override  }
+         { this method and this method must be replaced by a more generic }
+         { implementation FK                                              }
+         if (tmpref.index=reg.reglo) then
+          begin
+            tmpreg:=cg.getaddressregister(list);
+            cg.a_load_reg_reg(list,OS_ADDR,OS_ADDR,tmpref.index,tmpreg);
+            tmpref.index:=tmpreg;
+          end;
+        cg.a_load_ref_reg(list,OS_32,OS_32,tmpref,reg.reglo);
+        inc(tmpref.offset,4);
+        cg.a_load_ref_reg(list,OS_32,OS_32,tmpref,reg.reghi);
+      end;
+
+
+    procedure tcg64f32.a_load64_reg_reg(list : taasmoutput;regsrc,regdst : tregister64);
+
+      begin
+        cg.a_load_reg_reg(list,OS_32,OS_32,regsrc.reglo,regdst.reglo);
+        cg.a_load_reg_reg(list,OS_32,OS_32,regsrc.reghi,regdst.reghi);
+      end;
+
+
+    procedure tcg64f32.a_load64_const_reg(list : taasmoutput;value : int64;reg : tregister64);
+
+      begin
+        cg.a_load_const_reg(list,OS_32,aint(lo(value)),reg.reglo);
+        cg.a_load_const_reg(list,OS_32,aint(hi(value)),reg.reghi);
+      end;
+
+
+    procedure tcg64f32.a_load64_loc_reg(list : taasmoutput;const l : tlocation;reg : tregister64);
+
+      begin
+        case l.loc of
+          LOC_REFERENCE, LOC_CREFERENCE:
+            a_load64_ref_reg(list,l.reference,reg);
+          LOC_REGISTER,LOC_CREGISTER:
+            a_load64_reg_reg(list,l.register64,reg);
+          LOC_CONSTANT :
+            a_load64_const_reg(list,l.value64,reg);
+          else
+            internalerror(200112292);
+        end;
+      end;
+
+
+    procedure tcg64f32.a_load64_loc_ref(list : taasmoutput;const l : tlocation;const ref : treference);
+      begin
+        case l.loc of
+          LOC_REGISTER,LOC_CREGISTER:
+            a_load64_reg_ref(list,l.register64,ref);
+          LOC_CONSTANT :
+            a_load64_const_ref(list,l.value64,ref);
+          else
+            internalerror(200203288);
+        end;
+      end;
+
+
+    procedure tcg64f32.a_load64_const_loc(list : taasmoutput;value : int64;const l : tlocation);
+
+      begin
+        case l.loc of
+          LOC_REFERENCE, LOC_CREFERENCE:
+            a_load64_const_ref(list,value,l.reference);
+          LOC_REGISTER,LOC_CREGISTER:
+            a_load64_const_reg(list,value,l.register64);
+          else
+            internalerror(200112293);
+        end;
+      end;
+
+
+    procedure tcg64f32.a_load64_reg_loc(list : taasmoutput;reg : tregister64;const l : tlocation);
+
+      begin
+        case l.loc of
+          LOC_REFERENCE, LOC_CREFERENCE:
+            a_load64_reg_ref(list,reg,l.reference);
+          LOC_REGISTER,LOC_CREGISTER:
+            a_load64_reg_reg(list,reg,l.register64);
+          else
+            internalerror(200112293);
+        end;
+      end;
+
+
+    procedure tcg64f32.a_load64high_reg_ref(list : taasmoutput;reg : tregister;const ref : treference);
+      var
+        tmpref: treference;
+      begin
+        if target_info.endian = endian_big then
+          cg.a_load_reg_ref(list,OS_32,OS_32,reg,ref)
+        else
+          begin
+            tmpref := ref;
+            inc(tmpref.offset,4);
+            cg.a_load_reg_ref(list,OS_32,OS_32,reg,tmpref)
+          end;
+      end;
+
+    procedure tcg64f32.a_load64low_reg_ref(list : taasmoutput;reg : tregister;const ref : treference);
+      var
+        tmpref: treference;
+      begin
+        if target_info.endian = endian_little then
+          cg.a_load_reg_ref(list,OS_32,OS_32,reg,ref)
+        else
+          begin
+            tmpref := ref;
+            inc(tmpref.offset,4);
+            cg.a_load_reg_ref(list,OS_32,OS_32,reg,tmpref)
+          end;
+      end;
+
+
+    procedure tcg64f32.a_load64high_ref_reg(list : taasmoutput;const ref : treference;reg : tregister);
+      var
+        tmpref: treference;
+      begin
+        if target_info.endian = endian_big then
+          cg.a_load_ref_reg(list,OS_32,OS_32,ref,reg)
+        else
+          begin
+            tmpref := ref;
+            inc(tmpref.offset,4);
+            cg.a_load_ref_reg(list,OS_32,OS_32,tmpref,reg)
+          end;
+      end;
+
+
+    procedure tcg64f32.a_load64low_ref_reg(list : taasmoutput;const ref : treference;reg : tregister);
+      var
+        tmpref: treference;
+      begin
+        if target_info.endian = endian_little then
+          cg.a_load_ref_reg(list,OS_32,OS_32,ref,reg)
+        else
+          begin
+            tmpref := ref;
+            inc(tmpref.offset,4);
+            cg.a_load_ref_reg(list,OS_32,OS_32,tmpref,reg)
+          end;
+      end;
+
+
+    procedure tcg64f32.a_load64low_loc_reg(list : taasmoutput;const l : tlocation;reg : tregister);
+      begin
+        case l.loc of
+          LOC_REFERENCE,
+          LOC_CREFERENCE :
+            a_load64low_ref_reg(list,l.reference,reg);
+          LOC_REGISTER,
+          LOC_CREGISTER :
+            cg.a_load_reg_reg(list,OS_32,OS_32,l.register64.reglo,reg);
+          LOC_CONSTANT :
+            cg.a_load_const_reg(list,OS_32,aint(lo(l.value64)),reg);
+          else
+            internalerror(200203244);
+        end;
+      end;
+
+
+    procedure tcg64f32.a_load64high_loc_reg(list : taasmoutput;const l : tlocation;reg : tregister);
+      begin
+        case l.loc of
+          LOC_REFERENCE,
+          LOC_CREFERENCE :
+            a_load64high_ref_reg(list,l.reference,reg);
+          LOC_REGISTER,
+          LOC_CREGISTER :
+            cg.a_load_reg_reg(list,OS_32,OS_32,l.register64.reghi,reg);
+          LOC_CONSTANT :
+            cg.a_load_const_reg(list,OS_32,hi(l.value64),reg);
+          else
+            internalerror(200203244);
+        end;
+      end;
+
+
+    procedure tcg64f32.a_op64_const_loc(list : taasmoutput;op:TOpCG;size : tcgsize;value : int64;const l: tlocation);
+      begin
+        case l.loc of
+          LOC_REFERENCE, LOC_CREFERENCE:
+            a_op64_const_ref(list,op,size,value,l.reference);
+          LOC_REGISTER,LOC_CREGISTER:
+            a_op64_const_reg(list,op,size,value,l.register64);
+          else
+            internalerror(200203292);
+        end;
+      end;
+
+
+    procedure tcg64f32.a_op64_reg_loc(list : taasmoutput;op:TOpCG;size : tcgsize;reg : tregister64;const l : tlocation);
+      begin
+        case l.loc of
+          LOC_REFERENCE, LOC_CREFERENCE:
+            a_op64_reg_ref(list,op,size,reg,l.reference);
+          LOC_REGISTER,LOC_CREGISTER:
+            a_op64_reg_reg(list,op,size,reg,l.register64);
+          else
+            internalerror(2002032422);
+        end;
+      end;
+
+
+
+    procedure tcg64f32.a_op64_loc_reg(list : taasmoutput;op:TOpCG;size : tcgsize;const l : tlocation;reg : tregister64);
+      begin
+        case l.loc of
+          LOC_REFERENCE, LOC_CREFERENCE:
+            a_op64_ref_reg(list,op,size,l.reference,reg);
+          LOC_REGISTER,LOC_CREGISTER:
+            a_op64_reg_reg(list,op,size,l.register64,reg);
+          LOC_CONSTANT :
+            a_op64_const_reg(list,op,size,l.value64,reg);
+          else
+            internalerror(200203242);
+        end;
+      end;
+
+
+    procedure tcg64f32.a_op64_ref_reg(list : taasmoutput;op:TOpCG;size : tcgsize;const ref : treference;reg : tregister64);
+      var
+        tempreg: tregister64;
+      begin
+        tempreg.reghi:=cg.getintregister(list,OS_32);
+        tempreg.reglo:=cg.getintregister(list,OS_32);
+        a_load64_ref_reg(list,ref,tempreg);
+        a_op64_reg_reg(list,op,size,tempreg,reg);
+      end;
+
+
+    procedure tcg64f32.a_op64_reg_ref(list : taasmoutput;op:TOpCG;size : tcgsize;reg : tregister64; const ref: treference);
+      var
+        tempreg: tregister64;
+      begin
+        tempreg.reghi:=cg.getintregister(list,OS_32);
+        tempreg.reglo:=cg.getintregister(list,OS_32);
+        a_load64_ref_reg(list,ref,tempreg);
+        a_op64_reg_reg(list,op,size,reg,tempreg);
+        a_load64_reg_ref(list,tempreg,ref);
+      end;
+
+
+    procedure tcg64f32.a_op64_const_ref(list : taasmoutput;op:TOpCG;size : tcgsize;value : int64;const ref : treference);
+      var
+        tempreg: tregister64;
+      begin
+        tempreg.reghi:=cg.getintregister(list,OS_32);
+        tempreg.reglo:=cg.getintregister(list,OS_32);
+        a_load64_ref_reg(list,ref,tempreg);
+        a_op64_const_reg(list,op,size,value,tempreg);
+        a_load64_reg_ref(list,tempreg,ref);
+      end;
+
+
+    procedure tcg64f32.a_param64_reg(list : taasmoutput;reg : tregister64;const paraloc : tcgpara);
+      var
+        tmplochi,tmploclo: tcgpara;
+      begin
+        tmploclo.init;
+        tmplochi.init;
+        splitparaloc64(paraloc,tmploclo,tmplochi);
+        { Keep this order of first hi before lo to have
+          the correct push order for i386 }
+        cg.a_param_reg(list,OS_32,reg.reghi,tmplochi);
+        cg.a_param_reg(list,OS_32,reg.reglo,tmploclo);
+        tmploclo.done;
+        tmplochi.done;
+      end;
+
+
+    procedure tcg64f32.a_param64_const(list : taasmoutput;value : int64;const paraloc : tcgpara);
+      var
+        tmplochi,tmploclo: tcgpara;
+      begin
+        tmploclo.init;
+        tmplochi.init;
+        splitparaloc64(paraloc,tmploclo,tmplochi);
+        { Keep this order of first hi before lo to have
+          the correct push order for i386 }
+        cg.a_param_const(list,OS_32,aint(hi(value)),tmplochi);
+        cg.a_param_const(list,OS_32,aint(lo(value)),tmploclo);
+        tmploclo.done;
+        tmplochi.done;
+      end;
+
+
+    procedure tcg64f32.a_param64_ref(list : taasmoutput;const r : treference;const paraloc : tcgpara);
+      var
+        tmprefhi,tmpreflo : treference;
+        tmploclo,tmplochi : tcgpara;
+      begin
+        tmploclo.init;
+        tmplochi.init;
+        splitparaloc64(paraloc,tmploclo,tmplochi);
+        tmprefhi:=r;
+        tmpreflo:=r;
+        if target_info.endian=endian_big then
+          inc(tmpreflo.offset,4)
+        else
+          inc(tmprefhi.offset,4);
+        { Keep this order of first hi before lo to have
+          the correct push order for i386 }
+        cg.a_param_ref(list,OS_32,tmprefhi,tmplochi);
+        cg.a_param_ref(list,OS_32,tmpreflo,tmploclo);
+        tmploclo.done;
+        tmplochi.done;
+      end;
+
+
+    procedure tcg64f32.a_param64_loc(list : taasmoutput;const l:tlocation;const paraloc : tcgpara);
+      begin
+        case l.loc of
+          LOC_REGISTER,
+          LOC_CREGISTER :
+            a_param64_reg(list,l.register64,paraloc);
+          LOC_CONSTANT :
+            a_param64_const(list,l.value64,paraloc);
+          LOC_CREFERENCE,
+          LOC_REFERENCE :
+            a_param64_ref(list,l.reference,paraloc);
+          else
+            internalerror(200203287);
+        end;
+      end;
+
+
+    procedure tcg64f32.g_rangecheck64(list : taasmoutput;const l:tlocation;fromdef,todef:tdef);
+
+      var
+        neglabel,
+        poslabel,
+        endlabel: tasmlabel;
+        hreg   : tregister;
+        hdef   :  torddef;
+        opsize   : tcgsize;
+        oldregisterdef: boolean;
+        from_signed,to_signed: boolean;
+        temploc : tlocation;
+
+      begin
+         from_signed := is_signed(fromdef);
+         to_signed := is_signed(todef);
+
+         if not is_64bit(todef) then
+           begin
+             oldregisterdef := registerdef;
+             registerdef := false;
+
+             { get the high dword in a register }
+             if l.loc in [LOC_REGISTER,LOC_CREGISTER] then
+               begin
+                 hreg := l.register64.reghi;
+               end
+             else
+               begin
+                 hreg:=cg.getintregister(list,OS_32);
+                 a_load64high_ref_reg(list,l.reference,hreg);
+               end;
+             objectlibrary.getjumplabel(poslabel);
+
+             { check high dword, must be 0 (for positive numbers) }
+             cg.a_cmp_const_reg_label(list,OS_32,OC_EQ,0,hreg,poslabel);
+
+             { It can also be $ffffffff, but only for negative numbers }
+             if from_signed and to_signed then
+               begin
+                 objectlibrary.getjumplabel(neglabel);
+                 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');
+
+             { if the high dword = 0, the low dword can be considered a }
+             { simple cardinal                                          }
+             cg.a_label(list,poslabel);
+             hdef:=torddef.create(u32bit,0,$ffffffff);
+
+             location_copy(temploc,l);
+             temploc.size:=OS_32;
+
+             if (temploc.loc in [LOC_REFERENCE,LOC_CREFERENCE]) and
+                (target_info.endian = endian_big) then
+               inc(temploc.reference.offset,4);
+
+             cg.g_rangecheck(list,temploc,hdef,todef);
+             hdef.free;
+
+             if from_signed and to_signed then
+               begin
+                 objectlibrary.getjumplabel(endlabel);
+                 cg.a_jmp_always(list,endlabel);
+                 { if the high dword = $ffffffff, then the low dword (when }
+                 { considered as a longint) must be < 0                    }
+                 cg.a_label(list,neglabel);
+                 if l.loc in [LOC_REGISTER,LOC_CREGISTER] then
+                   begin
+                     hreg := l.register64.reglo;
+                   end
+                 else
+                   begin
+                     hreg:=cg.getintregister(list,OS_32);
+                     a_load64low_ref_reg(list,l.reference,hreg);
+                   end;
+                 { get a new neglabel (JM) }
+                 objectlibrary.getjumplabel(neglabel);
+                 cg.a_cmp_const_reg_label(list,OS_32,OC_LT,0,hreg,neglabel);
+
+                 cg.a_call_name(list,'FPC_RANGEERROR');
+
+                 { if we get here, the 64bit value lies between }
+                 { longint($80000000) and -1 (JM)               }
+                 cg.a_label(list,neglabel);
+                 hdef:=torddef.create(s32bit,longint($80000000),-1);
+                 location_copy(temploc,l);
+                 temploc.size:=OS_32;
+                 cg.g_rangecheck(list,temploc,hdef,todef);
+                 hdef.free;
+                 cg.a_label(list,endlabel);
+               end;
+             registerdef := oldregisterdef;
+           end
+         else
+           { todef = 64bit int }
+           { no 64bit subranges supported, so only a small check is necessary }
+
+           { if both are signed or both are unsigned, no problem! }
+           if (from_signed xor to_signed) and
+              { also not if the fromdef is unsigned and < 64bit, since that will }
+              { always fit in a 64bit int (todef is 64bit)                       }
+              (from_signed or
+               (torddef(fromdef).typ = u64bit)) then
+             begin
+               { in all cases, there is only a problem if the higest bit is set }
+               if l.loc in [LOC_REGISTER,LOC_CREGISTER] then
+                 begin
+                   if is_64bit(fromdef) then
+                     begin
+                       hreg := l.register64.reghi;
+                       opsize := OS_32;
+                     end
+                   else
+                     begin
+                       hreg := l.register;
+                       opsize := def_cgsize(fromdef);
+                     end;
+                 end
+               else
+                 begin
+                   hreg:=cg.getintregister(list,OS_32);
+
+                   opsize := def_cgsize(fromdef);
+                   if opsize in [OS_64,OS_S64] then
+                     a_load64high_ref_reg(list,l.reference,hreg)
+                   else
+                     cg.a_load_ref_reg(list,opsize,OS_32,l.reference,hreg);
+                 end;
+               objectlibrary.getjumplabel(poslabel);
+               cg.a_cmp_const_reg_label(list,opsize,OC_GTE,0,hreg,poslabel);
+
+               cg.a_call_name(list,'FPC_RANGEERROR');
+               cg.a_label(list,poslabel);
+             end;
+      end;
+
+
+    function tcg64f32.optimize64_op_const_reg(list: taasmoutput; var op: topcg; var a : int64; var reg: tregister64): boolean;
+      var
+        lowvalue, highvalue : longint;
+        hreg: tregister;
+      begin
+        lowvalue := longint(a);
+        highvalue:= longint(a shr 32);
+        { assume it will be optimized out }
+        optimize64_op_const_reg := true;
+        case op of
+        OP_ADD:
+           begin
+             if a = 0 then
+                exit;
+           end;
+        OP_AND:
+           begin
+              if lowvalue <> -1 then
+                cg.a_op_const_reg(list,op,OS_32,lowvalue,reg.reglo);
+              if highvalue <> -1 then
+                cg.a_op_const_reg(list,op,OS_32,highvalue,reg.reghi);
+              { already emitted correctly }
+              exit;
+           end;
+        OP_OR:
+           begin
+              if lowvalue <> 0 then
+                cg.a_op_const_reg(list,op,OS_32,lowvalue,reg.reglo);
+              if highvalue <> 0 then
+                cg.a_op_const_reg(list,op,OS_32,highvalue,reg.reghi);
+              { already emitted correctly }
+              exit;
+           end;
+        OP_SUB:
+           begin
+             if a = 0 then
+                exit;
+           end;
+        OP_XOR:
+           begin
+           end;
+        OP_SHL:
+           begin
+             if a = 0 then
+                 exit;
+             { simply clear low-register
+               and shift the rest and swap
+               registers.
+             }
+             if (a > 31) then
+               begin
+                 cg.a_load_const_reg(list,OS_32,0,reg.reglo);
+                 cg.a_op_const_reg(list,OP_SHL,OS_32,a mod 32,reg.reghi);
+                 { swap the registers }
+                 hreg := reg.reghi;
+                 reg.reghi := reg.reglo;
+                 reg.reglo := hreg;
+                 exit;
+               end;
+           end;
+        OP_SHR:
+           begin
+             if a = 0 then exit;
+             { simply clear high-register
+               and shift the rest and swap
+               registers.
+             }
+             if (a > 31) then
+               begin
+                 cg.a_load_const_reg(list,OS_32,0,reg.reghi);
+                 cg.a_op_const_reg(list,OP_SHL,OS_32,a mod 32,reg.reglo);
+                 { swap the registers }
+                 hreg := reg.reghi;
+                 reg.reghi := reg.reglo;
+                 reg.reglo := hreg;
+                 exit;
+               end;
+           end;
+        OP_IMUL,OP_MUL:
+           begin
+             if a = 1 then exit;
+           end;
+        OP_IDIV,OP_DIV:
+            begin
+             if a = 1 then exit;
+            end;
+        else
+           internalerror(20020817);
+        end;
+        optimize64_op_const_reg := false;
+      end;
+
+end.

+ 605 - 0
compiler/cgbase.pas

@@ -0,0 +1,605 @@
+{
+    Copyright (c) 1998-2002 by Florian Klaempfl
+
+    Some basic types and constants for the code 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.
+
+ ****************************************************************************
+}
+{# This unit exports some types which are used across the code generator }
+unit cgbase;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+      globtype,
+      symconst;
+
+    type
+       { Location types where value can be stored }
+       TCGLoc=(
+         LOC_INVALID,      { added for tracking problems}
+         LOC_VOID,         { no value is available }
+         LOC_CONSTANT,     { constant value }
+         LOC_JUMP,         { boolean results only, jump to false or true label }
+         LOC_FLAGS,        { boolean results only, flags are set }
+         LOC_CREFERENCE,   { in memory constant value reference (cannot change) }
+         LOC_REFERENCE,    { in memory value }
+         LOC_REGISTER,     { in a processor register }
+         LOC_CREGISTER,    { Constant register which shouldn't be modified }
+         LOC_FPUREGISTER,  { FPU stack }
+         LOC_CFPUREGISTER, { if it is a FPU register variable on the fpu stack }
+         LOC_MMXREGISTER,  { MMX register }
+         { MMX register variable }
+         LOC_CMMXREGISTER,
+         { multimedia register }
+         LOC_MMREGISTER,
+         { Constant multimedia reg which shouldn't be modified }
+         LOC_CMMREGISTER
+       );
+
+       { since we have only 16bit offsets, we need to be able to specify the high
+         and lower 16 bits of the address of a symbol of up to 64 bit }
+       trefaddr = (
+         addr_no,
+         addr_full,
+         {$IFNDEF POWERPC64}
+         addr_hi,
+         addr_lo,
+         {$ENDIF}
+         addr_pic
+         {$IFDEF POWERPC64}
+         ,
+         addr_low,         // bits 48-63
+         addr_high,        // bits 32-47
+         addr_higher,      // bits 16-31
+         addr_highest,     // bits 00-15
+         addr_higha,       // bits 16-31, adjusted
+         addr_highera,     // bits 32-47, adjusted
+         addr_highesta     // bits 48-63, adjusted
+         {$ENDIF}
+         );
+
+
+       {# Generic opcodes, which must be supported by all processors
+       }
+       topcg =
+       (
+          OP_NONE,
+          OP_ADD,       { simple addition          }
+          OP_AND,       { simple logical and       }
+          OP_DIV,       { simple unsigned division }
+          OP_IDIV,      { simple signed division   }
+          OP_IMUL,      { simple signed multiply   }
+          OP_MUL,       { simple unsigned multiply }
+          OP_NEG,       { simple negate            }
+          OP_NOT,       { simple logical not       }
+          OP_OR,        { simple logical or        }
+          OP_SAR,       { arithmetic shift-right   }
+          OP_SHL,       { logical shift left       }
+          OP_SHR,       { logical shift right      }
+          OP_SUB,       { simple subtraction       }
+          OP_XOR        { simple exclusive or      }
+        );
+
+       {# Generic flag values - used for jump locations }
+       TOpCmp =
+       (
+          OC_NONE,
+          OC_EQ,           { equality comparison              }
+          OC_GT,           { greater than (signed)            }
+          OC_LT,           { less than (signed)               }
+          OC_GTE,          { greater or equal than (signed)   }
+          OC_LTE,          { less or equal than (signed)      }
+          OC_NE,           { not equal                        }
+          OC_BE,           { less or equal than (unsigned)    }
+          OC_B,            { less than (unsigned)             }
+          OC_AE,           { greater or equal than (unsigned) }
+          OC_A             { greater than (unsigned)          }
+        );
+
+       { OS_NO is also used memory references with large data that can
+         not be loaded in a register directly }
+       TCgSize = (OS_NO,
+                 { integer registers }
+                  OS_8,OS_16,OS_32,OS_64,OS_128,OS_S8,OS_S16,OS_S32,OS_S64,OS_S128,
+                 { single,double,extended,comp,float128 }
+                  OS_F32,OS_F64,OS_F80,OS_C64,OS_F128,
+                 { multi-media sizes: split in byte, word, dword, ... }
+                 { entities, then the signed counterparts             }
+                  OS_M8,OS_M16,OS_M32,OS_M64,OS_M128,
+                  OS_MS8,OS_MS16,OS_MS32,OS_MS64,OS_MS128);
+
+      { Register types }
+      TRegisterType = (
+        R_INVALIDREGISTER, { = 0 }
+        R_INTREGISTER,     { = 1 }
+        R_FPUREGISTER,     { = 2 }
+        { used by Intel only }
+        R_MMXREGISTER,     { = 3 }
+        R_MMREGISTER,      { = 4 }
+        R_SPECIALREGISTER, { = 5 }
+        R_ADDRESSREGISTER  { = 6 }
+      );
+
+      { Sub registers }
+      TSubRegister = (
+        R_SUBNONE, { = 0; no sub register possible }
+        R_SUBL,    { = 1; 8 bits, Like AL }
+        R_SUBH,    { = 2; 8 bits, Like AH }
+        R_SUBW,    { = 3; 16 bits, Like AX }
+        R_SUBD,    { = 4; 32 bits, Like EAX }
+        R_SUBQ,    { = 5; 64 bits, Like RAX }
+        { For Sparc floats that use F0:F1 to store doubles }
+        R_SUBFS,   { = 6; Float that allocates 1 FPU register }
+        R_SUBFD,   { = 7; Float that allocates 2 FPU registers }
+        R_SUBFQ,   { = 8; Float that allocates 4 FPU registers }
+        R_SUBMMS,  { = 9; single scalar in multi media register }
+        R_SUBMMD   { = 10; double scalar in multi media register }
+      );
+
+      TSuperRegister = type word;
+
+      {
+        The new register coding:
+
+        SuperRegister   (bits 0..15)
+        Subregister     (bits 16..23)
+        Register type   (bits 24..31)
+
+        TRegister is defined as an enum to make it incompatible
+        with TSuperRegister to avoid mixing them
+      }
+      TRegister = (
+        TRegisterLowEnum := Low(longint),
+        TRegisterHighEnum := High(longint)
+      );
+      TRegisterRec=packed record
+{$ifdef FPC_BIG_ENDIAN}
+         regtype : Tregistertype;
+         subreg  : Tsubregister;
+         supreg  : Tsuperregister;
+{$else FPC_BIG_ENDIAN}
+         supreg  : Tsuperregister;
+         subreg  : Tsubregister;
+         regtype : Tregistertype;
+{$endif FPC_BIG_ENDIAN}
+      end;
+
+      { A type to store register locations for 64 Bit values. }
+{$ifdef cpu64bit}
+      tregister64 = tregister;
+{$else cpu64bit}
+      tregister64 = record
+         reglo,reghi : tregister;
+      end;
+{$endif cpu64bit}
+
+      Tregistermmxset = record
+        reg0,reg1,reg2,reg3:Tregister
+      end;
+
+      { Set type definition for registers }
+      tcpuregisterset = set of byte;
+      tsuperregisterset = array[byte] of set of byte;
+
+      pmmshuffle = ^tmmshuffle;
+
+      { this record describes shuffle operations for mm operations; if a pointer a shuffle record
+        passed to an mm operation is nil, it means that the whole location is moved }
+      tmmshuffle = record
+        { describes how many shuffles are actually described, if len=0 then
+          moving the scalar with index 0 to the scalar with index 0 is meant }
+        len : byte;
+        { lower nibble of each entry of this array describes index of the source data index while
+          the upper nibble describes the destination index }
+        shuffles : array[1..1] of byte;
+      end;
+
+      Tsuperregisterarray=array[0..$ffff] of Tsuperregister;
+      Psuperregisterarray=^Tsuperregisterarray;
+
+      Tsuperregisterworklist=object
+        buflength,
+        buflengthinc,
+        length:word;
+        buf:Psuperregisterarray;
+        constructor init;
+        constructor copyfrom(const x:Tsuperregisterworklist);
+        destructor  done;
+        procedure clear;
+        procedure add(s:tsuperregister);
+        function get:tsuperregister;
+        procedure deleteidx(i:word);
+        function delete(s:tsuperregister):boolean;
+      end;
+      psuperregisterworklist=^tsuperregisterworklist;
+
+    const
+       { alias for easier understanding }
+       R_SSEREGISTER = R_MMREGISTER;
+
+       { 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,
+         { floating point values }
+         4,8,10,8,16,
+         { multimedia values }
+         1,2,4,8,16,1,2,4,8,16);
+
+       tfloat2tcgsize: array[tfloattype] of tcgsize =
+         (OS_F32,OS_F64,OS_F80,OS_C64,OS_C64,OS_F128);
+
+       tcgsize2tfloat: array[OS_F32..OS_C64] of tfloattype =
+         (s32real,s64real,s80real,s64comp);
+
+       { Table to convert tcgsize variables to the correspondending
+         unsigned types }
+       tcgsize2unsigned : array[tcgsize] of tcgsize = (OS_NO,
+          OS_8,OS_16,OS_32,OS_64,OS_128,OS_8,OS_16,OS_32,OS_64,OS_128,
+          OS_F32,OS_F64,OS_F80,OS_C64,OS_F128,
+          OS_M8,OS_M16,OS_M32,OS_M64,OS_M128,OS_M8,OS_M16,OS_M32,
+          OS_M64,OS_M128);
+
+       tcgloc2str : array[TCGLoc] of string[11] = (
+            'LOC_INVALID',
+            'LOC_VOID',
+            'LOC_CONST',
+            'LOC_JUMP',
+            'LOC_FLAGS',
+            'LOC_CREF',
+            'LOC_REF',
+            'LOC_REG',
+            'LOC_CREG',
+            'LOC_FPUREG',
+            'LOC_CFPUREG',
+            'LOC_MMXREG',
+            'LOC_CMMXREG',
+            'LOC_MMREG',
+            'LOC_CMMREG');
+
+    var
+       mms_movescalar : pmmshuffle;
+
+    procedure supregset_reset(var regs:tsuperregisterset;setall:boolean;
+                              maxreg:Tsuperregister);{$ifdef USEINLINE}inline;{$endif}
+    procedure supregset_include(var regs:tsuperregisterset;s:tsuperregister);{$ifdef USEINLINE}inline;{$endif}
+    procedure supregset_exclude(var regs:tsuperregisterset;s:tsuperregister);{$ifdef USEINLINE}inline;{$endif}
+    function supregset_in(const regs:tsuperregisterset;s:tsuperregister):boolean;{$ifdef USEINLINE}inline;{$endif}
+
+    function newreg(rt:tregistertype;sr:tsuperregister;sb:tsubregister):tregister;{$ifdef USEINLINE}inline;{$endif}
+    function getsubreg(r:tregister):tsubregister;{$ifdef USEINLINE}inline;{$endif}
+    function getsupreg(r:tregister):tsuperregister;{$ifdef USEINLINE}inline;{$endif}
+    function getregtype(r:tregister):tregistertype;{$ifdef USEINLINE}inline;{$endif}
+    procedure setsubreg(var r:tregister;sr:tsubregister);{$ifdef USEINLINE}inline;{$endif}
+    procedure setsupreg(var r:tregister;sr:tsuperregister);{$ifdef USEINLINE}inline;{$endif}
+    function generic_regname(r:tregister):string;
+
+    {# From a constant numeric value, return the abstract code generator
+       size.
+    }
+    function int_cgsize(const a: aint): tcgsize;{$ifdef USEINLINE}inline;{$endif}
+
+    { return the inverse condition of opcmp }
+    function inverse_opcmp(opcmp: topcmp): topcmp;{$ifdef USEINLINE}inline;{$endif}
+
+    { return whether op is commutative }
+    function commutativeop(op: topcg): boolean;{$ifdef USEINLINE}inline;{$endif}
+
+    { returns true, if shuffle describes a real shuffle operation and not only a move }
+    function realshuffle(shuffle : pmmshuffle) : boolean;
+
+    { returns true, if the shuffle describes only a move of the scalar at index 0 }
+    function shufflescalar(shuffle : pmmshuffle) : boolean;
+
+    { removes shuffling from shuffle, this means that the destenation index of each shuffle is copied to
+      the source }
+    procedure removeshuffles(var shuffle : tmmshuffle);
+
+implementation
+
+    uses
+      verbose;
+
+{******************************************************************************
+                             tsuperregisterworklist
+******************************************************************************}
+
+    constructor tsuperregisterworklist.init;
+
+    begin
+      length:=0;
+      buflength:=0;
+      buflengthinc:=16;
+      buf:=nil;
+    end;
+
+    constructor Tsuperregisterworklist.copyfrom(const x:Tsuperregisterworklist);
+
+    begin
+      self:=x;
+      if x.buf<>nil then
+        begin
+          getmem(buf,buflength*sizeof(Tsuperregister));
+          move(x.buf^,buf^,length*sizeof(Tsuperregister));
+        end;
+    end;
+
+    destructor tsuperregisterworklist.done;
+
+    begin
+      if assigned(buf) then
+        freemem(buf);
+    end;
+
+
+    procedure tsuperregisterworklist.add(s:tsuperregister);
+
+    begin
+      inc(length);
+      { Need to increase buffer length? }
+      if length>=buflength then
+        begin
+          inc(buflength,buflengthinc);
+          buflengthinc:=buflengthinc*2;
+          if buflengthinc>256 then
+             buflengthinc:=256;
+          reallocmem(buf,buflength*sizeof(Tsuperregister));
+        end;
+      buf^[length-1]:=s;
+    end;
+
+
+    procedure tsuperregisterworklist.clear;
+
+    begin
+      length:=0;
+    end;
+
+
+    procedure tsuperregisterworklist.deleteidx(i:word);
+
+    begin
+      if length=0 then
+        internalerror(200310144);
+      buf^[i]:=buf^[length-1];
+      dec(length);
+    end;
+
+
+    function tsuperregisterworklist.get:tsuperregister;
+
+    begin
+      if length=0 then
+        internalerror(200310142);
+      get:=buf^[0];
+      buf^[0]:=buf^[length-1];
+      dec(length);
+    end;
+
+
+    function tsuperregisterworklist.delete(s:tsuperregister):boolean;
+
+    var
+      i:longint;
+
+    begin
+      delete:=false;
+      { indexword in 1.0.x and 1.9.4 is broken }
+      i:=indexword(buf^,length,s);
+      if i<>-1 then
+        begin
+          deleteidx(i);
+          delete := true;
+        end;
+    end;
+
+
+    procedure supregset_reset(var regs:tsuperregisterset;setall:boolean;
+                              maxreg:Tsuperregister);{$ifdef USEINLINE}inline;{$endif}
+
+    begin
+      fillchar(regs,(maxreg+7) shr 3,-byte(setall));
+    end;
+
+
+    procedure supregset_include(var regs:tsuperregisterset;s:tsuperregister);{$ifdef USEINLINE}inline;{$endif}
+      begin
+        include(regs[s shr 8],(s and $ff));
+      end;
+
+
+    procedure supregset_exclude(var regs:tsuperregisterset;s:tsuperregister);{$ifdef USEINLINE}inline;{$endif}
+      begin
+        exclude(regs[s shr 8],(s and $ff));
+      end;
+
+
+    function supregset_in(const regs:tsuperregisterset;s:tsuperregister):boolean;{$ifdef USEINLINE}inline;{$endif}
+      begin
+        result:=(s and $ff) in regs[s shr 8];
+      end;
+
+
+    function newreg(rt:tregistertype;sr:tsuperregister;sb:tsubregister):tregister;{$ifdef USEINLINE}inline;{$endif}
+      begin
+        tregisterrec(result).regtype:=rt;
+        tregisterrec(result).supreg:=sr;
+        tregisterrec(result).subreg:=sb;
+      end;
+
+
+    function getsubreg(r:tregister):tsubregister;{$ifdef USEINLINE}inline;{$endif}
+      begin
+        result:=tregisterrec(r).subreg;
+      end;
+
+
+    function getsupreg(r:tregister):tsuperregister;{$ifdef USEINLINE}inline;{$endif}
+      begin
+        result:=tregisterrec(r).supreg;
+      end;
+
+
+    function getregtype(r:tregister):tregistertype;{$ifdef USEINLINE}inline;{$endif}
+      begin
+        result:=tregisterrec(r).regtype;
+      end;
+
+
+    procedure setsubreg(var r:tregister;sr:tsubregister);{$ifdef USEINLINE}inline;{$endif}
+      begin
+        tregisterrec(r).subreg:=sr;
+      end;
+
+
+    procedure setsupreg(var r:tregister;sr:tsuperregister);{$ifdef USEINLINE}inline;{$endif}
+      begin
+        tregisterrec(r).supreg:=sr;
+      end;
+
+
+    function generic_regname(r:tregister):string;
+      var
+        nr : string[12];
+      begin
+        str(getsupreg(r),nr);
+        case getregtype(r) of
+          R_INTREGISTER:
+            result:='ireg'+nr;
+          R_FPUREGISTER:
+            result:='freg'+nr;
+          R_MMREGISTER:
+            result:='mreg'+nr;
+          R_MMXREGISTER:
+            result:='xreg'+nr;
+          else
+            begin
+              result:='INVALID';
+              exit;
+            end;
+        end;
+        case getsubreg(r) of
+          R_SUBNONE:
+            ;
+          R_SUBL:
+            result:=result+'l';
+          R_SUBH:
+            result:=result+'h';
+          R_SUBW:
+            result:=result+'w';
+          R_SUBD:
+            result:=result+'d';
+          R_SUBQ:
+            result:=result+'q';
+          R_SUBFS:
+            result:=result+'fs';
+          R_SUBFD:
+            result:=result+'fd';
+          R_SUBMMD:
+            result:=result+'md';
+          R_SUBMMS:
+            result:=result+'ms';
+          else
+            internalerror(200308252);
+        end;
+      end;
+
+
+    function int_cgsize(const a: aint): tcgsize;{$ifdef USEINLINE}inline;{$endif}
+      const
+        size2cgsize : array[0..8] of tcgsize = (
+          OS_NO,OS_8,OS_16,OS_32,OS_32,OS_64,OS_64,OS_64,OS_64
+        );
+      begin
+        if a>8 then
+          result:=OS_NO
+        else
+          result:=size2cgsize[a];
+      end;
+
+
+    function inverse_opcmp(opcmp: topcmp): topcmp;{$ifdef USEINLINE}inline;{$endif}
+      const
+        list: array[TOpCmp] of TOpCmp =
+          (OC_NONE,OC_NE,OC_LTE,OC_GTE,OC_LT,OC_GT,OC_EQ,OC_A,OC_AE,
+           OC_B,OC_BE);
+      begin
+        inverse_opcmp := list[opcmp];
+      end;
+
+
+    function commutativeop(op: topcg): boolean;{$ifdef USEINLINE}inline;{$endif}
+      const
+        list: array[topcg] of boolean =
+          (true,true,true,false,false,true,true,false,false,
+           true,false,false,false,false,true);
+      begin
+        commutativeop := list[op];
+      end;
+
+
+    function realshuffle(shuffle : pmmshuffle) : boolean;
+      var
+        i : longint;
+      begin
+        realshuffle:=true;
+        if (shuffle=nil) or (shuffle^.len=0) then
+          realshuffle:=false
+        else
+          begin
+            for i:=1 to shuffle^.len do
+              begin
+                if (shuffle^.shuffles[i] and $f)<>((shuffle^.shuffles[i] and $f0) shr 8) then
+                  exit;
+              end;
+            realshuffle:=false;
+          end;
+      end;
+
+
+    function shufflescalar(shuffle : pmmshuffle) : boolean;
+      begin
+        result:=shuffle^.len=0;
+      end;
+
+
+    procedure removeshuffles(var shuffle : tmmshuffle);
+      var
+        i : longint;
+      begin
+        if shuffle.len=0 then
+          exit;
+        for i:=1 to shuffle.len do
+          shuffle.shuffles[i]:=(shuffle.shuffles[i] and $f0) or ((shuffle.shuffles[i] and $f0) shr 8);
+      end;
+
+
+initialization
+  new(mms_movescalar);
+  mms_movescalar^.len:=0;
+finalization
+  dispose(mms_movescalar);
+end.

+ 2090 - 0
compiler/cgobj.pas

@@ -0,0 +1,2090 @@
+{
+    Copyright (c) 1998-2005 by Florian Klaempfl
+    Member of the Free Pascal development team
+
+    This unit implements the basic 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)
+   Abstreact code generator unit. This contains the base class
+   to implement for all new supported processors.
+
+   WARNING: None of the routines implemented in these modules,
+   or their descendants, should use the temp. allocator, as
+   these routines may be called inside genentrycode, and the
+   stack frame is already setup!
+}
+unit cgobj;
+
+{$i fpcdefs.inc}
+
+  interface
+
+    uses
+       cclasses,globtype,
+       cpubase,cgbase,cgutils,parabase,
+       aasmbase,aasmtai,aasmcpu,
+       symconst,symbase,symtype,symdef,symtable,rgobj
+       ;
+
+    type
+       talignment = (AM_NATURAL,AM_NONE,AM_2BYTE,AM_4BYTE,AM_8BYTE);
+
+       {# @abstract(Abstract code generator)
+          This class implements an abstract instruction generator. Some of
+          the methods of this class are generic, while others must
+          be overriden for all new processors which will be supported
+          by Free Pascal. For 32-bit processors, the base class
+          sould be @link(tcg64f32) and not @var(tcg).
+       }
+       tcg = class
+       public
+          alignment : talignment;
+          rg        : array[tregistertype] of trgobj;
+          t_times   : longint;
+       {$ifdef flowgraph}
+          aktflownode:word;
+       {$endif}
+          {************************************************}
+          {                 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;
+
+       {$ifdef flowgraph}
+          procedure init_flowgraph;
+          procedure done_flowgraph;
+       {$endif}
+          {# Gets a register suitable to do integer operations on.}
+          function getintregister(list:Taasmoutput;size:Tcgsize):Tregister;virtual;
+          {# Gets a register suitable to do integer operations on.}
+          function getaddressregister(list:Taasmoutput):Tregister;virtual;
+          function getfpuregister(list:Taasmoutput;size:Tcgsize):Tregister;virtual;
+          function getmmregister(list:Taasmoutput;size:Tcgsize):Tregister;virtual;
+          function getflagregister(list:Taasmoutput;size:Tcgsize):Tregister;virtual;abstract;
+          {Does the generic cg need SIMD registers, like getmmxregister? Or should
+           the cpu specific child cg object have such a method?}
+
+          procedure add_reg_instruction(instr:Tai;r:tregister);virtual;
+          procedure add_move_instruction(instr:Taicpu);virtual;
+
+          function  uses_registers(rt:Tregistertype):boolean;virtual;
+          {# Get a specific register.}
+          procedure getcpuregister(list:Taasmoutput;r:Tregister);virtual;
+          procedure ungetcpuregister(list:Taasmoutput;r:Tregister);virtual;
+          {# Get multiple registers specified.}
+          procedure alloccpuregisters(list:Taasmoutput;rt:Tregistertype;r:Tcpuregisterset);virtual;
+          {# Free multiple registers specified.}
+          procedure dealloccpuregisters(list:Taasmoutput;rt:Tregistertype;r:Tcpuregisterset);virtual;
+
+          procedure allocallcpuregisters(list:Taasmoutput);virtual;
+          procedure deallocallcpuregisters(list:Taasmoutput);virtual;
+          procedure do_register_allocation(list:Taasmoutput;headertai:tai);virtual;
+
+          function makeregsize(list:Taasmoutput;reg:Tregister;size:Tcgsize):Tregister;
+
+          {# Emit a label to the instruction stream. }
+          procedure a_label(list : taasmoutput;l : tasmlabel);virtual;
+
+          {# Allocates register r by inserting a pai_realloc record }
+          procedure a_reg_alloc(list : taasmoutput;r : tregister);
+          {# Deallocates register r by inserting a pa_regdealloc record}
+          procedure a_reg_dealloc(list : taasmoutput;r : tregister);
+          { Synchronize register, make sure it is still valid }
+          procedure a_reg_sync(list : taasmoutput;r : tregister);
+
+          {# 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.
+             This must be overriden for each CPU target.
+
+             @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_param_reg(list : taasmoutput;size : tcgsize;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 overriden for optimization purposes if the cpu
+             permits directly sending this type of parameter.
+
+             @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_param_const(list : taasmoutput;size : tcgsize;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 overriden for optimization purposes if the cpu
+             permits directly sending this type of parameter.
+
+             @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_param_ref(list : taasmoutput;size : tcgsize;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_param_loc(list : taasmoutput;const l : tlocation;const cgpara : TCGPara);
+          {# 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.
+
+             A generic version is provided. This routine should
+             be overriden for optimization purposes if the cpu
+             permits directly sending this type of parameter.
+
+             @param(r reference to get address from)
+             @param(nr parameter number (starting from one) of routine (from left to right))
+          }
+          procedure a_paramaddr_ref(list : taasmoutput;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 overriden for each new target cpu.
+
+             There is no a_call_ref because loading the reference will use
+             a temp register on most cpu's resulting in conflicts with the
+             registers used for the parameters (PFV)
+          }
+          procedure a_call_name(list : taasmoutput;const s : string);virtual; abstract;
+          procedure a_call_reg(list : taasmoutput;reg : tregister);virtual;abstract;
+
+          { move instructions }
+          procedure a_load_const_reg(list : taasmoutput;size : tcgsize;a : aint;register : tregister);virtual; abstract;
+          procedure a_load_const_ref(list : taasmoutput;size : tcgsize;a : aint;const ref : treference);virtual;
+          procedure a_load_const_loc(list : taasmoutput;a : aint;const loc : tlocation);
+          procedure a_load_reg_ref(list : taasmoutput;fromsize,tosize : tcgsize;register : tregister;const ref : treference);virtual; abstract;
+          procedure a_load_reg_reg(list : taasmoutput;fromsize,tosize : tcgsize;reg1,reg2 : tregister);virtual; abstract;
+          procedure a_load_reg_loc(list : taasmoutput;fromsize : tcgsize;reg : tregister;const loc: tlocation);
+          procedure a_load_ref_reg(list : taasmoutput;fromsize,tosize : tcgsize;const ref : treference;register : tregister);virtual; abstract;
+          procedure a_load_ref_ref(list : taasmoutput;fromsize,tosize : tcgsize;const sref : treference;const dref : treference);virtual;
+          procedure a_load_loc_reg(list : taasmoutput;tosize: tcgsize; const loc: tlocation; reg : tregister);
+          procedure a_load_loc_ref(list : taasmoutput;tosize: tcgsize; const loc: tlocation; const ref : treference);
+          procedure a_loadaddr_ref_reg(list : taasmoutput;const ref : treference;r : tregister);virtual; abstract;
+
+          { fpu move instructions }
+          procedure a_loadfpu_reg_reg(list: taasmoutput; size:tcgsize; reg1, reg2: tregister); virtual; abstract;
+          procedure a_loadfpu_ref_reg(list: taasmoutput; size: tcgsize; const ref: treference; reg: tregister); virtual; abstract;
+          procedure a_loadfpu_reg_ref(list: taasmoutput; size: tcgsize; reg: tregister; const ref: treference); virtual; abstract;
+          procedure a_loadfpu_loc_reg(list: taasmoutput; const loc: tlocation; const reg: tregister);
+          procedure a_loadfpu_reg_loc(list: taasmoutput; size: tcgsize; const reg: tregister; const loc: tlocation);
+          procedure a_paramfpu_reg(list : taasmoutput;size : tcgsize;const r : tregister;const cgpara : TCGPara);virtual;
+          procedure a_paramfpu_ref(list : taasmoutput;size : tcgsize;const ref : treference;const cgpara : TCGPara);virtual;
+
+          { vector register move instructions }
+          procedure a_loadmm_reg_reg(list: taasmoutput; fromsize, tosize : tcgsize;reg1, reg2: tregister;shuffle : pmmshuffle); virtual; abstract;
+          procedure a_loadmm_ref_reg(list: taasmoutput; fromsize, tosize : tcgsize;const ref: treference; reg: tregister;shuffle : pmmshuffle); virtual; abstract;
+          procedure a_loadmm_reg_ref(list: taasmoutput; fromsize, tosize : tcgsize;reg: tregister; const ref: treference;shuffle : pmmshuffle); virtual; abstract;
+          procedure a_loadmm_loc_reg(list: taasmoutput; size: tcgsize; const loc: tlocation; const reg: tregister;shuffle : pmmshuffle);
+          procedure a_loadmm_reg_loc(list: taasmoutput; size: tcgsize; const reg: tregister; const loc: tlocation;shuffle : pmmshuffle);
+          procedure a_parammm_reg(list: taasmoutput; size: tcgsize; reg: tregister;const cgpara : TCGPara;shuffle : pmmshuffle); virtual;
+          procedure a_parammm_ref(list: taasmoutput; size: tcgsize; const ref: treference;const cgpara : TCGPara;shuffle : pmmshuffle); virtual;
+          procedure a_parammm_loc(list: taasmoutput; const loc: tlocation; const cgpara : TCGPara;shuffle : pmmshuffle); virtual;
+          procedure a_opmm_reg_reg(list: taasmoutput; Op: TOpCG; size : tcgsize;src,dst: tregister;shuffle : pmmshuffle); virtual;abstract;
+          procedure a_opmm_ref_reg(list: taasmoutput; Op: TOpCG; size : tcgsize;const ref: treference; reg: tregister;shuffle : pmmshuffle); virtual;
+          procedure a_opmm_loc_reg(list: taasmoutput; Op: TOpCG; size : tcgsize;const loc: tlocation; reg: tregister;shuffle : pmmshuffle); virtual;
+          procedure a_opmm_reg_ref(list: taasmoutput; Op: TOpCG; size : tcgsize;reg: tregister;const ref: treference; 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 : taasmoutput; Op: TOpCG; size: TCGSize; a: Aint; reg: TRegister); virtual; abstract;
+          procedure a_op_const_ref(list : taasmoutput; Op: TOpCG; size: TCGSize; a: Aint; const ref: TReference); virtual;
+          procedure a_op_const_loc(list : taasmoutput; Op: TOpCG; a: Aint; const loc: tlocation);
+          procedure a_op_reg_reg(list : taasmoutput; Op: TOpCG; size: TCGSize; reg1, reg2: TRegister); virtual; abstract;
+          procedure a_op_reg_ref(list : taasmoutput; Op: TOpCG; size: TCGSize; reg: TRegister; const ref: TReference); virtual;
+          procedure a_op_ref_reg(list : taasmoutput; Op: TOpCG; size: TCGSize; const ref: TReference; reg: TRegister); virtual;
+          procedure a_op_reg_loc(list : taasmoutput; Op: TOpCG; reg: tregister; const loc: tlocation);
+          procedure a_op_ref_loc(list : taasmoutput; Op: TOpCG; const ref: TReference; const loc: tlocation);
+
+          { 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: taasmoutput; op: TOpCg; size: tcgsize; a: aint; src, dst: tregister); virtual;
+          procedure a_op_reg_reg_reg(list: taasmoutput; op: TOpCg; size: tcgsize; src1, src2, dst: tregister); virtual;
+          procedure a_op_const_reg_reg_checkoverflow(list: taasmoutput; op: TOpCg; size: tcgsize; a: aint; src, dst: tregister;setflags : boolean;var ovloc : tlocation); virtual;
+          procedure a_op_reg_reg_reg_checkoverflow(list: taasmoutput; op: TOpCg; size: tcgsize; src1, src2, dst: tregister;setflags : boolean;var ovloc : tlocation); virtual;
+
+          {  comparison operations }
+          procedure a_cmp_const_reg_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp;a : aint;reg : tregister;
+            l : tasmlabel);virtual; abstract;
+          procedure a_cmp_const_ref_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp;a : aint;const ref : treference;
+            l : tasmlabel); virtual;
+          procedure a_cmp_const_loc_label(list: taasmoutput; size: tcgsize;cmp_op: topcmp; a: aint; const loc: tlocation;
+            l : tasmlabel);
+          procedure a_cmp_reg_reg_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp;reg1,reg2 : tregister;l : tasmlabel); virtual; abstract;
+          procedure a_cmp_ref_reg_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp; const ref: treference; reg : tregister; l : tasmlabel); virtual;
+          procedure a_cmp_reg_ref_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp;reg : tregister; const ref: treference; l : tasmlabel); virtual;
+          procedure a_cmp_loc_reg_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp; const loc: tlocation; reg : tregister; l : tasmlabel);
+          procedure a_cmp_ref_loc_label(list: taasmoutput; size: tcgsize;cmp_op: topcmp; const ref: treference; const loc: tlocation;
+            l : tasmlabel);
+
+          procedure a_jmp_name(list : taasmoutput;const s : string); virtual; abstract;
+          procedure a_jmp_always(list : taasmoutput;l: tasmlabel); virtual; abstract;
+          procedure a_jmp_flags(list : taasmoutput;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: taasmoutput; size: TCgSize; const f: tresflags; reg: TRegister); virtual; abstract;
+          procedure g_flags2ref(list: taasmoutput; size: TCgSize; const f: tresflags; const ref:TReference); virtual;
+
+          {
+             This routine tries to optimize the const_reg opcode, and should be
+             called at the start of a_op_const_reg. It returns the actual opcode
+             to emit, and the constant value to emit. If this routine returns
+             TRUE, @var(no) instruction should be emitted (.eg : imul reg by 1 )
+
+             @param(op The opcode to emit, returns the opcode which must be emitted)
+             @param(a  The constant which should be emitted, returns the constant which must
+                    be emitted)
+             @param(reg The register to emit the opcode with, returns the register with
+                   which the opcode will be emitted)
+          }
+          function optimize_op_const_reg(list: taasmoutput; var op: topcg; var a : aint; var reg: tregister): boolean;virtual;
+
+         {#
+             This routine is used in exception management nodes. It should
+             save the exception reason currently in the FUNCTION_RETURN_REG. The
+             save should be done either to a temp (pointed to by href).
+             or on the stack (pushing the value on the stack).
+
+             The size of the value to save is OS_S32. The default version
+             saves the exception reason to a temp. memory area.
+          }
+         procedure g_exception_reason_save(list : taasmoutput; const href : treference);virtual;
+         {#
+             This routine is used in exception management nodes. It should
+             save the exception reason constant. The
+             save should be done either to a temp (pointed to by href).
+             or on the stack (pushing the value on the stack).
+
+             The size of the value to save is OS_S32. The default version
+             saves the exception reason to a temp. memory area.
+          }
+         procedure g_exception_reason_save_const(list : taasmoutput; const href : treference; a: aint);virtual;
+         {#
+             This routine is used in exception management nodes. It should
+             load the exception reason to the FUNCTION_RETURN_REG. The saved value
+             should either be in the temp. area (pointed to by href , href should
+             *NOT* be freed) or on the stack (the value should be popped).
+
+             The size of the value to save is OS_S32. The default version
+             saves the exception reason to a temp. memory area.
+          }
+         procedure g_exception_reason_load(list : taasmoutput; const href : treference);virtual;
+
+          procedure g_maybe_testself(list : taasmoutput;reg:tregister);
+          procedure g_maybe_testvmt(list : taasmoutput;reg:tregister;objdef:tobjectdef);
+          {# This should emit the opcode to copy len bytes from the source
+             to destination.
+
+             It must be overriden for each new target processor.
+
+             @param(source Source reference of copy)
+             @param(dest Destination reference of copy)
+
+          }
+          procedure g_concatcopy(list : taasmoutput;const source,dest : treference;len : aint);virtual; abstract;
+          {# This should emit the opcode to copy len bytes from the an unaligned source
+             to destination.
+
+             It must be overriden for each new target processor.
+
+             @param(source Source reference of copy)
+             @param(dest Destination reference of copy)
+
+          }
+          procedure g_concatcopy_unaligned(list : taasmoutput;const source,dest : treference;len : aint);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 : taasmoutput;const source,dest : treference;len:byte);
+
+          procedure g_incrrefcount(list : taasmoutput;t: tdef; const ref: treference);
+          procedure g_decrrefcount(list : taasmoutput;t: tdef; const ref: treference);
+          procedure g_initialize(list : taasmoutput;t : tdef;const ref : treference);
+          procedure g_finalize(list : taasmoutput;t : tdef;const ref : treference);
+
+          {# Generates range checking code. It is to note
+             that this routine does not need to be overriden,
+             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: taasmoutput; const l:tlocation; fromdef,todef: tdef); virtual;
+
+          {# Generates overflow checking code for a node }
+          procedure g_overflowcheck(list: taasmoutput; const Loc:tlocation; def:tdef); virtual;abstract;
+          procedure g_overflowCheck_loc(List:TAasmOutput;const Loc:TLocation;def:TDef;ovloc : tlocation);virtual;
+
+          procedure g_copyvaluepara_openarray(list : taasmoutput;const ref:treference;const lenloc:tlocation;elesize:aint;destreg:tregister);virtual;
+          procedure g_releasevaluepara_openarray(list : taasmoutput;const l:tlocation);virtual;
+
+          {# Emits instructions when compilation is done in profile
+             mode (this is set as a command line option). The default
+             behavior does nothing, should be overriden as required.
+          }
+          procedure g_profilecode(list : taasmoutput);virtual;
+          {# Emits instruction for allocating @var(size) bytes at the stackpointer
+
+             @param(size Number of bytes to allocate)
+          }
+          procedure g_stackpointer_alloc(list : taasmoutput;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 : taasmoutput;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 : taasmoutput;parasize:longint;nostackframe:boolean);virtual;abstract;
+          {# This routine is called when generating the code for the entry point
+             of a routine. It should save all registers which are not used in this
+             routine, and which should be declared as saved in the std_saved_registers
+             set.
+
+             This routine is mainly used when linking to code which is generated
+             by ABI-compliant compilers (like GCC), to make sure that the reserved
+             registers of that ABI are not clobbered.
+
+             @param(usedinproc Registers which are used in the code of this routine)
+          }
+          procedure g_save_standard_registers(list:Taasmoutput);virtual;
+          {# This routine is called when generating the code for the exit point
+             of a routine. It should restore all registers which were previously
+             saved in @var(g_save_standard_registers).
+
+             @param(usedinproc Registers which are used in the code of this routine)
+          }
+          procedure g_restore_standard_registers(list:Taasmoutput);virtual;
+          procedure g_intf_wrapper(list: TAAsmoutput; procdef: tprocdef; const labelname: string; ioffset: longint);virtual;abstract;
+          procedure g_adjust_self_value(list:taasmoutput;procdef: tprocdef;ioffset: aint);virtual;
+       end;
+
+{$ifndef cpu64bit}
+    {# @abstract(Abstract code generator for 64 Bit operations)
+       This class implements an abstract code generator class
+       for 64 Bit operations.
+    }
+    tcg64 = class
+        procedure a_load64_const_ref(list : taasmoutput;value : int64;const ref : treference);virtual;abstract;
+        procedure a_load64_reg_ref(list : taasmoutput;reg : tregister64;const ref : treference);virtual;abstract;
+        procedure a_load64_ref_reg(list : taasmoutput;const ref : treference;reg : tregister64);virtual;abstract;
+        procedure a_load64_reg_reg(list : taasmoutput;regsrc,regdst : tregister64);virtual;abstract;
+        procedure a_load64_const_reg(list : taasmoutput;value : int64;reg : tregister64);virtual;abstract;
+        procedure a_load64_loc_reg(list : taasmoutput;const l : tlocation;reg : tregister64);virtual;abstract;
+        procedure a_load64_loc_ref(list : taasmoutput;const l : tlocation;const ref : treference);virtual;abstract;
+        procedure a_load64_const_loc(list : taasmoutput;value : int64;const l : tlocation);virtual;abstract;
+        procedure a_load64_reg_loc(list : taasmoutput;reg : tregister64;const l : tlocation);virtual;abstract;
+
+        procedure a_load64high_reg_ref(list : taasmoutput;reg : tregister;const ref : treference);virtual;abstract;
+        procedure a_load64low_reg_ref(list : taasmoutput;reg : tregister;const ref : treference);virtual;abstract;
+        procedure a_load64high_ref_reg(list : taasmoutput;const ref : treference;reg : tregister);virtual;abstract;
+        procedure a_load64low_ref_reg(list : taasmoutput;const ref : treference;reg : tregister);virtual;abstract;
+        procedure a_load64high_loc_reg(list : taasmoutput;const l : tlocation;reg : tregister);virtual;abstract;
+        procedure a_load64low_loc_reg(list : taasmoutput;const l : tlocation;reg : tregister);virtual;abstract;
+
+        procedure a_op64_ref_reg(list : taasmoutput;op:TOpCG;size : tcgsize;const ref : treference;reg : tregister64);virtual;abstract;
+        procedure a_op64_reg_reg(list : taasmoutput;op:TOpCG;size : tcgsize;regsrc,regdst : tregister64);virtual;abstract;
+        procedure a_op64_reg_ref(list : taasmoutput;op:TOpCG;size : tcgsize;regsrc : tregister64;const ref : treference);virtual;abstract;
+        procedure a_op64_const_reg(list : taasmoutput;op:TOpCG;size : tcgsize;value : int64;regdst : tregister64);virtual;abstract;
+        procedure a_op64_const_ref(list : taasmoutput;op:TOpCG;size : tcgsize;value : int64;const ref : treference);virtual;abstract;
+        procedure a_op64_const_loc(list : taasmoutput;op:TOpCG;size : tcgsize;value : int64;const l: tlocation);virtual;abstract;
+        procedure a_op64_reg_loc(list : taasmoutput;op:TOpCG;size : tcgsize;reg : tregister64;const l : tlocation);virtual;abstract;
+        procedure a_op64_loc_reg(list : taasmoutput;op:TOpCG;size : tcgsize;const l : tlocation;reg64 : tregister64);virtual;abstract;
+        procedure a_op64_const_reg_reg(list: taasmoutput;op:TOpCG;size : tcgsize;value : int64;regsrc,regdst : tregister64);virtual;
+        procedure a_op64_reg_reg_reg(list: taasmoutput;op:TOpCG;size : tcgsize;regsrc1,regsrc2,regdst : tregister64);virtual;
+        procedure a_op64_const_reg_reg_checkoverflow(list: taasmoutput;op:TOpCG;size : tcgsize;value : int64;regsrc,regdst : tregister64;setflags : boolean;var ovloc : tlocation);virtual;
+        procedure a_op64_reg_reg_reg_checkoverflow(list: taasmoutput;op:TOpCG;size : tcgsize;regsrc1,regsrc2,regdst : tregister64;setflags : boolean;var ovloc : tlocation);virtual;
+
+        procedure a_param64_reg(list : taasmoutput;reg64 : tregister64;const loc : TCGPara);virtual;abstract;
+        procedure a_param64_const(list : taasmoutput;value : int64;const loc : TCGPara);virtual;abstract;
+        procedure a_param64_ref(list : taasmoutput;const r : treference;const loc : TCGPara);virtual;abstract;
+        procedure a_param64_loc(list : taasmoutput;const l : tlocation;const loc : TCGPara);virtual;abstract;
+
+        {
+             This routine tries to optimize the const_reg opcode, and should be
+             called at the start of a_op64_const_reg. It returns the actual opcode
+             to emit, and the constant value to emit. If this routine returns
+             TRUE, @var(no) instruction should be emitted (.eg : imul reg by 1 )
+
+             @param(op The opcode to emit, returns the opcode which must be emitted)
+             @param(a  The constant which should be emitted, returns the constant which must
+                    be emitted)
+             @param(reg The register to emit the opcode with, returns the register with
+                   which the opcode will be emitted)
+        }
+        function optimize64_op_const_reg(list: taasmoutput; var op: topcg; var a : int64; var reg: tregister64): boolean;virtual;abstract;
+
+
+        { override to catch 64bit rangechecks }
+        procedure g_rangecheck64(list: taasmoutput; const l:tlocation; fromdef,todef: tdef);virtual;abstract;
+    end;
+{$endif cpu64bit}
+
+    var
+       {# Main code generator class }
+       cg : tcg;
+{$ifndef cpu64bit}
+       {# Code generator class for all operations working with 64-Bit operands }
+       cg64 : tcg64;
+{$endif cpu64bit}
+
+
+implementation
+
+    uses
+       globals,options,systems,
+       verbose,defutil,paramgr,symsym,
+       tgobj,cutils,procinfo;
+
+    const
+      { Please leave this here, this module should NOT use
+        exprasmlist, the lists are always passed as arguments.
+        Declaring it as string here results in an error when compiling (PFV) }
+      exprasmlist = 'error';
+
+
+{*****************************************************************************
+                            basic functionallity
+******************************************************************************}
+
+    constructor tcg.create;
+      begin
+      end;
+
+
+{*****************************************************************************
+                                register allocation
+******************************************************************************}
+
+
+    procedure tcg.init_register_allocators;
+      begin
+        fillchar(rg,sizeof(rg),0);
+        add_reg_instruction_hook:=@add_reg_instruction;
+      end;
+
+
+    procedure tcg.done_register_allocators;
+      begin
+        { Safety }
+        fillchar(rg,sizeof(rg),0);
+        add_reg_instruction_hook:=nil;
+      end;
+
+    {$ifdef flowgraph}
+    procedure Tcg.init_flowgraph;
+
+    begin
+      aktflownode:=0;
+    end;
+
+    procedure Tcg.done_flowgraph;
+
+    begin
+    end;
+    {$endif}
+
+    function tcg.getintregister(list:Taasmoutput;size:Tcgsize):Tregister;
+      begin
+        if not assigned(rg[R_INTREGISTER]) then
+          internalerror(200312122);
+        result:=rg[R_INTREGISTER].getregister(list,cgsize2subreg(size));
+      end;
+
+
+    function tcg.getfpuregister(list:Taasmoutput;size:Tcgsize):Tregister;
+      begin
+        if not assigned(rg[R_FPUREGISTER]) then
+          internalerror(200312123);
+        result:=rg[R_FPUREGISTER].getregister(list,cgsize2subreg(size));
+      end;
+
+
+    function tcg.getmmregister(list:Taasmoutput;size:Tcgsize):Tregister;
+      begin
+        if not assigned(rg[R_MMREGISTER]) then
+          internalerror(2003121214);
+        result:=rg[R_MMREGISTER].getregister(list,cgsize2subreg(size));
+      end;
+
+
+    function tcg.getaddressregister(list:Taasmoutput):Tregister;
+      begin
+        if assigned(rg[R_ADDRESSREGISTER]) then
+          result:=rg[R_ADDRESSREGISTER].getregister(list,R_SUBWHOLE)
+        else
+          begin
+            if not assigned(rg[R_INTREGISTER]) then
+              internalerror(200312121);
+            result:=rg[R_INTREGISTER].getregister(list,R_SUBWHOLE);
+          end;
+      end;
+
+
+    function Tcg.makeregsize(list:Taasmoutput;reg:Tregister;size:Tcgsize):Tregister;
+      var
+        subreg:Tsubregister;
+      begin
+        subreg:=cgsize2subreg(size);
+        result:=reg;
+        setsubreg(result,subreg);
+        { notify RA }
+        if result<>reg then
+          list.concat(tai_regalloc.resize(result));
+      end;
+
+
+    procedure tcg.getcpuregister(list:Taasmoutput;r:Tregister);
+      begin
+        if not assigned(rg[getregtype(r)]) then
+          internalerror(200312125);
+        rg[getregtype(r)].getcpuregister(list,r);
+      end;
+
+
+    procedure tcg.ungetcpuregister(list:Taasmoutput;r:Tregister);
+      begin
+        if not assigned(rg[getregtype(r)]) then
+          internalerror(200312126);
+        rg[getregtype(r)].ungetcpuregister(list,r);
+      end;
+
+
+    procedure tcg.alloccpuregisters(list:Taasmoutput;rt:Tregistertype;r:Tcpuregisterset);
+      begin
+        if assigned(rg[rt]) then
+          rg[rt].alloccpuregisters(list,r)
+        else
+          internalerror(200310092);
+      end;
+
+
+    procedure tcg.allocallcpuregisters(list:Taasmoutput);
+      begin
+        alloccpuregisters(list,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default));
+{$ifndef i386}
+        alloccpuregisters(list,R_FPUREGISTER,paramanager.get_volatile_registers_fpu(pocall_default));
+{$ifdef cpumm}
+        alloccpuregisters(list,R_MMREGISTER,paramanager.get_volatile_registers_mm(pocall_default));
+{$endif cpumm}
+{$endif i386}
+      end;
+
+
+    procedure tcg.dealloccpuregisters(list:Taasmoutput;rt:Tregistertype;r:Tcpuregisterset);
+      begin
+        if assigned(rg[rt]) then
+          rg[rt].dealloccpuregisters(list,r)
+        else
+          internalerror(200310093);
+      end;
+
+
+    procedure tcg.deallocallcpuregisters(list:Taasmoutput);
+      begin
+        dealloccpuregisters(list,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default));
+{$ifndef i386}
+        dealloccpuregisters(list,R_FPUREGISTER,paramanager.get_volatile_registers_fpu(pocall_default));
+{$ifdef cpumm}
+        dealloccpuregisters(list,R_MMREGISTER,paramanager.get_volatile_registers_mm(pocall_default));
+{$endif cpumm}
+{$endif i386}
+      end;
+
+
+    function tcg.uses_registers(rt:Tregistertype):boolean;
+      begin
+        if assigned(rg[rt]) then
+          result:=rg[rt].uses_registers
+        else
+          result:=false;
+      end;
+
+
+    procedure tcg.add_reg_instruction(instr:Tai;r:tregister);
+      var
+        rt : tregistertype;
+      begin
+        rt:=getregtype(r);
+        { Only add it when a register allocator is configured.
+          No IE can be generated, because the VMT is written
+          without a valid rg[] }
+        if assigned(rg[rt]) then
+          rg[rt].add_reg_instruction(instr,r);
+      end;
+
+
+    procedure tcg.add_move_instruction(instr:Taicpu);
+      var
+        rt : tregistertype;
+      begin
+        rt:=getregtype(instr.oper[O_MOV_SOURCE]^.reg);
+        if assigned(rg[rt]) then
+          rg[rt].add_move_instruction(instr)
+        else
+          internalerror(200310095);
+      end;
+
+
+    procedure tcg.do_register_allocation(list:Taasmoutput;headertai:tai);
+      var
+        rt : tregistertype;
+      begin
+        for rt:=R_FPUREGISTER to R_SPECIALREGISTER do
+          begin
+            if assigned(rg[rt]) then
+              rg[rt].do_register_allocation(list,headertai);
+          end;
+         { running the other register allocator passes could require addition int/addr. registers
+           when spilling so run int/addr register allocation at the end }
+         if assigned(rg[R_INTREGISTER]) then
+           rg[R_INTREGISTER].do_register_allocation(list,headertai);
+         if assigned(rg[R_ADDRESSREGISTER]) then
+           rg[R_ADDRESSREGISTER].do_register_allocation(list,headertai);
+      end;
+
+
+    procedure tcg.a_reg_alloc(list : taasmoutput;r : tregister);
+      begin
+         list.concat(tai_regalloc.alloc(r,nil));
+      end;
+
+
+    procedure tcg.a_reg_dealloc(list : taasmoutput;r : tregister);
+      begin
+         list.concat(tai_regalloc.dealloc(r,nil));
+      end;
+
+
+    procedure tcg.a_reg_sync(list : taasmoutput;r : tregister);
+      var
+        instr : tai;
+      begin
+        instr:=tai_regalloc.sync(r);
+        list.concat(instr);
+        add_reg_instruction(instr,r);
+      end;
+
+
+    procedure tcg.a_label(list : taasmoutput;l : tasmlabel);
+      begin
+         list.concat(tai_label.create(l));
+      end;
+
+
+{*****************************************************************************
+          for better code generation these methods should be overridden
+******************************************************************************}
+
+    procedure tcg.a_param_reg(list : taasmoutput;size : tcgsize;r : tregister;const cgpara : TCGPara);
+      var
+         ref : treference;
+      begin
+         cgpara.check_simple_location;
+         case cgpara.location^.loc of
+            LOC_REGISTER,LOC_CREGISTER:
+              a_load_reg_reg(list,size,cgpara.location^.size,r,cgpara.location^.register);
+            LOC_REFERENCE,LOC_CREFERENCE:
+              begin
+                 reference_reset_base(ref,cgpara.location^.reference.index,cgpara.location^.reference.offset);
+                 a_load_reg_ref(list,size,cgpara.location^.size,r,ref);
+              end
+            else
+              internalerror(2002071004);
+         end;
+      end;
+
+
+    procedure tcg.a_param_const(list : taasmoutput;size : tcgsize;a : aint;const cgpara : TCGPara);
+      var
+         ref : treference;
+      begin
+         cgpara.check_simple_location;
+         case cgpara.location^.loc of
+            LOC_REGISTER,LOC_CREGISTER:
+              a_load_const_reg(list,cgpara.location^.size,a,cgpara.location^.register);
+            LOC_REFERENCE,LOC_CREFERENCE:
+              begin
+                 reference_reset_base(ref,cgpara.location^.reference.index,cgpara.location^.reference.offset);
+                 a_load_const_ref(list,cgpara.location^.size,a,ref);
+              end
+            else
+              internalerror(2002071004);
+         end;
+      end;
+
+
+    procedure tcg.a_param_ref(list : taasmoutput;size : tcgsize;const r : treference;const cgpara : TCGPara);
+      var
+         ref : treference;
+      begin
+         cgpara.check_simple_location;
+         case cgpara.location^.loc of
+            LOC_REGISTER,LOC_CREGISTER:
+              a_load_ref_reg(list,size,cgpara.location^.size,r,cgpara.location^.register);
+            LOC_REFERENCE,LOC_CREFERENCE:
+              begin
+                 reference_reset(ref);
+                 ref.base:=cgpara.location^.reference.index;
+                 ref.offset:=cgpara.location^.reference.offset;
+                 { use concatcopy, because it can also be a float which fails when
+                   load_ref_ref is used }
+                 g_concatcopy(list,r,ref,tcgsize2size[size]);
+              end
+            else
+              internalerror(2002071004);
+         end;
+      end;
+
+
+    procedure tcg.a_param_loc(list : taasmoutput;const l:tlocation;const cgpara : TCGPara);
+      begin
+        case l.loc of
+          LOC_REGISTER,
+          LOC_CREGISTER :
+            a_param_reg(list,l.size,l.register,cgpara);
+          LOC_CONSTANT :
+            a_param_const(list,l.size,l.value,cgpara);
+          LOC_CREFERENCE,
+          LOC_REFERENCE :
+            a_param_ref(list,l.size,l.reference,cgpara);
+          else
+            internalerror(2002032211);
+        end;
+      end;
+
+
+    procedure tcg.a_paramaddr_ref(list : taasmoutput;const r : treference;const cgpara : TCGPara);
+      var
+         hr : tregister;
+      begin
+         cgpara.check_simple_location;
+         hr:=getaddressregister(list);
+         a_loadaddr_ref_reg(list,r,hr);
+         a_param_reg(list,OS_ADDR,hr,cgpara);
+      end;
+
+
+{****************************************************************************
+                       some generic implementations
+****************************************************************************}
+
+    procedure tcg.a_load_ref_ref(list : taasmoutput;fromsize,tosize : tcgsize;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 tcg.a_load_const_ref(list : taasmoutput;size : tcgsize;a : aint;const ref : treference);
+      var
+        tmpreg: tregister;
+      begin
+        tmpreg:=getintregister(list,size);
+        a_load_const_reg(list,size,a,tmpreg);
+        a_load_reg_ref(list,size,size,tmpreg,ref);
+      end;
+
+
+    procedure tcg.a_load_const_loc(list : taasmoutput;a : aint;const loc: tlocation);
+      begin
+        case loc.loc of
+          LOC_REFERENCE,LOC_CREFERENCE:
+            a_load_const_ref(list,loc.size,a,loc.reference);
+          LOC_REGISTER,LOC_CREGISTER:
+            a_load_const_reg(list,loc.size,a,loc.register);
+          else
+            internalerror(200203272);
+        end;
+      end;
+
+
+    procedure tcg.a_load_reg_loc(list : taasmoutput;fromsize : tcgsize;reg : tregister;const loc: tlocation);
+      begin
+        case loc.loc of
+          LOC_REFERENCE,LOC_CREFERENCE:
+            a_load_reg_ref(list,fromsize,loc.size,reg,loc.reference);
+          LOC_REGISTER,LOC_CREGISTER:
+            a_load_reg_reg(list,fromsize,loc.size,reg,loc.register);
+          else
+            internalerror(200203271);
+        end;
+      end;
+
+
+    procedure tcg.a_load_loc_reg(list : taasmoutput; tosize: tcgsize; const loc: tlocation; reg : tregister);
+      begin
+        case loc.loc of
+          LOC_REFERENCE,LOC_CREFERENCE:
+            a_load_ref_reg(list,loc.size,tosize,loc.reference,reg);
+          LOC_REGISTER,LOC_CREGISTER:
+            a_load_reg_reg(list,loc.size,tosize,loc.register,reg);
+          LOC_CONSTANT:
+            a_load_const_reg(list,tosize,loc.value,reg);
+          else
+            internalerror(200109092);
+        end;
+      end;
+
+
+    procedure tcg.a_load_loc_ref(list : taasmoutput;tosize: tcgsize; const loc: tlocation; const ref : treference);
+      begin
+        case loc.loc of
+          LOC_REFERENCE,LOC_CREFERENCE:
+            a_load_ref_ref(list,loc.size,tosize,loc.reference,ref);
+          LOC_REGISTER,LOC_CREGISTER:
+            a_load_reg_ref(list,loc.size,tosize,loc.register,ref);
+          LOC_CONSTANT:
+            a_load_const_ref(list,tosize,loc.value,ref);
+          else
+            internalerror(200109302);
+        end;
+      end;
+
+
+    function tcg.optimize_op_const_reg(list: taasmoutput; var op: topcg; var a : aint; var reg:tregister): boolean;
+      var
+        powerval : longint;
+      begin
+        optimize_op_const_reg := false;
+        case op of
+          { or with zero returns same result }
+          OP_OR : if a = 0 then optimize_op_const_reg := true;
+          { and with max returns same result }
+          OP_AND : if (a = high(a)) then optimize_op_const_reg := true;
+          { division by 1 returns result }
+          OP_DIV :
+            begin
+              if a = 1 then
+                optimize_op_const_reg := true
+              else if ispowerof2(int64(a), powerval) then
+                begin
+                  a := powerval;
+                  op:= OP_SHR;
+                end;
+              exit;
+            end;
+          OP_IDIV:
+            begin
+              if a = 1 then
+                optimize_op_const_reg := true
+              else if ispowerof2(int64(a), powerval) then
+                begin
+                  a := powerval;
+                  op:= OP_SAR;
+                end;
+               exit;
+            end;
+        OP_MUL,OP_IMUL:
+            begin
+               if a = 1 then
+                  optimize_op_const_reg := true
+               else if ispowerof2(int64(a), powerval) then
+                 begin
+                   a := powerval;
+                   op:= OP_SHL;
+                 end;
+               exit;
+            end;
+        OP_SAR,OP_SHL,OP_SHR:
+           begin
+              if a = 0 then
+                 optimize_op_const_reg := true;
+              exit;
+           end;
+        end;
+      end;
+
+
+    procedure tcg.a_loadfpu_loc_reg(list: taasmoutput; const loc: tlocation; const reg: tregister);
+      begin
+        case loc.loc of
+          LOC_REFERENCE, LOC_CREFERENCE:
+            a_loadfpu_ref_reg(list,loc.size,loc.reference,reg);
+          LOC_FPUREGISTER, LOC_CFPUREGISTER:
+            a_loadfpu_reg_reg(list,loc.size,loc.register,reg);
+          else
+            internalerror(200203301);
+        end;
+      end;
+
+
+    procedure tcg.a_loadfpu_reg_loc(list: taasmoutput; size: tcgsize; const reg: tregister; const loc: tlocation);
+      begin
+        case loc.loc of
+          LOC_REFERENCE, LOC_CREFERENCE:
+            a_loadfpu_reg_ref(list,size,reg,loc.reference);
+          LOC_FPUREGISTER, LOC_CFPUREGISTER:
+            a_loadfpu_reg_reg(list,size,reg,loc.register);
+          else
+            internalerror(48991);
+         end;
+      end;
+
+
+    procedure tcg.a_paramfpu_reg(list : taasmoutput;size : tcgsize;const r : tregister;const cgpara : TCGPara);
+      var
+         ref : treference;
+      begin
+         case cgpara.location^.loc of
+            LOC_FPUREGISTER,LOC_CFPUREGISTER:
+              begin
+                cgpara.check_simple_location;
+                a_loadfpu_reg_reg(list,size,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);
+                a_loadfpu_reg_ref(list,size,r,ref);
+              end;
+            LOC_REGISTER,LOC_CREGISTER:
+              begin
+                { paramfpu_ref does the check_simpe_location check here if necessary }
+                tg.GetTemp(list,TCGSize2Size[size],tt_normal,ref);
+                a_loadfpu_reg_ref(list,size,r,ref);
+                a_paramfpu_ref(list,size,ref,cgpara);
+                tg.Ungettemp(list,ref);
+              end;
+            else
+              internalerror(2002071004);
+         end;
+      end;
+
+
+    procedure tcg.a_paramfpu_ref(list : taasmoutput;size : tcgsize;const ref : treference;const cgpara : TCGPara);
+      var
+         href : treference;
+      begin
+         cgpara.check_simple_location;
+         case cgpara.location^.loc of
+          LOC_FPUREGISTER,LOC_CFPUREGISTER:
+            a_loadfpu_ref_reg(list,size,ref,cgpara.location^.register);
+          LOC_REFERENCE,LOC_CREFERENCE:
+            begin
+              reference_reset_base(href,cgpara.location^.reference.index,cgpara.location^.reference.offset);
+              { concatcopy should choose the best way to copy the data }
+              g_concatcopy(list,ref,href,tcgsize2size[size]);
+            end;
+          else
+            internalerror(200402201);
+        end;
+      end;
+
+
+    procedure tcg.a_op_const_ref(list : taasmoutput; Op: TOpCG; size: TCGSize; 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 tcg.a_op_const_loc(list : taasmoutput; Op: TOpCG; a: aint; const loc: tlocation);
+      begin
+        case loc.loc of
+          LOC_REGISTER, LOC_CREGISTER:
+            a_op_const_reg(list,op,loc.size,a,loc.register);
+          LOC_REFERENCE, LOC_CREFERENCE:
+            a_op_const_ref(list,op,loc.size,a,loc.reference);
+          else
+            internalerror(200109061);
+        end;
+      end;
+
+
+    procedure tcg.a_op_reg_ref(list : taasmoutput; Op: TOpCG; size: TCGSize;reg: TRegister;  const ref: TReference);
+      var
+        tmpreg : tregister;
+      begin
+        tmpreg:=getintregister(list,size);
+        a_load_ref_reg(list,size,size,ref,tmpreg);
+        a_op_reg_reg(list,op,size,reg,tmpreg);
+        a_load_reg_ref(list,size,size,tmpreg,ref);
+      end;
+
+
+    procedure tcg.a_op_ref_reg(list : taasmoutput; Op: TOpCG; size: TCGSize; 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 tcg.a_op_reg_loc(list : taasmoutput; Op: TOpCG; reg: tregister; const loc: tlocation);
+
+      begin
+        case loc.loc of
+          LOC_REGISTER, LOC_CREGISTER:
+            a_op_reg_reg(list,op,loc.size,reg,loc.register);
+          LOC_REFERENCE, LOC_CREFERENCE:
+            a_op_reg_ref(list,op,loc.size,reg,loc.reference);
+          else
+            internalerror(200109061);
+        end;
+      end;
+
+
+    procedure tcg.a_op_ref_loc(list : taasmoutput; Op: TOpCG; const ref: TReference; const loc: tlocation);
+
+      var
+        tmpreg: tregister;
+
+      begin
+        case loc.loc of
+          LOC_REGISTER,LOC_CREGISTER:
+            a_op_ref_reg(list,op,loc.size,ref,loc.register);
+          LOC_REFERENCE,LOC_CREFERENCE:
+            begin
+              tmpreg:=getintregister(list,loc.size);
+              a_load_ref_reg(list,loc.size,loc.size,ref,tmpreg);
+              a_op_reg_ref(list,op,loc.size,tmpreg,loc.reference);
+            end;
+          else
+            internalerror(200109061);
+        end;
+      end;
+
+    procedure Tcg.a_op_const_reg_reg(list:Taasmoutput;op:Topcg;size:Tcgsize;
+                                     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 tcg.a_op_reg_reg_reg(list: taasmoutput; op: TOpCg;
+        size: tcgsize; 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
+            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;
+
+
+    procedure tcg.a_op_const_reg_reg_checkoverflow(list: taasmoutput; op: TOpCg; size: tcgsize; a: aint; src, dst: tregister;setflags : boolean;var ovloc : tlocation);
+      begin
+        a_op_const_reg_reg(list,op,size,a,src,dst);
+        ovloc.loc:=LOC_VOID;
+      end;
+
+
+    procedure tcg.a_op_reg_reg_reg_checkoverflow(list: taasmoutput; op: TOpCg; size: tcgsize; src1, src2, dst: tregister;setflags : boolean;var ovloc : tlocation);
+      begin
+        a_op_reg_reg_reg(list,op,size,src1,src2,dst);
+        ovloc.loc:=LOC_VOID;
+      end;
+
+
+    procedure tcg.a_cmp_const_ref_label(list : taasmoutput;size : tcgsize;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 tcg.a_cmp_const_loc_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp;a : aint;const loc : tlocation;
+      l : tasmlabel);
+
+      begin
+        case loc.loc of
+          LOC_REGISTER,LOC_CREGISTER:
+            a_cmp_const_reg_label(list,size,cmp_op,a,loc.register,l);
+          LOC_REFERENCE,LOC_CREFERENCE:
+            a_cmp_const_ref_label(list,size,cmp_op,a,loc.reference,l);
+          else
+            internalerror(200109061);
+        end;
+      end;
+
+
+    procedure tcg.a_cmp_ref_reg_label(list : taasmoutput;size : tcgsize;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 tcg.a_cmp_reg_ref_label(list : taasmoutput;size : tcgsize;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 tcg.a_cmp_loc_reg_label(list : taasmoutput;size : tcgsize;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);
+          else
+            internalerror(200203231);
+        end;
+      end;
+
+
+    procedure tcg.a_cmp_ref_loc_label(list : taasmoutput;size : tcgsize;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
+          else
+            internalerror(200109061);
+        end;
+      end;
+
+
+    procedure tcg.a_loadmm_loc_reg(list: taasmoutput; size: tcgsize; const loc: tlocation; const reg: tregister;shuffle : pmmshuffle);
+      begin
+        case loc.loc of
+          LOC_MMREGISTER,LOC_CMMREGISTER:
+            a_loadmm_reg_reg(list,loc.size,size,loc.register,reg,shuffle);
+          LOC_REFERENCE,LOC_CREFERENCE:
+            a_loadmm_ref_reg(list,loc.size,size,loc.reference,reg,shuffle);
+          else
+            internalerror(200310121);
+        end;
+      end;
+
+
+    procedure tcg.a_loadmm_reg_loc(list: taasmoutput; size: tcgsize; const reg: tregister; const loc: tlocation;shuffle : pmmshuffle);
+      begin
+        case loc.loc of
+          LOC_MMREGISTER,LOC_CMMREGISTER:
+            a_loadmm_reg_reg(list,size,loc.size,reg,loc.register,shuffle);
+          LOC_REFERENCE,LOC_CREFERENCE:
+            a_loadmm_reg_ref(list,size,loc.size,reg,loc.reference,shuffle);
+          else
+            internalerror(200310122);
+        end;
+      end;
+
+
+    procedure tcg.a_parammm_reg(list: taasmoutput; size: tcgsize; reg: tregister;const cgpara : TCGPara;shuffle : pmmshuffle);
+      var
+        href : treference;
+      begin
+         cgpara.check_simple_location;
+         case cgpara.location^.loc of
+          LOC_MMREGISTER,LOC_CMMREGISTER:
+            a_loadmm_reg_reg(list,size,cgpara.location^.size,reg,cgpara.location^.register,shuffle);
+          LOC_REFERENCE,LOC_CREFERENCE:
+            begin
+              reference_reset_base(href,cgpara.location^.reference.index,cgpara.location^.reference.offset);
+              a_loadmm_reg_ref(list,size,cgpara.location^.size,reg,href,shuffle);
+            end
+          else
+            internalerror(200310123);
+        end;
+      end;
+
+
+    procedure tcg.a_parammm_ref(list: taasmoutput; size: tcgsize;const ref: treference;const cgpara : TCGPara;shuffle : pmmshuffle);
+      var
+         hr : tregister;
+         hs : tmmshuffle;
+      begin
+         cgpara.check_simple_location;
+         hr:=getmmregister(list,cgpara.location^.size);
+         a_loadmm_ref_reg(list,size,cgpara.location^.size,ref,hr,shuffle);
+         if realshuffle(shuffle) then
+           begin
+             hs:=shuffle^;
+             removeshuffles(hs);
+             a_parammm_reg(list,cgpara.location^.size,hr,cgpara,@hs);
+           end
+         else
+           a_parammm_reg(list,cgpara.location^.size,hr,cgpara,shuffle);
+      end;
+
+
+    procedure tcg.a_parammm_loc(list: taasmoutput;const loc: tlocation; const cgpara : TCGPara;shuffle : pmmshuffle);
+      begin
+        case loc.loc of
+          LOC_MMREGISTER,LOC_CMMREGISTER:
+            a_parammm_reg(list,loc.size,loc.register,cgpara,shuffle);
+          LOC_REFERENCE,LOC_CREFERENCE:
+            a_parammm_ref(list,loc.size,loc.reference,cgpara,shuffle);
+          else
+            internalerror(200310123);
+        end;
+      end;
+
+
+    procedure tcg.a_opmm_ref_reg(list: taasmoutput; Op: TOpCG; size : tcgsize;const ref: treference; reg: tregister;shuffle : pmmshuffle);
+      var
+         hr : tregister;
+         hs : tmmshuffle;
+      begin
+         hr:=getmmregister(list,size);
+         a_loadmm_ref_reg(list,size,size,ref,hr,shuffle);
+         if realshuffle(shuffle) then
+           begin
+             hs:=shuffle^;
+             removeshuffles(hs);
+             a_opmm_reg_reg(list,op,size,hr,reg,@hs);
+           end
+         else
+           a_opmm_reg_reg(list,op,size,hr,reg,shuffle);
+      end;
+
+
+    procedure tcg.a_opmm_reg_ref(list: taasmoutput; Op: TOpCG; size : tcgsize;reg: tregister; const ref: treference; shuffle : pmmshuffle);
+      var
+         hr : tregister;
+         hs : tmmshuffle;
+      begin
+         hr:=getmmregister(list,size);
+         a_loadmm_ref_reg(list,size,size,ref,hr,shuffle);
+         if realshuffle(shuffle) then
+           begin
+             hs:=shuffle^;
+             removeshuffles(hs);
+             a_opmm_reg_reg(list,op,size,reg,hr,@hs);
+             a_loadmm_reg_ref(list,size,size,hr,ref,@hs);
+           end
+         else
+           begin
+             a_opmm_reg_reg(list,op,size,reg,hr,shuffle);
+             a_loadmm_reg_ref(list,size,size,hr,ref,shuffle);
+           end;
+      end;
+
+
+    procedure tcg.a_opmm_loc_reg(list: taasmoutput; Op: TOpCG; size : tcgsize;const loc: tlocation; reg: tregister;shuffle : pmmshuffle);
+      begin
+        case loc.loc of
+          LOC_CMMREGISTER,LOC_MMREGISTER:
+            a_opmm_reg_reg(list,op,size,loc.register,reg,shuffle);
+          LOC_CREFERENCE,LOC_REFERENCE:
+            a_opmm_ref_reg(list,op,size,loc.reference,reg,shuffle);
+          else
+            internalerror(200312232);
+        end;
+      end;
+
+
+    procedure tcg.g_concatcopy_unaligned(list : taasmoutput;const source,dest : treference;len : aint);
+      begin
+        g_concatcopy(list,source,dest,len);
+      end;
+
+
+    procedure tcg.g_copyshortstring(list : taasmoutput;const source,dest : treference;len:byte);
+      var
+        cgpara1,cgpara2,cgpara3 : TCGPara;
+      begin
+        cgpara1.init;
+        cgpara2.init;
+        cgpara3.init;
+        paramanager.getintparaloc(pocall_default,1,cgpara1);
+        paramanager.getintparaloc(pocall_default,2,cgpara2);
+        paramanager.getintparaloc(pocall_default,3,cgpara3);
+        paramanager.allocparaloc(list,cgpara3);
+        a_paramaddr_ref(list,dest,cgpara3);
+        paramanager.allocparaloc(list,cgpara2);
+        a_paramaddr_ref(list,source,cgpara2);
+        paramanager.allocparaloc(list,cgpara1);
+        a_param_const(list,OS_INT,len,cgpara1);
+        paramanager.freeparaloc(list,cgpara3);
+        paramanager.freeparaloc(list,cgpara2);
+        paramanager.freeparaloc(list,cgpara1);
+        allocallcpuregisters(list);
+        a_call_name(list,'FPC_SHORTSTR_ASSIGN');
+        deallocallcpuregisters(list);
+        cgpara3.done;
+        cgpara2.done;
+        cgpara1.done;
+      end;
+
+
+    procedure tcg.g_incrrefcount(list : taasmoutput;t: tdef; const ref: treference);
+      var
+        href : treference;
+        incrfunc : string;
+        cgpara1,cgpara2 : TCGPara;
+      begin
+         cgpara1.init;
+         cgpara2.init;
+         paramanager.getintparaloc(pocall_default,1,cgpara1);
+         paramanager.getintparaloc(pocall_default,2,cgpara2);
+         if is_interfacecom(t) then
+          incrfunc:='FPC_INTF_INCR_REF'
+         else if is_ansistring(t) then
+       {$ifdef ansistring_bits}
+           begin
+             case Tstringdef(t).string_typ of
+               st_ansistring16:
+                 incrfunc:='FPC_ANSISTR16_INCR_REF';
+               st_ansistring32:
+                 incrfunc:='FPC_ANSISTR32_INCR_REF';
+               st_ansistring64:
+                 incrfunc:='FPC_ANSISTR64_INCR_REF';
+             end;
+           end
+       {$else}
+            incrfunc:='FPC_ANSISTR_INCR_REF'
+       {$endif}
+         else if is_widestring(t) then
+          incrfunc:='FPC_WIDESTR_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
+            paramanager.allocparaloc(list,cgpara1);
+            { these functions get the pointer by value }
+            a_param_ref(list,OS_ADDR,ref,cgpara1);
+            paramanager.freeparaloc(list,cgpara1);
+            allocallcpuregisters(list);
+            a_call_name(list,incrfunc);
+            deallocallcpuregisters(list);
+          end
+         else
+          begin
+            reference_reset_symbol(href,tstoreddef(t).get_rtti_label(initrtti),0);
+            paramanager.allocparaloc(list,cgpara2);
+            a_paramaddr_ref(list,href,cgpara2);
+            paramanager.allocparaloc(list,cgpara1);
+            a_paramaddr_ref(list,ref,cgpara1);
+            paramanager.freeparaloc(list,cgpara1);
+            paramanager.freeparaloc(list,cgpara2);
+            allocallcpuregisters(list);
+            a_call_name(list,'FPC_ADDREF');
+            deallocallcpuregisters(list);
+          end;
+         cgpara2.done;
+         cgpara1.done;
+      end;
+
+
+    procedure tcg.g_decrrefcount(list : taasmoutput;t: tdef; const ref: treference);
+      var
+        href : treference;
+        decrfunc : string;
+        needrtti : boolean;
+        cgpara1,cgpara2 : TCGPara;
+      begin
+        cgpara1.init;
+        cgpara2.init;
+        paramanager.getintparaloc(pocall_default,1,cgpara1);
+        paramanager.getintparaloc(pocall_default,2,cgpara2);
+        needrtti:=false;
+        if is_interfacecom(t) then
+          decrfunc:='FPC_INTF_DECR_REF'
+        else if is_ansistring(t) then
+       {$ifdef ansistring_bits}
+           begin
+             case Tstringdef(t).string_typ of
+               st_ansistring16:
+                 decrfunc:='FPC_ANSISTR16_DECR_REF';
+               st_ansistring32:
+                 decrfunc:='FPC_ANSISTR32_DECR_REF';
+               st_ansistring64:
+                 decrfunc:='FPC_ANSISTR64_DECR_REF';
+             end;
+           end
+       {$else}
+            decrfunc:='FPC_ANSISTR_DECR_REF'
+       {$endif}
+         else if is_widestring(t) then
+          decrfunc:='FPC_WIDESTR_DECR_REF'
+         else if is_dynamic_array(t) then
+          begin
+            decrfunc:='FPC_DYNARRAY_DECR_REF';
+            needrtti:=true;
+          end
+         else
+          decrfunc:='';
+         { call the special decr function or the generic decref }
+         if decrfunc<>'' then
+          begin
+            if needrtti then
+             begin
+               reference_reset_symbol(href,tstoreddef(t).get_rtti_label(initrtti),0);
+               paramanager.allocparaloc(list,cgpara2);
+               a_paramaddr_ref(list,href,cgpara2);
+             end;
+            paramanager.allocparaloc(list,cgpara1);
+            a_paramaddr_ref(list,ref,cgpara1);
+            paramanager.freeparaloc(list,cgpara1);
+            if needrtti then
+              paramanager.freeparaloc(list,cgpara2);
+            allocallcpuregisters(list);
+            a_call_name(list,decrfunc);
+            deallocallcpuregisters(list);
+          end
+         else
+          begin
+            reference_reset_symbol(href,tstoreddef(t).get_rtti_label(initrtti),0);
+            paramanager.allocparaloc(list,cgpara2);
+            a_paramaddr_ref(list,href,cgpara2);
+            paramanager.allocparaloc(list,cgpara1);
+            a_paramaddr_ref(list,ref,cgpara1);
+            paramanager.freeparaloc(list,cgpara1);
+            paramanager.freeparaloc(list,cgpara2);
+            allocallcpuregisters(list);
+            a_call_name(list,'FPC_DECREF');
+            deallocallcpuregisters(list);
+         end;
+        cgpara2.done;
+        cgpara1.done;
+      end;
+
+
+    procedure tcg.g_initialize(list : taasmoutput;t : tdef;const ref : treference);
+      var
+         href : treference;
+         cgpara1,cgpara2 : TCGPara;
+      begin
+        cgpara1.init;
+        cgpara2.init;
+        paramanager.getintparaloc(pocall_default,1,cgpara1);
+        paramanager.getintparaloc(pocall_default,2,cgpara2);
+         if is_ansistring(t) or
+            is_widestring(t) or
+            is_interfacecom(t) or
+            is_dynamic_array(t) then
+           a_load_const_ref(list,OS_ADDR,0,ref)
+         else
+           begin
+              reference_reset_symbol(href,tstoreddef(t).get_rtti_label(initrtti),0);
+              paramanager.allocparaloc(list,cgpara2);
+              a_paramaddr_ref(list,href,cgpara2);
+              paramanager.allocparaloc(list,cgpara1);
+              a_paramaddr_ref(list,ref,cgpara1);
+              paramanager.freeparaloc(list,cgpara1);
+              paramanager.freeparaloc(list,cgpara2);
+              allocallcpuregisters(list);
+              a_call_name(list,'FPC_INITIALIZE');
+              deallocallcpuregisters(list);
+           end;
+        cgpara1.done;
+        cgpara2.done;
+      end;
+
+
+    procedure tcg.g_finalize(list : taasmoutput;t : tdef;const ref : treference);
+      var
+         href : treference;
+         cgpara1,cgpara2 : TCGPara;
+      begin
+        cgpara1.init;
+        cgpara2.init;
+        paramanager.getintparaloc(pocall_default,1,cgpara1);
+        paramanager.getintparaloc(pocall_default,2,cgpara2);
+         if is_ansistring(t) or
+            is_widestring(t) or
+            is_interfacecom(t) then
+           begin
+             g_decrrefcount(list,t,ref);
+             a_load_const_ref(list,OS_ADDR,0,ref);
+           end
+         else
+           begin
+              reference_reset_symbol(href,tstoreddef(t).get_rtti_label(initrtti),0);
+              paramanager.allocparaloc(list,cgpara2);
+              a_paramaddr_ref(list,href,cgpara2);
+              paramanager.allocparaloc(list,cgpara1);
+              a_paramaddr_ref(list,ref,cgpara1);
+              paramanager.freeparaloc(list,cgpara1);
+              paramanager.freeparaloc(list,cgpara2);
+              allocallcpuregisters(list);
+              a_call_name(list,'FPC_FINALIZE');
+              deallocallcpuregisters(list);
+           end;
+        cgpara1.done;
+        cgpara2.done;
+      end;
+
+
+    procedure tcg.g_rangecheck(list: taasmoutput; const l:tlocation;fromdef,todef: tdef);
+    { generate range checking code for the value at location p. The type     }
+    { type used is checked against todefs ranges. fromdef (p.resulttype.def) }
+    { is the original type used at that location. When both defs are equal   }
+    { the check is also insert (needed for succ,pref,inc,dec)                }
+      const
+        aintmax=high(aint);
+      var
+        neglabel : tasmlabel;
+        hreg : tregister;
+        lto,hto,
+        lfrom,hfrom : TConstExprInt;
+        from_signed: boolean;
+      begin
+        { range checking on and range checkable value? }
+        if not(cs_check_range in aktlocalswitches) or
+           not(fromdef.deftype in [orddef,enumdef,arraydef]) then
+          exit;
+{$ifndef cpu64bit}
+        { 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 cpu64bit}
+        { 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);
+        { 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          }
+{$ifdef cpu64bit}
+        if (fromdef = todef) and
+           (fromdef.deftype=orddef) and
+           (((((torddef(fromdef).typ = s64bit) and
+               (lfrom = low(int64)) and
+               (hfrom = high(int64))) or
+              ((torddef(fromdef).typ = u64bit) and
+               (lfrom = low(qword)) and
+               (hfrom = high(qword)))))) then
+          exit;
+{$else cpu64bit}
+        if (fromdef = todef) and
+           (fromdef.deftype=orddef) and
+           (((((torddef(fromdef).typ = s32bit) and
+               (lfrom = low(longint)) and
+               (hfrom = high(longint))) or
+              ((torddef(fromdef).typ = u32bit) and
+               (lfrom = low(cardinal)) and
+               (hfrom = high(cardinal)))))) then
+          exit;
+{$endif cpu64bit}
+
+        { if the from-range falls completely in the to-range, no check }
+        { is necessary. Don't do this conversion for the largest unsigned type }
+        if (todef<>fromdef) and
+           (from_signed or (hfrom>=0)) and
+           (lto<=lfrom) and (hto>=hfrom) then
+          exit;
+
+        { 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                                 }
+
+        { is_signed now also works for arrays (it checks the rangetype) (JM) }
+        if from_signed xor is_signed(todef) 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
+                     a_call_name(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
+                     a_call_name(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,OS_INT);
+        a_load_loc_reg(list,OS_INT,l,hreg);
+        a_op_const_reg(list,OP_SUB,OS_INT,aint(lto),hreg);
+        objectlibrary.getjumplabel(neglabel);
+        {
+        if from_signed then
+          a_cmp_const_reg_label(list,OS_INT,OC_GTE,aint(hto-lto),hreg,neglabel)
+        else
+        }
+{$ifdef cpu64bit}
+        if qword(hto-lto)>qword(aintmax) then
+          a_cmp_const_reg_label(list,OS_INT,OC_BE,aintmax,hreg,neglabel)
+        else
+{$endif cpu64bit}
+          a_cmp_const_reg_label(list,OS_INT,OC_BE,aint(hto-lto),hreg,neglabel);
+        a_call_name(list,'FPC_RANGEERROR');
+        a_label(list,neglabel);
+      end;
+
+
+    procedure tcg.g_overflowCheck_loc(List:TAasmOutput;const Loc:TLocation;def:TDef;ovloc : tlocation);
+      begin
+        g_overflowCheck(list,loc,def);
+      end;
+
+
+    procedure tcg.g_flags2ref(list: taasmoutput; size: TCgSize; const f: tresflags; const ref:TReference);
+
+      var
+        tmpreg : tregister;
+      begin
+        tmpreg:=getintregister(list,size);
+        g_flags2reg(list,size,f,tmpreg);
+        a_load_reg_ref(list,size,size,tmpreg,ref);
+      end;
+
+
+    procedure tcg.g_maybe_testself(list : taasmoutput;reg:tregister);
+      var
+        OKLabel : tasmlabel;
+        cgpara1 : TCGPara;
+      begin
+        if (cs_check_object in aktlocalswitches) or
+           (cs_check_range in aktlocalswitches) then
+         begin
+           objectlibrary.getjumplabel(oklabel);
+           a_cmp_const_reg_label(list,OS_ADDR,OC_NE,0,reg,oklabel);
+           cgpara1.init;
+           paramanager.getintparaloc(pocall_default,1,cgpara1);
+           paramanager.allocparaloc(list,cgpara1);
+           a_param_const(list,OS_INT,210,cgpara1);
+           paramanager.freeparaloc(list,cgpara1);
+           a_call_name(list,'FPC_HANDLEERROR');
+           a_label(list,oklabel);
+           cgpara1.done;
+         end;
+      end;
+
+
+    procedure tcg.g_maybe_testvmt(list : taasmoutput;reg:tregister;objdef:tobjectdef);
+      var
+        hrefvmt : treference;
+        cgpara1,cgpara2 : TCGPara;
+      begin
+        cgpara1.init;
+        cgpara2.init;
+        paramanager.getintparaloc(pocall_default,1,cgpara1);
+        paramanager.getintparaloc(pocall_default,2,cgpara2);
+        if (cs_check_object in aktlocalswitches) then
+         begin
+           reference_reset_symbol(hrefvmt,objectlibrary.newasmsymbol(objdef.vmt_mangledname,AB_EXTERNAL,AT_DATA),0);
+           paramanager.allocparaloc(list,cgpara2);
+           a_paramaddr_ref(list,hrefvmt,cgpara2);
+           paramanager.allocparaloc(list,cgpara1);
+           a_param_reg(list,OS_ADDR,reg,cgpara1);
+           paramanager.freeparaloc(list,cgpara1);
+           paramanager.freeparaloc(list,cgpara2);
+           allocallcpuregisters(list);
+           a_call_name(list,'FPC_CHECK_OBJECT_EXT');
+           deallocallcpuregisters(list);
+         end
+        else
+         if (cs_check_range in aktlocalswitches) then
+          begin
+            paramanager.allocparaloc(list,cgpara1);
+            a_param_reg(list,OS_ADDR,reg,cgpara1);
+            paramanager.freeparaloc(list,cgpara1);
+            allocallcpuregisters(list);
+            a_call_name(list,'FPC_CHECK_OBJECT');
+            deallocallcpuregisters(list);
+          end;
+        cgpara1.done;
+        cgpara2.done;
+      end;
+
+
+{*****************************************************************************
+                            Entry/Exit Code Functions
+*****************************************************************************}
+
+    procedure tcg.g_copyvaluepara_openarray(list : taasmoutput;const ref:treference;const lenloc:tlocation;elesize:aint;destreg:tregister);
+      var
+        sizereg,sourcereg,lenreg : tregister;
+        cgpara1,cgpara2,cgpara3 : TCGPara;
+      begin
+        { because some abis don't support dynamic stack allocation properly
+          open array value parameters are copied onto the heap
+        }
+
+        { calculate necessary memory }
+
+        { read/write operations on one register make the life of the register allocator hard }
+        if not(lenloc.loc in [LOC_REGISTER,LOC_CREGISTER]) then
+          begin
+            lenreg:=getintregister(list,OS_INT);
+            a_load_loc_reg(list,OS_INT,lenloc,lenreg);
+          end
+        else
+          lenreg:=lenloc.register;
+
+        sizereg:=getintregister(list,OS_INT);
+        a_op_const_reg_reg(list,OP_ADD,OS_INT,1,lenreg,sizereg);
+        a_op_const_reg(list,OP_IMUL,OS_INT,elesize,sizereg);
+        { load source }
+        sourcereg:=getaddressregister(list);
+        a_loadaddr_ref_reg(list,ref,sourcereg);
+
+        { do getmem call }
+        cgpara1.init;
+        paramanager.getintparaloc(pocall_default,1,cgpara1);
+        paramanager.allocparaloc(list,cgpara1);
+        a_param_reg(list,OS_INT,sizereg,cgpara1);
+        paramanager.freeparaloc(list,cgpara1);
+        allocallcpuregisters(list);
+        a_call_name(list,'FPC_GETMEM');
+        deallocallcpuregisters(list);
+        cgpara1.done;
+        { return the new address }
+        a_load_reg_reg(list,OS_ADDR,OS_ADDR,NR_FUNCTION_RESULT_REG,destreg);
+
+        { do move call }
+        cgpara1.init;
+        cgpara2.init;
+        cgpara3.init;
+        paramanager.getintparaloc(pocall_default,1,cgpara1);
+        paramanager.getintparaloc(pocall_default,2,cgpara2);
+        paramanager.getintparaloc(pocall_default,3,cgpara3);
+        { load size }
+        paramanager.allocparaloc(list,cgpara3);
+        a_param_reg(list,OS_INT,sizereg,cgpara3);
+        { load destination }
+        paramanager.allocparaloc(list,cgpara2);
+        a_param_reg(list,OS_ADDR,destreg,cgpara2);
+        { load source }
+        paramanager.allocparaloc(list,cgpara1);
+        a_param_reg(list,OS_ADDR,sourcereg,cgpara1);
+        paramanager.freeparaloc(list,cgpara3);
+        paramanager.freeparaloc(list,cgpara2);
+        paramanager.freeparaloc(list,cgpara1);
+        allocallcpuregisters(list);
+        a_call_name(list,'FPC_MOVE');
+        deallocallcpuregisters(list);
+        cgpara3.done;
+        cgpara2.done;
+        cgpara1.done;
+      end;
+
+
+    procedure tcg.g_releasevaluepara_openarray(list : taasmoutput;const l:tlocation);
+      var
+        cgpara1 : TCGPara;
+      begin
+        { do move call }
+        cgpara1.init;
+        paramanager.getintparaloc(pocall_default,1,cgpara1);
+        { load source }
+        paramanager.allocparaloc(list,cgpara1);
+        a_param_loc(list,l,cgpara1);
+        paramanager.freeparaloc(list,cgpara1);
+        allocallcpuregisters(list);
+        a_call_name(list,'FPC_FREEMEM');
+        deallocallcpuregisters(list);
+        cgpara1.done;
+      end;
+
+
+    procedure tcg.g_save_standard_registers(list:Taasmoutput);
+      var
+        href : treference;
+        size : longint;
+        r : integer;
+      begin
+        { Get temp }
+        size:=0;
+        for r:=low(saved_standard_registers) to high(saved_standard_registers) do
+          if saved_standard_registers[r] in rg[R_INTREGISTER].used_in_proc then
+            inc(size,sizeof(aint));
+        if size>0 then
+          begin
+            tg.GetTemp(list,size,tt_noreuse,current_procinfo.save_regs_ref);
+            { Copy registers to temp }
+            href:=current_procinfo.save_regs_ref;
+
+            for r:=low(saved_standard_registers) to high(saved_standard_registers) do
+              begin
+                if saved_standard_registers[r] in rg[R_INTREGISTER].used_in_proc then
+                  begin
+                    a_load_reg_ref(list,OS_ADDR,OS_ADDR,newreg(R_INTREGISTER,saved_standard_registers[r],R_SUBWHOLE),href);
+                    inc(href.offset,sizeof(aint));
+                  end;
+                include(rg[R_INTREGISTER].preserved_by_proc,saved_standard_registers[r]);
+              end;
+          end;
+      end;
+
+
+    procedure tcg.g_restore_standard_registers(list:Taasmoutput);
+      var
+        href : treference;
+        r : integer;
+        hreg : tregister;
+      begin
+        { Copy registers from temp }
+        href:=current_procinfo.save_regs_ref;
+        for r:=low(saved_standard_registers) to high(saved_standard_registers) do
+          if saved_standard_registers[r] in rg[R_INTREGISTER].used_in_proc then
+            begin
+              hreg:=newreg(R_INTREGISTER,saved_standard_registers[r],R_SUBWHOLE);
+              { Allocate register so the optimizer does remove the load }
+              a_reg_alloc(list,hreg);
+              a_load_ref_reg(list,OS_ADDR,OS_ADDR,href,hreg);
+              inc(href.offset,sizeof(aint));
+            end;
+        tg.UnGetTemp(list,current_procinfo.save_regs_ref);
+      end;
+
+
+    procedure tcg.g_profilecode(list : taasmoutput);
+      begin
+      end;
+
+
+    procedure tcg.g_exception_reason_save(list : taasmoutput; const href : treference);
+      begin
+        a_load_reg_ref(list, OS_INT, OS_INT, NR_FUNCTION_RESULT_REG, href);
+      end;
+
+
+    procedure tcg.g_exception_reason_save_const(list : taasmoutput; const href : treference; a: aint);
+      begin
+        a_load_const_ref(list, OS_INT, a, href);
+      end;
+
+
+    procedure tcg.g_exception_reason_load(list : taasmoutput; const href : treference);
+      begin
+        a_load_ref_reg(list, OS_INT, OS_INT, href, NR_FUNCTION_RESULT_REG);
+      end;
+
+
+    procedure tcg.g_adjust_self_value(list:taasmoutput;procdef: tprocdef;ioffset: aint);
+      var
+        hsym : tsym;
+        href : treference;
+        paraloc : tcgparalocation;
+      begin
+        { calculate the parameter info for the procdef }
+        if not procdef.has_paraloc_info then
+          begin
+            procdef.requiredargarea:=paramanager.create_paraloc_info(procdef,callerside);
+            procdef.has_paraloc_info:=true;
+          end;
+        hsym:=tsym(procdef.parast.search('self'));
+        if not(assigned(hsym) and
+               (hsym.typ=paravarsym)) then
+          internalerror(200305251);
+        paraloc:=tparavarsym(hsym).paraloc[callerside].location^;
+        case paraloc.loc of
+          LOC_REGISTER:
+            cg.a_op_const_reg(list,OP_SUB,paraloc.size,ioffset,paraloc.register);
+          LOC_REFERENCE:
+            begin
+               { offset in the wrapper needs to be adjusted for the stored
+                 return address }
+               reference_reset_base(href,paraloc.reference.index,paraloc.reference.offset+sizeof(aint));
+               cg.a_op_const_ref(list,OP_SUB,paraloc.size,ioffset,href);
+            end
+          else
+            internalerror(200309189);
+        end;
+      end;
+
+{*****************************************************************************
+                                    TCG64
+*****************************************************************************}
+
+{$ifndef cpu64bit}
+    procedure tcg64.a_op64_const_reg_reg(list: taasmoutput;op:TOpCG;size : tcgsize;value : int64; regsrc,regdst : tregister64);
+      begin
+        a_load64_reg_reg(list,regsrc,regdst);
+        a_op64_const_reg(list,op,size,value,regdst);
+      end;
+
+
+    procedure tcg64.a_op64_reg_reg_reg(list: taasmoutput;op:TOpCG;size : tcgsize;regsrc1,regsrc2,regdst : tregister64);
+      var
+        tmpreg64 : tregister64;
+      begin
+        { when src1=dst then we need to first create a temp to prevent
+          overwriting src1 with src2 }
+        if (regsrc1.reghi=regdst.reghi) or
+           (regsrc1.reglo=regdst.reghi) or
+           (regsrc1.reghi=regdst.reglo) or
+           (regsrc1.reglo=regdst.reglo) then
+          begin
+            tmpreg64.reglo:=cg.getintregister(list,OS_32);
+            tmpreg64.reghi:=cg.getintregister(list,OS_32);
+            a_load64_reg_reg(list,regsrc2,tmpreg64);
+            a_op64_reg_reg(list,op,size,regsrc1,tmpreg64);
+            a_load64_reg_reg(list,tmpreg64,regdst);
+          end
+        else
+          begin
+            a_load64_reg_reg(list,regsrc2,regdst);
+            a_op64_reg_reg(list,op,size,regsrc1,regdst);
+          end;
+      end;
+
+
+    procedure tcg64.a_op64_const_reg_reg_checkoverflow(list: taasmoutput;op:TOpCG;size : tcgsize;value : int64;regsrc,regdst : tregister64;setflags : boolean;var ovloc : tlocation);
+      begin
+        a_op64_const_reg_reg(list,op,size,value,regsrc,regdst);
+        ovloc.loc:=LOC_VOID;
+      end;
+
+
+    procedure tcg64.a_op64_reg_reg_reg_checkoverflow(list: taasmoutput;op:TOpCG;size : tcgsize;regsrc1,regsrc2,regdst : tregister64;setflags : boolean;var ovloc : tlocation);
+      begin
+        a_op64_reg_reg_reg(list,op,size,regsrc1,regsrc2,regdst);
+        ovloc.loc:=LOC_VOID;
+      end;
+
+
+{$endif cpu64bit}
+
+
+
+initialization
+    ;
+finalization
+  cg.free;
+{$ifndef cpu64bit}
+  cg64.free;
+{$endif cpu64bit}
+end.

+ 186 - 0
compiler/cgutils.pas

@@ -0,0 +1,186 @@
+{
+    Copyright (c) 1998-2004 by Florian Klaempfl
+
+    Some basic types and constants for the code 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.
+
+ ****************************************************************************
+}
+{ This unit exports some helper routines which are used across the code generator }
+unit cgutils;
+
+{$i fpcdefs.inc}
+
+  interface
+
+    uses
+      globtype,
+      cclasses,
+      aasmbase,
+      cpubase,cgbase;
+
+    type
+      { reference record, reordered for best alignment }
+      preference = ^treference;
+      treference = record
+         offset      : aint;
+         symbol,
+         relsymbol   : tasmsymbol;
+         segment,
+         base,
+         index       : tregister;
+         refaddr     : trefaddr;
+         scalefactor : byte;
+{$ifdef arm}
+         symboldata  : tlinkedlistitem;
+         signindex   : shortint;
+         shiftimm    : byte;
+         addressmode : taddressmode;
+         shiftmode   : tshiftmode;
+{$endif arm}
+{$ifdef m68k}
+         { indexed increment and decrement mode }
+         { (An)+ and -(An)                      }
+         direction : tdirection;
+{$endif m68k}
+      end;
+
+      tlocation = record
+         loc  : TCGLoc;
+         size : TCGSize;
+         case TCGLoc of
+            LOC_FLAGS : (resflags : tresflags);
+            LOC_CONSTANT : (
+              case longint of
+{$ifdef FPC_BIG_ENDIAN}
+                1 : (_valuedummy,value : aint);
+{$else FPC_BIG_ENDIAN}
+                1 : (value : aint);
+{$endif FPC_BIG_ENDIAN}
+                2 : (value64 : Int64);
+              );
+            LOC_CREFERENCE,
+            LOC_REFERENCE : (reference : treference);
+            { segment in reference at the same place as in loc_register }
+            LOC_REGISTER,
+            LOC_CREGISTER : (
+              case longint of
+                1 : (register : tregister;
+{$ifdef m68k}
+                     { some m68k OSes require that the result is returned in d0 and a0
+                       the second location must be stored here }
+                     registeralias : tregister;
+{$endif m68k}
+                    );
+{$ifndef cpu64bit}
+                { overlay a 64 Bit register type }
+                2 : (register64 : tregister64);
+{$endif cpu64bit}
+              );
+      end;
+
+
+    { trerefence handling }
+
+    {# Clear to zero a treference }
+    procedure reference_reset(var ref : treference);
+    {# Clear to zero a treference, and set is base address
+       to base register.
+    }
+    procedure reference_reset_base(var ref : treference;base : tregister;offset : longint);
+    procedure reference_reset_symbol(var ref : treference;sym : tasmsymbol;offset : longint);
+    { This routine verifies if two references are the same, and
+       if so, returns TRUE, otherwise returns false.
+    }
+    function references_equal(sref : treference;dref : treference) : boolean;
+
+    { tlocation handling }
+
+    procedure location_reset(var l : tlocation;lt:TCGLoc;lsize:TCGSize);
+    procedure location_copy(var destloc:tlocation; const sourceloc : tlocation);
+    procedure location_swap(var destloc,sourceloc : tlocation);
+
+implementation
+
+{****************************************************************************
+                                  TReference
+****************************************************************************}
+
+    procedure reference_reset(var ref : treference);
+      begin
+        FillChar(ref,sizeof(treference),0);
+{$ifdef arm}
+        ref.signindex:=1;
+{$endif arm}
+      end;
+
+
+    procedure reference_reset_base(var ref : treference;base : tregister;offset : longint);
+      begin
+        reference_reset(ref);
+        ref.base:=base;
+        ref.offset:=offset;
+      end;
+
+
+    procedure reference_reset_symbol(var ref : treference;sym : tasmsymbol;offset : longint);
+      begin
+        reference_reset(ref);
+        ref.symbol:=sym;
+        ref.offset:=offset;
+      end;
+
+
+    function references_equal(sref : treference;dref : treference):boolean;
+      begin
+        references_equal:=CompareByte(sref,dref,sizeof(treference))=0;
+      end;
+
+
+{****************************************************************************
+                                  TLocation
+****************************************************************************}
+
+    procedure location_reset(var l : tlocation;lt:TCGLoc;lsize:TCGSize);
+      begin
+        FillChar(l,sizeof(tlocation),0);
+        l.loc:=lt;
+        l.size:=lsize;
+{$ifdef arm}
+        if l.loc in [LOC_REFERENCE,LOC_CREFERENCE] then
+          l.reference.signindex:=1;
+{$endif arm}
+      end;
+
+
+    procedure location_copy(var destloc:tlocation; const sourceloc : tlocation);
+      begin
+        destloc:=sourceloc;
+      end;
+
+
+    procedure location_swap(var destloc,sourceloc : tlocation);
+      var
+        swapl : tlocation;
+      begin
+        swapl := destloc;
+        destloc := sourceloc;
+        sourceloc := swapl;
+      end;
+
+
+
+end.

+ 252 - 0
compiler/charset.pas

@@ -0,0 +1,252 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2000 by Florian Klaempfl
+    member of the Free Pascal development team.
+
+    This unit implements several classes for charset conversions
+
+    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 charset;
+
+{$i fpcdefs.inc}
+
+  interface
+
+    type
+       tunicodechar = word;
+       tunicodestring = ^tunicodechar;
+
+       tcsconvert = class
+         // !!!!!!1constructor create;
+       end;
+
+       tunicodecharmappingflag = (umf_noinfo,umf_leadbyte,umf_undefined,
+         umf_unused);
+
+       punicodecharmapping = ^tunicodecharmapping;
+       tunicodecharmapping = record
+          unicode : tunicodechar;
+          flag : tunicodecharmappingflag;
+          reserved : byte;
+       end;
+
+       punicodemap = ^tunicodemap;
+       tunicodemap = record
+          cpname : string[20];
+          map : punicodecharmapping;
+          lastchar : longint;
+          next : punicodemap;
+          internalmap : boolean;
+       end;
+
+       tcp2unicode = class(tcsconvert)
+       end;
+
+    function loadunicodemapping(const cpname,f : string) : punicodemap;
+    procedure registermapping(p : punicodemap);
+    function getmap(const s : string) : punicodemap;
+    function mappingavailable(const s : string) : boolean;
+    function getunicode(c : char;p : punicodemap) : tunicodechar;
+    function getascii(c : tunicodechar;p : punicodemap) : string;
+
+  implementation
+
+    var
+       mappings : punicodemap;
+
+    function loadunicodemapping(const cpname,f : string) : punicodemap;
+
+      var
+         data : punicodecharmapping;
+         datasize : longint;
+         t : text;
+         s,hs : string;
+         scanpos,charpos,unicodevalue : longint;
+         code : integer;
+         flag : tunicodecharmappingflag;
+         p : punicodemap;
+         lastchar : longint;
+
+      begin
+         lastchar:=-1;
+         loadunicodemapping:=nil;
+         datasize:=256;
+         getmem(data,sizeof(tunicodecharmapping)*datasize);
+         assign(t,f);
+         {$I-}
+         reset(t);
+         {$I+}
+         if ioresult<>0 then
+           begin
+              freemem(data,sizeof(tunicodecharmapping)*datasize);
+              exit;
+           end;
+         while not(eof(t)) do
+           begin
+              readln(t,s);
+              if (s[1]='0') and (s[2]='x') then
+                begin
+                   flag:=umf_unused;
+                   scanpos:=3;
+                   hs:='$';
+                   while s[scanpos] in ['0'..'9','A'..'F','a'..'f'] do
+                     begin
+                        hs:=hs+s[scanpos];
+                        inc(scanpos);
+                     end;
+                   val(hs,charpos,code);
+                   if code<>0 then
+                     begin
+                        freemem(data,sizeof(tunicodecharmapping)*datasize);
+                        close(t);
+                        exit;
+                     end;
+                   while not(s[scanpos] in ['0','#']) do
+                     inc(scanpos);
+                   if s[scanpos]='#' then
+                     begin
+                        { special char }
+                        unicodevalue:=$ffff;
+                        hs:=copy(s,scanpos,length(s)-scanpos+1);
+                        if hs='#DBCS LEAD BYTE' then
+                          flag:=umf_leadbyte;
+                     end
+                   else
+                     begin
+                        { C hex prefix }
+                        inc(scanpos,2);
+                        hs:='$';
+                        while s[scanpos] in ['0'..'9','A'..'F','a'..'f'] do
+                          begin
+                             hs:=hs+s[scanpos];
+                             inc(scanpos);
+                          end;
+                        val(hs,unicodevalue,code);
+                        if code<>0 then
+                          begin
+                             freemem(data,sizeof(tunicodecharmapping)*datasize);
+                             close(t);
+                             exit;
+                          end;
+                        if charpos>datasize then
+                          begin
+                             { allocate 1024 bytes more because         }
+                             { if we need more than 256 entries it's    }
+                             { probably a mbcs with a lot of            }
+                             { entries                                  }
+                             datasize:=charpos+1024;
+                             reallocmem(data,sizeof(tunicodecharmapping)*datasize);
+                          end;
+                        flag:=umf_noinfo;
+                     end;
+                   data[charpos].flag:=flag;
+                   data[charpos].unicode:=unicodevalue;
+                   if charpos>lastchar then
+                     lastchar:=charpos;
+                end;
+           end;
+         close(t);
+         new(p);
+         p^.lastchar:=lastchar;
+         p^.cpname:=cpname;
+         p^.internalmap:=false;
+         p^.next:=nil;
+         p^.map:=data;
+         loadunicodemapping:=p;
+      end;
+
+    procedure registermapping(p : punicodemap);
+
+      begin
+         p^.next:=mappings;
+         mappings:=p;
+      end;
+
+    function getmap(const s : string) : punicodemap;
+
+      var
+         hp : punicodemap;
+
+      const
+         mapcachep : punicodemap = nil;
+
+      begin
+         if assigned(mapcachep) and
+            (mapcachep^.cpname=s) then
+           begin
+              getmap:=mapcachep;
+              exit;
+           end;
+         hp:=mappings;
+         while assigned(hp) do
+           begin
+              if hp^.cpname=s then
+                begin
+                   getmap:=hp;
+                   mapcachep:=hp;
+                   exit;
+                end;
+              hp:=hp^.next;
+           end;
+         getmap:=nil;
+      end;
+
+    function mappingavailable(const s : string) : boolean;
+
+      begin
+         mappingavailable:=getmap(s)<>nil;
+      end;
+
+    function getunicode(c : char;p : punicodemap) : tunicodechar;
+
+      begin
+         if ord(c)<=p^.lastchar then
+           getunicode:=p^.map[ord(c)].unicode
+         else
+           getunicode:=0;
+      end;
+
+    function getascii(c : tunicodechar;p : punicodemap) : string;
+
+      var
+         i : longint;
+
+      begin
+         { at least map to space }
+         getascii:=#32;
+         for i:=0 to p^.lastchar do
+           if p^.map[i].unicode=c then
+             begin
+                if i<256 then
+                  getascii:=chr(i)
+                else
+                  getascii:=chr(i div 256)+chr(i mod 256);
+                exit;
+             end;
+      end;
+
+  var
+     hp : punicodemap;
+
+initialization
+  mappings:=nil;
+finalization
+  while assigned(mappings) do
+    begin
+       hp:=mappings^.next;
+       if not(mappings^.internalmap) then
+         begin
+            freemem(mappings^.map);
+            dispose(mappings);
+         end;
+       mappings:=hp;
+    end;
+end.

+ 413 - 0
compiler/cmsgs.pas

@@ -0,0 +1,413 @@
+{
+    Copyright (c) 1998-2002 by Peter Vreman
+
+    This unit implements the message 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.
+
+ ****************************************************************************
+}
+unit cmsgs;
+
+{$i fpcdefs.inc}
+
+interface
+
+const
+  maxmsgidxparts = 20;
+
+type
+  ppchar=^pchar;
+
+  TArrayOfPChar = array[0..1000] of pchar;
+  PArrayOfPChar = ^TArrayOfPChar;
+
+  PMessage=^TMessage;
+  TMessage=object
+    msgfilename : string;
+    msgintern   : boolean;
+    msgallocsize,
+    msgsize,
+    msgparts,
+    msgs        : longint;
+    msgtxt      : pchar;
+    msgidx      : array[1..maxmsgidxparts] of PArrayOfPChar;
+    msgidxmax   : array[1..maxmsgidxparts] of longint;
+    constructor Init(n:longint;const idxmax:array of longint);
+    destructor  Done;
+    function  LoadIntern(p:pointer;n:longint):boolean;
+    function  LoadExtern(const fn:string):boolean;
+    procedure ClearIdx;
+    procedure CreateIdx;
+    function  GetPChar(nr:longint):pchar;
+    function  Get(nr:longint;const args:array of string):string;
+  end;
+
+{ this will read a line until #10 or #0 and also increase p }
+function GetMsgLine(var p:pchar):string;
+
+
+implementation
+
+uses
+  cutils,
+  strings;
+
+
+function MsgReplace(const s:string;const args:array of string):string;
+var
+  last,
+  i  : longint;
+  hs : string;
+
+begin
+  if s='' then
+    begin
+      MsgReplace:='';
+      exit;
+    end;
+  hs:='';
+  i:=0;
+  last:=0;
+  while (i<length(s)-1) do
+    begin
+      inc(i);
+      if (s[i]='$') and (s[i+1] in ['1'..'9']) then
+        begin
+          hs:=hs+copy(s,last+1,i-last-1)+args[byte(s[i+1])-byte('1')];
+          inc(i);
+          last:=i;
+        end;
+    end;
+  MsgReplace:=hs+copy(s,last+1,length(s)-last);;
+end;
+
+
+
+constructor TMessage.Init(n:longint;const idxmax:array of longint);
+var
+  i : longint;
+begin
+  msgtxt:=nil;
+  msgsize:=0;
+  msgparts:=n;
+  if n<>high(idxmax)+1 then
+   fail;
+  for i:=1 to n do
+   begin
+     msgidxmax[i]:=idxmax[i-1];
+     getmem(msgidx[i],msgidxmax[i]*sizeof(pointer));
+     fillchar(msgidx[i]^,msgidxmax[i]*sizeof(pointer),0);
+   end;
+end;
+
+
+destructor TMessage.Done;
+var
+  i : longint;
+begin
+  for i:=1 to msgparts do
+   freemem(msgidx[i],msgidxmax[i]*sizeof(pointer));
+  if msgallocsize>0 then
+   begin
+     freemem(msgtxt,msgsize);
+     msgallocsize:=0;
+   end;
+  msgtxt:=nil;
+  msgsize:=0;
+  msgparts:=0;
+end;
+
+
+function TMessage.LoadIntern(p:pointer;n:longint):boolean;
+begin
+  msgtxt:=pchar(p);
+  msgsize:=n;
+  msgallocsize:=0;
+  msgintern:=true;
+  ClearIdx;
+  CreateIdx;
+  LoadIntern:=true;
+end;
+
+
+function TMessage.LoadExtern(const fn:string):boolean;
+
+{$ifndef FPC}
+  procedure readln(var t:text;var s:string);
+  var
+    c : char;
+    i : longint;
+  begin
+    c:=#0;
+    i:=0;
+    while (not eof(t)) and (c<>#10) do
+     begin
+       read(t,c);
+       if c<>#10 then
+        begin
+          inc(i);
+          s[i]:=c;
+        end;
+     end;
+    if (i>0) and (s[i]=#13) then
+     dec(i);
+    s[0]:=chr(i);
+  end;
+{$endif}
+
+const
+  bufsize=8192;
+var
+  f       : text;
+  error,multiline : boolean;
+  line,i,j : longint;
+  ptxt    : pchar;
+  s,s1    : string;
+  buf     : pointer;
+
+  procedure err(const msgstr:string);
+  begin
+    writeln('*** PPC, file ',fn,', error in line ',line,': ',msgstr);
+    error:=true;
+  end;
+
+begin
+  LoadExtern:=false;
+  getmem(buf,bufsize);
+  { Read the message file }
+  assign(f,fn);
+  {$I-}
+   reset(f);
+  {$I+}
+  if ioresult<>0 then
+   begin
+     WriteLn('*** PPC, can not open message file ',fn);
+     exit;
+   end;
+  settextbuf(f,buf^,bufsize);
+  { First parse the file and count bytes needed }
+  error:=false;
+  line:=0;
+  multiline:=false;
+  msgsize:=0;
+  while not eof(f) do
+   begin
+     readln(f,s);
+     inc(line);
+     if multiline then
+      begin
+        if s=']' then
+         multiline:=false
+        else
+         inc(msgsize,length(s)+1); { +1 for linebreak }
+      end
+     else
+      begin
+        if (s<>'') and not(s[1] in ['#',';','%']) then
+         begin
+           i:=pos('=',s);
+           if i>0 then
+            begin
+              j:=i+1;
+              if not(s[j] in ['0'..'9']) then
+               err('no number found')
+              else
+               begin
+                 while (s[j] in ['0'..'9']) do
+                  inc(j);
+               end;
+              if j-i-1<>5 then
+               err('number length is not 5');
+              if s[j+1]='[' then
+               begin
+                 inc(msgsize,j-i);
+                 multiline:=true
+               end
+              else
+               inc(msgsize,length(s)-i+1);
+            end
+           else
+            err('no = found');
+         end;
+      end;
+   end;
+  if multiline then
+   err('still in multiline mode');
+  if error then
+   begin
+     freemem(buf,bufsize);
+     close(f);
+     exit;
+   end;
+  { now read the buffer in mem }
+  msgallocsize:=msgsize;
+  getmem(msgtxt,msgallocsize);
+  ptxt:=msgtxt;
+  reset(f);
+  while not eof(f) do
+   begin
+     readln(f,s);
+     if multiline then
+      begin
+        if s=']' then
+         begin
+           multiline:=false;
+           { overwrite last eol }
+           dec(ptxt);
+           ptxt^:=#0;
+           inc(ptxt);
+         end
+        else
+         begin
+           move(s[1],ptxt^,length(s));
+           inc(ptxt,length(s));
+           ptxt^:=#10;
+           inc(ptxt);
+         end;
+      end
+     else
+      begin
+        if (s<>'') and not(s[1] in ['#',';','%']) then
+         begin
+           i:=pos('=',s);
+           if i>0 then
+            begin
+              j:=i+1;
+              while (s[j] in ['0'..'9']) do
+               inc(j);
+              { multiline start then no txt }
+              if s[j+1]='[' then
+               begin
+                 s1:=Copy(s,i+1,j-i);
+                 move(s1[1],ptxt^,length(s1));
+                 inc(ptxt,length(s1));
+                 multiline:=true;
+               end
+              else
+               begin
+                 { txt including number }
+                 s1:=Copy(s,i+1,255);
+                 move(s1[1],ptxt^,length(s1));
+                 inc(ptxt,length(s1));
+                 ptxt^:=#0;
+                 inc(ptxt);
+               end;
+            end;
+         end;
+      end;
+   end;
+  close(f);
+  freemem(buf,bufsize);
+{ now we can create the index, clear if the previous load was also
+  an external file, because those can't be reused }
+  if not msgintern then
+   ClearIdx;
+  CreateIdx;
+{ set that we've loaded an external file }
+  msgintern:=false;
+  LoadExtern:=true;
+end;
+
+
+procedure TMessage.ClearIdx;
+var
+  i : longint;
+begin
+  { clear }
+  for i:=1 to msgparts do
+   fillchar(msgidx[i]^,msgidxmax[i]*sizeof(pointer),0);
+end;
+
+
+procedure TMessage.CreateIdx;
+var
+  hp1,
+  hp,hpend : pchar;
+  code : integer;
+  num  : longint;
+  number : string[5];
+  i   : longint;
+  numpart,numidx : longint;
+begin
+  { process msgtxt buffer }
+  number:='00000';
+  hp:=msgtxt;
+  hpend:=@msgtxt[msgsize];
+  while (hp<hpend) do
+   begin
+     hp1:=hp;
+     for i:=1 to 5 do
+      begin
+        number[i]:=hp1^;
+        inc(hp1);
+      end;
+     val(number,num,code);
+     numpart:=num div 1000;
+     numidx:=num mod 1000;
+     { check range }
+     if (numpart <= msgparts) and (numidx < msgidxmax[numpart]) then
+      begin
+        { skip _ }
+        inc(hp1);
+        { put the address in the idx, the numbers are already checked }
+        msgidx[numpart]^[numidx]:=hp1;
+      end;
+     { next string }
+     hp:=pchar(@hp[strlen(hp)+1]);
+   end;
+end;
+
+
+function GetMsgLine(var p:pchar):string;
+var
+  i  : longint;
+begin
+  i:=0;
+  while not(p^ in [#0,#10]) and (i<255) do
+   begin
+     inc(i);
+     GetMsgLine[i]:=p^;
+     inc(p);
+   end;
+  { skip #10 }
+  if p^=#10 then
+   inc(p);
+  { if #0 then set p to nil }
+  if p^=#0 then
+   p:=nil;
+  { return string }
+  GetMsgLine[0]:=chr(i);
+end;
+
+
+function TMessage.GetPChar(nr:longint):pchar;
+begin
+  GetPChar:=msgidx[nr div 1000]^[nr mod 1000];
+end;
+
+
+function TMessage.Get(nr:longint;const args:array of string):string;
+var
+  hp : pchar;
+begin
+  hp:=msgidx[nr div 1000]^[nr mod 1000];
+  if hp=nil then
+    Get:='msg nr '+tostr(nr)
+  else
+    Get:=MsgReplace(strpas(hp),args);
+end;
+
+end.

+ 413 - 0
compiler/comphook.pas

@@ -0,0 +1,413 @@
+{
+    Copyright (c) 1998-2002 by Peter Vreman
+
+    This unit handles the compilerhooks for output to external programs
+
+    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 comphook;
+
+{$i fpcdefs.inc}
+
+interface
+
+uses
+{$IFNDEF MACOS_USE_FAKE_SYSUTILS}
+  SysUtils,
+{$ELSE}
+  globals,
+{$ENDIF}
+  finput;
+
+Const
+  { Levels }
+  V_None         = $0;
+  V_Fatal        = $1;
+  V_Error        = $2;
+  V_Normal       = $4; { doesn't show a text like Error: }
+  V_Warning      = $8;
+  V_Note         = $10;
+  V_Hint         = $20;
+  V_LineInfoMask = $fff;
+  { From here by default no line info }
+  V_Info         = $1000;
+  V_Status       = $2000;
+  V_Used         = $4000;
+  V_Tried        = $8000;
+  V_Conditional  = $10000;
+  V_Debug        = $20000;
+  V_Executable   = $40000;
+  V_LevelMask    = $fffffff;
+  V_All          = V_LevelMask;
+  V_Default      = V_Fatal + V_Error + V_Normal;
+  { Flags }
+  V_LineInfo     = $10000000;
+
+const
+  { RHIDE expect gcc like error output }
+  fatalstr      : string[20] = 'Fatal:';
+  errorstr      : string[20] = 'Error:';
+  warningstr    : string[20] = 'Warning:';
+  notestr       : string[20] = 'Note:';
+  hintstr       : string[20] = 'Hint:';
+
+type
+  PCompilerStatus = ^TCompilerStatus;
+  TCompilerStatus = record
+  { Current status }
+    currentmodule,
+    currentsourcepath,
+    currentsource : string;   { filename }
+    currentline,
+    currentcolumn : longint;  { current line and column }
+  { Total Status }
+    compiledlines : longint;  { the number of lines which are compiled }
+    errorcount    : longint;  { number of generated errors }
+  { program info }
+    isexe,
+    islibrary     : boolean;
+  { Settings for the output }
+    verbosity     : longint;
+    maxerrorcount : longint;
+    errorwarning,
+    errornote,
+    errorhint,
+    skip_error,
+    use_stderr,
+    use_redir,
+    use_bugreport,
+    use_gccoutput,
+    print_source_path,
+    compiling_current : boolean;
+  { Redirection support }
+    redirfile : text;
+  { Special file for bug report }
+    reportbugfile : text;
+  end;
+var
+  status : tcompilerstatus;
+
+    type
+      EControlCAbort=class(Exception)
+        constructor Create;
+      end;
+      ECompilerAbort=class(Exception)
+        constructor Create;
+      end;
+      ECompilerAbortSilent=class(Exception)
+        constructor Create;
+      end;
+
+{ Default Functions }
+Function  def_status:boolean;
+Function  def_comment(Level:Longint;const s:string):boolean;
+function  def_internalerror(i: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 redirecting for IDE support }
+type
+  tstopprocedure         = procedure(err:longint);
+  tstatusfunction        = function:boolean;
+  tcommentfunction       = function(Level:Longint;const s:string):boolean;
+  tinternalerrorfunction = function(i:longint):boolean;
+
+  tinitsymbolinfoproc = procedure;
+  tdonesymbolinfoproc = procedure;
+  textractsymbolinfoproc = procedure;
+  topeninputfilefunc = function(const filename: string): tinputfile;
+  tgetnamedfiletimefunc = function(const filename: string): longint;
+
+const
+  do_status        : tstatusfunction  = @def_status;
+  do_comment       : tcommentfunction = @def_comment;
+  do_internalerror : tinternalerrorfunction = @def_internalerror;
+
+  do_initsymbolinfo : tinitsymbolinfoproc = @def_initsymbolinfo;
+  do_donesymbolinfo : tdonesymbolinfoproc = @def_donesymbolinfo;
+  do_extractsymbolinfo : textractsymbolinfoproc = @def_extractsymbolinfo;
+
+  do_openinputfile : topeninputfilefunc = @def_openinputfile;
+  do_getnamedfiletime : tgetnamedfiletimefunc = @def_getnamedfiletime;
+
+implementation
+
+  uses
+{$IFNDEF USE_SYSUTILS}
+   dos,
+{$ENDIF USE_SYSUTILS}
+   cutils
+   ;
+
+{****************************************************************************
+                          Helper Routines
+****************************************************************************}
+
+function gccfilename(const s : string) : string;
+var
+  i : longint;
+begin
+  for i:=1to length(s) do
+   begin
+     case s[i] of
+      '\' : gccfilename[i]:='/';
+ 'A'..'Z' : gccfilename[i]:=chr(ord(s[i])+32);
+     else
+      gccfilename[i]:=s[i];
+     end;
+   end;
+  gccfilename[0]:=s[0];
+end;
+
+
+function tostr(i : longint) : string;
+var
+  hs : string;
+begin
+  str(i,hs);
+  tostr:=hs;
+end;
+
+
+{****************************************************************************
+                          Stopping the compiler
+****************************************************************************}
+
+     constructor EControlCAbort.Create;
+       begin
+{$IFNDEF MACOS_USE_FAKE_SYSUTILS}
+         inherited Create('Ctrl-C Signaled!');
+{$ELSE}
+         inherited Create;
+{$ENDIF}
+       end;
+
+
+     constructor ECompilerAbort.Create;
+       begin
+{$IFNDEF MACOS_USE_FAKE_SYSUTILS}
+         inherited Create('Compilation Aborted');
+{$ELSE}
+         inherited Create;
+{$ENDIF}
+       end;
+
+
+     constructor ECompilerAbortSilent.Create;
+       begin
+{$IFNDEF MACOS_USE_FAKE_SYSUTILS}
+         inherited Create('Compilation Aborted');
+{$ELSE}
+         inherited Create;
+{$ENDIF}
+       end;
+
+
+{****************************************************************************
+                         Predefined default Handlers
+****************************************************************************}
+
+function def_status:boolean;
+var
+  hstatus : TFPCHeapStatus;
+begin
+  def_status:=false; { never stop }
+{ Status info?, Called every line }
+  if ((status.verbosity and V_Status)<>0) then
+   begin
+     if (status.compiledlines=1) or
+        (status.currentline mod 100=0) then
+       begin
+         if status.currentline>0 then
+           Write(status.currentline,' ');
+         hstatus:=GetFPCHeapStatus;
+         WriteLn(DStr(hstatus.CurrHeapUsed shr 10),'/',DStr(hstatus.CurrHeapSize shr 10),' Kb Used');
+       end;
+   end;
+{$ifdef macos}
+  Yield;
+{$endif}
+end;
+
+
+Function def_comment(Level:Longint;const s:string):boolean;
+const
+  rh_errorstr   = 'error:';
+  rh_warningstr = 'warning:';
+var
+  hs : string;
+begin
+  def_comment:=false; { never stop }
+  hs:='';
+  if not(status.use_gccoutput) then
+    begin
+      if (status.verbosity and Level)=V_Hint then
+        hs:=hintstr;
+      if (status.verbosity and Level)=V_Note then
+        hs:=notestr;
+      if (status.verbosity and Level)=V_Warning then
+        hs:=warningstr;
+      if (status.verbosity and Level)=V_Error then
+        hs:=errorstr;
+      if (status.verbosity and Level)=V_Fatal then
+        hs:=fatalstr;
+      if (status.verbosity and Level)=V_Used then
+        hs:=PadSpace('('+status.currentmodule+')',10);
+    end
+  else
+    begin
+      if (status.verbosity and Level)=V_Hint then
+        hs:=rh_warningstr;
+      if (status.verbosity and Level)=V_Note then
+        hs:=rh_warningstr;
+      if (status.verbosity and Level)=V_Warning then
+        hs:=rh_warningstr;
+      if (status.verbosity and Level)=V_Error then
+        hs:=rh_errorstr;
+      if (status.verbosity and Level)=V_Fatal then
+        hs:=rh_errorstr;
+    end;
+  { Generate line prefix }
+  if ((Level and V_LineInfo)=V_LineInfo) and
+     (status.currentsource<>'') and
+     (status.currentline>0) then
+   begin
+     {$ifndef macos}
+     { Adding the column should not confuse RHIDE,
+     even if it does not yet use it PM
+     but only if it is after error or warning !! PM }
+     if status.currentcolumn>0 then
+      begin
+        if status.use_gccoutput then
+          hs:=gccfilename(status.currentsource)+':'+tostr(status.currentline)+': '+hs+' '+
+              tostr(status.currentcolumn)+': '+s
+        else
+          begin
+            hs:=status.currentsource+'('+tostr(status.currentline)+
+              ','+tostr(status.currentcolumn)+') '+hs+' '+s;
+            if status.print_source_path then
+              hs:=status.currentsourcepath+hs;
+          end;
+      end
+     else
+      begin
+        if status.use_gccoutput then
+          hs:=gccfilename(status.currentsource)+': '+hs+' '+tostr(status.currentline)+': '+s
+        else
+          hs:=status.currentsource+'('+tostr(status.currentline)+') '+hs+' '+s;
+      end;
+     {$else}
+     {MPW style error}
+     if status.currentcolumn>0 then
+       hs:='File "'+status.currentsourcepath+status.currentsource+'"; Line '+tostr(status.currentline)+
+         ' #[' + tostr(status.currentcolumn) + '] ' +hs+' '+s
+     else
+       hs:='File "'+status.currentsourcepath+status.currentsource+'"; Line '+tostr(status.currentline)+' # '+hs+' '+s;
+     {$endif}
+   end
+  else
+   begin
+     if hs<>'' then
+      hs:=hs+' '+s
+     else
+      hs:=s;
+   end;
+
+  { Display line }
+  if ((status.verbosity and (Level and V_LevelMask))=(Level and V_LevelMask)) then
+   begin
+{$ifdef FPC}
+     if status.use_stderr then
+      begin
+        writeln(stderr,hs);
+        flush(stderr);
+      end
+     else
+{$endif}
+      begin
+        if status.use_redir then
+         writeln(status.redirfile,hs)
+        else
+         writeln(hs);
+      end;
+   end;
+  { include everything in the bugreport file }
+  if status.use_bugreport then
+   begin
+{$ifdef FPC}
+     Write(status.reportbugfile,hexstr(level,8)+':');
+     Writeln(status.reportbugfile,hs);
+{$endif}
+   end;
+end;
+
+
+function def_internalerror(i : longint) : boolean;
+begin
+  do_comment(V_Fatal+V_LineInfo,'Internal error '+tostr(i));
+{$ifdef EXTDEBUG}
+  {$ifdef FPC}
+    { Internalerror() and def_internalerror() do not
+      have a stackframe }
+    dump_stack(stdout,get_caller_frame(get_frame));
+  {$endif FPC}
+{$endif EXTDEBUG}
+  def_internalerror:=true;
+end;
+
+procedure def_initsymbolinfo;
+begin
+end;
+
+procedure def_donesymbolinfo;
+begin
+end;
+
+procedure def_extractsymbolinfo;
+begin
+end;
+
+function  def_openinputfile(const filename: string): tinputfile;
+begin
+  def_openinputfile:=tdosinputfile.create(filename);
+end;
+
+
+Function def_GetNamedFileTime (Const F : String) : Longint;
+var
+{$IFDEF USE_SYSUTILS}
+  fh : THandle;
+{$ELSE USE_SYSUTILS}
+  info : SearchRec;
+{$ENDIF USE_SYSUTILS}
+begin
+  Result := -1;
+{$IFDEF USE_SYSUTILS}
+  fh := FileOpen(f, faArchive+faReadOnly+faHidden);
+  Result := FileGetDate(fh);
+  FileClose(fh);
+{$ELSE USE_SYSUTILS}
+  FindFirst (F,archive+readonly+hidden,info);
+  if DosError=0 then
+    Result := info.time;
+  FindClose(info);
+{$ENDIF USE_SYSUTILS}
+end;
+
+end.

+ 450 - 0
compiler/compiler.pas

@@ -0,0 +1,450 @@
+{
+    This unit is the interface of the compiler which can be used by
+    external programs to link in the compiler
+
+    Copyright (c) 1998-2005 by Florian Klaempfl
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************}
+
+unit compiler;
+
+{$i fpcdefs.inc}
+
+{$ifdef FPC}
+   { One of Alpha, I386 or M68K must be defined }
+   {$UNDEF CPUOK}
+
+   {$ifdef I386}
+   {$define CPUOK}
+   {$endif}
+
+   {$ifdef M68K}
+   {$ifndef CPUOK}
+   {$DEFINE CPUOK}
+   {$else}
+     {$fatal cannot define two CPU switches}
+   {$endif}
+   {$endif}
+
+   {$ifdef alpha}
+   {$ifndef CPUOK}
+   {$DEFINE CPUOK}
+   {$else}
+     {$fatal cannot define two CPU switches}
+   {$endif}
+   {$endif}
+
+   {$ifdef vis}
+   {$ifndef CPUOK}
+   {$DEFINE CPUOK}
+   {$else}
+     {$fatal cannot define two CPU switches}
+   {$endif}
+   {$endif}
+
+
+   {$ifdef powerpc}
+   {$ifndef CPUOK}
+   {$DEFINE CPUOK}
+   {$else}
+     {$fatal cannot define two CPU switches}
+   {$endif}
+   {$endif}
+   
+   {$ifdef POWERPC64}
+   {$ifndef CPUOK}
+   {$DEFINE CPUOK}
+   {$else}
+     {$fatal cannot define two CPU switches}
+   {$endif}
+   {$endif}   
+
+   {$ifdef ia64}
+   {$ifndef CPUOK}
+   {$DEFINE CPUOK}
+   {$else}
+     {$fatal cannot define two CPU switches}
+   {$endif}
+   {$endif}
+
+   {$ifdef SPARC}
+   {$ifndef CPUOK}
+   {$DEFINE CPUOK}
+   {$else}
+     {$fatal cannot define two CPU switches}
+   {$endif}
+   {$endif}
+
+   {$ifdef x86_64}
+   {$ifndef CPUOK}
+   {$DEFINE CPUOK}
+   {$else}
+     {$fatal cannot define two CPU switches}
+   {$endif}
+   {$endif}
+
+   {$ifdef ARM}
+   {$ifndef CPUOK}
+   {$DEFINE CPUOK}
+   {$else}
+     {$fatal cannot define two CPU switches}
+   {$endif ARM}
+   {$endif ARM}
+
+
+   {$ifdef MIPS}
+   {$ifndef CPUOK}
+   {$DEFINE CPUOK}
+   {$else}
+     {$fatal cannot define two CPU switches}
+   {$endif MIPS}
+   {$endif MIPS}
+
+   {$ifndef CPUOK}
+   {$fatal One of the switches I386, iA64, Alpha, PowerPC or M68K must be defined}
+   {$endif}
+
+   {$ifdef support_mmx}
+     {$ifndef i386}
+       {$fatal I386 switch must be on for MMX support}
+     {$endif i386}
+   {$endif support_mmx}
+{$endif}
+
+interface
+
+uses
+{$ifdef fpc}
+  {$ifdef GO32V2}
+    emu387,
+  {$endif GO32V2}
+  {$ifdef WATCOM} // wiktor: pewnie nie potrzeba
+    emu387,
+{    dpmiexcp, }
+  {$endif WATCOM}
+{$endif}
+{$ifdef BrowserLog}
+  browlog,
+{$endif BrowserLog}
+{$IFDEF USE_SYSUTILS}
+{$ELSE USE_SYSUTILS}
+  dos,
+{$ENDIF USE_SYSUTILS}
+{$IFNDEF MACOS_USE_FAKE_SYSUTILS}
+  sysutils,
+{$ENDIF MACOS_USE_FAKE_SYSUTILS}
+  verbose,comphook,systems,
+  cutils,cclasses,globals,options,fmodule,parser,symtable,
+  assemble,link,dbgbase,import,export,tokens,pass_1
+  { cpu specific commandline options }
+  ,cpuswtch
+  { cpu parameter handling }
+  ,cpupara
+  { procinfo stuff }
+  ,cpupi
+  { cpu codegenerator }
+  ,cgcpu
+{$ifndef NOPASS2}
+  ,cpunode
+{$endif}
+  { cpu targets }
+  ,cputarg
+  { system information for source system }
+  { the information about the target os  }
+  { are pulled in by the t_* units       }
+{$ifdef amiga}
+  ,i_amiga
+{$endif amiga}
+{$ifdef atari}
+  ,i_atari
+{$endif atari}
+{$ifdef beos}
+  ,i_beos
+{$endif beos}
+{$ifdef fbsd}
+  ,i_fbsd
+{$endif fbsd}
+{$ifdef gba}
+  ,i_gba
+{$endif gba}
+{$ifdef go32v2}
+  ,i_go32v2
+{$endif go32v2}
+{$ifdef linux}
+  ,i_linux
+{$endif linux}
+{$ifdef macos}
+  ,i_macos
+{$endif macos}
+{$ifdef nwm}
+  ,i_nwm
+{$endif nwm}
+{$ifdef nwl}
+  ,i_nwl
+{$endif nwm}
+{$ifdef os2}
+ {$ifdef emx}
+  ,i_emx
+ {$else emx}
+  ,i_os2
+ {$endif emx}
+{$endif os2}
+{$ifdef palmos}
+  ,i_palmos
+{$endif palmos}
+{$ifdef solaris}
+  ,i_sunos
+{$endif solaris}
+{$ifdef wdosx}
+  ,i_wdosx
+{$endif wdosx}
+{$ifdef win32}
+  ,i_win
+{$endif win32}
+  ;
+
+function Compile(const cmd:string):longint;
+
+
+implementation
+
+uses
+  aasmcpu;
+
+{$ifdef EXTDEBUG}
+  {$define SHOWUSEDMEM}
+{$endif}
+{$ifdef MEMDEBUG}
+  {$define SHOWUSEDMEM}
+{$endif}
+
+var
+  CompilerInitedAfterArgs,
+  CompilerInited : boolean;
+
+
+{****************************************************************************
+                                Compiler
+****************************************************************************}
+
+procedure DoneCompiler;
+begin
+  if not CompilerInited then
+   exit;
+{ Free compiler if args are read }
+{$ifdef BrowserLog}
+  DoneBrowserLog;
+{$endif BrowserLog}
+{$ifdef BrowserCol}
+  do_doneSymbolInfo;
+{$endif BrowserCol}
+  if CompilerInitedAfterArgs then
+   begin
+     CompilerInitedAfterArgs:=false;
+     DoneParser;
+     DoneImport;
+     DoneExport;
+     DoneDebuginfo;
+     DoneLinker;
+     DoneAssembler;
+     DoneAsm;
+   end;
+{ Free memory for the others }
+  CompilerInited:=false;
+  DoneSymtable;
+  DoneGlobals;
+  donetokens;
+end;
+
+
+procedure InitCompiler(const cmd:string);
+begin
+  if CompilerInited then
+   DoneCompiler;
+{ inits which need to be done before the arguments are parsed }
+  InitSystems;
+  { globals depends on source_info so it must be after systems }
+  InitGlobals;
+  { verbose depends on exe_path and must be after globals }
+  InitVerbose;
+{$ifdef BrowserLog}
+  InitBrowserLog;
+{$endif BrowserLog}
+{$ifdef BrowserCol}
+  do_initSymbolInfo;
+{$endif BrowserCol}
+  inittokens;
+  InitSymtable; {Must come before read_arguments, to enable macrosymstack}
+  CompilerInited:=true;
+{ this is needed here for the IDE
+  in case of compilation failure
+  at the previous compile }
+  current_module:=nil;
+{ read the arguments }
+  read_arguments(cmd);
+{ inits which depend on arguments }
+  InitParser;
+  InitImport;
+  InitExport;
+  InitLinker;
+  InitAssembler;
+  InitDebugInfo;
+  InitAsm;
+  CompilerInitedAfterArgs:=true;
+end;
+
+
+function Compile(const cmd:string):longint;
+
+{$ifdef fpc}
+{$maxfpuregisters 0}
+{$endif fpc}
+
+  procedure writepathlist(w:longint;l:TSearchPathList);
+  var
+    hp : tstringlistitem;
+  begin
+    hp:=tstringlistitem(l.first);
+    while assigned(hp) do
+     begin
+       Message1(w,hp.str);
+       hp:=tstringlistitem(hp.next);
+     end;
+  end;
+
+  function getrealtime : real;
+  var
+{$IFDEF USE_SYSUTILS}
+    h,m,s,s1000 : word;
+{$ELSE USE_SYSUTILS}
+    h,m,s,s100 : word;
+{$ENDIF USE_SYSUTILS}
+  begin
+{$IFDEF USE_SYSUTILS}
+    DecodeTime(Time,h,m,s,s1000);
+    getrealtime:=h*3600.0+m*60.0+s+s1000/1000.0;
+{$ELSE USE_SYSUTILS}
+    gettime(h,m,s,s100);
+    getrealtime:=h*3600.0+m*60.0+s+s100/100.0;
+{$ENDIF USE_SYSUTILS}
+  end;
+
+var
+  starttime  : real;
+{$ifdef SHOWUSEDMEM}
+  hstatus : TFPCHeapStatus;
+{$endif SHOWUSEDMEM}
+begin
+  try
+    try
+       { Initialize the compiler }
+       InitCompiler(cmd);
+
+       { show some info }
+       Message1(general_t_compilername,FixFileName(system.paramstr(0)));
+       Message1(general_d_sourceos,source_info.name);
+       Message1(general_i_targetos,target_info.name);
+       Message1(general_t_exepath,exepath);
+       WritePathList(general_t_unitpath,unitsearchpath);
+       WritePathList(general_t_includepath,includesearchpath);
+       WritePathList(general_t_librarypath,librarysearchpath);
+       WritePathList(general_t_objectpath,objectsearchpath);
+
+       starttime:=getrealtime;
+
+       { Compile the program }
+  {$ifdef PREPROCWRITE}
+       if parapreprocess then
+        parser.preprocess(inputdir+inputfile+inputextension)
+       else
+  {$endif PREPROCWRITE}
+        parser.compile(inputdir+inputfile+inputextension);
+
+       { Show statistics }
+       if status.errorcount=0 then
+        begin
+          starttime:=getrealtime-starttime;
+          if starttime<0 then
+            starttime:=starttime+3600.0*24.0;
+          Message2(general_i_abslines_compiled,tostr(status.compiledlines),tostr(trunc(starttime))+
+            '.'+tostr(trunc(frac(starttime)*10)));
+        end;
+     finally
+       { no message possible after this !!    }
+       DoneCompiler;
+     end;
+  except
+
+    on EControlCAbort do
+      begin
+        try
+          { in case of 50 errors, this could cause another exception,
+            suppress this exception
+          }
+          Message(general_f_compilation_aborted);
+        except
+          on ECompilerAbort do
+            ;
+        end;
+        DoneVerbose;
+      end;
+    on ECompilerAbort do
+      begin
+        try
+          { in case of 50 errors, this could cause another exception,
+            suppress this exception
+          }
+          Message(general_f_compilation_aborted);
+        except
+          on ECompilerAbort do
+            ;
+        end;
+        DoneVerbose;
+      end;
+    on ECompilerAbortSilent do
+      begin
+        DoneVerbose;
+      end;
+    on Exception do
+      begin
+        { General catchall, normally not used }
+        try
+          { in case of 50 errors, this could cause another exception,
+            suppress this exception
+          }
+          Message(general_f_compilation_aborted);
+        except
+          on ECompilerAbort do
+            ;
+        end;
+        DoneVerbose;
+        Raise;
+      end;
+  end;
+{$ifdef SHOWUSEDMEM}
+      hstatus:=GetFPCHeapStatus;
+      Writeln('Max Memory used/heapsize: ',DStr(hstatus.MaxHeapUsed shr 10),'/',DStr(hstatus.MaxHeapSize shr 10),' Kb');
+{$endif SHOWUSEDMEM}
+
+  { Set the return value if an error has occurred }
+  if status.errorcount=0 then
+    result:=0
+  else
+    result:=1;
+end;
+
+end.

+ 107 - 0
compiler/compinnr.inc

@@ -0,0 +1,107 @@
+{
+    This file is part of the Free Pascal run time library and compiler.
+    Copyright (c) 1998-2002 by the Free Pascal development team
+
+    Internal Function/Constant Evaluator numbers
+
+    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.
+
+ **********************************************************************}
+
+const
+{ Internal functions }
+   in_lo_word           = 1;
+   in_hi_word           = 2;
+   in_lo_long           = 3;
+   in_hi_long           = 4;
+   in_ord_x             = 5;
+   in_length_x          = 6;
+   in_chr_byte          = 7;
+   in_write_x           = 14;
+   in_writeln_x         = 15;
+   in_read_x            = 16;
+   in_readln_x          = 17;
+   in_concat_x          = 18;
+   in_assigned_x        = 19;
+   in_str_x_string      = 20;
+   in_ofs_x             = 21;
+   in_sizeof_x          = 22;
+   in_typeof_x          = 23;
+   in_val_x             = 24;
+   in_reset_x           = 25;
+   in_rewrite_x         = 26;
+   in_low_x             = 27;
+   in_high_x            = 28;
+   in_seg_x             = 29;
+   in_pred_x            = 30;
+   in_succ_x            = 31;
+   in_reset_typedfile   = 32;
+   in_rewrite_typedfile = 33;
+   in_settextbuf_file_x = 34;
+   in_inc_x             = 35;
+   in_dec_x             = 36;
+   in_include_x_y       = 37;
+   in_exclude_x_y       = 38;
+   in_break             = 39;
+   in_continue          = 40;
+   in_assert_x_y        = 41;
+   in_addr_x            = 42;
+   in_typeinfo_x        = 43;
+   in_setlength_x       = 44;
+   in_finalize_x        = 45;
+   in_new_x             = 46;
+   in_dispose_x         = 47;
+   in_exit              = 48;
+   in_copy_x            = 49;
+   in_initialize_x      = 50;
+   in_leave             = 51; {macpas}
+   in_cycle             = 52; {macpas}
+   in_slice_x           = 53;
+
+{ Internal constant functions }
+   in_const_sqr        = 100;
+   in_const_abs        = 101;
+   in_const_odd        = 102;
+   in_const_ptr        = 103;
+   in_const_swap_word  = 104;
+   in_const_swap_long  = 105;
+   in_lo_qword         = 106;
+   in_hi_qword         = 107;
+   in_const_swap_qword = 108;
+   in_prefetch_var     = 109;
+
+{ FPU functions }
+   in_trunc_real       = 120;
+   in_round_real       = 121;
+   in_frac_real        = 122;
+   in_int_real         = 123;
+   in_exp_real         = 124;
+   in_cos_real         = 125;
+   in_pi_real          = 126;
+   in_abs_real         = 127;
+   in_sqr_real         = 128;
+   in_sqrt_real        = 129;
+   in_arctan_real      = 130;
+   in_ln_real          = 131;
+   in_sin_real         = 132;
+
+{ MMX functions }
+  { these contants are used by the mmx unit }
+
+   { MMX }
+   in_mmx_pcmpeqb      = 200;
+   in_mmx_pcmpeqw      = 201;
+   in_mmx_pcmpeqd      = 202;
+   in_mmx_pcmpgtb      = 203;
+   in_mmx_pcmpgtw      = 204;
+   in_mmx_pcmpgtd      = 205;
+
+   { 3DNow }
+
+   { SSE }
+

+ 185 - 0
compiler/comprsrc.pas

@@ -0,0 +1,185 @@
+{
+    Copyright (c) 1998-2002 by Florian Klaempfl
+
+    Handles the resource files handling
+
+    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 comprsrc;
+
+{$i fpcdefs.inc}
+
+interface
+
+type
+   presourcefile=^tresourcefile;
+   tresourcefile=object
+   private
+      fname : string;
+   public
+      constructor Init(const fn:string);
+      destructor Done;
+      procedure  Compile;virtual;
+   end;
+
+procedure CompileResourceFiles;
+
+
+implementation
+
+uses
+{$IFDEF USE_SYSUTILS}
+  SysUtils,
+{$ELSE USE_SYSUTILS}
+  dos,
+{$ENDIF USE_SYSUTILS}
+  Systems,cutils,Globtype,Globals,Verbose,Fmodule,
+  Script;
+
+{****************************************************************************
+                              TRESOURCEFILE
+****************************************************************************}
+
+constructor tresourcefile.init(const fn:string);
+begin
+  fname:=fn;
+end;
+
+
+destructor tresourcefile.done;
+begin
+end;
+
+
+procedure tresourcefile.compile;
+var
+  respath,
+  srcfilepath : dirstr;
+  n       : namestr;
+{$IFDEF USE_SYSUTILS}
+{$ELSE USE_SYSUTILS}
+  e       : extstr;
+{$ENDIF USE_SYSUTILS}
+  s,
+  resobj,
+  resbin   : string;
+  resfound,
+  objused  : boolean;
+begin
+  resbin:='';
+  resfound:=false;
+  if utilsdirectory<>'' then
+    resfound:=FindFile(utilsprefix+target_res.resbin+source_info.exeext,utilsdirectory,resbin);
+  if not resfound then
+    resfound:=FindExe(utilsprefix+target_res.resbin,resbin);
+  { get also the path to be searched for the windres.h }
+{$IFDEF USE_SYSUTILS}
+  respath := SplitPath(resbin);
+{$ELSE USE_SYSUTILS}
+  fsplit(resbin,respath,n,e);
+{$ENDIF USE_SYSUTILS}
+  if (not resfound) and not(cs_link_extern in aktglobalswitches) then
+   begin
+     Message(exec_e_res_not_found);
+     aktglobalswitches:=aktglobalswitches+[cs_link_extern];
+   end;
+{$IFDEF USE_SYSUTILS}
+  srcfilepath := SplitPath(current_module.mainsource^);
+{$ELSE USE_SYSUTILS}
+  fsplit(current_module.mainsource^,srcfilepath,n,e);
+{$ENDIF USE_SYSUTILS}
+  if not path_absolute(fname) then
+    fname:=srcfilepath+fname;
+  resobj:=ForceExtension(fname,target_info.resobjext);
+  s:=target_res.rescmd;
+  ObjUsed:=(pos('$OBJ',s)>0);
+  Replace(s,'$OBJ',maybequoted(resobj));
+  Replace(s,'$RES',maybequoted(fname));
+  { windres doesn't like empty include paths }
+  if respath='' then
+    respath:='.';
+  Replace(s,'$INC',maybequoted(respath));
+  if (target_info.system = system_i386_win32) and
+     (srcfilepath<>'') then
+    s:=s+' --include '+maybequoted(srcfilepath);
+{ Execute the command }
+  if not (cs_link_extern in aktglobalswitches) then
+   begin
+     Message1(exec_i_compilingresource,fname);
+     Message2(exec_d_resbin_params,resbin,s);
+{$IFDEF USE_SYSUTILS}
+     try
+       if ExecuteProcess(resbin,s) <> 0 then
+       begin
+         Message(exec_e_error_while_linking);
+         aktglobalswitches:=aktglobalswitches+[cs_link_extern];
+       end;
+     except
+       on E:EOSError do
+       begin
+         Message(exec_e_cant_call_linker);
+         aktglobalswitches:=aktglobalswitches+[cs_link_extern];
+       end
+     end;
+{$ELSE USE_SYSUTILS}
+     swapvectors;
+     exec(resbin,s);
+     swapvectors;
+     if (doserror<>0) then
+      begin
+        Message(exec_e_cant_call_linker);
+        aktglobalswitches:=aktglobalswitches+[cs_link_extern];
+      end
+     else
+      if (dosexitcode<>0) then
+       begin
+         Message(exec_e_error_while_linking);
+         aktglobalswitches:=aktglobalswitches+[cs_link_extern];
+       end;
+{$ENDIF USE_SYSUTILS}
+    end;
+  { Update asmres when externmode is set }
+  if cs_link_extern in aktglobalswitches then
+    AsmRes.AddLinkCommand(resbin,s,'');
+  if ObjUsed then
+    current_module.linkotherofiles.add(resobj,link_allways);
+end;
+
+
+procedure CompileResourceFiles;
+var
+  hr : presourcefile;
+begin
+  { OS/2 (EMX) must be processed elsewhere (in the linking/binding stage).
+    same with MacOS}
+  if not (target_info.system in [system_i386_os2,
+                                 system_i386_emx,system_powerpc_macos]) then
+   While not current_module.ResourceFiles.Empty do
+     begin
+       if target_info.res<>res_none then
+         begin
+           hr:=new(presourcefile,init(current_module.ResourceFiles.getfirst));
+           hr^.compile;
+           dispose(hr,done);
+         end
+       else
+         Message(scan_e_resourcefiles_not_supported);
+     end;
+end;
+
+
+end.

+ 281 - 0
compiler/cp437.pas

@@ -0,0 +1,281 @@
+{ This is an automatically created file, so don't edit it }
+unit cp437;
+
+  interface
+
+  implementation
+
+  uses
+     charset;
+
+  const
+     map : array[0..255] of tunicodecharmapping = (
+       (unicode : 0; flag : umf_noinfo; reserved : 0),
+       (unicode : 1; flag : umf_noinfo; reserved : 0),
+       (unicode : 2; flag : umf_noinfo; reserved : 0),
+       (unicode : 3; flag : umf_noinfo; reserved : 0),
+       (unicode : 4; flag : umf_noinfo; reserved : 0),
+       (unicode : 5; flag : umf_noinfo; reserved : 0),
+       (unicode : 6; flag : umf_noinfo; reserved : 0),
+       (unicode : 7; flag : umf_noinfo; reserved : 0),
+       (unicode : 8; flag : umf_noinfo; reserved : 0),
+       (unicode : 9; flag : umf_noinfo; reserved : 0),
+       (unicode : 10; flag : umf_noinfo; reserved : 0),
+       (unicode : 11; flag : umf_noinfo; reserved : 0),
+       (unicode : 12; flag : umf_noinfo; reserved : 0),
+       (unicode : 13; flag : umf_noinfo; reserved : 0),
+       (unicode : 14; flag : umf_noinfo; reserved : 0),
+       (unicode : 15; flag : umf_noinfo; reserved : 0),
+       (unicode : 16; flag : umf_noinfo; reserved : 0),
+       (unicode : 17; flag : umf_noinfo; reserved : 0),
+       (unicode : 18; flag : umf_noinfo; reserved : 0),
+       (unicode : 19; flag : umf_noinfo; reserved : 0),
+       (unicode : 20; flag : umf_noinfo; reserved : 0),
+       (unicode : 21; flag : umf_noinfo; reserved : 0),
+       (unicode : 22; flag : umf_noinfo; reserved : 0),
+       (unicode : 23; flag : umf_noinfo; reserved : 0),
+       (unicode : 24; flag : umf_noinfo; reserved : 0),
+       (unicode : 25; flag : umf_noinfo; reserved : 0),
+       (unicode : 26; flag : umf_noinfo; reserved : 0),
+       (unicode : 27; flag : umf_noinfo; reserved : 0),
+       (unicode : 28; flag : umf_noinfo; reserved : 0),
+       (unicode : 29; flag : umf_noinfo; reserved : 0),
+       (unicode : 30; flag : umf_noinfo; reserved : 0),
+       (unicode : 31; flag : umf_noinfo; reserved : 0),
+       (unicode : 32; flag : umf_noinfo; reserved : 0),
+       (unicode : 33; flag : umf_noinfo; reserved : 0),
+       (unicode : 34; flag : umf_noinfo; reserved : 0),
+       (unicode : 35; flag : umf_noinfo; reserved : 0),
+       (unicode : 36; flag : umf_noinfo; reserved : 0),
+       (unicode : 37; flag : umf_noinfo; reserved : 0),
+       (unicode : 38; flag : umf_noinfo; reserved : 0),
+       (unicode : 39; flag : umf_noinfo; reserved : 0),
+       (unicode : 40; flag : umf_noinfo; reserved : 0),
+       (unicode : 41; flag : umf_noinfo; reserved : 0),
+       (unicode : 42; flag : umf_noinfo; reserved : 0),
+       (unicode : 43; flag : umf_noinfo; reserved : 0),
+       (unicode : 44; flag : umf_noinfo; reserved : 0),
+       (unicode : 45; flag : umf_noinfo; reserved : 0),
+       (unicode : 46; flag : umf_noinfo; reserved : 0),
+       (unicode : 47; flag : umf_noinfo; reserved : 0),
+       (unicode : 48; flag : umf_noinfo; reserved : 0),
+       (unicode : 49; flag : umf_noinfo; reserved : 0),
+       (unicode : 50; flag : umf_noinfo; reserved : 0),
+       (unicode : 51; flag : umf_noinfo; reserved : 0),
+       (unicode : 52; flag : umf_noinfo; reserved : 0),
+       (unicode : 53; flag : umf_noinfo; reserved : 0),
+       (unicode : 54; flag : umf_noinfo; reserved : 0),
+       (unicode : 55; flag : umf_noinfo; reserved : 0),
+       (unicode : 56; flag : umf_noinfo; reserved : 0),
+       (unicode : 57; flag : umf_noinfo; reserved : 0),
+       (unicode : 58; flag : umf_noinfo; reserved : 0),
+       (unicode : 59; flag : umf_noinfo; reserved : 0),
+       (unicode : 60; flag : umf_noinfo; reserved : 0),
+       (unicode : 61; flag : umf_noinfo; reserved : 0),
+       (unicode : 62; flag : umf_noinfo; reserved : 0),
+       (unicode : 63; flag : umf_noinfo; reserved : 0),
+       (unicode : 64; flag : umf_noinfo; reserved : 0),
+       (unicode : 65; flag : umf_noinfo; reserved : 0),
+       (unicode : 66; flag : umf_noinfo; reserved : 0),
+       (unicode : 67; flag : umf_noinfo; reserved : 0),
+       (unicode : 68; flag : umf_noinfo; reserved : 0),
+       (unicode : 69; flag : umf_noinfo; reserved : 0),
+       (unicode : 70; flag : umf_noinfo; reserved : 0),
+       (unicode : 71; flag : umf_noinfo; reserved : 0),
+       (unicode : 72; flag : umf_noinfo; reserved : 0),
+       (unicode : 73; flag : umf_noinfo; reserved : 0),
+       (unicode : 74; flag : umf_noinfo; reserved : 0),
+       (unicode : 75; flag : umf_noinfo; reserved : 0),
+       (unicode : 76; flag : umf_noinfo; reserved : 0),
+       (unicode : 77; flag : umf_noinfo; reserved : 0),
+       (unicode : 78; flag : umf_noinfo; reserved : 0),
+       (unicode : 79; flag : umf_noinfo; reserved : 0),
+       (unicode : 80; flag : umf_noinfo; reserved : 0),
+       (unicode : 81; flag : umf_noinfo; reserved : 0),
+       (unicode : 82; flag : umf_noinfo; reserved : 0),
+       (unicode : 83; flag : umf_noinfo; reserved : 0),
+       (unicode : 84; flag : umf_noinfo; reserved : 0),
+       (unicode : 85; flag : umf_noinfo; reserved : 0),
+       (unicode : 86; flag : umf_noinfo; reserved : 0),
+       (unicode : 87; flag : umf_noinfo; reserved : 0),
+       (unicode : 88; flag : umf_noinfo; reserved : 0),
+       (unicode : 89; flag : umf_noinfo; reserved : 0),
+       (unicode : 90; flag : umf_noinfo; reserved : 0),
+       (unicode : 91; flag : umf_noinfo; reserved : 0),
+       (unicode : 92; flag : umf_noinfo; reserved : 0),
+       (unicode : 93; flag : umf_noinfo; reserved : 0),
+       (unicode : 94; flag : umf_noinfo; reserved : 0),
+       (unicode : 95; flag : umf_noinfo; reserved : 0),
+       (unicode : 96; flag : umf_noinfo; reserved : 0),
+       (unicode : 97; flag : umf_noinfo; reserved : 0),
+       (unicode : 98; flag : umf_noinfo; reserved : 0),
+       (unicode : 99; flag : umf_noinfo; reserved : 0),
+       (unicode : 100; flag : umf_noinfo; reserved : 0),
+       (unicode : 101; flag : umf_noinfo; reserved : 0),
+       (unicode : 102; flag : umf_noinfo; reserved : 0),
+       (unicode : 103; flag : umf_noinfo; reserved : 0),
+       (unicode : 104; flag : umf_noinfo; reserved : 0),
+       (unicode : 105; flag : umf_noinfo; reserved : 0),
+       (unicode : 106; flag : umf_noinfo; reserved : 0),
+       (unicode : 107; flag : umf_noinfo; reserved : 0),
+       (unicode : 108; flag : umf_noinfo; reserved : 0),
+       (unicode : 109; flag : umf_noinfo; reserved : 0),
+       (unicode : 110; flag : umf_noinfo; reserved : 0),
+       (unicode : 111; flag : umf_noinfo; reserved : 0),
+       (unicode : 112; flag : umf_noinfo; reserved : 0),
+       (unicode : 113; flag : umf_noinfo; reserved : 0),
+       (unicode : 114; flag : umf_noinfo; reserved : 0),
+       (unicode : 115; flag : umf_noinfo; reserved : 0),
+       (unicode : 116; flag : umf_noinfo; reserved : 0),
+       (unicode : 117; flag : umf_noinfo; reserved : 0),
+       (unicode : 118; flag : umf_noinfo; reserved : 0),
+       (unicode : 119; flag : umf_noinfo; reserved : 0),
+       (unicode : 120; flag : umf_noinfo; reserved : 0),
+       (unicode : 121; flag : umf_noinfo; reserved : 0),
+       (unicode : 122; flag : umf_noinfo; reserved : 0),
+       (unicode : 123; flag : umf_noinfo; reserved : 0),
+       (unicode : 124; flag : umf_noinfo; reserved : 0),
+       (unicode : 125; flag : umf_noinfo; reserved : 0),
+       (unicode : 126; flag : umf_noinfo; reserved : 0),
+       (unicode : 127; flag : umf_noinfo; reserved : 0),
+       (unicode : 199; flag : umf_noinfo; reserved : 0),
+       (unicode : 252; flag : umf_noinfo; reserved : 0),
+       (unicode : 233; flag : umf_noinfo; reserved : 0),
+       (unicode : 226; flag : umf_noinfo; reserved : 0),
+       (unicode : 228; flag : umf_noinfo; reserved : 0),
+       (unicode : 224; flag : umf_noinfo; reserved : 0),
+       (unicode : 229; flag : umf_noinfo; reserved : 0),
+       (unicode : 231; flag : umf_noinfo; reserved : 0),
+       (unicode : 234; flag : umf_noinfo; reserved : 0),
+       (unicode : 235; flag : umf_noinfo; reserved : 0),
+       (unicode : 232; flag : umf_noinfo; reserved : 0),
+       (unicode : 239; flag : umf_noinfo; reserved : 0),
+       (unicode : 238; flag : umf_noinfo; reserved : 0),
+       (unicode : 236; flag : umf_noinfo; reserved : 0),
+       (unicode : 196; flag : umf_noinfo; reserved : 0),
+       (unicode : 197; flag : umf_noinfo; reserved : 0),
+       (unicode : 201; flag : umf_noinfo; reserved : 0),
+       (unicode : 230; flag : umf_noinfo; reserved : 0),
+       (unicode : 198; flag : umf_noinfo; reserved : 0),
+       (unicode : 244; flag : umf_noinfo; reserved : 0),
+       (unicode : 246; flag : umf_noinfo; reserved : 0),
+       (unicode : 242; flag : umf_noinfo; reserved : 0),
+       (unicode : 251; flag : umf_noinfo; reserved : 0),
+       (unicode : 249; flag : umf_noinfo; reserved : 0),
+       (unicode : 255; flag : umf_noinfo; reserved : 0),
+       (unicode : 214; flag : umf_noinfo; reserved : 0),
+       (unicode : 220; flag : umf_noinfo; reserved : 0),
+       (unicode : 162; flag : umf_noinfo; reserved : 0),
+       (unicode : 163; flag : umf_noinfo; reserved : 0),
+       (unicode : 165; flag : umf_noinfo; reserved : 0),
+       (unicode : 8359; flag : umf_noinfo; reserved : 0),
+       (unicode : 402; flag : umf_noinfo; reserved : 0),
+       (unicode : 225; flag : umf_noinfo; reserved : 0),
+       (unicode : 237; flag : umf_noinfo; reserved : 0),
+       (unicode : 243; flag : umf_noinfo; reserved : 0),
+       (unicode : 250; flag : umf_noinfo; reserved : 0),
+       (unicode : 241; flag : umf_noinfo; reserved : 0),
+       (unicode : 209; flag : umf_noinfo; reserved : 0),
+       (unicode : 170; flag : umf_noinfo; reserved : 0),
+       (unicode : 186; flag : umf_noinfo; reserved : 0),
+       (unicode : 191; flag : umf_noinfo; reserved : 0),
+       (unicode : 8976; flag : umf_noinfo; reserved : 0),
+       (unicode : 172; flag : umf_noinfo; reserved : 0),
+       (unicode : 189; flag : umf_noinfo; reserved : 0),
+       (unicode : 188; flag : umf_noinfo; reserved : 0),
+       (unicode : 161; flag : umf_noinfo; reserved : 0),
+       (unicode : 171; flag : umf_noinfo; reserved : 0),
+       (unicode : 187; flag : umf_noinfo; reserved : 0),
+       (unicode : 9617; flag : umf_noinfo; reserved : 0),
+       (unicode : 9618; flag : umf_noinfo; reserved : 0),
+       (unicode : 9619; flag : umf_noinfo; reserved : 0),
+       (unicode : 9474; flag : umf_noinfo; reserved : 0),
+       (unicode : 9508; flag : umf_noinfo; reserved : 0),
+       (unicode : 9569; flag : umf_noinfo; reserved : 0),
+       (unicode : 9570; flag : umf_noinfo; reserved : 0),
+       (unicode : 9558; flag : umf_noinfo; reserved : 0),
+       (unicode : 9557; flag : umf_noinfo; reserved : 0),
+       (unicode : 9571; flag : umf_noinfo; reserved : 0),
+       (unicode : 9553; flag : umf_noinfo; reserved : 0),
+       (unicode : 9559; flag : umf_noinfo; reserved : 0),
+       (unicode : 9565; flag : umf_noinfo; reserved : 0),
+       (unicode : 9564; flag : umf_noinfo; reserved : 0),
+       (unicode : 9563; flag : umf_noinfo; reserved : 0),
+       (unicode : 9488; flag : umf_noinfo; reserved : 0),
+       (unicode : 9492; flag : umf_noinfo; reserved : 0),
+       (unicode : 9524; flag : umf_noinfo; reserved : 0),
+       (unicode : 9516; flag : umf_noinfo; reserved : 0),
+       (unicode : 9500; flag : umf_noinfo; reserved : 0),
+       (unicode : 9472; flag : umf_noinfo; reserved : 0),
+       (unicode : 9532; flag : umf_noinfo; reserved : 0),
+       (unicode : 9566; flag : umf_noinfo; reserved : 0),
+       (unicode : 9567; flag : umf_noinfo; reserved : 0),
+       (unicode : 9562; flag : umf_noinfo; reserved : 0),
+       (unicode : 9556; flag : umf_noinfo; reserved : 0),
+       (unicode : 9577; flag : umf_noinfo; reserved : 0),
+       (unicode : 9574; flag : umf_noinfo; reserved : 0),
+       (unicode : 9568; flag : umf_noinfo; reserved : 0),
+       (unicode : 9552; flag : umf_noinfo; reserved : 0),
+       (unicode : 9580; flag : umf_noinfo; reserved : 0),
+       (unicode : 9575; flag : umf_noinfo; reserved : 0),
+       (unicode : 9576; flag : umf_noinfo; reserved : 0),
+       (unicode : 9572; flag : umf_noinfo; reserved : 0),
+       (unicode : 9573; flag : umf_noinfo; reserved : 0),
+       (unicode : 9561; flag : umf_noinfo; reserved : 0),
+       (unicode : 9560; flag : umf_noinfo; reserved : 0),
+       (unicode : 9554; flag : umf_noinfo; reserved : 0),
+       (unicode : 9555; flag : umf_noinfo; reserved : 0),
+       (unicode : 9579; flag : umf_noinfo; reserved : 0),
+       (unicode : 9578; flag : umf_noinfo; reserved : 0),
+       (unicode : 9496; flag : umf_noinfo; reserved : 0),
+       (unicode : 9484; flag : umf_noinfo; reserved : 0),
+       (unicode : 9608; flag : umf_noinfo; reserved : 0),
+       (unicode : 9604; flag : umf_noinfo; reserved : 0),
+       (unicode : 9612; flag : umf_noinfo; reserved : 0),
+       (unicode : 9616; flag : umf_noinfo; reserved : 0),
+       (unicode : 9600; flag : umf_noinfo; reserved : 0),
+       (unicode : 945; flag : umf_noinfo; reserved : 0),
+       (unicode : 223; flag : umf_noinfo; reserved : 0),
+       (unicode : 915; flag : umf_noinfo; reserved : 0),
+       (unicode : 960; flag : umf_noinfo; reserved : 0),
+       (unicode : 931; flag : umf_noinfo; reserved : 0),
+       (unicode : 963; flag : umf_noinfo; reserved : 0),
+       (unicode : 181; flag : umf_noinfo; reserved : 0),
+       (unicode : 964; flag : umf_noinfo; reserved : 0),
+       (unicode : 934; flag : umf_noinfo; reserved : 0),
+       (unicode : 920; flag : umf_noinfo; reserved : 0),
+       (unicode : 937; flag : umf_noinfo; reserved : 0),
+       (unicode : 948; flag : umf_noinfo; reserved : 0),
+       (unicode : 8734; flag : umf_noinfo; reserved : 0),
+       (unicode : 966; flag : umf_noinfo; reserved : 0),
+       (unicode : 949; flag : umf_noinfo; reserved : 0),
+       (unicode : 8745; flag : umf_noinfo; reserved : 0),
+       (unicode : 8801; flag : umf_noinfo; reserved : 0),
+       (unicode : 177; flag : umf_noinfo; reserved : 0),
+       (unicode : 8805; flag : umf_noinfo; reserved : 0),
+       (unicode : 8804; flag : umf_noinfo; reserved : 0),
+       (unicode : 8992; flag : umf_noinfo; reserved : 0),
+       (unicode : 8993; flag : umf_noinfo; reserved : 0),
+       (unicode : 247; flag : umf_noinfo; reserved : 0),
+       (unicode : 8776; flag : umf_noinfo; reserved : 0),
+       (unicode : 176; flag : umf_noinfo; reserved : 0),
+       (unicode : 8729; flag : umf_noinfo; reserved : 0),
+       (unicode : 183; flag : umf_noinfo; reserved : 0),
+       (unicode : 8730; flag : umf_noinfo; reserved : 0),
+       (unicode : 8319; flag : umf_noinfo; reserved : 0),
+       (unicode : 178; flag : umf_noinfo; reserved : 0),
+       (unicode : 9632; flag : umf_noinfo; reserved : 0),
+       (unicode : 160; flag : umf_noinfo; reserved : 0)
+     );
+
+     unicodemap : tunicodemap = (
+       cpname : 'cp437';
+       map : @map;
+       lastchar : 255;
+       next : nil;
+       internalmap : true
+     );
+
+  begin
+     registermapping(@unicodemap)
+  end.

+ 281 - 0
compiler/cp850.pas

@@ -0,0 +1,281 @@
+{ This is an automatically created file, so don't edit it }
+unit cp850;
+
+  interface
+
+  implementation
+
+  uses
+     charset;
+
+  const
+     map : array[0..255] of tunicodecharmapping = (
+       (unicode : 0; flag : umf_noinfo; reserved : 0),
+       (unicode : 1; flag : umf_noinfo; reserved : 0),
+       (unicode : 2; flag : umf_noinfo; reserved : 0),
+       (unicode : 3; flag : umf_noinfo; reserved : 0),
+       (unicode : 4; flag : umf_noinfo; reserved : 0),
+       (unicode : 5; flag : umf_noinfo; reserved : 0),
+       (unicode : 6; flag : umf_noinfo; reserved : 0),
+       (unicode : 7; flag : umf_noinfo; reserved : 0),
+       (unicode : 8; flag : umf_noinfo; reserved : 0),
+       (unicode : 9; flag : umf_noinfo; reserved : 0),
+       (unicode : 10; flag : umf_noinfo; reserved : 0),
+       (unicode : 11; flag : umf_noinfo; reserved : 0),
+       (unicode : 12; flag : umf_noinfo; reserved : 0),
+       (unicode : 13; flag : umf_noinfo; reserved : 0),
+       (unicode : 14; flag : umf_noinfo; reserved : 0),
+       (unicode : 15; flag : umf_noinfo; reserved : 0),
+       (unicode : 16; flag : umf_noinfo; reserved : 0),
+       (unicode : 17; flag : umf_noinfo; reserved : 0),
+       (unicode : 18; flag : umf_noinfo; reserved : 0),
+       (unicode : 19; flag : umf_noinfo; reserved : 0),
+       (unicode : 20; flag : umf_noinfo; reserved : 0),
+       (unicode : 21; flag : umf_noinfo; reserved : 0),
+       (unicode : 22; flag : umf_noinfo; reserved : 0),
+       (unicode : 23; flag : umf_noinfo; reserved : 0),
+       (unicode : 24; flag : umf_noinfo; reserved : 0),
+       (unicode : 25; flag : umf_noinfo; reserved : 0),
+       (unicode : 26; flag : umf_noinfo; reserved : 0),
+       (unicode : 27; flag : umf_noinfo; reserved : 0),
+       (unicode : 28; flag : umf_noinfo; reserved : 0),
+       (unicode : 29; flag : umf_noinfo; reserved : 0),
+       (unicode : 30; flag : umf_noinfo; reserved : 0),
+       (unicode : 31; flag : umf_noinfo; reserved : 0),
+       (unicode : 32; flag : umf_noinfo; reserved : 0),
+       (unicode : 33; flag : umf_noinfo; reserved : 0),
+       (unicode : 34; flag : umf_noinfo; reserved : 0),
+       (unicode : 35; flag : umf_noinfo; reserved : 0),
+       (unicode : 36; flag : umf_noinfo; reserved : 0),
+       (unicode : 37; flag : umf_noinfo; reserved : 0),
+       (unicode : 38; flag : umf_noinfo; reserved : 0),
+       (unicode : 39; flag : umf_noinfo; reserved : 0),
+       (unicode : 40; flag : umf_noinfo; reserved : 0),
+       (unicode : 41; flag : umf_noinfo; reserved : 0),
+       (unicode : 42; flag : umf_noinfo; reserved : 0),
+       (unicode : 43; flag : umf_noinfo; reserved : 0),
+       (unicode : 44; flag : umf_noinfo; reserved : 0),
+       (unicode : 45; flag : umf_noinfo; reserved : 0),
+       (unicode : 46; flag : umf_noinfo; reserved : 0),
+       (unicode : 47; flag : umf_noinfo; reserved : 0),
+       (unicode : 48; flag : umf_noinfo; reserved : 0),
+       (unicode : 49; flag : umf_noinfo; reserved : 0),
+       (unicode : 50; flag : umf_noinfo; reserved : 0),
+       (unicode : 51; flag : umf_noinfo; reserved : 0),
+       (unicode : 52; flag : umf_noinfo; reserved : 0),
+       (unicode : 53; flag : umf_noinfo; reserved : 0),
+       (unicode : 54; flag : umf_noinfo; reserved : 0),
+       (unicode : 55; flag : umf_noinfo; reserved : 0),
+       (unicode : 56; flag : umf_noinfo; reserved : 0),
+       (unicode : 57; flag : umf_noinfo; reserved : 0),
+       (unicode : 58; flag : umf_noinfo; reserved : 0),
+       (unicode : 59; flag : umf_noinfo; reserved : 0),
+       (unicode : 60; flag : umf_noinfo; reserved : 0),
+       (unicode : 61; flag : umf_noinfo; reserved : 0),
+       (unicode : 62; flag : umf_noinfo; reserved : 0),
+       (unicode : 63; flag : umf_noinfo; reserved : 0),
+       (unicode : 64; flag : umf_noinfo; reserved : 0),
+       (unicode : 65; flag : umf_noinfo; reserved : 0),
+       (unicode : 66; flag : umf_noinfo; reserved : 0),
+       (unicode : 67; flag : umf_noinfo; reserved : 0),
+       (unicode : 68; flag : umf_noinfo; reserved : 0),
+       (unicode : 69; flag : umf_noinfo; reserved : 0),
+       (unicode : 70; flag : umf_noinfo; reserved : 0),
+       (unicode : 71; flag : umf_noinfo; reserved : 0),
+       (unicode : 72; flag : umf_noinfo; reserved : 0),
+       (unicode : 73; flag : umf_noinfo; reserved : 0),
+       (unicode : 74; flag : umf_noinfo; reserved : 0),
+       (unicode : 75; flag : umf_noinfo; reserved : 0),
+       (unicode : 76; flag : umf_noinfo; reserved : 0),
+       (unicode : 77; flag : umf_noinfo; reserved : 0),
+       (unicode : 78; flag : umf_noinfo; reserved : 0),
+       (unicode : 79; flag : umf_noinfo; reserved : 0),
+       (unicode : 80; flag : umf_noinfo; reserved : 0),
+       (unicode : 81; flag : umf_noinfo; reserved : 0),
+       (unicode : 82; flag : umf_noinfo; reserved : 0),
+       (unicode : 83; flag : umf_noinfo; reserved : 0),
+       (unicode : 84; flag : umf_noinfo; reserved : 0),
+       (unicode : 85; flag : umf_noinfo; reserved : 0),
+       (unicode : 86; flag : umf_noinfo; reserved : 0),
+       (unicode : 87; flag : umf_noinfo; reserved : 0),
+       (unicode : 88; flag : umf_noinfo; reserved : 0),
+       (unicode : 89; flag : umf_noinfo; reserved : 0),
+       (unicode : 90; flag : umf_noinfo; reserved : 0),
+       (unicode : 91; flag : umf_noinfo; reserved : 0),
+       (unicode : 92; flag : umf_noinfo; reserved : 0),
+       (unicode : 93; flag : umf_noinfo; reserved : 0),
+       (unicode : 94; flag : umf_noinfo; reserved : 0),
+       (unicode : 95; flag : umf_noinfo; reserved : 0),
+       (unicode : 96; flag : umf_noinfo; reserved : 0),
+       (unicode : 97; flag : umf_noinfo; reserved : 0),
+       (unicode : 98; flag : umf_noinfo; reserved : 0),
+       (unicode : 99; flag : umf_noinfo; reserved : 0),
+       (unicode : 100; flag : umf_noinfo; reserved : 0),
+       (unicode : 101; flag : umf_noinfo; reserved : 0),
+       (unicode : 102; flag : umf_noinfo; reserved : 0),
+       (unicode : 103; flag : umf_noinfo; reserved : 0),
+       (unicode : 104; flag : umf_noinfo; reserved : 0),
+       (unicode : 105; flag : umf_noinfo; reserved : 0),
+       (unicode : 106; flag : umf_noinfo; reserved : 0),
+       (unicode : 107; flag : umf_noinfo; reserved : 0),
+       (unicode : 108; flag : umf_noinfo; reserved : 0),
+       (unicode : 109; flag : umf_noinfo; reserved : 0),
+       (unicode : 110; flag : umf_noinfo; reserved : 0),
+       (unicode : 111; flag : umf_noinfo; reserved : 0),
+       (unicode : 112; flag : umf_noinfo; reserved : 0),
+       (unicode : 113; flag : umf_noinfo; reserved : 0),
+       (unicode : 114; flag : umf_noinfo; reserved : 0),
+       (unicode : 115; flag : umf_noinfo; reserved : 0),
+       (unicode : 116; flag : umf_noinfo; reserved : 0),
+       (unicode : 117; flag : umf_noinfo; reserved : 0),
+       (unicode : 118; flag : umf_noinfo; reserved : 0),
+       (unicode : 119; flag : umf_noinfo; reserved : 0),
+       (unicode : 120; flag : umf_noinfo; reserved : 0),
+       (unicode : 121; flag : umf_noinfo; reserved : 0),
+       (unicode : 122; flag : umf_noinfo; reserved : 0),
+       (unicode : 123; flag : umf_noinfo; reserved : 0),
+       (unicode : 124; flag : umf_noinfo; reserved : 0),
+       (unicode : 125; flag : umf_noinfo; reserved : 0),
+       (unicode : 126; flag : umf_noinfo; reserved : 0),
+       (unicode : 127; flag : umf_noinfo; reserved : 0),
+       (unicode : 199; flag : umf_noinfo; reserved : 0),
+       (unicode : 252; flag : umf_noinfo; reserved : 0),
+       (unicode : 233; flag : umf_noinfo; reserved : 0),
+       (unicode : 226; flag : umf_noinfo; reserved : 0),
+       (unicode : 228; flag : umf_noinfo; reserved : 0),
+       (unicode : 224; flag : umf_noinfo; reserved : 0),
+       (unicode : 229; flag : umf_noinfo; reserved : 0),
+       (unicode : 231; flag : umf_noinfo; reserved : 0),
+       (unicode : 234; flag : umf_noinfo; reserved : 0),
+       (unicode : 235; flag : umf_noinfo; reserved : 0),
+       (unicode : 232; flag : umf_noinfo; reserved : 0),
+       (unicode : 239; flag : umf_noinfo; reserved : 0),
+       (unicode : 238; flag : umf_noinfo; reserved : 0),
+       (unicode : 236; flag : umf_noinfo; reserved : 0),
+       (unicode : 196; flag : umf_noinfo; reserved : 0),
+       (unicode : 197; flag : umf_noinfo; reserved : 0),
+       (unicode : 201; flag : umf_noinfo; reserved : 0),
+       (unicode : 230; flag : umf_noinfo; reserved : 0),
+       (unicode : 198; flag : umf_noinfo; reserved : 0),
+       (unicode : 244; flag : umf_noinfo; reserved : 0),
+       (unicode : 246; flag : umf_noinfo; reserved : 0),
+       (unicode : 242; flag : umf_noinfo; reserved : 0),
+       (unicode : 251; flag : umf_noinfo; reserved : 0),
+       (unicode : 249; flag : umf_noinfo; reserved : 0),
+       (unicode : 255; flag : umf_noinfo; reserved : 0),
+       (unicode : 214; flag : umf_noinfo; reserved : 0),
+       (unicode : 220; flag : umf_noinfo; reserved : 0),
+       (unicode : 248; flag : umf_noinfo; reserved : 0),
+       (unicode : 163; flag : umf_noinfo; reserved : 0),
+       (unicode : 216; flag : umf_noinfo; reserved : 0),
+       (unicode : 215; flag : umf_noinfo; reserved : 0),
+       (unicode : 402; flag : umf_noinfo; reserved : 0),
+       (unicode : 225; flag : umf_noinfo; reserved : 0),
+       (unicode : 237; flag : umf_noinfo; reserved : 0),
+       (unicode : 243; flag : umf_noinfo; reserved : 0),
+       (unicode : 250; flag : umf_noinfo; reserved : 0),
+       (unicode : 241; flag : umf_noinfo; reserved : 0),
+       (unicode : 209; flag : umf_noinfo; reserved : 0),
+       (unicode : 170; flag : umf_noinfo; reserved : 0),
+       (unicode : 186; flag : umf_noinfo; reserved : 0),
+       (unicode : 191; flag : umf_noinfo; reserved : 0),
+       (unicode : 174; flag : umf_noinfo; reserved : 0),
+       (unicode : 172; flag : umf_noinfo; reserved : 0),
+       (unicode : 189; flag : umf_noinfo; reserved : 0),
+       (unicode : 188; flag : umf_noinfo; reserved : 0),
+       (unicode : 161; flag : umf_noinfo; reserved : 0),
+       (unicode : 171; flag : umf_noinfo; reserved : 0),
+       (unicode : 187; flag : umf_noinfo; reserved : 0),
+       (unicode : 9617; flag : umf_noinfo; reserved : 0),
+       (unicode : 9618; flag : umf_noinfo; reserved : 0),
+       (unicode : 9619; flag : umf_noinfo; reserved : 0),
+       (unicode : 9474; flag : umf_noinfo; reserved : 0),
+       (unicode : 9508; flag : umf_noinfo; reserved : 0),
+       (unicode : 193; flag : umf_noinfo; reserved : 0),
+       (unicode : 194; flag : umf_noinfo; reserved : 0),
+       (unicode : 192; flag : umf_noinfo; reserved : 0),
+       (unicode : 169; flag : umf_noinfo; reserved : 0),
+       (unicode : 9571; flag : umf_noinfo; reserved : 0),
+       (unicode : 9553; flag : umf_noinfo; reserved : 0),
+       (unicode : 9559; flag : umf_noinfo; reserved : 0),
+       (unicode : 9565; flag : umf_noinfo; reserved : 0),
+       (unicode : 162; flag : umf_noinfo; reserved : 0),
+       (unicode : 165; flag : umf_noinfo; reserved : 0),
+       (unicode : 9488; flag : umf_noinfo; reserved : 0),
+       (unicode : 9492; flag : umf_noinfo; reserved : 0),
+       (unicode : 9524; flag : umf_noinfo; reserved : 0),
+       (unicode : 9516; flag : umf_noinfo; reserved : 0),
+       (unicode : 9500; flag : umf_noinfo; reserved : 0),
+       (unicode : 9472; flag : umf_noinfo; reserved : 0),
+       (unicode : 9532; flag : umf_noinfo; reserved : 0),
+       (unicode : 227; flag : umf_noinfo; reserved : 0),
+       (unicode : 195; flag : umf_noinfo; reserved : 0),
+       (unicode : 9562; flag : umf_noinfo; reserved : 0),
+       (unicode : 9556; flag : umf_noinfo; reserved : 0),
+       (unicode : 9577; flag : umf_noinfo; reserved : 0),
+       (unicode : 9574; flag : umf_noinfo; reserved : 0),
+       (unicode : 9568; flag : umf_noinfo; reserved : 0),
+       (unicode : 9552; flag : umf_noinfo; reserved : 0),
+       (unicode : 9580; flag : umf_noinfo; reserved : 0),
+       (unicode : 164; flag : umf_noinfo; reserved : 0),
+       (unicode : 240; flag : umf_noinfo; reserved : 0),
+       (unicode : 208; flag : umf_noinfo; reserved : 0),
+       (unicode : 202; flag : umf_noinfo; reserved : 0),
+       (unicode : 203; flag : umf_noinfo; reserved : 0),
+       (unicode : 200; flag : umf_noinfo; reserved : 0),
+       (unicode : 305; flag : umf_noinfo; reserved : 0),
+       (unicode : 205; flag : umf_noinfo; reserved : 0),
+       (unicode : 206; flag : umf_noinfo; reserved : 0),
+       (unicode : 207; flag : umf_noinfo; reserved : 0),
+       (unicode : 9496; flag : umf_noinfo; reserved : 0),
+       (unicode : 9484; flag : umf_noinfo; reserved : 0),
+       (unicode : 9608; flag : umf_noinfo; reserved : 0),
+       (unicode : 9604; flag : umf_noinfo; reserved : 0),
+       (unicode : 166; flag : umf_noinfo; reserved : 0),
+       (unicode : 204; flag : umf_noinfo; reserved : 0),
+       (unicode : 9600; flag : umf_noinfo; reserved : 0),
+       (unicode : 211; flag : umf_noinfo; reserved : 0),
+       (unicode : 223; flag : umf_noinfo; reserved : 0),
+       (unicode : 212; flag : umf_noinfo; reserved : 0),
+       (unicode : 210; flag : umf_noinfo; reserved : 0),
+       (unicode : 245; flag : umf_noinfo; reserved : 0),
+       (unicode : 213; flag : umf_noinfo; reserved : 0),
+       (unicode : 181; flag : umf_noinfo; reserved : 0),
+       (unicode : 254; flag : umf_noinfo; reserved : 0),
+       (unicode : 222; flag : umf_noinfo; reserved : 0),
+       (unicode : 218; flag : umf_noinfo; reserved : 0),
+       (unicode : 219; flag : umf_noinfo; reserved : 0),
+       (unicode : 217; flag : umf_noinfo; reserved : 0),
+       (unicode : 253; flag : umf_noinfo; reserved : 0),
+       (unicode : 221; flag : umf_noinfo; reserved : 0),
+       (unicode : 175; flag : umf_noinfo; reserved : 0),
+       (unicode : 180; flag : umf_noinfo; reserved : 0),
+       (unicode : 173; flag : umf_noinfo; reserved : 0),
+       (unicode : 177; flag : umf_noinfo; reserved : 0),
+       (unicode : 8215; flag : umf_noinfo; reserved : 0),
+       (unicode : 190; flag : umf_noinfo; reserved : 0),
+       (unicode : 182; flag : umf_noinfo; reserved : 0),
+       (unicode : 167; flag : umf_noinfo; reserved : 0),
+       (unicode : 247; flag : umf_noinfo; reserved : 0),
+       (unicode : 184; flag : umf_noinfo; reserved : 0),
+       (unicode : 176; flag : umf_noinfo; reserved : 0),
+       (unicode : 168; flag : umf_noinfo; reserved : 0),
+       (unicode : 183; flag : umf_noinfo; reserved : 0),
+       (unicode : 185; flag : umf_noinfo; reserved : 0),
+       (unicode : 179; flag : umf_noinfo; reserved : 0),
+       (unicode : 178; flag : umf_noinfo; reserved : 0),
+       (unicode : 9632; flag : umf_noinfo; reserved : 0),
+       (unicode : 160; flag : umf_noinfo; reserved : 0)
+     );
+
+     unicodemap : tunicodemap = (
+       cpname : 'cp850';
+       map : @map;
+       lastchar : 255;
+       next : nil;
+       internalmap : true
+     );
+
+  begin
+     registermapping(@unicodemap)
+  end.

+ 281 - 0
compiler/cp8859_1.pas

@@ -0,0 +1,281 @@
+{ This is an automatically created file, so don't edit it }
+unit cp8859_1;
+
+  interface
+
+  implementation
+
+  uses
+     charset;
+
+  const
+     map : array[0..255] of tunicodecharmapping = (
+       (unicode : 0; flag : umf_noinfo; reserved : 0),
+       (unicode : 1; flag : umf_noinfo; reserved : 0),
+       (unicode : 2; flag : umf_noinfo; reserved : 0),
+       (unicode : 3; flag : umf_noinfo; reserved : 0),
+       (unicode : 4; flag : umf_noinfo; reserved : 0),
+       (unicode : 5; flag : umf_noinfo; reserved : 0),
+       (unicode : 6; flag : umf_noinfo; reserved : 0),
+       (unicode : 7; flag : umf_noinfo; reserved : 0),
+       (unicode : 8; flag : umf_noinfo; reserved : 0),
+       (unicode : 9; flag : umf_noinfo; reserved : 0),
+       (unicode : 10; flag : umf_noinfo; reserved : 0),
+       (unicode : 11; flag : umf_noinfo; reserved : 0),
+       (unicode : 12; flag : umf_noinfo; reserved : 0),
+       (unicode : 13; flag : umf_noinfo; reserved : 0),
+       (unicode : 14; flag : umf_noinfo; reserved : 0),
+       (unicode : 15; flag : umf_noinfo; reserved : 0),
+       (unicode : 16; flag : umf_noinfo; reserved : 0),
+       (unicode : 17; flag : umf_noinfo; reserved : 0),
+       (unicode : 18; flag : umf_noinfo; reserved : 0),
+       (unicode : 19; flag : umf_noinfo; reserved : 0),
+       (unicode : 20; flag : umf_noinfo; reserved : 0),
+       (unicode : 21; flag : umf_noinfo; reserved : 0),
+       (unicode : 22; flag : umf_noinfo; reserved : 0),
+       (unicode : 23; flag : umf_noinfo; reserved : 0),
+       (unicode : 24; flag : umf_noinfo; reserved : 0),
+       (unicode : 25; flag : umf_noinfo; reserved : 0),
+       (unicode : 26; flag : umf_noinfo; reserved : 0),
+       (unicode : 27; flag : umf_noinfo; reserved : 0),
+       (unicode : 28; flag : umf_noinfo; reserved : 0),
+       (unicode : 29; flag : umf_noinfo; reserved : 0),
+       (unicode : 30; flag : umf_noinfo; reserved : 0),
+       (unicode : 31; flag : umf_noinfo; reserved : 0),
+       (unicode : 32; flag : umf_noinfo; reserved : 0),
+       (unicode : 33; flag : umf_noinfo; reserved : 0),
+       (unicode : 34; flag : umf_noinfo; reserved : 0),
+       (unicode : 35; flag : umf_noinfo; reserved : 0),
+       (unicode : 36; flag : umf_noinfo; reserved : 0),
+       (unicode : 37; flag : umf_noinfo; reserved : 0),
+       (unicode : 38; flag : umf_noinfo; reserved : 0),
+       (unicode : 39; flag : umf_noinfo; reserved : 0),
+       (unicode : 40; flag : umf_noinfo; reserved : 0),
+       (unicode : 41; flag : umf_noinfo; reserved : 0),
+       (unicode : 42; flag : umf_noinfo; reserved : 0),
+       (unicode : 43; flag : umf_noinfo; reserved : 0),
+       (unicode : 44; flag : umf_noinfo; reserved : 0),
+       (unicode : 45; flag : umf_noinfo; reserved : 0),
+       (unicode : 46; flag : umf_noinfo; reserved : 0),
+       (unicode : 47; flag : umf_noinfo; reserved : 0),
+       (unicode : 48; flag : umf_noinfo; reserved : 0),
+       (unicode : 49; flag : umf_noinfo; reserved : 0),
+       (unicode : 50; flag : umf_noinfo; reserved : 0),
+       (unicode : 51; flag : umf_noinfo; reserved : 0),
+       (unicode : 52; flag : umf_noinfo; reserved : 0),
+       (unicode : 53; flag : umf_noinfo; reserved : 0),
+       (unicode : 54; flag : umf_noinfo; reserved : 0),
+       (unicode : 55; flag : umf_noinfo; reserved : 0),
+       (unicode : 56; flag : umf_noinfo; reserved : 0),
+       (unicode : 57; flag : umf_noinfo; reserved : 0),
+       (unicode : 58; flag : umf_noinfo; reserved : 0),
+       (unicode : 59; flag : umf_noinfo; reserved : 0),
+       (unicode : 60; flag : umf_noinfo; reserved : 0),
+       (unicode : 61; flag : umf_noinfo; reserved : 0),
+       (unicode : 62; flag : umf_noinfo; reserved : 0),
+       (unicode : 63; flag : umf_noinfo; reserved : 0),
+       (unicode : 64; flag : umf_noinfo; reserved : 0),
+       (unicode : 65; flag : umf_noinfo; reserved : 0),
+       (unicode : 66; flag : umf_noinfo; reserved : 0),
+       (unicode : 67; flag : umf_noinfo; reserved : 0),
+       (unicode : 68; flag : umf_noinfo; reserved : 0),
+       (unicode : 69; flag : umf_noinfo; reserved : 0),
+       (unicode : 70; flag : umf_noinfo; reserved : 0),
+       (unicode : 71; flag : umf_noinfo; reserved : 0),
+       (unicode : 72; flag : umf_noinfo; reserved : 0),
+       (unicode : 73; flag : umf_noinfo; reserved : 0),
+       (unicode : 74; flag : umf_noinfo; reserved : 0),
+       (unicode : 75; flag : umf_noinfo; reserved : 0),
+       (unicode : 76; flag : umf_noinfo; reserved : 0),
+       (unicode : 77; flag : umf_noinfo; reserved : 0),
+       (unicode : 78; flag : umf_noinfo; reserved : 0),
+       (unicode : 79; flag : umf_noinfo; reserved : 0),
+       (unicode : 80; flag : umf_noinfo; reserved : 0),
+       (unicode : 81; flag : umf_noinfo; reserved : 0),
+       (unicode : 82; flag : umf_noinfo; reserved : 0),
+       (unicode : 83; flag : umf_noinfo; reserved : 0),
+       (unicode : 84; flag : umf_noinfo; reserved : 0),
+       (unicode : 85; flag : umf_noinfo; reserved : 0),
+       (unicode : 86; flag : umf_noinfo; reserved : 0),
+       (unicode : 87; flag : umf_noinfo; reserved : 0),
+       (unicode : 88; flag : umf_noinfo; reserved : 0),
+       (unicode : 89; flag : umf_noinfo; reserved : 0),
+       (unicode : 90; flag : umf_noinfo; reserved : 0),
+       (unicode : 91; flag : umf_noinfo; reserved : 0),
+       (unicode : 92; flag : umf_noinfo; reserved : 0),
+       (unicode : 93; flag : umf_noinfo; reserved : 0),
+       (unicode : 94; flag : umf_noinfo; reserved : 0),
+       (unicode : 95; flag : umf_noinfo; reserved : 0),
+       (unicode : 96; flag : umf_noinfo; reserved : 0),
+       (unicode : 97; flag : umf_noinfo; reserved : 0),
+       (unicode : 98; flag : umf_noinfo; reserved : 0),
+       (unicode : 99; flag : umf_noinfo; reserved : 0),
+       (unicode : 100; flag : umf_noinfo; reserved : 0),
+       (unicode : 101; flag : umf_noinfo; reserved : 0),
+       (unicode : 102; flag : umf_noinfo; reserved : 0),
+       (unicode : 103; flag : umf_noinfo; reserved : 0),
+       (unicode : 104; flag : umf_noinfo; reserved : 0),
+       (unicode : 105; flag : umf_noinfo; reserved : 0),
+       (unicode : 106; flag : umf_noinfo; reserved : 0),
+       (unicode : 107; flag : umf_noinfo; reserved : 0),
+       (unicode : 108; flag : umf_noinfo; reserved : 0),
+       (unicode : 109; flag : umf_noinfo; reserved : 0),
+       (unicode : 110; flag : umf_noinfo; reserved : 0),
+       (unicode : 111; flag : umf_noinfo; reserved : 0),
+       (unicode : 112; flag : umf_noinfo; reserved : 0),
+       (unicode : 113; flag : umf_noinfo; reserved : 0),
+       (unicode : 114; flag : umf_noinfo; reserved : 0),
+       (unicode : 115; flag : umf_noinfo; reserved : 0),
+       (unicode : 116; flag : umf_noinfo; reserved : 0),
+       (unicode : 117; flag : umf_noinfo; reserved : 0),
+       (unicode : 118; flag : umf_noinfo; reserved : 0),
+       (unicode : 119; flag : umf_noinfo; reserved : 0),
+       (unicode : 120; flag : umf_noinfo; reserved : 0),
+       (unicode : 121; flag : umf_noinfo; reserved : 0),
+       (unicode : 122; flag : umf_noinfo; reserved : 0),
+       (unicode : 123; flag : umf_noinfo; reserved : 0),
+       (unicode : 124; flag : umf_noinfo; reserved : 0),
+       (unicode : 125; flag : umf_noinfo; reserved : 0),
+       (unicode : 126; flag : umf_noinfo; reserved : 0),
+       (unicode : 127; flag : umf_noinfo; reserved : 0),
+       (unicode : 128; flag : umf_noinfo; reserved : 0),
+       (unicode : 129; flag : umf_noinfo; reserved : 0),
+       (unicode : 130; flag : umf_noinfo; reserved : 0),
+       (unicode : 131; flag : umf_noinfo; reserved : 0),
+       (unicode : 132; flag : umf_noinfo; reserved : 0),
+       (unicode : 133; flag : umf_noinfo; reserved : 0),
+       (unicode : 134; flag : umf_noinfo; reserved : 0),
+       (unicode : 135; flag : umf_noinfo; reserved : 0),
+       (unicode : 136; flag : umf_noinfo; reserved : 0),
+       (unicode : 137; flag : umf_noinfo; reserved : 0),
+       (unicode : 138; flag : umf_noinfo; reserved : 0),
+       (unicode : 139; flag : umf_noinfo; reserved : 0),
+       (unicode : 140; flag : umf_noinfo; reserved : 0),
+       (unicode : 141; flag : umf_noinfo; reserved : 0),
+       (unicode : 142; flag : umf_noinfo; reserved : 0),
+       (unicode : 143; flag : umf_noinfo; reserved : 0),
+       (unicode : 144; flag : umf_noinfo; reserved : 0),
+       (unicode : 145; flag : umf_noinfo; reserved : 0),
+       (unicode : 146; flag : umf_noinfo; reserved : 0),
+       (unicode : 147; flag : umf_noinfo; reserved : 0),
+       (unicode : 148; flag : umf_noinfo; reserved : 0),
+       (unicode : 149; flag : umf_noinfo; reserved : 0),
+       (unicode : 150; flag : umf_noinfo; reserved : 0),
+       (unicode : 151; flag : umf_noinfo; reserved : 0),
+       (unicode : 152; flag : umf_noinfo; reserved : 0),
+       (unicode : 153; flag : umf_noinfo; reserved : 0),
+       (unicode : 154; flag : umf_noinfo; reserved : 0),
+       (unicode : 155; flag : umf_noinfo; reserved : 0),
+       (unicode : 156; flag : umf_noinfo; reserved : 0),
+       (unicode : 157; flag : umf_noinfo; reserved : 0),
+       (unicode : 158; flag : umf_noinfo; reserved : 0),
+       (unicode : 159; flag : umf_noinfo; reserved : 0),
+       (unicode : 160; flag : umf_noinfo; reserved : 0),
+       (unicode : 161; flag : umf_noinfo; reserved : 0),
+       (unicode : 162; flag : umf_noinfo; reserved : 0),
+       (unicode : 163; flag : umf_noinfo; reserved : 0),
+       (unicode : 164; flag : umf_noinfo; reserved : 0),
+       (unicode : 165; flag : umf_noinfo; reserved : 0),
+       (unicode : 166; flag : umf_noinfo; reserved : 0),
+       (unicode : 167; flag : umf_noinfo; reserved : 0),
+       (unicode : 168; flag : umf_noinfo; reserved : 0),
+       (unicode : 169; flag : umf_noinfo; reserved : 0),
+       (unicode : 170; flag : umf_noinfo; reserved : 0),
+       (unicode : 171; flag : umf_noinfo; reserved : 0),
+       (unicode : 172; flag : umf_noinfo; reserved : 0),
+       (unicode : 173; flag : umf_noinfo; reserved : 0),
+       (unicode : 174; flag : umf_noinfo; reserved : 0),
+       (unicode : 175; flag : umf_noinfo; reserved : 0),
+       (unicode : 176; flag : umf_noinfo; reserved : 0),
+       (unicode : 177; flag : umf_noinfo; reserved : 0),
+       (unicode : 178; flag : umf_noinfo; reserved : 0),
+       (unicode : 179; flag : umf_noinfo; reserved : 0),
+       (unicode : 180; flag : umf_noinfo; reserved : 0),
+       (unicode : 181; flag : umf_noinfo; reserved : 0),
+       (unicode : 182; flag : umf_noinfo; reserved : 0),
+       (unicode : 183; flag : umf_noinfo; reserved : 0),
+       (unicode : 184; flag : umf_noinfo; reserved : 0),
+       (unicode : 185; flag : umf_noinfo; reserved : 0),
+       (unicode : 186; flag : umf_noinfo; reserved : 0),
+       (unicode : 187; flag : umf_noinfo; reserved : 0),
+       (unicode : 188; flag : umf_noinfo; reserved : 0),
+       (unicode : 189; flag : umf_noinfo; reserved : 0),
+       (unicode : 190; flag : umf_noinfo; reserved : 0),
+       (unicode : 191; flag : umf_noinfo; reserved : 0),
+       (unicode : 192; flag : umf_noinfo; reserved : 0),
+       (unicode : 193; flag : umf_noinfo; reserved : 0),
+       (unicode : 194; flag : umf_noinfo; reserved : 0),
+       (unicode : 195; flag : umf_noinfo; reserved : 0),
+       (unicode : 196; flag : umf_noinfo; reserved : 0),
+       (unicode : 197; flag : umf_noinfo; reserved : 0),
+       (unicode : 198; flag : umf_noinfo; reserved : 0),
+       (unicode : 199; flag : umf_noinfo; reserved : 0),
+       (unicode : 200; flag : umf_noinfo; reserved : 0),
+       (unicode : 201; flag : umf_noinfo; reserved : 0),
+       (unicode : 202; flag : umf_noinfo; reserved : 0),
+       (unicode : 203; flag : umf_noinfo; reserved : 0),
+       (unicode : 204; flag : umf_noinfo; reserved : 0),
+       (unicode : 205; flag : umf_noinfo; reserved : 0),
+       (unicode : 206; flag : umf_noinfo; reserved : 0),
+       (unicode : 207; flag : umf_noinfo; reserved : 0),
+       (unicode : 208; flag : umf_noinfo; reserved : 0),
+       (unicode : 209; flag : umf_noinfo; reserved : 0),
+       (unicode : 210; flag : umf_noinfo; reserved : 0),
+       (unicode : 211; flag : umf_noinfo; reserved : 0),
+       (unicode : 212; flag : umf_noinfo; reserved : 0),
+       (unicode : 213; flag : umf_noinfo; reserved : 0),
+       (unicode : 214; flag : umf_noinfo; reserved : 0),
+       (unicode : 215; flag : umf_noinfo; reserved : 0),
+       (unicode : 216; flag : umf_noinfo; reserved : 0),
+       (unicode : 217; flag : umf_noinfo; reserved : 0),
+       (unicode : 218; flag : umf_noinfo; reserved : 0),
+       (unicode : 219; flag : umf_noinfo; reserved : 0),
+       (unicode : 220; flag : umf_noinfo; reserved : 0),
+       (unicode : 221; flag : umf_noinfo; reserved : 0),
+       (unicode : 222; flag : umf_noinfo; reserved : 0),
+       (unicode : 223; flag : umf_noinfo; reserved : 0),
+       (unicode : 224; flag : umf_noinfo; reserved : 0),
+       (unicode : 225; flag : umf_noinfo; reserved : 0),
+       (unicode : 226; flag : umf_noinfo; reserved : 0),
+       (unicode : 227; flag : umf_noinfo; reserved : 0),
+       (unicode : 228; flag : umf_noinfo; reserved : 0),
+       (unicode : 229; flag : umf_noinfo; reserved : 0),
+       (unicode : 230; flag : umf_noinfo; reserved : 0),
+       (unicode : 231; flag : umf_noinfo; reserved : 0),
+       (unicode : 232; flag : umf_noinfo; reserved : 0),
+       (unicode : 233; flag : umf_noinfo; reserved : 0),
+       (unicode : 234; flag : umf_noinfo; reserved : 0),
+       (unicode : 235; flag : umf_noinfo; reserved : 0),
+       (unicode : 236; flag : umf_noinfo; reserved : 0),
+       (unicode : 237; flag : umf_noinfo; reserved : 0),
+       (unicode : 238; flag : umf_noinfo; reserved : 0),
+       (unicode : 239; flag : umf_noinfo; reserved : 0),
+       (unicode : 240; flag : umf_noinfo; reserved : 0),
+       (unicode : 241; flag : umf_noinfo; reserved : 0),
+       (unicode : 242; flag : umf_noinfo; reserved : 0),
+       (unicode : 243; flag : umf_noinfo; reserved : 0),
+       (unicode : 244; flag : umf_noinfo; reserved : 0),
+       (unicode : 245; flag : umf_noinfo; reserved : 0),
+       (unicode : 246; flag : umf_noinfo; reserved : 0),
+       (unicode : 247; flag : umf_noinfo; reserved : 0),
+       (unicode : 248; flag : umf_noinfo; reserved : 0),
+       (unicode : 249; flag : umf_noinfo; reserved : 0),
+       (unicode : 250; flag : umf_noinfo; reserved : 0),
+       (unicode : 251; flag : umf_noinfo; reserved : 0),
+       (unicode : 252; flag : umf_noinfo; reserved : 0),
+       (unicode : 253; flag : umf_noinfo; reserved : 0),
+       (unicode : 254; flag : umf_noinfo; reserved : 0),
+       (unicode : 255; flag : umf_noinfo; reserved : 0)
+     );
+
+     unicodemap : tunicodemap = (
+       cpname : '8859-1';
+       map : @map;
+       lastchar : 255;
+       next : nil;
+       internalmap : true
+     );
+
+  begin
+     registermapping(@unicodemap)
+  end.

+ 100 - 0
compiler/crc.pas

@@ -0,0 +1,100 @@
+{
+    Copyright (c) 2000-2002 by Free Pascal Development Team
+
+    Routines to compute CRC values
+
+    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 crc;
+
+{$i fpcdefs.inc}
+
+Interface
+
+Function Crc32(Const HStr:String):cardinal;
+Function UpdateCrc32(InitCrc:cardinal;const InBuf;InLen:integer):cardinal;
+Function UpdCrc32(InitCrc:cardinal;b:byte):cardinal;
+
+
+Implementation
+
+{*****************************************************************************
+                                   Crc 32
+*****************************************************************************}
+
+var
+  Crc32Tbl : array[0..255] of cardinal;
+
+procedure MakeCRC32Tbl;
+var
+  crc : cardinal;
+  i,n : integer;
+begin
+  for i:=0 to 255 do
+   begin
+     crc:=i;
+     for n:=1 to 8 do
+      if (crc and 1)<>0 then
+       crc:=(crc shr 1) xor cardinal($edb88320)
+      else
+       crc:=crc shr 1;
+     Crc32Tbl[i]:=crc;
+   end;
+end;
+
+
+Function Crc32(Const HStr:String):cardinal;
+var
+  i : integer;
+  InitCrc : cardinal;
+begin
+  if Crc32Tbl[1]=0 then
+   MakeCrc32Tbl;
+  InitCrc:=cardinal($ffffffff);
+  for i:=1 to Length(Hstr) do
+   InitCrc:=Crc32Tbl[byte(InitCrc) xor ord(Hstr[i])] xor (InitCrc shr 8);
+  Crc32:=InitCrc;
+end;
+
+
+
+Function UpdateCrc32(InitCrc:cardinal;const InBuf;InLen:Integer):cardinal;
+var
+  i : integer;
+  p : pchar;
+begin
+  if Crc32Tbl[1]=0 then
+   MakeCrc32Tbl;
+  p:=@InBuf;
+  for i:=1 to InLen do
+   begin
+     InitCrc:=Crc32Tbl[byte(InitCrc) xor byte(p^)] xor (InitCrc shr 8);
+     inc(p);
+   end;
+  UpdateCrc32:=InitCrc;
+end;
+
+
+
+Function UpdCrc32(InitCrc:cardinal;b:byte):cardinal;
+begin
+  if Crc32Tbl[1]=0 then
+   MakeCrc32Tbl;
+  UpdCrc32:=Crc32Tbl[byte(InitCrc) xor b] xor (InitCrc shr 8);
+end;
+
+end.

+ 294 - 0
compiler/cresstr.pas

@@ -0,0 +1,294 @@
+{
+    Copyright (c) 1998-2002 by Michael van Canneyt
+
+    Handles resourcestrings
+
+    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 cresstr;
+
+{$i fpcdefs.inc}
+
+interface
+
+uses
+  cclasses;
+
+Type
+  { These are used to form a singly-linked list, ordered by hash value }
+  TResourceStringItem = class(TLinkedListItem)
+    Name  : String;
+    Value : Pchar;
+    Len   : Longint;
+    hash  : Cardinal;
+    constructor Create(const AName:string;AValue:pchar;ALen:longint);
+    destructor  Destroy;override;
+    procedure CalcHash;
+  end;
+
+  Tresourcestrings=class
+  private
+    List : TLinkedList;
+  public
+    ResStrCount : longint;
+    constructor Create;
+    destructor  Destroy;override;
+    function  Register(Const name : string;p : pchar;len : longint) : longint;
+    procedure CreateResourceStringList;
+    Procedure WriteResourceFile(const FileName : String);
+  end;
+
+var
+  resourcestrings : Tresourcestrings;
+
+
+implementation
+
+uses
+   cutils,globtype,globals,
+   symdef,
+   verbose,fmodule,
+   aasmbase,aasmtai,
+   aasmcpu;
+
+
+{ ---------------------------------------------------------------------
+   Calculate hash value, based on the string
+  ---------------------------------------------------------------------}
+
+{ ---------------------------------------------------------------------
+                          TRESOURCESTRING_ITEM
+  ---------------------------------------------------------------------}
+
+constructor TResourceStringItem.Create(const AName:string;AValue:pchar;ALen:longint);
+begin
+  inherited Create;
+  Name:=AName;
+  Len:=ALen;
+  GetMem(Value,Len);
+  Move(AValue^,Value^,Len);
+  CalcHash;
+end;
+
+
+destructor TResourceStringItem.Destroy;
+begin
+  FreeMem(Value,Len);
+end;
+
+procedure TResourceStringItem.CalcHash;
+Var
+  g : Cardinal;
+  I : longint;
+begin
+  hash:=0;
+  For I:=0 to Len-1 do { 0 terminated }
+   begin
+     hash:=hash shl 4;
+     inc(Hash,Ord(Value[i]));
+     g:=hash and ($f shl 28);
+     if g<>0 then
+      begin
+        hash:=hash xor (g shr 24);
+        hash:=hash xor g;
+      end;
+   end;
+  If Hash=0 then
+    Hash:=$ffffffff;
+end;
+
+
+{ ---------------------------------------------------------------------
+                          Tresourcestrings
+  ---------------------------------------------------------------------}
+
+Constructor Tresourcestrings.Create;
+begin
+  List:=TStringList.Create;
+  ResStrCount:=0;
+end;
+
+
+Destructor Tresourcestrings.Destroy;
+begin
+  List.Free;
+end;
+
+
+{ ---------------------------------------------------------------------
+    Create the full asmlist for resourcestrings.
+  ---------------------------------------------------------------------}
+
+procedure Tresourcestrings.CreateResourceStringList;
+
+  Procedure AppendToAsmResList (P : TResourceStringItem);
+  Var
+    l1 : tasmlabel;
+    s : pchar;
+    l : longint;
+  begin
+    with p Do
+     begin
+       if (Value=nil) or (len=0) then
+         asmlist[al_resourcestrings].concat(tai_const.create_sym(nil))
+       else
+         begin
+            objectlibrary.getdatalabel(l1);
+            asmlist[al_resourcestrings].concat(tai_const.create_sym(l1));
+            maybe_new_object_file(asmlist[al_const]);
+            asmlist[al_const].concat(tai_align.Create(const_align(sizeof(aint))));
+            asmlist[al_const].concat(tai_const.create_aint(-1));
+            asmlist[al_const].concat(tai_const.create_aint(len));
+            asmlist[al_const].concat(tai_label.create(l1));
+            getmem(s,len+1);
+            move(value^,s^,len);
+            s[len]:=#0;
+            asmlist[al_const].concat(tai_string.create_pchar(s,len));
+            asmlist[al_const].concat(tai_const.create_8bit(0));
+         end;
+       { append Current value (nil) and hash...}
+       asmlist[al_resourcestrings].concat(tai_const.create_sym(nil));
+       asmlist[al_resourcestrings].concat(tai_const.create_32bit(longint(hash)));
+       { Append the name as a ansistring. }
+       objectlibrary.getdatalabel(l1);
+       l:=length(name);
+       asmlist[al_resourcestrings].concat(tai_const.create_sym(l1));
+       maybe_new_object_file(asmlist[al_const]);
+       asmlist[al_const].concat(tai_align.create(const_align(sizeof(aint))));
+       asmlist[al_const].concat(tai_const.create_aint(-1));
+       asmlist[al_const].concat(tai_const.create_aint(l));
+       asmlist[al_const].concat(tai_label.create(l1));
+       getmem(s,l+1);
+       move(Name[1],s^,l);
+       s[l]:=#0;
+       asmlist[al_const].concat(tai_string.create_pchar(s,l));
+       asmlist[al_const].concat(tai_const.create_8bit(0));
+     end;
+  end;
+
+Var
+  R : tresourceStringItem;
+begin
+  if asmlist[al_resourcestrings]=nil then
+    asmlist[al_resourcestrings]:=taasmoutput.create;
+  maybe_new_object_file(asmlist[al_resourcestrings]);
+  new_section(asmlist[al_resourcestrings],sec_data,'',4);
+  asmlist[al_resourcestrings].concat(tai_align.create(const_align(sizeof(aint))));
+  asmlist[al_resourcestrings].concat(tai_symbol.createname_global(
+    make_mangledname('RESOURCESTRINGLIST',current_module.localsymtable,''),AT_DATA,0));
+  asmlist[al_resourcestrings].concat(tai_const.create_32bit(resstrcount));
+  R:=TResourceStringItem(List.First);
+  while assigned(R) do
+   begin
+     AppendToAsmResList(R);
+     R:=TResourceStringItem(R.Next);
+   end;
+  asmlist[al_resourcestrings].concat(tai_symbol_end.createname(
+    current_module.modulename^+'_'+'RESOURCESTRINGLIST'));
+end;
+
+
+{ ---------------------------------------------------------------------
+    Insert 1 resource string in all tables.
+  ---------------------------------------------------------------------}
+
+function  Tresourcestrings.Register(const name : string;p : pchar;len : longint) : longint;
+begin
+  List.Concat(tResourceStringItem.Create(lower(current_module.modulename^+'.'+Name),p,len));
+  Register:=ResStrCount;
+  inc(ResStrCount);
+end;
+
+
+Procedure Tresourcestrings.WriteResourceFile(const FileName : String);
+Type
+  TMode = (quoted,unquoted);
+Var
+  F : Text;
+  Mode : TMode;
+  R : TResourceStringItem;
+  C : char;
+  Col,i : longint;
+
+  Procedure Add(Const S : String);
+  begin
+    Write(F,S);
+    Col:=Col+length(s);
+  end;
+
+begin
+  If List.Empty then
+    exit;
+  message1 (general_i_writingresourcefile,SplitFileName(filename));
+  Assign(F,Filename);
+  {$i-}
+  Rewrite(f);
+  {$i+}
+  If IOresult<>0 then
+    begin
+      message1(general_e_errorwritingresourcefile,filename);
+      exit;
+    end;
+  R:=TResourceStringItem(List.First);
+  While assigned(R) do
+   begin
+     writeln(f);
+     Writeln(f,'# hash value = ',R.hash);
+     col:=0;
+     Add(R.Name+'=');
+     Mode:=unquoted;
+     For I:=0 to R.Len-1 do
+      begin
+        C:=R.Value[i];
+        If (ord(C)>31) and (Ord(c)<=128) and (c<>'''') then
+         begin
+           If mode=Quoted then
+            Add(c)
+           else
+            begin
+              Add(''''+c);
+              mode:=quoted
+            end;
+         end
+        else
+         begin
+           If Mode=quoted then
+            begin
+              Add('''');
+              mode:=unquoted;
+            end;
+           Add('#'+tostr(ord(c)));
+         end;
+        If Col>72 then
+         begin
+           if mode=quoted then
+            Write (F,'''');
+           Writeln(F,'+');
+           Col:=0;
+           Mode:=unQuoted;
+         end;
+      end;
+     if mode=quoted then
+      writeln (f,'''');
+     Writeln(f);
+     R:=TResourceStringItem(R.Next);
+   end;
+  close(f);
+end;
+
+
+end.

+ 613 - 0
compiler/cstreams.pas

@@ -0,0 +1,613 @@
+{
+    Copyright (c) 1998-2002 by Florian Klaempfl and Peter Vreman
+
+    This module provides stream classes
+
+    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 cstreams;
+
+{$i fpcdefs.inc}
+
+interface
+
+   uses
+     cutils;
+
+
+{****************************************************************************
+                                  TCStream
+****************************************************************************}
+
+    {
+      TCStream is copied directly from classesh.inc from the FCL so
+      it's compatible with the normal Classes.TStream.
+
+      TCFileStream is a merge of THandleStream and TFileStream and updated
+      to have a 'file' type instead of Handle.
+
+      TCCustomMemoryStream and TCMemoryStream are direct copies.
+    }
+    const
+       { TCStream seek origins }
+       soFromBeginning = 0;
+       soFromCurrent = 1;
+       soFromEnd = 2;
+
+       { TCFileStream create mode }
+       fmCreate        = $FFFF;
+       fmOpenRead      = 0;
+       fmOpenWrite     = 1;
+       fmOpenReadWrite = 2;
+
+var
+{ Used for Error reporting instead of exceptions }
+  CStreamError : longint;
+
+type
+{ Fake TComponent class, it isn't used any futher }
+  TCComponent = class(TObject)
+  end;
+
+{ TCStream abstract class }
+
+  TCStream = class(TObject)
+  private
+    function GetPosition: Longint;
+    procedure SetPosition(Pos: Longint);
+    function GetSize: Longint;
+  protected
+    procedure SetSize(NewSize: Longint); virtual;
+  public
+    function Read(var Buffer; Count: Longint): Longint; virtual; abstract;
+    function Write(const Buffer; Count: Longint): Longint; virtual; abstract;
+    function Seek(Offset: Longint; Origin: Word): Longint; virtual; abstract;
+    procedure ReadBuffer(var Buffer; Count: Longint);
+    procedure WriteBuffer(const Buffer; Count: Longint);
+    function CopyFrom(Source: TCStream; Count: Longint): Longint;
+    function ReadComponent(Instance: TCComponent): TCComponent;
+    function ReadComponentRes(Instance: TCComponent): TCComponent;
+    procedure WriteComponent(Instance: TCComponent);
+    procedure WriteComponentRes(const ResName: string; Instance: TCComponent);
+    procedure WriteDescendent(Instance, Ancestor: TCComponent);
+    procedure WriteDescendentRes(const ResName: string; Instance, Ancestor: TCComponent);
+    procedure WriteResourceHeader(const ResName: string; {!!!:out} var FixupInfo: Integer);
+    procedure FixupResourceHeader(FixupInfo: Integer);
+    procedure ReadResHeader;
+    function ReadByte : Byte;
+    function ReadWord : Word;
+    function ReadDWord : Cardinal;
+    function ReadAnsiString : AnsiString;
+    procedure WriteByte(b : Byte);
+    procedure WriteWord(w : Word);
+    procedure WriteDWord(d : Cardinal);
+    Procedure WriteAnsiString (S : AnsiString);
+    property Position: Longint read GetPosition write SetPosition;
+    property Size: Longint read GetSize write SetSize;
+  end;
+
+{ TFileStream class }
+
+  TCFileStream = class(TCStream)
+  Private
+    FFileName : String;
+    FHandle: File;
+  protected
+    procedure SetSize(NewSize: Longint); override;
+  public
+    constructor Create(const AFileName: string; Mode: Word);
+    destructor Destroy; override;
+    function Read(var Buffer; Count: Longint): Longint; override;
+    function Write(const Buffer; Count: Longint): Longint; override;
+    function Seek(Offset: Longint; Origin: Word): Longint; override;
+    property FileName : String Read FFilename;
+  end;
+
+{ TCustomMemoryStream abstract class }
+
+  TCCustomMemoryStream = class(TCStream)
+  private
+    FMemory: Pointer;
+    FSize, FPosition: Longint;
+  protected
+    procedure SetPointer(Ptr: Pointer; ASize: Longint);
+  public
+    function Read(var Buffer; Count: Longint): Longint; override;
+    function Seek(Offset: Longint; Origin: Word): Longint; override;
+    procedure SaveToStream(Stream: TCStream);
+    procedure SaveToFile(const FileName: string);
+    property Memory: Pointer read FMemory;
+  end;
+
+{ TCMemoryStream }
+
+  TCMemoryStream = class(TCCustomMemoryStream)
+  private
+    FCapacity: Longint;
+    procedure SetCapacity(NewCapacity: Longint);
+  protected
+    function Realloc(var NewCapacity: Longint): Pointer; virtual;
+    property Capacity: Longint read FCapacity write SetCapacity;
+  public
+    destructor Destroy; override;
+    procedure Clear;
+    procedure LoadFromStream(Stream: TCStream);
+    procedure LoadFromFile(const FileName: string);
+    procedure SetSize(NewSize: Longint); override;
+    function Write(const Buffer; Count: Longint): Longint; override;
+  end;
+
+
+implementation
+
+  Type
+    PByte = ^Byte;
+
+{*****************************************************************************
+                                   TCStream
+*****************************************************************************}
+
+  function TCStream.GetPosition: Longint;
+
+    begin
+       Result:=Seek(0,soFromCurrent);
+    end;
+
+  procedure TCStream.SetPosition(Pos: Longint);
+
+    begin
+       Seek(pos,soFromBeginning);
+    end;
+
+  function TCStream.GetSize: Longint;
+
+    var
+       p : longint;
+
+    begin
+       p:=GetPosition;
+       GetSize:=Seek(0,soFromEnd);
+       Seek(p,soFromBeginning);
+    end;
+
+  procedure TCStream.SetSize(NewSize: Longint);
+
+    begin
+    // We do nothing. Pipe streams don't support this
+    // As wel as possible read-ony streams !!
+    end;
+
+  procedure TCStream.ReadBuffer(var Buffer; Count: Longint);
+
+    begin
+       CStreamError:=0;
+       if Read(Buffer,Count)<Count then
+         CStreamError:=102;
+    end;
+
+  procedure TCStream.WriteBuffer(const Buffer; Count: Longint);
+
+    begin
+       CStreamError:=0;
+       if Write(Buffer,Count)<Count then
+         CStreamError:=103;
+    end;
+
+  function TCStream.CopyFrom(Source: TCStream; Count: Longint): Longint;
+
+    var
+       i : longint;
+       buffer : array[0..1023] of byte;
+
+    begin
+       CStreamError:=0;
+       Result:=0;
+       while Count>0 do
+         begin
+            if (Count>sizeof(buffer)) then
+              i:=sizeof(Buffer)
+            else
+              i:=Count;
+            i:=Source.Read(buffer,i);
+            i:=Write(buffer,i);
+            dec(count,i);
+            inc(Result,i);
+            if i=0 then
+              exit;
+         end;
+    end;
+
+  function TCStream.ReadComponent(Instance: TCComponent): TCComponent;
+    begin
+      Result:=nil;
+    end;
+
+  function TCStream.ReadComponentRes(Instance: TCComponent): TCComponent;
+    begin
+      Result:=nil;
+    end;
+
+  procedure TCStream.WriteComponent(Instance: TCComponent);
+    begin
+    end;
+
+  procedure TCStream.WriteComponentRes(const ResName: string; Instance: TCComponent);
+    begin
+    end;
+
+  procedure TCStream.WriteDescendent(Instance, Ancestor: TCComponent);
+    begin
+    end;
+
+  procedure TCStream.WriteDescendentRes(const ResName: string; Instance, Ancestor: TCComponent);
+    begin
+    end;
+
+  procedure TCStream.WriteResourceHeader(const ResName: string; {!!!: out} var FixupInfo: Integer);
+    begin
+    end;
+
+  procedure TCStream.FixupResourceHeader(FixupInfo: Integer);
+    begin
+    end;
+
+  procedure TCStream.ReadResHeader;
+    begin
+    end;
+
+  function TCStream.ReadByte : Byte;
+
+    var
+       b : Byte;
+
+    begin
+       ReadBuffer(b,1);
+       ReadByte:=b;
+    end;
+
+  function TCStream.ReadWord : Word;
+
+    var
+       w : Word;
+
+    begin
+       ReadBuffer(w,2);
+       ReadWord:=w;
+    end;
+
+  function TCStream.ReadDWord : Cardinal;
+
+    var
+       d : Cardinal;
+
+    begin
+       ReadBuffer(d,4);
+       ReadDWord:=d;
+    end;
+
+  Function TCStream.ReadAnsiString : AnsiString;
+  Var
+    TheSize : Longint;
+    P : PByte ;
+  begin
+    ReadBuffer (TheSize,SizeOf(TheSize));
+    SetLength(Result,TheSize);
+    // Illegal typecast if no AnsiStrings defined.
+    if TheSize>0 then
+     begin
+       ReadBuffer (Pointer(Result)^,TheSize);
+       P:=PByte(PtrInt(Result)+TheSize);
+       p^:=0;
+     end;
+   end;
+
+  Procedure TCStream.WriteAnsiString (S : AnsiString);
+
+  Var L : Longint;
+
+  begin
+    L:=Length(S);
+    WriteBuffer (L,SizeOf(L));
+    WriteBuffer (Pointer(S)^,L);
+  end;
+
+  procedure TCStream.WriteByte(b : Byte);
+
+    begin
+       WriteBuffer(b,1);
+    end;
+
+  procedure TCStream.WriteWord(w : Word);
+
+    begin
+       WriteBuffer(w,2);
+    end;
+
+  procedure TCStream.WriteDWord(d : Cardinal);
+
+    begin
+       WriteBuffer(d,4);
+    end;
+
+
+{****************************************************************************}
+{*                             TCFileStream                                  *}
+{****************************************************************************}
+
+constructor TCFileStream.Create(const AFileName: string; Mode: Word);
+begin
+  FFileName:=AFileName;
+  If Mode=fmcreate then
+    begin
+      system.assign(FHandle,AFileName);
+      {$I-}
+       system.rewrite(FHandle,1);
+      {$I+}
+      CStreamError:=IOResult;
+    end
+  else
+    begin
+      system.assign(FHandle,AFileName);
+      {$I-}
+       system.reset(FHandle,1);
+      {$I+}
+      CStreamError:=IOResult;
+    end;
+end;
+
+
+destructor TCFileStream.Destroy;
+begin
+  {$I-}
+   System.Close(FHandle);
+  {$I+}
+  CStreamError:=IOResult;
+end;
+
+
+function TCFileStream.Read(var Buffer; Count: Longint): Longint;
+begin
+  CStreamError:=0;
+  BlockRead(FHandle,Buffer,Count,Result);
+  If Result=-1 then Result:=0;
+end;
+
+
+function TCFileStream.Write(const Buffer; Count: Longint): Longint;
+begin
+  CStreamError:=0;
+  BlockWrite (FHandle,(@Buffer)^,Count,Result);
+  If Result=-1 then Result:=0;
+end;
+
+
+Procedure TCFileStream.SetSize(NewSize: Longint);
+begin
+  {$I-}
+   System.Seek(FHandle,NewSize);
+   System.Truncate(FHandle);
+  {$I+}
+  CStreamError:=IOResult;
+end;
+
+
+function TCFileStream.Seek(Offset: Longint; Origin: Word): Longint;
+var
+  l : longint;
+begin
+  {$I-}
+   case Origin of
+     soFromBeginning :
+       System.Seek(FHandle,Offset);
+     soFromCurrent :
+       begin
+         l:=System.FilePos(FHandle);
+         inc(l,Offset);
+         System.Seek(FHandle,l);
+       end;
+     soFromEnd :
+       begin
+         l:=System.FileSize(FHandle);
+         dec(l,Offset);
+         if l<0 then
+          l:=0;
+         System.Seek(FHandle,l);
+       end;
+   end;
+  {$I+}
+  CStreamError:=IOResult;
+  Result:=CStreamError;
+end;
+
+
+{****************************************************************************}
+{*                             TCustomMemoryStream                          *}
+{****************************************************************************}
+
+procedure TCCustomMemoryStream.SetPointer(Ptr: Pointer; ASize: Longint);
+
+begin
+  FMemory:=Ptr;
+  FSize:=ASize;
+end;
+
+
+function TCCustomMemoryStream.Read(var Buffer; Count: Longint): Longint;
+
+begin
+  Result:=0;
+  If (FSize>0) and (FPosition<Fsize) then
+    begin
+    Result:=FSize-FPosition;
+    If Result>Count then Result:=Count;
+    Move (Pointer(PtrInt(FMemory)+FPosition)^,Buffer,Result);
+    FPosition:=Fposition+Result;
+    end;
+end;
+
+
+function TCCustomMemoryStream.Seek(Offset: Longint; Origin: Word): Longint;
+
+begin
+  Case Origin of
+    soFromBeginning : FPosition:=Offset;
+    soFromEnd       : FPosition:=FSize+Offset;
+    soFromCurrent   : FpoSition:=FPosition+Offset;
+  end;
+  Result:=FPosition;
+end;
+
+
+procedure TCCustomMemoryStream.SaveToStream(Stream: TCStream);
+
+begin
+  if FSize>0 then Stream.WriteBuffer (FMemory^,FSize);
+end;
+
+
+procedure TCCustomMemoryStream.SaveToFile(const FileName: string);
+
+Var S : TCFileStream;
+
+begin
+  Try
+    S:=TCFileStream.Create (FileName,fmCreate);
+    SaveToStream(S);
+  finally
+    S.free;
+  end;
+end;
+
+
+{****************************************************************************}
+{*                             TCMemoryStream                                *}
+{****************************************************************************}
+
+
+Const TMSGrow = 4096; { Use 4k blocks. }
+
+procedure TCMemoryStream.SetCapacity(NewCapacity: Longint);
+
+begin
+  SetPointer (Realloc(NewCapacity),Fsize);
+  FCapacity:=NewCapacity;
+end;
+
+
+function TCMemoryStream.Realloc(var NewCapacity: Longint): Pointer;
+
+Var MoveSize : Longint;
+
+begin
+  CStreamError:=0;
+  If NewCapacity>0 Then // round off to block size.
+    NewCapacity := (NewCapacity + (TMSGrow-1)) and not (TMSGROW-1);
+  // Only now check !
+  If NewCapacity=FCapacity then
+    Result:=FMemory
+  else
+    If NewCapacity=0 then
+      FreeMem (FMemory,Fcapacity)
+    else
+      begin
+      GetMem (Result,NewCapacity);
+      If Result=Nil then
+        CStreamError:=204;
+      If FCapacity>0 then
+        begin
+        MoveSize:=FSize;
+        If MoveSize>NewCapacity then MoveSize:=NewCapacity;
+        Move (Fmemory^,Result^,MoveSize);
+        FreeMem (FMemory,FCapacity);
+        end;
+      end;
+end;
+
+
+destructor TCMemoryStream.Destroy;
+
+begin
+  Clear;
+  Inherited Destroy;
+end;
+
+
+procedure TCMemoryStream.Clear;
+
+begin
+  FSize:=0;
+  FPosition:=0;
+  SetCapacity (0);
+end;
+
+
+procedure TCMemoryStream.LoadFromStream(Stream: TCStream);
+
+begin
+  Stream.Position:=0;
+  SetSize(Stream.Size);
+  If FSize>0 then Stream.ReadBuffer(FMemory^,FSize);
+end;
+
+
+procedure TCMemoryStream.LoadFromFile(const FileName: string);
+
+Var S : TCFileStream;
+
+begin
+  Try
+    S:=TCFileStream.Create (FileName,fmOpenRead);
+    LoadFromStream(S);
+  finally
+    S.free;
+  end;
+end;
+
+
+procedure TCMemoryStream.SetSize(NewSize: Longint);
+
+begin
+  SetCapacity (NewSize);
+  FSize:=NewSize;
+  IF FPosition>FSize then
+    FPosition:=FSize;
+end;
+
+
+function TCMemoryStream.Write(const Buffer; Count: Longint): Longint;
+
+Var NewPos : Longint;
+
+begin
+  If Count=0 then
+   begin
+     Result:=0;
+     exit;
+   end;
+  NewPos:=FPosition+Count;
+  If NewPos>Fsize then
+    begin
+    IF NewPos>FCapacity then
+      SetCapacity (NewPos);
+    FSize:=Newpos;
+    end;
+  System.Move (Buffer,Pointer(Ptrint(FMemory)+FPosition)^,Count);
+  FPosition:=NewPos;
+  Result:=Count;
+end;
+
+end.

+ 1081 - 0
compiler/cutils.pas

@@ -0,0 +1,1081 @@
+{
+    Copyright (c) 1998-2002 by Florian Klaempfl
+
+    This unit implements some support functions
+
+    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 some generic support functions which are used
+   in the different parts of the compiler.
+}
+unit cutils;
+
+{$i fpcdefs.inc}
+
+interface
+
+
+    type
+       pstring = ^string;
+       Tcharset=set of char;
+
+    var
+      internalerrorproc : procedure(i:longint);
+
+
+    {# Returns the minimal value between @var(a) and @var(b) }
+    function min(a,b : longint) : longint;{$ifdef USEINLINE}inline;{$endif}
+    function min(a,b : int64) : int64;{$ifdef USEINLINE}inline;{$endif}
+    {# Returns the maximum value between @var(a) and @var(b) }
+    function max(a,b : longint) : longint;{$ifdef USEINLINE}inline;{$endif}
+    function max(a,b : int64) : int64;{$ifdef USEINLINE}inline;{$endif}
+    {# Returns the value in @var(x) swapped to different endian }
+    Function SwapInt64(x : int64): int64;{$ifdef USEINLINE}inline;{$endif}
+    {# Returns the value in @var(x) swapped to different endian }
+    function SwapLong(x : longint): longint;{$ifdef USEINLINE}inline;{$endif}
+    {# Returns the value in @va(x) swapped to different endian }
+    function SwapWord(x : word): word;{$ifdef USEINLINE}inline;{$endif}
+    {# Return value @var(i) aligned on @var(a) boundary }
+    function align(i,a:longint):longint;{$ifdef USEINLINE}inline;{$endif}
+
+    function used_align(varalign,minalign,maxalign:longint):longint;
+    function size_2_align(len : longint) : longint;
+    procedure Replace(var s:string;s1:string;const s2:string);
+    procedure Replace(var s:AnsiString;s1:string;const s2:string);
+    procedure ReplaceCase(var s:string;const s1,s2:string);
+    function upper(const s : string) : string;
+    function lower(const s : string) : string;
+    function trimbspace(const s:string):string;
+    function trimspace(const s:string):string;
+    function space (b : longint): string;
+    function PadSpace(const s:string;len:longint):string;
+    function GetToken(var s:string;endchar:char):string;
+    procedure uppervar(var s : string);
+    function hexstr(val : cardinal;cnt : cardinal) : string;
+    function realtostr(e:extended):string;{$ifdef USEINLINE}inline;{$endif}
+    function tostr(i : qword) : string;{$ifdef USEINLINE}inline;{$endif}overload;
+    function tostr(i : int64) : string;{$ifdef USEINLINE}inline;{$endif}overload;
+    function tostr(i : longint) : string;{$ifdef USEINLINE}inline;{$endif}overload;
+    function tostr_with_plus(i : int64) : string;{$ifdef USEINLINE}inline;{$endif}
+    function DStr(l:longint):string;
+    {# Returns true if the string s is a number }
+    function is_number(const s : string) : boolean;{$ifdef USEINLINE}inline;{$endif}
+    {# Returns true if value is a power of 2, the actual
+       exponent value is returned in power.
+    }
+    function ispowerof2(value : int64;out power : longint) : boolean;
+    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;
+
+    {# If the string is quoted, in accordance with pascal, it is
+       dequoted and returned in s, and the function returns true.
+       If it is not quoted, or if the quoting is bad, s is not touched,
+       and false is returned.
+    }
+    function DePascalQuote(var s: string): Boolean;
+    function CompareText(S1, S2: string): longint;
+
+    { releases the string p and assignes nil to p }
+    { if p=nil then freemem isn't called          }
+    procedure stringdispose(var p : pstring);{$ifdef USEINLINE}inline;{$endif}
+
+
+    { allocates mem for a copy of s, copies s to this mem and returns }
+    { a pointer to this mem                                           }
+    function stringdup(const s : string) : pstring;{$ifdef USEINLINE}inline;{$endif}
+
+    {# Allocates memory for the string @var(s) and copies s as zero
+       terminated string to that allocated memory and returns a pointer
+       to that mem
+    }
+    function  strpnew(const s : string) : pchar;
+    procedure strdispose(var p : pchar);
+
+    {# makes the character @var(c) lowercase, with spanish, french and german
+       character set
+    }
+    function lowercase(c : char) : char;
+
+    { makes zero terminated string to a pascal string }
+    { the data in p is modified and p is returned     }
+    function pchar2pstring(p : pchar) : pstring;
+
+    { ambivalent to pchar2pstring }
+    function pstring2pchar(p : pstring) : pchar;
+
+    { Speed/Hash value }
+    Function GetSpeedValue(Const s:String):cardinal;
+
+    { Ansistring (pchar+length) support }
+    procedure ansistringdispose(var p : pchar;length : longint);
+    function compareansistrings(p1,p2 : pchar;length1,length2 : longint) : longint;
+    function concatansistrings(p1,p2 : pchar;length1,length2 : longint) : pchar;
+
+    {Lzw encode/decode to compress strings -> save memory.}
+    function minilzw_encode(const s:string):string;
+    function minilzw_decode(const s:string):string;
+
+
+implementation
+
+uses
+  strings
+  ;
+
+
+    var
+      uppertbl,
+      lowertbl  : array[char] of char;
+
+
+    function min(a,b : longint) : longint;{$ifdef USEINLINE}inline;{$endif}
+    {
+      return the minimal of a and b
+    }
+      begin
+         if a>b then
+           min:=b
+         else
+           min:=a;
+      end;
+
+
+    function min(a,b : int64) : int64;{$ifdef USEINLINE}inline;{$endif}
+    {
+      return the minimal of a and b
+    }
+      begin
+         if a>b then
+           min:=b
+         else
+           min:=a;
+      end;
+
+
+    function max(a,b : longint) : longint;{$ifdef USEINLINE}inline;{$endif}
+    {
+      return the maximum of a and b
+    }
+      begin
+         if a<b then
+           max:=b
+         else
+           max:=a;
+      end;
+
+
+    function max(a,b : int64) : int64;{$ifdef USEINLINE}inline;{$endif}
+    {
+      return the maximum of a and b
+    }
+      begin
+         if a<b then
+           max:=b
+         else
+           max:=a;
+      end;
+
+
+    Function SwapLong(x : longint): longint;{$ifdef USEINLINE}inline;{$endif}
+      var
+        y : word;
+        z : word;
+      Begin
+        y := x shr 16;
+        y := word(longint(y) shl 8) or (y shr 8);
+        z := x and $FFFF;
+        z := word(longint(z) shl 8) or (z shr 8);
+        SwapLong := (longint(z) shl 16) or longint(y);
+      End;
+
+
+    Function SwapInt64(x : int64): int64;{$ifdef USEINLINE}inline;{$endif}
+      Begin
+        result:=swaplong(longint(hi(x)));
+        result:=result or (swaplong(longint(lo(x))) shl 32);
+      End;
+
+
+    Function SwapWord(x : word): word;{$ifdef USEINLINE}inline;{$endif}
+      var
+        z : byte;
+      Begin
+        z := x shr 8;
+        x := x and $ff;
+        x := (x shl 8);
+        SwapWord := x or z;
+      End;
+
+
+    function align(i,a:longint):longint;{$ifdef USEINLINE}inline;{$endif}
+    {
+      return value <i> aligned <a> boundary
+    }
+      begin
+        { for 0 and 1 no aligning is needed }
+        if a<=1 then
+          result:=i
+        else
+          begin
+            if i<0 then
+              result:=((i-a+1) div a) * a
+            else
+              result:=((i+a-1) div a) * a;
+          end;
+      end;
+
+
+    function size_2_align(len : longint) : longint;
+      begin
+         if len>16 then
+           size_2_align:=32
+         else if len>8 then
+           size_2_align:=16
+         else if len>4 then
+           size_2_align:=8
+         else if len>2 then
+           size_2_align:=4
+         else if len>1 then
+           size_2_align:=2
+         else
+           size_2_align:=1;
+      end;
+
+
+    function used_align(varalign,minalign,maxalign:longint):longint;
+      begin
+        { varalign  : minimum alignment required for the variable
+          minalign  : Minimum alignment of this structure, 0 = undefined
+          maxalign  : Maximum alignment of this structure, 0 = undefined }
+        if (minalign>0) and
+           (varalign<minalign) then
+         used_align:=minalign
+        else
+         begin
+           if (maxalign>0) and
+              (varalign>maxalign) then
+            used_align:=maxalign
+           else
+            used_align:=varalign;
+         end;
+      end;
+
+
+    procedure Replace(var s:string;s1:string;const s2:string);
+      var
+         last,
+         i  : longint;
+      begin
+        s1:=upper(s1);
+        last:=0;
+        repeat
+          i:=pos(s1,upper(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;
+
+
+    procedure Replace(var s:AnsiString;s1:string;const s2:string);
+      var
+         last,
+         i  : longint;
+      begin
+        s1:=upper(s1);
+        last:=0;
+        repeat
+          i:=pos(s1,upper(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;
+
+
+    procedure ReplaceCase(var s:string;const s1,s2:string);
+      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 upper(const s : string) : string;
+    {
+      return uppercased string of s
+    }
+      var
+        i  : longint;
+      begin
+        for i:=1 to length(s) do
+          upper[i]:=uppertbl[s[i]];
+        upper[0]:=s[0];
+      end;
+
+
+    function lower(const s : string) : string;
+    {
+      return lowercased string of s
+    }
+      var
+        i : longint;
+      begin
+        for i:=1 to length(s) do
+          lower[i]:=lowertbl[s[i]];
+        lower[0]:=s[0];
+      end;
+
+
+    procedure uppervar(var s : string);
+    {
+      uppercase string s
+    }
+      var
+         i : longint;
+      begin
+         for i:=1 to length(s) do
+          s[i]:=uppertbl[s[i]];
+      end;
+
+
+    procedure initupperlower;
+      var
+        c : char;
+      begin
+        for c:=#0 to #255 do
+         begin
+           lowertbl[c]:=c;
+           uppertbl[c]:=c;
+           case c of
+             'A'..'Z' :
+               lowertbl[c]:=char(byte(c)+32);
+             'a'..'z' :
+               uppertbl[c]:=char(byte(c)-32);
+           end;
+         end;
+      end;
+
+
+    function hexstr(val : cardinal;cnt : cardinal) : string;
+      const
+        HexTbl : array[0..15] of char='0123456789ABCDEF';
+      var
+        i,j : cardinal;
+      begin
+        { calculate required length }
+        i:=0;
+        j:=val;
+        while (j>0) do
+         begin
+           inc(i);
+           j:=j shr 4;
+         end;
+        { generate fillers }
+        j:=0;
+        while (i+j<cnt) do
+         begin
+           inc(j);
+           hexstr[j]:='0';
+         end;
+        { generate hex }
+        inc(j,i);
+        hexstr[0]:=chr(j);
+        while (val>0) do
+         begin
+           hexstr[j]:=hextbl[val and $f];
+           dec(j);
+           val:=val shr 4;
+         end;
+      end;
+
+
+    function DStr(l:longint):string;
+      var
+        TmpStr : string[32];
+        i : longint;
+      begin
+        Str(l,TmpStr);
+        i:=Length(TmpStr);
+        while (i>3) do
+         begin
+           dec(i,3);
+           if TmpStr[i]<>'-' then
+            insert('.',TmpStr,i+1);
+         end;
+        DStr:=TmpStr;
+      end;
+
+
+    function trimbspace(const s:string):string;
+    {
+      return s with all leading spaces and tabs removed
+    }
+      var
+        i,j : longint;
+      begin
+        j:=1;
+        i:=length(s);
+        while (j<i) and (s[j] in [#9,' ']) do
+         inc(j);
+        trimbspace:=Copy(s,j,i-j+1);
+      end;
+
+
+
+    function trimspace(const s:string):string;
+    {
+      return s with all leading and ending spaces and tabs removed
+    }
+      var
+        i,j : longint;
+      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);
+        trimspace:=Copy(s,j,i-j+1);
+      end;
+
+
+    function space (b : longint): string;
+      var
+       s: string;
+      begin
+        space[0] := chr(b);
+        s[0] := chr(b);
+        FillChar (S[1],b,' ');
+        space:=s;
+      end;
+
+
+    function PadSpace(const s:string;len:longint):string;
+    {
+      return s with spaces add to the end
+    }
+      begin
+         if length(s)<len then
+          PadSpace:=s+Space(len-length(s))
+         else
+          PadSpace:=s;
+      end;
+
+
+    function GetToken(var s:string;endchar:char):string;
+      var
+        i : longint;
+      begin
+        GetToken:='';
+        s:=TrimSpace(s);
+        if (length(s)>0) and
+           (s[1]='''') then
+         begin
+           i:=1;
+           while (i<length(s)) do
+            begin
+              inc(i);
+              if s[i]='''' then
+               begin
+                 { Remove double quote }
+                 if (i<length(s)) and
+                    (s[i+1]='''') then
+                  begin
+                    Delete(s,i,1);
+                    inc(i);
+                  end
+                 else
+                  begin
+                    GetToken:=Copy(s,2,i-2);
+                    Delete(s,1,i);
+                    exit;
+                  end;
+               end;
+            end;
+           GetToken:=s;
+           s:='';
+         end
+        else
+         begin
+           i:=pos(EndChar,s);
+           if i=0 then
+            begin
+              GetToken:=s;
+              s:='';
+              exit;
+            end
+           else
+            begin
+              GetToken:=Copy(s,1,i-1);
+              Delete(s,1,i);
+              exit;
+            end;
+         end;
+      end;
+
+
+   function realtostr(e:extended):string;{$ifdef USEINLINE}inline;{$endif}
+     begin
+        str(e,result);
+     end;
+
+
+   function tostr(i : qword) : string;{$ifdef USEINLINE}inline;{$endif}overload;
+   {
+     return string of value i
+   }
+     begin
+        str(i,result);
+     end;
+
+
+   function tostr(i : int64) : string;{$ifdef USEINLINE}inline;{$endif}overload;
+   {
+     return string of value i
+   }
+     begin
+        str(i,result);
+     end;
+
+
+   function tostr(i : longint) : string;{$ifdef USEINLINE}inline;{$endif}overload;
+   {
+     return string of value i
+   }
+     begin
+        str(i,result);
+     end;
+
+
+   function tostr_with_plus(i : int64) : string;{$ifdef USEINLINE}inline;{$endif}
+   {
+     return string of value i, but always include a + when i>=0
+   }
+     begin
+        str(i,result);
+        if i>=0 then
+          result:='+'+result;
+     end;
+
+
+    function is_number(const s : string) : boolean;{$ifdef USEINLINE}inline;{$endif}
+    {
+      is string a correct number ?
+    }
+      var
+         w : integer;
+         l : longint;
+      begin
+         val(s,l,w);
+         is_number:=(w=0);
+      end;
+
+
+    function ispowerof2(value : int64;out power : longint) : boolean;
+    {
+      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;
+      end;
+
+
+    function backspace_quote(const s:string;const qchars:Tcharset):string;
+
+    var i:byte;
+
+    begin
+      backspace_quote:='';
+      for i:=1 to length(s) do
+        begin
+          if (s[i]=#10) and (#10 in qchars) then
+            backspace_quote:=backspace_quote+'\n'
+          else if (s[i]=#13) and (#13 in qchars) then
+            backspace_quote:=backspace_quote+'\r'
+          else
+            begin
+              if s[i] in qchars then
+                backspace_quote:=backspace_quote+'\';
+              backspace_quote:=backspace_quote+s[i];
+            end;
+        end;
+    end;
+
+    function octal_quote(const s:string;const qchars:Tcharset):string;
+
+    var i:byte;
+
+    begin
+      octal_quote:='';
+      for i:=1 to length(s) do
+        begin
+          if s[i] in qchars then
+            begin
+              if ord(s[i])<64 then
+                octal_quote:=octal_quote+'\'+octstr(ord(s[i]),3)
+              else
+                octal_quote:=octal_quote+'\'+octstr(ord(s[i]),4);
+            end
+          else
+            octal_quote:=octal_quote+s[i];
+        end;
+    end;
+
+    function maybequoted(const s:string):string;
+      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
+               s1:=s1+s[i];
+           end;
+         end;
+        if quoted then
+          maybequoted:=s1+'"'
+        else
+          maybequoted:=s;
+      end;
+
+
+    function DePascalQuote(var s: string): Boolean;
+      var
+        destPos, sourcePos, len: Integer;
+        t: string;
+        ch: Char;
+    begin
+      DePascalQuote:= false;
+      len:= length(s);
+      if (len >= 1) and (s[1] = '''') then
+        begin
+          {Remove quotes, exchange '' against ' }
+          destPos := 0;
+          sourcepos:=1;
+          while (sourcepos<len) do
+            begin
+              inc(sourcePos);
+              ch := s[sourcePos];
+              if ch = '''' then
+                begin
+                  inc(sourcePos);
+                  if (sourcePos <= len) and (s[sourcePos] = '''') then
+                    {Add the quote as part of string}
+                  else
+                    begin
+                      SetLength(t, destPos);
+                      s:= t;
+                      Exit(true);
+                    end;
+                end;
+              inc(destPos);
+              t[destPos] := ch;
+            end;
+        end;
+    end;
+
+
+    function pchar2pstring(p : pchar) : pstring;
+      var
+         w,i : longint;
+      begin
+         w:=strlen(p);
+         for i:=w-1 downto 0 do
+           p[i+1]:=p[i];
+         p[0]:=chr(w);
+         pchar2pstring:=pstring(p);
+      end;
+
+
+    function pstring2pchar(p : pstring) : pchar;
+      var
+         w,i : longint;
+      begin
+         w:=length(p^);
+         for i:=1 to w do
+           p^[i-1]:=p^[i];
+         p^[w]:=#0;
+         pstring2pchar:=pchar(p);
+      end;
+
+
+    function lowercase(c : char) : char;
+       begin
+          case c of
+             #65..#90 : c := chr(ord (c) + 32);
+             #154 : c:=#129;  { german }
+             #142 : c:=#132;  { german }
+             #153 : c:=#148;  { german }
+             #144 : c:=#130;  { french }
+             #128 : c:=#135;  { french }
+             #143 : c:=#134;  { swedish/norge (?) }
+             #165 : c:=#164;  { spanish }
+             #228 : c:=#229;  { greek }
+             #226 : c:=#231;  { greek }
+             #232 : c:=#227;  { greek }
+          end;
+          lowercase := c;
+       end;
+
+
+    function strpnew(const s : string) : pchar;
+      var
+         p : pchar;
+      begin
+         getmem(p,length(s)+1);
+         strpcopy(p,s);
+         strpnew:=p;
+      end;
+
+
+    procedure strdispose(var p : pchar);
+      begin
+        if assigned(p) then
+         begin
+           freemem(p,strlen(p)+1);
+           p:=nil;
+         end;
+      end;
+
+
+    procedure stringdispose(var p : pstring);{$ifdef USEINLINE}inline;{$endif}
+      begin
+         if assigned(p) then
+           begin
+             freemem(p,length(p^)+1);
+             p:=nil;
+           end;
+      end;
+
+
+    function stringdup(const s : string) : pstring;{$ifdef USEINLINE}inline;{$endif}
+      begin
+         getmem(result,length(s)+1);
+         result^:=s;
+      end;
+
+
+    function CompareText(S1, S2: string): longint;
+      begin
+        UpperVar(S1);
+        UpperVar(S2);
+        if S1<S2 then
+         CompareText:=-1
+        else
+         if S1>S2 then
+          CompareText:= 1
+        else
+         CompareText:=0;
+      end;
+
+
+{*****************************************************************************
+                               GetSpeedValue
+*****************************************************************************}
+
+    var
+      Crc32Tbl : array[0..255] of cardinal;
+
+    procedure MakeCRC32Tbl;
+      var
+        crc : cardinal;
+        i,n : integer;
+      begin
+        for i:=0 to 255 do
+         begin
+           crc:=i;
+           for n:=1 to 8 do
+            if odd(longint(crc)) then
+             crc:=cardinal(crc shr 1) xor cardinal($edb88320)
+            else
+             crc:=cardinal(crc shr 1);
+           Crc32Tbl[i]:=crc;
+         end;
+      end;
+
+
+    Function GetSpeedValue(Const s:String):cardinal;
+      var
+        i : integer;
+        InitCrc : cardinal;
+      begin
+        InitCrc:=cardinal($ffffffff);
+        for i:=1 to Length(s) do
+         InitCrc:=Crc32Tbl[byte(InitCrc) xor ord(s[i])] xor (InitCrc shr 8);
+        GetSpeedValue:=InitCrc;
+      end;
+
+
+{*****************************************************************************
+                               Ansistring (PChar+Length)
+*****************************************************************************}
+
+    procedure ansistringdispose(var p : pchar;length : longint);
+      begin
+         if assigned(p) then
+           begin
+             freemem(p,length+1);
+             p:=nil;
+           end;
+      end;
+
+
+    { enable ansistring comparison }
+    { 0 means equal }
+    { 1 means p1 > p2 }
+    { -1 means p1 < p2 }
+    function compareansistrings(p1,p2 : pchar;length1,length2 :  longint) : longint;
+      var
+         i,j : longint;
+      begin
+         compareansistrings:=0;
+         j:=min(length1,length2);
+         i:=0;
+         while (i<j) do
+          begin
+            if p1[i]>p2[i] then
+             begin
+               compareansistrings:=1;
+               exit;
+             end
+            else
+             if p1[i]<p2[i] then
+              begin
+                compareansistrings:=-1;
+                exit;
+              end;
+            inc(i);
+          end;
+         if length1>length2 then
+          compareansistrings:=1
+         else
+          if length1<length2 then
+           compareansistrings:=-1;
+      end;
+
+
+    function concatansistrings(p1,p2 : pchar;length1,length2 : longint) : pchar;
+      var
+         p : pchar;
+      begin
+         getmem(p,length1+length2+1);
+         move(p1[0],p[0],length1);
+         move(p2[0],p[length1],length2+1);
+         concatansistrings:=p;
+      end;
+
+
+{*****************************************************************************
+                       Ultra basic KISS Lzw (de)compressor
+*****************************************************************************}
+
+    {This is an extremely basic implementation of the Lzw algorithm. It
+     compresses 7-bit ASCII strings into 8-bit compressed strings.
+     The Lzw dictionary is preinitialized with 0..127, therefore this
+     part of the dictionary does not need to be stored in the arrays.
+     The Lzw code size is allways 8 bit, so we do not need complex code
+     that can write partial bytes.}
+
+    function minilzw_encode(const s:string):string;
+
+    var t,u,i:byte;
+        c:char;
+        data:array[128..255] of char;
+        previous:array[128..255] of byte;
+        lzwptr:byte;
+        next_avail:set of 0..255;
+
+    label l1;
+
+    begin
+      minilzw_encode:='';
+      if s<>'' then
+        begin
+          lzwptr:=127;
+          t:=byte(s[1]);
+          i:=2;
+          u:=128;
+          next_avail:=[];
+          while i<=length(s) do
+            begin
+              c:=s[i];
+              if not(t in next_avail) or (u>lzwptr) then goto l1;
+              while (previous[u]<>t) or (data[u]<>c) do
+                begin
+                  inc(u);
+                  if u>lzwptr then goto l1;
+                end;
+              t:=u;
+              inc(i);
+              continue;
+            l1:
+              {It's a pity that we still need those awfull tricks
+               with this modern compiler. Without this performance
+               of the entire procedure drops about 3 times.}
+              inc(minilzw_encode[0]);
+              minilzw_encode[length(minilzw_encode)]:=char(t);
+              if lzwptr=255 then
+                begin
+                  lzwptr:=127;
+                  next_avail:=[];
+                end
+              else
+                begin
+                  inc(lzwptr);
+                  data[lzwptr]:=c;
+                  previous[lzwptr]:=t;
+                  include(next_avail,t);
+                end;
+              t:=byte(c);
+              u:=128;
+              inc(i);
+            end;
+          inc(minilzw_encode[0]);
+          minilzw_encode[length(minilzw_encode)]:=char(t);
+        end;
+    end;
+
+    function minilzw_decode(const s:string):string;
+
+    var oldc,newc,c:char;
+        i,j:byte;
+        data:array[128..255] of char;
+        previous:array[128..255] of byte;
+        lzwptr:byte;
+        t:string;
+
+    begin
+      minilzw_decode:='';
+      if s<>'' then
+        begin
+          lzwptr:=127;
+          oldc:=s[1];
+          c:=oldc;
+          i:=2;
+          minilzw_decode:=oldc;
+          while i<=length(s) do
+            begin
+              newc:=s[i];
+              if byte(newc)>lzwptr then
+                begin
+                  t:=c;
+                  c:=oldc;
+                end
+              else
+                begin
+                  c:=newc;
+                  t:='';
+                end;
+              while c>=#128 do
+                begin
+                  inc(t[0]);
+                  t[length(t)]:=data[byte(c)];
+                  byte(c):=previous[byte(c)];
+                end;
+              inc(minilzw_decode[0]);
+              minilzw_decode[length(minilzw_decode)]:=c;
+              for j:=length(t) downto 1 do
+                begin
+                  inc(minilzw_decode[0]);
+                  minilzw_decode[length(minilzw_decode)]:=t[j];
+                end;
+              if lzwptr=255 then
+                lzwptr:=127
+              else
+                begin
+                  inc(lzwptr);
+                  previous[lzwptr]:=byte(oldc);
+                  data[lzwptr]:=c;
+                end;
+              oldc:=newc;
+              inc(i);
+            end;
+        end;
+    end;
+
+
+    procedure defaulterror(i:longint);
+      begin
+        writeln('Internal error ',i);
+        runerror(255);
+      end;
+
+
+initialization
+  internalerrorproc:=@defaulterror;
+  makecrc32tbl;
+  initupperlower;
+end.

+ 128 - 0
compiler/dbgbase.pas

@@ -0,0 +1,128 @@
+{
+    Copyright (c) 2003-2004 by Peter Vreman and Florian Klaempfl
+
+    This units contains support for 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 dbgbase;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+      systems,
+      symdef,symtype,
+      symsym,
+      aasmtai;
+
+    type
+      TDebugInfo=class
+        constructor Create;virtual;
+        procedure inserttypeinfo;virtual;
+        procedure insertmoduleinfo;virtual;
+        procedure insertlineinfo(list:taasmoutput);virtual;
+        procedure referencesections(list:taasmoutput);virtual;
+      end;
+      TDebugInfoClass=class of TDebugInfo;
+
+    var
+      CDebugInfo : array[tdbg] of TDebugInfoClass;
+      DebugInfo  : TDebugInfo;
+
+    procedure InitDebugInfo;
+    procedure DoneDebugInfo;
+    procedure RegisterDebugInfo(const r:tdbginfo;c:TDebugInfoClass);
+
+
+implementation
+
+    uses
+      verbose;
+
+
+    constructor tdebuginfo.Create;
+      begin
+      end;
+
+
+    procedure tdebuginfo.insertmoduleinfo;
+      begin
+      end;
+
+
+    procedure tdebuginfo.inserttypeinfo;
+      begin
+      end;
+
+
+    procedure tdebuginfo.insertlineinfo(list:taasmoutput);
+      begin
+      end;
+
+
+    procedure tdebuginfo.referencesections(list:taasmoutput);
+      begin
+      end;
+
+
+    procedure InitDebugInfo;
+      begin
+        if not assigned(CDebugInfo[target_dbg.id]) then
+          begin
+            Comment(V_Fatal,'cg_f_debuginfo_output_not_supported');
+            exit;
+          end;
+        DebugInfo:=CDebugInfo[target_dbg.id].Create;
+      end;
+
+
+    procedure DoneDebugInfo;
+      begin
+        if assigned(DebugInfo) then
+          begin
+            DebugInfo.Free;
+            DebugInfo:=nil;
+          end;
+      end;
+
+
+    procedure RegisterDebugInfo(const r:tdbginfo;c:TDebugInfoClass);
+      var
+        t : tdbg;
+      begin
+        t:=r.id;
+        if assigned(dbginfos[t]) then
+          writeln('Warning: DebugInfo is already registered!')
+        else
+          Getmem(dbginfos[t],sizeof(tdbginfo));
+        dbginfos[t]^:=r;
+        CDebugInfo[t]:=c;
+      end;
+
+
+    const
+      dbg_none_info : tdbginfo =
+         (
+           id     : dbg_none;
+           idtxt  : 'NONE';
+         );
+
+initialization
+  RegisterDebugInfo(dbg_none_info,tdebuginfo);
+end.

+ 49 - 0
compiler/dbgdwarf.pas

@@ -0,0 +1,49 @@
+{
+    Copyright (c) 2003-2004 by Peter Vreman and Florian Klaempfl
+
+    This units contains support for DWARF 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 dbgdwarf;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+      DbgBase;
+
+    type
+      TDebugInfoDwarf=class(TDebugInfo)
+      end;
+
+implementation
+
+    uses
+      Systems;
+
+    const
+      dbg_dwarf_info : tdbginfo =
+         (
+           id     : dbg_dwarf;
+           idtxt  : 'DWARF';
+         );
+
+initialization
+  RegisterDebugInfo(dbg_dwarf_info,TDebugInfoDwarf);
+end.

+ 1589 - 0
compiler/dbgstabs.pas

@@ -0,0 +1,1589 @@
+{
+    Copyright (c) 2003-2004 by Peter Vreman and Florian Klaempfl
+
+    This units contains support for STABS 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 dbgstabs;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+      cclasses,
+      dbgbase,
+      symtype,symdef,symsym,symtable,symbase,
+      aasmtai;
+
+    type
+      TDebugInfoStabs=class(TDebugInfo)
+      private
+        writing_def_stabs  : boolean;
+        global_stab_number : word;
+        defnumberlist      : tlist;
+        { tsym writing }
+        function  sym_var_value(const s:string;arg:pointer):string;
+        function  sym_stabstr_evaluate(sym:tsym;const s:string;const vars:array of string):Pchar;
+        procedure write_symtable_syms(list:taasmoutput;st:tsymtable);
+        { tdef writing }
+        function  def_stab_number(def:tdef):string;
+        function  def_stab_classnumber(def:tobjectdef):string;
+        function  def_var_value(const s:string;arg:pointer):string;
+        function  def_stabstr_evaluate(def:tdef;const s:string;const vars:array of string):Pchar;
+        procedure field_add_stabstr(p:Tnamedindexitem;arg:pointer);
+        procedure method_add_stabstr(p:Tnamedindexitem;arg:pointer);
+        function  def_stabstr(def:tdef):pchar;
+        procedure write_def_stabstr(list:taasmoutput;def:tdef);
+        procedure field_write_defs(p:Tnamedindexitem;arg:pointer);
+        procedure method_write_defs(p :tnamedindexitem;arg:pointer);
+        procedure write_symtable_defs(list:taasmoutput;st:tsymtable);
+        procedure write_procdef(list:taasmoutput;pd:tprocdef);
+        procedure insertsym(list:taasmoutput;sym:tsym);
+        procedure insertdef(list:taasmoutput;def:tdef);
+      public
+        procedure inserttypeinfo;override;
+        procedure insertmoduleinfo;override;
+        procedure insertlineinfo(list:taasmoutput);override;
+        procedure referencesections(list:taasmoutput);override;
+      end;
+
+
+implementation
+
+    uses
+      strings,cutils,
+      systems,globals,globtype,verbose,
+      symconst,defutil,
+      cpuinfo,cpubase,cgbase,paramgr,
+      aasmbase,procinfo,
+      finput,fmodule,ppu;
+
+    const
+      memsizeinc = 512;
+
+      N_GSYM = $20;
+      N_STSYM = 38;     { initialized const }
+      N_LCSYM = 40;     { non initialized variable}
+      N_Function = $24; { function or const }
+      N_TextLine = $44;
+      N_DataLine = $46;
+      N_BssLine = $48;
+      N_RSYM = $40;     { register variable }
+      N_LSYM = $80;
+      N_tsym = 160;
+      N_SourceFile = $64;
+      N_IncludeFile = $84;
+      N_BINCL = $82;
+      N_EINCL = $A2;
+      N_EXCL  = $C2;
+
+      tagtypes = [
+        recorddef,
+        enumdef,
+        stringdef,
+        filedef,
+        objectdef
+      ];
+
+    type
+       get_var_value_proc=function(const s:string;arg:pointer):string of object;
+
+       Trecord_stabgen_state=record
+          stabstring:Pchar;
+          stabsize,staballoc,recoffset:integer;
+       end;
+       Precord_stabgen_state=^Trecord_stabgen_state;
+
+
+    function string_evaluate(s:string;get_var_value:get_var_value_proc;
+                             get_var_value_arg:pointer;
+                             const vars:array of string):Pchar;
+
+    (*
+     S contains a prototype of a result. Stabstr_evaluate will expand
+     variables and parameters.
+
+     Output is s in ASCIIZ format, with the following expanded:
+
+     ${varname}   - The variable name is expanded.
+     $n           - The parameter n is expanded.
+     $$           - Is expanded to $
+    *)
+
+    const maxvalue=9;
+          maxdata=1023;
+
+    var i,j:byte;
+        varname:string[63];
+        varno,varcounter:byte;
+        varvalues:array[0..9] of Pstring;
+        {1 kb of parameters is the limit. 256 extra bytes are allocated to
+         ensure buffer integrity.}
+        varvaluedata:array[0..maxdata+256] of char;
+        varptr:Pchar;
+        varidx : byte;
+        len:cardinal;
+        r:Pchar;
+
+    begin
+      {Two pass approach, first, calculate the length and receive variables.}
+      i:=1;
+      len:=0;
+      varcounter:=0;
+      varptr:=@varvaluedata;
+      while i<=length(s) do
+        begin
+          if (s[i]='$') and (i<length(s)) then
+            begin
+             if s[i+1]='$' then
+               begin
+                 inc(len);
+                 inc(i);
+               end
+             else if (s[i+1]='{') and (length(s)>2) and (i<length(s)-2) then
+               begin
+                 varname:='';
+                 inc(i,2);
+                 repeat
+                   inc(varname[0]);
+                   varname[length(varname)]:=s[i];
+                   s[i]:=char(varcounter);
+                   inc(i);
+                 until s[i]='}';
+                 varvalues[varcounter]:=Pstring(varptr);
+                 if varptr>@varvaluedata+maxdata then
+                   internalerrorproc(200411152);
+                 Pstring(varptr)^:=get_var_value(varname,get_var_value_arg);
+                 inc(len,length(Pstring(varptr)^));
+                 inc(varptr,length(Pstring(varptr)^)+1);
+                 inc(varcounter);
+               end
+             else if s[i+1] in ['1'..'9'] then
+               begin
+                 varidx:=byte(s[i+1])-byte('1');
+                 if varidx>high(vars) then
+                   internalerror(200509263);
+                 inc(len,length(vars[varidx]));
+                 inc(i);
+               end;
+            end
+          else
+            inc(len);
+          inc(i);
+        end;
+
+      {Second pass, writeout result.}
+      getmem(r,len+1);
+      string_evaluate:=r;
+      i:=1;
+      while i<=length(s) do
+        begin
+          if (s[i]='$') and (i<length(s)) then
+            begin
+             if s[i+1]='$' then
+               begin
+                 r^:='$';
+                 inc(r);
+                 inc(i);
+               end
+             else if (s[i+1]='{') and (length(s)>2) and (i<length(s)-2) then
+               begin
+                 varname:='';
+                 inc(i,2);
+                 varno:=byte(s[i]);
+                 repeat
+                   inc(i);
+                 until s[i]='}';
+                 for j:=1 to length(varvalues[varno]^) do
+                   begin
+                     r^:=varvalues[varno]^[j];
+                     inc(r);
+                   end;
+               end
+             else if s[i+1] in ['0'..'9'] then
+               begin
+                 for j:=1 to length(vars[byte(s[i+1])-byte('1')]) do
+                   begin
+                     r^:=vars[byte(s[i+1])-byte('1')][j];
+                     inc(r);
+                   end;
+                 inc(i);
+               end
+            end
+          else
+            begin
+              r^:=s[i];
+              inc(r);
+            end;
+          inc(i);
+        end;
+      r^:=#0;
+    end;
+
+
+{****************************************************************************
+                               TDef support
+****************************************************************************}
+
+    function TDebugInfoStabs.def_stab_number(def:tdef):string;
+      begin
+        { procdefs only need a number, mark them as already written
+          so they won't be written implicitly }
+        if (def.deftype=procdef) then
+          def.stab_state:=stab_state_written;
+        { Stab must already be written, or we must be busy writing it }
+        if writing_def_stabs and
+           not(def.stab_state in [stab_state_writing,stab_state_written]) then
+          internalerror(200403091);
+        { Keep track of used stabs, this info is only usefull for stabs
+          referenced by the symbols. Definitions will always include all
+          required stabs }
+        if def.stab_state=stab_state_unused then
+          def.stab_state:=stab_state_used;
+        { Need a new number? }
+        if def.stab_number=0 then
+          begin
+            inc(global_stab_number);
+            { classes require 2 numbers }
+            if is_class(def) then
+              inc(global_stab_number);
+            def.stab_number:=global_stab_number;
+            if global_stab_number>=defnumberlist.count then
+              defnumberlist.count:=global_stab_number+250;
+            defnumberlist[global_stab_number]:=def;
+          end;
+        result:=tostr(def.stab_number);
+      end;
+
+
+    function TDebugInfoStabs.def_stab_classnumber(def:tobjectdef):string;
+      begin
+        if def.stab_number=0 then
+          def_stab_number(def);
+        result:=tostr(def.stab_number-1);
+      end;
+
+
+    function TDebugInfoStabs.def_var_value(const s:string;arg:pointer):string;
+      var
+        def : tdef;
+      begin
+        def:=tdef(arg);
+        result:='';
+        if s='numberstring' then
+          result:=def_stab_number(def)
+        else if s='sym_name' then
+          begin
+            if assigned(def.typesym) then
+               result:=Ttypesym(def.typesym).name;
+          end
+        else if s='N_LSYM' then
+          result:=tostr(N_LSYM)
+        else if s='savesize' then
+          result:=tostr(def.size);
+      end;
+
+
+    function TDebugInfoStabs.def_stabstr_evaluate(def:tdef;const s:string;const vars:array of string):Pchar;
+      begin
+        result:=string_evaluate(s,@def_var_value,def,vars);
+      end;
+
+
+    procedure TDebugInfoStabs.field_add_stabstr(p:Tnamedindexitem;arg:pointer);
+      var
+        newrec  : Pchar;
+        spec    : string[3];
+        varsize : aint;
+        state   : Precord_stabgen_state;
+      begin
+        state:=arg;
+        { static variables from objects are like global objects }
+        if (Tsym(p).typ=fieldvarsym) and
+           not(sp_static in Tsym(p).symoptions) then
+          begin
+            if ([sp_protected,sp_strictprotected]*tsym(p).symoptions)<>[] then
+              spec:='/1'
+            else if ([sp_private,sp_strictprivate]*tsym(p).symoptions)<>[] then
+              spec:='/0'
+            else
+              spec:='';
+            varsize:=tfieldvarsym(p).vartype.def.size;
+            { open arrays made overflows !! }
+            if varsize>$fffffff then
+              varsize:=$fffffff;
+            newrec:=def_stabstr_evaluate(nil,'$1:$2,$3,$4;',[p.name,
+                                     spec+def_stab_number(tfieldvarsym(p).vartype.def),
+                                     tostr(tfieldvarsym(p).fieldoffset*8),tostr(varsize*8)]);
+            if state^.stabsize+strlen(newrec)>=state^.staballoc-256 then
+              begin
+                inc(state^.staballoc,strlen(newrec)+64);
+                reallocmem(state^.stabstring,state^.staballoc);
+              end;
+            strcopy(state^.stabstring+state^.stabsize,newrec);
+            inc(state^.stabsize,strlen(newrec));
+            strdispose(newrec);
+            {This should be used for case !!}
+            inc(state^.recoffset,Tfieldvarsym(p).vartype.def.size);
+          end;
+      end;
+
+
+    procedure TDebugInfoStabs.method_add_stabstr(p:Tnamedindexitem;arg:pointer);
+      var virtualind,argnames : string;
+          newrec : pchar;
+          pd     : tprocdef;
+          lindex : longint;
+          arglength : byte;
+          sp : char;
+          state:^Trecord_stabgen_state;
+          olds:integer;
+          i : integer;
+          parasym : tparavarsym;
+      begin
+        state:=arg;
+        if tsym(p).typ = procsym then
+         begin
+           pd := tprocsym(p).first_procdef;
+           if (po_virtualmethod in pd.procoptions) then
+             begin
+               lindex := pd.extnumber;
+               {doesnt seem to be necessary
+               lindex := lindex or $80000000;}
+               virtualind := '*'+tostr(lindex)+';'+def_stab_classnumber(pd._class)+';'
+             end
+            else
+             virtualind := '.';
+
+            { used by gdbpas to recognize constructor and destructors }
+            if (pd.proctypeoption=potype_constructor) then
+              argnames:='__ct__'
+            else if (pd.proctypeoption=potype_destructor) then
+              argnames:='__dt__'
+            else
+              argnames := '';
+
+           { arguments are not listed here }
+           {we don't need another definition}
+            for i:=0 to pd.paras.count-1 do
+              begin
+                parasym:=tparavarsym(pd.paras[i]);
+                if Parasym.vartype.def.deftype = formaldef then
+                  begin
+                    case Parasym.varspez of
+                      vs_var :
+                        argnames := argnames+'3var';
+                      vs_const :
+                        argnames:=argnames+'5const';
+                      vs_out :
+                        argnames:=argnames+'3out';
+                    end;
+                  end
+                else
+                  begin
+                    { if the arg definition is like (v: ^byte;..
+                    there is no sym attached to data !!! }
+                    if assigned(Parasym.vartype.def.typesym) then
+                      begin
+                        arglength := length(Parasym.vartype.def.typesym.name);
+                        argnames := argnames + tostr(arglength)+Parasym.vartype.def.typesym.name;
+                      end
+                    else
+                      argnames:=argnames+'11unnamedtype';
+                  end;
+              end;
+           { here 2A must be changed for private and protected }
+           { 0 is private 1 protected and 2 public }
+           if ([sp_private,sp_strictprivate]*tsym(p).symoptions)<>[] then
+             sp:='0'
+           else if ([sp_protected,sp_strictprotected]*tsym(p).symoptions)<>[] then
+             sp:='1'
+           else
+             sp:='2';
+           newrec:=def_stabstr_evaluate(nil,'$1::$2=##$3;:$4;$5A$6;',[p.name,def_stab_number(pd),
+                                    def_stab_number(pd.rettype.def),argnames,sp,
+                                    virtualind]);
+           { get spare place for a string at the end }
+           olds:=state^.stabsize;
+           inc(state^.stabsize,strlen(newrec));
+           if state^.stabsize>=state^.staballoc-256 then
+             begin
+                inc(state^.staballoc,strlen(newrec)+64);
+                reallocmem(state^.stabstring,state^.staballoc);
+             end;
+           strcopy(state^.stabstring+olds,newrec);
+           strdispose(newrec);
+           {This should be used for case !!
+           RecOffset := RecOffset + pd.size;}
+         end;
+      end;
+
+
+    function TDebugInfoStabs.def_stabstr(def:tdef):pchar;
+
+        function stringdef_stabstr(def:tstringdef):pchar;
+          var
+            slen : aint;
+            bytest,charst,longst : string;
+          begin
+            case def.string_typ of
+              st_shortstring:
+                begin
+                  { fix length of openshortstring }
+                  slen:=def.len;
+                  if slen=0 then
+                    slen:=255;
+                  charst:=def_stab_number(cchartype.def);
+                  bytest:=def_stab_number(u8inttype.def);
+                  result:=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.def);
+                  bytest:=def_stab_number(u8inttype.def);
+                  longst:=def_stab_number(u32inttype.def);
+                  result:=def_stabstr_evaluate(def,'s$1length:$2,0,32;dummy:$6,32,8;st:ar$2;1;$3;$4,40,$5;;',
+                              [tostr(def.len+5),longst,tostr(def.len),charst,tostr(def.len*8),bytest]);
+               end;
+             st_ansistring:
+               begin
+                 { looks like a pchar }
+                 charst:=def_stab_number(cchartype.def);
+                 result:=strpnew('*'+charst);
+               end;
+             st_widestring:
+               begin
+                 { looks like a pwidechar }
+                 charst:=def_stab_number(cwidechartype.def);
+                 result:=strpnew('*'+charst);
+               end;
+            end;
+          end;
+
+        function enumdef_stabstr(def:tenumdef):pchar;
+          var
+            st : Pchar;
+            p : Tenumsym;
+            s : string;
+            memsize,
+            stl : aint;
+          begin
+            memsize:=memsizeinc;
+            getmem(st,memsize);
+            { we can specify the size with @s<size>; prefix PM }
+            if def.size <> std_param_align then
+              strpcopy(st,'@s'+tostr(def.size*8)+';e')
+            else
+              strpcopy(st,'e');
+            p := tenumsym(def.firstenum);
+            stl:=strlen(st);
+            while assigned(p) do
+              begin
+                s :=p.name+':'+tostr(p.value)+',';
+                { place for the ending ';' also }
+                if (stl+length(s)+1>=memsize) then
+                  begin
+                    inc(memsize,memsizeinc);
+                    reallocmem(st,memsize);
+                  end;
+                strpcopy(st+stl,s);
+                inc(stl,length(s));
+                p:=p.nextenum;
+              end;
+            st[stl]:=';';
+            st[stl+1]:=#0;
+            reallocmem(st,stl+2);
+            result:=st;
+          end;
+
+        function orddef_stabstr(def:torddef):pchar;
+          begin
+            if cs_gdb_valgrind in aktglobalswitches then
+              begin
+                case def.typ of
+                  uvoid :
+                    result:=strpnew(def_stab_number(def));
+                  bool8bit,
+                  bool16bit,
+                  bool32bit :
+                    result:=def_stabstr_evaluate(def,'r${numberstring};0;255;',[]);
+                  u32bit,
+                  s64bit,
+                  u64bit :
+                    result:=def_stabstr_evaluate(def,'r${numberstring};0;-1;',[]);
+                  else
+                    result:=def_stabstr_evaluate(def,'r${numberstring};$1;$2;',[tostr(longint(def.low)),tostr(longint(def.high))]);
+                end;
+              end
+            else
+              begin
+                case def.typ of
+                  uvoid :
+                    result:=strpnew(def_stab_number(def));
+                  uchar :
+                    result:=strpnew('-20;');
+                  uwidechar :
+                    result:=strpnew('-30;');
+                  bool8bit :
+                    result:=strpnew('-21;');
+                  bool16bit :
+                    result:=strpnew('-22;');
+                  bool32bit :
+                    result:=strpnew('-23;');
+                  u64bit :
+                    result:=strpnew('-32;');
+                  s64bit :
+                    result:=strpnew('-31;');
+                  {u32bit : result:=def_stab_number(s32inttype.def)+';0;-1;'); }
+                  else
+                    result:=def_stabstr_evaluate(def,'r${numberstring};$1;$2;',[tostr(longint(def.low)),tostr(longint(def.high))]);
+                end;
+             end;
+          end;
+
+        function floatdef_stabstr(def:tfloatdef):Pchar;
+          begin
+            case def.typ of
+              s32real,
+              s64real,
+              s80real:
+                result:=def_stabstr_evaluate(def,'r$1;${savesize};0;',[def_stab_number(s32inttype.def)]);
+              s64currency,
+              s64comp:
+                result:=def_stabstr_evaluate(def,'r$1;-${savesize};0;',[def_stab_number(s32inttype.def)]);
+              else
+                internalerror(200509261);
+            end;
+          end;
+
+        function filedef_stabstr(def:tfiledef):pchar;
+          begin
+{$ifdef cpu64bit}
+            result:=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.def),
+                                     def_stab_number(s64inttype.def),
+                                     def_stab_number(u8inttype.def),
+                                     def_stab_number(cchartype.def)]);
+{$else cpu64bit}
+            result:=def_stabstr_evaluate(def,'s${savesize}HANDLE:$1,0,32;MODE:$1,32,32;RECSIZE:$1,64,32;'+
+                                     '_PRIVATE:ar$1;1;32;$3,96,256;USERDATA:ar$1;1;16;$2,352,128;'+
+                                     'NAME:ar$1;0;255;$3,480,2048;;',[def_stab_number(s32inttype.def),
+                                     def_stab_number(u8inttype.def),
+                                     def_stab_number(cchartype.def)]);
+{$endif cpu64bit}
+          end;
+
+        function procdef_stabstr(def:tprocdef):pchar;
+          Var
+            RType : Char;
+            Obj,Info : String;
+            stabsstr : string;
+            p : pchar;
+          begin
+            obj := def.procsym.name;
+            info := '';
+            if (po_global in def.procoptions) then
+              RType := 'F'
+            else
+              RType := 'f';
+            if assigned(def.owner) then
+             begin
+               if (def.owner.symtabletype = objectsymtable) then
+                 obj := def.owner.name^+'__'+def.procsym.name;
+               if not(cs_gdb_valgrind in aktglobalswitches) and
+                  (def.owner.symtabletype=localsymtable) and
+                  assigned(def.owner.defowner) and
+                  assigned(tprocdef(def.owner.defowner).procsym) then
+                 info := ','+def.procsym.name+','+tprocdef(def.owner.defowner).procsym.name;
+             end;
+            stabsstr:=def.mangledname;
+            getmem(p,length(stabsstr)+255);
+            strpcopy(p,'"'+obj+':'+RType
+                  +def_stab_number(def.rettype.def)+info+'",'+tostr(n_function)
+                  +',0,'+
+                  tostr(def.fileinfo.line)
+                  +',');
+            strpcopy(strend(p),stabsstr);
+            result:=strnew(p);
+            freemem(p,length(stabsstr)+255);
+          end;
+
+        function recorddef_stabstr(def:trecorddef):pchar;
+          var
+            state : Trecord_stabgen_state;
+          begin
+            getmem(state.stabstring,memsizeinc);
+            state.staballoc:=memsizeinc;
+            strpcopy(state.stabstring,'s'+tostr(def.size));
+            state.recoffset:=0;
+            state.stabsize:=strlen(state.stabstring);
+            def.symtable.foreach(@field_add_stabstr,@state);
+            state.stabstring[state.stabsize]:=';';
+            state.stabstring[state.stabsize+1]:=#0;
+            reallocmem(state.stabstring,state.stabsize+2);
+            result:=state.stabstring;
+          end;
+
+        function objectdef_stabstr(def:tobjectdef):pchar;
+          var
+            anc    : tobjectdef;
+            state  :Trecord_stabgen_state;
+            ts     : string;
+          begin
+            { Write the invisible pointer for the class? }
+            if (def.objecttype=odt_class) and
+               (not def.writing_class_record_stab) then
+              begin
+                result:=strpnew('*'+def_stab_classnumber(def));
+                exit;
+              end;
+
+            state.staballoc:=memsizeinc;
+            getmem(state.stabstring,state.staballoc);
+            strpcopy(state.stabstring,'s'+tostr(tobjectsymtable(def.symtable).datasize));
+            if assigned(def.childof) then
+              begin
+                {only one ancestor not virtual, public, at base offset 0 }
+                {       !1           ,    0       2         0    ,       }
+                strpcopy(strend(state.stabstring),'!1,020,'+def_stab_classnumber(def.childof)+';');
+              end;
+            {virtual table to implement yet}
+            state.recoffset:=0;
+            state.stabsize:=strlen(state.stabstring);
+            def.symtable.foreach(@field_add_stabstr,@state);
+            if (oo_has_vmt in def.objectoptions) then
+              if not assigned(def.childof) or not(oo_has_vmt in def.childof.objectoptions) then
+                 begin
+                    ts:='$vf'+def_stab_classnumber(def)+':'+def_stab_number(vmtarraytype.def)+','+tostr(def.vmt_offset*8)+';';
+                    strpcopy(state.stabstring+state.stabsize,ts);
+                    inc(state.stabsize,length(ts));
+                 end;
+            def.symtable.foreach(@method_add_stabstr,@state);
+            if (oo_has_vmt in def.objectoptions) then
+              begin
+                 anc := def;
+                 while assigned(anc.childof) and (oo_has_vmt in anc.childof.objectoptions) do
+                   anc := anc.childof;
+                 { just in case anc = self }
+                 ts:=';~%'+def_stab_classnumber(anc)+';';
+              end
+            else
+              ts:=';';
+            strpcopy(state.stabstring+state.stabsize,ts);
+            inc(state.stabsize,length(ts));
+            reallocmem(state.stabstring,state.stabsize+1);
+            result:=state.stabstring;
+          end;
+
+      begin
+        result:=nil;
+        case def.deftype of
+          stringdef :
+            result:=stringdef_stabstr(tstringdef(def));
+          enumdef :
+            result:=enumdef_stabstr(tenumdef(def));
+          orddef :
+            result:=orddef_stabstr(torddef(def));
+          floatdef :
+            result:=floatdef_stabstr(tfloatdef(def));
+          filedef :
+            result:=filedef_stabstr(tfiledef(def));
+          recorddef :
+            result:=recorddef_stabstr(trecorddef(def));
+          variantdef :
+            result:=def_stabstr_evaluate(def,'formal${numberstring};',[]);
+          pointerdef :
+            result:=strpnew('*'+def_stab_number(tpointerdef(def).pointertype.def));
+          classrefdef :
+            result:=strpnew(def_stab_number(pvmttype.def));
+          setdef :
+            result:=def_stabstr_evaluate(def,'@s$1;S$2',[tostr(def.size*8),def_stab_number(tsetdef(def).elementtype.def)]);
+          formaldef :
+            result:=def_stabstr_evaluate(def,'formal${numberstring};',[]);
+          arraydef :
+            result:=def_stabstr_evaluate(def,'ar$1;$2;$3;$4',[def_stab_number(tarraydef(def).rangetype.def),
+               tostr(tarraydef(def).lowrange),tostr(tarraydef(def).highrange),def_stab_number(tarraydef(def).elementtype.def)]);
+          procdef :
+            result:=procdef_stabstr(tprocdef(def));
+          procvardef :
+            result:=strpnew('*f'+def_stab_number(tprocvardef(def).rettype.def));
+          objectdef :
+            begin
+              if tobjectdef(def).writing_class_record_stab then
+                result:=objectdef_stabstr(tobjectdef(def))
+              else
+                result:=strpnew('*'+def_stab_classnumber(tobjectdef(def)));
+            end;
+        end;
+      end;
+
+
+    procedure TDebugInfoStabs.write_def_stabstr(list:taasmoutput;def:tdef);
+      var
+        stabchar : string[2];
+        ss,st,su : pchar;
+      begin
+        { procdefs require a different stabs style without type prefix }
+        if def.deftype=procdef then
+          begin
+            st:=def_stabstr(def);
+            { add to list }
+            list.concat(Tai_stab.create(stab_stabs,st));
+          end
+        else
+          begin
+            { type prefix }
+            if def.deftype in tagtypes then
+              stabchar := 'Tt'
+            else
+              stabchar := 't';
+            { Here we maybe generate a type, so we have to use numberstring }
+            if is_class(def) and
+               tobjectdef(def).writing_class_record_stab then
+              st:=def_stabstr_evaluate(def,'"${sym_name}:$1$2=',[stabchar,def_stab_classnumber(tobjectdef(def))])
+            else
+              st:=def_stabstr_evaluate(def,'"${sym_name}:$1$2=',[stabchar,def_stab_number(def)]);
+            ss:=def_stabstr(def);
+            reallocmem(st,strlen(ss)+512);
+            { line info is set to 0 for all defs, because the def can be in an other
+              unit and then the linenumber is invalid in the current sourcefile }
+            su:=def_stabstr_evaluate(def,'",${N_LSYM},0,0,0',[]);
+            strcopy(strecopy(strend(st),ss),su);
+            reallocmem(st,strlen(st)+1);
+            strdispose(ss);
+            strdispose(su);
+            { add to list }
+            list.concat(Tai_stab.create(stab_stabs,st));
+          end;
+      end;
+
+
+    procedure TDebugInfoStabs.field_write_defs(p:Tnamedindexitem;arg:pointer);
+      begin
+        if (Tsym(p).typ=fieldvarsym) and
+           not(sp_static in Tsym(p).symoptions) then
+          insertdef(taasmoutput(arg),tfieldvarsym(p).vartype.def);
+      end;
+
+
+    procedure TDebugInfoStabs.method_write_defs(p :tnamedindexitem;arg:pointer);
+      var
+        pd : tprocdef;
+      begin
+        if tsym(p).typ = procsym then
+          begin
+            pd:=tprocsym(p).first_procdef;
+            insertdef(taasmoutput(arg),pd.rettype.def);
+          end;
+      end;
+
+
+    procedure TDebugInfoStabs.insertdef(list:taasmoutput;def:tdef);
+      var
+        anc : tobjectdef;
+        oldtypesym : tsym;
+//        nb  : string[12];
+      begin
+        if (def.stab_state in [stab_state_writing,stab_state_written]) then
+          exit;
+        { to avoid infinite loops }
+        def.stab_state := stab_state_writing;
+        { write dependencies first }
+        case def.deftype of
+          stringdef :
+            begin
+              if tstringdef(def).string_typ=st_widestring then
+                insertdef(list,cwidechartype.def)
+              else
+                begin
+                  insertdef(list,cchartype.def);
+                  insertdef(list,u8inttype.def);
+                end;
+            end;
+          floatdef :
+            insertdef(list,s32inttype.def);
+          filedef :
+            begin
+              insertdef(list,s32inttype.def);
+{$ifdef cpu64bit}
+              insertdef(list,s64inttype.def);
+{$endif cpu64bit}
+              insertdef(list,u8inttype.def);
+              insertdef(list,cchartype.def);
+            end;
+          classrefdef :
+            insertdef(list,pvmttype.def);
+          pointerdef :
+            insertdef(list,tpointerdef(def).pointertype.def);
+          setdef :
+            insertdef(list,tsetdef(def).elementtype.def);
+          procvardef,
+          procdef :
+            insertdef(list,tprocdef(def).rettype.def);
+          arraydef :
+            begin
+              insertdef(list,tarraydef(def).rangetype.def);
+              insertdef(list,tarraydef(def).elementtype.def);
+            end;
+          recorddef :
+            trecorddef(def).symtable.foreach(@field_write_defs,list);
+          objectdef :
+            begin
+              insertdef(list,vmtarraytype.def);
+              { first the parents }
+              anc:=tobjectdef(def);
+              while assigned(anc.childof) do
+                begin
+                  anc:=anc.childof;
+                  insertdef(list,anc);
+                end;
+              tobjectdef(def).symtable.foreach(@field_write_defs,list);
+              tobjectdef(def).symtable.foreach(@method_write_defs,list);
+            end;
+        end;
+(*
+        { Handle pointerdefs to records and objects to avoid recursion }
+        if (def.deftype=pointerdef) and
+           (tpointerdef(def).pointertype.def.deftype in [recorddef,objectdef]) then
+          begin
+            def.stab_state:=stab_state_used;
+            write_def_stabstr(list,def);
+            {to avoid infinite recursion in record with next-like fields }
+            if tdef(tpointerdef(def).pointertype.def).stab_state=stab_state_writing then
+              begin
+                if assigned(tpointerdef(def).pointertype.def.typesym) then
+                  begin
+                    if is_class(tpointerdef(def).pointertype.def) then
+                      nb:=def_stab_classnumber(tobjectdef(tpointerdef(def).pointertype.def))
+                    else
+                      nb:=def_stab_number(tpointerdef(def).pointertype.def);
+                    list.concat(Tai_stab.create(stab_stabs,def_stabstr_evaluate(
+                            def,'"${sym_name}:t${numberstring}=*$1=xs$2:",${N_LSYM},0,0,0',
+                            [nb,tpointerdef(def).pointertype.def.typesym.name])));
+                  end;
+                def.stab_state:=stab_state_written;
+              end
+          end
+        else
+*)
+        case def.deftype of
+          objectdef :
+            begin
+              { classes require special code to write the record and the invisible pointer }
+              if is_class(def) then
+                begin
+                  { Write the record class itself }
+                  tobjectdef(def).writing_class_record_stab:=true;
+                  write_def_stabstr(list,def);
+                  tobjectdef(def).writing_class_record_stab:=false;
+                  { Write the invisible pointer class }
+                  oldtypesym:=def.typesym;
+                  def.typesym:=nil;
+                  write_def_stabstr(list,def);
+                  def.typesym:=oldtypesym;
+                end
+              else
+                write_def_stabstr(list,def);
+              { VMT symbol }
+              if (oo_has_vmt in tobjectdef(def).objectoptions) and
+                 assigned(def.owner) and
+                 assigned(def.owner.name) then
+                list.concat(Tai_stab.create(stab_stabs,strpnew('"vmt_'+def.owner.name^+tobjectdef(def).name+':S'+
+                       def_stab_number(vmttype.def)+'",'+tostr(N_STSYM)+',0,0,'+tobjectdef(def).vmt_mangledname)));
+            end;
+          procdef :
+            begin
+              { procdefs are handled separatly }
+            end;
+          else
+            write_def_stabstr(list,def);
+        end;
+
+        def.stab_state := stab_state_written;
+      end;
+
+
+    procedure TDebugInfoStabs.write_symtable_defs(list:taasmoutput;st:tsymtable);
+
+       procedure dowritestabs(list:taasmoutput;st:tsymtable);
+         var
+           p : tdef;
+         begin
+           p:=tdef(st.defindex.first);
+           while assigned(p) do
+             begin
+               if (p.stab_state=stab_state_used) then
+                 insertdef(list,p);
+               p:=tdef(p.indexnext);
+             end;
+         end;
+
+      var
+        old_writing_def_stabs : boolean;
+      begin
+        case st.symtabletype of
+          staticsymtable :
+            list.concat(tai_comment.Create(strpnew('Defs - Begin Staticsymtable')));
+          globalsymtable :
+            list.concat(tai_comment.Create(strpnew('Defs - Begin unit '+st.name^+' has index '+tostr(st.moduleid))));
+        end;
+        old_writing_def_stabs:=writing_def_stabs;
+        writing_def_stabs:=true;
+        dowritestabs(list,st);
+        writing_def_stabs:=old_writing_def_stabs;
+        case st.symtabletype of
+          staticsymtable :
+            list.concat(tai_comment.Create(strpnew('Defs - End Staticsymtable')));
+          globalsymtable :
+            list.concat(tai_comment.Create(strpnew('Defs - End unit '+st.name^+' has index '+tostr(st.moduleid))));
+        end;
+      end;
+
+
+    procedure TDebugInfoStabs.write_procdef(list:taasmoutput;pd:tprocdef);
+      var
+        templist : taasmoutput;
+        stabsendlabel : tasmlabel;
+        mangled_length : longint;
+        p : pchar;
+        hs : string;
+      begin
+        if assigned(pd.procstarttai) then
+          begin
+            templist:=taasmoutput.create;
+            { para types }
+            write_def_stabstr(templist,pd);
+            if assigned(pd.parast) then
+              write_symtable_syms(templist,pd.parast);
+            { local type defs and vars should not be written
+              inside the main proc stab }
+            if assigned(pd.localst) and
+               (pd.localst.symtabletype=localsymtable) then
+              write_symtable_syms(templist,pd.localst);
+            asmlist[al_procedures].insertlistbefore(pd.procstarttai,templist);
+            { end of procedure }
+            objectlibrary.getlabel(stabsendlabel,alt_dbgtype);
+            templist.concat(tai_label.create(stabsendlabel));
+            if assigned(pd.funcretsym) and
+               (tabstractnormalvarsym(pd.funcretsym).refs>0) then
+              begin
+                if tabstractnormalvarsym(pd.funcretsym).localloc.loc=LOC_REFERENCE then
+                  begin
+    {$warning Need to add gdb support for ret in param register calling}
+                    if paramanager.ret_in_param(pd.rettype.def,pd.proccalloption) then
+                      hs:='X*'
+                    else
+                      hs:='X';
+                    templist.concat(Tai_stab.create(stab_stabs,strpnew(
+                       '"'+pd.procsym.name+':'+hs+def_stab_number(pd.rettype.def)+'",'+
+                       tostr(N_tsym)+',0,0,'+tostr(tabstractnormalvarsym(pd.funcretsym).localloc.reference.offset))));
+                    if (m_result in aktmodeswitches) then
+                      templist.concat(Tai_stab.create(stab_stabs,strpnew(
+                         '"RESULT:'+hs+def_stab_number(pd.rettype.def)+'",'+
+                         tostr(N_tsym)+',0,0,'+tostr(tabstractnormalvarsym(pd.funcretsym).localloc.reference.offset))));
+                  end;
+              end;
+            mangled_length:=length(pd.mangledname);
+            getmem(p,2*mangled_length+50);
+            strpcopy(p,'192,0,0,');
+            {$IFDEF POWERPC64}strpcopy(strend(p), '.');{$ENDIF POWERPC64}
+            strpcopy(strend(p),pd.mangledname);
+            if (target_info.use_function_relative_addresses) then
+              begin
+                strpcopy(strend(p),'-');
+                {$IFDEF POWERPC64}strpcopy(strend(p), '.');{$ENDIF POWERPC64}
+                strpcopy(strend(p),pd.mangledname);
+              end;
+            templist.concat(Tai_stab.Create(stab_stabn,strnew(p)));
+            strpcopy(p,'224,0,0,'+stabsendlabel.name);
+            if (target_info.use_function_relative_addresses) then
+              begin
+                strpcopy(strend(p),'-');
+                {$IFDEF POWERPC64}strpcopy(strend(p), '.');{$ENDIF POWERPC64}
+                strpcopy(strend(p),pd.mangledname);
+              end;
+            templist.concat(Tai_stab.Create(stab_stabn,strnew(p)));
+            freemem(p,2*mangled_length+50);
+            asmlist[al_procedures].insertlistbefore(pd.procendtai,templist);
+            templist.free;
+          end;
+      end;
+
+
+{****************************************************************************
+                               TSym support
+****************************************************************************}
+
+    function TDebugInfoStabs.sym_var_value(const s:string;arg:pointer):string;
+      var
+        sym : tsym;
+      begin
+        sym:=tsym(arg);
+        result:='';
+        if s='name' then
+          result:=sym.name
+        else if s='mangledname' then
+          result:=sym.mangledname
+        else if s='ownername' then
+          result:=sym.owner.name^
+        else if s='line' then
+          result:=tostr(sym.fileinfo.line)
+        else if s='N_LSYM' then
+          result:=tostr(N_LSYM)
+        else if s='N_LCSYM' then
+          result:=tostr(N_LCSYM)
+        else if s='N_RSYM' then
+          result:=tostr(N_RSYM)
+        else if s='N_TSYM' then
+          result:=tostr(N_TSYM)
+        else if s='N_STSYM' then
+          result:=tostr(N_STSYM)
+        else if s='N_FUNCTION' then
+          result:=tostr(N_FUNCTION)
+        else
+          internalerror(200401152);
+      end;
+
+
+    function TDebugInfoStabs.sym_stabstr_evaluate(sym:tsym;const s:string;const vars:array of string):Pchar;
+      begin
+        result:=string_evaluate(s,@sym_var_value,sym,vars);
+      end;
+
+
+    procedure TDebugInfoStabs.insertsym(list:taasmoutput;sym:tsym);
+
+        function fieldvarsym_stabstr(sym:tfieldvarsym):Pchar;
+          begin
+            result:=nil;
+            if (sym.owner.symtabletype=objectsymtable) and
+               (sp_static in sym.symoptions) then
+              result:=sym_stabstr_evaluate(sym,'"${ownername}__${name}:S$1",${N_LCSYM},0,${line},${mangledname}',
+                  [def_stab_number(sym.vartype.def)]);
+          end;
+
+        function globalvarsym_stabstr(sym:tglobalvarsym):Pchar;
+          var
+            st : string;
+            threadvaroffset : string;
+            regidx : Tregisterindex;
+          begin
+            result:=nil;
+            { external symbols can't be resolved at link time, so we
+              can't generate stabs for them }
+            if vo_is_external in sym.varoptions then
+              exit;
+            st:=def_stab_number(sym.vartype.def);
+            case sym.localloc.loc of
+              LOC_REGISTER,
+              LOC_CREGISTER,
+              LOC_MMREGISTER,
+              LOC_CMMREGISTER,
+              LOC_FPUREGISTER,
+              LOC_CFPUREGISTER :
+                begin
+                  regidx:=findreg_by_number(sym.localloc.register);
+                  { "eax", "ecx", "edx", "ebx", "esp", "ebp", "esi", "edi", "eip", "ps", "cs", "ss", "ds", "es", "fs", "gs", }
+                  { this is the register order for GDB}
+                  if regidx<>0 then
+                    result:=sym_stabstr_evaluate(sym,'"${name}:r$1",${N_RSYM},0,${line},$2',[st,tostr(regstabs_table[regidx])]);
+                end;
+              else
+                begin
+                  if (vo_is_thread_var in sym.varoptions) then
+                    threadvaroffset:='+'+tostr(sizeof(aint))
+                  else
+                    threadvaroffset:='';
+                  { Here we used S instead of
+                    because with G GDB doesn't look at the address field
+                    but searches the same name or with a leading underscore
+                    but these names don't exist in pascal !}
+                  st:='S'+st;
+                  result:=sym_stabstr_evaluate(sym,'"${name}:$1",${N_LCSYM},0,${line},${mangledname}$2',[st,threadvaroffset]);
+                end;
+            end;
+          end;
+
+        function localvarsym_stabstr(sym:tlocalvarsym):Pchar;
+          var
+            st : string;
+            regidx : Tregisterindex;
+          begin
+            result:=nil;
+            { There is no space allocated for not referenced locals }
+            if (sym.owner.symtabletype=localsymtable) and (sym.refs=0) then
+              exit;
+
+            st:=def_stab_number(sym.vartype.def);
+            case sym.localloc.loc of
+              LOC_REGISTER,
+              LOC_CREGISTER,
+              LOC_MMREGISTER,
+              LOC_CMMREGISTER,
+              LOC_FPUREGISTER,
+              LOC_CFPUREGISTER :
+                begin
+                  regidx:=findreg_by_number(sym.localloc.register);
+                  { "eax", "ecx", "edx", "ebx", "esp", "ebp", "esi", "edi", "eip", "ps", "cs", "ss", "ds", "es", "fs", "gs", }
+                  { this is the register order for GDB}
+                  if regidx<>0 then
+                    result:=sym_stabstr_evaluate(sym,'"${name}:r$1",${N_RSYM},0,${line},$2',[st,tostr(regstabs_table[regidx])]);
+                end;
+              LOC_REFERENCE :
+                { offset to ebp => will not work if the framepointer is esp
+                  so some optimizing will make things harder to debug }
+                result:=sym_stabstr_evaluate(sym,'"${name}:$1",${N_TSYM},0,${line},$2',[st,tostr(sym.localloc.reference.offset)])
+              else
+                internalerror(2003091814);
+            end;
+          end;
+
+        function paravarsym_stabstr(sym:tparavarsym):Pchar;
+          var
+            st : string;
+            regidx : Tregisterindex;
+            c : char;
+          begin
+            result:=nil;
+            { set loc to LOC_REFERENCE to get somewhat usable debugging info for -Or }
+            { while stabs aren't adapted for regvars yet                             }
+            if (vo_is_self in sym.varoptions) then
+              begin
+                case sym.localloc.loc of
+                  LOC_REGISTER,
+                  LOC_CREGISTER:
+                    regidx:=findreg_by_number(sym.localloc.register);
+                  LOC_REFERENCE: ;
+                  else
+                    internalerror(2003091815);
+                end;
+                if (po_classmethod in tabstractprocdef(sym.owner.defowner).procoptions) or
+                   (po_staticmethod in tabstractprocdef(sym.owner.defowner).procoptions) then
+                  begin
+                    if (sym.localloc.loc=LOC_REFERENCE) then
+                      result:=sym_stabstr_evaluate(sym,'"pvmt:p$1",${N_TSYM},0,0,$2',
+                        [def_stab_number(pvmttype.def),tostr(sym.localloc.reference.offset)]);
+      (*            else
+                      result:=sym_stabstr_evaluate(sym,'"pvmt:r$1",${N_RSYM},0,0,$2',
+                        [def_stab_number(pvmttype.def),tostr(regstabs_table[regidx])]) *)
+                    end
+                else
+                  begin
+                    if not(is_class(tprocdef(sym.owner.defowner)._class)) then
+                      c:='v'
+                    else
+                      c:='p';
+                    if (sym.localloc.loc=LOC_REFERENCE) then
+                      result:=sym_stabstr_evaluate(sym,'"$$t:$1",${N_TSYM},0,0,$2',
+                            [c+def_stab_number(tprocdef(sym.owner.defowner)._class),tostr(sym.localloc.reference.offset)]);
+      (*            else
+                      result:=sym_stabstr_evaluate(sym,'"$$t:r$1",${N_RSYM},0,0,$2',
+                            [c+def_stab_number(tprocdef(sym.owner.defowner)._class),tostr(regstabs_table[regidx])]); *)
+                  end;
+              end
+            else
+              begin
+                st:=def_stab_number(sym.vartype.def);
+
+                if paramanager.push_addr_param(sym.varspez,sym.vartype.def,tprocdef(sym.owner.defowner).proccalloption) and
+                   not(vo_has_local_copy in sym.varoptions) and
+                   not is_open_string(sym.vartype.def) then
+                  st := 'v'+st { should be 'i' but 'i' doesn't work }
+                else
+                  st := 'p'+st;
+                case sym.localloc.loc of
+                  LOC_REGISTER,
+                  LOC_CREGISTER,
+                  LOC_MMREGISTER,
+                  LOC_CMMREGISTER,
+                  LOC_FPUREGISTER,
+                  LOC_CFPUREGISTER :
+                    begin
+                      regidx:=findreg_by_number(sym.localloc.register);
+                      { "eax", "ecx", "edx", "ebx", "esp", "ebp", "esi", "edi", "eip", "ps", "cs", "ss", "ds", "es", "fs", "gs", }
+                      { this is the register order for GDB}
+                      if regidx<>0 then
+                        result:=sym_stabstr_evaluate(sym,'"${name}:r$1",${N_RSYM},0,${line},$2',[st,tostr(longint(regstabs_table[regidx]))]);
+                    end;
+                  LOC_REFERENCE :
+                    { offset to ebp => will not work if the framepointer is esp
+                      so some optimizing will make things harder to debug }
+                    result:=sym_stabstr_evaluate(sym,'"${name}:$1",${N_TSYM},0,${line},$2',[st,tostr(sym.localloc.reference.offset)])
+                  else
+                    internalerror(2003091814);
+                end;
+              end;
+          end;
+
+        function constsym_stabstr(sym:tconstsym):Pchar;
+          var
+            st : string;
+          begin
+            case sym.consttyp of
+              conststring:
+                begin
+                  if sym.value.len<200 then
+                    st:='s'''+backspace_quote(octal_quote(strpas(pchar(sym.value.valueptr)),[#0..#9,#11,#12,#14..#31,'''']),['"','\',#10,#13])+''''
+                  else
+                    st:='<constant string too long>';
+                end;
+              constord:
+                st:='i'+tostr(sym.value.valueord);
+              constpointer:
+                st:='i'+tostr(sym.value.valueordptr);
+              constreal:
+                begin
+                  system.str(pbestreal(sym.value.valueptr)^,st);
+                  st := 'r'+st;
+                end;
+              else
+                begin
+                  { if we don't know just put zero !! }
+                  st:='i0';
+                end;
+            end;
+            { valgrind does not support constants }
+            if cs_gdb_valgrind in aktglobalswitches then
+              result:=nil
+            else
+              result:=sym_stabstr_evaluate(sym,'"${name}:c=$1;",${N_FUNCTION},0,${line},0',[st]);
+          end;
+
+        function typesym_stabstr(sym:ttypesym) : pchar;
+          var
+            stabchar : string[2];
+          begin
+            result:=nil;
+            if not assigned(sym.restype.def) then
+              internalerror(200509262);
+            if sym.restype.def.deftype in tagtypes then
+              stabchar:='Tt'
+            else
+              stabchar:='t';
+            result:=sym_stabstr_evaluate(sym,'"${name}:$1$2",${N_LSYM},0,${line},0',[stabchar,def_stab_number(sym.restype.def)]);
+          end;
+
+        function procsym_stabstr(sym:tprocsym) : pchar;
+          var
+            i : longint;
+          begin
+            result:=nil;
+            for i:=1 to sym.procdef_count do
+              write_procdef(list,sym.procdef[i]);
+          end;
+
+      var
+        stabstr : Pchar;
+      begin
+        stabstr:=nil;
+        case sym.typ of
+          labelsym :
+            stabstr:=sym_stabstr_evaluate(sym,'"${name}",${N_LSYM},0,${line},0',[]);
+          fieldvarsym :
+            stabstr:=fieldvarsym_stabstr(tfieldvarsym(sym));
+          globalvarsym :
+            stabstr:=globalvarsym_stabstr(tglobalvarsym(sym));
+          localvarsym :
+            stabstr:=localvarsym_stabstr(tlocalvarsym(sym));
+          paravarsym :
+            stabstr:=paravarsym_stabstr(tparavarsym(sym));
+          typedconstsym :
+            stabstr:=sym_stabstr_evaluate(sym,'"${name}:S$1",${N_STSYM},0,${line},${mangledname}',
+                [def_stab_number(ttypedconstsym(sym).typedconsttype.def)]);
+          constsym :
+            stabstr:=constsym_stabstr(tconstsym(sym));
+          typesym :
+            stabstr:=typesym_stabstr(ttypesym(sym));
+          procsym :
+            stabstr:=procsym_stabstr(tprocsym(sym));
+        end;
+        if stabstr<>nil then
+          list.concat(Tai_stab.create(stab_stabs,stabstr));
+        { For object types write also the symtable entries }
+        if (sym.typ=typesym) and (ttypesym(sym).restype.def.deftype=objectdef) then
+          write_symtable_syms(list,tobjectdef(ttypesym(sym).restype.def).symtable);
+        sym.isstabwritten:=true;
+      end;
+
+
+    procedure TDebugInfoStabs.write_symtable_syms(list:taasmoutput;st:tsymtable);
+      var
+        p : tsym;
+      begin
+        case st.symtabletype of
+          staticsymtable :
+            list.concat(tai_comment.Create(strpnew('Syms - Begin Staticsymtable')));
+          globalsymtable :
+            list.concat(tai_comment.Create(strpnew('Syms - Begin unit '+st.name^+' has index '+tostr(st.moduleid))));
+        end;
+        p:=tsym(st.symindex.first);
+        while assigned(p) do
+          begin
+            if (not p.isstabwritten) then
+              insertsym(list,p);
+            p:=tsym(p.indexnext);
+          end;
+        case st.symtabletype of
+          staticsymtable :
+            list.concat(tai_comment.Create(strpnew('Syms - End Staticsymtable')));
+          globalsymtable :
+            list.concat(tai_comment.Create(strpnew('Syms - End unit '+st.name^+' has index '+tostr(st.moduleid))));
+        end;
+      end;
+
+{****************************************************************************
+                             Proc/Module support
+****************************************************************************}
+
+    procedure tdebuginfostabs.inserttypeinfo;
+
+       procedure reset_unit_type_info;
+       var
+         hp : tmodule;
+       begin
+         hp:=tmodule(loaded_units.first);
+         while assigned(hp) do
+           begin
+             hp.is_stab_written:=false;
+             hp:=tmodule(hp.next);
+           end;
+       end;
+
+       procedure write_used_unit_type_info(list:taasmoutput;hp:tmodule);
+       var
+         pu : tused_unit;
+       begin
+         pu:=tused_unit(hp.used_units.first);
+         while assigned(pu) do
+           begin
+             if not pu.u.is_stab_written then
+               begin
+                 { prevent infinte loop for circular dependencies }
+                 pu.u.is_stab_written:=true;
+                 { write type info from used units, use a depth first
+                   strategy to reduce the recursion in writing all
+                   dependent stabs }
+                 write_used_unit_type_info(list,pu.u);
+                 if assigned(pu.u.globalsymtable) then
+                   write_symtable_defs(list,pu.u.globalsymtable);
+               end;
+             pu:=tused_unit(pu.next);
+           end;
+       end;
+
+      var
+        stabsvarlist,
+        stabstypelist : taasmoutput;
+        storefilepos  : tfileposinfo;
+        st : tsymtable;
+        i  : longint;
+      begin
+        storefilepos:=aktfilepos;
+        aktfilepos:=current_module.mainfilepos;
+
+        global_stab_number:=0;
+        defnumberlist:=tlist.create;
+        stabsvarlist:=taasmoutput.create;
+        stabstypelist:=taasmoutput.create;
+
+        { include symbol that will be referenced from the main to be sure to
+          include this debuginfo .o file }
+        if current_module.is_unit then
+          begin
+            current_module.flags:=current_module.flags or uf_has_debuginfo;
+            st:=current_module.globalsymtable;
+          end
+        else
+          st:=current_module.localsymtable;
+        new_section(asmlist[al_stabs],sec_data,st.name^,0);
+        asmlist[al_stabs].concat(tai_symbol.Createname_global(make_mangledname('DEBUGINFO',st,''),AT_DATA,0));
+
+        { first write all global/local symbols. This will flag all required tdefs  }
+        if assigned(current_module.globalsymtable) then
+          write_symtable_syms(stabsvarlist,current_module.globalsymtable);
+        if assigned(current_module.localsymtable) then
+          write_symtable_syms(stabsvarlist,current_module.localsymtable);
+
+        { reset unit type info flag }
+        reset_unit_type_info;
+
+        { write used types from the used units }
+        write_used_unit_type_info(stabstypelist,current_module);
+        { last write the types from this unit }
+        if assigned(current_module.globalsymtable) then
+          write_symtable_defs(stabstypelist,current_module.globalsymtable);
+        if assigned(current_module.localsymtable) then
+          write_symtable_defs(stabstypelist,current_module.localsymtable);
+
+        asmlist[al_stabs].concatlist(stabstypelist);
+        asmlist[al_stabs].concatlist(stabsvarlist);
+
+        { reset stab numbers }
+        for i:=0 to defnumberlist.count-1 do
+          begin
+            if assigned(defnumberlist[i]) then
+              begin
+                tdef(defnumberlist[i]).stab_number:=0;
+                tdef(defnumberlist[i]).stab_state:=stab_state_unused;
+              end;
+          end;
+
+        defnumberlist.free;
+        defnumberlist:=nil;
+
+        stabsvarlist.free;
+        stabstypelist.free;
+        aktfilepos:=storefilepos;
+      end;
+
+
+    procedure tdebuginfostabs.insertlineinfo(list:taasmoutput);
+      var
+        currfileinfo,
+        lastfileinfo : tfileposinfo;
+        currfuncname : pstring;
+        currsectype  : tasmsectiontype;
+        hlabel       : tasmlabel;
+        hp : tai;
+        infile : tinputfile;
+      begin
+        FillChar(lastfileinfo,sizeof(lastfileinfo),0);
+        currfuncname:=nil;
+        currsectype:=sec_code;
+        hp:=Tai(list.first);
+        while assigned(hp) do
+          begin
+            case hp.typ of
+              ait_section :
+                currsectype:=tai_section(hp).sectype;
+              ait_function_name :
+                currfuncname:=tai_function_name(hp).funcname;
+              ait_force_line :
+                lastfileinfo.line:=-1;
+            end;
+
+            if (currsectype=sec_code) and
+               (hp.typ=ait_instruction) then
+              begin
+                currfileinfo:=tailineinfo(hp).fileinfo;
+                { file changed ? (must be before line info) }
+                if (currfileinfo.fileindex<>0) and
+                   (lastfileinfo.fileindex<>currfileinfo.fileindex) then
+                  begin
+                    infile:=current_module.sourcefiles.get_file(currfileinfo.fileindex);
+                    if assigned(infile) then
+                      begin
+                        objectlibrary.getlabel(hlabel,alt_dbgfile);
+                        { emit stabs }
+                        if (infile.path^<>'') then
+                          list.insertbefore(Tai_stab.Create_str(stab_stabs,'"'+BsToSlash(FixPath(infile.path^,false))+'",'+tostr(n_includefile)+
+                                            ',0,0,'+hlabel.name),hp);
+                        list.insertbefore(Tai_stab.Create_str(stab_stabs,'"'+FixFileName(infile.name^)+'",'+tostr(n_includefile)+
+                                          ',0,0,'+hlabel.name),hp);
+                        list.insertbefore(tai_label.create(hlabel),hp);
+                        { force new line info }
+                        lastfileinfo.line:=-1;
+                      end;
+                  end;
+
+                { line changed ? }
+                if (lastfileinfo.line<>currfileinfo.line) and (currfileinfo.line<>0) then
+                  begin
+                     if assigned(currfuncname) and
+                        (target_info.use_function_relative_addresses) then
+                      begin
+                        objectlibrary.getlabel(hlabel,alt_dbgline);
+                        list.insertbefore(Tai_stab.Create_str(stab_stabn,tostr(n_textline)+',0,'+tostr(currfileinfo.line)+','+
+                                          hlabel.name+' - '+{$IFDEF POWERPC64}'.'+{$ENDIF POWERPC64}currfuncname^),hp);
+                        list.insertbefore(tai_label.create(hlabel),hp);
+                      end
+                     else
+                      list.insertbefore(Tai_stab.Create_str(stab_stabd,tostr(n_textline)+',0,'+tostr(currfileinfo.line)),hp);
+                  end;
+                lastfileinfo:=currfileinfo;
+              end;
+
+            hp:=tai(hp.next);
+          end;
+      end;
+
+
+    procedure tdebuginfostabs.insertmoduleinfo;
+      var
+        hlabel : tasmlabel;
+        infile : tinputfile;
+        templist : taasmoutput;
+      begin
+        { emit main source n_sourcefile for start of module }
+        objectlibrary.getlabel(hlabel,alt_dbgfile);
+        infile:=current_module.sourcefiles.get_file(1);
+        templist:=taasmoutput.create;
+        new_section(templist,sec_code,'',0);
+        if (infile.path^<>'') then
+          templist.concat(Tai_stab.Create_str(stab_stabs,'"'+BsToSlash(FixPath(infile.path^,false))+'",'+tostr(n_sourcefile)+
+                      ',0,0,'+hlabel.name));
+        templist.concat(Tai_stab.Create_str(stab_stabs,'"'+FixFileName(infile.name^)+'",'+tostr(n_sourcefile)+
+                    ',0,0,'+hlabel.name));
+        templist.concat(tai_label.create(hlabel));
+        asmlist[al_stabsstart].insertlist(templist);
+        templist.free;
+        { emit empty n_sourcefile for end of module }
+        objectlibrary.getlabel(hlabel,alt_dbgfile);
+        templist:=taasmoutput.create;
+        new_section(templist,sec_code,'',0);
+        templist.concat(Tai_stab.Create_str(stab_stabs,'"",'+tostr(n_sourcefile)+',0,0,'+hlabel.name));
+        templist.concat(tai_label.create(hlabel));
+        asmlist[al_stabsend].insertlist(templist);
+        templist.free;
+      end;
+
+
+    procedure tdebuginfostabs.referencesections(list:taasmoutput);
+      var
+        hp   : tused_unit;
+      begin
+        { Reference all DEBUGINFO sections from the main .text section }
+        if (target_info.system <> system_powerpc_macos) then
+          begin
+            { include reference to all debuginfo sections of used units }
+            hp:=tused_unit(usedunits.first);
+            while assigned(hp) do
+              begin
+                If (hp.u.flags and uf_has_debuginfo)=uf_has_debuginfo then
+                  list.concat(Tai_const.Createname(make_mangledname('DEBUGINFO',hp.u.globalsymtable,''),AT_DATA,0));
+                hp:=tused_unit(hp.next);
+              end;
+            { include reference to debuginfo for this program }
+            list.concat(Tai_const.Createname(make_mangledname('DEBUGINFO',current_module.localsymtable,''),AT_DATA,0));
+          end;
+      end;
+
+
+    const
+      dbg_stabs_info : tdbginfo =
+         (
+           id     : dbg_stabs;
+           idtxt  : 'STABS';
+         );
+
+initialization
+  RegisterDebugInfo(dbg_stabs_info,TDebugInfoStabs);
+end.

+ 1489 - 0
compiler/defcmp.pas

@@ -0,0 +1,1489 @@
+{
+    Copyright (c) 1998-2002 by Florian Klaempfl
+
+    Compare definitions and parameter lists
+
+    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 defcmp;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+       cclasses,
+       globtype,globals,
+       node,
+       symconst,symtype,symdef;
+
+     type
+       { if acp is cp_all the var const or nothing are considered equal }
+       tcompare_paras_type = ( cp_none, cp_value_equal_const, cp_all,cp_procvar);
+       tcompare_paras_option = (cpo_allowdefaults,cpo_ignorehidden,cpo_allowconvert,cpo_comparedefaultvalue);
+       tcompare_paras_options = set of tcompare_paras_option;
+
+       tcompare_defs_option = (cdo_internal,cdo_explicit,cdo_check_operator,cdo_allow_variant);
+       tcompare_defs_options = set of tcompare_defs_option;
+
+       tconverttype = (tc_none,
+          tc_equal,
+          tc_not_possible,
+          tc_string_2_string,
+          tc_char_2_string,
+          tc_char_2_chararray,
+          tc_pchar_2_string,
+          tc_cchar_2_pchar,
+          tc_cstring_2_pchar,
+          tc_cstring_2_int,
+          tc_ansistring_2_pchar,
+          tc_string_2_chararray,
+          tc_chararray_2_string,
+          tc_array_2_pointer,
+          tc_pointer_2_array,
+          tc_int_2_int,
+          tc_int_2_bool,
+          tc_bool_2_bool,
+          tc_bool_2_int,
+          tc_real_2_real,
+          tc_int_2_real,
+          tc_real_2_currency,
+          tc_proc_2_procvar,
+          tc_arrayconstructor_2_set,
+          tc_load_smallset,
+          tc_cord_2_pointer,
+          tc_intf_2_string,
+          tc_intf_2_guid,
+          tc_class_2_intf,
+          tc_char_2_char,
+          tc_normal_2_smallset,
+          tc_dynarray_2_openarray,
+          tc_pwchar_2_string,
+          tc_variant_2_dynarray,
+          tc_dynarray_2_variant,
+          tc_variant_2_enum,
+          tc_enum_2_variant,
+          tc_interface_2_variant,
+          tc_variant_2_interface,
+          tc_array_2_dynarray
+       );
+
+    function compare_defs_ext(def_from,def_to : tdef;
+                              fromtreetype : tnodetype;
+                              var doconv : tconverttype;
+                              var operatorpd : tprocdef;
+                              cdoptions:tcompare_defs_options):tequaltype;
+
+    { Returns if the type def_from can be converted to def_to or if both types are equal }
+    function compare_defs(def_from,def_to:tdef;fromtreetype:tnodetype):tequaltype;
+
+    { Returns true, if def1 and def2 are semantically the same }
+    function equal_defs(def_from,def_to:tdef):boolean;
+
+    { Checks for type compatibility (subgroups of type)
+      used for case statements... probably missing stuff
+      to use on other types }
+    function is_subequal(def1, def2: tdef): boolean;
+
+     {# true, if two parameter lists are equal
+      if acp is cp_none, all have to match exactly
+      if acp is cp_value_equal_const call by value
+      and call by const parameter are assumed as
+      equal
+      allowdefaults indicates if default value parameters
+      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)
+    }
+    function compare_paras(para1,para2 : tlist; acp : tcompare_paras_type; cpoptions: tcompare_paras_options):tequaltype;
+
+    { True if a function can be assigned to a procvar }
+    { changed first argument type to pabstractprocdef so that it can also be }
+    { used to test compatibility between two pprocvardefs (JM)               }
+    function proc_to_procvar_equal(def1:tabstractprocdef;def2:tprocvardef):tequaltype;
+
+
+implementation
+
+    uses
+      verbose,systems,
+      symtable,symsym,
+      defutil,symutil;
+
+
+    function compare_defs_ext(def_from,def_to : tdef;
+                              fromtreetype : tnodetype;
+                              var doconv : tconverttype;
+                              var operatorpd : tprocdef;
+                              cdoptions:tcompare_defs_options):tequaltype;
+
+      { Tbasetype:
+           uvoid,
+           u8bit,u16bit,u32bit,u64bit,
+           s8bit,s16bit,s32bit,s64bit,
+           bool8bit,bool16bit,bool32bit,
+           uchar,uwidechar }
+
+      type
+        tbasedef=(bvoid,bchar,bint,bbool);
+      const
+        basedeftbl:array[tbasetype] of tbasedef =
+          (bvoid,
+           bint,bint,bint,bint,
+           bint,bint,bint,bint,
+           bbool,bbool,bbool,
+           bchar,bchar,bint);
+
+        basedefconvertsimplicit : array[tbasedef,tbasedef] of tconverttype =
+          { void, char, int, bool }
+         ((tc_not_possible,tc_not_possible,tc_not_possible,tc_not_possible),
+          (tc_not_possible,tc_char_2_char,tc_not_possible,tc_not_possible),
+          (tc_not_possible,tc_not_possible,tc_int_2_int,tc_not_possible),
+          (tc_not_possible,tc_not_possible,tc_not_possible,tc_bool_2_bool));
+        basedefconvertsexplicit : array[tbasedef,tbasedef] of tconverttype =
+          { void, char, int, bool }
+         ((tc_not_possible,tc_not_possible,tc_not_possible,tc_not_possible),
+          (tc_not_possible,tc_char_2_char,tc_int_2_int,tc_int_2_bool),
+          (tc_not_possible,tc_int_2_int,tc_int_2_int,tc_int_2_bool),
+          (tc_not_possible,tc_bool_2_int,tc_bool_2_int,tc_bool_2_bool));
+
+      var
+         subeq,eq : tequaltype;
+         hd1,hd2 : tdef;
+         hct : tconverttype;
+         hd3 : tobjectdef;
+         hpd : tprocdef;
+      begin
+         eq:=te_incompatible;
+         doconv:=tc_not_possible;
+
+         { safety check }
+         if not(assigned(def_from) and assigned(def_to)) then
+          begin
+            compare_defs_ext:=te_incompatible;
+            exit;
+          end;
+
+         { same def? then we've an exact match }
+         if def_from=def_to then
+          begin
+            doconv:=tc_equal;
+            compare_defs_ext:=te_exact;
+            exit;
+          end;
+
+         { we walk the wanted (def_to) types and check then the def_from
+           types if there is a conversion possible }
+         case def_to.deftype of
+           orddef :
+             begin
+               case def_from.deftype of
+                 orddef :
+                   begin
+                     if (torddef(def_from).typ=torddef(def_to).typ) then
+                      begin
+                        case torddef(def_from).typ of
+                          uchar,uwidechar,
+                          u8bit,u16bit,u32bit,u64bit,
+                          s8bit,s16bit,s32bit,s64bit:
+                            begin
+                              if (torddef(def_from).low=torddef(def_to).low) and
+                                 (torddef(def_from).high=torddef(def_to).high) then
+                                eq:=te_equal
+                              else
+                                begin
+                                  doconv:=tc_int_2_int;
+                                  eq:=te_convert_l1;
+                                end;
+                            end;
+                          uvoid,
+                          bool8bit,bool16bit,bool32bit:
+                            eq:=te_equal;
+                          else
+                            internalerror(200210061);
+                        end;
+                      end
+                     else
+                      begin
+                        if cdo_explicit in cdoptions then
+                         doconv:=basedefconvertsexplicit[basedeftbl[torddef(def_from).typ],basedeftbl[torddef(def_to).typ]]
+                        else
+                         doconv:=basedefconvertsimplicit[basedeftbl[torddef(def_from).typ],basedeftbl[torddef(def_to).typ]];
+                        if (doconv=tc_not_possible) then
+                          eq:=te_incompatible
+                        else
+                          { "punish" bad type conversions :) (JM) }
+                          if (not is_in_limit(def_from,def_to)) and
+                             (def_from.size > def_to.size) then
+                            eq:=te_convert_l3
+                        else
+                          eq:=te_convert_l1;
+                      end;
+                   end;
+                 enumdef :
+                   begin
+                     { needed for char(enum) }
+                     if cdo_explicit in cdoptions then
+                      begin
+                        doconv:=tc_int_2_int;
+                        eq:=te_convert_l1;
+                      end;
+                   end;
+                 floatdef :
+                   begin
+                     if is_currency(def_to) then
+                      begin
+                        doconv:=tc_real_2_currency;
+                        eq:=te_convert_l2;
+                      end;
+                   end;
+                 classrefdef,
+                 procvardef,
+                 pointerdef :
+                   begin
+                     if cdo_explicit in cdoptions then
+                      begin
+                        eq:=te_convert_l1;
+                        if (fromtreetype=niln) then
+                         begin
+                           { will be handled by the constant folding }
+                           doconv:=tc_equal;
+                         end
+                        else
+                         doconv:=tc_int_2_int;
+                      end;
+                   end;
+                 arraydef :
+                   begin
+                     if (m_mac in aktmodeswitches) and
+                        (fromtreetype=stringconstn) then
+                       begin
+                         eq:=te_convert_l3;
+                         doconv:=tc_cstring_2_int;
+                       end;
+                   end;
+               end;
+             end;
+
+           stringdef :
+             begin
+               case def_from.deftype of
+                 stringdef :
+                   begin
+                     { Constant string }
+                     if (fromtreetype=stringconstn) then
+                      begin
+                        { we can change the stringconst node }
+                        if (tstringdef(def_from).string_typ=st_conststring) or
+                           (tstringdef(def_from).string_typ=tstringdef(def_to).string_typ) then
+                          eq:=te_equal
+                        else
+                         begin
+                           doconv:=tc_string_2_string;
+                           { Don't prefer conversions from widestring to a
+                             normal string as we can loose information }
+                           if tstringdef(def_from).string_typ=st_widestring then
+                             eq:=te_convert_l3
+                           else if tstringdef(def_to).string_typ=st_widestring then
+                             eq:=te_convert_l2
+                           else
+                             eq:=te_equal;
+                         end;
+                      end
+                     else
+                     { Same string type, for shortstrings also the length must match }
+                      if (tstringdef(def_from).string_typ=tstringdef(def_to).string_typ) and
+                         ((tstringdef(def_from).string_typ<>st_shortstring) or
+                          (tstringdef(def_from).len=tstringdef(def_to).len)) then
+                        eq:=te_equal
+                     else
+                       begin
+                         doconv:=tc_string_2_string;
+                         case tstringdef(def_from).string_typ of
+                           st_widestring :
+                             begin
+                               { Prefer conversions to ansistring }
+                               if tstringdef(def_to).string_typ=st_ansistring then
+                                 eq:=te_convert_l2
+                               else
+                                 eq:=te_convert_l3;
+                             end;
+                           st_shortstring :
+                             begin
+                               { Prefer shortstrings of different length or conversions
+                                 from shortstring to ansistring }
+                               if (tstringdef(def_to).string_typ=st_shortstring) then
+                                 eq:=te_convert_l1
+                               else if tstringdef(def_to).string_typ=st_ansistring then
+                                 eq:=te_convert_l2
+                               else
+                                 eq:=te_convert_l3;
+                             end;
+                           st_ansistring :
+                             begin
+                               { Prefer conversion to widestrings }
+                               if (tstringdef(def_to).string_typ=st_widestring) then
+                                 eq:=te_convert_l2
+                               else
+                                 eq:=te_convert_l3;
+                             end;
+                         end;
+                       end;
+                   end;
+                 orddef :
+                   begin
+                   { char to string}
+                     if is_char(def_from) or
+                        is_widechar(def_from) then
+                      begin
+                        doconv:=tc_char_2_string;
+                        eq:=te_convert_l1;
+                      end;
+                   end;
+                 arraydef :
+                   begin
+                     { array of char to string, the length check is done by the firstpass of this node }
+                     if is_chararray(def_from) or is_open_chararray(def_from) then
+                      begin
+                        { "Untyped" stringconstn is an array of char }
+                        if fromtreetype=stringconstn then
+                          begin
+                            doconv:=tc_string_2_string;
+                            { prefered string type depends on the $H switch }
+                            if not(cs_ansistrings in aktlocalswitches) and
+                               (tstringdef(def_to).string_typ=st_shortstring) then
+                              eq:=te_equal
+                            else if (cs_ansistrings in aktlocalswitches) and
+                               (tstringdef(def_to).string_typ=st_ansistring) then
+                              eq:=te_equal
+                            else if tstringdef(def_to).string_typ=st_widestring then
+                              eq:=te_convert_l3
+                            else
+                              eq:=te_convert_l1;
+                          end
+                        else
+                          begin
+                          doconv:=tc_chararray_2_string;
+                          if is_open_array(def_from) then
+                            begin
+                              if is_ansistring(def_to) then
+                                eq:=te_convert_l1
+                              else if is_widestring(def_to) then
+                                eq:=te_convert_l3
+                              else
+                                eq:=te_convert_l2;
+                            end
+                          else
+                            begin
+                              if is_shortstring(def_to) then
+                                begin
+                                  { Only compatible with arrays that fit
+                                    smaller than 255 chars }
+                                  if (def_from.size <= 255) then
+                                    eq:=te_convert_l1;
+                                end
+                              else if is_ansistring(def_to) then
+                                begin
+                                  if (def_from.size > 255) then
+                                    eq:=te_convert_l1
+                                  else
+                                    eq:=te_convert_l2;
+                                end
+                              else if is_widestring(def_to) then
+                                eq:=te_convert_l3
+                              else
+                                eq:=te_convert_l2;
+                            end;
+                          end;
+                      end
+                     else
+                     { array of widechar to string, the length check is done by the firstpass of this node }
+                      if is_widechararray(def_from) or is_open_widechararray(def_from) then
+                       begin
+                         doconv:=tc_chararray_2_string;
+                         if is_widestring(def_to) then
+                           eq:=te_convert_l1
+                         else
+                           { size of widechar array is double due the sizeof a widechar }
+                           if not(is_shortstring(def_to) and (def_from.size>255*sizeof(widechar))) then
+                             eq:=te_convert_l3
+                         else
+                           eq:=te_convert_l2;
+                       end;
+                   end;
+                 pointerdef :
+                   begin
+                   { pchar can be assigned to short/ansistrings,
+                     but not in tp7 compatible mode }
+                     if not(m_tp7 in aktmodeswitches) then
+                       begin
+                          if is_pchar(def_from) then
+                           begin
+                             doconv:=tc_pchar_2_string;
+                             { 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 aktlocalswitches)) or
+                                (is_ansistring(def_to) and
+                                 (cs_ansistrings in aktlocalswitches)) then
+                               eq:=te_convert_l1
+                             else
+                               eq:=te_convert_l2;
+                           end
+                          else if is_pwidechar(def_from) then
+                           begin
+                             doconv:=tc_pwchar_2_string;
+                             if is_widestring(def_to) then
+                               eq:=te_convert_l1
+                             else
+                               eq:=te_convert_l3;
+                           end;
+                       end;
+                   end;
+               end;
+             end;
+
+           floatdef :
+             begin
+               case def_from.deftype of
+                 orddef :
+                   begin { ordinal to real }
+                     if is_integer(def_from) or
+                        (is_currency(def_from) and
+                         (s64currencytype.def.deftype = floatdef)) then
+                       begin
+                         doconv:=tc_int_2_real;
+                         eq:=te_convert_l1;
+                       end
+                     else if is_currency(def_from)
+                             { and (s64currencytype.def.deftype = orddef)) } then
+                       begin
+                         { prefer conversion to orddef in this case, unless    }
+                         { the orddef < currency (then it will get convert l3, }
+                         { and conversion to float is favoured)                }
+                         doconv:=tc_int_2_real;
+                         eq:=te_convert_l2;
+                       end;
+                   end;
+                 floatdef :
+                   begin
+                     if tfloatdef(def_from).typ=tfloatdef(def_to).typ then
+                       eq:=te_equal
+                     else
+                       begin
+                         if (fromtreetype=realconstn) or
+                            not((cdo_explicit in cdoptions) and
+                                (m_delphi in aktmodeswitches)) then
+                           begin
+                             doconv:=tc_real_2_real;
+                             { do we loose precision? }
+                             if def_to.size<def_from.size then
+                               eq:=te_convert_l2
+                             else
+                               eq:=te_convert_l1;
+                           end;
+                       end;
+                   end;
+               end;
+             end;
+
+           enumdef :
+             begin
+               case def_from.deftype of
+                 enumdef :
+                   begin
+                     if cdo_explicit in cdoptions then
+                      begin
+                        eq:=te_convert_l1;
+                        doconv:=tc_int_2_int;
+                      end
+                     else
+                      begin
+                        hd1:=def_from;
+                        while assigned(tenumdef(hd1).basedef) do
+                          hd1:=tenumdef(hd1).basedef;
+                        hd2:=def_to;
+                        while assigned(tenumdef(hd2).basedef) do
+                          hd2:=tenumdef(hd2).basedef;
+                        if (hd1=hd2) then
+                          begin
+                            eq:=te_convert_l1;
+                            { because of packenum they can have different sizes! (JM) }
+                            doconv:=tc_int_2_int;
+                          end
+                        else
+                          begin
+                            { assignment of an enum symbol to an unique type? }
+                            if (fromtreetype=ordconstn) and
+                              (tenumsym(tenumdef(hd1).firstenum)=tenumsym(tenumdef(hd2).firstenum)) then
+                              begin
+                                { because of packenum they can have different sizes! (JM) }
+                                eq:=te_convert_l1;
+                                doconv:=tc_int_2_int;
+                              end;
+                          end;
+                      end;
+                   end;
+                 orddef :
+                   begin
+                     if cdo_explicit in cdoptions then
+                      begin
+                        eq:=te_convert_l1;
+                        doconv:=tc_int_2_int;
+                      end;
+                   end;
+                 variantdef :
+                   begin
+                     eq:=te_convert_l1;
+                     doconv:=tc_variant_2_enum;
+                   end;
+                 pointerdef :
+                   begin
+                     { ugly, but delphi allows it }
+                     if (cdo_explicit in cdoptions) and
+                       (m_delphi in aktmodeswitches) and
+                       (eq=te_incompatible) then
+                       begin
+                         doconv:=tc_int_2_int;
+                         eq:=te_convert_l1;
+                       end;
+                   end;
+               end;
+             end;
+
+           arraydef :
+             begin
+             { open array is also compatible with a single element of its base type }
+               if is_open_array(def_to) and
+                  equal_defs(def_from,tarraydef(def_to).elementtype.def) then
+                begin
+                  doconv:=tc_equal;
+                  eq:=te_convert_l1;
+                end
+               else
+                begin
+                  case def_from.deftype of
+                    arraydef :
+                      begin
+                        { to dynamic array }
+                        if is_dynamic_array(def_to) then
+                         begin
+                           if equal_defs(tarraydef(def_from).elementtype.def,tarraydef(def_to).elementtype.def) then
+                             begin
+                               { dynamic array -> dynamic array }
+                               if is_dynamic_array(def_from) then
+                                 eq:=te_equal
+                               { fpc modes only: array -> dyn. array }
+                               else if (aktmodeswitches*[m_objfpc,m_fpc]<>[]) and
+                                 not(is_special_array(def_from)) and
+                                 is_zero_based_array(def_from) then
+                                 begin
+                                   eq:=te_convert_l2;
+                                   doconv:=tc_array_2_dynarray;
+                                 end;
+                             end
+                         end
+                        else
+                         { to open array }
+                         if is_open_array(def_to) then
+                          begin
+                            { array constructor -> open array }
+                            if is_array_constructor(def_from) then
+                             begin
+                               if is_void(tarraydef(def_from).elementtype.def) then
+                                begin
+                                  doconv:=tc_equal;
+                                  eq:=te_convert_l1;
+                                end
+                               else
+                                begin
+                                  subeq:=compare_defs_ext(tarraydef(def_from).elementtype.def,
+                                                       tarraydef(def_to).elementtype.def,
+                                                       arrayconstructorn,hct,hpd,[cdo_check_operator]);
+                                  if (subeq>=te_equal) then
+                                    begin
+                                      doconv:=tc_equal;
+                                      eq:=te_convert_l1;
+                                    end
+                                  else
+                                   if (subeq>te_incompatible) then
+                                    begin
+                                      doconv:=hct;
+                                      eq:=te_convert_l2;
+                                    end;
+                                end;
+                             end
+                            else
+                             { dynamic array -> open array }
+                             if is_dynamic_array(def_from) and
+                                equal_defs(tarraydef(def_from).elementtype.def,tarraydef(def_to).elementtype.def) then
+                               begin
+                                 doconv:=tc_dynarray_2_openarray;
+                                 eq:=te_convert_l2;
+                               end
+                            else
+                             { array -> open array }
+                             if equal_defs(tarraydef(def_from).elementtype.def,tarraydef(def_to).elementtype.def) then
+                               eq:=te_equal;
+                          end
+                        else
+                         { to array of const }
+                         if is_array_of_const(def_to) then
+                          begin
+                            if is_array_of_const(def_from) or
+                               is_array_constructor(def_from) then
+                             begin
+                               eq:=te_equal;
+                             end
+                            else
+                             { array of tvarrec -> array of const }
+                             if equal_defs(tarraydef(def_to).elementtype.def,tarraydef(def_from).elementtype.def) then
+                              begin
+                                doconv:=tc_equal;
+                                eq:=te_convert_l1;
+                              end;
+                          end
+                        else
+                          { to array of char, from "Untyped" stringconstn (array of char) }
+                          if (fromtreetype=stringconstn) and
+                             (is_chararray(def_to) or
+                              is_widechararray(def_to)) then
+                            begin
+                              eq:=te_convert_l1;
+                              doconv:=tc_string_2_chararray;
+                            end
+                        else
+                         { other arrays }
+                          begin
+                            { open array -> array }
+                            if is_open_array(def_from) and
+                               equal_defs(tarraydef(def_from).elementtype.def,tarraydef(def_to).elementtype.def) then
+                              begin
+                                eq:=te_equal
+                              end
+                            else
+                            { array -> array }
+                             if not(m_tp7 in aktmodeswitches) and
+                                not(m_delphi in aktmodeswitches) and
+                                (tarraydef(def_from).lowrange=tarraydef(def_to).lowrange) and
+                                (tarraydef(def_from).highrange=tarraydef(def_to).highrange) and
+                                equal_defs(tarraydef(def_from).elementtype.def,tarraydef(def_to).elementtype.def) and
+                                equal_defs(tarraydef(def_from).rangetype.def,tarraydef(def_to).rangetype.def) then
+                              begin
+                                eq:=te_equal
+                              end;
+                          end;
+                      end;
+                    pointerdef :
+                      begin
+                        { nil and voidpointers are compatible with dyn. arrays }
+                        if is_dynamic_array(def_to) and
+                           ((fromtreetype=niln) or
+                            is_voidpointer(def_from)) then
+                         begin
+                           doconv:=tc_equal;
+                           eq:=te_convert_l1;
+                         end
+                        else
+                         if is_zero_based_array(def_to) and
+                            equal_defs(tpointerdef(def_from).pointertype.def,tarraydef(def_to).elementtype.def) then
+                          begin
+                            doconv:=tc_pointer_2_array;
+                            eq:=te_convert_l1;
+                          end;
+                      end;
+                    stringdef :
+                      begin
+                        { string to char array }
+                        if (not is_special_array(def_to)) and
+                           (is_char(tarraydef(def_to).elementtype.def)or
+                            is_widechar(tarraydef(def_to).elementtype.def)) then
+                         begin
+                           doconv:=tc_string_2_chararray;
+                           eq:=te_convert_l1;
+                         end;
+                      end;
+                    orddef:
+                      begin
+                        if is_chararray(def_to) and
+                           is_char(def_from) then
+                          begin
+                            doconv:=tc_char_2_chararray;
+                            eq:=te_convert_l2;
+                          end;
+                      end;
+                    recorddef :
+                      begin
+                        { tvarrec -> array of const }
+                         if is_array_of_const(def_to) and
+                            equal_defs(def_from,tarraydef(def_to).elementtype.def) then
+                          begin
+                            doconv:=tc_equal;
+                            eq:=te_convert_l1;
+                          end;
+                      end;
+                    variantdef :
+                      begin
+                         if is_dynamic_array(def_to) then
+                           begin
+                              doconv:=tc_variant_2_dynarray;
+                              eq:=te_convert_l1;
+                           end;
+                      end;
+                  end;
+                end;
+             end;
+
+           variantdef :
+             begin
+               if (cdo_allow_variant in cdoptions) then
+                 begin
+                   case def_from.deftype of
+                     enumdef :
+                       begin
+                         doconv:=tc_enum_2_variant;
+                         eq:=te_convert_l1;
+                       end;
+                     arraydef :
+                       begin
+                          if is_dynamic_array(def_from) then
+                            begin
+                               doconv:=tc_dynarray_2_variant;
+                               eq:=te_convert_l1;
+                            end;
+                       end;
+                     objectdef :
+                       begin
+                          if is_interface(def_from) then
+                            begin
+                               doconv:=tc_interface_2_variant;
+                               eq:=te_convert_l1;
+                            end;
+                       end;
+                   end;
+                 end;
+             end;
+
+           pointerdef :
+             begin
+               case def_from.deftype of
+                 stringdef :
+                   begin
+                     { string constant (which can be part of array constructor)
+                       to zero terminated string constant }
+                     if (fromtreetype in [arrayconstructorn,stringconstn]) and
+                        (is_pchar(def_to) or is_pwidechar(def_to)) then
+                      begin
+                        doconv:=tc_cstring_2_pchar;
+                        eq:=te_convert_l2;
+                      end
+                     else
+                      if cdo_explicit in cdoptions then
+                       begin
+                         { pchar(ansistring) }
+                         if is_pchar(def_to) and
+                            is_ansistring(def_from) then
+                          begin
+                            doconv:=tc_ansistring_2_pchar;
+                            eq:=te_convert_l1;
+                          end
+                         else
+                          { pwidechar(widestring) }
+                          if is_pwidechar(def_to) and
+                             is_widestring(def_from) then
+                           begin
+                             doconv:=tc_ansistring_2_pchar;
+                             eq:=te_convert_l1;
+                           end;
+                       end;
+                   end;
+                 orddef :
+                   begin
+                     { char constant to zero terminated string constant }
+                     if (fromtreetype=ordconstn) then
+                      begin
+                        if (is_char(def_from) or is_widechar(def_from)) and
+                           (is_pchar(def_to) or is_pwidechar(def_to)) then
+                         begin
+                           doconv:=tc_cchar_2_pchar;
+                           eq:=te_convert_l1;
+                         end
+                        else
+                         if (m_delphi in aktmodeswitches) and is_integer(def_from) then
+                          begin
+                            doconv:=tc_cord_2_pointer;
+                            eq:=te_convert_l2;
+                          end;
+                      end;
+                     { delphi compatible, allow explicit typecasts from
+                       ordinals to pointer.
+                       It is also used by the compiler internally for inc(pointer,ordinal) }
+                     if (eq=te_incompatible) and
+                        not is_void(def_from) and
+                        (
+                         (
+                          (m_delphi in aktmodeswitches) and
+                          (cdo_explicit in cdoptions)
+                         ) or
+                         (cdo_internal in cdoptions)
+                        ) then
+                      begin
+                        doconv:=tc_int_2_int;
+                        eq:=te_convert_l1;
+                      end;
+                   end;
+                 arraydef :
+                   begin
+                     { string constant (which can be part of array constructor)
+                       to zero terminated string constant }
+                     if (fromtreetype in [arrayconstructorn,stringconstn]) and
+                        (is_pchar(def_to) or is_pwidechar(def_to)) then
+                      begin
+                        doconv:=tc_cstring_2_pchar;
+                        eq:=te_convert_l2;
+                      end
+                     else
+                      { chararray to pointer }
+                      if (is_zero_based_array(def_from) or
+                          is_open_array(def_from)) and
+                          equal_defs(tarraydef(def_from).elementtype.def,tpointerdef(def_to).pointertype.def) then
+                        begin
+                          doconv:=tc_array_2_pointer;
+                          { don't prefer the pchar overload when a constant
+                            string was passed }
+                          if fromtreetype=stringconstn then
+                            eq:=te_convert_l2
+                          else
+                            eq:=te_convert_l1;
+                        end
+                     else
+                       { dynamic array to pointer, delphi only }
+                       if (m_delphi in aktmodeswitches) and
+                          is_dynamic_array(def_from) then
+                        begin
+                          eq:=te_equal;
+                        end;
+                   end;
+                 pointerdef :
+                   begin
+                     { check for far pointers }
+                     if (tpointerdef(def_from).is_far<>tpointerdef(def_to).is_far) then
+                       begin
+                         eq:=te_incompatible;
+                       end
+                     else
+                      { the types can be forward type, handle before normal type check !! }
+                      if assigned(def_to.typesym) and
+                         (tpointerdef(def_to).pointertype.def.deftype=forwarddef) then
+                       begin
+                         if (def_from.typesym=def_to.typesym) then
+                          eq:=te_equal
+                       end
+                     else
+                      { same types }
+                      if equal_defs(tpointerdef(def_from).pointertype.def,tpointerdef(def_to).pointertype.def) then
+                       begin
+                         eq:=te_equal
+                       end
+                     else
+                      { child class pointer can be assigned to anchestor pointers }
+                      if (
+                          (tpointerdef(def_from).pointertype.def.deftype=objectdef) and
+                          (tpointerdef(def_to).pointertype.def.deftype=objectdef) and
+                          tobjectdef(tpointerdef(def_from).pointertype.def).is_related(
+                            tobjectdef(tpointerdef(def_to).pointertype.def))
+                         ) then
+                       begin
+                         doconv:=tc_equal;
+                         eq:=te_convert_l1;
+                       end
+                     else
+                      { all pointers can be assigned to void-pointer }
+                      if is_void(tpointerdef(def_to).pointertype.def) then
+                       begin
+                         doconv:=tc_equal;
+                         { give pwidechar,pchar a penalty so it prefers
+                           conversion to ansistring }
+                         if is_pchar(def_from) or
+                            is_pwidechar(def_from) then
+                           eq:=te_convert_l2
+                         else
+                           eq:=te_convert_l1;
+                       end
+                     else
+                      { all pointers can be assigned from void-pointer }
+                      if is_void(tpointerdef(def_from).pointertype.def) or
+                      { all pointers can be assigned from void-pointer or formaldef pointer, check
+                        tw3777.pp if you change this }
+                        (tpointerdef(def_from).pointertype.def.deftype=formaldef) then
+                       begin
+                         doconv:=tc_equal;
+                         { give pwidechar a penalty so it prefers
+                           conversion to pchar }
+                         if is_pwidechar(def_to) then
+                           eq:=te_convert_l2
+                         else
+                           eq:=te_convert_l1;
+                       end;
+                   end;
+                 procvardef :
+                   begin
+                     { procedure variable can be assigned to an void pointer,
+                       this not allowed for methodpointers }
+                     if (is_void(tpointerdef(def_to).pointertype.def) or
+                         (m_mac_procvar in aktmodeswitches)) and
+                        tprocvardef(def_from).is_addressonly then
+                      begin
+                        doconv:=tc_equal;
+                        eq:=te_convert_l1;
+                      end;
+                   end;
+                 procdef :
+                   begin
+                     { procedure variable can be assigned to an void pointer,
+                       this not allowed for methodpointers }
+                     if (m_mac_procvar in aktmodeswitches) and
+                        tprocdef(def_from).is_addressonly then
+                      begin
+                        doconv:=tc_proc_2_procvar;
+                        eq:=te_convert_l2;
+                      end;
+                   end;
+                 classrefdef,
+                 objectdef :
+                   begin
+                     { class types and class reference type
+                       can be assigned to void pointers, but it is less
+                       preferred than assigning to a related objectdef }
+                     if (
+                         is_class_or_interface(def_from) or
+                         (def_from.deftype=classrefdef)
+                        ) and
+                        (tpointerdef(def_to).pointertype.def.deftype=orddef) and
+                        (torddef(tpointerdef(def_to).pointertype.def).typ=uvoid) then
+                       begin
+                         doconv:=tc_equal;
+                         eq:=te_convert_l2;
+                       end;
+                   end;
+               end;
+             end;
+
+           setdef :
+             begin
+               case def_from.deftype of
+                 setdef :
+                   begin
+                     if assigned(tsetdef(def_from).elementtype.def) and
+                        assigned(tsetdef(def_to).elementtype.def) then
+                      begin
+                        { sets with the same element base type are equal }
+                        if is_subequal(tsetdef(def_from).elementtype.def,tsetdef(def_to).elementtype.def) then
+                         eq:=te_equal;
+                      end
+                     else
+                      { empty set is compatible with everything }
+                      eq:=te_equal;
+                   end;
+                 arraydef :
+                   begin
+                     { automatic arrayconstructor -> set conversion }
+                     if is_array_constructor(def_from) then
+                      begin
+                        doconv:=tc_arrayconstructor_2_set;
+                        eq:=te_convert_l1;
+                      end;
+                   end;
+               end;
+             end;
+
+           procvardef :
+             begin
+               case def_from.deftype of
+                 procdef :
+                   begin
+                     { proc -> procvar }
+                     if (m_tp_procvar in aktmodeswitches) or
+                        (m_mac_procvar in aktmodeswitches) then
+                      begin
+                        subeq:=proc_to_procvar_equal(tprocdef(def_from),tprocvardef(def_to));
+                        if subeq>te_incompatible then
+                         begin
+                           doconv:=tc_proc_2_procvar;
+                           eq:=te_convert_l1;
+                         end;
+                      end;
+                   end;
+                 procvardef :
+                   begin
+                     { procvar -> procvar }
+                     eq:=proc_to_procvar_equal(tprocvardef(def_from),tprocvardef(def_to));
+                   end;
+                 pointerdef :
+                   begin
+                     { nil is compatible with procvars }
+                     if (fromtreetype=niln) then
+                      begin
+                        doconv:=tc_equal;
+                        eq:=te_convert_l1;
+                      end
+                     else
+                      { for example delphi allows the assignement from pointers }
+                      { to procedure variables                                  }
+                      if (m_pointer_2_procedure in aktmodeswitches) and
+                         is_void(tpointerdef(def_from).pointertype.def) and
+                         tprocvardef(def_to).is_addressonly then
+                       begin
+                         doconv:=tc_equal;
+                         eq:=te_convert_l1;
+                       end;
+                   end;
+               end;
+             end;
+
+           objectdef :
+             begin
+               { object pascal objects }
+               if (def_from.deftype=objectdef) and
+                  (tobjectdef(def_from).is_related(tobjectdef(def_to))) then
+                begin
+                  doconv:=tc_equal;
+                  eq:=te_convert_l1;
+                end
+               else
+               { Class/interface specific }
+                if is_class_or_interface(def_to) then
+                 begin
+                   { void pointer also for delphi mode }
+                   if (m_delphi in aktmodeswitches) and
+                      is_voidpointer(def_from) then
+                    begin
+                      doconv:=tc_equal;
+                      { prefer pointer-pointer assignments }
+                      eq:=te_convert_l2;
+                    end
+                   else
+                   { nil is compatible with class instances and interfaces }
+                    if (fromtreetype=niln) then
+                     begin
+                       doconv:=tc_equal;
+                       eq:=te_convert_l1;
+                     end
+                   { classes can be assigned to interfaces }
+                   else if is_interface(def_to) and
+                     is_class(def_from) and
+                     assigned(tobjectdef(def_from).implementedinterfaces) then
+                     begin
+                        { we've to search in parent classes as well }
+                        hd3:=tobjectdef(def_from);
+                        while assigned(hd3) do
+                          begin
+                             if hd3.implementedinterfaces.searchintf(def_to)<>-1 then
+                               begin
+                                  doconv:=tc_class_2_intf;
+                                  { don't prefer this over objectdef->objectdef }
+                                  eq:=te_convert_l2;
+                                  break;
+                               end;
+                             hd3:=hd3.childof;
+                          end;
+                     end
+                   { Interface 2 GUID handling }
+                   else if (def_to=tdef(rec_tguid)) and
+                           (fromtreetype=typen) and
+                           is_interface(def_from) and
+                           assigned(tobjectdef(def_from).iidguid) then
+                     begin
+                       eq:=te_convert_l1;
+                       doconv:=tc_equal;
+                     end
+                   else if (def_from.deftype=variantdef) and is_interface(def_to) then
+                     begin
+                       doconv:=tc_variant_2_interface;
+                       eq:=te_convert_l2;
+                     end
+                   { ugly, but delphi allows it }
+                   else if (eq=te_incompatible) and
+                     (def_from.deftype=orddef) and
+                     (m_delphi in aktmodeswitches) and
+                     (cdo_explicit in cdoptions) then
+                     begin
+                       doconv:=tc_int_2_int;
+                       eq:=te_convert_l1;
+                     end;
+                 end;
+             end;
+
+           classrefdef :
+             begin
+               { similar to pointerdef wrt forwards }
+               if assigned(def_to.typesym) and
+                  (tclassrefdef(def_to).pointertype.def.deftype=forwarddef) then
+                 begin
+                   if (def_from.typesym=def_to.typesym) then
+                    eq:=te_equal;
+                 end
+               else
+                { class reference types }
+                if (def_from.deftype=classrefdef) then
+                 begin
+                   if equal_defs(tclassrefdef(def_from).pointertype.def,tclassrefdef(def_to).pointertype.def) then
+                    begin
+                      eq:=te_equal;
+                    end
+                   else
+                    begin
+                      doconv:=tc_equal;
+                      if (cdo_explicit in cdoptions) or
+                         tobjectdef(tclassrefdef(def_from).pointertype.def).is_related(
+                           tobjectdef(tclassrefdef(def_to).pointertype.def)) then
+                        eq:=te_convert_l1;
+                    end;
+                 end
+               else
+                { nil is compatible with class references }
+                if (fromtreetype=niln) then
+                 begin
+                   doconv:=tc_equal;
+                   eq:=te_convert_l1;
+                 end;
+             end;
+
+           filedef :
+             begin
+               { typed files are all equal to the abstract file type
+               name TYPEDFILE in system.pp in is_equal in types.pas
+               the problem is that it sholud be also compatible to FILE
+               but this would leed to a problem for ASSIGN RESET and REWRITE
+               when trying to find the good overloaded function !!
+               so all file function are doubled in system.pp
+               this is not very beautiful !!}
+               if (def_from.deftype=filedef) then
+                begin
+                  if (tfiledef(def_from).filetyp=tfiledef(def_to).filetyp) then
+                   begin
+                     if
+                        (
+                         (tfiledef(def_from).typedfiletype.def=nil) and
+                         (tfiledef(def_to).typedfiletype.def=nil)
+                        ) or
+                        (
+                         (tfiledef(def_from).typedfiletype.def<>nil) and
+                         (tfiledef(def_to).typedfiletype.def<>nil) and
+                         equal_defs(tfiledef(def_from).typedfiletype.def,tfiledef(def_to).typedfiletype.def)
+                        ) or
+                        (
+                         (tfiledef(def_from).filetyp = ft_typed) and
+                         (tfiledef(def_to).filetyp = ft_typed) and
+                         (
+                          (tfiledef(def_from).typedfiletype.def = tdef(voidtype.def)) or
+                          (tfiledef(def_to).typedfiletype.def = tdef(voidtype.def))
+                         )
+                        ) then
+                      begin
+                        eq:=te_equal;
+                      end;
+                   end
+                  else
+                   if ((tfiledef(def_from).filetyp = ft_untyped) and
+                       (tfiledef(def_to).filetyp = ft_typed)) or
+                      ((tfiledef(def_from).filetyp = ft_typed) and
+                       (tfiledef(def_to).filetyp = ft_untyped)) then
+                    begin
+                      doconv:=tc_equal;
+                      eq:=te_convert_l1;
+                    end;
+                end;
+             end;
+
+           recorddef :
+             begin
+               { interface -> guid }
+               if is_interface(def_from) and
+                  (def_to=rec_tguid) then
+                begin
+                  doconv:=tc_intf_2_guid;
+                  eq:=te_convert_l1;
+                end;
+             end;
+
+           formaldef :
+             begin
+               doconv:=tc_equal;
+               if (def_from.deftype=formaldef) then
+                 eq:=te_equal
+               else
+                { Just about everything can be converted to a formaldef...}
+                if not (def_from.deftype in [abstractdef,errordef]) then
+                  eq:=te_convert_l1;
+             end;
+        end;
+
+        { if we didn't find an appropriate type conversion yet
+          then we search also the := operator }
+        if (eq=te_incompatible) and
+           (
+            { Check for variants? }
+            (
+             (cdo_allow_variant in cdoptions) and
+             ((def_from.deftype=variantdef) or (def_to.deftype=variantdef))
+            ) or
+            { Check for operators? }
+            (
+             (cdo_check_operator in cdoptions) and
+             ((def_from.deftype in [objectdef,recorddef,arraydef,stringdef,variantdef]) or
+              (def_to.deftype in [objectdef,recorddef,arraydef,stringdef,variantdef]))
+            )
+           ) then
+          begin
+            operatorpd:=search_assignment_operator(def_from,def_to);
+            if assigned(operatorpd) then
+             eq:=te_convert_operator;
+          end;
+
+        { update convtype for te_equal when it is not yet set }
+        if (eq=te_equal) and
+           (doconv=tc_not_possible) then
+          doconv:=tc_equal;
+
+        compare_defs_ext:=eq;
+      end;
+
+
+    function equal_defs(def_from,def_to:tdef):boolean;
+      var
+        convtyp : tconverttype;
+        pd : tprocdef;
+      begin
+        { Compare defs with nothingn and no explicit typecasts and
+          searching for overloaded operators is not needed }
+        equal_defs:=(compare_defs_ext(def_from,def_to,nothingn,convtyp,pd,[])>=te_equal);
+      end;
+
+
+    function compare_defs(def_from,def_to:tdef;fromtreetype:tnodetype):tequaltype;
+      var
+        doconv : tconverttype;
+        pd : tprocdef;
+      begin
+        compare_defs:=compare_defs_ext(def_from,def_to,fromtreetype,doconv,pd,[cdo_check_operator,cdo_allow_variant]);
+      end;
+
+
+    function is_subequal(def1, def2: tdef): boolean;
+      var
+         basedef1,basedef2 : tenumdef;
+
+      Begin
+        is_subequal := false;
+        if assigned(def1) and assigned(def2) then
+         Begin
+           if (def1.deftype = orddef) and (def2.deftype = orddef) then
+            Begin
+              { see p.47 of Turbo Pascal 7.01 manual for the separation of types }
+              { range checking for case statements is done with testrange        }
+              case torddef(def1).typ of
+                u8bit,u16bit,u32bit,u64bit,
+                s8bit,s16bit,s32bit,s64bit :
+                  is_subequal:=(torddef(def2).typ in [s64bit,u64bit,s32bit,u32bit,u8bit,s8bit,s16bit,u16bit]);
+                bool8bit,bool16bit,bool32bit :
+                  is_subequal:=(torddef(def2).typ in [bool8bit,bool16bit,bool32bit]);
+                uchar :
+                  is_subequal:=(torddef(def2).typ=uchar);
+                uwidechar :
+                  is_subequal:=(torddef(def2).typ=uwidechar);
+              end;
+            end
+           else
+            Begin
+              { Check if both basedefs are equal }
+              if (def1.deftype=enumdef) and (def2.deftype=enumdef) then
+                Begin
+                   { get both basedefs }
+                   basedef1:=tenumdef(def1);
+                   while assigned(basedef1.basedef) do
+                     basedef1:=basedef1.basedef;
+                   basedef2:=tenumdef(def2);
+                   while assigned(basedef2.basedef) do
+                     basedef2:=basedef2.basedef;
+                   is_subequal:=(basedef1=basedef2);
+                end;
+            end;
+         end;
+      end;
+
+
+    function compare_paras(para1,para2 : tlist; acp : tcompare_paras_type; cpoptions: tcompare_paras_options):tequaltype;
+      var
+        currpara1,
+        currpara2 : tparavarsym;
+        eq,lowesteq : tequaltype;
+        hpd       : tprocdef;
+        convtype  : tconverttype;
+        cdoptions : tcompare_defs_options;
+        i1,i2     : byte;
+      begin
+         compare_paras:=te_incompatible;
+         cdoptions:=[cdo_check_operator,cdo_allow_variant];
+         { we need to parse the list from left-right so the
+           not-default parameters are checked first }
+         lowesteq:=high(tequaltype);
+         i1:=0;
+         i2:=0;
+         if cpo_ignorehidden in cpoptions then
+           begin
+             while (i1<para1.count) and
+                   (vo_is_hidden_para in tparavarsym(para1[i1]).varoptions) do
+               inc(i1);
+             while (i2<para2.count) and
+                   (vo_is_hidden_para in tparavarsym(para2[i2]).varoptions) do
+               inc(i2);
+           end;
+         while (i1<para1.count) and (i2<para2.count) do
+           begin
+             eq:=te_incompatible;
+
+             currpara1:=tparavarsym(para1[i1]);
+             currpara2:=tparavarsym(para2[i2]);
+
+             { Unique types must match exact }
+             if ((df_unique in currpara1.vartype.def.defoptions) or (df_unique in currpara2.vartype.def.defoptions)) and
+                (currpara1.vartype.def<>currpara2.vartype.def) then
+               exit;
+
+             { Handle hidden parameters separately, because self is
+               defined as voidpointer for methodpointers }
+             if (vo_is_hidden_para in currpara1.varoptions) or
+                (vo_is_hidden_para in currpara2.varoptions) then
+              begin
+                { both must be hidden }
+                if (vo_is_hidden_para in currpara1.varoptions)<>(vo_is_hidden_para in currpara2.varoptions) then
+                  exit;
+                eq:=te_equal;
+                if not(vo_is_self in currpara1.varoptions) and
+                   not(vo_is_self in currpara2.varoptions) then
+                 begin
+                   if (currpara1.varspez<>currpara2.varspez) then
+                    exit;
+                   eq:=compare_defs_ext(currpara1.vartype.def,currpara2.vartype.def,nothingn,
+                                        convtype,hpd,cdoptions);
+                 end;
+              end
+             else
+              begin
+                case acp of
+                  cp_value_equal_const :
+                    begin
+                       if (
+                           (currpara1.varspez<>currpara2.varspez) and
+                           ((currpara1.varspez in [vs_var,vs_out]) or
+                            (currpara2.varspez in [vs_var,vs_out]))
+                          ) then
+                         exit;
+                       eq:=compare_defs_ext(currpara1.vartype.def,currpara2.vartype.def,nothingn,
+                                            convtype,hpd,cdoptions);
+                    end;
+                  cp_all :
+                    begin
+                       if (currpara1.varspez<>currpara2.varspez) then
+                         exit;
+                       eq:=compare_defs_ext(currpara1.vartype.def,currpara2.vartype.def,nothingn,
+                                            convtype,hpd,cdoptions);
+                    end;
+                  cp_procvar :
+                    begin
+                       if (currpara1.varspez<>currpara2.varspez) then
+                         exit;
+                       eq:=compare_defs_ext(currpara1.vartype.def,currpara2.vartype.def,nothingn,
+                                            convtype,hpd,cdoptions);
+                       { Parameters must be at least equal otherwise the are incompatible }
+                       if (eq<te_equal) then
+                         eq:=te_incompatible;
+                    end;
+                  else
+                    eq:=compare_defs_ext(currpara1.vartype.def,currpara2.vartype.def,nothingn,
+                                         convtype,hpd,cdoptions);
+                 end;
+               end;
+              { check type }
+              if eq=te_incompatible then
+                exit;
+              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;
+              inc(i1);
+              inc(i2);
+              if cpo_ignorehidden in cpoptions then
+                begin
+                  while (i1<para1.count) and
+                        (vo_is_hidden_para in tparavarsym(para1[i1]).varoptions) do
+                    inc(i1);
+                  while (i2<para2.count) and
+                        (vo_is_hidden_para in tparavarsym(para2[i2]).varoptions) do
+                    inc(i2);
+                end;
+           end;
+         { when both lists are empty then the parameters are equal. Also
+           when one list is empty and the other has a parameter with default
+           value assigned then the parameters are also equal }
+         if ((i1>=para1.count) and (i2>=para2.count)) or
+            ((cpo_allowdefaults in cpoptions) and
+             (((i1<para1.count) and assigned(tparavarsym(para1[i1]).defaultconstsym)) or
+              ((i2<para2.count) and assigned(tparavarsym(para2[i2]).defaultconstsym)))) then
+           compare_paras:=lowesteq;
+      end;
+
+
+    function proc_to_procvar_equal(def1:tabstractprocdef;def2:tprocvardef):tequaltype;
+      var
+        eq : tequaltype;
+        po_comp : tprocoptions;
+      begin
+         proc_to_procvar_equal:=te_incompatible;
+         if not(assigned(def1)) or not(assigned(def2)) then
+           exit;
+         { check for method pointer }
+         if (def1.is_methodpointer xor def2.is_methodpointer) or
+            (def1.is_addressonly xor def2.is_addressonly) then
+           exit;
+         { check return value and options, methodpointer is already checked }
+         po_comp:=[po_staticmethod,po_interrupt,
+                   po_iocheck,po_varargs];
+         if (m_delphi in aktmodeswitches) then
+           exclude(po_comp,po_varargs);
+         if (def1.proccalloption=def2.proccalloption) and
+            ((po_comp * def1.procoptions)= (po_comp * def2.procoptions)) and
+            equal_defs(def1.rettype.def,def2.rettype.def) then
+          begin
+            { return equal type based on the parameters, but a proc->procvar
+              is never exact, so map an exact match of the parameters to
+              te_equal }
+            eq:=compare_paras(def1.paras,def2.paras,cp_procvar,[]);
+            if eq=te_exact then
+             eq:=te_equal;
+            proc_to_procvar_equal:=eq;
+          end;
+      end;
+
+end.

Vissa filer visades inte eftersom för många filer har ändrats