diff options
Diffstat (limited to 'tests')
104 files changed, 3699 insertions, 555 deletions
diff --git a/tests/Makefile b/tests/Makefile index 60512a45ae..605326a3f9 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -1,9 +1,9 @@ # -# Don't edit, this file is generated by FPCMake Version 2.0.0 [2014-03-19 rev 27188] +# Don't edit, this file is generated by FPCMake Version 2.0.0 [2014-12-07 rev 29213] # default: allexectests -MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-haiku i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian i386-nativent i386-iphonesim i386-android m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos powerpc-embedded powerpc-wii powerpc-aix sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-netbsd x86_64-solaris x86_64-openbsd x86_64-darwin x86_64-win64 x86_64-embedded arm-linux arm-palmos arm-darwin arm-wince arm-gba arm-nds arm-embedded arm-symbian arm-android powerpc64-linux powerpc64-darwin powerpc64-embedded powerpc64-aix avr-embedded armeb-linux armeb-embedded mips-linux mipsel-linux mipsel-embedded mipsel-android jvm-java jvm-android i8086-msdos -BSDs = freebsd netbsd openbsd darwin +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-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 +BSDs = freebsd netbsd openbsd darwin dragonfly UNIXs = linux $(BSDs) solaris qnx haiku aix LIMIT83fs = go32v2 os2 emx watcom msdos OSNeedsComspecToRunBatch = go32v2 watcom @@ -394,6 +394,9 @@ endif ifeq ($(FULL_TARGET),i386-android) override TARGET_PROGRAMS+=gparmake endif +ifeq ($(FULL_TARGET),i386-aros) +override TARGET_PROGRAMS+=gparmake +endif ifeq ($(FULL_TARGET),m68k-linux) override TARGET_PROGRAMS+=gparmake endif @@ -481,6 +484,9 @@ endif ifeq ($(FULL_TARGET),x86_64-embedded) override TARGET_PROGRAMS+=gparmake endif +ifeq ($(FULL_TARGET),x86_64-dragonfly) +override TARGET_PROGRAMS+=gparmake +endif ifeq ($(FULL_TARGET),arm-linux) override TARGET_PROGRAMS+=gparmake endif @@ -793,6 +799,12 @@ EXEEXT= HASSHAREDLIB=1 SHORTSUFFIX=lnx endif +ifeq ($(OS_TARGET),dragonfly) +BATCHEXT=.sh +EXEEXT= +HASSHAREDLIB=1 +SHORTSUFFIX=df +endif ifeq ($(OS_TARGET),freebsd) BATCHEXT=.sh EXEEXT= @@ -838,6 +850,11 @@ EXEEXT= SHAREDLIBEXT=.library SHORTSUFFIX=amg endif +ifeq ($(OS_TARGET),aros) +EXEEXT= +SHAREDLIBEXT=.library +SHORTSUFFIX=aros +endif ifeq ($(OS_TARGET),morphos) EXEEXT= SHAREDLIBEXT=.library @@ -1259,6 +1276,9 @@ endif ifeq ($(FULL_TARGET),i386-android) REQUIRE_PACKAGES_RTL=1 endif +ifeq ($(FULL_TARGET),i386-aros) +REQUIRE_PACKAGES_RTL=1 +endif ifeq ($(FULL_TARGET),m68k-linux) REQUIRE_PACKAGES_RTL=1 endif @@ -1346,6 +1366,9 @@ endif ifeq ($(FULL_TARGET),x86_64-embedded) REQUIRE_PACKAGES_RTL=1 endif +ifeq ($(FULL_TARGET),x86_64-dragonfly) +REQUIRE_PACKAGES_RTL=1 +endif ifeq ($(FULL_TARGET),arm-linux) REQUIRE_PACKAGES_RTL=1 endif @@ -1566,7 +1589,7 @@ endif ifdef CREATESHARED override FPCOPT+=-Cg endif -ifneq ($(findstring $(OS_TARGET),freebsd openbsd netbsd linux solaris),) +ifneq ($(findstring $(OS_TARGET),dragonfly freebsd openbsd netbsd linux solaris),) ifeq ($(CPU_TARGET),x86_64) override FPCOPT+=-Cg endif @@ -1596,17 +1619,23 @@ ifdef ACROSSCOMPILE override FPCOPT+=$(CROSSOPT) endif override COMPILER:=$(strip $(FPC) $(FPCOPT)) -ifeq (,$(findstring -s ,$(COMPILER))) +ifneq (,$(findstring -sh ,$(COMPILER))) +UseEXECPPAS=1 +endif +ifneq (,$(findstring -s ,$(COMPILER))) +ifeq ($(FULL_SOURCE),$(FULL_TARGET)) +UseEXECPPAS=1 +endif +endif +ifneq ($(UseEXECPPAS),1) EXECPPAS= else -ifeq ($(FULL_SOURCE),$(FULL_TARGET)) ifdef RUNBATCH EXECPPAS:=@$(RUNBATCH) $(PPAS) else EXECPPAS:=@$(PPAS) endif endif -endif .PHONY: fpc_exes ifndef CROSSINSTALL ifneq ($(TARGET_PROGRAMS),) @@ -2110,7 +2139,7 @@ PREPUP=utils/prepup endif tstunits: $(MAKE) -C tstunits FPC_VERSION= FPC=$(TEST_FPC) CPU_TARGET=$(TEST_CPU_TARGET) OS_TARGET=$(TEST_OS_TARGET) 'OPT=$(TEST_OPT)' CCOMPILER=$(TEST_CCOMPILER) BINUTILSPREFIX=$(TEST_BINUTILSPREFIX) -.PHONY: create_c_objects delete_c_objects copyfiles +.PHONY: create_c_objects delete_c_objects copyfiles test_c_objects C_SOURCE_DIR=test/cg/obj C_SOURCES=ctest.c tcext3.c tcext4.c tcext5.c tcext6.c CPP_SOURCES=cpptcl1.cpp cpptcl2.cpp @@ -2269,6 +2298,11 @@ ifndef SINGLEDOTESTRUNS $(Q)$(DOTEST) $(DOTESTOPT) -e $(wildcard $(addsuffix /t*.pp,$(TESTDIRS))) endif alltests: alltest alltbs alltbf allwebtbs allwebtbf +test_c_objects: testprep + $(MAKE) $(patsubst %.pp,%.log, $(wildcard test/cg/cdecl/tcalext*.pp))) + $(MAKE) $(patsubst %.pp,%.elg, $(wildcard test/cg/cdecl/tcalext*.pp))) + $(MAKE) $(patsubst %.pp,%.log, $(wildcard test/cg/cdecl/tcppcl*.pp))) + $(MAKE) $(patsubst %.pp,%.elg, $(wildcard test/cg/cdecl/tcppcl*.pp))) ifdef SINGLEDOTESTRUNS .PHONY: allexectbs allexectbf allexecwebtbs allexecwebtbf allexectest allexectests allexectbs: $(addsuffix .tbslog, $(LOGFILES)) @@ -2294,7 +2328,11 @@ $(TEST_OUTPUTDIR)/%.webtbflog : $(WEBTBFREQ) $(TEST_OUTPUTDIR)/%.testlog : $(TESTREQ) $(Q)$(ECHO) -n >> $(TEST_OUTPUTDIR)/faillist.testlog $(Q)$(ECHO) -n >> $(TEST_OUTPUTDIR)/longlog.testlog -allexectests: $(TEST_OUTPUTDIR)/log.testlog $(TEST_OUTPUTDIR)/log.tbslog $(TEST_OUTPUTDIR)/log.tbflog $(TEST_OUTPUTDIR)/log.webtbslog $(TEST_OUTPUTDIR)/log.webtbflog $(addprefix $(TEST_OUTPUTDIR)/,$(foreach EXT, $(LOGEXT), $(addsuffix $(EXT), faillist longlog))) $(addsuffix .mergedlog, $(LOGFILES)) +allexectests: $(TEST_OUTPUTDIR)/log.testlog $(TEST_OUTPUTDIR)/log.tbslog \ + $(TEST_OUTPUTDIR)/log.tbflog $(TEST_OUTPUTDIR)/log.webtbslog \ + $(TEST_OUTPUTDIR)/log.webtbflog \ + $(addprefix $(TEST_OUTPUTDIR)/,$(foreach EXT, $(LOGEXT), $(addsuffix $(EXT), faillist longlog))) \ + $(addsuffix .mergedlog, $(LOGFILES)) else .PHONY: allexectests gparmake_allexectests MAKEINC=$(TEST_OUTPUTDIR)/MakeChunks-$(TEST_TARGETSUFFIX).inc @@ -2321,7 +2359,7 @@ clean_sources: -$(DEL) $(wildcard $(patsubst %.pp,%$(PPUEXT),$(wildcard $(addsuffix /*.pp,$(DIRS))))) clean_test: -$(DELTREE) $(TEST_OUTPUTDIR) - -$(DEL) core gmon.out testprep-stamp.$(TEST_FULL_TARGET) dotgz.bat + -$(DEL) core gmon.out testprep-stamp.$(TEST_FULL_TARGET) dotgz$(SRCBATCHEXT) clean: clean_sources fpc_clean $(MAKE) clean_test CPU_TARGET=$(TEST_CPU_TARGET) OS_TARGET=$(TEST_OS_TARGET) $(MAKE) -C tstunits clean CPU_TARGET=$(TEST_CPU_TARGET) OS_TARGET=$(TEST_OS_TARGET) @@ -2345,6 +2383,9 @@ $(TEST_OUTPUTDIR)/dbdigest.cfg: $(ECHOREDIR) CPU=$(TEST_CPU_TARGET) >> $(TEST_OUTPUTDIR)/dbdigest.cfg $(ECHOREDIR) Version=$(TEST_FPC_VERSION) >> $(TEST_OUTPUTDIR)/dbdigest.cfg $(ECHOREDIR) LogFile=log >> $(TEST_OUTPUTDIR)/dbdigest.cfg +ifneq ($(TEST_USE_LONGLOG),) + $(ECHOREDIR) LongLogFile=longlog >> $(TEST_OUTPUTDIR)/dbdigest.cfg +endif $(ECHOREDIR) Submitter=$(TEST_USER) >> $(TEST_OUTPUTDIR)/dbdigest.cfg $(ECHOREDIR) Machine=$(TEST_HOSTNAME) >> $(TEST_OUTPUTDIR)/dbdigest.cfg $(ECHOREDIR) Comment=$(TEST_OPT) >> $(TEST_OUTPUTDIR)/dbdigest.cfg @@ -2368,29 +2409,53 @@ TARFROM=-I tar.lst else TARFROM=--files-from=tar.lst endif +ifneq ($(TEST_USE_LONGLOG),) +PREPUP_OPT=-ll +else +PREPUP_OPT= +endif ifndef inWinDOS $(TEST_OUTPUTDIR)/tar.lst: +ifdef inOS2 + cd $(subst /,\,$(TEST_OUTPUTDIR)) && gnufind . -name "*.log" -o -name "*.elg" > tar.lst + $(ECHOREDIR) log>> $(TEST_OUTPUTDIR)/tar.lst + $(ECHOREDIR) dbdigest.cfg>> $(TEST_OUTPUTDIR)/tar.lst +else +ifeq ($(TEST_USE_LONGLOG),) cd $(TEST_OUTPUTDIR) && find . -name '*.log' -o -name '*.elg' > tar.lst +else + $(ECHOREDIR) "longlog" > $(TEST_OUTPUTDIR)/tar.lst +endif $(ECHOREDIR) "log" >> $(TEST_OUTPUTDIR)/tar.lst $(ECHOREDIR) "dbdigest.cfg" >> $(TEST_OUTPUTDIR)/tar.lst +endif $(TEST_OUTPUTDIR)/$(DB_TARGZ): $(TEST_OUTPUTDIR)/tar.lst $(TEST_OUTPUTDIR)/dbdigest.cfg ifdef inCygWin dos2unix $(TEST_OUTPUTDIR)/tar.lst endif +ifdef inOS2 + dos2unix $(TEST_OUTPUTDIR)/tar.lst + cd $(subst /,\,$(TEST_OUTPUTDIR)) && $(TARPROG) czf $(DB_TARGZ) $(TARFROM) +else cd $(TEST_OUTPUTDIR) && $(TARPROG) czf $(DB_TARGZ) $(TARFROM) +endif else $(TEST_OUTPUTDIR)/$(DB_TARGZ): $(TEST_OUTPUTDIR)/dbdigest.cfg ifdef inDOS - $(ECHOREDIR) @echo off > dotgz.bat - $(ECHOREDIR) cd $(subst /,\,$(TEST_OUTPUTDIR)) >> dotgz.bat - $(ECHOREDIR) $(subst /,\,../../$(PREPUP)) $(DB_TARGZ) >> dotgz.bat - $(ECHOREDIR) if errorlevel 1 $(DEL) $(DB_TARGZ) >> dotgz.bat - $(ECHOREDIR) cd $(subst /,\,../../) >> dotgz.bat - $(RUNBATCH) dotgz.bat + $(ECHOREDIR) @echo off > dotgz$(SRCBATCHEXT) + $(ECHOREDIR) cd $(subst /,\,$(TEST_OUTPUTDIR)) >> dotgz$(SRCBATCHEXT) + $(ECHOREDIR) $(subst /,\,../../$(PREPUP)) $(DB_TARGZ) >> dotgz$(SRCBATCHEXT) + $(ECHOREDIR) if errorlevel 1 $(DEL) $(DB_TARGZ) >> dotgz$(SRCBATCHEXT) + $(ECHOREDIR) cd $(subst /,\,../../) >> dotgz$(SRCBATCHEXT) + $(RUNBATCH) dotgz$(SRCBATCHEXT) +else +ifdef inOS2 + cd "$(subst /,\,$(TEST_OUTPUTDIR))" && "..\..\$(PREPUP)" $(DB_TARGZ) else cd "$(TEST_OUTPUTDIR)" && "../../$(PREPUP)" $(DB_TARGZ) endif endif +endif ifndef DB_USE_SSH ifdef inWinDOS UsePutty=1 @@ -2402,8 +2467,12 @@ ifdef UsePutty plink -load "fpc@www.freepascal.org" "mv $(DB_UPLOADDIR)/$(DB_TARGZ).part $(DB_UPLOADDIR)/$(DB_TARGZ)" else scp $(DB_SSH_EXTRA) $(TEST_OUTPUTDIR)/$(DB_TARGZ) $(DB_HOST):$(DB_UPLOADDIR)/$(DB_TARGZ).part +ifdef inOS2 + $(ECHOREDIR) . | ssh $(DB_SSH_EXTRA) $(DB_HOST) "mv $(DB_UPLOADDIR)/$(DB_TARGZ).part $(DB_UPLOADDIR)/$(DB_TARGZ)" +else ssh $(DB_SSH_EXTRA) $(DB_HOST) "mv $(DB_UPLOADDIR)/$(DB_TARGZ).part $(DB_UPLOADDIR)/$(DB_TARGZ)" endif +endif all : allexectests full : $(MAKE) clean diff --git a/tests/Makefile.fpc b/tests/Makefile.fpc index af8b8508d2..e8ae5f6c3b 100644 --- a/tests/Makefile.fpc +++ b/tests/Makefile.fpc @@ -215,7 +215,7 @@ tstunits: # Copy test environment dependent files ctest.o, cext3.o, cext4.o to test/cg etc # -.PHONY: create_c_objects delete_c_objects copyfiles +.PHONY: create_c_objects delete_c_objects copyfiles test_c_objects C_SOURCE_DIR=test/cg/obj C_SOURCES=ctest.c tcext3.c tcext4.c tcext5.c tcext6.c @@ -261,6 +261,7 @@ copyfiles: $(TEST_OUTPUTDIR) -$(COPY) $(CPP_OBJECTS) $(TEST_OUTPUTDIR)/test/cg -$(MKDIRTREE) $(TEST_OUTPUTDIR)/test/units/system + ################################ # Preparation for tests # @@ -429,6 +430,12 @@ endif alltests: alltest alltbs alltbf allwebtbs allwebtbf +test_c_objects: testprep + $(MAKE) $(patsubst %.pp,%.log, $(wildcard test/cg/cdecl/tcalext*.pp))) + $(MAKE) $(patsubst %.pp,%.elg, $(wildcard test/cg/cdecl/tcalext*.pp))) + $(MAKE) $(patsubst %.pp,%.log, $(wildcard test/cg/cdecl/tcppcl*.pp))) + $(MAKE) $(patsubst %.pp,%.elg, $(wildcard test/cg/cdecl/tcppcl*.pp))) + ################################ # Compile and Run tests # @@ -467,7 +474,11 @@ $(TEST_OUTPUTDIR)/%.testlog : $(TESTREQ) $(Q)$(ECHO) -n >> $(TEST_OUTPUTDIR)/longlog.testlog # run all tests, then merge log files -allexectests: $(TEST_OUTPUTDIR)/log.testlog $(TEST_OUTPUTDIR)/log.tbslog $(TEST_OUTPUTDIR)/log.tbflog $(TEST_OUTPUTDIR)/log.webtbslog $(TEST_OUTPUTDIR)/log.webtbflog $(addprefix $(TEST_OUTPUTDIR)/,$(foreach EXT, $(LOGEXT), $(addsuffix $(EXT), faillist longlog))) $(addsuffix .mergedlog, $(LOGFILES)) +allexectests: $(TEST_OUTPUTDIR)/log.testlog $(TEST_OUTPUTDIR)/log.tbslog \ + $(TEST_OUTPUTDIR)/log.tbflog $(TEST_OUTPUTDIR)/log.webtbslog \ + $(TEST_OUTPUTDIR)/log.webtbflog \ + $(addprefix $(TEST_OUTPUTDIR)/,$(foreach EXT, $(LOGEXT), $(addsuffix $(EXT), faillist longlog))) \ + $(addsuffix .mergedlog, $(LOGFILES)) # SINGLEDOTESTRUNS else @@ -480,7 +491,7 @@ $(GPARMAKE): $(COMPILER_UNITTARGETDIR) utils/gparmake.pp $(FPC) $(FPCOPT) -FE. utils/gparmake.pp $(OPT) # Can't have testprep as prerequisite, because that is a phony target and -# phony targets are always remade. Since the makefile will be reparsed +# phony targets are always remade. Since the makefile will be reparsed # after making the MakeChunks file (because it has to be included) and all # up-to-date checks will be re-evaluated, this means that the testprep rule # (or testprep timestamp file, which depends on phony rules and hence has @@ -493,7 +504,7 @@ $(GPARMAKE): $(COMPILER_UNITTARGETDIR) utils/gparmake.pp # building it via the utils Makefile $(MAKEINC): $(GPARMAKE) $(TEST_OUTPUTDIR) # generate rules for parallel executions of dotest -# gparmake now also needs an additional parameter for the name of the +# gparmake now also needs an additional parameter for the name of the # used subdirectory. Note also that the index must be increasing for each # new call with a gap insuring that all the previous files have lower index # even if CHUNKSIZE is equal to 1. @@ -527,7 +538,7 @@ allexectests: $(MAKEINC) # SINGLEDOTESTRUNS endif - + ################################ # Clean @@ -541,7 +552,7 @@ clean_sources: clean_test: -$(DELTREE) $(TEST_OUTPUTDIR) - -$(DEL) core gmon.out testprep-stamp.$(TEST_FULL_TARGET) dotgz.bat + -$(DEL) core gmon.out testprep-stamp.$(TEST_FULL_TARGET) dotgz$(SRCBATCHEXT) clean: clean_sources fpc_clean $(MAKE) clean_test CPU_TARGET=$(TEST_CPU_TARGET) OS_TARGET=$(TEST_OS_TARGET) @@ -579,6 +590,9 @@ $(TEST_OUTPUTDIR)/dbdigest.cfg: $(ECHOREDIR) CPU=$(TEST_CPU_TARGET) >> $(TEST_OUTPUTDIR)/dbdigest.cfg $(ECHOREDIR) Version=$(TEST_FPC_VERSION) >> $(TEST_OUTPUTDIR)/dbdigest.cfg $(ECHOREDIR) LogFile=log >> $(TEST_OUTPUTDIR)/dbdigest.cfg +ifneq ($(TEST_USE_LONGLOG),) + $(ECHOREDIR) LongLogFile=longlog >> $(TEST_OUTPUTDIR)/dbdigest.cfg +endif $(ECHOREDIR) Submitter=$(TEST_USER) >> $(TEST_OUTPUTDIR)/dbdigest.cfg $(ECHOREDIR) Machine=$(TEST_HOSTNAME) >> $(TEST_OUTPUTDIR)/dbdigest.cfg $(ECHOREDIR) Comment=$(TEST_OPT) >> $(TEST_OUTPUTDIR)/dbdigest.cfg @@ -606,31 +620,58 @@ else TARFROM=--files-from=tar.lst endif +# Pass option -ll to perpup if we use longlog file +# instead of add all *.log and *.elg files to DB_TARGZ +ifneq ($(TEST_USE_LONGLOG),) +PREPUP_OPT=-ll +else +PREPUP_OPT= +endif + ifndef inWinDOS $(TEST_OUTPUTDIR)/tar.lst: +ifdef inOS2 + cd $(subst /,\,$(TEST_OUTPUTDIR)) && gnufind . -name "*.log" -o -name "*.elg" > tar.lst + $(ECHOREDIR) log>> $(TEST_OUTPUTDIR)/tar.lst + $(ECHOREDIR) dbdigest.cfg>> $(TEST_OUTPUTDIR)/tar.lst +else +ifeq ($(TEST_USE_LONGLOG),) cd $(TEST_OUTPUTDIR) && find . -name '*.log' -o -name '*.elg' > tar.lst +else + $(ECHOREDIR) "longlog" > $(TEST_OUTPUTDIR)/tar.lst +endif $(ECHOREDIR) "log" >> $(TEST_OUTPUTDIR)/tar.lst $(ECHOREDIR) "dbdigest.cfg" >> $(TEST_OUTPUTDIR)/tar.lst +endif $(TEST_OUTPUTDIR)/$(DB_TARGZ): $(TEST_OUTPUTDIR)/tar.lst $(TEST_OUTPUTDIR)/dbdigest.cfg ifdef inCygWin dos2unix $(TEST_OUTPUTDIR)/tar.lst endif +ifdef inOS2 + dos2unix $(TEST_OUTPUTDIR)/tar.lst + cd $(subst /,\,$(TEST_OUTPUTDIR)) && $(TARPROG) czf $(DB_TARGZ) $(TARFROM) +else cd $(TEST_OUTPUTDIR) && $(TARPROG) czf $(DB_TARGZ) $(TARFROM) +endif else $(TEST_OUTPUTDIR)/$(DB_TARGZ): $(TEST_OUTPUTDIR)/dbdigest.cfg ifdef inDOS - $(ECHOREDIR) @echo off > dotgz.bat - $(ECHOREDIR) cd $(subst /,\,$(TEST_OUTPUTDIR)) >> dotgz.bat - $(ECHOREDIR) $(subst /,\,../../$(PREPUP)) $(DB_TARGZ) >> dotgz.bat - $(ECHOREDIR) if errorlevel 1 $(DEL) $(DB_TARGZ) >> dotgz.bat - $(ECHOREDIR) cd $(subst /,\,../../) >> dotgz.bat - $(RUNBATCH) dotgz.bat + $(ECHOREDIR) @echo off > dotgz$(SRCBATCHEXT) + $(ECHOREDIR) cd $(subst /,\,$(TEST_OUTPUTDIR)) >> dotgz$(SRCBATCHEXT) + $(ECHOREDIR) $(subst /,\,../../$(PREPUP)) $(DB_TARGZ) >> dotgz$(SRCBATCHEXT) + $(ECHOREDIR) if errorlevel 1 $(DEL) $(DB_TARGZ) >> dotgz$(SRCBATCHEXT) + $(ECHOREDIR) cd $(subst /,\,../../) >> dotgz$(SRCBATCHEXT) + $(RUNBATCH) dotgz$(SRCBATCHEXT) +else +ifdef inOS2 + cd "$(subst /,\,$(TEST_OUTPUTDIR))" && "..\..\$(PREPUP)" $(DB_TARGZ) else cd "$(TEST_OUTPUTDIR)" && "../../$(PREPUP)" $(DB_TARGZ) endif endif +endif # Use Putty, unless we set DB_USE_SSH to force ssh usage @@ -647,8 +688,12 @@ ifdef UsePutty plink -load "fpc@www.freepascal.org" "mv $(DB_UPLOADDIR)/$(DB_TARGZ).part $(DB_UPLOADDIR)/$(DB_TARGZ)" else scp $(DB_SSH_EXTRA) $(TEST_OUTPUTDIR)/$(DB_TARGZ) $(DB_HOST):$(DB_UPLOADDIR)/$(DB_TARGZ).part +ifdef inOS2 + $(ECHOREDIR) . | ssh $(DB_SSH_EXTRA) $(DB_HOST) "mv $(DB_UPLOADDIR)/$(DB_TARGZ).part $(DB_UPLOADDIR)/$(DB_TARGZ)" +else ssh $(DB_SSH_EXTRA) $(DB_HOST) "mv $(DB_UPLOADDIR)/$(DB_TARGZ).part $(DB_UPLOADDIR)/$(DB_TARGZ)" endif +endif all : allexectests diff --git a/tests/readme.txt b/tests/readme.txt index 51b7d96f97..fb4aeb585b 100644 --- a/tests/readme.txt +++ b/tests/readme.txt @@ -181,7 +181,7 @@ TEST_RSH set this to the hostname when you want to use rsh/rcp TEST_SSH set this to use ssh/scp to execute the test TEST_PUTTY test using putty when remote testing (pscp and plink) TEST_ADB run tests om remote Android device using ADB. Specify - TEST_ADB=1 to run on default connected device. Specify + TEST_ADB=1 to run on default connected device. Specify TEST_ADB=<serial> to run on specific connected device. TEST_REMOTEOPT extra options to remote program TEST_REMOTEPATH set remote path to use, default is /tmp @@ -268,3 +268,5 @@ On Windows: - There must be a putty session named fpc@www.freepascal.org which is enabled to login automatically into www.freepascal.org +Use TEST_USE_LONGLOG=1 as make parameter to pass information +to server using longlog file instead of the whole output. diff --git a/tests/tbf/tb0249.pp b/tests/tbf/tb0249.pp new file mode 100644 index 0000000000..6fde9cf76b --- /dev/null +++ b/tests/tbf/tb0249.pp @@ -0,0 +1,8 @@ +{ %FAIL } + +program tb0249; +var + p: PByte; +begin + p := nil - 5; +end. diff --git a/tests/tbf/tb0250.pp b/tests/tbf/tb0250.pp new file mode 100644 index 0000000000..cc29a9f2ca --- /dev/null +++ b/tests/tbf/tb0250.pp @@ -0,0 +1,22 @@ +{ %FAIL } + +program tb0250; + +{$mode delphi} + +type + TTest<T> = class + class var + fTest: TClass; + procedure Test; + end; + +procedure TTest<T>.Test; +begin + fTest.ToString; +end; + +begin + +end. + diff --git a/tests/tbs/tb0162.pp b/tests/tbs/tb0162.pp index e698fe365c..16c10af8ce 100644 --- a/tests/tbs/tb0162.pp +++ b/tests/tbs/tb0162.pp @@ -5,10 +5,13 @@ uses sysutils; +var + has_errors: boolean; + procedure doerror(l: longint); begin writeln('error near ',l); - halt(1); + has_errors:=true; end; {$R-} @@ -20,6 +23,7 @@ var i: integer; n: int64; q: qword; begin + has_errors:=false; i := 32767; i := i + 15; b := 255; @@ -212,5 +216,6 @@ begin end; {$endif fpc} - + if has_errors then + halt(1); End. diff --git a/tests/tbs/tb0524.pp b/tests/tbs/tb0524.pp index ba10a014b0..3c4df26421 100644 --- a/tests/tbs/tb0524.pp +++ b/tests/tbs/tb0524.pp @@ -62,9 +62,9 @@ begin with saddr do begin - family:=af_inet; - port:=ntobe(word(6667)); - addr:=0; + sin_family:=af_inet; + sin_port:=ntobe(word(6667)); + sin_addr:=NoAddress; end; if fpbind(lsock,@saddr,sizeof(saddr))<>0 then diff --git a/tests/tbs/tb0608.pp b/tests/tbs/tb0608.pp new file mode 100644 index 0000000000..029bf2d71c --- /dev/null +++ b/tests/tbs/tb0608.pp @@ -0,0 +1,9 @@ +const + c = {$IF Declared(o) And (o<>Integer(0))}Succ{$IFEND}(False); + + begin + if c then + halt(1); + writeln('ok'); + end. + diff --git a/tests/test/cpu16/i8086/tmmc.pp b/tests/test/cpu16/i8086/tmmc.pp index 648db5b9e0..4c52ee4e85 100644 --- a/tests/test/cpu16/i8086/tmmc.pp +++ b/tests/test/cpu16/i8086/tmmc.pp @@ -25,6 +25,7 @@ program tmml; var CS, DS, SS, HS: Word; HeapP: Pointer; + HeapOrgSeg, HeapOrgOfs, HeapEndSeg, HeapEndOfs: Word; ErrorsFound: Boolean; procedure Error(const S: string); @@ -48,10 +49,16 @@ begin DS := DSeg; SS := SSeg; HS := Seg(HeapP^); + HeapOrgSeg := Seg(HeapOrg^); + HeapOrgOfs := Ofs(HeapOrg^); + HeapEndSeg := Seg(HeapEnd^); + HeapEndOfs := Ofs(HeapEnd^); Writeln('PrefixSeg=', PrefixSeg); Writeln('CS=', CS); Writeln('DS=', DS); Writeln('SS=', SS); + Writeln('HeapOrg=', HeapOrgSeg, ':', HeapOrgOfs); + Writeln('HeapEnd=', HeapEndSeg, ':', HeapEndOfs); Writeln('Heap Seg=', HS); if not (PrefixSeg < CS) then Error('PrefixSeg >= CS'); @@ -63,6 +70,14 @@ begin Error('DS >= SS'); if not (SS < HS) then Error('SS >= HeapSeg'); + if HeapOrgOfs <> 0 then + Error('HeapOrg offset <> 0'); + if HeapEndOfs <> 0 then + Error('HeapEnd offset <> 0'); + if (HeapOrgSeg - SS) <> 1024 then + Error('HeapOrgSeg <> SS+1024 (16kb stack)'); + if (PrefixSeg + MemW[PrefixSeg-1:3]) <> HeapEndSeg then + Error('HeapEnd segment <> end_of_current_program_MCB'); FreeMem(HeapP, 5); if ErrorsFound then begin diff --git a/tests/test/cpu16/i8086/tmml.pp b/tests/test/cpu16/i8086/tmml.pp index fa3346e554..31618d28fe 100644 --- a/tests/test/cpu16/i8086/tmml.pp +++ b/tests/test/cpu16/i8086/tmml.pp @@ -21,6 +21,7 @@ program tmml; var CS, DS, SS, HS: Word; HeapP: Pointer; + HeapOrgSeg, HeapOrgOfs, HeapEndSeg, HeapEndOfs: Word; ErrorsFound: Boolean; procedure Error(const S: string); @@ -44,10 +45,16 @@ begin DS := DSeg; SS := SSeg; HS := Seg(HeapP^); + HeapOrgSeg := Seg(HeapOrg^); + HeapOrgOfs := Ofs(HeapOrg^); + HeapEndSeg := Seg(HeapEnd^); + HeapEndOfs := Ofs(HeapEnd^); Writeln('PrefixSeg=', PrefixSeg); Writeln('CS=', CS); Writeln('DS=', DS); Writeln('SS=', SS); + Writeln('HeapOrg=', HeapOrgSeg, ':', HeapOrgOfs); + Writeln('HeapEnd=', HeapEndSeg, ':', HeapEndOfs); Writeln('Heap Seg=', HS); if not (PrefixSeg < CS) then Error('PrefixSeg >= CS'); @@ -57,6 +64,14 @@ begin Error('DS >= SS'); if not (SS < HS) then Error('SS >= HeapSeg'); + if HeapOrgOfs <> 0 then + Error('HeapOrg offset <> 0'); + if HeapEndOfs <> 0 then + Error('HeapEnd offset <> 0'); + if (HeapOrgSeg - SS) <> 1024 then + Error('HeapOrgSeg <> SS+1024 (16kb stack)'); + if (PrefixSeg + MemW[PrefixSeg-1:3]) <> HeapEndSeg then + Error('HeapEnd segment <> end_of_current_program_MCB'); FreeMem(HeapP, 5); if ErrorsFound then begin diff --git a/tests/test/cpu16/i8086/ttheap1.pp b/tests/test/cpu16/i8086/ttheap1.pp new file mode 100644 index 0000000000..362a01fb3d --- /dev/null +++ b/tests/test/cpu16/i8086/ttheap1.pp @@ -0,0 +1,181 @@ +{ %cpu=i8086 } + +{ Test for TP7 compatibility of the tiny heap free list in the i8086 far data + memory models. + + This test is TP7 compatible. } + +{$IFDEF FPC} + {$DEFINE SKIP_TEST} + {$IFDEF FPC_MM_COMPACT} + {$UNDEF SKIP_TEST} + {$ENDIF not FPC_MM_COMPACT} + {$IFDEF FPC_MM_LARGE} + {$UNDEF SKIP_TEST} + {$ENDIF not FPC_MM_LARGE} + {$IFDEF FPC_MM_HUGE} + {$UNDEF SKIP_TEST} + {$ENDIF not FPC_MM_HUGE} +{$ENDIF FPC} + +{$IFDEF SKIP_TEST} +program ttheap1; +begin + Writeln('Test compiled for the wrong memory model. Goodbye!'); +end +{$ELSE SKIP_TEST} + +program ttheap1; + +type + PHeapBlock = ^THeapBlock; + THeapBlock = record + Next: PHeapBlock; + Size: Pointer; + end; + +function HexStr(L: LongInt; digits: Integer): string; +const + D: array [0..15] of char = '0123456789ABCDEF'; +var + res: string; + I: Integer; +begin + res := ''; + for I := 1 to digits do + begin + res := D[L and 15] + res; + L := L shr 4; + end; + HexStr := res; +end; + +function PtrStr(P: Pointer): string; +begin + PtrStr := '$' + HexStr(Seg(P^), 4) + ':' + HexStr(Ofs(P^), 4); +end; + +procedure CheckNormalization(P: Pointer); +begin + if Ofs(P^) > 15 then + begin + Writeln('Pointer not normalized! ', PtrStr(P)); + Halt(1); + end; +end; + +procedure CheckAlignment(P: Pointer); +begin + if (Ofs(P^) mod 8) <> 0 then + begin + Writeln('Pointer not aligned! ', PtrStr(P)); + Halt(1); + end; +end; + +procedure CheckSequence(P1, P2: Pointer); +begin + if ((LongInt(Seg(P1^)) shl 4) + Ofs(P1^)) >= + ((LongInt(Seg(P2^)) shl 4) + Ofs(P2^)) then + begin + Writeln('Pointer sequence broken: ', PtrStr(P1) , '>=', PtrStr(P2), ' (should be <)'); + Halt(1); + end; +end; + +procedure CheckSequence_AllowEquals(P1, P2: Pointer); +begin + if ((LongInt(Seg(P1^)) shl 4) + Ofs(P1^)) > + ((LongInt(Seg(P2^)) shl 4) + Ofs(P2^)) then + begin + Writeln('Pointer sequence broken: ', PtrStr(P1) , '>', PtrStr(P2), ' (should be <=)'); + Halt(1); + end; +end; + +procedure CheckOverlap(P1, P1Size, P2: Pointer); +begin + if (((LongInt(Seg(P1^)) shl 4) + Ofs(P1^)) + + ((LongInt(Seg(P1Size^)) shl 4) + Ofs(P1Size^))) >= + ((LongInt(Seg(P2^)) shl 4) + Ofs(P2^)) then + begin + Writeln('Free list overlap: ', PtrStr(P1), '+', PtrStr(P1Size) , '>=', PtrStr(P2), ' (should be <)'); + Halt(1); + end; +end; + +procedure WalkFreeList; +var + Block: PHeapBlock; +begin + Block := FreeList; + repeat + CheckNormalization(Block); + CheckAlignment(Block); + Write(PtrStr(Block), ' : Next=', PtrStr(Block^.Next), ' Size=', PtrStr(Block^.Size)); + if Block = HeapPtr then + begin + Writeln(', Reached HeapPtr!'); + break; + end; + Writeln; + CheckNormalization(Block^.Size); + CheckAlignment(Block^.Size); + CheckSequence(Block, Block^.Next); + CheckOverlap(Block, Block^.Size, Block^.Next); + Block := Block^.Next; + until false; +end; + +procedure DumpHeap; +begin + Writeln('HeapOrg = ', PtrStr(HeapOrg)); + Writeln('HeapEnd = ', PtrStr(HeapEnd)); + Writeln('HeapPtr = ', PtrStr(HeapPtr)); + Writeln('FreeList = ', PtrStr(FreeList)); + CheckNormalization(HeapOrg); + CheckAlignment(HeapOrg); + CheckNormalization(HeapEnd); + CheckAlignment(HeapEnd); + CheckSequence_AllowEquals(HeapOrg, FreeList); + CheckSequence_AllowEquals(HeapPtr, HeapEnd); + WalkFreeList; +end; + +procedure RandomMem; +var + I: Integer; + Q: array [0..1000] of record + p: Pointer; + Size: Word; + end; +begin + FillChar(Q, SizeOf(Q), 0); + for I := 1 to 10000 do + begin + with Q[Random(1001)] do + begin + if p = nil then + begin + Size := Random(100); + GetMem(p, Size); + end + else + begin + FreeMem(p, Size); + p := nil; + Size := 0; + end; + end; + end; +end; + +begin + Randomize; + DumpHeap; + RandomMem; + DumpHeap; + Writeln('Ok!'); +end +{$ENDIF SKIP_TEST} +. diff --git a/tests/test/jvm/testall.bat b/tests/test/jvm/testall.bat index 22dd423911..cd51c745c1 100644 --- a/tests/test/jvm/testall.bat +++ b/tests/test/jvm/testall.bat @@ -295,10 +295,22 @@ if %errorlevel% neq 0 exit /b %errorlevel% java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tptrdynarr if %errorlevel% neq 0 exit /b %errorlevel% ppcjvm -O2 -g -B -Sa tprop5a +if %errorlevel% neq 0 exit /b %errorlevel% java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tprop5a +if %errorlevel% neq 0 exit /b %errorlevel% ppcjvm -O2 -g -B -Sa tprop5a -CTautosetterprefix=Set -CTautogetterprefix=Get +if %errorlevel% neq 0 exit /b %errorlevel% java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tprop5a +if %errorlevel% neq 0 exit /b %errorlevel% ppcjvm -O2 -g -B -Sa tprop6a +if %errorlevel% neq 0 exit /b %errorlevel% java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tprop6a +if %errorlevel% neq 0 exit /b %errorlevel% ppcjvm -O2 -g -B -Sa tprop6a -CTautosetterprefix=Set -CTautogetterprefix=Get +if %errorlevel% neq 0 exit /b %errorlevel% java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tprop6a +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g -B -CTinitlocals tsetstring +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tsetstring +if %errorlevel% neq 0 exit /b %errorlevel% diff --git a/tests/test/jvm/testall.sh b/tests/test/jvm/testall.sh index 5feb130a08..bb8a1e227d 100755 --- a/tests/test/jvm/testall.sh +++ b/tests/test/jvm/testall.sh @@ -182,3 +182,5 @@ $PPC -O2 -g -B -Sa tprop6a java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/$RTLDIR:. tprop6a $PPC -O2 -g -B -Sa tprop6a -CTautosetterprefix=Set -CTautogetterprefix=Get java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/$RTLDIR:. tprop6a +$PPC -O2 -g -B -Sa tsetstring +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/$RTLDIR:. tsetstring diff --git a/tests/test/jvm/tsetstring.pp b/tests/test/jvm/tsetstring.pp new file mode 100644 index 0000000000..9f800d8ce9 --- /dev/null +++ b/tests/test/jvm/tsetstring.pp @@ -0,0 +1,32 @@ +program tsetstring; + +type + tstr866 = type ansistring(866); + +var + str866: tstr866; + a: ansistring; + u: unicodestring; + s: shortstring; + pa: pansichar; +begin + setstring(str866,'abcdef',5); + if stringcodepage(str866)<>866 then + halt(1); + if str866<>'abcde' then + halt(2); + setstring(a,'abc',3); + if (stringcodepage(a)<>0) and + (stringcodepage(a)<>DefaultSystemCodePage) then + halt(3); + if a<>'abc' then + halt(4); + pa:='12345'; + setstring(u,pa,5); + if u<>'12345' then + halt(5); + setstring(s,pa,5); + if s<>'12345' then + halt(7); +end. + diff --git a/tests/test/tcpstransistr2widechararray2.pp b/tests/test/tcpstransistr2widechararray2.pp new file mode 100644 index 0000000000..4b191ac422 --- /dev/null +++ b/tests/test/tcpstransistr2widechararray2.pp @@ -0,0 +1,31 @@ +{ this file is stored in utf8, but we don't tell the compiler so that the string + constant gets code page 0/CP_ACP; this test is to make sure that + fpc_ansistr_to_widechararray() translates CP_ACP to the actual value of + DefaultSystemCodePage before calling widestringmanager.ansi2widemoveproc +} + +{$ifdef unix} +uses + cwstring; +{$endif} +{$r+} +var + u8: ansistring; + a: array[0..10] of unicodechar; + u16: unicodestring; + i: longint; +begin + DefaultSystemCodePage:=CP_UTF8; + u8:='èà '; + a:=u8; + u16:=unicodestring(u8); + for i:=0 to 1 do + begin + writeln('u16[',i-low(a)+low(u16),'] = $',hexstr(ord(u16[i-low(a)+low(u16)]),2)); + writeln('a[',i,'] = $',hexstr(ord(a[i]),2)); + if u16[i-low(a)+low(u16)]<>a[i] then + halt(i+1); + end; + if a[2]<>#0 then + halt(3); +end. diff --git a/tests/test/tgenconstraint37.pp b/tests/test/tgenconstraint37.pp new file mode 100644 index 0000000000..a9d46c211b --- /dev/null +++ b/tests/test/tgenconstraint37.pp @@ -0,0 +1,35 @@ +{ %NORUN } + +program tgenconstraint37; + +{$mode objfpc} + +type + generic TGenericTObject<T: TObject> = class + end; + + generic TGenericClass<T: class> = class + end; + + generic TGenericIInterface<T: IInterface> = class + end; + + TTestObject = class; + ITestInterface = interface; + + + TGenericTObjectTTestObject = specialize TGenericTObject<TTestObject>; + + TGenericClassTTestObject = specialize TGenericClass<TTestObject>; + + TGenericIInterfaceITestInterface = specialize TGenericIInterface<ITestInterface>; + + + TTestObject = class + end; + + ITestInterface = interface + end; + +begin +end. diff --git a/tests/test/tgenconstraint38.pp b/tests/test/tgenconstraint38.pp new file mode 100644 index 0000000000..95a319e890 --- /dev/null +++ b/tests/test/tgenconstraint38.pp @@ -0,0 +1,20 @@ +{ %FAIL } + +program tgenconstraint38; + +{$mode objfpc} + +type + generic TGeneric<T: TObject, IInterface> = class + end; + + TTest = class; + + TGenericTTest = specialize TGeneric<TTest>; + + TTest = class + end; + +begin + +end. diff --git a/tests/test/tgenconstraint39.pp b/tests/test/tgenconstraint39.pp new file mode 100644 index 0000000000..4230178ee1 --- /dev/null +++ b/tests/test/tgenconstraint39.pp @@ -0,0 +1,23 @@ +{ %FAIL } + +program tgenconstraint39; + +{$mode objfpc} + +type + TSomeClass = class + end; + + generic TGeneric<T: TSomeClass> = class + end; + + TTest = class; + + TGenericTTest = specialize TGeneric<TTest>; + + TTest = class(TSomeClass) + end; + +begin + +end. diff --git a/tests/test/tgenconstraint40.pp b/tests/test/tgenconstraint40.pp new file mode 100644 index 0000000000..a89d14d384 --- /dev/null +++ b/tests/test/tgenconstraint40.pp @@ -0,0 +1,23 @@ +{ %FAIL } + +program tgenconstraint40; + +{$mode objfpc} + +type + ISomeInterface = interface + end; + + generic TGeneric<T: ISomeInterface> = class + end; + + ITest = interface; + + TGenericITest = specialize TGeneric<ITest>; + + ITest = interface(ISomeInterface) + end; + +begin + +end. diff --git a/tests/test/tgeneric97.pp b/tests/test/tgeneric97.pp new file mode 100644 index 0000000000..cfb1434d53 --- /dev/null +++ b/tests/test/tgeneric97.pp @@ -0,0 +1,18 @@ +program tgeneric97; + +{$mode objfpc} + +type + generic TTest<T> = class + + end; + + TTestLongInt = specialize TTest<LongInt>; + TTestString = specialize TTest<AnsiString>; + +begin + if LowerCase(TTestLongInt.ClassName) <> 'ttest<system.longint>' then + halt(1); + if LowerCase(TTestString.ClassName) <> 'ttest<system.ansistring>' then + halt(2); +end. diff --git a/tests/test/tgeneric98.pp b/tests/test/tgeneric98.pp new file mode 100644 index 0000000000..272ba9c1d5 --- /dev/null +++ b/tests/test/tgeneric98.pp @@ -0,0 +1,50 @@ +{ %NORUN } + +program tgeneric98; + +{$mode objfpc} + +type + generic TTest<T> = class + public type + TAlias = T; + private + fField: TAlias; + procedure SetField(aValue: TAlias); + public + property Field: TAlias read fField write SetField; + function CalcField: TAlias; + end; + + generic TTest2<T> = class + public type + TTestT = specialize TTest<T>; + private + fField: TTestT.TAlias; + procedure SetField(aValue: TTestT.TAlias); + public + property Field: TTestT.TAlias read fField write SetField; + function CalcField: TTestT.TAlias; + end; + +procedure TTest.SetField(aValue: TAlias); +begin +end; + +function TTest.CalcField: TAlias; +begin + Result := Default(TAlias); +end; + +procedure TTest2.SetField(aValue: TTestT.TAlias); +begin +end; + +function TTest2.CalcField: TTestT.TAlias; +begin + Result := Default(TTestT.TAlias); +end; + +begin + +end. diff --git a/tests/test/thlp47.pp b/tests/test/thlp47.pp new file mode 100644 index 0000000000..f715006043 --- /dev/null +++ b/tests/test/thlp47.pp @@ -0,0 +1,56 @@ +{ This tests that class variables for the various helper kinds work correctly } + +program thlp47; + +{$mode objfpc} +{$modeswitch advancedrecords} +{$modeswitch typehelpers} + +type + TObjectHelper = class helper for TObject + public + class procedure Init; + public class var + Value: LongInt; + end; + + TGuidHelper = record helper for TGuid + public + class procedure Init; static; + public class var + Value: LongInt; + end; + + TLongIntHelper = type helper for LongInt + public + class procedure Init; static; + public class var + Value: LongInt; + end; + +class procedure TObjectHelper.Init; +begin + Value := 42; +end; + +class procedure TGuidHelper.Init; +begin + Value := 21; +end; + +class procedure TLongIntHelper.Init; +begin + Value := 84; +end; + +begin + TObject.Init; + if TObject.Value <> 42 then + Halt(1); + TGuid.Init; + if TGuid.Value <> 21 then + Halt(2); + LongInt.Init; + if LongInt.Value <> 84 then + Halt(3); +end. diff --git a/tests/test/thlp48.pp b/tests/test/thlp48.pp new file mode 100644 index 0000000000..c7895acc71 --- /dev/null +++ b/tests/test/thlp48.pp @@ -0,0 +1,24 @@ +{ %fail } +{ %opt=-vw -Sew } + +program thelper; + +{$mode objfpc} + +type + TTest = class; + + TTestHelper = class helper for TTest + procedure Test; + end; + + TTest = class + Test: LongInt; + end; + +procedure TTestHelper.Test; +begin +end; + +begin +end. diff --git a/tests/test/tisorec1.pp b/tests/test/tisorec1.pp index 2ab137a600..796df8afab 100644 --- a/tests/test/tisorec1.pp +++ b/tests/test/tisorec1.pp @@ -6,7 +6,7 @@ type 1 : (s : array[0..255] of char); 2 : (n : integer); 3 : (w : word; case j : integer of - 1 : (s : array[0..255] of char); + 1 : (t : array[0..255] of char); 2 : (a : integer); ); end; diff --git a/tests/test/tisorec4.pp b/tests/test/tisorec4.pp new file mode 100644 index 0000000000..24e321741a --- /dev/null +++ b/tests/test/tisorec4.pp @@ -0,0 +1,23 @@ +{$mode iso} +type + tr = record + l : longint; + case integer of + 1 : (s : array[0..255] of char); + 2 : (n : integer); + 3 : (w : word; case j : integer of + 1 : (t : array[0..255] of char); + 2 : (a : integer); + ); + end; + pr = ^tr; + +var + r : pr; +begin + new(r,3,2); + if r^.j<>2 then + halt(1); + dispose(r); + writeln('ok'); +end. diff --git a/tests/test/tobjc41.pp b/tests/test/tobjc41.pp new file mode 100644 index 0000000000..7f033f883a --- /dev/null +++ b/tests/test/tobjc41.pp @@ -0,0 +1,24 @@ +{ %target=darwin } +{ %fail } +{ %opt=-Sew } + +{$mode objfpc} +{$modeswitch objectivec2} + +uses + uobjc41; + +type + NSDictionaryUtilities = objccategory (NSSubject) + { the "key" paramter should give a warning because there's already a "key" + message in a category for NSObject } + function containsKey (key: NSString): boolean; message 'containsKey:'; + end; + +function NSDictionaryUtilities.containsKey (key: NSString): boolean; +begin + result:=false; +end; + +begin +end. diff --git a/tests/test/tthlp22.pp b/tests/test/tthlp22.pp index 57f7bd4d26..ebe02c7e95 100644 --- a/tests/test/tthlp22.pp +++ b/tests/test/tthlp22.pp @@ -1,8 +1,8 @@ -{ %FAIL } +{ %NORUN } { type helpers are not parsed if modeswitch typehelpers is not set (mode Delphi) } -program tthlp20; +program tthlp22; {$mode delphi} diff --git a/tests/test/units/math/troundm.pp b/tests/test/units/math/troundm.pp new file mode 100644 index 0000000000..9f09721774 --- /dev/null +++ b/tests/test/units/math/troundm.pp @@ -0,0 +1,174 @@ + + +{ Converting 64-bit integers with more than 53 significant bits to double-precision + floating point format is subject to rounding. Hence result depends on rounding mode. + The same goes for 32-bit integers with more than 23 significant bits converted to + single. } +uses math; + +type + TExpected=array[TFPURoundingMode] of qword; + +const + res1_single: TExpected = ( + $4E800000, + $4E800000, + $4E800001, + $4E800000 + ); + + res2_single: TExpected = ( + $4EFFFFFF, + $4EFFFFFF, + $4F000000, + $4EFFFFFF + ); + + res3_single: TExpected = ( + $CEFFFFFF, + $CF000000, + $CEFFFFFF, + $CEFFFFFF + ); + + + res1: TExpected = ( + $43D0000000000000, + $43D0000000000000, + $43D0000000000001, + $43D0000000000000 + ); + + res2: TExpected = ( + $43E0000000000000, + $43DFFFFFFFFFFFFF, + $43E0000000000000, + $43DFFFFFFFFFFFFF + ); + + res3: TExpected = ( + qword($C3E0000000000000), + qword($C3E0000000000000), + qword($C3DFFFFFFFFFFFFF), + qword($C3DFFFFFFFFFFFFF) + ); + +var + has_errors: boolean=false; + +procedure fail; +begin + writeln('Wrong!'); + has_errors:=true; +end; + + +procedure test32(x: longint; const res: texpected); +var + y: single; + yd: longword absolute y; +begin + writeln('integer value=',hexstr(x,8)); + y:=x; + writeln('rmNearest ',y, ' ',hexstr(yd,8)); + if yd<>res[rmNearest] then fail; + + setroundmode(rmUp); + y:=x; + writeln('rmUp ',y, ' ',hexstr(yd,8)); + if yd<>res[rmUp] then fail; + + setroundmode(rmDown); + y:=x; + writeln('rmDown ',y, ' ',hexstr(yd,8)); + if yd<>res[rmDown] then fail; + + setroundmode(rmTruncate); + y:=x; + writeln('rmTruncate ',y, ' ',hexstr(yd,8)); + if yd<>res[rmTruncate] then fail; +end; + + +procedure testint64(x: int64; const res: TExpected); +var + y: double; + yq: qword absolute y; +begin + writeln('integer value=',hexstr(x,16)); + setroundmode(rmNearest); + y:=x; + writeln('rmNearest ',y, ' ',hexstr(yq,16)); + if yq<>res[rmNearest] then fail; + + setroundmode(rmUp); + y:=x; + writeln('rmUp ',y, ' ',hexstr(yq,16)); + if yq<>res[rmUp] then fail; + + setroundmode(rmDown); + y:=x; + writeln('rmDown ',y, ' ',hexstr(yq,16)); + if yq<>res[rmDown] then fail; + + setroundmode(rmTruncate); + y:=x; + writeln('rmTruncate ',y, ' ',hexstr(yq,16)); + if yq<>res[rmTruncate] then fail; +end; + + +procedure testqword(x: qword; const res: TExpected); +var + y: double; + yq: qword absolute y; +begin + writeln('integer value=',hexstr(x,16)); + setroundmode(rmNearest); + y:=x; + writeln('rmNearest ',y, ' ',hexstr(yq,16)); + if yq<>res[rmNearest] then fail; + + setroundmode(rmUp); + y:=x; + writeln('rmUp ',y, ' ',hexstr(yq,16)); + if yq<>res[rmUp] then fail; + + setroundmode(rmDown); + y:=x; + writeln('rmDown ',y, ' ',hexstr(yq,16)); + if yq<>res[rmDown] then fail; + + setroundmode(rmTruncate); + y:=x; + writeln('rmTruncate ',y, ' ',hexstr(yq,16)); + if yq<>res[rmTruncate] then fail; +end; + + +begin + writeln('Testing longint->single conversion'); + test32($40000001,res1_single); + writeln; + test32($7fffffff,res2_single); + writeln; + test32(longint($80000001),res3_single); + writeln; + + writeln('Testing int64->double conversion'); + testint64($4000000000000001,res1); + writeln; + testint64($7fffffffffffffff,res2); + writeln; + testint64(int64($8000000000000001),res3); + writeln; + + writeln('Testing qword->double conversion'); + testqword($4000000000000001,res1); + writeln; + testqword($7fffffffffffffff,res2); + writeln; + + if has_errors then + halt(1); +end. diff --git a/tests/test/units/system/tfloatrecs.pp b/tests/test/units/system/tfloatrecs.pp new file mode 100644 index 0000000000..776ba361b8 --- /dev/null +++ b/tests/test/units/system/tfloatrecs.pp @@ -0,0 +1,273 @@ +uses + Math; + +procedure do_error(i : longint); + begin + writeln('Error near ',i); + halt(1); + end; + +var +{$ifdef FPC_HAS_TYPE_EXTENDED} + extended_NaN,extended_Inf,extended_NInf,extended_NDenormal,extended_Denormal,extended_Zero,extended_NZero, + extended_Positive,extended_Negative,extended_InvalidOp : extended; +{$endif FPC_HAS_TYPE_EXTENDED} +{$ifdef FPC_HAS_TYPE_DOUBLE} + double_NaN,double_Inf,double_NInf,double_NDenormal,double_Denormal,double_Zero,double_NZero, + double_Positive,double_Negative : double; +{$endif FPC_HAS_TYPE_DOUBLE} +{$ifdef FPC_HAS_TYPE_SINGLE} + single_NaN,single_Inf,single_NInf,single_NDenormal,single_Denormal,single_Zero,single_NZero, + single_Positive,single_Negative : single; +{$endif FPC_HAS_TYPE_SINGLE} + +begin +{$ifdef FPC_HAS_TYPE_EXTENDED} + extended_NaN:=NaN; + + extended_Inf:=Infinity; + + extended_NInf:=-Infinity; + + extended_Denormal:=1234.0; + TExtended80Rec(extended_Denormal).Exp:=0; + + extended_NDenormal:=-1234.0; + TExtended80Rec(extended_NDenormal).Exp:=0; + + extended_Zero:=0.0; + + extended_NZero:=0.0; + TExtended80Rec(extended_NZero).Sign:=true; + + extended_Positive:=Pi*10; + + extended_Negative:=-Pi*10; + + extended_InvalidOp:=0; + TExtended80Rec(extended_InvalidOp).Exp:=$7fff; + + if TExtended80Rec(extended_NaN).SpecialType<>fsNaN then + do_error(1); + + if TExtended80Rec(extended_Inf).SpecialType<>fsInf then + do_error(2); + + if TExtended80Rec(extended_NInf).SpecialType<>fsNInf then + do_error(3); + + if TExtended80Rec(extended_Denormal).SpecialType<>fsDenormal then + do_error(4); + + if TExtended80Rec(extended_NDenormal).SpecialType<>fsNDenormal then + do_error(5); + + if TExtended80Rec(extended_Zero).SpecialType<>fsZero then + do_error(6); + + if TExtended80Rec(extended_NZero).SpecialType<>fsNZero then + do_error(7); + + if TExtended80Rec(extended_Positive).SpecialType<>fsPositive then + do_error(8); + + if TExtended80Rec(extended_Negative).SpecialType<>fsNegative then + do_error(9); + + if TExtended80Rec(extended_InvalidOp).SpecialType<>fsInvalidOp then + do_error(10); + + if TExtended80Rec(extended_Positive).Mantissa<>$7B53D14AA9C2F2C2 then + do_error(11); + + if TExtended80Rec(extended_Positive).Fraction<>4.15926535897932384694E-0001 then + do_error(12); + + if TExtended80Rec(extended_Positive).Exponent<>4 then + do_error(13); + + if TExtended80Rec(extended_Positive).Sign then + do_error(14); + + if TExtended80Rec(extended_Positive).Exp<>$4003 then + do_error(15); + + if TExtended80Rec(extended_Negative).Mantissa<>$7B53D14AA9C2F2C2 then + do_error(16); + + if TExtended80Rec(extended_Negative).Fraction<>-4.15926535897932384694E-0001 then + do_error(17); + + if TExtended80Rec(extended_Negative).Exponent<>4 then + do_error(18); + + if not(TExtended80Rec(extended_Negative).Sign) then + do_error(19); + + if TExtended80Rec(extended_Negative).Exp<>$4003 then + do_error(20); +{$endif FPC_HAS_TYPE_EXTENDED} + +{$ifdef FPC_HAS_TYPE_DOUBLE} + double_NaN:=NaN; + + double_Inf:=Infinity; + + double_NInf:=-Infinity; + + double_Denormal:=1234.0; + TDoubleRec(double_Denormal).Exp:=0; + + double_NDenormal:=-1234.0; + TDoubleRec(double_NDenormal).Exp:=0; + + double_Zero:=0.0; + + double_NZero:=0.0; + TDoubleRec(double_NZero).Sign:=true; + + double_Positive:=Pi*10; + + double_Negative:=-Pi*10; + + if TDoubleRec(double_NaN).SpecialType<>fsNaN then + do_error(101); + + if TDoubleRec(double_Inf).SpecialType<>fsInf then + do_error(102); + + if TDoubleRec(double_NInf).SpecialType<>fsNInf then + do_error(103); + + if TDoubleRec(double_Denormal).SpecialType<>fsDenormal then + do_error(104); + + if TDoubleRec(double_NDenormal).SpecialType<>fsNDenormal then + do_error(105); + + if TDoubleRec(double_Zero).SpecialType<>fsZero then + do_error(106); + + if TDoubleRec(double_NZero).SpecialType<>fsNZero then + do_error(107); + + if TDoubleRec(double_Positive).SpecialType<>fsPositive then + do_error(108); + + if TDoubleRec(double_Negative).SpecialType<>fsNegative then + do_error(109); + + if TDoubleRec(double_Positive).Mantissa<>$000F6A7A2955385E then + do_error(111); + + if TDoubleRec(double_Positive).Fraction<>4.15926535897931159980E-0001 then + do_error(112); + + if TDoubleRec(double_Positive).Exponent<>4 then + do_error(113); + + if TDoubleRec(double_Positive).Sign then + do_error(114); + + if TDoubleRec(double_Positive).Exp<>$403 then + do_error(115); + + if TDoubleRec(double_Negative).Mantissa<>$000F6A7A2955385E then + do_error(116); + + if TDoubleRec(double_Negative).Fraction<>-4.15926535897931159980E-0001 then + do_error(117); + + if TDoubleRec(double_Negative).Exponent<>4 then + do_error(118); + + if not(TDoubleRec(double_Negative).Sign) then + do_error(119); + + if TDoubleRec(double_Negative).Exp<>$403 then + do_error(120); +{$endif FPC_HAS_TYPE_DOUBLE} + +{$ifdef FPC_HAS_TYPE_DOUBLE} + single_NaN:=NaN; + + single_Inf:=Infinity; + + single_NInf:=-Infinity; + + single_Denormal:=1234.0; + TSingleRec(single_Denormal).Exp:=0; + + single_NDenormal:=-1234.0; + TSingleRec(single_NDenormal).Exp:=0; + + single_Zero:=0.0; + + single_NZero:=0.0; + TSingleRec(single_NZero).Sign:=true; + + single_Positive:=Pi*10; + + single_Negative:=-Pi*10; + + if TSingleRec(single_NaN).SpecialType<>fsNaN then + do_error(201); + + if TSingleRec(single_Inf).SpecialType<>fsInf then + do_error(202); + + if TSingleRec(single_NInf).SpecialType<>fsNInf then + do_error(203); + + if TSingleRec(single_Denormal).SpecialType<>fsDenormal then + do_error(204); + + if TSingleRec(single_NDenormal).SpecialType<>fsNDenormal then + do_error(205); + + if TSingleRec(single_Zero).SpecialType<>fsZero then + do_error(206); + + if TSingleRec(single_NZero).SpecialType<>fsNZero then + do_error(207); + + if TSingleRec(single_Positive).SpecialType<>fsPositive then + do_error(208); + + if TSingleRec(single_Negative).SpecialType<>fsNegative then + do_error(209); + + if TSingleRec(single_Positive).Mantissa<>$7b53d1 then + do_error(211); + + if TSingleRec(single_Positive).Fraction<>4.15925979614257812500E-0001 then + do_error(212); + + if TSingleRec(single_Positive).Exponent<>4 then + do_error(213); + + if TSingleRec(single_Positive).Sign then + do_error(214); + + if TSingleRec(single_Positive).Exp<>$83 then + do_error(215); + + if TSingleRec(single_Negative).Mantissa<>$7b53d1 then + do_error(216); + + if TSingleRec(single_Negative).Fraction<>-4.15925979614257812500E-0001 then + do_error(217); + + if TSingleRec(single_Negative).Exponent<>4 then + do_error(218); + + if not(TSingleRec(single_Negative).Sign) then + do_error(219); + + if TSingleRec(single_Negative).Exp<>$83 then + do_error(220); +{$endif FPC_HAS_TYPE_DOUBLE} + + writeln('ok'); +end. + diff --git a/tests/test/units/system/tio.pp b/tests/test/units/system/tio.pp index 5cbf2fb080..e8d3a23640 100644 --- a/tests/test/units/system/tio.pp +++ b/tests/test/units/system/tio.pp @@ -124,6 +124,24 @@ begin WriteLn('Passed!'); end; +procedure test_already_closed_close; +begin + Write('closing already closed file...(IOResult=103 expected) '); + Close(F); + test(IOResult, 103); + WriteLn('Passed!'); +end; + +procedure test_not_yet_open_close(name : string); +begin + Write('closing assigned only file...(IOResult=103 expected) '); + Assign(F,name); + test(IOResult,0); + Close(F); + test(IOResult, 103); + WriteLn('Passed!'); +end; + procedure test_rename(oldname, newname : shortstring); begin @@ -150,6 +168,7 @@ Begin {------------------------ create and play with a new file --------------------------} FillChar(readData,DATA_SIZE,0); + test_not_yet_open_close(FILE_NAME); test_do_open(FILE_NAME, MODE_REWRITE); test_do_write(DATA, DATA_SIZE); test_do_filesize(DATA_SIZE); @@ -174,6 +193,7 @@ Begin RunError(255); *) test_do_close; + test_already_closed_close; {------------------------ create and play with an old file --------------------------} FillChar(readData,DATA_SIZE,0); test_do_open(FILE_NAME2, MODE_REWRITE); diff --git a/tests/test/units/sysutils/tencodingtest.pp b/tests/test/units/sysutils/tencodingtest.pp index 04e7a61c49..2e88f2c4dd 100644 --- a/tests/test/units/sysutils/tencodingtest.pp +++ b/tests/test/units/sysutils/tencodingtest.pp @@ -44,6 +44,11 @@ begin SetString(S, PAnsiChar(Bytes), Length(Bytes)); if not CompareMem(Pointer(S), Pointer(Cp866String), Length(S)) then halt(1); + if StringCodePage(S)<>DefaultSystemCodePage then + halt(11); + SetString(Cp1251String,pchar(Cp1251String),length(Cp1251String)); + if StringCodePage(Cp1251String)<>1251 then + halt(12); U1 := Cp866Encoding.GetString(Bytes); U2 := TEncoding.Unicode.GetString(TEncoding.Convert(Cp866Encoding, TEncoding.Unicode, Bytes)); if U1 <> U2 then diff --git a/tests/test/units/variants/tw26370.pp b/tests/test/units/variants/tw26370.pp new file mode 100644 index 0000000000..ae816390a4 --- /dev/null +++ b/tests/test/units/variants/tw26370.pp @@ -0,0 +1,19 @@ +{$mode objfpc} +uses Variants; + +procedure test; +var + Bounds: Array [0..1] of TVarArrayBound; + V1, V2: Variant; +begin + Bounds[0].lowbound := 0; + Bounds[0].elementcount := 1; + Bounds[1].lowbound := 0; + Bounds[1].elementcount := 0; + V1 := VarArrayCreate(@Bounds, 2, varVariant); + V2 := V1; // <- Exception EVariantBadIndexError!!!!! +end; + +begin + test; +end.
\ No newline at end of file diff --git a/tests/test/units/variants/tw27044.pp b/tests/test/units/variants/tw27044.pp new file mode 100644 index 0000000000..7edaee5acf --- /dev/null +++ b/tests/test/units/variants/tw27044.pp @@ -0,0 +1,28 @@ +{ %norun } +{ Test that invoking methods on Variant that are function results, etc. + compiles without errors. } +{$mode delphi}{$H+} + +uses SysUtils,variants; + +type + TTest = class + private + FObj: IDispatch; + function GetObj: OleVariant; + public + property Obj: OleVariant read GetObj; + end; + +var tst: TTest; + +function TTest.GetObj: OleVariant; +begin + Result := FObj; +end; + +begin + variant(0).foo; + tst.Obj.bar; +end. + diff --git a/tests/test/uobjc41.pp b/tests/test/uobjc41.pp new file mode 100644 index 0000000000..e711b49ef1 --- /dev/null +++ b/tests/test/uobjc41.pp @@ -0,0 +1,23 @@ +{$mode objfpc} +{$modeswitch objectivec2} + +unit uobjc41; + +interface + +type + NSSubject = objcclass(NSObject) + end; + + MyCategory = objccategory(NSObject) + procedure key; message 'key'; + end; + +implementation + +procedure MyCategory.key; +begin +end; + +begin +end. diff --git a/tests/tstunits/Makefile b/tests/tstunits/Makefile index 39a1d5baa1..3c28a7e76e 100644 --- a/tests/tstunits/Makefile +++ b/tests/tstunits/Makefile @@ -1,9 +1,9 @@ # -# Don't edit, this file is generated by FPCMake Version 2.0.0 [2014-02-06 rev 26692] +# Don't edit, this file is generated by FPCMake Version 2.0.0 [2014-12-07 rev 29213] # 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 m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos powerpc-embedded powerpc-wii powerpc-aix sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-netbsd x86_64-solaris x86_64-openbsd x86_64-darwin x86_64-win64 x86_64-embedded arm-linux arm-palmos arm-darwin arm-wince arm-gba arm-nds arm-embedded arm-symbian arm-android powerpc64-linux powerpc64-darwin powerpc64-embedded powerpc64-aix avr-embedded armeb-linux armeb-embedded mips-linux mipsel-linux mipsel-android jvm-java jvm-android i8086-msdos -BSDs = freebsd netbsd openbsd darwin +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-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 +BSDs = freebsd netbsd openbsd darwin dragonfly UNIXs = linux $(BSDs) solaris qnx haiku aix LIMIT83fs = go32v2 os2 emx watcom msdos OSNeedsComspecToRunBatch = go32v2 watcom @@ -184,6 +184,12 @@ $(error When compiling for arm-embedded, a sub-architecture (e.g. SUBARCH=armv4t endif override FPCOPT+=-Cp$(SUBARCH) endif +ifeq ($(FULL_TARGET),mipsel-embedded) +ifeq ($(SUBARCH),) +$(error When compiling for mipsel-embedded, a sub-architecture (e.g. SUBARCH=pic32mx) must be defined) +endif +override FPCOPT+=-Cp$(SUBARCH) +endif ifneq ($(findstring $(OS_SOURCE),$(LIMIT83fs)),) TARGETSUFFIX=$(OS_TARGET) SOURCESUFFIX=$(OS_SOURCE) @@ -388,6 +394,9 @@ endif ifeq ($(FULL_TARGET),i386-android) override CLEAN_UNITS+=erroru popuperr ptest endif +ifeq ($(FULL_TARGET),i386-aros) +override CLEAN_UNITS+=erroru popuperr ptest +endif ifeq ($(FULL_TARGET),m68k-linux) override CLEAN_UNITS+=erroru popuperr ptest endif @@ -475,6 +484,9 @@ endif ifeq ($(FULL_TARGET),x86_64-embedded) override CLEAN_UNITS+=erroru popuperr ptest endif +ifeq ($(FULL_TARGET),x86_64-dragonfly) +override CLEAN_UNITS+=erroru popuperr ptest +endif ifeq ($(FULL_TARGET),arm-linux) override CLEAN_UNITS+=erroru popuperr ptest endif @@ -529,6 +541,9 @@ endif ifeq ($(FULL_TARGET),mipsel-linux) override CLEAN_UNITS+=erroru popuperr ptest endif +ifeq ($(FULL_TARGET),mipsel-embedded) +override CLEAN_UNITS+=erroru popuperr ptest +endif ifeq ($(FULL_TARGET),mipsel-android) override CLEAN_UNITS+=erroru popuperr ptest endif @@ -611,6 +626,9 @@ endif ifeq ($(FULL_TARGET),i386-android) override COMPILER_TARGETDIR+=$(TARGETSUFFIX) endif +ifeq ($(FULL_TARGET),i386-aros) +override COMPILER_TARGETDIR+=$(TARGETSUFFIX) +endif ifeq ($(FULL_TARGET),m68k-linux) override COMPILER_TARGETDIR+=$(TARGETSUFFIX) endif @@ -698,6 +716,9 @@ endif ifeq ($(FULL_TARGET),x86_64-embedded) override COMPILER_TARGETDIR+=$(TARGETSUFFIX) endif +ifeq ($(FULL_TARGET),x86_64-dragonfly) +override COMPILER_TARGETDIR+=$(TARGETSUFFIX) +endif ifeq ($(FULL_TARGET),arm-linux) override COMPILER_TARGETDIR+=$(TARGETSUFFIX) endif @@ -752,6 +773,9 @@ endif ifeq ($(FULL_TARGET),mipsel-linux) override COMPILER_TARGETDIR+=$(TARGETSUFFIX) endif +ifeq ($(FULL_TARGET),mipsel-embedded) +override COMPILER_TARGETDIR+=$(TARGETSUFFIX) +endif ifeq ($(FULL_TARGET),mipsel-android) override COMPILER_TARGETDIR+=$(TARGETSUFFIX) endif @@ -1006,6 +1030,12 @@ EXEEXT= HASSHAREDLIB=1 SHORTSUFFIX=lnx endif +ifeq ($(OS_TARGET),dragonfly) +BATCHEXT=.sh +EXEEXT= +HASSHAREDLIB=1 +SHORTSUFFIX=df +endif ifeq ($(OS_TARGET),freebsd) BATCHEXT=.sh EXEEXT= @@ -1051,6 +1081,11 @@ EXEEXT= SHAREDLIBEXT=.library SHORTSUFFIX=amg endif +ifeq ($(OS_TARGET),aros) +EXEEXT= +SHAREDLIBEXT=.library +SHORTSUFFIX=aros +endif ifeq ($(OS_TARGET),morphos) EXEEXT= SHAREDLIBEXT=.library @@ -1515,7 +1550,7 @@ endif ifdef CREATESHARED override FPCOPT+=-Cg endif -ifneq ($(findstring $(OS_TARGET),freebsd openbsd netbsd linux solaris),) +ifneq ($(findstring $(OS_TARGET),dragonfly freebsd openbsd netbsd linux solaris),) ifeq ($(CPU_TARGET),x86_64) override FPCOPT+=-Cg endif @@ -1545,17 +1580,23 @@ ifdef ACROSSCOMPILE override FPCOPT+=$(CROSSOPT) endif override COMPILER:=$(strip $(FPC) $(FPCOPT)) -ifeq (,$(findstring -s ,$(COMPILER))) +ifneq (,$(findstring -sh ,$(COMPILER))) +UseEXECPPAS=1 +endif +ifneq (,$(findstring -s ,$(COMPILER))) +ifeq ($(FULL_SOURCE),$(FULL_TARGET)) +UseEXECPPAS=1 +endif +endif +ifneq ($(UseEXECPPAS),1) EXECPPAS= else -ifeq ($(FULL_SOURCE),$(FULL_TARGET)) ifdef RUNBATCH EXECPPAS:=@$(RUNBATCH) $(PPAS) else EXECPPAS:=@$(PPAS) endif endif -endif ifdef TARGET_RSTS override RSTFILES=$(addsuffix $(RSTEXT),$(TARGET_RSTS)) override CLEANRSTFILES+=$(RSTFILES) diff --git a/tests/utils/Makefile b/tests/utils/Makefile index 0847de00c9..dd3b6b4537 100644 --- a/tests/utils/Makefile +++ b/tests/utils/Makefile @@ -1,9 +1,9 @@ # -# Don't edit, this file is generated by FPCMake Version 2.0.0 [2014-02-06 rev 26692] +# Don't edit, this file is generated by FPCMake Version 2.0.0 [2014-12-07 rev 29213] # 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 m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos powerpc-embedded powerpc-wii powerpc-aix sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-netbsd x86_64-solaris x86_64-openbsd x86_64-darwin x86_64-win64 x86_64-embedded arm-linux arm-palmos arm-darwin arm-wince arm-gba arm-nds arm-embedded arm-symbian arm-android powerpc64-linux powerpc64-darwin powerpc64-embedded powerpc64-aix avr-embedded armeb-linux armeb-embedded mips-linux mipsel-linux mipsel-android jvm-java jvm-android i8086-msdos -BSDs = freebsd netbsd openbsd darwin +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-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 +BSDs = freebsd netbsd openbsd darwin dragonfly UNIXs = linux $(BSDs) solaris qnx haiku aix LIMIT83fs = go32v2 os2 emx watcom msdos OSNeedsComspecToRunBatch = go32v2 watcom @@ -184,6 +184,12 @@ $(error When compiling for arm-embedded, a sub-architecture (e.g. SUBARCH=armv4t endif override FPCOPT+=-Cp$(SUBARCH) endif +ifeq ($(FULL_TARGET),mipsel-embedded) +ifeq ($(SUBARCH),) +$(error When compiling for mipsel-embedded, a sub-architecture (e.g. SUBARCH=pic32mx) must be defined) +endif +override FPCOPT+=-Cp$(SUBARCH) +endif ifneq ($(findstring $(OS_SOURCE),$(LIMIT83fs)),) TARGETSUFFIX=$(OS_TARGET) SOURCESUFFIX=$(OS_SOURCE) @@ -388,6 +394,9 @@ endif ifeq ($(FULL_TARGET),i386-android) override TARGET_PROGRAMS+=dotest fptime fail testfail digest concat $(DBDIGEST) endif +ifeq ($(FULL_TARGET),i386-aros) +override TARGET_PROGRAMS+=dotest fptime fail testfail digest concat $(DBDIGEST) +endif ifeq ($(FULL_TARGET),m68k-linux) override TARGET_PROGRAMS+=dotest fptime fail testfail digest concat $(DBDIGEST) endif @@ -475,6 +484,9 @@ endif ifeq ($(FULL_TARGET),x86_64-embedded) override TARGET_PROGRAMS+=dotest fptime fail testfail digest concat $(DBDIGEST) endif +ifeq ($(FULL_TARGET),x86_64-dragonfly) +override TARGET_PROGRAMS+=dotest fptime fail testfail digest concat $(DBDIGEST) +endif ifeq ($(FULL_TARGET),arm-linux) override TARGET_PROGRAMS+=dotest fptime fail testfail digest concat $(DBDIGEST) endif @@ -529,6 +541,9 @@ endif ifeq ($(FULL_TARGET),mipsel-linux) override TARGET_PROGRAMS+=dotest fptime fail testfail digest concat $(DBDIGEST) endif +ifeq ($(FULL_TARGET),mipsel-embedded) +override TARGET_PROGRAMS+=dotest fptime fail testfail digest concat $(DBDIGEST) +endif ifeq ($(FULL_TARGET),mipsel-android) override TARGET_PROGRAMS+=dotest fptime fail testfail digest concat $(DBDIGEST) endif @@ -610,6 +625,9 @@ endif ifeq ($(FULL_TARGET),i386-android) override CLEAN_PROGRAMS+=dbdigest dbconfig endif +ifeq ($(FULL_TARGET),i386-aros) +override CLEAN_PROGRAMS+=dbdigest dbconfig +endif ifeq ($(FULL_TARGET),m68k-linux) override CLEAN_PROGRAMS+=dbdigest dbconfig endif @@ -697,6 +715,9 @@ endif ifeq ($(FULL_TARGET),x86_64-embedded) override CLEAN_PROGRAMS+=dbdigest dbconfig endif +ifeq ($(FULL_TARGET),x86_64-dragonfly) +override CLEAN_PROGRAMS+=dbdigest dbconfig +endif ifeq ($(FULL_TARGET),arm-linux) override CLEAN_PROGRAMS+=dbdigest dbconfig endif @@ -751,6 +772,9 @@ endif ifeq ($(FULL_TARGET),mipsel-linux) override CLEAN_PROGRAMS+=dbdigest dbconfig endif +ifeq ($(FULL_TARGET),mipsel-embedded) +override CLEAN_PROGRAMS+=dbdigest dbconfig +endif ifeq ($(FULL_TARGET),mipsel-android) override CLEAN_PROGRAMS+=dbdigest dbconfig endif @@ -1006,6 +1030,12 @@ EXEEXT= HASSHAREDLIB=1 SHORTSUFFIX=lnx endif +ifeq ($(OS_TARGET),dragonfly) +BATCHEXT=.sh +EXEEXT= +HASSHAREDLIB=1 +SHORTSUFFIX=df +endif ifeq ($(OS_TARGET),freebsd) BATCHEXT=.sh EXEEXT= @@ -1051,6 +1081,11 @@ EXEEXT= SHAREDLIBEXT=.library SHORTSUFFIX=amg endif +ifeq ($(OS_TARGET),aros) +EXEEXT= +SHAREDLIBEXT=.library +SHORTSUFFIX=aros +endif ifeq ($(OS_TARGET),morphos) EXEEXT= SHAREDLIBEXT=.library @@ -1515,7 +1550,7 @@ endif ifdef CREATESHARED override FPCOPT+=-Cg endif -ifneq ($(findstring $(OS_TARGET),freebsd openbsd netbsd linux solaris),) +ifneq ($(findstring $(OS_TARGET),dragonfly freebsd openbsd netbsd linux solaris),) ifeq ($(CPU_TARGET),x86_64) override FPCOPT+=-Cg endif @@ -1545,17 +1580,23 @@ ifdef ACROSSCOMPILE override FPCOPT+=$(CROSSOPT) endif override COMPILER:=$(strip $(FPC) $(FPCOPT)) -ifeq (,$(findstring -s ,$(COMPILER))) +ifneq (,$(findstring -sh ,$(COMPILER))) +UseEXECPPAS=1 +endif +ifneq (,$(findstring -s ,$(COMPILER))) +ifeq ($(FULL_SOURCE),$(FULL_TARGET)) +UseEXECPPAS=1 +endif +endif +ifneq ($(UseEXECPPAS),1) EXECPPAS= else -ifeq ($(FULL_SOURCE),$(FULL_TARGET)) ifdef RUNBATCH EXECPPAS:=@$(RUNBATCH) $(PPAS) else EXECPPAS:=@$(PPAS) endif endif -endif .PHONY: fpc_exes ifndef CROSSINSTALL ifneq ($(TARGET_PROGRAMS),) diff --git a/tests/utils/avx/asmtestgenerator.pas b/tests/utils/avx/asmtestgenerator.pas index 47c586d1dc..b642c0f712 100644 --- a/tests/utils/avx/asmtestgenerator.pas +++ b/tests/utils/avx/asmtestgenerator.pas @@ -28,7 +28,8 @@ uses BaseList, Classes; type TOpType = (otUnknown, otXMMReg, otXMMRM, otXMMRM16, otXMMRM8, otYMMReg, otYMMRM, otEAX, otRAX, otMem32, - otMem8, otMem16, otMem64, otMem128, otMem256, otREG64, otREG32, otRM32, otRM64, otIMM8); + otMem8, otMem16, otMem64, otMem128, otMem256, otREG64, otREG32, otRM32, otRM64, otIMM8, + otXMEM32, otXMEM64, otYMEM32, otYMEM64); TOperandListItem = class(TObject) private @@ -58,6 +59,8 @@ type end; + { TAsmTestGenerator } + TAsmTestGenerator = class(TObject) private FReg32Base : TStringList; @@ -66,10 +69,15 @@ type FReg64Index : TStringList; FReg6432Base : TStringList; FReg6432Index : TStringList; + FReg32XMMIndex : TStringList; + FReg32YMMIndex : TStringList; + FReg64XMMIndex : TStringList; + FReg64YMMIndex : TStringList; Fx64: boolean; procedure MemRegBaseIndexCombi(const aPrefix: String; aSLBaseReg, aSLIndexReg, aRList: TStringList); + procedure VectorMemRegBaseIndexCombi(const aPrefix: String; aSLBaseReg, aSLIndexReg, aRList: TStringList); function InternalCalcTestData(const aInst, aOp1, aOp2, aOp3, aOp4: String): TStringList; public @@ -583,6 +591,76 @@ begin Item.Values.Add('0'); end + else if AnsiSameText(sl_Operand, 'XMEM32') then + begin + Item.OpNumber := il_Op; + Item.OpTyp := otXMEM32; + Item.OpActive := true; + + if UsePrefix then sl_Prefix := 'oword '; + + if x64 then + begin + VectorMemRegBaseIndexCombi(sl_prefix, FReg64Base, FReg64XMMIndex, Item.Values); + end + else + begin + VectorMemRegBaseIndexCombi(sl_prefix, FReg32Base, FReg32XMMIndex, Item.Values); + end; + end + else if AnsiSameText(sl_Operand, 'XMEM64') then + begin + Item.OpNumber := il_Op; + Item.OpTyp := otXMEM64; + Item.OpActive := true; + + if UsePrefix then sl_Prefix := 'oword '; + + if x64 then + begin + VectorMemRegBaseIndexCombi(sl_prefix, FReg64Base, FReg64XMMIndex, Item.Values); + end + else + begin + VectorMemRegBaseIndexCombi(sl_prefix, FReg32Base, FReg32XMMIndex, Item.Values); + end; + end + else if AnsiSameText(sl_Operand, 'YMEM32') then + begin + Item.OpNumber := il_Op; + Item.OpTyp := otYMEM32; + Item.OpActive := true; + + if UsePrefix then sl_Prefix := 'yword '; + + if x64 then + begin + VectorMemRegBaseIndexCombi(sl_prefix, FReg64Base, FReg64YMMIndex, Item.Values); + end + else + begin + VectorMemRegBaseIndexCombi(sl_prefix, FReg32Base, FReg32YMMIndex, Item.Values); + end; + end + else if AnsiSameText(sl_Operand, 'YMEM64') then + begin + Item.OpNumber := il_Op; + Item.OpTyp := otYMEM64; + Item.OpActive := true; + + if UsePrefix then sl_Prefix := 'yword '; + + if x64 then + begin + VectorMemRegBaseIndexCombi(sl_prefix, FReg64Base, FReg64YMMIndex, Item.Values); + end + else + begin + VectorMemRegBaseIndexCombi(sl_prefix, FReg32Base, FReg32YMMIndex, Item.Values); + end; + end + + else begin Item.OpNumber := il_Op; @@ -590,7 +668,8 @@ begin Item.OpActive := false; Item.Values.Add(''); - end; + end + end; sl_RegCombi := ''; @@ -755,6 +834,11 @@ begin FReg64Index := TStringList.Create; FReg6432Base := TStringList.Create; FReg6432Index := TStringList.Create; + FReg32XMMIndex := TStringList.Create; + FReg32YMMIndex := TStringList.Create; + FReg64XMMIndex := TStringList.Create; + FReg64YMMIndex := TStringList.Create; + FReg32Base.Add('EAX'); FReg32Base.Add('EBX'); @@ -840,6 +924,60 @@ begin FReg6432Index.Add('R13D'); FReg6432Index.Add('R14D'); FReg6432Index.Add('R15D'); + + FReg32XMMIndex.ADD('XMM0'); + FReg32XMMIndex.ADD('XMM1'); + FReg32XMMIndex.ADD('XMM2'); + FReg32XMMIndex.ADD('XMM3'); + FReg32XMMIndex.ADD('XMM4'); + FReg32XMMIndex.ADD('XMM5'); + FReg32XMMIndex.ADD('XMM6'); + FReg32XMMIndex.ADD('XMM7'); + + FReg32YMMIndex.ADD('YMM0'); + FReg32YMMIndex.ADD('YMM1'); + FReg32YMMIndex.ADD('YMM2'); + FReg32YMMIndex.ADD('YMM3'); + FReg32YMMIndex.ADD('YMM4'); + FReg32YMMIndex.ADD('YMM5'); + FReg32YMMIndex.ADD('YMM6'); + FReg32YMMIndex.ADD('YMM7'); + + FReg64XMMIndex.ADD('XMM0'); + FReg64XMMIndex.ADD('XMM1'); + FReg64XMMIndex.ADD('XMM2'); + FReg64XMMIndex.ADD('XMM3'); + FReg64XMMIndex.ADD('XMM4'); + FReg64XMMIndex.ADD('XMM5'); + FReg64XMMIndex.ADD('XMM6'); + FReg64XMMIndex.ADD('XMM7'); + FReg64XMMIndex.ADD('XMM8'); + FReg64XMMIndex.ADD('XMM9'); + FReg64XMMIndex.ADD('XMM10'); + FReg64XMMIndex.ADD('XMM11'); + FReg64XMMIndex.ADD('XMM12'); + FReg64XMMIndex.ADD('XMM13'); + FReg64XMMIndex.ADD('XMM14'); + FReg64XMMIndex.ADD('XMM15'); + + + FReg64YMMIndex.ADD('YMM0'); + FReg64YMMIndex.ADD('YMM1'); + FReg64YMMIndex.ADD('YMM2'); + FReg64YMMIndex.ADD('YMM3'); + FReg64YMMIndex.ADD('YMM4'); + FReg64YMMIndex.ADD('YMM5'); + FReg64YMMIndex.ADD('YMM6'); + FReg64YMMIndex.ADD('YMM7'); + FReg64YMMIndex.ADD('YMM8'); + FReg64YMMIndex.ADD('YMM9'); + FReg64YMMIndex.ADD('YMM10'); + FReg64YMMIndex.ADD('YMM11'); + FReg64YMMIndex.ADD('YMM12'); + FReg64YMMIndex.ADD('YMM13'); + FReg64YMMIndex.ADD('YMM14'); + FReg64YMMIndex.ADD('YMM15'); + end; destructor TAsmTestGenerator.Destroy; @@ -851,6 +989,11 @@ begin FreeAndNil(FReg6432Base); FreeAndNil(FReg6432Index); + FreeAndNil(FReg32XMMIndex); + FreeAndNil(FReg32YMMIndex); + FreeAndNil(FReg64XMMIndex); + FreeAndNil(FReg64YMMIndex); + inherited; end; @@ -880,6 +1023,51 @@ begin end; end; +procedure TAsmTestGenerator.VectorMemRegBaseIndexCombi(const aPrefix: String; + aSLBaseReg, aSLIndexReg, aRList: TStringList); +var + il_Base: integer; + il_Index: integer; +begin + + //for il_Index := 0 to aSLIndexReg.Count - 1 do + //begin + // aRList.Add(format(aPrefix + '[%s]', [aSLIndexReg[il_Index]])); + // + // aRList.Add(format(aPrefix + '[%s * 2]', [aSLIndexReg[il_Index]])); + // aRList.Add(format(aPrefix + '[%s * 4]', [aSLIndexReg[il_Index]])); + // aRList.Add(format(aPrefix + '[%s * 8]', [aSLIndexReg[il_Index]])); + // + // aRList.Add(format(aPrefix + '[%s * 2 + 16]', [aSLIndexReg[il_Index]])); + // aRList.Add(format(aPrefix + '[%s * 4 + 32]', [aSLIndexReg[il_Index]])); + // aRList.Add(format(aPrefix + '[%s * 8 + 48]', [aSLIndexReg[il_Index]])); + //end; + + + for il_Base := 0 to aSLBaseReg.Count - 1 do + begin + //aRList.Add(format(aPrefix + '[%s]', [aSLBaseReg[il_Base]])); + + for il_Index := 0 to aSLIndexReg.Count - 1 do + begin + aRList.Add(format(aPrefix + '[%s + %s]', [aSLBaseReg[il_Base], aSLIndexReg[il_Index]])); + + aRList.Add(format(aPrefix + '[%s + %s * 2]', [aSLBaseReg[il_Base], aSLIndexReg[il_Index]])); + aRList.Add(format(aPrefix + '[%s + %s * 4]', [aSLBaseReg[il_Base], aSLIndexReg[il_Index]])); + aRList.Add(format(aPrefix + '[%s + %s * 8]', [aSLBaseReg[il_Base], aSLIndexReg[il_Index]])); + + aRList.Add(format(aPrefix + '[%s + %s * 2 + 16]', [aSLBaseReg[il_Base], aSLIndexReg[il_Index]])); + aRList.Add(format(aPrefix + '[%s + %s * 4 + 32]', [aSLBaseReg[il_Base], aSLIndexReg[il_Index]])); + aRList.Add(format(aPrefix + '[%s + %s * 8 + 48]', [aSLBaseReg[il_Base], aSLIndexReg[il_Index]])); + + + aRList.Add(format(aPrefix + '[%s + %s]', [aSLIndexReg[il_Index], aSLBaseReg[il_Base]])); + + aRList.Add(format(aPrefix + '[%s + %s + 16]', [aSLIndexReg[il_Index], aSLBaseReg[il_Base]])); + end; + end; +end; + class procedure TAsmTestGenerator.CalcTestData(aX64: boolean; const aInst, aOp1, aOp2, aOp3, aOp4: String; aSL: TStringList); var diff --git a/tests/utils/avx/avxopcodes.pas b/tests/utils/avx/avxopcodes.pas index ade1651c77..bae89e0ec0 100644 --- a/tests/utils/avx/avxopcodes.pas +++ b/tests/utils/avx/avxopcodes.pas @@ -773,6 +773,36 @@ begin FOpCodeList.Add('VFNMSUB132SS,1,1,XMMREG,XMMREG,XMMRM,'); FOpCodeList.Add('VFNMSUB213SS,1,1,XMMREG,XMMREG,XMMRM,'); FOpCodeList.Add('VFNMSUB231SS,1,1,XMMREG,XMMREG,XMMRM,'); + + + FOpCodeList.Add('VGATHERDPD,1,1,XMMREG,XMEM32,XMMREG,'); + FOpCodeList.Add('VGATHERDPD,1,1,YMMREG,XMEM32,YMMREG,'); + + FOpCodeList.Add('VGATHERQPD,1,1,XMMREG,XMEM64,XMMREG,'); + FOpCodeList.Add('VGATHERQPD,1,1,YMMREG,YMEM64,YMMREG,'); + + + FOpCodeList.Add('VGATHERDPS,1,1,XMMREG,XMEM32,XMMREG,'); + FOpCodeList.Add('VGATHERDPS,1,1,YMMREG,YMEM32,YMMREG,'); + + FOpCodeList.Add('VGATHERQPS,1,1,XMMREG,XMEM64,XMMREG,'); + FOpCodeList.Add('VGATHERQPS,1,1,XMMREG,YMEM64,XMMREG,'); + + + + FOpCodeList.Add('VPGATHERDD,1,1,XMMREG,XMEM32,XMMREG,'); + FOpCodeList.Add('VPGATHERDD,1,1,YMMREG,YMEM32,YMMREG,'); + + FOpCodeList.Add('VPGATHERQD,1,1,XMMREG,XMEM64,XMMREG,'); + FOpCodeList.Add('VPGATHERQD,1,1,XMMREG,YMEM64,XMMREG,'); + + + FOpCodeList.Add('VPGATHERDQ,1,1,XMMREG,XMEM32,XMMREG,'); + FOpCodeList.Add('VPGATHERDQ,1,1,YMMREG,XMEM32,YMMREG,'); + + FOpCodeList.Add('VPGATHERQQ,1,1,XMMREG,XMEM64,XMMREG,'); + FOpCodeList.Add('VPGATHERQQ,1,1,YMMREG,YMEM64,YMMREG,'); + end; function TAVXTestGenerator.InternalMakeTestFiles(aX64: boolean; aDestPath, aFileExt: String; diff --git a/tests/utils/dbconfig.pp b/tests/utils/dbconfig.pp index f2f37cc5ae..992b9caf9c 100644 --- a/tests/utils/dbconfig.pp +++ b/tests/utils/dbconfig.pp @@ -2,7 +2,7 @@ This file is part of the Free Pascal test suite. Copyright (c) 2002 by the Free Pascal development team. - This program iupdates TESTCONFIG anf TESTRUNHISTORY tables + This program updates TESTCONFIG anf TESTRUNHISTORY tables with the last tests run. See the file COPYING.FPC, included in this distribution, @@ -24,7 +24,7 @@ program dbconfig; uses sysutils,teststr,testu,tresults, - mysql55dyn,dbtests; + sqldb,dbtests; Var @@ -451,7 +451,7 @@ var qry : string; firstRunID, lastRunID,PrevRunID : Integer; RunCount : Integer; - res : TQueryResult; + res : TSQLQuery; AddCount : boolean; begin AddCount:=false; @@ -463,7 +463,7 @@ begin Verbose(V_Warning,format('FirstRunID changed from %d to %d',[FirstRunID,TestRunID])); qry:=format('UPDATE TESTCONFIG SET TCONF_FIRST_RUN_FK=%d WHERE TCONF_ID=%d', [TestRunID,ConfigID]); - if RunQuery(qry,res) then + if OpenQuery(qry,res,false) then FreeQueryResult(res) else Verbose(V_Warning,'Update of LastRunID failed'); @@ -474,7 +474,7 @@ begin begin qry:=format('UPDATE TESTCONFIG SET TCONF_LAST_RUN_FK=%d WHERE TCONF_ID=%d', [TestRunID,ConfigID]); - if RunQuery(qry,res) then + if OpenQuery(qry,res,false) then FreeQueryResult(res) else Verbose(V_Warning,'Update of LastRunID failed'); @@ -487,7 +487,7 @@ begin begin qry:=format('UPDATE TESTCONFIG SET TCONF_NEW_RUN_FK=%d WHERE TCONF_ID=%d', [TestRunID,ConfigID]); - if RunQuery(qry,res) then + if OpenQuery(qry,res,false) then FreeQueryResult(res) else Verbose(V_Warning,'Update of LastRunID failed'); @@ -504,7 +504,7 @@ begin Inc(RunCount); qry:=format('UPDATE TESTCONFIG SET TCONF_COUNT_RUNS=%d WHERE TCONF_ID=%d', [RunCount,ConfigID]); - if RunQuery(qry,res) then + if OpenQuery(qry,res,false) then FreeQueryResult(res) else Verbose(V_Warning,'Update of TU_COUNT_RUNS failed'); @@ -536,7 +536,7 @@ begin AddTestHistoryEntry(TestRunID,0); end; -Procedure InsertRunsIntoConfigAndHistory(var GlobalRes : TQueryResult); +Procedure InsertRunsIntoConfigAndHistory(var GlobalRes : TSQLQuery); var i,fid, num_fields : Integer; @@ -544,9 +544,10 @@ var s : string; runid,previd : Integer; begin - with GlobalRes^ do + with GlobalRes do begin - num_fields:=mysql_num_fields(GlobalRes); + num_fields:=FieldCount; + First; Writeln('Row count=',row_count); for i:=0 to row_count-1 do begin @@ -571,20 +572,20 @@ begin end; end; -Procedure GetAllTestRuns(var GlobalRes : TQueryResult); +Procedure GetAllTestRuns(var GlobalRes : TSQLQuery); var qry : string; begin qry:='SELECT * FROM TESTRUN ORDER BY TU_ID'; if OffsetString<>'' then qry:=qry+' LIMIT 1000 OFFSET '+OffsetString; - if not RunQuery(qry,GlobalRes) then + if not OpenQuery(qry,GlobalRes,false) then Verbose(V_Warning,'Failed to fetch testrun content'); end; var - GlobalRes : TQueryResult; + GlobalRes : TSQLQuery; begin ProcessConfigFile('dbdigest.cfg'); diff --git a/tests/utils/dbdigest.pp b/tests/utils/dbdigest.pp index 3f042079c2..1fce9ec2b3 100644 --- a/tests/utils/dbdigest.pp +++ b/tests/utils/dbdigest.pp @@ -81,7 +81,8 @@ TConfigOpt = ( coComment, coTestSrcDir, coRelSrcDir, - coVerbose + coVerbose, + coSQL ); { Additional options only for dbdigest.cfg file } @@ -115,7 +116,8 @@ ConfigStrings : Array [TConfigOpt] of string = ( 'comment', 'testsrcdir', 'relsrcdir', - 'verbose' + 'verbose', + 'sql' ); ConfigOpts : Array[TConfigOpt] of char =( @@ -136,7 +138,8 @@ ConfigOpts : Array[TConfigOpt] of char =( 'C', { coComment } 'S', { coTestSrcDir } 'r', { coRelSrcDir } - 'V' { coVerbose } + 'V', { coVerbose } + 'Q' { coSQL } ); ConfigAddStrings : Array [TConfigAddOpt] of string = ( @@ -215,6 +218,7 @@ begin coCPU : TestCPU:=Value; coCategory : TestCategory:=Value; coVersion : TestVersion:=Value; + coSQL : DoSQL:=True; coDate : begin { Formated like YYYYMMDDhhmm } @@ -369,7 +373,13 @@ begin Verbose(V_ERROR,'Illegal command-line option : '+O) else begin - Found:=(I<ParamCount); + if c=coverbose then + begin + Found:=true; + o:=''; + end + else + Found:=(I<ParamCount); If Not found then Verbose(V_ERROR,'Option requires argument : '+O) else @@ -533,6 +543,7 @@ begin begin readln(logfile,line); fullline:=line; + ts:=stFailedToCompile; If analyse(line,TS) then begin Verbose(V_NORMAL,'Analysing result for test '+Line); @@ -599,29 +610,27 @@ procedure UpdateTestRun; var i : TTestStatus; qry : string; - res : TQueryResult; begin qry:='UPDATE TESTRUN SET '; for i:=low(TTestStatus) to high(TTestStatus) do qry:=qry+format('%s=%d, ',[SQLField[i],StatusCount[i]]); if TestCompilerDate<>'' then - qry:=qry+format('%s="%s", ',[ConfigAddCols[coCompilerDate],EscapeSQL(TestCompilerDate)]); + qry:=qry+format('%s=''%s'', ',[ConfigAddCols[coCompilerDate],EscapeSQL(TestCompilerDate)]); if TestCompilerFullVersion<>'' then - qry:=qry+format('%s="%s", ',[ConfigAddCols[coCompilerFullVersion],EscapeSQL(TestCompilerFullVersion)]); + qry:=qry+format('%s=''%s'', ',[ConfigAddCols[coCompilerFullVersion],EscapeSQL(TestCompilerFullVersion)]); if TestSvnCompilerRevision<>'' then - qry:=qry+format('%s="%s", ',[ConfigAddCols[coSvnCompilerRevision],EscapeSQL(TestSvnCompilerRevision)]); + qry:=qry+format('%s=''%s'', ',[ConfigAddCols[coSvnCompilerRevision],EscapeSQL(TestSvnCompilerRevision)]); if TestSvnTestsRevision<>'' then - qry:=qry+format('%s="%s", ',[ConfigAddCols[coSvnTestsRevision],EscapeSQL(TestSvnTestsRevision)]); + qry:=qry+format('%s=''%s'', ',[ConfigAddCols[coSvnTestsRevision],EscapeSQL(TestSvnTestsRevision)]); if TestSvnRTLRevision<>'' then - qry:=qry+format('%s="%s", ',[ConfigAddCols[coSvnRTLRevision],EscapeSQL(TestSvnRTLRevision)]); + qry:=qry+format('%s=''%s'', ',[ConfigAddCols[coSvnRTLRevision],EscapeSQL(TestSvnRTLRevision)]); if TestSvnPackagesRevision<>'' then - qry:=qry+format('%s="%s", ',[ConfigAddCols[coSvnPackagesRevision],EscapeSQL(TestSvnPackagesRevision)]); + qry:=qry+format('%s=''%s'', ',[ConfigAddCols[coSvnPackagesRevision],EscapeSQL(TestSvnPackagesRevision)]); - qry:=qry+format('TU_SUBMITTER="%s", TU_MACHINE="%s", TU_COMMENT="%s", TU_DATE="%s"',[Submitter,Machine,Comment,SqlDate(TestDate)]); + qry:=qry+format('TU_SUBMITTER=''%s'', TU_MACHINE=''%s'', TU_COMMENT=''%s'', TU_DATE=''%s''',[Submitter,Machine,Comment,SqlDate(TestDate)]); qry:=qry+' WHERE TU_ID='+format('%d',[TestRunID]); - if RunQuery(Qry,res) then - FreeQueryResult(Res); + ExecuteQuery(Qry,False); end; function GetTestConfigId : Integer; @@ -633,9 +642,9 @@ begin 'TCONF_OS_FK=%d AND ' + 'TCONF_VERSION_FK=%d AND ' + 'TCONF_CATEGORY_FK=%d AND ' + - 'TCONF_SUBMITTER="%s" AND ' + - 'TCONF_MACHINE="%s" AND ' + - 'TCONF_COMMENT="%s" '; + 'TCONF_SUBMITTER=''%s'' AND ' + + 'TCONF_MACHINE=''%s'' AND ' + + 'TCONF_COMMENT=''%s'' '; ConfigID:=IDQuery(format(qry,[TestCPUID, TestOSID, TestVersionID, TestCategoryID, Submitter, Machine, Comment])); GetTestConfigID:=ConfigID; @@ -646,7 +655,6 @@ var qry : string; firstRunID, lastRunID,PrevRunID : Integer; RunCount : Integer; - res : TQueryResult; AddCount : boolean; begin @@ -659,9 +667,7 @@ begin Verbose(V_Warning,format('FirstRunID changed from %d to %d',[FirstRunID,TestRunID])); qry:=format('UPDATE TESTCONFIG SET TCONF_FIRST_RUN_FK=%d WHERE TCONF_ID=%d', [TestRunID,ConfigID]); - if RunQuery(qry,res) then - FreeQueryResult(res) - else + if Not ExecuteQuery(qry,False) then Verbose(V_Warning,'Update of LastRunID failed'); end; qry:=format('SELECT TCONF_LAST_RUN_FK FROM TESTCONFIG WHERE TCONF_ID=%d',[ConfigID]); @@ -670,9 +676,7 @@ begin begin qry:=format('UPDATE TESTCONFIG SET TCONF_LAST_RUN_FK=%d WHERE TCONF_ID=%d', [TestRunID,ConfigID]); - if RunQuery(qry,res) then - FreeQueryResult(res) - else + if not ExecuteQuery(qry,False) then Verbose(V_Warning,'Update of LastRunID failed'); end else @@ -681,14 +685,12 @@ begin PrevRunID:=IDQuery(qry); if TestRunID<>PrevRunID then begin - qry:=format('UPDATE TESTCONFIG SET TCONF_NEW_RUN_FK=%d WHERE TCONF_ID=%d', - [TestRunID,ConfigID]); - if RunQuery(qry,res) then - FreeQueryResult(res) - else - Verbose(V_Warning,'Update of LastRunID failed'); - AddTestHistoryEntry(TestRunID,PrevRunID); - AddCount:=true; + qry:=format('UPDATE TESTCONFIG SET TCONF_NEW_RUN_FK=%d WHERE TCONF_ID=%d', + [TestRunID,ConfigID]); + if not ExecuteQuery(qry,False) then + Verbose(V_Warning,'Update of LastRunID failed'); + AddTestHistoryEntry(TestRunID,PrevRunID); + AddCount:=true; end else Verbose(V_Warning,'TestRunID is equal to last!'); @@ -700,9 +702,7 @@ begin Inc(RunCount); qry:=format('UPDATE TESTCONFIG SET TCONF_COUNT_RUNS=%d WHERE TCONF_ID=%d', [RunCount,ConfigID]); - if RunQuery(qry,res) then - FreeQueryResult(res) - else + if not ExecuteQuery(qry,False) then Verbose(V_Warning,'Update of TU_COUNT_RUNS failed'); end; UpdateTestConfigID:=true; @@ -717,31 +717,23 @@ begin 'TCONF_CPU_FK,TCONF_OS_FK,TCONF_VERSION_FK,TCONF_CATEGORY_FK,'+ 'TCONF_SUBMITTER,TCONF_MACHINE,TCONF_COMMENT,'+ 'TCONF_NEW_DATE,TCONF_FIRST_DATE,TCONF_LAST_DATE) '; - qry:=qry+format(' VALUES(%d,%d,%d,%d,%d,%d,%d,"%s","%s","%s","%s","%s","%s") ', - [TestRunID, TestRunID, TestRunID, TestCPUID, - TestOSID, TestVersionID, TestCategoryID, - Submitter, Machine, Comment, - SqlDate(TestDate), SqlDate(TestDate), SqlDate(TestDate)]); + qry:=qry+format(' VALUES(%d,%d,%d,%d,%d,%d,%d,''%s'',''%s'',''%s'',''%s'',''%s'',''%s'') ', + [TestRunID, TestRunID, TestRunID, TestCPUID, + TestOSID, TestVersionID, TestCategoryID, + Submitter, Machine, Comment, + SqlDate(TestDate), SqlDate(TestDate), SqlDate(TestDate)]); + qry:=qry+' RETURNING TCONF_ID'; Result:=InsertQuery(qry); AddTestHistoryEntry(TestRunID,0); end; procedure UpdateTestConfig; - var - qry : string; - res : TQueryResult; begin - qry:='SHOW TABLES LIKE ''TESTCONFIG'''; - if not RunQuery(Qry,Res) then - exit; - { Row_Count is zero if table does not exist } - if Res^.Row_Count=0 then exit; - FreeQueryResult(Res); if GetTestPreviousRunHistoryID(TestRunID) <> -1 then begin - Verbose(V_DEBUG,format('TestRun %d already in TestHistory table',[TestRunID])); - exit; + Verbose(V_DEBUG,format('TestRun %d already in TestHistory table',[TestRunID])); + exit; end; if GetTestConfigID >= 0 then diff --git a/tests/utils/dbtests.pp b/tests/utils/dbtests.pp index 340c552567..5a19e8e716 100644 --- a/tests/utils/dbtests.pp +++ b/tests/utils/dbtests.pp @@ -6,7 +6,7 @@ unit dbtests; Interface Uses - mysql55dyn, testu; + sqldb, testu; { --------------------------------------------------------------------- High-level access @@ -34,21 +34,19 @@ function AddTestHistoryEntry(TestRunID,TestPreviousID : Integer) : boolean; Low-level DB access. ---------------------------------------------------------------------} - -Type - TQueryResult = PMYSQL_RES; - Function ConnectToDatabase(DatabaseName,Host,User,Password,Port : String) : Boolean; Procedure DisconnectDatabase; Function InsertQuery(const Query : string) : Integer; -Function RunQuery (Qry : String; Var res : TQueryResult) : Boolean ; -Procedure FreeQueryResult (Res : TQueryResult); -Function GetResultField (Res : TQueryResult; Id : Integer) : String; +Function ExecuteQuery (Qry : String; Silent : Boolean) : Boolean ; +Function OpenQuery (Qry : String; Out Res : TSQLQuery; Silent : Boolean) : Boolean ; +Procedure FreeQueryResult (Var Res : TSQLQuery); +Function GetResultField (Res : TSQLQuery; Id : Integer) : String; Function IDQuery(Qry : String) : Integer; Function StringQuery(Qry : String) : String; Function EscapeSQL( S : String) : String; Function SQLDate(D : TDateTime) : String; + var RelSrcDir, TestSrcDir : string; @@ -56,141 +54,158 @@ var Implementation Uses - SysUtils; + SysUtils, pqconnection; + +Var + Connection : TPQConnection; { --------------------------------------------------------------------- Low-level DB access. ---------------------------------------------------------------------} - -Var - Connection : PMYSQL; - - Function ConnectToDatabase(DatabaseName,Host,User,Password,Port : String) : Boolean; -Var - S : String; - PortNb : longint; - Error : word; begin - Verbose(V_DEBUG,'Connection params : '+DatabaseName+' '+Host+' '+User+' '+Password+' '+Port); - if Port<>'' then - begin - Val(Port,PortNb,Error); - if Error<>0 then - PortNb:=0; - end - else - PortNB:=0; - Connection:=mysql_init(Nil); - Result:=mysql_real_connect(Connection,PChar(Host),PChar(User),PChar(Password),Nil,PortNb,Nil,CLIENT_MULTI_RESULTS)<>Nil; - If Not Result then - begin - S:=Strpas(mysql_error(connection)); - Verbose(V_ERROR,'Failed to connect to database : '+S); - end - else - begin - Result:=Mysql_select_db(Connection,Pchar(DatabaseName))>=0; - If Not result then + Result:=False; + Verbose(V_SQL,'Connection params : '+DatabaseName+' '+Host+' '+User+' '+Port); + Connection:=TPQConnection.Create(Nil); + try + Connection.Hostname:=Host; + Connection.DatabaseName:=DatabaseName; + Connection.Username:=User; + Connection.Password:=Password; + Connection.Connected:=true; + Connection.Transaction:=TSQLTransaction.Create(Connection); + if (Port<>'') then + Connection.Params.Values['Port']:=Port; + except + On E : Exception do begin - S:=StrPas(mysql_error(connection)); - DisconnectDatabase; - Verbose(V_Error,'Failed to select database : '+S); + Verbose(V_ERROR,'Failed to connect to database : '+E.Message); + FreeAndNil(Connection); end; - end; + end; end; Procedure DisconnectDatabase; begin - mysql_close(Connection); + FreeAndNil(Connection); end; -Function RunQuery (Qry : String; Var res : TQueryResult) : Boolean ; +Function CreateQuery(Const ASQL : String) : TSQLQuery; begin - Verbose(V_DEBUG,'Running query:'+Qry); - Result:=mysql_query(Connection,PChar(qry))=0; - If Not Result then - Verbose(V_WARNING,'Query : '+Qry+'Failed : '+Strpas(mysql_error(connection))) - else - Res:=Mysql_store_result(connection); + Result:=TSQLQuery.Create(Connection); + Result.Database:=Connection; + Result.Transaction:=Connection.Transaction; + Result.SQL.Text:=ASQL; end; -{ No warning if it fails } -Function RunSilentQuery (Qry : String; Var res : TQueryResult) : Boolean ; + + +Function ExecuteQuery (Qry : String; Silent : Boolean) : Boolean ; begin - Verbose(V_DEBUG,'Running silent query:'+Qry); - Result:=mysql_query(Connection,PChar(qry))=0; - If Not Result then - Verbose(V_DEBUG,'Silent query : '+Qry+'Failed : '+Strpas(mysql_error(connection))) - else - Res:=Mysql_store_result(connection); + Verbose(V_SQL,'Executing query:'+Qry); + Result:=False; + try + With CreateQuery(Qry) do + try + ExecSQL; + Result:=True; + (Transaction as TSQLTransaction).Commit; + finally + Free; + end; + except + On E : exception do + begin + Connection.Transaction.RollBack; + if not Silent then + Verbose(V_WARNING,'Query : '+Qry+'Failed : '+E.Message); + end; + end; end; +Function OpenQuery (Qry : String; Out res : TSQLQuery; Silent : Boolean) : Boolean ; -Function GetResultField (Res : TQueryResult; Id : Integer) : String; +begin + Result:=False; + Verbose(V_SQL,'Running query:'+Qry); + Res:=CreateQuery(Qry); + try + Res.Open; + Result:=True; + except + On E : exception do + begin + FreeAndNil(Res); + Try + Connection.Transaction.RollBack; + except + end; + if not Silent then + Verbose(V_WARNING,'Query : '+Qry+'Failed : '+E.Message); + end; + end; +end; + +Function GetResultField (Res : TSQLQuery; Id : Integer) : String; -Var - Row : PPchar; begin - if Res=Nil then + If (Res=Nil) or (ID>=Res.Fields.Count) then Result:='' else - begin - Row:=mysql_fetch_row(Res); - If (Row=Nil) or (Row[ID]=Nil) then - Result:='' - else - Result:=strpas(Row[ID]); - end; - Verbose(V_DEBUG,'Field value '+Result); + Result:=Res.Fields[ID].AsString; + Verbose(V_SQL,'Field value '+Result); end; -Procedure FreeQueryResult (Res : TQueryResult); +Procedure FreeQueryResult(var Res : TSQLQuery); begin - mysql_free_result(Res); + if Assigned(Res) and Assigned(Res.Transaction) then + (Res.Transaction as TSQLTransaction).Commit; + FreeAndNil(Res); end; Function IDQuery(Qry : String) : Integer; Var - Res : TQueryResult; + Res : TSQLQuery; begin Result:=-1; - If RunQuery(Qry,Res) then - begin - Result:=StrToIntDef(GetResultField(Res,0),-1); - FreeQueryResult(Res); + If OpenQuery(Qry,Res,False) then + try + Result:=StrToIntDef(GetResultField(Res,0),-1); + finally + FreeQueryResult(Res); end; end; Function StringQuery(Qry : String) : String; Var - Res : TQueryResult; + Res : TSQLQuery; begin Result:=''; - If RunQuery(Qry,Res) then - begin - Result:=GetResultField(Res,0); - FreeQueryResult(Res); + If OpenQuery(Qry,Res,False) then + try + Result:=GetResultField(Res,0); + finally + FreeQueryResult(Res); end; end; Function EscapeSQL( S : String) : String; begin - Result:=StringReplace(S,'\','\\',[rfReplaceAll]); - Result:=StringReplace(Result,'"','\"',[rfReplaceAll]); - Verbose(V_DEBUG,'EscapeSQL : "'+S+'" -> "'+Result+'"'); +// Result:=StringReplace(S,'\','\\',[rfReplaceAll]); + Result:=StringReplace(S,'''','''''',[rfReplaceAll]); + Verbose(V_SQL,'EscapeSQL : "'+S+'" -> "'+Result+'"'); end; @@ -208,7 +223,7 @@ end; Function GetTestID(Name : string) : Integer; Const - SFromName = 'SELECT T_ID FROM TESTS WHERE (T_NAME="%s")'; + SFromName = 'SELECT T_ID FROM TESTS WHERE (T_NAME=''%s'')'; begin Result:=IDQuery(Format(SFromName,[Name])); @@ -217,7 +232,7 @@ end; Function GetOSID(Name : String) : Integer; Const - SFromName = 'SELECT TO_ID FROM TESTOS WHERE (TO_NAME="%s")'; + SFromName = 'SELECT TO_ID FROM TESTOS WHERE (TO_NAME=''%s'')'; begin Result:=IDQuery(Format(SFromName,[Name])); @@ -226,7 +241,7 @@ end; Function GetVersionID(Name : String) : Integer; Const - SFromName = 'SELECT TV_ID FROM TESTVERSION WHERE (TV_VERSION="%s")'; + SFromName = 'SELECT TV_ID FROM TESTVERSION WHERE (TV_VERSION=''%s'')'; begin Result:=IDQuery(Format(SFromName,[Name])); @@ -235,7 +250,7 @@ end; Function GetCPUID(Name : String) : Integer; Const - SFromName = 'SELECT TC_ID FROM TESTCPU WHERE (TC_NAME="%s")'; + SFromName = 'SELECT TC_ID FROM TESTCPU WHERE (TC_NAME=''%s'')'; begin Result:=IDQuery(Format(SFromName,[Name])); @@ -244,7 +259,7 @@ end; Function GetCategoryID(Name : String) : Integer; Const - SFromName = 'SELECT TCAT_ID FROM TESTCATEGORY WHERE (TCAT_NAME="%s")'; + SFromName = 'SELECT TCAT_ID FROM TESTCATEGORY WHERE (TCAT_NAME=''%s'')'; begin Result:=IDQuery(Format(SFromName,[Name])); @@ -258,24 +273,16 @@ Const ' (TU_OS_FK=%d) '+ ' AND (TU_CPU_FK=%d) '+ ' AND (TU_VERSION_FK=%d) '+ - ' AND (TU_DATE="%s")'; + ' AND (TU_DATE=''%s'')'; begin Result:=IDQuery(Format(SFromIDS,[OSID,CPUID,VERSIONID,SQLDate(Date)])); end; Function InsertQuery(const Query : string) : Integer; -Var - Res : TQueryResult; begin - If RunQuery(Query,Res) then - begin - Result:=mysql_insert_id(connection); - FreeQueryResult(Res); - end - else - Result:=-1; + Result:=IDQuery(Query); end; Function AddRun(OSID, CPUID, VERSIONID, CATEGORYID : Integer; Date : TDateTime) : Integer; @@ -284,12 +291,12 @@ Const SInsertRun = 'INSERT INTO TESTRUN '+ '(TU_OS_FK,TU_CPU_FK,TU_VERSION_FK,TU_CATEGORY_FK,TU_DATE)'+ ' VALUES '+ - '(%d,%d,%d,%d,"%s")'; + '(%d,%d,%d,%d,''%s'') RETURNING TU_ID'; var Qry : string; begin qry:=Format(SInsertRun,[OSID,CPUID,VERSIONID,CATEGORYID,SQLDate(Date)]); - Result:=InsertQuery(Qry); + Result:=IDQuery(Qry); end; function posr(c : Char; const s : AnsiString) : integer; @@ -337,7 +344,7 @@ begin FileName := FileName + '.pp' else exit; - Verbose(V_Debug,'Reading '+FileName); + Verbose(V_Debug,'Reading: '+FileName); assign(t,FileName); {$I-} reset(t); @@ -376,11 +383,10 @@ Function AddTest(Name : String; AddSource : Boolean) : Integer; Const SInsertTest = 'INSERT INTO TESTS (T_NAME,T_ADDDATE)'+ - ' VALUES ("%s",NOW())'; + ' VALUES (''%s'',NOW())'; Var Info : TConfig; - Res : TQueryResult; begin Result:=-1; @@ -388,9 +394,8 @@ begin GetConfig(TestSrcDir+RelSrcDir+Name,Info)) or GetUnitTestConfig(Name,Info) then begin - If RunQuery(Format(SInsertTest,[Name]),Res) then + If ExecuteQuery(Format(SInsertTest,[Name]),False) then begin - FreeQueryResult(Res); Result:=GetTestID(Name); If Result=-1 then Verbose(V_WARNING,'Could not find newly added test!') @@ -406,17 +411,17 @@ begin end; Const - B : Array[Boolean] of String = ('-','+'); + B : Array[Boolean] of String = ('f','t'); Function UpdateTest(ID : Integer; Info : TConfig; Source : String) : Boolean; Const SUpdateTest = 'Update TESTS SET '+ - ' T_CPU="%s", T_OS="%s", T_VERSION="%s",'+ - ' T_GRAPH="%s", T_INTERACTIVE="%s", T_RESULT=%d,'+ - ' T_FAIL="%s", T_RECOMPILE="%s", T_NORUN="%s",'+ - ' T_NEEDLIBRARY="%s", T_KNOWNRUNERROR=%d,'+ - ' T_KNOWN="%s", T_NOTE="%s", T_OPTS = "%s"'+ + ' T_CPU=''%s'', T_OS=''%s'', T_VERSION=''%s'','+ + ' T_GRAPH=''%s'', T_INTERACTIVE=''%s'', T_RESULT=%d,'+ + ' T_FAIL=''%s'', T_RECOMPILE=''%s'', T_NORUN=''%s'','+ + ' T_NEEDLIBRARY=''%s'', T_KNOWNRUNERROR=%d,'+ + ' T_KNOWN=''%s'', T_NOTE=''%s'', T_OPTS = ''%s'''+ ' %s '+ 'WHERE'+ ' T_ID=%d'; @@ -424,13 +429,12 @@ Const Var Qry : String; - Res : TQueryResult; begin If Source<>'' then begin Source:=EscapeSQL(Source); - Source:=', T_SOURCE="'+Source+'"'; + Source:=', T_SOURCE='''+Source+''''; end; With Info do Qry:=Format(SUpdateTest,[EscapeSQL(NeedCPU),'',EscapeSQL(MinVersion), @@ -441,8 +445,7 @@ begin Source, ID ]); - Result:=RunQuery(Qry,res); - FreeQueryResult(Res); + Result:=ExecuteQuery(Qry,False); end; Function AddTestResult(TestID,RunID,TestRes : Integer; @@ -453,37 +456,33 @@ Const SInsertRes='Insert into TESTRESULTS '+ '(TR_TEST_FK,TR_TESTRUN_FK,TR_OK,TR_SKIP,TR_RESULT) '+ ' VALUES '+ - '(%d,%d,"%s","%s",%d) '; + '(%d,%d,''%s'',''%s'',%d) RETURNING TR_ID'; SSelectId='SELECT TR_ID FROM TESTRESULTS WHERE (TR_TEST_FK=%d) '+ ' AND (TR_TESTRUN_FK=%d)'; - SInsertLog='Update TESTRESULTS SET TR_LOG="%s"'+ - ',TR_OK="%s",TR_SKIP="%s",TR_RESULT=%d WHERE (TR_ID=%d)'; + SInsertLog='Update TESTRESULTS SET TR_LOG=''%s'''+ + ',TR_OK=''%s'',TR_SKIP=''%s'',TR_RESULT=%d WHERE (TR_ID=%d)'; Var Qry : String; - Res : TQueryResult; updateValues : boolean; + begin updateValues:=false; Result:=-1; Qry:=Format(SInsertRes, [TestID,RunID,B[OK],B[Skipped],TestRes,EscapeSQL(Log)]); - If RunSilentQuery(Qry,Res) then - Result:=mysql_insert_id(connection) - else + Result:=IDQuery(Qry); + if (Result=-1) then begin - Qry:=format(SSelectId,[TestId,RunId]); - Result:=IDQuery(Qry); - if Result<>-1 then - updateValues:=true; + Qry:=format(SSelectId,[TestId,RunId]); + Result:=IDQuery(Qry); + if Result<>-1 then + UpdateValues:=true; end; if (Result<>-1) and ((Log<>'') or updateValues) then begin - Qry:=format(SInsertLog,[EscapeSQL(Log),B[OK],B[Skipped],TestRes,Result]); - if not RunQuery(Qry,Res) then - begin - Verbose(V_Warning,'Insert Log failed'); - end; - FreeQueryResult(Res); + Qry:=Format(SInsertLog,[EscapeSQL(Log),B[OK],B[Skipped],TestRes,Result]); + if Not ExecuteQuery(Qry,False) then + Verbose(V_Warning,'Insert Log failed'); end; { If test already existed, return false for is_new to avoid double counting } is_new:=not updateValues; @@ -504,12 +503,8 @@ Function CleanTestRun(ID : Integer) : Boolean; Const SDeleteRun = 'DELETE FROM TESTRESULTS WHERE TR_TESTRUN_FK=%d'; -Var - Res : TQueryResult; - begin - Result:=RunQuery(Format(SDeleteRun,[ID]),Res); - FreeQueryResult(Res); + Result:=ExecuteQuery(Format(SDeleteRun,[ID]),False); end; function GetTestPreviousRunHistoryID(TestRunID : Integer) : Integer; @@ -525,21 +520,14 @@ begin end; function AddTestHistoryEntry(TestRunID,TestPreviousID : Integer) : boolean; + var qry : string; - res : TQueryResult; + begin - qry:=format('INSERT INTO TESTRUNHISTORY (TH_ID_FK,TH_PREVIOUS_FK) '+ + Qry:=format('INSERT INTO TESTRUNHISTORY (TH_ID_FK,TH_PREVIOUS_FK) '+ ' VALUES (%d,%d)',[TestRunID,TestPreviousID]); - If RunQuery(qry,res) then - begin - FreeQueryResult(res); - AddTestHistoryEntry:=true; - end - else - AddTestHistoryEntry:=false; + Result:=ExecuteQuery(Qry,False); end; -begin - initialisemysql; end. diff --git a/tests/utils/dotest.pp b/tests/utils/dotest.pp index fca8a669ea..b93d91931a 100644 --- a/tests/utils/dotest.pp +++ b/tests/utils/dotest.pp @@ -61,6 +61,7 @@ const DllExt : string = '.so'; DllPrefix: string = 'lib'; DefaultTimeout=60; + READ_ONLY = 0; var Config : TConfig; @@ -358,7 +359,8 @@ end; procedure mkdirtree(const s:string); var - hs : string; + SErr, hs : string; + Err: longint; begin if s='' then exit; @@ -371,11 +373,16 @@ begin { Try parent first } mkdirtree(SplitPath(hs)); { make this dir } - Verbose(V_Debug,'Making Directory '+s); + Verbose(V_Debug,'Making directory '+s); {$I-} - mkdir(s); + MkDir (HS); {$I+} - ioresult; + Err := IOResult; + if Err <> 0 then + begin + Str (Err, SErr); + Verbose (V_Error, 'Directory creation failed ' + SErr); + end; end; end; @@ -397,6 +404,8 @@ const bufsize = 16384; var f,g : file; + oldfilemode : byte; + st : string; addsize, i : longint; buf : pointer; @@ -405,14 +414,7 @@ begin Verbose(V_Debug,'Appending '+fn1+' to '+fn2) else Verbose(V_Debug,'Copying '+fn1+' to '+fn2); - assign(f,fn1); assign(g,fn2); - {$I-} - reset(f,1); - {$I+} - addsize:=0; - if ioresult<>0 then - Verbose(V_Error,'Can''t open '+fn1); if append then begin {$I-} @@ -431,7 +433,36 @@ begin if ioresult<>0 then Verbose(V_Error,'Can''t open '+fn2+' for output'); end; + assign(f,fn1); + {$I-} + { Try using read only file mode } + oldfilemode:=filemode; + filemode:=READ_ONLY; + reset(f,1); + {$I+} + addsize:=0; getmem(buf,bufsize); + if ioresult<>0 then + begin + sleep(1000); + {$I-} + reset(f,1); + {$I+} + if ioresult<>0 then + begin + Verbose(V_Warning,'Can''t open '+fn1); + st:='Can''t open '+fn1; + i:=length(st); + // blocksize is larger than 255, so no check is needed + move(st[1],buf^,i); + blockwrite(g,buf^,i); + freemem(buf,bufsize); + close(g); + filemode:=oldfilemode; + exit; + end; + end; + filemode:=oldfilemode; repeat blockread(f,buf^,bufsize,i); blockwrite(g,buf^,i); diff --git a/tests/utils/libtar.pas b/tests/utils/libtar.pas index 68f6f2f743..9110bb0ba5 100644 --- a/tests/utils/libtar.pas +++ b/tests/utils/libtar.pas @@ -2,7 +2,7 @@ Copyright (c) 2000-2006 by Stefan Heymann See the file COPYING.FPC, included in this distribution, - for details about the copyright. + 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 @@ -45,7 +45,7 @@ TTarWriter Usage - Now your tar file is ready. -Source +Source -------------------------- The official site to get this code is http://www.destructor.de/ @@ -86,13 +86,13 @@ INTERFACE {$DEFINE Kylix} {$DEFINE LIBCUNIT} {$ENDIF} -{$ENDIF} +{$ENDIF} USES {$IFDEF LIBCUNIT} Libc, // MvdV: Nothing is used from this??? {$ENDIF} -{$ifdef Unix} +{$ifdef Unix} BaseUnix, Unix, {$endif} (*$IFDEF MSWINDOWS *) @@ -187,7 +187,7 @@ TYPE CONSTRUCTOR Create (TargetStream : TStream); OVERLOAD; CONSTRUCTOR Create (TargetFilename : STRING; Mode : INTEGER = fmCreate); OVERLOAD; DESTRUCTOR Destroy; OVERRIDE; // Writes End-Of-File Tag - PROCEDURE AddFile (Filename : STRING; TarFilename : STRING = ''); + FUNCTION AddFile (Filename : STRING; TarFilename : STRING = '') : BOOLEAN; PROCEDURE AddStream (Stream : TStream; TarFilename : STRING; FileDateGmt : TDateTime); PROCEDURE AddString (Contents : STRING; TarFilename : STRING; FileDateGmt : TDateTime); PROCEDURE AddDir (Dirname : STRING; DateGmt : TDateTime; MaxDirSize : INT64 = 0); @@ -250,7 +250,7 @@ END; FUNCTION ConvertFilename (Filename : STRING) : STRING; // Converts the filename to Unix conventions -// could be empty and inlined away for FPC. FPC I/O should be +// could be empty and inlined away for FPC. FPC I/O should be // forward/backward slash safe. BEGIN (*$IFDEF Unix *) @@ -787,20 +787,32 @@ BEGIN END; -PROCEDURE TTarWriter.AddFile (Filename : STRING; TarFilename : STRING = ''); +FUNCTION TTarWriter.AddFile (Filename : STRING; TarFilename : STRING = '') : BOOLEAN; VAR S : TFileStream; Date : TDateTime; BEGIN + AddFile:=false; Date := FileTimeGMT (Filename); IF TarFilename = '' THEN TarFilename := ConvertFilename (Filename); + TRY S := TFileStream.Create (Filename, fmOpenRead OR fmShareDenyWrite); + EXCEPT + ON EFOpenError DO + BEGIN + Writeln(stderr,'LibTar error: unable to open file "',Filename,'" for reading.'); + exit; + END; + END; + TRY AddStream (S, TarFilename, Date); + // No error, AddFile succeeded + AddFile:=true; FINALLY S.Free - END; + END; END; diff --git a/tests/utils/prepup.pp b/tests/utils/prepup.pp index bcfbced496..4c988404eb 100644 --- a/tests/utils/prepup.pp +++ b/tests/utils/prepup.pp @@ -22,6 +22,9 @@ uses const use_longlog : boolean = false; + has_file_errors : boolean = false; + MAX_RETRY = 5; + RETRY_WAIT_TIME = 1000; { One second wait time before trying again } var tarwriter : ttarwriter; @@ -33,6 +36,8 @@ procedure dosearch(const dir : string); Var Info : TSearchRec; hs : string; + tries : longint; + write_ok : boolean; begin If FindFirst (dir+DirectorySeparator+s,faAnyFile,Info)=0 then begin @@ -42,7 +47,25 @@ procedure dosearch(const dir : string); hs:=dir+DirectorySeparator+Name; { strip leading ./ } delete(hs,1,2); - tarwriter.addfile(hs); + if not tarwriter.addfile(hs) then + begin + tries:=1; + write_ok:=false; + while tries<MAX_RETRY do + begin + sleep(RETRY_WAIT_TIME); + inc(tries); + if tarwriter.addfile(hs) then + begin + write_ok:=true; + tries:=MAX_RETRY; + end; + end; + has_file_errors:=(write_ok=false); + if not write_ok then + tarwriter.addstring('###File Open failed###', + ConvertFileName(hs),Info.Time); + end; end; Until FindNext(info)<>0; end; @@ -69,6 +92,8 @@ End; var index : longint; +const + has_errors : boolean = false; begin index:=1; if paramcount<>1 then @@ -89,12 +114,19 @@ begin TarWriter := TTarWriter.Create (C); if not use_longlog then dosearch('.'); - TarWriter.AddFile('dbdigest.cfg'); - TarWriter.AddFile('log'); + if not TarWriter.AddFile('dbdigest.cfg') then + has_errors:=true; + if not TarWriter.AddFile('log') then + has_errors:=true; if use_longlog then - TarWriter.AddFile('longlog'); + if not TarWriter.AddFile('longlog') then + has_errors:=true; TarWriter.free; c.free; + if has_file_errors then + writeln(stderr,'Prepup error: some files were not copied'); + if has_errors then + halt(2); end. diff --git a/tests/utils/redir.pp b/tests/utils/redir.pp index 5eb31a6d58..5e046a25c6 100644 --- a/tests/utils/redir.pp +++ b/tests/utils/redir.pp @@ -30,7 +30,7 @@ Interface {$define implemented} {$endif} {$ifdef OS2} -{$define shell_implemented} +{$define implemented} {$endif} {$ifdef windows} {$define implemented} @@ -104,6 +104,11 @@ Uses {$ifdef windows} windows, {$endif windows} +{$IFDEF OS2} + {$IFNDEF EMX} + DosCalls, + {$ENDIF EMX} +{$ENDIF OS2} {$ifdef unix} baseunix, unix, @@ -328,13 +333,78 @@ begin end; {$endif} -{$ifdef os2} -Function fpclose (Handle : Longint) : boolean; +{$IFDEF OS2} + {$IFDEF EMX} +{$ASMMODE INTEL} +function fpDup (FH: longint): longint; assembler; +asm + mov ebx, eax + mov ah, 45h + call syscall + jnc @fpdup_end + mov eax, -1 +@fpdup_end: +end; + +function fpDup2 (FH, NH: longint): longint; assembler; +asm + cmp eax, edx + jnz @fpdup2_go + mov eax, 0 + jmp @fpdup2_end +@fpdup2_go: + push ebx + mov ebx, eax + mov ecx, edx + mov ah, 46h + call syscall + pop ebx + jnc @fpdup2_end + mov eax, -1 +@fpdup2_end: +end; + +function fpClose (Handle: longint): boolean; assembler; +asm + push ebx + mov ebx, eax + mov ah, 3Eh + call syscall + pop ebx + mov eax, 1 + jnc @fpclose_end + dec eax +end; + +{$ASMMODE DEFAULT} + {$ELSE EMX} + +function fpDup (FH: longint): longint; +var + NH: THandle; begin - { Do we need this ?? } - fpclose:=true; + NH := THandle (-1); + if DosDupHandle (THandle (FH), NH) = 0 then + fpDup := longint (NH) + else + fpDup := -1; end; -{$endif} + +function fpDup2 (FH, NH: longint): longint; +begin + if FH = NH then + fpDup2 := 0 + else + if DosDupHandle (THandle (FH), THandle (NH)) <> 0 then + fpDup2 := -1; +end; + +function fpClose (Handle: longint): boolean; +begin + fpClose := DosClose (THandle (Handle)) = 0; +end; + {$ENDIF EMX} +{$ENDIF OS2} {$I-} diff --git a/tests/utils/testsuite/Makefile b/tests/utils/testsuite/Makefile index fb3a1c53a4..050af5b6a3 100644 --- a/tests/utils/testsuite/Makefile +++ b/tests/utils/testsuite/Makefile @@ -1,9 +1,9 @@ # -# Don't edit, this file is generated by FPCMake Version 2.0.0 [2014-02-06 rev 26692] +# Don't edit, this file is generated by FPCMake Version 2.0.0 [2014-12-07 rev 29213] # 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 m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos powerpc-embedded powerpc-wii powerpc-aix sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-netbsd x86_64-solaris x86_64-openbsd x86_64-darwin x86_64-win64 x86_64-embedded arm-linux arm-palmos arm-darwin arm-wince arm-gba arm-nds arm-embedded arm-symbian arm-android powerpc64-linux powerpc64-darwin powerpc64-embedded powerpc64-aix avr-embedded armeb-linux armeb-embedded mips-linux mipsel-linux mipsel-android jvm-java jvm-android i8086-msdos -BSDs = freebsd netbsd openbsd darwin +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-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 +BSDs = freebsd netbsd openbsd darwin dragonfly UNIXs = linux $(BSDs) solaris qnx haiku aix LIMIT83fs = go32v2 os2 emx watcom msdos OSNeedsComspecToRunBatch = go32v2 watcom @@ -184,6 +184,12 @@ $(error When compiling for arm-embedded, a sub-architecture (e.g. SUBARCH=armv4t endif override FPCOPT+=-Cp$(SUBARCH) endif +ifeq ($(FULL_TARGET),mipsel-embedded) +ifeq ($(SUBARCH),) +$(error When compiling for mipsel-embedded, a sub-architecture (e.g. SUBARCH=pic32mx) must be defined) +endif +override FPCOPT+=-Cp$(SUBARCH) +endif ifneq ($(findstring $(OS_SOURCE),$(LIMIT83fs)),) TARGETSUFFIX=$(OS_TARGET) SOURCESUFFIX=$(OS_SOURCE) @@ -320,7 +326,7 @@ FPCFPMAKE=$(FPC) endif endif override PACKAGE_NAME=testsuite -override PACKAGE_VERSION=2.7.1 +override PACKAGE_VERSION=3.1.1 ifeq ($(FULL_TARGET),i386-linux) override TARGET_PROGRAMS+=testsuite endif @@ -390,6 +396,9 @@ endif ifeq ($(FULL_TARGET),i386-android) override TARGET_PROGRAMS+=testsuite endif +ifeq ($(FULL_TARGET),i386-aros) +override TARGET_PROGRAMS+=testsuite +endif ifeq ($(FULL_TARGET),m68k-linux) override TARGET_PROGRAMS+=testsuite endif @@ -477,6 +486,9 @@ endif ifeq ($(FULL_TARGET),x86_64-embedded) override TARGET_PROGRAMS+=testsuite endif +ifeq ($(FULL_TARGET),x86_64-dragonfly) +override TARGET_PROGRAMS+=testsuite +endif ifeq ($(FULL_TARGET),arm-linux) override TARGET_PROGRAMS+=testsuite endif @@ -531,6 +543,9 @@ endif ifeq ($(FULL_TARGET),mipsel-linux) override TARGET_PROGRAMS+=testsuite endif +ifeq ($(FULL_TARGET),mipsel-embedded) +override TARGET_PROGRAMS+=testsuite +endif ifeq ($(FULL_TARGET),mipsel-android) override TARGET_PROGRAMS+=testsuite endif @@ -612,6 +627,9 @@ endif ifeq ($(FULL_TARGET),i386-android) override COMPILER_UNITDIR+=.. endif +ifeq ($(FULL_TARGET),i386-aros) +override COMPILER_UNITDIR+=.. +endif ifeq ($(FULL_TARGET),m68k-linux) override COMPILER_UNITDIR+=.. endif @@ -699,6 +717,9 @@ endif ifeq ($(FULL_TARGET),x86_64-embedded) override COMPILER_UNITDIR+=.. endif +ifeq ($(FULL_TARGET),x86_64-dragonfly) +override COMPILER_UNITDIR+=.. +endif ifeq ($(FULL_TARGET),arm-linux) override COMPILER_UNITDIR+=.. endif @@ -753,6 +774,9 @@ endif ifeq ($(FULL_TARGET),mipsel-linux) override COMPILER_UNITDIR+=.. endif +ifeq ($(FULL_TARGET),mipsel-embedded) +override COMPILER_UNITDIR+=.. +endif ifeq ($(FULL_TARGET),mipsel-android) override COMPILER_UNITDIR+=.. endif @@ -1038,6 +1062,12 @@ EXEEXT= HASSHAREDLIB=1 SHORTSUFFIX=lnx endif +ifeq ($(OS_TARGET),dragonfly) +BATCHEXT=.sh +EXEEXT= +HASSHAREDLIB=1 +SHORTSUFFIX=df +endif ifeq ($(OS_TARGET),freebsd) BATCHEXT=.sh EXEEXT= @@ -1083,6 +1113,11 @@ EXEEXT= SHAREDLIBEXT=.library SHORTSUFFIX=amg endif +ifeq ($(OS_TARGET),aros) +EXEEXT= +SHAREDLIBEXT=.library +SHORTSUFFIX=aros +endif ifeq ($(OS_TARGET),morphos) EXEEXT= SHAREDLIBEXT=.library @@ -1665,6 +1700,16 @@ REQUIRE_PACKAGES_FPMKUNIT=1 REQUIRE_PACKAGES_FCL-BASE=1 REQUIRE_PACKAGES_FCL-DB=1 endif +ifeq ($(FULL_TARGET),i386-aros) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_PASZLIB=1 +REQUIRE_PACKAGES_FCL-PROCESS=1 +REQUIRE_PACKAGES_HASH=1 +REQUIRE_PACKAGES_LIBTAR=1 +REQUIRE_PACKAGES_FPMKUNIT=1 +REQUIRE_PACKAGES_FCL-BASE=1 +REQUIRE_PACKAGES_FCL-DB=1 +endif ifeq ($(FULL_TARGET),m68k-linux) REQUIRE_PACKAGES_RTL=1 REQUIRE_PACKAGES_PASZLIB=1 @@ -1955,6 +2000,16 @@ REQUIRE_PACKAGES_FPMKUNIT=1 REQUIRE_PACKAGES_FCL-BASE=1 REQUIRE_PACKAGES_FCL-DB=1 endif +ifeq ($(FULL_TARGET),x86_64-dragonfly) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_PASZLIB=1 +REQUIRE_PACKAGES_FCL-PROCESS=1 +REQUIRE_PACKAGES_HASH=1 +REQUIRE_PACKAGES_LIBTAR=1 +REQUIRE_PACKAGES_FPMKUNIT=1 +REQUIRE_PACKAGES_FCL-BASE=1 +REQUIRE_PACKAGES_FCL-DB=1 +endif ifeq ($(FULL_TARGET),arm-linux) REQUIRE_PACKAGES_RTL=1 REQUIRE_PACKAGES_PASZLIB=1 @@ -2135,6 +2190,16 @@ REQUIRE_PACKAGES_FPMKUNIT=1 REQUIRE_PACKAGES_FCL-BASE=1 REQUIRE_PACKAGES_FCL-DB=1 endif +ifeq ($(FULL_TARGET),mipsel-embedded) +REQUIRE_PACKAGES_RTL=1 +REQUIRE_PACKAGES_PASZLIB=1 +REQUIRE_PACKAGES_FCL-PROCESS=1 +REQUIRE_PACKAGES_HASH=1 +REQUIRE_PACKAGES_LIBTAR=1 +REQUIRE_PACKAGES_FPMKUNIT=1 +REQUIRE_PACKAGES_FCL-BASE=1 +REQUIRE_PACKAGES_FCL-DB=1 +endif ifeq ($(FULL_TARGET),mipsel-android) REQUIRE_PACKAGES_RTL=1 REQUIRE_PACKAGES_PASZLIB=1 @@ -2592,7 +2657,7 @@ endif ifdef CREATESHARED override FPCOPT+=-Cg endif -ifneq ($(findstring $(OS_TARGET),freebsd openbsd netbsd linux solaris),) +ifneq ($(findstring $(OS_TARGET),dragonfly freebsd openbsd netbsd linux solaris),) ifeq ($(CPU_TARGET),x86_64) override FPCOPT+=-Cg endif @@ -2628,17 +2693,23 @@ ifdef ACROSSCOMPILE override FPCOPT+=$(CROSSOPT) endif override COMPILER:=$(strip $(FPC) $(FPCOPT)) -ifeq (,$(findstring -s ,$(COMPILER))) +ifneq (,$(findstring -sh ,$(COMPILER))) +UseEXECPPAS=1 +endif +ifneq (,$(findstring -s ,$(COMPILER))) +ifeq ($(FULL_SOURCE),$(FULL_TARGET)) +UseEXECPPAS=1 +endif +endif +ifneq ($(UseEXECPPAS),1) EXECPPAS= else -ifeq ($(FULL_SOURCE),$(FULL_TARGET)) ifdef RUNBATCH EXECPPAS:=@$(RUNBATCH) $(PPAS) else EXECPPAS:=@$(PPAS) endif endif -endif .PHONY: fpc_exes ifndef CROSSINSTALL ifneq ($(TARGET_PROGRAMS),) diff --git a/tests/utils/testsuite/Makefile.fpc b/tests/utils/testsuite/Makefile.fpc index d0d97cae28..010fcf89bd 100644 --- a/tests/utils/testsuite/Makefile.fpc +++ b/tests/utils/testsuite/Makefile.fpc @@ -4,7 +4,7 @@ [package] name=testsuite -version=2.7.1 +version=3.1.1 [require] packages=fcl-base fcl-db diff --git a/tests/utils/testsuite/testsuite.lpi b/tests/utils/testsuite/testsuite.lpi index bd5b4c9380..ee4e1d55a5 100644 --- a/tests/utils/testsuite/testsuite.lpi +++ b/tests/utils/testsuite/testsuite.lpi @@ -1,159 +1,279 @@ -<?xml version="1.0"?> +<?xml version="1.0" encoding="UTF-8"?> <CONFIG> <ProjectOptions> - <Version Value="3"/> + <Version Value="9"/> <General> - <ProjectType Value="Program"/> + <Flags> + <MainUnitHasCreateFormStatements Value="False"/> + <MainUnitHasTitleStatement Value="False"/> + <LRSInOutputDirectory Value="False"/> + </Flags> <MainUnit Value="0"/> - <ActiveEditorIndexAtStart Value="1"/> - <IconPath Value="./"/> - <TargetFileExt Value=""/> <Title Value="testsuite"/> + <ActiveWindowIndexAtStart Value="0"/> </General> - <JumpHistory Count="12" HistoryIndex="11"> - <Position1> - <Filename Value="dbwhtml.pp"/> - <Caret Line="85" Column="3" TopLine="82"/> - </Position1> - <Position2> - <Filename Value="dbwhtml.pp"/> - <Caret Line="204" Column="5" TopLine="164"/> - </Position2> - <Position3> - <Filename Value="dbwhtml.pp"/> - <Caret Line="205" Column="5" TopLine="165"/> - </Position3> - <Position4> - <Filename Value="dbwhtml.pp"/> - <Caret Line="203" Column="25" TopLine="168"/> - </Position4> - <Position5> - <Filename Value="dbwhtml.pp"/> - <Caret Line="212" Column="15" TopLine="195"/> - </Position5> - <Position6> - <Filename Value="dbwhtml.pp"/> - <Caret Line="70" Column="67" TopLine="52"/> - </Position6> - <Position7> - <Filename Value="utests.pp"/> - <Caret Line="594" Column="5" TopLine="554"/> - </Position7> - <Position8> - <Filename Value="utests.pp"/> - <Caret Line="66" Column="1" TopLine="34"/> - </Position8> - <Position9> - <Filename Value="dbwhtml.pp"/> - <Caret Line="396" Column="4" TopLine="361"/> - </Position9> - <Position10> - <Filename Value="utests.pp"/> - <Caret Line="66" Column="14" TopLine="35"/> - </Position10> - <Position11> - <Filename Value="utests.pp"/> - <Caret Line="600" Column="56" TopLine="568"/> - </Position11> - <Position12> - <Filename Value="utests.pp"/> - <Caret Line="31" Column="77" TopLine="14"/> - </Position12> - </JumpHistory> - <Units Count="8"> + <BuildModes Count="1"> + <Item1 Name="default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <IgnoreBinaries Value="False"/> + <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> + <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/> + </local> + </RunParams> + <Units Count="12"> <Unit0> - <CursorPos X="19" Y="5"/> - <EditorIndex Value="0"/> <Filename Value="testsuite.pp"/> <IsPartOfProject Value="True"/> - <Loaded Value="True"/> - <TopLine Value="1"/> <UnitName Value="testsuite"/> - <UsageCount Value="56"/> + <EditorIndex Value="0"/> + <WindowIndex Value="1"/> + <TopLine Value="1"/> + <CursorPos X="29" Y="5"/> + <UsageCount Value="72"/> + <Loaded Value="True"/> + <LoadedDesigner Value="True"/> </Unit0> <Unit1> - <CursorPos X="23" Y="595"/> - <EditorIndex Value="1"/> <Filename Value="utests.pp"/> <IsPartOfProject Value="True"/> - <Loaded Value="True"/> - <TopLine Value="568"/> <UnitName Value="utests"/> - <UsageCount Value="56"/> + <IsVisibleTab Value="True"/> + <EditorIndex Value="1"/> + <WindowIndex Value="1"/> + <TopLine Value="1003"/> + <CursorPos X="59" Y="919"/> + <UsageCount Value="72"/> + <Loaded Value="True"/> </Unit1> <Unit2> - <CursorPos X="6" Y="136"/> - <EditorIndex Value="4"/> - <Filename Value="/home/michael/fixbranch/rtl/linux/syslinux.pp"/> - <Loaded Value="True"/> - <TopLine Value="94"/> + <Filename Value="../../../../../fixbranch/rtl/linux/syslinux.pp"/> <UnitName Value="SysLinux"/> - <UsageCount Value="28"/> + <WindowIndex Value="1"/> + <TopLine Value="94"/> + <CursorPos X="6" Y="136"/> + <UsageCount Value="26"/> + <LoadedDesigner Value="True"/> </Unit2> <Unit3> + <Filename Value="../../../../../test.sql"/> + <TopLine Value="1"/> <CursorPos X="1" Y="1"/> - <Filename Value="/home/michael/test.sql"/> <SyntaxHighlighter Value="None"/> - <TopLine Value="1"/> - <UsageCount Value="8"/> + <UsageCount Value="6"/> </Unit3> <Unit4> - <CursorPos X="27" Y="23"/> - <EditorIndex Value="3"/> - <Filename Value="/home/michael/fixbranch/rtl/unix/linux.pp"/> - <Loaded Value="True"/> - <TopLine Value="1"/> + <Filename Value="../../../../../fixbranch/rtl/unix/linux.pp"/> <UnitName Value="Linux"/> - <UsageCount Value="25"/> + <WindowIndex Value="1"/> + <TopLine Value="1"/> + <CursorPos X="27" Y="23"/> + <UsageCount Value="23"/> + <LoadedDesigner Value="True"/> </Unit4> <Unit5> - <CursorPos X="56" Y="251"/> - <Filename Value="/home/michael/projects/lazarus/components/editbutton/editbtn.pas"/> - <TopLine Value="248"/> + <Filename Value="../../../../../projects/lazarus/components/editbutton/editbtn.pas"/> <UnitName Value="EditBtn"/> - <UsageCount Value="8"/> + <TopLine Value="248"/> + <CursorPos X="56" Y="251"/> + <UsageCount Value="6"/> </Unit5> <Unit6> - <CursorPos X="31" Y="8"/> - <Filename Value="/home/michael/projects/lazarus/components/editbutton/demo/frmmain.pp"/> + <Filename Value="../../../../../projects/lazarus/components/editbutton/demo/frmmain.pp"/> <ComponentName Value="Form1"/> - <ResourceFilename Value="/home/michael/projects/lazarus/components/editbutton/demo/frmmain.lrs"/> - <TopLine Value="1"/> <UnitName Value="frmmain"/> - <UsageCount Value="20"/> + <TopLine Value="1"/> + <CursorPos X="31" Y="8"/> + <UsageCount Value="18"/> </Unit6> <Unit7> - <CursorPos X="27" Y="393"/> - <EditorIndex Value="2"/> <Filename Value="dbwhtml.pp"/> - <Loaded Value="True"/> - <TopLine Value="384"/> <UnitName Value="dbwhtml"/> - <UsageCount Value="25"/> + <WindowIndex Value="1"/> + <TopLine Value="384"/> + <CursorPos X="27" Y="393"/> + <UsageCount Value="23"/> + <LoadedDesigner Value="True"/> </Unit7> + <Unit8> + <Filename Value="../tresults.pp"/> + <IsPartOfProject Value="True"/> + <UnitName Value="tresults"/> + <UsageCount Value="36"/> + </Unit8> + <Unit9> + <Filename Value="../../../../build/tag_2_6_4/fpcsrc/packages/fcl-base/src/wformat.pp"/> + <UnitName Value="wformat"/> + <EditorIndex Value="4"/> + <WindowIndex Value="1"/> + <TopLine Value="17"/> + <CursorPos X="15" Y="35"/> + <UsageCount Value="18"/> + <Loaded Value="True"/> + </Unit9> + <Unit10> + <Filename Value="../../../../build/tag_2_6_4/fpcsrc/packages/fcl-web/src/base/webutil.pp"/> + <UnitName Value="webutil"/> + <EditorIndex Value="3"/> + <WindowIndex Value="1"/> + <TopLine Value="1"/> + <CursorPos X="1" Y="1"/> + <UsageCount Value="17"/> + <Loaded Value="True"/> + </Unit10> + <Unit11> + <Filename Value="../../../../build/tag_2_6_4/fpcsrc/packages/fcl-web/src/base/cgiapp.pp"/> + <UnitName Value="cgiapp"/> + <EditorIndex Value="2"/> + <WindowIndex Value="1"/> + <TopLine Value="34"/> + <CursorPos X="1" Y="40"/> + <UsageCount Value="17"/> + <Loaded Value="True"/> + </Unit11> </Units> - <PublishOptions> - <Version Value="2"/> - <IgnoreBinaries Value="False"/> - <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> - <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/> - </PublishOptions> - <RunParams> - <local> - <FormatVersion Value="1"/> - <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/> - </local> - </RunParams> - <RequiredPackages Count="1"> - <Item1> - <PackageName Value="editbutton"/> - <MinVersion Valid="True"/> - </Item1> - </RequiredPackages> + <JumpHistory Count="30" HistoryIndex="29"> + <Position1> + <Filename Value="utests.pp"/> + <Caret Line="574" Column="45" TopLine="549"/> + </Position1> + <Position2> + <Filename Value="utests.pp"/> + <Caret Line="946" Column="27" TopLine="930"/> + </Position2> + <Position3> + <Filename Value="utests.pp"/> + <Caret Line="1103" Column="40" TopLine="1077"/> + </Position3> + <Position4> + <Filename Value="utests.pp"/> + <Caret Line="1467" Column="37" TopLine="1442"/> + </Position4> + <Position5> + <Filename Value="utests.pp"/> + <Caret Line="1468" Column="71" TopLine="1443"/> + </Position5> + <Position6> + <Filename Value="utests.pp"/> + <Caret Line="1469" Column="48" TopLine="1444"/> + </Position6> + <Position7> + <Filename Value="utests.pp"/> + <Caret Line="2531" Column="53" TopLine="2531"/> + </Position7> + <Position8> + <Filename Value="utests.pp"/> + <Caret Line="2554" Column="17" TopLine="2525"/> + </Position8> + <Position9> + <Filename Value="utests.pp"/> + <Caret Line="2533" Column="17" TopLine="2519"/> + </Position9> + <Position10> + <Filename Value="utests.pp"/> + <Caret Line="2544" Column="18" TopLine="2540"/> + </Position10> + <Position11> + <Filename Value="utests.pp"/> + <Caret Line="121" Column="1" TopLine="121"/> + </Position11> + <Position12> + <Filename Value="utests.pp"/> + <Caret Line="326" Column="24" TopLine="301"/> + </Position12> + <Position13> + <Filename Value="utests.pp"/> + <Caret Line="67" Column="1" TopLine="61"/> + </Position13> + <Position14> + <Filename Value="utests.pp"/> + <Caret Line="846" Column="3" TopLine="842"/> + </Position14> + <Position15> + <Filename Value="utests.pp"/> + <Caret Line="1" Column="1" TopLine="1"/> + </Position15> + <Position16> + <Filename Value="utests.pp"/> + <Caret Line="2555" Column="11" TopLine="2530"/> + </Position16> + <Position17> + <Filename Value="utests.pp"/> + <Caret Line="2554" Column="10" TopLine="2530"/> + </Position17> + <Position18> + <Filename Value="utests.pp"/> + <Caret Line="1" Column="1" TopLine="1"/> + </Position18> + <Position19> + <Filename Value="utests.pp"/> + <Caret Line="420" Column="21" TopLine="412"/> + </Position19> + <Position20> + <Filename Value="utests.pp"/> + <Caret Line="1" Column="1" TopLine="1"/> + </Position20> + <Position21> + <Filename Value="utests.pp"/> + <Caret Line="2555" Column="41" TopLine="2532"/> + </Position21> + <Position22> + <Filename Value="utests.pp"/> + <Caret Line="2493" Column="3" TopLine="2478"/> + </Position22> + <Position23> + <Filename Value="utests.pp"/> + <Caret Line="2" Column="1" TopLine="1"/> + </Position23> + <Position24> + <Filename Value="utests.pp"/> + <Caret Line="2534" Column="11" TopLine="2527"/> + </Position24> + <Position25> + <Filename Value="utests.pp"/> + <Caret Line="1" Column="1" TopLine="1"/> + </Position25> + <Position26> + <Filename Value="utests.pp"/> + <Caret Line="304" Column="21" TopLine="300"/> + </Position26> + <Position27> + <Filename Value="utests.pp"/> + <Caret Line="676" Column="1" TopLine="661"/> + </Position27> + <Position28> + <Filename Value="utests.pp"/> + <Caret Line="912" Column="13" TopLine="904"/> + </Position28> + <Position29> + <Filename Value="utests.pp"/> + <Caret Line="1" Column="1" TopLine="1"/> + </Position29> + <Position30> + <Filename Value="utests.pp"/> + <Caret Line="919" Column="16" TopLine="889"/> + </Position30> + </JumpHistory> </ProjectOptions> <CompilerOptions> + <Version Value="11"/> + <SearchPaths> + <OtherUnitFiles Value=".."/> + </SearchPaths> + <Parsing> + <SyntaxOptions> + <UseAnsiStrings Value="False"/> + </SyntaxOptions> + </Parsing> <Other> <CompilerPath Value="$(CompPath)"/> </Other> </CompilerOptions> + <EditorMacros Count="0"/> </CONFIG> diff --git a/tests/utils/testsuite/testsuite.pp b/tests/utils/testsuite/testsuite.pp index a926345c91..7d077b5427 100644 --- a/tests/utils/testsuite/testsuite.pp +++ b/tests/utils/testsuite/testsuite.pp @@ -2,7 +2,7 @@ {$h+} program testsuite; -uses utests; +uses utests, tresults; Var App : TTestSuite; diff --git a/tests/utils/testsuite/utests.pp b/tests/utils/testsuite/utests.pp index 8190d171be..8b428771f4 100644 --- a/tests/utils/testsuite/utests.pp +++ b/tests/utils/testsuite/utests.pp @@ -1,13 +1,16 @@ {$mode objfpc} {$h+} + unit utests; interface uses cgiapp, - sysutils,mysql55conn,sqldb,whtml,dbwhtml,db, - tresults, + sysutils, + pqconnection, + sqldb,whtml,dbwhtml,db, + tresults,webutil, Classes,ftFont,fpimage,fpimgcanv,fpWritePng,fpcanvas; const @@ -17,9 +20,14 @@ const ViewRevURL='http://svn.freepascal.org/cgi-bin/viewvc.cgi?view=revision&revision='; TestsSubDir='/tests/'; DataBaseSubDir='/packages/fcl-db/tests/'; + var TestsuiteCGIURL : string; + Type + + { TTestSuite } + TTestSuite = Class(TCgiApplication) Private FHTMLWriter : THtmlWriter; @@ -56,6 +64,7 @@ Type FLimit : Integer; FTestLastDays : Integer; FNeedEnd : boolean; + procedure DumpTestInfo(Q: TSQLQuery); Procedure GetOverviewRowAttr(Sender : TObject; Var BGColor : String; Var Align : THTMLAlign; Var VAlign : THTMLValign; Var CustomAttr : String) ; @@ -191,6 +200,8 @@ type ver_2_6_1, ver_2_6_2, ver_2_6_3, + ver_2_6_4, + ver_2_6_5, ver_2_7_1); const @@ -227,6 +238,8 @@ const '2.6.1', '2.6.2', '2.6.3', + '2.6.4', + '2.6.5', '2.7.1' ); @@ -259,6 +272,8 @@ const 'tags/release_2_6_0', 'tags/release_2_6_2', 'tags/release_2_6_2', + 'tags/release_2_6_4', + 'tags/release_2_6_4', 'branches/fixes_2_6', 'trunk' ); @@ -366,7 +381,8 @@ begin FVersion:=RequestVariables['version']; if Length(FVersion) = 0 then FVersion:=RequestVariables['TESTVERSION']; - + TestsuiteCGIURL:=Self.ScriptName; + SDetailsURL := TestsuiteCGIURL + '?action=1&run1id=%s'; FOS:=RequestVariables['os']; if Length(FOS) = 0 then FOS:=RequestVariables['TESTOS']; @@ -434,7 +450,7 @@ Function TTestSuite.ConnectToDB : Boolean; begin Result:=False; - FDB:=TMySQl55Connection.Create(Self); + FDB:=TPQConnection.Create(Self); FDB.HostName:=DefHost; FDB.DatabaseName:=DefDatabase; FDB.UserName:=DefDBUser; @@ -548,6 +564,9 @@ begin end; Procedure TTestSuite.EmitTitle(ATitle : String); + +Var + S : TStrings; begin AddResponseLn('<HTML>'); AddResponseLn('<TITLE>'+ATitle+'</TITLE>'); @@ -575,7 +594,6 @@ begin DumpLn('View Test suite results'); HeaderEnd(1); DumpLn('Please specify search criteria:'); - ParagraphStart; FormStart(TestsuiteCGIURL,''); if FDebug then EmitHiddenVar('DEBUGCGI', '1'); @@ -692,7 +710,6 @@ begin DumpLn('View Test suite results'); HeaderEnd(1); DumpLn('Please specify search criteria:'); - ParagraphStart; FormStart(TestsuiteCGIURL,''); if FDebug then EmitHiddenVar('DEBUGCGI', '1'); @@ -892,7 +909,7 @@ end; Procedure TTestSuite.ShowRunOverview; Const SOverview = 'SELECT TU_ID as ID,TU_DATE as Date,TC_NAME as CPU,TO_NAME as OS,'+ - 'TV_VERSION as Version,count(*) as Count,'+ + 'TV_VERSION as Version,(select count(*) from testresults where (TR_TESTRUN_FK=TU_ID)) as Count,'+ 'TU_SVNCOMPILERREVISION as SvnCompRev,'+ 'TU_SVNRTLREVISION as SvnRTLRev,'+ 'TU_SVNPACKAGESREVISION as SvnPackRev,TU_SVNTESTSREVISION as SvnTestsRev,'+ @@ -901,11 +918,13 @@ Const '(TU_SUCCESSFULLYFAILED+TU_SUCCESFULLYCOMPILED+TU_SUCCESSFULLYRUN+'+ 'TU_FAILEDTOCOMPILE+TU_FAILEDTORUN+TU_FAILEDTOFAIL) as Total,'+ 'TU_SUBMITTER as Submitter, TU_MACHINE as Machine, TU_COMMENT as Comment %s '+ - 'FROM TESTRUN left join TESTCPU on (TC_ID=TU_CPU_FK) left join TESTOS on (TO_ID=TU_OS_FK) '+ - 'left join TESTVERSION on (TV_ID=TU_VERSION_FK) left join TESTCATEGORY on (TCAT_ID=TU_CATEGORY_FK) '+ - 'left join TESTRESULTS on (TR_TESTRUN_FK=TU_ID) '+ + 'FROM '+ + ' TESTRUN '+ + ' left join TESTCPU on (TC_ID=TU_CPU_FK) '+ + ' left join TESTOS on (TO_ID=TU_OS_FK) '+ + ' left join TESTVERSION on (TV_ID=TU_VERSION_FK) '+ + ' left join TESTCATEGORY on (TCAT_ID=TU_CATEGORY_FK) '+ '%s'+ - 'GROUP BY TU_ID '+ 'ORDER BY TU_ID DESC LIMIT %d'; @@ -924,7 +943,7 @@ begin if (FOS<>'') and (GetOSName(FOS)<>'All') then S:=S+' AND (TU_OS_FK='+FOS+')'; If (Round(FDate)<>0) then - S:=S+' AND (TU_DATE LIKE '''+FormatDateTime('YYYY-MM-DD',FDate)+'%'')'; + S:=S+' AND (to_char(TU_DATE, ''YYYY-MM-DD'') LIKE '''+FormatDateTime('YYYY-MM-DD',FDate)+'%'')'; If FSubmitter<>'' then S:=S+' AND (TU_SUBMITTER='''+FSubmitter+''')'; If FMachine<>'' then @@ -933,11 +952,9 @@ begin S:=S+' AND (TU_COMMENT LIKE '''+Fcomment+''')'; If FCond<>'' then S:=S+' AND ('+FCond+')'; - If FOnlyFailed then - S:=S+' AND (TR_OK="-")'; If GetCategoryName(FCategory)<>'DB' then - SC:=', CONCAT(TU_SVNCOMPILERREVISION,"/",TU_SVNRTLREVISION,"/", '+ - 'TU_SVNPACKAGESREVISION,"/",TU_SVNTESTSREVISION) as svnrev' + SC:=', CONCAT(TU_SVNCOMPILERREVISION,''/'',TU_SVNRTLREVISION,''/'', '+ + 'TU_SVNPACKAGESREVISION,''/'',TU_SVNTESTSREVISION) as svnrev' else SC:=''; If (FCategory='') or (GetCategoryName(FCategory)='All') then @@ -1088,8 +1105,8 @@ begin If Result then begin If GetCategoryName(FCategory)<>'DB' then - SC:=', CONCAT(TU_SVNCOMPILERREVISION,"/",TU_SVNRTLREVISION,"/", '+ - 'TU_SVNPACKAGESREVISION,"/",TU_SVNTESTSREVISION) as svnrev' + SC:=', CONCAT(TU_SVNCOMPILERREVISION,''/'',TU_SVNRTLREVISION,''/'', '+ + 'TU_SVNPACKAGESREVISION,''/'',TU_SVNTESTSREVISION) as svnrev' else SC:=''; If GetCategoryName(FCategory)='All' then @@ -1198,7 +1215,8 @@ begin DumpLn('SVN Revisions:'); CellNext; SC:=Q1.FieldByName('svnrev').AsString; - FormatSVNData(SC); + if (SC<>'') then + FormatSVNData(SC); LDumpLn(SC); CellNext; if Q2 <> nil then @@ -1397,9 +1415,9 @@ begin +' WHERE (TR_TEST_FK=T_ID) AND (TR_TESTRUN_FK='+FRunID+') '; If FOnlyFailed then - S:=S+' AND (TR_OK="-")'; + S:=S+' AND (not TR_OK)'; If FNoSkipped then - S:=S+' AND (TR_SKIP="-")'; + S:=S+' AND (not TR_SKIP)'; S:=S+' ORDER BY TR_ID '; Qry:=S; If FDebug then @@ -1466,6 +1484,45 @@ begin end; end; +Procedure TTestSuite.DumpTestInfo(Q : TSQLQuery); + +Var + I : Integer; + field_displayed : boolean; + FieldValue,FieldName : String; + +begin + With FHTMLWriter do + For i:=0 to Q.FieldCount-1 do + begin + FieldValue:=Q.Fields[i].AsString; + FieldName:=Q.Fields[i].DisplayName; + field_displayed:=false; + if (Not Q.fields[i].IsNull) and (FieldName<>'t_name') and (FieldName<>'t_source') then + begin + if (Q.Fields[i].Datatype=ftBoolean) then + begin + if Q.Fields[i].AsBoolean then + begin + DumpLn('Flag '); + DumpLn(FieldName); + DumpLn(' set'); + field_displayed:=true; + end; + end + else if FieldValue<>'' then + begin + DumpLn(FieldName); + DumpLn(' '); + DumpLn(FieldValue); + field_displayed:=true; + end; + if field_displayed then + DumpLn('<BR>'); + end; + end; +end; + Procedure TTestSuite.ShowOneTest; Var @@ -1484,8 +1541,7 @@ begin EmitContentType; EmitDocType; if FTestFileID='' then - FTestFileID:=GetSingleton('SELECT T_ID FROM TESTS WHERE T_NAME LIKE ''%'+ - FTestFileName+'%'''); + FTestFileID:=GetSingleton('SELECT T_ID FROM TESTS WHERE T_NAME LIKE ''%'+FTestFileName+'%'''); if FTestFileID<>'' then FTestFileName:=GetTestFileName(FTestFileID); EmitTitle(Title+' : File '+FTestFileName+' Results'); @@ -1527,26 +1583,7 @@ begin Try Open; Try - For i:=0 to FieldCount-1 do - begin - FieldValue:=Fields[i].AsString; - FieldName:=Fields[i].DisplayName; - - if (FieldValue<>'') and (FieldValue<>'-') and - (FieldName<>'T_NAME') and (FieldName<>'T_SOURCE') then - begin - if (FieldValue='+') then - DumpLn('Flag '); - DumpLn(FieldName); - DumpLn(' '); - if FieldValue='+' then - DumpLn(' set') - else - DumpLn(FieldValue); - DumpLn('<BR>'); - end; - end; - + DumpTestInfo(Q); Finally Close; end; @@ -1617,7 +1654,7 @@ begin Free; end; ParaGraphStart; - DumpLn(Format('<p>Record count: %d </p>',[Q.RecordCount])); + DumpLn(Format('Record count: %d',[Q.RecordCount])); ParaGraphEnd; Finally Close; @@ -1746,8 +1783,10 @@ end; Procedure TTestSuite.ShowHistory; + Const MaxCombo = 50; + Type StatusLongintArray = Array [TTestStatus] of longint; StatusDateTimeArray = Array [TTestStatus] of TDateTime; @@ -1755,6 +1794,7 @@ Type AStatusDTA = Array[1..MaxCombo] of StatusDateTimeArray; PStatusLA = ^AStatusLA; PStatusDTA = ^AStatusDTA; + Var S,SS,FL,cpu,version,os : String; date : TDateTime; @@ -1782,8 +1822,9 @@ Var version_first_date_id, version_last_date_id : PStatusLA; FieldName,FieldValue, LLog,Source : String; - Res : Boolean; + B,Res : Boolean; ver : known_versions; + begin Res:=False; os_count:=nil; @@ -1855,25 +1896,7 @@ begin Try Open; Try - For i:=0 to FieldCount-1 do - begin - FieldValue:=Fields[i].AsString; - FieldName:=Fields[i].DisplayName; - if (FieldValue<>'') and (FieldValue<>'-') and - (FieldName<>'T_NAME') and (FieldName<>'T_SOURCE') then - begin - if (FieldValue='+') then - DumpLn('Flag '); - DumpLn(FieldName); - DumpLn(' '); - if FieldValue='+' then - DumpLn(' set') - else - DumpLn(FieldValue); - DumpLn('<BR>'); - end; - end; - + DumpTestInfo(Q); Finally Close; end; @@ -2048,14 +2071,11 @@ begin begin Q.RecNo:=i; inc(total_count); - S:=Fields[ok_ind].AsString; - - if S='+' then + if Q.Fields[ok_ind].AsBoolean then inc(OK_count) else inc(not_OK_count); - S:=Fields[skip_ind].AsString; - if S='+' then + if Fields[skip_ind].AsBoolean then inc(skip_count) else inc(not_skip_count); @@ -2529,35 +2549,26 @@ begin HeaderEnd(2); ParaGraphStart; Q:=CreateDataset(''); - Q.SQL.Text:='CREATE TEMPORARY TABLE tr1 like TESTRESULTS;'; - Q.ExecSQL; - Q.SQL.Text:='CREATE TEMPORARY TABLE tr2 like TESTRESULTS;'; - Q.ExecSQL; - Q.SQL.Text:='INSERT INTO tr1 SELECT * FROM '+TESTRESULTSTableName(FRunId)+ - - ' WHERE TR_TESTRUN_FK='+FRunID+';'; - Q.ExecSQL; - Q.SQL.Text:='INSERT INTO tr2 SELECT * FROM '+TESTRESULTSTableName(FCompareRunId)+ - ' WHERE TR_TESTRUN_FK='+FCompareRunID+';'; - Q.ExecSQL; - S:='SELECT T_ID as Id,T_NAME as Filename,tr1.TR_SKIP as Run1_Skipped,' + S:='with tr1 as (SELECT * FROM '+TESTRESULTSTableName(FRunId)+ ' WHERE TR_TESTRUN_FK='+FRunID+'), '+ + ' tr2 as (SELECT * FROM '+TESTRESULTSTableName(FCompareRunId)+' WHERE TR_TESTRUN_FK='+FCompareRunID+')'+ + ' SELECT T_ID as id,T_NAME as Filename,tr1.TR_SKIP as Run1_Skipped,' +'tr2.TR_SKIP as Run2_Skipped,tr1.TR_OK as Run1_OK,' +'tr2.TR_OK as Run2_OK, tr1.TR_Result as Run1_Result,' +'tr2.TR_RESULT as Run2_Result ' +'FROM TESTS, tr2 LEFT JOIN tr1 USING (TR_TEST_FK) ' - +'WHERE ((tr1.TR_SKIP IS NULL) or' - +' (tr2.TR_SKIP IS NULL) or ' + +'WHERE ((tr1.TR_SKIP IS NULL) or (tr2.TR_SKIP IS NULL) or ' +' (%s (tr1.TR_Result<>tr2.TR_Result)))' +'and (T_ID=tr2.TR_TEST_FK)'; If FNoSkipped then begin - Qry:='(((tr1.TR_SKIP="+") and (tr2.TR_OK="-") and (tr2.TR_SKIP="-")) or ' - +'((tr1.TR_OK="-") and (tr1.TR_SKIP="-") and (tr2.TR_SKIP="+")) or ' - +'((tr1.TR_SKIP="-") and (tr2.TR_SKIP="-"))) and '; + Qry:='(((tr1.TR_SKIP) and (not tr2.TR_OK) and (not tr2.TR_SKIP)) or ' + +'((not tr1.TR_OK) and (not tr1.TR_SKIP) and (tr2.TR_SKIP)) or ' + +'((not tr1.TR_SKIP) and (not tr2.TR_SKIP))) and '; end else Qry:=''; Qry:=Format(S,[Qry]); +// DumpLn(Qry); If FDebug then begin system.WriteLn('Query: '+Qry); @@ -2646,25 +2657,25 @@ begin Run2Field := P.Dataset.FindField('OK'); if Run2Field = nil then Run2Field := P.Dataset.FindField('Run2_OK'); - If (not FNoSkipped) and ((Skip1Field.AsString='+') - or ((Skip2Field <> nil) and (Skip2Field.AsString = '+'))) then + If (not FNoSkipped) and ((Skip1Field.AsBoolean) + or ((Skip2Field <> nil) and (Skip2Field.AsBoolean))) then begin Inc(FRunSkipCount); BGColor:='yellow'; // Yellow end - else If Run2Field.AsString='+' then + else If Run2Field.AsBoolean then begin if Run1Field.AsString='' then BGColor:='#68DFB8' - else if Run1Field.ASString<>'+' then + else if Run1Field.AsBoolean then BGColor:='#98FB98'; // pale Green end - else if Run2Field.AsString='-' then + else if Not Run2Field.AsBoolean then begin Inc(FRunFailedCount); if Run1Field.AsString='' then BGColor:='#FF82AB' // Light red - else if Run1Field.AsString<>'-' then + else if Not Run1Field.AsBoolean then BGColor:='#FF225B'; end; end; @@ -2738,7 +2749,7 @@ begin pos_colon:=pos(':',SubStr); Rev:=copy(SubStr,pos_colon+1,length(SubStr)); { Remove suffix like M for modified...} - while not (Rev[length(Rev)] in ['0'..'9']) do + while (length(Rev)>0) and (not (Rev[length(Rev)] in ['0'..'9'])) do Rev:=Copy(Rev,1,length(Rev)-1); S:=ViewRevURL+Rev; CellData:=CellData+Format('<A HREF="%s" target="_blank">%s</A>',[S,SubStr]); @@ -2971,6 +2982,5 @@ begin else TestsuiteCGIURL:=TestsuiteURLPrefix+'cgi-bin/'+TestsuiteBin; - SDetailsURL := TestsuiteCGIURL + '?action=1&run1id=%s'; ShortDateFormat:='yyyy/mm/dd'; end. diff --git a/tests/utils/testu.pp b/tests/utils/testu.pp index 4b73ecaa36..0c424aa6f4 100644 --- a/tests/utils/testu.pp +++ b/tests/utils/testu.pp @@ -10,7 +10,7 @@ Interface ---------------------------------------------------------------------} type - TVerboseLevel=(V_Abort,V_Error,V_Warning,V_Normal,V_Debug); + TVerboseLevel=(V_Abort,V_Error,V_Warning,V_Normal,V_Debug,V_SQL); TConfig = record NeedOptions, @@ -48,6 +48,7 @@ type Const DoVerbose : boolean = false; + DoSQL : boolean = false; procedure TrimB(var s:string); procedure TrimE(var s:string); @@ -66,6 +67,9 @@ begin V_Debug : if DoVerbose then writeln('Debug: ',s); + V_SQL : + if DoSQL then + writeln('SQL: ',s); V_Warning : writeln('Warning: ',s); V_Error : diff --git a/tests/webtbf/tw26456.pp b/tests/webtbf/tw26456.pp new file mode 100644 index 0000000000..fcc7abcea2 --- /dev/null +++ b/tests/webtbf/tw26456.pp @@ -0,0 +1,16 @@ +{ %FAIL } + +program tw26456; +{$modeswitch advancedrecords} +type + THelper = record helper for xxxxxxx + procedure test; + end; + + procedure THelper.test; + begin + end; + +begin +end. + diff --git a/tests/webtbf/tw26704.pp b/tests/webtbf/tw26704.pp new file mode 100644 index 0000000000..63a13edacb --- /dev/null +++ b/tests/webtbf/tw26704.pp @@ -0,0 +1,11 @@ +{ %fail } + +type + TTest = record + Value: Byte; + case Integer of + 0: (Value: Word); + end; + +begin +end. diff --git a/tests/webtbf/tw9039c.pp b/tests/webtbf/tw9039c.pp index b36d500216..01629ba752 100644 --- a/tests/webtbf/tw9039c.pp +++ b/tests/webtbf/tw9039c.pp @@ -6,7 +6,7 @@ type tr = packed record l: longint; case byte of - 0: (l: longint); + 0: (x: longint); 1: (e: ta); end; diff --git a/tests/webtbs/tw10247.pp b/tests/webtbs/tw10247.pp index 582b6479b4..e7efa345a4 100644 --- a/tests/webtbs/tw10247.pp +++ b/tests/webtbs/tw10247.pp @@ -4,6 +4,7 @@ type generic TNode<T> = class public type + TAlias = T; PT = ^T; private var @@ -25,7 +26,7 @@ type destructor Destroy; override; function GetAddr: TTNode.PT; - procedure SetV(v: TTNode.T); + procedure SetV(v: TTNode.TAlias); end; constructor TNode.Create; @@ -54,7 +55,7 @@ begin end; -procedure TContainer.SetV(v: TTNode.T); +procedure TContainer.SetV(v: TTNode.TAlias); begin Data.Data:=v; end; diff --git a/tests/webtbs/tw10247b.pp b/tests/webtbs/tw10247b.pp index b94b745670..e0d7b88e5e 100644 --- a/tests/webtbs/tw10247b.pp +++ b/tests/webtbs/tw10247b.pp @@ -3,6 +3,7 @@ type generic TNode<T> = class public type + TAlias = T; PT = T; private var @@ -26,7 +27,7 @@ begin end; -function GetIntNode: TTNodeLongint.T; +function GetIntNode: TTNodeLongint.TAlias; begin result := 10; end; diff --git a/tests/webtbs/tw11563.pp b/tests/webtbs/tw11563.pp index ab2b693e2f..e7dbe477aa 100644 --- a/tests/webtbs/tw11563.pp +++ b/tests/webtbs/tw11563.pp @@ -18,6 +18,9 @@ program ExecStack; {$ifdef cpumips} ret: array[0..1] of longword; {$endif} +{$ifdef cpum68k} + ret: word; +{$endif} DoNothing: proc; begin @@ -51,7 +54,13 @@ program ExecStack; ret[1]:=0; { delay slot } DoNothing:=proc(@ret); DoNothing; -{$endif} +{$endif cpumips} +{$ifdef cpum68k} + ret:=$4E75; + DoNothing:=proc(@ret); + DoNothing; +{$endif cpum68k} + end; begin DoIt; diff --git a/tests/webtbs/tw17904.pas b/tests/webtbs/tw17904.pas index 06a01e7b2b..de8d8d5f08 100644 --- a/tests/webtbs/tw17904.pas +++ b/tests/webtbs/tw17904.pas @@ -8,7 +8,7 @@ type TTest = class(TCustomVariantType) procedure Clear(var V: TVarData); override; procedure Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean); override; - procedure DispInvoke(Dest: PVarData; const Source: TVarData; CallDesc: PCallDesc; Params: Pointer); override; + procedure DispInvoke(Dest: PVarData; var Source: TVarData; CallDesc: PCallDesc; Params: Pointer); override; end; procedure TTest.Clear(var V: TVarData); @@ -19,7 +19,7 @@ procedure TTest.Copy(var Dest: TVarData; const Source: TVarData; const Indirect: begin end; -procedure TTest.DispInvoke(Dest: PVarData; const Source: TVarData; CallDesc: PCallDesc; Params: Pointer); +procedure TTest.DispInvoke(Dest: PVarData; var Source: TVarData; CallDesc: PCallDesc; Params: Pointer); var tmp: Word; begin diff --git a/tests/webtbs/tw19452.pp b/tests/webtbs/tw19452.pp new file mode 100644 index 0000000000..e2d9163775 --- /dev/null +++ b/tests/webtbs/tw19452.pp @@ -0,0 +1,17 @@ +{ %norun } + +{$mode objfpc} +type + TMyObject = class + public + constructor Create(ar: array of TMyObject); + end; + +constructor TMyObject.Create(ar: array of TMyObject); +begin +end; + +begin + TMyObject.Create([nil]); +end. + diff --git a/tests/webtbs/tw19452a.pp b/tests/webtbs/tw19452a.pp new file mode 100644 index 0000000000..89cd2daaf5 --- /dev/null +++ b/tests/webtbs/tw19452a.pp @@ -0,0 +1,24 @@ +{ %norun } + +{$mode objfpc} +type + TMyObject = class; + TArr = array of TMyObject; + TMyObject = class + public + constructor Create(ar: array of TMyObject); overload; + constructor Create(ar: TArr); overload; + end; + +constructor TMyObject.Create(ar: array of TMyObject); +begin +end; + +constructor TMyObject.Create(ar: Tarr); +begin +end; + +begin + TMyObject.Create([nil]); +end. + diff --git a/tests/webtbs/tw19622.pp b/tests/webtbs/tw19622.pp index d5f5e6d66f..902b56fcbf 100644 --- a/tests/webtbs/tw19622.pp +++ b/tests/webtbs/tw19622.pp @@ -1,33 +1,7 @@ -Var a,b:qword; - c:boolean; - aa,bb:longword; +var + c:boolean; Begin - a:=qword($FFFFFFFFFFFFFFFF); - b:=9223372036854775807; - c:=a>b; - if not c then + c:=18446744073709551615>=9223372036854775807; + if not(c) then halt(1); - if not(qword($FFFFFFFFFFFFFFFF)>9223372036854775807) then - halt(2); - c:=qword($FFFFFFFFFFFFFFFF)>b; - if not c then - halt(3); - c:=18446744073709551615>=9223372036854775807; - if not c then - halt(4); - - - aa:=$FFFFFFFF; - bb:=2147483647; - c:=aa>bb; - if not c then - halt(5); - if not ($FFFFFFFF>2147483647) then - halt(6); - c:=$FFFFFFFF>bb; - if not c then - halt(7); - c:=4294967295>=2147483647; - if not c then - halt(8); End. diff --git a/tests/webtbs/tw21449.pp b/tests/webtbs/tw21449.pp new file mode 100644 index 0000000000..211fbee837 --- /dev/null +++ b/tests/webtbs/tw21449.pp @@ -0,0 +1,54 @@ +
+{$mode objfpc}{$H+}
+
+uses
+ Classes, SysUtils;
+
+type
+ data_record = record
+ amountStr:String;
+ amount:Currency;
+ end;
+
+const
+ kColCount = 5;
+ kFormatString:array[0..kColCount-1]of String = ( '%1.0f', '%1.1f', '%1.2f', '%1.3f', '%1.4f' );
+
+ kRowCount = 2;
+ kTestData:array[0..kRowCount-1] of data_record = (
+ (amountStr:'209.98'; amount:209.98 ),
+ (amountStr:'9.94'; amount:9.94 ) );
+ ExpectedResults: array[0..kRowCount-1,0..kColCount-1] of string =
+ (('210','210.0','209.98','209.980','209.9800'),
+ ('10','9.9','9.94','9.940','9.9400'));
+
+procedure test;
+var
+ amount:Currency;
+ index:Integer;
+ rowIndex:Integer;
+begin
+ rowIndex := 0;
+ while( rowIndex < kRowCount )do
+ begin
+ val(kTestData[rowIndex].amountStr,amount,index);
+ if index<>0 then
+ halt(1);
+ write(kTestData[rowIndex].amountStr,' -- ',amount:0:4,': ');
+ index := 0;
+ while( index < kColCount )do
+ begin
+ write(Format( kFormatString[index], [amount] ),',');
+ if Format( kFormatString[index], [amount] )<>ExpectedResults[rowindex,index] then
+ halt(2);
+ Inc( index );
+ end;
+ writeln;
+ Inc( rowIndex );
+ end;
+end;
+
+begin
+ test;
+end.
+
diff --git a/tests/webtbs/tw22376.pp b/tests/webtbs/tw22376.pp new file mode 100644 index 0000000000..a65730ae97 --- /dev/null +++ b/tests/webtbs/tw22376.pp @@ -0,0 +1,26 @@ +{ %cpu=i386,x86_64 } +{ %opt=-Cg- } +{$mode objfpc} +{$asmmode intel} + + +function bar: integer; +begin + result:=$12345678; +end; + +function foo: pointer; assembler; nostackframe; +asm +{$ifdef x86_64} + lea rax,[bar+rip] +{$else} + lea eax,[bar] +{$endif} +end; + + +begin + if (foo<>pointer(@bar)) then + halt(1); +end. + diff --git a/tests/webtbs/tw23109.pp b/tests/webtbs/tw23109.pp new file mode 100644 index 0000000000..a3c7a7d642 --- /dev/null +++ b/tests/webtbs/tw23109.pp @@ -0,0 +1,13 @@ +{ %cpu=x86_64} +{ %opt=-Cg -vew } + +var + global: boolean; public; +begin + asm + movq global@GOTPCREL(%rip), %rax + movb $1, (%rax) + end; + if not global then + halt(1); +end. diff --git a/tests/webtbs/tw23212.pp b/tests/webtbs/tw23212.pp index 9e6758be06..2263be45b3 100644 --- a/tests/webtbs/tw23212.pp +++ b/tests/webtbs/tw23212.pp @@ -10,7 +10,7 @@ Type End; { Record } TSomeRecord = Packed Record - Case A : Cardinal OF + Case x : Cardinal OF 0 : (A : TSomeRec1); End; { Record } diff --git a/tests/webtbs/tw24863.pp b/tests/webtbs/tw24863.pp index e408036117..2ded6a2823 100644 --- a/tests/webtbs/tw24863.pp +++ b/tests/webtbs/tw24863.pp @@ -1,4 +1,7 @@ { %OPT=-Sc } +{ %SKIPTARGET=go32v2 } +{ Test skipped for go32v2, because it forbids the + testsuite to complete without manually killing the program } program test2; {$mode objfpc}{$H+} diff --git a/tests/webtbs/tw24872.pp b/tests/webtbs/tw24872.pp new file mode 100644 index 0000000000..7830e91aae --- /dev/null +++ b/tests/webtbs/tw24872.pp @@ -0,0 +1,23 @@ +{ %NORUN } + +program tw24872; + +{$mode delphi} + +procedure Test; +begin +end; + +type + TRec<T> = record {for generic class is ok, and non generic record too} + procedure Foo; + end; + +procedure TRec<T>.Foo; +begin + Test +end; // Error: Global Generic template references static symtable + +begin +end. + diff --git a/tests/webtbs/tw25606.pp b/tests/webtbs/tw25606.pp new file mode 100644 index 0000000000..3df0e08dba --- /dev/null +++ b/tests/webtbs/tw25606.pp @@ -0,0 +1,17 @@ +{ %NORUN } + +program tw25606; + +{$MODE DELPHI} + +type + TValueInt32Helper = record helper for Int32 + const + C{: Int32} = 0; + end; + +var + I: Int32 = Int32.C; +begin +end. + diff --git a/tests/webtbs/tw25916a.pp b/tests/webtbs/tw25916a.pp new file mode 100644 index 0000000000..6d65556d14 --- /dev/null +++ b/tests/webtbs/tw25916a.pp @@ -0,0 +1,14 @@ +{ %OPT=-Sh} +{$MODE OBJFPC} +{$OPTIMIZATION DFA} +{$HINTS ON} +program test; + +procedure TestText(var F: Text); +begin + Writeln(F, 'Test'); // Hint: Local variable "F" does not seem to be initialized +end; + +begin + TestText(Output); +end. diff --git a/tests/webtbs/tw25916b.pp b/tests/webtbs/tw25916b.pp new file mode 100644 index 0000000000..907c59e876 --- /dev/null +++ b/tests/webtbs/tw25916b.pp @@ -0,0 +1,13 @@ +{ %OPT=-Sh} +{$MODE OBJFPC} +{$OPTIMIZATION DFA} +{$HINTS ON} +program test; + +procedure TestText(var F: longint); +begin + TestText(F); +end; + +begin +end. diff --git a/tests/webtbs/tw25917.pp b/tests/webtbs/tw25917.pp new file mode 100644 index 0000000000..4b0977088c --- /dev/null +++ b/tests/webtbs/tw25917.pp @@ -0,0 +1,34 @@ +{ %NORUN } + +program tw25917; + +{$APPTYPE CONSOLE} +{$MODE DELPHI} + +type + TA<T1, T2> = class + end; + + TB<T1, T2> = class + private + type + T3 = record end; + + TC = class(TA<T1, T3>) + public + procedure Foo; + end; + end; + +procedure TB<T1, T2>.TC.Foo; +var + L: TB<T1, T2>.T3; +begin +end; + +var + x: TB<Pointer, Pointer>; + +begin +end. + diff --git a/tests/webtbs/tw26069.pp b/tests/webtbs/tw26069.pp new file mode 100644 index 0000000000..95e8130c88 --- /dev/null +++ b/tests/webtbs/tw26069.pp @@ -0,0 +1,23 @@ +{ %norun } +Unit tw26069; + +{$mode delphi} + +Interface + +Type + TClass1 = Class + Type + TReason = (rnOne, rnTwo); + End; + + TClass2 = Class + Type + TReason = (rn1, rn2); + End; + + +Implementation + +End. + diff --git a/tests/webtbs/tw26075.pp b/tests/webtbs/tw26075.pp new file mode 100644 index 0000000000..251c252a01 --- /dev/null +++ b/tests/webtbs/tw26075.pp @@ -0,0 +1,35 @@ +program fpc_advrec_bug; + +{$mode delphi} +{$optimization off} + +Uses TypInfo; + +Type + + PTypeInfoRec = Record + FValue : PTypeInfo; + Function QualifiedName : String; + End; + +Function PTypeInfoRec.QualifiedName : String; +Begin + Result := ''; +End; + +function Test : Pointer; +Begin + Result := nil; +End; + +Var + + p : PTypeInfo; + +begin + + PTypeInfoRec(p).QualifiedName; // OK + PTypeInfoRec(Test).QualifiedName; // OK + PTypeInfoRec(TypeInfo(String)).QualifiedName; // Internal error 200304235 + +end. diff --git a/tests/webtbs/tw26075b.pp b/tests/webtbs/tw26075b.pp new file mode 100644 index 0000000000..37d7812dbd --- /dev/null +++ b/tests/webtbs/tw26075b.pp @@ -0,0 +1,35 @@ +program fpc_advrec_bug; + +{$mode delphi} +{$optimization off} + +Uses TypInfo; + +Type + + PTypeInfoRec = object + FValue : PTypeInfo; + Function QualifiedName : String; + End; + +Function PTypeInfoRec.QualifiedName : String; +Begin + Result := ''; +End; + +function Test : Pointer; +Begin + Result := nil; +End; + +Var + + p : PTypeInfo; + +begin + + PTypeInfoRec(p).QualifiedName; // OK + PTypeInfoRec(Test).QualifiedName; // OK + PTypeInfoRec(TypeInfo(String)).QualifiedName; // Internal error 200304235 + +end. diff --git a/tests/webtbs/tw26403.pp b/tests/webtbs/tw26403.pp new file mode 100644 index 0000000000..9dee0fb10b --- /dev/null +++ b/tests/webtbs/tw26403.pp @@ -0,0 +1,23 @@ +{ %OPT=-Sew } +{$OPTIMIZATION DFA} +{$HINTS ON} +program test; + +type + TIntArray = array of Integer; + +procedure Reset(var Foo: TIntArray); +begin + SetLength(Foo, 0); +end; + +procedure Foo(var Bar: TIntArray); +begin + Reset(Bar); // Hint: Local variable "Bar" does not seem to be initialized +end; + +var + Baz: TIntArray; +begin + Foo(Baz); // Hint: Local variable "Baz" does not seem to be initialized +end. diff --git a/tests/webtbs/tw26467.pp b/tests/webtbs/tw26467.pp new file mode 100644 index 0000000000..c172c4a2c6 --- /dev/null +++ b/tests/webtbs/tw26467.pp @@ -0,0 +1,19 @@ +{ %OPT=-Sew} +{$INLINE ON} +{$ASSERTIONS ON} +program test; + +procedure TestFunc(); +begin + Assert(True); +end; + +procedure TestFuncInline(); inline; +begin + Assert(True); +end; + +begin + TestFunc(); + TestFuncInline(); // Warning: unreachable code +end. diff --git a/tests/webtbs/tw26481.pp b/tests/webtbs/tw26481.pp new file mode 100644 index 0000000000..9c83cd5281 --- /dev/null +++ b/tests/webtbs/tw26481.pp @@ -0,0 +1,33 @@ +{ %NORUN } + +program tw26481; + +{$MODE DELPHI} + +type + IComparer<T> = interface + function Compare(constref Left, Right: T): Integer; overload; + end; + + TOrdinalComparer<T, THashFactory> = class(TInterfacedObject, IComparer<T>) + protected class var + FComparer: IComparer<T>; + FTest: TClass; + public + function Compare(constref Left, Right: T): Integer; virtual; abstract; + end; + + TGOrdinalStringComparer<T, THashFactory> = class(TOrdinalComparer<T, THashFactory>) + public + function Compare(constref ALeft, ARight: T): Integer; override; + end; + +function TGOrdinalStringComparer<THashFactory, T>.Compare(constref ALeft, + ARight: T): Integer; +begin + Result := FComparer.Compare(ALeft, ARight); +end; + +begin +end. + diff --git a/tests/webtbs/tw26482.pp b/tests/webtbs/tw26482.pp new file mode 100644 index 0000000000..df56ff95f4 --- /dev/null +++ b/tests/webtbs/tw26482.pp @@ -0,0 +1,25 @@ +unit tw26482; + +{$mode delphi} + +interface + +type + TEnumerator<T> = class + end; + + TList<T> = class + public + type + TEnumerator = class(TObject); + protected + function DoGetEnumerator: TEnumerator<T>; + end; + +implementation + +function TList<T>.DoGetEnumerator: TEnumerator<T>; // Error: Identifier not found "TEnumerator$1" +begin +end; + +end. diff --git a/tests/webtbs/tw26483.pp b/tests/webtbs/tw26483.pp new file mode 100644 index 0000000000..3da391e327 --- /dev/null +++ b/tests/webtbs/tw26483.pp @@ -0,0 +1,24 @@ +{ %NORUN } + +program tw26483; + +{$MODE DELPHI} + +type + TA<T> = class + private + F: Integer; + end; + + TB<T> = class + procedure Foo(A: TObject); + end; + +procedure TB<T>.Foo(A: TObject); +begin + WriteLn(TA<T>(A).F); // p004.Error: identifier idents no member "F" +end; + +begin +end. + diff --git a/tests/webtbs/tw26536.pp b/tests/webtbs/tw26536.pp new file mode 100644 index 0000000000..293cb6d6ef --- /dev/null +++ b/tests/webtbs/tw26536.pp @@ -0,0 +1,40 @@ +{$MODE OBJFPC} +program test; + +type + TBaseClass = class + function PrintSelf(): TBaseClass; inline; // has to be inline for the bug to manifest + end; + + TSubClass = class(TBaseClass) + end; + +function TBaseClass.PrintSelf(): TBaseClass; inline; +begin + Writeln(PtrUInt(Self)); + Result := nil; + Writeln(PtrUInt(Self)); // prints 0! + if not assigned(self) then + halt(1); +end; + +procedure NoOp(var Dummy: TBaseClass); +begin +end; + + +var + Instance, Variable: TBaseClass; + res: longint; +begin + Instance := TSubClass.Create(); + Variable := nil; + + NoOp(Variable); // this call is important for the bug to manifest + Variable := Instance; + // object being invoked has to be cast to a different type for the bug to manifest + // return value has to be assigned to the variable being used as "self" + Variable := TSubClass(Variable).PrintSelf(); + + Instance.Free(); +end. diff --git a/tests/webtbs/tw26599.pp b/tests/webtbs/tw26599.pp new file mode 100644 index 0000000000..1cc76c9a34 --- /dev/null +++ b/tests/webtbs/tw26599.pp @@ -0,0 +1,19 @@ +{ %NORUN } + +program tw26599; + +{$mode delphi} + +type + TSomeList<T : TObject> = Class + End; { Class } + + TSomeClass = Class; + TSomeClassList = TSomeList<TSomeClass>; + + TSomeClass = Class(TObject) + SomeList : TSomeClassList; + End; + +begin +end. diff --git a/tests/webtbs/tw26615.pp b/tests/webtbs/tw26615.pp new file mode 100644 index 0000000000..9fb3f179e2 --- /dev/null +++ b/tests/webtbs/tw26615.pp @@ -0,0 +1,29 @@ +{ %NORUN } + +program tw26615; + +{$MODE OBJFPC}{$H+} +{$MODESWITCH TYPEHELPERS} + +uses + sysutils; + +type + TStringHelper = type helper for UnicodeString + class function Cr(AStr: UnicodeString): UnicodeString; static; overload; + end; + +class function TStringHelper.Cr(AStr: UnicodeString): UnicodeString; +begin + Result := '#'+AStr; +end; + +var + us: UnicodeString; + +begin + + us := UnicodeString.Cr('a'); + writeln(us); + +end. diff --git a/tests/webtbs/tw26627.pp b/tests/webtbs/tw26627.pp new file mode 100644 index 0000000000..cc9a482124 --- /dev/null +++ b/tests/webtbs/tw26627.pp @@ -0,0 +1,16 @@ +program test; + +{$mode objfpc}{$h+} + +uses SysUtils; + +var a: ansistring; + +begin + defaultfilesystemcodepage:=CP_UTF8; + defaultrtlfilesystemcodepage:=CP_ASCII; + a := DirectorySeparator+'.'; + a := ExpandFileName(a); + if StringCodePage(a)<> defaultrtlfilesystemcodepage then + halt(1); +end.
\ No newline at end of file diff --git a/tests/webtbs/tw26668.pp b/tests/webtbs/tw26668.pp new file mode 100644 index 0000000000..8f03ddb6d5 --- /dev/null +++ b/tests/webtbs/tw26668.pp @@ -0,0 +1,34 @@ +{ %CPU=i386 } +{ %OPT=-Cg- } + +{$mode delphi} +const __dd = 1; +function f1 (var p : longword) : byte; +asm + lea eax, [ eax + 2 ] + mov al, [eax - __dd + 1].byte +end; + +function f2 (var p : longword) : byte; +asm + lea eax, [ eax + 2 ] + mov al, [eax - __dd].byte [1] +end; + +function f3 (var p : longword) : byte; +asm + lea eax, [ eax + 2 ] + mov al, [eax - 1 + 1].byte +end; + +var v : longword = $01020304; + +begin + { all three functions must produce the same code } + if f1(v)<>2 then + halt(1); + if f2(v)<>2 then + halt(2); + if f3(v)<>2 then + halt(3); +end. diff --git a/tests/webtbs/tw26749.pp b/tests/webtbs/tw26749.pp new file mode 100644 index 0000000000..600f9204c8 --- /dev/null +++ b/tests/webtbs/tw26749.pp @@ -0,0 +1,27 @@ +{ %NORUN } + +program tw26749; + +{$mode delphi} +{$modeswitch advancedrecords} + +type + + { TVector3 } + + TVector3<T> = record + class function null : TVector3<T>; static; + end; + + TLine<T> = array[0..1] of TVector3<T>; + +{ TVector3<T> } + +class function TVector3<T>.null : TVector3<T>; +begin + +end; + +begin +end. + diff --git a/tests/webtbs/tw26773.pp b/tests/webtbs/tw26773.pp new file mode 100644 index 0000000000..fa690065e5 --- /dev/null +++ b/tests/webtbs/tw26773.pp @@ -0,0 +1,161 @@ +program SourceBug; + +{$APPTYPE CONSOLE} + +{$ifdef FPC} +{$MODE Delphi} +{$endif} + +uses + Variants, + SysUtils; + +type + TSampleVariant = class(TInvokeableVariantType) + protected + {$ifndef FPC} + function FixupIdent(const AText: string): string; override; + {$endif} + public + procedure Clear(var V: TVarData); override; + procedure Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean ); override; + function GetProperty(var Dest: TVarData; const V: TVarData; + const Name: string): Boolean; override; + function SetProperty(var V: TVarData; const Name: string; + const Value: TVarData): Boolean; override; + end; + +procedure TSampleVariant.Clear(var V: TVarData); +begin + V.VType:=varEmpty; +end; + +procedure TSampleVariant.Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean); +begin + if Indirect and VarDataIsByRef(Source) then + VarDataCopyNoInd(Dest, Source) + else with Dest do + VType:=Source.VType; +end; + +{$ifndef FPC} +function TSampleVariant.FixupIdent(const AText: string): string; +begin + result := AText; // we do not want any uppercase names +end; +{$endif} + +function TSampleVariant.GetProperty(var Dest: TVarData; const V: TVarData; + const Name: string): Boolean; +begin + assert(V.VType=varType); + if Name='IntField' then + begin + variant(Dest) := V.VInt64; + result := true; + end + else if Name='FloatField' then + begin + variant(Dest) := V.VDouble; + result := true; + end + else if Name='BoolField' then + begin + variant(Dest) := V.VBoolean; + result := true; + end + else + result := false; +end; + +function TSampleVariant.SetProperty(var V: TVarData; const Name: string; + const Value: TVarData): Boolean; +begin + assert(V.VType=varType); + if Name='IntField' then + begin + PVarData(@V)^.VInt64 := variant(Value); + result := true; + end + else if Name='FloatField' then + begin + PVarData(@V)^.VDouble := variant(Value); + result := true; + end + else if Name='BoolField' then + begin + PVarData(@V)^.VBoolean := variant(Value); + result := true; + end + else + result := false; +end; + +var + SampleVariant: TSampleVariant; + v: Variant; + + GB1 : Byte; + GS1 : Shortint; + GW : Word; + GL : longint; + gsi : single; + gd : double; + gi64 : int64; + gdate: tdatetime; + gb: boolean; +begin + SampleVariant:=TSampleVariant.Create; + v := null; + TVarData(v).VType:=SampleVariant.VarType; + v.IntField := 100; + if v.IntField<>100 then + halt(1); + + gb1:=128; + gs1:=127; + gw:=32768; + gl:=longint($b100dbad); + gsi:=12345789.5; + gd:=999991234889879.5; + gi64:=$813245678901234; + gdate:=now; + gb:=false; + + v.IntField:=gb1; + if v.IntField<>gb1 then + halt(2); + + v.IntField:=gs1; + if v.IntField<>gs1 then + halt(3); + + v.IntField:=gw; + if v.IntField<>gw then + halt(4); + + v.IntField:=gl; + if v.IntField<>gl then + halt(5); + + v.FloatField:=gsi; + if v.FloatField<>gsi then + halt(6); + + v.FloatField:=gd; + if v.FloatField<>gd then + halt(7); + + v.IntField:=gi64; + if v.IntField<>gi64 then + halt(8); + + v.FloatField:=gdate; + if v.FloatField<>gdate then + halt(9); + + v.BoolField:=gb; + if boolean(v.BoolField)<>gb then + halt(10); + +end. diff --git a/tests/webtbs/tw26922.pp b/tests/webtbs/tw26922.pp new file mode 100644 index 0000000000..0414610bba --- /dev/null +++ b/tests/webtbs/tw26922.pp @@ -0,0 +1,12 @@ +{ %INTERACTIVE } +{ This test requires a change in uw26922a for recompilation which can not be done automatically by + simply adding a define, because the compiler won't detect that it needs to recompile that unit } + +program tw26922; + +uses + uw26922a, uw26922b; + +begin +end. + diff --git a/tests/webtbs/tw26976.pp b/tests/webtbs/tw26976.pp new file mode 100644 index 0000000000..f8ec0e1854 --- /dev/null +++ b/tests/webtbs/tw26976.pp @@ -0,0 +1,17 @@ +{ %norun } + +{$MODE OBJFPC} +program test; + +type + TTest = class end; + +procedure E(Arg1: array of UTF8String); +begin end; + +procedure E(Arg1: array of TTest); +begin end; + +begin + E(['aa']); // Incompatible types: got "Constant String" expected "TTest" +end. diff --git a/tests/webtbs/tw26993.pp b/tests/webtbs/tw26993.pp new file mode 100644 index 0000000000..2094cc2d87 --- /dev/null +++ b/tests/webtbs/tw26993.pp @@ -0,0 +1,49 @@ +program tw26993; + +{$mode delphi} + +uses + Classes, SysUtils; + +type + + { TExtendedTestCase } + + TExtendedTestCase = record + private + FValue: extended; + public + property Value: extended read FValue write FValue; + class operator Add(v1, v2: TExtendedTestCase): TExtendedTestCase; + class operator Multiply(v1, v2: TExtendedTestCase): TExtendedTestCase; + end; + + +{ TExtendedTestCase } + +class operator TExtendedTestCase.Add(v1, v2: TExtendedTestCase): TExtendedTestCase; +begin + Result.Value := v1.Value + v2.Value; +end; + +class operator TExtendedTestCase.Multiply(v1, v2: TExtendedTestCase): +TExtendedTestCase; +begin + Result.Value := v1.Value * v2.Value; +end; + +var + e1,e2,e3: textendedtestcase; +begin + e1.fvalue:=2.0; + e2.fvalue:=3.0; + e3:=e1+e2; + if (e3*e2).fvalue<>15.0 then + halt(1); + +end. + + + + + diff --git a/tests/webtbs/tw26993a.pp b/tests/webtbs/tw26993a.pp new file mode 100644 index 0000000000..95813a9c9c --- /dev/null +++ b/tests/webtbs/tw26993a.pp @@ -0,0 +1,50 @@ +program tw26993a; + +{$mode delphi} + +uses + Classes, SysUtils; + +type + + { TExtendedTestCase } + + TExtendedTestCase = record + private + FValue: extended; + dummy: array[0..5] of byte; + public + property Value: extended read FValue write FValue; + class operator Add(v1, v2: TExtendedTestCase): TExtendedTestCase; + class operator Multiply(v1, v2: TExtendedTestCase): TExtendedTestCase; + end; + + +{ TExtendedTestCase } + +class operator TExtendedTestCase.Add(v1, v2: TExtendedTestCase): TExtendedTestCase; +begin + Result.Value := v1.Value + v2.Value; +end; + +class operator TExtendedTestCase.Multiply(v1, v2: TExtendedTestCase): +TExtendedTestCase; +begin + Result.Value := v1.Value * v2.Value; +end; + +var + e1,e2,e3: textendedtestcase; +begin + e1.fvalue:=2.0; + e2.fvalue:=3.0; + e3:=e1+e2; + if (e3*e2).fvalue<>15.0 then + halt(1); + +end. + + + + + diff --git a/tests/webtbs/tw27029.pp b/tests/webtbs/tw27029.pp new file mode 100644 index 0000000000..0f31f51b04 --- /dev/null +++ b/tests/webtbs/tw27029.pp @@ -0,0 +1,11 @@ +uses + sysutils, math; + +begin + DecimalSeparator:=','; + if FloatToStrF(nan, ffExponent, 15, 1)<>'Nan' then + halt(1); + if FloatToStrF(1.3, ffExponent, 15, 1)[2]<>',' then + halt(1); + writeln('ok'); +end. diff --git a/tests/webtbs/tw27120.pp b/tests/webtbs/tw27120.pp new file mode 100644 index 0000000000..7f4d9d0a75 --- /dev/null +++ b/tests/webtbs/tw27120.pp @@ -0,0 +1,18 @@ +{ %NORUN } + +program tw27120; + +{$mode objfpc} + +type + TFoo = class + end; + + TBar = class helper for TFoo + private class var + FFoo: TFoo; + end; + +begin + +end. diff --git a/tests/webtbs/tw27153.pp b/tests/webtbs/tw27153.pp new file mode 100644 index 0000000000..e8b15ce373 --- /dev/null +++ b/tests/webtbs/tw27153.pp @@ -0,0 +1,3 @@ +{ %OPT=-CPPACKENUM=1 -CPPACKRECORD=1 -CPPACKSET=1} +begin +end. diff --git a/tests/webtbs/tw27173.pp b/tests/webtbs/tw27173.pp new file mode 100644 index 0000000000..3eb3f043aa --- /dev/null +++ b/tests/webtbs/tw27173.pp @@ -0,0 +1,16 @@ +program error; + +{$mode Delphi} + +uses sysutils; + +type a = 1..MaxInt; + +var b: a; + c: integer; + +begin + b := 3; + c := -5 div b; + writeln(c); +end. diff --git a/tests/webtbs/tw27185.pp b/tests/webtbs/tw27185.pp new file mode 100644 index 0000000000..d90ef66c48 --- /dev/null +++ b/tests/webtbs/tw27185.pp @@ -0,0 +1,99 @@ +program tw27185; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX}{$IFDEF UseCThreads} + cthreads, + {$ENDIF}{$ENDIF} + Classes + { you can add units after this }; + +var + NormalClassInit: Boolean = False; + NormalClassDone: Boolean = False; + NestedTypeClassInit: Boolean = False; + NestedTypeClassDone: Boolean = False; + NestedTypeClassNestedClassInit: Boolean = False; + NestedTypeClassNestedClassDone: Boolean = False; + +Type + + { TNormalClass } + + TNormalClass = class + public + class constructor Create; + class destructor Destroy; + end; + + { TNestedTypeClass } + + TNestedTypeClass = class + private + type + + { TNestedClass } + + TNestedClass = class + public + class constructor Create; + class destructor Destroy; + end; + + public + class constructor Create; + class destructor Destroy; + end; + +{ TNestedTypeClass } + +class constructor TNestedTypeClass.Create; +begin + NestedTypeClassInit := True; + //WriteLn('class constructor TNestedTypeClass.Create'); +end; + +class destructor TNestedTypeClass.Destroy; +begin + NestedTypeClassDone := True; + //WriteLn('class destructor TNestedTypeClass.Destroy'); +end; + +{ TNormalClass } + +class constructor TNormalClass.Create; +begin + NormalClassInit := True; + //WriteLn('class constructor TNormalClass.Create'); +end; + +class destructor TNormalClass.Destroy; +begin + NormalClassDone := False; + //WriteLn('class destructor TNormalClass.Destroy'); +end; + +{ TNestedTypeClass.TNestedClass } + +class constructor TNestedTypeClass.TNestedClass.Create; +begin + NestedTypeClassNestedClassInit := True; + //WriteLn('class constructor TNestedTypeClass.TNestedClass.Create'); +end; + +class destructor TNestedTypeClass.TNestedClass.Destroy; +begin + NestedTypeClassNestedClassDone := True; + //WriteLn('class destructor TNestedTypeClass.TNestedClass.Destroy'); +end; + +begin + if not NormalClassInit then + Halt(1); + if not NestedTypeClassInit then + Halt(2); + if not NestedTypeClassNestedClassInit then + Halt(3); +end. + diff --git a/tests/webtbs/tw27256.pp b/tests/webtbs/tw27256.pp new file mode 100644 index 0000000000..bd7752f16d --- /dev/null +++ b/tests/webtbs/tw27256.pp @@ -0,0 +1,25 @@ +program Test; + +type + FullType = (Unknown,Stiletto,Vanguard); + SubType = Stiletto..Vanguard; + +const + full_choices: array[FullType] of String = ('U','S','V'); + sub_choices: array[SubType] of String = ('S', 'V'); + +var + x : longint; + +procedure abc(choices: array of String); +begin + inc(x,high(choices)); +end; + +begin + abc(full_choices); + abc(sub_choices); + if x<>3 then + halt(1); + writeln('ok'); +end. diff --git a/tests/webtbs/tw27294.pp b/tests/webtbs/tw27294.pp new file mode 100644 index 0000000000..34d14f5df2 --- /dev/null +++ b/tests/webtbs/tw27294.pp @@ -0,0 +1,26 @@ +uses + uw27294; + +var + p : procedure; + +procedure test; + +begin + p:=@test; + writeln('OK'); +end; + +procedure global; +begin + p:=nil; + test; + p(); +end; + +begin + global; + uw27294.global; +end. + + diff --git a/tests/webtbs/tw27300a.pp b/tests/webtbs/tw27300a.pp new file mode 100644 index 0000000000..46e5262bf9 --- /dev/null +++ b/tests/webtbs/tw27300a.pp @@ -0,0 +1,22 @@ +{ %target=win32,win64,wince } +{ %norun } +program Project1; + +uses + Classes; + +const + kernel32 = 'kernel32.dll'; + +type + BOOL = Boolean; + HANDLE = THandle; + +function OpenThread( + {_In_} dwDesiredAccess: DWORD; + {_In_} bInheritHandle: BOOL; + {_In_} dwThreadId: DWORD +): HANDLE; WINAPI; external kernel32; + +begin +end. diff --git a/tests/webtbs/tw8513.pp b/tests/webtbs/tw8513.pp index 8a37d84c0d..31b45fbbad 100644 --- a/tests/webtbs/tw8513.pp +++ b/tests/webtbs/tw8513.pp @@ -14,6 +14,7 @@ end; var Item: TMyType; ItemAsByte: byte absolute Item; + ItemAsWord: word absolute Item; r: tr; b: byte absolute r.b; @@ -40,6 +41,13 @@ begin if (itemasbyte <> $de) then halt(1); +{$ifdef FPC_BIG_ENDIAN} + if (itemasword <> $dead) then +{$else} + if (itemasword <> $adde) then +{$endif} + halt(3); + r.a := $de; r.b := $ad; r.c := $be; diff --git a/tests/webtbs/tw9162.pp b/tests/webtbs/tw9162.pp index 7c2b66c45f..41e30bd656 100644 --- a/tests/webtbs/tw9162.pp +++ b/tests/webtbs/tw9162.pp @@ -11,7 +11,7 @@ type protected procedure Clear(var V: TVarData); override; procedure Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean ); override; - procedure DispInvoke(Dest: PVarData; const Source: TVarData; CallDesc: PCallDesc; Params: Pointer); override; + procedure DispInvoke(Dest: PVarData; var Source: TVarData; CallDesc: PCallDesc; Params: Pointer); override; end; procedure TSampleVariant.Clear(var V: TVarData); @@ -30,7 +30,7 @@ end; var p : pointer; -procedure TSampleVariant.DispInvoke(Dest: PVarData; const Source: TVarData; CallDesc: PCallDesc; Params: Pointer); +procedure TSampleVariant.DispInvoke(Dest: PVarData; var Source: TVarData; CallDesc: PCallDesc; Params: Pointer); begin Writeln('Dest is 0x', IntToStr(Cardinal(Dest))); p:=Dest; diff --git a/tests/webtbs/tw9461.pp b/tests/webtbs/tw9461.pp index c6bf21a4c6..db27334eae 100644 --- a/tests/webtbs/tw9461.pp +++ b/tests/webtbs/tw9461.pp @@ -3,7 +3,9 @@ procedure p; assembler; var i : longint; asm +{$ifndef CPUTHUMB} mla r0,r1,r2,r3 +{$endif CPUTHUMB} end; begin diff --git a/tests/webtbs/uw26922a.pp b/tests/webtbs/uw26922a.pp new file mode 100644 index 0000000000..997bc0f255 --- /dev/null +++ b/tests/webtbs/uw26922a.pp @@ -0,0 +1,28 @@ +unit uw26922a; + +{$mode objfpc}{$H+} + +interface + +uses + unit2_test; + +Type + TTestAbstract = class + + end; + + TTest = class; + + TTestObject = class(specialize TTestObjectAbstract<TTest>); + + // Note: uncomment TTestAbstract when for recompilation + TTest = class//(TTestAbstract) + public + end; + + +implementation + +end. + diff --git a/tests/webtbs/uw26922b.pp b/tests/webtbs/uw26922b.pp new file mode 100644 index 0000000000..5afb1fd0eb --- /dev/null +++ b/tests/webtbs/uw26922b.pp @@ -0,0 +1,20 @@ +unit uw26922b; + +{$mode objfpc}{$H+} + +interface + +Type + generic TTestObjectAbstract<T> = class + private + var + FTest : T; + end; + +implementation + +uses + uw26922a; + +end. + diff --git a/tests/webtbs/uw27294.pp b/tests/webtbs/uw27294.pp new file mode 100644 index 0000000000..7a6407a033 --- /dev/null +++ b/tests/webtbs/uw27294.pp @@ -0,0 +1,28 @@ +unit + uw27294; + +interface + +procedure global; + +implementation + +var + p : procedure; + +procedure test; + +begin + p:=@test; + writeln('OK'); +end; + +procedure global; +begin + p:=nil; + test; + p(); +end; + +end. + |