+ unit handling rewrite branch created

git-svn-id: branches/unitrw@133 -

.gitattributes

@@ -1 +1,518 @@
 * text=auto !eol
+compiler/COPYING -text
+compiler/MPWMake -text
+compiler/Makefile -text
+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/armreg.dat -text
+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/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/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/gdb.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/ag386int.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/n386cnv.pas svneol=native#text/plain
+compiler/i386/n386con.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/m68kreg.dat -text
+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/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/mipsreg.dat -text
+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 -text
+compiler/msg/errord.msg -text
+compiler/msg/errore.msg -text
+compiler/msg/errores.msg -text
+compiler/msg/errorf.msg -text
+compiler/msg/errorhe.msg -text
+compiler/msg/errorn.msg -text
+compiler/msg/errorpl.msg -text
+compiler/msg/errorpli.msg -text
+compiler/msg/errorr.msg -text
+compiler/msg/errorrw.msg -text
+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/options.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/ppcins.dat -text
+compiler/powerpc/ppcreg.dat -text
+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/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/spreg.dat -text
+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_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_win32.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_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_win32.pas svneol=native#text/plain
+compiler/tgobj.pas svneol=native#text/plain
+compiler/tokens.pas svneol=native#text/plain
+compiler/utils/Makefile -text
+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 -text
+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/gppc386.pp svneol=native#text/plain
+compiler/utils/mk68kreg.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/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/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/x86ins.dat -text
+compiler/x86/x86reg.dat -text
+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/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

.gitignore

