diff --git a/tests/Makefile b/tests/Makefile new file mode 100644 index 0000000000..b15443d458 --- /dev/null +++ b/tests/Makefile @@ -0,0 +1,1231 @@ +# +# Makefile generated by fpcmake v1.00 [2000/10/27] +# + +defaultrule: alltests + +##################################################################### +# Autodetect OS (Linux or Dos or Windows NT) +# define inUnix when running under Unix (Linux,FreeBSD) +# define inWinNT when running under WinNT +##################################################################### + +# We need only / in the path +override PATH:=$(subst \,/,$(PATH)) + +# Search for PWD and determine also if we are under linux +PWD:=$(strip $(wildcard $(addsuffix /pwd.exe,$(subst ;, ,$(PATH))))) +ifeq ($(PWD),) +PWD:=$(strip $(wildcard $(addsuffix /pwd,$(subst :, ,$(PATH))))) +ifeq ($(PWD),) +nopwd: + @echo You need the GNU utils package to use this Makefile! + @echo Get ftp://ftp.freepascal.org/pub/fpc/dist/go32v2/utilgo32.zip + @exit +else +inUnix=1 +endif +else +PWD:=$(firstword $(PWD)) +endif + +# Detect NT - NT sets OS to Windows_NT +# Detect OS/2 - OS/2 has OS2_SHELL defined +ifndef inUnix +ifeq ($(OS),Windows_NT) +inWinNT=1 +else +ifdef OS2_SHELL +inOS2=1 +endif +endif +endif + +# The extension of executables +ifdef inUnix +SRCEXEEXT= +else +SRCEXEEXT=.exe +endif + +# The path which is searched separated by spaces +ifdef inUnix +SEARCHPATH=$(subst :, ,$(PATH)) +else +SEARCHPATH=$(subst ;, ,$(PATH)) +endif + +# Base dir +ifdef PWD +BASEDIR:=$(shell $(PWD)) +else +BASEDIR=. +endif + +##################################################################### +# FPC version/target Detection +##################################################################### + +# What compiler to use ? +ifndef FPC +# Compatibility with old makefiles +ifdef PP +FPC=$(PP) +else +FPC=ppc386 +endif +endif +override FPC:=$(subst $(SRCEXEEXT),,$(FPC)) +override FPC:=$(subst \,/,$(FPC))$(SRCEXEEXT) + +# Target OS +ifndef OS_TARGET +OS_TARGET:=$(shell $(FPC) -iTO) +endif + +# Source OS +ifndef OS_SOURCE +OS_SOURCE:=$(shell $(FPC) -iSO) +endif + +# Target CPU +ifndef CPU_TARGET +CPU_TARGET:=$(shell $(FPC) -iTP) +endif + +# Source CPU +ifndef CPU_SOURCE +CPU_SOURCE:=$(shell $(FPC) -iSP) +endif + +# FPC version +ifndef FPC_VERSION +FPC_VERSION:=$(shell $(FPC) -iV) +endif + +export FPC OS_TARGET OS_SOURCE CPU_TARGET CPU_SOURCE FPC_VERSION + +##################################################################### +# FPCDIR Setting +##################################################################### + +# Test FPCDIR to look if the RTL dir exists +ifdef FPCDIR +override FPCDIR:=$(subst \,/,$(FPCDIR)) +ifeq ($(wildcard $(FPCDIR)/rtl),) +ifeq ($(wildcard $(FPCDIR)/units),) +override FPCDIR=wrong +endif +endif +else +override FPCDIR=wrong +endif + +# Detect FPCDIR +ifeq ($(FPCDIR),wrong) +ifdef inUnix +override FPCDIR=/usr/local/lib/fpc/$(FPC_VERSION) +ifeq ($(wildcard $(FPCDIR)/units),) +override FPCDIR=/usr/lib/fpc/$(FPC_VERSION) +endif +else +override FPCDIR:=$(subst /$(FPC),,$(firstword $(strip $(wildcard $(addsuffix /$(FPC),$(SEARCHPATH)))))) +override FPCDIR:=$(FPCDIR)/.. +ifeq ($(wildcard $(FPCDIR)/rtl),) +ifeq ($(wildcard $(FPCDIR)/units),) +override FPCDIR:=$(FPCDIR)/.. +ifeq ($(wildcard $(FPCDIR)/rtl),) +ifeq ($(wildcard $(FPCDIR)/units),) +override FPCDIR=c:/pp +endif +endif +endif +endif +endif +endif + +##################################################################### +# User Settings +##################################################################### + + +# Targets + + +# Clean + + +# Install + +ZIPTARGET=install + +# Defaults + + +# Directories + + +# Packages + + +# Libraries + + +# Info + +INFOTARGET=fpc_infocfg fpc_infoobjects fpc_infoinstall + +##################################################################### +# Shell tools +##################################################################### + +# echo +ifndef ECHO +ECHO:=$(strip $(wildcard $(addsuffix /gecho$(EXEEXT),$(SEARCHPATH)))) +ifeq ($(ECHO),) +ECHO:=$(strip $(wildcard $(addsuffix /echo$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(ECHO),) +ECHO:=echo +ECHOE:=echo +else +ECHO:=$(firstword $(ECHO)) +ECHOE=$(ECHO) -E +endif +else +ECHO:=$(firstword $(ECHO)) +ECHOE=$(ECHO) -E +endif +endif + +# To copy pograms +ifndef COPY +COPY:=cp -fp +endif + +# Copy a whole tree +ifndef COPYTREE +COPYTREE:=cp -rfp +endif + +# To move pograms +ifndef MOVE +MOVE:=mv -f +endif + +# Check delete program +ifndef DEL +DEL:=rm -f +endif + +# Check deltree program +ifndef DELTREE +DELTREE:=rm -rf +endif + +# To install files +ifndef INSTALL +ifdef inUnix +INSTALL:=install -c -m 644 +else +INSTALL:=$(COPY) +endif +endif + +# To install programs +ifndef INSTALLEXE +ifdef inUnix +INSTALLEXE:=install -c -m 755 +else +INSTALLEXE:=$(COPY) +endif +endif + +# To make a directory. +ifndef MKDIR +ifdef inUnix +MKDIR:=install -m 755 -d +else +MKDIR:=ginstall -m 755 -d +endif +endif + +export ECHO ECHOE COPY COPYTREE MOVE DEL DELTREE INSTALL INSTALLEXE MKDIR + +##################################################################### +# Default Tools +##################################################################### + +# assembler, redefine it if cross compiling +ifndef AS +AS=as +endif + +# linker, but probably not used +ifndef LD +LD=ld +endif + +# ppas.bat / ppas.sh +ifdef inUnix +PPAS=ppas.sh +else +ifdef inOS2 +PPAS=ppas.cmd +else +PPAS=ppas.bat +endif +endif + +# ldconfig to rebuild .so cache +ifdef inUnix +LDCONFIG=ldconfig +else +LDCONFIG= +endif + +# ppumove +ifndef PPUMOVE +PPUMOVE:=$(strip $(wildcard $(addsuffix /ppumove$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(PPUMOVE),) +PPUMOVE= +else +PPUMOVE:=$(firstword $(PPUMOVE)) +endif +endif +export PPUMOVE + +# ppufiles +ifndef PPUFILES +PPUFILES:=$(strip $(wildcard $(addsuffix /ppufiles$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(PPUFILES),) +PPUFILES= +else +PPUFILES:=$(firstword $(PPUFILES)) +endif +endif +export PPUFILES + +# Look if UPX is found for go32v2 and win32. We can't use $UPX becuase +# upx uses that one itself (PFV) +ifndef UPXPROG +ifeq ($(OS_TARGET),go32v2) +UPXPROG:=1 +endif +ifeq ($(OS_TARGET),win32) +UPXPROG:=1 +endif +ifdef UPXPROG +UPXPROG:=$(strip $(wildcard $(addsuffix /upx$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(UPXPROG),) +UPXPROG= +else +UPXPROG:=$(firstword $(UPXPROG)) +endif +else +UPXPROG= +endif +endif +export UPXPROG + +# ZipProg, you can't use Zip as the var name (PFV) +ifndef ZIPPROG +ZIPPROG:=$(strip $(wildcard $(addsuffix /zip$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(ZIPPROG),) +ZIPPROG= +else +ZIPPROG:=$(firstword $(ZIPPROG)) +endif +endif +export ZIPPROG + +ZIPOPT=-9 +ZIPEXT=.zip + +# Tar +ifndef TARPROG +TARPROG:=$(strip $(wildcard $(addsuffix /tar$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(TARPROG),) +TARPROG= +else +TARPROG:=$(firstword $(TARPROG)) +endif +endif +export TARPROG + +ifeq ($(USETAR),bz2) +TAROPT=vI +TAREXT=.tar.bz2 +else +TAROPT=vz +TAREXT=.tar.gz +endif + +##################################################################### +# Default extensions +##################################################################### + +# Default needed extensions (Go32v2,Linux) +LOADEREXT=.as +EXEEXT=.exe +PPLEXT=.ppl +PPUEXT=.ppu +OEXT=.o +ASMEXT=.s +SMARTEXT=.sl +STATICLIBEXT=.a +SHAREDLIBEXT=.so +RSTEXT=.rst +FPCMADE=fpcmade + +# Go32v1 +ifeq ($(OS_TARGET),go32v1) +PPUEXT=.pp1 +OEXT=.o1 +ASMEXT=.s1 +SMARTEXT=.sl1 +STATICLIBEXT=.a1 +SHAREDLIBEXT=.so1 +FPCMADE=fpcmade.v1 +endif + +# Go32v2 +ifeq ($(OS_TARGET),go32v2) +FPCMADE=fpcmade.dos +endif + +# Linux +ifeq ($(OS_TARGET),linux) +EXEEXT= +HASSHAREDLIB=1 +FPCMADE=fpcmade.lnx +endif + +# Linux +ifeq ($(OS_TARGET),freebsd) +EXEEXT= +HASSHAREDLIB=1 +FPCMADE=fpcmade.freebsd +endif + +# Win32 +ifeq ($(OS_TARGET),win32) +PPUEXT=.ppw +OEXT=.ow +ASMEXT=.sw +SMARTEXT=.slw +STATICLIBEXT=.aw +SHAREDLIBEXT=.dll +FPCMADE=fpcmade.w32 +endif + +# OS/2 +ifeq ($(OS_TARGET),os2) +PPUEXT=.ppo +ASMEXT=.so2 +OEXT=.oo2 +SMARTEXT=.so +STATICLIBEXT=.ao2 +SHAREDLIBEXT=.dll +FPCMADE=fpcmade.os2 +endif + +# library prefix +LIBPREFIX=lib +ifeq ($(OS_TARGET),go32v2) +LIBPREFIX= +endif +ifeq ($(OS_TARGET),go32v1) +LIBPREFIX= +endif + +# determine which .pas extension is used +ifndef PASEXT +ifdef EXEOBJECTS +override TESTPAS:=$(strip $(wildcard $(addsuffix .pas,$(firstword $(EXEOBJECTS))))) +else +override TESTPAS:=$(strip $(wildcard $(addsuffix .pas,$(firstword $(UNITOBJECTS))))) +endif +ifeq ($(TESTPAS),) +PASEXT=.pp +else +PASEXT=.pas +endif +endif + + + +##################################################################### +# Default Directories +##################################################################### + +# Linux and freebsd use unix dirs with /usr/bin, /usr/lib +# When zipping use the target as default, when normal install then +# use the source os as default +ifdef ZIPNAME +# Zipinstall +ifeq ($(OS_TARGET),linux) +UNIXINSTALLDIR=1 +endif +ifeq ($(OS_TARGET),freebsd) +UNIXINSTALLDIR=1 +endif +else +# Normal install +ifeq ($(OS_SOURCE),linux) +UNIXINSTALLDIR=1 +endif +ifeq ($(OS_SOURCE),freebsd) +UNIXINSTALLDIR=1 +endif +endif + +# set the prefix directory where to install everything +ifndef PREFIXINSTALLDIR +ifdef UNIXINSTALLDIR +PREFIXINSTALLDIR=/usr +else +PREFIXINSTALLDIR=/pp +endif +endif +export PREFIXINSTALLDIR + +# Where to place the resulting zip files +ifndef DESTZIPDIR +DESTZIPDIR:=$(BASEDIR) +endif +export DESTZIPDIR + +##################################################################### +# Install Directories +##################################################################### + +# set the base directory where to install everything +ifndef BASEINSTALLDIR +ifdef UNIXINSTALLDIR +BASEINSTALLDIR=$(PREFIXINSTALLDIR)/lib/fpc/$(FPC_VERSION) +else +BASEINSTALLDIR=$(PREFIXINSTALLDIR) +endif +endif + +# set the directory where to install the binaries +ifndef BININSTALLDIR +ifdef UNIXINSTALLDIR +BININSTALLDIR=$(PREFIXINSTALLDIR)/bin +else +BININSTALLDIR=$(BASEINSTALLDIR)/bin/$(OS_TARGET) +endif +endif + +# set the directory where to install the units. +ifndef UNITINSTALLDIR +UNITINSTALLDIR=$(BASEINSTALLDIR)/units/$(OS_TARGET) +ifdef UNITSUBDIR +UNITINSTALLDIR:=$(UNITINSTALLDIR)/$(UNITSUBDIR) +endif +endif + +# Where to install shared libraries +ifndef LIBINSTALLDIR +ifdef UNIXINSTALLDIR +LIBINSTALLDIR=$(PREFIXINSTALLDIR)/lib +else +LIBINSTALLDIR=$(UNITINSTALLDIR) +endif +endif + +# Where the source files will be stored +ifndef SOURCEINSTALLDIR +ifdef UNIXINSTALLDIR +SOURCEINSTALLDIR=$(PREFIXINSTALLDIR)/src/fpc-$(FPC_VERSION) +else +SOURCEINSTALLDIR=$(BASEINSTALLDIR)/source +endif +ifdef SOURCESUBDIR +SOURCEINSTALLDIR:=$(SOURCEINSTALLDIR)/$(SOURCESUBDIR) +endif +endif + +# Where the doc files will be stored +ifndef DOCINSTALLDIR +ifdef UNIXINSTALLDIR +DOCINSTALLDIR=$(PREFIXINSTALLDIR)/doc/fpc-$(FPC_VERSION) +else +DOCINSTALLDIR=$(BASEINSTALLDIR)/doc +endif +endif + +# Where to install the examples, under linux we use the doc dir +# because the copytree command will create a subdir itself +ifndef EXAMPLEINSTALLDIR +ifdef UNIXINSTALLDIR +EXAMPLEINSTALLDIR=$(DOCINSTALLDIR)/examples +else +EXAMPLEINSTALLDIR=$(BASEINSTALLDIR)/examples +endif +ifdef EXAMPLESUBDIR +EXAMPLEINSTALLDIR:=$(EXAMPLEINSTALLDIR)/$(EXAMPLESUBDIR) +endif +endif + +# Where the some extra (data)files will be stored +ifndef DATAINSTALLDIR +DATAINSTALLDIR=$(BASEINSTALLDIR) +endif + +##################################################################### +# Redirection +##################################################################### + +ifndef REDIRFILE +REDIRFILE=log +endif + +ifdef REDIR +ifndef inUnix +override FPC=redir -eo $(FPC) +endif +# set the verbosity to max +override FPCOPT+=-va +override REDIR:= >> $(REDIRFILE) +endif + + +##################################################################### +# Compiler Command Line +##################################################################### + +# Load commandline OPTDEF and add FPC_CPU define +override FPCOPTDEF:=-d$(CPU_TARGET) + +# Load commandline OPT and add target and unit dir to be sure +ifneq ($(OS_TARGET),$(OS_SOURCE)) +override FPCOPT+=-T$(OS_TARGET) +endif + +# User dirs should be first, so they are looked at first +ifdef UNITDIR +override FPCOPT+=$(addprefix -Fu,$(UNITDIR)) +endif +ifdef LIBDIR +override FPCOPT+=$(addprefix -Fl,$(LIBDIR)) +endif +ifdef OBJDIR +override FPCOPT+=$(addprefix -Fo,$(OBJDIR)) +endif +ifdef INCDIR +override FPCOPT+=$(addprefix -Fi,$(INCDIR)) +endif + +# Smartlinking +ifdef LINKSMART +override FPCOPT+=-XX +endif + +# Smartlinking creation +ifdef CREATESMART +override FPCOPT+=-CX +endif + +# Debug +ifdef DEBUG +override FPCOPT+=-gl -dDEBUG +endif + +# Release mode (strip, optimize and don't load ppc386.cfg) +# 0.99.12b has a bug in the optimizer so don't use it by default +ifdef RELEASE +ifeq ($(FPC_VERSION),0.99.12) +override FPCOPT+=-Xs -OGp3 -n +else +override FPCOPT+=-Xs -OG2p3 -n +endif +endif + +# Strip +ifdef STRIP +override FPCOPT+=-Xs +endif + +# Optimizer +ifdef OPTIMIZE +override FPCOPT+=-OG2p3 +endif + +# Verbose settings (warning,note,info) +ifdef VERBOSE +override FPCOPT+=-vwni +endif + +ifdef UNITSDIR +override FPCOPT+=-Fu$(UNITSDIR) +endif + +# Target dirs and the prefix to use for clean/install +ifdef TARGETDIR +override FPCOPT+=-FE$(TARGETDIR) +ifeq ($(TARGETDIR),.) +override TARGETDIRPREFIX= +else +override TARGETDIRPREFIX=$(TARGETDIR)/ +endif +endif +ifdef UNITTARGETDIR +override FPCOPT+=-FU$(UNITTARGETDIR) +ifeq ($(UNITTARGETDIR),.) +override UNITTARGETDIRPREFIX= +else +override UNITTARGETDIRPREFIX=$(TARGETDIR)/ +endif +else +ifdef TARGETDIR +override UNITTARGETDIR=$(TARGETDIR) +override UNITTARGETDIRPREFIX=$(TARGETDIRPREFIX) +endif +endif + +# Add commandline options last so they can override +ifdef OPT +override FPCOPT+=$(OPT) +endif + +# Add defines from FPCOPTDEF to FPCOPT +ifdef FPCOPTDEF +override FPCOPT+=$(FPCOPTDEF) +endif + +# Error file ? +ifdef ERRORFILE +override FPCOPT+=-Fr$(ERRORFILE) +endif + +# Was a config file specified ? +ifdef CFGFILE +override FPCOPT+=@$(CFGFILE) +endif + +# For win32 the options are passed using the environment FPCEXTCMD +ifeq ($(OS_SOURCE),win32) +override FPCEXTCMD:=$(FPCOPT) +override FPCOPT:=!FPCEXTCMD +export FPCEXTCMD +endif + +# Compiler commandline +override COMPILER:=$(FPC) $(FPCOPT) + +# also call ppas if with command option -s +# but only if the OS_SOURCE and OS_TARGE are equal +ifeq (,$(findstring -s ,$(COMPILER))) +EXECPPAS= +else +ifeq ($(OS_SOURCE),$(OS_TARGET)) +EXECPPAS:=@$(PPAS) +endif +endif + +##################################################################### +# Standard rules +##################################################################### + +debug: fpc_debug + +smart: fpc_smart + +shared: fpc_shared + +showinstall: fpc_showinstall + +install: fpc_install + +sourceinstall: fpc_sourceinstall + +exampleinstall: fpc_exampleinstall + +zipinstall: fpc_zipinstall + +zipsourceinstall: fpc_zipsourceinstall + +zipexampleinstall: fpc_zipexampleinstall + +distclean: fpc_distclean + +cleanall: fpc_cleanall + +.PHONY: debug smart shared showinstall install sourceinstall exampleinstall zipinstall zipsourceinstall zipexampleinstall distclean cleanall + +##################################################################### +# General compile rules +##################################################################### + +.PHONY: fpc_packages fpc_all fpc_debug + +$(FPCMADE): $(ALLTARGET) + @$(ECHO) Compiled > $(FPCMADE) + +fpc_packages: $(COMPILEPACKAGES) + +fpc_all: fpc_packages $(FPCMADE) + +fpc_debug: + $(MAKE) all DEBUG=1 + +# Search paths for .ppu if targetdir is set +ifdef UNITTARGETDIR +vpath %$(PPUEXT) $(UNITTARGETDIR) +endif + +# General compile rules, available for both possible PASEXT + +.SUFFIXES: $(EXEEXT) $(PPUEXT) $(OEXT) .pas .pp + +%$(PPUEXT): %.pp + $(COMPILER) $< $(REDIR) + $(EXECPPAS) + +%$(PPUEXT): %.pas + $(COMPILER) $< $(REDIR) + $(EXECPPAS) + +%$(EXEEXT): %.pp + $(COMPILER) $< $(REDIR) + $(EXECPPAS) + +%$(EXEEXT): %.pas + $(COMPILER) $< $(REDIR) + $(EXECPPAS) + +##################################################################### +# Library +##################################################################### + +.PHONY: fpc_smart fpc_shared + +ifdef LIBVERSION +LIBFULLNAME=$(LIBNAME).$(LIBVERSION) +else +LIBFULLNAME=$(LIBNAME) +endif + +# Default sharedlib units are all unit objects +ifndef SHAREDLIBUNITOBJECTS +SHAREDLIBUNITOBJECTS:=$(UNITOBJECTS) +endif + +fpc_smart: + $(MAKE) all LINKSMART=1 CREATESMART=1 + +fpc_shared: all +ifdef HASSHAREDLIB +ifndef LIBNAME + @$(ECHO) "LIBNAME not set" +else + $(PPUMOVE) $(SHAREDLIBUNITOBJECTS) -o$(LIBFULLNAME) +endif +else + @$(ECHO) "Shared Libraries not supported" +endif + +##################################################################### +# Install rules +##################################################################### + +.PHONY: fpc_showinstall fpc_install + +ifdef EXTRAINSTALLUNITS +override INSTALLPPUFILES+=$(addsuffix $(PPUEXT),$(EXTRAINSTALLUNITS)) +endif + +ifdef INSTALLPPUFILES +override INSTALLPPUFILES:=$(addprefix $(UNITTARGETDIRPREFIX),$(INSTALLPPUFILES)) +ifdef PPUFILES +INSTALLPPULINKFILES:=$(shell $(PPUFILES) -S -O $(INSTALLPPUFILES)) +else +INSTALLPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(INSTALLPPUFILES)) $(addprefix $(LIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(INSTALLPPUFILES)))) +endif +override INSTALLPPULINKFILES:=$(addprefix $(UNITTARGETDIRPREFIX),$(INSTALLPPULINKFILES)) +endif + +ifdef INSTALLEXEFILES +override INSTALLEXEFILES:=$(addprefix $(TARGETDIRPREFIX),$(INSTALLEXEFILES)) +endif + +fpc_showinstall: $(SHOWINSTALLTARGET) +ifdef INSTALLEXEFILES + @$(ECHO) -e $(addprefix "\n"$(BININSTALLDIR)/,$(INSTALLEXEFILES)) +endif +ifdef INSTALLPPUFILES + @$(ECHO) -e $(addprefix "\n"$(UNITINSTALLDIR)/,$(INSTALLPPUFILES)) +ifneq ($(INSTALLPPULINKFILES),) + @$(ECHO) -e $(addprefix "\n"$(UNITINSTALLDIR)/,$(INSTALLPPULINKFILES)) +endif +ifneq ($(wildcard $(LIBFULLNAME)),) + @$(ECHO) $(LIBINSTALLDIR)/$(LIBFULLNAME) +ifdef HASSHAREDLIB + @$(ECHO) $(LIBINSTALLDIR)/$(LIBNAME) +endif +endif +endif +ifdef EXTRAINSTALLFILES + @$(ECHO) -e $(addprefix "\n"$(DATAINSTALLDIR)/,$(EXTRAINSTALLFILES)) +endif + +fpc_install: $(INSTALLTARGET) +# Create UnitInstallFiles +ifdef INSTALLEXEFILES + $(MKDIR) $(BININSTALLDIR) +# Compress the exes if upx is defined +ifdef UPXPROG + -$(UPXPROG) $(INSTALLEXEFILES) +endif + $(INSTALLEXE) $(INSTALLEXEFILES) $(BININSTALLDIR) +endif +ifdef INSTALLPPUFILES + $(MKDIR) $(UNITINSTALLDIR) + $(INSTALL) $(INSTALLPPUFILES) $(UNITINSTALLDIR) +ifneq ($(INSTALLPPULINKFILES),) + $(INSTALL) $(INSTALLPPULINKFILES) $(UNITINSTALLDIR) +endif +ifneq ($(wildcard $(LIBFULLNAME)),) + $(MKDIR) $(LIBINSTALLDIR) + $(INSTALL) $(LIBFULLNAME) $(LIBINSTALLDIR) +ifdef inUnix + ln -sf $(LIBFULLNAME) $(LIBINSTALLDIR)/$(LIBNAME) +endif +endif +endif +ifdef EXTRAINSTALLFILES + $(MKDIR) $(DATAINSTALLDIR) + $(INSTALL) $(EXTRAINSTALLFILES) $(DATAINSTALLDIR) +endif + +##################################################################### +# SourceInstall rules +##################################################################### + +.PHONY: fpc_sourceinstall + +ifndef SOURCETOPDIR +SOURCETOPDIR=$(BASEDIR) +endif + +fpc_sourceinstall: clean + $(MKDIR) $(SOURCEINSTALLDIR) + $(COPYTREE) $(SOURCETOPDIR) $(SOURCEINSTALLDIR) + +##################################################################### +# exampleinstall rules +##################################################################### + +.PHONY: fpc_exampleinstall + +fpc_exampleinstall: $(addsuffix _clean,$(EXAMPLEDIROBJECTS)) +ifdef EXAMPLESOURCEFILES + $(MKDIR) $(EXAMPLEINSTALLDIR) + $(COPY) $(EXAMPLESOURCEFILES) $(EXAMPLEINSTALLDIR) +endif +ifdef EXAMPLEDIROBJECTS +ifndef EXAMPLESOURCEFILES + $(MKDIR) $(EXAMPLEINSTALLDIR) +endif + $(COPYTREE) $(addsuffix /*,$(EXAMPLEDIROBJECTS)) $(EXAMPLEINSTALLDIR) +endif + +##################################################################### +# Zip +##################################################################### + +.PHONY: fpc_zipinstall + +# Create suffix to add +ifndef PACKAGESUFFIX +PACKAGESUFFIX=$(OS_TARGET) +ifeq ($(OS_TARGET),go32v2) +PACKAGESUFFIX=go32 +endif +ifeq ($(OS_TARGET),win32) +PACKAGESUFFIX=w32 +endif +endif + +# Temporary path to pack a file +ifndef PACKDIR +ifndef inUnix +PACKDIR=$(BASEDIR)/pack_tmp +else +PACKDIR=/tmp/fpc-pack +endif +endif + +# Maybe create default zipname from packagename +ifndef ZIPNAME +ifdef PACKAGENAME +ZIPNAME=$(PACKAGEPREFIX)$(PACKAGENAME)$(PACKAGESUFFIX) +endif +endif + +# Use tar by default under linux +ifndef USEZIP +ifdef inUnix +USETAR=1 +endif +endif + +fpc_zipinstall: +ifndef ZIPNAME + @$(ECHO) "Please specify ZIPNAME!" + @exit 1 +else + $(MAKE) $(ZIPTARGET) PREFIXINSTALLDIR=$(PACKDIR) +ifdef USETAR + $(DEL) $(DESTZIPDIR)/$(ZIPNAME)$(TAREXT) + cd $(PACKDIR) ; $(TARPROG) cf$(TAROPT) $(DESTZIPDIR)/$(ZIPNAME)$(TAREXT) * ; cd $(BASEDIR) +else + $(DEL) $(DESTZIPDIR)/$(ZIPNAME)$(ZIPEXT) + cd $(PACKDIR) ; $(ZIPPROG) -Dr $(ZIPOPT) $(DESTZIPDIR)/$(ZIPNAME)$(ZIPEXT) * ; cd $(BASEDIR) +endif + $(DELTREE) $(PACKDIR) +endif + +.PHONY: fpc_zipsourceinstall + +fpc_zipsourceinstall: + $(MAKE) fpc_zipinstall ZIPTARGET=sourceinstall PACKAGESUFFIX=src + +.PHONY: fpc_zipexampleinstall + +fpc_zipexampleinstall: + $(MAKE) fpc_zipinstall ZIPTARGET=exampleinstall PACKAGESUFFIX=exm + +##################################################################### +# Clean rules +##################################################################### + +.PHONY: fpc_clean fpc_cleanall fpc_distclean + +ifdef EXEFILES +override CLEANEXEFILES:=$(addprefix $(TARGETDIRPREFIX),$(CLEANEXEFILES)) +endif + +ifdef EXTRACLEANUNITS +override CLEANPPUFILES+=$(addsuffix $(PPUEXT),$(EXTRACLEANUNITS)) +endif + +ifdef CLEANPPUFILES +override CLEANPPUFILES:=$(addprefix $(UNITTARGETDIRPREFIX),$(CLEANPPUFILES)) +# Get the .o and .a files created for the units +ifdef PPUFILES +CLEANPPULINKFILES:=$(shell $(PPUFILES) $(CLEANPPUFILES)) +else +CLEANPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(CLEANPPUFILES)) $(addprefix $(LIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(CLEANPPUFILES)))) +endif +override CLEANPPULINKFILES:=$(addprefix $(UNITTARGETDIRPREFIX),$(CLEANPPULINKFILES)) +endif + +fpc_clean: $(CLEANTARGET) +ifdef CLEANEXEFILES + -$(DEL) $(CLEANEXEFILES) +endif +ifdef CLEANPPUFILES + -$(DEL) $(CLEANPPUFILES) +endif +ifneq ($(CLEANPPULINKFILES),) + -$(DEL) $(CLEANPPULINKFILES) +endif +ifdef CLEANRSTFILES + -$(DEL) $(addprefix $(UNITTARGETDIRPREFIX),$(CLEANRSTFILES)) +endif +ifdef EXTRACLEANFILES + -$(DEL) $(EXTRACLEANFILES) +endif +ifdef LIBNAME + -$(DEL) $(LIBNAME) $(LIBFULLNAME) +endif + -$(DEL) $(FPCMADE) $(PPAS) link.res $(FPCEXTFILE) $(REDIRFILE) + +fpc_distclean: fpc_clean + +# Also run clean first if targetdir is set. Unittargetdir is always +# set if targetdir or unittargetdir is specified +ifdef UNITTARGETDIR +TARGETDIRCLEAN=fpc_clean +endif + +fpc_cleanall: $(CLEANTARGET) $(TARGETDIRCLEAN) +ifdef CLEANEXEFILES + -$(DEL) $(CLEANEXEFILES) +endif + -$(DEL) *$(OEXT) *$(PPUEXT) *$(RSTEXT) *$(ASMEXT) *$(STATICLIBEXT) *$(SHAREDLIBEXT) *$(PPLEXT) + -$(DELTREE) *$(SMARTEXT) + -$(DEL) $(FPCMADE) $(PPAS) link.res $(FPCEXTFILE) $(REDIRFILE) + +##################################################################### +# Info rules +##################################################################### + +.PHONY: fpc_info fpc_cfginfo fpc_objectinfo fpc_toolsinfo fpc_installinfo \ + fpc_dirinfo + +fpc_info: $(INFOTARGET) + +fpc_infocfg: + @$(ECHO) + @$(ECHO) == Configuration info == + @$(ECHO) + @$(ECHO) FPC....... $(FPC) + @$(ECHO) Version... $(FPC_VERSION) + @$(ECHO) CPU....... $(CPU_TARGET) + @$(ECHO) Source.... $(OS_SOURCE) + @$(ECHO) Target.... $(OS_TARGET) + @$(ECHO) + +fpc_infoobjects: + @$(ECHO) + @$(ECHO) == Object info == + @$(ECHO) + @$(ECHO) LoaderObjects..... $(LOADEROBJECTS) + @$(ECHO) UnitObjects....... $(UNITOBJECTS) + @$(ECHO) ExeObjects........ $(EXEOBJECTS) + @$(ECHO) + @$(ECHO) ExtraCleanUnits... $(EXTRACLEANUNITS) + @$(ECHO) ExtraCleanFiles... $(EXTRACLEANFILES) + @$(ECHO) + @$(ECHO) ExtraInstallUnits. $(EXTRAINSTALLUNITS) + @$(ECHO) ExtraInstallFiles. $(EXTRAINSTALLFILES) + @$(ECHO) + +fpc_infoinstall: + @$(ECHO) + @$(ECHO) == Install info == + @$(ECHO) +ifdef DATE + @$(ECHO) DateStr.............. $(DATESTR) +endif +ifdef PACKAGEPREFIX + @$(ECHO) PackagePrefix........ $(PACKAGEPREFIX) +endif +ifdef PACKAGENAME + @$(ECHO) PackageName.......... $(PACKAGENAME) +endif + @$(ECHO) PackageSuffix........ $(PACKAGESUFFIX) + @$(ECHO) + @$(ECHO) BaseInstallDir....... $(BASEINSTALLDIR) + @$(ECHO) BinInstallDir........ $(BININSTALLDIR) + @$(ECHO) LibInstallDir........ $(LIBINSTALLDIR) + @$(ECHO) UnitInstallDir....... $(UNITINSTALLDIR) + @$(ECHO) SourceInstallDir..... $(SOURCEINSTALLDIR) + @$(ECHO) DocInstallDir........ $(DOCINSTALLDIR) + @$(ECHO) DataInstallDir....... $(DATAINSTALLDIR) + @$(ECHO) + @$(ECHO) DestZipDir........... $(DESTZIPDIR) + @$(ECHO) ZipName.............. $(ZIPNAME) + @$(ECHO) + +##################################################################### +# Local Makefile +##################################################################### + +ifneq ($(wildcard fpcmake.loc),) +include fpcmake.loc +endif + +##################################################################### +# Users rules +##################################################################### + +.PHONY: all units tests cont_tests + +# Unix like OS ? +ifeq ($(OS_TARGET),linux) +INUNIX=1 +endif +ifeq ($(OS_TARGET),freebsd) +INUNIX=1 +endif + +# For linux by default no graph tests +ifdef INUNIX +NOGRAPH=1 +endif + + +# +# Tools +# + +ifndef LONGLOG +export LONGLOG:=longlog +endif + +ifndef LOG +export LOG:=log +endif + +units : units/$(FPCMADE) +units/$(FPCMADE): + $(MAKE) -C units + +DOTEST=dotest$(EXEEXT) +$(DOTEST) : utils/dotest.pp utils/redir.pp + $(FPC) -Fu../units -FE. utils/dotest + +testcheck: units $(DOTEST) + +# +# Test run targets +# + +DIRS=webtbs webtbf tbs tbf test testopt + +all : alltests + +tests : clean all_compilations + +cont_tests : all_compilations + +%.log : %.pp + $(DOTEST) $< + +%.elg : %.pp + $(DOTEST) -e $< + +alltbs : testcheck $(patsubst %.pp,%.log,$(wildcard tbs/*.pp)) +alltbf : testcheck $(patsubst %.pp,%.log,$(wildcard tbf/*.pp)) + +allwebtbs : testcheck $(patsubst %.pp,%.log,$(wildcard webtbs/*.pp)) +allwebtbf : testcheck $(patsubst %.pp,%.log,$(wildcard webtbs/*.pp)) + +alltest : testcheck $(patsubst %.pp,%.log,$(wildcard test/*.pp)) +alltestopt : testcheck $(patsubst %.pp,%.log,$(wildcard testopt/*.pp)) + +alltests: alltest alltbs alltbf allwebtbs allwebtbf + +clean: + -rm -f $(addsuffix /*$(PPUEXT),$(DIRS)) + -rm -f $(addsuffix /*$(OEXT),$(DIRS)) + -rm -f $(addsuffix /*.rst,$(DIRS)) + -rm -f $(addsuffix /*$(SHAREDLIBEXT),$(DIRS)) + -rm -f $(addsuffix /*.log,$(DIRS)) + -rm -f $(addsuffix /*.elg,$(DIRS)) +ifdef INUNIX + -rm -f $(wildcard $(patsubst %.pp,%$(EXEEXT),$(wildcard $(addsuffix /t*.pp,$(DIRS))))) +else + -rm -f $(addsuffix /*$(EXEEXT),$(DIRS)) +endif + -rm -f *.tmp + -rm -f $(LOG) $(LONGLOG) fail + -rm -f ppas.sh ppas.bat + +full : clean all_compilations allexec + +info : + @echo This Makefile allows to test the compiler + @echo compilation of 'ts*.pp' should succeed + @echo compilation of 'tf*.pp' should fail + @echo compilation of 'test*.pp' should succeed + @echo 'to*.pp' files should also compile + @echo simply run \'make tests\' to test all compilation + @echo run \'make allexec\' to test also if the executables + @echo created behave like the should + @echo run \'make tesiexec\' to test executables + @echo that require interactive mode diff --git a/tests/Makefile.fpc b/tests/Makefile.fpc new file mode 100644 index 0000000000..fa8a2f8c3f --- /dev/null +++ b/tests/Makefile.fpc @@ -0,0 +1,104 @@ +# +# Makefile.fpc for Free Pascal Tests directory +# + +[defaults] +defaultrule=alltests + +[rules] +.PHONY: all units tests cont_tests + +# Unix like OS ? +ifeq ($(OS_TARGET),linux) +INUNIX=1 +endif +ifeq ($(OS_TARGET),freebsd) +INUNIX=1 +endif + +# For linux by default no graph tests +ifdef INUNIX +NOGRAPH=1 +endif + + +# +# Tools +# + +ifndef LONGLOG +export LONGLOG:=longlog +endif + +ifndef LOG +export LOG:=log +endif + +units : units/$(FPCMADE) +units/$(FPCMADE): + $(MAKE) -C units + +DOTEST=dotest$(EXEEXT) +$(DOTEST) : utils/dotest.pp utils/redir.pp + $(FPC) -Fu../units -FE. utils/dotest + +testcheck: units $(DOTEST) + +# +# Test run targets +# + +DIRS=webtbs webtbf tbs tbf test testopt + +all : alltests + +tests : clean all_compilations + +cont_tests : all_compilations + +%.log : %.pp + $(DOTEST) $< + +%.elg : %.pp + $(DOTEST) -e $< + +alltbs : testcheck $(patsubst %.pp,%.log,$(wildcard tbs/*.pp)) +alltbf : testcheck $(patsubst %.pp,%.log,$(wildcard tbf/*.pp)) + +allwebtbs : testcheck $(patsubst %.pp,%.log,$(wildcard webtbs/*.pp)) +allwebtbf : testcheck $(patsubst %.pp,%.log,$(wildcard webtbs/*.pp)) + +alltest : testcheck $(patsubst %.pp,%.log,$(wildcard test/*.pp)) +alltestopt : testcheck $(patsubst %.pp,%.log,$(wildcard testopt/*.pp)) + +alltests: alltest alltbs alltbf allwebtbs allwebtbf + +clean: + -rm -f $(addsuffix /*$(PPUEXT),$(DIRS)) + -rm -f $(addsuffix /*$(OEXT),$(DIRS)) + -rm -f $(addsuffix /*.rst,$(DIRS)) + -rm -f $(addsuffix /*$(SHAREDLIBEXT),$(DIRS)) + -rm -f $(addsuffix /*.log,$(DIRS)) + -rm -f $(addsuffix /*.elg,$(DIRS)) +ifdef INUNIX + -rm -f $(wildcard $(patsubst %.pp,%$(EXEEXT),$(wildcard $(addsuffix /t*.pp,$(DIRS))))) +else + -rm -f $(addsuffix /*$(EXEEXT),$(DIRS)) +endif + -rm -f *.tmp + -rm -f $(LOG) $(LONGLOG) fail + -rm -f ppas.sh ppas.bat + +full : clean all_compilations allexec + +info : + @echo This Makefile allows to test the compiler + @echo compilation of 'ts*.pp' should succeed + @echo compilation of 'tf*.pp' should fail + @echo compilation of 'test*.pp' should succeed + @echo 'to*.pp' files should also compile + @echo simply run \'make tests\' to test all compilation + @echo run \'make allexec\' to test also if the executables + @echo created behave like the should + @echo run \'make tesiexec\' to test executables + @echo that require interactive mode \ No newline at end of file diff --git a/tests/tbf/tb1.pp b/tests/tbf/tb1.pp new file mode 100644 index 0000000000..b4bb3ca4b8 --- /dev/null +++ b/tests/tbf/tb1.pp @@ -0,0 +1,9 @@ +{ Old file: tbf0008.pp } +{ tests the crash when decrementing constants OK 0.9.2 } + +const + compilerconst=1; + +begin + dec(compilerconst); +end. diff --git a/tests/tbf/tb10.pp b/tests/tbf/tb10.pp new file mode 100644 index 0000000000..b6ae708e3e --- /dev/null +++ b/tests/tbf/tb10.pp @@ -0,0 +1,6 @@ +{ Old file: tbf0085.pp } +{ shows runerror 216 OK 0.99.1 (CEC) } + +Begin + writeln(l); +end. diff --git a/tests/tbf/tb11.pp b/tests/tbf/tb11.pp new file mode 100644 index 0000000000..2953edcc8c --- /dev/null +++ b/tests/tbf/tb11.pp @@ -0,0 +1,18 @@ +{ Old file: tbf0086.pp } +{ shows runerror 216 OK 0.99.1 (CEC) } + + +var + v: word; + w: shortint; + z: byte; + y: integer; + +type + zz: shortint = 255; +Begin + y:=64000; + z:=32767; + w:=64000; + v:=-1; +end. diff --git a/tests/tbf/tb12.pp b/tests/tbf/tb12.pp new file mode 100644 index 0000000000..a5a6806651 --- /dev/null +++ b/tests/tbf/tb12.pp @@ -0,0 +1,18 @@ +{ Old file: tbf0087.pp } +{ shows internal error 12 - no more SegFaults OK 0.99.1 (FK) } + +{ + BP Error message is 'Pointer variable Expected' +} +type + tobj=object + l : longint; + constructor init; + end; +var + o : tobj; +begin + new(o); {This will create a internal error 9999} + new(o,init); {This will create a Segfault and Core Dump under linux} +end. + \ No newline at end of file diff --git a/tests/tbf/tb13.pp b/tests/tbf/tb13.pp new file mode 100644 index 0000000000..673fa9d4a0 --- /dev/null +++ b/tests/tbf/tb13.pp @@ -0,0 +1,6 @@ +{ Old file: tbf0088.pp } +{ internal error 12 or Runerror 216 OK 0.99.1 (FK) } + +Begin + typeof(x1); { Gives out an internal error -- better then 9999 though } +end. diff --git a/tests/tbf/tb14.pp b/tests/tbf/tb14.pp new file mode 100644 index 0000000000..549fc2a7a0 --- /dev/null +++ b/tests/tbf/tb14.pp @@ -0,0 +1,6 @@ +{ Old file: tbf0089.pp } +{ internal error 12 or Runerror 216 OK 0.99.1 (FK) } + +Begin + sizeof(x); +end. diff --git a/tests/tbf/tb15.pp b/tests/tbf/tb15.pp new file mode 100644 index 0000000000..e6a475fe2b --- /dev/null +++ b/tests/tbf/tb15.pp @@ -0,0 +1,8 @@ +{ Old file: tbf0094.pp } +{ internal error when recordtype not found with case OK 0.99.1 } + +begin + case textrec(l).mode of + 1 ; + end; +end. \ No newline at end of file diff --git a/tests/tbf/tb16.pp b/tests/tbf/tb16.pp new file mode 100644 index 0000000000..2863e707d3 --- /dev/null +++ b/tests/tbf/tb16.pp @@ -0,0 +1,42 @@ +{ Old file: tbf0097.pp } +{ two errors in bp7 but not in FPC OK 0.99.6 (FK) } + +{ + This compiles fine with FPC, but not with Bp7 see 2 comments +} + +type + t=object + s : string; { No ; needed ? } + procedure p; + end; + + t2=object(t) + procedure p1(p : string); + end; + +procedure t2.p1(p : string); + + begin + end; + +procedure t.p; + +var + s : longint; { Not allowed with BP7 } + x : longint; + +procedure nested; + + var + s : longint; + + begin + end; + +begin +end; + + +begin +end. diff --git a/tests/tbf/tb17.pp b/tests/tbf/tb17.pp new file mode 100644 index 0000000000..14539a8f76 --- /dev/null +++ b/tests/tbf/tb17.pp @@ -0,0 +1,10 @@ +{ Old file: tbf0100.pp } +{ a unit may only occure once in uses OK 0.99.6 (PM) } + +unit tbs0100; +interface +uses dos; +implementation +uses dos; { Not Allowed in BP7} +end. + diff --git a/tests/tbf/tb18.pp b/tests/tbf/tb18.pp new file mode 100644 index 0000000000..ebe83fad03 --- /dev/null +++ b/tests/tbf/tb18.pp @@ -0,0 +1,21 @@ +{ Old file: tbf0101.pp } +{ no type checking for routines in interfance and OK 0.99.1 (CEC) } + +Unit tbs0101; + +Interface + + Procedure MyProc(V: Integer); + + +Implementation + + Procedure MyProc(Y: Integer); + Begin + end; + + +end. + + + diff --git a/tests/tbf/tb19.pp b/tests/tbf/tb19.pp new file mode 100644 index 0000000000..89061bc26d --- /dev/null +++ b/tests/tbf/tb19.pp @@ -0,0 +1,8 @@ +{ Old file: tbf0108.pp } +{ gives wrong error message OK 0.99.1 (PFV) } + +uses + dos, + ; +begin +end. \ No newline at end of file diff --git a/tests/tbf/tb2.pp b/tests/tbf/tb2.pp new file mode 100644 index 0000000000..d5c9e6c010 --- /dev/null +++ b/tests/tbf/tb2.pp @@ -0,0 +1,9 @@ +{ Old file: tbf0010.pp } +{ tests string constants exceeding lines OK 0.9.2 } + +program hello; + + begin + writeln('Hello); + end. + diff --git a/tests/tbf/tb20.pp b/tests/tbf/tb20.pp new file mode 100644 index 0000000000..443b5f6cd3 --- /dev/null +++ b/tests/tbf/tb20.pp @@ -0,0 +1,12 @@ +{ Old file: tbf0109.pp } +{ syntax error not detected when using a set as pointer OK 0.99.1 (FK) } + +Type T = (aa,bb,cc,dd,ee,ff,gg,hh); + Tset = set of t; + +Var a: Tset; + +Begin + If (aa in a^) Then begin end; + {it seems that correct code is generated, but the syntax is wrong} +End. diff --git a/tests/tbf/tb21.pp b/tests/tbf/tb21.pp new file mode 100644 index 0000000000..691cf6340a --- /dev/null +++ b/tests/tbf/tb21.pp @@ -0,0 +1,8 @@ +{ Old file: tbf0110.pp } +{ SigSegv when using undeclared var in Case OK 0.99.6 (PFV) } + +Begin + Case Pai(hp1)^.typ Of + ait_instruction: + End +End. diff --git a/tests/tbf/tb22.pp b/tests/tbf/tb22.pp new file mode 100644 index 0000000000..de037c3ec8 --- /dev/null +++ b/tests/tbf/tb22.pp @@ -0,0 +1,24 @@ +{ Old file: tbf0117.pp } +{ internalerror 17 (and why is there an automatic float OK 0.99.6 (FK) } + +var + i: word; + j: integer; +Begin + i:=65530; + i:=i+1; { CF check } + i:=i-1; + i:=i*5; + i:=i/5; + i:=i shl 5; + i:=i shr 5; + Inc(i); { no check } + j:=32765; { OV check } + j:=j+1; + inc(j); + j:=j-1; + j:=j*5; + j:=j div 5; + j:=j shl 5; + j:=j shr 5; +end. \ No newline at end of file diff --git a/tests/tbf/tb23.pp b/tests/tbf/tb23.pp new file mode 100644 index 0000000000..406eb0ed9c --- /dev/null +++ b/tests/tbf/tb23.pp @@ -0,0 +1,20 @@ +{ Old file: tbf0127.pp } +{ problem with cdecl in implementation part OK 0.99.7 (PFV) } + +unit tbf0127; + + interface + + procedure x(l : longint); + + implementation + + procedure crash; + + begin + x(1234); { called with pascal calling conventions } + end; + + procedure x(l : longint);external;cdecl; + +end. diff --git a/tests/tbf/tb24.pp b/tests/tbf/tb24.pp new file mode 100644 index 0000000000..bd7c1e0245 --- /dev/null +++ b/tests/tbf/tb24.pp @@ -0,0 +1,12 @@ +{ Old file: tbf0136.pp } +{ No types necessary in the procedure header OK 0.99.6 (PFV) } + +{ + No type declaration necessary ???? +} +procedure p(handle1,handle2); +begin +end; + +begin +end. diff --git a/tests/tbf/tb25.pp b/tests/tbf/tb25.pp new file mode 100644 index 0000000000..df3fcf7455 --- /dev/null +++ b/tests/tbf/tb25.pp @@ -0,0 +1,23 @@ +{ Old file: tbf0148.pp } +{ crash when setting function result of a declared but not yet implemented function in another function } + +unit test; + +interface + +Function t(a: Byte): byte; +Function DoT(b: byte): Byte; + +implementation + +Function t(a: Byte): Byte; +var f: byte; +Begin + DoT := f; +End; + +Function DoT(b: byte): Byte; +Begin +End; + +end. diff --git a/tests/tbf/tb26.pp b/tests/tbf/tb26.pp new file mode 100644 index 0000000000..a1622ff383 --- /dev/null +++ b/tests/tbf/tb26.pp @@ -0,0 +1,13 @@ +{ Old file: tbf0151.pp } +{ crash when using undeclared variable in withstatement OK 0.99.7 (PFV) } + +type tr = record + l1, l2: longint + end; + +var r: tr; + +begin + with r do + inc(l) +end. diff --git a/tests/tbf/tb27.pp b/tests/tbf/tb27.pp new file mode 100644 index 0000000000..19cecb26be --- /dev/null +++ b/tests/tbf/tb27.pp @@ -0,0 +1,20 @@ +{ Old file: tbf0153.pp } +{ Asm, indexing a local/para var should produce an error like tp7 OK 0.99.9 (PFV) } + +{$asmmode att} + +procedure asmfunc(p:pointer);assembler; +asm +{ + this is changed into movl %eax,(%ebx+8) which is not correct, and tp7 + also doesn't allow 'mov p[bx],ax' or 'mov p+bx,ax' + + Solution: for parameters and locals the index must be turned off + + Don't forget to check the intel assembler also +} + movl %eax,p(%ebx) +end; + +begin +end. diff --git a/tests/tbf/tb28.pp b/tests/tbf/tb28.pp new file mode 100644 index 0000000000..a7eaa36a9a --- /dev/null +++ b/tests/tbf/tb28.pp @@ -0,0 +1,20 @@ +{ Old file: tbf0155.pp } +{ Asm, Missing string return for asm functions } + +{ this is not a real bug but rather a feature : + assembler function are only accepted for + simple return values + i.e. either in register or FPU (PM) } + +{ so for the moment this is rejected code ! } + +function asmstr:string;assembler; +asm + movl __RESULT,%edi + movl $0x4101,%al + stosw +end; + +begin + writeln(asmstr); +end; \ No newline at end of file diff --git a/tests/tbf/tb29.pp b/tests/tbf/tb29.pp new file mode 100644 index 0000000000..1dfb1df8de --- /dev/null +++ b/tests/tbf/tb29.pp @@ -0,0 +1,20 @@ +{ Old file: tbf0157.pp } +{ Invalid compilation and also crashes OK 0.99.7 (PFV) } + +{ this should be rejected because we only accept integer args } + +program write_it; +var x,y:real; + i : longint; + s : string; +begin +x:=5.6; +y:=45.789; +write(y:2:3,' ',x:3:4); +write(i:5); +s:='short'; +write(s:11); +write(i:5:2); +write(s:25:3); +write(x:5.2); +end. diff --git a/tests/tbf/tb3.pp b/tests/tbf/tb3.pp new file mode 100644 index 0000000000..734c7799de --- /dev/null +++ b/tests/tbf/tb3.pp @@ -0,0 +1,15 @@ +{ Old file: tbf0029.pp } +{ tests typeof(object type) OK 0.99.1 (FK) } + +type + TA = object + end; + +var + P: Pointer; + +begin + { must fail on compilation because + TA has no VMT } + P := pointer(TypeOf(TA)); +end. diff --git a/tests/tbf/tb30.pp b/tests/tbf/tb30.pp new file mode 100644 index 0000000000..6308059ed2 --- /dev/null +++ b/tests/tbf/tb30.pp @@ -0,0 +1,11 @@ +{ Old file: tbf0158.pp } +{ Invalid boolean typecast OK 0.99.7 (PFV) } + +program tmp; + +var + Molo :Boolean; + +begin + Molo := 1; { This should give out a Type mismatch error ! } +end. diff --git a/tests/tbf/tb31.pp b/tests/tbf/tb31.pp new file mode 100644 index 0000000000..d2d574f01f --- /dev/null +++ b/tests/tbf/tb31.pp @@ -0,0 +1,14 @@ +{ Old file: tbf0161.pp } +{ internal error when trying to create a set with another OK 0.99.9 (PFV) } + +Program tbs0161; + +{the following program should give a syntax error, but causes an internal error} + +const s = [1,2,3,4,5]; + +var b: Byte; + +Begin + If b in [s] then; +End. diff --git a/tests/tbf/tb32.pp b/tests/tbf/tb32.pp new file mode 100644 index 0000000000..b22eaf187b --- /dev/null +++ b/tests/tbf/tb32.pp @@ -0,0 +1,17 @@ +{ Old file: tbf0164.pp } +{ crash when using undeclared array index in with statement OK 0.99.8 (PFV) } + +type t1r = record + a, b: Byte; + end; + t2r = record + l1, l2: Array[1..4] Of t1r; + end; + + +Var r: t2r; + +begin + with r.l1[counter] Do + Inc(a) +end. diff --git a/tests/tbf/tb33.pp b/tests/tbf/tb33.pp new file mode 100644 index 0000000000..00057ff20f --- /dev/null +++ b/tests/tbf/tb33.pp @@ -0,0 +1,13 @@ +{ Old file: tbf0166.pp } +{ forward type used in declaration crashes instead of error OK 0.99.9 (PFV) } + +type + punknown=^unknown; + + t=object + procedure p(i:unknown); + end; + +begin +end. + \ No newline at end of file diff --git a/tests/tbf/tb34.pp b/tests/tbf/tb34.pp new file mode 100644 index 0000000000..1890752664 --- /dev/null +++ b/tests/tbf/tb34.pp @@ -0,0 +1,12 @@ +{ Old file: tbf0167.pp } +{ crash when declaring a procedure with same name as object OK 0.99.9 (PFV) } + +type ObjTest = Object + End; + +Procedure ObjTest; +Begin +end; + +Begin +end. diff --git a/tests/tbf/tb35.pp b/tests/tbf/tb35.pp new file mode 100644 index 0000000000..bbf76fa78e --- /dev/null +++ b/tests/tbf/tb35.pp @@ -0,0 +1,9 @@ +{ Old file: tbf0168.pp } +{ set:=set+element is allowed (should be: set:=set+[element]) OK 0.99.9 (PFV) } + +var bset: set of 0..31; + b: byte; + +Begin + bset := bset + b; +End. diff --git a/tests/tbf/tb36.pp b/tests/tbf/tb36.pp new file mode 100644 index 0000000000..8b0ed1a6d9 --- /dev/null +++ b/tests/tbf/tb36.pp @@ -0,0 +1,14 @@ +{ Old file: tbf0172.pp } +{ with with absolute seg:ofs should not be possible OK 0.99.9 (PM) } + +type + rec=record + a : longint; + end; + +var + r1 : rec absolute $40:$49; +begin + with r1 do + a:=1; +end. diff --git a/tests/tbf/tb37.pp b/tests/tbf/tb37.pp new file mode 100644 index 0000000000..c3b8eb8ba6 --- /dev/null +++ b/tests/tbf/tb37.pp @@ -0,0 +1,12 @@ +{ Old file: tbf0173.pp } +{ secondbugs is parsed as asm, but should be normal pascalcode OK 0.99.9 (PFV) } + +var + secondbug : word; +procedure p;assembler; +begin + if secondbug=0 then; +end; + +begin +end. \ No newline at end of file diff --git a/tests/tbf/tb38.pp b/tests/tbf/tb38.pp new file mode 100644 index 0000000000..21cea93367 --- /dev/null +++ b/tests/tbf/tb38.pp @@ -0,0 +1,13 @@ +{ Old file: tbf0175.pp } +{ Asm, mov word,%eax should not be allowed without casting emits a warning (or error with range checking enabled) OK 0.99.11 (PM) } + +{ this will just give out an error } +{$asmmode att} +{$R+} +var + w : word; +begin + asm + movl w,%ecx + end; +end. \ No newline at end of file diff --git a/tests/tbf/tb39.pp b/tests/tbf/tb39.pp new file mode 100644 index 0000000000..482c8fc9f2 --- /dev/null +++ b/tests/tbf/tb39.pp @@ -0,0 +1,12 @@ +{ Old file: tbf0186.pp } +{ Erroneous array syntax is accepted. OK 0.99.9 (PFV) } + + program bug0186; + var + endline:^integer; + line:array [1..endline^] of ^char; + begin + new (endline); + endline^:=5; + endline^:=10; + end. diff --git a/tests/tbf/tb4.pp b/tests/tbf/tb4.pp new file mode 100644 index 0000000000..0bb5da6489 --- /dev/null +++ b/tests/tbf/tb4.pp @@ -0,0 +1,12 @@ +{ Old file: tbf0036.pp } +{ assigning a single character to array of char ?OK 0.9.9 } + +program bug0036; + +{Discovered by Daniel Mantione.} + +var a:array[0..31] of char; + +begin + a:=' '; {Incorrect Pascal statement, but why a protection error?} +end. diff --git a/tests/tbf/tb40.pp b/tests/tbf/tb40.pp new file mode 100644 index 0000000000..2ffc8916f5 --- /dev/null +++ b/tests/tbf/tb40.pp @@ -0,0 +1,12 @@ +{ Old file: tbf0196.pp } +{ "function a;" is accepted (should require result type) OK 0.99.1 (PM) } + +Program bug0195; + +function a; +begin +end; + +begin + a +end. diff --git a/tests/tbf/tb41.pp b/tests/tbf/tb41.pp new file mode 100644 index 0000000000..0ec1d3113a --- /dev/null +++ b/tests/tbf/tb41.pp @@ -0,0 +1,16 @@ +{ Old file: tbf0197.pp } +{ should produce an error: problem with c1:=c2 1000); + Writeln(c1); +end. \ No newline at end of file diff --git a/tests/tbf/tb42.pp b/tests/tbf/tb42.pp new file mode 100644 index 0000000000..3547b7a58f --- /dev/null +++ b/tests/tbf/tb42.pp @@ -0,0 +1,34 @@ +{ Old file: tbf0205.pp } +{ and parsing bugs, generates wrong code (tp7 gives parser error) OK 0.99.11 (PM) } + +program bug_show; +{ By PAV (pavsoft@usa.net) } + +function bad_uppercase(s:string):string; +var i:integer; +begin + for i:=1 to length(s) do + if (ord(s[i])>=97 and ord(s[i])<=122) then s[i]:=chr(ord(s[i])-97+65); + bad_uppercase:=s; +end; + +function good_uppercase(s:string):string; +var i:integer; +begin + for i:=1 to length(s) do + if (ord(s[i])>=97) and (ord(s[i])<=122) then s[i]:=chr(ord(s[i])-97+65); + good_uppercase:=s; +end; + +const cadena='Free Paskal Compiler 0.99.8 !!! (bug)'; +begin + writeln('This is the original string before convert it'); + writeln(cadena); + writeln(); + writeln('This is a bad result, using "if ( and )"'); + writeln(bad_uppercase(cadena)); + writeln(); + writeln('This is a good result, using "if () and ()"'); + writeln(good_uppercase(cadena)); + writeln(); +end. diff --git a/tests/tbf/tb43.pp b/tests/tbf/tb43.pp new file mode 100644 index 0000000000..36bede5401 --- /dev/null +++ b/tests/tbf/tb43.pp @@ -0,0 +1,14 @@ +{ Old file: tbf0208.pp } +{ implicit conversion from boolean to longint should not be allowed } + +program tbf0208; + +{ implicit boolean to integer conversion should not be + allowed } +var + b : boolean; + i : longint; +begin + b:=true; + i:=b; +end. \ No newline at end of file diff --git a/tests/tbf/tb44.pp b/tests/tbf/tb44.pp new file mode 100644 index 0000000000..21ad42c10b --- /dev/null +++ b/tests/tbf/tb44.pp @@ -0,0 +1,16 @@ +{ Old file: tbf0219.pp } +{ wrong error message OK 0.99.11 (PFV) } + +{ Should give '(' expected in line 6 } + + const + replaces=4; + replacetab : array[1..replaces,1..2] of string[32]=( + ':',' or colon', + 'mem8','mem or bits8', + 'mem16','mem or bits16', + 'mem32','mem or bits32' + ) +begin +end. + diff --git a/tests/tbf/tb45.pp b/tests/tbf/tb45.pp new file mode 100644 index 0000000000..45100ee35f --- /dev/null +++ b/tests/tbf/tb45.pp @@ -0,0 +1,17 @@ +{ Old file: tbf0230.pp } +{ several strange happen on the ln function: ln(0): no FPE and writeln can't write non numeric values Gives out an exception on compiling because of zero div OK 0.99.11 (PM) } + +{$ifdef go32v2} +uses + dpmiexcp; +{$endif} + +var + e : extended; + +begin + e:=-1.0; + writeln(ln(0)); + writeln(power(0,1.0)); + writeln(ln(e)); +end . diff --git a/tests/tbf/tb46.pp b/tests/tbf/tb46.pp new file mode 100644 index 0000000000..58e7a6fd17 --- /dev/null +++ b/tests/tbf/tb46.pp @@ -0,0 +1,20 @@ +{ Old file: tbf0231.pp } +{ Problem with comments OK 0.99.11 (PFV) } + + +{$undef dummy} + +{$ifdef DUMMY} + (* <= this should not be considered as a + higher comment level !! + + test +{$endif dummy} + +var + e : extended; + +begin + e:=1.0; + writeln(ln(e)); +end. diff --git a/tests/tbf/tb47.pp b/tests/tbf/tb47.pp new file mode 100644 index 0000000000..c71ff5ec16 --- /dev/null +++ b/tests/tbf/tb47.pp @@ -0,0 +1,11 @@ +{ Old file: tbf0234.pp } +{ New with void pointer OK 0.99.11 (PM) } + +program bug0232; + +var p:pointer; + +begin + new(p); + dispose(p); +end. diff --git a/tests/tbf/tb48.pp b/tests/tbf/tb48.pp new file mode 100644 index 0000000000..48cdfc96fc --- /dev/null +++ b/tests/tbf/tb48.pp @@ -0,0 +1,14 @@ +{ Old file: tbf0242.pp } +{ Crash when passing a procedure to formal parameter OK 0.99.11 (PM) } + +procedure p; +begin +end; + +procedure p1(var x); +begin +end; + +begin + p1(p); +end. \ No newline at end of file diff --git a/tests/tbf/tb49.pp b/tests/tbf/tb49.pp new file mode 100644 index 0000000000..5dab8dc5dd --- /dev/null +++ b/tests/tbf/tb49.pp @@ -0,0 +1,29 @@ +{ Old file: tbf0245.pp } +{ assigning pointers to address of consts is allowed (refused by BP !) OK 0.99.13 (PFV) } + +const + r = 3.5; + s = 'test idiot'; +type + preal = ^real; + pstring = ^string; + + procedure ss; + begin + end; + +var + p : pointer; + pr : preal; + ps : pstring; + + begin + p:=@ss; + p:=@s; + pr:=@r; + ps:=@s; + pr^:=7.8; + ps^:='test3'; + Writeln('r=',r,' s=',s); + end. + diff --git a/tests/tbf/tb5.pp b/tests/tbf/tb5.pp new file mode 100644 index 0000000000..a73cf60a1b --- /dev/null +++ b/tests/tbf/tb5.pp @@ -0,0 +1,14 @@ +{ Old file: tbf0049.pp } +{ shows an error while defining subrange types OK 0.99.7 (PFV) } + +type + days = (Mon,Tue,Wed,Thu,Fri,Sat,Sun); + weekend = Sat..Sun; + +var + w : weekend; + +begin + w:=5; + {$message the line before should produce an error } +end. diff --git a/tests/tbf/tb50.pp b/tests/tbf/tb50.pp new file mode 100644 index 0000000000..d42ab9110d --- /dev/null +++ b/tests/tbf/tb50.pp @@ -0,0 +1,16 @@ +{ Old file: tbf0246.pp } +{ const para can be changed without error OK 0.99.13 (PFV) } + +type + tref=record + ofs : longint; + end; + +procedure p(const ref:tref); +begin + with ref do + ofs:=ofs+1; { This should issue an error, because ref is const ! } +end; + +begin +end. \ No newline at end of file diff --git a/tests/tbf/tb51.pp b/tests/tbf/tb51.pp new file mode 100644 index 0000000000..c99d76a3a8 --- /dev/null +++ b/tests/tbf/tb51.pp @@ -0,0 +1,11 @@ +{ Old file: tbf0248.pp } +{ Asm, Wrong assembler code accepted by new assembler reader OK 0.99.11 (PFV) } + +{$asmmode att} + +begin + asm + call *%eax // this is correct + movl %esi,*%eax + end; +end. diff --git a/tests/tbf/tb52.pp b/tests/tbf/tb52.pp new file mode 100644 index 0000000000..18d49096f7 --- /dev/null +++ b/tests/tbf/tb52.pp @@ -0,0 +1,24 @@ +{ Old file: tbf0265.pp } +{ nested proc with for-counter in other lex level OK 0.99.13 (PFV) } + +PROGRAM t9; + +PROCEDURE Eeep; +VAR + X: BYTE; + NewNG: STRING; +PROCEDURE SubProc; + BEGIN + newng := 'alt'; + FOR X := 1 TO LENGTH(NewNG) DO BEGIN + WRITELN(X); + END; +END; +BEGIN + SubProc; +END; + +BEGIN + Eeep; +END. + diff --git a/tests/tbf/tb53.pp b/tests/tbf/tb53.pp new file mode 100644 index 0000000000..3801816a73 --- /dev/null +++ b/tests/tbf/tb53.pp @@ -0,0 +1,11 @@ +{ Old file: tbf0269.pp } +{ wrong linenumber for repeat until when type mismatch OK 0.99.12b (PM) } + +{ No idea how I could test this !! PM } +{ we should parse the compiler output !! } +{ Wrong line number for error message } +begin + repeat + writeln('test'); + until sptr; +end. diff --git a/tests/tbf/tb54.pp b/tests/tbf/tb54.pp new file mode 100644 index 0000000000..255c827f30 --- /dev/null +++ b/tests/tbf/tb54.pp @@ -0,0 +1,39 @@ +{ Old file: tbf0272.pp } +{ No error issued if wrong parameter in function inside a second function OK 0.99.13 (PFV) } + +program test_const_string; + +const + conststring = 'Constant string'; + +function astring(s :string) : string; + +begin + astring:='Test string'+s; +end; + +procedure testvar(var s : string); +begin + writeln('testvar s is "',s,'"'); +end; + +procedure testconst(const s : string); +begin + writeln('testconst s is "',s,'"'); +end; + +procedure testvalue(s : string); +begin + writeln('testvalue s is "',s,'"'); +end; + +const + s : string = 'test'; + +begin + testvalue(astring('e')); + testconst(astring(s)); + testconst(conststring); + testvar(conststring);{ refused a compile time } +end. + diff --git a/tests/tbf/tb55.pp b/tests/tbf/tb55.pp new file mode 100644 index 0000000000..ee1397e7e3 --- /dev/null +++ b/tests/tbf/tb55.pp @@ -0,0 +1,22 @@ +{ Old file: tbf0281.pp } +{ dup id checking with property is wrong } + +{$mode objfpc} + +type + test_one = class + protected + fTest : String; + public + property Test: String READ fTest WRITE fTest; + procedure Testen(Test: BOolean); + { ^ duplicate identifier? } + end; + + +procedure test_one.testen(test: boolean); +begin +end; + +begin +end. diff --git a/tests/tbf/tb56.pp b/tests/tbf/tb56.pp new file mode 100644 index 0000000000..f41605ce11 --- /dev/null +++ b/tests/tbf/tb56.pp @@ -0,0 +1,12 @@ +{ Old file: tbf0284.pp } +{ wrong file position with dup id in other unit OK 0.99.13 (PFV) } + +uses tbs0284b; +{$HINTS ON} +type + o2=object(o1) + p : longint; + end; + +begin +end. diff --git a/tests/tbf/tb57.pp b/tests/tbf/tb57.pp new file mode 100644 index 0000000000..5c3a20cf20 --- /dev/null +++ b/tests/tbf/tb57.pp @@ -0,0 +1,14 @@ +{ Old file: tbf0298.pp } +{ l1+l2:=l1+l2 gives no error OK 0.99.13 (PFV) } + +program test_loc_mem; + +{$ifdef go32v2} + uses + dpmiexcp; +{$endif go32v2} + +var l1,l2 : longint; +begin + l1+l2:=l1+l2; +end. diff --git a/tests/tbf/tb58.pp b/tests/tbf/tb58.pp new file mode 100644 index 0000000000..a0b6e4c7f5 --- /dev/null +++ b/tests/tbf/tb58.pp @@ -0,0 +1,7 @@ +{ Old file: tbf0300.pp } +{ crash if method on non existing object is parsed (form bugs 651) OK 0.99.13 (PFV) } + + procedure nonexistent_class_or_object.method; begin end; +begin +end. + diff --git a/tests/tbf/tb59.pp b/tests/tbf/tb59.pp new file mode 100644 index 0000000000..0995c104fa --- /dev/null +++ b/tests/tbf/tb59.pp @@ -0,0 +1,11 @@ +{ Old file: tbf0301.pp } +{ crash if destructor without object name is parsed OK 0.99.13 (PFV) } + +Program bug0301; + +destructor done; +begin +end; + +begin +end. \ No newline at end of file diff --git a/tests/tbf/tb6.pp b/tests/tbf/tb6.pp new file mode 100644 index 0000000000..fd09dd3c26 --- /dev/null +++ b/tests/tbf/tb6.pp @@ -0,0 +1,24 @@ +{ Old file: tbf0060.pp } +{ shows missing type checking for case statements OK 0.99.1 (CEC) } + +Program Test; + +{ No errors -- problems is due to the fact that the rules for type +compatibility (p.47 language guide) -- are not respected, in other words +in case statements there is no type checking whatsoever in fpc!! + I think that these are separate cases: + 1st case) s32bit,u32bit,u8bit,s8bit,s16bit,u16bit + 2nd case) uchar + 3rd case) bool8bit +These are not /should not be compatible with each other in a case +statement imho - CEC +} + +var + myvar:char; +Begin + case myvar of + 1: ; + #2: ; + end; +end. diff --git a/tests/tbf/tb60.pp b/tests/tbf/tb60.pp new file mode 100644 index 0000000000..24ef4e1465 --- /dev/null +++ b/tests/tbf/tb60.pp @@ -0,0 +1,13 @@ +{ Old file: tbf0310.pp } +{ local and para dup are not detected OK 0.99.15 (FK) } + +procedure p(s:string); +var + s : string; +begin + writeln(s); +end; + +begin + p('test'); +end. \ No newline at end of file diff --git a/tests/tbf/tb61.pp b/tests/tbf/tb61.pp new file mode 100644 index 0000000000..2faec32f27 --- /dev/null +++ b/tests/tbf/tb61.pp @@ -0,0 +1,14 @@ +{ Old file: tbf0311.pp } +{ No dup id checking in variant records OK 0.99.15 (FK) } + +type + tsplitextended = record + case byte of + 0: (a: array[0..9] of byte); + { the following "a" should give a duplicate identifier error } + 1: (a: array[0..4] of word); + 2: (a: array[0..1] of cardinal; w: word); + end; + +begin +end. diff --git a/tests/tbf/tb62.pp b/tests/tbf/tb62.pp new file mode 100644 index 0000000000..b2eed5c1b1 --- /dev/null +++ b/tests/tbf/tb62.pp @@ -0,0 +1,12 @@ +{ Old file: tbf0314.pp } +{ } + +procedure p(var b); +begin +end; + +var + s : string; +begin + p(@s[1]); +end. diff --git a/tests/tbf/tb63.pp b/tests/tbf/tb63.pp new file mode 100644 index 0000000000..f19a598ea9 --- /dev/null +++ b/tests/tbf/tb63.pp @@ -0,0 +1,8 @@ +{ Old file: tbf0315.pp } +{ } + +begin +asm + movl $%1000, %eax +end; +end. diff --git a/tests/tbf/tb64.pp b/tests/tbf/tb64.pp new file mode 100644 index 0000000000..8a5ccc1eac --- /dev/null +++ b/tests/tbf/tb64.pp @@ -0,0 +1,30 @@ +{ Old file: tbf0320.pp } +{ } + +{$ifdef fpc}{$mode delphi}{$endif} + +{ These should give an error, as also done in tp,delphi. + See tbs0319.pp for a test with class which should compile in + delphi mode } + +type + cl=object + k : longint; + procedure p1; + procedure p2; + end; + +procedure cl.p1; +var + k : longint; +begin +end; + +procedure cl.p2; +var + p1 : longint; +begin +end; + +begin +end. diff --git a/tests/tbf/tb65.pp b/tests/tbf/tb65.pp new file mode 100644 index 0000000000..768ad76e25 --- /dev/null +++ b/tests/tbf/tb65.pp @@ -0,0 +1,9 @@ +{ Old file: tbf0323.pp } +{ } + +{$ifdef fpc}{$mode delphi}{$endif} +type + TA = (aOne := 1, aTwo, aThree, aFour, aSix); + +begin +end. diff --git a/tests/tbf/tb66.pp b/tests/tbf/tb66.pp new file mode 100644 index 0000000000..82cfb9079d --- /dev/null +++ b/tests/tbf/tb66.pp @@ -0,0 +1,13 @@ +{ Old file: tbf0324.pp } +{ } + +{$ifdef fpc}{$mode delphi}{$endif} + +function k2:longint; +var + result : word; +begin +end; + +begin +end. \ No newline at end of file diff --git a/tests/tbf/tb67.pp b/tests/tbf/tb67.pp new file mode 100644 index 0000000000..515166a778 --- /dev/null +++ b/tests/tbf/tb67.pp @@ -0,0 +1,17 @@ +{ Old file: tbf0325.pp } +{ } + +{$ifdef fpc}{$mode delphi}{$endif} + +function k2(result:word):longint; +begin +end; + +function k3(l:word):longint; +var + result : word; +begin +end; + +begin +end. \ No newline at end of file diff --git a/tests/tbf/tb68.pp b/tests/tbf/tb68.pp new file mode 100644 index 0000000000..1665f91217 --- /dev/null +++ b/tests/tbf/tb68.pp @@ -0,0 +1,9 @@ +{ Old file: tbf0326.pp } +{ } + +{$mode delphi} +const + anyconst = %11111; + +begin +end. diff --git a/tests/tbf/tb69.pp b/tests/tbf/tb69.pp new file mode 100644 index 0000000000..e3cb71dcf6 --- /dev/null +++ b/tests/tbf/tb69.pp @@ -0,0 +1,24 @@ +{ Old file: tbf0328.pp } +{ } + +{$ifdef fpc}{$mode delphi}{$endif} + +procedure k1(l:longint); +begin +end; + +procedure k1(l:string);overload; +begin +end; + +procedure k2(l:longint);overload; +begin +end; + +procedure k2(l:string); +begin +end; + + +begin +end. diff --git a/tests/tbf/tb7.pp b/tests/tbf/tb7.pp new file mode 100644 index 0000000000..bb4726e808 --- /dev/null +++ b/tests/tbf/tb7.pp @@ -0,0 +1,6 @@ +{ Old file: tbf0061.pp } +{ shows wrong errors when compiling (NOT A bugs) OK 0.99.1 } + +Begin + 55ms; +end. diff --git a/tests/tbf/tb70.pp b/tests/tbf/tb70.pp new file mode 100644 index 0000000000..92214ccb58 --- /dev/null +++ b/tests/tbf/tb70.pp @@ -0,0 +1,8 @@ +{ Old file: tbf0342.pp } +{ } + +type + WORD=word; + +begin +end. diff --git a/tests/tbf/tb71.pp b/tests/tbf/tb71.pp new file mode 100644 index 0000000000..bc21f57ba7 --- /dev/null +++ b/tests/tbf/tb71.pp @@ -0,0 +1,12 @@ +{ Old file: tbf0343.pp } +{ } + +{$mode delphi} +type + TListEntry = record + Next: ^TListEntry; (*<-- Error message here*) + Data: Integer; + end; + +begin +end. diff --git a/tests/tbf/tb72.pp b/tests/tbf/tb72.pp new file mode 100644 index 0000000000..dddd8d964b --- /dev/null +++ b/tests/tbf/tb72.pp @@ -0,0 +1,8 @@ +{ Old file: tbf0345.pp } +{ } + +var + WORD : array[1..2] of word; + +begin +end. diff --git a/tests/tbf/tb73.pp b/tests/tbf/tb73.pp new file mode 100644 index 0000000000..3c00665702 --- /dev/null +++ b/tests/tbf/tb73.pp @@ -0,0 +1,12 @@ +{ Old file: tbf0347.pp } +{ } + +{$mode delphi} + +type x = ^longint; + +var y:x; + +begin + y [5]:=5; +end. diff --git a/tests/tbf/tb74.pp b/tests/tbf/tb74.pp new file mode 100644 index 0000000000..63a76f3a54 --- /dev/null +++ b/tests/tbf/tb74.pp @@ -0,0 +1,17 @@ +{ Old file: tbf0349.pp } +{ } + +{$mode delphi} + +type + TCl=class; + +const + b=1; + +type + TCL=class + end; + +begin +end. diff --git a/tests/tbf/tb75.pp b/tests/tbf/tb75.pp new file mode 100644 index 0000000000..47b63f3721 --- /dev/null +++ b/tests/tbf/tb75.pp @@ -0,0 +1,12 @@ +{ %OPT=-Sew } + +{ Old file: tbf0351.pp } + +{$MACRO OFF} + +{ The next line should give a Warning that macro support not has + been turned on } +{$define mac1 := writeln('test')} + +begin +end. diff --git a/tests/tbf/tb76.pp b/tests/tbf/tb76.pp new file mode 100644 index 0000000000..bad7b6481e --- /dev/null +++ b/tests/tbf/tb76.pp @@ -0,0 +1,18 @@ +{ Old file: tbf0352.pp } +{ } + +{$ifdef fpc}{$MODE OBJFPC}{$endif} + +Procedure Proc1(args:array of const); +begin +end; + +Procedure Proc2(args:array of longint); +Begin + { this should give an error } + Proc1(args); +End; + +Begin + Proc1([0,1]); +End. diff --git a/tests/tbf/tb77.pp b/tests/tbf/tb77.pp new file mode 100644 index 0000000000..e377b4b63e --- /dev/null +++ b/tests/tbf/tb77.pp @@ -0,0 +1,12 @@ +{ Old file: tbf0353.pp } +{ } + +{ $version >= 1.1} +type + ti = interface + private + procedure p; + end; + +begin +end. diff --git a/tests/tbf/tb78.pp b/tests/tbf/tb78.pp new file mode 100644 index 0000000000..62730a6fc1 --- /dev/null +++ b/tests/tbf/tb78.pp @@ -0,0 +1,11 @@ +{ Old file: tbf0354.pp } +{ } + +{ $version >= 1.1} +type + ti = interface + constructor create; + end; + +begin +end. diff --git a/tests/tbf/tb79.pp b/tests/tbf/tb79.pp new file mode 100644 index 0000000000..c2f588e714 --- /dev/null +++ b/tests/tbf/tb79.pp @@ -0,0 +1,11 @@ +{ Old file: tbf0355.pp } +{ } + +{ $version >= 1.1} +type + ti = interface + destructor destroy; + end; + +begin +end. diff --git a/tests/tbf/tb8.pp b/tests/tbf/tb8.pp new file mode 100644 index 0000000000..f6e84cb7d8 --- /dev/null +++ b/tests/tbf/tb8.pp @@ -0,0 +1,8 @@ +{ Old file: tbf0071.pp } +{ shows that an unterminated constant string in a writeln() statement crashes the compiler. } + +program tbf0071; + +begin + writeln (' +end. \ No newline at end of file diff --git a/tests/tbf/tb80.pp b/tests/tbf/tb80.pp new file mode 100644 index 0000000000..49211bc056 --- /dev/null +++ b/tests/tbf/tb80.pp @@ -0,0 +1,11 @@ +{ Old file: tbf0356.pp } +{ } + +{ $version >= 1.1} +type + ti = interface + l : longint; + end; + +begin +end. diff --git a/tests/tbf/tb81.pp b/tests/tbf/tb81.pp new file mode 100644 index 0000000000..fcb94bc7e7 --- /dev/null +++ b/tests/tbf/tb81.pp @@ -0,0 +1,12 @@ +{ Old file: tbf0357.pp } +{ } + +{ $version >= 1.1} +type + ti = interface + protected + procedure p; + end; + +begin +end. diff --git a/tests/tbf/tb82.pp b/tests/tbf/tb82.pp new file mode 100644 index 0000000000..3f1cfd9574 --- /dev/null +++ b/tests/tbf/tb82.pp @@ -0,0 +1,12 @@ +{ Old file: tbf0358.pp } +{ } + +{ $version >= 1.1} +type + ti = interface + public + procedure p; + end; + +begin +end. diff --git a/tests/tbf/tb83.pp b/tests/tbf/tb83.pp new file mode 100644 index 0000000000..4154523e52 --- /dev/null +++ b/tests/tbf/tb83.pp @@ -0,0 +1,12 @@ +{ Old file: tbf0359.pp } +{ } + +{ $version >= 1.1} +type + ti = interface + published + procedure p; + end; + +begin +end. diff --git a/tests/tbf/tb84.pp b/tests/tbf/tb84.pp new file mode 100644 index 0000000000..99b8e66ddc --- /dev/null +++ b/tests/tbf/tb84.pp @@ -0,0 +1,18 @@ +{ Old file: tbf0360.pp } +{ } + +procedure myproc; +var + a: word; + a: word; + a: word; + a: word; + a: word; +begin + a := 1; + writeln (a); +end; + +begin + myproc; +end. diff --git a/tests/tbf/tb85.pp b/tests/tbf/tb85.pp new file mode 100644 index 0000000000..b647d8d106 --- /dev/null +++ b/tests/tbf/tb85.pp @@ -0,0 +1,34 @@ +{ Old file: tbf0361.pp } +{ } + +type + + ExecProc = Procedure; + +type + MenuItem = record + Caption: String[32]; + Exec: ExecProc; + end; + +Procedure AddItem(ACaption: String; AExec: ExecProc; var Item: MenuItem); +begin + Item.Caption:=ACaption; + Item.Exec:=AExec; +end; + +Procedure ExecFirstItem; +begin + Writeln('Result of "Item 1"'); +end; + +var M1,M2,M3: MenuItem; + Ep: ExecProc; + +begin + AddItem('Item 1',Nil,M1); + Ep:=ExecFirstItem; // should give error in fpc mode + AddItem('Item 2',Ep,M2); + AddItem('Item 3',@ExecFirstItem,M3); +end. + diff --git a/tests/tbf/tb86.pp b/tests/tbf/tb86.pp new file mode 100644 index 0000000000..227e351a77 --- /dev/null +++ b/tests/tbf/tb86.pp @@ -0,0 +1,11 @@ + +type + r=record + a :longint; + end; +var + w : ^r; +begin + if w^<>$1111 then + writeln; +end. \ No newline at end of file diff --git a/tests/tbf/tb87.pp b/tests/tbf/tb87.pp new file mode 100644 index 0000000000..bc881bbccd --- /dev/null +++ b/tests/tbf/tb87.pp @@ -0,0 +1,8 @@ + +var + i,j : longint; +begin + i:=longint; + j:=i*word+j*shortint; + j:= 15 +5*i +(i*i)+sqr(word); +end. \ No newline at end of file diff --git a/tests/tbf/tb88.pp b/tests/tbf/tb88.pp new file mode 100644 index 0000000000..aa9e56898b --- /dev/null +++ b/tests/tbf/tb88.pp @@ -0,0 +1,10 @@ +{$mode objfpc} +label l; + +begin + try + goto l; + finally + end; + l: +end. diff --git a/tests/tbf/tb89.pp b/tests/tbf/tb89.pp new file mode 100644 index 0000000000..e73b2a460e --- /dev/null +++ b/tests/tbf/tb89.pp @@ -0,0 +1,10 @@ +{$mode objfpc} +label l; + +begin + try + finally + l: + end; + goto l; +end. diff --git a/tests/tbf/tb9.pp b/tests/tbf/tb9.pp new file mode 100644 index 0000000000..c86cedd388 --- /dev/null +++ b/tests/tbf/tb9.pp @@ -0,0 +1,34 @@ +{ Old file: tbf0075.pp } +{ shows invalid pchar output to console OK 0.99.1 } + +Unit tbs0075; + +Interface + + +Procedure MyTest;Far; { IMPLEMENTATION expected error. } + +{ Further information: NEAR IS NOT ALLOWED IN BORLAND PASCAL } +{ Therefore the bugfix should only be for the FAR keyword. } + Procedure MySecondTest; + +Implementation + +{ near and far are not allowed here, but maybe we don't care since they are ignored by } +{ FPC. } +Procedure MyTest; +Begin +end; + +Procedure MySecondTest;Far;Forward; + + +Procedure MySecondTest;Far; +Begin +end; + + + + + +end. diff --git a/tests/tbf/tb90.pp b/tests/tbf/tb90.pp new file mode 100644 index 0000000000..d07c380d99 --- /dev/null +++ b/tests/tbf/tb90.pp @@ -0,0 +1,10 @@ +{$mode objfpc} +label l; + +begin + try + except + goto l; + end; + l: +end. diff --git a/tests/tbf/tb91.pp b/tests/tbf/tb91.pp new file mode 100644 index 0000000000..1b7798f94c --- /dev/null +++ b/tests/tbf/tb91.pp @@ -0,0 +1,14 @@ +{$mode objfpc} +uses + sysutils; + +label l; + +begin + try + except + on e : exception do + goto l; + end; + l: +end. diff --git a/tests/tbf/tb92.pp b/tests/tbf/tb92.pp new file mode 100644 index 0000000000..a541df99d8 --- /dev/null +++ b/tests/tbf/tb92.pp @@ -0,0 +1,20 @@ +{$mode objfpc} +type + tc1 = class + l : longint; + property p : longint read l; + end; + + tc2 = class(tc1) + { in Delphi mode } + { parameters can have the same name as properties } + procedure p1(p : longint); + end; + +procedure tc2.p1(p : longint); + + begin + end; + +begin +end. diff --git a/tests/tbf/tb93.pp b/tests/tbf/tb93.pp new file mode 100644 index 0000000000..cce0e21c91 --- /dev/null +++ b/tests/tbf/tb93.pp @@ -0,0 +1,20 @@ + + +type + obj = object + procedure method1; + procedure method2; + end; + + procedure obj.method1; + + procedure obj.method2; + + begin + end; + + begin + end; + + begin + end. \ No newline at end of file diff --git a/tests/tbf/tb94.pp b/tests/tbf/tb94.pp new file mode 100644 index 0000000000..32985f1c04 --- /dev/null +++ b/tests/tbf/tb94.pp @@ -0,0 +1,23 @@ +{$mode objfpc} +type + to1 = class + procedure p;virtual; + end; + + to2 = class(to1) + function p : longint;override; + end; + + procedure to1.p; + + begin + end; + + function to2.p : longint; + + begin + end; + +begin +end. + diff --git a/tests/tbs/tb1.pp b/tests/tbs/tb1.pp new file mode 100644 index 0000000000..f2cad1bb0e --- /dev/null +++ b/tests/tbs/tb1.pp @@ -0,0 +1,12 @@ +{ Old file: tbs0001.pp } +{ tests a bugs in the .ascii output (#0 and too long) OK 0.9.2 } + +program smalltest; + const + teststr : string = ' '#9#255#0; +begin + writeln(teststr); + teststr := 'gaga'; + writeln(teststr); + if teststr<>'gaga' then halt(1); +end. diff --git a/tests/tbs/tb10.pp b/tests/tbs/tb10.pp new file mode 100644 index 0000000000..fb510e52af --- /dev/null +++ b/tests/tbs/tb10.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0012.pp } +{ tests type conversation byte(a>b) OK 0.9.9 (FK) } + +var + a,b : longint; + +begin + a:=1; + b:=2; + if byte(a>b)=byte(af then + halt(1); +end. diff --git a/tests/tbs/tb103.pp b/tests/tbs/tb103.pp new file mode 100644 index 0000000000..09457be669 --- /dev/null +++ b/tests/tbs/tb103.pp @@ -0,0 +1,21 @@ +{ Old file: tbs0121.pp } +{ cardinal -> byte conversion not work (and crashes) OK 0.99.6 (FK) } + +{$R+} +var + + c : cardinal; + i : integer; + w : word; + b : byte; + si : shortint; + +begin + w:=c; + i:=c; + b:=c; + b:=si; +end. + + + diff --git a/tests/tbs/tb104.pp b/tests/tbs/tb104.pp new file mode 100644 index 0000000000..34c49758ec --- /dev/null +++ b/tests/tbs/tb104.pp @@ -0,0 +1,12 @@ +{ Old file: tbs0122.pp } +{ exit() gives a warning that the result is not set OK 0.99.6 (FK) } + + +function f:longint; +begin + exit(1); +end; + +begin + writeln(f); +end. diff --git a/tests/tbs/tb105.pp b/tests/tbs/tb105.pp new file mode 100644 index 0000000000..5f88476260 --- /dev/null +++ b/tests/tbs/tb105.pp @@ -0,0 +1,21 @@ +{ Old file: tbs0123.pp } +{ Asm, problem with intel assembler (shrd) OK 0.99.11 (PM) } + +{ bug for shrd assemblerreader } +begin + if false then + begin +{$asmmode intel} + asm + SHRD [ESI-8], EAX, CL + SHLD EBX,ECX,5 + IMUL ECX,dword [EBP-8],5 + end; +{$asmmode att} + asm + shrdl %cl,%eax,-8(%esi) + shldl $5,%ecx,%ebx + imull $5,-8(%ebp),%ecx + end; + end; +end. diff --git a/tests/tbs/tb106.pp b/tests/tbs/tb106.pp new file mode 100644 index 0000000000..3cece386ce --- /dev/null +++ b/tests/tbs/tb106.pp @@ -0,0 +1,45 @@ +{ %OPT= -Aas } + +{ Old file: tbs0124.pp } +{ Asm, problem with -Rintel switch and indexing OK 0.99.11 (PM/PFV) } + +{ this problem comes from the fact that + L is a static variable, not a local one !! + but the static variable symtable is the localst of the + main procedure (PM) + It must be checked if we are at main level or not !! } + +var + l : longint; + + procedure error; + begin + Writeln('Error in tbs0124'); + Halt(1); + end; + +begin +{$asmmode direct} + asm + movl $5,l + end; + if l<>5 then error; +{$asmmode att} + asm + movl l,%eax + addl $2,%eax + movl %eax,l + end; + if l<>7 then error; +{$asmmode intel} + { problem here is that l is replaced by BP-offset } + { relative to stack, and the parser thinks all wrong } + { because of this. } + asm + mov eax,l + add eax,5 + mov l,eax + end; + if l<>12 then error; + Writeln('tbs0124 OK'); +end. diff --git a/tests/tbs/tb107.pp b/tests/tbs/tb107.pp new file mode 100644 index 0000000000..76998f8fe7 --- /dev/null +++ b/tests/tbs/tb107.pp @@ -0,0 +1,24 @@ +{ Old file: tbs0124b.pp } +{ } + +{$asmmode intel} +var + i : byte; + l : array[0..7] of longint; +begin + { problem here is that l is replaced by BP-offset } + { relative to stack, and the parser thinks all wrong } + { because of this. } + + for i:=0 to 7 do + l[i]:=35; + asm + mov eax,3 + mov l[eax*4],55 + end; + if l[3]<>55 then + begin + Writeln('Error in parsing assembler'); + Halt(1); + end; +end. diff --git a/tests/tbs/tb108.pp b/tests/tbs/tb108.pp new file mode 100644 index 0000000000..896c8b9ee3 --- /dev/null +++ b/tests/tbs/tb108.pp @@ -0,0 +1,15 @@ +{ Old file: tbs0125.pp } +{ wrong colors with DOS CRT unit OK 0.99.6 (PFV) } + +uses +crt; +var +i:integer; +begin +clrscr; +textcolor(blue); +writeln('ole'); +textcolor(red); +writeln('rasmussen'); +writeln(i); +end. diff --git a/tests/tbs/tb109.pp b/tests/tbs/tb109.pp new file mode 100644 index 0000000000..a734bccb42 --- /dev/null +++ b/tests/tbs/tb109.pp @@ -0,0 +1,8 @@ +{ Old file: tbs0126.pp } +{ packed array isn't allowed OK 0.99.6 (FK) } + +type + myarray = packed array[0..10] of longint; + +begin +end. diff --git a/tests/tbs/tb11.pp b/tests/tbs/tb11.pp new file mode 100644 index 0000000000..6f2bb8cd5d --- /dev/null +++ b/tests/tbs/tb11.pp @@ -0,0 +1,12 @@ +{ Old file: tbs0013.pp } +{ } + +procedure test(w : word); + + begin + end; + +begin + test(1234); +end. + diff --git a/tests/tbs/tb110.pp b/tests/tbs/tb110.pp new file mode 100644 index 0000000000..ea0d97f340 --- /dev/null +++ b/tests/tbs/tb110.pp @@ -0,0 +1,12 @@ +{ Old file: tbs0128.pp } +{ problem with ^[ OK 0.99.6 (PFV) } + +{ ^ followed by a letter must be interpreted differently + depending on context } + +const + ArrowKeysOrFirstLetter='arrow keys '^]^r^z' or First letter. '; + +begin + writeln(ord(^))); +end. diff --git a/tests/tbs/tb111.pp b/tests/tbs/tb111.pp new file mode 100644 index 0000000000..df0d39e4cb --- /dev/null +++ b/tests/tbs/tb111.pp @@ -0,0 +1,15 @@ +{ Old file: tbs0129.pp } +{ endless loop with while/continue OK 0.99.6 (FK) } + +var + e:boolean; + a:integer; +begin + e:=true; + a:=3; + while (a<5) and e do begin + e:=false; + write('*'); + continue; + end; +end. \ No newline at end of file diff --git a/tests/tbs/tb112.pp b/tests/tbs/tb112.pp new file mode 100644 index 0000000000..1b0bc50866 --- /dev/null +++ b/tests/tbs/tb112.pp @@ -0,0 +1,14 @@ +{ Old file: tbs0130.pp } +{ in [..#255] problem OK 0.99.6 (PFV) } + +var + c : char; +begin + c:=#91; + if c in [#64..#255] then + writeln('boe'); + c:=#32; + if c in [#64..#255] then + writeln('boe'); +end. + diff --git a/tests/tbs/tb113.pp b/tests/tbs/tb113.pp new file mode 100644 index 0000000000..bf08a01e4a --- /dev/null +++ b/tests/tbs/tb113.pp @@ -0,0 +1,14 @@ +{ Old file: tbs0131.pp } +{ internal error 10 with highdimension arrays OK 0.99.6 (MVC) } + +type TA = Array[1..2,1..2,1..2,1..2,1..2,1..2,1..3,1..3,1..3,1..3] of Byte; + +var v,w: ta; + e: longint; + +Begin + e :=1; + v[e,e,e,e,e,e,e,e,e,e] :=1; + w[e,e,e,e,e,e,v[e,e,e,e,e,e,e,e,e,e],e,e,v[e,e,e,e,e,e,v[e,v[e,e,e,e,e,v[e,e,e,e,e,e,e,e,e,e],e,e,e,e],e,e,e,e,e,e,e,e],e,e,e]] := v [e,e,e,e,e,e,e,e,e,e]; + writeln(w[e,e,e,e,e,e,e,e,e,e]) +end. diff --git a/tests/tbs/tb114.pp b/tests/tbs/tb114.pp new file mode 100644 index 0000000000..a800f78b95 --- /dev/null +++ b/tests/tbs/tb114.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0132.pp } +{ segmentation fault with type loop OK 0.99.7 (FK) } + +type + + p=^p2; + p2 = ^p; + + var a:p; + a2:p2; + + begin + a:=@a2; + a2:=@a; + a:=a2^; + end. \ No newline at end of file diff --git a/tests/tbs/tb115.pp b/tests/tbs/tb115.pp new file mode 100644 index 0000000000..795f39220f --- /dev/null +++ b/tests/tbs/tb115.pp @@ -0,0 +1,17 @@ +{ Old file: tbs0133.pp } +{ object type declaration not 100% compatibile with TP7 } + +type + t=object + f : longint; + procedure p; + g : longint; { Not allowed in BP7 } + end; + + procedure t.p; + begin + end; + + begin + end. + diff --git a/tests/tbs/tb116.pp b/tests/tbs/tb116.pp new file mode 100644 index 0000000000..a434a56641 --- /dev/null +++ b/tests/tbs/tb116.pp @@ -0,0 +1,34 @@ +{ Old file: tbs0134.pp } +{ 'continue' keyword is bugsgy. OK 0.99.6 (FK) } + +{ +In this simple examply, the even loop is wrong. When continue; is called, +it should go back to the top and check the loop conditions and exit when i = +4, but continue skips checking the loop conditions and does i=5 too, then it +is odd, doesn't run the continue, and the loop terminates properly. +} + + +procedure demoloop( max:integer ); +var i : integer; +begin +i := 1; +while (i <= max) do + begin + if (i mod 2 = 0) then + begin + writeln('Even ',i,' of ',max); + inc(i); + continue; + end; + writeln('Odd ',i,' of ',max); + inc(i); + end; +end; + +begin +writeln('Odd loop (continue is *not* last call):'); +demoloop(3); +writeln('Even loop (continue is last call):'); +demoloop(4); +end. diff --git a/tests/tbs/tb117.pp b/tests/tbs/tb117.pp new file mode 100644 index 0000000000..4c76d970e8 --- /dev/null +++ b/tests/tbs/tb117.pp @@ -0,0 +1,13 @@ +{ Old file: tbs0135.pp } +{ Unsupported subrange type construction. OK 0.99.6 } + +program test; +const + A = 0; + B = 1; + C = 2; + +type D = A..C; + +begin +end. \ No newline at end of file diff --git a/tests/tbs/tb118.pp b/tests/tbs/tb118.pp new file mode 100644 index 0000000000..53627e5aec --- /dev/null +++ b/tests/tbs/tb118.pp @@ -0,0 +1,48 @@ +{ Old file: tbs0137.pp } +{ Cannot assign child object variable to parent objcet type variable OK 0.99.6 } + +program OO_Test; + +Type TVater = Object + Constructor Init; + Procedure Gehen; Virtual; + Procedure Laufen; Virtual; + End; + + TSohn = Object(TVater) + Procedure Gehen; Virtual; + End; + +Var V : TVater; + S : TSohn; + +Constructor TVater.Init; +Begin +End; + +Procedure TVater.Gehen; +Begin + Writeln('langsam gehen'); +End; + +Procedure TVater.Laufen; +Begin + Gehen; + Gehen; +End; + +Procedure TSohn.Gehen; +Begin + Writeln('schnell gehen'); +End; + +Begin + V.Init; + S.Init; + V.Laufen; + Writeln; + S.Laufen; + Writeln; + V := S; + V.Gehen; +End. diff --git a/tests/tbs/tb119.pp b/tests/tbs/tb119.pp new file mode 100644 index 0000000000..1d5949cadd --- /dev/null +++ b/tests/tbs/tb119.pp @@ -0,0 +1,38 @@ +{ Old file: tbs0138.pp } +{ with problem, %esi can be crushed and is not restored OK 0.99.6 (PM) } + +{program p; uncomment for a crash} +type + tpt=^tpo; + tpo=object + constructor init; + procedure pi1; + procedure pi2; + end; +constructor tpo.init; +begin +end; +procedure tpo.pi1; +begin +end; +procedure tpo.pi2; +begin +end; +procedure crushesi;assembler; +asm + movl %eax,%esi +end ['EAX','ESI']; +var + p1 : tpt; +begin + p1:=new(tpt,init); + with p1^ do + begin + pi1; + crushesi; { After this the %esi should be reloaded from the tempvariable } + pi1; + end; +{ There is here already a tempvar for %esi, why not use it here too ? } + p1^.pi2; + p1^.pi2; +end. diff --git a/tests/tbs/tb12.pp b/tests/tbs/tb12.pp new file mode 100644 index 0000000000..97c602499e --- /dev/null +++ b/tests/tbs/tb12.pp @@ -0,0 +1,25 @@ +{ Old file: tbs0014.pp } +{ } + +type + prec = ^trec; + + trec = record + p : prec; + l : longint; + end; + +function test(p1,p2 : prec) : boolean; + + begin + if p1^.l=12 then + case p1^.l of + 123 : test:=(test(p1^.p,p2^.p) and test(p1^.p,p2^.p)) or + (test(p1^.p,p2^.p) and test(p1^.p,p2^.p)); + 1234 : test:=(test(p1^.p,p2^.p) and test(p1^.p,p2^.p)) or + (test(p1^.p,p2^.p) and test(p1^.p,p2^.p)); + end; + end; + +begin +end. diff --git a/tests/tbs/tb120.pp b/tests/tbs/tb120.pp new file mode 100644 index 0000000000..63f5abf943 --- /dev/null +++ b/tests/tbs/tb120.pp @@ -0,0 +1,26 @@ +{ Old file: tbs0139.pp } +{ Cannot access protected method of ancestor class from other unit. OK 0.99.6 } + +unit tb120; + +{$mode objfpc} + + interface + uses + tb121; + + type + AnotherClass=class(SomeClass) + protected + procedure doSomething; override; + end ; + + implementation + + procedure AnotherClass.doSomething; + begin + inherited doSomething; // this causes the error: " can not call protected + // method from here " ( or something similar ) + end ; + +end. \ No newline at end of file diff --git a/tests/tbs/tb121.pp b/tests/tbs/tb121.pp new file mode 100644 index 0000000000..eb04761fd4 --- /dev/null +++ b/tests/tbs/tb121.pp @@ -0,0 +1,24 @@ +{ Old file: tbs0139a.pp } +{ } + + unit tb121; + +{$mode objfpc} + + interface + + type + SomeClass=class(TObject) + protected + procedure doSomething; virtual; + end ; + + implementation + + + procedure SomeClass.doSomething; + begin + Writeln ('Hello from SomeClass.DoSomething'); + end ; + +end. \ No newline at end of file diff --git a/tests/tbs/tb122.pp b/tests/tbs/tb122.pp new file mode 100644 index 0000000000..c3e7667fee --- /dev/null +++ b/tests/tbs/tb122.pp @@ -0,0 +1,27 @@ +{ Old file: tbs0140.pp } +{ Shows that interdependent units still are not OK. OK 0.99.6 (PFV) } + +unit tb122; + +{ + The first compilation runs fine. + A second compilation (i.e; .ppu files exist already) crashes the compiler !! +} + +interface + +type + TObject = object + constructor Init(aPar:byte); + end; + +implementation + +uses tb123; + +constructor TObject.Init(aPar:byte); + begin + if aPar=0 then Message(Self); + end; + +end. diff --git a/tests/tbs/tb123.pp b/tests/tbs/tb123.pp new file mode 100644 index 0000000000..cd2b9af3bc --- /dev/null +++ b/tests/tbs/tb123.pp @@ -0,0 +1,17 @@ +{ Old file: tbs0140a.pp } +{ } + + +unit tb123; + +interface + +uses tb122; + +procedure Message(var O:TObject); + +implementation + +procedure Message(var O:TObject); + begin writeln('Message') end; +end. diff --git a/tests/tbs/tb124.pp b/tests/tbs/tb124.pp new file mode 100644 index 0000000000..787b17eb14 --- /dev/null +++ b/tests/tbs/tb124.pp @@ -0,0 +1,71 @@ +{ %OPT= -S2 } + +{ Old file: tbs0141.pp } +{ Wrong Class sizes when using forwardly defined classes. OK 0.99.6 } + +program bug; + +{ uses objpas; not with -S2 !! } +type + // + TObjectAB = class; + TObjectABCD = class; + TObjectABCDEF = class; + // } + TObjectAB = class(tobject) + a, b: integer; + end ; + TObjectABCD = class(TObjectAB) + c, d: integer; + end ; + TObjectABCDEF = class(TObjectABCD) + e, f: integer; + end ; + +var + a, b, c: TObject; + +begin +a := TObjectAB.Create; +WriteLn(a.InstanceSize, ' Should be: 12'); +if a.InstanceSize + SizeOf(integer)*2 <> TObjectABCD.InstanceSize then + Halt(1); +b := TObjectABCD.Create; +if b.InstanceSize + SizeOf(integer)*2 <> TObjectABCDEF.InstanceSize then + Halt(1); +WriteLn(b.InstanceSize, ' Should be: 20'); +c := TObjectABCDEF.Create; +WriteLn(c.InstanceSize, ' Should be: 28'); +end. + +{ +Here are the VMT tables from the assembler file: + +.globl VMT_TD$_TOBJECTAB +VMT_TD$_TOBJECTAB: + .long 12,-12 + .long VMT_OBJPAS$_TOBJECT + .long _OBJPAS$$_$$_TOBJECT_DESTROY + .long _OBJPAS$$_$$_TOBJECT_NEWINSTANCE + .long _OBJPAS$$_$$_TOBJECT_FREEINSTANCE + .long _OBJPAS$$_$$_TOBJECT_SAFECALLEXCEPTION$TOBJECT$POINTER + .long _OBJPAS$$_$$_TOBJECT_DEFAULTHANDLER$$$$ +.globl VMT_TD$_TOBJECTABCD +VMT_TD$_TOBJECTABCD: + .long 12,-12 + .long VMT_TD$_TOBJECTAB + .long _OBJPAS$$_$$_TOBJECT_DESTROY + .long _OBJPAS$$_$$_TOBJECT_NEWINSTANCE + .long _OBJPAS$$_$$_TOBJECT_FREEINSTANCE + .long _OBJPAS$$_$$_TOBJECT_SAFECALLEXCEPTION$TOBJECT$POINTER + .long _OBJPAS$$_$$_TOBJECT_DEFAULTHANDLER$$$$ +.globl VMT_TD$_TOBJECTABCDEF +VMT_TD$_TOBJECTABCDEF: + .long 12,-12 + .long VMT_TD$_TOBJECTABCD + .long _OBJPAS$$_$$_TOBJECT_DESTROY + .long _OBJPAS$$_$$_TOBJECT_NEWINSTANCE + .long _OBJPAS$$_$$_TOBJECT_FREEINSTANCE + .long _OBJPAS$$_$$_TOBJECT_SAFECALLEXCEPTION$TOBJECT$POINTER + .long _OBJPAS$$_$$_TOBJECT_DEFAULTHANDLER$$$$ +} \ No newline at end of file diff --git a/tests/tbs/tb125.pp b/tests/tbs/tb125.pp new file mode 100644 index 0000000000..4b2d9a184b --- /dev/null +++ b/tests/tbs/tb125.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0142.pp } +{ sizeof(object) is not tp7 compatible when no constructor is used OK 0.99.9 (PM) } + + +{$PACKRECORDS 1} + +type +Time = object + h,m,s:byte; +end; + +var OT:Time; + l : longint; +begin + l:=SizeOf(OT); +end. diff --git a/tests/tbs/tb126.pp b/tests/tbs/tb126.pp new file mode 100644 index 0000000000..2d691e51b0 --- /dev/null +++ b/tests/tbs/tb126.pp @@ -0,0 +1,14 @@ +{ Old file: tbs0143.pp } +{ cannot concat string and array of char in $X+ mode OK 0.99.7 (PFV) } + + + +const + string1 : string = 'hello '; + string2 : array[1..5] of char = 'there'; +var + s : string; +begin + s:=string1+string2; + writeln(string1+string2); +end. \ No newline at end of file diff --git a/tests/tbs/tb127.pp b/tests/tbs/tb127.pp new file mode 100644 index 0000000000..fd554b2cbd --- /dev/null +++ b/tests/tbs/tb127.pp @@ -0,0 +1,24 @@ +{ Old file: tbs0144.pp } +{ problem with 'with object do' OK 0.99.7 (PFV) } + +program done_bug; + +type +TObject = object + Constructor Init; + Destructor Done; +end; +PObject = ^TObject; + +Constructor TObject.Init; +begin end; +Destructor TObject.Done; +begin end; + +var P:PObject; + +begin +New(P,Init); +with P^ do Done; { Compiler PANIC here ! } +Dispose(P); +end. diff --git a/tests/tbs/tb128.pp b/tests/tbs/tb128.pp new file mode 100644 index 0000000000..2840628ff5 --- /dev/null +++ b/tests/tbs/tb128.pp @@ -0,0 +1,33 @@ +{ Old file: tbs0145.pp } +{ typed files with huges records (needs filerec.size:longint) OK 0.99.7 (PFV) } + +{$I+} +const + Mb=512; + siz=1024*Mb; + +type + buf=array[1..siz] of byte; + +var + fin, + fout : file of buf; + b1,a1 : buf; + +begin + fillchar(a1,sizeof(a1),1); + assign(fout,'tmp.tmp'); + rewrite(fout); + write(fout,a1); + close(fout); + + assign(fin,'tmp.tmp'); + reset(fin); + read(fin,b1); + close(fin); + if not b1[512*Mb]=1 then + begin + writeln('data err'); + Halt(1); + end; +end. \ No newline at end of file diff --git a/tests/tbs/tb129.pp b/tests/tbs/tb129.pp new file mode 100644 index 0000000000..439489df25 --- /dev/null +++ b/tests/tbs/tb129.pp @@ -0,0 +1,17 @@ +{ Old file: tbs0146.pp } +{ no sizeof() for var arrays and the size is pushed incorrect OK 0.99.7 (PFV) } + + +procedure myfunction(var t : array of char); +begin + writeln(sizeof(t)); { should be 51 } + if sizeof(t)<>51 then halt(1); +end; + +var + mycharstring : array[0..50] of char; + +begin + myfunction(mycharstring); + if sizeof(mycharstring)<>51 then halt(1); +end. diff --git a/tests/tbs/tb13.pp b/tests/tbs/tb13.pp new file mode 100644 index 0000000000..4aa1086cd4 --- /dev/null +++ b/tests/tbs/tb13.pp @@ -0,0 +1,24 @@ +{ Old file: tbs0015.pp } +{ tests for wrong allocated register for return result of floating function (allocates int register) OK 0.9.2 } + +program test; +type + realgr= array [1..1000] of double; +var + sx :realgr; + i :integer; + stemp :double; +begin + sx[1]:=10; + sx[2]:=-20; + sx[3]:=30; + sx[4]:=-40; + sx[5]:=50; + sx[6]:=-60; + i:=1; + stemp:=1000; + stemp := stemp+abs(sx[i])+abs(sx[i+1])+abs(sx[i+2])+abs(sx[i+3])+ + abs(sx[i+4])+abs(sx[i+5]); + writeln(stemp); + if stemp<>1210.0 then halt(1); +end. diff --git a/tests/tbs/tb130.pp b/tests/tbs/tb130.pp new file mode 100644 index 0000000000..5bd8b5f5ad --- /dev/null +++ b/tests/tbs/tb130.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0147.pp } +{ function b; is not allowed in implementation OK 0.99.7 (PFV) } + +{$mode tp} +unit tb130; +interface + +function b:boolean; + +implementation + +function b; +begin +end; + +end. diff --git a/tests/tbs/tb131.pp b/tests/tbs/tb131.pp new file mode 100644 index 0000000000..76018cae7b --- /dev/null +++ b/tests/tbs/tb131.pp @@ -0,0 +1,13 @@ +{ Old file: tbs0149a.pp } +{ } + +unit tb131; + +interface + +Const tset = [1,2,3,4,5]; + c = 1; + +implementation + +end. diff --git a/tests/tbs/tb132.pp b/tests/tbs/tb132.pp new file mode 100644 index 0000000000..5c6be74ed6 --- /dev/null +++ b/tests/tbs/tb132.pp @@ -0,0 +1,28 @@ +{ Old file: tbs0149b.pp } +{ } + +{there is no crash when tset or c from unit a are used in OuterProcedure, + it's only a problem when using them in a nested procedure/function} + +unit tb132; + +interface + +uses tb131; + +implementation + +Procedure OuterProcedure; + + function t(a: byte): byte; + begin + if a = c then t := a else t := 0; + if a in tset {probably same bug} + then t := a + else t := 0 + end; + +Begin +End; + +end. diff --git a/tests/tbs/tb133.pp b/tests/tbs/tb133.pp new file mode 100644 index 0000000000..2ac610de45 --- /dev/null +++ b/tests/tbs/tb133.pp @@ -0,0 +1,30 @@ +{ Old file: tbs0150.pp } +{ Shows that the assert() macro is missing under Delphi OK 0.99.9 (PFV) } + +program bug0150; +{ + bug to show that there is no assert() macro and directive +} + +var B : boolean; + i : integer; + +begin + b:=true; + i:=0; + // First for assert messages should not give anything. + // First two generate code, but are OK. + // second two don't generate code ($C- !) +{$c+} + assert (b); + assert (I=0); +{$c-} + assert (not(b)); + assert (i<>0); +{$c+} + // This one should give the normal assert message. + assert (not(b)); + // This one should give a custom assert message. + // you must uncomment the previous one to see this one. + assert (not(I=0),'Custom assert message'); +end. diff --git a/tests/tbs/tb134.pp b/tests/tbs/tb134.pp new file mode 100644 index 0000000000..07232d08c1 --- /dev/null +++ b/tests/tbs/tb134.pp @@ -0,0 +1,39 @@ +{ Old file: tbs0152.pp } +{ End value of loop variable must be calculated before loop variable is initialized. OK 0.99.11 (PM) } + +Program tbs0152; + +{ + Shows wrong evaluation of loop boundaries. First end boundary must + be calculated, only then Loop variable should be initialized. + Change loop variable to J to see what should be the correct output. +} + +PROCEDURE LGrow(VAR S : String;C:CHAR;Count:WORD); + + VAR I,J :WORD; + +BEGIN + I:=ORD(S[0]); { Keeping length in local data eases optimalisations} + IF I'1111111abcedfghij' then + begin + writeln('tbs0152 fails'); + halt(1); + end; +end. diff --git a/tests/tbs/tb135.pp b/tests/tbs/tb135.pp new file mode 100644 index 0000000000..aa2ffefc87 --- /dev/null +++ b/tests/tbs/tb135.pp @@ -0,0 +1,11 @@ +{ Old file: tbs0154.pp } +{ Subrange types give type mismatch when assigning to OK 0.99.7 (PFV) } + +type + week=(mon,tue,wed); +Var + w : week; + w1 : mon..tue; +begin + w1:=w; +end. diff --git a/tests/tbs/tb136.pp b/tests/tbs/tb136.pp new file mode 100644 index 0000000000..5b861fad2c --- /dev/null +++ b/tests/tbs/tb136.pp @@ -0,0 +1,7 @@ +{ Old file: tbs0156a.pp } +{ } + +uses tb137; + +begin +end. diff --git a/tests/tbs/tb137.pp b/tests/tbs/tb137.pp new file mode 100644 index 0000000000..572251f471 --- /dev/null +++ b/tests/tbs/tb137.pp @@ -0,0 +1,15 @@ +{ Old file: tbs0156b.pp } +{ } + +unit tb137; +interface + +type + _win_st = record + _parent : ^WINDOW; + end; + WINDOW = _win_st; + +implementation + +end. \ No newline at end of file diff --git a/tests/tbs/tb138.pp b/tests/tbs/tb138.pp new file mode 100644 index 0000000000..4e515b63da --- /dev/null +++ b/tests/tbs/tb138.pp @@ -0,0 +1,13 @@ +{ Old file: tbs0157.pp } +{ Invalid compilation and also crashes OK 0.99.7 (PFV) } + +{ this should be rejected because we only accept integer args } + +program write_it; +var x,y:real; +begin +x:=5.6; +y:=45.789; +write(y:2:3,x:3:4); +{write(y:3.2,x:5.2);} +end. diff --git a/tests/tbs/tb139.pp b/tests/tbs/tb139.pp new file mode 100644 index 0000000000..c0f21b6d03 --- /dev/null +++ b/tests/tbs/tb139.pp @@ -0,0 +1,25 @@ +{ Old file: tbs0159.pp } +{ Invalid virtual functions - should compile OK 0.99.7 (FK) } + +Type TParent = Object + Procedure SomeProc; + end; + + TChild = Object(TParent) + Procedure SomeProc; virtual; + end; + + + Procedure TParent.someproc; + Begin + end; + + + procedure TChild.Someproc; + Begin + end; + + + +Begin +end. \ No newline at end of file diff --git a/tests/tbs/tb14.pp b/tests/tbs/tb14.pp new file mode 100644 index 0000000000..0bd3e8d3a0 --- /dev/null +++ b/tests/tbs/tb14.pp @@ -0,0 +1,196 @@ +{ Old file: tbs0016.pp } +{ } + + uses + crt; + + const + { ... parameters } + w = 10; { max. 10 } + h = 10; { max. 10 } + + type + tp = array[0..w,0..h] of double; + + var + temp : tp; + phi : tp; + Bi : tp; + + boundary : array[0..w,0..h] of double; + + function start_temp(i,j : longint) : double; + + begin + start_temp:=(boundary[i,0]*(h-j)+boundary[i,h]*j+boundary[0,j]*(w-i)+boundary[w,j]*i)/(w+h); + end; + + procedure init; + + var + i,j : longint; + + begin + for i:=0 to w do + for j:=0 to h do + temp[i,j]:=start_temp(i,j); + end; + + procedure draw; + + var + i,j : longint; + + begin + for i:=0 to w do + for j:=0 to h do + begin + textcolor(white); + gotoxy(i*7+1,j*2+1); + writeln(temp[i,j]:6:0); + textcolor(darkgray); + gotoxy(i*7+1,j*2+2); + writeln(phi[i,j]:6:3); + end; + end; + + procedure calc_phi; + + var + i,j : longint; + + begin + for i:=0 to w do + for j:=0 to h do + begin + if (i=0) and (j=0) then + begin + phi[i,j]:=Bi[i,j]*boundary[i,j]+0.5*temp[i,j+1]+0.5*temp[i+1,j]-(1+Bi[i,j])*temp[i,j]; + end + else if (i=0) and (j=h) then + begin + phi[i,j]:=Bi[i,j]*boundary[i,j]+0.5*temp[i,j-1]+0.5*temp[i+1,j]-(1+Bi[i,j])*temp[i,j]; + end + else if (i=w) and (j=0) then + begin + phi[i,j]:=Bi[i,j]*boundary[i,j]+0.5*temp[i,j+1]+0.5*temp[i-1,j]-(1+Bi[i,j])*temp[i,j]; + end + else if (i=w) and (j=h) then + begin + phi[i,j]:=Bi[i,j]*boundary[i,j]+0.5*temp[i,j-1]+0.5*temp[i-1,j]-(1+Bi[i,j])*temp[i,j]; + end + else if i=0 then + begin + phi[i,j]:=Bi[i,j]*boundary[i,j]+temp[i+1,j]+0.5*temp[i,j-1]+0.5*temp[i,j+1]-(2+Bi[i,j])*temp[i,j]; + end + else if i=w then + begin + phi[i,j]:=Bi[i,j]*boundary[i,j]+temp[i-1,j]+0.5*temp[i,j-1]+0.5*temp[i,j+1]-(2+Bi[i,j])*temp[i,j]; + end + else if j=0 then + begin + phi[i,j]:=Bi[i,j]*boundary[i,j]+temp[i,j+1]+0.5*temp[i-1,j]+0.5*temp[i+1,j]-(2+Bi[i,j])*temp[i,j]; + end + else if j=h then + begin + phi[i,j]:=Bi[i,j]*boundary[i,j]+temp[i,j-1]+0.5*temp[i-1,j]+0.5*temp[i+1,j]-(2+Bi[i,j])*temp[i,j]; + end + else + phi[i,j]:=temp[i,j-1]+temp[i-1,j]-4*temp[i,j]+temp[i+1,j]+temp[i,j+1]; + end; + end; + + procedure adapt(i,j : longint); + + begin + if (i=0) and (j=0) then + begin + temp[i,j]:=(Bi[i,j]*boundary[i,j]+0.5*temp[i,j+1]+0.5*temp[i+1,j])/(1+Bi[i,j]); + end + else if (i=0) and (j=h) then + begin + temp[i,j]:=(Bi[i,j]*boundary[i,j]+0.5*temp[i,j-1]+0.5*temp[i+1,j])/(1+Bi[i,j]); + end + else if (i=w) and (j=0) then + begin + temp[i,j]:=(Bi[i,j]*boundary[i,j]+0.5*temp[i,j+1]+0.5*temp[i-1,j])/(1+Bi[i,j]); + end + else if (i=w) and (j=h) then + begin + temp[i,j]:=(Bi[i,j]*boundary[i,j]+0.5*temp[i,j-1]+0.5*temp[i-1,j])/(1+Bi[i,j]); + end + else if i=0 then + begin + temp[i,j]:=(Bi[i,j]*boundary[i,j]+temp[i+1,j]+0.5*temp[i,j-1]+0.5*temp[i,j+1])/(2+Bi[i,j]); + end + else if i=w then + begin + temp[i,j]:=(Bi[i,j]*boundary[i,j]+temp[i-1,j]+0.5*temp[i,j-1]+0.5*temp[i,j+1])/(2+Bi[i,j]); + end + else if j=0 then + begin + temp[i,j]:=(Bi[i,j]*boundary[i,j]+temp[i,j+1]+0.5*temp[i-1,j]+0.5*temp[i+1,j])/(2+Bi[i,j]); + end + else if j=h then + begin + temp[i,j]:=(Bi[i,j]*boundary[i,j]+temp[i,j-1]+0.5*temp[i-1,j]+0.5*temp[i+1,j])/(2+Bi[i,j]); + end + else + temp[i,j]:=(temp[i,j-1]+temp[i-1,j]+temp[i+1,j]+temp[i,j+1])/4; + end; + + var + iter,i,j,mi,mj : longint; + habs,sigma_phi : double; + + begin + clrscr; + iter:=0; + { setup boundary conditions } + for i:=0 to w do + for j:=0 to h do + begin + if (i=0) or (i=w) then + bi[i,j]:=100 + else + bi[i,j]:=100; + + if (j=0) then + boundary[i,j]:=1000 + else + boundary[i,j]:=300; + end; + init; + draw; + repeat + calc_phi; + mi:=0; + mj:=0; + sigma_phi:=0; + inc(iter); + habs:=abs(phi[mi,mj]); + for i:=0 to w do + for j:=0 to h do + begin + if abs(phi[i,j])>habs then + begin + mi:=i; + mj:=j; + habs:=abs(phi[mi,mj]); + end; + { calculate error } + sigma_phi:=sigma_phi+abs(phi[i,j]); + end; + adapt(mi,mj); + gotoxy(1,23); + textcolor(white); + writeln(iter,' iterations, sigma_phi=',sigma_phi); + until {keypressed or }(sigma_phi<0.5); + draw; + gotoxy(1,23); + textcolor(white); + writeln(iter,' iterations, sigma_phi=',sigma_phi); + {writeln('press a key'); + if readkey=#0 then + readkey;} + end. diff --git a/tests/tbs/tb140.pp b/tests/tbs/tb140.pp new file mode 100644 index 0000000000..3fb1df11b7 --- /dev/null +++ b/tests/tbs/tb140.pp @@ -0,0 +1,19 @@ +{ Old file: tbs0160.pp } +{ Incompatibility with BP: Self shouldn't be a reserved word. OK 0.99.9 (PM) } + +program xxxx; + +procedure yyyy; + +var self:word; + +begin +end; + +procedure self; + +begin +end; + +begin +end. diff --git a/tests/tbs/tb141.pp b/tests/tbs/tb141.pp new file mode 100644 index 0000000000..c33c5241ac --- /dev/null +++ b/tests/tbs/tb141.pp @@ -0,0 +1,13 @@ +{ Old file: tbs0162.pp } +{ continue in repeat ... until loop doesn't work correct OK 0.99.8 (PFV) } + +var + i : longint; + +begin + i:=1; + repeat + continue; + until i=1; +end. + diff --git a/tests/tbs/tb142.pp b/tests/tbs/tb142.pp new file mode 100644 index 0000000000..d7af769054 --- /dev/null +++ b/tests/tbs/tb142.pp @@ -0,0 +1,19 @@ +{ Old file: tbs0163.pp } +{ missing <= and >= operators for sets. OK 0.99.11 (JM) } + +Program test; + +{ shows missing <= and >= for sets } + +Type + Days = (Monday,tuesday,wednesday,thursday,friday,saturday,sunday); + +Var + FreeDays,Weekend : set of days; + +begin + Weekend := [saturday, sunday]; + FreeDays := [friday, saturday, sunday]; + If (Weekend <= Freedays) then + Writeln ('Free in weekend !'); +end. diff --git a/tests/tbs/tb143.pp b/tests/tbs/tb143.pp new file mode 100644 index 0000000000..ba566b88ba --- /dev/null +++ b/tests/tbs/tb143.pp @@ -0,0 +1,20 @@ +{ Old file: tbs0164.pp } +{ crash when using undeclared array index in with statement OK 0.99.8 (PFV) } + +type t1r = record + a, b: Byte; + end; + t2r = record + l1, l2: Array[1..4] Of t1r; + end; + + +Var r: t2r; + counter : byte; + +begin + counter:=2; + + with r.l1[counter] Do + Inc(a) +end. diff --git a/tests/tbs/tb144.pp b/tests/tbs/tb144.pp new file mode 100644 index 0000000000..951ad201e7 --- /dev/null +++ b/tests/tbs/tb144.pp @@ -0,0 +1,22 @@ +{ Old file: tbs0165.pp } +{ missing range check code for enumerated types. OK 0.99.9 (PFV) } + +{$R+} +Program bug0165; + +uses + erroru; + +{ No range check when -Cr given} + +Type Directions = (North, East,South,West); + +Var Go : Directions; + + +begin + Require_Error(201); + Go:=North; + Go:=Pred(Go); { must give run-time error } + Go:=Pred(North); { must give compile time error } +end. diff --git a/tests/tbs/tb145.pp b/tests/tbs/tb145.pp new file mode 100644 index 0000000000..5868ec2a6d --- /dev/null +++ b/tests/tbs/tb145.pp @@ -0,0 +1,15 @@ +{ Old file: tbs0169.pp } +{ missing new(type) support for not object/class OK 0.99.9 (PM) } + +type + psearchrec=^longint; + +Var Sr : PSearchrec; + +begin + Sr := New(PSearchRec); + Sr^ := 45; + if Sr^<>45 then + Halt(1); + Dispose(Sr); +end. diff --git a/tests/tbs/tb146.pp b/tests/tbs/tb146.pp new file mode 100644 index 0000000000..cf0cc98b40 --- /dev/null +++ b/tests/tbs/tb146.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0170.pp } +{ Asm, {$ifdef} is seen as a separator OK 0.99.9 (PFV) } + +procedure free1; +begin +end; + +procedure free2; +begin +end; + +begin +asm + call {$ifdef dummy}free1{$else}free2{$endif} +end; +end. diff --git a/tests/tbs/tb147.pp b/tests/tbs/tb147.pp new file mode 100644 index 0000000000..099a7ded30 --- /dev/null +++ b/tests/tbs/tb147.pp @@ -0,0 +1,15 @@ +{ Old file: tbs0171.pp } +{ missing typecasting in constant expression solved for pointers OK 0.99.11 (PM) } + +type + pstring=^string; +const + drivestr:string='c:'; + pdrivestr:pstring=pstring(@drivestr); +begin + if pdrivestr^<>'c:' then + begin + Writeln('Error in typecast of const'); + Halt(1); + end; +end. diff --git a/tests/tbs/tb148.pp b/tests/tbs/tb148.pp new file mode 100644 index 0000000000..17af17afcb --- /dev/null +++ b/tests/tbs/tb148.pp @@ -0,0 +1,22 @@ +{ Old file: tbs0174.pp } +{ Asm, offsets of fields are not possible yet OK 0.99.9 (PFV) } + +{$ASMMODE ATT} + +type + tobj=object + l : longint; + end; +var + t : tobj; + +procedure kl;assembler; +asm + movl tobj.l,%eax // tobj.l should return the offset of l in tobj +end; + + +begin +end. + + diff --git a/tests/tbs/tb149.pp b/tests/tbs/tb149.pp new file mode 100644 index 0000000000..438ff9cc6b --- /dev/null +++ b/tests/tbs/tb149.pp @@ -0,0 +1,13 @@ +{ Old file: tbs0175.pp } +{ Asm, mov word,%eax should not be allowed without casting emits a warning (or error with range checking enabled) OK 0.99.11 (PM) } + +{ this will just give out a warning } +{$asmmode att} +{$R-} +var + w : word; +begin + asm + movl w,%ecx + end; +end. \ No newline at end of file diff --git a/tests/tbs/tb15.pp b/tests/tbs/tb15.pp new file mode 100644 index 0000000000..57e7e28532 --- /dev/null +++ b/tests/tbs/tb15.pp @@ -0,0 +1,41 @@ +{ Old file: tbs0017.pp } +{ } + + +{$ifdef go32v2} + uses dpmiexcp; + +{$endif go32v2} + +const + nextoptpass : longint = 0; + procedure init; + + const + endofparas : boolean = false; + + procedure getparastring; + + procedure nextopt; + + begin + endofparas:=true; + getparastring; + inc(nextoptpass); + init; + end; + + begin + if not endofparas then + nextopt; + end; + + begin + getparastring; + end; + +begin + init; + if nextoptpass<>1 then Halt(1); +end. + diff --git a/tests/tbs/tb150.pp b/tests/tbs/tb150.pp new file mode 100644 index 0000000000..f42f6c5fda --- /dev/null +++ b/tests/tbs/tb150.pp @@ -0,0 +1,21 @@ +{ %OPT= -Un } + +{ Old file: tbs0176.pp } +{ unit.symbol not allowed for implementation vars OK 0.99.9 (PM) } + +{ no unit name checking !! } +unit tb150_wrong; +interface + +var + l1 : longint; + +implementation + +var + l2 : longint; + +begin + tb150_wrong.l1:=1; + tb150_wrong.l2:=1; +end. \ No newline at end of file diff --git a/tests/tbs/tb151.pp b/tests/tbs/tb151.pp new file mode 100644 index 0000000000..19f498b533 --- /dev/null +++ b/tests/tbs/tb151.pp @@ -0,0 +1,9 @@ +{ Old file: tbs0177.pp } +{ program.symbol not allowed (almost the same as bugs 176) OK 0.99.9 (PM) } + +program p; +var + l : longint; +begin + p.l:=1; +end. \ No newline at end of file diff --git a/tests/tbs/tb152.pp b/tests/tbs/tb152.pp new file mode 100644 index 0000000000..a103fec7ac --- /dev/null +++ b/tests/tbs/tb152.pp @@ -0,0 +1,68 @@ +{ %OPT=-Sg } + +{ Old file: tbs0178.pp } +{ problems with undefined labels and fail outside constructor OK 0.99.9 (PM) } + +PROGRAM NoLabel; { this program compiles fine with TP but not with FP } + + type + ptestobj = ^ttestobj; + ttestobj = object + constructor init; + procedure test_self; + end; + + const + allowed : boolean = false; + + constructor ttestobj.init; + begin + if not allowed then + fail; + end; + procedure ttestobj.test_self; + function myself : ptestobj; + begin + myself:=@self; + end; + + begin + if myself<>@self then + begin + Writeln('problem with self'); + Halt(1); + end; + end; + + +LABEL + N1, + N2, + FAIL, { this is a reserved word in constructors only! - FP fails here +} + More; { label not defined - FP fails, but a warning is enough for that +} + { since label referenced nowhere } + var ptest : ptestobj; + self : longint; +BEGIN + new(ptest,init); + if ptest<>nil then + begin + Writeln('Fail does not work !!'); + Halt(1); + end; + allowed:=true; + new(ptest,init); + if ptest=nil then + begin + Writeln('Constructor does not work !!'); + Halt(1); + end + else + ptest^.test_self; + N1: Write; + N2: Write; + FAIL: Write; + self:=1; +END. diff --git a/tests/tbs/tb153.pp b/tests/tbs/tb153.pp new file mode 100644 index 0000000000..f2e92a2775 --- /dev/null +++ b/tests/tbs/tb153.pp @@ -0,0 +1,14 @@ +{ %OPT= -So } + +{ Old file: tbs0179.pp } +{ show a problem for -So mode OK 0.99.9 (PM) } + +UNIT tb153; +INTERFACE + PROCEDURE A(B:WORD); +IMPLEMENTATION + PROCEDURE A; { <-- works with TP, FP says overloading problem } + BEGIN + Write(B); + END; +END. diff --git a/tests/tbs/tb154.pp b/tests/tbs/tb154.pp new file mode 100644 index 0000000000..960e553ba0 --- /dev/null +++ b/tests/tbs/tb154.pp @@ -0,0 +1,19 @@ +{ %OPT=-Un } + +{ Old file: tbs0180.pp } +{ problem for units with names different from file name should be accepted with -Un !! Solved, but you still need to use the file name from other units OK 0.99.9 (PM) } + +{ this name should be accepted with -Un option !! } +UNIT tb154_wrong; +INTERFACE + uses + tb155; + + procedure dummy; +IMPLEMENTATION + procedure dummy; + begin + { Unit_with_strange_name.dummy; should this work ?? } + tb155.dummy; + end; +END. diff --git a/tests/tbs/tb155.pp b/tests/tbs/tb155.pp new file mode 100644 index 0000000000..424d9f327a --- /dev/null +++ b/tests/tbs/tb155.pp @@ -0,0 +1,16 @@ +{ %OPT=-Un } + +{ Old file: tbs0180a.pp } + +{ this name should be accepted with -Un option !! } +UNIT Unit_with_strange_name; +INTERFACE + procedure dummy; +IMPLEMENTATION + procedure dummy; + begin + end; + +begin + Unit_with_strange_name.dummy; +END. diff --git a/tests/tbs/tb156.pp b/tests/tbs/tb156.pp new file mode 100644 index 0000000000..1e8a5795e1 --- /dev/null +++ b/tests/tbs/tb156.pp @@ -0,0 +1,12 @@ +{ Old file: tbs0181.pp } +{ shows a problem with name mangling OK 0.99.9 (PM) } + +{ shows a problem of name mangling } +Program tb156; + + Uses tb157; + + var l : mylongint; +begin + dummy(l); +end. diff --git a/tests/tbs/tb157.pp b/tests/tbs/tb157.pp new file mode 100644 index 0000000000..a0007816db --- /dev/null +++ b/tests/tbs/tb157.pp @@ -0,0 +1,30 @@ +{ Old file: tbs0181a.pp } +{ } + +{ shows a problem of name mangling } +Unit tb157; + +Interface + + type mylongint = longint; + mylongint2 = mylongint; + + procedure dummy(var l : mylongint); + +Implementation + + var l : longint; + + procedure use_before_implemented; + begin + dummy(l); + end; + + procedure dummy(var l : mylongint2); + begin + l:=78; + end; + +begin + use_before_implemented; +end. diff --git a/tests/tbs/tb158.pp b/tests/tbs/tb158.pp new file mode 100644 index 0000000000..7bf7efda13 --- /dev/null +++ b/tests/tbs/tb158.pp @@ -0,0 +1,34 @@ +{ Old file: tbs0182.pp } +{ @record.field doesn't work in constant expr OK 0.99.9 (PM) } + +TYPE Rec = RECORD + x:WORD; + y:WORD; + END; + + Rec1 = Record + x,y : longint; + end; + Rec2 = Record + r,s : Rec1; + z : word; + end; + plongint = ^longint; + +VAR s:WORD; + r:Rec; + rr : Rec2; + +CONST p1:POINTER = @s; { Works fine } + p2:POINTER = @R.y; { illegal expression } + p3:pointer = @rr.s.y; + p4:plongint = @rr.s.y; +BEGIN + rr.s.y:=15; + if plongint(p3)^<>15 then + Begin + Writeln('Error : wrong code generated'); + Halt(1); + End; +END. + diff --git a/tests/tbs/tb159.pp b/tests/tbs/tb159.pp new file mode 100644 index 0000000000..9eec5768e2 --- /dev/null +++ b/tests/tbs/tb159.pp @@ -0,0 +1,30 @@ +{ Old file: tbs0183.pp } +{ internal error 10 in secondnot OK 0.99.11 (PM) } + +program Internal_Error_10; + +type + PBug = ^TBug; + TBug = array[1..1] of boolean; + +var + Left : PBug; + test : longint; + +begin + New(left); + test := 1; + +{ following shows internal error 10 only if the + + array index is a var on both sides + ( if either is a constant then it compiles fine, error only occurs if the + not is in the statement ) + bug only appears if the array is referred to using a pointer - + if using TBug, and no pointers it compiles fine + with PBug the error appears + } + + Left^[test] := not Left^[test]; +end. + diff --git a/tests/tbs/tb16.pp b/tests/tbs/tb16.pp new file mode 100644 index 0000000000..e892e70c1e --- /dev/null +++ b/tests/tbs/tb16.pp @@ -0,0 +1,15 @@ +{ Old file: tbs0018.pp } +{ tests for the possibility to declare all types using pointers "forward" : type p = ^x; x=byte; OK 0.9.3 } + +type + p = ^x; + x = byte; + +var + b : p; + +begin + new(b); + b^:=12; +end. + diff --git a/tests/tbs/tb160.pp b/tests/tbs/tb160.pp new file mode 100644 index 0000000000..c1dac73c7d --- /dev/null +++ b/tests/tbs/tb160.pp @@ -0,0 +1,28 @@ +{ Old file: tbs0184.pp } +{ multiple copies of the same constant set are stored in executable OK 0.99.9 (PFV) } + +Program Bug0184; + +{ multiple copies of the constant sets are stored in the assembler file when + they are needed more than once} + +Var BSet: Set of Byte; + SSet: Set of 0..31; + b,c: byte; + s: 0..31; + +Begin + BSet := BSet + [b]; {creates a big, empty set} + BSet := BSet + [c]; {creates another one} + BSet := BSet + [3]; {creates a big set with element three set} + BSet := BSet + [3]; {and antoher one} + + SSet := SSet + [5]; {creates a small set containing 5} + SSet := SSet + [s]; {creates a small, empty set} + SSet := SSet + [5]; {creates another small set containing 5} + SSet := SSet + [s]; {creates another small, empty set} + +{BTW: small constant sets don't have to be stored seperately in the + executable, as they're simple 32 bit constants, like longints!} + +End. diff --git a/tests/tbs/tb161.pp b/tests/tbs/tb161.pp new file mode 100644 index 0000000000..cdf16a61fe --- /dev/null +++ b/tests/tbs/tb161.pp @@ -0,0 +1,66 @@ +{ Old file: tbs0185.pp } +{ missing range checking for Val and subrange types OK 0.99.11 (JM/PFV) } + +Program bug0185; + +{shows some bugs with rangechecks} +{ readln from input changed to from a file to render it non-interactive } + +var s: String; + i: integer; + code: word; + e: 0..10; + f : text; + should_generate_error : boolean; + oldexit : pointer; + + procedure myexit; + begin + exitproc:=oldexit; + if should_generate_error and (exitcode=201) then + begin + Writeln('Program generates a range check error correctly'); + errorcode:=0; + exitcode:=0; + erroraddr:=nil; + close(f); + erase(f); + end; + end; + +Begin + oldexit:=exitproc; + exitproc:=@myexit; + should_generate_error:=false; +{$R-} + s := '$fffff'; + val(s, i, code); {no range check error may occur here} + Writeln('Integer($fffff) = ',i); + + assign(f,'tbs0185.tmp'); + rewrite(f); + Writeln(f,'20'); + Writeln(f,'34'); + close(f); + reset(f); + Write('Enter the value 20 (should not give a rangecheck error): '); + Readln(f,e); + + +{$R+} + s := '$ffff'; + val(s, i, code); {no range check error may occur here} + Writeln('integer($ffff) = ', i,'(should not give range check error)'); + + Writeln('Enter value from 0-10 to test Val rangecheck, another for subrange rangecheck: '); + should_generate_error:=true; + Readln(f,e); + + Writeln('If you entered a value different from 0-10, subrange range checks don''t work!'); + s := '65535'; + val(s, i, code); {must give a range check error} + Writeln('Val range check failed!'); + close(f); + erase(f); + Halt(1); +End. diff --git a/tests/tbs/tb162.pp b/tests/tbs/tb162.pp new file mode 100644 index 0000000000..f8a11f14e1 --- /dev/null +++ b/tests/tbs/tb162.pp @@ -0,0 +1,116 @@ +{ %OPT=-St -Cr } + +{ Old file: tbs0187.pp } +{ constructor in a WIth statement isn't called correct. (works at lest in the case stated) OK 0.99.11 (PM) } + +{$static on} + +type + Tbaseclass = object + base_arg : longint; + st_count : longint;static; + constructor Init; + destructor Done; + procedure Run; virtual; + + end; + Totherclass = object(Tbaseclass) + other_arg : longint; + procedure Run; virtual; + + end; + +const + BaseRunCount : integer = 0; + OtherRunCount : integer = 0; + +constructor Tbaseclass.Init; + +begin + writeln('Init'); + Inc(st_count); + Run; +end; + +destructor Tbaseclass.Done; + +begin + writeln('Done'); + dec(st_count); +end; + +procedure Tbaseclass.Run; + +begin + writeln('Base method'); + inc(BaseRunCount); +end; + + +procedure Totherclass.Run; + +begin + writeln('Inherited method'); + inc(OtherRunCount); +end; + + { try this as local vars } + + procedure test_local_class_init; + var base1 : TbaseClass; + var other1 : TOtherClass; + begin + with other1 do + Init; + with base1 do + Init; + with other1 do + begin + Writeln('number of objects = ',st_count); + base_arg:=2; + other_arg:=6; + Run; + end; + { test if changed !! } + + if (other1.base_arg<>2) or (other1.other_arg<>6) then + Halt(1); + + with base1 do + begin + Run; + Done; + end; + other1.done; + end; + +var base : Tbaseclass; + other : Totherclass; + testfield : longint; + +begin +// Uncommenting here and commenting the init in the WIth solves it. +// Base.Init; + with base do + begin + Init; + Run; + Done; + end; +// Uncommenting here and commenting the init in the WIth solves it. +// Other.init; + with other do + begin + Init; + Run; + Done; + end; + + test_local_class_init; +{ Calls Tbaseclass.Run when it should call Totherclass.Run } + If (BaseRunCount<>4) or (OtherRunCount<>4) then + Begin + Writeln('Error in tb162'); + Halt(1); + End; +end. diff --git a/tests/tbs/tb163.pp b/tests/tbs/tb163.pp new file mode 100644 index 0000000000..897b3d30e4 --- /dev/null +++ b/tests/tbs/tb163.pp @@ -0,0 +1,45 @@ +{ Old file: tbs0188.pp } +{ can't print function result of procedural var that returns a function. Not a bugs : wrong syntax !! See source (PM) } + +{ this are no bugs, just wrong + understanding of FPC syntax } + +type testfunc = function:longint; + +var f : testfunc; + +var test: testfunc; + +function test_temp: longint; +begin + test_temp:=12; +end; + +procedure sound(test: testfunc); +begin + {writeln(test); this is wrong because + test is the function itself and write does not know how to + output a function ! + to call test you must use test() !! } + writeln(test()); +end; { proc. sound } + +var i : longint; +begin + i:=test_temp; + f:=@test_temp; + if f()<>i then + begin + Writeln('error calling f'); + Halt(1); + end; + + { this works for FPC + sound(test_temp); + but the correct syntax would be } + sound(@test_temp); + { imagine if a function would return its own type !! } + + { for f var this is correct also ! } + sound(f); +end. diff --git a/tests/tbs/tb164.pp b/tests/tbs/tb164.pp new file mode 100644 index 0000000000..5864fe61d0 --- /dev/null +++ b/tests/tbs/tb164.pp @@ -0,0 +1,25 @@ +{ Old file: tbs0189.pp } +{ cant compare adresses of function variables !! As tbs0188 FPC syntax problem see source (PM) } + +var m: procedure; + +procedure test; +begin +end; + +procedure test2; +begin +end; + +begin + if @test <> @test2 then + writeln('different!') + else + writeln('error'); + m:=@test; + + { here also the syntax was wrong !! } + { @m <> @test have different types !! } + if m <> @test then + writeln('error'); +end. diff --git a/tests/tbs/tb165.pp b/tests/tbs/tb165.pp new file mode 100644 index 0000000000..b021cbfa02 --- /dev/null +++ b/tests/tbs/tb165.pp @@ -0,0 +1,13 @@ +{ Old file: tbs0190.pp } +{ can't have typecast for var params ?? OK 0.99.11 (PM) } + +procedure a(var b: boolean); +begin + b:=true; +end; + +var C: byte; + +begin + a(boolean(c)); +end. diff --git a/tests/tbs/tb166.pp b/tests/tbs/tb166.pp new file mode 100644 index 0000000000..0c17f0c862 --- /dev/null +++ b/tests/tbs/tb166.pp @@ -0,0 +1,31 @@ +{ Old file: tbs0191.pp } +{ missing vecn constant evaluation OK 0.99.11 (PM) } + +type + trec=record + a,b : longint; + end; + prec=^trec; + +const + s : string = 'test'; + + cfg : array[1..2] of trec=( + (a:1;b:2), + (a:3;b:4) + ); + pcfg : prec = @cfg[2]; + + l : ^longint = @cfg[1].b; { l^ should be 2 } + + pc : pchar = @s[1]; + +begin + Writeln(' l^ = ',l^); + Writeln('pc[0] = ',pc[0]); + if (l^<>2) or (pc[0]<>'t') then + Begin + Writeln('Wrong code generated'); + RunError(1); + End; +end. diff --git a/tests/tbs/tb167.pp b/tests/tbs/tb167.pp new file mode 100644 index 0000000000..5133cdbed5 --- /dev/null +++ b/tests/tbs/tb167.pp @@ -0,0 +1,11 @@ +{ Old file: tbs0192.pp } +{ can't compare boolean result with true/false, because the boolean result is already in the flags OK 0.99.11 (PFV) } + +var + k,l : word; +begin + if (k<>l)=false then + ; + if (k<>l)=true then + ; +end. \ No newline at end of file diff --git a/tests/tbs/tb168.pp b/tests/tbs/tb168.pp new file mode 100644 index 0000000000..583c60624a --- /dev/null +++ b/tests/tbs/tb168.pp @@ -0,0 +1,18 @@ +{ Old file: tbs0193.pp } +{ overflow checking for 8 and 16 bit operations wrong } + +{$R-} +{$Q+} +var i: integer; + b: byte; + +begin + i := 32767; + i := i + 15; + b := 255; + b := b + 18; + b := 255; + b := b * 8; + b := 255; + b := b * 17 +End. diff --git a/tests/tbs/tb169.pp b/tests/tbs/tb169.pp new file mode 100644 index 0000000000..735a58584a --- /dev/null +++ b/tests/tbs/tb169.pp @@ -0,0 +1,45 @@ +{ Old file: tbs0194.pp } +{ @procedure var returns value in it instead of address !! OK 0.99.11 (PM) } + +{$Q+} + +type + tproc = function : longint; + +var + f : tproc; + fa : array [0..1] of tproc; + + function dummy : longint; + begin + dummy:=25; + end; +const + prog_has_errors : boolean = false; + + procedure Wrong(const s : string); + begin + writeln(s); + prog_has_errors:=True; + end; + +Begin + f:=@dummy; + if f()<>25 then + Wrong('f() does not call dummy !!'); + if pointer(@f)=pointer(@dummy) then + Wrong('@f returns value of f !'); + if longint(f)=longint(@f) then + Wrong('longint(@f)=longint(f) !!!!'); + if f<>@dummy then + Wrong('f does not return the address of dummy'); + if longint(@f)=longint(@dummy) then + Wrong('longint(@f) returns address of dummy instead of address of f'); + fa[0]:=@dummy; + if longint(@f)=longint(@fa[0]) then + Wrong('arrays of procvar also wrong'); + if longint(f)<>longint(fa[0]) then + Wrong('arrays of procvar and procvars are handled differently !!'); + if prog_has_errors then + Halt(1); +End. diff --git a/tests/tbs/tb17.pp b/tests/tbs/tb17.pp new file mode 100644 index 0000000000..10dbbb6731 --- /dev/null +++ b/tests/tbs/tb17.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0019.pp } +{ } + +type + b = ^x; + + x = byte; + +var + pb : b; + +begin + new(pb); + pb^:=10; +end. + diff --git a/tests/tbs/tb170.pp b/tests/tbs/tb170.pp new file mode 100644 index 0000000000..2845d405ef --- /dev/null +++ b/tests/tbs/tb170.pp @@ -0,0 +1,47 @@ +{ Old file: tbs0195.pp } +{ Problem with Getimage, crash of DOS box, even with dpmiexcp!! (PFV) Not a bugs, you must use p^. } + +{$ifdef go32v2} +{$define OK} +{$endif} +{$ifdef linux} +{$define OK} +{$endif} +{$ifdef win32} +{$define OK} +{$endif} + +{$ifdef OK} +uses graph +{$ifdef go32v2} +,dpmiexcp +{$endif go32v2}; +var + GDriver, GMode: Integer; + w:word; + p:pointer; +{$endif OK} +begin +{$ifdef OK} + GDriver := $FF; + GMode := $101; + InitGraph(GDriver, GMode, ''); + if (GraphResult <> grOK) then + Halt(0); + rectangle(0,0,getmaxx,getmaxy); + w := imagesize(0,0,111,111); + getmem(p, w); + + {---runtime-error!------} + { getimage(0,0,111,111, p); } + {-----------------------} + + { This is the correct usage (PFV) } + getimage(0,0,111,111, p^); + + + freemem(p, w); + closegraph; + readln; +{$endif OK} +end. diff --git a/tests/tbs/tb171.pp b/tests/tbs/tb171.pp new file mode 100644 index 0000000000..10bb311310 --- /dev/null +++ b/tests/tbs/tb171.pp @@ -0,0 +1,17 @@ +{ %OPT= -So } + +{ Old file: tbs0196.pp } +{ "function a;" is accepted (should require result type) OK 0.99.1 (PM) } + +Unit tbs0196; +interface + + function a : integer; + +implementation + function a; +begin + a:=1; +end; + +end. diff --git a/tests/tbs/tb172.pp b/tests/tbs/tb172.pp new file mode 100644 index 0000000000..2b41614663 --- /dev/null +++ b/tests/tbs/tb172.pp @@ -0,0 +1,17 @@ +{ Old file: tbs0198.pp } +{ calling specifications aren't allowed in class declarations, this should be allowed OK 0.99.11 (PM) } + +{$mode objfpc} +type + to1 = class + function GetCaps1 : Longint;virtual;abstract; + function GetCaps2 : Longint;virtual;stdcall; + function GetCaps : Longint;virtual;stdcall;abstract; + end; + +function to1.GetCaps2 : Longint;stdcall; +begin +end; + +begin +end. diff --git a/tests/tbs/tb173.pp b/tests/tbs/tb173.pp new file mode 100644 index 0000000000..7b33ccc2b2 --- /dev/null +++ b/tests/tbs/tb173.pp @@ -0,0 +1,27 @@ +{ Old file: tbs0199.pp } +{ bugs in mul code OK 0.99.11 (FK) } + +PROGRAM PRTest; + +TYPE + ptRec = ^tRec; + tRec = Record + D : DWORD; + END; + +VAR + pR1, pR2 : ptRec; +BEGIN + GetMem(pR1, SizeOf(tRec)); + GetMem(pR2, SizeOf(tRec)); + + pR1^.D := 10; + Move(pR1^,pR2^,SizeOf(tRec)); + WriteLn(pR1^.D:16,pR2^.D:16); + + pR1^.D := 1; + pR2^.D := pR1^.D*2; { THE BUG IS HERE } + WriteLn(pR1^.D:16,pR2^.D:16); + if (pR1^.D<>1) or (pR2^.D<>2) then + Halt(1); +END. diff --git a/tests/tbs/tb174.pp b/tests/tbs/tb174.pp new file mode 100644 index 0000000000..8a57c5e325 --- /dev/null +++ b/tests/tbs/tb174.pp @@ -0,0 +1,44 @@ +{ %OPT= -Ratt } + +{ Old file: tbs0201.pp } +{ problem with record var-parameters and assembler OK 0.99.11 (PFV) } + +program bug0201; + +type rec = record + a : DWord; + b : Word; + end; + +{ this is really for tests but + this should be coded with const r1 and r2 !! } + +function x(r1 : rec; r2 : rec; var r3 : rec) : integer; assembler; +asm + movl r3, %edi + movl r1, %ebx + movl r2, %ecx + movl rec.a(%ebx), %eax + addl rec.a(%ecx), %eax + movl %eax, rec.a(%edi) + + movw rec.b(%ebx), %ax + addw rec.b(%ecx), %ax + movw %ax, rec.b(%edi) + movw $1,%ax +end; + +var r1, r2, r3 : rec; + +begin + r1.a := 100; r1.b := 200; + r2.a := 300; r2.b := 400; + x(r1, r2, r3); + Writeln(r3.a, ' ', r3.b); + if (r3.a<>400) or (r3.b<>600) then + begin + Writeln('Error in assembler code'); + Halt(1); + end; +end. + diff --git a/tests/tbs/tb175.pp b/tests/tbs/tb175.pp new file mode 100644 index 0000000000..539bb96dd7 --- /dev/null +++ b/tests/tbs/tb175.pp @@ -0,0 +1,34 @@ +{ Old file: tbs0202.pp } +{ flag results not supported with case OK 0.99.11 (PFV) } + +program silly; + +var greater : boolean; + +procedure error; +begin + Writeln('Error in tbs0202'); + Halt(1); +end; + +procedure compare(i,j : integer); +begin + case (i>j) of + true : begin + greater:=true; + end; + false : begin + greater:=false; + end; + end; +end; + +begin + compare(45,2); + if not greater then + error; + compare(-5,26); + if greater then + error; +end. + diff --git a/tests/tbs/tb176.pp b/tests/tbs/tb176.pp new file mode 100644 index 0000000000..f1fafdd9d6 --- /dev/null +++ b/tests/tbs/tb176.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0203.pp } +{ problem with changed mangledname of procedures after use } + +program tbs0203; + +uses +{$ifdef go32v2} + dpmiexcp, +{$endif def go32v2} + tbs0203a; + +begin + c; + a; +end. + diff --git a/tests/tbs/tb177.pp b/tests/tbs/tb177.pp new file mode 100644 index 0000000000..98ec0ef00c --- /dev/null +++ b/tests/tbs/tb177.pp @@ -0,0 +1,28 @@ +{ Old file: tbs0203a.pp } +{ } + +unit tbs0203a; + +interface + procedure a; + procedure c; + + const is_called : boolean = false; + +implementation + + procedure c; + begin + a; + end; + + procedure b;[public, alias : '_assembler_a']; + begin + Writeln('b called'); + Is_called:=true; + end; + + procedure a;external name '_assembler_a'; + +end. + diff --git a/tests/tbs/tb178.pp b/tests/tbs/tb178.pp new file mode 100644 index 0000000000..a0e15d4e64 --- /dev/null +++ b/tests/tbs/tb178.pp @@ -0,0 +1,33 @@ +{ Old file: tbs0204.pp } +{ can typecast the result var in an assignment OK 0.99.11 (PM) } + +{ boolean(byte) byte(boolean) + word(wordbool) wordbool(word) + longint(longbool) and longbool(longint) + must be accepted as var parameters + or a left of an assignment } + +procedure error; +begin + Writeln('Error in tbs0204'); + Halt(1); +end; + +var + b : boolean; + wb : wordbool; + lb : longbool; + +begin + byte(b):=1; + word(wb):=1; + longint(lb):=1; + if (not b) or (not wb) or (not lb) then + error; + byte(b):=2; + Writeln('if a boolean contains 2 it is considered as ',b); + byte(b):=3; + Writeln('if a boolean contains 3 it is considered as ',b); + shortint(b):=-1; + Writeln('if a boolean contains shortint(-1) it is considered as ',b); +end. \ No newline at end of file diff --git a/tests/tbs/tb179.pp b/tests/tbs/tb179.pp new file mode 100644 index 0000000000..f6f063a215 --- /dev/null +++ b/tests/tbs/tb179.pp @@ -0,0 +1,13 @@ +{ Old file: tbs0206.pp } +{ sets with variable ranges doesn't work OK 0.99.11 (PFV) } + +PROGRAM SetRange_Bug; +CONST a:char='A';z:char='Z'; +VAR s:set of char;c:char; +BEGIN + s:=[a..z]; + for c:=#0 to #255 do + if c in s then + write(c); + writeln; +END. \ No newline at end of file diff --git a/tests/tbs/tb18.pp b/tests/tbs/tb18.pp new file mode 100644 index 0000000000..6c5011e5f5 --- /dev/null +++ b/tests/tbs/tb18.pp @@ -0,0 +1,42 @@ +{ Old file: tbs0021.pp } +{ tests compatibility of empty sets with other set and the evalution of constant sets OK 0.9.3 } + +{ tests constant set evalution } + +var + a : set of byte; + +const + b : set of byte = [0..255]+[9]; + +type + tcommandset = set of byte; + +const +cmZoom = 10; +cmClose = 5; +cmResize = 8; +cmNext = 12; +cmPrev = 15; + +CONST + CurCommandSet : TCommandSet = ([0..255] - + [cmZoom, cmClose, cmResize, cmNext, cmPrev]); + commands : tcommandset = []; + +var + CommandSetChanged : boolean; + +PROCEDURE DisableCommands (Commands: TCommandSet); + + BEGIN + {$IFNDEF PPC_FPK} { FPK bug } + CommandSetChanged := CommandSetChanged OR + (CurCommandSet * Commands <> []); { Set changed flag } + {$ENDIF} + CurCommandSet := CurCommandSet - Commands; { Update command set } + END; + +begin + a:=[byte(1)]+[byte(2)]; +end. \ No newline at end of file diff --git a/tests/tbs/tb180.pp b/tests/tbs/tb180.pp new file mode 100644 index 0000000000..ea3d11a897 --- /dev/null +++ b/tests/tbs/tb180.pp @@ -0,0 +1,11 @@ +{ Old file: tbs0207.pp } +{ a class destructor doesn't release the memory OK 0.99.11 (FK) } + + +{$mode delphi} + var i : longint; + +begin + for i:=1 to 100 do + tobject.create.free; +end. diff --git a/tests/tbs/tb181.pp b/tests/tbs/tb181.pp new file mode 100644 index 0000000000..3629359bce --- /dev/null +++ b/tests/tbs/tb181.pp @@ -0,0 +1,21 @@ +{ Old file: tbs0209.pp } +{ problem with boolean expressions of different store sizes } + +program bug0209; + +{ problem with boolean expression mixing different boolean sizes } + +var + b : boolean; + wb : wordbool; + lb : longbool; +begin + b:=true; + wb:=true; + lb:=true; + if (not b) or (not wb) or (not lb) then + begin + Writeln('Error with boolean expressions of different sizes'); + Halt(1); + end; +end. \ No newline at end of file diff --git a/tests/tbs/tb182.pp b/tests/tbs/tb182.pp new file mode 100644 index 0000000000..81dd8f7049 --- /dev/null +++ b/tests/tbs/tb182.pp @@ -0,0 +1,13 @@ +{ Old file: tbs0210.pp } +{ fillchar should accept boolean value also !! OK 0.99.11 (PM) } + +{ boolean args are accepted for fillchar in BP } + +program test; + + var l : array[1..10] of boolean; + +begin + fillchar(l,sizeof(l),true); +end. + diff --git a/tests/tbs/tb183.pp b/tests/tbs/tb183.pp new file mode 100644 index 0000000000..d90496e45e --- /dev/null +++ b/tests/tbs/tb183.pp @@ -0,0 +1,32 @@ +{ Old file: tbs0211.pp } +{ a and not a is true !!! (if a:=boolean(5)) OK 0.99.11 (PM) } + +var + a,b : boolean; + c : byte; + i : longint; + +procedure Error; +begin + Writeln('Error in bug0211'); + Halt(1); +end; + +begin + c:=5; + a:=boolean(c); + if a and not a then + Begin + Writeln('FPC is crazy !!'); + Error; + End; + i:=256; + a:=boolean(i); + { the value here is less trivial } + { BP returns false here !! } + { the problem is the converting wordbool to boolean } + { if wordbool is 256 should not convert true to false !! } + + Writeln('boolean(256) =',a); +end. + diff --git a/tests/tbs/tb184.pp b/tests/tbs/tb184.pp new file mode 100644 index 0000000000..324d23797d --- /dev/null +++ b/tests/tbs/tb184.pp @@ -0,0 +1,23 @@ +{ Old file: tbs0212.pp } +{ problem with properties OK 0.99.11 (PFV) } + +program proptest; + +{$mode objfpc} + +type + TMyRec = record + Int: Integer; + Str: String; + end; + + TMyClass = class + private + FMyRec: TMyRec; + public + property AnInt: Integer read FMyRec.Int; + property AStr: String read FMyRec.Str; + end; + +begin +end. \ No newline at end of file diff --git a/tests/tbs/tb185.pp b/tests/tbs/tb185.pp new file mode 100644 index 0000000000..9b918a9793 --- /dev/null +++ b/tests/tbs/tb185.pp @@ -0,0 +1,38 @@ +{ Old file: tbs0213.pp } +{ name mangling problem with nested procedures in overloaded } + +uses + tbs0213a; + +PROCEDURE Testsomething(VAR A:LONGINT); + +FUNCTION Internaltest(L:LONGINT):LONGINT; + +BEGIN + InternalTest:=L+10; +END; + +BEGIN + A:=Internaltest(20)+5; +END; + +PROCEDURE Testsomething(VAR A:WORD); + +FUNCTION Internaltest(L:LONGINT):WORD; + +BEGIN + InternalTest:=L+15; +END; + +BEGIN + A:=Internaltest(20)+5; +END; + +VAR O : LONGINT; + O2 : WORD; + +BEGIN + TestSomething(O); + TestSomething(O2); +END. + diff --git a/tests/tbs/tb186.pp b/tests/tbs/tb186.pp new file mode 100644 index 0000000000..b93fbc62c3 --- /dev/null +++ b/tests/tbs/tb186.pp @@ -0,0 +1,99 @@ +{ Old file: tbs0213a.pp } +{ } + +{ different tests for the problem of local + functions having the same name } + +unit tbs0213a; + +interface + +PROCEDURE Testsomething(VAR A:LONGINT); + +PROCEDURE Testsomething(VAR A:WORD); + +implementation + + +PROCEDURE Testsomething(VAR A:LONGINT); + +FUNCTION Internaltest(L:LONGINT):LONGINT; + +BEGIN + InternalTest:=L+10; +END; + +BEGIN + A:=Internaltest(20)+5; +END; + +PROCEDURE Testsomething(VAR A:WORD); + +FUNCTION Internaltest(L:LONGINT):WORD; + +BEGIN + InternalTest:=L+15; +END; + +BEGIN + A:=Internaltest(20)+5; +END; + +PROCEDURE Testsomething2(VAR A:LONGINT); + +FUNCTION Internaltest(L:LONGINT):LONGINT; + +BEGIN + InternalTest:=L+10; +END; + +BEGIN + A:=Internaltest(20)+5; +END; + +PROCEDURE Testsomething2(VAR A:WORD); + +FUNCTION Internaltest(L:LONGINT):WORD; + +BEGIN + InternalTest:=L+15; +END; + +BEGIN + A:=Internaltest(20)+5; +END; + +PROCEDURE Testsomething3(VAR A:WORD);forward; + +PROCEDURE Testsomething3(VAR A:LONGINT); + +FUNCTION Internaltest(L:LONGINT):LONGINT; + +BEGIN + InternalTest:=L+10; +END; + +BEGIN + A:=Internaltest(20)+5; +END; + +PROCEDURE Testsomething3(VAR A:WORD); + +FUNCTION Internaltest(L:LONGINT):WORD; + +BEGIN + InternalTest:=L+15; +END; + +BEGIN + A:=Internaltest(20)+5; +END; + +VAR O : LONGINT; + O2 : WORD; + +BEGIN + TestSomething(O); + TestSomething(O2); +END. + diff --git a/tests/tbs/tb187.pp b/tests/tbs/tb187.pp new file mode 100644 index 0000000000..561d9da526 --- /dev/null +++ b/tests/tbs/tb187.pp @@ -0,0 +1,32 @@ +{ %OPT=-St } + +{ Old file: tbs0214.pp } +{ bugs for static methods OK 0.99.11 (PM) } + +Program SttcTest; +{ Note: I've cut a lot out of this program, it did originally have + constructors, destructors and instanced objects, but this + is the minimum required to produce the problem, and I think + that this should work, unless I've misunderstood the use of + the static keyword. } +Type + TObjectType1 = Object + Procedure Setup; static; + Procedure Weird; static; + End; + +Procedure TObjectType1.Setup; + Begin + End; + +Procedure TObjectType1.Weird; + Begin + End; + +Begin + TObjectType1.Setup; + TObjectType1.Weird; + TObjectType1.Weird; // GPFs before exiting "Weird" + Writeln('THE END.'); +End. + diff --git a/tests/tbs/tb188.pp b/tests/tbs/tb188.pp new file mode 100644 index 0000000000..ded5feb688 --- /dev/null +++ b/tests/tbs/tb188.pp @@ -0,0 +1,56 @@ +{ %OPT=-St } + +{ Old file: tbs0215.pp } +{ more bugss with static methods OK 0.99.11 (PM) } + +{ allow static keyword } +{ submitted by Andrew Wilson } + +Program X; + +{$ifdef go32v2} + uses dpmiexcp; +{$endif go32v2} + +Type + PY=^Y; + Y=Object + A : LongInt; + P : PY; static; + Constructor Init(NewA:LongInt); + Procedure StaticMethod; static; + Procedure VirtualMethod; virtual; + End; + +Constructor Y.Init(NewA:LongInt); + Begin + A:=NewA; + P:=@self; + End; + +Procedure Y.StaticMethod; + Begin + Writeln(P^.A); // Compiler complains about using A. + P^.VirtualMethod; // Same with the virtual method. + With P^ do begin + Writeln(A); // These two seem to compile, but I + VirtualMethod; // can't get them to work. It seems to + End; // be the same problem as last time, so + End; // I'll check it again when I get the + // new snapshot. +Procedure Y.VirtualMethod; + Begin + Writeln('VirtualMethod ',A); + End; + +var T1,T2 : PY; + +Begin + New(T1,init(1)); + New(T2,init(2)); + T1^.VirtualMethod; + T2^.VirtualMethod; + Y.StaticMethod; + T1^.StaticMethod; + T2^.StaticMethod; +End. diff --git a/tests/tbs/tb189.pp b/tests/tbs/tb189.pp new file mode 100644 index 0000000000..ca945ad4b0 --- /dev/null +++ b/tests/tbs/tb189.pp @@ -0,0 +1,37 @@ +{ Old file: tbs0216.pp } +{ problem with with fields as function args OK 0.99.11 (PM) } + +type rec = record + a : Longint; + b : Longint; + c : Longint; + d : record + e : Longint; + f : Word; + end; + g : Longint; + end; + +const r : rec = ( + a : 100; b : 200; c : 300; d : (e : 20; f : 30); g : 10); + + +begin + with r do begin + Writeln('A : ', a); + if a<>100 then halt(1); + Writeln('B : ', b); + if b<>200 then halt(1); + Writeln('C : ', c); + if c<>300 then halt(1); + Writeln('D'); + with d do begin + Writeln('E : ', e); + if e<>20 then halt(1); + Writeln('F : ', f); + if f<>30 then halt(1); + end; + Writeln('G : ', g); + if g<>10 then halt(1); + end; +end. diff --git a/tests/tbs/tb19.pp b/tests/tbs/tb19.pp new file mode 100644 index 0000000000..cdc4737af1 --- /dev/null +++ b/tests/tbs/tb19.pp @@ -0,0 +1,32 @@ +{ Old file: tbs0022.pp } +{ tests getting the address of a method OK 0.9.3 } + +type + tobject = object + procedure x; + constructor c; + end; + +procedure a; + + begin + end; + +procedure tobject.x; + + begin + end; + +constructor tobject.c; + + begin + end; + +var + p : pointer; + +begin + p:=@a; + p:=@tobject.x; + p:=@tobject.c; +end. diff --git a/tests/tbs/tb190.pp b/tests/tbs/tb190.pp new file mode 100644 index 0000000000..1bdee473be --- /dev/null +++ b/tests/tbs/tb190.pp @@ -0,0 +1,22 @@ +{ Old file: tbs0217.pp } +{ in tp mode can't use the procvar in writeln OK 0.99.11 (PFV) } + +{$ifdef fpc}{$mode tp}{$endif} + +type tmpproc=function:longint; + +function a:longint;{$ifndef fpc}far;{$endif} +begin + a:=-1; +end; + +procedure tmp(aa: tmpproc); +begin + writeln(aa); { "Cannot read/write variables of this type", TP kan dit +wel? } + if aa<>-1 then halt(1); +end; + +begin + tmp(a); { de TP manier , in FPC moet dit zijn tmp(@a); } +end. diff --git a/tests/tbs/tb191.pp b/tests/tbs/tb191.pp new file mode 100644 index 0000000000..c29161b042 --- /dev/null +++ b/tests/tbs/tb191.pp @@ -0,0 +1,47 @@ +{ Old file: tbs0218.pp } +{ rounding errors with write/str (the bugs is fixed, OK 0.99.11 (FK) } + +Program Wrong_Output; +{} +Var r,rr,error:Extended; + s:String; + code : word; +{} +Begin + Writeln('Size of Extended type (r)=',SizeOf(r),' bytes'); + r:=0.000058184639; + Writeln('r=',r); + Writeln('r=',r:16:13); + Writeln('r=',r:15:12); + Writeln('r=',r:14:11); + Writeln('r=',r:13:10); + Writeln('r=',r:12:9); + Writeln('r=',r:11:8); + Writeln('r=',r:10:7); + Writeln('r=',r:9:6); + Writeln('r=',r:8:5); + Writeln('r=',r:7:4); + Str(r,s); + Writeln('r=',s,' (as string)'); + str(r,s); + val(s,rr,code); + { calculate maximum possible precision } + if sizeof(extended) = 10 then + error := exp(17*ln(10)) + else if sizeof(extended) = 8 then + error := exp(14*ln(10)) + else if sizeof(extended) = 4 then + { the net may have to be 9 instead of 8, not sure } + error := exp(8*ln(10)) + else + begin + Writeln('unknown extended type size!'); + halt(1) + end; + if abs(r-rr) > error then + begin + Writeln('r=',r); + Writeln('is different from rr=',rr); + halt(1); + end; +End. \ No newline at end of file diff --git a/tests/tbs/tb192.pp b/tests/tbs/tb192.pp new file mode 100644 index 0000000000..09443a738f --- /dev/null +++ b/tests/tbs/tb192.pp @@ -0,0 +1,18 @@ +{ Old file: tbs0220.pp } +{ array of char overloading problem with strings OK 0.99.11 (PFV) } + +type + a = array[1..100] of char; + +var + a1 : a; + s : string; +begin + a1[1]:='1';a1[2]:='2';a1[3]:='3'; + a1[4]:='4';a1[5]:='5';a1[6]:='6'; + a1[7]:='7';a1[8]:='8';a1[9]:='9'; + a1[10]:='0';a1[11]:='1'; + s:=Copy(a1,1,10); + if s<>'1234567890' then halt(1); + writeln('ok'); +end. diff --git a/tests/tbs/tb193.pp b/tests/tbs/tb193.pp new file mode 100644 index 0000000000..a1552baec4 --- /dev/null +++ b/tests/tbs/tb193.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0221.pp } +{ syntax parsing incompatibilities with tp7 OK 0.99.11 (PFV) } + + +var + r : double; + c : char; +begin + r:=1.; + c:=^.; { this compile in tp7, c should contain 'n'/#110 } + if c<>#110 then + begin + Writeln('FPC does not support ^. character!'); + Halt(1); + end; +end. diff --git a/tests/tbs/tb194.pp b/tests/tbs/tb194.pp new file mode 100644 index 0000000000..0fa6ea5421 --- /dev/null +++ b/tests/tbs/tb194.pp @@ -0,0 +1,14 @@ +{ Old file: tbs0222.pp } +{ an record field can't be the counter index (compiles with TP) OK 0.99.11 (PFV) } + + +type TStruct = record + x,y: Integer; + end; + +var i: TStruct; + +begin + for i.x:=1 to 10 do + writeln(i.x); +end. diff --git a/tests/tbs/tb195.pp b/tests/tbs/tb195.pp new file mode 100644 index 0000000000..cbf2a67c43 --- /dev/null +++ b/tests/tbs/tb195.pp @@ -0,0 +1,23 @@ +{ Old file: tbs0223.pp } +{ wrong boolean evaluation in writeln OK 0.99.11 (PFV) } + + +uses + erroru; + +var a:string; + +begin + writeln('B:'='B:'); { debbuger evaluates this to FALSE } + if 'B:'='B:' then + writeln('OK') + else + error; + a:='A:'; + inc(a[1]); + writeln(a='B:'); { TRUE } + if a='B:' then + writeln('OK') + else + error; +end. diff --git a/tests/tbs/tb196.pp b/tests/tbs/tb196.pp new file mode 100644 index 0000000000..b1ff90ae01 --- /dev/null +++ b/tests/tbs/tb196.pp @@ -0,0 +1,22 @@ +{ Old file: tbs0224.pp } +{ I/O-Error generation in readln can't be switched off OK 0.99.11 (PFV) } + + +var f:text; + i:integer; +begin + assign(f,'bug0224.txt'); + rewrite(f); + write(f,' '); + reset(f); +{$I-} + readln(f,i); { you can't avoid run-time error generation } +{$I+} + if IOResult<>0 then + writeln('error...'); +{$I-} + close(f); + erase(f); +{$I+} + if IOResult<>0 then; +end. diff --git a/tests/tbs/tb197.pp b/tests/tbs/tb197.pp new file mode 100644 index 0000000000..d9aadcb3d1 --- /dev/null +++ b/tests/tbs/tb197.pp @@ -0,0 +1,33 @@ +{ Old file: tbs0225.pp } +{ Sigsegv when run with range checks on open arrays OK 0.99.11 (PFV) } + + program bug0255; + +{$mode objfpc} + +{$R+} + + function erwwert(const feld: array of LongInt):extended; + var i: LongInt; + begin + Result:=0; + for i:=low(feld) to high(feld) + do begin + writeln(i); // gives "0" + Result:=Result+feld[i]; + end; //^^^^^^^ there occurs the segfault (216) + // on the first loop + Result:=Result/(high(feld)-low(feld)+1); + end; + + var werte: array[0..299] of LongInt; + i: LongInt; + + begin + //init the array + for i:=0 to 299 + do werte[i]:=Random(5)-2; + + //and do something with it + writeln(erwwert(werte):6:5); + end. diff --git a/tests/tbs/tb198.pp b/tests/tbs/tb198.pp new file mode 100644 index 0000000000..fe4607e52a --- /dev/null +++ b/tests/tbs/tb198.pp @@ -0,0 +1,12 @@ +{ Old file: tbs0226.pp } +{ Asm, offset of var is not allowed as constant OK 0.99.11 (PFV) } + +{$ifdef fpc}{$asmmode intel}{$endif} +var + test : longint; +begin + exit; { don't run this code below !! } + asm + dd test + end; +end. diff --git a/tests/tbs/tb199.pp b/tests/tbs/tb199.pp new file mode 100644 index 0000000000..a10d6ca0c7 --- /dev/null +++ b/tests/tbs/tb199.pp @@ -0,0 +1,15 @@ +{ Old file: tbs0227.pp } +{ external var does strange things when declared in localsymtable OK 0.99.11 (PFV) } + +function getheapsize:longint;assembler; +var + heapsize : longint;external name 'HEAPSIZE'; + sbrk : longint;external name '___sbrk'; +asm + movl HEAPSIZE,%eax +end ['EAX']; + +begin + writeln(getheapsize); +end. + diff --git a/tests/tbs/tb2.pp b/tests/tbs/tb2.pp new file mode 100644 index 0000000000..dc21bbb6f6 --- /dev/null +++ b/tests/tbs/tb2.pp @@ -0,0 +1,86 @@ +{ Old file: tbs0002.pp } +{ tests for the endless bugs in the optimizer OK 0.9.2 } + +unit tb2; + + interface + + implementation + +{$message starting hexstr} + function hexstr(val : longint;cnt : byte) : string; + + const + hexval : string[16]=('0123456789ABCDEF'); + + var + s : string; + l2,i : integer; + l1 : longInt; + + begin + s[0]:=char(cnt); + l1:=longint($f) shl (4*(cnt-1)); + for i:=1 to cnt do + begin + l2:=(val and l1) shr (4*(cnt-i)); + l1:=l1 shr 4; + s[i]:=hexval[l2+1]; + end; + hexstr:=s; + end; + +{$message starting dump_stack} + + procedure dump_stack(bp : longint); + +{$message starting get_next_frame} + + function get_next_frame(bp : longint) : longint; + + begin + asm + movl bp,%eax + movl (%eax),%eax + movl %eax,__RESULT + end ['EAX']; + end; + + procedure dump_frame(addr : longint); + + begin + { to be used by symify } + writeln(' 0x',HexStr(addr,8)); + end; + +{$message starting get_addr} + + function get_addr(BP : longint) : longint; + + begin + asm + movl BP,%eax + movl 4(%eax),%eax + movl %eax,__RESULT + end ['EAX']; + end; + +{$message starting main} + + var + i,prevbp : longint; + + begin + prevbp:=bp-1; + i:=0; + while bp > prevbp do + begin + dump_frame(get_addr(bp)); + i:=i+1; + if i>max_frame_dump then exit; + prevbp:=bp; + bp:=get_next_frame(bp); + end; + end; + +end. diff --git a/tests/tbs/tb20.pp b/tests/tbs/tb20.pp new file mode 100644 index 0000000000..cffbda50e2 --- /dev/null +++ b/tests/tbs/tb20.pp @@ -0,0 +1,50 @@ +{ Old file: tbs0023.pp } +{ tests handling of self pointer in nested methods OK 0.9.3 } + +type + tobject = object + a : longint; + procedure t1; + procedure t2;virtual; + constructor init; + end; + +procedure tobject.t1; + + procedure nested1; + + begin + writeln; + a:=1; + end; + + begin + end; + +procedure tobject.t2; + + procedure nested1; + + begin + writeln; + a:=1; + end; + + begin + end; + +constructor tobject.init; + + procedure nested1; + + begin + writeln; + a:=1; + end; + + begin + end; + + +begin +end. \ No newline at end of file diff --git a/tests/tbs/tb200.pp b/tests/tbs/tb200.pp new file mode 100644 index 0000000000..506a410529 --- /dev/null +++ b/tests/tbs/tb200.pp @@ -0,0 +1,18 @@ +{ Old file: tbs0228.pp } +{ Asm, wrong warning for size OK 0.99.11 (PFV) } + +PROGRAM Buggy; + +{$ASMMODE ATT} + +PROCEDURE XX; ASSEMBLER; +TYPE + TabType=ARRAY[0..3] OF BYTE; +CONST + TabCent : TabType = (0,6,4,2); +ASM + movzbl TabCent(,%eax),%ebx +END; + +BEGIN +END. diff --git a/tests/tbs/tb201.pp b/tests/tbs/tb201.pp new file mode 100644 index 0000000000..0956e7443b --- /dev/null +++ b/tests/tbs/tb201.pp @@ -0,0 +1,37 @@ +{ Old file: tbs0229.pp } +{ consts > 255 are truncated (should work in -S2,-Sd) OK 0.99.11 (PFV) } + +{$mode objfpc} +{$X-} + +const + CRLF = #13#10; + c = + '1-----------------'+CRLF+ + '2/PcbDict 200 dict'+CRLF+ + '3PcbDicljkljkljk b'+CRLF+ + '4PcbDict /DictMaix'+CRLF+ + '5% draw a pin-poll'+CRLF+ + '6% get x+CRLF+ y s'+CRLF+ + '7/thickness exch h'+CRLF+ + '8gsave x y transls'+CRLF+ + '9---------jljkljkl'+crlf+ + '10----------2jkljk'+crlf+ + '11----------jkllkk'+crlf+ + 'eeeeeeeeeeeeeeeeee'+crlf+ + '2-----------------'+CRLF+ + '2/PcbDict 200 dice'+CRLF+ + 'END____.XXXXXxjk b'+CRLF+ + '4PcbDict /DictMaix'+CRLF+ + '5% draw a pin-poll'+CRLF+ + '6% get x+CRLF+ y s'+CRLF+ + '7/thickness exch h'+CRLF+ + '8gsave x y transls'+CRLF+ + '9---------jljkljkl'+crlf+ + '10----------2jkljk'+crlf+ + '11----------jkllkk'+crlf+ + 'eeeeeeeeeeeeeeeeee12'; + +begin + write(c); +end. diff --git a/tests/tbs/tb202.pp b/tests/tbs/tb202.pp new file mode 100644 index 0000000000..2517d76cfa --- /dev/null +++ b/tests/tbs/tb202.pp @@ -0,0 +1,11 @@ +{ Old file: tbs0232.pp } +{ const. procedure variables need a special syntax if they use calling specification modifiers } + +const + p1 : procedure;stdcall=nil; { <----- this doesn't what you expect !!!!} + p2 : procedure stdcall=nil; { so delphi supports also this way of } + { declaration } + +begin +end. + diff --git a/tests/tbs/tb203.pp b/tests/tbs/tb203.pp new file mode 100644 index 0000000000..bb80d7de98 --- /dev/null +++ b/tests/tbs/tb203.pp @@ -0,0 +1,34 @@ +{ Old file: tbs0233.pp } +{ Problem with enum sets in args OK 0.99.11 (PFV) } + +program except_test; + +type byteset = set of byte; + enumset = set of (zero,one,two,three); + +function test(s : byteset) : boolean; +begin + test:=false; + if 0 in s then + begin + Writeln('Contains zero !'); + test:=true; + end; +end; + +function testenum(s : enumset) : boolean; +begin + testenum:=false; + + if zero in s then + begin + Writeln('Contains zero !'); + testenum:=true; + end; +end; + +begin + if test([1..5,8]) then halt(1); + if not test([0,8,15]) then halt(1); + if not testenum([zero,two]) then halt(1); +end. diff --git a/tests/tbs/tb204.pp b/tests/tbs/tb204.pp new file mode 100644 index 0000000000..79ad1d855a --- /dev/null +++ b/tests/tbs/tb204.pp @@ -0,0 +1,13 @@ +{ Old file: tbs0234.pp } +{ New with void pointer OK 0.99.11 (PM) } + +program bug0232; + +{$mode tp} + +var p:pointer; + +begin + new(p); + dispose(p); +end. diff --git a/tests/tbs/tb205.pp b/tests/tbs/tb205.pp new file mode 100644 index 0000000000..bf7e7e32c9 --- /dev/null +++ b/tests/tbs/tb205.pp @@ -0,0 +1,20 @@ +{ Old file: tbs0235.pp } +{ Val(cardinal) bugs OK 0.99.11 (JM) } + +program bug0233; + +var s:string; + w:cardinal; + code:word; + +begin + s:='192'; + val(s,w,code); + if code<>0 then + begin + writeln('Error'); + halt(1); + end + else + writeln(w); +end. diff --git a/tests/tbs/tb206.pp b/tests/tbs/tb206.pp new file mode 100644 index 0000000000..52f17d05bb --- /dev/null +++ b/tests/tbs/tb206.pp @@ -0,0 +1,43 @@ +{ Old file: tbs0236.pp } +{ Problem with range check of subsets !! compile with -Cr OK 0.99.11 (PFV) } + +{$R+} +program test_set_subrange; + +uses + erroru; + + type + enum = (zero,one,two,three); + + sub_enum = one..three; + prec = ^trec; + + trec = record + dummy : longint; + en : enum; + next : prec; + end; + + const + str : array[sub_enum] of string = ('one','two','three'); + +procedure test; + + var hp : prec; + t : sub_enum; + + begin + new(hp); + hp^.en:=zero; + new(hp^.next); + hp^.next^.en:=three; + t:=hp^.en; + Writeln('hp^.en = ',str[hp^.en]); + Writeln('hp^.next^.en = ',str[hp^.next^.en]); + end; + +begin + require_error(201); + test; +end. diff --git a/tests/tbs/tb207.pp b/tests/tbs/tb207.pp new file mode 100644 index 0000000000..ca124b7a7d --- /dev/null +++ b/tests/tbs/tb207.pp @@ -0,0 +1,25 @@ +{ Old file: tbs0237.pp } +{ Can't have sub procedures with names defined in interface OK 0.99.13 (PM) } + +unit tbs0237; +interface + + procedure sub1(w1,w2:word); + +implementation + +procedure p1; + + procedure sub1(w:word); + begin + end; + +begin +end; + + +procedure sub1(w1,w2:word); +begin +end; + +end. diff --git a/tests/tbs/tb208.pp b/tests/tbs/tb208.pp new file mode 100644 index 0000000000..10ef6838f2 --- /dev/null +++ b/tests/tbs/tb208.pp @@ -0,0 +1,38 @@ +{ Old file: tbs0238.pp } +{ Internal error 432645 (from Frank MCCormick, mailinglist 24/2) OK 0.99.11 (PM) } + +program test1; + + {compiles under TPC - PPC386 gives internal error} + +Type str1=string[160]; + +var + fileof :file of str1; + lol :array[1..8] of str1; + nu,n:integer; + i,tt :str1; + ul :text; + a: str1; + + +procedure test; + + +begin + for nu:=1 to 8 do read(fileof,lol[nu]); + writeln('File contents'); + for nu:=4 to 8 do writeln(lol[nu]); +end; + + +begin + assign(fileof,'tbs0238.tmp'); + rewrite(fileof); + a:='dummy string !!'; + for nu:=1 to 8 do write(fileof,a); + close(fileof); + reset(fileof); + test; + close(fileof); +end. diff --git a/tests/tbs/tb209.pp b/tests/tbs/tb209.pp new file mode 100644 index 0000000000..73b7cd9fc4 --- /dev/null +++ b/tests/tbs/tb209.pp @@ -0,0 +1,50 @@ +{ Old file: tbs0239.pp } +{ No warning for uninitialized class in IS statements OK 0.99.11 (PM) } + +{$mode delphi} + uses +{$ifdef go32v2} + dpmiexcp, +{$endif go32v2} + sysutils; + type + ttest=class + end; + ttest2 = class(ttest) + end; + ttestclass=class of ttest; + var + i,j:ttest; + tt:tclass; + begin + tt:=ttest; + i:=ttest.create; + j:=ttest2.create; + Writeln('tt is a class of ttest initialized by "tt:=ttest"'); + Writeln('i is a ttest class initialized by "i:=ttest.create"'); + Writeln('j is a ttest class initialized by "j:=ttest2.create"'); + writeln('i is tobject ',i is tobject); + if not(i is tobject) then + Halt(1); + writeln('i is tt ',i is tt); + if not(i is tt) then + Halt(1); + writeln('i is ttest ',i is ttest); + if not(i is ttest) then + Halt(1); + writeln('i is ttest2 ',i is ttest2); + if (i is ttest2) then + Halt(1); + writeln('j is tobject ',j is tobject); + if not(j is tobject) then + Halt(1); + writeln('j is tt ',j is tt); + if not(j is tt) then + Halt(1); + writeln('j is ttest ',j is ttest); + if not(j is ttest) then + Halt(1); + writeln('j is ttest2 ',j is ttest2); + if not(j is ttest2) then + Halt(1); + end. diff --git a/tests/tbs/tb21.pp b/tests/tbs/tb21.pp new file mode 100644 index 0000000000..ad1ef0066e --- /dev/null +++ b/tests/tbs/tb21.pp @@ -0,0 +1,27 @@ +{ Old file: tbs0024.pp } +{ } + + +type + charset=set of char; + + trec=record + junk : array[1..32] of byte; + t : charset; + end; + + var + tr : trec; + tp : ^trec; + + + procedure Crash(const k:charset); + + begin + tp^.t:=[#7..#10]+k; + end; + + begin + tp:=@tr; + Crash([#20..#32]); + end. \ No newline at end of file diff --git a/tests/tbs/tb210.pp b/tests/tbs/tb210.pp new file mode 100644 index 0000000000..170efa1e7e --- /dev/null +++ b/tests/tbs/tb210.pp @@ -0,0 +1,24 @@ +{ Old file: tbs0240.pp } +{ Problems with larges value is case statements OK 0.99.11 (FK) } + +Program TEST; + +var CurFileCrc32f : cardinal{Longint}; + CheckThis : String; + +BEGIN + CurFileCrc32f := $C5CAF43C; + CheckThis := ''; + Case CurFileCrc32f of + $F3DC2AF0 : CheckThis := ' First '; + $27BF798B : CheckThis := ' Second '; + $7BA5BB19 : CheckThis := ' Third'; + $FA246A81 : CheckThis := ' Forth'; + $8A00B508 : CheckThis := ' Fifth'; + $C5CAF43C : CheckThis := ' Sixth'; + End; + Writeln( CheckThis ); + If CheckThis<>' Sixth' then halt(1); +END. + + diff --git a/tests/tbs/tb211.pp b/tests/tbs/tb211.pp new file mode 100644 index 0000000000..aace2d58be --- /dev/null +++ b/tests/tbs/tb211.pp @@ -0,0 +1,19 @@ +{ Old file: tbs0241.pp } +{ Problem with importing function from a DLL with .drv suffix ! OK 0.99.11 (PM) } + +{$ifdef win32} +program test_win32_drv; + +procedure printer;external 'winspool.drv' name 'AbortPrinter'; +procedure test; + + begin + Writeln('Loading of Winspool works '); + end; + +begin + test; +{$else} +begin +{$endif} +end. diff --git a/tests/tbs/tb212.pp b/tests/tbs/tb212.pp new file mode 100644 index 0000000000..97a5fda104 --- /dev/null +++ b/tests/tbs/tb212.pp @@ -0,0 +1,31 @@ +{ Old file: tbs0242b.pp } +{ } + + +const + test = 5; + + procedure test_const(const s : string;const x); + begin + writeln(s,' is ',longint(x)); + end; + + procedure change(var x); + begin + inc(longint(x)); + end; + const i : longint = 12; + var + j : longint; +begin + j:=34; + test_const('Const 5',5); + test_const('Untyped const test',test); + test_const('Typed_const i',i); + test_const('Var j',j); + {test_const('i<>j ',i<>j);} + change(i); + change(j); + { change(test); + change(longint); } +end. diff --git a/tests/tbs/tb213.pp b/tests/tbs/tb213.pp new file mode 100644 index 0000000000..d95bdb90f7 --- /dev/null +++ b/tests/tbs/tb213.pp @@ -0,0 +1,38 @@ +{ Old file: tbs0243.pp } +{ Arguments of functions are computed from right to left this } + +program simpletest; + +var i : longint; + + function _next : longint; + begin + inc(i); + _next:=i; + end; + + procedure test(a,b : longint); + begin + Writeln('first arg is ',a); + Writeln('second arg is ',b); + end; + + procedure check(a,b : longint); + begin + if a>b then + begin + Writeln('FPC does not follow PASCAL rules for parameter passing'); + Halt(1); + end; + end; + +begin +{ this could give + first arg is 1 + second arg is 2 + but FPC parses the second arg before the first one ! } +test(_next,_next); +writeln('third arg is ',_next); +writeln('fourth arg is ',_next,' fifth arg is ',_next); +check(_next,_next); +end. diff --git a/tests/tbs/tb214.pp b/tests/tbs/tb214.pp new file mode 100644 index 0000000000..d0eb904c79 --- /dev/null +++ b/tests/tbs/tb214.pp @@ -0,0 +1,27 @@ +{ Old file: tbs0244.pp } +{ nested procedures can't have same name as global ones (same as tbs0237) OK 0.99.13 (PM) } + +Unit tbs0244; + +{test also with -So !!!} + +Interface + +Procedure t(a,b: longint); + +Implementation + +Procedure t(a,b: longint); +begin +end; + +Procedure t2; + + Procedure t(l: Longint); + Begin + End; + +Begin +End; + +End. diff --git a/tests/tbs/tb215.pp b/tests/tbs/tb215.pp new file mode 100644 index 0000000000..8e36cbe6e0 --- /dev/null +++ b/tests/tbs/tb215.pp @@ -0,0 +1,25 @@ +{ Old file: tbs0247.pp } +{ var with initial value not supprted (Delphi var x : integer = 5;) allowed in -Sd mode OK 0.99.11 (PM) } + +{$mode delphi} + +var + x : integer = 34; +{ this is the way Delphi creates initialized vars + ++ its much more logical then BP + typed const !! + -- its incompatible with BP !! (PM) } + + y : array[0..2] of real = (0.0,1.23,2.56); + +{ these are true const in Delphi mode and thus + it should not be possible to change ! } + +const + z : real = 45.2; + +begin + y[2]:=z; + { this should be refused ! } + z:=y[1]; +end. \ No newline at end of file diff --git a/tests/tbs/tb216.pp b/tests/tbs/tb216.pp new file mode 100644 index 0000000000..1bb62c7bba --- /dev/null +++ b/tests/tbs/tb216.pp @@ -0,0 +1,64 @@ +{ Old file: tbs0249.pp } +{ procedure of object cannot be assigned to property. OK 0.99.11 (PFV) } + +program TestEvent; + +{$mode objfpc} +{$M+} + +type + TNotifyEvent = procedure( Sender: TObject ) of object; + + THost = class + protected + FOnEvent: TNotifyEvent; + procedure SetOnEvent( Value: TNotifyEvent ); + public + constructor Create; + procedure Trigger; + procedure SayHello; + published + property OnEvent: TNotifyEvent read FOnEvent write SetOnEvent; + end; + + TDummy = class + procedure HandleEvent( Sender: TObject ); + end; + +constructor THost.Create; +begin + FOnEvent := nil; +end; + +procedure THost.Trigger; +begin + if @FOnEvent <> nil then + FOnEvent( Self ) +end; + +procedure THost.SetOnEvent( Value: TNotifyEvent ); +begin + FOnEvent := Value +end; + +procedure THost.SayHello; +begin + Writeln( 'Hello event' ) +end; + +procedure TDummy.HandleEvent( Sender: TObject ); +begin + THost( Sender ).SayHello +end; + + +var + Host: THost; + Dummy: TDummy; +begin + Dummy := TDummy.Create; + Host := THost.Create; + with Host,Dummy do + OnEvent := @HandleEvent; // this is 57, 27 is ";" + Host.Trigger; +end. diff --git a/tests/tbs/tb217.pp b/tests/tbs/tb217.pp new file mode 100644 index 0000000000..abe559afc5 --- /dev/null +++ b/tests/tbs/tb217.pp @@ -0,0 +1,32 @@ +{ Old file: tbs0250.pp } +{ error with Ansistrings and loops. OK 0.99.11 (PFV) } + +program testme; + +uses erroru; + +// Removing this switch removes the bug !! +{$H+} + +var A : String; + P : PChar; + I : longint; + +begin + P := 'Some sample testchar'; + A := Ansistring(P); + Writeln ('A : ',A); + for I:=1 to length(A)-1 do + begin + A:='Some small test'; + A:=A+' ansistring'; + Writeln ('A : ',A); + If A<>'' then + Writeln ('All is fine') + else + begin + writeln ('Oh-oh!'); + error; + end; + end; +end. diff --git a/tests/tbs/tb218.pp b/tests/tbs/tb218.pp new file mode 100644 index 0000000000..fd2a069bd2 --- /dev/null +++ b/tests/tbs/tb218.pp @@ -0,0 +1,29 @@ +{ Old file: tbs0251.pp } +{ typed const are not aligned correctly OK 0.99.11 (PM) } + + +uses erroru; + +const + c : byte = 5; + r : real = 3.4; +var + l : longint; + cc : char; + rr : real; + +begin + l:=longint(@r); + if (l mod 4)<>0 then + begin + Writeln('static const are not aligned properly !'); + error; + end; + cc:='d'; + l:=longint(@rr); + if (l mod 4)<>0 then + begin + Writeln('static var are not aligned properly !'); + error; + end; +end. diff --git a/tests/tbs/tb219.pp b/tests/tbs/tb219.pp new file mode 100644 index 0000000000..a64141a6d4 --- /dev/null +++ b/tests/tbs/tb219.pp @@ -0,0 +1,21 @@ +{ Old file: tbs0252.pp } +{ typecasting not possible within typed const OK 0.99.13 (PFV) } + +type + wnd=procedure; + r=record + w : wnd; + end; + +procedure p; +begin +end; + +const + r1:r=( + w : wnd(@p); + ); + +begin +end. + diff --git a/tests/tbs/tb22.pp b/tests/tbs/tb22.pp new file mode 100644 index 0000000000..edb53a5f06 --- /dev/null +++ b/tests/tbs/tb22.pp @@ -0,0 +1,18 @@ +{ Old file: tbs0025.pp } +{ tests for a wrong uninit. var. warning OK 0.9.3 } + +procedure p1; +type + datetime=record + junk : string; +end; +var + dt : datetime; +begin + fillchar(dt,sizeof(dt),0); +end; + +begin + P1; +end. + diff --git a/tests/tbs/tb220.pp b/tests/tbs/tb220.pp new file mode 100644 index 0000000000..98fc44963f --- /dev/null +++ b/tests/tbs/tb220.pp @@ -0,0 +1,21 @@ +{ Old file: tbs0253.pp } +{ problem with overloaded procedures and forward OK 0.99.11 (PFV) } + +procedure test(w : word);forward; + +procedure test(a : string); +begin + Writeln(a); + test(20); +end; + +procedure test(w :word); +begin + writeln(w); +end; + +begin + test('test'); + test(32); +end. + diff --git a/tests/tbs/tb221.pp b/tests/tbs/tb221.pp new file mode 100644 index 0000000000..a8db1be2b8 --- /dev/null +++ b/tests/tbs/tb221.pp @@ -0,0 +1,7 @@ +{ Old file: tbs0254.pp } +{ problem of endless loop if string at end of main file without new line. OK 0.99.11 (PM) } + +begin +end. + +disposestr \ No newline at end of file diff --git a/tests/tbs/tb222.pp b/tests/tbs/tb222.pp new file mode 100644 index 0000000000..87de34cd6a --- /dev/null +++ b/tests/tbs/tb222.pp @@ -0,0 +1,12 @@ +{ Old file: tbs0255.pp } +{ internal error 10 with in and function calls OK 0.99.12 (FK) } + + +function a: char; +begin + a:='c'; +end; + +begin + if #12 in [a, a, a, a, a] then ; { <--- } +end. diff --git a/tests/tbs/tb223.pp b/tests/tbs/tb223.pp new file mode 100644 index 0000000000..e23bd6ede3 --- /dev/null +++ b/tests/tbs/tb223.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0256.pp } +{ problem with conditionnals in TP mode OK 0.99.11 (PM) } + +{$mode tp} + +{$undef dummy } + +{$ifdef dummy} + procedure test; + begin + foreach({$ifndef TP}@{$endif}add_to_browserlog); + end; +{$endif BrowserLog} + +begin +end. diff --git a/tests/tbs/tb224.pp b/tests/tbs/tb224.pp new file mode 100644 index 0000000000..1cd751556e --- /dev/null +++ b/tests/tbs/tb224.pp @@ -0,0 +1,21 @@ +{ Old file: tbs0257.pp } +{ problem with procvars in tp mode OK 0.99.11 (PM) } + +{$mode tp} + +type proc = procedure(a : longint); +procedure test(b : longint); +begin + Writeln('Test ',b); +end; + +var + t : proc; + +begin + t:=test; + t:=proc(test); + test(3); + t(5); +end. + diff --git a/tests/tbs/tb225.pp b/tests/tbs/tb225.pp new file mode 100644 index 0000000000..3e71f19351 --- /dev/null +++ b/tests/tbs/tb225.pp @@ -0,0 +1,66 @@ +{ Old file: tbs0258.pp } +{ bugs in small const set extension to large sets OK 0.99.12 (PM) } + +{$ifdef fpc} +{$mode tp} +{$endif fpc} +program test_set; + +uses erroru; + +{$R-} + +procedure test; + + var + i : longint; + j : integer; + k : word; + l : shortint; + m : byte; + x : array [1..32] of byte; + + begin + for i:=1 to 32 do x[i]:=$ff; + i:=1; + if not(i in [1,3,5,8,11,14,15]) then + begin + writeln('Error in set'); + error; + end; + i:=135; + if i in [1,3,5,8,11,14,15] then + begin + writeln('Error : 135 is in [1,3,5,8,11,14,15]'); + error; + end; + i:=257; + if not(i in [1,3,5,8,11,14,15]) then + begin + writeln('Error : 257 isn''t in [1,3,5,8,11,14,15]'); + error; + end; + l:=-1; + if not(l in [1,3,5,8,11,14,15,255]) then + begin + writeln('Error : -1 isn''t in [1,3,5,8,11,14,15,255]'); + error; + end; + i:=257; + if not(l in [1,3,5,8,11,14,15,255]) then + begin + writeln('Error : longint(257) isn''t in [1,3,5,8,11,14,15,255]'); + error; + end; + for i:=1 to 32 do x[i]:=0; + i:=135; + if i in [1,3,5,8,11,14,15] then + begin + writeln('Second try Error : 135 is in [1,3,5,8,11,14,15]'); + error; + end; + end; + +begin + test; +end. \ No newline at end of file diff --git a/tests/tbs/tb226.pp b/tests/tbs/tb226.pp new file mode 100644 index 0000000000..c7103c28de --- /dev/null +++ b/tests/tbs/tb226.pp @@ -0,0 +1,10 @@ +{ %OPT= -O1} + +{ Old file: tbs0259.pp } +{ problem with optimizer for real math (use -O1) OK 0.99.12 (PM) } + +VAR time1,time2 : Real; +BEGIN + time1 := 0; + time2 := time1*time1; +END. diff --git a/tests/tbs/tb227.pp b/tests/tbs/tb227.pp new file mode 100644 index 0000000000..6d4805f772 --- /dev/null +++ b/tests/tbs/tb227.pp @@ -0,0 +1,35 @@ +{ Old file: tbs0260.pp } +{ problem with VMT generation if non virtual method has a virtual overload OK 0.99.12 (PM) } + +program test; + + type + obj1 = object + st : string; + constructor init; + procedure writeit; + end; + + obj2 = object(obj1) + procedure writeit;virtual; + end; + + obj3 = object(obj2) + l : longint; + end; + + constructor obj1.init; + begin + end; + + procedure obj1.writeit; + begin + end; + + procedure obj2.writeit; + begin + end; + + +begin +end. diff --git a/tests/tbs/tb228.pp b/tests/tbs/tb228.pp new file mode 100644 index 0000000000..de3219dd25 --- /dev/null +++ b/tests/tbs/tb228.pp @@ -0,0 +1,35 @@ +{ Old file: tbs0261.pp } +{ problems for assignment overloading OK 0.99.12a (PM) } + +program bug0261; + +{ test for operator overloading } +{ Copyright (c) 1999 Lourens Veen } +{ why doesn't this work? } +uses + erroru, + tbs0261a; + + +var a : mythingy; + b : myotherthingy; + c : mythirdthingy; +begin + a.x:=55; + a.y:=45; + a.c:=7; + b:=a; + c:=a; + if b.d<>c.e then + begin + Writeln('Error in assignment overloading'); + Halt(1); + end; + if b<>c then + begin + Writeln('Error in equal overloading'); + Halt(1); + end; + Writeln('Sizeof(mythirdthingy)=',sizeof(mythirdthingy)); + Writeln('Sizeof(mynewthingy)=',sizeof(mynewthingy)); +end. diff --git a/tests/tbs/tb229.pp b/tests/tbs/tb229.pp new file mode 100644 index 0000000000..5a5a2d2045 --- /dev/null +++ b/tests/tbs/tb229.pp @@ -0,0 +1,57 @@ +{ Old file: tbs0261a.pp } +{ } + +unit tbs0261a; + +{ test for operator overloading } +{ Copyright (c) 1999 Lourens Veen } +{ why doesn't this work? } + +interface + +type mythingy = record + x, y : longint; + c : byte; + end; + + myotherthingy = record + x, y : longint; + d : byte; + end; + + mythirdthingy = record + x, y : longint; + e : byte; + end; + + mynewthingy = record + x, y : longint; + e,f : byte; + end; + +operator := (a : mythingy) r : myotherthingy; +operator := (a : mythingy) r : mythirdthingy; +operator = (b : myotherthingy;c : mythirdthingy) res : boolean; + +implementation + +operator := (a : mythingy) r : myotherthingy; +begin + r.x := a.x; + r.y := a.y; + r.d := a.c; +end; + +operator := (a : mythingy) r : mythirdthingy; +begin + r.x := a.x; + r.y := a.y; + r.e := a.c; +end; + +operator = (b : myotherthingy;c : mythirdthingy) res : boolean; +begin + res:=(b.x=c.x) and (b.y=c.y) and (b.d=c.e); +end; + +end. diff --git a/tests/tbs/tb23.pp b/tests/tbs/tb23.pp new file mode 100644 index 0000000000..3594991f0e --- /dev/null +++ b/tests/tbs/tb23.pp @@ -0,0 +1,25 @@ +{ Old file: tbs0026.pp } +{ tests for a wrong unused. var. warning OK 0.9.4 } + +const + HexTbl : array[0..15] of char=('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'); +function HexB(b:byte):string; +begin + HexB[0]:=#2; + HexB[1]:=HexTbl[b shr 4]; + HexB[2]:=HexTbl[b and $f]; +end; + + + +function HexW(w:word):string; +begin + HexW:=HexB(w shr 8)+HexB(w and $ff); +end; + + + +begin + HexW($fff); +end. + diff --git a/tests/tbs/tb230.pp b/tests/tbs/tb230.pp new file mode 100644 index 0000000000..c5e1938d93 --- /dev/null +++ b/tests/tbs/tb230.pp @@ -0,0 +1,117 @@ +{ Old file: tbs0262.pp } +{ problems with virtual and overloaded methods } + +program test; + + type + obj1 = object + st2 : string; + constructor init; + procedure writeit; + procedure writeit(st : string);virtual; + end; + + obj2 = object(obj1) + procedure writeit;virtual; + end; + + obj3 = object(obj2) + l2 : longint; + procedure writeit(l : longint);virtual; + procedure writeit(st : string);virtual; + end; + + obj4 = object(obj3) + procedure writeit;virtual; + procedure writeit(st : string);virtual; + end; + + obj5 = object(obj4) + procedure writeit;virtual; + procedure writeit(st : string); + procedure writeit(l : longint);virtual; + end; + + constructor obj1.init; + begin + end; + + procedure obj1.writeit; + begin + Writeln('Obj1 writeit'); + end; + + procedure obj1.writeit(st : string); + begin + Writeln('Obj1 writeit(string) ',st); + end; + + procedure obj2.writeit; + begin + Writeln('Obj2 writeit'); + end; + + procedure obj3.writeit(st : string); + begin + Writeln('Obj3 writeit(string) ',st); + end; + + procedure obj3.writeit(l : longint); + begin + Writeln('Obj2 writeit(longint) ',l); + end; + + procedure obj4.writeit; + begin + Writeln('Obj4 writeit'); + end; + + procedure obj4.writeit(st : string); + begin + Writeln('Obj4 writeit(string) ',st); + end; + + procedure obj5.writeit; + begin + Writeln('Obj5 writeit'); + end; + + procedure obj5.writeit(st : string); + begin + Writeln('Obj5 writeit(string) ',st); + end; + + procedure obj5.writeit(l : longint); + begin + Writeln('Obj5 writeit(longint) ',l); + end; + +var + o1 : obj1; + o2 : obj2; + o3 : obj3; + o4 : obj4; + o5 : obj5; + + + +begin + o1.init; + o1.writeit; + o1.writeit('o1'); + o2.init; + o2.writeit; + o2.writeit('o2'); + o3.init; + o3.writeit; + o3.writeit('o3'); + o3.writeit(3); + o4.init; + o4.writeit; + o4.writeit('o4'); + o4.writeit(4); + o5.init; + o5.writeit; + o5.writeit('o5'); + o5.writeit(5); +end. diff --git a/tests/tbs/tb231.pp b/tests/tbs/tb231.pp new file mode 100644 index 0000000000..064a4ba0bb --- /dev/null +++ b/tests/tbs/tb231.pp @@ -0,0 +1,29 @@ +{ Old file: tbs0263.pp } +{ export directive is not necessary in delphi anymore OK 0.99.13 (PFV) } + +{$ifdef linux} + {$define doit} +{$endif} +{$ifdef win32} + {$define doit} +{$endif} +{$ifdef doit} +library tbs0263; + +{ + The export directive is not necessary anymore in delphi, it's a leftover + from the 16bit model, just like near and far. +} + +procedure testp; +begin +end; + +exports + testp name 'testp'; + +end. +{$else} +begin +end. +{$endif} diff --git a/tests/tbs/tb232.pp b/tests/tbs/tb232.pp new file mode 100644 index 0000000000..8afbd603e6 --- /dev/null +++ b/tests/tbs/tb232.pp @@ -0,0 +1,47 @@ +{ Old file: tbs0264.pp } +{ methodpointer bugss OK 0.99.12b (FK) } + +{$MODE DELPHI} + +type + a = class + c : procedure of object; + + constructor create; virtual; + destructor destroy; override; + + procedure e; virtual; + procedure f; virtual; + end; + +constructor a.create; +begin + c := @e; +end; + +destructor a.destroy; +begin +end; + +procedure a.e; +begin + Writeln('E'); + c := @f; +end; + +procedure a.f; +begin + Writeln('F'); + c := @e; +end; + +var + z : a; + +begin + z := a.create; + z.c; + z.c; + z.c; + z.free; +end. diff --git a/tests/tbs/tb233.pp b/tests/tbs/tb233.pp new file mode 100644 index 0000000000..6ed7e38378 --- /dev/null +++ b/tests/tbs/tb233.pp @@ -0,0 +1,19 @@ +{ Old file: tbs0266.pp } +{ linux crt write cuts 256 char OK 0.99.13 (PFV) } + +PROGRAM t10; + +USES CRT; + +VAR S: STRING; + X: BYTE; + + + BEGIN + S := ''; + FOR X := 1 TO 253 DO S:=S+'-'; + S := S+'_!'; + WRITE(S); + WRITE('*',S); + END. + \ No newline at end of file diff --git a/tests/tbs/tb234.pp b/tests/tbs/tb234.pp new file mode 100644 index 0000000000..fd16bbdd9e --- /dev/null +++ b/tests/tbs/tb234.pp @@ -0,0 +1,31 @@ +{ Old file: tbs0267.pp } +{ parameters after methodpointer are wrong OK 0.99.12b (FK) } + +{$MODE objfpc} + +program procofobject_arg; +type + TProcOfObject = procedure of object; + TTestClass = class + procedure SomeMethod; + end; + +procedure TTestClass.SomeMethod; begin end; + + +// the following proc won't print i2 correctly + +procedure CrashProc(i1: Integer;method: TProcOfObject; i2: Integer); +begin + WriteLn('i1 is :', i1); + WriteLn('i2 is :', i2); + if i2<>456 then + Halt(1); +end; + +var + instance: TTestClass; +begin + instance := TTestClass.Create; + CrashProc(123, @instance.SomeMethod, 456); +end. diff --git a/tests/tbs/tb235.pp b/tests/tbs/tb235.pp new file mode 100644 index 0000000000..c1e2235aa1 --- /dev/null +++ b/tests/tbs/tb235.pp @@ -0,0 +1,33 @@ +{ Old file: tbs0268.pp } +{ crash with exceptions OK 0.99.13 (FK) } + +PROGRAM Test2; + +{$MODE DELPHI} + +USES SysUtils; // Dos for DosError because FindFirst is not a Function? + +PROCEDURE DirList; +(* Show all Files, gives me "unhandled exception occurred at xxx, access + violation" after inserting Try Except it worked but i got a "forever + scrolling screen", then i inserted raise and got a correct "Exception + in FindFirst" and "At end of ExceptionAddressStack" + Next i inserted the ON E:EXCEPTION and ,E.Message an got 9999 *) +VAR SR : TSearchRec; +BEGIN + TRY + FindFirst ('*',faAnyFile,SR); // why not a function ? + EXCEPT + ON E:EXCEPTION DO + WriteLn ('Exception in FindFirst !-', E.Message); + END; + repeat + Write (SR.Name,' '); + until FindNext (SR)<>0; + FindClose (SR); // and this is Delphi ? +END; + +BEGIN + WriteLn ('Hello, this is my first FPC-Program'); + DirList; +END. diff --git a/tests/tbs/tb236.pp b/tests/tbs/tb236.pp new file mode 100644 index 0000000000..56e5eaff47 --- /dev/null +++ b/tests/tbs/tb236.pp @@ -0,0 +1,24 @@ +{ Old file: tbs0270.pp } +{ unexpected eof in tp mode with (* and directives OK 0.99.13 (PFV) } + +unit tbs0270; + +{$mode tp} + +interface + +const + s='df'; + +{$IFDEF VDE} + SFilterOpen = ' (*.nnn)|*.nnn' + '|' + 'Alle Files (*.*)|*.*'; + SFilterSave = ' (*.nnn)|*.nnn'; + SFilterOpen2 = ' (*.vvv)|*.vvv' + '|' + 'All Files (*.*)|*.*'; + SFilterSave2 = ' (*.vvv)|*.vvv'; + SFilterOpen3 = ' (*.eee)|*.eee' + '|' + 'All Files (*.*)|*.*'; + SFilterSave3 = ' (*.eee)|*.eee'; +{$ENDIF} + +implementation + +end. diff --git a/tests/tbs/tb237.pp b/tests/tbs/tb237.pp new file mode 100644 index 0000000000..6e382ad4f7 --- /dev/null +++ b/tests/tbs/tb237.pp @@ -0,0 +1,34 @@ +{ Old file: tbs0271.pp } +{ abstract methods can't be assigned to methodpointers OK 0.99.13 (??) } + +{$mode fpc} + type + tproc = procedure; + +procedure proc1; +begin +end; + +var + _copyscan : tproc; + +procedure setproc; +begin + _copyscan := @proc1; +end; + +procedure testproc; +begin + if not (_copyscan=@proc1) then + begin + Writeln(' Problem procvar equality'); + Halt(1); + end + else + Writeln(' No problem with procedure equality'); +end; + +begin + setproc; + testproc; +end. diff --git a/tests/tbs/tb238.pp b/tests/tbs/tb238.pp new file mode 100644 index 0000000000..ad793df626 --- /dev/null +++ b/tests/tbs/tb238.pp @@ -0,0 +1,36 @@ +{ Old file: tbs0272.pp } +{ No error issued if wrong parameter in function inside a second function OK 0.99.13 (PFV) } + +program test_const_string; + + +function astring(s :string) : string; + +begin + astring:='Test string'+s; +end; + +procedure testvar(var s : string); +begin + writeln('testvar s is "',s,'"'); +end; + +procedure testconst(const s : string); +begin + writeln('testconst s is "',s,'"'); +end; + +procedure testvalue(s : string); +begin + writeln('testvalue s is "',s,'"'); +end; + +const + s : string = 'test'; + conststr = 'Const test'; +begin + testvalue(astring('e')); + testconst(astring(s)); + testconst(conststr); +end. + diff --git a/tests/tbs/tb239.pp b/tests/tbs/tb239.pp new file mode 100644 index 0000000000..ffeadb2b2a --- /dev/null +++ b/tests/tbs/tb239.pp @@ -0,0 +1,21 @@ +{ Old file: tbs0273.pp } +{ small array pushing to array of char procedure is wrong OK 0.99.13 (PFV) } + +Program CharArr; + +Var CharArray : Array[1..4] Of Char; + + S : String; + +Begin + CharArray:='BUG?'; + S:=CharArray; + WriteLn(S); { * This is O.K. * } + WriteLn(CharArray); { * GENERAL PROTECTION FAULT. * } + if CharArray<>'BUG?' then + begin + Writeln('Error comparing charaay to constant string'); + Halt(1); + end; +End. + diff --git a/tests/tbs/tb24.pp b/tests/tbs/tb24.pp new file mode 100644 index 0000000000..e63e82d6ed --- /dev/null +++ b/tests/tbs/tb24.pp @@ -0,0 +1,8 @@ +{ Old file: tbs0027.pp } +{ tests type enumtype = (One, two, three, forty:=40, fifty); OK 0.9.5 } + +type enumtype = (One, two, three, forty:=40, fifty); + +begin +end. + diff --git a/tests/tbs/tb240.pp b/tests/tbs/tb240.pp new file mode 100644 index 0000000000..22c43f53e6 --- /dev/null +++ b/tests/tbs/tb240.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0274.pp } +{ @(proc) is not allowed OK 0.99.13 (PFV) } + +type + proc=procedure(a:longint); + +procedure prc(a:longint); +begin +end; + +var + p : proc; +begin + p:=@prc; + p:=@(prc); { should this be allowed ? } +end. \ No newline at end of file diff --git a/tests/tbs/tb241.pp b/tests/tbs/tb241.pp new file mode 100644 index 0000000000..d40ce6b53d --- /dev/null +++ b/tests/tbs/tb241.pp @@ -0,0 +1,8 @@ +{ Old file: tbs0275.pp } +{ too many warnings } + +var + d : single; +begin + writeln(longint(d)); +end. diff --git a/tests/tbs/tb242.pp b/tests/tbs/tb242.pp new file mode 100644 index 0000000000..40bff2030f --- /dev/null +++ b/tests/tbs/tb242.pp @@ -0,0 +1,49 @@ +{ Old file: tbs0276.pp } +{ Asm, intel reference parsing incompatibility OK 0.99.13 (PFV) } + +{$asmmode intel} +type + trec = record + ypos, + xpos : longint; + end; + + z80cont = record + dummy : longint; + page: array [0..11,0..16383] of byte; + end; + +var + rec : tRec; + myz80 : z80cont; + error : boolean; + test : byte; +begin + error:=false; + test:=23; + rec.xpos:=1; + myz80.page[0,5]:=15; + asm + lea edi, Rec + cmp byte ptr [edi+tRec.Xpos], 1 + jne @error + cmp byte ptr [edi].trec.Xpos, 1 + jne @error + mov ecx, 5 + mov dh,byte ptr myz80.page[ecx] + cmp dh,15 + jne @error + mov byte ptr myz80.page[ecx],51 + jmp @noerror + @error: + mov byte ptr error,1 + @noerror: + end; + if error or (test<>23) or (myz80.page[0,5]<>51) then + begin + Writeln('Error in assembler code generation'); + Halt(1); + end + else + Writeln('Correct assembler generated'); +end. diff --git a/tests/tbs/tb243.pp b/tests/tbs/tb243.pp new file mode 100644 index 0000000000..9e3a786a5d --- /dev/null +++ b/tests/tbs/tb243.pp @@ -0,0 +1,8 @@ +{ Old file: tbs0277.pp } +{ typecasting with const not possible OK 0.99.13 (PFV) } + + program bug0277; + const test_byte=pchar(1); + begin + writeln('Hello world'); + end. diff --git a/tests/tbs/tb244.pp b/tests/tbs/tb244.pp new file mode 100644 index 0000000000..aefd8e934e --- /dev/null +++ b/tests/tbs/tb244.pp @@ -0,0 +1,32 @@ +{ Old file: tbs0278.pp } +{ (* in conditional code is handled wrong for tp,delphi OK 0.99.13 (PFV) } + +{$ifdef fpc}{$mode tp}{$endif} +unit tbs0278; + +interface + +{ +a string constant within $IFDEF that +contains "(*" causes an error; +compile it with "ppc386 test -So" or "-Sd" +} + +var + c : char; + +{$IFDEF not_defined} +const + c = 'b''(* + +{ $else} + +var + c : char; + +{$ENDIF} + + +implementation + +end. diff --git a/tests/tbs/tb245.pp b/tests/tbs/tb245.pp new file mode 100644 index 0000000000..fe836d95f8 --- /dev/null +++ b/tests/tbs/tb245.pp @@ -0,0 +1,36 @@ +{ Old file: tbs0279.pp } +{ crash with ansistring and new(^ansistring) OK 0.99.13 (PFV) } + +{$H+} +Program AnsiTest; + +Type + PS=^String; + +procedure test; +var + P:PS; +Begin + New(P); + P^:=''; + P^:=P^+'BLAH'; + P^:=P^+' '+P^; + Writeln(P^); + Dispose(P); +end; + +var + membefore : longint; + +begin + membefore:=memavail; + test; + if membefore<>memavail then + begin + Writeln('Memory hole using pointers to ansi strings'); + Halt(1); + end + else + Writeln('No memory hole with pointers to ansi strings'); +end. + diff --git a/tests/tbs/tb246.pp b/tests/tbs/tb246.pp new file mode 100644 index 0000000000..19828e91be --- /dev/null +++ b/tests/tbs/tb246.pp @@ -0,0 +1,51 @@ +{ Old file: tbs0280.pp } +{ problem with object finalization. OK 0.99.13 (FK) } + +{$mode objfpc} +{$H+} + +program memhole; + +{$ifdef go32v2} +uses + dpmiexcp; +{$endif go32v2} + +type + TMyClass = class + s: String; + end; + plongint = ^longint; + +procedure dotest; + +var + c: TMyClass; + s : string; + +begin + s:='world'; + s:='Hallo '+s; + writeln((plongint(s)-4)^); + c := TMyClass.Create; + writeln(longint(c.s)); + c.s := Copy('Test', 1, 4); + writeln((plongint(c.s)-4)^); + c.free; +end; + +var + membefore : longint; +begin + membefore:=memavail; + writeln(memavail); + dotest; + writeln(memavail); + if membefore<>memavail then + begin + Writeln('Memory hole using ansi strings in classes'); + Halt(1); + end + else + Writeln('No memory hole unsing ansi strings in classes'); +end. diff --git a/tests/tbs/tb247.pp b/tests/tbs/tb247.pp new file mode 100644 index 0000000000..8451394c81 --- /dev/null +++ b/tests/tbs/tb247.pp @@ -0,0 +1,36 @@ +{ Old file: tbs0282.pp } +{ long mangledname problem with -Aas OK 0.99.13 (PFV) } + + +type very____long_____string___identifier= string[200]; + +procedure test(very__long_variable01: very____long_____string___identifier; + very__long_variable02: very____long_____string___identifier; + very__long_variable03: very____long_____string___identifier; + very__long_variable04: very____long_____string___identifier; + very__long_variable05: very____long_____string___identifier; + very__long_variable06: very____long_____string___identifier; + very__long_variable07: very____long_____string___identifier; + very__long_variable08: very____long_____string___identifier; + very__long_variable09: very____long_____string___identifier; + very__long_variable10: very____long_____string___identifier; + very__long_variable11: very____long_____string___identifier; + very__long_variable12: very____long_____string___identifier; + very__long_variable13: very____long_____string___identifier; + very__long_variable14: very____long_____string___identifier; + very__long_variable15: very____long_____string___identifier; + very__long_variable16: very____long_____string___identifier; + very__long_variable17: very____long_____string___identifier; + very__long_variable18: very____long_____string___identifier); +begin + writeln('hi!'); +end; + +begin + writeln('vreemd!'); + test('','','','','','','','','','', + '','','','','','','',''); +end. + + + diff --git a/tests/tbs/tb248.pp b/tests/tbs/tb248.pp new file mode 100644 index 0000000000..5a55143d26 --- /dev/null +++ b/tests/tbs/tb248.pp @@ -0,0 +1,15 @@ +{ Old file: tbs0283.pp } +{ bugs in constant char comparison evaluation OK 0.99.13 (PFV) } + +const dirsep = '\'; + +begin + if dirsep = '/' + then + begin + writeln('bug!'); + Halt(1); + end + else + writeln('ok'); +end. diff --git a/tests/tbs/tb249.pp b/tests/tbs/tb249.pp new file mode 100644 index 0000000000..4582def941 --- /dev/null +++ b/tests/tbs/tb249.pp @@ -0,0 +1,12 @@ +{ Old file: tbs0284b.pp } +{ } + +unit tbs0284b; +interface +type + o1=object + p : longint; + end; + +implementation +end. diff --git a/tests/tbs/tb25.pp b/tests/tbs/tb25.pp new file mode 100644 index 0000000000..d99deefff1 --- /dev/null +++ b/tests/tbs/tb25.pp @@ -0,0 +1,13 @@ +{ Old file: tbs0028.pp } +{ type enumtype = (a); writeln(ord(a)); } + +type + enumtype = (a); + +var + e : enumtype; + +begin + writeln(ord(e)); +end. + diff --git a/tests/tbs/tb250.pp b/tests/tbs/tb250.pp new file mode 100644 index 0000000000..c2f2cf4d34 --- /dev/null +++ b/tests/tbs/tb250.pp @@ -0,0 +1,21 @@ +{ Old file: tbs0285.pp } +{ Asm, TYPE not support in intel mode OK 0.99.13 (PFV) } + +{$asmmode intel} + +TYPE something = RECORD big:LONGINT; small:BYTE; END; + +FUNCTION typesize:INTEGER; ASSEMBLER; +ASM + MOV EAX, TYPE something +END; + +BEGIN + writeln(typesize); + if typesize<>sizeof(something) then + begin + Writeln('Error in type inside intel asm'); + Halt(1); + end; +END. + diff --git a/tests/tbs/tb251.pp b/tests/tbs/tb251.pp new file mode 100644 index 0000000000..453cd58a5b --- /dev/null +++ b/tests/tbs/tb251.pp @@ -0,0 +1,8 @@ +{ Old file: tbs0286.pp } +{ #$08d not allowed as Char constant OK 0.99.13 (PFV) } + +var + c : char; +begin + c:=#$08d; +end. diff --git a/tests/tbs/tb252.pp b/tests/tbs/tb252.pp new file mode 100644 index 0000000000..e99afa0c28 --- /dev/null +++ b/tests/tbs/tb252.pp @@ -0,0 +1,24 @@ +{ Old file: tbs0287.pp } +{ (true > false) not supported OK 0.99.13 (PFV) } + +var + b,bb : boolean; +begin + b:=(true > false); + if b then + writeln('ok 1') + else + halt(1); + b:=true; + b:=(b > false); + if b then + writeln('ok 2') + else + halt(1); + b:=false; + bb:=true; + if b $ffff then + begin + Writeln('i:=$ffff loads ',i,'$7fff if i is integer !'); + end; + j := 65535; + if j <> 65535 then + begin + Writeln('j:=65535 loads ',j,' if j is integer !'); + end; + if ($ffff=65535) and (i<>j) then + begin + Writeln('i and j are different !!!'); + Halt(1); + end; +end. \ No newline at end of file diff --git a/tests/tbs/tb256.pp b/tests/tbs/tb256.pp new file mode 100644 index 0000000000..a76705551a --- /dev/null +++ b/tests/tbs/tb256.pp @@ -0,0 +1,28 @@ +{ Old file: tbs0291.pp } +{ @procvar in tp mode bugss OK 0.99.13 (PFV) } + +{$mode tp} + +function ReturnString: string; +begin + ReturnString := 'A string'; +end; + +procedure AcceptString(S: string); +begin + WriteLn('Got: ', S); +end; + +type + TStringFunc = function: string; + +const + SF: TStringFunc = ReturnString; +var + S2: TStringFunc; +begin + @S2:=@ReturnString; + AcceptString(ReturnString); + AcceptString(SF); + AcceptString(S2); +end. diff --git a/tests/tbs/tb257.pp b/tests/tbs/tb257.pp new file mode 100644 index 0000000000..ee8d76f542 --- /dev/null +++ b/tests/tbs/tb257.pp @@ -0,0 +1,50 @@ +{ Old file: tbs0292.pp } +{ objects not finalized when disposed OK 0.99.13 (FK) } + +{$mode objfpc} + +type + pobj = ^tobj; + tobj = object + a: ansistring; + constructor init(s: ansistring); + destructor done; + end; + + PAnsiRec = ^TAnsiRec; + TAnsiRec = Packed Record + Maxlen, + len, + ref : Longint; + First : Char; + end; + +const firstoff = sizeof(tansirec)-1; + +var o: pobj; + t: ansistring; + +constructor tobj.init(s: ansistring); +begin + a := s; +end; + +destructor tobj.done; +begin +end; + +const + s : string = ' with suffix'; +var + refbefore : longint; +begin + t:='test'+s; + refbefore:=pansirec(pointer(t)-firstoff)^.ref; + writeln('refcount before init: ',pansirec(pointer(t)-firstoff)^.ref); + new(o,init(t)); + writeln('refcount after init: ',pansirec(pointer(t)-firstoff)^.ref); + dispose(o,done); + writeln('refcount after done: ',pansirec(pointer(t)-firstoff)^.ref); + if refbefore<>pansirec(pointer(t)-firstoff)^.ref then + Halt(1); +end. diff --git a/tests/tbs/tb258.pp b/tests/tbs/tb258.pp new file mode 100644 index 0000000000..74705e7f49 --- /dev/null +++ b/tests/tbs/tb258.pp @@ -0,0 +1,31 @@ +{ Old file: tbs0293.pp } +{ no error with variable name = type name } + +program bug0293; + +{$ifdef fpc}{$mode objfpc}{$endif} + +TYPE Ttype = class + field :LONGINT; + CONSTRUCTOR DOSOMETHING; + END; + +CONSTRUCTOR TTYPE.DOSOMETHING; +BEGIN +END; + +var + longint : longint; + +procedure p; +VAR + TTYPE : TTYPE; +BEGIn + ttype:=ttype.dosomething; +END; + +begin + p; +end. + + diff --git a/tests/tbs/tb259.pp b/tests/tbs/tb259.pp new file mode 100644 index 0000000000..03573d6b4b --- /dev/null +++ b/tests/tbs/tb259.pp @@ -0,0 +1,42 @@ +{ Old file: tbs0294.pp } +{ parameter with the same name as function is allowed in tp7/delphi Yes, but in BP this leads to being unable to set the return value ! } + +{$mode tp} +{ this is allowed in BP !!! + but its complete nonsense because + this code sets parameter test + so the return value can not be set at all !!!!! + of course in Delphi you can use result so there it + makes sense to allow this ! PM } +function test(var test:longint):longint; +var + x : longint; +begin + { in BP the arg is change here !! } + test:=1; + x:=3; +end; + +function st(var st : string) : string; +begin + st:='OK'; +end; + +var t : longint; + myst : string; +begin + t:=2; + myst:='Before'; + test(t); + st(myst); + if (t<>1) then + begin + writeln('Test arg in Test function is not handled like in BP'); + halt(1); + end; + if (myst<>'OK') then + begin + writeln('St arg in St string function is not handled like in BP'); + halt(1); + end; +end. diff --git a/tests/tbs/tb26.pp b/tests/tbs/tb26.pp new file mode 100644 index 0000000000..56765c3eb1 --- /dev/null +++ b/tests/tbs/tb26.pp @@ -0,0 +1,23 @@ +{ Old file: tbs0029.pp } +{ tests typeof(object type) OK 0.99.1 (FK) } + +type + TA = object + constructor init; + procedure test;virtual; + end; + + constructor TA.init; + begin + end; + + procedure TA.test; + begin + end; + +var + P: Pointer; + +begin + P := pointer(TypeOf(TA)); +end. diff --git a/tests/tbs/tb260.pp b/tests/tbs/tb260.pp new file mode 100644 index 0000000000..09cdacd997 --- /dev/null +++ b/tests/tbs/tb260.pp @@ -0,0 +1,21 @@ +{ Old file: tbs0295.pp } +{ forward type definition is resolved wrong OK 0.99.13 (PFV) } + +type + t1=longint; + +procedure p; +type + pt1=^t1; + t1=string; +var + t : t1; + p : pt1; +begin + p:=@t; + p^:='test'; +end; + +begin + p; +end. diff --git a/tests/tbs/tb261.pp b/tests/tbs/tb261.pp new file mode 100644 index 0000000000..30d6b98b2b --- /dev/null +++ b/tests/tbs/tb261.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0296.pp } +{ exit(string) does not work (web form bugs 613) OK 0.99.13 (PM) } + + +function test : string; + + begin + test:='This should not be printed'; + exit('this should be printed'); + end; + +begin + writeln(test); + if test<>'this should be printed' then + Halt(1); +end. diff --git a/tests/tbs/tb262.pp b/tests/tbs/tb262.pp new file mode 100644 index 0000000000..71d5bf02f1 --- /dev/null +++ b/tests/tbs/tb262.pp @@ -0,0 +1,17 @@ +{ Old file: tbs0297.pp } +{ calling of interrupt procedure allowed but wrong code generated OK 0.99.13 (PM) } + +program test_int; + +{$ifdef go32v2} + uses + dpmiexcp; +{$endif go32v2} + +procedure int;interrupt; +begin +end; + +begin + int; +end. diff --git a/tests/tbs/tb263.pp b/tests/tbs/tb263.pp new file mode 100644 index 0000000000..09205f4b54 --- /dev/null +++ b/tests/tbs/tb263.pp @@ -0,0 +1,33 @@ +{ Old file: tbs0299.pp } +{ passing Array[0..1] of char by value to proc leads to problems OK 0.99.13 (PM) +passing Array[0..1] of char by value to proc leads to problems } + +type + TwoChar = Array[0..1] of char; + Empty = Record + End; +const + asd : TwoChar = ('a','b'); + +procedure Tester(i:TwoChar; a: Empty;l : longint;var ll : longint); +begin + i[0]:=i[1]; + Writeln('l = ',l,' @l = ',hexstr(longint(@l),8),' @a = ',hexstr(longint(@a),8)); + inc(ll); +end; + +var + a : Empty; + l,ll : longint; +begin + l:=6; + ll:=15; + Writeln(Sizeof(asd)); + Tester(asd,a,l,ll); + Writeln(asd); + if (ll<>16) then + Begin + Writeln('Error with passing value parameter of type array [1..2] of char'); + Halt(1); + end; +end. diff --git a/tests/tbs/tb264.pp b/tests/tbs/tb264.pp new file mode 100644 index 0000000000..1f540903fc --- /dev/null +++ b/tests/tbs/tb264.pp @@ -0,0 +1,22 @@ +{ Old file: tbs0302.pp } +{ inherited property generates wrong assembler OK 0.99.13 (PFV) } + +{$ifdef fpc}{$mode objfpc}{$endif} +type + c1=class + Ffont : longint; + property Font:longint read Ffont; + end; + + c2=class(c1) + function GetFont:longint; + end; + +function c2.GetFont:longint; +begin + result:=Font; + result:=inherited Font; +end; + +begin +end. diff --git a/tests/tbs/tb265.pp b/tests/tbs/tb265.pp new file mode 100644 index 0000000000..c1287e61ed --- /dev/null +++ b/tests/tbs/tb265.pp @@ -0,0 +1,24 @@ +{ Old file: tbs0303.pp } +{ One more InternalError(10) out of register ! OK 0.99.13 (FK) } + + + type + intarray = array[1..1000,0..1] of longint; + + procedure test; + var + ar : intarray; + i : longint; + procedure local; + begin + i:=4; + ar[i,0]:=56; + ar[i-1,0]:=pred(ar[i,0]); + end; + begin + local; + end; + +begin + test; +end. diff --git a/tests/tbs/tb266.pp b/tests/tbs/tb266.pp new file mode 100644 index 0000000000..54f615d607 --- /dev/null +++ b/tests/tbs/tb266.pp @@ -0,0 +1,22 @@ +{ Old file: tbs0304.pp } +{ Label redefined when inlining assembler OK 0.99.13 (PFV) } + +{$asmmode intel} +{$inline on} + +var + cb : word; + +procedure A(B: word); assembler; inline; +asm + MOV AX,B + CMP AX,[CB] + JZ @@10 + MOV [CB],AX +@@10: +end; + +begin + a(1); + a(2); +end. \ No newline at end of file diff --git a/tests/tbs/tb267.pp b/tests/tbs/tb267.pp new file mode 100644 index 0000000000..88a149207e --- /dev/null +++ b/tests/tbs/tb267.pp @@ -0,0 +1,31 @@ +{ Old file: tbs0305.pp } +{ Finally is not handled correctly after inputting 0 } + +{$mode objfpc} +uses +(* sysutils does not work correctly with DPMIEXCP unit + anyway, its not needed anymore + since the exception handler is now in system unit +{$ifdef go32v2} +dpmiexcp, +{$endif} *) +sysutils; +var i,j,k:real; +const except_called : boolean = false; +begin + i:=100; + j:=0; + try + k:=i/j; + writeln(k:5:3); + except + k:=0; + writeln('Illegal Input'); + except_called:=true; + end; + if not except_called then + begin + Writeln('Error in except handling'); + Halt(1); + end; +end. \ No newline at end of file diff --git a/tests/tbs/tb268.pp b/tests/tbs/tb268.pp new file mode 100644 index 0000000000..93382f6fa5 --- /dev/null +++ b/tests/tbs/tb268.pp @@ -0,0 +1,50 @@ +{ %RESULT=217 } + +{ Old file: tbs0306.pp } +{ Address is not popped with exit in try...except block OK 0.99.13 (PFV) } + +{$MODE objfpc} +{$H+} + +{ + Don't forget break,continue support +} + +program stackcrash; +uses sysutils; +type + TMyClass = class + public + procedure Proc1; + procedure Proc2; + end; + +procedure TMyClass.Proc1; +var + x, y: Integer; +begin + try + exit; + except + on e: Exception do begin e.Message := '[Proc1]' + e.Message; raise e end; + end; +end; + +procedure TMyClass.Proc2; +var + x: array[0..7] of Byte; + crash: Boolean; +begin + crash := True; // <--- ! This corrupts the stack?!? + raise Exception.Create('I will crash now...'); +end; + +var + obj: TMyClass; +begin + obj := TMyClass.Create; + obj.Proc1; + WriteLn('Proc1 done, calling Proc2...'); + obj.Proc2; + WriteLn('Proc2 done'); +end. diff --git a/tests/tbs/tb269.pp b/tests/tbs/tb269.pp new file mode 100644 index 0000000000..981b661141 --- /dev/null +++ b/tests/tbs/tb269.pp @@ -0,0 +1,36 @@ +{ Old file: tbs0307.pp } +{ "with object_type" doesn't work correctly! OK 0.99.13 (?) } + +type + tobj = object + l: longint; + constructor init; + procedure setV(v: longint); + destructor done; + end; + +constructor tobj.init; +begin + l := 0; +end; + +procedure tobj.setV(v: longint); +begin + l := v; +end; + +destructor tobj.done; +begin +end; + +var t: tobj; + +begin + t.init; + with t do + setV(5); + writeln(t.l, ' (should be 5!)'); + if t.L<>5 then + Halt(1); + t.done; +end. diff --git a/tests/tbs/tb27.pp b/tests/tbs/tb27.pp new file mode 100644 index 0000000000..389e80e45a --- /dev/null +++ b/tests/tbs/tb27.pp @@ -0,0 +1,9 @@ +{ Old file: tbs0030.pp } +{ tests type conversations in typed consts OK 0.9.6 } + +const + a : array[0..1] of real = (1,1); + +begin +end. + diff --git a/tests/tbs/tb270.pp b/tests/tbs/tb270.pp new file mode 100644 index 0000000000..fba864c961 --- /dev/null +++ b/tests/tbs/tb270.pp @@ -0,0 +1,8 @@ +{ Old file: tbs0308.pp } +{ } + +uses tbs0308a; + +begin + writeln(coursedb.name(60)); +end. diff --git a/tests/tbs/tb271.pp b/tests/tbs/tb271.pp new file mode 100644 index 0000000000..d9bc92a924 --- /dev/null +++ b/tests/tbs/tb271.pp @@ -0,0 +1,29 @@ +{ Old file: tbs0308a.pp } +{ problem with objects that don't have VMT nor variable fields OK 0.99.13 (FK) } + +unit tbs0308a; + +interface + +type + tcourses = object + function index(cName: string): integer; + function name(cIndex: integer): string; + end; + +var coursedb: tcourses; + l: longint; + +implementation + +function tcourses.index(cName: string): integer; +begin + index := byte(cName[0]); +end; + +function tcourses.name(cIndex: integer): string; +begin + name := char(byte(cIndex)); +end; + +end. diff --git a/tests/tbs/tb272.pp b/tests/tbs/tb272.pp new file mode 100644 index 0000000000..a3342c0052 --- /dev/null +++ b/tests/tbs/tb272.pp @@ -0,0 +1,84 @@ +{ Old file: tbs0309.pp } +{ problem with ATT assembler written by bin writer OK 0.99.14 (PFV) } + +{ This code was first written by Florian + to test the GDB output for FPU + he thought first that FPU output was wrong + but in fact it is a bug in FPC :( } +program bug0309; + +var + a,b : double; + _as,bs : single; + al,bl : extended; + aw,bw : integer; + ai,bi : longint; + ac : comp; +begin +{$ifdef CPU86} +{$asmmode att} + asm + fninit; + end; + a:=1; + b:=2; + asm + movl $1,%eax + fldl a + fldl b + faddp %st,%st(1) + fstpl a + end; + { the above generates wrong code in binary writer + fldl is replaced by flds !! + if using -alt option to force assembler output + all works correctly PM } + writeln('a = ',a,' should be 3'); + if a<>3.0 then + Halt(1); + a:=1.0; + a:=a+b; + writeln('a = ',a,' should be 3'); + _as:=0; + al:=0; + asm + fldl a + fsts _as + fstpt al + end; + if (_as<>3.0) or (al<>3.0) then + Halt(1); + ai:=5; + bi:=5; + asm + fildl ai + fstpl a + end; + if a<>5.0 then + Halt(1); + + ac:=5; + asm + fildl ai + fstpl a + end; + if a<>5.0 then + Halt(1); + aw:=-4; + bw:=45; + asm + fildw aw + fstpl a + end; + if a<>-4.0 then + Halt(1); + ac:=345; + asm + fildq ac + fstpl a + end; + if a<>345.0 then + Halt(1); + +{$endif CPU86} +end. \ No newline at end of file diff --git a/tests/tbs/tb273.pp b/tests/tbs/tb273.pp new file mode 100644 index 0000000000..c0c7574534 --- /dev/null +++ b/tests/tbs/tb273.pp @@ -0,0 +1,147 @@ +{ Old file: tbs0312.pp } +{ Again the problem of local procs inside methods } + +{ Program that showss a problem if + Self is not reloaded in %esi register + at entry in local procedure inside method } + +uses + objects; + +type +{$ifndef FPC} + sw_integer = integer; +{$endif not FPC} + + PMYObj = ^TMyObj; + + TMyObj = Object(TObject) + x : longint; + Constructor Init(ax : longint); + procedure display;virtual; + end; + + PMYObj2 = ^TMyObj2; + + TMyObj2 = Object(TMyObj) + y : longint; + Constructor Init(ax,ay : longint); + procedure display;virtual; + end; + + PMyCollection = ^TMyCollection; + + TMyCollection = Object(TCollection) + function At(I : sw_integer) : PMyObj; + procedure DummyThatShouldNotBeCalled;virtual; + end; + + { TMy is also a TCollection so that + ShowMy and DummyThatShouldNotBeCalled are at same position in VMT } + TMy = Object(TCollection) + Col : PMyCollection; + MyObj : PMyObj; + ShowMyCalled : boolean; + constructor Init; + destructor Done;virtual; + procedure ShowAll; + procedure AddMyObj(x : longint); + procedure AddMyObj2(x,y : longint); + procedure ShowMy;virtual; + end; + + Constructor TMyObj.Init(ax : longint); + begin + Inherited Init; + x:=ax; + end; + + Procedure TMyObj.Display; + begin + Writeln('x = ',x); + end; + + Constructor TMyObj2.Init(ax,ay : longint); + begin + Inherited Init(ax); + y:=ay; + end; + + Procedure TMyObj2.Display; + begin + Writeln('x = ',x,' y = ',y); + end; + + Function TMyCollection.At(I : sw_integer) : PMyObj; + begin + At:=Inherited At(I); + end; + + Procedure TMyCollection.DummyThatShouldNotBeCalled; + begin + Writeln('This method should never be called'); + Abstract; + end; + + Constructor TMy.Init; + + begin + New(Col,Init(5,5)); + MyObj:=nil; + ShowMyCalled:=false; + end; + + Destructor TMy.Done; + begin + Dispose(Col,Done); + Inherited Done; + end; + + Procedure TMy.ShowAll; + + procedure ShowIt(P : pointer);{$ifdef TP}far;{$endif} + begin + ShowMy; + PMyObj(P)^.Display; + end; + begin + Col^.ForEach(@ShowIt); + end; + + Procedure TMy.ShowMy; + begin + if assigned(MyObj) then + MyObj^.Display; + ShowMyCalled:=true; + end; + + Procedure TMy.AddMyObj(x : longint); + + begin + MyObj:=New(PMyObj,Init(x)); + Col^.Insert(MyObj); + end; + + Procedure TMy.AddMyObj2(x,y : longint); + begin + MyObj:=New(PMyObj2,Init(x,y)); + Col^.Insert(MyObj); + end; + +var + My : TMy; +begin + My.Init; + My.AddMyObj(5); + My.AddMyObj2(4,3); + My.AddMyObj(43); + { MyObj field is now a PMyObj with value 43 } + My.ShowAll; + If not My.ShowMyCalled then + begin + Writeln('ShowAll does not work correctly'); + Halt(1); + end; + My.Done; + +end. \ No newline at end of file diff --git a/tests/tbs/tb274.pp b/tests/tbs/tb274.pp new file mode 100644 index 0000000000..8af9c686fd --- /dev/null +++ b/tests/tbs/tb274.pp @@ -0,0 +1,27 @@ +{ Old file: tbs0313.pp } +{ } + + {$asmmode intel} + TYPE + TPoint3 = RECORD + x,y,z:Single; + END; + + OPERATOR + (CONST p1,p2:TPoint3) p : TPoint3; Assembler; + ASM + mov EBX,[p1] + mov EDI,[p2] + mov EDX,[p] + movq MM0,[EBX] + pfadd MM0,[EDI] + movq [EDX],MM0 + { Now the correct way would be something like: } + movd MM0,[EBX+8] // [movd reg??,mem?? - invalid combination of opcod + movd MM1,[EDI+8] // and here, too + pfadd MM0,MM1 + movd [EDX+8],MM0 // and here + femms + END; + +begin +end. diff --git a/tests/tbs/tb275.pp b/tests/tbs/tb275.pp new file mode 100644 index 0000000000..cb2ae4c663 --- /dev/null +++ b/tests/tbs/tb275.pp @@ -0,0 +1,23 @@ +{ Old file: tbs0316.pp } +{ } + +{$asmmode intel} + +procedure test(b : longint); assembler; +type + splitlong = packed record b1, b2, b3, b4 : Byte; end; +asm + mov splitlong(b).b2, al +end; + +{$asmmode att} + +procedure test2(b : longint); assembler; +type + splitlong = packed record b1, b2, b3, b4 : Byte; end; +asm + movb splitlong(b).b2, %al +end; + +begin +end. diff --git a/tests/tbs/tb276.pp b/tests/tbs/tb276.pp new file mode 100644 index 0000000000..621fce29ba --- /dev/null +++ b/tests/tbs/tb276.pp @@ -0,0 +1,10 @@ +{ %OPT= -Sen } + +{ Old file: tbs0317.pp } + +{ This shouldn't give a warning, because it can be used in an other program } +var + exportedc : longint;cvar;public; +begin + exportedc:=0; +end. diff --git a/tests/tbs/tb277.pp b/tests/tbs/tb277.pp new file mode 100644 index 0000000000..82319780c9 --- /dev/null +++ b/tests/tbs/tb277.pp @@ -0,0 +1,15 @@ +{ %OPT=-Sen } +{ %RESULT=217 } + +{ Old file: tbs0318.pp } + +{$mode objfpc} +uses sysutils; + +{ The exception is used in the raise statement, so no Note should be thrown } +var + e : exception; +begin + e:=exception.create('test'); + raise e; +end. diff --git a/tests/tbs/tb278.pp b/tests/tbs/tb278.pp new file mode 100644 index 0000000000..fc3668bf96 --- /dev/null +++ b/tests/tbs/tb278.pp @@ -0,0 +1,69 @@ +{ Old file: tbs0319.pp } +{ } + +{$ifdef fpc}{$mode delphi}{$endif} + +function a:longint; +var + a : longint; +begin + a:=1; +end; + +type + cl=class + k : longint; + procedure p1; + procedure p2; + end; + + o = class + nonsense :string; + procedure flup(nonsense:string); + end; + + o2 = class + nonsense :string; + procedure flop; + procedure flup(nonsense:longint); + procedure flup2(flop:longint); + end; + +procedure o.flup(nonsense:string); +begin +end; + +procedure o2.flop; +begin +end; + +procedure o2.flup(nonsense:longint); +var + l : longint; +begin + l:=nonsense; +end; + +procedure o2.flup2(flop:longint); +var + l : longint; +begin + l:=flop; + flup(flop); +end; + + +procedure cl.p1; +var + k : longint; +begin +end; + +procedure cl.p2; +var + p1 : longint; +begin +end; + +begin +end. diff --git a/tests/tbs/tb279.pp b/tests/tbs/tb279.pp new file mode 100644 index 0000000000..86835b8fa4 --- /dev/null +++ b/tests/tbs/tb279.pp @@ -0,0 +1,9 @@ +{ Old file: tbs0321.pp } +{ } + +{$mode delphi} +type + tfunc = function : longint stdcall; + +begin +end. diff --git a/tests/tbs/tb28.pp b/tests/tbs/tb28.pp new file mode 100644 index 0000000000..212f9c4bca --- /dev/null +++ b/tests/tbs/tb28.pp @@ -0,0 +1,11 @@ +{ Old file: tbs0031.pp } +{ tests array[boolean] of .... OK 0.9.8 } + +var + a : array[boolean] of longint; + +begin + a[true]:=1234; + a[false]:=123; +end. + diff --git a/tests/tbs/tb280.pp b/tests/tbs/tb280.pp new file mode 100644 index 0000000000..a8347114d0 --- /dev/null +++ b/tests/tbs/tb280.pp @@ -0,0 +1,27 @@ +{ Old file: tbs0322.pp } +{ } + +{$ifdef fpc}{$asmmode intel}{$endif} +var + boxes : record + pbox : longint; + pbox2 : longint; + end; +var + s1,s2 : longint; +begin +asm + mov s1,type boxes.pbox + mov s2,type boxes +end; + if s1<>sizeof(boxes.pbox) then + begin + writeln('Wrong size for TYPE'); + halt(1); + end; + if s2<>sizeof(boxes) then + begin + writeln('Wrong size for TYPE'); + halt(1); + end; +end. \ No newline at end of file diff --git a/tests/tbs/tb281.pp b/tests/tbs/tb281.pp new file mode 100644 index 0000000000..91ae66d798 --- /dev/null +++ b/tests/tbs/tb281.pp @@ -0,0 +1,55 @@ +{ Old file: tbs0327.pp } +{ } + +{$ifdef fpc}{$mode delphi}{$endif} +unit tbs0327; +interface + +type + tc=class + procedure l(i:integer);overload; + procedure l(s:string);overload; + end; + + procedure l2(i:integer);overload; + procedure l2(s:string);overload; + +implementation + + procedure l3(i:integer);forward;overload; + procedure l3(s:string);forward;overload; + +procedure tc.l(i:integer); +begin +end; + +procedure tc.l(s:string); +begin +end; + +procedure l2(i:integer); +begin +end; + +procedure l2(s:string); +begin +end; + +procedure l3(i:integer);overload; +begin +end; + +procedure l3(s:string); +begin +end; + +procedure k(l:longint);overload; +begin +end; + +procedure k(l:string);overload; +begin +end; + +begin +end. diff --git a/tests/tbs/tb282.pp b/tests/tbs/tb282.pp new file mode 100644 index 0000000000..4e18f06f01 --- /dev/null +++ b/tests/tbs/tb282.pp @@ -0,0 +1,64 @@ +{ Old file: tbs0329.pp } +{ } + +{$packrecords c} + +type + SHORT=smallint; + WINBOOL = longbool; + WCHAR=word; + UINT=cardinal; + + COORD = record + X : SHORT; + Y : SHORT; + end; + + KEY_EVENT_RECORD = packed record + bKeyDown : WINBOOL; + wRepeatCount : WORD; + wVirtualKeyCode : WORD; + wVirtualScanCode : WORD; + case longint of + 0 : ( UnicodeChar : WCHAR; + dwControlKeyState : DWORD; ); + 1 : ( AsciiChar : CHAR ); + end; + + MOUSE_EVENT_RECORD = record + dwMousePosition : COORD; + dwButtonState : DWORD; + dwControlKeyState : DWORD; + dwEventFlags : DWORD; + end; + + WINDOW_BUFFER_SIZE_RECORD = record + dwSize : COORD; + end; + + MENU_EVENT_RECORD = record + dwCommandId : UINT; + end; + + FOCUS_EVENT_RECORD = record + bSetFocus : WINBOOL; + end; + + INPUT_RECORD = record + EventType : WORD; + case longint of + 0 : ( KeyEvent : KEY_EVENT_RECORD ); + 1 : ( MouseEvent : MOUSE_EVENT_RECORD ); + 2 : ( WindowBufferSizeEvent : WINDOW_BUFFER_SIZE_RECORD ); + 3 : ( MenuEvent : MENU_EVENT_RECORD ); + 4 : ( FocusEvent : FOCUS_EVENT_RECORD ); + end; + +begin + if sizeof(INPUT_RECORD)<>20 then + begin + writeln('Wrong packing for Packrecords C and union ',sizeof(INPUT_RECORD),' instead of ',20); + halt(1); + end; +end. + diff --git a/tests/tbs/tb283.pp b/tests/tbs/tb283.pp new file mode 100644 index 0000000000..e84b57a964 --- /dev/null +++ b/tests/tbs/tb283.pp @@ -0,0 +1,29 @@ +{ Old file: tbs0330.pp } +{ } + +{$ifdef fpc}{$mode objfpc}{$endif} +uses + Classes; + +type + TMyClass = class(TPersistent); + +var + MyVar: Integer; + + +type + TMyClass2 = class(TObject) + procedure MyProc; + end; + + TMyOtherClass = class(TPersistent); + +procedure TMyClass2.MyProc; +var + MyImportantVar: Integer; +begin +end; + +begin +end. diff --git a/tests/tbs/tb284.pp b/tests/tbs/tb284.pp new file mode 100644 index 0000000000..ea8b12b39f --- /dev/null +++ b/tests/tbs/tb284.pp @@ -0,0 +1,18 @@ +{ Old file: tbs0331.pp } +{ } + +{$mode tp} +unit tbs0331; + + interface + + procedure a(s : string); + + implementation + + procedure a; + + begin + end; + +end. diff --git a/tests/tbs/tb285.pp b/tests/tbs/tb285.pp new file mode 100644 index 0000000000..a9e12a7158 --- /dev/null +++ b/tests/tbs/tb285.pp @@ -0,0 +1,14 @@ +{ Old file: tbs0332.pp } +{ } + +{$MODE objfpc} +uses Classes; +var + o: TComponent; + begin + o := TComponent(TComponent.NewInstance); + o.Create(nil); + o.Free; + end. + + diff --git a/tests/tbs/tb286.pp b/tests/tbs/tb286.pp new file mode 100644 index 0000000000..34d07c2080 --- /dev/null +++ b/tests/tbs/tb286.pp @@ -0,0 +1,19 @@ +{ Old file: tbs0333.pp } +{ } + +var + a,b : comp; + s1,s2 : string; +begin + a:=11384563; + b:=a*a; + str(a*a:0:0,s1); + str(b:0:0,s2); + writeln(s1); + writeln(s2); + if (s1<>'129608274700969') or (s2<>'129608274700969') then + begin + writeln('Error with comp type rounding'); + halt(1); + end; +end. diff --git a/tests/tbs/tb287.pp b/tests/tbs/tb287.pp new file mode 100644 index 0000000000..fd91b7f07b --- /dev/null +++ b/tests/tbs/tb287.pp @@ -0,0 +1,25 @@ +{ Old file: tbs0334.pp } +{ } + +{$ifdef fpc}{$mode objfpc}{$endif} + +type + tvarrec=record + vpointer : pointer; + end; +var + r : tvarrec; + b : boolean; +function Next: TVarRec; +begin + next:=r; +end; + +begin + r.vpointer:=@b; + { The result of next is loaded and a value is assigned } + with Next do + boolean(VPointer^) := true; + if not b then + writeln('Error with assigning to function result'); +end. diff --git a/tests/tbs/tb288.pp b/tests/tbs/tb288.pp new file mode 100644 index 0000000000..7ecb2216f9 --- /dev/null +++ b/tests/tbs/tb288.pp @@ -0,0 +1,10 @@ +{ Old file: tbs0335.pp } +{ } + +{$mode delphi} +procedure f;stdcall export; +asm +end; + +begin +end. \ No newline at end of file diff --git a/tests/tbs/tb289.pp b/tests/tbs/tb289.pp new file mode 100644 index 0000000000..05ddaadfdd --- /dev/null +++ b/tests/tbs/tb289.pp @@ -0,0 +1,48 @@ +{ Old file: tbs0336.pp } +{ } + +{$mode objfpc} +Uses classes,sysutils; + + +const dsmerged=0; + dsopenerror=1; + dscreateerror=2; + dsconverterror=3; + dsmismatcherror=4; + dscrcerror=5; + dserror=6; + +type tvsmergediffs=class + procedure execute; + end; + + tvsdiffitem= class + status : longint; + end; + +EMismatchedDiffError =class(exception); +EDiffCrcCompareError= class(exception); + +procedure TvsMergeDiffs.Execute; +var + Stream: tFileStream; + Item: TvsDiffItem; + a : longint; +begin + try + Item.Status := dsMerged; + except + { Only the number of on xx do statements seems to matter, not + which ones, try commenting 3 or 4 out} + on EFOpenError do Item.Status := dsOpenError; + on EFCreateError do Item.Status := dsCreateError; + on EConvertError do Item.Status := dsConvertError; + on EMismatchedDiffError do Item.Status := dsMismatchError; + on EDiffCrcCompareError do Item.Status := dsCrcError; + on Exception do Item.Status := dsError; + end; +end; + +begin +end. \ No newline at end of file diff --git a/tests/tbs/tb29.pp b/tests/tbs/tb29.pp new file mode 100644 index 0000000000..51fd2d5cc9 --- /dev/null +++ b/tests/tbs/tb29.pp @@ -0,0 +1,15 @@ +{ Old file: tbs0032.pp } +{ tests for a bugs with the stack OK 0.9.9 } + +var + p : procedure(w : word); + + procedure pp(w :word); + begin + Writeln(w); + end; + +begin + p:=@pp; + p(1234); +end. diff --git a/tests/tbs/tb290.pp b/tests/tbs/tb290.pp new file mode 100644 index 0000000000..f24d8707cb --- /dev/null +++ b/tests/tbs/tb290.pp @@ -0,0 +1,32 @@ +{ Old file: tbs0337.pp } +{ } + +program vartest; + +{$ifdef fpc}{$mode objfpc}{$endif} + +uses + Classes; + +type + TMyComponent = class(TComponent) + aaaaaaaaaa: TComponent; + b: TComponent; + private + public + constructor Create(AOwner: TComponent); override; + end; + + +constructor TMyComponent.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + aaaaaaaaaa := TComponent.Create(Self); +end; + +var + MyComponent: TMyComponent; + +begin + MyComponent := TMyComponent.Create(nil); +end. diff --git a/tests/tbs/tb291.pp b/tests/tbs/tb291.pp new file mode 100644 index 0000000000..e7756e30a7 --- /dev/null +++ b/tests/tbs/tb291.pp @@ -0,0 +1,13 @@ +{ Old file: tbs0338.pp } +{ } + +{$mode delphi} + +{$define skip} + +begin + writeln('Hello world!'); +{$ifndef skip} + write('}'); +{$endif skip} +end. diff --git a/tests/tbs/tb292.pp b/tests/tbs/tb292.pp new file mode 100644 index 0000000000..b4e88712b4 --- /dev/null +++ b/tests/tbs/tb292.pp @@ -0,0 +1,23 @@ +{ %OPT=-Sen } + +{ Old file: tbs0339.pp } + +type + rec=record + x,y : longint; + end; +var + r : array[1..10] of rec; + i : longint; +begin + i:=1; + with r[i] do + begin + x:=1; + y:=1; + end; + with r[i] do + begin + writeln(x,y); + end; +end. diff --git a/tests/tbs/tb293.pp b/tests/tbs/tb293.pp new file mode 100644 index 0000000000..bd26791e89 --- /dev/null +++ b/tests/tbs/tb293.pp @@ -0,0 +1,23 @@ +{ Old file: tbs0340.pp } +{ } + +{$packenum 1} +type + t = (a,b,c,d,e); + +const arr: array[0..4] of t = (a,b,c,d,e); + +var + x: byte; + +begin + x := 0; + writeln(ord(arr[x]),' ',ord(arr[x+1]),' ',ord(arr[x+2]),' ',ord(arr[x+3]),' ',ord(arr[x+4])); + for x:=0 to 4 do + if ord(arr[x])<>x then + begin + writeln('error in {$packenum 1}'); + halt(1); + end; +end. + diff --git a/tests/tbs/tb294.pp b/tests/tbs/tb294.pp new file mode 100644 index 0000000000..ecf663470e --- /dev/null +++ b/tests/tbs/tb294.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0341.pp } +{ } + +procedure IncLimit(var B: Byte; const Limit: Byte; const Incr: Byte); +begin +end; +procedure IncLimit(var B: Longint; const Limit: Longint; const Incr: Longint); +begin +end; + +var + b : byte; +begin + inclimit(b,128,3); +end. + diff --git a/tests/tbs/tb295.pp b/tests/tbs/tb295.pp new file mode 100644 index 0000000000..69ea5dc291 --- /dev/null +++ b/tests/tbs/tb295.pp @@ -0,0 +1,9 @@ +{ Old file: tbs0344.pp } +{ } + +var + r : record + word : array[1..2] of word; + end; +begin +end. diff --git a/tests/tbs/tb296.pp b/tests/tbs/tb296.pp new file mode 100644 index 0000000000..07df6ad3c3 --- /dev/null +++ b/tests/tbs/tb296.pp @@ -0,0 +1,12 @@ +{ Old file: tbs0346a.pp } +{ } + +unit tbs0346a; +interface + +type + word = system.word; + +implementation + +end. diff --git a/tests/tbs/tb297.pp b/tests/tbs/tb297.pp new file mode 100644 index 0000000000..526fb25a1d --- /dev/null +++ b/tests/tbs/tb297.pp @@ -0,0 +1,19 @@ +{ Old file: tbs0346b.pp } +{ } + +unit tbs0346b; +interface + +{ this uses system.word } +procedure p(w:word); + +implementation +uses + tbs0346a; + +{ this uses tbs0346a.word } +procedure p(w:word); +begin +end; + +end. diff --git a/tests/tbs/tb298.pp b/tests/tbs/tb298.pp new file mode 100644 index 0000000000..b4c16fc500 --- /dev/null +++ b/tests/tbs/tb298.pp @@ -0,0 +1,15 @@ +{ Old file: tbs0348.pp } +{ } + +{$mode delphi} + +type fluparr=array[0..1000] of longint; + flupptr=^fluparr; + +var flup : Flupptr; + Flupresult : longint; + flupa : fluparr; +begin + flup:=@flupa; + flupresult:=flup[5]; +end. diff --git a/tests/tbs/tb299.pp b/tests/tbs/tb299.pp new file mode 100644 index 0000000000..c50eff3af3 --- /dev/null +++ b/tests/tbs/tb299.pp @@ -0,0 +1,11 @@ +{ Old file: tbs0350.pp } +{ } + +var + c : char; + i : integer; +begin + i:=integer(c); + c:=char(i); +end. + diff --git a/tests/tbs/tb3.pp b/tests/tbs/tb3.pp new file mode 100644 index 0000000000..ce7a1ee882 --- /dev/null +++ b/tests/tbs/tb3.pp @@ -0,0 +1,21 @@ +{ Old file: tbs0003.pp } +{ dito OK 0.9.2 } + +unit tbs0003; + + interface + + implementation + + + procedure dump_stack(bp : longint); + + function get_next_frame(bp : longint) : longint; + + begin + end; + + begin + end; + +end. diff --git a/tests/tbs/tb30.pp b/tests/tbs/tb30.pp new file mode 100644 index 0000000000..e3e9b0ecda --- /dev/null +++ b/tests/tbs/tb30.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0033.pp } +{ tests var p : pchar; begin p:='c'; end. OK 0.9.9 } + +var + p1 : pchar; + p2 : array[0..10] of char; + s : string; + c : char; + +begin + p1:='c'; + s:='c'; + { this isn't allowed + p1:=c; + } +end. diff --git a/tests/tbs/tb300.pp b/tests/tbs/tb300.pp new file mode 100644 index 0000000000..f957255c60 --- /dev/null +++ b/tests/tbs/tb300.pp @@ -0,0 +1,26 @@ +{ Old file: tbs0353.pp } +{ } + +Var + I : Int64; + j : longint; + K : Int64; + err : boolean; +begin + I:=2; + Writeln(i); + K:=1 shl 62; + For j:=1 to 61 do + begin + I:=I*2; + If I/k*100>100 then + begin + Writeln('Error'); + err:=true; + end + else + Writeln(j:2,': ',i:20,' ',i div 1024:20,' ',(i/k*100):4:1); + end; + if err then + halt(1); +end. diff --git a/tests/tbs/tb301.pp b/tests/tbs/tb301.pp new file mode 100644 index 0000000000..e13f7c0bea --- /dev/null +++ b/tests/tbs/tb301.pp @@ -0,0 +1,20 @@ +{ Old file: tbs0355.pp } +{ } + +{MvdV; published in core. + Element that is in the type zz too is not recognised as such. + } + +type xx=(notinsubset1,insubset1,insubset2,notinsubset2); + zz=insubset1..insubset2; + + ll=record + yy:zz; + end; + +const oo : array[0..1] of ll = ( + (yy:insubset1), + (yy:insubset2)); +begin +end. + diff --git a/tests/tbs/tb302.pp b/tests/tbs/tb302.pp new file mode 100644 index 0000000000..2a09cf02a1 --- /dev/null +++ b/tests/tbs/tb302.pp @@ -0,0 +1,14 @@ +{ Old file: tbs0356.pp } +{ } + +unit tbs0356; +interface +uses sysutils; +type + + Foo = + packed record + Dates : array[1..11] of Date; + end; +implementation +end. diff --git a/tests/tbs/tb305.pp b/tests/tbs/tb305.pp new file mode 100644 index 0000000000..aa00b2ac20 --- /dev/null +++ b/tests/tbs/tb305.pp @@ -0,0 +1,14 @@ +unit th010018; + +interface +type + rec=object + i : longint; + nrs : (one,two,three); + end; +var + brec : rec; + +implementation + +end. \ No newline at end of file diff --git a/tests/tbs/tb306.pp b/tests/tbs/tb306.pp new file mode 100644 index 0000000000..6e37ea2a3c --- /dev/null +++ b/tests/tbs/tb306.pp @@ -0,0 +1,36 @@ +{$mode objfpc} +type + tobject1 = class + readl : longint; + function readl2 : longint; + procedure writel(ll : longint); + procedure writel2(ll : longint); + property l : longint read readl write writel; + property l2 : longint read readl2 write writel2; + end; + +procedure tobject1.writel(ll : longint); + + begin + end; + +procedure tobject1.writel2(ll : longint); + + begin + end; + +function tobject1.readl2 : longint; + + begin + end; + +var + object1 : tobject1; + i : longint; + +begin + object1:=tobject1.create; + i:=object1.l; + i:=object1.l2; + object1.l:=123; +end. \ No newline at end of file diff --git a/tests/tbs/tb307.pp b/tests/tbs/tb307.pp new file mode 100644 index 0000000000..6097f6e0d0 --- /dev/null +++ b/tests/tbs/tb307.pp @@ -0,0 +1,45 @@ +{$mode objfpc} +type + tmyclass = class of tmyobject; + + tmyobject = class + end; + +{ only a stupid test routine } +function getanchestor(c : tclass) : tclass; + + var + l : longint; + + begin + getanchestor:=tobject; + l:=l+1; + end; + +var + classref : tclass; + myclassref : tmyclass; + +const + constclassref1 : tclass = tobject; + constclassref2 : tclass = nil; + constclassref3 : tclass = tobject; + +begin + { simple test } + classref:=classref; + { more difficult } + classref:=myclassref; + classref:=tobject; + myclassref:=tmyobject; + + classref:=getanchestor(myclassref); + if (constclassref1.classname<>'TOBJECT') or + (constclassref2<>nil) or + (myclassref.classname<>'TMYOBJECT') or + (classref.classname<>'TOBJECT') then + begin + writeln('Error'); + halt(1); + end; +end. diff --git a/tests/tbs/tb308.pp b/tests/tbs/tb308.pp new file mode 100644 index 0000000000..d4c0f7cd98 --- /dev/null +++ b/tests/tbs/tb308.pp @@ -0,0 +1,204 @@ +{$Mode objfpc} + +{ + This unit introduces some basic classes as they are defined in Delphi. + These classes should be source compatible to their Delphi counterparts: + TPersistent + TComponent +} + +Unit tb308; + +{$M+} + +Interface + +Type + +{ --------------------------------------------------------------------- + Forward Declarations. + ---------------------------------------------------------------------} + + TComponent = Class; + TFiler = Class; + TPersistent = Class; + +{ --------------------------------------------------------------------- + TFiler + ---------------------------------------------------------------------} + + TFiler = Class (TObject) + Protected + FAncestor : TComponent; + FIgnoreChildren : Boolean; + FRoot : TComponent; + Private + Public + Published + { Methods } + Constructor Create {(Stream : TStream; BufSize : Longint) }; + Destructor Destroy; override; + Procedure FlushBuffer; virtual; abstract; + { Properties } + Property Root : TComponent Read FRoot Write FRoot; + Property Ancestor : TComponent Read FAncestor Write FAncestor; + Property IgnoreChildren : Boolean Read FIgnoreChildren Write FIgnoreChildren; + end; + +{ --------------------------------------------------------------------- + TPersistent + ---------------------------------------------------------------------} + + TPersistent = Class (TObject) + Private + Procedure AssignError (Source : TPersistent); + Protected + Procedure AssignTo (Dest : TPersistent); + Procedure DefineProperties (Filer : TFiler); Virtual; + Public + { Methods } + Destructor Destroy; Override; + Procedure Assign (Source : TPersistent); virtual; + Published + end; + +{ --------------------------------------------------------------------- + TComponent + ---------------------------------------------------------------------} + + TComponentState = Set of ( csLoading, csReading, CsWriting, csDestroying, + csDesigning, csAncestor, csUpdating, csFixups ); + TComponentStyle = set of ( csInheritable,csCheckPropAvail ); + TComponentName = String; + + TComponent = Class (TPersistent) + Protected + FComponentState : TComponentState; + FComponentStyle : TComponentStyle; + FName : TComponentName; + + FOwner : TComponent; + Function GetComponent (Index : Longint) : TComponent; + Function GetComponentCount : Longint; + Function GetComponentIndex : Longint; + Procedure SetComponentIndex (Value : Longint); + Procedure Setname (Value : TComponentName); + Private + Public + { Methods } + { Properties } + Property ComponentCount : Longint Read GetComponentCount; { RO } + Property ComponentIndex : Longint Read GetComponentIndex write SetComponentIndex; { R/W } + // Property Components [Index : LongInt] : TComponent Read GetComponent; { R0 } + Property ComponentState : TComponentState Read FComponentState; { RO } + Property ComponentStyle : TcomponentStyle Read FComponentStyle; { RO } + Property Owner : TComponent Read Fowner; { RO } + Published + Property Name : TComponentName Read FName Write Setname; + end; + + + + +Implementation + +{ --------------------------------------------------------------------- + TComponent + ---------------------------------------------------------------------} + +Function TComponent.GetComponent (Index : Longint) : TComponent; + +begin +end; + + + +Function TComponent.GetComponentCount : Longint; + +begin +end; + + + +Function TComponent.GetComponentIndex : Longint; + +begin +end; + + + +Procedure TComponent.SetComponentIndex (Value : Longint); + +begin +end; + + + + +Procedure TComponent.Setname (Value : TComponentName); + +begin +end; + + + +{ --------------------------------------------------------------------- + TFiler + ---------------------------------------------------------------------} + +Constructor TFiler.Create {(Stream : TStream; BufSize : Longint) }; + +begin +end; + + + + +Destructor TFiler.Destroy; + +begin +end; + + + + +{ --------------------------------------------------------------------- + TPersistent + ---------------------------------------------------------------------} + +Procedure TPersistent.AssignError (Source : TPersistent); + +begin +end; + + + +Procedure TPersistent.AssignTo (Dest : TPersistent); + +begin +end; + + + +Procedure TPersistent.DefineProperties (Filer : TFiler); + +begin +end; + + + +Destructor TPersistent.Destroy; + +begin +end; + + + +Procedure TPersistent.Assign (Source : TPersistent); + +begin +end; + + + +end. diff --git a/tests/tbs/tb309.pp b/tests/tbs/tb309.pp new file mode 100644 index 0000000000..48c05b5e4c --- /dev/null +++ b/tests/tbs/tb309.pp @@ -0,0 +1,55 @@ +uses + crt; + +begin + textcolor(blue); + writeln('blue'); + + textcolor(green); + writeln('green'); + + textcolor(cyan); + writeln('cyan'); + + textcolor(red); + writeln('red'); + + textcolor(magenta); + writeln('magenta'); + + textcolor(brown); + writeln('brown'); + + textcolor(lightgray); + writeln('lightgray'); + + textcolor(darkgray); + writeln('darkgray'); + + textcolor(lightblue); + writeln('lightblue'); + + textcolor(lightgreen); + writeln('lightgreen'); + + textcolor(lightcyan); + writeln('lightcyan'); + + textcolor(lightred); + writeln('lightred'); + + textcolor(lightmagenta); + writeln('lightmagenta'); + + textcolor(yellow); + writeln('yellow'); + + textcolor(white); + writeln('white'); + + textcolor(white+blink); + writeln('white blinking'); + + textcolor(lightgray); + writeln; +end. diff --git a/tests/tbs/tb31.pp b/tests/tbs/tb31.pp new file mode 100644 index 0000000000..275fd0e107 --- /dev/null +++ b/tests/tbs/tb31.pp @@ -0,0 +1,19 @@ +{ Old file: tbs0034.pp } +{ shows wrong line numbering when asmbler is parsed in direct mode. } + +{ line numbering problem } +{ I don't really know how to test this (PM } + var i : longint; + +begin + asm + movl %eax,%eax + movl %eax,%eax + movl %eax,%eax + movl %eax,%eax + movl %eax,%eax + movl %eax,%eax + movl %eax,%eax + end ; + i:=0; +end. diff --git a/tests/tbs/tb310.pp b/tests/tbs/tb310.pp new file mode 100644 index 0000000000..73b43a5a26 --- /dev/null +++ b/tests/tbs/tb310.pp @@ -0,0 +1,23 @@ +{$mode objfpc} + +{ tests forward class types } + +type + tclass1 = class; + + tclass2 = class + class1 : tclass1; + end; + +var + c : tclass1; + +type + tclass1 = class(tclass2) + i : longint; + end; + +begin + c:=tclass1.create; + c.i:=12; +end. diff --git a/tests/tbs/tb311.pp b/tests/tbs/tb311.pp new file mode 100644 index 0000000000..ed66bd12c5 --- /dev/null +++ b/tests/tbs/tb311.pp @@ -0,0 +1,43 @@ +{$mode objfpc} + +type + tclass1 = class + procedure a;virtual; + procedure b;virtual; + end; + + tclass2 = class(tclass1) + procedure a;override; + procedure b;override; + procedure c;virtual; + end; + + + procedure tclass1.a; + + begin + end; + + procedure tclass1.b; + + begin + end; + + procedure tclass2.a; + + begin + end; + + procedure tclass2.b; + + begin + end; + + + procedure tclass2.c; + + begin + end; + +begin +end. \ No newline at end of file diff --git a/tests/tbs/tb312.pp b/tests/tbs/tb312.pp new file mode 100644 index 0000000000..49f2d38979 --- /dev/null +++ b/tests/tbs/tb312.pp @@ -0,0 +1,13 @@ +{$ifdef win32} +library test; + + procedure exporttest;export; + + begin + end; + + exports exporttest; +{$endif} + +begin +end. diff --git a/tests/tbs/tb313.pp b/tests/tbs/tb313.pp new file mode 100644 index 0000000000..4d51718f62 --- /dev/null +++ b/tests/tbs/tb313.pp @@ -0,0 +1,47 @@ +{$mode objfpc} + +type + tobject2 = class + i : longint; + procedure y; + constructor create; + class procedure x; + class procedure v;virtual; + end; + + procedure tobject2.y; + + begin + Writeln('Procedure y called'); + end; + + class procedure tobject2.v; + + begin + end; + + class procedure tobject2.x; + + begin + v; + end; + + constructor tobject2.create; + + begin + end; + + type + tclass2 = class of tobject2; + + var + a : class of tobject2; + object2 : tobject2; + +begin + a:=tobject2; + a.x; + tobject2.x; + object2:=tobject2.create; + object2:=a.create; +end. \ No newline at end of file diff --git a/tests/tbs/tb314.pp b/tests/tbs/tb314.pp new file mode 100644 index 0000000000..941c3b9ac4 --- /dev/null +++ b/tests/tbs/tb314.pp @@ -0,0 +1,41 @@ +{$mode objfpc} + +type + tobject2 = class + constructor create; + function rname : string; + procedure wname(const s : string); + property name : string read rname write wname; + end; + + tclass2 = class of tobject2; + +var + o2 : tobject2; + c2 : tclass2; + +constructor tobject2.create; + + begin + inherited create; + end; + +procedure tobject2.wname(const s : string); + + begin + end; + +function tobject2.rname : string; + + begin + end; + +begin + o2:=tobject2.create; + o2.name:='1234'; + writeln(o2.name); + o2.destroy; + c2:=tobject2; + o2:=c2.create; + o2.destroy; +end. diff --git a/tests/tbs/tb315.pp b/tests/tbs/tb315.pp new file mode 100644 index 0000000000..378ff5d3b2 --- /dev/null +++ b/tests/tbs/tb315.pp @@ -0,0 +1,13 @@ +unit tb315; + + interface + + type + tr = record + case a : (x,y,z) of + x : (l : longint); + end; + + implementation + +end. diff --git a/tests/tbs/tb316.pp b/tests/tbs/tb316.pp new file mode 100644 index 0000000000..704663d4ac --- /dev/null +++ b/tests/tbs/tb316.pp @@ -0,0 +1,15 @@ +uses + tb315; + + var + r : tr; + + begin + r.a:=x; + if r.a=x then + begin + with r do + if a=y then + ; + end; + end. diff --git a/tests/tbs/tb317.pp b/tests/tbs/tb317.pp new file mode 100644 index 0000000000..e3dd5788bd --- /dev/null +++ b/tests/tbs/tb317.pp @@ -0,0 +1,58 @@ +{$R+} +type + ta = object + constructor init; + destructor done; + procedure p;virtual; + end; + + pa = ^ta; + +constructor ta.init; + + begin + end; + +destructor ta.done; + + begin + end; + +procedure ta.p; + + begin + end; + +type + plongint = ^longint; + +var + p : pa; + data : array[0..4] of longint; + saveexit : pointer; + + procedure testerror; + begin + exitproc:=saveexit; + if errorcode=210 then + begin + errorcode:=0; + writeln('Object valid VMT check works'); + runerror(0); + end + else + halt(1); + end; + +begin + saveexit:=exitproc; + exitproc:=@testerror; + fillchar(data,sizeof(data),12); + p:=new(pa,init); + p^.p; + { the vmt pointer gets an invalid value: } + plongint(p)^:=longint(@data); + { causes runerror } + p^.p; + halt(1); +end. diff --git a/tests/tbs/tb318.pp b/tests/tbs/tb318.pp new file mode 100644 index 0000000000..9cdfb6dae6 --- /dev/null +++ b/tests/tbs/tb318.pp @@ -0,0 +1,74 @@ +program tb318; + +Type + TRec = record + X,Y : longint; + end; + + TRecFile = File of TRec; + +var TF : TRecFile; + LF : File of longint; + i,j,k,l : longint; + t : Trec; + +begin + Write ('Writing files...'); + assign (LF,'longint.dat'); + rewrite (LF); + for i:=1 to 10 do + write (LF,i); + close (LF); + Assign (TF,'TRec.dat'); + rewrite (TF); + for i:=1 to 10 do + for j:=1 to 10 do + begin + t.x:=i; + t.y:=j; + write (TF,T); + end; + close (TF); + writeln ('Done'); + reset (LF); + reset (TF); + Write ('Sequential read test...'); + for i:=1 to 10 do + begin + read (LF,J); + if j<>i then writeln ('Read of longint failed at :',i); + end; + for i:=1 to 10 do + for j:=1 to 10 do + begin + read (tf,t); + if (t.x<>i) or (t.y<>j) then + writeln ('Read of record failed at :',i,',',j); + end; + writeln ('Done.'); + Write ('Random access read test...'); + For i:=1 to 10 do + begin + k:=random(10); + seek (lf,k); + read (lf,j); + if j<>k+1 then + Writeln ('Failed random read of longint at pos ',k,' : ',j); + end; + For i:=1 to 10 do + for j:=1 to 10 do + begin + k:=random(10); + l:=random(10); + seek (tf,k*10+l); + read (tf,t); + if (t.x<>k+1) or (t.y<>l+1) then + Writeln ('Failed random read of longint at pos ',k,',',l,' : ',t.x,',',t.y); + end; + Writeln ('Done.'); + close (lf); + close (TF); + erase (lf); + erase (tf); + +end. \ No newline at end of file diff --git a/tests/tbs/tb319.pp b/tests/tbs/tb319.pp new file mode 100644 index 0000000000..7aec067fc1 --- /dev/null +++ b/tests/tbs/tb319.pp @@ -0,0 +1,37 @@ +{ problem of conversion between + smallsets and long sets } +type + +{ Command sets } + + PCommandSet = ^TCommandSet; + TCommandSet = set of Byte; + +Const + cmValid = 0; + cmQuit = 1; + cmError = 2; + cmMenu = 3; + cmClose = 4; + cmZoom = 5; + cmResize = 6; + cmNext = 7; + cmPrev = 8; + cmHelp = 9; + +{ Application command codes } + + cmCut = 20; + cmCopy = 21; + cmPaste = 22; + cmUndo = 23; + cmClear = 24; + cmTile = 25; + cmCascade = 26; + + CurCommandSet: TCommandSet = + [0..255] - [cmZoom, cmClose, cmResize, cmNext, cmPrev]; + + + begin + end. diff --git a/tests/tbs/tb32.pp b/tests/tbs/tb32.pp new file mode 100644 index 0000000000..2b8987e95c --- /dev/null +++ b/tests/tbs/tb32.pp @@ -0,0 +1,18 @@ +{ Old file: tbs0035.pp } +{ label at end of block gives error OK 0.9.9 (FK) } + +{$goto on} + +program bug0035; + +{Discovered by Daniel Mantione.} + +label hallo; + +begin + writeln('Hello'); + begin +hallo: {Error message: Incorrect expression.} + end; + writeln('Hello again'); +end. diff --git a/tests/tbs/tb320.pp b/tests/tbs/tb320.pp new file mode 100644 index 0000000000..8c99967d9e --- /dev/null +++ b/tests/tbs/tb320.pp @@ -0,0 +1,33 @@ +{ show a problem with IOCHECK !! + inside reset(file) + we call reset(file,longint) + but we also emit a call to iocheck after and this is wrong !! PM } + +program getret; + + uses dos; + + var + ppfile : file; + +begin + assign(ppfile,'this_file_probably_does_not_exist&~"#'); +{$I-} + reset(ppfile,1); + if ioresult=0 then + begin +{$I+} + close(ppfile); + end + else + writeln('the file does not exist') ; +{$I-} + reset(ppfile); + if ioresult=0 then + begin +{$I+} + close(ppfile); + end + else + writeln('the file does not exist') ; +end. diff --git a/tests/tbs/tb321.pp b/tests/tbs/tb321.pp new file mode 100644 index 0000000000..b8f895b2ae --- /dev/null +++ b/tests/tbs/tb321.pp @@ -0,0 +1,13 @@ +uses tb321a; + +var + arec : rec; + +begin + arec.nrs:=one; + if arec.nrs<>one then + begin + Writeln('Error with enums inside objects'); + Halt(1); + end; +end. \ No newline at end of file diff --git a/tests/tbs/tb321a.pp b/tests/tbs/tb321a.pp new file mode 100644 index 0000000000..b181845546 --- /dev/null +++ b/tests/tbs/tb321a.pp @@ -0,0 +1,14 @@ +unit tb321a; + +interface +type + rec=object + i : longint; + nrs : (one,two,three); + end; +var + brec : rec; + +implementation + +end. \ No newline at end of file diff --git a/tests/tbs/tb322.pp b/tests/tbs/tb322.pp new file mode 100644 index 0000000000..7f33a31637 --- /dev/null +++ b/tests/tbs/tb322.pp @@ -0,0 +1,39 @@ + +{ this program shows a possible problem + of name mangling in FPC (PM) } + procedure test; + + function a : longint; + begin + a:=1; + end; + + begin + writeln('a = ',a); + end; + + procedure test(b : byte); + + function a : longint; + begin + a:=2; + end; + + begin + writeln('b = ',b); + writeln('a = ',a); + end; + + type a = word; + + function test_(b : a) : longint; + begin + test_:=b; + end; + +begin + test(1); + test; + test(4); +end. + diff --git a/tests/tbs/tb323.pp b/tests/tbs/tb323.pp new file mode 100644 index 0000000000..ff1c7a83af --- /dev/null +++ b/tests/tbs/tb323.pp @@ -0,0 +1,10 @@ +{ test for const string that is a char } + +const + C ='D'; + D = 'AD'; + PP : string[length(D)] = D; + P : String[length(c)] = C; + +begin +end. diff --git a/tests/tbs/tb324.pp b/tests/tbs/tb324.pp new file mode 100644 index 0000000000..e069193e11 --- /dev/null +++ b/tests/tbs/tb324.pp @@ -0,0 +1,19 @@ +{ %OPT=-g } +{ the debug info created problems for very long mangled names + because the manglednames where shorten differently (PM) + fixed in v 0.99.9 } +program ts010021; + +var i : longint; + + type very_very_very_long_integer = longint; + + function ugly(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p : + very_very_very_long_integer) : longint; + + begin + ugly:=0; + end; + +begin +end. diff --git a/tests/tbs/tb325.pp b/tests/tbs/tb325.pp new file mode 100644 index 0000000000..fc1ef924df --- /dev/null +++ b/tests/tbs/tb325.pp @@ -0,0 +1,46 @@ +program ts010022; + +const + EXCEPTIONCOUNT = 18; + exception_names : array[0..EXCEPTIONCOUNT-1] of pchar = ( + 'Division by Zero', + 'Debug', + 'NMI', + 'Breakpoint', + 'Overflow', + 'Bounds Check', + 'Invalid Opcode', + 'Coprocessor not available', + 'Double Fault', + 'Coprocessor overrun', + 'Invalid TSS', + 'Segment Not Present', + 'Stack Fault', + 'General Protection Fault', + 'Page fault', + ' ', + 'Coprocessor Error', + 'Alignment Check'); + + single_pchar : pchar = 'Alone test'; + +const filename = 'ts010022.tmp'; + +var en : pchar; + f : text; + st : string; +begin + assign(f,filename); + rewrite(f); + en:=single_pchar; + Writeln(f,en); + en:=exception_names[6]; + writeln(f,en); + close(f); + reset(f); + readln(f,st); + if st<>'Alone test' then halt(1); + readln(f,st); + if st<>'Invalid Opcode' then halt(1); + close(f); +end. \ No newline at end of file diff --git a/tests/tbs/tb326.pp b/tests/tbs/tb326.pp new file mode 100644 index 0000000000..9394da828f --- /dev/null +++ b/tests/tbs/tb326.pp @@ -0,0 +1,14 @@ +const + nl=#10; +type + cs=set of char; + +function p(c:cs):boolean; +begin + p:=(#10 in c); +end; + +begin + if p([#1..#255]-[nl]) then + halt(1); +end. \ No newline at end of file diff --git a/tests/tbs/tb327.pp b/tests/tbs/tb327.pp new file mode 100644 index 0000000000..ce82589859 --- /dev/null +++ b/tests/tbs/tb327.pp @@ -0,0 +1,34 @@ +{$asmmode att} + +const + Count=100; + +type + trec=record + a,b,c : longint; + end; + + +var + r : trec; +begin + asm + leal r,%edi + leal r,%esi + movl %es:46(%edi),%eax + movl 2+trec.b(%esi),%eax + movl $1,%ebx + movl trec.b(%esi,%ebx,(2*4)),%eax + movl r(,%ebx,(2*4)),%eax + xorl %esi,%esi + movl r.c(,%esi,(2*4)),%eax + movl Count,%eax + movl Count*100,%eax + movl trec.b+2,%eax + leal r,%esi + movl trec.b+2(%esi),%eax +{$ifdef go32v2} + movl %fs:(0x46c),%eax +{$endif} + end; +end. \ No newline at end of file diff --git a/tests/tbs/tb328.pp b/tests/tbs/tb328.pp new file mode 100644 index 0000000000..26cf01ea76 --- /dev/null +++ b/tests/tbs/tb328.pp @@ -0,0 +1,29 @@ +{$asmmode intel} + +const + Count=100; + +type + trec=record + a,b : longint; + end; + +var + r : trec; +begin + asm + xor esi,esi + mov [esi+r],eax + lea esi,r + mov [esi+2+trec.b],eax + mov trec[esi].b,eax + mov eax,trec.b+2 + mov trec[esi].b+2,eax + mov eax,Count + mov eax,Count*100 +{$ifdef go32v2} + mov fs:[0468+trec.b],eax + mov fs:[046ch],eax +{$endif} + end; +end. \ No newline at end of file diff --git a/tests/tbs/tb329.pp b/tests/tbs/tb329.pp new file mode 100644 index 0000000000..04136f33d8 --- /dev/null +++ b/tests/tbs/tb329.pp @@ -0,0 +1,45 @@ +{ this test program test allocation of large pieces of stack } +{ this is especially necessary for win32 } + +procedure p1(a : array of byte); + + var + i : longint; + + begin + for i:=0 to high(a) do + a[i]:=0; + end; + +procedure p2; + + var + a : array[0..20000] of byte; + i : longint; + + begin + for i:=0 to high(a) do + a[i]:=0; + end; + +procedure p3; + + var + a : array[0..200000] of byte; + i : longint; + + begin + for i:=0 to high(a) do + a[i]:=0; + end; + + +var + a : array[0..10000] of byte; + +begin + p1(a); + p2; + p3; +end. + diff --git a/tests/tbs/tb33.pp b/tests/tbs/tb33.pp new file mode 100644 index 0000000000..4b2ab3a7bc --- /dev/null +++ b/tests/tbs/tb33.pp @@ -0,0 +1,52 @@ +{ Old file: tbs0037.pp } +{ tests missing graph.setgraphmode OK RTL (FK) } + +{$ifdef go32v2} +{$define OK} +{$endif} +{$ifdef linux} +{$define OK} +{$endif} +{$ifdef win32} +{$define OK} +{$endif} + +{$ifdef OK} +uses + graph, + crt; + +var + gd,gm,res : integer; +{$endif OK} + +begin +{$ifdef OK} + gd:=detect; + initgraph(gd,gm,''); + res := graphresult; + if res <> grOk then + begin + graphErrorMsg(res); + halt(1); + end; + setviewport(0,0,getmaxx,getmaxy,clipon); + line(1,1,100,100); + {readkey;} + setgraphmode(m1024x768); + setviewport(0,0,getmaxx,getmaxy,clipon); + res := graphresult; + if res <> grOk then + begin + closegraph; + graphErrorMsg(res); + { no error, graph mode is simply not supported } + halt(0); + end; + line(100,100,1024,800); + {readkey;} + delay(1000); + closegraph; +{$endif OK} +end. + diff --git a/tests/tbs/tb330.pp b/tests/tbs/tb330.pp new file mode 100644 index 0000000000..c89308f006 --- /dev/null +++ b/tests/tbs/tb330.pp @@ -0,0 +1,25 @@ +{$IFDEF FPC} +{$ASMMODE INTEL} +{$ENDIF} +{$N+} + +FUNCTION Floor(M2:Comp):LONGINT;assembler; + +VAR X : COMP; + X2 : LONGINT; + X3 : Double; + s : single; + +ASM + FLD QWord Ptr X // Here S_IL must be changed to + // S_FL, i.e. the compiler must generate + // fldl "X" instead of fldq "X" which is wrong + fld X2 // No mem64, so no problem + FLD QWord Ptr X3 // This one goes wrong under AS + FilD QWord Ptr X // This one translates to fildq and is accepted? + fild X2 // No mem64, so no problem + FiLD QWord Ptr X3 // This one translates to fildq and is accepted? +end; + +BEGIN +END. diff --git a/tests/tbs/tb331.pp b/tests/tbs/tb331.pp new file mode 100644 index 0000000000..c853d5e5b5 --- /dev/null +++ b/tests/tbs/tb331.pp @@ -0,0 +1,13 @@ +// checks type cast of nil in const statement + type + THandle = longint; + WSAEVENT = THandle; + const + WSA_INVALID_EVENT = WSAEVENT(nil); + + var + l : longint; + +begin + l:=WSA_INVALID_EVENT*1; +end. diff --git a/tests/tbs/tb332.pp b/tests/tbs/tb332.pp new file mode 100644 index 0000000000..04136f33d8 --- /dev/null +++ b/tests/tbs/tb332.pp @@ -0,0 +1,45 @@ +{ this test program test allocation of large pieces of stack } +{ this is especially necessary for win32 } + +procedure p1(a : array of byte); + + var + i : longint; + + begin + for i:=0 to high(a) do + a[i]:=0; + end; + +procedure p2; + + var + a : array[0..20000] of byte; + i : longint; + + begin + for i:=0 to high(a) do + a[i]:=0; + end; + +procedure p3; + + var + a : array[0..200000] of byte; + i : longint; + + begin + for i:=0 to high(a) do + a[i]:=0; + end; + + +var + a : array[0..10000] of byte; + +begin + p1(a); + p2; + p3; +end. + diff --git a/tests/tbs/tb333.pp b/tests/tbs/tb333.pp new file mode 100644 index 0000000000..fede1db11d --- /dev/null +++ b/tests/tbs/tb333.pp @@ -0,0 +1,20 @@ +{$mode delphi} +type + tc1 = class + l : longint; + property p : longint read l; + end; + + tc2 = class(tc1) + { in Delphi mode } + { parameters can have the same name as properties } + procedure p1(p : longint); + end; + +procedure tc2.p1(p : longint); + + begin + end; + +begin +end. diff --git a/tests/tbs/tb334.pp b/tests/tbs/tb334.pp new file mode 100644 index 0000000000..a12f135f39 --- /dev/null +++ b/tests/tbs/tb334.pp @@ -0,0 +1,15 @@ +var + d1,d2 :double; + i1,i2 : int64; + c1,c2 : dword; + +begin + c1:=10; + c2:=100; + i1:=1000; + i2:=10000; + d1:=c1/c2; + d2:=i1/i2; + if d1<>d2 then + halt(1); +end. diff --git a/tests/tbs/tb335.pp b/tests/tbs/tb335.pp new file mode 100644 index 0000000000..7a39833f6b --- /dev/null +++ b/tests/tbs/tb335.pp @@ -0,0 +1,12 @@ +type ta = array[1..1,1..100] of integer; + +procedure t(a: ta); +begin +end; + +var a: ta; + +begin + t(a); +end. + diff --git a/tests/tbs/tb336.pp b/tests/tbs/tb336.pp new file mode 100644 index 0000000000..7ac7f2185f --- /dev/null +++ b/tests/tbs/tb336.pp @@ -0,0 +1,76 @@ +{ %OPT=-Or } +{ test for full boolean eval and register usage with b+ } + +{$b+} + +var + funcscalled: byte; + ok: boolean; + +function function1: boolean; +begin + writeln('function1 called!'); + inc(funcscalled); + function1 := false; +end; + +function function2: boolean; +begin + writeln('function2 called!'); + inc(funcscalled); + function2 := false; +end; + +function function3: boolean; +begin + writeln('function3 called!'); + inc(funcscalled); + function3 := false; +end; + +function function4: boolean; +begin + writeln('function4 called!'); + inc(funcscalled); + function4 := false; +end; + +function test2: boolean; +var j, k, l, m: longint; +begin + test2 := true; + m := 0; +{ get as much regvars occupied as possible } + for j := 1 to 1000 do + for k := 1 to 1000 do + for l := k downto 0 do + inc(m,j - k + l); + if (j = 5) and (k = 0) and (l = 100) and function1 then + begin + test2 := false; + writeln('bug'); + end; +end; + +begin + ok := true; + funcscalled := 0; + if function1 and function2 and function3 and function4 then + begin + writeln('bug!'); + end; + ok := funcscalled = 4; + if ok then + writeln('all functions called!') + else + writeln('not all functions called'); + ok := test2 and (funcscalled = 5); + if ok then + writeln('test2 passed') + else writeln('test2 not passed'); + if not ok then + begin + writeln('full boolean evaluation is not working!'); + halt(1); + end; +end. diff --git a/tests/tbs/tb337.pp b/tests/tbs/tb337.pp new file mode 100644 index 0000000000..93a8a9971e --- /dev/null +++ b/tests/tbs/tb337.pp @@ -0,0 +1,8 @@ +{$mode objfpc} +var + o : tobject; + +begin + if assigned(o) then + halt(1); +end. diff --git a/tests/tbs/tb338.pp b/tests/tbs/tb338.pp new file mode 100644 index 0000000000..101387659a --- /dev/null +++ b/tests/tbs/tb338.pp @@ -0,0 +1,13 @@ +{$mode objfpc} + +{ tests assignements and compare } + +var + o1,o2 : tobject; + +begin + o1:=nil; + o2:=o1; + if o2<>nil then + halt(1); +end. diff --git a/tests/tbs/tb339.pp b/tests/tbs/tb339.pp new file mode 100644 index 0000000000..5cdabec138 --- /dev/null +++ b/tests/tbs/tb339.pp @@ -0,0 +1,5 @@ +var + l : farpointer; +begin + l:=ptr(0,0); +end. \ No newline at end of file diff --git a/tests/tbs/tb34.pp b/tests/tbs/tb34.pp new file mode 100644 index 0000000000..fb57b2dc28 --- /dev/null +++ b/tests/tbs/tb34.pp @@ -0,0 +1,8 @@ +{ Old file: tbs0038.pp } +{ tests const ps : ^string = nil; OK 0.9.9 (FK) } + +CONST ps : ^STRING = nil; + +begin +end. + diff --git a/tests/tbs/tb35.pp b/tests/tbs/tb35.pp new file mode 100644 index 0000000000..407665a4b9 --- /dev/null +++ b/tests/tbs/tb35.pp @@ -0,0 +1,13 @@ +{ Old file: tbs0039.pp } +{ shows the else-else problem OK 0.9.9 (FK) } + +VAR a : BYTE; +BEGIN + a := 1; + IF a=0 THEN + IF a=1 THEN a:=2 + ELSE + ELSE a:=3; { "Illegal expression" } +END. + + diff --git a/tests/tbs/tb36.pp b/tests/tbs/tb36.pp new file mode 100644 index 0000000000..9bfb24851d --- /dev/null +++ b/tests/tbs/tb36.pp @@ -0,0 +1,29 @@ +{ Old file: tbs0040.pp } +{ shows the if b1 xor b2 problem where b1,b2 :boolean OK 0.9.9 (FK) } + +{ xor operator bug } +{ needs fix in pass_1.pas line } +{ 706. as well as in the code } +{ generator - secondadd() } +var + b1,b2: boolean; +Begin + b1:=true; + b2:=false; + If (b1 xor b2) Then + begin + end + else + begin + writeln('Problem with bool xor'); + halt; + end; + b1:=true; + b2:=true; + If (b1 xor b2) Then + begin + writeln('Problem with bool xor'); + halt; + end; + writeln('No problem found'); +end. diff --git a/tests/tbs/tb37.pp b/tests/tbs/tb37.pp new file mode 100644 index 0000000000..b7e8ee82b1 --- /dev/null +++ b/tests/tbs/tb37.pp @@ -0,0 +1,11 @@ +{ Old file: tbs0041.pp } +{ shows the if then end. problem OK 0.9.9 (FK) } + +var + b1: boolean; +Begin + begin + If b1 then { illegal expression } + end; + while b1 do +End. diff --git a/tests/tbs/tb38.pp b/tests/tbs/tb38.pp new file mode 100644 index 0000000000..98f3044627 --- /dev/null +++ b/tests/tbs/tb38.pp @@ -0,0 +1,11 @@ +{ %OPT= -Rintel } + +{ Old file: tbs0042.pp } +{ shows assembler double operator expression problem OK 0.99.7 (PFV) } + +Begin + asm + mov ax,3*-4 { evaluator stack underflow } + end; { due to two operators following each other } +end. { this will also happen in att syntax. } + diff --git a/tests/tbs/tb39.pp b/tests/tbs/tb39.pp new file mode 100644 index 0000000000..6fc53ffa66 --- /dev/null +++ b/tests/tbs/tb39.pp @@ -0,0 +1,35 @@ +{ Old file: tbs0043.pp } +{ shows assembler nasm output fpu opcodes problem OK 0.99.6 (PFV) } + +{ THE OUTPUT is incorrect but the } +{ parsing is correct. } +{ under nasm output only. } +{ works correctly under tasm/gas } +{ other problems occur with other } +{ things in math.inc } +{ pp -TDOS -Ratt -Anasm bug0043.pp } + procedure frac; + + begin + asm + subl $16,%esp + fnstcw -4(%ebp) + fwait { unknown instruction } + movw -4(%ebp),%cx + orw $0x0c3f,%cx + movw %cx,-8(%ebp) + fldcw -8(%ebp) + fwait { unknown instruction } + fldl 8(%ebp) + frndint + fsubl 8(%ebp) + fabsl + fclex + fldcw -4(%ebp) + leave + ret $8 + end ['ECX']; + end; + +Begin +end. diff --git a/tests/tbs/tb4.pp b/tests/tbs/tb4.pp new file mode 100644 index 0000000000..367c87d090 --- /dev/null +++ b/tests/tbs/tb4.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0004.pp } +{ tests the continue instruction in the for loop OK 0.9.2 } + +var + i : longint; + +begin + for i:=1 to 100 do + begin + writeln('Hello'); + continue; + writeln('ohh'); + Halt(1); + end; +end. + diff --git a/tests/tbs/tb40.pp b/tests/tbs/tb40.pp new file mode 100644 index 0000000000..67ec2527e7 --- /dev/null +++ b/tests/tbs/tb40.pp @@ -0,0 +1,19 @@ +{ Old file: tbs0044.pp } +{ shows $ifdef and comment nesting/directive problem OK 0.99.1 (PFV) } + + { Problem with nested comments -- as you can probably see } + { but it does give out kind of a funny error output :) } + + + {$UNDEF VP} + + {$IFDEF Windows} ssss {$ENDIF} {No Syntax Error} + + {$IFDEF VP} + {$D+}{$R+} + {$ELSE} + {$IFDEF Windows} ssss {$ENDIF} {Syntax Error at: Col 25 } + {$ENDIF} + + BEGIN + END. diff --git a/tests/tbs/tb41.pp b/tests/tbs/tb41.pp new file mode 100644 index 0000000000..4c59e93287 --- /dev/null +++ b/tests/tbs/tb41.pp @@ -0,0 +1,29 @@ +{ Old file: tbs0045.pp } +{ shows problem with virtual private methods (might not be a true bugs but more of an incompatiblity?) the compiler warns now if there is a private and virtual method } + + +TYPE + tmyexample =object + public + constructor init; + destructor done; virtual; + private + procedure mytest;virtual; { syntax error --> should give only a +warning ? } + end; + + constructor tmyexample.init; + begin + end; + + destructor tmyexample.done; + Begin + end; + + procedure tmyexample.mytest; + begin + end; + +Begin +end. + diff --git a/tests/tbs/tb42.pp b/tests/tbs/tb42.pp new file mode 100644 index 0000000000..9efefa99d4 --- /dev/null +++ b/tests/tbs/tb42.pp @@ -0,0 +1,56 @@ +{ Old file: tbs0046.pp } +{ problems with sets with values over 128 due to sign extension (already fixed ) but also for SET_IN_BYTE } + +program test; + +{$R-} + +{$ifdef fpc} +{$ifdef go32v2} +uses + dpmiexcp; +{$endif} +{$endif} + +type byteset = set of byte; + bl = record i,j : longint; + end; +const set1 : byteset = [1,50,220]; + set2 : byteset = [55]; +var i : longint; + b : bl; + + function bi : longint; + + begin + bi:=b.i; + end; + +begin +set1:=set1+set2; +writeln('set 1 = [1,50,55,220]'); +i:=50; +if i in set1 then + writeln(i,' is in set1'); +i:=220; +if i in set1 then + writeln(i,' is in set1'); +i:=$100+220; +if i in set1 then + writeln(i,' is in set1'); +i:=-35; +if i in set1 then + writeln(i,' is in set1'); +b.i:=50; +i:=$100+220; +if i in [50,220] then + writeln(i,' is in [50,220]'); +if Bi in [50,220] then + writeln(b.i,' is in [50,220]'); +b.i:=220; +if bi in [50,220] then + writeln(b.i,' is in [50,220]'); +B.i:=-36; +if bi in [50,220] then + writeln(B.i,' is in [50,220]'); +end. diff --git a/tests/tbs/tb43.pp b/tests/tbs/tb43.pp new file mode 100644 index 0000000000..baaf17b574 --- /dev/null +++ b/tests/tbs/tb43.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0047.pp } +{ compiling with -So crashes the compiler OK 0.99.1 (CEC) } + +procedure test; + + begin + end; + +var + p1 : procedure; + p2 : pointer; + +begin + p1:=@test; + p2:=@test; +end. diff --git a/tests/tbs/tb44.pp b/tests/tbs/tb44.pp new file mode 100644 index 0000000000..c6ed5fa779 --- /dev/null +++ b/tests/tbs/tb44.pp @@ -0,0 +1,47 @@ +{ Old file: tbs0048.pp } +{ shows a problem with putimage on some computers OK 0.99.13 (JM) } + +{$ifdef go32v2} +{$define OK} +{$endif} +{$ifdef linux} +{$define OK} +{$endif} +{$ifdef win32} +{$define OK} +{$endif} + +{$ifdef OK} +uses + graph,crt; + +var + gd,gm : integer; + i,size : longint; + p : pointer; +{$endif OK} + +begin +{$ifdef OK} + gd:=detect; + initgraph(gd,gm,''); + setcolor(brown); + line(0,0,getmaxx,0); + {readkey;}delay(1000); + size:=imagesize(0,0,getmaxx,0); + getmem(p,size); + getimage(0,0,getmaxx,0,p^); + cleardevice; + for i:=0 to getmaxy do + begin + putimage(0,i,p^,xorput); + end; + {readkey;}delay(1000); + for i:=0 to getmaxy do + begin + putimage(0,i,p^,xorput); + end; + {readkey;}delay(1000); + closegraph; +{$endif OK} +end. diff --git a/tests/tbs/tb45.pp b/tests/tbs/tb45.pp new file mode 100644 index 0000000000..3a512620b8 --- /dev/null +++ b/tests/tbs/tb45.pp @@ -0,0 +1,22 @@ +{ Old file: tbs0050.pp } +{ can't set a function result in a nested procedure of a function OK 0.99.7 (PM) } + +function Append : Boolean; + + procedure DoAppend; + begin + Append := true; + end; + +begin + Append:=False; + DoAppend; +end; + +begin + If not Append then + begin + Writeln('TBS0050 fails'); + Halt(1); + end; +end. diff --git a/tests/tbs/tb46.pp b/tests/tbs/tb46.pp new file mode 100644 index 0000000000..6fe2a9ddab --- /dev/null +++ b/tests/tbs/tb46.pp @@ -0,0 +1,98 @@ +{ Old file: tbs0051.pp } +{ Graph, shows a problem with putpixel OK 0.99.9 (PM) } + +program TestPutP; + +{$ifdef go32v2} + {define has_colors_equal} +{$endif go32v2} + +{$ifdef go32v2} +{$define OK} +{$endif} +{$ifdef linux} +{$define OK} +{$endif} + +{$ifdef OK} +uses crt,graph; + +{$ifndef has_colors_equal} + function ColorsEqual(c1, c2 : longint) : boolean; + begin + ColorsEqual:=((GetMaxColor=$FF) and ((c1 and $FF)=(c2 and $FF))) or + ((GetMaxColor=$7FFF) and ((c1 and $F8F8F8)=(c2 and $F8F8F8))) or + ((GetMaxColor=$FFFF) and ((c1 and $F8FCF8)=(c2 and $F8FCF8))) or + ((GetMaxColor>$10000) and ((c1 and $FFFFFF)=(c2 and $FFFFFF))); + end; + +{$endif not has_colors_equal} + +var gd,gm,gError,yi,i : integer; + col: longint; + error : word; + +{$endif OK} +BEGIN +{$ifdef OK} + if paramcount=0 then + gm:=$111 {640x480/64K HiColor} + else + begin + val(paramstr(1),gm,error); + if error<>0 then + gm:=$111; + end; + gd:=detect; + + InitGraph(gd,gm,''); + gError := graphResult; + IF gError <> grOk + THEN begin + writeln ('graphDriver=',gd,' graphMode=',gm, + #13#10'Graphics error: ',gError); + halt(1); + end; + + for i := 0 to 255 + do begin + { new grpah unit used word type for colors } + col := {i shl 16 + }(i) shl 8 + (i div 2); + for yi := 0 to 20 do + PutPixel (i,yi,col); + SetColor (col); + Line (i,22,i,42); + end; + + for i:=0 to 255 do + if not ColorsEqual(getpixel(i,15),getpixel(i,30)) then + Halt(1); + {readkey;}delay(1000); + + closegraph; +{$endif OK} +END. + +{ + $Log$ + Revision 1.1 2000-11-29 23:14:15 peter + * new testsuite setup + + Revision 1.1 2000/07/13 09:21:54 michael + + Initial import + + Revision 1.2 2000/04/14 05:44:22 pierre + * adapted to new graph unit + + Revision 1.1 1999/12/02 17:37:38 peter + * moved *.pp into subdirs + * fpcmaked + + Revision 1.5 1999/11/28 12:17:14 jonas + * changed the requested graphdriver from $FF to VESA (= 10), so the + test program works again with the new graph unit + * undefined has_colors_equal for go32v2, because it is not anymore + in the new graph unit + + +} diff --git a/tests/tbs/tb47.pp b/tests/tbs/tb47.pp new file mode 100644 index 0000000000..b875548542 --- /dev/null +++ b/tests/tbs/tb47.pp @@ -0,0 +1,52 @@ +{ Old file: tbs0052.pp } +{ Graph, collects missing graph unit routines OK 0.99.9 (PM) } + +{$ifdef go32v2} +{$define OK} +{$endif} +{$ifdef linux} +{$define OK} +{$endif} +{$ifdef win32} +{$define OK} +{$endif} + +{$ifdef OK} +uses + crt,graph; + +const + Triangle: array[1..3] of PointType = ((X: 50; Y: 100), (X: 100; Y:100), + (X: 150; Y: 150)); + Rect : array[1..4] of PointType = ((X: 50; Y: 100), (X: 100; Y:100), + (X: 75; Y: 150), (X: 80; Y : 50)); + Penta : array[1..5] of PointType = ((X: 250; Y: 100), (X: 300; Y:100), + (X: 275; Y: 150), (X: 280; Y : 50), (X:295; Y : 80) ); + +var Gd, Gm: Integer; +{$endif OK} +begin +{$ifdef OK} + Gd := Detect; + InitGraph(Gd, Gm, 'c:\bp\bgi'); + if GraphResult <> grOk then + Halt(1); + drawpoly(SizeOf(Triangle) div SizeOf(PointType), Triangle); + {readln;}delay(1000); + setcolor(red); + fillpoly(SizeOf(Triangle) div SizeOf(PointType), Triangle); + {readln;}delay(1000); + SetFillStyle(SolidFill,blue); + Bar(0,0,GetMaxX,GetMaxY); + Rectangle(25,25,GetMaxX-25,GetMaxY-25); + setViewPort(25,25,GetMaxX-25,GetMaxY-25,true); + clearViewPort; + setcolor(magenta); + SetFillStyle(SolidFill,red); + fillpoly(SizeOf(Rect) div SizeOf(PointType), Rect); + fillpoly(SizeOf(Penta) div SizeOf(PointType), Penta); + graphdefaults; + {readln;}delay(1000); + CloseGraph; +{$endif OK} +end. diff --git a/tests/tbs/tb48.pp b/tests/tbs/tb48.pp new file mode 100644 index 0000000000..2b23112b55 --- /dev/null +++ b/tests/tbs/tb48.pp @@ -0,0 +1,18 @@ +{ Old file: tbs0053.pp } +{ shows a problem with open arrays OK 0.99.1 (FK) } + +procedure abc(var a : array of char); + + begin + // error: a:='asdf'; + end; + +var + c : array[0..10] of char; + +begin + abc(c); + writeln(c); + // error: writeln(a); +end. + diff --git a/tests/tbs/tb49.pp b/tests/tbs/tb49.pp new file mode 100644 index 0000000000..0f3bfb5ccc --- /dev/null +++ b/tests/tbs/tb49.pp @@ -0,0 +1,9 @@ +{ Old file: tbs0054.pp } +{ wordbool and longbool types are missed OK 0.99.6 (PFV) } + +var + wb : wordbool; + wl : longbool; + +begin +end. diff --git a/tests/tbs/tb5.pp b/tests/tbs/tb5.pp new file mode 100644 index 0000000000..a32e5705d9 --- /dev/null +++ b/tests/tbs/tb5.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0005.pp } +{ tests the if 1=1 then ... bugs OK 0.9.2 } + +uses + erroru; + +begin + if 1=1 then + begin + Writeln('OK'); + end; + if 1<>1 then + begin + Error; + end; +end. diff --git a/tests/tbs/tb50.pp b/tests/tbs/tb50.pp new file mode 100644 index 0000000000..f56cf46a3d --- /dev/null +++ b/tests/tbs/tb50.pp @@ -0,0 +1,18 @@ +{ Old file: tbs0055.pp } +{ internal error 10 (means too few registers OK 0.99.1 (FK) } + +type + tarraysingle = array[0..1] of single; + +procedure test(var a : tarraysingle); + +var + i,j,k : integer; + +begin + a[i]:=a[j]-a[k]; +end; + +begin +end. + diff --git a/tests/tbs/tb51.pp b/tests/tbs/tb51.pp new file mode 100644 index 0000000000..12134b01f0 --- /dev/null +++ b/tests/tbs/tb51.pp @@ -0,0 +1,17 @@ +{ Old file: tbs0056.pp } +{ shows a _very_ simple expression which generates OK 0.99.1 (FK) } + +PROGRAM ShowBug; + +(* This will compile +VAR N, E: Integer;*) + +(* This will NOT compile*) +VAR N, E: LongInt; + +BEGIN + E := 2; + WriteLn(E); + N := 44 - E; + WriteLn(N); +END. diff --git a/tests/tbs/tb52.pp b/tests/tbs/tb52.pp new file mode 100644 index 0000000000..62b1afb044 --- /dev/null +++ b/tests/tbs/tb52.pp @@ -0,0 +1,37 @@ +{ Old file: tbs0057.pp } +{ Graph, shows a crash with switch graph/text/graph OK 0.99.9 (PM) } + +{$ifdef go32v2} +{$define OK} +{$endif} +{$ifdef linux} +{$define OK} +{$endif} +{$ifdef win32} +{$define OK} +{$endif} + +{$ifdef OK} +uses + graph,crt; + +var + gd,gm : integer; + +{$endif OK} +begin +{$ifdef OK} + gd:=detect; + gm:=$103; + initgraph(gd,gm,''); + setcolor(white); + line(1,1,100,100); + {readkey;}delay(1000); + closegraph; + initgraph(gd,gm,''); + line(100,100,1,100); + {readkey;}delay(1000); + closegraph; +{$endif OK} + writeln('OK'); +end. diff --git a/tests/tbs/tb53.pp b/tests/tbs/tb53.pp new file mode 100644 index 0000000000..3e8cf6c184 --- /dev/null +++ b/tests/tbs/tb53.pp @@ -0,0 +1,12 @@ +{ Old file: tbs0058.pp } +{ causes an internal error 10 (problem with getregisterOK 0.99.1 (FK) } + +{$r+} +var + a1 : array[0..1,0..1] of word; + a2 : array[0..1,0..1] of longint; + i,j,l,n : longint; + +begin + a1[i,j]:=a2[l,n]; +end. diff --git a/tests/tbs/tb54.pp b/tests/tbs/tb54.pp new file mode 100644 index 0000000000..b7af245695 --- /dev/null +++ b/tests/tbs/tb54.pp @@ -0,0 +1,12 @@ +{ Old file: tbs0059.pp } +{ shows the problem with syntax error with ordinal OK 0.99.1 (FK) } + +Program ConstBug; + +Const + S = ord('J'); + t: byte = ord('J'); + + +Begin +end. diff --git a/tests/tbs/tb55.pp b/tests/tbs/tb55.pp new file mode 100644 index 0000000000..eaa543612d --- /dev/null +++ b/tests/tbs/tb55.pp @@ -0,0 +1,11 @@ +{ Old file: tbs0061.pp } +{ shows wrong errors when compiling (NOT A bugs) OK 0.99.1 } + +var + r : double; + s : string; + +begin + r:=1234.0; + str(r,s); +end. diff --git a/tests/tbs/tb56.pp b/tests/tbs/tb56.pp new file mode 100644 index 0000000000..16575312f7 --- /dev/null +++ b/tests/tbs/tb56.pp @@ -0,0 +1,12 @@ +{ Old file: tbs0062.pp } +{ shows illegal type conversion for boolean OK 0.99.6 (PFV) } + +Program Bug0062; + + +var + myvar:boolean; +Begin + { by fixing this we also start partly implementing LONGBOOL/WORDBOOL } + myvar:=boolean(1); { illegal type conversion } +end. diff --git a/tests/tbs/tb57.pp b/tests/tbs/tb57.pp new file mode 100644 index 0000000000..b37349f39c --- /dev/null +++ b/tests/tbs/tb57.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0063.pp } +{ shows problem with ranges in sets for variables OK 0.99.7 (PFV) } + +{ may also crash/do weird error messages with the compiler } +var + min: char; + max: char; + i: char; +begin + min:='c'; + max:='z'; + if i in [min..max] then + Begin + end; +end. + diff --git a/tests/tbs/tb58.pp b/tests/tbs/tb58.pp new file mode 100644 index 0000000000..e1564b357f --- /dev/null +++ b/tests/tbs/tb58.pp @@ -0,0 +1,18 @@ +{ Old file: tbs0064.pp } +{ shows other types of problems with case statements OK 0.99.1 (FK) } + +var + i: byte; + j: integer; + c: char; +Begin + case i of + Ord('x'): ; + end; + case j of + Ord('x'): ; + end; + case c of + Chr(112): ; + end; +end. \ No newline at end of file diff --git a/tests/tbs/tb59.pp b/tests/tbs/tb59.pp new file mode 100644 index 0000000000..62c9b90739 --- /dev/null +++ b/tests/tbs/tb59.pp @@ -0,0 +1,13 @@ +{ Old file: tbs0065.pp } +{ shows that frac() doesn't work correctly. OK 0.99.1 (PFV) } + +Program Example27; + +{ Program to demonstrate the Frac function. } + +Var R : Real; + +begin + Writeln (Frac (123.456):0:3); { Prints O.456 } + Writeln (Frac (-123.456):0:3); { Prints -O.456 } +end. diff --git a/tests/tbs/tb6.pp b/tests/tbs/tb6.pp new file mode 100644 index 0000000000..35c1476ab6 --- /dev/null +++ b/tests/tbs/tb6.pp @@ -0,0 +1,21 @@ +{ Old file: tbs0006.pp } +{ tests the wrong floating point code generation OK 0.9.2 } + +uses + erroru; +var + a,b,c,d,e,f,g,r : double; + +begin + a:=10.0; + b:=11.0; + c:=13.0; + d:=17.0; + e:=19.0; + f:=23.0; + r:=2.0; + a:= a - 2*b*e - 2*c*f - 2*d*g - Sqr(r); + writeln(a,' (must be -1010)'); + if a<>-1010.0 then + Error; +end. diff --git a/tests/tbs/tb60.pp b/tests/tbs/tb60.pp new file mode 100644 index 0000000000..5c004d7829 --- /dev/null +++ b/tests/tbs/tb60.pp @@ -0,0 +1,13 @@ +{ Old file: tbs0066.pp } +{ shows that Round doesn't work correctly. (NOT A bugs) OK 0.99.1 } + +Program Example54; + +{ Program to demonstrate the Round function. } + +begin + Writeln (Round(123.456)); { Prints 124 } + Writeln (Round(-123.456)); { Prints -124 } + Writeln (Round(12.3456)); { Prints 12 } + Writeln (Round(-12.3456)); { Prints -12 } +end. diff --git a/tests/tbs/tb61.pp b/tests/tbs/tb61.pp new file mode 100644 index 0000000000..0d009fe125 --- /dev/null +++ b/tests/tbs/tb61.pp @@ -0,0 +1,21 @@ +{ Old file: tbs0067.pp } +{ Shows incorrect symbol resolution when using uses in implementation More info can be found in file tbs0067b.pp. } + +unit tbs0067; + +interface + +type + tlong=record + a : longint; + end; + +procedure p(var t:tlong); + +implementation + +procedure p(var t:tlong); +begin +end; + +end. diff --git a/tests/tbs/tb62.pp b/tests/tbs/tb62.pp new file mode 100644 index 0000000000..c5abb1d512 --- /dev/null +++ b/tests/tbs/tb62.pp @@ -0,0 +1,30 @@ +{ Old file: tbs0067b.pp } +{ (Work together) OK 0.99.1 } + +unit tbs0067b; + +interface + + +type + tlong=record + a : longint; + end; + +procedure p(var l:tlong); + +implementation + +uses tbs0067; + +{ the tlong parameter is taken from unit bug0067, + and not from the interface part of this unit. + setting the uses clause in the interface part + removes the problem } + +procedure p(var l:tlong); +begin + tbs0067.p(tbs0067.tlong(l)); +end; + +end. diff --git a/tests/tbs/tb63.pp b/tests/tbs/tb63.pp new file mode 100644 index 0000000000..abf5fc7fa0 --- /dev/null +++ b/tests/tbs/tb63.pp @@ -0,0 +1,12 @@ +{ Old file: tbs0068.pp } +{ Shows incorrect type of ofs() OK 0.99.1 (PFV and FK) } + +program bug0068; + +var + p : pointer; + l : longint; +begin + l:=Ofs(p); { Ofs returns a pointer type !? } + +end. diff --git a/tests/tbs/tb64.pp b/tests/tbs/tb64.pp new file mode 100644 index 0000000000..516c3475df --- /dev/null +++ b/tests/tbs/tb64.pp @@ -0,0 +1,28 @@ +{ Old file: tbs0069.pp } +{ Shows problem with far qualifier in units OK 0.99.1 (CEC) } + +Unit tbs0069; + +Interface + +Procedure MyTest;Far; { IMPLEMENTATION expected error. } + +{ Further information: NEAR IS NOT ALLOWED IN BORLAND PASCAL } +{ Therefore the bugfix should only be for the FAR keyword. } +(* Procedure MySecondTest;Near; *) + +Implementation + +{ near and far are not allowed here, but maybe we don't care since they are ignored by } +{ FPC. } +Procedure MyTest; +Begin +end; + +Procedure MySecondTest; +Begin +end; + + + +end. diff --git a/tests/tbs/tb65.pp b/tests/tbs/tb65.pp new file mode 100644 index 0000000000..a6dd5229ff --- /dev/null +++ b/tests/tbs/tb65.pp @@ -0,0 +1,13 @@ +{ Old file: tbs0070.pp } +{ shows missing include and exclude from rtl OK 0.99.6 (MVC) } + +Program Test; + +type + myenum = (YES,NO,MAYBE); +var + myvar:set of myenum; +Begin + Include(myvar,Yes); + Exclude(myvar,No); +end. diff --git a/tests/tbs/tb66.pp b/tests/tbs/tb66.pp new file mode 100644 index 0000000000..766f469fa0 --- /dev/null +++ b/tests/tbs/tb66.pp @@ -0,0 +1,18 @@ +{ Old file: tbs0072.pp } +{ causes an internal error 10 ( i386 ONLY ) OK 0.99.1 (FK) } + +type + tarraysingle = array[0..1] of single; + +procedure test(var a : tarraysingle); + +var + i,j,k : integer; + +begin + a[i]:=a[j]-a[k]; +end; + +begin +end. + diff --git a/tests/tbs/tb67.pp b/tests/tbs/tb67.pp new file mode 100644 index 0000000000..6fe177fc56 --- /dev/null +++ b/tests/tbs/tb67.pp @@ -0,0 +1,33 @@ +{ Old file: tbs0073.pp } +{ shows incompatiblity with bp for distance qualifiers OK 0.99.6 (PFV) } + +Unit tbs0073; + +Interface + + +Procedure MyTest;Far; { IMPLEMENTATION expected error. } + +{ Further information: NEAR IS NOT ALLOWED IN BORLAND PASCAL } +{ Therefore the bugfix should only be for the FAR keyword. } + Procedure MySecondTest; + +Implementation + +{ near and far are not allowed here, but maybe we don't care since they are ignored by } +{ FPC. } +Procedure MyTest; +Begin +end; + + + +Procedure MySecondTest;Far; +Begin +end; + + + + + +end. diff --git a/tests/tbs/tb68.pp b/tests/tbs/tb68.pp new file mode 100644 index 0000000000..cbeb471231 --- /dev/null +++ b/tests/tbs/tb68.pp @@ -0,0 +1,31 @@ +{ Old file: tbs0074.pp } +{ shows MAJOR bugs when trying to compile valid code OK 0.99.1 (PM/CEC) } + +type + tmyobject = object + constructor init; + procedure callit; virtual; + destructor done; virtual; + end; + + + constructor tmyobject.init; + Begin + end; + + destructor tmyobject.done; + Begin + end; + + procedure tmyobject.callit; + Begin + WriteLn('Hello...'); + end; + + var + obj: tmyobject; + Begin + obj.init; + obj.callit; +{ obj.done;} + end. diff --git a/tests/tbs/tb69.pp b/tests/tbs/tb69.pp new file mode 100644 index 0000000000..64b2ccca7c --- /dev/null +++ b/tests/tbs/tb69.pp @@ -0,0 +1,27 @@ +{ Old file: tbs0076.pp } +{ bugs in intel asm generator. was already fixed OK 0.99.1 (FK) } + +program bug0076; + +{Generates wrong code when compiled with output set to intel asm. + + Reported from mailinglist by Vtech Kavan. + + 15 Januari 1998, Daniel Mantione} + +type TVtx2D = record x,y:longint end; + +var Vtx2d:array[0..2] of TVtx2D; + +function SetupScanLines(va,vb,vc:word):single; +var dx3d,dx2d,dy2d,dz,ex3d,ex2d,ez:longint; + r:single; +begin + dy2d := Vtx2d[vb].y; + r := (dy2d-Vtx2d[va].y); {this line causes error!!!!!!!!!!!!!!!!!!!} +end; + +begin + SetupScanLines(1,2,3); +end. + diff --git a/tests/tbs/tb7.pp b/tests/tbs/tb7.pp new file mode 100644 index 0000000000..fd49e44635 --- /dev/null +++ b/tests/tbs/tb7.pp @@ -0,0 +1,20 @@ +{ Old file: tbs0007.pp } +{ tests the infinity loop when using byte counter OK 0.9.2 } + +uses + erroru; + +var + count : byte; + test : longint; +begin + test:=0; + for count:=1 to 127 do + begin + inc(test); + writeln(count,'. loop'); + if test>127 then + Error; + end; +end. + diff --git a/tests/tbs/tb70.pp b/tests/tbs/tb70.pp new file mode 100644 index 0000000000..a0541d7a16 --- /dev/null +++ b/tests/tbs/tb70.pp @@ -0,0 +1,12 @@ +{ Old file: tbs0077.pp } +{ shows a bugs with absolute in interface part of unit OK 0.99.1 (FK) } + +uses + tbs0077b; + +begin + b:=89; + writeln(a); +end. + + diff --git a/tests/tbs/tb71.pp b/tests/tbs/tb71.pp new file mode 100644 index 0000000000..1c1a5d934a --- /dev/null +++ b/tests/tbs/tb71.pp @@ -0,0 +1,14 @@ +{ Old file: tbs0077b.pp } +{ used by unit tbs0077.pp } + +unit tbs0077b; + + interface + + var + a : longint; + b : longint absolute a; + + implementation + +end. diff --git a/tests/tbs/tb72.pp b/tests/tbs/tb72.pp new file mode 100644 index 0000000000..cc091bf097 --- /dev/null +++ b/tests/tbs/tb72.pp @@ -0,0 +1,12 @@ +{ %OPT=-Rintel } + +{ Old file: tbs0078.pp } +{ Shows problems with longint constant in intel asm OK 0.99.1 (CEC) } + +{ shows error with asm_size_mismatch } +Begin + asm + mov eax, 2147483647 + mov eax, 2000000000 + end; +end. diff --git a/tests/tbs/tb73.pp b/tests/tbs/tb73.pp new file mode 100644 index 0000000000..74d7e04640 --- /dev/null +++ b/tests/tbs/tb73.pp @@ -0,0 +1,22 @@ +{ %OPT= -Rintel } + +{ Old file: tbs0079.pp } +{ Shows problems with stackframe with assembler keyword OK 0.99.1 (CEC) } + +procedure nothing(x,y: longint);assembler; +asm + mov eax,x + mov ebx,y +end; + + +{procedure nothing(x,y: longint); +begin + asm + mov eax,x + mov ebx,y + end; +end; } + +Begin +end. diff --git a/tests/tbs/tb74.pp b/tests/tbs/tb74.pp new file mode 100644 index 0000000000..0e84505031 --- /dev/null +++ b/tests/tbs/tb74.pp @@ -0,0 +1,11 @@ +{ Old file: tbs0080.pp } +{ Shows Missing High() (internal) function. OK 0.99.6 (MVC) } + +program bug0080; + +type + + tHugeArray = array [ 1 .. High(Word) ] of byte; + +begin +end. \ No newline at end of file diff --git a/tests/tbs/tb75.pp b/tests/tbs/tb75.pp new file mode 100644 index 0000000000..40b42c9cb2 --- /dev/null +++ b/tests/tbs/tb75.pp @@ -0,0 +1,10 @@ +{ Old file: tbs0081.pp } +{ Shows incompatibility with borland's 'array of char'. OK 0.99.1 (FK) } + +program bug0081; + +const + EOL : array [1..2] of char = #13 + #10; + +begin +end. diff --git a/tests/tbs/tb76.pp b/tests/tbs/tb76.pp new file mode 100644 index 0000000000..278ae9d2ca --- /dev/null +++ b/tests/tbs/tb76.pp @@ -0,0 +1,32 @@ +{ Old file: tbs0082.pp } +{ Shows incompatibility with BP : Multiple destructors. OK 0.99.1 (FK) } + +Unit tbs0082; + +interface + +Type T = OBject + Constructor Init; + Destructor Free; virtual; + Destructor Destroy; virtual; + end; + +implementation + +constructor T.INit; + +begin +end; + +Destructor t.Free; + +begin +end; + +Destructor t.Destroy; + +begin +end; + + +end. \ No newline at end of file diff --git a/tests/tbs/tb77.pp b/tests/tbs/tb77.pp new file mode 100644 index 0000000000..54cdd17105 --- /dev/null +++ b/tests/tbs/tb77.pp @@ -0,0 +1,11 @@ +{ Old file: tbs0083.pp } +{ shows missing "dynamic" set constructor OK 0.99.7 (PFV) } + + +var + s1 : set of char; + c1,c2,c3 : char; + +begin + s1:=[c1..c2,c3]; +end. diff --git a/tests/tbs/tb78.pp b/tests/tbs/tb78.pp new file mode 100644 index 0000000000..6c7b4c43c7 --- /dev/null +++ b/tests/tbs/tb78.pp @@ -0,0 +1,18 @@ +{ Old file: tbs0084.pp } +{ no more pascal type checking OK 0.99.1 (FK) } + +{$R-} + +{ Basic Pascal principles gone done the drain... !!!! } + +var + v: word; + w: shortint; + z: byte; + y: integer; +Begin + y:=64000; + z:=32767; + w:=64000; + v:=-1; +end. \ No newline at end of file diff --git a/tests/tbs/tb79.pp b/tests/tbs/tb79.pp new file mode 100644 index 0000000000..7e27ee9aa2 --- /dev/null +++ b/tests/tbs/tb79.pp @@ -0,0 +1,13 @@ +{ Old file: tbs0090.pp } +{ shows PChar comparison problem OK 0.99.7 (PFV) } + +{$X+} +var + mystr : array[0..4] of char; + +Begin + if mystr = #0#0#0#0 then + Begin + end; + mystr:=#0#0#0#0; +end. diff --git a/tests/tbs/tb8.pp b/tests/tbs/tb8.pp new file mode 100644 index 0000000000..9c6df331eb --- /dev/null +++ b/tests/tbs/tb8.pp @@ -0,0 +1,30 @@ +{ Old file: tbs0009.pp } +{ tests comperations in function calls a(c<0); OK 0.9.2 } + +var c:byte; + + Procedure a(b:boolean); + + begin + if b then writeln('TRUE') else writeln('FALSE'); + end; + + function Test_a(b:boolean) : string; + + begin + if b then Test_a:='TRUE' else Test_a:='FALSE'; + end; + + begin {main program} + a(true); {works} + if Test_a(true)<>'TRUE' then halt(1); + a(false); {works} + if Test_a(false)<>'FALSE' then halt(1); + c:=0; + a(c>0); {doesn't work} + if Test_a(c>0)<>'FALSE' then halt(1); + a(c<0); {doesn't work} + if Test_a(c<0)<>'FALSE' then halt(1); + a(c=0); + if Test_a(c=0)<>'TRUE' then halt(1); + end. diff --git a/tests/tbs/tb80.pp b/tests/tbs/tb80.pp new file mode 100644 index 0000000000..588d8d1377 --- /dev/null +++ b/tests/tbs/tb80.pp @@ -0,0 +1,26 @@ +{ Old file: tbs0091.pp } +{ missing standard functions in constant expressions OK 0.99.7 (PFV) } + +{ Page 22 of The Language Guide of Turbo Pascal } +var + t: byte; +const + a = Trunc(1.3); + b = Round(1.6); + c = abs(-5); + ErrStr = 'Hello!'; + d = Length(ErrStr); + e = Lo($1234); + f = Hi($1234); + g = Chr(34); + h = Odd(1); + i = Ord('3'); + j = Pred(34); + l = Sizeof(t); + m = Succ(9); + n = Swap($1234); + o = ptr(0,0); +Begin +end. + + diff --git a/tests/tbs/tb81.pp b/tests/tbs/tb81.pp new file mode 100644 index 0000000000..f109b8ddf4 --- /dev/null +++ b/tests/tbs/tb81.pp @@ -0,0 +1,13 @@ +{ Old file: tbs0092.pp } +{ The unfixable bugs. Maybe we find a solution one day. OK 0.99.6 (FK) } + +{The unfixable bug. Maybe we get an idea when we keep looking at it. + Daniel Mantione 5 februari 1998.} + +const + a:1..4=2; {Crash 1.} + b:set of 1..4=[2,3]; {Also crashes, but is the same bug.} + +begin + writeln(a); +end. diff --git a/tests/tbs/tb82.pp b/tests/tbs/tb82.pp new file mode 100644 index 0000000000..c41ca82793 --- /dev/null +++ b/tests/tbs/tb82.pp @@ -0,0 +1,21 @@ +{ Old file: tbs0093.pp } +{ Two Cardinal type bugss 0K 0.99.1 (FK/MvC) } + +{ Two cardinal type bugs } +var + c : cardinal; + l : longint; + b : byte; + s : shortint; + w : word; +begin + b:=123; + w:=s; + l:=b; + c:=b; {generates movzbl %eax,%edx instead of movzbl %al,%edx} + + c:=123; + writeln(c); {Shows '0' outline right! instead of '123' outlined left} + c:=$7fffffff; + writeln(c); {Shows '0' outline right! instead of '123' outlined left} +end. diff --git a/tests/tbs/tb83.pp b/tests/tbs/tb83.pp new file mode 100644 index 0000000000..4c636daa12 --- /dev/null +++ b/tests/tbs/tb83.pp @@ -0,0 +1,18 @@ +{ Old file: tbs0095.pp } +{ case with ranges starting with #0 bugss OK 0.99.1 (FK) } + +var + ch : char; +begin + ch:=#3; + case ch of + #0..#31 : ; + else + writeln('bug'); + end; + case ch of + #0,#1,#3 : ; + else + writeln('bug'); + end; +end. diff --git a/tests/tbs/tb84.pp b/tests/tbs/tb84.pp new file mode 100644 index 0000000000..1732a92b3d --- /dev/null +++ b/tests/tbs/tb84.pp @@ -0,0 +1,27 @@ +{ Old file: tbs0096.pp } +{ problem with objects as parameters OK 0.99.6 (PM) } + +type + TParent = object + end; + + PParent = ^TParent; + + TChild = object(TParent) + end; + +procedure aProc(const x : TParent ); +begin +end; + +procedure anotherProc(var x : TParent ); +begin +end; + +var + y : TChild; + + begin + aProc(y); + anotherProc(y); + end. diff --git a/tests/tbs/tb85.pp b/tests/tbs/tb85.pp new file mode 100644 index 0000000000..aa6292be0f --- /dev/null +++ b/tests/tbs/tb85.pp @@ -0,0 +1,48 @@ +{ Old file: tbs0098.pp } +{ File type casts are not allowed (works in TP7) OK 0.99.1 (FK) } + +program Test; +{ Show how to seek to an OFFSET (not a line number) in a textfile, } +{ without using asm. Arne de Bruijn, 1994, PD } +uses Dos; { For TextRec and FileRec } +var + F:text; + L:longint; + S:string; +begin + assign(F,'tbs/tbs0098.pp'); { Assign F to itself } + reset(F); { Open it (as a textfile) } + ReadLn(F); { Just read some lines } + ReadLn(F); + ReadLn(F); + FileRec((@F)^).Mode:=fmInOut; { Set to binary mode } + { (The (@F)^ part is to let TP 'forget' the type of the structure, so } + { you can type-caste it to everything (note that with and without (@X)^ } + { can give a different value, longint(bytevar) gives the same value as } + { bytevar, while longint((@bytevar)^) gives the same as } + { longint absolute Bytevar (i.e. all 4 bytes in a longint are readed } + { from memory instead of 3 filled with zeros))) } + FileRec((@F)^).RecSize:=1; { Set record size to 1 (a byte)} + L:=(FilePos(File((@F)^))-TextRec(F).BufEnd)+TextRec(F).BufPos; +{... This line didn't work the last time I tried, it chokes on the "File" +typecasting thing.} + + { Get the fileposition, subtract the already readed buffer, and add the } + { position in that buffer } + TextRec(F).Mode:=fmInput; { Set back to text mode } + TextRec(F).BufSize:=SizeOf(TextBuf); { BufSize overwritten by RecSize } + { Doesn't work with SetTextBuf! } + ReadLn(F,S); { Read the next line } + WriteLn('Next line:',S); { Display it } + FileRec((@F)^).Mode:=fmInOut; { Set to binary mode } + FileRec((@F)^).RecSize:=1; { Set record size to 1 (a byte)} + Seek(File((@F)^),L); { Do the seek } +{... And again here.} + + TextRec(F).Mode:=fmInput; { Set back to text mode } + TextRec(F).BufSize:=SizeOf(TextBuf); { Doesn't work with SetTextBuf! } + TextRec(F).BufPos:=0; TextRec(F).BufEnd:=0; { Reset buffer counters } + ReadLn(F,S); { Show that it worked, the same } + WriteLn('That line again:',S); { line readed again! } + Close(F); { Close it } +end. diff --git a/tests/tbs/tb86.pp b/tests/tbs/tb86.pp new file mode 100644 index 0000000000..e5638b81eb --- /dev/null +++ b/tests/tbs/tb86.pp @@ -0,0 +1,10 @@ +{ Old file: tbs0099.pp } +{ wrong assembler code is genereatoed for range check OK 0.99.1 (?) } + + +{$R+} +var w:word; + s:Shortint; +begin + w := s; +end. diff --git a/tests/tbs/tb87.pp b/tests/tbs/tb87.pp new file mode 100644 index 0000000000..4f5689e8f1 --- /dev/null +++ b/tests/tbs/tb87.pp @@ -0,0 +1,22 @@ +{ Old file: tbs0102.pp } +{ page fault when trying to compile under ppcm68k OK 0.99.1 } + +{ assembler reader of m68k for register ranges } + +unit tbs0102; + interface + + implementation + +{$ifdef M68K} + procedure int_help_constructor; + + begin + asm + movem.l d0-a7,-(sp) + end; + end; +{$endif M68K} + + + end. diff --git a/tests/tbs/tb88.pp b/tests/tbs/tb88.pp new file mode 100644 index 0000000000..7ac377e809 --- /dev/null +++ b/tests/tbs/tb88.pp @@ -0,0 +1,11 @@ +{ Old file: tbs0103.pp } +{ problems with boolean typecasts (other type) OK 0.99.6 (PFV) } + + +Var + out: boolean; + int: byte; +Begin + { savesize is different! } + out:=boolean((int AND $20) SHL 4); +end. diff --git a/tests/tbs/tb89.pp b/tests/tbs/tb89.pp new file mode 100644 index 0000000000..69660cf963 --- /dev/null +++ b/tests/tbs/tb89.pp @@ -0,0 +1,19 @@ +{ Old file: tbs0104.pp } +{ cardinal greater than $7fffffff aren't written OK 0.99.1 (FK) } + +{$ifdef go32v2} +uses + dpmiexcp; +{$endif} + +{ Two cardinal type bugs } +var + c : cardinal; +begin + c:=$80000000; + writeln(c); + c:=$80001234; + writeln(c); + c:=$ffffffff; + writeln(c); +end. diff --git a/tests/tbs/tb9.pp b/tests/tbs/tb9.pp new file mode 100644 index 0000000000..2f1d121e67 --- /dev/null +++ b/tests/tbs/tb9.pp @@ -0,0 +1,17 @@ +{ Old file: tbs0011.pp } +{ tests div/mod bugs, where edx is scrambled, if a called procedure does a div/mod OK 0.9.2 } + +{$message don't know how to make a test from bug0011 (PM)} +var + vga : array[0..320*200-1] of byte; + +procedure test(x,y : longint); + + begin + vga[x+y mod 320]:=random(256); + vga[x+y mod 320]:=random(256); + end; + +begin +end. + diff --git a/tests/tbs/tb90.pp b/tests/tbs/tb90.pp new file mode 100644 index 0000000000..1571bf09d8 --- /dev/null +++ b/tests/tbs/tb90.pp @@ -0,0 +1,49 @@ +{ Old file: tbs0105.pp } +{ typecasts are now ignored problem (NOT A bugs) OK 0.99.1 } + +{$ifdef go32v2} +{$define OK} +{$endif} +{$ifdef linux} +{$define OK} +{$endif} + +{ Win32 signal support is still missing ! } + +{$ifdef OK} + +{$ifdef go32v2} + uses dpmiexcp; +{$endif go32v2} +{$ifdef linux} + uses linux; +{$endif linux} + + function our_sig(l : longint) : longint;{$ifdef linux}cdecl;{$endif} + begin + { If we land here the program works correctly !! } + Writeln('Sigsegv signal recieved'); + our_sig:=0; + Halt(0); + end; + +Var + Sel: Word; + v: pointer; +{$endif OK} +Begin +{$ifdef OK} + Signal(SIGSEGV,signalhandler(@our_sig)); + { generate a sigsegv by writing to null-address } + sel:=0; + v:=nil; +{$ifdef go32v2} + { on win9X no zero page protection :( } + v:=pointer(-2); +{$endif go32v2} + word(v^):=sel; + { we should not go to here } + Writeln('Error : signal not called'); + Halt(1); +{$endif OK} +end. \ No newline at end of file diff --git a/tests/tbs/tb91.pp b/tests/tbs/tb91.pp new file mode 100644 index 0000000000..78a6982ea3 --- /dev/null +++ b/tests/tbs/tb91.pp @@ -0,0 +1,15 @@ +{ Old file: tbs0106.pp } +{ typecasts are now ignored problem (NOT A bugs) OK 0.99.1 } + +{$R-} + +{ I think this now occurs with most type casting... } +{ I think type casting is no longer considered?? } + +Var + Sel: Word; + Sel2: byte; +Begin + Sel:=word($7fffffff); + Sel2:=byte($7fff); +end. \ No newline at end of file diff --git a/tests/tbs/tb92.pp b/tests/tbs/tb92.pp new file mode 100644 index 0000000000..0b3cd52b29 --- /dev/null +++ b/tests/tbs/tb92.pp @@ -0,0 +1,34 @@ +{ Old file: tbs0107.pp } +{ shows page fault problem (run in TRUE DOS mode) OK ??.?? } + +{ PAGE FAULT PROBLEM ... TEST UNDER DOS ONLY! Not windows... } +{ -Cr -g flags } + +Program Test1; + +{$ifdef go32v2} +uses + dpmiexcp; +{$endif} + +type + myObject = object + constructor init; + procedure v;virtual; + end; + + constructor myobject.init; + Begin + end; + + procedure myobject.v; + Begin + WriteLn('Hello....'); + end; + +var + my: myobject; +Begin + my.init; + my.v; +end. diff --git a/tests/tbs/tb93.pp b/tests/tbs/tb93.pp new file mode 100644 index 0000000000..e6d8c543b0 --- /dev/null +++ b/tests/tbs/tb93.pp @@ -0,0 +1,12 @@ +{ Old file: tbs0109.pp } +{ syntax error not detected when using a set as pointer OK 0.99.1 (FK) } + +Type T = (aa,bb,cc,dd,ee,ff,gg,hh); + Tset = set of t; + +Var a: Tset; + +Begin + If (aa in a) Then begin end; + {it seems that correct code is generated, but the syntax is wrong} +End. diff --git a/tests/tbs/tb94.pp b/tests/tbs/tb94.pp new file mode 100644 index 0000000000..58499305d8 --- /dev/null +++ b/tests/tbs/tb94.pp @@ -0,0 +1,23 @@ +{ Old file: tbs0111.pp } +{ blockread(typedfile,...) is not allowed in TP7 } + +var + ft : text; + f : file of word; + i : word; + buf : string; +begin + assign(ft,'tbs0111.tmp'); + rewrite(ft); + for i:=1 to 40 do + Writeln(ft,'Dummy text to test bug 111'); + close(ft); + assign(f,'tbs0111.tmp'); + reset(f); + blockread(f,buf[1],127,i); { This is not allowed in BP7 } + buf[0]:=chr(i*2); + close(f); + writeln(i); + writeln(buf); + erase(f); +end. diff --git a/tests/tbs/tb95.pp b/tests/tbs/tb95.pp new file mode 100644 index 0000000000..c9ee0d6286 --- /dev/null +++ b/tests/tbs/tb95.pp @@ -0,0 +1,24 @@ +{ Old file: tbs0112.pp } +{ still generates an internal error 10 OK 0.99.1 (FK) } + +type + TextBuf=array[0..127] of char; + TextRec=record + BufPtr : ^textbuf; + BufPos : word; + end; + +Function ReadNumeric(var f:TextRec;var s:string;base:longint):Boolean; +{ + Read Numeric Input, if buffer is empty then return True +} +begin + while ((base>=10) and (f.BufPtr^[f.BufPos] in ['0'..'9'])) or + ((base=16) and (f.BufPtr^[f.BufPos] in ['A'..'F'])) or + ((base=2) and (f.BufPtr^[f.BufPos] in ['0'..'1'])) do + Begin + End; +end; + +begin +end. diff --git a/tests/tbs/tb96.pp b/tests/tbs/tb96.pp new file mode 100644 index 0000000000..cade856486 --- /dev/null +++ b/tests/tbs/tb96.pp @@ -0,0 +1,16 @@ +{ Old file: tbs0113.pp } +{ point initialization problems OK 0.99.1 (PM/FK) } + +program test; + +type pRecord = ^aRecord; + aRecord = record + next : pRecord; + a, b, c : integer; + end; + +const rec1 : aRecord = (next : nil; a : 10; b : 20; c : 30); + rec2 : aRecord = (next : @rec1; a : 20; b : 30; c : 40); + +begin +end. diff --git a/tests/tbs/tb97.pp b/tests/tbs/tb97.pp new file mode 100644 index 0000000000..1512913fa0 --- /dev/null +++ b/tests/tbs/tb97.pp @@ -0,0 +1,6 @@ +{ Old file: tbs0114.pp } +{ writeln problem (by Pavel Ozerski) OK 0.99.1 (PFV) } + +begin + write{ln}(0.997:0:2); +end. diff --git a/tests/tbs/tb98.pp b/tests/tbs/tb98.pp new file mode 100644 index 0000000000..d61f6ffb3d --- /dev/null +++ b/tests/tbs/tb98.pp @@ -0,0 +1,14 @@ +{ Old file: tbs0115.pp } +{ missing writeln for comp data type OK 0.99.6 (FK) } + +var + c : comp; + +begin + c:=1234; + writeln(c); + {readln(c);} + c:=-258674; + writeln(c); +end. + diff --git a/tests/tbs/tb99.pp b/tests/tbs/tb99.pp new file mode 100644 index 0000000000..9b41c3a548 --- /dev/null +++ b/tests/tbs/tb99.pp @@ -0,0 +1,12 @@ +{ Old file: tbs0116.pp } +{ when local variable size is > $ffff, enter can't be used to create the stack frame, but it is with -Og } + +Procedure test; +{compile with -Og to show bug} + +Var a: Array[1..4000000] of longint; +Begin +End; + +Begin +End. diff --git a/tests/test/README b/tests/test/README new file mode 100644 index 0000000000..4a64be972d --- /dev/null +++ b/tests/test/README @@ -0,0 +1,64 @@ +This directory contains tests for several parts of the compiler and RTL + +Compiler +-------- +Shortstrings .......... tstring1.pp compatibility and speed of shortstrings + tstring2.pp some misc. tests mainly collected + from bug reports + tstring3.pp Typed Constant string loading from + other constants + tstring4.pp Ansistring #1 + tstring5.pp Ansistring #2 +Classes ............... tclass1.pp AfterConstruction + tclass2.pp BeforeDestruction +Objects ............... tobject1.pp Fail in constructor +Exceptions ............ texception1.pp + texception2.pp + texception3.pp + texception4.pp Math exceptions +Procedure Variable .... tprocvar1.pp + tprocvar2.pp +Libraries ............. testlib.pp a very primitive test +Parameter passing ..... tpara1.pp Out Parameter + +input/output .......... tinoutres.pp tests inoutres values of invalid + operations +Units ................. testu1.pp tests init. & finalization and halt + testu2.pp in finalization + testu3.pp a type redefining problem + testu4.pp + testu5.pp +case .................. tcase1.pp tests case statements with byte and word + sized decision variables + tcase2.pp tests case with sub enum types +Arrays ................ tarray1.pp open arrays with classes + tarray2.pp Array of const + tarray3.pp Array of Char #1 + tarray4.pp Array of Char #2 +Enumerations .......... tenum1.pp tests assignments of subrange + enumerations +Codegenerration ....... tcg1.pp i386 pushw + tcg2.pp saveregisters +Inline ................ tinline1.pp tests recursive inlining, inlining + a procedure multiple times and + inlining procedures in other + inline procedures. +TypeInfo .............. trtti2.pp test the function system.typeinfo + trtti3.pp tests the procedure system.finalize +Resourcestrings ....... tresstr.pp tests a simple resource string +Range checking ........ trange1.pp range checking when converting int64/ + qword to longint/cardinal + trange2.pp range checking when converting + between longint and cardinal + trange3.pp range checking for array +Random ................ trandom.pp tests random (interactive) +Floating Point ........ tfpu1.pp + tfpu2.pp + +RTL +--- +str/write(real_type) .. tstrreal1.pp test correct rounding + tstrreal2.pp test correct writing of 10 till 1e-24 +Heap .................. theap.pp Heap manager test +Dos unit .............. tdos.pp tests most dos unit functions (interactive) +Crt unit .............. tcrt.pp tests most crt unit functions (interactive) diff --git a/tests/test/tarray1.pp b/tests/test/tarray1.pp new file mode 100644 index 0000000000..c10befa9f9 --- /dev/null +++ b/tests/test/tarray1.pp @@ -0,0 +1,19 @@ +{$mode objfpc} +type + tc1 = class + end; + + tc2 = class(tc1) + end; + + tcoc1 = class of tc1; + tcoc2 = class of tc2; + +procedure p(const a : array of tcoc1); + + begin + end; + +begin + p([tc2]); +end. diff --git a/tests/test/tarray2.pp b/tests/test/tarray2.pp new file mode 100644 index 0000000000..5b5c3821f2 --- /dev/null +++ b/tests/test/tarray2.pp @@ -0,0 +1,111 @@ +{$mode objfpc} +Program TestAOC; + +{ Program to test array of const } + +{ All elements of the following record must be tested : + Elements not yet tested are commented out. + + Type + PVarRec = ^TVarRec; + TVarRec = record + case vType: Byte of + vtInteger : (VInteger: Integer; VType:Longint); + vtBoolean : (VBoolean: Boolean); + vtChar : (VChar: Char); + vtExtended : (VExtended: PExtended); + vtString : (VString: PShortString); + vtPointer : (VPointer: Pointer); + vtPChar : (VPChar: PChar); + vtObject : (VObject: TObject); + vtClass : (VClass: TClass); + // vtWideChar : (VWideChar: WideChar); + // vtPWideChar : (VPWideChar: PWideChar); + vtAnsiString : (VAnsiString: Pointer); + // vtCurrency : (VCurrency: PCurrency); + // vtVariant : (VVariant: PVariant); + // vtInterface : (VInterface: Pointer); + // vtWideString : (VWideString: Pointer); + vtInt64 : (VInt64: PInt64); + vtQWord : (VQWord: PQWord); + end; +} + +procedure testit2 (args: array of byte); +begin +end; + +Procedure Testit (Args: Array of const); + +Var I : longint; + +begin + If High(Args)<0 then + begin + Writeln ('No aguments'); + exit; + end; + Writeln ('Got ',High(Args)+1,' arguments :'); + For i:=0 to High(Args) do + begin + write ('Argument ',i,' has type '); + case Args[i].vtype of + vtinteger : Writeln ('Integer, Value :',args[i].vinteger); + vtboolean : Writeln ('Boolean, Value :',args[i].vboolean); + vtchar : Writeln ('Char, value : ',args[i].vchar); + vtextended : Writeln ('Extended, value : ',args[i].VExtended^); + vtString : Writeln ('ShortString, value :',args[i].VString^); + vtPointer : Writeln ('Pointer, value : ',Longint(Args[i].VPointer)); + vtPChar : Writeln ('PCHar, value : ',Args[i].VPChar); + vtObject : Writeln ('Object, name : ',Args[i].VObject.Classname); + vtClass : Writeln ('Class reference, name : ',Args[i].VClass.Classname); + vtAnsiString : Writeln ('AnsiString, value :',AnsiString(Args[I].VAnsiString)); + +{ + vtWideChar : (VWideChar: WideChar); + vtPWideChar : (VPWideChar: PWideChar); + vtCurrency : (VCurrency: PCurrency); + vtVariant : (VVariant: PVariant); + vtInterface : (VInterface: Pointer); + vtWideString : (VWideString: Pointer); +} + vtInt64 : Writeln ('Int64, value : ',args[i].VInt64^); + vtQWord : Writeln ('QWord, value : ',args[i].VQWord^); + else + Writeln ('(Unknown) : ',args[i].vtype); + end; + end; +end; + +Const P1 : Pchar = 'Eerste Pchar'; + p2 : Pchar = 'Tweede pchar'; + +Var ObjA,ObjB : TObject; + ACLass,BClass : TClass; + S,T : AnsiString; + +begin + ObjA:=TObject.Create; + ObjB:=TObject.Create; + AClass:=TObject; + S:='Ansistring 1'; + T:='AnsiString 2'; + writeln ('Size of VarRec : ',Sizeof(TVarRec)); + Testit ([]); + Testit ([1,2]); + Testit (['A','B']); + Testit ([TRUE,FALSE,TRUE]); + Testit (['String','Another string']); + Testit ([S,T]) ; + Testit ([P1,P2]); + Testit ([@testit,Nil]); + Testit ([ObjA,ObjB]); + Testit ([1.234,1.234]); + TestIt ([AClass]); + TestIt ([QWord(1234)]); + TestIt ([Int64(1234)]); + TestIt ([Int64(12341234)*1000000000+Int64(12341234)]); + + TestIt2 ([]); + TestIt2 ([1,2]); +end. diff --git a/tests/test/tarray3.pp b/tests/test/tarray3.pp new file mode 100644 index 0000000000..086d8b94f2 --- /dev/null +++ b/tests/test/tarray3.pp @@ -0,0 +1,157 @@ +{$P+} + +type + CharA4 = array [1..4] of char; + CharA6 = array [1..6] of char; + String4 = String[4]; + String5 = String[5]; + String6 = String[6]; + String8 = String[8]; + +const + car4_1 : CharA4 = 'ABCD'; + car4_2 : CharA4 = 'abcd'; + car6_1 : CharA6 = 'EFGHIJ'; + car6_2 : CharA6 = 'efghij'; + cst4_1 : String4 = 'ABCD'; + cst6_2 : string6 = 'EFGHIJ'; + cst8_1 : string8 = 'abcd'; + cst8_2 : string8 = 'efghij'; + +var + ar4_1, ar4_2 : CharA4; + ar6_1, ar6_2 : CharA6; + st4_1, st4_2 : string4; + st5_1, st5_2 : string5; + st6_1, st6_2 : string6; + st8_1, st8_2 : string8; + pc : pchar; + +const + has_errors : boolean = false; + + procedure error(const st : string); + begin + Writeln('Error: ',st); + has_errors:=true; + end; + + procedure testvalueconv(st : string4); + begin + Writeln('st=',st); + Writeln('Length(st)=',Length(st)); + If Length(st)>4 then + Error('string length too big in calling value arg'); + end; + + procedure testconstconv(const st : string4); + begin + Writeln('st=',st); + Writeln('Length(st)=',Length(st)); + If Length(st)>4 then + Error('string length too big in calling const arg'); + end; + + procedure testvarconv(var st : string4); + begin + Writeln('st=',st); + Writeln('Length(st)=',Length(st)); + If Length(st)>4 then + Error('string length too big in calling var arg'); + end; + +{$P-} + procedure testvarconv2(var st : string4); + begin + Writeln('st=',st); + Writeln('Length(st)=',Length(st)); + If Length(st)>4 then + Error('string length too big in calling var arg without openstring'); + end; + +begin + { compare array of char to constant strings } + Writeln('Testing if "',car4_1,'" is equal to "',cst4_1,'"'); + if car4_1<>cst4_1 then + error('Comparison of array of char and string don''t work'); + Writeln('Testing if "',car4_1,'" is equal to "ABCD"'); + if car4_1<>'ABCD' then + error('Comparison of array of char and constat string don''t work'); + Writeln('Testing if "',cst4_1,'" is equal to "ABCD"'); + if 'ABCD'<>cst4_1 then + error('Comparison of string and constant string don''t work'); + car4_1:='AB'#0'D'; + if car4_1='AB' then + Writeln('Anything beyond a #0 is ignored') + else if car4_1='AB'#0'D' then + Writeln('Chars after #0 are not ignored') + else + Error('problems if #0 in array of char'); +{$ifdef FPC this is not allowed in BP !} + car4_1:=cst4_1; +{ if it is allowed then it must also work correctly !! } + Writeln('Testing if "',car4_1,'" is equal to "',cst4_1,'"'); + if car4_1<>cst4_1 then + error('Comparison of array of char and string don''t work'); + if string4(car6_2)<>'efgh' then + error('typcasting to shorter strings leads to problems'); + ar4_2:='Test'; + ar4_1:=cst6_2; + if ar4_2<>'Test' then + error('overwriting beyond char array size'); + ar6_1:='Test'#0'T'; + st6_1:=ar6_1; + if (st6_1<>ar6_1) or (st6_1='Test') then + error('problems with #0'); + ar6_1:='AB'; + if ar6_1='AB'#0't'#0'T' then + Error('assigning strings to array of char does not zero end of array if string is shorter'); + if ar6_1='AB'#0#0#0#0 then + writeln('assigning shorter strings to array of char does zero fo tserarray') + else + error('assigning "AB" to ar6_1 gives '+ar6_1); +{$endif} + cst8_1:=car4_1; +{ if it is allowed then it must also work correctly !! } + Writeln('Testing if "',car4_1,'" is equal to "',cst8_1,'"'); + if car4_1<>cst8_1 then + error('Comparison of array of char and string don''t work'); + st4_2:='Test'; + st4_1:=car6_1; + if (st4_2<>'Test') or (st4_1<>'EFGH') then + error('problems when copying long char array to shorter string'); + testvalueconv('AB'); + testvalueconv('ABCDEFG'); + testvalueconv(car4_1); + testvalueconv(car6_1); + getmem(pc,256); + pc:='Long Test'; +{$ifdef FPC this is not allowed in BP !} + testvalueconv(pc); +{$endif def FPC this is not allowed in BP !} + testconstconv('AB'); + testconstconv('ABCDEFG'); + testconstconv(st4_1); + testconstconv(cst6_2); +{$ifdef FPC this is not allowed in BP !} + testconstconv(pc); +{$endif def FPC this is not allowed in BP !} + testvarconv(st4_2); + testvarconv(cst4_1); +{$ifdef FPC this is not allowed in BP !} + testvarconv(st6_1); + testvarconv(cst8_1); +{$endif def FPC this is not allowed in BP !} + { testvarconv(pc); this one fails at compilation } + testvarconv2(st4_2); + testvarconv2(cst4_1); +{$ifdef FPC this is not allowed in BP !} + testvarconv2(st6_1); + testvarconv2(cst8_1); +{$endif def FPC this is not allowed in BP !} + if has_errors then + begin + Writeln('There are still problems with arrays of char'); + Halt(1); + end; +end. diff --git a/tests/test/tarray4.pp b/tests/test/tarray4.pp new file mode 100644 index 0000000000..b1dd3e3f71 --- /dev/null +++ b/tests/test/tarray4.pp @@ -0,0 +1,142 @@ +{$P-} + +type + CharA4 = array [1..4] of char; + CharA6 = array [1..6] of char; + String4 = String[4]; + String5 = String[5]; + String6 = String[6]; + String8 = String[8]; + +const + car4_1 : CharA4 = 'ABCD'; + car4_2 : CharA4 = 'abcd'; + car6_1 : CharA6 = 'EFGHIJ'; + car6_2 : CharA6 = 'efghij'; + cst4_1 : String4 = 'ABCD'; + cst6_2 : string6 = 'EFGHIJ'; + cst8_1 : string8 = 'abcd'; + cst8_2 : string8 = 'efghij'; + +var + ar4_1, ar4_2 : CharA4; + ar6_1, ar6_2 : CharA6; + st4_1, st4_2 : string4; + st5_1, st5_2 : string5; + st6_1, st6_2 : string6; + st8_1, st8_2 : string8; + pc : pchar; + +const + has_errors : boolean = false; + + procedure error(const st : string); + begin + Writeln('Error: ',st); + has_errors:=true; + end; + + procedure testvalueconv(st : string4); + begin + Writeln('st=',st); + Writeln('Length(st)=',Length(st)); + If Length(st)>4 then + Error('string length too big in calling value arg'); + end; + + procedure testconstconv(const st : string4); + begin + Writeln('st=',st); + Writeln('Length(st)=',Length(st)); + If Length(st)>4 then + Error('string length too big in calling const arg'); + end; + + procedure testvarconv(var st : string4); + begin + Writeln('st=',st); + Writeln('Length(st)=',Length(st)); + If Length(st)>4 then + Error('string length too big in calling var arg'); + end; + +begin + { compare array of char to constant strings } + Writeln('Testing if "',car4_1,'" is equal to "',cst4_1,'"'); + if car4_1<>cst4_1 then + error('Comparison of array of char and string don''t work'); + Writeln('Testing if "',car4_1,'" is equal to "ABCD"'); + if car4_1<>'ABCD' then + error('Comparison of array of char and constat string don''t work'); + Writeln('Testing if "',cst4_1,'" is equal to "ABCD"'); + if 'ABCD'<>cst4_1 then + error('Comparison of string and constant string don''t work'); + car4_1:='AB'#0'D'; + if car4_1='AB' then + Writeln('Anything beyond a #0 is ignored') + else if car4_1='AB'#0'D' then + Writeln('Chars after #0 are not ignored') + else + Error('problems if #0 in array of char'); +{$ifdef FPC this is not allowed in BP !} + car4_1:=cst4_1; +{ if it is allowed then it must also work correctly !! } + Writeln('Testing if "',car4_1,'" is equal to "',cst4_1,'"'); + if car4_1<>cst4_1 then + error('Comparison of array of char and string don''t work'); + if string4(car6_2)<>'efgh' then + error('typcasting to shorter strings leads to problems'); + ar4_2:='Test'; + ar4_1:=cst6_2; + if ar4_2<>'Test' then + error('overwriting beyond char array size'); + ar6_1:='Test'#0'T'; + st6_1:=ar6_1; + if (st6_1<>ar6_1) or (st6_1='Test') then + error('problems with #0'); + ar6_1:='AB'; + if ar6_1='AB'#0't'#0'T' then + Error('assigning strings to array of char does not zero end of array if string is shorter'); + if ar6_1='AB'#0#0#0#0 then + writeln('assigning shorter strings to array of char does zero fo tserarray') + else + error('assigning "AB" to ar6_1 gives '+ar6_1); +{$endif} + cst8_1:=car4_1; +{ if it is allowed then it must also work correctly !! } + Writeln('Testing if "',car4_1,'" is equal to "',cst8_1,'"'); + if car4_1<>cst8_1 then + error('Comparison of array of char and string don''t work'); + st4_2:='Test'; + st4_1:=car6_1; + if (st4_2<>'Test') or (st4_1<>'EFGH') then + error('problems when copying long char array to shorter string'); + testvalueconv('AB'); + testvalueconv('ABCDEFG'); + testvalueconv(car4_1); + testvalueconv(car6_1); + getmem(pc,256); + pc:='Long Test'; +{$ifdef FPC this is not allowed in BP !} + testvalueconv(pc); +{$endif def FPC this is not allowed in BP !} + testconstconv('AB'); + testconstconv('ABCDEFG'); + testconstconv(st4_1); + testconstconv(cst6_2); +{$ifdef FPC this is not allowed in BP !} + testconstconv(pc); +{$endif def FPC this is not allowed in BP !} + testvarconv(st4_2); + testvarconv(cst4_1); +{$ifdef FPC this is not allowed in BP !} + testvarconv(st6_1); + testvarconv(cst8_1); +{$endif def FPC this is not allowed in BP !} + { testvarconv(pc); this one fails at compilation } + if has_errors then + begin + Writeln('There are still problems with arrays of char'); + Halt(1); + end; +end. diff --git a/tests/test/tcase1.pp b/tests/test/tcase1.pp new file mode 100644 index 0000000000..7ab8ab8854 --- /dev/null +++ b/tests/test/tcase1.pp @@ -0,0 +1,56 @@ +program test_case; +function case1(Val : byte) : char; +begin + case Val of + 0..25 : case1:=chr(Val + ord('A')); + 26..51: case1:=chr(Val + ord('a') - 26); + 52..61: case1:=chr(Val + ord('0') - 52); + 62 : case1:='+'; + 63 : case1:='/'; + else + case1:='$'; + end; +end; + +function case2(Val : integer) : integer; +begin + case Val of + -1 : case2:=1; + 32765.. + 32767 : case2:=2; + else + case2:=-1; + end; +end; + +function case3(Val : integer) : integer; +begin + case Val of + -32768.. + -32766 : case3:=1; + 0..10 : case3:=2; + else + case3:=-1; + end; +end; + +var + error: boolean; + +begin + { The correct outputs should be: + F $ + 2 2 + 1 2 2 + } + error := false; + writeln(case1(5), ' ', case1(255),' (should be: F $)'); + error := (case1(5) <> 'F') or (case1(255) <> '$'); + writeln(case2(32765), ' ', case2(32767),' (should be: 2 2)'); + error := error or (case2(32765) <> 2) or (case2(32767) <> 2); + writeln(case3(-32768),' ',case3(0), ' ',case3(5),' (should be: 1 2 2)'); + error := error or (case3(-32768) <> 1) or (case3(0) <> 2) or + (case3(5) <> 2); + if error then + halt(1); +end. \ No newline at end of file diff --git a/tests/test/tcase2.pp b/tests/test/tcase2.pp new file mode 100644 index 0000000000..34f014493b --- /dev/null +++ b/tests/test/tcase2.pp @@ -0,0 +1,21 @@ +type + days = (sun,mon,tue,wed,thu,fri,sat); + workdays = mon..fri; + +procedure t(d: workdays); + begin + case d of + mon: writeln('monday'); + thu: writeln('thursday'); + else + writeln('error'); + end; + end; + +var + d: workdays; + +begin + d := thu; + t(d); +end. diff --git a/tests/test/tcg1.pp b/tests/test/tcg1.pp new file mode 100644 index 0000000000..605f15f642 --- /dev/null +++ b/tests/test/tcg1.pp @@ -0,0 +1,76 @@ +{ %CPU=i386 } +{$R-} +program test_register_pushing; + +var + before, after : longint; + wpush,lpush : longint; +const + haserror : boolean = false; + +begin +{$ifdef CPUI386} +{$asmmode att} + asm + movl %esp,before + pushw %es + movl %esp,after + popw %es + end; + wpush:=before-after; + if wpush<>2 then + begin + Writeln('Compiler does not push "pushw %es" into 2 bytes'); + haserror:=true; + end; + asm + movl %esp,before + pushl %es + movl %esp,after + popl %es + end; + lpush:=before-after; + + if lpush<>4 then + begin + Writeln('Compiler does not push "pushl %es" into 4 bytes'); + haserror:=true; + end; + + asm + movl %esp,before + pushw %gs + movl %esp,after + popw %gs + end; + wpush:=before-after; + if wpush<>2 then + begin + Writeln('Compiler does not push "pushw %gs" into 2 bytes'); + haserror:=true; + end; + asm + movl %esp,before + pushl %gs + movl %esp,after + popl %gs + end; + lpush:=before-after; + + if lpush<>4 then + begin + Writeln('Compiler does not push "pushl %gs" into 4 bytes'); + haserror:=true; + end; +{$asmmode intel} + asm + mov before,esp + push es + mov after,esp + pop es + end; + Writeln('Intel "push es" uses ',before-after,' bytes'); +{$endif CPUI386} + if haserror then + Halt(1); +end. \ No newline at end of file diff --git a/tests/test/tcg2.pp b/tests/test/tcg2.pp new file mode 100644 index 0000000000..b2f1fa5130 --- /dev/null +++ b/tests/test/tcg2.pp @@ -0,0 +1,18 @@ +{ %CPU=i386 } + +function x : longint;saveregisters; +begin + x:=34; +end; + +var + y : longint; +begin + asm + movl $15,%eax + end; + y:=x; + Writeln(y); + if y<>34 then + halt(1); +end. \ No newline at end of file diff --git a/tests/test/tclass1.pp b/tests/test/tclass1.pp new file mode 100644 index 0000000000..95b124abfa --- /dev/null +++ b/tests/test/tclass1.pp @@ -0,0 +1,40 @@ +{$mode objfpc} + +type + to1 = class + constructor create; + procedure afterconstruction;override; + end; + +var + i : longint; + + constructor to1.create; + + begin + inherited create; + if i<>1000 then + halt(1); + i:=2000; + end; + + procedure to1.afterconstruction; + + begin + if i<>2000 then + halt(1); + i:=3000; + end; + +var + o1 : to1; + +begin + i:=1000; + o1:=to1.create; + if i<>3000 then + halt(1); + o1.destroy; + writeln('ok'); +end. + diff --git a/tests/test/tclass2.pp b/tests/test/tclass2.pp new file mode 100644 index 0000000000..a6e4dd6823 --- /dev/null +++ b/tests/test/tclass2.pp @@ -0,0 +1,40 @@ +{$mode objfpc} + +type + to1 = class + destructor destroy;override; + procedure beforedestruction;override; + end; + +var + i : longint; + + destructor to1.destroy; + + begin + if i<>2000 then + halt(1); + i:=3000; + inherited destroy; + end; + + procedure to1.beforedestruction; + + begin + if i<>1000 then + halt(1); + i:=2000; + end; + +var + o1 : to1; + +begin + o1:=to1.create; + i:=1000; + o1.destroy; + if i<>3000 then + halt(1); + writeln('ok'); +end. + diff --git a/tests/test/tclass3.pp b/tests/test/tclass3.pp new file mode 100644 index 0000000000..e3def7183b --- /dev/null +++ b/tests/test/tclass3.pp @@ -0,0 +1,30 @@ +{$ifdef fpc} + {$mode delphi} +{$endif} +type + TMyComponent = class + public + constructor Create(k1:longint;k2: shortstring); + destructor Destroy;override; + end; + + TMyComponent1 = class(TMyComponent) + public + constructor Create(l1:longint;l2:shortstring); + end; + +constructor TMyComponent.Create(k1:longint;k2:shortstring); +begin +end; + +destructor TMyComponent.Destroy; +begin +end; + +constructor TMyComponent1.Create(l1:longint;l2:shortstring); +begin + inherited; +end; + +begin +end. diff --git a/tests/test/tcrt.pp b/tests/test/tcrt.pp new file mode 100644 index 0000000000..638d0ab937 --- /dev/null +++ b/tests/test/tcrt.pp @@ -0,0 +1,106 @@ +{ %INTERACTIVE } +{ + $Id$ + + Program to test CRT unit by Mark May. + Only standard TP functions are tested (except WhereX, WhereY). +} +program tesicrt; + +uses crt; +var + i,j : longint; + fil : text; + c : char; +begin +{Window/AssignCrt/GotoXY} + clrscr; + writeln ('This should be on a clear screen...'); + gotoxy (10,10); + writeln ('(10,10) is the coordinate of this sentence'); + window (10,11,70,22); + writeln ('Window (10,11,70,22) executed.'); + writeln ('Sending some output to a file, assigned to crt.'); + assigncrt ( fil); + rewrite (fil); + writeln (fil,'This was written to the file, assigned to the crt.'); + writeln (fil,'01234567890123456789012345678901234567890123456789012345678901234567890'); + close (fil); + writeln ('The above too, but this not any more'); + write ('Press any key to continue'); + c:=readkey; + clrscr; + writeln ('the small window should have been cleared.'); + write ('Press any key to continue'); + c:=readkey; + +{Colors/KeyPressed} + window (1,1,80,25); + clrscr; + writeln ('Color testing :'); + writeln; + highvideo; + write ('highlighted text'); + normvideo; + write (' normal text '); + lowvideo; + writeln ('And low text.'); + writeln; + writeln ('Color chart :'); + for i:=black to lightgray do + begin + textbackground (i); + textcolor (0); + write ('backgr. : ',i:2,' '); + for j:= black to white do + begin + textcolor (j); + write (' ',j:2,' '); + end; + writeln; + end; + normvideo; + writeln ('The same, with blinking foreground.'); + for i:=black to lightgray do + begin + textbackground (i); + textcolor (0); + write ('backgr. : ',i:2,' '); + for j:= black to white do + begin + textcolor (j+128); + write (' ',j:2,' '); + end; + writeln; + end; + textcolor (white); + textbackground (black); + writeln; + writeln ('press any key to continue'); + repeat until keypressed; + c:=readkey; + +{ClrEol/DelLine/InsLine} + clrscr; + writeln ('Testing some line functions :'); + writeln ; + writeln ('This line should become blank after you press enter'); + writeln; + writeln ('The following line should then become blank from column 10'); + writeln ('12345678901234567890'); + writeln; + writeln ('This line should dissapear.'); + writeln; + writeln ('Between this line and the next, an empty line should appear.'); + writeln ('This is the next line, above which the empty one should appear'); + writeln; + write ('Press any key to observe the predicted effects.'); + readkey; + gotoxy(1,3);clreol; + gotoxy (10,6);clreol; + gotoxy (1,8);delline; + gotoxy (1,10); insline; + gotoxy (17,13); clreol; + writeln ('end.'); + readkey; +end. diff --git a/tests/test/tdos.pp b/tests/test/tdos.pp new file mode 100644 index 0000000000..d94ae536cc --- /dev/null +++ b/tests/test/tdos.pp @@ -0,0 +1,177 @@ +{ %INTERACTIVE } +{ + $Id$ + + Program to test DOS unit by Peter Vreman. + Only main TP functions are tested (nothing with Interrupts/Break/Verify). +} +{$V-} +program tesidos; +uses dos; + +procedure TestInfo; +var + dt : DateTime; + ptime : longint; + wday : word; + HSecs : word; +begin + writeln; + writeln('Info Functions'); + writeln('**************'); + writeln('Dosversion : ',lo(DosVersion),'.',hi(DosVersion)); + GetDate(Dt.Year,Dt.Month,Dt.Day,wday); + writeln('Current Date : ',Dt.Month,'-',Dt.Day,'-',Dt.Year,' weekday ',wday); + GetTime(Dt.Hour,Dt.Min,Dt.Sec,HSecs); + writeln('Current Time : ',Dt.Hour,':',Dt.Min,':',Dt.Sec,' hsecs ',HSecs); + PackTime(Dt,ptime); + writeln('Packed like dos: ',ptime); + UnpackTime(ptime,DT); + writeln('Unpacked again : ',Dt.Month,'-',Dt.Day,'-',Dt.Year,' ',Dt.Hour,':',Dt.Min,':',Dt.Sec); + writeln; + write('Press Enter'); + Readln; +end; + + +procedure TestEnvironment; +var + i : longint; +begin + writeln; + writeln('Environment Functions'); + writeln('*********************'); + writeln('Amount of environment strings : ',EnvCount); + writeln('GetEnv TERM : ',GetEnv('TERM')); + writeln('GetEnv HOST : ',GetEnv('HOST')); + writeln('GetEnv PATH : ',GetEnv('PATH')); + writeln('GetEnv SHELL: ',GetEnv('SHELL')); + write('Press Enter for all Environment Strings using EnvStr()'); + Readln; + for i:=1 to EnvCount do + writeln(EnvStr(i)); + write('Press Enter'); + Readln; +end; + + +procedure TestExec; +begin + writeln; + writeln('Exec Functions'); + writeln('**************'); + write('Press Enter for an Exec of ''ls -la'''); + Readln; +{$ifdef linux } + Exec('ls','-la'); +{$else not linux } + SwapVectors; + Exec('ls','-la'); + SwapVectors; +{$endif not linux } + write('Press Enter'); + Readln; +end; + + + +procedure TestDisk; +var + Dir : SearchRec; +begin + writeln; + writeln('Disk Functions'); + writeln('**************'); + writeln('DiskFree 0 : ',DiskFree(0)); + writeln('DiskSize 0 : ',DiskSize(0)); + {writeln('DiskSize 1 : ',DiskSize(1)); this is a: on dos ??! } + writeln('DiskSize 1 : ',DiskSize(3)); { this is c: on dos } +{$IFDEF LINUX} + AddDisk('/fd0'); + writeln('DiskSize 4 : ',DiskSize(4)); +{$ENDIF} + write('Press Enter for FindFirst/FindNext Test'); + Readln; + + FindFirst('*.*',$20,Dir); + while (DosError=0) do + begin + Writeln(dir.Name,' ',dir.Size); + FindNext(Dir); + end; + write('Press Enter'); + Readln; +end; + + + +procedure TestFile; +var + test, + name,dir,ext : string; +begin + writeln; + writeln('File(name) Functions'); + writeln('********************'); +{$ifdef linux } + test:='/usr/local/bin/ppc.so'; + writeln('FSplit(',test,')'); + FSplit(test,dir,name,ext); + writeln('dir: ',dir,' name: ',name,' ext: ',ext); + test:='/usr/bin.1/ppc'; + writeln('FSplit(',test,')'); + FSplit(test,dir,name,ext); + writeln('dir: ',dir,' name: ',name,' ext: ',ext); + test:='mtools.tar.gz'; + writeln('FSplit(',test,')'); + FSplit(test,dir,name,ext); + writeln('dir: ',dir,' name: ',name,' ext: ',ext); + + Writeln('Expanded dos.pp : ',FExpand('dos.pp')); + Writeln('Expanded ../dos.pp : ',FExpand('../dos.pp')); + Writeln('Expanded /usr/local/dos.pp : ',FExpand('/usr/local/dos.pp')); + Writeln('Expanded ../dos/./../././dos.pp : ',FExpand('../dos/./../././dos.pp')); + + test:='../;/usr/;/usr/bin/;/usr/bin;/bin/;'; +{$else not linux } + test:='\usr\local\bin\ppc.so'; + writeln('FSplit(',test,')'); + FSplit(test,dir,name,ext); + writeln('dir: ',dir,' name: ',name,' ext: ',ext); + test:='\usr\bin.1\ppc'; + writeln('FSplit(',test,')'); + FSplit(test,dir,name,ext); + writeln('dir: ',dir,' name: ',name,' ext: ',ext); + test:='mtools.tar.gz'; + writeln('FSplit(',test,')'); + FSplit(test,dir,name,ext); + writeln('dir: ',dir,' name: ',name,' ext: ',ext); + + Writeln('Expanded dos.pp : ',FExpand('dos.pp')); + Writeln('Expanded ..\dos.pp : ',FExpand('..\dos.pp')); + Writeln('Expanded \usr\local\dos.pp : ',FExpand('\usr\local\dos.pp')); + Writeln('Expanded ..\dos\.\..\.\.\dos.pp : ',FExpand('..\dos\.\..\.\.\dos.pp')); + + test:='..\;\usr\;\usr\bin\;\usr\bin;\bin\;'; +{$endif not linux} + test:=test+getenv('PATH'); +{$ifdef linux} + Writeln('FSearch ls: ',FSearch('ls',test)); +{$else not linux} + Writeln('FSearch ls: ',FSearch('ls.exe',test)); +{$endif not linux} + + write('Press Enter'); + Readln; +end; + + + +begin + TestInfo; + TestEnvironment; + TestExec; + TestDisk; + TestFile; +end. + diff --git a/tests/test/tenum1.pp b/tests/test/tenum1.pp new file mode 100644 index 0000000000..c77f66a4f3 --- /dev/null +++ b/tests/test/tenum1.pp @@ -0,0 +1,14 @@ +type + days = (mon,tue,wed,thu,fri,sat,sun); + weekend = sat..sun; + +procedure t2(day: weekend); +begin + if day = sat then + writeln('ok') + else writeln('error'); +end; + +begin + t2(sat); +end. diff --git a/tests/test/texception1.pp b/tests/test/texception1.pp new file mode 100644 index 0000000000..c7fc42e841 --- /dev/null +++ b/tests/test/texception1.pp @@ -0,0 +1,202 @@ +{ %RESULT=217 } +program testexceptions; + +{$mode objfpc} + +Type + TAObject = class(TObject) + a : longint; + end; + TBObject = Class(TObject) + b : longint; + end; + +Procedure raiseanexception; + +Var A : TAObject; + +begin + Writeln ('Creating exception object'); + A:=TAObject.Create; + Writeln ('Raising with this object'); + raise A; + Writeln ('This can''t happen'); +end; + +Var MaxLevel : longint; + +Procedure DoTryFinally (Level : Longint; DoRaise : Boolean); + + +Var Raised,Reraised : Boolean; + I : Longint; + +begin + Try + writeln ('Try(',level,') : Checking for exception'); + If Level=MaxLevel then + begin + if DoRaise then + begin + Writeln ('Try(',level,'): Level ',maxlevel,' reached, raising exception.'); + Raiseanexception + end + else + Writeln ('Try(',Level,'): Not raising exception') + end + else + begin + Writeln ('Try(',level,') : jumping to next level'); + DoTryFinally(Level+1,DoRaise); + end; + finally + Writeln ('Finally (',level,'): Starting code.'); + end; + writeln ('Out of try/finally at level (',level,')'); +end; + +Procedure DoTryExcept (Level : Longint; DoRaise : Boolean); + +Var Raised : Boolean; + I : Longint; + Caught : TObject; + +begin + Try + writeln ('Try(',level,') : Checking for exception'); + If Level=MaxLevel then + if DoRaise then + begin + Writeln ('Try(',level,'): Level ',maxlevel,', raising exception.'); + Raiseanexception + end + else + Writeln ('Try(',Level,'): level ',maxlevel,'. Not raising exception') + else + begin + Writeln ('Try(',level,') : jumping to next level'); + DoTryExcept(Level+1,DoRaise); + end; + except + On TAObject do Writeln ('Exception was caught by TAObject'); + On TBobject do Writeln ('Exception was caught by TBObject'); + On E : TObject do Writeln ('Caught object ',E.ClassName); +// writeln ('Except (',level,') : Exception caught by default handler'); + end; + writeln ('Out of try/except at level (',level,')'); +end; + +Procedure DoMix (Level : Longint; DoRaise : Boolean); + +Var Raised : Boolean; + I : Longint; + Caught : TObject; + +begin + Try + Try + writeln ('Try(',level,') : Checking for exception'); + If Level=MaxLevel then + if DoRaise then + begin + Writeln ('Try(',level,'): Level ',maxlevel,', raising exception.'); + Raiseanexception + end + else + Writeln ('Try(',Level,'): level ',maxlevel,'. Not raising exception') + else + begin + Writeln ('Try(',level,') : jumping to next level'); + DoMix(Level+1,DoRaise); + end; + finally + Writeln ('Mix:Finally (',level,'): Starting code.'); + end; + Writeln ('Level (',level,') : Out of try/finally'); + except + On TAObject do Writeln ('Exception was caught by TAObject'); + On TBobject do Writeln ('Exception was caught by TBObject'); + On TObject do writeln ('Except (',level,') : Exception caught by TObject'); +// The following don't work... + On E : TObject do Writeln ('Caught object ',E.ClassName); + else + writeln ('Except (',level,') : Exception caught by default handler'); + end; + writeln ('Out of try/except at level (',level,')'); +end; + +function _dotryfinally : boolean; + +var + problem : boolean; + +begin + result:=false; + try + try + finally + writeln('Raising an exception in finally statement'); + Raiseanexception + end; + except + end; + try + exit; + finally + result:=true; + end; + writeln('Problem with finally and exit !!!!'); + halt(1); +end; + +procedure dotryfinally; + + begin + if not(_dotryfinally) then + begin + writeln('Problem with finally and exit !!!!'); + halt(1); + end; + end; + +Procedure Start(Const Msg : string); + +begin + Writeln (Msg); + Writeln; +end; + +Procedure Finish; + +begin + Writeln; + Write ('Finished.'); + { Press enter to continue.'); + Readln; tests/test/test... must be non interactive !! PM } +end; + + +begin + Maxlevel:=3; + Start ('Testing Try/Finally without raise'); + DoTryFinally (1,False); + Finish; + Start ('Testing Try/except without raise'); + DoTryExcept (1,FAlse); + Finish; + Start ('Testing Mix without raise'); + DoMix (1,False); + Finish; + Start ('Testing Try/except with raise'); + DoTryExcept (1,true); + Finish; + Start ('Testing Mix with raise'); + DoMix (1,true); + Finish; + Start ('Testing Try/Finally with Exit'); + dotryfinally; + Finish; + Writeln ('Testing Try/Finally with raise'); + Start ('This one should end with an error message !!.'); + DoTryFinally (1,True); +end. diff --git a/tests/test/texception2.pp b/tests/test/texception2.pp new file mode 100644 index 0000000000..8e70db1ecb --- /dev/null +++ b/tests/test/texception2.pp @@ -0,0 +1,26 @@ +{$mode objfpc} +uses + sysutils; + +procedure d; + + var + d1 : double; + + begin + d1:=0; + d1:=1/d1; + end; + +var + i : longint; + +begin + for i:=1 to 20 do + try + d; + except + on exception do + ; + end; +end. \ No newline at end of file diff --git a/tests/test/texception3.pp b/tests/test/texception3.pp new file mode 100644 index 0000000000..5bd4cb1103 --- /dev/null +++ b/tests/test/texception3.pp @@ -0,0 +1,776 @@ +{$mode objfpc} +uses + erroru,sysutils; + +var + i : longint; + +procedure test1; + + begin + try + i:=0; + exit; + finally + inc(i); + end; + i:=-2; + end; + +procedure test2; + + begin + try + i:=0; + raise exception.create(''); + finally + inc(i); + end; + i:=-2; + end; + +procedure test3; + + begin + try + try + i:=0; + raise exception.create(''); + finally + inc(i); + end; + finally + inc(i); + end; + i:=-2; + end; + +procedure test4; + + begin + try + try + i:=0; + exit; + finally + inc(i); + end; + finally + inc(i); + end; + i:=-2; + end; + +procedure test5; + + var + j : longint; + + begin + for j:=1 to 10 do + begin + try + i:=0; + break; + finally + inc(i); + end; + dec(i); + end; + end; + +procedure test6; + + var + j : longint; + + begin + i:=0; + for j:=1 to 10 do + begin + try + continue; + finally + inc(i); + end; + dec(i); + end; + end; + +procedure test7; + + var + j : longint; + + begin + for j:=1 to 10 do + begin + try + try + i:=0; + break; + finally + inc(i); + end; + dec(i); + finally + inc(i); + end; + end; + end; + +procedure test8; + + var + j : longint; + + begin + i:=0; + for j:=1 to 10 do + begin + try + try + continue; + finally + inc(i); + end; + finally + inc(i); + end; + dec(i); + end; + end; + + +{ some combined test ... } + +procedure test9; + + var + j : longint; + + begin + try + i:=0; + finally + for j:=1 to 10 do + begin + try + if j<2 then + continue + else + break; + finally + inc(i); + end; + dec(i); + end; + end; + end; + +procedure test10; + + var + j : longint; + + begin + try + i:=0; + j:=1; + finally + while j<=10 do + begin + try + if j<2 then + continue + else + break; + finally + inc(i); + inc(j); + end; + dec(i); + end; + end; + end; + +{ the do_raise function is a little bit more complicated } +{ so we also check if memory is lost } +function do_raise : ansistring; + + var + a1,a2 : ansistring; + j : longint; + + begin + for j:=1 to 3 do + begin + a1:=copy('Hello world',1,5); + do_raise:=copy(a2,1,1); + end; + raise exception.create('A string to test memory allocation'); + do_error(99998); + end; + + +{ now test real exceptions } +procedure test100; + + begin + try + i:=0; + do_raise; + except + inc(i); + end; + end; + +procedure test101; + + begin + try + try + i:=0; + do_raise; + except + inc(i); + do_raise; + end; + except + inc(i); + end; + end; + +procedure test102; + + begin + try + try + i:=0; + do_raise; + except + inc(i); + raise; + end; + except + inc(i); + end; + end; + +{ tests continue in try...except...end; statements } +procedure test103; + + var + j,k : longint; + + begin + i:=0; + for j:=1 to 10 do + try + for k:=1 to 10 do + try + inc(i); + if (i mod 10)>5 then + do_raise + else + continue; + except + continue + end; + if i>50 then + do_raise + else + continue; + except + continue; + end; + end; + +procedure test104; + + begin + try + i:=1; + exit; + // we should never get there + do_raise; + except + i:=-1; + end; + i:=-2; + end; + +procedure test105; + + begin + try + i:=0; + do_raise; + // we should never get there + i:=-1; + except + inc(i); + exit; + end; + end; + +procedure test106; + + begin + try + try + i:=1; + exit; + // we should never get there + do_raise; + except + i:=-1; + end; + i:=-2; + except + end; + end; + +procedure test107; + + begin + try + do_raise; + except + try + i:=0; + do_raise; + // we should never get there + i:=-1; + except + inc(i); + exit; + end; + end; + end; + +{ tests break in try...except...end; statements } +procedure test108; + + begin + i:=0; + while true do + try + while true do + try + inc(i); + break; + except + end; + inc(i); + break; + except + end; + end; + +procedure test109; + + begin + i:=0; + while true do + try + repeat + try + do_raise; + i:=-1; + except + inc(i); + break; + end; + until false; + do_raise; + i:=-1; + except + inc(i); + break; + end; + end; + +{ test the on statement } +procedure test110; + + begin + try + i:=0; + do_raise; + except + on e : exception do + inc(i); + end; + end; + +procedure test111; + + begin + try + try + i:=0; + do_raise; + except + on e : exception do + begin + inc(i); + do_raise; + end; + end; + except + on e : exception do + inc(i); + end; + end; + +procedure test112; + + begin + try + try + i:=0; + do_raise; + except + on e : exception do + begin + inc(i); + raise; + end; + end; + except + on e : exception do + inc(i); + end; + end; + +procedure test113; + + var + j,k : longint; + + begin + i:=0; + for j:=1 to 10 do + try + for k:=1 to 10 do + try + inc(i); + if (i mod 10)>5 then + do_raise + else + continue; + except + on e : exception do + continue + end; + if i>50 then + do_raise + else + continue; + except + on e : exception do + continue; + end; + end; + +procedure test114; + + begin + try + i:=1; + exit; + // we should never get there + do_raise; + except + on e : exception do + i:=-1; + end; + i:=-2; + end; + +procedure test115; + + begin + try + i:=0; + do_raise; + // we should never get there + i:=-1; + except + on e : exception do + begin + inc(i); + exit; + end; + end; + end; + +procedure test116; + + begin + try + try + i:=1; + exit; + // we should never get there + do_raise; + except + on e : exception do + i:=-1; + end; + i:=-2; + except + on e : exception do + ; + end; + end; + +procedure test117; + + begin + try + do_raise; + except + try + i:=0; + do_raise; + // we should never get there + i:=-1; + except + on e : exception do + begin + inc(i); + exit; + end; + end; + end; + end; + +{ tests break in try...except...end; statements } +procedure test118; + + begin + i:=0; + while true do + try + while true do + try + inc(i); + break; + except + on e : exception do + ; + end; + inc(i); + break; + except + on e : exception do + ; + end; + end; + +procedure test119; + + begin + i:=0; + while true do + try + repeat + try + do_raise; + i:=-1; + except + on e : exception do + begin + inc(i); + break; + end; + end; + until false; + do_raise; + i:=-1; + except + on e : exception do + begin + inc(i); + break; + end; + end; + end; + +var + startmemavail : longint; + +begin + writeln('Testing exception handling'); + startmemavail:=memavail; + i:=-1; + try + test1; + finally + inc(i); + end; + if i<>2 then + do_error(1001); + + i:=-1; + try + test2; + except + inc(i); + end; + if i<>2 then + do_error(1002); + + i:=-1; + try + test3; + except + inc(i); + end; + if i<>3 then + do_error(1003); + + i:=-1; + test4; + if i<>2 then + do_error(1004); + + i:=-1; + test5; + if i<>1 then + do_error(1005); + + i:=-1; + test6; + if i<>10 then + do_error(1006); + + i:=-1; + test7; + if i<>2 then + do_error(1007); + + i:=-1; + test8; + if i<>20 then + do_error(1008); + + i:=-1; + test9; + if i<>2 then + do_error(1009); + + i:=-1; + test10; + if i<>2 then + do_error(1010); + + i:=-1; + test100; + if i<>1 then + do_error(1100); + + i:=-1; + test101; + if i<>2 then + do_error(1101); + + i:=-1; + test102; + if i<>2 then + do_error(1102); + + i:=-1; + test103; + if i<>100 then + do_error(1103); + + + i:=-1; + test104; + if i<>1 then + do_error(1104); + + i:=-1; + test105; + if i<>1 then + do_error(1105); + + i:=-1; + test106; + if i<>1 then + do_error(1106); + + i:=-1; + test107; + if i<>1 then + do_error(1107); + + i:=-1; + test108; + if i<>2 then + do_error(1108); + + i:=-1; + test109; + if i<>2 then + do_error(1109); + + i:=-1; + test110; + if i<>1 then + do_error(1110); + + i:=-1; + test111; + if i<>2 then + do_error(1111); + + i:=-1; + test112; + if i<>2 then + do_error(1112); + + i:=-1; + test113; + if i<>100 then + do_error(1113); + + + i:=-1; + test114; + if i<>1 then + do_error(1114); + + i:=-1; + test115; + if i<>1 then + do_error(1115); + + i:=-1; + test116; + if i<>1 then + do_error(1116); + + i:=-1; + test117; + if i<>1 then + do_error(1117); + + i:=-1; + test118; + if i<>2 then + do_error(1118); + + i:=-1; + test119; + if i<>2 then + do_error(1119); + + if memavail<>startmemavail then + do_error(99999); + writeln('Test successfully passed'); + halt(0); +end. \ No newline at end of file diff --git a/tests/test/texception4.pp b/tests/test/texception4.pp new file mode 100644 index 0000000000..71ec644b99 --- /dev/null +++ b/tests/test/texception4.pp @@ -0,0 +1,126 @@ + +{$mode objfpc} + +uses + sysutils; + +const + Program_has_errors : boolean = false; + exception_called : boolean = false; + TestNumber : longint = 10000; + +procedure test_exception(const s : string); + begin + if not(exception_called) then + begin + Writeln('Exception not called : ',s); + Program_has_errors := true; + end; + end; + +var + i,j : longint; + e : extended; + exception_count,level : longint; +begin + j:=0; + i:=100; + try + exception_called:=false; + j := i div j; + except + on e : exception do + begin + Writeln('First integer exception called ',e.message); + exception_called:=true; + end; + end; + test_exception('First division by zero for integers'); + try + exception_called:=false; + j := i div j; + except + on e : exception do + begin + Writeln('Second integer exception called ',e.message); + exception_called:=true; + end; + end; + test_exception('Second division by zero for integers'); + try + exception_called:=false; + e:=i/j; + except + on e : exception do + begin + Writeln('First real exception called ',e.message); + exception_called:=true; + end; + end; + test_exception('First division by zero for reals'); + try + exception_called:=false; + e:=i/j; + except + on e : exception do + begin + Writeln('Second real exception called ',e.message); + exception_called:=true; + end; + end; + test_exception('Second division by zero for reals'); + try + exception_called:=false; + j := i div j; + except + on e : exception do + begin + Writeln('exception called ',e.message); + exception_called:=true; + end; + end; + test_exception('third division by zero for integers'); + exception_count:=0; + level:=0; + for j:=1 to TestNumber do + begin + try + i:=0; + inc(level); + e:=j/i; + except + on e : exception do + begin + inc(exception_count); + if level>1 then + Writeln('exception overrun'); + dec(level); + end; + end; + + end; + if exception_count<>TestNumber then + begin + program_has_errors:=true; + Writeln('Could not generate ',TestNumber,' consecutive exceptions'); + Writeln('Only ',exception_count,' exceptions were generated'); + end + else + begin + Writeln(TestNumber,' consecutive exceptions generated successfully'); + end; + try + exception_called:=false; + i := -1; + e := ln(i); + except + on e : exception do + begin + Writeln('exception called ',e.message); + exception_called:=true; + end; + end; + test_exception('ln(-1)'); + if program_has_errors then + Halt(1); +end. \ No newline at end of file diff --git a/tests/test/tfpu1.pp b/tests/test/tfpu1.pp new file mode 100644 index 0000000000..e13a14f47a --- /dev/null +++ b/tests/test/tfpu1.pp @@ -0,0 +1,126 @@ +{ %CPU=I386 } +program test_fp_instructions; + + + function test : extended; + + var + x,y : integer; + statusword,controlword : word; + z,t : longint; + a,b,c : comp; + begin + x:=5; + c:=5; + t:=5; + z:=4; + a:=20; + { test all FPU instructions using 's' and 'l' suffix + for word and dword size PM } +{$asmmode att} + asm + fildl z + fiadds x + fistpq b + fildl z + ficoms x + fistpq b + fildl z + ficomps x + fildl z + fidivs x + fistpq b + fildl z + fidivrs x + fistpq b + fildl z + fisubs x + fistpq b + fildl z + fisubrs x + fistpq b + fildl z + fimuls x + fistpq b + end; + if a<>b then + begin + Writeln('Error in FPU att syntax code generation'); + Halt(1); + end; + asm + fildl z + fiaddl t + fistpq b + fildl z + ficoml t + fistpq b + fildl z + ficompl t + fildl z + fidivl t + fistpq b + fildl z + fidivrl t + fistpq b + fildl z + fisubl t + fistpq b + fildl z + fisubrl t + fistpq b + fildl z + fimull t + fistpq b + end; + if a<>b then + begin + Writeln('Error in FPU att syntax code generation'); + Halt(1); + end; + { test CW and SW instructions } + { FSTSW FNSTSW + FLDCW FSTCW FNSTCW } + asm + fstsw statusword + fstsww statusword + fnstsw statusword + fnstsww statusword + fstcw controlword + fstcww controlword + fnstcw controlword + fnstcww controlword + fldcw controlword + fldcww controlword + end; +{$asmmode intel} + asm + fild dword ptr z + fimul dword ptr t + fistp qword ptr b + fild dword ptr z + fimul word ptr x + fistp qword ptr b + end; + if a<>b then + begin + Writeln('Error in FPU code generation'); + Halt(1); + end; + { test CW and SW instructions } + asm + fstsw word ptr [statusword] + fnstsw word ptr [statusword] + fstcw word ptr [controlword] + fnstcw word ptr[controlword] + fldcw word ptr [controlword] + end; + test:=b; + end; + +var + z : extended; + +begin + z:=test; +end. \ No newline at end of file diff --git a/tests/test/tfpu2.pp b/tests/test/tfpu2.pp new file mode 100644 index 0000000000..27b52c8951 --- /dev/null +++ b/tests/test/tfpu2.pp @@ -0,0 +1,29 @@ +{$mode objfpc} +program test_fpu_excpetions; + +uses + sysutils; + + function mysqrt(x : real) : real; + + begin + try + mysqrt:=sqrt(x); + except + on e : exception do + mysqrt:=0; + end; + end; + + var + x, y,z : real; + +begin + x:=6.5; + y:=5.76; + z:=3.1; + Writeln('Testing mysqrt (x) = sqrt(x) if x >= 0'); + Writeln(' = 0 if x < 0'); + Writeln(' 6.5+5.76*mysqrt(3.1) = ',x+y*mysqrt(z):0:6); + Writeln(' 6.5+5.76*mysqrt(-3.1) = ',x+y*mysqrt(-z):0:6); +end. \ No newline at end of file diff --git a/tests/test/tfpu3.pp b/tests/test/tfpu3.pp new file mode 100644 index 0000000000..25e17e2f50 --- /dev/null +++ b/tests/test/tfpu3.pp @@ -0,0 +1,107 @@ +{ testfdiv variant with NASM output forced } +{$ifdef go32v2} +{$output_format nasmcoff} +{$endif} +{$ifdef win32} +{$output_format nasmwin32} +{$endif} +{$ifdef linux} +{$output_format nasmelf} +{$endif} +{ This test program deals with the + the delicate problem of + non commutative FPU instruction + where the destination register + is ST(1) to ST(7) + + Whereas Intel interprets + fdiv st(1),st + as + st(1):=st(1) / st + The ATT read + fdiv %st,%st(1) + as + st(1):=st/st(1) + Should be tested with + different output styles : + for go32v2 + -Aas -Acoff and -Anasmcoff + for win32 + -Aas -Apecoff and -Anasmwin32 + for linux + -Aas and -Anasmelf + } + +program test_nasm_div; + + +var + x,y,z : double; + +begin + x:=4; + y:=2; + Writeln('4/2=',x/y:0:2); + if x/y <> 2.0 then + Halt(1); +{$asmmode att} + asm + fldl y + fldl x + fdivp %st,%st(1) + fstpl z + end; + Writeln('ATT result of 4/2=',z:0:2); + if z <> 2.0 then + Halt(1); + asm + fldl y + fldl x + fdiv %st(1),%st + fstpl z + fstp %st + end; + Writeln('ATT result of 4/2=',z:0:2); + if z <> 2.0 then + Halt(1); + asm + fldl y + fldl x + fadd + fstpl z + end; + Writeln('ATT result of 4+2=',z:0:2); + if z <> 6.0 then + Halt(1); +{$asmmode intel} + asm + fld x + fld y + fdivp st(1),st + fstp z + end; + Writeln('Intel result of 4/2=',z:0:2); + if z <> 2.0 then + Halt(1); + asm + fld y + fld x + fdiv st,st(1) + fstp z + fstp st + end; + Writeln('Intel result of 4/2=',z:0:2); + if z <> 2.0 then + Halt(1); + asm + fld y + fld x + fadd + fstp z + end; + Writeln('Intel result of 4+2=',z:0:2); + if z <> 6.0 then + Halt(1); + + Writeln('All tests completed successfully!'); +end. diff --git a/tests/test/tfpu4.pp b/tests/test/tfpu4.pp new file mode 100644 index 0000000000..dad60fc729 --- /dev/null +++ b/tests/test/tfpu4.pp @@ -0,0 +1,99 @@ +{ testfdiv variant with GNU AS output forced } +{$output_format as} +{ This test program deals with the + the delicate problem of + non commutative FPU instruction + where the destination register + is ST(1) to ST(7) + + Whereas Intel interprets + fdiv st(1),st + as + st(1):=st(1) / st + The ATT read + fdiv %st,%st(1) + as + st(1):=st/st(1) + Should be tested with + different output styles : + for go32v2 + -Aas -Acoff and -Anasmcoff + for win32 + -Aas -Apecoff and -Anasmwin32 + for linux + -Aas and -Anasmelf + } + +program test_nasm_div; + + +var + x,y,z : double; + +begin + x:=4; + y:=2; + Writeln('4/2=',x/y:0:2); + if x/y <> 2.0 then + Halt(1); +{$asmmode att} + asm + fldl y + fldl x + fdivp %st,%st(1) + fstpl z + end; + Writeln('ATT result of 4/2=',z:0:2); + if z <> 2.0 then + Halt(1); + asm + fldl y + fldl x + fdiv %st(1),%st + fstpl z + fstp %st + end; + Writeln('ATT result of 4/2=',z:0:2); + if z <> 2.0 then + Halt(1); + asm + fldl y + fldl x + fadd + fstpl z + end; + Writeln('ATT result of 4+2=',z:0:2); + if z <> 6.0 then + Halt(1); +{$asmmode intel} + asm + fld x + fld y + fdivp st(1),st + fstp z + end; + Writeln('Intel result of 4/2=',z:0:2); + if z <> 2.0 then + Halt(1); + asm + fld y + fld x + fdiv st,st(1) + fstp z + fstp st + end; + Writeln('Intel result of 4/2=',z:0:2); + if z <> 2.0 then + Halt(1); + asm + fld y + fld x + fadd + fstp z + end; + Writeln('Intel result of 4+2=',z:0:2); + if z <> 6.0 then + Halt(1); + + Writeln('All tests completed successfully!'); +end. diff --git a/tests/test/tfpu5.pp b/tests/test/tfpu5.pp new file mode 100644 index 0000000000..c27a338f97 --- /dev/null +++ b/tests/test/tfpu5.pp @@ -0,0 +1,98 @@ +{ This test program deals with the + the delicate problem of + non commutative FPU instruction + where the destination register + is ST(1) to ST(7) + + Whereas Intel interprets + fdiv st(1),st + as + st(1):=st(1) / st + The ATT read + fdiv %st,%st(1) + as + st(1):=st/st(1) + Should be tested with + different output styles : + for go32v2 + -Aas -Acoff and -Anasmcoff + for win32 + -Aas -Apecoff and -Anasmwin32 + for linux + -Aas and -Anasmelf + } + +program test_nasm_div; + + +var + x,y,z : double; + +begin + x:=4; + y:=2; + Writeln('4/2=',x/y:0:2); + if x/y <> 2.0 then + Halt(1); +{$asmmode att} + asm + fldl y + fldl x + fdivp %st,%st(1) + fstpl z + end; + Writeln('ATT result of 4/2=',z:0:2); + if z <> 2.0 then + Halt(1); + asm + fldl y + fldl x + fdiv %st(1),%st + fstpl z + fstp %st + end; + Writeln('ATT result of 4/2=',z:0:2); + if z <> 2.0 then + Halt(1); + asm + fldl y + fldl x + fadd + fstpl z + end; + Writeln('ATT result of 4+2=',z:0:2); + if z <> 6.0 then + Halt(1); +{$asmmode intel} + asm + fld x + fld y + fdivp st(1),st + fstp z + end; + Writeln('Intel result of 4/2=',z:0:2); + if z <> 2.0 then + Halt(1); + asm + fld y + fld x + fdiv st,st(1) + fstp z + fstp st + end; + Writeln('Intel result of 4/2=',z:0:2); + if z <> 2.0 then + Halt(1); + asm + fld y + fld x + fadd + fstp z + end; + Writeln('Intel result of 4+2=',z:0:2); + if z <> 6.0 then + Halt(1); + + Writeln('All tests completed successfully!'); +end. + diff --git a/tests/test/tgoto.pp b/tests/test/tgoto.pp new file mode 100644 index 0000000000..735029b0a1 --- /dev/null +++ b/tests/test/tgoto.pp @@ -0,0 +1,27 @@ +program testgoto; + +{$goto on} + +function test : longint; + +label l; + + +var + a,b : longint; + +begin + a:=1; + b:=1; + l: + if a>b then + begin + exit(0); + end; + a:=2; + goto l; +end; + +begin + test; +end. diff --git a/tests/test/theap.pp b/tests/test/theap.pp new file mode 100644 index 0000000000..f39452cae1 --- /dev/null +++ b/tests/test/theap.pp @@ -0,0 +1,170 @@ +{ + $Id$ + + Program to test heap functions, timing doesn't work +} +PROGRAM TestHeap; + +Procedure InitMSTimer; +begin +end; + + + +{Get MS Timer} +Function MSTimer:longint; +begin + MSTimer:=0; +end; + + +VAR Dummy,Start, LoopTime,LoopTime2: LONGINT; + Delta, TotalTime: LONGINT; + L,Choice,K,T: WORD; + BlkPtr: ARRAY [1..10000] OF POINTER; + BlkSize: ARRAY [1..10000] OF WORD; + Permutation: ARRAY [1..10000] OF WORD; + +BEGIN + INitMSTimer; + WriteLn ('Test of TP heap functions'); + WriteLn; + TotalTime := 0; + RandSeed := 997; + WriteLn ('MaxAvail: ', MaxAvail, ' MemAvail: ', MemAvail); + Start :=MSTimer; + FOR L := 1 TO 10000 DO BEGIN + END; + LoopTime := MSTimer-Start; + FOR L := 1 TO 10000 DO BEGIN + BlkSize [L] := Random (512) + 1; + END; + Write ('Allocating 10000 blocks at the end of the heap: '); + Start := MSTImer; + FOR L := 1 TO 10000 DO BEGIN + GetMem (BlkPtr [L], BlkSize [L]); + END; + Delta := MSTimer-Start-LoopTime; + Inc (TotalTime, Delta); + WriteLn (Delta:5, ' ms'); + WriteLn ('MaxAvail: ', MaxAvail, ' MemAvail: ', MemAvail); + Write ('Deallocating same 10000 blocks in reverse order:'); + Start := MSTimer; + FOR L := 1 TO 10000 DO BEGIN + FreeMem (BlkPtr [L], BlkSize [L]); + END; + Delta := MSTimer-Start-LoopTime; + Inc (TotalTime, Delta); + WriteLn (Delta:5, ' ms'); + WriteLn ('MaxAvail: ', MaxAvail, ' MemAvail: ', MemAvail); + Write ('Allocating 10000 blocks at the end of the heap: '); + Start := MSTimer; + FOR L := 1 TO 10000 DO BEGIN + GetMem (BlkPtr [L], BlkSize [L]); + END; + Delta := MSTimer-Start-LoopTime; + Inc (TotalTime, Delta); + WriteLn (Delta:5, ' ms'); + WriteLn ('MaxAvail: ', MaxAvail, ' MemAvail: ', MemAvail); + FOR L := 1 TO 10000 DO BEGIN + Permutation [L] := L; + END; + Start := MSTimer; + FOR L := 10000 DOWNTO 1 DO BEGIN + Choice := Random (L)+1; + K := Permutation [Choice]; + Permutation [Choice] := Permutation [L]; + END; + LoopTime2 := MSTimer - Start; + FOR L := 1 TO 10000 DO BEGIN + Permutation [L] := L; + END; + Write ('Deallocating same 10000 blocks at random: '); + Start := MSTimer; + FOR L := 10000 DOWNTO 1 DO BEGIN + Choice := Random (L)+1; + K := Permutation [Choice]; + Permutation [Choice] := Permutation [L]; + FreeMem (BlkPtr [K], BlkSize [K]); + END; + Delta := MSTimer - Start - LoopTime2; + Inc (TotalTime, Delta); + WriteLn (Delta:5, ' ms'); + WriteLn ('MaxAvail: ', MaxAvail, ' MemAvail: ', MemAvail); + Write ('Allocating 10000 blocks at the end of the heap: '); + Start := MSTimer; + FOR L := 1 TO 10000 DO BEGIN + GetMem (BlkPtr [L], BlkSize [L]); + END; + Delta := MSTimer-Start-LoopTime; + Inc (TotalTime, Delta); + WriteLn (Delta:5, ' ms'); + WriteLn ('MaxAvail: ', MaxAvail, ' MemAvail: ', MemAvail); + FOR L := 1 TO 10000 DO BEGIN + Permutation [L] := L; + END; + Start := MSTimer; + FOR L := 10000 DOWNTO 1 DO BEGIN + Choice := Random (L)+1; + K := Permutation [Choice]; + T:= Permutation [L]; + Permutation [L] := Permutation [Choice]; + Permutation [Choice] := T; + END; + LoopTime2 := MSTimer - Start; + FOR L := 1 TO 10000 DO BEGIN + Permutation [L] := L; + END; + Write ('Deallocating 5000 blocks at random: '); + Start := MSTimer; + FOR L := 10000 DOWNTO 5001 DO BEGIN + Choice := Random (L)+1; + K := Permutation [Choice]; + T:= Permutation [L]; + Permutation [L] := Permutation [Choice]; + Permutation [Choice] := T; + SYSTEM.FreeMem (BlkPtr [K], BlkSize [K]); + END; + Delta := MSTimer-Start-LoopTime2; + Inc (TotalTime, Delta); + WriteLn (Delta:5, ' ms'); + WriteLn ('MaxAvail: ', MaxAvail, ' MemAvail: ', MemAvail); + Start := MSTimer; + FOR L := 1 TO 10000 DO BEGIN + Dummy := MaxAvail; + END; + Delta := MSTimer-Start; + Inc (TotalTime, (Delta + 5) DIV 10); + WriteLn ('10000 calls to MaxAvail: ', Delta:5, ' ms'); + Start := MSTimer; + FOR L := 1 TO 10000 DO BEGIN + Dummy := MemAvail; + END; + Delta := MSTimer - Start; + Inc (TotalTime, (Delta + 5) DIV 10); + WriteLn ('10000 calls to MemAvail: ', Delta:5, ' ms'); + WriteLn ('MaxAvail: ', MaxAvail, ' MemAvail: ', MemAvail); + Write ('Reallocating deallocated 500 blocks at random: '); + Start := MSTimer; + FOR L := 5001 TO 10000 DO BEGIN + GetMem (BlkPtr [Permutation [L]], BlkSize [Permutation [L]]); + END; + Delta := MSTimer-Start-LoopTime; + Inc (TotalTime, Delta); + WriteLn (Delta:5, ' ms'); + WriteLn ('MaxAvail: ', MaxAvail, ' MemAvail: ', MemAvail); + Write ('Deallocating all 10000 blocks at random: '); + Start := MSTimer; + FOR L := 10000 DOWNTO 1 DO BEGIN + FreeMem (BlkPtr [L], BlkSize [L]); + END; + Delta := MSTimer-Start-LoopTime; + Inc (TotalTime, Delta); + WriteLn (Delta:5, ' ms'); + WriteLn ('MaxAvail: ', MaxAvail, ' MemAvail: ', MemAvail); + WriteLn; + WriteLn ('Total time for benchmark: ', TotalTime, ' ms'); +END. + + + diff --git a/tests/test/tinline1.pp b/tests/test/tinline1.pp new file mode 100644 index 0000000000..de9d0507c0 --- /dev/null +++ b/tests/test/tinline1.pp @@ -0,0 +1,121 @@ +program inline01; + +var + starti: longint; + i:longint; + + +{$INLINE ON} + +procedure kkainl(var c: longint); inline; +begin + if c <> starti then + begin + writeln('bug'); + halt(1); + end; + writeln('kka ',c); + c:=c+1; + if i <> starti+1 then + begin + writeln('bug'); + halt(1); + end; +end; + +procedure kka(var c:longint); +begin + if c <> starti then + begin + writeln('bug'); + halt(1); + end; + writeln('kka ',c); + c:=c+1; + if i <> starti+1 then + begin + writeln('bug'); + halt(1); + end; +end; + +procedure kkb(var c:longint);inline; +begin + if c <> starti then + begin + writeln('bug'); + halt(1); + end; + kka(c); + if i <> starti+1 then + begin + writeln('bug'); + halt(1); + end; + writeln('kkb ',c); +end; + +procedure kkb2(var c:longint);inline; +begin + if c <> starti then + begin + writeln('bug'); + halt(1); + end; + kkainl(c); + if i <> starti+1 then + begin + writeln('bug'); + halt(1); + end; + writeln('kkb ',c); +end; + +procedure kkc(var c: longint); +begin + if c <> starti then + begin + writeln('bug'); + halt(1); + end; + kkb(c); + if i <> starti+1 then + begin + writeln('bug'); + halt(1); + end; +end; + +procedure kkcinl(var c: longint); inline; +begin + if c <> starti then + begin + writeln('bug'); + halt(1); + end; + kkb2(c); + if i <> starti+1 then + begin + writeln('bug'); + halt(1); + end; +end; + +begin + i:=5; + starti := 5; + kkc(i); + starti := i; + kkc(i); + starti := i; + kkb(i); + starti := i; + kkb(i); + starti := i; + kka(i); + starti := i; + kkcinl(i); + starti := i; + kkb2(i); +end. + diff --git a/tests/test/tinline2.pp b/tests/test/tinline2.pp new file mode 100644 index 0000000000..e3efc808a2 --- /dev/null +++ b/tests/test/tinline2.pp @@ -0,0 +1,23 @@ +{$inline on} +procedure test(var a : longint;b : longint);inline; + +begin + a:=32-b; +end; + +procedure test2(var a : longint;b : longint); + +begin + a:=32-b; +end; + + var + a,b : longint; +begin + test2(a,16); + Writeln('a=',a,' should be 16'); + if (a<>16) then halt(1); + test(a,16); + Writeln('a=',a,' should be 16'); + if (a<>16) then halt(1); +end. \ No newline at end of file diff --git a/tests/test/tinoutres.pp b/tests/test/tinoutres.pp new file mode 100644 index 0000000000..911a70afcc --- /dev/null +++ b/tests/test/tinoutres.pp @@ -0,0 +1,307 @@ +{ checks if the correct RTE's are generated for invalid io operations } + +{$i-} + +procedure test(value, required: longint); +begin + if value <> required then + begin + writeln('Got ',value,' instead of ',required); + halt(1); + end; +end; + +procedure test_read_text; +var + f: text; + s: string; +begin + { to avoid influence of previous runs/procedures } + fillchar(f,sizeof(f),0); + write('Reading from not opened text file...'); + read(f,s); + test(ioresult,103); + readln(f); + test(ioresult,103); + writeln(' Passed!'); + + write('Seekeoln from not opened text file...'); + seekeoln(f); + test(ioresult,103); + writeln(' Passed!'); + + write('Seekeof from not opened text file...'); + seekeof(f); + test(ioresult,103); + writeln(' Passed!'); + + assign(f,'inoutrte.$$$'); + rewrite(f); + test(ioresult,0); + + write('Reading from write-only (rewritten) text file...'); + read(f,s); + test(ioresult,104); + readln(f); + test(ioresult,104); + writeln(' Passed!'); + + write('Seekeoln from write-only (rewritten) text file...'); + seekeoln(f); + test(ioresult,104); + writeln(' Passed!'); + + write('Seekeof from write-only (rewritten) text file...'); + seekeof(f); + test(ioresult,104); + writeln(' Passed!'); + + close(f); + test(ioresult,0); + append(f); + test(ioresult,0); + + write('Reading from write-only (appended) text file...'); + read(f,s); + test(ioresult,104); + readln(f); + test(ioresult,104); + writeln(' Passed!'); + + write('Seekeoln from write-only (appended) text file...'); + seekeoln(f); + test(ioresult,104); + writeln(' Passed!'); + + write('Seekeof from write-only (appended) text file...'); + seekeof(f); + test(ioresult,104); + writeln(' Passed!'); + + close(f); + test(ioresult,0); + erase(f); + test(ioresult,0); +end; + +procedure test_read_typed; +var + f: file of byte; + s: byte; +begin + { to avoid influence of previous runs/procedures } + fillchar(f,sizeof(f),0); + + write('Reading from not opened typed file...'); + read(f,s); + test(ioresult,103); + writeln(' Passed!'); + + { with filemode 2, the file is read-write } + filemode := 1; + assign(f,'inoutrte.$$$'); + rewrite(f); + test(ioresult, 0); + write(f,s); + test(ioresult, 0); + close(f); + test(ioresult, 0); + reset(f); + test(ioresult, 0); + write('Reading from write-only typed file...'); + read(f,s); + test(ioresult,104); + writeln(' Passed!'); + + filemode := 2; + close(f); + test(ioresult, 0); + erase(f); + test(ioresult, 0); +end; + +procedure test_read_untyped; +var + f: file; + r: longint; + s: byte; +begin + { to avoid influence of previous runs/procedures } + fillchar(f,sizeof(f),0); + + write('Reading from not opened untyped file...'); + blockread(f,s,1,r); + test(ioresult,103); + writeln(' Passed!'); + + { with filemode 2, the file is read-write } + filemode := 1; + assign(f,'inoutrte.$$$'); + rewrite(f); + test(ioresult, 0); + blockwrite(f,s,1); + test(ioresult, 0); + close(f); + test(ioresult, 0); + reset(f); + test(ioresult, 0); + write('Reading from write-only utyped file...'); + blockread(f,s,1,r); + test(ioresult,104); + writeln(' Passed!'); + + filemode := 2; + close(f); + test(ioresult, 0); + erase(f); + test(ioresult, 0); +end; + + +procedure test_write_text; +var f: text; + s: string; +begin + { to avoid influence of previous runs/procedures } + fillchar(f,sizeof(f),0); + + write('Writing to not opened text file...'); + write(f,s); + test(ioresult,103); + writeln(f); + test(ioresult,103); + writeln(' Passed!'); + + assign(f,'inoutrte.$$$'); + rewrite(f); + close(f); + test(ioresult,0); + reset(f); + test(ioresult,0); + + write('Writing to read-only text file...'); + write(f,s); + test(ioresult,105); + writeln(f); + test(ioresult,105); + Writeln(' Passed!'); + + close(f); + test(ioresult,0); + erase(f); + test(ioresult,0); +end; + +procedure test_write_typed; +var f: file of byte; + s: byte; +begin + { to avoid influence of previous runs/procedures } + fillchar(f,sizeof(f),0); + + write('Writing to not opened typed file...'); + write(f,s); + test(ioresult,103); + writeln(' Passed!'); + + assign(f,'inoutrte.$$$'); + rewrite(f); + close(f); + test(ioresult,0); + filemode := 0; + reset(f); + test(ioresult,0); + + write('Writing to read-only typed file...'); + write(f,s); + test(ioresult,105); + Writeln(' Passed!'); + + filemode := 2; + close(f); + test(ioresult,0); + erase(f); + test(ioresult,0); +end; + +procedure test_write_untyped; +var f: file; + r: longint; + s: byte; +begin + { to avoid influence of previous runs/procedures } + fillchar(f,sizeof(f),0); + + write('Writing to not opened untyped file...'); + blockwrite(f,s,1,r); + test(ioresult,103); + writeln(' Passed!'); + + assign(f,'inoutrte.$$$'); + rewrite(f); + close(f); + test(ioresult,0); + filemode := 0; + reset(f); + test(ioresult,0); + + write('Writing to read-only untyped file...'); + blockwrite(f,s,1,r); + test(ioresult,105); + Writeln(' Passed!'); + + filemode := 2; + close(f); + test(ioresult,0); + erase(f); + test(ioresult,0); +end; + + +procedure test_close_text; +var f: text; +begin + { to avoid influence of previous runs/procedures } + fillchar(f,sizeof(f),0); + + write('Testing closing of not opened text file...'); + close(f); + test(ioresult,103); + writeln(' Passed!'); +end; + +procedure test_close_typed; +var f: file of byte; +begin + { to avoid influence of previous runs/procedures } + fillchar(f,sizeof(f),0); + + write('Testing closing of not opened typed file...'); + close(f); + test(ioresult,103); + writeln(' Passed!'); +end; + +procedure test_close_untyped; +var f: file; +begin + { to avoid influence of previous runs/procedures } + fillchar(f,sizeof(f),0); + + write('Testing closing of not opened untyped file...'); + close(f); + test(ioresult,103); + writeln(' Passed!'); +end; + +begin + test_read_text; + test_read_typed; + test_read_untyped; + test_write_text; + test_write_typed; + test_write_untyped; + test_close_text; + test_close_typed; + test_close_untyped; +end. diff --git a/tests/test/tint641.pp b/tests/test/tint641.pp new file mode 100644 index 0000000000..05a9e1a340 --- /dev/null +++ b/tests/test/tint641.pp @@ -0,0 +1,96 @@ +const + q2 : qword = 1234; + i2 : int64 = -1234; + +var + q : qword; + i : int64; + l1,l2 : longint; + s : string; + +procedure p1(q : qword;i : int64); + + begin + end; + +function f1 : qword; + + begin + end; + +function f2 : int64; + + begin + end; + +var + q1,q3,q4 : qword; + +begin + q1:=1; + q3:=1; + q4:=1; + if not((q4 div q3) div (q2 div q1)<>(q2 div q1) div (q4 div q3)) then + writeln('Error :('); + q:=q-q; + q:=q-(q*q); + q:=(q*q)-(q*q); + { first test the comparisation } + if q<>q then + begin + writeln('Error :('); + end; + + if q>q then + begin + writeln('Error :('); + end; + + if i>f2 then + begin + writeln('Error :('); + end; + if l1>l2 then + begin + writeln('Error :('); + end; + p1(q,i); + q:=f1; + i:=f2; + q:=q+q; + i:=((i+i) xor (i+i)) or ((i+i) xor (i+i)); + q:=q shl l1; + q:=q shr l1; + q:=(q shl l1)+(q shl l1); + + q:=not(q); + i:=not(i); + q:=not(q xor q); + i:=not(i or i); + + { unary minus } + q:=-q; + i:=-i; + q:=-(q xor q); + i:=-(i or i); + + { multiplication } + // q:=3; + q:=q*q; + + i:=i*i; + + q:=q*(q*q); + i:=i*(i*i); + + q:=(q*q)*(q*q); + q:=((q*q)*(q*q))*((q*q)*(q*q)); + + writeln(q); + writeln(i); +{ test can't be interactive (PFV) + read(q); + read(i); } + str(q,s); + str(i,s); +end. diff --git a/tests/test/tint642.pp b/tests/test/tint642.pp new file mode 100644 index 0000000000..8ce8a09337 --- /dev/null +++ b/tests/test/tint642.pp @@ -0,0 +1,1190 @@ +{$Q-} { this is necessary to avoid an overflow error below } +{$mode objfpc} +uses + sysutils +{$ifdef go32v2} + ,dpmiexcp +{$endif go32v2} + ; + +type + tqwordrec = packed record + low,high : dword; + end; + +procedure dumpqword(q : qword); + + begin + write('$',hexstr(tqwordrec(q).high,8),' ',hexstr(tqwordrec(q).low,8)); + end; + +procedure dumpqwordln(q : qword); + + begin + dumpqword(q); + writeln; + end; + +procedure assignqword(h,l : dword;var q : qword); + + begin + tqwordrec(q).high:=h; + tqwordrec(q).low:=l; + end; + +procedure do_error(l : longint); + + begin + writeln('Error near number ',l); + halt(1); + end; + +procedure do_error; + + begin + do_error(0); + end; + +procedure simpletestcmpqword; + + var + q1,q2,q3,q4 : qword; + + begin + assignqword(0,5,q1); + assignqword(6,0,q2); + assignqword(6,1,q3); + assignqword(6,5,q4); + { first test the code generation of the operators } + if q1<>q1 then + do_error(0); + if q2<>q2 then + do_error(0); + if q3<>q3 then + do_error(0); + if not(q1=q1) then + do_error(0); + if not(q2=q2) then + do_error(0); + if not(q3=q3) then + do_error(0); + writeln(' <>,= succesfully tested'); + + if q1>q2 then + do_error(1100); + if q2>q3 then + do_error(1101); + if q2 succesfully tested'); + + if q1>=q2 then + do_error(1104); + if q2>=q3 then + do_error(1105); + if q2<=q1 then + do_error(1106); + if q3<=q2 then + do_error(1107); + writeln(' >=,<= succesfully tested'); + + if q1=q2 then + do_error(1108); + if q2=q3 then + do_error(1109); + if q3=q1 then + do_error(1111); + + if q1=q4 then + do_error(1112); + if q2=q4 then + do_error(1113); + if q3=q4 then + do_error(1114); + writeln(' More comparisations successful tested'); + end; + +procedure testaddqword; + + var + q1,q2,q3,q4,q5,q6 : qword; + + begin + { without overflow between 32 bit } + assignqword(0,5,q1); + assignqword(0,6,q2); + assignqword(0,1,q3); + assignqword(0,11,q4); + assignqword(0,1,q5); + if q1+q2<>q4 then + do_error(1200); + if q1+q3+q1<>q4 then + do_error(1201); + if q1+(q3+q1)<>q4 then + do_error(1202); + if (q1+q3)+q1<>q4 then + do_error(1203); + { a more complex expression } + if ((((q5+q3)+(q3+q5))+((q5+q3)+(q3+q5)))+q5+q3+q5)<>q4 then + do_error(1204); + { with overflow between 32 bit } + assignqword(0,$ffffffff,q1); + assignqword(1,3,q2); + assignqword(0,4,q3); + assignqword(1,4,q4); + assignqword(0,1,q5); + assignqword(1,$fffffffe,q6); + if q1+q3<>q2 then + do_error(1205); + if q3+q1<>q2 then + do_error(1206); + if q1+(q3+q5)<>q4 then + do_error(1207); + if (q1+q3)+q5<>q4 then + do_error(1208); + if (q1+q1)<>q6 then + do_error(1209); + end; + +procedure testcmpqword; + + var + q1,q2,q3,q4,q5,q6 : qword; + + begin + assignqword(0,$ffffffff,q1); + assignqword(0,$ffffffff,q2); + assignqword(1,$fffffffe,q3); + assignqword(0,2,q4); + assignqword(1,$fffffffc,q5); + if (q1+q2)<>q3 then + do_error(1300); + if not(q3=(q1+q2)) then + do_error(1301); + if (q1+q2)>q3 then + do_error(1302); + if (q1+q2)=(q1+q2)) then + do_error(1305); + + if (q1+q2)<>(q4+q5) then + do_error(1306); + if not((q4+q5)=(q1+q2)) then + do_error(1307); + if (q1+q2)>(q4+q5) then + do_error(1308); + if (q1+q2)<(q4+q5) then + do_error(1309); + if not((q4+q5)<=(q1+q2)) then + do_error(1310); + if not((q4+q5)>=(q1+q2)) then + do_error(1311); + end; + +procedure testlogqword; + + var + q0,q1,q2,q3,q4,q5,q6 : qword; + + begin + assignqword(0,0,q0); + assignqword($ffffffff,$ffffffff,q1); + assignqword(0,$ffffffff,q2); + assignqword($ffffffff,0,q3); + assignqword($a0a0a0a0,$50505050,q4); + assignqword(0,$50505050,q5); + assignqword($a0a0a0a0,0,q6); + + { here we don't need to test all cases of locations, } + { this is already done by the addtion test } + if (q2 or q3)<>q1 then + do_error(1400); + if (q5 or q6)<>q4 then + do_error(1401); + + if (q2 and q3)<>q0 then + do_error(1402); + if (q5 and q6)<>q0 then + do_error(1403); + + if (q2 xor q3)<>q1 then + do_error(1404); + if (q5 xor q6)<>q4 then + do_error(1405); + { the test before could be also passed by the or operator! } + if (q4 xor q4)<>q0 then + do_error(1406); + end; + +procedure testshlshrqword; + + var + q0,q1,q2,q3,q4,q5 : qword; + l1,l2 : longint; + + begin + assignqword(0,0,q0); + assignqword($ffff,$ffff0000,q1); + assignqword(0,$ffffffff,q2); + assignqword($ffffffff,0,q3); + assignqword(0,1,q4); + assignqword($80000000,0,q5); + + l1:=16; + l2:=0; + if (q1 shl 16)<>q3 then + do_error(1500); + if (q1 shl 48)<>q0 then + do_error(1501); + if (q1 shl 47)<>q5 then + do_error(1501); + if ((q1+q0) shl 16)<>q3 then + do_error(1502); + if ((q1+q0) shl 48)<>q0 then + do_error(1503); + if ((q1+q0) shl 47)<>q5 then + do_error(15031); + + if (q1 shl l1)<>q3 then + do_error(1504); + if (q1 shl (3*l1))<>q0 then + do_error(1505); + if ((q1+q0) shl l1)<>q3 then + do_error(1506); + if ((q1+q0) shl (3*l1))<>q0 then + do_error(1507); + if ((q1+q0) shl (3*l1-1))<>q5 then + do_error(15071); + + if (q1 shl (l1+l2))<>q3 then + do_error(1508); + if ((q1+q0) shl (l1+l2))<>q3 then + do_error(1509); + + if (q1 shr 16)<>q2 then + do_error(1510); + if (q1 shr 48)<>q0 then + do_error(1511); + if (q1 shr 47)<>q4 then + do_error(15111); + + if ((q1+q0) shr 16)<>q2 then + do_error(1512); + if ((q1+q0) shr 48)<>q0 then + do_error(1513); + if (q1 shr l1)<>q2 then + do_error(1514); + if (q1 shr (3*l1))<>q0 then + do_error(1515); + if (q1 shr (3*l1-1))<>q4 then + do_error(15151); + + if ((q1+q0) shr l1)<>q2 then + do_error(1516); + if ((q1+q0) shr (3*l1))<>q0 then + do_error(1517); + if ((q1+q0) shr (3*l1-1))<>q4 then + do_error(15171); + + if (q1 shr (l1+l2))<>q2 then + do_error(1518); + if ((q1+q0) shr (l1+l2))<>q2 then + do_error(1519); + end; + +procedure testsubqword; + + var + q0,q1,q2,q3,q4,q5,q6 : qword; + + begin + { without overflow between 32 bit } + assignqword(0,0,q0); + assignqword(0,6,q1); + assignqword(0,5,q2); + assignqword(0,1,q3); + assignqword(0,11,q4); + assignqword(0,1,q5); + if q1-q2<>q3 then + do_error(1600); + if q1-q0-q1<>q0 then + do_error(1601); + if q1-(q0-q1)<>q1+q1 then + do_error(1602); + if (q1-q0)-q1<>q0 then + do_error(1603); + + { a more complex expression } + if ((((q5-q3)-(q3-q5))-((q5-q3)-(q3-q5))))<>q0 then + do_error(1604); + + { with overflow between 32 bit } + assignqword(1,0,q1); + assignqword(0,$ffffffff,q2); + assignqword(0,1,q3); + assignqword(1,$ffffffff,q4); + + if q1-q2<>q3 then + do_error(1605); + if q1-q0-q2<>q3 then + do_error(1606); + if q1-(q0-q2)<>q4 then + do_error(1607); + if (q1-q0)-q1<>q0 then + do_error(1608); + + assignqword(1,$ffffffff,q5); + assignqword(1,$ffffffff,q4); + + { a more complex expression } + if ((((q5-q3)-(q3-q5))-((q5-q3)-(q3-q5))))<>q0 then + do_error(1609); + end; + +procedure testnotqword; + + var + q0,q1,q2,q3,q4 : qword; + + begin + assignqword($f0f0f0f0,$f0f0f0f0,q1); + assignqword($f0f0f0f,$f0f0f0f,q2); + assignqword($f0f0f0f0,0,q3); + assignqword(0,$f0f0f0f0,q4); + if not(q1)<>q2 then + do_error(1700); + if not(q3 or q4)<>q2 then + do_error(1701); + + { do a more complex expression to stress the register saving } + if not(q3 or q4)<>not(q3 or q4) then + do_error(1702); + end; + +procedure testnegqword; + + var + q0,q1,q2,q3,q4 : qword; + + begin + assignqword($1,$0,q1); + assignqword($0,1234,q2); + if -q1<>(0-q1) then + do_error(2700); + if -q2<>(0-q2) then + do_error(2701); + if -(q1+q2)<>(0-(q1+q2)) then + do_error(2702); + end; + +procedure testmulqword; + + var + q0,q1,q2,q3,q4,q5,q6 : qword; + i : longint; + + begin + assignqword(0,0,q0); + assignqword(0,1,q1); + assignqword(0,4,q2); + assignqword(2,0,q3); + assignqword(8,0,q4); + assignqword(0,1,q5); + assignqword($ffff,$12344321,q6); + { to some trivial tests } + { to test the code generation } + if q1*q2<>q2 then + do_error(1800); + if q1*q2*q3<>q4 then + do_error(1801); + if q1*(q2*q3)<>q4 then + do_error(1802); + if (q1*q2)*q3<>q4 then + do_error(1803); + if (q6*q5)*(q1*q2)<>q1*q2*q5*q6 then + do_error(1804); + + { a more complex expression } + if ((((q1*q5)*(q1*q5))*((q5*q1)*(q1*q5)))*q5*q1*q5)<>q1 then + do_error(1805); + + { now test the multiplication procedure with random bit patterns } + writeln('Doing some random multiplications, takes a few seconds'); + writeln('.....................................100%'); + for i:=1 to 1000000 do + begin + tqwordrec(q1).high:=0; + tqwordrec(q1).low:=random($7ffffffe); + tqwordrec(q2).high:=0; + tqwordrec(q2).low:=random($7ffffffe); + if q1*q2<>q2*q1 then + begin + write('Multiplication of '); + dumpqword(q1); + write(' and '); + dumpqword(q2); + writeln(' failed'); + do_error(1806); + end; + if i mod 50000=0 then + write('.'); + end; + for i:=1 to 1000000 do + begin + tqwordrec(q1).high:=0; + tqwordrec(q1).low:=random($7ffffffe); + q1:=q1 shl 16; + tqwordrec(q2).high:=0; + tqwordrec(q2).low:=random($fffe); + if q1*q2<>q2*q1 then + begin + write('Multiplication of '); + dumpqword(q1); + write(' and '); + dumpqword(q2); + writeln(' failed'); + do_error(1806); + end; + if i mod 50000=0 then + write('.'); + end; + writeln(' OK'); + end; + +procedure testdivqword; + + var + q0,q1,q2,q3,q4,q5,q6 : qword; + i : longint; + + begin + assignqword(0,0,q0); + assignqword(0,1,q1); + assignqword(0,4,q2); + assignqword(2,0,q3); + assignqword(8,0,q4); + assignqword(0,1,q5); + assignqword($ffff,$12344321,q6); + { to some trivial tests } + { to test the code generation } + if q2 div q1<>q2 then + do_error(1900); + if q2 div q1 div q1<>q2 then + do_error(1901); + if q2 div (q4 div q3)<>q1 then + do_error(1902); + if (q4 div q3) div q2<>q1 then + do_error(1903); + + { a more complex expression } + if (q4 div q3) div (q2 div q1)<>(q2 div q1) div (q4 div q3) then + do_error(1904); + + { now test the division procedure with random bit patterns } + writeln('Doing some random divisions, takes a few seconds'); + writeln('.................100%'); + for i:=1 to 100000 do + begin + tqwordrec(q1).high:=random($7ffffffe); + tqwordrec(q1).low:=random($7ffffffe); + tqwordrec(q2).high:=random($7ffffffe); + tqwordrec(q2).low:=random($7ffffffe); + { avoid division by zero } + if (tqwordrec(q2).low or tqwordrec(q2).high)=0 then + tqwordrec(q2).low:=1; + q3:=q1 div q2; + { get a restless division } + q1:=q2*q3; + q3:=q1 div q2; + if q3*q2<>q1 then + begin + write('Division of '); + dumpqword(q1); + write(' by '); + dumpqword(q2); + writeln(' failed'); + do_error(1906); + end; + if i mod 10000=0 then + write('.'); + end; + for i:=1 to 100000 do + begin + tqwordrec(q1).high:=0; + tqwordrec(q1).low:=random($7ffffffe); + tqwordrec(q2).high:=0; + tqwordrec(q2).low:=random($7ffffffe); + { avoid division by zero } + if tqwordrec(q2).low=0 then + tqwordrec(q2).low:=1; + { get a restless division } + q3:=q1*q2; + q3:=q3 div q2; + if q3<>q1 then + begin + write('Division of '); + dumpqword(q1); + write(' by '); + dumpqword(q2); + writeln(' failed'); + do_error(1907); + end; + if i mod 10000=0 then + write('.'); + end; + writeln(' OK'); + end; + +function testf : qword; + + var + q : qword; + + begin + assignqword($ffffffff,$a0a0a0a0,q); + testf:=q; + end; + +procedure testfuncqword; + + var + q : qword; + + begin + assignqword($ffffffff,$a0a0a0a0,q); + if testf<>q then + do_error(1900); + if q<>testf then + do_error(1901); + end; + +procedure testtypecastqword; + + var + s1,s2 : shortint; + b1,b2 : byte; + w1,w2 : word; + i1,i2 : integer; + l1,l2 : longint; + d1,d2 : dword; + q1,q2 : qword; + r1,r2 : double; + + begin + { shortint } + s1:=75; + s2:=0; + q1:=s1; + { mix up the processor a little bit } + q2:=q1; + if q2<>75 then + begin + dumpqword(q2); + do_error(2006); + end; + s2:=q2; + if s1<>s2 then + do_error(2000); + + { byte } + b1:=$ca; + b2:=0; + q1:=b1; + { mix up the processor a little bit } + q2:=q1; + if q2<>$ca then + do_error(2007); + b2:=q2; + if b1<>b2 then + do_error(2001); + + { integer } + i1:=12345; + i2:=0; + q1:=i1; + { mix up the processor a little bit } + q2:=q1; + if q2<>12345 then + do_error(2008); + i2:=q2; + if i1<>i2 then + do_error(2002); + + { word } + w1:=$a0ff; + w2:=0; + q1:=w1; + { mix up the processor a little bit } + q2:=q1; + if q2<>$a0ff then + do_error(2009); + w2:=q2; + if w1<>w2 then + do_error(2003); + + { longint } + l1:=12341234; + l2:=0; + q1:=l1; + { mix up the processor a little bit } + q2:=q1; + if q2<>12341234 then + do_error(2010); + l2:=q2; + if l1<>l2 then + do_error(2004); + + { dword } + d1:=$5bcdef01; + b2:=0; + q1:=d1; + { mix up the processor a little bit } + q2:=q1; + if q2<>$5bcdef01 then + do_error(2011); + d2:=q2; + if d1<>d2 then + do_error(2005); + + { real } + { memory location } + q1:=12; + d1:=q1; + d2:=12; + if d1<>d2 then + do_error(2012); + + { register location } + q1:=12; + d1:=q1+1; + d2:=13; + if d1<>d2 then + do_error(2013); + + // a constant which can't be loaded with fild + q1:=$80000000; + q1:=q1 shl 32; + d1:=q1; + d2:=$80000000; + if d1<>d2*d2*2.0 then + do_error(20); + // register location + d1:=q1+1; + if d1<>d2*d2*2.0+1 then + do_error(2014); + end; + +procedure testioqword; + + var + t : text; + q1,q2 : qword; + i : longint; + + begin + assignqword($ffffffff,$a0a0a0a0,q1); + assign(t,'testi642.tmp'); + rewrite(t); + writeln(t,q1); + close(t); + reset(t); + readln(t,q2); + close(t); + if q1<>q2 then + do_error(2100); + { do some random tests } + for i:=1 to 100 do + begin + tqwordrec(q1).high:=random($7ffffffe); + tqwordrec(q1).low:=random($7ffffffe); + rewrite(t); + writeln(t,q1); + close(t); + reset(t); + readln(t,q2); + close(t); + if q1<>q2 then + begin + write('I/O of ');dumpqword(q1);writeln(' failed'); + do_error(2101); + end; + end; + end; + +procedure teststringqword; + + var + q1,q2 : qword; + s : string; + l : longint; + a : ansistring; + + begin + { testing str: shortstring } + // simple tests + q1:=1; + str(q1,s); + if s<>'1' then + do_error(2200); + // simple tests + q1:=0; + str(q1,s); + if s<>'0' then + do_error(2201); + + // more complex tests + q1:=4321; + str(q1,s); + if s<>'4321' then + do_error(2202); + str(q1:6,s); + if s<>' 4321' then + do_error(2203); + + // create a big qword: + q2:=1234; + l:=1000000000; + q2:=q2*l; + l:=54321; + q2:=q2+l; + str(q2,s); + if s<>'1234000054321' then + do_error(2204); + + { testing str: ansistring } + // more complex tests + q1:=4321; + str(q1,a); + if a<>'4321' then + do_error(2205); + str(q1:6,a); + if a<>' 4321' then + do_error(2206); + + // create a big qword: + q2:=1234; + l:=1000000000; + q2:=q2*l; + l:=54321; + q2:=q2+l; + str(q2,a); + if a<>'1234000054321' then + do_error(2207); + + { testing val } + { !!!!!!! } + end; + +procedure testmodqword; + + var + q0,q1,q2,q3,q4,q5,q6 : qword; + i : longint; + + begin + assignqword(0,0,q0); + assignqword(0,3,q1); + assignqword(0,5,q2); + assignqword(0,2,q3); + assignqword(0,4,q4); + assignqword(0,1,q5); + assignqword($ffff,$12344321,q6); + { to some trivial tests } + { to test the code generation } + if q2 mod q1<>q3 then + do_error(2300); + if q2 mod q1 mod q3<>q0 then + do_error(2301); + if q2 mod (q1 mod q3)<>q0 then + do_error(2302); + if (q1 mod q3) mod q2<>q5 then + do_error(2303); + if q1 mod q2<>q1 then + do_error(2308); + + { a more complex expression } + if (q2 mod q4) mod (q1 mod q3)<>(q1 mod q3) mod (q2 mod q4) then + do_error(2304); + + { now test the modulo division procedure with random bit patterns } + writeln('Doing some random module divisions, takes a few seconds'); + writeln('.................100%'); + for i:=1 to 100000 do + begin + tqwordrec(q1).high:=random($7ffffffe); + tqwordrec(q1).low:=random($7ffffffe); + tqwordrec(q2).high:=random($7ffffffe); + tqwordrec(q2).low:=random($7ffffffe); + { avoid division by zero } + if (tqwordrec(q2).low or tqwordrec(q2).high)=0 then + tqwordrec(q2).low:=1; + q3:=q1 mod q2; + if (q1-q3) mod q2<>q0 then + begin + write('Modulo division of '); + dumpqword(q1); + write(' by '); + dumpqword(q2); + writeln(' failed'); + do_error(2306); + end; + if i mod 10000=0 then + write('.'); + end; + for i:=1 to 100000 do + begin + tqwordrec(q1).high:=random($7ffffffe); + tqwordrec(q1).low:=random($7ffffffe); + tqwordrec(q2).high:=0; + tqwordrec(q2).low:=random($7ffffffe); + { avoid division by zero } + if tqwordrec(q2).low=0 then + tqwordrec(q2).low:=1; + { get a restless division } + q3:=q1 mod q2; + if (q1-q3) mod q2<>q0 then + begin + write('Modulo division of '); + dumpqword(q1); + write(' by '); + dumpqword(q2); + writeln(' failed'); + do_error(2307); + end; + if i mod 10000=0 then + write('.'); + end; + writeln(' OK'); + end; + +const + constqword : qword = 131975; + +procedure testconstassignqword; + + var + q1,q2,q3 : qword; + + begin + // constant assignments + assignqword(0,5,q2); + q1:=5; + if q1<>q2 then + do_error(2400); + + // constants in expressions + q1:=1234; + if q1<>1234 then + do_error(2401); + + // typed constants + assignqword(0,131975,q1); + q2:=131975; + if q1<>q2 then + do_error(2402); + + //!!!!! large constants are still missed + end; + +{$Q+} +procedure testreqword; + + var + q0,q1,q2,q3 : qword; + + begin + q0:=0; + assignqword($ffffffff,$ffffffff,q1); + q2:=1; + + // addition + try + // expect an exception + q3:=q1+q2; + do_error(2500); + except + on eintoverflow do + ; + else + do_error(2501); + end; + // subtraction + try + q3:=q0-q2; + do_error(2502); + except + on eintoverflow do + ; + else + do_error(2503); + end; + + // multiplication + q2:=2; + try + q3:=q2*q1; + do_error(2504); + except + on eintoverflow do + ; + else + do_error(2505); + end; + + // division + try + q3:=q1 div q0; + do_error(2506); + except + on edivbyzero do + ; + else + do_error(2507); + end; + + // modulo division + try + q3:=q1 mod q0; + do_error(2508); + except + on edivbyzero do + ; + else + do_error(2509); + end; +{$Q-} + + // now we do the same operations but without overflow + // checking -> we should get no exceptions + q2:=1; + + // addition + try + q3:=q1+q2; + except + do_error(2510); + end; + // subtraction + try + q3:=q0-q2; + except + do_error(2511); + end; + + // multiplication + q2:=2; + try + q3:=q2*q1; + except + do_error(2512); + end; + + end; + +procedure testintqword; + + var + q1,q2,q3 : qword; + + begin + // lo/hi + assignqword($fafafafa,$03030303,q1); + if lo(q1)<>$03030303 then + do_error(2600); + if hi(q1)<>$fafafafa then + do_error(2601); + if lo(q1+1)<>$03030304 then + do_error(2602); + if hi(q1+$f0000000)<>$fafafafa then + do_error(2603); + + // swap + assignqword($03030303,$fafafafa,q2); + if swap(q1)<>q2 then + do_error(2604); + + // succ/pred + assignqword(0,$1,q1); + q3:=q1; + q1:=succ(q1); + q1:=succ(q1+1); + q2:=pred(q1-1); + q2:=pred(q2); + if q3<>q2 then + do_error(2605); + assignqword(0,$ffffffff,q1); + q3:=q1; + q1:=succ(q1); + q1:=succ(q1+1); + q2:=pred(q1-1); + q2:=pred(q2); + if q3<>q2 then + do_error(2606); + end; + +procedure testcritical; + + var + a : array[0..10,0..10,0..10] of qword; + i,j,k : longint; + d1,d2 : extended; + q1,q2 : qword; + i1,i2 : int64; + + begin + i:=1; + j:=3; + k:=5; + { check if it is handled correct if a register is used } + { in a reference as well as temp. reg } + a[i,j,k]:=1234; + a[i,j,k]:=a[i,j,k]+a[i,j,k]; + if a[i,j,k]<>2468 then + do_error(2700); + if not(not(a[i,j,k]))<>a[i,j,k] then + do_error(2701); + if -(-(a[i,j,k]))<>a[i,j,k] then + do_error(2702); + if (a[i,j,k] shl (i-i))<>a[i,j,k] then + do_error(2703); + q1:=10; + q2:=100; + i1:=1000; + i2:=10000; + d1:=q1/q2; + d2:=i1/i2; + if (d1<>d2) then + do_error(2704); + end; + +var + q : qword; + +begin + randomize; + writeln('------------------------------------------------------'); + writeln(' QWord test '); + writeln('------------------------------------------------------'); + writeln; + + writeln('Testing assignqword and dumpqword ... '); + assignqword($12345678,$9ABCDEF0,q); + dumpqword(q); + writeln; + writeln('The output should be:'); + writeln('$12345678 9ABCDEF0'); + writeln; + + writeln('Testing simple QWord comparisations'); + simpletestcmpqword; + writeln('Testing simple QWord comparisations was successful'); + writeln; + + writeln('Testing QWord additions'); + testaddqword; + writeln('Testing QWord additions was successful'); + writeln; + + writeln('Testing more QWord comparisations'); + testcmpqword; + writeln('Testing more QWord comparisations was successful'); + writeln; + + writeln('Testing QWord subtraction'); + testsubqword; + writeln('Testing QWord subtraction was successful'); + writeln; + + writeln('Testing QWord constants'); + testconstassignqword; + writeln('Testing QWord constants was successful'); + writeln; + + writeln('Testing QWord logical operators (or,xor,and)'); + testlogqword; + writeln('Testing QWord logical operators (or,xor,and) was successful'); + writeln; + + writeln('Testing QWord logical not operator'); + testnotqword; + writeln('Testing QWord logical not operator was successful'); + writeln; + + writeln('Testing QWord logical - operator'); + testnegqword; + writeln('Testing QWord logical - operator was successful'); + writeln; + + writeln('Testing QWord logical shift operators (shr,shr)'); + testshlshrqword; + writeln('Testing QWord logical shift operators (shr,shr) was successful'); + writeln; + + writeln('Testing QWord function results'); + testfuncqword; + writeln('Testing QWord function results was successful'); + writeln; + + writeln('Testing QWord type casts'); + testtypecastqword; + writeln('Testing QWord type casts was successful'); + writeln; + + writeln('Testing QWord internal procedures'); + testintqword; + writeln('Testing QWord internal procedures was successful'); + writeln; + + writeln('Testing QWord multiplications'); + testmulqword; + writeln('Testing QWord multiplications was successful'); + writeln; + + writeln('Testing QWord division'); + testdivqword; + writeln('Testing QWord division was successful'); + writeln; + + writeln('Testing QWord modulo division'); + testmodqword; + writeln('Testing QWord modulo division was successful'); + writeln; + + writeln('Testing QWord runtime errors'); + testreqword; + writeln('Testing QWord runtime errors was successful'); + writeln; + + writeln('Testing QWord string conversion'); + teststringqword; + writeln('Testing QWord string conversion was successful'); + writeln; + + writeln('Testing QWord input/output'); + testioqword; + writeln('Testing QWord input/output was successful'); + writeln; + + writeln('Some extra tests for critical things'); + testcritical; + writeln('Extra tests for critical things were successful'); + + writeln('------------------------------------------------------'); + writeln(' QWord test successful'); + writeln('------------------------------------------------------'); + writeln; + writeln('------------------------------------------------------'); + writeln(' Int64 test '); + writeln('------------------------------------------------------'); + writeln; + + writeln('------------------------------------------------------'); + writeln(' Int64 test successful'); + writeln('------------------------------------------------------'); + halt(0); +end. \ No newline at end of file diff --git a/tests/test/tinterface1.pp b/tests/test/tinterface1.pp new file mode 100644 index 0000000000..3d54b8fb2d --- /dev/null +++ b/tests/test/tinterface1.pp @@ -0,0 +1,31 @@ +{$mode objfpc} +type + IInterface = interface(IUnknown) + procedure mydo; + end; + + TMyClass = class(TInterfacedObject, IInterface) + procedure mydo;virtual; + end; + +var + l : longint; + +procedure tmyclass.mydo; + + begin + l:=1; + end; + +var + c: TMyClass; + i: IInterface; + +begin + c := TMyClass.Create; + i := c; + l:=0; + i.mydo; + if l<>1 then + halt(1); +end. diff --git a/tests/test/tinterface2.pp b/tests/test/tinterface2.pp new file mode 100644 index 0000000000..bfe3bb3236 --- /dev/null +++ b/tests/test/tinterface2.pp @@ -0,0 +1,47 @@ +{ $version >= 1.1} +{$mode objfpc} +type + ITest = interface(IUnknown) + procedure DoSomething; + end; + + + TMyClass = class(TInterfacedObject, ITest) + procedure DoSomething; + end; + +var + i : longint; + +procedure TMyClass.DoSomething; +begin + inc(i); +end; + + +procedure DoTest(const ATest: ITest); +begin + ATest.DoSomething; +end; + + +procedure DoTest2(ATest: ITest); +begin + ATest.DoSomething; +end; + + +var + c: TMyClass; +begin + i:=0; + c := TMyClass.Create; + DoTest(c); + DoTest2(c); + c.Free; + if i<>2 then + begin + writeln('Problem with passing interfaces as parameters'); + halt(1); + end; +end. diff --git a/tests/test/tinterface3.pp b/tests/test/tinterface3.pp new file mode 100644 index 0000000000..b89ef6958e --- /dev/null +++ b/tests/test/tinterface3.pp @@ -0,0 +1,11 @@ +{ $version >= 1.1} +{$mode objfpc} +type + IMyInterface = interface + function f : longint; + procedure p(a : longint); + property x : longint read f write p; + end; + +begin +end. diff --git a/tests/test/tinterrupt.pp b/tests/test/tinterrupt.pp new file mode 100644 index 0000000000..7d7d017c2a --- /dev/null +++ b/tests/test/tinterrupt.pp @@ -0,0 +1,40 @@ +program test_interrupt; + + + +procedure test1;interrupt; +begin + Writeln('Test1 interrupt'); +end; + +procedure test2(var a,b : longint);interrupt; +begin + Writeln('Test2 interrupt'); + a:=1; + b:=2; +end; + +function test3 : longint; interrupt; +begin + Writeln('test3 called'); + test3:=55; +end; + + var + x,y : longint; + +begin + x:=-1; + test1; + test2(x,y); + if (x<>1) or (y<>2) then + begin + Writeln('Error with interrupt'); + Halt(1); + end; + if test3<>55 then + begin + Writeln('Error with interrupt function'); + Halt(1); + end; +end. \ No newline at end of file diff --git a/tests/test/tlibrary.pp b/tests/test/tlibrary.pp new file mode 100644 index 0000000000..2048ae6214 --- /dev/null +++ b/tests/test/tlibrary.pp @@ -0,0 +1,35 @@ +{$ifdef win32} + {$define supported} + {$define supportidx} +{$endif win32} +{$ifdef linux} + {$define supported} +{$endif linux} + +{$ifdef supported} + +library bug; + +const + publicname='TestName'; + publicindex = 1234; + +procedure Test;export; + + begin + end; + +exports + Test name publicname; +{$ifdef supportidx} +exports + Test index publicindex; +{$endif} + +begin +end. +{$else supported} +begin + Writeln('No library for that target'); +end. +{$endif supported} diff --git a/tests/test/tmath1.pp b/tests/test/tmath1.pp new file mode 100644 index 0000000000..2576092cde --- /dev/null +++ b/tests/test/tmath1.pp @@ -0,0 +1,74 @@ + + + +Procedure TestDiv; +var + bx,by: byte; + ix,iy: integer; + wx,wy: word; + lx,ly: longint; +Begin + { byte test } + bx:=10; + by:=5; + bx:=bx div by; + if bx = 2 then + WriteLn('TEST_DIV(1): PASSED.') + else + WriteLn('TEST_DIV(1): FAILED.'); + bx:=20; + bx:=bx div 10; + if bx = 2 then + WriteLn('TEST_DIV(2): PASSED.') + else + WriteLn('TEST_DIV(2): FAILED.'); + { integer test } + ix:=-10; + iy:=5; + ix:=ix div iy; + if ix = -2 then + WriteLn('TEST_DIV(3): PASSED.') + else + WriteLn('TEST_DIV(3): FAILED.'); + ix:=-20; + ix:=ix div 10; + if ix = -2 then + WriteLn('TEST_DIV(4): PASSED.') + else + WriteLn('TEST_DIV(4): FAILED.'); + { word test } + wx:=64000; + wy:=2; + wx:=wx div wy; + if wx = 32000 then + WriteLn('TEST_DIV(5): PASSED.') + else + WriteLn('TEST_DIV(5): FAILED.'); + wx:=20; + wx:=wx div 10; + if wx = 2 then + WriteLn('TEST_DIV(6): PASSED.') + else + WriteLn('TEST_DIV(6): FAILED.'); + { longint test } + lx:=-1000000; + ly:=2; + lx:=lx div ly; + if lx = -500000 then + WriteLn('TEST_DIV(7): PASSED.') + else + WriteLn('TEST_DIV(7): FAILED.'); + lx:=-1000000; + lx:=lx div 10; + if lx = -100000 then + WriteLn('TEST_DIV(8): PASSED.') + else + WriteLn('TEST_DIV(8): FAILED.') +end; + + + + +Begin + Testdiv; +end. \ No newline at end of file diff --git a/tests/test/tmath2.pp b/tests/test/tmath2.pp new file mode 100644 index 0000000000..4888b5cd8e --- /dev/null +++ b/tests/test/tmath2.pp @@ -0,0 +1,102 @@ +Program TestCardinal; + +{ Tests different features of the cardinal type } +{ We must also test range checking thereafter } +Procedure TestEqualAssign; +var + l : longint; + i : cardinal; + j : cardinal; +Begin + l:=$80000000; { longint } + i:=l; { longint -> cardinal } + j:=i; { cardinal -> cardinal } + l:=j; { cardinal -> longint } +end; + + +Procedure TestBiggerAssign; +var + b: byte; + c: char; + s: shortint; + i: integer; + w: word; + j: cardinal; +Begin + b:=0; + c:=#$7f; + s:=120; + i:=16384; + w:=32767; + j:=b; { byte -> cardinal } + { THIS LINE CRASHES THE COMPILER FPC v0.99.5a } +{ j:=c;} { char -> cardinal } + j:=ord(c);{ char -> cardinal } + j:=s; { shortint -> cardinal } + j:=i; { integer -> cardinal } + j:=w; { word -> cardinal } +end; + +Procedure TestSmallerAssign; +var + b: byte; + c: char; + s: shortint; + i: integer; + w: word; + j: cardinal; +Begin + j:=$ffffffff; + b:=byte(j); + c:=char(j); + s:=shortint(j); + i:=integer(j); + w:=word(j); +end; + + +Procedure TestMul; +var + j: cardinal; + k: cardinal; +Begin + j:=1; + k:=$8000000; + j:=j*16384; + j:=j*k +end; + + +Procedure TestDiv; +var + j: cardinal; + k: cardinal; +Begin + j:=1; + k:=$8000000; + j:=j div 16384; + j:=j div k; + k:=k mod 200; +end; + + +Procedure TestAdd; +Begin +end; + + +Procedure TestSub; +Begin +end; + + +Begin + TestEqualAssign; + TestBiggerAssign; + TestSmallerAssign; + TestMul; + TestDiv; +end. + + diff --git a/tests/test/tmmx1.pp b/tests/test/tmmx1.pp new file mode 100644 index 0000000000..6ac2051fe0 --- /dev/null +++ b/tests/test/tmmx1.pp @@ -0,0 +1,84 @@ +{ this contains currently only a basic test of mmx support } +{ the following instructions are tested: + PSUBW + PSUBUSW + PADDW + PADDUSW +} +uses + mmx; + +procedure do_error(l : longint); + + begin + writeln('Error near number ',l); + halt(1); + end; + +function equal(const v1,v2 : tmmxword) : boolean; + + var + i : integer; + + begin + equal:=false; + for i:=0 to 3 do + if v1[i]<>v2[i] then + exit; + equal:=true; + end; + +procedure testmmxword; + + var t1,t5 : tmmxword; + + const + c0 : tmmxword = (0,0,0,0); + c1 : tmmxword = (1,1,1,1); + c2 : tmmxword = (1234,4321,1111,33333); + c3 : tmmxword = (1234,4321,2222,11111); + c4 : tmmxword = (2468,8642,3333,44444); + c5 : tmmxword = ($ffff,$ffff,$ffff,$ffff); + + begin + {$mmx+} + { Intel: paddw } + t1:=c2+c3; + if not(equal(t1,c4)) then + do_error(1000); + + { Intel: psubw } + t5:=t1-c2; + if not(equal(t5,c3)) then + do_error(1001); + t1:=not(c0); + + { does a not } + if not(equal(t1,c5)) then + do_error(1002); + + { test the saturation } + {$saturation+} + t1:=c5+c2+c3; + if not(equal(t1,c5)) then + do_error(1003); + + t1:=c4-c5-t1; + if not(equal(t1,c0)) then + do_error(1004); + {$saturation-} + end; + +begin + if not(is_mmx_cpu) then + begin + writeln('!!!! Warning: You need a mmx capable CPU to run this test !!!!'); + halt(0); + end; + writeln('Testing basic tmmxword support'); + testmmxword; + writeln('Test succesful'); + writeln; +end. + + diff --git a/tests/test/tobject1.pp b/tests/test/tobject1.pp new file mode 100644 index 0000000000..cc91cb065e --- /dev/null +++ b/tests/test/tobject1.pp @@ -0,0 +1,91 @@ +{ %RESULT=210 } +{$R+} + +program test_fail; + + type + parrayobj = ^tarrayobj; + tarrayobj = object + ar : array [1..4] of real; + constructor init(do_fail : boolean); + procedure test;virtual; + destructor done;virtual; + end; + pbigarrayobj = ^tbigarrayobj; + tbigarrayobj = object(tarrayobj) + ar2 : array [1..10000] of real; + constructor good_init; + constructor wrong_init; + procedure test;virtual; + end; + var + pa1, pa2 : parrayobj; + ta1, ta2 : tarrayobj; + availmem : longint; + + constructor tarrayobj.init(do_fail : boolean); + begin + ar[1]:=1; + if do_fail then + fail; + ar[2]:=2; + end; + + destructor tarrayobj.done; + begin + end; + + procedure tarrayobj.test; + begin + Writeln('@self = ',longint(@self)); + Writeln('typeof = ',longint(typeof(self))); + if ar[1]=1 then + Writeln('Init called'); + if ar[2]=2 then + Writeln('Init successful'); + end; + + constructor tbigarrayobj.good_init; + begin + inherited init(false); + Writeln('End of tbigarrayobj.good_init'); + end; + + constructor tbigarrayobj.wrong_init; + begin + inherited init(true); + Writeln('End of tbigarrayobj.wrong_init'); + end; + + procedure tbigarrayobj.test; + begin + Writeln('tbigarrayobj.test called'); + Inherited test; + end; + + begin + availmem:=memavail; + new(pa1,init(false)); + writeln('After successful new(pa1,init), memory used = ',availmem - memavail); + new(pa2,init(true)); + writeln('After unsuccessful new(pa2,init), memory used = ',availmem - memavail); + writeln('pa1 = ',longint(pa1),' pa2 = ',longint(pa2)); + writeln('Call to pa1^.test after successful init'); + pa1^.test; + dispose(pa1,done); + writeln('After release of pa1, memory used = ',availmem - memavail); + pa1:=new(pbigarrayobj,good_init); + writeln('After successful pa1:=new(pbigarrayobj,good_init), memory used = ',availmem - memavail); + pa2:=new(pbigarrayobj,wrong_init); + writeln('After unsuccessful pa2:=new(pbigarrayobj,wrong_init), memory used = ',availmem - memavail); + writeln('pa1 = ',longint(pa1),' pa2 = ',longint(pa2)); + writeln('Call to pa1^.test after successful init'); + pa1^.test; + ta1.init(false); + writeln('Call to ta1.test after successful init'); + ta1.test; + ta2.init(true); + writeln('typeof(ta2) = ',longint(typeof(ta2)),' after unsuccessful init'); + Writeln('Trying to call ta2.test (should generate a Run Time Error)'); + ta2.test; + end. diff --git a/tests/test/tobject2.pp b/tests/test/tobject2.pp new file mode 100644 index 0000000000..2ff9946e9c --- /dev/null +++ b/tests/test/tobject2.pp @@ -0,0 +1,103 @@ + + +TYPE + + psimpleobject = ^tsimpleobject; + tsimpleobject = object + x: longint; + z: array[0..34] of byte; + Procedure Init(somez: longint); + Procedure Hello; + end; + + pbase = ^tbase; + tbase = object + numofentries : longint; + constructor init(i : integer); + destructor done; virtual; + procedure showit; virtual; + end; + + pderived = ^tderived; + tderived = object(tbase) + x: longint; + constructor init; + destructor done; virtual; + procedure showit; virtual; + end; + + + Procedure TsimpleObject.init(somez: longint); + var + i: byte; + Begin + for i:=0 to 34 do + z[i]:=i; + x:=somez; + end; + + + Procedure TSimpleObject.hello; + var + i: byte; + Begin + WriteLn('hello world'); + for i:=0 to 34 do + Write(z[i],' '); + WriteLn; + WriteLN(x); + end; + + + constructor tbase.init(i: integer); + Begin + numofentries := i; + end; + + destructor tbase.done; + Begin + end; + + procedure tbase.showit; + Begin + WriteLn('This is the base class'); + end; + + constructor tderived.init; + Begin + inherited init(5); + x:=10; + end; + + procedure tderived.showit; + Begin + WriteLn('This is the derived class'); + WriteLn(numofentries); + WriteLn(x); + end; + + destructor tderived.done; + Begin + end; + + + Procedure CreateObject; + var + obj: pbase; + Begin + obj^.showit; + dispose(obj,done); + end; + +var + myobj: tsimpleobject; + obj: pbase; + devobj: tderived; +Begin + WriteLn(MemAvail); + obj:=new(pbase,init(10)); + obj^.showit; + WriteLn(MemAvail); + dispose(obj,done); + WriteLn(MemAvail); +end. \ No newline at end of file diff --git a/tests/test/toperator1.pp b/tests/test/toperator1.pp new file mode 100644 index 0000000000..181045f258 --- /dev/null +++ b/tests/test/toperator1.pp @@ -0,0 +1,15 @@ +uses + toperator2,toperator3; + +var + a,b,c : op1; + d,e,f : op2; + +begin + a.x:=67;a.y:=-45; + b.x:=89;b.y:=23; + c:=a+b; + e.x:=67;e.y:=-45;e.z:=67; + f.x:=89;f.y:=23;f.z:=56; + d:=e+f; +end. \ No newline at end of file diff --git a/tests/test/toperator2.pp b/tests/test/toperator2.pp new file mode 100644 index 0000000000..5ca75b06fc --- /dev/null +++ b/tests/test/toperator2.pp @@ -0,0 +1,38 @@ +unit toperator2; + +interface + +type + op1 = record + x,y : longint; + end; + +operator + (const a,b : op1) c : op1; + +implementation + +uses + toperator3; + +operator + (const a,b : op1) c : op1; +begin + c.x:=a.x+b.x; + c.y:=a.y+b.y; +end; + +procedure test_op2; +var + a,b,c : op2; +begin + a.x:=44; + a.y:=67; + b.x:=-34; + b.y:=-57; + c:=a+b; + if (c.x<>10) or (c.y<>10) then + Halt(1); +end; + +begin + test_op2; +end. \ No newline at end of file diff --git a/tests/test/toperator3.pp b/tests/test/toperator3.pp new file mode 100644 index 0000000000..ace3fb914e --- /dev/null +++ b/tests/test/toperator3.pp @@ -0,0 +1,66 @@ +unit toperator3; + +interface + +type + op2 = record + x,y,z : longint; + end; + +operator + (const a,b : op2) c : op2; + +implementation + +uses + toperator2,toperator4; + +operator + (const a,b : op2) c : op2; +begin + c.x:=a.x+b.x; + c.y:=a.y+b.y; +end; + +procedure test_op3; +var + a,b,c : op3; +begin + a.x:=44.0; + a.y:=67.0; + b.x:=-34.0; + b.y:=-57.0; + c:=a+b; + if (c.x<>10.0) or (c.y<>10.0) then + Halt(1); +end; + +procedure test_op2; +var + a,b,c : op2; +begin + a.x:=44; + a.y:=67; + b.x:=-34; + b.y:=-57; + c:=a+b; + if (c.x<>10) or (c.y<>10) then + Halt(1); +end; + +procedure test_op1; +var + a,b,c : op1; +begin + a.x:=44; + a.y:=67; + b.x:=-34; + b.y:=-57; + c:=a+b; + if (c.x<>10) or (c.y<>10) then + Halt(1); +end; + +begin + test_op1; + test_op2; + test_op3; +end. \ No newline at end of file diff --git a/tests/test/toperator4.pp b/tests/test/toperator4.pp new file mode 100644 index 0000000000..20a07e70e5 --- /dev/null +++ b/tests/test/toperator4.pp @@ -0,0 +1,20 @@ +unit toperator4; + +interface + +type + op3 = record + x,y : real; + end; + +operator + (const a,b : op3) c : op3; + +implementation + +operator + (const a,b : op3) c : op3; +begin + c.x:=a.x+b.x; + c.y:=a.y+b.y; +end; + +end. \ No newline at end of file diff --git a/tests/test/tpara1.pp b/tests/test/tpara1.pp new file mode 100644 index 0000000000..9c32ab5bf3 --- /dev/null +++ b/tests/test/tpara1.pp @@ -0,0 +1,95 @@ +uses + erroru; + +{$ifdef HASOUT} +type + tr1 = record + l1,l2 : longint; + end; + +procedure p1(out b : byte); + + begin + if b<>0 then + do_error(1001); + b:=$aa; + end; + +procedure p2(out w : word); + + begin + if w<>0 then + do_error(1002); + w:=$aaaa; + end; + +procedure p3(out d : dword); + + begin + if d<>0 then + do_error(1003); + d:=$aaaaaaaa; + end; + +procedure p4(out r : tr1); + + begin + if r.l1<>0 then + do_error(1004); + if r.l2<>0 then + do_error(1005); + r.l1:=$aaaaaaaa; + r.l2:=$aaaaaaaa; + end; + +procedure p5(out a : ansistring); + + begin + if a<>'' then + do_error(1000); + a:='Now it''s another ansistring'; + end; + +var + b : byte; + w : word; + d : dword; + r1 : tr1; + a : ansistring; + + +begin + b:=$ff; + w:=$ffff; + d:=$ffffffff; + a:='An ansistring'; + r1.l1:=$ffffffff; + r1.l2:=$ffffffff; + + p1(b); + if b<>$aa then + do_error(1100); + + p2(w); + if w<>$aaaa then + do_error(1101); + + p3(d); + if d<>$aaaaaaaa then + do_error(1102); + + p4(r1); + if r1.l1<>$aaaaaaaa then + do_error(1103); + if r1.l2<>$aaaaaaaa then + do_error(1104); + + p5(a); + if a<>'Now it''s another ansistring' then + do_error(1105); +end. +{$else} +begin + Writeln('No out parameter support'); +end. +{$endif HASOUT} diff --git a/tests/test/tprocvar1.pp b/tests/test/tprocvar1.pp new file mode 100644 index 0000000000..0f04ed5e1d --- /dev/null +++ b/tests/test/tprocvar1.pp @@ -0,0 +1,168 @@ +{ + $Id$ + This program tries to test any aspect of procedure variables and related + stuff in FPC mode +} + +{$ifdef go32v2} +uses + dpmiexcp; +{$endif go32v2} + +Type + TMyRecord = Record + MyProc1,MyProc2 : Procedure(l : longint); + MyVar : longint; + end; + +procedure do_error(i : longint); + + begin + writeln('Error near: ',i); + halt(1); + end; + +var + globalvar : longint; + +type + tpoo_rec = record + procpointer : pointer; + s : pointer; + end; + +procedure callmethodparam(s : pointer;addr : pointer;param : longint); + + var + p : procedure(param : longint) of object; + + begin + tpoo_rec(p).procpointer:=addr; + tpoo_rec(p).s:=s; + p(param); + end; + +type + to1 = object + constructor init; + procedure test1; + procedure test2(l : longint); + procedure test3(l : longint);virtual;abstract; + end; + + to2 = object(to1) + procedure test3(l : longint);virtual; + end; + + constructor to1.init; + + begin + end; + + procedure to1.test1; + var + p:pointer; + begin + // useless only a semantic test + p:=@to1.test1; + // this do we use to do some testing + p:=@to1.test2; + globalvar:=0; + callmethodparam(@self,p,1234); + if globalvar<>1234 then + do_error(1000); + end; + + procedure to1.test2(l : longint); + + begin + globalvar:=l; + end; + + procedure to2.test3(l : longint); + + begin + globalvar:=l; + end; + + procedure testproc(l : longint); + + begin + globalvar:=l; + end; + +const + constmethodaddr : pointer = @to1.test2; + MyRecord : TMyRecord = ( + MyProc1 : TestProc; + MyProc2 : @TestProc; + ); + +var + o1 : to1; + o2 : to2; + p : procedure(l : longint) of object; + +begin + { Simple procedure variables } + writeln('Procedure variables'); + globalvar:=0; + MyRecord.MyProc1(1234); + if globalvar<>1234 then + do_error(2000); + globalvar:=0; + MyRecord.MyProc2(4321); + if globalvar<>4321 then + do_error(2001); + writeln('Ok'); + { } + { Procedures of objects } + { } + o1.init; + o2.init; + writeln('Procedures of objects'); + p:=@o1.test2; + globalvar:=0; + p(12); + if globalvar<>12 then + do_error(1002); + writeln('Ok'); + p:=@o2.test3; + globalvar:=0; + p(12); + if globalvar<>12 then + do_error(1004); + writeln('Ok'); + { } + { Pointers and addresses of procedures } + { } + writeln('Getting an address of a method as pointer'); + o1.test1; + globalvar:=0; + callmethodparam(@o1,constmethodaddr,34); + if globalvar<>34 then + do_error(1001); + writeln('Ok'); +end. +{ + $Log$ + Revision 1.1 2000-11-29 23:14:19 peter + * new testsuite setup + + Revision 1.1 2000/07/13 09:22:06 michael + + Initial import + + Revision 1.2 2000/04/02 09:06:55 florian + *** empty log message *** + + Revision 1.1 1999/12/02 17:37:45 peter + * moved *.pp into subdirs + * fpcmaked + + Revision 1.2 1999/11/29 22:55:25 florian + * small update + + Revision 1.1 1999/09/11 19:45:33 florian + * first version, please keep it up-to-date + +} diff --git a/tests/test/tprocvar2.pp b/tests/test/tprocvar2.pp new file mode 100644 index 0000000000..b158607521 --- /dev/null +++ b/tests/test/tprocvar2.pp @@ -0,0 +1,38 @@ +{$F+} +{$ifdef fpc} +{$mode tp} +{$endif fpc} + +type + tproc = procedure; + tprocx = procedure(x : longint); + +const + dummy_call_count : longint = 0; + +procedure dummy; +begin + writeln('Dummy called'); + inc(dummy_call_count); +end; + +procedure dummyx(x : longint); +begin + writeln('Dummy called with x=',x); + inc(dummy_call_count); +end; + +var + tp2 : tproc; + tp1x,tp2x : tprocx; +const + tp1 : tproc = dummy; + +begin + move(@tp1,@tp2,sizeof(tproc)); + tp2; + tp1x:=dummyx; + move(@tp1x,@tp2x,sizeof(tproc)); + tp2x(2); + +end. \ No newline at end of file diff --git a/tests/test/trandom.pp b/tests/test/trandom.pp new file mode 100644 index 0000000000..b414a1f1a3 --- /dev/null +++ b/tests/test/trandom.pp @@ -0,0 +1,136 @@ +{ %GRAPH } +{ %INTERACTIVE } +{ + This program test the random function + It gets 10M random values + that are placed in 10000 windows + and print the number of occurence for each window + and the profile of the distribution + of the counts + + - this gave very bad value due to a modulo problem + but after this solved + it still shows strange wings !! +} +program test_random; + +uses +{$ifdef go32v2} + dpmiexcp, +{$endif go32v2} + graph; + + +const max = 1000; + maxint = 10000*max; + + +var x : array[0..max-1] of longint; + y : array[-100..100] of longint; + + mean,level,i : longint; + maxcount,delta,maximum,minimum : longint; + st,st2 : string; + gm,gd : integer; + color : longint; + +begin + +{$ifdef go32v2} + gm:=m640x400x256; + gd:=vesa; +{$else } + gd:=detect; +{$endif } + InitGraph(gd,gm,'\tp\bgi'); +{$ifdef FPC} + SetWriteMode(NormalPut); +{$endif FPC} + SetColor(red); + color:=blue; + + mean:=maxint div max; + + setfillstyle(solidfill,blue); + for level:=0 to 10 do + begin + + for i:=0 to max-1 do + x[i]:=0; + for i:=-100 to 100 do + y[i]:=0; + for i:=0 to maxint-1 do + begin + if level=0 then + inc(x[trunc(random*max)]) + else + inc(x[random(max*level) div (level)]); + if i mod (maxint div 10) = 0 then + begin + bar(20+textwidth('iteration '),17, + 20+textwidth('iteration 0000000'),26); + st:=''; + str(i,st); + st:='iteration '+st; + OutTextXY(20,20,st); + {Writeln(stderr,st);} + end; + end; + maximum:=0; + minimum:=$7FFFFFFF; + maxcount:=0; + for i:=0 to max-1 do + begin + if x[i]>maximum then + maximum:=x[i]; + if x[i]maxcount then + maxcount:=y[i]; + if maxcount=0 then + inc(maxcount); + + OutTextXY(GetMaxX div 2,GetMaxY-30,'Random Test Program'); + + str(level,st); + st:='Level '+st; + bar(30,GetMaxY-65, + 30+textwidth(st),getMaxY-52); + OutTextXY(30,GetMaxY-59,st); + str(maximum,st); + str(minimum,st2); + st:='Maximum = '+st+' Minimum ='+st2; + bar(30,GetMaxY-35, + 30+Textwidth(st),getMaxY-22); + OutTextXY(30,GetMaxY-29,st); + + for i:=0 to max-1 do + putpixel( (i*getmaxX) div max, + GetMaxY-(x[i]*getMaxY) div (2*mean), color); + inc(color); + setColor(color); + delta:=maximum-minimum+1; + for i:=-100 to 100 do + begin + if i=minimum then + moveto( ((i+100)*getMaxX) div 201, + GetMaxY-(y[i]*getMaxY) div maxcount) + else + lineto( ((i+100)*getMaxX) div 201, + GetMaxY-(y[i]*getMaxY) div maxcount); + if y[i]>0 then + circle( ((i+100)*getMaxX) div 201, + GetMaxY-(y[i]*getMaxY) div maxcount,5); + end; + readln; + inc(color); + end; + CloseGraph; +end. diff --git a/tests/test/trange1.pp b/tests/test/trange1.pp new file mode 100644 index 0000000000..e2170e022b --- /dev/null +++ b/tests/test/trange1.pp @@ -0,0 +1,232 @@ +{$mode objfpc} +uses sysutils; + +var + error: boolean; + +{$r+} +function testlongint_int64(i: int64; shouldfail: boolean): boolean; +var + l: longint; + failed: boolean; +begin + failed := false; + try + l := i; + except + failed := true; + end; + result := failed = shouldfail; + error := error or not result; +end; + +function testlongint_qword(i: qword; shouldfail: boolean): boolean; +var + l: longint; + failed: boolean; +begin + failed := false; + try + l := i; + except + failed := true; + end; + result := failed = shouldfail; + error := error or not result; +end; + +function testdword_int64(i: int64; shouldfail: boolean): boolean; +var + l: dword; + failed: boolean; +begin + failed := false; + try + l := i; + except + failed := true; + end; + result := failed = shouldfail; + error := error or not result; +end; + +function testdword_qword(i: qword; shouldfail: boolean): boolean; +var + l: dword; + failed: boolean; +begin + failed := false; + try + l := i; + except + failed := true; + end; + result := failed = shouldfail; + error := error or not result; +end; + +{$r-} + +var + i: int64; + q: qword; +begin + error := false; +{ *********************** int64 to longint ********************* } + writeln('int64 to longint'); + i := $ffffffffffffffff; + writeln(i); + if not testlongint_int64(i,false) then + writeln('test1 failed'); + i := i and $ffffffff00000000; + writeln(i); + if not testlongint_int64(i,true) then + writeln('test2 failed'); + inc(i); + writeln(i); + if not testlongint_int64(i,true) then + writeln('test3 failed'); + longint(i) := $80000000; + writeln(i); + if not testlongint_int64(i,false) then + writeln('test4 failed'); + i := 0; + longint(i) := $80000000; + writeln(i); + if not testlongint_int64(i,true) then + writeln('test5 failed'); + dec(i); + writeln(i); + if not testlongint_int64(i,false) then + writeln('test6 failed'); + i := 0; + longint(i) := $ffffffff; + writeln(i); + if not testlongint_int64(i,true) then + writeln('test7 failed'); + i := 0; + writeln(i); + if not testlongint_int64(i,false) then + writeln('test8 failed'); + +{ *********************** qword to longint ********************* } + writeln; + writeln('qword to longint'); + q := $ffffffffffffffff; + writeln(q); + if not testlongint_qword(q,true) then + writeln('test1 failed'); + q := q and $ffffffff00000000; + writeln(q); + if not testlongint_qword(q,true) then + writeln('test2 failed'); + inc(q); + writeln(q); + if not testlongint_qword(q,true) then + writeln('test3 failed'); + longint(q) := $80000000; + writeln(q); + if not testlongint_qword(q,true) then + writeln('test4 failed'); + q := 0; + longint(q) := $80000000; + writeln(q); + if not testlongint_qword(q,true) then + writeln('test5 failed'); + dec(q); + writeln(q); + if not testlongint_qword(q,false) then + writeln('test6 failed'); + q := 0; + longint(q) := $ffffffff; + writeln(q); + if not testlongint_qword(q,true) then + writeln('test7 failed'); + q := 0; + writeln(q); + if not testlongint_qword(q,false) then + writeln('test8 failed'); + +{ *********************** int64 to dword ********************* } + writeln; + writeln('int64 to dword'); + i := $ffffffffffffffff; + writeln(i); + if not testdword_int64(i,true) then + writeln('test1 failed'); + i := i and $ffffffff00000000; + writeln(i); + if not testdword_int64(i,true) then + writeln('test2 failed'); + inc(i); + writeln(i); + if not testdword_int64(i,true) then + writeln('test3 failed'); + longint(i) := $80000000; + writeln(i); + if not testdword_int64(i,true) then + writeln('test4 failed'); + i := 0; + longint(i) := $80000000; + writeln(i); + if not testdword_int64(i,false) then + writeln('test5 failed'); + dec(i); + writeln(i); + if not testdword_int64(i,false) then + writeln('test6 failed'); + i := 0; + longint(i) := $ffffffff; + writeln(i); + if not testdword_int64(i,false) then + writeln('test7 failed'); + i := 0; + writeln(i); + if not testdword_int64(i,false) then + writeln('test8 failed'); + +{ *********************** qword to dword ********************* } + writeln; + writeln('qword to dword'); + q := $ffffffffffffffff; + writeln(q); + if not testdword_qword(q,true) then + writeln('test1 failed'); + q := q and $ffffffff00000000; + writeln(q); + if not testdword_qword(q,true) then + writeln('test2 failed'); + inc(q); + writeln(q); + if not testdword_qword(q,true) then + writeln('test3 failed'); + longint(q) := $80000000; + writeln(q); + if not testdword_qword(q,true) then + writeln('test4 failed'); + q := 0; + longint(q) := $80000000; + writeln(q); + if not testdword_qword(q,false) then + writeln('test5 failed'); + dec(q); + writeln(q); + if not testdword_qword(q,false) then + writeln('test6 failed'); + q := 0; + longint(q) := $ffffffff; + writeln(q); + if not testdword_qword(q,false) then + writeln('test7 failed'); + q := 0; + writeln(q); + if not testdword_qword(q,false) then + writeln('test8 failed'); + + if error then + begin + writeln; + writeln('still range check problems!'); + halt(1); + end; +end. diff --git a/tests/test/trange2.pp b/tests/test/trange2.pp new file mode 100644 index 0000000000..4ae7ee677a --- /dev/null +++ b/tests/test/trange2.pp @@ -0,0 +1,30 @@ +{$mode objfpc} +uses sysutils; +{$r+} + +var + l: longint; + c: cardinal; + n: longint; +begin + n := 0; + l := -1; + try + c := l; + except + writeln('caught 1!'); + inc(n); + end; + longint(c) := $ffffffff; + try + l := c; + except + writeln('caught 2!'); + inc(n); + end; + if n <> 2 then + begin + writeln('Still problems with range checking between longint/cardinal'); + halt(1); + end; +end. diff --git a/tests/test/trange3.pp b/tests/test/trange3.pp new file mode 100644 index 0000000000..c8e289dd6d --- /dev/null +++ b/tests/test/trange3.pp @@ -0,0 +1,134 @@ +{$mode objfpc} +uses sysutils; + +{$r+} + +var + a1: array[-5..6] of byte; + a2: array[-12..-1] of byte; + a3: array[0..6] of byte; + a4: array[1..12] of byte; + + c: cardinal; + l: longint; + b: byte; + finalerror: boolean; + +function check_longint(l: longint; res1, res2, res3, res4: boolean): boolean; +var + caught, + error: boolean; +begin + result := false; + + caught := false; + try + b := a1[l]; + except + caught := true; + end; + error := caught <> res1; + if error then writeln('long 1 failed for ',l); + result := result or error; + + caught := false; + try + b := a2[l]; + except + caught := true; + end; + error := caught <> res2; + if error then writeln('long 2 failed for ',l); + result := result or error; + + caught := false; + try + b := a3[l]; + except + caught := true; + end; + error := caught <> res3; + if error then writeln('long 3 failed for ',l); + result := result or error; + + caught := false; + try + b := a4[l]; + except + caught := true; + end; + error := caught <> res4; + if error then writeln('long 4 failed for ',l); + result := result or error; + writeln; +end; + +function check_cardinal(l: cardinal; res1, res2, res3, res4: boolean): boolean; +var + caught, + error: boolean; +begin + result := false; + + caught := false; + try + b := a1[l]; + except + caught := true; + end; + error := caught <> res1; + if error then writeln('card 1 failed for ',l); + result := result or error; + + caught := false; + try + b := a2[l]; + except + caught := true; + end; + error := caught <> res2; + if error then writeln('card 2 failed for ',l); + result := result or error; + + caught := false; + try + b := a3[l]; + except + caught := true; + end; + error := caught <> res3; + if error then writeln('card 3 failed for ',l); + result := result or error; + + caught := false; + try + b := a4[l]; + except + caught := true; + end; + error := caught <> res4; + if error then writeln('card 4 failed for ',l); + result := result or error; + writeln; +end; + + +begin + finalerror := + check_longint(-1,false,false,true,true); + finalerror := + check_longint(-6,true,false,true,true) or finalerror; + finalerror := + check_longint(0,false,true,false,true) or finalerror; + finalerror := + check_cardinal(0,false,true,false,true); + finalerror := + check_cardinal(cardinal($ffffffff),true,true,true,true) or finalerror; + finalerror := + check_cardinal(5,false,true,false,false) or finalerror; + if finalerror then + begin + writeln('Still errors in range checking for array indexes'); + halt(1); + end; +end. diff --git a/tests/test/trange4.pp b/tests/test/trange4.pp new file mode 100644 index 0000000000..bf529f2c94 --- /dev/null +++ b/tests/test/trange4.pp @@ -0,0 +1,24 @@ + +var x : byte; + y : longint; + +procedure set_x; +begin + y:=345; + {$R-} + x:=y; + {$R+} + Writeln('x = ',x); + {$R-} + x:=y + {$R+} +end; +{ the bug comes from the fact that as there is no +semicolon after x:=y the parser must read up to end; statement +and thus change the range check mode before +the assign node is created !! } + +begin + set_x; + Writeln('x = ',x); +end. \ No newline at end of file diff --git a/tests/test/treal1.pp b/tests/test/treal1.pp new file mode 100644 index 0000000000..a1a886462a --- /dev/null +++ b/tests/test/treal1.pp @@ -0,0 +1,76 @@ +{$E-} + + Procedure TestSub; + var + i : Real; + j : Real; + Begin + i:=99.9; + j:=10.0; + i:=i-j; + Write('RESULT SHOULD BE: 89.9 :'); + WriteLn(i); + i:=j-i; + Write('RESULT SHOULD BE: -79.9 :'); + WriteLn(i); + j:=j-10.0; + Write('RESULT SHOULD BE: 0.0 :'); + WriteLn(j); + end; + + Function TestAdd(i : real): Real; + Begin + i:=i+1.5; + if i > 10.0 then + Begin + Write('RESULT SHOULD BE: 10.5 :'); + WriteLn(i); + exit; + end; + TestAdd:=TestAdd(i); + end; + + Procedure TestDiv; + var + i : Real; + j : Real; + Begin + i:=-99.9; + j:=10.0; + i:=i / j; + Write('RESULT SHOULD BE: -9.9 :'); + WriteLn(i); + i:=j / i; + Write('RESULT SHOULD BE: -1.01 :'); + WriteLn(i); + j:=i / 10.0; + Write('RESULT SHOULD BE: -0.1001 :'); + WriteLn(j); + end; + + + + Procedure TestComplex; + var + i : real; + Begin + Write('RESULT SHOULD BE 2.09 :'); + i := 4.4; + WriteLn(Sqrt(i)); + Write('RESULT SHOULD BE PI :'); + WriteLn(Pi); + Write('RESULT SHOULD BE 4.0 :'); + WriteLn(Round(3.6)); + end; + + +Begin + WriteLn('------------ SUB ---------------'); + TestSub; + WriteLn('------------ ADD ---------------'); + TestAdd(0); + WriteLn('------------ DIV ---------------'); + TestDiv; + WriteLn('------------ COMPLEX ---------------'); + TestComplex; +end. diff --git a/tests/test/tresstr.pp b/tests/test/tresstr.pp new file mode 100644 index 0000000000..5c1b1e98dd --- /dev/null +++ b/tests/test/tresstr.pp @@ -0,0 +1,8 @@ +{$mode objfpc} +resourcestring + s = 'Hello world'; + +begin + if s<>'Hello world' then + halt(1); +end. diff --git a/tests/test/trtti1.pp b/tests/test/trtti1.pp new file mode 100644 index 0000000000..89c6372c7f --- /dev/null +++ b/tests/test/trtti1.pp @@ -0,0 +1,567 @@ +Program trtti1; + +{$Mode Delphi} +{$M+} + +Uses + Typinfo; + +Const TypeNames : Array [TTYpeKind] of string[15] = + ('Unknown','Integer','Char','Enumeration', + 'Float','Set','Method','ShortString','LongString', + 'AnsiString','WideString','Variant','Array','Record', + 'Interface','Class','Object','WideChar','Bool','Int64','QWord'); + +Const OrdinalTypes = [tkInteger,tkChar,tkENumeration,tkbool]; + +Type + TMyEnum = (meFirst,meSecond,meThird); + TMyTestObject = Class(TObject) + Private + FBoolean : Boolean; + FByte : Byte; + FChar : Char; + FWord : Word; + FInteger : Integer; + Flongint : Longint; + FCardinal : Cardinal; + FReal : Real; + FExtended : Extended; + FMyEnum : TMyEnum; + FAnsiString : AnsiSTring; + FObj : TObject; + FStored : Boolean; + Function GetBoolean : Boolean; + Function GetByte : Byte; + Function GetChar : Char; + Function GetWord : Word; + Function GetInteger : Integer; + Function GetLongint : Longint; + Function GetCardinal : Cardinal; + Function GetReal : Real; + Function GetExtended : Extended; + Function GetAnsiString : AnsiString; + Function GetMyEnum : TMyEnum; + Procedure SetBoolean ( Value : Boolean); + Procedure SetByte ( Value : Byte ); + Procedure SetChar ( Value : Char ); + Procedure SetWord ( Value : Word ); + Procedure SetInteger ( Value : Integer ); + Procedure SetLongint ( Value : Longint ); + Procedure SetCardinal ( Value : Cardinal ); + Procedure SetReal ( Value : Real ); + Procedure SetExtended ( Value : Extended ); + Procedure SetAnsiString ( Value : AnsiString ); + Procedure SetMyEnum ( Value : TMyEnum ); + Function GetVirtualBoolean : Boolean; virtual; + Function GetVirtualByte : Byte; virtual; + Function GetVirtualChar : Char; virtual; + Function GetVirtualWord : Word; virtual; + Function GetVirtualInteger : Integer; virtual; + Function GetVirtualLongint : Longint; virtual; + Function GetVirtualCardinal : Cardinal; virtual; + Function GetVirtualReal : Real; virtual; + Function GetVirtualExtended : Extended; virtual; + Function GetVirtualAnsiString : AnsiString; virtual; + Function GetVirtualMyEnum : TMyEnum; virtual; + Procedure SetVirtualBoolean ( Value : Boolean); virtual; + Procedure SetVirtualByte ( Value : Byte ); virtual; + Procedure SetVirtualChar ( Value : Char ); virtual; + Procedure SetVirtualWord ( Value : Word ); virtual; + Procedure SetVirtualInteger ( Value : Integer ); virtual; + Procedure SetVirtualLongint ( Value : Longint ); virtual; + Procedure SetVirtualCardinal ( Value : Cardinal ); virtual; + Procedure SetVirtualReal ( Value : Real ); virtual; + Procedure SetVirtualExtended ( Value : Extended ); virtual; + Procedure SetVirtualAnsiString ( Value : AnsiString ); virtual; + Procedure SetVirtualMyEnum ( Value : TMyEnum ); virtual; + Function GetStaticStored : Boolean; + Function GetVirtualStored : Boolean;virtual; + Public + Constructor Create; + Destructor Destroy;override; + Published + Property ObjField: TObject read FObj write FObj; + Property BooleanField : Boolean Read FBoolean Write FBoolean; + Property ByteField : Byte Read FByte Write FByte; + Property CharField : Char Read FChar Write FChar; + Property WordField : Word Read FWord Write FWord; + Property IntegerField : Integer Read FInteger Write FInteger; + Property LongintField : Longint Read FLongint Write FLongint; + Property CardinalField : Cardinal Read FCardinal Write FCardinal; + Property RealField : Real Read FReal Write FReal; + Property ExtendedField : Extended Read FExtended Write FExtended; + Property AnsiStringField : AnsiString Read FAnsiString Write FAnsiString; + Property MyEnumField : TMyEnum Read FMyEnum Write FMyEnum; + Property BooleanMethod : Boolean Read GetBoolean Write SetBoolean; + Property ByteMethod : Byte Read GetByte Write SetByte; + Property CharMethod : Char Read GetChar Write SetChar; + Property WordMethod : Word Read GetWord Write SetWord; + Property IntegerMethod : Integer Read GetInteger Write SetInteger; + Property LongintMethod : Longint Read GetLongint Write SetLongint; + Property CardinalMethod : Cardinal Read GetCardinal Write SetCardinal; + Property RealMethod : Real Read GetReal Write SetReal; + Property ExtendedMethod : Extended Read GetExtended Write SetExtended; + Property AnsiStringMethod : AnsiString Read GetAnsiString Write SetAnsiString; + Property MyEnumMethod : TMyEnum Read GetMyEnum Write SetMyEnum; + Property BooleanVirtualMethod : Boolean Read GetVirtualBoolean Write SetVirtualBoolean; + Property ByteVirtualMethod : Byte Read GetVirtualByte Write SetVirtualByte; + Property CharVirtualMethod : Char Read GetVirtualChar Write SetVirtualChar; + Property WordVirtualMethod : Word Read GetVirtualWord Write SetVirtualWord; + Property IntegerVirtualMethod : Integer Read GetVirtualInteger Write SetVirtualInteger; + Property LongintVirtualMethod : Longint Read GetVirtualLongint Write SetVirtualLongint; + Property CardinalVirtualMethod : Cardinal Read GetVirtualCardinal Write SetVirtualCardinal; + Property RealVirtualMethod : Real Read GetVirtualReal Write SetVirtualReal; + Property ExtendedVirtualMethod : Extended Read GetVirtualExtended Write SetVirtualExtended; + Property AnsiStringVirtualMethod : AnsiString Read GetVirtualAnsiString Write SetVirtualAnsiString; + Property MyEnumVirtualMethod : TMyEnum Read GetVirtualMyEnum Write SetVirtualMyEnum; + Property StoredIntegerConstFalse : Longint Read FLongint Stored False; + Property StoredIntegerConstTrue : Longint Read FLongint Stored True; + Property StoredIntegerField : Longint Read FLongint Stored FStored; + Property StoredIntegerMethod : Longint Read Flongint Stored GetStaticStored; + Property StoredIntegerVirtualMethod : Longint Read Flongint Stored GetVirtualStored; + end; + +Constructor TMyTestObject.Create; + +begin + FBoolean:=true; + FByte:=1; { : Byte;} + FChar:='B'; { : Char; } + FWord:=3; {: Word; } + FInteger:=4; {: Integer; } + Flongint:=5; { : Longint; } + FCardinal:=6; {: Cardinal; } + FReal:=7.0; { : Real;} + FExtended :=8.0; { Extended;} + FMyEnum:=methird; { TMyEnum;} + FAnsiString:='this is an AnsiString'; +end; + +Destructor TMyTestObject.Destroy; + +begin + Inherited Destroy; +end; + +Function TMyTestObject.GetBoolean : boolean; + +begin + Result:=FBoolean; +end; + +Function TMyTestObject.GetByte : Byte; + +begin + Result:=FByte; +end; + +Function TMyTestObject.GetChar : Char; +begin + Result:=FChar; +end; + +Function TMyTestObject.GetWord : Word; +begin + Result:=FWord; +end; + +Function TMyTestObject.GetInteger : Integer; +begin + Result:=FInteger; +end; + +Function TMyTestObject.GetLongint : Longint; +begin + Result:=FLongint; +end; + +Function TMyTestObject.GetCardinal : Cardinal; +begin + Result:=FCardinal; +end; + +Function TMyTestObject.GetReal : Real; +begin + Result:=FReal; +end; + +Function TMyTestObject.GetExtended : Extended; +begin + Result:=FExtended; +end; + +Function TMyTestObject.GetAnsiString : AnsiString; +begin + Result:=FAnsiString; +end; + +Function TMyTestObject.GetMyEnum : TMyEnum; +begin + Result:=FMyEnum; +end; + +Procedure TMyTestObject.Setboolean ( Value : boolean ); +begin + Fboolean:=Value; +end; + + +Procedure TMyTestObject.SetByte ( Value : Byte ); +begin + FByte:=Value; +end; + +Procedure TMyTestObject.SetChar ( Value : Char ); +begin + FChar:=Value; +end; + +Procedure TMyTestObject.SetWord ( Value : Word ); +begin + FWord:=Value; +end; + +Procedure TMyTestObject.SetInteger ( Value : Integer ); +begin + FInteger:=Value; +end; + +Procedure TMyTestObject.SetLongint ( Value : Longint ); +begin + FLongint:=Value; +end; + +Procedure TMyTestObject.SetCardinal ( Value : Cardinal ); +begin + FCardinal:=Value; +end; + +Procedure TMyTestObject.SetReal ( Value : Real ); +begin + FReal:=Value; +end; + +Procedure TMyTestObject.SetExtended ( Value : Extended ); +begin + FExtended:=Value; +end; + +Procedure TMyTestObject.SetAnsiString ( Value : AnsiString ); +begin + FAnsiString:=Value; +end; + +Procedure TMyTestObject.SetMyEnum ( Value : TMyEnum ); +begin + FMyEnum:=Value; +end; + +Function TMyTestObject.GetVirtualBoolean : boolean; + +begin + Result:=FBoolean; +end; + +Function TMyTestObject.GetVirtualByte : Byte; + +begin + Result:=FByte; +end; + +Function TMyTestObject.GetVirtualChar : Char; +begin + Result:=FChar; +end; + +Function TMyTestObject.GetVirtualWord : Word; +begin + Result:=FWord; +end; + +Function TMyTestObject.GetVirtualInteger : Integer; +begin + Result:=FInteger; +end; + +Function TMyTestObject.GetVirtualLongint : Longint; +begin + Result:=FLongint; +end; + +Function TMyTestObject.GetVirtualCardinal : Cardinal; +begin + Result:=FCardinal; +end; + +Function TMyTestObject.GetVirtualReal : Real; +begin + Result:=FReal; +end; + +Function TMyTestObject.GetVirtualExtended : Extended; +begin + Result:=FExtended; +end; + +Function TMyTestObject.GetVirtualAnsiString : AnsiString; +begin + Result:=FAnsiString; +end; + +Function TMyTestObject.GetVirtualMyEnum : TMyEnum; +begin + Result:=FMyEnum; +end; + +Procedure TMyTestObject.SetVirtualboolean ( Value : boolean ); +begin + Fboolean:=Value; +end; + + +Procedure TMyTestObject.SetVirtualByte ( Value : Byte ); +begin + FByte:=Value; +end; + +Procedure TMyTestObject.SetVirtualChar ( Value : Char ); +begin + FChar:=Value; +end; + +Procedure TMyTestObject.SetVirtualWord ( Value : Word ); +begin + FWord:=Value; +end; + +Procedure TMyTestObject.SetVirtualInteger ( Value : Integer ); +begin + FInteger:=Value; +end; + +Procedure TMyTestObject.SetVirtualLongint ( Value : Longint ); +begin + FLongint:=Value; +end; + +Procedure TMyTestObject.SetVirtualCardinal ( Value : Cardinal ); +begin + FCardinal:=Value; +end; + +Procedure TMyTestObject.SetVirtualReal ( Value : Real ); +begin + FReal:=Value; +end; + +Procedure TMyTestObject.SetVirtualExtended ( Value : Extended ); +begin + FExtended:=Value; +end; + +Procedure TMyTestObject.SetVirtualAnsiString ( Value : AnsiString ); +begin + FAnsiString:=Value; +end; + +Procedure TMyTestObject.SetVirtualMyEnum ( Value : TMyEnum ); +begin + FMyEnum:=Value; +end; + +Function TMyTestObject.GetStaticStored : Boolean; + +begin + Result:=False; +end; + +Function TMyTestObject.GetVirtualStored : Boolean; + +begin + Result:=False; +end; + +Procedure DumpMem ( PL : PByte ); + +Var I,j : longint; + +begin + For I:=1 to 16 do + begin + Write ((I-1)*16:3,' :'); + For J:=1 to 10 do + begin + If (PL^>31) and (PL^<129) then + Write(' ',CHar(PL^)) + else + Write (PL^:3); + Write (' '); + inc(pl); + end; + writeln; + end; +end; + + +Function ProcType (PP : Byte) : String; + +begin + Case PP and 3 of + ptfield : Result:='from Field'; + ptstatic : Result:='with static method'; + ptVirtual : Result:='with virtual method'; + ptconst : Result:='with Const'; + end; +end; + +Procedure DumpTypeInfo (O : TMyTestObject); + +Var + PT : PTypeData; + PI : PTypeInfo; + I : Longint; + PP : PPropList; + +begin + PI:=O.ClassInfo; + Writeln ('Type kind : ',TypeNames[PI^.Kind]); + Writeln ('Type name : ',PI^.Name); + PT:=GetTypeData(PI); + //DumpMem(PByte(PI)); + If PT^.ParentInfo=Nil then + Writeln ('Object has no parent info') + else + Writeln ('Object has parent info'); + Writeln ('Property Count : ',PT^.PropCount); + Writeln ('Unit name : ',PT^.UnitName); + GetMem (PP,PT^.PropCount*SizeOf(Pointer)); + GetPropInfos(PI,PP); + For I:=0 to PT^.PropCount-1 do + If PP^[i]<>Nil then + With PP^[I]^ do + begin + Writeln ('Property name : ',Name); + Writeln (' Type kind: ',TypeNames[PropType^.Kind]); + Writeln (' Type Name: ',PropType^.Name); + If GetProc=Nil then Write ('No'); + Writeln (' Getproc available'); + If SetProc=Nil then Write ('No'); + Writeln (' Setproc available'); + If StoredProc=Nil then Write ('No'); + Writeln (' Storedproc available'); + Writeln (' Get property ',proctype(Propprocs)); + Writeln (' Set Property ',proctype(propprocs shr 2)); + Writeln (' Stored Property ',proctype(propprocs shr 4)); + Writeln (' Default : ',Default,' Index : ',Index); + Writeln (' NameIndex : ',NameIndex); + end; +end; + +Procedure PrintObject ( Obj: TMyTestObject); + +begin + With Obj do + begin + Writeln ('Field properties :'); + Writeln ('Property booleanField : ',booleanField); + Writeln ('Property ByteField : ',ByteField); + Writeln ('Property CharField : ',CharField); + Writeln ('Property WordField : ',WordField); + Writeln ('Property IntegerField : ',IntegerField); + Writeln ('Property LongintField : ',LongintField); + Writeln ('Property CardinalField : ',CardinalField); + Writeln ('Property RealField : ',RealField); + Writeln ('Property ExtendedField : ',ExtendedFIeld); + Writeln ('Property AnsiStringField : ',AnsiStringField); + Writeln ('Property MyEnumField : ',ord(MyEnumField)); + Writeln ('Method properties :'); + Writeln ('Property booleanMethod : ',BooleanMethod); + Writeln ('Property ByteMethod : ',ByteMethod); + Writeln ('Property CharMethod : ',CharMethod); + Writeln ('Property WordMethod : ',WordMethod); + Writeln ('Property IntegerMethod : ',IntegerMethod); + Writeln ('Property LongintMethod : ',LongintMethod); + Writeln ('Property CardinalMethod : ',CardinalMethod); + Writeln ('Property RealMethod : ',RealMethod); + Writeln ('Property ExtendedMethod : ',ExtendedMethod); + Writeln ('Property AnsiStringMethod : ',AnsiStringMethod); + Writeln ('Property MyEnumMethod : ',ord(MyEnumMethod)); + Writeln ('VirtualMethod properties :'); + Writeln ('Property booleanVirtualMethod : ',BooleanVirtualMethod); + Writeln ('Property ByteVirtualMethod : ',ByteVirtualMethod); + Writeln ('Property CharVirtualMethod : ',CharVirtualMethod); + Writeln ('Property WordVirtualMethod : ',WordVirtualMethod); + Writeln ('Property IntegerVirtualMethod : ',IntegerVirtualMethod); + Writeln ('Property LongintVirtualMethod : ',LongintVirtualMethod); + Writeln ('Property CardinalVirtualMethod : ',CardinalVirtualMethod); + Writeln ('Property RealVirtualMethod : ',RealVirtualMethod); + Writeln ('Property ExtendedVirtualMethod : ',ExtendedVirtualMethod); + Writeln ('Property AnsiStringVirtualMethod : ',AnsiStringVirtualMethod); + Writeln ('Property MyEnumVirtualMethod : ',ord(MyEnumVirtualMethod)); + end; +end; + +Procedure TestGet (O : TMyTestObject); + +Var + PT : PTypeData; + PI : PTypeInfo; + I,J : Longint; + PP : PPropList; + prI : PPropInfo; + +begin + PI:=O.ClassInfo; + Writeln ('Type kind : ',TypeNames[PI^.Kind]); + Writeln ('Type name : ',PI^.Name); + PT:=GetTypeData(PI); + If PT^.ParentInfo=Nil then + Writeln ('Object has no parent info') + else + Writeln ('Object has parent info'); + Writeln ('Property Count : ',PT^.PropCount); + Writeln ('Unit name : ',PT^.UnitName); + GetMem (PP,PT^.PropCount*SizeOf(Pointer)); + GetPropInfos(PI,PP); + For I:=0 to PT^.PropCount-1 do + begin + pri:=PP^[i]; + With Pri^ do + begin + Write ('(Examining ',name,' : Type : ',TypeNames[PropType^.Kind],', '); + If (Proptype^.kind in Ordinaltypes) Then + begin + J:=GetOrdProp(O,pri); + Write ('Value : ',j); + If PropType^.Kind=tkenumeration then + Write ('(=',GetEnumName(Proptype,J),')') + end + else + Case pri^.proptype^.kind of + tkfloat : begin + Write ('Value : '); + Flush(output); + Write(GetFloatProp(O,pri)) + end; + tkAstring : begin + Write ('value : '); + flush (output); + Write(GetStrProp(O,Pri)); + end; + else + Write ('Untested type:',ord(pri^.proptype^.kind)); + end; + Writeln (')'); + end; + end; +end; + +Var O : TMyTestObject; + +begin + O:=TMyTestObject.Create; + DumpTypeInfo(O); + PrintObject(O); + testget(o); +end. diff --git a/tests/test/trtti2.pp b/tests/test/trtti2.pp new file mode 100644 index 0000000000..f3a4366d7c --- /dev/null +++ b/tests/test/trtti2.pp @@ -0,0 +1,8 @@ +type + pbyte = ^byte; + +begin + if (pbyte(typeinfo(longint))^<>1 then + halt(1); +end. + diff --git a/tests/test/trtti3.pp b/tests/test/trtti3.pp new file mode 100644 index 0000000000..bf5c925d52 --- /dev/null +++ b/tests/test/trtti3.pp @@ -0,0 +1,21 @@ +{$mode delphi} +var + a,c1,c2 : ansistring; + aa : array[1..10] of ansistring; + i : longint; + +begin + c1:='Hello '; + c2:=' world'; + a:=c1+c2; + finalize(a); + if length(a)<>0 then + halt(1); + for i:=1 to 10 do + aa[i]:=c1+c2; + finalize(aa[1],10); + for i:=1 to 10 do + if length(aa[i])<>0 then + halt(1); +end. + diff --git a/tests/test/tset1.pp b/tests/test/tset1.pp new file mode 100644 index 0000000000..9bd3eededa --- /dev/null +++ b/tests/test/tset1.pp @@ -0,0 +1,175 @@ +{ + $Id$ + + Program to test set functions +} + +{$define FPC_HAS_SET_INEQUALITIES} + +program TestSet; + +Procedure InitMSTimer; +begin +end; + + +{Get MS Timer} +Function MSTimer:longint; +begin + MSTimer:=0; +end; + + +const + Lval=2000; +VAR Box1, Box2: ARRAY [0..255] OF BYTE; + OneWOTwo, TwoWOOne, + UnionSet, InterSet, + Set1, Set2, Set3: SET OF BYTE; + K, MaxNr, L, + N, Low, Hi: INTEGER; + Start: LONGINT; + +begin + WriteLn ('Set operators functional and speed test'); + WriteLn; + + RandSeed := 17; + + for L := 0 TO 255 DO begin + Box1 [L] := L; + end; + MaxNr := 255; + for L := 0 TO 255 DO begin + K := Random (MaxNr+1); + Box2 [L] := Box1 [K]; + Box1 [K] := Box1 [MaxNr]; + Dec (MaxNr); + end; + + Start :=MSTimer; + + Set1 := []; + Set2 := []; + for L := 0 TO 255 DO begin + Set1 := Set1 + [Box2 [L]]; + if NOT (Box2 [L] IN Set1) then begin + WriteLn ('error in AddElem or InSet functions'); + Halt; + end; + Set2 := Set2 + [Box2 [L]] + []; + end; + +{$ifdef FPC_HAS_SET_INEQUALITIES } + if (Set1 <> Set2) OR (NOT (Set1 <= Set2)) OR (NOT (Set1 >= Set2)) then begin +{$else FPC_HAS_SET_INEQUALITIES } + if (Set1 <> Set2) then begin +{$endif FPC_HAS_SET_INEQUALITIES } + WriteLn ('error in relational operators 1'); + Halt; + end; + + for L := 0 TO 255 DO begin + Set1 := Set1 - [Box2 [L]]; + if Box2 [L] IN Set1 then begin + WriteLn ('error in set difference 1'); + Halt; + end; + end; + + if Set1 <> [] then begin + WriteLn ('error in set difference 2'); + Halt; + end; + + for L := 1 TO LVal DO begin + REPEAT + Low := Random (256); + Hi := Random (256); + UNTIL Low <= Hi; + + Set1 := []; + Set1 := Set1 + [Low..Hi]; + for K := 0 TO 255 DO begin + if (K IN Set1) AND ((K < Low) OR (K > Hi)) then begin + WriteLn ('wrong set inclusion in add range'); + Halt; + end; + if (NOT (K IN Set1)) AND ((K >= Low) AND (K <= Hi)) then begin + WriteLn ('wrong set exclusion in add range'); + Halt; + end; + end; + end; + + for L := 1 TO LVal DO begin + Set1 := []; + Set2 := []; + + for K := 1 TO 10 DO begin + Low := Random (256); + Hi := Random (256); + Set2:= Set1 + [Low..Hi]; +{$ifdef FPC_HAS_SET_INEQUALITIES } + if (Set1 >= Set2) AND (Set1 <> Set2) then begin +{$else FPC_HAS_SET_INEQUALITIES } + if (Set1 <> Set2) then begin +{$endif FPC_HAS_SET_INEQUALITIES } + WriteLn ('error in relational operators 2'); + Halt; + end; +{$ifdef FPC_HAS_SET_INEQUALITIES } + if NOT (Set1 <= Set2) then begin + WriteLn ('error in relational operators 3'); + Halt; + end; +{$endif FPC_HAS_SET_INEQUALITIES } + Set1 := Set2; + + end; + end; + + for L := 1 TO LVal DO begin + Set1 := []; + for K := 1 TO 10 DO begin + Low := Random (256); + Hi := Random (256); + Set1:= Set1 + [Low..Hi]; + end; + Set2 := []; + for K := 1 TO 10 DO begin + Low := Random (256); + Hi := Random (256); + Set2:= Set2 + [Low..Hi]; + end; + + OneWOTwo := Set1 - Set2; + TwoWOOne := Set2 - Set1; + InterSet := Set1 * Set2; + UnionSet := Set1 + Set2; + + if InterSet <> (Set2 * Set1) then begin + WriteLn ('error in set difference'); + Halt; + end; + + if (InterSet + OneWOTwo) <> Set1 then begin + WriteLn ('error in set difference or intersection'); + Halt; + end; + + if (InterSet + TwoWOOne) <> Set2 then begin + WriteLn ('error in set difference or intersection'); + Halt; + end; + + if (OneWOTwo + TwoWOOne + InterSet) <> UnionSet then begin + WriteLn ('error in set union, intersection or difference'); + Halt; + end; + + end; + Start:=MSTimer-Start; + WriteLn('Set test completes in ',Start,' ms'); +end. + diff --git a/tests/test/tset2.pp b/tests/test/tset2.pp new file mode 100644 index 0000000000..eea1536355 --- /dev/null +++ b/tests/test/tset2.pp @@ -0,0 +1,351 @@ +(*********************************************************************) +(* Copyright (C) 1998, Carl Eric Codere *) +(*********************************************************************) +(* FPC (Free Pascal compiler) testsuite: SETS *) +(* Tests the following: in, +, -, *, assignments. *) +(* for small sets amd large sets, both with constants *) +(* and variables. *) +(*********************************************************************) + +type + myenum = (dA,dB,dC,dd,dedf,dg,dh,di,dj,dk,dl,dm,dn); + tasmop = (A_ABCD, + A_ADD,A_ADDA,A_ADDI,A_ADDQ,A_ADDX,A_AND,A_ANDI, + A_ASL,A_ASR,A_BCC,A_BCS,A_BEQ,A_BGE,A_BGT,A_BHI, + A_BLE,A_BLS,A_BLT,A_BMI,A_BNE,A_BPL,A_BVC,A_BVS, + A_BCHG,A_BCLR,A_BRA,A_BSET,A_BSR,A_BTST,A_CHK, + A_CLR,A_CMP,A_CMPA,A_CMPI,A_CMPM,A_DBCC,A_DBCS,A_DBEQ,A_DBGE, + A_DBGT,A_DBHI,A_DBLE,A_DBLS,A_DBLT,A_DBMI,A_DBNE,A_DBRA, + A_DBPL,A_DBT,A_DBVC,A_DBVS,A_DBF,A_DIVS,A_DIVU, + A_EOR,A_EORI,A_EXG,A_ILLEGAL,A_EXT,A_JMP,A_JSR, + A_LEA,A_LINK,A_LSL,A_LSR,A_MOVE,A_MOVEA,A_MOVEI,A_MOVEQ, + A_MOVEM,A_MOVEP,A_MULS,A_MULU,A_NBCD,A_NEG,A_NEGX, + A_NOP,A_NOT,A_OR,A_ORI,A_PEA,A_ROL,A_ROR,A_ROXL, + A_ROXR,A_RTR,A_RTS,A_SBCD,A_SCC,A_SCS,A_SEQ,A_SGE, + A_SGT,A_SHI,A_SLE,A_SLS,A_SLT,A_SMI,A_SNE, + A_SPL,A_ST,A_SVC,A_SVS,A_SF,A_SUB,A_SUBA,A_SUBI,A_SUBQ, + A_SUBX,A_SWAP,A_TAS,A_TRAP,A_TRAPV,A_TST,A_UNLK, + A_RTE,A_RESET,A_STOP, + { MC68010 instructions } + A_BKPT,A_MOVEC,A_MOVES,A_RTD, + { MC68020 instructions } + A_BFCHG,A_BFCLR,A_BFEXTS,A_BFEXTU,A_BFFFO, + A_BFINS,A_BFSET,A_BFTST,A_CALLM,A_CAS,A_CAS2, + A_CHK2,A_CMP2,A_DIVSL,A_DIVUL,A_EXTB,A_PACK,A_RTM, + A_TRAPCC,A_TRACS,A_TRAPEQ,A_TRAPF,A_TRAPGE,A_TRAPGT, + A_TRAPHI,A_TRAPLE,A_TRAPLS,A_TRAPLT,A_TRAPMI,A_TRAPNE, + A_TRAPPL,A_TRAPT,A_TRAPVC,A_TRAPVS,A_UNPK, + { FPU Processor instructions - directly supported only. } + { IEEE aware and misc. condition codes not supported } + A_FABS,A_FADD, + A_FBEQ,A_FBNE,A_FBNGT,A_FBGT,A_FBGE,A_FBNGE, + A_FBLT,A_FBNLT,A_FBLE,A_FBGL,A_FBNGL,A_FBGLE,A_FBNGLE, + A_FDBEQ,A_FDBNE,A_FDBGT,A_FDBNGT,A_FDBGE,A_FDBNGE, + A_FDBLT,A_FDBNLT,A_FDBLE,A_FDBGL,A_FDBNGL,A_FDBGLE,A_FBDNGLE, + A_FSEQ,A_FSNE,A_FSGT,A_FSNGT,A_FSGE,A_FSNGE, + A_FSLT,A_FSNLT,A_FSLE,A_FSGL,A_FSNGL,A_FSGLE,A_FSNGLE, + A_FCMP,A_FDIV,A_FMOVE,A_FMOVEM, + A_FMUL,A_FNEG,A_FNOP,A_FSQRT,A_FSUB,A_FSGLDIV, + A_FSFLMUL,A_FTST, + A_FTRAPEQ,A_FTRAPNE,A_FTRAPGT,A_FTRAPNGT,A_FTRAPGE,A_FTRAPNGE, + A_FTRAPLT,A_FTRAPNLT,A_FTRAPLE,A_FTRAPGL,A_FTRAPNGL,A_FTRAPGLE,A_FTRAPNGLE, + { Protected instructions } + A_CPRESTORE,A_CPSAVE, + { FPU Unit protected instructions } + { and 68030/68851 common MMU instructions } + { (this may include 68040 MMU instructions) } + A_FRESTORE,A_FSAVE,A_PFLUSH,A_PFLUSHA,A_PLOAD,A_PMOVE,A_PTEST, + { Useful for assembly langage output } + A_LABEL,A_NONE); + + +Function X(y:myenum): myenum; +Begin + x:=y; +end; + + +Procedure SecondInSets; +{ SET_IN_BYTE TESTS } +var + op : tasmop; + oplist: set of tasmop; +Begin + Write('TESTING SET_IN_BYTE:'); + oplist:=[]; + op:=A_JSR; + if op in oplist then + WriteLn(' FAILED.'); + op:=A_MOVE; + oplist:=oplist+[A_MOVE]; + if op in oplist then + WriteLn(' PASSED.'); +end; + +Procedure SetSetByte; +{ SET_SET_BYTE } +var + op : tasmop; + oplist: set of tasmop; +Begin + Write('TESTING SET_SET_BYTE(1):'); + op:=A_LABEL; + oplist:=[]; + oplist:=oplist+[op]; + if op in oplist then + Begin + WriteLn(' PASSED.'); + end + else + Begin + WriteLn(' FAILED.'); + end; +end; + + +Procedure SetAddSets; +{ SET_ADD_SETS } +var + op2list :set of tasmop; + oplist: set of tasmop; +Begin + op2list:=[]; + oplist:=[]; + oplist:=[A_MOVE]+[A_JSR]; + op2list:=[A_LABEL]; + oplist:=op2list+oplist; + if A_MOVE in oplist then + if A_LABEL in oplist then + if A_JSR in oplist then + WriteLn('TESTING SET_ADD_SETS: PASSED.') + else + WriteLn('TESTING SET_ADD_SETS: FAILED.') + else + WriteLn('TESTING SET_ADD_SETS: FAILED.') + else + WriteLn('TESTING SET_ADD_SETS: FAILED.') +end; + +Procedure SetSubsets; +{ SET_SUB_SETS } +var + op2list :set of tasmop; + oplist: set of tasmop; +Begin + op2list:=[]; + oplist:=[]; + oplist:=[A_MOVE]+[A_JSR]; + op2list:=[A_MOVE]+[A_JSR]; + oplist:=op2list-oplist; + if (A_MOVE in oplist) or (A_LABEL in oplist) or (A_JSR in oplist) then + WriteLn('TESTING SET_SUB_SETS: FAILED.') + else + WriteLn('TESTING SET_SUB_SETS: PASSED.') +end; + +Procedure SetCompSets; +{ SET_COMP_SETS } +var + op2list :set of tasmop; + oplist: set of tasmop; +Begin + op2list:=[]; + oplist:=[]; + oplist:=[A_MOVE]+[A_JSR]; + op2list:=[A_MOVE]+[A_JSR]; + if oplist=op2list then + WriteLn('TESTING SET_COMP_SETS(1): PASSED.') + else + WriteLn('TESTING SET_COMP_SETS(1): FAILED.'); + oplist:=[A_MOVE]; + if oplist=op2list then + WriteLn('TESTING SET_COMP_SETS(2): FAILED.') + else + WriteLn('TESTING SET_COMP_SETS(2): PASSED.'); +end; + +Procedure SetMulSets; +{ SET_COMP_SETS } +var + op2list :set of tasmop; + oplist: set of tasmop; +Begin + op2list:=[]; + oplist:=[]; + oplist:=[A_MOVE]+[A_JSR]; + op2list:=[A_MOVE]; + oplist:=oplist*op2list; + if A_JSR in oplist then + WriteLn('TESTING SET_MUL_SETS(1): FAILED.') + else + WriteLn('TESTING SET_MUL_SETS(1): PASSED.'); + if A_MOVE in oplist then + WriteLn('TESTING SET_MUL_SETS(2): PASSED.') + else + WriteLn('TESTING SET_MUL_SETS(2): FAILED.') +end; + +{------------------------------ TESTS FOR SMALL VALUES ---------------------} +Procedure SmallInSets; +{ SET_IN_BYTE TESTS } +var + op : myenum; + oplist: set of myenum; +Begin + Write('TESTING IN_BYTE:'); + oplist:=[]; + op:=Dn; + if op in oplist then + WriteLn(' FAILED.'); + op:=dm; + oplist:=oplist+[Dm]; + if op in oplist then + WriteLn(' PASSED.'); +end; + +Procedure SmallSetByte; +{ SET_SET_BYTE } +var + op : myenum; + oplist: set of myenum; +Begin + Write('TESTING SET_BYTE(1):'); + op:=DA; + oplist:=[]; + oplist:=oplist+[op]; + if op in oplist then + Begin + WriteLn(' PASSED.'); + end + else + Begin + WriteLn(' FAILED.'); + end; +end; + + +Procedure SmallAddSets; +{ SET_ADD_SETS } +var + op2list :set of myenum; + oplist: set of myenum; +Begin + op2list:=[]; + oplist:=[]; + oplist:=[DA]+[DC]; + op2list:=[DB]; + oplist:=op2list+oplist; + if DA in oplist then + if DC in oplist then + if DB in oplist then + WriteLn('TESTING SET_ADD_SETS: PASSED.') + else + WriteLn('TESTING ADD_SETS: FAILED.') + else + WriteLn('TESTING ADD_SETS: FAILED.') + else + WriteLn('TESTING ADD_SETS: FAILED.') +end; + +Procedure SmallSubsets; +{ SET_SUB_SETS } +var + op2list :set of myenum; + oplist: set of myenum; +Begin + op2list:=[]; + oplist:=[]; + oplist:=[DA]+[DC]; + op2list:=[DA]+[DC]; + oplist:=op2list-oplist; + if (DA in oplist) or (DB in oplist) or (DC in oplist) then + WriteLn('TESTING SUB_SETS: FAILED.') + else + WriteLn('TESTING SUB_SETS: PASSED.') +end; + +Procedure SmallCompSets; +{ SET_COMP_SETS } +var + op2list :set of myenum; + oplist: set of myenum; +Begin + op2list:=[]; + oplist:=[]; + oplist:=[DA]+[DC]; + op2list:=[DA]+[DC]; + if oplist=op2list then + WriteLn('TESTING COMP_SETS(1): PASSED.') + else + WriteLn('TESTING COMP_SETS(1): FAILED.'); + oplist:=[DA]; + if oplist=op2list then + WriteLn('TESTING COMP_SETS(2): FAILED.') + else + WriteLn('TESTING COMP_SETS(2): PASSED.'); +end; + +Procedure SmallMulSets; +{ SET_COMP_SETS } +var + op2list :set of myenum; + oplist: set of myenum; +Begin + op2list:=[]; + oplist:=[]; + oplist:=[DA]+[DC]; + op2list:=[DA]; + oplist:=oplist*op2list; + if DC in oplist then + WriteLn('TESTING MUL_SETS(1): FAILED.') + else + WriteLn('TESTING MUL_SETS(1): PASSED.'); + if DA in oplist then + WriteLn('TESTING MUL_SETS(2): PASSED.') + else + WriteLn('TESTING MUL_SETS(2): FAILED.') +end; + +const + b: myenum = (dA); +var + enum: set of myenum; + oplist: set of tasmop; + l : word; +Begin +{ small sets } + enum:=[]; + { add } + enum:=enum+[da]; + { subtract } + enum:=enum-[da]; + if DA in enum then + WriteLn('Found A_LABEL'); + { very large sets } + { copy loop test } + WRITELN('LARGE SETS:'); + oplist := [A_LABEL]; + { secondin test } + if A_LABEL in oplist then + WriteLn('TESTING SIMPLE SECOND_IN: PASSED.'); + { } + oplist:=[]; + if A_LABEL in oplist then + WriteLn('SECOND IN FAILED.'); + SecondinSets; + SetSetByte; + SetAddSets; + SetSubSets; + SetCompSets; + SetMulSets; + WRITELN('SMALL SETS:'); + SmallInSets; + SmallAddSets; + SmallSubSets; + SmallCompSets; + SmallMulSets; + l:=word(A_CPRESTORE); + if l = word(A_CPRESTORE) then + Begin + end; +end. diff --git a/tests/test/tstring1.pp b/tests/test/tstring1.pp new file mode 100644 index 0000000000..539b8b9d42 --- /dev/null +++ b/tests/test/tstring1.pp @@ -0,0 +1,266 @@ +program TestStr; +{$ifdef timer} +uses Timer; +{$else} +type + TTimer = Object + TotalMSec, + StartMSec : longint; + constructor init; + procedure reset; + procedure start; + procedure stop; + Function MSec:longint; + end; + +procedure TTimer.Reset; +begin +end; + +procedure TTimer.Start; +begin +end; + + +procedure TTimer.Stop; +begin +end; + + +Function TTimer.MSec:longint; +begin + MSec:=0; +end; + +Constructor TTimer.Init; +begin +end; + +{$endif} + +const + TestSize=10; {Use at least 10 for reasonable results} +type + BenType=array[1..8] of longint; +var + Total : longint; + headBen, + LoadBen, + ConcatBen, + DelBen, + InsBen, + CopyBen, + CmpBen, + MixBen : BenType; + t : TTimer; + +function TestOK:boolean; +Const + TestStr: string[22]='HELLO, THIS IS A TEST '; +var + I : INTEGER; + U : STRING[1]; + Q : STRING[100]; + S : STRING[55]; + T : STRING[60]; + V : STRING; +begin + TestOk:=false; + T:='THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG 1234567890'; + Insert (T, T, 1); +{Writeln(T);} + Delete (T, 55, 54); + S:=Copy (T, -5, 2); {'TH'} + U:=Copy (T, 7, 4); {'I'} + S:=S + U; {'THI'} + Q:=Copy (T, 32, 70); {'THE LAZY DOG 1234567890'} + Delete (Q, 2, 1); {'TE LAZY DOG 1234567890'} + Delete (Q, 100, 2); {'TE LAZY DOG 1234567890'} + Delete (Q, 3, -4); {'TE LAZY DOG 1234567890'} + Delete (Q, 3, 10); {'TE1234567890'} +{ writeln('TE1234567890 - ',Q);} + I:=Pos ('S', T); {25} + Insert(Copy(T,I,200),Q,3);{'TES OVER THE LAZY DOG 12345678901234567890'} + Delete (Q, 4, 6); {'TESTHE LAZY DOG 12345678901234567890} + S:=S + T [25]; {'THIS'} + S:=S + Copy (S, 3, -5) + Copy (S, 3, 2); {'THISIS'} + V:=T; {'THE QUICK BROWN FOX JUMPS OVER THE LAZY ..'} + Delete (V, -10, 47); {'AZY DOG 1234567890'} + if (Copy (V, -7, -1)='') and (Pos ('DOG', V)=5) then {TRUE} + Insert (V, S, 200); {'THISISAZY DOG 1234567890'} + U:=Copy (T, 44, 40); {' '} + Insert (U, S, 5); {'THIS ISAZY DOG 1234567890'} + I:=Pos ('ZY', S); {9} + Delete (S, I, -5); {'THIS ISAZY DOG 1234567890'} + Insert (Copy(S,5,1),S,8); {'THIS IS AZY DOG 1234567890'} + Delete (S, 10, 16); {'THIS IS A0'} + if S [Length (S)]='0' then {TRUE} + S:=S + Q; {'THIS IS A0TESTHE LAZY DOG 123456789012345...'} + V:=Copy (S, Length (S) - 19, 10); {'1234567890'} + if V=Copy (S, Length (S) - 9, 10) then {TRUE} + Delete (S, 15, 3 * Length (V)+2); {'THIS IS A0TEST'} + Insert ('', S, 0); {'THIS IS A0TEST'} + Insert(Copy(S,5,1),S,11); {'THIS IS A0 TEST'} + Insert ('HELLO', S, -4); {'HELLOTHIS IS A0 TEST'} + Insert (',', S, 6); {'HELLO,THIS IS A0 TEST'} + Delete (S, Pos ('TEST', S) - 2, 1); {'HELLO,THIS IS A TEST'} + Delete (Q, 0, 32767); {''} + Q:=Q + ' '; {' '} + Insert (Q, S, 7); {'HELLO, THIS IS A TEST'} + Insert (Q, S, 255); {'HELLO, THIS IS A TEST '} + if (S=TestStr) and (Q=' ') and (V='1234567890') and + (T='THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG 1234567890') then + TestOK:=true; +end; + + +procedure TestSpeed(Row,Len:byte); +var + l : longint; + hstr, + OrgStr : string; +begin + HeadBen[Row]:=Len; + OrgStr:=''; + while Length(OrgStr)'Hello') or + (a[j,j]<>'Hello') or + (a[k,k]<>'Hello') or + (a[l,l]<>'Hello') then + do_error(1000); + end; + +begin + writeln('Misc. shortstring tests'); + chararray2stringtest; + writeln('Misc. shortstring tests successfully passed'); + halt(0); +end. diff --git a/tests/test/tstring3.pp b/tests/test/tstring3.pp new file mode 100644 index 0000000000..e2798ed89d --- /dev/null +++ b/tests/test/tstring3.pp @@ -0,0 +1,43 @@ +program testcstr; + +{$mode objfpc} + +resourcestring + RsFDivFlawed = 'Res1'; + RsFDivOK = 'Res2'; + +const + c1 = 'A'; + c2 = 'B'; + s1 = 'String1'; + s2 = 'String2'; + + FDIVResStringS : array [0..1] of shortstring = (RsFDivFlawed, RsFDivOK); + FDIVResStringsA : array [0..1] of ansistring = (RsFDivFlawed, RsFDivOK); + FDivChars : array [0..1] of shortstring = (c1,c2); + FDivCharsA : array [0..1] of ansistring = (c1,c2); + FDIVStringS : array [0..1] of shortstring = (s1,s2); + FDIVStringsA : array [0..1] of ansistring = (s1,s2); + +var + error : integer; +begin + error:=0; + if Fdivresstrings[0]<>'Res1' then + inc(error); + if FdivresstringsA[1]<>'Res2' then + inc(error); + if FdivChars[0]<>'A' then + inc(error); + if FdivCharsA[1]<>'B' then + inc(error); + if Fdivstrings[0]<>'String1' then + inc(error); + if FdivstringsA[1]<>'String2' then + inc(error); + if error>0 then + begin + writeln(error,' errors with constant strings'); + halt(1); + end; +end. diff --git a/tests/test/tstring4.pp b/tests/test/tstring4.pp new file mode 100644 index 0000000000..36cfe59d44 --- /dev/null +++ b/tests/test/tstring4.pp @@ -0,0 +1,486 @@ +Program ansitest; + +{$ifndef fpc} +Function Memavail : Longint; +begin + Result:=0; +end; +{$endif} + +{ ------------------------------------------------------------------- + General stuff + ------------------------------------------------------------------- } + +Procedure DoMem (Var StartMem : Longint); + +begin + Writeln ('Lost ',StartMem-Memavail,' Bytes.'); + StartMem:=MemAvail; +end; + +Procedure DoRef (P : Pointer); + +Type PLongint = ^Longint; + +begin + If P=Nil then + Writeln ('(Ref : Empty string)') + else +{$ifdef fpc} + Writeln (' (Ref: ',Plongint(Longint(P)-4)^,',Len: ',PLongint(Longint(P)-8)^,')'); +{$else} + Writeln (' (Ref: ',Plongint(Longint(P)-8)^,',Len: ',PLongint(Longint(P)-4)^,')'); +{$endif} +end; + +{ ------------------------------------------------------------------- + Initialize/Finalize test + ------------------------------------------------------------------- } + + +Procedure TestInitFinal; + +Type ARec = record + FirstName, LastName : AnsiString; + end; + AnArray = Array [1..10] of AnsiString; + + +Var + S : AnsiString; + AR : Arec; + AAR : AnArray; + I : longint; + +Begin + S:='This is an ansistring!'; + If Pointer(AR.FirstNAme)<>Nil then + Writeln ('AR.FirstName not OK'); + If Pointer(AR.LastName)<>Nil then + Writeln ('AR.LastName not OK'); + for I:=1 to 10 do + If Pointer(AAR[I])<>Nil then + Writeln ('Array (',I,') NOT ok'); + AR.FirstName:='Napoleon'; + AR.LastName:='Bonaparte'; + For I:=1 to 10 do + AAR[I]:='Yet another AnsiString'; + Writeln ('S : ',S); + Writeln (AR.FirstName, ' ', AR.LastName); + For I:=1 to 10 do + Writeln (I:2,' : ',AAR[i]); +end; + +{ ------------------------------------------------------------------- + Parameter passing test + ------------------------------------------------------------------- } + + +Procedure TestVarParam (Var Sv : AnsiString); + +Var LS : AnsiString; + +begin + Write ('TestVarParam : Got S="',Sv,'"'); + DoRef(Pointer(Sv)); + Sv:='This is a var parameter ansistring'; + Write ('S Changed to : ',Sv); + DoRef (Pointer(Sv)); + Ls:=Sv; + Write ('Assigned to local var: "',ls,'"'); + DoRef (Pointer(Sv)); +end; + +Procedure TestValParam (S : AnsiString); + +Var LS : AnsiString; + +begin + Write ('TestValParam : Got S="',S,'"'); + S:='This is a value parameter ansistring'; + Write ('S Changed to : ',S); + DoRef(Pointer(S)); + Ls:=S; + Write ('Assigned to local var: "',ls,'"'); + DoRef(Pointer(S)); +end; + +Procedure TestConstParam (Const Sc : AnsiString); + +Var LS : AnsiString; + +begin + Write ('TestConstParam : Got S="',Sc,'"'); + DoRef(Pointer(Sc)); + Ls:=Sc; + Write ('Assigned to local var: "',ls,'"'); + DoRef(Pointer(Sc)); +end; + +Procedure TestParams; + +Var S : AnsiString; + Mem : Longint; + +begin + Mem:=MemAvail; + S :='This is another ansistring'; + Writeln ('Calling testvalparam with "',s,'"'); + testvalparam (s); + DoMem(Mem); + Writeln ('Calling testConstparam with "',s,'"'); + testconstparam (s); + DoMem(Mem); + Writeln ('Calling testvarparam with "',s,'"'); + testvarparam (s); + Writeln ('TestVarParam returned with "',S,'"'); + DoMem(Mem); +end; + +{ ------------------------------------------------------------------- + Comparision operators test + ------------------------------------------------------------------- } + +Procedure TestCompare; + +Const S1 : AnsiString = 'Teststring 1'; + S2 : AnsiString = 'Teststring 1'; + S3 : AnsiString = 'Teststring 2'; + S4 : AnsiString = ''; + PC : Pchar = 'Teststring 1'; + +Var S,T : AnsiString; + ss : Shortstring; + +begin + If S1=S2 then writeln ('S1 and S2 are the same'); + If S4='' then Writeln ('S4 is empty. OK'); + If Not(S4='Non-empty') then writeln ('S4 is not non-empty'); + if S3='Teststring 2' then writeln('S3 equals "Teststring 2". OK.'); + Write ('S3<>S2 : '); + If S2<>S3 Then writeln ('OK') else writeln ('NOT OK'); + Write ('S3>S2 : '); + If (S3>S2) Then Writeln ('OK') else writeln ('NOT OK'); + Write ('S1S3 do + begin + INc(i); + If I=10 then s3:='ABCDEF'; + end; + Writeln (' Done'); +end; + +Procedure TestStdFunc; + + +Var S,T : AnsiString; + SS : ShortString; + C : Char; + Ca : Cardinal; + L : longint; + I : Integer; + W : Word; + B : Byte; + R : Real; + D : Double; + E : Extended; + Si : Single; + Co : Comp; + TempMem:Longint; +begin + TempMem:=Memavail; + S:='ABCDEF'; + Write ('S = "',S,'"');Doref(Pointer(S)); + T:=Copy(S,1,3); + Write ('T : "',T,'"');DoRef(Pointer(T)); + T:=Copy(S,3,3); + Write ('T : "',T,'"');DoRef(Pointer(T)); + T:=Copy(S,3,6); + Write ('T : "',T,'"');DoRef(Pointer(T)); + Writeln ('Inserting "123" in S at pos 4'); + Insert ('123',S,4); + Write ('S = "',S,'"');DoRef(Pointer(S)); + Writeln ('Deleting 3 characters From S starting Pos 4'); + Delete (S,4,3); + Write ('S = "',S,'"');Doref(Pointer(S)); + Writeln ('Pos ''DE'' in S is : ',Pos('DE',S)); + Write ('S = "',S,'"');Doref(Pointer(S)); + Writeln ('Setting T to ''DE''.'); + T:='DE'; + //!! Here something weird is happening ? S is lost ??? + Writeln('***'); + Writeln ('Pos T in S is : ',Pos(T,S)); + Write ('S = "',S,'"');Doref(Pointer(S)); + Writeln ('Setting T to ''D''.'); + T:='D'; + Writeln ('Pos T in S is : ',Pos(T,S)); + Write ('S = "',S,'"');Doref(Pointer(S)); + Writeln ('Setting T to ''DA''.'); + T:='DA'; + Writeln ('Pos T in S is : ',Pos(T,S)); + Write ('S = "',S,'"');Doref(Pointer(S)); + Writeln ('SS:=''DE'''); + Writeln('***'); + SS:='DE'; + Writeln ('Pos SS in S is : ',Pos(SS,S)); + Write ('S = "',S,'"');Doref(Pointer(S)); + Writeln ('C:=''D'''); + C:='D'; + Writeln ('Pos C in S is : ',Pos(C,S)); + Write ('S = "',S,'"');Doref(Pointer(S)); + Writeln ('Pos ''D'' in S is : ',Pos('D',S)); + Write ('S = "',S,'"');Doref(Pointer(S)); + Write ('str(Ca,S)= '); + ca:=1; + str(Ca,S); + Writeln (S); + Write ('str(L,S)= '); + L:=2; + str(L,S); + Writeln (S); + Write ('str(I,S)= '); + I:=3; + str(I,S); + Writeln (S); + Write ('str(W,S)= '); + W:=4; + str(W,S); + Writeln (S); + Write ('str(R,S)= '); + R:=1.0; + str(R,S); + Writeln (S); + Write ('str(D,S)= '); + D:=2.0; + str(D,S); + Writeln (S); + Write ('str(E,S)= '); + E:=3.0; + str(E,S); + Writeln (S); + Write ('str(Co,S)= '); + Co:=4.0; + str(Co,S); + Writeln (S); + Write ('str(Si,S)= '); + Si:=5.0; + str(Si,S); + Writeln (S); +end; + +Var GlobalStartMem,StartMem : Longint; + +begin + GlobalStartMem:=MemAvail; + StartMem:=MemAvail; + Writeln ('Testing Initialize/Finalize.'); + TestInitFinal; + Write ('End of Initialize/finalize test : ');DoMem(StartMem); + + Writeln;Writeln ('Testing parameter passing.'); + TestParams; + Write ('End of Parameter passing test : ');DoMem(StartMem); + + Writeln;Writeln ('Testing comparision operators'); + TestCompare; + Write ('End of compare test : ');DoMem(StartMem); + + Writeln;Writeln ('Testing setlength of AnsiStrings'); + TestSetLength; + Write ('End of setlength test : ');DoMem(StartMem); + + Writeln;Writeln ('Testing Adding of AnsiStrings'); + TestAdd; + Write ('End of adding test : ');DoMem(StartMem); + + Writeln;Writeln ('Testing Adding of AnsiStrings in expressions'); + TestAddExpr; + Write ('End of adding in expressions test : ');DoMem(StartMem); + + Writeln;Writeln ('Testing type conversion.'); + TestConversion; + Write ('End of typeconversion test : ');DoMem(StartMem); + + Writeln;Writeln ('Testing indexed access.'); + TestIndex; + Write ('End of index access test : ');DoMem(StartMem); + + Writeln;Writeln ('Testing standard functions.'); + TestStdfunc; + Write ('End of standard functions: ');DoMem(StartMem); + Write ('For the whole program ');DoMem(GlobalStartMem); +end. diff --git a/tests/test/tstring5.pp b/tests/test/tstring5.pp new file mode 100644 index 0000000000..3423add3aa --- /dev/null +++ b/tests/test/tstring5.pp @@ -0,0 +1,40 @@ +uses + erroru; + +var + a1,a2 : ansistring; + +function f1 : ansistring; + + begin + f1:=''; + end; + +function f2 : ansistring; + + begin + f2:='Hello'; + end; + +begin + a1:=''; + a2:='Hello'; + if a1<>'' then + do_error(1000); + if a2='' then + do_error(1001); + if ''<>a1 then + do_error(1002); + if ''=a2 then + do_error(1003); + + if f1<>'' then + do_error(1004); + if f2='' then + do_error(1005); + if ''<>f1 then + do_error(1006); + if ''=f2 then + do_error(1007); +end. + diff --git a/tests/test/tstrreal1.pp b/tests/test/tstrreal1.pp new file mode 100644 index 0000000000..aba2879e26 --- /dev/null +++ b/tests/test/tstrreal1.pp @@ -0,0 +1,42 @@ +const + s: array[0..16] of string[13] = + ('99999.900000', + '99999.990000', + '99999.999000', + '99999.999900', + '99999.999990', + '99999.999999', + '100000.000000', + '100000.000000', + '100000.000000', + '100000.000000', + '100000.000000', + '100000.000000', + '100000.000000', + '100000.000000', + '100000.000000', + '100000.000000', + '100000.000000'); + +var + e,e2,e3: double; + s2: string; + c: longint; + +begin + e := 100000.0; + e2 := 0.1; + c := 0; + repeat + e3 := e-e2; + str(e3:0:6,s2); + writeln(s2); + if s2 <> s[c] then + begin + writeln(' Error, should be ',s[c]); + halt(1); + end; + e2 := e2 /10.0; + inc(c); + until e2 < 1e-17; +end. diff --git a/tests/test/tstrreal2.pp b/tests/test/tstrreal2.pp new file mode 100644 index 0000000000..13921c404f --- /dev/null +++ b/tests/test/tstrreal2.pp @@ -0,0 +1,43 @@ +const + s: array[1..21] of string = + ('10.00000000000000000', + '1.00000000000000000', + '0.10000000000000000', + '0.01000000000000000', + '0.00100000000000000', + '0.00010000000000000', + '0.00001000000000000', + '0.00000100000000000', + '0.00000010000000000', + '0.00000001000000000', + '0.00000000100000000', + '0.00000000010000000', + '0.00000000001000000', + '0.00000000000100000', + '0.00000000000010000', + '0.00000000000001000', + '0.00000000000000100', + '0.00000000000000010', + '0.00000000000000001', + '0.00000000000000000', + '0.00000000000000000'); + +var + e: extended; + c: longint; + s2: string; + +begin + e := 10.0; + for c := 1 to 21 do + begin + str(e:0:17,s2); + writeln(s2); + if s2 <> s[c] then + begin + writeln(' Error, should be ',s[c]); + halt(1); + end; + e := e / 10.0; + end; +end. diff --git a/tests/test/tunit1.pp b/tests/test/tunit1.pp new file mode 100644 index 0000000000..c4689355a5 --- /dev/null +++ b/tests/test/tunit1.pp @@ -0,0 +1,7 @@ +uses + erroru,tunit2; + +begin + if testvar<>1234567 then + do_error(1000); +end. diff --git a/tests/test/tunit2.pp b/tests/test/tunit2.pp new file mode 100644 index 0000000000..1347f0a7c0 --- /dev/null +++ b/tests/test/tunit2.pp @@ -0,0 +1,20 @@ +unit tunit2; + + interface + + var + testvar : longint; + + implementation + + uses + erroru; + +initialization + testvar:=1234567; +finalization + if testvar<>1234567 then + do_error(1001) + else + halt(0); +end. diff --git a/tests/test/tunit3.pp b/tests/test/tunit3.pp new file mode 100644 index 0000000000..692125d612 --- /dev/null +++ b/tests/test/tunit3.pp @@ -0,0 +1,11 @@ +unit tunit3; + + interface + + type + tr = record + end; + + implementation + +end. diff --git a/tests/test/tunit4.pp b/tests/test/tunit4.pp new file mode 100644 index 0000000000..27e05dfc9a --- /dev/null +++ b/tests/test/tunit4.pp @@ -0,0 +1,13 @@ +unit tunit4; + + interface + + uses + tunit3; + + type + tr = tunit3.tr; + + implementation + +end. diff --git a/tests/test/tunit5.pp b/tests/test/tunit5.pp new file mode 100644 index 0000000000..e04381fb74 --- /dev/null +++ b/tests/test/tunit5.pp @@ -0,0 +1,13 @@ +unit tunit5; + + interface + + uses + tunit4; + + type + pr = ^tr; + + implementation + +end. diff --git a/tests/testopt/README b/tests/testopt/README new file mode 100644 index 0000000000..0fa16c1b2a --- /dev/null +++ b/tests/testopt/README @@ -0,0 +1,12 @@ +This directory contains some tests which test the optimizer +Register variables: + Enumerations .......................... treg1.pp + Readln ................................ treg2.pp + Range checking ........................ treg3.pp +Common subexpression elimination (assembler) + Multidimensional array index operation. tcse1.pp + CSE and range checking ................ tcse2.pp + web bug 972............................ tcse3.pp +Peephole + CMOV optimize ......................... tcmov.pp + \ No newline at end of file diff --git a/tests/testopt/tcmov.pp b/tests/testopt/tcmov.pp new file mode 100644 index 0000000000..8c6d5cbf09 --- /dev/null +++ b/tests/testopt/tcmov.pp @@ -0,0 +1,29 @@ +var + l1,l2 : longint; + w1,w2 : word; + b1,b2 : byte; + b : boolean; + +begin + if b then + w1:=w2; + if b then + w1:=w2; + if b then + begin + w1:=w2; + l1:=l2; + end; + if b then + w1:=w2 + else + w2:=w1; + { + if b then + begin + w1:=w2; + l1:=l2; + b1:=b2; + end; + } +end. \ No newline at end of file diff --git a/tests/testopt/tcse1.pp b/tests/testopt/tcse1.pp new file mode 100644 index 0000000000..e8073e921d --- /dev/null +++ b/tests/testopt/tcse1.pp @@ -0,0 +1,27 @@ +{ %OPT=-OG2p3} + +procedure t; +var + a: array[1..10,1..10] of string[31]; + i, j: longint; + c: char; + +begin + i := 5; + j := 7; + a[i,j] := '123456789'; + c := '0'; +{ clear the optimizer state } + asm + end; + a[i,j] := a[i,j] + c; + if a[i,j] <> '1234567890' then + begin + writeln('error!'); + halt(1) + end; +end; + +begin + t; +end. diff --git a/tests/testopt/tcse2.pp b/tests/testopt/tcse2.pp new file mode 100644 index 0000000000..57ccb73cd8 --- /dev/null +++ b/tests/testopt/tcse2.pp @@ -0,0 +1,72 @@ +{ %OPT=-OG2} +{$r+} + +type + tsubr = 1..100000; + tarr = array[1..100000] of longint; + +function test(b: tsubr): longint; +begin + test := b; +end; + +var + p: ^longint; + l: longint; + a, a2: tarr; + +begin + getmem(p,4); + p^ := 100000; + l := 5; + { clear the optimizer state } + asm + end; +{$r-} + { get p^ in eax, the following statement generates the code } + { movl A,%eax } + { movl (%eax),%eax } + a[p^] := l; +{$r+} + { now, p^ gets rangechecked, this generates the code } + { movl A,%eax (1) } + { movl (%eax),%ecx (1) } + { ... } + { call rangecheck_procedure } + { pushl (%eax) } + { } + { With the bug in the optimizer, the instructions marked with (1) are } + { replaced by } + { movl %eax,%ecx } + { } + { and as such the "pushl (%eax)" pushes a wrong value afterwards } + l := test(p^); + if l <> 100000 then + begin + writeln('Problem 1!'); + halt(1); + end; + p^ := 5; + l := 5; + { clear the optimizer state } + asm + end; +{$r-} + { the following moves p^ in %edx } + a2[l] := a[p^]; +{$r+} + { same test as before, but now the original value comes from edx } + { instead of that it is already in eax (so check that it doesn't } + { replace the } + { movl P,%eax } + { movl (%eax),%ecx } + { with } + { movl %edx,%ecx } + l := test(p^); + if l <> 5 then + begin + writeln('Problem 2!'); + halt(1); + end; + freemem(p,4); +end. diff --git a/tests/testopt/tcse3.pp b/tests/testopt/tcse3.pp new file mode 100644 index 0000000000..878705e0ca --- /dev/null +++ b/tests/testopt/tcse3.pp @@ -0,0 +1,40 @@ +{ %OPT=-O2} +function forms(s: string; len: word): string; +begin + str(len,forms); + forms := s + ', ' + forms; +end; + +procedure wrt2(s: string); +begin + if s <> 'e 123, 4' then + begin + writeln('bug!'); + halt(1); + end; +end; + +type + pstring = ^string; + ta = array[0..254] of pstring; + tb = array[0..254] of byte; + +procedure t(var sel: ta; var selhigh: tb); +var + ml, i: byte; +begin + i := 5; + ml := 8; + new(sel[i]); + sel[i]^ := 'testje 123'; + selhigh[i] := 5; + wrt2(forms(copy(sel[i]^,selhigh[i]+1,255),ml-selhigh[i]+1)); +end; + +var + a: ta; + b: tb; + +begin + t(a,b); +end. \ No newline at end of file diff --git a/tests/testopt/treg1.pp b/tests/testopt/treg1.pp new file mode 100644 index 0000000000..e83dc45a50 --- /dev/null +++ b/tests/testopt/treg1.pp @@ -0,0 +1,26 @@ +{ %OPT=-Or} +{$minenumsize 1} + +type + tenum = (e1,e2,e3); + +procedure p1(e : tenum);forward; + +procedure p1; + + begin + e:=tenum(byte(e)*byte(e)); + case e of + e1 : ; + else + begin + writeln('error'); + halt(1); + end; + end; + end; + +begin + p1(e1); +end. + diff --git a/tests/testopt/treg2.dat b/tests/testopt/treg2.dat new file mode 100644 index 0000000000..b3b34eee96 --- /dev/null +++ b/tests/testopt/treg2.dat @@ -0,0 +1,7 @@ +1.0 +2.0 +3.0 +4.0 +5.0 +6.0 + diff --git a/tests/testopt/treg2.pp b/tests/testopt/treg2.pp new file mode 100644 index 0000000000..4e7ad77065 --- /dev/null +++ b/tests/testopt/treg2.pp @@ -0,0 +1,42 @@ +{ %OPT=-Or} +{$maxfpuregisters 3} +uses + dotest; + +var + t : text; + +procedure p; + + var + d : double; + e : extended; + s : single; + + begin + readln(t,d); + if d<>1 then + do_error(1000); + readln(t,d); + if d<>2 then + do_error(1001); + readln(t,e); + if e<>3 then + do_error(1002); + readln(t,e); + if e<>4 then + do_error(1003); + readln(t,s); + if s<>5 then + do_error(1004); + readln(t,s); + if s<>6 then + do_error(1005); + end; + +begin + assign(t,'testreg2.dat'); + reset(t); + p; + close(t); +end. diff --git a/tests/testopt/treg3.pp b/tests/testopt/treg3.pp new file mode 100644 index 0000000000..a8645a1726 --- /dev/null +++ b/tests/testopt/treg3.pp @@ -0,0 +1,33 @@ +{ %OPT=-Or} +program rangecse; + +{$r+} + +type + pa = ^ta; + ta = array[0..100] of longint; + +procedure t; +var + i, j: longint; + p: pa; +begin + new(p); + fillchar(p^,101*sizeof(longint),0); + p^[100] := 5; + j := 5; + for i:=1 to 101 do + if j=p^[i-1] then + begin + writeln('found!'); + dispose(p); + exit; + end; + writeln('failed..'); + dispose(p); + halt(1); +end; + +begin + t; +end. \ No newline at end of file diff --git a/tests/units/Makefile b/tests/units/Makefile new file mode 100644 index 0000000000..0d0324f35c --- /dev/null +++ b/tests/units/Makefile @@ -0,0 +1,1273 @@ +# +# Makefile generated by fpcmake v1.00 [2000/10/27] +# + +defaultrule: all + +##################################################################### +# Autodetect OS (Linux or Dos or Windows NT) +# define inUnix when running under Unix (Linux,FreeBSD) +# define inWinNT when running under WinNT +##################################################################### + +# We need only / in the path +override PATH:=$(subst \,/,$(PATH)) + +# Search for PWD and determine also if we are under linux +PWD:=$(strip $(wildcard $(addsuffix /pwd.exe,$(subst ;, ,$(PATH))))) +ifeq ($(PWD),) +PWD:=$(strip $(wildcard $(addsuffix /pwd,$(subst :, ,$(PATH))))) +ifeq ($(PWD),) +nopwd: + @echo You need the GNU utils package to use this Makefile! + @echo Get ftp://ftp.freepascal.org/pub/fpc/dist/go32v2/utilgo32.zip + @exit +else +inUnix=1 +endif +else +PWD:=$(firstword $(PWD)) +endif + +# Detect NT - NT sets OS to Windows_NT +# Detect OS/2 - OS/2 has OS2_SHELL defined +ifndef inUnix +ifeq ($(OS),Windows_NT) +inWinNT=1 +else +ifdef OS2_SHELL +inOS2=1 +endif +endif +endif + +# The extension of executables +ifdef inUnix +SRCEXEEXT= +else +SRCEXEEXT=.exe +endif + +# The path which is searched separated by spaces +ifdef inUnix +SEARCHPATH=$(subst :, ,$(PATH)) +else +SEARCHPATH=$(subst ;, ,$(PATH)) +endif + +# Base dir +ifdef PWD +BASEDIR:=$(shell $(PWD)) +else +BASEDIR=. +endif + +##################################################################### +# FPC version/target Detection +##################################################################### + +# What compiler to use ? +ifndef FPC +# Compatibility with old makefiles +ifdef PP +FPC=$(PP) +else +FPC=ppc386 +endif +endif +override FPC:=$(subst $(SRCEXEEXT),,$(FPC)) +override FPC:=$(subst \,/,$(FPC))$(SRCEXEEXT) + +# Target OS +ifndef OS_TARGET +OS_TARGET:=$(shell $(FPC) -iTO) +endif + +# Source OS +ifndef OS_SOURCE +OS_SOURCE:=$(shell $(FPC) -iSO) +endif + +# Target CPU +ifndef CPU_TARGET +CPU_TARGET:=$(shell $(FPC) -iTP) +endif + +# Source CPU +ifndef CPU_SOURCE +CPU_SOURCE:=$(shell $(FPC) -iSP) +endif + +# FPC version +ifndef FPC_VERSION +FPC_VERSION:=$(shell $(FPC) -iV) +endif + +export FPC OS_TARGET OS_SOURCE CPU_TARGET CPU_SOURCE FPC_VERSION + +##################################################################### +# FPCDIR Setting +##################################################################### + +# Test FPCDIR to look if the RTL dir exists +ifdef FPCDIR +override FPCDIR:=$(subst \,/,$(FPCDIR)) +ifeq ($(wildcard $(FPCDIR)/rtl),) +ifeq ($(wildcard $(FPCDIR)/units),) +override FPCDIR=wrong +endif +endif +else +override FPCDIR=wrong +endif + +# Detect FPCDIR +ifeq ($(FPCDIR),wrong) +ifdef inUnix +override FPCDIR=/usr/local/lib/fpc/$(FPC_VERSION) +ifeq ($(wildcard $(FPCDIR)/units),) +override FPCDIR=/usr/lib/fpc/$(FPC_VERSION) +endif +else +override FPCDIR:=$(subst /$(FPC),,$(firstword $(strip $(wildcard $(addsuffix /$(FPC),$(SEARCHPATH)))))) +override FPCDIR:=$(FPCDIR)/.. +ifeq ($(wildcard $(FPCDIR)/rtl),) +ifeq ($(wildcard $(FPCDIR)/units),) +override FPCDIR:=$(FPCDIR)/.. +ifeq ($(wildcard $(FPCDIR)/rtl),) +ifeq ($(wildcard $(FPCDIR)/units),) +override FPCDIR=c:/pp +endif +endif +endif +endif +endif +endif + +ifndef PACKAGESDIR +PACKAGESDIR=$(FPCDIR)/packages +endif +ifndef TOOLKITSDIR +TOOLKITSDIR= +endif +ifndef COMPONENTSDIR +COMPONENTSDIR= +endif + +# Create units dir +ifneq ($(FPCDIR),.) +UNITSDIR=$(FPCDIR)/units/$(OS_TARGET) +endif + +##################################################################### +# User Settings +##################################################################### + + +# Targets + +override UNITOBJECTS+=erroru + +# Clean + + +# Install + +ZIPTARGET=install + +# Defaults + + +# Directories + + +# Packages + +override PACKAGES+=rtl + +# Libraries + + +# Info + +INFOTARGET=fpc_infocfg fpc_infoobjects fpc_infoinstall + +##################################################################### +# Shell tools +##################################################################### + +# echo +ifndef ECHO +ECHO:=$(strip $(wildcard $(addsuffix /gecho$(EXEEXT),$(SEARCHPATH)))) +ifeq ($(ECHO),) +ECHO:=$(strip $(wildcard $(addsuffix /echo$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(ECHO),) +ECHO:=echo +ECHOE:=echo +else +ECHO:=$(firstword $(ECHO)) +ECHOE=$(ECHO) -E +endif +else +ECHO:=$(firstword $(ECHO)) +ECHOE=$(ECHO) -E +endif +endif + +# To copy pograms +ifndef COPY +COPY:=cp -fp +endif + +# Copy a whole tree +ifndef COPYTREE +COPYTREE:=cp -rfp +endif + +# To move pograms +ifndef MOVE +MOVE:=mv -f +endif + +# Check delete program +ifndef DEL +DEL:=rm -f +endif + +# Check deltree program +ifndef DELTREE +DELTREE:=rm -rf +endif + +# To install files +ifndef INSTALL +ifdef inUnix +INSTALL:=install -c -m 644 +else +INSTALL:=$(COPY) +endif +endif + +# To install programs +ifndef INSTALLEXE +ifdef inUnix +INSTALLEXE:=install -c -m 755 +else +INSTALLEXE:=$(COPY) +endif +endif + +# To make a directory. +ifndef MKDIR +ifdef inUnix +MKDIR:=install -m 755 -d +else +MKDIR:=ginstall -m 755 -d +endif +endif + +export ECHO ECHOE COPY COPYTREE MOVE DEL DELTREE INSTALL INSTALLEXE MKDIR + +##################################################################### +# Default Tools +##################################################################### + +# assembler, redefine it if cross compiling +ifndef AS +AS=as +endif + +# linker, but probably not used +ifndef LD +LD=ld +endif + +# ppas.bat / ppas.sh +ifdef inUnix +PPAS=ppas.sh +else +ifdef inOS2 +PPAS=ppas.cmd +else +PPAS=ppas.bat +endif +endif + +# ldconfig to rebuild .so cache +ifdef inUnix +LDCONFIG=ldconfig +else +LDCONFIG= +endif + +# ppumove +ifndef PPUMOVE +PPUMOVE:=$(strip $(wildcard $(addsuffix /ppumove$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(PPUMOVE),) +PPUMOVE= +else +PPUMOVE:=$(firstword $(PPUMOVE)) +endif +endif +export PPUMOVE + +# ppufiles +ifndef PPUFILES +PPUFILES:=$(strip $(wildcard $(addsuffix /ppufiles$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(PPUFILES),) +PPUFILES= +else +PPUFILES:=$(firstword $(PPUFILES)) +endif +endif +export PPUFILES + +# Look if UPX is found for go32v2 and win32. We can't use $UPX becuase +# upx uses that one itself (PFV) +ifndef UPXPROG +ifeq ($(OS_TARGET),go32v2) +UPXPROG:=1 +endif +ifeq ($(OS_TARGET),win32) +UPXPROG:=1 +endif +ifdef UPXPROG +UPXPROG:=$(strip $(wildcard $(addsuffix /upx$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(UPXPROG),) +UPXPROG= +else +UPXPROG:=$(firstword $(UPXPROG)) +endif +else +UPXPROG= +endif +endif +export UPXPROG + +# ZipProg, you can't use Zip as the var name (PFV) +ifndef ZIPPROG +ZIPPROG:=$(strip $(wildcard $(addsuffix /zip$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(ZIPPROG),) +ZIPPROG= +else +ZIPPROG:=$(firstword $(ZIPPROG)) +endif +endif +export ZIPPROG + +ZIPOPT=-9 +ZIPEXT=.zip + +# Tar +ifndef TARPROG +TARPROG:=$(strip $(wildcard $(addsuffix /tar$(SRCEXEEXT),$(SEARCHPATH)))) +ifeq ($(TARPROG),) +TARPROG= +else +TARPROG:=$(firstword $(TARPROG)) +endif +endif +export TARPROG + +ifeq ($(USETAR),bz2) +TAROPT=vI +TAREXT=.tar.bz2 +else +TAROPT=vz +TAREXT=.tar.gz +endif + +##################################################################### +# Default extensions +##################################################################### + +# Default needed extensions (Go32v2,Linux) +LOADEREXT=.as +EXEEXT=.exe +PPLEXT=.ppl +PPUEXT=.ppu +OEXT=.o +ASMEXT=.s +SMARTEXT=.sl +STATICLIBEXT=.a +SHAREDLIBEXT=.so +RSTEXT=.rst +FPCMADE=fpcmade + +# Go32v1 +ifeq ($(OS_TARGET),go32v1) +PPUEXT=.pp1 +OEXT=.o1 +ASMEXT=.s1 +SMARTEXT=.sl1 +STATICLIBEXT=.a1 +SHAREDLIBEXT=.so1 +FPCMADE=fpcmade.v1 +endif + +# Go32v2 +ifeq ($(OS_TARGET),go32v2) +FPCMADE=fpcmade.dos +endif + +# Linux +ifeq ($(OS_TARGET),linux) +EXEEXT= +HASSHAREDLIB=1 +FPCMADE=fpcmade.lnx +endif + +# Linux +ifeq ($(OS_TARGET),freebsd) +EXEEXT= +HASSHAREDLIB=1 +FPCMADE=fpcmade.freebsd +endif + +# Win32 +ifeq ($(OS_TARGET),win32) +PPUEXT=.ppw +OEXT=.ow +ASMEXT=.sw +SMARTEXT=.slw +STATICLIBEXT=.aw +SHAREDLIBEXT=.dll +FPCMADE=fpcmade.w32 +endif + +# OS/2 +ifeq ($(OS_TARGET),os2) +PPUEXT=.ppo +ASMEXT=.so2 +OEXT=.oo2 +SMARTEXT=.so +STATICLIBEXT=.ao2 +SHAREDLIBEXT=.dll +FPCMADE=fpcmade.os2 +endif + +# library prefix +LIBPREFIX=lib +ifeq ($(OS_TARGET),go32v2) +LIBPREFIX= +endif +ifeq ($(OS_TARGET),go32v1) +LIBPREFIX= +endif + +# determine which .pas extension is used +ifndef PASEXT +ifdef EXEOBJECTS +override TESTPAS:=$(strip $(wildcard $(addsuffix .pas,$(firstword $(EXEOBJECTS))))) +else +override TESTPAS:=$(strip $(wildcard $(addsuffix .pas,$(firstword $(UNITOBJECTS))))) +endif +ifeq ($(TESTPAS),) +PASEXT=.pp +else +PASEXT=.pas +endif +endif + + +# Check if the dirs really exists, else turn it off +ifeq ($(wildcard $(UNITSDIR)),) +UNITSDIR= +endif +ifeq ($(wildcard $(TOOLKITSDIR)),) +TOOLKITSDIR= +endif +ifeq ($(wildcard $(PACKAGESDIR)),) +PACKAGESDIR= +endif +ifeq ($(wildcard $(COMPONENTSDIR)),) +COMPONENTSDIR= +endif + + +# PACKAGESDIR packages + +PACKAGERTL=1 + +ifdef PACKAGERTL +ifneq ($(wildcard $(FPCDIR)/rtl),) +ifneq ($(wildcard $(FPCDIR)/rtl/$(OS_TARGET)),) +PACKAGEDIR_RTL=$(FPCDIR)/rtl/$(OS_TARGET) +else +PACKAGEDIR_RTL=$(FPCDIR)/rtl +endif +ifeq ($(wildcard $(PACKAGEDIR_RTL)/$(FPCMADE)),) +override COMPILEPACKAGES+=package_rtl +package_rtl: + $(MAKE) -C $(PACKAGEDIR_RTL) all +endif +UNITDIR_RTL=$(PACKAGEDIR_RTL) +else +PACKAGEDIR_RTL= +ifneq ($(wildcard $(UNITSDIR)/rtl),) +ifneq ($(wildcard $(UNITSDIR)/rtl/$(OS_TARGET)),) +UNITDIR_RTL=$(UNITSDIR)/rtl/$(OS_TARGET) +else +UNITDIR_RTL=$(UNITSDIR)/rtl +endif +else +UNITDIR_RTL= +endif +endif +ifdef UNITDIR_RTL +override NEEDUNITDIR+=$(UNITDIR_RTL) +endif +endif + + +##################################################################### +# Default Directories +##################################################################### + +# Linux and freebsd use unix dirs with /usr/bin, /usr/lib +# When zipping use the target as default, when normal install then +# use the source os as default +ifdef ZIPNAME +# Zipinstall +ifeq ($(OS_TARGET),linux) +UNIXINSTALLDIR=1 +endif +ifeq ($(OS_TARGET),freebsd) +UNIXINSTALLDIR=1 +endif +else +# Normal install +ifeq ($(OS_SOURCE),linux) +UNIXINSTALLDIR=1 +endif +ifeq ($(OS_SOURCE),freebsd) +UNIXINSTALLDIR=1 +endif +endif + +# set the prefix directory where to install everything +ifndef PREFIXINSTALLDIR +ifdef UNIXINSTALLDIR +PREFIXINSTALLDIR=/usr +else +PREFIXINSTALLDIR=/pp +endif +endif +export PREFIXINSTALLDIR + +# Where to place the resulting zip files +ifndef DESTZIPDIR +DESTZIPDIR:=$(BASEDIR) +endif +export DESTZIPDIR + +##################################################################### +# Install Directories +##################################################################### + +# set the base directory where to install everything +ifndef BASEINSTALLDIR +ifdef UNIXINSTALLDIR +BASEINSTALLDIR=$(PREFIXINSTALLDIR)/lib/fpc/$(FPC_VERSION) +else +BASEINSTALLDIR=$(PREFIXINSTALLDIR) +endif +endif + +# set the directory where to install the binaries +ifndef BININSTALLDIR +ifdef UNIXINSTALLDIR +BININSTALLDIR=$(PREFIXINSTALLDIR)/bin +else +BININSTALLDIR=$(BASEINSTALLDIR)/bin/$(OS_TARGET) +endif +endif + +# set the directory where to install the units. +ifndef UNITINSTALLDIR +UNITINSTALLDIR=$(BASEINSTALLDIR)/units/$(OS_TARGET) +ifdef UNITSUBDIR +UNITINSTALLDIR:=$(UNITINSTALLDIR)/$(UNITSUBDIR) +endif +endif + +# Where to install shared libraries +ifndef LIBINSTALLDIR +ifdef UNIXINSTALLDIR +LIBINSTALLDIR=$(PREFIXINSTALLDIR)/lib +else +LIBINSTALLDIR=$(UNITINSTALLDIR) +endif +endif + +# Where the source files will be stored +ifndef SOURCEINSTALLDIR +ifdef UNIXINSTALLDIR +SOURCEINSTALLDIR=$(PREFIXINSTALLDIR)/src/fpc-$(FPC_VERSION) +else +SOURCEINSTALLDIR=$(BASEINSTALLDIR)/source +endif +ifdef SOURCESUBDIR +SOURCEINSTALLDIR:=$(SOURCEINSTALLDIR)/$(SOURCESUBDIR) +endif +endif + +# Where the doc files will be stored +ifndef DOCINSTALLDIR +ifdef UNIXINSTALLDIR +DOCINSTALLDIR=$(PREFIXINSTALLDIR)/doc/fpc-$(FPC_VERSION) +else +DOCINSTALLDIR=$(BASEINSTALLDIR)/doc +endif +endif + +# Where to install the examples, under linux we use the doc dir +# because the copytree command will create a subdir itself +ifndef EXAMPLEINSTALLDIR +ifdef UNIXINSTALLDIR +EXAMPLEINSTALLDIR=$(DOCINSTALLDIR)/examples +else +EXAMPLEINSTALLDIR=$(BASEINSTALLDIR)/examples +endif +ifdef EXAMPLESUBDIR +EXAMPLEINSTALLDIR:=$(EXAMPLEINSTALLDIR)/$(EXAMPLESUBDIR) +endif +endif + +# Where the some extra (data)files will be stored +ifndef DATAINSTALLDIR +DATAINSTALLDIR=$(BASEINSTALLDIR) +endif + +##################################################################### +# Redirection +##################################################################### + +ifndef REDIRFILE +REDIRFILE=log +endif + +ifdef REDIR +ifndef inUnix +override FPC=redir -eo $(FPC) +endif +# set the verbosity to max +override FPCOPT+=-va +override REDIR:= >> $(REDIRFILE) +endif + + +##################################################################### +# Compiler Command Line +##################################################################### + +# Load commandline OPTDEF and add FPC_CPU define +override FPCOPTDEF:=-d$(CPU_TARGET) + +# Load commandline OPT and add target and unit dir to be sure +ifneq ($(OS_TARGET),$(OS_SOURCE)) +override FPCOPT+=-T$(OS_TARGET) +endif + +# User dirs should be first, so they are looked at first +ifdef UNITDIR +override FPCOPT+=$(addprefix -Fu,$(UNITDIR)) +endif +ifdef LIBDIR +override FPCOPT+=$(addprefix -Fl,$(LIBDIR)) +endif +ifdef OBJDIR +override FPCOPT+=$(addprefix -Fo,$(OBJDIR)) +endif +ifdef INCDIR +override FPCOPT+=$(addprefix -Fi,$(INCDIR)) +endif + +# Smartlinking +ifdef LINKSMART +override FPCOPT+=-XX +endif + +# Smartlinking creation +ifdef CREATESMART +override FPCOPT+=-CX +endif + +# Debug +ifdef DEBUG +override FPCOPT+=-gl -dDEBUG +endif + +# Release mode (strip, optimize and don't load ppc386.cfg) +# 0.99.12b has a bug in the optimizer so don't use it by default +ifdef RELEASE +ifeq ($(FPC_VERSION),0.99.12) +override FPCOPT+=-Xs -OGp3 -n +else +override FPCOPT+=-Xs -OG2p3 -n +endif +endif + +# Strip +ifdef STRIP +override FPCOPT+=-Xs +endif + +# Optimizer +ifdef OPTIMIZE +override FPCOPT+=-OG2p3 +endif + +# Verbose settings (warning,note,info) +ifdef VERBOSE +override FPCOPT+=-vwni +endif + +ifdef NEEDUNITDIR +override FPCOPT+=$(addprefix -Fu,$(NEEDUNITDIR)) +endif + +ifdef UNITSDIR +override FPCOPT+=-Fu$(UNITSDIR) +endif + +# Target dirs and the prefix to use for clean/install +ifdef TARGETDIR +override FPCOPT+=-FE$(TARGETDIR) +ifeq ($(TARGETDIR),.) +override TARGETDIRPREFIX= +else +override TARGETDIRPREFIX=$(TARGETDIR)/ +endif +endif +ifdef UNITTARGETDIR +override FPCOPT+=-FU$(UNITTARGETDIR) +ifeq ($(UNITTARGETDIR),.) +override UNITTARGETDIRPREFIX= +else +override UNITTARGETDIRPREFIX=$(TARGETDIR)/ +endif +else +ifdef TARGETDIR +override UNITTARGETDIR=$(TARGETDIR) +override UNITTARGETDIRPREFIX=$(TARGETDIRPREFIX) +endif +endif + +# Add commandline options last so they can override +ifdef OPT +override FPCOPT+=$(OPT) +endif + +# Add defines from FPCOPTDEF to FPCOPT +ifdef FPCOPTDEF +override FPCOPT+=$(FPCOPTDEF) +endif + +# Error file ? +ifdef ERRORFILE +override FPCOPT+=-Fr$(ERRORFILE) +endif + +# Was a config file specified ? +ifdef CFGFILE +override FPCOPT+=@$(CFGFILE) +endif + +# For win32 the options are passed using the environment FPCEXTCMD +ifeq ($(OS_SOURCE),win32) +override FPCEXTCMD:=$(FPCOPT) +override FPCOPT:=!FPCEXTCMD +export FPCEXTCMD +endif + +# Compiler commandline +override COMPILER:=$(FPC) $(FPCOPT) + +# also call ppas if with command option -s +# but only if the OS_SOURCE and OS_TARGE are equal +ifeq (,$(findstring -s ,$(COMPILER))) +EXECPPAS= +else +ifeq ($(OS_SOURCE),$(OS_TARGET)) +EXECPPAS:=@$(PPAS) +endif +endif + +##################################################################### +# Standard rules +##################################################################### + +all: fpc_all + +debug: fpc_debug + +smart: fpc_smart + +shared: fpc_shared + +showinstall: fpc_showinstall + +install: fpc_install + +sourceinstall: fpc_sourceinstall + +exampleinstall: fpc_exampleinstall + +zipinstall: fpc_zipinstall + +zipsourceinstall: fpc_zipsourceinstall + +zipexampleinstall: fpc_zipexampleinstall + +distclean: fpc_distclean + +cleanall: fpc_cleanall + +info: fpc_info + +.PHONY: all debug smart shared showinstall install sourceinstall exampleinstall zipinstall zipsourceinstall zipexampleinstall distclean cleanall info + +##################################################################### +# Units +##################################################################### + +.PHONY: fpc_units + +override ALLTARGET+=fpc_units + +override UNITPPUFILES=$(addsuffix $(PPUEXT),$(UNITOBJECTS)) +override INSTALLPPUFILES+=$(UNITPPUFILES) +override CLEANPPUFILES+=$(UNITPPUFILES) + +fpc_units: $(UNITPPUFILES) + +##################################################################### +# General compile rules +##################################################################### + +.PHONY: fpc_packages fpc_all fpc_debug + +$(FPCMADE): $(ALLTARGET) + @$(ECHO) Compiled > $(FPCMADE) + +fpc_packages: $(COMPILEPACKAGES) + +fpc_all: fpc_packages $(FPCMADE) + +fpc_debug: + $(MAKE) all DEBUG=1 + +# Search paths for .ppu if targetdir is set +ifdef UNITTARGETDIR +vpath %$(PPUEXT) $(UNITTARGETDIR) +endif + +# General compile rules, available for both possible PASEXT + +.SUFFIXES: $(EXEEXT) $(PPUEXT) $(OEXT) .pas .pp + +%$(PPUEXT): %.pp + $(COMPILER) $< $(REDIR) + $(EXECPPAS) + +%$(PPUEXT): %.pas + $(COMPILER) $< $(REDIR) + $(EXECPPAS) + +%$(EXEEXT): %.pp + $(COMPILER) $< $(REDIR) + $(EXECPPAS) + +%$(EXEEXT): %.pas + $(COMPILER) $< $(REDIR) + $(EXECPPAS) + +##################################################################### +# Library +##################################################################### + +.PHONY: fpc_smart fpc_shared + +ifdef LIBVERSION +LIBFULLNAME=$(LIBNAME).$(LIBVERSION) +else +LIBFULLNAME=$(LIBNAME) +endif + +# Default sharedlib units are all unit objects +ifndef SHAREDLIBUNITOBJECTS +SHAREDLIBUNITOBJECTS:=$(UNITOBJECTS) +endif + +fpc_smart: + $(MAKE) all LINKSMART=1 CREATESMART=1 + +fpc_shared: all +ifdef HASSHAREDLIB +ifndef LIBNAME + @$(ECHO) "LIBNAME not set" +else + $(PPUMOVE) $(SHAREDLIBUNITOBJECTS) -o$(LIBFULLNAME) +endif +else + @$(ECHO) "Shared Libraries not supported" +endif + +##################################################################### +# Install rules +##################################################################### + +.PHONY: fpc_showinstall fpc_install + +ifdef EXTRAINSTALLUNITS +override INSTALLPPUFILES+=$(addsuffix $(PPUEXT),$(EXTRAINSTALLUNITS)) +endif + +ifdef INSTALLPPUFILES +override INSTALLPPUFILES:=$(addprefix $(UNITTARGETDIRPREFIX),$(INSTALLPPUFILES)) +ifdef PPUFILES +INSTALLPPULINKFILES:=$(shell $(PPUFILES) -S -O $(INSTALLPPUFILES)) +else +INSTALLPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(INSTALLPPUFILES)) $(addprefix $(LIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(INSTALLPPUFILES)))) +endif +override INSTALLPPULINKFILES:=$(addprefix $(UNITTARGETDIRPREFIX),$(INSTALLPPULINKFILES)) +endif + +ifdef INSTALLEXEFILES +override INSTALLEXEFILES:=$(addprefix $(TARGETDIRPREFIX),$(INSTALLEXEFILES)) +endif + +fpc_showinstall: $(SHOWINSTALLTARGET) +ifdef INSTALLEXEFILES + @$(ECHO) -e $(addprefix "\n"$(BININSTALLDIR)/,$(INSTALLEXEFILES)) +endif +ifdef INSTALLPPUFILES + @$(ECHO) -e $(addprefix "\n"$(UNITINSTALLDIR)/,$(INSTALLPPUFILES)) +ifneq ($(INSTALLPPULINKFILES),) + @$(ECHO) -e $(addprefix "\n"$(UNITINSTALLDIR)/,$(INSTALLPPULINKFILES)) +endif +ifneq ($(wildcard $(LIBFULLNAME)),) + @$(ECHO) $(LIBINSTALLDIR)/$(LIBFULLNAME) +ifdef HASSHAREDLIB + @$(ECHO) $(LIBINSTALLDIR)/$(LIBNAME) +endif +endif +endif +ifdef EXTRAINSTALLFILES + @$(ECHO) -e $(addprefix "\n"$(DATAINSTALLDIR)/,$(EXTRAINSTALLFILES)) +endif + +fpc_install: $(INSTALLTARGET) +# Create UnitInstallFiles +ifdef INSTALLEXEFILES + $(MKDIR) $(BININSTALLDIR) +# Compress the exes if upx is defined +ifdef UPXPROG + -$(UPXPROG) $(INSTALLEXEFILES) +endif + $(INSTALLEXE) $(INSTALLEXEFILES) $(BININSTALLDIR) +endif +ifdef INSTALLPPUFILES + $(MKDIR) $(UNITINSTALLDIR) + $(INSTALL) $(INSTALLPPUFILES) $(UNITINSTALLDIR) +ifneq ($(INSTALLPPULINKFILES),) + $(INSTALL) $(INSTALLPPULINKFILES) $(UNITINSTALLDIR) +endif +ifneq ($(wildcard $(LIBFULLNAME)),) + $(MKDIR) $(LIBINSTALLDIR) + $(INSTALL) $(LIBFULLNAME) $(LIBINSTALLDIR) +ifdef inUnix + ln -sf $(LIBFULLNAME) $(LIBINSTALLDIR)/$(LIBNAME) +endif +endif +endif +ifdef EXTRAINSTALLFILES + $(MKDIR) $(DATAINSTALLDIR) + $(INSTALL) $(EXTRAINSTALLFILES) $(DATAINSTALLDIR) +endif + +##################################################################### +# SourceInstall rules +##################################################################### + +.PHONY: fpc_sourceinstall + +ifndef SOURCETOPDIR +SOURCETOPDIR=$(BASEDIR) +endif + +fpc_sourceinstall: clean + $(MKDIR) $(SOURCEINSTALLDIR) + $(COPYTREE) $(SOURCETOPDIR) $(SOURCEINSTALLDIR) + +##################################################################### +# exampleinstall rules +##################################################################### + +.PHONY: fpc_exampleinstall + +fpc_exampleinstall: $(addsuffix _clean,$(EXAMPLEDIROBJECTS)) +ifdef EXAMPLESOURCEFILES + $(MKDIR) $(EXAMPLEINSTALLDIR) + $(COPY) $(EXAMPLESOURCEFILES) $(EXAMPLEINSTALLDIR) +endif +ifdef EXAMPLEDIROBJECTS +ifndef EXAMPLESOURCEFILES + $(MKDIR) $(EXAMPLEINSTALLDIR) +endif + $(COPYTREE) $(addsuffix /*,$(EXAMPLEDIROBJECTS)) $(EXAMPLEINSTALLDIR) +endif + +##################################################################### +# Zip +##################################################################### + +.PHONY: fpc_zipinstall + +# Create suffix to add +ifndef PACKAGESUFFIX +PACKAGESUFFIX=$(OS_TARGET) +ifeq ($(OS_TARGET),go32v2) +PACKAGESUFFIX=go32 +endif +ifeq ($(OS_TARGET),win32) +PACKAGESUFFIX=w32 +endif +endif + +# Temporary path to pack a file +ifndef PACKDIR +ifndef inUnix +PACKDIR=$(BASEDIR)/pack_tmp +else +PACKDIR=/tmp/fpc-pack +endif +endif + +# Maybe create default zipname from packagename +ifndef ZIPNAME +ifdef PACKAGENAME +ZIPNAME=$(PACKAGEPREFIX)$(PACKAGENAME)$(PACKAGESUFFIX) +endif +endif + +# Use tar by default under linux +ifndef USEZIP +ifdef inUnix +USETAR=1 +endif +endif + +fpc_zipinstall: +ifndef ZIPNAME + @$(ECHO) "Please specify ZIPNAME!" + @exit 1 +else + $(MAKE) $(ZIPTARGET) PREFIXINSTALLDIR=$(PACKDIR) +ifdef USETAR + $(DEL) $(DESTZIPDIR)/$(ZIPNAME)$(TAREXT) + cd $(PACKDIR) ; $(TARPROG) cf$(TAROPT) $(DESTZIPDIR)/$(ZIPNAME)$(TAREXT) * ; cd $(BASEDIR) +else + $(DEL) $(DESTZIPDIR)/$(ZIPNAME)$(ZIPEXT) + cd $(PACKDIR) ; $(ZIPPROG) -Dr $(ZIPOPT) $(DESTZIPDIR)/$(ZIPNAME)$(ZIPEXT) * ; cd $(BASEDIR) +endif + $(DELTREE) $(PACKDIR) +endif + +.PHONY: fpc_zipsourceinstall + +fpc_zipsourceinstall: + $(MAKE) fpc_zipinstall ZIPTARGET=sourceinstall PACKAGESUFFIX=src + +.PHONY: fpc_zipexampleinstall + +fpc_zipexampleinstall: + $(MAKE) fpc_zipinstall ZIPTARGET=exampleinstall PACKAGESUFFIX=exm + +##################################################################### +# Clean rules +##################################################################### + +.PHONY: fpc_clean fpc_cleanall fpc_distclean + +ifdef EXEFILES +override CLEANEXEFILES:=$(addprefix $(TARGETDIRPREFIX),$(CLEANEXEFILES)) +endif + +ifdef EXTRACLEANUNITS +override CLEANPPUFILES+=$(addsuffix $(PPUEXT),$(EXTRACLEANUNITS)) +endif + +ifdef CLEANPPUFILES +override CLEANPPUFILES:=$(addprefix $(UNITTARGETDIRPREFIX),$(CLEANPPUFILES)) +# Get the .o and .a files created for the units +ifdef PPUFILES +CLEANPPULINKFILES:=$(shell $(PPUFILES) $(CLEANPPUFILES)) +else +CLEANPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(CLEANPPUFILES)) $(addprefix $(LIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(CLEANPPUFILES)))) +endif +override CLEANPPULINKFILES:=$(addprefix $(UNITTARGETDIRPREFIX),$(CLEANPPULINKFILES)) +endif + +fpc_clean: $(CLEANTARGET) +ifdef CLEANEXEFILES + -$(DEL) $(CLEANEXEFILES) +endif +ifdef CLEANPPUFILES + -$(DEL) $(CLEANPPUFILES) +endif +ifneq ($(CLEANPPULINKFILES),) + -$(DEL) $(CLEANPPULINKFILES) +endif +ifdef CLEANRSTFILES + -$(DEL) $(addprefix $(UNITTARGETDIRPREFIX),$(CLEANRSTFILES)) +endif +ifdef EXTRACLEANFILES + -$(DEL) $(EXTRACLEANFILES) +endif +ifdef LIBNAME + -$(DEL) $(LIBNAME) $(LIBFULLNAME) +endif + -$(DEL) $(FPCMADE) $(PPAS) link.res $(FPCEXTFILE) $(REDIRFILE) + +fpc_distclean: fpc_clean + +# Also run clean first if targetdir is set. Unittargetdir is always +# set if targetdir or unittargetdir is specified +ifdef UNITTARGETDIR +TARGETDIRCLEAN=fpc_clean +endif + +fpc_cleanall: $(CLEANTARGET) $(TARGETDIRCLEAN) +ifdef CLEANEXEFILES + -$(DEL) $(CLEANEXEFILES) +endif + -$(DEL) *$(OEXT) *$(PPUEXT) *$(RSTEXT) *$(ASMEXT) *$(STATICLIBEXT) *$(SHAREDLIBEXT) *$(PPLEXT) + -$(DELTREE) *$(SMARTEXT) + -$(DEL) $(FPCMADE) $(PPAS) link.res $(FPCEXTFILE) $(REDIRFILE) + +##################################################################### +# Info rules +##################################################################### + +.PHONY: fpc_info fpc_cfginfo fpc_objectinfo fpc_toolsinfo fpc_installinfo \ + fpc_dirinfo + +fpc_info: $(INFOTARGET) + +fpc_infocfg: + @$(ECHO) + @$(ECHO) == Configuration info == + @$(ECHO) + @$(ECHO) FPC....... $(FPC) + @$(ECHO) Version... $(FPC_VERSION) + @$(ECHO) CPU....... $(CPU_TARGET) + @$(ECHO) Source.... $(OS_SOURCE) + @$(ECHO) Target.... $(OS_TARGET) + @$(ECHO) + +fpc_infoobjects: + @$(ECHO) + @$(ECHO) == Object info == + @$(ECHO) + @$(ECHO) LoaderObjects..... $(LOADEROBJECTS) + @$(ECHO) UnitObjects....... $(UNITOBJECTS) + @$(ECHO) ExeObjects........ $(EXEOBJECTS) + @$(ECHO) + @$(ECHO) ExtraCleanUnits... $(EXTRACLEANUNITS) + @$(ECHO) ExtraCleanFiles... $(EXTRACLEANFILES) + @$(ECHO) + @$(ECHO) ExtraInstallUnits. $(EXTRAINSTALLUNITS) + @$(ECHO) ExtraInstallFiles. $(EXTRAINSTALLFILES) + @$(ECHO) + +fpc_infoinstall: + @$(ECHO) + @$(ECHO) == Install info == + @$(ECHO) +ifdef DATE + @$(ECHO) DateStr.............. $(DATESTR) +endif +ifdef PACKAGEPREFIX + @$(ECHO) PackagePrefix........ $(PACKAGEPREFIX) +endif +ifdef PACKAGENAME + @$(ECHO) PackageName.......... $(PACKAGENAME) +endif + @$(ECHO) PackageSuffix........ $(PACKAGESUFFIX) + @$(ECHO) + @$(ECHO) BaseInstallDir....... $(BASEINSTALLDIR) + @$(ECHO) BinInstallDir........ $(BININSTALLDIR) + @$(ECHO) LibInstallDir........ $(LIBINSTALLDIR) + @$(ECHO) UnitInstallDir....... $(UNITINSTALLDIR) + @$(ECHO) SourceInstallDir..... $(SOURCEINSTALLDIR) + @$(ECHO) DocInstallDir........ $(DOCINSTALLDIR) + @$(ECHO) DataInstallDir....... $(DATAINSTALLDIR) + @$(ECHO) + @$(ECHO) DestZipDir........... $(DESTZIPDIR) + @$(ECHO) ZipName.............. $(ZIPNAME) + @$(ECHO) + +##################################################################### +# Local Makefile +##################################################################### + +ifneq ($(wildcard fpcmake.loc),) +include fpcmake.loc +endif + +##################################################################### +# Users rules +##################################################################### + +.PHONY: go32v2_units linux_units os2_units win32_units clean + +erroru$(PPUEXT): erroru.pp $(OS_TARGET)_units + + +go32v2_units : + $(MAKE) clean OS_TARGET=go32v2 + $(MAKE) -C ../../rtl/go32v2 clean all OS_TARGET=go32v2 + -$(COPY) ../../rtl/go32v2/*.o . + -$(COPY) ../../rtl/go32v2/*.a . + -$(COPY) ../../rtl/go32v2/*.ppu . + $(MAKE) -C ../../fcl/go32v2 clean all OS_TARGET=go32v2 + -$(COPY) ../../fcl/go32v2/*.o . + -$(COPY) ../../fcl/go32v2/*.a . + -$(COPY) ../../fcl/go32v2/*.ppu . + +linux_units : + $(MAKE) clean OS_TARGET=linux + $(MAKE) -C ../../rtl/linux clean all OS_TARGET=linux + -$(COPY) ../../rtl/linux/*.o . + -$(COPY) ../../rtl/linux/*.a . + -$(COPY) ../../rtl/linux/*.ppu . + $(MAKE) -C ../../fcl/linux clean all OS_TARGET=linux + -$(COPY) ../../fcl/linux/*.o . + -$(COPY) ../../fcl/linux/*.a . + -$(COPY) ../../fcl/linux/*.ppu . + +os2_units : + $(MAKE) clean OS_TARGET=os2 + $(MAKE) -C ../../rtl/os2 clean all OS_TARGET=os2 + -$(COPY) ../../rtl/os2/*.oo2 . + -$(COPY) ../../rtl/os2/*.ao2 . + -$(COPY) ../../rtl/os2/*.ppo . + $(MAKE) -C ../../fcl/os2 clean all OS_TARGET=os2 + -$(COPY) ../../fcl/os2/*.oo2 . + -$(COPY) ../../fcl/os2/*.ao2 . + -$(COPY) ../../fcl/os2/*.ppo . + +win32_units : + $(MAKE) clean OS_TARGET=win32 + $(MAKE) -C ../../rtl/win32 clean all OS_TARGET=win32 + -$(COPY) ../../rtl/win32/*.ow . + -$(COPY) ../../rtl/win32/*.aw . + -$(COPY) ../../rtl/win32/*.ppw . + $(MAKE) -C ../../fcl/win32 clean all OS_TARGET=win32 + -$(COPY) ../../fcl/win32/*.ow . + -$(COPY) ../../fcl/win32/*.aw . + -$(COPY) ../../fcl/win32/*.ppw . + +clean : cleanall diff --git a/tests/units/Makefile.fpc b/tests/units/Makefile.fpc new file mode 100644 index 0000000000..38b072095b --- /dev/null +++ b/tests/units/Makefile.fpc @@ -0,0 +1,60 @@ +# +# Makefile.fpc to create and group units needed for +# tests for all targets +# + +[targets] +units=erroru + + +[rules] +.PHONY: go32v2_units linux_units os2_units win32_units clean + +erroru$(PPUEXT): erroru.pp $(OS_TARGET)_units + + +go32v2_units : + $(MAKE) clean OS_TARGET=go32v2 + $(MAKE) -C ../../rtl/go32v2 clean all OS_TARGET=go32v2 + -$(COPY) ../../rtl/go32v2/*.o . + -$(COPY) ../../rtl/go32v2/*.a . + -$(COPY) ../../rtl/go32v2/*.ppu . + $(MAKE) -C ../../fcl/go32v2 clean all OS_TARGET=go32v2 + -$(COPY) ../../fcl/go32v2/*.o . + -$(COPY) ../../fcl/go32v2/*.a . + -$(COPY) ../../fcl/go32v2/*.ppu . + +linux_units : + $(MAKE) clean OS_TARGET=linux + $(MAKE) -C ../../rtl/linux clean all OS_TARGET=linux + -$(COPY) ../../rtl/linux/*.o . + -$(COPY) ../../rtl/linux/*.a . + -$(COPY) ../../rtl/linux/*.ppu . + $(MAKE) -C ../../fcl/linux clean all OS_TARGET=linux + -$(COPY) ../../fcl/linux/*.o . + -$(COPY) ../../fcl/linux/*.a . + -$(COPY) ../../fcl/linux/*.ppu . + +os2_units : + $(MAKE) clean OS_TARGET=os2 + $(MAKE) -C ../../rtl/os2 clean all OS_TARGET=os2 + -$(COPY) ../../rtl/os2/*.oo2 . + -$(COPY) ../../rtl/os2/*.ao2 . + -$(COPY) ../../rtl/os2/*.ppo . + $(MAKE) -C ../../fcl/os2 clean all OS_TARGET=os2 + -$(COPY) ../../fcl/os2/*.oo2 . + -$(COPY) ../../fcl/os2/*.ao2 . + -$(COPY) ../../fcl/os2/*.ppo . + +win32_units : + $(MAKE) clean OS_TARGET=win32 + $(MAKE) -C ../../rtl/win32 clean all OS_TARGET=win32 + -$(COPY) ../../rtl/win32/*.ow . + -$(COPY) ../../rtl/win32/*.aw . + -$(COPY) ../../rtl/win32/*.ppw . + $(MAKE) -C ../../fcl/win32 clean all OS_TARGET=win32 + -$(COPY) ../../fcl/win32/*.ow . + -$(COPY) ../../fcl/win32/*.aw . + -$(COPY) ../../fcl/win32/*.ppw . + +clean : cleanall diff --git a/tests/units/erroru.pp b/tests/units/erroru.pp new file mode 100644 index 0000000000..a67ded0ef4 --- /dev/null +++ b/tests/units/erroru.pp @@ -0,0 +1,85 @@ +unit erroru; +interface + + procedure do_error(l : longint); + + procedure error; + + procedure accept_error(num : longint); + + procedure require_error(num : longint); + + +implementation + +const + program_has_error : boolean = false; + accepted_error_num : longint = 0; + required_error_num : longint = 0; + +procedure do_error(l : longint); +begin + writeln('Error near: ',l); + halt(100); +end; + + +procedure error; +begin + Writeln('Error in ',paramstr(0)); + program_has_error:=true; +end; + + +procedure accept_error(num : longint); +begin + accepted_error_num:=num; +end; + + +procedure require_error(num : longint); +begin + required_error_num:=num; + accepted_error_num:=num; +end; + + +procedure error_unit_exit; +begin + if exitcode<>0 then + begin + if (required_error_num<>0) and (exitcode<>required_error_num) then + begin + Write('Program ',paramstr(0)); + Write(' exited with error ',exitcode,' whereas error '); + Writeln(required_error_num,' was expected'); + Halt(1); + end + else if exitcode<>accepted_error_num then + begin + Write('Program ',paramstr(0)); + Write(' exited with error ',exitcode,' whereas only error '); + Writeln(accepted_error_num,' was expected'); + Halt(1); + end; + end + else if required_error_num<>0 then + begin + Write('Program ',paramstr(0)); + Write(' exited without error whereas error '); + Writeln(required_error_num,' was expected'); + Halt(1); + end; + if program_has_error then + Halt(1) + else + begin + exitcode:=0; + erroraddr:=nil; + end; +end; + + +finalization + error_unit_exit; +end. diff --git a/tests/utils/dotest.pp b/tests/utils/dotest.pp new file mode 100644 index 0000000000..dc5582aa3a --- /dev/null +++ b/tests/utils/dotest.pp @@ -0,0 +1,521 @@ +program dotest; +uses + dos, + redir; + +const +{$ifdef UNIX} + ExeExt=''; +{$else UNIX} + ExeExt:='exe'; +{$endif UNIX} + +type + TVerboseLevel=(V_Abort,V_Error,V_Warning,V_Normal,V_Debug); + + TConfig = record + NeedOptions, + NeedCPU, + NeedVersion : string; + ResultCode : longint; + IsInteractive : boolean; + UsesGraph : boolean; + Category : string; + end; + +var + Config : TConfig; + CompilerBin : string; + CompilerCPU : string; + CompilerVersion : string; + PPFile : string; + TestName : string; + +const + ResLogfile : string[32] = 'log'; + LongLogfile : string[32] = 'longlog'; + FailLogfile : string[32] = 'faillist'; + DoVerbose : boolean = false; + DoGraph : boolean = false; + DoInteractive : boolean = false; + +procedure Verbose(lvl:TVerboseLevel;const s:string); +begin + case lvl of + V_Normal : + writeln(s); + V_Debug : + if DoVerbose then + writeln('Debug: ',s); + V_Warning : + writeln('Warning: ',s); + V_Error : + begin + writeln('Error: ',s); + halt(1); + end; + V_Abort : + begin + writeln('Abort: ',s); + halt(0); + end; + end; +end; + + +Function FileExists (Const F : String) : Boolean; +{ + Returns True if the file exists, False if not. +} +Var + info : searchrec; +begin + FindFirst (F,anyfile,Info); + FileExists:=DosError=0; + FindClose (Info); +end; + + +function ToStr(l:longint):string; +var + s : string; +begin + Str(l,s); + ToStr:=s; +end; + + +procedure TrimB(var s:string); +begin + while (s<>'') and (s[1] in [' ',#9]) do + delete(s,1,1); +end; + + +procedure TrimE(var s:string); +begin + while (s<>'') and (s[length(s)] in [' ',#9]) do + delete(s,length(s),1); +end; + + +function upper(const s : string) : string; +var + i : longint; +begin + for i:=1 to length(s) do + if s[i] in ['a'..'z'] then + upper[i]:=char(byte(s[i])-32) + else + upper[i]:=s[i]; + upper[0]:=s[0]; +end; + + +function SplitPath(const s:string):string; +var + i : longint; +begin + i:=Length(s); + while (i>0) and not(s[i] in ['/','\']) do + dec(i); + SplitPath:=Copy(s,1,i); +end; + + +function ForceExtension(Const HStr,ext:String):String; +{ + Return a filename which certainly has the extension ext +} +var + j : longint; +begin + j:=length(Hstr); + while (j>0) and (Hstr[j]<>'.') do + dec(j); + if j=0 then + j:=255; + if Ext<>'' then + ForceExtension:=Copy(Hstr,1,j-1)+'.'+Ext + else + ForceExtension:=Copy(Hstr,1,j-1); +end; + + +procedure Copyfile(const fn1,fn2:string;append:boolean); +const + bufsize = 16384; +var + f,g : file; + i : longint; + buf : pointer; +begin + if Append then + 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+} + if ioresult<>0 then + Verbose(V_Error,'Can''t open '+fn1); + if append then + begin + {$I-} + reset(g,1); + {$I+} + if ioresult<>0 then + append:=false + else + seek(g,filesize(g)); + end; + if not append then + begin + {$I-} + rewrite(g,1); + {$I+} + if ioresult<>0 then + Verbose(V_Error,'Can''t open '+fn2+' for output'); + end; + getmem(buf,bufsize); + repeat + blockread(f,buf^,bufsize,i); + blockwrite(g,buf^,i); + until i0 then + begin + {$I-} + rewrite(t); + {$I+} + if ioresult<>0 then + Verbose(V_Abort,'Can''t append to '+logfile); + end; + writeln(t,s); + close(t); +end; + + +function GetConfig(const fn:string;var r:TConfig):boolean; +var + t : text; + code : integer; + s,res : string; + + function GetEntry(const entry:string):boolean; + var + i : longint; + begin + Getentry:=false; + Res:=''; + if Upper(Copy(s,1,length(entry)))=Upper(entry) then + begin + Delete(s,1,length(entry)); + TrimB(s); + if (s<>'') then + begin + if (s[1]='=') then + begin + delete(s,1,1); + i:=pos('}',s); + if i=0 then + i:=255 + else + dec(i); + res:=Copy(s,1,i); + TrimB(res); + TrimE(res); + end; + Verbose(V_Debug,'Config: '+Entry+' = "'+Res+'"'); + GetEntry:=true; + end; + end; + end; + +begin + GetConfig:=false; + Verbose(V_Debug,'Reading '+fn); + assign(t,fn); + {$I-} + reset(t); + {$I+} + if ioresult<>0 then + begin + Verbose(V_Error,'Can''t open '+fn); + exit; + end; + while not eof(t) do + begin + readln(t,s); + if s<>'' then + begin + if s[1]='{' then + begin + delete(s,1,1); + TrimB(s); + if (s<>'') and (s[1]='%') then + begin + delete(s,1,1); + if GetEntry('OPT') then + r.NeedOptions:=res + else + if GetEntry('CPU') then + r.NeedCPU:=res + else + if GetEntry('VERSION') then + r.NeedVersion:=res + else + if GetEntry('RESULT') then + Val(res,r.ResultCode,code) + else + if GetEntry('GRAPH') then + r.UsesGraph:=true + else + if GetEntry('INTERACTIVE') then + r.IsInteractive:=true + else + Verbose(V_Error,'Unknown entry: '+s); + end; + end + else + break; + end; + end; + close(t); + GetConfig:=true; +end; + + +function GetCompilerVersion:boolean; +var + t : text; +begin + GetCompilerVersion:=false; + ExecuteRedir(CompilerBin,'-iV','','out',''); + assign(t,'out'); + {$I-} + reset(t); + readln(t,CompilerVersion); + close(t); + erase(t); + {$I+} + if ioresult<>0 then + Verbose(V_Error,'Can''t get Compiler Version') + else + begin + Verbose(V_Debug,'Current Compiler Version: '+CompilerVersion); + GetCompilerVersion:=true; + end; +end; + + +function GetCompilerCPU:boolean; +var + t : text; +begin + GetCompilerCPU:=false; + ExecuteRedir(CompilerBin,'-iTP','','out',''); + assign(t,'out'); + {$I-} + reset(t); + readln(t,CompilerCPU); + close(t); + erase(t); + {$I+} + if ioresult<>0 then + Verbose(V_Error,'Can''t get Compiler CPU Target') + else + begin + Verbose(V_Debug,'Current Compiler CPU Target: '+CompilerCPU); + GetCompilerCPU:=true; + end; +end; + + +function RunCompiler:boolean; +var + outname, + args : string; +begin + RunCompiler:=false; + OutName:=ForceExtension(PPFile,'log'); + args:='-Fuunits'; + if Config.NeedOptions<>'' then + args:=args+' '+Config.NeedOptions; + args:=args+' '+ppfile; + Verbose(V_Debug,'Executing '+compilerbin+' '+args); + ExecuteRedir(CompilerBin,args,'',OutName,''); + if ExecuteResult<>0 then + begin + AddLog(FailLogFile,TestName); + AddLog(ResLogFile,'Failed to compile '+PPFile); + AddLog(LongLogFile,'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>'); + CopyFile(OutName,LongLogFile,true); + Verbose(V_Abort,'Exitcode: '+ToStr(ExecuteResult)+' (expected 0)'); + end + else + begin + AddLog(ResLogFile,'Successfully compiled '+PPFile); + RunCompiler:=true; + end; +end; + + +function RunExecutable:boolean; +var + outname, + TestExe : string; +begin + RunExecutable:=false; + TestExe:=ForceExtension(PPFile,ExeExt); + OutName:=ForceExtension(PPFile,'elg'); + Verbose(V_Debug,'Executing '+TestExe); + ExecuteRedir(TestExe,'','',OutName,''); + if ExecuteResult<>Config.ResultCode then + begin + AddLog(FailLogFile,TestName); + AddLog(ResLogFile,'Failed to run '+PPFile); + AddLog(LongLogFile,'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>'); + AddLog(LongLogFile,'Failed to run '+PPFile+' ('+ToStr(ExecuteResult)+')'); + Copyfile(OutName,LongLogFile,true); + Verbose(V_Abort,'Exitcode: '+ToStr(ExecuteResult)+' (expected '+ToStr(Config.ResultCode)+')'); + end + else + begin + AddLog(ResLogFile,'Successfully run '+PPFile); + RunExecutable:=true; + end; +end; + + +procedure getargs; +var + ch : char; + para : string; + i : longint; + + procedure helpscreen; + begin + writeln('dotest [Options] '); + Writeln; + Writeln('Options can be:'); + writeln(' -C set compiler to use'); + writeln(' -V verbose'); + halt(1); + end; + +begin + PPFile:=''; + CompilerBin:='ppc386'; + for i:=1 to paramcount do + begin + para:=Paramstr(i); + if (para[1]='-') then + begin + ch:=Upcase(para[2]); + delete(para,1,2); + case ch of + 'C' : CompilerBin:=Para; + 'V' : DoVerbose:=true; + 'G' : DoGraph:=true; + 'I' : DoInteractive:=true; + end; + end + else + begin + PPFile:=ForceExtension(Para,'pp'); + end; + end; + if (PPFile='') then + HelpScreen; + TestName:=Copy(PPFile,1,Pos('.pp',PPFile)-1); + Verbose(V_Debug,'Running test '+TestName+', file '+PPFile); +end; + + +procedure RunTest; +var + Res : boolean; +begin + Verbose(V_Normal,'Running test '+TestName); + Res:=GetConfig(ppfile,Config); + + if Res then + begin + if Config.UsesGraph and (not DoGraph) then + begin + Verbose(V_Abort,'Skipping test because it uses graph'); + Res:=false; + end; + end; + + if Res then + begin + if Config.IsInteractive and (not DoInteractive) then + begin + Verbose(V_Abort,'Skipping test because it is interactive'); + Res:=false; + end; + end; + + if Res then + begin + if Config.NeedVersion<>'' then + begin + Verbose(V_Debug,'Required compiler version: '+Config.NeedVersion); + Res:=GetCompilerVersion; + if Config.NeedVersion'' then + begin + Verbose(V_Debug,'Required compiler cpu: '+Config.NeedCPU); + Res:=GetCompilerVersion; + if Upper(Config.NeedCPU) '+Config.NeedCPU); + Res:=false; + end; + end; + end; + + if Res then + Res:=RunCompiler; + + if Res then + begin + if FileExists(ForceExtension(PPFile,'ppu')) or + FileExists(ForceExtension(PPFile,'ppw')) then + Verbose(V_Debug,'Unit found, skipping run test') + else + Res:=RunExecutable; + end; +end; + + +begin + GetArgs; + RunTest; +end. diff --git a/tests/utils/redir.pp b/tests/utils/redir.pp new file mode 100644 index 0000000000..53b56cc8fc --- /dev/null +++ b/tests/utils/redir.pp @@ -0,0 +1,731 @@ +{ + $Id$ + This file is part of the Free Pascal Test Suite + Copyright (c) 1999-2000 by Pierre Muller + + Unit to redirect output and error to files + + Adapted from code donated to public domain by Schwartz Gabriel 20/03/1993 + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + **********************************************************************} +Unit Redir; +Interface + +{$R-} +{$ifndef linux} + {$S-} +{$endif} + +{$ifdef TP} +{$define implemented} +{$endif TP} +{$ifdef Go32v2} +{$define implemented} +{$endif} +{$ifdef Win32} +{$define implemented} +{$endif} +{$ifdef linux} +{$define implemented} +{$endif} + +{ be sure msdos is not set for FPC compiler } +{$ifdef FPC} +{$UnDef MsDos} +{$endif FPC} + +Var + IOStatus : Integer; + RedirErrorOut,RedirErrorIn, + RedirErrorError : Integer; + ExecuteResult : Word; + +{------------------------------------------------------------------------------} +procedure InitRedir; +function ExecuteRedir (Const ProgName, ComLine, RedirStdIn, RedirStdOut, RedirStdErr : String) : boolean; +procedure DosExecute(ProgName, ComLine : String); + +function ChangeRedirOut(Const Redir : String; AppendToFile : Boolean) : Boolean; +procedure RestoreRedirOut; +procedure DisableRedirOut; +procedure EnableRedirOut; +function ChangeRedirIn(Const Redir : String) : Boolean; +procedure RestoreRedirIn; +procedure DisableRedirIn; +procedure EnableRedirIn; +function ChangeRedirError(Const Redir : String; AppendToFile : Boolean) : Boolean; +procedure RestoreRedirError; +procedure DisableRedirError; +procedure EnableRedirError; +procedure RedirDisableAll; +procedure RedirEnableAll; + +Implementation + +Uses +{$ifdef go32v2} + go32, +{$endif go32v2} +{$ifdef win32} + windows, +{$endif win32} +{$ifdef linux} + linux, +{$endif linux} + dos; + +var + FIN,FOUT,FERR : ^File; + RedirChangedOut, + RedirChangedIn : Boolean; + RedirChangedError : Boolean; + InRedirDisabled,OutRedirDisabled,ErrorRedirDisabled : Boolean; + +{***************************************************************************** + Dos +*****************************************************************************} + +{$ifdef implemented} + +{$ifdef TP} + +{$ifndef win32} +const + UnusedHandle = -1; + StdInputHandle = 0; + StdOutputHandle = 1; + StdErrorHandle = 2; +{$endif win32} + +Type + PtrRec = packed record + Ofs, Seg : Word; + end; + + PHandles = ^THandles; + THandles = Array [Byte] of Byte; + + PWord = ^Word; + +Var + MinBlockSize : Word; + MyBlockSize : Word; + Handles : PHandles; + PrefSeg : Word; + OldHandleOut,OldHandleIn,OldHandleError : Byte; +{$endif TP} + +var + TempHOut, TempHIn,TempHError : longint; + +{ For linux the following functions exist +Function Dup(oldfile:longint;var newfile:longint):Boolean; +Function Dup2(oldfile,newfile:longint):Boolean; +Function fdClose(fd:longint):boolean; +} +{$ifdef go32v2} + +function dup(fh : longint;var nh : longint) : boolean; + var + Regs : Registers; + +begin + Regs.ah:=$45; + Regs.bx:=fh; + MsDos (Regs); + Dup:=true; + If (Regs.Flags and fCarry)=0 then + nh:=Regs.Ax + else + Dup:=false; +end; + +function dup2(fh,nh : longint) : boolean; + var + Regs : Registers; + +begin + Dup2:=true; + If fh=nh then + exit; + Regs.ah:=$46; + Regs.bx:=fh; + Regs.cx:=nh; + MsDos (Regs); + If (Regs.Flags and fCarry)<>0 then + Dup2:=false; +end; + +Function FdClose (Handle : Longint) : boolean; +var Regs: registers; +begin + Regs.Eax := $3e00; + Regs.Ebx := Handle; + MsDos(Regs); + FdClose:=(Regs.Flags and fCarry)=0; +end; + +{$endif def go32v2} + +{$ifdef win32} +Function FdClose (Handle : Longint) : boolean; +begin + { Do we need this ?? } + FdClose:=true; +end; +{$endif} + +{$ifdef TP} +Function FdClose (Handle : Longint) : boolean; +begin + { if executed as under GO32 this hangs the DOS-prompt } + FdClose:=true; +end; + +{$endif} + +{$I-} +function FileExist(const FileName : PathStr) : Boolean; +var + f : file; + Attr : word; +begin + Assign(f, FileName); + GetFAttr(f, Attr); + FileExist := DosError = 0; +end; + + +{............................................................................} + +function ChangeRedirOut(Const Redir : String; AppendToFile : Boolean) : Boolean; + begin + ChangeRedirOut:=False; + If Redir = '' then Exit; + Assign (FOUT^, Redir); + If AppendToFile and FileExist(Redir) then + Begin + Reset(FOUT^,1); + Seek(FOUT^,FileSize(FOUT^)); + End else Rewrite (FOUT^); + + RedirErrorOut:=IOResult; + IOStatus:=RedirErrorOut; + If IOStatus <> 0 then Exit; +{$ifndef FPC} + Handles:=Ptr (prefseg, PWord (Ptr (prefseg, $34))^); + OldHandleOut:=Handles^[StdOutputHandle]; + Handles^[StdOutputHandle]:=Handles^[FileRec (FOUT^).Handle]; + ChangeRedirOut:=True; + OutRedirDisabled:=False; +{$else} +{$ifdef win32} + if SetStdHandle(Std_Output_Handle,FileRec(FOUT^).Handle) then +{$else not win32} + if dup(StdOutputHandle,TempHOut) and + dup2(FileRec(FOUT^).Handle,StdOutputHandle) then +{$endif not win32} + begin + ChangeRedirOut:=True; + OutRedirDisabled:=False; + end; +{$endif def FPC} + RedirChangedOut:=True; + end; + +function ChangeRedirIn(Const Redir : String) : Boolean; + begin + ChangeRedirIn:=False; + If Redir = '' then Exit; + Assign (FIN^, Redir); + Reset(FIN^,1); + + RedirErrorIn:=IOResult; + IOStatus:=RedirErrorIn; + If IOStatus <> 0 then Exit; +{$ifndef FPC} + Handles:=Ptr (prefseg, PWord (Ptr (prefseg, $34))^); + OldHandleIn:=Handles^[StdInputHandle]; + Handles^[StdInputHandle]:=Handles^[FileRec (FIN^).Handle]; + ChangeRedirIn:=True; + InRedirDisabled:=False; +{$else} +{$ifdef win32} + if SetStdHandle(Std_Input_Handle,FileRec(FIN^).Handle) then +{$else not win32} + if dup(StdInputHandle,TempHIn) and + dup2(FileRec(FIN^).Handle,StdInputHandle) then +{$endif not win32} + begin + ChangeRedirIn:=True; + InRedirDisabled:=False; + end; +{$endif def FPC} + RedirChangedIn:=True; + end; + +function ChangeRedirError(Const Redir : String; AppendToFile : Boolean) : Boolean; + begin + ChangeRedirError:=False; + If Redir = '' then Exit; + Assign (FERR^, Redir); + If AppendToFile and FileExist(Redir) then + Begin + Reset(FERR^,1); + Seek(FERR^,FileSize(FERR^)); + End else Rewrite (FERR^); + + RedirErrorError:=IOResult; + IOStatus:=RedirErrorError; + If IOStatus <> 0 then Exit; +{$ifndef FPC} + Handles:=Ptr (prefseg, PWord (Ptr (prefseg, $34))^); + OldHandleError:=Handles^[StdErrorHandle]; + Handles^[StdErrorHandle]:=Handles^[FileRec (FERR^).Handle]; + ChangeRedirError:=True; + ErrorRedirDisabled:=False; +{$else} +{$ifdef win32} + if SetStdHandle(Std_Error_Handle,FileRec(FERR^).Handle) then +{$else not win32} + if dup(StdErrorHandle,TempHError) and + dup2(FileRec(FERR^).Handle,StdErrorHandle) then +{$endif not win32} + begin + ChangeRedirError:=True; + ErrorRedirDisabled:=False; + end; +{$endif} + RedirChangedError:=True; + end; + + +{$IfDef MsDos} +{Set HeapEnd Pointer to Current Used Heapsize} +Procedure SmallHeap;assembler; +asm + mov bx,word ptr HeapPtr + shr bx,4 + inc bx + add bx,word ptr HeapPtr+2 + mov ax,PrefixSeg + sub bx,ax + mov es,ax + mov ah,4ah + int 21h +end; + + + +{Set HeapEnd Pointer to Full Heapsize} +Procedure FullHeap;assembler; +asm + mov bx,word ptr HeapEnd + shr bx,4 + inc bx + add bx,word ptr HeapEnd+2 + mov ax,PrefixSeg + sub bx,ax + mov es,ax + mov ah,4ah + int 21h +end; + +{$EndIf MsDos} + + + procedure RestoreRedirOut; + + begin + If not RedirChangedOut then Exit; +{$ifndef FPC} + Handles^[StdOutputHandle]:=OldHandleOut; + OldHandleOut:=StdOutputHandle; +{$else} +{$ifdef win32} + SetStdHandle(Std_Output_Handle,StdOutputHandle); +{$else not win32} + dup2(TempHOut,StdOutputHandle); +{$endif not win32} +{$endif FPC} + Close (FOUT^); + fdClose(TempHOut); + RedirChangedOut:=false; + end; + + {............................................................................} + + procedure RestoreRedirIn; + + begin + If not RedirChangedIn then Exit; +{$ifndef FPC} + Handles^[StdInputHandle]:=OldHandleIn; + OldHandleIn:=StdInputHandle; +{$else} +{$ifdef win32} + SetStdHandle(Std_Input_Handle,StdInputHandle); +{$else not win32} + dup2(TempHIn,StdInputHandle); +{$endif not win32} +{$endif} + Close (FIn^); + fdClose(TempHIn); + RedirChangedIn:=false; + end; + + {............................................................................} + + procedure DisableRedirIn; + + begin + If not RedirChangedIn then Exit; + If InRedirDisabled then Exit; +{$ifndef FPC} + Handles^[StdInputHandle]:=OldHandleIn; +{$else} +{$ifdef win32} + SetStdHandle(Std_Input_Handle,StdInputHandle); +{$else not win32} + dup2(TempHIn,StdInputHandle); +{$endif not win32} +{$endif} + InRedirDisabled:=True; + end; + + {............................................................................} + + procedure EnableRedirIn; + + begin + If not RedirChangedIn then Exit; + If not InRedirDisabled then Exit; +{$ifndef FPC} + Handles:=Ptr (prefseg, PWord (Ptr (prefseg, $34))^); + Handles^[StdInputHandle]:=Handles^[FileRec (FIn^).Handle]; +{$else} +{$ifdef win32} + SetStdHandle(Std_Input_Handle,FileRec(FIn^).Handle); +{$else not win32} + dup2(FileRec(FIn^).Handle,StdInputHandle); +{$endif not win32} +{$endif} + InRedirDisabled:=False; + end; + + {............................................................................} + + procedure DisableRedirOut; + + begin + If not RedirChangedOut then Exit; + If OutRedirDisabled then Exit; +{$ifndef FPC} + Handles^[StdOutputHandle]:=OldHandleOut; +{$else} +{$ifdef win32} + SetStdHandle(Std_Output_Handle,StdOutputHandle); +{$else not win32} + dup2(TempHOut,StdOutputHandle); +{$endif not win32} +{$endif} + OutRedirDisabled:=True; + end; + + {............................................................................} + + procedure EnableRedirOut; + + begin + If not RedirChangedOut then Exit; + If not OutRedirDisabled then Exit; +{$ifndef FPC} + Handles:=Ptr (prefseg, PWord (Ptr (prefseg, $34))^); + Handles^[StdOutputHandle]:=Handles^[FileRec (FOut^).Handle]; +{$else} +{$ifdef win32} + SetStdHandle(Std_Output_Handle,FileRec(FOut^).Handle); +{$else not win32} + dup2(FileRec(FOut^).Handle,StdOutputHandle); +{$endif not win32} +{$endif} + OutRedirDisabled:=False; + end; + + {............................................................................} + + procedure RestoreRedirError; + + begin + If not RedirChangedError then Exit; +{$ifndef FPC} + Handles^[StdErrorHandle]:=OldHandleError; + OldHandleError:=StdErrorHandle; +{$else} +{$ifdef win32} + SetStdHandle(Std_Error_Handle,StdErrorHandle); +{$else not win32} + dup2(TempHError,StdErrorHandle); +{$endif not win32} +{$endif} + Close (FERR^); + fdClose(TempHError); + RedirChangedError:=false; + end; + + {............................................................................} + + procedure DisableRedirError; + + begin + If not RedirChangedError then Exit; + If ErrorRedirDisabled then Exit; +{$ifndef FPC} + Handles^[StdErrorHandle]:=OldHandleError; +{$else} +{$ifdef win32} + SetStdHandle(Std_Error_Handle,StdErrorHandle); +{$else not win32} + dup2(TempHError,StdErrorHandle); +{$endif not win32} +{$endif} + ErrorRedirDisabled:=True; + end; + + {............................................................................} + + procedure EnableRedirError; + + begin + If not RedirChangedError then Exit; + If not ErrorRedirDisabled then Exit; +{$ifndef FPC} + Handles:=Ptr (prefseg, PWord (Ptr (prefseg, $34))^); + Handles^[StdErrorHandle]:=Handles^[FileRec (FErr^).Handle]; +{$else} +{$ifdef win32} + SetStdHandle(Std_Error_Handle,FileRec(FErr^).Handle); +{$else not win32} + dup2(FileRec(FERR^).Handle,StdErrorHandle); +{$endif not win32} +{$endif} + ErrorRedirDisabled:=False; + end; + +{............................................................................} + +function ExecuteRedir (Const ProgName, ComLine, RedirStdIn, RedirStdOut, RedirStdErr : String) : boolean; +Begin + RedirErrorOut:=0; RedirErrorIn:=0; RedirErrorError:=0; + ExecuteResult:=0; + IOStatus:=0; + if RedirStdIn<>'' then + ChangeRedirIn(RedirStdIn); + if RedirStdOut<>'' then + ChangeRedirOut(RedirStdOut,false); + if RedirStdErr<>'stderr' then + ChangeRedirError(RedirStdErr,false); + DosExecute(ProgName,ComLine); + RestoreRedirOut; + RestoreRedirIn; + RestoreRedirError; + ExecuteRedir:=(IOStatus=0) and (RedirErrorOut=0) and + (RedirErrorIn=0) and (RedirErrorError=0) and + (ExecuteResult=0); +End; + +{............................................................................} + +procedure RedirDisableAll; + begin + If RedirChangedIn and not InRedirDisabled then + DisableRedirIn; + If RedirChangedOut and not OutRedirDisabled then + DisableRedirOut; + If RedirChangedError and not ErrorRedirDisabled then + DisableRedirError; + end; + +{............................................................................} + +procedure RedirEnableAll; + begin + If RedirChangedIn and InRedirDisabled then + EnableRedirIn; + If RedirChangedOut and OutRedirDisabled then + EnableRedirOut; + If RedirChangedError and ErrorRedirDisabled then + EnableRedirError; + end; + + +procedure InitRedir; +begin +{$ifndef FPC} + PrefSeg:=PrefixSeg; +{$endif FPC} +end; + +{$else not implemented} + + +{***************************************************************************** + Fake +*****************************************************************************} + +function ExecuteRedir (Const ProgName, ComLine, RedirStdIn, RedirStdOut, RedirStdErr : String) : boolean; +begin + ExecuteRedir:=false; +end; + +function ChangeRedirOut(Const Redir : String; AppendToFile : Boolean) : Boolean; +begin + ChangeRedirOut:=false; +end; + + +procedure RestoreRedirOut; +begin +end; + + +procedure DisableRedirOut; +begin +end; + + +procedure EnableRedirOut; +begin +end; + + +function ChangeRedirIn(Const Redir : String) : Boolean; +begin + ChangeRedirIn:=false; +end; + + +procedure RestoreRedirIn; +begin +end; + + +procedure DisableRedirIn; +begin +end; + + +procedure EnableRedirIn; +begin +end; + + +function ChangeRedirError(Const Redir : String; AppendToFile : Boolean) : Boolean; +begin + ChangeRedirError:=false; +end; + + +procedure RestoreRedirError; +begin +end; + + +procedure DisableRedirError; +begin +end; + + +procedure EnableRedirError; +begin +end; + + +procedure RedirDisableAll; +begin +end; + + +procedure RedirEnableAll; +begin +end; + + +procedure InitRedir; +begin +end; +{$endif not implemented} + + +{............................................................................} + + procedure DosExecute(ProgName, ComLine : String); +{$ifdef win32} + var + StoreInherit : BOOL; +{$endif win32} + + Begin +{$IfDef MsDos} + SmallHeap; +{$EndIf MsDos} + SwapVectors; + { Must use shell() for linux for the wildcard expansion (PFV) } +{$ifdef linux} + IOStatus:=0; + ExecuteResult:=Shell(Progname+' '+Comline); + { Signal that causes the stop of the shell } + IOStatus:=ExecuteResult and $7F; + { Exit Code seems to be in the second byte, + is this also true for BSD ?? + $80 bit is a CoreFlag apparently } + ExecuteResult:=(ExecuteResult and $ff00) shr 8; +{$else} +{$ifdef win32} + StoreInherit:=ExecInheritsHandles; + ExecInheritsHandles:=true; +{$endif win32} + DosError:=0; + Dos.Exec (ProgName, ComLine); +{$ifdef win32} + ExecInheritsHandles:=StoreInherit; +{$endif win32} + IOStatus:=DosError; + ExecuteResult:=DosExitCode; +{$endif} + SwapVectors; +{$ifdef CPU86} + { reset the FPU } +{$asmmode att} + asm + fninit + end; +{$endif CPU86} +{$IfDef MsDos} + Fullheap; +{$EndIf MsDos} + End; + +{***************************************************************************** + Initialize +*****************************************************************************} + +initialization + New(FIn); New(FOut); New(FErr); + +finalization + Dispose(FIn); Dispose(FOut); Dispose(FErr); +End. +{ + $Log$ + Revision 1.1 2000-11-29 23:14:20 peter + * new testsuite setup + +} \ No newline at end of file diff --git a/tests/webtbf/tw1157.pp b/tests/webtbf/tw1157.pp new file mode 100644 index 0000000000..cc63909463 --- /dev/null +++ b/tests/webtbf/tw1157.pp @@ -0,0 +1,41 @@ +{ Source provided for Free Pascal Bug Report 1157 } +{ Submitted by "Colin Goldie" on 2000-10-06 } +{ e-mail: Colin_G@Positek.com.au } + +{$mode delphi} + +{$asmmode intel} + +{ @Result in assembler functions where + the function result is not on stack + should be refused in Delphi mode } + +Function GetBLUEfromRGB( color : word ) : byte; assembler; +asm + mov cx,color + and cx,0000000000011111b + mov @Result,cl +end; + +{ +Does something weird .. to the stack im guessing ... error 206 and 103 +errors occur 'File not open' ... + +However, if instead of using @Result , i chuck my return value into the +accumulator register , everything thing works hunky dory. +} + +Function GetBLUEfromRGB2( color : word ) : byte; assembler; +asm + mov cx,color + and cx,0000000000011111b + mov al,cl +end; + +begin + if GetBlueFromRGB2($fff)<>GetBlueFromRGB($fff) then + begin + Writeln('Error in assembler statement'); + Halt(1); + end; +end. diff --git a/tests/webtbf/tw1157a.pp b/tests/webtbf/tw1157a.pp new file mode 100644 index 0000000000..3472ecc147 --- /dev/null +++ b/tests/webtbf/tw1157a.pp @@ -0,0 +1,41 @@ +{ Source provided for Free Pascal Bug Report 1157 } +{ Submitted by "Colin Goldie" on 2000-10-06 } +{ e-mail: Colin_G@Positek.com.au } + +{$mode tp} + +{$asmmode intel} + +{ @Result in assembler functions where + the function result is not on stack + should be refused in Turbo Pascal mode } + +Function GetBLUEfromRGB( color : word ) : byte; assembler; +asm + mov cx,color + and cx,0000000000011111b + mov @Result,cl +end; + +{ +Does something weird .. to the stack im guessing ... error 206 and 103 +errors occur 'File not open' ... + +However, if instead of using @Result , i chuck my return value into the +accumulator register , everything thing works hunky dory. +} + +Function GetBLUEfromRGB2( color : word ) : byte; assembler; +asm + mov cx,color + and cx,0000000000011111b + mov al,cl +end; + +begin + if GetBlueFromRGB2($fff)<>GetBlueFromRGB($fff) then + begin + Writeln('Error in assembler statement'); + Halt(1); + end; +end. diff --git a/tests/webtbf/tw1238.pp b/tests/webtbf/tw1238.pp new file mode 100644 index 0000000000..7e948d32a6 --- /dev/null +++ b/tests/webtbf/tw1238.pp @@ -0,0 +1,23 @@ +{ Source provided for Free Pascal Bug Report 1238 } +{ Submitted by "Mazen NEIFER" on 2000-11-14 } +{ e-mail: mazen_neifer@ayna.com } +PROGRAM Concat; +VAR + InputFile,OutputFile:File; + c:Char; + Buffer:Array[DWord]OF Byte; + ReadCount,WriteCount:DWord; +BEGIN + Assign(OutputFile,'Maple.tar.gz'); + ReWrite(OutputFile,1); + FOR c:='a' TO 'n' DO + BEGIN + Assign(InputFile,'xa'+c); + Reset(InputFile,1); + BlockRead(InputFile,Buffer,SizeOf(Buffer),ReadCount); + BlockWrite(OutputFile,Buffer,SizeOf(Buffer),WriteCount); + Close(InputFile); + END; + Close(OutputFile); +END. + diff --git a/tests/webtbf/tw744.pp b/tests/webtbf/tw744.pp new file mode 100644 index 0000000000..62af7cc84b --- /dev/null +++ b/tests/webtbf/tw744.pp @@ -0,0 +1,9 @@ +Unit tbug744; + +Interface + +Uses tbug744a; + +Implementation + +end. diff --git a/tests/webtbf/tw744a.pp b/tests/webtbf/tw744a.pp new file mode 100644 index 0000000000..ae38115e7f --- /dev/null +++ b/tests/webtbf/tw744a.pp @@ -0,0 +1,10 @@ +Unit tbug744a; + +Interface + +Uses tbug744; + +Implementation + +end. + diff --git a/tests/webtbf/tw784.pp b/tests/webtbf/tw784.pp new file mode 100644 index 0000000000..ba6f9d61cf --- /dev/null +++ b/tests/webtbf/tw784.pp @@ -0,0 +1,27 @@ +{$R+} +{ should not compile if range check on } +program BigRange; + +const + Limit = 100000000; { Hundred millions } + One = 1; + +var + Huge: longint; + +begin + Huge := Limit + One; + + writeln(One, ' is the lower bound'); + writeln(Limit, ' is the upper bound'); + + if Limit in [One .. Limit] then + writeln(Limit, ' is within the range') + else + writeln(Limit, ' is out of the range'); + + if Huge in [One .. Limit] then + writeln(Huge, ' is within the range') + else + writeln(Huge, ' is out of the range') +end. diff --git a/tests/webtbf/tw807.pp b/tests/webtbf/tw807.pp new file mode 100644 index 0000000000..e0d3cdc10b --- /dev/null +++ b/tests/webtbf/tw807.pp @@ -0,0 +1,52 @@ +{$mode objfpc} + +Program test; + +uses crt; + +type + TMatrix = class + Constructor Create; + private + Elements : array [1..10,1..10] of real; + end; + +Constructor TMatrix.Create; + +begin +end; + +OPERATOR :=(r:Real):TMatrix; + BEGIN + WITH RESULT DO + BEGIN +{ Do something } + END; + writeln ('Call to overloaded operator :=, real operand'); + END; +operator :=(m : TMatrix):TMatrix; + BEGIN + WITH RESULT DO + BEGIN +{ Do something } + END; + writeln ('Call to overloaded operator :=, matrix operand'); + END; + +var + m : TMatrix; + m2 : TMatrix; + +begin + clrscr; + writeln ('Performing calculations...'); + m:=TMatrix.Create; + m2:=TMatrix.Create; + writeln ('Assigning real to matrix...'); +{ This one works } + m:=1; + writeln ('Assigning matrix to matrix...'); +{ This one does not work } + m:=m2; + writeln ('Done.'); +end. \ No newline at end of file diff --git a/tests/webtbf/tw856.pp b/tests/webtbf/tw856.pp new file mode 100644 index 0000000000..84157603dc --- /dev/null +++ b/tests/webtbf/tw856.pp @@ -0,0 +1,7 @@ +{$MODE objfpc} +uses + tbug856u; + +begin + TMyClass.Create(1); +end. \ No newline at end of file diff --git a/tests/webtbf/tw856u.pp b/tests/webtbf/tw856u.pp new file mode 100644 index 0000000000..001ea88687 --- /dev/null +++ b/tests/webtbf/tw856u.pp @@ -0,0 +1,16 @@ +{$MODE objfpc} +unit tbug856u; +interface +type + TMyClass = class + protected + constructor Create(x: Integer); + end; + +implementation + +constructor TMyClass.Create(x: Integer); +begin +end; + +end. \ No newline at end of file diff --git a/tests/webtbf/tw890.pp b/tests/webtbf/tw890.pp new file mode 100644 index 0000000000..0de365d363 --- /dev/null +++ b/tests/webtbf/tw890.pp @@ -0,0 +1,19 @@ +{$ifdef FPC} + {$MODE TP} +{$endif FPC} + +unit tbug890; + +INTERFACE + +procedure GetScreenLine(const x: Integer); + +IMPLEMENTATION + + +procedure GetScreenLine(x: Integer); +begin +end; + +begin +end. \ No newline at end of file diff --git a/tests/webtbf/tw896.pp b/tests/webtbf/tw896.pp new file mode 100644 index 0000000000..95a8bdb285 --- /dev/null +++ b/tests/webtbf/tw896.pp @@ -0,0 +1,16 @@ + +var + dat : file; + j : longint; + Buffer : Array[0..2047] of byte; + +begin + for j:=0 to 2047 do + Buffer[j]:=j and $ff; + Assign(dat,'tbug896.txt'); + Rewrite(dat,1); + for j:= 0 to 2047 do + { write should not be allowed for untyped files } + write (dat,Buffer[j]); + Close(dat); +end. \ No newline at end of file diff --git a/tests/webtbf/tw896a.pp b/tests/webtbf/tw896a.pp new file mode 100644 index 0000000000..602e63086e --- /dev/null +++ b/tests/webtbf/tw896a.pp @@ -0,0 +1,16 @@ + +var + dat : file of byte; + j : longint; + Buffer : Array[0..2047] of byte; + +begin + for j:=0 to 2047 do + Buffer[j]:=j and $ff; + Assign(dat,'tbug896.txt'); + Rewrite(dat,1); + for j:= 0 to 2047 do + { writeln should not be allowed for typed files } + writeln (dat,Buffer[j]); + Close(dat); +end. \ No newline at end of file diff --git a/tests/webtbs/tw1021.pp b/tests/webtbs/tw1021.pp new file mode 100644 index 0000000000..d598abe6f2 --- /dev/null +++ b/tests/webtbs/tw1021.pp @@ -0,0 +1,55 @@ +{ Source provided for Free Pascal Bug Report 1021 } +{ Submitted by "Oliver Puetz" on 2000-07-03 } +{ e-mail: Oliver.Puetz@gmx.de } +{ + Free Pascal Compiler version 0.99.15 [2000/03/30] for i386 + Copyright (c) 1993-2000 by Florian Klaempfl + Win NT 4.0 Fixpak 2 + + With TFloat = EXTENDED Writeln resumes 0.0 0.0 1 + With TFloat = DOUBLE Writeln resumes 0.0 1.0 1 + + Thus only the write-command seems not to transfer the extended a equals 1 + to a string like '1' +} + +type tfloat = extended; + +var a, b : tfloat; + i : INTEGER; + f : text; +begin + case sizeof(tfloat) of + 4: writeln('single'); + 8: writeln('double'); + 10: writeln('extended'); + else writeln(sizeof(tfloat)); + end; + a := 0; + b := 1 - a; + i := Round(b); + writeln(a:30:20, b:30:20, i:10); + assign(f,'tbug1021.txt'); + rewrite(f); + writeln(f,a:30:20,' ',b:30:20,' ',i:10); + close(f); + reset(f); + read(f,a); + read(f,b); + read(f,i); + if (a<>0.0) then + begin + Writeln('Error reading A value, should be zero'); + Halt(1); + end; + if (b<>1.0) then + begin + Writeln('Error reading B value, should be one'); + Halt(1); + end; + if (i<>1) then + begin + Writeln('Error reading I value, should be one'); + Halt(1); + end; +end. \ No newline at end of file diff --git a/tests/webtbs/tw1023.pp b/tests/webtbs/tw1023.pp new file mode 100644 index 0000000000..8d41755c3e --- /dev/null +++ b/tests/webtbs/tw1023.pp @@ -0,0 +1,29 @@ +{ Source provided for Free Pascal Bug Report 1023 } +{ Submitted by "Denis Yarkovoy" on 2000-07-03 } +{ e-mail: gunky9@geocities.com } + {$goto on} + {$i386_intel} + label l1; + +var + pp : pointer; + + procedure p1; assembler; asm + mov eax, offset l1 + lea edi,pp + mov dword ptr [edi],eax + end; + + procedure p; assembler; asm + l1: + clc + end; + +begin + pp:=nil; + p1; + if pp=nil then + halt(1) + else + Writeln('Bug 1023 fixed'); +end. diff --git a/tests/webtbs/tw1041.pp b/tests/webtbs/tw1041.pp new file mode 100644 index 0000000000..49148609fd --- /dev/null +++ b/tests/webtbs/tw1041.pp @@ -0,0 +1,14 @@ +uses + sysutils,dos; + +begin +Writeln('Dos DiskSize = ',Dos.DiskSize(0)); +Writeln('Sysutils DiskSize = ',SysUtils.DiskSize(0)); +Writeln('Dos DiskFree = ',Dos.DiskFree(0)); +Writeln('Sysutils DiskFree = ',SysUtils.DiskFree(0)); +if Dos.DiskSize(0)<>SysUtils.DiskSize(0) then + Begin + Writeln('Error with DiskSize'); + Halt(1); + End; +end. \ No newline at end of file diff --git a/tests/webtbs/tw1046.pp b/tests/webtbs/tw1046.pp new file mode 100644 index 0000000000..0f83838ee5 --- /dev/null +++ b/tests/webtbs/tw1046.pp @@ -0,0 +1,8 @@ +procedure test2(self : longint); +begin + writeln(self); +end; + +begin + test2(1); +end. diff --git a/tests/webtbs/tw1061.pp b/tests/webtbs/tw1061.pp new file mode 100644 index 0000000000..14b225848e --- /dev/null +++ b/tests/webtbs/tw1061.pp @@ -0,0 +1,12 @@ +var vlCnt:longint; +begin + vlCnt := 10; + case vlCnt of + 7: writeln(7); + 12,13: begin + writeln('Case codegeneration error!'); + halt(1); + end; + 11:writeln(11); + end; +end. diff --git a/tests/webtbs/tw1066a.pp b/tests/webtbs/tw1066a.pp new file mode 100644 index 0000000000..03ab923fab --- /dev/null +++ b/tests/webtbs/tw1066a.pp @@ -0,0 +1,119 @@ +{ Source provided for Free Pascal Bug Report 1066 } +{ Submitted by "Fernando Oscar Schmitt" on 2000-07-24 } +{ e-mail: pulp@cpovo.net } + +var + somevar:longint; + +{$asmmode intel} +{$inline on} + +procedure putpixel(x,y,color:longint);assembler;inline; +asm +mov edi,x +mov eax,y +cmp edi,0 +jl @@putpixelend +cmp eax,0 +jl @@putpixelend +cmp edi,1023 +jg @@putpixelend +cmp eax,767 +jg @@putpixelend +shl eax,12 +mov ebx,color +add eax,somevar +mov [eax+edi*4],ebx +@@putpixelend: +end ['eax','ebx','edi']; + + +procedure pixelrow(y,x1,x2,color:longint);assembler;inline; +asm +mov edi,x1 +mov ecx,x2 +mov eax,y +cmp edi,ecx +jle @@pixelrowdirok +xchg edi,ecx +@@pixelrowdirok: +cmp eax,0 +jl @@endpixelrow +cmp eax,767 +jg @@endpixelrow +cmp ecx,0 +jl @@endpixelrow +cmp edi,1023 +jg @@endpixelrow +cmp edi,0 +jge @@pixelrowx1ok +mov edi,0 +@@pixelrowx1ok: +cmp ecx,1023 +jle @@pixelrowx2ok +mov ecx,1023 +@@pixelrowx2ok: +sub ecx,edi +shl eax,12 +inc ecx +add eax,somevar +cld +lea edi,[eax+4*edi] +mov eax,color +rep stosd +@@endpixelrow: +end ['eax','ecx','edi']; + + +function str(w:word):string; +var tmp:string; +begin +system.str(w,tmp); +str:=tmp; +end; + +function str(l:longint):string; +var tmp:string; +begin +system.str(l,tmp); +str:=tmp; +end; + + +procedure circle(x0,y0,r,color:longint); +var x,y:longint; +begin +for x:=0 to trunc(r*(sqrt(2)/2))+1 do + begin + y:=round(sqrt(r*r-x*x)); + putpixel(x0+x,y0+y,color); + putpixel(x0-x,y0+y,color); + putpixel(x0+x,y0-y,color); + putpixel(x0-x,y0-y,color); + putpixel(x0+y,y0+x,color); + putpixel(x0-y,y0+x,color); + putpixel(x0+y,y0-x,color); + putpixel(x0-y,y0-x,color); + end; +end; + + +procedure circlefill(x0,y0,r,color:longint); +var x,y:longint; +begin +for x:=0 to trunc(r*(sqrt(2)/2))+1 do + begin + y:=round(sqrt(r*r-x*x)); + pixelrow(y0+y,x0-x,x0+x,color); + pixelrow(y0-y,x0-x,x0+x,color); + pixelrow(y0+x,x0-y,x0+y,color); + pixelrow(y0-x,x0-y,x0+y,color); + end; +end; + + +begin + +end. + + diff --git a/tests/webtbs/tw1066b.pp b/tests/webtbs/tw1066b.pp new file mode 100644 index 0000000000..6bc1e83fa5 --- /dev/null +++ b/tests/webtbs/tw1066b.pp @@ -0,0 +1,117 @@ +{----------------cut here----------------} + +{$asmmode intel} +{$inline on} + +var + somevar:longint; + + +procedure wastememory(x,y,color:longint);assembler;inline; +asm +mov edi,x +mov eax,y +cmp edi,0 +jl @@wastememoryend +cmp eax,0 +jl @@wastememoryend +cmp edi,1023 +jg @@wastememoryend +cmp eax,767 +jg @@wastememoryend +shl eax,12 +mov ebx,color +add eax,somevar +mov [eax+edi*4],ebx +@@wastememoryend: +end ['eax','ebx','edi']; + + +procedure wastememory2(y,x1,x2,color:longint);assembler;inline; +asm +mov edi,x1 +mov ecx,x2 +mov eax,y +cmp edi,ecx +jle @@wastememory2dirok +xchg edi,ecx +@@wastememory2dirok: +cmp eax,0 +jl @@endwastememory2 +cmp eax,767 +jg @@endwastememory2 +cmp ecx,0 +jl @@endwastememory2 +cmp edi,1023 +jg @@endwastememory2 +cmp edi,0 +jge @@wastememory2x1ok +mov edi,0 +@@wastememory2x1ok: +cmp ecx,1023 +jle @@wastememory2x2ok +mov ecx,1023 +@@wastememory2x2ok: +sub ecx,edi +shl eax,12 +inc ecx +add eax,somevar +cld +lea edi,[eax+4*edi] +mov eax,color +rep stosd +@@endwastememory2: +end ['eax','ecx','edi']; + + +function str(w:word):string; +var tmp:string; +begin +system.str(w,tmp); +str:=tmp; +end; + +function str(l:longint):string; +var tmp:string; +begin +system.str(l,tmp); +str:=tmp; +end; + + +procedure testcompiler(x0,y0,r,color:longint); +var x,y:longint; +begin +for x:=0 to trunc(r*(sqrt(2)/2))+1 do + begin + y:=round(sqrt(r*r-x*x)); + wastememory(x0+x,y0+y,color); + wastememory(x0-x,y0+y,color); + wastememory(x0+x,y0-y,color); + wastememory(x0-x,y0-y,color); + wastememory(x0+y,y0+x,color); + wastememory(x0-y,y0+x,color); + wastememory(x0+y,y0-x,color); + wastememory(x0-y,y0-x,color); + end; +end; + + +procedure testcompiler2(x0,y0,r,color:longint); +var x,y:longint; +begin +for x:=0 to trunc(r*(sqrt(2)/2))+1 do + begin + y:=round(sqrt(r*r-x*x)); + wastememory2(y0+y,x0-x,x0+x,color); + wastememory2(y0-y,x0-x,x0+x,color); + wastememory2(y0+x,x0-y,x0+y,color); + wastememory2(y0-x,x0-y,x0+y,color); + end; +end; + + +begin + +end. + diff --git a/tests/webtbs/tw1068.pp b/tests/webtbs/tw1068.pp new file mode 100644 index 0000000000..01c6c16fea --- /dev/null +++ b/tests/webtbs/tw1068.pp @@ -0,0 +1,14 @@ +PROGRAM bug1068; +VAR i: INT64; + s : string; +BEGIN + i:=2147483648; + str(i,s); + if s<>'2147483648' then + begin + writeln(s); + halt(1); + end + else + halt(0); +END. diff --git a/tests/webtbs/tw1071.pp b/tests/webtbs/tw1071.pp new file mode 100644 index 0000000000..b2a797e3ac --- /dev/null +++ b/tests/webtbs/tw1071.pp @@ -0,0 +1,38 @@ +var i: int64; + il: longint; + +begin + for il:=-20 to 20 do + begin + i:=il; + case i of + -3: + if (i<>-3) then + halt(1); + -7..-5: + if (i<-7) or (i>-5) then + halt(1); + -9..-8: + if (i<-9) or (i>-8) then + halt(1); + 0: + if (i<>0) then + halt(1); + 1: + if (i<>1) then + halt(1); + 2: + if (i<>2) then + halt(1); + 3..6: + if (i<3) or (i>6) then + halt(1); + 8..10: + if (i<8) or (i>10) then + halt(1); + end; + end; + halt(0); +end. + + diff --git a/tests/webtbs/tw1073.pp b/tests/webtbs/tw1073.pp new file mode 100644 index 0000000000..a873c891a5 --- /dev/null +++ b/tests/webtbs/tw1073.pp @@ -0,0 +1,43 @@ + +type Char4=array[1..4] of char; + T1=packed record + A1:Char4; + A2:Char4; + A3:Char4; + end; + PT2=^T2; + T2=record + B1:T1; + B2:Char4; + B3:longint; + end; + T3=record + C1:Char4; + end; + +var S1,S2:String; + +procedure trifich(P1,P2,P3:string; P4:boolean); +begin + if P4 then WriteLn(P2+P3+'IN '+P1); +end; + +var V1:PT2; + V2:T3; +begin + new(V1); + s1 := 'abc'; + s2 := 'def'; + with v1^ do + begin + b1.a1 := '1234'; + b1.a2 := '5678'; + b1.a3 := 'ghij'; + b2 := '0000'; + b3 := longint(char4('9999')); + end; + v2.c1 := 'wxyz'; + TriFich(S1+S2, + V1^.B1.A1+V1^.B1.A2+V1^.B1.A3+V1^.B2+Char4(V1^.B3)+#13#10, + V1^.B1.A1+V1^.B1.A2+V1^.B1.A3+V2.C1+Char4(V1^.B3)+#13#10,true); +end. diff --git a/tests/webtbs/tw1081.pp b/tests/webtbs/tw1081.pp new file mode 100644 index 0000000000..fb1b4f0cee --- /dev/null +++ b/tests/webtbs/tw1081.pp @@ -0,0 +1,41 @@ +uses dos; +var dirinfo:searchrec; + +function IntToStr(I: Longint): String; +{ Convert any integer type to a string } +var + S: string[11]; +begin + Str(I, S); + IntToStr := S; +end; + +procedure write_error(errorstring:string); +var +h,m,s,j,mo,ta,dummy:word; +stri:string; +begin + gettime(h,m,s,dummy); + getdate(j,mo,ta,dummy); + stri:=inttostr(j)+':'+inttostr(mo)+':'+inttostr(ta)+' '+inttostr(h)+':'+inttostr(m)+':'+inttostr(s); + writeln(stri,' ',errorstring); +end; + +procedure readprgfiles; +var i:word; +begin + FindFirst('*.pp',anyfile, DirInfo); + while doserror = 0 do + begin + inc(i); + writeln(dirinfo.name); + write_error(dirinfo.name); {without this function the program works} + FindNext(DirInfo); + end; + write_error('fertig'); +end; + + +BEGIN +readprgfiles; +END. diff --git a/tests/webtbs/tw1090.pp b/tests/webtbs/tw1090.pp new file mode 100644 index 0000000000..8f6978e72f --- /dev/null +++ b/tests/webtbs/tw1090.pp @@ -0,0 +1,17 @@ +{$asmmode intel} +const + Number = $7FFFFFF; + Shift = 7; +var + l : longint; +begin + ASM + MOV EAX,(Number shr (Shift+3)) + mov l,eax + End; + if l<>131071 then + begin + writeln('error in constant eval in intel reader'); + halt(1); + end; +end. \ No newline at end of file diff --git a/tests/webtbs/tw1092.pp b/tests/webtbs/tw1092.pp new file mode 100644 index 0000000000..455c8254d6 --- /dev/null +++ b/tests/webtbs/tw1092.pp @@ -0,0 +1,21 @@ +PROGRAM tbug1092; +USES Dos; +const +{$Ifdef linux} + path='/etc'; +{$else} + path='c:\'; +{$endif} +var + t : text; +BEGIN + { create a file } + assign(t,'tbug1092.txt'); + rewrite(t); + close(t); + if FSearch('tbug1092.txt',path)<>'tbug1092.txt' then + begin + writeln('FSearch didn''t find file in the current dir!'); + halt(1); + end; +END. diff --git a/tests/webtbs/tw1096.pp b/tests/webtbs/tw1096.pp new file mode 100644 index 0000000000..206c783bae --- /dev/null +++ b/tests/webtbs/tw1096.pp @@ -0,0 +1,24 @@ +Program Test; +{$X-} + +Function TestFunc : Boolean; +var b : Boolean; +begin + TestFunc := True; + b := True; + if b then + begin + exit; + end; +end; + +begin + writeln(3 xor 1); + if TestFunc then + begin + writeln('Yo'); + end; +end. + + + diff --git a/tests/webtbs/tw1097.pp b/tests/webtbs/tw1097.pp new file mode 100644 index 0000000000..bd1cbd99bf --- /dev/null +++ b/tests/webtbs/tw1097.pp @@ -0,0 +1,26 @@ +{$H+} + +type + Tsome = Record + One,Two,Three:String; + end; + +Procedure passhere(Some:TSome;onemore:String); +Begin +end; + +procedure fromhere; +Var + me:Tsome; +Begin + me.one:='blah'; + me.two:=''; + me.three:=''; + passhere(Me,'text some'); +end; + +begin + fromhere; +end. + + diff --git a/tests/webtbs/tw1103.pp b/tests/webtbs/tw1103.pp new file mode 100644 index 0000000000..e84690a7f3 --- /dev/null +++ b/tests/webtbs/tw1103.pp @@ -0,0 +1,23 @@ +{$MODE OBJFPC } +type + TestRec = record + fString : AnsiString; + fInt1 : Longint; + fInt2 : Longint; + fRetAddr : Longint; + end; + +function GetGroupInfo: TestRec; +begin + fillchar(Result, Sizeof(Result), 0); + Result.fRetAddr := 0; +end; + +function SelectGroup: TestRec; +begin + Result := GetGroupInfo; +end; + +begin + SelectGroup; +end. diff --git a/tests/webtbs/tw1104.pp b/tests/webtbs/tw1104.pp new file mode 100644 index 0000000000..38c490bfe0 --- /dev/null +++ b/tests/webtbs/tw1104.pp @@ -0,0 +1,14 @@ +var + r1,r2 : extended; + code : integer; +begin + val('.',r1,code); + if r1<>0.0 then + writeln('error with val(".")'); + val('.E',r2,code); + if r2<>0.0 then + writeln('error with val(".E")'); + if (r1<>0.0) or (r2<>0.0) then + halt(1); +end. + diff --git a/tests/webtbs/tw1111.pp b/tests/webtbs/tw1111.pp new file mode 100644 index 0000000000..223352f3fd --- /dev/null +++ b/tests/webtbs/tw1111.pp @@ -0,0 +1,7 @@ +var + v : 0..5; + sMin, sMax : 0..5; // if top of range is less than 32, get compiler Panic +begin + if v in [sMin..sMax] then ; +end. + diff --git a/tests/webtbs/tw1117.pp b/tests/webtbs/tw1117.pp new file mode 100644 index 0000000000..9c441b4823 --- /dev/null +++ b/tests/webtbs/tw1117.pp @@ -0,0 +1,27 @@ +{$asmmode intel} +var + l1,l2 : longint; + +procedure DrawSprite1( spr : longint ); assembler; +asm + mov eax,spr + mov l1, eax +end; + +procedure DrawSprite2( spr : longint ); +begin +asm + mov eax,spr + mov l2,eax +end; +end; + +begin + DrawSprite1(1); + DrawSprite2(1); + if l1<>l2 then + begin + Writeln('Error!'); + halt(1); + end; +end. diff --git a/tests/webtbs/tw1123.pp b/tests/webtbs/tw1123.pp new file mode 100644 index 0000000000..72c7189163 --- /dev/null +++ b/tests/webtbs/tw1123.pp @@ -0,0 +1,30 @@ +TYPE PObj = ^TObj; + TObj = OBJECT + ii : INTEGER; + CONSTRUCTOR Init(i :INTEGER); + DESTRUCTOR Done; + END; + +CONSTRUCTOR TObj.Init(i :INTEGER); +BEGIN + ii := i; +END; + +DESTRUCTOR TObj.Done; +BEGIN +END; + +VAR Obj : ARRAY[1..2] OF TObj; + +BEGIN + Obj[1].Init(10); + WITH Obj[2] DO Init(Obj[1].ii + 1); (* equal Init(0+1) = wrong *) + + Writeln; + Writeln(Obj[1].ii:10); + Writeln(Obj[2].ii:10); + if Obj[2].ii<>11 then + halt(1); + +(* this should report 10 and 11, when ok *) +END. diff --git a/tests/webtbs/tw1124.pp b/tests/webtbs/tw1124.pp new file mode 100644 index 0000000000..bd2385775e --- /dev/null +++ b/tests/webtbs/tw1124.pp @@ -0,0 +1,18 @@ + Type + t1 = record + dummy:integer; + end; + t2 = record + dummy:string; + end; + +operator = (i1,i2:t1) r:boolean; +begin +end; + +operator = (i1,i2:t2) r:boolean; +begin +end; + +begin +end. diff --git a/tests/webtbs/tw1132.pp b/tests/webtbs/tw1132.pp new file mode 100644 index 0000000000..caa7df20ee --- /dev/null +++ b/tests/webtbs/tw1132.pp @@ -0,0 +1,28 @@ +program BugDemo2; + +type + MyRecordType = + record + RecordElement1 : word; + RecordElement2 : word; + end; + +var + MyRecord : MyRecordType; + MyPointer1,MyPointer2 : pointer; + +begin + with MyRecord do + begin + { next statement crashes the compiler } + MyPointer1 := addr(RecordElement2); + + { next statement is OK } + MyPointer2 := addr(MyRecord.RecordElement2); + end; + if MyPointer1<>MyPointer2 then + begin + Writeln('Error with addr() and with statement'); + halt(1); + end; +end. diff --git a/tests/webtbs/tw1133.pp b/tests/webtbs/tw1133.pp new file mode 100644 index 0000000000..016b1968ff --- /dev/null +++ b/tests/webtbs/tw1133.pp @@ -0,0 +1,34 @@ +{$mode objfpc} +type + float = double; + + +function ConvertRealToPixel(Axis : integer; + HelpReal : real) : real; + + begin { function ConvertRealToPixel } + ConvertRealToPixel := HelpReal; + end; { function ConvertRealToPixel } + + +var + HelpFloat1,HelpFloat2,HelpFloat3 : float; + SegmentStartPos : float; + SegmentLength : float; + + +begin + SegmentStartPos := 0.5; + SegmentLength := 0.5; + HelpFloat1 := SegmentStartPos - SegmentLength / 2; + HelpFloat2 := ConvertRealToPixel(1,HelpFloat1); + writeln('Function result = ',HelpFloat2,' This is OK'); + + HelpFloat3 := ConvertRealToPixel(1,SegmentStartPos - SegmentLength / 2); + writeln('Function result = ',HelpFloat3,' THIS IS WRONG !'); + if HelpFloat2<>HelpFloat3 then + begin + Writeln('ERROR!'); + Halt(1); + end; +end. diff --git a/tests/webtbs/tw1152.pp b/tests/webtbs/tw1152.pp new file mode 100644 index 0000000000..c9c3df79aa --- /dev/null +++ b/tests/webtbs/tw1152.pp @@ -0,0 +1,39 @@ +{ Source provided for Free Pascal Bug Report 1152 } +{ Submitted by "Dirk Verwiebe" on 2000-09-30 } +{ e-mail: dirk@verwiebe.de } + +{$mode objfpc} + +program exception; +uses sysutils,crt; +var + saveexit : pointer; + finally_called : boolean; + +procedure my_exit; + begin + exitproc:=saveexit; + if not finally_called then + begin + Writeln('Problem with exception handling if crt unit is used'); + RunError(1); + end + else + begin + Writeln('Exception handling works'); + exitcode:=0; + end; + end; + + +BEGIN + saveexit:=exitproc; + exitproc:=@my_exit; + finally_called:=false; +try + mem[$ffffffff]:=0; +finally + finally_called:=true; + writeln('Error !!!'); +end; +END. \ No newline at end of file diff --git a/tests/webtbs/tw1157.pp b/tests/webtbs/tw1157.pp new file mode 100644 index 0000000000..64ed35b450 --- /dev/null +++ b/tests/webtbs/tw1157.pp @@ -0,0 +1,35 @@ +{ Source provided for Free Pascal Bug Report 1157 } +{ Submitted by "Colin Goldie" on 2000-10-06 } +{ e-mail: Colin_G@Positek.com.au } + +{$asmmode intel} + +Function GetBLUEfromRGB( color : word ) : byte; assembler; +asm + mov cx,color + and cx,0000000000011111b + mov @Result,cl +end; + +{ +Does something weird .. to the stack im guessing ... error 206 and 103 +errors occur 'File not open' ... + +However, if instead of using @Result , i chuck my return value into the +accumulator register , everything thing works hunky dory. +} + +Function GetBLUEfromRGB2( color : word ) : byte; assembler; +asm + mov cx,color + and cx,0000000000011111b + mov al,cl +end; + +begin + if GetBlueFromRGB2($fff)<>GetBlueFromRGB($fff) then + begin + Writeln('Error in assembler statement'); + Halt(1); + end; +end. \ No newline at end of file diff --git a/tests/webtbs/tw1203.pp b/tests/webtbs/tw1203.pp new file mode 100644 index 0000000000..45f3cc7ee6 --- /dev/null +++ b/tests/webtbs/tw1203.pp @@ -0,0 +1,22 @@ +{ Source provided for Free Pascal Bug Report 1203 } +{ Submitted by "Marco van de Voort" on 2000-10-29 } +{ e-mail: marco@freepascal.org } +{$mode Delphi} +type + someprocedureofobjectype=procedure (sender:tobject) OF +OBJECT; + + a=class + protected + fondisplay : someprocedureofobjectype; + end; + + b=class(A) + protected + fondisplay : someprocedureofobjectype; + end; + +begin +end. + + diff --git a/tests/webtbs/tw1204.pp b/tests/webtbs/tw1204.pp new file mode 100644 index 0000000000..46a20525da --- /dev/null +++ b/tests/webtbs/tw1204.pp @@ -0,0 +1,73 @@ +{ Source provided for Free Pascal Bug Report 1204 } +{ Submitted by "Marco van de Voort" on 2000-10-29 } +{ e-mail: marco@freepascal.org } + +Uses Windows,Sysutils,Classes; + +type + TICMPDisplay = procedure(Sender: TObject; Msg : String) of object; + TICMPReply = procedure(Sender: TObject; Error : Integer) of +object; + + // The object wich encapsulate the ICMP.DLL + TICMP = class(TObject) + private + FOnDisplay : TICMPDisplay; // Event handler to +display + public + constructor Create; virtual; + destructor Destroy; override; + property OnDisplay : TICMPDisplay read FOnDisplay write +FOnDisplay; + end; + + TPingDisplay = procedure(Sender: TObject; Icmp: TObject; Msg : +String) of object; + + + TPing = class(TComponent) + private + FIcmp : TICMP; + FOnDisplay : TPingDisplay; + protected + procedure IcmpDisplay(Sender: TObject; Msg: String); + + public + constructor Create(Owner : TComponent); override; + destructor Destroy; override; + property OnDisplay : TPingDisplay read FOnDisplay + write FOnDisplay; + + end; + +constructor TICMP.Create; +begin +end; + +destructor TICMP.Destroy; +begin +end; + +constructor TPing.Create(Owner : TComponent); +begin + Inherited Create(Owner); + FIcmp := TICMP.Create; + FIcmp.OnDisplay := IcmpDisplay; +end; + + +{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +* * *} +destructor TPing.Destroy; +begin +end; + +procedure TPing.IcmpDisplay(Sender: TObject; Msg: String); +begin + if Assigned(FOnDisplay) then + FOnDisplay(Self, Sender, Msg); +end; + +begin +end. + diff --git a/tests/webtbs/tw1250.pp b/tests/webtbs/tw1250.pp new file mode 100644 index 0000000000..6daef31b1f --- /dev/null +++ b/tests/webtbs/tw1250.pp @@ -0,0 +1,17 @@ +uses classes; + +var list : TStringList; + +begin + list := TStringList.Create; + try + list.commatext := '"0","6","-1"'; + writeln ('---'); + writeln (list.text); + writeln ('---'); + finally + list.Free; + writeln ('Freeing list'); + end; +end. + diff --git a/tests/webtbs/tw1251a.pp b/tests/webtbs/tw1251a.pp new file mode 100644 index 0000000000..cdd7d48b4c --- /dev/null +++ b/tests/webtbs/tw1251a.pp @@ -0,0 +1,10 @@ +{$mode objfpc} + +begin + try + writeln ('Start: create game object'); + except + on e : exception do + writeln ('Exception: ', e.message); + end; +end. diff --git a/tests/webtbs/tw1251b.pp b/tests/webtbs/tw1251b.pp new file mode 100644 index 0000000000..3f2dbc5be0 --- /dev/null +++ b/tests/webtbs/tw1251b.pp @@ -0,0 +1,5 @@ +program strings; + +uses classes; + +var list : TStringList; diff --git a/tests/webtbs/tw1255.pp b/tests/webtbs/tw1255.pp new file mode 100644 index 0000000000..81afa68d33 --- /dev/null +++ b/tests/webtbs/tw1255.pp @@ -0,0 +1,27 @@ +{$mode objfpc} +uses + sysutils; + +procedure testff(const s: string); +var + sr: tsearchrec; + i : integer; +begin + i:=0; + if findfirst(s,faAnyFile,sr)=0 then + repeat + writeln(sr.name); + inc(i); + until findnext(sr)<>0; + findclose(sr); + if (i=0) then + halt(1); +end; + +begin +{$ifdef UNIX} + testff('/etc/host*'); +{$else} + testff('c:\autoexec.*'); +{$endif} +end. diff --git a/tests/webtbs/tw555.pp b/tests/webtbs/tw555.pp new file mode 100644 index 0000000000..6b3d5553b5 --- /dev/null +++ b/tests/webtbs/tw555.pp @@ -0,0 +1,50 @@ +{ FPC behaves interestingly once encountered virtual method + declared as + procedure TWhateverObject.Method1; assembler; asm ... end; + if you ever try to overload such method _in another unit_, + than compile _second unit_, and than try to compile it again (???)- + you will end up with the message "Function header does not match + forward declaration of TNewObject.Method1" although in reality + it does match perfectly. + sometimes i encounter the same message even on non-assembler methods, + but i have not been able to reproduce them cleanly nor find the + reason for such behavior.} + + unit tbug555; + + + interface + uses + tbug555a; + + type + TBugObjChild = Object(TBugObj) + procedure Method1; + procedure Method2;virtual; + procedure Method3; + procedure Method4;virtual; + end; + + implementation + + procedure TBugObjChild.Method1; + begin + end; + + procedure TBugObjChild.Method2; + begin + end; + +{$ASMMODE ATT} + procedure TBugObjChild.Method3;assembler; + asm + movl $1,%eax + end; + + procedure TBugObjChild.Method4;assembler; + asm + movl $1,%eax + end; + + +end. diff --git a/tests/webtbs/tw555a.pp b/tests/webtbs/tw555a.pp new file mode 100644 index 0000000000..1ee2a0c520 --- /dev/null +++ b/tests/webtbs/tw555a.pp @@ -0,0 +1,57 @@ +{ FPC behaves interestingly once encountered virtual method + declared as + procedure TWhateverObject.Method1; assembler; asm ... end; + if you ever try to overload such method _in another unit_, + than compile _second unit_, and than try to compile it again (???)- + you will end up with the message "Function header does not match + forward declaration of TNewObject.Method1" although in reality + it does match perfectly. + sometimes i encounter the same message even on non-assembler methods, + but i have not been able to reproduce them cleanly nor find the + reason for such behavior.} + + unit tbug555a; + + interface + + type + + TBugObj = Object + constructor Init; + procedure Method1; + procedure Method2;virtual; + procedure Method3; + procedure Method4;virtual; + destructor Done;virtual; + end; + + implementation + + Constructor TBugObj.Init; + begin + end; + +{$ASMMODE ATT} + procedure TBugObj.Method1;assembler; + asm + movl $1,%eax + end; + + procedure TBugObj.Method2;assembler; + asm + movl $1,%eax + end; + + procedure TBugObj.Method3; + begin + end; + + procedure TBugObj.Method4; + begin + end; + + Destructor TBugObj.Done; + begin + end; + +end. diff --git a/tests/webtbs/tw630.pp b/tests/webtbs/tw630.pp new file mode 100644 index 0000000000..3c9438fc04 --- /dev/null +++ b/tests/webtbs/tw630.pp @@ -0,0 +1,34 @@ +{ Program 1 : memory waste + dummy test } + +USES SysUtils; + +procedure test_it; +var + sRec : TSearchRec; +begin + writeln(memAvail); + findFirst('c:\*.*',faVolumeId,sRec); + findClose(sRec); + writeln(sRec.name); + writeln(memAvail); { 288 bytes waste ! } +end; + +begin + Writeln('Before call ',MemAvail); + test_it; + Writeln('After call : ',MemAvail); +end. +(*{ Program 2 : correct } + +USES Dos; + +var + sRec : searchRec; +begin + writeln(memAvail); + findFirst('c:\*.*',volumeid,sRec); + findClose(sRec); + writeln(sRec.name); + writeln(memAvail); { no memory waste ! } +end. *) diff --git a/tests/webtbs/tw701a.pp b/tests/webtbs/tw701a.pp new file mode 100644 index 0000000000..ce4b214a9b --- /dev/null +++ b/tests/webtbs/tw701a.pp @@ -0,0 +1,18 @@ +var + s : string; + + procedure UseString(const as : string); + begin + s:=as; + end; + + procedure MyExit; + begin + Writeln('Last call to UseString was with as = ',s); + end; + +begin + exitproc:=@MyExit; + UseString('Dummy test'); +end. + diff --git a/tests/webtbs/tw701b.pp b/tests/webtbs/tw701b.pp new file mode 100644 index 0000000000..55d2b0de59 --- /dev/null +++ b/tests/webtbs/tw701b.pp @@ -0,0 +1,6 @@ +program memhole; +uses tbug701d,tbug701e,tbug701c; +begin + // the tbug701c is to be on the save side + tbug701c.TestProc('test'); +end. diff --git a/tests/webtbs/tw701c.pp b/tests/webtbs/tw701c.pp new file mode 100644 index 0000000000..8c9a84ffe9 --- /dev/null +++ b/tests/webtbs/tw701c.pp @@ -0,0 +1,22 @@ +unit tbug701c; + + interface + procedure TestProc(arg: AnsiString); + + var + s1: array[0..9] of AnsiString; + implementation + + var + s2: array[0..9] of AnsiString; + + procedure TestProc(arg: AnsiString); + + begin + s1[0] := arg + '!s10'; + s1[3] := arg + '!s13'; + s2[4] := arg + '!s24'; + s2[7] := arg + '!s27'; + end; + +end. diff --git a/tests/webtbs/tw701d.pp b/tests/webtbs/tw701d.pp new file mode 100644 index 0000000000..fd867522b7 --- /dev/null +++ b/tests/webtbs/tw701d.pp @@ -0,0 +1,18 @@ +unit tbug701d; + + interface + + implementation + +var + startmem : longint; + +initialization + startmem:=memavail; +finalization + if startmem<>memavail then + begin + writeln('Problem with ansistrings in units'); + halt(1); + end; +end. diff --git a/tests/webtbs/tw701e.pp b/tests/webtbs/tw701e.pp new file mode 100644 index 0000000000..36a114d7e3 --- /dev/null +++ b/tests/webtbs/tw701e.pp @@ -0,0 +1,25 @@ +unit tbug701e; + + interface + + procedure TestProc(arg: AnsiString); + + var + s1: array[0..9] of AnsiString; + + implementation + + var + s2: array[0..9] of AnsiString; + + procedure TestProc(arg: AnsiString); + + begin + s1[0] := arg + '!s10'; + s1[3] := arg + '!s13'; + s2[4] := arg + '!s24'; + s2[7] := arg + '!s27'; + end; +initialization +finalization +end. diff --git a/tests/webtbs/tw711.pp b/tests/webtbs/tw711.pp new file mode 100644 index 0000000000..0e23674399 --- /dev/null +++ b/tests/webtbs/tw711.pp @@ -0,0 +1,78 @@ +program TestGetPutim; {Compiled with the 0.99.13 version under GO32V2!} + + + +uses +{$ifdef go32v2} + dpmiexcp, +{$endif go32v2} + graph; + + + + + +var graphdriver,graphmode :integer; + + imsize:longint; + + im:pointer; + + + +begin +{$ifdef win32} + graphdriver:=VGA; + graphmode:=detect; +{$else not win32} + graphdriver:=VESA; + graphmode:=$103; +{$endif} + Initgraph(graphdriver,graphmode,''); + + {************} +(* + setcolor(6); + + moveto(0,0); {Some drawing} + + lineto(500,500); + + circle(95,95,80); + +{************} + + + +{!!!!!!!!!!!!} + + imsize:= imagesize(0,0,300,300); {This is the part we have problem with.} + + getmem(im,imsize); {The result we get after PutImage is} + + getimage(0,0,300,300,im^); {chaotic independently from the graphmode!} + + putimage(50,50,im^,0); {We tested this on a S3Trio 3D videcard,} + + {which is VESA compatible.} + +{!!!!!!!!!!!!} + + + +readln; + {repeat until keypressed;} + *) + closegraph; + +end. + +{ + + I. Groma + + groma@metal.elte.hu + + Budapest 11/24/1999 + +} diff --git a/tests/webtbs/tw719.pp b/tests/webtbs/tw719.pp new file mode 100644 index 0000000000..259864ecf1 --- /dev/null +++ b/tests/webtbs/tw719.pp @@ -0,0 +1,17 @@ +uses + sysutils; + +var + S : string; + SR : TSearchRec; + r : longint; +begin +r:=FindFirst('*.*',faAnyFile,SR); +while r=0 do + begin + S:=DateTimeToStr(FileDateToDateTime(FileAge(SR.Name))); + Writeln(SR.Name,' has Date ',S); + r:=FindNext(SR); + end; +FindClose(SR); +end. diff --git a/tests/webtbs/tw735.pp b/tests/webtbs/tw735.pp new file mode 100644 index 0000000000..67583dfb00 --- /dev/null +++ b/tests/webtbs/tw735.pp @@ -0,0 +1,25 @@ +{$asmmode intel} +{$inline on} + +procedure DoIt; +begin + Writeln('DoIt was called'); +end; + +const + CB : word = 5; + +procedure A(B: word); assembler; inline; +asm + MOV AX,B + CMP AX,[CB] + JZ @OK + MOV [CB],AX + CALL DoIt +@OK: { <-- creates labels with same name } +end; + +begin + A(5); + A(8); +end. diff --git a/tests/webtbs/tw736.pp b/tests/webtbs/tw736.pp new file mode 100644 index 0000000000..8b8f7bb2fe --- /dev/null +++ b/tests/webtbs/tw736.pp @@ -0,0 +1,130 @@ +{$ifdef FPC} +{$ASMMODE INTEL} +{$INLINE ON} +{$endif FPC} + +program test; + +type + tobj = object + x : word; + constructor init; + procedure test;virtual; + procedure testx; + end; + +constructor tobj.init; +begin + x:=1; +end; + +procedure tobj.testx; +begin + asm + mov ax,3 + mov word ptr[x],ax + end; +end; + +procedure tobj.test; +var + pattern: word; + dummyval : word; + + function rotate: boolean; assembler; {$ifdef FPC}inline;{$endif FPC} + asm + mov al,0 + rol word ptr [pattern],1 + rcl al,1 + end; + +{ this does still not work because + it can only work as inline not as normal sub function + because dummyval and pattern are not reachable !! PM + function rotateb(dummy : byte) : boolean; assembler; inline; + asm + movzx byte ptr [dummy],ax + mov ax,word ptr [dummyval] + mov al,0 + rol word ptr [pattern],1 + rcl al,1 + end; } + +var + i : byte; + +begin + pattern:= $a0a0; + for i:=1 to 16 do + begin + Write('obj pattern = ', + {$ifdef FPC} + hexstr(pattern,4),' '); + {$else} + pattern,' '); + {$endif} + if rotate then + Writeln('bit found') + else + Writeln('no bit found'); + end; +end; + +procedure changepattern; +var + pattern: word; + dummyval : word; + + function rotate: boolean; assembler; {$ifdef FPC}inline;{$endif FPC} + asm + mov al,0 + rol word ptr [pattern],1 + rcl al,1 + end; + +{ this does still not work because + it can only work as inline not as normal sub function + because dummyval and pattern are not reachable !! PM + function rotateb(dummy : byte) : boolean; assembler; inline; + asm + movzx byte ptr [dummy],ax + mov ax,word ptr [dummyval] + mov al,0 + rol word ptr [pattern],1 + rcl al,1 + end; } + +var + i : byte; + +begin + pattern:= $a0a0; + for i:=1 to 16 do + begin + Write('pattern = ', + {$ifdef FPC} + hexstr(pattern,4),' '); + {$else} + pattern,' '); + {$endif} + if rotate then + Writeln('bit found') + else + Writeln('no bit found'); + end; +end; + +var + + t : tobj; +begin + changepattern; + t.init; + t.test; + t.testx; + if t.x<>3 then + begin + Writeln('Unable to access object fields in assembler'); + Halt(1); + end; +end. \ No newline at end of file diff --git a/tests/webtbs/tw738.pp b/tests/webtbs/tw738.pp new file mode 100644 index 0000000000..727dc18cf9 --- /dev/null +++ b/tests/webtbs/tw738.pp @@ -0,0 +1,15 @@ +{$mode delphi} + +type + (* + {$IFDEF FPK} + SomeClass = class; { this line shouldn't be necessary } + {$ENDIF} + *) + + SomeClass = class + SomeMember:SomeClass; + end; + +begin +end. diff --git a/tests/webtbs/tw739.pp b/tests/webtbs/tw739.pp new file mode 100644 index 0000000000..fe8d1663bb --- /dev/null +++ b/tests/webtbs/tw739.pp @@ -0,0 +1,13 @@ +{$mode delphi} + +type +(* {$IFDEF FPK} + y = class; { shouldn't be necessary } +{$ENDIF} *) + x = class of y; + y = class + z:Boolean; + end; + +begin +end. diff --git a/tests/webtbs/tw748.pp b/tests/webtbs/tw748.pp new file mode 100644 index 0000000000..041c43f531 --- /dev/null +++ b/tests/webtbs/tw748.pp @@ -0,0 +1,4 @@ +begin + writeln('Hello World'); +end. +{this comment produces Unexpected end of file} diff --git a/tests/webtbs/tw751.pp b/tests/webtbs/tw751.pp new file mode 100644 index 0000000000..32eccc6d1d --- /dev/null +++ b/tests/webtbs/tw751.pp @@ -0,0 +1,6 @@ +var x,y:integer; +begin + +y:=5; +for x:=0 to 10 do if x0 then + begin + val(paramstr(1),count,error); + if error = 0 then + Max:=count; + count:=0; + end; + + for i:=1 to Max do + begin + str(i,s); + s:='file'+s+'.tmp'; + assign(f[i],s); + rewrite(f[i]); + count:=i; + Writeln(f[i],'This is file ',i); + Writeln(i,' files open'); + { no closing so they are finally all open } + end; + + for i:=Max downto 1 do + begin + close(f[i]); + erase(f[i]); + end; +end. diff --git a/tests/webtbs/tw755.pp b/tests/webtbs/tw755.pp new file mode 100644 index 0000000000..aae8e90c83 --- /dev/null +++ b/tests/webtbs/tw755.pp @@ -0,0 +1,40 @@ +type + de10_eqn_vector = array [1..10] of double; + de10_func = function : double; + de10func = de10_func; + DE10_PHI_ARRAY = array[1..10] of double; + DE10phiarray = DE10_PHI_ARRAY; + de10eqnvec = de10_eqn_vector; + de10_12_vector = array [10..12] of double; + de10_13_vector = array [10..13] of double; + de1012vec = de10_12_vector; + de1013vec = de10_13_vector; + +PROCEDURE Step10( VAR X : double; VAR Y : + DE10_EQN_VECTOR; F10 : DE10_FUNC; VAR NEQN : INTEGER; VAR H : double; VAR + EPS : double; VAR WT : DE10_EQN_VECTOR; VAR START : BOOLEAN; VAR HOLD : + double; VAR K : INTEGER; VAR KOLD : INTEGER; VAR CRASH : BOOLEAN; VAR PHI : + DE10_PHI_ARRAY; VAR P : DE10_EQN_VECTOR; VAR YP : DE10_EQN_VECTOR; + VAR PSI : DE10_12_VECTOR; VAR ALPHA : DE10_12_VECTOR; VAR BETA : + DE10_12_VECTOR; VAR SIG : DE10_13_VECTOR; VAR V : DE10_12_VECTOR; VAR W + : DE10_12_VECTOR; VAR G : DE10_13_VECTOR; VAR PHASE1 : BOOLEAN; VAR NS : + INTEGER; VAR NORND : BOOLEAN ); + begin + end; + +PROCEDURE Step11( VAR X : double; VAR Y : DE10EQNVEC; F10 : DE10FUNC; VAR + NEQN : INTEGER; VAR H : double; VAR EPS : double; VAR WT : DE10EQNVEC; VAR + START : BOOLEAN; VAR HOLD : double; VAR K : INTEGER; VAR KOLD : INTEGER; + VAR CRASH : BOOLEAN; VAR PHI : DE10PHIARRAY; VAR P : DE10EQNVEC; VAR YP + : DE10EQNVEC; VAR PSI : DE1012VEC; VAR ALPHA : DE1012VEC; VAR BETA : + DE1012VEC; VAR SIG : DE1013VEC; VAR V : DE1012VEC; VAR W : DE1012VEC; VAR + G : DE1013VEC; VAR PHASE1 : BOOLEAN; VAR NS : INTEGER; VAR NORND : + BOOLEAN ); + + begin + end; + + + +begin +end. diff --git a/tests/webtbs/tw760.pp b/tests/webtbs/tw760.pp new file mode 100644 index 0000000000..e58913f651 --- /dev/null +++ b/tests/webtbs/tw760.pp @@ -0,0 +1,32 @@ +type TElement = object + constructor Init; + {something} + destructor Free; virtual; + destructor Done; virtual; + end; + +constructor TElement.Init; +begin + Writeln('Init called'); +end; + +destructor TElement.free; +begin + Writeln('Free used'); +end; + +destructor TElement.Done; +begin + Writeln('Done used'); +end; + +var + E : TElement; + PE : ^TElement; + +begin + E.init; + E.Free; + new(PE,init); + dispose(PE,Done); +end. diff --git a/tests/webtbs/tw761.pp b/tests/webtbs/tw761.pp new file mode 100644 index 0000000000..1adf5d608d --- /dev/null +++ b/tests/webtbs/tw761.pp @@ -0,0 +1,14 @@ +{$asmmode intel} +Type TFather = Object A : Integer; end; + TSon = Object (TFather) B : Integer; end; + +Var Son : TSon; + +begin + Asm + mov ax, Son.A + mov ax, Son.B + end; +end. + + diff --git a/tests/webtbs/tw769.pp b/tests/webtbs/tw769.pp new file mode 100644 index 0000000000..6cadf19112 --- /dev/null +++ b/tests/webtbs/tw769.pp @@ -0,0 +1,9 @@ + +Program test; + +var x,y:integer; + +begin +y:=5; +for x:=0 to 10 do if x4 then + Halt(1); + close(t); +end. \ No newline at end of file diff --git a/tests/webtbs/tw776.pp b/tests/webtbs/tw776.pp new file mode 100644 index 0000000000..fe918a1102 --- /dev/null +++ b/tests/webtbs/tw776.pp @@ -0,0 +1,16 @@ +{$mode objfpc} +uses sysutils; + var i:integer; + j : record + x,y : longint; + end; +begin + i:=0; + format('%d', [i]); + with j do + begin + x:=2; + y:=4; + Writeln('j.x=',x,' j.y=',y); + end; +end. \ No newline at end of file diff --git a/tests/webtbs/tw784.pp b/tests/webtbs/tw784.pp new file mode 100644 index 0000000000..f1fe396511 --- /dev/null +++ b/tests/webtbs/tw784.pp @@ -0,0 +1,27 @@ +{$R-} +{ should compile if no range check on } +program BigRange; + +const + Limit = 100000000; { Hundred millions } + One = 1; + +var + Huge: longint; + +begin + Huge := Limit + One; + + writeln(One, ' is the lower bound'); + writeln(Limit, ' is the upper bound'); + + if Limit in [One .. Limit] then + writeln(Limit, ' is within the range') + else + writeln(Limit, ' is out of the range'); + + if Huge in [One .. Limit] then + writeln(Huge, ' is within the range') + else + writeln(Huge, ' is out of the range') +end. diff --git a/tests/webtbs/tw788.pp b/tests/webtbs/tw788.pp new file mode 100644 index 0000000000..7616f08efa --- /dev/null +++ b/tests/webtbs/tw788.pp @@ -0,0 +1,68 @@ +{$ifdef FPC} +Uses Math; + +{$else not FPC} +function degtorad(deg : extended) : extended; + + begin + degtorad:=deg*(pi/180.0); + end; + +function radtodeg(rad : extended) : extended; + + begin + radtodeg:=rad*(180.0/pi); + end; + + function ArcSin(x : extended) : extended; + begin + if abs(x)=1.0 then + arcsin:=Pi/2 + else + arcsin:=ArcTan(x/sqrt(1-x*x)); + end; + function ArcTan2(x,y : extended) : extended; + begin + ArcTan2:=ArcTan(x/y); + end; +{$endif not FPC} + +Var + I : Integer; + RI,RRI,R0 : extended; + +Begin + For I := -179 To 179 Do + Begin + RI:=I; + WriteLn( RadToDeg(ArcSin(Sin(DegToRad(RI)))):3:18); + End; + For I := -89 To 89 Do + Begin + RI:=I; + RRI:=RadToDeg(ArcSin( Sin(DegToRad(RI)))); + WriteLn(RI:3:18,' ',RRI:3:18); + If RI<>RRI then + begin + Writeln('Not exact ',RRI-RI:3:18); + if I<>0 then + begin + Writeln('Percentage error = ',Abs(RRI -RI) *100 / I:3:18); + if abs((RRI -RI) *100 / I)>0.0001 then + Begin + Writeln('Error too big '); + Halt(1); + end; + end; + end; + End; + RI:=3; + RRI:=1; + R0:=1; + Writeln( ArcTan2(ArcTan2(1,1),R0):3:18 , ' should be 0.66577375...'); + if ArcTan2(ArcTan2(1,1),R0)<>ArcTan(ArcTan(1)/R0) then + begin + Writeln('There is still a bug in ArcTan2 !'); + Halt(1); + end; +End. \ No newline at end of file diff --git a/tests/webtbs/tw789.pp b/tests/webtbs/tw789.pp new file mode 100644 index 0000000000..19aba4225d --- /dev/null +++ b/tests/webtbs/tw789.pp @@ -0,0 +1,14 @@ +{$MODE DELPHI} + +uses sysutils; + +procedure tt (params : array of const); +begin +// this call generate Access violation + writeln (Format ('Params test %d', params)); +end; + +begin + writeln (Format ('First test %d', [1])); + tt ([1]); +end. \ No newline at end of file diff --git a/tests/webtbs/tw793.pp b/tests/webtbs/tw793.pp new file mode 100644 index 0000000000..cdabffc839 --- /dev/null +++ b/tests/webtbs/tw793.pp @@ -0,0 +1,29 @@ +{$MODE Delphi} + +program bug; +type + +TMyObject = class + public + constructor Create; virtual; + constructor Init; +end; + +var + M: TMyObject; + + +constructor TMyObject.Create; +begin + Writeln('Now executing TmyObject.Create'); +end; + +constructor TMyObject.Init; +begin + Create; + Writeln('Now finishing the INIT constructor.'); +end; + +begin + M := TMyObject.Init; +end. \ No newline at end of file diff --git a/tests/webtbs/tw797.pp b/tests/webtbs/tw797.pp new file mode 100644 index 0000000000..251ba8b215 --- /dev/null +++ b/tests/webtbs/tw797.pp @@ -0,0 +1,30 @@ +program test; +{$INLINE ON} + +var + s2 : string; + j : longint; + + procedure Tst(s: ShortString;var j : longint); inline; + var + i : longint; + begin + s:=s + ' Yes'; + i:=5; + j:=j+i; + WriteLn(s); + s2:=s; + end; +begin + s2:='Before inline'; + j:=5; + Tst('Hello Hello Hello',j); + if (s2<>'Hello Hello Hello Yes') or (j<>10) then + begin + if (s2<>'Hello Hello Hello Yes') then + writeln('s2 = ',s2); + if (j<>10) then + writeln('j = ',s2); + halt(1); + end; +end. \ No newline at end of file diff --git a/tests/webtbs/tw797a.pp b/tests/webtbs/tw797a.pp new file mode 100644 index 0000000000..464dd5466f --- /dev/null +++ b/tests/webtbs/tw797a.pp @@ -0,0 +1,26 @@ +program test; +{$INLINE ON} +{$ASMMODE ATT} + +var + j : longint; + + procedure Tst(var j : longint); assembler;inline; + var + i : longint; + asm + movl j,%ebx + movl (%ebx),%eax + movl $5,i + addl i,%eax + movl %eax,(%ebx) + end; + +begin + j:=5; + Tst(j); + if (j<>10) then + begin + halt(1); + end; +end. \ No newline at end of file diff --git a/tests/webtbs/tw801.pp b/tests/webtbs/tw801.pp new file mode 100644 index 0000000000..f5b8ba4e4e --- /dev/null +++ b/tests/webtbs/tw801.pp @@ -0,0 +1,12 @@ +program WrongHint; +type + PRecord = ^TRecord; + TRecord = record + end; +var + x: PRecord; +begin + + New(x); + Dispose(x); +end. \ No newline at end of file diff --git a/tests/webtbs/tw802.pp b/tests/webtbs/tw802.pp new file mode 100644 index 0000000000..e409ef0cf4 --- /dev/null +++ b/tests/webtbs/tw802.pp @@ -0,0 +1,9 @@ +program test; + function testf (a:byte;b:integer;c:char):char; + begin + testf:=c; + end; +begin + writeln('"',testf(0,-1,'A'),'"'); +end. + diff --git a/tests/webtbs/tw803.pp b/tests/webtbs/tw803.pp new file mode 100644 index 0000000000..90a9ca1a43 --- /dev/null +++ b/tests/webtbs/tw803.pp @@ -0,0 +1,17 @@ +{$MODE objfpc} +program FileExc; +uses SysUtils, Classes; +var + f: TFileStream; +begin + try + f := TFileStream.Create('a nonexistent file', fmOpenRead); + except + on e: Exception do begin + f.Free; + halt(0); + end; + end; + writeln('Error'); + halt(1); +end. diff --git a/tests/webtbs/tw809.pp b/tests/webtbs/tw809.pp new file mode 100644 index 0000000000..70df392bd9 --- /dev/null +++ b/tests/webtbs/tw809.pp @@ -0,0 +1,7 @@ +PROGRAM Test; + +USES Tbug809a; + +BEGIN + Schreib('Test'); +END. \ No newline at end of file diff --git a/tests/webtbs/tw809a.pp b/tests/webtbs/tw809a.pp new file mode 100644 index 0000000000..24890cfcd4 --- /dev/null +++ b/tests/webtbs/tw809a.pp @@ -0,0 +1,14 @@ +UNIT tbug809a; + +INTERFACE + + PROCEDURE Schreib(st : STRING); + +IMPLEMENTATION + +PROCEDURE Schreib(st : STRING); +BEGIN + WriteLn(st); +END; + +END. \ No newline at end of file diff --git a/tests/webtbs/tw810.pp b/tests/webtbs/tw810.pp new file mode 100644 index 0000000000..c64c972128 --- /dev/null +++ b/tests/webtbs/tw810.pp @@ -0,0 +1,13 @@ +program bug; +var i:byte; + e:extended; + s:string; +begin +e:=103; (*1003,100003,1000003*) +for i:=0 to 17 do + begin + str(e:0:i,s); + writeln(s); + end; + +end. \ No newline at end of file diff --git a/tests/webtbs/tw812.pp b/tests/webtbs/tw812.pp new file mode 100644 index 0000000000..3013983254 --- /dev/null +++ b/tests/webtbs/tw812.pp @@ -0,0 +1,26 @@ +program TestVm2; + +{$IFDEF WIN32}{$APPTYPE CONSOLE}{$ENDIF} + +procedure Test; +var + P: Pointer; +begin + P:=nil; + ReAllocMem(P, 8); + ReAllocMem(P, 0); +end; + +var MemBefore : longint; +begin + writeln(MemAvail); + MemBefore:=MemAvail; + Test; + writeln(MemAvail); + if MemBefore<>MemAvail then + begin + Writeln('ReAllocMem creates emory leaks'); + Writeln('Bug 812 is not yet fixed'); + Halt(1); + end; +end. \ No newline at end of file diff --git a/tests/webtbs/tw813.pp b/tests/webtbs/tw813.pp new file mode 100644 index 0000000000..78bf249b90 --- /dev/null +++ b/tests/webtbs/tw813.pp @@ -0,0 +1,31 @@ +program TestVm2; + +{$IFDEF WIN32}{$APPTYPE CONSOLE}{$ENDIF} + +procedure Test; +var + P: Pointer; +begin + P:=nil; + ReAllocMem(P, 8); + ReAllocMem(P, 0); + if P<>nil then + begin + Writeln('ReAllocMem wtih zero size does not set pointer to nil'); + Writeln('Bug 813 is not yet fixed'); + Halt(1); + end; +end; + +var MemBefore : longint; +begin + writeln(MemAvail); + MemBefore:=MemAvail; + Test; + writeln(MemAvail); + if MemBefore<>MemAvail then + begin + Writeln('ReAllocMem creates emory leaks'); + Writeln('Bug 812 is not yet fixed'); + end; +end. \ No newline at end of file diff --git a/tests/webtbs/tw814.pp b/tests/webtbs/tw814.pp new file mode 100644 index 0000000000..2b42a75ea1 --- /dev/null +++ b/tests/webtbs/tw814.pp @@ -0,0 +1,5 @@ +const + MaxFloat80 = 1.1E+4932; +begin + Writeln(MaxFloat80); +end. \ No newline at end of file diff --git a/tests/webtbs/tw815.pp b/tests/webtbs/tw815.pp new file mode 100644 index 0000000000..ad1aee05ef --- /dev/null +++ b/tests/webtbs/tw815.pp @@ -0,0 +1,10 @@ +{$mode delphi} + +function T: Integer; +begin + for Result:=0 to 10 do ; +end; + +begin + T; +end. \ No newline at end of file diff --git a/tests/webtbs/tw816.pp b/tests/webtbs/tw816.pp new file mode 100644 index 0000000000..a950bacf98 --- /dev/null +++ b/tests/webtbs/tw816.pp @@ -0,0 +1,24 @@ +uses graph; +var + gd,gm:integer; + testimage:array[1..50000] of byte; {this is plenty big} +begin + gd:=VESA; + gm:=$100; { 640 x 400 x 256 } + initgraph(gd,gm,''); + if graphresult<>grOk then + begin + Writeln('Unable to open driver ',gd,' in mode ',gm); + Halt(1); + end; + line(0,0,639,399); + getimage(190,49,257,125,testimage); + { a simple statement, and yet + it throws a General Protection fault, but only with certain + numbers for getimage. The numbers i have here do not produce + too big an image for the array testimage, and yet it faults. + Is this a bug in getimage, or is there something i am + missing here? + } + closegraph; +end. \ No newline at end of file diff --git a/tests/webtbs/tw819.pp b/tests/webtbs/tw819.pp new file mode 100644 index 0000000000..4116232ece --- /dev/null +++ b/tests/webtbs/tw819.pp @@ -0,0 +1,27 @@ +{$mode objfpc} +type + T1 = class + function Get(I: Integer): Integer; virtual; abstract; + property T[I: Integer]: Integer read Get; default; + end; + + T2 = class(T1) + function Get(I: Integer): Integer; override; + property T[I: Integer]: Integer read Get; default; + end; + +function T2.Get(I: Integer): Integer; +begin + Result:=I; +end; + +var + c2 : t2; + +begin + c2:=t2.create; + if c2[9]<>9 then + halt(1) + else + halt(0); +end. diff --git a/tests/webtbs/tw825.pp b/tests/webtbs/tw825.pp new file mode 100644 index 0000000000..5499e320d7 --- /dev/null +++ b/tests/webtbs/tw825.pp @@ -0,0 +1,39 @@ +{$mode tp} +{ args for destructors + are allowed in TP mode for compatibility only PM } + +program test_destructor_with_args; + +var + z : longint; + + type + tt = object + constructor dummy; + destructor done(x : longint);virtual; + end; + + constructor tt.dummy; + begin + end; + + destructor tt.done; + begin + Writeln('x in tt.done is ',x); + z:=x; + end; + + var + pt : ^tt; + +begin + Writeln('ln(5)=',ln(5)); + new(pt,dummy); + pt^.done(4); + if z<>4 then + Halt(1); + pt^.dummy; + dispose(pt,done(5)); + if z<>5 then + Halt(1); +end. \ No newline at end of file diff --git a/tests/webtbs/tw839.pp b/tests/webtbs/tw839.pp new file mode 100644 index 0000000000..6b51019d9f --- /dev/null +++ b/tests/webtbs/tw839.pp @@ -0,0 +1,18 @@ +{$mode tp} +program notcom; + +type demo=object + constructor init; + destructor done(x:longint); + end; + +constructor demo.init; +begin +end; + +destructor demo.done(x:longint); +begin +end; + +begin +end. \ No newline at end of file diff --git a/tests/webtbs/tw840.pp b/tests/webtbs/tw840.pp new file mode 100644 index 0000000000..35f7eb6319 --- /dev/null +++ b/tests/webtbs/tw840.pp @@ -0,0 +1,24 @@ +{$mode TP} + +program tbug840; + +uses tbug840a; + +begin +tbug840b.i:=1; +end. + +----------------------------- cut here ---------------------------------------- +unit ua; + +interface +uses ub; +implementation +end. +----------------------------- cut here ---------------------------------------- +unit ub; + +interface +var i:longint; +implementation +end. \ No newline at end of file diff --git a/tests/webtbs/tw840a.pp b/tests/webtbs/tw840a.pp new file mode 100644 index 0000000000..83180d1905 --- /dev/null +++ b/tests/webtbs/tw840a.pp @@ -0,0 +1,6 @@ +unit tbug840a; + +interface +uses tbug840b; +implementation +end. diff --git a/tests/webtbs/tw840b.pp b/tests/webtbs/tw840b.pp new file mode 100644 index 0000000000..eaf502988c --- /dev/null +++ b/tests/webtbs/tw840b.pp @@ -0,0 +1,6 @@ +unit tbug840b; + +interface +var i:longint; +implementation +end. \ No newline at end of file diff --git a/tests/webtbs/tw848.pp b/tests/webtbs/tw848.pp new file mode 100644 index 0000000000..378fe7fa99 --- /dev/null +++ b/tests/webtbs/tw848.pp @@ -0,0 +1,28 @@ +{$ASMMODE INTEL} + +PROCEDURE a; +VAR v,v2,v3:integer; + + PROCEDURE b;assembler; + ASM + MOV AX,v + mov v2,AX + mov EDI,0 + MOV AX,[EDI+v] + MOV AX,[EBP+OFFSET v] + MOV v3,AX + END; + +BEGIN + v:=5; + v2:=4; + v3:=0; + b; + if (v2<>v) or (v3<>v) then + Halt(1); +END; + +begin + a; + Writeln('Program works'); +end. \ No newline at end of file diff --git a/tests/webtbs/tw852.pp b/tests/webtbs/tw852.pp new file mode 100644 index 0000000000..07fa3d2e27 --- /dev/null +++ b/tests/webtbs/tw852.pp @@ -0,0 +1,13 @@ +type + TFloat80Array = array [0..1000000] of Extended; + +procedure AddFloat80Proc(var Vector1; const Vector2; Count: Integer); +var + I: Integer; +begin + for I:=0 to Count - 1 do + TFloat80Array(Vector1)[I]:=TFloat80Array(Vector1)[I] + TFloat80Array(Vector2)[I]; +end; + +begin +end. diff --git a/tests/webtbs/tw855.pp b/tests/webtbs/tw855.pp new file mode 100644 index 0000000000..181f0ca417 --- /dev/null +++ b/tests/webtbs/tw855.pp @@ -0,0 +1,16 @@ +{$MODE objfpc} +{$R+} +type + TMyRec = record + x: Integer; + end; + TMyArray = array[LongWord] of TMyRec; + PMyArray = ^TMyArray; +var + a: PMyArray; + i: Integer; +begin + GetMem(a, SizeOf(TMyRec)); + i := 0; + a^[i].x := 1; +end. \ No newline at end of file diff --git a/tests/webtbs/tw859.pp b/tests/webtbs/tw859.pp new file mode 100644 index 0000000000..a219da2159 --- /dev/null +++ b/tests/webtbs/tw859.pp @@ -0,0 +1,31 @@ +type + TBoolArray = array [0..1048576] of Boolean; + +procedure OrBoolProc(var Vector1; const Vector2; Count: Integer); +var + I: Integer; +begin + for I:=0 to Count - 1 do + TBoolArray(Vector1)[I]:=TBoolArray(Vector1)[I] or TBoolArray(Vector2)[I]; +end; + +var + A, B: array [0..10] of Boolean; + I: Integer; +const + error : boolean = false; +begin + for I:=0 to High(A) do A[I]:=False; + for I:=0 to High(B) do B[I]:=True; + OrBoolProc(A, B, SizeOf(A)); + for I:=0 to High(A) do + begin + write(A[I], ' '); + if not A[i] then + error:=true; + end; + writeln; + if error then + Halt(1); + +end. \ No newline at end of file diff --git a/tests/webtbs/tw866.pp b/tests/webtbs/tw866.pp new file mode 100644 index 0000000000..09f98e2a75 --- /dev/null +++ b/tests/webtbs/tw866.pp @@ -0,0 +1,17 @@ +{$mode objfpc} +Type + ts = set of (tse); + ts2 = set of (t1,t2); + enum3 = (tm1:=-1,t0,tp1); + ts3 = set of t0 .. tp1; + var + f:ts; + f2 : ts2; + f3 : ts3; + +begin + f2:=f2+[t2]; + f2:=f2+[t1]; + f:=f+[tse]; // compiler says that set elements are not compatible + { f3:=[tm1];} +end. \ No newline at end of file diff --git a/tests/webtbs/tw868.pp b/tests/webtbs/tw868.pp new file mode 100644 index 0000000000..dd7949daa2 --- /dev/null +++ b/tests/webtbs/tw868.pp @@ -0,0 +1,51 @@ +{$mode objfpc} +{$H+} +type + TTreeData = record + Key: String; + Data: Integer; + end; + + TNode = class + data: TTreeData; + end; + + TStrIntDic = class + FNode: TNode; + destructor Destroy; override; + procedure Add(const Key: String; Data: Integer); + end; + +destructor TStrIntDic.Destroy; +begin + FNode.Free; + inherited Destroy; +end; + +procedure TStrIntDic.Add(const Key: String; Data: Integer); +var + T: TTreeData; +begin + T.Key:=Key; + T.Data:=Data; + FNode:=TNode.Create; + FNode.data:=T; +end; + +procedure Test; +var + SD: TStrIntDic; +begin + SD:=TStrIntDic.Create; + try + SD.Add('asdf', 2); + finally + SD.Free; + end; +end; + +begin + Test; + write('Test for bug 868 completed.'); + {readln;} +end. \ No newline at end of file diff --git a/tests/webtbs/tw869.pp b/tests/webtbs/tw869.pp new file mode 100644 index 0000000000..6700374792 --- /dev/null +++ b/tests/webtbs/tw869.pp @@ -0,0 +1,24 @@ +program prueba; +uses crt; +var + resultado,exponente:integer; +begin + exponente := 3; + resultado := -1 ** exponente; + writeln (resultado); + if resultado<>-1 then + Halt(1); + exponente := 4; + resultado := -(1 ** exponente); + writeln (resultado); + if resultado<>-1 then + Halt(1); + resultado := (-1) ** exponente; + writeln (resultado); + if resultado<>1 then + Halt(1); + resultado := -1 ** exponente; + writeln (resultado); + if resultado<>-1 then + Halt(1); +end. \ No newline at end of file diff --git a/tests/webtbs/tw870.pp b/tests/webtbs/tw870.pp new file mode 100644 index 0000000000..d62a1aac2e --- /dev/null +++ b/tests/webtbs/tw870.pp @@ -0,0 +1,21 @@ +{$mode objfpc} +uses sysUtils; + + type + t = object + f:integer; + function m: AnsiString; + end; + + function t.m: AnsiString; + begin + result:=IntToStr(f); + end; + + var ti:t; + +begin + ti.f:=1; // no vmt for t - constructor call is not needed + writeln(format('%s', [ti.m])); // this works + writeln(format('%s, %s', [ti.m, ti.m])); // this does not - the same story with classes +end. \ No newline at end of file diff --git a/tests/webtbs/tw873.pp b/tests/webtbs/tw873.pp new file mode 100644 index 0000000000..20937840ee --- /dev/null +++ b/tests/webtbs/tw873.pp @@ -0,0 +1,41 @@ +{$mode objfpc} +program Teste; + +// Compile it using the Delphi extensions +// directive. + +type + TObject = class + private + procedure SetValue(v: integer); + public + fx: integer; + Constructor Create; + Destructor Destroy; + property x: integer read fx write SetValue; + end; + +var + Obj: TObject; + +Constructor TObject.Create; +begin + fx := 0; +end; + +Destructor TObject.Destroy; +begin +end; + +procedure TObject.SetValue(v: integer); +begin + fx := v + 2; +end; + +begin + writeln('This will be printed'); + Obj := TObject.Create; + writeln('This won''t.'); +end. + + diff --git a/tests/webtbs/tw873a.pp b/tests/webtbs/tw873a.pp new file mode 100644 index 0000000000..3a1fc61a70 --- /dev/null +++ b/tests/webtbs/tw873a.pp @@ -0,0 +1,40 @@ +{$mode objfpc} +program Teste; + +// Compile it using the Delphi extensions +// directive. + +type + TObjectB = class + private + procedure SetValue(v: integer); + public + fx: integer; + Constructor Create; + Destructor Destroy; + property x: integer read fx write SetValue; + end; + +var + Obj: TObjectB; + +Constructor TObjectB.Create; +begin + fx := 0; +end; + +Destructor TObjectB.Destroy; +begin +end; + +procedure TObjectB.SetValue(v: integer); +begin + fx := v + 2; +end; + +begin + writeln('This will be printed'); + Obj := TObjectB.Create; + writeln('This won''t.'); +end. + diff --git a/tests/webtbs/tw876.pp b/tests/webtbs/tw876.pp new file mode 100644 index 0000000000..041543c41d --- /dev/null +++ b/tests/webtbs/tw876.pp @@ -0,0 +1,30 @@ +{ %OPT=-pg } + +program test1; +var + i,j:longint; + l : longint; + a,b:double; + +procedure test; +begin + b:=1.0; + i:=2; + a:=b+3; + j:=i div 2; +end; + +procedure test2; +begin + test; + Writeln('i=',i,' l=',l); +end; + +begin + for l:=1 to 10000 do + begin + test; + test2; + test; + end; +end. \ No newline at end of file diff --git a/tests/webtbs/tw877.pp b/tests/webtbs/tw877.pp new file mode 100644 index 0000000000..75f6935d0d --- /dev/null +++ b/tests/webtbs/tw877.pp @@ -0,0 +1,26 @@ +{$mode objfpc} + +program testlist; +uses + Sysutils, + Classes; +var + l: TList; + IsCaught: boolean; + +begin + L:= TList.Create; + IsCaught:=false; + Try + WriteLn(LongInt(L[0]));{L[0] not exist, ==> access violation} + L.Free; + Except + on eListError do + IsCaught:=true; + end; + If not IsCaught then + begin + Writeln('Error in TList'); + Halt(1); + end; +end. diff --git a/tests/webtbs/tw879.pp b/tests/webtbs/tw879.pp new file mode 100644 index 0000000000..50f88c8891 --- /dev/null +++ b/tests/webtbs/tw879.pp @@ -0,0 +1,13 @@ +PROGRAM TEST; +TYPE + ta = ARRAY[3..8] OF word; +VAR + aa : ^ta; + i : word; +BEGIN + NEW(aa); + FOR i:=LOW(aa^) TO HIGH(aa^) DO + aa^[i]:=0; +END. + + diff --git a/tests/webtbs/tw881.pp b/tests/webtbs/tw881.pp new file mode 100644 index 0000000000..aa5d789e8c --- /dev/null +++ b/tests/webtbs/tw881.pp @@ -0,0 +1,14 @@ +PROGRAM TEST; +TYPE + byteSet = SET OF 0..7; + booleanArray = ARRAY[0..HIGH(word) DIV 8] OF byteSet; + booleanArrayPointer = ^booleanArray; + +PROCEDURE SetBooleanArray( CONST p : booleanArrayPointer; + CONST index : word ); +BEGIN + INCLUDE(p^[index DIV 8],index MOD 8) +END; + +BEGIN +END. diff --git a/tests/webtbs/tw882.pp b/tests/webtbs/tw882.pp new file mode 100644 index 0000000000..b26b45db7c --- /dev/null +++ b/tests/webtbs/tw882.pp @@ -0,0 +1,30 @@ +{$D+,E-,I+,L+,P-,Q+,R+,S+,T+,V+,X+,Y+} +{$M 8192,0,655360} +PROGRAM TEST; +CONST + maxBlockSize = 1 SHL 13; +TYPE + byteBlock = ARRAY[0..PRED(maxBlockSize)] OF byte; +VAR + bb0 : ^byteBlock; +TYPE + rec = RECORD i1, len : word END; +VAR + mr : rec; + bw : word; +BEGIN + NEW(bb0); + mr.i1:=0; mr.len:=0; + bb0^[0] := 1; + bb0^[1] := 2; + {$T+} + bw:=word(Addr(bb0^[mr.i1])^); + if bw <> 1 then + halt(1); + {$T-} + bw:=word(Addr(bb0^[mr.i1])^); + if bw <> (2 shl 8 + 1) then + halt(1); +END +. + diff --git a/tests/webtbs/tw890.pp b/tests/webtbs/tw890.pp new file mode 100644 index 0000000000..495d328e13 --- /dev/null +++ b/tests/webtbs/tw890.pp @@ -0,0 +1,43 @@ +{$ifdef FPC} + {$MODE TP} +{$endif FPC} + +unit tbug890; + +INTERFACE + +procedure GetScreenLine(const x: Integer); + +function dummy(const x : integer) : integer; +function dummy2(var x : integer) : integer; +function dummystr(x : integer) : string; + +IMPLEMENTATION + + +procedure GetScreenLine; +begin +end; + +function dummy2; +begin + dummy2:=x; + x:=0; +end; + +function dummystr; +var + s : string; +begin + str(x,s); + dummystr:=s; +end; + +{ this one is refused by BP :( } +function dummy : integer; +begin + dummy:=x; +end; + +begin +end. \ No newline at end of file diff --git a/tests/webtbs/tw891.pp b/tests/webtbs/tw891.pp new file mode 100644 index 0000000000..6c2bb4883c --- /dev/null +++ b/tests/webtbs/tw891.pp @@ -0,0 +1,39 @@ +{ this declaration: ;} +{$ifdef FPC} + {$mode TP} +{$endif} + var + name_a : packed array[0..255] of char; + +const + name_b : PChar = 't'; + +begin + { the FPC compiler (0.99.14a) will refuse to compile + the line ; } + name_a[0]:='x'; + name_a[1]:=#0; + if (name_b <> name_a) then + begin + writeln(' a and b are different'); + end + else + writeln('address of name_a and name_b are equal'); + { while it works under Turbo Pascal (TP). ;} + name_b:=@name_a; + if name_a<>name_b then + begin + Writeln('Wrong result'); + Halt(1); + end; +{$ifdef FPC} + if (name_b <> PChar(name_a)) then + writeln(' a and b are different'); + { is a legal FPC line, but illegal in TP.} +{$endif} + { I used ; } + if (name_b <> PChar(@name_a)) then + writeln(' a and b are different'); + {because it seems to work for both compiler.} + +end. \ No newline at end of file diff --git a/tests/webtbs/tw892.pp b/tests/webtbs/tw892.pp new file mode 100644 index 0000000000..cf83496232 --- /dev/null +++ b/tests/webtbs/tw892.pp @@ -0,0 +1,18 @@ + + +{$asmmode intel} + +var + i,j : longint; + +begin + i:=56; + { this should work as ss and ds have the same selector value } + asm + segss + mov eax,dword ptr [i] + mov dword ptr [j],eax + end; + if i<>j then + Halt(1); +end. \ No newline at end of file diff --git a/tests/webtbs/tw893.pp b/tests/webtbs/tw893.pp new file mode 100644 index 0000000000..aedcd10ffa --- /dev/null +++ b/tests/webtbs/tw893.pp @@ -0,0 +1,17 @@ +{$asmmode intel} +type + BugObject = object + Fld: word; + procedure WontCompile; + end; + +procedure BugObject.WontCompile; +begin + asm + xor ax, ax + mov fld, ax + end; +end; + +begin +end. diff --git a/tests/webtbs/tw895.pp b/tests/webtbs/tw895.pp new file mode 100644 index 0000000000..7d096b022a --- /dev/null +++ b/tests/webtbs/tw895.pp @@ -0,0 +1,14 @@ +program bug; + +begin + {$I-} + mkdir('test895'); + InOutRes:=0; + {$I+} + writeln('This is a test'); + {$I-} + mkdir('test895'); + InOutRes:=0; + {$I+} + writeln('This is a test'); +end. \ No newline at end of file diff --git a/tests/webtbs/tw896.pp b/tests/webtbs/tw896.pp new file mode 100644 index 0000000000..86552230c6 --- /dev/null +++ b/tests/webtbs/tw896.pp @@ -0,0 +1,34 @@ + +var + dat,dat2 : file of byte; + j : longint; + Buffer,Buffer2 : Array[0..2047] of byte; + +begin + for j:=0 to 2047 do + Buffer[j]:=j and $ff; + Assign(dat,'tbug896.txt'); + Rewrite(dat,1); + for j:= 0 to 2047 do + write (dat,Buffer[j]); + Close(dat); + Assign(dat2,'tbug896a.txt'); + Rewrite(dat2); + for j:= 0 to 2047 do + write (dat2,Buffer[j]); + Close(dat2); + Reset(dat); + Reset(dat2,1); + for j:=0 to 2047 do + begin + read(dat,Buffer[j]); + read(dat2,Buffer2[j]); + if Buffer[j]<>Buffer2[j] then + begin + Writeln('Error in typed file handling'); + Halt(1); + end; + end; + Close(dat); + close(dat2); +end. \ No newline at end of file diff --git a/tests/webtbs/tw900.pp b/tests/webtbs/tw900.pp new file mode 100644 index 0000000000..8a5fb3cc9f --- /dev/null +++ b/tests/webtbs/tw900.pp @@ -0,0 +1,14 @@ +program Test; + +uses strings; + +var Str1 : PChar; + +begin + GetMem(Str1,256); + StrPCopy (Str1, ParamStr(0)); + writeln ('Arg 0 is "',Str1,'"'); + StrPCopy (Str1, ParamStr(1)); + writeln ('Arg 1 is "',Str1,'"'); + FreeMem(Str1,256); +end. \ No newline at end of file diff --git a/tests/webtbs/tw902.pp b/tests/webtbs/tw902.pp new file mode 100644 index 0000000000..86cecdda98 --- /dev/null +++ b/tests/webtbs/tw902.pp @@ -0,0 +1,12 @@ +uses + dos; +begin + writeln; + writeln(fsearch('c:\command.com', '')); + { here you get the full path in BP7, but nothing in FPC } + writeln(fsearch('c:\command.com', 'c:\a')); + { I really would not consider this as a bug !! } + { this use of fsearch is not document in BP PM } + if fsearch('c:\command.com', '')<>fsearch('c:\command.com', 'c:\a') then + Writeln('fsearch result is not BP compatible'); +end. \ No newline at end of file diff --git a/tests/webtbs/tw909.pp b/tests/webtbs/tw909.pp new file mode 100644 index 0000000000..9aa3aa9d70 --- /dev/null +++ b/tests/webtbs/tw909.pp @@ -0,0 +1,7 @@ +uses sysutils; + var r:array[0..3] of real; +begin + r[0]:=1; r[1]:=2; r[2]:=3; r[3]:=4; + // the following is supposed to print "1, 2, 3, 4", instead it prints "4, 4, 4, 4" + writeln(format('%g, %g, %g, %g',[r[0],r[1],r[2],r[3]])); +end. \ No newline at end of file diff --git a/tests/webtbs/tw911.pp b/tests/webtbs/tw911.pp new file mode 100644 index 0000000000..19f1d46b8e --- /dev/null +++ b/tests/webtbs/tw911.pp @@ -0,0 +1,8 @@ +Function Log(const b,r:real):real; +begin + log:=ln(r)/ln(b); +end; + +begin + log(2,5); +end. \ No newline at end of file diff --git a/tests/webtbs/tw912.pp b/tests/webtbs/tw912.pp new file mode 100644 index 0000000000..db5ef30c78 --- /dev/null +++ b/tests/webtbs/tw912.pp @@ -0,0 +1,44 @@ +const + BufSize = 2048; + +var + f : file; + res : longint; + buf : array [0..BufSize-1] of byte; + result : word; +begin +assign(f,paramstr(0)); +{$I-} +reset(f,1); +res:=IOResult; +{$I+} +if res=0 then + Writeln('It is possible to open the executable in Read/Write mode') +else + begin + filemode:=0; + {$I-} + reset(f,1); + res:=IOResult; + {$I+} + if res=0 then + Writeln('It is only possible to open the executable in Read mode') + else + Writeln('It is not possible to open the executable in Read mode'); + end; +if res=0 then + begin +{$I-} + blockread(f,buf,sizeof(buf),result); + res:=IOResult; +{$I+} + if res<>0 then + Writeln('Problem reading executable'); + if res=0 then + close(f) + else + RunError(res); + end +else + RunError(res); +end. \ No newline at end of file diff --git a/tests/webtbs/tw918.pp b/tests/webtbs/tw918.pp new file mode 100644 index 0000000000..6baf4796ef --- /dev/null +++ b/tests/webtbs/tw918.pp @@ -0,0 +1,15 @@ +program test; + +procedure Test1; +var + a: Integer; + + procedure Test2; + begin + a:= 0; + end; +begin +end; + +begin +end. diff --git a/tests/webtbs/tw919.pp b/tests/webtbs/tw919.pp new file mode 100644 index 0000000000..0576469d61 --- /dev/null +++ b/tests/webtbs/tw919.pp @@ -0,0 +1,15 @@ + var i:integer; +{$i386_intel} +{ "mov i,1" + is like + "mov word ptr [i],1" + or + movw i,$1 in ATT syntax } + +begin + asm + mov i, 1 + end; + if i <> 1 then + halt(1); +end. \ No newline at end of file diff --git a/tests/webtbs/tw922.pp b/tests/webtbs/tw922.pp new file mode 100644 index 0000000000..681aee0ea9 --- /dev/null +++ b/tests/webtbs/tw922.pp @@ -0,0 +1,24 @@ +program test; + +{$ifdef win32} +uses + windows; +{$endif } + +procedure write1( var charbuf:string); +begin + Writeln(Charbuf); +end; + +procedure write2( var charbuf:string; attrbuf:array of word); +begin + Writeln(Charbuf); +end; + +var chars : String[82]; + attrs : array [1..162] of word; +begin + Chars := 'Das ist ein Test, den ich gerade schreibe'; + write1(chars); + write2(chars,attrs); +end. diff --git a/tests/webtbs/tw925.pp b/tests/webtbs/tw925.pp new file mode 100644 index 0000000000..58ec24a714 --- /dev/null +++ b/tests/webtbs/tw925.pp @@ -0,0 +1,23 @@ +{$asmmode intel} + +{$ifdef go32v2} + PROCEDURE Cursor(Form: word);assembler; + asm + mov cx,word ptr[Form] + and cx,1F1Fh + mov ah,1 + int 10h + end; +{$else not go32v2} + { no interrupt call on other targets } + procedure cursor(form : word);assembler; + asm + mov cx,word ptr[Form] + and cx,1F1Fh + mov ah,1 + end; +{$endif go32v2} + +begin + Cursor($11F); +end. \ No newline at end of file diff --git a/tests/webtbs/tw932.pp b/tests/webtbs/tw932.pp new file mode 100644 index 0000000000..ca1a389d59 --- /dev/null +++ b/tests/webtbs/tw932.pp @@ -0,0 +1,16 @@ +program test; + +{$ASMMODE Intel } + +procedure TestProc; +const + TestConst: String = 'Test'; +begin + asm + mov edi, offset TestConst + end; +end; + +begin + TestProc; +end. \ No newline at end of file diff --git a/tests/webtbs/tw934.pp b/tests/webtbs/tw934.pp new file mode 100644 index 0000000000..4f3afcb12e --- /dev/null +++ b/tests/webtbs/tw934.pp @@ -0,0 +1,19 @@ +{ %OPT=-Or } +{$mode objfpc} + Type + t = class(TObject) + f1,f2:dword; + constructor Init(p1, p2:dword); + end; + + constructor t.Init(p1, p2:dword); + begin + f1:=p1; f2:=p2; + end; + var ti:t; +begin + ti:=t.Init(1,2); + writeln(ti.f1, ', ', ti.f2); // prints garbage instead of t2 + if ti.f2<>2 then + Halt(1); +end. \ No newline at end of file diff --git a/tests/webtbs/tw935.pp b/tests/webtbs/tw935.pp new file mode 100644 index 0000000000..fbf479644e --- /dev/null +++ b/tests/webtbs/tw935.pp @@ -0,0 +1,23 @@ +{$inline on} + +procedure test(v:boolean); + + procedure notice(s:string);inline; + begin + writeln(s); + end; + +begin +if v then notice('this string vanishes.'); +writeln('"test" main body executed.'); +end; + + + +begin +writeln('testing with True...'); +test(true); +writeln; +writeln('testing with False...'); +test(false); +end. \ No newline at end of file diff --git a/tests/webtbs/tw937.pp b/tests/webtbs/tw937.pp new file mode 100644 index 0000000000..ed6dc37ad1 --- /dev/null +++ b/tests/webtbs/tw937.pp @@ -0,0 +1,17 @@ +program test_0_to_power_6; + +uses + crt; +var + result,number,exponent : integer; +begin + number := 0; + exponent := 6; + result := number ** exponent; + write (result); + if result<>0 then + begin + Writeln(' 0 ** 6 should be equal to 0'); + Halt(1); + end; +end. \ No newline at end of file diff --git a/tests/webtbs/tw938.pp b/tests/webtbs/tw938.pp new file mode 100644 index 0000000000..bb00434211 --- /dev/null +++ b/tests/webtbs/tw938.pp @@ -0,0 +1,74 @@ +Program test_operator; +type + Vector = record + X,Y,Z : extended; + end; + Matrix = array [1..4,1..4] of extended; + +Const + IDENTITYMATRIX : Matrix = + ( (1,0,0,0), + (0,1,0,0), + (0,0,1,0), + (0,0,0,1)); +{...} + +function NewVector (ax,ay,az : extended) : Vector; +begin + NewVector.X:=ax; + NewVector.Y:=ay; + NewVector.Z:=az; +end; + +operator * (V : Vector;Value : extended) Result : Vector; + begin + Result.X:=Result.X*Value; + Result.Y:=Result.Y*Value; + Result.Z:=Result.Z*Value; + end; +{...} +operator * (Value : extended;V : Vector) Result : Vector; + begin + Result.X:=Result.X*Value; + Result.Y:=Result.Y*Value; + Result.Z:=Result.Z*Value; + end; +{...} + + +operator * (M : Matrix;Value : extended) Result : Matrix; + var i,j : longint; + begin + for i:=1 to 4 do + for j:=1 to 4 do + Result[i,j]:=M[i,j]*Value; + end; +{...} +operator * (Value : extended;M : Matrix) Result : Matrix; + var i,j : longint; + begin + for i:=1 to 4 do + for j:=1 to 4 do + Result[i,j]:=M[i,j]*Value; + end; +{...} + +var + V1, V2 : Vector; + M1, M2 : Matrix; + +begin + V1 := NewVector (1,1,1); + V2 := V1 * 2; + { Everything ok } + + + M2 := IDENTITYMATRIX; + M1 := M2 * 2; + M1 := IDENTITYMATRIX * 2; + M2 := IDENTITYMATRIX * 4; + { Error: Incompatible types: got "E3MATRIX" expected "LONGINT" in both rows. This doesn't happen if I use 2.0 and 4.0 values. } + + + {...} +end. diff --git a/tests/webtbs/tw944.pp b/tests/webtbs/tw944.pp new file mode 100644 index 0000000000..33f1d15426 --- /dev/null +++ b/tests/webtbs/tw944.pp @@ -0,0 +1,26 @@ +{$ifdef TP} +{$N+} +{$endif TP} +PROGRAM fadd_bug; +VAR x,y,z,t: double; +BEGIN +x:=4.5; +y:=5.5; +{$ifndef TP} +{$asmmode intel} +{$endif TP} +asm + fld x + fld y + fadd + fstp z +end; +t:=x+y; +if (z<>10.0) or (z<>t) then + begin + Writeln('Error in FADD handling'); + Halt(1); + end +else + Writeln('FADD assembler instruction works'); +END. \ No newline at end of file diff --git a/tests/webtbs/tw947.pp b/tests/webtbs/tw947.pp new file mode 100644 index 0000000000..4b59eca603 --- /dev/null +++ b/tests/webtbs/tw947.pp @@ -0,0 +1,59 @@ +{$mode objfpc} + +var + last,lastt2 : integer; + +type + T1 = class + procedure SomeMethod(Param: Integer); virtual; + end; + + T2 = class(T1) + procedure SomeMethod(Param: Integer); override; + procedure InheritedMethod(Param: Integer); + destructor Destroy; override; + end; + +procedure T1.SomeMethod(Param: Integer); +begin + last:=Param; + writeln('T1 ', Param); +end; + +procedure T2.InheritedMethod(Param: Integer); +begin + inherited SomeMethod(Param); +end; + +procedure T2.SomeMethod(Param: Integer); +begin + lastt2:=param; + writeln('T2 ', Param); +end; + +destructor T2.Destroy; +begin + SomeMethod(3); + inherited SomeMethod(2); + inherited Destroy; +end; + +var + A: T2; +begin + Last:=0; + lastt2:=0; + A:=T2.Create; + A.SomeMethod(1); { Ok } + if lastt2<>1 then + Halt(1); + A.InheritedMethod(4); { Ok } + if last<>4 then + Halt(1); + A.Free; { error } + if last<>2 then + Halt(1); + if lastt2<>3 then + Halt(1); + Writeln('Bug with calling inherited in destructors solved'); +end. \ No newline at end of file diff --git a/tests/webtbs/tw961.pp b/tests/webtbs/tw961.pp new file mode 100644 index 0000000000..5c04a530b6 --- /dev/null +++ b/tests/webtbs/tw961.pp @@ -0,0 +1,32 @@ +{ older ppc386 only define cpu86 } +{$ifdef cpu86} +{$define cpui386} +{$endif cpu86} +var + x,y : byte; + z : longint; +{$asmmode intel} + +procedure test(var x : byte); +begin + x:=5; +{$ifdef cpui386} + asm + mov edi,$12345678 + mov edi,x + mov dword ptr [edi],78 + end; +{$else cpui386} + x:=$78; +{$endif cpui386} +end; + +begin + x:=34; + test(x); + if x<>78 then + begin + Writeln('Problem !!'); + Halt(1); + end; +end. \ No newline at end of file diff --git a/tests/webtbs/tw966.pp b/tests/webtbs/tw966.pp new file mode 100644 index 0000000000..18d6af4644 --- /dev/null +++ b/tests/webtbs/tw966.pp @@ -0,0 +1,81 @@ +{ Source provided for Free Pascal Bug Report 966 } +{$i-} +{$ifdef linux} +{$define has_sockets} +{$endif linux} +{$ifdef win32} +{$define has_sockets} +{$endif win32} + +{$ifdef has_sockets} +uses +{$ifdef linux} + linux, +{$else} + crt, +{$endif} + Sockets; +Var + S : Longint ; Sin,Sout: Text; + Temp, Temp2 : Char; + i : longint; + +const + isocket: TInetSockAddr= ( + Family:AF_INET; + Port:$1500; + Addr:((93*256+36)*256+161)*256+130); + {*** ftp 130.161.36.93 i.e. ftp.freepascal.org } + { FIXME: it would be much better to have the number + through a name server but I don't know how to do this ! PM } + + procedure perror(const S: string); + begin + writeln(S,SocketError); + halt(100) ; + end; + + procedure read_to_eof; + var + temp2 : char; + begin +{$ifdef linux} + while selecttext(sin,1)>0 do + begin + read(Sin,Temp2); + write(Temp2); + end; +{$else} + repeat until not eof(sin); + while not eof(sin) do + begin + read(Sin,Temp2); + write(Temp2); + delay(1); + end; +{$endif} + end; + +begin + S:=Socket(AF_INET,SOCK_STREAM,0); + if SocketError<>0 then Perror('Client : Socket : '); + WriteLn('*1'); + if not Connect(s,isocket,sin,sout)then Perror('Client : Socket : '); + WriteLn('*2'); + ReWrite(Sout); Reset(Sin); + WriteLn('*3'); + read_to_eof; + Writeln('Sending "USER anonymous#10"'); + Write(Sout,'USER anonymous'#10); + read_to_eof; + Writeln('Sending "PASS core@freepascal.org#10"'); + Write(Sout,'PASS core@freepascal.org'#10); + read_to_eof; + Writeln('Sending "QUIT#10"'); + Write(Sout,'QUIT'#10); + read_to_eof; + shutdown(s,2); close(sin); close(sout); +{$else : not has_sockets} + Writeln('No sockets unit for this target'); +{$endif has_sockets} +end. \ No newline at end of file diff --git a/tests/webtbs/tw976.pp b/tests/webtbs/tw976.pp new file mode 100644 index 0000000000..107bd76f0f --- /dev/null +++ b/tests/webtbs/tw976.pp @@ -0,0 +1,41 @@ +{ Source provided for Free Pascal Bug Report 976 } +{ Submitted by } +{ e-mail: } +Program Test_Me; + +type PDouble = ^Double; +var A, B: PDouble; + x: Double; + +Operator + (x: Double; A: PDouble) B: Double; + + begin + B := x + A^; + end; + +{ This was wrong because B value is not initialized !! +Operator + (x: Single; A: PDouble) B: PDouble; + + begin + B^ := x + A^; + end; } + +begin +new (A); +new (B); +x := 0.5; +A^ := x; + +{--- Addition "Double + Double": OK} +B^ := x + A^; +writeln (B^:4:2); +if B^<>1.0 then + Halt(1); +{---Identical error messages for addition "PDouble + Double" and "Double + PDouble"} +{---in spite of overloaded + operator} +// B := A + x; +B^ := x + A; +writeln (B^:4:2); +if B^<>1.0 then + Halt(1); +end. \ No newline at end of file