Added missing files

git-svn-id: branches/interfacertti@31476 -

.gitattributes

@@ -281,6 +281,10 @@ compiler/i8086/tgcpu.pas svneol=native#text/plain
 compiler/impdef.pas svneol=native#text/plain
 compiler/import.pas svneol=native#text/plain
 compiler/jvm/aasmcpu.pas svneol=native#text/plain
+compiler/jvm/agjasmin.pas svneol=native#text/plain
+compiler/jvm/aoptcpu.pas svneol=native#text/plain
+compiler/jvm/aoptcpub.pas svneol=native#text/plain
+compiler/jvm/aoptcpud.pas svneol=native#text/plain
 compiler/jvm/cgcpu.pas svneol=native#text/plain
 compiler/jvm/cpubase.pas svneol=native#text/plain
 compiler/jvm/cpuinfo.pas svneol=native#text/plain
@@ -331,6 +335,7 @@ compiler/llvm/llvmnode.pas svneol=native#text/plain
 compiler/llvm/llvmpara.pas svneol=native#text/plain
 compiler/llvm/llvmsym.pas svneol=native#text/plain
 compiler/llvm/llvmtarg.pas svneol=native#text/plain
+compiler/llvm/llvmtype.pas svneol=native#text/plain
 compiler/llvm/nllvmadd.pas svneol=native#text/plain
 compiler/llvm/nllvmcal.pas svneol=native#text/plain
 compiler/llvm/nllvmcnv.pas svneol=native#text/plain
@@ -342,6 +347,7 @@ compiler/llvm/nllvmmem.pas svneol=native#text/plain
 compiler/llvm/nllvmtcon.pas svneol=native#text/plain
 compiler/llvm/nllvmutil.pas svneol=native#text/plain
 compiler/llvm/rgllvm.pas svneol=native#text/plain
+compiler/llvm/symllvm.pas svneol=native#text/plain
 compiler/llvm/tgllvm.pas svneol=native#text/plain
 compiler/m68k/aasmcpu.pas svneol=native#text/plain
 compiler/m68k/ag68kgas.pas svneol=native#text/plain
@@ -505,6 +511,7 @@ compiler/optutils.pas svneol=native#text/plain
 compiler/optvirt.pas svneol=native#text/plain
 compiler/owar.pas svneol=native#text/plain
 compiler/owbase.pas svneol=native#text/plain
+compiler/owomflib.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
@@ -2053,12 +2060,16 @@ packages/fcl-base/texts/fptemplate.txt svneol=native#text/plain
 packages/fcl-db/Makefile svneol=native#text/plain
 packages/fcl-db/Makefile.fpc svneol=native#text/plain
 packages/fcl-db/Makefile.fpc.fpcmake svneol=native#text/plain
+packages/fcl-db/examples/createsql.lpi svneol=native#text/plain
+packages/fcl-db/examples/createsql.pas svneol=native#text/plain
 packages/fcl-db/examples/dbftool.lpi svneol=native#text/plain
 packages/fcl-db/examples/dbftool.lpr svneol=native#text/plain
 packages/fcl-db/examples/fbadmindemo.pp svneol=native#text/plain
 packages/fcl-db/examples/fbeventstest.pp svneol=native#text/plain
 packages/fcl-db/examples/loadlibdemo.lpi svneol=native#text/plain
 packages/fcl-db/examples/loadlibdemo.pp svneol=native#text/plain
+packages/fcl-db/examples/logsqldemo.lpi svneol=native#text/plain
+packages/fcl-db/examples/logsqldemo.pas svneol=native#text/plain
 packages/fcl-db/examples/pqeventstest.pp svneol=native#text/plain
 packages/fcl-db/examples/sqlite3loadlib.lpr svneol=native#text/plain
 packages/fcl-db/examples/sqlparser.pp svneol=native#text/plain
@@ -2283,6 +2294,7 @@ packages/fcl-db/tests/memdstoolsunit.pas svneol=native#text/plain
 packages/fcl-db/tests/reruntest.sh svneol=native#text/plain
 packages/fcl-db/tests/sdfdstoolsunit.pas svneol=native#text/plain
 packages/fcl-db/tests/sqldbtoolsunit.pas svneol=native#text/plain
+packages/fcl-db/tests/sqlite3dstoolsunit.pas svneol=LF#text/plain eol=lf
 packages/fcl-db/tests/tccsvdataset.pp svneol=native#text/plain
 packages/fcl-db/tests/tcgensql.pas svneol=native#text/plain
 packages/fcl-db/tests/tcparser.pas svneol=native#text/plain
@@ -3120,6 +3132,7 @@ packages/fcl-web/src/base/Makefile svneol=native#text/plain
 packages/fcl-web/src/base/Makefile.fpc svneol=native#text/plain
 packages/fcl-web/src/base/README.txt svneol=native#text/plain
 packages/fcl-web/src/base/cgiapp.pp svneol=native#text/plain
+packages/fcl-web/src/base/cgiprotocol.pp svneol=native#text/plain
 packages/fcl-web/src/base/custcgi.pp svneol=native#text/plain
 packages/fcl-web/src/base/custfcgi.pp svneol=native#text/plain
 packages/fcl-web/src/base/custhttpapp.pp svneol=native#text/plain
@@ -3137,10 +3150,18 @@ packages/fcl-web/src/base/fphttpapp.pp svneol=native#text/plain
 packages/fcl-web/src/base/fphttpclient.pp svneol=native#text/plain
 packages/fcl-web/src/base/fphttpserver.pp svneol=native#text/plain
 packages/fcl-web/src/base/fphttpstatus.pas svneol=native#text/plain
+packages/fcl-web/src/base/fphttpwebclient.pp svneol=native#text/plain
+packages/fcl-web/src/base/fpjwt.pp svneol=native#text/plain
+packages/fcl-web/src/base/fpoauth2.pp svneol=native#text/plain
+packages/fcl-web/src/base/fpoauth2ini.pp svneol=native#text/plain
 packages/fcl-web/src/base/fpweb.pp svneol=native#text/plain
+packages/fcl-web/src/base/fpwebclient.pp svneol=native#text/plain
 packages/fcl-web/src/base/fpwebfile.pp svneol=native#text/plain
 packages/fcl-web/src/base/httpdefs.pp svneol=native#text/plain
+packages/fcl-web/src/base/httpprotocol.pp svneol=native#text/plain
 packages/fcl-web/src/base/iniwebsession.pp svneol=native#text/plain
+packages/fcl-web/src/base/restbase.pp svneol=native#text/plain
+packages/fcl-web/src/base/restcodegen.pp svneol=native#text/plain
 packages/fcl-web/src/base/webpage.pp svneol=native#text/plain
 packages/fcl-web/src/base/websession.pp svneol=native#text/plain
 packages/fcl-web/src/base/webutil.pp svneol=native#text/plain
@@ -5802,6 +5823,7 @@ packages/mysql/src/mysql51emb.pp svneol=native#text/plain
 packages/mysql/src/mysql55.pp svneol=native#text/plain
 packages/mysql/src/mysql55dyn.pp svneol=native#text/plain
 packages/mysql/src/mysql56dyn.pp svneol=native#text/plain
+packages/mysql/src/mysql57dyn.pp svneol=native#text/plain
 packages/ncurses/Makefile svneol=native#text/plain
 packages/ncurses/Makefile.fpc svneol=native#text/plain
 packages/ncurses/Makefile.fpc.fpcmake svneol=native#text/plain
@@ -7628,6 +7650,7 @@ packages/winunits-base/src/richedit.pp svneol=native#text/plain
 packages/winunits-base/src/shellapi.pp svneol=native#text/plain
 packages/winunits-base/src/shfolder.pp svneol=native#text/plain
 packages/winunits-base/src/shlobj.pp svneol=native#text/plain
+packages/winunits-base/src/shlwapi.pp svneol=native#text/plain
 packages/winunits-base/src/stdole2.pas svneol=native#text/plain
 packages/winunits-base/src/tmschema.inc svneol=native#text/plain
 packages/winunits-base/src/typelib.pas svneol=native#text/plain
@@ -8028,6 +8051,7 @@ rtl/aix/termiosproc.inc svneol=native#text/plain
 rtl/aix/unxconst.inc svneol=native#text/plain
 rtl/aix/unxfunc.inc svneol=native#text/plain
 rtl/amicommon/README.TXT svneol=native#text/plain
+rtl/amicommon/athreads.pp svneol=native#text/plain
 rtl/amicommon/classes.pp svneol=native#text/plain
 rtl/amicommon/dos.pp svneol=native#text/plain
 rtl/amicommon/osdebug.inc svneol=native#text/plain
@@ -8039,12 +8063,14 @@ rtl/amicommon/sysheap.inc svneol=native#text/plain
 rtl/amicommon/sysos.inc svneol=native#text/plain
 rtl/amicommon/sysosh.inc svneol=native#text/plain
 rtl/amicommon/sysutils.pp svneol=native#text/plain
+rtl/amicommon/tthread.inc svneol=native#text/plain
 rtl/amiga/Makefile svneol=native#text/plain
 rtl/amiga/Makefile.fpc svneol=native#text/plain
 rtl/amiga/doslibd.inc svneol=native#text/plain
 rtl/amiga/m68k/doslibf.inc svneol=native#text/plain
 rtl/amiga/m68k/execd.inc svneol=native#text/plain
 rtl/amiga/m68k/execf.inc svneol=native#text/plain
+rtl/amiga/m68k/m68kamiga.inc svneol=native#text/plain
 rtl/amiga/m68k/prt0.as svneol=native#text/plain
 rtl/amiga/m68k/utild1.inc svneol=native#text/plain
 rtl/amiga/m68k/utild2.inc svneol=native#text/plain
@@ -8270,6 +8296,7 @@ rtl/embedded/arm/cortexm3.pp svneol=native#text/pascal
 rtl/embedded/arm/cortexm3_start.inc svneol=native#text/pascal
 rtl/embedded/arm/cortexm4.pp svneol=native#text/pascal
 rtl/embedded/arm/cortexm4f_start.inc svneol=native#text/pascal
+rtl/embedded/arm/cortexm7.pp svneol=native#text/plain
 rtl/embedded/arm/lm3fury.pp svneol=native#text/pascal
 rtl/embedded/arm/lm3tempest.pp svneol=native#text/pascal
 rtl/embedded/arm/lm4f120.pp svneol=native#text/pascal
@@ -8279,6 +8306,7 @@ rtl/embedded/arm/lpc13xx.pp svneol=native#text/pascal
 rtl/embedded/arm/lpc1768.pp svneol=native#text/pascal
 rtl/embedded/arm/lpc21x4.pp svneol=native#text/plain
 rtl/embedded/arm/lpc8xx.pp svneol=native#text/pascal
+rtl/embedded/arm/mk20d7.pp svneol=native#text/plain
 rtl/embedded/arm/sc32442b.pp svneol=native#text/pascal
 rtl/embedded/arm/stm32f0xx.pp svneol=native#text/plain
 rtl/embedded/arm/stm32f10x_cl.pp svneol=native#text/plain
@@ -8287,8 +8315,156 @@ rtl/embedded/arm/stm32f10x_hd.pp svneol=native#text/pascal
 rtl/embedded/arm/stm32f10x_ld.pp svneol=native#text/pascal
 rtl/embedded/arm/stm32f10x_md.pp svneol=native#text/pascal
 rtl/embedded/arm/stm32f10x_xl.pp svneol=native#text/pascal
+rtl/embedded/arm/stm32f429.pp svneol=native#text/pascal
+rtl/embedded/arm/stm32f745.pp svneol=native#text/plain
+rtl/embedded/arm/stm32f746.pp svneol=native#text/plain
+rtl/embedded/arm/stm32f756.pp svneol=native#text/plain
 rtl/embedded/arm/xmc4500.pp svneol=native#text/pascal
+rtl/embedded/avr/at90can128.pp svneol=native#text/plain
+rtl/embedded/avr/at90can32.pp svneol=native#text/plain
+rtl/embedded/avr/at90can64.pp svneol=native#text/plain
+rtl/embedded/avr/at90pwm1.pp svneol=native#text/plain
+rtl/embedded/avr/at90pwm161.pp svneol=native#text/plain
+rtl/embedded/avr/at90pwm216.pp svneol=native#text/plain
+rtl/embedded/avr/at90pwm2b.pp svneol=native#text/plain
+rtl/embedded/avr/at90pwm316.pp svneol=native#text/plain
+rtl/embedded/avr/at90pwm3b.pp svneol=native#text/plain
+rtl/embedded/avr/at90pwm81.pp svneol=native#text/plain
+rtl/embedded/avr/at90usb1286.pp svneol=native#text/plain
+rtl/embedded/avr/at90usb1287.pp svneol=native#text/plain
+rtl/embedded/avr/at90usb162.pp svneol=native#text/plain
+rtl/embedded/avr/at90usb646.pp svneol=native#text/plain
+rtl/embedded/avr/at90usb647.pp svneol=native#text/plain
+rtl/embedded/avr/at90usb82.pp svneol=native#text/plain
+rtl/embedded/avr/ata6285.pp svneol=native#text/plain
+rtl/embedded/avr/ata6286.pp svneol=native#text/plain
 rtl/embedded/avr/atmega128.pp svneol=native#text/plain
+rtl/embedded/avr/atmega1280.pp svneol=native#text/plain
+rtl/embedded/avr/atmega1281.pp svneol=native#text/plain
+rtl/embedded/avr/atmega1284.pp svneol=native#text/plain
+rtl/embedded/avr/atmega1284p.pp svneol=native#text/plain
+rtl/embedded/avr/atmega128a.pp svneol=native#text/plain
+rtl/embedded/avr/atmega128rfa1.pp svneol=native#text/plain
+rtl/embedded/avr/atmega16.pp svneol=native#text/plain
+rtl/embedded/avr/atmega162.pp svneol=native#text/plain
+rtl/embedded/avr/atmega164a.pp svneol=native#text/plain
+rtl/embedded/avr/atmega164p.pp svneol=native#text/plain
+rtl/embedded/avr/atmega164pa.pp svneol=native#text/plain
+rtl/embedded/avr/atmega165a.pp svneol=native#text/plain
+rtl/embedded/avr/atmega165p.pp svneol=native#text/plain
+rtl/embedded/avr/atmega165pa.pp svneol=native#text/plain
+rtl/embedded/avr/atmega168.pp svneol=native#text/plain
+rtl/embedded/avr/atmega168a.pp svneol=native#text/plain
+rtl/embedded/avr/atmega168p.pp svneol=native#text/plain
+rtl/embedded/avr/atmega168pa.pp svneol=native#text/plain
+rtl/embedded/avr/atmega169a.pp svneol=native#text/plain
+rtl/embedded/avr/atmega169p.pp svneol=native#text/plain
+rtl/embedded/avr/atmega169pa.pp svneol=native#text/plain
+rtl/embedded/avr/atmega16a.pp svneol=native#text/plain
+rtl/embedded/avr/atmega16hvb.pp svneol=native#text/plain
+rtl/embedded/avr/atmega16m1.pp svneol=native#text/plain
+rtl/embedded/avr/atmega16u2.pp svneol=native#text/plain
+rtl/embedded/avr/atmega16u4.pp svneol=native#text/plain
+rtl/embedded/avr/atmega2560.pp svneol=native#text/plain
+rtl/embedded/avr/atmega2561.pp svneol=native#text/plain
+rtl/embedded/avr/atmega32.pp svneol=native#text/plain
+rtl/embedded/avr/atmega324a.pp svneol=native#text/plain
+rtl/embedded/avr/atmega324p.pp svneol=native#text/plain
+rtl/embedded/avr/atmega324pa.pp svneol=native#text/plain
+rtl/embedded/avr/atmega325.pp svneol=native#text/plain
+rtl/embedded/avr/atmega3250.pp svneol=native#text/plain
+rtl/embedded/avr/atmega3250a.pp svneol=native#text/plain
+rtl/embedded/avr/atmega3250p.pp svneol=native#text/plain
+rtl/embedded/avr/atmega3250pa.pp svneol=native#text/plain
+rtl/embedded/avr/atmega325a.pp svneol=native#text/plain
+rtl/embedded/avr/atmega325p.pp svneol=native#text/plain
+rtl/embedded/avr/atmega325pa.pp svneol=native#text/plain
+rtl/embedded/avr/atmega328.pp svneol=native#text/plain
+rtl/embedded/avr/atmega328p.pp svneol=native#text/plain
+rtl/embedded/avr/atmega329.pp svneol=native#text/plain
+rtl/embedded/avr/atmega3290.pp svneol=native#text/plain
+rtl/embedded/avr/atmega3290a.pp svneol=native#text/plain
+rtl/embedded/avr/atmega3290p.pp svneol=native#text/plain
+rtl/embedded/avr/atmega3290pa.pp svneol=native#text/plain
+rtl/embedded/avr/atmega329a.pp svneol=native#text/plain
+rtl/embedded/avr/atmega329p.pp svneol=native#text/plain
+rtl/embedded/avr/atmega329pa.pp svneol=native#text/plain
+rtl/embedded/avr/atmega32a.pp svneol=native#text/plain
+rtl/embedded/avr/atmega32c1.pp svneol=native#text/plain
+rtl/embedded/avr/atmega32hvb.pp svneol=native#text/plain
+rtl/embedded/avr/atmega32m1.pp svneol=native#text/plain
+rtl/embedded/avr/atmega32u2.pp svneol=native#text/plain
+rtl/embedded/avr/atmega32u4.pp svneol=native#text/plain
+rtl/embedded/avr/atmega48.pp svneol=native#text/plain
+rtl/embedded/avr/atmega48a.pp svneol=native#text/plain
+rtl/embedded/avr/atmega48p.pp svneol=native#text/plain
+rtl/embedded/avr/atmega48pa.pp svneol=native#text/plain
+rtl/embedded/avr/atmega64.pp svneol=native#text/plain
+rtl/embedded/avr/atmega640.pp svneol=native#text/plain
+rtl/embedded/avr/atmega644.pp svneol=native#text/plain
+rtl/embedded/avr/atmega644a.pp svneol=native#text/plain
+rtl/embedded/avr/atmega644p.pp svneol=native#text/plain
+rtl/embedded/avr/atmega644pa.pp svneol=native#text/plain
+rtl/embedded/avr/atmega645.pp svneol=native#text/plain
+rtl/embedded/avr/atmega6450.pp svneol=native#text/plain
+rtl/embedded/avr/atmega6450a.pp svneol=native#text/plain
+rtl/embedded/avr/atmega6450p.pp svneol=native#text/plain
+rtl/embedded/avr/atmega645a.pp svneol=native#text/plain
+rtl/embedded/avr/atmega645p.pp svneol=native#text/plain
+rtl/embedded/avr/atmega649.pp svneol=native#text/plain
+rtl/embedded/avr/atmega6490.pp svneol=native#text/plain
+rtl/embedded/avr/atmega6490a.pp svneol=native#text/plain
+rtl/embedded/avr/atmega6490p.pp svneol=native#text/plain
+rtl/embedded/avr/atmega649a.pp svneol=native#text/plain
+rtl/embedded/avr/atmega649p.pp svneol=native#text/plain
+rtl/embedded/avr/atmega64a.pp svneol=native#text/plain
+rtl/embedded/avr/atmega64c1.pp svneol=native#text/plain
+rtl/embedded/avr/atmega64m1.pp svneol=native#text/plain
+rtl/embedded/avr/atmega8.pp svneol=native#text/plain
+rtl/embedded/avr/atmega8515.pp svneol=native#text/plain
+rtl/embedded/avr/atmega8535.pp svneol=native#text/plain
+rtl/embedded/avr/atmega88.pp svneol=native#text/plain
+rtl/embedded/avr/atmega88a.pp svneol=native#text/plain
+rtl/embedded/avr/atmega88p.pp svneol=native#text/plain
+rtl/embedded/avr/atmega88pa.pp svneol=native#text/plain
+rtl/embedded/avr/atmega8a.pp svneol=native#text/plain
+rtl/embedded/avr/atmega8u2.pp svneol=native#text/plain
+rtl/embedded/avr/attiny10.pp svneol=native#text/plain
+rtl/embedded/avr/attiny13.pp svneol=native#text/plain
+rtl/embedded/avr/attiny13a.pp svneol=native#text/plain
+rtl/embedded/avr/attiny1634.pp svneol=native#text/plain
+rtl/embedded/avr/attiny167.pp svneol=native#text/plain
+rtl/embedded/avr/attiny20.pp svneol=native#text/plain
+rtl/embedded/avr/attiny2313.pp svneol=native#text/plain
+rtl/embedded/avr/attiny2313a.pp svneol=native#text/plain
+rtl/embedded/avr/attiny24.pp svneol=native#text/plain
+rtl/embedded/avr/attiny24a.pp svneol=native#text/plain
+rtl/embedded/avr/attiny25.pp svneol=native#text/plain
+rtl/embedded/avr/attiny26.pp svneol=native#text/plain
+rtl/embedded/avr/attiny261.pp svneol=native#text/plain
+rtl/embedded/avr/attiny261a.pp svneol=native#text/plain
+rtl/embedded/avr/attiny28.pp svneol=native#text/plain
+rtl/embedded/avr/attiny4.pp svneol=native#text/plain
+rtl/embedded/avr/attiny40.pp svneol=native#text/plain
+rtl/embedded/avr/attiny4313.pp svneol=native#text/plain
+rtl/embedded/avr/attiny43u.pp svneol=native#text/plain
+rtl/embedded/avr/attiny44.pp svneol=native#text/plain
+rtl/embedded/avr/attiny44a.pp svneol=native#text/plain
+rtl/embedded/avr/attiny45.pp svneol=native#text/plain
+rtl/embedded/avr/attiny461.pp svneol=native#text/plain
+rtl/embedded/avr/attiny461a.pp svneol=native#text/plain
+rtl/embedded/avr/attiny48.pp svneol=native#text/plain
+rtl/embedded/avr/attiny5.pp svneol=native#text/plain
+rtl/embedded/avr/attiny828.pp svneol=native#text/plain
+rtl/embedded/avr/attiny84.pp svneol=native#text/plain
+rtl/embedded/avr/attiny84a.pp svneol=native#text/plain
+rtl/embedded/avr/attiny85.pp svneol=native#text/plain
+rtl/embedded/avr/attiny861.pp svneol=native#text/plain
+rtl/embedded/avr/attiny861a.pp svneol=native#text/plain
+rtl/embedded/avr/attiny87.pp svneol=native#text/plain
+rtl/embedded/avr/attiny88.pp svneol=native#text/plain
+rtl/embedded/avr/attiny9.pp svneol=native#text/plain
+rtl/embedded/avr/avrcommon.inc svneol=native#text/plain
 rtl/embedded/avr/avrsim.pp svneol=native#text/plain
 rtl/embedded/avr/start.inc svneol=native#text/plain
 rtl/embedded/buildrtl.lpi svneol=native#text/plain
@@ -8720,6 +8896,7 @@ rtl/linux/osdefs.inc svneol=native#text/plain
 rtl/linux/osmacro.inc svneol=native#text/plain
 rtl/linux/ossysc.inc svneol=native#text/plain
 rtl/linux/ostypes.inc svneol=native#text/plain
+rtl/linux/pmutext.inc svneol=native#text/plain
 rtl/linux/powerpc/bsyscall.inc svneol=native#text/plain
 rtl/linux/powerpc/cprt0.as svneol=native#text/plain
 rtl/linux/powerpc/dllprt0.as svneol=native#text/plain
@@ -8770,6 +8947,7 @@ rtl/linux/sparc/syscall.inc svneol=native#text/plain
 rtl/linux/sparc/syscallh.inc svneol=native#text/plain
 rtl/linux/sparc/sysnr.inc svneol=native#text/plain
 rtl/linux/suuid.inc svneol=native#text/plain
+rtl/linux/sysnr-gen.inc svneol=native#text/plain
 rtl/linux/sysos.inc svneol=native#text/plain
 rtl/linux/sysosh.inc svneol=native#text/plain
 rtl/linux/system.pp svneol=native#text/plain
@@ -10543,6 +10721,9 @@ tests/tbs/tb0606.pp svneol=native#text/pascal
 tests/tbs/tb0607.pp svneol=native#text/plain
 tests/tbs/tb0608.pp svneol=native#text/pascal
 tests/tbs/tb0609.pp svneol=native#text/plain
+tests/tbs/tb0610.pp svneol=native#text/pascal
+tests/tbs/tb0611.pp svneol=native#text/pascal
+tests/tbs/tb0612.pp svneol=native#text/pascal
 tests/tbs/tb205.pp svneol=native#text/plain
 tests/tbs/tb610.pp svneol=native#text/pascal
 tests/tbs/tbs0594.pp svneol=native#text/pascal
@@ -11250,6 +11431,7 @@ tests/test/jvm/testall.sh -text svneol=native#application/x-sh
 tests/test/jvm/testansi.pp svneol=native#text/plain
 tests/test/jvm/testintf.pp svneol=native#text/plain
 tests/test/jvm/testshort.pp svneol=native#text/plain
+tests/test/jvm/tformalclass.pp svneol=native#text/plain
 tests/test/jvm/tformalpara.pp svneol=native#text/plain
 tests/test/jvm/tinitvar.pp svneol=native#text/plain
 tests/test/jvm/tint.pp svneol=native#text/plain
@@ -11257,6 +11439,7 @@ tests/test/jvm/tintstr.pp svneol=native#text/plain
 tests/test/jvm/tjavalowercaseproc.java svneol=native#text/plain
 tests/test/jvm/tjsetter.java svneol=native#text/plain
 tests/test/jvm/tlowercaseproc.pp svneol=native#text/plain
+tests/test/jvm/tnestcallpass1.pp svneol=native#text/plain
 tests/test/jvm/tnestdynarr.pp svneol=native#text/plain
 tests/test/jvm/tnestedset.pp svneol=native#text/plain
 tests/test/jvm/tnestproc.pp svneol=native#text/plain
@@ -13111,6 +13294,7 @@ tests/webtbf/tw2281.pp svneol=native#text/plain
 tests/webtbf/tw2285.pp svneol=native#text/plain
 tests/webtbf/tw22941.pp svneol=native#text/plain
 tests/webtbf/tw23110.pp svneol=native#text/plain
+tests/webtbf/tw23169.pp svneol=native#text/pascal
 tests/webtbf/tw23546b.pp svneol=native#text/pascal
 tests/webtbf/tw23547a.pp svneol=native#text/pascal
 tests/webtbf/tw23547b.pp svneol=native#text/pascal
@@ -13164,6 +13348,7 @@ tests/webtbf/tw2751.pp svneol=native#text/plain
 tests/webtbf/tw2752.pp svneol=native#text/plain
 tests/webtbf/tw2787.pp svneol=native#text/plain
 tests/webtbf/tw2795.pp svneol=native#text/plain
+tests/webtbf/tw28338.pp svneol=native#text/plain
 tests/webtbf/tw2853.pp svneol=native#text/plain
 tests/webtbf/tw2853a.pp svneol=native#text/plain
 tests/webtbf/tw2853b.pp svneol=native#text/plain
@@ -13841,6 +14026,7 @@ tests/webtbs/tw16366.pp svneol=native#text/plain
 tests/webtbs/tw16377.pp svneol=native#text/plain
 tests/webtbs/tw16402.pp svneol=native#text/plain
 tests/webtbs/tw1658.pp svneol=native#text/plain
+tests/webtbs/tw16582.pp svneol=native#text/plain
 tests/webtbs/tw16592.pp svneol=native#text/plain
 tests/webtbs/tw16622.pp svneol=native#text/pascal
 tests/webtbs/tw16668.pp svneol=native#text/plain
@@ -13945,6 +14131,7 @@ tests/webtbs/tw18103a.pp svneol=native#text/pascal
 tests/webtbs/tw18103b.pp svneol=native#text/pascal
 tests/webtbs/tw18103c.pp svneol=native#text/pascal
 tests/webtbs/tw18113.pp svneol=native#text/plain
+tests/webtbs/tw18121.pp svneol=native#text/plain
 tests/webtbs/tw18123.pp svneol=native#text/pascal
 tests/webtbs/tw18127.pp svneol=native#text/pascal
 tests/webtbs/tw18131.pp svneol=native#text/pascal
@@ -14444,6 +14631,7 @@ tests/webtbs/tw27153.pp svneol=native#text/pascal
 tests/webtbs/tw27173.pp svneol=native#text/pascal
 tests/webtbs/tw27185.pp svneol=native#text/pascal
 tests/webtbs/tw2721.pp svneol=native#text/plain
+tests/webtbs/tw27210.pp svneol=native#text/plain
 tests/webtbs/tw2723.pp svneol=native#text/plain
 tests/webtbs/tw2725.pp svneol=native#text/plain
 tests/webtbs/tw27256.pp svneol=native#text/pascal
@@ -14474,29 +14662,44 @@ tests/webtbs/tw2767.pp svneol=native#text/plain
 tests/webtbs/tw27691.pp svneol=native#text/plain
 tests/webtbs/tw2771.pp svneol=native#text/plain
 tests/webtbs/tw2772.pp svneol=native#text/plain
+tests/webtbs/tw27750a.pp svneol=native#text/pascal
+tests/webtbs/tw27750b.pp svneol=native#text/pascal
 tests/webtbs/tw2776.pp svneol=native#text/plain
 tests/webtbs/tw2778.pp svneol=native#text/plain
 tests/webtbs/tw2779.pp svneol=native#text/plain
 tests/webtbs/tw2780.pp svneol=native#text/plain
 tests/webtbs/tw27811.pp svneol=native#text/plain
+tests/webtbs/tw27832.pp svneol=native#text/plain
 tests/webtbs/tw2788.pp svneol=native#text/plain
+tests/webtbs/tw27880.pp svneol=native#text/plain
 tests/webtbs/tw2789.pp svneol=native#text/plain
 tests/webtbs/tw2794.pp svneol=native#text/plain
+tests/webtbs/tw27998.pp svneol=native#text/plain
+tests/webtbs/tw27998a.pp svneol=native#text/plain
+tests/webtbs/tw28007.pp svneol=native#text/pascal
 tests/webtbs/tw2803.pp svneol=native#text/plain
+tests/webtbs/tw28058.pp svneol=native#text/pascal
 tests/webtbs/tw2806.pp svneol=native#text/plain
 tests/webtbs/tw2807.pp svneol=native#text/plain
+tests/webtbs/tw28089.pp svneol=native#text/plain
 tests/webtbs/tw2809.pp svneol=native#text/plain
 tests/webtbs/tw2812.pp svneol=native#text/plain
 tests/webtbs/tw2815.pp svneol=native#text/plain
 tests/webtbs/tw2817.pp svneol=native#text/plain
+tests/webtbs/tw28271.pp svneol=native#text/pascal
+tests/webtbs/tw28279.pp svneol=native#text/plain
 tests/webtbs/tw2829.pp svneol=native#text/plain
 tests/webtbs/tw2830.pp svneol=native#text/plain
+tests/webtbs/tw28313.pp -text svneol=native#text/plain
 tests/webtbs/tw2832.pp svneol=native#text/plain
 tests/webtbs/tw2834.pp svneol=native#text/plain
+tests/webtbs/tw28372.pp svneol=native#text/plain
 tests/webtbs/tw2841.pp svneol=native#text/plain
 tests/webtbs/tw28442.pp svneol=native#text/pascal
 tests/webtbs/tw28454.pp svneol=native#text/plain
+tests/webtbs/tw28475.pp svneol=native#text/plain
 tests/webtbs/tw2853.pp svneol=native#text/plain
+tests/webtbs/tw28530.pp svneol=native#text/pascal
 tests/webtbs/tw2853a.pp svneol=native#text/plain
 tests/webtbs/tw2853b.pp svneol=native#text/plain
 tests/webtbs/tw2853c.pp svneol=native#text/plain
@@ -15164,6 +15367,7 @@ tests/webtbs/uw17493.pp svneol=native#text/plain
 tests/webtbs/uw17950.pas svneol=native#text/pascal
 tests/webtbs/uw18087a.pp svneol=native#text/pascal
 tests/webtbs/uw18087b.pp svneol=native#text/pascal
+tests/webtbs/uw18121.pp svneol=native#text/plain
 tests/webtbs/uw18909a.pp svneol=native#text/pascal
 tests/webtbs/uw18909b.pp svneol=native#text/pascal
 tests/webtbs/uw19159.pp svneol=native#text/pascal
@@ -15413,6 +15617,7 @@ utils/fpdoc/fpdocstripper.lpi svneol=native#text/plain
 utils/fpdoc/fpdocstripper.pp svneol=native#text/plain
 utils/fpdoc/fpdocxmlopts.pas svneol=native#text/plain
 utils/fpdoc/fpmake.pp svneol=native#text/plain
+utils/fpdoc/gentest.sh svneol=native#text/plain
 utils/fpdoc/images/minus.png -text svneol=unset#image/png
 utils/fpdoc/images/plus.png -text svneol=unset#image/png
 utils/fpdoc/intl/Makefile svneol=native#text/plain

compiler/Makefile

@@ -1,5 +1,5 @@
 #
-# Don't edit, this file is generated by FPCMake Version 2.0.0 [2015/06/28]
+# Don't edit, this file is generated by FPCMake Version 2.0.0 [2015-07-28 rev 31240]
 #
 default: all
 MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-haiku i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian i386-nativent i386-iphonesim i386-android i386-aros m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos powerpc-embedded powerpc-wii powerpc-aix sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-netbsd x86_64-solaris x86_64-openbsd x86_64-darwin x86_64-win64 x86_64-embedded x86_64-iphonesim x86_64-aros x86_64-dragonfly arm-linux arm-palmos arm-darwin arm-wince arm-gba arm-nds arm-embedded arm-symbian arm-android powerpc64-linux powerpc64-darwin powerpc64-embedded powerpc64-aix avr-embedded armeb-linux armeb-embedded mips-linux mipsel-linux mipsel-embedded mipsel-android jvm-java jvm-android i8086-msdos aarch64-linux aarch64-darwin
@@ -526,7 +526,7 @@ ifeq ($(PPC_TARGET),mipsel)
 override LOCALOPT+=-Fumips
 endif
 ifeq ($(PPC_TARGET),jvm)
-override LOCALOPT+=-Fujvm -dNOOPT
+override LOCALOPT+=-Fujvm
 endif
 ifeq ($(PPC_TARGET),i8086)
 override LOCALOPT+=-Fux86
@@ -2962,6 +2962,7 @@ endif
 ifeq ($(OS_SOURCE),openbsd)
 override FPCOPT+=-FD$(NEW_BINUTILS_PATH)
 override FPCMAKEOPT+=-FD$(NEW_BINUTILS_PATH)
+override FPMAKE_BUILD_OPT+=-FD$(NEW_BINUTILS_PATH)
 endif
 ifndef CROSSBOOTSTRAP
 ifneq ($(BINUTILSPREFIX),)
@@ -2974,6 +2975,7 @@ endif
 ifndef CROSSCOMPILE
 ifneq ($(BINUTILSPREFIX),)
 override FPCMAKEOPT+=-XP$(BINUTILSPREFIX)
+override FPMAKE_BUILD_OPT+=-XP$(BINUTILSPREFIX)
 endif
 endif
 ifdef UNITDIR
@@ -3073,6 +3075,9 @@ endif
 ifdef OPT
 override FPCOPT+=$(OPT)
 endif
+ifdef FPMAKEBUILDOPT
+override FPMAKE_BUILD_OPT+=$(FPMAKEBUILDOPT)
+endif
 ifdef FPCOPTDEF
 override FPCOPT+=$(addprefix -d,$(FPCOPTDEF))
 endif
@@ -3264,7 +3269,7 @@ endif
 fpc_sourceinstall: distclean
 	$(MKDIR) $(INSTALL_SOURCEDIR)
 	$(COPYTREE) $(BASEDIR)/* $(INSTALL_SOURCEDIR)
-fpc_exampleinstall: $(addsuffix _distclean,$(TARGET_EXAMPLEDIRS))
+fpc_exampleinstall: $(EXAMPLEINSTALLTARGET) $(addsuffix _distclean,$(TARGET_EXAMPLEDIRS))
 ifdef HASEXAMPLES
 	$(MKDIR) $(INSTALL_EXAMPLEDIR)
 endif
@@ -3436,6 +3441,10 @@ endif
 ifdef DEBUGSYMEXT
 	-$(DEL) *$(DEBUGSYMEXT)
 endif
+ifdef LOCALFPMAKEBIN
+	-$(DEL) $(LOCALFPMAKEBIN)
+	-$(DEL) $(FPMAKEBINOBJ)
+endif
 fpc_distclean: cleanall
 .PHONY: fpc_baseinfo
 override INFORULES+=fpc_baseinfo

compiler/Makefile.fpc

@@ -37,7 +37,7 @@ CYCLETARGETS=i386 powerpc sparc arm x86_64 powerpc64 m68k armeb mipsel mips avr
 # All supported targets used for clean
 ALLTARGETS=$(CYCLETARGETS)
 
-# Allow ALPHA, POWERPC, POWERPC64, M68K, I386, jvm defines for target cpu
+# Allow POWERPC, POWERPC64, M68K, I386, jvm defines for target cpu
 ifdef POWERPC
 PPC_TARGET=powerpc
 endif
@@ -290,7 +290,7 @@ endif
 
 # jvm specific
 ifeq ($(PPC_TARGET),jvm)
-override LOCALOPT+=-Fujvm -dNOOPT
+override LOCALOPT+=-Fujvm
 endif
 
 # i8086 specific

compiler/aarch64/ncpucnv.pas

@@ -142,7 +142,7 @@ implementation
   procedure taarch64typeconvnode.second_int_to_bool;
     var
       resflags: tresflags;
-      hlabel,oldTrueLabel,oldFalseLabel : tasmlabel;
+      hlabel: tasmlabel;
     begin
       if (nf_explicit in flags) and
          not(left.expectloc in [LOC_FLAGS,LOC_JUMP]) then
@@ -154,10 +154,6 @@ implementation
       { can't use the generic code, as it assumes that OP_OR automatically sets
         the flags. We can also do things more efficiently directly }
 
-      oldTrueLabel:=current_procinfo.CurrTrueLabel;
-      oldFalseLabel:=current_procinfo.CurrFalseLabel;
-      current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
-      current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
       secondpass(left);
       if codegenerror then
        exit;
@@ -195,8 +191,6 @@ implementation
       else
         cg.g_flags2reg(current_asmdata.CurrAsmList,location.size,resflags,location.register);
       cg.a_reg_dealloc(current_asmdata.CurrAsmList,NR_DEFAULTFLAGS);
-      current_procinfo.CurrTrueLabel:=oldTrueLabel;
-      current_procinfo.CurrFalseLabel:=oldFalseLabel;
     end;
 
 

compiler/aasmtai.pas

@@ -69,14 +69,6 @@ interface
           ait_stab,
           ait_force_line,
           ait_function_name,
-{$ifdef alpha}
-          { the follow is for the DEC Alpha }
-          ait_frame,
-{$endif alpha}
-{$ifdef ia64}
-          ait_bundle,
-          ait_stop,
-{$endif ia64}
 {$ifdef m68k}
           ait_labeled_instruction,
 {$endif m68k}
@@ -197,14 +189,6 @@ interface
           'stab',
           'force_line',
           'function_name',
-{$ifdef alpha}
-          { the follow is for the DEC Alpha }
-          'frame',
-{$endif alpha}
-{$ifdef ia64}
-          'bundle',
-          'stop',
-{$endif ia64}
 {$ifdef m68k}
           'labeled_instr',
 {$endif m68k}
@@ -292,7 +276,7 @@ interface
                    ,ait_directive
                    ,ait_varloc,
 {$ifdef JVM}
-                   ait_jvar, ait_jcatch,
+                   ait_jvar,
 {$endif JVM}
                    ait_seh_directive];
 
@@ -348,7 +332,7 @@ interface
         asd_weak_definition,
         { for Jasmin }
         asd_jclass,asd_jinterface,asd_jsuper,asd_jfield,asd_jlimit,asd_jline,
-        { .ent/.end for MIPS and Alpha }
+        { .ent/.end for MIPS }
         asd_ent,asd_ent_end,
         { supported by recent clang-based assemblers for data-in-code  }
         asd_data_region, asd_end_data_region,
@@ -383,7 +367,7 @@ interface
         'no_dead_strip','weak_reference','lazy_reference','weak_definition',
         { for Jasmin }
         'class','interface','super','field','limit','line',
-        { .ent/.end for MIPS and Alpha }
+        { .ent/.end for MIPS }
         'ent','end',
         { supported by recent clang-based assemblers for data-in-code }
         'data_region','end_data_region',

compiler/aggas.pas

@@ -142,13 +142,6 @@ implementation
           #9'.uahalf'#9,#9'.uaword'#9,#9'.uaxword'#9
         );
 
-      { Alpha type of unaligned pseudo-instructions }
-      use_ua_alpha_systems = [system_alpha_linux];
-      ait_ua_alpha_const2str : array[aitconst_16bit_unaligned..aitconst_64bit_unaligned]
-        of string[20]=(
-          #9'.uword'#9,#9'.ulong'#9,#9'.uquad'#9
-        );
-
       { Generic unaligned pseudo-instructions, seems ELF specific }
       use_ua_elf_systems = [system_mipsel_linux,system_mipseb_linux,system_mipsel_android,system_mipsel_embedded,system_mipseb_embedded];
       ait_ua_elf_const2str : array[aitconst_16bit_unaligned..aitconst_64bit_unaligned]
@@ -954,9 +947,6 @@ implementation
                          if (constdef in ait_unaligned_consts) and
                             (target_info.system in use_ua_sparc_systems) then
                            AsmWrite(ait_ua_sparc_const2str[constdef])
-                         else if (constdef in ait_unaligned_consts) and
-                            (target_info.system in use_ua_alpha_systems) then
-                           AsmWrite(ait_ua_alpha_const2str[constdef])
                          else if (constdef in ait_unaligned_consts) and
                                  (target_info.system in use_ua_elf_systems) then
                            AsmWrite(ait_ua_elf_const2str[constdef])

compiler/aoptobj.pas

@@ -1239,7 +1239,7 @@ Unit AoptObj;
               if { the next instruction after the label where the jump hp arrives}
                  { is unconditional or of the same type as hp, so continue       }
                  IsJumpToLabel(taicpu(p1))
-{$ifndef MIPS}
+{$if not defined(MIPS) and not defined(JVM)}
 { for MIPS, it isn't enough to check the condition; first operands must be same, too. }
                  or
                  conditions_equal(taicpu(p1).condition,hp.condition) or
@@ -1256,7 +1256,7 @@ Unit AoptObj;
                    (IsJumpToLabel(taicpu(p2)) or
                    (conditions_equal(taicpu(p2).condition,hp.condition))) and
                   SkipLabels(p1,p1))
-{$endif MIPS}
+{$endif not MIPS and not JVM}
                  then
                 begin
                   { quick check for loops of the form "l5: ; jmp l5 }
@@ -1277,7 +1277,7 @@ Unit AoptObj;
                   JumpTargetOp(hp)^.ref^.symbol:=JumpTargetOp(taicpu(p1))^.ref^.symbol;
                   tasmlabel(JumpTargetOp(hp)^.ref^.symbol).increfs;
                 end
-{$ifndef MIPS}
+{$if not defined(MIPS) and not defined(JVM)}
               else
                 if conditions_equal(taicpu(p1).condition,inverse_cond(hp.condition)) then
                   if not FindAnyLabel(p1,l) then
@@ -1308,7 +1308,7 @@ Unit AoptObj;
                       if not GetFinalDestination(hp,succ(level)) then
                         exit;
                     end;
-{$endif not MIPS}
+{$endif not MIPS and not JVM}
           end;
         GetFinalDestination := true;
       end;
@@ -1357,7 +1357,11 @@ Unit AoptObj;
                           begin
                             hp2:=p;
                             while GetNextInstruction(hp2, hp1) and
-                                  (hp1.typ <> ait_label) do
+                                  (hp1.typ <> ait_label)
+{$ifdef JVM}
+                                  and (hp1.typ <> ait_jcatch)
+{$endif}
+                                  do
                               if not(hp1.typ in ([ait_label,ait_align]+skipinstr)) then
                                 begin
                                   if (hp1.typ = ait_instruction) and

compiler/arm/narmadd.pas

@@ -407,10 +407,13 @@ interface
         unsigned : boolean;
         oldnodetype : tnodetype;
         dummyreg : tregister;
+        truelabel, falselabel: tasmlabel;
         l: tasmlabel;
       const
         lt_zero_swapped: array[boolean] of tnodetype = (ltn, gtn);
       begin
+        truelabel:=nil;
+        falselabel:=nil;
         unsigned:=not(is_signed(left.resultdef)) or
                   not(is_signed(right.resultdef));
 
@@ -472,17 +475,19 @@ interface
             else
             { operation requiring proper N, Z and V flags ? }
               begin
-                location_reset(location,LOC_JUMP,OS_NO);
+                current_asmdata.getjumplabel(truelabel);
+                current_asmdata.getjumplabel(falselabel);
+                location_reset_jump(location,truelabel,falselabel);
                 cg.a_reg_alloc(current_asmdata.CurrAsmList,NR_DEFAULTFLAGS);
                 current_asmdata.CurrAsmList.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(current_asmdata.CurrAsmList,getresflags(false),current_procinfo.CurrTrueLabel);
+                        cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(false),location.truelabel);
                         { cheat a little bit for the negative test }
                         toggleflag(nf_swapped);
-                        cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(false),current_procinfo.CurrFalseLabel);
+                        cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(false),location.falselabel);
                         cg.a_reg_dealloc(current_asmdata.CurrAsmList,NR_DEFAULTFLAGS);
                         toggleflag(nf_swapped);
                      end;
@@ -493,13 +498,13 @@ interface
                           nodetype:=ltn
                         else
                           nodetype:=gtn;
-                        cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),current_procinfo.CurrTrueLabel);
+                        cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),location.truelabel);
                         { cheat for the negative test }
                         if nodetype=ltn then
                           nodetype:=gtn
                         else
                           nodetype:=ltn;
-                        cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),current_procinfo.CurrFalseLabel);
+                        cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),location.falselabel);
                         cg.a_reg_dealloc(current_asmdata.CurrAsmList,NR_DEFAULTFLAGS);
                         nodetype:=oldnodetype;
                      end;
@@ -508,8 +513,8 @@ interface
                 current_asmdata.CurrAsmList.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(current_asmdata.CurrAsmList,getresflags(true),current_procinfo.CurrTrueLabel);
-                cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+                cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(true),location.truelabel);
+                cg.a_jmp_always(current_asmdata.CurrAsmList,location.falselabel);
                 cg.a_reg_dealloc(current_asmdata.CurrAsmList,NR_DEFAULTFLAGS);
               end;
           end;

compiler/arm/narmcnv.pas

@@ -283,13 +283,9 @@ implementation
         hregister : tregister;
         href      : treference;
         resflags  : tresflags;
-        hlabel,oldTrueLabel,oldFalseLabel : tasmlabel;
+        hlabel    : tasmlabel;
         newsize   : tcgsize;
       begin
-         oldTrueLabel:=current_procinfo.CurrTrueLabel;
-         oldFalseLabel:=current_procinfo.CurrFalseLabel;
-         current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
-         current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
          secondpass(left);
          if codegenerror then
           exit;
@@ -307,8 +303,6 @@ implementation
                 hlcg.location_force_reg(current_asmdata.CurrAsmList,location,left.resultdef,resultdef,true)
               else
                 location.size:=newsize;
-              current_procinfo.CurrTrueLabel:=oldTrueLabel;
-              current_procinfo.CurrFalseLabel:=oldFalseLabel;
               exit;
            end;
 
@@ -365,10 +359,10 @@ implementation
               begin
                 hregister:=cg.getintregister(current_asmdata.CurrAsmList,OS_INT);
                 current_asmdata.getjumplabel(hlabel);
-                cg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
+                cg.a_label(current_asmdata.CurrAsmList,left.location.truelabel);
                 cg.a_load_const_reg(current_asmdata.CurrAsmList,OS_INT,1,hregister);
                 cg.a_jmp_always(current_asmdata.CurrAsmList,hlabel);
-                cg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+                cg.a_label(current_asmdata.CurrAsmList,left.location.falselabel);
                 cg.a_load_const_reg(current_asmdata.CurrAsmList,OS_INT,0,hregister);
                 cg.a_label(current_asmdata.CurrAsmList,hlabel);
                 tbasecgarm(cg).cgsetflags:=true;
@@ -401,9 +395,6 @@ implementation
          else
 {$endif cpu64bitalu}
            location.register:=hreg1;
-
-         current_procinfo.CurrTrueLabel:=oldTrueLabel;
-         current_procinfo.CurrFalseLabel:=oldFalseLabel;
       end;
 
 

compiler/arm/narmmat.pas

@@ -309,29 +309,11 @@ implementation
 *****************************************************************************}
 
     procedure tarmnotnode.second_boolean;
-      var
-        hl : tasmlabel;
       begin
         { if the location is LOC_JUMP, we do the secondpass after the
           labels are allocated
         }
-        if left.expectloc=LOC_JUMP then
-          begin
-            hl:=current_procinfo.CurrTrueLabel;
-            current_procinfo.CurrTrueLabel:=current_procinfo.CurrFalseLabel;
-            current_procinfo.CurrFalseLabel:=hl;
-            secondpass(left);
-
-            if left.location.loc<>LOC_JUMP then
-              internalerror(2012081305);
-
-            maketojumpbool(current_asmdata.CurrAsmList,left,lr_load_regvars);
-            hl:=current_procinfo.CurrTrueLabel;
-            current_procinfo.CurrTrueLabel:=current_procinfo.CurrFalseLabel;
-            current_procinfo.CurrFalseLabel:=hl;
-            location.loc:=LOC_JUMP;
-          end
-        else
+        if not handle_locjump then
           begin
             secondpass(left);
             case left.location.loc of

compiler/arm/narmset.pas

@@ -51,7 +51,7 @@ interface
 implementation
 
     uses
-      verbose,globals,constexp,defutil,
+      verbose,globals,constexp,defutil,systems,
       aasmbase,aasmtai,aasmdata,aasmcpu,
       cpubase,cpuinfo,
       cgutils,cgobj,ncgutil,
@@ -72,7 +72,8 @@ implementation
         if not(assigned(result)) then
           begin
             if not(checkgenjumps(setparts,numparts,use_small)) and
-              use_small then
+              use_small and
+              (target_info.endian=endian_little) then
               expectloc:=LOC_FLAGS;
           end;
       end;
@@ -82,6 +83,14 @@ implementation
         so : tshifterop;
         hregister : tregister;
       begin
+        { the code below needs changes for big endian targets (they start
+          counting from the most significant bit)
+        }
+        if target_info.endian=endian_big then
+          begin
+            inherited;
+            exit;
+          end;
         location_reset(location,LOC_FLAGS,OS_NO);
         location.resflags:=F_NE;
         if (left.location.loc=LOC_CONSTANT) and not(GenerateThumbCode) then

compiler/avr/navrmat.pas

@@ -57,30 +57,10 @@ implementation
 
     procedure tavrnotnode.second_boolean;
       var
-        hl : tasmlabel;
         tmpreg : tregister;
         i : longint;
       begin
-        { if the location is LOC_JUMP, we do the secondpass after the
-          labels are allocated
-        }
-        if left.expectloc=LOC_JUMP then
-          begin
-            hl:=current_procinfo.CurrTrueLabel;
-            current_procinfo.CurrTrueLabel:=current_procinfo.CurrFalseLabel;
-            current_procinfo.CurrFalseLabel:=hl;
-            secondpass(left);
-
-            if left.location.loc<>LOC_JUMP then
-              internalerror(2012081304);
-
-            maketojumpbool(current_asmdata.CurrAsmList,left,lr_load_regvars);
-            hl:=current_procinfo.CurrTrueLabel;
-            current_procinfo.CurrTrueLabel:=current_procinfo.CurrFalseLabel;
-            current_procinfo.CurrFalseLabel:=hl;
-            location.loc:=LOC_JUMP;
-          end
-        else
+        if not handle_locjump then
           begin
             secondpass(left);
             case left.location.loc of

compiler/cgutils.pas

@@ -151,7 +151,10 @@ unit cgutils;
             );
             LOC_SUBSETREF : (
               sref: tsubsetreference;
-            )
+            );
+            LOC_JUMP : (
+              truelabel, falselabel: tasmlabel;
+            );
       end;
 
 
@@ -175,6 +178,8 @@ unit cgutils;
     procedure location_reset(var l : tlocation;lt:TCGNonRefLoc;lsize:TCGSize);
     { for loc_(c)reference }
     procedure location_reset_ref(var l : tlocation;lt:TCGRefLoc;lsize:TCGSize; alignment: longint);
+    { for loc_jump }
+    procedure location_reset_jump(out l: tlocation; truelab, falselab: tasmlabel);
     procedure location_copy(var destloc:tlocation; const sourceloc : tlocation);
     procedure location_swap(var destloc,sourceloc : tlocation);
     function location_reg2string(const locreg: tlocation): string;
@@ -247,8 +252,8 @@ uses
         FillChar(l,sizeof(tlocation),0);
         l.loc:=lt;
         l.size:=lsize;
-        if l.loc in [LOC_REFERENCE,LOC_CREFERENCE] then
-          { call location_reset_ref instead }
+        if l.loc in [LOC_REFERENCE,LOC_CREFERENCE,LOC_JUMP] then
+          { call location_reset_ref/jump instead }
           internalerror(2009020705);
       end;
 
@@ -265,6 +270,16 @@ uses
     end;
 
 
+    procedure location_reset_jump(out l: tlocation; truelab, falselab: tasmlabel);
+      begin
+        FillChar(l,sizeof(tlocation),0);
+        l.loc:=LOC_JUMP;
+        l.size:=OS_NO;
+        l.truelabel:=truelab;
+        l.falselabel:=falselab;
+      end;
+
+
     procedure location_copy(var destloc:tlocation; const sourceloc : tlocation);
       begin
         destloc:=sourceloc;

compiler/fpcdefs.inc

@@ -93,20 +93,6 @@
   {$define cpucapabilities}
 {$endif x86_64}
 
-{$ifdef ia64}
-  {$define cpuflags}
-  {$define cpu64bitalu}
-  {$define cpu64bitaddr}
-  {$define cpuextended}
-  {$define cpufloat128}
-{$endif ia64}
-
-{$ifdef alpha}
-  {$define cpu64bitalu}
-  {$define cpu64bitaddr}
-  {$define cpurefshaveindexreg}
-{$endif alpha}
-
 {$ifdef sparc}
   {$define cpu32bit}
   {$define cpu32bitaddr}

compiler/globals.pas

@@ -230,9 +230,6 @@ interface
        asmextraopt       : string;
 
        { things specified with parameters }
-       paratarget        : tsystem;
-       paratargetdbg     : tdbg;
-       paratargetasm     : tasm;
        paralinkoptions   : TCmdStr;
        paradynamiclinker : string;
        paraprintnodetree : byte;
@@ -297,7 +294,6 @@ interface
        MacOSXVersionMin,
        iPhoneOSVersionMin: string[15];
        RelocSectionSetExplicitly : boolean;
-       LinkTypeSetExplicitly : boolean;
 
        current_tokenpos,                  { position of the last token }
        current_filepos : tfileposinfo;    { current position }
@@ -345,11 +341,6 @@ interface
     const
        DLLsource : boolean = false;
 
-       { used to set all registers used for each global function
-         this should dramatically decrease the number of
-         recompilations needed PM }
-       simplify_ppu : boolean = true;
-
        Inside_asm_statement : boolean = false;
 
        global_unit_count : word = 0;
@@ -453,11 +444,6 @@ interface
         optimizecputype : cpu_athlon64;
         fputype : fpu_sse64;
   {$endif x86_64}
-  {$ifdef ia64}
-        cputype : cpu_itanium;
-        optimizecputype : cpu_itanium;
-        fputype : fpu_itanium;
-  {$endif ia64}
   {$ifdef avr}
         cputype : cpuinfo.cpu_avr5;
         optimizecputype : cpuinfo.cpu_avr5;
@@ -1372,9 +1358,6 @@ implementation
         compile_level:=0;
         codegenerror:=false;
         DLLsource:=false;
-        paratarget:=system_none;
-        paratargetasm:=as_none;
-        paratargetdbg:=dbg_none;
 
         { Output }
         OutputFileName:='';
@@ -1421,7 +1404,6 @@ implementation
         GenerateImportSection:=false;
         RelocSection:=false;
         RelocSectionSetExplicitly:=false;
-        LinkTypeSetExplicitly:=false;
         MacOSXVersionMin:='';
         iPhoneOSVersionMin:='';
         { memory sizes, will be overridden by parameter or default for target

compiler/hlcg2ll.pas

@@ -307,7 +307,7 @@ unit hlcg2ll;
           procedure location_force_mmregscalar(list:TAsmList;var l: tlocation;size:tdef;maybeconst:boolean);override;
 //          procedure location_force_mmreg(list:TAsmList;var l: tlocation;size:tdef;maybeconst:boolean);override;
 
-          procedure maketojumpbool(list:TAsmList; p : tnode);override;
+          procedure maketojumpboollabels(list: TAsmList; p: tnode; truelabel, falselabel: tasmlabel); override;
 
           procedure gen_load_para_value(list:TAsmList);override;
          protected
@@ -1041,11 +1041,11 @@ implementation
 {$endif cpuflags}
               LOC_JUMP :
                 begin
-                  cg.a_label(list,current_procinfo.CurrTrueLabel);
+                  cg.a_label(list,l.truelabel);
                   cg.a_load_const_reg(list,OS_INT,1,hregister);
                   current_asmdata.getjumplabel(hl);
                   cg.a_jmp_always(list,hl);
-                  cg.a_label(list,current_procinfo.CurrFalseLabel);
+                  cg.a_label(list,l.falselabel);
                   cg.a_load_const_reg(list,OS_INT,0,hregister);
                   cg.a_label(list,hl);
 {$if defined(cpu8bitalu) or defined(cpu16bitalu)}
@@ -1141,11 +1141,11 @@ implementation
                 if TCGSize2Size[dst_cgsize]>TCGSize2Size[OS_INT] then
                   tmpsize:=OS_INT;
 {$endif}
-                cg.a_label(list,current_procinfo.CurrTrueLabel);
+                cg.a_label(list,l.truelabel);
                 cg.a_load_const_reg(list,tmpsize,1,hregister);
                 current_asmdata.getjumplabel(hl);
                 cg.a_jmp_always(list,hl);
-                cg.a_label(list,current_procinfo.CurrFalseLabel);
+                cg.a_label(list,l.falselabel);
                 cg.a_load_const_reg(list,tmpsize,0,hregister);
                 cg.a_label(list,hl);
 {$if defined(cpu8bitalu) or defined(cpu16bitalu)}
@@ -1311,11 +1311,11 @@ implementation
       ncgutil.location_force_mmreg(list,l,maybeconst);
     end;
 *)
-  procedure thlcg2ll.maketojumpbool(list: TAsmList; p: tnode);
+  procedure thlcg2ll.maketojumpboollabels(list: TAsmList; p: tnode; truelabel, falselabel: tasmlabel);
     begin
       { loadregvars parameter is no longer used, should be removed from
          ncgutil version as well }
-      ncgutil.maketojumpbool(list,p,lr_dont_load_regvars);
+      ncgutil.maketojumpboollabels(list,p,truelabel,falselabel);
     end;
 
   procedure thlcg2ll.gen_load_para_value(list: TAsmList);

compiler/hlcgobj.pas

@@ -552,7 +552,12 @@ unit hlcgobj;
             a register it is expected to contain the address of the data }
           procedure location_get_data_ref(list:TAsmList;def: tdef; const l:tlocation;var ref:treference;loadref:boolean; alignment: longint);virtual;
 
-          procedure maketojumpbool(list:TAsmList; p : tnode);virtual;
+          { if p is a boolean expression, turns p.location into a LOC_JUMP with
+            jumps to generated true and false labels; otherwise internalerrors }
+          procedure maketojumpbool(list: TAsmList; p: tnode);
+          { same as above, but using predefined true/false labels instead of
+            by generating new ones }
+          procedure maketojumpboollabels(list: TAsmList; p: tnode; truelabel, falselabel: tasmlabel);virtual;
           { if the result of n is a LOC_C(..)REGISTER, try to find the corresponding
             loadn and change its location to a new register (= SSA). In case reload
             is true, transfer the old to the new register                            }
@@ -3850,11 +3855,11 @@ implementation
 {$endif cpuflags}
         LOC_JUMP :
           begin
-            a_label(list,current_procinfo.CurrTrueLabel);
+            a_label(list,l.truelabel);
             a_load_const_reg(list,dst_size,1,hregister);
             current_asmdata.getjumplabel(hl);
             a_jmp_always(list,hl);
-            a_label(list,current_procinfo.CurrFalseLabel);
+            a_label(list,l.falselabel);
             a_load_const_reg(list,dst_size,0,hregister);
             a_label(list,hl);
           end;
@@ -4035,15 +4040,27 @@ implementation
         end;
       end;
 
+
   procedure thlcgobj.maketojumpbool(list: TAsmList; p: tnode);
-  {
-    produces jumps to true respectively false labels using boolean expressions
-
-    depending on whether the loading of regvars is currently being
-    synchronized manually (such as in an if-node) or automatically (most of
-    the other cases where this procedure is called), loadregvars can be
-    "lr_load_regvars" or "lr_dont_load_regvars"
-  }
+    var
+      truelabel,
+      falselabel: tasmlabel;
+    begin
+       if p.location.loc<>LOC_JUMP then
+         begin
+           current_asmdata.getjumplabel(truelabel);
+           current_asmdata.getjumplabel(falselabel);
+         end
+       else
+         begin
+           truelabel:=p.location.truelabel;
+           falselabel:=p.location.falselabel;
+         end;
+       maketojumpboollabels(list,p,truelabel,falselabel);
+    end;
+
+
+  procedure thlcgobj.maketojumpboollabels(list: TAsmList; p: tnode; truelabel, falselabel: tasmlabel);
     var
       storepos : tfileposinfo;
     begin
@@ -4056,9 +4073,9 @@ implementation
             if is_constboolnode(p) then
               begin
                  if Tordconstnode(p).value.uvalue<>0 then
-                   a_jmp_always(list,current_procinfo.CurrTrueLabel)
+                   a_jmp_always(list,truelabel)
                  else
-                   a_jmp_always(list,current_procinfo.CurrFalseLabel)
+                   a_jmp_always(list,falselabel)
               end
             else
               begin
@@ -4067,17 +4084,28 @@ implementation
                    LOC_SUBSETREF,LOC_CSUBSETREF,
                    LOC_CREGISTER,LOC_REGISTER,LOC_CREFERENCE,LOC_REFERENCE :
                      begin
-                       a_cmp_const_loc_label(list,p.resultdef,OC_NE,0,p.location,current_procinfo.CurrTrueLabel);
-                       a_jmp_always(list,current_procinfo.CurrFalseLabel);
+                       a_cmp_const_loc_label(list,p.resultdef,OC_NE,0,p.location,truelabel);
+                       a_jmp_always(list,falselabel);
                      end;
                    LOC_JUMP:
-                     ;
+                     begin
+                       if truelabel<>p.location.truelabel then
+                         begin
+                           a_label(list,p.location.truelabel);
+                           a_jmp_always(list,truelabel);
+                         end;
+                       if falselabel<>p.location.falselabel then
+                         begin
+                           a_label(list,p.location.falselabel);
+                           a_jmp_always(list,falselabel);
+                         end;
+                     end;
 {$ifdef cpuflags}
                    LOC_FLAGS :
                      begin
-                       a_jmp_flags(list,p.location.resflags,current_procinfo.CurrTrueLabel);
+                       a_jmp_flags(list,p.location.resflags,truelabel);
                        a_reg_dealloc(list,NR_DEFAULTFLAGS);
-                       a_jmp_always(list,current_procinfo.CurrFalseLabel);
+                       a_jmp_always(list,falselabel);
                      end;
 {$endif cpuflags}
                    else
@@ -4087,6 +4115,7 @@ implementation
                      end;
                  end;
               end;
+            location_reset_jump(p.location,truelabel,falselabel);
          end
        else
          internalerror(2011010419);

compiler/htypechk.pas

@@ -2602,7 +2602,8 @@ implementation
         paraidx  : integer;
         currparanr : byte;
         rfh,rth  : double;
-        objdef   : tobjectdef;
+        obj_from,
+        obj_to   : tobjectdef;
         def_from,
         def_to   : tdef;
         currpt,
@@ -2768,13 +2769,15 @@ implementation
                   def_is_related(tobjectdef(def_from),tobjectdef(def_to)) then
                  begin
                    eq:=te_convert_l1;
-                   objdef:=tobjectdef(def_from);
-                   while assigned(objdef) do
+                   { resolve anonymous external class definitions }
+                   obj_from:=find_real_class_definition(tobjectdef(def_from),false);
+                   obj_to:=find_real_class_definition(tobjectdef(def_to),false);
+                   while assigned(obj_from) do
                      begin
-                       if objdef=def_to then
+                       if obj_from=obj_to then
                          break;
                        hp^.ordinal_distance:=hp^.ordinal_distance+1;
-                       objdef:=objdef.childof;
+                       obj_from:=obj_from.childof;
                      end;
                  end
                { compare_defs_ext compares sets and array constructors very poorly because

compiler/i386/n386add.pas

@@ -229,6 +229,8 @@ interface
 
     procedure ti386addnode.second_cmp64bit;
       var
+        truelabel,
+        falselabel,
         hlab       : tasmlabel;
         href       : treference;
         unsigned   : boolean;
@@ -246,12 +248,12 @@ interface
            case nodetype of
               ltn,gtn:
                 begin
-                   if (hlab<>current_procinfo.CurrTrueLabel) then
-                     cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),current_procinfo.CurrTrueLabel);
+                   if (hlab<>location.truelabel) then
+                     cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),location.truelabel);
                    { cheat a little bit for the negative test }
                    toggleflag(nf_swapped);
-                   if (hlab<>current_procinfo.CurrFalseLabel) then
-                     cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),current_procinfo.CurrFalseLabel);
+                   if (hlab<>location.falselabel) then
+                     cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),location.falselabel);
                    toggleflag(nf_swapped);
                 end;
               lten,gten:
@@ -261,21 +263,21 @@ interface
                      nodetype:=ltn
                    else
                      nodetype:=gtn;
-                   if (hlab<>current_procinfo.CurrTrueLabel) then
-                     cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),current_procinfo.CurrTrueLabel);
+                   if (hlab<>location.truelabel) then
+                     cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),location.truelabel);
                    { cheat for the negative test }
                    if nodetype=ltn then
                      nodetype:=gtn
                    else
                      nodetype:=ltn;
-                   if (hlab<>current_procinfo.CurrFalseLabel) then
-                     cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),current_procinfo.CurrFalseLabel);
+                   if (hlab<>location.falselabel) then
+                     cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),location.falselabel);
                    nodetype:=oldnodetype;
                 end;
               equaln:
-                cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,current_procinfo.CurrFalseLabel);
+                cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,location.falselabel);
               unequaln:
-                cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,current_procinfo.CurrTrueLabel);
+                cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,location.truelabel);
            end;
         end;
 
@@ -288,23 +290,25 @@ interface
                 begin
                    { the comparisaion of the low dword have to be }
                    {  always unsigned!                            }
-                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(true),current_procinfo.CurrTrueLabel);
-                   cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(true),location.truelabel);
+                   cg.a_jmp_always(current_asmdata.CurrAsmList,location.falselabel);
                 end;
               equaln:
                 begin
-                   cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,current_procinfo.CurrFalseLabel);
-                   cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
+                   cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,location.falselabel);
+                   cg.a_jmp_always(current_asmdata.CurrAsmList,location.truelabel);
                 end;
               unequaln:
                 begin
-                   cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,current_procinfo.CurrTrueLabel);
-                   cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+                   cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,location.truelabel);
+                   cg.a_jmp_always(current_asmdata.CurrAsmList,location.falselabel);
                 end;
            end;
         end;
 
       begin
+        truelabel:=nil;
+        falselabel:=nil;
         pass_left_right;
 
         unsigned:=((left.resultdef.typ=orddef) and
@@ -313,7 +317,9 @@ interface
                    (torddef(right.resultdef).ordtype=u64bit));
 
         { we have LOC_JUMP as result }
-        location_reset(location,LOC_JUMP,OS_NO);
+        current_asmdata.getjumplabel(truelabel);
+        current_asmdata.getjumplabel(falselabel);
+        location_reset_jump(location,truelabel,falselabel);
 
         { Relational compares against constants having low dword=0 can omit the
           second compare based on the fact that any unsigned value is >=0 }
@@ -322,8 +328,8 @@ interface
            (lo(right.location.value64)=0) then
           begin
             case getresflags(true) of
-              F_AE: hlab:=current_procinfo.CurrTrueLabel;
-              F_B:  hlab:=current_procinfo.CurrFalseLabel;
+              F_AE: hlab:=location.truelabel ;
+              F_B:  hlab:=location.falselabel;
             end;
           end;
 

compiler/i8086/n8086add.pas

@@ -518,6 +518,8 @@ interface
 
     procedure ti8086addnode.second_cmp64bit;
       var
+        truelabel,
+        falselabel : tasmlabel;
         hregister,
         hregister2 : tregister;
         href       : treference;
@@ -536,10 +538,10 @@ interface
            case nodetype of
               ltn,gtn:
                 begin
-                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),current_procinfo.CurrTrueLabel);
+                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),location.truelabel);
                    { cheat a little bit for the negative test }
                    toggleflag(nf_swapped);
-                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),current_procinfo.CurrFalseLabel);
+                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),location.falselabel);
                    toggleflag(nf_swapped);
                 end;
               lten,gten:
@@ -549,19 +551,19 @@ interface
                      nodetype:=ltn
                    else
                      nodetype:=gtn;
-                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),current_procinfo.CurrTrueLabel);
+                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),location.truelabel);
                    { cheat for the negative test }
                    if nodetype=ltn then
                      nodetype:=gtn
                    else
                      nodetype:=ltn;
-                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),current_procinfo.CurrFalseLabel);
+                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),location.falselabel);
                    nodetype:=oldnodetype;
                 end;
               equaln:
-                cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,current_procinfo.CurrFalseLabel);
+                cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,location.falselabel);
               unequaln:
-                cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,current_procinfo.CurrTrueLabel);
+                cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,location.truelabel);
            end;
         end;
 
@@ -580,10 +582,10 @@ interface
                 begin
                    { the comparisaion of the low word have to be }
                    {  always unsigned!                           }
-                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(true),current_procinfo.CurrTrueLabel);
+                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(true),location.truelabel);
                    { cheat a little bit for the negative test }
                    toggleflag(nf_swapped);
-                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(true),current_procinfo.CurrFalseLabel);
+                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(true),location.falselabel);
                    toggleflag(nf_swapped);
                 end;
               lten,gten:
@@ -593,19 +595,19 @@ interface
                      nodetype:=ltn
                    else
                      nodetype:=gtn;
-                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(true),current_procinfo.CurrTrueLabel);
+                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(true),location.truelabel);
                    { cheat for the negative test }
                    if nodetype=ltn then
                      nodetype:=gtn
                    else
                      nodetype:=ltn;
-                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(true),current_procinfo.CurrFalseLabel);
+                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(true),location.falselabel);
                    nodetype:=oldnodetype;
                 end;
               equaln:
-                cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,current_procinfo.CurrFalseLabel);
+                cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,location.falselabel);
               unequaln:
-                cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,current_procinfo.CurrTrueLabel);
+                cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,location.truelabel);
            end;
         end;
 
@@ -618,23 +620,25 @@ interface
                 begin
                    { the comparisaion of the low word have to be }
                    {  always unsigned!                           }
-                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(true),current_procinfo.CurrTrueLabel);
-                   cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(true),location.truelabel);
+                   cg.a_jmp_always(current_asmdata.CurrAsmList,location.falselabel);
                 end;
               equaln:
                 begin
-                   cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,current_procinfo.CurrFalseLabel);
-                   cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
+                   cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,location.falselabel);
+                   cg.a_jmp_always(current_asmdata.CurrAsmList,location.truelabel);
                 end;
               unequaln:
                 begin
-                   cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,current_procinfo.CurrTrueLabel);
-                   cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+                   cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,location.truelabel);
+                   cg.a_jmp_always(current_asmdata.CurrAsmList,location.falselabel);
                 end;
            end;
         end;
 
       begin
+        truelabel:=nil;
+        falselabel:=nil;
         pass_left_right;
 
         unsigned:=((left.resultdef.typ=orddef) and
@@ -642,6 +646,11 @@ interface
                   ((right.resultdef.typ=orddef) and
                    (torddef(right.resultdef).ordtype=u64bit));
 
+        { we have LOC_JUMP as result }
+        current_asmdata.getjumplabel(truelabel);
+        current_asmdata.getjumplabel(falselabel);
+        location_reset_jump(location,truelabel,falselabel);
+
         { left and right no register?  }
         { then one must be demanded    }
         if (left.location.loc<>LOC_REGISTER) then
@@ -709,7 +718,7 @@ interface
                  middlejmp64bitcmp;
                  emit_ref_reg(A_CMP,S_W,right.location.reference,left.location.register64.reglo);
                  lastjmp64bitcmp;
-                 cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+                 cg.a_jmp_always(current_asmdata.CurrAsmList,location.falselabel);
                  location_freetemp(current_asmdata.CurrAsmList,right.location);
                end;
              LOC_CONSTANT :
@@ -727,13 +736,12 @@ interface
                internalerror(200203282);
            end;
          end;
-
-        { we have LOC_JUMP as result }
-        location_reset(location,LOC_JUMP,OS_NO)
       end;
 
     procedure ti8086addnode.second_cmp32bit;
       var
+        truelabel,
+        falselabel: tasmlabel;
         hregister : tregister;
         href      : treference;
         unsigned  : boolean;
@@ -751,10 +759,10 @@ interface
            case nodetype of
               ltn,gtn:
                 begin
-                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),current_procinfo.CurrTrueLabel);
+                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),location.truelabel);
                    { cheat a little bit for the negative test }
                    toggleflag(nf_swapped);
-                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),current_procinfo.CurrFalseLabel);
+                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),location.falselabel);
                    toggleflag(nf_swapped);
                 end;
               lten,gten:
@@ -764,19 +772,19 @@ interface
                      nodetype:=ltn
                    else
                      nodetype:=gtn;
-                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),current_procinfo.CurrTrueLabel);
+                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),location.truelabel);
                    { cheat for the negative test }
                    if nodetype=ltn then
                      nodetype:=gtn
                    else
                      nodetype:=ltn;
-                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),current_procinfo.CurrFalseLabel);
+                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),location.falselabel);
                    nodetype:=oldnodetype;
                 end;
               equaln:
-                cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,current_procinfo.CurrFalseLabel);
+                cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,location.falselabel);
               unequaln:
-                cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,current_procinfo.CurrTrueLabel);
+                cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,location.truelabel);
            end;
         end;
 
@@ -789,23 +797,25 @@ interface
                 begin
                    { the comparisaion of the low dword have to be }
                    {  always unsigned!                            }
-                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(true),current_procinfo.CurrTrueLabel);
-                   cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(true),location.truelabel);
+                   cg.a_jmp_always(current_asmdata.CurrAsmList,location.falselabel);
                 end;
               equaln:
                 begin
-                   cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,current_procinfo.CurrFalseLabel);
-                   cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
+                   cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,location.falselabel);
+                   cg.a_jmp_always(current_asmdata.CurrAsmList,location.truelabel);
                 end;
               unequaln:
                 begin
-                   cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,current_procinfo.CurrTrueLabel);
-                   cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+                   cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,location.truelabel);
+                   cg.a_jmp_always(current_asmdata.CurrAsmList,location.falselabel);
                 end;
            end;
         end;
 
       begin
+        truelabel:=nil;
+        falselabel:=nil;
         pass_left_right;
 
         unsigned:=((left.resultdef.typ=orddef) and
@@ -814,6 +824,11 @@ interface
                    (torddef(right.resultdef).ordtype=u32bit)) or
                   is_hugepointer(left.resultdef);
 
+        { we have LOC_JUMP as result }
+        current_asmdata.getjumplabel(truelabel);
+        current_asmdata.getjumplabel(falselabel);
+        location_reset_jump(location,truelabel,falselabel);
+
         { left and right no register?  }
         { then one must be demanded    }
         if (left.location.loc<>LOC_REGISTER) then
@@ -866,7 +881,7 @@ interface
                  dec(href.offset,2);
                  emit_ref_reg(A_CMP,S_W,href,left.location.register);
                  secondjmp32bitcmp;
-                 cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+                 cg.a_jmp_always(current_asmdata.CurrAsmList,location.falselabel);
                  location_freetemp(current_asmdata.CurrAsmList,right.location);
                end;
              LOC_CONSTANT :
@@ -880,9 +895,6 @@ interface
                internalerror(200203282);
            end;
          end;
-
-        { we have LOC_JUMP as result }
-        location_reset(location,LOC_JUMP,OS_NO)
       end;
 
 

compiler/jvm/aasmcpu.pas

@@ -123,7 +123,7 @@ implementation
         ops:=1;
         is_jmp:=op in [a_if_acmpeq, a_if_acmpne, a_if_icmpeq, a_if_icmpge, a_if_icmpgt,
           a_if_icmple, a_if_icmplt, a_if_icmpne,
-          a_ifeq, a_ifge, a_ifgt, a_ifle, a_iflt, a_ifne, a_ifnonnull, a_ifnull];
+          a_ifeq, a_ifge, a_ifgt, a_ifle, a_iflt, a_ifne, a_ifnonnull, a_ifnull, a_goto];
         loadsymbol(0,_op1,0);
       end;
 

compiler/jvm/agjasmin.pas

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

compiler/jvm/aoptcpu.pas

@@ -0,0 +1,183 @@
+{
+    Copyright (c) 2015 by Jonas Maebe, member of the Free Pascal
+    Development Team
+
+    This unit implements the JVM 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, aasmtai, aopt, aoptcpub;
+
+Type
+  TCpuAsmOptimizer = class(TAsmOptimizer)
+   protected
+    function RemoveDoubleSwap(var p: tai): boolean;
+    function RemoveCommutativeSwap(var p: tai): boolean;
+    function RemoveLoadLoadSwap(var p: tai): boolean;
+   public
+    { uses the same constructor as TAopObj }
+    function PeepHoleOptPass1Cpu(var p: tai): boolean; override;
+    procedure PeepHoleOptPass2;override;
+    function PostPeepHoleOptsCpu(var p: tai): boolean; override;
+  End;
+
+Implementation
+
+  uses
+    aasmbase,aasmcpu,cgbase;
+
+
+  function TCpuAsmOptimizer.RemoveDoubleSwap(var p: tai): boolean;
+    var
+      next, next2: tai;
+    begin
+      result:=false;
+      { remove two successive "swap" instructions }
+      if (taicpu(p).opcode=a_swap) and
+         GetNextInstruction(p,next) and
+         (next.typ=ait_instruction) and
+         (taicpu(next).opcode=a_swap) then
+        begin
+          { can't be the instruction, must end in a return or so }
+          next2:=tai(next.next);
+          asml.remove(p);
+          asml.remove(next);
+          p.free;
+          next.free;
+          p:=next2;
+          result:=true;
+        end;
+    end;
+
+
+  { returns whether p is an instruction that does not consume any stack slots,
+    and adds a new item on the stack that is one stack slot wide }
+  function OpCreatesSingleStackSlot(p: tai): boolean;
+    begin
+      result:=
+        (p.typ=ait_instruction) and
+        (taicpu(p).opcode in
+          [a_aload, a_aload_0, a_aload_1, a_aload_2, a_aload_3,
+           a_bipush,
+           a_fconst_0, a_fconst_1, a_fconst_2,
+           a_fload, a_fload_0, a_fload_1, a_fload_2, a_fload_3,
+           a_getstatic,
+           a_iconst_m1, a_iconst_0, a_iconst_1, a_iconst_2, a_iconst_3,
+           a_iconst_4, a_iconst_5,
+           a_iload, a_iload_0, a_iload_1, a_iload_2, a_iload_3,
+           a_new,
+           a_sipush]);
+    end;
+
+
+  function OpIsCommutativeSingleSlots(p: tai): boolean;
+    begin
+      result:=
+        (p.typ=ait_instruction) and
+        (taicpu(p).opcode in
+          [a_fadd, a_fmul,
+           a_iadd, a_iand, a_imul, a_ior, a_ixor,
+           a_pop2])
+    end;
+
+
+  function TCpuAsmOptimizer.RemoveCommutativeSwap(var p: tai): boolean;
+    var
+      next: tai;
+    begin
+      result:=false;
+      if (taicpu(p).opcode<>a_swap) then
+        exit;
+      { if the next opcode is commutative operation, we can remove the swap }
+      if GetNextInstruction(p,next) and
+         OpIsCommutativeSingleSlots(next) then
+        begin
+          asml.remove(p);
+          p.free;
+          p:=next;
+          result:=true;
+          exit;
+        end;
+    end;
+
+
+  function TCpuAsmOptimizer.PeepHoleOptPass1Cpu(var p: tai): boolean;
+    var
+      next, next2: tai;
+    begin
+      result:=false;
+      case p.typ of
+        ait_instruction:
+          begin
+            if RemoveDoubleSwap(p) or
+               RemoveCommutativeSwap(p) then
+              exit(true)
+          end;
+      end;
+    end;
+
+
+  procedure TCpuAsmOptimizer.PeepHoleOptPass2;
+    begin
+    end;
+
+
+  function TCpuAsmOptimizer.RemoveLoadLoadSwap(var p: tai): boolean;
+    var
+      next, prev1, prev2: tai;
+    begin
+      result:=false;
+      if (taicpu(p).opcode<>a_swap) then
+        exit;
+      { if we can swap the previous two instructions that put the items on the
+        stack, we can remove the swap -- only do this in PostPeepholeOpts,
+        because this may make the temp alloc information invalid. Ideally, we
+        should move the tempallocs around too }
+      if GetLastInstruction(p,prev1) and
+         OpCreatesSingleStackSlot(prev1) and
+         GetLastInstruction(prev1,prev2) and
+         OpCreatesSingleStackSlot(prev2) then
+        begin
+          next:=tai(p.next);
+          asml.remove(prev2);
+          asml.InsertAfter(prev2,prev1);
+          asml.remove(p);
+          p.free;
+          p:=next;
+          result:=true;
+        end;
+    end;
+
+
+  function TCpuAsmOptimizer.PostPeepHoleOptsCpu(var p: tai): boolean;
+    begin
+      result:=
+        RemoveLoadLoadSwap(p);
+    end;
+
+begin
+  casmoptimizer:=TCpuAsmOptimizer;
+End.
+

compiler/jvm/aoptcpub.pas

@@ -0,0 +1,115 @@
+ {
+    Copyright (c) 2015 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 JVM 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 a scaled index }
+{ define RefsHaveScale}
+
+{ enable the following define if memory references can have a segment }
+{ override                                                            }
+{ define RefsHaveSegment}
+
+Interface
+
+Uses
+  aasmcpu,AOptBase, cpubase;
+
+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 = 2;
+
+{ the maximum number of operands an instruction has }
+
+  MaxOps = 2;
+
+{Oper index of operand that contains the source (reference) with a load }
+{instruction                                                            }
+
+  LoadSrc = 1;
+
+{Oper index of operand that contains the destination (register) with a load }
+{instruction                                                                }
+
+//  LoadDst = 0;
+
+{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_GOTO;
+  aopt_condjmp = A_NONE;
+
+Implementation
+
+{ ************************************************************************* }
+{ **************************** TCondRegs ********************************** }
+{ ************************************************************************* }
+Constructor TCondRegs.init;
+Begin
+End;
+
+Destructor TCondRegs.Done; {$ifdef inl} inline; {$endif inl}
+Begin
+End;
+
+End.

compiler/jvm/aoptcpud.pas

@@ -0,0 +1,34 @@
+{
+    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
+
+Implementation
+
+
+End.
+

compiler/jvm/cpubase.pas

@@ -288,9 +288,16 @@ uses
     function std_regname(r:Tregister):string;
     function findreg_by_number(r:Tregister):tregisterindex;
 
+    { since we don't use tasmconds, don't call this routine
+      (it will internalerror). We need it anyway to get aoptobj
+      to compile (but it won't execute it).
+    }
+    function inverse_cond(const c: TAsmCond): Tasmcond; {$ifdef USEINLINE}inline;{$endif USEINLINE}
+
 implementation
 
 uses
+  verbose,
   rgbase;
 
 {*****************************************************************************
@@ -345,4 +352,10 @@ uses
       end;
 
 
+    function inverse_cond(const c: TAsmCond): Tasmcond; {$ifdef USEINLINE}inline;{$endif USEINLINE}
+      begin
+        result:=C_None;
+        internalerror(2015082701);
+      end;
+
 end.

compiler/jvm/njvmadd.pas

@@ -56,7 +56,7 @@ interface
       cutils,verbose,constexp,globtype,
       symconst,symtable,symdef,symcpu,
       paramgr,procinfo,pass_1,
-      aasmtai,aasmdata,aasmcpu,defutil,
+      aasmbase,aasmtai,aasmdata,aasmcpu,defutil,
       hlcgobj,hlcgcpu,cgutils,
       cpupara,
       nbas,ncon,nset,nadd,ncal,ncnv,ninl,nld,nmat,nmem,
@@ -335,8 +335,12 @@ interface
 
     procedure tjvmaddnode.second_generic_compare(unsigned: boolean);
       var
+        truelabel,
+        falselabel: tasmlabel;
         cmpop: TOpCmp;
       begin
+        truelabel:=nil;
+        falselabel:=nil;
         pass_left_right;
         { swap the operands to make it easier for the optimizer to optimize
           the operand stack slot reloading in case both are in a register }
@@ -346,21 +350,24 @@ interface
         cmpop:=cmpnode2topcmp(unsigned);
         if (nf_swapped in flags) then
           cmpop:=swap_opcmp(cmpop);
-        location_reset(location,LOC_JUMP,OS_NO);
+
+        current_asmdata.getjumplabel(truelabel);
+        current_asmdata.getjumplabel(falselabel);
+        location_reset_jump(location,truelabel,falselabel);
 
         if left.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
-          hlcg.a_cmp_loc_reg_label(current_asmdata.CurrAsmList,left.resultdef,cmpop,right.location,left.location.register,current_procinfo.CurrTrueLabel)
+          hlcg.a_cmp_loc_reg_label(current_asmdata.CurrAsmList,left.resultdef,cmpop,right.location,left.location.register,location.truelabel)
         else case right.location.loc of
           LOC_REGISTER,LOC_CREGISTER:
-            hlcg.a_cmp_reg_loc_label(current_asmdata.CurrAsmList,left.resultdef,cmpop,right.location.register,left.location,current_procinfo.CurrTrueLabel);
+            hlcg.a_cmp_reg_loc_label(current_asmdata.CurrAsmList,left.resultdef,cmpop,right.location.register,left.location,location.truelabel);
           LOC_REFERENCE,LOC_CREFERENCE:
-            hlcg.a_cmp_ref_loc_label(current_asmdata.CurrAsmList,left.resultdef,cmpop,right.location.reference,left.location,current_procinfo.CurrTrueLabel);
+            hlcg.a_cmp_ref_loc_label(current_asmdata.CurrAsmList,left.resultdef,cmpop,right.location.reference,left.location,location.truelabel);
           LOC_CONSTANT:
-            hlcg.a_cmp_const_loc_label(current_asmdata.CurrAsmList,left.resultdef,cmpop,right.location.value,left.location,current_procinfo.CurrTrueLabel);
+            hlcg.a_cmp_const_loc_label(current_asmdata.CurrAsmList,left.resultdef,cmpop,right.location.value,left.location,location.truelabel);
           else
             internalerror(2011010413);
         end;
-        hlcg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+        hlcg.a_jmp_always(current_asmdata.CurrAsmList,location.falselabel);
       end;
 
     procedure tjvmaddnode.pass_left_right;
@@ -441,9 +448,13 @@ interface
 
     procedure tjvmaddnode.second_cmpfloat;
       var
-        op : tasmop;
+        truelabel,
+        falselabel: tasmlabel;
+        op: tasmop;
         cmpop: TOpCmp;
       begin
+        truelabel:=nil;
+        falselabel:=nil;
         pass_left_right;
         { swap the operands to make it easier for the optimizer to optimize
           the operand stack slot reloading in case both are in a register }
@@ -453,7 +464,10 @@ interface
         cmpop:=cmpnode2topcmp(false);
         if (nf_swapped in flags) then
           cmpop:=swap_opcmp(cmpop);
-        location_reset(location,LOC_JUMP,OS_NO);
+
+        current_asmdata.getjumplabel(truelabel);
+        current_asmdata.getjumplabel(falselabel);
+        location_reset_jump(location,truelabel,falselabel);
 
         thlcgjvm(hlcg).a_load_loc_stack(current_asmdata.CurrAsmList,left.resultdef,left.location);
         thlcgjvm(hlcg).a_load_loc_stack(current_asmdata.CurrAsmList,right.resultdef,right.location);
@@ -473,9 +487,9 @@ interface
         current_asmdata.CurrAsmList.concat(taicpu.op_none(op));
         thlcgjvm(hlcg).decstack(current_asmdata.CurrAsmList,(1+ord(left.location.size=OS_F64))*2-1);
 
-        current_asmdata.CurrAsmList.concat(taicpu.op_sym(opcmp2if[cmpop],current_procinfo.CurrTrueLabel));
+        current_asmdata.CurrAsmList.concat(taicpu.op_sym(opcmp2if[cmpop],location.truelabel));
         thlcgjvm(hlcg).decstack(current_asmdata.CurrAsmList,1);
-        hlcg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+        hlcg.a_jmp_always(current_asmdata.CurrAsmList,location.falselabel);
       end;
 
 

compiler/jvm/njvmcnv.pas

@@ -704,12 +704,7 @@ implementation
     procedure tjvmtypeconvnode.second_bool_to_int;
       var
          newsize: tcgsize;
-         oldTrueLabel,oldFalseLabel : tasmlabel;
       begin
-         oldTrueLabel:=current_procinfo.CurrTrueLabel;
-         oldFalseLabel:=current_procinfo.CurrFalseLabel;
-         current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
-         current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
          secondpass(left);
          location_copy(location,left.location);
          newsize:=def_cgsize(resultdef);
@@ -737,20 +732,14 @@ implementation
          else
            { may differ in sign, e.g. bytebool -> byte   }
            location.size:=newsize;
-         current_procinfo.CurrTrueLabel:=oldTrueLabel;
-         current_procinfo.CurrFalseLabel:=oldFalseLabel;
       end;
 
 
     procedure tjvmtypeconvnode.second_int_to_bool;
       var
-        hlabel1,hlabel2,oldTrueLabel,oldFalseLabel : tasmlabel;
+        hlabel1,hlabel2: tasmlabel;
         newsize  : tcgsize;
       begin
-        oldTrueLabel:=current_procinfo.CurrTrueLabel;
-        oldFalseLabel:=current_procinfo.CurrFalseLabel;
-        current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
-        current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
         secondpass(left);
         if codegenerror then
           exit;
@@ -770,8 +759,6 @@ implementation
                hlcg.location_force_reg(current_asmdata.CurrAsmList,location,left.resultdef,resultdef,true)
              else
                location.size:=newsize;
-             current_procinfo.CurrTrueLabel:=oldTrueLabel;
-             current_procinfo.CurrFalseLabel:=oldFalseLabel;
              exit;
           end;
 
@@ -786,8 +773,8 @@ implementation
            end;
          LOC_JUMP :
            begin
-             hlabel1:=current_procinfo.CurrFalseLabel;
-             hlcg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
+             hlabel1:=left.location.falselabel;
+             hlcg.a_label(current_asmdata.CurrAsmList,left.location.truelabel);
            end;
          else
            internalerror(10062);
@@ -805,9 +792,6 @@ implementation
        thlcgjvm(hlcg).a_load_const_stack(current_asmdata.CurrAsmList,resultdef,0,R_INTREGISTER);
        hlcg.a_label(current_asmdata.CurrAsmList,hlabel2);
        thlcgjvm(hlcg).a_load_stack_reg(current_asmdata.CurrAsmList,resultdef,location.register);
-
-       current_procinfo.CurrTrueLabel:=oldTrueLabel;
-       current_procinfo.CurrFalseLabel:=oldFalseLabel;
      end;
 
 

compiler/jvm/njvmmem.pas

@@ -405,13 +405,9 @@ implementation
 
     procedure tjvmvecnode.pass_generate_code;
       var
-        otl,ofl: tasmlabel;
         psym: tsym;
         newsize: tcgsize;
-        isjump: boolean;
       begin
-        otl:=nil;
-        ofl:=nil;
         if left.resultdef.typ=stringdef then
           internalerror(2011052702);
 
@@ -432,30 +428,18 @@ implementation
           and then asking for the size doesn't make any sense }
         hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,java_jlobject,java_jlobject,true);
         location.reference.base:=left.location.register;
-        isjump:=(right.expectloc=LOC_JUMP);
-        if isjump then
-         begin
-           otl:=current_procinfo.CurrTrueLabel;
-           current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
-           ofl:=current_procinfo.CurrFalseLabel;
-           current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
-         end;
         secondpass(right);
+        if (right.expectloc=LOC_JUMP)<>
+           (right.location.loc=LOC_JUMP) then
+          internalerror(2011090501);
 
         { simplify index location if necessary, since array references support
           an index in memory, but not an another array index }
-        if isjump or
+        if (right.location.loc=LOC_JUMP) or
            ((right.location.loc in [LOC_REFERENCE,LOC_CREFERENCE]) and
             (right.location.reference.arrayreftype<>art_none)) then
           hlcg.location_force_reg(current_asmdata.CurrAsmList,right.location,right.resultdef,right.resultdef,true);
 
-        if isjump then
-         begin
-           current_procinfo.CurrTrueLabel:=otl;
-           current_procinfo.CurrFalseLabel:=ofl;
-         end
-        else if (right.location.loc = LOC_JUMP) then
-          internalerror(2011090501);
         { replace enum class instance with the corresponding integer value }
         if (right.resultdef.typ=enumdef) then
           begin

compiler/jvm/rgcpu.pas

@@ -181,8 +181,8 @@ implementation
             and remove. We don't have to check that the load/store
             types match, because they have to for this to be
             valid JVM code }
-          dealloc:=nextskipping(p,[ait_comment]);
-          load:=nextskipping(dealloc,[ait_comment]);
+          dealloc:=nextskipping(p,[ait_comment,ait_tempalloc]);
+          load:=nextskipping(dealloc,[ait_comment,ait_tempalloc]);
           reg:=NR_NO;
           if issimpleregstore(p,reg,true) and
              isregallocoftyp(dealloc,ra_dealloc,reg) and
@@ -201,6 +201,71 @@ implementation
         end;
 
 
+     function try_swap_store_x_load(var p: tai): boolean;
+       var
+         insertpos,
+         storex,
+         deallocy,
+         loady,
+         deallocx,
+         loadx: tai;
+         swapxy: taicpu;
+         regx, regy: tregister;
+       begin
+         result:=false;
+         { check for:
+             alloc regx (optional)
+             store regx (p)
+             dealloc regy
+             load regy
+             dealloc regx
+             load regx
+           and change to
+             dealloc regy
+             load regy
+             swap
+             alloc regx (if it existed)
+             store regx
+             dealloc regx
+             load  regx
+
+           This will create opportunities to remove the store/load regx
+           (and possibly also for regy)
+         }
+         regx:=NR_NO;
+         regy:=NR_NO;
+         if not issimpleregstore(p,regx,false) then
+           exit;
+         storex:=p;
+         deallocy:=nextskipping(storex,[ait_comment,ait_tempalloc]);
+         loady:=nextskipping(deallocy,[ait_comment,ait_tempalloc]);
+         deallocx:=nextskipping(loady,[ait_comment,ait_tempalloc]);
+         loadx:=nextskipping(deallocx,[ait_comment,ait_tempalloc]);
+         if not assigned(loadx) then
+           exit;
+         if not issimpleregload(loady,regy,false) then
+           exit;
+         if not issimpleregload(loadx,regx,false) then
+           exit;
+         if not isregallocoftyp(deallocy,ra_dealloc,regy) then
+           exit;
+         if not isregallocoftyp(deallocx,ra_dealloc,regx) then
+           exit;
+         insertpos:=tai(p.previous);
+         if not assigned(insertpos) or
+            not isregallocoftyp(insertpos,ra_alloc,regx) then
+           insertpos:=storex;
+         list.remove(deallocy);
+         list.insertbefore(deallocy,insertpos);
+         list.remove(loady);
+         list.insertbefore(loady,insertpos);
+         swapxy:=taicpu.op_none(a_swap);
+         swapxy.fileinfo:=taicpu(loady).fileinfo;
+         list.insertbefore(swapxy,insertpos);
+         result:=true;
+       end;
+
+
       var
         p,next,nextnext: tai;
         reg: tregister;
@@ -215,7 +280,7 @@ implementation
                 ait_regalloc:
                   begin
                     reg:=NR_NO;
-                    next:=nextskipping(p,[ait_comment]);
+                    next:=nextskipping(p,[ait_comment,ait_tempalloc]);
                     nextnext:=nextskipping(next,[ait_comment,ait_regalloc]);
                     if assigned(nextnext) then
                       begin
@@ -241,26 +306,12 @@ implementation
                   end;
                 ait_instruction:
                   begin
-                    if try_remove_store_dealloc_load(p) then
+                    if try_remove_store_dealloc_load(p) or
+                       try_swap_store_x_load(p) then
                       begin
                         removedsomething:=true;
                         continue;
                       end;
-                    { todo in peephole optimizer:
-                        alloc regx // not double precision
-                        store regx // not double precision
-                        load  regy or memy
-                        dealloc regx
-                        load regx
-                      -> change into
-                        load regy or memy
-                        swap       // can only handle single precision
-
-                      and then
-                        swap
-                        <commutative op>
-                       -> remove swap
-                    }
                   end;
               end;
               p:=tai(p.next);

compiler/llvm/llvmtype.pas

@@ -0,0 +1,690 @@
+{
+    Copyright (c) 2008,2015 by Peter Vreman, Florian Klaempfl and Jonas Maebe
+
+    This units contains support for generating LLVM type 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.
+
+ ****************************************************************************
+}
+{
+  This units contains support for LLVM type info generation.
+
+  It's based on the debug info system, since it's quite similar
+}
+unit llvmtype;
+
+{$i fpcdefs.inc}
+{$h+}
+
+interface
+
+    uses
+      cclasses,globtype,
+      aasmbase,aasmtai,aasmdata,
+      symbase,symtype,symdef,symsym,
+      aasmllvm,aasmcnst,
+      finput,
+      dbgbase;
+
+
+    { TLLVMTypeInfo }
+    type
+      TLLVMTypeInfo = class(TDebugInfo)
+      protected
+        { using alias/external declarations it's possible to refer to the same
+          assembler symbol using multiple types:
+            function f(p: pointer): pointer; [public, alias: 'FPC_FUNC'];
+            procedure test(p: pointer); external name 'FPC_FUNC';
+
+          We have to insert the appropriate typecasts (per module) for LLVM in
+          this case. That can only be done after all code for a module has been
+          generated, as these alias declarations can appear anywhere }
+        asmsymtypes: THashSet;
+
+        procedure record_asmsym_def(sym: TAsmSymbol; def: tdef; redefine: boolean);
+        function  get_asmsym_def(sym: TAsmSymbol): tdef;
+
+        function record_def(def:tdef): tdef;
+
+        procedure appenddef_array(list:TAsmList;def:tarraydef);override;
+        procedure appenddef_abstractrecord(list:TAsmList;def:tabstractrecorddef);
+        procedure appenddef_record(list:TAsmList;def:trecorddef);override;
+        procedure appenddef_pointer(list:TAsmList;def:tpointerdef);override;
+        procedure appenddef_procvar(list:TAsmList;def:tprocvardef);override;
+        procedure appendprocdef(list:TAsmList;def:tprocdef);override;
+        procedure appenddef_object(list:TAsmList;def: tobjectdef);override;
+        procedure appenddef_variant(list:TAsmList;def: tvariantdef);override;
+        procedure appenddef_file(list:TasmList;def:tfiledef);override;
+
+        procedure appendsym_var(list:TAsmList;sym:tabstractnormalvarsym);
+        procedure appendsym_staticvar(list:TAsmList;sym:tstaticvarsym);override;
+        procedure appendsym_paravar(list:TAsmList;sym:tparavarsym);override;
+        procedure appendsym_localvar(list:TAsmList;sym:tlocalvarsym);override;
+        procedure appendsym_fieldvar(list:TAsmList;sym:tfieldvarsym);override;
+        procedure appendsym_const(list:TAsmList;sym:tconstsym);override;
+        procedure appendsym_absolute(list:TAsmList;sym:tabsolutevarsym);override;
+
+        procedure enum_membersyms_callback(p:TObject;arg:pointer);
+
+        procedure collect_llvmins_info(deftypelist: tasmlist; p: taillvm);
+        procedure collect_tai_info(deftypelist: tasmlist; p: tai);
+        procedure collect_asmlist_info(deftypelist, asmlist: tasmlist);
+
+        procedure insert_llvmins_typeconversions(toplevellist: tasmlist; p: taillvm);
+        procedure insert_typedconst_typeconversion(toplevellist: tasmlist; p: tai_abstracttypedconst);
+        procedure insert_tai_typeconversions(toplevellist: tasmlist; p: tai);
+        procedure insert_asmlist_typeconversions(toplevellist, list: tasmlist);
+        procedure maybe_insert_extern_sym_decl(toplevellist: tasmlist; sym: tasmsymbol; def: tdef);
+        procedure update_asmlist_alias_types(list: tasmlist);
+
+      public
+        constructor Create;override;
+        destructor Destroy;override;
+        procedure inserttypeinfo;override;
+      end;
+
+implementation
+
+    uses
+      sysutils,cutils,cfileutl,constexp,
+      version,globals,verbose,systems,
+      cpubase,cgbase,paramgr,
+      fmodule,nobj,
+      defutil,defcmp,symconst,symtable,
+      llvmbase,llvmdef
+      ;
+
+{****************************************************************************
+                              TDebugInfoDwarf
+****************************************************************************}
+
+    procedure TLLVMTypeInfo.record_asmsym_def(sym: TAsmSymbol; def: tdef; redefine: boolean);
+      var
+        res: PHashSetItem;
+      begin
+        res:=asmsymtypes.FindOrAdd(@sym,sizeof(sym));
+        { due to internal aliases with different signatures, we may end up with
+          multiple defs for the same symbol -> use the one from the declaration,
+          and insert typecasts as necessary elsewhere }
+        if redefine or
+           not assigned(res^.Data) then
+          res^.Data:=def;
+      end;
+
+
+    function TLLVMTypeInfo.get_asmsym_def(sym: TAsmSymbol): tdef;
+      var
+        res: PHashSetItem;
+      begin
+        res:=asmsymtypes.Find(@sym,sizeof(sym));
+        { we must have a def for every used asmsym }
+        if not assigned(res) or
+           not assigned(res^.data) then
+          internalerror(2015042701);
+        result:=tdef(res^.Data);
+      end;
+
+
+    function TLLVMTypeInfo.record_def(def:tdef): tdef;
+      begin
+        result:=def;
+        if def.dbg_state<>dbg_state_unused then
+          exit;
+        def.dbg_state:=dbg_state_used;
+        deftowritelist.Add(def);
+        defnumberlist.Add(def);
+      end;
+
+
+    constructor TLLVMTypeInfo.Create;
+      begin
+        inherited Create;
+        asmsymtypes:=THashSet.Create(current_asmdata.AsmSymbolDict.Count,true,false);
+      end;
+
+
+    destructor TLLVMTypeInfo.Destroy;
+      begin
+        asmsymtypes.free;
+        inherited destroy;
+      end;
+
+
+    procedure TLLVMTypeInfo.enum_membersyms_callback(p:TObject; arg: pointer);
+      begin
+        case tsym(p).typ of
+          fieldvarsym:
+            appendsym_fieldvar(TAsmList(arg),tfieldvarsym(p));
+        end;
+      end;
+
+
+    procedure TLLVMTypeInfo.collect_llvmins_info(deftypelist: tasmlist; p: taillvm);
+      var
+        opidx, paraidx: longint;
+        callpara: pllvmcallpara;
+      begin
+        for opidx:=0 to p.ops-1 do
+          case p.oper[opidx]^.typ of
+            top_def:
+              appenddef(deftypelist,p.oper[opidx]^.def);
+            top_tai:
+              collect_tai_info(deftypelist,p.oper[opidx]^.ai);
+            top_ref:
+              begin
+                if (p.llvmopcode<>la_br) and
+                   assigned(p.oper[opidx]^.ref^.symbol) and
+                   (p.oper[opidx]^.ref^.symbol.bind<>AB_TEMP) then
+                  begin
+                    if (opidx=3) and
+                       (p.llvmopcode=la_call) then
+                      record_asmsym_def(p.oper[opidx]^.ref^.symbol,tpointerdef(p.oper[0]^.def).pointeddef,false)
+                    { not a named register }
+                    else if (p.oper[opidx]^.ref^.refaddr<>addr_full) then
+                      record_asmsym_def(p.oper[opidx]^.ref^.symbol,p.spilling_get_reg_type(opidx),false);
+                  end;
+              end;
+            top_para:
+              for paraidx:=0 to p.oper[opidx]^.paras.count-1 do
+                begin
+                  callpara:=pllvmcallpara(p.oper[opidx]^.paras[paraidx]);
+                  appenddef(deftypelist,callpara^.def);
+                end;
+          end;
+      end;
+
+
+    procedure TLLVMTypeInfo.collect_tai_info(deftypelist: tasmlist; p: tai);
+      begin
+        case p.typ of
+          ait_llvmalias:
+            begin
+              appenddef(deftypelist,taillvmalias(p).def);
+              record_asmsym_def(taillvmalias(p).newsym,taillvmalias(p).def,true);
+            end;
+          ait_llvmdecl:
+            begin
+              appenddef(deftypelist,taillvmdecl(p).def);
+              record_asmsym_def(taillvmdecl(p).namesym,taillvmdecl(p).def,true);
+              collect_asmlist_info(deftypelist,taillvmdecl(p).initdata);
+            end;
+          ait_llvmins:
+            collect_llvmins_info(deftypelist,taillvm(p));
+          ait_typedconst:
+            appenddef(deftypelist,tai_abstracttypedconst(p).def);
+        end;
+      end;
+
+
+    procedure TLLVMTypeInfo.collect_asmlist_info(deftypelist, asmlist: tasmlist);
+      var
+        hp: tai;
+      begin
+        if not assigned(asmlist) then
+          exit;
+        hp:=tai(asmlist.first);
+        while assigned(hp) do
+          begin
+            collect_tai_info(deftypelist,hp);
+            hp:=tai(hp.next);
+          end;
+      end;
+
+
+    function equal_llvm_defs(def1, def2: tdef): boolean;
+      var
+        def1str, def2str: TSymStr;
+      begin
+        if def1=def2 then
+          exit(true);
+        def1str:=llvmencodetypename(def1);
+        def2str:=llvmencodetypename(def2);
+        { normalise both type representations in case one is a procdef
+          and the other is a procvardef}
+        if def1.typ=procdef then
+          def1str:=def1str+'*';
+        if def2.typ=procdef then
+          def2str:=def2str+'*';
+        result:=def1str=def2str;
+      end;
+
+
+    procedure TLLVMTypeInfo.insert_llvmins_typeconversions(toplevellist: tasmlist; p: taillvm);
+      var
+        symdef,
+        opdef,
+        opcmpdef: tdef;
+        cnv: taillvm;
+        i: longint;
+      begin
+        case p.llvmopcode of
+          la_call:
+            if p.oper[3]^.typ=top_ref then
+              begin
+                maybe_insert_extern_sym_decl(toplevellist,p.oper[3]^.ref^.symbol,tpointerdef(p.oper[0]^.def).pointeddef);
+                symdef:=get_asmsym_def(p.oper[3]^.ref^.symbol);
+                { the type used in the call is different from the type used to
+                  declare the symbol -> insert a typecast }
+                if not equal_llvm_defs(symdef,p.oper[0]^.def) then
+                  begin
+                    if symdef.typ=procdef then
+                      { ugly, but can't use getcopyas(procvardef) due to the
+                        symtablestack not being available here (cpointerdef.getreusable
+                        is hardcoded to put things in the current module's
+                        symtable) and "pointer to procedure" results in the
+                        correct llvm type }
+                      symdef:=cpointerdef.getreusable(tprocdef(symdef));
+                    cnv:=taillvm.op_reg_size_sym_size(la_bitcast,NR_NO,symdef,p.oper[3]^.ref^.symbol,p.oper[0]^.def);
+                    p.loadtai(3,cnv);
+                  end;
+              end;
+          else if p.llvmopcode<>la_br then
+            begin
+              { check the types of all symbolic operands }
+              for i:=0 to p.ops-1 do
+                case p.oper[i]^.typ of
+                  top_ref:
+                    if (p.oper[i]^.ref^.refaddr<>addr_full) and
+                       assigned(p.oper[i]^.ref^.symbol) and
+                       (p.oper[i]^.ref^.symbol.bind<>AB_TEMP) then
+                      begin
+                        opdef:=p.spilling_get_reg_type(i);
+                        case opdef.typ of
+                          pointerdef:
+                            opcmpdef:=tpointerdef(opdef).pointeddef;
+                          procvardef,
+                          procdef:
+                            opcmpdef:=opdef;
+                          else
+                            internalerror(2015073101);
+                        end;
+                        maybe_insert_extern_sym_decl(toplevellist,p.oper[i]^.ref^.symbol,opcmpdef);
+                        symdef:=get_asmsym_def(p.oper[i]^.ref^.symbol);
+                        if not equal_llvm_defs(symdef,opcmpdef) then
+                          begin
+                            if symdef.typ=procdef then
+                              symdef:=cpointerdef.getreusable(symdef);
+                            cnv:=taillvm.op_reg_size_sym_size(la_bitcast,NR_NO,cpointerdef.getreusable(symdef),p.oper[i]^.ref^.symbol,opdef);
+                            p.loadtai(i,cnv);
+                          end;
+                      end;
+                  top_tai:
+                    insert_tai_typeconversions(toplevellist,p.oper[i]^.ai);
+                end;
+            end;
+        end;
+      end;
+
+
+    procedure TLLVMTypeInfo.insert_typedconst_typeconversion(toplevellist: tasmlist; p: tai_abstracttypedconst);
+      var
+        symdef: tdef;
+        cnv: taillvm;
+        elementp: tai_abstracttypedconst;
+      begin
+        case p.adetyp of
+          tck_simple:
+            begin
+              case tai_simpletypedconst(p).val.typ of
+                ait_const:
+                  if assigned(tai_const(tai_simpletypedconst(p).val).sym) and
+                     not assigned(tai_const(tai_simpletypedconst(p).val).endsym) then
+                    begin
+                      maybe_insert_extern_sym_decl(toplevellist,tai_const(tai_simpletypedconst(p).val).sym,p.def);
+                      symdef:=get_asmsym_def(tai_const(tai_simpletypedconst(p).val).sym);
+                      { all references to symbols in typed constants are
+                        references to the address of a global symbol (you can't
+                        refer to the data itself, just like you can't initialise
+                        a Pascal (typed) constant with the contents of another
+                        typed constant) }
+                      symdef:=cpointerdef.getreusable(symdef);
+                      if not equal_llvm_defs(symdef,p.def) then
+                        begin
+                          cnv:=taillvm.op_reg_tai_size(la_bitcast,NR_NO,tai_simpletypedconst.create(tck_simple,symdef,tai_simpletypedconst(p).val),p.def);
+                          tai_simpletypedconst(p).val:=cnv;
+                        end;
+                    end;
+                else
+                  insert_tai_typeconversions(toplevellist,tai_simpletypedconst(p).val);
+              end;
+            end;
+          tck_array,
+          tck_record:
+            begin
+              for elementp in tai_aggregatetypedconst(p) do
+                insert_typedconst_typeconversion(toplevellist,elementp);
+            end;
+        end;
+      end;
+
+
+    procedure TLLVMTypeInfo.insert_tai_typeconversions(toplevellist: tasmlist; p: tai);
+      begin
+        case p.typ of
+          ait_llvmins:
+            insert_llvmins_typeconversions(toplevellist,taillvm(p));
+          { can also be necessary in case someone initialises a typed const with
+            the address of an external symbol aliasing one declared with a
+            different type in the same mmodule. }
+          ait_typedconst:
+            insert_typedconst_typeconversion(toplevellist,tai_abstracttypedconst(p));
+          ait_llvmdecl:
+            insert_asmlist_typeconversions(toplevellist,taillvmdecl(p).initdata);
+        end;
+      end;
+
+
+    procedure TLLVMTypeInfo.insert_asmlist_typeconversions(toplevellist, list: tasmlist);
+      var
+        hp: tai;
+      begin
+        if not assigned(list) then
+          exit;
+        hp:=tai(list.first);
+        while assigned(hp) do
+          begin
+            insert_tai_typeconversions(toplevellist,hp);
+            hp:=tai(hp.next);
+          end;
+      end;
+
+
+    procedure TLLVMTypeInfo.maybe_insert_extern_sym_decl(toplevellist: tasmlist; sym: tasmsymbol; def: tdef);
+      var
+        sec: tasmsectiontype;
+      begin
+        { Necessery for "external" declarations for symbols not declared in the
+          current unit. We can't create these declarations when the alias is
+          initially generated, because the symbol may still be defined later at
+          that point.
+
+          We also do it for all other external symbol references (e.g.
+          references to symbols declared in other units), because then this
+          handling is centralised in one place. }
+        if not(sym.declared) then
+          begin
+            if def.typ=procdef then
+              sec:=sec_code
+            else
+              sec:=sec_data;
+            toplevellist.Concat(taillvmdecl.create(sym,def,nil,sec,def.alignment));
+            record_asmsym_def(sym,def,true);
+          end;
+      end;
+
+
+    procedure TLLVMTypeInfo.update_asmlist_alias_types(list: tasmlist);
+      var
+        hp: tai;
+        def: tdef;
+      begin
+        if not assigned(list) then
+          exit;
+        hp:=tai(list.first);
+        while assigned(hp) do
+          begin
+            case hp.typ of
+              ait_llvmalias:
+                begin
+                  { replace the def of the alias declaration with the def of
+                    the aliased symbol -> we'll insert the appropriate type
+                    conversions for all uses of this symbol in the code (since
+                    every use also specifies the used type) }
+                  record_asmsym_def(taillvmalias(hp).oldsym,taillvmalias(hp).def,false);
+                  def:=get_asmsym_def(taillvmalias(hp).oldsym);
+                  if taillvmalias(hp).def<>def then
+                    begin
+                      taillvmalias(hp).def:=def;
+                      record_asmsym_def(taillvmalias(hp).newsym,def,true);
+                    end;
+                end;
+              ait_llvmdecl:
+                update_asmlist_alias_types(taillvmdecl(hp).initdata);
+            end;
+            hp:=tai(hp.next);
+          end;
+      end;
+
+
+    procedure TLLVMTypeInfo.appenddef_array(list:TAsmList;def:tarraydef);
+      begin
+        appenddef(list,def.elementdef);
+      end;
+
+
+    procedure TLLVMTypeInfo.appenddef_abstractrecord(list:TAsmList;def:tabstractrecorddef);
+      var
+        symdeflist: tfpobjectlist;
+        i: longint;
+      begin
+        symdeflist:=tabstractrecordsymtable(def.symtable).llvmst.symdeflist;
+        for i:=0 to symdeflist.Count-1 do
+          appenddef(list,tllvmshadowsymtableentry(symdeflist[i]).def);
+        if assigned(def.typesym) then
+          list.concat(taillvm.op_size(LA_TYPE,record_def(def)));
+      end;
+
+
+    procedure TLLVMTypeInfo.appenddef_record(list:TAsmList;def:trecorddef);
+      begin
+        appenddef_abstractrecord(list,def);
+      end;
+
+
+    procedure TLLVMTypeInfo.appenddef_pointer(list:TAsmList;def:tpointerdef);
+      begin
+        appenddef(list,def.pointeddef);
+      end;
+
+
+    procedure TLLVMTypeInfo.appenddef_procvar(list:TAsmList;def:tprocvardef);
+      var
+        i: longint;
+      begin
+        { todo: handle mantis #25551; there is no way to create a symbolic
+          la_type for a procvardef (unless it's a procedure of object/record),
+          which means that recursive references should become plain "procedure"
+          types that are then casted to the real type when they are used }
+        for i:=0 to def.paras.count-1 do
+          appenddef(list,tparavarsym(def.paras[i]).vardef);
+        appenddef(list,def.returndef);
+        if assigned(def.typesym) and
+           not def.is_addressonly then
+          list.concat(taillvm.op_size(LA_TYPE,record_def(def)));
+      end;
+
+
+    procedure TLLVMTypeInfo.appendprocdef(list:TAsmList;def:tprocdef);
+      begin
+        { the procdef itself is already written by appendprocdef_implicit }
+      
+        { last write the types from this procdef }
+        if assigned(def.parast) then
+          write_symtable_defs(current_asmdata.asmlists[al_start],def.parast);
+        if assigned(def.localst) and
+           (def.localst.symtabletype=localsymtable) then
+          write_symtable_defs(current_asmdata.asmlists[al_start],def.localst);
+      end;
+
+
+    procedure TLLVMTypeInfo.appendsym_var(list:TAsmList;sym:tabstractnormalvarsym);
+      begin
+        appenddef(list,sym.vardef);
+      end;
+
+
+    procedure TLLVMTypeInfo.appendsym_staticvar(list:TAsmList;sym:tstaticvarsym);
+      begin
+        appendsym_var(list,sym);
+      end;
+
+
+    procedure TLLVMTypeInfo.appendsym_localvar(list:TAsmList;sym:tlocalvarsym);
+      begin
+        appendsym_var(list,sym);
+      end;
+
+
+    procedure TLLVMTypeInfo.appendsym_paravar(list:TAsmList;sym:tparavarsym);
+      begin
+        appendsym_var(list,sym);
+      end;
+
+
+    procedure TLLVMTypeInfo.appendsym_fieldvar(list:TAsmList;sym: tfieldvarsym);
+      begin
+        appenddef(list,sym.vardef);
+      end;
+
+
+    procedure TLLVMTypeInfo.appendsym_const(list:TAsmList;sym:tconstsym);
+      begin
+        appenddef(list,sym.constdef);
+      end;
+
+
+    procedure TLLVMTypeInfo.appendsym_absolute(list:TAsmList;sym:tabsolutevarsym);
+      begin
+        appenddef(list,sym.vardef);
+      end;
+
+
+    procedure TLLVMTypeInfo.inserttypeinfo;
+
+      procedure write_defs_to_write;
+        var
+          n       : integer;
+          looplist,
+          templist: TFPObjectList;
+          def     : tdef;
+        begin
+          templist := TFPObjectList.Create(False);
+          looplist := deftowritelist;
+          while looplist.count > 0 do
+            begin
+              deftowritelist := templist;
+              for n := 0 to looplist.count - 1 do
+                begin
+                  def := tdef(looplist[n]);
+                  case def.dbg_state of
+                    dbg_state_written:
+                      continue;
+                    dbg_state_writing:
+                      internalerror(200610052);
+                    dbg_state_unused:
+                      internalerror(200610053);
+                    dbg_state_used:
+                      appenddef(current_asmdata.asmlists[al_start],def)
+                  else
+                    internalerror(200610054);
+                  end;
+                end;
+              looplist.clear;
+              templist := looplist;
+              looplist := deftowritelist;
+            end;
+          templist.free;
+        end;
+
+
+      var
+        storefilepos: tfileposinfo;
+        def: tdef;
+        i: longint;
+        hal: tasmlisttype;
+      begin
+        storefilepos:=current_filepos;
+        current_filepos:=current_module.mainfilepos;
+
+        defnumberlist:=TFPObjectList.create(false);
+        deftowritelist:=TFPObjectList.create(false);
+
+        { write all global/static variables, part of flaggin all required tdefs  }
+        if assigned(current_module.globalsymtable) then
+          write_symtable_syms(current_asmdata.asmlists[al_start],current_module.globalsymtable);
+        if assigned(current_module.localsymtable) then
+          write_symtable_syms(current_asmdata.asmlists[al_start],current_module.localsymtable);
+
+        { write all procedures and methods, part of flagging all required tdefs }
+        if assigned(current_module.globalsymtable) then
+          write_symtable_procdefs(current_asmdata.asmlists[al_start],current_module.globalsymtable);
+        if assigned(current_module.localsymtable) then
+          write_symtable_procdefs(current_asmdata.asmlists[al_start],current_module.localsymtable);
+
+        { process all llvm instructions, part of flagging all required tdefs }
+        for hal:=low(TasmlistType) to high(TasmlistType) do
+          if hal<>al_start then
+            collect_asmlist_info(current_asmdata.asmlists[al_start],current_asmdata.asmlists[hal]);
+
+        { update the defs of all alias declarations so they match those of the
+          declarations of the symbols they alias }
+        for hal:=low(TasmlistType) to high(TasmlistType) do
+          if hal<>al_start then
+            update_asmlist_alias_types(current_asmdata.asmlists[hal]);
+
+        { and insert the necessary type conversions }
+        for hal:=low(TasmlistType) to high(TasmlistType) do
+          if hal<>al_start then
+            insert_asmlist_typeconversions(
+              current_asmdata.asmlists[hal],
+              current_asmdata.asmlists[hal]);
+
+        { write all used defs }
+        write_defs_to_write;
+
+        { reset all def labels }
+        for i:=0 to defnumberlist.count-1 do
+          begin
+            def := tdef(defnumberlist[i]);
+            if assigned(def) then
+              begin
+                def.dbg_state:=dbg_state_unused;
+              end;
+          end;
+
+        defnumberlist.free;
+        defnumberlist:=nil;
+        deftowritelist.free;
+        deftowritelist:=nil;
+
+        current_filepos:=storefilepos;
+      end;
+
+
+    procedure TLLVMTypeInfo.appenddef_object(list:TAsmList;def: tobjectdef);
+      begin
+        appenddef_abstractrecord(list,def);
+      end;
+
+
+    procedure TLLVMTypeInfo.appenddef_variant(list:TAsmList;def: tvariantdef);
+      begin
+        appenddef(list,tabstractrecorddef(search_system_type('TVARDATA').typedef));
+      end;
+
+
+    procedure TLLVMTypeInfo.appenddef_file(list:TAsmList;def:tfiledef);
+      begin
+        case tfiledef(def).filetyp of
+          ft_text    :
+            appenddef(list,tabstractrecorddef(search_system_type('TEXTREC').typedef));
+          ft_typed,
+          ft_untyped :
+            appenddef(list,tabstractrecorddef(search_system_type('FILEREC').typedef));
+        end;
+      end;
+
+end.

compiler/llvm/nllvmcnv.pas

@@ -169,6 +169,8 @@ procedure tllvmtypeconvnode.second_bool_to_int;
 
 procedure tllvmtypeconvnode.second_int_to_bool;
   var
+    truelabel,
+    falselabel: tasmlabel;
     newsize  : tcgsize;
   begin
     secondpass(left);
@@ -191,17 +193,20 @@ procedure tllvmtypeconvnode.second_int_to_bool;
          exit;
       end;
 
-    location_reset(location,LOC_JUMP,OS_NO);
     case left.location.loc of
       LOC_SUBSETREG,LOC_CSUBSETREG,LOC_SUBSETREF,LOC_CSUBSETREF,
       LOC_CREFERENCE,LOC_REFERENCE,LOC_REGISTER,LOC_CREGISTER:
         begin
-          hlcg.a_cmp_const_loc_label(current_asmdata.CurrAsmList,left.resultdef,OC_EQ,0,left.location,current_procinfo.CurrFalseLabel);
-          hlcg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
+          current_asmdata.getjumplabel(truelabel);
+          current_asmdata.getjumplabel(falselabel);
+          location_reset_jump(location,truelabel,falselabel);
+
+          hlcg.a_cmp_const_loc_label(current_asmdata.CurrAsmList,left.resultdef,OC_EQ,0,left.location,location.falselabel);
+          hlcg.a_jmp_always(current_asmdata.CurrAsmList,location.truelabel);
         end;
       LOC_JUMP :
         begin
-          { nothing to do, jumps already go to the right labels }
+          location:=left.location;
         end;
       else
         internalerror(10062);

compiler/llvm/symllvm.pas

@@ -0,0 +1,182 @@
+{
+    Copyright (c) 2014 by Florian Klaempfl
+
+    Symbol table overrides for LLVM
+
+    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 symllvm;
+
+{$i fpcdefs.inc}
+
+interface
+
+uses
+  globtype,
+  symcpu;
+
+type
+  { defs }
+  tllvmfiledef = class(tcpufiledef)
+  end;
+
+  tllvmvariantdef = class(tcpuvariantdef)
+  end;
+
+  tllvmformaldef = class(tcpuformaldef)
+  end;
+
+  tllvmforwarddef = class(tcpuforwarddef)
+  end;
+
+  tllvmundefineddef = class(tcpuundefineddef)
+  end;
+
+  tllvmerrordef = class(tcpuerrordef)
+  end;
+
+  tllvmpointerdef = class(tcpupointerdef)
+  end;
+
+  tllvmrecorddef = class(tcpurecorddef)
+  end;
+
+  tllvmimplementedinterface = class(tcpuimplementedinterface)
+  end;
+
+  tllvmobjectdef = class(tcpuobjectdef)
+  end;
+
+  tllvmclassrefdef = class(tcpuclassrefdef)
+  end;
+
+  tllvmarraydef = class(tcpuarraydef)
+  end;
+
+  tllvmorddef = class(tcpuorddef)
+  end;
+
+  tllvmfloatdef = class(tcpufloatdef)
+  end;
+
+  tllvmprocvardef = class(tcpuprocvardef)
+  end;
+
+  tllvmprocdef = class(tcpuprocdef)
+  end;
+
+  tllvmstringdef = class(tcpustringdef)
+  end;
+
+  tllvmenumdef = class(tcpuenumdef)
+  end;
+
+  tllvmsetdef = class(tcpusetdef)
+  end;
+
+  { syms }
+  tllvmlabelsym = class(tcpulabelsym)
+  end;
+
+  tllvmunitsym = class(tcpuunitsym)
+  end;
+
+  tllvmprogramparasym = class(tcpuprogramparasym)
+  end;
+
+  tllvmnamespacesym = class(tcpunamespacesym)
+  end;
+
+  tllvmprocsym = class(tcpuprocsym)
+  end;
+
+  tllvmtypesym = class(tcputypesym)
+  end;
+
+  tllvmfieldvarsym = class(tcpufieldvarsym)
+  end;
+
+  tllvmlocalvarsym = class(tcpulocalvarsym)
+  end;
+
+  tllvmparavarsym = class(tcpuparavarsym)
+  end;
+
+  tllvmstaticvarsym = class(tcpustaticvarsym)
+  end;
+
+  tllvmabsolutevarsym = class(tcpuabsolutevarsym)
+  end;
+
+  tllvmpropertysym = class(tcpupropertysym)
+  end;
+
+  tllvmconstsym = class(tcpuconstsym)
+  end;
+
+  tllvmenumsym = class(tcpuenumsym)
+  end;
+
+  tllvmsyssym = class(tcpusyssym)
+  end;
+
+
+implementation
+
+uses
+  symconst,symdef,symsym;
+
+begin
+  { used tdef classes }
+  cfiledef:=tllvmfiledef;
+  cvariantdef:=tllvmvariantdef;
+  cformaldef:=tllvmformaldef;
+  cforwarddef:=tllvmforwarddef;
+  cundefineddef:=tllvmundefineddef;
+  cerrordef:=tllvmerrordef;
+  cpointerdef:=tllvmpointerdef;
+  crecorddef:=tllvmrecorddef;
+  cimplementedinterface:=tllvmimplementedinterface;
+  cobjectdef:=tllvmobjectdef;
+  cclassrefdef:=tllvmclassrefdef;
+  carraydef:=tllvmarraydef;
+  corddef:=tllvmorddef;
+  cfloatdef:=tllvmfloatdef;
+  cprocvardef:=tllvmprocvardef;
+  cprocdef:=tllvmprocdef;
+  cstringdef:=tllvmstringdef;
+  cenumdef:=tllvmenumdef;
+  csetdef:=tllvmsetdef;
+
+  { used tsym classes }
+  clabelsym:=tllvmlabelsym;
+  cunitsym:=tllvmunitsym;
+  cprogramparasym:=tllvmprogramparasym;
+  cnamespacesym:=tllvmnamespacesym;
+  cprocsym:=tllvmprocsym;
+  ctypesym:=tllvmtypesym;
+  cfieldvarsym:=tllvmfieldvarsym;
+  clocalvarsym:=tllvmlocalvarsym;
+  cparavarsym:=tllvmparavarsym;
+  cstaticvarsym:=tllvmstaticvarsym;
+  cabsolutevarsym:=tllvmabsolutevarsym;
+  cpropertysym:=tllvmpropertysym;
+  cconstsym:=tllvmconstsym;
+  cenumsym:=tllvmenumsym;
+  csyssym:=tllvmsyssym;
+end.
+

compiler/m68k/n68kadd.pas

@@ -375,6 +375,8 @@ implementation
 
     procedure t68kaddnode.second_cmp64bit;
       var
+        truelabel,
+        falselabel: tasmlabel;
         hlab: tasmlabel;
         unsigned : boolean;
         href: treference;
@@ -386,12 +388,12 @@ implementation
           case nodetype of
             ltn,gtn:
               begin
-                if (hlab<>current_procinfo.CurrTrueLabel) then
-                  cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),current_procinfo.CurrTrueLabel);
+                if (hlab<>location.truelabel) then
+                  cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),location.truelabel);
                 { cheat a little bit for the negative test }
                 toggleflag(nf_swapped);
-                if (hlab<>current_procinfo.CurrFalseLabel) then
-                  cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),current_procinfo.CurrFalseLabel);
+                if (hlab<>location.falselabel) then
+                  cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),location.falselabel);
                 toggleflag(nf_swapped);
               end;
             lten,gten:
@@ -401,21 +403,21 @@ implementation
                   nodetype:=ltn
                 else
                   nodetype:=gtn;
-                if (hlab<>current_procinfo.CurrTrueLabel) then
-                  cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),current_procinfo.CurrTrueLabel);
+                if (hlab<>location.truelabel) then
+                  cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),location.truelabel);
                 { cheat for the negative test }
                 if nodetype=ltn then
                   nodetype:=gtn
                 else
                   nodetype:=ltn;
-                if (hlab<>current_procinfo.CurrFalseLabel) then
-                  cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),current_procinfo.CurrFalseLabel);
+                if (hlab<>location.falselabel) then
+                  cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),location.falselabel);
                 nodetype:=oldnodetype;
               end;
             equaln:
-              cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,current_procinfo.CurrFalseLabel);
+              cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,location.falselabel);
             unequaln:
-              cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,current_procinfo.CurrTrueLabel);
+              cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,location.truelabel);
           end;
         end;
 
@@ -424,30 +426,34 @@ implementation
           case nodetype of
             ltn,gtn,lten,gten:
               begin
-                cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(true),current_procinfo.CurrTrueLabel);
-                cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+                cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(true),location.truelabel);
+                cg.a_jmp_always(current_asmdata.CurrAsmList,location.falselabel);
               end;
             equaln:
               begin
-                cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,current_procinfo.CurrFalseLabel);
-                cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
+                cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,location.falselabel);
+                cg.a_jmp_always(current_asmdata.CurrAsmList,location.truelabel);
               end;
             unequaln:
               begin
-                cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,current_procinfo.CurrTrueLabel);
-                cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+                cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,location.truelabel);
+                cg.a_jmp_always(current_asmdata.CurrAsmList,location.falselabel);
               end;
           end;
         end;
 
       begin
+        truelabel:=nil;
+        falselabel:=nil;
         { This puts constant operand (if any) to the right }
         pass_left_right;
 
         unsigned:=not(is_signed(left.resultdef)) or
                   not(is_signed(right.resultdef));
 
-        location_reset(location,LOC_JUMP,OS_NO);
+        current_asmdata.getjumplabel(truelabel);
+        current_asmdata.getjumplabel(falselabel);
+        location_reset_jump(location,truelabel,falselabel);
 
         { Relational compares against constants having low dword=0 can omit the
           second compare based on the fact that any unsigned value is >=0 }
@@ -456,8 +462,8 @@ implementation
            (lo(right.location.value64)=0) then
           begin
             case getresflags(true) of
-              F_AE: hlab:=current_procinfo.CurrTrueLabel;
-              F_B:  hlab:=current_procinfo.CurrFalseLabel;
+              F_AE: hlab:=location.truelabel;
+              F_B:  hlab:=location.falselabel;
             end;
           end;
 

compiler/m68k/n68kcnv.pas

@@ -165,16 +165,9 @@ implementation
         resflags : tresflags;
         opsize   : tcgsize;
         newsize  : tcgsize;
-        hlabel,
-        oldTrueLabel,
-        oldFalseLabel : tasmlabel;
+        hlabel   : tasmlabel;
         tmpreference : treference;
       begin
-         oldTrueLabel:=current_procinfo.CurrTrueLabel;
-         oldFalseLabel:=current_procinfo.CurrFalseLabel;
-         current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
-         current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
-
          secondpass(left);
 
          { Explicit typecasts from any ordinal type to a boolean type }
@@ -190,8 +183,6 @@ implementation
                 hlcg.location_force_reg(current_asmdata.CurrAsmList,location,left.resultdef,resultdef,true)
               else
                 location.size:=newsize;
-              current_procinfo.CurrTrueLabel:=oldTrueLabel;
-              current_procinfo.CurrFalseLabel:=oldFalseLabel;
               exit;
            end;
 
@@ -266,13 +257,13 @@ implementation
                 location_reset(location,LOC_REGISTER,newsize);
                 location.register:=cg.getintregister(current_asmdata.CurrAsmList,location.size);
                 current_asmdata.getjumplabel(hlabel);
-                cg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
+                cg.a_label(current_asmdata.CurrAsmList,left.location.truelabel);
                 if not(is_cbool(resultdef)) then
                   cg.a_load_const_reg(current_asmdata.CurrAsmList,location.size,1,location.register)
                 else
                   cg.a_load_const_reg(current_asmdata.CurrAsmList,location.size,-1,location.register);
                 cg.a_jmp_always(current_asmdata.CurrAsmList,hlabel);
-                cg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+                cg.a_label(current_asmdata.CurrAsmList,left.location.falselabel);
                 cg.a_load_const_reg(current_asmdata.CurrAsmList,location.size,0,location.register);
                 cg.a_label(current_asmdata.CurrAsmList,hlabel);
               end;
@@ -305,8 +296,6 @@ implementation
                   cg.a_op_reg_reg(current_asmdata.CurrAsmList,OP_NEG,newsize,location.register,location.register);
               end
            end;
-         current_procinfo.CurrTrueLabel:=oldTrueLabel;
-         current_procinfo.CurrFalseLabel:=oldFalseLabel;
       end;
 
 

compiler/mips/ncpuadd.pas

@@ -108,28 +108,33 @@ const
 
 procedure tmipsaddnode.cmp64_lt(left_reg, right_reg: TRegister64;unsigned: boolean);
 begin
-  cg.a_cmp_reg_reg_label(current_asmdata.CurrAsmList,OS_INT,cmpops[unsigned],right_reg.reghi,left_reg.reghi,current_procinfo.CurrTrueLabel);
-  cg.a_cmp_reg_reg_label(current_asmdata.CurrAsmList,OS_INT,OC_NE,left_reg.reghi,right_reg.reghi,current_procinfo.CurrFalseLabel);
-  cg.a_cmp_reg_reg_label(current_asmdata.CurrAsmList,OS_INT,OC_B,right_reg.reglo,left_reg.reglo,current_procinfo.CurrTrueLabel);
-  cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+  cg.a_cmp_reg_reg_label(current_asmdata.CurrAsmList,OS_INT,cmpops[unsigned],right_reg.reghi,left_reg.reghi,location.truelabel);
+  cg.a_cmp_reg_reg_label(current_asmdata.CurrAsmList,OS_INT,OC_NE,left_reg.reghi,right_reg.reghi,location.falselabel);
+  cg.a_cmp_reg_reg_label(current_asmdata.CurrAsmList,OS_INT,OC_B,right_reg.reglo,left_reg.reglo,location.truelabel);
+  cg.a_jmp_always(current_asmdata.CurrAsmList,location.falselabel);
 end;
 
 
 procedure tmipsaddnode.cmp64_le(left_reg, right_reg: TRegister64;unsigned: boolean);
 begin
-  cg.a_cmp_reg_reg_label(current_asmdata.CurrAsmList,OS_INT,cmpops[unsigned],left_reg.reghi,right_reg.reghi,current_procinfo.CurrFalseLabel);
-  cg.a_cmp_reg_reg_label(current_asmdata.CurrAsmList,OS_INT,OC_NE,left_reg.reghi,right_reg.reghi,current_procinfo.CurrTrueLabel);
-  cg.a_cmp_reg_reg_label(current_asmdata.CurrAsmList,OS_INT,OC_B,left_reg.reglo,right_reg.reglo,current_procinfo.CurrFalseLabel);
-  cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
+  cg.a_cmp_reg_reg_label(current_asmdata.CurrAsmList,OS_INT,cmpops[unsigned],left_reg.reghi,right_reg.reghi,location.falselabel);
+  cg.a_cmp_reg_reg_label(current_asmdata.CurrAsmList,OS_INT,OC_NE,left_reg.reghi,right_reg.reghi,location.truelabel);
+  cg.a_cmp_reg_reg_label(current_asmdata.CurrAsmList,OS_INT,OC_B,left_reg.reglo,right_reg.reglo,location.falselabel);
+  cg.a_jmp_always(current_asmdata.CurrAsmList,location.truelabel);
 end;
 
 
 procedure tmipsaddnode.second_cmp64bit;
 var
+  truelabel,
+  falselabel: tasmlabel;
   unsigned: boolean;
   left_reg,right_reg: TRegister64;
 begin
-  location_reset(location, LOC_JUMP, OS_NO);
+  current_asmdata.getjumplabel(truelabel);
+  current_asmdata.getjumplabel(falselabel);
+  location_reset_jump(location,truelabel,falselabel);
+
   pass_left_right;
   force_reg_left_right(true,true);
 
@@ -160,15 +165,15 @@ begin
   case NodeType of
     equaln:
       begin
-        cg.a_cmp_reg_reg_label(current_asmdata.CurrAsmList,OS_INT,OC_NE,left_reg.reghi,right_reg.reghi,current_procinfo.CurrFalseLabel);
-        cg.a_cmp_reg_reg_label(current_asmdata.CurrAsmList,OS_INT,OC_NE,left_reg.reglo,right_reg.reglo,current_procinfo.CurrFalseLabel);
-        cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
+        cg.a_cmp_reg_reg_label(current_asmdata.CurrAsmList,OS_INT,OC_NE,left_reg.reghi,right_reg.reghi,location.falselabel);
+        cg.a_cmp_reg_reg_label(current_asmdata.CurrAsmList,OS_INT,OC_NE,left_reg.reglo,right_reg.reglo,location.falselabel);
+        cg.a_jmp_always(current_asmdata.CurrAsmList,location.truelabel);
       end;
     unequaln:
       begin
-        cg.a_cmp_reg_reg_label(current_asmdata.CurrAsmList,OS_INT,OC_NE,left_reg.reghi,right_reg.reghi,current_procinfo.CurrTrueLabel);
-        cg.a_cmp_reg_reg_label(current_asmdata.CurrAsmList,OS_INT,OC_NE,left_reg.reglo,right_reg.reglo,current_procinfo.CurrTrueLabel);
-        cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+        cg.a_cmp_reg_reg_label(current_asmdata.CurrAsmList,OS_INT,OC_NE,left_reg.reghi,right_reg.reghi,location.truelabel);
+        cg.a_cmp_reg_reg_label(current_asmdata.CurrAsmList,OS_INT,OC_NE,left_reg.reglo,right_reg.reglo,location.truelabel);
+        cg.a_jmp_always(current_asmdata.CurrAsmList,location.falselabel);
       end;
   else
     if nf_swapped in flags then

compiler/mips/ncpucnv.pas

@@ -195,14 +195,10 @@ procedure tMIPSELtypeconvnode.second_int_to_bool;
 var
   hreg1, hreg2: tregister;
   opsize: tcgsize;
-  hlabel, oldtruelabel, oldfalselabel: tasmlabel;
+  hlabel: tasmlabel;
   newsize  : tcgsize;
   href: treference;
 begin
-  oldtruelabel  := current_procinfo.CurrTrueLabel;
-  oldfalselabel := current_procinfo.CurrFalseLabel;
-  current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
-  current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
   secondpass(left);
   if codegenerror then
     exit;
@@ -220,8 +216,6 @@ begin
          hlcg.location_force_reg(current_asmdata.CurrAsmList,location,left.resultdef,resultdef,true)
        else
          location.size:=newsize;
-       current_procinfo.CurrTrueLabel:=oldTrueLabel;
-       current_procinfo.CurrFalseLabel:=oldFalseLabel;
        exit;
     end;
 
@@ -271,10 +265,10 @@ begin
     begin
       hreg1 := cg.getintregister(current_asmdata.CurrAsmList, OS_INT);
       current_asmdata.getjumplabel(hlabel);
-      cg.a_label(current_asmdata.CurrAsmList, current_procinfo.CurrTrueLabel);
+      cg.a_label(current_asmdata.CurrAsmList, left.location.truelabel);
       cg.a_load_const_reg(current_asmdata.CurrAsmList, OS_INT, 1, hreg1);
       cg.a_jmp_always(current_asmdata.CurrAsmList, hlabel);
-      cg.a_label(current_asmdata.CurrAsmList, current_procinfo.CurrFalseLabel);
+      cg.a_label(current_asmdata.CurrAsmList, left.location.falselabel);
       cg.a_load_const_reg(current_asmdata.CurrAsmList, OS_INT, 0, hreg1);
       cg.a_label(current_asmdata.CurrAsmList, hlabel);
     end;
@@ -305,10 +299,6 @@ begin
        else
 {$endif not cpu64bitalu}
          location.Register := hreg1;
-
-
-  current_procinfo.CurrTrueLabel  := oldtruelabel;
-  current_procinfo.CurrFalseLabel := oldfalselabel;
 end;
 
 

compiler/msg/errore.msg

@@ -2210,7 +2210,7 @@ sym_w_experimental_unit=05079_W_Unit "$1" is experimental
 % declared as \var{experimental} is used. Experimental units
 % might disappear or change semantics in future versions. Usage of this unit
 % should be avoided as much as possible.
-sym_e_formal_class_not_resolved=05080_E_No complete definition of the formally declared class "$1" is in scope
+sym_e_formal_class_not_resolved=05080_E_No full definition of the formally declared class "$1" is in scope. Add the unit containing its full definition to the uses clause.
 % Objecive-C and Java classes can be imported formally, without using the unit in which it is fully declared.
 % This enables making forward references to such classes and breaking circular dependencies amongst units.
 % However, as soon as you wish to actually do something with an entity of this class type (such as

compiler/msgidx.inc

@@ -1017,7 +1017,7 @@ const
   option_info=11024;
   option_help_pages=11025;
 
-  MsgTxtSize = 75822;
+  MsgTxtSize = 75883;
 
   MsgIdxMax : array[1..20] of longint=(
     26,99,342,124,96,58,127,32,207,64,

compiler/ncgadd.pas

@@ -89,14 +89,9 @@ interface
       var
         tmpreg     : tregister;
 {$ifdef x86}
-        pushedfpu,
+        pushedfpu  : boolean;
 {$endif x86}
-        isjump     : boolean;
-        otl,ofl    : tasmlabel;
       begin
-        otl:=nil;
-        ofl:=nil;
-
         { calculate the operator which is more difficult }
         firstcomplex(self);
 
@@ -104,26 +99,9 @@ interface
         if (left.nodetype=ordconstn) then
           swapleftright;
 
-        isjump:=(left.expectloc=LOC_JUMP);
-        if isjump then
-          begin
-             otl:=current_procinfo.CurrTrueLabel;
-             current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
-             ofl:=current_procinfo.CurrFalseLabel;
-             current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
-          end;
         secondpass(left);
         if left.location.loc in [LOC_FLAGS,LOC_JUMP] then
           hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,resultdef,false);
-        if isjump then
-          begin
-            current_procinfo.CurrTrueLabel:=otl;
-            current_procinfo.CurrFalseLabel:=ofl;
-          end
-        else
-          if left.location.loc=LOC_JUMP then
-            internalerror(2012081302);
-
 {$ifdef x86}
         { are too few registers free? }
         pushedfpu:=false;
@@ -135,22 +113,9 @@ interface
           end;
 {$endif x86}
 
-        isjump:=(right.expectloc=LOC_JUMP);
-        if isjump then
-          begin
-             otl:=current_procinfo.CurrTrueLabel;
-             current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
-             ofl:=current_procinfo.CurrFalseLabel;
-             current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
-          end;
         secondpass(right);
         if right.location.loc in [LOC_FLAGS,LOC_JUMP] then
           hlcg.location_force_reg(current_asmdata.CurrAsmList,right.location,right.resultdef,resultdef,false);
-        if isjump then
-          begin
-            current_procinfo.CurrTrueLabel:=otl;
-            current_procinfo.CurrFalseLabel:=ofl;
-          end;
 {$ifdef x86}
         if pushedfpu then
           begin
@@ -414,7 +379,7 @@ interface
     procedure tcgaddnode.second_addboolean;
       var
         cgop    : TOpCg;
-        otl,ofl : tasmlabel;
+        truelabel, falselabel : tasmlabel;
         oldflowcontrol : tflowcontrol;
       begin
         { And,Or will only evaluate from left to right only the
@@ -423,25 +388,22 @@ interface
            (not(cs_full_boolean_eval in current_settings.localswitches) or
             (nf_short_bool in flags)) then
           begin
-            location_reset(location,LOC_JUMP,OS_NO);
             case nodetype of
               andn :
                 begin
-                   otl:=current_procinfo.CurrTrueLabel;
-                   current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
                    secondpass(left);
                    hlcg.maketojumpbool(current_asmdata.CurrAsmList,left);
-                   hlcg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
-                   current_procinfo.CurrTrueLabel:=otl;
+                   hlcg.a_label(current_asmdata.CurrAsmList,left.location.truelabel);
+                   current_asmdata.getjumplabel(truelabel);
+                   location_reset_jump(location,truelabel,left.location.falselabel);
                 end;
               orn :
                 begin
-                   ofl:=current_procinfo.CurrFalseLabel;
-                   current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
                    secondpass(left);
                    hlcg.maketojumpbool(current_asmdata.CurrAsmList,left);
-                   hlcg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
-                   current_procinfo.CurrFalseLabel:=ofl;
+                   hlcg.a_label(current_asmdata.CurrAsmList,left.location.falselabel);
+                   current_asmdata.getjumplabel(falselabel);
+                   location_reset_jump(location,left.location.truelabel,falselabel);
                 end;
               else
                 internalerror(200307044);
@@ -451,7 +413,9 @@ interface
             include(flowcontrol,fc_inflowcontrol);
 
             secondpass(right);
-            hlcg.maketojumpbool(current_asmdata.CurrAsmList,right);
+            { jump to the same labels as the left side, since the andn/orn
+              merges the results of left and right }
+            hlcg.maketojumpboollabels(current_asmdata.CurrAsmList,right,location.truelabel,location.falselabel);
 
             flowcontrol:=oldflowcontrol+(flowcontrol-[fc_inflowcontrol]);
           end

compiler/ncgcal.pas

@@ -262,8 +262,6 @@ implementation
     procedure tcgcallparanode.secondcallparan;
       var
          href    : treference;
-         otlabel,
-         oflabel : tasmlabel;
          pushaddr: boolean;
       begin
          if not(assigned(parasym)) then
@@ -273,10 +271,6 @@ implementation
            a parameter }
          if (left.nodetype<>nothingn) then
            begin
-             otlabel:=current_procinfo.CurrTrueLabel;
-             oflabel:=current_procinfo.CurrFalseLabel;
-             current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
-             current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
              if assigned(fparainit) then
                secondpass(fparainit);
              secondpass(left);
@@ -373,8 +367,6 @@ implementation
                  else
                    push_value_para;
                end;
-             current_procinfo.CurrTrueLabel:=otlabel;
-             current_procinfo.CurrFalseLabel:=oflabel;
 
              { update return location in callnode when this is the function
                result }

compiler/ncgcnv.pas

@@ -160,13 +160,9 @@ interface
         hregister : tregister;
         href      : treference;
         resflags  : tresflags;
-        hlabel,oldTrueLabel,oldFalseLabel : tasmlabel;
+        hlabel    : tasmlabel;
         newsize   : tcgsize;
       begin
-        oldTrueLabel:=current_procinfo.CurrTrueLabel;
-        oldFalseLabel:=current_procinfo.CurrFalseLabel;
-        current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
-        current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
         secondpass(left);
         if codegenerror then
          exit;
@@ -189,8 +185,6 @@ interface
                hlcg.location_force_reg(current_asmdata.CurrAsmList,location,left.resultdef,resultdef,true)
              else
                location.size:=newsize;
-             current_procinfo.CurrTrueLabel:=oldTrueLabel;
-             current_procinfo.CurrFalseLabel:=oldFalseLabel;
              exit;
           end;
         { though ppc/ppc64 doesn't use the generic code, we need to ifdef here
@@ -247,10 +241,10 @@ interface
             begin
               hregister:=cg.getintregister(current_asmdata.CurrAsmList,OS_INT);
               current_asmdata.getjumplabel(hlabel);
-              cg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
+              cg.a_label(current_asmdata.CurrAsmList,left.location.truelabel);
               cg.a_load_const_reg(current_asmdata.CurrAsmList,OS_INT,1,hregister);
               cg.a_jmp_always(current_asmdata.CurrAsmList,hlabel);
-              cg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+              cg.a_label(current_asmdata.CurrAsmList,left.location.falselabel);
               cg.a_load_const_reg(current_asmdata.CurrAsmList,OS_INT,0,hregister);
               cg.a_label(current_asmdata.CurrAsmList,hlabel);
               cg.a_op_reg_reg(current_asmdata.CurrAsmList,OP_OR,OS_INT,hregister,hregister);
@@ -265,8 +259,6 @@ interface
         cg.a_reg_dealloc(current_asmdata.CurrAsmList,NR_DEFAULTFLAGS);
         if (is_cbool(resultdef)) then
           cg.a_op_reg_reg(current_asmdata.CurrAsmList,OP_NEG,location.size,location.register,location.register);
-        current_procinfo.CurrTrueLabel:=oldTrueLabel;
-        current_procinfo.CurrFalseLabel:=oldFalseLabel;
       end;
 {$endif cpuflags}
 
@@ -609,12 +601,7 @@ interface
     procedure tcgtypeconvnode.second_bool_to_int;
       var
          newsize: tcgsize;
-         oldTrueLabel,oldFalseLabel : tasmlabel;
       begin
-         oldTrueLabel:=current_procinfo.CurrTrueLabel;
-         oldFalseLabel:=current_procinfo.CurrFalseLabel;
-         current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
-         current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
          secondpass(left);
          location_copy(location,left.location);
          newsize:=def_cgsize(resultdef);
@@ -637,8 +624,6 @@ interface
          else
            { may differ in sign, e.g. bytebool -> byte   }
            location.size:=newsize;
-         current_procinfo.CurrTrueLabel:=oldTrueLabel;
-         current_procinfo.CurrFalseLabel:=oldFalseLabel;
       end;
 
 

compiler/ncgflw.pas

@@ -134,7 +134,7 @@ implementation
       var
          lcont,lbreak,lloop,
          oldclabel,oldblabel : tasmlabel;
-         otlabel,oflabel : tasmlabel;
+         truelabel,falselabel : tasmlabel;
          oldflowcontrol : tflowcontrol;
          oldexecutionweight : longint;
       begin
@@ -181,28 +181,23 @@ implementation
 {$endif OLDREGVARS}
 
          hlcg.a_label(current_asmdata.CurrAsmList,lcont);
-         otlabel:=current_procinfo.CurrTrueLabel;
-         oflabel:=current_procinfo.CurrFalseLabel;
          if lnf_checknegate in loopflags then
-          begin
-            current_procinfo.CurrTrueLabel:=lbreak;
-            current_procinfo.CurrFalseLabel:=lloop;
-          end
+           begin
+             truelabel:=lbreak;
+             falselabel:=lloop;
+           end
          else
-          begin
-            current_procinfo.CurrTrueLabel:=lloop;
-            current_procinfo.CurrFalseLabel:=lbreak;
-          end;
+           begin
+             truelabel:=lloop;
+             falselabel:=lbreak;
+           end;
          secondpass(left);
 
-         hlcg.maketojumpbool(current_asmdata.CurrAsmList,left);
+         hlcg.maketojumpboollabels(current_asmdata.CurrAsmList,left,truelabel,falselabel);
          hlcg.a_label(current_asmdata.CurrAsmList,lbreak);
 
          sync_regvars(false);
 
-         current_procinfo.CurrTrueLabel:=otlabel;
-         current_procinfo.CurrFalseLabel:=oflabel;
-
          current_procinfo.CurrContinueLabel:=oldclabel;
          current_procinfo.CurrBreakLabel:=oldblabel;
          { a break/continue in a while/repeat block can't be seen outside }
@@ -217,7 +212,7 @@ implementation
     procedure tcgifnode.pass_generate_code;
 
       var
-         hl,otlabel,oflabel : tasmlabel;
+         hl : tasmlabel;
          oldflowcontrol: tflowcontrol;
          oldexecutionweight : longint;
 (*
@@ -238,10 +233,6 @@ implementation
 
          oldflowcontrol := flowcontrol;
          include(flowcontrol,fc_inflowcontrol);
-         otlabel:=current_procinfo.CurrTrueLabel;
-         oflabel:=current_procinfo.CurrFalseLabel;
-         current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
-         current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
          secondpass(left);
 
 (*
@@ -270,7 +261,7 @@ implementation
 
          if assigned(right) then
            begin
-              hlcg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
+              hlcg.a_label(current_asmdata.CurrAsmList,left.location.truelabel);
               secondpass(right);
            end;
 
@@ -305,7 +296,7 @@ implementation
                    ;
                    hlcg.a_jmp_always(current_asmdata.CurrAsmList,hl);
                 end;
-              hlcg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+              hlcg.a_label(current_asmdata.CurrAsmList,left.location.falselabel);
               secondpass(t1);
 (*
               { save current asmlist (previous instructions + else-block) }
@@ -332,11 +323,11 @@ implementation
                   current_asmdata.CurrAsmList := TAsmList.create;
                 end;
 *)
-              hlcg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+              hlcg.a_label(current_asmdata.CurrAsmList,left.location.falselabel);
            end;
          if not(assigned(right)) then
            begin
-              hlcg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
+              hlcg.a_label(current_asmdata.CurrAsmList,left.location.truelabel);
            end;
 
 (*
@@ -376,8 +367,6 @@ implementation
 
          cg.executionweight:=oldexecutionweight;
 
-         current_procinfo.CurrTrueLabel:=otlabel;
-         current_procinfo.CurrFalseLabel:=oflabel;
          flowcontrol := oldflowcontrol + (flowcontrol - [fc_inflowcontrol]);
       end;
 
@@ -423,8 +412,7 @@ implementation
 
     procedure tcgfornode.pass_generate_code;
       var
-         l3,oldclabel,oldblabel,
-         otl, ofl : tasmlabel;
+         l3,oldclabel,oldblabel : tasmlabel;
          temptovalue : boolean;
          hop : topcg;
          hcond : topcmp;
@@ -433,11 +421,8 @@ implementation
          cmp_const:Tconstexprint;
          oldflowcontrol : tflowcontrol;
          oldexecutionweight : longint;
-         isjump: boolean;
       begin
          location_reset(location,LOC_VOID,OS_NO);
-         ofl:=nil;
-         otl:=nil;
 
          oldclabel:=current_procinfo.CurrContinueLabel;
          oldblabel:=current_procinfo.CurrBreakLabel;
@@ -458,22 +443,9 @@ implementation
          }
            and not(assigned(entrylabel));
 
-        isjump:=(t1.expectloc=LOC_JUMP);
-        if isjump then
-          begin
-             otl:=current_procinfo.CurrTrueLabel;
-             current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
-             ofl:=current_procinfo.CurrFalseLabel;
-             current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
-          end;
         secondpass(t1);
         if t1.location.loc in [LOC_FLAGS,LOC_JUMP] then
           hlcg.location_force_reg(current_asmdata.CurrAsmList,t1.location,t1.resultdef,t1.resultdef,false);
-        if isjump then
-          begin
-            current_procinfo.CurrTrueLabel:=otl;
-            current_procinfo.CurrFalseLabel:=ofl;
-          end;
          { calculate pointer value and check if changeable and if so }
          { load into temporary variable                       }
          if t1.nodetype<>ordconstn then
@@ -491,22 +463,9 @@ implementation
          cg.executionweight:=oldexecutionweight;
 
          { load from value }
-         isjump:=(right.expectloc=LOC_JUMP);
-         if isjump then
-           begin
-              otl:=current_procinfo.CurrTrueLabel;
-              current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
-              ofl:=current_procinfo.CurrFalseLabel;
-              current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
-           end;
          secondpass(right);
          if right.location.loc in [LOC_FLAGS,LOC_JUMP] then
            hlcg.location_force_reg(current_asmdata.CurrAsmList,right.location,right.resultdef,right.resultdef,false);
-         if isjump then
-           begin
-             current_procinfo.CurrTrueLabel:=otl;
-             current_procinfo.CurrFalseLabel:=ofl;
-           end;
 
          hlcg.maybe_change_load_node_reg(current_asmdata.CurrAsmList,left,false);
          oldflowcontrol:=flowcontrol;

compiler/ncghlmat.pas

@@ -43,7 +43,7 @@ uses
   aasmbase,aasmdata,
   defutil,
   procinfo,
-  cgbase,pass_2,hlcgobj;
+  cgbase,cgutils,pass_2,hlcgobj;
 
 {*****************************************************************************
                                tcghlnotnode
@@ -59,18 +59,11 @@ function tcghlnotnode.pass_1: tnode;
 
 
 procedure tcghlnotnode.second_boolean;
-  var
-    hl : tasmlabel;
   begin
-    hl:=current_procinfo.CurrTrueLabel;
-    current_procinfo.CurrTrueLabel:=current_procinfo.CurrFalseLabel;
-    current_procinfo.CurrFalseLabel:=hl;
     secondpass(left);
     hlcg.maketojumpbool(current_asmdata.CurrAsmList,left);
-    hl:=current_procinfo.CurrTrueLabel;
-    current_procinfo.CurrTrueLabel:=current_procinfo.CurrFalseLabel;
-    current_procinfo.CurrFalseLabel:=hl;
-    location.loc:=LOC_JUMP;
+    { switch true and false labels to invert result }
+    location_reset_jump(location,left.location.falselabel,left.location.truelabel);
   end;
 
 end.

compiler/ncgld.pas

@@ -584,7 +584,7 @@ implementation
 
     procedure tcgassignmentnode.pass_generate_code;
       var
-         otlabel,hlabel,oflabel : tasmlabel;
+         hlabel : tasmlabel;
          href : treference;
          releaseright : boolean;
          alignmentrequirement,
@@ -601,11 +601,6 @@ implementation
 
         location_reset(location,LOC_VOID,OS_NO);
 
-        otlabel:=current_procinfo.CurrTrueLabel;
-        oflabel:=current_procinfo.CurrFalseLabel;
-        current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
-        current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
-
         {
           in most cases we can process first the right node which contains
           the most complex code. Exceptions for this are:
@@ -962,7 +957,7 @@ implementation
               LOC_JUMP :
                 begin
                   current_asmdata.getjumplabel(hlabel);
-                  hlcg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
+                  hlcg.a_label(current_asmdata.CurrAsmList,right.location.truelabel);
                   if is_pasbool(left.resultdef) then
                     begin
 {$ifndef cpu64bitalu}
@@ -983,7 +978,7 @@ implementation
                     end;
 
                   hlcg.a_jmp_always(current_asmdata.CurrAsmList,hlabel);
-                  hlcg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+                  hlcg.a_label(current_asmdata.CurrAsmList,right.location.falselabel);
 {$ifndef cpu64bitalu}
                   if left.location.size in [OS_64,OS_S64] then
                     cg64.a_load64_const_loc(current_asmdata.CurrAsmList,0,left.location)
@@ -1073,9 +1068,6 @@ implementation
 
         if releaseright then
           location_freetemp(current_asmdata.CurrAsmList,right.location);
-
-        current_procinfo.CurrTrueLabel:=otlabel;
-        current_procinfo.CurrFalseLabel:=oflabel;
       end;
 
 
@@ -1125,8 +1117,6 @@ implementation
         href  : treference;
         lt    : tdef;
         paraloc : tcgparalocation;
-        otlabel,
-        oflabel : tasmlabel;
         vtype : longint;
         eledef: tdef;
         elesize : longint;
@@ -1135,8 +1125,6 @@ implementation
         freetemp,
         dovariant: boolean;
       begin
-        otlabel:=nil;
-        oflabel:=nil;
         if is_packed_array(resultdef) then
           internalerror(200608042);
         dovariant:=
@@ -1175,26 +1163,14 @@ implementation
            if assigned(hp.left) then
             begin
               freetemp:=true;
-              if (hp.left.expectloc=LOC_JUMP) then
-                begin
-                  otlabel:=current_procinfo.CurrTrueLabel;
-                  oflabel:=current_procinfo.CurrFalseLabel;
-                  current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
-                  current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
-                end;
               secondpass(hp.left);
+              if (hp.left.location.loc=LOC_JUMP)<>
+                 (hp.left.expectloc=LOC_JUMP) then
+                internalerror(2007103101);
               { Move flags and jump in register }
               if hp.left.location.loc in [LOC_FLAGS,LOC_JUMP] then
                 hlcg.location_force_reg(current_asmdata.CurrAsmList,hp.left.location,hp.left.resultdef,hp.left.resultdef,false);
 
-              if (hp.left.location.loc=LOC_JUMP) then
-                begin
-                  if (hp.left.expectloc<>LOC_JUMP) then
-                    internalerror(2007103101);
-                  current_procinfo.CurrTrueLabel:=otlabel;
-                  current_procinfo.CurrFalseLabel:=oflabel;
-                end;
-
               if dovariant then
                begin
                  { find the correct vtype value }

compiler/ncgmat.pas

@@ -609,15 +609,10 @@ implementation
 
 
     function tcgnotnode.handle_locjump: boolean;
-      var
-        hl: tasmlabel;
       begin
         result:=(left.expectloc=LOC_JUMP);
         if result then
           begin
-            hl:=current_procinfo.CurrTrueLabel;
-            current_procinfo.CurrTrueLabel:=current_procinfo.CurrFalseLabel;
-            current_procinfo.CurrFalseLabel:=hl;
             secondpass(left);
 
             if is_constboolnode(left) then
@@ -625,12 +620,8 @@ implementation
             if left.location.loc<>LOC_JUMP then
               internalerror(2012081306);
 
-            { This does nothing for LOC_JUMP }
-            //maketojumpbool(current_asmdata.CurrAsmList,left,lr_load_regvars);
-            hl:=current_procinfo.CurrTrueLabel;
-            current_procinfo.CurrTrueLabel:=current_procinfo.CurrFalseLabel;
-            current_procinfo.CurrFalseLabel:=hl;
-            location_reset(location,LOC_JUMP,OS_NO);
+            { switch true and false labels to invert result }
+            location_reset_jump(location,left.location.falselabel,left.location.truelabel);
           end;
       end;
 

compiler/ncgmem.pas

@@ -872,12 +872,10 @@ implementation
          offsetdec,
          extraoffset : aint;
          rightp      : pnode;
-         otl,ofl  : tasmlabel;
          newsize  : tcgsize;
          mulsize,
          bytemulsize,
          alignpow : aint;
-         isjump   : boolean;
          paraloc1,
          paraloc2 : tcgpara;
          subsetref : tsubsetreference;
@@ -1083,17 +1081,10 @@ implementation
               { calculate from left to right }
               if not(location.loc in [LOC_CREFERENCE,LOC_REFERENCE]) then
                 internalerror(200304237);
-              isjump:=(right.expectloc=LOC_JUMP);
-              otl:=nil;
-              ofl:=nil;
-              if isjump then
-               begin
-                 otl:=current_procinfo.CurrTrueLabel;
-                 current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
-                 ofl:=current_procinfo.CurrFalseLabel;
-                 current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
-               end;
               secondpass(right);
+              if (right.expectloc=LOC_JUMP)<>
+                 (right.location.loc=LOC_JUMP) then
+                internalerror(2006010801);
 
               { if mulsize = 1, we won't have to modify the index }
               if not(right.location.loc in [LOC_CREGISTER,LOC_REGISTER]) or
@@ -1105,14 +1096,6 @@ implementation
               else
                 indexdef:=right.resultdef;
 
-              if isjump then
-               begin
-                 current_procinfo.CurrTrueLabel:=otl;
-                 current_procinfo.CurrFalseLabel:=ofl;
-               end
-              else if (right.location.loc = LOC_JUMP) then
-                internalerror(2006010801);
-
             { produce possible range check code: }
               if cs_check_range in current_settings.localswitches then
                begin

compiler/ncgset.pas

@@ -241,7 +241,6 @@ implementation
          adjustment,
          setbase    : aint;
          l, l2      : tasmlabel;
-         otl, ofl   : tasmlabel;
          hr,
          pleftreg   : tregister;
          setparts   : Tsetparts;
@@ -252,14 +251,11 @@ implementation
          orgopsize  : tcgsize;
          orgopdef   : tdef;
          genjumps,
-         use_small,
-         isjump     : boolean;
+         use_small  : boolean;
          i,numparts : byte;
          needslabel : Boolean;
        begin
          l2:=nil;
-         ofl:=nil;
-         otl:=nil;
 
          { We check first if we can generate jumps, this can be done
            because the resultdef is already set in firstpass }
@@ -282,35 +278,17 @@ implementation
            end;
          needslabel := false;
 
-         isjump:=false;
-         if (left.expectloc=LOC_JUMP) then
-           begin
-             otl:=current_procinfo.CurrTrueLabel;
-             current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
-             ofl:=current_procinfo.CurrFalseLabel;
-             current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
-             isjump:=true;
-           end
-         else if not genjumps then
+         if not genjumps then
            { calculate both operators }
            { the complex one first }
-           { only if left will not be a LOC_JUMP, to keep complexity in the }
-           { code generator down. This almost never happens anyway, only in }
-           { case like "if ((a in someset) in someboolset) then" etc        }
-           { also not in case of genjumps, because then we don't secondpass }
+           { not in case of genjumps, because then we don't secondpass      }
            { right at all (so we have to make sure that "right" really is   }
            { "right" and not "swapped left" in that case)                   }
            firstcomplex(self);
 
          secondpass(left);
-         if isjump then
-           begin
-             hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,orgopdef,opdef,true);
-             left.resultdef:=opdef;
-             current_procinfo.CurrTrueLabel:=otl;
-             current_procinfo.CurrFalseLabel:=ofl;
-           end
-         else if (left.location.loc=LOC_JUMP) then
+         if (left.expectloc=LOC_JUMP)<>
+            (left.location.loc=LOC_JUMP) then
            internalerror(2007070101);
 
          { Only process the right if we are not generating jumps }
@@ -327,7 +305,9 @@ implementation
          if genjumps then
            begin
              { location is always LOC_JUMP }
-             location_reset(location,LOC_JUMP,OS_NO);
+             current_asmdata.getjumplabel(l);
+             current_asmdata.getjumplabel(l2);
+             location_reset_jump(location,l,l2);
 
              { If register is used, use only lower 8 bits }
              hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,opdef,false);
@@ -375,24 +355,24 @@ implementation
                      { (this will never overflow since we check at the     }
                      { beginning whether stop-start <> 255)                }
                      hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, uopdef, OC_B,
-                       setparts[i].stop-setparts[i].start+1,pleftreg,current_procinfo.CurrTrueLabel);
+                       setparts[i].stop-setparts[i].start+1,pleftreg,location.truelabel);
                    end
                  else
                    { if setparts[i].start = 0 and setparts[i].stop = 255,  }
                    { it's always true since "in" is only allowed for bytes }
                    begin
-                     hlcg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
+                     hlcg.a_jmp_always(current_asmdata.CurrAsmList,location.truelabel);
                    end;
                end
               else
                begin
                  { Emit code to check if left is an element }
                  hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opdef, OC_EQ,
-                       setparts[i].stop-adjustment,pleftreg,current_procinfo.CurrTrueLabel);
+                       setparts[i].stop-adjustment,pleftreg,location.truelabel);
                end;
               { To compensate for not doing a second pass }
               right.location.reference.symbol:=nil;
-              hlcg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+              hlcg.a_jmp_always(current_asmdata.CurrAsmList,location.falselabel);
            end
          else
          {*****************************************************************}
@@ -935,15 +915,11 @@ implementation
          max_label: tconstexprint;
          labelcnt : tcgint;
          max_linear_list : aint;
-         otl, ofl: tasmlabel;
-         isjump : boolean;
          max_dist,
          dist : aword;
          oldexecutionweight : longint;
       begin
          location_reset(location,LOC_VOID,OS_NO);
-         ofl:=nil;
-         otl:=nil;
 
          oldflowcontrol := flowcontrol;
          include(flowcontrol,fc_inflowcontrol);
@@ -967,17 +943,10 @@ implementation
               jmp_le:=OC_BE;
            end;
 
-         { save current current_procinfo.CurrTrueLabel and current_procinfo.CurrFalseLabel }
-         isjump:=false;
-         if left.expectloc=LOC_JUMP then
-          begin
-            otl:=current_procinfo.CurrTrueLabel;
-            current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
-            ofl:=current_procinfo.CurrFalseLabel;
-            current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
-            isjump:=true;
-          end;
          secondpass(left);
+         if (left.expectloc=LOC_JUMP)<>
+            (left.location.loc=LOC_JUMP) then
+           internalerror(2006050501);
          { determines the size of the operand }
          opsize:=left.resultdef;
          { copy the case expression to a register }
@@ -991,14 +960,6 @@ implementation
          else
 {$endif not cpu64bitalu}
            hregister:=left.location.register;
-         if isjump then
-          begin
-            current_procinfo.CurrTrueLabel:=otl;
-            current_procinfo.CurrFalseLabel:=ofl;
-          end
-         else
-          if (left.location.loc=LOC_JUMP) then
-            internalerror(2006050501);
 
          { we need the min_label always to choose between }
          { cmps and subs/decs                             }

compiler/ncgutil.pas

@@ -57,7 +57,7 @@ interface
 }
 
     procedure firstcomplex(p : tbinarynode);
-    procedure maketojumpbool(list:TAsmList; p : tnode; loadregvars: tloadregvars);
+    procedure maketojumpboollabels(list: TAsmList; p: tnode; truelabel, falselabel: tasmlabel);
 //    procedure remove_non_regvars_from_loc(const t: tlocation; var regs:Tsuperregisterset);
 
     procedure location_force_mmreg(list:TAsmList;var l: tlocation;maybeconst:boolean);
@@ -257,14 +257,9 @@ implementation
       end;
 
 
-    procedure maketojumpbool(list:TAsmList; p : tnode; loadregvars: tloadregvars);
+    procedure maketojumpboollabels(list: TAsmList; p: tnode; truelabel, falselabel: tasmlabel);
     {
       produces jumps to true respectively false labels using boolean expressions
-
-      depending on whether the loading of regvars is currently being
-      synchronized manually (such as in an if-node) or automatically (most of
-      the other cases where this procedure is called), loadregvars can be
-      "lr_load_regvars" or "lr_dont_load_regvars"
     }
       var
         opsize : tcgsize;
@@ -277,16 +272,12 @@ implementation
          current_filepos:=p.fileinfo;
          if is_boolean(p.resultdef) then
            begin
-{$ifdef OLDREGVARS}
-              if loadregvars = lr_load_regvars then
-                load_all_regvars(list);
-{$endif OLDREGVARS}
               if is_constboolnode(p) then
                 begin
                    if Tordconstnode(p).value.uvalue<>0 then
-                     cg.a_jmp_always(list,current_procinfo.CurrTrueLabel)
+                     cg.a_jmp_always(list,truelabel)
                    else
-                     cg.a_jmp_always(list,current_procinfo.CurrFalseLabel)
+                     cg.a_jmp_always(list,falselabel)
                 end
               else
                 begin
@@ -297,8 +288,8 @@ implementation
                        begin
                          tmpreg := cg.getintregister(list,OS_INT);
                          hlcg.a_load_loc_reg(list,p.resultdef,osuinttype,p.location,tmpreg);
-                         cg.a_cmp_const_reg_label(list,OS_INT,OC_NE,0,tmpreg,current_procinfo.CurrTrueLabel);
-                         cg.a_jmp_always(list,current_procinfo.CurrFalseLabel);
+                         cg.a_cmp_const_reg_label(list,OS_INT,OC_NE,0,tmpreg,truelabel);
+                         cg.a_jmp_always(list,falselabel);
                        end;
                      LOC_CREGISTER,LOC_REGISTER,LOC_CREFERENCE,LOC_REFERENCE :
                        begin
@@ -323,17 +314,28 @@ implementation
                              opsize:=OS_32;
                            end;
 {$endif cpu64bitalu}
-                         cg.a_cmp_const_loc_label(list,opsize,OC_NE,0,p.location,current_procinfo.CurrTrueLabel);
-                         cg.a_jmp_always(list,current_procinfo.CurrFalseLabel);
+                         cg.a_cmp_const_loc_label(list,opsize,OC_NE,0,p.location,truelabel);
+                         cg.a_jmp_always(list,falselabel);
                        end;
                      LOC_JUMP:
-                       ;
+                       begin
+                         if truelabel<>p.location.truelabel then
+                           begin
+                             cg.a_label(list,p.location.truelabel);
+                             cg.a_jmp_always(list,truelabel);
+                           end;
+                         if falselabel<>p.location.falselabel then
+                           begin
+                             cg.a_label(list,p.location.falselabel);
+                             cg.a_jmp_always(list,falselabel);
+                           end;
+                       end;
 {$ifdef cpuflags}
                      LOC_FLAGS :
                        begin
-                         cg.a_jmp_flags(list,p.location.resflags,current_procinfo.CurrTrueLabel);
+                         cg.a_jmp_flags(list,p.location.resflags,truelabel);
                          cg.a_reg_dealloc(list,NR_DEFAULTFLAGS);
-                         cg.a_jmp_always(list,current_procinfo.CurrFalseLabel);
+                         cg.a_jmp_always(list,falselabel);
                        end;
 {$endif cpuflags}
                      else
@@ -343,6 +345,7 @@ implementation
                        end;
                    end;
                 end;
+              location_reset_jump(p.location,truelabel,falselabel);
            end
          else
            internalerror(200112305);

compiler/ncon.pas

@@ -105,6 +105,7 @@ interface
           function pass_1 : tnode;override;
           function pass_typecheck:tnode;override;
           function docompare(p: tnode) : boolean; override;
+          procedure printnodedata(var t : text); override;
        end;
        tpointerconstnodeclass = class of tpointerconstnode;
 
@@ -805,6 +806,13 @@ implementation
       end;
 
 
+    procedure tpointerconstnode.printnodedata(var t : text);
+      begin
+        inherited printnodedata(t);
+        writeln(t,printnodeindention,'value = $',hexstr(PUInt(value),sizeof(PUInt)*2));
+      end;
+
+
 {*****************************************************************************
                              TSTRINGCONSTNODE
 *****************************************************************************}

compiler/ninl.pas

@@ -34,6 +34,7 @@ interface
        tinlinenode = class(tunarynode)
           inlinenumber : byte;
           constructor create(number : byte;is_const:boolean;l : tnode);virtual;
+          constructor createintern(number : byte;is_const:boolean;l : tnode);virtual;
           constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
           procedure ppuwrite(ppufile:tcompilerppufile);override;
           function dogetcopy : tnode;override;
@@ -138,6 +139,14 @@ implementation
       end;
 
 
+    constructor tinlinenode.createintern(number : byte; is_const : boolean;
+     l : tnode);
+      begin
+         create(number,is_const,l);
+         include(flags,nf_internal);
+      end;
+
+
     constructor tinlinenode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
       begin
         inherited ppuload(t,ppufile);
@@ -2286,7 +2295,7 @@ implementation
                         result:=create_simplified_ord_const(vl,resultdef,forinline)
                       else
                         { check the range for enums, chars, booleans }
-                        result:=cordconstnode.create(vl,left.resultdef,true)
+                        result:=cordconstnode.create(vl,left.resultdef,not(nf_internal in flags))
                     end
                 end;
               in_low_x,

compiler/nld.pas

@@ -697,12 +697,14 @@ implementation
 {$endif}
         then
           begin
-            check_ranges(fileinfo,right,left.resultdef);
+            if not(nf_internal in flags) then
+              check_ranges(fileinfo,right,left.resultdef);
           end
         else
           begin
             { check if the assignment may cause a range check error }
-            check_ranges(fileinfo,right,left.resultdef);
+            if not(nf_internal in flags) then
+              check_ranges(fileinfo,right,left.resultdef);
 
             { beginners might be confused about an error message like
               Incompatible types: got "untyped" expected "LongInt"
@@ -711,6 +713,8 @@ implementation
             if (left.resultdef.typ<>procvardef) and
               (right.nodetype=calln) and is_void(right.resultdef) then
               CGMessage(type_e_procedures_return_no_value)
+            else if nf_internal in flags then
+              inserttypeconv_internal(right,left.resultdef)
             else
               inserttypeconv(right,left.resultdef);
           end;

compiler/nmem.pas

@@ -83,6 +83,7 @@ interface
           function dogetcopy : tnode;override;
           function pass_1 : tnode;override;
           function pass_typecheck:tnode;override;
+          function simplify(forinline : boolean) : tnode; override;
          protected
           mark_read_written: boolean;
           function typecheck_non_proc(realsource: tnode; out res: tnode): boolean; virtual;
@@ -597,6 +598,32 @@ implementation
             { vsf_referred_not_inited                          }
             set_varstate(left,vs_read,[vsf_must_be_valid]);
           end;
+        if not(assigned(result)) then
+          result:=simplify(false);
+      end;
+
+
+    function taddrnode.simplify(forinline : boolean) : tnode;
+      var
+        hsym : tfieldvarsym;
+      begin
+        result:=nil;
+        if ((left.nodetype=subscriptn) and
+          (tsubscriptnode(left).left.nodetype=derefn) and
+          (tsubscriptnode(left).left.resultdef.typ=recorddef) and
+          (tderefnode(tsubscriptnode(left).left).left.nodetype=niln)) or
+          ((left.nodetype=subscriptn) and
+          (tsubscriptnode(left).left.nodetype=typeconvn) and
+          (tsubscriptnode(left).left.resultdef.typ=recorddef) and
+          (ttypeconvnode(tsubscriptnode(left).left).left.nodetype=derefn) and
+          (tderefnode(ttypeconvnode(tsubscriptnode(left).left).left).left.nodetype=niln)) then
+          begin
+            hsym:=tsubscriptnode(left).vs;
+            if tabstractrecordsymtable(hsym.owner).is_packed then
+              result:=cpointerconstnode.create(hsym.fieldoffset div 8,resultdef)
+            else
+              result:=cpointerconstnode.create(hsym.fieldoffset,resultdef);
+          end;
       end;
 
 

compiler/nutils.pas

@@ -1354,7 +1354,9 @@ implementation
 
     function is_const(node : tnode) : boolean;
       begin
-        result:=(node.nodetype=temprefn) and (ti_const in ttemprefnode(node).tempinfo^.flags)
+        result:=is_constnode(node) or
+          ((node.nodetype=temprefn) and (ti_const in ttemprefnode(node).tempinfo^.flags)) or
+          ((node.nodetype=loadn) and (tloadnode(node).symtableentry.typ=paravarsym) and (tparavarsym(tloadnode(node).symtableentry).varspez in [vs_const,vs_constref]));
       end;
 
 

compiler/options.pas

@@ -50,6 +50,10 @@ Type
     ParaLibraryPath,
     ParaFrameworkPath : TSearchPathList;
     ParaAlignment   : TAlignmentInfo;
+    paratarget        : tsystem;
+    paratargetasm     : tasm;
+    paratargetdbg     : tdbg;
+    LinkTypeSetExplicitly : boolean;
     Constructor Create;
     Destructor Destroy;override;
     procedure WriteLogo;
@@ -675,9 +679,6 @@ begin
 {$ifdef sparc}
       'S',
 {$endif}
-{$ifdef vis}
-      'I',
-{$endif}
 {$ifdef avr}
       'V',
 {$endif}
@@ -3092,6 +3093,10 @@ begin
   ParaFrameworkPath:=TSearchPathList.Create;
   FillChar(ParaAlignment,sizeof(ParaAlignment),0);
   MacVersionSet:=false;
+  paratarget:=system_none;
+  paratargetasm:=as_none;
+  paratargetdbg:=dbg_none;
+  LinkTypeSetExplicitly:=false;
 end;
 
 
@@ -3314,10 +3319,6 @@ begin
   def_system_macro('FPC_CURRENCY_IS_INT64');
   def_system_macro('FPC_COMP_IS_INT64');
 {$endif}
-{$ifdef ALPHA}
-  def_system_macro('CPUALPHA');
-  def_system_macro('CPU64');
-{$endif}
 {$ifdef powerpc}
   def_system_macro('CPUPOWERPC');
   def_system_macro('CPUPOWERPC32');
@@ -3332,10 +3333,6 @@ begin
   def_system_macro('FPC_CURRENCY_IS_INT64');
   def_system_macro('FPC_COMP_IS_INT64');
 {$endif}
-{$ifdef iA64}
-  def_system_macro('CPUIA64');
-  def_system_macro('CPU64');
-{$endif}
 {$ifdef x86_64}
   def_system_macro('CPUX86_64');
   def_system_macro('CPUAMD64');
@@ -3359,10 +3356,6 @@ begin
   def_system_macro('FPC_CURRENCY_IS_INT64');
   def_system_macro('FPC_COMP_IS_INT64');
 {$endif}
-{$ifdef vis}
-  def_system_macro('CPUVIS');
-  def_system_macro('CPU32');
-{$endif}
 {$ifdef arm}
   def_system_macro('CPUARM');
   def_system_macro('CPU32');
@@ -3643,23 +3636,23 @@ begin
 
 {$ifdef llvm}
   { force llvm assembler writer }
-  paratargetasm:=as_llvm;
+  option.paratargetasm:=as_llvm;
 {$endif llvm}
   { maybe override assembler }
-  if (paratargetasm<>as_none) then
+  if (option.paratargetasm<>as_none) then
     begin
-      if not set_target_asm(paratargetasm) then
+      if not set_target_asm(option.paratargetasm) then
         begin
-          Message2(option_incompatible_asm,asminfos[paratargetasm]^.idtxt,target_info.name);
+          Message2(option_incompatible_asm,asminfos[option.paratargetasm]^.idtxt,target_info.name);
           set_target_asm(target_info.assemextern);
           Message1(option_asm_forced,target_asm.idtxt);
         end;
-      if (af_no_debug in asminfos[paratargetasm]^.flags) and
-         (paratargetdbg<>dbg_none) then
+      if (af_no_debug in asminfos[option.paratargetasm]^.flags) and
+         (option.paratargetdbg<>dbg_none) then
         begin
           Message1(option_confict_asm_debug,
-            asminfos[paratargetasm]^.idtxt);
-          paratargetdbg:=dbg_none;
+            asminfos[option.paratargetasm]^.idtxt);
+          option.paratargetdbg:=dbg_none;
           exclude(init_settings.moduleswitches,cs_debuginfo);
         end;
     end;
@@ -3667,8 +3660,8 @@ begin
   option.checkoptionscompatibility;
 
   { maybe override debug info format }
-  if (paratargetdbg<>dbg_none) then
-    if not set_target_dbg(paratargetdbg) then
+  if (option.paratargetdbg<>dbg_none) then
+    if not set_target_dbg(option.paratargetdbg) then
       Message(option_w_unsupported_debug_format);
 
   { switch assembler if it's binary and we got -a on the cmdline }
@@ -3967,7 +3960,7 @@ if (target_info.abi = abi_eabihf) then
      (target_info.system in [system_i386_win32,system_x86_64_win64]) then
     exclude(target_info.flags,tf_smartlink_sections);
 
-  if not LinkTypeSetExplicitly then
+  if not option.LinkTypeSetExplicitly then
     set_default_link_type;
 
   { Default alignment settings,

compiler/owomflib.pas

@@ -0,0 +1,491 @@
+{
+    Copyright (c) 2015 by Nikolay Nikolov
+
+    Contains the stuff for writing Relocatable Object Module Format (OMF)
+    libraries directly. This is the object format used on the i8086-msdos
+    platform (also known as .lib files in the dos world, even though Free
+    Pascal uses the extension .a).
+
+    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 owomflib;
+
+{$i fpcdefs.inc}
+
+interface
+
+uses
+  cclasses,
+  globtype,
+  owbase;
+
+type
+
+  { TOmfLibDictionaryEntry }
+
+  TOmfLibDictionaryEntry=class(TFPHashObject)
+  private
+    FPageNum: Word;
+  public
+    constructor Create(HashObjectList:TFPHashObjectList;const aName:TSymStr;aPageNum:Word);
+    property PageNum: Word read FPageNum write FPageNum;
+  end;
+
+  { TOmfLibObjectWriter }
+
+  TOmfLibObjectWriter=class(TObjectWriter)
+  private
+    FPageSize: Integer;
+    FLibName: string;
+    FLibData: TDynamicArray;
+    FObjFileName: string;
+    FObjData: TDynamicArray;
+    FObjStartPage: Word;
+    FDictionary: TFPHashObjectList;
+
+    procedure WriteHeader(DictStart: DWord; DictBlocks: Word);
+    procedure WriteFooter;
+    procedure WriteLib;
+    function WriteDictionary: byte;
+    function TryWriteDictionaryWithSize(nblocks: Byte): Boolean;
+  public
+    constructor createAr(const Aarfn:string);override;
+    destructor  destroy;override;
+    function  createfile(const fn:string):boolean;override;
+    procedure closefile;override;
+    procedure writesym(const sym:string);override;
+    procedure write(const b;len:longword);override;
+  end;
+
+  { TOmfLibObjectReader }
+
+  TOmfLibObjectReader=class(TObjectReader)
+  private
+    LibSymbols : TFPHashObjectList;
+    islib: boolean;
+    CurrMemberPos : longint;
+    CurrMemberName : string;
+    FPageSize: Integer;
+    procedure ReadLibrary;
+    procedure ReadDictionary(DictionaryOffset: DWord; DictionarySizeInBlocks: Word);
+  protected
+    function getfilename:string;override;
+    function GetPos: longint;override;
+    function GetIsArchive: boolean;override;
+  public
+    constructor createAr(const Aarfn:string;allow_nonar:boolean=false);override;
+    destructor  destroy;override;
+    function  openfile(const fn:string):boolean;override;
+    procedure closefile;override;
+    procedure seek(len:longint);override;
+  end;
+
+implementation
+
+    uses
+      SysUtils,
+      cstreams,
+      globals,
+      verbose,
+      omfbase;
+
+    const
+      libbufsize = 65536;
+      objbufsize = 65536;
+
+{*****************************************************************************
+                                   Helpers
+*****************************************************************************}
+
+    function ModName2DictEntry(const modnm: string): string;
+      begin
+        if Copy(modnm,Length(modnm)-1,2)='.o' then
+          Result:=Copy(modnm,1,Length(modnm)-2)+'!'
+        else
+          Result:=modnm;
+      end;
+
+{*****************************************************************************
+                                TOmfLibDictionaryEntry
+*****************************************************************************}
+
+    constructor TOmfLibDictionaryEntry.Create(HashObjectList: TFPHashObjectList; const aName: TSymStr; aPageNum: Word);
+      begin
+        inherited Create(HashObjectList,aName);
+        PageNum:=aPageNum;
+      end;
+
+{*****************************************************************************
+                                TOmfLibObjectWriter
+*****************************************************************************}
+
+    constructor TOmfLibObjectWriter.createAr(const Aarfn: string);
+      begin
+        FPageSize:=512;
+        FLibName:=Aarfn;
+        FLibData:=TDynamicArray.Create(libbufsize);
+        FDictionary:=TFPHashObjectList.Create;
+        { header is at page 0, so first module starts at page 1 }
+        FObjStartPage:=1;
+      end;
+
+
+    destructor TOmfLibObjectWriter.destroy;
+      begin
+        if Errorcount=0 then
+          WriteLib;
+        FLibData.Free;
+        FObjData.Free;
+        FDictionary.Free;
+        inherited destroy;
+      end;
+
+
+    function TOmfLibObjectWriter.createfile(const fn: string): boolean;
+      begin
+        FObjFileName:=fn;
+        FreeAndNil(FObjData);
+        FObjData:=TDynamicArray.Create(objbufsize);
+        createfile:=true;
+        fobjsize:=0;
+      end;
+
+
+    procedure TOmfLibObjectWriter.closefile;
+      var
+        RawRec: TOmfRawRecord;
+        ObjHeader: TOmfRecord_THEADR;
+      begin
+        FLibData.seek(FObjStartPage*FPageSize);
+        FObjData.seek(0);
+        RawRec:=TOmfRawRecord.Create;
+        repeat
+          RawRec.ReadFrom(FObjData);
+          if RawRec.RecordType=RT_THEADR then
+            begin
+              ObjHeader:=TOmfRecord_THEADR.Create;
+              ObjHeader.DecodeFrom(RawRec);
+              { create a dictionary entry with the module name }
+              TOmfLibDictionaryEntry.Create(FDictionary,ModName2DictEntry(ObjHeader.ModuleName),FObjStartPage);
+              ObjHeader.Free;
+            end;
+          RawRec.WriteTo(FLibData);
+        until RawRec.RecordType in [RT_MODEND,RT_MODEND32];
+        RawRec.Free;
+        { calculate start page of next module }
+        FObjStartPage:=(FLibData.Pos+FPageSize-1) div FPageSize;
+        fobjsize:=0;
+      end;
+
+
+    procedure TOmfLibObjectWriter.writesym(const sym: string);
+      begin
+        TOmfLibDictionaryEntry.Create(FDictionary,sym,FObjStartPage);
+      end;
+
+
+    procedure TOmfLibObjectWriter.write(const b; len: longword);
+      begin
+        inc(fobjsize,len);
+        inc(fsize,len);
+        FObjData.write(b,len);
+      end;
+
+    procedure TOmfLibObjectWriter.WriteHeader(DictStart: DWord; DictBlocks: Word);
+      var
+        Header: TOmfRecord_LIBHEAD;
+        RawRec: TOmfRawRecord;
+      begin
+        { set header properties }
+        Header:=TOmfRecord_LIBHEAD.Create;
+        Header.PageSize:=FPageSize;
+        Header.DictionaryOffset:=DictStart;
+        Header.DictionarySizeInBlocks:=DictBlocks;
+        Header.CaseSensitive:=true;
+
+        { write header }
+        RawRec:=TOmfRawRecord.Create;
+        Header.EncodeTo(RawRec);
+        FLibData.seek(0);
+        RawRec.WriteTo(FLibData);
+        Header.Free;
+        RawRec.Free;
+      end;
+
+    procedure TOmfLibObjectWriter.WriteFooter;
+      var
+        Footer: TOmfRecord_LIBEND;
+        RawRec: TOmfRawRecord;
+      begin
+        FLibData.seek(FObjStartPage*FPageSize);
+        Footer:=TOmfRecord_LIBEND.Create;
+        Footer.CalculatePaddingBytes(FLibData.Pos);
+        RawRec:=TOmfRawRecord.Create;
+        Footer.EncodeTo(RawRec);
+        RawRec.WriteTo(FLibData);
+        Footer.Free;
+        RawRec.Free;
+      end;
+
+    procedure TOmfLibObjectWriter.WriteLib;
+      var
+        libf: TCCustomFileStream;
+        DictStart: LongWord;
+        DictBlocks: Byte;
+      begin
+        libf:=CFileStreamClass.Create(FLibName,fmCreate);
+        if CStreamError<>0 then
+          begin
+            Message1(exec_e_cant_create_archivefile,FLibName);
+            exit;
+          end;
+        WriteFooter;
+        DictStart:=FLibData.Pos;
+        DictBlocks:=WriteDictionary;
+        WriteHeader(DictStart,DictBlocks);
+        FLibData.WriteStream(libf);
+        libf.Free;
+      end;
+
+    function TOmfLibObjectWriter.WriteDictionary: Byte;
+      var
+        nb: Byte;
+      begin
+        for nb in OmfLibDictionaryBlockCounts do
+          if TryWriteDictionaryWithSize(nb) then
+            exit(nb);
+        { could not write dictionary, even with the largest number of blocks }
+        internalerror(2015042201);
+      end;
+
+    function TOmfLibObjectWriter.TryWriteDictionaryWithSize(nblocks: Byte): Boolean;
+      const
+        nbuckets=37;
+        freespace=nbuckets;
+      type
+        PBlock=^TBlock;
+        TBlock=array[0..511] of byte;
+      var
+        blocks: array of TBlock;
+        i: Integer;
+        N: TSymStr;
+        length_of_string: Integer;
+        h: TOmfLibHash;
+        start_block,start_bucket: Integer;
+        space_required: Integer;
+        pb: PBlock;
+        success: Boolean;
+        store_at: Integer;
+        PageNum: Word;
+      begin
+        SetLength(blocks,nblocks);
+        for i:=0 to nblocks-1 do
+          begin
+            FillChar(blocks[i],SizeOf(blocks[i]),0);
+            blocks[i][freespace]:=(freespace+1) div 2;
+          end;
+
+        for i:=0 to FDictionary.Count-1 do
+          begin
+            N:=TOmfLibDictionaryEntry(FDictionary[i]).Name;
+            PageNum:=TOmfLibDictionaryEntry(FDictionary[i]).PageNum;
+            length_of_string:=Length(N);
+            h:=compute_omf_lib_hash(N,nblocks);
+            start_block:=h.block_x;
+            start_bucket:=h.bucket_x;
+            space_required:=1+length_of_string+2;
+            if odd(space_required) then
+              Inc(space_required);
+            repeat
+              pb:=@blocks[h.block_x];
+              success:=false;
+              repeat
+                if pb^[h.bucket_x]=0 then
+                  begin
+                    if (512-pb^[freespace]*2)<space_required then
+                      break;
+                    pb^[h.bucket_x]:=pb^[freespace];
+                    store_at:=2*pb^[h.bucket_x];
+                    pb^[store_at]:=length_of_string;
+                    Move(N[1],pb^[store_at+1],length_of_string);
+                    pb^[store_at+1+length_of_string]:=Byte(PageNum);
+                    pb^[store_at+1+length_of_string+1]:=Byte(PageNum shr 8);
+                    Inc(pb^[freespace],space_required div 2);
+                    if pb^[freespace]=0 then
+                      pb^[freespace]:=255;
+                    success:=true;
+                    break;
+                  end;
+                h.bucket_x:=(h.bucket_x+h.bucket_d) mod nbuckets;
+              until h.bucket_x=start_bucket;
+              if not success then
+                begin
+                  h.block_x:=(h.block_x+h.block_d) mod nblocks;
+                  if h.block_x=start_block then
+                    exit(false); // not enough blocks
+                  pb^[freespace]:=255;
+                end;
+            until success;
+          end;
+        FLibData.write(blocks[0],nblocks*SizeOf(TBlock));
+        Result:=true;
+      end;
+
+{*****************************************************************************
+                                TOmfLibObjectReader
+*****************************************************************************}
+
+  procedure TOmfLibObjectReader.ReadLibrary;
+    var
+      RawRecord: TOmfRawRecord;
+      Header: TOmfRecord_LIBHEAD;
+      FIsCaseSensitive: Boolean;
+    begin
+      RawRecord:=TOmfRawRecord.Create;
+      RawRecord.ReadFrom(Self);
+      Header:=TOmfRecord_LIBHEAD.Create;
+      Header.DecodeFrom(RawRecord);
+      FPageSize:=Header.PageSize;
+      FIsCaseSensitive:=Header.CaseSensitive;
+      ReadDictionary(Header.DictionaryOffset, Header.DictionarySizeInBlocks);
+    end;
+
+  procedure TOmfLibObjectReader.ReadDictionary(DictionaryOffset: DWord; DictionarySizeInBlocks: Word);
+    const
+      nbuckets=37;
+      freespace=nbuckets;
+    type
+      PBlock=^TBlock;
+      TBlock=array[0..511] of byte;
+    var
+      blocks: array of TBlock;
+      blocknr: Integer;
+      block: PBlock;
+      ofs: Integer;
+      bucket: Integer;
+      length_of_string: Byte;
+      name: string;
+      PageNum: Integer;
+    begin
+      seek(DictionaryOffset);
+      SetLength(blocks,DictionarySizeInBlocks);
+      read(blocks[0],DictionarySizeInBlocks*SizeOf(TBlock));
+      for blocknr:=0 to DictionarySizeInBlocks-1 do
+        begin
+          block:=@(blocks[blocknr]);
+          for bucket:=0 to nbuckets-1 do
+            if block^[bucket]<>0 then
+              begin
+                ofs:=2*block^[bucket];
+                length_of_string:=block^[ofs];
+                if (ofs+1+length_of_string+1)>High(TBlock) then
+                  begin
+                    Comment(V_Error,'OMF dictionary entry goes beyond end of block');
+                    continue;
+                  end;
+                SetLength(name,length_of_string);
+                Move(block^[ofs+1],name[1],length_of_string);
+                PageNum:=block^[ofs+1+length_of_string]+
+                         block^[ofs+1+length_of_string+1] shl 8;
+                TOmfLibDictionaryEntry.create(LibSymbols,name,PageNum);
+              end;
+        end;
+    end;
+
+  function TOmfLibObjectReader.getfilename: string;
+    begin
+      Result:=inherited getfilename;
+      if CurrMemberName<>'' then
+        result:=result+'('+CurrMemberName+')';
+    end;
+
+  function TOmfLibObjectReader.GetPos: longint;
+    begin
+      result:=inherited GetPos-CurrMemberPos;
+    end;
+
+  function TOmfLibObjectReader.GetIsArchive: boolean;
+    begin
+      result:=islib;
+    end;
+
+  constructor TOmfLibObjectReader.createAr(const Aarfn: string; allow_nonar: boolean);
+    var
+      RecType: Byte;
+    begin
+      inherited Create;
+      LibSymbols:=TFPHashObjectList.Create(true);
+      CurrMemberPos:=0;
+      CurrMemberName:='';
+      if inherited openfile(Aarfn) then
+        begin
+          Read(RecType,1);
+          Seek(0);
+          islib:=RecType=RT_LIBHEAD;
+          if islib then
+            ReadLibrary
+          else if (not allow_nonar) then
+            Comment(V_Error,'Not an OMF library file, illegal magic: '+filename);
+        end;
+    end;
+
+  destructor TOmfLibObjectReader.destroy;
+    begin
+      inherited closefile;
+      LibSymbols.Free;
+      inherited Destroy;
+    end;
+
+  function TOmfLibObjectReader.openfile(const fn: string): boolean;
+    var
+      libsym: TOmfLibDictionaryEntry;
+      RawRec: TOmfRawRecord;
+      Header: TOmfRecord_THEADR;
+    begin
+      result:=false;
+      libsym:=TOmfLibDictionaryEntry(LibSymbols.Find(ModName2DictEntry(fn)));
+      if not assigned(libsym) then
+        exit;
+      CurrMemberPos:=libsym.PageNum*FPageSize;
+      inherited Seek(CurrMemberPos);
+
+      { read the header, to obtain the module name }
+      RawRec:=TOmfRawRecord.Create;
+      RawRec.ReadFrom(self);
+      Header:=TOmfRecord_THEADR.Create;
+      Header.DecodeFrom(RawRec);
+      CurrMemberName:=Header.ModuleName;
+      Header.Free;
+      RawRec.Free;
+
+      { go back to the beginning of the file }
+      inherited Seek(CurrMemberPos);
+      result:=true;
+    end;
+
+  procedure TOmfLibObjectReader.closefile;
+    begin
+      CurrMemberPos:=0;
+      CurrMemberName:='';
+    end;
+
+  procedure TOmfLibObjectReader.seek(len: longint);
+    begin
+      inherited Seek(CurrMemberPos+len);
+    end;
+
+end.

compiler/pmodules.pas

@@ -145,7 +145,7 @@ implementation
         if not(target_info.system in systems_darwin) and
            (
             (tf_needs_dwarf_cfi in target_info.flags) or
-            (paratargetdbg in [dbg_dwarf2, dbg_dwarf3])
+            (target_dbg.id in [dbg_dwarf2, dbg_dwarf3])
            ) then
           begin
             current_asmdata.asmlists[al_dwarf_frame].Free;
@@ -313,7 +313,7 @@ implementation
              AddUnit('heaptrc');
            { Lineinfo unit }
            if (cs_use_lineinfo in current_settings.globalswitches) then begin
-             case paratargetdbg of
+             case target_dbg.id of
                dbg_stabs:
                  AddUnit('lineinfo');
                dbg_stabx:
@@ -434,7 +434,7 @@ implementation
            if s='LINEINFO' then
              begin
                Message(parser_w_no_lineinfo_use_switch);
-               if (paratargetdbg in [dbg_dwarf2, dbg_dwarf3]) then
+               if (target_dbg.id in [dbg_dwarf2, dbg_dwarf3]) then
                 s := 'LNFODWRF';
               sorg := s;
              end;
@@ -1239,7 +1239,7 @@ type
            end;
 {$ifdef EXTDEBUG}
          if not(cs_compilesystem in current_settings.moduleswitches) then
-           if (store_crc<>current_module.crc) and simplify_ppu then
+           if (store_crc<>current_module.crc) then
              Message1(unit_u_implementation_crc_changed,current_module.ppufilename);
 {$endif EXTDEBUG}
 

compiler/powerpc/nppcadd.pas

@@ -143,6 +143,8 @@ interface
 
     procedure tppcaddnode.second_add64bit;
       var
+        truelabel,
+        falselabel : tasmlabel;
         op         : TOpCG;
         op1,op2    : TAsmOp;
         cmpop,
@@ -192,10 +194,10 @@ interface
            case nodetype of
               ltn,gtn:
                 begin
-                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags,current_procinfo.CurrTrueLabel);
+                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags,truelabel);
                    { cheat a little bit for the negative test }
                    toggleflag(nf_swapped);
-                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags,current_procinfo.CurrFalseLabel);
+                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags,falselabel);
                    toggleflag(nf_swapped);
                 end;
               lten,gten:
@@ -205,24 +207,24 @@ interface
                      nodetype:=ltn
                    else
                      nodetype:=gtn;
-                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags,current_procinfo.CurrTrueLabel);
+                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags,truelabel);
                    { cheat for the negative test }
                    if nodetype=ltn then
                      nodetype:=gtn
                    else
                      nodetype:=ltn;
-                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags,current_procinfo.CurrFalseLabel);
+                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags,falselabel);
                    nodetype:=oldnodetype;
                 end;
               equaln:
                 begin
                   nodetype := unequaln;
-                  cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags,current_procinfo.CurrFalseLabel);
+                  cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags,falselabel);
                   nodetype := equaln;
                 end;
               unequaln:
                 begin
-                  cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags,current_procinfo.CurrTrueLabel);
+                  cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags,truelabel);
                 end;
            end;
         end;
@@ -237,20 +239,20 @@ interface
                 begin
                    { the comparison of the low dword always has }
                    { to be always unsigned!                     }
-                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags,current_procinfo.CurrTrueLabel);
-                   cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags,truelabel);
+                   cg.a_jmp_always(current_asmdata.CurrAsmList,falselabel);
                 end;
               equaln:
                 begin
                    nodetype := unequaln;
-                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags,current_procinfo.CurrFalseLabel);
-                   cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
+                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags,falselabel);
+                   cg.a_jmp_always(current_asmdata.CurrAsmList,truelabel);
                    nodetype := equaln;
                 end;
               unequaln:
                 begin
-                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags,current_procinfo.CurrTrueLabel);
-                   cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags,truelabel);
+                   cg.a_jmp_always(current_asmdata.CurrAsmList,falselabel);
                 end;
            end;
         end;
@@ -260,6 +262,8 @@ interface
       tempreg64: tregister64;
 
       begin
+        truelabel:=nil;
+        falselabel:=nil;
         firstcomplex(self);
 
         pass_left_and_right;
@@ -306,8 +310,16 @@ interface
             internalerror(2002072705);
         end;
 
-        if not cmpop then
-          location_reset(location,LOC_REGISTER,def_cgsize(resultdef));
+        if not cmpop or
+           (nodetype in [equaln,unequaln]) then
+          location_reset(location,LOC_REGISTER,def_cgsize(resultdef))
+        else
+          begin
+            { we call emit_cmp, which will set location.loc to LOC_FLAGS ->
+              wait till the end with setting the location }
+            current_asmdata.getjumplabel(truelabel);
+            current_asmdata.getjumplabel(falselabel);
+          end;
 
         load_left_right(cmpop,((cs_check_overflow in current_settings.localswitches) and
             (nodetype in [addn,subn])) or (nodetype = muln));
@@ -544,7 +556,7 @@ interface
         {  real location only now) (JM)                               }
         if cmpop and
            not(nodetype in [equaln,unequaln]) then
-          location_reset(location,LOC_JUMP,OS_NO);
+          location_reset_jump(location,truelabel,falselabel);
       end;
 
 

compiler/powerpc/nppcmat.pas

@@ -26,7 +26,7 @@ unit nppcmat;
 interface
 
     uses
-      node,nmat;
+      node,nmat, ncgmat;
 
     type
       tppcmoddivnode = class(tmoddivnode)
@@ -44,7 +44,7 @@ interface
          procedure pass_generate_code;override;
       end;
 
-      tppcnotnode = class(tnotnode)
+      tppcnotnode = class(tcgnotnode)
          procedure pass_generate_code;override;
       end;
 
@@ -513,31 +513,11 @@ implementation
     procedure tppcnotnode.pass_generate_code;
 
       var
-         hl : tasmlabel;
          tmpreg: tregister;
       begin
          if is_boolean(resultdef) then
           begin
-            { if the location is LOC_JUMP, we do the secondpass after the
-              labels are allocated
-            }
-            if left.expectloc=LOC_JUMP then
-              begin
-                hl:=current_procinfo.CurrTrueLabel;
-                current_procinfo.CurrTrueLabel:=current_procinfo.CurrFalseLabel;
-                current_procinfo.CurrFalseLabel:=hl;
-                secondpass(left);
-
-                if left.location.loc<>LOC_JUMP then
-                  internalerror(2012081303);
-
-                maketojumpbool(current_asmdata.CurrAsmList,left,lr_load_regvars);
-                hl:=current_procinfo.CurrTrueLabel;
-                current_procinfo.CurrTrueLabel:=current_procinfo.CurrFalseLabel;
-                current_procinfo.CurrFalseLabel:=hl;
-                location.loc:=LOC_JUMP;
-              end
-            else
+            if not handle_locjump then
               begin
                 secondpass(left);
                 case left.location.loc of

compiler/powerpc64/nppcmat.pas

@@ -26,7 +26,7 @@ unit nppcmat;
 interface
 
 uses
-  node, nmat;
+  node, nmat, ncgmat;
 
 type
   tppcmoddivnode = class(tmoddivnode)
@@ -42,7 +42,7 @@ type
     procedure pass_generate_code override;
   end;
 
-  tppcnotnode = class(tnotnode)
+  tppcnotnode = class(tcgnotnode)
     procedure pass_generate_code override;
   end;
 
@@ -376,28 +376,10 @@ end;
 
 procedure tppcnotnode.pass_generate_code;
 
-var
-  hl: tasmlabel;
-
 begin
   if is_boolean(resultdef) then
   begin
-    { if the location is LOC_JUMP, we do the secondpass after the
-      labels are allocated
-    }
-    if left.expectloc = LOC_JUMP then
-    begin
-      hl := current_procinfo.CurrTrueLabel;
-      current_procinfo.CurrTrueLabel := current_procinfo.CurrFalseLabel;
-      current_procinfo.CurrFalseLabel := hl;
-      secondpass(left);
-      maketojumpbool(current_asmdata.CurrAsmList, left, lr_load_regvars);
-      hl := current_procinfo.CurrTrueLabel;
-      current_procinfo.CurrTrueLabel := current_procinfo.CurrFalseLabel;
-      current_procinfo.CurrFalseLabel := hl;
-      location.loc := LOC_JUMP;
-    end
-    else
+    if not handle_locjump then
     begin
       secondpass(left);
       case left.location.loc of

compiler/pp.pas

@@ -32,7 +32,6 @@ program pp;
   SPARC               generate a compiler for SPARC
   POWERPC             generate a compiler for the PowerPC
   POWERPC64           generate a compiler for the PowerPC64 architecture
-  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
@@ -87,18 +86,6 @@ program pp;
   {$endif CPUDEFINED}
   {$define CPUDEFINED}
 {$endif M68K}
-{$ifdef vis}
-  {$ifdef CPUDEFINED}
-    {$fatal ONLY one of the switches for the CPU type must be defined}
-  {$endif CPUDEFINED}
-  {$define CPUDEFINED}
-{$endif}
-{$ifdef iA64}
-  {$ifdef CPUDEFINED}
-    {$fatal ONLY one of the switches for the CPU type must be defined}
-  {$endif CPUDEFINED}
-  {$define CPUDEFINED}
-{$endif iA64}
 {$ifdef POWERPC}
   {$ifdef CPUDEFINED}
     {$fatal ONLY one of the switches for the CPU type must be defined}
@@ -111,12 +98,6 @@ program pp;
   {$endif CPUDEFINED}
   {$define CPUDEFINED}
 {$endif POWERPC64}
-{$ifdef ALPHA}
-  {$ifdef CPUDEFINED}
-    {$fatal ONLY one of the switches for the CPU type must be defined}
-  {$endif CPUDEFINED}
-  {$define CPUDEFINED}
-{$endif ALPHA}
 {$ifdef SPARC}
   {$ifdef CPUDEFINED}
     {$fatal ONLY one of the switches for the CPU type must be defined}

compiler/ppcgen/ngppcadd.pas

@@ -193,14 +193,10 @@ implementation
       var
         cgop      : TOpCg;
         cgsize  : TCgSize;
-        cmpop,
-        isjump  : boolean;
-        otl,ofl : tasmlabel;
+        cmpop   : boolean;
       begin
         { calculate the operator which is more difficult }
         firstcomplex(self);
-        otl:=nil;
-        ofl:=nil;
 
         cmpop:=false;
         if (torddef(left.resultdef).ordtype in [pasbool8,bool8bit]) or
@@ -223,43 +219,19 @@ implementation
             if left.nodetype in [ordconstn,realconstn] then
              swapleftright;
 
-            isjump:=(left.expectloc=LOC_JUMP);
-            if isjump then
-              begin
-                 otl:=current_procinfo.CurrTrueLabel;
-                 current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
-                 ofl:=current_procinfo.CurrFalseLabel;
-                 current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
-              end;
             secondpass(left);
+            if (left.expectloc=LOC_JUMP)<>
+               (left.location.loc=LOC_JUMP) then
+              internalerror(2003122901);
             if left.location.loc in [LOC_FLAGS,LOC_JUMP] then
               hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,cgsize_orddef(cgsize),false);
-            if isjump then
-             begin
-               current_procinfo.CurrTrueLabel:=otl;
-               current_procinfo.CurrFalseLabel:=ofl;
-             end
-            else if left.location.loc=LOC_JUMP then
-              internalerror(2003122901);
 
-            isjump:=(right.expectloc=LOC_JUMP);
-            if isjump then
-              begin
-                 otl:=current_procinfo.CurrTrueLabel;
-                 current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
-                 ofl:=current_procinfo.CurrFalseLabel;
-                 current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
-              end;
             secondpass(right);
+            if (right.expectloc=LOC_JUMP)<>
+               (right.location.loc=LOC_JUMP) then
+              internalerror(200312292);
             if right.location.loc in [LOC_FLAGS,LOC_JUMP] then
               hlcg.location_force_reg(current_asmdata.CurrAsmList,right.location,right.resultdef,cgsize_orddef(cgsize),false);
-            if isjump then
-             begin
-               current_procinfo.CurrTrueLabel:=otl;
-               current_procinfo.CurrFalseLabel:=ofl;
-             end
-            else if right.location.loc=LOC_JUMP then
-              internalerror(200312292);
 
             cmpop := nodetype in [ltn,lten,gtn,gten,equaln,unequaln];
 

compiler/ppcgen/ngppccnv.pas

@@ -75,13 +75,9 @@ implementation
 {$endif not cpu64bitalu}
         resflags : tresflags;
         opsize   : tcgsize;
-        hlabel, oldTrueLabel, oldFalseLabel : tasmlabel;
-        newsize   : tcgsize;
+        hlabel   : tasmlabel;
+        newsize  : tcgsize;
       begin
-         oldTrueLabel:=current_procinfo.CurrTrueLabel;
-         oldFalseLabel:=current_procinfo.CurrFalseLabel;
-         current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
-         current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
          secondpass(left);
          if codegenerror then
           exit;
@@ -99,8 +95,6 @@ implementation
                 hlcg.location_force_reg(current_asmdata.CurrAsmList,location,left.resultdef,resultdef,true)
               else
                 location.size:=newsize;
-              current_procinfo.CurrTrueLabel:=oldTrueLabel;
-              current_procinfo.CurrFalseLabel:=oldFalseLabel;
               exit;
            end;
 
@@ -176,13 +170,13 @@ implementation
               begin
                 hreg1:=cg.getintregister(current_asmdata.CurrAsmList,OS_INT);
                 current_asmdata.getjumplabel(hlabel);
-                cg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
+                cg.a_label(current_asmdata.CurrAsmList,left.location.truelabel);
                 if not(is_cbool(resultdef)) then
                   cg.a_load_const_reg(current_asmdata.CurrAsmList,OS_INT,1,hreg1)
                 else
                   cg.a_load_const_reg(current_asmdata.CurrAsmList,OS_INT,-1,hreg1);
                 cg.a_jmp_always(current_asmdata.CurrAsmList,hlabel);
-                cg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+                cg.a_label(current_asmdata.CurrAsmList,left.location.falselabel);
                 cg.a_load_const_reg(current_asmdata.CurrAsmList,OS_INT,0,hreg1);
                 cg.a_label(current_asmdata.CurrAsmList,hlabel);
               end;
@@ -204,9 +198,6 @@ implementation
          else
 {$endif cpu64bitalu}
            location.register:=hreg1;
-
-         current_procinfo.CurrTrueLabel:=oldTrueLabel;
-         current_procinfo.CurrFalseLabel:=oldFalseLabel;
       end;
 
 end.

compiler/procinfo.pas

@@ -108,9 +108,7 @@ unit procinfo;
 
           { Labels for TRUE/FALSE condition, BREAK and CONTINUE }
           CurrBreakLabel,
-          CurrContinueLabel,
-          CurrTrueLabel,
-          CurrFalseLabel : tasmlabel;
+          CurrContinueLabel : tasmlabel;
 
           { label to leave the sub routine }
           CurrExitLabel : tasmlabel;
@@ -160,12 +158,6 @@ unit procinfo;
           { Destroy the entire procinfo tree, starting from the outermost parent }
           procedure destroy_tree;
 
-          { Store CurrTrueLabel and CurrFalseLabel to saved and generate new ones }
-          procedure save_jump_labels(out saved: tsavedlabels);
-
-          { Restore CurrTrueLabel and CurrFalseLabel from saved }
-          procedure restore_jump_labels(const saved: tsavedlabels);
-
           function get_first_nestedproc: tprocinfo;
           function has_nestedprocs: boolean;
           function get_normal_proc: tprocinfo;
@@ -216,8 +208,6 @@ implementation
         current_asmdata.getjumplabel(CurrGOTLabel);
         CurrBreakLabel:=nil;
         CurrContinueLabel:=nil;
-        CurrTrueLabel:=nil;
-        CurrFalseLabel:=nil;
         if Assigned(parent) and (parent.procdef.parast.symtablelevel>=normal_function_level) then
           parent.addnestedproc(Self);
       end;
@@ -277,20 +267,6 @@ implementation
           result:=result.parent;
       end;
 
-    procedure tprocinfo.save_jump_labels(out saved: tsavedlabels);
-      begin
-        saved[false]:=CurrFalseLabel;
-        saved[true]:=CurrTrueLabel;
-        current_asmdata.getjumplabel(CurrTrueLabel);
-        current_asmdata.getjumplabel(CurrFalseLabel);
-      end;
-
-    procedure tprocinfo.restore_jump_labels(const saved: tsavedlabels);
-      begin
-        CurrFalseLabel:=saved[false];
-        CurrTrueLabel:=saved[true];
-      end;
-
     procedure tprocinfo.allocate_push_parasize(size:longint);
       begin
         if size>maxpushedparasize then

compiler/psystem.pas

@@ -719,18 +719,10 @@ implementation
         aiclass[ait_stab]:=tai_stab;
         aiclass[ait_force_line]:=tai_force_line;
         aiclass[ait_function_name]:=tai_function_name;
-{$ifdef alpha}
-          { the follow is for the DEC Alpha }
-        aiclass[ait_frame]:=tai_frame;
-{$endif alpha}
 {$ifdef m68k}
 { TODO: FIXME: tai_labeled_instruction doesn't exists}
 //        aiclass[ait_labeled_instruction]:=tai_labeled_instruction;
 {$endif m68k}
-{$ifdef ia64}
-        aiclass[ait_bundle]:=tai_bundle;
-        aiclass[ait_stop]:=tai_stop;
-{$endif ia64}
 {$ifdef SPARC}
 //        aiclass[ait_labeled_instruction]:=tai_labeled_instruction;
 {$endif SPARC}

compiler/ptype.pas

@@ -928,10 +928,7 @@ implementation
            include(current_structdef.defoptions,df_specialization);
          if assigned(old_current_structdef) and
              (df_generic in old_current_structdef.defoptions) then
-           begin
-             include(current_structdef.defoptions,df_generic);
-             current_genericdef:=current_structdef;
-           end;
+           include(current_structdef.defoptions,df_generic);
 
          insert_generic_parameter_types(current_structdef,genericdef,genericlist);
          { when we are parsing a generic already then this is a generic as
@@ -939,6 +936,8 @@ implementation
          if old_parse_generic then
            include(current_structdef.defoptions, df_generic);
          parse_generic:=(df_generic in current_structdef.defoptions);
+         if parse_generic and not assigned(current_genericdef) then
+           current_genericdef:=current_structdef;
          { in non-Delphi modes we need a strict private symbol without type
            count and type parameters in the name to simply resolving }
          maybe_insert_generic_rename_symbol(n,genericlist);

compiler/rgobj.pas

@@ -21,10 +21,11 @@
 
 {$i fpcdefs.inc}
 
+{ $define DEBUG_REGALLOC}
+
 { Allow duplicate allocations, can be used to get the .s file written }
 { $define ALLOWDUPREG}
 
-
 unit rgobj;
 
   interface
@@ -577,9 +578,9 @@ unit rgobj;
         insert_regalloc_info_all(list);
         ibitmap:=tinterferencebitmap.create;
         generate_interference_graph(list,headertai);
-{$ifdef DEBUG_SSA}
+{$ifdef DEBUG_REGALLOC}
         writegraph(rtindex);
-{$endif DEBUG_SSA}
+{$endif DEBUG_REGALLOC}
         inc(rtindex);
         { Don't do the real allocation when -sr is passed }
         if (cs_no_regalloc in current_settings.globalswitches) then
@@ -1116,7 +1117,7 @@ unit rgobj;
             for i:=1 to adj^.length do
               begin
                 n:=adj^.buf^[i-1];
-                if flags*[ri_coalesced,ri_selected]=[] then
+                if reginfo[n].flags*[ri_coalesced,ri_selected]=[] then
                   begin
                     supregset_include(done,n);
                     if reginfo[n].degree>=usable_registers_cnt then
@@ -1131,7 +1132,7 @@ unit rgobj;
             n:=adj^.buf^[i-1];
             if not supregset_in(done,n) and
                (reginfo[n].degree>=usable_registers_cnt) and
-               (reginfo[u].flags*[ri_coalesced,ri_selected]=[]) then
+               (reginfo[n].flags*[ri_coalesced,ri_selected]=[]) then
               inc(k);
           end;
       conservative:=(k<usable_registers_cnt);

compiler/scandir.pas

@@ -1203,7 +1203,7 @@ unit scandir;
     procedure dir_smartlink;
       begin
         do_moduleswitch(cs_create_smart);
-        if (paratargetdbg in [dbg_dwarf2,dbg_dwarf3]) and
+        if (target_dbg.id in [dbg_dwarf2,dbg_dwarf3]) and
             not(target_info.system in (systems_darwin+[system_i8086_msdos])) and
             { smart linking does not yet work with DWARF debug info on most targets }
             (cs_create_smart in current_settings.moduleswitches) and

compiler/sparc/ncpucnv.pas

@@ -233,13 +233,9 @@ implementation
         hreg1,hreg2 : tregister;
         resflags : tresflags;
         opsize   : tcgsize;
-        hlabel,oldTrueLabel,oldFalseLabel : tasmlabel;
+        hlabel   : tasmlabel;
         newsize  : tcgsize;
       begin
-        oldTrueLabel:=current_procinfo.CurrTrueLabel;
-        oldFalseLabel:=current_procinfo.CurrFalseLabel;
-        current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
-        current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
         secondpass(left);
         if codegenerror then
           exit;
@@ -257,8 +253,6 @@ implementation
                 hlcg.location_force_reg(current_asmdata.CurrAsmList,location,left.resultdef,resultdef,true)
               else
                 location.size:=newsize;
-              current_procinfo.CurrTrueLabel:=oldTrueLabel;
-              current_procinfo.CurrFalseLabel:=oldFalseLabel;
               exit;
            end;
 
@@ -320,13 +314,13 @@ implementation
             begin
               hreg1:=cg.getintregister(current_asmdata.CurrAsmList,OS_INT);
               current_asmdata.getjumplabel(hlabel);
-              cg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
+              cg.a_label(current_asmdata.CurrAsmList,left.location.truelabel);
               if not(is_cbool(resultdef)) then
                 cg.a_load_const_reg(current_asmdata.CurrAsmList,OS_INT,1,hreg1)
               else
                 cg.a_load_const_reg(current_asmdata.CurrAsmList,OS_INT,-1,hreg1);
               cg.a_jmp_always(current_asmdata.CurrAsmList,hlabel);
-              cg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+              cg.a_label(current_asmdata.CurrAsmList,left.location.falselabel);
               cg.a_load_const_reg(current_asmdata.CurrAsmList,OS_INT,0,hreg1);
               cg.a_label(current_asmdata.CurrAsmList,hlabel);
             end;
@@ -348,9 +342,6 @@ implementation
          else
 {$endif not cpu64bitalu}
            location.register:=hreg1;
-
-        current_procinfo.CurrTrueLabel:=oldTrueLabel;
-        current_procinfo.CurrFalseLabel:=oldFalseLabel;
       end;
 
 

compiler/systems.pas

@@ -223,7 +223,7 @@ interface
        systems_wince = [system_arm_wince,system_i386_wince];
        systems_android = [system_arm_android, system_i386_android, system_mipsel_android];
        systems_linux = [system_i386_linux,system_x86_64_linux,system_powerpc_linux,system_powerpc64_linux,
-                       system_arm_linux,system_sparc_linux,system_alpha_linux,system_m68k_linux,
+                       system_arm_linux,system_sparc_linux,system_m68k_linux,
                        system_x86_6432_linux,system_mipseb_linux,system_mipsel_linux,system_aarch64_linux];
        systems_dragonfly = [system_x86_64_dragonfly];
        systems_freebsd = [system_i386_freebsd,
@@ -241,10 +241,10 @@ interface
        systems_aix = [system_powerpc_aix,system_powerpc64_aix];
 
        { all real windows systems, no cripple ones like wince, wdosx et. al. }
-       systems_windows = [system_i386_win32,system_x86_64_win64,system_ia64_win64];
+       systems_windows = [system_i386_win32,system_x86_64_win64];
 
        { all windows systems }
-       systems_all_windows = [system_i386_win32,system_x86_64_win64,system_ia64_win64,
+       systems_all_windows = [system_i386_win32,system_x86_64_win64,
                              system_arm_wince,system_i386_wince];
 
        { all darwin systems }
@@ -259,7 +259,7 @@ interface
 
        { all embedded systems }
        systems_embedded = [system_i386_embedded,system_m68k_embedded,
-                           system_alpha_embedded,system_powerpc_embedded,
+                           system_powerpc_embedded,
                            system_sparc_embedded,system_vm_embedded,
                            system_iA64_embedded,system_x86_64_embedded,
                            system_mips_embedded,system_arm_embedded,
@@ -305,8 +305,7 @@ interface
                                          system_i386_Netware,
                                          system_i386_netwlibc,
                                          system_arm_wince,
-                                         system_x86_64_win64,
-                                         system_ia64_win64]+systems_linux+systems_android;
+                                         system_x86_64_win64]+systems_linux+systems_android;
 
        { all systems for which weak linking has been tested/is supported }
        systems_weak_linking = systems_darwin + systems_solaris + systems_linux + systems_android;
@@ -835,14 +834,6 @@ begin
   {$endif cpu68}
 {$endif m68k}
 
-{$ifdef alpha}
-  {$ifdef cpualpha}
-    default_target(source_info.system);
-  {$else cpualpha}
-    default_target(system_alpha_linux);
-  {$endif cpualpha}
-{$endif alpha}
-
 {$ifdef powerpc}
   {$ifdef cpupowerpc}
     default_target(source_info.system);

compiler/systems/i_linux.pas

@@ -359,70 +359,6 @@ unit i_linux;
             llvmdatalayout : 'E-p:64:64:64-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-f128:64:64-v128:128:128-n32:64';
           );
 
-       system_alpha_linux_info : tsysteminfo =
-          (
-            system       : system_alpha_LINUX;
-            name         : 'Linux for Alpha';
-            shortname    : 'Linux';
-            flags        : [tf_needs_symbol_size,tf_needs_symbol_type,tf_files_case_sensitive,
-                            tf_smartlink_library,tf_has_winlike_resources];
-            cpu          : cpu_alpha;
-            unit_env     : 'LINUXUNITS';
-            extradefines : 'UNIX;HASUNIX';
-            exeext       : '';
-            defext       : '.def';
-            scriptext    : '.sh';
-            smartext     : '.sl';
-            unitext      : '.ppu';
-            unitlibext   : '.ppl';
-            asmext       : '.s';
-            objext       : '.o';
-            resext       : '.res';
-            resobjext    : '.or';
-            sharedlibext : '.so';
-            staticlibext : '.a';
-            staticlibprefix : 'libp';
-            sharedlibprefix : 'lib';
-            sharedClibext : '.so';
-            staticClibext : '.a';
-            staticClibprefix : 'lib';
-            sharedClibprefix : 'lib';
-            importlibprefix : 'libimp';
-            importlibext : '.a';
-            Cprefix      : '';
-            newline      : #10;
-            dirsep       : '/';
-            assem        : as_gas;
-            assemextern  : as_gas;
-            link         : ld_none;
-            linkextern   : ld_linux;
-            ar           : ar_gnu_ar;
-            res          : res_elf;
-            dbg          : dbg_stabs;
-            script       : script_unix;
-            endian       : endian_little;
-            alignment    :
-              (
-                procalign       : 4;
-                loopalign       : 4;
-                jumpalign       : 0;
-                constalignmin   : 0;
-                constalignmax   : 4;
-                varalignmin     : 0;
-                varalignmax     : 4;
-                localalignmin   : 4;
-                localalignmax   : 4;
-                recordalignmin  : 0;
-                recordalignmax  : 2;
-                maxCrecordalign : 4
-              );
-            first_parm_offset : 8;
-            stacksize    : 32*1024*1024;
-            stackalign   : 8;  { ??? }
-            abi : abi_default;
-            llvmdatalayout : 'todo';
-          );
-
        system_x86_64_linux_info : tsysteminfo =
           (
             system       : system_x86_64_LINUX;
@@ -1047,11 +983,6 @@ initialization
     set_source_info(system_x86_64_linux_info);
   {$endif linux}
 {$endif CPUX86_64}
-{$ifdef CPUALPHA}
-  {$ifdef linux}
-    set_source_info(system_alpha_linux_info);
-  {$endif linux}
-{$endif CPUALPHA}
 {$ifdef CPUSPARC}
   {$ifdef linux}
     set_source_info(system_sparc_linux_info);

compiler/systems/t_msdos.pas

@@ -265,7 +265,7 @@ begin
 
   LinkRes.Add('option quiet');
 
-  if paratargetdbg in [dbg_dwarf2,dbg_dwarf3,dbg_dwarf4] then
+  if target_dbg.id in [dbg_dwarf2,dbg_dwarf3,dbg_dwarf4] then
     LinkRes.Add('debug dwarf');
 
   { add objectfiles, start with prt0 always }

compiler/systems/t_win.pas

@@ -956,7 +956,7 @@ implementation
                     imagebase:=$10000
                   else
 {$ifdef cpu64bitaddr}
-                    if (paratargetdbg = dbg_stabs) then
+                    if (target_dbg.id = dbg_stabs) then
                       imagebase:=$400000
                     else
                       imagebase:= $100000000;

compiler/version.pas

@@ -53,21 +53,12 @@ interface
 {$ifdef cpum68k}
         source_cpu_string = 'm68k';
 {$endif cpum68k}
-{$ifdef cpuia64}
-        source_cpu_string = 'ia64';
-{$endif cpuia64}
 {$ifdef cpux86_64}
         source_cpu_string = 'x86_64';
 {$endif cpux86_64}
 {$ifdef cpusparc}
         source_cpu_string = 'sparc';
 {$endif cpusparc}
-{$ifdef cpusalpha}
-        source_cpu_string = 'alpha';
-{$endif cpualpha}
-{$ifdef cpuvis}
-        source_cpu_string = 'vis';
-{$endif cpuvis}
 {$ifdef cpuarm}
         source_cpu_string = 'arm';
 {$endif cpuarm}

compiler/x86/agx86nsm.pas

@@ -1098,7 +1098,7 @@ interface
         AsmWriteLn('GROUP DGROUP rodata data fpc bss stack heap')
       else
         AsmWriteLn('GROUP DGROUP rodata data fpc bss');
-      if paratargetdbg in [dbg_dwarf2,dbg_dwarf3,dbg_dwarf4] then
+      if target_dbg.id in [dbg_dwarf2,dbg_dwarf3,dbg_dwarf4] then
         begin
           AsmWriteLn('SECTION .debug_frame  use32 class=DWARF align=4');
           AsmWriteLn('SECTION .debug_info   use32 class=DWARF align=4');

compiler/x86/nx86add.pas

@@ -132,14 +132,15 @@ unit nx86add;
                   (right.location.loc=LOC_CONSTANT) and
                   (right.location.value=0) then
                  begin
-                { 'test $-1,%reg' is transformable into 'test $-1,spilltemp' if %reg needs
-                   spilling, while 'test %reg,%reg' still requires loading into register.
-                   If spilling is not necessary, it is changed back into 'test %reg,%reg' by
-                   peephole optimizer (this optimization is currently available only for i386). }
-                   if (target_info.cpu=cpu_i386) then
-                     emit_const_reg(A_TEST,TCGSize2Opsize[opsize],aint(-1),left.location.register)
-                   else  
-                     emit_reg_reg(A_TEST,TCGSize2Opsize[opsize],left.location.register,left.location.register);
+                   { 'test $-1,%reg' is transformable into 'test $-1,spilltemp' if %reg needs
+                      spilling, while 'test %reg,%reg' still requires loading into register.
+                      If spilling is not necessary, it is changed back into 'test %reg,%reg' by
+                      peephole optimizer (this optimization is currently available only for i386). }
+{$ifdef i386}
+                   emit_const_reg(A_TEST,TCGSize2Opsize[opsize],aint(-1),left.location.register)
+{$else i386}
+                   emit_reg_reg(A_TEST,TCGSize2Opsize[opsize],left.location.register,left.location.register);
+{$endif i386}
                  end
                else
                  if (op=A_ADD) and

compiler/x86/nx86cnv.pas

@@ -92,13 +92,9 @@ implementation
         i         : integer;
 {$endif not cpu64bitalu}
         resflags  : tresflags;
-        hlabel,oldTrueLabel,oldFalseLabel : tasmlabel;
+        hlabel    : tasmlabel;
         newsize   : tcgsize;
       begin
-         oldTrueLabel:=current_procinfo.CurrTrueLabel;
-         oldFalseLabel:=current_procinfo.CurrFalseLabel;
-         current_asmdata.getjumplabel(current_procinfo.CurrTrueLabel);
-         current_asmdata.getjumplabel(current_procinfo.CurrFalseLabel);
          secondpass(left);
          if codegenerror then
           exit;
@@ -115,8 +111,6 @@ implementation
                 hlcg.location_force_reg(current_asmdata.CurrAsmList,location,left.resultdef,resultdef,true)
               else
                 location.size:=newsize;
-              current_procinfo.CurrTrueLabel:=oldTrueLabel;
-              current_procinfo.CurrFalseLabel:=oldFalseLabel;
               exit;
            end;
 
@@ -184,13 +178,13 @@ implementation
                 location_reset(location,LOC_REGISTER,def_cgsize(resultdef));
                 location.register:=cg.getintregister(current_asmdata.CurrAsmList,location.size);
                 current_asmdata.getjumplabel(hlabel);
-                cg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
+                cg.a_label(current_asmdata.CurrAsmList,left.location.truelabel);
                 if not(is_cbool(resultdef)) then
                   cg.a_load_const_reg(current_asmdata.CurrAsmList,location.size,1,location.register)
                 else
                   cg.a_load_const_reg(current_asmdata.CurrAsmList,location.size,-1,location.register);
                 cg.a_jmp_always(current_asmdata.CurrAsmList,hlabel);
-                cg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+                cg.a_label(current_asmdata.CurrAsmList,left.location.falselabel);
                 cg.a_load_const_reg(current_asmdata.CurrAsmList,location.size,0,location.register);
                 cg.a_label(current_asmdata.CurrAsmList,hlabel);
               end;
@@ -226,8 +220,6 @@ implementation
                    cg.a_op_reg_reg(current_asmdata.CurrAsmList,OP_NEG,location.size,location.register,location.register);
                end
            end;
-         current_procinfo.CurrTrueLabel:=oldTrueLabel;
-         current_procinfo.CurrFalseLabel:=oldFalseLabel;
        end;
 
 

compiler/x86_64/nx64flw.pas

@@ -507,7 +507,7 @@ procedure tx64tryexceptnode.pass_generate_code;
         cg.a_label(current_asmdata.CurrAsmList,breakexceptlabel);
         cg.g_call(current_asmdata.CurrAsmList,'FPC_DONEEXCEPTION');
         if (fc_unwind in flowcontrol) then
-          cg.g_local_unwind(current_asmdata.CurrAsmList,oldCurrExitLabel)
+          cg.g_local_unwind(current_asmdata.CurrAsmList,oldBreakLabel)
         else
           cg.a_jmp_always(current_asmdata.CurrAsmList,oldBreakLabel);
       end;
@@ -517,7 +517,7 @@ procedure tx64tryexceptnode.pass_generate_code;
         cg.a_label(current_asmdata.CurrAsmList,continueexceptlabel);
         cg.g_call(current_asmdata.CurrAsmList,'FPC_DONEEXCEPTION');
         if (fc_unwind in flowcontrol) then
-          cg.g_local_unwind(current_asmdata.CurrAsmList,oldCurrExitLabel)
+          cg.g_local_unwind(current_asmdata.CurrAsmList,oldContinueLabel)
         else
           cg.a_jmp_always(current_asmdata.CurrAsmList,oldContinueLabel);
       end;

packages/fcl-db/examples/createsql.lpi

@@ -0,0 +1,63 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="9"/>
+    <General>
+      <Flags>
+        <MainUnitHasCreateFormStatements Value="False"/>
+      </Flags>
+      <SessionStorage Value="InProjectDir"/>
+      <MainUnit Value="0"/>
+      <Title Value="Generate SQL Demo"/>
+      <UseAppBundle Value="False"/>
+      <ResourceType Value="res"/>
+    </General>
+    <i18n>
+      <EnableI18N LFM="False"/>
+    </i18n>
+    <VersionInfo>
+      <StringTable ProductVersion=""/>
+    </VersionInfo>
+    <BuildModes Count="1">
+      <Item1 Name="Default" Default="True"/>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+    </PublishOptions>
+    <RunParams>
+      <local>
+        <FormatVersion Value="1"/>
+      </local>
+    </RunParams>
+    <Units Count="1">
+      <Unit0>
+        <Filename Value="createsql.pas"/>
+        <IsPartOfProject Value="True"/>
+      </Unit0>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="11"/>
+    <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)"/>
+    </SearchPaths>
+    <Parsing>
+      <SyntaxOptions>
+        <UseAnsiStrings Value="False"/>
+      </SyntaxOptions>
+    </Parsing>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions Count="3">
+      <Item1>
+        <Name Value="EAbort"/>
+      </Item1>
+      <Item2>
+        <Name Value="ECodetoolError"/>
+      </Item2>
+      <Item3>
+        <Name Value="EFOpenError"/>
+      </Item3>
+    </Exceptions>
+  </Debugging>
+</CONFIG>

packages/fcl-db/examples/createsql.pas

@@ -0,0 +1,203 @@
+program createsql;
+
+{$mode objfpc}{$H+}
+
+uses
+  {$IFDEF UNIX}{$IFDEF UseCThreads}
+  cthreads,
+  {$ENDIF}{$ENDIF}
+  typinfo, Classes, SysUtils, CustApp, db, sqldb, fpdatadict,
+  fpddfb,fpddpq,fpddOracle,fpddsqlite3,fpddmysql40,fpddmysql41,fpddmysql50, fpddodbc,
+  strutils;
+
+
+type
+
+  { TGenSQLApplication }
+
+  TGenSQLApplication = class(TCustomApplication)
+  private
+    function CreateSQLEngine(AType: String): TFPDDSQLEngine;
+    procedure ConnectToDatabase(const AType, ADatabaseName,AUserName,APassword: String);
+    procedure DoConvertQuery(const S, T, KF: String; ST: TSTatementType);
+  protected
+    FConn : TSQLConnector;
+    FDD : TFPDataDictionary;
+    FENG  : TFPDDSQLEngine;
+    procedure DoRun; override;
+  public
+    constructor Create(TheOwner: TComponent); override;
+    destructor Destroy; override;
+    procedure WriteHelp(Const AMsg : string); virtual;
+  end;
+
+{ TGenSQLApplication }
+
+procedure TGenSQLApplication.ConnectToDatabase(Const AType,ADatabaseName,AUSerName,APassword : String);
+begin
+  FConn:=TSQLConnector.Create(Self);
+  FConn.ConnectorType:=AType;
+  FConn.DatabaseName:=ADatabaseName;
+  FConn.UserName:=AUserName;
+  FConn.Password:=APassword;
+  FConn.Transaction:=TSQLTransaction.Create(Self);
+  FConn.Connected:=True;
+  FDD:=TFPDataDictionary.Create;
+  FENG:=CreateSQLEngine(AType);
+end;
+
+Function TGenSQLApplication.CreateSQLEngine(AType : String): TFPDDSQLEngine;
+
+begin
+  Case lowercase(AType) of
+    'firebird' :  Result:=TFPDDFBSQLEngine.Create;
+  else
+    Result:=TFPDDSQLEngine.Create;
+  end;
+end;
+
+procedure TGenSQLApplication.DoConvertQuery(Const S,T,KF : String; ST : TSTatementType);
+
+Var
+  Q  : TSQLQuery;
+  TD : TDDTableDef;
+  Fields,KeyFields : TFPDDFieldList;
+  I : Integer;
+  F : TDDFieldDef;
+  FN,SQL : String;
+
+begin
+  TD:=FDD.Tables.AddTable(T);
+  Q:=TSQLQuery.Create(Self);
+  try
+    Q.Database:=FConn;
+    Q.Transaction:=FConn.Transaction;
+    Q.SQL.Text:=S;
+    Q.Open;
+    TD.ImportFromDataset(Q);
+  finally
+    Q.Free;
+  end;
+  if (KF<>'') then
+    begin
+    KeyFields:=TFPDDFieldList.Create(False);
+    For I:=1 to WordCount(KF,[',']) do
+      begin
+      FN:=ExtractWord(I,KF,[',']);
+      F:=TD.Fields.FieldByName(FN);
+      if (F=nil) then
+        Writeln('Warning: Field ',FN,' does not exist.')
+      else
+        KeyFields.Add(F);
+      end;
+    end;
+  Fields:=TFPDDFieldList.CreateFromTableDef(TD);
+  try
+    FEng.TableDef:=TD;
+    Case ST of
+      stDDL    : SQL:=FEng.CreateCreateSQL(KeyFields);
+      stSelect : SQL:=FEng.CreateSelectSQL(Fields,KeyFields);
+      stInsert : SQL:=FEng.CreateInsertSQL(Fields);
+      stUpdate : SQL:=FEng.CreateUpdateSQL(Fields,KeyFields);
+      stDelete : SQL:=FEng.CreateDeleteSQL(KeyFields);
+    end;
+    Writeln(SQL);
+  finally
+    KeyFields.Free;
+  end;
+end;
+procedure TGenSQLApplication.DoRun;
+
+var
+  ErrorMsg: String;
+  S,T,KF : String;
+  I : Integer;
+  ST : TStatementType;
+
+begin
+
+  // quick check parameters
+  ErrorMsg:=CheckOptions('hc:d:s:t:y:k:u:p:', 'help connection-type: database: sql: table: type: keyfields: user: password:');
+  if ErrorMsg<>'' then
+    WriteHelp(ErrorMsg);
+  if HasOption('h', 'help') then
+    WriteHelp('');
+  S:=GetOptionValue('c','connection-type');
+  T:=GetOptionValue('d','database');
+  if (S='') or (t='') then
+    Writehelp('Need database and connectiontype');
+  ConnectToDatabase(S,T,GetOptionValue('u','user'),GetOptionValue('p','password'));
+  S:=GetOptionValue('s','sql');
+  T:=GetOptionValue('t','table');
+  if (t='') then
+    Writehelp('Need table name');
+  i:=GetEnumValue(TypeInfo(TStatementType),'st'+GetOptionValue('y','type'));
+  if I=-1 then
+    Writehelp(Format('Unknown statement type : %s',[GetOptionValue('y','type')]));
+  ST:=TStatementType(i);
+  KF:=GetOptionValue('k','keyfields');
+  if (KF='') and  (st in [stselect, stupdate, stdelete]) then
+    Writehelp('Need key fields for delete, select and update');
+  if (S='') then
+    S:='SELECT * FROM '+T+' WHERE 0=1';
+  DoConvertQuery(S,T,KF,ST);
+  // stop program loop
+  Terminate;
+end;
+
+constructor TGenSQLApplication.Create(TheOwner: TComponent);
+begin
+  inherited Create(TheOwner);
+  StopOnException:=True;
+end;
+
+destructor TGenSQLApplication.Destroy;
+begin
+  FreeAndNil(FConn);
+  FreeAndNil(FDD);
+  FreeAndNil(FENG);
+  inherited Destroy;
+end;
+
+procedure TGenSQLApplication.WriteHelp(Const AMsg : string);
+
+Var
+  S : String;
+  L : TStrings;
+begin
+  if AMsg<>'' then
+    Writeln('Error : ',AMsg);
+  Writeln('Usage: ', ExeName, ' [options]');
+  Writeln('Where options is one or more of:');
+  Writeln('-h  --help              this help message');
+  Writeln('-c  --connection-type=ctype   Set connection type (required)' );
+  Writeln('-d  --database=db       database connection name (required)');
+  Writeln('-s  --sql=sql           SQL to execute (optional)');
+  Writeln('-t  --table=tablename   tablename to use for statement (required)');
+  Writeln('-y  --type=stype        Statement type (required) one of ddl, select, insert, update, delete)');
+  Writeln('-k  --keyfields=fields  Comma-separated list of key fields (required for delete, update, optional for select,ddl)');
+  Writeln('-u  --user=username     User name to connect to database');
+  Writeln('-p  --password=password Password of user to connect to database with');
+  Writeln('Where ctype is one of : ');
+  L:=TStringList.Create;
+  try
+    GetConnectionList(L);
+    for S in L do
+      Writeln('  ',lowercase(S));
+
+  finally
+    L.Free;
+  end;
+
+  Halt(Ord(AMsg<>''));
+end;
+
+var
+  Application: TGenSQLApplication;
+begin
+  Application:=TGenSQLApplication.Create(nil);
+  Application.Title:='Generate SQL Demo';
+  Application.Run;
+  Application.Free;
+end.
+

packages/fcl-db/examples/logsqldemo.lpi

@@ -0,0 +1,64 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="9"/>
+    <General>
+      <Flags>
+        <MainUnitHasCreateFormStatements Value="False"/>
+      </Flags>
+      <SessionStorage Value="InProjectDir"/>
+      <MainUnit Value="0"/>
+      <Title Value="Generate SQL Demo"/>
+      <UseAppBundle Value="False"/>
+      <ResourceType Value="res"/>
+    </General>
+    <i18n>
+      <EnableI18N LFM="False"/>
+    </i18n>
+    <VersionInfo>
+      <StringTable ProductVersion=""/>
+    </VersionInfo>
+    <BuildModes Count="1">
+      <Item1 Name="Default" Default="True"/>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+    </PublishOptions>
+    <RunParams>
+      <local>
+        <FormatVersion Value="1"/>
+        <CommandLineParams Value="-c firebird -d localhost:/home/firebird/timetrack.fb -u WISASOFT -p SysteemD -s 'SELECT * FROM PROJECT WHERE PJ_ID=:ID' -P ID=s:632F3D2F-055A-4DD9-852B-4050BF6A2ED9"/>
+      </local>
+    </RunParams>
+    <Units Count="1">
+      <Unit0>
+        <Filename Value="logsqldemo.pas"/>
+        <IsPartOfProject Value="True"/>
+      </Unit0>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="11"/>
+    <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)"/>
+    </SearchPaths>
+    <Parsing>
+      <SyntaxOptions>
+        <UseAnsiStrings Value="False"/>
+      </SyntaxOptions>
+    </Parsing>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions Count="3">
+      <Item1>
+        <Name Value="EAbort"/>
+      </Item1>
+      <Item2>
+        <Name Value="ECodetoolError"/>
+      </Item2>
+      <Item3>
+        <Name Value="EFOpenError"/>
+      </Item3>
+    </Exceptions>
+  </Debugging>
+</CONFIG>

packages/fcl-db/examples/logsqldemo.pas

@@ -0,0 +1,200 @@
+program logsqldemo;
+
+{$mode objfpc}{$H+}
+
+uses
+  {$IFDEF UNIX}{$IFDEF UseCThreads}
+  cthreads,
+  {$ENDIF}{$ENDIF}
+  typinfo, Classes, SysUtils, CustApp, db, sqldb,
+  ibconnection, sqlite3conn, oracleconnection, mysql40conn,mysql41conn, mssqlconn,
+  mysql50conn, mysql55conn, mysql56conn, odbcconn, pqconnection, strutils;
+
+
+type
+
+  { TGenSQLApplication }
+
+  TGenSQLApplication = class(TCustomApplication)
+    procedure DoSQLLog(Sender: TSQLConnection; EventType: TDBEventType;
+      const Msg: String);
+  private
+    procedure ConnectToDatabase(const AType, ADatabaseName,AUserName,APassword: String);
+    procedure RunQuery(SQL: String; ParamValues: TStrings);
+  protected
+    FConn : TSQLConnector;
+    procedure DoRun; override;
+  public
+    constructor Create(TheOwner: TComponent); override;
+    destructor Destroy; override;
+    procedure WriteHelp(Const AMsg : string); virtual;
+  end;
+
+{ TGenSQLApplication }
+
+procedure TGenSQLApplication.DoSQLLog(Sender: TSQLConnection;
+  EventType: TDBEventType; const Msg: String);
+begin
+  Writeln(stderr,'[',EventType,'] : ',Msg);
+end;
+
+procedure TGenSQLApplication.ConnectToDatabase(const AType, ADatabaseName,
+  AUserName, APassword: String);
+begin
+  FConn:=TSQLConnector.Create(Self);
+  FConn.ConnectorType:=AType;
+  FConn.DatabaseName:=ADatabaseName;
+  FConn.UserName:=AUserName;
+  FConn.Password:=APassword;
+  FConn.Transaction:=TSQLTransaction.Create(Self);
+  FConn.OnLog:=@DoSQLLog;
+  FConn.LogEvents:=LogAllEventsExtra;
+  FConn.Connected:=True;
+end;
+
+procedure TGenSQLApplication.RunQuery(SQL : String; ParamValues : TStrings);
+
+Var
+  S,PT,V : String;
+  I : Integer;
+  P : TParam;
+  Q : TSQLQuery;
+  F : TField;
+
+begin
+  Q:=TSQLQuery.Create(Self);
+  try
+    Q.Database:=FConn;
+    Q.Transaction:=FConn.Transaction;
+    Q.SQL.Text:=SQL;
+    For P in Q.Params do
+      begin
+      S:=ParamValues.Values[P.Name];
+      PT:=ExtractWord(1,S,[':']);
+      V:=ExtractWord(2,S,[':']);
+      Case lowercase(PT) of
+        's' : P.AsString:=V;
+        'i'    : P.AsInteger:=StrToInt(V);
+        'i64'  : P.AsLargeInt:=StrToInt64(V);
+        'dt'   : P.AsDateTime:=StrToDateTime(V);
+        'd'    : P.AsDateTime:=StrToDate(V);
+        't'    : P.AsDateTime:=StrToTime(V);
+        'f'    : P.AsFloat:=StrToFloat(V);
+        'c'    : P.AsCurrency:=StrToCurr(V);
+      else
+        Raise Exception.CreateFmt('unknown parameter type for %s : %s (value: %s)',[P.Name,PT,V]);
+      end
+      end;
+    Q.Open;
+    I:=0;
+    While not Q.EOF do
+      begin
+      Inc(I);
+      Writeln('Record ',I,':');
+      For F in Q.Fields do
+        if F.IsNull then
+          writeln(F.FieldName,'=<Null>')
+        else
+          writeln(F.FieldName,'=',F.AsString);
+      Q.Next;
+      end;
+  finally
+    Q.Free;
+  end;
+end;
+
+procedure TGenSQLApplication.DoRun;
+
+var
+  ErrorMsg: String;
+  S,T,KF : String;
+  I : Integer;
+  ST : TStatementType;
+  P : TStrings;
+
+begin
+
+  // quick check parameters
+  ErrorMsg:=CheckOptions('hc:d:s:u:p:P:', 'help connection-type: database: sql: user: password: param:');
+  if ErrorMsg<>'' then
+    WriteHelp(ErrorMsg);
+  if HasOption('h', 'help') then
+    WriteHelp('');
+  S:=GetOptionValue('c','connection-type');
+  T:=GetOptionValue('d','database');
+  if (S='') or (t='') then
+    Writehelp('Need database and connectiontype');
+  ConnectToDatabase(S,T,GetOptionValue('u','user'),GetOptionValue('p','password'));
+  S:=GetOptionValue('s','sql');
+  P:=TStringList.Create;
+  try
+    P.AddStrings(GetOptionValues('P','param'));
+    RunQuery(S,P);
+  finally
+    P.Free;
+  end;
+  // stop program loop
+  Terminate;
+end;
+
+constructor TGenSQLApplication.Create(TheOwner: TComponent);
+begin
+  inherited Create(TheOwner);
+  StopOnException:=True;
+end;
+
+destructor TGenSQLApplication.Destroy;
+begin
+  FreeAndNil(FConn);
+  inherited Destroy;
+end;
+
+procedure TGenSQLApplication.WriteHelp(const AMsg: string);
+
+Var
+  S : String;
+  L : TStrings;
+begin
+  if AMsg<>'' then
+    Writeln('Error : ',AMsg);
+  Writeln('Usage: ', ExeName, ' [options]');
+  Writeln('Where options is one or more of:');
+  Writeln('-h  --help              this help message');
+  Writeln('-c  --connection-type=ctype   Set connection type (required)' );
+  Writeln('Where ctype is one of : ');
+  L:=TStringList.Create;
+  try
+    GetConnectionList(L);
+    for S in L do
+      Writeln('  ',lowercase(S));
+
+  finally
+    L.Free;
+  end;
+  Writeln('-d  --database=db       database connection name (required)');
+  Writeln('-s  --sql=sql           SQL to execute (required), can contain parameters');
+  Writeln('-u  --user=username     User name to connect to database');
+  Writeln('-p  --password=password Password of user to connect to database with');
+  Writeln('-P  --param=name=value  Parameter values encoded as ptype:value');
+  Writeln('Where ptype is one of : ');
+  Writeln('  s  : string');
+  Writeln('  dt : datetime');
+  Writeln('  d  : date');
+  Writeln('  t  : time');
+  Writeln('  i  : integer');
+  Writeln('  i64  : int64');
+  Writeln('  f  : float');
+  Writeln('  c  : currency');
+
+  Halt(Ord(AMsg<>''));
+end;
+
+var
+  Application: TGenSQLApplication;
+begin
+  Application:=TGenSQLApplication.Create(nil);
+  Application.Title:='Generate SQL Demo';
+  Application.Run;
+  Application.Free;
+end.
+

packages/fcl-db/tests/sqlite3dstoolsunit.pas

@@ -0,0 +1,203 @@
+unit Sqlite3DSToolsUnit;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, toolsunit
+  ,db, Sqlite3DS
+  ;
+
+
+const
+  STestNotApplicable = 'This test does not apply to this sqlite3ds connection type';
+
+
+type
+  { TSqlite3DSDBConnector }
+
+  TSqlite3DSDBConnector = class(TDBConnector)
+  private
+    FDataset: TSqlite3Dataset;
+    Function CreateDataset: TSqlite3Dataset;
+  protected
+    procedure CreateNDatasets; override;
+    procedure CreateFieldDataset; override;
+    procedure DropNDatasets; override;
+    procedure DropFieldDataset; override;
+    Function InternalGetNDataset(n : integer) : TDataset; override;
+    Function InternalGetFieldDataset : TDataSet; override;
+  public
+    procedure TryDropIfExist(const ATableName : String);
+    destructor Destroy; override;
+    constructor Create; override;
+    procedure ExecuteDirect(const SQL: string);
+  end;
+
+
+implementation
+
+{ TSqlite3DSDBConnector }
+
+function TSqlite3DSDBConnector.CreateDataset: TSqlite3Dataset;
+
+begin
+  Result := TSqlite3Dataset.create(nil);
+  Result.FileName := dbname;
+end;
+
+procedure TSqlite3DSDBConnector.CreateNDatasets;
+var CountID : Integer;
+begin
+  try
+    TryDropIfExist('FPDEV');
+    FDataset.ExecSQL('create table FPDEV (' +
+                              '  ID INT NOT NULL,  ' +
+                              '  NAME VARCHAR(50), ' +
+                              '  PRIMARY KEY (ID)  ' +
+                              ')');
+    FDataset.ExecSQL('BEGIN;');
+    for countID := 1 to MaxDataSet do
+      FDataset.ExecSQL('insert into FPDEV (ID,NAME) ' +
+                                'values ('+inttostr(countID)+',''TestName'+inttostr(countID)+''')');
+    FDataset.ExecSQL('COMMIT;');
+  except
+    on E: Exception do begin
+      if dblogfilename<>'' then
+        LogMessage('Custom','Exception running CreateNDatasets: '+E.Message);
+      FDataset.ExecSQL('ROLLBACK;');
+    end;
+  end;
+end;
+
+procedure TSqlite3DSDBConnector.CreateFieldDataset;
+var
+  FieldDataset: TSqlite3Dataset;
+  i: Integer;
+
+begin
+  FieldDataset := CreateDataset;
+  try
+    TryDropIfExist('FPDEV_FIELD');
+    with FieldDataset do
+    begin
+       TableName := 'FPDEV_FIELD';
+       PrimaryKey := 'ID';
+       FieldDefs.Add('ID', ftInteger);
+       FieldDefs.Add('FSTRING', ftString, 10);
+       //FieldDefs.Add('FSMALLINT', ftSmallint);
+       FieldDefs.Add('FINTEGER', ftInteger);
+       FieldDefs.Add('FWORD', ftWord);
+       FieldDefs.Add('FBOOLEAN', ftBoolean);
+       FieldDefs.Add('FFLOAT', ftFloat);
+       FieldDefs.Add('FCURRENCY', ftCurrency);
+       //FieldDefs.Add('FBCD', ftBCD);
+       FieldDefs.Add('FDATE', ftDate);
+       FieldDefs.Add('FDATETIME', ftDateTime);
+       FieldDefs.Add('FLARGEINT', ftLargeint);
+       FieldDefs.Add('FMEMO', ftMemo);
+       if not CreateTable then
+         raise Exception.Create('Error in CreateTable: ' + FieldDataset.ReturnString);
+       Open;
+       for i := 0 to testValuesCount - 1 do
+       begin
+         Append;
+         FieldByName('ID').AsInteger := i;
+         FieldByName('FSTRING').AsString := testStringValues[i];
+         //FieldByName('FSMALLINT').AsInteger := testSmallIntValues[i];
+         FieldByName('FINTEGER').AsInteger := testIntValues[i];
+         FieldByName('FWORD').AsInteger := testWordValues[i];
+         FieldByName('FBOOLEAN').AsBoolean := testBooleanValues[i];
+         FieldByName('FFLOAT').AsFloat := testFloatValues[i];
+         FieldByName('FCURRENCY').AsCurrency := testCurrencyValues[i];
+         // work around missing TBCDField.AsBCD:
+         //  FieldByName('FBCD').AsBCD := StrToBCD(testFmtBCDValues[i],Self.FormatSettings);
+         FieldByName('FDATE').AsDateTime := StrToDate(testDateValues[i], 'yyyy/mm/dd', '-');
+         FieldByName('FDATETIME').AsDateTime := StrToDateTime(testValues[ftDateTime,i], Self.FormatSettings);
+         FieldByName('FLARGEINT').AsLargeInt := testLargeIntValues[i];
+         FieldByName('FMEMO').AsString := testStringValues[i];
+         Post;
+       end;
+       if not ApplyUpdates then
+         raise Exception.Create('Error in ApplyUpdates: ' + FieldDataset.ReturnString);
+       Destroy;
+     end;
+  except
+    on E: Exception do begin
+      if dblogfilename<>'' then
+        LogMessage('Custom','Exception running CreateFieldDataset: '+E.Message);
+      FDataset.ExecSQL('ROLLBACK;');
+    end;
+  end;
+end;
+
+procedure TSqlite3DSDBConnector.DropNDatasets;
+begin
+  try
+    FDataset.ExecSQL('DROP TABLE FPDEV');
+  Except
+    on E: Exception do begin
+      if dblogfilename<>'' then
+        LogMessage('Custom','Exception running DropNDatasets: '+E.Message);
+      FDataset.ExecSQL('ROLLBACK;');
+    end;
+  end;
+end;
+
+procedure TSqlite3DSDBConnector.DropFieldDataset;
+begin
+  try
+    FDataset.ExecSQL('DROP TABLE FPDEV_FIELD');
+  Except
+    on E: Exception do begin
+      if dblogfilename<>'' then
+        LogMessage('Custom','Exception running DropFieldDataset: '+E.Message);
+      FDataset.ExecSQL('ROLLBACK;');
+    end;
+  end;
+end;
+
+function TSqlite3DSDBConnector.InternalGetNDataset(n: integer): TDataset;
+begin
+  Result := CreateDataset;
+  with (Result as TSqlite3Dataset) do
+    begin
+    sql := 'SELECT * FROM FPDEV WHERE ID < '+inttostr(n+1)+' ORDER BY ID';
+    end;
+end;
+
+function TSqlite3DSDBConnector.InternalGetFieldDataset: TDataSet;
+begin
+  Result := CreateDataset;
+  with (Result as TSqlite3Dataset) do
+    begin
+    sql := 'SELECT * FROM FPDEV_FIELD';
+    end;
+end;
+
+procedure TSqlite3DSDBConnector.TryDropIfExist(const ATableName: String);
+begin
+  FDataset.ExecSQL('drop table if exists ' + ATableName);
+end;
+
+procedure TSqlite3DSDBConnector.ExecuteDirect(const SQL: string);
+begin
+  FDataset.ExecSQL(SQL);
+end;
+
+destructor TSqlite3DSDBConnector.Destroy;
+begin
+  inherited Destroy;
+  FDataset.Destroy;
+end;
+
+constructor TSqlite3DSDBConnector.Create;
+begin
+  FDataset := CreateDataset;
+  Inherited;
+end;
+
+initialization
+  RegisterClass(TSqlite3DSDBConnector);
+end.

packages/fcl-json/src/fpjson.pp

@@ -46,6 +46,9 @@ Const
   AsJSONFormat      = [foSingleLineArray,foSingleLineObject]; // These options make FormatJSON behave as AsJSON
   AsCompressedJSON  = [foSingleLineArray,foSingleLineObject,foskipWhiteSpace]; // These options make FormatJSON behave as AsJSON with TJSONData.CompressedJSON=True
   AsCompactJSON     = [foSingleLineArray,foSingleLineObject,foskipWhiteSpace,foDoNotQuoteMembers]; // These options make FormatJSON behave as AsJSON with TJSONData.CompressedJSON=True and TJSONObject.UnquotedMemberNames=True
+  ValueJSONTypes    = [jtNumber, jtString, jtBoolean, jtNull];
+  ActualValueJSONTypes = ValueJSONTypes - [jtNull];
+  StructuredJSONTypes  = [jtArray,jtObject];
 
 Type
   TJSONData = Class;

packages/fcl-json/src/jsonconf.pp

@@ -30,12 +30,9 @@ interface
 uses
   SysUtils, Classes, fpjson, jsonscanner,jsonparser;
 
-resourcestring
-  SWrongRootName = 'XML file has wrong root element name';
 
 type
   EJSONConfigError = class(Exception);
-  TPathFlags = set of (pfHasValue, pfWriteAccess);
 
 (* ********************************************************************
    "APath" is the path and name of a value: A JSON configuration file 
@@ -70,9 +67,9 @@ type
     procedure Loaded; override;
     function FindPath(Const APath: UnicodeString; AllowCreate : Boolean) : TJSONObject;
     function FindObject(Const APath: UnicodeString; AllowCreate : Boolean) : TJSONObject;
-    function FindObject(Const APath: UnicodeString; AllowCreate : Boolean;Var ElName : UnicodeString) : TJSONObject;
-    function FindElement(Const APath: UnicodeString; CreateParent : Boolean) : TJSONData;
-    function FindElement(Const APath: UnicodeString; CreateParent : Boolean; Var AParent : TJSONObject; Var ElName : UnicodeString) : TJSONData;
+    function FindObject(Const APath: UnicodeString; AllowCreate : Boolean;Out ElName : UnicodeString) : TJSONObject;
+    function FindElement(Const APath: UnicodeString; CreateParent : Boolean; AllowObject : Boolean = False) : TJSONData;
+    function FindElement(Const APath: UnicodeString; CreateParent : Boolean; out AParent : TJSONObject; Out ElName : UnicodeString; AllowObject : Boolean = False) : TJSONData;
   public
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
@@ -90,11 +87,14 @@ type
     function  GetValue(const APath: UnicodeString; ADefault: Int64): Int64; overload;
     function  GetValue(const APath: UnicodeString; ADefault: Boolean): Boolean; overload;
     function  GetValue(const APath: UnicodeString; ADefault: Double): Double; overload;
+    Function GetValue(const APath: UnicodeString; AValue: TStrings; Const ADefault: String) : Boolean; overload;
+    Function GetValue(const APath: UnicodeString; AValue: TStrings; Const ADefault: TStrings): Boolean; overload;
     procedure SetValue(const APath: UnicodeString; const AValue: UnicodeString); overload;
     procedure SetValue(const APath: UnicodeString; AValue: Integer); overload;
     procedure SetValue(const APath: UnicodeString; AValue: Int64); overload;
     procedure SetValue(const APath: UnicodeString; AValue: Boolean); overload;
     procedure SetValue(const APath: UnicodeString; AValue: Double); overload;
+    procedure SetValue(const APath: UnicodeString; AValue: TStrings; AsObject : Boolean = False); overload;
 
     procedure SetDeleteValue(const APath: UnicodeString; const AValue, DefValue: UnicodeString); overload;
     procedure SetDeleteValue(const APath: UnicodeString; AValue, DefValue: Integer); overload;
@@ -116,7 +116,7 @@ type
 
 implementation
 
-Const
+Resourcestring
   SErrInvalidJSONFile = '"%s" is not a valid JSON configuration file.';
   SErrCouldNotOpenKey = 'Could not open key "%s".';
 
@@ -181,7 +181,7 @@ begin
 end;
 
 function TJSONConfig.FindObject(const APath: UnicodeString; AllowCreate: Boolean;
-  var ElName: UnicodeString): TJSONObject;
+  out ElName: UnicodeString): TJSONObject;
 
 Var
   S,El : UnicodeString;
@@ -247,20 +247,19 @@ begin
   ElName:=S;
 end;
 
-function TJSONConfig.FindElement(const APath: UnicodeString; CreateParent: Boolean
-  ): TJSONData;
+function TJSONConfig.FindElement(const APath: UnicodeString; CreateParent: Boolean; AllowObject : Boolean = False): TJSONData;
 
 Var
   O : TJSONObject;
   ElName : UnicodeString;
   
 begin
-  Result:=FindElement(APath,CreateParent,O,ElName);
+  Result:=FindElement(APath,CreateParent,O,ElName,AllowObject);
 end;
 
 function TJSONConfig.FindElement(const APath: UnicodeString;
-  CreateParent: Boolean; var AParent: TJSONObject; var ElName: UnicodeString
-  ): TJSONData;
+  CreateParent: Boolean; out AParent: TJSONObject; out ElName: UnicodeString;
+  AllowObject : Boolean = False): TJSONData;
 
 Var
   I : Integer;
@@ -273,9 +272,10 @@ begin
 //    Writeln('Found parent, looking for element:',elName);
     I:=AParent.IndexOfName(ElName);
 //    Writeln('Element index is',I);
-    If (I<>-1) And (AParent.items[I].JSONType<>jtObject) then
+    If (I<>-1) And ((AParent.items[I].JSONType<>jtObject) or AllowObject) then
       Result:=AParent.Items[i];
     end;
+//  Writeln('Find ',aPath,' in "',FJSON.AsJSOn,'" : ',Elname,' : ',Result<>NIl);
 end;
 
 
@@ -350,6 +350,44 @@ begin
     Result:=StrToFloatDef(El.AsString,ADefault);
 end;
 
+function TJSONConfig.GetValue(const APath: UnicodeString; AValue: TStrings;
+  const ADefault: String): Boolean;
+var
+  El : TJSONData;
+  D : TJSONEnum;
+
+begin
+  AValue.Clear;
+  El:=FindElement(StripSlash(APath),False,True);
+  Result:=Assigned(el);
+  If Not Result then
+    begin
+    AValue.Text:=ADefault;
+    exit;
+    end;
+  Case El.JSONType of
+    jtArray:
+      For D in El do
+        if D.Value.JSONType in ActualValueJSONTypes then
+          AValue.Add(D.Value.AsString);
+    jtObject:
+      For D in El do
+        if D.Value.JSONType in ActualValueJSONTypes then
+          AValue.Add(D.Key+'='+D.Value.AsString);
+  else
+    AValue.Text:=EL.AsString
+  end;
+
+end;
+
+function TJSONConfig.GetValue(const APath: UnicodeString; AValue: TStrings;
+  const ADefault: TStrings): Boolean;
+begin
+  Result:=GetValue(APath,AValue,'');
+  If Not Result then
+    AValue.Assign(ADefault);
+end;
+
 
 procedure TJSONConfig.SetValue(const APath: UnicodeString; const AValue: UnicodeString);
 
@@ -509,6 +547,58 @@ begin
   FModified:=True;
 end;
 
+procedure TJSONConfig.SetValue(const APath: UnicodeString; AValue: TStrings; AsObject : Boolean = False);
+var
+  El : TJSONData;
+  ElName : UnicodeString;
+  O : TJSONObject;
+  I : integer;
+  A : TJSONArray;
+  N,V : String;
+  DoDelete: Boolean;
+
+begin
+  El:=FindElement(StripSlash(APath),True,O,ElName,True);
+  if Assigned(El) then
+    begin
+    if AsObject then
+      DoDelete:=(Not (El is TJSONObject))
+    else
+      DoDelete:=(Not (El is TJSONArray));
+    if DoDelete then
+      begin
+      I:=O.IndexOfName(elName);
+      O.Delete(i);
+      El:=Nil;
+      end;
+    end;
+  If Not Assigned(el) then
+    begin
+    if AsObject then
+      El:=TJSONObject.Create
+    else
+      El:=TJSONArray.Create;
+    O.Add(ElName,El);
+    end;
+  if Not AsObject then
+    begin
+    A:=El as TJSONArray;
+    A.Clear;
+    For N in Avalue do
+      A.Add(N);
+    end
+  else
+    begin
+    O:=El as TJSONObject;
+    For I:=0 to AValue.Count-1 do
+      begin
+      AValue.GetNameValue(I,N,V);
+      O.Add(N,V);
+      end;
+    end;
+  FModified:=True;
+end;
+
 procedure TJSONConfig.SetDeleteValue(const APath: UnicodeString; AValue,
   DefValue: Boolean);
 begin
@@ -621,7 +711,7 @@ begin
   DoSetFilename(AFilename, False);
 end;
 
-function TJSONConfig.StripSlash(Const P: UnicodeString): UnicodeString;
+function TJSONConfig.StripSlash(const P: UnicodeString): UnicodeString;
 
 Var
   L : Integer;
@@ -643,7 +733,6 @@ end;
 procedure TJSONConfig.OpenKey(const aPath: UnicodeString; AllowCreate: Boolean);
 
 Var
-  ElName : UnicodeString;
   P : String;
   L : Integer;
 begin

packages/fcl-json/tests/jsonconftest.pp

@@ -13,6 +13,8 @@ type
 
   TTestJSONConfig= class(TTestCase)
   Private
+    procedure AssertStrings(Msg: String; L: TStrings;
+      const Values: array of string);
     Function CreateConf(AFileName : String) : TJSONCOnfig;
     Procedure DeleteConf(C : TJSONConfig; DeleteConfFile : Boolean = true);
   published
@@ -22,6 +24,7 @@ type
     procedure TestEnumValues;
     procedure TestClear;
     procedure TestKey;
+    procedure TestStrings;
   end;
 
 implementation
@@ -253,6 +256,67 @@ begin
   end;
 end;
 
+procedure TTestJSONConfig.AssertStrings(Msg : String; L : TStrings; Const Values : Array of string);
+
+Var
+  I : Integer;
+begin
+  Msg:=Msg+': ';
+  AssertNotNull(Msg+'Have strings',L);
+  AssertEquals(Msg+'Correct element count',Length(Values),L.Count);
+  For I:=0 to L.Count-1 do
+    AssertEquals(Msg+'element '+IntToStr(i),Values[i],l[i]);
+end;
+
+procedure TTestJSONConfig.TestStrings;
+
+Var
+  C : TJSONCOnfig;
+  L,LD : TStrings;
+
+begin
+  L:=Nil;
+  LD:=Nil;
+  C:=CreateConf('test.json');
+  try
+    L:=TStringList.Create;
+    LD:=TStringList.Create;
+    L.Add('abc');
+    C.GetValue('list',L,'');
+    AssertStrings('Clear, no default.',L,[]);
+    C.GetValue('list',L,'text');
+    AssertStrings('Use default.',L,['text']);
+    L.Clear;
+    L.Add('abc');
+    L.Add('def');
+    C.SetValue('a',L);
+    C.GetValue('a',LD,'');
+    AssertStrings('List',LD,['abc','def']);
+    L.Clear;
+    L.Add('abc=1');
+    L.Add('def=2');
+    C.SetValue('a',L,True);
+    LD.Clear;
+    C.GetValue('a',LD,'');
+    AssertStrings('List',LD,['abc=1','def=2']);
+    C.SetValue('a','abc');
+    C.GetValue('a',L,'');
+    AssertStrings('String',L,['abc']);
+    C.SetValue('a',Integer(1));
+    C.GetValue('a',L,'');
+    AssertStrings('integer',L,['1']);
+    C.SetValue('a',True);
+    C.GetValue('a',L,'');
+    AssertStrings('integer',L,['True']);
+    C.SetValue('a',Int64(1));
+    C.GetValue('a',L,'');
+    AssertStrings('int64',L,['1']);
+  finally
+    L.Free;
+    C.Free;
+  end;
+end;
+
 
 initialization
 

packages/fcl-json/tests/testjsonconf.pp

@@ -18,6 +18,8 @@ var
   Application: TMyTestRunner;
 
 begin
+  DefaultFormat:=fPlain;
+  DefaultRunAllTests:=True;
   Application := TMyTestRunner.Create(nil);
   Application.Initialize;
   Application.Run;

packages/fcl-web/src/base/cgiprotocol.pp

@@ -0,0 +1,81 @@
+unit cgiprotocol;
+
+{$mode objfpc}{$H+}
+
+interface
+
+Const
+  CGIVarCount = 45 ;
+
+Type
+  TCGIVarArray = Array[1..CGIVarCount] of String;
+
+Const
+  CgiVarNames : TCGIVarArray =
+   ({ 1  } 'AUTH_TYPE',
+    { 2  } 'CONTENT_LENGTH',
+    { 3  } 'CONTENT_TYPE',
+    { 4  } 'GATEWAY_INTERFACE',
+    { 5  } 'PATH_INFO',
+    { 6  } 'PATH_TRANSLATED',
+    { 7  } 'QUERY_STRING',
+    { 8  } 'REMOTE_ADDR',
+    { 9  } 'REMOTE_HOST',
+    { 10 } 'REMOTE_IDENT',
+    { 11 } 'REMOTE_USER',
+    { 12 } 'REQUEST_METHOD',
+    { 13 } 'SCRIPT_NAME',
+    { 14 } 'SERVER_NAME',
+    { 15 } 'SERVER_PORT',
+    { 16 } 'SERVER_PROTOCOL',
+    { 17 } 'SERVER_SOFTWARE',
+    { 18 } 'HTTP_ACCEPT',
+    { 19 } 'HTTP_ACCEPT_CHARSET',
+    { 20 } 'HTTP_ACCEPT_ENCODING',
+    { 21 } 'HTTP_IF_MODIFIED_SINCE',
+    { 22 } 'HTTP_REFERER',
+    { 23 } 'HTTP_USER_AGENT',
+    { 24 } 'HTTP_COOKIE',
+    { 25 } 'HTTP_IF_NONE_MATCH',
+
+     // Additional Apache vars
+    { 26 } 'HTTP_CONNECTION',
+    { 27 } 'HTTP_ACCEPT_LANGUAGE',
+    { 28 } 'HTTP_HOST',
+    { 29 } 'SERVER_SIGNATURE',
+    { 30 } 'SERVER_ADDR',
+    { 31 } 'DOCUMENT_ROOT',
+    { 32 } 'SERVER_ADMIN',
+    { 33 } 'SCRIPT_FILENAME',
+    { 34 } 'REMOTE_PORT',
+    { 35 } 'REQUEST_URI',
+    { 36 } 'CONTENT',
+    { 37 } 'HTTP_X_REQUESTED_WITH',
+    { 38 } 'HTTP_AUTHORIZATION',
+    { 39 } 'SCRIPT_URI',
+    { 40 } 'SCRIPT_URL',
+    { 41 } 'CONTEXT_DOCUMENT_ROOT',
+    { 42 } 'CONTEXT_PREFIX',
+    { 43 } 'HTTP_CACHE_CONTROL',
+    { 44 } 'HTTP_PRAGMA',
+    { 45 } 'REQUEST_SCHEME'
+    );
+
+Function IndexOfCGIVar(AVarName: String): Integer;
+
+implementation
+
+uses sysutils;
+
+Function IndexOfCGIVar(AVarName: String): Integer;
+
+begin
+  Result:=CGIVarCount;
+  While (Result>0) and (CompareText(AVarName,CgiVarNames[Result])<>0) do
+    Dec(Result);
+  If Result<1 then
+    Result:=-1;
+end;
+
+end.
+

packages/fcl-web/src/base/fphttpwebclient.pp

@@ -0,0 +1,156 @@
+{ **********************************************************************
+  This file is part of the Free Component Library (FCL)
+  Copyright (c) 2015 by the Free Pascal development team
+        
+  FPHTTPClient implementation of TFPWebclient.
+            
+  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 fphttpwebclient;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, fpwebclient, fphttpclient;
+
+Type
+
+  { TFPHTTPRequest }
+
+  TFPHTTPRequest = Class(TWebClientRequest)
+  Private
+    FHTTP : TFPHTTPClient;
+  Public
+    function GetHeaders: TStrings;override;
+    Constructor Create(AHTTP : TFPHTTPClient);
+    Destructor Destroy; override;
+  end;
+
+  { TFPHTTPRequest }
+
+  TFPHTTPResponse = Class(TWebClientResponse)
+  Private
+    FHTTP : TFPHTTPClient;
+  Protected
+    function GetHeaders: TStrings;override;
+    Function GetStatusCode : Integer; override;
+    Function GetStatusText : String; override;
+  Public
+    Constructor Create(AHTTP : TFPHTTPRequest);
+  end;
+
+  { TFPHTTPWebClient }
+
+  TFPHTTPWebClient = Class(TAbstractWebClient)
+  Protected
+    Function DoCreateRequest: TWebClientRequest; override;
+    Function DoHTTPMethod(Const AMethod,AURL : String; ARequest : TWebClientRequest) : TWebClientResponse; override;
+  end;
+
+implementation
+
+uses dateutils;
+
+{ TFPHTTPRequest }
+
+function TFPHTTPRequest.GetHeaders: TStrings;
+begin
+  Result:=FHTTP.RequestHeaders;
+end;
+
+constructor TFPHTTPRequest.Create(AHTTP: TFPHTTPClient);
+begin
+  FHTTP:=AHTTP;
+end;
+
+destructor TFPHTTPRequest.Destroy;
+begin
+  FreeAndNil(FHTTP);
+  inherited Destroy;
+end;
+
+{ TFPHTTPResponse }
+
+function TFPHTTPResponse.GetHeaders: TStrings;
+begin
+  if Assigned(FHTTP) then
+    Result:=FHTTP.ResponseHeaders
+  else
+    Result:=Inherited GetHeaders;
+end;
+
+Function TFPHTTPResponse.GetStatusCode: Integer;
+begin
+  if Assigned(FHTTP) then
+    Result:=FHTTP.ResponseStatusCode
+  else
+    Result:=0;
+end;
+
+Function TFPHTTPResponse.GetStatusText: String;
+begin
+  if Assigned(FHTTP) then
+    Result:=FHTTP.ResponseStatusText
+  else
+    Result:='';
+end;
+
+Constructor TFPHTTPResponse.Create(AHTTP: TFPHTTPRequest);
+begin
+  Inherited Create(AHTTP);
+  FHTTP:=AHTTP.FHTTP;
+end;
+
+
+{ TFPHTTPWebClient }
+
+Function TFPHTTPWebClient.DoCreateRequest: TWebClientRequest;
+begin
+  Result:=TFPHTTPRequest.Create(TFPHTTPClient.Create(Self));
+  Result.Headers.NameValueSeparator:=':';
+end;
+
+Function TFPHTTPWebClient.DoHTTPMethod(Const AMethod, AURL: String;
+  ARequest: TWebClientRequest): TWebClientResponse;
+
+Var
+  U,S : String;
+  h : TFPHTTPClient;
+  Res : Boolean;
+
+begin
+  U:=AURL;
+  H:=TFPHTTPRequest(ARequest).FHTTP;
+  S:=ARequest.ParamsAsQuery;
+  if (S<>'') then
+    begin
+    if Pos('?',U)=0 then
+      U:=U+'?';
+    U:=U+S;
+    end;
+  Result:=TFPHTTPResponse.Create(ARequest as TFPHTTPRequest);
+  try
+    if Assigned(ARequest.Content) and (ARequest.Headers.IndexOfName('Content-length')<0) then
+      H.AddHeader('Content-length',IntToStr(ARequest.Content.size));
+    if ARequest.Content.Size>0 then
+      begin
+      H.RequestBody:=ARequest.Content;
+      H.RequestBody.Position:=0;
+      end;
+    H.HTTPMethod(AMethod,U,Result.Content,[]); // Will rais an exception
+  except
+    FreeAndNil(Result);
+    Raise;
+  end;
+end;
+
+end.
+

packages/fcl-web/src/base/fpjwt.pp

@@ -0,0 +1,416 @@
+{ **********************************************************************
+  This file is part of the Free Component Library (FCL)
+  Copyright (c) 2015 by the Free Pascal development team
+        
+  JSON Web Token implementation
+            
+  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 fpjwt;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  TypInfo, Classes, SysUtils, fpjson, base64;
+
+Type
+
+  { TBaseJWT }
+
+  TBaseJWT = Class(TPersistent)
+  private
+  Protected
+    // Override this to disable writing a property to the JSON.
+    function WriteProp(P: PPropInfo; All: Boolean): Boolean; virtual;
+    function GetAsEncodedString: String; virtual;
+    procedure SetAsEncodedString(AValue: String); virtual;
+    function GetAsString: TJSONStringType; virtual;
+    procedure SetAsString(AValue: TJSONStringType);virtual;
+    Procedure DoLoadFromJSON(JSON : TJSONObject);virtual;
+    Procedure DoSaveToJSON(JSON : TJSONObject; All : Boolean);virtual;
+  Public
+    Constructor Create; virtual;
+    Procedure LoadFromJSON(JSON : TJSONObject);
+    Procedure SaveToJSON(JSON : TJSONObject; All : Boolean);
+    // Decode Base64 string. Padds the String with = to a multiple of 4
+    Class Function DecodeString(S : String) : String;
+    // Decode Base64 string and return a JSON Object. Padds the String with = to a multiple of 4
+    Class Function DecodeStringToJSON(S : String) : TJSONObject;
+    // Get/Set as string. This is normally the JSON form.
+    Property AsString : TJSONStringType Read GetAsString Write SetAsString;
+    // Set as string. This is normally the JSON form, encoded as Base64.
+    Property AsEncodedString : String Read GetAsEncodedString Write SetAsEncodedString;
+  end;
+
+  { TJOSE }
+
+  TJOSE = Class(TBaseJWT)
+  private
+    Falg: String;
+    Fcrit: String;
+    Fcty: String;
+    Fjku: String;
+    Fjwk: String;
+    Fkid: String;
+    Ftyp: String;
+    Fx5c: String;
+    Fx5t: String;
+    Fx5ts256: String;
+    Fx5u: String;
+  Published
+    // Registered names. Keep the case lowercase, the RTTI must match the registered name.
+    Property cty : String Read Fcty Write Fcty;
+    Property typ : String Read Ftyp Write Ftyp;
+    Property alg : String Read Falg Write Falg;
+    Property jku : String Read Fjku Write fjku;
+    Property jwk : String Read Fjwk Write fjwk;
+    Property kid : String Read Fkid Write fkid;
+    Property x5u : String Read Fx5u Write fx5u;
+    Property x5c : String Read Fx5c Write fx5c;
+    Property x5t : String Read Fx5t Write fx5t;
+    Property x5ts256 : String Read Fx5ts256 Write fx5ts256;
+    Property crit : String Read Fcrit Write fcrit;
+  end;
+  TJOSEClass = Class of TJOSE;
+
+  { TClaims }
+
+  TClaims = Class(TBaseJWT)
+  private
+    FAud: String;
+    FExp: Int64;
+    FIat: Int64;
+    FIss: String;
+    FJTI: String;
+    FNbf: Int64;
+    FSub: String;
+  Published
+    // Registered Claim Names. Keep the case lowercase, the RTTI must match the registered name.
+    Property iss : String Read FIss Write FIss;
+    Property sub : String Read FSub Write FSub;
+    Property aud : String Read FAud Write FAud;
+    Property exp : Int64 Read FExp Write FExp;
+    Property nbf : Int64 Read FNbf Write FNbf;
+    Property iat : Int64 Read FIat Write FIat;
+    Property jti : String Read FJTI Write FJTI;
+  end;
+  TClaimsClass = Class of TClaims;
+
+  { TJWT }
+
+  TJWT = Class(TBaseJWT)
+  private
+    FClaims: TClaims;
+    FJOSE: TJOSE;
+    FSignature: String;
+    procedure SetClaims(AValue: TClaims);
+    procedure SetJOSE(AValue: TJOSE);
+  Protected
+    Function CreateJOSE : TJOSE; Virtual;
+    Function CreateClaims : TClaims; Virtual;
+    // AsString and AsEncodedString are the same in this case.
+    function GetAsString: TJSONStringType; override;
+    procedure SetAsString(AValue: TJSONStringType);override;
+    function GetAsEncodedString: String;override;
+    Procedure SetAsEncodedString (AValue : String);override;
+  Public
+    Constructor Create; override;
+    Destructor Destroy; override;
+    // Owned by the JWT. The JSON header.
+    Property JOSE : TJOSE Read FJOSE Write SetJOSE;
+    // Owned by the JWT. The set of claims. The actuall class will depend on the descendant.
+    Property Claims : TClaims Read FClaims Write SetClaims;
+    Property Signature : String Read FSignature Write FSignature;
+  end;
+
+implementation
+
+uses strutils;
+
+{ TJWT }
+
+procedure TJWT.SetClaims(AValue: TClaims);
+begin
+  if FClaims=AValue then Exit;
+  FClaims:=AValue;
+end;
+
+procedure TJWT.SetJOSE(AValue: TJOSE);
+begin
+  if FJOSE=AValue then Exit;
+  FJOSE:=AValue;
+end;
+
+function TJWT.CreateJOSE: TJOSE;
+begin
+  Result:=TJOSE.Create;
+end;
+
+function TJWT.CreateClaims: TClaims;
+begin
+  Result:=TClaims.Create;
+end;
+
+function TJWT.GetAsString: TJSONStringType;
+begin
+  Result:=EncodeStringBase64(JOSE.AsString);
+  Result:=Result+'.'+EncodeStringBase64(Claims.AsString);
+  If (Signature<>'') then
+    Result:=Result+'.'+Signature;
+end;
+
+
+function TJWT.GetAsEncodedString: String;
+begin
+  Result:=GetAsString;
+end;
+
+procedure TJWT.SetAsEncodedString(AValue: String);
+begin
+  SetAsString(AValue);
+end;
+
+constructor TJWT.Create;
+begin
+  Inherited;
+  FJOSE:=CreateJOSE;
+  FClaims:=CreateCLaims;
+end;
+
+destructor TJWT.Destroy;
+begin
+  FreeAndNil(FJOSE);
+  FreeAndNil(FClaims);
+  Inherited;
+end;
+
+procedure TJWT.SetAsString(AValue: TJSONStringType);
+
+Var
+  J,C,S : String;
+
+begin
+  J:=ExtractWord(1,AValue,['.']);
+  C:=ExtractWord(2,AValue,['.']);
+  S:=ExtractWord(3,AValue,['.']);
+  JOSE.AsEncodedString:=J;
+  Claims.AsEncodedString:=C;
+  Signature:=S;
+end;
+
+{ TBaseJWT }
+
+function TBaseJWT.GetAsEncodedString: String;
+begin
+  Result:=EncodeStringBase64(AsString)
+end;
+
+procedure TBaseJWT.SetAsEncodedString(AValue: String);
+
+begin
+  AsString:=DecodeString(AValue);
+end;
+
+function TBaseJWT.GetAsString: TJSONStringType;
+
+Var
+  O : TJSONObject;
+
+begin
+  O:=TJSONObject.Create;
+  try
+    SaveToJSON(O,False);
+    Result:=O.AsJSON;
+  finally
+    O.Free;
+  end;
+end;
+
+procedure TBaseJWT.SetAsString(AValue: TJSONStringType);
+Var
+  D : TJSONData;
+  O : TJSONObject absolute D;
+
+begin
+  D:=GetJSON(AValue);
+  try
+    if D is TJSONObject then
+      LoadFromJSON(O);
+  finally
+    D.Free;
+  end;
+end;
+
+procedure TBaseJWT.DoLoadFromJSON(JSON: TJSONObject);
+
+Var
+  D : TJSONEnum;
+  P : PPropinfo;
+
+begin
+  For D in JSON Do
+    begin
+    P:=GetPropInfo(Self,D.Key);
+    if (P<>Nil) and not D.Value.IsNull then
+      Case P^.PropType^.Kind of
+        tkInteger : SetOrdProp(Self,P,D.Value.AsInteger);
+        tkChar :
+            if D.Value.AsString<>'' then
+              SetOrdProp(Self,P,Ord(D.Value.AsString[1]));
+        tkEnumeration :
+          if (D.Value.JSONType=jtNumber) and (TJSONNumber(D.Value).NumberType=ntInteger) then
+            SetOrdProp(Self,P,D.Value.AsInteger)
+          else
+            SetOrdProp(Self,P,GetEnumValue(p^.PropType,D.Value.AsString));
+        tkFloat :
+          SetFloatProp(Self,P,D.Value.AsFloat);
+        tkSString,tkLString,tkAString :
+            SetStrProp(Self,P,D.Value.AsString);
+        tkWChar, tkUString,tkWString,tkUChar:
+            SetWideStrProp(Self,P,D.Value.AsString);
+        tkBool :
+          SetOrdProp(Self,P,Ord(D.Value.AsBoolean));
+        tkInt64,tkQWord:
+          SetInt64Prop(Self,P,Ord(D.Value.AsInt64));
+        end;
+   end;
+end;
+
+function TBaseJWT.WriteProp(P: PPropInfo; All: Boolean): Boolean;
+
+begin
+  Result:=True;
+end;
+
+procedure TBaseJWT.DoSaveToJSON(JSON: TJSONObject; All: Boolean);
+
+
+Var
+  D : TJSONEnum;
+  P : PPropinfo;
+  PL : PPropList;
+  I,VI,Count : Integer;
+  VF : Double;
+  C : Char;
+  CW : WideChar;
+  I64 : Int64;
+  W : UnicodeString;
+  S : String;
+
+begin
+  Count:=GetPropList(Self,PL);
+  try
+    For I:=0 to Count-1 do
+      begin
+      P:=PL^[i];
+      if WriteProp(P,All) then
+        Case P^.PropType^.Kind of
+          tkInteger :
+            begin
+            VI:=GetOrdProp(Self,P);
+            if All or (VI<>0) then
+              JSON.Add(P^.Name,VI);
+            end;
+          tkChar :
+            begin
+            C:=Char(GetOrdProp(Self,P));
+            if All or (C<>#0) then
+              if C=#0 then
+                JSON.Add(p^.Name,'')
+              else
+                JSON.Add(p^.Name,C);
+            end;
+          tkEnumeration :
+            begin
+            vi:=GetOrdProp(Self,P);
+            JSON.Add(P^.Name,GetEnumName(p^.PropType,VI));
+            end;
+          tkFloat :
+            begin
+            VF:=GetFloatProp(Self,P);
+            If All or (VF<>0) then
+              JSON.Add(P^.Name,VF);
+            end;
+          tkSString,tkLString,tkAString :
+            begin
+            S:=GetStrProp(Self,P);
+            if All or (S<>'') then
+              JSON.Add(P^.Name,S);
+            end;
+          tkWChar:
+            begin
+            CW:=WideChar(GetOrdProp(Self,P));
+            if All or (CW<>#0) then
+              if CW=#0 then
+                JSON.Add(p^.Name,'')
+              else
+                JSON.Add(p^.Name,Utf8Encode(WideString(CW)));
+            end;
+          tkUString,tkWString,tkUChar:
+             begin
+              W:=GetWideStrProp(Self,P);
+              if All or (W<>'') then
+                JSON.Add(P^.Name,Utf8Encode(W));
+              end;
+          tkBool :
+            JSON.Add(P^.Name,(GetOrdProp(Self,P)<>0));
+          tkInt64,tkQWord:
+            begin
+            I64:=GetInt64Prop(Self,P);
+            if All or (I64<>0) then
+              JSON.Add(p^.Name,I64);
+            end;
+          end;
+      end;
+  finally
+    FreeMem(PL);
+  end;
+end;
+
+constructor TBaseJWT.Create;
+begin
+  Inherited Create;
+end;
+
+procedure TBaseJWT.LoadFromJSON(JSON: TJSONObject);
+begin
+  DoLoadFromJSon(JSON);
+end;
+
+procedure TBaseJWT.SaveToJSON(JSON: TJSONObject; All: Boolean);
+begin
+  DoSaveToJSon(JSON,All);
+end;
+
+class function TBaseJWT.DecodeString(S: String): String;
+
+Var
+  R : Integer;
+
+begin
+  R:=(length(S) mod 4);
+  if R<>0 then
+    S:=S+StringOfChar('=',4-r);
+  Result:=DecodeStringBase64(S);
+end;
+
+class function TBaseJWT.DecodeStringToJSON(S: String): TJSONObject;
+
+Var
+  D : TJSONData;
+begin
+  D:=GetJSON(DecodeString(S));
+  if not (D is TJSONData) then
+    FreeAndNil(D);
+  Result:=TJSONObject(D);
+end;
+
+end.
+

packages/fcl-web/src/base/fpoauth2.pp

@@ -0,0 +1,779 @@
+{ **********************************************************************
+  This file is part of the Free Component Library (FCL)
+  Copyright (c) 2015 by the Free Pascal development team
+        
+  OAuth2 web request handler classes 
+            
+  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 fpoauth2;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Typinfo,Classes, SysUtils, fpjson, fpjwt, fpwebclient;
+
+Type
+  { TOAuth2Config }
+  TAccessType = (atOnline,atOffline);
+  TAbstracTOAuth2ConfigStore = Class;
+  EOAuth2 = Class(Exception);
+  { TOAuth2Config }
+
+  { TJWTIDToken }
+
+  TJWTIDToken = Class(TJWT)
+  private
+    FClaimsClass: TClaimsClass;
+    FJOSEClass: TJOSEClass;
+  Protected
+    Function CreateClaims : TClaims; override;
+    Function CreateJOSE : TJOSE; override;
+    Property ClaimsClass: TClaimsClass Read FClaimsClass;
+    Property JOSEClass: TJOSEClass Read FJOSEClass;
+  Public
+    // Pass on the actual Claims/JOSE class to be used. When Nil, defaults are used.
+    Constructor CreateWithClasses(AClaims: TClaimsClass; AJOSE : TJOSEClass);
+    // Extract a unique user ID from the claims. By default, this calls GetUniqueUserName
+    Function GetUniqueUserID : String; virtual;
+    // Extract a unique user name from the claims. Must be overridden by descendents.
+    Function GetUniqueUserName : String; virtual;
+    // Extract a user display name from the claims. By default, this calls GetUniqueUserName
+    Function GetUserDisplayName : String; virtual;
+  end;
+  // OAuth2 client and server settings.
+
+  TOAuth2Config = Class(TPersistent)
+  private
+    FAuthScope: String;
+    FAuthURL: String;
+    FClientID: String;
+    FClientSecret: String;
+    FRedirectURI: String;
+    FDeveloperKey: String;
+    FHostedDomain: String;
+    FIncludeGrantedScopes: Boolean;
+    FOpenIDRealm: String;
+    FTokenURL: String;
+    FAccessType: TAccessType;
+  Protected
+  Public
+    Procedure Assign(Source : TPersistent); override;
+    Procedure SaveToStrings(L : TStrings);
+  Published
+    //
+    // Local OAuth2 client config part.
+    //
+    Property ClientID : String Read FClientID Write FClientID;
+    Property ClientSecret : String Read FClientSecret Write FClientSecret;
+    Property RedirectURI : String Read FRedirectURI Write FRedirectURI;
+    Property AccessType : TAccessType Read FAccessType Write FAccessType;
+    // Specific for google.
+    Property DeveloperKey : String Read FDeveloperKey Write FDeveloperKey;
+    Property OpenIDRealm : String Read FOpenIDRealm Write FOpenIDRealm;
+    //
+    // Auth Provider part
+    //
+    // Domain part, can be substituted on URL to refresh access token
+    Property HostedDomain : String Read FHostedDomain Write FHostedDomain;
+    // URL to authenticate a user. used in creating the redirect URL. Can contain %HostedDomain%
+    Property AuthURL: String Read FAuthURL Write FAuthURL;
+    // URL To exchange authorization code for access token. Can contain %HostedDomain%
+    Property TokenURL: String Read FTokenURL Write FTokenURL;
+    // Authorized Scopes (Google parlance) or resources (Microsoft parlance)
+    Property AuthScope: String Read FAuthScope Write FAuthScope;
+    // Google specific: adds AuthScope to existing scopes (incremental increase of authorization).
+    Property IncludeGrantedScopes : Boolean Read FIncludeGrantedScopes Write FIncludeGrantedScopes;
+  end;
+  TOAuth2ConfigClass = Class of TOAuth2Config;
+
+  { TOAuth2Session }
+  //
+  // User config part
+  //
+
+  TOAuth2Session = Class(TPersistent)
+  Private
+    FRefreshToken: String;
+    FLoginHint: String;
+    FIDToken: String;
+    FState: String;
+    FAccessToken: String;
+    FAuthTokenType: String;
+    FAuthCode: String;
+    FAuthExpires: TDateTime;
+    FAuthExpiryPeriod: Integer;
+    procedure SetAuthExpiryPeriod(AValue: Integer);
+  Protected
+    Class Function AuthExpiryMargin : Integer; virtual;
+    procedure DoLoadFromJSON(AJSON: TJSONObject); virtual;
+  Public
+    Procedure LoadTokensFromJSONResponse(Const AJSON : String);
+    Procedure LoadStartTokensFromVariables(Const Variables : TStrings);
+    Procedure SaveToStrings(L : TStrings);
+    procedure Assign(Source: TPersistent); override;
+  Published
+    // Authentication code received at the first step of the OAuth2 sequence
+    Property AuthCode: String Read FAuthCode Write FAuthCode;
+    // Access token to be used for authorized scopes. Received in step 2 of the OAuth2 sequence;
+    Property AccessToken: String Read FAccessToken Write FAccessToken;
+    // Refresh token to renew Access token. received in step 2 of the OAuth2 sequence;
+    Property RefreshToken : String Read FRefreshToken Write FRefreshToken;
+    // When does the authentication end, local time.
+    Property AuthExpires : TDateTime Read FAuthExpires Write FAuthExpires;
+    // Seconds till access token expires. Setting this will set the AuthExpires property to Now+(AuthExpiryPeriod-AuthExpiryMargin)
+    Property AuthExpiryPeriod : Integer Read FAuthExpiryPeriod Write SetAuthExpiryPeriod;
+    // Token type (Bearer)
+    Property AuthTokenType: String Read FAuthTokenType Write FAuthTokenType;
+    // State, saved as part of the user config.
+    Property State : String Read FState Write FState;
+    // Login hint
+    Property LoginHint : String Read FLoginHint Write FLoginHint;
+    // IDToken
+    Property IDToken : String Read FIDToken Write FIDToken;
+  end;
+  TOAuth2SessionClass = Class of TOAuth2Session;
+
+  TAbstractOAuth2ConfigStore = CLass(TComponent)
+  Public
+    Procedure SaveConfig(AConfig : TOAuth2Config); virtual; abstract;
+    Procedure LoadConfig(AConfig : TOAuth2Config); virtual; abstract;
+    Procedure SaveSession(ASession : TOAuth2Session; Const AUser : String); virtual; abstract;
+    Procedure LoadSession(ASession : TOAuth2Session; Const AUser : String); virtual; abstract;
+  end;
+  TAbstractOAuth2ConfigStoreClass = Class of TAbstractOAuth2ConfigStore;
+
+  TUserConsentHandler = Procedure (Const AURL : String; Out AAuthCode : String) of object;
+  TOnAuthConfigChangeHandler = Procedure (Const Sender : TObject; Const AConfig : TOAuth2Config) of object;
+  TOnAuthSessionChangeHandler = Procedure (Const Sender : TObject; Const ASession : TOAuth2Session) of object;
+  TOnIDTokenChangeHandler = Procedure (Const Sender : TObject; Const AToken : TJWTIDToken) of object;
+  TSignRequestHandler = Procedure (Const Sender : TObject; Const ARequest : TWebClientRequest)of object;
+
+  TAuthenticateAction = (aaContinue,aaRedirect,aaFail);
+
+  { TOAuth2Handler }
+
+  TOAuth2Handler = Class(TAbstractRequestSigner)
+  private
+    FAutoStore: Boolean;
+    FClaimsClass: TClaimsClass;
+    FConfig: TOAuth2Config;
+    FConfigLoaded: Boolean;
+    FIDToken: TJWTIDToken;
+    FOnAuthSessionChange: TOnAuthSessionChangeHandler;
+    FOnIDTokenChange: TOnIDTokenChangeHandler;
+    FSession: TOAuth2Session;
+    FOnAuthConfigChange: TOnAuthConfigChangeHandler;
+    FOnSignRequest: TOnAuthSessionChangeHandler;
+    FOnUserConsent: TUserConsentHandler;
+    FSessionLoaded: Boolean;
+    FWebClient: TAbstractWebClient;
+    FStore : TAbstracTOAuth2ConfigStore;
+    procedure SetConfig(AValue: TOAuth2Config);
+    procedure SetSession(AValue: TOAuth2Session);
+    procedure SetStore(AValue: TAbstracTOAuth2ConfigStore);
+  Protected
+    Function RefreshToken: Boolean; virtual;
+    Function CreateOauth2Config : TOAuth2Config; virtual;
+    Function CreateOauth2Session : TOAuth2Session; virtual;
+    Function CreateIDToken : TJWTIDToken; virtual;
+    Procedure Notification(AComponent: TComponent; Operation: TOperation); override;
+    Procedure DoAuthConfigChange; virtual;
+    Procedure DoAuthSessionChange; virtual;
+    Procedure DoSignRequest(ARequest: TWebClientRequest); override;
+    Property ConfigLoaded : Boolean Read FConfigLoaded;
+    Property SessionLoaded : Boolean Read FSessionLoaded;
+  Public
+    Class Var DefaultConfigClass : TOAuth2ConfigClass;
+    Class Var DefaultSessionClass : TOAuth2SessionClass;
+  Public
+    Constructor Create(AOwner : TComponent);override;
+    Destructor Destroy; override;
+    // Variable name for AuthScope in authentication URL.
+    // Default = scope. Descendents can override this to provide correct behaviour.
+    Class Function AuthScopeVariableName : String; virtual;
+    // Check if config is authenticated.
+    Function IsAuthenticated : Boolean; virtual;
+    // Generate an authentication URL
+    Function AuthenticateURL : String; virtual;
+    // Check what needs to be done for authentication.
+    // Do whatever is necessary to mark the request as 'authenticated'.
+    Function Authenticate: TAuthenticateAction; virtual;
+    // Load config from store
+    procedure LoadConfig;
+    // Save config to store
+    procedure SaveConfig;
+    // Load Session from store.If AUser is empty, then ID Token.GetUniqueUser is used.
+    procedure LoadSession(Const AUser : String = '');
+    // Save session in store. If AUser is empty, then ID Token.GetUniqueUser is used. Will call OnAuthSessionChange
+    procedure SaveSession(Const AUser : String = '');
+    // Refresh ID token from Session.IDToken. Called after token is refreshed or session is loaded.
+    // This will change the actual IDToken instance.
+    procedure RefreshIDToken;
+    // This is populated from Config.IDToken if it is not empty. Do not cache this instance. It is recreated after a call to RefreshIDToken
+    Property IDToken : TJWTIDToken Read FIDToken;
+    // Set this to initialize the claims for the ID token. By default, it is TClaims
+    Property ClaimsClass : TClaimsClass Read FClaimsClass Write FClaimsClass;
+  Published
+    // Must be set prior to calling
+    Property Config : TOAuth2Config Read FConfig Write SetConfig;
+    // Session info.
+    Property Session : TOAuth2Session Read FSession Write SetSession;
+    // Webclient used to do requests to authorization service
+    Property WebClient : TAbstractWebClient Read FWebClient Write FWebClient;
+    // Event handler to get user consent if no access token or refresh token is available
+    Property OnUserConsent : TUserConsentHandler Read FOnUserConsent Write FOnUserConsent;
+    // Called when the auth config informaion changes
+    Property OnAuthConfigChange : TOnAuthConfigChangeHandler Read FOnAuthConfigChange Write FOnAuthConfigChange;
+    // Called when the auth sesson information changes
+    Property OnAuthSessionChange : TOnAuthSessionChangeHandler Read FOnAuthSessionChange Write FOnAuthSessionChange;
+    // Called when the IDToken information changes
+    Property OnIDTokenChange : TOnIDTokenChangeHandler Read FOnIDTokenChange Write FOnIDTokenChange;
+    // Called when a request is signed
+    Property OnSignRequest : TOnAuthSessionChangeHandler Read FOnSignRequest Write FOnSignRequest;
+    // User to load/store parts of the config store.
+    Property Store : TAbstracTOAuth2ConfigStore Read FStore Write SetStore;
+    // Call storing automatically when needed.
+    Property AutoStore : Boolean Read FAutoStore Write FAutoStore;
+  end;
+  TOAuth2HandlerClass = Class of TOAuth2Handler;
+
+
+
+implementation
+
+uses httpdefs;
+
+Resourcestring
+  SErrFailedToRefreshToken = 'Failed to refresh access token: Status %d, Error: %s';
+
+{ TOAuth2Handler }
+
+{ Several possibilities:
+  1. Acess token is available.
+     A) Access token is not yet expired
+        -> All is well, continue.
+     B) Access token is available, but is expired.
+        Refresh token is
+          i) Available
+             -> get new access token using refresh token.
+             (may fail -> fail)
+          ii) Not available
+              -> error.
+  3. No access token is available.
+     A) Offline
+        -> Need to get user consent using callback.
+        i) User consent results in Access token (AConfig.AuthToken)
+           ->  Auth token is exchanged for a refresh token & access token
+        ii) User consent failed or no callback.
+           -> Fail
+     B) Online: Need to redirect to get access token and auth token.
+
+}
+
+{ TTWTIDToken }
+
+constructor TJWTIDToken.CreateWithClasses(AClaims: TClaimsClass;
+  AJOSE: TJOSEClass);
+begin
+  FClaimsClass:=AClaims;
+  FJOSEClass:=AJOSE;
+  Inherited Create;
+end;
+
+function TJWTIDToken.GetUniqueUserID: String;
+begin
+  Result:=GetUniqueUserName;
+end;
+
+function TJWTIDToken.GetUniqueUserName: String;
+begin
+  Result:='';
+end;
+
+function TJWTIDToken.GetUserDisplayName: String;
+begin
+  Result:=GetUniqueUserName;
+end;
+
+function TJWTIDToken.CreateClaims: TClaims;
+begin
+  if FClaimsClass=Nil then
+    Result:=Inherited CreateClaims
+  else
+    Result:=FClaimsClass.Create;
+end;
+
+function TJWTIDToken.CreateJOSE: TJOSE;
+begin
+  if FJOSEClass=Nil then
+    Result:=Inherited CreateJOSE
+  else
+  Result:=FJOSEClass.Create;
+end;
+
+function TOAuth2Handler.Authenticate: TAuthenticateAction;
+
+Var
+  S : String;
+
+begin
+  if IsAuthenticated then
+    result:=aaContinue
+  else
+    Case Config.AccessType of
+      atonline :
+        Result:=aaRedirect; // we need to let the user authenticate himself.
+      atoffline :
+        if Not Assigned(FOnUserConsent) then
+          result:=aaFail
+        else
+          begin
+          FOnUserConsent(AuthenticateURL,S);
+          Session.AuthCode:=S;
+          // Exchange authcode for access code.
+          if IsAuthenticated then
+            result:=aaContinue
+          else
+            result:=aaFail
+          end;
+    end;
+end;
+
+function TOAuth2Handler.AuthenticateURL: String;
+begin
+  Result:=Config.AuthURL
+        + '?'+ AuthScopeVariableName+'='+HTTPEncode(Config.AuthScope)
+        +'&redirect_uri='+HTTPEncode(Config.RedirectUri)
+        +'&client_id='+HTTPEncode(Config.ClientID)
+        +'&response_type=code'; // Request refresh token.
+  if Assigned(Session) then
+    begin
+    if (Session.LoginHint<>'') then
+      Result:=Result +'&login_hint='+HTTPEncode(Session.LoginHint);
+    if (Session.State<>'') then
+      Result:=Result +'&state='+HTTPEncode(Session.State);
+    end;
+end;
+
+procedure TOAuth2Handler.SetConfig(AValue: TOAuth2Config);
+
+begin
+  if FConfig=AValue then Exit;
+  FConfig.Assign(AValue);
+end;
+
+procedure TOAuth2Handler.SetSession(AValue: TOAuth2Session);
+begin
+  if FSession=AValue then Exit;
+  FSession.Assign(AValue);
+end;
+
+procedure TOAuth2Handler.LoadConfig;
+
+begin
+  if Assigned(Store) and not ConfigLoaded then
+    begin
+    Store.LoadConfig(Config);
+    FConfigLoaded:=True;
+    end;
+end;
+
+procedure TOAuth2Handler.SaveConfig;
+begin
+  if Assigned(Store) then
+    begin
+    Store.SaveConfig(Config);
+    FConfigLoaded:=True;
+    end;
+end;
+
+procedure TOAuth2Handler.LoadSession(const AUser: String);
+
+Var
+  U : String;
+
+begin
+  if Assigned(Store) then
+    begin
+    U:=AUser;
+    If (U='') and Assigned(FIDToken) then
+      U:=FIDToken.GetUniqueUserID;
+    Store.LoadSession(Session,AUser);
+    FSessionLoaded:=True;
+    if (Session.IDToken<>'') then
+      RefreshIDToken;
+    end;
+end;
+
+procedure TOAuth2Handler.SaveSession(const AUser: String);
+
+Var
+  U : String;
+
+begin
+  if Assigned(FOnAuthSessionChange) then
+    FOnAuthSessionChange(Self,Session);
+  if Assigned(Store) then
+    begin
+    Store.SaveSession(Session,AUser);
+    FSessionLoaded:=True;
+    end;
+end;
+
+procedure TOAuth2Handler.RefreshIDToken;
+begin
+  FreeAndNil(FIDToken);
+  if (Session.IDToken<>'') then
+    begin
+    FIDtoken:=CreateIDToken;
+    FIDToken.AsEncodedString:=Session.IDToken;
+    If Assigned(FOnIDTokenChange) then
+      FOnIDTokenChange(Self,FIDToken);
+    end;
+end;
+
+function TOAuth2Handler.RefreshToken: Boolean;
+
+Var
+  URL,Body : String;
+  D : TJSONData;
+  Req: TWebClientRequest;
+  Resp: TWebClientResponse;
+
+begin
+  LoadConfig;
+  Req:=Nil;
+  Resp:=Nil;
+  D:=Nil;
+  try
+    Req:=WebClient.CreateRequest;
+    Req.Headers.Values['Content-Type']:='application/x-www-form-urlencoded';
+    url:=Config.TOKENURL;
+    Body:='client_id='+HTTPEncode(Config.ClientID)+
+          '&client_secret='+ HTTPEncode(Config.ClientSecret);
+    if (Session.RefreshToken<>'') then
+      body:=Body+'&refresh_token='+HTTPEncode(Session.RefreshToken)+
+                 '&grant_type=refresh_token'
+    else
+      begin
+      body:=Body+
+            '&grant_type=authorization_code'+
+            '&redirect_uri='+HTTPEncode(Config.RedirectUri)+
+            '&code='+HTTPEncode(Session.AuthCode);
+      end;
+    Req.SetContentFromString(Body);
+    Resp:=WebClient.ExecuteRequest('POST',url,Req);
+    Result:=(Resp.StatusCode=200);
+    if Result then
+      begin
+      Session.LoadTokensFromJSONResponse(Resp.GetContentAsString);
+      If (Session.IDToken)<>'' then
+        begin
+        RefreshIDToken;
+        DoAuthSessionChange;
+        end;
+      end
+    else
+      Raise EOAuth2.CreateFmt(SErrFailedToRefreshToken,[Resp.StatusCode,Resp.StatusText]);
+    Result:=True;
+  finally
+    D.Free;
+    Resp.Free;
+    Req.Free;
+  end;
+end;
+
+function TOAuth2Handler.CreateOauth2Config: TOAuth2Config;
+begin
+  Result:=DefaultConfigClass.Create;
+end;
+
+function TOAuth2Handler.CreateOauth2Session: TOAuth2Session;
+begin
+  Result:=DefaultSessionClass.Create;
+end;
+
+function TOAuth2Handler.CreateIDToken: TJWTIDToken;
+begin
+  Result:=TJWTIDToken.CreateWithClasses(ClaimsClass,Nil);
+end;
+
+procedure TOAuth2Handler.Notification(AComponent: TComponent;
+  Operation: TOperation);
+begin
+  inherited Notification(AComponent, Operation);
+  if (Operation=opRemove) then
+    if AComponent=FStore then
+      FStore:=Nil;
+end;
+
+function TOAuth2Handler.IsAuthenticated: Boolean;
+
+begin
+  LoadConfig;
+  // See if we need to load the session
+  if (Session.RefreshToken='') then
+    LoadSession;
+  Result:=(Session.AccessToken<>'');
+  If Result then
+    // have access token. Check if it is still valid.
+    begin
+    // Not expired ?
+    Result:=(Now<Session.AuthExpires);
+    // Expired, but have refresh token ?
+    if (not Result) and (Session.RefreshToken<>'') then
+      Result:=RefreshToken;
+    end
+  else if (Session.RefreshToken<>'') then
+    begin
+    // No access token, but have refresh token
+    Result:=RefreshToken;
+    end
+  else  if (Session.AuthCode<>'') then
+    // No access or refresh token, but have auth code.
+      Result:=RefreshToken;
+end;
+
+
+{ TOAuth2Handler }
+
+
+procedure TOAuth2Handler.DoAuthConfigChange;
+begin
+  If Assigned(FOnAuthConfigChange) then
+    FOnAuthConfigChange(Self,Config);
+  SaveConfig;
+end;
+
+procedure TOAuth2Handler.DoAuthSessionChange;
+begin
+  If Assigned(FOnAuthSessionChange) then
+    FOnAuthSessionChange(Self,Session);
+  SaveSession;
+end;
+
+procedure TOAuth2Handler.DoSignRequest(ARequest: TWebClientRequest);
+
+Var
+  TT,AT : String;
+begin
+  if Authenticate=aaContinue then
+    begin
+    TT:=Session.AuthTokenType;
+    AT:=Session.AccessToken;
+    Arequest.Headers.Add('Authorization: '+TT+' '+HTTPEncode(AT));
+    end
+  else
+    Raise EOAuth2.Create('Cannot sign request: not authorized');
+end;
+
+constructor TOAuth2Handler.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  FConfig:=CreateOauth2Config;
+  FSession:=CreateOauth2Session;
+end;
+
+destructor TOAuth2Handler.Destroy;
+begin
+  FreeAndNil(FIDToken);
+  FreeAndNil(FConfig);
+  FreeAndNil(FSession);
+  inherited Destroy;
+end;
+
+class function TOAuth2Handler.AuthScopeVariableName: String;
+begin
+  Result:='scope';
+end;
+
+
+{ TOAuth2Config }
+
+procedure TOAuth2Handler.SetStore(AValue: TAbstracTOAuth2ConfigStore);
+begin
+  if FStore=AValue then Exit;
+  if Assigned(FStore) then
+    FStore.RemoveFreeNotification(Self);
+  FStore:=AValue;
+  if Assigned(FStore) then
+    FStore.FreeNotification(Self);
+end;
+
+class function TOAuth2Session.AuthExpiryMargin: Integer;
+begin
+  Result:=10;
+end;
+
+procedure TOAuth2Session.SetAuthExpiryPeriod(AValue: Integer);
+begin
+  if FAuthExpiryPeriod=AValue then Exit;
+  FAuthExpiryPeriod:=AValue;
+  AuthExpires:=Now+AValue/SecsPerDay;
+end;
+
+
+procedure TOAuth2Config.Assign(Source: TPersistent);
+
+Var
+  C : TOAuth2Config;
+
+begin
+  if Source is TOAuth2Config then
+    begin
+    C:=Source as TOAuth2Config;
+    FAuthURL:=C.AuthURL;
+    FTokenURL:=C.TokenURL;
+    FClientID:=C.ClientID;
+    FClientSecret:=C.ClientSecret;
+    FRedirectURI:=C.RedirectURI;
+    FAccessType:=C.AccessType;
+    FDeveloperKey:=C.DeveloperKey;
+    FHostedDomain:=C.HostedDomain;
+    FIncludeGrantedScopes:=C.IncludeGrantedScopes;
+    FOpenIDRealm:=C.OpenIDRealm;
+    FAuthScope:=C.AuthScope;
+    end
+  else
+    inherited Assign(Source);
+end;
+
+procedure TOAuth2Config.SaveToStrings(L: TStrings);
+  Procedure W(N,V : String);
+
+  begin
+    L.Add(N+'='+V);
+  end;
+
+begin
+  W('AuthURL',AuthURL);
+  W('TokenURL',TokenURL);
+  W('ClientID',ClientID);
+  W('ClientSecret',ClientSecret);
+  W('RedirectURI',RedirectURI);
+  W('AccessType',GetEnumName(TypeInfo(TAccessType),Ord(AccessType)));
+  W('DeveloperKey',DeveloperKey);
+  W('HostedDomain',HostedDomain);
+  W('IncludeGrantedScopes',BoolToStr(IncludeGrantedScopes,True));
+  W('OpenIDRealm',OpenIDRealm);
+  W('AuthScope',AuthScope);
+end;
+
+procedure TOAuth2Session.SaveToStrings(L: TStrings);
+
+  Procedure W(N,V : String);
+
+  begin
+    L.Add(N+'='+V);
+  end;
+
+begin
+  W('AuthCode',AuthCode);
+  W('RefreshToken',RefreshToken);
+  W('LoginHint',LoginHint);
+  W('IDToken',IDToken);
+  W('AccessToken',AccessToken);
+  W('AuthExpiryPeriod',IntToStr(AuthExpiryPeriod));
+  W('AuthExpires',DateTimeToStr(AuthExpires));
+  W('State',State);
+  W('AuthTokenType',AuthTokenType);
+end;
+
+procedure TOAuth2Session.Assign(Source: TPersistent);
+
+Var
+  C : TOAuth2Session;
+
+begin
+  if Source is TOAuth2Session then
+    begin
+    C:=Source as TOAuth2Session;
+    FAuthCode:=C.AuthCode;
+    FRefreshToken:=C.RefreshToken;
+    FLoginHint:=C.LoginHint;
+    FIDToken:=C.IDToken;
+    FAccessToken:=C.AccessToken;
+    FAuthExpiryPeriod:=C.AuthExpiryPeriod;
+    FAuthExpires:=C.AuthExpires;
+    FState:=C.State;
+    FAuthTokenType:=C.AuthTokenType;
+    end
+  else
+    inherited Assign(Source);
+end;
+
+
+procedure TOAuth2Session.DoLoadFromJSON(AJSON: TJSONObject);
+
+  Function Get(Const AName,ADefault : String) : String;
+
+  begin
+    Result:=AJSON.Get(AName,ADefault);
+  end;
+
+Var
+  i : Integer;
+
+begin
+  AccessToken:=Get('access_token',AccessToken);
+  RefreshToken:=Get('refresh_token',RefreshToken);
+  AuthTokenType:=Get('token_type',AuthTokenType);
+  IDToken:=Get('id_token',IDToken);
+  // Microsoft sends expires_in as String !!
+  I:=AJSON.IndexOfName('expires_in');
+  if (I<>-1) then
+    begin
+    I:=AJSON.Items[i].AsInteger;
+    if (I>0) then
+      AuthExpiryPeriod:=I;
+    end;
+end;
+
+procedure TOAuth2Session.LoadTokensFromJSONResponse(const AJSON: String);
+
+Var
+  D : TJSONData;
+
+begin
+  D:=GetJSON(AJSON);
+  try
+    DoLoadFromJSON(D as TJSONObject);
+  finally
+    D.Free;
+  end;
+end;
+
+procedure TOAuth2Session.LoadStartTokensFromVariables(const Variables: TStrings);
+
+  Function Get(Const AName,ADefault : String) : String;
+
+  Var
+    I : Integer;
+
+  begin
+    I:=Variables.IndexOfName(AName);
+    if I=-1 then
+      Result:=ADefault
+    else
+      Result:=Variables.ValueFromIndex[i];
+  end;
+
+begin
+  AuthCode:=Get('code',AuthCode);
+  LoginHint:=Get('login_hint',LoginHint);
+end;
+
+
+initialization
+  TOAuth2Handler.DefaultConfigClass:=TOAuth2Config;
+  TOAuth2Handler.DefaultSessionClass:=TOAuth2Session;
+end.
+

packages/fcl-web/src/base/fpoauth2ini.pp

@@ -0,0 +1,311 @@
+{ **********************************************************************
+  This file is part of the Free Component Library (FCL)
+  Copyright (c) 2015 by the Free Pascal development team
+        
+  OAuth2 store using an .ini file.
+            
+  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 fpoauth2ini;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, fpoauth2, inifiles;
+
+Type
+
+  { TFPOAuth2IniStore }
+
+  TFPOAuth2IniStore = Class(TAbstracTOAuth2ConfigStore)
+  private
+    FApplicationSection: String;
+    FConfigFileName: String;
+    FFileName: String;
+    FProviderSection: String;
+    FSessionFileName: String;
+    FUserSection: String;
+    procedure EnsureFileName;
+    Procedure EnsureConfigSections;
+  Protected
+    Function DetectSessionFileName : String;
+    Function EnsureUserSession(ASession: TOAuth2Session): Boolean; virtual;
+  Public
+    Constructor Create(AOwner : TComponent); override;
+    Destructor Destroy; override;
+
+    Procedure SaveConfigToIni(AIni : TCustomIniFile;AConfig : TOAuth2Config); virtual;
+    Procedure LoadConfigFromIni(AIni : TCustomIniFile;AConfig : TOAuth2Config); virtual;
+    Procedure SaveSessionToIni(AIni : TCustomIniFile;ASession : TOAuth2Session); virtual;
+    Procedure LoadSessionFromIni(AIni : TCustomIniFile;ASession : TOAuth2Session); virtual;
+    Procedure SaveConfig(AConfig : TOAuth2Config); override;
+    Procedure LoadConfig(AConfig : TOAuth2Config); override;
+    Procedure LoadSession(ASession : TOAuth2Session;Const AUser : String); override;
+    Procedure SaveSession(Asession : TOAuth2Session;Const AUser : String); override;
+  Published
+    // Static configuration, readable by web process. Default is app config file.
+    Property ConfigFileName: String Read FConfigFileName Write FConfigFileName;
+    // Per-user (session) configuration, writeable by webprocess. Default is temp dir+'oauth-'+ConfigFileName
+    Property SessionFileName: String Read FSessionFileName Write FSessionFileName;
+    // Name of application section (Application)
+    Property ApplicationSection : String Read FApplicationSection Write FApplicationSection;
+    // Name of provider section (Provider)
+    Property ProviderSection : String Read FProviderSection Write FProviderSection;
+    // Name of User session section (username from ID)
+    Property UserSessionSection : String Read FUserSection Write FUserSection;
+  end;
+
+
+implementation
+
+uses typinfo;
+
+Const
+  // Default sections.
+
+  SApplication = 'Application';
+  SProvider    = 'Provider';
+
+Const
+  SClient            = 'Client';
+  SAuth              = 'Authorization';
+
+  KeyenableGZIP      = 'EnableGZIP';
+  KeyApplicationName = 'ApplicationName';
+  KeyMethod          = 'Method';
+
+  // Application keys
+  KeyClientID        = 'client_id';
+  KeyClientSecret    = 'client_secret';
+  KeyRedirectURI     = 'redirect_uri';
+  KeyAccessType      = 'access_type';
+  KeyDeveloperKey    = 'DeveloperKey';
+  KeyOpenIDRealm     = 'OpenIDRealm';
+
+  // Provider keys
+  KeyHostedDomain    = 'HostedDomain';
+  KeyTokenURL        = 'TokenURL';
+  KeyAuthURL         = 'AuthURL';
+  KeyAuthScope       = 'AuthScope';
+
+  // User keys
+  KeyAccessToken     = 'access_token';
+  KeyRefreshToken    = 'refresh_token';
+  KeyTokenType       = 'token_type';
+  KeyExpiresAt       = 'expires_at';
+  KeyExpiresIn       = 'expires_in';
+  KeyLoginHint       = 'login_hint';
+  KeyIDToken         = 'id_token';
+
+{ TFPOAuth2IniStore }
+
+Procedure Touch(FN : String);
+
+begin
+//  FileClose(FileCreate('/tmp/logs/'+fn));
+end;
+
+procedure TFPOAuth2IniStore.EnsureFileName;
+
+begin
+  If (ConfigFileName='') then
+    ConfigFileName:=GetAppConfigFile(True);
+  if SessionFIleName='' then
+    SessionFileName:=GetTempDir(True)+'oauth-'+ExtractFileName(GetAppConfigFile(True));
+end;
+
+procedure TFPOAuth2IniStore.EnsureConfigSections;
+begin
+  if (ApplicationSection='') then
+    ApplicationSection:=SApplication;
+  if (ProviderSection='') then
+    ProviderSection:=SProvider;
+end;
+
+function TFPOAuth2IniStore.DetectSessionFileName: String;
+begin
+  Result:=FSessionFileName;
+  If Result='' then
+    Result:=ConfigFileName
+end;
+
+procedure TFPOAuth2IniStore.SaveConfigToIni(AIni: TCustomIniFile; AConfig: TOAuth2Config);
+
+begin
+  EnsureConfigSections;
+  Touch('saveconfigfomini');
+  Touch('saveconfigfomini-app-'+ApplicationSection);
+  Touch('saveconfigfomini-provider-'+ProviderSection);
+  With AIni,AConfig do
+    begin
+    WriteString(ApplicationSection,KeyClientID,ClientID);
+    WriteString(ApplicationSection,KeyClientSecret,ClientSecret);
+    WriteString(ApplicationSection,KeyRedirectURI,RedirectURI);
+    WriteString(ApplicationSection,KeyDeveloperKey,DeveloperKey);
+    WriteString(ApplicationSection,KeyOpenIDRealm,OpenIDRealm);
+    WriteString(ApplicationSection,KeyAccessType,GetEnumName(Typeinfo(TAccessType),Ord(AccessType)));
+    WriteString(ProviderSection,KeyHostedDomain,HostedDomain);
+    WriteString(ProviderSection,KeyTokenURL,TokenURL);
+    WriteString(ProviderSection,KeyAuthURL,AuthURL);
+    WriteString(ProviderSection,KeyAuthScope,AuthScope);
+    end;
+end;
+
+procedure TFPOAuth2IniStore.LoadConfigFromIni(AIni: TCustomIniFile;
+  AConfig: TOAuth2Config);
+
+Var
+  S : String;
+  i : Integer;
+
+begin
+  EnsureConfigSections;
+  Touch('Loadconfigfomini');
+  Touch('Loadconfigfomini-app-'+ApplicationSection);
+  Touch('Loadconfigfomini-provider-'+ProviderSection);
+  With AIni,AConfig do
+    begin
+    ClientID:=ReadString(ApplicationSection,KeyClientID,ClientID);
+    ClientSecret:=ReadString(ApplicationSection,KeyClientSecret,ClientSecret);
+    RedirectURI:=AIni.ReadString(ApplicationSection,KeyRedirectURI,RedirectURI);
+    DeveloperKey:=AIni.ReadString(ApplicationSection,KeyDeveloperKey,DeveloperKey);
+    OpenIDRealm:=AIni.ReadString(ApplicationSection,KeyOpenIDRealm,OpenIDRealm);
+    S:=AIni.ReadString(ApplicationSection,KeyAccessType,GetEnumName(Typeinfo(TAccessType),Ord(AccessType)));
+    i:= GetEnumValue(TYpeinfo(TAccessType),S);
+    if (I<>-1) then
+      AccessType:=TAccessType(i);
+    HostedDomain:=ReadString(ProviderSection,KeyHostedDomain,HostedDomain);
+    TokenURL:=ReadString(ProviderSection,KeyTokenURL,TokenURL);
+    AuthURL:=ReadString(ProviderSection,KeyAuthURL,AuthURL);
+    AuthScope:=ReadString(ProviderSection,KeyAuthScope,AuthScope);
+    end;
+end;
+
+procedure TFPOAuth2IniStore.SaveSessionToIni(AIni: TCustomIniFile;
+  ASession: TOAuth2Session);
+begin
+  Touch('savesessiontoini'+usersessionsection);
+  With AIni,ASession do
+    begin
+    WriteString(UserSessionSection,KeyLoginHint,LoginHint);
+    WriteString(UserSessionSection,KeyAccessToken,AccessToken);
+    WriteString(UserSessionSection,KeyRefreshToken,RefreshToken);
+    WriteString(UserSessionSection,KeyTokenType,AuthTokenType);
+    WriteInteger(UserSessionSection,KeyExpiresIn,AuthExpiryPeriod);
+    WriteDateTime(UserSessionSection,KeyExpiresAt,AuthExpires);
+    WriteString(UserSessionSection,KeyIDToken,IDToken);
+    end;
+end;
+
+procedure TFPOAuth2IniStore.LoadSessionFromIni(AIni: TCustomIniFile;
+  ASession: TOAuth2Session);
+begin
+  Touch('loadsessionini-'+usersessionsection);
+  With AIni,ASession do
+    begin
+    LoginHint:=ReadString(UserSessionSection,KeyLoginHint,LoginHint);
+    AccessToken:=ReadString(UserSessionSection,KeyAccessToken,AccessToken);
+    RefreshToken:=ReadString(UserSessionSection,KeyRefreshToken,RefreshToken);
+    AuthTokenType:=ReadString(UserSessionSection,KeyTokenType,AuthTokenType);
+    AuthExpiryPeriod:=ReadInteger(UserSessionSection,KeyExpiresIn,0);
+    AuthExpires:=ReadDateTime(UserSessionSection,KeyExpiresAt,AuthExpires);
+    IDToken:=ReadString(UserSessionSection,KeyIDToken,'');
+    end;
+end;
+
+procedure TFPOAuth2IniStore.SaveConfig(AConfig: TOAuth2Config);
+
+Var
+  Ini : TMemIniFile;
+
+begin
+  Touch('saveconfig');
+  EnsureFileName;
+  Ini:=TMemIniFile.Create(ConfigFileName);
+  try
+    SaveConfigToIni(Ini,AConfig);
+    Ini.UpdateFile;
+  finally
+    Ini.Free;
+  end;
+end;
+
+procedure TFPOAuth2IniStore.LoadConfig(AConfig: TOAuth2Config);
+Var
+  Ini : TMemIniFile;
+
+begin
+  Touch('loadconfig');
+  EnsureFileName;
+  Ini:=TMemIniFile.Create(ConfigFileName);
+  try
+    LoadConfigFromIni(Ini,AConfig);
+  finally
+    Ini.Free;
+  end;
+end;
+
+function TFPOAuth2IniStore.EnsureUserSession(ASession: TOAuth2Session): Boolean;
+
+begin
+  Result:=(UserSessionSection<>'');
+end;
+
+constructor TFPOAuth2IniStore.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  EnsureConfigSections;
+end;
+
+destructor TFPOAuth2IniStore.Destroy;
+begin
+  inherited Destroy;
+end;
+
+procedure TFPOAuth2IniStore.LoadSession(ASession: TOAuth2Session;
+  const AUser: String);
+
+Var
+  Ini : TMemIniFile;
+
+begin
+  Touch('loadsession');
+  EnsureFileName;
+  If not EnsureUserSession(ASession) then
+    Exit;
+  Ini:=TMemIniFile.Create(SessionFileName);
+  try
+    LoadSessionFromIni(Ini,ASession);
+  finally
+    Ini.Free;
+  end;
+end;
+
+procedure TFPOAuth2IniStore.SaveSession(Asession: TOAuth2Session;
+  const AUser: String);
+
+Var
+  Ini : TMemIniFile;
+
+begin
+  EnsureFileName;
+  If not EnsureUserSession(ASession) then
+    Exit;
+  Ini:=TMemIniFile.Create(SessionFileName);
+  try
+    SaveSessionToIni(Ini,ASession);
+    Ini.UpdateFile;
+  finally
+    Ini.Free;
+  end;
+end;
+
+end.
+

packages/fcl-web/src/base/fpwebclient.pp

@@ -0,0 +1,355 @@
+{ **********************************************************************
+  This file is part of the Free Component Library (FCL)
+  Copyright (c) 2015 by the Free Pascal development team
+        
+  FPWebclient - abstraction for client execution of HTTP requests.
+            
+  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 fpwebclient;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils;
+
+Type
+  { TRequestResponse }
+
+  TRequestResponse = Class(TObject)
+  private
+    FHeaders : TStrings;
+    FStream : TStream;
+    FOwnsStream : Boolean;
+  Protected
+    function GetHeaders: TStrings;virtual;
+    function GetStream: TStream;virtual;
+  Public
+    Destructor Destroy; override;
+    Procedure SetContentFromString(Const S : String) ;
+    Function GetContentAsString : String;
+    // Request headers or response headers
+    Property Headers : TStrings Read GetHeaders;
+    // Request content or response content
+    Property Content: TStream Read GetStream;
+  end;
+
+  { TWebClientRequest }
+
+  TWebClientRequest = Class(TRequestResponse)
+  Private
+    FExtraParams : TStrings;
+    FResponseStream: TStream;
+  Protected
+    function GetExtraParams: TStrings; virtual;
+  Public
+    Destructor Destroy; override;
+    Function ParamsAsQuery : String;
+    // Query Parameters to include in request
+    Property Params : TStrings Read GetExtraParams;
+    // If you want the response to go to this stream, set this in the request
+    Property ResponseContent : TStream Read FResponseStream Write FResponseStream;
+  end;
+
+
+  { TResponse }
+
+  { TWebClientResponse }
+
+  TWebClientResponse = Class(TRequestResponse)
+  Protected
+    Function GetStatusCode : Integer; virtual;
+    Function GetStatusText : String; virtual;
+  Public
+    Constructor Create(ARequest : TWebClientRequest); virtual;
+    // Status code of request
+    Property StatusCode : Integer Read GetStatusCode;
+    // Status text of request
+    Property StatusText : String Read GetStatusText;
+  end;
+
+  { TAbstractRequestSigner }
+
+  TAbstractRequestSigner = Class(TComponent)
+  Protected
+    Procedure DoSignRequest(ARequest : TWebClientRequest); virtual; abstract;
+  Public
+    Procedure SignRequest(ARequest : TWebClientRequest);
+  end;
+
+  { TAbstractResponseExaminer }
+
+  TAbstractResponseExaminer = Class(TComponent)
+  Protected
+    Procedure DoExamineResponse(AResponse : TWebClientResponse); virtual; abstract;
+  Public
+    Procedure ExamineResponse(AResponse : TWebClientResponse);
+  end;
+
+  { TAbstractWebClient }
+
+  TSSLVersion = (svAny,svSSLv2,svSSLv3,svTLSv1,svTLSv11,svTLSv12,svTLSv13);
+  TSSLVersions = Set of TSSLVersion;
+  TSSLVersionArray = Array of TSSLVersion;
+
+  TAbstractWebClient = Class(TComponent)
+  private
+    FExaminer: TAbstractResponseExaminer;
+    FSigner: TAbstractRequestSigner;
+    FLogFile : String;
+    FLogStream : TStream;
+    FTrySSLVersion: TSSLVersion;
+    Procedure LogRequest(AMethod, AURL: String; ARequest: TWebClientRequest);
+    Procedure LogResponse(AResponse: TWebClientResponse);
+    procedure SetLogFile(AValue: String);
+  protected
+    // Write a string to the log file
+    procedure StringToStream(str: string);
+    // Must execute the requested method using request/response. Must take ResponseCOntent stream into account
+    Function DoHTTPMethod(Const AMethod,AURL : String; ARequest : TWebClientRequest) : TWebClientResponse; virtual; abstract;
+    // Must create a request.
+    Function DoCreateRequest : TWebClientRequest; virtual; abstract;
+  Public
+    Destructor Destroy; override;
+
+    // Executes the HTTP method AMethod on AURL. Raises an exception on error.
+    // On success, TWebClientResponse is returned. It must be freed by the caller.
+    Function ExecuteRequest(Const AMethod,AURL : String; ARequest : TWebClientRequest) : TWebClientResponse;
+    // Same as HTTPMethod, but signs the request first using signer.
+    Function ExecuteSignedRequest(Const AMethod,AURL : String; ARequest : TWebClientRequest) : TWebClientResponse;
+    // Create a new request. The caller is responsible for freeing the request.
+    Function CreateRequest : TWebClientRequest;
+    // These can be set to sign/examine the request/response.
+    Property RequestSigner : TAbstractRequestSigner Read FSigner Write FSigner;
+    Property ResponseExaminer : TAbstractResponseExaminer Read FExaminer Write FExaminer;
+    Property LogFile : String Read FLogFile Write SetLogFile;
+    property SSLVersion : TSSLVersion Read FTrySSLVersion Write FTrySSLVersion;
+  end;
+  TAbstractWebClientClass = Class of TAbstractWebClient;
+
+  EFPWebClient = Class(Exception);
+
+Var
+  DefaultWebClientClass : TAbstractWebClientClass = Nil;
+
+implementation
+
+uses httpdefs;
+
+{ TAbstractRequestSigner }
+
+Procedure TAbstractRequestSigner.SignRequest(ARequest: TWebClientRequest);
+begin
+  DoSignRequest(ARequest);
+end;
+
+{ TAbstractResponseExaminer }
+
+Procedure TAbstractResponseExaminer.ExamineResponse(
+  AResponse: TWebClientResponse);
+begin
+  DoExamineResponse(AResponse);
+end;
+
+{ TWebClientRequest }
+
+function TWebClientRequest.GetExtraParams: TStrings;
+begin
+  if FExtraParams=Nil then
+    FExtraParams:=TStringList.Create;
+  Result:=FExtraParams;
+end;
+
+
+destructor TWebClientRequest.Destroy;
+begin
+  FreeAndNil(FExtraParams);
+  inherited Destroy;
+end;
+
+function TWebClientRequest.ParamsAsQuery: String;
+
+Var
+  N,V : String;
+  I : integer;
+
+begin
+  Result:='';
+  if Assigned(FextraParams) then
+    For I:=0 to FextraParams.Count-1 do
+      begin
+      If Result<>'' then
+        Result:=Result+'&';
+      FextraParams.GetNameValue(I,N,V);
+      Result:=Result+N+'='+HttpEncode(V);
+      end;
+end;
+
+{ TWebClientResponse }
+
+function TWebClientResponse.GetStatusCode: Integer;
+begin
+  Result:=0;
+end;
+
+function TWebClientResponse.GetStatusText: String;
+begin
+  Result:='';
+end;
+
+constructor TWebClientResponse.Create(ARequest: TWebClientRequest);
+begin
+  FStream:=ARequest.ResponseContent;
+end;
+
+{ TAbstractWebClient }
+
+
+procedure TAbstractWebClient.SetLogFile(AValue: String);
+begin
+  if FLogFile=AValue then Exit;
+  if Assigned(FlogStream) then
+    FreeAndNil(FlogStream);
+  FLogFile:=AValue;
+  if (FLogFile<>'') then
+    if FileExists(FLogFile) then
+      FLogStream:=TFileStream.Create(FLogFile,fmOpenWrite or fmShareDenyWrite)
+    else
+      FLogStream:=TFileStream.Create(FLogFile,fmCreate or fmShareDenyWrite);
+end;
+
+
+procedure TAbstractWebClient.StringToStream(str: string);
+begin
+  if Assigned(FLogStream) then
+    begin
+    Str:=Str+sLineBreak;
+    FlogStream.Write(str[1],length(str));
+    end;
+end;
+
+destructor TAbstractWebClient.Destroy;
+begin
+  LogFile:='';
+  inherited Destroy;
+end;
+
+procedure TAbstractWebClient.LogRequest(AMethod, AURL: String;
+  ARequest: TWebClientRequest);
+
+
+Var
+  I : Integer;
+
+begin
+  StringToStream(StringOfChar('-',80));
+  StringToStream('Request : '+AMethod+' '+AURL);
+  StringToStream('Headers:');
+  For I:=0 to ARequest.Headers.Count-1 do
+   StringToStream(ARequest.Headers[I]);
+  StringToStream('Body:');
+  FLogStream.CopyFrom(ARequest.Content,0);
+  ARequest.Content.Position:=0;
+  StringToStream('');
+end;
+
+procedure TAbstractWebClient.LogResponse(AResponse: TWebClientResponse);
+
+Var
+  I : Integer;
+
+begin
+  StringToStream(StringOfChar('-',80));
+  StringToStream('Response : '+IntToStr(AResponse.StatusCode)+' : '+AResponse.StatusText);
+  StringToStream('Headers:');
+  For I:=0 to AResponse.Headers.Count-1 do
+    StringToStream(AResponse.Headers[I]);
+  StringToStream('Body:');
+  FLogStream.CopyFrom(AResponse.Content,0);
+  AResponse.Content.Position:=0;
+  StringToStream('');
+end;
+
+function TAbstractWebClient.ExecuteRequest(const AMethod, AURL: String;
+  ARequest: TWebClientRequest): TWebClientResponse;
+begin
+  if Assigned(FLogStream) then
+    LogRequest(AMethod,AURL,ARequest);
+  Result:=DoHTTPMethod(AMethod,AURL,ARequest);
+  if Assigned(Result) then
+    begin
+    if Assigned(FLogStream) then
+      LogResponse(Result);
+    If Assigned(FExaminer) then
+      FExaminer.ExamineResponse(Result);
+    end;
+end;
+
+function TAbstractWebClient.ExecuteSignedRequest(const AMethod, AURL: String;
+  ARequest: TWebClientRequest): TWebClientResponse;
+begin
+  If Assigned(FSigner) and Assigned(ARequest) then
+    FSigner.SignRequest(ARequest);
+  Result:=ExecuteRequest(AMethod,AURl,ARequest);
+end;
+
+function TAbstractWebClient.CreateRequest: TWebClientRequest;
+begin
+  Result:=DoCreateRequest;
+end;
+
+{ TRequestResponse }
+
+function TRequestResponse.GetHeaders: TStrings;
+begin
+  if FHeaders=Nil then
+    begin
+    FHeaders:=TStringList.Create;
+    FHeaders.NameValueSeparator:=':';
+    end;
+  Result:=FHeaders;
+end;
+
+function TRequestResponse.GetStream: TStream;
+begin
+  if (FStream=Nil) then
+    begin
+    FStream:=TMemoryStream.Create;
+    FOwnsStream:=True;
+    end;
+  Result:=FStream;
+end;
+
+Destructor TRequestResponse.Destroy;
+begin
+  FreeAndNil(FHeaders);
+  If FOwnsStream then
+    FreeAndNil(FStream);
+  inherited Destroy;
+end;
+
+Procedure TRequestResponse.SetContentFromString(Const S: String);
+begin
+  if (S<>'') then
+    Content.WriteBuffer(S[1],SizeOf(Char)*Length(S));
+end;
+
+Function TRequestResponse.GetContentAsString: String;
+begin
+  SetLength(Result,Content.Size);
+  if (Length(Result)>0) then
+    begin
+    Content.Position:=0;
+    Content.ReadBuffer(Result[1],Length(Result));
+    end;
+end;
+
+end.
+

packages/fcl-web/src/base/httpprotocol.pp

@@ -0,0 +1,269 @@
+unit httpprotocol;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils;
+
+Type
+  // HTTP 1.1 defined headers.
+  THeader = (hhUnknown,
+     hhAccept,hhAcceptCharset,hhAcceptEncoding, hhAcceptLanguage,
+     hhAcceptRanges, hhAge, hhAllow, hhAuthorization, hhCacheControl,
+     hhConnection, hhContentEncoding, hhContentLanguage,
+     hhContentLength,hhContentLocation, hhContentMD5, hhContentRange,
+     hhContentType, hhDate, hhETag, hhExpires, hhExpect,
+     hhFrom, hhHost, hhIfMatch, hhIfModifiedSince, hhIfNoneMatch,
+     hhIfRange, hhIfUnModifiedSince, hhLastModified, hhLocation, hhMaxForwards,
+     hhPragma, hhProxyAuthenticate, hhProxyAuthorization, hhRange, hhReferer,
+     hhRetryAfter, hhServer, hhTE, hhTrailer,
+     hhTransferEncoding, hhUpgrade , hhUserAgent, hhVary,
+     hhVia, hhWarning, hhWWWAuthenticate);
+  THeaders = Set of THeader;
+  THeaderDirection = (hdRequest,hdResponse);
+  THeaderDirections = Set of THeaderDirection;
+
+  THeadersArray = Array[THeader] of string;
+
+Const
+  HeaderAccept          = 'Accept';
+  HeaderAcceptCharset   = 'Accept-Charset';
+  HeaderAcceptEncoding  = 'Accept-Encoding';
+  HeaderAcceptLanguage  = 'Accept-Language';
+  HeaderAcceptRanges    = 'Accept-Ranges';
+  HeaderAge             = 'Age';
+  HeaderAllow           = 'Allow';
+  HeaderAuthorization   = 'Authorization';
+  HeaderCacheControl    = 'Cache-Control';
+  HeaderConnection      = 'Connection';
+  HeaderContentEncoding = 'Content-Encoding';
+  HeaderContentLanguage = 'Content-Language';
+  HeaderContentLength   = 'Content-Length';
+  HeaderContentLocation = 'Content-Location';
+  HeaderContentMD5      = 'Content-MD5';
+  HeaderContentRange    = 'Content-Range';
+  HeaderContentType     = 'Content-Type';
+  HeaderDate            = 'Date';
+  HeaderETag            = 'ETag';
+  HeaderExpires         = 'Expires';
+  HeaderExpect          = 'Expect';
+  HeaderFrom            = 'From';
+  HeaderHost            = 'Host';
+  HeaderIfMatch         = 'If-Match';
+  HeaderIfModifiedSince = 'If-Modified-Since';
+  HeaderIfNoneMatch     = 'If-None-Match';
+  HeaderIfRange         = 'If-Range';
+  HeaderIfUnModifiedSince = 'If-Unmodified-Since';
+  HeaderLastModified    = 'Last-Modified';
+  HeaderLocation        = 'Location';
+  HeaderMaxForwards     = 'Max-Forwards';
+  HeaderPragma          = 'Pragma';
+  HeaderProxyAuthenticate = 'Proxy-Authenticate';
+  HeaderProxyAuthorization = 'Proxy-Authorization';
+  HeaderRange           = 'Range';
+  HeaderReferer         = 'Referer';
+  HeaderRetryAfter      = 'Retry-After';
+  HeaderServer          = 'Server';
+  HeaderTE              = 'TE';
+  HeaderTrailer         = 'Trailer';
+  HeaderTransferEncoding = 'Transfer-Encoding';
+  HeaderUpgrade         = 'Upgrade';
+  HeaderUserAgent       = 'User-Agent';
+  HeaderVary            = 'Vary';
+  HeaderVia             = 'Via';
+  HeaderWarning         = 'Warning';
+  HeaderWWWAuthenticate = 'WWW-Authenticate';
+
+  // These Headers are NOT in the HTTP 1.1 definition.
+  HeaderXRequestedWith  = 'X-Requested-With';
+  HeaderCookie          = 'Cookie';
+  HeaderSetCookie       = 'Set-Cookie';
+
+  HTTPDateFmt     = '"%s", dd "%s" yyyy hh:mm:ss'; // For use in FormatDateTime
+  SCookieExpire   = ' "Expires="'+HTTPDateFmt+' "GMT"';
+  SCookieDomain   = ' Domain=%s';
+  SCookiePath     = ' Path=%s';
+  SCookieSecure   = ' Secure';
+  SCookieHttpOnly = ' HttpOnly';
+
+  HTTPMonths: array[1..12] of string[3] = (
+    'Jan', 'Feb', 'Mar', 'Apr',
+    'May', 'Jun', 'Jul', 'Aug',
+    'Sep', 'Oct', 'Nov', 'Dec');
+  HTTPDays: array[1..7] of string[3] = (
+    'Sun', 'Mon', 'Tue', 'Wed',
+    'Thu', 'Fri', 'Sat');
+
+
+Const
+  HTTPHeaderDirections : Array[THeader] of THeaderDirections = (
+   [],
+   [hdRequest],[hdRequest],[hdRequest], [hdRequest],
+   [hdResponse], [hdResponse], [hdResponse], [hdRequest], [hdRequest,hdResponse],
+   [hdRequest,hdResponse], [hdRequest,hdResponse], [hdRequest,hdResponse],
+   [hdRequest,hdResponse],[hdRequest,hdResponse], [hdRequest,hdResponse], [hdRequest,hdResponse],
+   [hdRequest,hdResponse], [hdRequest,hdResponse], [hdResponse], [hdRequest,hdResponse], [hdRequest],
+   [hdRequest], [hdRequest], [hdRequest], [hdRequest], [hdRequest],
+   [hdRequest], [hdRequest], [hdRequest,hdResponse], [hdResponse], [hdRequest],
+   [hdRequest, hdResponse] , [hdResponse], [hdRequest], [hdRequest,hdResponse], [hdRequest],
+   [hdResponse], [hdResponse], [hdRequest], [hdRequest,hdResponse],
+   [hdRequest,hdResponse], [hdRequest,hdResponse], [hdRequest], [hdRequest,hdResponse],
+   [hdRequest,hdResponse], [hdRequest,hdResponse], [hdResponse]);
+
+  HTTPHeaderNames : THeadersArray
+                 = ('',
+                    HeaderAccept,HeaderAcceptCharset,HeaderAcceptEncoding, HeaderAcceptLanguage,
+                    HeaderAcceptRanges, HeaderAge, HeaderAllow, HeaderAuthorization, HeaderCacheControl,
+                    HeaderConnection, HeaderContentEncoding, HeaderContentLanguage,
+                    HeaderContentLength,HeaderContentLocation, HeaderContentMD5, HeaderContentRange,
+                    HeaderContentType, HeaderDate, HeaderETag, HeaderExpires, HeaderExpect,
+                    HeaderFrom, HeaderHost, HeaderIfMatch, HeaderIfModifiedSince, HeaderIfNoneMatch,
+                    HeaderIfRange, HeaderIfModifiedSince, HeaderLastModified, HeaderLocation, HeaderMaxForwards ,
+                    HeaderPragma, HeaderProxyAuthenticate, HeaderProxyAuthorization, HeaderRange, HeaderReferer,
+                    HeaderRetryAfter, HeaderServer, HeaderTE, HeaderTrailer,
+                    HeaderTransferEncoding, HeaderUpgrade , HeaderUserAgent, HeaderVary,
+                    HeaderVia, HeaderWarning, HeaderWWWAuthenticate);
+
+Function HeaderName(AHeader : THeader) : String;
+Function HeaderType(AHeader : String) : THeader;
+Function HTTPDecode(const AStr: String): String;
+Function HTTPEncode(const AStr: String): String;
+Function IncludeHTTPPathDelimiter(const AStr: String): String;
+Function ExcludeHTTPPathDelimiter(const AStr: String): String;
+
+implementation
+
+function HeaderName(AHeader: THeader): String;
+
+begin
+  Result:=HTTPHeaderNames[AHeader];
+end;
+
+function HeaderType(AHeader: String): THeader;
+
+begin
+  Result:=High(THeader);
+  While (Result>hhUnknown) and (CompareText(HTTPHeaderNames[Result],AHeader)<>0) do
+    Result:=Pred(Result);
+end;
+
+function HTTPDecode(const AStr: String): String;
+
+var
+  S,SS, R : PChar;
+  H : String[3];
+  L,C : Integer;
+
+begin
+  L:=Length(Astr);
+  SetLength(Result,L);
+  If (L=0) then
+    exit;
+  S:=PChar(AStr);
+  SS:=S;
+  R:=PChar(Result);
+  while (S-SS)<L do
+    begin
+    case S^ of
+      '+': R^ := ' ';
+      '%': begin
+           Inc(S);
+           if ((S-SS)<L) then
+             begin
+             if (S^='%') then
+               R^:='%'
+             else
+               begin
+               H:='$00';
+               H[2]:=S^;
+               Inc(S);
+               If (S-SS)<L then
+                 begin
+                 H[3]:=S^;
+                 Val(H,PByte(R)^,C);
+                 If (C<>0) then
+                   R^:=' ';
+                 end;
+               end;
+             end;
+           end;
+      else
+        R^ := S^;
+      end;
+    Inc(R);
+    Inc(S);
+    end;
+  SetLength(Result,R-PChar(Result));
+end;
+
+function HTTPEncode(const AStr: String): String;
+
+const
+  HTTPAllowed = ['A'..'Z','a'..'z',
+                 '*','@','.','_','-',
+                 '0'..'9',
+                 '$','!','''','(',')'];
+
+var
+  SS,S,R: PChar;
+  H : String[2];
+  L : Integer;
+
+begin
+  L:=Length(AStr);
+  SetLength(Result,L*3); // Worst case scenario
+  if (L=0) then
+    exit;
+  R:=PChar(Result);
+  S:=PChar(AStr);
+  SS:=S; // Avoid #0 limit !!
+  while ((S-SS)<L) do
+    begin
+    if S^ in HTTPAllowed then
+      R^:=S^
+    else if (S^=' ') then
+      R^:='+'
+    else
+      begin
+      R^:='%';
+      H:=HexStr(Ord(S^),2);
+      Inc(R);
+      R^:=H[1];
+      Inc(R);
+      R^:=H[2];
+      end;
+    Inc(R);
+    Inc(S);
+    end;
+  SetLength(Result,R-PChar(Result));
+end;
+
+function IncludeHTTPPathDelimiter(const AStr: String): String;
+
+Var
+  l : Integer;
+
+begin
+  Result:=AStr;
+  L:=Length(Result);
+  If (L>0) and (Result[L]<>'/') then
+    Result:=Result+'/';
+end;
+
+function ExcludeHTTPPathDelimiter(const AStr: String): String;
+
+Var
+  l : Integer;
+
+begin
+  L:=Length(AStr);
+  If (L>0) and (AStr[L]='/') then
+    Result:=Copy(AStr,1,L-1)
+  else
+    Result:=AStr;
+end;
+
+end.
+

packages/fcl-web/src/base/restbase.pp

@@ -0,0 +1,1342 @@
+{ **********************************************************************
+  This file is part of the Free Component Library (FCL)
+  Copyright (c) 2015 by the Free Pascal development team
+        
+  Base for REST classes 
+            
+  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 restbase;
+
+{$mode objfpc}{$H+}
+{ $DEFINE DEBUGBASEOBJMEMLEAK}
+
+interface
+
+uses
+  typinfo, fpjson, Classes, SysUtils, contnrs;
+
+Type
+  ERESTAPI = Class(Exception);
+  TStringArray = Array of string;
+  TStringArrayArray = Array of TStringArray;
+  TUnicodeStringArray = Array of UnicodeString;
+  TIntegerArray = Array of Integer;
+  TInt64Array = Array of Int64;
+  TInt32Array = Array of Integer;
+  TFloatArray = Array of TJSONFloat;
+  TFloatArrayArray = Array of TFloatArray;
+  TDoubleArray = Array of TJSONFloat;
+  TDoubleArrayArray = Array of TDoubleArray;
+  TDateTimeArray = Array of TDateTime;
+  TBooleanArray = Array of boolean;
+  TChildType = (ctArray,ctObject);
+  TChildTypes = Set of TChildType;
+
+  { TBaseObject }
+  TObjectOption = (ooStartRecordingChanges,ooCreateObjectOnGet);
+  TObjectOptions = set of TObjectOption;
+  TDateTimeType = (dtNone,dtDateTime,dtDate,dtTime);
+
+Const
+  DefaultObjectOptions = [ooStartRecordingChanges]; // Default for constructor.
+  IndexShift = 3; // Number of bits reserved for flags.
+
+Type
+{$M+}
+
+  TBaseObject = CLass(TObject)
+  Private
+    FObjectOptions : TObjectOptions;
+    fadditionalProperties : TJSONObject;
+    FBits : TBits;
+    Function GetDynArrayProp(P: PPropInfo) : Pointer; virtual;
+    procedure SetDynArrayProp(P: PPropInfo; AValue : Pointer); virtual;
+    procedure SetObjectOptions(AValue: TObjectOptions);
+    Function GetAdditionalProperties : TJSONObject;
+  protected
+{$ifdef ver2_6}
+    // Version 2.6.4 has a bug for i386 where the array cannot be set through RTTI.
+    // This is a helper method that sets the length of the array to the desired length,
+    // After which the new array pointer is read again.
+    // AName is guaranteed to be lowercase
+    Procedure SetArrayLength(const AName : String; ALength : Longint); virtual;
+{$endif}
+    Procedure MarkPropertyChanged(AIndex : Integer);
+    Function IsDateTimeProp(Info : PTypeInfo) : Boolean;
+    Function DateTimePropType(Info : PTypeInfo) : TDateTimeType;
+    // Load properties
+    Procedure ClearProperty(P: PPropInfo); virtual;
+    Procedure SetBooleanProperty(P: PPropInfo; AValue: Boolean); virtual;
+    Procedure SetFloatProperty(P: PPropInfo; AValue: Extended); virtual;
+    Procedure SetInt64Property(P: PPropInfo; AValue: Int64); virtual;
+    {$ifndef ver2_6}
+    Procedure SetQWordProperty(P: PPropInfo; AValue: QWord); virtual;
+    {$endif}
+    Procedure SetIntegerProperty(P: PPropInfo; AValue: Integer); virtual;
+    Procedure SetStringProperty(P: PPropInfo; AValue: String); virtual;
+    Procedure SetArrayProperty(P: PPropInfo; AValue : TJSONArray); virtual;
+    Procedure SetObjectProperty(P: PPropInfo; AValue : TJSONObject); virtual;
+    Procedure SetSetProperty(P: PPropInfo; AValue : TJSONArray); virtual;
+    Procedure SetEnumProperty(P: PPropInfo; AValue : TJSONData); virtual;
+    // Save properties
+    Function GetBooleanProperty(P: PPropInfo) : TJSONData; virtual;
+    Function GetIntegerProperty(P: PPropInfo) : TJSONData; virtual;
+    Function GetInt64Property(P: PPropInfo) : TJSONData; virtual;
+    Function GetQwordProperty(P: PPropInfo) : TJSONData; virtual;
+    Function GetFloatProperty(P: PPropInfo) : TJSONData; virtual;
+    Function GetStringProperty(P: PPropInfo) : TJSONData; virtual;
+    Function GetSetProperty(P: PPropInfo) : TJSONData; virtual;
+    Function GetEnumeratedProperty(P: PPropInfo) : TJSONData; virtual;
+    Function GetArrayProperty(P: PPropInfo) : TJSONData; virtual;
+    Function GetObjectProperty(P: PPropInfo) : TJSONData; virtual;
+    // Clear properties on
+    Procedure ClearChildren(ChildTypes : TChildTypes); virtual;
+    Class Function ClearChildTypes : TChildTypes; virtual;
+  Public
+    Constructor Create(AOptions : TObjectOptions = DefaultObjectOptions); Virtual;
+    Destructor Destroy; override;
+    Procedure StartRecordPropertyChanges;
+    Procedure ClearPropertyChanges;
+    Procedure StopRecordPropertyChanges;
+    Function IsPropertyModified(Info : PPropInfo) : Boolean;
+    Function IsPropertyModified(const AName : String) : Boolean;
+    Class Function AllowAdditionalProperties : Boolean; virtual;
+    Class Function GetTotalPropCount : Integer; virtual;
+    Class Function GetCurrentPropCount : Integer; virtual;
+    Class Function GetParentPropCount : Integer; virtual;
+    Class Function ExportPropertyName(Const AName : String) : string; virtual;
+    Class Function CleanPropertyName(Const AName : String) : string;
+    Class Function CreateObject(Const AKind : String) : TBaseObject;
+    Class Procedure RegisterObject;
+    Class Function ObjectRestKind : String; virtual;
+    Procedure LoadPropertyFromJSON(Const AName : String; JSON : TJSONData); virtual;
+    Function SavePropertyToJSON(Info : PPropInfo) : TJSONData; virtual;
+    Procedure LoadFromJSON(JSON : TJSONObject); virtual;
+    Procedure SaveToJSON(JSON : TJSONObject); virtual;
+    Function SaveToJSON : TJSONObject;
+    Property ObjectOptions : TObjectOptions Read FObjectOptions Write SetObjectOptions;
+    Property additionalProperties : TJSONObject Read GetAdditionalProperties;
+  end;
+  TBaseObjectClass = Class of TBaseObject;
+  TObjectArray =  Array of TBaseObject;
+  TObjectArrayArray =  Array of TObjectArray;
+
+  TBaseListEnumerator = class
+  private
+    FList: TFPObjectList;
+    FPosition: Integer;
+  public
+    constructor Create(AList: TFPObjectList);
+    function GetCurrent: TBaseObject; virtual;
+    function MoveNext: Boolean;
+    property Current: TBaseObject read GetCurrent;
+  end;
+  TBaseListEnumeratorClass = Class of TBaseListEnumerator;
+
+  { TBaseObjectList }
+
+  TBaseObjectList = Class(TBaseObject)
+  private
+    FList : TFPObjectList;
+  Protected
+    function GetO(Aindex : Integer): TBaseObject;
+    procedure SetO(Aindex : Integer; AValue: TBaseObject);
+    Class Function ObjectClass : TBaseObjectClass; virtual;
+    Function DoCreateEnumerator(AEnumClass : TBaseListEnumeratorClass) : TBaseListEnumerator;
+  Public
+    Constructor Create(AOptions : TObjectOptions = DefaultObjectOptions); Override;
+    Destructor Destroy; override;
+    function GetEnumerator : TBaseListEnumerator;
+    Function AddObject(Const AKind : String) : TBaseObject; virtual;
+    Property Objects [Aindex : Integer] : TBaseObject Read GetO Write SetO; default;
+  end;
+
+  { TBaseObjectList }
+
+  { TBaseNamedObjectList }
+
+  TBaseNamedObjectList = Class(TBaseObject)
+  private
+    FList : TStringList;
+    function GetN(Aindex : Integer): String;
+    function GetO(Aindex : Integer): TBaseObject;
+    function GetON(AName : String): TBaseObject;
+    procedure SetN(Aindex : Integer; AValue: String);
+    procedure SetO(Aindex : Integer; AValue: TBaseObject);
+    procedure SetON(AName : String; AValue: TBaseObject);
+  Protected
+    Class Function ObjectClass : TBaseObjectClass; virtual;
+  Public
+    Constructor Create(AOptions : TObjectOptions = DefaultObjectOptions); Override;
+    Destructor Destroy; override;
+    Function AddObject(Const AName,AKind : String) : TBaseObject; virtual;
+    Property Names [Aindex : Integer] : String Read GetN Write SetN;
+    Property Objects [Aindex : Integer] : TBaseObject Read GetO Write SetO;
+    Property ObjectByName [AName : String] : TBaseObject Read GetON Write SetON; default;
+  end;
+
+  // used to catch a general JSON schema.
+  { TJSONSchema }
+
+  TJSONSchema = Class(TBaseObject)
+  private
+    FSchema: String;
+  Public
+    Procedure SetArrayProperty(P: PPropInfo; AValue : TJSONArray); override;
+    Procedure LoadFromJSON(JSON : TJSONObject); override;
+    Property Schema : String Read FSchema Write FSchema;
+  end;
+  TJSONSchemaArray = Array of TJSONSchema;
+  TTJSONSchemaArray = TJSONSchemaArray;
+
+  { TObjectFactory }
+
+  TObjectFactory = Class(TComponent)
+  Private
+    FList : TClassList;
+  Public
+    Constructor Create(AOwner : TComponent); override;
+    Destructor Destroy; override;
+    Procedure RegisterObject(A : TBaseObjectClass);
+    Function GetObjectClass(Const AKind : String) : TBaseObjectClass;
+  end;
+
+Function  RESTFactory : TObjectFactory;
+
+Function DateTimeToRFC3339(ADate :TDateTime):string;
+Function DateToRFC3339(ADate :TDateTime):string;
+Function TimeToRFC3339(ADate :TDateTime):string;
+Function TryRFC3339ToDateTime(const Avalue: String; out ADateTime: TDateTime): Boolean;
+Function RFC3339ToDateTime(const Avalue: String): TDateTime;
+
+implementation
+
+Var
+  Fact : TObjectFactory;
+
+function DateTimeToRFC3339(ADate :TDateTime):string;
+
+begin
+  Result:=FormatDateTime('yyyy-mm-dd"T"hh":"nn":"ss"."zzz"Z"',ADate);
+end;
+
+function DateToRFC3339(ADate: TDateTime): string;
+begin
+  Result:=FormatDateTime('yyyy-mm-dd',ADate);
+end;
+
+function TimeToRFC3339(ADate :TDateTime):string;
+
+begin
+  Result:=FormatDateTime('hh":"nn":"ss"."zzz',ADate);
+end;
+
+
+Function TryRFC3339ToDateTime(const Avalue: String; out ADateTime: TDateTime): Boolean;
+
+//          1         2
+// 12345678901234567890123
+// yyyy-mm-ddThh:nn:ss.zzz
+
+Type
+  TPartPos = (ppTime,ppYear,ppMonth,ppDay,ppHour,ppMinute,ppSec);
+  TPos = Array [TPartPos] of byte;
+
+Const
+  P : TPos = (11,1,6,9,12,15,18);
+
+var
+  lY, lM, lD, lH, lMi, lS: Integer;
+
+begin
+  if Trim(AValue) = '' then
+    begin
+    Result:=True;
+    ADateTime:=0;
+    end;
+  lY:=StrToIntDef(Copy(AValue,P[ppYear],4),-1);
+  lM:=StrToIntDef(Copy(AValue,P[ppMonth],2),-1);
+  lD:=StrToIntDef(Copy(AValue,P[ppDay],2),-1);
+  if (Length(AValue)>=P[ppTime]) then
+    begin
+    lH:=StrToIntDef(Copy(AValue,P[ppHour],2),-1);
+    lMi:=StrToIntDef(Copy(AValue,P[ppMinute],2),-1);
+    lS:=StrToIntDef(Copy(AValue,P[ppSec],2),-1);
+    end
+  else
+    begin
+    lH:=0;
+    lMi:=0;
+    lS:=0;
+    end;
+  Result:=(lY>=0) and (lM>=00) and (lD>=0) and (lH>=0) and (lMi>=0) and (ls>=0);
+  if Not Result then
+    ADateTime:=0
+  else
+    { Cannot EncodeDate if any part equals 0. EncodeTime is okay. }
+    if (lY = 0) or (lM = 0) or (lD = 0) then
+      ADateTime:=EncodeTime(lH, lMi, lS, 0)
+    else
+      ADateTime:=EncodeDate(lY, lM, lD) + EncodeTime(lH, lMi, lS, 0);
+end;
+
+Function CountProperties(TypeInfo : PTypeInfo; Recurse : Boolean): Integer;
+
+   function aligntoptr(p : pointer) : pointer;inline;
+
+   begin
+{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
+     result:=align(p,sizeof(p));
+{$else FPC_REQUIRES_PROPER_ALIGNMENT}
+     result:=p;
+{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
+   end;
+
+var
+  hp : PTypeData;
+  pd : ^TPropData;
+
+begin
+  Result:=0;
+  while Assigned(TypeInfo) do
+    begin
+    // skip the name
+    hp:=GetTypeData(Typeinfo);
+    // the class info rtti the property rtti follows immediatly
+    pd:=aligntoptr(pointer(pointer(@hp^.UnitName)+Length(hp^.UnitName)+1));
+    Result:=Result+Pd^.PropCount;
+    if Recurse then
+      TypeInfo:=HP^.ParentInfo
+    else
+      TypeInfo:=Nil;
+    end;
+end;
+
+
+Function RFC3339ToDateTime(const Avalue: String): TDateTime;
+
+begin
+  if Not TryRFC3339ToDateTime(AValue,Result) then
+    Result:=0;
+end;
+
+Function RESTFactory : TObjectFactory;
+
+begin
+  if Fact=Nil then
+    Fact:=TObjectfactory.Create(Nil);
+  Result:=Fact;
+end;
+
+{ TObjectFactory }
+
+Constructor TObjectFactory.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  FList:=TClassList.Create;
+end;
+
+Destructor TObjectFactory.Destroy;
+begin
+  FreeAndNil(FList);
+  inherited Destroy;
+end;
+
+Procedure TObjectFactory.RegisterObject(A: TBaseObjectClass);
+begin
+  Flist.Add(A);
+end;
+
+Function TObjectFactory.GetObjectClass(Const AKind: String): TBaseObjectClass;
+
+Var
+  I : Integer;
+  N : String;
+
+begin
+  I:=FList.Count-1;
+  Result:=Nil;
+  While (Result=Nil) and (I>=0) do
+    begin
+    Result:=TBaseObjectClass(FList[i]);
+    N:=Result.ObjectRestKind;
+    if CompareText(N,AKind)<>0 then
+      Result:=nil;
+    Dec(I);
+    end;
+end;
+
+
+{ TBaseNamedObjectList }
+
+function TBaseNamedObjectList.GetN(Aindex : Integer): String;
+begin
+  Result:=Flist[AIndex];
+end;
+
+function TBaseNamedObjectList.GetO(Aindex: Integer): TBaseObject;
+begin
+  Result:=TBaseObject(Flist.Objects[AIndex]);
+end;
+
+function TBaseNamedObjectList.GetON(AName : String): TBaseObject;
+
+Var
+  I : Integer;
+
+begin
+  I:=FList.IndexOf(AName);
+  if I<>-1 then
+    Result:=GetO(I)
+  else
+    Result:=Nil;
+end;
+
+procedure TBaseNamedObjectList.SetN(Aindex : Integer; AValue: String);
+begin
+  Flist[AIndex]:=Avalue
+end;
+
+procedure TBaseNamedObjectList.SetO(Aindex: Integer; AValue: TBaseObject);
+begin
+  Flist.Objects[AIndex]:=Avalue
+end;
+
+procedure TBaseNamedObjectList.SetON(AName : String; AValue: TBaseObject);
+Var
+  I : Integer;
+
+begin
+  I:=FList.IndexOf(AName);
+  if I<>-1 then
+    SetO(I,AValue)
+  else
+    Flist.AddObject(AName,AValue);
+end;
+
+Class Function TBaseNamedObjectList.ObjectClass: TBaseObjectClass;
+begin
+  Result:=TBaseObject;
+end;
+
+Constructor TBaseNamedObjectList.Create(AOptions : TObjectOptions = DefaultObjectOptions);
+begin
+  inherited Create(AOptions);
+  FList:=TStringList.Create;
+  Flist.OwnsObjects:=True;
+end;
+
+Destructor TBaseNamedObjectList.Destroy;
+begin
+  FreeAndNil(Flist);
+  inherited Destroy;
+end;
+
+Function TBaseNamedObjectList.AddObject(Const AName, AKind: String
+  ): TBaseObject;
+begin
+  Result:=CreateObject(AKind);
+  ObjectByName[AName]:=Result;
+end;
+{ TJSONSchema }
+
+Procedure TJSONSchema.SetArrayProperty(P: PPropInfo; AValue: TJSONArray);
+begin
+  Schema:=AValue.asJSON
+end;
+
+Procedure TJSONSchema.LoadFromJSON(JSON: TJSONObject);
+begin
+  Schema:=JSON.AsJSON;
+end;
+
+{ TBaseObjectList }
+
+function TBaseObjectList.GetO(Aindex : Integer): TBaseObject;
+begin
+  Result:=TBaseObject(FList[AIndex]);
+end;
+
+procedure TBaseObjectList.SetO(Aindex : Integer; AValue: TBaseObject);
+begin
+  FList[AIndex]:=AValue;
+end;
+
+class function TBaseObjectList.ObjectClass: TBaseObjectClass;
+begin
+  Result:=TBaseObject;
+end;
+
+function TBaseObjectList.DoCreateEnumerator(AEnumClass: TBaseListEnumeratorClass
+  ): TBaseListEnumerator;
+begin
+  Result:=AEnumClass.Create(FList);
+end;
+
+constructor TBaseObjectList.Create(AOptions: TObjectOptions);
+begin
+  inherited Create(AOptions);
+  FList:=TFPObjectList.Create;
+end;
+
+destructor TBaseObjectList.Destroy;
+begin
+  FreeAndNil(FList);
+  inherited Destroy;
+end;
+
+function TBaseObjectList.GetEnumerator: TBaseListEnumerator;
+begin
+  Result:=TBaseListEnumerator.Create(FList);
+end;
+
+function TBaseObjectList.AddObject(const AKind: String): TBaseObject;
+
+Var
+  C : TBaseObjectClass;
+begin
+  if (AKind<>'') then
+    begin
+    C:=RestFactory.GetObjectClass(AKind);
+    if Not C.InheritsFrom(ObjectClass) then
+      Raise ERestAPI.CreateFmt('Cannot add object of kind "%s" to list, associated class "%s" is not a descendent of list class "%s"',[AKind,C.ClassName,ObjectClass.ClassName]);
+    end;
+  Result:=ObjectClass.Create;
+  FList.Add(Result);
+end;
+
+constructor TBAseListEnumerator.Create(AList: TFPObjectList);
+begin
+  inherited Create;
+  FList := AList;
+  FPosition := -1;
+end;
+
+function TBaseListEnumerator.GetCurrent: TBaseObject;
+begin
+  Result := TBaseObject(FList[FPosition]);
+end;
+
+function TBaseListEnumerator.MoveNext: Boolean;
+begin
+  Inc(FPosition);
+  Result := FPosition < FList.Count;
+end;
+
+{ TBaseObject }
+
+function TBaseObject.GetDynArrayProp(P: PPropInfo): Pointer;
+begin
+  Result:=Pointer(GetObjectProp(Self,P));
+end;
+
+
+procedure TBaseObject.SetDynArrayProp(P: PPropInfo; AValue: Pointer);
+begin
+  SetObjectProp(Self,P,TObject(AValue));
+end;
+
+procedure TBaseObject.SetObjectOptions(AValue: TObjectOptions);
+begin
+  if FObjectOptions=AValue then Exit;
+  FObjectOptions:=AValue;
+  if ooStartRecordingChanges in FObjectOptions then
+    StartRecordPropertyChanges
+end;
+
+procedure TBaseObject.MarkPropertyChanged(AIndex: Integer);
+begin
+  If Assigned(FBits) then
+    FBits.SetOn(GetParentPropCount+(AIndex shr IndexShift));
+end;
+
+function TBaseObject.IsDateTimeProp(Info: PTypeInfo): Boolean;
+begin
+  Result:=DateTimePropType(Info)<>dtNone;
+end;
+
+function TBaseObject.DateTimePropType(Info: PTypeInfo): TDateTimeType;
+begin
+  Result:=dtNone;
+  if (Info=TypeInfo(TDateTime)) then
+    Result:=dtDateTime
+  else if (Info=TypeInfo(TDate)) then
+    Result:=dtDate
+  else if (Info=TypeInfo(TTime)) then
+    Result:=dtTime
+end;
+
+procedure TBaseObject.ClearProperty(P: PPropInfo);
+begin
+  Case P^.PropType^.Kind of
+    tkInteger,
+    tkChar,
+    tkEnumeration,
+    tkBool,
+    tkSet : SetOrdProp(Self,P,0);
+    tkFloat : SetFloatProp(Self,P,0.0);
+    tkSString,
+    tkLString,
+    tkUChar,
+    tkAString: SetStrProp(Self,P,'');
+    tkWChar,
+    tkWString: SetWideStrProp(Self,P,'');
+    tkUString:  SetUnicodeStrProp(Self,P,'');
+    tkInt64,
+    tkQWord : SetInt64Prop(Self,P,0);
+    tkClass :
+      begin
+      GetObjectProp(Self,P).Free;
+      SetObjectProp(Self,P,Nil);
+      end
+  else
+    // Do nothing
+  end;
+end;
+
+procedure TBaseObject.SetBooleanProperty(P: PPropInfo; AValue: Boolean);
+begin
+  SetOrdProp(Self,P,Ord(AValue));
+end;
+
+procedure TBaseObject.SetFloatProperty(P: PPropInfo; AValue: Extended);
+
+begin
+  SetFloatProp(Self,P,AValue);
+end;
+
+procedure TBaseObject.SetIntegerProperty(P: PPropInfo; AValue: Integer);
+
+begin
+  SetOrdProp(Self,P,AValue);
+end;
+
+procedure TBaseObject.SetInt64Property(P: PPropInfo; AValue: Int64);
+
+begin
+  SetInt64Prop(Self,P,AValue);
+end;
+
+{$ifndef ver2_6}
+procedure TBaseObject.SetQWordProperty(P: PPropInfo; AValue: QWord);
+
+begin
+  SetInt64Prop(Self,P,Int64(AValue));
+end;
+{$endif}
+
+procedure TBaseObject.SetStringProperty(P: PPropInfo; AValue: String);
+Var
+  D : TDateTime;
+begin
+  if not IsDateTimeProp(P^.PropType) then
+    SetStrProp(Self,P,AValue)
+  else if TryRFC3339ToDateTime(AValue,D) then
+    SetFloatProp(Self,P,D)
+  else
+    SetFloatProp(Self,P,0)
+end;
+
+procedure TBaseObject.SetArrayProperty(P: PPropInfo; AValue: TJSONArray);
+
+Var
+  T : PTypeData;
+  L : TBaseObjectList;
+  D : TJSONEnum;
+  O : TObjectArray;
+  I : Integer;
+  PA : ^pdynarraytypeinfo;
+  ET : PTypeInfo;
+  LPN,AN : String;
+  AP : Pointer;
+  S : TJSONSchema;
+
+begin
+  if P^.PropType^.Kind=tkClass then
+    begin
+    T:=GetTypeData(P^.PropType);
+    if T^.ClassType.InheritsFrom(TBaseObjectList) then
+      begin
+      L:=TBaseObjectList(TBaseObjectClass(T^.ClassType).Create);
+      SetObjectProp(Self,P,L);
+      For D in AValue do
+        L.AddObject('').LoadFromJSON(D.Value as TJSONObject);
+      end
+    else if T^.ClassType.InheritsFrom(TJSONSchema) then
+      begin
+      S:=TJSONSchema.Create;
+      S.SetArrayProperty(P,AValue);
+      SetObjectProp(Self,P,S);
+      end
+    else
+      Raise ERESTAPI.CreateFmt('Unsupported class %s for property %s',[T^.ClassType.ClassName,P^.Name]);
+    end
+  else if P^.PropType^.Kind=tkDynArray then
+    begin
+    // Get array value
+    AP:=GetObjectProp(Self,P);
+    i:=Length(P^.PropType^.name);
+    PA:=@(pdynarraytypeinfo(P^.PropType)^.elesize)+i;
+    PA:=@(pdynarraytypeinfo(P^.PropType)^.eletype)+i;
+    ET:=PTYpeInfo(PA^);
+    if ET^.Kind=tkClass then
+      begin
+      // get object type name
+      AN:=PTYpeInfo(PA^)^.Name;
+      // Free all objects
+      O:=TObjectArray(AP);
+      For I:=0 to Length(O)-1 do
+        FreeAndNil(O[i]);
+      end;
+    // Clear array
+{$ifdef ver2_6}
+    LPN:=Lowercase(P^.Name);
+    SetArrayLength(LPN,0);
+{$else}
+    I:=0;
+    DynArraySetLength(AP,P^.PropType,1,@i);
+{$endif}
+    // Now, set new length
+    I:=AValue.Count;
+    // Writeln(ClassName,' (Array) Setting length of array property ',P^.Name,' (type: ',P^.PropType^.Name,')  to ',AValue.Count);
+{$ifdef ver2_6}
+    // Workaround for bug in 2.6.4 that cannot set the array prop correctly.
+    // Call helper routine and re-get array value
+    SetArrayLength(LPN,i);
+    AP:=GetObjectProp(Self,P);
+{$else}
+    DynArraySetLength(AP,P^.PropType,1,@i);
+    I:=Length(TObjectArray(AP));
+    SetDynArrayProp(P,AP);
+{$endif}
+    // Fill in all elements
+    For I:=0 to AValue.Count-1 do
+      begin
+      Case ET^.Kind of
+        tkClass :
+          begin
+          // Writeln(ClassName,' Adding instance of type: ',AN);
+          TObjectArray(AP)[I]:=CreateObject(AN);
+          TObjectArray(AP)[I].LoadFromJSON(AValue.Objects[i]);
+          end;
+        tkFloat :
+          if IsDateTimeProp(ET) then
+            TDateTimeArray(AP)[I]:=RFC3339ToDateTime(AValue.Strings[i])
+          else
+            TFloatArray(AP)[I]:=AValue.Floats[i];
+        tkInt64 :
+          TInt64Array(AP)[I]:=AValue.Int64s[i];
+        tkBool :
+          begin
+          TBooleanArray(AP)[I]:=AValue.Booleans[i];
+          end;
+        tkInteger :
+         TIntegerArray(AP)[I]:=AValue.Integers[i];
+        tkUstring,
+        tkWstring :
+          TUnicodeStringArray(AP)[I]:=UTF8Decode(AValue.Strings[i]);
+        tkString,
+        tkAstring,
+        tkLString :
+          begin
+          // Writeln('Setting String ',i,': ',AValue.Strings[i]);
+          TStringArray(AP)[I]:=AValue.Strings[i];
+          end;
+      else
+        Raise ERESTAPI.CreateFmt('%s: unsupported array element type : ',[ClassName,GetEnumName(TypeInfo(TTypeKind),Ord(ET^.Kind))]);
+      end;
+      end;
+    end;
+end;
+
+procedure TBaseObject.SetObjectProperty(P: PPropInfo; AValue: TJSONObject);
+Var
+  O : TBaseObject;
+  A: Pointer;
+  T : PTypeData;
+  D : TJSONEnum;
+  AN : String;
+  I : Integer;
+  L : TBaseObjectList;
+  NL : TBaseNamedObjectList;
+  PA : ^pdynarraytypeinfo;
+
+begin
+  if P^.PropType^.Kind=tkDynArray then
+    begin
+    A:=GetDynArrayProp(P);
+    For I:=0 to Length(TObjectArray(A))-1 do
+      FreeAndNil(TObjectArray(A)[i]);
+    // Writeln(ClassName,' (Object) Setting length of array property ',P^.Name,'(type: ',P^.PropType^.Name,')  to ',AValue.Count,' (current: ',Length(TObjectArray(A)),')');
+    SetLength(TObjectArray(A),AValue.Count);
+    i:=Length(P^.PropType^.name);
+    PA:=@(pdynarraytypeinfo(P^.PropType)^.elesize)+i;
+    PA:=@(pdynarraytypeinfo(P^.PropType)^.eletype)+i;
+    AN:=PTYpeInfo(PA^)^.Name;
+    I:=0;
+    For D in AValue do
+      begin
+      O:=CreateObject(AN);
+      TObjectArray(A)[I]:=O;
+      // Writeln(ClassName,' Adding instance of type: ',AN,' for key ',D.Key);
+      if IsPublishedProp(O,'name') then
+        SetStrProp(O,'name',D.Key);
+      O.LoadFromJSON(D.Value as TJSONObject);
+      Inc(I);
+      end;
+    // Writeln(ClassName,' Done with array ',P^.Name,', final array length: ', Length(TObjectArray(A)));
+    SetDynArrayProp(P,A);
+    {
+      For I:=0 to Length(TObjectArray(A))-1 do
+        if IsPublishedProp(TObjectArray(A)[i],'name') then
+    SetDynArrayProp(P,AP);
+      //   Writeln(ClassName,'.',P^.name,'[',i,'] : ',getStrProp(TObjectArray(A)[I],'name'));
+      B:=GetDynArrayProp(P);
+      If Pointer(B)<>Pointer(A) then
+      //  Writeln(ClassName,': Array ',P^.Name,'was not set correctly');
+    }
+    Exit;
+    end;
+  if Not (P^.PropType^.Kind=tkClass) then
+    Raise ERESTAPI.CreateFmt('%s: Unsupported type for property %s',[ClassName,P^.Name]);
+  T:=GetTypeData(P^.PropType);
+  if T^.ClassType.InheritsFrom(TBaseObject) then
+    begin
+    O:=TBaseObject(GetObjectProp(Self,P,TBaseObject));
+    if O=Nil then
+      begin
+      O:=TBaseObjectClass(T^.ClassType).Create;
+      SetObjectProp(Self,P,O);
+      end;
+    O.LoadFromJSON(AValue);
+    end
+  else if T^.ClassType.InheritsFrom(TBaseObjectList) then
+    begin
+    L:=TBaseObjectList(TBaseObjectClass(T^.ClassType).Create);
+    SetObjectProp(Self,P,L);
+    For D in AValue do
+      L.AddObject('').LoadFromJSON(D.Value as TJSONObject);
+    end
+  else if T^.ClassType.InheritsFrom(TBaseNamedObjectList) then
+    begin
+    NL:=TBaseNamedObjectList(TBaseObjectClass(T^.ClassType).Create);
+    SetObjectProp(Self,P,L);
+    For D in AValue do
+      NL.AddObject(D.Key,'').LoadFromJSON(D.Value as TJSONObject);
+    end
+  else
+    Raise ERESTAPI.CreateFmt('%s: unsupported class %s for property %s',[ClassName, T^.ClassType.ClassName,P^.Name]);
+end;
+
+procedure TBaseObject.SetSetProperty(P: PPropInfo; AValue: TJSONArray);
+
+type
+  TSet = set of 0..31;
+
+var
+  S,I,V : Integer;
+  CurValue: string;
+  EnumTyp: PTypeInfo;
+  EnumTypData: PTypeData;
+
+begin
+  S:=0;
+  EnumTyp:=GetTypeData(P^.PropType)^.CompType;
+  EnumTypData:=GetTypeData(EnumTyp);
+  For I:=0 to AValue.Count-1 do
+    begin
+    CurValue:=AValue.Strings[i];
+    if Not TryStrToInt(CurValue,V) then
+      V:=GetEnumValue(EnumTyp,CurValue);
+    if (V<EnumTypData^.MinValue) or (V>EnumTypData^.MaxValue) or (V>31) then
+      Raise ERESTAPI.CreateFmt('%s: Invalid value %s for property %s',[ClassName, CurValue,P^.Name]);
+    Include(TSet(S),V);
+    end;
+  SetOrdProp(Self,P,S);
+end;
+
+procedure TBaseObject.SetEnumProperty(P: PPropInfo; AValue: TJSONData);
+Var
+  I : Integer;
+
+begin
+  I:=GetEnumValue(P^.PropType,AValue.AsString);
+  if (I=-1) then
+    Raise ERESTAPI.CreateFmt('%s: Invalid value %s for property %s',[ClassName, AValue.AsString,P^.Name]);
+  SetOrdProp(Self,P,I);
+end;
+
+function TBaseObject.GetBooleanProperty(P: PPropInfo): TJSONData;
+begin
+  Result:=TJSONBoolean.Create(GetOrdProp(Self,P)<>0);
+end;
+
+function TBaseObject.GetIntegerProperty(P: PPropInfo): TJSONData;
+begin
+  Result:=TJSONIntegerNumber.Create(GetOrdProp(Self,P));
+end;
+
+function TBaseObject.GetInt64Property(P: PPropInfo): TJSONData;
+begin
+  Result:=TJSONInt64Number.Create(GetInt64Prop(Self,P));
+end;
+
+function TBaseObject.GetQwordProperty(P: PPropInfo): TJSONData;
+begin
+  Result:=TJSONInt64Number.Create(Int64(GetInt64Prop(Self,P)));
+end;
+
+function TBaseObject.GetFloatProperty(P: PPropInfo): TJSONData;
+begin
+  Case DateTimePropType(P^.PropType) of
+    dtDateTime:
+      Result:=TJSONString.Create(DateTimeToRFC3339(GetFloatProp(Self,P)));
+    dtDate:
+      Result:=TJSONString.Create(DateToRFC3339(GetFloatProp(Self,P)));
+    dtTime:
+      Result:=TJSONString.Create(TimeToRFC3339(GetFloatProp(Self,P))) ;
+  else
+    Result:=TJSONFloatNumber.Create(GetFloatProp(Self,P));
+  end;
+end;
+
+function TBaseObject.GetStringProperty(P: PPropInfo): TJSONData;
+begin
+  Result:=TJSONString.Create(GetStrProp(Self,P));
+end;
+
+function TBaseObject.GetSetProperty(P: PPropInfo): TJSONData;
+
+type
+  TSet = set of 0..31;
+var
+  Typ: PTypeInfo;
+  S, i: integer;
+begin
+  Result:=TJSONArray.Create;
+  Typ:=GetTypeData(P^.PropType)^.CompType;
+  S:=GetOrdProp(Self,P);
+  for i:=Low(TSet) to High(TSet) do
+    if (i in TSet(S)) then
+      TJSONArray(Result).Add(TJSONString.Create(GetEnumName(Typ,i)));
+end;
+
+
+function TBaseObject.GetEnumeratedProperty(P: PPropInfo): TJSONData;
+begin
+  Result:=TJSONString.Create(GetEnumProp(Self,P));
+end;
+
+function TBaseObject.GetArrayProperty(P: PPropInfo): TJSONData;
+
+Var
+  AO : TObject;
+  I : Integer;
+  PA : ^pdynarraytypeinfo;
+  ET : PTypeInfo;
+  AP : Pointer;
+  A : TJSONArray;
+  O : TJSONObject;
+
+begin
+  A:=TJSONArray.Create;
+  Result:=A;
+  // Get array value type
+  AP:=GetObjectProp(Self,P);
+  i:=Length(P^.PropType^.name);
+  PA:=@(pdynarraytypeinfo(P^.PropType)^.eletype)+i;
+  ET:=PTYpeInfo(PA^);
+  // Fill in all elements
+  Case ET^.Kind of
+  tkClass:
+    For I:=0 to Length(TObjectArray(AP))-1 do
+      begin
+      // Writeln(ClassName,' Adding instance of type: ',AN);
+      AO:=TObjectArray(AP)[I];
+      if AO.InheritsFrom(TBaseObject) then
+        begin
+        O:=TJSONObject.Create;
+        A.Add(O);
+        TBaseObject(AO).SaveToJSON(O);
+        end;
+      end;
+  tkFloat:
+    if IsDateTimeProp(ET) then
+      For I:=0 to Length(TDateTimeArray(AP))-1 do
+        A.Add(TJSONString.Create(DateTimeToRFC3339(TDateTimeArray(AP)[I])))
+    else
+      For I:=0 to Length(TFloatArray(AP))-1 do
+        A.Add(TJSONFloatNumber.Create(TFloatArray(AP)[I]));
+  tkInt64:
+    For I:=0 to Length(TInt64Array(AP))-1 do
+      A.Add(TJSONInt64Number.Create(TInt64Array(AP)[I]));
+  tkBool:
+    For I:=0 to Length(TInt64Array(AP))-1 do
+      A.Add(TJSONBoolean.Create(TBooleanArray(AP)[I]));
+  tkInteger :
+    For I:=0 to Length(TIntegerArray(AP))-1 do
+     A.Add(TJSONIntegerNumber.Create(TIntegerArray(AP)[I]));
+  tkUstring,
+  tkWstring :
+    For I:=0 to Length(TUnicodeStringArray(AP))-1 do
+      A.Add(TJSONString.Create(TUnicodeStringArray(AP)[I]));
+  tkString,
+  tkAstring,
+  tkLString :
+    For I:=0 to Length(TStringArray(AP))-1 do
+      A.Add(TJSONString.Create(TStringArray(AP)[I]));
+  else
+    Raise ERESTAPI.CreateFmt('%s: unsupported array element type : ',[ClassName,GetEnumName(TypeInfo(TTypeKind),Ord(ET^.Kind))]);
+  end;
+end;
+
+function TBaseObject.GetObjectProperty(P: PPropInfo): TJSONData;
+
+Var
+  O : TObject;
+
+begin
+  O:=GetObjectProp(Self,P);
+  if (O is TBaseObject) then
+    Result:=TBaseObject(O).SaveToJSON
+  else
+    Result:=Nil; // maybe we need to add an option to return null ?
+end;
+
+procedure TBaseObject.ClearChildren(ChildTypes: TChildTypes);
+
+Type
+  TObjectArr = Array of TObject;
+
+var
+  PL: PPropList;
+  P : PPropInfo;
+  i,j,count,len:integer;
+  A : pointer;
+  PA : ^pdynarraytypeinfo;
+  O : TObject;
+
+begin
+  Count:=GetPropList(Self,PL);
+  try
+    for i:=0 to Count-1 do
+      begin
+      P:=PL^[I];
+      case P^.PropType^.Kind of
+        tkClass:
+          if (ctObject in ChildTypes) then
+            begin
+            // Writeln(ClassName,' Examining object: ',P^.Name);
+            O:=GetObjectProp(Self,P);
+            O.Free;
+            SetObjectProp(Self,P,Nil);
+            end;
+        tkDynArray:
+          if (ctArray in ChildTypes) then
+            begin
+            len:=Length(P^.PropType^.Name);
+            PA:=@(pdynarraytypeinfo(P^.PropType)^.eletype)+len;
+            if PTYpeInfo(PA^)^.Kind=tkClass then
+              begin
+              A:=GetDynArrayProp(P);
+//              Writeln(ClassName,' Examining array: ',P^.Name,'Count:',Length(TObjectArr(A)));
+              For J:=0 to Length(TObjectArr(A))-1 do
+                begin
+                FreeAndNil(TObjectArr(A)[J]);
+                end;
+              end;
+            // Length is set to nil by destructor
+            end;
+      end;
+      end;
+  finally
+    FreeMem(PL);
+  end;
+end;
+
+class function TBaseObject.ClearChildTypes: TChildTypes;
+begin
+  Result:=[ctArray,ctObject]
+end;
+
+
+{$IFDEF DEBUGBASEOBJMEMLEAK}
+Var
+  ObjCounter : TStrings;
+{$ENDIF}
+constructor TBaseObject.Create(AOptions: TObjectOptions);
+begin
+{$IFDEF DEBUGBASEOBJMEMLEAK}
+  if ObjCounter=Nil then
+    ObjCounter:=TStringList.Create;
+  ObjCounter.Values[ClassName]:=IntToStr(StrToIntDef(ObjCounter.Values[ClassName],0)+1);
+{$ENDIF}
+  ObjectOptions:=AOptions;
+  // Do nothing
+end;
+
+destructor TBaseObject.Destroy;
+
+begin
+  StopRecordPropertyChanges;
+{$IFDEF DEBUGBASEOBJMEMLEAK}
+  ObjCounter.Values[ClassName]:=IntToStr(StrToIntDef(ObjCounter.Values[ClassName],0)-1);
+{$ENDIF}
+  FreeAndNil(fadditionalProperties);
+  if ClearChildTypes<>[] then
+    ClearChildren(ClearChildTypes);
+  inherited;
+end;
+
+procedure TBaseObject.StartRecordPropertyChanges;
+begin
+  if Assigned(FBits) then
+    FBits.ClearAll
+  else
+    FBits:=TBits.Create(GetTotalPropCount);
+end;
+
+procedure TBaseObject.ClearPropertyChanges;
+begin
+  FBits.ClearAll;
+end;
+
+procedure TBaseObject.StopRecordPropertyChanges;
+begin
+  FreeAndNil(FBits);
+end;
+
+function TBaseObject.IsPropertyModified(Info: PPropInfo): Boolean;
+begin
+  Result:=Not Assigned(FBits) or FBits.Bits[Info^.NameIndex]
+end;
+
+function TBaseObject.IsPropertyModified(const AName: String): Boolean;
+begin
+  Result:=IsPropertyModified(GetPropInfo(Self,AName));
+end;
+
+function TBaseObject.GetAdditionalProperties: TJSONObject;
+begin
+  if (fAdditionalProperties=Nil) and AllowAdditionalProperties then
+    fAdditionalProperties:=TJSONObject.Create;
+  Result:=fAdditionalProperties
+end;
+
+{$IFDEF VER2_6}
+procedure TBaseObject.SetArrayLength(Const AName: String; ALength: Longint);
+begin
+  Raise ERestAPI.CreateFmt('Unknown Array %s',[AName]);
+end;
+{$ENDIF}
+
+class function TBaseObject.AllowAdditionalProperties: Boolean;
+begin
+  Result:=False;
+end;
+
+class function TBaseObject.ExportPropertyName(const AName: String): string;
+begin
+  Result:=AName;
+end;
+
+class function TBaseObject.CleanPropertyName(const AName: String): string;
+
+Const
+   KW=';absolute;and;array;asm;begin;case;const;constructor;destructor;div;do;'+
+       'downto;else;end;file;for;function;goto;if;implementation;in;inherited;'+
+       'inline;interface;label;mod;nil;not;object;of;on;operator;or;packed;'+
+       'procedure;program;record;reintroduce;repeat;self;set;shl;shr;string;then;'+
+       'to;type;unit;until;uses;var;while;with;xor;dispose;exit;false;new;true;'+
+       'as;class;dispinterface;except;exports;finalization;finally;initialization;'+
+       'inline;is;library;on;out;packed;property;raise;resourcestring;threadvar;try;'+
+       'private;published;length;setlength;';
+Var
+  I : Integer;
+
+begin
+  Result:=Aname;
+  For I:=Length(Result) downto 1 do
+    If Not ((Upcase(Result[i]) in ['_','A'..'Z'])
+             or ((I>1) and (Result[i] in (['0'..'9'])))) then
+     Delete(Result,i,1);
+  if Pos(';'+lowercase(Result)+';',KW)<>0 then
+   Result:='_'+Result
+end;
+
+class function TBaseObject.CreateObject(const AKind: String): TBaseObject;
+
+Var
+  C : TBaseObjectClass;
+
+begin
+  C:=RESTFactory.GetObjectClass(AKind);
+  if C<>Nil then
+    Result:=C.Create
+  else
+    Raise ERESTAPI.CreateFmt('Unknown class : "%s"',[AKind]);
+  // Do nothing
+end;
+
+class procedure TBaseObject.RegisterObject;
+begin
+  RESTFactory.RegisterObject(Self);
+end;
+
+class function TBaseObject.ObjectRestKind: String;
+begin
+  Result:=ClassName;
+end;
+
+class function TBaseObject.GetTotalPropCount: Integer;
+begin
+  Result:=GetTypeData(ClassInfo)^.PropCount;
+end;
+
+class function TBaseObject.GetCurrentPropCount: Integer;
+begin
+  Result:=CountProperties(ClassInfo,False);
+end;
+
+class function TBaseObject.GetParentPropCount: Integer;
+
+begin
+  if (ClassParent=TBaseObject) or (ClassParent=Nil) then
+    Result:=0
+  else
+    Result:=TBaseObjectClass(ClassParent).GetTotalPropCount;
+end;
+
+procedure TBaseObject.LoadPropertyFromJSON(const AName: String; JSON: TJSONData
+  );
+
+Var
+  P : PPropInfo;
+  o : TJSONObject;
+
+begin
+  // Writeln(ClassName,' loading : ',ANAme,' -> ',CleanPropertyName(aName));
+  P:=GetPropInfo(Self,CleanPropertyName(aName));
+  if (P=Nil) then
+    begin
+    o:=additionalProperties;
+    if o=Nil then
+      Raise ERESTAPI.CreateFmt('%s : Unknown property "%s"',[ClassName,AName]);
+    o.Add(aName,JSON.Clone);
+    end
+  else
+    case JSON.JSONType of
+      jtstring  :
+        if (P^.PropType^.Kind=tkEnumeration) then
+          SetEnumProperty(P,JSON)
+        else
+          SetStringproperty(P,JSON.AsString);
+      jtNumber  :
+        case TJSONNumber(JSON).NumberType of
+          ntFloat   : SetFloatProperty(P,JSON.asFloat);
+          ntInteger : SetIntegerProperty(P,JSON.asInteger);
+          ntInt64   : SetInt64Property(P,JSON.asInt64);
+{$ifndef ver2_6}
+          ntqword   : SetQWordProperty(P,JSON.asQWord);
+{$endif}
+        end;
+      jtNull    : ClearProperty(P);
+      jtBoolean : SetBooleanProperty(P,json.AsBoolean);
+      jtArray   :
+        if P^.PropType^.Kind=tkSet then
+          SetSetProperty(P,TJSONArray(json))
+        else
+          SetArrayProperty(P,TJSONArray(json));
+      jtObject   : SetObjectProperty(P,TJSONObject(json));
+    end;
+end;
+
+function TBaseObject.SavePropertyToJSON(Info: PPropInfo): TJSONData;
+
+begin
+  Result:=Nil;
+  if Not IsPropertyModified(Info) then
+    Exit;
+  Case Info^.PropType^.Kind of
+   tkSet         : Result:=GetSetProperty(Info);
+   tkEnumeration : Result:=GetEnumeratedProperty(Info);
+   tkAstring,
+   tkUstring,
+   tkWString,
+   tkwchar,
+   tkuchar,
+   tkString   : Result:=GetStringProperty(Info);
+   tkFloat    : Result:=GetFloatProperty(Info);
+   tkBool     : Result:=GetBooleanProperty(Info);
+   tkClass    : Result:=GetObjectProperty(Info);
+   tkDynArray : Result:=GetArrayProperty(Info);
+   tkQWord    : Result:=GetQWordProperty(Info);
+   tkInt64    : Result:=GetInt64Property(Info);
+   tkInteger  : Result:=GetIntegerProperty(Info);
+  end;
+end;
+
+procedure TBaseObject.LoadFromJSON(JSON: TJSONObject);
+
+Var
+  D : TJSONEnum;
+
+begin
+  StopRecordPropertyChanges;
+  For D in JSON Do
+    LoadPropertyFromJSON(D.Key,D.Value);
+  StartRecordPropertyChanges;
+end;
+
+procedure TBaseObject.SaveToJSON(JSON: TJSONObject);
+
+var
+  PL: PPropList;
+  P : PPropInfo;
+  I,Count : integer;
+  D : TJSONData;
+
+begin
+  Count:=GetPropList(Self,PL);
+  try
+    for i:=0 to Count-1 do
+      begin
+      P:=PL^[I];
+      D:=SavePropertyToJSON(P);
+      if (D<>Nil) then
+        JSON.add(ExportPropertyName(P^.Name),D);
+      end;
+  finally
+    FreeMem(PL);
+  end;
+end;
+
+function TBaseObject.SaveToJSON: TJSONObject;
+begin
+  Result:=TJSONObject.Create;
+  try
+    SaveToJSON(Result);
+  except
+    FreeAndNil(Result);
+    Raise;
+  end;
+end;
+
+finalization
+{$IFDEF DEBUGBASEOBJMEMLEAK}
+  if Assigned(ObjCounter) then
+    begin
+    Writeln(StdErr,'Object allocate-free count: ');
+    Writeln(StdErr,ObjCounter.Text);
+    FreeAndNil(ObjCounter);
+    end;
+{$ENDIF}
+  FreeAndNil(Fact);
+end.
+

packages/fcl-web/src/base/restcodegen.pp

@@ -0,0 +1,309 @@
+{ **********************************************************************
+  This file is part of the Free Component Library (FCL)
+  Copyright (c) 2015 by the Free Pascal development team
+        
+  REST classes code generator base.
+            
+  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 restcodegen;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils;
+
+Type
+  TCodegenLogType = (cltInfo);
+  TCodegenLogTypes = Set of TCodegenLogType;
+  TCodeGeneratorLogEvent = Procedure (Sender : TObject; LogType : TCodegenLogType; Const Msg : String) of object;
+  { TRestCodeGenerator }
+
+  TRestCodeGenerator = Class(TComponent)
+  Private
+    FAddTimeStamp: Boolean;
+    FBaseClassName: String;
+    FBaseListClassName: String;
+    FClassPrefix: String;
+    FExtraUnits: String;
+    FLicenseText: TStrings;
+    FOnLog: TCodeGeneratorLogEvent;
+    FOutputUnitName: String;
+    FSource : TStrings;
+    Findent : String;
+  Protected
+    // Source manipulation
+    Procedure DoLog(Const Msg : String; AType : TCodegenLogType = cltInfo);
+    Procedure DoLog(Const Fmt : String; Args : Array of const; AType : TCodegenLogType = cltInfo);
+    Procedure CreateHeader; virtual;
+    Procedure IncIndent;
+    Procedure DecIndent;
+    Function MakePascalString(S: String; AddQuotes: Boolean=False): String;
+    Function PrettyPrint(Const S: string): String;
+    Procedure AddLn(Const Aline: string);
+    Procedure AddLn(Const Alines : array of string);
+    Procedure AddLn(Const Alines : TStrings);
+    Procedure AddLn(Const Fmt: string; Args : Array of const);
+    Procedure Comment(Const AComment : String; Curly : Boolean = False);
+    Procedure Comment(Const AComment : Array of String);
+    Procedure Comment(Const AComment : TStrings);
+    Procedure ClassHeader(Const AClassName: String); virtual;
+    Procedure SimpleMethodBody(Lines: Array of string); virtual;
+    Function BaseUnits : String; virtual;
+  Public
+    Constructor Create(AOwner : TComponent); override;
+    Destructor Destroy; override;
+    procedure SaveToStream(const AStream: TStream);
+    Procedure SaveToFile(Const AFileName : string);
+    Procedure LoadFromFile(Const AFileName : string);
+    Procedure LoadFromStream(Const AStream : TStream); virtual; abstract;
+    Procedure Execute; virtual; abstract;
+    Property Source : TStrings Read FSource;
+  Published
+    Property BaseClassName : String Read FBaseClassName Write FBaseClassName;
+    Property BaseListClassName : String Read FBaseListClassName Write FBaseListClassName;
+    Property OutputUnitName : String Read FOutputUnitName Write FOutputUnitName;
+    Property ExtraUnits : String Read FExtraUnits Write FExtraUnits;
+    Property ClassPrefix : String Read FClassPrefix Write FClassPrefix;
+    Property LicenseText : TStrings Read FLicenseText;
+    Property OnLog : TCodeGeneratorLogEvent Read FOnLog Write FOnlog;
+    Property AddTimeStamp : Boolean Read FAddTimeStamp Write FAddTimeStamp;
+  end;
+
+implementation
+
+{ TRestCodeGenerator }
+procedure TRestCodeGenerator.IncIndent;
+begin
+  FIndent:=FIndent+StringOfChar(' ',2);
+end;
+
+procedure TRestCodeGenerator.DecIndent;
+
+Var
+  L : Integer;
+begin
+  L:=Length(Findent);
+  if L>0  then
+    FIndent:=Copy(FIndent,1,L-2)
+end;
+
+procedure TRestCodeGenerator.AddLn(const Aline: string);
+
+begin
+  FSource.Add(FIndent+ALine);
+end;
+
+procedure TRestCodeGenerator.AddLn(const Alines: array of string);
+
+Var
+  S : String;
+
+begin
+  For s in alines do
+    Addln(S);
+end;
+
+procedure TRestCodeGenerator.AddLn(const Alines: TStrings);
+Var
+  S : String;
+
+begin
+  For s in alines do
+    Addln(S);
+end;
+
+procedure TRestCodeGenerator.AddLn(const Fmt: string; Args: array of const);
+begin
+  AddLn(Format(Fmt,Args));
+end;
+
+procedure TRestCodeGenerator.Comment(const AComment: String; Curly: Boolean);
+begin
+  if Curly then
+    AddLn('{ '+AComment+' }')
+  else
+    AddLn('//'+AComment);
+end;
+
+procedure TRestCodeGenerator.Comment(const AComment: array of String);
+begin
+  AddLn('{');
+  IncIndent;
+  AddLn(AComment);
+  DecIndent;
+  AddLn('}');
+end;
+
+procedure TRestCodeGenerator.Comment(const AComment: TStrings);
+begin
+  AddLn('{');
+  IncIndent;
+  AddLn(AComment);
+  DecIndent;
+  AddLn('}');
+end;
+
+
+
+constructor TRestCodeGenerator.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  FSource:=TstringList.Create;
+  FLicenseText:=TstringList.Create;
+end;
+
+destructor TRestCodeGenerator.Destroy;
+begin
+  FreeAndNil(FLicenseText);
+  FreeAndNil(FSource);
+  inherited Destroy;
+end;
+
+
+procedure TRestCodeGenerator.LoadFromFile(const AFileName: string);
+
+Var
+  F : TFileStream;
+
+begin
+  F:=TFileStream.Create(AFileName,fmOpenRead or fmShareDenyWrite);
+  try
+    LoadFromStream(F);
+  finally
+    F.Free;
+  end;
+end;
+
+procedure TRestCodeGenerator.SaveToStream(const AStream : TStream);
+
+begin
+  if (FSource.Count=0) then
+    Execute;
+  FSource.SaveToStream(AStream)
+end;
+
+procedure TRestCodeGenerator.SaveToFile(const AFileName: string);
+
+Var
+  F : TFileStream;
+  B : Boolean;
+
+begin
+  B:=False;
+  F:=Nil;
+  try
+    B:=(Source.Count=0) and (OutputUnitName='');
+    if B then
+      OutputUnitname:=ChangeFileExt(ExtractFileName(AFileName),'');
+    F:=TFileStream.Create(aFilename,fmCreate);
+    SaveToStream(F);
+  finally
+    F.Free;
+    if B then
+      OutputUnitName:='';
+  end;
+end;
+
+procedure TRestCodeGenerator.DoLog(const Msg: String; AType: TCodegenLogType);
+begin
+  If Assigned(FOnLog) then
+    FOnLog(Self,Atype,Msg);
+end;
+
+procedure TRestCodeGenerator.DoLog(const Fmt: String; Args: array of const;
+  AType: TCodegenLogType);
+begin
+  DoLog(Format(Fmt,Args),AType);
+end;
+
+procedure TRestCodeGenerator.CreateHeader;
+
+Var
+  B,S : String;
+
+begin
+  if LicenseText.Count>0 then
+    Comment(LicenseText);
+  if AddTimeStamp then
+    Comment('Generated on: '+DateTimeToStr(Now));
+  addln('{$MODE objfpc}');
+  addln('{$H+}');
+  addln('');
+  addln('interface');
+  addln('');
+  S:=ExtraUnits;
+  B:=BaseUnits;
+  if (B<>'') then
+    if (S<>'') then
+      begin
+      if (B[Length(B)]<>',') then
+        B:=B+',';
+      S:=B+S;
+      end
+    else
+      S:=B;
+  addln('uses sysutils, classes, %s;',[S]);
+  addln('');
+end;
+
+procedure TRestCodeGenerator.SimpleMethodBody(Lines: array of string);
+
+Var
+   S : String;
+
+begin
+  AddLn('');
+  AddLn('begin');
+  IncIndent;
+  For S in Lines do
+    AddLn(S);
+  DecIndent;
+  AddLn('end;');
+  AddLn('');
+end;
+
+function TRestCodeGenerator.BaseUnits: String;
+begin
+  Result:='';
+end;
+
+
+function TRestCodeGenerator.MakePascalString(S: String; AddQuotes: Boolean
+  ): String;
+
+begin
+  Result:=StringReplace(S,'''','''''',[rfReplaceAll]);
+  if AddQuotes then
+    Result:=''''+Result+'''';
+end;
+
+function TRestCodeGenerator.PrettyPrint(const S: string): String;
+
+begin
+  If (S='') then
+    Result:=''
+  else
+    Result:=Upcase(S[1])+Copy(S,2,Length(S)-1);
+end;
+
+procedure TRestCodeGenerator.ClassHeader(const AClassName: String);
+
+begin
+  AddLn('');
+  AddLn('{ '+StringOfChar('-',68));
+  AddLn('  '+AClassName);
+  AddLn('  '+StringOfChar('-',68)+'}');
+  AddLn('');
+end;
+
+end.
+

packages/fpmkunit/src/fpmkunit.pp

@@ -1205,7 +1205,7 @@ Type
     Procedure UnInstall(Packages : TPackages);
     Procedure ZipInstall(Packages : TPackages);
     Procedure Archive(Packages : TPackages);
-    procedure Manifest(Packages: TPackages);
+    procedure Manifest(Packages: TPackages; Package: TPackage);
     procedure PkgList(Packages: TPackages);
     Procedure Clean(Packages : TPackages; AllTargets: boolean);
 
@@ -4866,8 +4866,6 @@ end;
 
 procedure TCustomInstaller.Archive;
 begin
-  // Force generation of manifest.xml, this is required for the repository
-  BuildEngine.Manifest(Packages);
   NotifyEventCollection.CallEvents(neaBeforeArchive, self);
   BuildEngine.Archive(Packages);
   NotifyEventCollection.CallEvents(neaAfterArchive, self);
@@ -4877,7 +4875,7 @@ end;
 procedure TCustomInstaller.Manifest;
 begin
   NotifyEventCollection.CallEvents(neaBeforeManifest, self);
-  BuildEngine.Manifest(Packages);
+  BuildEngine.Manifest(Packages, nil);
   NotifyEventCollection.CallEvents(neaAfterManifest, self);
 end;
 
@@ -7558,17 +7556,20 @@ begin
   For I:=0 to Packages.Count-1 do
     begin
       P:=Packages.PackageItems[i];
+      // Force generation of manifest.xml, this is required for the repository
+      Manifest(nil, P);
       Archive(P);
     end;
   NotifyEventCollection.CallEvents(neaAfterArchive, Self);
 end;
 
 
-procedure TBuildEngine.Manifest(Packages: TPackages);
+procedure TBuildEngine.Manifest(Packages: TPackages; Package: TPackage);
 Var
   L : TStrings;
   I : Integer;
   P : TPackage;
+  FN: string;
 begin
   NotifyEventCollection.CallEvents(neaBeforeManifest, Self);
   Log(vlDebug, SDbgBuildEngineGenerateManifests);
@@ -7578,14 +7579,25 @@ begin
     Log(vlDebug, Format(SDbgGenerating, [ManifestFile]));
     L.Add('<?xml version="1.0"?>');
     L.Add('<packages>');
-    For I:=0 to Packages.Count-1 do
+    if assigned(Packages) then
       begin
-        P:=Packages.PackageItems[i];
-        Log(vlInfo, Format(SInfoManifestPackage,[P.Name]));
-        P.GetManifest(L);
+        For I:=0 to Packages.Count-1 do
+          begin
+            P:=Packages.PackageItems[i];
+            Log(vlInfo, Format(SInfoManifestPackage,[P.Name]));
+            P.GetManifest(L);
+          end
+      end;
+    if assigned(Package) then
+      begin
+        Log(vlInfo, Format(SInfoManifestPackage,[Package.Name]));
+        Package.GetManifest(L);
       end;
     L.Add('</packages>');
-    L.SaveToFile(ManifestFile);
+    FN := ManifestFile;
+    if assigned(Package) then
+      FN := FixPath(Package.Directory, True)+FN;
+    L.SaveToFile(FN);
   Finally
     L.Free;
   end;