@@ -0,0 +1,5 @@
+compiler/*.bak
+compiler/*.exe
+compiler/i386/*.bak
+compiler/utils/*.exe
+compiler/x86/*.bak

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.

compiler/Makefile

@@ -0,0 +1,2682 @@
+#
+# Don't edit, this file is generated by FPCMake Version 2.0.0 [2005/05/05]
+#
+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 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 arm-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
+ifdef ALPHA
+PPC_TARGET=alpha
+endif
+ifdef POWERPC
+PPC_TARGET=powerpc
+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),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),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),arm-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),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),arm-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),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),arm-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),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),arm-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),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),arm-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),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),arm-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),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),arm-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:=-O1
+else
+FPCCPUOPT:=
+endif
+endif
+override FPCOPT+=-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),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),arm-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,$(CYCLETARGETS)):
+	-$(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,$(CYCLETARGETS)) $(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

compiler/Makefile.fpc

@@ -0,0 +1,554 @@
+#
+#   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
+
+# Allow ALPHA, POWERPC, M68K, I386 defines for target cpu
+ifdef ALPHA
+PPC_TARGET=alpha
+endif
+ifdef POWERPC
+PPC_TARGET=powerpc
+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),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,$(CYCLETARGETS)):
+        -$(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,$(CYCLETARGETS)) $(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

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

compiler/aasmbase.pas

@@ -0,0 +1,940 @@
+{
+    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);
+
+       TAsmRelocationType = (RELOC_ABSOLUTE,RELOC_RELATIVE,RELOC_RVA);
+
+       TAsmSectionType=(sec_none,
+         sec_code,sec_data,sec_rodata,sec_bss,
+         sec_common, { used for executable creation }
+         sec_custom, { custom section, no prefix }
+         { 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
+       );
+
+       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;
+
+       TAsmLabel = class(TAsmSymbol)
+         { this is set by the tai_label.Init }
+         is_set,
+         { is the label only there for getting an address (e.g. for i/o }
+         { checks -> true) or is it a jump target (false)               }
+         is_addr : boolean;
+         labelnr : longint;
+         constructor create(nr:longint);
+         constructor createdata(const modulename:string;nr:longint);
+         constructor createaddr(nr:longint);
+         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{$ifndef VER1_9_4}[80]{$endif};
+         FCurrSec   : TAsmSection;
+         FSects     : TDictionary;
+         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 allocstabs(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 writestabs(offset:aint;p:pchar;nidx,nother,line:longint;reloc:boolean);virtual;abstract;
+         procedure writesymstabs(offset:aint;p:pchar;ps:tasmsymbol;nidx,nother,line:longint;reloc:boolean);virtual;abstract;
+         procedure beforealloc;virtual;
+         procedure beforewrite;virtual;
+         procedure afteralloc;virtual;
+         procedure afterwrite;virtual;
+         procedure resetsections;
+         procedure fixuprelocs;
+         property Name:string{$ifndef VER1_9_4}[80]{$endif} read FName;
+         property CurrSec:TAsmSection read FCurrSec;
+         property Symbols:TindexArray read FSymbols;
+         property Sects:TDictionary read FSects;
+       end;
+       TAsmObjectDataClass = class of TAsmObjectData;
+
+       tasmsymbolidxarr = array[0..($7fffffff div sizeof(pointer))-1] of tasmsymbol;
+       pasmsymbolidxarr = ^tasmsymbolidxarr;
+
+       TAsmLibraryData = class(TLinkedListItem)
+       private
+         nextaltnr   : longint;
+         nextlabelnr : 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;is_addr,is_data:boolean) : tasmlabel;
+         {# create a new assembler label }
+         procedure getlabel(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 getlabelnr(var l : longint);
+         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;
+
+
+    var
+      objectlibrary : tasmlibrarydata;
+
+
+implementation
+
+    uses
+      strings,
+      verbose;
+
+    const
+      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 codesegment }
+        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.create(nr:longint);
+      begin;
+        labelnr:=nr;
+        inherited create(target_asm.labelprefix+tostr(labelnr),AB_LOCAL,AT_FUNCTION);
+        is_set:=false;
+        is_addr := false;
+      end;
+
+
+    constructor tasmlabel.createdata(const modulename:string;nr:longint);
+      begin;
+        labelnr:=nr;
+        inherited create('_$'+modulename+'$_L'+tostr(labelnr),AB_GLOBAL,AT_DATA);
+        is_set:=false;
+        is_addr := false;
+        { write it always }
+        increfs;
+      end;
+
+
+    constructor tasmlabel.createaddr(nr:longint);
+      begin;
+        self.create(nr);
+        is_addr := true;
+      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 }
+        FSects:=tdictionary.create;
+        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
+        FSects.free;
+        FSymbols.free;
+      end;
+
+
+    function TAsmObjectData.sectionname(atype:tasmsectiontype;const aname:string):string;
+      const
+        secnames : array[tasmsectiontype] of string[12] = ('',
+          'code','data','rodata','bss',
+          'common',
+          'note',
+          'stab','stabstr',
+          'idata2','idata4','idata5','idata6','idata7','edata',
+          'eh_frame',
+          'debug_frame'
+        );
+      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(FSects.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);
+            FSects.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.allocstabs(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
+        FSects.foreach(@section_reset,nil);
+      end;
+
+
+    procedure TAsmObjectData.fixuprelocs;
+      begin
+        FSects.foreach(@section_fixuprelocs,nil);
+      end;
+
+
+{****************************************************************************
+                                TAsmLibraryData
+****************************************************************************}
+
+    constructor TAsmLibraryData.create(const n:string);
+      begin
+        inherited create;
+        realname:=n;
+        name:=upper(n);
+        { symbols }
+        symbolsearch:=tdictionary.create;
+        symbolsearch.usehash;
+        { labels }
+        nextaltnr:=1;
+        nextlabelnr:=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;is_addr,is_data:boolean) : tasmlabel;
+      var
+        hp : tasmlabel;
+      begin
+        if is_addr then
+         hp:=tasmlabel.createaddr(nr)
+        else if is_data then
+         hp:=tasmlabel.createdata(name,nr)
+        else
+         hp:=tasmlabel.create(nr);
+        symbolsearch.insert(hp);
+        newasmlabel:=hp;
+      end;
+
+
+    procedure TAsmLibraryData.getlabel(var l : tasmlabel);
+      begin
+        l:=tasmlabel.create(nextlabelnr);
+        inc(nextlabelnr);
+        symbolsearch.insert(l);
+      end;
+
+
+    procedure TAsmLibraryData.getdatalabel(var l : tasmlabel);
+      begin
+        l:=tasmlabel.createdata(name,nextlabelnr);
+        inc(nextlabelnr);
+        symbolsearch.insert(l);
+      end;
+
+
+    procedure TAsmLibraryData.getaddrlabel(var l : tasmlabel);
+      begin
+        l:=tasmlabel.createaddr(nextlabelnr);
+        inc(nextlabelnr);
+        symbolsearch.insert(l);
+      end;
+
+
+    procedure TAsmLibraryData.getlabelnr(var l : longint);
+      begin
+         l:=nextlabelnr;
+         inc(nextlabelnr);
+      end;
+
+
+end.

compiler/aasmtai.pas

@@ -0,0 +1,2248 @@
+{
+    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_direct,
+          ait_string,
+          ait_instruction,
+          ait_datablock,
+          ait_symbol,
+          ait_symbol_end, { needed to calc the size of a symbol }
+          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,
+{$ifdef GDB}
+          ait_stabn,
+          ait_stabs,
+          ait_force_line,
+          ait_stab_function_name,
+{$endif GDB}
+{$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,
+          { special symbol for darwin pic code }
+          ait_non_lazy_symbol_pointer
+          );
+
+    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',
+          'direct',
+          'string',
+          'instruction',
+          'datablock',
+          'symbol',
+          'symbol_end',
+          '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',
+{$ifdef GDB}
+          'stabn',
+          'stabs',
+          'force_line',
+          'stab_funcname',
+{$endif GDB}
+{$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',
+          'non_lazy_symbol_pointer'
+          );
+
+    type
+      { Types of operand }
+      toptype=(top_none,top_reg,top_ref,top_const,top_bool,top_local,
+       { ARM only }
+       top_regset,
+       top_shifterop,
+       { m68k only }
+       top_reglist);
+
+      { 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
+{$ifdef GDB}
+                   ,ait_stabs, ait_stabn, ait_stab_function_name, ait_force_line
+{$endif GDB}
+                   ,ait_regalloc, ait_tempalloc, ait_symbol_end];
+
+{ 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,
+{$ifdef GDB}
+                  ait_stabn,ait_stabs,ait_stab_function_name,
+{$endif GDB}
+                  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,
+                  ait_non_lazy_symbol_pointer
+                  ];
+
+
+    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);
+          constructor Create_length_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;
+
+       { 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;
+
+       { Directly output data to final assembler file }
+       tai_direct = class(tailineinfo)
+          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 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;
+
+       { 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;
+       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;
+
+
+    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;
+
+      { default lists }
+      datasegment,codesegment,bsssegment,
+      debuglist,withdebuglist,consts,
+      importssection,exportssection,
+      resourcesection,rttilist,
+      dwarflist,
+      { data used by pic code }
+      picdata,
+      resourcestringlist         : 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);
+
+    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) and
+                not(cs_debuginfo in aktmoduleswitches);
+      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;
+
+
+{****************************************************************************
+                             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_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);
+
+       begin
+          inherited Create;
+          typ:=ait_string;
+          str:=_str;
+          len:=strlen(_str);
+       end;
+
+    constructor tai_string.Create_length_pchar(_str : pchar;length : longint);
+
+       begin
+          inherited Create;
+          typ:=ait_string;
+          str:=_str;
+          len:=length;
+       end;
+
+    destructor tai_string.destroy;
+
+      begin
+         { you can have #0 inside the strings so }
+         if str<>nil then
+           freemem(str,len+1);
+         inherited Destroy;
+      end;
+
+
+    constructor tai_string.ppuload(t:taitype;ppufile:tcompilerppufile);
+      begin
+        inherited ppuload(t,ppufile);
+        len:=ppufile.getlongint;
+        getmem(str,len+1);
+        ppufile.getdata(str^,len);
+        str[len]:=#0;
+      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+1);
+        move(str^,tai_string(p).str^,len+1);
+        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_DIRECT
+ ****************************************************************************}
+
+     constructor tai_direct.Create(_str : pchar);
+
+       begin
+          inherited Create;
+          typ:=ait_direct;
+          str:=_str;
+       end;
+
+    destructor tai_direct.destroy;
+
+      begin
+         strdispose(str);
+         inherited Destroy;
+      end;
+
+    constructor tai_direct.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_direct.ppuwrite(ppufile:tcompilerppufile);
+      var
+        len : longint;
+      begin
+        inherited ppuwrite(ppufile);
+        len:=strlen(str);
+        ppufile.putlongint(len);
+        ppufile.putdata(str^,len);
+      end;
+
+
+    function tai_direct.getcopy : tlinkedlistitem;
+      var
+        p : tlinkedlistitem;
+      begin
+        p:=inherited getcopy;
+        getmem(tai_direct(p).str,strlen(str)+1);
+        move(str^,tai_direct(p).str^,strlen(str)+1);
+        getcopy:=p;
+      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_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);
+      end;
+
+
+    function tai_cpu_abstract.spilling_get_operation_type(opnr: longint): topertype;
+      begin
+        internalerror(200404091);
+      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.

compiler/aggas.pas

@@ -0,0 +1,985 @@
+{
+    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;
+{$ifdef GDB}
+        procedure WriteFileLineInfo(var fileinfo : tfileposinfo);
+        procedure WriteFileEndInfo;
+{$endif}
+        procedure WriteInstruction(hp: tai);  virtual; abstract;
+      public
+        procedure WriteTree(p:TAAsmoutput);override;
+        procedure WriteAsmList;override;
+      end;
+
+    const
+      regname_count=45;
+      regname_count_bsstart=32;   { Largest power of 2 out of regname_count. }
+
+
+implementation
+
+    uses
+      cutils,globtype,systems,
+      fmodule,finput,verbose,
+      itcpugas
+{$ifdef GDB}
+{$IFDEF USE_SYSUTILS}
+{$ELSE USE_SYSUTILS}
+      ,strings
+{$ENDIF USE_SYSUTILS}
+      ,gdb
+{$endif GDB}
+      ;
+
+    const
+      line_length = 70;
+
+var
+{$ifdef GDB}
+      n_line       : byte;     { different types of source lines }
+      linecount,
+      includecount : longint;
+      funcname     : pchar;
+      stabslastfileinfo : tfileposinfo;
+{$endif}
+      lasTSecType  : 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                              }
+{****************************************************************************}
+
+{$ifdef GDB}
+      procedure TGNUAssembler.WriteFileLineInfo(var fileinfo : tfileposinfo);
+        var
+          curr_n : byte;
+        begin
+          if not ((cs_debuginfo in aktmoduleswitches) or
+             (cs_gdb_lineinfo in aktglobalswitches)) then
+           exit;
+        { file changed ? (must be before line info) }
+          if (fileinfo.fileindex<>0) and
+             (stabslastfileinfo.fileindex<>fileinfo.fileindex) then
+           begin
+             infile:=current_module.sourcefiles.get_file(fileinfo.fileindex);
+             if assigned(infile) then
+              begin
+                if includecount=0 then
+                 curr_n:=n_sourcefile
+                else
+                 curr_n:=n_includefile;
+                if (infile.path^<>'') then
+                 begin
+                   AsmWriteLn(#9'.stabs "'+BsToSlash(FixPath(infile.path^,false))+'",'+
+                     tostr(curr_n)+',0,0,'+target_asm.labelprefix+'text'+ToStr(IncludeCount));
+                 end;
+                AsmWriteLn(#9'.stabs "'+FixFileName(infile.name^)+'",'+
+                  tostr(curr_n)+',0,0,'+target_asm.labelprefix+'text'+ToStr(IncludeCount));
+                AsmWriteLn(target_asm.labelprefix+'text'+ToStr(IncludeCount)+':');
+                inc(includecount);
+                { force new line info }
+                stabslastfileinfo.line:=-1;
+              end;
+           end;
+        { line changed ? }
+          if (stabslastfileinfo.line<>fileinfo.line) and (fileinfo.line<>0) then
+           begin
+             if (n_line=n_textline) and assigned(funcname) and
+                (target_info.use_function_relative_addresses) then
+              begin
+                AsmWriteLn(target_asm.labelprefix+'l'+tostr(linecount)+':');
+                AsmWrite(#9'.stabn '+tostr(n_line)+',0,'+tostr(fileinfo.line)+','+
+                           target_asm.labelprefix+'l'+tostr(linecount)+' - ');
+                AsmWritePChar(FuncName);
+                AsmLn;
+                inc(linecount);
+              end
+             else
+              AsmWriteLn(#9'.stabd'#9+tostr(n_line)+',0,'+tostr(fileinfo.line));
+           end;
+          stabslastfileinfo:=fileinfo;
+        end;
+
+      procedure TGNUAssembler.WriteFileEndInfo;
+
+        begin
+          if not ((cs_debuginfo in aktmoduleswitches) or
+             (cs_gdb_lineinfo in aktglobalswitches)) then
+           exit;
+          WriteSection(sec_code,'');
+          AsmWriteLn(#9'.stabs "",'+tostr(n_sourcefile)+',0,0,'+target_asm.labelprefix+'etext');
+          AsmWriteLn(target_asm.labelprefix+'etext:');
+        end;
+
+{$endif GDB}
+
+
+    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',
+          'common',
+          '.note',
+          '.stab','.stabstr',
+          '.idata$2','.idata$4','.idata$5','.idata$6','.idata$7','.edata',
+          '.eh_frame',
+          '.debug_frame'
+        );
+      begin
+        if (target_info.system = system_powerpc_darwin) and
+           (atype = sec_bss) then
+          atype := sec_code;
+        if use_smartlink_section and
+           (atype<>sec_bss) and
+           (aname<>'') then
+          result:='.gnu.linkonce'+copy(secnames[atype],1,2)+'.'+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_powerpc_darwin, system_i386_OS2, system_i386_EMX: ;
+         else
+          AsmWrite('.section ');
+        end;
+        s:=sectionname(atype,aname);
+        AsmWrite(s);
+        if copy(s,1,4)='.gnu' then
+          begin
+            case atype of
+              sec_rodata,
+              sec_data :
+                AsmWrite(',""');
+              sec_code :
+                AsmWrite(',"x"');
+            end;
+          end;
+        AsmLn;
+{$ifdef GDB}
+        { this is needed for line info in data }
+        funcname:=nil;
+        case atype of
+          sec_code :
+            n_line:=n_textline;
+          sec_rodata,
+          sec_data :
+            n_line:=n_dataline;
+          sec_bss  :
+            n_line:=n_bssline;
+          else
+            n_line:=n_dataline;
+        end;
+{$endif GDB}
+        LasTSecType:=atype;
+      end;
+
+
+    procedure TGNUAssembler.WriteTree(p:TAAsmoutput);
+    const
+      regallocstr : array[tregalloctype] of string[10]=(' allocated',' released',' sync',' resized');
+      tempallocstr : array[boolean] of string[10]=(' released',' allocated');
+    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;
+    begin
+      if not assigned(p) then
+       exit;
+      last_align := 2;
+      InlineLevel:=0;
+      { lineinfo is only needed for codesegment (PFV) }
+      do_line:=(cs_asm_source in aktglobalswitches) or
+               ((cs_lineinfo in aktmoduleswitches)
+                 and (p=codesegment));
+      hp:=tai(p.first);
+      while assigned(hp) do
+       begin
+         if not(hp.typ in SkipLineInfo) then
+          begin
+            hp1 := hp as tailineinfo;
+            aktfilepos:=hp1.fileinfo;
+{$ifdef GDB}
+             { write stabs }
+             if (cs_debuginfo in aktmoduleswitches) or
+                (cs_gdb_lineinfo in aktglobalswitches) then
+               WriteFileLineInfo(hp1.fileinfo);
+{$endif GDB}
+             { 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;
+                   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
+                begin
+                  WriteSection(tai_section(hp).sectype,tai_section(hp).name^);
+{$ifdef GDB}
+                  lastfileinfo.line:=-1;
+{$endif GDB}
+                end
+               else
+                begin
+{$ifdef EXTDEBUG}
+                  AsmWrite(target_asm.comment);
+                  AsmWriteln(' sec_none');
+{$endif EXTDEBUG}
+                end;
+             end;
+
+           ait_datablock :
+             begin
+               if tai_datablock(hp).is_global then
+                AsmWrite(#9'.comm'#9)
+               else
+                AsmWrite(#9'.lcomm'#9);
+               AsmWrite(tai_datablock(hp).sym.name);
+               AsmWrite(','+tostr(tai_datablock(hp).size));
+               if (target_info.system = system_powerpc_darwin) and
+                  not(tai_datablock(hp).is_global) then
+                 AsmWrite(','+tostr(last_align));
+               AsmWriteln('');
+             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(LasTSecType 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_direct :
+             begin
+               AsmWritePChar(tai_direct(hp).str);
+               AsmLn;
+{$IfDef GDB}
+               if strpos(tai_direct(hp).str,'.data')<>nil then
+                 n_line:=n_dataline
+               else if strpos(tai_direct(hp).str,'.text')<>nil then
+                 n_line:=n_textline
+               else if strpos(tai_direct(hp).str,'.bss')<>nil then
+                 n_line:=n_bssline;
+{$endif GDB}
+             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 in [system_i386_linux,system_i386_beos,
+                                         system_powerpc_linux,system_m68k_linux,
+                                         system_sparc_linux,system_alpha_linux,
+                                         system_x86_64_linux,system_arm_linux] then
+                begin
+                   AsmWrite(#9'.type'#9);
+                   AsmWrite(tai_symbol(hp).sym.name);
+                   if assigned(tai(hp.next)) and
+                      (tai(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]) then
+                     begin
+                       if target_info.system = system_arm_linux then
+                         AsmWriteLn(',#object')
+                       else
+                         AsmWriteLn(',@object')
+                     end
+                   else
+                     begin
+                       if target_info.system = system_arm_linux then
+                         AsmWriteLn(',#function')
+                       else
+                         AsmWriteLn(',@function');
+                     end;
+                   if tai_symbol(hp).sym.size>0 then
+                    begin
+                      AsmWrite(#9'.size'#9);
+                      AsmWrite(tai_symbol(hp).sym.name);
+                      AsmWrite(', ');
+                      AsmWriteLn(tostr(tai_symbol(hp).sym.size));
+                    end;
+                end;
+               AsmWrite(tai_symbol(hp).sym.name);
+               AsmWriteLn(':');
+             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);
+                  AsmWrite(tai_symbol_end(hp).sym.name);
+                  AsmWrite(', '+s+' - ');
+                  AsmWriteLn(tai_symbol_end(hp).sym.name);
+                end;
+             end;
+
+           ait_instruction :
+             begin
+               WriteInstruction(hp);
+             end;
+
+{$ifdef GDB}
+           ait_stabs :
+             begin
+               if assigned(tai_stabs(hp).str) then
+                 begin
+                   AsmWrite(#9'.stabs ');
+                   AsmWritePChar(tai_stabs(hp).str);
+                   AsmLn;
+                 end;
+             end;
+
+           ait_stabn :
+             begin
+               if assigned(tai_stabn(hp).str) then
+                 begin
+                   AsmWrite(#9'.stabn ');
+                   AsmWritePChar(tai_stabn(hp).str);
+                   AsmLn;
+                 end;
+             end;
+
+           ait_force_line :
+             stabslastfileinfo.line:=0;
+
+           ait_stab_function_name:
+             funcname:=tai_stab_function_name(hp).str;
+{$endif GDB}
+
+           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
+                       lasTSectype:=tai_section(hp.next).sectype;
+                     hp:=tai(hp.next);
+                   end;
+{$ifdef GDB}
+                  { force write of filename }
+                  FillChar(stabslastfileinfo,sizeof(stabslastfileinfo),0);
+                  includecount:=0;
+                  funcname:=nil;
+                  WriteFileLineInfo(aktfilepos);
+{$endif GDB}
+                  if lasTSectype<>sec_none then
+                    WriteSection(lasTSectype,'');
+                  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_non_lazy_symbol_pointer:
+             AsmWriteLn('.non_lazy_symbol_pointer');
+
+           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;
+{$ifdef GDB}
+      fileinfo : tfileposinfo;
+{$endif GDB}
+
+    begin
+{$ifdef EXTDEBUG}
+      if assigned(current_module.mainsource) then
+       Comment(V_Debug,'Start writing gas-styled assembler output for '+current_module.mainsource^);
+{$endif}
+
+      LasTSectype:=sec_none;
+{$ifdef GDB}
+      FillChar(stabslastfileinfo,sizeof(stabslastfileinfo),0);
+{$endif GDB}
+      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;
+{$ifdef GDB}
+      n_line:=n_bssline;
+      funcname:=nil;
+      linecount:=1;
+      includecount:=0;
+      fileinfo.fileindex:=1;
+      fileinfo.line:=1;
+      { Write main file }
+      WriteFileLineInfo(fileinfo);
+{$endif GDB}
+      AsmStartSize:=AsmSize;
+      symendcount:=0;
+
+      If (cs_debuginfo in aktmoduleswitches) then
+        WriteTree(debuglist);
+      WriteTree(codesegment);
+      WriteTree(datasegment);
+      WriteTree(consts);
+      WriteTree(rttilist);
+      WriteTree(picdata);
+      Writetree(resourcestringlist);
+      WriteTree(bsssegment);
+      Writetree(importssection);
+      { exports are written by DLLTOOL
+        if we use it so don't insert it twice (PM) }
+      if not UseDeffileForExports and assigned(exportssection) then
+        Writetree(exportssection);
+      Writetree(resourcesection);
+      Writetree(dwarflist);
+      {$ifdef GDB}
+      WriteFileEndInfo;
+      {$ENDIF}
+
+      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.

compiler/alpha/aasmcpu.pas

@@ -0,0 +1,287 @@
+{
+    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.
+{
+  $Log: aasmcpu.pas,v $
+  Revision 1.5  2005/02/14 17:13:09  peter
+    * truncate log
+
+}

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.

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.

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.

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.

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.

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.

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.

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.

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.

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.

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.

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.

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.

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.

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.

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.

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.

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);
+
+        { 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;}
+            { 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;
+
+
+begin
+  casmoptimizer:=TAsmOptimizer;
+end.

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;
+        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.

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.

compiler/aoptda.pas

@@ -0,0 +1,185 @@
+{
+    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);
+    {$ifdef GDB}
+            ait_stabs, ait_stabn, ait_stab_function_name:;
+    {$endif GDB}
+            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.

compiler/aoptobj.pas

@@ -0,0 +1,1085 @@
+{
+    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);
+
+        { 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;virtual;
+        procedure PeepHoleOptPass1;virtual;
+        procedure PeepHoleOptPass2;virtual;
+        procedure PostPeepHoleOpts;virtual;
+
+        { processor dependent methods }
+      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) 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) 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.getlabel(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));
+            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) 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
+                                  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;
+      begin
+      end;
+
+
+End.

compiler/arm/aasmcpu.pas

@@ -0,0 +1,517 @@
+{
+    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,aasmtai,
+  aasmbase,globtype,globals,verbose,
+  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;
+
+    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;
+      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;
+
+
+{ ****************************** newra stuff *************************** }
+
+    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_LDRD,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_STRD,
+          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 InitAsm;
+      begin
+      end;
+
+
+    procedure DoneAsm;
+      begin
+      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.getlabel(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;
+
+end.

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.

compiler/arm/aoptcpu.pas

@@ -0,0 +1,40 @@
+{
+    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, aoptobj, aoptcpub;
+
+Type
+  TAOptCpu = class(TAoptObj)
+    { uses the same constructor as TAopObj }
+  End;
+
+Implementation
+
+End.

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.

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.

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.

compiler/arm/armreg.dat

@@ -0,0 +1,102 @@
+;
+; $Id: armreg.dat,v 1.3 2004/06/16 20:07:10 florian Exp $
+;
+; 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
+
+;
+; $Log: armreg.dat,v $
+; Revision 1.3  2004/06/16 20:07:10  florian
+;   * dwarf branch merged
+;
+; Revision 1.2.2.1  2004/06/12 17:01:01  florian
+;   * fixed compilation of arm compiler
+;
+; Revision 1.2  2003/09/09 12:53:39  florian
+;   * some assembling problems fixed
+;   * improved loadaddr_ref_reg
+;
+; Revision 1.1  2003/09/04 00:15:29  florian
+;   * first bunch of adaptions of arm compiler for new register type
+;

compiler/arm/cgcpu.pas

@@ -0,0 +1,1687 @@
+{
+
+    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;
+
+        {  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 is_shifter_const(d : aint;var imm_shift : byte) : boolean;
+
+    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
+        ref: treference;
+        tmpreg: tregister;
+      begin
+        paraloc.check_simple_location;
+        case paraloc.location^.loc of
+          LOC_REGISTER,LOC_CREGISTER:
+            a_load_ref_reg(list,size,size,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,size);
+               a_load_ref_reg(list,size,size,r,tmpreg);
+               a_load_reg_ref(list,size,size,tmpreg,ref);
+            end;
+          LOC_FPUREGISTER,LOC_CFPUREGISTER:
+            case size of
+               OS_F32, OS_F64:
+                 a_loadfpu_ref_reg(list,size,r,paraloc.location^.register);
+               else
+                 internalerror(2002072801);
+            end;
+          else
+            internalerror(2002081103);
+        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;
+
+
+     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;
+
+
+     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.getlabel(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
+           (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);
+            { create consts entry }
+            objectlibrary.getlabel(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_R15;
+            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;
+
+        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_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(200309021);
+         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,objectlibrary.newasmsymbol(l.name,AB_EXTERNAL,AT_FUNCTION)));
+      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 tmpref.base=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
+              a_op_const_reg_reg(list,OP_ADD,OS_ADDR,tmpref.offset,tmpref.base,r)
+            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.getlabel(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.getlabel(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.getlabel(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 procdef.proctypeoption<>potype_none 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.

compiler/arm/cpubase.pas

@@ -0,0 +1,512 @@
+{
+    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=(A_None,A_ADC,A_ADD,A_AND,A_N,A_BIC,A_BKPT,A_B,A_BL,A_BLX,A_BX,
+              A_CDP,A_CDP2,A_CLZ,A_CMN,A_CMP,A_EOR,A_LDC,_A_LDC2,
+              A_LDM,A_LDR,A_LDRB,A_LDRD,A_LDRBT,A_LDRH,A_LDRSB,
+              A_LDRSH,A_LDRT,A_MCR,A_MCR2,A_MCRR,A_MLA,A_MOV,
+              A_MRC,A_MRC2,A_MRRC,A_RS,A_MSR,A_MUL,A_MVN,
+              A_ORR,A_PLD,A_QADD,A_QDADD,A_QDSUB,A_QSUB,A_RSB,A_RSC,
+              A_SBC,A_SMLAL,A_SMULL,A_SMUL,
+              A_SMULW,A_STC,A_STC2,A_STM,A_STR,A_STRB,A_STRBT,A_STRD,
+              A_STRH,A_STRT,A_SUB,A_SWI,A_SWP,A_SWPB,A_TEQ,A_TST,
+              A_UMLAL,A_UMULL,
+              { FPA coprocessor instructions }
+              A_LDF,A_STF,A_LFM,A_SFM,A_FLT,A_FIX,A_WFS,A_RFS,A_RFC,
+              A_ADF,A_DVF,A_FDV,A_FML,A_FRD,A_MUF,A_POL,A_PW,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_NRM,A_RND,A_SIN,A_SQT,A_TAN,A_URD,
+              A_CMF,A_CMFE,A_CNF
+              { VPA coprocessor codes }
+              );
+
+      { 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;
+      { 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;
+
+  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);
+      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;
+
+
+end.

compiler/arm/cpuinfo.pas

@@ -0,0 +1,90 @@
+{
+    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_compilerproc,
+     pocall_inline,
+     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.

compiler/arm/cpunode.pas

@@ -0,0 +1,44 @@
+{
+    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
+       ;
+
+end.

compiler/arm/cpupara.pas

@@ -0,0 +1,448 @@
+{
+    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,
+       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=pocall_softfloat 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
+                   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
+                            paraloc^.loc:=LOC_REFERENCE;
+                            paraloc^.reference.index:=NR_STACK_POINTER_REG;
+                            paraloc^.reference.offset:=stack_offset;
+                            inc(stack_offset,4);
+                         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;
+          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
+            p.funcretloc[side].loc:=LOC_FPUREGISTER;
+            p.funcretloc[side].register:=NR_FPU_RESULT_REG;
+          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.

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.

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.

compiler/arm/cputarg.pas

@@ -0,0 +1,51 @@
+{
+    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}
+
+{**************************************
+             Assemblers
+**************************************}
+
+    {$ifndef NOAGARMGAS}
+      ,agarmgas
+    {$endif}
+      ;
+
+end.

compiler/arm/itcpugas.pas

@@ -0,0 +1,112 @@
+{
+    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 = (
+            '','adc','add','and','n','bic','bkpt','b','bl','blx','bx',
+            'cdp','cdp2','clz','cmn','cmp','eor','ldc','ldc2',
+            'ldm','ldr','ldrb','ldrd','ldrbt','ldrh','ldrsb',
+            'ldrsh','ldrt','mcr','mcr2','mcrr','mla','mov',
+            'mrc','mrc2','mrrc','rs','msr','mul','mvn',
+            'orr','pld','qadd','qdadd','qdsub','qsub','rsb','rsc',
+            'sbc','smlal','smull','smul',
+            'smulw','stc','stc2','stm','str','strb','strbt','strd',
+            'strh','strt','sub','swi','swp','swpb','teq','tst',
+            'umlal','umull',
+            { FPA coprocessor codes }
+            'ldf','stf','lfm','sfm','flt','fix','wfs','rfs','rfc',
+            'adf','dvf','fdv','fml','frd','muf','pol','pw','rdf',
+            'rmf','rpw','rsf','suf','abs','acs','asn','atn','cos',
+            'exp','log','lgn','mvf','mnf','nrm','rnd','sin','sqt','tan','urd',
+            'cmf','cmfe','cnf'
+            { VPA coprocessor codes }
+            );
+
+
+    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.

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.

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.

compiler/arm/narmcnv.pas

@@ -0,0 +1,225 @@
+{
+    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,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
+        { 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;
+
+
+    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.getlabel(truelabel);
+         objectlibrary.getlabel(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.getlabel(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.

compiler/arm/narminl.pas

@@ -0,0 +1,201 @@
+{
+    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
+        expectloc:=LOC_FPUREGISTER;
+        registersint:=left.registersint;
+        registersfpu:=max(left.registersfpu,1);
+        first_abs_real := nil;
+      end;
+
+
+    function tarminlinenode.first_sqr_real : tnode;
+      begin
+        expectloc:=LOC_FPUREGISTER;
+        registersint:=left.registersint;
+        registersfpu:=max(left.registersfpu,1);
+        first_sqr_real:=nil;
+      end;
+
+
+    function tarminlinenode.first_sqrt_real : tnode;
+      begin
+        expectloc:=LOC_FPUREGISTER;
+        registersint:=left.registersint;
+        registersfpu:=max(left.registersfpu,1);
+        first_sqrt_real := nil;
+      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.

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.

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.

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.

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);

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

compiler/arm/rarmnor.inc

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

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)

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

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

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

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'

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;

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.getlabel(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.getlabel(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.

compiler/assemble.pas

@@ -0,0 +1,1682 @@
+{
+    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 = 10;
+       { 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;
+{$ifdef GDB}
+        n_line       : byte;     { different types of source lines }
+        linecount,
+        includecount : longint;
+        funcname     : tasmsymbol;
+        stabslastfileinfo : tfileposinfo;
+        procedure convertstabs(p:pchar);
+        procedure emitlineinfostabs(nidx,line : longint);
+        procedure emitstabs(s:string);
+        procedure WriteFileLineInfo(var fileinfo : tfileposinfo);
+        procedure StartFileLineInfo;
+        procedure EndFileLineInfo;
+{$endif}
+        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 GDB}
+      finput,
+      gdb,
+{$endif GDB}
+{$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 ((aktoutputformat 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;
+
+
+{$ifdef GDB}
+    procedure TInternalAssembler.convertstabs(p:pchar);
+      var
+        ofs,
+        nidx,nother,ii,i,line,j : longint;
+        code : integer;
+        hp : pchar;
+        reloc : boolean;
+        ps : tasmsymbol;
+        s : string;
+      begin
+        ofs:=0;
+        reloc:=true;
+        ps:=nil;
+        if p[0]='"' then
+         begin
+           i:=1;
+           { we can have \" inside the string !! PM }
+           while not ((p[i]='"') and (p[i-1]<>'\')) do
+            inc(i);
+           p[i]:=#0;
+           ii:=i;
+           hp:=@p[1];
+           s:=StrPas(@P[i+2]);
+         end
+        else
+         begin
+           hp:=nil;
+           s:=StrPas(P);
+           i:=-2; {needed below (PM) }
+         end;
+      { When in pass 1 then only alloc and leave }
+        if currpass=1 then
+         begin
+           objectdata.allocstabs(hp);
+           if assigned(hp) then
+            p[i]:='"';
+           exit;
+         end;
+      { Parse the rest of the stabs }
+        if s='' then
+         internalerror(33000);
+        j:=pos(',',s);
+        if j=0 then
+         internalerror(33001);
+        Val(Copy(s,1,j-1),nidx,code);
+        if code<>0 then
+         internalerror(33002);
+        i:=i+2+j;
+        Delete(s,1,j);
+        j:=pos(',',s);
+        if (j=0) then
+         internalerror(33003);
+        Val(Copy(s,1,j-1),nother,code);
+        if code<>0 then
+         internalerror(33004);
+        i:=i+j;
+        Delete(s,1,j);
+        j:=pos(',',s);
+        if j=0 then
+         begin
+           j:=256;
+           ofs:=-1;
+         end;
+        Val(Copy(s,1,j-1),line,code);
+        if code<>0 then
+          internalerror(33005);
+        if ofs=0 then
+          begin
+            Delete(s,1,j);
+            i:=i+j;
+            Val(s,ofs,code);
+            if code=0 then
+              reloc:=false
+            else
+              begin
+                ofs:=0;
+                s:=strpas(@p[i]);
+                { handle asmsymbol or
+                    asmsymbol - asmsymbol }
+                j:=pos(' ',s);
+                if j=0 then
+                  j:=pos('-',s);
+                { also try to handle
+                  asmsymbol + constant
+                  or
+                  asmsymbol - constant }
+                if j=0 then
+                  j:=pos('+',s);
+
+                if j<>0 then
+                  begin
+                    Val(Copy(s,j+1,255),ofs,code);
+                    if code<>0 then
+                      ofs:=0
+                    else
+                    { constant reading successful,
+                      avoid further treatment by
+                      setting s[j] to '+' }
+                      s[j]:='+';
+                  end
+                else
+                { single asmsymbol }
+                  j:=256;
+                { the symbol can be external
+                  so we must use newasmsymbol and
+                  not getasmsymbol !! PM }
+                ps:=objectlibrary.newasmsymbol(copy(s,1,j-1),AB_EXTERNAL,AT_NONE);
+                if not assigned(ps) then
+                  internalerror(33006)
+                else
+                  begin
+                    ofs:=ofs+ps.address;
+                    reloc:=true;
+                    objectlibrary.UsedAsmSymbolListInsert(ps);
+                  end;
+                if (j<256) and (s[j]<>'+') then
+                  begin
+                    i:=i+j;
+                    s:=strpas(@p[i]);
+                    if (s<>'') and (s[1]=' ') then
+                      begin
+                         j:=0;
+                         while (s[j+1]=' ') do
+                           inc(j);
+                         i:=i+j;
+                         s:=strpas(@p[i]);
+                      end;
+                    ps:=objectlibrary.getasmsymbol(s);
+                    if not assigned(ps) then
+                      internalerror(33007)
+                    else
+                      begin
+                        if ps.section<>objectdata.currsec then
+                          internalerror(33008);
+                        ofs:=ofs-ps.address;
+                        reloc:=false;
+                        objectlibrary.UsedAsmSymbolListInsert(ps);
+                      end;
+                  end;
+              end;
+          end;
+        { External references (AB_EXTERNAL and AB_COMMON) need a symbol relocation }
+        if assigned(ps) and (ps.currbind in [AB_EXTERNAL,AB_COMMON]) then
+          begin
+            if currpass=2 then
+              begin
+                objectdata.writesymbol(ps);
+                objectoutput.exportsymbol(ps);
+              end;
+            objectdata.writeSymStabs(ofs,hp,ps,nidx,nother,line,reloc)
+          end
+        else
+          objectdata.writeStabs(ofs,hp,nidx,nother,line,reloc);
+        if assigned(hp) then
+         p[ii]:='"';
+      end;
+
+
+    procedure TInternalAssembler.emitlineinfostabs(nidx,line : longint);
+      begin
+        if currpass=1 then
+          begin
+            objectdata.allocstabs(nil);
+            exit;
+          end;
+
+        if (nidx=n_textline) and assigned(funcname) and
+           (target_info.use_function_relative_addresses) then
+          objectdata.writeStabs(objectdata.currsec.datasize-funcname.address,nil,nidx,0,line,false)
+        else
+          objectdata.writeStabs(objectdata.currsec.datasize,nil,nidx,0,line,true);
+      end;
+
+
+    procedure TInternalAssembler.emitstabs(s:string);
+      begin
+        s:=s+#0;
+        ConvertStabs(@s[1]);
+      end;
+
+
+    procedure TInternalAssembler.WriteFileLineInfo(var fileinfo : tfileposinfo);
+      var
+        curr_n : byte;
+        hp : tasmsymbol;
+        infile : tinputfile;
+      begin
+        if not ((cs_debuginfo in aktmoduleswitches) or
+           (cs_gdb_lineinfo in aktglobalswitches)) then
+         exit;
+
+        { file changed ? (must be before line info) }
+        if (fileinfo.fileindex<>0) and
+           (stabslastfileinfo.fileindex<>fileinfo.fileindex) then
+         begin
+           infile:=current_module.sourcefiles.get_file(fileinfo.fileindex);
+           if assigned(infile) then
+            begin
+              if includecount=0 then
+               curr_n:=n_sourcefile
+              else
+               curr_n:=n_includefile;
+              { get symbol for this includefile }
+              hp:=objectlibrary.newasmsymbol('Ltext'+ToStr(IncludeCount),AB_LOCAL,AT_FUNCTION);
+              if currpass=1 then
+                begin
+                  objectdata.allocsymbol(currpass,hp,0);
+                  objectlibrary.UsedAsmSymbolListInsert(hp);
+                end
+              else
+                objectdata.writesymbol(hp);
+              { emit stabs }
+              if (infile.path^<>'') then
+                EmitStabs('"'+BsToSlash(FixPath(infile.path^,false))+'",'+tostr(curr_n)+
+                          ',0,0,Ltext'+ToStr(IncludeCount));
+              EmitStabs('"'+FixFileName(infile.name^)+'",'+tostr(curr_n)+
+                        ',0,0,Ltext'+ToStr(IncludeCount));
+              inc(includecount);
+              { force new line info }
+              stabslastfileinfo.line:=-1;
+            end;
+         end;
+
+        { line changed ? }
+        if (stabslastfileinfo.line<>fileinfo.line) and (fileinfo.line<>0) then
+          emitlineinfostabs(n_line,fileinfo.line);
+        stabslastfileinfo:=fileinfo;
+      end;
+
+
+    procedure TInternalAssembler.StartFileLineInfo;
+      var
+        fileinfo : tfileposinfo;
+      begin
+        FillChar(stabslastfileinfo,sizeof(stabslastfileinfo),0);
+        n_line:=n_bssline;
+        funcname:=nil;
+        linecount:=1;
+        includecount:=0;
+        fileinfo.fileindex:=1;
+        fileinfo.line:=1;
+        WriteFileLineInfo(fileinfo);
+      end;
+
+
+    procedure TInternalAssembler.EndFileLineInfo;
+      var
+        hp : tasmsymbol;
+      begin
+          if not ((cs_debuginfo in aktmoduleswitches) or
+             (cs_gdb_lineinfo in aktglobalswitches)) then
+           exit;
+        objectdata.createsection(sec_code,'',0,[]);
+        hp:=objectlibrary.newasmsymbol('Letext',AB_LOCAL,AT_FUNCTION);
+        if currpass=1 then
+          begin
+            objectdata.allocsymbol(currpass,hp,0);
+            objectlibrary.UsedAsmSymbolListInsert(hp);
+          end
+        else
+          objectdata.writesymbol(hp);
+        EmitStabs('"",'+tostr(n_sourcefile)+',0,0,Letext');
+      end;
+{$endif GDB}
+
+
+    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}
+               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 : longint;
+{$ifdef i386}
+{$ifndef NOAG386BIN}
+        i : longint;
+{$endif NOAG386BIN}
+{$endif i386}
+      begin
+        inlinelevel:=0;
+        while assigned(hp) do
+         begin
+{$ifdef GDB}
+           { write stabs, no line info for inlined code }
+           if (inlinelevel=0) and
+              ((cs_debuginfo in aktmoduleswitches) or
+               (cs_gdb_lineinfo in aktglobalswitches)) then
+            begin
+              if (objectdata.currsec<>nil) and
+                 not(hp.typ in SkipLineInfo) then
+               WriteFileLineInfo(tailineinfo(hp).fileinfo);
+            end;
+{$endif GDB}
+           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 objectdata.currsec.sectype<>sec_bss 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);
+{$ifdef GDB}
+                 case Tai_section(hp).sectype of
+                   sec_code :
+                     n_line:=n_textline;
+                   sec_data :
+                     n_line:=n_dataline;
+                   sec_bss :
+                     n_line:=n_bssline;
+                   else
+                     n_line:=n_dataline;
+                 end;
+                 stabslastfileinfo.line:=-1;
+{$endif GDB}
+               end;
+{$ifdef GDB}
+             ait_stabn :
+               begin
+                 if assigned(Tai_stabn(hp).str) then
+                   convertstabs(Tai_stabn(hp).str);
+               end;
+             ait_stabs :
+               begin
+                 if assigned(Tai_stabs(hp).str) then
+                   convertstabs(Tai_stabs(hp).str);
+               end;
+             ait_stab_function_name :
+               begin
+                 if assigned(Tai_stab_function_name(hp).str) then
+                  begin
+                    funcname:=objectlibrary.getasmsymbol(strpas(Tai_stab_function_name(hp).str));
+                    objectlibrary.UsedAsmSymbolListInsert(funcname);
+                  end
+                 else
+                  funcname:=nil;
+               end;
+             ait_force_line :
+               stabslastfileinfo.line:=0;
+{$endif}
+             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
+{$ifdef i386}
+{$ifndef NOAG386BIN}
+                 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;
+{$endif NOAG386BIN}
+{$endif i386}
+               end;
+             ait_direct :
+               Message(asmw_f_direct_not_supported);
+             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
+{$ifdef GDB}
+           { write stabs, no line info for inlined code }
+           if (inlinelevel=0) and
+              ((cs_debuginfo in aktmoduleswitches) or
+               (cs_gdb_lineinfo in aktglobalswitches)) then
+            begin
+              if (objectdata.currsec<>nil) and
+                 not(hp.typ in SkipLineInfo) then
+               WriteFileLineInfo(tailineinfo(hp).fileinfo);
+            end;
+{$endif GDB}
+           case hp.typ of
+             ait_align :
+               begin
+                 if objectdata.currsec.sectype=sec_bss 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);
+{$ifdef GDB}
+                 case Tai_section(hp).sectype of
+                  sec_code : n_line:=n_textline;
+                  sec_data : n_line:=n_dataline;
+                   sec_bss : n_line:=n_bssline;
+                 else
+                  n_line:=n_dataline;
+                 end;
+                 stabslastfileinfo.line:=-1;
+{$endif GDB}
+               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}
+{$ifdef FPC}
+                 co:=comp(Tai_comp_64bit(hp).value);
+{$else}
+                 co:=Tai_comp_64bit(hp).value;
+{$endif}
+                 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;
+{$ifdef i386}
+{$ifndef NOAG386BIN}
+             ait_instruction :
+               Taicpu(hp).Pass2(objectdata);
+{$endif NOAG386BIN}
+{$endif i386}
+{$ifdef GDB}
+             ait_stabn :
+               convertstabs(Tai_stabn(hp).str);
+             ait_stabs :
+               convertstabs(Tai_stabs(hp).str);
+             ait_stab_function_name :
+               if assigned(Tai_stab_function_name(hp).str) then
+                 funcname:=objectlibrary.getasmsymbol(strpas(Tai_stab_function_name(hp).str))
+               else
+                 funcname:=nil;
+             ait_force_line :
+               stabslastfileinfo.line:=0;
+{$endif}
+             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,[]);
+{$ifdef GDB}
+        StartFileLineInfo;
+{$endif GDB}
+        { start with list 1 }
+        currlistidx:=1;
+        currlist:=list[currlistidx];
+        hp:=Tai(currList.first);
+        while assigned(hp) do
+         begin
+           hp:=TreePass1(hp);
+           MaybeNextList(hp);
+         end;
+{$ifdef GDB}
+        EndFileLineInfo;
+{$endif GDB}
+        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,[]);
+{$ifdef GDB}
+        StartFileLineInfo;
+{$endif GDB}
+        { start with list 1 }
+        currlistidx:=1;
+        currlist:=list[currlistidx];
+        hp:=Tai(currList.first);
+        while assigned(hp) do
+         begin
+           hp:=TreePass2(hp);
+           MaybeNextList(hp);
+         end;
+{$ifdef GDB}
+        EndFileLineInfo;
+{$endif GDB}
+        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,[]);
+{$ifdef GDB}
+           StartFileLineInfo;
+{$endif GDB}
+           TreePass1(hp);
+{$ifdef GDB}
+           EndFileLineInfo;
+{$endif GDB}
+           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,[]);
+{$ifdef GDB}
+           StartFileLineInfo;
+{$endif GDB}
+           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;
+{$ifdef GDB}
+           EndFileLineInfo;
+{$endif GDB}
+           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;
+
+        procedure addlist(p:TAAsmoutput);
+        begin
+          inc(lists);
+          list[lists]:=p;
+        end;
+
+      begin
+        if cs_debuginfo in aktmoduleswitches then
+          addlist(debuglist);
+        addlist(codesegment);
+        addlist(datasegment);
+        addlist(consts);
+        addlist(rttilist);
+        addlist(picdata);
+        if assigned(resourcestringlist) then
+          addlist(resourcestringlist);
+        addlist(bsssegment);
+        if assigned(importssection) then
+          addlist(importssection);
+        if assigned(exportssection) and not UseDeffileForExports then
+          addlist(exportssection);
+        if assigned(resourcesection) then
+          addlist(resourcesection);
+{$warning TODO internal writer support for dwarf}
+        {if assigned(dwarflist) then
+          addlist(dwarflist);}
+
+        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
+        { target_asm is already set by readarguments }
+        initoutputformat:=target_asm.id;
+        aktoutputformat:=target_asm.id;
+      end;
+
+
+    procedure DoneAssembler;
+      begin
+      end;
+
+end.

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.

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.

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
+

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.

compiler/cclasses.pas

@@ -0,0 +1,2366 @@
+{
+    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;
+{$ifdef HASGETHEAPSTATUS}
+      var
+        status : TFPCHeapStatus;
+{$endif HASGETHEAPSTATUS}
+      begin
+{$ifdef HASGETHEAPSTATUS}
+        status:=GetFPCHeapStatus;
+        startmem:=status.CurrHeapUsed;
+{$else HASGETHEAPSTATUS}
+        startmem:=memavail;
+{$endif HASGETHEAPSTATUS}
+      end;
+
+
+    procedure tmemdebug.stop;
+{$ifdef HASGETHEAPSTATUS}
+      var
+        status : TFPCHeapStatus;
+{$endif HASGETHEAPSTATUS}
+      begin
+{$ifdef HASGETHEAPSTATUS}
+        if startmem<>0 then
+         begin
+           status:=GetFPCHeapStatus;
+           inc(TotalMem,startmem-status.CurrHeapUsed);
+           startmem:=0;
+         end;
+{$else HASGETHEAPSTATUS}
+        if startmem<>0 then
+         begin
+           inc(TotalMem,memavail-startmem);
+           startmem:=0;
+         end;
+{$endif HASGETHEAPSTATUS}
+      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.

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.getlabel(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.getlabel(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.getlabel(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.getlabel(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.getlabel(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.

compiler/cgbase.pas

@@ -0,0 +1,596 @@
+{
+    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 16 offsets, we need to be able to specify the high
+         and low 16 bits of the address of a symbol                            }
+       trefaddr = (addr_no,addr_full,addr_hi,addr_lo,addr_pic);
+
+       {# 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 }
+      );
+
+      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 }
+{$ifndef VER1_0}
+  {$ifndef VER1_9_4}
+    {$define USEINDEXWORD}
+  {$endif}
+{$endif}
+{$ifdef USEINDEXWORD}
+      i:=indexword(buf^,length,s);
+      if i<>-1 then
+        begin
+          deleteidx(i);
+          delete := true;
+        end;
+{$else USEINDEXWORD}
+      for i:=1 to length do
+        if buf^[i-1]=s then
+          begin
+            deleteidx(i-1);
+            delete:=true;
+            break;
+          end;
+{$endif USEINDEXWORD}
+{$undef USEINDEXWORD}
+    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';
+          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.

compiler/cgobj.pas

@@ -0,0 +1,2080 @@
+{
+    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 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(200312124);
+        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.dealloccpuregisters(list:Taasmoutput;rt:Tregistertype;r:Tcpuregisterset);
+      begin
+        if assigned(rg[rt]) then
+          rg[rt].dealloccpuregisters(list,r)
+        else
+          internalerror(200310093);
+      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
+         cgpara.check_simple_location;
+         case cgpara.location^.loc of
+            LOC_FPUREGISTER,LOC_CFPUREGISTER:
+              a_loadfpu_reg_reg(list,size,r,cgpara.location^.register);
+            LOC_REFERENCE,LOC_CREFERENCE:
+              begin
+                 reference_reset_base(ref,cgpara.location^.reference.index,cgpara.location^.reference.offset);
+                 a_loadfpu_reg_ref(list,size,r,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);
+        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_SHORTSTR_ASSIGN');
+        dealloccpuregisters(list,R_FPUREGISTER,paramanager.get_volatile_registers_fpu(pocall_default));
+        dealloccpuregisters(list,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default));
+        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);
+            alloccpuregisters(list,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default));
+            a_call_name(list,incrfunc);
+            dealloccpuregisters(list,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default));
+          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);
+            alloccpuregisters(list,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default));
+            a_call_name(list,'FPC_ADDREF');
+            dealloccpuregisters(list,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default));
+          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);
+            alloccpuregisters(list,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default));
+            a_call_name(list,decrfunc);
+            dealloccpuregisters(list,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default));
+          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);
+            alloccpuregisters(list,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default));
+            a_call_name(list,'FPC_DECREF');
+            dealloccpuregisters(list,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default));
+         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);
+              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_INITIALIZE');
+              dealloccpuregisters(list,R_FPUREGISTER,paramanager.get_volatile_registers_fpu(pocall_default));
+              dealloccpuregisters(list,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default));
+           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);
+              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_FINALIZE');
+              dealloccpuregisters(list,R_FPUREGISTER,paramanager.get_volatile_registers_fpu(pocall_default));
+              dealloccpuregisters(list,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default));
+           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)                }
+{$ifndef ver1_0}
+      const
+        aintmax=high(aint);
+{$endif}
+      var
+        neglabel : tasmlabel;
+        hreg : tregister;
+        lto,hto,
+        lfrom,hfrom : TConstExprInt;
+        from_signed: boolean;
+{$ifdef ver1_0}
+        aintmax : aint;
+{$endif ver1_0}
+      begin
+{$ifdef ver1_0}
+  {$ifdef cpu64bit}
+        { this is required to prevent incorrect code }
+        aintmax:=$7fffffff;
+        aintmax:=int64(aintmax shl 16) or int64($ffff);
+        aintmax:=int64(aintmax shl 16) or int64($ffff);
+  {$else cpu64bit}
+        aintmax:=high(aint);
+  {$endif cpu64bit}
+{$endif}
+        { 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.getlabel(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.getlabel(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);
+           alloccpuregisters(list,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default));
+           a_call_name(list,'FPC_CHECK_OBJECT_EXT');
+           dealloccpuregisters(list,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default));
+         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);
+            alloccpuregisters(list,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default));
+            a_call_name(list,'FPC_CHECK_OBJECT');
+            dealloccpuregisters(list,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default));
+          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);
+        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_GETMEM');
+        dealloccpuregisters(list,R_FPUREGISTER,paramanager.get_volatile_registers_fpu(pocall_default));
+        dealloccpuregisters(list,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default));
+        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);
+        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));
+        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);
+        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_FREEMEM');
+        dealloccpuregisters(list,R_FPUREGISTER,paramanager.get_volatile_registers_fpu(pocall_default));
+        dealloccpuregisters(list,R_INTREGISTER,paramanager.get_volatile_registers_int(pocall_default));
+        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.

compiler/cgutils.pas

@@ -0,0 +1,188 @@
+{
+    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.

compiler/charset.pas

@@ -0,0 +1,253 @@
+{
+    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
+         mapcache : string = '';
+         mapcachep : punicodemap = nil;
+
+      begin
+         if (mapcache=s) 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;
+                   mapcache:=s;
+                   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.

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.

compiler/comphook.pas

@@ -0,0 +1,416 @@
+{
+    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,
+    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
+{$IFDEF USE_SYSUTILS}
+    SysUtils,
+{$ELSE 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;
+{$ifdef HASGETHEAPSTATUS}
+var
+  hstatus : TFPCHeapStatus;
+{$endif HASGETHEAPSTATUS}
+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,' ');
+{$ifdef HASGETHEAPSTATUS}
+         hstatus:=GetFPCHeapStatus;
+         WriteLn(DStr(hstatus.CurrHeapUsed shr 10),'/',DStr(hstatus.CurrHeapSize shr 10),' Kb Used');
+{$else HASGETHEAPSTATUS}
+         WriteLn(DStr(memavail shr 10),'/',DStr(system.heapsize shr 10),' Kb Free');
+{$endif HASGETHEAPSTATUS}
+       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
+          hs:=status.currentsource+'('+tostr(status.currentline)+
+              ','+tostr(status.currentcolumn)+') '+hs+' '+s;
+      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.

compiler/compiler.pas

@@ -0,0 +1,469 @@
+{
+    Copyright (c) 1998-2002 by Florian Klaempfl
+
+    This unit is the interface of the compiler which can be used by
+     external programs to link in 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 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 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,import,export,tokens,pass_1
+  { cpu overrides }
+  ,cpuswtch
+  { cpu codegenerator }
+  ,cgcpu
+{$ifndef NOPASS2}
+  ,cpunode
+{$endif}
+  { cpu targets }
+  ,cputarg
+  { cpu parameter handling }
+  ,cpupara
+  { procinfo stuff }
+  ,cpupi
+  { 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 fbds}
+  ,i_fbsd
+{$endif fbds}
+{$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_win32
+{$endif win32}
+  { assembler readers }
+{$ifdef i386}
+  {$ifndef NoRa386Int}
+       ,ra386int
+  {$endif NoRa386Int}
+  {$ifndef NoRa386Att}
+       ,ra386att
+  {$endif NoRa386Att}
+{$else}
+  ,rasm
+{$endif i386}
+{$ifdef powerpc}
+  ,rappcgas
+{$endif powerpc}
+{$ifdef x86_64}
+  ,rax64att
+{$endif x86_64}
+{$ifdef arm}
+  ,raarmgas
+{$endif arm}
+{$ifdef SPARC}
+  ,racpugas
+{$endif SPARC}
+  ;
+
+function Compile(const cmd:string):longint;
+
+
+implementation
+
+uses
+{$IFDEF USE_SYSUTILS}
+  SysUtils,
+{$ENDIF USE_SYSUTILS}
+  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;
+     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;
+  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}
+{$ifdef HASGETHEAPSTATUS}
+  hstatus : TFPCHeapStatus;
+{$endif HASGETHEAPSTATUS}
+{$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_e_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_e_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_e_compilation_aborted);
+        except
+          on ECompilerAbort do
+            ;
+        end;
+        DoneVerbose;
+        Raise;
+      end;
+  end;
+{$ifdef SHOWUSEDMEM}
+  {$ifdef HASGETHEAPSTATUS}
+      hstatus:=GetFPCHeapStatus;
+      Writeln('Max Memory used/heapsize: ',DStr(hstatus.MaxHeapUsed shr 10),'/',DStr(hstatus.MaxHeapSize shr 10),' Kb');
+  {$else HASGETHEAPSTATUS}
+      Writeln('Memory used (heapsize): ',DStr(system.Heapsize shr 10),' Kb');
+  {$endif HASGETHEAPSTATUS}
+{$endif SHOWUSEDMEM}
+
+  { Set the return value if an error has occurred }
+  if status.errorcount=0 then
+    result:=0
+  else
+    result:=1;
+end;
+
+end.

compiler/compinnr.inc

@@ -0,0 +1,112 @@
+{
+    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}
+
+{ 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 }
+
+{
+  $Log: compinnr.inc,v $
+  Revision 1.16  2005/02/14 17:13:06  peter
+    * truncate log
+
+}

compiler/comprsrc.pas

@@ -0,0 +1,182 @@
+{
+    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(target_res.resbin+source_info.exeext,utilsdirectory,resbin);
+  if not resfound then
+   resfound:=FindExe(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));
+  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);
+{$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
+      case target_info.system of
+        system_m68k_palmos,
+        system_i386_win32,
+        system_i386_wdosx :
+          hr:=new(presourcefile,init(current_module.ResourceFiles.getfirst));
+        else
+          Message(scan_e_resourcefiles_not_supported);
+      end;
+      hr^.compile;
+      dispose(hr,done);
+    end;
+end;
+
+
+end.

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.

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.

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.

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.

compiler/cresstr.pas

@@ -0,0 +1,292 @@
+{
+    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;
+
+{$ifdef ver1_0}
+  {$R-}
+{$endif}
+
+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
+         resourcestringlist.concat(tai_const.create_sym(nil))
+       else
+         begin
+            objectlibrary.getdatalabel(l1);
+            resourcestringlist.concat(tai_const.create_sym(l1));
+            consts.concat(tai_align.Create(const_align(sizeof(aint))));
+            consts.concat(tai_const.create_aint(-1));
+            consts.concat(tai_const.create_aint(len));
+            consts.concat(tai_label.create(l1));
+            getmem(s,len+1);
+            move(Value^,s^,len);
+            s[len]:=#0;
+            consts.concat(tai_string.create_length_pchar(s,len));
+            consts.concat(tai_const.create_8bit(0));
+         end;
+       { append Current value (nil) and hash...}
+       resourcestringlist.concat(tai_const.create_sym(nil));
+       resourcestringlist.concat(tai_const.create_32bit(longint(hash)));
+       { Append the name as a ansistring. }
+       objectlibrary.getdatalabel(l1);
+       L:=Length(Name);
+       resourcestringlist.concat(tai_const.create_sym(l1));
+       consts.concat(tai_align.Create(const_align(sizeof(aint))));
+       consts.concat(tai_const.create_aint(-1));
+       consts.concat(tai_const.create_aint(l));
+       consts.concat(tai_label.create(l1));
+       getmem(s,l+1);
+       move(Name[1],s^,l);
+       s[l]:=#0;
+       consts.concat(tai_string.create_length_pchar(s,l));
+       consts.concat(tai_const.create_8bit(0));
+     end;
+  end;
+
+Var
+  R : tresourceStringItem;
+begin
+  if not(assigned(resourcestringlist)) then
+    resourcestringlist:=taasmoutput.create;
+  resourcestringlist.insert(tai_const.create_32bit(resstrcount));
+  resourcestringlist.insert(tai_symbol.createname_global(make_mangledname('RESOURCESTRINGLIST',current_module.localsymtable,''),AT_DATA,0));
+  resourcestringlist.insert(tai_align.Create(const_align(sizeof(aint))));
+  R:=TResourceStringItem(List.First);
+  While assigned(R) do
+   begin
+     AppendToAsmResList(R);
+     R:=TResourceStringItem(R.Next);
+   end;
+  resourcestringlist.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.

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.

compiler/cutils.pas

@@ -0,0 +1,1222 @@
+{
+    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
+{$ifdef ver1_0}
+       ptrint = longint;
+{$endif ver1_0}
+       pstring = ^string;
+       get_var_value_proc=function(const s:string):string of object;
+       Tcharset=set of char;
+
+    var
+      internalerrorproc : procedure(i:longint);
+
+{$ifndef HASGETFPCHEAPSTATUS}
+    type
+      TFPCHeapStatus = THeapStatus;
+    function GetFPCHeapStatus:TFPCHeapStatus;
+{$endif HASGETFPCHEAPSTATUS}
+
+    {# 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;var 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);
+
+    function string_evaluate(s:string;get_var_value:get_var_value_proc;
+                             const vars:array of string):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
+  ;
+
+
+{$ifndef HASGETFPCHEAPSTATUS}
+    function GetFPCHeapStatus:TFPCHeapStatus;
+    begin
+      GetHeapStatus(result);
+    end;
+{$endif HASGETFPCHEAPSTATUS}
+
+
+    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;var 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;
+
+    function string_evaluate(s:string;get_var_value:get_var_value_proc;
+                             const vars:array of string):Pchar;
+
+    {S contains a prototype of a stabstring. 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;
+        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);
+                 inc(len,length(Pstring(varptr)^));
+                 inc(varptr,length(Pstring(varptr)^)+1);
+                 inc(varcounter);
+               end
+             else if s[i+1] in ['0'..'9'] then
+               begin
+                 inc(len,length(vars[byte(s[i+1])-byte('1')]));
+                 inc(i);
+               end;
+            end
+          else
+            inc(len);
+          inc(i);
+        end;
+
+      {Second pass, writeout stabstring.}
+      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;
+
+{*****************************************************************************
+                               GetSpeedValue
+*****************************************************************************}
+
+{$ifdef ver1_0}
+  {$R-}
+{$endif}
+
+    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.

compiler/defcmp.pas

@@ -0,0 +1,1401 @@
+{
+    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_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;methoderr:boolean):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;
+               end;
+             end;
+
+           stringdef :
+             begin
+               case def_from.deftype of
+                 stringdef :
+                   begin
+                     { Constant string }
+                     if (fromtreetype=stringconstn) then
+                      begin
+                        if (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_l1
+                           else
+                             begin
+                               if tstringdef(def_to).string_typ=st_widestring then
+                                 eq:=te_convert_l1
+                               else
+                                 eq:=te_equal; { we can change the stringconst node }
+                             end;
+                         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;
+                         { Prefer conversions to shortstring over other
+                           conversions. This is compatible with Delphi (PFV) }
+                         if tstringdef(def_to).string_typ=st_shortstring then
+                           eq:=te_convert_l2
+                         else
+                           eq:=te_convert_l3;
+                       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
+                        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_l2
+                            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
+                              eq:=te_convert_l2;
+                          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;
+                       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
+                         { 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_l1;
+                      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_l1;
+                          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
+                     { 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;
+                        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) and
+                        tprocvardef(def_from).is_addressonly then
+                      begin
+                        doconv:=tc_equal;
+                        eq:=te_convert_l1;
+                      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) then
+                      begin
+                        subeq:=proc_to_procvar_equal(tprocdef(def_from),tprocvardef(def_to),true);
+                        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),false);
+                   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;
+                                  eq:=te_convert_l1;
+                                  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_l1;
+                     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;methoderr:boolean):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
+          begin
+            if methoderr then
+              Message(type_e_no_method_and_procedure_not_compatible);
+            exit;
+          end;
+         { 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.

compiler/defutil.pas

@@ -0,0 +1,907 @@
+{
+    Copyright (c) 1998-2002 by Florian Klaempfl
+
+    This unit provides some help routines for type 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 defutil;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+       cclasses,
+       globtype,globals,
+       symconst,symbase,symtype,symdef,
+       cgbase,cpubase;
+
+    type
+       tmmxtype = (mmxno,mmxu8bit,mmxs8bit,mmxu16bit,mmxs16bit,
+                   mmxu32bit,mmxs32bit,mmxfixed16,mmxsingle);
+
+
+{*****************************************************************************
+                          Basic type functions
+ *****************************************************************************}
+
+    {# Returns true, if definition defines an ordinal type }
+    function is_ordinal(def : tdef) : boolean;
+
+    {# Returns the minimal integer value of the type }
+    function get_min_value(def : tdef) : TConstExprInt;
+
+    {# Returns basetype of the specified integer range }
+    function range_to_basetype(l,h:TConstExprInt):tbasetype;
+
+    procedure range_to_type(l,h:TConstExprInt;var tt:ttype);
+
+    procedure int_to_type(v:TConstExprInt;var tt:ttype);
+
+    {# Returns true, if definition defines an integer type }
+    function is_integer(def : tdef) : boolean;
+
+    {# Returns true if definition is a boolean }
+    function is_boolean(def : tdef) : boolean;
+
+    {# Returns true if definition is a char
+
+       This excludes the unicode char.
+    }
+    function is_char(def : tdef) : boolean;
+
+    {# Returns true if definition is a widechar }
+    function is_widechar(def : tdef) : boolean;
+
+    {# Returns true if definition is a void}
+    function is_void(def : tdef) : boolean;
+
+    {# Returns true if definition is a smallset}
+    function is_smallset(p : tdef) : boolean;
+
+    {# Returns true, if def defines a signed data type
+       (only for ordinal types)
+    }
+    function is_signed(def : tdef) : boolean;
+
+    {# Returns true whether def_from's range is comprised in def_to's if both are
+      orddefs, false otherwise                                              }
+    function is_in_limit(def_from,def_to : tdef) : boolean;
+
+    function is_in_limit_value(val_from:TConstExprInt;def_from,def_to : tdef) : boolean;
+
+{*****************************************************************************
+                              Array helper functions
+ *****************************************************************************}
+
+    {# Returns true, if p points to a zero based (non special like open or
+      dynamic array def).
+
+      This is mainly used to see if the array
+      is convertable to a pointer
+    }
+    function is_zero_based_array(p : tdef) : boolean;
+
+    {# Returns true if p points to an open array definition }
+    function is_open_array(p : tdef) : boolean;
+
+    {# Returns true if p points to a dynamic array definition }
+    function is_dynamic_array(p : tdef) : boolean;
+
+    {# Returns true, if p points to an array of const definition }
+    function is_array_constructor(p : tdef) : boolean;
+
+    {# Returns true, if p points to a variant array }
+    function is_variant_array(p : tdef) : boolean;
+
+    {# Returns true, if p points to an array of const }
+    function is_array_of_const(p : tdef) : boolean;
+
+    {# Returns true, if p points any kind of special array
+
+       That is if the array is an open array, a variant
+       array, an array constants constructor, or an
+       array of const.
+    }
+    function is_special_array(p : tdef) : boolean;
+
+    {# Returns true if p is a char array def }
+    function is_chararray(p : tdef) : boolean;
+
+    {# Returns true if p is a wide char array def }
+    function is_widechararray(p : tdef) : boolean;
+
+    {# Returns true if p is a open char array def }
+    function is_open_chararray(p : tdef) : boolean;
+
+    {# Returns true if p is a open wide char array def }
+    function is_open_widechararray(p : tdef) : boolean;
+
+{*****************************************************************************
+                          String helper functions
+ *****************************************************************************}
+
+    {# Returns true if p points to an open string type }
+    function is_open_string(p : tdef) : boolean;
+
+    {# Returns true if p is an ansi string type }
+    function is_ansistring(p : tdef) : boolean;
+
+    {# Returns true if p is a long string type }
+    function is_longstring(p : tdef) : boolean;
+
+    {# returns true if p is a wide string type }
+    function is_widestring(p : tdef) : boolean;
+
+    {# Returns true if p is a short string type }
+    function is_shortstring(p : tdef) : boolean;
+
+    {# Returns true if p is a pchar def }
+    function is_pchar(p : tdef) : boolean;
+
+    {# Returns true if p is a pwidechar def }
+    function is_pwidechar(p : tdef) : boolean;
+
+    {# Returns true if p is a voidpointer def }
+    function is_voidpointer(p : tdef) : boolean;
+
+    {# Returns true, if definition is a float }
+    function is_fpu(def : tdef) : boolean;
+
+    {# Returns true, if def is a currency type }
+    function is_currency(def : tdef) : boolean;
+
+    {# Returns true, if def is a single type }
+    function is_single(def : tdef) : boolean;
+
+    {# Returns true, if def is a double type }
+    function is_double(def : tdef) : boolean;
+
+    {# Returns true, if def is an extended type }
+    function is_extended(def : tdef) : boolean;
+
+    {# Returns true, if def is a 32 bit integer type }
+    function is_32bitint(def : tdef) : boolean;
+
+    {# Returns true, if def is a 64 bit integer type }
+    function is_64bitint(def : tdef) : boolean;
+
+    {# Returns true, if def is a 64 bit type }
+    function is_64bit(def : tdef) : boolean;
+
+    {# If @var(l) isn't in the range of def a range check error (if not explicit) is generated and
+      the value is placed within the range
+    }
+    procedure testrange(def : tdef;var l : tconstexprint;explicit:boolean);
+
+    {# Returns the range of def, where @var(l) is the low-range and @var(h) is
+      the high-range.
+    }
+    procedure getrange(def : tdef;var l : TConstExprInt;var h : TConstExprInt);
+
+    { some type helper routines for MMX support }
+    function is_mmx_able_array(p : tdef) : boolean;
+
+    {# returns the mmx type }
+    function mmx_type(p : tdef) : tmmxtype;
+
+    {# From a definition return the abstract code generator size enum. It is
+       to note that the value returned can be @var(OS_NO) }
+    function def_cgsize(def: tdef): tcgsize;
+
+
+implementation
+
+    uses
+       systems,verbose;
+
+    { returns true, if def uses FPU }
+    function is_fpu(def : tdef) : boolean;
+      begin
+         is_fpu:=(def.deftype=floatdef);
+      end;
+
+
+    { returns true, if def is a currency type }
+    function is_currency(def : tdef) : boolean;
+      begin
+         case s64currencytype.def.deftype of
+           orddef :
+             result:=(def.deftype=orddef) and
+                     (torddef(s64currencytype.def).typ=torddef(def).typ);
+           floatdef :
+             result:=(def.deftype=floatdef) and
+                     (tfloatdef(s64currencytype.def).typ=tfloatdef(def).typ);
+           else
+             internalerror(200304222);
+         end;
+      end;
+
+
+    { returns true, if def is a single type }
+    function is_single(def : tdef) : boolean;
+      begin
+        result:=(def.deftype=floatdef) and
+          (tfloatdef(def).typ=s32real);
+      end;
+
+
+    { returns true, if def is a double type }
+    function is_double(def : tdef) : boolean;
+      begin
+        result:=(def.deftype=floatdef) and
+          (tfloatdef(def).typ=s64real);
+      end;
+
+
+    function is_extended(def : tdef) : boolean;
+      begin
+        result:=(def.deftype=floatdef) and
+          (tfloatdef(def).typ=s80real);
+      end;
+
+
+    function range_to_basetype(l,h:TConstExprInt):tbasetype;
+      begin
+        { prefer signed over unsigned }
+        if (l>=-128) and (h<=127) then
+         range_to_basetype:=s8bit
+        else if (l>=0) and (h<=255) then
+         range_to_basetype:=u8bit
+        else if (l>=-32768) and (h<=32767) then
+         range_to_basetype:=s16bit
+        else if (l>=0) and (h<=65535) then
+         range_to_basetype:=u16bit
+        else if (l>=low(longint)) and (h<=high(longint)) then
+         range_to_basetype:=s32bit
+        else if (l>=low(cardinal)) and (h<=high(cardinal)) then
+         range_to_basetype:=u32bit
+        else
+         range_to_basetype:=s64bit;
+      end;
+
+
+    procedure range_to_type(l,h:TConstExprInt;var tt:ttype);
+      begin
+        { prefer signed over unsigned }
+        if (l>=-128) and (h<=127) then
+         tt:=s8inttype
+        else if (l>=0) and (h<=255) then
+         tt:=u8inttype
+        else if (l>=-32768) and (h<=32767) then
+         tt:=s16inttype
+        else if (l>=0) and (h<=65535) then
+         tt:=u16inttype
+        else if (l>=low(longint)) and (h<=high(longint)) then
+         tt:=s32inttype
+        else if (l>=low(cardinal)) and (h<=high(cardinal)) then
+         tt:=u32inttype
+        else
+         tt:=s64inttype;
+      end;
+
+
+    procedure int_to_type(v:TConstExprInt;var tt:ttype);
+      begin
+        range_to_type(v,v,tt);
+      end;
+
+
+    { true if p is an ordinal }
+    function is_ordinal(def : tdef) : boolean;
+      var
+         dt : tbasetype;
+      begin
+         case def.deftype of
+           orddef :
+             begin
+               dt:=torddef(def).typ;
+               is_ordinal:=dt in [uchar,uwidechar,
+                                  u8bit,u16bit,u32bit,u64bit,
+                                  s8bit,s16bit,s32bit,s64bit,
+                                  bool8bit,bool16bit,bool32bit];
+             end;
+           enumdef :
+             is_ordinal:=true;
+           else
+             is_ordinal:=false;
+         end;
+      end;
+
+
+    { returns the min. value of the type }
+    function get_min_value(def : tdef) : TConstExprInt;
+      begin
+         case def.deftype of
+           orddef:
+             get_min_value:=torddef(def).low;
+           enumdef:
+             get_min_value:=tenumdef(def).min;
+           else
+             get_min_value:=0;
+         end;
+      end;
+
+
+    { true if p is an integer }
+    function is_integer(def : tdef) : boolean;
+      begin
+        is_integer:=(def.deftype=orddef) and
+                    (torddef(def).typ in [u8bit,u16bit,u32bit,u64bit,
+                                          s8bit,s16bit,s32bit,s64bit]);
+      end;
+
+
+    { true if p is a boolean }
+    function is_boolean(def : tdef) : boolean;
+      begin
+        is_boolean:=(def.deftype=orddef) and
+                    (torddef(def).typ in [bool8bit,bool16bit,bool32bit]);
+      end;
+
+
+    { true if p is a void }
+    function is_void(def : tdef) : boolean;
+      begin
+        is_void:=(def.deftype=orddef) and
+                 (torddef(def).typ=uvoid);
+      end;
+
+
+    { true if p is a char }
+    function is_char(def : tdef) : boolean;
+      begin
+        is_char:=(def.deftype=orddef) and
+                 (torddef(def).typ=uchar);
+      end;
+
+
+    { true if p is a wchar }
+    function is_widechar(def : tdef) : boolean;
+      begin
+        is_widechar:=(def.deftype=orddef) and
+                 (torddef(def).typ=uwidechar);
+      end;
+
+
+    { true if p is signed (integer) }
+    function is_signed(def : tdef) : boolean;
+      var
+         dt : tbasetype;
+      begin
+         case def.deftype of
+           orddef :
+             begin
+               dt:=torddef(def).typ;
+               is_signed:=(dt in [s8bit,s16bit,s32bit,s64bit,scurrency]);
+             end;
+           enumdef :
+             is_signed:=tenumdef(def).min < 0;
+           arraydef :
+             is_signed:=is_signed(tarraydef(def).rangetype.def);
+           else
+             is_signed:=false;
+         end;
+      end;
+
+
+    function is_in_limit(def_from,def_to : tdef) : boolean;
+
+      var
+        fromqword, toqword: boolean;
+
+      begin
+         if (def_from.deftype <> orddef) or
+            (def_to.deftype <> orddef) then
+           begin
+             is_in_limit := false;
+             exit;
+           end;
+         fromqword := torddef(def_from).typ = u64bit;
+         toqword := torddef(def_to).typ = u64bit;
+         is_in_limit:=(toqword and is_signed(def_from)) or
+                      ((not fromqword) and
+                       (torddef(def_from).low>=torddef(def_to).low) and
+                       (torddef(def_from).high<=torddef(def_to).high));
+      end;
+
+
+    function is_in_limit_value(val_from:TConstExprInt;def_from,def_to : tdef) : boolean;
+
+      begin
+         if (def_from.deftype <> orddef) and
+            (def_to.deftype <> orddef) then
+           internalerror(200210062);
+         if (torddef(def_to).typ = u64bit) then
+          begin
+            is_in_limit_value:=((TConstExprUInt(val_from)>=TConstExprUInt(torddef(def_to).low)) and
+                                (TConstExprUInt(val_from)<=TConstExprUInt(torddef(def_to).high)));
+          end
+         else
+          begin;
+            is_in_limit_value:=((val_from>=torddef(def_to).low) and
+                                (val_from<=torddef(def_to).high));
+          end;
+      end;
+
+
+    { true, if p points to an open array def }
+    function is_open_string(p : tdef) : boolean;
+      begin
+         is_open_string:=(p.deftype=stringdef) and
+                         (tstringdef(p).string_typ=st_shortstring) and
+                         (tstringdef(p).len=0);
+      end;
+
+
+    { true, if p points to a zero based array def }
+    function is_zero_based_array(p : tdef) : boolean;
+      begin
+         is_zero_based_array:=(p.deftype=arraydef) and
+                              (tarraydef(p).lowrange=0) and
+                              not(is_special_array(p));
+      end;
+
+    { true if p points to a dynamic array def }
+    function is_dynamic_array(p : tdef) : boolean;
+      begin
+         is_dynamic_array:=(p.deftype=arraydef) and
+           tarraydef(p).IsDynamicArray;
+      end;
+
+
+    { true, if p points to an open array def }
+    function is_open_array(p : tdef) : boolean;
+      begin
+         { check for s32inttype is needed, because for u32bit the high
+           range is also -1 ! (PFV) }
+         is_open_array:=(p.deftype=arraydef) and
+                        (tarraydef(p).rangetype.def=s32inttype.def) and
+                        (tarraydef(p).lowrange=0) and
+                        (tarraydef(p).highrange=-1) and
+                        not(tarraydef(p).IsConstructor) and
+                        not(tarraydef(p).IsVariant) and
+                        not(tarraydef(p).IsArrayOfConst) and
+                        not(tarraydef(p).IsDynamicArray);
+
+      end;
+
+    { true, if p points to an array of const def }
+    function is_array_constructor(p : tdef) : boolean;
+      begin
+         is_array_constructor:=(p.deftype=arraydef) and
+                        (tarraydef(p).IsConstructor);
+      end;
+
+    { true, if p points to a variant array }
+    function is_variant_array(p : tdef) : boolean;
+      begin
+         is_variant_array:=(p.deftype=arraydef) and
+                        (tarraydef(p).IsVariant);
+      end;
+
+    { true, if p points to an array of const }
+    function is_array_of_const(p : tdef) : boolean;
+      begin
+         is_array_of_const:=(p.deftype=arraydef) and
+                        (tarraydef(p).IsArrayOfConst);
+      end;
+
+    { true, if p points to a special array }
+    function is_special_array(p : tdef) : boolean;
+      begin
+         is_special_array:=(p.deftype=arraydef) and
+                        ((tarraydef(p).IsVariant) or
+                         (tarraydef(p).IsArrayOfConst) or
+                         (tarraydef(p).IsConstructor) or
+                         (tarraydef(p).IsDynamicArray) or
+                         is_open_array(p)
+                        );
+      end;
+
+{$ifdef ansistring_bits}
+    { true if p is an ansi string def }
+    function is_ansistring(p : tdef) : boolean;
+      begin
+         is_ansistring:=(p.deftype=stringdef) and
+                        (tstringdef(p).string_typ in [st_ansistring16,st_ansistring32,st_ansistring64]);
+      end;
+{$else}
+    { true if p is an ansi string def }
+    function is_ansistring(p : tdef) : boolean;
+      begin
+         is_ansistring:=(p.deftype=stringdef) and
+                        (tstringdef(p).string_typ=st_ansistring);
+      end;
+{$endif}
+
+    { true if p is an long string def }
+    function is_longstring(p : tdef) : boolean;
+      begin
+         is_longstring:=(p.deftype=stringdef) and
+                        (tstringdef(p).string_typ=st_longstring);
+      end;
+
+
+    { true if p is an wide string def }
+    function is_widestring(p : tdef) : boolean;
+      begin
+         is_widestring:=(p.deftype=stringdef) and
+                        (tstringdef(p).string_typ=st_widestring);
+      end;
+
+
+    { true if p is an short string def }
+    function is_shortstring(p : tdef) : boolean;
+      begin
+         is_shortstring:=(p.deftype=stringdef) and
+                         (tstringdef(p).string_typ=st_shortstring);
+      end;
+
+    { true if p is a char array def }
+    function is_chararray(p : tdef) : boolean;
+      begin
+        is_chararray:=(p.deftype=arraydef) and
+                      is_char(tarraydef(p).elementtype.def) and
+                      not(is_special_array(p));
+      end;
+
+    { true if p is a widechar array def }
+    function is_widechararray(p : tdef) : boolean;
+      begin
+        is_widechararray:=(p.deftype=arraydef) and
+                          is_widechar(tarraydef(p).elementtype.def) and
+                          not(is_special_array(p));
+      end;
+
+
+    { true if p is a open char array def }
+    function is_open_chararray(p : tdef) : boolean;
+      begin
+        is_open_chararray:= is_open_array(p) and
+                            is_char(tarraydef(p).elementtype.def);
+      end;
+
+    { true if p is a open wide char array def }
+    function is_open_widechararray(p : tdef) : boolean;
+      begin
+        is_open_widechararray:= is_open_array(p) and
+                                is_widechar(tarraydef(p).elementtype.def);
+      end;
+
+    { true if p is a pchar def }
+    function is_pchar(p : tdef) : boolean;
+      begin
+        is_pchar:=(p.deftype=pointerdef) and
+                  (is_char(tpointerdef(p).pointertype.def) or
+                   (is_zero_based_array(tpointerdef(p).pointertype.def) and
+                    is_chararray(tpointerdef(p).pointertype.def)));
+      end;
+
+    { true if p is a pchar def }
+    function is_pwidechar(p : tdef) : boolean;
+      begin
+        is_pwidechar:=(p.deftype=pointerdef) and
+                      (is_widechar(tpointerdef(p).pointertype.def) or
+                       (is_zero_based_array(tpointerdef(p).pointertype.def) and
+                        is_widechararray(tpointerdef(p).pointertype.def)));
+      end;
+
+
+    { true if p is a voidpointer def }
+    function is_voidpointer(p : tdef) : boolean;
+      begin
+        is_voidpointer:=(p.deftype=pointerdef) and
+                        (tpointerdef(p).pointertype.def.deftype=orddef) and
+                        (torddef(tpointerdef(p).pointertype.def).typ=uvoid);
+      end;
+
+
+    { true if p is a smallset def }
+    function is_smallset(p : tdef) : boolean;
+      begin
+        is_smallset:=(p.deftype=setdef) and
+                     (tsetdef(p).settype=smallset);
+      end;
+
+
+    { true, if def is a 32 bit int type }
+    function is_32bitint(def : tdef) : boolean;
+      begin
+         result:=(def.deftype=orddef) and (torddef(def).typ in [u32bit,s32bit])
+      end;
+
+
+    { true, if def is a 64 bit int type }
+    function is_64bitint(def : tdef) : boolean;
+      begin
+         is_64bitint:=(def.deftype=orddef) and (torddef(def).typ in [u64bit,s64bit])
+      end;
+
+
+    { true, if def is a 64 bit type }
+    function is_64bit(def : tdef) : boolean;
+      begin
+         is_64bit:=(def.deftype=orddef) and (torddef(def).typ in [u64bit,s64bit,scurrency])
+      end;
+
+
+    { if l isn't in the range of def a range check error (if not explicit) is generated and
+      the value is placed within the range }
+    procedure testrange(def : tdef;var l : tconstexprint;explicit:boolean);
+      var
+         lv,hv: TConstExprInt;
+         error: boolean;
+      begin
+         error := false;
+         { for 64 bit types we need only to check if it is less than }
+         { zero, if def is a qword node                              }
+         if is_64bitint(def) then
+           begin
+              if (l<0) and (torddef(def).typ=u64bit) then
+                begin
+                   { don't zero the result, because it may come from hex notation
+                     like $ffffffffffffffff! (JM)
+                   l:=0; }
+                   if not explicit then
+                    begin
+                      if (cs_check_range in aktlocalswitches) then
+                        Message(parser_e_range_check_error)
+                      else
+                        Message(parser_w_range_check_error);
+                    end;
+                   error := true;
+                end;
+           end
+         else
+           begin
+              getrange(def,lv,hv);
+              if (l<lv) or (l>hv) then
+                begin
+                   if not explicit then
+                    begin
+                      if ((def.deftype=enumdef) and
+                          { delphi allows range check errors in
+                           enumeration type casts FK }
+                          not(m_delphi in aktmodeswitches)) or
+                         (cs_check_range in aktlocalswitches) then
+                        Message(parser_e_range_check_error)
+                      else
+                        Message(parser_w_range_check_error);
+                    end;
+                   error := true;
+                end;
+           end;
+         if error then
+          begin
+             { Fix the value to fit in the allocated space for this type of variable }
+             case longint(def.size) of
+               1: l := l and $ff;
+               2: l := l and $ffff;
+               { work around sign extension bug (to be fixed) (JM) }
+               4: l := l and (int64($fffffff) shl 4 + $f);
+             end;
+             { do sign extension if necessary (JM) }
+             if is_signed(def) then
+              begin
+                case longint(def.size) of
+                  1: l := shortint(l);
+                  2: l := smallint(l);
+                  4: l := longint(l);
+                end;
+              end;
+          end;
+      end;
+
+
+    { return the range from def in l and h }
+    procedure getrange(def : tdef;var l : TConstExprInt;var h : TConstExprInt);
+      begin
+        case def.deftype of
+          orddef :
+            begin
+              l:=torddef(def).low;
+              h:=torddef(def).high;
+            end;
+          enumdef :
+            begin
+              l:=tenumdef(def).min;
+              h:=tenumdef(def).max;
+            end;
+          arraydef :
+            begin
+              l:=tarraydef(def).lowrange;
+              h:=tarraydef(def).highrange;
+            end;
+        else
+          internalerror(987);
+        end;
+      end;
+
+
+    function mmx_type(p : tdef) : tmmxtype;
+      begin
+         mmx_type:=mmxno;
+         if is_mmx_able_array(p) then
+           begin
+              if tarraydef(p).elementtype.def.deftype=floatdef then
+                case tfloatdef(tarraydef(p).elementtype.def).typ of
+                  s32real:
+                    mmx_type:=mmxsingle;
+                end
+              else
+                case torddef(tarraydef(p).elementtype.def).typ of
+                   u8bit:
+                     mmx_type:=mmxu8bit;
+                   s8bit:
+                     mmx_type:=mmxs8bit;
+                   u16bit:
+                     mmx_type:=mmxu16bit;
+                   s16bit:
+                     mmx_type:=mmxs16bit;
+                   u32bit:
+                     mmx_type:=mmxu32bit;
+                   s32bit:
+                     mmx_type:=mmxs32bit;
+                end;
+           end;
+      end;
+
+
+    function is_mmx_able_array(p : tdef) : boolean;
+      begin
+{$ifdef SUPPORT_MMX}
+         if (cs_mmx_saturation in aktlocalswitches) then
+           begin
+              is_mmx_able_array:=(p.deftype=arraydef) and
+                not(is_special_array(p)) and
+                (
+                 (
+                  (tarraydef(p).elementtype.def.deftype=orddef) and
+                  (
+                   (
+                    (tarraydef(p).lowrange=0) and
+                    (tarraydef(p).highrange=1) and
+                    (torddef(tarraydef(p).elementtype.def).typ in [u32bit,s32bit])
+                   )
+                   or
+                   (
+                    (tarraydef(p).lowrange=0) and
+                    (tarraydef(p).highrange=3) and
+                    (torddef(tarraydef(p).elementtype.def).typ in [u16bit,s16bit])
+                   )
+                  )
+                 )
+                 or
+                (
+                 (
+                  (tarraydef(p).elementtype.def.deftype=floatdef) and
+                  (
+                   (tarraydef(p).lowrange=0) and
+                   (tarraydef(p).highrange=1) and
+                   (tfloatdef(tarraydef(p).elementtype.def).typ=s32real)
+                  )
+                 )
+                )
+              );
+           end
+         else
+           begin
+              is_mmx_able_array:=(p.deftype=arraydef) and
+                (
+                 (
+                  (tarraydef(p).elementtype.def.deftype=orddef) and
+                  (
+                   (
+                    (tarraydef(p).lowrange=0) and
+                    (tarraydef(p).highrange=1) and
+                    (torddef(tarraydef(p).elementtype.def).typ in [u32bit,s32bit])
+                   )
+                   or
+                   (
+                    (tarraydef(p).lowrange=0) and
+                    (tarraydef(p).highrange=3) and
+                    (torddef(tarraydef(p).elementtype.def).typ in [u16bit,s16bit])
+                   )
+                   or
+                   (
+                    (tarraydef(p).lowrange=0) and
+                    (tarraydef(p).highrange=7) and
+                    (torddef(tarraydef(p).elementtype.def).typ in [u8bit,s8bit])
+                   )
+                  )
+                 )
+                 or
+                 (
+                  (tarraydef(p).elementtype.def.deftype=floatdef) and
+                  (
+                   (tarraydef(p).lowrange=0) and
+                   (tarraydef(p).highrange=1) and
+                   (tfloatdef(tarraydef(p).elementtype.def).typ=s32real)
+                  )
+                 )
+                );
+           end;
+{$else SUPPORT_MMX}
+         is_mmx_able_array:=false;
+{$endif SUPPORT_MMX}
+      end;
+
+
+    function def_cgsize(def: tdef): tcgsize;
+      begin
+        case def.deftype of
+          orddef,
+          enumdef,
+          setdef:
+            begin
+              result:=int_cgsize(def.size);
+              if is_signed(def) then
+                result:=tcgsize(ord(result)+(ord(OS_S8)-ord(OS_8)));
+            end;
+          classrefdef,
+          pointerdef:
+            result := OS_ADDR;
+          procvardef:
+            begin
+              if tprocvardef(def).is_methodpointer and
+                 (not tprocvardef(def).is_addressonly) then
+                result := OS_64
+              else
+                result := OS_ADDR;
+            end;
+          stringdef :
+            begin
+              if is_ansistring(def) or is_widestring(def) then
+                result := OS_ADDR
+              else
+                result:=int_cgsize(def.size);
+            end;
+          objectdef :
+            begin
+              if is_class_or_interface(def) then
+                result := OS_ADDR
+              else
+                result:=int_cgsize(def.size);
+            end;
+          floatdef:
+            result := tfloat2tcgsize[tfloatdef(def).typ];
+          recorddef :
+            result:=int_cgsize(def.size);
+          arraydef :
+            begin
+              if not is_special_array(def) then
+                result := int_cgsize(def.size)
+              else
+                begin
+                  if is_dynamic_array(def) then
+                    result := OS_ADDR
+                  else
+                    result := OS_NO;
+                end;
+            end;
+          else
+            begin
+              { undefined size }
+              result:=OS_NO;
+            end;
+        end;
+      end;
+
+
+end.

compiler/dwarf.pas

@@ -0,0 +1,419 @@
+{
+    Copyright (c) 2003-2004 by Peter Vreman and Florian Klaempfl
+
+    This units contains special support for DWARF debug info
+
+    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 dwarf;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+      cclasses,
+      globtype,
+      cgbase,cpubase,
+      aasmbase,aasmtai;
+
+    const
+      maxdwarfops = 2;
+
+    type
+      tdwarfoperenc=(doe_uleb,doe_sleb,doe_ptr,doe_32bit,doe_16bit,doe_8bit);
+      tdwarfopertype=(dop_reg,dop_const,dop_sym,dop_reloffset);
+
+      tdwarfoper=record
+        enc : tdwarfoperenc;
+        case typ:tdwarfopertype of
+          dop_reg : (register:tregister);
+          dop_const : (value:int64);
+          dop_sym : (sym:tasmsymbol);
+          dop_reloffset : (beginsym,endsym:tasmsymbol);
+      end;
+
+      tdwarfitem=class(TLinkedListItem)
+        op   : byte;
+        ops  : byte;
+        oper : array[0..maxdwarfops-1] of tdwarfoper;
+        constructor create(aop:longint);
+        constructor create_reg(aop:longint;enc1:tdwarfoperenc;reg:tregister);
+        constructor create_const(aop:longint;enc1:tdwarfoperenc;val:int64);
+        constructor create_reloffset(aop:longint;enc1:tdwarfoperenc;beginlab,endlab:tasmsymbol);
+        constructor create_reg_const(aop:longint;enc1:tdwarfoperenc;reg:tregister;enc2:tdwarfoperenc;val:longint);
+        procedure generate_code(list:taasmoutput);
+      end;
+
+      tdwarf=class
+      private
+        FDwarfList : TLinkedList;
+      public
+        constructor create;
+        destructor destroy;override;
+        property DwarfList:TlinkedList read FDwarfList;
+      end;
+
+      tdwarfcfi=class(tdwarf)
+      private
+        FFrameStartLabel,
+        FFrameEndLabel,
+        FLastloclabel : tasmlabel;
+        procedure cfa_advance_loc(list:taasmoutput);
+      protected
+        code_alignment_factor,
+        data_alignment_factor : shortint;
+      public
+        constructor create;
+        procedure generate_code(list:taasmoutput);
+        { operations }
+        procedure start_frame(list:taasmoutput);
+        procedure end_frame(list:taasmoutput);
+        procedure cfa_offset(list:taasmoutput;reg:tregister;ofs:longint);
+        procedure cfa_restore(list:taasmoutput;reg:tregister);
+        procedure cfa_def_cfa_register(list:taasmoutput;reg:tregister);
+        procedure cfa_def_cfa_offset(list:taasmoutput;ofs:longint);
+      end;
+
+
+    var
+      dwarfcfi : tdwarfcfi;
+
+    function dwarf_reg(r:tregister):longint;
+
+
+implementation
+
+    uses
+      verbose;
+
+    const
+      { Call frame information }
+      DW_CFA_set_loc          = $01;
+      DW_CFA_advance_loc1     = $02;
+      DW_CFA_advance_loc2     = $03;
+      DW_CFA_advance_loc4     = $04;
+      DW_CFA_offset_extended  = $05;
+      DW_CFA_restore_extended = $06;
+      DW_CFA_def_cfa          = $0c;
+      DW_CFA_def_cfa_register = $0d;
+      DW_CFA_def_cfa_offset   = $0e;
+      { Own additions }
+      DW_CFA_start_frame = $f0;
+      DW_CFA_end_frame   = $f1;
+
+
+{****************************************************************************
+                                  Helpers
+****************************************************************************}
+
+    function dwarf_reg(r:tregister):longint;
+      begin
+        result:=regdwarf_table[findreg_by_number(r)];
+      end;
+
+
+{****************************************************************************
+                                  TDWARF
+****************************************************************************}
+
+    constructor tdwarf.create;
+      begin
+        FDwarfList:=TLinkedList.Create;
+      end;
+
+
+    destructor tdwarf.destroy;
+      begin
+        FDwarfList.Free;
+      end;
+
+
+{****************************************************************************
+                                TDWARFITEM
+****************************************************************************}
+
+    constructor tdwarfitem.create(aop:longint);
+      begin
+        inherited create;
+        op:=aop;
+        ops:=0;
+      end;
+
+
+    constructor tdwarfitem.create_reg(aop:longint;enc1:tdwarfoperenc;reg:tregister);
+      begin
+        inherited create;
+        op:=aop;
+        ops:=1;
+        oper[0].typ:=dop_reg;
+        oper[0].enc:=enc1;
+        oper[0].register:=reg;
+      end;
+
+
+    constructor tdwarfitem.create_const(aop:longint;enc1:tdwarfoperenc;val:int64);
+      begin
+        inherited create;
+        op:=aop;
+        ops:=1;
+        oper[0].typ:=dop_const;
+        oper[0].enc:=enc1;
+        oper[0].value:=val;
+      end;
+
+
+    constructor tdwarfitem.create_reloffset(aop:longint;enc1:tdwarfoperenc;beginlab,endlab:tasmsymbol);
+      begin
+        inherited create;
+        op:=aop;
+        ops:=1;
+        { relative offsets are passed }
+        oper[0].typ:=dop_reloffset;
+        oper[0].enc:=enc1;
+        oper[0].beginsym:=beginlab;
+        oper[0].endsym:=endlab;
+      end;
+
+
+    constructor tdwarfitem.create_reg_const(aop:longint;enc1:tdwarfoperenc;reg:tregister;enc2:tdwarfoperenc;val:longint);
+      begin
+        inherited create;
+        op:=aop;
+        ops:=2;
+        oper[0].typ:=dop_reg;
+        oper[0].enc:=enc1;
+        oper[0].register:=reg;
+        oper[1].typ:=dop_const;
+        oper[1].enc:=enc2;
+        oper[1].value:=val;
+      end;
+
+
+    procedure tdwarfitem.generate_code(list:taasmoutput);
+      const
+        enc2ait_const : array[tdwarfoperenc] of taitype = (
+          ait_const_uleb128bit,ait_const_sleb128bit,ait_const_ptr,
+          ait_const_32bit,ait_const_16bit,ait_const_8bit
+        );
+      var
+        i : integer;
+      begin
+        list.concat(tai_const.create_8bit(op));
+        for i:=0 to ops-1 do
+          begin
+            case oper[i].typ of
+              dop_const :
+                list.concat(tai_const.create(enc2ait_const[oper[i].enc],oper[i].value));
+              dop_sym :
+                begin
+                  if oper[i].enc<>doe_ptr then
+                    internalerror(200404127);
+                  list.concat(tai_const.create_sym(oper[i].sym));
+                end;
+              dop_reloffset :
+                list.concat(tai_const.create_rel_sym(enc2ait_const[oper[i].enc],oper[i].beginsym,oper[i].endsym));
+              dop_reg :
+                list.concat(tai_const.create(enc2ait_const[oper[i].enc],regdwarf_table[findreg_by_number(oper[i].register)]));
+              else
+                internalerror(200404128);
+            end;
+          end;
+      end;
+
+
+{****************************************************************************
+                                 TDWARFCFI
+****************************************************************************}
+
+    constructor tdwarfcfi.create;
+      begin
+        inherited create;
+        FFrameStartLabel:=nil;
+        FFrameEndLabel:=nil;
+        FLastLocLabel:=nil;
+        code_alignment_factor:=1;
+        data_alignment_factor:=-1;
+      end;
+
+
+    procedure tdwarfcfi.generate_code(list:taasmoutput);
+      var
+        hp : tdwarfitem;
+        cielabel,
+        lenstartlabel,
+        lenendlabel    : tasmlabel;
+        tc             : tai_const;
+      begin
+        new_section(list,sec_debug_frame,'',0);
+        { CIE
+           DWORD   length
+           DWORD   CIE_Id = 0xffffffff
+           BYTE    version = 1
+           STRING  augmentation = "" = BYTE 0
+           ULEB128 code alignment factor = 1
+           ULEB128 data alignment factor = -1
+           BYTE    return address register
+           <...>   start sequence
+        }
+        objectlibrary.getlabel(cielabel);
+        list.concat(tai_label.create(cielabel));
+        objectlibrary.getlabel(lenstartlabel);
+        objectlibrary.getlabel(lenendlabel);
+        list.concat(tai_const.create_rel_sym(ait_const_32bit,lenstartlabel,lenendlabel));
+        list.concat(tai_label.create(lenstartlabel));
+        list.concat(tai_const.create_32bit(longint($ffffffff)));
+        list.concat(tai_const.create_8bit(1));
+        list.concat(tai_const.create_8bit(0)); { empty string }
+        list.concat(tai_const.create_uleb128bit(code_alignment_factor));
+        list.concat(tai_const.create_sleb128bit(data_alignment_factor));
+        list.concat(tai_const.create_8bit(dwarf_reg(NR_RETURN_ADDRESS_REG)));
+        { Generate standard code
+            def_cfa(stackpointer,sizeof(aint))
+            cfa_offset_extended(returnaddres,-sizeof(aint))
+        }
+{$warning TODO This needs to be target dependent}
+        list.concat(tai_const.create_8bit(DW_CFA_def_cfa));
+        list.concat(tai_const.create_uleb128bit(dwarf_reg(NR_STACK_POINTER_REG)));
+        list.concat(tai_const.create_uleb128bit(sizeof(aint)));
+        list.concat(tai_const.create_8bit(DW_CFA_offset_extended));
+        list.concat(tai_const.create_uleb128bit(dwarf_reg(NR_RETURN_ADDRESS_REG)));
+        list.concat(tai_const.create_uleb128bit((-sizeof(aint)) div data_alignment_factor));
+        list.concat(cai_align.create_zeros(4));
+        list.concat(tai_label.create(lenendlabel));
+        lenstartlabel:=nil;
+        lenendlabel:=nil;
+
+        hp:=TDwarfItem(Dwarflist.first);
+        while assigned(hp) do
+          begin
+            case hp.op of
+              DW_CFA_Start_Frame :
+                begin
+                  if assigned(lenstartlabel) then
+                    internalerror(200404125);
+                  if (hp.ops<>1) or
+                     (hp.oper[0].typ<>dop_reloffset) then
+                    internalerror(200404126);
+                  objectlibrary.getlabel(lenstartlabel);
+                  objectlibrary.getlabel(lenendlabel);
+                  { FDE
+                     DWORD length
+                     DWORD CIE-pointer = cielabel
+                     PTRSIZE initial location = oper[0]
+                     PTRSIZE function size = oper[1]
+                  }
+                  list.concat(tai_const.create_rel_sym(ait_const_32bit,lenstartlabel,lenendlabel));
+                  list.concat(tai_label.create(lenstartlabel));
+                  { force label offset to 32bit }
+                  tc:=tai_const.create_sym(cielabel);
+                  tc.typ:=ait_const_32bit;
+                  list.concat(tc);
+                  list.concat(tai_const.create_sym(hp.oper[0].beginsym));
+                  list.concat(tai_const.create_rel_sym(ait_const_ptr,hp.oper[0].beginsym,hp.oper[0].endsym));
+                end;
+              DW_CFA_End_Frame :
+                begin
+                  list.concat(cai_align.create_zeros(4));
+                  list.concat(tai_label.create(lenendlabel));
+                  lenstartlabel:=nil;
+                  lenendlabel:=nil;
+                end;
+              else
+                hp.generate_code(list);
+            end;
+            hp:=TDwarfItem(hp.next);
+          end;
+        { Check for open frames }
+        if assigned(lenstartlabel) then
+          internalerror(2004041210);
+        { Dwarflist is processed, remove items }
+        DwarfList.Clear;
+      end;
+
+
+    procedure tdwarfcfi.start_frame(list:taasmoutput);
+      begin
+        if assigned(FFrameStartLabel) then
+          internalerror(200404129);
+        objectlibrary.getlabel(FFrameStartLabel);
+        objectlibrary.getlabel(FFrameEndLabel);
+        FLastloclabel:=FFrameStartLabel;
+        list.concat(tai_label.create(FFrameStartLabel));
+        dwarflist.concat(tdwarfitem.create_reloffset(DW_CFA_start_frame,doe_32bit,FFrameStartLabel,FFrameEndLabel));
+      end;
+
+
+    procedure tdwarfcfi.end_frame(list:taasmoutput);
+      begin
+        if not assigned(FFrameStartLabel) then
+          internalerror(2004041213);
+        dwarflist.concat(tdwarfitem.create(DW_CFA_end_frame));
+        list.concat(tai_label.create(FFrameEndLabel));
+        FFrameStartLabel:=nil;
+        FFrameEndLabel:=nil;
+        FLastLocLabel:=nil;
+      end;
+
+
+    procedure tdwarfcfi.cfa_advance_loc(list:taasmoutput);
+      var
+        currloclabel : tasmlabel;
+      begin
+        if FLastloclabel=nil then
+          internalerror(200404082);
+        objectlibrary.getlabel(currloclabel);
+        list.concat(tai_label.create(currloclabel));
+        dwarflist.concat(tdwarfitem.create_reloffset(DW_CFA_advance_loc4,doe_32bit,FLastloclabel,currloclabel));
+        FLastloclabel:=currloclabel;
+      end;
+
+
+    procedure tdwarfcfi.cfa_offset(list:taasmoutput;reg:tregister;ofs:longint);
+      begin
+        cfa_advance_loc(list);
+{$warning TODO check if ref is a temp}
+        { offset must be positive }
+        dwarflist.concat(tdwarfitem.create_reg_const(DW_CFA_offset_extended,doe_uleb,reg,doe_uleb,ofs div data_alignment_factor));
+      end;
+
+
+    procedure tdwarfcfi.cfa_restore(list:taasmoutput;reg:tregister);
+      begin
+        cfa_advance_loc(list);
+        dwarflist.concat(tdwarfitem.create_reg(DW_CFA_restore_extended,doe_uleb,reg));
+      end;
+
+
+    procedure tdwarfcfi.cfa_def_cfa_register(list:taasmoutput;reg:tregister);
+      begin
+        cfa_advance_loc(list);
+        dwarflist.concat(tdwarfitem.create_reg(DW_CFA_def_cfa_register,doe_uleb,reg));
+      end;
+
+
+    procedure tdwarfcfi.cfa_def_cfa_offset(list:taasmoutput;ofs:longint);
+      begin
+        cfa_advance_loc(list);
+        dwarflist.concat(tdwarfitem.create_const(DW_CFA_def_cfa_offset,doe_uleb,ofs));
+      end;
+
+
+begin
+{$warning TODO Maybe initialize per module}
+  dwarfcfi:=tdwarfcfi.create;
+end.

compiler/export.pas

@@ -0,0 +1,179 @@
+{
+    Copyright (c) 1998-2002 by Florian Klaempfl
+
+    This unit implements an uniform export 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 export;
+
+{$i fpcdefs.inc}
+
+interface
+
+uses
+  cutils,cclasses,
+  systems,
+  symtype,
+  aasmbase;
+
+const
+   { export options }
+   eo_resident = $1;
+   eo_index    = $2;
+   eo_name     = $4;
+
+type
+   texported_item = class(TLinkedListItem)
+      sym : tsym;
+      index : longint;
+      name : pstring;
+      options : word;
+      is_var : boolean;
+      constructor create;
+      destructor destroy;override;
+   end;
+
+   texportlib=class
+   private
+      notsupmsg : boolean;
+      procedure NotSupported;
+   public
+      edatalabel : tasmlabel;
+      constructor Create;virtual;
+      destructor Destroy;override;
+      procedure preparelib(const s : string);virtual;
+      procedure exportprocedure(hp : texported_item);virtual;
+      procedure exportvar(hp : texported_item);virtual;
+      procedure generatelib;virtual;
+   end;
+
+   TExportLibClass=class of TExportLib;
+
+var
+  CExportLib : array[tsystem] of TExportLibClass;
+  ExportLib  : TExportLib;
+
+procedure RegisterExport(t:tsystem;c:TExportLibClass);
+procedure InitExport;
+procedure DoneExport;
+
+implementation
+
+uses
+  verbose,globals;
+
+{****************************************************************************
+                           TExported_procedure
+****************************************************************************}
+
+constructor texported_item.Create;
+begin
+  inherited Create;
+  sym:=nil;
+  index:=-1;
+  name:=nil;
+  options:=0;
+  is_var:=false;
+end;
+
+
+destructor texported_item.destroy;
+begin
+  stringdispose(name);
+  inherited destroy;
+end;
+
+
+{****************************************************************************
+                              TExportLib
+****************************************************************************}
+
+constructor texportlib.Create;
+begin
+  notsupmsg:=false;
+  edatalabel:=nil;
+end;
+
+
+destructor texportlib.Destroy;
+begin
+end;
+
+
+procedure texportlib.NotSupported;
+begin
+  { show the message only once }
+  if not notsupmsg then
+   begin
+     Message(exec_e_dll_not_supported);
+     notsupmsg:=true;
+   end;
+end;
+
+
+procedure texportlib.preparelib(const s:string);
+begin
+  NotSupported;
+end;
+
+
+procedure texportlib.exportprocedure(hp : texported_item);
+begin
+  NotSupported;
+end;
+
+
+procedure texportlib.exportvar(hp : texported_item);
+begin
+  NotSupported;
+end;
+
+
+procedure texportlib.generatelib;
+begin
+  NotSupported;
+end;
+
+
+{*****************************************************************************
+                                 Init/Done
+*****************************************************************************}
+
+procedure RegisterExport(t:tsystem;c:TExportLibClass);
+begin
+  CExportLib[t]:=c;
+end;
+
+
+procedure InitExport;
+begin
+  if assigned(CExportLib[target_info.system]) then
+   exportlib:=CExportLib[target_info.system].Create
+  else
+   exportlib:=TExportLib.Create;
+end;
+
+
+procedure DoneExport;
+begin
+  if assigned(Exportlib) then
+    Exportlib.free;
+end;
+
+
+end.

compiler/finput.pas

@@ -0,0 +1,740 @@
+{
+    Copyright (c) 1998-2002 by Florian Klaempfl
+
+    This unit implements an extended file management
+
+    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 finput;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+      cutils,cclasses;
+
+    const
+       InputFileBufSize=32*1024;
+       linebufincrease=512;
+
+    type
+       tlongintarr = array[0..1000000] of longint;
+       plongintarr = ^tlongintarr;
+
+       tinputfile = class
+         path,name : pstring;       { path and filename }
+         next      : tinputfile;    { next file for reading }
+
+         is_macro,
+         endoffile,                 { still bytes left to read }
+         closed       : boolean;    { is the file closed }
+
+         buf          : pchar;      { buffer }
+         bufstart,                  { buffer start position in the file }
+         bufsize,                   { amount of bytes in the buffer }
+         maxbufsize   : longint;    { size in memory for the buffer }
+
+         saveinputpointer : pchar;  { save fields for scanner variables }
+         savelastlinepos,
+         saveline_no      : longint;
+
+         linebuf    : plongintarr;  { line buffer to retrieve lines }
+         maxlinebuf : longint;
+
+         ref_index  : longint;      { to handle the browser refs }
+         ref_next   : tinputfile;
+
+         constructor create(const fn:string);
+         destructor  destroy;override;
+         procedure setpos(l:longint);
+         procedure seekbuf(fpos:longint);
+         procedure readbuf;
+         function  open:boolean;
+         procedure close;
+         procedure tempclose;
+         function  tempopen:boolean;
+         procedure setmacro(p:pchar;len:longint);
+         procedure setline(line,linepos:longint);
+         function  getlinestr(l:longint):string;
+         function  getfiletime:longint;
+       protected
+         filetime  : longint;
+         function fileopen(const filename: string): boolean; virtual; abstract;
+         function fileseek(pos: longint): boolean; virtual; abstract;
+         function fileread(var databuf; maxsize: longint): longint; virtual; abstract;
+         function fileeof: boolean; virtual; abstract;
+         function fileclose: boolean; virtual; abstract;
+         procedure filegettime; virtual; abstract;
+       end;
+
+       tdosinputfile = class(tinputfile)
+       protected
+         function fileopen(const filename: string): boolean; override;
+         function fileseek(pos: longint): boolean; override;
+         function fileread(var databuf; maxsize: longint): longint; override;
+         function fileeof: boolean; override;
+         function fileclose: boolean; override;
+         procedure filegettime; override;
+       private
+         f            : file;       { current file handle }
+       end;
+
+       tinputfilemanager = class
+          files : tinputfile;
+          last_ref_index : longint;
+          cacheindex : longint;
+          cacheinputfile : tinputfile;
+          constructor create;
+          destructor destroy;override;
+          procedure register_file(f : tinputfile);
+          procedure inverse_register_indexes;
+          function  get_file(l:longint) : tinputfile;
+          function  get_file_name(l :longint):string;
+          function  get_file_path(l :longint):string;
+       end;
+
+{****************************************************************************
+                                TModuleBase
+ ****************************************************************************}
+
+     type
+        tmodulestate = (ms_unknown,
+          ms_registered,
+          ms_load,ms_compile,
+          ms_second_load,ms_second_compile,
+          ms_compiled
+        );
+     const
+        ModuleStateStr : array[TModuleState] of string[20] = (
+          'Unknown',
+          'Registered',
+          'Load','Compile',
+          'Second_Load','Second_Compile',
+          'Compiled'
+        );
+
+     type
+        tmodulebase = class(TLinkedListItem)
+          { index }
+          unit_index       : longint;  { global counter for browser }
+          { status }
+          state            : tmodulestate;
+          { sources }
+          sourcefiles      : tinputfilemanager;
+          { paths and filenames }
+          paramallowoutput : boolean;  { original allowoutput parameter }
+          paramfn,                  { original filename }
+          path,                     { path where the module is find/created }
+          outputpath,               { path where the .s / .o / exe are created }
+          modulename,               { name of the module in uppercase }
+          realmodulename,           { name of the module in the orignal case }
+          objfilename,              { fullname of the objectfile }
+          newfilename,              { fullname of the assemblerfile }
+          ppufilename,              { fullname of the ppufile }
+          staticlibfilename,        { fullname of the static libraryfile }
+          sharedlibfilename,        { fullname of the shared libraryfile }
+          mapfilename,              { fullname of the mapfile }
+          exefilename,              { fullname of the exefile }
+          mainsource   : pstring;   { name of the main sourcefile }
+          constructor create(const s:string);
+          destructor destroy;override;
+          procedure setfilename(const fn:string;allowoutput:boolean);
+          function get_asmfilename : string;
+       end;
+
+
+implementation
+
+uses
+{$IFDEF USE_SYSUTILS}
+  SysUtils,
+  GlobType,
+{$ELSE USE_SYSUTILS}
+  dos,
+{$ENDIF USE_SYSUTILS}
+{$ifdef heaptrc}
+  fmodule,
+  ppheap,
+{$endif heaptrc}
+  globals,systems
+  ;
+
+{****************************************************************************
+                                  TINPUTFILE
+ ****************************************************************************}
+
+    constructor tinputfile.create(const fn:string);
+{$IFDEF USE_SYSUTILS}
+{$ELSE USE_SYSUTILS}
+      var
+        p:dirstr;
+        n:namestr;
+        e:extstr;
+{$ENDIF USE_SYSUTILS}
+      begin
+{$IFDEF USE_SYSUTILS}
+        name:=stringdup(SplitFileName(fn));
+        path:=stringdup(SplitPath(fn));
+{$ELSE USE_SYSUTILS}
+        FSplit(fn,p,n,e);
+        name:=stringdup(n+e);
+        path:=stringdup(p);
+{$ENDIF USE_SYSUTILS}
+        next:=nil;
+        filetime:=-1;
+      { file info }
+        is_macro:=false;
+        endoffile:=false;
+        closed:=true;
+        buf:=nil;
+        bufstart:=0;
+        bufsize:=0;
+        maxbufsize:=InputFileBufSize;
+      { save fields }
+        saveinputpointer:=nil;
+        saveline_no:=0;
+        savelastlinepos:=0;
+      { indexing refs }
+        ref_next:=nil;
+        ref_index:=0;
+      { line buffer }
+        linebuf:=nil;
+        maxlinebuf:=0;
+      end;
+
+
+    destructor tinputfile.destroy;
+      begin
+        if not closed then
+         close;
+        stringdispose(path);
+        stringdispose(name);
+      { free memory }
+        if assigned(linebuf) then
+         freemem(linebuf,maxlinebuf shl 2);
+      end;
+
+
+    procedure tinputfile.setpos(l:longint);
+      begin
+        bufstart:=l;
+      end;
+
+
+    procedure tinputfile.seekbuf(fpos:longint);
+      begin
+        if closed then
+         exit;
+        fileseek(fpos);
+        bufstart:=fpos;
+        bufsize:=0;
+      end;
+
+
+    procedure tinputfile.readbuf;
+      begin
+        if is_macro then
+         endoffile:=true;
+        if closed then
+         exit;
+        inc(bufstart,bufsize);
+        bufsize:=fileread(buf^,maxbufsize-1);
+        buf[bufsize]:=#0;
+        endoffile:=fileeof;
+      end;
+
+
+    function tinputfile.open:boolean;
+      begin
+        open:=false;
+        if not closed then
+         Close;
+        if not fileopen(path^+name^) then
+         exit;
+      { file }
+        endoffile:=false;
+        closed:=false;
+        Getmem(buf,MaxBufsize);
+        bufstart:=0;
+        bufsize:=0;
+        open:=true;
+      end;
+
+
+    procedure tinputfile.close;
+      begin
+        if is_macro then
+         begin
+           if assigned(buf) then
+            begin
+              Freemem(buf,maxbufsize);
+              buf:=nil;
+            end;
+           closed:=true;
+           exit;
+         end;
+        if not closed then
+         begin
+           fileclose;
+           closed:=true;
+         end;
+        if assigned(buf) then
+          begin
+             Freemem(buf,maxbufsize);
+             buf:=nil;
+          end;
+        bufstart:=0;
+      end;
+
+
+    procedure tinputfile.tempclose;
+      begin
+        if is_macro then
+         exit;
+        if not closed then
+         begin
+           fileclose;
+           if assigned(buf) then
+            begin
+              Freemem(buf,maxbufsize);
+              buf:=nil;
+            end;
+           closed:=true;
+         end;
+      end;
+
+
+    function tinputfile.tempopen:boolean;
+      begin
+        tempopen:=false;
+        if is_macro then
+         begin
+           { seek buffer postion to bufstart }
+           if bufstart>0 then
+            begin
+              move(buf[bufstart],buf[0],bufsize-bufstart+1);
+              bufstart:=0;
+            end;
+           tempopen:=true;
+           exit;
+         end;
+        if not closed then
+         exit;
+        if not fileopen(path^+name^) then
+         exit;
+        closed:=false;
+      { get new mem }
+        Getmem(buf,maxbufsize);
+      { restore state }
+        fileseek(BufStart);
+        bufsize:=0;
+        readbuf;
+        tempopen:=true;
+      end;
+
+
+    procedure tinputfile.setmacro(p:pchar;len:longint);
+      begin
+      { create new buffer }
+        getmem(buf,len+1);
+        move(p^,buf^,len);
+        buf[len]:=#0;
+      { reset }
+        bufstart:=0;
+        bufsize:=len;
+        maxbufsize:=len+1;
+        is_macro:=true;
+        endoffile:=true;
+        closed:=true;
+      end;
+
+
+    procedure tinputfile.setline(line,linepos:longint);
+      var
+        oldlinebuf  : plongintarr;
+      begin
+        if line<1 then
+         exit;
+        while (line>=maxlinebuf) do
+         begin
+           oldlinebuf:=linebuf;
+         { create new linebuf and move old info }
+           getmem(linebuf,(maxlinebuf+linebufincrease) shl 2);
+           if assigned(oldlinebuf) then
+            begin
+              move(oldlinebuf^,linebuf^,maxlinebuf shl 2);
+              freemem(oldlinebuf,maxlinebuf shl 2);
+            end;
+           fillchar(linebuf^[maxlinebuf],linebufincrease shl 2,0);
+           inc(maxlinebuf,linebufincrease);
+         end;
+        linebuf^[line]:=linepos;
+      end;
+
+
+    function tinputfile.getlinestr(l:longint):string;
+      var
+        c    : char;
+        i,
+        fpos : longint;
+        p    : pchar;
+      begin
+        getlinestr:='';
+        if l<maxlinebuf then
+         begin
+           fpos:=linebuf^[l];
+           { fpos is set negativ if the line was already written }
+           { but we still know the correct value                 }
+           if fpos<0 then
+             fpos:=-fpos+1;
+           if closed then
+            open;
+         { in current buf ? }
+           if (fpos<bufstart) or (fpos>bufstart+bufsize) then
+            begin
+              seekbuf(fpos);
+              readbuf;
+            end;
+         { the begin is in the buf now simply read until #13,#10 }
+           i:=0;
+           p:=@buf[fpos-bufstart];
+           repeat
+             c:=p^;
+             if c=#0 then
+              begin
+                if endoffile then
+                 break;
+                readbuf;
+                p:=buf;
+                c:=p^;
+              end;
+             if c in [#10,#13] then
+              break;
+             inc(i);
+             getlinestr[i]:=c;
+             inc(p);
+           until (i=255);
+           getlinestr[0]:=chr(i);
+         end;
+      end;
+
+
+    function tinputfile.getfiletime:longint;
+      begin
+        if filetime=-1 then
+         filegettime;
+        getfiletime:=filetime;
+      end;
+
+
+{****************************************************************************
+                                TDOSINPUTFILE
+ ****************************************************************************}
+
+    function tdosinputfile.fileopen(const filename: string): boolean;
+      var
+        ofm : byte;
+      begin
+        { Check if file exists, this will also check if it is
+          a real file and not a directory }
+        if not fileexists(filename) then
+          begin
+            result:=false;
+            exit;
+          end;
+        { Open file }
+        ofm:=filemode;
+        filemode:=0;
+        Assign(f,filename);
+        {$I-}
+         reset(f,1);
+        {$I+}
+        filemode:=ofm;
+        fileopen:=(ioresult=0);
+      end;
+
+
+    function tdosinputfile.fileseek(pos: longint): boolean;
+      begin
+        {$I-}
+         seek(f,Pos);
+        {$I+}
+        fileseek:=(ioresult=0);
+      end;
+
+
+    function tdosinputfile.fileread(var databuf; maxsize: longint): longint;
+      var
+        w : longint;
+      begin
+        blockread(f,databuf,maxsize,w);
+        fileread:=w;
+      end;
+
+
+    function tdosinputfile.fileeof: boolean;
+      begin
+        fileeof:=eof(f);
+      end;
+
+
+    function tdosinputfile.fileclose: boolean;
+      begin
+        {$I-}
+         system.close(f);
+        {$I+}
+        fileclose:=(ioresult=0);
+      end;
+
+
+    procedure tdosinputfile.filegettime;
+      begin
+        filetime:=getnamedfiletime(path^+name^);
+      end;
+
+
+{****************************************************************************
+                                Tinputfilemanager
+ ****************************************************************************}
+
+    constructor tinputfilemanager.create;
+      begin
+         files:=nil;
+         last_ref_index:=0;
+         cacheindex:=0;
+         cacheinputfile:=nil;
+      end;
+
+
+    destructor tinputfilemanager.destroy;
+      var
+         hp : tinputfile;
+      begin
+         hp:=files;
+         while assigned(hp) do
+          begin
+            files:=files.ref_next;
+            hp.free;
+            hp:=files;
+          end;
+         last_ref_index:=0;
+      end;
+
+
+    procedure tinputfilemanager.register_file(f : tinputfile);
+      begin
+         { don't register macro's }
+         if f.is_macro then
+          exit;
+         inc(last_ref_index);
+         f.ref_next:=files;
+         f.ref_index:=last_ref_index;
+         files:=f;
+         { update cache }
+         cacheindex:=last_ref_index;
+         cacheinputfile:=f;
+{$ifdef heaptrc}
+         ppheap_register_file(f.name^,current_module.unit_index*100000+f.ref_index);
+{$endif heaptrc}
+      end;
+
+
+   { this procedure is necessary after loading the
+     sources files from a PPU file  PM }
+   procedure tinputfilemanager.inverse_register_indexes;
+     var
+        f : tinputfile;
+     begin
+        f:=files;
+        while assigned(f) do
+          begin
+             f.ref_index:=last_ref_index-f.ref_index+1;
+             f:=f.ref_next;
+          end;
+        { reset cache }
+        cacheindex:=0;
+        cacheinputfile:=nil;
+     end;
+
+
+
+   function tinputfilemanager.get_file(l :longint) : tinputfile;
+     var
+        ff : tinputfile;
+     begin
+       { check cache }
+       if (l=cacheindex) and assigned(cacheinputfile) then
+        begin
+          get_file:=cacheinputfile;
+          exit;
+        end;
+       ff:=files;
+       while assigned(ff) and (ff.ref_index<>l) do
+         ff:=ff.ref_next;
+       get_file:=ff;
+     end;
+
+
+   function tinputfilemanager.get_file_name(l :longint):string;
+     var
+       hp : tinputfile;
+     begin
+       hp:=get_file(l);
+       if assigned(hp) then
+        get_file_name:=hp.name^
+       else
+        get_file_name:='';
+     end;
+
+
+   function tinputfilemanager.get_file_path(l :longint):string;
+     var
+       hp : tinputfile;
+     begin
+       hp:=get_file(l);
+       if assigned(hp) then
+        get_file_path:=hp.path^
+       else
+        get_file_path:='';
+     end;
+
+
+{****************************************************************************
+                                TModuleBase
+ ****************************************************************************}
+
+    procedure tmodulebase.setfilename(const fn:string;allowoutput:boolean);
+      var
+        p : dirstr;
+        n : NameStr;
+        e : ExtStr;
+        prefix,
+        suffix,
+        extension : NameStr;
+      begin
+         stringdispose(objfilename);
+         stringdispose(newfilename);
+         stringdispose(ppufilename);
+         stringdispose(staticlibfilename);
+         stringdispose(sharedlibfilename);
+         stringdispose(mapfilename);
+         stringdispose(exefilename);
+         stringdispose(outputpath);
+         stringdispose(path);
+         { Create names }
+         paramfn := stringdup(fn);
+         paramallowoutput := allowoutput;
+{$IFDEF USE_SYSUTILS}
+         p := SplitPath(fn);
+         n := SplitName(fn);
+         e := SplitExtension(fn);
+{$ELSE USE_SYSUTILS}
+         fsplit(fn,p,n,e);
+{$ENDIF USE_SYSUTILS}
+         n:=FixFileName(n);
+         { set path }
+         path:=stringdup(FixPath(p,false));
+         { obj,asm,ppu names }
+         p:=path^;
+         if AllowOutput then
+          begin
+            if (OutputUnitDir<>'') then
+             p:=OutputUnitDir
+            else
+             if (OutputExeDir<>'') then
+              p:=OutputExeDir;
+          end;
+         outputpath:=stringdup(p);
+         newfilename := stringdup(n);
+         objfilename:=stringdup(p+n+target_info.objext);
+         ppufilename:=stringdup(p+n+target_info.unitext);
+         { lib and exe could be loaded with a file specified with -o }
+         prefix := target_info.sharedlibprefix;
+         suffix := '';
+         extension := target_info.sharedlibext;
+
+         if AllowOutput and (compile_level=1) then
+         begin
+           if OutputFile <> '' then n:=OutputFile;
+           if Assigned(OutputPrefix) then prefix := OutputPrefix^;
+           if Assigned(OutputSuffix) then suffix := OutputSuffix^;
+           if OutputExtension <> '' then extension := OutputExtension;
+         end;
+
+         staticlibfilename:=stringdup(p+target_info.staticlibprefix+n+target_info.staticlibext);
+         { output dir of exe can be specified separatly }
+         if AllowOutput and (OutputExeDir<>'') then
+          p:=OutputExeDir
+         else
+          p:=path^;
+         sharedlibfilename:=stringdup(p+prefix+n+suffix+extension);
+         exefilename:=stringdup(p+n+target_info.exeext);
+         mapfilename:=stringdup(p+n+'.map');
+      end;
+
+
+    constructor tmodulebase.create(const s:string);
+      begin
+        modulename:=stringdup(Upper(s));
+        realmodulename:=stringdup(s);
+        mainsource:=nil;
+        ppufilename:=nil;
+        objfilename:=nil;
+        newfilename:=nil;
+        staticlibfilename:=nil;
+        sharedlibfilename:=nil;
+        exefilename:=nil;
+        mapfilename:=nil;
+        outputpath:=nil;
+        path:=nil;
+        { status }
+        state:=ms_registered;
+        { unit index }
+        inc(global_unit_count);
+        unit_index:=global_unit_count;
+        { sources }
+        sourcefiles:=TInputFileManager.Create;
+      end;
+
+
+    function tmodulebase.get_asmfilename : string;
+     begin
+         get_asmfilename:=outputpath^+newfilename^+target_info.asmext;
+     end;
+
+    destructor tmodulebase.destroy;
+      begin
+        if assigned(sourcefiles) then
+         sourcefiles.free;
+        sourcefiles:=nil;
+        stringdispose(objfilename);
+        stringdispose(newfilename);
+        stringdispose(ppufilename);
+        stringdispose(staticlibfilename);
+        stringdispose(sharedlibfilename);
+        stringdispose(exefilename);
+        stringdispose(mapfilename);
+        stringdispose(outputpath);
+        stringdispose(path);
+        stringdispose(modulename);
+        stringdispose(realmodulename);
+        stringdispose(mainsource);
+        inherited destroy;
+      end;
+
+end.

compiler/fmodule.pas

@@ -0,0 +1,831 @@
+{
+    Copyright (c) 1998-2002 by Florian Klaempfl
+
+    This unit implements the first loading and searching of the modules
+
+    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 fmodule;
+
+{$i fpcdefs.inc}
+
+{$ifdef go32v2}
+  {$define shortasmprefix}
+{$endif}
+{$ifdef watcom}
+  {$define shortasmprefix}
+{$endif}
+{$ifdef tos}
+  {$define shortasmprefix}
+{$endif}
+{$ifdef OS2}
+  { Allthough OS/2 supports long filenames I play it safe and
+    use 8.3 filenames, because this allows the compiler to run
+    on a FAT partition. (DM) }
+  {$define shortasmprefix}
+{$endif}
+
+interface
+
+    uses
+       cutils,cclasses,
+       globals,finput,
+       symbase,symsym,aasmbase;
+
+
+    type
+      trecompile_reason = (rr_unknown,
+        rr_noppu,rr_sourcenewer,rr_build,rr_crcchanged
+      );
+
+      TExternalsItem=class(TLinkedListItem)
+      public
+        found : longbool;
+        data  : pstring;
+        constructor Create(const s:string);
+        Destructor Destroy;override;
+      end;
+
+      tlinkcontaineritem=class(tlinkedlistitem)
+      public
+         data : pstring;
+         needlink : cardinal;
+         constructor Create(const s:string;m:cardinal);
+         destructor Destroy;override;
+      end;
+
+      tlinkcontainer=class(tlinkedlist)
+         procedure add(const s : string;m:cardinal);
+         function get(var m:cardinal) : string;
+         function getusemask(mask:cardinal) : string;
+         function find(const s:string):boolean;
+      end;
+
+      tmodule = class;
+      tused_unit = class;
+
+      tunitmaprec = record
+        u        : tmodule;
+        { number of references }
+        refs     : longint;
+        { index in the derefmap }
+        derefidx : longint;
+      end;
+      punitmap = ^tunitmaprec;
+
+      tderefmaprec = record
+        u           : tmodule;
+        { modulename, used during ppu load }
+        modulename  : pstring;
+      end;
+      pderefmap = ^tderefmaprec;
+
+      tmodule = class(tmodulebase)
+        do_reload,                { force reloading of the unit }
+        do_compile,               { need to compile the sources }
+        sources_avail,            { if all sources are reachable }
+        interface_compiled,       { if the interface section has been parsed/compiled/loaded }
+        is_stab_written,
+        is_reset,
+        is_unit,
+        in_interface,             { processing the implementation part? }
+        in_global     : boolean;  { allow global settings }
+        mode_switch_allowed  : boolean;  { Whether a mode switch is still allowed at this point in the parsing.}
+        mainfilepos   : tfileposinfo;
+        recompile_reason : trecompile_reason;  { the reason why the unit should be recompiled }
+        crc,
+        interface_crc : cardinal;
+        flags         : cardinal;  { the PPU flags }
+        islibrary     : boolean;  { if it is a library (win32 dll) }
+        moduleid      : longint;
+        unitmap       : punitmap; { mapping of all used units }
+        unitmapsize   : longint;  { number of units in the map }
+        derefmap      : pderefmap; { mapping of all units needed for deref }
+        derefmapcnt   : longint;  { number of units in the map }
+        derefmapsize  : longint;  { number of units in the map }
+        derefdataintflen : longint;
+        derefdata     : tdynamicarray;
+        globalsymtable,           { pointer to the global symtable of this unit }
+        localsymtable : tsymtable;{ pointer to the local symtable of this unit }
+        globalmacrosymtable,           { pointer to the global macro symtable of this unit }
+        localmacrosymtable : tsymtable;{ pointer to the local macro symtable of this unit }
+        scanner       : pointer;  { scanner object used }
+        procinfo      : pointer;  { current procedure being compiled }
+        loaded_from   : tmodule;
+        uses_imports  : boolean;  { Set if the module imports from DLL's.}
+        imports       : tlinkedlist;
+        _exports      : tlinkedlist;
+        externals     : tlinkedlist; {Only for DLL scanners by using Unix-style $LINKLIB }
+        resourcefiles : tstringlist;
+        linkunitofiles,
+        linkunitstaticlibs,
+        linkunitsharedlibs,
+        linkotherofiles,           { objects,libs loaded from the source }
+        linkothersharedlibs,       { using $L or $LINKLIB or import lib (for linux) }
+        linkotherstaticlibs  : tlinkcontainer;
+
+        used_units           : tlinkedlist;
+        dependent_units      : tlinkedlist;
+
+        localunitsearchpath,           { local searchpaths }
+        localobjectsearchpath,
+        localincludesearchpath,
+        locallibrarysearchpath : TSearchPathList;
+
+        asmprefix     : pstring;  { prefix for the smartlink asmfiles }
+        librarydata   : tasmlibrarydata;   { librarydata for this module }
+        {create creates a new module which name is stored in 's'. LoadedFrom
+        points to the module calling it. It is nil for the first compiled
+        module. This allow inheritence of all path lists. MUST pay attention
+        to that when creating link.res!!!!(mazen)}
+        constructor create(LoadedFrom:TModule;const s:string;_is_unit:boolean);
+        destructor destroy;override;
+        procedure reset;virtual;
+        procedure adddependency(callermodule:tmodule);
+        procedure flagdependent(callermodule:tmodule);
+        function  addusedunit(hp:tmodule;inuses:boolean;usym:tunitsym):tused_unit;
+        procedure updatemaps;
+        function  derefidx_unit(id:longint):longint;
+        function  resolve_unit(id:longint):tmodule;
+        procedure allunitsused;
+        procedure setmodulename(const s:string);
+      end;
+
+       tused_unit = class(tlinkedlistitem)
+          checksum,
+          interface_checksum : cardinal;
+          in_uses,
+          in_interface    : boolean;
+          u               : tmodule;
+          unitsym         : tunitsym;
+          constructor create(_u : tmodule;intface,inuses:boolean;usym:tunitsym);
+       end;
+
+       tdependent_unit = class(tlinkedlistitem)
+          u : tmodule;
+          constructor create(_u : tmodule);
+       end;
+
+    var
+       main_module       : tmodule;     { Main module of the program }
+       current_module    : tmodule;     { Current module which is compiled or loaded }
+       compiled_module   : tmodule;     { Current module which is compiled }
+       usedunits         : tlinkedlist; { Used units for this program }
+       loaded_units      : tlinkedlist; { All loaded units }
+       SmartLinkOFiles   : TStringList; { List of .o files which are generated,
+                                          used to delete them after linking }
+
+    function get_source_file(moduleindex,fileindex : longint) : tinputfile;
+    procedure addloadedunit(hp:tmodule);
+
+
+implementation
+
+    uses
+    {$IFDEF USE_SYSUTILS}
+      SysUtils,
+      GlobType,
+    {$ELSE USE_SYSUTILS}
+      dos,
+    {$ENDIF USE_SYSUTILS}
+      verbose,systems,
+      scanner,ppu,
+      procinfo;
+
+
+{*****************************************************************************
+                             Global Functions
+*****************************************************************************}
+
+    function get_source_file(moduleindex,fileindex : longint) : tinputfile;
+      var
+         hp : tmodule;
+      begin
+         hp:=tmodule(loaded_units.first);
+         while assigned(hp) and (hp.unit_index<>moduleindex) do
+           hp:=tmodule(hp.next);
+         if assigned(hp) then
+          get_source_file:=hp.sourcefiles.get_file(fileindex)
+         else
+          get_source_file:=nil;
+      end;
+
+
+    procedure addloadedunit(hp:tmodule);
+      begin
+        hp.moduleid:=loaded_units.count;
+        loaded_units.concat(hp);
+      end;
+
+
+{****************************************************************************
+                             TLinkContainerItem
+ ****************************************************************************}
+
+    constructor TLinkContainerItem.Create(const s:string;m:cardinal);
+      begin
+        inherited Create;
+        data:=stringdup(s);
+        needlink:=m;
+      end;
+
+
+    destructor TLinkContainerItem.Destroy;
+      begin
+        stringdispose(data);
+      end;
+
+
+{****************************************************************************
+                           TLinkContainer
+ ****************************************************************************}
+
+    procedure TLinkContainer.add(const s : string;m:cardinal);
+      begin
+        inherited concat(TLinkContainerItem.Create(s,m));
+      end;
+
+
+    function TLinkContainer.get(var m:cardinal) : string;
+      var
+        p : tlinkcontaineritem;
+      begin
+        p:=tlinkcontaineritem(inherited getfirst);
+        if p=nil then
+         begin
+           get:='';
+           m:=0;
+         end
+        else
+         begin
+           get:=p.data^;
+           m:=p.needlink;
+           p.free;
+         end;
+      end;
+
+
+    function TLinkContainer.getusemask(mask:cardinal) : string;
+      var
+         p : tlinkcontaineritem;
+         found : boolean;
+      begin
+        found:=false;
+        repeat
+          p:=tlinkcontaineritem(inherited getfirst);
+          if p=nil then
+           begin
+             getusemask:='';
+             exit;
+           end;
+          getusemask:=p.data^;
+          found:=(p.needlink and mask)<>0;
+          p.free;
+        until found;
+      end;
+
+
+    function TLinkContainer.find(const s:string):boolean;
+      var
+        newnode : tlinkcontaineritem;
+      begin
+        find:=false;
+        newnode:=tlinkcontaineritem(First);
+        while assigned(newnode) do
+         begin
+           if newnode.data^=s then
+            begin
+              find:=true;
+              exit;
+            end;
+           newnode:=tlinkcontaineritem(newnode.next);
+         end;
+      end;
+
+
+{****************************************************************************
+                              TExternalsItem
+ ****************************************************************************}
+
+    constructor tExternalsItem.Create(const s:string);
+      begin
+        inherited Create;
+        found:=false;
+        data:=stringdup(s);
+      end;
+
+
+    destructor tExternalsItem.Destroy;
+      begin
+        stringdispose(data);
+        inherited;
+      end;
+
+
+{****************************************************************************
+                              TUSED_UNIT
+ ****************************************************************************}
+
+    constructor tused_unit.create(_u : tmodule;intface,inuses:boolean;usym:tunitsym);
+      begin
+        u:=_u;
+        in_interface:=intface;
+        in_uses:=inuses;
+        unitsym:=usym;
+        if _u.state=ms_compiled then
+         begin
+           checksum:=u.crc;
+           interface_checksum:=u.interface_crc;
+         end
+        else
+         begin
+           checksum:=0;
+           interface_checksum:=0;
+         end;
+      end;
+
+
+{****************************************************************************
+                            TDENPENDENT_UNIT
+ ****************************************************************************}
+
+    constructor tdependent_unit.create(_u : tmodule);
+      begin
+         u:=_u;
+      end;
+
+
+{****************************************************************************
+                                  TMODULE
+ ****************************************************************************}
+
+    constructor tmodule.create(LoadedFrom:TModule;const s:string;_is_unit:boolean);
+      var
+        p : dirstr;
+        n : namestr;
+        e : extstr;
+      begin
+    {$IFDEF USE_SYSUTILS}
+        p := SplitPath(s);
+        n := SplitName(s);
+        e := SplitExtension(s);
+    {$ELSE USE_SYSUTILS}
+        FSplit(s,p,n,e);
+    {$ENDIF USE_SYSUTILS}
+        { Programs have the name 'Program' to don't conflict with dup id's }
+        if _is_unit then
+         inherited create(n)
+        else
+         inherited create('Program');
+        mainsource:=stringdup(s);
+        { Dos has the famous 8.3 limit :( }
+{$ifdef shortasmprefix}
+        asmprefix:=stringdup(FixFileName('as'));
+{$else}
+        asmprefix:=stringdup(FixFileName(n));
+{$endif}
+        setfilename(p+n,true);
+        localunitsearchpath:=TSearchPathList.Create;
+        localobjectsearchpath:=TSearchPathList.Create;
+        localincludesearchpath:=TSearchPathList.Create;
+        locallibrarysearchpath:=TSearchPathList.Create;
+        used_units:=TLinkedList.Create;
+        dependent_units:=TLinkedList.Create;
+        resourcefiles:=TStringList.Create;
+        linkunitofiles:=TLinkContainer.Create;
+        linkunitstaticlibs:=TLinkContainer.Create;
+        linkunitsharedlibs:=TLinkContainer.Create;
+        linkotherofiles:=TLinkContainer.Create;
+        linkotherstaticlibs:=TLinkContainer.Create;
+        linkothersharedlibs:=TLinkContainer.Create;
+        crc:=0;
+        interface_crc:=0;
+        flags:=0;
+        scanner:=nil;
+        unitmap:=nil;
+        unitmapsize:=0;
+        derefmap:=nil;
+        derefmapsize:=0;
+        derefmapcnt:=0;
+        derefdata:=TDynamicArray.Create(1024);
+        derefdataintflen:=0;
+        globalsymtable:=nil;
+        localsymtable:=nil;
+        globalmacrosymtable:=nil;
+        localmacrosymtable:=nil;
+        loaded_from:=LoadedFrom;
+        do_reload:=false;
+        do_compile:=false;
+        sources_avail:=true;
+        mainfilepos.line:=0;
+        mainfilepos.column:=0;
+        mainfilepos.fileindex:=0;
+        recompile_reason:=rr_unknown;
+        in_interface:=true;
+        in_global:=true;
+        is_unit:=_is_unit;
+        islibrary:=false;
+        is_stab_written:=false;
+        is_reset:=false;
+        mode_switch_allowed:= true;
+        uses_imports:=false;
+        imports:=TLinkedList.Create;
+        _exports:=TLinkedList.Create;
+        externals:=TLinkedList.Create;
+        librarydata:=tasmlibrarydata.create(realmodulename^);
+      end;
+
+
+    destructor tmodule.Destroy;
+      var
+{$ifdef MEMDEBUG}
+        d : tmemdebug;
+{$endif}
+        i : longint;
+        hpi : tprocinfo;
+      begin
+        if assigned(unitmap) then
+          freemem(unitmap);
+        if assigned(derefmap) then
+          begin
+            for i:=0 to derefmapcnt-1 do
+              stringdispose(derefmap[i].modulename);
+            freemem(derefmap);
+          end;
+        if assigned(imports) then
+         imports.free;
+        if assigned(_exports) then
+         _exports.free;
+        if assigned(externals) then
+         externals.free;
+        if assigned(scanner) then
+         begin
+            { also update current_scanner if it was pointing
+              to this module }
+            if current_scanner=tscannerfile(scanner) then
+             current_scanner:=nil;
+            tscannerfile(scanner).free;
+         end;
+        if assigned(procinfo) then
+          begin
+            if current_procinfo=tprocinfo(procinfo) then
+             current_procinfo:=nil;
+            { release procinfo tree }
+            while assigned(procinfo) do
+             begin
+               hpi:=tprocinfo(procinfo).parent;
+               tprocinfo(procinfo).free;
+               procinfo:=hpi;
+             end;
+          end;
+        used_units.free;
+        dependent_units.free;
+        resourcefiles.Free;
+        linkunitofiles.Free;
+        linkunitstaticlibs.Free;
+        linkunitsharedlibs.Free;
+        linkotherofiles.Free;
+        linkotherstaticlibs.Free;
+        linkothersharedlibs.Free;
+        stringdispose(objfilename);
+        stringdispose(newfilename);
+        stringdispose(ppufilename);
+        stringdispose(staticlibfilename);
+        stringdispose(sharedlibfilename);
+        stringdispose(exefilename);
+        stringdispose(outputpath);
+        stringdispose(path);
+        stringdispose(realmodulename);
+        stringdispose(mainsource);
+        stringdispose(asmprefix);
+        localunitsearchpath.Free;
+        localobjectsearchpath.free;
+        localincludesearchpath.free;
+        locallibrarysearchpath.free;
+{$ifdef MEMDEBUG}
+        d:=tmemdebug.create(modulename^+' - symtable');
+{$endif}
+        derefdata.free;
+        if assigned(globalsymtable) then
+          globalsymtable.free;
+        if assigned(localsymtable) then
+          localsymtable.free;
+        if assigned(globalmacrosymtable) then
+          globalmacrosymtable.free;
+        if assigned(localmacrosymtable) then
+          localmacrosymtable.free;
+{$ifdef MEMDEBUG}
+        d.free;
+{$endif}
+{$ifdef MEMDEBUG}
+        d:=tmemdebug.create(modulename^+' - librarydata');
+{$endif}
+        librarydata.free;
+{$ifdef MEMDEBUG}
+        d.free;
+{$endif}
+        stringdispose(modulename);
+        inherited Destroy;
+      end;
+
+
+    procedure tmodule.reset;
+      var
+        hpi : tprocinfo;
+        i   : longint;
+      begin
+        if assigned(scanner) then
+          begin
+            { also update current_scanner if it was pointing
+              to this module }
+            if current_scanner=tscannerfile(scanner) then
+             current_scanner:=nil;
+            tscannerfile(scanner).free;
+            scanner:=nil;
+          end;
+        if assigned(procinfo) then
+          begin
+            if current_procinfo=tprocinfo(procinfo) then
+             current_procinfo:=nil;
+            { release procinfo tree }
+            while assigned(procinfo) do
+             begin
+               hpi:=tprocinfo(procinfo).parent;
+               tprocinfo(procinfo).free;
+               procinfo:=hpi;
+             end;
+          end;
+        if assigned(globalsymtable) then
+          begin
+            globalsymtable.free;
+            globalsymtable:=nil;
+          end;
+        if assigned(localsymtable) then
+          begin
+            localsymtable.free;
+            localsymtable:=nil;
+          end;
+        if assigned(globalmacrosymtable) then
+          begin
+            globalmacrosymtable.free;
+            globalmacrosymtable:=nil;
+          end;
+        if assigned(localmacrosymtable) then
+          begin
+            localmacrosymtable.free;
+            localmacrosymtable:=nil;
+          end;
+        derefdata.free;
+        derefdata:=TDynamicArray.Create(1024);
+        if assigned(unitmap) then
+          begin
+            freemem(unitmap);
+            unitmap:=nil;
+          end;
+        if assigned(derefmap) then
+          begin
+            for i:=0 to derefmapcnt-1 do
+              stringdispose(derefmap[i].modulename);
+            freemem(derefmap);
+            derefmap:=nil;
+          end;
+        unitmapsize:=0;
+        derefmapsize:=0;
+        derefmapcnt:=0;
+        derefdataintflen:=0;
+        sourcefiles.free;
+        sourcefiles:=tinputfilemanager.create;
+        librarydata.free;
+        librarydata:=tasmlibrarydata.create(realmodulename^);
+        imports.free;
+        imports:=tlinkedlist.create;
+        _exports.free;
+        _exports:=tlinkedlist.create;
+        externals.free;
+        externals:=tlinkedlist.create;
+        used_units.free;
+        used_units:=TLinkedList.Create;
+        dependent_units.free;
+        dependent_units:=TLinkedList.Create;
+        resourcefiles.Free;
+        resourcefiles:=TStringList.Create;
+        linkunitofiles.Free;
+        linkunitofiles:=TLinkContainer.Create;
+        linkunitstaticlibs.Free;
+        linkunitstaticlibs:=TLinkContainer.Create;
+        linkunitsharedlibs.Free;
+        linkunitsharedlibs:=TLinkContainer.Create;
+        linkotherofiles.Free;
+        linkotherofiles:=TLinkContainer.Create;
+        linkotherstaticlibs.Free;
+        linkotherstaticlibs:=TLinkContainer.Create;
+        linkothersharedlibs.Free;
+        linkothersharedlibs:=TLinkContainer.Create;
+        uses_imports:=false;
+        do_compile:=false;
+        do_reload:=false;
+        interface_compiled:=false;
+        in_interface:=true;
+        in_global:=true;
+        mode_switch_allowed:=true;
+        is_stab_written:=false;
+        is_reset:=false;
+        crc:=0;
+        interface_crc:=0;
+        flags:=0;
+        mainfilepos.line:=0;
+        mainfilepos.column:=0;
+        mainfilepos.fileindex:=0;
+        recompile_reason:=rr_unknown;
+        {
+          The following fields should not
+          be reset:
+           mainsource
+           state
+           loaded_from
+           sources_avail
+        }
+      end;
+
+
+    procedure tmodule.adddependency(callermodule:tmodule);
+      begin
+        { This is not needed for programs }
+        if not callermodule.is_unit then
+          exit;
+        Message2(unit_u_add_depend_to,callermodule.modulename^,modulename^);
+        dependent_units.concat(tdependent_unit.create(callermodule));
+      end;
+
+
+    procedure tmodule.flagdependent(callermodule:tmodule);
+      var
+        pm : tdependent_unit;
+      begin
+        { flag all units that depend on this unit for reloading }
+        pm:=tdependent_unit(current_module.dependent_units.first);
+        while assigned(pm) do
+         begin
+           { We do not have to reload the unit that wants to load
+             this unit, unless this unit is already compiled during
+             the loading }
+           if (pm.u=callermodule) and
+              (pm.u.state<>ms_compiled) then
+             Message1(unit_u_no_reload_is_caller,pm.u.modulename^)
+           else
+            if pm.u.state=ms_second_compile then
+              Message1(unit_u_no_reload_in_second_compile,pm.u.modulename^)
+           else
+            begin
+              pm.u.do_reload:=true;
+              Message1(unit_u_flag_for_reload,pm.u.modulename^);
+            end;
+           pm:=tdependent_unit(pm.next);
+         end;
+      end;
+
+
+    function tmodule.addusedunit(hp:tmodule;inuses:boolean;usym:tunitsym):tused_unit;
+      var
+        pu : tused_unit;
+      begin
+        pu:=tused_unit.create(hp,in_interface,inuses,usym);
+        used_units.concat(pu);
+        addusedunit:=pu;
+      end;
+
+
+    procedure tmodule.updatemaps;
+      var
+        oldmapsize : longint;
+        hp  : tmodule;
+        i   : longint;
+      begin
+        { Extend unitmap }
+        oldmapsize:=unitmapsize;
+        unitmapsize:=loaded_units.count;
+        reallocmem(unitmap,unitmapsize*sizeof(tunitmaprec));
+        fillchar(unitmap[oldmapsize],(unitmapsize-oldmapsize)*sizeof(tunitmaprec),0);
+
+        { Extend Derefmap }
+        oldmapsize:=derefmapsize;
+        derefmapsize:=loaded_units.count;
+        reallocmem(derefmap,derefmapsize*sizeof(tderefmaprec));
+        fillchar(derefmap[oldmapsize],(derefmapsize-oldmapsize)*sizeof(tderefmaprec),0);
+
+        { Add all units to unitmap }
+        hp:=tmodule(loaded_units.first);
+        i:=0;
+        while assigned(hp) do
+          begin
+            if hp.moduleid>=unitmapsize then
+              internalerror(200501151);
+            { Verify old entries }
+            if (i<oldmapsize) then
+              begin
+                if (hp.moduleid<>i) or
+                   (unitmap[hp.moduleid].u<>hp) then
+                  internalerror(200501156);
+              end
+            else
+              begin
+                unitmap[hp.moduleid].u:=hp;
+                unitmap[hp.moduleid].derefidx:=-1;
+              end;
+            inc(i);
+            hp:=tmodule(hp.next);
+          end;
+      end;
+
+
+    function tmodule.derefidx_unit(id:longint):longint;
+      begin
+        if id>=unitmapsize then
+          internalerror(2005011511);
+        if unitmap[id].derefidx=-1 then
+          begin
+            unitmap[id].derefidx:=derefmapcnt;
+            inc(derefmapcnt);
+            derefmap[unitmap[id].derefidx].u:=unitmap[id].u;
+          end;
+        if unitmap[id].derefidx>=derefmapsize then
+          internalerror(2005011514);
+        result:=unitmap[id].derefidx;
+      end;
+
+
+    function tmodule.resolve_unit(id:longint):tmodule;
+      var
+        hp : tmodule;
+      begin
+        if id>=derefmapsize then
+          internalerror(200306231);
+        result:=derefmap[id].u;
+        if not assigned(result) then
+          begin
+            if not assigned(derefmap[id].modulename) or
+               (derefmap[id].modulename^='') then
+              internalerror(200501159);
+            hp:=tmodule(loaded_units.first);
+            while assigned(hp) do
+              begin
+                if hp.modulename^=derefmap[id].modulename^ then
+                  break;
+                hp:=tmodule(hp.next);
+              end;
+            if not assigned(hp) then
+              internalerror(2005011510);
+            derefmap[id].u:=hp;
+            result:=hp;
+          end;
+      end;
+
+
+    procedure tmodule.allunitsused;
+      var
+        pu : tused_unit;
+      begin
+        pu:=tused_unit(used_units.first);
+        while assigned(pu) do
+          begin
+            if assigned(pu.u.globalsymtable) then
+              begin
+                if unitmap[pu.u.moduleid].u<>pu.u then
+                  internalerror(200501157);
+                { Give a note when the unit is not referenced, skip
+                  this is for units with an initialization/finalization }
+                if (unitmap[pu.u.moduleid].refs=0) and
+                   ((pu.u.flags and (uf_init or uf_finalize))=0) then
+                  CGMessagePos2(pu.unitsym.fileinfo,sym_n_unit_not_used,pu.u.realmodulename^,realmodulename^);
+              end;
+            pu:=tused_unit(pu.next);
+          end;
+      end;
+
+
+    procedure tmodule.setmodulename(const s:string);
+      begin
+        stringdispose(modulename);
+        stringdispose(realmodulename);
+        modulename:=stringdup(upper(s));
+        realmodulename:=stringdup(s);
+        { also update asmlibrary names }
+        librarydata.name:=modulename^;
+        librarydata.realname:=realmodulename^;
+      end;
+
+end.

compiler/fpcdefs.inc

@@ -0,0 +1,115 @@
+{$ifdef FPC}
+  {$mode objfpc}
+  {$asmmode default}
+  {$H-}
+  {$goto on}
+  {$inline on}
+
+  { 1Mb stack }
+  {$MEMORY 1000000}
+
+  { This reduces the memory requirements a lot }
+  {$PACKENUM 1}
+
+  {$ifndef VER1_0}
+      { We don't use exceptions, so turn off the implicit
+        exceptions in the constructors }
+      {$IMPLICITEXCEPTIONS OFF}
+      { Inline small functions, but not when EXTDEBUG is used }
+      {$ifndef EXTDEBUG}
+        {$define USEINLINE}
+      {$endif EXTDEBUG}
+  {$else}
+      { Optimizer is broken when compiling with optimizations using 1.0.x }
+      {$ifndef USEOPT}
+        {$define NOOPT}
+      {$endif}
+
+      { 1.0.x generates broken code for sysutils }
+      {$ifndef FORCE_SYSUTILS}
+        {$undef USE_SYSUTILS}
+      {$endif}
+  {$endif VER1_0}
+
+  {$ifdef VER1_9_4}
+     { 1.9.4 generates broken code for sysutils }
+     {$ifndef FORCE_SYSUTILS}
+       {$undef USE_SYSUTILS}
+     {$endif}
+  {$endif}
+
+  {$define USEEXCEPT}
+
+  {$ifdef cpuarm}
+    {$packrecords c}
+  {$endif cpuarm}
+{$endif}
+
+{$ifdef i386}
+  {$define x86}
+  {$define cpuflags}
+  {$define cpuextended}
+  {$define USECMOV}
+{$endif i386}
+
+{$ifdef x86_64}
+  {$define x86}
+  {$define cpuflags}
+  {$define cpu64bit}
+  {$define cpuextended}
+  {$define cpufloat128}
+  {$define cputargethasfixedstack}
+  {$define USECMOV}
+{$endif x86_64}
+
+{$ifdef alpha}
+  {$define cpu64bit}
+{$endif alpha}
+
+{$ifdef sparc}
+  {$define cpuflags}
+  {$define cputargethasfixedstack}
+  {$define cpurequiresproperalignment}
+{$endif sparc}
+
+{$ifdef powerpc}
+  {$define cpuflags}
+  {$define cputargethasfixedstack}
+{$endif powerpc}
+
+{$ifdef arm}
+  {$define cpuflags}
+  {$define cpuneedsdiv32helper}
+  {$define cputargethasfixedstack}
+  {$define cpurequiresproperalignment}
+{$endif arm}
+
+{$ifdef m68k}
+  {$define cpuflags}
+  {$define cpufpemu}
+{$endif m68k}
+
+{$IFDEF MACOS}
+{$DEFINE MACOS_USE_FAKE_SYSUTILS}
+{$ENDIF MACOS}
+
+{
+  $Log: fpcdefs.inc,v $
+  Revision 1.51  2005/03/20 21:41:29  florian
+    * USECMOV activated
+
+  Revision 1.50  2005/02/26 01:26:59  jonas
+    * fixed generic jumps optimizer and enabled it for ppc (the label table
+      was not being initialised -> getfinaldestination always failed, which
+      caused wrong optimizations in some cases)
+    * changed the inverse_cond into a function, because tasmcond is a record
+      on ppc
+    + added a compare_conditions() function for the same reason
+
+  Revision 1.49  2005/02/14 17:13:06  peter
+    * truncate log
+
+  Revision 1.48  2005/02/08 22:33:51  olle
+    * fixed compilation on MacOS
+
+}

compiler/fppu.pas

@@ -0,0 +1,1610 @@
+{
+    Copyright (c) 1998-2002 by Florian Klaempfl
+
+    This unit implements the first loading and searching of the modules
+
+    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 fppu;
+
+{$i fpcdefs.inc}
+
+{ close ppufiles on system that are
+  short on file handles like DOS system PM }
+{$ifdef GO32V2}
+  {$define SHORT_ON_FILE_HANDLES}
+{$endif GO32V2}
+{$ifdef WATCOM}
+  {$define SHORT_ON_FILE_HANDLES}
+{$endif WATCOM}
+
+interface
+
+    uses
+       cutils,cclasses,
+       globtype,globals,finput,fmodule,
+       symbase,ppu,symtype;
+
+    type
+       tppumodule = class(tmodule)
+          ppufile    : tcompilerppufile; { the PPU file }
+          sourcefn   : pstring; { Source specified with "uses .. in '..'" }
+{$ifdef Test_Double_checksum}
+          crc_array  : pointer;
+          crc_size   : longint;
+          crc_array2 : pointer;
+          crc_size2  : longint;
+{$endif def Test_Double_checksum}
+          constructor create(LoadedFrom:TModule;const s:string;const fn:string;_is_unit:boolean);
+          destructor destroy;override;
+          procedure reset;override;
+          function  openppu:boolean;
+          procedure getppucrc;
+          procedure writeppu;
+          procedure loadppu;
+          function  needrecompile:boolean;
+       private
+          function  search_unit(onlysource,shortname:boolean):boolean;
+          procedure load_interface;
+          procedure load_implementation;
+          procedure load_symtable_refs;
+          procedure load_usedunits;
+          procedure writesourcefiles;
+          procedure writeusedunit(intf:boolean);
+          procedure writelinkcontainer(var p:tlinkcontainer;id:byte;strippath:boolean);
+          procedure writederefmap;
+          procedure writederefdata;
+          procedure putasmsymbol_in_idx(s:tnamedindexitem;arg:pointer);
+          procedure writeasmsymbols;
+          procedure readsourcefiles;
+          procedure readloadunit;
+          procedure readlinkcontainer(var p:tlinkcontainer);
+          procedure readderefmap;
+          procedure readderefdata;
+          procedure readasmsymbols;
+{$IFDEF MACRO_DIFF_HINT}
+          procedure writeusedmacro(p:TNamedIndexItem;arg:pointer);
+          procedure writeusedmacros;
+          procedure readusedmacros;
+{$ENDIF}
+       end;
+
+    procedure reload_flagged_units;
+    function registerunit(callermodule:tmodule;const s : stringid;const fn:string) : tppumodule;
+
+
+implementation
+
+uses
+  verbose,systems,version,
+  symtable, symsym,
+  scanner,
+  aasmbase,
+  parser;
+
+{****************************************************************************
+                                 Helpers
+ ****************************************************************************}
+
+    procedure reload_flagged_units;
+      var
+        hp : tmodule;
+      begin
+        { now reload all dependent units }
+        hp:=tmodule(loaded_units.first);
+        while assigned(hp) do
+         begin
+           if hp.do_reload then
+             tppumodule(hp).loadppu;
+           hp:=tmodule(hp.next);
+         end;
+      end;
+
+
+{****************************************************************************
+                                TPPUMODULE
+ ****************************************************************************}
+
+    constructor tppumodule.create(LoadedFrom:TModule;const s:string;const fn:string;_is_unit:boolean);
+      begin
+        inherited create(LoadedFrom,s,_is_unit);
+        ppufile:=nil;
+        sourcefn:=stringdup(fn);
+      end;
+
+
+    destructor tppumodule.Destroy;
+      begin
+        if assigned(ppufile) then
+         ppufile.free;
+        ppufile:=nil;
+        stringdispose(sourcefn);
+        inherited Destroy;
+      end;
+
+
+    procedure tppumodule.reset;
+      begin
+        if assigned(ppufile) then
+         begin
+           ppufile.free;
+           ppufile:=nil;
+         end;
+        inherited reset;
+      end;
+
+
+    function tppumodule.openppu:boolean;
+      var
+        ppufiletime : longint;
+      begin
+        openppu:=false;
+        Message1(unit_t_ppu_loading,ppufilename^);
+      { Get ppufile time (also check if the file exists) }
+        ppufiletime:=getnamedfiletime(ppufilename^);
+        if ppufiletime=-1 then
+         exit;
+      { Open the ppufile }
+        Message1(unit_u_ppu_name,ppufilename^);
+        ppufile:=tcompilerppufile.create(ppufilename^);
+        if not ppufile.openfile then
+         begin
+           ppufile.free;
+           ppufile:=nil;
+           Message(unit_u_ppu_file_too_short);
+           exit;
+         end;
+      { check for a valid PPU file }
+        if not ppufile.CheckPPUId then
+         begin
+           ppufile.free;
+           ppufile:=nil;
+           Message(unit_u_ppu_invalid_header);
+           exit;
+         end;
+      { check for allowed PPU versions }
+        if not (ppufile.GetPPUVersion = CurrentPPUVersion) then
+         begin
+           Message1(unit_u_ppu_invalid_version,tostr(ppufile.GetPPUVersion));
+           ppufile.free;
+           ppufile:=nil;
+           exit;
+         end;
+      { check the target processor }
+        if tsystemcpu(ppufile.header.cpu)<>target_cpu then
+         begin
+           ppufile.free;
+           ppufile:=nil;
+           Message(unit_u_ppu_invalid_processor);
+           exit;
+         end;
+      { check target }
+        if tsystem(ppufile.header.target)<>target_info.system then
+         begin
+           ppufile.free;
+           ppufile:=nil;
+           Message(unit_u_ppu_invalid_target);
+           exit;
+         end;
+{$ifdef cpufpemu}
+       { check if floating point emulation is on?}
+        if ((ppufile.header.flags and uf_fpu_emulation)<>0) and
+            (cs_fp_emulation in aktmoduleswitches) then
+         begin
+           ppufile.free;
+           ppufile:=nil;
+           Message(unit_u_ppu_invalid_fpumode);
+           exit;
+         end;
+{$endif cpufpemu}
+
+      { Load values to be access easier }
+        flags:=ppufile.header.flags;
+        crc:=ppufile.header.checksum;
+        interface_crc:=ppufile.header.interface_checksum;
+      { Show Debug info }
+        Message1(unit_u_ppu_time,filetimestring(ppufiletime));
+        Message1(unit_u_ppu_flags,tostr(flags));
+        Message1(unit_u_ppu_crc,hexstr(ppufile.header.checksum,8));
+        Message1(unit_u_ppu_crc,hexstr(ppufile.header.interface_checksum,8)+' (intfc)');
+        do_compile:=false;
+        openppu:=true;
+      end;
+
+
+    function tppumodule.search_unit(onlysource,shortname:boolean):boolean;
+      var
+         singlepathstring,
+         filename : string;
+
+         Function UnitExists(const ext:string;var foundfile:string):boolean;
+         begin
+           Message1(unit_t_unitsearch,Singlepathstring+filename+ext);
+           UnitExists:=FindFile(FileName+ext,Singlepathstring,foundfile);
+         end;
+
+         Function PPUSearchPath(const s:string):boolean;
+         var
+           found : boolean;
+           hs    : string;
+         begin
+           Found:=false;
+           singlepathstring:=FixPath(s,false);
+         { Check for PPU file }
+           Found:=UnitExists(target_info.unitext,hs);
+           if Found then
+            Begin
+              SetFileName(hs,false);
+              Found:=OpenPPU;
+            End;
+           PPUSearchPath:=Found;
+         end;
+
+         Function SourceSearchPath(const s:string):boolean;
+         var
+           found   : boolean;
+           hs      : string;
+         begin
+           Found:=false;
+           singlepathstring:=FixPath(s,false);
+         { Check for Sources }
+           ppufile:=nil;
+           do_compile:=true;
+           recompile_reason:=rr_noppu;
+         {Check for .pp file}
+           Found:=UnitExists(sourceext,hs);
+           if not Found then
+            begin
+              { Check for .pas }
+              Found:=UnitExists(pasext,hs);
+            end;
+           if not Found and (m_mac in aktmodeswitches) then
+            begin
+              { Check for .p, if mode is macpas}
+              Found:=UnitExists(pext,hs);
+            end;
+           stringdispose(mainsource);
+           if Found then
+            begin
+              sources_avail:=true;
+              { Load Filenames when found }
+              mainsource:=StringDup(hs);
+              SetFileName(hs,false);
+            end
+           else
+            sources_avail:=false;
+           SourceSearchPath:=Found;
+         end;
+
+         Function SearchPath(const s:string):boolean;
+         var
+           found : boolean;
+         begin
+           { First check for a ppu, then for the source }
+           found:=false;
+           if not onlysource then
+            found:=PPUSearchPath(s);
+           if not found then
+            found:=SourceSearchPath(s);
+           SearchPath:=found;
+         end;
+
+         Function SearchPathList(list:TSearchPathList):boolean;
+         var
+           hp : TStringListItem;
+           found : boolean;
+         begin
+           found:=false;
+           hp:=TStringListItem(list.First);
+           while assigned(hp) do
+            begin
+              found:=SearchPath(hp.Str);
+              if found then
+               break;
+              hp:=TStringListItem(hp.next);
+            end;
+           SearchPathList:=found;
+         end;
+
+       var
+         fnd : boolean;
+         hs  : string;
+       begin
+         if shortname then
+          filename:=FixFileName(Copy(realmodulename^,1,8))
+         else
+          filename:=FixFileName(realmodulename^);
+         { try to find unit
+            1. look for ppu in cwd
+            2. look for ppu in outputpath if set, this is tp7 compatible (PFV)
+            3. look for the specified source file (from the uses line)
+            4. look for source in cwd
+            5. look in same path as local unit
+            6. local unit pathlist
+            7. global unit pathlist }
+         fnd:=false;
+         if not onlysource then
+          begin
+            fnd:=PPUSearchPath('.');
+            if (not fnd) and (outputpath^<>'') then
+             fnd:=PPUSearchPath(outputpath^);
+           end;
+         if (not fnd) and (sourcefn^<>'') then
+          begin
+            { the full filename is specified so we can't use here the
+              searchpath (PFV) }
+            Message1(unit_t_unitsearch,AddExtension(sourcefn^,sourceext));
+            fnd:=FindFile(AddExtension(sourcefn^,sourceext),'',hs);
+            if not fnd then
+             begin
+               Message1(unit_t_unitsearch,AddExtension(sourcefn^,pasext));
+               fnd:=FindFile(AddExtension(sourcefn^,pasext),'',hs);
+             end;
+            if not fnd and ((m_mac in aktmodeswitches) or target_info.p_ext_support) then
+             begin
+               Message1(unit_t_unitsearch,AddExtension(sourcefn^,pext));
+               fnd:=FindFile(AddExtension(sourcefn^,pext),'',hs);
+             end;
+            if fnd then
+             begin
+               sources_avail:=true;
+               do_compile:=true;
+               recompile_reason:=rr_noppu;
+               stringdispose(mainsource);
+               mainsource:=StringDup(hs);
+               SetFileName(hs,false);
+             end;
+          end;
+         if not fnd then
+           fnd:=SourceSearchPath('.');
+         if (not fnd) and Assigned(Loaded_From) then
+           begin
+             fnd:=PPUSearchPath(Loaded_From.Path^);
+             if not fnd then
+               fnd:=SourceSearchPath(Loaded_From.Path^);
+             if not fnd then
+               fnd:=SearchPathList(Loaded_From.LocalUnitSearchPath);
+           end;
+         if not fnd then
+           fnd:=SearchPathList(UnitSearchPath);
+
+         { try to find a file with the first 8 chars of the modulename, like
+           dos }
+         if (not fnd) and (length(filename)>8) then
+          begin
+            filename:=copy(filename,1,8);
+            fnd:=SearchPath('.');
+            if (not fnd) then
+             fnd:=SearchPathList(LocalUnitSearchPath);
+            if not fnd then
+             fnd:=SearchPathList(UnitSearchPath);
+          end;
+         search_unit:=fnd;
+      end;
+
+
+{**********************************
+    PPU Reading/Writing Helpers
+***********************************}
+
+{$IFDEF MACRO_DIFF_HINT}
+    var
+      is_initial: Boolean;
+
+    procedure tppumodule.writeusedmacro(p:TNamedIndexItem;arg:pointer);
+      begin
+        if tmacro(p).is_used or is_initial then
+          begin
+            ppufile.putstring(p.name);
+            ppufile.putbyte(byte(is_initial));
+            ppufile.putbyte(byte(tmacro(p).is_used));
+          end;
+      end;
+
+    procedure tppumodule.writeusedmacros;
+      begin
+        ppufile.do_crc:=false;
+        is_initial:= true;
+        initialmacrosymtable.foreach(@writeusedmacro,nil);
+        is_initial:= false;
+        if assigned(globalmacrosymtable) then
+          globalmacrosymtable.foreach(@writeusedmacro,nil);
+        localmacrosymtable.foreach(@writeusedmacro,nil);
+        ppufile.writeentry(ibusedmacros);
+        ppufile.do_crc:=true;
+      end;
+{$ENDIF}
+
+    procedure tppumodule.writesourcefiles;
+      var
+        hp  : tinputfile;
+        i,j : longint;
+      begin
+      { second write the used source files }
+        ppufile.do_crc:=false;
+        hp:=sourcefiles.files;
+      { write source files directly in good order }
+        j:=0;
+        while assigned(hp) do
+          begin
+            inc(j);
+            hp:=hp.ref_next;
+          end;
+        while j>0 do
+          begin
+            hp:=sourcefiles.files;
+            for i:=1 to j-1 do
+              hp:=hp.ref_next;
+            ppufile.putstring(hp.name^);
+            ppufile.putlongint(hp.getfiletime);
+            dec(j);
+         end;
+        ppufile.writeentry(ibsourcefiles);
+        ppufile.do_crc:=true;
+      end;
+
+
+    procedure tppumodule.writeusedunit(intf:boolean);
+      var
+        hp : tused_unit;
+        oldcrc : boolean;
+      begin
+        { write a reference for each used unit }
+        hp:=tused_unit(used_units.first);
+        while assigned(hp) do
+         begin
+           if hp.in_interface=intf then
+             begin
+               ppufile.putstring(hp.u.realmodulename^);
+               { the checksum should not affect the crc of this unit ! (PFV) }
+               oldcrc:=ppufile.do_crc;
+               ppufile.do_crc:=false;
+               ppufile.putlongint(longint(hp.checksum));
+               ppufile.putlongint(longint(hp.interface_checksum));
+               ppufile.do_crc:=oldcrc;
+             end;
+           hp:=tused_unit(hp.next);
+         end;
+        ppufile.do_interface_crc:=true;
+        ppufile.writeentry(ibloadunit);
+      end;
+
+
+    procedure tppumodule.writelinkcontainer(var p:tlinkcontainer;id:byte;strippath:boolean);
+      var
+        hcontainer : tlinkcontainer;
+        s : string;
+        mask : cardinal;
+      begin
+        hcontainer:=TLinkContainer.Create;
+        while not p.empty do
+         begin
+           s:=p.get(mask);
+           if strippath then
+            ppufile.putstring(SplitFileName(s))
+           else
+            ppufile.putstring(s);
+           ppufile.putlongint(mask);
+           hcontainer.add(s,mask);
+         end;
+        ppufile.writeentry(id);
+        p.Free;
+        p:=hcontainer;
+      end;
+
+
+    procedure tppumodule.writederefmap;
+      var
+        i : longint;
+        oldcrc : boolean;
+      begin
+        { This does not influence crc }
+        oldcrc:=ppufile.do_crc;
+        ppufile.do_crc:=false;
+        { The unit map used for resolving }
+        ppufile.putlongint(derefmapcnt);
+        for i:=0 to derefmapcnt-1 do
+          begin
+            if not assigned(derefmap[i].u) then
+              internalerror(2005011512);
+            ppufile.putstring(derefmap[i].u.modulename^)
+          end;
+        ppufile.writeentry(ibderefmap);
+        ppufile.do_crc:=oldcrc;
+      end;
+
+
+    procedure tppumodule.writederefdata;
+      var
+        oldcrc : boolean;
+        len,hlen : longint;
+        buf : array[0..1023] of byte;
+      begin
+        if derefdataintflen>derefdata.size then
+          internalerror(200310223);
+        derefdata.seek(0);
+        { Write interface data }
+        len:=derefdataintflen;
+        while (len>0) do
+          begin
+            if len>1024 then
+              hlen:=1024
+            else
+              hlen:=len;
+            derefdata.read(buf,hlen);
+            ppufile.putdata(buf,hlen);
+            dec(len,hlen);
+          end;
+        { Write implementation data, this does not influence crc }
+        oldcrc:=ppufile.do_crc;
+        ppufile.do_crc:=false;
+        len:=derefdata.size-derefdataintflen;
+        while (len>0) do
+          begin
+            if len>1024 then
+              hlen:=1024
+            else
+              hlen:=len;
+            derefdata.read(buf,hlen);
+            ppufile.putdata(buf,hlen);
+            dec(len,hlen);
+          end;
+        if derefdata.pos<>derefdata.size then
+          internalerror(200310224);
+        ppufile.do_crc:=oldcrc;
+        ppufile.writeentry(ibderefdata);
+      end;
+
+
+    procedure tppumodule.putasmsymbol_in_idx(s:tnamedindexitem;arg:pointer);
+      begin
+        if tasmsymbol(s).ppuidx<>-1 then
+         librarydata.asmsymbolidx^[tasmsymbol(s).ppuidx-1]:=tasmsymbol(s);
+      end;
+
+
+    procedure tppumodule.writeasmsymbols;
+      var
+        s : tasmsymbol;
+        i : longint;
+        asmsymtype : byte;
+      begin
+        { get an ordered list of all symbols to put in the ppu }
+        getmem(librarydata.asmsymbolidx,librarydata.asmsymbolppuidx*sizeof(pointer));
+        fillchar(librarydata.asmsymbolidx^,librarydata.asmsymbolppuidx*sizeof(pointer),0);
+        librarydata.symbolsearch.foreach(@putasmsymbol_in_idx,nil);
+        { write the number of symbols }
+        ppufile.putlongint(librarydata.asmsymbolppuidx);
+        { write the symbols from the indexed list to the ppu }
+        for i:=1 to librarydata.asmsymbolppuidx do
+         begin
+           s:=librarydata.asmsymbolidx^[i-1];
+           if not assigned(s) then
+            internalerror(200208071);
+           asmsymtype:=1;
+           if s.Classtype=tasmlabel then
+            begin
+              if tasmlabel(s).is_addr then
+               asmsymtype:=4
+              else if tasmlabel(s).typ=AT_DATA then
+               asmsymtype:=3
+              else
+               asmsymtype:=2;
+            end;
+           ppufile.putbyte(asmsymtype);
+           case asmsymtype of
+             1 :
+               ppufile.putstring(s.name);
+             2..4 :
+               ppufile.putlongint(tasmlabel(s).labelnr);
+           end;
+           ppufile.putbyte(byte(s.defbind));
+           ppufile.putbyte(byte(s.typ));
+         end;
+        ppufile.writeentry(ibasmsymbols);
+      end;
+
+{$IFDEF MACRO_DIFF_HINT}
+
+{
+  Define MACRO_DIFF_HINT for the whole compiler (and ppudump)
+  to turn this facility on. Also the hint messages defined
+  below must be commented in in the msg/errore.msg file.
+
+  There is some problems with this, thats why it is shut off:
+
+  At the first compilation, consider a macro which is not initially
+  defined, but it is used (e g the check that it is undefined is true).
+  Since it do not exist, there is no macro object where the is_used
+  flag can be set. Later on when the macro is defined, and the ppu
+  is opened, the check cannot detect this.
+
+  Also, in which macro object should this flag be set ? It cant be set
+  for macros in the initialmacrosymboltable since this table is shared
+  between different files.
+}
+
+    procedure tppumodule.readusedmacros;
+      var
+        hs : string;
+        mac : tmacro;
+        was_initial,
+        was_used : boolean;
+      {Reads macros which was defined or used when the module was compiled.
+       This is done when a ppu file is open, before it possibly is parsed.}
+      begin
+        while not ppufile.endofentry do
+         begin
+           hs:=ppufile.getstring;
+           was_initial:=boolean(ppufile.getbyte);
+           was_used:=boolean(ppufile.getbyte);
+           mac:=tmacro(initialmacrosymtable.search(hs));
+           if assigned(mac) then
+             begin
+{$ifndef EXTDEBUG}
+           { if we don't have the sources why tell }
+              if sources_avail then
+{$endif ndef EXTDEBUG}
+               if (not was_initial) and was_used then
+                Message2(unit_h_cond_not_set_in_last_compile,hs,mainsource^);
+             end
+           else { not assigned }
+             if was_initial and
+                was_used then
+              Message2(unit_h_cond_set_in_last_compile,hs,mainsource^);
+         end;
+      end;
+{$ENDIF}
+
+    procedure tppumodule.readsourcefiles;
+      var
+        temp,hs       : string;
+        temp_dir      : string;
+        main_dir      : string;
+        found,
+        is_main       : boolean;
+        orgfiletime,
+        source_time   : longint;
+        hp            : tinputfile;
+      begin
+        sources_avail:=true;
+        is_main:=true;
+        main_dir:='';
+        while not ppufile.endofentry do
+         begin
+           hs:=ppufile.getstring;
+           orgfiletime:=ppufile.getlongint;
+           temp_dir:='';
+           if (flags and uf_in_library)<>0 then
+            begin
+              sources_avail:=false;
+              temp:=' library';
+            end
+           else if pos('Macro ',hs)=1 then
+            begin
+              { we don't want to find this file }
+              { but there is a problem with file indexing !! }
+              temp:='';
+            end
+           else
+            begin
+              { check the date of the source files:
+                 1 path of ppu
+                 2 path of main source
+                 3 current dir
+                 4 include/unit path }
+              Source_Time:=GetNamedFileTime(path^+hs);
+              found:=false;
+              if Source_Time<>-1 then
+                hs:=path^+hs
+              else
+               if not(is_main) then
+                begin
+                  Source_Time:=GetNamedFileTime(main_dir+hs);
+                  if Source_Time<>-1 then
+                    hs:=main_dir+hs;
+                end;
+              if Source_Time=-1 then
+                Source_Time:=GetNamedFileTime(hs);
+              if (Source_Time=-1) then
+                begin
+                  if is_main then
+                    found:=unitsearchpath.FindFile(hs,temp_dir)
+                  else
+                    found:=includesearchpath.FindFile(hs,temp_dir);
+                  if found then
+                   begin
+                     Source_Time:=GetNamedFileTime(temp_dir);
+                     if Source_Time<>-1 then
+                      hs:=temp_dir;
+                   end;
+                end;
+              if Source_Time<>-1 then
+                begin
+                  if is_main then
+                    main_dir:=splitpath(hs);
+                  temp:=' time '+filetimestring(source_time);
+                  if (orgfiletime<>-1) and
+                     (source_time<>orgfiletime) then
+                    begin
+                      if ((flags and uf_release)=0) then
+                        begin
+                          do_compile:=true;
+                          recompile_reason:=rr_sourcenewer;
+                        end
+                      else
+                        Message2(unit_h_source_modified,hs,ppufilename^);
+                      temp:=temp+' *';
+                    end;
+                end
+              else
+                begin
+                  sources_avail:=false;
+                  temp:=' not found';
+                end;
+              hp:=tinputfile.create(hs);
+              { the indexing is wrong here PM }
+              sourcefiles.register_file(hp);
+            end;
+           if is_main then
+             begin
+               stringdispose(mainsource);
+               mainsource:=stringdup(hs);
+             end;
+           Message1(unit_u_ppu_source,hs+temp);
+           is_main:=false;
+         end;
+      { check if we want to rebuild every unit, only if the sources are
+        available }
+        if do_build and sources_avail and
+           ((flags and uf_release)=0) then
+          begin
+             do_compile:=true;
+             recompile_reason:=rr_build;
+          end;
+      end;
+
+
+    procedure tppumodule.readloadunit;
+      var
+        hs : string;
+        pu : tused_unit;
+        hp : tppumodule;
+        intfchecksum,
+        checksum : cardinal;
+      begin
+        while not ppufile.endofentry do
+         begin
+           hs:=ppufile.getstring;
+           checksum:=cardinal(ppufile.getlongint);
+           intfchecksum:=cardinal(ppufile.getlongint);
+           { set the state of this unit before registering, this is
+             needed for a correct circular dependency check }
+           hp:=registerunit(self,hs,'');
+           pu:=addusedunit(hp,false,nil);
+           pu.checksum:=checksum;
+           pu.interface_checksum:=intfchecksum;
+         end;
+        in_interface:=false;
+      end;
+
+
+    procedure tppumodule.readlinkcontainer(var p:tlinkcontainer);
+      var
+        s : string;
+        m : longint;
+      begin
+        while not ppufile.endofentry do
+         begin
+           s:=ppufile.getstring;
+           m:=ppufile.getlongint;
+           p.add(s,m);
+         end;
+      end;
+
+
+    procedure tppumodule.readderefmap;
+      var
+        i : longint;
+      begin
+        { Load unit map used for resolving }
+        derefmapsize:=ppufile.getlongint;
+        getmem(derefmap,derefmapsize*sizeof(tderefmaprec));
+        fillchar(derefmap^,derefmapsize*sizeof(tderefmaprec),0);
+        for i:=0 to derefmapsize-1 do
+          derefmap[i].modulename:=stringdup(ppufile.getstring);
+      end;
+
+
+    procedure tppumodule.readderefdata;
+      var
+        len,hlen : longint;
+        buf : array[0..1023] of byte;
+      begin
+        len:=ppufile.entrysize;
+        while (len>0) do
+          begin
+            if len>1024 then
+              hlen:=1024
+            else
+              hlen:=len;
+            ppufile.getdata(buf,hlen);
+            derefdata.write(buf,hlen);
+            dec(len,hlen);
+          end;
+      end;
+
+
+    procedure tppumodule.readasmsymbols;
+      var
+        labelnr,
+        i     : longint;
+        name  : string;
+        bind  : TAsmSymBind;
+        typ   : TAsmSymType;
+        asmsymtype : byte;
+      begin
+        librarydata.asmsymbolppuidx:=ppufile.getlongint;
+        if librarydata.asmsymbolppuidx>0 then
+         begin
+           getmem(librarydata.asmsymbolidx,librarydata.asmsymbolppuidx*sizeof(pointer));
+           fillchar(librarydata.asmsymbolidx^,librarydata.asmsymbolppuidx*sizeof(pointer),0);
+           for i:=1 to librarydata.asmsymbolppuidx do
+            begin
+              asmsymtype:=ppufile.getbyte;
+              case asmsymtype of
+                1 :
+                  name:=ppufile.getstring;
+                2..4 :
+                  labelnr:=ppufile.getlongint;
+                else
+                  internalerror(200208192);
+              end;
+              bind:=tasmsymbind(ppufile.getbyte);
+              typ:=tasmsymtype(ppufile.getbyte);
+              case asmsymtype of
+                1 :
+                 librarydata.asmsymbolidx^[i-1]:=librarydata.newasmsymbol(name,bind,typ);
+                2 :
+                 librarydata.asmsymbolidx^[i-1]:=librarydata.newasmlabel(labelnr,false,false);
+                3 :
+                 librarydata.asmsymbolidx^[i-1]:=librarydata.newasmlabel(labelnr,false,true);
+                4 :
+                 librarydata.asmsymbolidx^[i-1]:=librarydata.newasmlabel(labelnr,true,false);
+              end;
+            end;
+         end;
+      end;
+
+
+    procedure tppumodule.load_interface;
+      var
+        b : byte;
+        newmodulename : string;
+      begin
+       { read interface part }
+         repeat
+           b:=ppufile.readentry;
+           case b of
+             ibmodulename :
+               begin
+                 newmodulename:=ppufile.getstring;
+                 if (cs_check_unit_name in aktglobalswitches) and
+                    (upper(newmodulename)<>modulename^) then
+                   Message2(unit_f_unit_name_error,realmodulename^,newmodulename);
+                 stringdispose(modulename);
+                 stringdispose(realmodulename);
+                 modulename:=stringdup(upper(newmodulename));
+                 realmodulename:=stringdup(newmodulename);
+               end;
+             ibsourcefiles :
+               readsourcefiles;
+{$IFDEF MACRO_DIFF_HINT}
+             ibusedmacros :
+               readusedmacros;
+{$ENDIF}
+             ibloadunit :
+               readloadunit;
+             iblinkunitofiles :
+               readlinkcontainer(LinkUnitOFiles);
+             iblinkunitstaticlibs :
+               readlinkcontainer(LinkUnitStaticLibs);
+             iblinkunitsharedlibs :
+               readlinkcontainer(LinkUnitSharedLibs);
+             iblinkotherofiles :
+               readlinkcontainer(LinkotherOFiles);
+             iblinkotherstaticlibs :
+               readlinkcontainer(LinkotherStaticLibs);
+             iblinkothersharedlibs :
+               readlinkcontainer(LinkotherSharedLibs);
+             ibderefmap :
+               readderefmap;
+             ibderefdata :
+               readderefdata;
+             ibendinterface :
+               break;
+           else
+             Message1(unit_f_ppu_invalid_entry,tostr(b));
+           end;
+           { we can already stop when we know that we must recompile }
+           if do_compile then
+             exit;
+         until false;
+      end;
+
+
+    procedure tppumodule.load_implementation;
+      var
+        b : byte;
+      begin
+         { read implementation part }
+         repeat
+           b:=ppufile.readentry;
+           case b of
+             ibloadunit :
+               readloadunit;
+             ibasmsymbols :
+               readasmsymbols;
+             ibendimplementation :
+               break;
+           else
+             Message1(unit_f_ppu_invalid_entry,tostr(b));
+           end;
+         until false;
+      end;
+
+
+    procedure tppumodule.load_symtable_refs;
+      var
+         b : byte;
+         i : longint;
+      begin
+        if (flags and uf_has_browser)<>0 then
+          begin
+            tstoredsymtable(globalsymtable).load_references(ppufile,true);
+            for i:=0 to unitmapsize-1 do
+              tstoredsymtable(globalsymtable).load_references(ppufile,false);
+            b:=ppufile.readentry;
+            if b<>ibendbrowser then
+             Message1(unit_f_ppu_invalid_entry,tostr(b));
+          end;
+        if ((flags and uf_local_browser)<>0) then
+          tstaticsymtable(localsymtable).load_references(ppufile,true);
+      end;
+
+
+    procedure tppumodule.writeppu;
+      var
+        pu : tused_unit;
+      begin
+         Message1(unit_u_ppu_write,realmodulename^);
+
+         { create unit flags }
+{$ifdef GDB}
+         if cs_gdb_dbx in aktglobalswitches then
+          flags:=flags or uf_has_dbx;
+{$endif GDB}
+         if cs_browser in aktmoduleswitches then
+          flags:=flags or uf_has_browser;
+         if cs_local_browser in aktmoduleswitches then
+          flags:=flags or uf_local_browser;
+         if do_release then
+          flags:=flags or uf_release;
+         if assigned(localsymtable) then
+           flags:=flags or uf_local_symtable;
+{$ifdef cpufpemu}
+         if (cs_fp_emulation in aktmoduleswitches) then
+           flags:=flags or uf_fpu_emulation;
+{$endif cpufpemu}
+{$ifdef Test_Double_checksum_write}
+         Assign(CRCFile,s+'.IMP');
+         Rewrite(CRCFile);
+{$endif def Test_Double_checksum_write}
+
+         { create new ppufile }
+         ppufile:=tcompilerppufile.create(ppufilename^);
+         if not ppufile.createfile then
+          Message(unit_f_ppu_cannot_write);
+
+         { first the unitname }
+         ppufile.putstring(realmodulename^);
+         ppufile.writeentry(ibmodulename);
+
+         writesourcefiles;
+{$IFDEF MACRO_DIFF_HINT}
+         writeusedmacros;
+{$ENDIF}
+
+         { write interface uses }
+         writeusedunit(true);
+
+         { write the objectfiles and libraries that come for this unit,
+           preserve the containers becuase they are still needed to load
+           the link.res. All doesn't depend on the crc! It doesn't matter
+           if a unit is in a .o or .a file }
+         ppufile.do_crc:=false;
+         writelinkcontainer(linkunitofiles,iblinkunitofiles,true);
+         writelinkcontainer(linkunitstaticlibs,iblinkunitstaticlibs,true);
+         writelinkcontainer(linkunitsharedlibs,iblinkunitsharedlibs,true);
+         writelinkcontainer(linkotherofiles,iblinkotherofiles,false);
+         writelinkcontainer(linkotherstaticlibs,iblinkotherstaticlibs,true);
+         writelinkcontainer(linkothersharedlibs,iblinkothersharedlibs,true);
+         ppufile.do_crc:=true;
+
+         { generate implementation deref data, the interface deref data is
+           already generated when calculating the interface crc }
+         if (cs_compilesystem in aktmoduleswitches) then
+           begin
+             tstoredsymtable(globalsymtable).buildderef;
+             derefdataintflen:=derefdata.size;
+           end;
+         tstoredsymtable(globalsymtable).buildderefimpl;
+         if (flags and uf_local_symtable)<>0 then
+           begin
+             tstoredsymtable(localsymtable).buildderef;
+             tstoredsymtable(localsymtable).buildderefimpl;
+           end;
+         writederefmap;
+         writederefdata;
+
+         ppufile.writeentry(ibendinterface);
+
+         { write the symtable entries }
+         tstoredsymtable(globalsymtable).ppuwrite(ppufile);
+
+         if assigned(globalmacrosymtable) and (globalmacrosymtable.symindex.count > 0) then
+           begin
+             ppufile.putbyte(byte(true));
+             ppufile.writeentry(ibexportedmacros);
+             tstoredsymtable(globalmacrosymtable).ppuwrite(ppufile);
+           end
+         else
+           begin
+             ppufile.putbyte(byte(false));
+             ppufile.writeentry(ibexportedmacros);
+           end;
+
+         { everything after this doesn't affect the crc }
+         ppufile.do_crc:=false;
+
+         { write implementation uses }
+         writeusedunit(false);
+
+         { write asmsymbols }
+         writeasmsymbols;
+
+         { end of implementation }
+         ppufile.writeentry(ibendimplementation);
+
+         { write static symtable
+           needed for local debugging of unit functions }
+         if (flags and uf_local_symtable)<>0 then
+           tstoredsymtable(localsymtable).ppuwrite(ppufile);
+
+         { write all browser section }
+         if (flags and uf_has_browser)<>0 then
+          begin
+            tstoredsymtable(globalsymtable).write_references(ppufile,true);
+            pu:=tused_unit(used_units.first);
+            while assigned(pu) do
+             begin
+               tstoredsymtable(pu.u.globalsymtable).write_references(ppufile,false);
+               pu:=tused_unit(pu.next);
+             end;
+            ppufile.writeentry(ibendbrowser);
+          end;
+         if ((flags and uf_local_browser)<>0) then
+           begin
+             if not assigned(localsymtable) then
+               internalerror(200408271);
+             tstaticsymtable(localsymtable).write_references(ppufile,true);
+           end;
+
+         { the last entry ibend is written automaticly }
+
+         { flush to be sure }
+         ppufile.flush;
+         { create and write header }
+         ppufile.header.size:=ppufile.size;
+         ppufile.header.checksum:=ppufile.crc;
+         ppufile.header.interface_checksum:=ppufile.interface_crc;
+         ppufile.header.compiler:=wordversion;
+         ppufile.header.cpu:=word(target_cpu);
+         ppufile.header.target:=word(target_info.system);
+         ppufile.header.flags:=flags;
+         ppufile.writeheader;
+
+         { save crc in current module also }
+         crc:=ppufile.crc;
+         interface_crc:=ppufile.interface_crc;
+
+{$ifdef Test_Double_checksum_write}
+         close(CRCFile);
+{$endif Test_Double_checksum_write}
+
+         ppufile.closefile;
+         ppufile.free;
+         ppufile:=nil;
+      end;
+
+
+    procedure tppumodule.getppucrc;
+      begin
+{$ifdef Test_Double_checksum_write}
+         Assign(CRCFile,s+'.INT')
+         Rewrite(CRCFile);
+{$endif def Test_Double_checksum_write}
+
+         { create new ppufile }
+         ppufile:=tcompilerppufile.create(ppufilename^);
+         ppufile.crc_only:=true;
+         if not ppufile.createfile then
+           Message(unit_f_ppu_cannot_write);
+
+         { first the unitname }
+         ppufile.putstring(realmodulename^);
+         ppufile.writeentry(ibmodulename);
+
+         { the interface units affect the crc }
+         writeusedunit(true);
+
+         { deref data of interface that affect the crc }
+         derefdata.reset;
+         tstoredsymtable(globalsymtable).buildderef;
+         derefdataintflen:=derefdata.size;
+         writederefmap;
+         writederefdata;
+
+         ppufile.writeentry(ibendinterface);
+
+         { write the symtable entries }
+         tstoredsymtable(globalsymtable).ppuwrite(ppufile);
+
+         if assigned(globalmacrosymtable) and (globalmacrosymtable.symindex.count > 0) then
+           begin
+             ppufile.putbyte(byte(true));
+             ppufile.writeentry(ibexportedmacros);
+             tstoredsymtable(globalmacrosymtable).ppuwrite(ppufile);
+           end
+         else
+           begin
+             ppufile.putbyte(byte(false));
+             ppufile.writeentry(ibexportedmacros);
+           end;
+
+         { save crc  }
+         crc:=ppufile.crc;
+         interface_crc:=ppufile.interface_crc;
+
+         { end of implementation, to generate a correct ppufile
+           for ppudump when using INTFPPU define }
+         ppufile.writeentry(ibendimplementation);
+
+{$ifdef Test_Double_checksum}
+         crc_array:=ppufile.crc_test;
+         ppufile.crc_test:=nil;
+         crc_size:=ppufile.crc_index2;
+         crc_array2:=ppufile.crc_test2;
+         ppufile.crc_test2:=nil;
+         crc_size2:=ppufile.crc_index2;
+{$endif Test_Double_checksum}
+
+{$ifdef Test_Double_checksum_write}
+         close(CRCFile);
+{$endif Test_Double_checksum_write}
+
+         { create and write header, this will only be used
+           for debugging purposes }
+         ppufile.header.size:=ppufile.size;
+         ppufile.header.checksum:=ppufile.crc;
+         ppufile.header.interface_checksum:=ppufile.interface_crc;
+         ppufile.header.compiler:=wordversion;
+         ppufile.header.cpu:=word(target_cpu);
+         ppufile.header.target:=word(target_info.system);
+         ppufile.header.flags:=flags;
+         ppufile.writeheader;
+
+         ppufile.closefile;
+         ppufile.free;
+         ppufile:=nil;
+      end;
+
+
+    procedure tppumodule.load_usedunits;
+      var
+        pu           : tused_unit;
+        load_refs    : boolean;
+        oldobjectlibrary : tasmlibrarydata;
+      begin
+        if current_module<>self then
+         internalerror(200212284);
+        load_refs:=true;
+
+        { load the used units from interface }
+        in_interface:=true;
+        pu:=tused_unit(used_units.first);
+        while assigned(pu) do
+         begin
+           if pu.in_interface then
+            begin
+              tppumodule(pu.u).loadppu;
+              { if this unit is compiled we can stop }
+              if state=ms_compiled then
+               exit;
+              { add this unit to the dependencies }
+              pu.u.adddependency(self);
+              { need to recompile the current unit, check the interface
+                crc. And when not compiled with -Ur then check the complete
+                crc }
+              if (pu.u.interface_crc<>pu.interface_checksum) or
+                 (
+                  ((ppufile.header.flags and uf_release)=0) and
+                  (pu.u.crc<>pu.checksum)
+                 ) then
+               begin
+                 Message2(unit_u_recompile_crc_change,realmodulename^,pu.u.realmodulename^);
+                 recompile_reason:=rr_crcchanged;
+                 do_compile:=true;
+                 exit;
+               end;
+            end;
+           pu:=tused_unit(pu.next);
+         end;
+
+        { ok, now load the interface of this unit }
+        if current_module<>self then
+         internalerror(200208187);
+        globalsymtable:=tglobalsymtable.create(modulename^,moduleid);
+        tstoredsymtable(globalsymtable).ppuload(ppufile);
+
+        if ppufile.readentry<>ibexportedmacros then
+          Message(unit_f_ppu_read_error);
+        if boolean(ppufile.getbyte) then
+          begin
+            globalmacrosymtable:=tmacrosymtable.Create(true);
+            tstoredsymtable(globalmacrosymtable).ppuload(ppufile)
+          end;
+
+        interface_compiled:=true;
+
+        { read the implementation part, containing
+          the implementation uses and objectdata }
+        in_interface:=false;
+        load_implementation;
+
+        { now only read the implementation uses }
+        pu:=tused_unit(used_units.first);
+        while assigned(pu) do
+         begin
+           if (not pu.in_interface) then
+            begin
+              tppumodule(pu.u).loadppu;
+              { if this unit is compiled we can stop }
+              if state=ms_compiled then
+               exit;
+              { add this unit to the dependencies }
+              pu.u.adddependency(self);
+              { need to recompile the current unit ? }
+              if (pu.u.interface_crc<>pu.interface_checksum) then
+                begin
+                  Message2(unit_u_recompile_crc_change,realmodulename^,pu.u.realmodulename^+' {impl}');
+                  recompile_reason:=rr_crcchanged;
+                  do_compile:=true;
+                  exit;
+                end;
+            end;
+           pu:=tused_unit(pu.next);
+         end;
+
+        { load implementation symtable }
+        if (flags and uf_local_symtable)<>0 then
+          begin
+            localsymtable:=tstaticsymtable.create(modulename^,moduleid);
+            tstaticsymtable(localsymtable).ppuload(ppufile);
+          end;
+
+        { we can now derefence all pointers to the implementation parts }
+        oldobjectlibrary:=objectlibrary;
+        objectlibrary:=librarydata;
+        tstoredsymtable(globalsymtable).derefimpl;
+        if assigned(localsymtable) then
+          tstoredsymtable(localsymtable).derefimpl;
+        objectlibrary:=oldobjectlibrary;
+
+        { load browser info if stored }
+        if ((flags and uf_has_browser)<>0) and load_refs then
+         begin
+           if current_module<>self then
+            internalerror(200208188);
+           load_symtable_refs;
+         end;
+      end;
+
+
+    function tppumodule.needrecompile:boolean;
+      var
+        pu : tused_unit;
+      begin
+        result:=false;
+        pu:=tused_unit(used_units.first);
+        while assigned(pu) do
+         begin
+           { need to recompile the current unit, check the interface
+             crc. And when not compiled with -Ur then check the complete
+             crc }
+           if (pu.u.interface_crc<>pu.interface_checksum) or
+              (
+               (pu.in_interface) and
+               (pu.u.crc<>pu.checksum)
+              ) then
+             begin
+               result:=true;
+               exit;
+             end;
+           pu:=tused_unit(pu.next);
+         end;
+      end;
+
+
+    procedure tppumodule.loadppu;
+      const
+        ImplIntf : array[boolean] of string[15]=('implementation','interface');
+      var
+        do_load,
+        second_time : boolean;
+        old_current_module : tmodule;
+      begin
+        old_current_module:=current_module;
+        Message3(unit_u_load_unit,old_current_module.modulename^,
+                 ImplIntf[old_current_module.in_interface],
+                 modulename^);
+
+        { Update loaded_from to detect cycles }
+        loaded_from:=old_current_module;
+
+        { check if the globalsymtable is already available, but
+          we must reload when the do_reload flag is set }
+        if (not do_reload) and
+           assigned(globalsymtable) then
+           exit;
+
+        { reset }
+        do_load:=true;
+        second_time:=false;
+        current_module:=self;
+        SetCompileModule(current_module);
+        Fillchar(aktfilepos,0,sizeof(aktfilepos));
+
+        { A force reload }
+        if do_reload then
+         begin
+           Message(unit_u_forced_reload);
+           do_reload:=false;
+           { When the unit is already loaded or being loaded
+             we can maybe skip a complete reload/recompile }
+           if assigned(globalsymtable) and
+              (not needrecompile) then
+             begin
+               { When we don't have any data stored yet there
+                 is nothing to resolve }
+               if interface_compiled then
+                 begin
+                   Message1(unit_u_reresolving_unit,modulename^);
+                   tstoredsymtable(globalsymtable).deref;
+                   tstoredsymtable(globalsymtable).derefimpl;
+                   if assigned(localsymtable) then
+                    begin
+                      tstoredsymtable(localsymtable).deref;
+                      tstoredsymtable(localsymtable).derefimpl;
+                    end;
+                 end
+               else
+                 Message1(unit_u_skipping_reresolving_unit,modulename^);
+               do_load:=false;
+             end;
+         end;
+
+        if do_load then
+         begin
+           { we are loading a new module, save the state of the scanner
+             and reset scanner+module }
+           if assigned(current_scanner) then
+             current_scanner.tempcloseinputfile;
+           current_scanner:=nil;
+
+           { loading the unit for a second time? }
+           if state=ms_registered then
+            state:=ms_load
+           else
+            begin
+              { try to load the unit a second time first }
+              Message1(unit_u_second_load_unit,modulename^);
+              Message2(unit_u_previous_state,modulename^,ModuleStateStr[state]);
+              { Flag modules to reload }
+              flagdependent(old_current_module);
+              { Reset the module }
+              reset;
+              if state in [ms_compile,ms_second_compile] then
+                begin
+                  Message1(unit_u_second_compile_unit,modulename^);
+                  state:=ms_second_compile;
+                  do_compile:=true;
+                end
+              else
+                state:=ms_second_load;
+              second_time:=true;
+            end;
+
+           { close old_current_ppu on system that are
+             short on file handles like DOS PM }
+{$ifdef SHORT_ON_FILE_HANDLES}
+           if old_current_module.is_unit and
+              assigned(tppumodule(old_current_module).ppufile) then
+             tppumodule(old_current_module).ppufile.tempclose;
+{$endif SHORT_ON_FILE_HANDLES}
+
+           { try to opening ppu, skip this when we already
+             know that we need to compile the unit }
+           if not do_compile then
+            begin
+              Message1(unit_u_loading_unit,modulename^);
+              search_unit(false,false);
+              if not do_compile then
+               begin
+                 load_interface;
+                 if not do_compile then
+                  begin
+                    load_usedunits;
+                    if not do_compile then
+                      Message1(unit_u_finished_loading_unit,modulename^);
+                  end;
+               end;
+              { PPU is not needed anymore }
+              if assigned(ppufile) then
+               begin
+                  ppufile.closefile;
+                  ppufile.free;
+                  ppufile:=nil;
+               end;
+            end;
+
+           { Do we need to recompile the unit }
+           if do_compile then
+            begin
+              { recompile the unit or give a fatal error if sources not available }
+              if not(sources_avail) then
+               begin
+                 if (not search_unit(true,false)) and
+                    (length(modulename^)>8) then
+                   search_unit(true,true);
+                 if not(sources_avail) then
+                  begin
+                    if recompile_reason=rr_noppu then
+                      Message1(unit_f_cant_find_ppu,realmodulename^)
+                    else
+                      Message1(unit_f_cant_compile_unit,realmodulename^);
+                  end;
+               end;
+              { Flag modules to reload }
+              flagdependent(old_current_module);
+              { Reset the module }
+              reset;
+              { compile this module }
+              if not(state in [ms_compile,ms_second_compile]) then
+                state:=ms_compile;
+              compile(mainsource^);
+            end
+           else
+            state:=ms_compiled;
+
+           if current_module<>self then
+             internalerror(200212282);
+
+           if in_interface then
+             internalerror(200212283);
+
+           { for a second_time recompile reload all dependent units,
+             for a first time compile register the unit _once_ }
+           if second_time then
+            reload_flagged_units
+           else
+            usedunits.concat(tused_unit.create(self,true,false,nil));
+
+           { reopen the old module }
+{$ifdef SHORT_ON_FILE_HANDLES}
+           if old_current_module.is_unit and
+              assigned(tppumodule(old_current_module).ppufile) then
+             tppumodule(old_current_module).ppufile.tempopen;
+{$endif SHORT_ON_FILE_HANDLES}
+
+           { reload old scanner }
+           current_scanner:=tscannerfile(old_current_module.scanner);
+           if assigned(current_scanner) then
+            begin
+              current_scanner.tempopeninputfile;
+              current_scanner.gettokenpos
+            end
+           else
+            fillchar(aktfilepos,sizeof(aktfilepos),0);
+         end;
+
+        { we are back, restore current_module }
+        current_module:=old_current_module;
+        SetCompileModule(current_module);
+      end;
+
+
+{*****************************************************************************
+                               RegisterUnit
+*****************************************************************************}
+
+
+    function registerunit(callermodule:tmodule;const s : stringid;const fn:string) : tppumodule;
+      var
+        ups   : stringid;
+        hp    : tppumodule;
+        hp2   : tmodule;
+      begin
+        { Info }
+        ups:=upper(s);
+        { search all loaded units }
+        hp:=tppumodule(loaded_units.first);
+        while assigned(hp) do
+         begin
+           if hp.modulename^=ups then
+            begin
+              { only check for units. The main program is also
+                as a unit in the loaded_units list. We simply need
+                to ignore this entry (PFV) }
+              if hp.is_unit then
+               begin
+                 { both units in interface ? }
+                 if callermodule.in_interface and
+                    hp.in_interface then
+                  begin
+                    { check for a cycle }
+                    hp2:=callermodule.loaded_from;
+                    while assigned(hp2) and (hp2<>hp) do
+                     begin
+                       if hp2.in_interface then
+                         hp2:=hp2.loaded_from
+                       else
+                         hp2:=nil;
+                     end;
+                    if assigned(hp2) then
+                      Message2(unit_f_circular_unit_reference,callermodule.realmodulename^,hp.realmodulename^);
+                  end;
+                 break;
+               end;
+            end;
+           { the next unit }
+           hp:=tppumodule(hp.next);
+         end;
+        { the unit is not in the loaded units,
+          we create an entry and register the unit }
+        if not assigned(hp) then
+         begin
+           Message1(unit_u_registering_new_unit,Upper(s));
+           hp:=tppumodule.create(callermodule,s,fn,true);
+           hp.loaded_from:=callermodule;
+           addloadedunit(hp);
+         end;
+        { return }
+        registerunit:=hp;
+      end;
+
+end.

compiler/gdb.pas

@@ -0,0 +1,233 @@
+{
+    Copyright (c) 1998-2002 by Florian Klaempfl
+
+    This units contains special support for the GDB
+
+    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 gdb;
+
+{$i fpcdefs.inc}
+
+interface
+
+uses
+  strings,
+  globtype,
+  aasmtai;
+
+{stab constants }
+Const
+    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;
+
+    type
+       tai_stabs = class(tai)
+          str : pchar;
+          constructor Create(_str : pchar);
+          destructor Destroy;override;
+       end;
+
+       tai_stabn = class(tai)
+          str : pchar;
+          constructor Create(_str : pchar);
+          destructor Destroy;override;
+       end;
+
+       { insert a cut to split into several smaller files }
+       tai_force_line = class(tailineinfo)
+          constructor Create;
+       end;
+
+       tai_stab_function_name = class(tai)
+          str : pchar;
+          constructor create(_str : pchar);
+          destructor destroy;override;
+       end;
+
+    const
+       DBX_counter : plongint = nil;
+       do_count_dbx : boolean = false;
+
+
+  implementation
+
+uses fmodule;
+
+{ to use N_EXCL we have to count the character in the stabs for
+N_BINCL to N_EINCL
+  Code comes from stabs.c for ld
+      if (type == N_BINCL)
+    (
+      bfd_vma val;
+      int nest;
+      bfd_byte *incl_sym;
+      struct stab_link_includes_entry *incl_entry;
+      struct stab_link_includes_totals *t;
+      struct stab_excl_list *ne;
+
+      val = 0;
+      nest = 0;
+      for (incl_sym = sym + STABSIZE;
+           incl_sym < symend;
+           incl_sym += STABSIZE)
+        (
+          int incl_type;
+
+          incl_type = incl_sym[TYPEOFF];
+          if (incl_type == 0)
+        break;
+          else if (incl_type == N_EINCL)
+        (
+          if (nest == 0)
+            break;
+          --nest;
+        )
+          else if (incl_type == N_BINCL)
+        ++nest;
+          else if (nest == 0)
+        (
+          const char *str;
+
+          str = ((char *) stabstrbuf
+             + stroff
+             + bfd_get_32 (abfd, incl_sym + STRDXOFF));
+          for (; *str != '\0'; str++)
+            (
+              val += *str;
+              if *str == '('
+            (
+               Skip the file number.
+              ++str;
+              while (isdigit ((unsigned char) *str))
+                ++str;
+              --str;
+            )
+            )
+        )
+        ) }
+
+
+   procedure count_dbx(st : pchar);
+     var i : longint;
+         do_count : boolean;
+     begin
+     do_count := false;
+     if assigned(dbx_counter) then
+       begin
+{$IfDef ExtDebugDbx }
+        Comment(V_Info,'Counting '+st);
+        Comment(V_Info,'count =  '+tostr(dbx_counter^));
+        Comment(V_Info,'addr = '+tostr(longint(dbx_counter)));
+{$EndIf ExtDebugDbx }
+          i:=0;
+          while i<=strlen(st) do
+            begin
+               if st[i] = '"' then
+                 if do_count then exit
+                 else do_count := true
+               else
+               if do_count then
+                 begin
+                   dbx_counter^ := dbx_counter^+byte(st[i]);
+                   { skip file number }
+                   if st[i] = '(' then
+                     begin
+                        inc(i);
+                        while st[i] in ['0'..'9'] do inc(i);
+                        dec(i);
+                     end;
+                 end;
+               inc(i);
+            end;
+       end;
+     end;
+
+
+    constructor tai_stabs.create(_str : pchar);
+
+      begin
+         inherited create;
+         typ:=ait_stabs;
+
+if current_module.modulename^='NCNV' then
+  current_module:=current_module;
+
+         str:=_str;
+         if do_count_dbx then
+           begin
+              count_dbx(str);
+           end;
+      end;
+
+    destructor tai_stabs.destroy;
+
+      begin
+         strdispose(str);
+         inherited destroy;
+      end;
+
+    constructor tai_stabn.create(_str : pchar);
+
+      begin
+         inherited create;
+         typ:=ait_stabn;
+         str:=_str;
+      end;
+
+    destructor tai_stabn.destroy;
+
+      begin
+         strdispose(str);
+         inherited destroy;
+      end;
+
+    constructor tai_force_line.create;
+
+      begin
+         inherited create;
+         typ:=ait_force_line;
+      end;
+
+    constructor tai_stab_function_name.create(_str : pchar);
+
+      begin
+         inherited create;
+         typ:=ait_stab_function_name;
+         str:=_str;
+      end;
+
+    destructor tai_stab_function_name.destroy;
+
+      begin
+         strdispose(str);
+         inherited destroy;
+      end;
+end.

compiler/gendef.pas

@@ -0,0 +1,159 @@
+{
+    Copyright (c) 1998-2002 by Florian Klaempfl
+
+    Generation of a .def file for needed for Os2/Win32
+
+    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 gendef;
+
+{$i fpcdefs.inc}
+
+interface
+uses
+  cclasses;
+
+type
+  tdeffile=class
+    fname : string;
+    constructor create(const fn:string);
+    destructor  destroy;override;
+    procedure addexport(const s:string);
+    procedure addimport(const s:string);
+    procedure writefile;
+    function empty : boolean;
+  private
+    is_empty : boolean;
+    WrittenOnDisk : boolean;
+    exportlist,
+    importlist   : tstringlist;
+  end;
+
+var
+  deffile : tdeffile;
+
+
+implementation
+
+uses
+  systems,cutils,globtype,globals;
+
+{******************************************************************************
+                               TDefFile
+******************************************************************************}
+
+constructor tdeffile.create(const fn:string);
+begin
+  fname:=fn;
+  WrittenOnDisk:=false;
+  is_empty:=true;
+  importlist:=TStringList.Create;
+  exportlist:=TStringList.Create;
+end;
+
+
+destructor tdeffile.destroy;
+begin
+  if WrittenOnDisk and
+     not(cs_link_extern in aktglobalswitches) then
+   RemoveFile(FName);
+  importlist.Free;
+  exportlist.Free;
+end;
+
+
+
+procedure tdeffile.addexport(const s:string);
+begin
+  exportlist.insert(s);
+  is_empty:=false;
+end;
+
+
+procedure tdeffile.addimport(const s:string);
+begin
+  importlist.insert(s);
+  is_empty:=false;
+end;
+
+
+function tdeffile.empty : boolean;
+begin
+  empty:=is_empty or DescriptionSetExplicity;
+end;
+
+
+procedure tdeffile.writefile;
+var
+  t : text;
+begin
+  If WrittenOnDisk then
+    Exit;
+{ open file }
+  assign(t,fname);
+  {$I+}
+   rewrite(t);
+  {$I-}
+  if ioresult<>0 then
+   exit;
+{$ifdef i386}
+  case target_info.system of
+    system_i386_Os2, system_i386_emx:
+      begin
+        write(t,'NAME '+inputfile);
+        if usewindowapi then
+          write(t,' WINDOWAPI');
+        writeln(t,'');
+        writeln(t,'PROTMODE');
+        writeln(t,'DESCRIPTION '+''''+description+'''');
+        writeln(t,'DATA'#9'MULTIPLE');
+        writeln(t,'STACKSIZE'#9+tostr(stacksize));
+        writeln(t,'HEAPSIZE'#9+tostr(heapsize));
+      end;
+  system_i386_win32, system_i386_wdosx :
+    begin
+      if description<>'' then
+        writeln(t,'DESCRIPTION '+''''+description+'''');
+      if dllversion<>'' then
+        writeln(t,'VERSION '+dllversion);
+    end;
+  end;
+{$endif}
+
+{write imports}
+  if not importlist.empty then
+   begin
+     writeln(t,'');
+     writeln(t,'IMPORTS');
+     while not importlist.empty do
+      writeln(t,#9+importlist.getfirst);
+   end;
+
+{write exports}
+  if not exportlist.empty then
+   begin
+     writeln(t,'');
+     writeln(t,'EXPORTS');
+     while not exportlist.empty do
+      writeln(t,#9+exportlist.getfirst);
+   end;
+
+  close(t);
+  WrittenOnDisk:=true;
+end;
+
+end.

compiler/globals.pas

@@ -0,0 +1,2294 @@
+{
+    Copyright (c) 1998-2002 by Florian Klaempfl
+
+    This unit implements some support functions and global variables
+
+    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 globals;
+
+{$i fpcdefs.inc}
+
+{ Use the internal linker by default }
+{ define INTERNALLINKER}
+
+interface
+
+    uses
+{$ifdef win32}
+      windows,
+{$endif}
+{$ifdef hasunix}
+  {$ifdef havelinuxrtl10}
+      linux,
+  {$else}
+      Baseunix,unix,
+  {$endif}
+{$endif}
+{$IFDEF USE_SYSUTILS}
+      SysUtils,
+{$ELSE USE_SYSUTILS}
+      strings,
+      dos,
+{$ENDIF USE_SYSUTILS}
+      cutils,cclasses,
+      cpuinfo,
+      globtype,version,systems;
+
+    const
+       delphimodeswitches : tmodeswitches=
+         [m_delphi,m_all,m_class,m_objpas,m_result,m_string_pchar,
+          m_pointer_2_procedure,m_autoderef,m_tp_procvar,m_initfinal,m_default_ansistring,
+          m_out,m_default_para,m_duplicate_names,m_hintdirective,m_add_pointer];
+       fpcmodeswitches    : tmodeswitches=
+         [m_fpc,m_all,m_string_pchar,m_nested_comment,m_repeat_forward,
+          m_cvar_support,m_initfinal,m_add_pointer,m_hintdirective];
+       objfpcmodeswitches : tmodeswitches=
+         [m_objfpc,m_fpc,m_all,m_class,m_objpas,m_result,m_string_pchar,m_nested_comment,
+          m_repeat_forward,m_cvar_support,m_initfinal,m_add_pointer,m_out,m_default_para,m_hintdirective];
+       tpmodeswitches     : tmodeswitches=
+         [m_tp7,m_all,m_tp_procvar,m_duplicate_names];
+       gpcmodeswitches    : tmodeswitches=
+         [m_gpc,m_all,m_tp_procvar];
+       macmodeswitches : tmodeswitches=
+         [m_mac,m_all,m_result,m_repeat_forward,m_cvar_support,m_tp_procvar];
+
+
+       { maximum number of locals in bytes before warning is emitted }
+       maxlocalsize = high(smallint);
+       { maximum number of paras in bytes before warning is emitted }
+       maxparasize = high(word);
+       { maximum nesting of routines }
+       maxnesting = 32;
+
+       { Filenames and extensions }
+       sourceext  = '.pp';
+       pasext     = '.pas';
+       pext       = '.p';
+
+       treelogfilename = 'tree.log';
+
+{$if defined(CPUARM) and defined(FPUFPA)}
+       MathQNaN : tdoublearray = (0,0,252,255,0,0,0,0);
+       MathInf : tdoublearray = (0,0,240,127,0,0,0,0);
+       MathNegInf : tdoublearray = (0,0,240,255,0,0,0,0);
+       MathPi : tdoublearray =  (251,33,9,64,24,45,68,84);
+{$else}
+{$ifdef FPC_LITTLE_ENDIAN}
+       MathQNaN : tdoublearray = (0,0,0,0,0,0,252,255);
+       MathInf : tdoublearray = (0,0,0,0,0,0,240,127);
+       MathNegInf : tdoublearray = (0,0,0,0,0,0,240,255);
+       MathPi : tdoublearray =  (24,45,68,84,251,33,9,64);
+       MathPiExtended : textendedarray = (53,194,104,33,162,218,15,201,0,64);
+{$else FPC_LITTLE_ENDIAN}
+       MathQNaN : tdoublearray = (255,252,0,0,0,0,0,0);
+       MathInf : tdoublearray = (127,240,0,0,0,0,0,0);
+       MathNegInf : tdoublearray = (255,240,0,0,0,0,0,0);
+       MathPi : tdoublearray =  (64,9,33,251,84,68,45,24);
+       MathPiExtended : textendedarray = (64,0,201,15,218,162,33,104,194,53);
+{$endif FPC_LITTLE_ENDIAN}
+{$endif}
+
+    type
+       TFPUException = (exInvalidOp, exDenormalized, exZeroDivide,
+                        exOverflow, exUnderflow, exPrecision);
+       TFPUExceptionMask = set of TFPUException;
+
+       pfileposinfo = ^tfileposinfo;
+       tfileposinfo = record
+         line      : longint;
+         column    : word;
+         fileindex : word;
+         { moduleindex : word; }
+       end;
+
+       TSearchPathList = class(TStringList)
+         procedure AddPath(s:string;addfirst:boolean);overload;
+         procedure AddPath(SrcPath,s:string;addfirst:boolean);overload;
+         procedure AddList(list:TSearchPathList;addfirst:boolean);
+         function  FindFile(const f : string;var foundfile:string):boolean;
+       end;
+
+       tcodepagestring = string[20];
+
+    var
+       { specified inputfile }
+       inputdir          : dirstr;
+       inputfile         : namestr;
+       inputextension    : extstr;
+       { specified outputfile with -o parameter }
+       outputfile        : namestr;
+       outputprefix      : pstring;
+       outputsuffix      : pstring;
+       outputextension   : namestr;
+       { specified with -FE or -FU }
+       outputexedir      : dirstr;
+       outputunitdir     : dirstr;
+
+       { things specified with parameters }
+       paralinkoptions,
+       paradynamiclinker : string;
+       paraprintnodetree : byte;
+       parapreprocess    : boolean;
+       printnodefile     : text;
+
+       {  typical cross compiling params}
+
+       { directory where the utils can be found (options -FD) }
+       utilsdirectory : dirstr;
+       { targetname specific prefix used by these utils (options -XP<path>) }
+       utilsprefix    : dirstr;
+       cshared        : boolean;        { pass --shared to ld to link C libs shared}
+       Dontlinkstdlibpath: Boolean;     { Don't add std paths to linkpath}
+       rlinkpath      : dirstr;         { rpath-link linkdir override}
+
+       { some flags for global compiler switches }
+       do_build,
+       do_release,
+       do_make       : boolean;
+       { path for searching units, different paths can be seperated by ; }
+       exepath            : dirstr;  { Path to ppc }
+       librarysearchpath,
+       unitsearchpath,
+       objectsearchpath,
+       includesearchpath  : TSearchPathList;
+       autoloadunits      : string;
+
+       { linking }
+       usewindowapi  : boolean;
+       description   : string;
+       DescriptionSetExplicity : boolean;
+       dllversion    : string;
+       dllmajor,
+       dllminor,
+       dllrevision   : word;  { revision only for netware }
+       UseDeffileForExports    : boolean;
+       UseDeffileForExportsSetExplicitly : boolean;
+       RelocSection : boolean;
+       RelocSectionSetExplicitly : boolean;
+       LinkTypeSetExplicitly : boolean;
+
+       akttokenpos,                  { position of the last token }
+       aktfilepos : tfileposinfo;    { current position }
+
+       nwscreenname : string;
+       nwthreadname : string;
+       nwcopyright  : string;
+
+       codegenerror : boolean;           { true if there is an error reported }
+
+       block_type : tblock_type;         { type of currently parsed block }
+
+       parsing_para_level : integer;     { parameter level, used to convert
+                                           proc calls to proc loads in firstcalln }
+       compile_level : word;
+       make_ref : boolean;
+       resolving_forward : boolean;      { used to add forward reference as second ref }
+       inlining_procedure : boolean;     { are we inlining a procedure }
+       exceptblockcounter    : integer;  { each except block gets a unique number check gotos      }
+       aktexceptblock        : integer;  { the exceptblock number of the current block (0 if none) }
+
+     { commandline values }
+       initglobalswitches : tglobalswitches;
+       initmoduleswitches : tmoduleswitches;
+       initlocalswitches  : tlocalswitches;
+       initmodeswitches   : tmodeswitches;
+       {$IFDEF testvarsets}
+        Initsetalloc,                            {0=fixed, 1 =var}
+       {$ENDIF}
+       initpackenum       : shortint;
+     {$ifdef ansistring_bits}
+       initansistring_bits: Tstringbits;
+     {$endif}
+       initalignment      : talignmentinfo;
+       initoptprocessor,
+       initspecificoptprocessor : tprocessors;
+       initfputype        : tfputype;
+       initasmmode        : tasmmode;
+       initinterfacetype  : tinterfacetypes;
+       initoutputformat   : tasm;
+       initdefproccall    : tproccalloption;
+       initsourcecodepage : tcodepagestring;
+
+     { current state values }
+       aktglobalswitches  : tglobalswitches;
+       aktmoduleswitches  : tmoduleswitches;
+       aktlocalswitches   : tlocalswitches;
+       nextaktlocalswitches : tlocalswitches;
+       localswitcheschanged : boolean;
+       aktmodeswitches    : tmodeswitches;
+       {$IFDEF testvarsets}
+        aktsetalloc,
+       {$ENDIF}
+       aktpackrecords,
+       aktpackenum        : shortint;
+     {$ifdef ansistring_bits}
+       aktansistring_bits : Tstringbits;
+     {$endif}
+       aktmaxfpuregisters : longint;
+       aktalignment       : talignmentinfo;
+       aktoptprocessor,
+       aktspecificoptprocessor : tprocessors;
+       aktfputype        : tfputype;
+       aktasmmode         : tasmmode;
+       aktinterfacetype   : tinterfacetypes;
+       aktoutputformat    : tasm;
+       aktdefproccall     : tproccalloption;
+       aktsourcecodepage : tcodepagestring;
+
+     { Memory sizes }
+       heapsize,
+       stacksize,
+       jmp_buf_size : longint;
+
+{$Ifdef EXTDEBUG}
+     { parameter switches }
+       debugstop : boolean;
+{$EndIf EXTDEBUG}
+       { windows / OS/2 application type }
+       apptype : tapptype;
+
+    const
+       DLLsource : boolean = false;
+       DLLImageBase : pstring = nil;
+
+       { used to set all registers used for each global function
+         this should dramatically decrease the number of
+         recompilations needed PM }
+       simplify_ppu : boolean = true;
+
+       { should we allow non static members ? }
+       allow_only_static : boolean = false;
+
+       Inside_asm_statement : boolean = false;
+
+       global_unit_count : word = 0;
+
+       { for error info in pp.pas }
+       parser_current_file : string = '';
+
+{$ifdef m68k}
+       { PalmOS resources }
+       palmos_applicationname : string = 'FPC Application';
+       palmos_applicationid : string[4] = 'FPCA';
+{$endif m68k}
+
+{$ifdef powerpc}
+       { default calling convention used on MorphOS }
+       syscall_convention : string = 'LEGACY';
+{$endif powerpc}
+
+    procedure abstract;
+
+    function bstoslash(const s : string) : string;
+
+    function getdatestr:string;
+    function gettimestr:string;
+    function filetimestring( t : longint) : string;
+
+    procedure DefaultReplacements(var s:string);
+    {Gives the absolute path to the current directory}
+    function  GetCurrentDir:string;
+    {Gives the relative path to the current directory,
+     with a trailing dir separator. E. g. on unix ./ }
+    function CurDirRelPath(systeminfo: tsysteminfo): string;
+    function  path_absolute(const s : string) : boolean;
+    Function  PathExists ( F : String) : Boolean;
+    Function  FileExists ( Const F : String) : Boolean;
+    function  FileExistsNonCase(const path,fn:string;var foundfile:string):boolean;
+    Function  RemoveFile(const f:string):boolean;
+    Function  RemoveDir(d:string):boolean;
+    Function  GetFileTime ( Var F : File) : Longint;
+    Function  GetNamedFileTime ( Const F : String) : Longint;
+    {Extracts the path without its filename, from a path.}
+    Function  SplitPath(const s:string):string;
+    Function  SplitFileName(const s:string):string;
+    Function  SplitName(const s:string):string;
+    Function  SplitExtension(Const HStr:String):String;
+    Function  AddExtension(Const HStr,ext:String):String;
+    Function  ForceExtension(Const HStr,ext:String):String;
+    Function  FixPath(s:string;allowdot:boolean):string;
+    function  FixFileName(const s:string):string;
+    function  TargetFixPath(s:string;allowdot:boolean):string;
+    function  TargetFixFileName(const s:string):string;
+    procedure SplitBinCmd(const s:string;var bstr: String;var cstr:TCmdStr);
+    function  FindFile(const f : string;path : string;var foundfile:string):boolean;
+    function  FindFilePchar(const f : string;path : pchar;var foundfile:string):boolean;
+    function  FindExe(const bin:string;var foundfile:string):boolean;
+    function  GetShortName(const n:string):string;
+    function  cleanpath(const s:string):String;
+
+    function Shell(const command:string): longint;
+    function  GetEnvPChar(const envname:string):pchar;
+    procedure FreeEnvPChar(p:pchar);
+
+    procedure SetFPUExceptionMask(const Mask: TFPUExceptionMask);
+    function is_number_float(d : double) : boolean;
+
+    Function SetCompileMode(const s:string; changeInit: boolean):boolean;
+    function SetAktProcCall(const s:string; changeInit: boolean):boolean;
+    function SetProcessor(const s:string; changeInit: boolean):boolean;
+    function SetFpuType(const s:string; changeInit: boolean):boolean;
+
+    procedure InitGlobals;
+    procedure DoneGlobals;
+
+    function  string2guid(const s: string; var GUID: TGUID): boolean;
+    function  guid2string(const GUID: TGUID): string;
+
+    function UpdateAlignmentStr(s:string;var a:talignmentinfo):boolean;
+
+    {# Routine to get the required alignment for size of data, which will
+       be placed in bss segment, according to the current alignment requirements }
+    function var_align(siz: longint): longint;
+    {# Routine to get the required alignment for size of data, which will
+       be placed in data/const segment, according to the current alignment requirements }
+    function const_align(siz: longint): longint;
+
+{$IFDEF MACOS_USE_FAKE_SYSUTILS}
+
+{Since SysUtils is not yet available for MacOS, fake
+ Exceptions classes are included here.}
+
+type
+   { exceptions }
+   Exception = class(TObject);
+
+   EExternal = class(Exception);
+
+   { integer math exceptions }
+   EInterror    = Class(EExternal);
+   EDivByZero   = Class(EIntError);
+   ERangeError  = Class(EIntError);
+   EIntOverflow = Class(EIntError);
+
+   { General math errors }
+   EMathError  = Class(EExternal);
+   EInvalidOp  = Class(EMathError);
+   EZeroDivide = Class(EMathError);
+   EOverflow   = Class(EMathError);
+   EUnderflow  = Class(EMathError);
+
+{$ENDIF MACOS_USE_FAKE_SYSUTILS}
+
+implementation
+
+    uses
+{$ifdef macos}
+      macutils,
+{$endif}
+      comphook;
+
+    procedure abstract;
+      begin
+        do_internalerror(255);
+      end;
+
+
+    procedure WarnNonExistingPath(const path : string);
+      begin
+        if assigned(do_comment) then
+          do_comment(V_Tried,'Path "'+path+'" not found');
+      end;
+
+
+    function bstoslash(const s : string) : string;
+    {
+      return string s with all \ changed into /
+    }
+      var
+         i : longint;
+      begin
+        for i:=1to length(s) do
+         if s[i]='\' then
+          bstoslash[i]:='/'
+         else
+          bstoslash[i]:=s[i];
+         bstoslash[0]:=s[0];
+      end;
+
+
+{****************************************************************************
+                               Time Handling
+****************************************************************************}
+
+    Function L0(l:longint):string;
+    {
+      return the string of value l, if l<10 then insert a zero, so
+      the string is always at least 2 chars '01','02',etc
+    }
+      var
+        s : string;
+      begin
+        Str(l,s);
+        if l<10 then
+         s:='0'+s;
+        L0:=s;
+      end;
+
+
+   function gettimestr:string;
+   {
+     get the current time in a string HH:MM:SS
+   }
+      var
+        hour,min,sec,hsec : word;
+      begin
+{$IFDEF USE_SYSUTILS}
+        DecodeTime(Time,hour,min,sec,hsec);
+{$ELSE USE_SYSUTILS}
+        dos.gettime(hour,min,sec,hsec);
+{$ENDIF USE_SYSUTILS}
+        gettimestr:=L0(Hour)+':'+L0(min)+':'+L0(sec);
+      end;
+
+
+   function getdatestr:string;
+   {
+     get the current date in a string YY/MM/DD
+   }
+      var
+{$IFDEF USE_SYSUTILS}
+        Year,Month,Day: Word;
+{$ELSE USE_SYSUTILS}
+        Year,Month,Day,Wday : Word;
+{$ENDIF USE_SYSUTILS}
+      begin
+{$IFDEF USE_SYSUTILS}
+        DecodeDate(Date,year,month,day);
+{$ELSE USE_SYSUTILS}
+        dos.getdate(year,month,day,wday);
+{$ENDIF USE_SYSUTILS}
+        getdatestr:=L0(Year)+'/'+L0(Month)+'/'+L0(Day);
+      end;
+
+
+   function  filetimestring( t : longint) : string;
+   {
+     convert dos datetime t to a string YY/MM/DD HH:MM:SS
+   }
+     var
+{$IFDEF USE_SYSUTILS}
+       DT : TDateTime;
+       hsec : word;
+{$ELSE USE_SYSUTILS}
+       DT : DateTime;
+{$ENDIF USE_SYSUTILS}
+       Year,Month,Day: Word;
+       hour,min,sec : word;
+     begin
+       if t=-1 then
+        begin
+          Result := 'Not Found';
+          exit;
+        end;
+{$IFDEF USE_SYSUTILS}
+       DT := FileDateToDateTime(t);
+       DecodeTime(DT,hour,min,sec,hsec);
+       DecodeDate(DT,year,month,day);
+{$ELSE USE_SYSUTILS}
+       unpacktime(t,DT);
+       year := DT.year;
+       month := DT.month;
+       day := DT.day;
+       hour := DT.hour;
+       min := DT.min;
+       sec := DT.sec;
+{$ENDIF USE_SYSUTILS}
+       Result := L0(Year)+'/'+L0(Month)+'/'+L0(Day)+' '+L0(Hour)+':'+L0(min)+':'+L0(sec);
+     end;
+
+
+{****************************************************************************
+                          Default Macro Handling
+****************************************************************************}
+
+     procedure DefaultReplacements(var s:string);
+       begin
+         { Replace some macros }
+         Replace(s,'$FPCVERSION',version_string);
+         Replace(s,'$FPCFULLVERSION',full_version_string);
+         Replace(s,'$FPCDATE',date_string);
+         Replace(s,'$FPCCPU',target_cpu_string);
+         Replace(s,'$FPCOS',target_os_string);
+         if tf_use_8_3 in Source_Info.Flags then
+           Replace(s,'$FPCTARGET',target_os_string)
+         else
+           Replace(s,'$FPCTARGET',target_full_string);
+       end;
+
+
+{****************************************************************************
+                               File Handling
+****************************************************************************}
+
+     var
+       CachedCurrentDir : string;
+
+   {Gives the absolute path to the current directory}
+   function GetCurrentDir:string;
+     begin
+       if CachedCurrentDir='' then
+         begin
+           GetDir(0,CachedCurrentDir);
+           CachedCurrentDir:=FixPath(CachedCurrentDir,false);
+         end;
+       result:=CachedCurrentDir;
+     end;
+
+   {Gives the relative path to the current directory,
+    with a trailing dir separator. E. g. on unix ./ }
+   function CurDirRelPath(systeminfo: tsysteminfo): string;
+
+   begin
+     if systeminfo.system <> system_powerpc_macos then
+       CurDirRelPath:= '.'+systeminfo.DirSep
+     else
+       CurDirRelPath:= ':'
+   end;
+
+
+   function path_absolute(const s : string) : boolean;
+   {
+     is path s an absolute path?
+   }
+     begin
+        path_absolute:=false;
+{$ifdef unix}
+        if (length(s)>0) and (s[1]='/') then
+          path_absolute:=true;
+{$else unix}
+{$ifdef amiga}
+        if ((length(s)>0) and ((s[1]='\') or (s[1]='/'))) or (Pos(':',s) = length(s)) then
+          path_absolute:=true;
+{$else}
+{$ifdef macos}
+        if IsMacFullPath(s) then
+          path_absolute:=true;
+{$else}
+        if ((length(s)>0) and ((s[1]='\') or (s[1]='/'))) or
+           ((length(s)>2) and (s[2]=':') and ((s[3]='\') or (s[3]='/'))) then
+          path_absolute:=true;
+{$endif macos}
+{$endif amiga}
+{$endif unix}
+     end;
+
+{$ifndef FPC}
+    Procedure FindClose(var Info : SearchRec);
+      Begin
+      End;
+{$endif not FPC}
+
+
+    Function FileExists ( Const F : String) : Boolean;
+{$IFDEF USE_SYSUTILS}
+{$ELSE USE_SYSUTILS}
+      var
+         Info : SearchRec;
+{$ENDIF USE_SYSUTILS}
+      begin
+{$IFDEF USE_SYSUTILS}
+        Result:=SysUtils.FileExists(f);
+{$ELSE USE_SYSUTILS}
+        findfirst(F,readonly+archive+hidden,info);
+        result:=(doserror=0);
+        findclose(Info);
+{$ENDIF USE_SYSUTILS}
+        if assigned(do_comment) then
+         begin
+           if Result then
+             do_comment(V_Tried,'Searching file '+F+'... found')
+           else
+             do_comment(V_Tried,'Searching file '+F+'... not found');
+         end;
+      end;
+
+
+    function FileExistsNonCase(const path,fn:string;var foundfile:string):boolean;
+      var
+        fn2 : string;
+      begin
+        result:=false;
+        if source_info.files_case_relevent then
+          begin
+            {
+              Search order for case sensitive systems:
+               1. NormalCase
+               2. lowercase
+               3. UPPERCASE
+            }
+            FoundFile:=path+fn;
+            If FileExists(FoundFile) then
+             begin
+               result:=true;
+               exit;
+             end;
+            fn2:=Lower(fn);
+            if fn2<>fn then
+              begin
+                FoundFile:=path+fn2;
+                If FileExists(FoundFile) then
+                 begin
+                   result:=true;
+                   exit;
+                 end;
+              end;
+            fn2:=Upper(fn);
+            if fn2<>fn then
+              begin
+                FoundFile:=path+fn2;
+                If FileExists(FoundFile) then
+                 begin
+                   result:=true;
+                   exit;
+                 end;
+              end;
+          end
+        else
+          begin
+            { None case sensitive only lowercase }
+            FoundFile:=path+Lower(fn);
+            If FileExists(FoundFile) then
+             begin
+               result:=true;
+               exit;
+             end;
+          end;
+        { Set foundfile to something usefull }
+        FoundFile:=fn;
+      end;
+
+
+    Function PathExists ( F : String) : Boolean;
+      Var
+{$IFDEF USE_SYSUTILS}
+{$ELSE USE_SYSUTILS}
+        FF : file;
+{$ENDIF USE_SYSUTILS}
+        A: word;
+        I: longint;
+      begin
+        if F = '' then
+          begin
+            PathExists := true;
+            exit;
+          end;
+        F := FExpand (F);
+        I := Pos (DriveSeparator, F);
+        if (F [Length (F)] = DirectorySeparator)
+                  and (((I = 0) and (Length (F) > 1)) or (I <> Length (F) - 1))
+          then
+            Delete (F, Length (F), 1);
+{$IFDEF USE_SYSUTILS}
+        PathExists := FileGetAttr(F) and faDirectory = faDirectory;
+{$ELSE USE_SYSUTILS}
+        Assign (FF, FExpand (F));
+        GetFAttr (FF, A);
+        PathExists := (DosError = 0) and (A and Directory = Directory);
+{$ENDIF USE_SYSUTILS}
+      end;
+
+
+    Function RemoveFile(const f:string):boolean;
+      var
+        g : file;
+      begin
+        assign(g,f);
+        {$I-}
+         erase(g);
+        {$I+}
+        RemoveFile:=(ioresult=0);
+      end;
+
+
+    Function RemoveDir(d:string):boolean;
+      begin
+        if d[length(d)]=source_info.DirSep then
+         Delete(d,length(d),1);
+        {$I-}
+         rmdir(d);
+        {$I+}
+        RemoveDir:=(ioresult=0);
+      end;
+
+
+    Function SplitPath(const s:string):string;
+      var
+        i : longint;
+      begin
+        i:=Length(s);
+{$ifdef macos}
+        while (i>0) and not(s[i] in [':']) do
+         dec(i);
+{$else macos}
+        while (i>0) and not(s[i] in ['/','\']) do
+         dec(i);
+{$endif macos}
+        SplitPath:=Copy(s,1,i);
+      end;
+
+
+    Function SplitFileName(const s:string):string;
+{$IFDEF USE_SYSUTILS}
+{$ELSE USE_SYSUTILS}
+      var
+        p : dirstr;
+        n : namestr;
+        e : extstr;
+{$ENDIF USE_SYSUTILS}
+      begin
+{$IFDEF USE_SYSUTILS}
+        SplitFileName:=ExtractFileName(s);
+{$ELSE USE_SYSUTILS}
+        FSplit(s,p,n,e);
+        SplitFileName:=n+e;
+{$ENDIF USE_SYSUTILS}
+      end;
+
+
+    Function SplitName(const s:string):string;
+      var
+        i,j : longint;
+      begin
+        i:=Length(s);
+        j:=Length(s);
+        while (i>0) and not(s[i] in ['/','\']) do
+         dec(i);
+        while (j>0) and (s[j]<>'.') do
+         dec(j);
+        if j<=i then
+         j:=255;
+        SplitName:=Copy(s,i+1,j-(i+1));
+      end;
+
+
+    Function SplitExtension(Const HStr:String):String;
+      var
+        j : longint;
+      begin
+        j:=length(Hstr);
+        while (j>0) and (Hstr[j]<>'.') do
+         begin
+           if hstr[j]=source_info.DirSep then
+            j:=0
+           else
+            dec(j);
+         end;
+        if j=0 then
+         j:=254;
+        SplitExtension:=Copy(Hstr,j,255);
+      end;
+
+
+    Function AddExtension(Const HStr,ext:String):String;
+      begin
+        if (Ext<>'') and (SplitExtension(HStr)='') then
+         AddExtension:=Hstr+Ext
+        else
+         AddExtension:=Hstr;
+      end;
+
+
+    Function ForceExtension(Const HStr,ext:String):String;
+      var
+        j : longint;
+      begin
+        j:=length(Hstr);
+        while (j>0) and (Hstr[j]<>'.') do
+         dec(j);
+        if j=0 then
+         j:=255;
+        ForceExtension:=Copy(Hstr,1,j-1)+Ext;
+      end;
+
+
+    Function FixPath(s:string;allowdot:boolean):string;
+      var
+        i : longint;
+      begin
+        { Fix separator }
+        for i:=1 to length(s) do
+         if s[i] in ['/','\'] then
+          s[i]:=source_info.DirSep;
+        { Fix ending / }
+        if (length(s)>0) and (s[length(s)]<>source_info.DirSep) and
+           (s[length(s)]<>':') then
+         s:=s+source_info.DirSep;
+        { Remove ./ }
+        if (not allowdot) and (s='.'+source_info.DirSep) then
+         s:='';
+        { return }
+        if source_info.files_case_relevent then
+         FixPath:=s
+        else
+         FixPath:=Lower(s);
+      end;
+
+  {Actually the version in macutils.pp could be used,
+   but that would not work for crosscompiling, so this is a slightly modified
+   version of it.}
+  function TranslatePathToMac (const path: string; mpw: Boolean): string;
+
+    function GetVolumeIdentifier: string;
+
+    begin
+      GetVolumeIdentifier := '{Boot}'
+      (*
+      if mpw then
+        GetVolumeIdentifier := '{Boot}'
+      else
+        GetVolumeIdentifier := macosBootVolumeName;
+      *)
+    end;
+
+    var
+      slashPos, oldpos, newpos, oldlen, maxpos: Longint;
+
+  begin
+    oldpos := 1;
+    slashPos := Pos('/', path);
+    if (slashPos <> 0) then   {its a unix path}
+      begin
+        if slashPos = 1 then
+          begin      {its a full path}
+            oldpos := 2;
+            TranslatePathToMac := GetVolumeIdentifier;
+          end
+        else     {its a partial path}
+          TranslatePathToMac := ':';
+      end
+    else
+      begin
+        slashPos := Pos('\', path);
+        if (slashPos <> 0) then   {its a dos path}
+          begin
+            if slashPos = 1 then
+              begin      {its a full path, without drive letter}
+                oldpos := 2;
+                TranslatePathToMac := GetVolumeIdentifier;
+              end
+            else if (Length(path) >= 2) and (path[2] = ':') then {its a full path, with drive letter}
+              begin
+                oldpos := 4;
+                TranslatePathToMac := GetVolumeIdentifier;
+              end
+            else     {its a partial path}
+              TranslatePathToMac := ':';
+          end;
+      end;
+
+    if (slashPos <> 0) then   {its a unix or dos path}
+      begin
+        {Translate "/../" to "::" , "/./" to ":" and "/" to ":" }
+        newpos := Length(TranslatePathToMac);
+        oldlen := Length(path);
+        SetLength(TranslatePathToMac, newpos + oldlen);  {It will be no longer than what is already}
+                                                                        {prepended plus length of path.}
+        maxpos := Length(TranslatePathToMac);          {Get real maxpos, can be short if String is ShortString}
+
+        {There is never a slash in the beginning, because either it was an absolute path, and then the}
+        {drive and slash was removed, or it was a relative path without a preceding slash.}
+        while oldpos <= oldlen do
+          begin
+            {Check if special dirs, ./ or ../ }
+            if path[oldPos] = '.' then
+              if (oldpos + 1 <= oldlen) and (path[oldPos + 1] = '.') then
+                begin
+                  if (oldpos + 2 > oldlen) or (path[oldPos + 2] in ['/', '\']) then
+                    begin
+                      {It is "../" or ".."  translates to ":" }
+                      if newPos = maxPos then
+                        begin {Shouldn't actually happen, but..}
+                          Exit('');
+                        end;
+                      newPos := newPos + 1;
+                      TranslatePathToMac[newPos] := ':';
+                      oldPos := oldPos + 3;
+                      continue;  {Start over again}
+                    end;
+                end
+              else if (oldpos + 1 > oldlen) or (path[oldPos + 1] in ['/', '\']) then
+                begin
+                  {It is "./" or "."  ignor it }
+                  oldPos := oldPos + 2;
+                  continue;  {Start over again}
+                end;
+
+            {Collect file or dir name}
+            while (oldpos <= oldlen) and not (path[oldPos] in ['/', '\']) do
+              begin
+                if newPos = maxPos then
+                  begin {Shouldn't actually happen, but..}
+                    Exit('');
+                  end;
+                newPos := newPos + 1;
+                TranslatePathToMac[newPos] := path[oldPos];
+                oldPos := oldPos + 1;
+              end;
+
+            {When we come here there is either a slash or we are at the end.}
+            if (oldpos <= oldlen) then
+              begin
+                if newPos = maxPos then
+                  begin {Shouldn't actually happen, but..}
+                    Exit('');
+                  end;
+                newPos := newPos + 1;
+                TranslatePathToMac[newPos] := ':';
+                oldPos := oldPos + 1;
+              end;
+          end;
+
+        SetLength(TranslatePathToMac, newpos);
+      end
+    else if (path = '.') then
+      TranslatePathToMac := ':'
+    else if (path = '..') then
+      TranslatePathToMac := '::'
+    else
+      TranslatePathToMac := path;  {its a mac path}
+  end;
+
+
+   function FixFileName(const s:string):string;
+     var
+       i      : longint;
+     begin
+       if source_info.system = system_powerpc_MACOS then
+         FixFileName:= TranslatePathToMac(s, true)
+       else if source_info.files_case_relevent then
+        begin
+          for i:=1 to length(s) do
+           begin
+             case s[i] of
+               '/','\' :
+                 FixFileName[i]:=source_info.dirsep;
+               else
+                 FixFileName[i]:=s[i];
+             end;
+           end;
+          FixFileName[0]:=s[0];
+        end
+       else
+        begin
+          for i:=1 to length(s) do
+           begin
+             case s[i] of
+               '/','\' :
+                  FixFileName[i]:=source_info.dirsep;
+               'A'..'Z' :
+                  FixFileName[i]:=char(byte(s[i])+32);
+                else
+                  FixFileName[i]:=s[i];
+             end;
+           end;
+          FixFileName[0]:=s[0];
+        end;
+     end;
+
+
+    Function TargetFixPath(s:string;allowdot:boolean):string;
+      var
+        i : longint;
+      begin
+        { Fix separator }
+        for i:=1 to length(s) do
+         if s[i] in ['/','\'] then
+          s[i]:=target_info.DirSep;
+        { Fix ending / }
+        if (length(s)>0) and (s[length(s)]<>target_info.DirSep) and
+           (s[length(s)]<>':') then
+         s:=s+target_info.DirSep;
+        { Remove ./ }
+        if (not allowdot) and (s='.'+target_info.DirSep) then
+         s:='';
+        { return }
+        if target_info.files_case_relevent then
+         TargetFixPath:=s
+        else
+         TargetFixPath:=Lower(s);
+      end;
+
+
+   function TargetFixFileName(const s:string):string;
+     var
+       i : longint;
+     begin
+       if target_info.system = system_powerpc_MACOS then
+         TargetFixFileName:= TranslatePathToMac(s, true)
+       else if target_info.files_case_relevent then
+         begin
+           for i:=1 to length(s) do
+           begin
+             case s[i] of
+               '/','\' :
+                 TargetFixFileName[i]:=target_info.dirsep;
+               else
+                 TargetFixFileName[i]:=s[i];
+             end;
+           end;
+           TargetFixFileName[0]:=s[0];
+         end
+       else
+         begin
+           for i:=1 to length(s) do
+           begin
+             case s[i] of
+               '/','\' :
+                  TargetFixFileName[i]:=target_info.dirsep;
+               'A'..'Z' :
+                  TargetFixFileName[i]:=char(byte(s[i])+32);
+                else
+                  TargetFixFileName[i]:=s[i];
+             end;
+           end;
+           TargetFixFileName[0]:=s[0];
+         end;
+     end;
+
+
+   procedure SplitBinCmd(const s:string;var bstr:String;var cstr:TCmdStr);
+     var
+       i : longint;
+     begin
+       i:=pos(' ',s);
+       if i>0 then
+        begin
+          bstr:=Copy(s,1,i-1);
+          cstr:=Copy(s,i+1,length(s)-i);
+        end
+       else
+        begin
+          bstr:=s;
+          cstr:='';
+        end;
+     end;
+
+  procedure TSearchPathList.AddPath(s:string;addfirst:boolean);
+    begin
+      AddPath('',s,AddFirst);
+    end;
+
+   procedure TSearchPathList.AddPath(SrcPath,s:string;addfirst:boolean);
+     var
+       staridx,
+       j        : longint;
+       prefix,
+       suffix,
+       CurrentDir,
+       currPath : string;
+       subdirfound : boolean;
+{$IFDEF USE_SYSUTILS}
+       dir      : TSearchRec;
+{$ELSE USE_SYSUTILS}
+       dir      : searchrec;
+{$ENDIF USE_SYSUTILS}
+       hp       : TStringListItem;
+
+       procedure AddCurrPath;
+       begin
+         if addfirst then
+          begin
+            Remove(currPath);
+            Insert(currPath);
+          end
+         else
+          begin
+            { Check if already in path, then we don't add it }
+            hp:=Find(currPath);
+            if not assigned(hp) then
+             Concat(currPath);
+          end;
+       end;
+
+     begin
+       if s='' then
+        exit;
+     { Support default macro's }
+       DefaultReplacements(s);
+     { get current dir }
+       CurrentDir:=GetCurrentDir;
+       repeat
+         { get currpath }
+         if addfirst then
+          begin
+            j:=length(s);
+            while (j>0) and (s[j]<>';') do
+             dec(j);
+            currPath:= TrimSpace(Copy(s,j+1,length(s)-j));
+            DePascalQuote(currPath);
+            currPath:=FixPath(currPath,false);
+            if j=0 then
+             s:=''
+            else
+             System.Delete(s,j,length(s)-j+1);
+          end
+         else
+          begin
+            j:=Pos(';',s);
+            if j=0 then
+             j:=255;
+            currPath:= TrimSpace(Copy(s,1,j-1));
+            DePascalQuote(currPath);
+            currPath:=SrcPath+FixPath(currPath,false);
+            System.Delete(s,1,j);
+          end;
+
+         { fix pathname }
+         if currPath='' then
+           currPath:= CurDirRelPath(source_info)
+         else
+          begin
+            currPath:=FixPath(FExpand(currPath),false);
+            if (CurrentDir<>'') and (Copy(currPath,1,length(CurrentDir))=CurrentDir) then
+             begin
+{$ifdef AMIGA}
+               currPath:= CurrentDir+Copy(currPath,length(CurrentDir)+1,255);
+{$else}
+               currPath:= CurDirRelPath(source_info)+Copy(currPath,length(CurrentDir)+1,255);
+{$endif}
+             end;
+          end;
+         { wildcard adding ? }
+         staridx:=pos('*',currpath);
+         if staridx>0 then
+          begin
+            prefix:=SplitPath(Copy(currpath,1,staridx));
+            suffix:=Copy(currpath,staridx+1,length(currpath));
+            subdirfound:=false;
+{$IFDEF USE_SYSUTILS}
+            if findfirst(prefix+'*',faDirectory,dir) = 0 then
+              begin
+                repeat
+                  if (dir.name<>'.') and
+                      (dir.name<>'..') and
+                      ((dir.attr and faDirectory)<>0) then
+                    begin
+                      subdirfound:=true;
+                      currpath:=prefix+dir.name+suffix;
+                      if (suffix='') or PathExists(currpath) then
+                        begin
+                          hp:=Find(currPath);
+                          if not assigned(hp) then
+                            AddCurrPath;
+                        end;
+                    end;
+                until findnext(dir) <> 0;
+              end
+{$ELSE USE_SYSUTILS}
+            findfirst(prefix+'*',directory,dir);
+            while doserror=0 do
+             begin
+               if (dir.name<>'.') and
+                  (dir.name<>'..') and
+                  ((dir.attr and directory)<>0) then
+                begin
+                  subdirfound:=true;
+                  currpath:=prefix+dir.name+suffix;
+                  if (suffix='') or PathExists(currpath) then
+                    begin
+                      hp:=Find(currPath);
+                      if not assigned(hp) then
+                        AddCurrPath;
+                    end;
+                end;
+               findnext(dir);
+             end;
+{$ENDIF USE_SYSUTILS}
+            FindClose(dir);
+            if not subdirfound then
+              WarnNonExistingPath(currpath);
+          end
+         else
+          begin
+            if PathExists(currpath) then
+             AddCurrPath
+            else
+             WarnNonExistingPath(currpath);
+          end;
+       until (s='');
+     end;
+
+
+   procedure TSearchPathList.AddList(list:TSearchPathList;addfirst:boolean);
+     var
+       s : string;
+       hl : TSearchPathList;
+       hp,hp2 : TStringListItem;
+     begin
+       if list.empty then
+        exit;
+       { create temp and reverse the list }
+       if addfirst then
+        begin
+          hl:=TSearchPathList.Create;
+          hp:=TStringListItem(list.first);
+          while assigned(hp) do
+           begin
+             hl.insert(hp.Str);
+             hp:=TStringListItem(hp.next);
+           end;
+          while not hl.empty do
+           begin
+             s:=hl.GetFirst;
+             Remove(s);
+             Insert(s);
+           end;
+          hl.Free;
+        end
+       else
+        begin
+          hp:=TStringListItem(list.first);
+          while assigned(hp) do
+           begin
+             hp2:=Find(hp.Str);
+             { Check if already in path, then we don't add it }
+             if not assigned(hp2) then
+              Concat(hp.Str);
+             hp:=TStringListItem(hp.next);
+           end;
+        end;
+     end;
+
+
+   function TSearchPathList.FindFile(const f : string;var foundfile:string):boolean;
+     Var
+       p : TStringListItem;
+     begin
+       FindFile:=false;
+       p:=TStringListItem(first);
+       while assigned(p) do
+        begin
+          result:=FileExistsNonCase(p.Str,f,FoundFile);
+          if result then
+            exit;
+          p:=TStringListItem(p.next);
+        end;
+       { Return original filename if not found }
+       FoundFile:=f;
+     end;
+
+
+   Function GetFileTime ( Var F : File) : Longint;
+     Var
+     {$ifdef hasunix}
+        info: Stat;
+     {$endif}
+       L : longint;
+     begin
+     {$ifdef hasunix}
+       {$IFDEF havelinuxrtl10}
+        FStat (F,Info);
+        L:=Info.Mtime;
+       {$ELSE}
+        FPFStat (F,Info);
+        L:=Info.st_Mtime;
+       {$ENDIF}
+     {$else}
+       GetFTime(f,l);
+     {$endif}
+       GetFileTime:=L;
+     end;
+
+
+   Function GetNamedFileTime (Const F : String) : Longint;
+     begin
+       GetNamedFileTime:=do_getnamedfiletime(F);
+     end;
+
+
+   function FindFile(const f : string;path : string;var foundfile:string):boolean;
+      Var
+        singlepathstring : string;
+        i : longint;
+     begin
+{$ifdef Unix}
+       for i:=1 to length(path) do
+        if path[i]=':' then
+         path[i]:=';';
+{$endif Unix}
+       FindFile:=false;
+       repeat
+          i:=pos(';',path);
+          if i=0 then
+           i:=256;
+          singlepathstring:=FixPath(copy(path,1,i-1),false);
+          delete(path,1,i);
+          result:=FileExistsNonCase(singlepathstring,f,FoundFile);
+          if result then
+            exit;
+       until path='';
+       FoundFile:=f;
+     end;
+
+
+   function FindFilePchar(const f : string;path : pchar;var foundfile:string):boolean;
+      Var
+        singlepathstring : string;
+        startpc,pc : pchar;
+        sepch : char;
+     begin
+{$ifdef Unix}
+       sepch:=':';
+{$else}
+{$ifdef macos}
+       sepch:=',';
+{$else}
+       sepch:=';';
+{$endif macos}
+{$endif Unix}
+       FindFilePchar:=false;
+       pc:=path;
+       repeat
+          startpc:=pc;
+          while (pc^<>sepch) and (pc^<>';') and (pc^<>#0) do
+           inc(pc);
+          move(startpc^,singlepathstring[1],pc-startpc);
+          singlepathstring[0]:=char(longint(pc-startpc));
+          singlepathstring:=FixPath(singlepathstring,false);
+          result:=FileExistsNonCase(singlepathstring,f,FoundFile);
+          if result then
+            exit;
+          if (pc^=#0) then
+            break;
+          inc(pc);
+       until false;
+       foundfile:=f;
+     end;
+
+
+   function  FindExe(const bin:string;var foundfile:string):boolean;
+     var
+       p : pchar;
+       found : boolean;
+     begin
+       found:=FindFile(FixFileName(AddExtension(bin,source_info.exeext)),'.;'+exepath,foundfile);
+       if not found then
+        begin
+{$ifdef macos}
+          p:=GetEnvPchar('Commands');
+{$else}
+          p:=GetEnvPchar('PATH');
+{$endif}
+          found:=FindFilePChar(FixFileName(AddExtension(bin,source_info.exeext)),p,foundfile);
+          FreeEnvPChar(p);
+        end;
+       FindExe:=found;
+     end;
+
+
+    function GetShortName(const n:string):string;
+{$ifdef win32}
+      var
+        hs,hs2 : string;
+        i : longint;
+{$endif}
+{$ifdef go32v2}
+      var
+        hs : string;
+{$endif}
+{$ifdef watcom}
+      var
+        hs : string;
+{$endif}
+      begin
+        GetShortName:=n;
+{$ifdef win32}
+        hs:=n+#0;
+        i:=Windows.GetShortPathName(@hs[1],@hs2[1],high(hs2));
+        if (i>0) and (i<=high(hs2)) then
+          begin
+            hs2[0]:=chr(strlen(@hs2[1]));
+            GetShortName:=hs2;
+          end;
+{$endif}
+{$ifdef go32v2}
+        hs:=n;
+        if Dos.GetShortName(hs) then
+         GetShortName:=hs;
+{$endif}
+{$ifdef watcom}
+        hs:=n;
+        if Dos.GetShortName(hs) then
+         GetShortName:=hs;
+{$endif}
+      end;
+
+
+function  CleanPath(const s:string):String;
+{ Wrapper that encapsulate fexpand/expandfilename}
+begin
+{$IFDEF USE_SYSUTILS}
+ cleanpath:=ExpandFileName(s);
+{$else}
+ cleanpath:=fexpand(s);
+{$endif}
+end;
+ {****************************************************************************
+                               OS Dependent things
+ ****************************************************************************}
+
+    function GetEnvPChar(const envname:string):pchar;
+      {$ifdef win32}
+      var
+        s     : string;
+        i,len : longint;
+        hp,p,p2 : pchar;
+      {$endif}
+      begin
+      {$ifdef hasunix}
+        GetEnvPchar:={$ifdef havelinuxrtl10}Linux.getenv{$else}BaseUnix.fpGetEnv{$endif}(envname);
+        {$define GETENVOK}
+      {$endif}
+      {$ifdef win32}
+        GetEnvPchar:=nil;
+        p:=GetEnvironmentStrings;
+        hp:=p;
+        while hp^<>#0 do
+         begin
+           s:=strpas(hp);
+           i:=pos('=',s);
+           len:=strlen(hp);
+           if upper(copy(s,1,i-1))=upper(envname) then
+            begin
+              GetMem(p2,len-length(envname));
+              Move(hp[i],p2^,len-length(envname));
+              GetEnvPchar:=p2;
+              break;
+            end;
+           { next string entry}
+           hp:=hp+len+1;
+         end;
+        FreeEnvironmentStrings(p);
+        {$define GETENVOK}
+      {$endif}
+      {$ifdef os2}
+        GetEnvPChar := Dos.GetEnvPChar (EnvName);
+        {$define GETENVOK}
+      {$endif}
+      {$ifdef GETENVOK}
+        {$undef GETENVOK}
+      {$else}
+        GetEnvPchar:=StrPNew(Dos.Getenv(envname));
+      {$endif}
+      end;
+
+
+    procedure FreeEnvPChar(p:pchar);
+      begin
+      {$ifndef hasunix}
+       {$ifndef os2}
+        StrDispose(p);
+       {$endif}
+      {$endif}
+      end;
+
+{$IFDEF MORPHOS}
+{$DEFINE AMIGASHELL}
+{$ENDIF}
+{$IFDEF AMIGA}
+{$DEFINE AMIGASHELL}
+{$ENDIF}
+
+    function Shell(const command:string): longint;
+      { This is already defined in the linux.ppu for linux, need for the *
+        expansion under linux }
+      {$ifdef hasunix}
+      begin
+        result := {$ifdef havelinuxrtl10}Linux{$else}Unix{$endif}.Shell(command);
+      end;
+      {$else}
+      {$ifdef amigashell}
+      begin
+{$IFDEF USE_SYSUTILS}
+        result := ExecuteProcess('',command);
+{$ELSE USE_SYSUTILS}
+        exec('',command);
+        if (doserror <> 0) then
+          result := doserror
+        else
+          result := dosexitcode;
+      end;
+{$ENDIF USE_SYSUTILS}
+      {$else}
+      var
+        comspec : string;
+      begin
+        comspec:=getenv('COMSPEC');
+{$IFDEF USE_SYSUTILS}
+        result := ExecuteProcess(comspec,' /C '+command);
+{$ELSE USE_SYSUTILS}
+        Exec(comspec,' /C '+command);
+        if (doserror <> 0) then
+          result := doserror
+        else
+          result := dosexitcode;
+      end;
+{$ENDIF USE_SYSUTILS}
+      {$endif}
+      {$endif}
+
+{$UNDEF AMIGASHELL}
+
+{$ifdef CPUI386}
+  {$define HASSETFPUEXCEPTIONMASK}
+      { later, this should be replaced by the math unit }
+      const
+        Default8087CW : word = $1332;
+
+      procedure Set8087CW(cw:word);assembler;
+        asm
+          movw cw,%ax
+          movw %ax,default8087cw
+          fnclex
+          fldcw default8087cw
+        end;
+
+
+      function Get8087CW:word;assembler;
+        asm
+          pushl $0
+          fnstcw (%esp)
+          popl %eax
+        end;
+
+
+      procedure SetFPUExceptionMask(const Mask: TFPUExceptionMask);
+        var
+          CtlWord: Word;
+        begin
+          CtlWord:=Get8087CW;
+          Set8087CW( (CtlWord and $FFC0) or Byte(Longint(Mask)) );
+        end;
+{$endif CPUI386}
+
+{$ifdef CPUX86_64}
+  {$define HASSETFPUEXCEPTIONMASK}
+      { later, this should be replaced by the math unit }
+      const
+        Default8087CW : word = $1332;
+
+      procedure Set8087CW(cw:word);assembler;
+        asm
+          movw cw,%ax
+          movw %ax,default8087cw
+          fnclex
+          fldcw default8087cw
+        end;
+
+
+      function Get8087CW:word;assembler;
+        asm
+          pushq $0
+          fnstcw (%rsp)
+          popq %rax
+        end;
+
+
+      procedure SetSSECSR(w : dword);
+        var
+          _w : dword;
+        begin
+          _w:=w;
+          asm
+            ldmxcsr _w
+          end;
+        end;
+
+
+      function GetSSECSR : dword;
+          var
+            _w : dword;
+          begin
+            asm
+              stmxcsr _w
+            end;
+            result:=_w;
+          end;
+
+
+      procedure SetFPUExceptionMask(const Mask: TFPUExceptionMask);
+        var
+          CtlWord: Word;
+          newmask : dword;
+        const
+          MM_MaskInvalidOp = %0000000010000000;
+          MM_MaskDenorm    = %0000000100000000;
+          MM_MaskDivZero   = %0000001000000000;
+          MM_MaskOverflow  = %0000010000000000;
+          MM_MaskUnderflow = %0000100000000000;
+          MM_MaskPrecision = %0001000000000000;
+        begin
+          { classic FPU }
+          CtlWord:=Get8087CW;
+          Set8087CW( (CtlWord and $FFC0) or Byte(Longint(Mask)) );
+
+          { SSE }
+
+          newmask:=GetSSECSR;
+
+          { invalid operation }
+          if (exInvalidOp in mask) then
+            newmask:=newmask or MM_MaskInvalidOp
+          else
+            newmask:=newmask and not(MM_MaskInvalidOp);
+
+          { denormals }
+          if (exDenormalized in mask) then
+            newmask:=newmask or MM_MaskDenorm
+          else
+            newmask:=newmask and not(MM_MaskDenorm);
+
+          { zero divide }
+          if (exZeroDivide in mask) then
+            newmask:=newmask or MM_MaskDivZero
+          else
+            newmask:=newmask and not(MM_MaskDivZero);
+
+          { overflow }
+          if (exOverflow in mask) then
+            newmask:=newmask or MM_MaskOverflow
+          else
+            newmask:=newmask and not(MM_MaskOverflow);
+
+          { underflow }
+          if (exUnderflow in mask) then
+            newmask:=newmask or MM_MaskUnderflow
+          else
+            newmask:=newmask and not(MM_MaskUnderflow);
+
+          { Precision (inexact result) }
+          if (exPrecision in mask) then
+            newmask:=newmask or MM_MaskPrecision
+          else
+            newmask:=newmask and not(MM_MaskPrecision);
+          SetSSECSR(newmask);
+        end;
+{$endif CPUX86_64}
+
+{$ifdef CPUPOWERPC}
+  {$define HASSETFPUEXCEPTIONMASK}
+      procedure SetFPUExceptionMask(const Mask: TFPUExceptionMask);
+        var
+          newmask: record
+            case byte of
+               1: (d: double);
+               2: (a,b: cardinal);
+            end;
+        begin
+          { load current control register contents }
+          asm
+            mffs f0
+            stfd f0,newmask.d
+          end;
+          { invalid operation: bit 24 (big endian, bit 0 = left-most bit) }
+          if (exInvalidOp in mask) then
+            newmask.b := newmask.b and not(1 shl (31-24))
+          else
+            newmask.b := newmask.b or (1 shl (31-24));
+
+          { denormals can not cause exceptions on the PPC }
+
+          { zero divide: bit 27 }
+          if (exZeroDivide in mask) then
+            newmask.b := newmask.b and not(1 shl (31-27))
+          else
+            newmask.b := newmask.b or (1 shl (31-27));
+
+          { overflow: bit 25 }
+          if (exOverflow in mask) then
+            newmask.b := newmask.b and not(1 shl (31-25))
+          else
+            newmask.b := newmask.b or (1 shl (31-25));
+
+          { underflow: bit 26 }
+          if (exUnderflow in mask) then
+            newmask.b := newmask.b and not(1 shl (31-26))
+          else
+            newmask.b := newmask.b or (1 shl (31-26));
+
+          { Precision (inexact result): bit 28 }
+          if (exPrecision in mask) then
+            newmask.b := newmask.b and not(1 shl (31-28))
+          else
+            newmask.b := newmask.b or (1 shl (31-28));
+          { update control register contents }
+          asm
+            lfd   f0, newmask.d
+            mtfsf 255,f0
+          end;
+        end;
+{$endif CPUPOWERPC}
+
+{$ifdef CPUSPARC}
+  {$define HASSETFPUEXCEPTIONMASK}
+      procedure SetFPUExceptionMask(const Mask: TFPUExceptionMask);
+        var
+          fsr : cardinal;
+        begin
+          { load current control register contents }
+          asm
+            st %fsr,fsr
+          end;
+          { invalid operation: bit 27 }
+          if (exInvalidOp in mask) then
+            fsr:=fsr and not(1 shl 27)
+          else
+            fsr:=fsr or (1 shl 27);
+
+          { zero divide: bit 24 }
+          if (exZeroDivide in mask) then
+            fsr:=fsr and not(1 shl 24)
+          else
+            fsr:=fsr or (1 shl 24);
+
+          { overflow: bit 26 }
+          if (exOverflow in mask) then
+            fsr:=fsr and not(1 shl 26)
+          else
+            fsr:=fsr or (1 shl 26);
+
+          { underflow: bit 25 }
+          if (exUnderflow in mask) then
+            fsr:=fsr and not(1 shl 25)
+          else
+            fsr:=fsr or (1 shl 25);
+
+          { Precision (inexact result): bit 23 }
+          if (exPrecision in mask) then
+            fsr:=fsr and not(1 shl 23)
+          else
+            fsr:=fsr or (1 shl 23);
+          { update control register contents }
+          asm
+            ld fsr,%fsr
+          end;
+        end;
+{$endif CPUSPARC}
+
+{$ifndef HASSETFPUEXCEPTIONMASK}
+      procedure SetFPUExceptionMask(const Mask: TFPUExceptionMask);
+        begin
+        end;
+{$endif HASSETFPUEXCEPTIONMASK}
+
+      function is_number_float(d : double) : boolean;
+        var
+           bytearray : array[0..7] of byte;
+        begin
+          move(d,bytearray,8);
+          { only 1.1 save, 1.0.x will use always little endian }
+{$ifdef FPC_BIG_ENDIAN}
+          result:=((bytearray[0] and $7f)<>$7f) or ((bytearray[1] and $f0)<>$f0);
+{$else FPC_BIG_ENDIAN}
+          result:=((bytearray[7] and $7f)<>$7f) or ((bytearray[6] and $f0)<>$f0);
+{$endif FPC_BIG_ENDIAN}
+        end;
+
+
+    function convertdoublearray(d : tdoublearray) : tdoublearray;{$ifdef USEINLINE}inline;{$endif}
+{$ifdef CPUARM}
+      var
+        i : longint;
+      begin
+        for i:=0 to 3 do
+          begin
+            result[i+4]:=d[i];
+            result[i]:=d[i+4];
+          end;
+{$else CPUARM}
+      begin
+        result:=d;
+{$endif CPUARM}
+      end;
+
+
+      Function SetCompileMode(const s:string; changeInit: boolean):boolean;
+      var
+        b : boolean;
+      begin
+        b:=true;
+        if s='DEFAULT' then
+          aktmodeswitches:=initmodeswitches
+        else
+         if s='DELPHI' then
+          aktmodeswitches:=delphimodeswitches
+        else
+         if s='TP' then
+          aktmodeswitches:=tpmodeswitches
+        else
+         if s='FPC' then
+          aktmodeswitches:=fpcmodeswitches
+        else
+         if s='OBJFPC' then
+          aktmodeswitches:=objfpcmodeswitches
+        else
+         if s='GPC' then
+          aktmodeswitches:=gpcmodeswitches
+        else
+         if s='MACPAS' then
+          aktmodeswitches:=macmodeswitches
+        else
+         b:=false;
+
+        if b and changeInit then
+          initmodeswitches := aktmodeswitches;
+
+        if b then
+         begin
+           { turn ansistrings on by default ? }
+           if (m_delphi in aktmodeswitches) then
+            begin
+              include(aktlocalswitches,cs_ansistrings);
+              if changeinit then
+               include(initlocalswitches,cs_ansistrings);
+            end
+           else
+            begin
+              exclude(aktlocalswitches,cs_ansistrings);
+              if changeinit then
+               exclude(initlocalswitches,cs_ansistrings);
+            end;
+           { Default enum packing for delphi/tp7 }
+           if (m_tp7 in aktmodeswitches) or
+              (m_delphi in aktmodeswitches) then
+             aktpackenum:=1
+           else
+             aktpackenum:=4;
+           if changeinit then
+             initpackenum:=aktpackenum;
+{$ifdef i386}
+           { Default to intel assembler for delphi/tp7 on i386 }
+           if (m_delphi in aktmodeswitches) or
+              (m_tp7 in aktmodeswitches) then
+             aktasmmode:=asmmode_i386_intel;
+           if changeinit then
+             initasmmode:=aktasmmode;
+{$endif i386}
+         end;
+
+        SetCompileMode:=b;
+      end;
+
+
+    function SetAktProcCall(const s:string; changeInit:boolean):boolean;
+      const
+        DefProcCallName : array[tproccalloption] of string[12] = ('',
+         'CDECL',
+         'CPPDECL',
+         '', { compilerproc }
+         'FAR16',
+         'OLDFPCCALL',
+         'INLINE',
+         '', { internproc }
+         '', { syscall }
+         'PASCAL',
+         'REGISTER',
+         'SAFECALL',
+         'STDCALL',
+         'SOFTFLOAT',
+         'MWPASCAL'
+        );
+      var
+        t : tproccalloption;
+      begin
+        result:=false;
+        for t:=low(tproccalloption) to high(tproccalloption) do
+         if DefProcCallName[t]=s then
+          begin
+            AktDefProcCall:=t;
+            result:=true;
+            break;
+          end;
+        if changeinit then
+         InitDefProcCall:=AktDefProcCall;
+      end;
+
+
+    function SetProcessor(const s:string; changeInit: boolean):boolean;
+      var
+        t : tprocessors;
+      begin
+        SetProcessor:=false;
+        for t:=low(tprocessors) to high(tprocessors) do
+          if processorsstr[t]=s then
+            begin
+              aktspecificoptprocessor:=t;
+              SetProcessor:=true;
+              break;
+            end;
+        if changeinit then
+          initspecificoptprocessor:=aktspecificoptprocessor;
+      end;
+
+
+    function SetFpuType(const s:string; changeInit: boolean):boolean;
+      var
+        t : tfputype;
+      begin
+        SetFpuType:=false;
+        for t:=low(tfputype) to high(tfputype) do
+          if fputypestr[t]=s then
+            begin
+              aktfputype:=t;
+              SetFpuType:=true;
+              break;
+            end;
+        if changeinit then
+          initfputype:=aktfputype;
+      end;
+
+
+    { '('D1:'00000000-'D2:'0000-'D3:'0000-'D4:'0000-000000000000)' }
+    function string2guid(const s: string; var GUID: TGUID): boolean;
+        function ishexstr(const hs: string): boolean;
+          var
+            i: integer;
+          begin
+            ishexstr:=false;
+            for i:=1 to Length(hs) do begin
+              if not (hs[i] in ['0'..'9','A'..'F','a'..'f']) then
+                exit;
+            end;
+            ishexstr:=true;
+          end;
+        function hexstr2longint(const hexs: string): longint;
+          var
+            i: integer;
+            rl: longint;
+          begin
+            rl:=0;
+            for i:=1 to length(hexs) do begin
+              rl:=rl shl 4;
+              case hexs[i] of
+                '0'..'9' : inc(rl,ord(hexs[i])-ord('0'));
+                'A'..'F' : inc(rl,ord(hexs[i])-ord('A')+10);
+                'a'..'f' : inc(rl,ord(hexs[i])-ord('a')+10);
+              end
+            end;
+            hexstr2longint:=rl;
+          end;
+      var
+        i: integer;
+      begin
+        if (Length(s)=38) and (s[1]='{') and (s[38]='}') and
+           (s[10]='-') and (s[15]='-') and (s[20]='-') and (s[25]='-') and
+           ishexstr(copy(s,2,8)) and ishexstr(copy(s,11,4)) and
+           ishexstr(copy(s,16,4)) and ishexstr(copy(s,21,4)) and
+           ishexstr(copy(s,26,12)) then begin
+          GUID.D1:=dword(hexstr2longint(copy(s,2,8)));
+          { these values are arealdy in the correct range (4 chars = word) }
+          GUID.D2:=word(hexstr2longint(copy(s,11,4)));
+          GUID.D3:=word(hexstr2longint(copy(s,16,4)));
+          for i:=0 to 1 do
+            GUID.D4[i]:=byte(hexstr2longint(copy(s,21+i*2,2)));
+          for i:=2 to 7 do
+            GUID.D4[i]:=byte(hexstr2longint(copy(s,22+i*2,2)));
+          string2guid:=true;
+        end
+        else
+          string2guid:=false;
+      end;
+
+    function guid2string(const GUID: TGUID): string;
+        function long2hex(l, len: longint): string;
+          const
+            hextbl: array[0..15] of char = '0123456789ABCDEF';
+          var
+            rs: string;
+            i: integer;
+          begin
+            rs[0]:=chr(len);
+            for i:=len downto 1 do begin
+              rs[i]:=hextbl[l and $F];
+              l:=l shr 4;
+            end;
+            long2hex:=rs;
+          end;
+      begin
+        guid2string:=
+          '{'+long2hex(GUID.D1,8)+
+          '-'+long2hex(GUID.D2,4)+
+          '-'+long2hex(GUID.D3,4)+
+          '-'+long2hex(GUID.D4[0],2)+long2hex(GUID.D4[1],2)+
+          '-'+long2hex(GUID.D4[2],2)+long2hex(GUID.D4[3],2)+
+              long2hex(GUID.D4[4],2)+long2hex(GUID.D4[5],2)+
+              long2hex(GUID.D4[6],2)+long2hex(GUID.D4[7],2)+
+          '}';
+      end;
+
+
+    function UpdateAlignmentStr(s:string;var a:talignmentinfo):boolean;
+      var
+        tok  : string;
+        vstr : string;
+        l    : longint;
+        code : integer;
+        b    : talignmentinfo;
+      begin
+        UpdateAlignmentStr:=true;
+        uppervar(s);
+        fillchar(b,sizeof(b),0);
+        repeat
+          tok:=GetToken(s,'=');
+          if tok='' then
+           break;
+          vstr:=GetToken(s,',');
+          val(vstr,l,code);
+          if tok='PROC' then
+           b.procalign:=l
+          else if tok='JUMP' then
+           b.jumpalign:=l
+          else if tok='LOOP' then
+           b.loopalign:=l
+          else if tok='CONSTMIN' then
+           b.constalignmin:=l
+          else if tok='CONSTMAX' then
+           b.constalignmax:=l
+          else if tok='VARMIN' then
+           b.varalignmin:=l
+          else if tok='VARMAX' then
+           b.varalignmax:=l
+          else if tok='LOCALMIN' then
+           b.localalignmin:=l
+          else if tok='LOCALMAX' then
+           b.localalignmax:=l
+          else if tok='RECORDMIN' then
+           b.recordalignmin:=l
+          else if tok='RECORDMAX' then
+           b.recordalignmax:=l
+          else { Error }
+           UpdateAlignmentStr:=false;
+        until false;
+        UpdateAlignment(a,b);
+      end;
+
+
+    function var_align(siz: longint): longint;
+      begin
+        siz := size_2_align(siz);
+        var_align := used_align(siz,aktalignment.varalignmin,aktalignment.varalignmax);
+      end;
+
+
+    function const_align(siz: longint): longint;
+      begin
+        siz := size_2_align(siz);
+        const_align := used_align(siz,aktalignment.constalignmin,aktalignment.constalignmax);
+      end;
+
+
+{****************************************************************************
+                                    Init
+****************************************************************************}
+
+{$ifdef unix}
+  {$define need_path_search}
+{$endif unix}
+{$ifdef os2}
+  {$define need_path_search}
+{$endif os2}
+{$ifdef macos}
+  {$define need_path_search}
+{$endif macos}
+
+   procedure get_exepath;
+     var
+       hs1 : namestr;
+       hs2 : extstr;
+{$IFDEF USE_SYSUTILS}
+       exeName:String;
+{$ENDIF USE_SYSUTILS}
+{$ifdef need_path_search}
+       p   : pchar;
+{$endif need_path_search}
+     begin
+{$IFDEF USE_SYSUTILS}
+       exepath:=GetEnvironmentVariable('PPC_EXEC_PATH');
+{$ELSE USE_SYSUTILS}
+       exepath:=dos.getenv('PPC_EXEC_PATH');
+{$ENDIF USE_SYSUTILS}
+       if exepath='' then
+{$IFDEF USE_SYSUTILS}
+        exeName := FixFileName(system.paramstr(0));
+        exepath := ExtractFilePath(exeName);
+        hs1 := ExtractFileName(exeName);
+        hs2 := ExtractFileExt(exeName);
+{$ELSE USE_SYSUTILS}
+        fsplit(FixFileName(system.paramstr(0)),exepath,hs1,hs2);
+{$ENDIF USE_SYSUTILS}
+{$ifdef need_path_search}
+       if exepath='' then
+        begin
+          if pos(source_info.exeext,hs1) <>
+               (length(hs1) - length(source_info.exeext)+1) then
+            hs1 := hs1 + source_info.exeext;
+{$ifdef macos}
+          p:=GetEnvPchar('Commands');
+{$else macos}
+          p:=GetEnvPchar('PATH');
+{$endif macos}
+          FindFilePChar(hs1,p,exepath);
+          FreeEnvPChar(p);
+          exepath:=SplitPath(exepath);
+        end;
+{$endif need_path_search}
+       exepath:=FixPath(exepath,false);
+     end;
+
+
+
+   procedure DoneGlobals;
+     begin
+       if assigned(DLLImageBase) then
+         StringDispose(DLLImageBase);
+       librarysearchpath.Free;
+       unitsearchpath.Free;
+       objectsearchpath.Free;
+       includesearchpath.Free;
+     end;
+
+   procedure InitGlobals;
+     begin
+        get_exepath;
+
+      { reset globals }
+        do_build:=false;
+        do_release:=false;
+        do_make:=true;
+        compile_level:=0;
+        DLLsource:=false;
+        inlining_procedure:=false;
+        resolving_forward:=false;
+        make_ref:=false;
+        LinkTypeSetExplicitly:=false;
+
+      { Output }
+        OutputFile:='';
+        OutputPrefix:=Nil;
+        OutputSuffix:=Nil;
+        OutputExtension:='';
+
+        OutputExeDir:='';
+        OutputUnitDir:='';
+
+      { Utils directory }
+        utilsdirectory:='';
+        utilsprefix:='';
+        cshared:=false;
+        rlinkpath:='';
+
+      { Search Paths }
+        librarysearchpath:=TSearchPathList.Create;
+        unitsearchpath:=TSearchPathList.Create;
+        includesearchpath:=TSearchPathList.Create;
+        objectsearchpath:=TSearchPathList.Create;
+
+      { Def file }
+        usewindowapi:=false;
+        description:='Compiled by FPC '+version_string+' - '+target_cpu_string;
+        DescriptionSetExplicity:=false;
+        dllversion:='';
+        dllmajor:=1;
+        dllminor:=0;
+        dllrevision:=0;
+        nwscreenname := '';
+        nwthreadname := '';
+        nwcopyright  := '';
+        UseDeffileForExports:=false;
+        UseDeffileForExportsSetExplicitly:=false;
+        RelocSection:=false;
+        RelocSectionSetExplicitly:=false;
+        LinkTypeSetExplicitly:=false;
+
+      { Init values }
+        initmodeswitches:=fpcmodeswitches;
+        initlocalswitches:=[cs_check_io,cs_typed_const_writable];
+        initmoduleswitches:=[cs_extsyntax,cs_implicit_exceptions];
+        initsourcecodepage:='8859-1';
+        initglobalswitches:=[cs_check_unit_name,cs_link_static{$ifdef INTERNALLINKER},cs_link_internal,cs_link_map{$endif}];
+        initoutputformat:=target_asm.id;
+        fillchar(initalignment,sizeof(talignmentinfo),0);
+        { might be overridden later }
+        initasmmode:=asmmode_standard;
+{$ifdef i386}
+        initoptprocessor:=ClassPentium3;
+        initspecificoptprocessor:=Class386;
+
+        initfputype:=fpu_x87;
+
+        initpackenum:=4;
+        {$IFDEF testvarsets}
+        initsetalloc:=0;
+        {$ENDIF}
+        initasmmode:=asmmode_i386_att;
+{$endif i386}
+{$ifdef m68k}
+        initoptprocessor:=MC68020;
+        initpackenum:=4;
+        {$IFDEF testvarsets}
+         initsetalloc:=0;
+        {$ENDIF}
+{$endif m68k}
+{$ifdef powerpc}
+        initoptprocessor:=PPC604;
+        initpackenum:=4;
+        {$IFDEF testvarsets}
+         initsetalloc:=0;
+        {$ENDIF}
+        initfputype:=fpu_standard;
+{$endif powerpc}
+{$ifdef sparc}
+        initoptprocessor:=SPARC_V8;
+        initpackenum:=4;
+        {$IFDEF testvarsets}
+         initsetalloc:=0;
+        {$ENDIF}
+{$endif sparc}
+{$ifdef arm}
+        initpackenum:=4;
+        {$IFDEF testvarsets}
+        initsetalloc:=0;
+        {$ENDIF}
+        initfputype:=fpu_fpa;
+{$endif arm}
+{$ifdef x86_64}
+        initoptprocessor:=ClassAthlon64;
+        initspecificoptprocessor:=ClassAthlon64;
+
+        initfputype:=fpu_sse64;
+
+        initpackenum:=4;
+        {$IFDEF testvarsets}
+        initsetalloc:=0;
+        {$ENDIF}
+        initasmmode:=asmmode_x86_64_gas;
+{$endif x86_64}
+        initinterfacetype:=it_interfacecom;
+        initdefproccall:=pocall_default;
+
+      { memory sizes, will be overriden by parameter or default for target
+        in options or init_parser }
+        stacksize:=0;
+        { not initialized yet }
+        jmp_buf_size:=-1;
+
+        apptype:=app_cui;
+     end;
+
+end.